summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog.104
-rw-r--r--lisp/ChangeLog.112
-rw-r--r--lisp/ChangeLog.124
-rw-r--r--lisp/ChangeLog.134
-rw-r--r--lisp/ChangeLog.144
-rw-r--r--lisp/ChangeLog.1514
-rw-r--r--lisp/ChangeLog.1626
-rw-r--r--lisp/ChangeLog.1720
-rw-r--r--lisp/ChangeLog.32
-rw-r--r--lisp/ChangeLog.62
-rw-r--r--lisp/ChangeLog.76
-rw-r--r--lisp/ChangeLog.84
-rw-r--r--lisp/ChangeLog.910
-rw-r--r--lisp/Makefile.in68
-rw-r--r--lisp/abbrev.el191
-rw-r--r--lisp/align.el187
-rw-r--r--lisp/allout-widgets.el355
-rw-r--r--lisp/allout.el693
-rw-r--r--lisp/ansi-color.el99
-rw-r--r--lisp/apropos.el267
-rw-r--r--lisp/arc-mode.el1200
-rw-r--r--lisp/array.el108
-rw-r--r--lisp/auth-source-pass.el67
-rw-r--r--lisp/auth-source.el139
-rw-r--r--lisp/autoarg.el11
-rw-r--r--lisp/autoinsert.el5
-rw-r--r--lisp/autorevert.el253
-rw-r--r--lisp/avoid.el38
-rw-r--r--lisp/battery.el676
-rw-r--r--lisp/bindings.el198
-rw-r--r--lisp/bookmark.el614
-rw-r--r--lisp/bs.el10
-rw-r--r--lisp/buff-menu.el254
-rw-r--r--lisp/button.el106
-rw-r--r--lisp/calc/calc-aent.el55
-rw-r--r--lisp/calc/calc-alg.el19
-rw-r--r--lisp/calc/calc-arith.el91
-rw-r--r--lisp/calc/calc-bin.el90
-rw-r--r--lisp/calc/calc-comb.el70
-rw-r--r--lisp/calc/calc-cplx.el2
-rw-r--r--lisp/calc/calc-embed.el96
-rw-r--r--lisp/calc/calc-ext.el175
-rw-r--r--lisp/calc/calc-fin.el2
-rw-r--r--lisp/calc/calc-forms.el84
-rw-r--r--lisp/calc/calc-frac.el7
-rw-r--r--lisp/calc/calc-funcs.el31
-rw-r--r--lisp/calc/calc-graph.el53
-rw-r--r--lisp/calc/calc-help.el88
-rw-r--r--lisp/calc/calc-incom.el2
-rw-r--r--lisp/calc/calc-keypd.el84
-rw-r--r--lisp/calc/calc-lang.el428
-rw-r--r--lisp/calc/calc-macs.el15
-rw-r--r--lisp/calc/calc-map.el91
-rw-r--r--lisp/calc/calc-math.el102
-rw-r--r--lisp/calc/calc-menu.el6
-rw-r--r--lisp/calc/calc-misc.el38
-rw-r--r--lisp/calc/calc-mode.el8
-rw-r--r--lisp/calc/calc-mtx.el10
-rw-r--r--lisp/calc/calc-nlfit.el98
-rw-r--r--lisp/calc/calc-poly.el21
-rw-r--r--lisp/calc/calc-prog.el146
-rw-r--r--lisp/calc/calc-rewr.el121
-rw-r--r--lisp/calc/calc-rules.el2
-rw-r--r--lisp/calc/calc-sel.el32
-rw-r--r--lisp/calc/calc-stat.el2
-rw-r--r--lisp/calc/calc-store.el98
-rw-r--r--lisp/calc/calc-stuff.el13
-rw-r--r--lisp/calc/calc-trail.el2
-rw-r--r--lisp/calc/calc-undo.el2
-rw-r--r--lisp/calc/calc-units.el50
-rw-r--r--lisp/calc/calc-vec.el49
-rw-r--r--lisp/calc/calc-yank.el162
-rw-r--r--lisp/calc/calc.el151
-rw-r--r--lisp/calc/calcalg2.el689
-rw-r--r--lisp/calc/calcalg3.el75
-rw-r--r--lisp/calc/calccomp.el383
-rw-r--r--lisp/calc/calcsel2.el3
-rw-r--r--lisp/calculator.el73
-rw-r--r--lisp/calendar/cal-bahai.el34
-rw-r--r--lisp/calendar/cal-china.el45
-rw-r--r--lisp/calendar/cal-coptic.el56
-rw-r--r--lisp/calendar/cal-dst.el26
-rw-r--r--lisp/calendar/cal-french.el258
-rw-r--r--lisp/calendar/cal-hebrew.el68
-rw-r--r--lisp/calendar/cal-html.el19
-rw-r--r--lisp/calendar/cal-islam.el25
-rw-r--r--lisp/calendar/cal-iso.el21
-rw-r--r--lisp/calendar/cal-julian.el48
-rw-r--r--lisp/calendar/cal-mayan.el10
-rw-r--r--lisp/calendar/cal-menu.el10
-rw-r--r--lisp/calendar/cal-move.el17
-rw-r--r--lisp/calendar/cal-persia.el30
-rw-r--r--lisp/calendar/cal-tex.el85
-rw-r--r--lisp/calendar/cal-x.el2
-rw-r--r--lisp/calendar/calendar.el97
-rw-r--r--lisp/calendar/diary-lib.el98
-rw-r--r--lisp/calendar/holidays.el17
-rw-r--r--lisp/calendar/icalendar.el101
-rw-r--r--lisp/calendar/iso8601.el36
-rw-r--r--lisp/calendar/lunar.el44
-rw-r--r--lisp/calendar/parse-time.el162
-rw-r--r--lisp/calendar/solar.el16
-rw-r--r--lisp/calendar/time-date.el84
-rw-r--r--lisp/calendar/timeclock.el14
-rw-r--r--lisp/calendar/todo-mode.el140
-rw-r--r--lisp/case-table.el40
-rw-r--r--lisp/cdl.el2
-rw-r--r--lisp/cedet/ChangeLog.14
-rw-r--r--lisp/cedet/cedet-cscope.el13
-rw-r--r--lisp/cedet/cedet-files.el2
-rw-r--r--lisp/cedet/cedet-global.el11
-rw-r--r--lisp/cedet/cedet-idutils.el21
-rw-r--r--lisp/cedet/cedet.el41
-rw-r--r--lisp/cedet/data-debug.el143
-rw-r--r--lisp/cedet/ede.el104
-rw-r--r--lisp/cedet/ede/auto.el30
-rw-r--r--lisp/cedet/ede/autoconf-edit.el2
-rw-r--r--lisp/cedet/ede/base.el80
-rw-r--r--lisp/cedet/ede/config.el12
-rw-r--r--lisp/cedet/ede/cpp-root.el27
-rw-r--r--lisp/cedet/ede/custom.el69
-rw-r--r--lisp/cedet/ede/detect.el12
-rw-r--r--lisp/cedet/ede/dired.el13
-rw-r--r--lisp/cedet/ede/emacs.el54
-rw-r--r--lisp/cedet/ede/files.el59
-rw-r--r--lisp/cedet/ede/generic.el24
-rw-r--r--lisp/cedet/ede/linux.el6
-rw-r--r--lisp/cedet/ede/locate.el48
-rw-r--r--lisp/cedet/ede/make.el43
-rw-r--r--lisp/cedet/ede/makefile-edit.el2
-rw-r--r--lisp/cedet/ede/pconf.el29
-rw-r--r--lisp/cedet/ede/pmake.el87
-rw-r--r--lisp/cedet/ede/proj-archive.el6
-rw-r--r--lisp/cedet/ede/proj-aux.el2
-rw-r--r--lisp/cedet/ede/proj-comp.el46
-rw-r--r--lisp/cedet/ede/proj-elisp.el59
-rw-r--r--lisp/cedet/ede/proj-info.el9
-rw-r--r--lisp/cedet/ede/proj-misc.el2
-rw-r--r--lisp/cedet/ede/proj-obj.el15
-rw-r--r--lisp/cedet/ede/proj-prog.el6
-rw-r--r--lisp/cedet/ede/proj-scheme.el4
-rw-r--r--lisp/cedet/ede/proj-shared.el8
-rw-r--r--lisp/cedet/ede/proj.el36
-rw-r--r--lisp/cedet/ede/project-am.el122
-rw-r--r--lisp/cedet/ede/shell.el2
-rw-r--r--lisp/cedet/ede/simple.el6
-rw-r--r--lisp/cedet/ede/source.el4
-rw-r--r--lisp/cedet/ede/speedbar.el52
-rw-r--r--lisp/cedet/ede/srecode.el3
-rw-r--r--lisp/cedet/ede/system.el2
-rw-r--r--lisp/cedet/ede/util.el2
-rw-r--r--lisp/cedet/mode-local.el47
-rw-r--r--lisp/cedet/pulse.el117
-rw-r--r--lisp/cedet/semantic.el211
-rw-r--r--lisp/cedet/semantic/analyze.el38
-rw-r--r--lisp/cedet/semantic/analyze/complete.el16
-rw-r--r--lisp/cedet/semantic/analyze/debug.el27
-rw-r--r--lisp/cedet/semantic/analyze/fcn.el4
-rw-r--r--lisp/cedet/semantic/analyze/refs.el10
-rw-r--r--lisp/cedet/semantic/bovine.el33
-rw-r--r--lisp/cedet/semantic/bovine/c.el128
-rw-r--r--lisp/cedet/semantic/bovine/debug.el4
-rw-r--r--lisp/cedet/semantic/bovine/el.el79
-rw-r--r--lisp/cedet/semantic/bovine/gcc.el22
-rw-r--r--lisp/cedet/semantic/bovine/grammar.el16
-rw-r--r--lisp/cedet/semantic/bovine/make.el15
-rw-r--r--lisp/cedet/semantic/bovine/scm.el13
-rw-r--r--lisp/cedet/semantic/chart.el12
-rw-r--r--lisp/cedet/semantic/complete.el134
-rw-r--r--lisp/cedet/semantic/ctxt.el30
-rw-r--r--lisp/cedet/semantic/db-debug.el6
-rw-r--r--lisp/cedet/semantic/db-ebrowse.el55
-rw-r--r--lisp/cedet/semantic/db-el.el16
-rw-r--r--lisp/cedet/semantic/db-file.el37
-rw-r--r--lisp/cedet/semantic/db-find.el27
-rw-r--r--lisp/cedet/semantic/db-global.el19
-rw-r--r--lisp/cedet/semantic/db-javascript.el22
-rw-r--r--lisp/cedet/semantic/db-mode.el6
-rw-r--r--lisp/cedet/semantic/db-ref.el8
-rw-r--r--lisp/cedet/semantic/db-typecache.el28
-rw-r--r--lisp/cedet/semantic/db.el26
-rw-r--r--lisp/cedet/semantic/debug.el64
-rw-r--r--lisp/cedet/semantic/decorate.el11
-rw-r--r--lisp/cedet/semantic/decorate/include.el16
-rw-r--r--lisp/cedet/semantic/decorate/mode.el33
-rw-r--r--lisp/cedet/semantic/dep.el50
-rw-r--r--lisp/cedet/semantic/doc.el9
-rw-r--r--lisp/cedet/semantic/ede-grammar.el43
-rw-r--r--lisp/cedet/semantic/edit.el24
-rw-r--r--lisp/cedet/semantic/find.el6
-rw-r--r--lisp/cedet/semantic/format.el27
-rw-r--r--lisp/cedet/semantic/fw.el112
-rw-r--r--lisp/cedet/semantic/grammar-wy.el496
-rw-r--r--lisp/cedet/semantic/grammar.el228
-rw-r--r--lisp/cedet/semantic/grm-wy-boot.el503
-rw-r--r--lisp/cedet/semantic/html.el10
-rw-r--r--lisp/cedet/semantic/ia-sb.el36
-rw-r--r--lisp/cedet/semantic/ia.el16
-rw-r--r--lisp/cedet/semantic/idle.el259
-rw-r--r--lisp/cedet/semantic/imenu.el55
-rw-r--r--lisp/cedet/semantic/java.el73
-rw-r--r--lisp/cedet/semantic/lex-spp.el95
-rw-r--r--lisp/cedet/semantic/lex.el365
-rw-r--r--lisp/cedet/semantic/mru-bookmark.el20
-rw-r--r--lisp/cedet/semantic/sb.el6
-rw-r--r--lisp/cedet/semantic/scope.el18
-rw-r--r--lisp/cedet/semantic/senator.el38
-rw-r--r--lisp/cedet/semantic/sort.el29
-rw-r--r--lisp/cedet/semantic/symref.el15
-rw-r--r--lisp/cedet/semantic/symref/cscope.el4
-rw-r--r--lisp/cedet/semantic/symref/filter.el10
-rw-r--r--lisp/cedet/semantic/symref/global.el2
-rw-r--r--lisp/cedet/semantic/symref/grep.el25
-rw-r--r--lisp/cedet/semantic/symref/idutils.el4
-rw-r--r--lisp/cedet/semantic/symref/list.el44
-rw-r--r--lisp/cedet/semantic/tag-file.el15
-rw-r--r--lisp/cedet/semantic/tag-ls.el44
-rw-r--r--lisp/cedet/semantic/tag-write.el4
-rw-r--r--lisp/cedet/semantic/tag.el114
-rw-r--r--lisp/cedet/semantic/texi.el18
-rw-r--r--lisp/cedet/semantic/util-modes.el88
-rw-r--r--lisp/cedet/semantic/util.el24
-rw-r--r--lisp/cedet/semantic/wisent.el44
-rw-r--r--lisp/cedet/semantic/wisent/comp.el129
-rw-r--r--lisp/cedet/semantic/wisent/grammar.el45
-rw-r--r--lisp/cedet/semantic/wisent/java-tags.el15
-rw-r--r--lisp/cedet/semantic/wisent/javascript.el23
-rw-r--r--lisp/cedet/semantic/wisent/python.el18
-rw-r--r--lisp/cedet/semantic/wisent/wisent.el28
-rw-r--r--lisp/cedet/srecode.el4
-rw-r--r--lisp/cedet/srecode/args.el2
-rw-r--r--lisp/cedet/srecode/compile.el13
-rw-r--r--lisp/cedet/srecode/cpp.el7
-rw-r--r--lisp/cedet/srecode/ctxt.el2
-rw-r--r--lisp/cedet/srecode/dictionary.el21
-rw-r--r--lisp/cedet/srecode/document.el25
-rw-r--r--lisp/cedet/srecode/el.el2
-rw-r--r--lisp/cedet/srecode/expandproto.el2
-rw-r--r--lisp/cedet/srecode/extract.el20
-rw-r--r--lisp/cedet/srecode/fields.el33
-rw-r--r--lisp/cedet/srecode/filters.el2
-rw-r--r--lisp/cedet/srecode/find.el23
-rw-r--r--lisp/cedet/srecode/getset.el4
-rw-r--r--lisp/cedet/srecode/insert.el17
-rw-r--r--lisp/cedet/srecode/java.el2
-rw-r--r--lisp/cedet/srecode/map.el6
-rw-r--r--lisp/cedet/srecode/mode.el35
-rw-r--r--lisp/cedet/srecode/semantic.el10
-rw-r--r--lisp/cedet/srecode/srt-mode.el40
-rw-r--r--lisp/cedet/srecode/srt.el8
-rw-r--r--lisp/cedet/srecode/table.el6
-rw-r--r--lisp/cedet/srecode/template.el8
-rw-r--r--lisp/cedet/srecode/texi.el4
-rw-r--r--lisp/char-fold.el13
-rw-r--r--lisp/chistory.el23
-rw-r--r--lisp/cmuscheme.el114
-rw-r--r--lisp/color.el5
-rw-r--r--lisp/comint.el225
-rw-r--r--lisp/completion.el318
-rw-r--r--lisp/composite.el23
-rw-r--r--lisp/cus-dep.el55
-rw-r--r--lisp/cus-edit.el705
-rw-r--r--lisp/cus-face.el23
-rw-r--r--lisp/cus-start.el72
-rw-r--r--lisp/cus-theme.el133
-rw-r--r--lisp/custom.el180
-rw-r--r--lisp/dabbrev.el10
-rw-r--r--lisp/delim-col.el2
-rw-r--r--lisp/delsel.el13
-rw-r--r--lisp/descr-text.el52
-rw-r--r--lisp/desktop.el25
-rw-r--r--lisp/dframe.el78
-rw-r--r--lisp/dired-aux.el682
-rw-r--r--lisp/dired-x.el287
-rw-r--r--lisp/dired.el1359
-rw-r--r--lisp/dirtrack.el17
-rw-r--r--lisp/disp-table.el4
-rw-r--r--lisp/display-fill-column-indicator.el16
-rw-r--r--lisp/display-line-numbers.el21
-rw-r--r--lisp/dnd.el51
-rw-r--r--lisp/doc-view.el155
-rw-r--r--lisp/dom.el50
-rw-r--r--lisp/dos-fns.el2
-rw-r--r--lisp/dos-vars.el6
-rw-r--r--lisp/dos-w32.el10
-rw-r--r--lisp/double.el15
-rw-r--r--lisp/dynamic-setting.el11
-rw-r--r--lisp/ebuff-menu.el97
-rw-r--r--lisp/echistory.el77
-rw-r--r--lisp/edmacro.el94
-rw-r--r--lisp/ehelp.el8
-rw-r--r--lisp/electric.el9
-rw-r--r--lisp/elide-head.el12
-rw-r--r--lisp/emacs-lisp/advice.el99
-rw-r--r--lisp/emacs-lisp/autoload.el220
-rw-r--r--lisp/emacs-lisp/avl-tree.el61
-rw-r--r--lisp/emacs-lisp/backquote.el2
-rw-r--r--lisp/emacs-lisp/backtrace.el8
-rw-r--r--lisp/emacs-lisp/benchmark.el100
-rw-r--r--lisp/emacs-lisp/bindat.el986
-rw-r--r--lisp/emacs-lisp/byte-opt.el2242
-rw-r--r--lisp/emacs-lisp/byte-run.el240
-rw-r--r--lisp/emacs-lisp/bytecomp.el1255
-rw-r--r--lisp/emacs-lisp/cconv.el338
-rw-r--r--lisp/emacs-lisp/chart.el84
-rw-r--r--lisp/emacs-lisp/check-declare.el7
-rw-r--r--lisp/emacs-lisp/checkdoc.el71
-rw-r--r--lisp/emacs-lisp/cl-extra.el80
-rw-r--r--lisp/emacs-lisp/cl-generic.el144
-rw-r--r--lisp/emacs-lisp/cl-indent.el38
-rw-r--r--lisp/emacs-lisp/cl-lib.el116
-rw-r--r--lisp/emacs-lisp/cl-macs.el684
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el21
-rw-r--r--lisp/emacs-lisp/cl-print.el2
-rw-r--r--lisp/emacs-lisp/cl-seq.el15
-rw-r--r--lisp/emacs-lisp/comp-cstr.el1197
-rw-r--r--lisp/emacs-lisp/comp.el4231
-rw-r--r--lisp/emacs-lisp/copyright.el40
-rw-r--r--lisp/emacs-lisp/crm.el11
-rw-r--r--lisp/emacs-lisp/debug.el12
-rw-r--r--lisp/emacs-lisp/derived.el52
-rw-r--r--lisp/emacs-lisp/disass.el34
-rw-r--r--lisp/emacs-lisp/easy-mmode.el386
-rw-r--r--lisp/emacs-lisp/easymenu.el42
-rw-r--r--lisp/emacs-lisp/edebug.el971
-rw-r--r--lisp/emacs-lisp/eieio-base.el385
-rw-r--r--lisp/emacs-lisp/eieio-compat.el2
-rw-r--r--lisp/emacs-lisp/eieio-core.el180
-rw-r--r--lisp/emacs-lisp/eieio-custom.el14
-rw-r--r--lisp/emacs-lisp/eieio-opt.el15
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el18
-rw-r--r--lisp/emacs-lisp/eieio.el149
-rw-r--r--lisp/emacs-lisp/eldoc.el747
-rw-r--r--lisp/emacs-lisp/elint.el25
-rw-r--r--lisp/emacs-lisp/elp.el29
-rw-r--r--lisp/emacs-lisp/ert-x.el63
-rw-r--r--lisp/emacs-lisp/ert.el161
-rw-r--r--lisp/emacs-lisp/ewoc.el48
-rw-r--r--lisp/emacs-lisp/faceup.el5
-rw-r--r--lisp/emacs-lisp/find-func.el118
-rw-r--r--lisp/emacs-lisp/float-sup.el3
-rw-r--r--lisp/emacs-lisp/generator.el33
-rw-r--r--lisp/emacs-lisp/generic.el16
-rw-r--r--lisp/emacs-lisp/gv.el166
-rw-r--r--lisp/emacs-lisp/helper.el29
-rw-r--r--lisp/emacs-lisp/hierarchy.el579
-rw-r--r--lisp/emacs-lisp/inline.el2
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el46
-rw-r--r--lisp/emacs-lisp/lisp-mode.el207
-rw-r--r--lisp/emacs-lisp/lisp.el436
-rw-r--r--lisp/emacs-lisp/macroexp.el298
-rw-r--r--lisp/emacs-lisp/map-ynp.el6
-rw-r--r--lisp/emacs-lisp/map.el355
-rw-r--r--lisp/emacs-lisp/memory-report.el319
-rw-r--r--lisp/emacs-lisp/nadvice.el28
-rw-r--r--lisp/emacs-lisp/package-x.el5
-rw-r--r--lisp/emacs-lisp/package.el750
-rw-r--r--lisp/emacs-lisp/pcase.el460
-rw-r--r--lisp/emacs-lisp/pp.el54
-rw-r--r--lisp/emacs-lisp/radix-tree.el12
-rw-r--r--lisp/emacs-lisp/re-builder.el120
-rw-r--r--lisp/emacs-lisp/regi.el78
-rw-r--r--lisp/emacs-lisp/ring.el2
-rw-r--r--lisp/emacs-lisp/rmc.el154
-rw-r--r--lisp/emacs-lisp/rx.el50
-rw-r--r--lisp/emacs-lisp/seq.el41
-rw-r--r--lisp/emacs-lisp/shadow.el39
-rw-r--r--lisp/emacs-lisp/shortdoc.el1360
-rw-r--r--lisp/emacs-lisp/smie.el59
-rw-r--r--lisp/emacs-lisp/subr-x.el173
-rw-r--r--lisp/emacs-lisp/syntax.el119
-rw-r--r--lisp/emacs-lisp/tabulated-list.el128
-rw-r--r--lisp/emacs-lisp/tcover-ses.el34
-rw-r--r--lisp/emacs-lisp/tcover-unsafep.el140
-rw-r--r--lisp/emacs-lisp/testcover.el56
-rw-r--r--lisp/emacs-lisp/text-property-search.el62
-rw-r--r--lisp/emacs-lisp/thunk.el4
-rw-r--r--lisp/emacs-lisp/timer-list.el123
-rw-r--r--lisp/emacs-lisp/timer.el3
-rw-r--r--lisp/emacs-lisp/trace.el23
-rw-r--r--lisp/emacs-lisp/unsafep.el41
-rw-r--r--lisp/emacs-lisp/warnings.el52
-rw-r--r--lisp/emacs-lock.el11
-rw-r--r--lisp/emulation/cua-base.el238
-rw-r--r--lisp/emulation/cua-gmrk.el61
-rw-r--r--lisp/emulation/cua-rect.el240
-rw-r--r--lisp/emulation/edt-lk201.el2
-rw-r--r--lisp/emulation/edt-mapper.el11
-rw-r--r--lisp/emulation/edt-pc.el2
-rw-r--r--lisp/emulation/edt-vt100.el2
-rw-r--r--lisp/emulation/edt.el165
-rw-r--r--lisp/emulation/keypad.el18
-rw-r--r--lisp/emulation/viper-cmd.el244
-rw-r--r--lisp/emulation/viper-ex.el35
-rw-r--r--lisp/emulation/viper-init.el130
-rw-r--r--lisp/emulation/viper-keym.el92
-rw-r--r--lisp/emulation/viper-macs.el65
-rw-r--r--lisp/emulation/viper-mous.el114
-rw-r--r--lisp/emulation/viper-util.el137
-rw-r--r--lisp/emulation/viper.el49
-rw-r--r--lisp/epa-dired.el45
-rw-r--r--lisp/epa-file.el92
-rw-r--r--lisp/epa-hook.el12
-rw-r--r--lisp/epa-ks.el345
-rw-r--r--lisp/epa-mail.el50
-rw-r--r--lisp/epa.el353
-rw-r--r--lisp/epg-config.el27
-rw-r--r--lisp/epg.el140
-rw-r--r--lisp/erc/ChangeLog.110
-rw-r--r--lisp/erc/erc-autoaway.el58
-rw-r--r--lisp/erc/erc-backend.el246
-rw-r--r--lisp/erc/erc-button.el64
-rw-r--r--lisp/erc/erc-capab.el58
-rw-r--r--lisp/erc/erc-dcc.el148
-rw-r--r--lisp/erc/erc-desktop-notifications.el23
-rw-r--r--lisp/erc/erc-ezbounce.el23
-rw-r--r--lisp/erc/erc-fill.el20
-rw-r--r--lisp/erc/erc-goodies.el98
-rw-r--r--lisp/erc/erc-ibuffer.el21
-rw-r--r--lisp/erc/erc-identd.el19
-rw-r--r--lisp/erc/erc-imenu.el9
-rw-r--r--lisp/erc/erc-join.el57
-rw-r--r--lisp/erc/erc-lang.el4
-rw-r--r--lisp/erc/erc-list.el66
-rw-r--r--lisp/erc/erc-log.el66
-rw-r--r--lisp/erc/erc-match.el142
-rw-r--r--lisp/erc/erc-menu.el22
-rw-r--r--lisp/erc/erc-netsplit.el28
-rw-r--r--lisp/erc/erc-networks.el37
-rw-r--r--lisp/erc/erc-notify.el34
-rw-r--r--lisp/erc/erc-page.el18
-rw-r--r--lisp/erc/erc-pcomplete.el41
-rw-r--r--lisp/erc/erc-replace.el15
-rw-r--r--lisp/erc/erc-ring.el38
-rw-r--r--lisp/erc/erc-services.el96
-rw-r--r--lisp/erc/erc-sound.el15
-rw-r--r--lisp/erc/erc-speedbar.el26
-rw-r--r--lisp/erc/erc-spelling.el10
-rw-r--r--lisp/erc/erc-stamp.el25
-rw-r--r--lisp/erc/erc-status-sidebar.el303
-rw-r--r--lisp/erc/erc-track.el97
-rw-r--r--lisp/erc/erc-truncate.el7
-rw-r--r--lisp/erc/erc-xdcc.el16
-rw-r--r--lisp/erc/erc.el793
-rw-r--r--lisp/eshell/em-basic.el9
-rw-r--r--lisp/eshell/em-cmpl.el338
-rw-r--r--lisp/eshell/em-dirs.el29
-rw-r--r--lisp/eshell/em-glob.el8
-rw-r--r--lisp/eshell/em-hist.el169
-rw-r--r--lisp/eshell/em-ls.el91
-rw-r--r--lisp/eshell/em-pred.el280
-rw-r--r--lisp/eshell/em-prompt.el28
-rw-r--r--lisp/eshell/em-rebind.el19
-rw-r--r--lisp/eshell/em-script.el17
-rw-r--r--lisp/eshell/em-smart.el31
-rw-r--r--lisp/eshell/em-term.el8
-rw-r--r--lisp/eshell/em-tramp.el7
-rw-r--r--lisp/eshell/em-unix.el76
-rw-r--r--lisp/eshell/em-xtra.el74
-rw-r--r--lisp/eshell/esh-arg.el99
-rw-r--r--lisp/eshell/esh-cmd.el62
-rw-r--r--lisp/eshell/esh-io.el12
-rw-r--r--lisp/eshell/esh-mode.el303
-rw-r--r--lisp/eshell/esh-module.el19
-rw-r--r--lisp/eshell/esh-opt.el8
-rw-r--r--lisp/eshell/esh-proc.el78
-rw-r--r--lisp/eshell/esh-util.el277
-rw-r--r--lisp/eshell/esh-var.el87
-rw-r--r--lisp/eshell/eshell.el35
-rw-r--r--lisp/expand.el42
-rw-r--r--lisp/ezimage.el2
-rw-r--r--lisp/face-remap.el76
-rw-r--r--lisp/facemenu.el169
-rw-r--r--lisp/faces.el201
-rw-r--r--lisp/ffap.el297
-rw-r--r--lisp/filecache.el42
-rw-r--r--lisp/fileloop.el64
-rw-r--r--lisp/filenotify.el2
-rw-r--r--lisp/files-x.el49
-rw-r--r--lisp/files.el1546
-rw-r--r--lisp/filesets.el637
-rw-r--r--lisp/find-cmd.el4
-rw-r--r--lisp/find-dired.el31
-rw-r--r--lisp/find-file.el314
-rw-r--r--lisp/find-lisp.el42
-rw-r--r--lisp/finder.el65
-rw-r--r--lisp/flow-ctrl.el13
-rw-r--r--lisp/foldout.el102
-rw-r--r--lisp/follow.el144
-rw-r--r--lisp/font-core.el14
-rw-r--r--lisp/font-lock.el131
-rw-r--r--lisp/format-spec.el210
-rw-r--r--lisp/format.el38
-rw-r--r--lisp/forms.el181
-rw-r--r--lisp/frame.el357
-rw-r--r--lisp/frameset.el12
-rw-r--r--lisp/fringe.el11
-rw-r--r--lisp/generic-x.el234
-rw-r--r--lisp/gnus/.dir-locals.el4
-rw-r--r--lisp/gnus/ChangeLog.210
-rw-r--r--lisp/gnus/ChangeLog.324
-rw-r--r--lisp/gnus/canlock.el13
-rw-r--r--lisp/gnus/deuglify.el64
-rw-r--r--lisp/gnus/gmm-utils.el30
-rw-r--r--lisp/gnus/gnus-agent.el181
-rw-r--r--lisp/gnus/gnus-art.el1260
-rw-r--r--lisp/gnus/gnus-async.el1
-rw-r--r--lisp/gnus/gnus-bcklg.el2
-rw-r--r--lisp/gnus/gnus-bookmark.el68
-rw-r--r--lisp/gnus/gnus-cache.el56
-rw-r--r--lisp/gnus/gnus-cite.el100
-rw-r--r--lisp/gnus/gnus-cloud.el80
-rw-r--r--lisp/gnus/gnus-cus.el58
-rw-r--r--lisp/gnus/gnus-dbus.el70
-rw-r--r--lisp/gnus/gnus-delay.el34
-rw-r--r--lisp/gnus/gnus-demon.el4
-rw-r--r--lisp/gnus/gnus-diary.el25
-rw-r--r--lisp/gnus/gnus-dired.el19
-rw-r--r--lisp/gnus/gnus-draft.el25
-rw-r--r--lisp/gnus/gnus-dup.el3
-rw-r--r--lisp/gnus/gnus-eform.el26
-rw-r--r--lisp/gnus/gnus-fun.el35
-rw-r--r--lisp/gnus/gnus-gravatar.el27
-rw-r--r--lisp/gnus/gnus-group.el783
-rw-r--r--lisp/gnus/gnus-html.el130
-rw-r--r--lisp/gnus/gnus-icalendar.el123
-rw-r--r--lisp/gnus/gnus-int.el445
-rw-r--r--lisp/gnus/gnus-kill.el32
-rw-r--r--lisp/gnus/gnus-logic.el2
-rw-r--r--lisp/gnus/gnus-mh.el8
-rw-r--r--lisp/gnus/gnus-ml.el2
-rw-r--r--lisp/gnus/gnus-mlspl.el6
-rw-r--r--lisp/gnus/gnus-msg.el507
-rw-r--r--lisp/gnus/gnus-notifications.el16
-rw-r--r--lisp/gnus/gnus-picon.el33
-rw-r--r--lisp/gnus/gnus-range.el21
-rw-r--r--lisp/gnus/gnus-registry.el240
-rw-r--r--lisp/gnus/gnus-rfc1843.el8
-rw-r--r--lisp/gnus/gnus-salt.el28
-rw-r--r--lisp/gnus/gnus-score.el273
-rw-r--r--lisp/gnus/gnus-search.el2165
-rw-r--r--lisp/gnus/gnus-sieve.el40
-rw-r--r--lisp/gnus/gnus-spec.el46
-rw-r--r--lisp/gnus/gnus-srvr.el115
-rw-r--r--lisp/gnus/gnus-start.el288
-rw-r--r--lisp/gnus/gnus-sum.el1299
-rw-r--r--lisp/gnus/gnus-topic.el248
-rw-r--r--lisp/gnus/gnus-undo.el38
-rw-r--r--lisp/gnus/gnus-util.el200
-rw-r--r--lisp/gnus/gnus-uu.el171
-rw-r--r--lisp/gnus/gnus-vm.el6
-rw-r--r--lisp/gnus/gnus-win.el19
-rw-r--r--lisp/gnus/gnus.el254
-rw-r--r--lisp/gnus/gssapi.el13
-rw-r--r--lisp/gnus/legacy-gnus-agent.el4
-rw-r--r--lisp/gnus/mail-source.el182
-rw-r--r--lisp/gnus/message.el1060
-rw-r--r--lisp/gnus/mm-archive.el26
-rw-r--r--lisp/gnus/mm-bodies.el2
-rw-r--r--lisp/gnus/mm-decode.el63
-rw-r--r--lisp/gnus/mm-encode.el11
-rw-r--r--lisp/gnus/mm-partial.el35
-rw-r--r--lisp/gnus/mm-url.el13
-rw-r--r--lisp/gnus/mm-util.el93
-rw-r--r--lisp/gnus/mm-uu.el14
-rw-r--r--lisp/gnus/mm-view.el114
-rw-r--r--lisp/gnus/mml-sec.el139
-rw-r--r--lisp/gnus/mml-smime.el41
-rw-r--r--lisp/gnus/mml.el138
-rw-r--r--lisp/gnus/mml1991.el14
-rw-r--r--lisp/gnus/mml2015.el45
-rw-r--r--lisp/gnus/nnagent.el18
-rw-r--r--lisp/gnus/nnbabyl.el46
-rw-r--r--lisp/gnus/nndiary.el87
-rw-r--r--lisp/gnus/nndir.el2
-rw-r--r--lisp/gnus/nndoc.el41
-rw-r--r--lisp/gnus/nndraft.el36
-rw-r--r--lisp/gnus/nneething.el18
-rw-r--r--lisp/gnus/nnfolder.el44
-rw-r--r--lisp/gnus/nngateway.el2
-rw-r--r--lisp/gnus/nnheader.el412
-rw-r--r--lisp/gnus/nnimap.el115
-rw-r--r--lisp/gnus/nnmail.el94
-rw-r--r--lisp/gnus/nnmaildir.el82
-rw-r--r--lisp/gnus/nnmairix.el233
-rw-r--r--lisp/gnus/nnmbox.el50
-rw-r--r--lisp/gnus/nnmh.el51
-rw-r--r--lisp/gnus/nnml.el79
-rw-r--r--lisp/gnus/nnnil.el22
-rw-r--r--lisp/gnus/nnoo.el130
-rw-r--r--lisp/gnus/nnregistry.el13
-rw-r--r--lisp/gnus/nnrss.el92
-rw-r--r--lisp/gnus/nnselect.el973
-rw-r--r--lisp/gnus/nnspool.el36
-rw-r--r--lisp/gnus/nntp.el43
-rw-r--r--lisp/gnus/nnvirtual.el69
-rw-r--r--lisp/gnus/nnweb.el30
-rw-r--r--lisp/gnus/score-mode.el8
-rw-r--r--lisp/gnus/smiley.el112
-rw-r--r--lisp/gnus/smime.el51
-rw-r--r--lisp/gnus/spam-report.el36
-rw-r--r--lisp/gnus/spam-stat.el60
-rw-r--r--lisp/gnus/spam-wash.el8
-rw-r--r--lisp/gnus/spam.el430
-rw-r--r--lisp/help-at-pt.el14
-rw-r--r--lisp/help-fns.el546
-rw-r--r--lisp/help-macro.el257
-rw-r--r--lisp/help-mode.el145
-rw-r--r--lisp/help.el858
-rw-r--r--lisp/hexl.el196
-rw-r--r--lisp/hfy-cmap.el45
-rw-r--r--lisp/hi-lock.el253
-rw-r--r--lisp/hilit-chg.el161
-rw-r--r--lisp/hippie-exp.el61
-rw-r--r--lisp/hl-line.el63
-rw-r--r--lisp/htmlfontify.el191
-rw-r--r--lisp/ibuf-ext.el223
-rw-r--r--lisp/ibuf-macs.el32
-rw-r--r--lisp/ibuffer.el676
-rw-r--r--lisp/icomplete.el592
-rw-r--r--lisp/ido.el334
-rw-r--r--lisp/ielm.el72
-rw-r--r--lisp/iimage.el13
-rw-r--r--lisp/image-dired.el18
-rw-r--r--lisp/image-file.el16
-rw-r--r--lisp/image-mode.el232
-rw-r--r--lisp/image.el137
-rw-r--r--lisp/image/exif.el7
-rw-r--r--lisp/image/gravatar.el173
-rw-r--r--lisp/image/image-converter.el38
-rw-r--r--lisp/imenu.el142
-rw-r--r--lisp/indent.el65
-rw-r--r--lisp/info-look.el13
-rw-r--r--lisp/info-xref.el2
-rw-r--r--lisp/info.el415
-rw-r--r--lisp/informat.el6
-rw-r--r--lisp/international/ccl.el14
-rw-r--r--lisp/international/characters.el162
-rw-r--r--lisp/international/fontset.el53
-rw-r--r--lisp/international/isearch-x.el25
-rw-r--r--lisp/international/iso-ascii.el5
-rw-r--r--lisp/international/iso-cvt.el24
-rw-r--r--lisp/international/iso-transl.el12
-rw-r--r--lisp/international/ja-dic-cnv.el30
-rw-r--r--lisp/international/ja-dic-utl.el2
-rw-r--r--lisp/international/kinsoku.el4
-rw-r--r--lisp/international/kkc.el2
-rw-r--r--lisp/international/latexenc.el4
-rw-r--r--lisp/international/latin1-disp.el21
-rw-r--r--lisp/international/mule-cmds.el488
-rw-r--r--lisp/international/mule-conf.el105
-rw-r--r--lisp/international/mule-diag.el62
-rw-r--r--lisp/international/mule-util.el33
-rw-r--r--lisp/international/mule.el235
-rw-r--r--lisp/international/ogonek.el10
-rw-r--r--lisp/international/quail.el248
-rw-r--r--lisp/international/rfc1843.el2
-rw-r--r--lisp/international/robin.el11
-rw-r--r--lisp/international/titdic-cnv.el62
-rw-r--r--lisp/international/ucs-normalize.el24
-rw-r--r--lisp/international/utf-7.el2
-rw-r--r--lisp/isearch.el705
-rw-r--r--lisp/isearchb.el9
-rw-r--r--lisp/jit-lock.el43
-rw-r--r--lisp/jka-cmpr-hook.el32
-rw-r--r--lisp/jka-compr.el163
-rw-r--r--lisp/json.el690
-rw-r--r--lisp/jsonrpc.el166
-rw-r--r--lisp/kermit.el2
-rw-r--r--lisp/kmacro.el136
-rw-r--r--lisp/language/burmese.el9
-rw-r--r--lisp/language/cham.el14
-rw-r--r--lisp/language/china-util.el2
-rw-r--r--lisp/language/chinese.el7
-rw-r--r--lisp/language/cyril-util.el4
-rw-r--r--lisp/language/cyrillic.el11
-rw-r--r--lisp/language/czech.el2
-rw-r--r--lisp/language/english.el2
-rw-r--r--lisp/language/ethio-util.el82
-rw-r--r--lisp/language/ethiopic.el6
-rw-r--r--lisp/language/european.el83
-rw-r--r--lisp/language/georgian.el2
-rw-r--r--lisp/language/greek.el2
-rw-r--r--lisp/language/hanja-util.el6
-rw-r--r--lisp/language/hebrew.el10
-rw-r--r--lisp/language/ind-util.el54
-rw-r--r--lisp/language/indian.el6
-rw-r--r--lisp/language/japan-util.el12
-rw-r--r--lisp/language/japanese.el28
-rw-r--r--lisp/language/khmer.el6
-rw-r--r--lisp/language/korea-util.el37
-rw-r--r--lisp/language/korean.el14
-rw-r--r--lisp/language/lao-util.el24
-rw-r--r--lisp/language/lao.el4
-rw-r--r--lisp/language/misc-lang.el63
-rw-r--r--lisp/language/romanian.el2
-rw-r--r--lisp/language/sinhala.el6
-rw-r--r--lisp/language/slovak.el2
-rw-r--r--lisp/language/tai-viet.el6
-rw-r--r--lisp/language/thai-util.el8
-rw-r--r--lisp/language/thai-word.el7
-rw-r--r--lisp/language/thai.el2
-rw-r--r--lisp/language/tibet-util.el82
-rw-r--r--lisp/language/tibetan.el12
-rw-r--r--lisp/language/tv-util.el7
-rw-r--r--lisp/language/utf-8-lang.el2
-rw-r--r--lisp/language/viet-util.el2
-rw-r--r--lisp/language/vietnamese.el2
-rw-r--r--lisp/ldefs-boot.el8483
-rw-r--r--lisp/leim/quail/arabic.el2
-rw-r--r--lisp/leim/quail/cham.el116
-rw-r--r--lisp/leim/quail/compose.el2952
-rw-r--r--lisp/leim/quail/croatian.el2
-rw-r--r--lisp/leim/quail/cyril-jis.el2
-rw-r--r--lisp/leim/quail/cyrillic.el2
-rw-r--r--lisp/leim/quail/czech.el2
-rw-r--r--lisp/leim/quail/ethiopic.el2
-rw-r--r--lisp/leim/quail/georgian.el2
-rw-r--r--lisp/leim/quail/greek.el2
-rw-r--r--lisp/leim/quail/hangul.el27
-rw-r--r--lisp/leim/quail/hanja-jis.el2
-rw-r--r--lisp/leim/quail/hanja.el2
-rw-r--r--lisp/leim/quail/hanja3.el2
-rw-r--r--lisp/leim/quail/hebrew.el2
-rw-r--r--lisp/leim/quail/indian.el103
-rw-r--r--lisp/leim/quail/ipa-praat.el4
-rw-r--r--lisp/leim/quail/ipa.el14
-rw-r--r--lisp/leim/quail/japanese.el13
-rw-r--r--lisp/leim/quail/lao.el4
-rw-r--r--lisp/leim/quail/latin-alt.el2
-rw-r--r--lisp/leim/quail/latin-ltx.el67
-rw-r--r--lisp/leim/quail/latin-post.el97
-rw-r--r--lisp/leim/quail/latin-pre.el33
-rw-r--r--lisp/leim/quail/lrt.el4
-rw-r--r--lisp/leim/quail/persian.el2
-rw-r--r--lisp/leim/quail/programmer-dvorak.el4
-rw-r--r--lisp/leim/quail/py-punct.el2
-rw-r--r--lisp/leim/quail/pypunct-b5.el2
-rw-r--r--lisp/leim/quail/rfc1345.el2
-rw-r--r--lisp/leim/quail/sami.el2
-rw-r--r--lisp/leim/quail/sgml-input.el2
-rw-r--r--lisp/leim/quail/sisheng.el2
-rw-r--r--lisp/leim/quail/slovak.el2
-rw-r--r--lisp/leim/quail/symbol-ksc.el2
-rw-r--r--lisp/leim/quail/tamil-dvorak.el2
-rw-r--r--lisp/leim/quail/thai.el2
-rw-r--r--lisp/leim/quail/tibetan.el8
-rw-r--r--lisp/leim/quail/uni-input.el20
-rw-r--r--lisp/leim/quail/viqr.el2
-rw-r--r--lisp/leim/quail/vntelex.el2
-rw-r--r--lisp/leim/quail/vnvni.el2
-rw-r--r--lisp/leim/quail/welsh.el2
-rw-r--r--lisp/linum.el13
-rw-r--r--lisp/loadhist.el68
-rw-r--r--lisp/loadup.el75
-rw-r--r--lisp/locate.el24
-rw-r--r--lisp/lpr.el39
-rw-r--r--lisp/ls-lisp.el91
-rw-r--r--lisp/mail/binhex.el40
-rw-r--r--lisp/mail/blessmail.el2
-rw-r--r--lisp/mail/emacsbug.el274
-rw-r--r--lisp/mail/feedmail.el136
-rw-r--r--lisp/mail/flow-fill.el43
-rw-r--r--lisp/mail/footnote.el28
-rw-r--r--lisp/mail/hashcash.el16
-rw-r--r--lisp/mail/ietf-drums.el4
-rw-r--r--lisp/mail/mail-extr.el136
-rw-r--r--lisp/mail/mail-hist.el15
-rw-r--r--lisp/mail/mail-parse.el2
-rw-r--r--lisp/mail/mail-prsvr.el2
-rw-r--r--lisp/mail/mail-utils.el10
-rw-r--r--lisp/mail/mailabbrev.el53
-rw-r--r--lisp/mail/mailalias.el8
-rw-r--r--lisp/mail/mailclient.el4
-rw-r--r--lisp/mail/mailheader.el35
-rw-r--r--lisp/mail/mspools.el118
-rw-r--r--lisp/mail/qp.el6
-rw-r--r--lisp/mail/reporter.el88
-rw-r--r--lisp/mail/rfc2045.el2
-rw-r--r--lisp/mail/rfc2047.el6
-rw-r--r--lisp/mail/rfc2231.el36
-rw-r--r--lisp/mail/rfc2368.el2
-rw-r--r--lisp/mail/rfc822.el15
-rw-r--r--lisp/mail/rmail-spam-filter.el77
-rw-r--r--lisp/mail/rmail.el356
-rw-r--r--lisp/mail/rmailedit.el43
-rw-r--r--lisp/mail/rmailkwd.el4
-rw-r--r--lisp/mail/rmailmm.el202
-rw-r--r--lisp/mail/rmailmsc.el4
-rw-r--r--lisp/mail/rmailout.el11
-rw-r--r--lisp/mail/rmailsort.el6
-rw-r--r--lisp/mail/rmailsum.el53
-rw-r--r--lisp/mail/sendmail.el82
-rw-r--r--lisp/mail/smtpmail.el157
-rw-r--r--lisp/mail/supercite.el141
-rw-r--r--lisp/mail/uce.el27
-rw-r--r--lisp/mail/unrmail.el4
-rw-r--r--lisp/mail/uudecode.el27
-rw-r--r--lisp/man.el121
-rw-r--r--lisp/master.el30
-rw-r--r--lisp/mb-depth.el25
-rw-r--r--lisp/md4.el19
-rw-r--r--lisp/menu-bar.el335
-rw-r--r--lisp/mh-e/ChangeLog.126
-rw-r--r--lisp/mh-e/mh-acros.el35
-rw-r--r--lisp/mh-e/mh-alias.el52
-rw-r--r--lisp/mh-e/mh-buffers.el4
-rw-r--r--lisp/mh-e/mh-comp.el135
-rw-r--r--lisp/mh-e/mh-compat.el10
-rw-r--r--lisp/mh-e/mh-e.el235
-rw-r--r--lisp/mh-e/mh-folder.el138
-rw-r--r--lisp/mh-e/mh-funcs.el10
-rw-r--r--lisp/mh-e/mh-gnus.el6
-rw-r--r--lisp/mh-e/mh-identity.el23
-rw-r--r--lisp/mh-e/mh-inc.el20
-rw-r--r--lisp/mh-e/mh-junk.el225
-rw-r--r--lisp/mh-e/mh-letter.el19
-rw-r--r--lisp/mh-e/mh-limit.el10
-rw-r--r--lisp/mh-e/mh-mime.el64
-rw-r--r--lisp/mh-e/mh-print.el9
-rw-r--r--lisp/mh-e/mh-scan.el40
-rw-r--r--lisp/mh-e/mh-search.el80
-rw-r--r--lisp/mh-e/mh-seq.el36
-rw-r--r--lisp/mh-e/mh-show.el33
-rw-r--r--lisp/mh-e/mh-speed.el22
-rw-r--r--lisp/mh-e/mh-thread.el44
-rw-r--r--lisp/mh-e/mh-tool-bar.el8
-rw-r--r--lisp/mh-e/mh-utils.el33
-rw-r--r--lisp/mh-e/mh-xface.el9
-rw-r--r--lisp/minibuf-eldef.el22
-rw-r--r--lisp/minibuffer.el895
-rw-r--r--lisp/misc.el18
-rw-r--r--lisp/misearch.el63
-rw-r--r--lisp/mouse-copy.el8
-rw-r--r--lisp/mouse-drag.el9
-rw-r--r--lisp/mouse.el615
-rw-r--r--lisp/mpc.el194
-rw-r--r--lisp/msb.el90
-rw-r--r--lisp/mwheel.el194
-rw-r--r--lisp/net/ange-ftp.el180
-rw-r--r--lisp/net/browse-url.el527
-rw-r--r--lisp/net/dbus.el1402
-rw-r--r--lisp/net/dictionary-connection.el156
-rw-r--r--lisp/net/dictionary.el1372
-rw-r--r--lisp/net/dig.el32
-rw-r--r--lisp/net/dns.el297
-rw-r--r--lisp/net/eudc-bob.el148
-rw-r--r--lisp/net/eudc-export.el89
-rw-r--r--lisp/net/eudc-hotlist.el14
-rw-r--r--lisp/net/eudc-vars.el4
-rw-r--r--lisp/net/eudc.el261
-rw-r--r--lisp/net/eudcb-bbdb.el162
-rw-r--r--lisp/net/eudcb-ldap.el37
-rw-r--r--lisp/net/eudcb-mab.el2
-rw-r--r--lisp/net/eudcb-macos-contacts.el123
-rw-r--r--lisp/net/eww.el488
-rw-r--r--lisp/net/gnutls.el28
-rw-r--r--lisp/net/goto-addr.el44
-rw-r--r--lisp/net/hmac-def.el2
-rw-r--r--lisp/net/hmac-md5.el40
-rw-r--r--lisp/net/imap.el128
-rw-r--r--lisp/net/ldap.el15
-rw-r--r--lisp/net/mailcap.el151
-rw-r--r--lisp/net/mairix.el243
-rw-r--r--lisp/net/net-utils.el138
-rw-r--r--lisp/net/netrc.el6
-rw-r--r--lisp/net/network-stream.el92
-rw-r--r--lisp/net/newst-backend.el277
-rw-r--r--lisp/net/newst-plainview.el139
-rw-r--r--lisp/net/newst-reader.el10
-rw-r--r--lisp/net/newst-ticker.el12
-rw-r--r--lisp/net/newst-treeview.el251
-rw-r--r--lisp/net/newsticker.el10
-rw-r--r--lisp/net/nsm.el17
-rw-r--r--lisp/net/ntlm.el110
-rw-r--r--lisp/net/pop3.el8
-rw-r--r--lisp/net/puny.el18
-rw-r--r--lisp/net/quickurl.el29
-rw-r--r--lisp/net/rcirc.el1551
-rw-r--r--lisp/net/rfc2104.el2
-rw-r--r--lisp/net/rlogin.el6
-rw-r--r--lisp/net/sasl-cram.el2
-rw-r--r--lisp/net/sasl-digest.el2
-rw-r--r--lisp/net/sasl-ntlm.el6
-rw-r--r--lisp/net/sasl-scram-sha256.el59
-rw-r--r--lisp/net/sasl.el24
-rw-r--r--lisp/net/secrets.el22
-rw-r--r--lisp/net/shr-color.el14
-rw-r--r--lisp/net/shr.el384
-rw-r--r--lisp/net/sieve-manage.el28
-rw-r--r--lisp/net/sieve-mode.el54
-rw-r--r--lisp/net/sieve.el98
-rw-r--r--lisp/net/snmp-mode.el114
-rw-r--r--lisp/net/soap-client.el178
-rw-r--r--lisp/net/soap-inspect.el54
-rw-r--r--lisp/net/socks.el20
-rw-r--r--lisp/net/telnet.el39
-rw-r--r--lisp/net/tramp-adb.el866
-rw-r--r--lisp/net/tramp-archive.el52
-rw-r--r--lisp/net/tramp-cache.el288
-rw-r--r--lisp/net/tramp-cmds.el140
-rw-r--r--lisp/net/tramp-compat.el202
-rw-r--r--lisp/net/tramp-crypt.el887
-rw-r--r--lisp/net/tramp-ftp.el6
-rw-r--r--lisp/net/tramp-fuse.el214
-rw-r--r--lisp/net/tramp-gvfs.el1070
-rw-r--r--lisp/net/tramp-integration.el72
-rw-r--r--lisp/net/tramp-rclone.el292
-rw-r--r--lisp/net/tramp-sh.el2455
-rw-r--r--lisp/net/tramp-smb.el410
-rw-r--r--lisp/net/tramp-sshfs.el391
-rw-r--r--lisp/net/tramp-sudoedit.el200
-rw-r--r--lisp/net/tramp-uu.el5
-rw-r--r--lisp/net/tramp.el1660
-rw-r--r--lisp/net/trampver.el31
-rw-r--r--lisp/net/webjump.el18
-rw-r--r--lisp/newcomment.el135
-rw-r--r--lisp/notifications.el103
-rw-r--r--lisp/novice.el2
-rw-r--r--lisp/nxml/nxml-mode.el40
-rw-r--r--lisp/nxml/rng-cmpct.el13
-rw-r--r--lisp/nxml/rng-loc.el2
-rw-r--r--lisp/nxml/rng-match.el2
-rw-r--r--lisp/nxml/rng-nxml.el18
-rw-r--r--lisp/nxml/rng-pttrn.el3
-rw-r--r--lisp/nxml/rng-util.el30
-rw-r--r--lisp/nxml/rng-valid.el30
-rw-r--r--lisp/nxml/rng-xsd.el6
-rw-r--r--lisp/nxml/xmltok.el45
-rw-r--r--lisp/nxml/xsd-regexp.el12
-rw-r--r--lisp/obsolete/abbrevlist.el4
-rw-r--r--lisp/obsolete/bruce.el10
-rw-r--r--lisp/obsolete/cc-compat.el4
-rw-r--r--lisp/obsolete/cl-compat.el44
-rw-r--r--lisp/obsolete/cl.el42
-rw-r--r--lisp/obsolete/complete.el78
-rw-r--r--lisp/obsolete/crisp.el130
-rw-r--r--lisp/obsolete/cust-print.el52
-rw-r--r--lisp/obsolete/erc-compat.el (renamed from lisp/erc/erc-compat.el)28
-rw-r--r--lisp/obsolete/erc-hecomplete.el13
-rw-r--r--lisp/obsolete/eudcb-ph.el6
-rw-r--r--lisp/obsolete/fast-lock.el144
-rw-r--r--lisp/obsolete/gs.el4
-rw-r--r--lisp/obsolete/gulp.el17
-rw-r--r--lisp/obsolete/html2text.el2
-rw-r--r--lisp/obsolete/info-edit.el4
-rw-r--r--lisp/obsolete/inversion.el (renamed from lisp/cedet/inversion.el)42
-rw-r--r--lisp/obsolete/iswitchb.el194
-rw-r--r--lisp/obsolete/landmark.el156
-rw-r--r--lisp/obsolete/lazy-lock.el168
-rw-r--r--lisp/obsolete/ledit.el157
-rw-r--r--lisp/obsolete/levents.el292
-rw-r--r--lisp/obsolete/lmenu.el445
-rw-r--r--lisp/obsolete/longlines.el73
-rw-r--r--lisp/obsolete/lucid.el211
-rw-r--r--lisp/obsolete/mailpost.el4
-rw-r--r--lisp/obsolete/mantemp.el2
-rw-r--r--lisp/obsolete/meese.el2
-rw-r--r--lisp/obsolete/messcompat.el2
-rw-r--r--lisp/obsolete/metamail.el (renamed from lisp/mail/metamail.el)14
-rw-r--r--lisp/obsolete/mouse-sel.el16
-rw-r--r--lisp/obsolete/nnir.el (renamed from lisp/gnus/nnir.el)1037
-rw-r--r--lisp/obsolete/old-emacs-lock.el16
-rw-r--r--lisp/obsolete/old-whitespace.el801
-rw-r--r--lisp/obsolete/otodo-mode.el116
-rw-r--r--lisp/obsolete/patcomp.el2
-rw-r--r--lisp/obsolete/pc-mode.el18
-rw-r--r--lisp/obsolete/pc-select.el17
-rw-r--r--lisp/obsolete/pgg-def.el10
-rw-r--r--lisp/obsolete/pgg-gpg.el12
-rw-r--r--lisp/obsolete/pgg-parse.el18
-rw-r--r--lisp/obsolete/pgg-pgp.el16
-rw-r--r--lisp/obsolete/pgg-pgp5.el14
-rw-r--r--lisp/obsolete/pgg.el113
-rw-r--r--lisp/obsolete/rcompile.el23
-rw-r--r--lisp/obsolete/s-region.el8
-rw-r--r--lisp/obsolete/sb-image.el47
-rw-r--r--lisp/obsolete/sregex.el40
-rw-r--r--lisp/obsolete/starttls.el34
-rw-r--r--lisp/obsolete/sup-mouse.el2
-rw-r--r--lisp/obsolete/terminal.el81
-rw-r--r--lisp/obsolete/tls.el55
-rw-r--r--lisp/obsolete/tpu-edt.el445
-rw-r--r--lisp/obsolete/tpu-extras.el35
-rw-r--r--lisp/obsolete/tpu-mapper.el4
-rw-r--r--lisp/obsolete/url-ns.el43
-rw-r--r--lisp/obsolete/vc-arch.el42
-rw-r--r--lisp/obsolete/vi.el310
-rw-r--r--lisp/obsolete/vip.el338
-rw-r--r--lisp/obsolete/ws-mode.el242
-rw-r--r--lisp/obsolete/yow.el5
-rw-r--r--lisp/org/ChangeLog.178
-rw-r--r--lisp/org/ob-R.el2
-rw-r--r--lisp/org/ob-clojure.el2
-rw-r--r--lisp/org/ob-comint.el6
-rw-r--r--lisp/org/ob-core.el19
-rw-r--r--lisp/org/ob-hledger.el2
-rw-r--r--lisp/org/ob-lilypond.el6
-rw-r--r--lisp/org/ob-mscgen.el4
-rw-r--r--lisp/org/ob-ocaml.el2
-rw-r--r--lisp/org/ob-screen.el2
-rw-r--r--lisp/org/ob-sql.el3
-rw-r--r--lisp/org/ob-tangle.el3
-rw-r--r--lisp/org/ol-bbdb.el2
-rw-r--r--lisp/org/ol-eshell.el2
-rw-r--r--lisp/org/ol-gnus.el4
-rw-r--r--lisp/org/ol-w3m.el6
-rw-r--r--lisp/org/ol.el14
-rw-r--r--lisp/org/org-agenda.el20
-rw-r--r--lisp/org/org-attach.el2
-rw-r--r--lisp/org/org-capture.el2
-rw-r--r--lisp/org/org-clock.el40
-rw-r--r--lisp/org/org-colview.el60
-rw-r--r--lisp/org/org-compat.el4
-rw-r--r--lisp/org/org-crypt.el2
-rw-r--r--lisp/org/org-ctags.el6
-rw-r--r--lisp/org/org-element.el2
-rw-r--r--lisp/org/org-indent.el8
-rw-r--r--lisp/org/org-install.el2
-rw-r--r--lisp/org/org-list.el2
-rw-r--r--lisp/org/org-macs.el61
-rw-r--r--lisp/org/org-mouse.el88
-rw-r--r--lisp/org/org-pcomplete.el11
-rw-r--r--lisp/org/org-protocol.el10
-rw-r--r--lisp/org/org-refile.el8
-rw-r--r--lisp/org/org-src.el2
-rw-r--r--lisp/org/org-table.el8
-rw-r--r--lisp/org/org-tempo.el2
-rw-r--r--lisp/org/org-timer.el17
-rw-r--r--lisp/org/org-version.el2
-rw-r--r--lisp/org/org.el15
-rw-r--r--lisp/org/ox-beamer.el8
-rw-r--r--lisp/org/ox-man.el2
-rw-r--r--lisp/org/ox-odt.el11
-rw-r--r--lisp/org/ox-texinfo.el16
-rw-r--r--lisp/org/ox.el4
-rw-r--r--lisp/outline.el352
-rw-r--r--lisp/password-cache.el23
-rw-r--r--lisp/pcmpl-cvs.el8
-rw-r--r--lisp/pcmpl-gnu.el39
-rw-r--r--lisp/pcmpl-linux.el23
-rw-r--r--lisp/pcmpl-rpm.el10
-rw-r--r--lisp/pcmpl-unix.el50
-rw-r--r--lisp/pcmpl-x.el37
-rw-r--r--lisp/pcomplete.el124
-rw-r--r--lisp/pixel-scroll.el11
-rw-r--r--lisp/play/5x5.el110
-rw-r--r--lisp/play/animate.el4
-rw-r--r--lisp/play/blackbox.el18
-rw-r--r--lisp/play/bubbles.el185
-rw-r--r--lisp/play/cookie1.el15
-rw-r--r--lisp/play/decipher.el132
-rw-r--r--lisp/play/dissociate.el2
-rw-r--r--lisp/play/doctor.el790
-rw-r--r--lisp/play/dunnet.el248
-rw-r--r--lisp/play/fortune.el70
-rw-r--r--lisp/play/gamegrid.el53
-rw-r--r--lisp/play/gametree.el39
-rw-r--r--lisp/play/gomoku.el165
-rw-r--r--lisp/play/handwrite.el103
-rw-r--r--lisp/play/hanoi.el16
-rw-r--r--lisp/play/life.el88
-rw-r--r--lisp/play/morse.el27
-rw-r--r--lisp/play/mpuz.el30
-rw-r--r--lisp/play/pong.el20
-rw-r--r--lisp/play/snake.el46
-rw-r--r--lisp/play/solitaire.el8
-rw-r--r--lisp/play/spook.el8
-rw-r--r--lisp/play/tetris.el95
-rw-r--r--lisp/play/zone.el21
-rw-r--r--lisp/plstore.el3
-rw-r--r--lisp/printing.el384
-rw-r--r--lisp/proced.el123
-rw-r--r--lisp/profiler.el38
-rw-r--r--lisp/progmodes/antlr-mode.el492
-rw-r--r--lisp/progmodes/asm-mode.el23
-rw-r--r--lisp/progmodes/autoconf.el2
-rw-r--r--lisp/progmodes/bat-mode.el4
-rw-r--r--lisp/progmodes/bug-reference.el410
-rw-r--r--lisp/progmodes/cc-align.el50
-rw-r--r--lisp/progmodes/cc-awk.el107
-rw-r--r--lisp/progmodes/cc-bytecomp.el29
-rw-r--r--lisp/progmodes/cc-cmds.el282
-rw-r--r--lisp/progmodes/cc-defs.el306
-rw-r--r--lisp/progmodes/cc-engine.el1296
-rw-r--r--lisp/progmodes/cc-fonts.el312
-rw-r--r--lisp/progmodes/cc-guess.el6
-rw-r--r--lisp/progmodes/cc-langs.el190
-rw-r--r--lisp/progmodes/cc-menus.el2
-rw-r--r--lisp/progmodes/cc-mode.el493
-rw-r--r--lisp/progmodes/cc-styles.el16
-rw-r--r--lisp/progmodes/cc-vars.el24
-rw-r--r--lisp/progmodes/cfengine.el74
-rw-r--r--lisp/progmodes/cl-font-lock.el290
-rw-r--r--lisp/progmodes/cmacexp.el58
-rw-r--r--lisp/progmodes/compile.el538
-rw-r--r--lisp/progmodes/cperl-mode.el1961
-rw-r--r--lisp/progmodes/cpp.el63
-rw-r--r--lisp/progmodes/cwarn.el17
-rw-r--r--lisp/progmodes/dcl-mode.el285
-rw-r--r--lisp/progmodes/ebnf-abn.el19
-rw-r--r--lisp/progmodes/ebnf-bnf.el8
-rw-r--r--lisp/progmodes/ebnf-dtd.el21
-rw-r--r--lisp/progmodes/ebnf-ebx.el22
-rw-r--r--lisp/progmodes/ebnf-iso.el10
-rw-r--r--lisp/progmodes/ebnf-otz.el2
-rw-r--r--lisp/progmodes/ebnf-yac.el16
-rw-r--r--lisp/progmodes/ebnf2ps.el91
-rw-r--r--lisp/progmodes/ebrowse.el465
-rw-r--r--lisp/progmodes/elisp-mode.el550
-rw-r--r--lisp/progmodes/etags.el120
-rw-r--r--lisp/progmodes/executable.el33
-rw-r--r--lisp/progmodes/f90.el101
-rw-r--r--lisp/progmodes/flymake-cc.el10
-rw-r--r--lisp/progmodes/flymake-proc.el21
-rw-r--r--lisp/progmodes/flymake.el379
-rw-r--r--lisp/progmodes/fortran.el258
-rw-r--r--lisp/progmodes/gdb-mi.el1325
-rw-r--r--lisp/progmodes/glasses.el15
-rw-r--r--lisp/progmodes/grep.el468
-rw-r--r--lisp/progmodes/gud.el416
-rw-r--r--lisp/progmodes/hideif.el1247
-rw-r--r--lisp/progmodes/hideshow.el21
-rw-r--r--lisp/progmodes/icon.el152
-rw-r--r--lisp/progmodes/idlw-complete-structtag.el18
-rw-r--r--lisp/progmodes/idlw-help.el145
-rw-r--r--lisp/progmodes/idlw-shell.el286
-rw-r--r--lisp/progmodes/idlw-toolbar.el119
-rw-r--r--lisp/progmodes/idlwave.el1360
-rw-r--r--lisp/progmodes/inf-lisp.el166
-rw-r--r--lisp/progmodes/js.el121
-rw-r--r--lisp/progmodes/ld-script.el12
-rw-r--r--lisp/progmodes/m4-mode.el91
-rw-r--r--lisp/progmodes/make-mode.el272
-rw-r--r--lisp/progmodes/meta-mode.el157
-rw-r--r--lisp/progmodes/mixal-mode.el72
-rw-r--r--lisp/progmodes/modula2.el92
-rw-r--r--lisp/progmodes/octave.el116
-rw-r--r--lisp/progmodes/opascal.el2
-rw-r--r--lisp/progmodes/pascal.el87
-rw-r--r--lisp/progmodes/perl-mode.el102
-rw-r--r--lisp/progmodes/prog-mode.el6
-rw-r--r--lisp/progmodes/project.el1036
-rw-r--r--lisp/progmodes/prolog.el235
-rw-r--r--lisp/progmodes/ps-mode.el65
-rw-r--r--lisp/progmodes/python.el580
-rw-r--r--lisp/progmodes/ruby-mode.el204
-rw-r--r--lisp/progmodes/scheme.el67
-rw-r--r--lisp/progmodes/sh-script.el1619
-rw-r--r--lisp/progmodes/simula.el211
-rw-r--r--lisp/progmodes/sql.el364
-rw-r--r--lisp/progmodes/subword.el4
-rw-r--r--lisp/progmodes/tcl.el253
-rw-r--r--lisp/progmodes/vera-mode.el75
-rw-r--r--lisp/progmodes/verilog-mode.el1394
-rw-r--r--lisp/progmodes/vhdl-mode.el1108
-rw-r--r--lisp/progmodes/which-func.el121
-rw-r--r--lisp/progmodes/xref.el556
-rw-r--r--lisp/progmodes/xscheme.el36
-rw-r--r--lisp/ps-bdf.el4
-rw-r--r--lisp/ps-def.el22
-rw-r--r--lisp/ps-mule.el50
-rw-r--r--lisp/ps-print.el22
-rw-r--r--lisp/ps-samp.el4
-rw-r--r--lisp/recentf.el136
-rw-r--r--lisp/rect.el11
-rw-r--r--lisp/registry.el33
-rw-r--r--lisp/repeat.el194
-rw-r--r--lisp/replace.el551
-rw-r--r--lisp/reposition.el234
-rw-r--r--lisp/reveal.el30
-rw-r--r--lisp/rfn-eshadow.el2
-rw-r--r--lisp/rot13.el29
-rw-r--r--lisp/ruler-mode.el71
-rw-r--r--lisp/savehist.el49
-rw-r--r--lisp/saveplace.el26
-rw-r--r--lisp/sb-image.el107
-rw-r--r--lisp/scroll-all.el23
-rw-r--r--lisp/scroll-bar.el2
-rw-r--r--lisp/scroll-lock.el7
-rw-r--r--lisp/select.el16
-rw-r--r--lisp/server.el207
-rw-r--r--lisp/ses.el146
-rw-r--r--lisp/shadowfile.el166
-rw-r--r--lisp/shell.el242
-rw-r--r--lisp/simple.el1684
-rw-r--r--lisp/skeleton.el126
-rw-r--r--lisp/so-long.el33
-rw-r--r--lisp/sort.el60
-rw-r--r--lisp/speedbar.el230
-rw-r--r--lisp/startup.el113
-rw-r--r--lisp/strokes.el231
-rw-r--r--lisp/subr.el1007
-rw-r--r--lisp/svg.el63
-rw-r--r--lisp/t-mouse.el4
-rw-r--r--lisp/tab-bar.el1012
-rw-r--r--lisp/tab-line.el235
-rw-r--r--lisp/talk.el6
-rw-r--r--lisp/tar-mode.el234
-rw-r--r--lisp/tempo.el68
-rw-r--r--lisp/term.el873
-rw-r--r--lisp/term/AT386.el2
-rw-r--r--lisp/term/bobcat.el1
-rw-r--r--lisp/term/common-win.el2
-rw-r--r--lisp/term/cygwin.el2
-rw-r--r--lisp/term/internal.el8
-rw-r--r--lisp/term/iris-ansi.el2
-rw-r--r--lisp/term/konsole.el4
-rw-r--r--lisp/term/linux.el2
-rw-r--r--lisp/term/lk201.el2
-rw-r--r--lisp/term/news.el2
-rw-r--r--lisp/term/ns-win.el50
-rw-r--r--lisp/term/rxvt.el23
-rw-r--r--lisp/term/screen.el2
-rw-r--r--lisp/term/st.el20
-rw-r--r--lisp/term/sun.el2
-rw-r--r--lisp/term/tmux.el2
-rw-r--r--lisp/term/tty-colors.el60
-rw-r--r--lisp/term/tvi970.el2
-rw-r--r--lisp/term/vt100.el2
-rw-r--r--lisp/term/vt200.el2
-rw-r--r--lisp/term/w32-win.el92
-rw-r--r--lisp/term/w32console.el2
-rw-r--r--lisp/term/wyse50.el8
-rw-r--r--lisp/term/x-win.el13
-rw-r--r--lisp/term/xterm.el27
-rw-r--r--lisp/textmodes/artist.el317
-rw-r--r--lisp/textmodes/bib-mode.el21
-rw-r--r--lisp/textmodes/bibtex-style.el15
-rw-r--r--lisp/textmodes/bibtex.el1094
-rw-r--r--lisp/textmodes/conf-mode.el274
-rw-r--r--lisp/textmodes/css-mode.el112
-rw-r--r--lisp/textmodes/dns-mode.el39
-rw-r--r--lisp/textmodes/enriched.el70
-rw-r--r--lisp/textmodes/fill.el74
-rw-r--r--lisp/textmodes/flyspell.el228
-rw-r--r--lisp/textmodes/ispell.el339
-rw-r--r--lisp/textmodes/less-css-mode.el11
-rw-r--r--lisp/textmodes/makeinfo.el20
-rw-r--r--lisp/textmodes/mhtml-mode.el97
-rw-r--r--lisp/textmodes/nroff-mode.el105
-rw-r--r--lisp/textmodes/page-ext.el23
-rw-r--r--lisp/textmodes/page.el2
-rw-r--r--lisp/textmodes/paragraphs.el35
-rw-r--r--lisp/textmodes/picture.el41
-rw-r--r--lisp/textmodes/po.el2
-rw-r--r--lisp/textmodes/refbib.el27
-rw-r--r--lisp/textmodes/refer.el40
-rw-r--r--lisp/textmodes/refill.el39
-rw-r--r--lisp/textmodes/reftex-auc.el64
-rw-r--r--lisp/textmodes/reftex-cite.el71
-rw-r--r--lisp/textmodes/reftex-dcr.el46
-rw-r--r--lisp/textmodes/reftex-global.el34
-rw-r--r--lisp/textmodes/reftex-index.el257
-rw-r--r--lisp/textmodes/reftex-parse.el19
-rw-r--r--lisp/textmodes/reftex-ref.el42
-rw-r--r--lisp/textmodes/reftex-sel.el207
-rw-r--r--lisp/textmodes/reftex-toc.el116
-rw-r--r--lisp/textmodes/reftex-vars.el140
-rw-r--r--lisp/textmodes/reftex.el200
-rw-r--r--lisp/textmodes/remember.el156
-rw-r--r--lisp/textmodes/rst.el388
-rw-r--r--lisp/textmodes/sgml-mode.el167
-rw-r--r--lisp/textmodes/table.el351
-rw-r--r--lisp/textmodes/tex-mode.el211
-rw-r--r--lisp/textmodes/texinfmt.el176
-rw-r--r--lisp/textmodes/texinfo.el407
-rw-r--r--lisp/textmodes/texnfo-upd.el48
-rw-r--r--lisp/textmodes/text-mode.el59
-rw-r--r--lisp/textmodes/tildify.el23
-rw-r--r--lisp/textmodes/two-column.el70
-rw-r--r--lisp/thingatpt.el72
-rw-r--r--lisp/thread.el2
-rw-r--r--lisp/thumbs.el120
-rw-r--r--lisp/time-stamp.el579
-rw-r--r--lisp/time.el467
-rw-r--r--lisp/timezone.el2
-rw-r--r--lisp/tmm.el58
-rw-r--r--lisp/tool-bar.el9
-rw-r--r--lisp/tooltip.el36
-rw-r--r--lisp/transient.el3676
-rw-r--r--lisp/tree-widget.el11
-rw-r--r--lisp/tutorial.el35
-rw-r--r--lisp/type-break.el12
-rw-r--r--lisp/uniquify.el54
-rw-r--r--lisp/url/ChangeLog.14
-rw-r--r--lisp/url/url-about.el12
-rw-r--r--lisp/url/url-auth.el31
-rw-r--r--lisp/url/url-cache.el29
-rw-r--r--lisp/url/url-cid.el2
-rw-r--r--lisp/url/url-cookie.el12
-rw-r--r--lisp/url/url-dav.el35
-rw-r--r--lisp/url/url-dired.el2
-rw-r--r--lisp/url/url-domsuf.el15
-rw-r--r--lisp/url/url-expand.el21
-rw-r--r--lisp/url/url-file.el2
-rw-r--r--lisp/url/url-ftp.el2
-rw-r--r--lisp/url/url-gw.el17
-rw-r--r--lisp/url/url-handlers.el7
-rw-r--r--lisp/url/url-history.el16
-rw-r--r--lisp/url/url-http.el78
-rw-r--r--lisp/url/url-imap.el5
-rw-r--r--lisp/url/url-irc.el8
-rw-r--r--lisp/url/url-ldap.el2
-rw-r--r--lisp/url/url-mailto.el15
-rw-r--r--lisp/url/url-methods.el4
-rw-r--r--lisp/url/url-misc.el2
-rw-r--r--lisp/url/url-news.el14
-rw-r--r--lisp/url/url-nfs.el2
-rw-r--r--lisp/url/url-privacy.el4
-rw-r--r--lisp/url/url-proxy.el15
-rw-r--r--lisp/url/url-queue.el29
-rw-r--r--lisp/url/url-tramp.el2
-rw-r--r--lisp/url/url-util.el40
-rw-r--r--lisp/url/url-vars.el32
-rw-r--r--lisp/url/url.el62
-rw-r--r--lisp/userlock.el85
-rw-r--r--lisp/vc/add-log.el163
-rw-r--r--lisp/vc/compare-w.el26
-rw-r--r--lisp/vc/cvs-status.el25
-rw-r--r--lisp/vc/diff-mode.el188
-rw-r--r--lisp/vc/diff.el20
-rw-r--r--lisp/vc/ediff-diff.el33
-rw-r--r--lisp/vc/ediff-help.el2
-rw-r--r--lisp/vc/ediff-init.el151
-rw-r--r--lisp/vc/ediff-merg.el4
-rw-r--r--lisp/vc/ediff-mult.el76
-rw-r--r--lisp/vc/ediff-ptch.el19
-rw-r--r--lisp/vc/ediff-util.el250
-rw-r--r--lisp/vc/ediff-vers.el43
-rw-r--r--lisp/vc/ediff-wind.el47
-rw-r--r--lisp/vc/ediff.el155
-rw-r--r--lisp/vc/emerge.el74
-rw-r--r--lisp/vc/log-edit.el72
-rw-r--r--lisp/vc/log-view.el16
-rw-r--r--lisp/vc/pcvs-defs.el19
-rw-r--r--lisp/vc/pcvs-info.el6
-rw-r--r--lisp/vc/pcvs-parse.el29
-rw-r--r--lisp/vc/pcvs-util.el30
-rw-r--r--lisp/vc/pcvs.el53
-rw-r--r--lisp/vc/smerge-mode.el123
-rw-r--r--lisp/vc/vc-annotate.el46
-rw-r--r--lisp/vc/vc-bzr.el123
-rw-r--r--lisp/vc/vc-cvs.el96
-rw-r--r--lisp/vc/vc-dav.el22
-rw-r--r--lisp/vc/vc-dir.el310
-rw-r--r--lisp/vc/vc-dispatcher.el47
-rw-r--r--lisp/vc/vc-filewise.el4
-rw-r--r--lisp/vc/vc-git.el229
-rw-r--r--lisp/vc/vc-hg.el176
-rw-r--r--lisp/vc/vc-hooks.el90
-rw-r--r--lisp/vc/vc-mtn.el31
-rw-r--r--lisp/vc/vc-rcs.el30
-rw-r--r--lisp/vc/vc-sccs.el36
-rw-r--r--lisp/vc/vc-src.el88
-rw-r--r--lisp/vc/vc-svn.el97
-rw-r--r--lisp/vc/vc.el265
-rw-r--r--lisp/vcursor.el326
-rw-r--r--lisp/version.el10
-rw-r--r--lisp/view.el211
-rw-r--r--lisp/vt-control.el18
-rw-r--r--lisp/vt100-led.el2
-rw-r--r--lisp/w32-fns.el24
-rw-r--r--lisp/w32-vars.el14
-rw-r--r--lisp/wdired.el638
-rw-r--r--lisp/whitespace.el111
-rw-r--r--lisp/wid-browse.el39
-rw-r--r--lisp/wid-edit.el670
-rw-r--r--lisp/widget.el4
-rw-r--r--lisp/windmove.el347
-rw-r--r--lisp/window.el817
-rw-r--r--lisp/winner.el32
-rw-r--r--lisp/woman.el281
-rw-r--r--lisp/x-dnd.el65
-rw-r--r--lisp/xdg.el6
-rw-r--r--lisp/xml.el23
-rw-r--r--lisp/xt-mouse.el40
-rw-r--r--lisp/xwidget.el280
1378 files changed, 109210 insertions, 74237 deletions
diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10
index 3a95841a934..c8b0bdabc50 100644
--- a/lisp/ChangeLog.10
+++ b/lisp/ChangeLog.10
@@ -12772,7 +12772,7 @@
(reftex-words-to-typekey-alist, reftex-key-to-index-macro-alist)
(reftex-query-index-macro-prompt, reftex-query-index-macro-help)
(reftex-no-follow-message, reftex-no-info-message): Likewise.
- (reftex-mode): Define systax table for bibtex parsing.
+ (reftex-mode): Define syntax table for bibtex parsing.
(reftex-syntax-table-for-bib): Syntax table for bibtex parsing.
* textmodes/reftex-cite.el (reftex-format-names): %a as name
@@ -15993,7 +15993,7 @@
* progmodes/cc-vars.el (c-offsets-alist): A more sane default
for `inexpr-statement'. This is not compatible, though.
- I think the benefit of a good default style outweights that in
+ I think the benefit of a good default style outweighs that in
this case. Besides, `inexpr-statement' is not very common.
2002-04-22 Martin Stjernholm <mast@lysator.liu.se>
diff --git a/lisp/ChangeLog.11 b/lisp/ChangeLog.11
index 3b430cafea4..0c72cb4c124 100644
--- a/lisp/ChangeLog.11
+++ b/lisp/ChangeLog.11
@@ -13392,7 +13392,7 @@
* progmodes/compile.el (compilation-error-regexp-alist):
Add Java ANt error detection as described in document
- http://ant.apache.org/faq.html
+ https://ant.apache.org/faq.html
2003-08-12 Juri Linkov <juri@jurta.org> (tiny change)
diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12
index 37727f4cd27..5d424570d83 100644
--- a/lisp/ChangeLog.12
+++ b/lisp/ChangeLog.12
@@ -16274,7 +16274,7 @@
(c-guess-basic-syntax): Adapt case 5B for the new
`c-just-after-func-arglist-p'. Merge cases 5B.1 and 5B.3.
- Remove cases 5D.1 and 5D.2 since they aren't trigged anymore (case 5B.1
+ Remove cases 5D.1 and 5D.2 since they aren't triggered anymore (case 5B.1
covers all cases now).
* progmodes/cc-defs.el (c-point): Add `bosws' and `eosws'.
@@ -32889,7 +32889,7 @@
2005-01-14 Nick Roberts <nickrob@snap.net.nz>
- * xt-mouse.el (xterm-mouse-event): Compute window co-ordinates
+ * xt-mouse.el (xterm-mouse-event): Compute window coordinates
more carefully.
2005-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
diff --git a/lisp/ChangeLog.13 b/lisp/ChangeLog.13
index 89e90ec3e22..d849bd88fcc 100644
--- a/lisp/ChangeLog.13
+++ b/lisp/ChangeLog.13
@@ -4765,7 +4765,7 @@
2007-12-30 Michael Albinus <michael.albinus@gmx.de>
* net/dbus.el (dbus-name-owner-changed-handler): Make the function
- resistent towards wrong parameters.
+ resistant towards wrong parameters.
(dbus-handle-event): Propagate D-Bus errors only in the debug case.
2007-12-30 Richard Stallman <rms@gnu.org>
@@ -5001,7 +5001,7 @@
* vc.el (vc-dired-ignorable-p, vc-dired-hook): Speed optimization;
use completion-ignored-extensions to detect files that should be
- ignorted in VC-Dired listings, heading off lots of expensive calls
+ ignored in VC-Dired listings, heading off lots of expensive calls
to (vc-state).
* vc.el (vc-dired-hook): Show unregistered file status as "?" in
diff --git a/lisp/ChangeLog.14 b/lisp/ChangeLog.14
index 063771c3c7c..edd5bdb7f9c 100644
--- a/lisp/ChangeLog.14
+++ b/lisp/ChangeLog.14
@@ -10889,7 +10889,7 @@
* menu-bar.el (menu-set-font): New function. Bind "Set Default
Font" menu item to it. Apply selected font to all frames, and
- make it savable.
+ make it saveable.
(menu-bar-options-save): Save `default' font if changed.
2008-06-10 Stefan Monnier <monnier@iro.umontreal.ca>
@@ -13625,7 +13625,7 @@
(completion-emacs22-try-completion): Place cursor after the /, as was
done in Emacs-22's minibuffer-complete-word.
Fix bug reported by David Hansen <david.hansen@gmx.net>.
- (completion-emacs22-try-completion): Merge all mergable text rather
+ (completion-emacs22-try-completion): Merge all mergeable text rather
than just /.
(completion-pcm--delim-wild-regex): New var.
(completion-pcm-word-delimiters): New custom.
diff --git a/lisp/ChangeLog.15 b/lisp/ChangeLog.15
index c090750e3df..bd1fbe61ad1 100644
--- a/lisp/ChangeLog.15
+++ b/lisp/ChangeLog.15
@@ -2803,7 +2803,7 @@
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 mergable by line-based text merging,
+ 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>
@@ -5135,10 +5135,10 @@
* 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
+ (verilog-extended-complete-re): Support 'pure' function & task
declarations (these have no bodies).
(verilog-beg-of-statement): General cleanup to enable support of
- 'pure' fucntion & task declarations (these have no bodies).
+ 'pure' function & 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)
@@ -10689,7 +10689,7 @@
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).
+ process every time when spellchecking from the minibuffer (bug#6143).
2010-05-13 Stefan Monnier <monnier@iro.umontreal.ca>
@@ -12100,7 +12100,7 @@
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
+ `image-extension-data'. Get GIF extension data from metadata
property `extension-data'.
2010-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
@@ -14907,7 +14907,7 @@
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.
+ when needed.
2009-12-02 Kenichi Handa <handa@m17n.org>
@@ -18684,7 +18684,7 @@
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
+ at end of line. Does not highlight 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.
diff --git a/lisp/ChangeLog.16 b/lisp/ChangeLog.16
index 7cdffd9724c..67b62767ed4 100644
--- a/lisp/ChangeLog.16
+++ b/lisp/ChangeLog.16
@@ -379,7 +379,7 @@
2013-02-28 Sam Steingold <sds@gnu.org>
* vc/diff-mode.el (diff-hunk-file-names): Handle filenames with spaces.
- See <http://stackoverflow.com/questions/14720205>.
+ See <https://stackoverflow.com/questions/14720205>.
2013-02-28 Thierry Volpiatto <thierry.volpiatto@gmail.com>
@@ -1326,7 +1326,7 @@
* net/soap-client.el (soap-invoke): Encode the string for
`url-request-data' as UTF-8.
- Fixes <http://code.google.com/p/emacs-soap-client/issues/detail?id=16>.
+ Fixes <https://code.google.com/p/emacs-soap-client/issues/detail?id=16>.
2013-02-01 Glenn Morris <rgm@gnu.org>
@@ -2462,7 +2462,7 @@
2012-12-27 Sam Steingold <sds@gnu.org>
* progmodes/cperl-mode.el (cperl-calculate-indent): Do not stagger
- continuations, see <http://stackoverflow.com/questions/3582436>.
+ continuations, see <https://stackoverflow.com/questions/3582436>.
2012-12-27 Dmitry Gutov <dgutov@yandex.ru>
@@ -3018,7 +3018,7 @@
* progmodes/sql.el: Use cl-lib and lexical-binding; various cleanup.
(sql-signum): Remove. Use `cl-signum' instead.
- (sql-read-passwd): Remove; use read-passwd instread.
+ (sql-read-passwd): Remove; use read-passwd instead.
(sql-get-login-ext): Use read-string.
(sql-get-login): Use dolist and pcase.
(sql--completion-table): Rename from sql-try-completion.
@@ -7833,7 +7833,7 @@
the form for POSITION argument.
* term/x-win.el (x-menu-bar-open):
- Use the value returend from (posn-at-point) as position
+ Use the value returned from (posn-at-point) as position
passed to `popup-menu'.
2012-08-09 Jay Belanger <jay.p.belanger@gmail.com>
@@ -11473,7 +11473,7 @@
(sh-set-shell): Use smie-setup if requested.
* term.el (term-set-escape-char): Properly set term-escape-char.
- See http://stackoverflow.com/questions/10524656.
+ See https://stackoverflow.com/questions/10524656.
2012-05-10 Chong Yidong <cyd@gnu.org>
@@ -11992,11 +11992,11 @@
* progmodes/verilog-mode.el (verilog-pretty-expr): Don't line up
assignment with tests in ifs and for loops.
(verilog-extended-complete-re, verilog-complete-reg): Change so
- that DPI inport functions don't look like function declarations.
+ that DPI import functions don't look like function declarations.
(verilog-pretty-expr): Don't line up assignment
operations to the test and increment in if and for loops
(verilog-extended-complete-re, verilog-complete-reg): Change so
- that DPI inport functions don't look like function declarations.
+ that DPI import functions don't look like function declarations.
2012-05-03 Kenichi Handa <handa@m17n.org>
@@ -15918,7 +15918,7 @@
Rework verilog-pretty-expr to handle new assignment operators in system
verilog, such as += *= and the like.
(verilog-assignment-operator-re): Regular expression to find the
- assigment operator in a verilog assignment.
+ assignment operator in a verilog assignment.
(verilog-assignment-operation-re): Regular expression to find an
assignment statement for pretty-expr.
(verilog-in-attribute-p): Query returns true if point is in an
@@ -16476,7 +16476,7 @@
(python-pdbtrack-track-stack-file): Adjust to recognize ipdb as well as
regular python pdb prompts. Adjustments shamelessly taken exactly as
suggested in EmacsWiki page (tiny change):
- http://www.emacswiki.org/PythonProgrammingInEmacs#toc14
+ https://www.emacswiki.org/PythonProgrammingInEmacs#toc14
2011-11-16 Juanma Barranquero <lekktu@gmail.com>
@@ -20442,7 +20442,7 @@
2011-07-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
* net/network-stream.el (open-network-stream): Use the
- :end-of-capability command thoughout.
+ :end-of-capability command throughout.
2011-07-03 Wolfgang Jenkner <wjenkner@inode.at> (tiny change)
@@ -21496,7 +21496,7 @@
* net/network-stream.el (open-network-stream): Add the keyword
:always-query-capabilities for the case where you want to force a
`plain' network connection, but the protocol still requires the
- capabilitiy command (i.e., SMTP and EHLO).
+ capability command (i.e., SMTP and EHLO).
* subr.el (process-live-p): Rename from `process-alive-p' for
consistency with other `-live-p' functions.
@@ -24707,7 +24707,7 @@
* 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)
+ (write-abbrev-file): New optional arg VERBOSE. (Bug#5937)
2011-03-29 Ken Manheimer <ken.manheimer@gmail.com>
diff --git a/lisp/ChangeLog.17 b/lisp/ChangeLog.17
index 21022e74f57..14a6c5d06e4 100644
--- a/lisp/ChangeLog.17
+++ b/lisp/ChangeLog.17
@@ -6540,8 +6540,8 @@
(newsticker--image-get): New arguments FILENAME and DIRECTORY.
Use `url-retrieve' if `newsticker-retrieval-method' is 'intern.
(newsticker--image-download-by-wget): New. Use process properties
- for storing informations.
- (newsticker--image-sentinel): Read informations from process properties.
+ for storing information.
+ (newsticker--image-sentinel): Read information from process properties.
(newsticker--image-save)
(newsticker--image-remove)
(newsticker--image-download-by-url)
@@ -8465,7 +8465,7 @@
2014-07-28 Glenn Morris <rgm@gnu.org>
* files.el (toggle-read-only): Re-add basic doc-string.
- * vc/vc-hooks.el (vc-toggle-read-only): Tweak obsolescence mesage.
+ * vc/vc-hooks.el (vc-toggle-read-only): Tweak obsolescence message.
* progmodes/prolog.el (prolog-mode-keybindings-edit):
Replace missing `switch-to-prolog' with `run-prolog'.
@@ -14399,7 +14399,7 @@
2014-01-05 Martin Rudalics <rudalics@gmx.at>
- * window.el (balance-windows): Add mising t to fix Bug#16351.
+ * window.el (balance-windows): Add missing t to fix Bug#16351.
2014-01-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -15098,7 +15098,7 @@
2013-12-18 Juri Linkov <juri@jurta.org>
* help-mode.el (help-mode-map): Bind "l" to help-go-back,
- and "r" to help-go-forward for compatibity with Info. (Bug#16178)
+ and "r" to help-go-forward for compatibility with Info. (Bug#16178)
2013-12-18 Leo Liu <sdl.web@gmail.com>
@@ -15729,7 +15729,7 @@
(flymake-get-temp-dir): Remove.
(flymake-popup-menu, flymake-nop, flymake-make-xemacs-menu)
(flymake-current-row, flymake-selected-frame)
- (flymake-get-point-pixel-pos): Remove xemacs compatibity and
+ (flymake-get-point-pixel-pos): Remove xemacs compatibility and
related functions. (Bug#16077)
2013-12-07 Bozhidar Batsov <bozhidar@batsov.com>
@@ -16822,7 +16822,7 @@
* emacs-lisp/byte-run.el (defmacro, defun): Set their `indent' property.
* electric.el (electric-indent-post-self-insert-function):
- Only delete trailing whitepsace if it is indeed trailing (bug#15767).
+ Only delete trailing whitespace if it is indeed trailing (bug#15767).
2013-11-04 Helmut Eller <eller.helmut@gmail.com>
@@ -17770,7 +17770,7 @@
2013-10-13 Kenichi Handa <handa@gnu.org>
* international/mule-cmds.el (select-safe-coding-system): Remove a
- superfluous condition in chekcing whether a coding system is safe
+ superfluous condition in checking whether a coding system is safe
or not.
2013-10-13 Oleh Krehel <ohwoeowho@gmail.com>
@@ -23495,7 +23495,7 @@
* progmodes/cc-defs.el (c-set-region-active, c-beginning-of-defun-1)
* progmodes/cc-mode.el (c-make-inherited-keymap): Use plain fboundp.
* progmodes/cc-defs.el (zmacs-region-stays, zmacs-regions)
- (lookup-syntax-properties): Remove unecessary cc-bytecomp-defvar.
+ (lookup-syntax-properties): Remove unnecessary cc-bytecomp-defvar.
* progmodes/cc-vars.el (other): Emacs has this widget since
at least 21.1, so don't (re)define it.
@@ -23951,7 +23951,7 @@
* simple.el (shell-command-on-region): Pass the `replace' argument
down to `call-process-region' to comply with the doc as reported on
- <http://stackoverflow.com/questions/16720458/emacs-noninteractive-call-to-shell-command-on-region-always-deletes-region>
+ <https://stackoverflow.com/questions/16720458/emacs-noninteractive-call-to-shell-command-on-region-always-deletes-region>
2013-05-23 Stefan Monnier <monnier@iro.umontreal.ca>
diff --git a/lisp/ChangeLog.3 b/lisp/ChangeLog.3
index c88107205e8..a4470b9cfda 100644
--- a/lisp/ChangeLog.3
+++ b/lisp/ChangeLog.3
@@ -6958,7 +6958,7 @@
1991-10-04 Roland McGrath (roland@albert.gnu.ai.mit.edu)
* rmail.el: Changed two regexps not to look specifically for 19yy
- for years; look for yyyy instead. Planning for the millenium.
+ for years; look for yyyy instead. Planning for the millennium.
1991-10-03 Roland McGrath (roland@albert.gnu.ai.mit.edu)
diff --git a/lisp/ChangeLog.6 b/lisp/ChangeLog.6
index f6442e37ded..492dae18e01 100644
--- a/lisp/ChangeLog.6
+++ b/lisp/ChangeLog.6
@@ -6742,7 +6742,7 @@
quoted tab into a space.
(sh-mode): Use new `skeleton-newline-indent-rigidly'.
(sh-set-shell): Make maximum font-locking also highlight keywords
- after ``' and `!'. (The latter is for ksh '93 but should't hurt other
+ after ``' and `!'. (The latter is for ksh '93 but shouldn't hurt other
shells.)
1995-08-18 Andre Spiegel <spiegel@berlin.informatik.uni-stuttgart.de>
diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7
index c787a6605a6..3de3f2f1571 100644
--- a/lisp/ChangeLog.7
+++ b/lisp/ChangeLog.7
@@ -5774,7 +5774,7 @@
1998-03-06 Dave Love <d.love@dl.ac.uk>
- * browse-url.el: Various doc fixes, mainly to remove innappropriate
+ * browse-url.el: Various doc fixes, mainly to remove inappropriate
leading "*"s.
(browse-url-new-window-p, browse-url-netscape-display)
(browse-url-save-file, browse-url-generic-program):
@@ -10843,7 +10843,7 @@
1997-09-06 Michael Kifer <kifer@cs.sunysb.edu>
* ediff-ptch.el (ediff-patch-buffer-internal):
- now behaves uniformely, whether the buffer
+ now behaves uniformly, whether the buffer
visits a file or not.
* ediff-util.el (ediff-other-buffer): Smarter selection of
suitable other buffer.
@@ -11291,7 +11291,7 @@
the various new variables mentioned above. Accept the `a' key to
use all selected citations.
(reftex-insert-bib-matches): New function.
- (reftex-format-citation): Now interpretes % escapes.
+ (reftex-format-citation): Now interprets % escapes.
(reftex-select-item): Emulate a search in the menu buffer.
Interpret the 'cnt text property.
(reftex-view-crossref): Allow more general label, cite and ref macros.
diff --git a/lisp/ChangeLog.8 b/lisp/ChangeLog.8
index 68ac8dbf6a5..3027463e539 100644
--- a/lisp/ChangeLog.8
+++ b/lisp/ChangeLog.8
@@ -7002,7 +7002,7 @@
1999-01-13 Eli Zaretskii <eliz@gnu.org>
* international/codepage.el (cp850-decode-table): Replace nil
- entries with codes of similary looking glyphs. (
+ entries with codes of similarly looking glyphs. (
Suggested by Jason Rumney <jasonr@altavista.net>.)
1999-01-13 Dave Love <fx@gnu.org>
@@ -7469,7 +7469,7 @@
(cperl-forward-re): Highlight the trailing / in s/foo// as string.
Highlight the starting // in s//foo/ as function-name.
Emit a meaningful error instead of a cryptic one for an
- uncomplete REx near end-of-buffer.
+ incomplete REx near end-of-buffer.
(cperl-electric-keyword): `qr' recognized.
(cperl-electric-else): Likewise.
diff --git a/lisp/ChangeLog.9 b/lisp/ChangeLog.9
index 0db318aab08..a8ef2ffa447 100644
--- a/lisp/ChangeLog.9
+++ b/lisp/ChangeLog.9
@@ -237,8 +237,8 @@
After 4.28:
(cperl-forward-re): Throw an error at proper moment REx unfinished.
After 4.29:
- (x-color-defined-p): Make an extra case to peacify the warning.
- Toplevel: `defvar' to peacify the warnings.
+ (x-color-defined-p): Make an extra case to pacify the warning.
+ Toplevel: `defvar' to pacify the warnings.
(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.
@@ -1183,7 +1183,7 @@
2001-09-07 Gerd Moellmann <gerd@gnu.org>
* isearch.el (isearch-intersects-p): New function.
- (isearch-close-unnecessary-overlays): Rename from *unecessary*,
+ (isearch-close-unnecessary-overlays): Rename from *unnecessary*,
use isearch-intersects-p, and clean up.
2001-09-07 Eli Zaretskii <eliz@is.elta.co.il>
@@ -12432,7 +12432,7 @@
is not reached. It is.
(vc-cvs-merge): Set state to 'edited after merge.
(vc-cvs-merge-news): Set workfile version to nil if not known.
- (vc-cvs-latest-on-branch-p): Recommented. Candidate for removal.
+ (vc-cvs-latest-on-branch-p): Recommended. Candidate for removal.
* vc-cvs.el, vc-rcs.el, vc-sccs.el (vc-*-checkout): Switch off
coding systems for checkout via stdout. (Merge from main line.)
@@ -13371,7 +13371,7 @@
if defined. (Merged from main line, slightly adapted.)
* vc-cvs.el (vc-cvs-annotate-difference): Handle possible
- millenium problem (merged from mainline).
+ millennium problem (merged from mainline).
2000-09-04 Martin Lorentzson <martinl@gnu.org>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 7d3defa0470..431217a9dac 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -21,6 +21,7 @@ SHELL = @SHELL@
srcdir = @srcdir@
top_srcdir = @top_srcdir@
+top_builddir = @top_builddir@
lisp = $(srcdir)
VPATH = $(srcdir)
EXEEXT = @EXEEXT@
@@ -29,24 +30,14 @@ EXEEXT = @EXEEXT@
# limitation.
XARGS_LIMIT = @XARGS_LIMIT@
-# 'make' verbosity.
-AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
-
-AM_V_ELC = $(am__v_ELC_@AM_V@)
-am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@)
-am__v_ELC_0 = @echo " ELC " $@;
-am__v_ELC_1 =
-
-AM_V_GEN = $(am__v_GEN_@AM_V@)
-am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
-am__v_GEN_0 = @echo " GEN " $@;
-am__v_GEN_1 =
-
-AM_V_at = $(am__v_at_@AM_V@)
-am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
-am__v_at_0 = @
-am__v_at_1 =
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ifndef NATIVE_FULL_AOT
+NATIVE_SKIP_NONDUMP = 1
+endif
+endif
+-include ${top_builddir}/src/verbose.mk
FIND_DELETE = @FIND_DELETE@
@@ -98,8 +89,12 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/macroexp.elc \
$(lisp)/emacs-lisp/cconv.elc \
$(lisp)/emacs-lisp/byte-opt.elc \
- $(lisp)/emacs-lisp/bytecomp.elc \
- $(lisp)/emacs-lisp/autoload.elc
+ $(lisp)/emacs-lisp/bytecomp.elc
+ifeq ($(HAVE_NATIVE_COMP),yes)
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
+endif
+COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc
# Files to compile early in compile-main. Works around bug#25556.
MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \
@@ -196,7 +191,6 @@ $(lisp)/finder-inf.el:
autoloads .PHONY: $(lisp)/loaddefs.el
$(lisp)/loaddefs.el: gen-lisp $(LOADDEFS)
- @echo Directories for loaddefs: ${SUBDIRS_ALMOST}
$(AM_V_GEN)$(emacs) -l autoload \
--eval '(setq autoload-ensure-writable t)' \
--eval '(setq autoload-builtin-package-versions t)' \
@@ -208,7 +202,7 @@ $(lisp)/loaddefs.el: gen-lisp $(LOADDEFS)
# regeneration of all these files.
.PHONY: autoloads-force
autoloads-force:
- rm loaddefs.el
+ rm -f $(lisp)/loaddefs.el
$(MAKE) autoloads
# This is required by the bootstrap-emacs target in ../src/Makefile, so
@@ -277,9 +271,15 @@ TAGS: ${ETAGS} ${tagsfiles}
THEFILE = no-such-file
.PHONY: $(THEFILE)c
$(THEFILE)c:
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
+ -l comp -f byte-compile-refresh-preloaded \
+ -f batch-byte+native-compile $(THEFILE)
+else
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
-f batch-byte-compile $(THEFILE)
+endif
# 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
@@ -292,8 +292,14 @@ $(THEFILE)c:
# An old-fashioned suffix rule, which, according to the GNU Make manual,
# cannot have prerequisites.
+ifeq ($(HAVE_NATIVE_COMP),yes)
+.el.elc:
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
+ -l comp -f batch-byte+native-compile $<
+else
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
+endif
.PHONY: compile-first compile-main compile compile-always
@@ -311,7 +317,13 @@ compile-first: $(COMPILE_FIRST)
.PHONY: compile-targets
# TARGETS is set dynamically in the recursive call from 'compile-main'.
+# Do not build comp.el unless necessary not to exceed max-specpdl-size and
+# max-lisp-eval-depth in normal builds.
+ifneq ($(HAVE_NATIVE_COMP),yes)
+compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out ./emacs-lisp/comp.elc,$(TARGETS)))
+else
compile-targets: $(TARGETS)
+endif
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
@@ -324,9 +336,11 @@ compile-main: gen-lisp compile-clean
GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \
continue; \
echo "$${el}c"; \
- done | xargs $(XARGS_LIMIT) echo) | \
- while read chunk; do \
- $(MAKE) compile-targets TARGETS="$$chunk"; \
+ done | xargs $(XARGS_LIMIT) echo) | \
+ while read chunk; do \
+ $(MAKE) compile-targets \
+ NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \
+ TARGETS="$$chunk"; \
done
.PHONY: compile-clean
@@ -453,7 +467,7 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el
--eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \
-f batch-update-autoloads $(CAL_DIR)
-.PHONY: bootstrap-clean distclean maintainer-clean extraclean
+.PHONY: bootstrap-clean distclean maintainer-clean
bootstrap-clean:
find $(lisp) -name '*.elc' $(FIND_DELETE)
@@ -465,10 +479,6 @@ distclean:
maintainer-clean: distclean bootstrap-clean
rm -f TAGS
-extraclean: bootstrap-clean distclean
- -for file in $(LOADDEFS); do rm -f $${file}~; done
- -rm -f $(lisp)/loaddefs.el~
-
.PHONY: check-declare
check-declare:
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index 1eeaf6d021b..54783db2c3e 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -189,17 +189,21 @@ the ones defined from the buffer now."
(table (read buf))
abbrevs name hook exp count sys)
(forward-line 1)
- (while (progn (forward-line 1)
- (not (eolp)))
- (setq name (read buf) count (read buf))
- (if (equal count '(sys))
- (setq sys t count (read buf))
- (setq sys nil))
- (setq exp (read buf))
- (skip-chars-backward " \t\n\f")
- (setq hook (if (not (eolp)) (read buf)))
- (skip-chars-backward " \t\n\f")
- (setq abbrevs (cons (list name exp hook count sys) abbrevs)))
+ (while (and (not (eobp))
+ ;; Advance as long as we're looking at blank lines
+ ;; or we have an abbrev.
+ (looking-at "[ \t\n]\\|\\(\"\\)"))
+ (when (match-string 1)
+ (setq name (read buf) count (read buf))
+ (if (equal count '(sys))
+ (setq sys t count (read buf))
+ (setq sys nil))
+ (setq exp (read buf))
+ (skip-chars-backward " \t\n\f")
+ (setq hook (if (not (eolp)) (read buf)))
+ (skip-chars-backward " \t\n\f")
+ (setq abbrevs (cons (list name exp hook count sys) abbrevs)))
+ (forward-line 1))
(define-abbrev-table table abbrevs)))))
(defun read-abbrev-file (&optional file quietly)
@@ -209,8 +213,7 @@ it defaults to the value of `abbrev-file-name'.
Optional second argument QUIETLY non-nil means don't display a message."
(interactive
(list
- (read-file-name (format "Read abbrev file (default %s): "
- abbrev-file-name)
+ (read-file-name (format-prompt "Read abbrev file" abbrev-file-name)
nil abbrev-file-name t)))
(load (or file abbrev-file-name) nil quietly)
(setq abbrevs-changed nil))
@@ -255,11 +258,7 @@ have been saved."
(if (abbrev--table-symbols table)
(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)))
+ (setq coding-system-for-write 'utf-8-emacs))
(goto-char (point-min))
(insert (format ";;-*-coding: %s;-*-\n" coding-system-for-write))
(write-region nil nil file nil (and (not verbose) 0)))))
@@ -517,17 +516,8 @@ It is nil if the abbrev has already been unexpanded.")
(defvar last-abbrev-location 0
"The location of the start of the last abbrev expanded.")
-;; (defvar local-abbrev-table fundamental-mode-abbrev-table
+;; (defvar-local local-abbrev-table fundamental-mode-abbrev-table
;; "Local (mode-specific) abbrev table of current buffer.")
-;; (make-variable-buffer-local 'local-abbrev-table)
-
-(defcustom pre-abbrev-expand-hook nil
- "Function or functions to be called before abbrev expansion is done.
-This is the first thing that `expand-abbrev' does, and so this may change
-the current abbrev table before abbrev lookup happens."
- :type 'hook
- :group 'abbrev-mode)
-(make-obsolete-variable 'pre-abbrev-expand-hook 'abbrev-expand-function "23.1")
(defun clear-abbrev-table (table)
"Undefine all abbrevs in abbrev table TABLE, leaving it empty."
@@ -837,16 +827,155 @@ see `define-abbrev' for details."
"Function that `expand-abbrev' uses to perform abbrev expansion.
Takes no argument and should return the abbrev symbol if expansion took place.")
+(defcustom abbrev-suggest nil
+ "Non-nil means suggest using abbrevs to save typing.
+When abbrev mode is active and this option is non-nil, Emacs will
+suggest in the echo area to use an existing abbrev if doing so
+will save enough typing. See `abbrev-suggest-hint-threshold' for
+the definition of \"enough typing\"."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom abbrev-suggest-hint-threshold 3
+ "Threshold for when to suggest to use an abbrev to save typing.
+The threshold is the amount of typing, in terms of the number of
+characters, that would be saved by using the abbrev. The
+thinking is that if the expansion is only a few characters
+longer than the abbrev, the benefit of informing the user is not
+significant. If you always want to be informed about existing
+abbrevs for the text you type, set this value to zero or less.
+This setting only applies if `abbrev-suggest' is non-nil."
+ :type 'number
+ :version "28.1")
+
+(defun abbrev--suggest-get-active-tables-including-parents ()
+ "Return a list of all active abbrev tables, including parent tables."
+ (let* ((tables (abbrev--active-tables))
+ (all tables))
+ (dolist (table tables)
+ (setq all (append (abbrev-table-get table :parents) all)))
+ all))
+
+(defun abbrev--suggest-get-active-abbrev-expansions ()
+ "Return a list of all the active abbrev expansions.
+Includes expansions from parent abbrev tables."
+ (let (expansions)
+ (dolist (table (abbrev--suggest-get-active-tables-including-parents))
+ (mapatoms (lambda (e)
+ (let ((value (symbol-value (abbrev--symbol e table))))
+ (when value
+ (push (cons value (symbol-name e)) expansions))))
+ table))
+ expansions))
+
+(defun abbrev--suggest-count-words (expansion)
+ "Return the number of words in EXPANSION.
+Expansion is a string of one or more words."
+ (length (split-string expansion " " t)))
+
+(defun abbrev--suggest-get-previous-words (n)
+ "Return the N words before point, spaces included."
+ (let ((end (point)))
+ (save-excursion
+ (backward-word n)
+ (replace-regexp-in-string
+ "\\s " " "
+ (buffer-substring-no-properties (point) end)))))
+
+(defun abbrev--suggest-above-threshold (expansion)
+ "Return non-nil if the abbrev in EXPANSION provides significant savings.
+A significant saving, here, is the difference in length between
+the abbrev and the abbrev expansion. EXPANSION is a cons cell
+where the car is the expansion and the cdr is the abbrev."
+ (>= (- (length (car expansion))
+ (length (cdr expansion)))
+ abbrev-suggest-hint-threshold))
+
+(defvar abbrev--suggest-saved-recommendations nil
+ "Keeps a list of expansions that have abbrevs defined.
+The user can show this list by calling
+`abbrev-suggest-show-report'.")
+
+(defun abbrev--suggest-inform-user (expansion)
+ "Display a message to the user about the existing abbrev.
+EXPANSION is a cons cell where the `car' is the expansion and the
+`cdr' is the abbrev."
+ (run-with-idle-timer
+ 1 nil
+ (lambda ()
+ (message "You can write `%s' using the abbrev `%s'."
+ (car expansion) (cdr expansion))))
+ (push expansion abbrev--suggest-saved-recommendations))
+
+(defun abbrev--suggest-shortest-abbrev (new current)
+ "Return the shortest abbrev of NEW and CURRENT.
+NEW and CURRENT are cons cells where the `car' is the expansion
+and the `cdr' is the abbrev."
+ (if (not current)
+ new
+ (if (< (length (cdr new))
+ (length (cdr current)))
+ new
+ current)))
+
+(defun abbrev--suggest-maybe-suggest ()
+ "Suggest an abbrev to the user based on the word(s) before point.
+Uses `abbrev-suggest-hint-threshold' to find out if the user should be
+informed about the existing abbrev."
+ (let (words abbrev-found word-count)
+ (dolist (expansion (abbrev--suggest-get-active-abbrev-expansions))
+ (setq word-count (abbrev--suggest-count-words (car expansion))
+ words (abbrev--suggest-get-previous-words word-count))
+ (let ((case-fold-search t))
+ (when (and (> word-count 0)
+ (string-match (car expansion) words)
+ (abbrev--suggest-above-threshold expansion))
+ (setq abbrev-found (abbrev--suggest-shortest-abbrev
+ expansion abbrev-found)))))
+ (when abbrev-found
+ (abbrev--suggest-inform-user abbrev-found))))
+
+(defun abbrev--suggest-get-totals ()
+ "Return a list of all expansions and how many times they were used.
+Each expansion is a cons cell where the `car' is the expansion
+and the `cdr' is the number of times the expansion has been
+typed."
+ (let (total cell)
+ (dolist (expansion abbrev--suggest-saved-recommendations)
+ (if (not (assoc (car expansion) total))
+ (push (cons (car expansion) 1) total)
+ (setq cell (assoc (car expansion) total))
+ (setcdr cell (1+ (cdr cell)))))
+ total))
+
+(defun abbrev-suggest-show-report ()
+ "Show a buffer with the list of abbrevs you could have used.
+This shows the abbrevs you've \"missed\" because you typed the
+full text instead of the abbrevs that expand into that text."
+ (interactive)
+ (let ((totals (abbrev--suggest-get-totals))
+ (buf (get-buffer-create "*abbrev-suggest*")))
+ (set-buffer buf)
+ (erase-buffer)
+ (insert "** Abbrev expansion usage **
+
+Below is a list of expansions for which abbrevs are defined, and
+the number of times the expansion was typed manually. To display
+and edit all abbrevs, type `M-x edit-abbrevs RET'\n\n")
+ (dolist (expansion totals)
+ (insert (format " %s: %d\n" (car expansion) (cdr expansion))))
+ (display-buffer buf)))
+
(defun expand-abbrev ()
"Expand the abbrev before point, if there is an abbrev there.
Effective when explicitly called even when `abbrev-mode' is nil.
-Before doing anything else, runs `pre-abbrev-expand-hook'.
Calls the value of `abbrev-expand-function' with no argument to do
the work, and returns whatever it does. (That return value should
be the abbrev symbol if expansion occurred, else nil.)"
(interactive)
- (run-hooks 'pre-abbrev-expand-hook)
- (funcall abbrev-expand-function))
+ (or (funcall abbrev-expand-function)
+ (if abbrev-suggest
+ (abbrev--suggest-maybe-suggest))))
(defun abbrev--default-expand ()
"Default function to use for `abbrev-expand-function'.
diff --git a/lisp/align.el b/lisp/align.el
index 6e4a32705e3..a0b626a5c43 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -129,6 +129,8 @@
"Hook that gets run after the aligner has been loaded."
:type 'hook
:group 'align)
+(make-obsolete-variable 'align-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom align-indent-before-aligning nil
"If non-nil, indent the marked region before aligning it."
@@ -387,7 +389,7 @@ The possible settings for `align-region-separate' are:
(regexp . "\\(^\\s-+[^( \t\n]\\|(\\(\\S-+\\)\\s-+\\)\\S-+\\(\\s-+\\)")
(group . 3)
(modes . align-lisp-modes)
- (run-if . ,(function (lambda () current-prefix-arg))))
+ (run-if . ,(lambda () current-prefix-arg)))
(lisp-alist-dot
(regexp . "\\(\\s-*\\)\\.\\(\\s-*\\)")
@@ -395,13 +397,12 @@ The possible settings for `align-region-separate' are:
(modes . align-lisp-modes))
(open-comment
- (regexp . ,(function
- (lambda (end reverse)
- (funcall (if reverse 're-search-backward
- 're-search-forward)
- (concat "[^ \t\n\\]"
- (regexp-quote comment-start)
- "\\(.+\\)$") end t))))
+ (regexp . ,(lambda (end reverse)
+ (funcall (if reverse 're-search-backward
+ 're-search-forward)
+ (concat "[^ \t\n\\]"
+ (regexp-quote comment-start)
+ "\\(.+\\)$") end t)))
(modes . align-open-comment-modes))
(c-macro-definition
@@ -409,25 +410,24 @@ The possible settings for `align-region-separate' are:
(modes . align-c++-modes))
(c-variable-declaration
- (regexp . ,(concat "[*&0-9A-Za-z_]>?[&*]*\\(\\s-+[*&]*\\)"
- "[A-Za-z_][0-9A-Za-z:_]*\\s-*\\(\\()\\|"
+ (regexp . ,(concat "[*&0-9A-Za-z_]>?[][&*]*\\(\\s-+[*&]*\\)"
+ "[A-Za-z_][][0-9A-Za-z:_]*\\s-*\\(\\()\\|"
"=[^=\n].*\\|(.*)\\|\\(\\[.*\\]\\)*\\)"
"\\s-*[;,]\\|)\\s-*$\\)"))
(group . 1)
(modes . align-c++-modes)
(justify . t)
(valid
- . ,(function
- (lambda ()
- (not (or (save-excursion
- (goto-char (match-beginning 1))
- (backward-word 1)
- (looking-at
- "\\(goto\\|return\\|new\\|delete\\|throw\\)"))
- (if (and (boundp 'font-lock-mode) font-lock-mode)
- (eq (get-text-property (point) 'face)
- 'font-lock-comment-face)
- (eq (caar (c-guess-basic-syntax)) 'c))))))))
+ . ,(lambda ()
+ (not (or (save-excursion
+ (goto-char (match-beginning 1))
+ (backward-word 1)
+ (looking-at
+ "\\(goto\\|return\\|new\\|delete\\|throw\\)"))
+ (if font-lock-mode
+ (eq (get-text-property (point) 'face)
+ 'font-lock-comment-face)
+ (eq (caar (c-guess-basic-syntax)) 'c)))))))
(c-assignment
(regexp . ,(concat "[^-=!^&*+<>/| \t\n]\\(\\s-*[-=!^&*+<>/|]*\\)"
@@ -461,14 +461,13 @@ The possible settings for `align-region-separate' are:
(regexp . ",\\(\\s-*\\)[^/ \t\n]")
(repeat . t)
(modes . align-c++-modes)
- (run-if . ,(function (lambda () current-prefix-arg))))
+ (run-if . ,(lambda () current-prefix-arg)))
; (valid
- ; . ,(function
- ; (lambda ()
+ ; . ,(lambda ()
; (memq (caar (c-guess-basic-syntax))
; '(brace-list-intro
; brace-list-entry
- ; brace-entry-open))))))
+ ; brace-entry-open)))))
;; With a prefix argument, comma delimiter will be aligned. Since
;; perl-mode doesn't give us enough syntactic information (and we
@@ -478,77 +477,69 @@ The possible settings for `align-region-separate' are:
(regexp . ",\\(\\s-*\\)[^# \t\n]")
(repeat . t)
(modes . (append align-perl-modes '(python-mode)))
- (run-if . ,(function (lambda () current-prefix-arg))))
+ (run-if . ,(lambda () current-prefix-arg)))
(c++-comment
(regexp . "\\(\\s-*\\)\\(//.*\\|/\\*.*\\*/\\s-*\\)$")
(modes . align-c++-modes)
(column . comment-column)
- (valid . ,(function
- (lambda ()
- (save-excursion
- (goto-char (match-beginning 1))
- (not (bolp)))))))
+ (valid . ,(lambda ()
+ (save-excursion
+ (goto-char (match-beginning 1))
+ (not (bolp))))))
(c-chain-logic
(regexp . "\\(\\s-*\\)\\(&&\\|||\\|\\<and\\>\\|\\<or\\>\\)")
(modes . align-c++-modes)
- (valid . ,(function
- (lambda ()
- (save-excursion
- (goto-char (match-end 2))
- (looking-at "\\s-*\\(/[*/]\\|$\\)"))))))
+ (valid . ,(lambda ()
+ (save-excursion
+ (goto-char (match-end 2))
+ (looking-at "\\s-*\\(/[*/]\\|$\\)")))))
(perl-chain-logic
(regexp . "\\(\\s-*\\)\\(&&\\|||\\|\\<and\\>\\|\\<or\\>\\)")
(modes . align-perl-modes)
- (valid . ,(function
- (lambda ()
- (save-excursion
- (goto-char (match-end 2))
- (looking-at "\\s-*\\(#\\|$\\)"))))))
+ (valid . ,(lambda ()
+ (save-excursion
+ (goto-char (match-end 2))
+ (looking-at "\\s-*\\(#\\|$\\)")))))
(python-chain-logic
(regexp . "\\(\\s-*\\)\\(\\<and\\>\\|\\<or\\>\\)")
(modes . '(python-mode))
- (valid . ,(function
- (lambda ()
- (save-excursion
- (goto-char (match-end 2))
- (looking-at "\\s-*\\(#\\|$\\|\\\\\\)"))))))
+ (valid . ,(lambda ()
+ (save-excursion
+ (goto-char (match-end 2))
+ (looking-at "\\s-*\\(#\\|$\\|\\\\\\)")))))
(c-macro-line-continuation
(regexp . "\\(\\s-*\\)\\\\$")
(modes . align-c++-modes)
(column . c-backslash-column))
; (valid
- ; . ,(function
- ; (lambda ()
+ ; . ,(lambda ()
; (memq (caar (c-guess-basic-syntax))
- ; '(cpp-macro cpp-macro-cont))))))
+ ; '(cpp-macro cpp-macro-cont)))))
(basic-line-continuation
(regexp . "\\(\\s-*\\)\\\\$")
(modes . '(python-mode makefile-mode)))
(tex-record-separator
- (regexp . ,(function
- (lambda (end reverse)
- (align-match-tex-pattern "&" end reverse))))
+ (regexp . ,(lambda (end reverse)
+ (align-match-tex-pattern "&" end reverse)))
(group . (1 2))
(modes . align-tex-modes)
(repeat . t))
(tex-tabbing-separator
- (regexp . ,(function
- (lambda (end reverse)
- (align-match-tex-pattern "\\\\[=>]" end reverse))))
+ (regexp . ,(lambda (end reverse)
+ (align-match-tex-pattern "\\\\[=>]" end reverse)))
(group . (1 2))
(modes . align-tex-modes)
(repeat . t)
- (run-if . ,(function
- (lambda ()
- (eq major-mode 'latex-mode)))))
+ (run-if . ,(lambda ()
+ (eq major-mode 'latex-mode))))
(tex-record-break
(regexp . "\\(\\s-*\\)\\\\\\\\")
@@ -561,10 +552,9 @@ The possible settings for `align-region-separate' are:
(group . 2)
(modes . align-text-modes)
(repeat . t)
- (run-if . ,(function
- (lambda ()
- (and current-prefix-arg
- (not (eq '- current-prefix-arg)))))))
+ (run-if . ,(lambda ()
+ (and current-prefix-arg
+ (not (eq '- current-prefix-arg))))))
;; With a negative prefix argument, lists of dollar figures will
;; be aligned.
@@ -572,9 +562,8 @@ The possible settings for `align-region-separate' are:
(regexp . "\\$?\\(\\s-+[0-9]+\\)\\.")
(modes . align-text-modes)
(justify . t)
- (run-if . ,(function
- (lambda ()
- (eq '- current-prefix-arg)))))
+ (run-if . ,(lambda ()
+ (eq '- current-prefix-arg))))
(css-declaration
(regexp . "^\\s-*\\(?:\\w-?\\)+:\\(\\s-*\\).*;")
@@ -755,13 +744,12 @@ The following attributes are meaningful:
(exc-open-comment
(regexp
- . ,(function
- (lambda (end reverse)
- (funcall (if reverse 're-search-backward
- 're-search-forward)
- (concat "[^ \t\n\\]"
- (regexp-quote comment-start)
- "\\(.+\\)$") end t))))
+ . ,(lambda (end reverse)
+ (funcall (if reverse 're-search-backward
+ 're-search-forward)
+ (concat "[^ \t\n\\]"
+ (regexp-quote comment-start)
+ "\\(.+\\)$") end t)))
(modes . align-open-comment-modes))
(exc-c-comment
@@ -787,18 +775,14 @@ See the documentation for `align-rules-list' for more info."
;;; Internal Variables:
-(defvar align-mode-rules-list nil
+(defvar-local align-mode-rules-list nil
"Alignment rules specific to the current major mode.
See the variable `align-rules-list' for more details.")
-(make-variable-buffer-local 'align-mode-rules-list)
-
-(defvar align-mode-exclude-rules-list nil
+(defvar-local align-mode-exclude-rules-list nil
"Alignment exclusion rules specific to the current major mode.
See the variable `align-exclude-rules-list' for more details.")
-(make-variable-buffer-local 'align-mode-exclude-rules-list)
-
(defvar align-highlight-overlays nil
"The current overlays highlighting the text matched by a rule.")
@@ -815,10 +799,9 @@ See the variable `align-exclude-rules-list' for more details.")
(regexp . "\\(others\\|[^ \t\n=<]\\)\\(\\s-*\\)=>\\(\\s-*\\)\\S-")
(group . (2 3))
(valid
- . ,(function
- (lambda ()
- (not (string= (downcase (match-string 1))
- "others"))))))
+ . ,(lambda ()
+ (not (string= (downcase (match-string 1))
+ "others")))))
(vhdl-colon
(regexp . "[^ \t\n:]\\(\\s-*\\):\\(\\s-*\\)[^=\n]")
@@ -1002,9 +985,8 @@ to be colored."
(completing-read
"Title of rule to highlight: "
(mapcar
- (function
- (lambda (rule)
- (list (symbol-name (car rule)))))
+ (lambda (rule)
+ (list (symbol-name (car rule))))
(append (or align-mode-rules-list align-rules-list)
(or align-mode-exclude-rules-list
align-exclude-rules-list))) nil t)))
@@ -1021,21 +1003,20 @@ to be colored."
(or align-mode-rules-list align-rules-list)))
(unless ex-rule (or exclude-rules align-mode-exclude-rules-list
align-exclude-rules-list))
- (function
- (lambda (b e mode)
- (if (and mode (listp mode))
- (if (equal (symbol-name (car mode)) title)
- (setq face (cons align-highlight-change-face
- align-highlight-nochange-face))
- (setq face nil))
- (when face
- (let ((overlay (make-overlay b e)))
- (setq align-highlight-overlays
- (cons overlay align-highlight-overlays))
- (overlay-put overlay 'face
- (if mode
- (car face)
- (cdr face)))))))))))
+ (lambda (b e mode)
+ (if (and mode (listp mode))
+ (if (equal (symbol-name (car mode)) title)
+ (setq face (cons align-highlight-change-face
+ align-highlight-nochange-face))
+ (setq face nil))
+ (when face
+ (let ((overlay (make-overlay b e)))
+ (setq align-highlight-overlays
+ (cons overlay align-highlight-overlays))
+ (overlay-put overlay 'face
+ (if mode
+ (car face)
+ (cdr face))))))))))
;;;###autoload
(defun align-unhighlight-rule ()
@@ -1329,7 +1310,7 @@ aligner would have dealt with are."
(thissep (if rulesep (cdr rulesep) separate))
same (eol 0)
search-start
- groups group-c
+ groups ;; group-c
spacing spacing-c
tab-stop tab-stop-c
repeat repeat-c
@@ -1453,7 +1434,7 @@ aligner would have dealt with are."
;; lookup the `group' attribute the first time
;; that we need it
- (unless group-c
+ (unless nil ;; group-c
(setq groups (or (cdr (assq 'group rule)) 1))
(unless (listp groups)
(setq groups (list groups)))
@@ -1606,8 +1587,6 @@ aligner would have dealt with are."
(if report
(message "Aligning...done"))))
-;; Provide:
-
(provide 'align)
(run-hooks 'align-load-hook)
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
index 59419786981..0e127040886 100644
--- a/lisp/allout-widgets.el
+++ b/lisp/allout-widgets.el
@@ -1,4 +1,4 @@
-;; allout-widgets.el --- Visually highlight allout outline structure.
+;;; allout-widgets.el --- Visually highlight allout outline structure. -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -6,7 +6,7 @@
;; Version: 1.0
;; Created: Dec 2005
;; Keywords: outlines
-;; Website: http://myriadicity.net/software-and-systems/craft/emacs-allout
+;; Website: https://myriadicity.net/software-and-systems/craft/emacs-allout
;; This file is part of GNU Emacs.
@@ -38,7 +38,7 @@
;; See the `allout-widgets-mode' docstring for more details.
;;
;; Info about allout and allout-widgets development are available at
-;; http://myriadicity.net/Sundry/EmacsAllout
+;; https://myriadicity.net/software-and-systems/craft/emacs-allout
;;
;; The graphics include:
;;
@@ -72,15 +72,14 @@
(eval-when-compile (require 'cl-lib))
;;;_ : 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.
+;; 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
+(defvar-local 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
@@ -101,8 +100,8 @@ with allout-mode."
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)
+ (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 ()
@@ -110,8 +109,8 @@ inhibition of allout-widgets-mode."
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)
+ (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
@@ -142,7 +141,7 @@ See `allout-widgets-mode' for allout widgets mode features."
:version "24.1"
:type 'boolean
:group 'allout-widgets
- :set 'allout-widgets-setup
+ :set #'allout-widgets-setup
)
;; ;;;_ = allout-widgets-allow-unruly-edits
;; (defcustom allout-widgets-allow-unruly-edits nil
@@ -207,22 +206,8 @@ See `allout-widgets-mode' for allout widgets mode features."
:version "24.1"
:type 'plist
:group 'allout-widgets)
+(make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1")
;;;_ . 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."
- :version "24.1"
- :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.
@@ -257,18 +242,17 @@ decreases as obsolete widgets are garbage collected."
:version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
-(defvar allout-widgets-tally nil
+(defvar-local allout-widgets-tally nil
"Hash-table of existing allout widgets, for debugging.
Table is maintained only if `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.
+ "Return a string with number of tracked widgets, or empty string if not tracking.
The string is formed for appending to the allout-mode mode-line lighter.
@@ -309,7 +293,7 @@ to publicize it by making it a customization variable)."
(message "%s" msg)
msg))
;;;_ = allout-widgets-mode-inhibit
-(defvar allout-widgets-mode-inhibit nil
+(defvar-local allout-widgets-mode-inhibit nil
"Inhibit `allout-widgets-mode' from activating widgets.
This also inhibits automatic adjustment of widgets to track allout outline
@@ -323,17 +307,14 @@ 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)
+(put 'allout-widgets-mode-inhibit 'safe-local-variable #'booleanp)
;;;_ = allout-inhibit-body-modification-hook
-(defvar allout-inhibit-body-modification-hook nil
+(defvar-local 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.
@@ -373,7 +354,7 @@ See \\[describe-mode] for many more options."
The structure includes the guides lines, bullet, and bullet cue.")
;;;_ = allout-widgets-changes-record
-(defvar allout-widgets-changes-record nil
+(defvar-local 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
@@ -384,14 +365,12 @@ type. For example:
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
+(defvar-local 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.")
@@ -408,50 +387,48 @@ onto the front.")
"Maintained true during `allout-widgets-exposure-undo-processor'")
;;;_ , Widget-specific outline text format
;;;_ = allout-escaped-prefix-regexp
-(defvar allout-escaped-prefix-regexp ""
+(defvar-local 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)))
+(defvar-local allout-item-icon-keymap
+ (let ((km (make-sparse-keymap))
+ (as-parent (if (current-local-map)
+ (make-composed-keymap (current-local-map)
+ (current-global-map))
+ (current-global-map))))
+ ;; The keymap parent is reset on the each local var when mode starts.
+ (set-keymap-parent km as-parent)
(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)
+ (define-key km digit #'digit-argument))
+ (define-key km "-" #'negative-argument)
;; 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))
+ (define-key km [(mouse-1)] #'ignore)
+ (define-key km [(mouse-2)] #'ignore)
;; Catchall, handles actual keybindings, dynamically doing keymap lookups:
- (define-key km [t] 'allout-item-icon-key-handler)
+ (define-key km [t] #'allout-item-icon-key-handler)
km)
"General tree-node key bindings.")
;;;_ = allout-item-body-keymap
-(defvar allout-item-body-keymap
+(defvar-local 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))
-
+ (as-parent (if (current-local-map)
+ (make-composed-keymap (current-local-map)
+ (current-global-map))
+ (current-global-map))))
+ ;; The keymap parent is reset on the each local var when mode starts.
+ (set-keymap-parent km as-parent)
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
+(defvar-local allout-cue-span-keymap
(let ((km (make-sparse-keymap)))
(set-keymap-parent km allout-item-icon-keymap)
km)
@@ -490,7 +467,7 @@ including things like:
(defvar allout-trailing-category nil
"Symbol carrying common properties of an overlay's trailing newline.")
;;;_ , Developer
-(defvar allout-widgets-last-decoration-timing nil
+(defvar-local 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.
@@ -501,7 +478,6 @@ The value is a list containing two elements:
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
@@ -559,34 +535,39 @@ outline hot-spot navigation (see `allout-mode')."
"\\1\\3"))
)
- (add-hook 'after-change-functions 'allout-widgets-after-change-handler
+ (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)))
+ (let ((as-parent (if (current-local-map)
+ (make-composed-keymap (current-local-map)
+ (current-global-map))
+ (current-global-map))))
+ (set-keymap-parent allout-item-body-keymap as-parent)
+ ;; allout-cue-span-keymap uses allout-item-icon-keymap as parent.
+ (set-keymap-parent allout-item-icon-keymap as-parent))
(add-hook 'allout-exposure-change-functions
- 'allout-widgets-exposure-change-recorder nil 'local)
+ #'allout-widgets-exposure-change-recorder nil 'local)
(add-hook 'allout-structure-added-functions
- 'allout-widgets-additions-recorder nil 'local)
+ #'allout-widgets-additions-recorder nil 'local)
(add-hook 'allout-structure-deleted-functions
- 'allout-widgets-deletions-recorder nil 'local)
+ #'allout-widgets-deletions-recorder nil 'local)
(add-hook 'allout-structure-shifted-functions
- 'allout-widgets-shifts-recorder nil 'local)
+ #'allout-widgets-shifts-recorder nil 'local)
(add-hook 'allout-after-copy-or-kill-hook
- 'allout-widgets-after-copy-or-kill-function nil 'local)
+ #'allout-widgets-after-copy-or-kill-function nil 'local)
(add-hook 'allout-post-undo-hook
- 'allout-widgets-after-undo-function nil 'local)
+ #'allout-widgets-after-undo-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
+ (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
+ (add-hook 'pre-command-hook #'allout-widgets-pre-command-business
nil 'local)
;; init the widgets tally for debugging:
@@ -615,23 +596,23 @@ outline hot-spot navigation (see `allout-mode')."
(remove-from-invisibility-spec 'allout-escapes)
(remove-hook 'after-change-functions
- 'allout-widgets-after-change-handler 'local)
+ #'allout-widgets-after-change-handler 'local)
(remove-hook 'allout-exposure-change-functions
- 'allout-widgets-exposure-change-recorder 'local)
+ #'allout-widgets-exposure-change-recorder 'local)
(remove-hook 'allout-structure-added-functions
- 'allout-widgets-additions-recorder 'local)
+ #'allout-widgets-additions-recorder 'local)
(remove-hook 'allout-structure-deleted-functions
- 'allout-widgets-deletions-recorder 'local)
+ #'allout-widgets-deletions-recorder 'local)
(remove-hook 'allout-structure-shifted-functions
- 'allout-widgets-shifts-recorder 'local)
+ #'allout-widgets-shifts-recorder 'local)
(remove-hook 'allout-after-copy-or-kill-hook
- 'allout-widgets-after-copy-or-kill-function 'local)
+ #'allout-widgets-after-copy-or-kill-function 'local)
(remove-hook 'before-change-functions
- 'allout-widgets-before-change-handler 'local)
+ #'allout-widgets-before-change-handler 'local)
(remove-hook 'post-command-hook
- 'allout-widgets-post-command-business 'local)
+ #'allout-widgets-post-command-business 'local)
(remove-hook 'pre-command-hook
- 'allout-widgets-pre-command-business 'local)
+ #'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
@@ -677,7 +658,7 @@ outline hot-spot navigation (see `allout-mode')."
(setplist 'allout-cue-span-category nil)
(put 'allout-cue-span-category 'evaporate t)
(put 'allout-cue-span-category
- 'modification-hooks '(allout-body-modification-handler))
+ 'modification-hooks '(allout-graphics-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)
@@ -701,12 +682,11 @@ outline hot-spot navigation (see `allout-mode')."
(allout-get-or-create-item-widget))))))
;;;_ . settings context
;;;_ = allout-container-item
-(defvar allout-container-item-widget nil
+(defvar-local 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)
@@ -730,7 +710,7 @@ Optional RECURSING is for internal use, to limit recursion."
(when allout-widgets-reenable-before-change-handler
(add-hook 'before-change-functions
- 'allout-widgets-before-change-handler
+ #'allout-widgets-before-change-handler
nil 'local)
(setq allout-widgets-reenable-before-change-handler nil))
@@ -899,7 +879,7 @@ encompassing condition-case."
(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)
+ (apply #'signal args)
(error "%s: unexpected mode, %s %s" this mode args))))
;;;_ > allout-widgets-changes-exceed-threshold-p ()
(defun allout-widgets-adjusting-message (message)
@@ -924,15 +904,15 @@ posting threshold criteria."
(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))))))
+ (mapc (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)))
@@ -983,18 +963,18 @@ Records changes in `allout-widgets-changes-record'."
Generally invoked via `allout-exposure-change-functions'."
- (let ((changes (sort changes (function (lambda (this next)
- (< (cadr this) (cadr next))))))
+ (let ((changes (sort changes (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
+ (let ((from (cadr change))
+ bucket
(to (caddr change))
(flag (cadddr change))
parent)
@@ -1005,10 +985,11 @@ Generally invoked via `allout-exposure-change-functions'."
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))
+ (cl-callf (lambda (x)
+ (let ((got (allout-range-overlaps from to x)))
+ (setq covered (car got))
+ (cadr got)))
+ (if flag handled-conceal handled-expose))
(when (not covered)
(save-excursion
@@ -1345,64 +1326,6 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES."
(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)
-;; (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)
- (cl-assert (equal (funcall try 3 5) '(nil ((3 5)))))
- ;; add range at end:
- (cl-assert (equal (funcall try 10 12) '(nil ((3 5) (10 12)))))
- ;; add range at beginning:
- (cl-assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12)))))
- ;; insert range somewhere in the middle:
- (cl-assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12)))))
- ;; consolidate some:
- (cl-assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12)))))
- ;; add more:
- (cl-assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17)))))
- ;; add more:
- (cl-assert (equal (funcall try 20 22)
- '(nil ((1 2) (3 9) (10 12) (15 17) (20 22)))))
- ;; encompass more:
- (cl-assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22)))))
- ;; encompass all:
- (cl-assert (equal (funcall try 2 25) '(t ((1 25)))))
-
- ;; fresh slate:
- (setq ranges nil)
- (cl-assert (equal (funcall try 20 25) '(nil ((20 25)))))
- (cl-assert (equal (funcall try 30 35) '(nil ((20 25) (30 35)))))
- (cl-assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35)))))
- (cl-assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35)))))
- (cl-assert (equal (funcall try 10 30) '(t ((10 35)))))
- (cl-assert (equal (funcall try 5 6) '(nil ((5 6) (10 35)))))
- (cl-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.
@@ -1502,8 +1425,7 @@ recursive operation."
;; the actual location of the item text:
:location 'allout-item-location
- :button-keymap allout-item-icon-keymap ; XEmacs
- :keymap allout-item-icon-keymap ; Emacs
+ :keymap allout-item-icon-keymap
;; Element regions:
:guides-span nil
@@ -1594,7 +1516,10 @@ We return the item-widget corresponding to the item at point."
(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))
+ (let ((parent-position (widget-apply parent
+ :actual-position :from)))
+ (when parent-position
+ (goto-char parent-position)))
(if (widget-get parent :is-container)
;; `allout-goto-prefix' will go to first non-container item:
(allout-goto-prefix)
@@ -1900,7 +1825,7 @@ reapplying this method will rectify the glyphs."
(if (> increment 1) (setq increment 1))
(when extenders
;; paint extenders after a connector, else leave spaces.
- (dotimes (i extenders)
+ (dotimes (_ extenders)
(put-text-property
position (setq position (1+ position))
'display (allout-fetch-icon-image
@@ -1994,8 +1919,7 @@ reapplying this method will rectify the glyphs."
;; 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)))
+ (let* ((cue-start (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))
@@ -2050,19 +1974,22 @@ Optional FORCE means force reassignment of the region property."
;;;_ > 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)
+ (let (done next widget
+ (end (or end (point-max))))
(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))))))
+ (while (not done)
+ (when (and (allout-on-current-heading-p)
+ (setq widget (allout-get-item-widget)))
+ (if widget
+ (allout-widgets-undecorate-item widget t)))
+ (goto-char (setq next
+ (next-single-char-property-change (point)
+ 'display
+ (current-buffer)
+ end)))
+ (if (>= next end)
+ (setq done t))))))
;;;_ > allout-widgets-undecorate-text (text)
(defun allout-widgets-undecorate-text (text)
"Eliminate widgets and decorations for all items in TEXT."
@@ -2304,7 +2231,7 @@ interactive command."
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)
+ (use-dir (if (equal (frame-parameter nil 'background-mode)
'light)
allout-widgets-icons-light-subdir
allout-widgets-icons-dark-subdir))
@@ -2316,15 +2243,13 @@ We use a caching strategy, so the caller doesn't need to do so."
(allout-widgets-copy-list (cadr got))
(while (and types (not got))
(setq got
- (allout-find-image
+ (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)
+ allout-widgets-item-image-properties-emacs
))))
(setq types (cdr types)))
(if got
@@ -2337,19 +2262,8 @@ We use a caching strategy, so the caller doesn't need to do so."
"Return seconds between START/END time values."
(let ((elapsed (time-subtract end start)))
(float-time elapsed)))
-;;;_ > 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.
-)
+(define-obsolete-function-alias 'allout-find-image #'find-image "28.1")
;;;_ > allout-widgets-copy-list (list)
(defun allout-widgets-copy-list (list)
;; duplicated from cl.el 'copy-list' as of 2008-08-17
@@ -2368,28 +2282,19 @@ The elements of LIST are not copied, just the list structure itself."
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)))
+ (mapcar (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...")
+(define-obsolete-function-alias 'allout-frame-property #'frame-parameter "28.1")
- (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:
+;;;_ . Local emacs vars.
+;;;_ , Local variables:
+;;;_ , allout-layout: (-1 : 0)
+;;;_ , End:
+
+;;; allout-widgets.el ends here
diff --git a/lisp/allout.el b/lisp/allout.el
index b6e53dca138..0625ea68abe 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1,12 +1,12 @@
-;;; allout.el --- extensive outline mode for use alone and with other modes
+;;; allout.el --- extensive outline mode for use alone and with other modes -*- lexical-binding: t; -*-
-;; Copyright (C) 1992-1994, 2001-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
;; Author: Ken Manheimer <ken dot manheimer at gmail...>
;; Created: Dec 1991 -- first release to usenet
;; Version: 2.3
;; Keywords: outlines, wp, languages, PGP, GnuPG
-;; Website: http://myriadicity.net/software-and-systems/craft/emacs-allout
+;; Website: https://myriadicity.net/software-and-systems/craft/emacs-allout
;; This file is part of GNU Emacs.
@@ -57,13 +57,12 @@
;; mode.
;;
;; Directions to the latest development version and helpful notes are
-;; available at http://myriadicity.net/Sundry/EmacsAllout .
+;; available at https://myriadicity.net/software-and-systems/craft/emacs-allout .
;;
;; 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. (`allout-init' is deprecated in favor of
-;; a purely customization-based method.)
+;; `allout-mode' as a minor mode.
;;
;; Note -- the lines beginning with `;;;_' are outline topic headers.
;; Customize `allout-auto-activation' to enable, then revisit this
@@ -76,10 +75,6 @@
(declare-function epa-passphrase-callback-function
"epa" (context key-id handback))
-;;;_* Dependency loads
-(require 'overlay)
-(eval-when-compile (require 'cl-lib))
-
;;;_* USER CUSTOMIZATION VARIABLES:
;;;_ > defgroup allout, allout-keybindings
@@ -138,13 +133,14 @@ respective allout-mode keybinding variables, `allout-command-prefix',
(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
+ (substitute-key-definition #'beginning-of-line #'allout-beginning-of-line
map global-map)
- (substitute-key-definition 'move-beginning-of-line 'allout-beginning-of-line
+ (substitute-key-definition #'move-beginning-of-line
+ #'allout-beginning-of-line
map global-map)
- (substitute-key-definition 'end-of-line 'allout-end-of-line
+ (substitute-key-definition #'end-of-line #'allout-end-of-line
map global-map)
- (substitute-key-definition 'move-end-of-line 'allout-end-of-line
+ (substitute-key-definition #'move-end-of-line #'allout-end-of-line
map global-map)
(allout-institute-keymap map)))
;;;_ > allout-institute-keymap (map)
@@ -174,7 +170,7 @@ Default is `\C-c<space>'; just `\C-c' is more short-and-sweet, if you're
willing to let allout use a bunch of \C-c keybindings."
:type 'string
:group 'allout-keybindings
- :set 'allout-compose-and-institute-keymap)
+ :set #'allout-compose-and-institute-keymap)
;;;_ = allout-keybindings-binding
(define-widget 'allout-keybindings-binding 'lazy
"Structure of allout keybindings customization items."
@@ -235,7 +231,7 @@ prevails."
:version "24.1"
:type 'allout-keybindings-binding
:group 'allout-keybindings
- :set 'allout-compose-and-institute-keymap
+ :set #'allout-compose-and-institute-keymap
)
;;;_ = allout-unprefixed-keybindings
(defcustom allout-unprefixed-keybindings
@@ -259,7 +255,7 @@ See the existing keys for examples."
:version "24.1"
:type 'allout-keybindings-binding
:group 'allout-keybindings
- :set 'allout-compose-and-institute-keymap
+ :set #'allout-compose-and-institute-keymap
)
;;;_ > allout-auto-activation-helper (var value)
@@ -281,8 +277,8 @@ Establishes allout processing as part of visiting a file if
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)))
+ (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
@@ -303,7 +299,7 @@ With value \"activate\", only auto-mode-activation is enabled.
Auto-layout is not.
With value nil, inhibit any automatic allout-mode activation."
- :set 'allout-auto-activation-helper
+ :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")
@@ -410,8 +406,7 @@ where auto-fill occurs."
:group 'allout)
(make-variable-buffer-local 'allout-use-hanging-indents)
;;;###autoload
-(put 'allout-use-hanging-indents 'safe-local-variable
- (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-use-hanging-indents 'safe-local-variable #'booleanp)
;;;_ = allout-reindent-bodies
(defcustom allout-reindent-bodies (if allout-use-hanging-indents
'text)
@@ -440,8 +435,7 @@ just the header."
:group 'allout)
(make-variable-buffer-local 'allout-show-bodies)
;;;###autoload
-(put 'allout-show-bodies 'safe-local-variable
- (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-show-bodies 'safe-local-variable #'booleanp)
;;;_ = allout-beginning-of-line-cycles
(defcustom allout-beginning-of-line-cycles t
@@ -514,7 +508,7 @@ character, which is typically set to the `allout-primary-bullet'."
:group 'allout)
(make-variable-buffer-local 'allout-header-prefix)
;;;###autoload
-(put 'allout-header-prefix 'safe-local-variable 'stringp)
+(put 'allout-header-prefix 'safe-local-variable #'stringp)
;;;_ = allout-primary-bullet
(defcustom allout-primary-bullet "*"
"Bullet used for top-level outline topics.
@@ -531,7 +525,7 @@ bullets."
:group 'allout)
(make-variable-buffer-local 'allout-primary-bullet)
;;;###autoload
-(put 'allout-primary-bullet 'safe-local-variable 'stringp)
+(put 'allout-primary-bullet 'safe-local-variable #'stringp)
;;;_ = allout-plain-bullets-string
(defcustom allout-plain-bullets-string ".,"
"The bullets normally used in outline topic prefixes.
@@ -547,7 +541,7 @@ of this var to take effect."
:group 'allout)
(make-variable-buffer-local 'allout-plain-bullets-string)
;;;###autoload
-(put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-plain-bullets-string 'safe-local-variable #'stringp)
;;;_ = allout-distinctive-bullets-string
(defcustom allout-distinctive-bullets-string "*+-=>()[{}&!?#%\"X@$~_\\:;^"
"Persistent outline header bullets used to distinguish special topics.
@@ -595,7 +589,7 @@ strings."
:group 'allout)
(make-variable-buffer-local 'allout-distinctive-bullets-string)
;;;###autoload
-(put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-distinctive-bullets-string 'safe-local-variable #'stringp)
;;;_ = allout-use-mode-specific-leader
(defcustom allout-use-mode-specific-leader t
@@ -662,8 +656,7 @@ are always respected by the topic maneuvering functions."
:group 'allout)
(make-variable-buffer-local 'allout-old-style-prefixes)
;;;###autoload
-(put 'allout-old-style-prefixes 'safe-local-variable
- (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-old-style-prefixes 'safe-local-variable #'booleanp)
;;;_ = allout-stylish-prefixes -- alternating bullets
(defcustom allout-stylish-prefixes t
"Do fancy stuff with topic prefix bullets according to level, etc.
@@ -711,8 +704,7 @@ is non-nil."
:group 'allout)
(make-variable-buffer-local 'allout-stylish-prefixes)
;;;###autoload
-(put 'allout-stylish-prefixes 'safe-local-variable
- (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-stylish-prefixes 'safe-local-variable #'booleanp)
;;;_ = allout-numbered-bullet
(defcustom allout-numbered-bullet "#"
@@ -726,10 +718,7 @@ disables numbering maintenance."
:group 'allout)
(make-variable-buffer-local 'allout-numbered-bullet)
;;;###autoload
-(put 'allout-numbered-bullet 'safe-local-variable
- (if (fboundp 'string-or-null-p)
- 'string-or-null-p
- (lambda (x) (or (stringp x) (null x)))))
+(put 'allout-numbered-bullet 'safe-local-variable #'string-or-null-p)
;;;_ = allout-file-xref-bullet
(defcustom allout-file-xref-bullet "@"
"Bullet signifying file cross-references, for `allout-resolve-xref'.
@@ -738,10 +727,7 @@ Set this var to the bullet you want to use for file cross-references."
:type '(choice (const nil) string)
:group 'allout)
;;;###autoload
-(put 'allout-file-xref-bullet 'safe-local-variable
- (if (fboundp 'string-or-null-p)
- 'string-or-null-p
- (lambda (x) (or (stringp x) (null x)))))
+(put 'allout-file-xref-bullet 'safe-local-variable #'string-or-null-p)
;;;_ = allout-presentation-padding
(defcustom allout-presentation-padding 2
"Presentation-format white-space padding factor, for greater indent."
@@ -750,7 +736,7 @@ Set this var to the bullet you want to use for file cross-references."
(make-variable-buffer-local 'allout-presentation-padding)
;;;###autoload
-(put 'allout-presentation-padding 'safe-local-variable 'integerp)
+(put 'allout-presentation-padding 'safe-local-variable #'integerp)
;;;_ = allout-flattened-numbering-abbreviation
(define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering
@@ -842,29 +828,14 @@ such topics are encrypted.)"
The value of `buffer-saved-size' at the time of decryption is used,
for restoring when all encryptions are established.")
-(defvar allout-just-did-undo nil
+(defvar-local allout-just-did-undo nil
"True just after undo commands, until allout-post-command-business.")
-(make-variable-buffer-local 'allout-just-did-undo)
;;;_ + Developer
;;;_ = allout-developer group
(defgroup allout-developer nil
"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
- "When non-nil, unit tests will be run at end of loading the allout module.
-
-Generally, allout 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-run-unit-tests' to see what's run."
- :type 'boolean
- :group 'allout-developer)
-
;;;_ + Miscellaneous customization
;;;_ = allout-enable-file-variable-adjustment
@@ -900,10 +871,10 @@ For details, see `allout-toggle-current-subtree-encryption's docstring."
msg))
;;;_ : Mode activation (defined here because it's referenced early)
;;;_ = allout-mode
-(defvar allout-mode nil "Allout outline mode minor-mode flag.")
-(make-variable-buffer-local 'allout-mode)
+(defvar-local allout-mode nil
+ "Allout outline mode minor-mode flag.")
;;;_ = allout-layout nil
-(defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL -- see docstring.
+(defvar-local 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-auto-activation'
@@ -929,34 +900,30 @@ followed by the equivalent of `(allout-expose-topic 0 : -1 -1 0)'.
`allout-default-layout' describes the specification format.
`allout-layout' can additionally have the value t, in which
case the value of `allout-default-layout' is used.")
-(make-variable-buffer-local 'allout-layout)
;;;###autoload
(put 'allout-layout 'safe-local-variable
(lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
;;;_ : Topic header format
;;;_ = allout-regexp
-(defvar allout-regexp ""
+(defvar-local allout-regexp ""
"Regular expression to match the beginning of a heading line.
Any line whose beginning matches this regexp is considered a
heading. This var is set according to the user configuration vars
by `allout-set-regexp'.")
-(make-variable-buffer-local 'allout-regexp)
;;;_ = allout-bullets-string
-(defvar allout-bullets-string ""
+(defvar-local allout-bullets-string ""
"A string dictating the valid set of outline topic bullets.
This var should *not* be set by the user -- it is set by `allout-set-regexp',
and is produced from the elements of `allout-plain-bullets-string'
and `allout-distinctive-bullets-string'.")
-(make-variable-buffer-local 'allout-bullets-string)
;;;_ = allout-bullets-string-len
-(defvar allout-bullets-string-len 0
+(defvar-local allout-bullets-string-len 0
"Length of current buffers' `allout-plain-bullets-string'.")
-(make-variable-buffer-local 'allout-bullets-string-len)
;;;_ = allout-depth-specific-regexp
-(defvar allout-depth-specific-regexp ""
+(defvar-local allout-depth-specific-regexp ""
"Regular expression to match a heading line prefix for a particular depth.
This expression is used to search for depth-specific topic
@@ -967,34 +934,28 @@ This var is set according to the user configuration vars by
`allout-set-regexp'. It is prepared with format strings for two
decimal numbers, which should each be one less than the depth of the
topic prefix to be matched.")
-(make-variable-buffer-local 'allout-depth-specific-regexp)
;;;_ = allout-depth-one-regexp
-(defvar allout-depth-one-regexp ""
+(defvar-local allout-depth-one-regexp ""
"Regular expression to match a heading line prefix for depth one.
This var is set according to the user configuration vars by
`allout-set-regexp'. It is prepared with format strings for two
decimal numbers, which should each be one less than the depth of the
topic prefix to be matched.")
-(make-variable-buffer-local 'allout-depth-one-regexp)
;;;_ = allout-line-boundary-regexp
-(defvar allout-line-boundary-regexp ()
+(defvar-local allout-line-boundary-regexp ()
"`allout-regexp' prepended with a newline for the search target.
This is properly set by `allout-set-regexp'.")
-(make-variable-buffer-local 'allout-line-boundary-regexp)
;;;_ = allout-bob-regexp
-(defvar allout-bob-regexp ()
+(defvar-local allout-bob-regexp ()
"Like `allout-line-boundary-regexp', for headers at beginning of buffer.")
-(make-variable-buffer-local 'allout-bob-regexp)
;;;_ = allout-header-subtraction
-(defvar allout-header-subtraction (1- (length allout-header-prefix))
+(defvar-local allout-header-subtraction (1- (length allout-header-prefix))
"Allout-header prefix length to subtract when computing topic depth.")
-(make-variable-buffer-local 'allout-header-subtraction)
;;;_ = allout-plain-bullets-string-len
-(defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
+(defvar-local allout-plain-bullets-string-len (length allout-plain-bullets-string)
"Length of `allout-plain-bullets-string', updated by `allout-set-regexp'.")
-(make-variable-buffer-local 'allout-plain-bullets-string-len)
;;;_ = allout-doublecheck-at-and-shallower
(defconst allout-doublecheck-at-and-shallower 3
@@ -1096,7 +1057,7 @@ invoking it directly."
(setq allout-primary-bullet leader))
allout-header-prefix)))
(defalias 'allout-infer-header-lead
- 'allout-infer-header-lead-and-primary-bullet)
+ #'allout-infer-header-lead-and-primary-bullet)
;;;_ > allout-infer-body-reindent ()
(defun allout-infer-body-reindent ()
"Determine proper setting for `allout-reindent-bodies'.
@@ -1236,14 +1197,13 @@ Also refresh various data structures that hinge on the regexp."
"[^" allout-primary-bullet "]"))
"\\)"
))))
-(define-obsolete-function-alias 'set-allout-regexp 'allout-set-regexp "26.1")
+(define-obsolete-function-alias 'set-allout-regexp #'allout-set-regexp "26.1")
;;;_ : Menu bar
(defvar allout-mode-exposure-menu)
(defvar allout-mode-editing-menu)
(defvar allout-mode-navigation-menu)
(defvar allout-mode-misc-menu)
(defun allout-produce-mode-menubar-entries ()
- (require 'easymenu)
(easy-menu-define allout-mode-exposure-menu
allout-mode-map-value
"Allout outline exposure menu."
@@ -1305,11 +1265,10 @@ Also refresh various data structures that hinge on the regexp."
["Set New Exposure" allout-expose-topic t])))
;;;_ : Allout Modal-Variables Utilities
;;;_ = allout-mode-prior-settings
-(defvar allout-mode-prior-settings nil
+(defvar-local allout-mode-prior-settings nil
"Internal `allout-mode' use; settings to be resumed on mode deactivation.
See `allout-add-resumptions' and `allout-do-resumptions'.")
-(make-variable-buffer-local 'allout-mode-prior-settings)
;;;_ > allout-add-resumptions (&rest pairs)
(defun allout-add-resumptions (&rest pairs)
"Set name/value PAIRS.
@@ -1492,16 +1451,15 @@ that was affected by the undo.."
:version "24.3")
;;;_ = allout-outside-normal-auto-fill-function
-(defvar allout-outside-normal-auto-fill-function nil
+(defvar-local allout-outside-normal-auto-fill-function nil
"Value of `normal-auto-fill-function' outside of allout mode.
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)
;;;_ = prevent redundant activation by desktop mode:
(add-to-list 'desktop-minor-mode-handlers '(allout-mode . nil))
;;;_ = allout-after-save-decrypt
-(defvar allout-after-save-decrypt nil
+(defvar-local allout-after-save-decrypt nil
"Internal variable, is nil or has the value of two points:
- the location of a topic to be decrypted after saving is done
@@ -1509,9 +1467,8 @@ wrapped within allout's automatic `fill-prefix' setting.")
This is used to decrypt the topic that was currently being edited, if it
was encrypted automatically as part of a file write or autosave.")
-(make-variable-buffer-local 'allout-after-save-decrypt)
;;;_ = allout-encryption-plaintext-sanitization-regexps
-(defvar allout-encryption-plaintext-sanitization-regexps nil
+(defvar-local allout-encryption-plaintext-sanitization-regexps nil
"List of regexps whose matches are removed from plaintext before encryption.
This is for the sake of removing artifacts, like escapes, that are added on
@@ -1524,9 +1481,8 @@ Each value can be a regexp or a list with a regexp followed by a
substitution string. If it's just a regexp, all its matches are removed
before the text is encrypted. If it's a regexp and a substitution, the
substitution is used against the regexp matches, a la `replace-match'.")
-(make-variable-buffer-local 'allout-encryption-plaintext-sanitization-regexps)
;;;_ = allout-encryption-ciphertext-rejection-regexps
-(defvar allout-encryption-ciphertext-rejection-regexps nil
+(defvar-local allout-encryption-ciphertext-rejection-regexps nil
"Variable for regexps matching plaintext to remove before encryption.
This is used to detect strings in encryption results that would
@@ -1539,13 +1495,11 @@ Encryptions that result in matches will be retried, up to
`allout-encryption-ciphertext-rejection-ceiling' times, after which
an error is raised.")
-(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
;;;_ = allout-encryption-ciphertext-rejection-ceiling
-(defvar allout-encryption-ciphertext-rejection-ceiling 5
+(defvar-local allout-encryption-ciphertext-rejection-ceiling 5
"Limit on number of times encryption ciphertext is rejected.
See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
-(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
;;;_ > 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!
@@ -1633,34 +1587,9 @@ non-nil in a lasting way.")
;;;_ #2 Mode environment and activation
;;;_ = allout-explicitly-deactivated
-(defvar allout-explicitly-deactivated nil
+(defvar-local 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 (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."
- (declare (obsolete allout-auto-activation "23.3"))
- (customize-set-variable 'allout-auto-activation (format "%s" mode))
- (format "%s" mode))
-
-;;;_ > allout-setup-menubar ()
-(defun allout-setup-menubar ()
- "Populate the current buffer's menubar with `allout-mode' stuff."
- (let ((menus (list allout-mode-exposure-menu
- allout-mode-editing-menu
- allout-mode-navigation-menu
- allout-mode-misc-menu))
- cur)
- (while menus
- (setq cur (car menus)
- menus (cdr menus))
- (easy-menu-add cur))))
;;;_ > allout-overlay-preparations
(defun allout-overlay-preparations ()
"Set the properties of the allout invisible-text overlay and others."
@@ -1674,11 +1603,9 @@ valid values."
;; property controls the isearch _arrival_ behavior. This is the case at
;; least in emacs 21, 22.1, and xemacs 21.4.
(put 'allout-exposure-category 'isearch-open-invisible
- 'allout-isearch-end-handler)
- (if (featurep 'xemacs)
- (put 'allout-exposure-category 'start-open t)
- (put 'allout-exposure-category 'insert-in-front-hooks
- '(allout-overlay-insert-in-front-handler)))
+ #'allout-isearch-end-handler)
+ (put 'allout-exposure-category 'insert-in-front-hooks
+ '(allout-overlay-insert-in-front-handler))
(put 'allout-exposure-category 'modification-hooks
'(allout-overlay-interior-modification-handler)))
;;;_ > define-minor-mode allout-mode
@@ -1966,12 +1893,12 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(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 '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-contents-functions
- 'allout-write-contents-hook-handler t)
+ #'allout-write-contents-hook-handler t)
(remove-overlays (point-min) (point-max)
'category 'allout-exposure-category))
@@ -2000,11 +1927,11 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(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 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
- (add-hook 'write-contents-functions 'allout-write-contents-hook-handler
+ (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 'isearch-mode-end-hook #'allout-isearch-end-handler nil t)
+ (add-hook 'write-contents-functions #'allout-write-contents-hook-handler
nil t)
;; Stash auto-fill settings and adjust so custom allout auto-fill
@@ -2029,8 +1956,6 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
;; allout-auto-fill will use the stashed values and so forth.
(allout-add-resumptions '(auto-fill-function allout-auto-fill)))
- (allout-setup-menubar)
-
;; Do auto layout if warranted:
(when (and allout-layout
allout-auto-activation
@@ -2050,7 +1975,7 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(allout-this-or-next-heading)
(condition-case err
(progn
- (apply 'allout-expose-topic (list use-layout))
+ (apply #'allout-expose-topic (list use-layout))
(message "Adjusting `%s' exposure... done."
(buffer-name)))
;; Problem applying exposure -- notify user, but don't
@@ -2062,7 +1987,7 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
) ; let (())
) ; define-minor-mode
;;;_ > allout-minor-mode alias
-(defalias 'allout-minor-mode 'allout-mode)
+(defalias 'allout-minor-mode #'allout-mode)
;;;_ > allout-unload-function
(defun allout-unload-function ()
"Unload the allout outline library."
@@ -2115,9 +2040,7 @@ internal functions use this feature cohesively bunch changes."
(allout-show-to-offshoot)))
(when (not first)
(setq first (point))))
- (goto-char (if (featurep 'xemacs)
- (next-property-change (1+ (point)) nil end)
- (next-char-property-change (1+ (point)) end))))
+ (goto-char (next-char-property-change (1+ (point)) end)))
(when first
(goto-char first)
(condition-case nil
@@ -2133,7 +2056,7 @@ internal functions use this feature cohesively bunch changes."
(error "Concealed-text change abandoned, text reconcealed"))))
(goto-char start))))
;;;_ > allout-before-change-handler (beg end)
-(defun allout-before-change-handler (beg end)
+(defun allout-before-change-handler (_beg _end)
"Protect against changes to invisible text.
See `allout-overlay-interior-modification-handler' for details."
@@ -2141,18 +2064,7 @@ See `allout-overlay-interior-modification-handler' for details."
(when (and (allout-mode-p) undo-in-progress)
(setq allout-just-did-undo t)
(if (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.
- (when (and (featurep 'xemacs) (allout-mode-p))
- ;; process all of the pending overlays:
- (save-excursion
- (goto-char beg)
- (let ((overlay (allout-get-invisibility-overlay)))
- (if overlay
- (allout-overlay-interior-modification-handler
- overlay nil beg end nil))))))
+ (allout-show-children))))
;;;_ > allout-isearch-end-handler (&optional overlay)
(defun allout-isearch-end-handler (&optional _overlay)
"Reconcile allout outline exposure on arriving in hidden text after isearch.
@@ -2173,21 +2085,17 @@ function can also be used as an `isearch-mode-end-hook'."
;; 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
+(defvar-local allout-recent-prefix-beginning 0
"Buffer point of the start of the last topic prefix encountered.")
-(make-variable-buffer-local 'allout-recent-prefix-beginning)
;;;_ = allout-recent-prefix-end
-(defvar allout-recent-prefix-end 0
+(defvar-local allout-recent-prefix-end 0
"Buffer point of the end of the last topic prefix encountered.")
-(make-variable-buffer-local 'allout-recent-prefix-end)
;;;_ = allout-recent-depth
-(defvar allout-recent-depth 0
+(defvar-local allout-recent-depth 0
"Depth of the last topic prefix encountered.")
-(make-variable-buffer-local 'allout-recent-depth)
;;;_ = allout-recent-end-of-subtree
-(defvar allout-recent-end-of-subtree 0
+(defvar-local allout-recent-end-of-subtree 0
"Buffer point last returned by `allout-end-of-current-subtree'.")
-(make-variable-buffer-local 'allout-recent-end-of-subtree)
;;;_ > allout-prefix-data ()
(defsubst allout-prefix-data ()
"Register allout-prefix state data.
@@ -2312,7 +2220,7 @@ Actually, returns prefix beginning point."
(or (not (allout-do-doublecheck))
(not (allout-aberrant-container-p)))))))
;;;_ > allout-on-heading-p ()
-(defalias 'allout-on-heading-p 'allout-on-current-heading-p)
+(defalias 'allout-on-heading-p #'allout-on-current-heading-p)
;;;_ > allout-e-o-prefix-p ()
(defun allout-e-o-prefix-p ()
"True if point is located where current topic prefix ends, heading begins."
@@ -2453,7 +2361,7 @@ Outermost is first."
(progn
(if (and (not (bolp))
(allout-hidden-p (1- (point))))
- (goto-char (allout-previous-single-char-property-change
+ (goto-char (previous-single-char-property-change
(1- (point)) 'invisible)))
(move-beginning-of-line 1))
(allout-depth)
@@ -2499,20 +2407,16 @@ Outermost is first."
(allout-back-to-current-heading)
(allout-end-of-current-line))
(t
- (if (not (allout-mark-active-p))
+ (if (not mark-active)
(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 GNU 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)))
+ (declare (obsolete nil "28.1"))
+ mark-active)
+
;;;_ > allout-next-heading ()
(defsubst allout-next-heading ()
"Move to the heading for the topic (possibly invisible) after this one.
@@ -2586,10 +2490,10 @@ We skip anomalous low-level topics, a la `allout-aberrant-container-p'."
;;;_ - Subtree Charting
;;;_ " These routines either produce or assess charts, which are
-;;; nested lists of the locations of topics within a subtree.
-;;;
-;;; Charts enable efficient subtree navigation by providing a reusable basis
-;;; for elaborate, compound assessment and adjustment of a subtree.
+;; nested lists of the locations of topics within a subtree.
+;;
+;; Charts enable efficient subtree navigation by providing a reusable basis
+;; for elaborate, compound assessment and adjustment of a subtree.
;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
(defun allout-chart-subtree (&optional levels visible orig-depth prev-depth)
@@ -2852,7 +2756,7 @@ of (before any) topics, in which case we return nil."
(goto-char (point-min))
nil))))
;;;_ > allout-back-to-heading ()
-(defalias 'allout-back-to-heading 'allout-back-to-current-heading)
+(defalias 'allout-back-to-heading #'allout-back-to-current-heading)
;;;_ > allout-pre-next-prefix ()
(defun allout-pre-next-prefix ()
"Skip forward to just before the next heading line.
@@ -2934,7 +2838,7 @@ collapsed."
(allout-beginning-of-current-entry)
(search-forward "\n" nil t)
(forward-char -1))
-(defalias 'allout-end-of-heading 'allout-end-of-current-heading)
+(defalias 'allout-end-of-heading #'allout-end-of-current-heading)
;;;_ > allout-get-body-text ()
(defun allout-get-body-text ()
"Return the unmangled body text of the topic immediately containing point."
@@ -3271,7 +3175,7 @@ Returns resulting position, else nil if none found."
;;;_ - Fundamental
;;;_ = allout-post-goto-bullet
-(defvar allout-post-goto-bullet nil
+(defvar-local allout-post-goto-bullet nil
"Outline internal var, for `allout-pre-command-business' hot-spot operation.
When set, tells post-processing to reposition on topic bullet, and
@@ -3279,18 +3183,15 @@ 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-value'.")
-(make-variable-buffer-local 'allout-post-goto-bullet)
;;;_ = allout-command-counter
-(defvar allout-command-counter 0
+(defvar-local allout-command-counter 0
"Counter that monotonically increases in allout-mode buffers.
Set by `allout-pre-command-business', to support allout addons in
coordinating with allout activity.")
-(make-variable-buffer-local 'allout-command-counter)
;;;_ = allout-this-command-hid-text
-(defvar allout-this-command-hid-text nil
+(defvar-local allout-this-command-hid-text nil
"True if the most recent allout-mode command hid any text.")
-(make-variable-buffer-local 'allout-this-command-hid-text)
;;;_ > allout-post-command-business ()
(defun allout-post-command-business ()
"Outline `post-command-hook' function.
@@ -3376,10 +3277,6 @@ Returns the qualifying command, if any, else nil."
(interactive)
(let* ((modified (event-modifiers last-command-event))
(key-num (cond ((numberp last-command-event) last-command-event)
- ;; for XEmacs character type:
- ((and (fboundp 'characterp)
- (apply 'characterp (list last-command-event)))
- (apply 'char-to-int (list last-command-event)))
(t 0)))
mapped-binding)
@@ -3443,7 +3340,7 @@ Offer one suitable for current depth DEPTH as default."
(format-message
"Select bullet: %s (`%s' default): "
sans-escapes
- (allout-substring-no-properties default-bullet))
+ (substring-no-properties default-bullet))
sans-escapes
t)))
(message "")
@@ -4458,9 +4355,9 @@ Topic exposure is marked with text-properties, to be used by
(if (not (allout-hidden-p))
(setq next
(max (1+ (point))
- (allout-next-single-char-property-change (point)
- 'invisible
- nil end))))
+ (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)
@@ -4499,7 +4396,7 @@ 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 (allout-next-single-char-property-change
+ (setq next (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.
@@ -4510,7 +4407,7 @@ 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 (allout-next-single-char-property-change
+ (setq next (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)
@@ -4543,12 +4440,12 @@ however, are left exactly like normal, non-allout-specific yanks."
(interactive "*P")
; Get to beginning, leaving
; region around subject:
- (if (< (allout-mark-marker t) (point))
+ (if (< (mark-marker) (point))
(exchange-point-and-mark))
(save-match-data
(let* ((subj-beg (point))
(into-bol (bolp))
- (subj-end (allout-mark-marker t))
+ (subj-end (mark-marker))
;; 'resituate' if yanking an entire topic into topic header:
(resituate (and (let ((allout-inhibit-aberrance-doublecheck t))
(allout-e-o-prefix-p))
@@ -4642,8 +4539,8 @@ however, are left exactly like normal, non-allout-specific yanks."
t)))
(message ""))))
(if (or into-bol resituate)
- (allout-hide-by-annotation (point) (allout-mark-marker t))
- (allout-deannotate-hidden (allout-mark-marker t) (point)))
+ (allout-hide-by-annotation (point) (mark-marker))
+ (allout-deannotate-hidden (mark-marker) (point)))
(if (not resituate)
(exchange-point-and-mark))
(run-hook-with-args 'allout-structure-added-functions subj-beg subj-end))))
@@ -4752,14 +4649,7 @@ this function."
(when flag
(let ((o (make-overlay from to nil 'front-advance)))
(overlay-put o 'category 'allout-exposure-category)
- (overlay-put o 'evaporate t)
- (when (featurep 'xemacs)
- (let ((props (symbol-plist 'allout-exposure-category)))
- (while props
- (condition-case nil
- ;; as of 2008-02-27, xemacs lacks modification-hooks
- (overlay-put o (pop props) (pop props))
- (error nil))))))
+ (overlay-put o 'evaporate t))
(setq allout-this-command-hid-text t))
(run-hook-with-args 'allout-exposure-change-functions from to flag))
;;;_ > allout-flag-current-subtree (flag)
@@ -5231,7 +5121,7 @@ Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
(if (and spec
(allout-descend-to-depth new-depth)
(not (allout-hidden-p)))
- (progn (setq got (apply 'allout-old-expose-topic spec))
+ (progn (setq got (apply #'allout-old-expose-topic spec))
(if (and got (or (not max-pos) (> got max-pos)))
(setq max-pos got)))))))
(while (and followers
@@ -5309,7 +5199,7 @@ Optional arg CONTEXT indicates interior levels to include."
(setq flat-index (cdr flat-index)))
;; Dispose of single extra delim:
(setq result (cdr result))))
- (apply 'concat result)))
+ (apply #'concat result)))
;;;_ > allout-stringify-flat-index-plain (flat-index)
(defun allout-stringify-flat-index-plain (flat-index)
"Convert list representing section/subsection/... to document string."
@@ -5320,7 +5210,7 @@ Optional arg CONTEXT indicates interior levels to include."
(if result
(cons delim result))))
(setq flat-index (cdr flat-index)))
- (apply 'concat result)))
+ (apply #'concat result)))
;;;_ > allout-stringify-flat-index-indented (flat-index)
(defun allout-stringify-flat-index-indented (flat-index)
"Convert list representing section/subsection/... to document string."
@@ -5349,7 +5239,7 @@ Optional arg CONTEXT indicates interior levels to include."
(setq flat-index (cdr flat-index)))
;; Dispose of single extra delim:
(setq result (cdr result))))
- (apply 'concat result)))
+ (apply #'concat result)))
;;;_ > allout-listify-exposed (&optional start end format)
(defun allout-listify-exposed (&optional start end format)
@@ -5474,11 +5364,9 @@ header and body. The elements of that list are:
(cdr format)))))))
;; Put the list with first at front, to last at back:
(nreverse result))))
-;;;_ > allout-region-active-p ()
-(defmacro allout-region-active-p ()
- (cond ((fboundp 'use-region-p) '(use-region-p))
- ((fboundp 'region-active-p) '(region-active-p))
- (t 'mark-active)))
+
+(define-obsolete-function-alias 'allout-region-active-p #'region-active-p "28.1")
+
;;_ > allout-process-exposed (&optional func from to frombuf
;;; tobuf format)
(defun allout-process-exposed (&optional func from to frombuf tobuf
@@ -5511,7 +5399,7 @@ Defaults:
; defaulting if necessary:
(if (not func) (setq func 'allout-insert-listified))
(if (not (and from to))
- (if (allout-region-active-p)
+ (if (region-active-p)
(setq from (region-beginning) to (region-end))
(setq from (point-min) to (point-max))))
(if frombuf
@@ -5594,7 +5482,7 @@ alternate presentation format for the outline:
(beg (if arg (allout-back-to-current-heading) (point-min)))
(end (if arg (allout-end-of-current-subtree) (point-max)))
(buf (current-buffer))
- (start-list ()))
+ ) ;; (start-list ())
(if (eq format 'flat)
(setq format (if arg (save-excursion
(goto-char beg)
@@ -5606,7 +5494,7 @@ alternate presentation format for the outline:
end
(current-buffer)
tobuf
- format start-list)
+ format nil) ;; start-list
(goto-char (point-min))
(pop-to-buffer buf)
(goto-char start-pt)))
@@ -5649,12 +5537,11 @@ used verbatim."
"Return copy of STRING for literal reproduction across LaTeX processing.
Expresses the original characters (including carriage returns) of the
string across LaTeX processing."
- (mapconcat (function
- (lambda (char)
- (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
- (concat "\\char" (number-to-string char) "{}"))
- ((= char ?\n) "\\\\")
- (t (char-to-string char)))))
+ (mapconcat (lambda (char)
+ (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
+ (concat "\\char" (number-to-string char) "{}"))
+ ((= char ?\n) "\\\\")
+ (t (char-to-string char))))
string
""))
;;;_ > allout-latex-verbatim-quote-curr-line ()
@@ -5719,11 +5606,12 @@ environment. Leaves point at the end of the line."
(begindoc "\\begin{document}\n\\begin{center}\n")
(title (format "%s%s%s%s"
"\\titlecmd{"
- (allout-latex-verb-quote (if allout-title
- (condition-case nil
- (eval allout-title)
- (error "<unnamed buffer>"))
- "Unnamed Outline"))
+ (allout-latex-verb-quote
+ (if allout-title
+ (condition-case nil
+ (eval allout-title t)
+ (error "<unnamed buffer>"))
+ "Unnamed Outline"))
"}\n"
"\\end{center}\n\n"))
(hsize "\\hsize = 7.5 true in\n")
@@ -5946,7 +5834,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
- (allout-select-safe-coding-system subtree-beg subtree-end))
+ (select-safe-coding-system subtree-beg subtree-end))
;; if the coding system for the text being encrypted is different
;; from that prevailing, then there a real risk that the coding
;; system can't be noticed by emacs when the file is visited. to
@@ -6316,7 +6204,7 @@ save. See `allout-encrypt-unencrypted-on-saves' for more info."
;;;_ > outlineify-sticky ()
;; outlinify-sticky is correct spelling; provide this alias for sticklers:
;;;###autoload
-(defalias 'outlinify-sticky 'outlineify-sticky)
+(defalias 'outlinify-sticky #'outlineify-sticky)
;;;###autoload
(defun outlineify-sticky (&optional _arg)
"Activate outline mode and establish file var so it is started subsequently.
@@ -6538,208 +6426,19 @@ If BEG is bigger than END we return 0."
;;;_ > allout-format-quote (string)
(defun allout-format-quote (string)
"Return a copy of string with all \"%\" characters doubled."
- (apply 'concat
+ (apply #'concat
(mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
string)))
(define-obsolete-function-alias 'allout-flatten #'flatten-tree "27.1")
-;;;_ : 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.
-
-XEmacs takes two optional args, while Emacs does not,
-so pass them along when appropriate."
- (if (featurep 'xemacs)
- (apply 'mark-marker force buffer)
- (mark-marker)))
-;;;_ > subst-char-in-string if necessary
-(if (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)))
-;;;_ > wholenump if necessary
-(if (not (fboundp 'wholenump))
- (defalias 'wholenump 'natnump))
-;;;_ > remove-overlays if necessary
-(if (not (fboundp 'remove-overlays))
- (defun remove-overlays (&optional beg end name val)
- "Clear BEG and END of overlays whose property NAME has value VAL.
-Overlays might be moved and/or split.
-BEG and END default respectively to the beginning and end of buffer."
- (unless beg (setq beg (point-min)))
- (unless end (setq end (point-max)))
- (if (< end beg)
- (setq beg (prog1 end (setq end beg))))
- (save-excursion
- (dolist (o (overlays-in beg end))
- (when (eq (overlay-get o name) val)
- ;; Either push this overlay outside beg...end
- ;; or split it to exclude beg...end
- ;; or delete it entirely (if it is contained in beg...end).
- (if (< (overlay-start o) beg)
- (if (> (overlay-end o) end)
- (progn
- (move-overlay (copy-overlay o)
- (overlay-start o) beg)
- (move-overlay o end (overlay-end o)))
- (move-overlay o (overlay-start o) beg))
- (if (> (overlay-end o) end)
- (move-overlay o end (overlay-end o))
- (delete-overlay o)))))))
- )
-;;;_ > copy-overlay if necessary -- xemacs ~ 21.4
-(if (not (fboundp 'copy-overlay))
- (defun copy-overlay (o)
- "Return a copy of overlay O."
- (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
- ;; FIXME: there's no easy way to find the
- ;; insertion-type of the two markers.
- (overlay-buffer o)))
- (props (overlay-properties o)))
- (while props
- (overlay-put o1 (pop props) (pop props)))
- o1)))
-;;;_ > add-to-invisibility-spec if necessary -- xemacs ~ 21.4
-(if (not (fboundp 'add-to-invisibility-spec))
- (defun add-to-invisibility-spec (element)
- "Add ELEMENT to `buffer-invisibility-spec'.
-See documentation for `buffer-invisibility-spec' for the kind of elements
-that can be added."
- (if (eq buffer-invisibility-spec t)
- (setq buffer-invisibility-spec (list t)))
- (setq buffer-invisibility-spec
- (cons element buffer-invisibility-spec))))
-;;;_ > remove-from-invisibility-spec if necessary -- xemacs ~ 21.4
-(if (not (fboundp 'remove-from-invisibility-spec))
- (defun remove-from-invisibility-spec (element)
- "Remove ELEMENT from `buffer-invisibility-spec'."
- (if (consp buffer-invisibility-spec)
- (setq buffer-invisibility-spec (delete element
- buffer-invisibility-spec)))))
-;;;_ > move-beginning-of-line if necessary -- older emacs, xemacs
-(if (not (fboundp 'move-beginning-of-line))
- (defun move-beginning-of-line (arg)
- "Move point to beginning of current line as displayed.
-\(This disregards invisible newlines such as those
-which are part of the text that an image rests on.)
-
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If point reaches the beginning or end of buffer, it stops there.
-To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
- (interactive "p")
- (or arg (setq arg 1))
- (if (/= arg 1)
- (condition-case nil (line-move (1- arg)) (error nil)))
-
- ;; Move to beginning-of-line, ignoring fields and invisible text.
- (skip-chars-backward "^\n")
- (while (and (not (bobp))
- (let ((prop
- (get-char-property (1- (point)) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (goto-char (if (featurep 'xemacs)
- (previous-property-change (point))
- (previous-char-property-change (point))))
- (skip-chars-backward "^\n"))
- (vertical-motion 0))
-)
-;;;_ > 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.
-\(This disregards invisible newlines such as those
-which are part of the text that an image rests on.)
-
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
-If point reaches the beginning or end of buffer, it stops there.
-To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
- (interactive "p")
- (or arg (setq arg 1))
- (let (done)
- (while (not done)
- (let ((newpos
- (save-excursion
- (let ((goal-column 0))
- (and (condition-case nil
- (or (line-move arg) t)
- (error nil))
- (not (bobp))
- (progn
- (while
- (and
- (not (bobp))
- (let ((prop
- (get-char-property (1- (point))
- 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop
- buffer-invisibility-spec)
- (assq prop
- buffer-invisibility-spec)))))
- (goto-char
- (previous-char-property-change (point))))
- (backward-char 1)))
- (point)))))
- (goto-char newpos)
- (if (and (> (point) newpos)
- (eq (preceding-char) ?\n))
- (backward-char 1)
- (if (and (> (point) newpos) (not (eobp))
- (not (eq (following-char) ?\n)))
- ;; If we skipped something intangible
- ;; and now we're not really at eol,
- ;; keep going.
- (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))
- )
-
+(define-obsolete-function-alias 'allout-mark-marker #'mark-marker "28.1")
+(define-obsolete-function-alias 'allout-substring-no-properties
+ #'substring-no-properties "28.1")
+(define-obsolete-function-alias 'allout-select-safe-coding-system
+ #'select-safe-coding-system "28.1")
+(define-obsolete-function-alias 'allout-previous-single-char-property-change
+ #'previous-single-char-property-change "28.1")
+(define-obsolete-function-alias 'allout-next-single-char-property-change
+ #'next-single-char-property-change "28.1")
;;;_ #10 Unfinished
;;;_ > allout-bullet-isearch (&optional bullet)
(defun allout-bullet-isearch (&optional bullet)
@@ -6758,136 +6457,6 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(isearch-repeat 'forward)
(isearch-mode t)))
-;;;_ #11 Unit tests -- this should be last item before "Provide"
-;;;_ > allout-run-unit-tests ()
-(defun allout-run-unit-tests ()
- "Run the various allout unit tests."
- (message "Running allout tests...")
- (allout-test-resumptions)
- (message "Running allout tests... Done.")
- (sit-for .5))
-;;;_ : test resumptions:
-;;;_ > allout-tests-obliterate-variable (name)
-(defun allout-tests-obliterate-variable (name)
- "Completely unbind variable with 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
- "Fodder for allout resumptions tests -- defvar just for byte compiler.")
-(defvar allout-tests-globally-true nil
- "Fodder for allout resumptions tests -- defvar just for byte compiler.")
-(defvar allout-tests-locally-true nil
- "Fodder for allout resumptions tests -- defvar just for byte compiler.")
-(defun allout-test-resumptions ()
- ;; FIXME: Use ERT.
- "Exercise allout resumptions."
- ;; for each resumption case, we also test that the right local/global
- ;; scopes are affected during resumption effects:
-
- ;; ensure that previously unbound variables return to the unbound state.
- (with-temp-buffer
- (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
- (allout-add-resumptions '(allout-tests-globally-unbound t))
- (cl-assert (not (default-boundp 'allout-tests-globally-unbound)))
- (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
- (cl-assert (boundp 'allout-tests-globally-unbound))
- (cl-assert (equal allout-tests-globally-unbound t))
- (allout-do-resumptions)
- (cl-assert (not (local-variable-p 'allout-tests-globally-unbound
- (current-buffer))))
- (cl-assert (not (boundp 'allout-tests-globally-unbound))))
-
- ;; ensure that variable with prior global value is resumed
- (with-temp-buffer
- (allout-tests-obliterate-variable 'allout-tests-globally-true)
- (setq allout-tests-globally-true t)
- (allout-add-resumptions '(allout-tests-globally-true nil))
- (cl-assert (equal (default-value 'allout-tests-globally-true) t))
- (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
- (cl-assert (equal allout-tests-globally-true nil))
- (allout-do-resumptions)
- (cl-assert (not (local-variable-p 'allout-tests-globally-true
- (current-buffer))))
- (cl-assert (boundp 'allout-tests-globally-true))
- (cl-assert (equal allout-tests-globally-true t)))
-
- ;; ensure that prior local value is resumed
- (with-temp-buffer
- (allout-tests-obliterate-variable 'allout-tests-locally-true)
- (set (make-local-variable 'allout-tests-locally-true) t)
- (cl-assert (not (default-boundp 'allout-tests-locally-true))
- nil (concat "Test setup mistake -- variable supposed to"
- " not have global binding, but it does."))
- (cl-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))
- (cl-assert (not (default-boundp 'allout-tests-locally-true)))
- (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
- (cl-assert (equal allout-tests-locally-true nil))
- (allout-do-resumptions)
- (cl-assert (boundp 'allout-tests-locally-true))
- (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
- (cl-assert (equal allout-tests-locally-true t))
- (cl-assert (not (default-boundp 'allout-tests-locally-true))))
-
- ;; ensure that last of multiple resumptions holds, for various scopes.
- (with-temp-buffer
- (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
- (allout-tests-obliterate-variable 'allout-tests-globally-true)
- (setq allout-tests-globally-true t)
- (allout-tests-obliterate-variable 'allout-tests-locally-true)
- (set (make-local-variable 'allout-tests-locally-true) t)
- (allout-add-resumptions '(allout-tests-globally-unbound t)
- '(allout-tests-globally-true nil)
- '(allout-tests-locally-true nil))
- (allout-add-resumptions '(allout-tests-globally-unbound 2)
- '(allout-tests-globally-true 3)
- '(allout-tests-locally-true 4))
- ;; reestablish many of the basic conditions are maintained after re-add:
- (cl-assert (not (default-boundp 'allout-tests-globally-unbound)))
- (cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
- (cl-assert (equal allout-tests-globally-unbound 2))
- (cl-assert (default-boundp 'allout-tests-globally-true))
- (cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
- (cl-assert (equal allout-tests-globally-true 3))
- (cl-assert (not (default-boundp 'allout-tests-locally-true)))
- (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
- (cl-assert (equal allout-tests-locally-true 4))
- (allout-do-resumptions)
- (cl-assert (not (local-variable-p 'allout-tests-globally-unbound
- (current-buffer))))
- (cl-assert (not (boundp 'allout-tests-globally-unbound)))
- (cl-assert (not (local-variable-p 'allout-tests-globally-true
- (current-buffer))))
- (cl-assert (boundp 'allout-tests-globally-true))
- (cl-assert (equal allout-tests-globally-true t))
- (cl-assert (boundp 'allout-tests-locally-true))
- (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
- (cl-assert (equal allout-tests-locally-true t))
- (cl-assert (not (default-boundp 'allout-tests-locally-true))))
-
- ;; ensure that deliberately unbinding registered variables doesn't foul things
- (with-temp-buffer
- (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
- (allout-tests-obliterate-variable 'allout-tests-globally-true)
- (setq allout-tests-globally-true t)
- (allout-tests-obliterate-variable 'allout-tests-locally-true)
- (set (make-local-variable 'allout-tests-locally-true) t)
- (allout-add-resumptions '(allout-tests-globally-unbound t)
- '(allout-tests-globally-true nil)
- '(allout-tests-locally-true nil))
- (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
- (allout-tests-obliterate-variable 'allout-tests-globally-true)
- (allout-tests-obliterate-variable 'allout-tests-locally-true)
- (allout-do-resumptions))
- )
-;;;_ % Run unit tests if `allout-run-unit-tests-on-load' is true:
-(when allout-run-unit-tests-on-load
- (allout-run-unit-tests))
-
-;;;_ #12 Provide
(provide 'allout)
;;;_* Local emacs vars.
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 1d916aea466..79dc821ea19 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -39,7 +39,7 @@
;;
;; SGR control sequences are defined in section 3.8.117 of the ECMA-48
;; standard (identical to ISO/IEC 6429), which is freely available as a
-;; PDF file <URL:http://www.ecma-international.org/publications/standards/Ecma-048.htm>.
+;; PDF file <URL:https://www.ecma-international.org/publications/standards/Ecma-048.htm>.
;; The "Graphic Rendition Combination Mode (GRCM)" implemented is
;; "cumulative mode" as defined in section 7.2.8. Cumulative mode
;; means that whenever possible, SGR control sequences are combined
@@ -75,6 +75,7 @@
;;; Code:
(defvar comint-last-output-start)
+(defvar compilation-filter-start)
;; Customization
@@ -84,7 +85,7 @@ This translation effectively colorizes strings and regions based upon
SGR control sequences embedded in the text. SGR (Select Graphic
Rendition) control sequences are defined in section 8.3.117 of the
ECMA-48 standard (identical to ISO/IEC 6429), which is freely available
-at <URL:http://www.ecma-international.org/publications/standards/Ecma-048.htm>
+at <URL:https://www.ecma-international.org/publications/standards/Ecma-048.htm>
as a PDF file."
:version "21.1"
:group 'processes)
@@ -181,6 +182,24 @@ in shell buffers. You set this variable by calling one of:
:group 'ansi-colors
:version "23.2")
+(defcustom ansi-color-for-compilation-mode t
+ "Determines what to do with compilation output.
+If nil, do nothing.
+
+If the symbol `filter', then filter all ANSI graphical control
+sequences.
+
+If anything else (such as t), then translate ANSI graphical
+control sequences into text properties.
+
+In order for this to have any effect, `ansi-color-compilation-filter'
+must be in `compilation-filter-hook'."
+ :type '(choice (const :tag "Do nothing" nil)
+ (const :tag "Filter" filter)
+ (other :tag "Translate" t))
+ :group 'ansi-colors
+ :version "28.1")
+
(defvar ansi-color-apply-face-function #'ansi-color-apply-overlay-face
"Function for applying an Ansi Color face to text in a buffer.
This function should accept three arguments: BEG, END, and FACE,
@@ -228,6 +247,19 @@ This is a good function to put in `comint-output-filter-functions'."
(t
(ansi-color-apply-on-region start-marker end-marker)))))
+;;;###autoload
+(defun ansi-color-compilation-filter ()
+ "Maybe translate SGR control sequences into text properties.
+This function depends on the `ansi-color-for-compilation-mode'
+variable, and is meant to be used in `compilation-filter-hook'."
+ (let ((inhibit-read-only t))
+ (pcase ansi-color-for-compilation-mode
+ ('nil nil)
+ ('filter
+ (ansi-color-filter-region compilation-filter-start (point)))
+ (_
+ (ansi-color-apply-on-region compilation-filter-start (point))))))
+
(define-obsolete-function-alias 'ansi-color-unfontify-region
'font-lock-default-unfontify-region "24.1")
@@ -363,7 +395,7 @@ it will override BEGIN, the start of the region. Set
(setq ansi-color-context-region (list nil (match-beginning 0)))
(setq ansi-color-context-region nil)))))
-(defun ansi-color-apply-on-region (begin end)
+(defun ansi-color-apply-on-region (begin end &optional preserve-sequences)
"Translates SGR control sequences into overlays or extents.
Delete all other control sequences without processing them.
@@ -380,18 +412,28 @@ ansi codes. This information will be used for the next call to
`ansi-color-apply-on-region'. Specifically, it will override
BEGIN, the start of the region and set the face with which to
start. Set `ansi-color-context-region' to nil if you don't want
-this."
+this.
+
+If PRESERVE-SEQUENCES is t, the sequences are hidden instead of
+being deleted."
(let ((codes (car ansi-color-context-region))
- (start-marker (or (cadr ansi-color-context-region)
- (copy-marker begin)))
- (end-marker (copy-marker end)))
+ (start-marker (or (cadr ansi-color-context-region)
+ (copy-marker begin)))
+ (end-marker (copy-marker end)))
(save-excursion
(goto-char start-marker)
;; Find the next escape sequence.
(while (re-search-forward ansi-color-control-seq-regexp end-marker t)
- ;; Remove escape sequence.
- (let ((esc-seq (delete-and-extract-region
+ ;; Extract escape sequence.
+ (let ((esc-seq (buffer-substring
(match-beginning 0) (point))))
+ (if preserve-sequences
+ ;; Make the escape sequence transparent.
+ (overlay-put (make-overlay (match-beginning 0) (point))
+ 'invisible t)
+ ;; Otherwise, strip.
+ (delete-region (match-beginning 0) (point)))
+
;; Colorize the old block from start to end using old face.
(funcall ansi-color-apply-face-function
(prog1 (marker-position start-marker)
@@ -414,11 +456,18 @@ this."
;; if the rest of the region should have a face, put it there
(funcall ansi-color-apply-face-function
start-marker end-marker (ansi-color--find-face codes))
- (setq ansi-color-context-region (if codes (list codes)))))
+ ;; Save a restart position when there are codes active. It's
+ ;; convenient for man.el's process filter to pass `begin'
+ ;; positions that overlap regions previously colored; these
+ ;; `codes' should not be applied to that overlap, so we need
+ ;; to know where they should really start.
+ (setq ansi-color-context-region
+ (if codes (list codes (copy-marker (point)))))))
;; Clean up our temporary markers.
(unless (eq start-marker (cadr ansi-color-context-region))
(set-marker start-marker nil))
- (set-marker end-marker nil)))
+ (unless (eq end-marker (cadr ansi-color-context-region))
+ (set-marker end-marker nil))))
(defun ansi-color-apply-overlay-face (beg end face)
"Make an overlay from BEG to END, and apply face FACE.
@@ -536,7 +585,7 @@ codes. Finally, the so changed list of codes is returned."
(cons new (remq new codes))))
(2 (unless (memq new '(20 26 28 29))
;; The standard says `21 doubly underlined' while
- ;; http://en.wikipedia.org/wiki/ANSI_escape_code claims
+ ;; https://en.wikipedia.org/wiki/ANSI_escape_code claims
;; `21 Bright/Bold: off or Underline: Double'.
(remq (- new 20) (pcase new
(22 (remq 1 codes))
@@ -566,27 +615,27 @@ The face definitions are based upon the variables
(index 0))
;; miscellaneous attributes
(mapc
- (function (lambda (e)
- (aset map index e)
- (setq index (1+ index)) ))
+ (lambda (e)
+ (aset map index e)
+ (setq index (1+ index)) )
ansi-color-faces-vector)
;; foreground attributes
(setq index 30)
(mapc
- (function (lambda (e)
- (aset map index
- (ansi-color-make-face 'foreground
- (if (consp e) (car e) e)))
- (setq index (1+ index)) ))
+ (lambda (e)
+ (aset map index
+ (ansi-color-make-face 'foreground
+ (if (consp e) (car e) e)))
+ (setq index (1+ index)) )
ansi-color-names-vector)
;; background attributes
(setq index 40)
(mapc
- (function (lambda (e)
- (aset map index
- (ansi-color-make-face 'background
- (if (consp e) (cdr e) e)))
- (setq index (1+ index)) ))
+ (lambda (e)
+ (aset map index
+ (ansi-color-make-face 'background
+ (if (consp e) (cdr e) e)))
+ (setq index (1+ index)) )
ansi-color-names-vector)
map))
diff --git a/lisp/apropos.el b/lisp/apropos.el
index 59ae753a557..376c1b2cbc5 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,4 +1,4 @@
-;;; apropos.el --- apropos commands for users and programmers
+;;; apropos.el --- apropos commands for users and programmers -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1994-1995, 2001-2021 Free Software Foundation,
;; Inc.
@@ -27,8 +27,7 @@
;; The ideas for this package were derived from the C code in
;; src/keymap.c and elsewhere. The functions in this file should
-;; always be byte-compiled for speed. Someone should rewrite this in
-;; C (as part of src/keymap.c) for speed.
+;; always be byte-compiled for speed.
;; The idea for super-apropos is based on the original implementation
;; by Lynn Slater <lrs@esl.com>.
@@ -57,8 +56,6 @@
;;; Code:
-(require 'button)
-
(defgroup apropos nil
"Apropos commands for users and programmers."
:group 'help
@@ -82,49 +79,46 @@ commands also has an optional argument to request a more extensive search.
Additionally, this option makes the function `apropos-library'
include key-binding information in its output."
- :group 'apropos
:type 'boolean)
(defface apropos-symbol
'((t (:inherit bold)))
"Face for the symbol name in Apropos output."
- :group 'apropos
:version "24.3")
(defface apropos-keybinding
'((t (:inherit underline)))
"Face for lists of keybinding in Apropos output."
- :group 'apropos
:version "24.3")
(defface apropos-property
'((t (:inherit font-lock-builtin-face)))
"Face for property name in Apropos output, or nil for none."
- :group 'apropos
:version "24.3")
+(defface apropos-button
+ '((t (:inherit (font-lock-variable-name-face button))))
+ "Face for buttons that indicate a face in Apropos."
+ :version "28.1")
+
(defface apropos-function-button
'((t (:inherit (font-lock-function-name-face button))))
"Button face indicating a function, macro, or command in Apropos."
- :group 'apropos
:version "24.3")
(defface apropos-variable-button
'((t (:inherit (font-lock-variable-name-face button))))
"Button face indicating a variable in Apropos."
- :group 'apropos
:version "24.3")
(defface apropos-user-option-button
'((t (:inherit (font-lock-variable-name-face button))))
"Button face indicating a user option in Apropos."
- :group 'apropos
:version "24.4")
(defface apropos-misc-button
'((t (:inherit (font-lock-constant-face button))))
"Button face indicating a miscellaneous object type in Apropos."
- :group 'apropos
:version "24.3")
(defcustom apropos-match-face 'match
@@ -132,14 +126,12 @@ include key-binding information in its output."
This applies when you look for matches in the documentation or variable value
for the pattern; the part that matches gets displayed in this font."
:type '(choice (const nil) face)
- :group 'apropos
:version "24.3")
(defcustom apropos-sort-by-scores nil
"Non-nil means sort matches by scores; best match is shown first.
This applies to all `apropos' commands except `apropos-documentation'.
If value is `verbose', the computed score is shown for each match."
- :group 'apropos
:type '(choice (const :tag "off" nil)
(const :tag "on" t)
(const :tag "show scores" verbose)))
@@ -148,7 +140,6 @@ If value is `verbose', the computed score is shown for each match."
"Non-nil means sort matches by scores; best match is shown first.
This applies to `apropos-documentation' only.
If value is `verbose', the computed score is shown for each match."
- :group 'apropos
:type '(choice (const :tag "off" nil)
(const :tag "on" t)
(const :tag "show scores" verbose)))
@@ -159,7 +150,11 @@ If value is `verbose', the computed score is shown for each match."
;; 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 "\C-m" #'apropos-follow)
+
+ ;; Movement keys
+ (define-key map "n" #'apropos-next-symbol)
+ (define-key map "p" #'apropos-previous-symbol)
map)
"Keymap used in Apropos mode.")
@@ -286,7 +281,7 @@ before `apropos-mode' makes it buffer-local.")
(define-button-type 'apropos-face
'apropos-label "Face"
'apropos-short-label "F"
- 'face '(font-lock-variable-name-face button)
+ 'face 'apropos-button
'help-echo "mouse-2, RET: Display more help on this face"
'follow-link t
'action (lambda (button)
@@ -348,7 +343,7 @@ before finding a label."
(defun apropos-words-to-regexp (words wild)
- "Make regexp matching any two of the words in WORDS.
+ "Return a regexp matching any two of the words in WORDS.
WILD should be a subexpression matching wildcards between matches."
(setq words (delete-dups (copy-sequence words)))
(if (null (cdr words))
@@ -357,7 +352,7 @@ WILD should be a subexpression matching wildcards between matches."
(lambda (w)
(concat "\\(?:" w "\\)" ;; parens for synonyms
wild "\\(?:"
- (mapconcat 'identity
+ (mapconcat #'identity
(delq w (copy-sequence words))
"\\|")
"\\)"))
@@ -380,9 +375,11 @@ kind of objects to search."
(user-error "No word list given"))
pattern)))
-(defun apropos-parse-pattern (pattern)
+(defun apropos-parse-pattern (pattern &optional multiline-p)
"Rewrite a list of words to a regexp matching all permutations.
If PATTERN is a string, that means it is already a regexp.
+MULTILINE-P, if non-nil, means produce a regexp that will match
+the words even if separated by newlines.
This updates variables `apropos-pattern', `apropos-pattern-quoted',
`apropos-regexp', `apropos-words', and `apropos-all-words-regexp'."
(setq apropos-words nil
@@ -393,15 +390,18 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted',
;; any combination of two or more words like this:
;; (a|b|c).*(a|b|c) which may give some false matches,
;; but as long as it also gives the right ones, that's ok.
+ ;; (Actually, when MULTILINE-P is non-nil, instead of '.' we
+ ;; use a trick that would find a match even if the words are
+ ;; on different lines.
(let ((words pattern))
- (setq apropos-pattern (mapconcat 'identity pattern " ")
+ (setq apropos-pattern (mapconcat #'identity pattern " ")
apropos-pattern-quoted (regexp-quote apropos-pattern))
(dolist (word words)
(let ((syn apropos-synonyms) (s word) (a word))
(while syn
(if (member word (car syn))
(progn
- (setq a (mapconcat 'identity (car syn) "\\|"))
+ (setq a (mapconcat #'identity (car syn) "\\|"))
(if (member word (cdr (car syn)))
(setq s a))
(setq syn nil))
@@ -409,9 +409,13 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted',
(setq apropos-words (cons s apropos-words)
apropos-all-words (cons a apropos-all-words))))
(setq apropos-all-words-regexp
- (apropos-words-to-regexp apropos-all-words ".+"))
+ (apropos-words-to-regexp apropos-all-words
+ ;; The [^b-a] trick matches any
+ ;; character including a newline.
+ (if multiline-p "[^b-a]+?" ".+")))
(setq apropos-regexp
- (apropos-words-to-regexp apropos-words ".*?")))
+ (apropos-words-to-regexp apropos-words
+ (if multiline-p "[^b-a]*?" ".*?"))))
(setq apropos-pattern-quoted (regexp-quote pattern)
apropos-all-words-regexp pattern
apropos-pattern pattern
@@ -514,7 +518,7 @@ variables, not just user options."
#'(lambda (symbol)
(and (boundp symbol)
(get symbol 'variable-documentation)))
- 'custom-variable-p)))
+ #'custom-variable-p)))
;;;###autoload
(defun apropos-variable (pattern &optional do-not-all)
@@ -541,9 +545,23 @@ will be buffer-local when set."
(and (local-variable-if-set-p symbol)
(get symbol 'variable-documentation)))))
+;;;###autoload
+(defun apropos-function (pattern)
+ "Show functions that match 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.
+
+This is the same as running `apropos-command' with a \\[universal-argument] prefix,
+or a non-nil `apropos-do-all' argument."
+ (interactive (list (apropos-read-pattern "function")))
+ (apropos-command pattern t))
+
;; For auld lang syne:
;;;###autoload
-(defalias 'command-apropos 'apropos-command)
+(defalias 'command-apropos #'apropos-command)
;;;###autoload
(defun apropos-command (pattern &optional do-all var-predicate)
"Show commands (interactively callable functions) that match PATTERN.
@@ -640,7 +658,7 @@ search for matches for any two (or more) of those words.
With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil,
consider all symbols (if they match PATTERN).
-Returns list of symbols and documentation found."
+Return list of symbols and documentation found."
(interactive (list (apropos-read-pattern "symbol")
current-prefix-arg))
(setq apropos--current (list #'apropos pattern do-all))
@@ -659,12 +677,11 @@ Returns list of symbols and documentation found."
(defun apropos-library-button (sym)
(if (null sym)
"<nothing>"
- (let ((name (copy-sequence (symbol-name sym))))
+ (let ((name (symbol-name sym)))
(make-text-button name nil
'type 'apropos-library
'face 'apropos-symbol
- 'apropos-symbol name)
- name)))
+ 'apropos-symbol name))))
;;;###autoload
(defun apropos-library (file)
@@ -673,7 +690,7 @@ FILE should be one of the libraries currently loaded and should
thus be found in `load-history'. If `apropos-do-all' is non-nil,
the output includes key-bindings of commands."
(interactive
- (let* ((libs (delq nil (mapcar 'car load-history)))
+ (let* ((libs (delq nil (mapcar #'car load-history)))
(libs
(nconc (delq nil
(mapcar
@@ -707,22 +724,27 @@ the output includes key-bindings of commands."
;; (autoload (push (cdr x) autoloads))
('require (push (cdr x) requires))
('provide (push (cdr x) provides))
- ('t nil) ; Skip "was an autoload" entries.
+ ('t nil) ; Skip "was an autoload" entries.
;; FIXME: Print information about each individual method: both
;; its docstring and specializers (bug#21422).
('cl-defmethod (push (cadr x) provides))
(_ (push (or (cdr-safe x) x) symbols))))
- (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
- (apropos-symbols-internal
- symbols apropos-do-all
- (concat
- (format-message
- "Library `%s' provides: %s\nand requires: %s"
- file
- (mapconcat 'apropos-library-button
- (or provides '(nil)) " and ")
- (mapconcat 'apropos-library-button
- (or requires '(nil)) " and ")))))))
+ (let ((apropos-pattern "") ;Dummy binding for apropos-symbols-internal.
+ (text
+ (concat
+ (format-message
+ "Library `%s' provides: %s\nand requires: %s"
+ file
+ (mapconcat #'apropos-library-button
+ (or provides '(nil)) " and ")
+ (mapconcat #'apropos-library-button
+ (or requires '(nil)) " and ")))))
+ (if (null symbols)
+ (with-output-to-temp-buffer "*Apropos*"
+ (with-current-buffer standard-output
+ (apropos-mode)
+ (apropos--preamble text)))
+ (apropos-symbols-internal symbols apropos-do-all text)))))
(defun apropos-symbols-internal (symbols keys &optional text)
;; Filter out entries that are marked as apropos-inhibit.
@@ -794,37 +816,37 @@ Returns list of symbols and values found."
(interactive (list (apropos-read-pattern "value")
current-prefix-arg))
(setq apropos--current (list #'apropos-value pattern do-all))
- (apropos-parse-pattern pattern)
+ (apropos-parse-pattern pattern t)
(or do-all (setq do-all apropos-do-all))
(setq apropos-accumulator ())
- (let (f v p)
- (mapatoms
- (lambda (symbol)
- (setq f nil v nil p nil)
- (or (memq symbol '(apropos-regexp
- apropos-pattern apropos-all-words-regexp
- apropos-words apropos-all-words
- do-all apropos-accumulator
- symbol f v p))
- (setq v (apropos-value-internal 'boundp symbol 'symbol-value)))
- (if do-all
- (setq f (apropos-value-internal 'fboundp symbol 'symbol-function)
- p (apropos-format-plist symbol "\n " t)))
- (if (apropos-false-hit-str v)
- (setq v nil))
- (if (apropos-false-hit-str f)
- (setq f nil))
- (if (apropos-false-hit-str p)
- (setq p nil))
- (if (or f v p)
- (setq apropos-accumulator (cons (list symbol
- (+ (apropos-score-str f)
- (apropos-score-str v)
- (apropos-score-str p))
- f v p)
- apropos-accumulator))))))
- (let ((apropos-multi-type do-all))
- (apropos-print nil "\n----------------\n")))
+ (let (f v p)
+ (mapatoms
+ (lambda (symbol)
+ (setq f nil v nil p nil)
+ (or (memq symbol '(apropos-regexp
+ apropos--current apropos-pattern-quoted pattern
+ apropos-pattern apropos-all-words-regexp
+ apropos-words apropos-all-words
+ apropos-accumulator))
+ (setq v (apropos-value-internal #'boundp symbol #'symbol-value)))
+ (if do-all
+ (setq f (apropos-value-internal #'fboundp symbol #'symbol-function)
+ p (apropos-format-plist symbol "\n " t)))
+ (if (apropos-false-hit-str v)
+ (setq v nil))
+ (if (apropos-false-hit-str f)
+ (setq f nil))
+ (if (apropos-false-hit-str p)
+ (setq p nil))
+ (if (or f v p)
+ (setq apropos-accumulator (cons (list symbol
+ (+ (apropos-score-str f)
+ (apropos-score-str v)
+ (apropos-score-str p))
+ f v p)
+ apropos-accumulator))))))
+ (let ((apropos-multi-type do-all))
+ (apropos-print nil "\n----------------\n")))
;;;###autoload
(defun apropos-local-value (pattern &optional buffer)
@@ -834,28 +856,28 @@ Optional arg BUFFER (default: current buffer) is the buffer to check."
(interactive (list (apropos-read-pattern "value of buffer-local variable")))
(unless buffer (setq buffer (current-buffer)))
(setq apropos--current (list #'apropos-local-value pattern buffer))
- (apropos-parse-pattern pattern)
+ (apropos-parse-pattern pattern t)
(setq apropos-accumulator ())
(let ((var nil))
(mapatoms
(lambda (symb)
- (unless (memq symb '(apropos-regexp apropos-pattern apropos-all-words-regexp
- apropos-words apropos-all-words apropos-accumulator symb var))
- (setq var (apropos-value-internal 'local-variable-if-set-p symb 'symbol-value)))
+ (unless (memq symb '(apropos-regexp apropos-pattern
+ apropos-all-words-regexp apropos-words
+ apropos-all-words apropos-accumulator))
+ (setq var (apropos-value-internal #'local-variable-if-set-p symb
+ #'symbol-value)))
(when (and (fboundp 'apropos-false-hit-str) (apropos-false-hit-str var))
(setq var nil))
(when var
(setq apropos-accumulator (cons (list symb (apropos-score-str var) nil var)
apropos-accumulator))))))
(let ((apropos-multi-type nil))
- (if (> emacs-major-version 20)
- (apropos-print
- nil "\n----------------\n"
- (format "Buffer `%s' has the following local variables\nmatching %s`%s':"
- (buffer-name buffer)
- (if (consp pattern) "keywords " "")
- pattern))
- (apropos-print nil "\n----------------\n"))))
+ (apropos-print
+ nil "\n----------------\n"
+ (format "Buffer `%s' has the following local variables\nmatching %s`%s':"
+ (buffer-name buffer)
+ (if (consp pattern) "keywords " "")
+ pattern))))
;;;###autoload
(defun apropos-documentation (pattern &optional do-all)
@@ -876,7 +898,7 @@ Returns list of symbols and documentation found."
(interactive (list (apropos-read-pattern "documentation")
current-prefix-arg))
(setq apropos--current (list #'apropos-documentation pattern do-all))
- (apropos-parse-pattern pattern)
+ (apropos-parse-pattern pattern t)
(or do-all (setq do-all apropos-do-all))
(setq apropos-accumulator () apropos-files-scanned ())
(let ((standard-input (get-buffer-create " apropos-temp"))
@@ -917,16 +939,20 @@ Returns list of symbols and documentation found."
(defun apropos-value-internal (predicate symbol function)
- (if (funcall predicate symbol)
- (progn
- (setq symbol (prin1-to-string (funcall function symbol)))
- (if (string-match apropos-regexp symbol)
- (progn
- (if apropos-match-face
- (put-text-property (match-beginning 0) (match-end 0)
- 'face apropos-match-face
- symbol))
- symbol)))))
+ (when (funcall predicate symbol)
+ (setq symbol (prin1-to-string
+ (if (memq symbol '(command-history minibuffer-history))
+ ;; The value we're looking for will always be in
+ ;; the first element of these two lists, so skip
+ ;; that value.
+ (cdr (funcall function symbol))
+ (funcall function symbol))))
+ (when (string-match apropos-regexp symbol)
+ (if apropos-match-face
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face apropos-match-face
+ symbol))
+ symbol)))
(defun apropos-documentation-internal (doc)
(cond
@@ -948,6 +974,10 @@ Returns list of symbols and documentation found."
doc))))
(defun apropos-format-plist (pl sep &optional compare)
+ "Return a string representation of the plist PL.
+Paired elements are separated by the string SEP. Only include
+properties matching the current `apropos-regexp' when COMPARE is
+non-nil."
(setq pl (symbol-plist pl))
(let (p p-out)
(while pl
@@ -956,13 +986,12 @@ Returns list of symbols and documentation found."
(put-text-property 0 (length (symbol-name (car pl)))
'face 'apropos-property p)
(setq p nil))
- (if p
- (progn
- (and compare apropos-match-face
- (put-text-property (match-beginning 0) (match-end 0)
- 'face apropos-match-face
- p))
- (setq p-out (concat p-out (if p-out sep) p))))
+ (when p
+ (and compare apropos-match-face
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face apropos-match-face
+ p))
+ (setq p-out (concat p-out (if p-out sep) p)))
(setq pl (nthcdr 2 pl)))
p-out))
@@ -1130,10 +1159,7 @@ as a heading."
symbol item)
(set-buffer standard-output)
(apropos-mode)
- (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"))
+ (apropos--preamble text)
(dolist (apropos-item p)
(when (and spacing (not (bobp)))
(princ spacing))
@@ -1214,8 +1240,8 @@ as a heading."
(apropos-print-doc 6 'apropos-face t)
(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-local truncate-partial-width-windows t)
+ (setq-local truncate-lines t))))
(prog1 apropos-accumulator
(setq apropos-accumulator ()))) ; permit gc
@@ -1263,6 +1289,14 @@ as a heading."
(fill-region opoint (point) nil t)))
(or (bolp) (terpri)))))
+(defun apropos--preamble (text)
+ (let ((inhibit-read-only t))
+ (insert (substitute-command-keys "Type \\[apropos-follow] on ")
+ (if apropos-multi-type "a type label" "an entry")
+ " to view its full documentation.\n\n")
+ (when text
+ (insert text "\n\n"))))
+
(defun apropos-follow ()
"Invokes any button at point, otherwise invokes the nearest label button."
(interactive)
@@ -1270,6 +1304,21 @@ as a heading."
(or (apropos-next-label-button (line-beginning-position))
(error "There is nothing to follow here"))))
+(defun apropos-next-symbol ()
+ "Move cursor down to the next symbol in an apropos-mode buffer."
+ (interactive)
+ (forward-line)
+ (while (and (not (eq (face-at-point) 'apropos-symbol))
+ (< (point) (point-max)))
+ (forward-line)))
+
+(defun apropos-previous-symbol ()
+ "Move cursor back to the last symbol in an apropos-mode buffer."
+ (interactive)
+ (forward-line -1)
+ (while (and (not (eq (face-at-point) 'apropos-symbol))
+ (> (point) (point-min)))
+ (forward-line -1)))
(defun apropos-describe-plist (symbol)
"Display a pretty listing of SYMBOL's plist."
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 3463badeff8..83c516100ab 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -1,4 +1,4 @@
-;;; arc-mode.el --- simple editing of archives
+;;; arc-mode.el --- simple editing of archives -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997-1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -41,8 +41,7 @@
;; changes will first take effect when the archive buffer
;; is saved. You will be warned about this.
;;
-;; * dos-fns.el: (Part of Emacs 19). You get automatic ^M^J <--> ^J
-;; conversion.
+;; * dos-fns.el: You get automatic ^M^J <--> ^J conversion.
;;
;; arc-mode.el does not work well with crypt++.el; for the archives as
;; such this could be fixed (but wouldn't be useful) by declaring such
@@ -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 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 Y
-;; Add new member N N N N N N
-;; Delete member Y Y Y Y N Y
-;; Rename member Y Y N N N N
-;; Chmod - Y Y - N N
-;; Chown - Y - - N N
-;; Chgrp - Y - - N N
+;; Arc Lzh Zip Zoo Rar 7z Ar Squashfs
+;; ---------------------------------------------------------------
+;; View listing Intern Intern Intern Intern Y Y Y Y
+;; Extract member Y Y Y Y Y Y Y Y
+;; Save changed member Y Y Y Y N Y Y N
+;; Add new member N N N N N N N N
+;; Delete member Y Y Y Y N Y N N
+;; Rename member Y Y N N N N N N
+;; Chmod - Y Y - N N N N
+;; Chown - Y - - N N N N
+;; Chgrp - Y - - N N N N
;;
;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
;; on the first released version of this package.
@@ -101,6 +100,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
;; -------------------------------------------------------------------------
;;; Section: Configuration.
@@ -108,22 +109,6 @@
"Simple editing of archives."
:group 'data)
-(defgroup archive-arc nil
- "ARC-specific options to archive."
- :group 'archive)
-
-(defgroup archive-lzh nil
- "LZH-specific options to archive."
- :group 'archive)
-
-(defgroup archive-zip nil
- "ZIP-specific options to archive."
- :group 'archive)
-
-(defgroup archive-zoo nil
- "ZOO-specific options to archive."
- :group 'archive)
-
(defcustom archive-tmpdir
;; make-temp-name is safe here because we use this name
;; to create a directory.
@@ -131,35 +116,48 @@
(expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp")
temporary-file-directory))
"Directory for temporary files made by `arc-mode.el'."
- :type 'directory
- :group 'archive)
+ :type 'directory)
(defcustom archive-remote-regexp "^/[^/:]*[^/:.]:"
"Regexp recognizing archive files names that are not local.
A non-local file is one whose file name is not proper outside Emacs.
A local copy of the archive will be used when updating."
- :type 'regexp
- :group 'archive)
+ :type 'regexp)
(define-obsolete-variable-alias 'archive-extract-hooks
'archive-extract-hook "24.3")
(defcustom archive-extract-hook nil
"Hook run when an archive member has been extracted."
- :type 'hook
- :group 'archive)
+ :type 'hook)
(defcustom archive-visit-single-files nil
"If non-nil, opening an archive with a single file visits that file.
If nil, visiting such an archive displays the archive summary."
:version "25.1"
:type '(choice (const :tag "Visit the single file" t)
- (const :tag "Show the archive summary" nil))
- :group 'archive)
+ (const :tag "Show the archive summary" nil)))
+
+(defcustom archive-hidden-columns '(Ids)
+ "Columns hidden from display."
+ :version "28.1"
+ :type '(set (const Mode)
+ (const Ids)
+ (const Date&Time)
+ (const Ratio)))
+
+(defconst archive-alternate-hidden-columns '(Mode Date&Time)
+ "Columns hidden when `archive-alternate-display' is used.")
+
;; ------------------------------
;; Arc archive configuration
;; We always go via a local file since there seems to be no reliable way
;; to extract to stdout without junk getting added.
+
+(defgroup archive-arc nil
+ "ARC-specific options to archive."
+ :group 'archive)
+
(defcustom archive-arc-extract
'("arc" "x")
"Program and its options to run in order to extract an arc file member.
@@ -168,8 +166,7 @@ name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-arc)
+ (string :format "%v"))))
(defcustom archive-arc-expunge
'("arc" "d")
@@ -178,8 +175,7 @@ Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-arc)
+ (string :format "%v"))))
(defcustom archive-arc-write-file-member
'("arc" "u")
@@ -188,11 +184,14 @@ Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-arc)
+ (string :format "%v"))))
;; ------------------------------
;; Lzh archive configuration
+(defgroup archive-lzh nil
+ "LZH-specific options to archive."
+ :group 'archive)
+
(defcustom archive-lzh-extract
'("lha" "pq")
"Program and its options to run in order to extract an lzh file member.
@@ -201,8 +200,7 @@ be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-lzh)
+ (string :format "%v"))))
(defcustom archive-lzh-expunge
'("lha" "d")
@@ -211,8 +209,7 @@ Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-lzh)
+ (string :format "%v"))))
(defcustom archive-lzh-write-file-member
'("lha" "a")
@@ -221,8 +218,7 @@ Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-lzh)
+ (string :format "%v"))))
;; ------------------------------
;; Zip archive configuration
@@ -231,6 +227,10 @@ Archive and member name will be added."
(when 7z
(file-name-nondirectory 7z))))
+(defgroup archive-zip nil
+ "ZIP-specific options to archive."
+ :group 'archive)
+
(defcustom archive-zip-extract
(cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
(archive-7z-program `(,archive-7z-program "x" "-so"))
@@ -242,8 +242,7 @@ be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zip)
+ (string :format "%v"))))
;; For several reasons the latter behavior is not desirable in general.
;; (1) It uses more disk space. (2) Error checking is worse or non-
@@ -260,8 +259,7 @@ Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zip)
+ (string :format "%v"))))
(defcustom archive-zip-update
(cond ((executable-find "zip") '("zip" "-q"))
@@ -274,8 +272,7 @@ file. Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zip)
+ (string :format "%v"))))
(defcustom archive-zip-update-case
(cond ((executable-find "zip") '("zip" "-q" "-k"))
@@ -288,8 +285,7 @@ Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zip)
+ (string :format "%v"))))
(declare-function msdos-long-file-names "msdos.c")
(defcustom archive-zip-case-fiddle (and (eq system-type 'ms-dos)
@@ -300,11 +296,14 @@ that uses caseless file names.
In addition, this flag forces members added/updated in the zip archive
to be truncated to DOS 8+3 file-name restrictions."
:type 'boolean
- :version "27.1"
- :group 'archive-zip)
+ :version "27.1")
;; ------------------------------
;; Zoo archive configuration
+(defgroup archive-zoo nil
+ "ZOO-specific options to archive."
+ :group 'archive)
+
(defcustom archive-zoo-extract
'("zoo" "xpq")
"Program and its options to run in order to extract a zoo file member.
@@ -313,8 +312,7 @@ be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zoo)
+ (string :format "%v"))))
(defcustom archive-zoo-expunge
'("zoo" "DqPP")
@@ -323,8 +321,7 @@ Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zoo)
+ (string :format "%v"))))
(defcustom archive-zoo-write-file-member
'("zoo" "a")
@@ -333,11 +330,14 @@ Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-zoo)
+ (string :format "%v"))))
;; ------------------------------
;; 7z archive configuration
+(defgroup archive-7z nil
+ "7Z-specific options to archive."
+ :group 'archive)
+
(defcustom archive-7z-extract
`(,(or archive-7z-program "7z") "x" "-so")
"Program and its options to run in order to extract a 7z file member.
@@ -347,8 +347,7 @@ be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-7z)
+ (string :format "%v"))))
(defcustom archive-7z-expunge
`(,(or archive-7z-program "7z") "d")
@@ -358,8 +357,7 @@ Archive and member names will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
- (string :format "%v")))
- :group 'archive-7z)
+ (string :format "%v"))))
(defcustom archive-7z-update
`(,(or archive-7z-program "7z") "u")
@@ -370,18 +368,35 @@ file. Archive and member name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
+ (string :format "%v"))))
+
+;; ------------------------------
+;; Squashfs archive configuration
+
+(defgroup archive-squashfs nil
+ "Squashfs-specific options to archive."
+ :group 'archive)
+
+(defcustom archive-squashfs-extract '("rdsquashfs" "-c")
+ "Program and its options to run in order to extract a squashsfs 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)
+ :version "28.1"
+ :group 'archive-squashfs)
;; -------------------------------------------------------------------------
;;; Section: Variables
(defvar archive-subtype nil "Symbol describing archive type.")
-(defvar archive-file-list-start nil "Position of first contents line.")
-(defvar archive-file-list-end nil "Position just after last contents line.")
-(defvar archive-proper-file-start nil "Position of real archive's start.")
+(defvar-local archive-file-list-start nil "Position of first contents line.")
+(defvar-local archive-file-list-end nil "Position just after last contents line.")
+(defvar-local archive-proper-file-start nil "Position of real archive's start.")
(defvar archive-read-only nil "Non-nil if the archive is read-only on disk.")
-(defvar archive-local-name nil "Name of local copy of remote archive.")
+(defvar-local archive-local-name nil "Name of local copy of remote archive.")
(defvar archive-mode-map
(let ((map (make-keymap)))
(set-keymap-parent map special-mode-map)
@@ -393,6 +408,7 @@ file. 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 "C" 'archive-copy-file)
(define-key map "m" 'archive-mark)
(define-key map "n" 'archive-next-line)
(define-key map "\C-n" 'archive-next-line)
@@ -428,11 +444,13 @@ file. Archive and member name will be added."
(cons "Immediate" (make-sparse-keymap "Immediate")))
(define-key map [menu-bar immediate alternate]
'(menu-item "Alternate Display" archive-alternate-display
- :enable (boundp (archive-name "alternate-display"))
:help "Toggle alternate file info display"))
(define-key map [menu-bar immediate view]
'(menu-item "View This File" archive-view
:help "Display file at cursor in View Mode"))
+ (define-key map [menu-bar immediate view]
+ '(menu-item "Copy This File" archive-copy-file
+ :help "Copy file at cursor to another location"))
(define-key map [menu-bar immediate display]
'(menu-item "Display in Other Window" archive-display-other-window
:help "Display file at cursor in another window"))
@@ -483,36 +501,58 @@ file. Archive and member name will be added."
:help "Delete all flagged files from archive"))
map)
"Local keymap for archive mode listings.")
-(defvar archive-file-name-indent nil "Column where file names start.")
+(defvar-local archive-file-name-indent nil "Column where file names start.")
-(defvar archive-remote nil "Non-nil if the archive is outside file system.")
-(make-variable-buffer-local 'archive-remote)
+(defvar-local archive-remote nil "Non-nil if the archive is outside file system.")
(put 'archive-remote 'permanent-local t)
-(defvar archive-member-coding-system nil "Coding-system of archive member.")
-(make-variable-buffer-local 'archive-member-coding-system)
+(defvar-local archive-member-coding-system nil "Coding-system of archive member.")
-(defvar archive-alternate-display nil
+(defvar-local archive-alternate-display nil
"Non-nil when alternate information is shown.")
-(make-variable-buffer-local 'archive-alternate-display)
(put 'archive-alternate-display 'permanent-local t)
(defvar archive-superior-buffer nil "In archive members, points to archive.")
(put 'archive-superior-buffer 'permanent-local t)
-(defvar archive-subfile-mode nil "Non-nil in archive member buffers.")
-(make-variable-buffer-local 'archive-subfile-mode)
+(defvar-local archive-subfile-mode nil
+ "Non-nil in archive member buffers.
+Its value is an `archive--file-desc'.")
(put 'archive-subfile-mode 'permanent-local t)
-(defvar archive-file-name-coding-system nil)
-(make-variable-buffer-local 'archive-file-name-coding-system)
+(defvar-local archive-file-name-coding-system nil)
(put 'archive-file-name-coding-system 'permanent-local t)
-(defvar archive-files nil
- "Vector of file descriptors.
-Each descriptor is a vector of the form
- [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]")
-(make-variable-buffer-local 'archive-files)
+(cl-defstruct (archive--file-desc
+ (:constructor nil)
+ (:constructor archive--file-desc
+ ;; ext-file-name and int-file-name are usually `eq'
+ ;; except when int-file-name is the downcased
+ ;; ext-file-name.
+ (ext-file-name int-file-name mode size time
+ &key pos ratio uid gid)))
+ ext-file-name int-file-name
+ (mode nil :type integer)
+ (size nil :type integer)
+ (time nil :type string)
+ (ratio nil :type string)
+ uid gid
+ pos)
+
+;; Features in formats:
+;;
+;; ARC: size, date&time (date and time strings internally generated)
+;; LZH: size, date&time, mode, uid, gid (mode, date, time generated, ugid:int)
+;; ZIP: size, date&time, mode (mode, date, time generated)
+;; ZOO: size, date&time (date and time strings internally generated)
+;; AR : size, date&time, mode, user, group (internally generated)
+;; RAR: size, date&time, ratio (all as strings, using `lsar')
+;; 7Z : size, date&time (all as strings, using `7z' or `7za')
+;;
+;; LZH has alternate display (with UID/GID i.s.o MODE/DATE/TIME
+
+(defvar-local archive-files nil
+ "Vector of `archive--file-desc' objects.")
;; -------------------------------------------------------------------------
;;; Section: Support functions.
@@ -520,9 +560,9 @@ Each descriptor is a vector of the form
(defun arc-insert-unibyte (&rest args)
"Like insert but don't make unibyte string and eight-bit char multibyte."
(dolist (elt args)
- (if (integerp elt)
- (insert (if (< elt 128) elt (decode-char 'eight-bit elt)))
- (insert elt))))
+ (insert (if (and (integerp elt) (>= elt 128))
+ (decode-char 'eight-bit elt)
+ elt))))
(defsubst archive-name (suffix)
(intern (concat "archive-" (symbol-name archive-subtype) "-" suffix)))
@@ -544,73 +584,19 @@ in which case a second argument, length LEN, should be supplied."
(aref str (- len i)))))
result))
-(defun archive-int-to-mode (mode)
- "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------."
- ;; FIXME: merge with tar-grind-file-mode.
- (string
- (if (zerop (logand 8192 mode))
- (if (zerop (logand 16384 mode)) ?- ?d)
- ?c) ; completeness
- (if (zerop (logand 256 mode)) ?- ?r)
- (if (zerop (logand 128 mode)) ?- ?w)
- (if (zerop (logand 64 mode))
- (if (zerop (logand 2048 mode)) ?- ?S)
- (if (zerop (logand 2048 mode)) ?x ?s))
- (if (zerop (logand 32 mode)) ?- ?r)
- (if (zerop (logand 16 mode)) ?- ?w)
- (if (zerop (logand 8 mode))
- (if (zerop (logand 1024 mode)) ?- ?S)
- (if (zerop (logand 1024 mode)) ?x ?s))
- (if (zerop (logand 4 mode)) ?- ?r)
- (if (zerop (logand 2 mode)) ?- ?w)
- (if (zerop (logand 1 mode)) ?- ?x)))
-
-(defun archive-calc-mode (oldmode newmode &optional error)
+(define-obsolete-function-alias 'archive-int-to-mode
+ 'file-modes-number-to-symbolic "28.1")
+
+(defun archive-calc-mode (oldmode newmode)
"From the integer OLDMODE and the string NEWMODE calculate a new file mode.
NEWMODE may be an octal number including a leading zero in which case it
will become the new mode.\n
NEWMODE may also be a relative specification like \"og-rwx\" in which case
-OLDMODE will be modified accordingly just like chmod(2) would have done.\n
-If optional third argument ERROR is non-nil an error will be signaled if
-the mode is invalid. If ERROR is nil then nil will be returned."
- (cond ((string-match "^0[0-7]*$" newmode)
- (let ((result 0)
- (len (length newmode))
- (i 1))
- (while (< i len)
- (setq result (+ (ash result 3) (aref newmode i) (- ?0))
- i (1+ i)))
- (logior (logand oldmode 65024) result)))
- ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode)
- (let ((who 0)
- (result oldmode)
- (op (aref newmode (match-beginning 2)))
- (bits 0)
- (i (match-beginning 3)))
- (while (< i (match-end 3))
- (let ((rwx (aref newmode i)))
- (setq bits (logior bits (cond ((= rwx ?r) 292)
- ((= rwx ?w) 146)
- ((= rwx ?x) 73)
- ((= rwx ?s) 3072)
- ((= rwx ?t) 512)))
- i (1+ i))))
- (while (< who (match-end 1))
- (let* ((whoc (aref newmode who))
- (whomask (cond ((= whoc ?a) 4095)
- ((= whoc ?u) 1472)
- ((= whoc ?g) 2104)
- ((= whoc ?o) 7))))
- (if (= op ?=)
- (setq result (logand result (lognot whomask))))
- (if (= op ?-)
- (setq result (logand result (lognot (logand whomask bits))))
- (setq result (logior result (logand whomask bits)))))
- (setq who (1+ who)))
- result))
- (t
- (if error
- (error "Invalid mode specification: %s" newmode)))))
+OLDMODE will be modified accordingly just like chmod(2) would have done."
+ ;; FIXME: Use `file-modes-symbolic-to-number'!
+ (if (string-match "\\`0[0-7]*\\'" newmode)
+ (logior (logand oldmode #o177000) (string-to-number newmode 8))
+ (file-modes-symbolic-to-number newmode oldmode)))
(defun archive-dosdate (date)
"Stringify dos packed DATE record."
@@ -622,7 +608,8 @@ the mode is invalid. If ERROR is nil then nil will be returned."
(format "%2d-%s-%d"
day
(aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun"
- "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month))
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
+ (1- month))
year))))
(defun archive-dostime (time)
@@ -658,10 +645,12 @@ Does not signal an error if optional argument NOERROR is non-nil."
(if (and (>= (point) archive-file-list-start)
(< no (length archive-files)))
(let ((item (aref archive-files no)))
- (if (vectorp item)
+ (if (and (archive--file-desc-p item)
+ (let ((mode (or (archive--file-desc-mode item) 0)))
+ (zerop (logand 16384 mode))))
item
(if (not noerror)
- (error "Entry is not a regular member of the archive"))))
+ (user-error "Entry is not a regular member of the archive"))))
(if (not noerror)
(error "Line does not describe a member of the archive")))))
;; -------------------------------------------------------------------------
@@ -671,11 +660,11 @@ Does not signal an error if optional argument NOERROR is non-nil."
(defun archive-mode (&optional force)
"Major mode for viewing an archive file in a dired-like way.
You can move around using the usual cursor motion commands.
-Letters no longer insert themselves.
-Type `e' to pull a file out of the archive and into its own buffer;
+Letters no longer insert themselves.\\<archive-mode-map>
+Type \\[archive-extract] to pull a file out of the archive and into its own buffer;
or click mouse-2 on the file's line in the archive mode buffer.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[archive-extract] command) and
save it, the contents of that buffer will be saved back into the
archive.
@@ -684,41 +673,34 @@ archive.
;; mode on and off. You can corrupt things that way.
(if (zerop (buffer-size))
;; At present we cannot create archives from scratch
- (funcall (or (default-value 'major-mode) 'fundamental-mode))
+ (funcall (or (default-value 'major-mode) #'fundamental-mode))
(if (and (not force) archive-files) nil
(kill-all-local-variables)
(let* ((type (archive-find-type))
(typename (capitalize (symbol-name type))))
- (make-local-variable 'archive-subtype)
- (setq archive-subtype type)
+ (setq-local archive-subtype type)
;; Buffer contains treated image of file before the file contents
- (make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function 'archive-mode-revert)
- (auto-save-mode 0)
+ (add-function :around (local 'revert-buffer-function)
+ #'archive--mode-revert)
- (add-hook 'write-contents-functions 'archive-write-file nil t)
+ (add-hook 'write-contents-functions #'archive-write-file nil t)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline nil)
- (make-local-variable 'local-enable-local-variables)
- (setq local-enable-local-variables nil)
+ (setq-local truncate-lines t)
+ (setq-local require-final-newline nil)
+ (setq-local local-enable-local-variables nil)
;; Prevent loss of data when saving the file.
- (make-local-variable 'file-precious-flag)
- (setq file-precious-flag t)
+ (setq-local file-precious-flag t)
- (make-local-variable 'archive-read-only)
;; Archives which are inside other archives and whose
;; names are invalid for this OS, can't be written.
- (setq archive-read-only
- (or (not (file-writable-p (buffer-file-name)))
- (and archive-subfile-mode
- (string-match file-name-invalid-regexp
- (aref archive-subfile-mode 0)))))
-
- ;; Should we use a local copy when accessing from outside Emacs?
- (make-local-variable 'archive-local-name)
+ (setq-local archive-read-only
+ (or (not (file-writable-p (buffer-file-name)))
+ (and archive-subfile-mode
+ (string-match file-name-invalid-regexp
+ (archive--file-desc-ext-file-name
+ archive-subfile-mode)))))
;; An archive can contain another archive whose name is invalid
;; on local filesystem. Treat such archives as remote.
@@ -728,16 +710,12 @@ archive.
(string-match file-name-invalid-regexp
(buffer-file-name)))))
- (setq major-mode 'archive-mode)
+ (setq major-mode #'archive-mode)
(setq mode-name (concat typename "-Archive"))
;; Run archive-foo-mode-hook and archive-mode-hook
(run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook)
(use-local-map archive-mode-map))
- (make-local-variable 'archive-proper-file-start)
- (make-local-variable 'archive-file-list-start)
- (make-local-variable 'archive-file-list-end)
- (make-local-variable 'archive-file-name-indent)
(setq archive-file-name-coding-system
(or file-name-coding-system
default-file-name-coding-system
@@ -781,6 +759,7 @@ archive.
(re-search-forward "Rar!" (+ (point) 100000) t))
'rar-exe)
((looking-at "7z\274\257\047\034") '7z)
+ ((looking-at "hsqs") 'squashfs)
(t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
@@ -803,7 +782,7 @@ when parsing the archive."
(let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file
(inhibit-read-only t))
(setq archive-proper-file-start (copy-marker (point-min) t))
- (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize)
+ (add-hook 'change-major-mode-hook #'archive-desummarize nil t)
(or shut-up
(message "Parsing archive file..."))
(buffer-disable-undo (current-buffer))
@@ -825,27 +804,35 @@ when parsing the archive."
(goto-char archive-file-list-start)
(archive-next-line no)))
+(cl-defstruct (archive--file-summary
+ (:constructor nil)
+ (:constructor archive--file-summary (text name-start name-end)))
+ text name-start name-end)
+
(defun archive-summarize-files (files)
"Insert a description of a list of files annotated with proper mouse face."
(setq archive-file-list-start (point-marker))
- (setq archive-file-name-indent (if files (aref (car files) 1) 0))
+ ;; Here we assume that they all start at the same column.
+ (setq archive-file-name-indent
+ ;; FIXME: We assume chars=columns (no double-wide chars and such).
+ (if files (archive--file-summary-name-start (car files)) 0))
;; We don't want to do an insert for each element since that takes too
;; long when the archive -- which has to be moved in memory -- is large.
(insert
- (apply
- #'concat
- (mapcar
- (lambda (fil)
- ;; Using `concat' here copies the text also, so we can add
- ;; properties without problems.
- (let ((text (concat (aref fil 0) "\n")))
- (add-text-properties
- (aref fil 1) (aref fil 2)
- '(mouse-face highlight
- help-echo "mouse-2: extract this file into a buffer")
- text)
- text))
- files)))
+ (mapconcat
+ (lambda (fil)
+ ;; Using `concat' here copies the text also, so we can add
+ ;; properties without problems.
+ (let ((text (concat (archive--file-summary-text fil) "\n")))
+ (add-text-properties
+ (archive--file-summary-name-start fil)
+ (archive--file-summary-name-end fil)
+ '(mouse-face highlight
+ help-echo "mouse-2: extract this file into a buffer")
+ text)
+ text))
+ files
+ ""))
(setq archive-file-list-end (point-marker)))
(defun archive-alternate-display ()
@@ -854,7 +841,27 @@ To avoid very long lines archive mode does not show all information.
This function changes the set of information shown for each files."
(interactive)
(setq archive-alternate-display (not archive-alternate-display))
+ (setq-local archive-hidden-columns
+ (if archive-alternate-display
+ archive-alternate-hidden-columns
+ (eval (car (or (get 'archive-hidden-columns 'customized-value)
+ (get 'archive-hidden-columns 'standard-value)))
+ t)))
+ (archive-resummarize))
+
+(defun archive-hideshow-column (column)
+ "Toggle visibility of COLUMN."
+ (interactive
+ (list (intern
+ (completing-read "Toggle visibility of: "
+ '(Mode Ids Ratio Date&Time)
+ nil t))))
+ (setq-local archive-hidden-columns
+ (if (memq column archive-hidden-columns)
+ (remove column archive-hidden-columns)
+ (cons column archive-hidden-columns)))
(archive-resummarize))
+
;; -------------------------------------------------------------------------
;;; Section: Local archive copy handling
@@ -899,7 +906,8 @@ using `make-temp-file', and the generated name is returned."
;; "foo.zip:bar.zip", which is invalid on DOS/Windows.
;; So use the actual name if available.
(archive-name
- (or (and archive-subfile-mode (aref archive-subfile-mode 0))
+ (or (and archive-subfile-mode (archive--file-desc-ext-file-name
+ archive-subfile-mode))
archive)))
(setq archive-local-name
(archive-unique-fname archive-name archive-tmpdir))
@@ -918,6 +926,7 @@ using `make-temp-file', and the generated name is returned."
(lno (archive-get-lineno))
(inhibit-read-only t))
(if unchanged nil
+ ;; FIXME: Use archive-resummarize?
(setq archive-files nil)
(erase-buffer)
(insert-file-contents name)
@@ -968,7 +977,7 @@ using `make-temp-file', and the generated name is returned."
(delete-file tmpfile)))))
(defun archive-file-name-handler (op &rest args)
- (or (eq op 'file-exists-p)
+ (or (eq op #'file-exists-p)
(let ((file-name-handler-alist nil))
(apply op args))))
@@ -1002,14 +1011,99 @@ using `make-temp-file', and the generated name is returned."
(kill-local-variable 'buffer-file-coding-system)
(after-insert-file-set-coding (- (point-max) (point-min))))))
+(defun archive-goto-file (file)
+ "Go to FILE in the current buffer.
+FILE should be a relative file name. If FILE can't be found,
+return nil. Otherwise point is returned."
+ (let ((start (point))
+ found)
+ (goto-char (point-min))
+ (while (and (not found)
+ (not (eobp)))
+ (forward-line 1)
+ (when-let ((descr (archive-get-descr t)))
+ (when (equal (archive--file-desc-ext-file-name descr) file)
+ (setq found t))))
+ (if (not found)
+ (progn
+ (goto-char start)
+ nil)
+ (point))))
+
+(defun archive-next-file-displayer (file regexp n)
+ "Return a closure to display the next file after FILE that matches REGEXP."
+ (let ((short (replace-regexp-in-string "\\`.*:" "" file))
+ next)
+ (archive-goto-file short)
+ (while (and (not next)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (save-excursion
+ (beginning-of-line)
+ (bobp)))))
+ (archive-next-line n)
+ (when-let ((descr (archive-get-descr t)))
+ (let ((candidate (archive--file-desc-ext-file-name descr))
+ (buffer (current-buffer)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq next (lambda ()
+ (kill-buffer (current-buffer))
+ (switch-to-buffer buffer)
+ (archive-extract)))))))
+ (unless next
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (archive-goto-file short))
+ next))
+
+(defun archive-copy-file (files new-name)
+ "Copy FILES to a location specified by NEW-NAME.
+FILES can be a single file or a list of files.
+
+Interactively, FILES is the list of marked files, or the file at
+point if nothing is marked, and the function prompts for
+NEW-NAME."
+ (interactive
+ (let ((names
+ (mapcar
+ #'archive--file-desc-ext-file-name
+ (or (archive-get-marked ?*) (list (archive-get-descr))))))
+ (list names
+ (read-file-name (format "Copy %s to: " (string-join names ", "))))))
+ (unless (consp files)
+ (setq files (list files)))
+ (when (and (> (length files) 1)
+ (not (file-directory-p new-name)))
+ (user-error "Can't copy a list of files to a single file"))
+ (save-excursion
+ (dolist (file files)
+ (let ((write-to (if (file-directory-p new-name)
+ (expand-file-name file new-name)
+ new-name)))
+ (when (and (file-exists-p write-to)
+ (not (yes-or-no-p (format "%s already exists; overwrite? "
+ write-to))))
+ (user-error "Not overwriting %s" write-to))
+ (archive-goto-file file)
+ (let* ((descr (archive-get-descr))
+ (archive (buffer-file-name))
+ (extractor (archive-name "extract"))
+ (ename (archive--file-desc-ext-file-name descr)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (archive--extract-file extractor archive ename)
+ (write-region (point-min) (point-max) write-to)))))))
+
(defun archive-extract (&optional other-window-p event)
"In archive mode, extract this entry of the archive into its own buffer."
(interactive (list nil last-input-event))
(if event (posn-set-point (event-end event)))
(let* ((view-p (eq other-window-p 'view))
(descr (archive-get-descr))
- (ename (aref descr 0))
- (iname (aref descr 1))
+ (ename (archive--file-desc-ext-file-name descr))
+ (iname (archive--file-desc-int-file-name descr))
(archive-buffer (current-buffer))
(arcdir default-directory)
(archive (buffer-file-name))
@@ -1038,32 +1132,12 @@ using `make-temp-file', and the generated name is returned."
(abbreviate-file-name buffer-file-name))
;; Set the default-directory to the dir of the superior buffer.
(setq default-directory arcdir)
- (make-local-variable 'archive-superior-buffer)
- (setq archive-superior-buffer archive-buffer)
+ (setq-local archive-superior-buffer archive-buffer)
(add-hook 'write-file-functions #'archive-write-file-member nil t)
(setq archive-subfile-mode descr)
(setq archive-file-name-coding-system file-name-coding)
(if (and
- (null
- (let (;; We may have to encode the file name argument for
- ;; external programs.
- (coding-system-for-write
- (and enable-multibyte-characters
- archive-file-name-coding-system))
- ;; We read an archive member by no-conversion at
- ;; first, then decode appropriately by calling
- ;; archive-set-buffer-as-visiting-file later.
- (coding-system-for-read 'no-conversion)
- ;; Avoid changing dir mtime by lock_file
- (create-lockfiles nil))
- (condition-case err
- (if (fboundp extractor)
- (funcall extractor archive ename)
- (archive-*-extract archive ename
- (symbol-value extractor)))
- (error
- (ding (message "%s" (error-message-string err)))
- nil))))
+ (null (archive--extract-file extractor archive ename))
just-created)
(progn
(set-buffer-modified-p nil)
@@ -1096,6 +1170,27 @@ using `make-temp-file', and the generated name is returned."
(other-window-p (switch-to-buffer-other-window buffer))
(t (switch-to-buffer buffer))))))
+(defun archive--extract-file (extractor archive ename)
+ (let (;; We may have to encode the file name argument for
+ ;; external programs.
+ (coding-system-for-write
+ (and enable-multibyte-characters
+ archive-file-name-coding-system))
+ ;; We read an archive member by no-conversion at
+ ;; first, then decode appropriately by calling
+ ;; archive-set-buffer-as-visiting-file later.
+ (coding-system-for-read 'no-conversion)
+ ;; Avoid changing dir mtime by lock_file
+ (create-lockfiles nil))
+ (condition-case err
+ (if (fboundp extractor)
+ (funcall extractor archive ename)
+ (archive-*-extract archive ename
+ (symbol-value extractor)))
+ (error
+ (ding (message "%s" (error-message-string err)))
+ nil))))
+
(defun archive-*-extract (archive name command)
(let* ((default-directory (file-name-as-directory archive-tmpdir))
(tmpfile (expand-file-name (file-name-nondirectory name)
@@ -1253,7 +1348,7 @@ using `make-temp-file', and the generated name is returned."
t)
(defun archive-*-write-file-member (archive descr command)
- (let* ((ename (aref descr 0))
+ (let* ((ename (archive--file-desc-ext-file-name descr))
(tmpfile (expand-file-name ename archive-tmpdir))
(top (directory-file-name (file-name-as-directory archive-tmpdir)))
(default-directory (file-name-as-directory top)))
@@ -1270,9 +1365,10 @@ using `make-temp-file', and the generated name is returned."
;; further processing clobbers it (we restore it in
;; archive-write-file-member, above).
(setq archive-member-coding-system last-coding-system-used)
- (if (aref descr 3)
+ (if (archive--file-desc-mode descr)
;; Set the file modes, but make sure we can read it.
- (set-file-modes tmpfile (logior ?\400 (aref descr 3))))
+ (set-file-modes tmpfile
+ (logior ?\400 (archive--file-desc-mode descr))))
(setq ename
(encode-coding-string ename archive-file-name-coding-system))
(let* ((coding-system-for-write 'no-conversion)
@@ -1376,7 +1472,7 @@ Use \\[archive-unmark-all-files] to remove all marks."
"Change the protection bits associated with all marked or this member.
The new protection bits can either be specified as an octal number or
as a relative change like \"g+rw\" as for chmod(2)."
- (interactive "sNew mode (octal or relative): ")
+ (interactive "sNew mode (octal or symbolic): ")
(if archive-read-only (error "Archive is read-only"))
(let ((func (archive-name "chmod-entry")))
(if (fboundp func)
@@ -1415,7 +1511,9 @@ as a relative change like \"g+rw\" as for chmod(2)."
(goto-char archive-file-list-start)
(while (< (point) archive-file-list-end)
(if (= (following-char) ?D)
- (setq files (cons (aref (archive-get-descr) 0) files)))
+ (setq files (cons (archive--file-desc-ext-file-name
+ (archive-get-descr))
+ files)))
(forward-line 1)))
(setq files (nreverse files))
(and files
@@ -1461,12 +1559,11 @@ 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 (orig-fun &rest args)
(let ((no (archive-get-lineno)))
(setq archive-files nil)
- (let ((revert-buffer-function nil)
- (coding-system-for-read 'no-conversion))
- (revert-buffer t t))
+ (let ((coding-system-for-read 'no-conversion))
+ (apply orig-fun t t (cddr args)))
(archive-mode)
(goto-char archive-file-list-start)
(archive-next-line no)))
@@ -1477,15 +1574,135 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(interactive)
(let ((inhibit-read-only t))
(undo)))
+
+(defun archive--fit (str len)
+ (let* ((spaces (- len (string-width str)))
+ (pre (/ spaces 2)))
+ (if (< spaces 1)
+ (substring str 0 len)
+ (concat (make-string pre ?\s) str (make-string (- spaces pre) ?\s)))))
+
+(defun archive--fit2 (str1 str2 len)
+ (let* ((spaces (- len (string-width str1) (string-width str2))))
+ (if (< spaces 1)
+ (substring (concat str1 str2) 0 len)
+ (concat str1 (make-string spaces ?\s) str2))))
+
+(defun archive--enabled-p (column)
+ (not (memq column archive-hidden-columns)))
+
+(defun archive--summarize-descs (descs)
+ (goto-char (point-min))
+ (if (null descs)
+ (progn (insert "M ... Filename\n")
+ (insert "- ----- ---------------\n")
+ (archive-summarize-files nil)
+ (insert "- ----- ---------------\n"))
+ (let* ((sample (car descs))
+ (maxsize 0)
+ (maxidlen 0)
+ (totalsize 0)
+ (times (archive--enabled-p 'Date&Time))
+ (ids (and (archive--enabled-p 'Ids)
+ (or (archive--file-desc-uid sample)
+ (archive--file-desc-gid sample))))
+ ;; For ratio, date/time, and mode, we presume that
+ ;; they're either present on all entries or on nonel, and that they
+ ;; take the same space on each of them.
+ (ratios (and (archive--enabled-p 'Ratio)
+ (archive--file-desc-ratio sample)))
+ (ratiolen (if ratios (string-width ratios)))
+ (timelen (length (archive--file-desc-time sample)))
+ (samplemode (and (archive--enabled-p 'Mode)
+ (archive--file-desc-mode sample)))
+ (modelen (length (if samplemode (file-modes-number-to-symbolic samplemode)))))
+ (dolist (desc descs)
+ (when ids
+ (let* ((uid (archive--file-desc-uid desc))
+ (gid (archive--file-desc-uid desc))
+ (len (cond
+ ((not uid) (string-width gid))
+ ((not gid) (string-width uid))
+ (t (+ (string-width uid) (string-width gid) 1)))))
+ (if (> len maxidlen) (setq maxidlen len))))
+ (let ((size (archive--file-desc-size desc)))
+ (cl-incf totalsize size)
+ (if (> size maxsize) (setq maxsize size))))
+ (let* ((sizelen (length (number-to-string maxsize)))
+ (dash
+ (concat
+ "- "
+ (if (> modelen 0) (concat (make-string modelen ?-) " "))
+ (if ids (concat (make-string maxidlen ?-) " "))
+ (make-string sizelen ?-) " "
+ (if ratios (concat (make-string (1+ ratiolen) ?-) " "))
+ " "
+ (if times (concat (make-string timelen ?-) " "))
+ "----------------\n"))
+ (startcol (+ 2
+ (if (> modelen 0) (+ 2 modelen) 0)
+ (if ids (+ maxidlen 2) 0)
+ sizelen 2
+ (if ratios (+ 2 ratiolen) 0)
+ (if times (+ timelen 2) 0))))
+ (insert
+ (concat "M "
+ (if (> modelen 0) (concat (archive--fit "Mode" modelen) " "))
+ (if ids (concat (archive--fit2 "Uid" "Gid" maxidlen) " "))
+ (archive--fit "Size" sizelen) " "
+ (if ratios (concat (archive--fit "Cmp" (1+ ratiolen)) " "))
+ " "
+ (if times (concat (archive--fit "Date&time" timelen) " "))
+ " Filename\n"))
+ (insert dash)
+ (archive-summarize-files
+ (mapcar (lambda (desc)
+ (let* ((size (number-to-string
+ (archive--file-desc-size desc)))
+ (text
+ (concat " "
+ (when (> modelen 0)
+ (concat (file-modes-number-to-symbolic
+ (archive--file-desc-mode desc))
+ " "))
+ (when ids
+ (concat (archive--fit2
+ (archive--file-desc-uid desc)
+ (archive--file-desc-gid desc)
+ maxidlen) " "))
+ (make-string (- sizelen (length size)) ?\s)
+ size
+ " "
+ (when ratios
+ (concat (archive--file-desc-ratio desc)
+ "% "))
+ " "
+ (when times
+ (concat (archive--file-desc-time desc)
+ " "))
+ (archive--file-desc-int-file-name desc))))
+ (archive--file-summary
+ text startcol (length text))))
+ descs))
+ (insert dash)
+ (insert (format (format "%%%dd %%s %%d files\n"
+ (+ 2
+ (if (> modelen 0) (+ 2 modelen) 0)
+ (if ids (+ maxidlen 2) 0)
+ sizelen))
+ totalsize
+ (make-string (+ (if times (+ 2 timelen) 0)
+ (if ratios (+ 2 ratiolen) 0) 1)
+ ?\s)
+ (length descs))))))
+ (apply #'vector descs))
+
;; -------------------------------------------------------------------------
;;; Section: Arc Archives
(defun archive-arc-summarize ()
(let ((p 1)
- (totalsize 0)
- (maxlen 8)
- files
- visual)
+ files)
(while (and (< (+ p 29) (point-max))
(= (get-byte p) ?\C-z)
(> (get-byte (1+ p)) 0))
@@ -1498,48 +1715,28 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(modtime (archive-l-e (+ p 21) 2))
(ucsize (archive-l-e (+ p 25) 4))
(fiddle (string= efnname (upcase efnname)))
- (ifnname (if fiddle (downcase efnname) efnname))
- (text (format " %8d %-11s %-8s %s"
- ucsize
- (archive-dosdate moddate)
- (archive-dostime modtime)
- ifnname)))
- (setq maxlen (max maxlen fnlen)
- totalsize (+ totalsize ucsize)
- visual (cons (vector text
- (- (length text) (length ifnname))
- (length text))
- visual)
- files (cons (vector efnname ifnname fiddle nil (1- p))
+ (ifnname (if fiddle (downcase efnname) efnname)))
+ (setq files (cons (archive--file-desc
+ efnname ifnname nil ucsize
+ (concat (archive-dosdate moddate)
+ " " (archive-dostime modtime))
+ :pos (1- p))
files)
p (+ p 29 csize))))
- (goto-char (point-min))
- (let ((dash (concat "- -------- ----------- -------- "
- (make-string maxlen ?-)
- "\n")))
- (insert "M Length Date Time File\n"
- dash)
- (archive-summarize-files (nreverse visual))
- (insert dash
- (format " %8d %d file%s"
- totalsize
- (length files)
- (if (= 1 (length files)) "" "s"))
- "\n"))
- (apply #'vector (nreverse files))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-arc-rename-entry (newname descr)
(if (string-match "[:\\/]" newname)
(error "File names in arc files must not contain a directory component"))
(if (> (length newname) 12)
(error "File names in arc files are limited to 12 characters"))
- (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0"
- (length newname))))
+ (let ((name (concat newname (make-string (- 13 (length newname)) ?\0)))
(inhibit-read-only t))
(save-restriction
(save-excursion
(widen)
- (goto-char (+ archive-proper-file-start (aref descr 4) 2))
+ (goto-char (+ archive-proper-file-start 2
+ (archive--file-desc-pos descr)))
(delete-char 13)
(arc-insert-unibyte name)))))
;; -------------------------------------------------------------------------
@@ -1547,10 +1744,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(defun archive-lzh-summarize (&optional start)
(let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe
- (totalsize 0)
- (maxlen 8)
- files
- visual)
+ files)
(while (progn (goto-char p) ;beginning of a base header.
(looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-"))
(let* ((hsize (get-byte p)) ;size of the base header (level 0 and 1)
@@ -1561,9 +1755,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.)
(hdrlvl (get-byte (+ p 20))) ;header level
thsize ;total header size (base + extensions)
- fnlen efnname osid fiddle ifnname width p2
+ fnlen efnname osid fiddle ifnname p2
neh ;beginning of next extension header (level 1 and 2)
- mode modestr uid gid text dir prname
+ mode uid gid dir prname
gname uname modtime moddate)
(if (= hdrlvl 3) (error "can't handle lzh level 3 header type"))
(when (or (= hdrlvl 0) (= hdrlvl 1))
@@ -1576,26 +1770,26 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(setq neh (+ p2 3)) ;specific to level 1 header
(if (= hdrlvl 2)
(setq neh (+ p 24)))) ;specific to level 2 header
- (if neh ;if level 1 or 2 we expect extension headers to follow
+ (if neh ;if level 1 or 2 we expect extension headers to follow
(let* ((ehsize (archive-l-e neh 2)) ;size of the extension header
(etype (get-byte (+ neh 2)))) ;extension type
(while (not (= ehsize 0))
- (cond
- ((= etype 1) ;file name
+ (cond
+ ((= etype 1) ;file name
(let ((i (+ neh 3)))
(while (< i (+ neh ehsize))
(setq efnname (concat efnname (char-to-string (get-byte i))))
(setq i (1+ i)))))
- ((= etype 2) ;directory name
+ ((= etype 2) ;directory name
(let ((i (+ neh 3)))
(while (< i (+ neh ehsize))
- (setq dir (concat dir
- (if (= (get-byte i)
- 255)
- "/"
- (char-to-string
- (char-after i)))))
- (setq i (1+ i)))))
+ (setq dir (concat dir
+ (if (= (get-byte i)
+ 255)
+ "/"
+ (char-to-string
+ (char-after i)))))
+ (setq i (1+ i)))))
((= etype 80) ;Unix file permission
(setq mode (archive-l-e (+ neh 3) 2)))
((= etype 81) ;UNIX file group/user ID
@@ -1611,7 +1805,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(while (< i (+ neh ehsize))
(setq uname (concat uname (char-to-string (char-after i))))
(setq i (1+ i)))))
- )
+ )
(setq neh (+ neh ehsize))
(setq ehsize (archive-l-e neh 2))
(setq etype (get-byte (+ neh 2))))
@@ -1637,60 +1831,25 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
((= 0 osid) (string= efnname (upcase efnname)))))
(setq ifnname (if fiddle (downcase efnname) efnname))
(setq prname (if dir (concat dir ifnname) ifnname))
- (setq width (if prname (string-width prname) 0))
- (setq modestr (if mode (archive-int-to-mode mode) "??????????"))
(setq moddate (if (= hdrlvl 2)
(archive-unixdate time1 time2) ;level 2 header in UNIX format
(archive-dosdate time2))) ;level 0 and 1 header in DOS format
(setq modtime (if (= hdrlvl 2)
(archive-unixtime time1 time2)
(archive-dostime time1)))
- (setq text (if archive-alternate-display
- (format " %8d %5S %5S %s"
- ucsize
- (or uid "?")
- (or gid "?")
- ifnname)
- (format " %10s %8d %-11s %-8s %s"
- modestr
- ucsize
- moddate
- modtime
- prname)))
- (setq maxlen (max maxlen width)
- totalsize (+ totalsize ucsize)
- visual (cons (vector text
- (- (length text) (length prname))
- (length text))
- visual)
- files (cons (vector prname ifnname fiddle mode (1- p))
- files))
+ (push (archive--file-desc
+ prname ifnname mode ucsize
+ (concat moddate " " modtime)
+ :pos (1- p)
+ :uid (or uname (if uid (number-to-string uid)))
+ :gid (or gname (if gid (number-to-string gid))))
+ files)
(cond ((= hdrlvl 1)
(setq p (+ p hsize 2 csize)))
((or (= hdrlvl 2) (= hdrlvl 0))
(setq p (+ p thsize 2 csize))))
))
- (goto-char (point-min))
- (let ((dash (concat (if archive-alternate-display
- "- -------- ----- ----- "
- "- ---------- -------- ----------- -------- ")
- (make-string maxlen ?-)
- "\n"))
- (header (if archive-alternate-display
- "M Length Uid Gid File\n"
- "M Filemode Length Date Time File\n"))
- (sumline (if archive-alternate-display
- " %8.0f %d file%s"
- " %8.0f %d file%s")))
- (insert header dash)
- (archive-summarize-files (nreverse visual))
- (insert dash
- (format sumline
- totalsize
- (length files)
- (if (= 1 (length files)) "" "s"))
- "\n"))
- (apply #'vector (nreverse files))))
+ (archive--summarize-descs (nreverse files))))
(defconst archive-lzh-alternate-display t)
@@ -1709,7 +1868,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(save-restriction
(save-excursion
(widen)
- (let* ((p (+ archive-proper-file-start (aref descr 4)))
+ (let* ((p (+ archive-proper-file-start
+ (archive--file-desc-pos descr)))
(oldhsize (get-byte p))
(oldfnlen (get-byte (+ p 21)))
(newfnlen (length newname))
@@ -1729,7 +1889,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(save-restriction
(widen)
(dolist (fil files)
- (let* ((p (+ archive-proper-file-start (aref fil 4)))
+ (let* ((p (+ archive-proper-file-start (archive--file-desc-pos fil)))
(hsize (get-byte p))
(fnlen (get-byte (+ p 21)))
(p2 (+ p 22 fnlen))
@@ -1746,7 +1906,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(delete-char 1)
(arc-insert-unibyte (archive-lzh-resum (1+ p) hsize)))
(message "Member %s does not have %s field"
- (aref fil 1) errtxt)))))))
+ (archive--file-desc-int-file-name fil) errtxt)))))))
(defun archive-lzh-chown-entry (newuid files)
(archive-lzh-ogm newuid files "an uid" 10))
@@ -1756,8 +1916,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(defun archive-lzh-chmod-entry (newmode files)
(archive-lzh-ogm
- ;; This should work even though newmode will be dynamically accessed.
- (lambda (old) (archive-calc-mode old newmode t))
+ (lambda (old) (archive-calc-mode old newmode))
files "a unix-style mode" 8))
;; -------------------------------------------------------------------------
@@ -1794,11 +1953,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(goto-char (- (point-max) (- 22 18)))
(search-backward-regexp "[P]K\005\006")
(let ((p (archive-l-e (+ (point) 16) 4))
- (maxlen 8)
- (totalsize 0)
- files
- visual
- emacs-int-has-32bits)
+ files)
(when (or (= p #xffffffff) (= p -1))
;; If the offset of end-of-central-directory is 0xFFFFFFFF, this
;; is a Zip64 extended ZIP file format, and we need to glean the
@@ -1824,7 +1979,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(fnlen (archive-l-e (+ p 28) 2))
(exlen (archive-l-e (+ p 30) 2))
(fclen (archive-l-e (+ p 32) 2))
- (lheader (archive-l-e (+ p 42) 4))
+ ;; (lheader (archive-l-e (+ p 42) 4))
(efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen))))
(decode-coding-string
str archive-file-name-coding-system)))
@@ -1848,44 +2003,18 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(logand 1 (get-byte (+ p 38))))
?\222 0)))
(t nil)))
- (modestr (if mode (archive-int-to-mode mode) "??????????"))
(fiddle (and archive-zip-case-fiddle
- (not (not (memq creator '(0 2 4 5 9))))
+ (memq creator '(0 2 4 5 9))
(string= (upcase efnname) efnname)))
- (ifnname (if fiddle (downcase efnname) efnname))
- (width (string-width ifnname))
- (text (format " %10s %8d %-11s %-8s %s"
- modestr
- ucsize
- (archive-dosdate moddate)
- (archive-dostime modtime)
- ifnname)))
- (setq maxlen (max maxlen width)
- totalsize (+ totalsize ucsize)
- visual (cons (vector text
- (- (length text) (length ifnname))
- (length text))
- visual)
- files (cons (if isdir
- nil
- (vector efnname ifnname fiddle mode
- (list (1- p) lheader)))
- files)
+ (ifnname (if fiddle (downcase efnname) efnname)))
+ (setq files (cons (archive--file-desc
+ efnname ifnname mode ucsize
+ (concat (archive-dosdate moddate)
+ " " (archive-dostime modtime))
+ :pos (1- p))
+ files)
p (+ p 46 fnlen exlen fclen))))
- (goto-char (point-min))
- (let ((dash (concat "- ---------- -------- ----------- -------- "
- (make-string maxlen ?-)
- "\n")))
- (insert "M Filemode Length Date Time File\n"
- dash)
- (archive-summarize-files (nreverse visual))
- (insert dash
- (format " %8d %d file%s"
- totalsize
- (length files)
- (if (= 1 (length files)) "" "s"))
- "\n"))
- (apply #'vector (nreverse files))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-zip-extract (archive name)
(cond
@@ -1910,21 +2039,27 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
name)
archive-zip-extract))))
+(defun archive--file-desc-case-fiddled (fd)
+ (not (eq (archive--file-desc-int-file-name fd)
+ (archive--file-desc-ext-file-name fd))))
+
(defun archive-zip-write-file-member (archive descr)
(archive-*-write-file-member
archive
descr
- (if (aref descr 2) archive-zip-update-case archive-zip-update)))
+ (if (archive--file-desc-case-fiddled descr)
+ archive-zip-update-case archive-zip-update)))
(defun archive-zip-chmod-entry (newmode files)
(save-restriction
(save-excursion
(widen)
(dolist (fil files)
- (let* ((p (+ archive-proper-file-start (car (aref fil 4))))
+ (let* ((p (+ archive-proper-file-start
+ (archive--file-desc-pos fil)))
(creator (get-byte (+ p 5)))
- (oldmode (aref fil 3))
- (newval (archive-calc-mode oldmode newmode t))
+ (oldmode (archive--file-desc-mode fil))
+ (newval (archive-calc-mode oldmode newmode))
(inhibit-read-only t))
(cond ((memq creator '(2 3)) ; Unix
(goto-char (+ p 40))
@@ -1943,10 +2078,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(defun archive-zoo-summarize ()
(let ((p (1+ (archive-l-e 25 4)))
- (maxlen 8)
- (totalsize 0)
- files
- visual)
+ files)
(while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4)))
(> (archive-l-e (+ p 6) 4) 0))
(let* ((next (1+ (archive-l-e (+ p 6) 4)))
@@ -1973,36 +2105,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(decode-coding-string
str archive-file-name-coding-system)))
(fiddle (and (= lfnlen 0) (string= efnname (upcase efnname))))
- (ifnname (if fiddle (downcase efnname) efnname))
- (width (string-width ifnname))
- (text (format " %8d %-11s %-8s %s"
- ucsize
- (archive-dosdate moddate)
- (archive-dostime modtime)
- ifnname)))
- (setq maxlen (max maxlen width)
- totalsize (+ totalsize ucsize)
- visual (cons (vector text
- (- (length text) (length ifnname))
- (length text))
- visual)
- files (cons (vector efnname ifnname fiddle nil (1- p))
+ (ifnname (if fiddle (downcase efnname) efnname)))
+ (setq files (cons (archive--file-desc
+ efnname ifnname nil ucsize
+ (concat (archive-dosdate moddate)
+ " " (archive-dostime modtime)))
files)
p next)))
- (goto-char (point-min))
- (let ((dash (concat "- -------- ----------- -------- "
- (make-string maxlen ?-)
- "\n")))
- (insert "M Length Date Time File\n"
- dash)
- (archive-summarize-files (nreverse visual))
- (insert dash
- (format " %8d %d file%s"
- totalsize
- (length files)
- (if (= 1 (length files)) "" "s"))
- "\n"))
- (apply #'vector (nreverse files))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-zoo-extract (archive name)
(archive-extract-by-stdout archive name archive-zoo-extract))
@@ -2014,17 +2124,16 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;; File is used internally for `archive-rar-exe-summarize'.
(unless file (setq file buffer-file-name))
(let* ((copy (file-local-copy file))
- (maxname 10)
- (maxsize 5)
(files ()))
(with-temp-buffer
- (call-process "lsar" nil t nil "-l" (or file copy))
- (if copy (delete-file copy))
+ (unwind-protect
+ (call-process "lsar" nil t nil "-l" (or file copy))
+ (if copy (delete-file copy)))
(goto-char (point-min))
- (re-search-forward "^\\(\s+=+\s*\\)+\n")
+ (re-search-forward "^\\(?:\s+=+\\)+\s*\n")
(while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags
"\\([0-9-]+\\)\s+" ; Size
- "\\([-0-9.%]+\\)\s+" ; Ratio
+ "\\([-0-9.]+\\)%?\s+" ; Ratio
"\\([0-9a-zA-Z]+\\)\s+" ; Mode
"\\([0-9-]+\\)\s+" ; Date
"\\([0-9:]+\\)\s+" ; Time
@@ -2033,36 +2142,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(goto-char (match-end 0))
(let ((name (match-string 6))
(size (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
- ;; Size, Ratio.
- size (match-string 2)
- ;; Date, Time.
- (match-string 4) (match-string 5))
+ (push (archive--file-desc name name nil
+ ;; Size
+ (string-to-number size)
+ ;; Date&Time.
+ (concat (match-string 4) " " (match-string 5))
+ :ratio (match-string 2))
files))))
- (setq files (nreverse files))
- (goto-char (point-min))
- (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize))
- (sep (format format "----------" "-----" (make-string maxsize ?-)
- "-----" ""))
- (column (length sep)))
- (insert (format format " Date " "Time " "Size" "Ratio" "Filename") "\n")
- (insert sep (make-string maxname ?-) "\n")
- (archive-summarize-files (mapcar (lambda (desc)
- (let ((text
- (format format
- (aref desc 6)
- (aref desc 7)
- (aref desc 4)
- (aref desc 5)
- (aref desc 1))))
- (vector text
- column
- (length text))))
- files))
- (insert sep (make-string maxname ?-) "\n")
- (apply #'vector files))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-rar-extract (archive name)
;; unrar-free seems to have no way to extract to stdout or even to a file.
@@ -2109,9 +2196,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;;; Section: 7z Archives
(defun archive-7z-summarize ()
- (let ((maxname 10)
- (maxsize 5)
- (file buffer-file-name)
+ (let ((file buffer-file-name)
(files ()))
(with-temp-buffer
(call-process archive-7z-program nil t nil "l" "-slt" file)
@@ -2128,29 +2213,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(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)
+ (push (archive--file-desc name name nil (string-to-number size) time)
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))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-7z-extract (archive name)
;; 7z doesn't provide a `quiet' option to suppress non-essential
@@ -2172,84 +2237,46 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;; not the GNU nor the BSD extensions. As it turns out, this is sufficient
;; for .deb packages.
-(autoload 'tar-grind-file-mode "tar-mode")
-
(defconst archive-ar-file-header-re
"\\(.\\{16\\}\\)\\([ 0-9]\\{12\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-7]\\{8\\}\\)\\([ 0-9]\\{10\\}\\)`\n")
+(defun archive-ar--name (name)
+ "Return the external name represented by the entry NAME.
+NAME is expected to be the 16-bytes part of an ar record."
+ (cond ((equal name "// ")
+ (propertize ".<ExtNamesTable>." 'face 'italic))
+ ((equal name "/ ")
+ (propertize ".<LookupTable>." 'face 'italic))
+ ((string-match "/? *\\'" name)
+ ;; FIXME: Decode? Add support for longer names?
+ (substring name 0 (match-beginning 0)))))
+
(defun archive-ar-summarize ()
;; File is used internally for `archive-rar-exe-summarize'.
- (let* ((maxname 10)
- (maxtime 16)
- (maxuser 5)
- (maxgroup 5)
- (maxmode 8)
- (maxsize 5)
- (files ()))
+ (let* ((files ()))
(goto-char (point-min))
(search-forward "!<arch>\n")
(while (looking-at archive-ar-file-header-re)
- (let ((name (match-string 1))
- extname
- (time (string-to-number (match-string 2)))
- (user (match-string 3))
- (group (match-string 4))
- (mode (string-to-number (match-string 5) 8))
- (size (string-to-number (match-string 6))))
+ (let* ((name (match-string 1))
+ extname
+ (time (string-to-number (match-string 2)))
+ (user (match-string 3))
+ (group (match-string 4))
+ (mode (string-to-number (match-string 5) 8))
+ (sizestr (match-string 6))
+ (size (string-to-number sizestr)))
;; Move to the beginning of the data.
(goto-char (match-end 0))
(setq time (format-time-string "%Y-%m-%d %H:%M" time))
- (setq extname
- (cond ((equal name "// ")
- (propertize ".<ExtNamesTable>." 'face 'italic))
- ((equal name "/ ")
- (propertize ".<LookupTable>." 'face 'italic))
- ((string-match "/? *\\'" name)
- (substring name 0 (match-beginning 0)))))
+ (setq extname (archive-ar--name name))
(setq user (substring user 0 (string-match " +\\'" user)))
(setq group (substring group 0 (string-match " +\\'" group)))
- (setq mode (tar-grind-file-mode mode))
;; Move to the end of the data.
(forward-char size) (if (eq ?\n (char-after)) (forward-char 1))
- (setq size (number-to-string size))
- (if (> (length name) maxname) (setq maxname (length name)))
- (if (> (length time) maxtime) (setq maxtime (length time)))
- (if (> (length user) maxuser) (setq maxuser (length user)))
- (if (> (length group) maxgroup) (setq maxgroup (length group)))
- (if (> (length mode) maxmode) (setq maxmode (length mode)))
- (if (> (length size) maxsize) (setq maxsize (length size)))
- (push (vector name extname nil mode
- time user group size)
+ (push (archive--file-desc extname extname mode size time
+ :uid user :gid group)
files)))
- (setq files (nreverse files))
- (goto-char (point-min))
- (let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s"
- maxmode maxuser maxgroup maxsize maxtime))
- (sep (format format (make-string maxmode ?-)
- (make-string maxuser ?-)
- (make-string maxgroup ?-)
- (make-string maxsize ?-)
- (make-string maxtime ?-) ""))
- (column (length sep)))
- (insert (format format " Mode " "User" "Group" " Size "
- " Date " "Filename")
- "\n")
- (insert sep (make-string maxname ?-) "\n")
- (archive-summarize-files (mapcar (lambda (desc)
- (let ((text
- (format format
- (aref desc 3)
- (aref desc 5)
- (aref desc 6)
- (aref desc 7)
- (aref desc 4)
- (aref desc 1))))
- (vector text
- column
- (length text))))
- files))
- (insert sep (make-string maxname ?-) "\n")
- (apply #'vector files))))
+ (archive--summarize-descs (nreverse files))))
(defun archive-ar-extract (archive name)
(let ((destbuf (current-buffer))
@@ -2266,10 +2293,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(let ((this (match-string 1)))
(setq size (string-to-number (match-string 6)))
(goto-char (match-end 0))
- (if (equal name this)
+ (if (equal name (archive-ar--name this))
(setq from (point))
;; Move to the end of the data.
- (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)))))
+ (forward-char size)
+ (if (eq ?\n (char-after)) (forward-char 1)))))
(when from
(set-buffer-multibyte nil)
(with-current-buffer destbuf
@@ -2279,6 +2307,92 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
;; Inform the caller that the call succeeded.
t))))))
+(defun archive-ar-write-file-member (archive descr)
+ (archive-*-write-file-member
+ archive
+ descr
+ '("ar" "r")))
+
+;; -------------------------------------------------------------------------
+;;; Section Squashfs archives.
+
+(defun archive-squashfs-summarize (&optional file)
+ (unless file
+ (setq file buffer-file-name))
+ (let ((copy (file-local-copy file))
+ (files ()))
+ (with-temp-buffer
+ (call-process "unsquashfs" nil t nil "-ll" (or file copy))
+ (when copy
+ (delete-file copy))
+ (goto-char (point-min))
+ (search-forward-regexp "[drwxl\\-]\\{10\\}")
+ (beginning-of-line)
+ (while (looking-at (concat
+ "^\\(.[rwx\\-]\\{9\\}\\) " ;Mode
+ "\\(.+\\)/\\(.+\\) " ;user/group
+ "\\(.+\\) " ;size
+ "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\) " ;date
+ "\\([0-9]\\{2\\}:[0-9]\\{2\\}\\) " ;time
+ "\\(.+\\)\n")) ;Filename
+ (let* ((name (match-string 7))
+ (flags (match-string 1))
+ (uid (match-string 2))
+ (gid (match-string 3))
+ (size (string-to-number (match-string 4)))
+ (date (match-string 5))
+ (time (match-string 6))
+ (date-time)
+ (mode))
+ ;; Only list directory and regular files
+ (when (or (eq (aref flags 0) ?d)
+ (eq (aref flags 0) ?-))
+ (when (equal name "squashfs-root")
+ (setf name "/"))
+ ;; Remove 'squashfs-root/' from filenames.
+ (setq name (string-replace "squashfs-root/" "" name))
+ (setq date-time (concat date " " time))
+ (setq mode (logior
+ (cond
+ ((eq (aref flags 0) ?d) #o40000)
+ (t 0))
+ ;; Convert symbolic to octal representation.
+ (file-modes-symbolic-to-number
+ (concat
+ "u=" (string-replace "-" "" (substring flags 1 4))
+ ",g=" (string-replace "-" "" (substring flags 4 7))
+ ",o=" (string-replace "-" ""
+ (substring flags 7 10))))))
+ (push (archive--file-desc name name mode size
+ date-time :uid uid :gid gid)
+ files)))
+ (goto-char (match-end 0))))
+ (archive--summarize-descs (nreverse files))))
+
+(defun archive-squashfs-extract-by-stdout (archive name command
+ &optional stderr-test)
+ (let ((stderr-file (make-temp-file "arc-stderr")))
+ (unwind-protect
+ (prog1
+ (apply #'call-process
+ (car command)
+ nil
+ (if stderr-file (list t stderr-file) t)
+ nil
+ (append (cdr command) (list name archive)))
+ (with-temp-buffer
+ (insert-file-contents stderr-file)
+ (goto-char (point-min))
+ (when (if (stringp stderr-test)
+ (not (re-search-forward stderr-test nil t))
+ (> (buffer-size) 0))
+ (message "%s" (buffer-string)))))
+ (if (file-exists-p stderr-file)
+ (delete-file stderr-file)))))
+
+(defun archive-squashfs-extract (archive name)
+ (archive-squashfs-extract-by-stdout archive name archive-squashfs-extract))
+
;; -------------------------------------------------------------------------
;; This line was a mistake; it is kept now for compatibility.
;; rms 15 Oct 98
diff --git a/lisp/array.el b/lisp/array.el
index e147cee1d59..6632da55dd4 100644
--- a/lisp/array.el
+++ b/lisp/array.el
@@ -1,4 +1,4 @@
-;;; array.el --- array editing commands for GNU Emacs
+;;; array.el --- array editing commands for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1987, 2000-2021 Free Software Foundation, Inc.
@@ -769,25 +769,25 @@ Return COLUMN."
(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)
+ (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.")
@@ -815,16 +815,18 @@ in array mode may have different values assigned to the variables.
The variables are:
Variables you assign:
- array-max-row: The number of rows in the array.
- array-max-column: The number of columns in the array.
- array-columns-per-line: The number of columns in the array per line of buffer.
- array-field-width: The width of each field, in characters.
- array-rows-numbered: A logical variable describing whether to ignore
- row numbers in the buffer.
+ `array-max-row': The number of rows in the array.
+ `array-max-column': The number of columns in the array.
+ `array-columns-per-line': The number of columns in the array
+ per line of buffer.
+ `array-field-width': The width of each field, in characters.
+ `array-rows-numbered': A logical variable describing whether to ignore
+ row numbers in the buffer.
Variables which are calculated:
- array-line-length: The number of characters in a buffer line.
- array-lines-per-row: The number of buffer lines used to display each row.
+ `array-line-length': The number of characters in a buffer line.
+ `array-lines-per-row': The number of buffer lines used to
+ display each row.
The following commands are available (an asterisk indicates it may
take a numeric prefix argument):
@@ -834,17 +836,17 @@ take a numeric prefix argument):
* \\[array-next-row] Move down one row.
* \\[array-previous-row] Move up one row.
- * \\[array-copy-forward] Copy the current field into the column to the right.
- * \\[array-copy-backward] Copy the current field into the column to the left.
- * \\[array-copy-down] Copy the current field into the row below.
- * \\[array-copy-up] Copy the current field into the row above.
+ * \\[array-copy-forward] Copy current field into the column to the right.
+ * \\[array-copy-backward] Copy current field into the column to the left.
+ * \\[array-copy-down] Copy current field into the row below.
+ * \\[array-copy-up] Copy current field into the row above.
- * \\[array-copy-column-forward] Copy the current column into the column to the right.
- * \\[array-copy-column-backward] Copy the current column into the column to the left.
+ * \\[array-copy-column-forward] Copy current column into the column to the right.
+ * \\[array-copy-column-backward] Copy current column into the column to the left.
* \\[array-copy-row-down] Copy the current row into the row below.
* \\[array-copy-row-up] Copy the current row into the row above.
- \\[array-fill-rectangle] Copy the field at mark into every cell with row and column
+ \\[array-fill-rectangle] Copy field at mark into every cell with row and column
between that of point and mark.
\\[array-what-position] Display the current array row and column.
@@ -855,7 +857,7 @@ take a numeric prefix argument):
\\[array-expand-rows] Expand the array (remove row numbers and
newlines inside rows)
- \\[array-display-local-variables] Display the current values of local variables.
+ \\[array-display-local-variables] Display current values of local variables.
Entering array mode calls the function `array-mode-hook'."
(make-local-variable 'array-buffer-line)
@@ -863,25 +865,25 @@ Entering array mode calls the function `array-mode-hook'."
(make-local-variable 'array-row)
(make-local-variable 'array-column)
(make-local-variable 'array-copy-string)
- (set (make-local-variable 'array-respect-tabs) nil)
- (set (make-local-variable 'array-max-row)
- (read-number "Number of array rows: "))
- (set (make-local-variable 'array-max-column)
- (read-number "Number of array columns: "))
- (set (make-local-variable 'array-columns-per-line)
- (read-number "Array columns per line: "))
- (set (make-local-variable 'array-field-width)
- (read-number "Field width: "))
- (set (make-local-variable 'array-rows-numbered)
- (y-or-n-p "Rows numbered? "))
- (set (make-local-variable 'array-line-length)
- (* array-field-width array-columns-per-line))
- (set (make-local-variable 'array-lines-per-row)
- (+ (floor (1- array-max-column) array-columns-per-line)
- (if array-rows-numbered 2 1)))
+ (setq-local array-respect-tabs nil)
+ (setq-local array-max-row
+ (read-number "Number of array rows: "))
+ (setq-local array-max-column
+ (read-number "Number of array columns: "))
+ (setq-local array-columns-per-line
+ (read-number "Array columns per line: "))
+ (setq-local array-field-width
+ (read-number "Field width: "))
+ (setq-local array-rows-numbered
+ (y-or-n-p "Rows numbered? "))
+ (setq-local array-line-length
+ (* array-field-width array-columns-per-line))
+ (setq-local array-lines-per-row
+ (+ (floor (1- array-max-column) array-columns-per-line)
+ (if array-rows-numbered 2 1)))
(message "")
(force-mode-line-update)
- (set (make-local-variable 'truncate-lines) t)
+ (setq-local truncate-lines t)
(setq overwrite-mode 'overwrite-mode-textual))
diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el
index 39db1a710bd..914f8d2f1bf 100644
--- a/lisp/auth-source-pass.el
+++ b/lisp/auth-source-pass.el
@@ -6,8 +6,6 @@
;; Nicolas Petton <nicolas@petton.fr>
;; Keith Amidon <camalot@picnicpark.org>
;; Version: 5.0.0
-;; Package-Requires: ((emacs "25"))
-;; Url: https://github.com/DamienCassou/auth-password-store
;; Created: 07 Jun 2015
;; This file is part of GNU Emacs.
@@ -27,16 +25,18 @@
;;; Commentary:
-;; Integrates password-store (http://passwordstore.org/) within
+;; Integrates password-store (https://passwordstore.org/) within
;; auth-source.
;;; Code:
(require 'seq)
-(eval-when-compile (require 'subr-x))
(require 'cl-lib)
(require 'auth-source)
(require 'url-parse)
+;; Use `eval-when-compile' after the other `require's to avoid spurious
+;; "might not be defined at runtime" warnings.
+(eval-when-compile (require 'subr-x))
(defgroup auth-source-pass nil
"password-store integration within auth-source."
@@ -58,14 +58,12 @@
(cl-defun auth-source-pass-search (&rest spec
&key backend type 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."
+ "Given some search query, return matching credentials.
+
+See `auth-source-search' for details on the parameters SPEC, BACKEND, TYPE,
+HOST, USER and PORT."
(cl-assert (or (null type) (eq type (oref backend type)))
t "Invalid password-store search: %s %s")
- (when (consp host)
- (warn "auth-source-pass ignores all but first host in spec.")
- ;; Take the first non-nil item of the list of hosts
- (setq host (seq-find #'identity host)))
(cond ((eq host t)
(warn "auth-source-pass does not handle host wildcards.")
nil)
@@ -76,12 +74,14 @@ See `auth-source-search' for details on SPEC."
(when-let ((result (auth-source-pass--build-result host port user)))
(list result)))))
-(defun auth-source-pass--build-result (host port user)
- "Build auth-source-pass entry matching HOST, PORT and USER."
- (let ((entry-data (auth-source-pass--find-match host user port)))
+(defun auth-source-pass--build-result (hosts port user)
+ "Build auth-source-pass entry matching HOSTS, PORT and USER.
+
+HOSTS can be a string or a list of strings."
+ (let ((entry-data (auth-source-pass--find-match hosts user port)))
(when entry-data
(let ((retval (list
- :host host
+ :host (auth-source-pass--get-attr "host" entry-data)
:port (or (auth-source-pass--get-attr "port" entry-data) port)
:user (or (auth-source-pass--get-attr "user" entry-data) user)
:secret (lambda () (auth-source-pass--get-attr 'secret entry-data)))))
@@ -123,7 +123,7 @@ ENTRY is the name of a password-store entry.
The key used to retrieve the password is the symbol `secret'.
The convention used as the format for a password-store file is
-the following (see http://www.passwordstore.org/#organization):
+the following (see URL `https://www.passwordstore.org/#organization'):
secret
key1: value1
@@ -167,15 +167,13 @@ The secret is the first line of CONTENTS."
(defun auth-source-pass--parse-data (contents)
"Parse the password-store data in the string CONTENTS and return an alist.
CONTENTS is the contents of a password-store formatted file."
- (let ((lines (split-string contents "\n" t "[ \t]+")))
+ (let ((lines (cdr (split-string contents "\n" t "[ \t]+"))))
(seq-remove #'null
(mapcar (lambda (line)
- (let ((pair (mapcar (lambda (s) (string-trim s))
- (split-string line ":"))))
- (when (> (length pair) 1)
- (cons (car pair)
- (mapconcat #'identity (cdr pair) ":")))))
- (cdr lines)))))
+ (when-let ((pos (seq-position line ?:)))
+ (cons (string-trim (substring line 0 pos))
+ (string-trim (substring line (1+ pos))))))
+ lines))))
(defun auth-source-pass--do-debug (&rest msg)
"Call `auth-source-do-debug` with MSG and a prefix."
@@ -192,12 +190,21 @@ CONTENTS is the contents of a password-store formatted file."
(lambda (file) (file-name-sans-extension (file-relative-name file store-dir)))
(directory-files-recursively store-dir "\\.gpg\\'"))))
-(defun auth-source-pass--find-match (host user port)
- "Return password-store entry data matching HOST, USER and PORT.
-
-Disambiguate between user provided inside HOST (e.g., user@server.com) and
-inside USER by giving priority to USER. Same for PORT."
- (apply #'auth-source-pass--find-match-unambiguous (auth-source-pass--disambiguate host user port)))
+(defun auth-source-pass--find-match (hosts user port)
+ "Return password-store entry data matching HOSTS, USER and PORT.
+
+Disambiguate between user provided inside HOSTS (e.g., user@server.com) and
+inside USER by giving priority to USER. Same for PORT.
+HOSTS can be a string or a list of strings."
+ (seq-some (lambda (host)
+ (let ((entry (apply #'auth-source-pass--find-match-unambiguous
+ (auth-source-pass--disambiguate host user port))))
+ (if (or (null entry) (assoc "host" entry))
+ entry
+ (cons (cons "host" host) entry))))
+ (if (listp hosts)
+ hosts
+ (list hosts))))
(defun auth-source-pass--disambiguate (host &optional user port)
"Return (HOST USER PORT) after disambiguation.
@@ -266,7 +273,7 @@ If ENTRIES is nil, use the result of calling `auth-source-pass-entries' instead.
(defun auth-source-pass--generate-entry-suffixes (hostname user port)
"Return a list of possible entry path suffixes in the password-store.
-Based on the supported pathname patterns for HOSTNAME, USER, &
+Based on the supported filename patterns for HOSTNAME, USER, &
PORT, return a list of possible suffixes for matching entries in
the password-store.
@@ -314,3 +321,5 @@ then NAME & USER, then NAME & PORT, then just NAME."
(provide 'auth-source-pass)
;;; auth-source-pass.el ends here
+
+;; LocalWords: backend hostname
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index c7a1afb132a..69197383982 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -121,12 +121,12 @@ let-binding."
:initform nil
:documentation "Internal backend data.")
(create-function :initarg :create-function
- :initform ignore
+ :initform #'ignore
:type function
:custom function
:documentation "The create function.")
(search-function :initarg :search-function
- :initform ignore
+ :initform #'ignore
:type function
:custom function
:documentation "The search function.")))
@@ -162,7 +162,7 @@ let-binding."
(defvar auth-source-creation-prompts nil
"Default prompts for token values. Usually let-bound.")
-(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
+(make-obsolete 'auth-source-hide-passwords nil "24.1")
(defcustom auth-source-save-behavior 'ask
"If set, auth-source will respect it for save behavior."
@@ -581,14 +581,15 @@ 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.
+can use %u, %h, and %p to show the user, host, and port. The prompt
+is formatted with `format-prompt', a trailing \": \" is removed.
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: \"))))
+ \\='((secret . \"Enter IMAP password for %h:%p\"))))
(auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1
:P \"pppp\" :Q \"qqqq\"
:create \\='(A B Q)))
@@ -860,7 +861,9 @@ while \(:host t) would find all host entries."
secret)))
(defun auth-source-format-prompt (prompt alist)
- "Format PROMPT using %x (for any character x) specifiers in ALIST."
+ "Format PROMPT using %x (for any character x) specifiers in ALIST.
+Remove trailing \": \"."
+ (setq prompt (replace-regexp-in-string ":\\s-*$" "" prompt))
(dolist (cell alist)
(let ((c (nth 0 cell))
(v (nth 1 cell)))
@@ -1267,7 +1270,7 @@ See `auth-source-search' for details on SPEC."
;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
(cl-defun auth-source-netrc-create (&rest spec
- &key backend host port create
+ &key backend host port create user
&allow-other-keys)
(let* ((base-required '(host user port secret))
;; we know (because of an assertion in auth-source-search) that the
@@ -1275,6 +1278,7 @@ See `auth-source-search' for details on SPEC."
(create-extra (if (eq t create) nil create))
(current-data (car (auth-source-search :max 1
:host host
+ :user user
:port port)))
(required (append base-required create-extra))
(file (oref backend source))
@@ -1344,11 +1348,11 @@ See `auth-source-search' for details on SPEC."
"[any port]"))))
(prompt (or (auth-source--aget auth-source-creation-prompts r)
(cl-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)))
+ (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 ,(auth-source--aget printable-defaults 'user))
@@ -1378,7 +1382,9 @@ See `auth-source-search' for details on SPEC."
(setq check nil)))
ret))
(t 'never)))
- (plain (or (eval default) (read-passwd prompt))))
+ (plain
+ (or (eval default)
+ (read-passwd (format-prompt prompt nil)))))
;; ask if we don't know what to do (in which case
;; auth-source-netrc-use-gpg-tokens must be a list)
(unless gpg-encrypt
@@ -1390,12 +1396,9 @@ See `auth-source-search' for details on SPEC."
(if (eq gpg-encrypt 'gpg)
(auth-source-epa-make-gpg-token plain file)
plain))
- (if (stringp default)
- (read-string (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
+ (if (and (stringp default) auth-source-save-behavior)
+ (read-string
+ (format-prompt prompt default) nil nil default)
(eval default)))))
(when data
@@ -1745,12 +1748,12 @@ authentication tokens:
"[any label]"))))
(prompt (or (auth-source--aget auth-source-creation-prompts r)
(cl-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: ")
- (label "Enter label for %u@%h: "))
- (format "Enter %s (%%u@%%h:%%p): " 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")
+ (label "Enter label for %u@%h"))
+ (format "Enter %s (%%u@%%h:%%p)" r)))
(prompt (auth-source-format-prompt
prompt
`((?u ,(auth-source--aget printable-defaults 'user))
@@ -1760,13 +1763,11 @@ authentication tokens:
;; Store the data, prompting for the password if needed.
(setq data (or data
(if (eq r 'secret)
- (or (eval default) (read-passwd prompt))
- (if (stringp default)
- (read-string (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
+ (or (eval default)
+ (read-passwd (format-prompt prompt nil)))
+ (if (and (stringp default) auth-source-save-behavior)
+ (read-string
+ (format-prompt prompt default) nil nil default)
(eval default)))))
(when data
@@ -2073,7 +2074,9 @@ entries for git.gnus.org:
(setcar
(cdr secret)
(let ((v (car (cdr secret))))
- (lambda () v))))
+ (if (functionp v)
+ (lambda () (funcall v plist))
+ (lambda () v)))))
plist))
items))
;; ensure each item has each key in `returned-keys'
@@ -2188,11 +2191,11 @@ entries for git.gnus.org:
"[any port]"))))
(prompt (or (auth-source--aget auth-source-creation-prompts r)
(cl-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)))
+ (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 ,(auth-source--aget printable-defaults 'user))
@@ -2202,14 +2205,11 @@ entries for git.gnus.org:
;; Store the data, prompting for the password if needed.
(setq data (or data
(if (eq r 'secret)
- (or (eval default) (read-passwd prompt))
- (if (stringp default)
+ (or (eval default)
+ (read-passwd (format-prompt prompt nil)))
+ (if (and (stringp default) auth-source-save-behavior)
(read-string
- (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
+ (format-prompt prompt default) nil nil default)
(eval default)))))
(when data
@@ -2308,9 +2308,9 @@ See `auth-source-search' for details on SPEC."
;; deprecate the old interface
(make-obsolete 'auth-source-user-or-password
- 'auth-source-search "Emacs 24.1")
+ 'auth-source-search "24.1")
(make-obsolete 'auth-source-forget-user-or-password
- 'auth-source-forget "Emacs 24.1")
+ 'auth-source-forget "24.1")
(defun auth-source-user-or-password
(mode host port &optional username create-missing delete-existing)
@@ -2406,23 +2406,51 @@ MODE can be \"login\" or \"password\"."
(list user password auth-info)))
;;; Tiny mode for editing .netrc/.authinfo modes (that basically just
-;;; hides passwords).
+;;; hides passwords and adds basic syntax highlighting).
(defcustom authinfo-hidden "password"
"Regexp matching elements in .authinfo/.netrc files that should be hidden."
:type 'regexp
:version "27.1")
+(defcustom authinfo-hide-elements t
+ "Whether to use `authinfo-hidden' to hide elements in authinfo files."
+ :type 'boolean
+ :version "28.1")
+
+(defvar authinfo--keywords
+ '(("^#.*" . font-lock-comment-face)
+ ("^\\(machine\\)[ \t]+\\([^ \t\n]+\\)"
+ (1 font-lock-variable-name-face)
+ (2 font-lock-builtin-face))
+ ("\\(login\\)[ \t]+\\([^ \t\n]+\\)"
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-keyword-face))
+ ("\\(password\\)[ \t]+\\([^ \t\n]+\\)"
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-doc-face))
+ ("\\(port\\)[ \t]+\\([^ \t\n]+\\)"
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-type-face))
+ ("\\([^ \t\n]+\\)[, \t]+\\([^ \t\n]+\\)"
+ (1 font-lock-constant-face)
+ (2 nil))))
+
;;;###autoload
(define-derived-mode authinfo-mode fundamental-mode "Authinfo"
"Mode for editing .authinfo/.netrc files.
-This is just like `fundamental-mode', but hides passwords. The
-passwords are revealed when point moved into the password.
+This is just like `fundamental-mode', but has basic syntax
+highlighting and hides passwords. Passwords are revealed when
+point is moved into the passwords (see `authinfo-hide-elements').
\\{authinfo-mode-map}"
- (authinfo--hide-passwords (point-min) (point-max))
- (reveal-mode))
+ (font-lock-add-keywords nil authinfo--keywords)
+ (setq-local comment-start "#")
+ (setq-local comment-end "")
+ (when authinfo-hide-elements
+ (authinfo--hide-passwords (point-min) (point-max))
+ (reveal-mode)))
(defun authinfo--hide-passwords (start end)
(save-excursion
@@ -2434,14 +2462,15 @@ passwords are revealed when point moved into the password.
nil t)
(when (auth-source-netrc-looking-at-token)
(let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
- (overlay-put overlay 'display (propertize "****"
- 'face 'warning))
+ (overlay-put overlay 'display
+ (propertize "****" 'face 'font-lock-doc-face))
(overlay-put overlay 'reveal-toggle-invisible
#'authinfo--toggle-display)))))))
(defun authinfo--toggle-display (overlay hide)
(if hide
- (overlay-put overlay 'display (propertize "****" 'face 'warning))
+ (overlay-put overlay 'display
+ (propertize "****" 'face 'font-lock-doc-face))
(overlay-put overlay 'display nil)))
(provide 'auth-source)
diff --git a/lisp/autoarg.el b/lisp/autoarg.el
index 3cbc90fa4fb..7c2c6f1030d 100644
--- a/lisp/autoarg.el
+++ b/lisp/autoarg.el
@@ -1,4 +1,4 @@
-;;; autoarg.el --- make digit keys supply prefix args
+;;; autoarg.el --- make digit keys supply prefix args -*- lexical-binding: t -*-
;; Copyright (C) 1998, 2000-2021 Free Software Foundation, Inc.
@@ -59,9 +59,8 @@
;; (define-key autoarg-mode-map [?\r] 'autoarg-terminate)
(defvar autoarg-kp-digits
- (let (alist)
- (dotimes (i 10 alist)
- (push (cons (intern (format "kp-%d" i)) i) alist))))
+ (mapcar (lambda (i) (cons (intern (format "kp-%d" i)) i))
+ (reverse (number-sequence 0 9))))
(defun autoarg-kp-digit-argument (arg)
"Part of the numeric argument for the next command, like `digit-argument'."
@@ -108,7 +107,7 @@ then invokes the normal binding of \\[autoarg-terminate].
`C-u \\[autoarg-terminate]' invokes the normal binding of \\[autoarg-terminate] four times.
\\{autoarg-mode-map}"
- nil " Aarg" autoarg-mode-map :global t :group 'keyboard)
+ :lighter" Aarg" :global t :group 'keyboard)
;;;###autoload
(define-minor-mode autoarg-kp-mode
@@ -119,7 +118,7 @@ This is similar to `autoarg-mode' but rebinds the keypad keys
`kp-1' etc. to supply digit arguments.
\\{autoarg-kp-mode-map}"
- nil " Aakp" autoarg-kp-mode-map :global t :group 'keyboard
+ :lighter " Aakp" :global t :group 'keyboard
(if autoarg-kp-mode
(dotimes (i 10)
(let ((sym (intern (format "kp-%d" i))))
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 88074d5c20e..0392903c332 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -315,8 +315,7 @@ The document was typeset with
@printindex cp
@bye
-
-@c " (file-name-nondirectory (buffer-file-name)) " ends here\n"))
+"))
"A list specifying text to insert by default into a new file.
Elements look like (CONDITION . ACTION) or ((CONDITION . DESCRIPTION) . ACTION).
CONDITION may be a regexp that must match the new file's name, or it may be
@@ -396,7 +395,7 @@ Matches the visited file name against the elements of `auto-insert-alist'."
;; which might ask the user for something
(switch-to-buffer (current-buffer))
(if (and (consp action)
- (not (eq (car action) 'lambda)))
+ (not (functionp action)))
(skeleton-insert action)
(funcall action)))))
(if (vectorp action)
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 3fe7a00cf23..9197eadf225 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -242,6 +242,8 @@ For more information, see Info node `(emacs)Auto Revert'."
:tag "Load Hook"
:group 'auto-revert
:type 'hook)
+(make-obsolete-variable 'auto-revert-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom auto-revert-check-vc-info nil
"If non-nil Auto-Revert Mode reliably updates version control info.
@@ -353,10 +355,9 @@ the list of old buffers.")
(add-hook 'after-set-visited-file-name-hook
#'auto-revert-set-visited-file-name)
-(defvar auto-revert--buffers-by-watch-descriptor
- (make-hash-table :test 'equal)
- "A hash table mapping notification descriptors to lists of buffers.
-The buffers use that descriptor for auto-revert notifications.
+(defvar auto-revert--buffer-by-watch-descriptor nil
+ "An association list mapping notification descriptors to buffers.
+The buffer uses that descriptor for auto-revert notifications.
The key is equal to `auto-revert-notify-watch-descriptor' in each
buffer.")
@@ -390,6 +391,10 @@ disk changes.
When a buffer is reverted, a message is generated. This can be
suppressed by setting `auto-revert-verbose' to nil.
+Reverting can sometimes fail to preserve all the markers in the buffer.
+To avoid that, set `revert-buffer-insert-file-contents-function' to
+the slower function `revert-buffer-insert-file-contents-delicately'.
+
Use `global-auto-revert-mode' to automatically revert all buffers.
Use `auto-revert-tail-mode' if you know that the file will only grow
without being changed in the part that is already in the buffer."
@@ -628,16 +633,12 @@ will use an up-to-date value of `auto-revert-interval'."
(defun auto-revert-notify-rm-watch ()
"Disable file notification for current buffer's associated file."
- (let ((desc auto-revert-notify-watch-descriptor)
- (table auto-revert--buffers-by-watch-descriptor))
- (when desc
- (let ((buffers (delq (current-buffer) (gethash desc table))))
- (if buffers
- (puthash desc buffers table)
- (remhash desc table)))
- (ignore-errors
- (file-notify-rm-watch desc))
- (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t)))
+ (when-let ((desc auto-revert-notify-watch-descriptor))
+ (setq auto-revert--buffer-by-watch-descriptor
+ (assoc-delete-all desc auto-revert--buffer-by-watch-descriptor))
+ (ignore-errors
+ (file-notify-rm-watch desc))
+ (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t))
(setq auto-revert-notify-watch-descriptor nil
auto-revert-notify-modified-p nil))
@@ -648,39 +649,21 @@ will use an up-to-date value of `auto-revert-interval'."
(string-match auto-revert-notify-exclude-dir-regexp
(expand-file-name default-directory))
(file-symlink-p (or buffer-file-name default-directory)))
- ;; Check, whether this has been activated already.
(let ((file (if buffer-file-name
(expand-file-name buffer-file-name default-directory)
(expand-file-name default-directory))))
- (maphash
- (lambda (key _value)
- (when (and
- (file-notify-valid-p key)
- (equal (file-notify--watch-absolute-filename
- (gethash key file-notify-descriptors))
- (directory-file-name file))
- (equal (file-notify--watch-callback
- (gethash key file-notify-descriptors))
- 'auto-revert-notify-handler))
- (setq auto-revert-notify-watch-descriptor key)))
- auto-revert--buffers-by-watch-descriptor)
- ;; Create a new watch if needed.
- (unless auto-revert-notify-watch-descriptor
- (setq auto-revert-notify-watch-descriptor
- (ignore-errors
- (file-notify-add-watch
- file
- (if buffer-file-name '(change attribute-change) '(change))
- 'auto-revert-notify-handler))))
+ (setq auto-revert-notify-watch-descriptor
+ (ignore-errors
+ (file-notify-add-watch
+ file
+ (if buffer-file-name '(change attribute-change) '(change))
+ 'auto-revert-notify-handler))))
(when auto-revert-notify-watch-descriptor
- (setq auto-revert-notify-modified-p t)
- (puthash
- auto-revert-notify-watch-descriptor
- (cons (current-buffer)
- (gethash auto-revert-notify-watch-descriptor
- auto-revert--buffers-by-watch-descriptor))
- auto-revert--buffers-by-watch-descriptor)
- (add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t)))))
+ (setq auto-revert-notify-modified-p t
+ auto-revert--buffer-by-watch-descriptor
+ (cons (cons auto-revert-notify-watch-descriptor (current-buffer))
+ auto-revert--buffer-by-watch-descriptor))
+ (add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t))))
;; If we have file notifications, we want to update the auto-revert buffers
;; immediately when a notification occurs. Since file updates can happen very
@@ -709,8 +692,8 @@ system.")
(action (nth 1 event))
(file (nth 2 event))
(file1 (nth 3 event)) ;; Target of `renamed'.
- (buffers (gethash descriptor
- auto-revert--buffers-by-watch-descriptor)))
+ (buffer (alist-get descriptor auto-revert--buffer-by-watch-descriptor
+ nil nil #'equal)))
;; Check, that event is meant for us.
(cl-assert descriptor)
;; Since we watch a directory, a file name must be returned.
@@ -719,9 +702,9 @@ system.")
(when auto-revert-debug
(message "auto-revert-notify-handler %S" event))
- (if (eq action 'stopped)
- ;; File notification has stopped. Continue with polling.
- (cl-dolist (buffer buffers)
+ (when (buffer-live-p buffer)
+ (if (eq action 'stopped)
+ ;; File notification has stopped. Continue with polling.
(with-current-buffer buffer
(when (or
;; A buffer associated with a file.
@@ -734,38 +717,35 @@ system.")
(auto-revert-notify-rm-watch)
;; Restart the timer if it wasn't running.
(unless auto-revert-timer
- (auto-revert-set-timer)))))
-
- ;; Loop over all buffers, in order to find the intended one.
- (cl-dolist (buffer buffers)
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (when (or
- ;; A buffer associated with a file.
- (and (stringp buffer-file-name)
- (or
- (and (memq
- action '(attribute-changed changed created))
- (string-equal
- (file-name-nondirectory file)
- (file-name-nondirectory buffer-file-name)))
- (and (eq action 'renamed)
- (string-equal
- (file-name-nondirectory file1)
- (file-name-nondirectory buffer-file-name)))))
- ;; A buffer w/o a file, like dired.
- (and (null buffer-file-name)
- (memq action '(created renamed deleted))))
- ;; Mark buffer modified.
- (setq auto-revert-notify-modified-p t)
-
- ;; Revert the buffer now if we're not locked out.
- (unless auto-revert--lockout-timer
- (auto-revert-handler)
- (setq auto-revert--lockout-timer
- (run-with-timer
- auto-revert--lockout-interval nil
- #'auto-revert--end-lockout buffer)))))))))))
+ (auto-revert-set-timer))))
+
+ (with-current-buffer buffer
+ (when (or
+ ;; A buffer associated with a file.
+ (and (stringp buffer-file-name)
+ (or
+ (and (memq
+ action '(attribute-changed changed created))
+ (string-equal
+ (file-name-nondirectory file)
+ (file-name-nondirectory buffer-file-name)))
+ (and (eq action 'renamed)
+ (string-equal
+ (file-name-nondirectory file1)
+ (file-name-nondirectory buffer-file-name)))))
+ ;; A buffer w/o a file, like dired.
+ (and (null buffer-file-name)
+ (memq action '(created renamed deleted))))
+ ;; Mark buffer modified.
+ (setq auto-revert-notify-modified-p t)
+
+ ;; Revert the buffer now if we're not locked out.
+ (unless auto-revert--lockout-timer
+ (auto-revert-handler)
+ (setq auto-revert--lockout-timer
+ (run-with-timer
+ auto-revert--lockout-interval nil
+ #'auto-revert--end-lockout buffer))))))))))
(defun auto-revert--end-lockout (buffer)
"End the lockout period after a notification.
@@ -869,6 +849,62 @@ This is an internal function used by Auto-Revert Mode."
(restore-buffer-modified-p modified)))
(set-visited-file-modtime))
+(defun auto-revert--buffer-candidates ()
+ "Return a prioritized list of buffers to maybe auto-revert.
+The differences between this return value and the reference
+variable `auto-revert-buffer-list' include: 1) this has more
+entries when in global-auto-revert-mode; 2) this prioritizes
+buffers not reverted last time due to user interruption. "
+ (let ((bufs (delq nil
+ ;; Buffers with remote contents shall be reverted only
+ ;; if the connection is established already.
+ (mapcar
+ (lambda (buf)
+ (and (buffer-live-p buf)
+ (with-current-buffer buf
+ (and
+ (or (not (file-remote-p default-directory))
+ (file-remote-p default-directory nil t))
+ buf))))
+ (auto-revert--polled-buffers))))
+ remaining new)
+ ;; Partition `bufs' into two halves depending on whether or not
+ ;; the buffers are in `auto-revert-remaining-buffers'. The two
+ ;; halves are then re-joined with the "remaining" buffers at the
+ ;; head of the list.
+ (dolist (buf auto-revert-remaining-buffers)
+ (when (memq buf bufs)
+ (push buf remaining)))
+ (dolist (buf bufs)
+ (unless (memq buf remaining)
+ (push buf new)))
+ (nreverse (nconc new remaining))))
+
+(defun auto-revert-buffer (buf)
+ "Revert a single buffer.
+
+This is performed as specified by Auto-Revert and Global
+Auto-Revert Modes."
+ (if (not (buffer-live-p buf))
+ (auto-revert-remove-current-buffer buf)
+ (with-current-buffer buf
+ ;; Test if someone has turned off Auto-Revert Mode
+ ;; in a non-standard way, for example by changing
+ ;; major mode.
+ (when (and (not auto-revert-mode)
+ (not auto-revert-tail-mode))
+ (auto-revert-remove-current-buffer))
+ (when (auto-revert-active-p)
+ ;; Enable file notification.
+ ;; Don't bother creating a notifier for non-file buffers
+ ;; unless it explicitly indicates that this works.
+ (when (and auto-revert-use-notify
+ (not auto-revert-notify-watch-descriptor)
+ (or buffer-file-name
+ buffer-auto-revert-by-notification))
+ (auto-revert-notify-add-watch))
+ (auto-revert-handler)))))
+
(defun auto-revert-buffers ()
"Revert buffers as specified by Auto-Revert and Global Auto-Revert Mode.
@@ -892,68 +928,19 @@ are checked first the next time this function is called.
This function is also responsible for removing buffers no longer in
Auto-Revert Mode from `auto-revert-buffer-list', and for canceling
the timer when no buffers need to be checked."
-
(save-match-data
- (let ((bufs (auto-revert--polled-buffers))
- remaining new)
- ;; Buffers with remote contents shall be reverted only if the
- ;; connection is established already.
- (setq bufs (delq nil
- (mapcar
- (lambda (buf)
- (and (buffer-live-p buf)
- (with-current-buffer buf
- (and
- (or (not (file-remote-p default-directory))
- (file-remote-p default-directory nil t))
- buf))))
- bufs)))
- ;; Partition `bufs' into two halves depending on whether or not
- ;; the buffers are in `auto-revert-remaining-buffers'. The two
- ;; halves are then re-joined with the "remaining" buffers at the
- ;; head of the list.
- (dolist (buf auto-revert-remaining-buffers)
- (if (memq buf bufs)
- (push buf remaining)))
- (dolist (buf bufs)
- (if (not (memq buf remaining))
- (push buf new)))
- (setq bufs (nreverse (nconc new remaining)))
+ (let ((bufs (auto-revert--buffer-candidates)))
(while (and bufs
(not (and auto-revert-stop-on-user-input
(input-pending-p))))
- (let ((buf (car bufs)))
- (if (not (buffer-live-p buf))
- ;; Remove dead buffer from `auto-revert-buffer-list'.
- (auto-revert-remove-current-buffer buf)
- (with-current-buffer buf
- ;; Test if someone has turned off Auto-Revert Mode
- ;; in a non-standard way, for example by changing
- ;; major mode.
- (if (and (not auto-revert-mode)
- (not auto-revert-tail-mode)
- (memq buf auto-revert-buffer-list))
- (auto-revert-remove-current-buffer))
- (when (auto-revert-active-p)
- ;; Enable file notification.
- ;; Don't bother creating a notifier for non-file buffers
- ;; unless it explicitly indicates that this works.
- (when (and auto-revert-use-notify
- (not auto-revert-notify-watch-descriptor)
- (or buffer-file-name
- buffer-auto-revert-by-notification))
- (auto-revert-notify-add-watch))
- (auto-revert-handler)))))
- (setq bufs (cdr bufs)))
+ (auto-revert-buffer (pop bufs)))
(setq auto-revert-remaining-buffers bufs)
;; Check if we should cancel the timer.
(unless (auto-revert--need-polling-p)
- (if (timerp auto-revert-timer)
- (cancel-timer auto-revert-timer))
+ (when (timerp auto-revert-timer)
+ (cancel-timer auto-revert-timer))
(setq auto-revert-timer nil)))))
-
-;; The end:
(provide 'autorevert)
(run-hooks 'auto-revert-load-hook)
diff --git a/lisp/avoid.el b/lisp/avoid.el
index b53584ba9c5..d3afecf8cc2 100644
--- a/lisp/avoid.el
+++ b/lisp/avoid.el
@@ -1,4 +1,4 @@
-;;; avoid.el --- make mouse pointer stay out of the way of editing
+;;; avoid.el --- make mouse pointer stay out of the way of editing -*- lexical-binding: t -*-
;; Copyright (C) 1993-1994, 2000-2021 Free Software Foundation, Inc.
@@ -25,8 +25,10 @@
;; For those who are annoyed by the mouse pointer obscuring text,
;; this mode moves the mouse pointer - either just a little out of
;; the way, or all the way to the corner of the frame.
-;; To use, load or evaluate this file and type M-x mouse-avoidance-mode .
-;; To set up permanently, put the following in your .emacs:
+;;
+;; To use, type `M-x mouse-avoidance-mode'.
+;;
+;; To set up permanently, put this in your .emacs:
;;
;; (if (display-mouse-p) (mouse-avoidance-mode 'animate))
;;
@@ -47,11 +49,6 @@
;;
;; For completely random pointer shape, replace the setq above with:
;; (setq x-pointer-shape (mouse-avoidance-random-shape))
-;;
-;; Bugs / Warnings / To-Do:
-;;
-;; - Using this code does slow Emacs down. "banish" mode shouldn't
-;; be too bad, and on my workstation even "animate" is reasonable.
;; Credits:
;; This code was helped by all those who contributed suggestions,
@@ -76,14 +73,13 @@
"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'."
+use either \\[customize] or \\[mouse-avoidance-mode]."
:set (lambda (_symbol value)
;; 'none below prevents toggling when value is nil.
(mouse-avoidance-mode (or value 'none)))
:initialize 'custom-initialize-default
:type '(choice (const :tag "none" nil) (const banish) (const jump)
(const animate) (const exile) (const proteus))
- :group 'avoid
:require 'avoid
:version "20.3")
@@ -92,25 +88,21 @@ use either \\[customize] or the function `mouse-avoidance-mode'."
"Average distance that mouse will be moved when approached by cursor.
Only applies in Mouse Avoidance mode `jump' and its derivatives.
For best results make this larger than `mouse-avoidance-threshold'."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-nudge-var 10
"Variability of `mouse-avoidance-nudge-dist' (which see)."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-animation-delay .01
"Delay between animation steps, in seconds."
- :type 'number
- :group 'avoid)
+ :type 'number)
(defcustom mouse-avoidance-threshold 5
"Mouse-pointer's flight distance.
If the cursor gets closer than this, the mouse pointer will move away.
Only applies in Mouse Avoidance modes `animate' and `jump'."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-banish-position '((frame-or-window . frame)
(side . right)
@@ -261,9 +253,9 @@ If you want the mouse banished to a different corner set
(t 0))))
(defun mouse-avoidance-nudge-mouse ()
- ;; Push the mouse a little way away, possibly animating the move.
- ;; For these modes, state keeps track of the total offset that we've
- ;; accumulated, and tries to keep it close to zero.
+ "Push the mouse a little way away, possibly animating the move.
+For these modes, state keeps track of the total offset that we've
+accumulated, and tries to keep it close to zero."
(let* ((cur (mouse-position))
(cur-pos (cdr cur))
(pos (window-edges))
@@ -375,7 +367,7 @@ redefine this function to suit your own tastes."
(setq mouse-avoidance-state nil))))))
(defun mouse-avoidance-fancy ()
- ;; Used for the "fancy" modes, ie jump et al.
+ ;; Used for the "fancy" modes, i.e. jump et al.
(if (and (not mouse-avoidance-animating-pointer)
(not (mouse-avoidance-ignore-p))
(mouse-avoidance-too-close-p (mouse-position)))
@@ -383,7 +375,7 @@ redefine this function to suit your own tastes."
(mouse-avoidance-nudge-mouse)
(if (not (eq (selected-frame) (car old-pos)))
;; This should never happen.
- (apply 'set-mouse-position old-pos)))))
+ (apply #'set-mouse-position old-pos)))))
;;;###autoload
(defun mouse-avoidance-mode (&optional mode)
diff --git a/lisp/battery.el b/lisp/battery.el
index 9683c5f11a9..bf864c2bd4a 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -1,8 +1,9 @@
-;;; battery.el --- display battery status information
+;;; battery.el --- display battery status information -*- lexical-binding:t -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
;; Author: Ralph Schleicher <rs@ralph-schleicher.de>
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: hardware
;; This file is part of GNU Emacs.
@@ -22,15 +23,19 @@
;;; Commentary:
-;; There is at present support for GNU/Linux, macOS and Windows. This
-;; library supports both the `/proc/apm' file format of Linux version
-;; 1.3.58 or newer and the `/proc/acpi/' directory structure of Linux
-;; 2.4.20 and 2.6. Darwin (macOS) is supported by using the `pmset'
-;; program. Windows is supported by the GetSystemPowerStatus API call.
+;; There is at present support for GNU/Linux, BSD, macOS, and Windows.
+;; This library supports:
+;; - UPower (https://upower.freedesktop.org) via D-Bus API.
+;; - The `/sys/class/power_supply/' files of Linux >= 2.6.39.
+;; - The `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6.
+;; - The `/proc/apm' file format of Linux version 1.3.58 or newer.
+;; - BSD by using the `apm' program.
+;; - Darwin (macOS) by using the `pmset' program.
+;; - Windows via the GetSystemPowerStatus API call.
;;; Code:
-(require 'timer)
+(require 'dbus)
(eval-when-compile (require 'cl-lib))
(defgroup battery nil
@@ -38,41 +43,75 @@
:prefix "battery-"
:group 'hardware)
-(defcustom battery-upower-device "battery_BAT1"
- "Upower battery device name."
- :version "26.1"
- :type 'string
- :group 'battery)
+(defcustom battery-upower-device nil
+ "Preferred UPower device name(s).
+When `battery-status-function' is set to `battery-upower', this
+user option specifies which power sources to query for status
+information and merge into a single report.
+
+When nil (the default), `battery-upower' queries all present
+battery and line power devices as determined by the UPower
+EnumerateDevices method. A string or a nonempty list of strings
+names particular devices to query instead. UPower battery and
+line power device names typically follow the patterns
+\"battery_BATN\" and \"line_power_ACN\", respectively, with N
+starting at 0 when present. Device names should not include the
+leading D-Bus path \"/org/freedesktop/UPower/devices/\"."
+ :version "28.1"
+ :type '(choice (const :tag "Autodetect all devices" nil)
+ (string :tag "Device")
+ (repeat :tag "Devices" string)))
+
+(defcustom battery-upower-subscribe t
+ "Whether to subscribe to UPower device change signals.
+When nil, battery status information is polled every
+`battery-update-interval' seconds. When non-nil (the default),
+the battery status is also updated whenever a power source is
+added or removed, or when the system starts or stops running on
+battery power.
+
+This only takes effect when `battery-status-function' is set to
+`battery-upower' before enabling `display-battery-mode'."
+ :version "28.1"
+ :type 'boolean)
+
+(defconst battery-upower-service "org.freedesktop.UPower"
+ "Well-known name of the UPower D-Bus service.
+See URL `https://upower.freedesktop.org/docs/ref-dbus.html'.")
+
+(defun battery--files (dir)
+ "Return a list of absolute file names in DIR or nil on error.
+Value does not include \".\" or \"..\"."
+ (ignore-errors (directory-files dir t directory-files-no-dot-files-regexp)))
(defun battery--find-linux-sysfs-batteries ()
- (let ((dirs nil))
- (dolist (file (directory-files "/sys/class/power_supply/" t))
- (when (and (or (file-directory-p file)
- (file-symlink-p file))
- (file-exists-p (expand-file-name "capacity" file)))
- (push file dirs)))
+ "Return a list of all sysfs battery directories."
+ (let (dirs)
+ (dolist (dir (battery--files "/sys/class/power_supply/"))
+ (when (file-exists-p (expand-file-name "capacity" dir))
+ (push dir dirs)))
(nreverse dirs)))
(defcustom battery-status-function
- (cond ((and (eq system-type 'gnu/linux)
- (file-readable-p "/proc/apm"))
- #'battery-linux-proc-apm)
+ (cond ((member battery-upower-service (dbus-list-activatable-names))
+ #'battery-upower)
+ ((and (eq system-type 'gnu/linux)
+ (battery--find-linux-sysfs-batteries))
+ #'battery-linux-sysfs)
((and (eq system-type 'gnu/linux)
(file-directory-p "/proc/acpi/battery"))
#'battery-linux-proc-acpi)
((and (eq system-type 'gnu/linux)
- (file-directory-p "/sys/class/power_supply/")
- (battery--find-linux-sysfs-batteries))
- #'battery-linux-sysfs)
+ (file-readable-p "/proc/apm"))
+ #'battery-linux-proc-apm)
((and (eq system-type 'berkeley-unix)
(file-executable-p "/usr/sbin/apm"))
#'battery-bsd-apm)
((and (eq system-type 'darwin)
- (condition-case nil
- (with-temp-buffer
- (and (eq (call-process "pmset" nil t nil "-g" "ps") 0)
- (> (buffer-size) 0)))
- (error nil)))
+ (ignore-errors
+ (with-temp-buffer
+ (and (eq (call-process "pmset" nil t nil "-g" "ps") 0)
+ (not (bobp))))))
#'battery-pmset)
((fboundp 'w32-battery-status)
#'w32-battery-status))
@@ -84,8 +123,8 @@ Its cons cells are of the form
CONVERSION is the character code of a \"conversion specification\"
introduced by a `%' character in a control string."
- :type '(choice (const nil) function)
- :group 'battery)
+ :version "28.1"
+ :type '(choice (const nil) function))
(defcustom battery-echo-area-format
"Power %L, battery %B (%p%% load, remaining time %t)"
@@ -96,17 +135,20 @@ string are substituted as defined by the current value of the variable
`battery-status-function'. Here are the ones generally available:
%c Current capacity (mAh or mWh)
%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status: empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
-%t Remaining time (to charge or discharge) in the form `h:min'"
- :type '(choice string (const nil))
- :group 'battery)
+%t Remaining time (to charge or discharge) in the form `h:min'
+
+The full `format-spec' formatting syntax is supported."
+ :link '(info-link "(elisp) Custom Format Strings")
+ :type '(choice string (const nil)))
(defvar battery-mode-line-string nil
"String to display in the mode line.")
@@ -115,14 +157,13 @@ string are substituted as defined by the current value of the variable
(defcustom battery-mode-line-limit 100
"Percentage of full battery load below which display battery status."
:version "24.1"
- :type 'integer
- :group 'battery)
+ :type 'integer)
(defcustom battery-mode-line-format
- (cond ((eq battery-status-function 'battery-linux-proc-acpi)
- "[%b%p%%,%d°C]")
+ (cond ((eq battery-status-function #'battery-linux-proc-acpi)
+ "[%b%p%%,%d°C] ")
(battery-status-function
- "[%b%p%%]"))
+ "[%b%p%%] "))
"Control string formatting the string to display in the mode line.
Ordinary characters in the control string are printed as-is, while
conversion specifications introduced by a `%' character in the control
@@ -130,34 +171,46 @@ string are substituted as defined by the current value of the variable
`battery-status-function'. Here are the ones generally available:
%c Current capacity (mAh or mWh)
%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status: empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
-%t Remaining time (to charge or discharge) in the form `h:min'"
- :type '(choice string (const nil))
- :group 'battery)
+%t Remaining time (to charge or discharge) in the form `h:min'
+
+The full `format-spec' formatting syntax is supported."
+ :link '(info-link "(elisp) Custom Format Strings")
+ :type '(choice string (const nil)))
(defcustom battery-update-interval 60
"Seconds after which the battery status will be updated."
- :type 'integer
- :group 'battery)
+ :type 'integer)
(defcustom battery-load-low 25
"Upper bound of low battery load percentage.
A battery load percentage below this number is considered low."
- :type 'integer
- :group 'battery)
+ :type 'integer)
(defcustom battery-load-critical 10
"Upper bound of critical battery load percentage.
A battery load percentage below this number is considered critical."
- :type 'integer
- :group 'battery)
+ :type 'integer)
+
+(defface battery-load-low
+ '((t :inherit warning))
+ "Face used in mode line string when battery load is low.
+See the option `battery-load-low'."
+ :version "28.1")
+
+(defface battery-load-critical
+ '((t :inherit error))
+ "Face used in mode line string when battery load is critical.
+See the option `battery-load-critical'."
+ :version "28.1")
(defvar battery-update-timer nil
"Interval timer object.")
@@ -181,17 +234,21 @@ The text displayed in the mode line is controlled by
`battery-mode-line-format' and `battery-status-function'.
The mode line is be updated every `battery-update-interval'
seconds."
- :global t :group 'battery
+ :global t
(setq battery-mode-line-string "")
(or global-mode-string (setq global-mode-string '("")))
(and battery-update-timer (cancel-timer battery-update-timer))
+ (battery--upower-unsubscribe)
(if (and battery-status-function battery-mode-line-format)
(if (not display-battery-mode)
(setq global-mode-string
(delq 'battery-mode-line-string global-mode-string))
(add-to-list 'global-mode-string 'battery-mode-line-string t)
+ (and (eq battery-status-function #'battery-upower)
+ battery-upower-subscribe
+ (battery--upower-subscribe))
(setq battery-update-timer (run-at-time nil battery-update-interval
- 'battery-update-handler))
+ #'battery-update-handler))
(battery-update))
(message "Battery status not available")
(setq display-battery-mode nil)))
@@ -203,34 +260,42 @@ seconds."
(defun battery-update ()
"Update battery status information in the mode line."
(let* ((data (and battery-status-function (funcall battery-status-function)))
- (percentage (car (read-from-string (cdr (assq ?p data))))))
- (setq battery-mode-line-string
- (propertize (if (and battery-mode-line-format
- (numberp percentage)
- (<= percentage battery-mode-line-limit))
- (battery-format battery-mode-line-format data)
- "")
- 'face
- (and (numberp percentage)
- (<= percentage battery-load-critical)
- 'error)
- 'help-echo "Battery status information")))
- (force-mode-line-update))
+ (percentage (car (read-from-string (cdr (assq ?p data)))))
+ (res (and battery-mode-line-format
+ (or (not (numberp percentage))
+ (<= percentage battery-mode-line-limit))
+ (battery-format battery-mode-line-format data)))
+ (len (length res)))
+ (unless (zerop len)
+ (cond ((not (numberp percentage)))
+ ((< percentage battery-load-critical)
+ (add-face-text-property 0 len 'battery-load-critical t res))
+ ((< percentage battery-load-low)
+ (add-face-text-property 0 len 'battery-load-low t res)))
+ (put-text-property 0 len 'help-echo "Battery status information" res))
+ (setq battery-mode-line-string (or res "")))
+ (force-mode-line-update t))
+
;;; `/proc/apm' interface for Linux.
-(defconst battery-linux-proc-apm-regexp
- (concat "^\\([^ ]+\\)" ; Driver version.
- " \\([^ ]+\\)" ; APM BIOS version.
- " 0x\\([0-9a-f]+\\)" ; APM BIOS flags.
- " 0x\\([0-9a-f]+\\)" ; AC line status.
- " 0x\\([0-9a-f]+\\)" ; Battery status.
- " 0x\\([0-9a-f]+\\)" ; Battery flags.
- " \\(-?[0-9]+\\)%" ; Load percentage.
- " \\(-?[0-9]+\\)" ; Remaining time.
- " \\(.*\\)" ; Time unit.
- "$")
+;; Regular expression matching contents of `/proc/apm'.
+(rx-define battery--linux-proc-apm
+ (: bol (group (+ (not ?\s))) ; Driver version.
+ " " (group (+ (not ?\s))) ; APM BIOS version.
+ " 0x" (group (+ xdigit)) ; APM BIOS flags.
+ " 0x" (group (+ xdigit)) ; AC line status.
+ " 0x" (group (+ xdigit)) ; Battery status.
+ " 0x" (group (+ xdigit)) ; Battery flags.
+ " " (group (? ?-) (+ digit)) ?% ; Load percentage.
+ " " (group (? ?-) (+ digit)) ; Remaining time.
+ " " (group (* nonl)) ; Time unit
+ eol))
+
+(defconst battery-linux-proc-apm-regexp (rx battery--linux-proc-apm)
"Regular expression matching contents of `/proc/apm'.")
+(make-obsolete-variable 'battery-linux-proc-apm-regexp
+ "it is no longer used." "28.1")
(defun battery-linux-proc-apm ()
"Get APM status information from Linux (the kernel).
@@ -250,12 +315,12 @@ The following %-sequences are provided:
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let (driver-version bios-version bios-interface line-status
- battery-status battery-status-symbol load-percentage
- seconds minutes hours remaining-time tem)
+ (let ( driver-version bios-version bios-interface line-status
+ battery-status battery-status-symbol load-percentage
+ seconds minutes hours remaining-time tem )
(with-temp-buffer
(ignore-errors (insert-file-contents "/proc/apm"))
- (when (re-search-forward battery-linux-proc-apm-regexp)
+ (when (re-search-forward (rx battery--linux-proc-apm) nil t)
(setq driver-version (match-string 1))
(setq bios-version (match-string 2))
(setq tem (string-to-number (match-string 3) 16))
@@ -268,9 +333,7 @@ The following %-sequences are provided:
(cond ((= tem 0) (setq line-status "off-line"))
((= tem 1) (setq line-status "on-line"))
((= tem 2) (setq line-status "on backup")))
- (setq tem (string-to-number (match-string 6) 16))
- (if (= tem 255)
- (setq battery-status "N/A")
+ (unless (= (string-to-number (match-string 6) 16) 255)
(setq tem (string-to-number (match-string 5) 16))
(cond ((= tem 0) (setq battery-status "high"
battery-status-symbol ""))
@@ -287,7 +350,7 @@ The following %-sequences are provided:
(setq minutes (/ seconds 60)
hours (/ seconds 3600))
(setq remaining-time
- (format "%d:%02d" hours (- minutes (* 60 hours))))))))
+ (format "%d:%02d" hours (% minutes 60)))))))
(list (cons ?v (or driver-version "N/A"))
(cons ?V (or bios-version "N/A"))
(cons ?I (or bios-interface "N/A"))
@@ -295,27 +358,31 @@ The following %-sequences are provided:
(cons ?B (or battery-status "N/A"))
(cons ?b (or battery-status-symbol ""))
(cons ?p (or load-percentage "N/A"))
- (cons ?s (or (and seconds (number-to-string seconds)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
+ (cons ?s (if seconds (number-to-string seconds) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
(cons ?t (or remaining-time "N/A")))))
;;; `/proc/acpi/' interface for Linux.
+(rx-define battery--acpi-rate (&rest hour)
+ (: (group (+ digit)) " " (group ?m (in "AW") hour)))
+(rx-define battery--acpi-capacity (battery--acpi-rate ?h))
+
(defun battery-linux-proc-acpi ()
"Get ACPI status information from Linux (the kernel).
-This function works only with the `/proc/acpi/' format introduced
-in Linux version 2.4.20 and 2.6.0.
+This function works only with the `/proc/acpi/' interface
+introduced in Linux version 2.4.20 and 2.6.0.
The following %-sequences are provided:
%c Current capacity (mAh)
-%r Current rate
+%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status, empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
@@ -331,45 +398,51 @@ The following %-sequences are provided:
;; information together since displaying for a variable amount of
;; batteries seems overkill for format-strings.
(with-temp-buffer
- (dolist (dir (ignore-errors (directory-files "/proc/acpi/battery/"
- t "\\`[^.]")))
- (erase-buffer)
- (ignore-errors (insert-file-contents (expand-file-name "state" dir)))
- (when (re-search-forward "present: +yes$" nil t)
- (and (re-search-forward "charging state: +\\(.*\\)$" nil t)
+ (dolist (dir (battery--files "/proc/acpi/battery/"))
+ (ignore-errors
+ (insert-file-contents (expand-file-name "state" dir) nil nil nil t))
+ (goto-char (point-min))
+ (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t)
+ (and (re-search-forward (rx "charging state:" (+ space)
+ (group (not space) (* nonl)) eol)
+ nil t)
(member charging-state '("unknown" "charged" nil))
;; On most multi-battery systems, most of the time only one
;; battery is "charging"/"discharging", the others are
;; "unknown".
(setq charging-state (match-string 1)))
- (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$"
+ (when (re-search-forward (rx "present rate:" (+ space)
+ (battery--acpi-rate) eol)
nil t)
(setq rate (+ (or rate 0) (string-to-number (match-string 1))))
(when (> rate 0)
- (setq rate-type (or (and rate-type
- (if (string= rate-type (match-string 2))
- rate-type
- (error
- "Inconsistent rate types (%s vs. %s)"
- rate-type (match-string 2))))
- (match-string 2)))))
- (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$"
+ (cond ((not rate-type)
+ (setq rate-type (match-string 2)))
+ ((not (string= rate-type (match-string 2)))
+ (error "Inconsistent rate types (%s vs. %s)"
+ rate-type (match-string 2))))))
+ (when (re-search-forward (rx "remaining capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(setq capacity
(+ (or capacity 0) (string-to-number (match-string 1))))))
(goto-char (point-max))
(ignore-errors (insert-file-contents (expand-file-name "info" dir)))
- (when (re-search-forward "present: +yes$" nil t)
- (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t)
+ (when (re-search-forward (rx "design capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf design-capacity (string-to-number (match-string 1))))
- (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "last full capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf last-full-capacity (string-to-number (match-string 1))))
- (when (re-search-forward
- "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t)
+ (when (re-search-forward (rx "design capacity warning:" (+ space)
+ battery--acpi-capacity eol)
+ nil t)
(cl-incf warn (string-to-number (match-string 1))))
- (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "design capacity low:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf low (string-to-number (match-string 1)))))))
(setq full-capacity (if (> last-full-capacity 0)
@@ -383,77 +456,70 @@ The following %-sequences are provided:
60)
rate))
hours (/ minutes 60)))
- (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A"))
+ (list (cons ?c (if capacity (number-to-string capacity) "N/A"))
(cons ?L (or (battery-search-for-one-match-in-files
- (mapcar (lambda (e) (concat e "/state"))
- (ignore-errors
- (directory-files "/proc/acpi/ac_adapter/"
- t "\\`[^.]")))
- "state: +\\(.*\\)$" 1)
-
+ (mapcar (lambda (d) (expand-file-name "state" d))
+ (battery--files "/proc/acpi/ac_adapter/"))
+ (rx "state:" (+ space) (group (not space) (* nonl)) eol)
+ 1)
"N/A"))
(cons ?d (or (battery-search-for-one-match-in-files
- (mapcar (lambda (e) (concat e "/temperature"))
- (ignore-errors
- (directory-files "/proc/acpi/thermal_zone/"
- t "\\`[^.]")))
- "temperature: +\\([0-9]+\\) C$" 1)
-
+ (mapcar (lambda (d) (expand-file-name "temperature" d))
+ (battery--files "/proc/acpi/thermal_zone/"))
+ (rx "temperature:" (+ space) (group (+ digit)) " C" eol)
+ 1)
"N/A"))
- (cons ?r (or (and rate (concat (number-to-string rate) " "
- rate-type)) "N/A"))
+ (cons ?r (if rate
+ (concat (number-to-string rate) " " rate-type)
+ "N/A"))
(cons ?B (or charging-state "N/A"))
- (cons ?b (or (and (string= charging-state "charging") "+")
- (and capacity (< capacity low) "!")
- (and capacity (< capacity warn) "-")
- ""))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?t (or (and minutes
- (format "%d:%02d" hours (- minutes (* 60 hours))))
- "N/A"))
- (cons ?p (or (and full-capacity capacity
- (> full-capacity 0)
- (number-to-string
- (floor (* 100 capacity) full-capacity)))
- "N/A")))))
+ (cons ?b (cond ((string= charging-state "charging") "+")
+ ((and capacity (< capacity low)) "!")
+ ((and capacity (< capacity warn)) "-")
+ ("")))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?t (if minutes (format "%d:%02d" hours (% minutes 60)) "N/A"))
+ (cons ?p (if (and full-capacity capacity (> full-capacity 0))
+ (number-to-string (floor (* 100 capacity) full-capacity))
+ "N/A")))))
;;; `/sys/class/power_supply/BATN' interface for Linux.
(defun battery-linux-sysfs ()
- "Get ACPI status information from Linux kernel.
+ "Get sysfs status information from Linux kernel.
This function works only with the new `/sys/class/power_supply/'
-format introduced in Linux version 2.4.25.
+interface introduced in Linux version 2.4.25.
The following %-sequences are provided:
%c Current capacity (mAh or mWh)
-%r Current rate
+%r Current rate of charge or discharge
+%L Power source (verbose)
%B Battery status (verbose)
+%b Battery status, empty means high, `-' means low,
+ `!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
%p Battery load percentage
-%L AC line status (verbose)
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let (charging-state temperature hours
- ;; Some batteries report charges and current, other energy and power.
+ (let (;; Some batteries report charges and current, others energy and power.
;; In order to reliably be able to combine those data, we convert them
;; all to energy/power (since we can't combine different charges if
;; they're not at the same voltage).
(energy-full 0.0)
(energy-now 0.0)
(power-now 0.0)
- (voltage-now 10.8)) ;Arbitrary default, in case the info is missing.
+ (voltage-now 10.8) ; Arbitrary default, in case the info is missing.
+ charging-state temperature hours percentage-now)
;; SysFS provides information about each battery present in the
;; system in a separate subdirectory. We are going to merge the
;; available information together.
(with-temp-buffer
- (dolist (dir (ignore-errors
- (battery--find-linux-sysfs-batteries)))
- (erase-buffer)
- (ignore-errors (insert-file-contents
- (expand-file-name "uevent" dir)))
+ (dolist (dir (battery--find-linux-sysfs-batteries))
+ (ignore-errors
+ (insert-file-contents (expand-file-name "uevent" dir) nil nil nil t))
(goto-char (point-min))
(when (re-search-forward
"POWER_SUPPLY_VOLTAGE_NOW=\\([0-9]*\\)$" nil t)
@@ -489,7 +555,7 @@ The following %-sequences are provided:
voltage-now))
(cl-incf energy-now (* (string-to-number now-string)
voltage-now)))
- ((and (progn (goto-char (point-min)) t)
+ ((and (goto-char (point-min))
(re-search-forward
"POWER_SUPPLY_ENERGY_FULL=\\([0-9]*\\)$" nil t)
(setq full-string (match-string 1))
@@ -498,15 +564,16 @@ The following %-sequences are provided:
(setq now-string (match-string 1)))
(cl-incf energy-full (string-to-number full-string))
(cl-incf energy-now (string-to-number now-string)))))
- (goto-char (point-min))
(unless (zerop power-now)
(let ((remaining (if (string= charging-state "Discharging")
energy-now
(- energy-full energy-now))))
(setq hours (/ remaining power-now)))))))
- (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0))
- (number-to-string (/ energy-now voltage-now)))
- (t "N/A")))
+ (when (and (> energy-full 0) (> energy-now 0))
+ (setq percentage-now (/ (* 100 energy-now) energy-full)))
+ (list (cons ?c (if (or (> energy-full 0) (> energy-now 0))
+ (number-to-string (/ energy-now voltage-now))
+ "N/A"))
(cons ?r (if (> power-now 0.0)
(format "%.1f" (/ power-now 1000000.0))
"N/A"))
@@ -517,104 +584,207 @@ The following %-sequences are provided:
"N/A"))
(cons ?d (or temperature "N/A"))
(cons ?B (or charging-state "N/A"))
- (cons ?p (cond ((and (> energy-full 0) (> energy-now 0))
- (format "%.1f"
- (/ (* 100 energy-now) energy-full)))
- (t "N/A")))
- (cons ?L (cond
- ((battery-search-for-one-match-in-files
- (list "/sys/class/power_supply/AC/online"
- "/sys/class/power_supply/ACAD/online"
- "/sys/class/power_supply/ADP1/online")
- "1" 0)
- "AC")
- ((battery-search-for-one-match-in-files
- (list "/sys/class/power_supply/AC/online"
- "/sys/class/power_supply/ACAD/online"
- "/sys/class/power_supply/ADP1/online")
- "0" 0)
- "BAT")
- (t "N/A"))))))
+ (cons ?b (cond ((string= charging-state "Charging") "+")
+ ((not percentage-now) "")
+ ((< percentage-now battery-load-critical) "!")
+ ((< percentage-now battery-load-low) "-")
+ ("")))
+ (cons ?p (if percentage-now (format "%.1f" percentage-now) "N/A"))
+ (cons ?L (pcase (battery-search-for-one-match-in-files
+ '("/sys/class/power_supply/AC/online"
+ "/sys/class/power_supply/ACAD/online"
+ "/sys/class/power_supply/ADP1/online")
+ (rx (in "01")) 0)
+ ("0" "BAT")
+ ("1" "AC")
+ (_ "N/A"))))))
-(declare-function dbus-get-property "dbus.el"
- (bus service path interface property))
-
-;;; `upowerd' interface.
-(defsubst battery-upower-prop (pname &optional device)
- (dbus-get-property
- :system
- "org.freedesktop.UPower"
- (concat "/org/freedesktop/UPower/devices/" (or device battery-upower-device))
- "org.freedesktop.UPower"
- pname))
+;;; UPower interface.
+
+(defconst battery-upower-interface "org.freedesktop.UPower"
+ "Name of the UPower D-Bus interface.
+See URL `https://upower.freedesktop.org/docs/UPower.html'.")
+
+(defconst battery-upower-path "/org/freedesktop/UPower"
+ "D-Bus object providing `battery-upower-interface'.")
+
+(defconst battery-upower-device-interface "org.freedesktop.UPower.Device"
+ "Name of the UPower Device D-Bus interface.
+See URL `https://upower.freedesktop.org/docs/Device.html'.")
+
+(defconst battery-upower-device-path "/org/freedesktop/UPower/devices"
+ "D-Bus object providing `battery-upower-device-interface'.")
+
+(defvar battery--upower-signals nil
+ "Handles for UPower signal subscriptions.")
+
+(defun battery--upower-signal-handler (&rest _)
+ "Update battery status on receiving a UPower D-Bus signal."
+ (timer-event-handler battery-update-timer))
+
+(defun battery--upower-props-changed (_interface changed _invalidated)
+ "Update status when system starts/stops running on battery.
+Intended as a UPower PropertiesChanged signal handler."
+ (when (assoc "OnBattery" changed)
+ (battery--upower-signal-handler)))
+
+(defun battery--upower-unsubscribe ()
+ "Unsubscribe from UPower device change signals."
+ (mapc #'dbus-unregister-object battery--upower-signals)
+ (setq battery--upower-signals ()))
+
+(defun battery--upower-subscribe ()
+ "Subscribe to UPower device change signals."
+ (push (dbus-register-signal :system battery-upower-service
+ battery-upower-path
+ dbus-interface-properties
+ "PropertiesChanged"
+ #'battery--upower-props-changed)
+ battery--upower-signals)
+ (dolist (method '("DeviceAdded" "DeviceRemoved"))
+ (push (dbus-register-signal :system battery-upower-service
+ battery-upower-path
+ battery-upower-interface
+ method #'battery--upower-signal-handler)
+ battery--upower-signals)))
+
+(defun battery--upower-device-properties (device)
+ "Return value for all available properties for the UPower DEVICE."
+ (dbus-get-all-properties
+ :system battery-upower-service
+ (expand-file-name device battery-upower-device-path)
+ battery-upower-device-interface))
+
+(defun battery--upower-devices ()
+ "List all UPower devices according to `battery-upower-device'."
+ (cond ((stringp battery-upower-device)
+ (list battery-upower-device))
+ (battery-upower-device)
+ ((dbus-ignore-errors
+ (dbus-call-method :system battery-upower-service
+ battery-upower-path
+ battery-upower-interface
+ "EnumerateDevices"
+ :timeout 1000)))))
+
+(defun battery--upower-state (props state)
+ "Merge the UPower battery state in PROPS with STATE.
+This is an extension of the UPower DisplayDevice algorithm for
+merging multiple battery states into one. PROPS is an alist of
+battery properties from `battery-upower-device-interface', and
+STATE is a symbol representing the state to merge with."
+ ;; Map UPower enum into our printable symbols.
+ (let* ((new (pcase (cdr (assoc "State" props))
+ (1 'charging)
+ (2 'discharging)
+ (3 'empty)
+ (4 'fully-charged)
+ (5 'pending-charge)
+ (6 'pending-discharge)))
+ ;; Unknown state represented by nil.
+ (either (delq nil (list new state))))
+ ;; Earlier states override later ones.
+ (car (cond ((memq 'charging either))
+ ((memq 'discharging either))
+ ((memq 'pending-charge either))
+ ((memq 'pending-discharge either))
+ ;; Only options left are full or empty,
+ ;; but if they conflict return nil.
+ ((null (cdr either)) either)
+ ((apply #'eq either) either)))))
(defun battery-upower ()
- "Get battery status from dbus Upower interface.
-This function works only in systems with `upowerd' daemon
-running.
+ "Get battery status from UPower D-Bus interface.
+This function works only in systems that provide a UPower D-Bus
+service.
The following %-sequences are provided:
%c Current capacity (mWh)
-%p Battery load percentage
-%r Current rate
-%B Battery status (verbose)
+%r Current rate of charge or discharge
%L AC line status (verbose)
+%B Battery status (verbose)
+%b Battery status: empty means high, `-' means low,
+ `!' means critical, and `+' means charging
+%d Temperature (in degrees Celsius)
+%p Battery load percentage
%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let ((percents (battery-upower-prop "Percentage"))
- (time-to-empty (battery-upower-prop "TimeToEmpty"))
- (time-to-full (battery-upower-prop "TimeToFull"))
- (state (battery-upower-prop "State"))
- (online (battery-upower-prop "Online" "line_power_ACAD"))
- (energy (battery-upower-prop "Energy"))
- (energy-rate (battery-upower-prop "EnergyRate"))
- (battery-states '((0 . "unknown") (1 . "charging")
- (2 . "discharging") (3 . "empty")
- (4 . "fully-charged") (5 . "pending-charge")
- (6 . "pending-discharge")))
- seconds minutes hours remaining-time)
- (cond ((and online time-to-full)
- (setq seconds time-to-full))
- ((and (not online) time-to-empty)
- (setq seconds time-to-empty)))
- (when seconds
- (setq minutes (/ seconds 60)
- hours (/ minutes 60)
- remaining-time (format "%d:%02d" hours (mod minutes 60))))
- (list (cons ?c (or (and energy
- (number-to-string (round (* 1000 energy))))
- "N/A"))
- (cons ?p (or (and percents (number-to-string (round percents)))
- "N/A"))
- (cons ?r (or (and energy-rate
- (concat (number-to-string energy-rate) " W"))
- "N/A"))
- (cons ?B (or (and state (cdr (assoc state battery-states)))
- "unknown"))
- (cons ?L (or (and online "on-line") "off-line"))
- (cons ?s (or (and seconds (number-to-string seconds)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
- (cons ?t (or remaining-time "N/A")))))
+ (let ((count 0) props type line-status state load temperature
+ secs mins hrs total-energy total-rate total-tte total-ttf)
+ ;; Merge information from all available or specified UPower
+ ;; devices like other `battery-status-function's.
+ (dolist (device (battery--upower-devices))
+ (setq props (battery--upower-device-properties device))
+ (setq type (cdr (assoc "Type" props)))
+ (cond
+ ((and (eq type 1) (not (eq line-status 'online)))
+ ;; It's a line power device: `online' if currently providing
+ ;; power, any other non-nil value if simply present.
+ (setq line-status (if (cdr (assoc "Online" props)) 'online t)))
+ ((and (eq type 2) (cdr (assoc "IsPresent" props)))
+ ;; It's a battery.
+ (setq count (1+ count))
+ (setq state (battery--upower-state props state))
+ (let ((energy (cdr (assoc "Energy" props)))
+ (rate (cdr (assoc "EnergyRate" props)))
+ (percent (cdr (assoc "Percentage" props)))
+ (temp (cdr (assoc "Temperature" props)))
+ (tte (cdr (assoc "TimeToEmpty" props)))
+ (ttf (cdr (assoc "TimeToFull" props))))
+ (when energy (setq total-energy (+ (or total-energy 0) energy)))
+ (when rate (setq total-rate (+ (or total-rate 0) rate)))
+ (when percent (setq load (+ (or load 0) percent)))
+ (when temp (setq temperature (+ (or temperature 0) temp)))
+ (when tte (setq total-tte (+ (or total-tte 0) tte)))
+ (when ttf (setq total-ttf (+ (or total-ttf 0) ttf)))))))
+ (when (> count 1)
+ ;; Averages over multiple batteries.
+ (when load (setq load (/ load count)))
+ (when temperature (setq temperature (/ temperature count))))
+ (when (setq secs (if (eq line-status 'online) total-ttf total-tte))
+ (setq mins (/ secs 60))
+ (setq hrs (/ secs 3600)))
+ (list (cons ?c (if total-energy
+ (format "%.0f" (* total-energy 1000))
+ "N/A"))
+ (cons ?r (if total-rate (format "%.1f W" total-rate) "N/A"))
+ (cons ?L (cond ((eq line-status 'online) "on-line")
+ (line-status "off-line")
+ ("N/A")))
+ (cons ?B (format "%s" (or state 'unknown)))
+ (cons ?b (cond ((eq state 'charging) "+")
+ ((and load (< load battery-load-critical)) "!")
+ ((and load (< load battery-load-low)) "-")
+ ("")))
+ ;; Zero usually means unknown.
+ (cons ?d (if (and temperature (/= temperature 0))
+ (format "%.0f" temperature)
+ "N/A"))
+ (cons ?p (if load (format "%.0f" load) "N/A"))
+ (cons ?s (if secs (number-to-string secs) "N/A"))
+ (cons ?m (if mins (number-to-string mins) "N/A"))
+ (cons ?h (if hrs (number-to-string hrs) "N/A"))
+ (cons ?t (if hrs (format "%d:%02d" hrs (% mins 60)) "N/A")))))
;;; `apm' interface for BSD.
+
(defun battery-bsd-apm ()
"Get APM status information from BSD apm binary.
The following %-sequences are provided:
+%P Advanced power saving mode state (verbose)
%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status, empty means high, `-' means low,
- `!' means critical, and `+' means charging
-%P Advanced power saving mode state (verbose)
-%p Battery charge percentage
-%s Remaining battery charge time in seconds
-%m Remaining battery charge time in minutes
-%h Remaining battery charge time in hours
-%t Remaining battery charge time in the form `h:min'"
+ `!' means critical, and `+' means charging
+%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
+%m Remaining time (to charge or discharge) in minutes
+%h Remaining time (to charge or discharge) in hours
+%t Remaining time (to charge or discharge) in the form `h:min'"
(let* ((os-name (car (split-string
;; FIXME: Can't we use something like `system-type'?
(shell-command-to-string "/usr/bin/uname"))))
@@ -680,7 +850,7 @@ The following %-sequences are provided:
(setq seconds (string-to-number battery-life)
minutes (truncate seconds 60)))
(setq hours (truncate minutes 60)
- remaining-time (format "%d:%02d" hours (mod minutes 60))))
+ remaining-time (format "%d:%02d" hours (% minutes 60))))
(list (cons ?L (or line-status "N/A"))
(cons ?B (or (car battery-status) "N/A"))
(cons ?b (or (cdr battery-status) "N/A"))
@@ -688,9 +858,9 @@ The following %-sequences are provided:
"N/A"
battery-percentage))
(cons ?P (or apm-mode "N/A"))
- (cons ?s (or (and seconds (number-to-string seconds)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
+ (cons ?s (if seconds (number-to-string seconds) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
(cons ?t (or remaining-time "N/A")))))
@@ -705,21 +875,25 @@ The following %-sequences are provided:
%b Battery status, empty means high, `-' means low,
`!' means critical, and `+' means charging
%p Battery load percentage
-%h Remaining time in hours
-%m Remaining time in minutes
-%t Remaining time in the form `h:min'"
- (let (power-source load-percentage battery-status battery-status-symbol
- remaining-time hours minutes)
+%m Remaining time (to charge or discharge) in minutes
+%h Remaining time (to charge or discharge) in hours
+%t Remaining time (to charge or discharge) in the form `h:min'"
+ (let ( power-source load-percentage battery-status battery-status-symbol
+ remaining-time hours minutes )
(with-temp-buffer
(ignore-errors (call-process "pmset" nil t nil "-g" "ps"))
(goto-char (point-min))
- (when (re-search-forward "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" nil t)
+ (when (re-search-forward ;; Handle old typo in output.
+ "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'"
+ nil t)
(setq power-source (match-string 1))
- (when (re-search-forward "^ -InternalBattery-0\\([ \t]+(id=[0-9]+)\\)*[ \t]+" nil t)
+ (when (re-search-forward (rx bol " -InternalBattery-0" (+ space)
+ (* "(id=" (+ digit) ")" (+ space)))
+ nil t)
(when (looking-at "\\([0-9]\\{1,3\\}\\)%")
(setq load-percentage (match-string 1))
(goto-char (match-end 0))
- (cond ((looking-at "; charging")
+ (cond ((looking-at-p "; charging")
(setq battery-status "charging"
battery-status-symbol "+"))
((< (string-to-number load-percentage) battery-load-critical)
@@ -750,13 +924,7 @@ The following %-sequences are provided:
(defun battery-format (format alist)
"Substitute %-sequences in FORMAT."
- (replace-regexp-in-string
- "%."
- (lambda (str)
- (let ((char (aref str 1)))
- (if (eq char ?%) "%"
- (or (cdr (assoc char alist)) ""))))
- format t t))
+ (format-spec format alist 'delete))
(defun battery-search-for-one-match-in-files (files regexp match-num)
"Search REGEXP in the content of the files listed in FILES.
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 48989fdc9d2..8e5799fbe88 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -1,4 +1,4 @@
-;;; bindings.el --- define standard key bindings and some variables
+;;; bindings.el --- define standard key bindings and some variables -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1987, 1992-1996, 1999-2021 Free Software
;; Foundation, Inc.
@@ -199,7 +199,7 @@ mouse-3: Set coding system"
(symbol-name buffer-file-coding-system))
"Buffer coding system: none specified")))
-(defvar mode-line-mule-info
+(defvar-local mode-line-mule-info
`(""
(current-input-method
(:propertize ("" current-input-method-title)
@@ -225,7 +225,6 @@ mnemonics of the following coding systems:
coding system for terminal output (on a text terminal)")
;;;###autoload
(put 'mode-line-mule-info 'risky-local-variable t)
-(make-variable-buffer-local 'mode-line-mule-info)
(defvar mode-line-client
`(""
@@ -247,7 +246,7 @@ mnemonics of the following coding systems:
(format "Buffer is %smodified\nmouse-1: Toggle modification state"
(if (buffer-modified-p (window-buffer window)) "" "not ")))
-(defvar mode-line-modified
+(defvar-local mode-line-modified
(list (propertize
"%1*"
'help-echo 'mode-line-read-only-help-echo
@@ -264,9 +263,8 @@ mnemonics of the following coding systems:
"Mode line construct for displaying whether current buffer is modified.")
;;;###autoload
(put 'mode-line-modified 'risky-local-variable t)
-(make-variable-buffer-local 'mode-line-modified)
-(defvar mode-line-remote
+(defvar-local mode-line-remote
(list (propertize
"%1@"
'mouse-face 'mode-line-highlight
@@ -283,7 +281,6 @@ mnemonics of the following coding systems:
"Mode line construct to indicate a remote buffer.")
;;;###autoload
(put 'mode-line-remote 'risky-local-variable t)
-(make-variable-buffer-local 'mode-line-remote)
;; MSDOS frames have window-system, but want the Fn identification.
(defun mode-line-frame-control ()
@@ -301,12 +298,11 @@ Value is used for `mode-line-frame-identification', which see."
;;;###autoload
(put 'mode-line-frame-identification 'risky-local-variable t)
-(defvar mode-line-process nil
+(defvar-local mode-line-process nil
"Mode line construct for displaying info on process status.
Normally nil in most modes, since there is no process to display.")
;;;###autoload
(put 'mode-line-process 'risky-local-variable t)
-(make-variable-buffer-local 'mode-line-process)
(defun bindings--define-key (map key item)
"Define KEY in keymap MAP according to ITEM from a menu.
@@ -334,22 +330,53 @@ of the menu's data."
(defvar mode-line-mode-menu (make-sparse-keymap "Minor Modes") "\
Menu of mode operations in the mode line.")
+(defun bindings--menu-item-string (item)
+ "Return the menu-item string for ITEM, or nil if not a menu-item."
+ (pcase item
+ (`(menu-item ,name . ,_) (eval name t))
+ (`(,(and (pred stringp) name) . ,_) name)))
+
+(defun bindings--sort-menu-keymap (map)
+ "Sort the bindings in MAP in alphabetical order by menu-item string.
+The order of bindings in a keymap matters only when it is used as
+a menu, so this function is not useful for non-menu keymaps."
+ (let ((bindings nil)
+ (prompt (keymap-prompt map)))
+ (while (keymapp map)
+ (setq map (map-keymap
+ (lambda (key item)
+ ;; FIXME: Handle char-ranges here?
+ (push (cons key item) bindings))
+ map)))
+ ;; Sort the bindings and make a new keymap from them.
+ (setq bindings
+ (sort bindings
+ (lambda (a b)
+ (string< (bindings--menu-item-string (cdr-safe a))
+ (bindings--menu-item-string (cdr-safe b))))))
+ (nconc (make-sparse-keymap prompt) bindings)))
+
(defvar mode-line-major-mode-keymap
(let ((map (make-sparse-keymap)))
(bindings--define-key map [mode-line down-mouse-1]
`(menu-item "Menu Bar" ignore
:filter ,(lambda (_) (mouse-menu-major-mode-map))))
(define-key map [mode-line mouse-2] 'describe-mode)
- (define-key map [mode-line down-mouse-3] mode-line-mode-menu)
+ (bindings--define-key map [mode-line down-mouse-3]
+ `(menu-item "Minor Modes" ,mode-line-mode-menu
+ :filter bindings--sort-menu-keymap))
map) "\
Keymap to display on major mode.")
(defvar mode-line-minor-mode-keymap
- (let ((map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap))
+ (mode-menu-binding
+ `(menu-item "Menu Bar" ,mode-line-mode-menu
+ :filter bindings--sort-menu-keymap)))
(define-key map [mode-line down-mouse-1] 'mouse-minor-mode-menu)
(define-key map [mode-line mouse-2] 'mode-line-minor-mode-help)
- (define-key map [mode-line down-mouse-3] mode-line-mode-menu)
- (define-key map [header-line down-mouse-3] mode-line-mode-menu)
+ (define-key map [mode-line down-mouse-3] mode-menu-binding)
+ (define-key map [header-line down-mouse-3] mode-menu-binding)
map) "\
Keymap to display on minor modes.")
@@ -411,6 +438,8 @@ zero, otherwise they start from one."
:type 'boolean
:group 'mode-line
:version "26.1")
+(make-obsolete-variable 'column-number-indicator-zero-based
+ 'mode-line-position-column-format "28.1")
(defcustom mode-line-percent-position '(-3 "%p")
"Specification of \"percentage offset\" of window through buffer.
@@ -431,6 +460,44 @@ displayed in `mode-line-position', a component of the default
:group 'mode-line)
(put 'mode-line-percent-position 'risky-local-variable t)
+(defcustom mode-line-position-line-format '(" L%l")
+ "Format used to display line numbers in the mode line.
+This is used when `line-number-mode' is switched on. The \"%l\"
+format spec will be replaced by the line number.
+
+Also see `mode-line-position-column-line-format'."
+ :type '(list string)
+ :version "28.1"
+ :group 'mode-line)
+
+(defcustom mode-line-position-column-format '(" C%c")
+ "Format used to display column numbers in the mode line.
+This is used when `column-number-mode' is switched on. The
+\"%c\" format spec is replaced by the zero-based column number,
+and \"%C\" is replaced by the one-based column number.
+
+Also see `mode-line-position-column-line-format'."
+ :type '(list string)
+ :version "28.1"
+ :group 'mode-line)
+
+(defcustom mode-line-position-column-line-format '(" (%l,%c)")
+ "Format used to display combined line/column numbers in the mode line.
+This is used when `column-number-mode' and `line-number-mode' are
+switched on. The \"%c\" format spec will be replaced by the
+column number, which is zero-based if
+`column-number-indicator-zero-based' is non-nil, and one-based if
+`column-number-indicator-zero-based' is nil."
+ :type '(list string)
+ :version "28.1"
+ :group 'mode-line)
+
+(defconst mode-line-position--column-line-properties
+ (list 'local-map mode-line-column-line-number-mode-map
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "Line number and Column number\n\
+mouse-1: Display Line and Column Mode Menu"))
+
(defvar mode-line-position
`((:propertize
mode-line-percent-position
@@ -450,38 +517,30 @@ mouse-1: Display Line and Column Mode Menu")))
(line-number-mode
((column-number-mode
(column-number-indicator-zero-based
- (10 ,(propertize
- " (%l,%c)"
- 'local-map mode-line-column-line-number-mode-map
- 'mouse-face 'mode-line-highlight
- 'help-echo "Line number and Column number\n\
-mouse-1: Display Line and Column Mode Menu"))
- (10 ,(propertize
- " (%l,%C)"
- 'local-map mode-line-column-line-number-mode-map
- 'mouse-face 'mode-line-highlight
- 'help-echo "Line number and Column number\n\
-mouse-1: Display Line and Column Mode Menu")))
- (6 ,(propertize
- " L%l"
- 'local-map mode-line-column-line-number-mode-map
- 'mouse-face 'mode-line-highlight
- 'help-echo "Line Number\n\
-mouse-1: Display Line and Column Mode Menu"))))
- ((column-number-mode
- (column-number-indicator-zero-based
- (5 ,(propertize
- " C%c"
- 'local-map mode-line-column-line-number-mode-map
- 'mouse-face 'mode-line-highlight
- 'help-echo "Column number\n\
-mouse-1: Display Line and Column Mode Menu"))
- (5 ,(propertize
- " C%C"
- 'local-map mode-line-column-line-number-mode-map
- 'mouse-face 'mode-line-highlight
- 'help-echo "Column number\n\
-mouse-1: Display Line and Column Mode Menu")))))))
+ (10
+ (:propertize
+ mode-line-position-column-line-format
+ ,@mode-line-position--column-line-properties))
+ (10
+ (:propertize
+ (:eval (string-replace
+ "%c" "%C" (car mode-line-position-column-line-format)))
+ ,@mode-line-position--column-line-properties)))
+ (6
+ (:propertize
+ mode-line-position-line-format
+ ,@mode-line-position--column-line-properties))))
+ (column-number-mode
+ (column-number-indicator-zero-based
+ (6
+ (:propertize
+ mode-line-position-column-format
+ (,@mode-line-position--column-line-properties)))
+ (6
+ (:propertize
+ (:eval (string-replace
+ "%c" "%C" (car mode-line-position-column-format)))
+ ,@mode-line-position--column-line-properties))))))
"Mode line construct for displaying the position in the buffer.
Normally displays the buffer percentage and, optionally, the
buffer size, the line number and the column number.")
@@ -514,7 +573,7 @@ mouse-1: Previous buffer\nmouse-3: Next buffer")
'mouse-face 'mode-line-highlight
'local-map mode-line-buffer-identification-keymap)))
-(defvar mode-line-buffer-identification
+(defvar-local mode-line-buffer-identification
(propertized-buffer-identification "%12b")
"Mode line construct for identifying the buffer being displayed.
Its default value is (\"%12b\") with some text properties added.
@@ -522,10 +581,9 @@ Major modes that edit things other than ordinary files may change this
\(e.g. Info, Dired,...)")
;;;###autoload
(put 'mode-line-buffer-identification 'risky-local-variable t)
-(make-variable-buffer-local 'mode-line-buffer-identification)
(defvar mode-line-misc-info
- '((global-mode-string ("" global-mode-string " ")))
+ '((global-mode-string ("" global-mode-string)))
"Mode line construct for miscellaneous information.
By default, this shows the information specified by `global-mode-string'.")
(put 'mode-line-misc-info 'risky-local-variable t)
@@ -586,7 +644,9 @@ Switch to the most recently selected buffer other than the current one."
(previous-buffer)))
(defmacro bound-and-true-p (var)
- "Return the value of symbol VAR if it is bound, else nil."
+ "Return the value of symbol VAR if it is bound, else nil.
+Note that if `lexical-binding' is in effect, this function isn't
+meaningful if it refers to a lexically bound variable."
`(and (boundp (quote ,var)) ,var))
;; Use mode-line-mode-menu for local minor-modes only.
@@ -827,7 +887,7 @@ in contrast with \\[forward-char] and \\[backward-char], which
see."
(interactive "^p")
(if visual-order-cursor-movement
- (dotimes (i (if (numberp n) (abs n) 1))
+ (dotimes (_ (if (numberp n) (abs n) 1))
(move-point-visually (if (and (numberp n) (< n 0)) -1 1)))
(if (eq (current-bidi-paragraph-direction) 'left-to-right)
(forward-char n)
@@ -845,7 +905,7 @@ in contrast with \\[forward-char] and \\[backward-char], which
see."
(interactive "^p")
(if visual-order-cursor-movement
- (dotimes (i (if (numberp n) (abs n) 1))
+ (dotimes (_ (if (numberp n) (abs n) 1))
(move-point-visually (if (and (numberp n) (< n 0)) 1 -1)))
(if (eq (current-bidi-paragraph-direction) 'left-to-right)
(backward-char n)
@@ -889,6 +949,7 @@ if `inhibit-field-text-motion' is non-nil."
(define-key narrow-map "n" 'narrow-to-region)
(define-key narrow-map "w" 'widen)
+(define-key narrow-map "g" 'goto-line-relative)
;; Quitting
(define-key global-map "\e\e\e" 'keyboard-escape-quit)
@@ -925,6 +986,12 @@ if `inhibit-field-text-motion' is non-nil."
;; Richard said that we should not use C-x <uppercase letter> and I have
;; no idea whereas to bind it. Any suggestion welcome. -stef
;; (define-key ctl-x-map "U" 'undo-only)
+(defvar undo-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "u" 'undo)
+ map)
+ "Keymap to repeat undo key sequences `C-x u u'. Used in `repeat-mode'.")
+(put 'undo 'repeat-map 'undo-repeat-map)
(define-key esc-map "!" 'shell-command)
(define-key esc-map "|" 'shell-command-on-region)
@@ -1011,6 +1078,17 @@ if `inhibit-field-text-motion' is non-nil."
(define-key ctl-x-map "`" 'next-error)
+(defvar next-error-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "n" 'next-error)
+ (define-key map "\M-n" 'next-error)
+ (define-key map "p" 'previous-error)
+ (define-key map "\M-p" 'previous-error)
+ map)
+ "Keymap to repeat next-error key sequences. Used in `repeat-mode'.")
+(put 'next-error 'repeat-map 'next-error-repeat-map)
+(put 'previous-error 'repeat-map 'next-error-repeat-map)
+
(defvar goto-map (make-sparse-keymap)
"Keymap for navigation commands.")
(define-key esc-map "g" goto-map)
@@ -1169,7 +1247,7 @@ if `inhibit-field-text-motion' is non-nil."
;; (define-key global-map [kp-9] 'function-key-error)
;; (define-key global-map [kp-equal] 'function-key-error)
-;; X11R6 distinguishes these keys from the non-kp keys.
+;; X11 distinguishes these keys from the non-kp keys.
;; Make them behave like the non-kp keys unless otherwise bound.
;; FIXME: rather than list such mappings for every modifier-combination,
;; we should come up with a way to do it generically, something like
@@ -1383,8 +1461,24 @@ if `inhibit-field-text-motion' is non-nil."
(define-key ctl-x-map "'" 'expand-abbrev)
(define-key ctl-x-map "\C-b" 'list-buffers)
+(define-key ctl-x-map "\C-j" 'dired-jump)
+(define-key ctl-x-4-map "\C-j" 'dired-jump-other-window)
+
(define-key ctl-x-map "z" 'repeat)
+(defvar ctl-x-x-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "f" #'font-lock-update)
+ (define-key map "g" #'revert-buffer)
+ (define-key map "r" #'rename-buffer)
+ (define-key map "u" #'rename-uniquely)
+ (define-key map "n" #'clone-buffer)
+ (define-key map "i" #'insert-buffer)
+ (define-key map "t" #'toggle-truncate-lines)
+ map)
+ "Keymap for subcommands of C-x x.")
+(define-key ctl-x-map "x" ctl-x-x-map)
+
(define-key esc-map "\C-l" 'reposition-window)
(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index cc5995d8040..ff9b8ab1388 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -26,12 +26,14 @@
;; This package is for setting "bookmarks" in files. A bookmark
;; associates a string with a location in a certain file. Thus, you
;; can navigate your way to that location by providing the string.
-;; See the "User Variables" section for customizations.
+;;
+;; Type `M-x customize-group RET boomark RET' for user options.
;;; Code:
(require 'pp)
+(require 'tabulated-list)
(require 'text-property-search)
(eval-when-compile (require 'cl-lib))
@@ -119,6 +121,12 @@ recently set ones come first, oldest ones come last)."
:type 'boolean)
+(defcustom bookmark-menu-confirm-deletion nil
+ "Non-nil means confirm before deleting bookmarks in a bookmark menu buffer.
+Nil means don't prompt for confirmation."
+ :version "28.1"
+ :type 'boolean)
+
(defcustom bookmark-automatically-show-annotations t
"Non-nil means show annotations when jumping to a bookmark."
:type 'boolean)
@@ -126,16 +134,16 @@ recently set ones come first, oldest ones come last)."
(defconst bookmark-bmenu-buffer "*Bookmark List*"
"Name of buffer used for Bookmark List.")
-(defcustom bookmark-bmenu-use-header-line t
+(defvar bookmark-bmenu-use-header-line t
"Non-nil means to use an immovable header line.
-This is as opposed to inline text at the top of the buffer."
- :version "24.4"
- :type 'boolean)
+This is as opposed to inline text at the top of the buffer.")
+(make-obsolete-variable 'bookmark-bmenu-use-header-line "no longer used." "28.1")
(defconst bookmark-bmenu-inline-header-height 2
"Number of lines used for the *Bookmark List* header.
\(This is only significant when `bookmark-bmenu-use-header-line'
is nil.)")
+(make-obsolete-variable 'bookmark-bmenu-inline-header-height "no longer used." "28.1")
(defconst bookmark-bmenu-marks-width 2
"Number of columns (chars) used for the *Bookmark List* marks column.
@@ -165,11 +173,34 @@ A non-nil value may result in truncated bookmark names."
"Time before `bookmark-bmenu-search' updates the display."
:type 'number)
+(defcustom bookmark-fontify t
+ "Whether to colorize a bookmarked line.
+If non-nil, setting a bookmark will colorize the current line with
+`bookmark-face'."
+ :type 'boolean
+ :version "28.1")
+
+;; FIXME: No longer used. Should be declared obsolete or removed.
(defface bookmark-menu-heading
'((t (:inherit font-lock-type-face)))
"Face used to highlight the heading in bookmark menu buffers."
:version "22.1")
+(defface bookmark-face
+ '((((class grayscale)
+ (background light))
+ :background "DimGray")
+ (((class grayscale)
+ (background dark))
+ :background "LightGray")
+ (((class color)
+ (background light))
+ :foreground "White" :background "DarkOrange1")
+ (((class color)
+ (background dark))
+ :foreground "Black" :background "DarkOrange1"))
+ "Face used to highlight current line."
+ :version "28.1")
;;; No user-serviceable parts beyond this point.
@@ -200,6 +231,7 @@ A non-nil value may result in truncated bookmark names."
(define-key map "f" 'bookmark-insert-location) ;"f"ind
(define-key map "r" 'bookmark-rename)
(define-key map "d" 'bookmark-delete)
+ (define-key map "D" 'bookmark-delete-all)
(define-key map "l" 'bookmark-load)
(define-key map "w" 'bookmark-write)
(define-key map "s" 'bookmark-save)
@@ -267,13 +299,11 @@ defaults to `bookmark-default-file' and MODTIME is its modification time.")
(defvar bookmark-file-coding-system nil
"The coding-system of the last loaded or saved bookmark file.")
-(defvar bookmark-current-bookmark nil
+(defvar-local bookmark-current-bookmark nil
"Name of bookmark most recently used in the current file.
It is buffer local, used to make moving a bookmark forward
through a file easier.")
-(make-variable-buffer-local 'bookmark-current-bookmark)
-
(defvar bookmark-alist-modification-count 0
"Number of modifications to bookmark list since it was last saved.")
@@ -425,6 +455,30 @@ In other words, return all information but the name."
(defvar bookmark-history nil
"The history list for bookmark functions.")
+(defun bookmark--fontify ()
+ "Apply a colorized overlay to the bookmarked location.
+See user option `bookmark-fontify'."
+ (let ((bm (make-overlay (point-at-bol)
+ (min (point-max) (1+ (point-at-eol))))))
+ (overlay-put bm 'category 'bookmark)
+ (overlay-put bm 'face 'bookmark-face)))
+
+(defun bookmark--unfontify (bm)
+ "Remove a bookmark's colorized overlay.
+BM is a bookmark as returned from function `bookmark-get-bookmark'.
+See user option `bookmark-fontify'."
+ (let ((filename (cdr (assq 'filename bm)))
+ (pos (cdr (assq 'position bm)))
+ overlays found temp)
+ (when (and pos filename)
+ (setq filename (expand-file-name filename))
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (equal filename buffer-file-name)
+ (setq overlays (overlays-at pos))
+ (while (and (not found) (setq temp (pop overlays)))
+ (when (eq 'bookmark (overlay-get temp 'category))
+ (delete-overlay (setq found temp))))))))))
(defun bookmark-completing-read (prompt &optional default)
"Prompting with PROMPT, read a bookmark name in completion.
@@ -507,10 +561,14 @@ old one."
(set-text-properties 0 (length stripped-name) nil stripped-name)
(if (and (not no-overwrite)
(bookmark-get-bookmark stripped-name 'noerror))
- ;; already existing bookmark under that name and
- ;; no prefix arg means just overwrite old bookmark
- ;; Use the new (NAME . ALIST) format.
- (setcdr (bookmark-get-bookmark stripped-name) alist)
+ ;; Already existing bookmark under that name and
+ ;; no prefix arg means just overwrite old bookmark.
+ (let ((bm (bookmark-get-bookmark stripped-name)))
+ ;; First clean up if previously location was fontified.
+ (when bookmark-fontify
+ (bookmark--unfontify bm))
+ ;; Modify using the new (NAME . ALIST) format.
+ (setcdr bm alist))
;; otherwise just cons it onto the front (either the bookmark
;; doesn't exist already, or there is no prefix arg. In either
@@ -734,8 +792,10 @@ CODING is the symbol of the coding-system in which the file is encoded."
(if (memq (coding-system-base coding) '(undecided prefer-utf-8))
(setq coding 'utf-8-emacs))
(insert
- (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*-\n"
- bookmark-file-format-version (coding-system-base coding)))
+ (format
+ ";;;; Emacs Bookmark Format Version %d\
+;;;; -*- coding: %S; mode: lisp-data -*-\n"
+ bookmark-file-format-version (coding-system-base coding)))
(insert ";;; This format is meant to be slightly human-readable;\n"
";;; nevertheless, you probably don't want to edit it.\n"
";;; "
@@ -800,7 +860,7 @@ still there, in order, if the topmost one is ever deleted."
(let ((str
(or name
(read-from-minibuffer
- (format "%s (default %s): " prompt default)
+ (format-prompt prompt default)
nil
bookmark-minibuffer-read-name-map
nil nil defaults))))
@@ -821,7 +881,9 @@ still there, in order, if the topmost one is ever deleted."
;; Ask for an annotation buffer for this bookmark
(when bookmark-use-annotations
- (bookmark-edit-annotation str))))
+ (bookmark-edit-annotation str))
+ (when bookmark-fontify
+ (bookmark--fontify))))
(setq bookmark-yank-point nil)
(setq bookmark-current-buffer nil)))
@@ -897,13 +959,11 @@ Does not affect the kill ring."
(when (and newline-too (= (following-char) ?\n))
(delete-char 1))))
-(defvar bookmark-annotation-name nil
+(defvar-local bookmark-annotation-name nil
"Name of bookmark under edit in `bookmark-edit-annotation-mode'.")
-(make-variable-buffer-local 'bookmark-annotation-name)
-(defvar bookmark--annotation-from-bookmark-list nil
+(defvar-local bookmark--annotation-from-bookmark-list nil
"If non-nil, `bookmark-edit-annotation-mode' should return to bookmark list.")
-(make-variable-buffer-local 'bookmark--annotation-from-bookmark-list)
(defun bookmark-default-annotation-text (bookmark-name)
"Return default annotation text for BOOKMARK-NAME.
@@ -920,8 +980,6 @@ annotations."
"# Date: " (current-time-string) "\n"))
-(define-obsolete-variable-alias 'bookmark-read-annotation-text-func
- 'bookmark-edit-annotation-text-func "23.1")
(defvar bookmark-edit-annotation-text-func 'bookmark-default-annotation-text
"Function to return default text to use for a bookmark annotation.
It takes one argument, the name of the bookmark, as a string.")
@@ -953,7 +1011,7 @@ When you have finished composing, type \\[bookmark-send-edited-annotation].
(defun bookmark-send-edited-annotation ()
"Use buffer contents as annotation for a bookmark.
Lines beginning with `#' are ignored."
- (interactive)
+ (interactive nil bookmark-edit-annotation-mode)
(if (not (derived-mode-p 'bookmark-edit-annotation-mode))
(error "Not in bookmark-edit-annotation-mode"))
(goto-char (point-min))
@@ -975,7 +1033,7 @@ Lines beginning with `#' are ignored."
(when from-bookmark-list
(pop-to-buffer (get-buffer bookmark-bmenu-buffer))
(goto-char (point-min))
- (text-property-search-forward 'bookmark-name-prop bookmark-name))
+ (bookmark-bmenu-bookmark))
(kill-buffer old-buffer)))
@@ -1040,6 +1098,14 @@ it to the name of the bookmark currently being set, advancing
(car dired-directory)))
(t (error "Buffer not visiting a file or directory")))))
+(defvar bookmark--watch-already-asked-mtime nil
+ "Mtime for which we already queried about reloading.")
+
+(defun bookmark--watch-file-already-queried-p (new-mtime)
+ ;; Don't ask repeatedly if user already said "no" to reloading a
+ ;; file with this mtime:
+ (prog1 (equal new-mtime bookmark--watch-already-asked-mtime)
+ (setq bookmark--watch-already-asked-mtime new-mtime)))
(defun bookmark-maybe-load-default-file ()
"If bookmarks have not been loaded from the default place, load them."
@@ -1048,13 +1114,15 @@ it to the name of the bookmark currently being set, advancing
(file-readable-p bookmark-default-file)
(bookmark-load bookmark-default-file t t)))
((and bookmark-watch-bookmark-file
- (not (equal (nth 5 (file-attributes
- (car bookmark-bookmarks-timestamp)))
- (cdr bookmark-bookmarks-timestamp)))
- (or (eq 'silent bookmark-watch-bookmark-file)
- (yes-or-no-p
- (format "Bookmarks %s changed on disk. Reload? "
- (car bookmark-bookmarks-timestamp)))))
+ (let ((new-mtime (nth 5 (file-attributes
+ (car bookmark-bookmarks-timestamp))))
+ (old-mtime (cdr bookmark-bookmarks-timestamp)))
+ (and (not (equal new-mtime old-mtime))
+ (not (bookmark--watch-file-already-queried-p new-mtime))
+ (or (eq 'silent bookmark-watch-bookmark-file)
+ (yes-or-no-p
+ (format "Bookmarks %s changed on disk. Reload? "
+ (car bookmark-bookmarks-timestamp)))))))
(bookmark-load (car bookmark-bookmarks-timestamp) t t))))
(defun bookmark-maybe-sort-alist ()
@@ -1062,8 +1130,7 @@ it to the name of the bookmark currently being set, advancing
If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist."
(if bookmark-sort-flag
(sort (copy-alist bookmark-alist)
- (function
- (lambda (x y) (string-lessp (car x) (car y)))))
+ (lambda (x y) (string-lessp (car x) (car y))))
bookmark-alist))
@@ -1085,6 +1152,14 @@ and then show any annotations for this bookmark."
(if win (set-window-point win (point))))
;; FIXME: we used to only run bookmark-after-jump-hook in
;; `bookmark-jump' itself, but in none of the other commands.
+ (when bookmark-fontify
+ (let ((overlays (overlays-at (point)))
+ temp found)
+ (while (and (not found) (setq temp (pop overlays)))
+ (when (eq 'bookmark (overlay-get temp 'category))
+ (setq found t)))
+ (unless found
+ (bookmark--fontify))))
(run-hooks 'bookmark-after-jump-hook)
(if bookmark-automatically-show-annotations
;; if there is an annotation for this bookmark,
@@ -1140,17 +1215,6 @@ DISPLAY-FUNC would be `switch-to-buffer-other-window'."
(let ((pop-up-frames t))
(bookmark-jump-other-window bookmark)))
-(defun bookmark-jump-noselect (bookmark)
- "Return the location pointed to by BOOKMARK (see `bookmark-jump').
-The return value has the form (BUFFER . POINT).
-
-Note: this function is deprecated and is present for Emacs 22
-compatibility only."
- (declare (obsolete bookmark-handle-bookmark "23.1"))
- (save-excursion
- (bookmark-handle-bookmark bookmark)
- (cons (current-buffer) (point))))
-
(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,
@@ -1359,6 +1423,7 @@ probably because we were called from there."
(bookmark-maybe-historicize-string bookmark-name)
(bookmark-maybe-load-default-file)
(let ((will-go (bookmark-get-bookmark bookmark-name 'noerror)))
+ (bookmark--unfontify will-go)
(setq bookmark-alist (delq will-go bookmark-alist))
;; Added by db, nil bookmark-current-bookmark if the last
;; occurrence has been deleted
@@ -1372,6 +1437,30 @@ probably because we were called from there."
(bookmark-save)))
+;;;###autoload
+(defun bookmark-delete-all (&optional no-confirm)
+ "Permanently delete all bookmarks.
+If optional argument NO-CONFIRM is non-nil, don't ask for
+confirmation."
+ (interactive "P")
+ ;; We don't use `bookmark-menu-confirm-deletion' here because that
+ ;; variable is specifically to control confirmation prompting in a
+ ;; bookmark menu buffer, where the user has the marked-for-deletion
+ ;; bookmarks arrayed in front of them and might have accidentally
+ ;; hit the key that executes the deletions. The UI situation here
+ ;; is quite different, by contrast: the user got to this point by a
+ ;; sequence of keystrokes unlikely to be typed by chance.
+ (when (or no-confirm
+ (yes-or-no-p "Permanently delete all bookmarks? "))
+ (bookmark-maybe-load-default-file)
+ (setq bookmark-alist-modification-count
+ (+ bookmark-alist-modification-count (length bookmark-alist)))
+ (setq bookmark-alist nil)
+ (bookmark-bmenu-surreptitiously-rebuild-list)
+ (when (bookmark-time-to-save-p)
+ (bookmark-save))))
+
+
(defun bookmark-time-to-save-p (&optional final-time)
"Return t if it is time to save bookmarks to disk, nil otherwise.
Optional argument FINAL-TIME means this is being called when Emacs
@@ -1605,7 +1694,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
(defvar bookmark-bmenu-mode-map
(let ((map (make-keymap)))
- (set-keymap-parent map special-mode-map)
+ (set-keymap-parent map tabulated-list-mode-map)
(define-key map "v" 'bookmark-bmenu-select)
(define-key map "w" 'bookmark-bmenu-locate)
(define-key map "5" 'bookmark-bmenu-other-frame)
@@ -1623,12 +1712,13 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
(define-key map "\C-d" 'bookmark-bmenu-delete-backwards)
(define-key map "x" 'bookmark-bmenu-execute-deletions)
(define-key map "d" 'bookmark-bmenu-delete)
+ (define-key map "D" 'bookmark-bmenu-delete-all)
(define-key map " " 'next-line)
- (define-key map "n" 'next-line)
- (define-key map "p" 'previous-line)
(define-key map "\177" 'bookmark-bmenu-backup-unmark)
(define-key map "u" 'bookmark-bmenu-unmark)
+ (define-key map "U" 'bookmark-bmenu-unmark-all)
(define-key map "m" 'bookmark-bmenu-mark)
+ (define-key map "M" 'bookmark-bmenu-mark-all)
(define-key map "l" 'bookmark-bmenu-load)
(define-key map "r" 'bookmark-bmenu-rename)
(define-key map "R" 'bookmark-bmenu-relocate)
@@ -1650,8 +1740,10 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
["Select Marked Bookmarks" bookmark-bmenu-select t]
"---"
["Mark Bookmark" bookmark-bmenu-mark t]
+ ["Mark all Bookmarks" bookmark-bmenu-mark-all t]
["Unmark Bookmark" bookmark-bmenu-unmark t]
["Unmark Backwards" bookmark-bmenu-backup-unmark t]
+ ["Unmark all Bookmarks" bookmark-bmenu-unmark-all t]
["Toggle Display of Filenames" bookmark-bmenu-toggle-filenames t]
["Display Location of Bookmark" bookmark-bmenu-locate t]
"---"
@@ -1659,6 +1751,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc."
["Rename Bookmark" bookmark-bmenu-rename t]
["Relocate Bookmark's File" bookmark-bmenu-relocate t]
["Mark Bookmark for Deletion" bookmark-bmenu-delete t]
+ ["Mark all Bookmarks for Deletion" bookmark-bmenu-delete-all t]
["Delete Marked Bookmarks" bookmark-bmenu-execute-deletions t])
("Annotations"
["Show Annotation for Current Bookmark" bookmark-bmenu-show-annotation t]
@@ -1688,6 +1781,43 @@ Don't affect the buffer ring order."
(save-window-excursion
(bookmark-bmenu-list)))))
+(defun bookmark-bmenu--revert ()
+ "Re-populate `tabulated-list-entries'."
+ (let (entries)
+ (dolist (full-record (bookmark-maybe-sort-alist))
+ (let* ((name (bookmark-name-from-full-record full-record))
+ (annotation (bookmark-get-annotation full-record))
+ (location (bookmark-location full-record)))
+ (push (list
+ full-record
+ `[,(if (and annotation (not (string-equal annotation "")))
+ "*" "")
+ ,(if (display-mouse-p)
+ (propertize name
+ 'font-lock-face 'bookmark-menu-bookmark
+ 'mouse-face 'highlight
+ 'follow-link t
+ 'help-echo "mouse-2: go to this bookmark in other window")
+ name)
+ ,@(if bookmark-bmenu-toggle-filenames
+ (list location))])
+ entries)))
+ (tabulated-list-init-header)
+ (setq tabulated-list-entries entries))
+ (tabulated-list-print t))
+
+;;;###autoload
+(defun bookmark-bmenu-get-buffer ()
+ "Return the Bookmark List, building it if it doesn't exists.
+Don't affect the buffer ring order."
+ (or (get-buffer bookmark-bmenu-buffer)
+ (save-excursion
+ (save-window-excursion
+ (bookmark-bmenu-list)
+ (get-buffer bookmark-bmenu-buffer)))))
+
+(custom-add-choice 'tab-bar-new-tab-choice
+ '(const :tag "Bookmark List" bookmark-bmenu-get-buffer))
;;;###autoload
(defun bookmark-bmenu-list ()
@@ -1701,76 +1831,25 @@ deletion, or > if it is flagged for displaying."
(if (called-interactively-p 'interactive)
(switch-to-buffer buf)
(set-buffer buf)))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (if (not bookmark-bmenu-use-header-line)
- (insert "% Bookmark\n- --------\n"))
- (add-text-properties (point-min) (point)
- '(font-lock-face bookmark-menu-heading))
- (dolist (full-record (bookmark-maybe-sort-alist))
- (let ((name (bookmark-name-from-full-record full-record))
- (annotation (bookmark-get-annotation full-record))
- (start (point))
- end)
- ;; if a bookmark has an annotation, prepend a "*"
- ;; in the list of bookmarks.
- (insert (if (and annotation (not (string-equal annotation "")))
- " *" " ")
- name)
- (setq end (point))
- (put-text-property
- (+ bookmark-bmenu-marks-width start) end 'bookmark-name-prop name)
- (when (display-mouse-p)
- (add-text-properties
- (+ bookmark-bmenu-marks-width start) end
- '(font-lock-face bookmark-menu-bookmark
- mouse-face highlight
- follow-link t
- help-echo "mouse-2: go to this bookmark in other window")))
- (insert "\n")))
- (set-buffer-modified-p (not (= bookmark-alist-modification-count 0)))
- (goto-char (point-min))
- (bookmark-bmenu-mode)
- (if bookmark-bmenu-use-header-line
- (bookmark-bmenu-set-header)
- (forward-line bookmark-bmenu-inline-header-height))
- (when (and bookmark-alist bookmark-bmenu-toggle-filenames)
- (bookmark-bmenu-toggle-filenames t))))
+ (bookmark-bmenu-mode)
+ (bookmark-bmenu--revert))
;;;###autoload
(defalias 'list-bookmarks 'bookmark-bmenu-list)
;;;###autoload
(defalias 'edit-bookmarks 'bookmark-bmenu-list)
-;; FIXME: This could also display the current default bookmark file
-;; according to `bookmark-bookmarks-timestamp'.
-(defun bookmark-bmenu-set-header ()
- "Set the immutable header line."
- (let ((header (concat "%% " "Bookmark")))
- (when bookmark-bmenu-toggle-filenames
- (setq header (concat header
- (make-string (- bookmark-bmenu-file-column
- (- (length header) 3)) ?\s)
- "File")))
- (let ((pos 0))
- (while (string-match "[ \t\n]+" header pos)
- (setq pos (match-end 0))
- (put-text-property (match-beginning 0) pos 'display
- (list 'space :align-to (- pos 1))
- header)))
- (put-text-property 0 2 'face 'fixed-pitch header)
- (setq header (concat (propertize " " 'display '(space :align-to 0))
- header))
- ;; Code derived from `buff-menu.el'.
- (setq header-line-format header)))
-
-(define-derived-mode bookmark-bmenu-mode special-mode "Bookmark Menu"
+(define-obsolete-function-alias 'bookmark-bmenu-set-header
+ #'tabulated-list-init-header "28.1")
+
+(define-derived-mode bookmark-bmenu-mode tabulated-list-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.
Bookmark names preceded by a \"*\" have annotations.
\\<bookmark-bmenu-mode-map>
\\[bookmark-bmenu-mark] -- mark bookmark to be displayed.
+\\[bookmark-bmenu-mark-all] -- mark all listed bookmarks to be displayed.
\\[bookmark-bmenu-select] -- select bookmark of line point is on.
Also show bookmarks marked using m in other windows.
\\[bookmark-bmenu-toggle-filenames] -- toggle displaying of filenames (they may obscure long bookmark names).
@@ -1787,122 +1866,90 @@ Bookmark names preceded by a \"*\" have annotations.
\\[bookmark-bmenu-relocate] -- relocate this bookmark's file (prompts for new file).
\\[bookmark-bmenu-delete] -- mark this bookmark to be deleted, and move down.
\\[bookmark-bmenu-delete-backwards] -- mark this bookmark to be deleted, and move up.
-\\[bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[bookmark-bmenu-delete]'.
+\\[bookmark-bmenu-delete-all] -- mark all listed bookmarks as to be deleted.
+\\[bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[bookmark-bmenu-delete]' or `\\[bookmark-bmenu-delete-all]'.
\\[bookmark-bmenu-save] -- save the current bookmark list in the default file.
With a prefix arg, prompts for a file to save in.
\\[bookmark-bmenu-load] -- load in a file of bookmarks (prompts for file.)
\\[bookmark-bmenu-unmark] -- remove all kinds of marks from current line.
With prefix argument, also move up one line.
\\[bookmark-bmenu-backup-unmark] -- back up a line and remove marks.
+\\[bookmark-bmenu-unmark-all] -- remove all kinds of marks from all listed bookmarks.
\\[bookmark-bmenu-show-annotation] -- show the annotation, if it exists, for the current bookmark
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.
\\[bookmark-bmenu-search] -- incrementally search for bookmarks."
(setq truncate-lines t)
- (setq buffer-read-only t))
+ (setq buffer-read-only t)
+ ;; FIXME: The header could also display the current default bookmark file
+ ;; according to `bookmark-bookmarks-timestamp'.
+ (setq tabulated-list-format
+ `[("" 1) ;; Space to add "*" for bookmark with annotation
+ ("Bookmark" ,bookmark-bmenu-file-column bookmark-bmenu--name-predicate)
+ ,@(if bookmark-bmenu-toggle-filenames
+ '(("File" 0 bookmark-bmenu--file-predicate)))])
+ (setq tabulated-list-padding bookmark-bmenu-marks-width)
+ (setq tabulated-list-sort-key '("Bookmark" . nil))
+ (add-hook 'tabulated-list-revert-hook #'bookmark-bmenu--revert nil t)'
+ (setq revert-buffer-function 'bookmark-bmenu--revert)
+ (tabulated-list-init-header))
+
+
+(defun bookmark-bmenu--name-predicate (a b)
+ "Predicate to sort \"*Bookmark List*\" buffer by the name column.
+This is used for `tabulated-list-format' in `bookmark-bmenu-mode'."
+ (string< (caar a) (caar b)))
+
+
+(defun bookmark-bmenu--file-predicate (a b)
+ "Predicate to sort \"*Bookmark List*\" buffer by the file column.
+This is used for `tabulated-list-format' in `bookmark-bmenu-mode'."
+ (string< (bookmark-location (car a)) (bookmark-location (car b))))
(defun bookmark-bmenu-toggle-filenames (&optional show)
"Toggle whether filenames are shown in the bookmark list.
Optional argument SHOW means show them unconditionally."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(cond
(show
- (setq bookmark-bmenu-toggle-filenames nil)
- (bookmark-bmenu-show-filenames)
(setq bookmark-bmenu-toggle-filenames t))
(bookmark-bmenu-toggle-filenames
- (bookmark-bmenu-hide-filenames)
(setq bookmark-bmenu-toggle-filenames nil))
(t
- (bookmark-bmenu-show-filenames)
(setq bookmark-bmenu-toggle-filenames t)))
- (when bookmark-bmenu-use-header-line
- (bookmark-bmenu-set-header)))
-
-
-(defun bookmark-bmenu-show-filenames (&optional force)
- "In an interactive bookmark list, show filenames along with bookmarks.
-Non-nil FORCE forces a redisplay showing the filenames. FORCE is used
-mainly for debugging, and should not be necessary in normal use."
- (if (and (not force) bookmark-bmenu-toggle-filenames)
- nil ;already shown, so do nothing
- (with-buffer-modified-unmodified
- (save-excursion
- (save-window-excursion
- (goto-char (point-min))
- (if (not bookmark-bmenu-use-header-line)
- (forward-line bookmark-bmenu-inline-header-height))
- (setq bookmark-bmenu-hidden-bookmarks ())
- (let ((inhibit-read-only t))
- (while (< (point) (point-max))
- (let ((bmrk (bookmark-bmenu-bookmark)))
- (push bmrk bookmark-bmenu-hidden-bookmarks)
- (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)
- (remove-text-properties start (point)
- '(mouse-face nil help-echo nil))))
- (delete-region (point) (progn (end-of-line) (point)))
- (insert " ")
- ;; Pass the NO-HISTORY arg:
- (bookmark-insert-location bmrk t)
- (forward-line 1)))))))))
-
-
-(defun bookmark-bmenu-hide-filenames (&optional force)
- "In an interactive bookmark list, hide the filenames of the bookmarks.
-Non-nil FORCE forces a redisplay showing the filenames. FORCE is used
-mainly for debugging, and should not be necessary in normal use."
- (when (and (not force) bookmark-bmenu-toggle-filenames)
- ;; nothing to hide if above is nil
- (with-buffer-modified-unmodified
- (save-excursion
- (goto-char (point-min))
- (if (not bookmark-bmenu-use-header-line)
- (forward-line bookmark-bmenu-inline-header-height))
- (setq bookmark-bmenu-hidden-bookmarks
- (nreverse bookmark-bmenu-hidden-bookmarks))
- (let ((inhibit-read-only t))
- (while bookmark-bmenu-hidden-bookmarks
- (move-to-column bookmark-bmenu-marks-width t)
- (bookmark-kill-line)
- (let ((name (pop bookmark-bmenu-hidden-bookmarks))
- (start (point)))
- (insert name)
- (put-text-property start (point) 'bookmark-name-prop name)
- (if (display-mouse-p)
- (add-text-properties
- start (point)
- '(font-lock-face bookmark-menu-bookmark
- mouse-face highlight
- follow-link t help-echo
- "mouse-2: go to this bookmark in other window"))))
- (forward-line 1)))))))
+ (bookmark-bmenu-surreptitiously-rebuild-list))
+
+
+(defun bookmark-bmenu-show-filenames (&optional _)
+ "In an interactive bookmark list, show filenames along with bookmarks."
+ (setq bookmark-bmenu-toggle-filenames t)
+ (bookmark-bmenu-surreptitiously-rebuild-list))
+
+
+(defun bookmark-bmenu-hide-filenames (&optional _)
+ "In an interactive bookmark list, hide the filenames of the bookmarks."
+ (setq bookmark-bmenu-toggle-filenames nil)
+ (bookmark-bmenu-surreptitiously-rebuild-list))
(defun bookmark-bmenu-ensure-position ()
"If point is not on a bookmark line, move it to one.
-If before the first bookmark line, move to the first; if after the
-last full line, move to the last full line. The return value is undefined."
- (cond ((and (not bookmark-bmenu-use-header-line)
- (< (count-lines (point-min) (point))
- bookmark-bmenu-inline-header-height))
- (goto-char (point-min))
- (forward-line bookmark-bmenu-inline-header-height))
- ((and (bolp) (eobp))
+If after the last full line, move to the last full line. The
+return value is undefined."
+ (cond ((and (bolp) (eobp))
(beginning-of-line 0))))
(defun bookmark-bmenu-bookmark ()
"Return the bookmark for this line in an interactive bookmark list buffer."
(bookmark-bmenu-ensure-position)
- (save-excursion
- (beginning-of-line)
- (forward-char bookmark-bmenu-marks-width)
- (get-text-property (point) 'bookmark-name-prop)))
+ (let* ((id (tabulated-list-get-id))
+ (entry (and id (assoc id tabulated-list-entries))))
+ (if entry
+ (caar entry)
+ "")))
(defun bookmark-show-annotation (bookmark-name-or-record)
@@ -1949,21 +1996,25 @@ If the annotation does not exist, do nothing."
(defun bookmark-bmenu-mark ()
"Mark bookmark on this line to be displayed by \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-select]."
- (interactive)
- (beginning-of-line)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-bmenu-ensure-position)
- (with-buffer-modified-unmodified
- (let ((inhibit-read-only t))
- (delete-char 1)
- (insert ?>)
- (forward-line 1)
- (bookmark-bmenu-ensure-position))))
+ (tabulated-list-put-tag ">" t))
+
+
+(defun bookmark-bmenu-mark-all ()
+ "Mark all listed bookmarks to be displayed by \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-select]."
+ (interactive nil bookmark-bmenu-mode)
+ (save-excursion
+ (goto-char (point-min))
+ (bookmark-bmenu-ensure-position)
+ (while (not (eobp))
+ (tabulated-list-put-tag ">" t))))
(defun bookmark-bmenu-select ()
"Select this line's bookmark; also display bookmarks marked with `>'.
-You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark] command."
- (interactive)
+You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark] or \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark-all] commands."
+ (interactive nil bookmark-bmenu-mode)
(let ((bmrk (bookmark-bmenu-bookmark))
(menu (current-buffer))
(others ())
@@ -2007,8 +2058,11 @@ You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mar
(defun bookmark-bmenu-save ()
"Save the current list into a bookmark file.
-With a prefix arg, prompts for a file to save them in."
- (interactive)
+With a prefix arg, prompts for a file to save them in.
+
+See also the related behaviors of `bookmark-load' and
+`bookmark-bmenu-load'."
+ (interactive nil bookmark-bmenu-mode)
(save-excursion
(save-window-excursion
(call-interactively 'bookmark-save)
@@ -2016,8 +2070,20 @@ With a prefix arg, prompts for a file to save them in."
(defun bookmark-bmenu-load ()
- "Load the bookmark file and rebuild the bookmark menu-buffer."
- (interactive)
+ "Load bookmarks from a file and rebuild the bookmark menu-buffer.
+Prompt for a file, with the default choice being the value of
+`bookmark-default-file'.
+
+With a prefix argument, replace the current ambient bookmarks
+(i.e., the ones in `bookmark-alist') with the ones from the selected
+file and make that file be the new value of `bookmark-default-file'.
+In other words, a prefix argument means \"switch over to the bookmark
+universe defined in the loaded file\". Without a prefix argument,
+just add the loaded bookmarks into the current ambient set.
+
+See the documentation for `bookmark-load' for more details; see also
+the related behaviors of `bookmark-save' and `bookmark-bmenu-save'."
+ (interactive nil bookmark-bmenu-mode)
(bookmark-bmenu-ensure-position)
(save-excursion
(save-window-excursion
@@ -2027,7 +2093,7 @@ With a prefix arg, prompts for a file to save them in."
(defun bookmark-bmenu-1-window ()
"Select this line's bookmark, alone, in full frame."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-jump (bookmark-bmenu-bookmark))
(bury-buffer (other-buffer))
(delete-other-windows))
@@ -2035,7 +2101,7 @@ With a prefix arg, prompts for a file to save them in."
(defun bookmark-bmenu-2-window ()
"Select this line's bookmark, with previous buffer in second window."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bmrk (bookmark-bmenu-bookmark))
(menu (current-buffer))
(pop-up-windows t))
@@ -2047,20 +2113,20 @@ With a prefix arg, prompts for a file to save them in."
(defun bookmark-bmenu-this-window ()
"Select this line's bookmark in this window."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-jump (bookmark-bmenu-bookmark)))
(defun bookmark-bmenu-other-window ()
"Select this line's bookmark in other window, leaving bookmark menu visible."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bookmark (bookmark-bmenu-bookmark)))
(bookmark--jump-via bookmark 'switch-to-buffer-other-window)))
(defun bookmark-bmenu-other-frame ()
"Select this line's bookmark in other frame."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bookmark (bookmark-bmenu-bookmark))
(pop-up-frames t))
(bookmark-jump-other-window bookmark)))
@@ -2068,7 +2134,7 @@ With a prefix arg, prompts for a file to save them in."
(defun bookmark-bmenu-switch-other-window ()
"Make the other window select this line's bookmark.
The current window remains selected."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bookmark (bookmark-bmenu-bookmark))
(fun (lambda (b) (display-buffer b t))))
(bookmark--jump-via bookmark fun)))
@@ -2077,7 +2143,7 @@ The current window remains selected."
"Jump to bookmark at mouse EVENT position in other window.
Move point in menu buffer to the position of EVENT and leave
bookmark menu visible."
- (interactive "e")
+ (interactive "e" bookmark-bmenu-mode)
(with-current-buffer (window-buffer (posn-window (event-end event)))
(save-excursion
(goto-char (posn-point (event-end event)))
@@ -2086,20 +2152,20 @@ bookmark menu visible."
(defun bookmark-bmenu-show-annotation ()
"Show the annotation for the current bookmark in another window."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bookmark (bookmark-bmenu-bookmark)))
(bookmark-show-annotation bookmark)))
(defun bookmark-bmenu-show-all-annotations ()
"Show the annotation for all bookmarks in another window."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-show-all-annotations))
(defun bookmark-bmenu-edit-annotation ()
"Edit the annotation for the current bookmark in another window."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bookmark (bookmark-bmenu-bookmark)))
(bookmark-edit-annotation bookmark t)))
@@ -2107,23 +2173,18 @@ bookmark menu visible."
(defun bookmark-bmenu-unmark (&optional backup)
"Cancel all requested operations on bookmark on this line and move down.
Optional BACKUP means move up."
- (interactive "P")
- (beginning-of-line)
+ (interactive "P" bookmark-bmenu-mode)
+ ;; any flags to reset according to circumstances? How about a
+ ;; flag indicating whether this bookmark is being visited?
+ ;; well, we don't have this now, so maybe later.
(bookmark-bmenu-ensure-position)
- (with-buffer-modified-unmodified
- (let ((inhibit-read-only t))
- (delete-char 1)
- ;; any flags to reset according to circumstances? How about a
- ;; flag indicating whether this bookmark is being visited?
- ;; well, we don't have this now, so maybe later.
- (insert " "))
- (forward-line (if backup -1 1))
- (bookmark-bmenu-ensure-position)))
+ (tabulated-list-put-tag " ")
+ (forward-line (if backup -1 1)))
(defun bookmark-bmenu-backup-unmark ()
"Move up and cancel all requested operations on bookmark on line above."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(forward-line -1)
(bookmark-bmenu-ensure-position)
(bookmark-bmenu-unmark)
@@ -2131,63 +2192,79 @@ Optional BACKUP means move up."
(bookmark-bmenu-ensure-position))
+(defun bookmark-bmenu-unmark-all ()
+ "Cancel all requested operations on all listed bookmarks."
+ (interactive nil bookmark-bmenu-mode)
+ (save-excursion
+ (goto-char (point-min))
+ (bookmark-bmenu-ensure-position)
+ (while (not (eobp))
+ (tabulated-list-put-tag " " t))))
+
+
(defun bookmark-bmenu-delete ()
"Mark bookmark on this line to be deleted.
To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-execute-deletions]."
- (interactive)
- (beginning-of-line)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-bmenu-ensure-position)
- (with-buffer-modified-unmodified
- (let ((inhibit-read-only t))
- (delete-char 1)
- (insert ?D)
- (forward-line 1)
- (bookmark-bmenu-ensure-position))))
+ (tabulated-list-put-tag "D" t))
(defun bookmark-bmenu-delete-backwards ()
"Mark bookmark on this line to be deleted, then move up one line.
To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-execute-deletions]."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(bookmark-bmenu-delete)
- (forward-line -2)
- (bookmark-bmenu-ensure-position)
- (forward-line 1)
- (bookmark-bmenu-ensure-position))
+ (forward-line -2))
-(defun bookmark-bmenu-execute-deletions ()
- "Delete bookmarks flagged `D'."
- (interactive)
- (let ((reporter (make-progress-reporter "Deleting bookmarks..."))
- (o-point (point))
- (o-str (save-excursion
- (beginning-of-line)
- (unless (= (following-char) ?D)
- (buffer-substring
- (point)
- (progn (end-of-line) (point))))))
- (o-col (current-column)))
+(defun bookmark-bmenu-delete-all ()
+ "Mark all listed bookmarks as to be deleted.
+To remove all deletion marks, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-unmark-all].
+To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-execute-deletions]."
+ (interactive nil bookmark-bmenu-mode)
+ (save-excursion
(goto-char (point-min))
- (unless bookmark-bmenu-use-header-line
- (forward-line 1))
- (while (re-search-forward "^D" (point-max) t)
- (bookmark-delete (bookmark-bmenu-bookmark) t)) ; pass BATCH arg
- (bookmark-bmenu-list)
- (if o-str
- (progn
- (goto-char (point-min))
- (search-forward o-str)
- (beginning-of-line)
- (forward-char o-col))
- (goto-char o-point))
- (beginning-of-line)
- (progress-reporter-done reporter)))
+ (bookmark-bmenu-ensure-position)
+ (while (not (eobp))
+ (tabulated-list-put-tag "D" t))))
+
+
+(defun bookmark-bmenu-execute-deletions ()
+ "Delete bookmarks flagged `D'.
+If `bookmark-menu-confirm-deletion' is non-nil, prompt for
+confirmation first."
+ (interactive nil bookmark-bmenu-mode)
+ (if (and bookmark-menu-confirm-deletion
+ (not (yes-or-no-p "Delete selected bookmarks? ")))
+ (message "Bookmarks not deleted.")
+ (let ((reporter (make-progress-reporter "Deleting bookmarks..."))
+ (o-point (point))
+ (o-str (save-excursion
+ (beginning-of-line)
+ (unless (= (following-char) ?D)
+ (buffer-substring
+ (point)
+ (progn (end-of-line) (point))))))
+ (o-col (current-column)))
+ (goto-char (point-min))
+ (while (re-search-forward "^D" (point-max) t)
+ (bookmark-delete (bookmark-bmenu-bookmark) t)) ; pass BATCH arg
+ (bookmark-bmenu-list)
+ (if o-str
+ (progn
+ (goto-char (point-min))
+ (search-forward o-str)
+ (beginning-of-line)
+ (forward-char o-col))
+ (goto-char o-point))
+ (beginning-of-line)
+ (progress-reporter-done reporter))))
(defun bookmark-bmenu-rename ()
"Rename bookmark on current line. Prompts for a new name."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bmrk (bookmark-bmenu-bookmark))
(thispoint (point)))
(bookmark-rename bmrk)
@@ -2196,14 +2273,14 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\
(defun bookmark-bmenu-locate ()
"Display location of this bookmark. Displays in the minibuffer."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bmrk (bookmark-bmenu-bookmark)))
(message "%s" (bookmark-location bmrk))))
(defun bookmark-bmenu-relocate ()
"Change the absolute file name of the bookmark on the current line.
Prompt with completion for the new path."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bmrk (bookmark-bmenu-bookmark))
(thispoint (point)))
(bookmark-relocate bmrk)
@@ -2223,7 +2300,7 @@ Prompt with completion for the new path."
;;;###autoload
(defun bookmark-bmenu-search ()
"Incremental search of bookmarks, hiding the non-matches as we go."
- (interactive)
+ (interactive nil bookmark-bmenu-mode)
(let ((bmk (bookmark-bmenu-bookmark))
(timer nil))
(unwind-protect
@@ -2315,6 +2392,9 @@ strings returned are not."
(bindings--define-key map [delete]
'(menu-item "Delete Bookmark..." bookmark-delete
:help "Delete a bookmark from the bookmark list"))
+ (bindings--define-key map [delete-all]
+ '(menu-item "Delete all Bookmarks..." bookmark-delete-all
+ :help "Delete all bookmarks from the bookmark list"))
(bindings--define-key map [rename]
'(menu-item "Rename Bookmark..." bookmark-rename
:help "Change the name of a bookmark"))
@@ -2347,6 +2427,8 @@ strings returned are not."
;; Load Hook
(defvar bookmark-load-hook nil
"Hook run at the end of loading library `bookmark.el'.")
+(make-obsolete-variable 'bookmark-load-hook
+ "use `with-eval-after-load' instead." "28.1")
;; Exit Hook, called from kill-emacs-hook
(defvar bookmark-exit-hook nil
diff --git a/lisp/bs.el b/lisp/bs.el
index 9162390e643..494bc426188 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -120,8 +120,6 @@
;; can cycle through all file buffers and *scratch* although your current
;; configuration perhaps is "files" which ignores buffer *scratch*.
-;;; History:
-
;;; Code:
;; ----------------------------------------------------------------------
@@ -173,7 +171,12 @@ return a string representing the column's value."
(defun bs--make-header-match-string ()
"Return a regexp matching the first line of a Buffer Selection Menu buffer."
- (concat "^\\(" (mapconcat #'car bs-attributes-list " *") " *$\\)"))
+ (concat "^\\("
+ (apply #'concat (mapcan (lambda (e)
+ (and (not (equal (car e) ""))
+ (list " *" (car e))))
+ bs-attributes-list))
+ " *$\\)"))
;; Font-Lock-Settings
(defvar bs-mode-font-lock-keywords
@@ -1501,7 +1504,6 @@ name of buffer configuration."
;; continue standard unloading
nil)
-;; Now provide feature bs
(provide 'bs)
;;; bs.el ends here
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index d10a3148ab8..340c926f8d6 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -69,11 +69,26 @@ minus `Buffer-menu-size-width'. This use is deprecated."
"use `Buffer-menu-name-width' and `Buffer-menu-size-width' instead."
"24.3")
-(defcustom Buffer-menu-name-width 19
- "Width of buffer name column in the Buffer Menu."
- :type 'number
+(defun Buffer-menu--dynamic-name-width (buffers)
+ "Return a name column width based on the current window width.
+The width will never exceed the actual width of the buffer names,
+but will never be narrower than 19 characters."
+ (max 19
+ ;; This gives 19 on an 80 column window, and take up
+ ;; proportionally more space as the window widens.
+ (min (truncate (/ (window-width) 4.2))
+ (apply #'max 0 (mapcar (lambda (b)
+ (length (buffer-name b)))
+ buffers)))))
+
+(defcustom Buffer-menu-name-width #'Buffer-menu--dynamic-name-width
+ "Width of buffer name column in the Buffer Menu.
+This can either be a number (used directly) or a function that
+will be called with the list of buffers and should return a
+number."
+ :type '(choice function number)
:group 'Buffer-menu
- :version "24.3")
+ :version "28.1")
(defcustom Buffer-menu-size-width 7
"Width of buffer size column in the Buffer Menu."
@@ -96,15 +111,13 @@ as it is by default."
:group 'Buffer-menu
:version "22.1")
-(defvar Buffer-menu-files-only nil
+(defvar-local Buffer-menu-files-only nil
"Non-nil if the current Buffer Menu lists only file buffers.
This is set by the prefix argument to `buffer-menu' and related
commands.")
-(make-variable-buffer-local 'Buffer-menu-files-only)
(defvar Buffer-menu-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map "v" 'Buffer-menu-select)
(define-key map "2" 'Buffer-menu-2-window)
@@ -138,84 +151,62 @@ commands.")
(define-key map [mouse-2] 'Buffer-menu-mouse-select)
(define-key map [follow-link] 'mouse-face)
-
- (define-key map [menu-bar Buffer-menu-mode] (cons (purecopy "Buffer-Menu") menu-map))
- (bindings--define-key menu-map [quit]
- '(menu-item "Quit" quit-window
- :help "Remove the buffer menu from the display"))
- (bindings--define-key menu-map [rev]
- '(menu-item "Refresh" revert-buffer
- :help "Refresh the *Buffer List* buffer contents"))
- (bindings--define-key menu-map [s0] menu-bar-separator)
- (bindings--define-key menu-map [tf]
- '(menu-item "Show Only File Buffers" Buffer-menu-toggle-files-only
- :button (:toggle . Buffer-menu-files-only)
- :help "Toggle whether the current buffer-menu displays only file buffers"))
- (bindings--define-key menu-map [s1] menu-bar-separator)
- ;; FIXME: The "Select" entries could use better names...
- (bindings--define-key menu-map [sel]
- '(menu-item "Select Marked" Buffer-menu-select
- :help "Select this line's buffer; also display buffers marked with `>'"))
- (bindings--define-key menu-map [bm2]
- '(menu-item "Select Two" Buffer-menu-2-window
- :help "Select this line's buffer, with previous buffer in second window"))
- (bindings--define-key menu-map [bm1]
- '(menu-item "Select Current" Buffer-menu-1-window
- :help "Select this line's buffer, alone, in full frame"))
- (bindings--define-key menu-map [ow]
- '(menu-item "Select in Other Window" Buffer-menu-other-window
- :help "Select this line's buffer in other window, leaving buffer menu visible"))
- (bindings--define-key menu-map [tw]
- '(menu-item "Select in Current Window" Buffer-menu-this-window
- :help "Select this line's buffer in this window"))
- (bindings--define-key menu-map [s2] menu-bar-separator)
- (bindings--define-key menu-map [is]
- '(menu-item "Regexp Isearch Marked Buffers..." Buffer-menu-isearch-buffers-regexp
- :help "Search for a regexp through all marked buffers using Isearch"))
- (bindings--define-key menu-map [ir]
- '(menu-item "Isearch Marked Buffers..." Buffer-menu-isearch-buffers
- :help "Search for a string through all marked buffers using Isearch"))
- (bindings--define-key menu-map [mo]
- '(menu-item "Multi Occur Marked Buffers..." Buffer-menu-multi-occur
- :help "Show lines matching a regexp in marked buffers using Occur"))
- (bindings--define-key menu-map [s3] menu-bar-separator)
- (bindings--define-key menu-map [by]
- '(menu-item "Bury" Buffer-menu-bury
- :help "Bury the buffer listed on this line"))
- (bindings--define-key menu-map [vt]
- '(menu-item "Set Unmodified" Buffer-menu-not-modified
- :help "Mark buffer on this line as unmodified (no changes to save)"))
- (bindings--define-key menu-map [ex]
- '(menu-item "Execute" Buffer-menu-execute
- :help "Save and/or delete buffers marked with s or k commands"))
- (bindings--define-key menu-map [s4] menu-bar-separator)
- (bindings--define-key menu-map [delb]
- '(menu-item "Mark for Delete and Move Backwards" Buffer-menu-delete-backwards
- :help "Mark buffer on this line to be deleted by x command and move up one line"))
- (bindings--define-key menu-map [del]
- '(menu-item "Mark for Delete" Buffer-menu-delete
- :help "Mark buffer on this line to be deleted by x command"))
-
- (bindings--define-key menu-map [sv]
- '(menu-item "Mark for Save" Buffer-menu-save
- :help "Mark buffer on this line to be saved by x command"))
- (bindings--define-key menu-map [umk]
- '(menu-item "Unmark" Buffer-menu-unmark
- :help "Cancel all requested operations on buffer on this line and move down"))
- (bindings--define-key menu-map [umkab]
- '(menu-item "Remove marks..." Buffer-menu-unmark-all-buffers
- :help "Cancel a requested operation on all buffers"))
- (bindings--define-key menu-map [umka]
- '(menu-item "Unmark all" Buffer-menu-unmark-all
- :help "Cancel all requested operations on buffers"))
- (bindings--define-key menu-map [mk]
- '(menu-item "Mark" Buffer-menu-mark
- :help "Mark buffer on this line for being displayed by v command"))
map)
"Local keymap for `Buffer-menu-mode' buffers.")
-(define-obsolete-variable-alias 'buffer-menu-mode-hook
- 'Buffer-menu-mode-hook "23.1")
+(easy-menu-define Buffer-menu-mode-menu Buffer-menu-mode-map
+ "Menu for `Buffer-menu-mode' buffers."
+ '("Buffer-Menu"
+ ["Mark" Buffer-menu-mark
+ :help "Mark buffer on this line for being displayed by v command"]
+ ["Unmark all" Buffer-menu-unmark-all
+ :help "Cancel all requested operations on buffers"]
+ ["Remove marks..." Buffer-menu-unmark-all-buffers
+ :help "Cancel a requested operation on all buffers"]
+ ["Unmark" Buffer-menu-unmark
+ :help "Cancel all requested operations on buffer on this line and move down"]
+ ["Mark for Save" Buffer-menu-save
+ :help "Mark buffer on this line to be saved by x command"]
+ ["Mark for Delete" Buffer-menu-delete
+ :help "Mark buffer on this line to be deleted by x command"]
+ ["Mark for Delete and Move Backwards" Buffer-menu-delete-backwards
+ :help "Mark buffer on this line to be deleted by x command and move up one line"]
+ "---"
+ ["Execute" Buffer-menu-execute
+ :help "Save and/or delete buffers marked with s or k commands"]
+ ["Set Unmodified" Buffer-menu-not-modified
+ :help "Mark buffer on this line as unmodified (no changes to save)"]
+ ["Bury" Buffer-menu-bury
+ :help "Bury the buffer listed on this line"]
+ "---"
+ ["Multi Occur Marked Buffers..." Buffer-menu-multi-occur
+ :help "Show lines matching a regexp in marked buffers using Occur"]
+ ["Isearch Marked Buffers..." Buffer-menu-isearch-buffers
+ :help "Search for a string through all marked buffers using Isearch"]
+ ["Regexp Isearch Marked Buffers..." Buffer-menu-isearch-buffers-regexp
+ :help "Search for a regexp through all marked buffers using Isearch"]
+ "---"
+ ;; FIXME: The "Select" entries could use better names...
+ ["Select in Current Window" Buffer-menu-this-window
+ :help "Select this line's buffer in this window"]
+ ["Select in Other Window" Buffer-menu-other-window
+ :help "Select this line's buffer in other window, leaving buffer menu visible"]
+ ["Select Current" Buffer-menu-1-window
+ :help "Select this line's buffer, alone, in full frame"]
+ ["Select Two" Buffer-menu-2-window
+ :help "Select this line's buffer, with previous buffer in second window"]
+ ["Select Marked" Buffer-menu-select
+ :help "Select this line's buffer; also display buffers marked with `>'"]
+ "---"
+ ["Show Only File Buffers" Buffer-menu-toggle-files-only
+ :help "Toggle whether the current buffer-menu displays only file buffers"
+ :style toggle
+ :selected Buffer-menu-files-only]
+ "---"
+ ["Refresh" revert-buffer
+ :help "Refresh the *Buffer List* buffer contents"]
+ ["Quit" quit-window
+ :help "Remove the buffer menu from the display"]))
(define-derived-mode Buffer-menu-mode tabulated-list-mode "Buffer Menu"
"Major mode for Buffer Menu buffers.
@@ -257,8 +248,9 @@ In Buffer Menu mode, the following commands are defined:
\\[revert-buffer] Update the list of buffers.
\\[Buffer-menu-toggle-files-only] Toggle whether the menu displays only file buffers.
\\[Buffer-menu-bury] Bury the buffer listed on this line."
- (set (make-local-variable 'buffer-stale-function)
- (lambda (&optional _noconfirm) 'fast))
+ :interactive nil
+ (setq-local buffer-stale-function
+ (lambda (&optional _noconfirm) 'fast))
(add-hook 'tabulated-list-revert-hook 'list-buffers--refresh nil t))
(defun buffer-menu (&optional arg)
@@ -317,7 +309,7 @@ ARG, show only buffers that are visiting files."
"Toggle whether the current buffer-menu displays only file buffers.
With a positive ARG, display only file buffers. With zero or
negative ARG, display other buffers as well."
- (interactive "P")
+ (interactive "P" Buffer-menu-mode)
(setq Buffer-menu-files-only
(cond ((not arg) (not Buffer-menu-files-only))
((> (prefix-numeric-value arg) 0) t)))
@@ -326,7 +318,8 @@ negative ARG, display other buffers as well."
"Showing all non-internal buffers."))
(revert-buffer))
-(defalias 'Buffer-menu-sort 'tabulated-list-sort)
+(define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort
+ "28.1")
(defun Buffer-menu-buffer (&optional error-if-non-existent-p)
@@ -362,14 +355,14 @@ is nil or omitted, and signal an error otherwise."
(defun Buffer-menu-mark ()
"Mark the Buffer menu entry at point for later display.
It will be displayed by the \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(tabulated-list-set-col 0 (char-to-string Buffer-menu-marker-char) t)
(forward-line))
(defun Buffer-menu-unmark (&optional backup)
"Cancel all requested operations on buffer on this line and move down.
Optional prefix arg means move up."
- (interactive "P")
+ (interactive "P" Buffer-menu-mode)
(Buffer-menu--unmark)
(forward-line (if backup -1 1)))
@@ -377,7 +370,7 @@ Optional prefix arg means move up."
"Cancel a requested operation on all buffers.
MARK is the character to flag the operation on the buffers.
When called interactively prompt for MARK; RET remove all marks."
- (interactive "cRemove marks (RET means all):")
+ (interactive "cRemove marks (RET means all):" Buffer-menu-mode)
(save-excursion
(goto-char (point-min))
(when (tabulated-list-header-overlay-p)
@@ -392,12 +385,12 @@ When called interactively prompt for MARK; RET remove all marks."
(defun Buffer-menu-unmark-all ()
"Cancel all requested operations on buffers."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(Buffer-menu-unmark-all-buffers ?\r))
(defun Buffer-menu-backup-unmark ()
"Move up and cancel all requested operations on buffer on line above."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(forward-line -1)
(Buffer-menu--unmark))
@@ -416,7 +409,7 @@ will delete it.
If prefix argument ARG is non-nil, it specifies the number of
buffers to delete; a negative ARG means to delete backwards."
- (interactive "p")
+ (interactive "p" Buffer-menu-mode)
(if (or (null arg) (= arg 0))
(setq arg 1))
(while (> arg 0)
@@ -435,14 +428,14 @@ buffers to delete; a negative ARG means to delete backwards."
A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]'
command will delete the marked buffer. Prefix ARG means move
that many lines."
- (interactive "p")
+ (interactive "p" Buffer-menu-mode)
(Buffer-menu-delete (- (or arg 1))))
(defun Buffer-menu-save ()
"Mark the buffer on this Buffer Menu line for saving.
A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' command
will save it."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(when (Buffer-menu-buffer)
(tabulated-list-set-col 2 "S" t)
(forward-line 1)))
@@ -451,7 +444,7 @@ will save it."
"Mark the buffer on this line as unmodified (no changes to save).
If ARG is non-nil (interactively, with a prefix argument), mark
it as modified."
- (interactive "P")
+ (interactive "P" Buffer-menu-mode)
(with-current-buffer (Buffer-menu-buffer t)
(set-buffer-modified-p arg))
(tabulated-list-set-col 2 (if arg "*" " ") t))
@@ -460,7 +453,7 @@ it as modified."
"Save and/or delete marked buffers in the Buffer Menu.
Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-save]' are saved.
Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(save-excursion
(Buffer-menu-beginning)
(while (not (eobp))
@@ -488,9 +481,10 @@ Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted
(defun Buffer-menu-select ()
"Select this line's buffer; also, display buffers marked with `>'.
You can mark buffers with the \\<Buffer-menu-mode-map>`\\[Buffer-menu-mark]' command.
+
This command deletes and replaces all the previously existing windows
-in the selected frame."
- (interactive)
+in the selected frame, and will remove any marks."
+ (interactive nil Buffer-menu-mode)
(let* ((this-buffer (Buffer-menu-buffer t))
(menu-buffer (current-buffer))
(others (delq this-buffer (Buffer-menu-marked-buffers t)))
@@ -521,23 +515,23 @@ If UNMARK is non-nil, unmark them."
(defun Buffer-menu-isearch-buffers ()
"Search for a string through all marked buffers using Isearch."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(multi-isearch-buffers (Buffer-menu-marked-buffers)))
(defun Buffer-menu-isearch-buffers-regexp ()
"Search for a regexp through all marked buffers using Isearch."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(multi-isearch-buffers-regexp (Buffer-menu-marked-buffers)))
(defun Buffer-menu-multi-occur (regexp &optional nlines)
"Show all lines in marked buffers containing a match for a regexp."
- (interactive (occur-read-primary-args))
+ (interactive (occur-read-primary-args) Buffer-menu-mode)
(multi-occur (Buffer-menu-marked-buffers) regexp nlines))
(defun Buffer-menu-visit-tags-table ()
"Visit the tags table in the buffer on this line. See `visit-tags-table'."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(let ((file (buffer-file-name (Buffer-menu-buffer t))))
(if file
(visit-tags-table file)
@@ -545,30 +539,30 @@ If UNMARK is non-nil, unmark them."
(defun Buffer-menu-1-window ()
"Select this line's buffer, alone, in full frame."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(switch-to-buffer (Buffer-menu-buffer t))
(bury-buffer (other-buffer))
(delete-other-windows))
(defun Buffer-menu-this-window ()
"Select this line's buffer in this window."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(switch-to-buffer (Buffer-menu-buffer t)))
(defun Buffer-menu-other-window ()
"Select this line's buffer in other window, leaving buffer menu visible."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(switch-to-buffer-other-window (Buffer-menu-buffer t)))
(defun Buffer-menu-switch-other-window ()
"Make the other window select this line's buffer.
The current window remains selected."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(display-buffer (Buffer-menu-buffer t) t))
(defun Buffer-menu-2-window ()
"Select this line's buffer, with previous buffer in second window."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(let ((buff (Buffer-menu-buffer t))
(menu (current-buffer)))
(delete-other-windows)
@@ -579,7 +573,7 @@ The current window remains selected."
(defun Buffer-menu-toggle-read-only ()
"Toggle read-only status of buffer on this line.
This behaves like invoking \\[read-only-mode] in that buffer."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(let ((read-only
(with-current-buffer (Buffer-menu-buffer t)
(read-only-mode 'toggle)
@@ -588,7 +582,7 @@ This behaves like invoking \\[read-only-mode] in that buffer."
(defun Buffer-menu-bury ()
"Bury the buffer listed on this line."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(let ((buffer (tabulated-list-get-id)))
(cond ((null buffer))
((buffer-live-p buffer)
@@ -604,12 +598,12 @@ This behaves like invoking \\[read-only-mode] in that buffer."
(defun Buffer-menu-view ()
"View this line's buffer in View mode."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(view-buffer (Buffer-menu-buffer t)))
(defun Buffer-menu-view-other-window ()
"View this line's buffer in View mode in another window."
- (interactive)
+ (interactive nil Buffer-menu-mode)
(view-buffer-other-window (Buffer-menu-buffer t)))
;;; Functions for populating the Buffer Menu.
@@ -634,7 +628,7 @@ means list those buffers and no others."
(defun Buffer-menu-mouse-select (event)
"Select the buffer whose line you click on."
- (interactive "e")
+ (interactive "e" Buffer-menu-mode)
(select-window (posn-window (event-end event)))
(let ((buffer (tabulated-list-get-id (posn-point (event-end event)))))
(when (buffer-live-p buffer)
@@ -645,25 +639,11 @@ means list those buffers and no others."
(defun list-buffers--refresh (&optional buffer-list old-buffer)
;; Set up `tabulated-list-format'.
- (let ((name-width Buffer-menu-name-width)
- (size-width Buffer-menu-size-width)
+ (let ((size-width Buffer-menu-size-width)
(marked-buffers (Buffer-menu-marked-buffers))
(buffer-menu-buffer (current-buffer))
(show-non-file (not Buffer-menu-files-only))
- entries)
- ;; Handle obsolete variable:
- (if Buffer-menu-buffer+size-width
- (setq name-width (- Buffer-menu-buffer+size-width size-width)))
- (setq tabulated-list-format
- (vector '("C" 1 t :pad-right 0)
- '("R" 1 t :pad-right 0)
- '("M" 1 t)
- `("Buffer" ,name-width t)
- `("Size" ,size-width tabulated-list-entry-size->
- :right-align t)
- `("Mode" ,Buffer-menu-mode-width t)
- '("File" 1 t)))
- (setq tabulated-list-use-header-line Buffer-menu-use-header-line)
+ entries name-width)
;; Collect info for each buffer we're interested in.
(dolist (buffer (or buffer-list
(buffer-list (if Buffer-menu-use-frame-buffer-list
@@ -693,6 +673,22 @@ means list those buffers and no others."
nil nil buffer)))
(Buffer-menu--pretty-file-name file)))
entries)))))
+ (setq name-width (if (functionp Buffer-menu-name-width)
+ (funcall Buffer-menu-name-width (mapcar #'car entries))
+ Buffer-menu-name-width))
+ ;; Handle obsolete variable:
+ (if Buffer-menu-buffer+size-width
+ (setq name-width (- Buffer-menu-buffer+size-width size-width)))
+ (setq tabulated-list-format
+ (vector '("C" 1 t :pad-right 0)
+ '("R" 1 t :pad-right 0)
+ '("M" 1 t)
+ `("Buffer" ,name-width t)
+ `("Size" ,size-width tabulated-list-entry-size->
+ :right-align t)
+ `("Mode" ,Buffer-menu-mode-width t)
+ '("File" 1 t)))
+ (setq tabulated-list-use-header-line Buffer-menu-use-header-line)
(setq tabulated-list-entries (nreverse entries)))
(tabulated-list-init-header))
diff --git a/lisp/button.el b/lisp/button.el
index 4d6e635a79e..74dfb5d5419 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -61,6 +61,7 @@
;; might get converted to ^M when building loaddefs.el
(define-key map [(control ?m)] 'push-button)
(define-key map [mouse-2] 'push-button)
+ (define-key map [follow-link] 'mouse-face)
;; FIXME: You'd think that for keymaps coming from text-properties on the
;; mode-line or header-line, the `mode-line' or `header-line' prefix
;; shouldn't be necessary!
@@ -78,6 +79,10 @@
"Keymap useful for buffers containing buttons.
Mode-specific keymaps may want to use this as their parent keymap.")
+(define-minor-mode button-mode
+ "A minor mode for navigating to buttons with the TAB key."
+ :keymap button-buffer-map)
+
;; Default properties for buttons.
(put 'default-button 'face 'button)
(put 'default-button 'mouse-face 'highlight)
@@ -341,15 +346,14 @@ If the property `button-data' is present, it will later be used
as the argument for the `action' callback function instead of the
default argument, which is the button itself.
-BEG can also be a string, in which case it is made into a button.
+BEG can also be a string, in which case a copy of it is made into
+a button and returned.
Also see `insert-text-button'."
(let ((object nil)
(type-entry
(or (plist-member properties 'type)
(plist-member properties :type))))
- (when (stringp beg)
- (setq object beg beg 0 end (length object)))
;; Disallow setting the `category' property directly.
(when (plist-get properties 'category)
(error "Button `category' property may not be set directly"))
@@ -362,6 +366,10 @@ Also see `insert-text-button'."
(setcar type-entry 'category)
(setcar (cdr type-entry)
(button-category-symbol (cadr type-entry))))
+ (when (stringp beg)
+ (setq object (copy-sequence beg))
+ (setq beg 0)
+ (setq end (length object)))
;; Now add all the text properties at once.
(add-text-properties beg end
;; Each button should have a non-eq `button'
@@ -461,18 +469,24 @@ see).
POS defaults to point, except when `push-button' is invoked
interactively as the result of a mouse-event, in which case, the
mouse event is used.
+
If there's no button at POS, do nothing and return nil, otherwise
-return t."
+return t.
+
+To get a description of the function that will be invoked when
+pushing a button, use the `button-describe' command."
(interactive
(list (if (integerp last-command-event) (point) last-command-event)))
(if (and (not (integerp pos)) (eventp pos))
;; POS is a mouse event; switch to the proper window/buffer
(let ((posn (event-start pos)))
(with-current-buffer (window-buffer (posn-window posn))
- (if (posn-string posn)
- ;; mode-line, header-line, or display string event.
- (button-activate (posn-string posn) t)
- (push-button (posn-point posn) t))))
+ (let* ((str (posn-string posn))
+ (str-button (and str (get-text-property (cdr str) 'button (car str)))))
+ (if str-button
+ ;; mode-line, header-line, or display string event.
+ (button-activate str t)
+ (push-button (posn-point posn) t)))))
;; POS is just normal position
(let ((button (button-at (or pos (point)))))
(when button
@@ -480,12 +494,17 @@ return t."
t))))
(defun button--help-echo (button)
- "Evaluate BUTTON's `help-echo' property and return its value."
- (let ((help (button-get button 'help-echo)))
- (if (functionp help)
- (let ((obj (if (overlayp button) button (current-buffer))))
- (funcall help (selected-window) obj (button-start button)))
- (eval help lexical-binding))))
+ "Evaluate BUTTON's `help-echo' property and return its value.
+If the result is non-nil, pass it through `substitute-command-keys'
+before returning it, as is done for `show-help-function'."
+ (let* ((help (button-get button 'help-echo))
+ (help (if (functionp help)
+ (funcall help
+ (selected-window)
+ (if (overlayp button) button (current-buffer))
+ (button-start button))
+ (eval help lexical-binding))))
+ (and help (substitute-command-keys help))))
(defun forward-button (n &optional wrap display-message no-error)
"Move to the Nth next button, or Nth previous button if N is negative.
@@ -550,6 +569,65 @@ Returns the button found."
(interactive "p\nd\nd")
(forward-button (- n) wrap display-message no-error))
+(defun button--describe (properties)
+ "Describe a button's PROPERTIES (an alist) in a *Help* buffer.
+This is a helper function for `button-describe', in order to be possible to
+use `help-setup-xref'.
+
+Each element of PROPERTIES should be of the form (PROPERTY . VALUE)."
+ (help-setup-xref (list #'button--describe properties)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (format-message "This button's type is `%s'."
+ (alist-get 'type properties)))
+ (dolist (prop '(action mouse-action))
+ (let ((name (symbol-name prop))
+ (val (alist-get prop properties)))
+ (when (functionp val)
+ (insert "\n\n"
+ (propertize (capitalize name) 'face 'bold)
+ "\nThe " name " of this button is")
+ (if (symbolp val)
+ (progn
+ (insert (format-message " `%s',\nwhich is " val))
+ (describe-function-1 val))
+ (insert "\n")
+ (princ val))))))))
+
+(defun button-describe (&optional button-or-pos)
+ "Display a buffer with information about the button at point.
+
+When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a
+buffer position where a button is present. If BUTTON-OR-POS is nil, the
+button at point is the button to describe."
+ (interactive "d")
+ (let* ((button (cond ((integer-or-marker-p button-or-pos)
+ (button-at button-or-pos))
+ ((null button-or-pos) (button-at (point)))
+ ((overlayp button-or-pos) button-or-pos)))
+ (props (and button
+ (mapcar (lambda (prop)
+ (cons prop (button-get button prop)))
+ '(type action mouse-action)))))
+ (when props
+ (button--describe props)
+ t)))
+
+(defun button-buttonize (string callback &optional data)
+ "Make STRING into a button and return it.
+When clicked, CALLBACK will be called with the DATA as the
+function argument. If DATA isn't present (or is nil), the button
+itself will be used instead as the function argument."
+ (propertize string
+ 'face 'button
+ 'button t
+ 'follow-link t
+ 'category t
+ 'button-data data
+ 'keymap button-map
+ 'action callback))
+
(provide 'button)
;;; button.el ends here
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el
index 35f33b6929a..1e31c3cadc0 100644
--- a/lisp/calc/calc-aent.el
+++ b/lisp/calc/calc-aent.el
@@ -1,4 +1,4 @@
-;;; calc-aent.el --- algebraic entry functions for Calc
+;;; calc-aent.el --- algebraic entry functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -76,8 +76,8 @@
(calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp))))
(setq alg-exp (list (nth 2 (car alg-exp)))))
(setq calc-quick-prev-results alg-exp
- buf (mapconcat (function (lambda (x)
- (math-format-value x 1000)))
+ buf (mapconcat (lambda (x)
+ (math-format-value x 1000))
alg-exp
" ")
shortbuf buf)
@@ -158,7 +158,7 @@
(setq strp (cdr (cdr strp))))
(calc-do-calc-eval (car str) separator args)))
((eq separator 'eval)
- (eval str))
+ (eval str t))
((eq separator 'macro)
(require 'calc-ext)
(let* ((calc-buffer (current-buffer))
@@ -197,18 +197,17 @@
(calc-language (if (memq calc-language '(nil big))
'flat calc-language))
(calc-dollar-values (mapcar
- (function
- (lambda (x)
- (if (stringp x)
- (progn
- (setq x (math-read-exprs x))
- (if (eq (car-safe x)
- 'error)
- (throw 'calc-error
- (calc-eval-error
- (cdr x)))
- (car x)))
- x)))
+ (lambda (x)
+ (if (stringp x)
+ (progn
+ (setq x (math-read-exprs x))
+ (if (eq (car-safe x)
+ 'error)
+ (throw 'calc-error
+ (calc-eval-error
+ (cdr x)))
+ (car x)))
+ x))
args))
(calc-dollar-used 0)
(res (if (stringp str)
@@ -285,6 +284,8 @@ The value t means abort and give an error message.")
(defvar calc-alg-entry-history nil
"History for algebraic entry.")
+(defvar calc-plain-entry nil)
+
;;;###autoload
(defun calc-alg-entry (&optional initial prompt)
(let* ((calc-dollar-values (mapcar #'calc-get-stack-element
@@ -401,7 +402,6 @@ The value t means abort and give an error message.")
(use-local-map calc-mode-map))
(calcAlg-enter))
-(defvar calc-plain-entry nil)
(defun calcAlg-edit ()
(interactive)
(if (or (not calc-plain-entry)
@@ -576,8 +576,9 @@ in Calc algebraic input.")
(defvar math-expr-data)
;;;###autoload
-(defun math-read-exprs (math-exp-str)
- (let ((math-exp-pos 0)
+(defun math-read-exprs (str)
+ (let ((math-exp-str str)
+ (math-exp-pos 0)
(math-exp-old-pos 0)
(math-exp-keep-spaces nil)
math-exp-token math-expr-data)
@@ -638,10 +639,10 @@ in Calc algebraic input.")
(math-find-user-tokens (car (car p)))
(setq p (cdr p)))
(setq calc-user-tokens (mapconcat 'identity
- (sort (mapcar 'car math-toks)
- (function (lambda (x y)
- (> (length x)
- (length y)))))
+ (sort (mapcar #'car math-toks)
+ (lambda (x y)
+ (> (length x)
+ (length y))))
"\\|")
calc-last-main-parse-table mtab
calc-last-user-lang-parse-table ltab
@@ -738,8 +739,8 @@ in Calc algebraic input.")
math-exp-pos (match-end 0)))
((and (setq adfn
(assq ch (get calc-language 'math-lang-read-symbol)))
- (eval (nth 1 adfn)))
- (eval (nth 2 adfn)))
+ (eval (nth 1 adfn) t))
+ (eval (nth 2 adfn) t))
((eq ch ?\$)
(if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos)
math-exp-pos)
@@ -771,8 +772,8 @@ in Calc algebraic input.")
math-expr-data (math-match-substring math-exp-str 1)
math-exp-pos (match-end 0)))
((and (setq adfn (get calc-language 'math-lang-read))
- (eval (nth 0 adfn))
- (eval (nth 1 adfn))))
+ (eval (nth 0 adfn) t)
+ (eval (nth 1 adfn) t)))
((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos)
(setq math-exp-pos (match-end 0))
(math-read-token))
diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el
index 95e91496277..162026d092b 100644
--- a/lisp/calc/calc-alg.el
+++ b/lisp/calc/calc-alg.el
@@ -444,12 +444,12 @@ Code can refer to the expression to simplify via lexical variable `expr'
and should return the simplified expression to use (or nil)."
(declare (indent 1) (debug (sexp body)))
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-simplify
- (nconc
- (get ',func 'math-simplify)
- (list
- #'(lambda (expr) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-simplify
+ (nconc
+ (get ',func 'math-simplify)
+ (list
+ (lambda (expr) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(math-defsimplify (+ -)
@@ -1785,7 +1785,7 @@ and should return the simplified expression to use (or nil)."
(cons (nth 2 expr) math-poly-neg-powers))))
(not (Math-zerop (nth 2 expr)))
(let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
- (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
+ (mapcar (lambda (x) (math-div x (nth 2 expr)))
p1))))
((and (eq (car expr) 'calcFunc-exp)
(equal math-var '(var e var-e)))
@@ -1838,8 +1838,9 @@ and should return the simplified expression to use (or nil)."
(defun math-polynomial-base (top-expr &optional pred)
"Find the variable (or sub-expression) which is the base of polynomial expr."
(let ((math-poly-base-pred
- (or pred (function (lambda (base) (math-polynomial-p
- top-expr base))))))
+ (or pred (lambda (base)
+ (math-polynomial-p
+ top-expr base)))))
(or (let ((math-poly-base-const-ok nil))
(math-polynomial-base-rec top-expr))
(let ((math-poly-base-const-ok t))
diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el
index a8afd1d26ef..9787fe0d609 100644
--- a/lisp/calc/calc-arith.el
+++ b/lisp/calc/calc-arith.el
@@ -1,4 +1,4 @@
-;;; calc-arith.el --- arithmetic functions for Calc
+;;; calc-arith.el --- arithmetic functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -250,44 +250,43 @@
(while (setq p (cdr p))
(and (eq (car-safe (car p)) 'vec)
(setq vec (nth 2 (car p)))
- (condition-case err
- (let ((v (nth 1 (car p))))
- (setq type nil range nil)
- (or (eq (car-safe vec) 'vec)
- (setq vec (list 'vec vec)))
- (while (and (setq vec (cdr vec))
- (not (Math-objectp (car vec))))
- (and (eq (car-safe (car vec)) 'var)
- (let ((st (assq (nth 1 (car vec))
- math-super-types)))
- (cond (st (setq type (append type st)))
- ((eq (nth 1 (car vec)) 'pos)
- (setq type (append type
- '(real number))
- range
- '(intv 1 0 (var inf var-inf))))
- ((eq (nth 1 (car vec)) 'nonneg)
- (setq type (append type
- '(real number))
- range
- '(intv 3 0
- (var inf var-inf))))))))
- (if vec
- (setq type (append type '(real number))
- range (math-prepare-set (cons 'vec vec))))
- (setq type (list type range))
- (or (eq (car-safe v) 'vec)
- (setq v (list 'vec v)))
- (while (setq v (cdr v))
- (if (or (eq (car-safe (car v)) 'var)
- (not (Math-primp (car v))))
- (setq math-decls-cache
- (cons (cons (if (eq (car (car v)) 'var)
- (nth 2 (car v))
- (car (car v)))
- type)
- math-decls-cache)))))
- (error nil)))))
+ (ignore-errors
+ (let ((v (nth 1 (car p))))
+ (setq type nil range nil)
+ (or (eq (car-safe vec) 'vec)
+ (setq vec (list 'vec vec)))
+ (while (and (setq vec (cdr vec))
+ (not (Math-objectp (car vec))))
+ (and (eq (car-safe (car vec)) 'var)
+ (let ((st (assq (nth 1 (car vec))
+ math-super-types)))
+ (cond (st (setq type (append type st)))
+ ((eq (nth 1 (car vec)) 'pos)
+ (setq type (append type
+ '(real number))
+ range
+ '(intv 1 0 (var inf var-inf))))
+ ((eq (nth 1 (car vec)) 'nonneg)
+ (setq type (append type
+ '(real number))
+ range
+ '(intv 3 0
+ (var inf var-inf))))))))
+ (if vec
+ (setq type (append type '(real number))
+ range (math-prepare-set (cons 'vec vec))))
+ (setq type (list type range))
+ (or (eq (car-safe v) 'vec)
+ (setq v (list 'vec v)))
+ (while (setq v (cdr v))
+ (if (or (eq (car-safe (car v)) 'var)
+ (not (Math-primp (car v))))
+ (setq math-decls-cache
+ (cons (cons (if (eq (car (car v)) 'var)
+ (nth 2 (car v))
+ (car (car v)))
+ type)
+ math-decls-cache)))))))))
(setq math-decls-all (assq 'var-All math-decls-cache)))))
(defun math-known-scalarp (a &optional assume-scalar)
@@ -2391,7 +2390,7 @@
(math-trunc (nth 3 a)))))
((math-provably-integerp a) a)
((Math-vectorp a)
- (math-map-vec (function (lambda (x) (math-trunc x math-trunc-prec))) a))
+ (math-map-vec (lambda (x) (math-trunc x math-trunc-prec)) a))
((math-infinitep a)
(if (or (math-posp a) (math-negp a))
a
@@ -2454,7 +2453,7 @@
(math-add (math-floor (nth 3 a)) -1)
(math-floor (nth 3 a)))))
((Math-vectorp a)
- (math-map-vec (function (lambda (x) (math-floor x math-floor-prec))) a))
+ (math-map-vec (lambda (x) (math-floor x math-floor-prec)) a))
((math-infinitep a)
(if (or (math-posp a) (math-negp a))
a
@@ -2521,7 +2520,7 @@
(math-ceiling (nth 2 a)))
(math-ceiling (nth 3 a))))
((Math-vectorp a)
- (math-map-vec (function (lambda (x) (math-ceiling x prec))) a))
+ (math-map-vec (lambda (x) (math-ceiling x prec)) a))
((math-infinitep a)
(if (or (math-posp a) (math-negp a))
a
@@ -2574,7 +2573,7 @@
((eq (car a) 'intv)
(math-floor (math-add a '(frac 1 2))))
((Math-vectorp a)
- (math-map-vec (function (lambda (x) (math-round x prec))) a))
+ (math-map-vec (lambda (x) (math-round x prec)) a))
((math-infinitep a)
(if (or (math-posp a) (math-negp a))
a
@@ -2657,7 +2656,7 @@
(calcFunc-scf (nth 2 x) n)
(calcFunc-scf (nth 3 x) n))))
((eq (car x) 'vec)
- (math-map-vec (function (lambda (x) (calcFunc-scf x n))) x))
+ (math-map-vec (lambda (x) (calcFunc-scf x n)) x))
((math-infinitep x)
x)
(t
@@ -2892,7 +2891,7 @@
(eq a b))
(list 'calcFunc-exp sumpow))
(t
- (condition-case err
+ (condition-case nil
(math-pow a sumpow)
(inexact-result (list '^ a sumpow)))))))))
(and math-simplifying-units
@@ -2927,7 +2926,7 @@
(math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
(t
(setq a (math-mul a b))
- (condition-case err
+ (condition-case nil
(math-pow a apow)
(inexact-result (list '^ a apow)))))))))))
diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index 8ab35365eba..503ed777029 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -1,4 +1,4 @@
-;;; calc-bin.el --- binary functions for Calc
+;;; calc-bin.el --- binary functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -126,8 +126,8 @@
(defun calc-word-size (n)
(interactive "P")
(calc-wrapper
- (or n (setq n (read-string (format "Binary word size: (default %d) "
- calc-word-size))))
+ (or n (setq n (read-string (format-prompt "Binary word size"
+ calc-word-size))))
(setq n (if (stringp n)
(if (equal n "")
calc-word-size
@@ -145,9 +145,10 @@
(setq math-half-2-word-size (math-power-of-2 (1- (math-abs n))))
(calc-do-refresh)
(calc-refresh-evaltos)
- (if (< n 0)
- (message "Binary word size is %d bits (two's complement)" (- n))
- (message "Binary word size is %d bits" n))))
+ (cond
+ ((< n 0) (message "Binary word size is %d bits (two's complement)" (- n)))
+ ((> n 0) (message "Binary word size is %d bits" n))
+ (t (message "No fixed binary word size")))))
@@ -198,48 +199,16 @@
(message "Omitting leading zeros on integers"))))
-(defvar math-power-of-2-cache (list 1 2 4 8 16 32 64 128 256 512 1024))
-(defvar math-big-power-of-2-cache nil)
(defun math-power-of-2 (n) ; [I I] [Public]
- (if (and (natnump n) (<= n 100))
- (or (nth n math-power-of-2-cache)
- (let* ((i (length math-power-of-2-cache))
- (val (nth (1- i) math-power-of-2-cache)))
- (while (<= i n)
- (setq val (math-mul val 2)
- math-power-of-2-cache (nconc math-power-of-2-cache
- (list val))
- i (1+ i)))
- val))
- (let ((found (assq n math-big-power-of-2-cache)))
- (if found
- (cdr found)
- (let ((po2 (math-ipow 2 n)))
- (setq math-big-power-of-2-cache
- (cons (cons n po2) math-big-power-of-2-cache))
- po2)))))
+ (if (natnump n)
+ (ash 1 n)
+ (error "argument must be a natural number")))
(defun math-integer-log2 (n) ; [I I] [Public]
- (let ((i 0)
- (p math-power-of-2-cache)
- val)
- (while (and p (Math-natnum-lessp (setq val (car p)) n))
- (setq p (cdr p)
- i (1+ i)))
- (if p
- (and (equal val n)
- i)
- (while (Math-natnum-lessp
- (prog1
- (setq val (math-mul val 2))
- (setq math-power-of-2-cache (nconc math-power-of-2-cache
- (list val))))
- n)
- (setq i (1+ i)))
- (and (equal val n)
- i))))
-
-
+ (and (natnump n)
+ (not (zerop n))
+ (zerop (logand n (1- n)))
+ (logb n)))
;;; Bitwise operations.
@@ -262,9 +231,10 @@
(defun math-binary-arg (a w)
(if (not (Math-integerp a))
(setq a (math-trunc a)))
- (if (< a 0)
- (logand a (1- (ash 1 (if w (math-trunc w) calc-word-size))))
- a))
+ (let ((w (if w (math-trunc w) calc-word-size)))
+ (if (and (< a 0) (not (zerop w)))
+ (logand a (1- (ash 1 w)))
+ a)))
(defun math-binary-modulo-args (f a b w)
(let (mod)
@@ -285,7 +255,7 @@
(let ((bits (math-integer-log2 mod)))
(if bits
(if w
- (if (/= w bits)
+ (if (and (/= w bits) (not (zerop w)))
(calc-record-why
"*Warning: Modulus inconsistent with word size"))
(setq w bits))
@@ -371,11 +341,12 @@
(math-clip (calcFunc-lsh a n (- w)) w)
(if (Math-integer-negp a)
(setq a (math-clip a w)))
- (cond ((or (Math-lessp n (- w))
- (Math-lessp w n))
+ (cond ((and (or (Math-lessp n (- w))
+ (Math-lessp w n))
+ (not (zerop w)))
0)
((< n 0)
- (math-quotient (math-clip a w) (math-power-of-2 (- n))))
+ (ash (math-clip a w) n))
(t
(math-clip (math-mul a (math-power-of-2 n)) w))))))
@@ -401,9 +372,10 @@
(math-clip (calcFunc-ash a n (- w)) w)
(if (Math-integer-negp a)
(setq a (math-clip a w)))
- (let ((two-to-sizem1 (math-power-of-2 (1- w)))
+ (let ((two-to-sizem1 (and (not (zerop w)) (math-power-of-2 (1- w))))
(sh (calcFunc-lsh a n w)))
- (cond ((Math-natnum-lessp a two-to-sizem1)
+ (cond ((or (zerop w)
+ (zerop (logand a two-to-sizem1)))
sh)
((Math-lessp n (- 1 w))
(math-add (math-mul two-to-sizem1 2) -1))
@@ -421,6 +393,8 @@
(if (eq (car-safe a) 'mod)
(math-binary-modulo-args 'calcFunc-rot a n w)
(setq w (if w (math-trunc w) calc-word-size))
+ (when (zerop w)
+ (error "Rotation requires a nonzero word size"))
(or (integerp w)
(math-reject-arg w 'fixnump))
(or (Math-integerp a)
@@ -432,7 +406,7 @@
(if (Math-integer-negp a)
(setq a (math-clip a w)))
(cond ((or (Math-integer-negp n)
- (not (Math-natnum-lessp n w)))
+ (>= n w))
(calcFunc-rot a (math-mod n w) w))
(t
(math-add (calcFunc-lsh a (- n w) w)
@@ -449,9 +423,11 @@
(math-reject-arg a 'integerp))
((< (or w (setq w calc-word-size)) 0)
(setq a (math-clip a (- w)))
- (if (Math-natnum-lessp a (math-power-of-2 (- -1 w)))
+ (if (< a (math-power-of-2 (- -1 w)))
a
(math-sub a (math-power-of-2 (- w)))))
+ ((math-zerop w)
+ a)
((Math-negp a)
(math-binary-arg a w))
((integerp a)
@@ -682,6 +658,8 @@
(defun math-format-twos-complement (a)
"Format an integer in two's complement mode."
+ (when (zerop calc-word-size)
+ (error "Nonzero word size required"))
(let* (;(calc-leading-zeros t)
(num
(cond
diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el
index cb84173c018..dc952213507 100644
--- a/lisp/calc/calc-comb.el
+++ b/lisp/calc/calc-comb.el
@@ -1,4 +1,4 @@
-;;; calc-comb.el --- combinatoric functions for Calc
+;;; calc-comb.el --- combinatoric functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -241,8 +241,8 @@
(calcFunc-gcd (math-neg a) b))
((Math-looks-negp b)
(calcFunc-gcd a (math-neg b)))
- ((Math-zerop a) b)
- ((Math-zerop b) a)
+ ((Math-zerop a) (math-abs b))
+ ((Math-zerop b) (math-abs a))
((and (Math-ratp a)
(Math-ratp b))
(math-make-frac (math-gcd (if (eq (car-safe a) 'frac) (nth 1 a) a)
@@ -292,15 +292,9 @@
(defconst math-small-factorial-table
(vector 1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800
- (math-read-number-simple "479001600")
- (math-read-number-simple "6227020800")
- (math-read-number-simple "87178291200")
- (math-read-number-simple "1307674368000")
- (math-read-number-simple "20922789888000")
- (math-read-number-simple "355687428096000")
- (math-read-number-simple "6402373705728000")
- (math-read-number-simple "121645100408832000")
- (math-read-number-simple "2432902008176640000")))
+ 479001600 6227020800 87178291200 1307674368000 20922789888000
+ 355687428096000 6402373705728000 121645100408832000
+ 2432902008176640000))
(defun calcFunc-fact (n) ; [I I] [F F] [Public]
(let (temp)
@@ -445,12 +439,25 @@
(math-div (calcFunc-fact (math-float n))
(math-mul (calcFunc-fact m)
(calcFunc-fact (math-sub n m))))))
- ((math-negp m) 0)
- ((math-negp n)
- (let ((val (calcFunc-choose (math-add (math-add n m) -1) m)))
+ ;; For the extension to negative integer arguments we follow
+ ;; M. J. Kronenburg, The Binomial Coefficient for Negative Arguments,
+ ;; arXiv:1105.3689v2
+ ((and (math-negp n) (not (math-negp m)))
+ ;; n<0≤m: (n choose m) = (-1)^m (-n+m-1 choose m)
+ (let ((val (calcFunc-choose (math-add (math-sub m n) -1) m)))
(if (math-evenp (math-trunc m))
val
(math-neg val))))
+ ((and (math-negp n) (math-num-integerp n))
+ (if (math-lessp n m)
+ 0
+ ;; m≤n<0: (n choose m) = (-1)^(n-m) (-m-1 choose n-m)
+ (let ((val (calcFunc-choose (math-sub (math-neg m) 1)
+ (math-sub n m))))
+ (if (math-evenp (math-sub n m))
+ val
+ (math-neg val)))))
+ ((math-negp m) 0)
((and (math-num-integerp n)
(Math-lessp n m))
0)
@@ -467,20 +474,23 @@
(math-choose-float-iter tm n 1 1)))))))
(defun math-choose-iter (m n i c)
- (if (and (= (% i 5) 1) (> i 5))
+ (while (<= i m)
+ (when (and (= (% i 5) 1) (> i 5))
(math-working (format "choose(%d)" (1- i)) c))
- (if (<= i m)
- (math-choose-iter m (1- n) (1+ i)
- (math-quotient (math-mul c n) i))
- c))
+ (setq c (math-quotient (math-mul c n) i))
+ (setq n (1- n))
+ (setq i (1+ i)))
+ c)
(defun math-choose-float-iter (count n i c)
- (if (= (% i 5) 1)
+ (while (> count 0)
+ (when (= (% i 5) 1)
(math-working (format "choose(%d)" (1- i)) c))
- (if (> count 0)
- (math-choose-float-iter (1- count) (math-sub n 1) (1+ i)
- (math-div (math-mul c n) i))
- c))
+ (setq c (math-div (math-mul c n) i))
+ (setq n (math-sub n 1))
+ (setq i (1+ i))
+ (setq count (1- count)))
+ c)
;;; Stirling numbers.
@@ -805,7 +815,7 @@
(error "Argument must be an integer"))
((Math-integer-negp n)
'(nil))
- ((Math-natnum-lessp n 8000000)
+ ((< n 8000000)
(let ((i -1) v)
(while (and (> (% n (setq v (aref math-primes-table
(setq i (1+ i)))))
@@ -903,7 +913,7 @@
(if (Math-messy-integerp n)
(setq n (math-trunc n)))
(if (Math-natnump n)
- (if (Math-natnum-lessp 2 n)
+ (if (< 2 n)
(let (factors res p (i 0))
(while (and (not (eq n 1))
(< i (length math-primes-table)))
@@ -917,7 +927,7 @@
(setq factors (nconc factors (list p))
n (car res)))
(or (eq n 1)
- (Math-natnum-lessp p (car res))
+ (< p (car res))
(setq factors (nconc factors (list n))
n 1))
(setq i (1+ i)))
@@ -936,7 +946,7 @@
(if (Math-messy-integerp n)
(setq n (math-trunc n)))
(if (Math-natnump n)
- (if (Math-natnum-lessp n 2)
+ (if (< n 2)
(if (Math-negp n)
(calcFunc-totient (math-abs n))
n)
@@ -959,7 +969,7 @@
(if (Math-messy-integerp n)
(setq n (math-trunc n)))
(if (and (Math-natnump n) (not (eq n 0)))
- (if (Math-natnum-lessp n 2)
+ (if (< n 2)
(if (Math-negp n)
(calcFunc-moebius (math-abs n))
1)
diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el
index da36c7cfe2e..03462020ea2 100644
--- a/lisp/calc/calc-cplx.el
+++ b/lisp/calc/calc-cplx.el
@@ -1,4 +1,4 @@
-;;; calc-cplx.el --- Complex number functions for Calc
+;;; calc-cplx.el --- Complex number functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el
index 1e5880370bb..74551404776 100644
--- a/lisp/calc/calc-embed.el
+++ b/lisp/calc/calc-embed.el
@@ -1,4 +1,4 @@
-;;; calc-embed.el --- embed Calc in a buffer
+;;; calc-embed.el --- embed Calc in a buffer -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -46,10 +46,8 @@
(defvar calc-embedded-modes nil)
(defvar calc-embedded-globals nil)
(defvar calc-embedded-active nil)
-(defvar calc-embedded-all-active nil)
-(make-variable-buffer-local 'calc-embedded-all-active)
-(defvar calc-embedded-some-active nil)
-(make-variable-buffer-local 'calc-embedded-some-active)
+(defvar-local calc-embedded-all-active nil)
+(defvar-local calc-embedded-some-active nil)
;; The following variables are customizable and defined in calc.el.
(defvar calc-embedded-announce-formula)
@@ -219,13 +217,17 @@
(defvar calc-override-minor-modes
(cons t calc-override-minor-modes-map))
-(defun calc-do-embedded (calc-embed-arg end obeg oend)
+(defvar calc-embedded-no-reselect nil)
+
+(defun calc-do-embedded (embed-arg end obeg oend)
+ (let ((calc-embed-arg embed-arg))
(if calc-embedded-info
;; Turn embedded mode off or switch to a new buffer.
(cond ((eq (current-buffer) (aref calc-embedded-info 1))
(let ((calcbuf (current-buffer))
- (buf (aref calc-embedded-info 0)))
+ ;; (buf (aref calc-embedded-info 0))
+ )
(calc-embedded-original-buffer t)
(calc-embedded nil)
(switch-to-buffer calcbuf)))
@@ -291,7 +293,7 @@
(calc-embedded-info info)
(calc-embedded-no-reselect t))
(calc-wrapper
- (let* ((okay nil)
+ (let* (;; (okay nil)
(calc-no-refresh-evaltos t))
(if (aref info 8)
(progn
@@ -336,7 +338,7 @@
"Type `C-x * x'"
"Give this command again")
" to return to normal")))))
- (scroll-down 0)) ; fix a bug which occurs when truncate-lines is changed.
+ (scroll-down 0))) ; fix a bug which occurs when truncate-lines is changed.
(defun calc-embedded-select (arg)
@@ -353,9 +355,10 @@
(calc-select-part 2)))
-(defun calc-embedded-update-formula (calc-embed-arg)
+(defun calc-embedded-update-formula (embed-arg)
(interactive "P")
- (if calc-embed-arg
+ (let ((calc-embed-arg embed-arg))
+ (if embed-arg
(let ((entry (assq (current-buffer) calc-embedded-active)))
(while (setq entry (cdr entry))
(and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto)
@@ -376,12 +379,13 @@
(progn
(save-excursion
(calc-embedded-update info 14 'eval t))
- (goto-char (+ (aref info 4) pt))))))))
+ (goto-char (+ (aref info 4) pt)))))))))
-(defun calc-embedded-edit (calc-embed-arg)
+(defun calc-embedded-edit (embed-arg)
(interactive "P")
- (let ((info (calc-embedded-make-info (point) nil t calc-embed-arg))
+ (let ((calc-embed-arg embed-arg))
+ (let ((info (calc-embedded-make-info (point) nil t embed-arg))
str)
(if (eq (car-safe (aref info 8)) 'error)
(progn
@@ -390,17 +394,16 @@
(calc-wrapper
(setq str (math-showing-full-precision
(math-format-nice-expr (aref info 8) (frame-width))))
- (calc-edit-mode (list 'calc-embedded-finish-edit info))
+ (calc--edit-mode (lambda () (calc-embedded-finish-edit info)))
(insert str "\n")))
- (calc-show-edit-buffer))
+ (calc-show-edit-buffer)))
(defvar calc-original-buffer)
(defvar calc-edit-top)
(defun calc-embedded-finish-edit (info)
(let ((buf (current-buffer))
(str (buffer-substring calc-edit-top (point-max)))
- (start (point))
- pos)
+ (start (point))) ;; pos
(switch-to-buffer calc-original-buffer)
(let ((val (with-current-buffer (aref info 1)
(let ((calc-language nil)
@@ -416,7 +419,8 @@
(calc-embedded-update info 14 t t))))
;;;###autoload
-(defun calc-do-embedded-activate (calc-embed-arg cbuf)
+(defun calc-do-embedded-activate (embed-arg cbuf)
+ (let ((calc-embed-arg embed-arg))
(calc-plain-buffer-only)
(if calc-embed-arg
(calc-embedded-forget))
@@ -443,7 +447,7 @@
(or (eq (car-safe (aref info 8)) 'error)
(goto-char (aref info 5))))))
(message "Activating %s for Calc Embedded mode...done" (buffer-name)))
- (calc-embedded-active-state t))
+ (calc-embedded-active-state t)))
(defun calc-plain-buffer-only ()
(if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode))
@@ -645,6 +649,8 @@ The command \\[yank] can retrieve it from there."
(defvar calc-embed-prev-modes)
(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
+ (defvar the-language)
+ (defvar the-display-just)
(let ((the-language (calc-embedded-language))
(the-display-just (calc-embedded-justify))
(v gmodes)
@@ -735,13 +741,13 @@ The command \\[yank] can retrieve it from there."
(defun calc-find-globals ()
(interactive)
- (and (eq major-mode 'calc-mode)
+ (and (derived-mode-p 'calc-mode)
(error "This command should be used in a normal editing buffer"))
(make-local-variable 'calc-embedded-globals)
(let ((case-fold-search nil)
(modes nil)
(save-pt (point))
- found value)
+ found) ;; value
(goto-char (point-min))
(while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t)
(and (setq found (assoc (buffer-substring (match-beginning 1)
@@ -764,7 +770,7 @@ The command \\[yank] can retrieve it from there."
(modes nil)
(emodes nil)
(pmodes nil)
- found value)
+ found) ;; value
(while (and no-defaults (search-backward "[calc-" nil t))
(forward-char 6)
(or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]")
@@ -817,9 +823,13 @@ The command \\[yank] can retrieve it from there."
(defvar calc-embed-vars-used)
(defun calc-embedded-make-info (point cbuf fresh &optional
- calc-embed-top calc-embed-bot
- calc-embed-outer-top calc-embed-outer-bot)
- (let* ((bufentry (assq (current-buffer) calc-embedded-active))
+ embed-top embed-bot
+ embed-outer-top embed-outer-bot)
+ (let* ((calc-embed-top embed-top)
+ (calc-embed-bot embed-bot)
+ (calc-embed-outer-top embed-outer-top)
+ (calc-embed-outer-bot embed-outer-bot)
+ (bufentry (assq (current-buffer) calc-embedded-active))
(found bufentry)
(force (and fresh calc-embed-top (null (equal calc-embed-top '(t)))))
(fixed calc-embed-top)
@@ -844,31 +854,21 @@ The command \\[yank] can retrieve it from there."
(newmode (cl-assoc-if #'derived-mode-p
calc-embedded-open-close-mode-alist)))
(when newann
- (make-local-variable 'calc-embedded-announce-formula)
- (setq calc-embedded-announce-formula (cdr newann)))
+ (setq-local calc-embedded-announce-formula (cdr newann)))
(when newform
- (make-local-variable 'calc-embedded-open-formula)
- (make-local-variable 'calc-embedded-close-formula)
- (setq calc-embedded-open-formula (nth 0 (cdr newform)))
- (setq calc-embedded-close-formula (nth 1 (cdr newform))))
+ (setq-local calc-embedded-open-formula (nth 0 (cdr newform)))
+ (setq-local calc-embedded-close-formula (nth 1 (cdr newform))))
(when newword
- (make-local-variable 'calc-embedded-word-regexp)
- (setq calc-embedded-word-regexp (nth 1 newword)))
+ (setq-local calc-embedded-word-regexp (nth 1 newword)))
(when newplain
- (make-local-variable 'calc-embedded-open-plain)
- (make-local-variable 'calc-embedded-close-plain)
- (setq calc-embedded-open-plain (nth 0 (cdr newplain)))
- (setq calc-embedded-close-plain (nth 1 (cdr newplain))))
+ (setq-local calc-embedded-open-plain (nth 0 (cdr newplain)))
+ (setq-local calc-embedded-close-plain (nth 1 (cdr newplain))))
(when newnewform
- (make-local-variable 'calc-embedded-open-new-formula)
- (make-local-variable 'calc-embedded-close-new-formula)
- (setq calc-embedded-open-new-formula (nth 0 (cdr newnewform)))
- (setq calc-embedded-close-new-formula (nth 1 (cdr newnewform))))
+ (setq-local calc-embedded-open-new-formula (nth 0 (cdr newnewform)))
+ (setq-local calc-embedded-close-new-formula (nth 1 (cdr newnewform))))
(when newmode
- (make-local-variable 'calc-embedded-open-mode)
- (make-local-variable 'calc-embedded-close-mode)
- (setq calc-embedded-open-mode (nth 0 (cdr newmode)))
- (setq calc-embedded-close-mode (nth 1 (cdr newmode)))))))
+ (setq-local calc-embedded-open-mode (nth 0 (cdr newmode)))
+ (setq-local calc-embedded-close-mode (nth 1 (cdr newmode)))))))
(while (and (cdr found)
(> point (aref (car (cdr found)) 3)))
(setq found (cdr found)))
@@ -1175,7 +1175,6 @@ The command \\[yank] can retrieve it from there."
;;; These are hooks called by the main part of Calc.
-(defvar calc-embedded-no-reselect nil)
(defun calc-embedded-select-buffer ()
(if (eq (current-buffer) (aref calc-embedded-info 0))
(let ((info calc-embedded-info)
@@ -1240,7 +1239,7 @@ The command \\[yank] can retrieve it from there."
(with-current-buffer (aref calc-embedded-info 1)
(let* ((info calc-embedded-info)
(extra-line (if (eq calc-language 'big) 1 0))
- (the-point (point))
+ ;; (the-point (point))
(empty (= (calc-stack-size) 0))
(entry (if empty
(list '(var empty var-empty) 1 nil)
@@ -1274,6 +1273,7 @@ The command \\[yank] can retrieve it from there."
(set-buffer-modified-p (buffer-modified-p)))))
(defun calc-embedded-modes-change (vars)
+ (defvar the-language) (defvar the-display-just)
(if (eq (car vars) 'calc-language) (setq vars '(the-language)))
(if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just)))
(while (and vars
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index 1949ecb1380..e85ecf03906 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -678,14 +678,13 @@
(calc-init-prefixes)
- (mapc (function
- (lambda (x)
+ (mapc (lambda (x)
(define-key calc-mode-map (format "c%c" x) 'calc-clean-num)
(define-key calc-mode-map (format "j%c" x) 'calc-select-part)
(define-key calc-mode-map (format "r%c" x) 'calc-recall-quick)
(define-key calc-mode-map (format "s%c" x) 'calc-store-quick)
(define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick)
- (define-key calc-mode-map (format "u%c" x) 'calc-quick-units)))
+ (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))
"0123456789")
(let ((i ?A))
@@ -711,9 +710,9 @@
(define-key calc-alg-map "\e\177" 'calc-pop-above)
;;;; (Autoloads here)
- (mapc (function (lambda (x)
- (mapcar (function (lambda (func) (autoload func (car x))))
- (cdr x))))
+ (mapc (lambda (x)
+ (mapcar (lambda (func) (autoload func (car x)))
+ (cdr x)))
'(
("calc-alg" calc-has-rules math-defsimplify
@@ -980,9 +979,9 @@ calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer)
))
- (mapcar (function (lambda (x)
- (mapcar (function (lambda (cmd) (autoload cmd (car x) nil t)))
- (cdr x))))
+ (mapcar (lambda (x)
+ (mapcar (lambda (cmd) (autoload cmd (car x) nil t))
+ (cdr x)))
'(
("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand
@@ -1196,7 +1195,7 @@ calc-set-xor calc-sort calc-subvector calc-tail calc-transpose
calc-unpack calc-unpack-bits calc-vector-find calc-vlength)
("calc-yank" calc-copy-as-kill calc-copy-region-as-kill
-calc-copy-to-buffer calc-edit calc-edit-cancel calc-edit-mode
+calc-copy-to-buffer calc-edit calc-edit-cancel calc--edit-mode
calc-kill calc-kill-region calc-yank))))
(defun calc-init-prefixes ()
@@ -1358,7 +1357,7 @@ calc-kill calc-kill-region calc-yank))))
calc-redo-list nil)
(let (calc-stack calc-user-parse-tables calc-standard-date-formats
calc-invocation-macro)
- (mapc (function (lambda (v) (set v nil))) calc-local-var-list)
+ (mapc (lambda (v) (set v nil)) calc-local-var-list)
(if (and arg (<= arg 0))
(calc-mode-var-list-restore-default-values)
(calc-mode-var-list-restore-saved-values)))
@@ -1398,9 +1397,8 @@ calc-kill calc-kill-region calc-yank))))
(defun calc-scroll-up (n)
(interactive "P")
- (condition-case nil
- (scroll-up (or n (/ (window-height) 2)))
- (error nil))
+ (ignore-errors
+ (scroll-up (or n (/ (window-height) 2))))
(if (pos-visible-in-window-p (max 1 (- (point-max) 2)))
(if (eq major-mode 'calc-mode)
(calc-realign)
@@ -1659,7 +1657,7 @@ calc-kill calc-kill-region calc-yank))))
(calc-pop-stack n 1 t)
(calc-push-list (mapcar #'car entries)
1
- (mapcar (function (lambda (x) (nth 2 x)))
+ (mapcar (lambda (x) (nth 2 x))
entries)))))))
(defvar calc-refreshing-evaltos nil)
@@ -1925,11 +1923,10 @@ calc-kill calc-kill-region calc-yank))))
(let* ((calc-z-prefix-msgs nil)
(calc-z-prefix-buf "")
(kmap (sort (copy-sequence (calc-user-key-map))
- (function (lambda (x y) (< (car x) (car y))))))
+ (lambda (x y) (< (car x) (car y)))))
(flags (apply #'logior
- (mapcar (function
- (lambda (k)
- (calc-user-function-classify (car k))))
+ (mapcar (lambda (k)
+ (calc-user-function-classify (car k)))
kmap))))
(if (= (logand flags 8) 0)
(calc-user-function-list kmap 7)
@@ -2420,17 +2417,6 @@ If X is not an error form, return 1."
(mapcar #'math-normalize (cdr a))))))
-;;; Normalize a bignum digit list by trimming high-end zeros. [L l]
-(defun math-norm-bignum (a)
- (let ((digs a) (last nil))
- (while digs
- (or (eq (car digs) 0) (setq last digs))
- (setq digs (cdr digs)))
- (and last
- (progn
- (setcdr last nil)
- a))))
-
;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public]
(defun calcFunc-sign (a &optional x)
(let ((signs (math-possible-signs a)))
@@ -2545,23 +2531,6 @@ If X is not an error form, return 1."
0
2))))
-;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B.
-(defun math-compare-bignum (a b) ; [S l l]
- (let ((res 0))
- (while (and a b)
- (if (< (car a) (car b))
- (setq res -1)
- (if (> (car a) (car b))
- (setq res 1)))
- (setq a (cdr a)
- b (cdr b)))
- (if a
- (progn
- (while (eq (car a) 0) (setq a (cdr a)))
- (if a 1 res))
- (while (eq (car b) 0) (setq b (cdr b)))
- (if b -1 res))))
-
(defun math-compare-lists (a b)
(cond ((null a) (null b))
((null b) nil)
@@ -2596,9 +2565,9 @@ If X is not an error form, return 1."
;;; True if A is numerically equal to the integer B. [P N S] [Public]
;;; B must not be a multiple of 10.
(defun math-equal-int (a b)
- (or (eq a b)
+ (or (eql a b)
(and (eq (car-safe a) 'float)
- (eq (nth 1 a) b)
+ (eql (nth 1 a) b)
(= (nth 2 a) 0))))
@@ -2634,9 +2603,8 @@ If X is not an error form, return 1."
(let ((rhs (calc-top-n 1)))
(calc-enter-result (- 1 n)
name
- (mapcar (function
- (lambda (x)
- (list func x rhs)))
+ (mapcar (lambda (x)
+ (list func x rhs))
(calc-top-list-n (- n) 2))))))))
(defun calc-unary-op-fancy (name func arg)
@@ -2645,9 +2613,8 @@ If X is not an error form, return 1."
(cond ((> n 0)
(calc-enter-result n
name
- (mapcar (function
- (lambda (x)
- (list func x)))
+ (mapcar (lambda (x)
+ (list func x))
(calc-top-list-n n))))
((< n 0)
(calc-enter-result 1
@@ -2690,7 +2657,7 @@ If X is not an error form, return 1."
(if (Math-integer-negp a) (setq a (math-neg a)))
(if (Math-integer-negp b) (setq b (math-neg b)))
(let (c)
- (if (Math-natnum-lessp a b)
+ (if (< a b)
(setq c b b a a c))
(while (and (consp a) (not (eq b 0)))
(setq c b
@@ -2817,23 +2784,23 @@ If X is not an error form, return 1."
(declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-integral
- (nconc
- (get ',func 'math-integral)
- (list
- #'(lambda (u) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-integral
+ (nconc
+ (get ',func 'math-integral)
+ (list
+ (lambda (u) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(defmacro math-defintegral-2 (funcs &rest code)
(declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-integral-2
- (nconc
- (get ',func 'math-integral-2)
- (list #'(lambda (u v) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-integral-2
+ (nconc
+ (get ',func 'math-integral-2)
+ (list (lambda (u v) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(defvar var-IntegAfterRules 'calc-IntegAfterRules)
@@ -3095,6 +3062,7 @@ If X is not an error form, return 1."
(defvar math-read-big-baseline)
(defvar math-read-big-h2)
(defvar math-read-big-err-msg)
+(defvar math-read-big-lines)
(defun math-read-big-expr (str)
(and (> (length calc-left-label) 0)
@@ -3139,41 +3107,42 @@ If X is not an error form, return 1."
(defvar math-rb-h2)
-(defun math-read-big-bigp (math-read-big-lines)
- (and (cdr math-read-big-lines)
- (let ((matrix nil)
- (v 0)
- (height (if (> (length (car math-read-big-lines)) 0) 1 0)))
- (while (and (cdr math-read-big-lines)
- (let* ((i 0)
- j
- (l1 (car math-read-big-lines))
- (l2 (nth 1 math-read-big-lines))
- (len (min (length l1) (length l2))))
- (if (> (length l2) 0)
- (setq height (1+ height)))
- (while (and (< i len)
- (or (memq (aref l1 i) '(?\ ?\- ?\_))
- (memq (aref l2 i) '(?\ ?\-))
- (and (memq (aref l1 i) '(?\| ?\,))
- (= (aref l2 i) (aref l1 i)))
- (and (eq (aref l1 i) ?\[)
- (eq (aref l2 i) ?\[)
- (let ((math-rb-h2 (length l1)))
- (setq j (math-read-big-balance
- (1+ i) v "[")))
- (setq i (1- j)))))
- (setq i (1+ i)))
- (or (= i len)
- (and (eq (aref l1 i) ?\[)
- (eq (aref l2 i) ?\[)
- (setq matrix t)
- nil))))
- (setq math-read-big-lines (cdr math-read-big-lines)
- v (1+ v)))
- (or (and (> height 1)
- (not (cdr math-read-big-lines)))
- matrix))))
+(defun math-read-big-bigp (read-big-lines)
+ (when (cdr read-big-lines)
+ (let ((math-read-big-lines read-big-lines)
+ (matrix nil)
+ (v 0)
+ (height (if (> (length (car read-big-lines)) 0) 1 0)))
+ (while (and (cdr math-read-big-lines)
+ (let* ((i 0)
+ j
+ (l1 (car math-read-big-lines))
+ (l2 (nth 1 math-read-big-lines))
+ (len (min (length l1) (length l2))))
+ (if (> (length l2) 0)
+ (setq height (1+ height)))
+ (while (and (< i len)
+ (or (memq (aref l1 i) '(?\ ?\- ?\_))
+ (memq (aref l2 i) '(?\ ?\-))
+ (and (memq (aref l1 i) '(?\| ?\,))
+ (= (aref l2 i) (aref l1 i)))
+ (and (eq (aref l1 i) ?\[)
+ (eq (aref l2 i) ?\[)
+ (let ((math-rb-h2 (length l1)))
+ (setq j (math-read-big-balance
+ (1+ i) v "[")))
+ (setq i (1- j)))))
+ (setq i (1+ i)))
+ (or (= i len)
+ (and (eq (aref l1 i) ?\[)
+ (eq (aref l2 i) ?\[)
+ (setq matrix t)
+ nil))))
+ (setq math-read-big-lines (cdr math-read-big-lines)
+ v (1+ v)))
+ (or (and (> height 1)
+ (not (cdr math-read-big-lines)))
+ matrix))))
;;; Nontrivial "flat" formatting.
@@ -3457,6 +3426,8 @@ A command spec is a command name symbol, a keyboard macro string, a
list containing a numeric entry string, or nil.
A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.")
+(make-obsolete-variable 'calc-ext-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'calc-ext-load-hook)
(provide 'calc-ext)
diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el
index 799b4b863e9..76bb53e7b10 100644
--- a/lisp/calc/calc-fin.el
+++ b/lisp/calc/calc-fin.el
@@ -1,4 +1,4 @@
-;;; calc-fin.el --- financial functions for Calc
+;;; calc-fin.el --- financial functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el
index 19badd42ec3..ee53b94cd64 100644
--- a/lisp/calc/calc-forms.el
+++ b/lisp/calc/calc-forms.el
@@ -1,4 +1,4 @@
-;;; calc-forms.el --- data format conversion functions for Calc
+;;; calc-forms.el --- data format conversion functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -678,10 +678,11 @@ in the Gregorian calendar."
(defvar math-fd-isoweek)
(defvar math-fd-isoweekday)
-(defun math-format-date (math-fd-date)
- (if (eq (car-safe math-fd-date) 'date)
- (setq math-fd-date (nth 1 math-fd-date)))
- (let ((entry (list math-fd-date calc-internal-prec calc-date-format)))
+(defun math-format-date (fd-date)
+ (let* ((math-fd-date (if (eq (car-safe fd-date) 'date)
+ (nth 1 fd-date)
+ fd-date))
+ (entry (list math-fd-date calc-internal-prec calc-date-format)))
(or (cdr (assoc entry math-format-date-cache))
(let* ((math-fd-dt nil)
(math-fd-iso-dt nil)
@@ -709,6 +710,10 @@ as measured in the number of days before December 31, 1 BC (Gregorian).")
"The beginning of the Julian date calendar,
as measured in the integer number of days before December 31, 1 BC (Gregorian).")
+(defconst math-unix-epoch 719163
+ "The beginning of Unix time: days from December 31, 1 BC (Gregorian)
+to Jan 1, 1970 AD.")
+
(defun math-format-date-part (x)
(cond ((stringp x)
x)
@@ -730,7 +735,8 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(math-floor math-fd-date)
math-julian-date-beginning-int)))
((eq x 'U)
- (math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
+ (math-format-number (nth 1 (math-date-parts math-fd-date
+ math-unix-epoch))))
((memq x '(IYYY Iww w))
(progn
(or math-fd-iso-dt
@@ -909,15 +915,16 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
;; which is called by math-parse-date and math-parse-standard-date.
(defvar math-pd-str)
-(defun math-parse-date (math-pd-str)
+(defun math-parse-date (pd-str)
(catch 'syntax
- (or (math-parse-standard-date math-pd-str t)
- (math-parse-standard-date math-pd-str nil)
- (and (string-match "W[0-9][0-9]" math-pd-str)
- (math-parse-iso-date math-pd-str))
- (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" math-pd-str)
- (list 'date (math-read-number (math-match-substring math-pd-str 1))))
+ (or (math-parse-standard-date pd-str t)
+ (math-parse-standard-date pd-str nil)
+ (and (string-match "W[0-9][0-9]" pd-str)
+ (math-parse-iso-date pd-str))
+ (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" pd-str)
+ (list 'date (math-read-number (math-match-substring pd-str 1))))
(let ((case-fold-search t)
+ (math-pd-str pd-str)
(year nil) (month nil) (day nil) (weekday nil)
(hour nil) (minute nil) (second nil) (bc-flag nil)
(a nil) (b nil) (c nil) (bigyear nil) temp)
@@ -1123,8 +1130,9 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(substring math-pd-str (match-end 0))))
n))))
-(defun math-parse-standard-date (math-pd-str with-time)
- (let ((case-fold-search t)
+(defun math-parse-standard-date (pd-str with-time)
+ (let ((math-pd-str pd-str)
+ (case-fold-search t)
(okay t) num
(fmt calc-date-format) this next (gnext nil)
(isoyear nil) (isoweek nil) (isoweekday nil)
@@ -1173,7 +1181,7 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(setq num (math-match-substring math-pd-str 0)
math-pd-str (substring math-pd-str (match-end 0))
num (math-date-to-dt
- (math-add 719164
+ (math-add math-unix-epoch
(math-div (math-read-number num)
'(float 864 2))))
hour (nth 3 num)
@@ -1301,9 +1309,10 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(setq day (math-add day (1- yearday))))
day))))))
-(defun math-parse-iso-date (math-pd-str)
- "Parse MATH-PD-STR as an ISO week date, or return nil."
- (let ((case-fold-search t)
+(defun math-parse-iso-date (pd-str)
+ "Parse PD-STR as an ISO week date, or return nil."
+ (let ((math-pd-str pd-str)
+ (case-fold-search t)
(isoyear nil) (isoweek nil) (isoweekday nil)
(hour nil) (minute nil) (second nil))
;; Extract the time, if any.
@@ -1434,11 +1443,11 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
(defun calcFunc-unixtime (date &optional zone)
(if (math-realp date)
(progn
- (setq date (math-add 719163 (math-div date '(float 864 2))))
+ (setq date (math-add math-unix-epoch (math-div date '(float 864 2))))
(list 'date (math-sub date (math-div (calcFunc-tzone zone date)
'(float 864 2)))))
(if (eq (car date) 'date)
- (math-add (nth 1 (math-date-parts (nth 1 date) 719163))
+ (math-add (nth 1 (math-date-parts (nth 1 date) math-unix-epoch))
(calcFunc-tzone zone date))
(math-reject-arg date 'datep))))
@@ -1608,7 +1617,7 @@ and ends on the first Sunday of November at 2 a.m."
(math-std-daylight-savings-old date dt zone bump)
(math-std-daylight-savings-new date dt zone bump)))
-(defun math-std-daylight-savings-new (date dt zone bump)
+(defun math-std-daylight-savings-new (date dt _zone bump)
"Standard North American daylight saving algorithm as of 2007.
This implements the rules for the U.S. and Canada.
Daylight saving begins on the second Sunday of March at 2 a.m.,
@@ -1629,7 +1638,7 @@ and ends on the first Sunday of November at 2 a.m."
(t 0))))
(t 0)))
-(defun math-std-daylight-savings-old (date dt zone bump)
+(defun math-std-daylight-savings-old (date dt _zone bump)
"Standard North American daylight saving algorithm before 2007.
This implements the rules for the U.S. and Canada.
Daylight saving begins on the first Sunday of April at 2 a.m.,
@@ -1652,7 +1661,7 @@ and ends on the last Sunday of October at 2 a.m."
;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given
;;; day of the given month.
-(defun math-prev-weekday-in-month (date dt day wday)
+(defun math-prev-weekday-in-month (date dt day _wday)
(or day (setq day (nth 2 dt)))
(if (> day (math-days-in-month (car dt) (nth 1 dt)))
(setq day (math-days-in-month (car dt) (nth 1 dt))))
@@ -1870,8 +1879,8 @@ and ends on the last Sunday of October at 2 a.m."
(and days (= day (car days))
(setq holiday t)))
(let* ((weekdays (nth 3 math-holidays-cache))
- (weeks (1- (/ (+ day 6) 7)))
- (wkday (- day 1 (* weeks 7))))
+ (weeks (/ day 7))
+ (wkday (mod day 7))) ; Day of week: 0=Sunday, 6=Saturday
(setq delta (+ delta (* weeks (length weekdays))))
(while (and weekdays (< (car weekdays) wkday))
(setq weekdays (cdr weekdays)
@@ -1905,14 +1914,15 @@ and ends on the last Sunday of October at 2 a.m."
(setq delta (1+ delta)))
(setq day (+ day delta)))
(let* ((weekdays (nth 3 math-holidays-cache))
- (bweek (- 7 (length weekdays)))
- (weeks (1- (/ (+ day (1- bweek)) bweek)))
- (wkday (- day 1 (* weeks bweek)))
+ (bweek (- 7 (length weekdays))) ; Business days in a week, 1..7.
+ (weeks (/ day bweek)) ; Whole weeks.
+ (wkday (mod day bweek)) ; Business day in last week, 0..bweek-1
(w 0))
(setq day (+ day (* weeks (length weekdays))))
+ ;; Add business days in the last week; `w' is weekday, 0..6.
(while (if (memq w weekdays)
(setq day (1+ day))
- (> (setq wkday (1- wkday)) 0))
+ (>= (setq wkday (1- wkday)) 0))
(setq w (1+ w)))
(let ((hours (nth 7 math-holidays-cache)))
(if hours
@@ -2030,18 +2040,18 @@ and ends on the last Sunday of October at 2 a.m."
nil)))
(or done (setq math-holidays-cache-tag t))))))
-(defun math-setup-year-holidays (math-sh-year)
- (let ((exprs (nth 2 math-holidays-cache)))
- (while exprs
+(defun math-setup-year-holidays (sh-year)
+ (let ((math-sh-year sh-year))
+ (dolist (expr (nth 2 math-holidays-cache))
+ (defvar var-y) (defvar var-m)
(let* ((var-y math-sh-year)
(var-m nil)
- (expr (math-evaluate-expr (car exprs))))
+ (expr (math-evaluate-expr expr)))
(if (math-expr-contains expr '(var m var-m))
(let ((var-m 0))
(while (<= (setq var-m (1+ var-m)) 12)
(math-setup-add-holidays (math-evaluate-expr expr))))
- (math-setup-add-holidays expr)))
- (setq exprs (cdr exprs)))))
+ (math-setup-add-holidays expr))))))
(defun math-setup-add-holidays (days) ; uses "math-sh-year"
(cond ((eq (car-safe days) 'vec)
@@ -2119,7 +2129,7 @@ and ends on the last Sunday of October at 2 a.m."
((memq (car n) '(+ - / vec neg))
(math-normalize
(cons (car n)
- (mapcar (function (lambda (x) (math-make-mod x m)))
+ (mapcar (lambda (x) (math-make-mod x m))
(cdr n)))))
((and (eq (car n) '*) (Math-anglep (nth 1 n)))
(math-mul (math-make-mod (nth 1 n) m) (nth 2 n)))
diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el
index 3d289421caf..bf3c16816db 100644
--- a/lisp/calc/calc-frac.el
+++ b/lisp/calc/calc-frac.el
@@ -1,4 +1,4 @@
-;;; calc-frac.el --- fraction functions for Calc
+;;; calc-frac.el --- fraction functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -132,9 +132,8 @@
(cond ((Math-ratp a)
a)
((memq (car a) '(cplx polar vec hms date sdev intv mod))
- (cons (car a) (mapcar (function
- (lambda (x)
- (calcFunc-frac x tol)))
+ (cons (car a) (mapcar (lambda (x)
+ (calcFunc-frac x tol))
(cdr a))))
((Math-messy-integerp a)
(math-trunc a))
diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el
index cdf291aa1d0..053fa2e5851 100644
--- a/lisp/calc/calc-funcs.el
+++ b/lisp/calc/calc-funcs.el
@@ -1,4 +1,4 @@
-;;; calc-funcs.el --- well-known functions for Calc
+;;; calc-funcs.el --- well-known functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -410,7 +410,7 @@
((and (math-num-integerp b)
(if (math-negp b)
(math-reject-arg b 'range)
- (Math-natnum-lessp (setq b (math-trunc b)) 20)))
+ (< (setq b (math-trunc b)) 20)))
(and calc-symbolic-mode (or (math-floatp a) (math-floatp b))
(math-inexact-result))
(math-mul
@@ -427,7 +427,7 @@
((and (math-num-integerp a)
(if (math-negp a)
(math-reject-arg a 'range)
- (Math-natnum-lessp (setq a (math-trunc a)) 20)))
+ (< (setq a (math-trunc a)) 20)))
(math-sub (or math-current-beta-value (calcFunc-beta a b))
(calcFunc-betaB (math-sub 1 x) b a)))
(t
@@ -797,12 +797,11 @@
(math-reduce-vec
'math-add
(cons 'vec
- (mapcar (function
- (lambda (c)
- (setq k (1+ k))
- (math-mul (math-mul fac c)
- (math-sub (math-pow x1 k)
- (math-pow x2 k)))))
+ (mapcar (lambda (c)
+ (setq k (1+ k))
+ (math-mul (math-mul fac c)
+ (math-sub (math-pow x1 k)
+ (math-pow x2 k))))
coefs)))
x)))
(math-mul (math-pow 2 n)
@@ -816,25 +815,25 @@
(list
(list 'frac
-174611
- (math-read-number-simple "802857662698291200000"))
+ 802857662698291200000)
(list 'frac
43867
- (math-read-number-simple "5109094217170944000"))
+ 5109094217170944000)
(list 'frac
-3617
- (math-read-number-simple "10670622842880000"))
+ 10670622842880000)
(list 'frac
1
- (math-read-number-simple "74724249600"))
+ 74724249600)
(list 'frac
-691
- (math-read-number-simple "1307674368000"))
+ 1307674368000)
(list 'frac
1
- (math-read-number-simple "47900160"))
+ 47900160)
(list 'frac
-1
- (math-read-number-simple "1209600"))
+ 1209600)
(list 'frac
1
30240)
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index aa18c7d4fb1..423d1e64126 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -1,4 +1,4 @@
-;;; calc-graph.el --- graph output functions for Calc
+;;; calc-graph.el --- graph output functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -216,7 +216,7 @@
(or (and (Math-num-integerp pstyle) (math-trunc pstyle))
(if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec)
0 -1))
- (math-contains-sdev-p (eval (nth 2 ydata))))))
+ (math-contains-sdev-p (eval (nth 2 ydata) t)))))
(defun calc-graph-lookup (thing)
(if (and (eq (car-safe thing) 'var)
@@ -313,13 +313,13 @@
(defvar calc-graph-blank)
(defvar calc-graph-non-blank)
(defvar calc-graph-curve-num)
+(defvar math-arglist)
(defun calc-graph-plot (flag &optional printing)
(interactive "P")
(calc-slow-wrapper
(let ((calcbuf (current-buffer))
(tempbuf (get-buffer-create "*Gnuplot Temp-2*"))
- (tempbuftop 1)
(tempoutfile nil)
(calc-graph-curve-num 0)
(calc-graph-refine (and flag (> (prefix-numeric-value flag) 0)))
@@ -351,7 +351,7 @@
(if (>= ver 3)
(insert "set surface\nset nocontour\n"
"set " (if calc-graph-is-splot "" "no") "parametric\n"
- "set notime\nset border\nset ztics\nset zeroaxis\n"
+ "set notimestamp\nset border\nset ztics\nset zeroaxis\n"
"set view 60,30,1,1\nset offsets 0,0,0,0\n"))
(setq samples-pos (point))
(insert "\n\n" str))
@@ -403,7 +403,7 @@
(and (equal output "tty") (setq tty-output t)))
(setq tempoutfile (calc-temp-file-name -1)
output tempoutfile))
- (setq output (eval output)))
+ (setq output (eval output t)))
(or (equal device calc-graph-last-device)
(progn
(setq calc-graph-last-device device)
@@ -480,9 +480,11 @@
(calc-graph-xp calc-graph-xvalue)
(calc-graph-yp calc-graph-yvalue)
(calc-graph-zp nil)
- (calc-graph-xlow nil) (calc-graph-xhigh nil) (y3low nil) (y3high nil)
+ (calc-graph-xlow nil) (calc-graph-xhigh nil)
+ ;; (y3low nil) (y3high nil)
calc-graph-xvec calc-graph-xval calc-graph-xstep var-DUMMY
- y3val calc-graph-y3step var-DUMMY2 (calc-graph-zval nil)
+ ;; y3val
+ calc-graph-y3step var-DUMMY2 (calc-graph-zval nil)
calc-graph-yvec calc-graph-yval calc-graph-ycache calc-graph-ycacheptr calc-graph-yvector
calc-graph-numsteps calc-graph-numsteps3
(calc-graph-keep-file (and (not calc-graph-is-splot) (file-exists-p filename)))
@@ -562,7 +564,7 @@
calc-gnuplot-print-output)))
(if (symbolp command)
(funcall command output)
- (eval command))))))))))
+ (eval command t))))))))))
(defun calc-graph-compute-2d ()
(if (setq calc-graph-yvec (eq (car-safe calc-graph-yvalue) 'vec))
@@ -905,16 +907,15 @@
(while calc-graph-file-cache
(and (car calc-graph-file-cache)
(file-exists-p (car (car calc-graph-file-cache)))
- (condition-case err
- (delete-file (car (car calc-graph-file-cache)))
- (error nil)))
+ (ignore-errors
+ (delete-file (car (car calc-graph-file-cache)))))
(setq calc-graph-file-cache (cdr calc-graph-file-cache))))
(defun calc-graph-kill-hook ()
(calc-graph-delete-temps))
(defun calc-graph-show-tty (output)
- "Default calc-gnuplot-plot-command for \"tty\" output mode.
+ "Default `calc-gnuplot-plot-command' for \"tty\" output mode.
This is useful for tek40xx and other graphics-terminal types."
(call-process shell-file-name nil calc-gnuplot-buffer nil
shell-command-switch
@@ -923,7 +924,7 @@ This is useful for tek40xx and other graphics-terminal types."
(defvar calc-dumb-map nil
"The keymap for the \"dumb\" terminal plot.")
-(defun calc-graph-show-dumb (&optional output)
+(defun calc-graph-show-dumb (&optional _output)
"Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type.
This \"dumb\" driver will be present in Gnuplot 3.0."
(interactive)
@@ -1116,14 +1117,14 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(delete-region start end)
(goto-char start)
(setq errform
- (condition-case nil
- (math-contains-sdev-p
- (eval (intern
- (concat "var-"
- (save-excursion
- (re-search-backward ":\\(.*\\)}")
- (match-string 1))))))
- (error nil)))
+ (ignore-errors
+ (math-contains-sdev-p
+ (symbol-value
+ (intern
+ (concat "var-"
+ (save-excursion
+ (re-search-backward ":\\(.*\\)}")
+ (match-string 1))))))))
(if yerr
(insert " with yerrorbars")
(insert " with "
@@ -1135,11 +1136,11 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if penbl "linespoints" "lines")
(if penbl "points" "dots"))))
(if (and pstyle (> pstyle 0))
- (insert " "
+ (insert " ls "
(if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1")
- " " (int-to-string pstyle))
+ " ps " (int-to-string pstyle))
(if (and lstyle (> lstyle 0))
- (insert " " (int-to-string lstyle)))))))
+ (insert " ls " (int-to-string lstyle)))))))
(calc-graph-view-commands))
(defun calc-graph-zero-x (flag)
@@ -1165,7 +1166,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or (calc-graph-find-plot nil nil)
(error "No data points have been set!"))
(let ((base (point))
- start
+ ;; start
end)
(re-search-forward "[,\n]\\|[ \t]+with")
(setq end (match-beginning 0))
@@ -1462,7 +1463,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(match-beginning 1)
(match-end 1))))
(setq calc-gnuplot-version 1))))
- (condition-case err
+ (condition-case nil
(let ((args (append (and calc-gnuplot-display
(not (equal calc-gnuplot-display
(getenv "DISPLAY")))
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index fc7f5f8b355..dd5063f27d5 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -1,4 +1,4 @@
-;;; calc-help.el --- help display functions for Calc,
+;;; calc-help.el --- help display functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -33,8 +33,8 @@
(declare-function Info-last "info" ())
-(defun calc-help-prefix (arg)
- "This key is the prefix for Calc help functions. See calc-help-for-help."
+(defun calc-help-prefix (&optional _arg)
+ "This key is the prefix for Calc help functions. See `calc-help-for-help'."
(interactive "P")
(or calc-dispatch-help (sit-for echo-keystrokes))
(let ((key (calc-read-key-sequence
@@ -79,7 +79,7 @@ C-w Describe how there is no warranty for Calc."
(message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel")
(memq (setq key (read-event))
'(? ?\C-h ?\C-? ?\C-v ?\M-v)))
- (condition-case err
+ (condition-case nil
(if (memq key '(? ?\C-v))
(scroll-up)
(scroll-down))
@@ -302,21 +302,19 @@ C-w Describe how there is no warranty for Calc."
(let ((entrylist '())
entry)
(require 'info nil t)
- (while indices
- (condition-case nil
- (with-temp-buffer
- (Info-mode)
- (Info-goto-node (concat "(Calc)" (car indices) " Index"))
- (goto-char (point-min))
- (while (re-search-forward "\n\\* \\(.*\\): " nil t)
- (setq entry (match-string 1))
- (if (and (not (string-match "<[1-9]+>" entry))
- (not (string-match "(.*)" entry))
- (not (string= entry "Menu")))
- (unless (assoc entry entrylist)
- (setq entrylist (cons entry entrylist))))))
- (error nil))
- (setq indices (cdr indices)))
+ (dolist (indice indices)
+ (ignore-errors
+ (with-temp-buffer
+ (Info-mode)
+ (Info-goto-node (concat "(Calc)" indice " Index"))
+ (goto-char (point-min))
+ (while (re-search-forward "\n\\* \\(.*\\): " nil t)
+ (setq entry (match-string 1))
+ (if (and (not (string-match "<[1-9]+>" entry))
+ (not (string-match "(.*)" entry))
+ (not (string= entry "Menu")))
+ (unless (assoc entry entrylist)
+ (setq entrylist (cons entry entrylist))))))))
entrylist))
(defun calc-describe-function (&optional func)
@@ -404,34 +402,32 @@ C-w Describe how there is no warranty for Calc."
"Or type `h i' to read the full Calc manual on-line.\n\n"))
(princ "Basic keys:\n")
(let* ((calc-full-help-flag t))
- (mapc (function (lambda (x) (princ (format
- " %s\n"
- (substitute-command-keys x)))))
+ (mapc (lambda (x)
+ (princ (format
+ " %s\n"
+ (substitute-command-keys x))))
(nreverse (cdr (reverse (cdr (calc-help))))))
- (mapc (function (lambda (prefix)
- (let ((msgs (condition-case err
- (funcall prefix)
- (error nil))))
- (if (car msgs)
- (princ
- (if (eq (nth 2 msgs) ?v)
- (format-message
- "\n`v' or `V' prefix (vector/matrix) keys: \n")
- (if (nth 2 msgs)
- (format-message
- "\n`%c' prefix (%s) keys:\n"
- (nth 2 msgs)
- (or (cdr (assq (nth 2 msgs)
- calc-help-long-names))
- (nth 1 msgs)))
- (format "\n%s-modified keys:\n"
- (capitalize (nth 1 msgs)))))))
- (mapcar (function
- (lambda (x)
- (princ (format
- " %s\n"
- (substitute-command-keys x)))))
- (car msgs)))))
+ (mapc (lambda (prefix)
+ (let ((msgs (ignore-errors (funcall prefix))))
+ (if (car msgs)
+ (princ
+ (if (eq (nth 2 msgs) ?v)
+ (format-message
+ "\n`v' or `V' prefix (vector/matrix) keys: \n")
+ (if (nth 2 msgs)
+ (format-message
+ "\n`%c' prefix (%s) keys:\n"
+ (nth 2 msgs)
+ (or (cdr (assq (nth 2 msgs)
+ calc-help-long-names))
+ (nth 1 msgs)))
+ (format "\n%s-modified keys:\n"
+ (capitalize (nth 1 msgs)))))))
+ (mapcar (lambda (x)
+ (princ (format
+ " %s\n"
+ (substitute-command-keys x))))
+ (car msgs))))
'(calc-inverse-prefix-help
calc-hyperbolic-prefix-help
calc-inv-hyp-prefix-help
diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el
index 6d490dbe516..e27d65092eb 100644
--- a/lisp/calc/calc-incom.el
+++ b/lisp/calc/calc-incom.el
@@ -1,4 +1,4 @@
-;;; calc-incom.el --- complex data type input functions for Calc
+;;; calc-incom.el --- complex data type input functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el
index e0820912207..1902a4f3f29 100644
--- a/lisp/calc/calc-keypd.el
+++ b/lisp/calc/calc-keypd.el
@@ -1,4 +1,4 @@
-;;; calc-keypd.el --- mouse-capable keypad input for Calc
+;;; calc-keypd.el --- mouse-capable keypad input for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -35,17 +35,17 @@
(defvar calc-keypad-prev-input nil)
(defvar calc-keypad-said-hello nil)
-;;; |----+----+----+----+----+----|
-;;; | ENTER |+/- |EEX |UNDO| <- |
-;;; |-----+---+-+--+--+-+---++----|
-;;; | INV | 7 | 8 | 9 | / |
-;;; |-----+-----+-----+-----+-----|
-;;; | HYP | 4 | 5 | 6 | * |
-;;; |-----+-----+-----+-----+-----|
-;;; |EXEC | 1 | 2 | 3 | - |
-;;; |-----+-----+-----+-----+-----|
-;;; | OFF | 0 | . | PI | + |
-;;; |-----+-----+-----+-----+-----|
+;; |----+----+----+----+----+----|
+;; | ENTER |+/- |EEX |UNDO| <- |
+;; |-----+---+-+--+--+-+---++----|
+;; | INV | 7 | 8 | 9 | / |
+;; |-----+-----+-----+-----+-----|
+;; | HYP | 4 | 5 | 6 | * |
+;; |-----+-----+-----+-----+-----|
+;; |EXEC | 1 | 2 | 3 | - |
+;; |-----+-----+-----+-----+-----|
+;; | OFF | 0 | . | PI | + |
+;; |-----+-----+-----+-----+-----|
(defvar calc-keypad-layout
'( ( ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over )
( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over )
@@ -83,12 +83,12 @@
calc-keypad-modes-menu
calc-keypad-user-menu ) )
-;;; |----+----+----+----+----+----|
-;;; |FLR |CEIL|RND |TRNC|CLN2|FLT |
-;;; |----+----+----+----+----+----|
-;;; | LN |EXP | |ABS |IDIV|MOD |
-;;; |----+----+----+----+----+----|
-;;; |SIN |COS |TAN |SQRT|y^x |1/x |
+;; |----+----+----+----+----+----|
+;; |FLR |CEIL|RND |TRNC|CLN2|FLT |
+;; |----+----+----+----+----+----|
+;; | LN |EXP | |ABS |IDIV|MOD |
+;; |----+----+----+----+----+----|
+;; |SIN |COS |TAN |SQRT|y^x |1/x |
(defvar calc-keypad-math-menu
'( ( ( "FLR" calc-floor )
@@ -110,12 +110,12 @@
( "y^x" calc-power )
( "1/x" calc-inv ) ) ))
-;;; |----+----+----+----+----+----|
-;;; |IGAM|BETA|IBET|ERF |BESJ|BESY|
-;;; |----+----+----+----+----+----|
-;;; |IMAG|CONJ| RE |ATN2|RAND|RAGN|
-;;; |----+----+----+----+----+----|
-;;; |GCD |FACT|DFCT|BNOM|PERM|NXTP|
+;; |----+----+----+----+----+----|
+;; |IGAM|BETA|IBET|ERF |BESJ|BESY|
+;; |----+----+----+----+----+----|
+;; |IMAG|CONJ| RE |ATN2|RAND|RAGN|
+;; |----+----+----+----+----+----|
+;; |GCD |FACT|DFCT|BNOM|PERM|NXTP|
(defvar calc-keypad-funcs-menu
'( ( ( "IGAM" calc-inc-gamma )
@@ -137,12 +137,12 @@
( "PERM" calc-perm )
( "NXTP" calc-next-prime calc-prev-prime ) ) ))
-;;; |----+----+----+----+----+----|
-;;; |AND | OR |XOR |NOT |LSH |RSH |
-;;; |----+----+----+----+----+----|
-;;; |DEC |HEX |OCT |BIN |WSIZ|ARSH|
-;;; |----+----+----+----+----+----|
-;;; | A | B | C | D | E | F |
+;; |----+----+----+----+----+----|
+;; |AND | OR |XOR |NOT |LSH |RSH |
+;; |----+----+----+----+----+----|
+;; |DEC |HEX |OCT |BIN |WSIZ|ARSH|
+;; |----+----+----+----+----+----|
+;; | A | B | C | D | E | F |
(defvar calc-keypad-binary-menu
'( ( ( "AND" calc-and calc-diff )
@@ -164,12 +164,12 @@
( "E" ("E") )
( "F" ("F") ) ) ))
-;;; |----+----+----+----+----+----|
-;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
-;;; |----+----+----+----+----+----|
-;;; |INV |DET |TRN |IDNT|CRSS|"x" |
-;;; |----+----+----+----+----+----|
-;;; |PACK|UNPK|INDX|BLD |LEN |... |
+;; |----+----+----+----+----+----|
+;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
+;; |----+----+----+----+----+----|
+;; |INV |DET |TRN |IDNT|CRSS|"x" |
+;; |----+----+----+----+----+----|
+;; |PACK|UNPK|INDX|BLD |LEN |... |
(defvar calc-keypad-vector-menu
'( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean )
@@ -196,12 +196,12 @@
( "LEN" calc-vlength )
( "..." calc-full-vectors ) ) ))
-;;; |----+----+----+----+----+----|
-;;; |FLT |FIX |SCI |ENG |GRP | |
-;;; |----+----+----+----+----+----|
-;;; |RAD |DEG |FRAC|POLR|SYMB|PREC|
-;;; |----+----+----+----+----+----|
-;;; |SWAP|RLL3|RLL4|OVER|STO |RCL |
+;; |----+----+----+----+----+----|
+;; |FLT |FIX |SCI |ENG |GRP | |
+;; |----+----+----+----+----+----|
+;; |RAD |DEG |FRAC|POLR|SYMB|PREC|
+;; |----+----+----+----+----+----|
+;; |SWAP|RLL3|RLL4|OVER|STO |RCL |
(defvar calc-keypad-modes-menu
'( ( ( "FLT" calc-normal-notation
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index 4e10cc17288..0117f449dd5 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -1,4 +1,4 @@
-;;; calc-lang.el --- calc language functions
+;;; calc-lang.el --- calc language functions -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -45,6 +45,8 @@
(defvar math-comp-comma)
(defvar math-comp-vector-prec)
+(defvar math-exp-str) ;; Dyn scoped
+
;;; Alternate entry/display languages.
(defun calc-set-language (lang &optional option no-refresh)
@@ -144,7 +146,7 @@
( y1 . (math-C-parse-bess))
( tgamma . calcFunc-gamma )))
-(defun math-C-parse-bess (f val)
+(defun math-C-parse-bess (_f val)
"Parse C's j0, j1, y0, y1 functions."
(let ((args (math-read-expr-list)))
(math-read-token)
@@ -155,7 +157,7 @@
((eq val 'y1) '(calcFunc-besY 1)))
args)))
-(defun math-C-parse-fma (f val)
+(defun math-C-parse-fma (_f _val)
"Parse C's fma function fma(x,y,z) => (x * y + z)."
(let ((args (math-read-expr-list)))
(math-read-token)
@@ -173,20 +175,19 @@
(put 'c 'math-vector-brackets "{}")
(put 'c 'math-radix-formatter
- (function (lambda (r s)
- (if (= r 16) (format "0x%s" s)
- (if (= r 8) (format "0%s" s)
- (format "%d#%s" r s))))))
+ (lambda (r s)
+ (if (= r 16) (format "0x%s" s)
+ (if (= r 8) (format "0%s" s)
+ (format "%d#%s" r s)))))
(put 'c 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-vector args ", " 0)
- "]")))))
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-vector args ", " 0)
+ "]"))))
(add-to-list 'calc-lang-slash-idiv 'c)
(add-to-list 'calc-lang-allow-underscores 'c)
@@ -236,9 +237,9 @@
(put 'pascal 'math-output-filter 'calc-output-case-filter)
(put 'pascal 'math-radix-formatter
- (function (lambda (r s)
- (if (= r 16) (format "$%s" s)
- (format "%d#%s" r s)))))
+ (lambda (r s)
+ (if (= r 16) (format "$%s" s)
+ (format "%d#%s" r s))))
(put 'pascal 'math-lang-read-symbol
'((?\$
@@ -251,17 +252,16 @@
math-exp-pos (match-end 1)))))
(put 'pascal 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr)
- (setq args (append (cdr (cdr (nth 1 a))) args)
- a (nth 1 a)))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-vector args ", " 0)
- "]")))))
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr)
+ (setq args (append (cdr (cdr (nth 1 a))) args)
+ a (nth 1 a)))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-vector args ", " 0)
+ "]"))))
(add-to-list 'calc-lang-allow-underscores 'pascal)
(add-to-list 'calc-lang-brackets-are-subscripts 'pascal)
@@ -348,17 +348,16 @@
math-exp-pos (match-end 0)))))
(put 'fortran 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr)
- (setq args (append (cdr (cdr (nth 1 a))) args)
- a (nth 1 a)))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "("
- (math-compose-vector args ", " 0)
- ")")))))
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr)
+ (setq args (append (cdr (cdr (nth 1 a))) args)
+ a (nth 1 a)))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "("
+ (math-compose-vector args ", " 0)
+ ")"))))
(add-to-list 'calc-lang-slash-idiv 'fortran)
(add-to-list 'calc-lang-allow-underscores 'fortran)
@@ -372,14 +371,14 @@
(defvar math-exp-old-pos)
(defvar math-parsing-fortran-vector nil)
-(defun math-parse-fortran-vector (op)
+(defun math-parse-fortran-vector (_op)
(let ((math-parsing-fortran-vector '(end . "\000")))
(prog1
(math-read-brackets t "]")
(setq math-exp-token (car math-parsing-fortran-vector)
math-expr-data (cdr math-parsing-fortran-vector)))))
-(defun math-parse-fortran-vector-end (x op)
+(defun math-parse-fortran-vector-end (x _op)
(if math-parsing-fortran-vector
(progn
(setq math-parsing-fortran-vector (cons math-exp-token math-expr-data)
@@ -466,10 +465,10 @@
( "\\times" * 191 190 )
( "*" * 191 190 )
( "2x" * 191 190 )
+ ( "/" / 185 186 )
( "+" + 180 181 )
( "-" - 180 181 )
( "\\over" / 170 171 )
- ( "/" / 170 171 )
( "\\choose" calcFunc-choose 170 171 )
( "\\mod" % 170 171 )
( "<" calcFunc-lt 160 161 )
@@ -596,18 +595,17 @@
(put 'tex 'math-input-filter 'math-tex-input-filter)
(put 'tex 'math-matrix-formatter
- (function
- (lambda (a)
- (if (and (integerp calc-language-option)
- (or (= calc-language-option 0)
- (> calc-language-option 1)
- (< calc-language-option -1)))
- (append '(vleft 0 "\\matrix{")
- (math-compose-tex-matrix (cdr a))
- '("}"))
- (append '(horiz "\\matrix{ ")
- (math-compose-tex-matrix (cdr a))
- '(" }"))))))
+ (lambda (a)
+ (if (and (integerp calc-language-option)
+ (or (= calc-language-option 0)
+ (> calc-language-option 1)
+ (< calc-language-option -1)))
+ (append '(vleft 0 "\\matrix{")
+ (math-compose-tex-matrix (cdr a))
+ '("}"))
+ (append '(horiz "\\matrix{ ")
+ (math-compose-tex-matrix (cdr a))
+ '(" }")))))
(put 'tex 'math-var-formatter 'math-compose-tex-var)
@@ -692,7 +690,7 @@
"_{" (math-compose-expr (nth 2 a) 0)
"}{" (math-compose-expr (nth 1 a) 0) "}"))))
-(defun math-parse-tex-sum (f val)
+(defun math-parse-tex-sum (f _val)
(let (low high save)
(or (equal math-expr-data "_") (throw 'syntax "Expected `_'"))
(math-read-token)
@@ -727,14 +725,15 @@
(math-compose-expr (nth 3 a) 0)
(if (memq (nth 1 a) '(0 2)) ")" "]")))
-(defun math-compose-tex-var (a prec)
+(defun math-compose-tex-var (a _prec)
(if (and calc-language-option
(not (= calc-language-option 0))
(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)))
- (format "\\hbox{%s}" (symbol-name (nth 1 a))))
+ (format (if (eq calc-language 'latex)
+ "\\text{%s}"
+ "\\hbox{%s}")
+ (symbol-name (nth 1 a)))
(math-compose-var a)))
(defun math-compose-tex-func (func a)
@@ -836,18 +835,17 @@
(put 'latex 'math-complex-format 'i)
(put 'latex 'math-matrix-formatter
- (function
- (lambda (a)
- (if (and (integerp calc-language-option)
- (or (= calc-language-option 0)
- (> calc-language-option 1)
- (< calc-language-option -1)))
- (append '(vleft 0 "\\begin{pmatrix}")
- (math-compose-tex-matrix (cdr a) t)
- '("\\end{pmatrix}"))
- (append '(horiz "\\begin{pmatrix} ")
- (math-compose-tex-matrix (cdr a) t)
- '(" \\end{pmatrix}"))))))
+ (lambda (a)
+ (if (and (integerp calc-language-option)
+ (or (= calc-language-option 0)
+ (> calc-language-option 1)
+ (< calc-language-option -1)))
+ (append '(vleft 0 "\\begin{pmatrix}")
+ (math-compose-tex-matrix (cdr a) t)
+ '("\\end{pmatrix}"))
+ (append '(horiz "\\begin{pmatrix} ")
+ (math-compose-tex-matrix (cdr a) t)
+ '(" \\end{pmatrix}")))))
(put 'latex 'math-var-formatter 'math-compose-tex-var)
@@ -906,7 +904,7 @@
(setq math-exp-str (copy-sequence math-exp-str))
(aset math-exp-str right ?\]))))))))))
-(defun math-latex-parse-frac (f val)
+(defun math-latex-parse-frac (_f _val)
(let (numer denom)
(setq numer (car (math-read-expr-list)))
(math-read-token)
@@ -916,7 +914,7 @@
(list 'frac numer denom)
(list '/ numer denom))))
-(defun math-latex-parse-two-args (f val)
+(defun math-latex-parse-two-args (f _val)
(let (first second)
(setq first (car (math-read-expr-list)))
(math-read-token)
@@ -931,7 +929,7 @@
(put 'latex 'math-input-filter 'math-tex-input-filter)
-(defun calc-eqn-language (n)
+(defun calc-eqn-language (_n)
(interactive "P")
(calc-wrapper
(calc-set-language 'eqn)
@@ -1020,36 +1018,34 @@
(put 'eqn 'math-evalto '("evalto " . " -> "))
(put 'eqn 'math-matrix-formatter
- (function
- (lambda (a)
- (append '(horiz "matrix { ")
- (math-compose-eqn-matrix
- (cdr (math-transpose a)))
- '("}")))))
+ (lambda (a)
+ (append '(horiz "matrix { ")
+ (math-compose-eqn-matrix
+ (cdr (math-transpose a)))
+ '("}"))))
(put 'eqn 'math-var-formatter
- (function
- (lambda (a prec)
- (let (v)
- (if (and math-compose-hash-args
- (let ((p calc-arg-values))
- (setq v 1)
- (while (and p (not (equal (car p) a)))
- (setq p (and (eq math-compose-hash-args t) (cdr p))
- v (1+ v)))
- p))
- (if (eq math-compose-hash-args 1)
- "#"
- (format "#%d" v))
- (if (string-match ".'\\'" (symbol-name (nth 2 a)))
- (math-compose-expr
- (list 'calcFunc-Prime
- (list
- 'var
- (intern (substring (symbol-name (nth 1 a)) 0 -1))
- (intern (substring (symbol-name (nth 2 a)) 0 -1))))
- prec)
- (symbol-name (nth 1 a))))))))
+ (lambda (a prec)
+ (let (v)
+ (if (and math-compose-hash-args
+ (let ((p calc-arg-values))
+ (setq v 1)
+ (while (and p (not (equal (car p) a)))
+ (setq p (and (eq math-compose-hash-args t) (cdr p))
+ v (1+ v)))
+ p))
+ (if (eq math-compose-hash-args 1)
+ "#"
+ (format "#%d" v))
+ (if (string-match ".'\\'" (symbol-name (nth 2 a)))
+ (math-compose-expr
+ (list 'calcFunc-Prime
+ (list
+ 'var
+ (intern (substring (symbol-name (nth 1 a)) 0 -1))
+ (intern (substring (symbol-name (nth 2 a)) 0 -1))))
+ prec)
+ (symbol-name (nth 1 a)))))))
(defconst math-eqn-special-funcs
'( calcFunc-log
@@ -1062,31 +1058,30 @@
calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh))
(put 'eqn 'math-func-formatter
- (function
- (lambda (func a)
- (let (left right)
- (if (string-match "[^']'+\\'" func)
- (let ((n (- (length func) (match-beginning 0) 1)))
- (setq func (substring func 0 (- n)))
- (while (>= (setq n (1- n)) 0)
- (setq func (concat func " prime")))))
- (cond ((or (> (length a) 2)
- (not (math-tex-expr-is-flat (nth 1 a))))
- (setq left "{left ( "
- right " right )}"))
-
- ((and
- (memq (car a) math-eqn-special-funcs)
- (= (length a) 2)
- (or (Math-realp (nth 1 a))
- (memq (car (nth 1 a)) '(var *))))
- (setq left "~{" right "}"))
- (t
- (setq left " ( "
- right " )")))
- (list 'horiz func left
- (math-compose-vector (cdr a) " , " 0)
- right)))))
+ (lambda (func a)
+ (let (left right)
+ (if (string-match "[^']'+\\'" func)
+ (let ((n (- (length func) (match-beginning 0) 1)))
+ (setq func (substring func 0 (- n)))
+ (while (>= (setq n (1- n)) 0)
+ (setq func (concat func " prime")))))
+ (cond ((or (> (length a) 2)
+ (not (math-tex-expr-is-flat (nth 1 a))))
+ (setq left "{left ( "
+ right " right )}"))
+
+ ((and
+ (memq (car a) math-eqn-special-funcs)
+ (= (length a) 2)
+ (or (Math-realp (nth 1 a))
+ (memq (car (nth 1 a)) '(var *))))
+ (setq left "~{" right "}"))
+ (t
+ (setq left " ( "
+ right " )")))
+ (list 'horiz func left
+ (math-compose-vector (cdr a) " , " 0)
+ right))))
(put 'eqn 'math-lang-read-symbol
'((?\"
@@ -1108,23 +1103,22 @@
("above" punc ",")))
(put 'eqn 'math-lang-adjust-words
- (function
- (lambda ()
- (let ((code (assoc math-expr-data math-eqn-ignore-words)))
- (cond ((null code))
- ((null (cdr code))
- (math-read-token))
- ((consp (nth 1 code))
- (math-read-token)
- (if (assoc math-expr-data (cdr code))
- (setq math-expr-data (format "%s %s"
- (car code) math-expr-data))))
- ((eq (nth 1 code) 'punc)
- (setq math-exp-token 'punc
- math-expr-data (nth 2 code)))
- (t
- (math-read-token)
- (math-read-token)))))))
+ (lambda ()
+ (let ((code (assoc math-expr-data math-eqn-ignore-words)))
+ (cond ((null code))
+ ((null (cdr code))
+ (math-read-token))
+ ((consp (nth 1 code))
+ (math-read-token)
+ (if (assoc math-expr-data (cdr code))
+ (setq math-expr-data (format "%s %s"
+ (car code) math-expr-data))))
+ ((eq (nth 1 code) 'punc)
+ (setq math-exp-token 'punc
+ math-expr-data (nth 2 code)))
+ (t
+ (math-read-token)
+ (math-read-token))))))
(put 'eqn 'math-lang-read
'((eq (string-match "->\\|<-\\|\\+-\\|\\\\dots\\|~\\|\\^"
@@ -1159,7 +1153,7 @@
(math-compose-eqn-matrix (cdr a)))))))
nil))
-(defun math-parse-eqn-matrix (f sym)
+(defun math-parse-eqn-matrix (_f _sym)
(let ((vec nil))
(while (assoc math-expr-data '(("ccol") ("lcol") ("rcol")))
(math-read-token)
@@ -1175,7 +1169,7 @@
(math-read-token)
(math-transpose (cons 'vec (nreverse vec)))))
-(defun math-parse-eqn-prime (x sym)
+(defun math-parse-eqn-prime (x _sym)
(if (eq (car-safe x) 'var)
(if (equal math-expr-data calc-function-open)
(progn
@@ -1354,16 +1348,15 @@
( calcFunc-in . (math-lang-compose-switch-args "Contains"))))
(put 'yacas 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-vector args ", " 0)
- "]")))))
-
-(defun math-yacas-parse-Sum (f val)
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-vector args ", " 0)
+ "]"))))
+
+(defun math-yacas-parse-Sum (f _val)
"Read in the arguments to \"Sum\" in Calc's Yacas mode."
(let ((args (math-read-expr-list)))
(math-read-token)
@@ -1512,7 +1505,7 @@
( substitute . (math-maxima-parse-subst))
( taylor . (math-maxima-parse-taylor))))
-(defun math-maxima-parse-subst (f val)
+(defun math-maxima-parse-subst (_f _val)
"Read in the arguments to \"subst\" in Calc's Maxima mode."
(let ((args (math-read-expr-list)))
(math-read-token)
@@ -1521,7 +1514,7 @@
(nth 2 args)
(nth 0 args))))
-(defun math-maxima-parse-taylor (f val)
+(defun math-maxima-parse-taylor (_f _val)
"Read in the arguments to \"taylor\" in Calc's Maxima mode."
(let ((args (math-read-expr-list)))
(math-read-token)
@@ -1597,24 +1590,22 @@
(add-to-list 'calc-lang-brackets-are-subscripts 'maxima)
(put 'maxima 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-vector args ", " 0)
- "]")))))
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-vector args ", " 0)
+ "]"))))
(put 'maxima 'math-matrix-formatter
- (function
- (lambda (a)
- (list 'horiz
- "matrix("
- (math-compose-vector (cdr a)
- (concat math-comp-comma " ")
- math-comp-vector-prec)
- ")"))))
+ (lambda (a)
+ (list 'horiz
+ "matrix("
+ (math-compose-vector (cdr a)
+ (concat math-comp-comma " ")
+ math-comp-vector-prec)
+ ")")))
;;; Giac
@@ -1762,7 +1753,7 @@
( contains . (math-lang-switch-args calcFunc-in))
( has . (math-lang-switch-args calcFunc-refers))))
-(defun math-lang-switch-args (f val)
+(defun math-lang-switch-args (f _val)
"Read 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."
@@ -1803,17 +1794,16 @@ order to Calc's."
(add-to-list 'calc-lang-allow-underscores 'giac)
(put 'giac 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-expr
- (calc-normalize (list '- (nth 2 a) 1)) 0)
- "]")))))
-
-(defun math-read-giac-subscr (x op)
+ (lambda (a)
+ ;; (let ((args (cdr (cdr a))))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-expr
+ (calc-normalize (list '- (nth 2 a) 1)) 0)
+ "]"))) ;;)
+
+(defun math-read-giac-subscr (x _op)
(let ((idx (math-read-expr-level 0)))
(or (equal math-expr-data "]")
(throw 'syntax "Expected `]'"))
@@ -1929,7 +1919,7 @@ order to Calc's."
(put 'math 'math-function-close "]")
(put 'math 'math-radix-formatter
- (function (lambda (r s) (format "%d^^%s" r s))))
+ (lambda (r s) (format "%d^^%s" r s)))
(put 'math 'math-lang-read
'((eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos)
@@ -1939,15 +1929,14 @@ order to Calc's."
math-exp-pos (match-end 0))))
(put 'math 'math-compose-subscr
- (function
- (lambda (a)
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "[["
- (math-compose-expr (nth 2 a) 0)
- "]]"))))
-
-(defun math-read-math-subscr (x op)
+ (lambda (a)
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "[["
+ (math-compose-expr (nth 2 a) 0)
+ "]]")))
+
+(defun math-read-math-subscr (x _op)
(let ((idx (math-read-expr-level 0)))
(or (and (equal math-expr-data "]")
(progn
@@ -2035,26 +2024,24 @@ order to Calc's."
(put 'maple 'math-complex-format 'I)
(put 'maple 'math-matrix-formatter
- (function
- (lambda (a)
- (list 'horiz
- "matrix("
- math-comp-left-bracket
- (math-compose-vector (cdr a)
- (concat math-comp-comma " ")
- math-comp-vector-prec)
- math-comp-right-bracket
- ")"))))
+ (lambda (a)
+ (list 'horiz
+ "matrix("
+ math-comp-left-bracket
+ (math-compose-vector (cdr a)
+ (concat math-comp-comma " ")
+ math-comp-vector-prec)
+ math-comp-right-bracket
+ ")")))
(put 'maple 'math-compose-subscr
- (function
- (lambda (a)
- (let ((args (cdr (cdr a))))
- (list 'horiz
- (math-compose-expr (nth 1 a) 1000)
- "["
- (math-compose-vector args ", " 0)
- "]")))))
+ (lambda (a)
+ (let ((args (cdr (cdr a))))
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 1000)
+ "["
+ (math-compose-vector args ", " 0)
+ "]"))))
(add-to-list 'calc-lang-allow-underscores 'maple)
(add-to-list 'calc-lang-brackets-are-subscripts 'maple)
@@ -2094,10 +2081,13 @@ 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 (rb-h1 rb-v1 rb-h2 rb-v2
&optional baseline prec short)
(or prec (setq prec 0))
-
+ (let ((math-rb-h1 rb-h1)
+ (math-rb-v1 rb-v1)
+ (math-rb-h2 rb-h2)
+ (math-rb-v2 rb-v2))
;; Clip whitespace above or below.
(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)))
@@ -2191,7 +2181,7 @@ order to Calc's."
v math-read-big-baseline))
;; Small radical sign.
- ((and (= other-char ?V)
+ ((and (memq other-char '(?V ?√))
(= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_))
(setq h (1+ math-rb-h1))
(math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t)
@@ -2449,7 +2439,7 @@ order to Calc's."
math-read-big-h2 h)
(or short (= math-read-big-h2 math-rb-h2)
(math-read-big-error h baseline))
- p)))
+ p))))
(defun math-read-big-char (h v)
(or (and (>= h math-rb-h1)
diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el
index fad622cf3a5..63258cde507 100644
--- a/lisp/calc/calc-macs.el
+++ b/lisp/calc/calc-macs.el
@@ -29,16 +29,15 @@
(declare-function math-looks-negp "calc-misc" (a))
(declare-function math-posp "calc-misc" (a))
(declare-function math-compare "calc-ext" (a b))
-(declare-function math-compare-bignum "calc-ext" (a b))
(defmacro calc-wrapper (&rest body)
- `(calc-do (function (lambda ()
- ,@body))))
+ `(calc-do (lambda ()
+ ,@body)))
(defmacro calc-slow-wrapper (&rest body)
`(calc-do
- (function (lambda () ,@body)) (point)))
+ (lambda () ,@body) (point)))
(defmacro math-showing-full-precision (form)
`(let ((calc-float-format calc-full-float-format))
@@ -61,6 +60,7 @@
(defmacro calc-with-trail-buffer (&rest body)
`(let ((save-buf (current-buffer))
(calc-command-flags nil))
+ (ignore save-buf) ;FIXME: Use a name less conflict-prone!
(with-current-buffer (calc-trail-display t)
(progn
(goto-char calc-trail-pointer)
@@ -173,13 +173,6 @@
(eq (nth 1 a) b)
(= (nth 2 a) 0))))
-(defsubst Math-natnum-lessp (a b)
- (if (consp a)
- (and (consp b)
- (= (math-compare-bignum (cdr a) (cdr b)) -1))
- (or (consp b)
- (< a b))))
-
(provide 'calc-macs)
;;; calc-macs.el ends here
diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el
index 280b3c20ecf..16a2bd89cac 100644
--- a/lisp/calc/calc-map.el
+++ b/lisp/calc/calc-map.el
@@ -1,4 +1,4 @@
-;;; calc-map.el --- higher-order functions for Calc
+;;; calc-map.el --- higher-order functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -48,6 +48,8 @@
(math-calcFunc-to-var (nth 1 oper))
expr)))))
+(defvar calc-mapping-dir nil)
+
(defun calc-reduce (&optional oper accum)
(interactive)
(calc-wrapper
@@ -136,7 +138,6 @@
(1+ calc-dollar-used))))))))
(defvar calc-verify-arglist t)
-(defvar calc-mapping-dir nil)
(defun calc-map-stack ()
"This is meant to be called by calc-keypad mode."
(interactive)
@@ -492,6 +493,8 @@
(defvar calc-get-operator-history nil
"History for calc-get-operator.")
+(defvar math-arglist)
+
(defun calc-get-operator (msg &optional nargs)
(setq calc-aborted-prefix nil)
(let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
@@ -609,14 +612,13 @@
"()")
minibuffer-local-map
t)))
- (setq math-arglist (mapcar (function
- (lambda (x)
- (list 'var
- x
- (intern
- (concat
- "var-"
- (symbol-name x))))))
+ (setq math-arglist (mapcar (lambda (x)
+ (list 'var
+ x
+ (intern
+ (concat
+ "var-"
+ (symbol-name x)))))
math-arglist))))
(setq oper (list "$"
(length math-arglist)
@@ -853,7 +855,7 @@
(i -1)
(math-working-step 0)
(math-working-step-2 nil)
- len cols obj expr)
+ len obj expr) ;; cols
(if (eq mode 'eqn)
(setq mode 'elems
heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt
@@ -959,12 +961,12 @@
(apply 'calcFunc-mapeqp func args)))
(defun calcFunc-mapeqr (func &rest args)
- (setq args (mapcar (function (lambda (x)
- (let ((func (assq (car-safe x)
- calc-tweak-eqn-table)))
- (if func
- (cons (nth 1 func) (cdr x))
- x))))
+ (setq args (mapcar (lambda (x)
+ (let ((func (assq (car-safe x)
+ calc-tweak-eqn-table)))
+ (if func
+ (cons (nth 1 func) (cdr x))
+ x)))
args))
(apply 'calcFunc-mapeqp func args))
@@ -1023,22 +1025,21 @@
(let ((expr (car (setq vec (cdr vec)))))
(if expr
(progn
- (condition-case err
- (and (symbolp func)
- (let ((lfunc (or (cdr (assq func
- '( (calcFunc-add . math-add)
- (calcFunc-sub . math-sub)
- (calcFunc-mul . math-mul)
- (calcFunc-div . math-div)
- (calcFunc-pow . math-pow)
- (calcFunc-mod . math-mod)
- (calcFunc-vconcat .
- math-concat) )))
- func)))
- (while (cdr vec)
- (setq expr (funcall lfunc expr (nth 1 vec))
- vec (cdr vec)))))
- (error nil))
+ (ignore-errors
+ (and (symbolp func)
+ (let ((lfunc (or (cdr (assq func
+ '( (calcFunc-add . math-add)
+ (calcFunc-sub . math-sub)
+ (calcFunc-mul . math-mul)
+ (calcFunc-div . math-div)
+ (calcFunc-pow . math-pow)
+ (calcFunc-mod . math-mod)
+ (calcFunc-vconcat
+ . math-concat) )))
+ func)))
+ (while (cdr vec)
+ (setq expr (funcall lfunc expr (nth 1 vec))
+ vec (cdr vec))))))
(while (setq vec (cdr vec))
(setq expr (math-build-call func (list expr (car vec)))))
(math-normalize expr))
@@ -1090,28 +1091,28 @@
(defun calcFunc-reducea (func vec)
(if (math-matrixp vec)
(cons 'vec
- (mapcar (function (lambda (x) (calcFunc-reducer func x)))
+ (mapcar (lambda (x) (calcFunc-reducer func x))
(cdr vec)))
(calcFunc-reducer func vec)))
(defun calcFunc-rreducea (func vec)
(if (math-matrixp vec)
(cons 'vec
- (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
+ (mapcar (lambda (x) (calcFunc-rreducer func x))
(cdr vec)))
(calcFunc-rreducer func vec)))
(defun calcFunc-reduced (func vec)
(if (math-matrixp vec)
(cons 'vec
- (mapcar (function (lambda (x) (calcFunc-reducer func x)))
+ (mapcar (lambda (x) (calcFunc-reducer func x))
(cdr (math-transpose vec))))
(calcFunc-reducer func vec)))
(defun calcFunc-rreduced (func vec)
(if (math-matrixp vec)
(cons 'vec
- (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
+ (mapcar (lambda (x) (calcFunc-rreducer func x))
(cdr (math-transpose vec))))
(calcFunc-rreducer func vec)))
@@ -1214,10 +1215,10 @@
(let ((mat nil))
(while (setq a (cdr a))
(setq mat (cons (cons 'vec
- (mapcar (function (lambda (x)
- (math-build-call func
- (list (car a)
- x))))
+ (mapcar (lambda (x)
+ (math-build-call func
+ (list (car a)
+ x)))
(cdr b)))
mat)))
(math-normalize (cons 'vec (nreverse mat)))))
@@ -1229,9 +1230,11 @@
(defvar math-inner-mul-func)
(defvar math-inner-add-func)
-(defun calcFunc-inner (math-inner-mul-func math-inner-add-func a b)
+(defun calcFunc-inner (inner-mul-func inner-add-func a b)
(or (math-vectorp a) (math-reject-arg a 'vectorp))
(or (math-vectorp b) (math-reject-arg b 'vectorp))
+ (let ((math-inner-mul-func inner-mul-func)
+ (math-inner-add-func inner-add-func))
(if (math-matrixp a)
(if (math-matrixp b)
(if (= (length (nth 1 a)) (length b))
@@ -1247,12 +1250,12 @@
(math-dimension-error))))
(if (math-matrixp b)
(nth 1 (math-inner-mats (list 'vec a) b))
- (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))
+ (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b))))))
(defun math-inner-mats (a b)
(let ((mat nil)
(cols (length (nth 1 b)))
- row col ap bp accum)
+ row col) ;; ap bp accum
(while (setq a (cdr a))
(setq col cols
row nil)
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el
index ede9daa5039..1c2e7bcf2bc 100644
--- a/lisp/calc/calc-math.el
+++ b/lisp/calc/calc-math.el
@@ -1,4 +1,4 @@
-;;; calc-math.el --- mathematical functions for Calc
+;;; calc-math.el --- mathematical functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -60,33 +60,23 @@
pow
(< pow 1.0e+INF))
(setq x (* 2 x))
- (setq pow (condition-case nil
- (expt 10.0 (* 2 x))
- (error nil))))
+ (setq pow (ignore-errors (expt 10.0 (* 2 x)))))
;; The following loop should stop when 10^(x+1) is too large.
- (setq pow (condition-case nil
- (expt 10.0 (1+ x))
- (error nil)))
+ (setq pow (ignore-errors (expt 10.0 (1+ x))))
(while (and
pow
(< pow 1.0e+INF))
(setq x (1+ x))
- (setq pow (condition-case nil
- (expt 10.0 (1+ x))
- (error nil))))
+ (setq pow (ignore-errors (expt 10.0 (1+ x)))))
(1- x))
"The largest exponent which Calc will convert to an Emacs float.")
(defvar math-smallest-emacs-expt
(let ((x -1))
- (while (condition-case nil
- (> (expt 10.0 x) 0.0)
- (error nil))
+ (while (ignore-errors (> (expt 10.0 x) 0.0))
(setq x (* 2 x)))
(setq x (/ x 2))
- (while (condition-case nil
- (> (expt 10.0 x) 0.0)
- (error nil))
+ (while (ignore-errors (> (expt 10.0 x) 0.0))
(setq x (1- x)))
(+ x 2))
"The smallest exponent which Calc will convert to an Emacs float.")
@@ -100,19 +90,18 @@ If this can't be done, return NIL."
(let* ((xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x))))))
(and (<= math-smallest-emacs-expt xpon)
(<= xpon math-largest-emacs-expt)
- (condition-case nil
- (math-read-number
- (number-to-string
- (funcall fn
- (string-to-number
- (let
- ((calc-number-radix 10)
- (calc-twos-complement-mode nil)
- (calc-float-format (list 'float calc-internal-prec))
- (calc-group-digits nil)
- (calc-point-char "."))
- (math-format-number (math-float x)))))))
- (error nil))))))
+ (ignore-errors
+ (math-read-number
+ (number-to-string
+ (funcall fn
+ (string-to-number
+ (let
+ ((calc-number-radix 10)
+ (calc-twos-complement-mode nil)
+ (calc-float-format (list 'float calc-internal-prec))
+ (calc-group-digits nil)
+ (calc-point-char "."))
+ (math-format-number (math-float x))))))))))))
(defun calc-sqrt (arg)
(interactive "P")
@@ -381,18 +370,6 @@ If this can't be done, return NIL."
(math-isqrt (math-floor a))
(math-floor (math-sqrt a))))
-(defun math-zerop-bignum (a)
- (and (eq (car a) 0)
- (progn
- (while (eq (car (setq a (cdr a))) 0))
- (null a))))
-
-(defun math-scale-bignum-digit-size (a n) ; [L L S]
- (while (> n 0)
- (setq a (cons 0 a)
- n (1- n)))
- a)
-
;;; Compute the square root of a number.
;;; [T N] if possible, else [F N] if possible, else [C N]. [Public]
(defun math-sqrt (a)
@@ -638,11 +615,11 @@ If this can't be done, return NIL."
(defvar math-nrf-nf)
(defvar math-nrf-nfm1)
-(defun math-nth-root-float (a math-nrf-n &optional guess)
+(defun math-nth-root-float (a nrf-n &optional guess)
(math-inexact-result)
(math-with-extra-prec 1
- (let ((math-nrf-nf (math-float math-nrf-n))
- (math-nrf-nfm1 (math-float (1- math-nrf-n))))
+ (let ((math-nrf-nf (math-float nrf-n))
+ (math-nrf-nfm1 (math-float (1- nrf-n))))
(math-nth-root-float-iter a (or guess
(math-make-float
1 (/ (+ (math-numdigs (nth 1 a))
@@ -665,18 +642,19 @@ If this can't be done, return NIL."
;; math-nth-root-int.
(defvar math-nri-n)
-(defun math-nth-root-integer (a math-nri-n &optional guess) ; [I I S]
- (math-nth-root-int-iter a (or guess
- (math-scale-int 1 (/ (+ (math-numdigs a)
- (1- math-nri-n))
- math-nri-n)))))
+(defun math-nth-root-integer (a nri-n &optional guess) ; [I I S]
+ (let ((math-nri-n nri-n))
+ (math-nth-root-int-iter a (or guess
+ (math-scale-int 1 (/ (+ (math-numdigs a)
+ (1- nri-n))
+ nri-n))))))
(defun math-nth-root-int-iter (a guess)
(math-working "root" guess)
(let* ((q (math-idivmod a (math-ipow guess (1- math-nri-n))))
(s (math-add (car q) (math-mul (1- math-nri-n) guess)))
(g2 (math-idivmod s math-nri-n)))
- (if (Math-natnum-lessp (car g2) guess)
+ (if (< (car g2) guess)
(math-nth-root-int-iter a (car g2))
(cons (and (equal (car g2) guess)
(eq (cdr q) 0)
@@ -693,13 +671,13 @@ If this can't be done, return NIL."
;;;; Transcendental functions.
-;;; All of these functions are defined on the complex plane.
-;;; (Branch cuts, etc. follow Steele's Common Lisp book.)
+;; All of these functions are defined on the complex plane.
+;; (Branch cuts, etc. follow Steele's Common Lisp book.)
-;;; Most functions increase calc-internal-prec by 2 digits, then round
-;;; down afterward. "-raw" functions use the current precision, require
-;;; their arguments to be in float (or complex float) format, and always
-;;; work in radians (where applicable).
+;; Most functions increase calc-internal-prec by 2 digits, then round
+;; down afterward. "-raw" functions use the current precision, require
+;; their arguments to be in float (or complex float) format, and always
+;; work in radians (where applicable).
(defun math-to-radians (a) ; [N N]
(cond ((eq (car-safe a) 'hms)
@@ -1126,9 +1104,9 @@ If this can't be done, return NIL."
(math-div-float (cdr sc) (car sc)))))))
-;;; This could use a smarter method: Reduce x as in math-sin-raw, then
-;;; compute either sin(x) or cos(x), whichever is smaller, and compute
-;;; the other using the identity sin(x)^2 + cos(x)^2 = 1.
+;; This could use a smarter method: Reduce x as in math-sin-raw, then
+;; compute either sin(x) or cos(x), whichever is smaller, and compute
+;; the other using the identity sin(x)^2 + cos(x)^2 = 1.
(defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x))
(cons (math-sin-raw x) (math-cos-raw x)))
@@ -1625,7 +1603,7 @@ If this can't be done, return NIL."
(math-natnump b) (not (eq b 0)))
(if (eq b 1)
(math-reject-arg x "*Logarithm base one")
- (if (Math-natnum-lessp x b)
+ (if (< x b)
0
(cdr (math-integer-log x b))))
(math-floor (calcFunc-log x b))))
@@ -2072,7 +2050,7 @@ If this can't be done, return NIL."
(put 'calcFunc-arctanh 'math-expandable t)
-;;; Convert A from HMS or degrees to radians.
+;; Convert A from HMS or degrees to radians.
(defun calcFunc-rad (a) ; [R R] [Public]
(cond ((or (Math-numberp a)
(eq (car a) 'intv))
@@ -2089,7 +2067,7 @@ If this can't be done, return NIL."
(t (list 'calcFunc-rad a))))
(put 'calcFunc-rad 'math-expandable t)
-;;; Convert A from HMS or radians to degrees.
+;; Convert A from HMS or radians to degrees.
(defun calcFunc-deg (a) ; [R R] [Public]
(cond ((or (Math-numberp a)
(eq (car a) 'intv))
diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el
index 7aa8d7f2b80..516f62d7b63 100644
--- a/lisp/calc/calc-menu.el
+++ b/lisp/calc/calc-menu.el
@@ -1,4 +1,4 @@
-;;; calc-menu.el --- a menu for Calc
+;;; calc-menu.el --- a menu for Calc -*- lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -781,7 +781,7 @@
:active (>= (calc-stack-size) 2)
:help "The cross product in R^3"]
["(2:) dot (1:)"
- calc-mult
+ calc-times
:keys "*"
:active (>= (calc-stack-size) 2)
:help "The dot product"]
@@ -1669,3 +1669,5 @@
["Quit" calc-quit]))
(provide 'calc-menu)
+
+;;; calc-menu.el ends here
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index fa081872e8b..b573c53f418 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -1,4 +1,4 @@
-;;; calc-misc.el --- miscellaneous functions for Calc
+;;; calc-misc.el --- miscellaneous functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -176,9 +176,9 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C).
"Create another, independent Calculator buffer."
(interactive)
(if (eq major-mode 'calc-mode)
- (mapc (function
- (lambda (v)
- (set-default v (symbol-value v)))) calc-local-var-list))
+ (mapc (lambda (v)
+ (set-default v (symbol-value v)))
+ calc-local-var-list))
(set-buffer (generate-new-buffer "*Calculator*"))
(pop-to-buffer (current-buffer))
(calc-mode))
@@ -274,9 +274,8 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C).
;;;###autoload
(defun calc-do-handle-whys ()
(setq calc-why (sort calc-next-why
- (function
- (lambda (x y)
- (and (eq (car x) '*) (not (eq (car y) '*))))))
+ (lambda (x y)
+ (and (eq (car x) '*) (not (eq (car y) '*)))))
calc-next-why nil)
(if (and calc-why (or (eq calc-auto-why t)
(and (eq (car (car calc-why)) '*)
@@ -505,7 +504,7 @@ With argument 0, switch line point is in with line mark is in."
;; 3 <-- mid-line = 3
;; 4 <-- point
;; 5 <-- bot-line = 5
- (dotimes (i mid-line)
+ (dotimes (_ mid-line)
(setq mid-cell old-top-list
old-top-list (cdr old-top-list))
(setcdr mid-cell new-top-list)
@@ -519,7 +518,7 @@ With argument 0, switch line point is in with line mark is in."
;; 2
;; 1
(setq prev-mid-cell old-top-list)
- (dotimes (i (- bot-line mid-line))
+ (dotimes (_ (- bot-line mid-line))
(setq bot-cell old-top-list
old-top-list (cdr old-top-list))
(setcdr bot-cell new-top-list)
@@ -757,19 +756,21 @@ loaded and the keystroke automatically re-typed."
;; The variable math-trunc-prec is local to math-trunc, but used by
;; math-trunc-fancy in calc-arith.el, which is called by math-trunc.
+(defvar math-trunc-prec)
;;;###autoload
-(defun math-trunc (a &optional math-trunc-prec)
- (cond (math-trunc-prec
+(defun math-trunc (a &optional trunc-prec)
+ (cond (trunc-prec
(require 'calc-ext)
- (math-trunc-special a math-trunc-prec))
+ (math-trunc-special a trunc-prec))
((Math-integerp a) a)
((Math-looks-negp a)
(math-neg (math-trunc (math-neg a))))
((eq (car a) 'float)
(math-scale-int (nth 1 a) (nth 2 a)))
(t (require 'calc-ext)
- (math-trunc-fancy a))))
+ (let ((math-trunc-prec trunc-prec))
+ (math-trunc-fancy a)))))
;;;###autoload
(defalias 'calcFunc-trunc 'math-trunc)
@@ -777,12 +778,13 @@ loaded and the keystroke automatically re-typed."
;; The variable math-floor-prec is local to math-floor, but used by
;; math-floor-fancy in calc-arith.el, which is called by math-floor.
+(defvar math-floor-prec)
;;;###autoload
-(defun math-floor (a &optional math-floor-prec) ; [Public]
- (cond (math-floor-prec
+(defun math-floor (a &optional floor-prec) ; [Public]
+ (cond (floor-prec
(require 'calc-ext)
- (math-floor-special a math-floor-prec))
+ (math-floor-special a floor-prec))
((Math-integerp a) a)
((Math-messy-integerp a) (math-trunc a))
((Math-realp a)
@@ -790,7 +792,9 @@ loaded and the keystroke automatically re-typed."
(math-add (math-trunc a) -1)
(math-trunc a)))
(t (require 'calc-ext)
- (math-floor-fancy a))))
+ (let ((math-floor-prec floor-prec))
+ (math-floor-fancy a)))))
+
;;;###autoload
(defalias 'calcFunc-floor 'math-floor)
diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el
index 93be713da48..68c8b90ac3b 100644
--- a/lisp/calc/calc-mode.el
+++ b/lisp/calc/calc-mode.el
@@ -1,4 +1,4 @@
-;;; calc-mode.el --- calculator modes for Calc
+;;; calc-mode.el --- calculator modes for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -268,7 +268,7 @@
(interactive)
(calc-wrapper
(let (pos
- (vals (mapcar (function (lambda (v) (symbol-value (car v))))
+ (vals (mapcar (lambda (v) (symbol-value (car v)))
calc-mode-var-list)))
(unless calc-settings-file
(error "No `calc-settings-file' specified"))
@@ -424,8 +424,8 @@
(t
"Not recording mode changes permanently")))))
-(defun calc-total-algebraic-mode (flag)
- (interactive "P")
+(defun calc-total-algebraic-mode (&optional _flag)
+ (interactive)
(calc-wrapper
(if (eq calc-algebraic-mode 'total)
(calc-algebraic-mode nil)
diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el
index c7ea228c5c2..9a08b8cb76a 100644
--- a/lisp/calc/calc-mtx.el
+++ b/lisp/calc/calc-mtx.el
@@ -1,4 +1,4 @@
-;;; calc-mtx.el --- matrix functions for Calc
+;;; calc-mtx.el --- matrix functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@
(defun math-col-matrix (a)
(if (and (Math-vectorp a)
(not (math-matrixp a)))
- (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a)))
+ (cons 'vec (mapcar (lambda (x) (list 'vec x)) (cdr a)))
a))
@@ -79,8 +79,8 @@
(cons 'vec (nreverse mat))))
(defun math-mul-mat-vec (a b)
- (cons 'vec (mapcar (function (lambda (row)
- (math-dot-product row b)))
+ (cons 'vec (mapcar (lambda (row)
+ (math-dot-product row b))
(cdr a))))
@@ -275,7 +275,7 @@ in LUD decomposition."
k (1+ k)))
(setcar (nthcdr j (nth i lu)) sum)
(let ((dum (math-lud-pivot-check sum)))
- (if (Math-lessp big dum)
+ (if (or (math-zerop big) (Math-lessp big dum))
(setq big dum
imax i)))
(setq i (1+ i)))
diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el
index 8cfc2824b54..f676b098e58 100644
--- a/lisp/calc/calc-nlfit.el
+++ b/lisp/calc/calc-nlfit.el
@@ -1,4 +1,4 @@
-;;; calc-nlfit.el --- nonlinear curve fitting for Calc
+;;; calc-nlfit.el --- nonlinear curve fitting for Calc -*- lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -104,19 +104,19 @@
(list 'vec C12 C22))))
(list A B)))))
-;;; The methods described by de Sousa require the cumulative data qdata
-;;; and the rates pdata. We will assume that we are given either
-;;; qdata and the corresponding times tdata, or pdata and the corresponding
-;;; tdata. The following two functions will find pdata or qdata,
-;;; given the other..
+;; The methods described by de Sousa require the cumulative data qdata
+;; and the rates pdata. We will assume that we are given either
+;; qdata and the corresponding times tdata, or pdata and the corresponding
+;; tdata. The following two functions will find pdata or qdata,
+;; given the other..
-;;; First, given two lists; one of values q0, q1, ..., qn and one of
-;;; corresponding times t0, t1, ..., tn; return a list
-;;; p0, p1, ..., pn of the rates of change of the qi with respect to t.
-;;; p0 is the right hand derivative (q1 - q0)/(t1 - t0).
-;;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)).
-;;; The other pis are the averages of the two:
-;;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)).
+;; First, given two lists; one of values q0, q1, ..., qn and one of
+;; corresponding times t0, t1, ..., tn; return a list
+;; p0, p1, ..., pn of the rates of change of the qi with respect to t.
+;; p0 is the right hand derivative (q1 - q0)/(t1 - t0).
+;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)).
+;; The other pis are the averages of the two:
+;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)).
(defun math-nlfit-get-rates-from-cumul (tdata qdata)
(let ((pdata (list
@@ -153,12 +153,12 @@
pdata))
(reverse pdata)))
-;;; Next, given two lists -- one of rates p0, p1, ..., pn and one of
-;;; corresponding times t0, t1, ..., tn -- and an initial values q0,
-;;; return a list q0, q1, ..., qn of the cumulative values.
-;;; q0 is the initial value given.
-;;; For i>0, qi is computed using the trapezoid rule:
-;;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1))
+;; Next, given two lists -- one of rates p0, p1, ..., pn and one of
+;; corresponding times t0, t1, ..., tn -- and an initial values q0,
+;; return a list q0, q1, ..., qn of the cumulative values.
+;; q0 is the initial value given.
+;; For i>0, qi is computed using the trapezoid rule:
+;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1))
(defun math-nlfit-get-cumul-from-rates (tdata pdata q0)
(let* ((qdata (list q0)))
@@ -177,16 +177,16 @@
(setq tdata (cdr tdata)))
(reverse qdata)))
-;;; Given the qdata, pdata and tdata, find the parameters
-;;; a, b and c that fit q = a/(1+b*exp(c*t)).
-;;; a is found using the method described by de Sousa.
-;;; b and c are found using least squares on the linearization
-;;; log((a/q)-1) = log(b) + c*t
-;;; In some cases (where the logistic curve may well be the wrong
-;;; model), the computed a will be less than or equal to the maximum
-;;; value of q in qdata; in which case the above linearization won't work.
-;;; In this case, a will be replaced by a number slightly above
-;;; the maximum value of q.
+;; Given the qdata, pdata and tdata, find the parameters
+;; a, b and c that fit q = a/(1+b*exp(c*t)).
+;; a is found using the method described by de Sousa.
+;; b and c are found using least squares on the linearization
+;; log((a/q)-1) = log(b) + c*t
+;; In some cases (where the logistic curve may well be the wrong
+;; model), the computed a will be less than or equal to the maximum
+;; value of q in qdata; in which case the above linearization won't work.
+;; In this case, a will be replaced by a number slightly above
+;; the maximum value of q.
(defun math-nlfit-find-qmax (qdata pdata tdata)
(let* ((ratios (math-map-binop 'math-div pdata qdata))
@@ -208,12 +208,12 @@
(calcFunc-exp (nth 0 bandc))
(nth 1 bandc))))
-;;; Next, given the pdata and tdata, we can find the qdata if we know q0.
-;;; We first try to find q0, using the fact that when p takes on its largest
-;;; value, q is half of its maximum value. So we'll find the maximum value
-;;; of q given various q0, and use bisection to approximate the correct q0.
+;; Next, given the pdata and tdata, we can find the qdata if we know q0.
+;; We first try to find q0, using the fact that when p takes on its largest
+;; value, q is half of its maximum value. So we'll find the maximum value
+;; of q given various q0, and use bisection to approximate the correct q0.
-;;; First, given pdata and tdata, find what half of qmax would be if q0=0.
+;; First, given pdata and tdata, find what half of qmax would be if q0=0.
(defun math-nlfit-find-qmaxhalf (pdata tdata)
(let ((pmax (math-max-list (car pdata) (cdr pdata)))
@@ -231,7 +231,7 @@
(setq tdata (cdr tdata)))
qmh))
-;;; Next, given pdata and tdata, approximate q0.
+;; Next, given pdata and tdata, approximate q0.
(defun math-nlfit-find-q0 (pdata tdata)
(let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata))
@@ -250,7 +250,7 @@
(setq q0 (math-add q0 qhalf)))
(let* ((qmin (math-sub q0 qhalf))
(qmax q0)
- (qt (math-nlfit-find-qmax
+ (_qt (math-nlfit-find-qmax
(mapcar
(lambda (q) (math-add q0 q))
qdata)
@@ -270,20 +270,20 @@
(setq i (1+ i)))
(math-mul '(float 5 -1) (math-add qmin qmax)))))
-;;; To improve the approximations to the parameters, we can use
-;;; Marquardt method as described in Schwarz's book.
+;; To improve the approximations to the parameters, we can use
+;; Marquardt method as described in Schwarz's book.
-;;; Small numbers used in the Givens algorithm
+;; Small numbers used in the Givens algorithm
(defvar math-nlfit-delta '(float 1 -8))
(defvar math-nlfit-epsilon '(float 1 -5))
-;;; Maximum number of iterations
+;; Maximum number of iterations
(defvar math-nlfit-max-its 100)
-;;; Next, we need some functions for dealing with vectors and
-;;; matrices. For convenience, we'll work with Emacs lists
-;;; as vectors, rather than Calc's vectors.
+;; Next, we need some functions for dealing with vectors and
+;; matrices. For convenience, we'll work with Emacs lists
+;; as vectors, rather than Calc's vectors.
(defun math-nlfit-set-elt (vec i x)
(setcar (nthcdr (1- i) vec) x))
@@ -589,7 +589,7 @@
(calcFunc-trn j) j))
(calcFunc-inv j)))
-(defun math-nlfit-get-sigmas (grad xlist pparms chisq)
+(defun math-nlfit-get-sigmas (grad xlist pparms _chisq)
(let* ((sgs nil)
(covar (math-nlfit-find-covar grad xlist pparms))
(n (1- (length covar)))
@@ -664,6 +664,10 @@
(calc-pop-push-record-list n prefix vals)
(calc-handle-whys))
+(defvar calc-curve-nvars)
+(defvar calc-curve-varnames)
+(defvar calc-curve-coefnames)
+
(defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv)
(calc-slow-wrapper
(let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit)))
@@ -678,7 +682,7 @@
(calc-curve-varnames nil)
(calc-curve-coefnames nil)
(calc-curve-nvars 1)
- (fitvars (calc-get-fit-variables 1 3))
+ (_fitvars (calc-get-fit-variables 1 3))
(var (nth 1 calc-curve-varnames))
(parms (cdr calc-curve-coefnames))
(parmguess
@@ -763,7 +767,7 @@
(calc-curve-varnames nil)
(calc-curve-coefnames nil)
(calc-curve-nvars 1)
- (fitvars (calc-get-fit-variables 1 2))
+ (_fitvars (calc-get-fit-variables 1 2))
(var (nth 1 calc-curve-varnames))
(parms (cdr calc-curve-coefnames))
(soln (list '* (nth 0 finalparms)
@@ -815,3 +819,5 @@
(calc-record traillist "parm")))))
(provide 'calc-nlfit)
+
+;;; calc-nlfit.el ends here
diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el
index b3e1c1e073d..77587cc4b86 100644
--- a/lisp/calc/calc-poly.el
+++ b/lisp/calc/calc-poly.el
@@ -202,7 +202,7 @@
(if (memq (car-safe expr) '(+ -))
(math-list-to-sum
(sort (math-sum-to-list expr)
- (function (lambda (a b) (math-beforep (car a) (car b))))))
+ (lambda (a b) (math-beforep (car a) (car b)))))
expr))
(defun math-list-to-sum (lst)
@@ -387,7 +387,7 @@ This returns only the remainder from the pseudo-division."
lst
(if (eq a -1)
(math-mul-list lst a)
- (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst))))
+ (mapcar (lambda (x) (math-poly-div-exact x a)) lst))))
(defun math-mul-list (lst a)
(if (eq a 1)
@@ -395,7 +395,7 @@ This returns only the remainder from the pseudo-division."
(if (eq a -1)
(mapcar 'math-neg lst)
(and (not (eq a 0))
- (mapcar (function (lambda (x) (math-mul x a))) lst)))))
+ (mapcar (lambda (x) (math-mul x a)) lst)))))
;;; Run GCD on all elements in a list.
(defun math-poly-gcd-list (lst)
@@ -502,10 +502,10 @@ Take the base that has the highest degree considering both a and b.
(defun math-sort-poly-base-list (lst)
"Sort a list of polynomial bases."
- (sort lst (function (lambda (a b)
- (or (> (nth 1 a) (nth 1 b))
- (and (= (nth 1 a) (nth 1 b))
- (math-beforep (car a) (car b))))))))
+ (sort lst (lambda (a b)
+ (or (> (nth 1 a) (nth 1 b))
+ (and (= (nth 1 a) (nth 1 b))
+ (math-beforep (car a) (car b)))))))
;;; Given an expression find all variables that are polynomial bases.
;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).
@@ -1033,10 +1033,9 @@ If no partial fraction representation can be found, return nil."
(math-transpose
(cons 'vec
(mapcar
- (function
- (lambda (x)
- (cons 'vec (math-padded-polynomial
- x var tdeg))))
+ (lambda (x)
+ (cons 'vec (math-padded-polynomial
+ x var tdeg)))
(cdr eqns))))))
(and (math-vectorp eqns)
(let ((res 0)
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 7755a71bace..4e27d7671e2 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -1,4 +1,4 @@
-;;; calc-prog.el --- user programmability functions for Calc
+;;; calc-prog.el --- user programmability functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -111,10 +111,15 @@
"Not reporting timing of commands"))))
(defun calc-pass-errors ()
+ ;; FIXME: This is broken at least since Emacs-26.
+ ;; AFAICT the immediate purpose of this code is to hack the
+ ;; `condition-case' in `calc-do' so it doesn't catch errors any
+ ;; more. I'm not sure why/whatfor this was designed, but I suspect
+ ;; that `condition-case-unless-debug' would cover the same needs.
(interactive)
;; The following two cases are for the new, optimizing byte compiler
;; or the standard 18.57 byte compiler, respectively.
- (condition-case err
+ (condition-case nil
(let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
(or (memq (car-safe (car-safe place)) '(error xxxerror))
(setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
@@ -165,6 +170,7 @@
;; calc-user-define-composition and calc-finish-formula-edit,
;; but is used by calc-fix-user-formula.
(defvar calc-user-formula-alist)
+(defvar math-arglist) ; dynamically bound in all callers
(defun calc-user-define-formula ()
(interactive)
@@ -176,7 +182,7 @@
odef key keyname cmd cmd-base cmd-base-default
func calc-user-formula-alist is-symb)
(if is-lambda
- (setq math-arglist (mapcar (function (lambda (x) (nth 1 x)))
+ (setq math-arglist (mapcar (lambda (x) (nth 1 x))
(nreverse (cdr (reverse (cdr form)))))
form (nth (1- (length form)) form))
(calc-default-formula-arglist form)
@@ -284,10 +290,10 @@
(y-or-n-p
"Leave it symbolic for non-constant arguments? ")))
(setq calc-user-formula-alist
- (mapcar (function (lambda (x)
- (or (cdr (assq x '((nil . arg-nil)
- (t . arg-t))))
- x))) calc-user-formula-alist))
+ (mapcar (lambda (x)
+ (or (cdr (assq x '((nil . arg-nil)
+ (t . arg-t))))
+ x)) calc-user-formula-alist))
(if cmd
(progn
(require 'calc-macs)
@@ -313,8 +319,8 @@
(append
(list 'lambda calc-user-formula-alist)
(and is-symb
- (mapcar (function (lambda (v)
- (list 'math-check-const v t)))
+ (mapcar (lambda (v)
+ (list 'math-check-const v t))
calc-user-formula-alist))
(list body))))
(put func 'calc-user-defn form)
@@ -328,7 +334,6 @@
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
(message "")))
-(defvar math-arglist) ; dynamically bound in all callers
(defun calc-default-formula-arglist (form)
(if (consp form)
(if (eq (car form) 'var)
@@ -478,13 +483,13 @@
(interactive)
(calc-wrapper
(let ((lang calc-language))
- (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
- t
- (format "Editing %s-Mode Syntax Table. "
- (cond ((null lang) "Normal")
- ((eq lang 'tex) "TeX")
- ((eq lang 'latex) "LaTeX")
- (t (capitalize (symbol-name lang))))))
+ (calc--edit-mode (lambda () (calc-finish-user-syntax-edit lang))
+ t
+ (format "Editing %s-Mode Syntax Table. "
+ (cond ((null lang) "Normal")
+ ((eq lang 'tex) "TeX")
+ ((eq lang 'latex) "LaTeX")
+ (t (capitalize (symbol-name lang))))))
(calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
lang)))
(calc-show-edit-buffer))
@@ -511,8 +516,9 @@
;; is called (indirectly) by calc-read-parse-table.
(defvar calc-lang)
-(defun calc-write-parse-table (tab calc-lang)
- (let ((p tab))
+(defun calc-write-parse-table (tab lang)
+ (let ((calc-lang lang)
+ (p tab))
(while p
(calc-write-parse-table-part (car (car p)))
(insert ":= "
@@ -551,8 +557,9 @@
(insert " "))))
(setq p (cdr p))))
-(defun calc-read-parse-table (calc-buf calc-lang)
- (let ((tab nil))
+(defun calc-read-parse-table (calc-buf lang)
+ (let ((calc-lang lang)
+ (tab nil))
(while (progn
(skip-chars-forward "\n\t ")
(not (eobp)))
@@ -689,12 +696,13 @@
(setq cmd (symbol-function cmd)))
(cond ((or (stringp cmd)
(and (consp cmd)
- (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
+ (eq (car-safe (nth 3 cmd)) #'calc-execute-kbd-macro)))
+ ;; FIXME: Won't (nth 3 cmd) fail when (stringp cmd)?
(let* ((mac (elt (nth 1 (nth 3 cmd)) 1))
(str (edmacro-format-keys mac t))
(kys (nth 3 (nth 3 cmd))))
- (calc-edit-mode
- (list 'calc-edit-macro-finish-edit cmdname kys)
+ (calc--edit-mode
+ (lambda () (calc-edit-macro-finish-edit cmdname kys))
t (format (concat
"Editing keyboard macro (%s, bound to %s).\n"
"Original keys: %s \n")
@@ -712,8 +720,8 @@
(if (and defn (calc-valid-formula-func func))
(let ((niceexpr (math-format-nice-expr defn (frame-width))))
(calc-wrapper
- (calc-edit-mode
- (list 'calc-finish-formula-edit (list 'quote func))
+ (calc--edit-mode
+ (lambda () (calc-finish-formula-edit func))
nil
(format (concat
"Editing formula (%s, %s, bound to %s).\n"
@@ -860,7 +868,7 @@
(defun calc-edit-macro-combine-digits ()
"Put an entire sequence of digits on a single line."
(let ((line (calc-edit-macro-command))
- curline)
+ ) ;; curline
(goto-char (line-beginning-position))
(kill-line 1)
(while (string-equal (calc-edit-macro-command-type) "calcDigit-start")
@@ -1038,7 +1046,7 @@ Redefine the corresponding command."
(let* ((cmd (cdr def))
(fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
(func nil)
- (pt (point))
+ ;; (pt (point))
(fill-column 70)
(fill-prefix nil)
str q-ok)
@@ -1873,9 +1881,9 @@ Redefine the corresponding command."
(if (fboundp (setq chk (intern (concat "math-" qual-name))))
(append rest
(if is-rest
- `((mapcar #'(lambda (x)
- (or (,chk x)
- (math-reject-arg x ',qual)))
+ `((mapcar (lambda (x)
+ (or (,chk x)
+ (math-reject-arg x ',qual)))
,var))
`((or (,chk ,var)
(math-reject-arg ,var ',qual)))))
@@ -1886,9 +1894,9 @@ Redefine the corresponding command."
qual-name 1))))))
(append rest
(if is-rest
- `((mapcar #'(lambda (x)
- (and (,chk x)
- (math-reject-arg x ',qual)))
+ `((mapcar (lambda (x)
+ (and (,chk x)
+ (math-reject-arg x ',qual)))
,var))
`((and
(,chk ,var)
@@ -1945,8 +1953,9 @@ Redefine the corresponding command."
;; by math-define-body.
(defvar math-exp-env)
-(defun math-define-body (body math-exp-env)
- (math-define-list body))
+(defun math-define-body (body exp-env)
+ (let ((math-exp-env exp-env))
+ (math-define-list body)))
(defun math-define-list (body &optional quote)
(cond ((null body)
@@ -1976,22 +1985,37 @@ Redefine the corresponding command."
(cons 'quote
(math-define-lambda (nth 1 exp) math-exp-env))
exp))
- ((memq func '(let let* for foreach))
- (let ((head (nth 1 exp))
- (body (cdr (cdr exp))))
- (if (memq func '(let let*))
- ()
- (setq func (cdr (assq func '((for . math-for)
- (foreach . math-foreach)))))
- (if (not (listp (car head)))
- (setq head (list head))))
- (macroexpand
- (cons func
- (cons (math-define-let head)
- (math-define-body body
- (nconc
- (math-define-let-env head)
- math-exp-env)))))))
+ ((eq func 'let)
+ (let ((bindings (nth 1 exp))
+ (body (cddr exp)))
+ `(let ,(math-define-let bindings)
+ ,@(math-define-body
+ body (append (math-define-let-env bindings)
+ math-exp-env)))))
+ ((eq func 'let*)
+ ;; Rewrite in terms of `let'.
+ (let ((bindings (nth 1 exp))
+ (body (cddr exp)))
+ (math-define-exp
+ (if (> (length bindings) 1)
+ `(let ,(list (car bindings))
+ (let* ,(cdr bindings) ,@body))
+ `(let ,bindings ,@body)))))
+ ((memq func '(for foreach))
+ (let ((bindings (nth 1 exp))
+ (body (cddr exp)))
+ (if (> (length bindings) 1)
+ ;; Rewrite as nested loops.
+ (math-define-exp
+ `(,func ,(list (car bindings))
+ (,func ,(cdr bindings) ,@body)))
+ (let ((mac (cdr (assq func '((for . math-for)
+ (foreach . math-foreach))))))
+ (macroexpand
+ `(,mac ,(math-define-let bindings)
+ ,@(math-define-body
+ body (append (math-define-let-env bindings)
+ math-exp-env))))))))
((and (memq func '(setq setf))
(math-complicated-lhs (cdr exp)))
(if (> (length exp) 3)
@@ -2008,7 +2032,7 @@ Redefine the corresponding command."
(math-define-cond (cdr exp))))
((and (consp func) ; ('spam a b) == force use of plain spam
(eq (car func) 'quote))
- (cons func (math-define-list (cdr exp))))
+ (cons (cadr func) (math-define-list (cdr exp))))
((symbolp func)
(let ((args (math-define-list (cdr exp)))
(prim (assq func math-prim-funcs)))
@@ -2267,20 +2291,16 @@ Redefine the corresponding command."
(defun math-handle-foreach (head body)
(let ((var (nth 0 (car head)))
+ (loop-var (gensym "foreach"))
(data (nth 1 (car head)))
(body (if (cdr head)
(list (math-handle-foreach (cdr head) body))
body)))
- (cons 'let
- (cons (list (list var data))
- (list
- (cons 'while
- (cons var
- (append body
- (list (list 'setq
- var
- (list 'cdr var)))))))))))
-
+ `(let ((,loop-var ,data))
+ (while ,loop-var
+ (let ((,var (car ,loop-var)))
+ ,@(append body
+ `((setq ,loop-var (cdr ,loop-var)))))))))
(defun math-body-refers-to (body thing)
(or (equal body thing)
diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el
index f364b064ae8..e3d4852a721 100644
--- a/lisp/calc/calc-rewr.el
+++ b/lisp/calc/calc-rewr.el
@@ -1,4 +1,4 @@
-;;; calc-rewr.el --- rewriting functions for Calc
+;;; calc-rewr.el --- rewriting functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -142,7 +142,7 @@
(calc-pop-push-record-list n "rwrt" (list expr)))
(calc-handle-whys)))
-(defun calc-match (pat &optional interactive)
+(defun calc-match (pat &optional _interactive)
(interactive "sPattern: \np")
(calc-slow-wrapper
(let (n expr)
@@ -158,9 +158,9 @@
(setq expr (calc-top-n 1)
n 1))
(or (math-vectorp expr) (error "Argument must be a vector"))
- (if (calc-is-inverse)
- (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
- (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
+ (calc-enter-result n "mtcn"
+ (math-match-patterns pat expr
+ (not (not (calc-is-inverse))))))))
(defvar math-mt-many)
@@ -169,8 +169,10 @@
;; but is used by math-rewrite-phase
(defvar math-rewrite-whole-expr)
-(defun math-rewrite (math-rewrite-whole-expr rules &optional math-mt-many)
- (let* ((crules (math-compile-rewrites rules))
+(defun math-rewrite (rewrite-whole-expr rules &optional mt-many)
+ (let* ((math-rewrite-whole-expr rewrite-whole-expr)
+ (math-mt-many mt-many)
+ (crules (math-compile-rewrites rules))
(heads (math-rewrite-heads math-rewrite-whole-expr))
(trace-buffer (get-buffer "*Trace*"))
(calc-display-just 'center)
@@ -179,19 +181,18 @@
(calc-line-numbering nil)
(calc-show-selections t)
(calc-why nil)
- (math-mt-func (function
- (lambda (x)
- (let ((result (math-apply-rewrites x (cdr crules)
- heads crules)))
- (if result
- (progn
- (if trace-buffer
- (let ((fmt (math-format-stack-value
- (list result nil nil))))
- (with-current-buffer trace-buffer
- (insert "\nrewrite to\n" fmt "\n"))))
- (setq heads (math-rewrite-heads result heads t))))
- result)))))
+ (math-mt-func (lambda (x)
+ (let ((result (math-apply-rewrites x (cdr crules)
+ heads crules)))
+ (if result
+ (progn
+ (if trace-buffer
+ (let ((fmt (math-format-stack-value
+ (list result nil nil))))
+ (with-current-buffer trace-buffer
+ (insert "\nrewrite to\n" fmt "\n"))))
+ (setq heads (math-rewrite-heads result heads t))))
+ result))))
(if trace-buffer
(let ((fmt (math-format-stack-value (list math-rewrite-whole-expr nil nil))))
(with-current-buffer trace-buffer
@@ -211,6 +212,8 @@
":\n" fmt "\n"))))
math-rewrite-whole-expr))
+(defvar math-rewrite-phase 1)
+
(defun math-rewrite-phase (sched)
(while (and sched (/= math-mt-many 0))
(if (listp (car sched))
@@ -464,6 +467,8 @@
;;; whole match the name v. Beware of circular structures!
;;;
+(defvar math-rewrite-whole nil)
+
(defun math-compile-patterns (pats)
(if (and (eq (car-safe pats) 'var)
(calc-var-value (nth 2 pats)))
@@ -479,13 +484,12 @@
(let ((math-rewrite-whole t))
(cdr (math-compile-rewrites (cons
'vec
- (mapcar (function (lambda (x)
- (list 'vec x t)))
+ (mapcar (lambda (x)
+ (list 'vec x t))
(if (eq (car-safe pats) 'vec)
(cdr pats)
(list pats)))))))))
-(defvar math-rewrite-whole nil)
(defvar math-make-import-list nil)
;; The variable math-import-list is local to part of math-compile-rewrites,
@@ -580,7 +584,7 @@
(let ((rule-set nil)
(all-heads nil)
(nil-rules nil)
- (rule-count 0)
+ ;; (rule-count 0)
(math-schedule nil)
(math-iterations nil)
(math-phases nil)
@@ -651,15 +655,14 @@
nil
(nreverse
(mapcar
- (function
- (lambda (v)
- (and (car v)
- (list
- 'calcFunc-assign
- (math-build-var-name
- (car v))
- (math-rwcomp-register-expr
- (nth 1 v))))))
+ (lambda (v)
+ (and (car v)
+ (list
+ 'calcFunc-assign
+ (math-build-var-name
+ (car v))
+ (math-rwcomp-register-expr
+ (nth 1 v)))))
math-regs))))
(math-rwcomp-match-vars math-rhs))
math-remembering)
@@ -667,7 +670,7 @@
(let* ((heads (math-rewrite-heads math-pattern))
(rule (list (vconcat
(nreverse
- (mapcar (function (lambda (x) (nth 3 x)))
+ (mapcar (lambda (x) (nth 3 x))
math-regs)))
math-prog
heads
@@ -719,10 +722,9 @@
(setq rules (cdr rules)))
(if nil-rules
(setq rule-set (cons (cons nil nil-rules) rule-set)))
- (setq all-heads (mapcar 'car
- (sort all-heads (function
- (lambda (x y)
- (< (cdr x) (cdr y)))))))
+ (setq all-heads (mapcar #'car
+ (sort all-heads (lambda (x y)
+ (< (cdr x) (cdr y))))))
(let ((set rule-set)
rule heads ptr)
(while set
@@ -785,15 +787,14 @@
(math-rewrite-heads-rec (car expr)))))))
(defun math-parse-schedule (sched)
- (mapcar (function
- (lambda (s)
- (if (integerp s)
- s
- (if (math-vectorp s)
- (math-parse-schedule (cdr s))
- (if (eq (car-safe s) 'var)
- (math-var-to-calcFunc s)
- (error "Improper component in rewrite schedule"))))))
+ (mapcar (lambda (s)
+ (if (integerp s)
+ s
+ (if (math-vectorp s)
+ (math-parse-schedule (cdr s))
+ (if (eq (car-safe s) 'var)
+ (math-var-to-calcFunc s)
+ (error "Improper component in rewrite schedule")))))
sched))
(defun math-rwcomp-match-vars (expr)
@@ -831,14 +832,16 @@
(defvar math-rwcomp-subst-new-func)
(defvar math-rwcomp-subst-old-func)
-(defun math-rwcomp-substitute (expr math-rwcomp-subst-old math-rwcomp-subst-new)
- (if (and (eq (car-safe math-rwcomp-subst-old) 'var)
- (memq (car-safe math-rwcomp-subst-new) '(var calcFunc-lambda)))
- (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc math-rwcomp-subst-old))
- (math-rwcomp-subst-new-func (math-var-to-calcFunc math-rwcomp-subst-new)))
+(defun math-rwcomp-substitute (expr rwcomp-subst-old rwcomp-subst-new)
+ (let ((math-rwcomp-subst-old rwcomp-subst-old)
+ (math-rwcomp-subst-new rwcomp-subst-new))
+ (if (and (eq (car-safe rwcomp-subst-old) 'var)
+ (memq (car-safe rwcomp-subst-new) '(var calcFunc-lambda)))
+ (let ((math-rwcomp-subst-old-func (math-var-to-calcFunc rwcomp-subst-old))
+ (math-rwcomp-subst-new-func (math-var-to-calcFunc rwcomp-subst-new)))
(math-rwcomp-subst-rec expr))
(let ((math-rwcomp-subst-old-func nil))
- (math-rwcomp-subst-rec expr))))
+ (math-rwcomp-subst-rec expr)))))
(defun math-rwcomp-subst-rec (expr)
(cond ((equal expr math-rwcomp-subst-old) math-rwcomp-subst-new)
@@ -1173,9 +1176,8 @@
(list 'calcFunc-register
reg2))))
(math-rwcomp-pattern (car arg2) (cdr arg2))))
- (let* ((args (mapcar (function
- (lambda (x)
- (cons x (math-rwcomp-best-reg x))))
+ (let* ((args (mapcar (lambda (x)
+ (cons x (math-rwcomp-best-reg x)))
(cdr expr)))
(args2 (copy-sequence args))
(argp (reverse args2))
@@ -1452,8 +1454,6 @@
,form
(setcar rules orig))))
-(defvar math-rewrite-phase 1)
-
;; The variable math-apply-rw-regs is local to math-apply-rewrites,
;; but is used by math-rwapply-replace-regs and math-rwapply-reg-looks-negp
;; which are called by math-apply-rewrites.
@@ -1463,11 +1463,12 @@
;; but is used by math-rwapply-remember.
(defvar math-apply-rw-ruleset)
-(defun math-apply-rewrites (expr rules &optional heads math-apply-rw-ruleset)
+(defun math-apply-rewrites (expr rules &optional heads apply-rw-ruleset)
(and
(setq rules (cdr (or (assq (car-safe expr) rules)
(assq nil rules))))
- (let ((result nil)
+ (let ((math-apply-rw-ruleset apply-rw-ruleset)
+ (result nil)
op math-apply-rw-regs inst part pc mark btrack
(tracing math-rwcomp-tracing)
(phase math-rewrite-phase))
diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el
index 089a7bf0d62..00080b69891 100644
--- a/lisp/calc/calc-rules.el
+++ b/lisp/calc/calc-rules.el
@@ -1,4 +1,4 @@
-;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc
+;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el
index c378f474d88..18fd483bafe 100644
--- a/lisp/calc/calc-sel.el
+++ b/lisp/calc/calc-sel.el
@@ -1,4 +1,4 @@
-;;; calc-sel.el --- data selection functions for Calc
+;;; calc-sel.el --- data selection functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -146,7 +146,8 @@
(defvar calc-fnp-op)
(defvar calc-fnp-num)
-(defun calc-find-nth-part (expr calc-fnp-num)
+(defun calc-find-nth-part (expr fnp-num)
+ (let ((calc-fnp-num fnp-num))
(if (and calc-assoc-selections
(assq (car-safe expr) calc-assoc-ops))
(let (calc-fnp-op)
@@ -154,7 +155,7 @@
(if (eq (car-safe expr) 'intv)
(and (>= calc-fnp-num 1) (<= calc-fnp-num 2) (nth (1+ calc-fnp-num) expr))
(and (not (Math-primp expr)) (>= calc-fnp-num 1) (< calc-fnp-num (length expr))
- (nth calc-fnp-num expr)))))
+ (nth calc-fnp-num expr))))))
(defun calc-find-nth-part-rec (expr) ; uses num, op
(or (if (and (setq calc-fnp-op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
@@ -381,7 +382,7 @@
;; (if (or (< num 1) (> num (calc-stack-size)))
;; (error "Cursor must be positioned on a stack element"))
(let* ((entry (calc-top num 'entry))
- ww w)
+ ) ;; ww w
(or (equal entry calc-selection-cache-entry)
(progn
(setcar entry (calc-encase-atoms (car entry)))
@@ -418,6 +419,7 @@
;; The variable math-comp-sel-tag is local to calc-find-selected-part,
;; but is used by math-comp-sel-flat-term and math-comp-add-string-sel
;; in calccomp.el, which are called (indirectly) by calc-find-selected-part.
+(defvar math-comp-sel-tag)
(defun calc-find-selected-part ()
(let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
@@ -436,7 +438,8 @@
(current-indentation))
lcount (1+ lcount)))
(- lcount (math-comp-ascent
- calc-selection-cache-comp) -1))))
+ calc-selection-cache-comp)
+ -1))))
(math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
spaces lcount))
(math-comp-sel-tag nil))
@@ -481,9 +484,10 @@
(defvar calc-rsf-old)
(defvar calc-rsf-new)
-(defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new)
- (setq calc-rsf-new (calc-encase-atoms calc-rsf-new))
- (calc-replace-sub-formula-rec expr))
+(defun calc-replace-sub-formula (expr rsf-old rsf-new)
+ (let ((calc-rsf-old rsf-old)
+ (calc-rsf-new (calc-encase-atoms rsf-new)))
+ (calc-replace-sub-formula-rec expr)))
(defun calc-replace-sub-formula-rec (expr)
(cond ((eq expr calc-rsf-old) calc-rsf-new)
@@ -671,12 +675,12 @@
(entry (calc-top num 'entry))
(expr (car entry))
(sel (or (calc-auto-selection entry) expr))
- alg)
- (let ((str (math-showing-full-precision
- (math-format-nice-expr sel (frame-width)))))
- (calc-edit-mode (list 'calc-finish-selection-edit
- num (list 'quote sel) calc-sel-reselect))
- (insert str "\n"))))
+ ;; alg
+ (str (math-showing-full-precision
+ (math-format-nice-expr sel (frame-width))))
+ (csr calc-sel-reselect))
+ (calc--edit-mode (lambda () (calc-finish-selection-edit num sel csr)))
+ (insert str "\n")))
(calc-show-edit-buffer))
(defvar calc-original-buffer)
diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el
index 75aa9b5ac4f..3cf9bec8346 100644
--- a/lisp/calc/calc-stat.el
+++ b/lisp/calc/calc-stat.el
@@ -1,4 +1,4 @@
-;;; calc-stat.el --- statistical functions for Calc
+;;; calc-stat.el --- statistical functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el
index b018dcd9836..ee29c440fe4 100644
--- a/lisp/calc/calc-store.el
+++ b/lisp/calc/calc-store.el
@@ -1,4 +1,4 @@
-;;; calc-store.el --- value storage functions for Calc
+;;; calc-store.el --- value storage functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -168,15 +168,13 @@
()
(setq calc-var-name-map (copy-keymap minibuffer-local-completion-map))
(define-key calc-var-name-map " " 'self-insert-command)
- (mapc (function
- (lambda (x)
+ (mapc (lambda (x)
(define-key calc-var-name-map (char-to-string x)
- 'calcVar-digit)))
+ 'calcVar-digit))
"0123456789")
- (mapc (function
- (lambda (x)
+ (mapc (lambda (x)
(define-key calc-var-name-map (char-to-string x)
- 'calcVar-oper)))
+ 'calcVar-oper))
"+-*/^|"))
(defvar calc-store-opers)
@@ -184,10 +182,11 @@
(defvar calc-read-var-name-history nil
"History for reading variable names.")
-(defun calc-read-var-name (prompt &optional calc-store-opers)
+(defun calc-read-var-name (prompt &optional store-opers)
(setq calc-given-value nil
calc-aborted-prefix nil)
- (let ((var (concat
+ (let* ((calc-store-opers store-opers)
+ (var (concat
"var-"
(let ((minibuffer-completion-table
(mapcar (lambda (x) (substring x 4))
@@ -323,10 +322,9 @@
(calc-pop-push-record
(1+ calc-given-value-flag)
(concat "=" (calc-var-name (car (car var))))
- (let ((saved-val (mapcar (function
- (lambda (v)
- (and (boundp (car v))
- (symbol-value (car v)))))
+ (let ((saved-val (mapcar (lambda (v)
+ (and (boundp (car v))
+ (symbol-value (car v))))
var)))
(unwind-protect
(let ((vv var))
@@ -428,21 +426,21 @@
(defun calc-edit-variable (&optional var)
(interactive)
(calc-wrapper
- (or var (setq var (calc-read-var-name
- (if calc-last-edited-variable
- (format "Edit (default %s): "
- (calc-var-name calc-last-edited-variable))
- "Edit: "))))
+ (unless var
+ (setq var (calc-read-var-name
+ (format-prompt "Edit" (and calc-last-edited-variable
+ (calc-var-name
+ calc-last-edited-variable))))))
(or var (setq var calc-last-edited-variable))
(if var
(let* ((value (calc-var-value var)))
(if (eq (car-safe value) 'special-const)
(error "%s is a special constant" var))
(setq calc-last-edited-variable var)
- (calc-edit-mode (list 'calc-finish-stack-edit (list 'quote var))
- t
- (format-message
- "Editing variable `%s'" (calc-var-name var)))
+ (calc--edit-mode (lambda () (calc-finish-stack-edit var))
+ t
+ (format-message
+ "Editing variable `%s'" (calc-var-name var)))
(and value
(insert (math-format-nice-expr value (frame-width)) "\n")))))
(calc-show-edit-buffer))
@@ -504,7 +502,7 @@
(calc-wrapper
(or var (setq var (calc-read-var-name "Declare: " 0)))
(or var (setq var 'var-All))
- (let* (dp decl def row rp)
+ (let* (dp decl row rp) ;; def
(or (and (calc-var-value 'var-Decls)
(eq (car-safe var-Decls) 'vec))
(setq var-Decls (list 'vec)))
@@ -596,13 +594,12 @@
calc-settings-file)))
(if var
(calc-insert-permanent-variable var)
- (mapatoms (function
- (lambda (x)
- (and (string-match "\\`var-" (symbol-name x))
- (not (memq x calc-dont-insert-variables))
- (calc-var-value x)
- (not (eq (car-safe (symbol-value x)) 'special-const))
- (calc-insert-permanent-variable x))))))
+ (mapatoms (lambda (x)
+ (and (string-match "\\`var-" (symbol-name x))
+ (not (memq x calc-dont-insert-variables))
+ (calc-var-value x)
+ (not (eq (car-safe (symbol-value x)) 'special-const))
+ (calc-insert-permanent-variable x)))))
(save-buffer))))
@@ -637,27 +634,26 @@
(defun calc-insert-variables (buf)
(interactive "bBuffer in which to save variable values: ")
(with-current-buffer buf
- (mapatoms (function
- (lambda (x)
- (and (string-match "\\`var-" (symbol-name x))
- (not (memq x calc-dont-insert-variables))
- (calc-var-value x)
- (not (eq (car-safe (symbol-value x)) 'special-const))
- (or (not (eq x 'var-Decls))
- (not (equal var-Decls '(vec))))
- (or (not (eq x 'var-Holidays))
- (not (equal var-Holidays '(vec (var sat var-sat)
- (var sun var-sun)))))
- (insert "(setq "
- (symbol-name x)
- " "
- (prin1-to-string
- (let ((calc-language
- (if (memq calc-language '(nil big))
- 'flat
- calc-language)))
- (math-format-value (symbol-value x) 100000)))
- ")\n")))))))
+ (mapatoms (lambda (x)
+ (and (string-match "\\`var-" (symbol-name x))
+ (not (memq x calc-dont-insert-variables))
+ (calc-var-value x)
+ (not (eq (car-safe (symbol-value x)) 'special-const))
+ (or (not (eq x 'var-Decls))
+ (not (equal var-Decls '(vec))))
+ (or (not (eq x 'var-Holidays))
+ (not (equal var-Holidays '(vec (var sat var-sat)
+ (var sun var-sun)))))
+ (insert "(setq "
+ (symbol-name x)
+ " "
+ (prin1-to-string
+ (let ((calc-language
+ (if (memq calc-language '(nil big))
+ 'flat
+ calc-language)))
+ (math-format-value (symbol-value x) 100000)))
+ ")\n"))))))
(defun calc-assign (arg)
(interactive "P")
diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el
index b233ec75249..9281666c3b6 100644
--- a/lisp/calc/calc-stuff.el
+++ b/lisp/calc/calc-stuff.el
@@ -1,4 +1,4 @@
-;;; calc-stuff.el --- miscellaneous functions for Calc
+;;; calc-stuff.el --- miscellaneous functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -182,7 +182,7 @@ With a prefix, push that prefix as a number onto the stack."
math-eval-rules-cache-tag t
math-format-date-cache nil
math-holidays-cache-tag t)
- (mapc (function (lambda (x) (set x -100))) math-cache-list)
+ (mapc (lambda (x) (set x -100)) math-cache-list)
(unless inhibit-msg
(message "All internal calculator caches have been reset"))))
@@ -258,14 +258,14 @@ With a prefix, push that prefix as a number onto the stack."
(t (list 'calcFunc-clean a)))))
(defun calcFunc-pclean (a &optional prec)
- (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
+ (math-map-over-constants (lambda (x) (calcFunc-clean x prec))
a))
(defun calcFunc-pfloat (a)
(math-map-over-constants 'math-float a))
(defun calcFunc-pfrac (a &optional tol)
- (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
+ (math-map-over-constants (lambda (x) (calcFunc-frac x tol))
a))
;; The variable math-moc-func is local to math-map-over-constants,
@@ -273,8 +273,9 @@ With a prefix, push that prefix as a number onto the stack."
;; math-map-over-constants.
(defvar math-moc-func)
-(defun math-map-over-constants (math-moc-func expr)
- (math-map-over-constants-rec expr))
+(defun math-map-over-constants (moc-func expr)
+ (let ((math-moc-func moc-func))
+ (math-map-over-constants-rec expr)))
(defun math-map-over-constants-rec (expr)
(cond ((or (Math-primp expr)
diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el
index 65db5ffae08..2cf5160d5d3 100644
--- a/lisp/calc/calc-trail.el
+++ b/lisp/calc/calc-trail.el
@@ -1,4 +1,4 @@
-;;; calc-trail.el --- functions for manipulating the Calc "trail"
+;;; calc-trail.el --- functions for manipulating the Calc "trail" -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el
index 60ed4310100..4add99a250f 100644
--- a/lisp/calc/calc-undo.el
+++ b/lisp/calc/calc-undo.el
@@ -1,4 +1,4 @@
-;;; calc-undo.el --- undo functions for Calc
+;;; calc-undo.el --- undo functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index 505bff1d241..c3adc3db02a 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -37,14 +37,14 @@
;;; 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)
+;;; CODATA (https://physics.nist.gov/cuu/Constants/index.html)
+;;; NIST (https://physics.nist.gov/Pubs/SP811/appenB9.html)
;;; ESUWM (Encyclopaedia of Scientific Units, Weights and
;;; Measures, by François Cardarelli)
;;; All conversions are exact unless otherwise noted.
;; CODATA values updated February 2016, using 2014 adjustment
-;; http://arxiv.org/pdf/1507.07956.pdf
+;; https://arxiv.org/pdf/1507.07956.pdf
;; Updated November 2018 for the redefinition of the SI
;; https://www.bipm.org/utils/en/pdf/CGPM/Draft-Resolution-A-EN.pdf
@@ -59,7 +59,7 @@
( mi "5280 ft" "Mile" )
( au "149597870691. m" "Astronomical Unit" nil
"149597870691 m (*)")
- ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html)
+ ;; (approx) NASA JPL (https://neo.jpl.nasa.gov/glossary/au.html)
( lyr "c yr" "Light Year" )
( pc "3.0856775854*10^16 m" "Parsec (**)" nil
"3.0856775854 10^16 m (*)") ;; (approx) ESUWM
@@ -860,23 +860,22 @@ If COMP or STD is non-nil, put that in the units table instead."
tab)
(message "Building units table...")
(setq math-units-table-buffer-valid nil)
- (setq tab (mapcar (function
- (lambda (x)
- (list (car x)
- (and (nth 1 x)
- (if (stringp (nth 1 x))
- (let ((exp (math-read-plain-expr
- (nth 1 x))))
- (if (eq (car-safe exp) 'error)
- (error "Format error in definition of %s in units table: %s"
- (car x) (nth 2 exp))
- exp))
- (nth 1 x)))
- (nth 2 x)
- (nth 3 x)
- (and (not (nth 1 x))
- (list (cons (car x) 1)))
- (nth 4 x))))
+ (setq tab (mapcar (lambda (x)
+ (list (car x)
+ (and (nth 1 x)
+ (if (stringp (nth 1 x))
+ (let ((exp (math-read-plain-expr
+ (nth 1 x))))
+ (if (eq (car-safe exp) 'error)
+ (error "Format error in definition of %s in units table: %s"
+ (car x) (nth 2 exp))
+ exp))
+ (nth 1 x)))
+ (nth 2 x)
+ (nth 3 x)
+ (and (not (nth 1 x))
+ (list (cons (car x) 1)))
+ (nth 4 x)))
combined-units))
(let ((math-units-table tab))
(mapc #'math-find-base-units tab))
@@ -1100,10 +1099,9 @@ If COMP or STD is non-nil, put that in the units table instead."
(setq math-decompose-units-cache
(cons entry
(sort ulist
- (function
- (lambda (x y)
- (not (Math-lessp (nth 1 x)
- (nth 1 y))))))))))
+ (lambda (x y)
+ (not (Math-lessp (nth 1 x)
+ (nth 1 y)))))))))
(cdr math-decompose-units-cache))))
(defun math-decompose-unit-part (unit)
@@ -2159,7 +2157,7 @@ If non-nil, return a list consisting of the note and the cents coefficient."
(calc-unary-op "midi" 'calcFunc-midi arg)))
(defun calc-spn (arg)
- "Return the scientific pitch notation corresponding to the expression on the stack."
+ "Return scientific pitch notation corresponding to the expression on the stack."
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "spn" 'calcFunc-spn arg)))
diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el
index 90431c7bd48..73783dd2c2c 100644
--- a/lisp/calc/calc-vec.el
+++ b/lisp/calc/calc-vec.el
@@ -1,4 +1,4 @@
-;;; calc-vec.el --- vector functions for Calc
+;;; calc-vec.el --- vector functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -744,7 +744,7 @@
;;; Get the Nth row of a matrix.
(defun calcFunc-mrow (mat n) ; [Public]
(if (Math-vectorp n)
- (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n)
+ (math-map-vec (lambda (x) (calcFunc-mrow mat x)) n)
(if (and (eq (car-safe n) 'intv) (math-constp n))
(calcFunc-subvec mat
(math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1))
@@ -768,15 +768,15 @@
;;; Get the Nth column of a matrix.
(defun math-mat-col (mat n)
- (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat))))
+ (cons 'vec (mapcar (lambda (x) (elt x n)) (cdr mat))))
(defun calcFunc-mcol (mat n) ; [Public]
(if (Math-vectorp n)
(calcFunc-trn
- (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n))
+ (math-map-vec (lambda (x) (calcFunc-mcol mat x)) n))
(if (and (eq (car-safe n) 'intv) (math-constp n))
(if (math-matrixp mat)
- (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat)
+ (math-map-vec (lambda (x) (calcFunc-mrow x n)) mat)
(calcFunc-mrow mat n))
(or (and (integerp (setq n (math-check-integer n)))
(> n 0))
@@ -804,7 +804,7 @@
;;; Remove the Nth column from a matrix.
(defun math-mat-less-col (mat n)
- (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
+ (cons 'vec (mapcar (lambda (x) (math-mat-less-row x n))
(cdr mat))))
(defun calcFunc-mrcol (mat n) ; [Public]
@@ -939,10 +939,10 @@
(calcFunc-idn a (1- (length m)))
(if (math-vectorp m)
(if (math-zerop a)
- (cons 'vec (mapcar (function (lambda (x)
- (if (math-vectorp x)
- (math-mimic-ident a x)
- a)))
+ (cons 'vec (mapcar (lambda (x)
+ (if (math-vectorp x)
+ (math-mimic-ident a x)
+ a))
(cdr m)))
(math-dimension-error))
(calcFunc-idn a))))
@@ -1111,18 +1111,20 @@
;; by calcFunc-grade and calcFunc-rgrade.
(defvar math-grade-vec)
-(defun calcFunc-grade (math-grade-vec)
- (if (math-vectorp math-grade-vec)
- (let* ((len (1- (length math-grade-vec))))
- (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep)))
- (math-reject-arg math-grade-vec 'vectorp)))
-
-(defun calcFunc-rgrade (math-grade-vec)
- (if (math-vectorp math-grade-vec)
- (let* ((len (1- (length math-grade-vec))))
+(defun calcFunc-grade (grade-vec)
+ (if (math-vectorp grade-vec)
+ (let* ((math-grade-vec grade-vec)
+ (len (1- (length grade-vec))))
+ (cons 'vec (sort (cdr (calcFunc-index len)) #'math-grade-beforep)))
+ (math-reject-arg grade-vec #'vectorp)))
+
+(defun calcFunc-rgrade (grade-vec)
+ (if (math-vectorp grade-vec)
+ (let* ((math-grade-vec grade-vec)
+ (len (1- (length grade-vec))))
(cons 'vec (nreverse (sort (cdr (calcFunc-index len))
- 'math-grade-beforep))))
- (math-reject-arg math-grade-vec 'vectorp)))
+ #'math-grade-beforep))))
+ (math-reject-arg grade-vec #'vectorp)))
(defun math-grade-beforep (i j)
(math-beforep (nth i math-grade-vec) (nth j math-grade-vec)))
@@ -1556,7 +1558,8 @@ of two matrices is a matrix."
(defvar math-exp-keep-spaces)
(defvar math-expr-data)
-(defun math-read-brackets (space-sep math-rb-close)
+(defun math-read-brackets (space-sep rb-close)
+ (let ((math-rb-close rb-close))
(and space-sep (setq space-sep (not (math-check-for-commas))))
(math-read-token)
(while (eq math-exp-token 'space)
@@ -1624,7 +1627,7 @@ of two matrices is a matrix."
(throw 'syntax "Expected `]'")))
(or (eq math-exp-token 'end)
(math-read-token))
- vals)))
+ vals))))
(defun math-check-for-commas (&optional balancing)
(let ((count 0)
diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el
index 99cfd0483b0..762adbd407e 100644
--- a/lisp/calc/calc-yank.el
+++ b/lisp/calc/calc-yank.el
@@ -1,4 +1,4 @@
-;;; calc-yank.el --- kill-ring functionality for Calc
+;;; calc-yank.el --- kill-ring functionality for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -150,34 +150,16 @@
;; otherwise it just parses the yanked string.
;; Modified to use Emacs 19 extended concept of kill-ring. -- daveg 12/15/96
;;;###autoload
-(defun calc-yank (radix)
- "Yank a value into the Calculator buffer.
-
-Valid numeric prefixes for RADIX: 0, 2, 6, 8
-No radix notation is prepended for any other numeric prefix.
-
-If RADIX is 2, prepend \"2#\" - Binary.
-If RADIX is 8, prepend \"8#\" - Octal.
-If RADIX is 0, prepend \"10#\" - Decimal.
-If RADIX is 6, prepend \"16#\" - Hexadecimal.
-
-If RADIX is a non-nil list (created using \\[universal-argument]), the user
-will be prompted to enter the radix in the minibuffer.
+(defun calc-yank-internal (radix thing-raw)
+ "Internal common implementation for yank functions.
-If RADIX is nil or if the yanked string already has a calc radix prefix, the
-yanked string will be passed on directly to the Calculator buffer without any
-alteration."
- (interactive "P")
+This function is used by both `calc-yank' and `calc-yank-mouse-primary'."
(calc-wrapper
(calc-pop-push-record-list
0 "yank"
(let* (radix-num
radix-notation
valid-num-regexp
- (thing-raw
- (if (fboundp 'current-kill)
- (current-kill 0 t)
- (car kill-ring-yank-pointer)))
(thing
(if (or (null radix)
;; Match examples: -2#10, 10\n(10#10,01)
@@ -232,6 +214,38 @@ alteration."
val))
val))))))))
+;;;###autoload
+(defun calc-yank-mouse-primary (radix)
+ "Yank the current primary selection into the Calculator buffer.
+See `calc-yank' for details about RADIX."
+ (interactive "P")
+ (if (or select-enable-primary
+ select-enable-clipboard)
+ (calc-yank-internal radix (gui-get-primary-selection))
+ ;; Yank from the kill ring.
+ (calc-yank radix)))
+
+;;;###autoload
+(defun calc-yank (radix)
+ "Yank a value into the Calculator buffer.
+
+Valid numeric prefixes for RADIX: 0, 2, 6, 8
+No radix notation is prepended for any other numeric prefix.
+
+If RADIX is 2, prepend \"2#\" - Binary.
+If RADIX is 8, prepend \"8#\" - Octal.
+If RADIX is 0, prepend \"10#\" - Decimal.
+If RADIX is 6, prepend \"16#\" - Hexadecimal.
+
+If RADIX is a non-nil list (created using \\[universal-argument]), the user
+will be prompted to enter the radix in the minibuffer.
+
+If RADIX is nil or if the yanked string already has a calc radix prefix, the
+yanked string will be passed on directly to the Calculator buffer without any
+alteration."
+ (interactive "P")
+ (calc-yank-internal radix (current-kill 0 t)))
+
;;; The Calc set- and get-register commands are modified versions of functions
;;; in register.el
@@ -387,7 +401,7 @@ Interactively, reads the register using `register-read-with-preview'."
(let* ((from-buffer (current-buffer))
(calc-was-started (get-buffer-window "*Calculator*"))
(single nil)
- data vals pos)
+ data vals) ;; pos
(if arg
(if (consp arg)
(setq single t)
@@ -625,27 +639,27 @@ Interactively, reads the register using `register-read-with-preview'."
(calc-slow-wrapper
(when (eq n 0)
(setq n (calc-stack-size)))
- (let* ((flag nil)
+ (let* (;; (flag nil)
(allow-ret (> n 1))
(list (math-showing-full-precision
(mapcar (if (> n 1)
- (function (lambda (x)
- (math-format-flat-expr x 0)))
- (function
- (lambda (x)
- (if (math-vectorp x) (setq allow-ret t))
- (math-format-nice-expr x (frame-width)))))
+ (lambda (x)
+ (math-format-flat-expr x 0))
+ (lambda (x)
+ (if (math-vectorp x) (setq allow-ret t))
+ (math-format-nice-expr x (frame-width))))
(if (> n 0)
(calc-top-list n)
(calc-top-list 1 (- n)))))))
- (calc-edit-mode (list 'calc-finish-stack-edit (or flag n)) allow-ret)
+ (calc--edit-mode (lambda () (calc-finish-stack-edit n)) ;; (or flag n)
+ allow-ret)
(while list
(insert (car list) "\n")
(setq list (cdr list)))))
(calc-show-edit-buffer))
(defun calc-alg-edit (str)
- (calc-edit-mode '(calc-finish-stack-edit 0))
+ (calc--edit-mode (lambda () (calc-finish-stack-edit 0)))
(calc-show-edit-buffer)
(insert str "\n")
(backward-char 1)
@@ -653,54 +667,47 @@ Interactively, reads the register using `register-read-with-preview'."
(defvar calc-edit-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\n" 'calc-edit-finish)
- (define-key map "\r" 'calc-edit-return)
- (define-key map "\C-c\C-c" 'calc-edit-finish)
+ (define-key map "\n" #'calc-edit-finish)
+ (define-key map "\r" #'calc-edit-return)
+ (define-key map "\C-c\C-c" #'calc-edit-finish)
map)
- "Keymap for use by the calc-edit command.")
+ "Keymap for use by the `calc-edit' command.")
-(defvar calc-original-buffer)
-(defvar calc-return-buffer)
-(defvar calc-one-window)
-(defvar calc-edit-handler)
-(defvar calc-restore-trail)
-(defvar calc-allow-ret)
-(defvar calc-edit-top)
+(defvar calc-original-buffer nil)
+(defvar calc-return-buffer nil)
+(defvar calc-one-window nil)
+(defvar calc-edit-handler nil)
+(defvar calc-restore-trail nil)
+(defvar calc-allow-ret nil)
+(defvar calc-edit-top nil)
-(defun calc-edit-mode (&optional handler allow-ret title)
+(put 'calc-edit-mode 'mode-class 'special)
+(define-derived-mode calc-edit-mode nil "Calc Edit"
"Calculator editing mode. Press RET, LFD, or C-c C-c to finish.
To cancel the edit, simply kill the *Calc Edit* buffer."
- (interactive)
+ (setq-local buffer-read-only nil)
+ (setq-local truncate-lines nil))
+
+(defun calc--edit-mode (handler &optional allow-ret title)
(unless handler
(error "This command can be used only indirectly through calc-edit"))
(let ((oldbuf (current-buffer))
(buf (get-buffer-create "*Calc Edit*")))
(set-buffer buf)
- (kill-all-local-variables)
- (use-local-map calc-edit-mode-map)
- (setq buffer-read-only nil)
- (setq truncate-lines nil)
- (setq major-mode 'calc-edit-mode)
- (setq mode-name "Calc Edit")
- (run-mode-hooks 'calc-edit-mode-hook)
- (make-local-variable 'calc-original-buffer)
- (setq calc-original-buffer oldbuf)
- (make-local-variable 'calc-return-buffer)
- (setq calc-return-buffer oldbuf)
- (make-local-variable 'calc-one-window)
- (setq calc-one-window (and (one-window-p t) pop-up-windows))
- (make-local-variable 'calc-edit-handler)
- (setq calc-edit-handler handler)
- (make-local-variable 'calc-restore-trail)
- (setq calc-restore-trail (get-buffer-window (calc-trail-buffer)))
- (make-local-variable 'calc-allow-ret)
- (setq calc-allow-ret allow-ret)
+ (calc-edit-mode)
+ (setq-local calc-original-buffer oldbuf)
+ (setq-local calc-return-buffer oldbuf)
+ (setq-local calc-one-window (and (one-window-p t) pop-up-windows))
+ (setq-local calc-edit-handler handler)
+ (setq-local calc-restore-trail (get-buffer-window (calc-trail-buffer)))
+ (setq-local calc-allow-ret allow-ret)
(let ((inhibit-read-only t))
(erase-buffer))
(add-hook 'kill-buffer-hook (lambda ()
(let ((calc-edit-handler nil))
(calc-edit-finish t))
- (message "(Canceled)")) t t)
+ (message "(Canceled)"))
+ t t)
(insert (propertize
(concat
(or title title "Calc Edit Mode. ")
@@ -708,9 +715,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(if allow-ret "" " or RET")
(format-message " to finish, `C-x k RET' to cancel.\n\n"))
'font-lock-face 'italic 'read-only t 'rear-nonsticky t 'front-sticky t))
- (make-local-variable 'calc-edit-top)
- (setq calc-edit-top (point))))
-(put 'calc-edit-mode 'mode-class 'special)
+ (setq-local calc-edit-top (point))))
(defun calc-show-edit-buffer ()
(let ((buf (current-buffer)))
@@ -730,24 +735,19 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(defun calc-edit-return ()
(interactive)
- (if (and (boundp 'calc-allow-ret) calc-allow-ret)
+ (if calc-allow-ret
(newline)
(calc-edit-finish)))
-;; The variable calc-edit-disp-trail is local to calc-edit finish, but
-;; is used by calc-finish-selection-edit and calc-finish-stack-edit.
+;; The variable `calc-edit-disp-trail' is local to `calc-edit-finish', but
+;; is used by `calc-finish-selection-edit' and `calc-finish-stack-edit'.
(defvar calc-edit-disp-trail)
(defun calc-edit-finish (&optional keep)
- "Finish calc-edit mode. Parse buffer contents and push them on the stack."
+ "Finish `calc-edit' mode. Parse buffer contents and push them on the stack."
(interactive "P")
(message "Working...")
- (or (and (boundp 'calc-original-buffer)
- (boundp 'calc-return-buffer)
- (boundp 'calc-one-window)
- (boundp 'calc-edit-handler)
- (boundp 'calc-restore-trail)
- (eq major-mode 'calc-edit-mode))
+ (or (derived-mode-p 'calc-edit-mode)
(error "This command is valid only in buffers created by calc-edit"))
(let ((buf (current-buffer))
(original calc-original-buffer)
@@ -762,7 +762,11 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(error "Original calculator buffer has been corrupted")))
(goto-char calc-edit-top)
(if (buffer-modified-p)
- (eval calc-edit-handler))
+ (if (functionp calc-edit-handler)
+ (funcall calc-edit-handler)
+ (message "Deprecated handler expression in calc-edit-handler: %S"
+ calc-edit-handler)
+ (eval calc-edit-handler t)))
(if (and one-window (not (one-window-p t)))
(delete-window))
(if (get-buffer-window return)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 1ddd62429f6..1e7d5e7766c 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -266,18 +266,18 @@
(sgml-mode . "<!-- Embed -->\n\\(<!-- .* -->\n\\)*")
(xml-mode . "<!-- Embed -->\n\\(<!-- .* -->\n\\)*")
(texinfo-mode . "@c Embed\n\\(@c .*\n\\)*"))
- "Alist of major modes with appropriate values for `calc-embedded-announce-formula'."
+ "Alist of major modes for `calc-embedded-announce-formula'."
:type '(alist :key-type (symbol :tag "Major mode")
:value-type (regexp :tag "Regexp to announce formula")))
(defcustom calc-embedded-open-formula
"\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin[^{].*\n\\|^\\\\begin{.*[^x]}.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n"
- "A regular expression for the opening delimiter of a formula used by calc-embedded."
+ "Regexp for the opening delimiter of a formula used by `calc-embedded'."
:type '(regexp))
(defcustom calc-embedded-close-formula
"\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end[^{].*\n\\|^\\\\end{.*[^x]}.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n"
- "A regular expression for the closing delimiter of a formula used by calc-embedded."
+ "Regexp for the closing delimiter of a formula used by calc-embedded."
:type '(regexp))
(defcustom calc-embedded-open-close-formula-alist
@@ -483,6 +483,11 @@ current precision are displayed in scientific notation in calc-mode.")
"Floating-point numbers with this negative exponent or lower are displayed
scientific notation in calc-mode.")
+(defvar calc-digit-after-point nil
+ "If t, display at least one digit after the decimal point, as in `12.0'.
+If nil, the decimal point may come last in a number, as in `12.'.
+This setting only applies to floats in normal display mode.")
+
(defvar calc-other-modes nil
"List of used-defined strings to append to Calculator mode line.")
@@ -506,7 +511,7 @@ The variable VAR will be added to `calc-mode-var-list'."
(defun calc-mode-var-list-restore-default-values ()
"Restore the default values of the variables in `calc-mode-var-list'."
- (mapcar (function (lambda (v) (set (car v) (nth 1 v))))
+ (mapcar (lambda (v) (set (car v) (nth 1 v)))
calc-mode-var-list))
(defun calc-mode-var-list-restore-saved-values ()
@@ -535,7 +540,7 @@ The variable VAR will be added to `calc-mode-var-list'."
newvarlist)))
(setq varlist (cdr varlist)))))))
(if newvarlist
- (mapcar (function (lambda (v) (set (car v) (nth 1 v))))
+ (mapcar (lambda (v) (set (car v) (nth 1 v)))
newvarlist)
(calc-mode-var-list-restore-default-values))))
@@ -721,7 +726,8 @@ If nil, computations on numbers always yield numbers where possible.")
(defcalcmodevar calc-matrix-mode nil
"If `matrix', variables are assumed to be matrix-valued.
If a number, variables are assumed to be NxN matrices.
-If `sqmatrix', variables are assumed to be square matrices of an unspecified size.
+If `sqmatrix', variables are assumed to be square matrices of an
+ unspecified size.
If `scalar', variables are assumed to be scalar-valued.
If nil, symbolic math routines make no assumptions about variables.")
@@ -884,6 +890,8 @@ Used by `calc-user-invocation'.")
(defvar calc-load-hook nil
"Hook run when calc.el is loaded.")
+(make-obsolete-variable 'calc-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defvar calc-window-hook nil
"Hook called to create the Calc window.")
@@ -1085,8 +1093,18 @@ Used by `calc-user-invocation'.")
(append (where-is-internal 'delete-backward-char global-map)
(where-is-internal 'backward-delete-char global-map)
(where-is-internal 'backward-delete-char-untabify global-map)
- '("\C-d"))
- '("\177" "\C-d")))
+ '("\177"))
+ '("\177")))
+
+(mapc (lambda (x)
+ (ignore-errors
+ (define-key calc-digit-map x 'calcDigit-delchar)
+ (define-key calc-mode-map x 'calc-pop)
+ (define-key calc-mode-map (vconcat "\e" x) 'calc-pop-above)))
+ (if calc-scan-for-dels
+ (append (where-is-internal 'delete-forward-char global-map)
+ '("\C-d"))
+ '("\C-d")))
(defvar calc-dispatch-map
(let ((map (make-keymap)))
@@ -1295,8 +1313,9 @@ Notations: 3.14e6 3.14 * 10^6
\\{calc-mode-map}
"
(interactive)
- (mapc (function ;FIXME: Why (set-default v (symbol-value v)) ?!?!?
- (lambda (v) (set-default v (symbol-value v))))
+ (mapc (lambda (v)
+ ;; FIXME: Why (set-default v (symbol-value v)) ?!?!?
+ (set-default v (symbol-value v)))
calc-local-var-list)
(kill-all-local-variables)
(use-local-map (if (eq calc-algebraic-mode 'total)
@@ -1362,6 +1381,29 @@ Notations: 3.14e6 3.14 * 10^6
(set-keymap-parent map calc-mode-map)
map))
+(defun calc--header-line (long short width &optional fudge)
+ "Return a Calc header line appropriate for the buffer width.
+
+LONG is a desired text for a wide window, SHORT is a desired
+abbreviated text, and width is the buffer width, which will be
+some fraction of the 'parent' window width (At the time of
+writing, 2/3 for calc, 1/3 for trail). The optional FUDGE is a
+trial-and-error adjustment number for the edge-cases at the
+border of the two cases."
+ ;; TODO: This could be called as part of a 'window-resize' hook.
+ (setq header-line-format
+ (let* ((len-long (length long))
+ (len-short (length short))
+ (fudge (or fudge 0))
+ ;; fudge for trail is: -3 (added to len-long)
+ ;; (width ) for trail
+ (factor (if (> width (+ len-long fudge)) len-long len-short))
+ (size (max (/ (- width factor) 2) 0))
+ (fill (make-string size ?-))
+ (pre (replace-regexp-in-string ".$" " " fill))
+ (post (replace-regexp-in-string "^." " " fill)))
+ (concat pre (if (= factor len-long) long short) post))))
+
(define-derived-mode calc-trail-mode fundamental-mode "Calc Trail"
"Calc Trail mode.
This mode is used by the *Calc Trail* buffer, which records all results
@@ -1376,9 +1418,9 @@ commands given here will actually operate on the *Calculator* stack."
(setq buffer-read-only t)
(make-local-variable 'overlay-arrow-position)
(make-local-variable 'overlay-arrow-string)
- (when (= (buffer-size) 0)
- (let ((inhibit-read-only t))
- (insert (propertize "Emacs Calculator Trail\n" 'face 'italic)))))
+ (when calc-show-banner
+ (calc--header-line "Emacs Calculator Trail" "Calc Trail"
+ (/ (window-width) 3) -3)))
(defun calc-create-buffer ()
"Create and initialize a buffer for the Calculator."
@@ -1392,6 +1434,12 @@ commands given here will actually operate on the *Calculator* stack."
(require 'calc-ext)
(calc-set-language calc-language calc-language-option t)))
+(defcustom calc-make-windows-dedicated t
+ "If non-nil, windows displaying Calc buffers will be marked dedicated.
+See `window-dedicated-p' for what that means."
+ :version "28.1"
+ :type 'boolean)
+
;;;###autoload
(defun calc (&optional arg full-display interactive)
"The Emacs Calculator. Full documentation is listed under `calc-mode'."
@@ -1431,13 +1479,14 @@ commands given here will actually operate on the *Calculator* stack."
(pop-to-buffer (current-buffer)))))))
(with-current-buffer (calc-trail-buffer)
(and calc-display-trail
- (= (window-width) (frame-width))
(calc-trail-display 1 t)))
(message "Welcome to the GNU Emacs Calculator! Press `?' or `h' for help, `q' to quit")
(run-hooks 'calc-start-hook)
(and (windowp full-display)
(window-point full-display)
(select-window full-display))
+ (and calc-make-windows-dedicated
+ (set-window-dedicated-p nil t))
(calc-check-defines)
(when (and calc-said-hello interactive)
(sit-for 2)
@@ -1487,7 +1536,7 @@ commands given here will actually operate on the *Calculator* stack."
(let ((tail (nthcdr (1- calc-undo-length) calc-undo-list)))
(if tail (setcdr tail nil)))
(setq calc-redo-list nil))))
- (mapc (function (lambda (v) (set-default v (symbol-value v))))
+ (mapc (lambda (v) (set-default v (symbol-value v)))
calc-local-var-list)
(let ((buf (current-buffer))
(win (get-buffer-window (current-buffer)))
@@ -1966,13 +2015,11 @@ See calc-keypad for details."
(calc-any-evaltos nil))
(setq calc-any-selections nil)
(erase-buffer)
- (when calc-show-banner
- (insert (propertize "--- Emacs Calculator Mode ---\n"
- 'face 'italic)))
+ (when calc-show-banner
+ (calc--header-line "Emacs Calculator Mode" "Emacs Calc"
+ (* 2 (/ (window-width) 3)) -3))
(while thing
(goto-char (point-min))
- (when calc-show-banner
- (forward-line 1))
(insert (math-format-stack-value (car thing)) "\n")
(setq thing (cdr thing)))
(calc-renumber-stack)
@@ -2051,12 +2098,11 @@ the United States."
(set-buffer calc-trail-buffer)
(unless (derived-mode-p 'calc-trail-mode)
(calc-trail-mode)
- (set (make-local-variable 'calc-main-buffer) buf)))))
+ (setq-local calc-main-buffer buf)))))
(or (and calc-trail-pointer
(eq (marker-buffer calc-trail-pointer) calc-trail-buffer))
(with-current-buffer calc-trail-buffer
(goto-char (point-min))
- (forward-line 1)
(setq calc-trail-pointer (point-marker))))
calc-trail-buffer)
@@ -2101,7 +2147,9 @@ the United States."
(if calc-trail-window-hook
(run-hooks 'calc-trail-window-hook)
(let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
- (set-window-buffer w calc-trail-buffer)))
+ (set-window-buffer w calc-trail-buffer)
+ (and calc-make-windows-dedicated
+ (set-window-dedicated-p w t))))
(calc-wrapper
(setq overlay-arrow-string calc-trail-overlay
overlay-arrow-position calc-trail-pointer)
@@ -2124,10 +2172,8 @@ the United States."
(if (derived-mode-p 'calc-trail-mode)
(progn
(beginning-of-line)
- (if (bobp)
- (forward-line 1)
- (if (eobp)
- (forward-line -1)))
+ (if (eobp)
+ (forward-line -1))
(if (or (bobp) (eobp))
(setq overlay-arrow-position nil) ; trail is empty
(set-marker calc-trail-pointer (point) (current-buffer))
@@ -2141,7 +2187,7 @@ the United States."
(if win
(save-excursion
(forward-line (/ (window-height win) 2))
- (forward-line (- 1 (window-height win)))
+ (forward-line (- 2 (window-height win)))
(set-window-start win (point))
(set-window-point win (+ calc-trail-pointer 4))
(set-buffer calc-main-buffer)
@@ -2276,7 +2322,7 @@ the United States."
((eq last-command-event ?@) "0@ ")
(t (char-to-string last-command-event))))
-(defvar calc-buffer)
+(defvar calc-buffer nil)
(defvar calc-prev-char)
(defvar calc-prev-prev-char)
(defvar calc-digit-value)
@@ -2316,7 +2362,7 @@ the United States."
(defun calcDigit-nondigit ()
(interactive)
;; Exercise for the reader: Figure out why this is a good precaution!
- (or (boundp 'calc-buffer)
+ (or calc-buffer
(use-local-map minibuffer-local-map))
(let ((str (minibuffer-contents)))
(setq calc-digit-value (with-current-buffer calc-buffer
@@ -2341,7 +2387,6 @@ the United States."
(defun calcDigit-key ()
(interactive)
- (goto-char (point-max))
(if (or (and (memq last-command-event '(?+ ?-))
(> (buffer-size) 0)
(/= (preceding-char) ?e))
@@ -2384,8 +2429,7 @@ the United States."
(delete-char 1))
(if (looking-at "-")
(delete-char 1)
- (insert "-")))
- (goto-char (point-max)))
+ (insert "-"))))
((eq last-command-event ?p)
(if (or (calc-minibuffer-contains ".*\\+/-.*")
(calc-minibuffer-contains ".*mod.*")
@@ -2427,7 +2471,7 @@ the United States."
(if (and (memq last-command-event '(?@ ?o ?h ?\' ?m))
(string-match " " calc-hms-format))
(insert " "))
- (if (and (eq this-command last-command)
+ (if (and (memq last-command '(calcDigit-start calcDigit-key))
(eq last-command-event ?.))
(progn
(require 'calc-ext)
@@ -2438,17 +2482,9 @@ the United States."
(setq calc-prev-prev-char calc-prev-char
calc-prev-char last-command-event))
-
(defun calcDigit-backspace ()
(interactive)
- (goto-char (point-max))
- (cond ((calc-minibuffer-contains ".* \\+/- \\'")
- (backward-delete-char 5))
- ((calc-minibuffer-contains ".* mod \\'")
- (backward-delete-char 5))
- ((calc-minibuffer-contains ".* \\'")
- (backward-delete-char 2))
- ((eq last-command 'calcDigit-start)
+ (cond ((eq last-command 'calcDigit-start)
(erase-buffer))
(t (backward-delete-char 1)))
(if (= (calc-minibuffer-size) 0)
@@ -2923,6 +2959,20 @@ the United States."
(- (- (nth 2 a) (nth 2 b)) ldiff))))
+(defun calcDigit-delchar ()
+ (interactive)
+ (cond ((looking-at-p " \\+/- \\'")
+ (delete-char 5))
+ ((looking-at-p " mod \\'")
+ (delete-char 5))
+ ((looking-at-p " \\'")
+ (delete-char 2))
+ ((eq last-command 'calcDigit-start)
+ (erase-buffer))
+ (t (unless (eobp) (delete-char 1))))
+ (when (= (calc-minibuffer-size) 0)
+ (setq last-command-event 13)
+ (calcDigit-nondigit)))
(defvar math-comp-selected)
@@ -3139,7 +3189,8 @@ the United States."
exp (- exp adj)))))
(setq str (int-to-string mant))
(let* ((len (length str))
- (dpos (+ exp len)))
+ (dpos (+ exp len))
+ (trailing-0 (and calc-digit-after-point "0")))
(if (and (eq fmt 'float)
(<= dpos (+ calc-internal-prec calc-display-sci-high))
(>= dpos (+ calc-display-sci-low 2)))
@@ -3149,9 +3200,11 @@ the United States."
(setq str (concat "0" point str)))
((and (<= exp 0) (> dpos 0))
(setq str (concat (substring str 0 dpos) point
- (substring str dpos))))
+ (substring str dpos)
+ (and (>= dpos len) trailing-0))))
((> exp 0)
- (setq str (concat str (make-string exp ?0) point)))
+ (setq str (concat str (make-string exp ?0)
+ point trailing-0)))
(t ; (< dpos 0)
(setq str (concat "0" point
(make-string (- dpos) ?0) str))))
@@ -3411,12 +3464,10 @@ See Info node `(calc)Defining Functions'."
(defun calc-clear-unread-commands ()
(setq unread-command-events nil))
-(defcalcmodevar math-2-word-size
- (math-read-number-simple "4294967296")
+(defcalcmodevar math-2-word-size 4294967296
"Two to the power of `calc-word-size'.")
-(defcalcmodevar math-half-2-word-size
- (math-read-number-simple "2147483648")
+(defcalcmodevar math-half-2-word-size 2147483648
"One-half of two to the power of `calc-word-size'.")
(when calc-always-load-extensions
diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el
index 3ede525cd67..94b99aa29d8 100644
--- a/lisp/calc/calcalg2.el
+++ b/lisp/calc/calcalg2.el
@@ -1,4 +1,4 @@
-;;; calcalg2.el --- more algebraic functions for Calc
+;;; calcalg2.el --- more algebraic functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -333,8 +333,10 @@
(setq n (1+ n)))
accum))))))
-(defun calcFunc-deriv (expr math-deriv-var &optional deriv-value math-deriv-symb)
- (let* ((math-deriv-total nil)
+(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
+ (let* ((math-deriv-var deriv-var)
+ (math-deriv-symb deriv-symb)
+ (math-deriv-total nil)
(res (catch 'math-deriv (math-derivative expr))))
(or (eq (car-safe res) 'calcFunc-deriv)
(null res)
@@ -344,9 +346,11 @@
(math-expr-subst res math-deriv-var deriv-value)
res))))
-(defun calcFunc-tderiv (expr math-deriv-var &optional deriv-value math-deriv-symb)
+(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb)
(math-setup-declarations)
- (let* ((math-deriv-total t)
+ (let* ((math-deriv-var deriv-var)
+ (math-deriv-symb deriv-symb)
+ (math-deriv-total t)
(res (catch 'math-deriv (math-derivative expr))))
(or (eq (car-safe res) 'calcFunc-tderiv)
(null res)
@@ -357,175 +361,175 @@
res))))
(put 'calcFunc-inv\' 'math-derivative-1
- (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
+ (lambda (u) (math-neg (math-div 1 (math-sqr u)))))
(put 'calcFunc-sqrt\' 'math-derivative-1
- (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
+ (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u)))))
(put 'calcFunc-deg\' 'math-derivative-1
- (function (lambda (u) (math-div-float '(float 18 1) (math-pi)))))
+ (lambda (_) (math-div-float '(float 18 1) (math-pi))))
(put 'calcFunc-rad\' 'math-derivative-1
- (function (lambda (u) (math-pi-over-180))))
+ (lambda (_) (math-pi-over-180)))
(put 'calcFunc-ln\' 'math-derivative-1
- (function (lambda (u) (math-div 1 u))))
+ (lambda (u) (math-div 1 u)))
(put 'calcFunc-log10\' 'math-derivative-1
- (function (lambda (u)
- (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
- u))))
+ (lambda (u)
+ (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
+ u)))
(put 'calcFunc-lnp1\' 'math-derivative-1
- (function (lambda (u) (math-div 1 (math-add u 1)))))
+ (lambda (u) (math-div 1 (math-add u 1))))
(put 'calcFunc-log\' 'math-derivative-2
- (function (lambda (x b)
- (and (not (Math-zerop b))
- (let ((lnv (math-normalize
- (list 'calcFunc-ln b))))
- (math-div 1 (math-mul lnv x)))))))
+ (lambda (x b)
+ (and (not (Math-zerop b))
+ (let ((lnv (math-normalize
+ (list 'calcFunc-ln b))))
+ (math-div 1 (math-mul lnv x))))))
(put 'calcFunc-log\'2 'math-derivative-2
- (function (lambda (x b)
- (let ((lnv (list 'calcFunc-ln b)))
- (math-neg (math-div (list 'calcFunc-log x b)
- (math-mul lnv b)))))))
+ (lambda (x b)
+ (let ((lnv (list 'calcFunc-ln b)))
+ (math-neg (math-div (list 'calcFunc-log x b)
+ (math-mul lnv b))))))
(put 'calcFunc-exp\' 'math-derivative-1
- (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
+ (lambda (u) (math-normalize (list 'calcFunc-exp u))))
(put 'calcFunc-expm1\' 'math-derivative-1
- (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
+ (lambda (u) (math-normalize (list 'calcFunc-expm1 u))))
(put 'calcFunc-sin\' 'math-derivative-1
- (function (lambda (u) (math-to-radians-2 (math-normalize
- (list 'calcFunc-cos u)) t))))
+ (lambda (u) (math-to-radians-2 (math-normalize
+ (list 'calcFunc-cos u)) t)))
(put 'calcFunc-cos\' 'math-derivative-1
- (function (lambda (u) (math-neg (math-to-radians-2
- (math-normalize
- (list 'calcFunc-sin u)) t)))))
+ (lambda (u) (math-neg (math-to-radians-2
+ (math-normalize
+ (list 'calcFunc-sin u)) t))))
(put 'calcFunc-tan\' 'math-derivative-1
- (function (lambda (u) (math-to-radians-2
- (math-sqr
- (math-normalize
- (list 'calcFunc-sec u))) t))))
+ (lambda (u) (math-to-radians-2
+ (math-sqr
+ (math-normalize
+ (list 'calcFunc-sec u))) t)))
(put 'calcFunc-sec\' 'math-derivative-1
- (function (lambda (u) (math-to-radians-2
- (math-mul
- (math-normalize
- (list 'calcFunc-sec u))
- (math-normalize
- (list 'calcFunc-tan u))) t))))
+ (lambda (u) (math-to-radians-2
+ (math-mul
+ (math-normalize
+ (list 'calcFunc-sec u))
+ (math-normalize
+ (list 'calcFunc-tan u))) t)))
(put 'calcFunc-csc\' 'math-derivative-1
- (function (lambda (u) (math-neg
- (math-to-radians-2
- (math-mul
- (math-normalize
- (list 'calcFunc-csc u))
- (math-normalize
- (list 'calcFunc-cot u))) t)))))
+ (lambda (u) (math-neg
+ (math-to-radians-2
+ (math-mul
+ (math-normalize
+ (list 'calcFunc-csc u))
+ (math-normalize
+ (list 'calcFunc-cot u))) t))))
(put 'calcFunc-cot\' 'math-derivative-1
- (function (lambda (u) (math-neg
- (math-to-radians-2
- (math-sqr
- (math-normalize
- (list 'calcFunc-csc u))) t)))))
+ (lambda (u) (math-neg
+ (math-to-radians-2
+ (math-sqr
+ (math-normalize
+ (list 'calcFunc-csc u))) t))))
(put 'calcFunc-arcsin\' 'math-derivative-1
- (function (lambda (u)
- (math-from-radians-2
- (math-div 1 (math-normalize
- (list 'calcFunc-sqrt
- (math-sub 1 (math-sqr u))))) t))))
+ (lambda (u)
+ (math-from-radians-2
+ (math-div 1 (math-normalize
+ (list 'calcFunc-sqrt
+ (math-sub 1 (math-sqr u))))) t)))
(put 'calcFunc-arccos\' 'math-derivative-1
- (function (lambda (u)
- (math-from-radians-2
- (math-div -1 (math-normalize
- (list 'calcFunc-sqrt
- (math-sub 1 (math-sqr u))))) t))))
+ (lambda (u)
+ (math-from-radians-2
+ (math-div -1 (math-normalize
+ (list 'calcFunc-sqrt
+ (math-sub 1 (math-sqr u))))) t)))
(put 'calcFunc-arctan\' 'math-derivative-1
- (function (lambda (u) (math-from-radians-2
- (math-div 1 (math-add 1 (math-sqr u))) t))))
+ (lambda (u) (math-from-radians-2
+ (math-div 1 (math-add 1 (math-sqr u))) t)))
(put 'calcFunc-sinh\' 'math-derivative-1
- (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
+ (lambda (u) (math-normalize (list 'calcFunc-cosh u))))
(put 'calcFunc-cosh\' 'math-derivative-1
- (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
+ (lambda (u) (math-normalize (list 'calcFunc-sinh u))))
(put 'calcFunc-tanh\' 'math-derivative-1
- (function (lambda (u) (math-sqr
- (math-normalize
- (list 'calcFunc-sech u))))))
+ (lambda (u) (math-sqr
+ (math-normalize
+ (list 'calcFunc-sech u)))))
(put 'calcFunc-sech\' 'math-derivative-1
- (function (lambda (u) (math-neg
- (math-mul
- (math-normalize (list 'calcFunc-sech u))
- (math-normalize (list 'calcFunc-tanh u)))))))
+ (lambda (u) (math-neg
+ (math-mul
+ (math-normalize (list 'calcFunc-sech u))
+ (math-normalize (list 'calcFunc-tanh u))))))
(put 'calcFunc-csch\' 'math-derivative-1
- (function (lambda (u) (math-neg
- (math-mul
- (math-normalize (list 'calcFunc-csch u))
- (math-normalize (list 'calcFunc-coth u)))))))
+ (lambda (u) (math-neg
+ (math-mul
+ (math-normalize (list 'calcFunc-csch u))
+ (math-normalize (list 'calcFunc-coth u))))))
(put 'calcFunc-coth\' 'math-derivative-1
- (function (lambda (u) (math-neg
- (math-sqr
- (math-normalize
- (list 'calcFunc-csch u)))))))
+ (lambda (u) (math-neg
+ (math-sqr
+ (math-normalize
+ (list 'calcFunc-csch u))))))
(put 'calcFunc-arcsinh\' 'math-derivative-1
- (function (lambda (u)
- (math-div 1 (math-normalize
- (list 'calcFunc-sqrt
- (math-add (math-sqr u) 1)))))))
+ (lambda (u)
+ (math-div 1 (math-normalize
+ (list 'calcFunc-sqrt
+ (math-add (math-sqr u) 1))))))
(put 'calcFunc-arccosh\' 'math-derivative-1
- (function (lambda (u)
- (math-div 1 (math-normalize
- (list 'calcFunc-sqrt
- (math-add (math-sqr u) -1)))))))
+ (lambda (u)
+ (math-div 1 (math-normalize
+ (list 'calcFunc-sqrt
+ (math-add (math-sqr u) -1))))))
(put 'calcFunc-arctanh\' 'math-derivative-1
- (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
+ (lambda (u) (math-div 1 (math-sub 1 (math-sqr u)))))
(put 'calcFunc-bern\'2 'math-derivative-2
- (function (lambda (n x)
- (math-mul n (list 'calcFunc-bern (math-add n -1) x)))))
+ (lambda (n x)
+ (math-mul n (list 'calcFunc-bern (math-add n -1) x))))
(put 'calcFunc-euler\'2 'math-derivative-2
- (function (lambda (n x)
- (math-mul n (list 'calcFunc-euler (math-add n -1) x)))))
+ (lambda (n x)
+ (math-mul n (list 'calcFunc-euler (math-add n -1) x))))
(put 'calcFunc-gammag\'2 'math-derivative-2
- (function (lambda (a x) (math-deriv-gamma a x 1))))
+ (lambda (a x) (math-deriv-gamma a x 1)))
(put 'calcFunc-gammaG\'2 'math-derivative-2
- (function (lambda (a x) (math-deriv-gamma a x -1))))
+ (lambda (a x) (math-deriv-gamma a x -1)))
(put 'calcFunc-gammaP\'2 'math-derivative-2
- (function (lambda (a x) (math-deriv-gamma a x
- (math-div
- 1 (math-normalize
- (list 'calcFunc-gamma
- a)))))))
+ (lambda (a x) (math-deriv-gamma a x
+ (math-div
+ 1 (math-normalize
+ (list 'calcFunc-gamma
+ a))))))
(put 'calcFunc-gammaQ\'2 'math-derivative-2
- (function (lambda (a x) (math-deriv-gamma a x
- (math-div
- -1 (math-normalize
- (list 'calcFunc-gamma
- a)))))))
+ (lambda (a x) (math-deriv-gamma a x
+ (math-div
+ -1 (math-normalize
+ (list 'calcFunc-gamma
+ a))))))
(defun math-deriv-gamma (a x scale)
(math-mul scale
@@ -533,13 +537,13 @@
(list 'calcFunc-exp (math-neg x)))))
(put 'calcFunc-betaB\' 'math-derivative-3
- (function (lambda (x a b) (math-deriv-beta x a b 1))))
+ (lambda (x a b) (math-deriv-beta x a b 1)))
(put 'calcFunc-betaI\' 'math-derivative-3
- (function (lambda (x a b) (math-deriv-beta x a b
- (math-div
- 1 (list 'calcFunc-beta
- a b))))))
+ (lambda (x a b) (math-deriv-beta x a b
+ (math-div
+ 1 (list 'calcFunc-beta
+ a b)))))
(defun math-deriv-beta (x a b scale)
(math-mul (math-mul (math-pow x (math-add a -1))
@@ -547,101 +551,96 @@
scale))
(put 'calcFunc-erf\' 'math-derivative-1
- (function (lambda (x) (math-div 2
- (math-mul (list 'calcFunc-exp
- (math-sqr x))
- (if calc-symbolic-mode
- '(calcFunc-sqrt
- (var pi var-pi))
- (math-sqrt-pi)))))))
+ (lambda (x) (math-div 2
+ (math-mul (list 'calcFunc-exp
+ (math-sqr x))
+ (if calc-symbolic-mode
+ '(calcFunc-sqrt
+ (var pi var-pi))
+ (math-sqrt-pi))))))
(put 'calcFunc-erfc\' 'math-derivative-1
- (function (lambda (x) (math-div -2
- (math-mul (list 'calcFunc-exp
- (math-sqr x))
- (if calc-symbolic-mode
- '(calcFunc-sqrt
- (var pi var-pi))
- (math-sqrt-pi)))))))
+ (lambda (x) (math-div -2
+ (math-mul (list 'calcFunc-exp
+ (math-sqr x))
+ (if calc-symbolic-mode
+ '(calcFunc-sqrt
+ (var pi var-pi))
+ (math-sqrt-pi))))))
(put 'calcFunc-besJ\'2 'math-derivative-2
- (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ
- (math-add v -1)
- z)
- (list 'calcFunc-besJ
- (math-add v 1)
- z))
- 2))))
+ (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ
+ (math-add v -1)
+ z)
+ (list 'calcFunc-besJ
+ (math-add v 1)
+ z))
+ 2)))
(put 'calcFunc-besY\'2 'math-derivative-2
- (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besY
- (math-add v -1)
- z)
- (list 'calcFunc-besY
- (math-add v 1)
- z))
- 2))))
+ (lambda (v z) (math-div (math-sub (list 'calcFunc-besY
+ (math-add v -1)
+ z)
+ (list 'calcFunc-besY
+ (math-add v 1)
+ z))
+ 2)))
(put 'calcFunc-sum 'math-derivative-n
- (function
- (lambda (expr)
- (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var)
- (throw 'math-deriv nil)
- (cons 'calcFunc-sum
- (cons (math-derivative (nth 1 expr))
- (cdr (cdr expr))))))))
+ (lambda (expr)
+ (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var)
+ (throw 'math-deriv nil)
+ (cons 'calcFunc-sum
+ (cons (math-derivative (nth 1 expr))
+ (cdr (cdr expr)))))))
(put 'calcFunc-prod 'math-derivative-n
- (function
- (lambda (expr)
- (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var)
- (throw 'math-deriv nil)
- (math-mul expr
- (cons 'calcFunc-sum
- (cons (math-div (math-derivative (nth 1 expr))
- (nth 1 expr))
- (cdr (cdr expr)))))))))
+ (lambda (expr)
+ (if (math-expr-contains (cons 'vec (cdr (cdr expr))) math-deriv-var)
+ (throw 'math-deriv nil)
+ (math-mul expr
+ (cons 'calcFunc-sum
+ (cons (math-div (math-derivative (nth 1 expr))
+ (nth 1 expr))
+ (cdr (cdr expr))))))))
(put 'calcFunc-integ 'math-derivative-n
- (function
- (lambda (expr)
- (if (= (length expr) 3)
- (if (equal (nth 2 expr) math-deriv-var)
- (nth 1 expr)
- (math-normalize
- (list 'calcFunc-integ
- (math-derivative (nth 1 expr))
- (nth 2 expr))))
- (if (= (length expr) 5)
- (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr)
- (nth 3 expr)))
- (upper (math-expr-subst (nth 1 expr) (nth 2 expr)
- (nth 4 expr))))
- (math-add (math-sub (math-mul upper
- (math-derivative (nth 4 expr)))
- (math-mul lower
- (math-derivative (nth 3 expr))))
- (if (equal (nth 2 expr) math-deriv-var)
- 0
- (math-normalize
- (list 'calcFunc-integ
- (math-derivative (nth 1 expr)) (nth 2 expr)
- (nth 3 expr) (nth 4 expr)))))))))))
+ (lambda (expr)
+ (if (= (length expr) 3)
+ (if (equal (nth 2 expr) math-deriv-var)
+ (nth 1 expr)
+ (math-normalize
+ (list 'calcFunc-integ
+ (math-derivative (nth 1 expr))
+ (nth 2 expr))))
+ (if (= (length expr) 5)
+ (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr)
+ (nth 3 expr)))
+ (upper (math-expr-subst (nth 1 expr) (nth 2 expr)
+ (nth 4 expr))))
+ (math-add (math-sub (math-mul upper
+ (math-derivative (nth 4 expr)))
+ (math-mul lower
+ (math-derivative (nth 3 expr))))
+ (if (equal (nth 2 expr) math-deriv-var)
+ 0
+ (math-normalize
+ (list 'calcFunc-integ
+ (math-derivative (nth 1 expr)) (nth 2 expr)
+ (nth 3 expr) (nth 4 expr))))))))))
(put 'calcFunc-if 'math-derivative-n
- (function
- (lambda (expr)
- (and (= (length expr) 4)
- (list 'calcFunc-if (nth 1 expr)
- (math-derivative (nth 2 expr))
- (math-derivative (nth 3 expr)))))))
+ (lambda (expr)
+ (and (= (length expr) 4)
+ (list 'calcFunc-if (nth 1 expr)
+ (math-derivative (nth 2 expr))
+ (math-derivative (nth 3 expr))))))
(put 'calcFunc-subscr 'math-derivative-n
- (function
- (lambda (expr)
- (and (= (length expr) 3)
- (list 'calcFunc-subscr (nth 1 expr)
- (math-derivative (nth 2 expr)))))))
+ (lambda (expr)
+ (and (= (length expr) 3)
+ (list 'calcFunc-subscr (nth 1 expr)
+ (math-derivative (nth 2 expr))))))
(defvar math-integ-var '(var X ---))
@@ -1011,11 +1010,10 @@
res '(calcFunc-integsubst)))
(and (memq (length part) '(3 4 5))
(let ((parts (mapcar
- (function
- (lambda (x)
- (math-expr-subst
- x (nth 2 part)
- math-integ-var)))
+ (lambda (x)
+ (math-expr-subst
+ x (nth 2 part)
+ math-integ-var))
(cdr part))))
(math-integrate-by-substitution
expr (car parts) t
@@ -1079,8 +1077,9 @@
;; math-integ-try-substitutions.
(defvar math-integ-expr)
-(defun math-do-integral-methods (math-integ-expr)
- (let ((math-so-far math-integ-var-list-list)
+(defun math-do-integral-methods (integ-expr)
+ (let ((math-integ-expr integ-expr)
+ (math-so-far math-integ-var-list-list)
rat-in)
;; Integration by substitution, for various likely sub-expressions.
@@ -1195,10 +1194,11 @@
(defvar math-good-parts)
-(defun math-integ-try-parts (expr &optional math-good-parts)
+(defun math-integ-try-parts (expr &optional good-parts)
;; Integration by parts:
;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x)
;; where h(x) = integ(g(x),x).
+ (let ((math-good-parts good-parts))
(or (let ((exp (calcFunc-expand expr)))
(and (not (equal exp expr))
(math-integral exp)))
@@ -1219,14 +1219,14 @@
(and (eq (car expr) '^)
(math-integrate-by-parts (math-pow (nth 1 expr)
(math-sub (nth 2 expr) 1))
- (nth 1 expr)))))
+ (nth 1 expr))))))
(defun math-integrate-by-parts (u vprime)
(let ((math-integ-level (if (or math-good-parts
(math-polynomial-p u math-integ-var))
math-integ-level
(1- math-integ-level)))
- (math-doing-parts t)
+ ;; (math-doing-parts t) ;Unused
v temp)
(and (>= math-integ-level 0)
(unwind-protect
@@ -1510,7 +1510,7 @@
var low high)
(nth 2 (nth 2 expr))))
((eq (car-safe expr) 'vec)
- (cons 'vec (mapcar (function (lambda (x) (calcFunc-integ x var low high)))
+ (cons 'vec (mapcar (lambda (x) (calcFunc-integ x var low high))
(cdr expr))))
(t
(let ((state (list calc-angle-mode
@@ -1532,7 +1532,7 @@
(math-any-substs t)
(math-enable-subst nil)
(math-prev-parts-v nil)
- (math-doing-parts nil)
+ ;; (math-doing-parts nil) ;Unused
(math-good-parts nil)
(res
(if trace-buffer
@@ -1545,9 +1545,7 @@
(set-buffer trace-buffer)
(goto-char (point-max))
(or (assq 'scroll-stop (buffer-local-variables))
- (progn
- (make-local-variable 'scroll-step)
- (setq scroll-step 3)))
+ (setq-local scroll-step 3))
(insert "\n\n\n")
(set-buffer calcbuf)
(math-try-integral sexpr))
@@ -1883,7 +1881,10 @@
(defvar calc-high)
(defvar math-var)
-(defun calcFunc-table (expr math-var &optional calc-low calc-high step)
+(defun calcFunc-table (expr var &optional low high step)
+ (let ((math-var var)
+ (calc-high high)
+ (calc-low low))
(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))
@@ -1894,8 +1895,7 @@
(let ((known (+ (if (Math-objectp calc-low) 1 0)
(if (Math-objectp calc-high) 1 0)
(if (or (null step) (Math-objectp step)) 1 0)))
- (count '(var inf var-inf))
- vec)
+ (count '(var inf var-inf))) ;; vec
(or (= known 2) ; handy optimization
(equal calc-high '(var inf var-inf))
(progn
@@ -1906,6 +1906,7 @@
(setq count (math-trunc count)))))
(if (Math-negp count)
(setq count -1))
+ (defvar var-DUMMY)
(if (integerp count)
(let ((var-DUMMY nil)
(vec math-tabulate-initial)
@@ -1939,7 +1940,7 @@
(and (not (and (equal calc-low '(neg (var inf var-inf)))
(equal calc-high '(var inf var-inf))))
(list calc-low calc-high))
- (and step (list step))))))
+ (and step (list step)))))))
(defun math-scan-for-limits (x)
(cond ((Math-primp x))
@@ -1951,8 +1952,10 @@
(high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x)))
math-var nil))
temp)
- (and low-val (math-realp low-val)
- high-val (math-realp high-val))
+ ;; FIXME: The below is a no-op, but I suspect its result
+ ;; was meant to be used, tho I don't know what for.
+ ;; (and low-val (math-realp low-val)
+ ;; high-val (math-realp high-val))
(and (Math-lessp high-val low-val)
(setq temp low-val low-val high-val high-val temp))
(setq calc-low (math-max calc-low (math-ceiling low-val))
@@ -2361,8 +2364,11 @@
(defvar math-try-solve-sign)
(defun math-try-solve-for
- (math-solve-lhs math-solve-rhs &optional math-try-solve-sign no-poly)
- (let (math-t1 math-t2 math-t3)
+ (solve-lhs solve-rhs &optional try-solve-sign no-poly)
+ (let ((math-solve-lhs solve-lhs)
+ (math-solve-rhs solve-rhs)
+ (math-try-solve-sign try-solve-sign)
+ math-t1 math-t2 math-t3)
(cond ((equal math-solve-lhs math-solve-var)
(setq math-solve-sign math-try-solve-sign)
(if (eq math-solve-full 'all)
@@ -2721,32 +2727,34 @@
(cons 'vec d)
(math-reject-arg expr "Expected a polynomial"))))
-(defun math-decompose-poly (math-solve-lhs math-solve-var degree sub-rhs)
- (let ((math-solve-rhs (or sub-rhs 1))
+(defun math-decompose-poly (solve-lhs solve-var degree sub-rhs)
+ (let ((math-solve-lhs solve-lhs)
+ (math-solve-var solve-var)
+ (math-solve-rhs (or sub-rhs 1))
math-t1 math-t2 math-t3)
(setq math-t2 (math-polynomial-base
math-solve-lhs
- (function
- (lambda (math-solve-b)
- (let ((math-poly-neg-powers '(1))
- (math-poly-mult-powers nil)
- (math-poly-frac-powers 1)
- (math-poly-exp-base t))
- (and (not (equal math-solve-b math-solve-lhs))
- (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs)
- (setq math-t3 '(1 0) math-t2 1
- math-t1 (math-is-polynomial math-solve-lhs
- math-solve-b 50))
- (if (and (equal math-poly-neg-powers '(1))
- (memq math-poly-mult-powers '(nil 1))
- (eq math-poly-frac-powers 1)
- sub-rhs)
- (setq math-t1 (cons (math-sub (car math-t1) math-solve-rhs)
- (cdr math-t1)))
- (math-solve-poly-funny-powers sub-rhs))
- (math-solve-crunch-poly degree)
- (or (math-expr-contains math-solve-b math-solve-var)
- (math-expr-contains (car math-t3) math-solve-var))))))))
+ (lambda (solve-b)
+ (let ((math-solve-b solve-b)
+ (math-poly-neg-powers '(1))
+ (math-poly-mult-powers nil)
+ (math-poly-frac-powers 1)
+ (math-poly-exp-base t))
+ (and (not (equal math-solve-b math-solve-lhs))
+ (or (not (memq (car-safe math-solve-b) '(+ -))) sub-rhs)
+ (setq math-t3 '(1 0) math-t2 1
+ math-t1 (math-is-polynomial math-solve-lhs
+ math-solve-b 50))
+ (if (and (equal math-poly-neg-powers '(1))
+ (memq math-poly-mult-powers '(nil 1))
+ (eq math-poly-frac-powers 1)
+ sub-rhs)
+ (setq math-t1 (cons (math-sub (car math-t1) math-solve-rhs)
+ (cdr math-t1)))
+ (math-solve-poly-funny-powers sub-rhs))
+ (math-solve-crunch-poly degree)
+ (or (math-expr-contains math-solve-b math-solve-var)
+ (math-expr-contains (car math-t3) math-solve-var)))))))
(if math-t2
(list (math-pow math-t2 (car math-t3))
(cons 'vec math-t1)
@@ -2964,7 +2972,7 @@
(math-poly-integer-root (car roots))
(setq roots (cdr roots)))
(list math-int-factors (nreverse math-int-coefs) math-int-scale))
- (let ((vec nil) res)
+ (let ((vec nil)) ;; res
(while roots
(let ((root (car roots))
(math-solve-full (and math-solve-full 'all)))
@@ -3109,7 +3117,7 @@
(iters 0)
(m (1- (length p)))
(try-newt (not polish))
- (tried-newt nil)
+ ;; (tried-newt nil)
b d f x1 dx dxold)
(while
(and (or (< (setq iters (1+ iters)) 50)
@@ -3146,7 +3154,7 @@
(math-lessp (math-abs-approx dx)
(calcFunc-scf (math-abs-approx x) -3)))
(let ((newt (math-poly-newton-root p x1 7)))
- (setq tried-newt t
+ (setq ;; tried-newt t
try-newt nil)
(if (math-zerop (cdr newt))
(setq x (car newt) x1 x)
@@ -3160,7 +3168,8 @@
(math-nearly-equal x x1))))
(let ((cdx (math-abs-approx dx)))
(setq x x1
- tried-newt nil)
+ ;; tried-newt nil
+ )
(prog1
(or (<= iters 6)
(math-lessp cdx dxold)
@@ -3227,7 +3236,9 @@
;; and math-solve-system-rec, but is used by math-solve-system-subst.
(defvar math-solve-simplifying)
-(defun math-solve-system (exprs math-solve-vars math-solve-full)
+(defun math-solve-system (exprs solve-vars solve-full)
+ (let ((math-solve-vars solve-vars)
+ (math-solve-full solve-full))
(setq exprs (mapcar 'list (if (Math-vectorp exprs)
(cdr exprs)
(list exprs)))
@@ -3237,18 +3248,18 @@
(or (let ((math-solve-simplifying nil))
(math-solve-system-rec exprs math-solve-vars nil))
(let ((math-solve-simplifying t))
- (math-solve-system-rec exprs math-solve-vars nil))))
+ (math-solve-system-rec exprs math-solve-vars nil)))))
-;;; The following backtracking solver works by choosing a variable
-;;; and equation, and trying to solve the equation for the variable.
-;;; If it succeeds it calls itself recursively with that variable and
-;;; equation removed from their respective lists, and with the solution
-;;; added to solns as well as being substituted into all existing
-;;; equations. The algorithm terminates when any solution path
-;;; manages to remove all the variables from var-list.
+;; The following backtracking solver works by choosing a variable
+;; and equation, and trying to solve the equation for the variable.
+;; If it succeeds it calls itself recursively with that variable and
+;; equation removed from their respective lists, and with the solution
+;; added to solns as well as being substituted into all existing
+;; equations. The algorithm terminates when any solution path
+;; manages to remove all the variables from `var-list'.
-;;; To support calcFunc-roots, entries in eqn-list and solns are
-;;; actually lists of equations.
+;; To support calcFunc-roots, entries in eqn-list and solns are
+;; actually lists of equations.
;; The variables math-solve-system-res and math-solve-system-vv are
;; local to math-solve-system-rec, but are used by math-solve-system-subst.
@@ -3306,12 +3317,11 @@
(delq (car v) (copy-sequence var-list))
(let ((math-solve-simplifying nil)
(s (mapcar
- (function
- (lambda (x)
- (cons
- (car x)
- (math-solve-system-subst
- (cdr x)))))
+ (lambda (x)
+ (cons
+ (car x)
+ (math-solve-system-subst
+ (cdr x))))
solns)))
(if elim
s
@@ -3327,35 +3337,33 @@
;; Eliminated all variables, so now put solution into the proper format.
(setq solns (sort solns
- (function
- (lambda (x y)
- (not (memq (car x) (memq (car y) math-solve-vars)))))))
+ (lambda (x y)
+ (not (memq (car x) (memq (car y) math-solve-vars))))))
(if (eq math-solve-full 'all)
(math-transpose
(math-normalize
(cons 'vec
(if solns
- (mapcar (function (lambda (x) (cons 'vec (cdr x)))) solns)
- (mapcar (function (lambda (x) (cons 'vec x))) eqn-list)))))
+ (mapcar (lambda (x) (cons 'vec (cdr x))) solns)
+ (mapcar (lambda (x) (cons 'vec x)) eqn-list)))))
(math-normalize
(cons 'vec
(if solns
- (mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns)
- (mapcar 'car eqn-list)))))))
+ (mapcar (lambda (x) (cons 'calcFunc-eq x)) solns)
+ (mapcar #'car eqn-list)))))))
(defun math-solve-system-subst (x) ; uses "res" and "v"
(let ((accum nil)
(res2 math-solve-system-res))
(while x
(setq accum (nconc accum
- (mapcar (function
- (lambda (r)
- (if math-solve-simplifying
- (math-simplify
- (math-expr-subst
- (car x) math-solve-system-vv r))
- (math-expr-subst
- (car x) math-solve-system-vv r))))
+ (mapcar (lambda (r)
+ (if math-solve-simplifying
+ (math-simplify
+ (math-expr-subst
+ (car x) math-solve-system-vv r))
+ (math-expr-subst
+ (car x) math-solve-system-vv r)))
(car res2)))
x (cdr x)
res2 (cdr res2)))
@@ -3437,10 +3445,12 @@
(if (memq (car expr) '(* /))
(math-looks-evenp (nth 1 expr)))))
-(defun math-solve-for (lhs rhs math-solve-var math-solve-full &optional sign)
- (if (math-expr-contains rhs math-solve-var)
- (math-solve-for (math-sub lhs rhs) 0 math-solve-var math-solve-full)
- (and (math-expr-contains lhs math-solve-var)
+(defun math-solve-for (lhs rhs solve-var solve-full &optional sign)
+ (let ((math-solve-var solve-var)
+ (math-solve-full solve-full))
+ (if (math-expr-contains rhs solve-var)
+ (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full)
+ (and (math-expr-contains lhs solve-var)
(math-with-extra-prec 1
(let* ((math-poly-base-variable math-solve-var)
(res (math-try-solve-for lhs rhs sign)))
@@ -3449,11 +3459,10 @@
(let ((old-len (length res))
new-len)
(setq res (delq nil
- (mapcar (function
- (lambda (x)
- (and (not (memq (car-safe x)
- '(cplx polar)))
- x)))
+ (mapcar (lambda (x)
+ (and (not (memq (car-safe x)
+ '(cplx polar)))
+ x))
res))
new-len (length res))
(if (< new-len old-len)
@@ -3462,7 +3471,7 @@
(format
"*Omitted %d complex solutions"
(- old-len new-len)))))))
- res)))))
+ res))))))
(defun math-solve-eqn (expr var full)
(if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt
@@ -3523,119 +3532,119 @@
(put 'calcFunc-inv 'math-inverse
- (function (lambda (x) (math-div 1 x))))
+ (lambda (x) (math-div 1 x)))
(put 'calcFunc-inv 'math-inverse-sign -1)
(put 'calcFunc-sqrt 'math-inverse
- (function (lambda (x) (math-sqr x))))
+ (lambda (x) (math-sqr x)))
(put 'calcFunc-conj 'math-inverse
- (function (lambda (x) (list 'calcFunc-conj x))))
+ (lambda (x) (list 'calcFunc-conj x)))
(put 'calcFunc-abs 'math-inverse
- (function (lambda (x) (math-solve-get-sign x))))
+ (lambda (x) (math-solve-get-sign x)))
(put 'calcFunc-deg 'math-inverse
- (function (lambda (x) (list 'calcFunc-rad x))))
+ (lambda (x) (list 'calcFunc-rad x)))
(put 'calcFunc-deg 'math-inverse-sign 1)
(put 'calcFunc-rad 'math-inverse
- (function (lambda (x) (list 'calcFunc-deg x))))
+ (lambda (x) (list 'calcFunc-deg x)))
(put 'calcFunc-rad 'math-inverse-sign 1)
(put 'calcFunc-ln 'math-inverse
- (function (lambda (x) (list 'calcFunc-exp x))))
+ (lambda (x) (list 'calcFunc-exp x)))
(put 'calcFunc-ln 'math-inverse-sign 1)
(put 'calcFunc-log10 'math-inverse
- (function (lambda (x) (list 'calcFunc-exp10 x))))
+ (lambda (x) (list 'calcFunc-exp10 x)))
(put 'calcFunc-log10 'math-inverse-sign 1)
(put 'calcFunc-lnp1 'math-inverse
- (function (lambda (x) (list 'calcFunc-expm1 x))))
+ (lambda (x) (list 'calcFunc-expm1 x)))
(put 'calcFunc-lnp1 'math-inverse-sign 1)
(put 'calcFunc-exp 'math-inverse
- (function (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x))
- (math-mul 2
- (math-mul '(var pi var-pi)
- (math-solve-get-int
- '(var i var-i))))))))
+ (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x))
+ (math-mul 2
+ (math-mul '(var pi var-pi)
+ (math-solve-get-int
+ '(var i var-i)))))))
(put 'calcFunc-exp 'math-inverse-sign 1)
(put 'calcFunc-expm1 'math-inverse
- (function (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x))
- (math-mul 2
- (math-mul '(var pi var-pi)
- (math-solve-get-int
- '(var i var-i))))))))
+ (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x))
+ (math-mul 2
+ (math-mul '(var pi var-pi)
+ (math-solve-get-int
+ '(var i var-i)))))))
(put 'calcFunc-expm1 'math-inverse-sign 1)
(put 'calcFunc-sin 'math-inverse
- (function (lambda (x) (let ((n (math-solve-get-int 1)))
- (math-add (math-mul (math-normalize
- (list 'calcFunc-arcsin x))
- (math-pow -1 n))
- (math-mul (math-half-circle t)
- n))))))
+ (lambda (x) (let ((n (math-solve-get-int 1)))
+ (math-add (math-mul (math-normalize
+ (list 'calcFunc-arcsin x))
+ (math-pow -1 n))
+ (math-mul (math-half-circle t)
+ n)))))
(put 'calcFunc-cos 'math-inverse
- (function (lambda (x) (math-add (math-solve-get-sign
- (math-normalize
- (list 'calcFunc-arccos x)))
- (math-solve-get-int
- (math-full-circle t))))))
+ (lambda (x) (math-add (math-solve-get-sign
+ (math-normalize
+ (list 'calcFunc-arccos x)))
+ (math-solve-get-int
+ (math-full-circle t)))))
(put 'calcFunc-tan 'math-inverse
- (function (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x))
- (math-solve-get-int
- (math-half-circle t))))))
+ (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x))
+ (math-solve-get-int
+ (math-half-circle t)))))
(put 'calcFunc-arcsin 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-sin x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-sin x))))
(put 'calcFunc-arccos 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-cos x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-cos x))))
(put 'calcFunc-arctan 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-tan x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-tan x))))
(put 'calcFunc-sinh 'math-inverse
- (function (lambda (x) (let ((n (math-solve-get-int 1)))
- (math-add (math-mul (math-normalize
- (list 'calcFunc-arcsinh x))
- (math-pow -1 n))
- (math-mul (math-half-circle t)
- (math-mul
- '(var i var-i)
- n)))))))
+ (lambda (x) (let ((n (math-solve-get-int 1)))
+ (math-add (math-mul (math-normalize
+ (list 'calcFunc-arcsinh x))
+ (math-pow -1 n))
+ (math-mul (math-half-circle t)
+ (math-mul
+ '(var i var-i)
+ n))))))
(put 'calcFunc-sinh 'math-inverse-sign 1)
(put 'calcFunc-cosh 'math-inverse
- (function (lambda (x) (math-add (math-solve-get-sign
- (math-normalize
- (list 'calcFunc-arccosh x)))
- (math-mul (math-full-circle t)
- (math-solve-get-int
- '(var i var-i)))))))
+ (lambda (x) (math-add (math-solve-get-sign
+ (math-normalize
+ (list 'calcFunc-arccosh x)))
+ (math-mul (math-full-circle t)
+ (math-solve-get-int
+ '(var i var-i))))))
(put 'calcFunc-tanh 'math-inverse
- (function (lambda (x) (math-add (math-normalize
- (list 'calcFunc-arctanh x))
- (math-mul (math-half-circle t)
- (math-solve-get-int
- '(var i var-i)))))))
+ (lambda (x) (math-add (math-normalize
+ (list 'calcFunc-arctanh x))
+ (math-mul (math-half-circle t)
+ (math-solve-get-int
+ '(var i var-i))))))
(put 'calcFunc-tanh 'math-inverse-sign 1)
(put 'calcFunc-arcsinh 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-sinh x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-sinh x))))
(put 'calcFunc-arcsinh 'math-inverse-sign 1)
(put 'calcFunc-arccosh 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-cosh x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-cosh x))))
(put 'calcFunc-arctanh 'math-inverse
- (function (lambda (x) (math-normalize (list 'calcFunc-tanh x)))))
+ (lambda (x) (math-normalize (list 'calcFunc-tanh x))))
(put 'calcFunc-arctanh 'math-inverse-sign 1)
diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el
index a914b8aec40..ee3ae0a4c1f 100644
--- a/lisp/calc/calcalg3.el
+++ b/lisp/calc/calcalg3.el
@@ -1,4 +1,4 @@
-;;; calcalg3.el --- more algebraic functions for Calc
+;;; calcalg3.el --- more algebraic functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -120,18 +120,24 @@
(defvar calc-curve-fit-history nil
"History for calc-curve-fit.")
-(defun calc-curve-fit (arg &optional calc-curve-model
- calc-curve-coefnames calc-curve-varnames)
+(defvar calc-graph-no-auto-view)
+(defvar calc-fit-to-trail nil)
+
+(defun calc-curve-fit (arg &optional curve-model
+ curve-coefnames curve-varnames)
(interactive "P")
(calc-slow-wrapper
(setq calc-aborted-prefix nil)
- (let ((func (if (calc-is-inverse) 'calcFunc-xfit
+ (let ((calc-curve-model curve-model)
+ (calc-curve-coefnames curve-coefnames)
+ (calc-curve-varnames curve-varnames)
+ (func (if (calc-is-inverse) 'calcFunc-xfit
(if (calc-is-hyperbolic) 'calcFunc-efit
'calcFunc-fit)))
key (which 0)
(nonlinear nil)
(plot nil)
- n calc-curve-nvars temp data
+ n calc-curve-nvars data ;; temp
(homog nil)
(msgs '( "(Press ? for help)"
"1 = linear or multilinear"
@@ -321,7 +327,7 @@
(calc-get-fit-variables 1 (1- (length calc-curve-coefnames))
(and homog 1)))
((memq key '(?\$ ?\' ?u ?U))
- (let* ((defvars nil)
+ (let* (;; (defvars nil)
(record-entry nil))
(if (eq key ?\')
(let* ((calc-dollar-values calc-arg-values)
@@ -470,17 +476,19 @@
(setq defv (calc-invent-independent-variables nv)))
(or defc
(setq defc (calc-invent-parameter-variables nc defv)))
- (let ((vars (read-string (format "Fitting variables (default %s; %s): "
- (mapconcat 'symbol-name
- (mapcar (function (lambda (v)
- (nth 1 v)))
- defv)
- ",")
- (mapconcat 'symbol-name
- (mapcar (function (lambda (v)
- (nth 1 v)))
- defc)
- ","))))
+ (let ((vars (read-string (format-prompt
+ "Fitting variables"
+ (format "%s; %s"
+ (mapconcat 'symbol-name
+ (mapcar (lambda (v)
+ (nth 1 v))
+ defv)
+ ",")
+ (mapconcat 'symbol-name
+ (mapcar (lambda (v)
+ (nth 1 v))
+ defc)
+ ",")))))
(coefs nil))
(setq vars (if (string-match "\\[" vars)
(math-read-expr vars)
@@ -706,7 +714,7 @@
"*Unable to find a sign change in this interval"))))
;;; "rtbis" (but we should be using Brent's method)
-(defun math-bisect-root (expr low vlow high vhigh)
+(defun math-bisect-root (expr low _vlow high vhigh)
(let ((step (math-sub-float high low))
(pos (Math-posp vhigh))
var-DUMMY
@@ -724,7 +732,8 @@
(setq high mid
vhigh vmid)
(setq low mid
- vlow vmid)))
+ ;; vlow vmid
+ )))
(list 'vec mid vmid)))
;;; "mnewt"
@@ -756,7 +765,8 @@
(list 'vec next expr-val))))
-(defun math-find-root (expr var guess math-root-widen)
+(defun math-find-root (expr var guess root-widen)
+ (let ((math-root-widen root-widen))
(if (eq (car-safe expr) 'vec)
(let ((n (1- (length expr)))
(calc-symbolic-mode nil)
@@ -869,7 +879,7 @@
(not (Math-numberp vlow))
(not (Math-numberp vhigh)))
(math-search-root expr deriv low vlow high vhigh)
- (math-bisect-root expr low vlow high vhigh))))))))))
+ (math-bisect-root expr low vlow high vhigh)))))))))))
(defun calcFunc-root (expr var guess)
(math-find-root expr var guess nil))
@@ -1017,7 +1027,7 @@
math-min-or-max))))))
;;; "brent"
-(defun math-brent-min (expr prec a va x vx b vb)
+(defun math-brent-min (expr prec a _va x vx b _vb)
(let ((iters (+ 20 (* 5 prec)))
(w x)
(vw vx)
@@ -1179,7 +1189,7 @@
(list 'calcFunc-mrow '(var line-p line-p) (1+ m)))))
(math-evaluate-expr expr)))
-(defun math-line-min (f1dim line-p line-xi n prec)
+(defun math-line-min (f1dim line-p line-xi _n prec)
(let* ((var-DUMMY nil)
(expr (math-evaluate-expr f1dim))
(params (math-widen-min expr '(float 0 0) '(float 1 0)))
@@ -1193,7 +1203,7 @@
(n 0)
(var-DUMMY nil)
(isvec (math-vectorp var))
- g guesses)
+ guesses) ;; g
(or (math-vectorp var)
(setq var (list 'vec var)))
(or (math-vectorp guess)
@@ -1326,7 +1336,7 @@
(or (> (length (nth 1 data)) 2)
(math-reject-arg data "*Too few data points"))
(if (and (math-vectorp x) (or (math-constp x) math-expand-formulas))
- (cons 'vec (mapcar (function (lambda (x) (calcFunc-polint data x)))
+ (cons 'vec (mapcar (lambda (x) (calcFunc-polint data x))
(cdr x)))
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp))
(math-with-extra-prec 2
@@ -1342,7 +1352,7 @@
(or (> (length (nth 1 data)) 2)
(math-reject-arg data "*Too few data points"))
(if (and (math-vectorp x) (or (math-constp x) math-expand-formulas))
- (cons 'vec (mapcar (function (lambda (x) (calcFunc-ratint data x)))
+ (cons 'vec (mapcar (lambda (x) (calcFunc-ratint data x))
(cdr x)))
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp))
(math-with-extra-prec 2
@@ -1491,7 +1501,8 @@
(defun math-ninteg-midpoint (expr lo hi mode) ; uses "math-ninteg-temp"
(if (eq mode 'inf)
- (let ((math-infinite-mode t) temp)
+ (let (;; (math-infinite-mode t) ;Unused!
+ temp)
(setq temp (math-div 1 lo)
lo (math-div 1 hi)
hi temp)))
@@ -1545,7 +1556,6 @@
(setq math-dummy-counter (1+ math-dummy-counter))))
(defvar math-in-fit 0)
-(defvar calc-fit-to-trail nil)
(defun calcFunc-fit (expr vars &optional coefs data)
(let ((math-in-fit 10))
@@ -1571,6 +1581,7 @@
(defvar math-fit-new-coefs)
(defun math-general-fit (expr vars coefs data mode)
+ (defvar var-YVAL) (defvar var-YVALX)
(let ((calc-simplify-mode nil)
(math-dummy-counter math-dummy-counter)
(math-in-fit 1)
@@ -1589,7 +1600,7 @@
(weights nil)
(var-YVAL nil) (var-YVALX nil)
covar beta
- n nn m mm v dummy p)
+ n m mm v dummy p) ;; nn
;; Validate and parse arguments.
(or data
@@ -1685,7 +1696,7 @@
(isigsq 1)
(xvals (make-vector mm 0))
(i 0)
- j k xval yval sigmasqr wt covj covjk covk betaj lud)
+ j k xval yval sigmasqr wt covj covjk covk betaj) ;; lud
(while (<= (setq i (1+ i)) n)
;; Assign various independent variables for this data point.
@@ -1899,8 +1910,8 @@
(while p
(setq vars (delq (assoc (car-safe p) vars) vars)
p (cdr p)))
- (sort (mapcar 'car vars)
- (function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))))
+ (sort (mapcar #'car vars)
+ (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
;; The variables math-all-vars-vars (the vars for math-all-vars) and
;; math-all-vars-found are local to math-all-vars-in, but are used by
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index ea0a95d1506..bd81d7fe406 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -138,19 +138,19 @@
(math-format-number (nth 2 aa))))))
(if (= calc-number-radix 10)
c
- (list 'horiz "(" c
- (list 'subscr ")"
- (int-to-string calc-number-radix)))))
+ (list 'subscr (math--comp-round-bracket c)
+ (int-to-string calc-number-radix))))
(math-format-number a)))
(if (not (eq calc-language 'big))
(math-format-number a prec)
(if (memq (car-safe a) '(cplx polar))
(if (math-zerop (nth 2 a))
(math-compose-expr (nth 1 a) prec)
- (list 'horiz "("
- (math-compose-expr (nth 1 a) 0)
- (if (eq (car a) 'cplx) ", " "; ")
- (math-compose-expr (nth 2 a) 0) ")"))
+ (math--comp-round-bracket
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 0)
+ (if (eq (car a) 'cplx) ", " "; ")
+ (math-compose-expr (nth 2 a) 0))))
(if (or (= calc-number-radix 10)
(not (Math-realp a))
(and calc-group-digits
@@ -340,12 +340,13 @@
(funcall spfn a prec)
(math-compose-var a)))))
((eq (car a) 'intv)
- (list 'horiz
- (if (memq (nth 1 a) '(0 1)) "(" "[")
- (math-compose-expr (nth 2 a) 0)
- " .. "
- (math-compose-expr (nth 3 a) 0)
- (if (memq (nth 1 a) '(0 2)) ")" "]")))
+ (math--comp-bracket
+ (if (memq (nth 1 a) '(0 1)) ?\( ?\[)
+ (if (memq (nth 1 a) '(0 2)) ?\) ?\])
+ (list 'horiz
+ (math-compose-expr (nth 2 a) 0)
+ " .. "
+ (math-compose-expr (nth 3 a) 0))))
((eq (car a) 'date)
(if (eq (car calc-date-format) 'X)
(math-format-date a)
@@ -377,7 +378,7 @@
(and (eq (car-safe (nth 1 a)) 'cplx)
(math-negp (nth 1 (nth 1 a)))
(eq (nth 2 (nth 1 a)) 0)))
- (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 0))
(math-compose-expr (nth 1 a) 201))
(let ((calc-language 'flat)
(calc-number-radix 10)
@@ -444,7 +445,7 @@
(if (> prec (nth 2 a))
(if (setq spfn (get calc-language 'math-big-parens))
(list 'horiz (car spfn) c (cdr spfn))
- (list 'horiz "(" c ")"))
+ (math--comp-round-bracket c))
c)))
((and (eq (car a) 'calcFunc-choriz)
(not (eq calc-language 'unform))
@@ -464,14 +465,13 @@
(math-compose-vector (cdr (nth 1 a))
(math-vector-to-string sep nil)
(or cprec prec))
- (cons 'horiz (mapcar (function
- (lambda (x)
- (if (eq (car-safe x) 'calcFunc-bstring)
- (prog1
- (math-compose-expr
- x (or bprec cprec prec))
- (setq bprec -123))
- (math-compose-expr x (or cprec prec)))))
+ (cons 'horiz (mapcar (lambda (x)
+ (if (eq (car-safe x) 'calcFunc-bstring)
+ (prog1
+ (math-compose-expr
+ x (or bprec cprec prec))
+ (setq bprec -123))
+ (math-compose-expr x (or cprec prec))))
(cdr (nth 1 a)))))))
((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
(not (eq calc-language 'unform))
@@ -482,47 +482,46 @@
(let* ((base 0)
(v 0)
(prec (or (nth 2 a) prec))
- (c (mapcar (function
- (lambda (x)
- (let ((b nil) (cc nil) a d)
- (if (and (memq (car-safe x) '(calcFunc-cbase
- calcFunc-ctbase
- calcFunc-cbbase))
- (memq (length x) '(1 2)))
- (setq b (car x)
- x (nth 1 x)))
- (if (and (eq (car-safe x) 'calcFunc-crule)
- (memq (length x) '(1 2))
- (or (null (nth 1 x))
- (and (math-vectorp (nth 1 x))
- (= (length (nth 1 x)) 2)
- (math-vector-is-string
- (nth 1 x)))
- (and (natnump (nth 1 x))
- (<= (nth 1 x) 255))))
- (setq cc (list
- 'rule
- (if (math-vectorp (nth 1 x))
- (aref (math-vector-to-string
- (nth 1 x) nil) 0)
- (or (nth 1 x) ?-))))
- (or (and (memq (car-safe x) '(calcFunc-cvspace
- calcFunc-ctspace
- calcFunc-cbspace))
- (memq (length x) '(2 3))
- (eq (nth 1 x) 0))
- (null x)
- (setq cc (math-compose-expr x prec))))
- (setq a (if cc (math-comp-ascent cc) 0)
- d (if cc (math-comp-descent cc) 0))
- (if (eq b 'calcFunc-cbase)
- (setq base (+ v a -1))
- (if (eq b 'calcFunc-ctbase)
- (setq base v)
- (if (eq b 'calcFunc-cbbase)
- (setq base (+ v a d -1)))))
- (setq v (+ v a d))
- cc)))
+ (c (mapcar (lambda (x)
+ (let ((b nil) (cc nil) a d)
+ (if (and (memq (car-safe x) '(calcFunc-cbase
+ calcFunc-ctbase
+ calcFunc-cbbase))
+ (memq (length x) '(1 2)))
+ (setq b (car x)
+ x (nth 1 x)))
+ (if (and (eq (car-safe x) 'calcFunc-crule)
+ (memq (length x) '(1 2))
+ (or (null (nth 1 x))
+ (and (math-vectorp (nth 1 x))
+ (= (length (nth 1 x)) 2)
+ (math-vector-is-string
+ (nth 1 x)))
+ (and (natnump (nth 1 x))
+ (<= (nth 1 x) 255))))
+ (setq cc (list
+ 'rule
+ (if (math-vectorp (nth 1 x))
+ (aref (math-vector-to-string
+ (nth 1 x) nil) 0)
+ (or (nth 1 x) ?-))))
+ (or (and (memq (car-safe x) '(calcFunc-cvspace
+ calcFunc-ctspace
+ calcFunc-cbspace))
+ (memq (length x) '(2 3))
+ (eq (nth 1 x) 0))
+ (null x)
+ (setq cc (math-compose-expr x prec))))
+ (setq a (if cc (math-comp-ascent cc) 0)
+ d (if cc (math-comp-descent cc) 0))
+ (if (eq b 'calcFunc-cbase)
+ (setq base (+ v a -1))
+ (if (eq b 'calcFunc-ctbase)
+ (setq base v)
+ (if (eq b 'calcFunc-cbbase)
+ (setq base (+ v a d -1)))))
+ (setq v (+ v a d))
+ cc))
(cdr (nth 1 a)))))
(setq c (delq nil c))
(if c
@@ -614,7 +613,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
((and (memq calc-language '(tex latex))
(memq (car a) '(/ calcFunc-choose calcFunc-evalto))
(>= prec 0))
@@ -640,7 +639,7 @@
(rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/))))
(and (equal (car op) "^")
(eq (math-comp-first-char lhs) ?-)
- (setq lhs (list 'horiz "(" lhs ")")))
+ (setq lhs (math--comp-round-bracket lhs)))
(and (memq calc-language '(tex latex))
(or (equal (car op) "^") (equal (car op) "_"))
(not (and (stringp rhs) (= (length rhs) 1)))
@@ -723,7 +722,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
(list 'horiz
@@ -761,7 +760,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
(list 'horiz
@@ -823,9 +822,16 @@
(if (setq spfn (get calc-language 'math-func-formatter))
(funcall spfn func a)
- (list 'horiz func calc-function-open
- (math-compose-vector (cdr a) ", " 0)
- calc-function-close))))))))))
+ (let ((args (math-compose-vector (cdr a) ", " 0)))
+ (if (and (member calc-function-open '("(" "[" "{"))
+ (member calc-function-close '(")" "]" "}")))
+ (list 'horiz func
+ (math--comp-bracket
+ (string-to-char calc-function-open)
+ (string-to-char calc-function-close)
+ args))
+ (list 'horiz func calc-function-open
+ args calc-function-close))))))))))))
(defun math-prod-first-term (x)
@@ -865,16 +871,15 @@
(while (<= (setq col (1+ col)) cols)
(setq res (cons (cons math-comp-just
(cons base
- (mapcar (function
- (lambda (r)
- (list 'horiz
- (math-compose-expr
- (nth col r)
- math-comp-vector-prec)
- (if (= col cols)
- ""
- (concat
- math-comp-comma-spc " ")))))
+ (mapcar (lambda (r)
+ (list 'horiz
+ (math-compose-expr
+ (nth col r)
+ math-comp-vector-prec)
+ (if (= col cols)
+ ""
+ (concat
+ math-comp-comma-spc " "))))
a)))
res)))
(nreverse res)))
@@ -923,7 +928,7 @@
( ?\^? . "\\^?" )))
(defun math-vector-to-string (a &optional quoted)
- (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
+ (setq a (concat (mapcar (lambda (x) (if (consp x) (nth 1 x) x))
(cdr a))))
(if (string-match "[\000-\037\177\\\"]" a)
(let ((p 0)
@@ -969,6 +974,69 @@
(and (memq (car a) '(^ calcFunc-subscr))
(math-tex-expr-is-flat (nth 1 a)))))
+;; FIXME: maybe try box drawing chars if big bracket chars are unavailable,
+;; like ┌ â”n
+;; │a + b│ ┌ a + b â”n
+;; │-----│ or │ ----- │ ?
+;; │ c │ └ c ┘
+;; └ ┘
+;; They are more common than the chars below, but look a bit square.
+;; Rounded corners exist but are less commonly available.
+
+(defconst math--big-bracket-alist
+ '((?\( . (?⎛ ?⎠?⎜))
+ (?\) . (?⎞ ?⎠ ?⎟))
+ (?\[ . (?⎡ ?⎣ ?⎢))
+ (?\] . (?⎤ ?⎦ ?⎥))
+ (?\{ . (?⎧ ?⎩ ?⎪ ?⎨))
+ (?\} . (?⎫ ?⎭ ?⎪ ?⎬)))
+ "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE).
+Not all brackets have midpieces.")
+
+(defun math--big-bracket (bracket-char height baseline)
+ "Composition for BRACKET-CHAR of HEIGHT with BASELINE."
+ (if (<= height 1)
+ (char-to-string bracket-char)
+ (let ((pieces (cdr (assq bracket-char math--big-bracket-alist))))
+ (if (memq nil (mapcar #'char-displayable-p pieces))
+ (char-to-string bracket-char)
+ (let* ((upper (nth 0 pieces))
+ (lower (nth 1 pieces))
+ (extension (nth 2 pieces))
+ (midpiece (nth 3 pieces)))
+ (cons 'vleft ; alignment doesn't matter; width is 1 char
+ (cons baseline
+ (mapcar
+ #'char-to-string
+ (append
+ (list upper)
+ (if midpiece
+ (let ((lower-ext (/ (- height 3) 2)))
+ (append
+ (make-list (- height 3 lower-ext) extension)
+ (list midpiece)
+ (make-list lower-ext extension)))
+ (make-list (- height 2) extension))
+ (list lower))))))))))
+
+(defun math--comp-bracket (left-bracket right-bracket comp)
+ "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET."
+ (if (eq calc-language 'big)
+ (let ((height (math-comp-height comp))
+ (baseline (1- (math-comp-ascent comp))))
+ (list 'horiz
+ (math--big-bracket left-bracket height baseline)
+ comp
+ (math--big-bracket right-bracket height baseline)))
+ (list 'horiz
+ (char-to-string left-bracket)
+ comp
+ (char-to-string right-bracket))))
+
+(defun math--comp-round-bracket (comp)
+ "Put the composition COMP inside plain brackets."
+ (math--comp-bracket ?\( ?\) comp))
+
(put 'calcFunc-log 'math-compose-big #'math-compose-log)
(defun math-compose-log (a _prec)
(and (= (length a) 3)
@@ -976,18 +1044,14 @@
(list 'subscr "log"
(let ((calc-language 'flat))
(math-compose-expr (nth 2 a) 1000)))
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-log10 'math-compose-big #'math-compose-log10)
(defun math-compose-log10 (a _prec)
(and (= (length a) 2)
(list 'horiz
- (list 'subscr "log" "10")
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (list 'subscr "log" "10")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv)
(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv)
@@ -1018,7 +1082,8 @@
(make-string (+ w 2) ?\_))
(list 'horiz
(if (= h 1)
- "V"
+ (if (char-displayable-p ?√)
+ "√" "V")
(append (list 'vleft (1- a))
(make-list (1- h) " |")
'("\\|")))
@@ -1029,12 +1094,9 @@
(defun math-compose-choose (a _prec)
(let ((a1 (math-compose-expr (nth 1 a) 0))
(a2 (math-compose-expr (nth 2 a) 0)))
- (list 'horiz
- "("
- (list 'vcent
- (math-comp-height a1)
- a1 " " a2)
- ")")))
+ (math--comp-round-bracket (list 'vcent
+ (+ (math-comp-height a1))
+ a1 " " a2))))
(put 'calcFunc-integ 'math-compose-big #'math-compose-integ)
(defun math-compose-integ (a prec)
@@ -1054,35 +1116,64 @@
"d%s"
(nth 1 (nth 2 a)))))
(nth 1 a)) 185))
- (calc-language 'flat)
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
- (list 'horiz
- (if parens "(" "")
- (append (list 'vcent (if high 3 2))
- (and high (list (list 'horiz " " high)))
- '(" /"
- " | "
- " | "
- " | "
- "/ ")
- (and low (list (list 'horiz low " "))))
- expr
- (if over
- ""
- (list 'horiz " d" var))
- (if parens ")" "")))))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 4 a) 0))))
+ ;; Check if we have Unicode integral top/bottom parts.
+ (fancy (and (char-displayable-p ?⌠)
+ (char-displayable-p ?⌡)))
+ ;; If we do, find the most suitable middle part.
+ (fancy-stem (cond ((not fancy))
+ ;; U+23AE INTEGRAL EXTENSION
+ ((char-displayable-p ?⎮) "⎮ ")
+ ;; U+2502 BOX DRAWINGS LIGHT VERTICAL
+ ((char-displayable-p ?│) "│ ")
+ ;; U+007C VERTICAL LINE
+ (t "| "))))
+ (let ((comp
+ (list 'horiz
+ (append (list 'vcent (if fancy
+ (if high 2 1)
+ (if high 3 2)))
+ (and high (list (if fancy
+ (list 'horiz high " ")
+ (list 'horiz " " high))))
+ (if fancy
+ (list "⌠ " fancy-stem "⌡ ")
+ '(" /"
+ " | "
+ " | "
+ " | "
+ "/ "))
+ (and low (list (if fancy
+ (list 'horiz low " ")
+ (list 'horiz low " ")))))
+ expr
+ (if over
+ ""
+ (list 'horiz " d" var)))))
+ (if parens
+ (math--comp-round-bracket comp)
+ comp)))))
(put 'calcFunc-sum 'math-compose-big #'math-compose-sum)
(defun math-compose-sum (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 185))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(180 201)) "(" "")
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
(append (list 'vcent (if high 3 2))
(and high (list high))
'("---- "
@@ -1095,32 +1186,42 @@
(list var)))
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
- expr
- (if (memq prec '(180 201)) ")" "")))))
+ expr)))
+ (if (memq prec '(180 201))
+ (math--comp-round-bracket comp)
+ comp))))
(put 'calcFunc-prod 'math-compose-big #'math-compose-prod)
(defun math-compose-prod (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 198))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(196 201)) "(" "")
- (append (list 'vcent (if high 3 2))
- (and high (list high))
- '("----- "
- " | | "
- " | | "
- " | | ")
- (if low
- (list (list 'horiz var " = " low))
- (list var)))
- (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
- " " "")
- expr
- (if (memq prec '(196 201)) ")" "")))))
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
+ (append (list 'vcent (if high 3 2))
+ (and high (list high))
+ '("----- "
+ " | | "
+ " | | "
+ " | | ")
+ (if low
+ (list (list 'horiz var " = " low))
+ (list var)))
+ (if (memq (car-safe (nth 1 a))
+ '(calcFunc-sum calcFunc-prod))
+ " " "")
+ expr)))
+ (if (memq prec '(196 201))
+ (math--comp-round-bracket comp)
+ comp))))
;; 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
diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el
index ad418ad7dbf..9c2ac975f0b 100644
--- a/lisp/calc/calcsel2.el
+++ b/lisp/calc/calcsel2.el
@@ -1,4 +1,4 @@
-;;; calcsel2.el --- selection functions for Calc
+;;; calcsel2.el --- selection functions for Calc -*- lexical-binding:t -*-
;; Copyright (C) 1990-1993, 2001-2021 Free Software Foundation, Inc.
@@ -34,6 +34,7 @@
;; The variable calc-sel-reselect is local to the methods below,
;; but is used by some functions in calc-sel.el which are called
;; by the functions below.
+(defvar calc-sel-reselect)
(defun calc-commute-left (arg)
(interactive "p")
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 074d750f2b0..99c9b6290c4 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -20,23 +20,18 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;;=====================================================================
;;; Commentary:
-;;
+
;; A calculator for Emacs.
;; Why should you reach for your mouse to get xcalc (calc.exe, gcalc or
;; whatever), when you have Emacs running already?
;;
-;; If this is not part of your Emacs distribution, then simply bind
-;; `calculator' to a key and make it an autoloaded function, e.g.:
-;; (autoload 'calculator "calculator"
-;; "Run the Emacs calculator." t)
+;; You can bind this to a key by adding this to your Init file:
+;;
;; (global-set-key [(control return)] 'calculator)
;;
;; Written by Eli Barzilay, eli@barzilay.org
-;;
-;;;=====================================================================
;;; Customization:
(defgroup calculator nil
@@ -50,19 +45,16 @@
"Run `calculator' electrically, in the echo area.
Electric mode saves some place but changes the way you interact with the
calculator."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-use-menu t
"Make `calculator' create a menu.
Note that this requires easymenu. Must be set before loading."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-bind-escape nil
"If non-nil, set escape to exit the calculator."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-unary-style 'postfix
"Value is either `prefix' or `postfix'.
@@ -75,44 +67,38 @@ This determines the default behavior of unary operators."
It should contain a \"%s\" somewhere that will indicate the i/o radixes;
this will be a two-character string as described in the documentation
for `calculator-mode'."
- :type 'string
- :group 'calculator)
+ :type 'string)
(defcustom calculator-number-digits 3
"The calculator's number of digits used for standard display.
Used by the `calculator-standard-display' function - it will use the
format string \"%.NC\" where this number is N and C is a character given
at runtime."
- :type 'integer
- :group 'calculator)
+ :type 'integer)
(defcustom calculator-radix-grouping-mode t
"Use digit grouping in radix output mode.
If this is set, chunks of `calculator-radix-grouping-digits' characters
will be separated by `calculator-radix-grouping-separator' when in radix
output mode is active (determined by `calculator-output-radix')."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-radix-grouping-digits 4
"The number of digits used for grouping display in radix modes.
See `calculator-radix-grouping-mode'."
- :type 'integer
- :group 'calculator)
+ :type 'integer)
(defcustom calculator-radix-grouping-separator "'"
"The separator used in radix grouping display.
See `calculator-radix-grouping-mode'."
- :type 'string
- :group 'calculator)
+ :type 'string)
(defcustom calculator-remove-zeros t
"Non-nil value means delete all redundant zero decimal digits.
If this value is not t and not nil, redundant zeros are removed except
for one.
Used by the `calculator-remove-zeros' function."
- :type '(choice (const t) (const leave-decimal) (const nil))
- :group 'calculator)
+ :type '(choice (const t) (const leave-decimal) (const nil)))
(defcustom calculator-displayer '(std ?n)
"A displayer specification for numerical values.
@@ -135,8 +121,7 @@ a character and G is an optional boolean, in this case the
arguments."
:type '(choice (function) (string) (sexp)
(list (const std) character)
- (list (const std) character boolean))
- :group 'calculator)
+ (list (const std) character boolean)))
(defcustom calculator-displayers
'(((std ?n) "Standard display, decimal point or scientific")
@@ -152,15 +137,13 @@ specification is the same as the values that can be stored in
`calculator-displayer'.
`calculator-rotate-displayer' rotates this list."
- :type 'sexp
- :group 'calculator)
+ :type 'sexp)
(defcustom calculator-paste-decimals t
"If non-nil, convert pasted integers so they have a decimal point.
This makes it possible to paste big integers since they will be read as
floats, otherwise the Emacs reader will fail on them."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(make-obsolete-variable 'calculator-paste-decimals
"it is no longer used." "26.1")
@@ -169,14 +152,12 @@ floats, otherwise the Emacs reader will fail on them."
`calculator-displayer', to format a string before copying it with
`calculator-copy'. If nil, then `calculator-displayer's normal value is
used."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-2s-complement nil
"If non-nil, show negative numbers in 2s complement in radix modes.
Otherwise show as a negative number."
- :type 'boolean
- :group 'calculator)
+ :type 'boolean)
(defcustom calculator-mode-hook nil
"List of hook functions for `calculator-mode' to run.
@@ -184,8 +165,7 @@ Note: if `calculator-electric-mode' is on, then this hook will get
activated in the minibuffer -- in that case it should not do much more
than local key settings and other effects that will change things
outside the scope of calculator related code."
- :type 'hook
- :group 'calculator)
+ :type 'hook)
(defcustom calculator-user-registers nil
"An association list of user-defined register bindings.
@@ -200,8 +180,7 @@ before you load calculator."
(when (boundp 'calculator-registers)
(setq calculator-registers
(append val calculator-registers)))
- (setq calculator-user-registers val))
- :group 'calculator)
+ (setq calculator-user-registers val)))
(defcustom calculator-user-operators nil
"A list of additional operators.
@@ -234,8 +213,7 @@ Examples:
Note that this will be either postfix or prefix, according to
`calculator-unary-style'."
- :type '(repeat (list string symbol sexp integer integer))
- :group 'calculator)
+ :type '(repeat (list string symbol sexp integer integer)))
;;;=====================================================================
;;; Code:
@@ -313,7 +291,7 @@ user-defined operators, use `calculator-user-operators' instead.")
5. The function's precedence -- should be in the range of 1 (lowest) to
9 (highest) (optional, defaults to 1);
-It it possible have a unary prefix version of a binary operator if it
+It is possible have a unary prefix version of a binary operator if it
comes later in this list. If the list begins with the symbol `nobind',
then no key binding will take place -- this is only used for predefined
keys.
@@ -860,11 +838,10 @@ The result should not exceed the screen width."
(if calculator-input-radix
(string-to-number str (cadr (assq calculator-input-radix
'((bin 2) (oct 8) (hex 16)))))
- (let* ((str (replace-regexp-in-string
- "\\.\\([^0-9].*\\)?$" ".0\\1" str))
- (str (replace-regexp-in-string
- "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str)))
- (string-to-number str))))
+ ;; parse numbers similarly to calculators
+ ;; (see tests in test/lisp/calculator-tests.el)
+ (let ((str (replace-regexp-in-string "\\.\\([^0-9].*\\)?$" ".0\\1" str)))
+ (float (string-to-number str)))))
(defun calculator-push-curnum ()
"Push the numeric value of the displayed number to the stack."
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 46174ec1750..350b7e51cb1 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -1,4 +1,4 @@
-;;; cal-bahai.el --- calendar functions for the Bahá’í calendar.
+;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -27,7 +27,7 @@
;; This collection of functions implements the features of calendar.el
;; and diary-lib.el that deal with the Bahá’í calendar.
-;; The Bahá’í (http://www.bahai.org) calendar system is based on a
+;; The Bahá’í (https://www.bahai.org) calendar system is based on a
;; solar cycle of 19 months with 19 days each. The four remaining
;; "intercalary" days are called the Ayyám-i-Há (days of Há), and are
;; placed between the 18th and 19th months. They are meant as a time
@@ -57,8 +57,8 @@
(defconst calendar-bahai-month-name-array
["Bahá" "Jalál" "Jamál" "‘Aẓamat" "Núr" "Raḥmat" "Kalimát" "Kamál"
- "Asmá’" "‘Izzat" "Mashíyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il"
- "Sharaf" "Sulṭán" "Mulk" "‘Alá’"]
+ "Asmá’" "‘Izzat" "Mas͟híyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il"
+ "S͟haraf" "Sulṭán" "Mulk" "‘Alá’"]
"Array of the month names in the Bahá’í calendar.")
(defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
@@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given."
(y (calendar-extract-year bahai-date)))
(if (< y 1)
"" ; pre-Bahai
- (let* ((m (calendar-extract-month bahai-date))
- (d (calendar-extract-day bahai-date))
- (monthname (if (and (= m 19)
+ (let ((m (calendar-extract-month bahai-date))
+ (d (calendar-extract-day bahai-date)))
+ (calendar-dlet
+ ((monthname (if (and (= m 19)
(<= d 0))
"Ayyám-i-Há"
(aref calendar-bahai-month-name-array (1- m))))
@@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given."
(year (number-to-string y))
(month (number-to-string m))
dayname)
- ;; Can't call calendar-date-string because of monthname oddity.
- (mapconcat 'eval calendar-date-display-form "")))))
+ ;; Can't call calendar-date-string because of monthname oddity.
+ (mapconcat #'eval calendar-date-display-form ""))))))
;;;###cal-autoload
(defun calendar-bahai-print-date ()
@@ -153,13 +154,12 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Bahá’í date command.
Reads a year, month and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Bahá’í calendar year (not 0): "
+ (year (calendar-read-sexp
+ "Bahá’í calendar year (not 0)"
(lambda (x) (not (zerop x)))
- (number-to-string
- (calendar-extract-year
- (calendar-bahai-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@@ -169,8 +169,8 @@ Reads a year, month and day."
nil t)
(calendar-make-alist calendar-bahai-month-name-array
1))))
- (day (calendar-read "Bahá’í calendar day (1-19): "
- (lambda (x) (and (< 0 x) (<= x 19))))))
+ (day (calendar-read-sexp "Bahá’í calendar day (1-19)"
+ (lambda (x) (and (< 0 x) (<= x 19))))))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index 7e5d0c46e11..9a28984a7ab 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -1,4 +1,4 @@
-;;; cal-china.el --- calendar functions for the Chinese calendar
+;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name,
(defun calendar-chinese-zodiac-sign-on-or-after (d)
"Absolute date of first new Zodiac sign on or after absolute date D.
The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
- (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
+ (with-suppressed-warnings ((lexical year))
+ (defvar year))
+ (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
(calendar-daylight-time-offset
calendar-chinese-daylight-time-offset)
@@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
(defun calendar-chinese-new-moon-on-or-after (d)
"Absolute date of first new moon on or after absolute date D."
+ (with-suppressed-warnings ((lexical year))
+ (defvar year))
(let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone))
(calendar-daylight-time-offset
@@ -602,14 +606,14 @@ Echo Chinese date unless NOECHO is non-nil."
(interactive
(let* ((c (calendar-chinese-from-absolute
(calendar-absolute-from-gregorian (calendar-current-date))))
- (cycle (calendar-read
- "Chinese calendar cycle number (>44): "
+ (cycle (calendar-read-sexp
+ "Chinese calendar cycle number (>44)"
(lambda (x) (> x 44))
- (number-to-string (car c))))
- (year (calendar-read
- "Year in Chinese cycle (1..60): "
+ (car c)))
+ (year (calendar-read-sexp
+ "Year in Chinese cycle (1..60)"
(lambda (x) (and (<= 1 x) (<= x 60)))
- (number-to-string (cadr c))))
+ (cadr c)))
(month-list (calendar-chinese-months-to-alist
(calendar-chinese-months cycle year)))
(month (cdr (assoc
@@ -624,9 +628,11 @@ Echo Chinese date unless NOECHO is non-nil."
(list cycle year month 1))))))
30
29))
- (day (calendar-read
- (format "Chinese calendar day (1-%d): " last)
- (lambda (x) (and (<= 1 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Chinese calendar day (1-%d)"
+ (lambda (x) (and (<= 1 x) (<= x last)))
+ nil
+ last)))
(list (list cycle year month day))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-chinese-to-absolute date)))
@@ -663,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil."
["正月" "二月" "三月" "四月" "五月" "六月"
"七月" "八月" "乿œˆ" "åæœˆ" "冬月" "臘月"])
-;;; NOTE: In the diary the cycle and year of a Chinese date is
-;;; combined using this formula: (+ (* cycle 100) year).
+;; NOTE: In the diary the cycle and year of a Chinese date is
+;; combined using this formula: (+ (* cycle 100) year).
;;;
-;;; These two functions convert to and back from this representation.
-(defun calendar-chinese-from-absolute-for-diary (date)
- (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date)))
+;; These two functions convert to and back from this representation.
+(defun calendar-chinese-from-absolute-for-diary (thedate)
+ (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate)))
;; Note: For leap months M is a float.
(list (floor m) d (+ (* c 100) y))))
-(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap)
- (pcase-let* ((`(,m ,d ,y) date)
+(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap)
+ (pcase-let* ((`(,m ,d ,y) thedate)
(cycle (floor y 100))
(year (mod y 100))
(months (calendar-chinese-months cycle year))
@@ -691,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil."
(unless (zerop month)
(calendar-mark-1 month day year
#'calendar-chinese-from-absolute-for-diary
- (lambda (date) (calendar-chinese-to-absolute-for-diary date t))
+ (lambda (thedate)
+ (calendar-chinese-to-absolute-for-diary thedate t))
color)))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el
index 3461f3259b9..11785c48f10 100644
--- a/lisp/calendar/cal-coptic.el
+++ b/lisp/calendar/cal-coptic.el
@@ -1,4 +1,4 @@
-;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
+;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given."
(m (calendar-extract-month coptic-date)))
(if (< y 1)
""
- (let ((monthname (aref calendar-coptic-month-name-array (1- m)))
- (day (number-to-string (calendar-extract-day coptic-date)))
- (dayname nil)
- (month (number-to-string m))
- (year (number-to-string y)))
- (mapconcat 'eval calendar-date-display-form "")))))
+ (calendar-dlet
+ ((monthname (aref calendar-coptic-month-name-array (1- m)))
+ (day (number-to-string (calendar-extract-day coptic-date)))
+ (dayname nil)
+ (month (number-to-string m))
+ (year (number-to-string y)))
+ (mapconcat #'eval calendar-date-display-form "")))))
;;;###cal-autoload
(defun calendar-coptic-print-date ()
@@ -136,13 +137,13 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Coptic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- (format "%s calendar year (>0): " calendar-coptic-name)
+ (year (calendar-read-sexp
+ "%s calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-coptic-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-coptic-from-absolute
+ (calendar-absolute-from-gregorian today)))
+ calendar-coptic-name))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
@@ -151,11 +152,14 @@ Reads a year, month, and day."
(append calendar-coptic-month-name-array nil))
nil t)
(calendar-make-alist calendar-coptic-month-name-array
- 1) t)))
+ 1)
+ t)))
(last (calendar-coptic-last-day-of-month month year))
- (day (calendar-read
- (format "%s calendar day (1-%d): " calendar-coptic-name last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "%s calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ calendar-coptic-name last)))
(list (list month day year))))
;;;###cal-autoload
@@ -194,30 +198,30 @@ Echo Coptic date unless NOECHO is t."
(defconst calendar-ethiopic-name "Ethiopic"
"Used in some message strings.")
-(defun calendar-ethiopic-to-absolute (date)
+(defun calendar-ethiopic-to-absolute (thedate)
"Compute absolute date from Ethiopic date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
- (calendar-coptic-to-absolute date)))
+ (calendar-coptic-to-absolute thedate)))
-(defun calendar-ethiopic-from-absolute (date)
+(defun calendar-ethiopic-from-absolute (thedate)
"Compute the Ethiopic equivalent for absolute date DATE.
The result is a list of the form (MONTH DAY YEAR).
The absolute date is the number of days elapsed since the imaginary
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
- (calendar-coptic-from-absolute date)))
+ (calendar-coptic-from-absolute thedate)))
;;;###cal-autoload
-(defun calendar-ethiopic-date-string (&optional date)
+(defun calendar-ethiopic-date-string (&optional thedate)
"String of Ethiopic date of Gregorian DATE.
Returns the empty string if DATE is pre-Ethiopic calendar.
Defaults to today's date if DATE is not given."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
(calendar-coptic-name calendar-ethiopic-name)
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
- (calendar-coptic-date-string date)))
+ (calendar-coptic-date-string thedate)))
;;;###cal-autoload
(defun calendar-ethiopic-print-date ()
@@ -229,8 +233,8 @@ Defaults to today's date if DATE is not given."
(call-interactively 'calendar-coptic-print-date)))
;;;###cal-autoload
-(defun calendar-ethiopic-goto-date (date &optional noecho)
- "Move cursor to Ethiopic date DATE.
+(defun calendar-ethiopic-goto-date (thedate &optional noecho)
+ "Move cursor to Ethiopic date THEDATE.
Echo Ethiopic date unless NOECHO is t."
(interactive
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
@@ -238,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t."
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
(calendar-coptic-read-date)))
(calendar-goto-date (calendar-gregorian-from-absolute
- (calendar-ethiopic-to-absolute date)))
+ (calendar-ethiopic-to-absolute thedate)))
(or noecho (calendar-ethiopic-print-date)))
;; To be called from diary-list-sexp-entries, where DATE is bound.
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index 0fcb387b02c..29864110a3e 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -200,7 +200,7 @@ The result has the proper form for `calendar-daylight-savings-starts'."
(calendar-persian-to-absolute `(7 1 ,(- year 621))))))))
(prevday-sec (- -1 utc-diff)) ; last sec of previous local day
new-rules)
- (calendar-dlet* ((year (1+ y)))
+ (calendar-dlet ((year (1+ y)))
;; Scan through the next few years until only one rule remains.
(while (cdr candidate-rules)
(dolist (rule candidate-rules)
@@ -350,17 +350,31 @@ If the locale never uses daylight saving time, set this to 0."
:group 'calendar-dst)
(defcustom calendar-standard-time-zone-name
- (or (nth 2 calendar-current-time-zone-cache) "EST")
+ (if (eq calendar-time-zone-style 'numeric)
+ (if calendar-current-time-zone-cache
+ (format-time-string
+ "%z" 0 (* 60 (car calendar-current-time-zone-cache)))
+ "+0000")
+ (or (nth 2 calendar-current-time-zone-cache) "EST"))
"Abbreviated name of standard time zone at `calendar-location-name'.
For example, \"EST\" in New York City, \"PST\" for Los Angeles."
:type 'string
+ :version "28.1"
+ :set-after '(calendar-time-zone-style)
:group 'calendar-dst)
(defcustom calendar-daylight-time-zone-name
- (or (nth 3 calendar-current-time-zone-cache) "EDT")
+ (if (eq calendar-time-zone-style 'numeric)
+ (if calendar-current-time-zone-cache
+ (format-time-string
+ "%z" 0 (* 60 (cadr calendar-current-time-zone-cache)))
+ "+0000")
+ (or (nth 3 calendar-current-time-zone-cache) "EDT"))
"Abbreviated name of daylight saving time zone at `calendar-location-name'.
For example, \"EDT\" in New York City, \"PDT\" for Los Angeles."
:type 'string
+ :version "28.1"
+ :set-after '(calendar-time-zone-style)
:group 'calendar-dst)
(defcustom calendar-daylight-savings-starts-time
@@ -383,7 +397,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(or (let ((expr (if calendar-dst-check-each-year-flag
(cadr (calendar-dst-find-startend year))
(nth 4 calendar-current-time-zone-cache))))
- (calendar-dlet* ((year year))
+ (calendar-dlet ((year year))
(if expr (eval expr))))
;; New US rules commencing 2007. https://www.iana.org/time-zones
(and (not (zerop calendar-daylight-time-offset))
@@ -395,7 +409,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(or (let ((expr (if calendar-dst-check-each-year-flag
(nth 2 (calendar-dst-find-startend year))
(nth 5 calendar-current-time-zone-cache))))
- (calendar-dlet* ((year year))
+ (calendar-dlet ((year year))
(if expr (eval expr))))
;; New US rules commencing 2007. https://www.iana.org/time-zones
(and (not (zerop calendar-daylight-time-offset))
@@ -405,7 +419,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(defun dst-in-effect (date)
"True if on absolute DATE daylight saving time is in effect.
Fractional part of DATE is local standard time of day."
- (calendar-dlet* ((year (calendar-extract-year
+ (calendar-dlet ((year (calendar-extract-year
(calendar-gregorian-from-absolute (floor date)))))
(let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts))
(dst-ends-gregorian (eval calendar-daylight-savings-ends))
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index e759b5dad95..1789f16445f 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -1,4 +1,4 @@
-;;; cal-french.el --- calendar functions for the French Revolutionary calendar
+;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free
;; Software Foundation, Inc.
@@ -35,54 +35,194 @@
(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
"Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
-(defconst calendar-french-month-name-array
- ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
- "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
- "Array of month names in the French calendar.")
+(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array
+ 'calendar-french-month-name-array "28.1")
-(defconst calendar-french-multibyte-month-name-array
+(defconst calendar-french-month-name-array
["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.")
+ "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"
+ "jour complémentaire"]
+ "Array of month names in the French calendar.")
(defconst calendar-french-day-name-array
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
- "Octidi" "Nonidi" "Decadi"]
+ "Octidi" "Nonidi" "Décadi"]
"Array of day names in the French calendar.")
-(defconst calendar-french-special-days-array
- ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
- "de la Re'volution"]
- "Array of special day names in the French calendar.")
+(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array
+ 'calendar-french-special-days-array "28.1")
-(defconst calendar-french-multibyte-special-days-array
+(defconst calendar-french-special-days-array
["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.")
+ "Array of special day names in the French calendar.")
+
+(defconst calendar-french-feasts-array
+ [;; Vendémiaire
+ "du Raisin" "du Safran" "de la Châtaigne"
+ "de la Colchique" "du Cheval" "de la Balsamine"
+ "de la Carotte" "de l'Amarante" "du Panais"
+ "de la Cuve" "de la Pomme de terre" "de l'Immortelle"
+ "du Potiron" "du Réséda" "de l'Âne"
+ "de la Belle de nuit" "de la Citrouille" "du Sarrasin"
+ "du Tournesol" "du Pressoir" "du Chanvre"
+ "de la Pêche" "du Navet" "de l'Amaryllis"
+ "du Bœuf" "de l'Aubergine" "du Piment"
+ "de la Tomate" "de l'Orge" "du Tonneau"
+ ;; Brumaire
+ "de la Pomme" "du Céleri" "de la Poire"
+ "de la Betterave" "de l'Oie" "de l'Héliotrope"
+ "de la Figue" "de la Scorsonère" "de l'Alisier"
+ "de la Charrue" "du Salsifis" "de la Macre"
+ "du Topinambour" "de l'Endive" "du Dindon"
+ "du Chervis" "du Cresson" "de la Dentelaire"
+ "de la Grenade" "de la Herse" "de la Bacchante"
+ "de l'Azerole" "de la Garance" "de l'Orange"
+ "du Faisan" "de la Pistache" "du Macjon"
+ "du Coing" "du Cormier" "du Rouleau"
+ ;; Frimaire
+ "de la Raiponce" "du Turneps" "de la Chicorée"
+ "de la Nèfle" "du Cochon" "de la Mâche"
+ "du Chou-fleur" "du Miel" "du Genièvre"
+ "de la Pioche" "de la Cire" "du Raifort"
+ "du Cèdre" "du Sapin" "du Chevreuil"
+ "de l'Ajonc" "du Cyprès" "du Lierre"
+ "de la Sabine" "du Hoyau" "de l'Érable-sucre"
+ "de la Bruyère" "du Roseau" "de l'Oseille"
+ "du Grillon" "du Pignon" "du Liège"
+ "de la Truffe" "de l'Olive" "de la Pelle"
+ ;; Nivôse
+ "de la Tourbe" "de la Houille" "du Bitume"
+ "du Soufre" "du Chien" "de la Lave"
+ "de la Terre végétale" "du Fumier" "du Salpêtre"
+ "du Fléau" "du Granit" "de l'Argile"
+ "de l'Ardoise" "du Grès" "du Lapin"
+ "du Silex" "de la Marne" "de la Pierre à chaux"
+ "du Marbre" "du Van" "de la Pierre à plâtre"
+ "du Sel" "du Fer" "du Cuivre"
+ "du Chat" "de l'Étain" "du Plomb"
+ "du Zinc" "du Mercure" "du Crible"
+ ;; Pluviôse
+ "de la Lauréole" "de la Mousse" "du Fragon"
+ "du Perce-neige" "du Taureau" "du Laurier-thym"
+ "de l'Amadouvier" "du Mézéréon" "du Peuplier"
+ "de la Cognée" "de l'Ellébore" "du Brocoli"
+ "du Laurier" "de l'Avelinier" "de la Vache"
+ "du Buis" "du Lichen" "de l'If"
+ "de la Pulmonaire" "de la Serpette" "du Thlaspi"
+ "du Thymelé" "du Chiendent" "de la Traînasse"
+ "du Lièvre" "de la Guède" "du Noisetier"
+ "du Cyclamen" "de la Chélidoine" "du Traîneau"
+ ;; Ventôse
+ "du Tussilage" "du Cornouiller" "du Violier"
+ "du Troène" "du Bouc" "de l'Asaret"
+ "de l'Alaterne" "de la Violette" "du Marsault"
+ "de la Bêche" "du Narcisse" "de l'Orme"
+ "de la Fumeterre" "du Vélar" "de la Chèvre"
+ "de l'Épinard" "du Doronic" "du Mouron"
+ "du Cerfeuil" "du Cordeau" "de la Mandragore"
+ "du Persil" "du Cochléaria" "de la Pâquerette"
+ "du Thon" "du Pissenlit" "de la Sylvie"
+ "du Capillaire" "du Frêne" "du Plantoir"
+ ;; Germinal
+ "de la Primevère" "du Platane" "de l'Asperge"
+ "de la Tulipe" "de la Poule" "de la Blette"
+ "du Bouleau" "de la Jonquille" "de l'Aulne"
+ "du Couvoir" "de la Pervenche" "du Charme"
+ "de la Morille" "du Hêtre" "de l'Abeille"
+ "de la Laitue" "du Mélèze" "de la Ciguë"
+ "du Radis" "de la Ruche" "du Gainier"
+ "de la Romaine" "du Marronnier" "de la Roquette"
+ "du Pigeon" "du Lilas" "de l'Anémone"
+ "de la Pensée" "de la Myrtille" "du Greffoir"
+ ;; Floréal
+ "de la Rose" "du Chêne" "de la Fougère"
+ "de l'Aubépine" "du Rossignol" "de l'Ancolie"
+ "du Muguet" "du Champignon" "de la Jacinthe"
+ "du Rateau" "de la Rhubarbe" "du Sainfoin"
+ "du Bâton-d'or" "du Chamérisier" "du Ver à soie"
+ "de la Consoude" "de la Pimprenelle" "de la Corbeille-d'or"
+ "de l'Arroche" "du Sarcloir" "du Statice"
+ "de la Fritillaire" "de la Bourrache" "de la Valériane"
+ "de la Carpe" "du Fusain" "de la Civette"
+ "de la Buglosse" "du Sénevé" "de la Houlette"
+ ;; Prairial
+ "de la Luzerne" "de l'Hémérocalle" "du Trèfle"
+ "de l'Angélique" "du Canard" "de la Mélisse"
+ "du Fromental" "du Martagon" "du Serpolet"
+ "de la Faux" "de la Fraise" "de la Bétoine"
+ "du Pois" "de l'Acacia" "de la Caille"
+ "de l'Å’illet" "du Sureau" "du Pavot"
+ "du Tilleul" "de la Fourche" "du Barbeau"
+ "de la Camomille" "du Chèvrefeuille" "du Caille-lait"
+ "de la Tanche" "du Jasmin" "de la Verveine"
+ "du Thym" "de la Pivoine" "du Chariot"
+ ;; Messidor
+ "du Seigle" "de l'Avoine" "de l'Oignon"
+ "de la Véronique" "du Mulet" "du Romarin"
+ "du Concombre" "de l'Échalotte" "de l'Absinthe"
+ "de la Faucille" "de la Coriandre" "de l'Artichaut"
+ "de la Giroflée" "de la Lavande" "du Chamois"
+ "du Tabac" "de la Groseille" "de la Gesse"
+ "de la Cerise" "du Parc" "de la Menthe"
+ "du Cumin" "du Haricot" "de l'Orcanète"
+ "de la Pintade" "de la Sauge" "de l'Ail"
+ "de la Vesce" "du Blé" "de la Chalémie"
+ ;; Thermidor
+ "de l'Épautre" "du Bouillon-blanc" "du Melon"
+ "de l'Ivraie" "du Bélier" "de la Prèle"
+ "de l'Armoise" "du Carthame" "de la Mûre"
+ "de l'Arrosoir" "du Panis" "du Salicor"
+ "de l'Abricot" "du Basilic" "de la Brebis"
+ "de la Guimauve" "du Lin" "de l'Amande"
+ "de la Gentiane" "de l'Écluse" "de la Carline"
+ "du Câprier" "de la Lentille" "de l'Aunée"
+ "de la Loutre" "de la Myrte" "du Colza"
+ "du Lupin" "du Coton" "du Moulin"
+ ;; Fructidor
+ "de la Prune" "du Millet" "du Lycoperdon"
+ "de l'Escourgeon" "du Saumon" "de la Tubéreuse"
+ "du Sucrion" "de l'Apocyn" "de la Réglisse"
+ "de l'Échelle" "de la Pastèque" "du Fenouil"
+ "de l'Épine-vinette" "de la Noix" "de la Truite"
+ "du Citron" "de la Cardère" "du Nerprun"
+ "du Tagette" "de la Hotte" "de l'Églantier"
+ "de la Noisette" "du Houblon" "du Sorgho"
+ "de l'Écrevisse" "de la Bagarade" "de la Verge-d'or"
+ "du Maïs" "du Marron" "du Panier"
+ ;; jour complémentaire
+ "de la Vertu" "du Génie" "du Travail"
+ "de la Raison" "des Récompenses" "de la Révolution"]
+ "Array of day feasts in the French calendar.")
(defun calendar-french-accents-p ()
- "Return non-nil if diacritical marks are available."
- (and (or window-system
- (terminal-coding-system))
- (or enable-multibyte-characters
- (and (char-table-p standard-display-table)
- (equal (aref standard-display-table 161) [161])))))
+ (declare (obsolete nil "28.1"))
+ t)
(defun calendar-french-month-name-array ()
"Return the array of month names, depending on whether accents are available."
- (if (calendar-french-accents-p)
- calendar-french-multibyte-month-name-array
- calendar-french-month-name-array))
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
+ calendar-french-month-name-array)
(defun calendar-french-day-name-array ()
"Return the array of day names."
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-day-name-array)
(defun calendar-french-special-days-array ()
"Return the special day names, depending on whether accents are available."
- (if (calendar-french-accents-p)
- calendar-french-multibyte-special-days-array
- calendar-french-special-days-array))
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
+ calendar-french-special-days-array)
+
+(defun calendar-french-trim-feast (feast)
+ "Remove the article from the FEAST.
+E.g. \"du Raisin\" -> \"Raisin\" or \"de la Vertu\" -> \"Vertu\"."
+ (cond
+ ((equal (substring feast 0 3) "du ") (substring feast 3))
+ ((equal (substring feast 0 6) "de la ") (substring feast 6))
+ ((equal (substring feast 0 5) "de l'") (substring feast 5))
+ ((equal (substring feast 0 4) "des ") (substring feast 4))
+ (t feast)))
(defun calendar-french-leap-year-p (year)
"True if YEAR is a leap year on the French Revolutionary calendar.
@@ -171,18 +311,13 @@ Defaults to today's date if DATE is not given."
(d (calendar-extract-day french-date)))
(cond
((< y 1) "")
- ((= m 13) (format (if (calendar-french-accents-p)
- "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 Révolution"
- "%d %s an %d de la Re'volution")
+ "%s %d %s an %d de la Révolution, jour %s"
+ (aref calendar-french-day-name-array (% (1- d) 10))
d
- (aref (calendar-french-month-name-array) (1- m))
- y)))))
+ (aref calendar-french-month-name-array (1- m))
+ y
+ (aref calendar-french-feasts-array (+ -31 (* 30 m) d)))))))
;;;###cal-autoload
(defun calendar-french-print-date ()
@@ -198,46 +333,45 @@ Defaults to today's date if DATE is not given."
"Move cursor to French Revolutionary date DATE.
Echo French Revolutionary date unless NOECHO is non-nil."
(interactive
- (let* ((months (calendar-french-month-name-array))
- (special-days (calendar-french-special-days-array))
+ (let* ((months calendar-french-month-name-array)
+ (feasts calendar-french-feasts-array)
(year (progn
- (calendar-read
- (if (calendar-french-accents-p)
- "Année de la Révolution (>0): "
- "Anne'e de la Re'volution (>0): ")
+ (calendar-read-sexp
+ "Année de la Révolution (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-french-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date))))))))
+ (calendar-extract-year
+ (calendar-french-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))))))
(month-list
(mapcar 'list
(append months
(if (calendar-french-leap-year-p year)
- (mapcar
- (lambda (x) (concat "Jour " x))
- calendar-french-special-days-array)
+ (mapcar #'calendar-french-trim-feast feasts)
(reverse
(cdr ; we don't want rev. day in a non-leap yr
(reverse
- (mapcar
- (lambda (x)
- (concat "Jour " x))
- special-days))))))))
+ (mapcar #'calendar-french-trim-feast
+ feasts))))))))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
- "Mois ou Sansculottide: "
+ "Mois ou \"jour complémentaire\" ou fête: "
month-list
nil t)
(calendar-make-alist month-list 1 'car) t)))
- (day (if (> month 12)
- (- month 12)
- (calendar-read
- "Jour (1-30): "
- (lambda (x) (and (<= 1 x) (<= x 30))))))
- (month (if (> month 12) 13 month)))
+ (last-day (calendar-french-last-day-of-month (min month 13) year))
+ (day (if (> month 13)
+ (- month 13)
+ (calendar-read-sexp
+ (format "Jour (1-%d): " last-day)
+ (lambda (x) (<= 1 x last-day)))))
+ ;; All days in Vendémiaire and numbered 1 to 365 e.g., "Pomme"
+ ;; gives 31 Vendémiaire automatically normalized to 1 Brumaire
+ ;; "Céleri" gives 32 Vnd normalized to 2 Bru, "Raiponce" gives
+ ;; 61 Vnd normalized to 1 Frimaire, etc until "Récompences" which
+ ;; gives 365 Vnd normalized to 5 jour complémentaire.
+ (month (if (> month 13) 1 month)))
(list (list month day year))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-french-to-absolute date)))
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index bcc80f0877b..50b4fc363bb 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -1,4 +1,4 @@
-;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
+;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for a Hebrew date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Hebrew calendar year (>3760): "
+ (year (calendar-read-sexp
+ "Hebrew calendar year (>3760)"
(lambda (x) (> x 3760))
- (number-to-string
- (calendar-extract-year
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-hebrew-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(month-array (if (calendar-hebrew-leap-year-p year)
calendar-hebrew-month-name-array-leap-year
calendar-hebrew-month-name-array-common-year))
@@ -258,10 +257,11 @@ Reads a year, month, and day."
(last (calendar-hebrew-last-day-of-month month year))
(first (if (and (= year 3761) (= month 10))
18 1))
- (day (calendar-read
- (format "Hebrew calendar day (%d-%d): "
- first last)
- (lambda (x) (and (<= first x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Hebrew calendar day (%d-%d)"
+ (lambda (x) (and (<= first x) (<= x last)))
+ nil
+ first last)))
(list (list month day year))))
;;;###cal-autoload
@@ -399,19 +399,20 @@ is non-nil."
(list m (calendar-last-day-of-month m y) y))))))
(abs-h (calendar-hebrew-to-absolute (list 9 25 h-y)))
(ord ["first" "second" "third" "fourth" "fifth" "sixth"
- "seventh" "eighth"])
- han)
+ "seventh" "eighth"]))
(holiday-filter-visible-calendar
(if (or all calendar-hebrew-all-holidays-flag)
(append
(list
(list (calendar-gregorian-from-absolute (1- abs-h))
"Erev Hanukkah"))
- (dotimes (i 8 (nreverse han))
- (push (list
- (calendar-gregorian-from-absolute (+ abs-h i))
- (format "Hanukkah (%s day)" (aref ord i)))
- han)))
+ (let (han)
+ (dotimes (i 8)
+ (push (list
+ (calendar-gregorian-from-absolute (+ abs-h i))
+ (format "Hanukkah (%s day)" (aref ord i)))
+ han))
+ (nreverse han)))
(list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah")))))))
;;;###holiday-autoload
@@ -681,10 +682,10 @@ from the cursor position."
(if (equal (current-buffer) (get-buffer calendar-buffer))
(calendar-cursor-to-date t)
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Year of death (>0): "
+ (year (calendar-read-sexp
+ "Year of death (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year today))))
+ (calendar-extract-year today)))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -694,20 +695,23 @@ from the cursor position."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-last-day-of-month month year))
- (day (calendar-read
- (format "Day of death (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Day of death (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list month day year))))
(death-year (calendar-extract-year death-date))
- (start-year (calendar-read
- (format "Starting year of Yahrzeit table (>%d): "
- death-year)
+ (start-year (calendar-read-sexp
+ "Starting year of Yahrzeit table (>%d)"
(lambda (x) (> x death-year))
- (number-to-string (1+ death-year))))
- (end-year (calendar-read
- (format "Ending year of Yahrzeit table (>=%d): "
- start-year)
- (lambda (x) (>= x start-year)))))
+ (1+ death-year)
+ death-year))
+ (end-year (calendar-read-sexp
+ "Ending year of Yahrzeit table (>=%d)"
+ (lambda (x) (>= x start-year))
+ nil
+ start-year)))
(list death-date start-year end-year)))
(message "Computing Yahrzeits...")
(let* ((h-date (calendar-hebrew-from-absolute
diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el
index 3d7cc938437..e5810c3f027 100644
--- a/lisp/calendar/cal-html.el
+++ b/lisp/calendar/cal-html.el
@@ -1,4 +1,4 @@
-;;; cal-html.el --- functions for printing HTML calendars
+;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical."
calendar-week-start-day))
7))
(monthpage-name (cal-html-monthpage-name month year))
- date)
+ ) ;; date
;; Start writing table.
(insert (cal-html-comment "MINICAL")
(cal-html-b-table "class=minical border=1 align=center"))
@@ -276,7 +276,7 @@ Contains links to previous and next month and year, and current minical."
(insert cal-html-e-tablerow-string
cal-html-b-tablerow-string)))
;; End empty slots (for some browsers like konqueror).
- (dotimes (i end-blank-days)
+ (dotimes (_ end-blank-days)
(insert
cal-html-b-tabledata-string
cal-html-e-tabledata-string)))
@@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST."
;;; User commands.
;;;###cal-autoload
-(defun cal-html-cursor-month (month year dir &optional event)
+(defun cal-html-cursor-month (month year dir &optional _event)
"Write an HTML calendar file for numeric MONTH of four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
-MONTH and YEAR are taken from the calendar cursor position, or from
-the position specified by EVENT. Note that any existing output files
-are overwritten."
+MONTH and YEAR are taken from the calendar cursor position.
+Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(date (calendar-cursor-to-date t event))
(month (calendar-extract-month date))
@@ -446,11 +445,11 @@ are overwritten."
(cal-html-one-month month year dir))
;;;###cal-autoload
-(defun cal-html-cursor-year (year dir &optional event)
+(defun cal-html-cursor-year (year dir &optional _event)
"Write HTML calendar files (index and monthly pages) for four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
-YEAR is taken from the calendar cursor position, or from the position
-specified by EVENT. Note that any existing output files are overwritten."
+YEAR is taken from the calendar cursor position.
+Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(year (calendar-extract-year
(calendar-cursor-to-date t event))))
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el
index d256310ba6c..45c6ffa7bd7 100644
--- a/lisp/calendar/cal-islam.el
+++ b/lisp/calendar/cal-islam.el
@@ -1,4 +1,4 @@
-;;; cal-islam.el --- calendar functions for the Islamic calendar
+;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -67,8 +67,8 @@
"Absolute date of Islamic DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
- (let* ((month (calendar-extract-month date))
- (day (calendar-extract-day date))
+ (let* (;;(month (calendar-extract-month date))
+ ;;(day (calendar-extract-day date))
(year (calendar-extract-year date))
(y (% year 30))
(leap-years-in-cycle (cond ((< y 3) 0)
@@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for an Islamic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Islamic calendar year (>0): "
+ (year (calendar-read-sexp
+ "Islamic calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(month-array calendar-islamic-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -159,9 +158,11 @@ Reads a year, month, and day."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-islamic-last-day-of-month month year))
- (day (calendar-read
- (format "Islamic calendar day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Islamic calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index 956433e4a20..90f57c25e9d 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -1,4 +1,4 @@
-;;; cal-iso.el --- calendar functions for the ISO calendar
+;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC."
"Interactively read the arguments for an ISO date command.
Reads a year and week, and if DAYFLAG is non-nil a day (otherwise
taken to be 1)."
- (let* ((year (calendar-read
- "ISO calendar year (>0): "
+ (let* ((year (calendar-read-sexp
+ "ISO calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (calendar-extract-year (calendar-current-date))))
(no-weeks (calendar-extract-month
(calendar-iso-from-absolute
(1-
(calendar-dayname-on-or-before
1 (calendar-absolute-from-gregorian
(list 1 4 (1+ year))))))))
- (week (calendar-read
- (format "ISO calendar week (1-%d): " no-weeks)
- (lambda (x) (and (> x 0) (<= x no-weeks)))))
- (day (if dayflag (calendar-read
- "ISO day (1-7): "
+ (week (calendar-read-sexp
+ "ISO calendar week (1-%d)"
+ (lambda (x) (and (> x 0) (<= x no-weeks)))
+ nil
+ no-weeks))
+ (day (if dayflag (calendar-read-sexp
+ "ISO day (1-7)"
(lambda (x) (and (<= 1 x) (<= x 7))))
1)))
(list (list week day year))))
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el
index 460f00eda4e..47880a4e974 100644
--- a/lisp/calendar/cal-julian.el
+++ b/lisp/calendar/cal-julian.el
@@ -1,4 +1,4 @@
-;;; cal-julian.el --- calendar functions for the Julian calendar
+;;; cal-julian.el --- calendar functions for the Julian calendar -*- lexical-binding:t -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'."
"Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
(interactive
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Julian calendar year (>0): "
+ (year (calendar-read-sexp
+ "Julian calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-julian-from-absolute
- (calendar-absolute-from-gregorian
- today))))))
+ (calendar-extract-year
+ (calendar-julian-from-absolute
+ (calendar-absolute-from-gregorian
+ today)))))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'."
(if (and (zerop (% year 4)) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
- (day (calendar-read
- (format "Julian calendar day (%d-%d): "
- (if (and (= year 1) (= month 1)) 3 1) last)
+ (day (calendar-read-sexp
+ "Julian calendar day (%d-%d)"
(lambda (x)
(and (< (if (and (= year 1) (= month 1)) 2 0) x)
- (<= x last))))))
+ (<= x last)))
+ nil
+ (if (and (= year 1) (= month 1)) 3 1) last)))
(list (list month day year))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-julian-to-absolute date)))
@@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given."
(defun calendar-astro-goto-day-number (daynumber &optional noecho)
"Move cursor to astronomical (Julian) DAYNUMBER.
Echo astronomical (Julian) day number unless NOECHO is non-nil."
- (interactive (list (calendar-read
- "Astronomical (Julian) day number (>1721425): "
+ (interactive (list (calendar-read-sexp
+ "Astronomical (Julian) day number (>1721425)"
(lambda (x) (> x 1721425)))))
(calendar-goto-date
(calendar-gregorian-from-absolute
@@ -182,23 +182,27 @@ Echo astronomical (Julian) day number unless NOECHO is non-nil."
(calendar-astro-to-absolute daynumber))))
(or noecho (calendar-astro-print-day-number)))
-
-;; The function below is designed to be used in sexp diary entries,
-;; and may be present in users' diary files, so suppress the warning
-;; about this prefix-less dynamic variable. It's called from
-;; `diary-list-sexp-entries', which binds the variable.
-(with-suppressed-warnings ((lexical date))
- (defvar date))
-
;;;###diary-autoload
(defun diary-julian-date ()
"Julian calendar equivalent of date diary entry."
+ ;; This function is designed to be used in sexp diary entries, and
+ ;; may be present in users' diary files, so suppress the warning
+ ;; about this prefix-less dynamic variable. It's called from
+ ;; `diary-list-sexp-entries', which binds the variable.
+ (with-suppressed-warnings ((lexical date))
+ (defvar date))
(format "Julian date: %s" (calendar-julian-date-string date)))
;; To be called from diary-list-sexp-entries, where DATE is bound.
;;;###diary-autoload
(defun diary-astro-day-number ()
"Astronomical (Julian) day number diary entry."
+ ;; This function is designed to be used in sexp diary entries, and
+ ;; may be present in users' diary files, so suppress the warning
+ ;; about this prefix-less dynamic variable. It's called from
+ ;; `diary-list-sexp-entries', which binds the variable.
+ (with-suppressed-warnings ((lexical date))
+ (defvar date))
(format "Astronomical (Julian) day number at noon UTC: %s.0"
(calendar-astro-date-string date)))
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index 8d894ebd986..9a221921130 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -1,4 +1,4 @@
-;;; cal-mayan.el --- calendar functions for the Mayan calendars
+;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*-
;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
(defun calendar-mayan-read-haab-date ()
"Prompt for a Mayan haab date."
(let* ((completion-ignore-case t)
- (haab-day (calendar-read
- "Haab kin (0-19): "
+ (haab-day (calendar-read-sexp
+ "Haab kin (0-19)"
(lambda (x) (and (>= x 0) (< x 20)))))
(haab-month-list (append calendar-mayan-haab-month-name-array
(and (< haab-day 5) '("Uayeb"))))
@@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
(defun calendar-mayan-read-tzolkin-date ()
"Prompt for a Mayan tzolkin date."
(let* ((completion-ignore-case t)
- (tzolkin-count (calendar-read
- "Tzolkin kin (1-13): "
+ (tzolkin-count (calendar-read-sexp
+ "Tzolkin kin (1-13)"
(lambda (x) (and (> x 0) (< x 14)))))
(tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
(tzolkin-name (cdr
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index a30c681a897..ef84bfadd31 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -1,4 +1,4 @@
-;;; cal-menu.el --- calendar functions for menu bar and popup menu support
+;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
@@ -104,9 +104,9 @@
;; The bug has since been fixed.
(dotimes (i 11)
(push (vector (format "hol-year-%d" i)
- `(lambda ()
- (interactive)
- (holiday-list (+ displayed-year ,(- i 5))))
+ (lambda ()
+ (interactive)
+ (holiday-list (+ displayed-year (- i 5))))
:label `(format "For Year %d"
(+ displayed-year ,(- i 5))))
l))
@@ -183,6 +183,8 @@ Signals an error if popups are unavailable."
;; Autoloaded in diary-lib.
(declare-function calendar-check-holidays "holidays" (date))
+(defvar diary-list-include-blanks)
+
(defun calendar-mouse-view-diary-entries (&optional date diary event)
"Pop up menu of diary entries for mouse-selected date.
Use optional DATE and alternative file DIARY. EVENT is the event
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index 710ce37ccbf..9294362cb43 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -1,4 +1,4 @@
-;;; cal-move.el --- calendar functions for movement in the calendar
+;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -386,15 +386,16 @@ Moves forward if ARG is negative."
"Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
Negative DAY counts backward from end of year."
(interactive
- (let* ((year (calendar-read
- "Year (>0): "
+ (let* ((year (calendar-read-sexp
+ "Year (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (calendar-extract-year (calendar-current-date))))
(last (if (calendar-leap-year-p year) 366 365))
- (day (calendar-read
- (format "Day number (+/- 1-%d): " last)
- (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
+ (day (calendar-read-sexp
+ "Day number (+/- 1-%d)"
+ (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))
+ nil
+ last)))
(list year day)))
(calendar-goto-date
(calendar-gregorian-from-absolute
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el
index a9c99fedbdb..dd005e86608 100644
--- a/lisp/calendar/cal-persia.el
+++ b/lisp/calendar/cal-persia.el
@@ -1,4 +1,4 @@
-;;; cal-persia.el --- calendar functions for the Persian calendar
+;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
@@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC."
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (calendar-extract-year persian-date))
- (m (calendar-extract-month persian-date))
- (monthname (aref calendar-persian-month-name-array (1- m)))
+ (m (calendar-extract-month persian-date)))
+ (calendar-dlet
+ ((monthname (aref calendar-persian-month-name-array (1- m)))
(day (number-to-string (calendar-extract-day persian-date)))
(year (number-to-string y))
(month (number-to-string m))
dayname)
- (mapconcat 'eval calendar-date-display-form "")))
+ (mapconcat #'eval calendar-date-display-form ""))))
;;;###cal-autoload
(defun calendar-persian-print-date ()
@@ -157,14 +158,13 @@ Gregorian date Sunday, December 31, 1 BC."
(defun calendar-persian-read-date ()
"Interactively read the arguments for a Persian date command.
Reads a year, month, and day."
- (let* ((year (calendar-read
- "Persian calendar year (not 0): "
+ (let* ((year (calendar-read-sexp
+ "Persian calendar year (not 0)"
(lambda (x) (not (zerop x)))
- (number-to-string
- (calendar-extract-year
- (calendar-persian-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))))
+ (calendar-extract-year
+ (calendar-persian-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@@ -175,9 +175,11 @@ Reads a year, month, and day."
(calendar-make-alist calendar-persian-month-name-array
1))))
(last (calendar-persian-last-day-of-month month year))
- (day (calendar-read
- (format "Persian calendar day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Persian calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 9df9f4cbedf..f5932014dd9 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -1,4 +1,4 @@
-;;; cal-tex.el --- calendar functions for printing calendars with LaTeX
+;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -248,6 +248,8 @@ This definition is the heart of the calendar!")
(autoload 'diary-list-entries "diary-lib")
+(defvar diary-list-include-blanks)
+
(defun cal-tex-list-diary-entries (d1 d2)
"Generate a list of all diary-entries from absolute date D1 to D2."
(let (diary-list-include-blanks)
@@ -591,6 +593,8 @@ indicates a buffer position to use instead of point."
LaTeX commands are inserted for the days of the MONTH in YEAR.
Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS
are included. Each day is formatted using format DAY-FORMAT."
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let ((blank-days ; at start of month
(mod
(- (calendar-day-of-week (list month 1 year))
@@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT."
(insert (format day-format (cal-tex-month-name month) j))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(cal-tex-arg)
(cal-tex-comment))
(when (and (zerop (mod (+ j blank-days) 7))
@@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
- (year (calendar-extract-year date))
+ ;; (year (calendar-extract-year date))
(day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
@@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
- (insert " " (eval cal-tex-daily-string))
+ (insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl)
(cal-tex-noindent)
@@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position."
(cal-tex-e-parbox "2cm")
(cal-tex-nl)
(setq month (calendar-extract-month date)
- year (calendar-extract-year date)))
+ ;; year (calendar-extract-year date)
+ ))
(cal-tex-e-parbox)
(unless (= i (1- n))
(run-hooks 'cal-tex-week-hook)
@@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position."
;; TODO respect cal-tex-daily-start,end?
;; Using different numbers of hours will probably break some layouts.
-(defun cal-tex-week-hours (date holidays height)
- "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT.
+(defun cal-tex-week-hours (thedate holidays height)
+ "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours
shown are hard-coded to 8-12, 13-17."
- (let ((month (calendar-extract-month date))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
+ (let ((date thedate)
+ (month (calendar-extract-month date))
(day (calendar-extract-day date))
- (year (calendar-extract-year date))
+ ;; (year (calendar-extract-year date))
morning afternoon s)
(cal-tex-comment "begin cal-tex-week-hours")
(cal-tex-cmd "\\ \\\\[-.2cm]")
@@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
- (insert " " (eval cal-tex-daily-string))
+ (insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl "-.3cm")
(cal-tex-rule "0pt" "6.8in" ".2mm")
@@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17."
(defun cal-tex-weekly-common (n event &optional filofax)
"Common code for weekly calendars."
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")
@@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
calendar-week-start-day
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(unless (= i (1- n))
@@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point."
"\\leftday")))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
- (if cal-tex-rules
- (insert "\\linesfill\n")
- (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
+ (insert (if cal-tex-rules
+ "\\linesfill\n"
+ "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
(cal-tex-newpage)
(setq date (cal-tex-incr-date date)))
(insert "%\n")
@@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point."
(insert "\\weekend")
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
- (if cal-tex-rules
- (insert "\\linesfill\n")
- (insert "\\vfill"))
+ (insert (if cal-tex-rules
+ "\\linesfill\n"
+ "\\vfill"))
(setq date (cal-tex-incr-date date)))
(or cal-tex-rules
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
@@ -1442,12 +1458,15 @@ a buffer position to use instead of point."
(cal-tex-end-document)
(run-hooks 'cal-tex-hook)))
-(defun cal-tex-daily-page (date)
- "Make a calendar page for Gregorian DATE on 8.5 by 11 paper.
+(defun cal-tex-daily-page (thedate)
+ "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces
hourly sections for the period specified by `cal-tex-daily-start'
and `cal-tex-daily-end'."
- (let ((month-name (cal-tex-month-name (calendar-extract-month date)))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
+ (let ((date thedate)
+ (month-name (cal-tex-month-name (calendar-extract-month date)))
(i (1- cal-tex-daily-start))
hour)
(cal-tex-banner "cal-tex-daily-page")
@@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'."
(cal-tex-bf month-name )
(cal-tex-e-parbox)
(cal-tex-hspace "1cm")
- (cal-tex-scriptsize (eval cal-tex-daily-string))
+ (cal-tex-scriptsize (eval cal-tex-daily-string t))
(cal-tex-hspace "3.5cm")
(cal-tex-e-makebox)
(cal-tex-hfill)
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 1c19a60db10..ca303ce39ae 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -1,4 +1,4 @@
-;;; cal-x.el --- calendar windows in dedicated frames
+;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 88734e2c02c..76d6132eae1 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -112,6 +112,8 @@
;;; Code:
+(eval-when-compile (require 'subr-x))
+
(load "cal-loaddefs" nil t)
;; Calendar has historically relied heavily on dynamic scoping.
@@ -135,15 +137,14 @@
;; - whatever is passed to diary-sexp-entry
;; - whatever is passed to diary-remind
-(defmacro calendar-dlet* (binders &rest body)
- "Like `let*' but using dynamic scoping."
+(defmacro calendar-dlet (binders &rest body)
+ "Like `dlet' but without warnings about non-prefixed var names."
(declare (indent 1) (debug let))
- `(progn
- (with-no-warnings ;Silence "lacks a prefix" warnings!
- ,@(mapcar (lambda (binder)
- `(defvar ,(if (consp binder) (car binder) binder)))
- binders))
- (let* ,binders ,@body)))
+ (let ((vars (mapcar (lambda (binder)
+ (if (consp binder) (car binder) binder))
+ binders)))
+ `(with-suppressed-warnings ((lexical ,@vars))
+ (dlet ,binders ,@body))))
;; Avoid recursive load of calendar when loading cal-menu. Yuck.
(provide 'calendar)
@@ -995,7 +996,7 @@ pre-existing calendar windows."
"Set the style of calendar and diary dates to STYLE (a symbol).
The valid styles are described in the documentation of `calendar-date-style'."
(interactive (list (intern
- (completing-read "Date style: "
+ (completing-read (format-prompt "Date style" "american")
'("american" "european" "iso") nil t
nil nil "american"))))
(or (memq style '(american european iso))
@@ -1062,6 +1063,15 @@ calendar."
:type 'boolean
:group 'holidays)
+;; fixme should have a :set that changes calendar-standard-time-zone-name etc.
+(defcustom calendar-time-zone-style 'symbolic
+ "Your preferred style for time zones.
+If 'numeric, use numeric time zones like \"+0100\".
+Otherwise, use symbolic time zones like \"CET\"."
+ :type '(choice (const numeric) (other symbolic))
+ :version "28.1"
+ :group 'calendar)
+
;;; End of user options.
(calendar-recompute-layout-variables)
@@ -1451,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date."
Inserts STRING so that it ends at INDENT. STRING is either a
literal string, or a sexp to evaluate to return such. Truncates
STRING to length TRUNCATE, and ensures a trailing space."
- (if (not (ignore-errors (stringp (setq string (eval string)))))
+ (if (not (ignore-errors (stringp (setq string (eval string t)))))
(calendar-move-to-column indent)
(if (> (string-width string) truncate)
(setq string (truncate-string-to-width string truncate)))
@@ -1489,7 +1499,7 @@ first INDENT characters on the line."
(goto-char (point-min))
(calendar-move-to-column indent)
(insert
- (calendar-dlet* ((month month) (year year))
+ (calendar-dlet ((month month) (year year))
(calendar-string-spread (list calendar-month-header)
?\s calendar-month-digit-width)))
(calendar-ensure-newline)
@@ -1506,7 +1516,7 @@ first INDENT characters on the line."
calendar-day-header-width nil ?\s)
(make-string (- calendar-column-width calendar-day-header-width) ?\s)))
(calendar-ensure-newline)
- (calendar-dlet* ((day day) (month month) (year year))
+ (calendar-dlet ((day day) (month month) (year year))
(calendar-insert-at-column indent calendar-intermonth-text trunc))
;; Add blank days before the first of the month.
(insert (make-string (* blank-days calendar-column-width) ?\s))
@@ -1517,8 +1527,8 @@ first INDENT characters on the line."
(insert (propertize
(format (format "%%%dd" calendar-day-digit-width) day)
'mouse-face 'highlight
- 'help-echo (calendar-dlet* ((day day) (month month) (year year))
- (eval calendar-date-echo-text))
+ 'help-echo (calendar-dlet ((day day) (month month) (year year))
+ (eval calendar-date-echo-text t))
;; 'date property prevents intermonth text confusing re-searches.
;; (Tried intangible, it did not really work.)
'date t)
@@ -1528,7 +1538,7 @@ first INDENT characters on the line."
(/= day last))
(calendar-ensure-newline)
(setq day (1+ day)) ; first day of next week
- (calendar-dlet* ((day day) (month month) (year year))
+ (calendar-dlet ((day day) (month month) (year year))
(calendar-insert-at-column indent calendar-intermonth-text trunc))))))
(defun calendar-redraw ()
@@ -1780,7 +1790,7 @@ For a complete description, see the info node `Calendar/Diary'.
(setq buffer-read-only t
buffer-undo-list t
indent-tabs-mode nil)
- (set (make-local-variable 'scroll-margin) 0) ; bug#10379
+ (setq-local scroll-margin 0) ; bug#10379
(calendar-update-mode-line)
(make-local-variable 'calendar-mark-ring)
(make-local-variable 'displayed-month) ; month in middle of window
@@ -1823,7 +1833,7 @@ concatenated and the result truncated."
(bufferp (get-buffer calendar-buffer)))
(with-current-buffer calendar-buffer
(let ((start (- calendar-left-margin 2)))
- (calendar-dlet* ((date (condition-case nil
+ (calendar-dlet ((date (condition-case nil
(calendar-cursor-to-nearest-date)
(error (calendar-current-date)))))
(setq mode-line-format
@@ -2046,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring."
(error "%s not available in the calendar"
(global-key-binding (this-command-keys))))
+(defun calendar-read-sexp (prompt predicate &optional default &rest args)
+ "Return an object read from the minibuffer.
+Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build
+the actual prompt. PREDICATE is called with a single value (the object
+the user entered) and it should return non-nil if that value is a valid choice.
+DEFAULT is the default value to use."
+ (unless (stringp default) (setq default (format "%S" default)))
+ (named-let query ()
+ ;; The call to `read-from-minibuffer' is copied from `read-minibuffer',
+ ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS.
+ (let ((value (read-from-minibuffer
+ (apply #'format-prompt prompt default args)
+ nil minibuffer-local-map t 'minibuffer-history default)))
+ (if (funcall predicate value)
+ value
+ (query)))))
+
(defun calendar-read (prompt acceptable &optional initial-contents)
"Return an object read from the minibuffer.
Prompt with the string PROMPT and use the function ACCEPTABLE to decide
if entered item is acceptable. If non-nil, optional third arg
INITIAL-CONTENTS is a string to insert in the minibuffer before reading."
+ (declare (obsolete calendar-read-sexp "28.1"))
(let ((value (read-minibuffer prompt initial-contents)))
(while (not (funcall acceptable value))
(setq value (read-minibuffer prompt initial-contents)))
value))
-
(defun calendar-customized-p (symbol)
"Return non-nil if SYMBOL has been customized."
(and (default-boundp symbol)
(let ((standard (get symbol 'standard-value)))
(and standard
- (not (equal (eval (car standard)) (default-value symbol)))))))
+ (not (equal (eval (car standard) t) (default-value symbol)))))))
(defun calendar-abbrev-construct (full &optional maxlen)
"From sequence FULL, return a vector of abbreviations.
@@ -2276,32 +2303,38 @@ arguments SEQUENCES."
(append (list sequence) sequences))
(reverse alist)))
-(defun calendar-read-date (&optional noday)
+(defun calendar-read-date (&optional noday default-date)
"Prompt for Gregorian date. Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month 1 year); if NODAY is any other non-nil value the value
returned is (month year)."
- (let* ((year (calendar-read
- "Year (>0): "
- (lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (unless default-date (setq default-date (calendar-current-date)))
+ (let* ((defyear (calendar-extract-year default-date))
+ (year (calendar-read-sexp "Year (>0)"
+ (lambda (x) (> x 0))
+ defyear))
(month-array calendar-month-name-array)
+ (defmon (aref month-array (1- (calendar-extract-month default-date))))
(completion-ignore-case t)
(month (cdr (assoc-string
- (completing-read
- "Month name: "
- (mapcar #'list (append month-array nil))
- nil t)
+ (completing-read
+ (format-prompt "Month name" defmon)
+ (append month-array nil)
+ nil t nil nil defmon)
(calendar-make-alist month-array 1) t)))
+ (defday (calendar-extract-day default-date))
(last (calendar-last-day-of-month month year)))
(if noday
(if (eq noday t)
(list month 1 year)
(list month year))
(list month
- (calendar-read (format "Day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))
+ (calendar-read-sexp "Day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ ;; Don't offer today's day as default
+ ;; if it's not valid for the chosen
+ ;; month/year.
+ (if (<= defday last) defday) last)
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)
@@ -2528,7 +2561,7 @@ and day names to be abbreviated as specified by
respectively. An optional parameter NODAYNAME, when t, omits the
name of the day of the week."
(let ((month (calendar-extract-month date)))
- (calendar-dlet*
+ (calendar-dlet
((dayname (unless nodayname (calendar-day-name date abbreviate)))
(monthname (calendar-month-name month abbreviate))
(day (number-to-string (calendar-extract-day date)))
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index d37ee71e6ff..f57fe26058f 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -73,18 +73,18 @@ are holidays."
;; follows: the first line matching "^# [tag:value]" defines the value
;; for that particular tag.
(defcustom diary-face-attrs
- '((" *\\[foreground:\\([-a-z]+\\)\\]$" 1 :foreground string)
- (" *\\[background:\\([-a-z]+\\)\\]$" 1 :background string)
- (" *\\[width:\\([-a-z]+\\)\\]$" 1 :width symbol)
- (" *\\[height:\\([.0-9]+\\)\\]$" 1 :height int)
- (" *\\[weight:\\([-a-z]+\\)\\]$" 1 :weight symbol)
- (" *\\[slant:\\([-a-z]+\\)\\]$" 1 :slant symbol)
- (" *\\[underline:\\([-a-z]+\\)\\]$" 1 :underline stringtnil)
- (" *\\[overline:\\([-a-z]+\\)\\]$" 1 :overline stringtnil)
- (" *\\[strike-through:\\([-a-z]+\\)\\]$" 1 :strike-through stringtnil)
- (" *\\[inverse-video:\\([-a-z]+\\)\\]$" 1 :inverse-video tnil)
- (" *\\[face:\\([-0-9a-z]+\\)\\]$" 1 :face string)
- (" *\\[font:\\([-a-z0-9]+\\)\\]$" 1 :font string)
+ '((" *\\[foreground:\\([-a-z]+\\)\\] *" 1 :foreground string)
+ (" *\\[background:\\([-a-z]+\\)\\] *" 1 :background string)
+ (" *\\[width:\\([-a-z]+\\)\\] *" 1 :width symbol)
+ (" *\\[height:\\([.0-9]+\\)\\] *" 1 :height int)
+ (" *\\[weight:\\([-a-z]+\\)\\] *" 1 :weight symbol)
+ (" *\\[slant:\\([-a-z]+\\)\\] *" 1 :slant symbol)
+ (" *\\[underline:\\([-a-z]+\\)\\] *" 1 :underline stringtnil)
+ (" *\\[overline:\\([-a-z]+\\)\\] *" 1 :overline stringtnil)
+ (" *\\[strike-through:\\([-a-z]+\\)\\] *" 1 :strike-through stringtnil)
+ (" *\\[inverse-video:\\([-a-z]+\\)\\] *" 1 :inverse-video tnil)
+ (" *\\[face:\\([-0-9a-z]+\\)\\] *" 1 :face string)
+ (" *\\[font:\\([-a-z0-9]+\\)\\] *" 1 :font string)
;; Unsupported.
;;; (" *\\[box:\\([-a-z]+\\)\\]$" 1 :box)
;;; (" *\\[stipple:\\([-a-z]+\\)\\]$" 1 :stipple)
@@ -98,7 +98,7 @@ specifies which face attribute (e.g. `:foreground') to modify, or
that this is a face (`:face') to apply. TYPE is the type of
attribute being applied. Available TYPES (see `diary-attrtype-convert')
are: `string', `symbol', `int', `tnil', `stringtnil'."
- :type '(repeat (list (string :tag "Regular expression")
+ :type '(repeat (list (regexp :tag "Regular expression")
(integer :tag "Sub-expression")
(symbol :tag "Attribute (e.g. :foreground)")
(choice (const string :tag "A string")
@@ -663,7 +663,7 @@ any entries were found."
(calendar-month-name-array (or months calendar-month-name-array))
(case-fold-search t)
entry-found)
- (calendar-dlet*
+ (calendar-dlet
((dayname (format "%s\\|%s\\.?" (calendar-day-name date)
(calendar-day-name date 'abbrev)))
(monthname (format "\\*\\|%s%s" (calendar-month-name month)
@@ -839,7 +839,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(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)
+ (setq-local diary-selective-display t)
(overlay-put ol 'invisible 'diary)
(overlay-put ol 'evaporate t)))
(dotimes (_ number)
@@ -858,7 +858,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
;; every time, diary-include-other-diary-files
;; binds it to nil (essentially) when it runs
;; in included files.
- (calendar-dlet* ((number number)
+ (calendar-dlet ((number number)
(list-only list-only))
(run-hooks 'diary-nongregorian-listing-hook
'diary-list-entries-hook))
@@ -877,7 +877,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(copy-sequence
(car display-buffer-fallback-action))))))
(funcall diary-display-function)))
- (calendar-dlet* ((number number)
+ (calendar-dlet ((number number)
(original-date original-date))
(run-hooks 'diary-hook))))))
(and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff)))
@@ -1092,7 +1092,9 @@ This is an option for `diary-display-function'."
(if (calendar-date-equal date (car h))
(setq date-holiday-list (append date-holiday-list
(cdr h)))))
- (insert (if (bobp) "" ?\n) (calendar-date-string date))
+ (insert (if (bobp) "" ?\n)
+ (propertize (calendar-date-string date)
+ 'font-lock-face 'diary))
(if date-holiday-list (insert ": "))
(setq cc (current-column))
(insert (mapconcat (lambda (x)
@@ -1100,7 +1102,10 @@ This is an option for `diary-display-function'."
x)
date-holiday-list
(concat "\n" (make-string cc ?\s))))
- (insert ?\n (make-string (+ cc longest) ?=) ?\n)))
+ (insert ?\n
+ (propertize (make-string (+ cc longest) ?=)
+ 'font-lock-face 'diary)
+ ?\n)))
(let ((this-entry (cadr entry))
this-loc marks temp-face)
(unless (zerop (length this-entry))
@@ -1261,7 +1266,7 @@ MARKFUNC is a function that marks entries of the appropriate type
matching a given date pattern. 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."
- (calendar-dlet*
+ (calendar-dlet
((dayname (diary-name-pattern calendar-day-name-array
calendar-day-abbrev-array))
(monthname (format "%s\\|\\*"
@@ -1430,7 +1435,7 @@ marks. This is intended to deal with deleted diary entries."
(defun diary-sexp-entry (sexp entry date)
"Process a SEXP diary ENTRY for DATE."
(let ((result
- (calendar-dlet* ((date date)
+ (calendar-dlet ((date date)
(entry entry))
(if calendar-debug-sexp
(let ((debug-on-error t))
@@ -2038,7 +2043,7 @@ calendar."
(and (integerp days)
(< days 0)
(setq days (number-sequence 1 (- days))))
- (calendar-dlet* ((diary-entry (eval sexp)))
+ (calendar-dlet ((diary-entry (eval sexp)))
(cond
;; Diary entry applies on date.
((and diary-entry
@@ -2054,7 +2059,7 @@ calendar."
(when (setq diary-entry (eval sexp))
;; Discard any mark portion from diary-anniversary, etc.
(if (consp diary-entry) (setq diary-entry (cdr diary-entry)))
- (calendar-dlet* ((days days))
+ (calendar-dlet ((days days))
(mapconcat #'eval diary-remind-message "")))))
;; Diary entry may apply to one of a list of days before date.
((and (listp days) days)
@@ -2216,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking."
(diary-make-entry
(format "%s(diary-cyclic %d %s)"
diary-sexp-entry-symbol
- (calendar-read "Repeat every how many days: "
- (lambda (x) (> x 0)))
+ (calendar-read-sexp "Repeat every how many days"
+ (lambda (x) (> x 0)))
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))
@@ -2259,7 +2264,7 @@ If given, optional SYMBOL must be a prefix to entries. If
optional ABBREV-ARRAY is present, also matches the abbreviations
from this array (with or without a final `.'), in addition to the
full month names."
- (calendar-dlet*
+ (calendar-dlet
((dayname (diary-name-pattern calendar-day-name-array
calendar-day-abbrev-array t))
(monthname (format "\\(%s\\|\\*\\)"
@@ -2376,10 +2381,9 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
;;;###autoload
(define-derived-mode diary-mode fundamental-mode "Diary"
"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)
+ (setq-local font-lock-defaults '(diary-font-lock-keywords t))
+ (setq-local comment-start diary-comment-start)
+ (setq-local 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
@@ -2394,8 +2398,9 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
(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."
+ (declare (obsolete nil "28.1"))
(concat
- (calendar-dlet*
+ (calendar-dlet
((dayname (diary-name-pattern calendar-day-name-array nil t))
(monthname (diary-name-pattern calendar-month-name-array nil t))
(day "1")
@@ -2414,15 +2419,17 @@ This depends on the calendar date style."
(defun diary-fancy-date-matcher (limit)
"Search for a fancy diary data header, up to LIMIT."
+ (declare (obsolete nil "28.1"))
;; 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))
+ (with-suppressed-warnings ((obsolete diary-fancy-date-pattern))
+ (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)))
(defvar diary-fancy-font-lock-keywords
- `((diary-fancy-date-matcher . 'diary)
- ("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary)
+ `(("^.*\\([aA]nniversary\\|[bB]irthday\\).*$" . 'diary-anniversary)
("^.*Yahrzeit.*$" . font-lock-constant-face)
("^\\(Erev \\)?Rosh Hodesh.*" . font-lock-function-name-face)
("^Day.*omer.*$" . font-lock-builtin-face)
@@ -2443,9 +2450,6 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
(if (looking-at "=+$") (forward-line -1))
(while (and (looking-at " +[^ ]")
(zerop (forward-line -1))))
- ;; This check not essential.
- (if (looking-at (diary-fancy-date-pattern))
- (setq beg (line-beginning-position)))
(goto-char end)
(forward-line 0)
(while (and (looking-at " +[^ ]")
@@ -2460,13 +2464,13 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
(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)
- '(diary-fancy-font-lock-keywords
- t nil nil nil
- (font-lock-fontify-region-function
- . diary-fancy-font-lock-fontify-region-function)))
- (set (make-local-variable 'minor-mode-overriding-map-alist)
- (list (cons t diary-fancy-overriding-map)))
+ (setq-local font-lock-defaults
+ '(diary-fancy-font-lock-keywords
+ t nil nil nil
+ (font-lock-fontify-region-function
+ . diary-fancy-font-lock-fontify-region-function)))
+ (setq-local minor-mode-overriding-map-alist
+ (list (cons t diary-fancy-overriding-map)))
(view-mode 1))
;; Following code from Dave Love <fx@gnu.org>.
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 932993beba0..3eae2dcc7f1 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -423,16 +423,15 @@ of a holiday list.
The optional LABEL is used to label the buffer created."
(interactive
- (let* ((start-year (calendar-read
- "Starting year of holidays (>0): "
+ (let* ((start-year (calendar-read-sexp
+ "Starting year of holidays (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
- (end-year (calendar-read
- (format "Ending year (inclusive) of holidays (>=%s): "
- start-year)
+ (calendar-extract-year (calendar-current-date))))
+ (end-year (calendar-read-sexp
+ "Ending year (inclusive) of holidays (>=%s)"
(lambda (x) (>= x start-year))
- (number-to-string start-year)))
+ start-year
+ start-year))
(completion-ignore-case t)
(lists
(list
@@ -684,7 +683,7 @@ nil, or if the date is not visible, there is no holiday."
(y displayed-year))
(calendar-increment-month m y -1)
(holiday-filter-visible-calendar
- (calendar-dlet* (year date)
+ (calendar-dlet (year date)
(list
(progn
(setq year y
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 6c73431ebf8..d18ec5e798f 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -6,7 +6,7 @@
;; Created: August 2002
;; Keywords: calendar
;; Human-Keywords: calendar, diary, iCalendar, vCalendar
-;; Version: 0.19
+;; Old-Version: 0.19
;; This file is part of GNU Emacs.
@@ -66,7 +66,7 @@
;; 0.02:
;; - Should work in XEmacs now. Thanks to Len Trigg for the XEmacs patches!
;; - Added exporting from Emacs diary to ical.
-;; - Some bugfixes, after testing with calendars from http://icalshare.com.
+;; - Some bugfixes, after testing with calendars from https://icalshare.com.
;; - Tested with Emacs 21.3.2 and XEmacs 21.4.12
;; 0.01: (2003-03-21)
@@ -105,9 +105,6 @@
;;; Code:
-(defconst icalendar-version "0.19"
- "Version number of icalendar.el.")
-
;; ======================================================================
;; Customizables
;; ======================================================================
@@ -514,9 +511,10 @@ The strings are suitable for assembling into a TZ variable."
(let* ((offsetto (car (cddr (assq 'TZOFFSETTO alist))))
(offsetfrom (car (cddr (assq 'TZOFFSETFROM alist))))
(rrule-value (car (cddr (assq 'RRULE alist))))
+ (rdate-p (and (assq 'RDATE alist) t))
(dtstart (car (cddr (assq 'DTSTART alist))))
- (no-dst (equal offsetto offsetfrom)))
- ;; FIXME: for now we only handle RRULE and not RDATE here.
+ (no-dst (or rdate-p (equal offsetto offsetfrom))))
+ ;; FIXME: the presence of an RDATE is assumed to denote the first day of the year
(when (and offsetto dtstart (or rrule-value no-dst))
(let* ((rrule (icalendar--split-value rrule-value))
(freq (cadr (assq 'FREQ rrule)))
@@ -560,12 +558,13 @@ The strings are suitable for assembling into a TZ variable."
(defun icalendar--parse-vtimezone (alist)
"Turn a VTIMEZONE ALIST into a cons (ID . TZ-STRING).
+Consider only the most recent date specification.
Return nil if timezone cannot be parsed."
(let* ((tz-id (icalendar--convert-string-for-import
(icalendar--get-event-property alist 'TZID)))
- (daylight (cadr (cdar (icalendar--get-children alist 'DAYLIGHT))))
+ (daylight (cadr (cdar (icalendar--get-most-recent-observance alist 'DAYLIGHT))))
(day (and daylight (icalendar--convert-tz-offset daylight t)))
- (standard (cadr (cdar (icalendar--get-children alist 'STANDARD))))
+ (standard (cadr (cdar (icalendar--get-most-recent-observance alist 'STANDARD))))
(std (and standard (icalendar--convert-tz-offset standard nil))))
(if (and tz-id std)
(cons tz-id
@@ -574,6 +573,28 @@ Return nil if timezone cannot be parsed."
"," (cdr day) "," (cdr std))
(car std))))))
+(defun icalendar--get-most-recent-observance (alist sub-comp)
+ "Return the latest observance for SUB-COMP DAYLIGHT or STANDARD.
+ALIST is a VTIMEZONE potentially containing historical records."
+;FIXME?: "most recent" should be relative to a given date
+ (let ((components (icalendar--get-children alist sub-comp)))
+ (list
+ (car
+ (sort components
+ (lambda (a b)
+ (let* ((get-recent (lambda (n)
+ (car
+ (sort
+ (delq nil
+ (mapcar (lambda (p)
+ (and (memq (car p) '(DTSTART RDATE))
+ (car (cddr p))))
+ n))
+ 'string-greaterp))))
+ (a-recent (funcall get-recent (car (cddr a))))
+ (b-recent (funcall get-recent (car (cddr b)))))
+ (string-greaterp a-recent b-recent))))))))
+
(defun icalendar--convert-all-timezones (icalendar)
"Convert all timezones in the ICALENDAR into an alist.
Each element of the alist is a cons (ID . TZ-STRING),
@@ -593,15 +614,18 @@ ZONE-MAP is a timezone alist as returned by `icalendar--convert-all-timezones'."
(cdr (assoc id zone-map)))))
(defun icalendar--decode-isodatetime (isodatetimestring &optional day-shift
- zone)
+ source-zone
+ result-zone)
"Return ISODATETIMESTRING in format like `decode-time'.
Converts from ISO-8601 to Emacs representation. If
ISODATETIMESTRING specifies UTC time (trailing letter Z) the
decoded time is given in the local time zone! If optional
parameter DAY-SHIFT is non-nil the result is shifted by DAY-SHIFT
days.
-ZONE, if provided, is the timezone, in any format understood by `encode-time'.
-
+SOURCE-ZONE, if provided, is the timezone for decoding the time,
+in any format understood by `encode-time'.
+RESULT-ZONE, if provided, is the timezone for encoding the result
+in any format understood by `decode-time'.
FIXME: multiple comma-separated values should be allowed!"
(icalendar--dmsg isodatetimestring)
(if isodatetimestring
@@ -623,7 +647,10 @@ FIXME: multiple comma-separated values should be allowed!"
(when (and (> (length isodatetimestring) 15)
;; UTC specifier present
(char-equal ?Z (aref isodatetimestring 15)))
- (setq zone t))
+ (setq source-zone t
+ ;; decode to local time unless result-zone is explicitly given,
+ ;; i.e. do not decode to UTC, i.e. do not (setq result-zone t)
+ ))
;; shift if necessary
(if day-shift
(let ((mdy (calendar-gregorian-from-absolute
@@ -636,9 +663,9 @@ FIXME: multiple comma-separated values should be allowed!"
;; create the decoded date-time
;; FIXME!?!
(let ((decoded-time (list second minute hour day month year
- nil -1 zone)))
+ nil -1 source-zone)))
(condition-case nil
- (decode-time (encode-time decoded-time))
+ (decode-time (encode-time decoded-time) result-zone)
(error
(message "Cannot decode \"%s\"" isodatetimestring)
;; Hope for the best....
@@ -684,9 +711,9 @@ FIXME: multiple comma-separated values should be allowed!"
(setq days (1- days))))
((match-beginning 4) ;days and time
(if (match-beginning 5)
- (setq days (* 7 (read (substring isodurationstring
- (match-beginning 6)
- (match-end 6))))))
+ (setq days (read (substring isodurationstring
+ (match-beginning 6)
+ (match-end 6)))))
(if (match-beginning 7)
(setq hours (read (substring isodurationstring
(match-beginning 8)
@@ -742,9 +769,6 @@ American format: \"month day year\"."
;; datetime == nil
nil))
-(define-obsolete-function-alias 'icalendar--datetime-to-noneuropean-date
- 'icalendar--datetime-to-american-date "icalendar 0.19")
-
(defun icalendar--datetime-to-european-date (datetime &optional separator)
"Convert the decoded DATETIME to European format.
Optional argument SEPARATOR gives the separator between month,
@@ -858,12 +882,14 @@ If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days."
(format "%04d%02d%02d" (nth 2 mdy) (nth 0 mdy) (nth 1 mdy))))
-(defun icalendar--datestring-to-isodate (datestring &optional day-shift)
+(defun icalendar--datestring-to-isodate (datestring &optional day-shift year-shift)
"Convert diary-style DATESTRING to iso-style date.
If DAY-SHIFT is non-nil, the result is shifted by DAY-SHIFT days
--- DAY-SHIFT must be either nil or an integer. This function
-tries to figure the date style from DATESTRING itself. If that
-is not possible it uses the current calendar date style."
+-- DAY-SHIFT must be either nil or an integer. If YEAR-SHIFT is
+non-nil, the result is shifted by YEAR-SHIFT years -- YEAR-SHIFT
+must be either nil or an integer. This function tries to figure
+the date style from DATESTRING itself. If that is not possible
+it uses the current calendar date style."
(let ((day -1) month year)
(save-match-data
(cond ( ;; iso-style numeric date
@@ -873,7 +899,7 @@ is not possible it uses the current calendar date style."
"0?\\([1-9][0-9]?\\)")
datestring)
(setq year (read (substring datestring (match-beginning 1)
- (match-end 1))))
+ (match-end 1))))
(setq month (read (substring datestring (match-beginning 2)
(match-end 2))))
(setq day (read (substring datestring (match-beginning 3)
@@ -936,6 +962,9 @@ is not possible it uses the current calendar date style."
(match-end 3)))))
(t
nil)))
+ (when year-shift
+ (setq year (+ year year-shift)))
+
(if (> day 0)
(let ((mdy (calendar-gregorian-from-absolute
(+ (calendar-absolute-from-gregorian (list month day
@@ -1754,8 +1783,8 @@ entries. ENTRY-MAIN is the first line of the diary entry."
;;BUT remove today if `diary-float'
;;expression does not hold true for today:
(when
- (null (calendar-dlet* ((date (calendar-current-date))
- (entry entry-main))
+ (null (calendar-dlet ((date (calendar-current-date))
+ (entry entry-main))
(diary-float month dayname n)))
(concat
"\nEXDATE;VALUE=DATE:"
@@ -1885,9 +1914,9 @@ entries. ENTRY-MAIN is the first line of the diary entry."
(let* ((datetime (substring entry-main (match-beginning 1)
(match-end 1)))
(startisostring (icalendar--datestring-to-isodate
- datetime))
+ datetime nil 1))
(endisostring (icalendar--datestring-to-isodate
- datetime 1))
+ datetime 1 1))
(starttimestring (icalendar--diarytime-to-isotime
(if (match-beginning 3)
(substring entry-main
@@ -2371,8 +2400,11 @@ END-T is the event's end time in diary format."
(if end-t "-" "")
(or end-t ""))))
(setq result (format
- "%%%%(and (diary-anniversary %s)) %s%s%s"
- dtstart-conv
+ "%%%%(diary-anniversary %s) %s%s%s"
+ (let* ((year (nth 5 dtstart-dec))
+ (dtstart-1y-dec (copy-sequence dtstart-dec)))
+ (setf (nth 5 dtstart-1y-dec) (1- year))
+ (icalendar--datetime-to-diary-date dtstart-1y-dec))
(or start-t "")
(if end-t "-" "") (or end-t "")))))
;; monthly
@@ -2521,6 +2553,11 @@ the entry."
(or (icalendar--get-event-property event 'URL) "")
(or (icalendar--get-event-property event 'CLASS) "")))
+;; Obsolete
+
+(defconst icalendar-version "0.19" "Version number of icalendar.el.")
+(make-obsolete-variable 'icalendar-version 'emacs-version "28.1")
+
(provide 'icalendar)
;;; icalendar.el ends here
diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el
index 0b7eb866801..f22f060e205 100644
--- a/lisp/calendar/iso8601.el
+++ b/lisp/calendar/iso8601.el
@@ -41,7 +41,7 @@
;;
;; The standard can be found at:
;;
-;; http://www.loc.gov/standards/datetime/iso-tc154-wg5_n0038_iso_wd_8601-1_2016-02-16.pdf
+;; https://www.loc.gov/standards/datetime/iso-tc154-wg5_n0038_iso_wd_8601-1_2016-02-16.pdf
;;
;; The Wikipedia page on the standard is also informative:
;;
@@ -69,6 +69,8 @@
"\\([+-]?[0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)")
(defconst iso8601--outdated-date-match
"--\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)")
+(defconst iso8601--outdated-reduced-precision-date-match
+ "---?\\([0-9][0-9]\\)")
(defconst iso8601--week-date-match
"\\([+-]?[0-9][0-9][0-9][0-9]\\)-?W\\([0-9][0-9]\\)-?\\([0-9]\\)?")
(defconst iso8601--ordinal-date-match
@@ -79,6 +81,7 @@
iso8601--full-date-match
iso8601--without-day-match
iso8601--outdated-date-match
+ iso8601--outdated-reduced-precision-date-match
iso8601--week-date-match
iso8601--ordinal-date-match)))
@@ -136,7 +139,8 @@ See `decode-time' for the meaning of FORM."
(when zone-string
(setf (decoded-time-zone date)
;; The time zone in decoded times are in seconds.
- (* (iso8601-parse-zone zone-string) 60)))
+ (* (iso8601-parse-zone zone-string) 60))
+ (setf (decoded-time-dst date) nil))
date)))
(defun iso8601-parse-date (string)
@@ -201,6 +205,12 @@ See `decode-time' for the meaning of FORM."
(iso8601--decoded-time :year year
:month (decoded-time-month month-day)
:day (decoded-time-day month-day))))
+ ;; Obsolete format with implied year: --MM
+ ((iso8601--match "--\\([0-9][0-9]\\)" string)
+ (iso8601--decoded-time :month (string-to-number (match-string 1 string))))
+ ;; Obsolete format with implied year and month: ---DD
+ ((iso8601--match "---\\([0-9][0-9]\\)" string)
+ (iso8601--decoded-time :day (string-to-number (match-string 1 string))))
(t
(signal 'wrong-type-argument string))))
@@ -221,17 +231,22 @@ See `decode-time' for the meaning of FORM."
(string-to-number (match-string 2 time))))
(second (and (match-string 3 time)
(string-to-number (match-string 3 time))))
- (fraction (and (not (zerop (length (match-string 4 time))))
- (string-to-number (match-string 4 time)))))
+ (frac-string (match-string 4 time))
+ fraction fraction-precision)
+ (when frac-string
+ ;; Remove trailing zeroes.
+ (setq frac-string (replace-regexp-in-string "0+\\'" "" frac-string))
+ (when (length> frac-string 0)
+ (setq fraction (string-to-number frac-string)
+ fraction-precision (length frac-string))))
(when (and fraction
(eq form t))
(cond
;; Sub-second time.
(second
- (let ((digits (1+ (truncate (log fraction 10)))))
- (setq second (cons (+ (* second (expt 10 digits))
- fraction)
- (expt 10 digits)))))
+ (setq second (cons (+ (* second (expt 10 fraction-precision))
+ fraction)
+ (expt 10 fraction-precision))))
;; Fractional minute.
(minute
(setq second (iso8601--decimalize fraction 60)))
@@ -332,6 +347,9 @@ Return the number of minutes."
(list start end
(or duration
;; FIXME: Support subseconds.
+ ;; FIXME: It makes no sense to decode a time difference
+ ;; according to (decoded-time-zone end), or according to
+ ;; any other time zone for that matter.
(decode-time (time-subtract (iso8601--encode-time end)
(iso8601--encode-time start))
(or (decoded-time-zone end) 0) 'integer)))))
@@ -354,7 +372,7 @@ Return the number of minutes."
(iso8601--value month)
(iso8601--value year)
nil
- dst
+ (if (or dst zone) dst -1)
zone))
(defun iso8601--encode-time (time)
diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el
index 446cd27477d..dd1d923f423 100644
--- a/lisp/calendar/lunar.el
+++ b/lisp/calendar/lunar.el
@@ -1,4 +1,4 @@
-;;; lunar.el --- calendar functions for phases of the moon
+;;; lunar.el --- calendar functions for phases of the moon -*- lexical-binding:t -*-
;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@@ -91,6 +91,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
(* -0.0016528 time time)
(* -0.00000239 time time time))
360.0))
+ (eclipse (eclipse-check moon-lat phase))
(adjustment
(if (memq phase '(0 2))
(+ (* (- 0.1734 (* 0.000393 time))
@@ -146,7 +147,26 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
(time (* 24 (- date (truncate date))))
(date (calendar-gregorian-from-absolute (truncate date)))
(adj (dst-adjust-time date time)))
- (list (car adj) (apply 'solar-time-string (cdr adj)) phase)))
+ (list (car adj) (apply 'solar-time-string (cdr adj)) phase eclipse)))
+
+;; from "Astronomy with your Personal Computer", Subroutine Eclipse
+;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990
+(defun eclipse-check (moon-lat phase)
+ (let* ((moon-lat (* (/ float-pi 180) moon-lat))
+ (moon-lat (abs (- moon-lat (* (floor (/ moon-lat float-pi))
+ float-pi))))
+ (moon-lat (if (> moon-lat 0.37)
+ (- float-pi moon-lat)
+ moon-lat))
+ (phase-name (cond ((= phase 0) "Solar")
+ ((= phase 2) "Lunar")
+ (t ""))))
+ (cond ((< moon-lat 2.42600766e-1)
+ (concat "** " phase-name " Eclipse **"))
+ ((< moon-lat 0.37)
+ (concat "** " phase-name " Eclipse possible **"))
+ (t
+ ""))))
(defconst lunar-cycles-per-year 12.3685 ; 365.25/29.530588853
"Mean number of lunar cycles per 365.25 day year.")
@@ -222,9 +242,10 @@ use instead of point."
(insert
(mapconcat
(lambda (x)
- (format "%s: %s %s" (calendar-date-string (car x))
+ (format "%s: %s %s %s" (calendar-date-string (car x))
(lunar-phase-name (nth 2 x))
- (cadr x)))
+ (cadr x)
+ (car (last x))))
(lunar-phase-list m1 y1) "\n")))
(message "Computing phases of the moon...done"))))
@@ -234,6 +255,8 @@ use instead of point."
If called with an optional prefix argument ARG, prompts for month and year.
This function is suitable for execution in an init file."
(interactive "P")
+ (with-suppressed-warnings ((lexical date))
+ (defvar date))
(save-excursion
(let* ((date (if arg (calendar-read-date t)
(calendar-current-date)))
@@ -241,18 +264,17 @@ This function is suitable for execution in an init file."
(displayed-year (calendar-extract-year date)))
(calendar-lunar-phases))))
-;; The function below is designed to be used in sexp diary entries,
-;; and may be present in users' diary files, so suppress the warning
-;; about this prefix-less dynamic variable. It's called from
-;; `diary-list-sexp-entries', which binds the variable.
-(with-suppressed-warnings ((lexical date))
- (defvar date))
-
;;;###diary-autoload
(defun diary-lunar-phases (&optional mark)
"Moon phases diary entry.
An optional parameter MARK specifies a face or single-character string to
use when highlighting the day in the calendar."
+ ;; This function is designed to be used in sexp diary entries, and
+ ;; may be present in users' diary files, so suppress the warning
+ ;; about this prefix-less dynamic variable. It's called from
+ ;; `diary-list-sexp-entries', which binds the variable.
+ (with-suppressed-warnings ((lexical date))
+ (defvar date))
(let* ((index (lunar-index date))
(phase (lunar-phase index)))
(while (calendar-date-compare phase (list date))
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index eed12cacfc7..5a3d2706afd 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -29,7 +29,7 @@
;; `parse-time-string' parses a time in a string and returns a list of
;; values, just like `decode-time', where unspecified elements in the
-;; string are returned as nil (except unspecfied DST is returned as -1).
+;; string are returned as nil (except unspecified DST is returned as -1).
;; `encode-time' may be applied on these values to obtain an internal
;; time value.
@@ -103,108 +103,108 @@ letters, digits, plus or minus signs or colons."
((4) parse-time-months)
((5) (100))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 8)
- (= (aref parse-time-elt 2) ?:)
- (= (aref parse-time-elt 5) ?:)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 8)
+ (= (aref parse-time-elt 2) ?:)
+ (= (aref parse-time-elt 5) ?:)))
[0 2] [3 5] [6 8])
((8 7) parse-time-zoneinfo
- ,#'(lambda () (car parse-time-val))
- ,#'(lambda () (cadr parse-time-val)))
+ ,(lambda () (car parse-time-val))
+ ,(lambda () (cadr parse-time-val)))
((8)
- ,#'(lambda ()
- (and (stringp parse-time-elt)
- (= 5 (length parse-time-elt))
- (or (= (aref parse-time-elt 0) ?+)
- (= (aref parse-time-elt 0) ?-))))
- ,#'(lambda () (* 60 (+ (cl-parse-integer parse-time-elt :start 3 :end 5)
- (* 60 (cl-parse-integer parse-time-elt :start 1 :end 3)))
- (if (= (aref parse-time-elt 0) ?-) -1 1))))
+ ,(lambda ()
+ (and (stringp parse-time-elt)
+ (= 5 (length parse-time-elt))
+ (or (= (aref parse-time-elt 0) ?+)
+ (= (aref parse-time-elt 0) ?-))))
+ ,(lambda () (* 60 (+ (cl-parse-integer parse-time-elt :start 3 :end 5)
+ (* 60 (cl-parse-integer parse-time-elt :start 1 :end 3)))
+ (if (= (aref parse-time-elt 0) ?-) -1 1))))
((5 4 3)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 10)
- (= (aref parse-time-elt 4) ?-)
- (= (aref parse-time-elt 7) ?-)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 10)
+ (= (aref parse-time-elt 4) ?-)
+ (= (aref parse-time-elt 7) ?-)))
[0 4] [5 7] [8 10])
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 5)
- (= (aref parse-time-elt 2) ?:)))
- [0 2] [3 5] ,#'(lambda () 0))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 5)
+ (= (aref parse-time-elt 2) ?:)))
+ [0 2] [3 5] ,(lambda () 0))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 4)
- (= (aref parse-time-elt 1) ?:)))
- [0 1] [2 4] ,#'(lambda () 0))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 4)
+ (= (aref parse-time-elt 1) ?:)))
+ [0 1] [2 4] ,(lambda () 0))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 7)
- (= (aref parse-time-elt 1) ?:)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 7)
+ (= (aref parse-time-elt 1) ?:)))
[0 1] [2 4] [5 7])
- ((5) (50 110) ,#'(lambda () (+ 1900 parse-time-elt)))
- ((5) (0 49) ,#'(lambda () (+ 2000 parse-time-elt))))
+ ((5) (50 110) ,(lambda () (+ 1900 parse-time-elt)))
+ ((5) (0 49) ,(lambda () (+ 2000 parse-time-elt))))
"(slots predicate extractor...)")
;;;###autoload(put 'parse-time-rules 'risky-local-variable t)
;;;###autoload
(defun parse-time-string (string)
"Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ).
-STRING should be something resembling an RFC 822 (or later) date-time, e.g.,
-\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is
+STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\",
+or something resembling an RFC 822 (or later) date-time, e.g.,
+\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is
somewhat liberal in what format it accepts, and will attempt to
return a \"likely\" value even for somewhat malformed strings.
The values returned are identical to those of `decode-time', but
any unknown values other than DST are returned as nil, and an
unknown DST value is returned as -1."
- (let ((time (list nil nil nil nil nil nil nil -1 nil))
- (temp (parse-time-tokenize (downcase string))))
- (while temp
- (let ((parse-time-elt (pop temp))
- (rules parse-time-rules)
- (exit nil))
- (while (and rules (not exit))
- (let* ((rule (pop rules))
- (slots (pop rule))
- (predicate (pop rule))
- (parse-time-val))
- (when (and (not (nth (car slots) time)) ;not already set
- (setq parse-time-val
- (cond ((and (consp predicate)
- (not (functionp predicate)))
- (and (numberp parse-time-elt)
- (<= (car predicate) parse-time-elt)
- (or (not (cdr predicate))
- (<= parse-time-elt
- (cadr predicate)))
- parse-time-elt))
- ((symbolp predicate)
- (cdr (assoc parse-time-elt
- (symbol-value predicate))))
- ((funcall predicate)))))
- (setq exit t)
- (while slots
- (let ((new-val (if rule
- (let ((this (pop rule)))
- (if (vectorp this)
- (cl-parse-integer
- parse-time-elt
- :start (aref this 0)
- :end (aref this 1))
- (funcall this)))
- parse-time-val)))
- (setf (nth (pop slots) time) new-val))))))))
- time))
+ (condition-case ()
+ (iso8601-parse string)
+ (wrong-type-argument
+ (let ((time (list nil nil nil nil nil nil nil -1 nil))
+ (temp (parse-time-tokenize (downcase string))))
+ (while temp
+ (let ((parse-time-elt (pop temp))
+ (rules parse-time-rules)
+ (exit nil))
+ (while (and rules (not exit))
+ (let* ((rule (pop rules))
+ (slots (pop rule))
+ (predicate (pop rule))
+ (parse-time-val))
+ (when (and (not (nth (car slots) time)) ;not already set
+ (setq parse-time-val
+ (cond ((and (consp predicate)
+ (not (functionp predicate)))
+ (and (numberp parse-time-elt)
+ (<= (car predicate) parse-time-elt)
+ (or (not (cdr predicate))
+ (<= parse-time-elt
+ (cadr predicate)))
+ parse-time-elt))
+ ((symbolp predicate)
+ (cdr (assoc parse-time-elt
+ (symbol-value predicate))))
+ ((funcall predicate)))))
+ (setq exit t)
+ (while slots
+ (let ((new-val (if rule
+ (let ((this (pop rule)))
+ (if (vectorp this)
+ (cl-parse-integer
+ parse-time-elt
+ :start (aref this 0)
+ :end (aref this 1))
+ (funcall this)))
+ parse-time-val)))
+ (setf (nth (pop slots) time) new-val))))))))
+ time))))
(defun parse-iso8601-time-string (date-string)
- "Parse an ISO 8601 time string, such as 2016-12-01T23:35:06-05:00.
-If DATE-STRING cannot be parsed, it falls back to
-`parse-time-string'."
- (when-let ((time
- (if (iso8601-valid-p date-string)
- (decoded-time-set-defaults (iso8601-parse date-string))
- ;; Fall back to having `parse-time-string' do fancy
- ;; things for us.
- (parse-time-string date-string))))
+ "Parse an ISO 8601 time string, such as \"2020-01-15T16:12:21-08:00\".
+Fall back on parsing something resembling an RFC 822 (or later) date-time.
+This function is like `parse-time-string' except that it returns
+a Lisp timestamp when successful."
+ (when-let ((time (parse-time-string date-string)))
(encode-time time)))
(provide 'parse-time)
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index b499a238bf3..b5f2f454aea 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -209,7 +209,6 @@ Returns nil if nothing was entered."
(defun solar-setup ()
"Prompt for `calendar-longitude', `calendar-latitude', `calendar-time-zone'."
- (beep)
(or calendar-longitude
(setq calendar-longitude
(solar-get-number
@@ -491,8 +490,8 @@ Uses binary search."
(utmin (+ ut (* direction 12.0)))
(utmax ut) ; the time searched is between utmin and utmax
;; utmin and utmax are in hours.
- (utmoment-old 0.0) ; rise or set approximation
- (utmoment 1.0) ; rise or set approximation
+ (utmoment-old utmin) ; rise or set approximation
+ (utmoment utmax) ; rise or set approximation
(hut 0) ; sun height at utmoment
(t0 (car time))
(hmin (cadr (solar-horizontal-coordinates (list t0 utmin)
@@ -553,7 +552,7 @@ degrees to find out if polar regions have 24 hours of sun or only night."
Format used is given by `calendar-time-display-form'."
(let* ((time (round (* 60 time)))
(24-hours (/ time 60)))
- (calendar-dlet*
+ (calendar-dlet
((time-zone time-zone)
(minutes (format "%02d" (% time 60)))
(12-hours (format "%d" (1+ (% (+ 24-hours 11) 12))))
@@ -840,7 +839,9 @@ This function is suitable for execution in an init file."
"E" "W"))))))
(calendar-standard-time-zone-name
(if (< arg 16) calendar-standard-time-zone-name
- (cond ((zerop calendar-time-zone) "UTC")
+ (cond ((zerop calendar-time-zone)
+ (if (eq calendar-time-zone-style 'numeric)
+ "+0000" "UTC"))
((< calendar-time-zone 0)
(format "UTC%dmin" calendar-time-zone))
(t (format "UTC+%dmin" calendar-time-zone)))))
@@ -1013,7 +1014,10 @@ Requires floating point."
(let* ((m displayed-month)
(y displayed-year)
(calendar-standard-time-zone-name
- (if calendar-time-zone calendar-standard-time-zone-name "UTC"))
+ (cond
+ (calendar-time-zone calendar-standard-time-zone-name)
+ ((eq calendar-time-zone-style 'numeric) "+0000")
+ (t "UTC")))
(calendar-daylight-savings-starts
(if calendar-time-zone calendar-daylight-savings-starts))
(calendar-daylight-savings-ends
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 789b7e1d428..1c169b78fd6 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -1,4 +1,4 @@
-;;; time-date.el --- Date and time handling functions
+;;; time-date.el --- Date and time handling functions -*- lexical-binding: t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -278,6 +278,10 @@ Lower-case specifiers return only the unit.
optional leading \".\" for zero-padding. For example, \"%.3Y\" will
return something of the form \"001 year\".
+The \"%s\" spec takes an additional optional parameter,
+introduced by the \",\" character, to say how many decimals to
+use. \"%,1s\" means \"use one decimal\".
+
The \"%z\" specifier does not print anything. When it is used, specifiers
must be given in order of decreasing size. To the left of \"%z\", nothing
is output until the first non-zero unit is encountered."
@@ -289,10 +293,11 @@ is output until the first non-zero unit is encountered."
("s" "second" 1)
("z")))
(case-fold-search t)
- spec match usedunits zeroflag larger prev name unit num zeropos)
- (while (string-match "%\\.?[0-9]*\\(.\\)" string start)
+ spec match usedunits zeroflag larger prev name unit num zeropos
+ fraction)
+ (while (string-match "%\\.?[0-9]*\\(,[0-9]\\)?\\(.\\)" string start)
(setq start (match-end 0)
- spec (match-string 1 string))
+ spec (match-string 2 string))
(unless (string-equal spec "%")
(or (setq match (assoc (downcase spec) units))
(error "Bad format specifier: `%s'" spec))
@@ -307,12 +312,17 @@ is output until the first non-zero unit is encountered."
(push match usedunits)))
(and zeroflag larger
(error "Units are not in decreasing order of size"))
- (setq seconds (time-convert seconds 'integer))
+ (unless (numberp seconds)
+ (setq seconds (float-time seconds)))
+ (setq fraction (mod seconds 1)
+ seconds (round seconds))
(dolist (u units)
(setq spec (car u)
name (cadr u)
unit (nth 2 u))
- (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(%s\\)" spec) string)
+ (when (string-match
+ (format "%%\\(\\.?[0-9]+\\)?\\(,[0-9]+\\)?\\(%s\\)" spec)
+ string)
(if (string-equal spec "z") ; must be last in units
(setq string
(replace-regexp-in-string
@@ -327,9 +337,23 @@ is output until the first non-zero unit is encountered."
(setq zeropos (unless (zerop num) (match-beginning 0))))
(setq string
(replace-match
- (format (concat "%" (match-string 1 string) "d%s") num
- (if (string-equal (match-string 2 string) spec)
- "" ; lower-case, no unit-name
+ (format (if (match-string 2 string)
+ (concat
+ "%"
+ (and (match-string 1 string)
+ (if (= (elt (match-string 1 string) 0) ?.)
+ (concat "0" (substring
+ (match-string 1 string) 1))
+ (match-string 1 string)))
+ (concat "." (substring
+ (match-string 2 string) 1))
+ "f%s")
+ (concat "%" (match-string 1 string) "d%s"))
+ (if (= unit 1)
+ (+ num fraction)
+ num)
+ (if (string-equal (match-string 3 string) spec)
+ "" ; lower-case, no unit-name
(format " %s%s" name
(if (= num 1) "" "s"))))
t t string))))))
@@ -355,6 +379,8 @@ is output until the first non-zero unit is encountered."
(defun date-days-in-month (year month)
"The number of days in MONTH in YEAR."
+ (unless (and (numberp month) (<= 1 month 12))
+ (error "Month %s is invalid" month))
(if (= month 2)
(if (date-leap-year-p year)
29
@@ -399,10 +425,10 @@ changes in daylight saving time are not taken into account."
(when (decoded-time-year delta)
(cl-incf (decoded-time-year time) (decoded-time-year delta)))
- ;; Months are pretty simple.
+ ;; Months are pretty simple, but start at 1 (for January).
(when (decoded-time-month delta)
- (let ((new (+ (decoded-time-month time) (decoded-time-month delta))))
- (setf (decoded-time-month time) (mod new 12))
+ (let ((new (+ (1- (decoded-time-month time)) (decoded-time-month delta))))
+ (setf (decoded-time-month time) (1+ (mod new 12)))
(cl-incf (decoded-time-year time) (/ new 12))))
;; Adjust for month length (as described in the doc string).
@@ -499,6 +525,8 @@ changes in daylight saving time are not taken into account."
(defun decoded-time-set-defaults (time &optional default-zone)
"Set any nil values in `decoded-time' TIME to default values.
The default value is based on January 1st, 1970 at midnight.
+This year is used to guarantee portability; see Info
+node `(elisp) Time of Day'.
TIME is modified and returned."
(unless (decoded-time-second time)
@@ -513,19 +541,33 @@ TIME is modified and returned."
(unless (decoded-time-month time)
(setf (decoded-time-month time) 1))
(unless (decoded-time-year time)
- (setf (decoded-time-year time) 0))
+ (setf (decoded-time-year time) 1970))
- ;; When we don't have a time zone and we don't have a DST, then mark
- ;; it as unknown.
- (when (and (not (decoded-time-zone time))
- (not (decoded-time-dst time)))
- (setf (decoded-time-dst time) -1))
+ ;; When we don't have a time zone, default to DEFAULT-ZONE without
+ ;; DST if DEFAULT-ZONE if given, and to unknown DST otherwise.
+ (unless (decoded-time-zone time)
+ (if default-zone
+ (progn (setf (decoded-time-zone time) default-zone)
+ (setf (decoded-time-dst time) nil))
+ (setf (decoded-time-dst time) -1)))
- (when (and (not (decoded-time-zone time))
- default-zone)
- (setf (decoded-time-zone time) 0))
time)
+(defun decoded-time-period (time)
+ "Interpret DECODED as a period and return its length in seconds.
+For computational purposes, years are 365 days long and months
+are 30 days long."
+ (+ (if (consp (decoded-time-second time))
+ ;; Fractional second.
+ (/ (float (car (decoded-time-second time)))
+ (cdr (decoded-time-second time)))
+ (or (decoded-time-second time) 0))
+ (* (or (decoded-time-minute time) 0) 60)
+ (* (or (decoded-time-hour time) 0) 60 60)
+ (* (or (decoded-time-day time) 0) 60 60 24)
+ (* (or (decoded-time-month time) 0) 60 60 24 30)
+ (* (or (decoded-time-year time) 0) 60 60 24 365)))
+
(provide 'time-date)
;;; time-date.el ends here
diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el
index 3c00d12cb66..4a4b65d3745 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -4,7 +4,7 @@
;; Author: John Wiegley <johnw@gnu.org>
;; Created: 25 Mar 1999
-;; Version: 2.6.1
+;; Old-Version: 2.6.1
;; Keywords: calendar data
;; This file is part of GNU Emacs.
@@ -37,8 +37,6 @@
;; You'll probably want to bind the timeclock commands to some handy
;; keystrokes. At the moment, C-x t is unused:
;;
-;; (require 'timeclock)
-;;
;; (define-key ctl-x-map "ti" 'timeclock-in)
;; (define-key ctl-x-map "to" 'timeclock-out)
;; (define-key ctl-x-map "tc" 'timeclock-change)
@@ -71,8 +69,6 @@
;; your average working time, and will make sure that the various
;; display functions return the correct value.
-;;; History:
-
;;; Code:
(require 'cl-lib)
@@ -193,6 +189,8 @@ to today."
(defcustom timeclock-load-hook nil
"Hook that gets run after timeclock has been loaded."
:type 'hook)
+(make-obsolete-variable 'timeclock-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom timeclock-in-hook nil
"A hook run every time an \"in\" event is recorded."
@@ -595,9 +593,9 @@ arguments of `completing-read'."
(defun timeclock-ask-for-project ()
"Ask the user for the project they are clocking into."
(completing-read
- (format "Clock into which project (default %s): "
- (or timeclock-last-project
- (car timeclock-project-list)))
+ (format-prompt "Clock into which project"
+ (or timeclock-last-project
+ (car timeclock-project-list)))
timeclock-project-list
nil nil nil nil
(or timeclock-last-project
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index fca0b16f445..680beb85aff 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -191,7 +191,7 @@ The final element is \"*\", indicating an unspecified month.")
(defconst todo-date-pattern
(let ((dayname (diary-name-pattern calendar-day-name-array nil t)))
(concat "\\(?4:\\(?5:" dayname "\\)\\|"
- (calendar-dlet*
+ (calendar-dlet
((dayname)
(monthname (format "\\(?6:%s\\)" (diary-name-pattern
todo-month-name-array
@@ -1937,11 +1937,13 @@ their associated keys and their effects."
(find-file-noselect file 'nowarn)
(set-window-buffer (selected-window)
(set-buffer (find-buffer-visiting file)))
- ;; If this command was invoked outside of a Todo mode buffer,
- ;; the call to todo-current-category above returned nil. If
- ;; we just entered Todo mode now, then cat was set to the
- ;; file's first category, but if todo-mode was already
- ;; enabled, cat did not get set, so we have to do that.
+ ;; If FILE is not in Todo mode, set it now, which also sets
+ ;; CAT to the file's first category.
+ (unless (derived-mode-p 'todo-mode) (todo-mode))
+ ;; But if FILE was already in todo-mode and the item insertion
+ ;; command was invoked outside of a Todo mode buffer, the
+ ;; above calls to todo-current-category returned nil, so we
+ ;; have to explicitly set CAT to the current category.
(unless cat
(setq cat (todo-current-category)))
(setq todo-current-todo-file file)
@@ -2169,7 +2171,9 @@ the item at point."
(if comment-delete
(when (todo-y-or-n-p "Delete comment? ")
(delete-region (match-beginning 0) (match-end 0)))
- (replace-match (read-string prompt (cons (match-string 1) 1))
+ (replace-match (save-match-data
+ (read-string prompt
+ (cons (match-string 1) 1)))
nil nil nil 1))
(if comment-delete
(user-error "There is no comment to delete")
@@ -2275,7 +2279,7 @@ made in the number or names of categories."
(inc (prefix-numeric-value inc))
(buffer-read-only nil)
ndate ntime
- year monthname month day dayname)
+ year monthname month day) ;; dayname
(when marked (todo--user-error-if-marked-done-item))
(save-excursion
(or (and marked (goto-char (point-min))) (todo-item-start))
@@ -2348,25 +2352,35 @@ made in the number or names of categories."
((or (string= omonth "*") (= mm 13))
(user-error "Cannot increment *"))
(t
- (let ((mminc (+ mm inc (if (< inc 0) 12 0))))
- ;; Increment or decrement month by INC
- ;; modulo 12.
- (setq mm (% mminc 12))
- ;; If result is 0, make month December.
- (setq mm (if (= mm 0) 12 (abs mm)))
+ (let* ((mmo mm)
+ ;; Change by 12 or more months?
+ (bigincp (>= (abs inc) 12))
+ ;; Month number is in range 1..12.
+ (mminc (+ mm (% inc 12)))
+ (mm (% (+ mminc 12) 12))
+ ;; 12n mod 12 = 0, so 0 is December.
+ (mm (if (= mm 0) 12 mm))
+ ;; Does change in month cross year?
+ (mmcmp (cond ((< inc 0) (> mm mmo))
+ ((> inc 0) (< mm mmo))))
+ (yyadjust (if bigincp
+ (+ (abs (/ inc 12))
+ (if mmcmp 1 0))
+ 1)))
;; Adjust year if necessary.
- (setq year (or (and (cond ((> mminc 12)
- (+ yy (/ mminc 12)))
- ((< mminc 1)
- (- yy (/ mminc 12) 1))
- (t yy))
- (number-to-string yy))
- oyear)))
- ;; Return the changed numerical month as
- ;; a string or the corresponding month name.
- (if omonth
- (number-to-string mm)
- (aref tma-array (1- mm))))))
+ (setq yy (cond ((and (< inc 0)
+ (or mmcmp bigincp))
+ (- yy yyadjust))
+ ((and (> inc 0)
+ (or mmcmp bigincp))
+ (+ yy yyadjust))
+ (t yy)))
+ (setq year (number-to-string yy))
+ ;; Return the changed numerical month as
+ ;; a string or the corresponding month name.
+ (if omonth
+ (number-to-string mm)
+ (aref tma-array (1- mm)))))))
;; Since the number corresponding to the arbitrary
;; month name "*" is out of the range of
;; calendar-last-day-of-month, set it to 1
@@ -2417,13 +2431,13 @@ made in the number or names of categories."
;; changed, rebuild the date string.
(when (memq what '(year month day))
(setq ndate
- (calendar-dlet*
+ (calendar-dlet
;; Needed by calendar-date-display-form.
((year year)
(monthname monthname)
(month month)
(day day)
- (dayname dayname))
+ (dayname nil)) ;; dayname
(mapconcat #'eval calendar-date-display-form "")))))
(when ndate (replace-match ndate nil nil nil 1))
;; Add new time string to the header, if it was supplied.
@@ -2731,9 +2745,10 @@ section in the category moved to."
(setq ov (make-overlay (save-excursion (todo-item-start))
(save-excursion (todo-item-end))))
(overlay-put ov 'face 'todo-search))
- (let* ((pl (if (and marked (> (cdr marked) 1)) "s" ""))
- (cat+file (todo-read-category (concat "Move item" pl
- " to category: ")
+ (let* ((num (if (not marked) 1 (cdr marked)))
+ (cat+file (todo-read-category
+ (ngettext "Move item to category: "
+ "Move items to category: " num)
nil file)))
(while (and (equal (car cat+file) cat1)
(equal (cdr cat+file) file1))
@@ -2960,7 +2975,7 @@ comments without asking."
(interactive)
(let* ((cat (todo-current-category))
(marked (assoc cat todo-categories-with-marks))
- (pl (if (and marked (> (cdr marked) 1)) "s" "")))
+ (num (if (not marked) 1 (cdr marked))))
(when (or marked (todo-done-item-p))
(let ((buffer-read-only)
(opoint (point))
@@ -2968,6 +2983,9 @@ comments without asking."
(first 'first)
(item-count 0)
(diary-count 0)
+ (omit-prompt (ngettext "Omit comment from restored item? "
+ "Omit comments from restored items? "
+ num))
start end item ov npoint undone)
(and marked (goto-char (point-min)))
(catch 'done
@@ -2999,10 +3017,7 @@ comments without asking."
(if (eq first 'first)
(setq first
(if (eq todo-undo-item-omit-comment 'ask)
- (when (todo-y-or-n-p
- (concat "Omit comment" pl
- " from restored item"
- pl "? "))
+ (when (todo-y-or-n-p omit-prompt)
'omit)
(when todo-undo-item-omit-comment 'omit)))
t)
@@ -3435,8 +3450,8 @@ containing only archived items, provided user option
are shown in `todo-archived-only' face."
(interactive)
(todo-display-categories)
- (let (sortkey)
- (todo-update-categories-display sortkey)))
+ ;; (let (sortkey)
+ (todo-update-categories-display nil)) ;; sortkey
(defun todo-next-button (n)
"Move point to the Nth next button in the table of categories."
@@ -4062,7 +4077,9 @@ regexp items."
((equal (file-name-extension f) "todt") "top")
((equal (file-name-extension f) "tody") "diary"))))
(push (cons (concat sf-name " (" type ")") f) falist)))
- (setq file (completing-read "Choose a filtered items file: " falist nil t nil
+ (setq file (completing-read (format-prompt "Choose a filtered items file"
+ (caar falist))
+ falist nil t nil
'todo--fifiles-history (caar falist)))
(setq file (cdr (assoc-string file falist)))
(find-file file)
@@ -4641,7 +4658,7 @@ strings built using the default value of
(defun todo-convert-legacy-date-time ()
"Return converted date-time string.
Helper function for `todo-convert-legacy-files'."
- (calendar-dlet*
+ (calendar-dlet
((year (match-string 1))
(month (match-string 2))
(monthname (calendar-month-name (string-to-number month) t))
@@ -4710,9 +4727,8 @@ name in `todo-directory'. See also the documentation string of
(todo-convert-legacy-date-time)))
(forward-line))
(setq file (concat todo-directory
- (read-string
- (format "Save file as (default \"%s\"): " default)
- nil nil default)
+ (read-string (format-prompt "Save file as" default)
+ nil nil default)
".todo"))
(unless (file-exists-p todo-directory)
(make-directory todo-directory))
@@ -5767,11 +5783,13 @@ have been removed."
(delete f todo-category-completions-files))
(push f deleted)))
(when deleted
- (let ((pl (> (length deleted) 1))
+ (let ((ndeleted (length deleted))
(names (mapconcat (lambda (f) (concat "\"" f "\"")) deleted ", ")))
- (message (concat "File" (if pl "s" "") " %s ha" (if pl "ve" "s")
- " been deleted and removed from\n"
- "the list of category completion files")
+ (message (concat
+ (ngettext "File %s has been deleted and removed from\n"
+ "Files %s have been deleted and removed from\n"
+ ndeleted)
+ "the list of category completion files")
names))
(put 'todo-category-completions-files 'custom-type
`(set ,@(todo--files-type-list)))
@@ -5923,8 +5941,15 @@ categories from `todo-category-completions-files'."
(todo-absolute-file-name
(let ((files (mapcar #'todo-short-file-name catfil)))
(completing-read (format str cat) files)))))))
- ;; Default to the current file.
- (unless file0 (setq file0 todo-current-todo-file))
+ ;; When called without arg FILE, use fallback todo file.
+ (unless file0 (setq file0 (or todo-current-todo-file
+ ;; If we're outside of todo-mode
+ ;; but there is a current todo
+ ;; file, use it.
+ todo-global-current-todo-file
+ ;; Else, use the default todo file.
+ (todo-absolute-file-name
+ todo-default-todo-file))))
;; First validate only a name passed interactively from
;; todo-add-category, which must be of a nonexistent category.
(unless (and (assoc cat categories) (not add))
@@ -6011,7 +6036,7 @@ indicating an unspecified month, day, or year.
When ARG is `day', non-nil arguments MO and YR determine the
number of the last the day of the month."
- (calendar-dlet*
+ (calendar-dlet
(year monthname month day dayname) ;Needed by calendar-date-display-form.
(when (or (not arg) (eq arg 'year))
(while (if (natnump year) (< year 1) (not (eq year '*)))
@@ -6087,11 +6112,12 @@ Valid time strings are those matching `diary-time-regexp'.
Typing `<return>' at the prompt returns the current time, if the
user option `todo-always-add-time-string' is non-nil, otherwise
the empty string (i.e., no time string)."
- (let (valid answer)
+ (let ((default (when todo-always-add-time-string
+ (format-time-string "%H:%M")))
+ valid answer)
(while (not valid)
- (setq answer (read-string "Enter a clock time: " nil nil
- (when todo-always-add-time-string
- (format-time-string "%H:%M"))))
+ (setq answer (read-string (format-prompt "Enter a clock time" default)
+ nil nil default))
(when (or (string= "" answer)
(string-match diary-time-regexp answer))
(setq valid t)))
@@ -6419,8 +6445,7 @@ Filtered Items mode following todo (not done) items."
("i" todo-insert-item)
("k" todo-delete-item)
("m" todo-move-item)
- ("u" todo-item-undone)
- ([remap newline] newline-and-indent))
+ ("u" todo-item-undone))
"List of key bindings for Todo mode only.")
(defvar todo-key-bindings-t+a+f
@@ -6486,7 +6511,6 @@ Filtered Items mode following todo (not done) items."
(defvar todo-edit-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-x\C-q" 'todo-edit-quit)
- (define-key map [remap newline] 'newline-and-indent)
map)
"Todo Edit mode keymap.")
@@ -6645,7 +6669,6 @@ Added to `window-configuration-change-hook' in Todo mode."
(setq-local font-lock-defaults '(todo-font-lock-keywords t))
(setq-local revert-buffer-function #'todo-revert-buffer)
(setq-local tab-width todo-indent-to-here)
- (setq-local indent-line-function #'todo-indent)
(when todo-wrap-lines
(visual-line-mode)
(setq wrap-prefix (make-string todo-indent-to-here 32))))
@@ -6720,6 +6743,7 @@ Added to `window-configuration-change-hook' in Todo mode."
\\{todo-edit-mode-map}"
(todo-modes-set-1)
+ (setq-local indent-line-function #'todo-indent)
(if (> (buffer-size) (- (point-max) (point-min)))
;; Editing one item in an indirect buffer, so buffer-file-name is nil.
(setq-local todo-current-todo-file todo-global-current-todo-file)
diff --git a/lisp/case-table.el b/lisp/case-table.el
index 1b3b30fc0a7..457e026f912 100644
--- a/lisp/case-table.el
+++ b/lisp/case-table.el
@@ -38,26 +38,26 @@
(interactive)
(let ((description (make-char-table 'case-table)))
(map-char-table
- (function (lambda (key value)
- (if (not (natnump value))
- (if (consp key)
- (set-char-table-range description key "case-invariant")
- (aset description key "case-invariant"))
- (let (from to)
- (if (consp key)
- (setq from (car key) to (cdr key))
- (setq from (setq to key)))
- (while (<= from to)
- (aset
- description from
- (cond ((/= from (downcase from))
- (concat "uppercase, matches "
- (char-to-string (downcase from))))
- ((/= from (upcase from))
- (concat "lowercase, matches "
- (char-to-string (upcase from))))
- (t "case-invariant")))
- (setq from (1+ from)))))))
+ (lambda (key value)
+ (if (not (natnump value))
+ (if (consp key)
+ (set-char-table-range description key "case-invariant")
+ (aset description key "case-invariant"))
+ (let (from to)
+ (if (consp key)
+ (setq from (car key) to (cdr key))
+ (setq from (setq to key)))
+ (while (<= from to)
+ (aset
+ description from
+ (cond ((/= from (downcase from))
+ (concat "uppercase, matches "
+ (char-to-string (downcase from))))
+ ((/= from (upcase from))
+ (concat "lowercase, matches "
+ (char-to-string (upcase from))))
+ (t "case-invariant")))
+ (setq from (1+ from))))))
(current-case-table))
(save-excursion
(with-output-to-temp-buffer "*Help*"
diff --git a/lisp/cdl.el b/lisp/cdl.el
index 679f29c3ce8..0f181ac6d4e 100644
--- a/lisp/cdl.el
+++ b/lisp/cdl.el
@@ -1,4 +1,4 @@
-;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs
+;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/ChangeLog.1 b/lisp/cedet/ChangeLog.1
index 05567e316f4..fb3dcd23965 100644
--- a/lisp/cedet/ChangeLog.1
+++ b/lisp/cedet/ChangeLog.1
@@ -301,7 +301,7 @@
manipulation of `ede-projects' with equivalent and better
functions.
(ede-proj-load): Replace call to test if dir has project to
- explicity ask filesystem if Project.ede is there.
+ explicitly ask filesystem if Project.ede is there.
* ede/config.el:
* ede/detect.el: New files.
@@ -2101,7 +2101,7 @@
by calling `srecode-cpp-apply-templates'.
* srecode/compile.el (srecode-compile-templates): Fix directory
- compare of built-in templates. Give built-ins lower piority.
+ compare of built-in templates. Give built-ins lower priority.
Support special variable "project".
(srecode-compile-template-table): Set :project slot of new tables.
(srecode-compile-one-template-tag):
diff --git a/lisp/cedet/cedet-cscope.el b/lisp/cedet/cedet-cscope.el
index 75a69db0a8c..6ffc2765d68 100644
--- a/lisp/cedet/cedet-cscope.el
+++ b/lisp/cedet/cedet-cscope.el
@@ -1,6 +1,6 @@
-;;; cedet-cscope.el --- CScope support for CEDET
+;;; cedet-cscope.el --- CScope support for CEDET -*- lexical-binding: t; -*-
-;;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Package: cedet
@@ -26,8 +26,6 @@
;;; Code:
-(declare-function inversion-check-version "inversion")
-
(defvar cedet-cscope-min-version "15.7"
"Minimum version of CScope required.")
@@ -36,7 +34,7 @@
:type 'string
:group 'cedet)
-(defun cedet-cscope-search (searchtext texttype type scope)
+(defun cedet-cscope-search (searchtext texttype type _scope)
"Perform a search with CScope, return the created buffer.
SEARCHTEXT is text to find.
TEXTTYPE is the type of text, such as `regexp', `string', `tagname',
@@ -87,7 +85,7 @@ options -cR."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-cscope-command
+ (apply #'call-process cedet-cscope-command
nil b nil
flags)
b))
@@ -139,7 +137,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if CScope isn't available,
return nil."
(interactive)
- (require 'inversion)
(let ((b (condition-case nil
(cedet-cscope-call (list "-V"))
(error nil)))
@@ -153,7 +150,7 @@ return nil."
(goto-char (point-min))
(re-search-forward "cscope: version \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
- (if (inversion-check-version rev nil cedet-cscope-min-version)
+ (if (version< rev cedet-cscope-min-version)
(if noerror
nil
(error "Version of CScope is %s. Need at least %s"
diff --git a/lisp/cedet/cedet-files.el b/lisp/cedet/cedet-files.el
index 31608159cc1..c9d557f5974 100644
--- a/lisp/cedet/cedet-files.el
+++ b/lisp/cedet/cedet-files.el
@@ -1,4 +1,4 @@
-;;; cedet-files.el --- Common routines dealing with file names.
+;;; cedet-files.el --- Common routines dealing with file names. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
index 5878ec1f485..227ebd54b86 100644
--- a/lisp/cedet/cedet-global.el
+++ b/lisp/cedet/cedet-global.el
@@ -1,4 +1,4 @@
-;;; cedet-global.el --- GNU Global support for CEDET.
+;;; cedet-global.el --- GNU Global support for CEDET. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;
;; Basic support for calling GNU Global, and testing version numbers.
-(declare-function inversion-check-version "inversion")
-
(defvar cedet-global-min-version "5.0"
"Minimum version of GNU Global required.")
@@ -77,7 +75,7 @@ SCOPE is the scope of the search, such as `project' or `subdirs'."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-global-command
+ (apply #'call-process cedet-global-command
nil b nil
flags)
b))
@@ -90,7 +88,7 @@ SCOPE is the scope of the search, such as `project' or `subdirs'."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-global-gtags-command
+ (apply #'call-process cedet-global-gtags-command
nil b nil
flags)
@@ -143,7 +141,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if Global isn't available,
return nil."
(interactive)
- (require 'inversion)
(let ((b (condition-case nil
(cedet-gnu-global-call (list "--version"))
(error nil)))
@@ -157,7 +154,7 @@ return nil."
(goto-char (point-min))
(re-search-forward "(?GNU GLOBAL)? \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
- (if (inversion-check-version rev nil cedet-global-min-version)
+ (if (version< rev cedet-global-min-version)
(if noerror
nil
(error "Version of GNU Global is %s. Need at least %s"
diff --git a/lisp/cedet/cedet-idutils.el b/lisp/cedet/cedet-idutils.el
index fc5e05af88e..a2b8cb35240 100644
--- a/lisp/cedet/cedet-idutils.el
+++ b/lisp/cedet/cedet-idutils.el
@@ -1,4 +1,4 @@
-;;; cedet-idutils.el --- ID Utils support for CEDET.
+;;; cedet-idutils.el --- ID Utils support for CEDET. -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -29,8 +29,6 @@
;;; Code:
-(declare-function inversion-check-version "inversion")
-
(defvar cedet-idutils-min-version "4.0"
"Minimum version of ID Utils required.")
@@ -49,7 +47,7 @@
:type 'string
:group 'cedet)
-(defun cedet-idutils-search (searchtext texttype type scope)
+(defun cedet-idutils-search (searchtext texttype type _scope)
"Perform a search with ID Utils, return the created buffer.
SEARCHTEXT is text to find.
TEXTTYPE is the type of text, such as `regexp', `string', `tagname',
@@ -66,7 +64,7 @@ Note: Scope is not yet supported."
(let* ((resultflg (if (eq texttype 'tagcompletions)
(list "--key=token")
(list "--result=grep")))
- (scopeflgs nil) ; (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
+ ;; (scopeflgs (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
(stflag (cond ((or (eq texttype 'tagname)
(eq texttype 'tagregexp))
(list "-r" "-w"))
@@ -79,7 +77,7 @@ Note: Scope is not yet supported."
;; t means 'symbol
(t (list "-l" "-w"))))
)
- (cedet-idutils-lid-call (append resultflg scopeflgs stflag
+ (cedet-idutils-lid-call (append resultflg nil stflag ;; scopeflgs
(list searchtext))))))
(defun cedet-idutils-fnid-call (flags)
@@ -91,7 +89,7 @@ Return the created buffer with program output."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-idutils-file-command
+ (apply #'call-process cedet-idutils-file-command
nil b nil
flags)
b))
@@ -105,7 +103,7 @@ Return the created buffer with program output."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-idutils-token-command
+ (apply #'call-process cedet-idutils-token-command
nil b nil
flags)
b))
@@ -119,7 +117,7 @@ Return the created buffer with program output."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process cedet-idutils-make-command
+ (apply #'call-process cedet-idutils-make-command
nil b nil
flags)
b))
@@ -135,7 +133,7 @@ Return a filename relative to the default directory."
(if (looking-at "[^ \n]*fnid: ")
(error "ID Utils not available")
(split-string (buffer-string) "\n" t)))))
- (setq ans (mapcar 'expand-file-name ans))
+ (setq ans (mapcar #'expand-file-name ans))
(when (called-interactively-p 'interactive)
(if ans
(if (= (length ans) 1)
@@ -167,7 +165,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if Global isn't available,
return nil."
(interactive)
- (require 'inversion)
(let ((b (condition-case nil
(cedet-idutils-fnid-call (list "--version"))
(error nil)))
@@ -182,7 +179,7 @@ return nil."
(if (re-search-forward "fnid - \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
(setq rev "0"))
- (if (inversion-check-version rev nil cedet-idutils-min-version)
+ (if (version< rev cedet-idutils-min-version)
(if noerror
nil
(error "Version of ID Utils is %s. Need at least %s"
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index caaec473a2c..b6043f1403e 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -1,4 +1,4 @@
-;;; cedet.el --- Setup CEDET environment
+;;; cedet.el --- Setup CEDET environment -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -48,25 +48,25 @@
(defvar cedet-menu-map ;(make-sparse-keymap "CEDET menu")
(let ((map (make-sparse-keymap "CEDET menu")))
- (define-key map [semantic-force-refresh] 'undefined)
- (define-key map [semantic-edit-menu] 'undefined)
- (define-key map [navigate-menu] 'undefined)
- (define-key map [semantic-options-separator] 'undefined)
- (define-key map [global-semantic-highlight-func-mode] 'undefined)
- (define-key map [global-semantic-stickyfunc-mode] 'undefined)
- (define-key map [global-semantic-decoration-mode] 'undefined)
- (define-key map [global-semantic-idle-completions-mode] 'undefined)
- (define-key map [global-semantic-idle-summary-mode] 'undefined)
- (define-key map [global-semantic-idle-scheduler-mode] 'undefined)
- (define-key map [global-semanticdb-minor-mode] 'undefined)
- (define-key map [cedet-menu-separator] 'undefined)
- (define-key map [ede-find-file] 'undefined)
- (define-key map [ede-speedbar] 'undefined)
- (define-key map [ede] 'undefined)
- (define-key map [ede-new] 'undefined)
- (define-key map [ede-target-options] 'undefined)
- (define-key map [ede-project-options] 'undefined)
- (define-key map [ede-build-forms-menu] 'undefined)
+ (define-key map [semantic-force-refresh] #'undefined)
+ (define-key map [semantic-edit-menu] #'undefined)
+ (define-key map [navigate-menu] #'undefined)
+ (define-key map [semantic-options-separator] #'undefined)
+ (define-key map [global-semantic-highlight-func-mode] #'undefined)
+ (define-key map [global-semantic-stickyfunc-mode] #'undefined)
+ (define-key map [global-semantic-decoration-mode] #'undefined)
+ (define-key map [global-semantic-idle-completions-mode] #'undefined)
+ (define-key map [global-semantic-idle-summary-mode] #'undefined)
+ (define-key map [global-semantic-idle-scheduler-mode] #'undefined)
+ (define-key map [global-semanticdb-minor-mode] #'undefined)
+ (define-key map [cedet-menu-separator] #'undefined)
+ (define-key map [ede-find-file] #'undefined)
+ (define-key map [ede-speedbar] #'undefined)
+ (define-key map [ede] #'undefined)
+ (define-key map [ede-new] #'undefined)
+ (define-key map [ede-target-options] #'undefined)
+ (define-key map [ede-project-options] #'undefined)
+ (define-key map [ede-build-forms-menu] #'undefined)
map)
"Menu keymap for the CEDET package.
This is used by `semantic-mode' and `global-ede-mode'.")
@@ -85,6 +85,7 @@ for the specified PACKAGE.
LOADED VERSION is the version of PACKAGE currently loaded in Emacs
memory and (presumably) running in this Emacs instance. Value is X
if the package has not been loaded."
+ (declare (obsolete emacs-version "28.1"))
(interactive)
(require 'inversion)
(with-output-to-temp-buffer "*CEDET*"
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
index ed6d1c56251..428848be04d 100644
--- a/lisp/cedet/data-debug.el
+++ b/lisp/cedet/data-debug.el
@@ -1,4 +1,4 @@
-;;; data-debug.el --- Data structure debugger
+;;; data-debug.el --- Data structure debugger -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -38,20 +38,19 @@
;; "Calculate something complicated at point, and return it."
;; (interactive) ;; function not normally interactive
;; (let ((stuff (do-stuff)))
-;; (when (interactive-p)
+;; (when (called-interactively-p 'interactive)
;; (data-debug-show-stuff stuff "myStuff"))
;; stuff))
-(require 'font-lock)
(require 'ring)
;;; Code:
;;; Compatibility
;;
-(defalias 'data-debug-overlay-properties 'overlay-properties)
-(defalias 'data-debug-overlay-p 'overlayp)
-(defalias 'dd-propertize 'propertize)
+(define-obsolete-function-alias 'data-debug-overlay-properties #'overlay-properties "28.1")
+(define-obsolete-function-alias 'data-debug-overlay-p #'overlayp "28.1")
+(define-obsolete-function-alias 'dd-propertize #'propertize "28.1")
;;; GENERIC STUFF
;;
@@ -73,7 +72,7 @@ The attributes belong to the tag PARENT."
"Insert all the parts of OVERLAY.
PREFIX specifies what to insert at the start of each line."
(let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
- (proplist (data-debug-overlay-properties overlay)))
+ (proplist (overlay-properties overlay)))
(data-debug-insert-property-list
proplist attrprefix)
)
@@ -101,14 +100,14 @@ PREBUTTONTEXT is some text between prefix and the overlay button."
(let ((start (point))
(end nil)
(str (format "%s" overlay))
- (tip nil))
+ ) ;; (tip nil)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
(put-text-property start end 'ddebug overlay)
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-overlay-from-point)
(insert "\n")
@@ -150,14 +149,14 @@ PREBUTTONTEXT is some text between prefix and the overlay list button."
(let ((start (point))
(end nil)
(str (format "#<overlay list: %d entries>" (length overlaylist)))
- (tip nil))
+ ) ;; (tip nil)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
(put-text-property start end 'ddebug overlaylist)
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-overlay-list-from-point)
(insert "\n")
@@ -205,14 +204,14 @@ PREBUTTONTEXT is some text between prefix and the buffer button."
(let ((start (point))
(end nil)
(str (format "%S" buffer))
- (tip nil))
+ ) ;; (tip nil)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
(put-text-property start end 'ddebug buffer)
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-buffer-from-point)
(insert "\n")
@@ -254,14 +253,14 @@ PREBUTTONTEXT is some text between prefix and the buffer list button."
(let ((start (point))
(end nil)
(str (format "#<buffer list: %d entries>" (length bufferlist)))
- (tip nil))
+ ) ;; (tip nil)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
(put-text-property start end 'ddebug bufferlist)
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-buffer-list-from-point)
(insert "\n")
@@ -310,14 +309,14 @@ PREBUTTONTEXT is some text between prefix and the process button."
(let ((start (point))
(end nil)
(str (format "%S : %s" process (process-status process)))
- (tip nil))
+ ) ;; (tip nil)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
(put-text-property start end 'ddebug process)
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-process-from-point)
(insert "\n")
@@ -364,8 +363,8 @@ PREBUTTONTEXT is some text between prefix and the stuff list button."
(str (format "#<RING: %d, %d max>"
(ring-length ring)
(ring-size ring)))
- (ringthing
- (if (= (ring-length ring) 0) nil (ring-ref ring 0)))
+ ;; (ringthing
+ ;; (if (= (ring-length ring) 0) nil (ring-ref ring 0)))
(tip (format "Ring max-size %d, length %d."
(ring-size ring)
(ring-length ring)))
@@ -393,10 +392,10 @@ PREBUTTONTEXT is some text between prefix and the stuff list button."
(lambda (key value)
(data-debug-insert-thing
key prefix
- (dd-propertize "key " 'face font-lock-comment-face))
+ (propertize "key " 'face font-lock-comment-face))
(data-debug-insert-thing
value prefix
- (dd-propertize "val " 'face font-lock-comment-face)))
+ (propertize "val " 'face font-lock-comment-face)))
hash-table))
(defun data-debug-insert-hash-table-from-point (point)
@@ -415,9 +414,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button."
(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext)
"Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text."
- (let ((string (dd-propertize (format "%s" hash-table)
+ (let ((string (propertize (format "%s" hash-table)
'face 'font-lock-keyword-face)))
- (insert (dd-propertize
+ (insert (propertize
(concat prefix prebuttontext string)
'ddebug hash-table
'ddebug-indent (length prefix)
@@ -438,13 +437,13 @@ PREBUTTONTEXT is some text between prefix and the stuff list button."
;; Widgets have a long list of properties
(defun data-debug-insert-widget-properties (widget prefix)
"Insert the contents of WIDGET inserting PREFIX before each element."
- (let ((type (car widget))
+ (let (;; (type (car widget))
(rest (cdr widget)))
(while rest
(data-debug-insert-thing (car (cdr rest))
prefix
(concat
- (dd-propertize (format "%s" (car rest))
+ (propertize (format "%s" (car rest))
'face font-lock-comment-face)
" : "))
(setq rest (cdr (cdr rest))))
@@ -468,9 +467,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button."
A Symbol is a simple thing, but this provides some face and prefix rules.
PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between prefix and the thing."
- (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget))
+ (let ((string (propertize (format "#<WIDGET %s>" (car widget))
'face 'font-lock-keyword-face)))
- (insert (dd-propertize
+ (insert (propertize
(concat prefix prebuttontext string)
'ddebug widget
'ddebug-indent (length prefix)
@@ -613,7 +612,7 @@ PREBUTTONTEXT is some text between prefix and the stuff vector button."
(symbol-value symbol)
(concat (make-string indent ? ) "> ")
(concat
- (dd-propertize "value"
+ (propertize "value"
'face 'font-lock-comment-face)
" ")))
(data-debug-insert-property-list
@@ -628,13 +627,13 @@ PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between prefix and the symbol button."
(let ((string
(cond ((fboundp symbol)
- (dd-propertize (concat "#'" (symbol-name symbol))
+ (propertize (concat "#'" (symbol-name symbol))
'face 'font-lock-function-name-face))
((boundp symbol)
- (dd-propertize (concat "'" (symbol-name symbol))
+ (propertize (concat "'" (symbol-name symbol))
'face 'font-lock-variable-name-face))
(t (format "'%s" symbol)))))
- (insert (dd-propertize
+ (insert (propertize
(concat prefix prebuttontext string)
'ddebug symbol
'ddebug-indent (length prefix)
@@ -657,7 +656,7 @@ PREBUTTONTEXT is some text between prefix and the thing."
(while (string-match "\t" newstr)
(setq newstr (replace-match "\\t" t t newstr)))
(insert prefix prebuttontext
- (dd-propertize (format "\"%s\"" newstr)
+ (propertize (format "\"%s\"" newstr)
'face font-lock-string-face)
"\n" )))
@@ -668,7 +667,7 @@ A Symbol is a simple thing, but this provides some face and prefix rules.
PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between prefix and the thing."
(insert prefix prebuttontext
- (dd-propertize (format "%S" thing)
+ (propertize (format "%S" thing)
'face font-lock-string-face)
"\n"))
@@ -684,7 +683,7 @@ PREBUTTONTEXT is some text between prefix and the thing."
)
;;; nil thing
-(defun data-debug-insert-nil (thing prefix prebuttontext)
+(defun data-debug-insert-nil (_thing prefix prebuttontext)
"Insert one simple THING with a face.
PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between prefix and the thing.
@@ -737,10 +736,10 @@ FACE is the face to use."
(null . data-debug-insert-nil)
;; Overlay
- (data-debug-overlay-p . data-debug-insert-overlay-button)
+ (overlayp . data-debug-insert-overlay-button)
;; Overlay list
- ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) .
+ ((lambda (thing) (and (consp thing) (overlayp (car thing)))) .
data-debug-insert-overlay-list-button)
;; Buffer
@@ -857,19 +856,18 @@ If PARENT is non-nil, it is somehow related as a parent to thing."
(defvar data-debug-mode-map
(let ((km (make-sparse-keymap)))
(suppress-keymap km)
- (define-key km [mouse-2] 'data-debug-expand-or-contract-mouse)
- (define-key km " " 'data-debug-expand-or-contract)
- (define-key km "\C-m" 'data-debug-expand-or-contract)
- (define-key km "n" 'data-debug-next)
- (define-key km "p" 'data-debug-prev)
- (define-key km "N" 'data-debug-next-expando)
- (define-key km "P" 'data-debug-prev-expando)
+ (define-key km [mouse-2] #'data-debug-expand-or-contract-mouse)
+ (define-key km " " #'data-debug-expand-or-contract)
+ (define-key km "\C-m" #'data-debug-expand-or-contract)
+ (define-key km "n" #'data-debug-next)
+ (define-key km "p" #'data-debug-prev)
+ (define-key km "N" #'data-debug-next-expando)
+ (define-key km "P" #'data-debug-prev-expando)
km)
"Keymap used in data-debug.")
(defcustom data-debug-mode-hook nil
"Hook run when data-debug starts."
- :group 'data-debug
:type 'hook)
(define-derived-mode data-debug-mode fundamental-mode "DATA-DEBUG"
@@ -880,11 +878,10 @@ If PARENT is non-nil, it is somehow related as a parent to thing."
comment-end ""
buffer-read-only t)
(setq-local comment-start-skip
- "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
(buffer-disable-undo)
- (set (make-local-variable 'font-lock-global-modes) nil)
- (font-lock-mode -1)
- )
+ (setq-local font-lock-global-modes nil)
+ (font-lock-mode -1))
;;;###autoload
(defun data-debug-new-buffer (name)
@@ -1034,7 +1031,7 @@ Do nothing if already contracted."
nil read-expression-map t
'read-expression-history))
))
- (let ((v (eval expr)))
+ (let ((v (eval expr t)))
(if (not v)
(message "Expression %s is nil." expr)
(data-debug-show-stuff v "expression"))))
@@ -1047,30 +1044,30 @@ If the result is a list or vector, then use the data debugger to display it."
(list (let ((minibuffer-completing-symbol t))
(read-from-minibuffer "Eval: "
nil read-expression-map t
- 'read-expression-history))
- ))
-
- (if (null eval-expression-debug-on-error)
- (setq values (cons (eval expr) values))
- (let ((old-value (make-symbol "t")) new-value)
- ;; Bind debug-on-error to something unique so that we can
- ;; detect when evalled code changes it.
- (let ((debug-on-error old-value))
- (setq values (cons (eval expr) values))
- (setq new-value debug-on-error))
- ;; If evalled code has changed the value of debug-on-error,
- ;; propagate that change to the global binding.
- (unless (eq old-value new-value)
- (setq debug-on-error new-value))))
-
- (if (or (consp (car values)) (vectorp (car values)))
- (let ((v (car values)))
- (data-debug-show-stuff v "Expression"))
- ;; Old style
- (prog1
- (prin1 (car values) t)
- (let ((str (eval-expression-print-format (car values))))
- (if str (princ str t))))))
+ 'read-expression-history))))
+
+ (let (result)
+ (if (null eval-expression-debug-on-error)
+ (setq result (values--store-value (eval expr t)))
+ (let ((old-value (make-symbol "t")) new-value)
+ ;; Bind debug-on-error to something unique so that we can
+ ;; detect when evalled code changes it.
+ (let ((debug-on-error old-value))
+ (setq result (values--store-value (eval expr t)))
+ (setq new-value debug-on-error))
+ ;; If evalled code has changed the value of debug-on-error,
+ ;; propagate that change to the global binding.
+ (unless (eq old-value new-value)
+ (setq debug-on-error new-value))))
+
+ (if (or (consp result) (vectorp result))
+ (let ((v result))
+ (data-debug-show-stuff v "Expression"))
+ ;; Old style
+ (prog1
+ (prin1 result t)
+ (let ((str (eval-expression-print-format result)))
+ (if str (princ str t)))))))
(provide 'data-debug)
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index 996aac812ca..2ec9f5d9d67 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1,4 +1,4 @@
-;;; ede.el --- Emacs Development Environment gloss
+;;; ede.el --- Emacs Development Environment gloss -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2005, 2007-2021 Free Software Foundation, Inc.
@@ -87,7 +87,6 @@ target wants the file, the user is asked. If only one target wants
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
:type '(choice (const always)
(const multi-ask)
(const ask)
@@ -95,7 +94,6 @@ target willing to take the file. `never' means never perform the check."
(defcustom ede-debug-program-function 'gdb
"Default Emacs command used to debug a target."
- :group 'ede
:type 'function) ; make this be a list of options some day
(defcustom ede-project-directories nil
@@ -112,7 +110,6 @@ If you invoke the commands \\[ede] or \\[ede-new] on a directory
that is not listed, Emacs will offer to add it to the list.
Any other value disables searching for EDE project files."
- :group 'ede
:type '(choice (const :tag "Any directory" t)
(repeat :tag "List of directories"
(directory))
@@ -140,22 +137,19 @@ specified by `ede-project-directories'."
(defvar ede-projects nil
"A list of all active projects currently loaded in Emacs.")
-(defvar ede-object-root-project nil
+(defvar-local ede-object-root-project nil
"The current buffer's current root project.
If a file is under a project, this specifies the project that is at
the root of a project tree.")
-(make-variable-buffer-local 'ede-object-root-project)
-(defvar ede-object-project nil
+(defvar-local ede-object-project nil
"The current buffer's current project at that level.
If a file is under a project, this specifies the project that contains the
current target.")
-(make-variable-buffer-local 'ede-object-project)
-(defvar ede-object nil
+(defvar-local ede-object nil
"The current buffer's target object.
This object's class determines how to compile and debug from a buffer.")
-(make-variable-buffer-local 'ede-object)
(defvar ede-selected-object nil
"The currently user-selected project or target.
@@ -189,21 +183,23 @@ Argument LIST-O-O is the list of objects to choose from."
;;; Menu and Keymap
+(declare-function ede-speedbar "ede/speedbar" ())
+
(defvar ede-minor-mode-map
(let ((map (make-sparse-keymap))
(pmap (make-sparse-keymap)))
- (define-key pmap "e" 'ede-edit-file-target)
- (define-key pmap "a" 'ede-add-file)
- (define-key pmap "d" 'ede-remove-file)
- (define-key pmap "t" 'ede-new-target)
- (define-key pmap "g" 'ede-rescan-toplevel)
- (define-key pmap "s" 'ede-speedbar)
- (define-key pmap "f" 'ede-find-file)
- (define-key pmap "C" 'ede-compile-project)
- (define-key pmap "c" 'ede-compile-target)
- (define-key pmap "\C-c" 'ede-compile-selected)
- (define-key pmap "D" 'ede-debug-target)
- (define-key pmap "R" 'ede-run-target)
+ (define-key pmap "e" #'ede-edit-file-target)
+ (define-key pmap "a" #'ede-add-file)
+ (define-key pmap "d" #'ede-remove-file)
+ (define-key pmap "t" #'ede-new-target)
+ (define-key pmap "g" #'ede-rescan-toplevel)
+ (define-key pmap "s" #'ede-speedbar)
+ (define-key pmap "f" #'ede-find-file)
+ (define-key pmap "C" #'ede-compile-project)
+ (define-key pmap "c" #'ede-compile-target)
+ (define-key pmap "\C-c" #'ede-compile-selected)
+ (define-key pmap "D" #'ede-debug-target)
+ (define-key pmap "R" #'ede-run-target)
;; bind our submap into map
(define-key map "\C-c." pmap)
map)
@@ -470,7 +466,7 @@ To be used in hook functions."
;; Emacs 21 has no buffer file name for directory edits.
;; so we need to add these hacks in.
(eq major-mode 'dired-mode)
- (eq major-mode 'vc-dired-mode))
+ (eq major-mode 'vc-dir-mode))
(ede-minor-mode 1)))
(define-minor-mode ede-minor-mode
@@ -479,9 +475,9 @@ To be used in hook functions."
If this file is contained, or could be contained in an EDE
controlled project, then this mode is activated automatically
provided `global-ede-mode' is enabled."
- :group 'ede
+ :global nil
(cond ((or (eq major-mode 'dired-mode)
- (eq major-mode 'vc-dired-mode))
+ (eq major-mode 'vc-dir-mode))
(ede-dired-minor-mode (if ede-minor-mode 1 -1)))
(ede-minor-mode
(if (not ede-constructing)
@@ -489,6 +485,9 @@ provided `global-ede-mode' is enabled."
;; If we fail to have a project here, turn it back off.
(ede-minor-mode -1)))))
+(declare-function ede-directory-project-cons "ede/files" (dir &optional force))
+(declare-function ede-toplevel-project-or-nil "ede/files" (dir))
+
(defun ede-initialize-state-current-buffer ()
"Initialize the current buffer's state for EDE.
Sets buffer local variables for EDE."
@@ -499,7 +498,7 @@ Sets buffer local variables for EDE."
;; Init the buffer.
(let* ((ROOT nil)
(proj (ede-directory-get-open-project default-directory
- 'ROOT)))
+ (gv-ref ROOT))))
(when (not proj)
;; If there is no open project, look up the project
@@ -520,7 +519,8 @@ Sets buffer local variables for EDE."
(ede-directory-safe-p top)))
;; The project is safe, so load it in.
- (setq proj (ede-load-project-file default-directory projdetect 'ROOT))))))
+ (setq proj (ede-load-project-file default-directory projdetect
+ (gv-ref ROOT)))))))
;; If PROJ is now loaded in, we can initialize our buffer to it.
(when proj
@@ -564,30 +564,29 @@ Sets buffer local variables for EDE."
This global minor mode enables `ede-minor-mode' in all buffers in
an EDE controlled project."
:global t
- :group 'ede
(if global-ede-mode
;; Turn on global-ede-mode
(progn
(if semantic-mode
(define-key cedet-menu-map [cedet-menu-separator] '("--")))
- (add-hook 'semanticdb-project-predicate-functions 'ede-directory-project-p)
- (add-hook 'semanticdb-project-root-functions 'ede-toplevel-project-or-nil)
- (add-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
+ (add-hook 'semanticdb-project-predicate-functions #'ede-directory-project-p)
+ (add-hook 'semanticdb-project-root-functions #'ede-toplevel-project-or-nil)
+ (add-hook 'ecb-source-path-functions #'ede-ecb-project-paths)
;; Append our hook to the end. This allows mode-local to finish
;; it's stuff before we start doing misc file loads, etc.
- (add-hook 'find-file-hook 'ede-turn-on-hook t)
- (add-hook 'dired-mode-hook 'ede-turn-on-hook)
- (add-hook 'kill-emacs-hook 'ede-save-cache)
+ (add-hook 'find-file-hook #'ede-turn-on-hook t)
+ (add-hook 'dired-mode-hook #'ede-turn-on-hook)
+ (add-hook 'kill-emacs-hook #'ede-save-cache)
(ede-load-cache)
(ede-reset-all-buffers))
;; Turn off global-ede-mode
(define-key cedet-menu-map [cedet-menu-separator] nil)
- (remove-hook 'semanticdb-project-predicate-functions 'ede-directory-project-p)
- (remove-hook 'semanticdb-project-root-functions 'ede-toplevel-project-or-nil)
- (remove-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
- (remove-hook 'find-file-hook 'ede-turn-on-hook)
- (remove-hook 'dired-mode-hook 'ede-turn-on-hook)
- (remove-hook 'kill-emacs-hook 'ede-save-cache)
+ (remove-hook 'semanticdb-project-predicate-functions #'ede-directory-project-p)
+ (remove-hook 'semanticdb-project-root-functions #'ede-toplevel-project-or-nil)
+ (remove-hook 'ecb-source-path-functions #'ede-ecb-project-paths)
+ (remove-hook 'find-file-hook #'ede-turn-on-hook)
+ (remove-hook 'dired-mode-hook #'ede-turn-on-hook)
+ (remove-hook 'kill-emacs-hook #'ede-save-cache)
(ede-save-cache)
(ede-reset-all-buffers)))
@@ -1083,7 +1082,7 @@ Flush the dead projects from the project cache."
(let ((dead nil))
(dolist (P ede-projects)
(when (not (file-exists-p (oref P file)))
- (add-to-list 'dead P)))
+ (cl-pushnew P dead :test #'equal)))
(dolist (D dead)
(ede-delete-project-from-global-list D))
))
@@ -1111,7 +1110,7 @@ Flush the dead projects from the project cache."
"Project file independent way to read a project in from DIR.
Optional DETECTIN is an autoload cons from `ede-detect-directory-for-project'
which can be passed in to save time.
-Optional ROOTRETURN will return the root project for DIR."
+Optional ROOTRETURN reference will return the root project for DIR."
;; Don't do anything if we are in the process of
;; constructing an EDE object.
;;
@@ -1150,7 +1149,8 @@ Optional ROOTRETURN will return the root project for DIR."
(setq o (ede-auto-load-project autoloader toppath))))
;; Return the found root project.
- (when rootreturn (set rootreturn o))
+ (when rootreturn (if (symbolp rootreturn) (set rootreturn o)
+ (setf (gv-deref rootreturn) o)))
;; The project has been found (in the global list) or loaded from
;; disk (via autoloader.) We can now search for the project asked
@@ -1507,6 +1507,8 @@ It does not apply the value to buffers."
;;; Integration with project.el
(defun project-try-ede (dir)
+ ;; FIXME: This passes the `ROOT' dynbound variable, but I don't know
+ ;; where it comes from!
(let ((project-dir
(locate-dominating-file
dir
@@ -1515,20 +1517,22 @@ It does not apply the value to buffers."
(when project-dir
(ede-directory-get-open-project project-dir 'ROOT))))
-(cl-defmethod project-roots ((project ede-project))
- (list (ede-project-root-directory project)))
+(cl-defmethod project-root ((project ede-project))
+ (ede-project-root-directory project))
+
+;;; FIXME: Could someone look into implementing `project-ignores' for
+;;; EDE and/or a faster `project-files'?
-(add-hook 'project-find-functions #'project-try-ede)
+(add-hook 'project-find-functions #'project-try-ede 50)
(provide 'ede)
;; Include this last because it depends on ede.
-(require 'ede/files)
+(if t (require 'ede/files)) ;; Don't bother loading it at compile-time.
;; If this does not occur after the provide, we can get a recursive
;; load. Yuck!
-(if (featurep 'speedbar)
- (ede-speedbar-file-setup)
- (add-hook 'speedbar-load-hook 'ede-speedbar-file-setup))
+(with-eval-after-load 'speedbar
+ (ede-speedbar-file-setup))
;;; ede.el ends here
diff --git a/lisp/cedet/ede/auto.el b/lisp/cedet/ede/auto.el
index ee75e297993..ee9d0116af3 100644
--- a/lisp/cedet/ede/auto.el
+++ b/lisp/cedet/ede/auto.el
@@ -1,4 +1,4 @@
-;;; ede/auto.el --- Autoload features for EDE
+;;; ede/auto.el --- Autoload features for EDE -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -64,24 +64,22 @@ location is varied dependent on other complex criteria, this class
can be used to define that match without loading the specific project
into memory.")
+(cl-defmethod ede-calc-fromconfig ((dirmatch ede-project-autoload-dirmatch))
+ "Calculate the value of :fromconfig from DIRMATCH."
+ (let* ((fc (oref dirmatch fromconfig))
+ (found (cond ((stringp fc) fc)
+ ((functionp fc) (funcall fc))
+ (t (error "Unknown dirmatch object match style.")))))
+ (expand-file-name found)
+ ))
+
(cl-defmethod ede-dirmatch-installed ((dirmatch ede-project-autoload-dirmatch))
"Return non-nil if the tool DIRMATCH might match is installed on the system."
- (let ((fc (oref dirmatch fromconfig)))
-
- (cond
- ;; If the thing to match is stored in a config file.
- ((stringp fc)
- (file-exists-p fc))
-
- ;; Add new types of dirmatches here.
-
- ;; Error for weird stuff
- (t (error "Unknown dirmatch type.")))))
-
+ (file-exists-p (ede-calc-fromconfig dirmatch)))
(cl-defmethod ede-do-dirmatch ((dirmatch ede-project-autoload-dirmatch) file)
"Does DIRMATCH match the filename FILE."
- (let ((fc (oref dirmatch fromconfig)))
+ (let ((fc (ede-calc-fromconfig dirmatch)))
(cond
;; If the thing to match is stored in a config file.
@@ -327,13 +325,13 @@ NOTE: Do not call this - it should only be called from `ede-load-project-file'."
;; See if we can do without them.
;; @FIXME - delete from loaddefs to remove this.
-(cl-defmethod ede-project-root ((this ede-project-autoload))
+(cl-defmethod ede-project-root ((_this ede-project-autoload))
"If a project knows its root, return it here.
Allows for one-project-object-for-a-tree type systems."
nil)
;; @FIXME - delete from loaddefs to remove this.
-(cl-defmethod ede-project-root-directory ((this ede-project-autoload) &optional file)
+(cl-defmethod ede-project-root-directory ((_this ede-project-autoload) &optional _file)
"" nil)
(provide 'ede/auto)
diff --git a/lisp/cedet/ede/autoconf-edit.el b/lisp/cedet/ede/autoconf-edit.el
index ca8535fdf23..d6f0a86f9ad 100644
--- a/lisp/cedet/ede/autoconf-edit.el
+++ b/lisp/cedet/ede/autoconf-edit.el
@@ -1,4 +1,4 @@
-;;; ede/autoconf-edit.el --- Keymap for autoconf
+;;; ede/autoconf-edit.el --- Keymap for autoconf -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2000, 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 7799746e0c4..103a37045cc 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -1,4 +1,4 @@
-;;; ede/base.el --- Baseclasses for EDE.
+;;; ede/base.el --- Baseclasses for EDE -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -47,7 +47,7 @@
;; and features of those files.
(defclass ede-target (eieio-speedbar-directory-button eieio-named)
- ((buttonface :initform speedbar-file-face) ;override for superclass
+ ((buttonface :initform 'speedbar-file-face) ;override for superclass
(name :initarg :name
:type string
:custom string
@@ -91,16 +91,16 @@ This is used to match target objects with the compilers they can use, and
which files this object is interested in."
:accessor ede-object-sourcecode)
(keybindings :allocation :class
- :initform (("D" . ede-debug-target))
+ :initform '(("D" . ede-debug-target))
:documentation
"Keybindings specialized to this type of target."
:accessor ede-object-keybindings)
(menu :allocation :class
- :initform ( [ "Debug target" ede-debug-target
- (ede-buffer-belongs-to-target-p) ]
- [ "Run target" ede-run-target
- (ede-buffer-belongs-to-target-p) ]
- )
+ :initform '( [ "Debug target" ede-debug-target
+ (ede-buffer-belongs-to-target-p) ]
+ [ "Run target" ede-run-target
+ (ede-buffer-belongs-to-target-p) ]
+ )
:documentation "Menu specialized to this type of target."
:accessor ede-object-menu)
)
@@ -160,16 +160,13 @@ and querying them will cause the actual project to get loaded.")
;; Projects can also affect how EDE works, by changing what appears in
;; the EDE menu, or how some keys are bound.
;;
-(unless (fboundp 'ede-target-list-p)
- (cl-deftype ede-target-list () '(list-of ede-target)))
-
(defclass ede-project (ede-project-placeholder)
((subproj :initform nil
:type list
:documentation "Sub projects controlled by this project.
For Automake based projects, each directory is treated as a project.")
(targets :initarg :targets
- :type ede-target-list
+ :type (list-of ede-target)
:custom (repeat (object :objectcreatefcn ede-new-target-custom))
:label "Local Targets"
:group (targets)
@@ -239,7 +236,7 @@ also be of a form used by TRAMP for use with scp, or rcp.")
This FTP site should be in Emacs form as needed by `ange-ftp'.
If this slot is nil, then use `ftp-site' instead.")
(configurations :initarg :configurations
- :initform ("debug" "release")
+ :initform '("debug" "release")
:type list
:custom (repeat string)
:label "Configuration Options"
@@ -261,25 +258,25 @@ and target specific elements such as build variables.")
:group (settings)
:documentation "Project local variables")
(keybindings :allocation :class
- :initform (("D" . ede-debug-target)
- ("R" . ede-run-target))
+ :initform '(("D" . ede-debug-target)
+ ("R" . ede-run-target))
:documentation "Keybindings specialized to this type of target."
:accessor ede-object-keybindings)
(menu :allocation :class
:initform
- (
- [ "Update Version" ede-update-version ede-object ]
- [ "Version Control Status" ede-vc-project-directory ede-object ]
- [ "Edit Project Homepage" ede-edit-web-page
- (and ede-object (oref (ede-toplevel) web-site-file)) ]
- [ "Browse Project URL" ede-web-browse-home
- (and ede-object
- (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
- "--"
- [ "Rescan Project Files" ede-rescan-toplevel t ]
- [ "Edit Projectfile" ede-edit-file-target
- (ede-buffer-belongs-to-project-p) ]
- )
+ '(
+ [ "Update Version" ede-update-version ede-object ]
+ [ "Version Control Status" ede-vc-project-directory ede-object ]
+ [ "Edit Project Homepage" ede-edit-web-page
+ (and ede-object (oref (ede-toplevel) web-site-file)) ]
+ [ "Browse Project URL" ede-web-browse-home
+ (and ede-object
+ (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
+ "--"
+ [ "Rescan Project Files" ede-rescan-toplevel t ]
+ [ "Edit Projectfile" ede-edit-file-target
+ (ede-buffer-belongs-to-project-p) ]
+ )
:documentation "Menu specialized to this type of target."
:accessor ede-object-menu)
)
@@ -291,7 +288,7 @@ All specific project types must derive from this project."
;;
(defmacro ede-with-projectfile (obj &rest forms)
"For the project in which OBJ resides, execute FORMS."
- (declare (indent 1))
+ (declare (indent 1) (debug t))
(unless (symbolp obj)
(message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
`(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
@@ -320,13 +317,15 @@ If set to nil, then the cache is not saved."
(defvar ede-project-cache-files nil
"List of project files EDE has seen before.")
+(defvar recentf-exclude)
+
(defun ede-save-cache ()
"Save a cache of EDE objects that Emacs has seen before."
(interactive)
(when ede-project-placeholder-cache-file
(let ((p ede-projects)
(c ede-project-cache-files)
- (recentf-exclude '( (lambda (f) t) ))
+ (recentf-exclude `( ,(lambda (_) t) ))
)
(condition-case nil
(progn
@@ -464,7 +463,7 @@ Not all buffers need headers, so return nil if no applicable."
(ede-buffer-header-file ede-object (current-buffer))
nil))
-(cl-defmethod ede-buffer-header-file ((this ede-project) buffer)
+(cl-defmethod ede-buffer-header-file ((_this ede-project) _buffer)
"Return nil, projects don't have header files."
nil)
@@ -490,12 +489,12 @@ Some projects may have multiple documentation files, so return a list."
(ede-buffer-documentation-files ede-object (current-buffer))
nil))
-(cl-defmethod ede-buffer-documentation-files ((this ede-project) buffer)
+(cl-defmethod ede-buffer-documentation-files ((this ede-project) _buffer)
"Return all documentation in project THIS based on BUFFER."
;; Find the info node.
(ede-documentation this))
-(cl-defmethod ede-buffer-documentation-files ((this ede-target) buffer)
+(cl-defmethod ede-buffer-documentation-files ((_this ede-target) buffer)
"Check for some documentation files for THIS.
Also do a quick check to see if there is a Documentation tag in this BUFFER."
(with-current-buffer buffer
@@ -521,7 +520,7 @@ files in the project."
proj (cdr proj)))
found))
-(cl-defmethod ede-documentation ((this ede-target))
+(cl-defmethod ede-documentation ((_this ede-target))
"Return a list of files that provide documentation.
Documentation is not for object THIS, but is provided by THIS for other
files in the project."
@@ -532,7 +531,7 @@ files in the project."
(ede-html-documentation (ede-toplevel))
)
-(cl-defmethod ede-html-documentation ((this ede-project))
+(cl-defmethod ede-html-documentation ((_this ede-project))
"Return a list of HTML files provided by project THIS."
)
@@ -639,18 +638,7 @@ PROJECT-FILE-NAME is a name of project file (short name, like `pom.xml', etc."
(oset this directory (file-name-directory (oref this file))))
)
-
-
-;;; Hooks & Autoloads
-;;
-;; These let us watch various activities, and respond appropriately.
-
-;; (add-hook 'edebug-setup-hook
-;; (lambda ()
-;; (def-edebug-spec ede-with-projectfile
-;; (form def-body))))
-
(provide 'ede/base)
;; Local variables:
diff --git a/lisp/cedet/ede/config.el b/lisp/cedet/ede/config.el
index 19686216cd5..98a0419e8bf 100644
--- a/lisp/cedet/ede/config.el
+++ b/lisp/cedet/ede/config.el
@@ -1,4 +1,4 @@
-;;; ede/config.el --- Configuration Handler baseclass
+;;; ede/config.el --- Configuration Handler baseclass -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
@@ -96,7 +96,7 @@ and also want to save some extra level of configuration.")
This filename excludes the directory name and is used to
initialize the :file slot of the persistent baseclass.")
(config-class
- :initform ede-extra-config
+ :initform 'ede-extra-config
:allocation :class
:type class
:documentation
@@ -171,7 +171,7 @@ the directory isn't on the `safe' list, ask to add it to the safe list."
(oset config project proj)))
config))
-(cl-defmethod ede-config-setup-configuration ((proj ede-project-with-config) config)
+(cl-defmethod ede-config-setup-configuration ((_proj ede-project-with-config) _config)
"Default configuration setup method."
nil)
@@ -187,7 +187,7 @@ the directory isn't on the `safe' list, ask to add it to the safe list."
(let ((config (ede-config-get-configuration proj t)))
(eieio-customize-object config)))
-(cl-defmethod ede-customize ((target ede-target-with-config))
+(cl-defmethod ede-customize ((_target ede-target-with-config))
"Customize the EDE TARGET by actually configuring the config object."
;; Nothing unique for the targets, use the project.
(ede-customize-project))
@@ -302,14 +302,14 @@ This class brings in method overloads for building.")
"Class to mix into a project with configuration for builds.
This class brings in method overloads for building.")
-(cl-defmethod project-compile-project ((proj ede-project-with-config-build) &optional command)
+(cl-defmethod project-compile-project ((proj ede-project-with-config-build) &optional _command)
"Compile the entire current project PROJ.
Argument COMMAND is the command to use when compiling."
(let* ((config (ede-config-get-configuration proj t))
(comp (oref config build-command)))
(compile comp)))
-(cl-defmethod project-compile-target ((obj ede-target-with-config-build) &optional command)
+(cl-defmethod project-compile-target ((_obj ede-target-with-config-build) &optional command)
"Compile the current target OBJ.
Argument COMMAND is the command to use for compiling the target."
(project-compile-project (ede-current-project) command))
diff --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el
index c558fcd893a..652d6476f02 100644
--- a/lisp/cedet/ede/cpp-root.el
+++ b/lisp/cedet/ede/cpp-root.el
@@ -1,4 +1,4 @@
-;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root
+;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -275,7 +275,7 @@ Each directory needs a project file to control it.")
;; objects is deleted.
(cl-defmethod initialize-instance ((this ede-cpp-root-project)
- &rest fields)
+ &rest _fields)
"Make sure the :file is fully expanded."
;; Add ourselves to the master list
(cl-call-next-method)
@@ -310,7 +310,7 @@ Each directory needs a project file to control it.")
;; project, simplifying authoring new single-point projects.
(cl-defmethod ede-find-subproject-for-directory ((proj ede-cpp-root-project)
- dir)
+ _dir)
"Return PROJ, for handling all subdirs below DIR."
proj)
@@ -319,7 +319,7 @@ Each directory needs a project file to control it.")
;; Creating new targets on a per directory basis is a good way to keep
;; files organized. See ede-emacs for an example with multiple file
;; types.
-(cl-defmethod ede-find-target ((proj ede-cpp-root-project) buffer)
+(cl-defmethod ede-find-target ((proj ede-cpp-root-project) _buffer)
"Find an EDE target in PROJ for BUFFER.
If one doesn't exist, create a new one for this directory."
(let* ((targets (oref proj targets))
@@ -451,7 +451,7 @@ This is for project include paths and spp source files."
"Get the pre-processor map for project THIS."
(ede-preprocessor-map (ede-target-parent this)))
-(cl-defmethod project-compile-project ((proj ede-cpp-root-project) &optional command)
+(cl-defmethod project-compile-project ((proj ede-cpp-root-project) &optional _command)
"Compile the entire current project PROJ.
Argument COMMAND is the command to use when compiling."
;; we need to be in the proj root dir for this to work
@@ -474,25 +474,10 @@ Argument COMMAND is the command to use for compiling the target."
(project-compile-project (oref obj project) command)))
-(cl-defmethod project-rescan ((this ede-cpp-root-project))
+(cl-defmethod project-rescan ((_this ede-cpp-root-project))
"Don't rescan this project from the sources."
(message "cpp-root has nothing to rescan."))
-;;; Quick Hack
-(defun ede-create-lots-of-projects-under-dir (dir projfile &rest attributes)
- "Create a bunch of projects under directory DIR.
-PROJFILE is a file name sans directory that indicates a subdirectory
-is a project directory.
-Generic ATTRIBUTES, such as :include-path can be added.
-Note: This needs some work."
- (let ((files (directory-files dir t)))
- (dolist (F files)
- (if (file-exists-p (expand-file-name projfile F))
- `(ede-cpp-root-project (file-name-nondirectory F)
- :name (file-name-nondirectory F)
- :file (expand-file-name projfile F)
- attributes)))))
-
(provide 'ede/cpp-root)
;; Local variables:
diff --git a/lisp/cedet/ede/custom.el b/lisp/cedet/ede/custom.el
index a8658a10f92..ac4f9f66846 100644
--- a/lisp/cedet/ede/custom.el
+++ b/lisp/cedet/ede/custom.el
@@ -1,4 +1,4 @@
-;;; ede/custom.el --- customization of EDE projects.
+;;; ede/custom.el --- customization of EDE projects. -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -50,11 +50,10 @@
(let* ((ov (oref (ede-current-project) local-variables))
(cp (ede-current-project)))
(ede-customize cp)
- (make-local-variable 'eieio-ede-old-variables)
- (setq eieio-ede-old-variables ov)))
+ (setq-local eieio-ede-old-variables ov)))
;;;###autoload
-(defalias 'customize-project 'ede-customize-project)
+(defalias 'customize-project #'ede-customize-project)
;;;###autoload
(defun ede-customize-current-target()
@@ -66,7 +65,7 @@
(ede-customize-target ede-object))
;;;###autoload
-(defalias 'customize-target 'ede-customize-current-target)
+(defalias 'customize-target #'ede-customize-current-target)
(defun ede-customize-target (obj)
"Edit fields of the current target through EIEIO & Custom.
@@ -98,13 +97,13 @@ OBJ is the target object to customize."
"Create a custom-like buffer for sorting targets of current project."
(interactive)
(let ((proj (ede-current-project))
- (count 1)
- current order)
+ ;; (count 1)
+ ) ;; current order
(switch-to-buffer (get-buffer-create "*EDE sort targets*"))
(erase-buffer)
(setq ede-object-project proj)
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _ignore)
(let ((targets (oref ede-object-project targets))
cur newtargets)
(while (setq cur (pop ede-project-sort-targets-order))
@@ -116,7 +115,7 @@ OBJ is the target object to customize."
" Accept ")
(widget-insert " ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _ignore)
(kill-buffer))
" Cancel ")
(widget-insert "\n\n")
@@ -134,45 +133,45 @@ OBJ is the target object to customize."
(defun ede-project-sort-targets-list ()
"Sort the target list while using `ede-project-sort-targets'."
(save-excursion
- (let ((count 0)
- (targets (oref ede-object-project targets))
+ (let ((targets (oref ede-object-project targets))
(inhibit-read-only t)
(inhibit-modification-hooks t))
(goto-char (point-min))
(forward-line 2)
(delete-region (point) (point-max))
- (while (< count (length targets))
+ (dotimes (count (length targets))
(if (> count 0)
(widget-create 'push-button
- :notify `(lambda (&rest ignore)
- (let ((cur ede-project-sort-targets-order))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth ,count cur)
- (1- ,count))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth (1- ,count) cur) ,count))
- (ede-project-sort-targets-list))
+ :notify (lambda (&rest _ignore)
+ (let ((cur ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth count cur)
+ (1- count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1- count) cur) count))
+ (ede-project-sort-targets-list))
" Up ")
(widget-insert " "))
(if (< count (1- (length targets)))
(widget-create 'push-button
- :notify `(lambda (&rest ignore)
- (let ((cur ede-project-sort-targets-order))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth ,count cur) (1+ ,count))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth (1+ ,count) cur) ,count))
- (ede-project-sort-targets-list))
+ :notify (lambda (&rest _ignore)
+ (let ((cur ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth count cur) (1+ count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1+ count) cur) count))
+ (ede-project-sort-targets-list))
" Down ")
(widget-insert " "))
(widget-insert (concat " " (number-to-string (1+ count)) ".: "
(oref (nth (nth count ede-project-sort-targets-order)
- targets) name) "\n"))
- (setq count (1+ count))))))
+ targets)
+ name)
+ "\n"))))))
;;; Customization hooks
;;
@@ -196,11 +195,11 @@ OBJ is the target object to customize."
;; These two methods should be implemented by subclasses of
;; project and targets in order to account for user specified
;; changes.
-(cl-defmethod eieio-done-customizing ((target ede-target))
+(cl-defmethod eieio-done-customizing ((_target ede-target))
"Call this when a user finishes customizing TARGET."
nil)
-(cl-defmethod ede-commit-project ((proj ede-project))
+(cl-defmethod ede-commit-project ((_proj ede-project))
"Commit any change to PROJ to its file."
nil
)
diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el
index 57a6b3b6911..c933fc4515e 100644
--- a/lisp/cedet/ede/detect.el
+++ b/lisp/cedet/ede/detect.el
@@ -1,4 +1,4 @@
-;;; ede/detect.el --- EDE project detection and file associations
+;;; ede/detect.el --- EDE project detection and file associations -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
@@ -35,16 +35,6 @@
(require 'ede/auto) ;; Autoload settings.
-(when (or (<= emacs-major-version 23)
- ;; predicate as name added in Emacs 24.2
- (and (= emacs-major-version 24)
- (< emacs-minor-version 2)))
- (message "Loading CEDET fallback autoload library.")
- (require 'cedet/dominate
- (expand-file-name "../../../etc/fallback-libraries/dominate.el"
- (file-name-directory load-file-name))))
-
-
;;; BASIC PROJECT SCAN
;;
(defun ede--detect-stop-scan-p (dir)
diff --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el
index c85d4ee7924..27735176c2a 100644
--- a/lisp/cedet/ede/dired.el
+++ b/lisp/cedet/ede/dired.el
@@ -1,4 +1,4 @@
-;;; ede/dired.el --- EDE extensions to dired.
+;;; ede/dired.el --- EDE extensions to dired. -*- lexical-binding: t -*-
;; Copyright (C) 1998-2000, 2003, 2009-2021 Free Software Foundation,
;; Inc.
@@ -30,17 +30,16 @@
;;; Code:
-(require 'easymenu)
(require 'dired)
(require 'ede)
(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)
+ (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"
diff --git a/lisp/cedet/ede/emacs.el b/lisp/cedet/ede/emacs.el
index 304184f0d00..00496ace16f 100644
--- a/lisp/cedet/ede/emacs.el
+++ b/lisp/cedet/ede/emacs.el
@@ -1,4 +1,4 @@
-;;; ede/emacs.el --- Special project for Emacs
+;;; ede/emacs.el --- Special project for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -54,31 +54,6 @@ Return a tuple of ( EMACSNAME . VERSION )."
(erase-buffer)
(setq default-directory (file-name-as-directory dir))
(cond
- ;; Maybe XEmacs?
- ((file-exists-p "version.sh")
- (setq emacs "XEmacs")
- (insert-file-contents "version.sh")
- (goto-char (point-min))
- (re-search-forward "emacs_major_version=\\([0-9]+\\)
-emacs_minor_version=\\([0-9]+\\)
-emacs_beta_version=\\([0-9]+\\)")
- (setq ver (concat (match-string 1) "."
- (match-string 2) "."
- (match-string 3)))
- )
- ((file-exists-p "sxemacs.pc.in")
- (setq emacs "SXEmacs")
- (insert-file-contents "sxemacs_version.m4")
- (goto-char (point-min))
- (re-search-forward "m4_define(\\[SXEM4CS_MAJOR_VERSION\\], \\[\\([0-9]+\\)\\])
-m4_define(\\[SXEM4CS_MINOR_VERSION\\], \\[\\([0-9]+\\)\\])
-m4_define(\\[SXEM4CS_BETA_VERSION\\], \\[\\([0-9]+\\)\\])")
- (setq ver (concat (match-string 1) "."
- (match-string 2) "."
- (match-string 3)))
- )
- ;; Insert other Emacs here...
-
;; Vaguely recent version of GNU Emacs?
((or (file-exists-p configure_ac)
(file-exists-p (setq configure_ac "configure.in")))
@@ -234,20 +209,19 @@ All files need the macros from lisp.h!"
(let* ((D (car dirs))
(ed (expand-file-name D base))
(ef (expand-file-name name ed)))
- (if (file-exists-p ef)
- (setq ans ef)
- ;; Not in this dir? How about subdirs?
- (let ((dirfile (directory-files ed t))
- (moredirs nil)
- )
- ;; Get all the subdirs.
- (dolist (DF dirfile)
- (when (and (file-directory-p DF)
- (not (string-match "\\.$" DF)))
- (push DF moredirs)))
- ;; Try again.
- (setq ans (ede-emacs-find-in-directories name ed moredirs))
- ))
+ (when (file-exists-p ed)
+ (if (file-exists-p ef)
+ (setq ans ef)
+ ;; Not in this dir? How about subdirs?
+ (let ((dirfile (directory-files ed t))
+ (moredirs nil))
+ ;; Get all the subdirs.
+ (dolist (DF dirfile)
+ (when (and (file-directory-p DF)
+ (not (string-match "\\.$" DF)))
+ (push DF moredirs)))
+ ;; Try again.
+ (setq ans (ede-emacs-find-in-directories name ed moredirs)))))
(setq dirs (cdr dirs))))
ans))
diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el
index be6ac5e926d..6b7e1595646 100644
--- a/lisp/cedet/ede/files.el
+++ b/lisp/cedet/ede/files.el
@@ -1,4 +1,4 @@
-;;; ede/files.el --- Associate projects with files and directories.
+;;; ede/files.el --- Associate projects with files and directories. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -33,6 +33,7 @@
;; till no ede-project-autoload structure matches.
;;
+(require 'eieio)
(require 'ede)
(declare-function ede-locate-file-in-hash "ede/locate")
@@ -75,13 +76,13 @@ Allows for one-project-object-for-a-tree type systems."
(oref this rootproject))
(cl-defmethod ede-project-root-directory ((this ede-project-placeholder)
- &optional file)
+ &optional _file)
"If a project knows its root, return it here.
Allows for one-project-object-for-a-tree type systems.
Optional FILE is the file to test. It is ignored in preference
of the anchor file for the project."
- (let ((root (or (ede-project-root this) this)))
- (file-name-directory (expand-file-name (oref this file)))))
+ ;; (let ((root (or (ede-project-root this) this)))
+ (file-name-directory (expand-file-name (oref this file)))) ;; )
;; Why INODEs?
@@ -96,15 +97,12 @@ of the anchor file for the project."
(defun ede--put-inode-dir-hash (dir inode)
"Add to the EDE project hash DIR associated with INODE."
- (when (fboundp 'puthash)
- (puthash dir inode ede-inode-directory-hash)
- inode))
+ (puthash dir inode ede-inode-directory-hash)
+ inode)
(defun ede--get-inode-dir-hash (dir)
"Get the EDE project hash DIR associated with INODE."
- (when (fboundp 'gethash)
- (gethash dir ede-inode-directory-hash)
- ))
+ (gethash dir ede-inode-directory-hash))
(defun ede--inode-for-dir (dir)
"Return the inode for the directory DIR."
@@ -144,7 +142,7 @@ Does not check subprojects."
(defun ede-directory-get-open-project (dir &optional rootreturn)
"Return an already open project that is managing DIR.
-Optional ROOTRETURN specifies a symbol to set to the root project.
+Optional ROOTRETURN specifies a `gv-ref' to set to the root project.
If DIR is the root project, then it is the same."
(let* ((inode (ede--inode-for-dir dir))
(ft (file-name-as-directory (expand-file-name dir)))
@@ -156,7 +154,8 @@ If DIR is the root project, then it is the same."
;; Default answer is this project
(setq ans proj)
;; Save.
- (when rootreturn (set rootreturn proj))
+ (when rootreturn (if (symbolp rootreturn) (set rootreturn proj)
+ (setf (gv-deref rootreturn) proj)))
;; Find subprojects.
(when (and proj (if ede--disable-inode
(not (string= ft (expand-file-name
@@ -272,28 +271,24 @@ Do this only when developing new projects that are incorrectly putting
Do this whenever a new project is created, as opposed to loaded."
;; TODO - Use maphash, and delete by regexp, not by dir searching!
(setq dir (expand-file-name dir))
- (when (fboundp 'remhash)
- (remhash (file-name-as-directory dir) ede-project-directory-hash)
- ;; Look for all subdirs of D, and remove them.
- (let ((match (concat "^" (regexp-quote dir))))
- (maphash (lambda (K O)
- (when (string-match match K)
- (remhash K ede-project-directory-hash)))
- ede-project-directory-hash))
- ))
+ (remhash (file-name-as-directory dir) ede-project-directory-hash)
+ ;; Look for all subdirs of D, and remove them.
+ (let ((match (concat "^" (regexp-quote dir))))
+ (maphash (lambda (K _O)
+ (when (string-match match K)
+ (remhash K ede-project-directory-hash)))
+ ede-project-directory-hash)))
(defun ede--directory-project-from-hash (dir)
"If there is an already loaded project for DIR, return it from the hash."
- (when (fboundp 'gethash)
- (setq dir (expand-file-name dir))
- (gethash dir ede-project-directory-hash nil)))
+ (setq dir (expand-file-name dir))
+ (gethash dir ede-project-directory-hash nil))
(defun ede--directory-project-add-description-to-hash (dir desc)
"Add to the EDE project hash DIR associated with DESC."
- (when (fboundp 'puthash)
- (setq dir (expand-file-name dir))
- (puthash dir desc ede-project-directory-hash)
- desc))
+ (setq dir (expand-file-name dir))
+ (puthash dir desc ede-project-directory-hash)
+ desc)
;;; DIRECTORY-PROJECT-P, -CONS
;;
@@ -370,7 +365,7 @@ If DIR is not part of a project, return nil."
(t nil))))
-(defalias 'ede-toplevel-project-or-nil 'ede-toplevel-project)
+(defalias 'ede-toplevel-project-or-nil #'ede-toplevel-project)
;;; DIRECTORY CONVERSION STUFF
;;
@@ -476,15 +471,15 @@ is returned."
ans))
-(cl-defmethod ede-expand-filename-impl ((this ede-project) filename &optional force)
+(cl-defmethod ede-expand-filename-impl ((this ede-project) filename &optional _force)
"Return a fully qualified file name based on project THIS.
FILENAME should be just a filename which occurs in a directory controlled
by this project.
Optional argument FORCE forces the default filename to be provided even if it
doesn't exist."
(let ((loc (ede-get-locator-object this))
- (path (ede-project-root-directory this))
- (proj (oref this subproj))
+ ;; (path (ede-project-root-directory this))
+ ;; (proj (oref this subproj))
(found nil))
;; find it Locally.
(setq found (or (ede-expand-filename-local this filename)
diff --git a/lisp/cedet/ede/generic.el b/lisp/cedet/ede/generic.el
index e410aa55535..4537f59ac9d 100644
--- a/lisp/cedet/ede/generic.el
+++ b/lisp/cedet/ede/generic.el
@@ -1,4 +1,4 @@
-;;; ede/generic.el --- Base Support for generic build systems
+;;; ede/generic.el --- Base Support for generic build systems -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -93,7 +93,7 @@
)
"User Configuration object for a generic project.")
-(defun ede-generic-load (dir &optional rootproj)
+(defun ede-generic-load (dir &optional _rootproj)
"Return a Generic Project object if there is a match.
Return nil if there isn't one.
Argument DIR is the directory it is created for.
@@ -137,7 +137,7 @@ subclasses of this base target will override the default value.")
ede-project-with-config-program
ede-project-with-config-c
ede-project-with-config-java)
- ((config-class :initform ede-generic-config)
+ ((config-class :initform 'ede-generic-config)
(config-file-basename :initform "EDEConfig.el")
(buildfile :initform ""
:type string
@@ -149,7 +149,7 @@ The class allocated value is replace by different sub classes.")
:abstract t)
(cl-defmethod initialize-instance ((this ede-generic-project)
- &rest fields)
+ &rest _fields)
"Make sure the targets slot is bound."
(cl-call-next-method)
(unless (slot-boundp this 'targets)
@@ -161,7 +161,7 @@ The class allocated value is replace by different sub classes.")
this)
(cl-defmethod ede-find-subproject-for-directory ((proj ede-generic-project)
- dir)
+ _dir)
"Return PROJ, for handling all subdirs below DIR."
proj)
@@ -258,8 +258,8 @@ If one doesn't exist, create a new one for this directory."
INTERNAL-NAME is obsolete and ignored.
EXTERNAL-NAME is a human readable name to describe the project; it
must be unique among all autoloaded projects.
-PROJECTFILE is a file name that identifies a project of this type to EDE, such as
-a Makefile, or SConstruct file.
+PROJECTFILE is a file name that identifies a project of this type to EDE, such
+as a Makefile, or SConstruct file.
CLASS is the EIEIO class that is used to track this project. It should subclass
`ede-generic-project'."
(ede-add-project-autoload
@@ -324,7 +324,7 @@ CLASS is the EIEIO class that is used to track this project. It should subclass
)
"Generic Project for makefiles.")
-(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-makefile-project) config)
+(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-makefile-project) config)
"Setup a configuration for Make."
(oset config build-command "make -k")
(oset config debug-command "gdb ")
@@ -337,7 +337,7 @@ CLASS is the EIEIO class that is used to track this project. It should subclass
)
"Generic Project for scons.")
-(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-scons-project) config)
+(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-scons-project) config)
"Setup a configuration for SCONS."
(oset config build-command "scons")
(oset config debug-command "gdb ")
@@ -350,7 +350,7 @@ CLASS is the EIEIO class that is used to track this project. It should subclass
)
"Generic Project for cmake.")
-(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-cmake-project) config)
+(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-cmake-project) config)
"Setup a configuration for CMake."
(oset config build-command "cmake")
(oset config debug-command "gdb ")
@@ -361,9 +361,9 @@ CLASS is the EIEIO class that is used to track this project. It should subclass
()
"Generic project found via Version Control files.")
-(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-vc-project) config)
+(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-vc-project) _config)
"Setup a configuration for projects identified by revision control."
- )
+ nil)
(provide 'ede/generic)
diff --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el
index 7a1c4c9e262..4b5530d6aca 100644
--- a/lisp/cedet/ede/linux.el
+++ b/lisp/cedet/ede/linux.el
@@ -1,4 +1,4 @@
-;;; ede/linux.el --- Special project for Linux
+;;; ede/linux.el --- Special project for Linux -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -47,26 +47,22 @@
(defcustom project-linux-build-directory-default 'ask
"Build directory."
:version "24.4"
- :group 'project-linux
:type '(choice (const :tag "Same as source directory" same)
(const :tag "Ask the user" ask)))
(defcustom project-linux-architecture-default 'ask
"Target architecture to assume when not auto-detected."
:version "24.4"
- :group 'project-linux
:type '(choice (string :tag "Architecture name")
(const :tag "Ask the user" ask)))
(defcustom project-linux-compile-target-command (concat ede-make-command " -k -C %s SUBDIRS=%s")
"Default command used to compile a target."
- :group 'project-linux
:type 'string)
(defcustom project-linux-compile-project-command (concat ede-make-command " -k -C %s")
"Default command used to compile a project."
- :group 'project-linux
:type 'string)
(defun ede-linux-version (dir)
diff --git a/lisp/cedet/ede/locate.el b/lisp/cedet/ede/locate.el
index e6a89533cca..016092cd8bf 100644
--- a/lisp/cedet/ede/locate.el
+++ b/lisp/cedet/ede/locate.el
@@ -1,4 +1,4 @@
-;;; ede/locate.el --- Locate support
+;;; ede/locate.el --- Locate support -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -110,7 +110,7 @@ based on `ede-locate-setup-options'."
)
"Baseclass for LOCATE feature in EDE.")
-(cl-defmethod initialize-instance ((loc ede-locate-base) &rest fields)
+(cl-defmethod initialize-instance ((loc ede-locate-base) &rest _fields)
"Make sure we have a hash table."
;; Basic setup.
(cl-call-next-method)
@@ -118,8 +118,8 @@ based on `ede-locate-setup-options'."
(ede-locate-flush-hash loc)
)
-(cl-defmethod ede-locate-ok-in-project ((loc (subclass ede-locate-base))
- root)
+(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-base))
+ _root)
"Is it ok to use this project type under ROOT."
t)
@@ -149,17 +149,15 @@ that created this EDE locate object."
(oset loc lastanswer ans)
ans))
-(cl-defmethod ede-locate-file-in-project-impl ((loc ede-locate-base)
- filesubstring
- )
+(cl-defmethod ede-locate-file-in-project-impl ((_loc ede-locate-base)
+ _filesubstring)
"Locate with LOC occurrences of FILESUBSTRING.
Searches are done under the current root of the EDE project
that created this EDE locate object."
- nil
- )
+ nil)
(cl-defmethod ede-locate-create/update-root-database
- ((loc (subclass ede-locate-base)) root)
+ ((loc (subclass ede-locate-base)) _root)
"Create or update the database for the current project.
You cannot create projects for the baseclass."
(error "Cannot create/update a database of type %S"
@@ -177,8 +175,8 @@ You cannot create projects for the baseclass."
Configure the Emacs `locate-program' variable to also
configure the use of EDE locate.")
-(cl-defmethod ede-locate-ok-in-project ((loc (subclass ede-locate-locate))
- root)
+(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-locate))
+ _root)
"Is it ok to use this project type under ROOT."
(or (featurep 'locate) (locate-library "locate"))
)
@@ -198,7 +196,7 @@ that created this EDE locate object."
(with-current-buffer b
(setq default-directory cd)
(erase-buffer))
- (apply 'call-process locate-command
+ (apply #'call-process locate-command
nil b nil
searchstr nil)
(with-current-buffer b
@@ -221,7 +219,7 @@ Configure EDE's use of GNU Global through the cedet-global.el
variable `cedet-global-command'.")
(cl-defmethod initialize-instance ((loc ede-locate-global)
- &rest slots)
+ &rest _slots)
"Make sure that we can use GNU Global."
(require 'cedet-global)
;; Get ourselves initialized.
@@ -235,8 +233,8 @@ variable `cedet-global-command'.")
(oref loc root))))
)
-(cl-defmethod ede-locate-ok-in-project ((loc (subclass ede-locate-global))
- root)
+(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-global))
+ root)
"Is it ok to use this project type under ROOT."
(require 'cedet-global)
(cedet-gnu-global-version-check)
@@ -252,7 +250,7 @@ variable `cedet-global-command'.")
(cedet-gnu-global-expand-filename filesubstring)))
(cl-defmethod ede-locate-create/update-root-database
- ((loc (subclass ede-locate-global)) root)
+ ((_loc (subclass ede-locate-global)) root)
"Create or update the GNU Global database for the current project."
(cedet-gnu-global-create/update-database root))
@@ -271,7 +269,7 @@ Configure EDE's use of IDUtils through the cedet-idutils.el
file name searching variable `cedet-idutils-file-command'.")
(cl-defmethod initialize-instance ((loc ede-locate-idutils)
- &rest slots)
+ &rest _slots)
"Make sure that we can use IDUtils."
;; Get ourselves initialized.
(cl-call-next-method)
@@ -283,8 +281,8 @@ file name searching variable `cedet-idutils-file-command'.")
(oref loc root)))
)
-(cl-defmethod ede-locate-ok-in-project ((loc (subclass ede-locate-idutils))
- root)
+(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-idutils))
+ root)
"Is it ok to use this project type under ROOT."
(require 'cedet-idutils)
(cedet-idutils-version-check)
@@ -301,7 +299,7 @@ that created this EDE locate object."
(cedet-idutils-expand-filename filesubstring)))
(cl-defmethod ede-locate-create/update-root-database
- ((loc (subclass ede-locate-idutils)) root)
+ ((_loc (subclass ede-locate-idutils)) root)
"Create or update the GNU Global database for the current project."
(cedet-idutils-create/update-database root))
@@ -320,7 +318,7 @@ Configure EDE's use of Cscope through the cedet-cscope.el
file name searching variable `cedet-cscope-file-command'.")
(cl-defmethod initialize-instance ((loc ede-locate-cscope)
- &rest slots)
+ &rest _slots)
"Make sure that we can use Cscope."
;; Get ourselves initialized.
(cl-call-next-method)
@@ -332,8 +330,8 @@ file name searching variable `cedet-cscope-file-command'.")
(oref loc root)))
)
-(cl-defmethod ede-locate-ok-in-project ((loc (subclass ede-locate-cscope))
- root)
+(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-cscope))
+ root)
"Is it ok to use this project type under ROOT."
(require 'cedet-cscope)
(cedet-cscope-version-check)
@@ -350,7 +348,7 @@ that created this EDE locate object."
(cedet-cscope-expand-filename filesubstring)))
(cl-defmethod ede-locate-create/update-root-database
- ((loc (subclass ede-locate-cscope)) root)
+ ((_loc (subclass ede-locate-cscope)) root)
"Create or update the Cscope database for the current project."
(require 'cedet-cscope)
(cedet-cscope-create/update-database root))
diff --git a/lisp/cedet/ede/make.el b/lisp/cedet/ede/make.el
index 7496526f9f4..3402020fc4a 100644
--- a/lisp/cedet/ede/make.el
+++ b/lisp/cedet/ede/make.el
@@ -1,6 +1,6 @@
-;;; ede/make.el --- General information about "make"
+;;; ede/make.el --- General information about "make" -*- lexical-binding: t -*-
-;;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -30,31 +30,15 @@
;;; Code:
-(declare-function inversion-check-version "inversion")
-
-(if (fboundp 'locate-file)
- (defsubst ede--find-executable (exec)
- "Return an expanded file name for a program EXEC on the exec path."
- (locate-file exec exec-path))
-
- ;; Else, older version of Emacs.
-
- (defsubst ede--find-executable (exec)
- "Return an expanded file name for a program EXEC on the exec path."
- (let ((p exec-path)
- (found nil))
- (while (and p (not found))
- (let ((f (expand-file-name exec (car p))))
- (if (file-exists-p f)
- (setq found f)))
- (setq p (cdr p)))
- found))
- )
+(defsubst ede--find-executable (exec)
+ "Return an expanded file name for a program EXEC on the exec path."
+ (declare (obsolete locate-file "28.1"))
+ (locate-file exec exec-path))
(defvar ede-make-min-version "3.0"
"Minimum version of GNU make required.")
-(defcustom ede-make-command (cond ((ede--find-executable "gmake")
+(defcustom ede-make-command (cond ((executable-find "gmake")
"gmake")
(t "make")) ;; What to do?
"The MAKE command to use for EDE when compiling.
@@ -74,8 +58,7 @@ If NOERROR is nil, then throw an error on failure. Return t otherwise."
(let ((b (get-buffer-create "*EDE Make Version*"))
(cd default-directory)
(rev nil)
- (ans nil)
- )
+ (ans nil))
(with-current-buffer b
;; Setup, and execute make.
(setq default-directory cd)
@@ -84,18 +67,18 @@ If NOERROR is nil, then throw an error on failure. Return t otherwise."
"--version")
;; Check the buffer for the string
(goto-char (point-min))
- (when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,]+\\),")
+ (when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,[:space:]]+\\),?")
(setq rev (match-string 1))
- (require 'inversion)
- (setq ans (not (inversion-check-version rev nil ede-make-min-version))))
+ (setq ans (not (version< rev ede-make-min-version))))
;; Answer reporting.
(when (and (called-interactively-p 'interactive) ans)
(message "GNU Make version %s. Good enough for CEDET." rev))
(when (and (not noerror) (not ans))
- (error "EDE requires GNU Make version %s or later. Configure `ede-make-command' to fix"
- ede-make-min-version))
+ (error "EDE requires GNU Make version %s or later (found %s). Configure `ede-make-command' to fix"
+ ede-make-min-version
+ rev))
ans)))
(provide 'ede/make)
diff --git a/lisp/cedet/ede/makefile-edit.el b/lisp/cedet/ede/makefile-edit.el
index 43655a5d1e3..d6965945494 100644
--- a/lisp/cedet/ede/makefile-edit.el
+++ b/lisp/cedet/ede/makefile-edit.el
@@ -1,4 +1,4 @@
-;;; makefile-edit.el --- Makefile editing/scanning commands.
+;;; makefile-edit.el --- Makefile editing/scanning commands. -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el
index 985e58e77da..c5b2ea4cb60 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
+;;; ede/pconf.el --- configure.ac maintenance for EDE -*- lexical-binding: t; -*-
-;;; Copyright (C) 1998-2000, 2005, 2008-2021 Free Software Foundation,
-;;; Inc.
+;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project
@@ -56,8 +55,9 @@ don't do it. A value of nil means to just do it.")
(and (eq ede-pconf-create-file-query 'ask)
(not (eq ede-pconf-create-file-query 'never))
(not (y-or-n-p
- (format "I had to create the %s file for you. Ok? " file)))
- (error "Quit")))))))
+ (format "I had to create the %s file for you. Ok? "
+ file))))
+ (error "Quit"))))))
(cl-defmethod ede-proj-configure-synchronize ((this ede-proj-project))
@@ -66,7 +66,7 @@ don't do it. A value of nil means to just do it.")
;;(td (file-name-directory (ede-proj-configure-file this)))
(targs (oref this targets))
(postcmd "")
- (add-missing nil))
+ ) ;; (add-missing nil)
;; First, make sure we have a file.
(if (not (file-exists-p (ede-proj-configure-file this)))
(autoconf-new-program b (oref this name) "Project.ede"))
@@ -96,7 +96,7 @@ don't do it. A value of nil means to just do it.")
(ede-map-targets sp #'ede-proj-flush-autoconf)))
(ede-map-all-subprojects
this
- (lambda (sp)
+ (lambda (_sp)
(ede-map-targets this #'ede-proj-tweak-autoconf)))
;; Now save
(save-buffer)
@@ -108,14 +108,15 @@ don't do it. A value of nil means to just do it.")
(ede-proj-configure-test-required-file this "README")
(ede-proj-configure-test-required-file this "ChangeLog")
;; Let specific targets get missing files.
- (mapc 'ede-proj-configure-create-missing targs)
+ (mapc #'ede-proj-configure-create-missing targs)
;; Verify that we have a make system.
(if (or (not (ede-expand-filename (ede-toplevel this) "Makefile"))
;; Now is this one of our old Makefiles?
(with-current-buffer
(find-file-noselect
(ede-expand-filename (ede-toplevel this)
- "Makefile" t) t)
+ "Makefile" t)
+ t)
(goto-char (point-min))
;; Here is the unique piece for our makefiles.
(re-search-forward "For use with: make" nil t)))
@@ -165,11 +166,11 @@ don't do it. A value of nil means to just do it.")
"Tweak the configure file (current buffer) to accommodate THIS."
;; Check the compilers belonging to THIS, and call the autoconf
;; setup for those compilers.
- (mapc 'ede-proj-tweak-autoconf (ede-proj-compilers this))
- (mapc 'ede-proj-tweak-autoconf (ede-proj-linkers this))
+ (mapc #'ede-proj-tweak-autoconf (ede-proj-compilers this))
+ (mapc #'ede-proj-tweak-autoconf (ede-proj-linkers this))
)
-(cl-defmethod ede-proj-flush-autoconf ((this ede-proj-target))
+(cl-defmethod ede-proj-flush-autoconf ((_this ede-proj-target))
"Flush the configure file (current buffer) to accommodate THIS.
By flushing, remove any cruft that may be in the file. Subsequent
calls to `ede-proj-tweak-autoconf' can restore items removed by flush."
@@ -177,13 +178,13 @@ calls to `ede-proj-tweak-autoconf' can restore items removed by flush."
;; @TODO - No-one calls this ???
-(cl-defmethod ede-proj-configure-add-missing ((this ede-proj-target))
+(cl-defmethod ede-proj-configure-add-missing ((_this ede-proj-target))
"Query if any files needed by THIS provided by automake are missing.
Results in --add-missing being passed to automake."
nil)
;; @TODO - No-one implements this yet.
-(cl-defmethod ede-proj-configure-create-missing ((this ede-proj-target))
+(cl-defmethod ede-proj-configure-create-missing ((_this ede-proj-target))
"Add any missing files for THIS by creating them."
nil)
diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el
index d4463345694..fd6918c4e81 100644
--- a/lisp/cedet/ede/pmake.el
+++ b/lisp/cedet/ede/pmake.el
@@ -1,4 +1,4 @@
-;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
+;;; ede-pmake.el --- EDE Generic Project Makefile code generator -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2005, 2007-2021 Free Software Foundation, Inc.
@@ -46,6 +46,7 @@
(require 'ede/proj)
(require 'ede/proj-obj)
(require 'ede/proj-comp)
+(require 'seq)
(declare-function ede-srecode-setup "ede/srecode")
(declare-function ede-srecode-insert "ede/srecode")
@@ -111,13 +112,13 @@ MFILENAME is the makefile to generate."
(let* ((targ (if isdist (oref this targets) mt))
(sp (oref this subproj))
- (df (apply 'append
+ (df (apply #'append
(mapcar (lambda (tg)
(ede-proj-makefile-dependency-files tg))
targ))))
;; Distribution variables
(ede-compiler-begin-unique
- (mapc 'ede-proj-makefile-insert-variables targ))
+ (mapc #'ede-proj-makefile-insert-variables targ))
;; Only add the distribution stuff in when depth != 0
(let ((top (ede-toplevel this))
(tmp this)
@@ -153,7 +154,8 @@ MFILENAME is the makefile to generate."
(concat ".deps/"
(file-name-nondirectory
(file-name-sans-extension
- f)) ".P"))
+ f))
+ ".P"))
df " "))))
;;
;; Insert ALL Rule
@@ -180,7 +182,7 @@ MFILENAME is the makefile to generate."
;;
;; NOTE: This is GNU Make specific.
(if (and (oref this automatic-dependencies) df)
- (insert "DEPS_MAGIC := $(shell mkdir .deps > /dev/null "
+ (insert "DEPS_MAGIC := $(shell mkdir .deps > " null-device " "
"2>&1 || :)\n"
"-include $(DEP_FILES)\n\n"))
;;
@@ -188,11 +190,11 @@ MFILENAME is the makefile to generate."
;;
(ede-compiler-begin-unique
(ede-proj-makefile-insert-rules this)
- (mapc 'ede-proj-makefile-insert-rules targ))
+ (mapc #'ede-proj-makefile-insert-rules targ))
;;
;; phony targets for sub projects
;;
- (mapc 'ede-proj-makefile-insert-subproj-rules sp)
+ (mapc #'ede-proj-makefile-insert-subproj-rules sp)
;;
;; Distribution rules such as CLEAN and DIST
;;
@@ -210,11 +212,11 @@ MFILENAME is the makefile to generate."
;; Distribution variables
(let ((targ (if isdist (oref this targets) mt)))
(ede-compiler-begin-unique
- (mapc 'ede-proj-makefile-insert-automake-pre-variables targ))
+ (mapc #'ede-proj-makefile-insert-automake-pre-variables targ))
(ede-compiler-begin-unique
- (mapc 'ede-proj-makefile-insert-source-variables targ))
+ (mapc #'ede-proj-makefile-insert-source-variables targ))
(ede-compiler-begin-unique
- (mapc 'ede-proj-makefile-insert-automake-post-variables targ))
+ (mapc #'ede-proj-makefile-insert-automake-post-variables targ))
(ede-compiler-begin-unique
(ede-proj-makefile-insert-user-rules this))
(insert "\n# End of Makefile.am\n")
@@ -241,6 +243,7 @@ MFILENAME is the makefile to generate."
(defmacro ede-pmake-insert-variable-shared (varname &rest body)
"Add VARNAME into the current Makefile.
Execute BODY in a location where a value can be placed."
+ (declare (debug t) (indent 1))
`(let ((addcr t) (v ,varname))
(if (save-excursion
(goto-char (point-max))
@@ -258,20 +261,19 @@ Execute BODY in a location where a value can be placed."
,@body
(if addcr (insert "\n"))
(goto-char (point-max))))
-(put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1)
(defmacro ede-pmake-insert-variable-once (varname &rest body)
"Add VARNAME into the current Makefile if it doesn't exist.
Execute BODY in a location where a value can be placed."
- `(let ((addcr t) (v ,varname))
- (unless
- (save-excursion
- (re-search-backward (concat "^" v "\\s-*=") nil t))
- (insert v "=")
- ,@body
- (when addcr (insert "\n"))
- (goto-char (point-max)))))
-(put 'ede-pmake-insert-variable-once 'lisp-indent-function 1)
+ (declare (debug t) (indent 1))
+ `(let ((v ,varname))
+ (unless
+ (save-excursion
+ (re-search-backward (concat "^" v "\\s-*=") nil t))
+ (insert v "=")
+ ,@body
+ (insert "\n")
+ (goto-char (point-max)))))
;;; SOURCE VARIABLE NAME CONSTRUCTION
@@ -289,7 +291,7 @@ Change . to _ in the variable name."
;;; DEPENDENCY FILE GENERATOR LISTS
;;
-(cl-defmethod ede-proj-makefile-dependency-files ((this ede-proj-target))
+(cl-defmethod ede-proj-makefile-dependency-files ((_this ede-proj-target))
"Return a list of source files to convert to dependencies.
Argument THIS is the target to get sources from."
nil)
@@ -302,7 +304,7 @@ Argument THIS is the target to get sources from."
Use CONFIGURATION as the current configuration to query."
(cdr (assoc configuration (oref this configuration-variables))))
-(cl-defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project))
+(cl-defmethod ede-proj-makefile-insert-variables-new ((_this ede-proj-project))
"Insert variables needed by target THIS.
NOTE: Not yet in use! This is part of an SRecode conversion of
@@ -420,7 +422,7 @@ Use CONFIGURATION as the current configuration to query."
(cdr (assoc configuration (oref this configuration-variables))))
(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile)
- &optional moresource)
+ &optional _moresource)
"Insert variables needed by target THIS.
Optional argument MORESOURCE is a list of additional sources to add to the
sources variable."
@@ -428,11 +430,11 @@ sources variable."
(let* ((proj (ede-target-parent this))
(conf-table (ede-proj-makefile-configuration-variables
this (oref proj configuration-default)))
- (conf-done nil)
+ ;; (conf-done nil)
)
;; Add in all variables from the configuration not already covered.
(mapc (lambda (c)
- (if (member (car c) conf-done)
+ (if nil ;; (member (car c) conf-done)
nil
(insert (car c) "=" (cdr c) "\n")))
conf-table))
@@ -449,12 +451,12 @@ sources variable."
(ede-proj-makefile-insert-variables linker)))))
(cl-defmethod ede-proj-makefile-insert-automake-pre-variables
- ((this ede-proj-target))
+ ((_this ede-proj-target))
"Insert variables needed by target THIS in Makefile.am before SOURCES."
nil)
(cl-defmethod ede-proj-makefile-insert-automake-post-variables
- ((this ede-proj-target))
+ ((_this ede-proj-target))
"Insert variables needed by target THIS in Makefile.am after SOURCES."
nil)
@@ -464,9 +466,9 @@ sources variable."
"Return a list of patterns that are considered garbage to THIS.
These are removed with make clean."
(let ((mc (ede-map-targets
- this (lambda (c) (ede-proj-makefile-garbage-patterns c))))
+ this #'ede-proj-makefile-garbage-patterns))
(uniq nil))
- (setq mc (sort (apply 'append mc) 'string<))
+ (setq mc (sort (apply #'append mc) #'string<))
;; Filter out duplicates from the targets.
(while mc
(if (and (car uniq) (string= (car uniq) (car mc)))
@@ -502,16 +504,16 @@ These are removed with make clean."
(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-project))
"Insert rules needed by THIS target."
- (mapc 'ede-proj-makefile-insert-rules (oref this inference-rules))
+ (mapc #'ede-proj-makefile-insert-rules (oref this inference-rules))
)
(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project))
"Insert any symbols that the DIST rule should depend on.
Argument THIS is the project that should insert stuff."
- (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets))
+ (mapc #'ede-proj-makefile-insert-dist-dependencies (oref this targets))
)
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target))
+(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((_this ede-proj-target))
"Insert any symbols that the DIST rule should depend on.
Argument THIS is the target that should insert stuff."
nil)
@@ -530,7 +532,7 @@ Argument THIS is the target that should insert stuff."
(insert " " (ede-subproject-relative-path sproj))
))))
-(cl-defmethod ede-proj-makefile-automake-insert-extradist ((this ede-proj-project))
+(cl-defmethod ede-proj-makefile-automake-insert-extradist ((_this ede-proj-project))
"Insert the EXTRADIST variable entries needed for Automake and EDE."
(proj-comp-insert-variable-once "EXTRA_DIST" (insert "Project.ede")))
@@ -602,16 +604,16 @@ Argument THIS is the target that should insert stuff."
"\t@false\n\n"
"\n\n# End of Makefile\n")))
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-target))
+(cl-defmethod ede-proj-makefile-insert-rules ((_this ede-proj-target))
"Insert rules needed by THIS target."
nil)
(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile))
"Insert rules needed by THIS target."
- (mapc 'ede-proj-makefile-insert-rules (oref this rules))
+ (mapc #'ede-proj-makefile-insert-rules (oref this rules))
(let ((c (ede-proj-compilers this)))
(when c
- (mapc 'ede-proj-makefile-insert-rules c)
+ (mapc #'ede-proj-makefile-insert-rules c)
(if (oref this phony)
(insert ".PHONY: " (ede-proj-makefile-target-name this) "\n"))
(insert (ede-proj-makefile-target-name this) ": "
@@ -622,9 +624,9 @@ Argument THIS is the target that should insert stuff."
(cl-defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile))
"Insert the commands needed by target THIS.
For targets, insert the commands needed by the chosen compiler."
- (mapc 'ede-proj-makefile-insert-commands (ede-proj-compilers this))
+ (mapc #'ede-proj-makefile-insert-commands (ede-proj-compilers this))
(when (object-assoc t :uselinker (ede-proj-compilers this))
- (mapc 'ede-proj-makefile-insert-commands (ede-proj-linkers this))))
+ (mapc #'ede-proj-makefile-insert-commands (ede-proj-linkers this))))
(cl-defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project))
@@ -632,11 +634,11 @@ For targets, insert the commands needed by the chosen compiler."
This is different from `ede-proj-makefile-insert-rules' in that this
function won't create the building rules which are auto created with
automake."
- (mapc 'ede-proj-makefile-insert-user-rules (oref this inference-rules)))
+ (mapc #'ede-proj-makefile-insert-user-rules (oref this inference-rules)))
(cl-defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target))
"Insert user specified rules needed by THIS target."
- (mapc 'ede-proj-makefile-insert-rules (oref this rules)))
+ (mapc #'ede-proj-makefile-insert-rules (oref this rules)))
(cl-defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile))
"Return a string representing the dependencies for THIS.
@@ -644,7 +646,7 @@ Some compilers only use the first element in the dependencies, others
have a list of intermediates (object files), and others don't care.
This allows customization of how these elements appear."
(let* ((c (ede-proj-compilers this))
- (io (eval (cons 'or (mapcar 'ede-compiler-intermediate-objects-p c))))
+ (io (seq-some #'ede-compiler-intermediate-objects-p c))
(out nil))
(if io
(progn
@@ -652,7 +654,8 @@ This allows customization of how these elements appear."
(setq out
(concat out "$(" (ede-compiler-intermediate-object-variable
(car c)
- (ede-proj-makefile-target-name this)) ")")
+ (ede-proj-makefile-target-name this))
+ ")")
c (cdr c)))
out)
(let ((sv (ede-proj-makefile-sourcevar this))
diff --git a/lisp/cedet/ede/proj-archive.el b/lisp/cedet/ede/proj-archive.el
index 2b1e50dcea3..9da6374d09c 100644
--- a/lisp/cedet/ede/proj-archive.el
+++ b/lisp/cedet/ede/proj-archive.el
@@ -1,10 +1,12 @@
-;;; ede/proj-archive.el --- EDE Generic Project archive support
+;;; ede/proj-archive.el --- EDE Generic Project archive support -*- lexical-binding: t -*-
;; Copyright (C) 1998-2001, 2009-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
+;; 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
@@ -43,7 +45,7 @@
"Linker object for creating an archive.")
(cl-defmethod ede-proj-makefile-insert-source-variables :before
- ((this ede-proj-target-makefile-archive) &optional moresource)
+ ((this ede-proj-target-makefile-archive) &optional _moresource)
"Insert bin_PROGRAMS variables needed by target THIS.
We aren't actually inserting SOURCE details, but this is used by the
Makefile.am generator, so use it to add this important bin program."
diff --git a/lisp/cedet/ede/proj-aux.el b/lisp/cedet/ede/proj-aux.el
index f5bcebdd4cf..73259558a62 100644
--- a/lisp/cedet/ede/proj-aux.el
+++ b/lisp/cedet/ede/proj-aux.el
@@ -1,4 +1,4 @@
-;;; ede/proj-aux.el --- EDE Generic Project auxiliary file support
+;;; ede/proj-aux.el --- EDE Generic Project auxiliary file support -*- lexical-binding: t -*-
;; Copyright (C) 1998-2000, 2007, 2009-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el
index 26aa66873a3..0d797aa5fb9 100644
--- a/lisp/cedet/ede/proj-comp.el
+++ b/lisp/cedet/ede/proj-comp.el
@@ -1,4 +1,4 @@
-;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver
+;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2001, 2004-2005, 2007, 2009-2021 Free Software
;; Foundation, Inc.
@@ -172,12 +172,12 @@ Adds this rule to a .PHONY list."))
This is used when creating a Makefile to prevent duplicate variables and
rules from being created.")
-(cl-defmethod initialize-instance :after ((this ede-compiler) &rest fields)
+(cl-defmethod initialize-instance :after ((this ede-compiler) &rest _fields)
"Make sure that all ede compiler objects are cached in
`ede-compiler-list'."
(add-to-list 'ede-compiler-list this))
-(cl-defmethod initialize-instance :after ((this ede-linker) &rest fields)
+(cl-defmethod initialize-instance :after ((this ede-linker) &rest _fields)
"Make sure that all ede compiler objects are cached in
`ede-linker-list'."
(add-to-list 'ede-linker-list this))
@@ -185,11 +185,13 @@ rules from being created.")
(defmacro ede-compiler-begin-unique (&rest body)
"Execute BODY, making sure that `ede-current-build-list' is maintained.
This will prevent rules from creating duplicate variables or rules."
+ (declare (indent 0) (debug t))
`(let ((ede-current-build-list nil))
,@body))
(defmacro ede-compiler-only-once (object &rest body)
"Using OBJECT, execute BODY only once per Makefile generation."
+ (declare (indent 1) (debug t))
`(if (not (member ,object ede-current-build-list))
(progn
(add-to-list 'ede-current-build-list ,object)
@@ -198,25 +200,18 @@ This will prevent rules from creating duplicate variables or rules."
(defmacro ede-linker-begin-unique (&rest body)
"Execute BODY, making sure that `ede-current-build-list' is maintained.
This will prevent rules from creating duplicate variables or rules."
+ (declare (indent 0) (debug t))
`(let ((ede-current-build-list nil))
,@body))
(defmacro ede-linker-only-once (object &rest body)
"Using OBJECT, execute BODY only once per Makefile generation."
+ (declare (indent 1) (debug t))
`(if (not (member ,object ede-current-build-list))
(progn
(add-to-list 'ede-current-build-list ,object)
,@body)))
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec ede-compiler-begin-unique def-body)
- (def-edebug-spec ede-compiler-only-once (form def-body))
- (def-edebug-spec ede-linker-begin-unique def-body)
- (def-edebug-spec ede-linker-only-once (form def-body))
- (def-edebug-spec ede-pmake-insert-variable-shared (form def-body))
- ))
-
;;; Queries
(defun ede-proj-find-compiler (compilers sourcetype)
"Return a compiler from the list COMPILERS that will compile SOURCETYPE."
@@ -246,21 +241,20 @@ This will prevent rules from creating duplicate variables or rules."
)
(oref this autoconf)))
-(cl-defmethod ede-proj-flush-autoconf ((this ede-compilation-program))
+(cl-defmethod ede-proj-flush-autoconf ((_this ede-compilation-program))
"Flush the configure file (current buffer) to accommodate THIS."
nil)
(defmacro proj-comp-insert-variable-once (varname &rest body)
"Add VARNAME into the current Makefile if it doesn't exist.
Execute BODY in a location where a value can be placed."
- `(let ((addcr t) (v ,varname))
+ (declare (indent 1) (debug (sexp body)))
+ `(let ((v ,varname))
(unless (re-search-backward (concat "^" v "\\s-*=") nil t)
(insert v "=")
,@body
- (if addcr (insert "\n"))
- (goto-char (point-max)))
- ))
-(put 'proj-comp-insert-variable-once 'lisp-indent-function 1)
+ (insert "\n")
+ (goto-char (point-max)))))
(cl-defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program))
"Insert variables needed by the compiler THIS."
@@ -281,8 +275,8 @@ If this compiler creates code that can be linked together,
then the object files created by the compiler are considered intermediate."
(oref this uselinker))
-(cl-defmethod ede-compiler-intermediate-object-variable ((this ede-compiler)
- targetname)
+(cl-defmethod ede-compiler-intermediate-object-variable ((_this ede-compiler)
+ targetname)
"Return a string based on THIS representing a make object variable.
TARGETNAME is the name of the target that these objects belong to."
(concat targetname "_OBJ"))
@@ -314,7 +308,7 @@ Not all compilers do this."
(cl-defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program))
"Insert rules needed for THIS compiler object."
(ede-compiler-only-once this
- (mapc 'ede-proj-makefile-insert-rules (oref this rules))))
+ (mapc #'ede-proj-makefile-insert-rules (oref this rules))))
(cl-defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule))
"Insert rules needed for THIS rule object."
@@ -343,16 +337,6 @@ compiler it decides to use after inserting in the rule."
commands))
(insert "\n")))
-;;; Some details about our new macro
-;;
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec ede-compiler-begin-unique def-body)))
-(put 'ede-compiler-begin-unique 'lisp-indent-function 0)
-(put 'ede-compiler-only-once 'lisp-indent-function 1)
-(put 'ede-linker-begin-unique 'lisp-indent-function 0)
-(put 'ede-linker-only-once 'lisp-indent-function 1)
-
(provide 'ede/proj-comp)
;;; ede/proj-comp.el ends here
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index 7ad359f62b5..7e0f5a89346 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -1,4 +1,4 @@
-;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support
+;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2005, 2007-2021 Free Software Foundation, Inc.
@@ -36,7 +36,7 @@
(keybindings :initform nil)
(phony :initform t)
(sourcetype :initform '(ede-source-emacs))
- (availablecompilers :initform '(ede-emacs-compiler ede-xemacs-compiler))
+ (availablecompilers :initform '(ede-emacs-compiler))
(aux-packages :initarg :aux-packages
:initform nil
:type list
@@ -64,7 +64,7 @@ This inserts the PRELOADS target-local variable."
(when preloads
(insert (format "%s: PRELOADS=%s\n"
(oref this name)
- (mapconcat 'identity preloads " ")))))
+ (mapconcat #'identity preloads " ")))))
(insert "\n"))
(cl-defmethod ede-proj-makefile-dependencies ((this ede-proj-target-elisp))
@@ -104,6 +104,7 @@ For Emacs Lisp, return addsuffix command on source files."
:name "xemacs"
:variables '(("EMACS" . "xemacs")))
"Compile Emacs Lisp programs with XEmacs.")
+(make-obsolete-variable 'ede-xemacs-compiler 'ede-emacs-compiler "28.1")
;;; Claiming files
(cl-defmethod ede-buffer-mine ((this ede-proj-target-elisp) buffer)
@@ -151,20 +152,11 @@ 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")))
+ ) ;; (elc (concat (file-name-sans-extension fsrc) ".elc"))
(with-no-warnings
- (if (< emacs-major-version 24)
- ;; Does not have `byte-recompile-file'
- (if (or (not (file-exists-p elc))
- (file-newer-than-file-p fsrc elc))
- (progn
- (setq comp (1+ comp))
- (byte-compile-file fsrc))
- (setq utd (1+ utd)))
-
- (if (eq (byte-recompile-file fsrc nil 0) t)
- (setq comp (1+ comp))
- (setq utd (1+ utd)))))))
+ (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" (eieio-object-name obj))
@@ -177,7 +169,7 @@ is found, such as a `-version' variable, or the standard header."
(if (and (slot-boundp this 'versionsource)
(oref this versionsource))
(let ((vs (oref this versionsource))
- (match nil))
+ ) ;; (match nil)
(while vs
(with-current-buffer (find-file-noselect
(ede-expand-filename this (car vs)))
@@ -185,7 +177,7 @@ is found, such as a `-version' variable, or the standard header."
(let ((case-fold-search t))
(if (re-search-forward "-version\\s-+\"\\([^\"]+\\)\"" nil t)
(progn
- (setq match t)
+ ;; (setq match t)
(delete-region (match-beginning 1)
(match-end 1))
(goto-char (match-beginning 1))
@@ -339,27 +331,27 @@ Lays claim to all .elc files that match .el files in this target."
If the `compiler' slot is empty, get the car of the compilers list."
(let ((comp (oref obj compiler)))
(if comp
- (if (listp comp)
- (setq comp (mapcar 'symbol-value comp))
- (setq comp (list (symbol-value comp))))
+ (setq comp (if (listp comp)
+ (mapcar #'symbol-value comp)
+ (list (symbol-value comp))))
;; Get the first element from our list of compilers.
- (let ((avail (mapcar 'symbol-value (oref obj availablecompilers))))
+ (let ((avail (mapcar #'symbol-value (oref obj availablecompilers))))
(setq comp (list (car avail)))))
comp))
-(cl-defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target-elisp-autoloads)
- &optional
- moresource)
+(cl-defmethod ede-proj-makefile-insert-source-variables ((_this ede-proj-target-elisp-autoloads)
+ &optional
+ _moresource)
"Insert the source variables needed by THIS.
Optional argument MORESOURCE is a list of additional sources to add to the
sources variable."
nil)
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp-autoloads))
+(cl-defmethod ede-proj-makefile-sourcevar ((_this ede-proj-target-elisp-autoloads))
"Return the variable name for THIS's sources."
nil) ; "LOADDEFS")
-(cl-defmethod ede-proj-makefile-dependencies ((this ede-proj-target-elisp-autoloads))
+(cl-defmethod ede-proj-makefile-dependencies ((_this ede-proj-target-elisp-autoloads))
"Return a string representing the dependencies for THIS.
Always return an empty string for an autoloads generator."
"")
@@ -369,21 +361,22 @@ Always return an empty string for an autoloads generator."
(ede-pmake-insert-variable-shared "LOADDEFS"
(insert (oref this autoload-file)))
(ede-pmake-insert-variable-shared "LOADDIRS"
- (insert (mapconcat 'identity
+ (insert (mapconcat #'identity
(or (oref this autoload-dirs) '("."))
" ")))
)
(cl-defmethod project-compile-target ((obj ede-proj-target-elisp-autoloads))
"Create or update the autoload target."
- (require 'cedet-autogen)
+ (require 'cedet-autogen) ;FIXME: We don't have this file!
+ (declare-function cedet-update-autoloads "cedet-autogen")
(let ((default-directory (ede-expand-filename obj ".")))
- (apply 'cedet-update-autoloads
+ (apply #'cedet-update-autoloads
(oref obj autoload-file)
(oref obj autoload-dirs))
))
-(cl-defmethod ede-update-version-in-source ((this ede-proj-target-elisp-autoloads) version)
+(cl-defmethod ede-update-version-in-source ((_this ede-proj-target-elisp-autoloads) _version)
"In a Lisp file, updated a version string for THIS to VERSION.
There are standards in Elisp files specifying how the version string
is found, such as a `-version' variable, or the standard header."
@@ -405,11 +398,11 @@ Argument THIS is the target which needs to insert an info file."
(insert " " (oref this autoload-file))
)
-(cl-defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp-autoloads))
+(cl-defmethod ede-proj-tweak-autoconf ((_this ede-proj-target-elisp-autoloads))
"Tweak the configure file (current buffer) to accommodate THIS."
(error "Autoloads not supported in autoconf yet"))
-(cl-defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp-autoloads))
+(cl-defmethod ede-proj-flush-autoconf ((_this ede-proj-target-elisp-autoloads))
"Flush the configure file (current buffer) to accommodate THIS."
nil)
diff --git a/lisp/cedet/ede/proj-info.el b/lisp/cedet/ede/proj-info.el
index 3d437016e93..dbb86edb217 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
+;;; ede-proj-info.el --- EDE Generic Project texinfo support -*- lexical-binding: t; -*-
-;;; Copyright (C) 1998-2001, 2004, 2007-2021 Free Software Foundation,
-;;; Inc.
+;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -70,7 +69,7 @@ All other sources should be included independently."))
;;; Makefile generation
;;
(cl-defmethod ede-proj-configure-add-missing
- ((this ede-proj-target-makefile-info))
+ ((_this ede-proj-target-makefile-info))
"Query if any files needed by THIS provided by automake are missing.
Results in --add-missing being passed to automake."
(not (ede-expand-filename (ede-toplevel) "texinfo.tex")))
@@ -97,7 +96,7 @@ when working in Automake mode."
(insert menu))
;; Now insert the rest of the source elsewhere
(ede-pmake-insert-variable-shared sv
- (insert (mapconcat 'identity src " ")))
+ (insert (mapconcat #'identity src " ")))
(if moresource
(error "Texinfo files should not have moresource")))))
diff --git a/lisp/cedet/ede/proj-misc.el b/lisp/cedet/ede/proj-misc.el
index 70132aff6c3..068e998d1a1 100644
--- a/lisp/cedet/ede/proj-misc.el
+++ b/lisp/cedet/ede/proj-misc.el
@@ -1,4 +1,4 @@
-;;; ede-proj-misc.el --- EDE Generic Project Emacs Lisp support
+;;; ede-proj-misc.el --- EDE Generic Project Emacs Lisp support -*- lexical-binding: t -*-
;; Copyright (C) 1998-2001, 2008-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el
index 3aa4497f932..1b96376d3eb 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
+;;; ede/proj-obj.el --- EDE Generic Project Object code generation support -*- lexical-binding: t; -*-
-;;; Copyright (C) 1998-2000, 2005, 2008-2021 Free Software Foundation,
-;;; Inc.
+;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -35,8 +34,8 @@
;;; Code:
(defclass ede-proj-target-makefile-objectcode (ede-proj-target-makefile)
(;; Give this a new default
- (configuration-variables :initform ("debug" . (("CFLAGS" . "-g")
- ("LDFLAGS" . "-g"))))
+ (configuration-variables :initform '("debug" . (("CFLAGS" . "-g")
+ ("LDFLAGS" . "-g"))))
;; @TODO - add an include path.
(availablecompilers :initform '(ede-gcc-compiler
ede-g++-compiler
@@ -282,15 +281,15 @@ Argument THIS is the target to get sources from."
(append (oref this source) (oref this auxsource)))
(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile-objectcode)
- &optional moresource)
+ &optional _moresource)
"Insert variables needed by target THIS.
Optional argument MORESOURCE is not used."
(let ((ede-proj-objectcode-dodependencies
(oref (ede-target-parent this) automatic-dependencies)))
(cl-call-next-method)))
-(cl-defmethod ede-buffer-header-file((this ede-proj-target-makefile-objectcode)
- buffer)
+(cl-defmethod ede-buffer-header-file ((this ede-proj-target-makefile-objectcode)
+ _buffer)
"There are no default header files."
(or (cl-call-next-method)
;; Ok, nothing obvious. Try looking in ourselves.
diff --git a/lisp/cedet/ede/proj-prog.el b/lisp/cedet/ede/proj-prog.el
index 3817cd7d40e..87b2ff7a551 100644
--- a/lisp/cedet/ede/proj-prog.el
+++ b/lisp/cedet/ede/proj-prog.el
@@ -1,4 +1,4 @@
-;;; ede-proj-prog.el --- EDE Generic Project program support
+;;; ede-proj-prog.el --- EDE Generic Project program support -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2001, 2005, 2008-2021 Free Software Foundation,
;; Inc.
@@ -90,11 +90,11 @@ Note: Currently only used for Automake projects."
(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile-program))
"Insert variables needed by the compiler THIS."
(cl-call-next-method)
- (let ((lf (mapconcat 'identity (oref this ldflags) " ")))
+ (let ((lf (mapconcat #'identity (oref this ldflags) " ")))
(with-slots (ldlibs) this
(if ldlibs
(setq lf
- (concat lf " -l" (mapconcat 'identity ldlibs " -l")))))
+ (concat lf " -l" (mapconcat #'identity ldlibs " -l")))))
;; LDFLAGS as needed.
(when (and lf (not (string= "" lf)))
(ede-pmake-insert-variable-once "LDDEPS" (insert lf)))))
diff --git a/lisp/cedet/ede/proj-scheme.el b/lisp/cedet/ede/proj-scheme.el
index 51844af5361..b0e287895f3 100644
--- a/lisp/cedet/ede/proj-scheme.el
+++ b/lisp/cedet/ede/proj-scheme.el
@@ -1,4 +1,4 @@
-;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support
+;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support -*- lexical-binding: t -*-
;; Copyright (C) 1998-2000, 2009-2021 Free Software Foundation, Inc.
@@ -40,7 +40,7 @@
)
"This target consists of scheme files.")
-(cl-defmethod ede-proj-tweak-autoconf ((this ede-proj-target-scheme))
+(cl-defmethod ede-proj-tweak-autoconf ((_this ede-proj-target-scheme))
"Tweak the configure file (current buffer) to accommodate THIS."
(autoconf-insert-new-macro "AM_INIT_GUILE_MODULE"))
diff --git a/lisp/cedet/ede/proj-shared.el b/lisp/cedet/ede/proj-shared.el
index 130d7b897aa..01f19bc6572 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
+;;; ede-proj-shared.el --- EDE Generic Project shared library support -*- lexical-binding: t; -*-
-;;; Copyright (C) 1998-2000, 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -170,7 +170,7 @@ Use ldlibs to add addition libraries.")
)
(cl-defmethod ede-proj-configure-add-missing
- ((this ede-proj-target-makefile-shared-object))
+ ((_this ede-proj-target-makefile-shared-object))
"Query if any files needed by THIS provided by automake are missing.
Results in --add-missing being passed to automake."
(not (and (ede-expand-filename (ede-toplevel) "ltconfig")
@@ -185,7 +185,7 @@ Makefile.am generator, so use it to add this important bin program."
(insert (concat "lib" (ede-name this) ".la"))))
(cl-defmethod ede-proj-makefile-insert-automake-post-variables
- ((this ede-proj-target-makefile-shared-object))
+ ((_this ede-proj-target-makefile-shared-object))
"Insert bin_PROGRAMS variables needed by target THIS.
We need to override -program which has an LDADD element."
nil)
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 59628ebf4c9..c8c34d092f1 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -1,4 +1,4 @@
-;;; ede/proj.el --- EDE Generic Project file driver
+;;; ede/proj.el --- EDE Generic Project file driver -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2003, 2007-2021 Free Software Foundation, Inc.
@@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS, then included into
commands where the variable would usually appear.")
(rules :initarg :rules
:initform nil
- :type list
+ :type (list-of ede-makefile-rule)
:custom (repeat (object :objecttype ede-makefile-rule))
:label "Additional Rules"
:group (make)
@@ -220,7 +220,7 @@ This enables the creation of your target type."
((extension :initform ".ede")
(file-header-line :initform ";; EDE Project Files are auto generated: Do Not Edit")
(makefile-type :initarg :makefile-type
- :initform Makefile
+ :initform 'Makefile
:type symbol
:custom (choice (const Makefile)
;(const Makefile.in)
@@ -240,7 +240,7 @@ in targets.")
:documentation "Variables to set in this Makefile.")
(configuration-variables
:initarg :configuration-variables
- :initform ("debug" (("DEBUG" . "1")))
+ :initform '("debug" (("DEBUG" . "1")))
:type list
:custom (repeat (cons (string :tag "Configuration")
(repeat
@@ -269,10 +269,10 @@ These files can contain additional rules, variables, and customizations.")
:documentation
"Non-nil to do implement automatic dependencies in the Makefile.")
(menu :initform
- (
- [ "Regenerate Makefiles" ede-proj-regenerate t ]
- [ "Upload Distribution" ede-upload-distribution t ]
- )
+ '(
+ [ "Regenerate Makefiles" ede-proj-regenerate t ]
+ [ "Upload Distribution" ede-upload-distribution t ]
+ )
)
(metasubproject
:initarg :metasubproject
@@ -339,7 +339,7 @@ Argument PROJ is the project to save."
(cl-call-next-method)
(ede-proj-save proj))
-(cl-defmethod eieio-done-customizing ((target ede-proj-target))
+(cl-defmethod eieio-done-customizing ((_target ede-proj-target))
"Call this when a user finishes customizing this object.
Argument TARGET is the project we are completing customization on."
(cl-call-next-method)
@@ -462,7 +462,7 @@ FILE must be massaged by `ede-convert-path'."
(object-remove-from-list target 'auxsource (ede-convert-path target file))
(ede-proj-save))
-(cl-defmethod project-update-version ((this ede-proj-project))
+(cl-defmethod project-update-version ((_this ede-proj-project))
"The :version of project THIS has changed."
(ede-proj-save))
@@ -486,7 +486,7 @@ FILE must be massaged by `ede-convert-path'."
(concat (oref this name) "-" (oref this version) ".tar.gz")
))
-(cl-defmethod project-compile-project ((proj ede-proj-project) &optional command)
+(cl-defmethod project-compile-project ((proj ede-proj-project) &optional _command)
"Compile the entire current project PROJ.
Argument COMMAND is the command to use when compiling."
(let ((pm (ede-proj-dist-makefile proj))
@@ -499,13 +499,13 @@ Argument COMMAND is the command to use when compiling."
;;; Target type specific compilations/debug
;;
-(cl-defmethod project-compile-target ((obj ede-proj-target) &optional command)
+(cl-defmethod project-compile-target ((_obj ede-proj-target) &optional command)
"Compile the current target OBJ.
Argument COMMAND is the command to use for compiling the target."
(project-compile-project (ede-current-project) command))
(cl-defmethod project-compile-target ((obj ede-proj-target-makefile)
- &optional command)
+ &optional _command)
"Compile the current target program OBJ.
Optional argument COMMAND is the s the alternate command to use."
(ede-proj-setup-buildenvironment (ede-current-project))
@@ -545,11 +545,11 @@ Converts all symbols into the objects to be used."
(if comp
;; Now that we have a pre-set compilers to use, convert tye symbols
;; into objects for ease of use
- (if (listp comp)
- (setq comp (mapcar 'symbol-value comp))
- (setq comp (list (symbol-value comp))))
+ (setq comp (if (listp comp)
+ (mapcar #'symbol-value comp)
+ (list (symbol-value comp))))
(let* ((acomp (oref obj availablecompilers))
- (avail (mapcar 'symbol-value acomp))
+ (avail (mapcar #'symbol-value acomp))
(st (oref obj sourcetype))
(sources (oref obj source)))
;; COMP is not specified, so generate a list from the available
@@ -585,7 +585,7 @@ Converts all symbols into the objects to be used."
(setq link (list (symbol-value link)))
(error ":linker is not a symbol. Howd you do that?"))
(let* ((alink (oref obj availablelinkers))
- (avail (mapcar 'symbol-value alink))
+ (avail (mapcar #'symbol-value alink))
(st (oref obj sourcetype))
(sources (oref obj source)))
;; LINKER is not specified, so generate a list from the available
diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el
index b8984a0d514..258917f01b9 100644
--- a/lisp/cedet/ede/project-am.el
+++ b/lisp/cedet/ede/project-am.el
@@ -1,4 +1,4 @@
-;;; project-am.el --- A project management scheme based on automake files.
+;;; project-am.el --- A project management scheme based on automake files. -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2000, 2003, 2005, 2007-2021 Free Software
;; Foundation, Inc.
@@ -54,17 +54,14 @@
(defcustom project-am-compile-project-command nil
"Default command used to compile a project."
- :group 'project-am
:type '(choice (const nil) string))
(defcustom project-am-compile-target-command (concat ede-make-command " -k %s")
"Default command used to compile a project."
- :group 'project-am
:type 'string)
(defcustom project-am-debug-target-function 'gdb
"Default Emacs command used to debug a target."
- :group 'project-am
:type 'function) ; make this be a list some day
(defconst project-am-type-alist
@@ -240,8 +237,8 @@ OT is the object target. DIR is the directory to start in."
(if (= (point-min) (point))
(re-search-forward (ede-target-name obj))))
-(cl-defmethod project-new-target ((proj project-am-makefile)
- &optional name type)
+(cl-defmethod project-new-target ((_proj project-am-makefile)
+ &optional name type)
"Create a new target named NAME.
Argument TYPE is the type of target to insert. This is a string
matching something in `project-am-type-alist' or type class symbol.
@@ -300,7 +297,7 @@ buffer being in order to provide a smart default target type."
;; This should be handled at the EDE level, calling a method of the
;; top most project.
;;
-(cl-defmethod project-compile-project ((obj project-am-target) &optional command)
+(cl-defmethod project-compile-project ((_obj project-am-target) &optional command)
"Compile the entire current project.
Argument COMMAND is the command to use when compiling."
(require 'compile)
@@ -324,7 +321,7 @@ Argument COMMAND is the command to use when compiling."
(let* ((default-directory (project-am-find-topmost-level default-directory)))
(compile command)))
-(cl-defmethod project-compile-project ((obj project-am-makefile)
+(cl-defmethod project-compile-project ((_obj project-am-makefile)
&optional command)
"Compile the entire current project.
Argument COMMAND is the command to use when compiling."
@@ -349,7 +346,7 @@ Argument COMMAND is the command to use when compiling."
(let* ((default-directory (project-am-find-topmost-level default-directory)))
(compile command)))
-(cl-defmethod project-compile-target ((obj project-am-target) &optional command)
+(cl-defmethod project-compile-target ((_obj project-am-target) &optional command)
"Compile the current target.
Argument COMMAND is the command to use for compiling the target."
(require 'compile)
@@ -423,7 +420,7 @@ Argument COMMAND is the command to use for compiling the target."
;;; Project loading and saving
;;
-(defun project-am-load (directory &optional rootproj)
+(defun project-am-load (directory &optional _rootproj)
"Read an automakefile DIRECTORY into our data structure.
If a given set of projects has already been loaded, then do nothing
but return the project for the directory given.
@@ -442,34 +439,28 @@ Optional ROOTPROJ is the root EDE project."
(file-name-directory (directory-file-name newdir))))
(expand-file-name dir)))
+(defvar recentf-exclude)
+
(defmacro project-am-with-makefile-current (dir &rest forms)
"Set the Makefile.am in DIR to be the current buffer.
-Run FORMS while the makefile is current.
-Kill the makefile if it was not loaded before the load."
- `(let* ((fn (expand-file-name "Makefile.am" ,dir))
- (fb nil)
- (kb (get-file-buffer fn)))
- (if (not (file-exists-p fn))
- nil
- (save-excursion
- (if kb (setq fb kb)
- ;; We need to find-file this thing, but don't use
- ;; any semantic features.
- (let ((semantic-init-hook nil)
- (recentf-exclude '( (lambda (f) t) ))
- )
- (setq fb (find-file-noselect fn)))
- )
- (set-buffer fb)
- (prog1 ,@forms
- (if (not kb) (kill-buffer (current-buffer))))))))
-(put 'project-am-with-makefile-current 'lisp-indent-function 1)
-
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec project-am-with-makefile-current
- (form def-body))))
-
+Run FORMS while the makefile is current."
+ (declare (indent 1) (debug (form def-body)))
+ `(project-am--with-makefile-current ,dir (lambda () ,@forms)))
+
+(defun project-am--with-makefile-current (dir fun)
+ (let* ((fn (expand-file-name "Makefile.am" dir))
+ (kb (get-file-buffer fn)))
+ (if (not (file-exists-p fn))
+ nil
+ (with-current-buffer
+ (or kb
+ ;; We need to find-file this thing, but don't use
+ ;; any semantic features.
+ (let ((semantic-init-hook nil)
+ (recentf-exclude `(,(lambda (_f) t))))
+ (find-file-noselect fn)))
+ (unwind-protect (funcall fun)
+ (if (not kb) (kill-buffer (current-buffer))))))))
(defun project-am-load-makefile (path &optional suggestedname)
"Convert PATH into a project Makefile, and return its project object.
@@ -480,6 +471,7 @@ This is used when subprojects are made in named subdirectories."
(if (and ede-object (project-am-makefile-p ede-object))
ede-object
(let* ((pi (project-am-package-info path))
+ (fn buffer-file-name)
(sfn (when suggestedname
(project-am-last-dir suggestedname)))
(pn (or sfn (nth 0 pi) (project-am-last-dir fn)))
@@ -493,8 +485,7 @@ This is used when subprojects are made in named subdirectories."
:file fn)))
(oset ampf directory (file-name-directory fn))
(oset ampf configureoutputfiles cof)
- (make-local-variable 'ede-object)
- (setq ede-object ampf)
+ (setq-local ede-object ampf)
;; Move the rescan after we set ede-object to prevent recursion
(project-rescan ampf)
ampf))))
@@ -605,10 +596,8 @@ Strip out duplicates, and recurse on variables."
(project-am-expand-subdirlist
place (makefile-macro-file-list var))
;; Else, add SP in if it isn't a dup.
- (if (member sp (symbol-value place))
- nil ; don't do it twice.
- (set place (cons sp (symbol-value place))) ;; add
- ))))
+ (cl-pushnew sp (gv-deref place) :test #'equal) ;; add
+ )))
subdirs)
)
@@ -654,7 +643,7 @@ Strip out duplicates, and recurse on variables."
;; We still have a list of targets. For all buffers, make sure
;; their object still exists!
;; FIGURE THIS OUT
- (project-am-expand-subdirlist 'csubprojexpanded csubproj)
+ (project-am-expand-subdirlist (gv-ref csubprojexpanded) csubproj)
;; Ok, now let's look at all our sub-projects.
(mapc (lambda (sp)
(let* ((subdir (file-name-as-directory
@@ -735,19 +724,19 @@ Strip out duplicates, and recurse on variables."
"Return the default macro to `edit' for this object type."
(concat (subst-char-in-string ?- ?_ (oref this name)) "_SOURCES"))
-(cl-defmethod project-am-macro ((this project-am-header-noinst))
+(cl-defmethod project-am-macro ((_this project-am-header-noinst))
"Return the default macro to `edit' for this object."
"noinst_HEADERS")
-(cl-defmethod project-am-macro ((this project-am-header-inst))
+(cl-defmethod project-am-macro ((_this project-am-header-inst))
"Return the default macro to `edit' for this object."
"include_HEADERS")
-(cl-defmethod project-am-macro ((this project-am-header-pkg))
+(cl-defmethod project-am-macro ((_this project-am-header-pkg))
"Return the default macro to `edit' for this object."
"pkginclude_HEADERS")
-(cl-defmethod project-am-macro ((this project-am-header-chk))
+(cl-defmethod project-am-macro ((_this project-am-header-chk))
"Return the default macro to `edit' for this object."
"check_HEADERS")
@@ -759,7 +748,7 @@ Strip out duplicates, and recurse on variables."
"Return the default macro to `edit' for this object type."
(oref this name))
-(cl-defmethod project-am-macro ((this project-am-lisp))
+(cl-defmethod project-am-macro ((_this project-am-lisp))
"Return the default macro to `edit' for this object."
"lisp_LISP")
@@ -786,13 +775,11 @@ nil means that this buffer belongs to no-one."
"Return t if object THIS lays claim to the file in BUFFER."
(let ((efn (expand-file-name (buffer-file-name buffer))))
(or (string= (oref this file) efn)
- (string-match "/configure\\.ac$" efn)
- (string-match "/configure\\.in$" efn)
- (string-match "/configure$" efn)
+ (string-match "/configure\\(?:\\.ac\\|\\.in\\)?\\'" efn)
;; Search output files.
(let ((ans nil))
(dolist (f (oref this configureoutputfiles))
- (when (string-match (concat (regexp-quote f) "$") efn)
+ (when (string-match (concat (regexp-quote f) "\\'") efn)
(setq ans t)))
ans)
)))
@@ -823,7 +810,7 @@ nil means that this buffer belongs to no-one."
"Return the sub project in AMPF specified by SUBDIR."
(object-assoc (expand-file-name subdir) 'file (oref ampf subproj)))
-(cl-defmethod project-compile-target-command ((this project-am-target))
+(cl-defmethod project-compile-target-command ((_this project-am-target))
"Default target to use when compiling a given target."
;; This is a pretty good default for most.
"")
@@ -862,7 +849,7 @@ Argument FILE is the file to extract the end directory name from."
(t
'project-am-program)))
-(cl-defmethod ede-buffer-header-file((this project-am-objectcode) buffer)
+(cl-defmethod ede-buffer-header-file((this project-am-objectcode) _buffer)
"There are no default header files."
(or (cl-call-next-method)
(let ((s (oref this source))
@@ -911,22 +898,13 @@ files in the project."
"Set the Configure FILE in the top most directory above DIR as current.
Run FORMS in the configure file.
Kill the Configure buffer if it was not already in a buffer."
- `(save-excursion
- (let ((fb (generate-new-buffer ,file)))
- (set-buffer fb)
- (erase-buffer)
- (insert-file-contents ,file)
- (prog1 ,@forms
- (kill-buffer fb)))))
-
-(put 'project-am-with-config-current 'lisp-indent-function 1)
-
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec project-am-with-config-current
- (form def-body))))
-
-(defmacro project-am-extract-shell-variable (var)
+ (declare (indent 1) (debug t))
+ `(with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents ,file)
+ ,@forms))
+
+(defun project-am-extract-shell-variable (var)
"Extract the value of the shell variable VAR from a shell script."
(save-excursion
(goto-char (point-min))
@@ -998,12 +976,12 @@ Calculates the info with `project-am-extract-package-info'."
(project-am-extract-package-info dir)))
;; for simple per project include path extension
-(cl-defmethod ede-system-include-path ((this project-am-makefile))
+(cl-defmethod ede-system-include-path ((_this project-am-makefile))
"Return `project-am-localvars-include-path', usually local variable
per file or in .dir-locals.el or similar."
(bound-and-true-p project-am-localvars-include-path))
-(cl-defmethod ede-system-include-path ((this project-am-target))
+(cl-defmethod ede-system-include-path ((_this project-am-target))
"Return `project-am-localvars-include-path', usually local variable
per file or in .dir-locals.el or similar."
(bound-and-true-p project-am-localvars-include-path))
diff --git a/lisp/cedet/ede/shell.el b/lisp/cedet/ede/shell.el
index ba36fccd0ba..371b04f9d29 100644
--- a/lisp/cedet/ede/shell.el
+++ b/lisp/cedet/ede/shell.el
@@ -1,4 +1,4 @@
-;;; ede/shell.el --- A shell controlled by EDE.
+;;; ede/shell.el --- A shell controlled by EDE. -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;;
diff --git a/lisp/cedet/ede/simple.el b/lisp/cedet/ede/simple.el
index ea6162ef94f..aaeb3f713c9 100644
--- a/lisp/cedet/ede/simple.el
+++ b/lisp/cedet/ede/simple.el
@@ -1,4 +1,4 @@
-;;; ede/simple.el --- Overlay an EDE structure on an existing project
+;;; ede/simple.el --- Overlay an EDE structure on an existing project -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -78,7 +78,7 @@ The directory has three parts:
ede-simple-save-file-name)
))
-(defun ede-simple-load (dir &optional rootproj)
+(defun ede-simple-load (dir &optional _rootproj)
"Load a project of type `Simple' for the directory DIR.
Return nil if there isn't one.
ROOTPROJ is nil, since we will only create a single EDE project here."
@@ -112,7 +112,7 @@ Each directory needs a project file to control it.")
(eieio-persistent-save proj))
(cl-defmethod ede-find-subproject-for-directory ((proj ede-simple-project)
- dir)
+ _dir)
"Return PROJ, for handling all subdirs below DIR."
proj)
diff --git a/lisp/cedet/ede/source.el b/lisp/cedet/ede/source.el
index abdb07f2d73..5dbad4fcc00 100644
--- a/lisp/cedet/ede/source.el
+++ b/lisp/cedet/ede/source.el
@@ -1,4 +1,4 @@
-;; ede/source.el --- EDE source code object
+;; ede/source.el --- EDE source code object -*- lexical-binding: t; -*-
;; Copyright (C) 2000, 2008-2021 Free Software Foundation, Inc.
@@ -72,7 +72,7 @@ that they are willing to use.")
;;; Methods
;;
-(cl-defmethod initialize-instance :after ((this ede-sourcecode) &rest fields)
+(cl-defmethod initialize-instance :after ((this ede-sourcecode) &rest _fields)
"Make sure that all ede compiler objects are cached in
`ede-compiler-list'."
(let ((lst ede-sourcecode-list))
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el
index 48c4a89c440..01d4f943df5 100644
--- a/lisp/cedet/ede/speedbar.el
+++ b/lisp/cedet/ede/speedbar.el
@@ -1,4 +1,4 @@
-;;; ede/speedbar.el --- Speedbar viewing of EDE projects
+;;; ede/speedbar.el --- Speedbar viewing of EDE projects -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2001, 2003, 2005, 2007-2021 Free Software
;; Foundation, Inc.
@@ -42,21 +42,21 @@
(setq ede-speedbar-key-map (speedbar-make-specialized-keymap))
;; General viewing things
- (define-key ede-speedbar-key-map "\C-m" 'speedbar-edit-line)
- (define-key ede-speedbar-key-map "+" 'speedbar-expand-line)
- (define-key ede-speedbar-key-map "=" 'speedbar-expand-line)
- (define-key ede-speedbar-key-map "-" 'speedbar-contract-line)
- (define-key ede-speedbar-key-map " " 'speedbar-toggle-line-expansion)
+ (define-key ede-speedbar-key-map "\C-m" #'speedbar-edit-line)
+ (define-key ede-speedbar-key-map "+" #'speedbar-expand-line)
+ (define-key ede-speedbar-key-map "=" #'speedbar-expand-line)
+ (define-key ede-speedbar-key-map "-" #'speedbar-contract-line)
+ (define-key ede-speedbar-key-map " " #'speedbar-toggle-line-expansion)
;; Some object based things
- (define-key ede-speedbar-key-map "C" 'eieio-speedbar-customize-line)
+ (define-key ede-speedbar-key-map "C" #'eieio-speedbar-customize-line)
;; Some project based things
- (define-key ede-speedbar-key-map "R" 'ede-speedbar-remove-file-from-target)
- (define-key ede-speedbar-key-map "b" 'ede-speedbar-compile-line)
- (define-key ede-speedbar-key-map "B" 'ede-speedbar-compile-project)
- (define-key ede-speedbar-key-map "D" 'ede-speedbar-make-distribution)
- (define-key ede-speedbar-key-map "E" 'ede-speedbar-edit-projectfile)
+ (define-key ede-speedbar-key-map "R" #'ede-speedbar-remove-file-from-target)
+ (define-key ede-speedbar-key-map "b" #'ede-speedbar-compile-line)
+ (define-key ede-speedbar-key-map "B" #'ede-speedbar-compile-project)
+ (define-key ede-speedbar-key-map "D" #'ede-speedbar-make-distribution)
+ (define-key ede-speedbar-key-map "E" #'ede-speedbar-edit-projectfile)
)
(defvar ede-speedbar-menu
@@ -98,7 +98,7 @@
(speedbar-get-focus)
)
-(defun ede-speedbar-toplevel-buttons (dir)
+(defun ede-speedbar-toplevel-buttons (_dir)
"Return a list of objects to display in speedbar.
Argument DIR is the directory from which to derive the list of objects."
ede-projects
@@ -180,13 +180,13 @@ Argument DIR is the directory from which to derive the list of objects."
(setq depth (1- depth)))
(speedbar-line-token))))
-(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-project) &optional depth)
+(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-project) &optional _depth)
"Return the path to OBJ.
Optional DEPTH is the depth we start at."
(file-name-directory (oref obj file))
)
-(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-target) &optional depth)
+(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-target) &optional _depth)
"Return the path to OBJ.
Optional DEPTH is the depth we start at."
(let ((proj (ede-target-parent obj)))
@@ -208,7 +208,7 @@ Optional DEPTH is the depth we start at."
"Provide a speedbar description for OBJ."
(ede-description obj))
-(cl-defmethod eieio-speedbar-child-description ((obj ede-target))
+(cl-defmethod eieio-speedbar-child-description ((_obj ede-target))
"Provide a speedbar description for a plain-child of OBJ.
A plain child is a child element which is not an EIEIO object."
(or (speedbar-item-info-file-helper)
@@ -251,7 +251,7 @@ It has depth DEPTH."
;;; Generic file management for TARGETS
;;
-(defun ede-file-find (text token indent)
+(defun ede-file-find (_text token indent)
"Find the file TEXT at path TOKEN.
INDENT is the current indentation level."
(speedbar-find-file-in-frame
@@ -290,7 +290,7 @@ level."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun ede-tag-find (text token indent)
+(defun ede-tag-find (_text token _indent)
"For the tag TEXT in a file TOKEN, goto that position.
INDENT is the current indentation level."
(let ((file (ede-find-nearest-file-line)))
@@ -314,21 +314,21 @@ INDENT is the current indentation level."
(defvar ede-speedbar-file-menu-additions
'("----"
["Create EDE Target" ede-new-target (ede-current-project) ]
- ["Add to project" ede-speedbar-file-add-to-project (ede-current-project) ]
+ ;; ["Add to project" ede-speedbar-file-add-to-project (ede-current-project) ]
["Compile project" ede-speedbar-compile-project (ede-current-project) ]
- ["Compile file target" ede-speedbar-compile-file-target (ede-current-project) ]
+ ;; ["Compile file target" ede-speedbar-compile-file-target (ede-current-project) ]
["Make distribution" ede-make-dist (ede-current-project) ]
)
"Set of menu items to splice into the speedbar menu.")
(defvar ede-speedbar-file-keymap
(let ((km (make-sparse-keymap)))
- (define-key km "a" 'ede-speedbar-file-add-to-project)
- (define-key km "t" 'ede-new-target)
- (define-key km "s" 'ede-speedbar)
- (define-key km "C" 'ede-speedbar-compile-project)
- (define-key km "c" 'ede-speedbar-compile-file-target)
- (define-key km "d" 'ede-make-dist)
+ ;; (define-key km "a" #'ede-speedbar-file-add-to-project)
+ (define-key km "t" #'ede-new-target)
+ (define-key km "s" #'ede-speedbar)
+ (define-key km "C" #'ede-speedbar-compile-project)
+ ;; (define-key km "c" #'ede-speedbar-compile-file-target)
+ (define-key km "d" #'ede-make-dist)
km)
"Keymap spliced into the speedbar keymap.")
diff --git a/lisp/cedet/ede/srecode.el b/lisp/cedet/ede/srecode.el
index 5dd0a7ec614..dd009bfb31a 100644
--- a/lisp/cedet/ede/srecode.el
+++ b/lisp/cedet/ede/srecode.el
@@ -1,4 +1,4 @@
-;;; ede/srecode.el --- EDE utilities on top of SRecoder
+;;; ede/srecode.el --- EDE utilities on top of SRecoder -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -86,7 +86,6 @@ Note: Just like `srecode-insert', but templates found in `ede' app."
(car (cdr dictionary-entries)))
(setq dictionary-entries
(cdr (cdr dictionary-entries))))
-
))
(provide 'ede/srecode)
diff --git a/lisp/cedet/ede/system.el b/lisp/cedet/ede/system.el
index d83d6d1cc69..8ef38f0d33e 100644
--- a/lisp/cedet/ede/system.el
+++ b/lisp/cedet/ede/system.el
@@ -1,4 +1,4 @@
-;;; ede-system.el --- EDE working with the system (VC, FTP, ETC)
+;;; ede-system.el --- EDE working with the system (VC, FTP, ETC) -*- lexical-binding: t -*-
;; Copyright (C) 2001-2003, 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/ede/util.el b/lisp/cedet/ede/util.el
index 80cbc211fc2..2b2402c6425 100644
--- a/lisp/cedet/ede/util.el
+++ b/lisp/cedet/ede/util.el
@@ -1,4 +1,4 @@
-;;; ede/util.el --- EDE utilities
+;;; ede/util.el --- EDE utilities -*- lexical-binding: t; -*-
;; Copyright (C) 2000, 2005, 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index b5b22094b86..247f78ecff7 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -91,13 +91,13 @@ MODES can be a symbol or a list of symbols.
FUNCTION does not have arguments."
(or (listp modes) (setq modes (list modes)))
(mode-local-map-file-buffers
- function #'(lambda ()
- (let ((mm (mode-local-equivalent-mode-p major-mode))
- (ans nil))
- (while (and (not ans) mm)
- (setq ans (memq (car mm) modes)
- mm (cdr mm)) )
- ans))))
+ function (lambda ()
+ (let ((mm (mode-local-equivalent-mode-p major-mode))
+ (ans nil))
+ (while (and (not ans) mm)
+ (setq ans (memq (car mm) modes)
+ mm (cdr mm)) )
+ ans))))
;;; Hook machinery
;;
@@ -170,11 +170,10 @@ definition."
;;; Core bindings API
;;
-(defvar mode-local-symbol-table nil
+(defvar-local mode-local-symbol-table nil
"Buffer local mode bindings.
These symbols provide a hook for a `major-mode' to specify specific
behaviors. Use the function `mode-local-bind' to define new bindings.")
-(make-variable-buffer-local 'mode-local-symbol-table)
(defvar mode-local-active-mode nil
"Major mode in which bindings are active.")
@@ -314,7 +313,7 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable."
;; Do the normal thing.
(let (modes table old-locals)
(unless mode
- (set (make-local-variable 'mode-local--init-mode) major-mode)
+ (setq-local mode-local--init-mode major-mode)
(setq mode major-mode))
;; Get MODE's parents & MODE in the right order.
(while mode
@@ -324,14 +323,14 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable."
(dolist (mode modes)
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
- #'(lambda (var)
- (when (get var 'mode-variable-flag)
- (let ((v (intern (symbol-name var))))
- ;; Save the current buffer-local value of the
- ;; mode-local variable.
- (and (local-variable-p v (current-buffer))
- (push (cons v (symbol-value v)) old-locals))
- (set (make-local-variable v) (symbol-value var)))))
+ (lambda (var)
+ (when (get var 'mode-variable-flag)
+ (let ((v (intern (symbol-name var))))
+ ;; Save the current buffer-local value of the
+ ;; mode-local variable.
+ (and (local-variable-p v (current-buffer))
+ (push (cons v (symbol-value v)) old-locals))
+ (set (make-local-variable v) (symbol-value var)))))
table)))
old-locals)))
@@ -349,9 +348,9 @@ If MODE is not specified it defaults to current `major-mode'."
(while mode
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
- #'(lambda (var)
- (when (get var 'mode-variable-flag)
- (kill-local-variable (intern (symbol-name var)))))
+ (lambda (var)
+ (when (get var 'mode-variable-flag)
+ (kill-local-variable (intern (symbol-name var)))))
table))
(setq mode (get-mode-local-parent mode)))))
@@ -429,7 +428,7 @@ Return the value of the last VAL."
;; Save mode bindings
(mode-local-bind (list ,@bl) '(mode-variable-flag t) ',mode)
;; Assign to local variables in all existing buffers in MODE
- (mode-local-map-mode-buffers #'(lambda () ,@sl) ',mode)
+ (mode-local-map-mode-buffers (lambda () ,@sl) ',mode)
;; Return the last value
,tmp)
)))
@@ -577,7 +576,7 @@ OVERARGS is a list of arguments passed to the override and
(put :override-with-args 'lisp-indent-function 1)
(define-obsolete-function-alias 'define-overload
- 'define-overloadable-function "27.1")
+ #'define-overloadable-function "27.1")
(define-obsolete-function-alias 'function-overload-p
#'mode-local--function-overload-p "27.1")
@@ -894,7 +893,7 @@ invoked interactively."
(interactive
(list (completing-read
"Mode: " obarray
- #'(lambda (s) (get s 'mode-local-symbol-table))
+ (lambda (s) (get s 'mode-local-symbol-table))
t (symbol-name major-mode))))
(when (setq mode (intern-soft mode))
(mode-local-describe-bindings-1 mode (called-interactively-p 'any))))
diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el
index aef4fc89057..7928fa1bf42 100644
--- a/lisp/cedet/pulse.el
+++ b/lisp/cedet/pulse.el
@@ -1,6 +1,6 @@
-;;; pulse.el --- Pulsing Overlays
+;;; pulse.el --- Pulsing Overlays -*- lexical-binding: t; -*-
-;;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.0
@@ -30,10 +30,9 @@
;;
;; The following are useful entry points:
;;
-;; `pulse' - Cause `pulse-highlight-face' to shift toward background color.
+;; `pulse-tick' - Cause `pulse-highlight-face' to shift toward background color.
;; Assumes you are using a version of Emacs that supports pulsing.
;;
-;;
;; `pulse-momentary-highlight-one-line' - Pulse a single line at POINT.
;; `pulse-momentary-highlight-region' - Pulse a region.
;; `pulse-momentary-highlight-overlay' - Pulse an overlay.
@@ -50,7 +49,9 @@
;;
;; Pulse is a part of CEDET. http://cedet.sf.net
-(defun pulse-available-p ()
+(require 'color)
+
+(defun pulse-available-p ()
"Return non-nil if pulsing is available on the current frame."
(condition-case nil
(let ((v (color-values (face-background 'default))))
@@ -90,69 +91,27 @@ Face used for temporary highlighting of tags for effect."
:group 'pulse)
;;; Code:
-;;
-(defun pulse-int-to-hex (int &optional nb-digits)
- "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
-Each X in the output string is a hexadecimal digit.
-NB-DIGITS is the number of hex digits. If INT is too large to be
-represented with NB-DIGITS, then the result is truncated from the
-left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
-the hex equivalent of 256 decimal is 100, which is more than 2 digits.
-
-This function was blindly copied from hexrgb.el by Drew Adams.
-https://www.emacswiki.org/emacs/hexrgb.el"
- (setq nb-digits (or nb-digits 4))
- (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
-
-(defun pulse-color-values-to-hex (values)
- "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
-Each X in the string is a hexadecimal digit.
-Input VALUES is as for the output of `x-color-values'.
-
-This function was blindly copied from hexrgb.el by Drew Adams.
-https://www.emacswiki.org/emacs/hexrgb.el"
- (concat "#"
- (pulse-int-to-hex (nth 0 values) 4) ; red
- (pulse-int-to-hex (nth 1 values) 4) ; green
- (pulse-int-to-hex (nth 2 values) 4))) ; blue
(defcustom pulse-iterations 10
"Number of iterations in a pulse operation."
:group 'pulse
:type 'number)
+
(defcustom pulse-delay .03
"Delay between face lightening iterations."
:group 'pulse
:type 'number)
-(defun pulse-lighten-highlight ()
- "Lighten the face by 1/`pulse-iterations' toward the background color.
-Return t if there is more drift to do, nil if completed."
- (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations)
- nil
- (let* ((frame (color-values (face-background 'default)))
- (pulse-background (face-background
- (get 'pulse-highlight-face
- :startface)
- nil t)));; can be nil
- (when pulse-background
- (let* ((start (color-values pulse-background))
- (frac (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations)
- (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations)
- (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations)))
- (it (get 'pulse-highlight-face :iteration))
- )
- (set-face-background 'pulse-highlight-face
- (pulse-color-values-to-hex
- (list
- (+ (nth 0 start) (* (nth 0 frac) it))
- (+ (nth 1 start) (* (nth 1 frac) it))
- (+ (nth 2 start) (* (nth 2 frac) it)))))
- (put 'pulse-highlight-face :iteration (1+ it))
- (if (>= (1+ it) pulse-iterations)
- nil
- t)))
- )))
+;;; Convenience Functions
+;;
+(defvar pulse-momentary-overlay nil
+ "The current pulsing overlay.")
+
+(defvar pulse-momentary-timer nil
+ "The current pulsing timer.")
+
+(defvar pulse-momentary-iteration 0
+ "The current pulsing iteration.")
(defun pulse-reset-face (&optional face)
"Reset the pulse highlighting FACE."
@@ -161,20 +120,12 @@ Return t if there is more drift to do, nil if completed."
(face-background face nil t)
(face-background 'pulse-highlight-start-face)
))
- (and face
- (set-face-extend 'pulse-highlight-face
- (face-extend-p face nil t)))
+ (set-face-extend 'pulse-highlight-face
+ (face-extend-p (or face 'pulse-highlight-start-face)
+ nil t))
(put 'pulse-highlight-face :startface (or face
'pulse-highlight-start-face))
- (put 'pulse-highlight-face :iteration 0))
-
-;;; Convenience Functions
-;;
-(defvar pulse-momentary-overlay nil
- "The current pulsing overlay.")
-
-(defvar pulse-momentary-timer nil
- "The current pulsing timer.")
+ (setq pulse-momentary-iteration 0))
(defun pulse-momentary-highlight-overlay (o &optional face)
"Pulse the overlay O, unhighlighting before next command.
@@ -194,21 +145,29 @@ Optional argument FACE specifies the face to do the highlighting."
(progn
(overlay-put o 'face (or face 'pulse-highlight-start-face))
(add-hook 'pre-command-hook
- 'pulse-momentary-unhighlight))
+ #'pulse-momentary-unhighlight))
;; Pulse it.
(overlay-put o 'face 'pulse-highlight-face)
;; The pulse function puts FACE onto 'pulse-highlight-face.
;; Thus above we put our face on the overlay, but pulse
;; with a reference face needed for the color.
(pulse-reset-face face)
- (setq pulse-momentary-timer
- (run-with-timer 0 pulse-delay #'pulse-tick
- (time-add nil
- (* pulse-delay pulse-iterations)))))))
-
-(defun pulse-tick (stop-time)
+ (let* ((start (color-name-to-rgb
+ (face-background 'pulse-highlight-face nil 'default)))
+ (stop (color-name-to-rgb (face-background 'default)))
+ (colors (mapcar (apply-partially 'apply 'color-rgb-to-hex)
+ (color-gradient start stop pulse-iterations))))
+ (setq pulse-momentary-timer
+ (run-with-timer 0 pulse-delay #'pulse-tick
+ colors
+ (time-add nil
+ (* pulse-delay pulse-iterations))))))))
+
+(defun pulse-tick (colors stop-time)
(if (time-less-p nil stop-time)
- (pulse-lighten-highlight)
+ (when-let (color (elt colors pulse-momentary-iteration))
+ (set-face-background 'pulse-highlight-face color)
+ (setq pulse-momentary-iteration (1+ pulse-momentary-iteration)))
(pulse-momentary-unhighlight)))
(defun pulse-momentary-unhighlight ()
@@ -233,7 +192,7 @@ Optional argument FACE specifies the face to do the highlighting."
(cancel-timer pulse-momentary-timer))
;; Remove this hook.
- (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight))
+ (remove-hook 'pre-command-hook #'pulse-momentary-unhighlight))
;;;###autoload
(defun pulse-momentary-highlight-one-line (point &optional face)
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 232e2b89686..fb443fa4a32 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -1,4 +1,4 @@
-;;; semantic.el --- Semantic buffer evaluator.
+;;; semantic.el --- Semantic buffer evaluator. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -57,6 +57,7 @@ excluded if a released version is required.
It is assumed that if the current version is newer than that specified,
everything passes. Exceptions occur when known incompatibilities are
introduced."
+ (declare (obsolete emacs-version "28.1"))
(require 'inversion)
(inversion-test 'semantic
(concat major "." minor
@@ -77,15 +78,12 @@ introduced."
;;; Variables and Configuration
;;
-(defvar semantic--parse-table nil
+(defvar-local semantic--parse-table nil
"Variable that defines how to parse top level items in a buffer.
This variable is for internal use only, and its content depends on the
external parser used.")
-(make-variable-buffer-local 'semantic--parse-table)
-(semantic-varalias-obsolete 'semantic-toplevel-bovine-table
- 'semantic--parse-table "23.2")
-(defvar semantic-symbol->name-assoc-list
+(defvar-local semantic-symbol->name-assoc-list
'((type . "Types")
(variable . "Variables")
(function . "Functions")
@@ -97,33 +95,19 @@ It is sometimes useful for a language to use a different string
in place of the default, even though that language will still
return a symbol. For example, Java return's includes, but the
string can be replaced with `Imports'.")
-(make-variable-buffer-local 'semantic-symbol->name-assoc-list)
-(defvar semantic-symbol->name-assoc-list-for-type-parts nil
+(defvar-local semantic-symbol->name-assoc-list-for-type-parts nil
"Like `semantic-symbol->name-assoc-list' for type parts.
Some tags that have children (see `semantic-tag-children-compatibility')
will want to define the names of classes of tags differently than at
the top level. For example, in C++, a Function may be called a
Method. In addition, there may be new types of tags that exist only
in classes, such as protection labels.")
-(make-variable-buffer-local 'semantic-symbol->name-assoc-list-for-type-parts)
-(defvar semantic-case-fold nil
+(defvar-local semantic-case-fold nil
"Value for `case-fold-search' when parsing.")
-(make-variable-buffer-local 'semantic-case-fold)
-
-(defvar semantic-expand-nonterminal nil
- "Function to call for each nonterminal production.
-Return a list of non-terminals derived from the first argument, or nil
-if it does not need to be expanded.
-Languages with compound definitions should use this function to expand
-from one compound symbol into several. For example, in C the definition
- int a, b;
-is easily parsed into one tag. This function should take this
-compound tag and turn it into two tags, one for A, and the other for B.")
-(make-variable-buffer-local 'semantic-expand-nonterminal)
-
-(defvar semantic--buffer-cache nil
+
+(defvar-local semantic--buffer-cache nil
"A cache of the fully parsed buffer.
If no significant changes have been made (based on the state) then
this is returned instead of re-parsing the buffer.
@@ -133,18 +117,13 @@ this is returned instead of re-parsing the buffer.
If you need a tag list, use `semantic-fetch-tags'. If you need the
cached values for some reason, chances are you can add a hook to
`semantic-after-toplevel-cache-change-hook'.")
-(make-variable-buffer-local 'semantic--buffer-cache)
-(semantic-varalias-obsolete 'semantic-toplevel-bovine-cache
- 'semantic--buffer-cache "23.2")
-(defvar semantic-unmatched-syntax-cache nil
+(defvar-local semantic-unmatched-syntax-cache nil
"A cached copy of unmatched syntax tokens.")
-(make-variable-buffer-local 'semantic-unmatched-syntax-cache)
-(defvar semantic-unmatched-syntax-cache-check nil
+(defvar-local semantic-unmatched-syntax-cache-check nil
"Non-nil if the unmatched syntax cache is out of date.
This is tracked with `semantic-change-function'.")
-(make-variable-buffer-local 'semantic-unmatched-syntax-cache-check)
(defvar semantic-edits-are-safe nil
"When non-nil, modifications do not require a reparse.
@@ -171,18 +150,6 @@ It is called before any request for tags is made via the function
`semantic-fetch-tags' by an application.
If any hook returns a nil value, the cached value is returned
immediately, even if it is empty.")
-(semantic-varalias-obsolete 'semantic-before-toplevel-bovination-hook
- 'semantic--before-fetch-tags-hook "23.2")
-
-(defvar semantic-after-toplevel-bovinate-hook nil
- "Hooks run after a toplevel parse.
-It is not run if the toplevel parse command is called, and buffer does
-not need to be fully reparsed.
-For language specific hooks, make sure you define this as a local hook.
-
-This hook should not be used any more.
-Use `semantic-after-toplevel-cache-change-hook' instead.")
-(make-obsolete-variable 'semantic-after-toplevel-bovinate-hook nil "23.2")
(defvar semantic-after-toplevel-cache-change-hook nil
"Hooks run after the buffer tag list has changed.
@@ -207,19 +174,16 @@ during a flush when the cache is given a new value of nil.")
:group 'semantic
:type 'boolean)
-(defvar semantic-parser-name "LL"
+(defvar-local semantic-parser-name "LL"
"Optional name of the parser used to parse input stream.")
-(make-variable-buffer-local 'semantic-parser-name)
-(defvar semantic--completion-cache nil
+(defvar-local semantic--completion-cache nil
"Internal variable used by `semantic-complete-symbol'.")
-(make-variable-buffer-local 'semantic--completion-cache)
;;; Parse tree state management API
;;
-(defvar semantic-parse-tree-state 'needs-rebuild
+(defvar-local semantic-parse-tree-state 'needs-rebuild
"State of the current parse tree.")
-(make-variable-buffer-local 'semantic-parse-tree-state)
(defmacro semantic-parse-tree-unparseable ()
"Indicate that the current buffer is unparseable.
@@ -295,9 +259,8 @@ These functions are called by `semantic-new-buffer-fcn', before
(defvar semantic-init-hook nil
"Hook run when a buffer is initialized with a parsing table.")
-(defvar semantic-init-mode-hook nil
+(defvar-local semantic-init-mode-hook nil
"Hook run when a buffer of a particular mode is initialized.")
-(make-variable-buffer-local 'semantic-init-mode-hook)
(defvar semantic-init-db-hook nil
"Hook run when a buffer is initialized with a parsing table for DBs.
@@ -305,13 +268,6 @@ This hook is for database functions which intend to swap in a tag table.
This guarantees that the DB will go before other modes that require
a parse of the buffer.")
-(semantic-varalias-obsolete 'semantic-init-hooks
- 'semantic-init-hook "23.2")
-(semantic-varalias-obsolete 'semantic-init-mode-hooks
- 'semantic-init-mode-hook "23.2")
-(semantic-varalias-obsolete 'semantic-init-db-hooks
- 'semantic-init-db-hook "23.2")
-
(defsubst semantic-error-if-unparsed ()
"Raise an error if current buffer was not parsed by Semantic."
(unless semantic-new-buffer-fcn-was-run
@@ -341,7 +297,7 @@ to use Semantic, and `semantic-init-hook' is run."
'semantic-inhibit-functions)))
;; Make sure that if this buffer is cloned, our tags and overlays
;; don't go along for the ride.
- (add-hook 'clone-indirect-buffer-hook 'semantic-clear-toplevel-cache
+ (add-hook 'clone-indirect-buffer-hook #'semantic-clear-toplevel-cache
nil t)
;; Specify that this function has done its work. At this point
;; we can consider that semantic is active in this buffer.
@@ -510,14 +466,12 @@ is requested."
;; Nuke all semantic overlays. This is faster than deleting based
;; on our data structure.
(let ((l (overlay-lists)))
- (mapc 'semantic-delete-overlay-maybe (car l))
- (mapc 'semantic-delete-overlay-maybe (cdr l))
+ (mapc #'semantic-delete-overlay-maybe (car l))
+ (mapc #'semantic-delete-overlay-maybe (cdr l))
)
(semantic-parse-tree-set-needs-rebuild)
;; Remove this hook which tracks if a buffer is up to date or not.
- (remove-hook 'after-change-functions 'semantic-change-function t)
- ;; Old model. Delete someday.
- ;;(run-hooks 'semantic-after-toplevel-bovinate-hook)
+ (remove-hook 'after-change-functions #'semantic-change-function t)
(run-hook-with-args 'semantic-after-toplevel-cache-change-hook
semantic--buffer-cache)
@@ -531,26 +485,20 @@ is requested."
(setq semantic--buffer-cache tagtable
semantic-unmatched-syntax-cache-check nil)
;; This is specific to the bovine parser.
- (set (make-local-variable 'semantic-bovinate-nonterminal-check-obarray)
- nil)
+ (setq-local semantic-bovinate-nonterminal-check-obarray nil)
(semantic-parse-tree-set-up-to-date)
- (add-hook 'after-change-functions 'semantic-change-function nil t)
+ (add-hook 'after-change-functions #'semantic-change-function nil t)
(run-hook-with-args 'semantic-after-toplevel-cache-change-hook
semantic--buffer-cache)
(setq semantic--completion-cache nil)
;; Refresh the display of unmatched syntax tokens if enabled
(run-hook-with-args 'semantic-unmatched-syntax-hook
- semantic-unmatched-syntax-cache)
- ;; Old Semantic 1.3 hook API. Maybe useful forever?
- (run-hooks 'semantic-after-toplevel-bovinate-hook)
- )
+ semantic-unmatched-syntax-cache))
(defvar semantic-working-type 'percent
"The type of working message to use when parsing.
'percent means we are doing a linear parse through the buffer.
'dynamic means we are reparsing specific tags.")
-(semantic-varalias-obsolete 'semantic-bovination-working-type
- 'semantic-working-type "23.2")
(defvar semantic-minimum-working-buffer-size (* 1024 5)
"The minimum size of a buffer before working messages are displayed.
@@ -586,8 +534,6 @@ was marked unparseable, then do nothing, and return the cache."
(semantic-active-p)
;; Application hooks say the buffer is safe for parsing
(run-hook-with-args-until-failure
- 'semantic-before-toplevel-bovination-hook)
- (run-hook-with-args-until-failure
'semantic--before-fetch-tags-hook)
;; If the buffer was previously marked unparseable,
;; then don't waste our time.
@@ -690,11 +636,6 @@ Does nothing if the current buffer doesn't need reparsing."
;; Return if we are lexically safe
lexically-safe))))
-(defun semantic-bovinate-toplevel (&optional ignored)
- "Backward compatibility function."
- (semantic-fetch-tags))
-(make-obsolete 'semantic-bovinate-toplevel 'semantic-fetch-tags "23.2")
-
;; Another approach is to let Emacs call the parser on idle time, when
;; needed, use `semantic-fetch-available-tags' to only retrieve
;; available tags, and setup the `semantic-after-*-hook' hooks to
@@ -737,15 +678,15 @@ This function returns semantic tags without overlays."
(if tag
(if (car tag)
(setq tag (mapcar
- #'(lambda (tag)
- ;; Set the 'reparse-symbol property to
- ;; NONTERM unless it was already setup
- ;; by a tag expander
- (or (semantic--tag-get-property
- tag 'reparse-symbol)
- (semantic--tag-put-property
- tag 'reparse-symbol nonterm))
- tag)
+ (lambda (tag)
+ ;; Set the 'reparse-symbol property to
+ ;; NONTERM unless it was already setup
+ ;; by a tag expander
+ (or (semantic--tag-get-property
+ tag 'reparse-symbol)
+ (semantic--tag-put-property
+ tag 'reparse-symbol nonterm))
+ tag)
(semantic--tag-expand tag))
result (append result tag))
;; No error in this case, a purposeful nil means don't
@@ -778,9 +719,8 @@ This function returns semantic tags without overlays."
;;
;; Any parser can use this API to provide a list of warnings during a
;; parse which a user may want to investigate.
-(defvar semantic-parser-warnings nil
+(defvar-local semantic-parser-warnings nil
"A list of parser warnings since the last full reparse.")
-(make-variable-buffer-local 'semantic-parser-warnings)
(defun semantic-clear-parser-warnings ()
"Clear the current list of parser warnings for this buffer."
@@ -812,20 +752,6 @@ This function returns semantic tags without overlays."
;; Please move away from these functions, and try using semantic 2.x
;; interfaces instead.
;;
-(defsubst semantic-bovinate-region-until-error
- (start end nonterm &optional depth)
- "NOTE: Use `semantic-parse-region' instead.
-
-Bovinate between START and END starting with NONTERM.
-Optional DEPTH specifies how many levels of parenthesis to enter.
-This command will parse until an error is encountered, and return
-the list of everything found until that moment.
-This is meant for finding variable definitions at the beginning of
-code blocks in methods. If `bovine-inner-scope' can also support
-commands, use `semantic-bovinate-from-nonterminal-full'."
- (semantic-parse-region start end nonterm depth t))
-(make-obsolete 'semantic-bovinate-region-until-error
- 'semantic-parse-region "23.2")
(defsubst semantic-bovinate-from-nonterminal
(start end nonterm &optional depth length)
@@ -840,21 +766,6 @@ tokens."
(semantic-lex start end (or depth 1) length)
nonterm))))
-(defsubst semantic-bovinate-from-nonterminal-full
- (start end nonterm &optional depth)
- "NOTE: Use `semantic-parse-region' instead.
-
-Bovinate from within a nonterminal lambda from START to END.
-Iterates until all the space between START and END is exhausted.
-Argument NONTERM is the nonterminal symbol to start with.
-If NONTERM is nil, use `bovine-block-toplevel'.
-Optional argument DEPTH is the depth of lists to dive into.
-When used in a `lambda' of a MATCH-LIST, there is no need to include
-a START and END part."
- (semantic-parse-region start end nonterm (or depth 1)))
-(make-obsolete 'semantic-bovinate-from-nonterminal-full
- 'semantic-parse-region "23.2")
-
;;; User interface
(defun semantic-force-refresh ()
@@ -868,25 +779,25 @@ Throw away all the old tags, and recreate the tag database."
(defvar semantic-mode-map
(let ((map (make-sparse-keymap)))
;; Key bindings:
- ;; (define-key km "f" 'senator-search-set-tag-class-filter)
- ;; (define-key km "i" 'senator-isearch-toggle-semantic-mode)
- (define-key map "\C-c,j" 'semantic-complete-jump-local)
- (define-key map "\C-c,J" 'semantic-complete-jump)
- (define-key map "\C-c,m" 'semantic-complete-jump-local-members)
- (define-key map "\C-c,g" 'semantic-symref-symbol)
- (define-key map "\C-c,G" 'semantic-symref)
- (define-key map "\C-c,p" 'senator-previous-tag)
- (define-key map "\C-c,n" 'senator-next-tag)
- (define-key map "\C-c,u" 'senator-go-to-up-reference)
- (define-key map "\C-c, " 'semantic-complete-analyze-inline)
- (define-key map "\C-c,\C-w" 'senator-kill-tag)
- (define-key map "\C-c,\M-w" 'senator-copy-tag)
- (define-key map "\C-c,\C-y" 'senator-yank-tag)
- (define-key map "\C-c,r" 'senator-copy-tag-to-register)
- (define-key map "\C-c,," 'semantic-force-refresh)
- (define-key map [?\C-c ?, up] 'senator-transpose-tags-up)
- (define-key map [?\C-c ?, down] 'senator-transpose-tags-down)
- (define-key map "\C-c,l" 'semantic-analyze-possible-completions)
+ ;; (define-key km "f" #'senator-search-set-tag-class-filter)
+ ;; (define-key km "i" #'senator-isearch-toggle-semantic-mode)
+ (define-key map "\C-c,j" #'semantic-complete-jump-local)
+ (define-key map "\C-c,J" #'semantic-complete-jump)
+ (define-key map "\C-c,m" #'semantic-complete-jump-local-members)
+ (define-key map "\C-c,g" #'semantic-symref-symbol)
+ (define-key map "\C-c,G" #'semantic-symref)
+ (define-key map "\C-c,p" #'senator-previous-tag)
+ (define-key map "\C-c,n" #'senator-next-tag)
+ (define-key map "\C-c,u" #'senator-go-to-up-reference)
+ (define-key map "\C-c, " #'semantic-complete-analyze-inline)
+ (define-key map "\C-c,\C-w" #'senator-kill-tag)
+ (define-key map "\C-c,\M-w" #'senator-copy-tag)
+ (define-key map "\C-c,\C-y" #'senator-yank-tag)
+ (define-key map "\C-c,r" #'senator-copy-tag-to-register)
+ (define-key map "\C-c,," #'semantic-force-refresh)
+ (define-key map [?\C-c ?, up] #'senator-transpose-tags-up)
+ (define-key map [?\C-c ?, down] #'senator-transpose-tags-down)
+ (define-key map "\C-c,l" #'semantic-analyze-possible-completions)
;; This hack avoids showing the CEDET menu twice if ede-minor-mode
;; and Semantic are both enabled. Is there a better way?
(define-key map [menu-bar cedet-menu]
@@ -1055,7 +966,6 @@ Prevent this load system from loading files in twice.")
global-semanticdb-minor-mode
global-semantic-idle-summary-mode
global-semantic-mru-bookmark-mode
- global-cedet-m3-minor-mode
global-semantic-idle-local-symbol-highlight-mode
global-semantic-highlight-edits-mode
global-semantic-show-unmatched-syntax-mode
@@ -1077,7 +987,6 @@ The possible elements of this list include the following:
`global-semantic-stickyfunc-mode' - Show current fun in header line.
`global-semantic-mru-bookmark-mode' - Provide `switch-to-buffer'-like
keybinding for tag names.
- `global-cedet-m3-minor-mode' - A mouse 3 context menu.
`global-semantic-idle-local-symbol-highlight-mode' - Highlight references
of the symbol under point.
The following modes are more targeted at people who want to see
@@ -1120,7 +1029,7 @@ Semantic mode.
(file-exists-p semanticdb-default-system-save-directory))
(require 'semantic/db-ebrowse)
(semanticdb-load-ebrowse-caches)))
- (add-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ (add-hook 'mode-local-init-hook #'semantic-new-buffer-fcn)
;; Add semantic-ia-complete-symbol to
;; completion-at-point-functions, so that it is run from
;; M-TAB.
@@ -1128,11 +1037,11 @@ Semantic mode.
;; Note: The first entry added is the last entry run, so the
;; most specific entry should be last.
(add-hook 'completion-at-point-functions
- 'semantic-analyze-nolongprefix-completion-at-point-function)
+ #'semantic-analyze-nolongprefix-completion-at-point-function)
(add-hook 'completion-at-point-functions
- 'semantic-analyze-notc-completion-at-point-function)
+ #'semantic-analyze-notc-completion-at-point-function)
(add-hook 'completion-at-point-functions
- 'semantic-analyze-completion-at-point-function)
+ #'semantic-analyze-completion-at-point-function)
(if (bound-and-true-p global-ede-mode)
(define-key cedet-menu-map [cedet-menu-separator] '("--")))
@@ -1143,21 +1052,21 @@ Semantic mode.
;; introduced in the buffer is pretty much futile, but we have to
;; clean the hooks and delete Semantic-related overlays, so that
;; Semantic can be re-activated cleanly.
- (remove-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ (remove-hook 'mode-local-init-hook #'semantic-new-buffer-fcn)
(remove-hook 'completion-at-point-functions
- 'semantic-analyze-completion-at-point-function)
+ #'semantic-analyze-completion-at-point-function)
(remove-hook 'completion-at-point-functions
- 'semantic-analyze-notc-completion-at-point-function)
+ #'semantic-analyze-notc-completion-at-point-function)
(remove-hook 'completion-at-point-functions
- 'semantic-analyze-nolongprefix-completion-at-point-function)
+ #'semantic-analyze-nolongprefix-completion-at-point-function)
(remove-hook 'after-change-functions
- 'semantic-change-function)
+ #'semantic-change-function)
(define-key cedet-menu-map [cedet-menu-separator] nil)
(define-key cedet-menu-map [semantic-options-separator] nil)
;; FIXME: handle semanticdb-load-ebrowse-caches
(dolist (mode semantic-submode-list)
- (if (and (boundp mode) (eval mode))
+ (if (and (boundp mode) (symbol-value mode))
(funcall mode -1)))
;; Unlink buffer and clear cache
(semantic--tag-unlink-cache-from-buffer)
diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el
index 10818cd507a..1a4be11c789 100644
--- a/lisp/cedet/semantic/analyze.el
+++ b/lisp/cedet/semantic/analyze.el
@@ -1,4 +1,4 @@
-;;; semantic/analyze.el --- Analyze semantic tags against local context
+;;; semantic/analyze.el --- Analyze semantic tags against local context -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2005, 2007-2021 Free Software Foundation, Inc.
@@ -167,7 +167,7 @@ of the parent function.")
;; Simple methods against the context classes.
;;
(cl-defmethod semantic-analyze-type-constraint
- ((context semantic-analyze-context) &optional desired-type)
+ ((_context semantic-analyze-context) &optional desired-type)
"Return a type constraint for completing :prefix in CONTEXT.
Optional argument DESIRED-TYPE may be a non-type tag to analyze."
(when (semantic-tag-p desired-type)
@@ -235,7 +235,8 @@ scoped. These are not local variables, but symbols available in a structure
which doesn't need to be dereferenced.
Optional argument TYPERETURN is a symbol in which the types of all found
will be stored. If nil, that data is thrown away.
-Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.
+Optional argument THROWSYM specifies a symbol the throw on non-recoverable
+error.
Remaining arguments FLAGS are additional flags to apply when searching.")
(defun semantic-analyze-find-tag-sequence-default
@@ -246,7 +247,8 @@ Remaining arguments FLAGS are additional flags to apply when searching.")
SCOPE are extra tags which are in scope.
TYPERETURN is a symbol in which to place a list of tag classes that
are found in SEQUENCE.
-Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.
+Optional argument THROWSYM specifies a symbol the throw on non-recoverable
+error.
Remaining arguments FLAGS are additional flags to apply when searching.
This function knows of flags:
`mustbeclassvariable'"
@@ -342,8 +344,8 @@ This function knows of flags:
(setq tagtype (cons tmptype tagtype))
(when miniscope
(let ((rawscope
- (apply 'append
- (mapcar 'semantic-tag-type-members tagtype))))
+ (apply #'append
+ (mapcar #'semantic-tag-type-members tagtype))))
(oset miniscope fullscope rawscope)))
)
(setq s (cdr s)))
@@ -435,6 +437,8 @@ to provide a large number of non-cached analysis for filtering symbols."
(:override)))
)
+(defvar semantic--prefixtypes)
+
(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
"Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
(let* ((semantic-analyze-error-stack nil)
@@ -451,14 +455,14 @@ to provide a large number of non-cached analysis for filtering symbols."
(catch 'unfindable
;; If debug on error is on, allow debugging in this fcn.
(setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'prefixtypes 'unfindable)))
+ prefix scope 'semantic--prefixtypes 'unfindable)))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
;; semantic-analyzer-debug-global-symbol
;; You will need to update both places.
(setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'prefixtypes))
+ prefix scope 'semantic--prefixtypes))
(error (semantic-analyze-push-error err))))
;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil))
@@ -529,7 +533,7 @@ Returns an object based on symbol `semantic-analyze-context'."
(bounds (nth 2 prefixandbounds))
;; @todo - vv too early to really know this answer! vv
(prefixclass (semantic-ctxt-current-class-list))
- (prefixtypes nil)
+ (semantic--prefixtypes nil)
(scope (semantic-calculate-scope position))
(function nil)
(fntag nil)
@@ -609,13 +613,13 @@ Returns an object based on symbol `semantic-analyze-context'."
(if debug-on-error
(catch 'unfindable
(setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'prefixtypes 'unfindable))
+ prefix scope 'semantic--prefixtypes 'unfindable))
;; If there's an alias, dereference it and analyze
;; sequence again.
(when (setq newseq
(semantic-analyze-dereference-alias prefix))
(setq prefix (semantic-analyze-find-tag-sequence
- newseq scope 'prefixtypes 'unfindable))))
+ newseq scope 'semantic--prefixtypes 'unfindable))))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
@@ -623,11 +627,11 @@ Returns an object based on symbol `semantic-analyze-context'."
;; You will need to update both places.
(progn
(setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'prefixtypes))
+ prefix scope 'semantic--prefixtypes))
(when (setq newseq
(semantic-analyze-dereference-alias prefix))
(setq prefix (semantic-analyze-find-tag-sequence
- newseq scope 'prefixtypes))))
+ newseq scope 'semantic--prefixtypes))))
(error (semantic-analyze-push-error err))))
)
@@ -648,7 +652,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:prefix prefix
:prefixclass prefixclass
:bounds bounds
- :prefixtypes prefixtypes
+ :prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
;; No function, try assignment
@@ -668,7 +672,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:bounds bounds
:prefix prefix
:prefixclass prefixclass
- :prefixtypes prefixtypes
+ :prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
;; TODO: Identify return value condition.
@@ -684,7 +688,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:bounds bounds
:prefix prefix
:prefixclass prefixclass
- :prefixtypes prefixtypes
+ :prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
(t (setq context-return nil))
@@ -748,7 +752,7 @@ Some useful functions are found in `semantic-format-tag-functions'."
:group 'semantic
:type semantic-format-tag-custom-list)
-(defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
+(defun semantic-analyze-princ-sequence (sequence &optional prefix _buff)
"Send the tag SEQUENCE to standard out.
Use PREFIX as a label.
Use BUFF as a source of override methods."
diff --git a/lisp/cedet/semantic/analyze/complete.el b/lisp/cedet/semantic/analyze/complete.el
index e8139ab1aea..ccf405d62e2 100644
--- a/lisp/cedet/semantic/analyze/complete.el
+++ b/lisp/cedet/semantic/analyze/complete.el
@@ -1,4 +1,4 @@
-;;; semantic/analyze/complete.el --- Smart Completions
+;;; semantic/analyze/complete.el --- Smart Completions -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -45,7 +45,7 @@
"For the tag TYPE, return any constant symbols of TYPE.
Used as options when completing.")
-(defun semantic-analyze-type-constants-default (type)
+(defun semantic-analyze-type-constants-default (_type)
"Do nothing with TYPE."
nil)
@@ -54,7 +54,7 @@ Used as options when completing.")
(let ((origc tags))
;; Accept only tags that are of the datatype specified by
;; the desired classes.
- (setq tags (apply 'nconc ;; All input lists are permutable.
+ (setq tags (apply #'nconc ;; All input lists are permutable.
(mapcar (lambda (class)
(semantic-find-tags-by-class class origc))
classlist)))
@@ -109,6 +109,8 @@ in a buffer."
(when (called-interactively-p 'any)
(error "Buffer was not parsed by Semantic."))))
+(defvar semantic--prefixtypes)
+
(defun semantic-analyze-possible-completions-default (context &optional flags)
"Default method for producing smart completions.
Argument CONTEXT is an object specifying the locally derived context.
@@ -121,14 +123,14 @@ FLAGS can be any number of:
(desired-type (semantic-analyze-type-constraint a))
(desired-class (oref a prefixclass))
(prefix (oref a prefix))
- (prefixtypes (oref a prefixtypes))
+ (semantic--prefixtypes (oref a prefixtypes))
(completetext nil)
(completetexttype nil)
(scope (oref a scope))
(localvar (when scope (oref scope localvar)))
(origc nil)
(c nil)
- (any nil)
+ ;; (any nil)
(do-typeconstraint (not (memq 'no-tc flags)))
(do-longprefix (not (memq 'no-longprefix flags)))
(do-unique (not (memq 'no-unique flags)))
@@ -138,7 +140,7 @@ FLAGS can be any number of:
;; If we are not doing the long prefix, shorten all the key
;; elements.
(setq prefix (list (car (reverse prefix)))
- prefixtypes nil))
+ semantic--prefixtypes nil))
;; Calculate what our prefix string is so that we can
;; find all our matching text.
@@ -155,7 +157,7 @@ FLAGS can be any number of:
;; The prefixtypes should always be at least 1 less than
;; the prefix since the type is never looked up for the last
;; item when calculating a sequence.
- (setq completetexttype (car (reverse prefixtypes)))
+ (setq completetexttype (car (reverse semantic--prefixtypes)))
(when (or (not completetexttype)
(not (and (semantic-tag-p completetexttype)
(eq (semantic-tag-class completetexttype) 'type))))
diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el
index 2b6990cd1ab..69b3b9c8328 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
+;;; semantic/analyze/debug.el --- Debug the analyzer -*- lexical-binding: t; -*-
-;;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -109,11 +109,11 @@ Argument COMP are possible completions here."
(condition-case err
(with-current-buffer origbuf
(let* ((position (or (cdr-safe (oref ctxt bounds)) (point)))
- (prefixtypes nil) ; Used as type return
+ ;; (semantic--prefixtypes nil) ; Used as type return
(scope (semantic-calculate-scope position))
)
(semantic-analyze-find-tag-sequence
- (list prefix "") scope 'prefixtypes)
+ (list prefix "") scope) ;; 'semantic--prefixtypes
)
)
(error (setq finderr err)))
@@ -149,7 +149,7 @@ path was setup incorrectly.\n")
(semantic-analyzer-debug-add-buttons)
))
-(defun semantic-analyzer-debug-missing-datatype (ctxt idx comp)
+(defun semantic-analyzer-debug-missing-datatype (ctxt idx _comp)
"Debug why we can't find a datatype entry for CTXT prefix at IDX.
Argument COMP are possible completions here."
(let* ((prefixitem (nth idx (oref ctxt prefix)))
@@ -590,22 +590,23 @@ Look for key expressions, and add push-buttons near them."
(with-current-buffer "*Help*"
(let ((inhibit-read-only t))
(goto-char (point-min))
- (set (make-local-variable 'semantic-analyzer-debug-orig) orig-buffer)
+ (setq-local semantic-analyzer-debug-orig orig-buffer)
;; First, add do-in buttons to recommendations.
(while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t)
- (let ((fcn (match-string 1)))
- (when (not (fboundp (intern-soft fcn)))
+ (let* ((fcn (match-string 1))
+ (fsym (intern-soft fcn)))
+ (when (not (fboundp fsym))
(error "Help Err: Can't find %s" fcn))
(end-of-line)
(insert " ")
(insert-button "[ Do It ]"
'mouse-face 'custom-button-pressed-face
'do-fcn fcn
- 'action `(lambda (arg)
- (let ((M semantic-analyzer-debug-orig))
- (set-buffer (marker-buffer M))
- (goto-char M))
- (call-interactively (quote ,(intern-soft fcn))))))))
+ 'action (lambda (_arg)
+ (let ((M semantic-analyzer-debug-orig))
+ (set-buffer (marker-buffer M))
+ (goto-char M))
+ (call-interactively fsym))))))
;; Do something else?
;; Clean up the mess
(set-buffer-modified-p nil))))
diff --git a/lisp/cedet/semantic/analyze/fcn.el b/lisp/cedet/semantic/analyze/fcn.el
index 10d11c33ebb..d47e8976e58 100644
--- a/lisp/cedet/semantic/analyze/fcn.el
+++ b/lisp/cedet/semantic/analyze/fcn.el
@@ -1,4 +1,4 @@
-;;; semantic/analyze/fcn.el --- Analyzer support functions.
+;;; semantic/analyze/fcn.el --- Analyzer support functions. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@ Return the string representing the compound name.")
(defun semantic-analyze-unsplit-name-default (namelist)
"Concatenate the names in NAMELIST with a . between."
- (mapconcat 'identity namelist "."))
+ (mapconcat #'identity namelist "."))
;;; SELECTING
;;
diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el
index 70e0f8e9d34..31cbb9e1173 100644
--- a/lisp/cedet/semantic/analyze/refs.el
+++ b/lisp/cedet/semantic/analyze/refs.el
@@ -1,4 +1,4 @@
-;;; semantic/analyze/refs.el --- Analysis of the references between tags.
+;;; semantic/analyze/refs.el --- Analysis of the references between tags. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -102,7 +102,8 @@ Use `semantic-analyze-current-tag' to debug this fcn."
;; into the context.
(cl-defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer)
"Return the implementations derived in the reference analyzer REFS.
-Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
+Optional argument IN-BUFFER indicates that the returned tag
+should be in an active buffer."
(let ((allhits (oref refs rawsearchdata))
(tag (oref refs tag))
(impl nil)
@@ -127,7 +128,8 @@ Optional argument IN-BUFFER indicates that the returned tag should be in an acti
(cl-defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer)
"Return the prototypes derived in the reference analyzer REFS.
-Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
+Optional argument IN-BUFFER indicates that the returned tag
+should be in an active buffer."
(let ((allhits (oref refs rawsearchdata))
(tag (oref refs tag))
(proto nil))
@@ -294,7 +296,7 @@ Only works for tags in the global namespace."
(let* ((classmatch (semantic-tag-class tag))
(RES
(semanticdb-find-tags-collector
- (lambda (table tags)
+ (lambda (_table tags)
(semantic-find-tags-by-class classmatch tags)
;; @todo - Add parent check also.
)
diff --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el
index 034ecb5ea1c..6be6dfd8dfd 100644
--- a/lisp/cedet/semantic/bovine.el
+++ b/lisp/cedet/semantic/bovine.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine.el --- LL Parser/Analyzer core.
+;;; semantic/bovine.el --- LL Parser/Analyzer core -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2004, 2006-2007, 2009-2021 Free Software
;; Foundation, Inc.
@@ -41,10 +41,9 @@
;;; Variables
;;
-(defvar semantic-bovinate-nonterminal-check-obarray nil
+(defvar-local semantic-bovinate-nonterminal-check-map nil
"Obarray of streams already parsed for nonterminal symbols.
Use this to detect infinite recursion during a parse.")
-(make-variable-buffer-local 'semantic-bovinate-nonterminal-check-obarray)
@@ -55,6 +54,7 @@ Use this to detect infinite recursion during a parse.")
"Create a lambda expression to return a list including RETURN-VAL.
The return list is a lambda expression to be used in a bovine table."
`(lambda (vals start end)
+ (ignore vals)
(append ,@return-val (list start end))))
;;; Semantic Bovination
@@ -79,21 +79,18 @@ environment of `semantic-bovinate-stream'."
(defun semantic-bovinate-nonterminal-check (stream nonterminal)
"Check if STREAM not already parsed for NONTERMINAL.
If so abort because an infinite recursive parse is suspected."
- (or (vectorp semantic-bovinate-nonterminal-check-obarray)
- (setq semantic-bovinate-nonterminal-check-obarray
- (make-vector 13 nil)))
- (let* ((nt (symbol-name nonterminal))
- (vs (symbol-value
- (intern-soft
- nt semantic-bovinate-nonterminal-check-obarray))))
+ (or (hash-table-p semantic-bovinate-nonterminal-check-map)
+ (setq semantic-bovinate-nonterminal-check-map
+ (make-hash-table :test #'eq)))
+ (let* ((vs (gethash nonterminal semantic-bovinate-nonterminal-check-map)))
(if (memq stream vs)
;; Always enter debugger to see the backtrace
(let ((debug-on-signal t)
(debug-on-error t))
- (setq semantic-bovinate-nonterminal-check-obarray nil)
- (error "Infinite recursive parse suspected on %s" nt))
- (set (intern nt semantic-bovinate-nonterminal-check-obarray)
- (cons stream vs)))))
+ (setq semantic-bovinate-nonterminal-check-map nil)
+ (error "Infinite recursive parse suspected on %s" nonterminal))
+ (push stream
+ (gethash nonterminal semantic-bovinate-nonterminal-check-map)))))
;;;###autoload
(defun semantic-bovinate-stream (stream &optional nonterminal)
@@ -110,6 +107,9 @@ list of semantic tokens found."
(or semantic--buffer-cache
(semantic-bovinate-nonterminal-check stream nonterminal))
+ ;; FIXME: `semantic-parse-region-c-mode' inspects `lse' to try and
+ ;; detect a recursive call (used with macroexpansion, to avoid inf-loops).
+ (with-suppressed-warnings ((lexical lse)) (defvar lse))
(let* ((table semantic--parse-table)
(matchlist (cdr (assq nonterminal table)))
(starting-stream stream)
@@ -216,7 +216,8 @@ list of semantic tokens found."
(setq cvl (cons
(if (memq (semantic-lex-token-class lse)
'(comment semantic-list))
- valdot val) cvl))) ;append unchecked value.
+ valdot val)
+ cvl))) ;append unchecked value.
(setq end (semantic-lex-token-end lse))
)
(setq lte nil cvl nil)) ;No more matches, exit
@@ -284,7 +285,7 @@ list of semantic tokens found."
;; Make it the default parser
;;;###autoload
-(defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)
+(defalias 'semantic-parse-stream-default #'semantic-bovinate-stream)
(provide 'semantic/bovine)
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index 3bb60ceb9ce..e7ecb61513f 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/c.el --- Semantic details for C
+;;; semantic/bovine/c.el --- Semantic details for C -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -46,27 +46,10 @@
(declare-function c-forward-conditional "cc-cmds")
(declare-function ede-system-include-path "ede")
-;;; Compatibility
-;;
(eval-when-compile (require 'cc-mode))
-(if (fboundp 'c-end-of-macro)
- (eval-and-compile
- (defalias 'semantic-c-end-of-macro 'c-end-of-macro))
- ;; From cc-mode 5.30
- (defun semantic-c-end-of-macro ()
- "Go to the end of a preprocessor directive.
-More accurately, move point to the end of the closest following line
-that doesn't end with a line continuation backslash.
-
-This function does not do any hidden buffer changes."
- (while (progn
- (end-of-line)
- (when (and (eq (char-before) ?\\)
- (not (eobp)))
- (forward-char)
- t))))
- )
+(define-obsolete-function-alias 'semantic-c-end-of-macro
+ #'c-end-of-macro "28.1")
;;; Code:
(with-suppressed-warnings ((obsolete define-child-mode))
@@ -131,7 +114,8 @@ part of the preprocessor map.")
"Reset the C preprocessor symbol map based on all input variables."
(when (and semantic-mode
(featurep 'semantic/bovine/c))
- (remove-hook 'mode-local-init-hook 'semantic-c-reset-preprocessor-symbol-map)
+ (remove-hook 'mode-local-init-hook
+ #'semantic-c-reset-preprocessor-symbol-map)
;; Initialize semantic-lex-spp-macro-symbol-obarray with symbols.
(setq-mode-local c-mode
semantic-lex-spp-macro-symbol-obarray
@@ -171,7 +155,7 @@ part of the preprocessor map.")
;; Make sure the preprocessor symbols are set up when mode-local kicks
;; in.
-(add-hook 'mode-local-init-hook 'semantic-c-reset-preprocessor-symbol-map)
+(add-hook 'mode-local-init-hook #'semantic-c-reset-preprocessor-symbol-map)
(defcustom semantic-lex-c-preprocessor-symbol-map nil
"Table of C Preprocessor keywords used by the Semantic C lexer.
@@ -254,8 +238,8 @@ Return the defined symbol as a special spp lex token."
(skip-chars-forward " \t")
(if (eolp)
nil
- (let* ((name (buffer-substring-no-properties
- (match-beginning 1) (match-end 1)))
+ (let* (;; (name (buffer-substring-no-properties
+ ;; (match-beginning 1) (match-end 1)))
(beginning-of-define (match-end 1))
(with-args (save-excursion
(goto-char (match-end 0))
@@ -266,7 +250,7 @@ Return the defined symbol as a special spp lex token."
(semantic-lex-analyzer #'semantic-cpp-lexer)
(raw-stream
(semantic-lex-spp-stream-for-macro (save-excursion
- (semantic-c-end-of-macro)
+ (c-end-of-macro)
;; HACK - If there's a C comment after
;; the macro, do not parse it.
(if (looking-back "/\\*.*" beginning-of-define)
@@ -385,7 +369,8 @@ Take the first interesting thing and convert it."
(defun semantic-c-evaluate-symbol-for-hideif (spp-symbol)
"Lookup the symbol SPP-SYMBOL (a string) to something hideif can use.
-Pulls out the symbol list, and call `semantic-c-convert-spp-value-to-hideif-value'."
+Pull out the symbol list, and call
+`semantic-c-convert-spp-value-to-hideif-value'."
(interactive "sSymbol name: ")
(when (symbolp spp-symbol) (setq spp-symbol (symbol-name spp-symbol)))
@@ -504,7 +489,7 @@ code to parse."
(error nil))))
(let ((eval-form (condition-case err
- (eval parsedtokelist)
+ (eval parsedtokelist t)
(error
(semantic-push-parser-warning
(format "Hideif forms produced an error. Assuming false.\n%S" err)
@@ -515,11 +500,11 @@ code to parse."
(equal eval-form 0)));; ifdef line resulted in false
;; The if indicates to skip this preprocessor section
- (let ((pt nil))
+ (let () ;; (pt nil)
(semantic-push-parser-warning (format "Skip %s" (buffer-substring-no-properties (point-at-bol) (point-at-eol)))
(point-at-bol) (point-at-eol))
(beginning-of-line)
- (setq pt (point))
+ ;; (setq pt (point))
;; This skips only a section of a conditional. Once that section
;; is opened, encountering any new #else or related conditional
;; should be skipped.
@@ -590,7 +575,7 @@ case, we must skip it since it is the ELSE part."
(define-lex-regex-analyzer semantic-lex-c-macrobits
"Ignore various forms of #if/#else/#endif conditionals."
"^\\s-*#\\s-*\\(if\\(n?def\\)?\\|endif\\|elif\\|else\\)"
- (semantic-c-end-of-macro)
+ (c-end-of-macro)
(setq semantic-lex-end-point (point))
nil)
@@ -834,7 +819,9 @@ MACRO expansion mode is handled through the nature of Emacs's non-lexical
binding of variables.
START, END, NONTERMINAL, DEPTH, and RETURNONERRORS are the same
as for the parent."
- (if (and (boundp 'lse) (or (/= start 1) (/= end (point-max))))
+ ;; FIXME: We shouldn't depend on the internals of `semantic-bovinate-stream'.
+ (with-suppressed-warnings ((lexical lse)) (defvar lse))
+ (if (and (boundp 'lse) (or (/= start (point-min)) (/= end (point-max))))
(let* ((last-lexical-token lse)
(llt-class (semantic-lex-token-class last-lexical-token))
(llt-fakebits (car (cdr last-lexical-token)))
@@ -942,7 +929,7 @@ the regular parser."
(semantic-lex-init)
(semantic-clear-toplevel-cache)
(remove-hook 'semantic-lex-reset-functions
- 'semantic-lex-spp-reset-hook t)
+ #'semantic-lex-spp-reset-hook t)
)
;; Get the macro symbol table right.
(setq semantic-lex-spp-dynamic-macro-symbol-obarray spp-syms)
@@ -986,7 +973,7 @@ the regular parser."
;; Notify about the debug
(setq semantic-c-debug-mode-init-last-mode mm)
- (add-hook 'post-command-hook 'semantic-c-debug-mode-init-pch)))
+ (add-hook 'post-command-hook #'semantic-c-debug-mode-init-pch)))
(defun semantic-c-debug-mode-init-pch ()
"Notify user about needing to debug their major mode hooks."
@@ -1003,7 +990,7 @@ M-x semantic-c-debug-mode-init
now.
")
- (remove-hook 'post-command-hook 'semantic-c-debug-mode-init-pch)))
+ (remove-hook 'post-command-hook #'semantic-c-debug-mode-init-pch)))
(defun semantic-expand-c-tag (tag)
"Expand TAG into a list of equivalent tags, or nil."
@@ -1244,7 +1231,7 @@ Use `semantic-analyze-current-tag' to debug this fcn."
(when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list 'semantic-tag-p tag)))
(let ((allhits nil)
(scope nil)
- (refs nil))
+ ) ;; (refs nil)
(save-excursion
(semantic-go-to-tag tag db)
(setq scope (semantic-calculate-scope))
@@ -1266,11 +1253,12 @@ Use `semantic-analyze-current-tag' to debug this fcn."
(reverse newparents)))
(setq allhits (semantic--analyze-refs-full-lookup tag scope t)))
- (setq refs (semantic-analyze-references (semantic-tag-name tag)
- :tag tag
- :tagdb db
- :scope scope
- :rawsearchdata allhits)))))
+ ;; (setq refs
+ (semantic-analyze-references (semantic-tag-name tag)
+ :tag tag
+ :tagdb db
+ :scope scope
+ :rawsearchdata allhits)))) ;;)
(defun semantic-c-reconstitute-token (tokenpart declmods typedecl)
"Reconstitute a token TOKENPART with DECLMODS and TYPEDECL.
@@ -1556,9 +1544,9 @@ This might be a string, or a list of tokens."
((semantic-tag-p templatespec)
(semantic-format-tag-abbreviate templatespec))
((listp templatespec)
- (mapconcat 'semantic-format-tag-abbreviate templatespec ", "))))
+ (mapconcat #'semantic-format-tag-abbreviate templatespec ", "))))
-(defun semantic-c-template-string (token &optional parent color)
+(defun semantic-c-template-string (token &optional parent _color)
"Return a string representing the TEMPLATE attribute of TOKEN.
This string is prefixed with a space, or is the empty string.
Argument PARENT specifies a parent type.
@@ -1566,8 +1554,8 @@ Argument COLOR specifies that the string should be colorized."
(let ((t2 (semantic-c-tag-template-specifier token))
(t1 (semantic-c-tag-template token))
;; @todo - Need to account for a parent that is a template
- (pt1 (if parent (semantic-c-tag-template parent)))
- (pt2 (if parent (semantic-c-tag-template-specifier parent)))
+ (_pt1 (if parent (semantic-c-tag-template parent)))
+ (_pt2 (if parent (semantic-c-tag-template-specifier parent)))
)
(cond (t2 ;; we have a template with specifier
(concat " <"
@@ -1626,7 +1614,7 @@ handled. A class is abstract only if its destructor is virtual."
(member "virtual" (semantic-tag-modifiers tag))))
(t (semantic-tag-abstract-p-default tag parent))))
-(defun semantic-c-dereference-typedef (type scope &optional type-declaration)
+(defun semantic-c-dereference-typedef (type _scope &optional type-declaration)
"If TYPE is a typedef, get TYPE's type by name or tag, and return.
SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef."
(if (and (eq (semantic-tag-class type) 'type)
@@ -1671,7 +1659,7 @@ return `ref<Foo,Bar>'."
(concat (semantic-tag-name type)
"<" (semantic-c--template-name-1 (cdr spec-list)) ">"))
-(defun semantic-c-dereference-template (type scope &optional type-declaration)
+(defun semantic-c-dereference-template (type _scope &optional type-declaration)
"Dereference any template specifiers in TYPE within SCOPE.
If TYPE is a template, return a TYPE copy with the templates types
instantiated as specified in TYPE-DECLARATION."
@@ -1693,7 +1681,7 @@ instantiated as specified in TYPE-DECLARATION."
(list type type-declaration))
;;; Patch here by "Raf" for instantiating templates.
-(defun semantic-c-dereference-member-of (type scope &optional type-declaration)
+(defun semantic-c-dereference-member-of (type _scope &optional type-declaration)
"Dereference through the `->' operator of TYPE.
Uses the return type of the `->' operator if it is contained in TYPE.
SCOPE is the current local scope to perform searches in.
@@ -1716,7 +1704,7 @@ Such an alias can be created through `using' statements in a
namespace declaration. This function checks the namespaces in
SCOPE for such statements."
(let ((scopetypes (oref scope scopetypes))
- typename currentns tmp usingname result namespaces)
+ typename currentns result namespaces) ;; usingname tmp
(when (and (semantic-tag-p type-declaration)
(or (null type) (semantic-tag-prototype-p type)))
(setq typename (semantic-analyze-split-name (semantic-tag-name type-declaration)))
@@ -1755,11 +1743,11 @@ with a fully qualified name in the original namespace. Returns
nil if NAMESPACE is not an alias."
(when (eq (semantic-tag-get-attribute namespace :kind) 'alias)
(let ((typename (semantic-analyze-split-name (semantic-tag-name type)))
- ns nstype originaltype newtype)
+ ns nstype originaltype) ;; newtype
;; Make typename unqualified
- (if (listp typename)
- (setq typename (last typename))
- (setq typename (list typename)))
+ (setq typename (if (listp typename)
+ (last typename)
+ (list typename)))
(when
(and
;; Get original namespace and make sure TYPE exists there.
@@ -1771,13 +1759,13 @@ nil if NAMESPACE is not an alias."
(semantic-tag-get-attribute nstype :members))))
;; Construct new type with name in original namespace.
(setq ns (semantic-analyze-split-name ns))
- (setq newtype
- (semantic-tag-clone
- (car originaltype)
- (semantic-analyze-unsplit-name
- (if (listp ns)
- (append ns typename)
- (append (list ns) typename)))))))))
+ ;; (setq newtype
+ (semantic-tag-clone
+ (car originaltype)
+ (semantic-analyze-unsplit-name
+ (if (listp ns)
+ (append ns typename)
+ (append (list ns) typename)))))))) ;; )
;; This searches a type in a namespace, following through all using
;; statements.
@@ -1785,7 +1773,7 @@ nil if NAMESPACE is not an alias."
"Check if TYPE is accessible in NAMESPACE through a using statement.
Returns the original type from the namespace where it is defined,
or nil if it cannot be found."
- (let (usings result usingname usingtype unqualifiedname members shortname tmp)
+ (let (usings result usingname usingtype unqualifiedname members) ;; shortname tmp
;; Get all using statements from NAMESPACE.
(when (and (setq usings (semantic-tag-get-attribute namespace :members))
(setq usings (semantic-find-tags-by-class 'using usings)))
@@ -1858,7 +1846,7 @@ These are constants which are of type TYPE."
(define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist)
"Assemble the list of names NAMELIST into a namespace name."
- (mapconcat 'identity namelist "::"))
+ (mapconcat #'identity namelist "::"))
(define-mode-local-override semantic-ctxt-scoped-types c++-mode (&optional point)
"Return a list of tags of CLASS type based on POINT.
@@ -1901,7 +1889,7 @@ DO NOT return the list of tags encompassing point."
(semantic-get-local-variables))))
(setq tagreturn
(append tagreturn
- (mapcar 'semantic-tag-type tmp))))))
+ (mapcar #'semantic-tag-type tmp))))))
;; Return the stuff
tagreturn))
@@ -1959,7 +1947,7 @@ namespace, since this means all tags inside this include will
have to be wrapped in that namespace."
(let ((inctable (semanticdb-find-table-for-include-default includetag table))
(inside-ns (semantic-tag-get-attribute includetag :inside-ns))
- tags newtags namespaces prefix parenttable newtable)
+ tags newtags namespaces parenttable newtable) ;; prefix
(if (or (null inside-ns)
(not inctable)
(not (slot-boundp inctable 'tags)))
@@ -2127,13 +2115,11 @@ actually in their parent which is not accessible.")
"Set up a buffer for semantic parsing of the C language."
(semantic-c-by--install-parser)
(setq semantic-lex-syntax-modifications '((?> ".")
- (?< ".")
- )
- )
+ (?< ".")))
(setq semantic-lex-analyzer #'semantic-c-lexer)
- (add-hook 'semantic-lex-reset-functions 'semantic-lex-spp-reset-hook nil t)
- (when (eq major-mode 'c++-mode)
+ (add-hook 'semantic-lex-reset-functions #'semantic-lex-spp-reset-hook nil t)
+ (when (derived-mode-p 'c++-mode)
(add-to-list 'semantic-lex-c-preprocessor-symbol-map '("__cplusplus" . "")))
)
@@ -2158,7 +2144,7 @@ actually in their parent which is not accessible.")
(defun semantic-c-describe-environment ()
"Describe the Semantic features of the current C environment."
(interactive)
- (if (not (member 'c-mode (mode-local-equivalent-mode-p major-mode)))
+ (if (not (derived-mode-p 'c-mode))
(error "Not useful to query C mode in %s mode" major-mode))
(let ((gcc (when (boundp 'semantic-gcc-setup-data)
semantic-gcc-setup-data))
@@ -2258,8 +2244,8 @@ actually in their parent which is not accessible.")
(if (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
(let ((macros nil))
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-project-macro-symbol-obarray)
(dolist (S macros)
(princ " ")
diff --git a/lisp/cedet/semantic/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el
index 8ea9ac24423..47850a5d1f4 100644
--- a/lisp/cedet/semantic/bovine/debug.el
+++ b/lisp/cedet/semantic/bovine/debug.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/debug.el --- Debugger support for bovinator
+;;; semantic/bovine/debug.el --- Debugger support for bovinator -*- lexical-binding: t; -*-
;; Copyright (C) 2003, 2009-2021 Free Software Foundation, Inc.
@@ -123,7 +123,7 @@ Argument CONDITION is the thrown error condition."
frame)
frame))
-(cl-defmethod semantic-debug-frame-highlight ((frame semantic-bovine-debug-error-frame))
+(cl-defmethod semantic-debug-frame-highlight ((_frame semantic-bovine-debug-error-frame))
"Highlight a frame from an action."
;; How do I get the location of the action in the source buffer?
)
diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el
index a0feb0c26ef..ebb20448ed5 100644
--- a/lisp/cedet/semantic/bovine/el.el
+++ b/lisp/cedet/semantic/bovine/el.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp
+;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
@@ -169,10 +169,10 @@ where:
- FORM is an Elisp form read from the current buffer.
- START and END are the beginning and end location of the
corresponding data in the current buffer."
+ (declare (indent 1))
(let ((sym (make-symbol "sym")))
`(dolist (,sym ',symbols)
(put ,sym 'semantic-elisp-form-parser #',parser))))
-(put 'semantic-elisp-setup-form-parser 'lisp-indent-function 1)
(defmacro semantic-elisp-reuse-form-parser (symbol &rest symbols)
"Reuse the form parser of SYMBOL for forms identified by SYMBOLS.
@@ -210,7 +210,7 @@ Return a bovination list to use."
;;; Form parsers
;;
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-function
(symbol-name (nth 2 form))
nil
@@ -234,7 +234,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
@@ -256,7 +256,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
(semantic-tag-new-variable
(symbol-name (nth 1 form))
@@ -274,7 +274,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
(semantic-tag-new-variable
(symbol-name (nth 1 form))
@@ -290,7 +290,7 @@ Return a bovination list to use."
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
(semantic-tag-new-variable
(symbol-name (nth 1 form))
@@ -307,7 +307,7 @@ Return a bovination list to use."
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
(semantic-tag
(symbol-name (nth 1 form))
@@ -321,7 +321,7 @@ Return a bovination list to use."
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-function
(symbol-name (cadr (cadr form)))
nil nil
@@ -333,7 +333,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let* ((a2 (nth 2 form))
(a3 (nth 3 form))
(args (if (listp a2) a2 a3))
@@ -353,7 +353,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
@@ -363,7 +363,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((docpart (nthcdr 4 form)))
(semantic-tag-new-type
(symbol-name (nth 1 form))
@@ -381,7 +381,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((slots (nthcdr 2 form)))
;; Skip doc string if present.
(and (stringp (car slots))
@@ -399,7 +399,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil nil
@@ -410,7 +410,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((args (nth 3 form)))
(semantic-tag-new-function
(symbol-name (nth 1 form))
@@ -420,12 +420,11 @@ Return a bovination list to use."
:parent (symbol-name (nth 2 form))
:documentation (semantic-elisp-do-doc (nth 4 form))
)))
- define-mode-overload-implementation ;; obsoleted
define-mode-local-override
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(semantic-tag-new-variable
(symbol-name (nth 2 form))
nil
@@ -438,7 +437,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((name (nth 1 form)))
(semantic-tag-new-include
(symbol-name (if (eq (car-safe name) 'quote)
@@ -450,7 +449,7 @@ Return a bovination list to use."
)
(semantic-elisp-setup-form-parser
- (lambda (form start end)
+ (lambda (form _start _end)
(let ((name (nth 1 form)))
(semantic-tag-new-package
(symbol-name (if (eq (car-safe name) 'quote)
@@ -465,27 +464,11 @@ Return a bovination list to use."
(define-mode-local-override semantic-dependency-tag-file
emacs-lisp-mode (tag)
"Find the file BUFFER depends on described by TAG."
- (if (fboundp 'find-library-name)
- (condition-case nil
- ;; Try an Emacs 22 fcn. This throws errors.
- (find-library-name (semantic-tag-name tag))
- (error
- (message "semantic: cannot find source file %s"
- (semantic-tag-name tag))))
- ;; No handy function available. (Older Emacsen)
- (let* ((lib (locate-library (semantic-tag-name tag)))
- (name (if lib (file-name-sans-extension lib) nil))
- (nameel (concat name ".el")))
- (cond
- ((and name (file-exists-p nameel)) nameel)
- ((and name (file-exists-p (concat name ".el.gz")))
- ;; This is the linux distro case.
- (concat name ".el.gz"))
- ;; Source file does not exist.
- (name
- (message "semantic: cannot find source file %s" (concat name ".el")))
- (t
- nil)))))
+ (condition-case nil
+ (find-library-name (semantic-tag-name tag))
+ (error
+ (message "semantic: cannot find source file %s"
+ (semantic-tag-name tag)))))
;;; DOC Strings
;;
@@ -517,7 +500,7 @@ into Emacs Lisp's memory."
""))))
(define-mode-local-override semantic-documentation-for-tag
- emacs-lisp-mode (tag &optional nosnarf)
+ emacs-lisp-mode (tag &optional _nosnarf)
"Return the documentation string for TAG.
Optional argument NOSNARF is ignored."
(let ((d (semantic-tag-docstring tag)))
@@ -594,7 +577,7 @@ Override function for `semantic-tag-protection'."
((string= prot "protected") 'protected))))
(define-mode-local-override semantic-tag-static-p
- emacs-lisp-mode (tag &optional parent)
+ emacs-lisp-mode (tag &optional _parent)
"Return non-nil if TAG is static in PARENT class.
Overrides `semantic-nonterminal-static'."
;; This can only be true (theoretically) in a class where it is assigned.
@@ -602,10 +585,10 @@ Overrides `semantic-nonterminal-static'."
;;; Context parsing
;;
-;; Emacs lisp is very different from C,C++ which most context parsing
+;; Emacs Lisp is very different from C,C++ which most context parsing
;; functions are written. Support them here.
(define-mode-local-override semantic-up-context emacs-lisp-mode
- (&optional point bounds-type)
+ (&optional _point _bounds-type)
"Move up one context in an Emacs Lisp function.
A Context in many languages is a block with its own local variables.
In Emacs, we will move up lists and stop when one starts with one of
@@ -650,7 +633,7 @@ define-mode-overload\\)\
))
(when fun
;; Do not return FUN IFF the cursor is on FUN.
- ;; Huh? Thats because if cursor is on fun, it is
+ ;; Huh? That's because if cursor is on fun, it is
;; the current symbol, and not the current function.
(if (save-excursion
(condition-case nil
@@ -669,7 +652,7 @@ define-mode-overload\\)\
(define-mode-local-override semantic-get-local-variables emacs-lisp-mode
- (&optional point)
+ (&optional _point)
"Return a list of local variables for POINT.
Scan backwards from point at each successive function. For all occurrences
of `let' or `let*', grab those variable names."
@@ -957,7 +940,7 @@ ELisp variables can be pretty long, so track this one too.")
;; loaded into Emacs.
)
-(add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup)
+(add-hook 'emacs-lisp-mode-hook #'semantic-default-elisp-setup)
;;; LISP MODE
;;
@@ -967,7 +950,7 @@ ELisp variables can be pretty long, so track this one too.")
;; See this syntax:
;; (defun foo () /#A)
;;
-(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup)
+(add-hook 'lisp-mode-hook #'semantic-default-elisp-setup)
(eval-after-load "semantic/db"
'(require 'semantic/db-el)
diff --git a/lisp/cedet/semantic/bovine/gcc.el b/lisp/cedet/semantic/bovine/gcc.el
index 1cfe5a3bac1..02bd0defef5 100644
--- a/lisp/cedet/semantic/bovine/gcc.el
+++ b/lisp/cedet/semantic/bovine/gcc.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser
+;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -25,6 +25,7 @@
;; GCC, and set up the preprocessor and include paths.
(require 'semantic/dep)
+(require 'cl-lib)
(defvar semantic-lex-c-preprocessor-symbol-file)
(defvar semantic-lex-c-preprocessor-symbol-map)
@@ -46,11 +47,11 @@ to give to the program."
(erase-buffer)
(setenv "LC_ALL" "C")
(condition-case nil
- (setq err (apply 'call-process gcc-cmd options))
+ (setq err (apply #'call-process gcc-cmd options))
(error ;; Some bogus directory for the first time perhaps?
(let ((default-directory (expand-file-name "~/")))
(condition-case nil
- (setq err (apply 'call-process gcc-cmd options))
+ (setq err (apply #'call-process gcc-cmd options))
(error ;; gcc doesn't exist???
nil)))))
(setenv "LC_ALL" old-lc-messages)
@@ -88,10 +89,9 @@ to give to the program."
(let ((path (substring line 1)))
(when (and (file-accessible-directory-p path)
(file-name-absolute-p path))
- (add-to-list 'inc-path
- (expand-file-name path)
- t))))))))
- inc-path))
+ (cl-pushnew (expand-file-name path) inc-path
+ :test #'equal))))))))
+ (nreverse inc-path)))
(defun semantic-cpp-defs (str)
@@ -101,7 +101,7 @@ to give to the program."
(dolist (L lines)
(let ((dat (split-string L)))
(when (= (length dat) 3)
- (add-to-list 'lst (cons (nth 1 dat) (nth 2 dat))))))
+ (push (cons (nth 1 dat) (nth 2 dat)) lst))))
lst))
(defun semantic-gcc-fields (str)
@@ -142,6 +142,8 @@ This is an alist, and should include keys of:
`--prefix' - where GCC was installed.
It should also include other symbols GCC was compiled with.")
+(defvar c++-include-path)
+
;;;###autoload
(defun semantic-gcc-setup ()
"Setup Semantic C/C++ parsing based on GCC output."
@@ -149,12 +151,12 @@ It should also include other symbols GCC was compiled with.")
(let* ((fields (or semantic-gcc-setup-data
(semantic-gcc-fields (semantic-gcc-query "gcc" "-v"))))
(cpp-options `("-E" "-dM" "-x" "c++" ,null-device))
- (query (let ((q (apply 'semantic-gcc-query "cpp" cpp-options)))
+ (query (let ((q (apply #'semantic-gcc-query "cpp" cpp-options)))
(if (stringp q)
q
;; `cpp' command in `semantic-gcc-setup' doesn't work on
;; Mac, try `gcc'.
- (apply 'semantic-gcc-query "gcc" cpp-options))))
+ (apply #'semantic-gcc-query "gcc" cpp-options))))
(defines (if (stringp query)
(semantic-cpp-defs query)
(message (concat "Could not query gcc for defines. "
diff --git a/lisp/cedet/semantic/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el
index 1c5806a632f..a2717d711fe 100644
--- a/lisp/cedet/semantic/bovine/grammar.el
+++ b/lisp/cedet/semantic/bovine/grammar.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/grammar.el --- Bovine's input grammar mode
+;;; semantic/bovine/grammar.el --- Bovine's input grammar mode -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;;
@@ -25,9 +25,8 @@
;;
;; Major mode for editing Bovine's input grammar (.by) files.
-;;; History:
-
;;; Code:
+
(require 'semantic)
(require 'semantic/grammar)
(require 'semantic/find)
@@ -143,8 +142,7 @@ expanded from elsewhere."
form (cdr form))
;; Hack for dealing with new reading of unquotes outside of
;; backquote (introduced in 2010-12-06T16:37:26Z!monnier@iro.umontreal.ca).
- (when (and (>= emacs-major-version 24)
- (listp first)
+ (when (and (listp first)
(or (equal (car first) '\,)
(equal (car first) '\,@)))
(if (listp (cadr first))
@@ -244,7 +242,8 @@ QUOTEMODE is the mode in which quoted symbols are slurred."
(insert "\n")
(cond
((eq (car sexp) 'EXPAND)
- (insert ",(lambda (vals start end)")
+ (insert ",(lambda (vals start end)"
+ "\n(ignore vals start end)")
;; The EXPAND macro definition is mandatory
(bovine-grammar-expand-form
(apply (cdr (assq 'EXPAND bovine--grammar-macros)) (cdr sexp))
@@ -476,7 +475,7 @@ Menu items are appended to the common grammar menu.")
(with-current-buffer (find-file-noselect infile)
(setq infile buffer-file-name)
(if outdir (setq default-directory outdir))
- (semantic-grammar-create-package nil t))
+ (semantic-grammar-create-package t t))
(error (message "%s" (error-message-string err)) nil)))
lang filename copyright-end)
(when (and packagename
@@ -521,7 +520,8 @@ Menu items are appended to the common grammar menu.")
(goto-char (point-min))
(delete-region (point-min) (line-end-position))
(insert ";;; " packagename
- " --- Generated parser support file")
+ " --- Generated parser support file "
+ "-*- lexical-binding:t -*-")
(delete-trailing-whitespace)
(re-search-forward ";;; \\(.*\\) ends here")
(replace-match packagename nil nil nil 1)))))
diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el
index aeccb31c8a9..bb579cfde3f 100644
--- a/lisp/cedet/semantic/bovine/make.el
+++ b/lisp/cedet/semantic/bovine/make.el
@@ -1,4 +1,4 @@
-;;; semantic/bovine/make.el --- Makefile parsing rules.
+;;; semantic/bovine/make.el --- Makefile parsing rules. -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2004, 2008-2021 Free Software Foundation, Inc.
@@ -50,7 +50,8 @@
nil)
(define-lex-regex-analyzer semantic-lex-make-command
- "A command in a Makefile consists of a line starting with TAB, and ending at the newline."
+ "Regexp for a command in a Makefile.
+It consists of a line starting with TAB, and ending at the newline."
"^\\(\t\\)"
(let ((start (match-end 0)))
(while (progn (end-of-line)
@@ -102,13 +103,13 @@ Ignore them."
xpand))
(define-mode-local-override semantic-get-local-variables
- makefile-mode (&optional point)
+ makefile-mode (&optional _point)
"Override `semantic-get-local-variables' so it does not throw an error.
We never have local variables in Makefiles."
nil)
(define-mode-local-override semantic-ctxt-current-class-list
- makefile-mode (&optional point)
+ makefile-mode (&optional _point)
"List of classes that are valid to place at point."
(let ((tag (semantic-current-tag)))
(when tag
@@ -175,7 +176,7 @@ This is the same as a regular prototype."
(semantic-format-tag-prototype tag parent color))
(define-mode-local-override semantic-analyze-possible-completions
- makefile-mode (context &rest flags)
+ makefile-mode (context &rest _flags)
"Return a list of possible completions in a Makefile.
Uses default implementation, and also gets a list of filenames."
(require 'semantic/analyze/complete)
@@ -217,7 +218,7 @@ Uses default implementation, and also gets a list of filenames."
;; but not actually parsed.
(file . "File"))
semantic-case-fold t
- semantic-tag-expand-function 'semantic-make-expand-tag
+ semantic-tag-expand-function #'semantic-make-expand-tag
semantic-lex-syntax-modifications '((?. "_")
(?= ".")
(?/ "_")
@@ -225,7 +226,7 @@ Uses default implementation, and also gets a list of filenames."
(?+ ".")
(?\\ ".")
)
- imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function #'semantic-create-imenu-index
)
(setq semantic-lex-analyzer #'semantic-make-lexer)
)
diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el
index 3445313f7c2..0395412069b 100644
--- a/lisp/cedet/semantic/bovine/scm.el
+++ b/lisp/cedet/semantic/bovine/scm.el
@@ -1,6 +1,6 @@
-;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile)
+;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile) -*- lexical-binding: t; -*-
-;;; Copyright (C) 2001-2004, 2008-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -49,7 +49,7 @@ actually on the local machine.")
")")
(semantic-format-tag-prototype-default tag parent color))))
-(define-mode-local-override semantic-documentation-for-tag scheme-mode (tag &optional nosnarf)
+(define-mode-local-override semantic-documentation-for-tag scheme-mode (tag &optional _nosnarf)
"Return the documentation string for TAG.
Optional argument NOSNARF is ignored."
(let ((d (semantic-tag-docstring tag)))
@@ -57,7 +57,7 @@ Optional argument NOSNARF is ignored."
(substring d 1)
d)))
-(define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag tagfile)
+(define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag _tagfile)
"Insert TAG from TAGFILE at point.
Attempts a simple prototype for calling or using TAG."
(cond ((eq (semantic-tag-class tag) 'function)
@@ -69,7 +69,7 @@ Attempts a simple prototype for calling or using TAG."
;; Note: Analyzer from Henry S. Thompson
(define-lex-regex-analyzer semantic-lex-scheme-symbol
"Detect and create symbol and keyword tokens."
- "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)*\\)"
+ "\\(\\sw\\|\\s_\\)+"
;; (message "symbol: %s" (match-string 0))
(semantic-lex-push-token
(semantic-lex-token
@@ -102,8 +102,7 @@ syntax as specified by the syntax table."
(function . "Functions")
(include . "Loads")
(package . "DefineModule"))
- imenu-create-index-function 'semantic-create-imenu-index
- imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function #'semantic-create-imenu-index
)
(setq semantic-lex-analyzer #'semantic-scheme-lexer)
)
diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el
index e7848faf741..0abbe458647 100644
--- a/lisp/cedet/semantic/chart.el
+++ b/lisp/cedet/semantic/chart.el
@@ -1,4 +1,4 @@
-;;; semantic/chart.el --- Utilities for use with semantic tag tables
+;;; semantic/chart.el --- Utilities for use with semantic tag tables -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2001, 2003, 2005, 2008-2021 Free Software
;; Foundation, Inc.
@@ -43,7 +43,7 @@ TAGTABLE is passed to `semantic-something-to-tag-table'."
(interactive)
(let* ((stream (semantic-something-to-tag-table
(or tagtable (current-buffer))))
- (names (mapcar 'cdr semantic-symbol->name-assoc-list))
+ (names (mapcar #'cdr semantic-symbol->name-assoc-list))
(nums (mapcar
(lambda (symname)
(length
@@ -57,7 +57,7 @@ TAGTABLE is passed to `semantic-something-to-tag-table'."
nums "Volume")
))
-(defun semantic-chart-database-size (&optional tagtable)
+(defun semantic-chart-database-size (&optional _tagtable)
"Create a bar chart representing the size of each file in semanticdb.
Each bar represents how many toplevel tags in TAGTABLE
exist in each database entry.
@@ -68,7 +68,7 @@ TAGTABLE is passed to `semantic-something-to-tag-table'."
(error "Semanticdb is not enabled"))
(let* ((db semanticdb-current-database)
(dbt (semanticdb-get-database-tables db))
- (names (mapcar 'car
+ (names (mapcar #'car
(object-assoc-list
'file
dbt)))
@@ -84,8 +84,8 @@ TAGTABLE is passed to `semantic-something-to-tag-table'."
(nums nil)
(fh (/ (- (frame-height) 7) 4)))
(setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b)))))
- (setq names (mapcar 'cdr numnuts)
- nums (mapcar 'car numnuts))
+ (setq names (mapcar #'cdr numnuts)
+ nums (mapcar #'car numnuts))
(if (> (length names) fh)
(progn
(setcdr (nthcdr fh names) nil)
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 0fe3dffe0de..d6ef7960473 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -1,4 +1,4 @@
-;;; semantic/complete.el --- Routines for performing tag completion
+;;; semantic/complete.el --- Routines for performing tag completion -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2005, 2007-2021 Free Software Foundation, Inc.
@@ -154,8 +154,8 @@ Presumably if you call this you will insert something new there."
(defun semantic-completion-message (fmt &rest args)
"Display the string FMT formatted with ARGS at the end of the minibuffer."
(if semantic-complete-inline-overlay
- (apply 'message fmt args)
- (apply 'message (concat "%s" fmt) (buffer-string) args)))
+ (apply #'message fmt args)
+ (apply #'message (concat "%s" fmt) (buffer-string) args)))
;;; ------------------------------------------------------------
;;; MINIBUFFER: Option Selection harnesses
@@ -171,14 +171,14 @@ Value should be a ... what?")
(defvar semantic-complete-key-map
(let ((km (make-sparse-keymap)))
- (define-key km " " 'semantic-complete-complete-space)
- (define-key km "\t" 'semantic-complete-complete-tab)
- (define-key km "\C-m" 'semantic-complete-done)
- (define-key km "\C-g" 'abort-recursive-edit)
- (define-key km "\M-n" 'next-history-element)
- (define-key km "\M-p" 'previous-history-element)
- (define-key km "\C-n" 'next-history-element)
- (define-key km "\C-p" 'previous-history-element)
+ (define-key km " " #'semantic-complete-complete-space)
+ (define-key km "\t" #'semantic-complete-complete-tab)
+ (define-key km "\C-m" #'semantic-complete-done)
+ (define-key km "\C-g" #'abort-recursive-edit)
+ (define-key km "\M-n" #'next-history-element)
+ (define-key km "\M-p" #'previous-history-element)
+ (define-key km "\C-n" #'next-history-element)
+ (define-key km "\C-p" #'previous-history-element)
;; Add history navigation
km)
"Keymap used while completing across a list of tags.")
@@ -488,7 +488,7 @@ If PARTIAL, do partial completion stopping at spaces."
)
(t nil))))
-(defun semantic-complete-do-completion (&optional partial inline)
+(defun semantic-complete-do-completion (&optional partial _inline)
"Do a completion for the current minibuffer.
If PARTIAL, do partial completion stopping at spaces.
if INLINE, then completion is happening inline in a buffer."
@@ -550,12 +550,12 @@ if INLINE, then completion is happening inline in a buffer."
;; push ourselves out of this mode on alternate keypresses.
(defvar semantic-complete-inline-map
(let ((km (make-sparse-keymap)))
- (define-key km "\C-i" 'semantic-complete-inline-TAB)
- (define-key km "\M-p" 'semantic-complete-inline-up)
- (define-key km "\M-n" 'semantic-complete-inline-down)
- (define-key km "\C-m" 'semantic-complete-inline-done)
- (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
- (define-key km "\C-g" 'semantic-complete-inline-quit)
+ (define-key km "\C-i" #'semantic-complete-inline-TAB)
+ (define-key km "\M-p" #'semantic-complete-inline-up)
+ (define-key km "\M-n" #'semantic-complete-inline-down)
+ (define-key km "\C-m" #'semantic-complete-inline-done)
+ (define-key km "\C-\M-c" #'semantic-complete-inline-exit)
+ (define-key km "\C-g" #'semantic-complete-inline-quit)
(define-key km "?"
(lambda () (interactive)
(describe-variable 'semantic-complete-inline-map)))
@@ -620,7 +620,7 @@ Similar to `minibuffer-contents' when completing in the minibuffer."
"Exit inline completion mode."
(interactive)
;; Remove this hook FIRST!
- (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
+ (remove-hook 'pre-command-hook #'semantic-complete-pre-command-hook)
(condition-case nil
(progn
@@ -649,7 +649,7 @@ Similar to `minibuffer-contents' when completing in the minibuffer."
;; Remove this hook LAST!!!
;; This will force us back through this function if there was
;; some sort of error above.
- (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
+ (remove-hook 'post-command-hook #'semantic-complete-post-command-hook)
;;(message "Exiting inline completion.")
)
@@ -770,8 +770,8 @@ END is at the end of the current symbol being completed."
(overlay-put semantic-complete-inline-overlay
'semantic-original-start start)
;; Install our command hooks
- (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
- (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
+ (add-hook 'pre-command-hook #'semantic-complete-pre-command-hook)
+ (add-hook 'post-command-hook #'semantic-complete-post-command-hook)
;; Go!
(semantic-complete-inline-force-display)
)
@@ -867,9 +867,8 @@ Expected return values are:
;; * semantic-collector-try-completion
;; * semantic-collector-all-completions
-(defvar semantic-collector-per-buffer-list nil
+(defvar-local semantic-collector-per-buffer-list nil
"List of collectors active in this buffer.")
-(make-variable-buffer-local 'semantic-collector-per-buffer-list)
(defvar semantic-collector-list nil
"List of global collectors active this session.")
@@ -930,8 +929,8 @@ The only options available for completion are those which can be logically
inserted into the current context.")
(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-analyze-completions) prefix completionlist)
- "calculate the completions for prefix from completionlist."
+ ((obj semantic-collector-analyze-completions) prefix _completionlist)
+ "calculate the completions for prefix from COMPLETIONLIST."
;; if there are no completions yet, calculate them.
(if (not (slot-boundp obj 'first-pass-completions))
(oset obj first-pass-completions
@@ -944,7 +943,7 @@ inserted into the current context.")
prefix
(oref obj first-pass-completions)))))
-(cl-defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
+(cl-defmethod semantic-collector-cleanup ((_obj semantic-collector-abstract))
"Clean up any mess this collector may have."
nil)
@@ -1005,7 +1004,7 @@ Output must be in semanticdb Find result format."
(list (cons table result)))))
(cl-defmethod semantic-collector-calculate-completions
- ((obj semantic-collector-abstract) prefix partial)
+ ((obj semantic-collector-abstract) prefix _partial)
"Calculate completions for prefix as setup for other queries."
(let* ((case-fold-search semantic-case-fold)
(same-prefix-p (semantic-collector-last-prefix= obj prefix))
@@ -1015,7 +1014,8 @@ Output must be in semanticdb Find result format."
(cond ((or same-prefix-p
(and last-prefix (eq (compare-strings
last-prefix 0 nil
- prefix 0 (length last-prefix)) t)))
+ prefix 0 (length last-prefix))
+ t)))
;; We have the same prefix, or last-prefix is a
;; substring of the of new prefix, in which case we are
;; refining our symbol so just re-use cache.
@@ -1024,7 +1024,8 @@ Output must be in semanticdb Find result format."
(> (length prefix) 1)
(eq (compare-strings
prefix 0 nil
- last-prefix 0 (length prefix)) t))
+ last-prefix 0 (length prefix))
+ t))
;; The new prefix is a substring of the old
;; prefix, and it's longer than one character.
;; Perform a full search to pull in additional
@@ -1135,7 +1136,7 @@ into a buffer."
(semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
(cl-defmethod semantic-collector-all-completions
- ((obj semantic-collector-abstract) prefix)
+ ((obj semantic-collector-abstract) _prefix)
"For OBJ, retrieve all completions matching PREFIX.
The returned list consists of all the tags currently
matching PREFIX."
@@ -1143,7 +1144,7 @@ matching PREFIX."
(oref obj last-all-completions)))
(cl-defmethod semantic-collector-try-completion
- ((obj semantic-collector-abstract) prefix)
+ ((obj semantic-collector-abstract) _prefix)
"For OBJ, attempt to match PREFIX.
See `try-completion' for details on how this works.
Return nil for no match.
@@ -1154,7 +1155,7 @@ with that name."
(oref obj last-completion)))
(cl-defmethod semantic-collector-calculate-cache
- ((obj semantic-collector-abstract))
+ ((_obj semantic-collector-abstract))
"Calculate the completion cache for OBJ."
nil
)
@@ -1177,7 +1178,7 @@ These collectors track themselves on a per-buffer basis."
:abstract t)
(cl-defmethod make-instance ((this (subclass semantic-collector-buffer-abstract))
- &rest args)
+ &rest _args)
"Reuse previously created objects of this type in buffer."
(let ((old nil)
(bl semantic-collector-per-buffer-list))
@@ -1194,7 +1195,7 @@ These collectors track themselves on a per-buffer basis."
old))
;; Buffer specific collectors should flush themselves
-(defun semantic-collector-buffer-flush (newcache)
+(defun semantic-collector-buffer-flush (_newcache)
"Flush all buffer collector objects.
NEWCACHE is the new tag table, but we ignore it."
(condition-case nil
@@ -1205,7 +1206,7 @@ NEWCACHE is the new tag table, but we ignore it."
(error nil)))
(add-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-collector-buffer-flush)
+ #'semantic-collector-buffer-flush)
;;; DEEP BUFFER SPECIFIC COMPLETION
;;
@@ -1247,8 +1248,8 @@ Uses semanticdb for searching all tags in the current project."
(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
+ ((obj semantic-collector-project) prefix _completionlist)
+ "Calculate the completions for prefix from COMPLETIONLIST."
(semanticdb-find-tags-for-completion prefix (oref obj path)))
;;; Brutish Project search
@@ -1260,8 +1261,8 @@ Uses semanticdb for searching all tags in the current project."
"semantic/db-find")
(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project-brutish) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
+ ((obj semantic-collector-project-brutish) prefix _completionlist)
+ "Calculate the completions for prefix from COMPLETIONLIST."
(require 'semantic/db-find)
(semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
@@ -1274,8 +1275,8 @@ Uses semanticdb for searching all tags in the current project."
"Completion engine for tags in a project.")
(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-local-members) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
+ ((obj semantic-collector-local-members) prefix _completionlist)
+ "Calculate the completions for prefix from COMPLETIONLIST."
(let* ((scope (or (oref obj scope)
(oset obj scope (semantic-calculate-scope))))
(localstuff (oref scope scope)))
@@ -1324,7 +1325,7 @@ a collector, and tracking tables of completion to display."
(define-obsolete-function-alias 'semantic-displayor-cleanup
#'semantic-displayer-cleanup "27.1")
-(cl-defmethod semantic-displayer-cleanup ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-cleanup ((_obj semantic-displayer-abstract))
"Clean up any mess this displayer may have."
nil)
@@ -1349,37 +1350,37 @@ a collector, and tracking tables of completion to display."
(define-obsolete-function-alias 'semantic-displayor-show-request
#'semantic-displayer-show-request "27.1")
-(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-show-request ((_obj semantic-displayer-abstract))
"A request to show the current tags table."
(ding))
(define-obsolete-function-alias 'semantic-displayor-focus-request
#'semantic-displayer-focus-request "27.1")
-(cl-defmethod semantic-displayer-focus-request ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-focus-request ((_obj semantic-displayer-abstract))
"A request to for the displayer to focus on some tag option."
(ding))
(define-obsolete-function-alias 'semantic-displayor-scroll-request
#'semantic-displayer-scroll-request "27.1")
-(cl-defmethod semantic-displayer-scroll-request ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-scroll-request ((_obj semantic-displayer-abstract))
"A request to for the displayer to scroll the completion list (if needed)."
(scroll-other-window))
(define-obsolete-function-alias 'semantic-displayor-focus-previous
#'semantic-displayer-focus-previous "27.1")
-(cl-defmethod semantic-displayer-focus-previous ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-focus-previous ((_obj semantic-displayer-abstract))
"Set the current focus to the previous item."
nil)
(define-obsolete-function-alias 'semantic-displayor-focus-next
#'semantic-displayer-focus-next "27.1")
-(cl-defmethod semantic-displayer-focus-next ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-focus-next ((_obj semantic-displayer-abstract))
"Set the current focus to the next item."
nil)
(define-obsolete-function-alias 'semantic-displayor-current-focus
#'semantic-displayer-current-focus "27.1")
-(cl-defmethod semantic-displayer-current-focus ((obj semantic-displayer-abstract))
+(cl-defmethod semantic-displayer-current-focus ((_obj semantic-displayer-abstract))
"Return a single tag currently in focus.
This object type doesn't do focus, so will never have a focus object."
nil)
@@ -1453,7 +1454,7 @@ which have the same name."
(define-obsolete-function-alias 'semantic-displayor-set-completions
#'semantic-displayer-set-completions "27.1")
(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-focus-abstract)
- table prefix)
+ _table _prefix)
"Set the list of tags to be completed over to TABLE."
(cl-call-next-method)
(slot-makeunbound obj 'focus))
@@ -1635,10 +1636,10 @@ This will not happen if you directly set this variable via `setq'."
:group 'semantic
:version "24.3"
:type 'integer
- :set '(lambda (sym var)
- (set-default sym var)
- (when (boundp 'x-max-tooltip-size)
- (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size))))))
+ :set (lambda (sym var)
+ (set-default sym var)
+ (when (boundp 'x-max-tooltip-size)
+ (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size))))))
(defclass semantic-displayer-tooltip (semantic-displayer-traditional)
@@ -1664,7 +1665,7 @@ This will not happen if you directly set this variable via `setq'."
"Display completions options in a tooltip.
Display mechanism using tooltip for a list of possible completions.")
-(cl-defmethod initialize-instance :after ((obj semantic-displayer-tooltip) &rest args)
+(cl-defmethod initialize-instance :after ((_obj semantic-displayer-tooltip) &rest _args)
"Make sure we have tooltips required."
(require 'tooltip))
@@ -1682,16 +1683,16 @@ Display mechanism using tooltip for a list of possible completions.")
(table (semantic-unique-tag-table-by-name tablelong))
(completions (mapcar semantic-completion-displayer-format-tag-function table))
(numcompl (length completions))
- (typing-count (oref obj typing-count))
+ ;; (typing-count (oref obj typing-count))
(mode (oref obj mode))
(max-tags (oref obj max-tags-initial))
(matchtxt (semantic-completion-text))
msg msg-tail)
;; Keep a count of the consecutive completion commands entered by the user.
- (if (and (stringp (this-command-keys))
- (string= (this-command-keys) "\C-i"))
- (oset obj typing-count (1+ (oref obj typing-count)))
- (oset obj typing-count 0))
+ (oset obj typing-count
+ (if (equal (this-command-keys) "\C-i")
+ (1+ (oref obj typing-count))
+ 0))
(cond
((eq mode 'quiet)
;; Switch back to standard mode if user presses key more than 5 times.
@@ -1731,7 +1732,7 @@ Display mechanism using tooltip for a list of possible completions.")
(when semantic-idle-scheduler-verbose-flag
(setq msg "[NO MATCH]"))))
;; Create the tooltip text.
- (setq msg (concat msg (mapconcat 'identity completions "\n"))))
+ (setq msg (concat msg (mapconcat #'identity completions "\n"))))
;; Add any tail info.
(setq msg (concat msg msg-tail))
;; Display tooltip.
@@ -1829,12 +1830,10 @@ text using overlay options.")
(define-obsolete-function-alias 'semantic-displayor-set-completions
#'semantic-displayer-set-completions "27.1")
(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-ghost)
- table prefix)
+ _table _prefix)
"Set the list of tags to be completed over to TABLE."
(cl-call-next-method)
-
- (semantic-displayer-cleanup obj)
- )
+ (semantic-displayer-cleanup obj))
(define-obsolete-function-alias 'semantic-displayor-show-request
@@ -2059,9 +2058,8 @@ prompts. these are calculated from the CONTEXT variable passed in."
(semantic-displayer-traditional-with-focus-highlight)
(with-current-buffer (oref context buffer)
(goto-char (cdr (oref context bounds)))
- (concat prompt (mapconcat 'identity syms ".")
- (if syms "." "")
- ))
+ (concat prompt (mapconcat #'identity syms ".")
+ (if syms "." "")))
nil
inp
history)))
diff --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el
index 4d2defde35b..17ffaeff5e4 100644
--- a/lisp/cedet/semantic/ctxt.el
+++ b/lisp/cedet/semantic/ctxt.el
@@ -1,4 +1,4 @@
-;;; semantic/ctxt.el --- Context calculations for Semantic tools.
+;;; semantic/ctxt.el --- Context calculations for Semantic tools -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -32,17 +32,15 @@
(require 'semantic)
;;; Code:
-(defvar semantic-command-separation-character
+(defvar-local semantic-command-separation-character
";"
"String which indicates the end of a command.
Used for identifying the end of a single command.")
-(make-variable-buffer-local 'semantic-command-separation-character)
-(defvar semantic-function-argument-separation-character
+(defvar-local semantic-function-argument-separation-character
","
"String which indicates the end of an argument.
Used for identifying arguments to functions.")
-(make-variable-buffer-local 'semantic-function-argument-separation-character)
;;; Local Contexts
;;
@@ -139,18 +137,16 @@ Return non-nil if there is no upper context."
(defmacro semantic-with-buffer-narrowed-to-context (&rest body)
"Execute BODY with the buffer narrowed to the current context."
+ (declare (indent 0) (debug t))
`(save-restriction
(semantic-narrow-to-context)
,@body))
-(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0)
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec semantic-with-buffer-narrowed-to-context
- (def-body))))
;;; Local Variables
;;
-;;
+
+(defvar semantic--progress-reporter)
+
(define-overloadable-function semantic-get-local-variables (&optional point)
"Get the local variables based on POINT's context.
Local variables are returned in Semantic tag format.
@@ -347,14 +343,10 @@ beginning and end of a command."
(defmacro semantic-with-buffer-narrowed-to-command (&rest body)
"Execute BODY with the buffer narrowed to the current command."
+ (declare (indent 0) (debug t))
`(save-restriction
(semantic-narrow-to-command)
,@body))
-(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0)
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec semantic-with-buffer-narrowed-to-command
- (def-body))))
(define-overloadable-function semantic-ctxt-end-of-symbol (&optional point)
"Move point to the end of the current symbol under POINT.
@@ -376,7 +368,7 @@ work on C like languages."
;; NOTE: The [ \n] expression below should used \\s-, but that
;; doesn't work in C since \n means end-of-comment, and isn't
;; really whitespace.
- (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)"))
+ ;;(fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)"))
(case-fold-search semantic-case-fold)
(continuesearch t)
(end nil)
@@ -657,7 +649,7 @@ POINT defaults to the value of point in current buffer.
You should override this function in multiple mode buffers to
determine which major mode apply at point.")
-(defun semantic-ctxt-current-mode-default (&optional point)
+(defun semantic-ctxt-current-mode-default (&optional _point)
"Return the major mode active at POINT.
POINT defaults to the value of point in current buffer.
This default implementation returns the current major mode."
@@ -673,7 +665,7 @@ The return value can be a mixed list of either strings (names of
types that are in scope) or actual tags (type declared locally
that may or may not have a name.)")
-(defun semantic-ctxt-scoped-types-default (&optional point)
+(defun semantic-ctxt-scoped-types-default (&optional _point)
"Return a list of scoped types by name for the current context at POINT.
This is very different for various languages, and does nothing unless
overridden."
diff --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el
index c553ab499ae..d8f7034f03a 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
+;;; semantic/db-debug.el --- Extra level debugging routines for Semantic -*- lexical-binding: t; -*-
-;;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -38,7 +38,7 @@
(data-debug-new-buffer "*SEMANTICDB*")
(data-debug-insert-stuff-list db "*")))
-(defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary)
+(defalias 'semanticdb-adebug-database-list #'semanticdb-dump-all-table-summary)
(defun semanticdb-adebug-current-database ()
"Run ADEBUG on the current database."
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el
index 4202b1f798e..8bc3b810a65 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -1,4 +1,4 @@
-;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse.
+;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse. -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -74,12 +74,12 @@ By default, include only headers since the semantic use of EBrowse
is only for searching via semanticdb, and thus only headers would
be searched."
:group 'semanticdb
- :type 'string)
+ :type 'regexp)
;;; SEMANTIC Database related Code
;;; Classes:
(defclass semanticdb-table-ebrowse (semanticdb-table)
- ((major-mode :initform c++-mode)
+ ((major-mode :initform #'c++-mode)
(ebrowse-tree :initform nil
:initarg :ebrowse-tree
:documentation
@@ -95,7 +95,7 @@ This table is composited from the ebrowse *Globals* section.")
(defclass semanticdb-project-database-ebrowse
(semanticdb-project-database)
- ((new-table-class :initform semanticdb-table-ebrowse
+ ((new-table-class :initform 'semanticdb-table-ebrowse
:type class
:documentation
"New tables created for this database are of this class.")
@@ -135,8 +135,8 @@ is specified by `semanticdb-default-save-directory'."
(let* ((savein (semanticdb-ebrowse-file-for-directory dir))
(filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
(files (directory-files (expand-file-name dir) t))
- (mma auto-mode-alist)
- (regexp nil)
+ ;; (mma auto-mode-alist)
+ ;; (regexp nil)
)
;; Create the input to the ebrowse command
(with-current-buffer filebuff
@@ -181,7 +181,8 @@ is specified by `semanticdb-default-save-directory'."
"Load all semanticdb controlled EBROWSE caches."
(interactive)
(let ((f (directory-files semanticdb-default-save-directory
- t (concat semanticdb-ebrowse-default-file-name
+ t (concat (regexp-quote
+ semanticdb-ebrowse-default-file-name)
"-load\\.el\\'")
t)))
(while f
@@ -221,12 +222,12 @@ warn instead."
;JAVE this just instantiates a default empty ebrowse struct?
; how would new instances wind up here?
-; the ebrowse class isn't singleton, unlike the emacs lisp one
+; the ebrowse class isn't singleton, unlike the Emacs Lisp one
(defvar-mode-local c++-mode semanticdb-project-system-databases
()
"Search Ebrowse for symbols.")
-(cl-defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
+(cl-defmethod semanticdb-needs-refresh-p ((_table semanticdb-table-ebrowse))
"EBROWSE database do not need to be refreshed.
JAVE: stub for needs-refresh, because, how do we know if BROWSE files
@@ -273,7 +274,7 @@ For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
(insert-file-contents B)
(let ((ans nil)
(efcn (symbol-function 'ebrowse-show-progress)))
- (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
+ (fset 'ebrowse-show-progress (lambda (&rest _junk) nil))
(unwind-protect ;; Protect against errors w/ ebrowse
(setq ans (list B (ebrowse-read)))
;; These items must always happen
@@ -340,10 +341,10 @@ If there is no database for DIRECTORY available, then
(while T
(let* ((tree (car T))
- (class (ebrowse-ts-class tree)); root class of tree
+ ;;(class (ebrowse-ts-class tree)); root class of tree
;; Something funny going on with this file thing...
- (filename (or (ebrowse-cs-source-file class)
- (ebrowse-cs-file class)))
+ ;; (filename (or (ebrowse-cs-source-file class)
+ ;; (ebrowse-cs-file class)))
)
(cond
((ebrowse-globals-tree-p tree)
@@ -362,18 +363,18 @@ If there is no database for DIRECTORY available, then
;;; Filename based methods
;;
-(defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
+(defun semanticdb-ebrowse-add-globals-to-table (_dbe tree)
"For database DBE, add the ebrowse TREE into the table."
(if (or (not (ebrowse-ts-p tree))
(not (ebrowse-globals-tree-p tree)))
(signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
(let* ((class (ebrowse-ts-class tree))
- (fname (or (ebrowse-cs-source-file class)
- (ebrowse-cs-file class)
- ;; Not def'd here, assume our current
- ;; file
- (concat default-directory "/unknown-proxy.hh")))
+ ;; (fname (or (ebrowse-cs-source-file class)
+ ;; (ebrowse-cs-file class)
+ ;; ;; Not def'd here, assume our current
+ ;; ;; file
+ ;; (concat default-directory "/unknown-proxy.hh")))
(vars (ebrowse-ts-member-functions tree))
(fns (ebrowse-ts-member-variables tree))
(toks nil)
@@ -572,7 +573,7 @@ return that."
;; how your new search routines are implemented.
;;
(cl-defmethod semanticdb-find-tags-by-name-method
- ((table semanticdb-table-ebrowse) name &optional tags)
+ ((_table semanticdb-table-ebrowse) _name &optional tags)
"Find all tags named NAME in TABLE.
Return a list of tags."
;;(message "semanticdb-find-tags-by-name-method name -- %s" name)
@@ -587,7 +588,7 @@ Return a list of tags."
)
(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((table semanticdb-table-ebrowse) regex &optional tags)
+ ((_table semanticdb-table-ebrowse) _regex &optional tags)
"Find all tags with name matching REGEX in TABLE.
Optional argument TAGS is a list of tags to search.
Return a list of tags."
@@ -597,7 +598,7 @@ Return a list of tags."
))
(cl-defmethod semanticdb-find-tags-for-completion-method
- ((table semanticdb-table-ebrowse) prefix &optional tags)
+ ((_table semanticdb-table-ebrowse) _prefix &optional tags)
"In TABLE, find all occurrences of tags matching PREFIX.
Optional argument TAGS is a list of tags to search.
Returns a table of all matching tags."
@@ -607,7 +608,7 @@ Returns a table of all matching tags."
))
(cl-defmethod semanticdb-find-tags-by-class-method
- ((table semanticdb-table-ebrowse) class &optional tags)
+ ((_table semanticdb-table-ebrowse) _class &optional tags)
"In TABLE, find all occurrences of tags of CLASS.
Optional argument TAGS is a list of tags to search.
Returns a table of all matching tags."
@@ -624,7 +625,7 @@ Returns a table of all matching tags."
;;
(cl-defmethod semanticdb-deep-find-tags-by-name-method
- ((table semanticdb-table-ebrowse) name &optional tags)
+ ((_table semanticdb-table-ebrowse) _name &optional _tags)
"Find all tags name NAME in TABLE.
Optional argument TAGS is a list of tags to search.
Like `semanticdb-find-tags-by-name-method' for ebrowse."
@@ -632,7 +633,7 @@ Like `semanticdb-find-tags-by-name-method' for ebrowse."
(cl-call-next-method))
(cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method
- ((table semanticdb-table-ebrowse) regex &optional tags)
+ ((_table semanticdb-table-ebrowse) _regex &optional _tags)
"Find all tags with name matching REGEX in TABLE.
Optional argument TAGS is a list of tags to search.
Like `semanticdb-find-tags-by-name-method' for ebrowse."
@@ -640,7 +641,7 @@ Like `semanticdb-find-tags-by-name-method' for ebrowse."
(cl-call-next-method))
(cl-defmethod semanticdb-deep-find-tags-for-completion-method
- ((table semanticdb-table-ebrowse) prefix &optional tags)
+ ((_table semanticdb-table-ebrowse) _prefix &optional _tags)
"In TABLE, find all occurrences of tags matching PREFIX.
Optional argument TAGS is a list of tags to search.
Like `semanticdb-find-tags-for-completion-method' for ebrowse."
@@ -650,7 +651,7 @@ Like `semanticdb-find-tags-for-completion-method' for ebrowse."
;;; Advanced Searches
;;
(cl-defmethod semanticdb-find-tags-external-children-of-type-method
- ((table semanticdb-table-ebrowse) type &optional tags)
+ ((_table semanticdb-table-ebrowse) _type &optional tags)
"Find all nonterminals which are child elements of TYPE
Optional argument TAGS is a list of tags to search.
Return a list of tags."
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el
index 4699e722c1a..41e48b0bc30 100644
--- a/lisp/cedet/semantic/db-el.el
+++ b/lisp/cedet/semantic/db-el.el
@@ -1,6 +1,6 @@
-;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp
+;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp -*- lexical-binding: t; -*-
-;;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -40,7 +40,7 @@
;;; Classes:
(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
- ((major-mode :initform emacs-lisp-mode)
+ ((major-mode :initform #'emacs-lisp-mode)
)
"A table for returning search results from Emacs.")
@@ -53,7 +53,7 @@ It does not need refreshing."
"Return nil, we never need a refresh."
nil)
-(cl-defmethod semanticdb-debug-info ((obj semanticdb-table-emacs-lisp))
+(cl-defmethod semanticdb-debug-info ((_obj semanticdb-table-emacs-lisp))
(list "(proxy)"))
(cl-defmethod cl-print-object ((obj semanticdb-table-emacs-lisp) stream)
@@ -63,7 +63,7 @@ It does not need refreshing."
(defclass semanticdb-project-database-emacs-lisp
(semanticdb-project-database eieio-singleton)
- ((new-table-class :initform semanticdb-table-emacs-lisp
+ ((new-table-class :initform 'semanticdb-table-emacs-lisp
:type class
:documentation
"New tables created for this database are of this class.")
@@ -195,9 +195,6 @@ If Emacs cannot resolve this symbol to a particular file, then return nil."
(when tab (cons tab match))))))
(autoload 'help-function-arglist "help-fns")
-(defalias 'semanticdb-elisp-sym-function-arglist 'help-function-arglist)
-(make-obsolete 'semanticdb-elisp-sym-function-arglist
- 'help-function-arglist "CEDET 1.1")
(defun semanticdb-elisp-sym->tag (sym &optional toktype)
"Convert SYM into a semantic tag.
@@ -347,6 +344,9 @@ Return a list of tags."
)
taglst))))
+(define-obsolete-function-alias 'semanticdb-elisp-sym-function-arglist
+ #'help-function-arglist "24.3")
+
(provide 'semantic/db-el)
;;; semantic/db-el.el ends here
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el
index 59e9db9cc0a..c9007ac7a02 100644
--- a/lisp/cedet/semantic/db-file.el
+++ b/lisp/cedet/semantic/db-file.el
@@ -1,6 +1,6 @@
-;;; semantic/db-file.el --- Save a semanticdb to a cache file.
+;;; semantic/db-file.el --- Save a semanticdb to a cache file. -*- lexical-binding: t; -*-
-;;; Copyright (C) 2000-2005, 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: tags
@@ -154,8 +154,6 @@ If DIRECTORY doesn't exist, create a new one."
;;; File IO
-(declare-function inversion-test "inversion")
-
(defun semanticdb-load-database (filename)
"Load the database FILENAME."
(condition-case foo
@@ -163,32 +161,19 @@ If DIRECTORY doesn't exist, create a new one."
'semanticdb-project-database-file))
(c (semanticdb-get-database-tables r))
(tv (oref r semantic-tag-version))
- (fv (oref r semanticdb-version))
- )
+ (fv (oref r semanticdb-version)))
;; Restore the parent-db connection
(while c
(oset (car c) parent-db r)
(setq c (cdr c)))
(unless (and (equal semanticdb-file-version fv)
(equal semantic-tag-version tv))
- ;; Try not to load inversion unless we need it:
- (require 'inversion)
- (if (not (inversion-test 'semanticdb-file fv))
- (when (inversion-test 'semantic-tag tv)
- ;; Incompatible version. Flush tables.
- (semanticdb-flush-database-tables r)
- ;; Reset the version to new version.
- (oset r semantic-tag-version semantic-tag-version)
- ;; Warn user
- (message "Semanticdb file is old. Starting over for %s"
- filename))
- ;; Version is not ok. Flush whole system
- (message "semanticdb file is old. Starting over for %s"
- filename)
- ;; This database is so old, we need to replace it.
- ;; We also need to delete it from the instance tracker.
- (delete-instance r)
- (setq r nil)))
+ ;; Version is not ok. Flush whole system
+ (message "semanticdb file is old. Starting over for %s" filename)
+ ;; This database is so old, we need to replace it.
+ ;; We also need to delete it from the instance tracker.
+ (delete-instance r)
+ (setq r nil))
r)
(error (message "Cache Error: [%s] %s, Restart"
filename foo)
@@ -373,13 +358,13 @@ Uses `semanticdb-persistent-path' to determine the return value."
(object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
(cl-defmethod semanticdb-file-name-non-directory
- ((dbclass (subclass semanticdb-project-database-file)))
+ ((_dbclass (subclass semanticdb-project-database-file)))
"Return the file name DBCLASS will use.
File name excludes any directory part."
semanticdb-default-file-name)
(cl-defmethod semanticdb-file-name-directory
- ((dbclass (subclass semanticdb-project-database-file)) directory)
+ ((_dbclass (subclass semanticdb-project-database-file)) directory)
"Return the relative directory to where DBCLASS will save its cache file.
The returned path is related to DIRECTORY."
(if semanticdb-default-save-directory
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el
index 72af7c23dab..c96a426280e 100644
--- a/lisp/cedet/semantic/db-find.el
+++ b/lisp/cedet/semantic/db-find.el
@@ -1,4 +1,4 @@
-;;; semantic/db-find.el --- Searching through semantic databases.
+;;; semantic/db-find.el --- Searching through semantic databases. -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -209,14 +209,14 @@ This class will cache data derived during various searches.")
)
(cl-defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
- new-tags)
+ _new-tags)
"Synchronize the search index IDX with some NEW-TAGS."
;; Reset our parts.
(semantic-reset idx)
;; Notify dependants by clearing their indices.
(semanticdb-notify-references
(oref idx table)
- (lambda (tab me)
+ (lambda (tab _me)
(semantic-reset (semanticdb-get-table-index tab))))
)
@@ -230,7 +230,7 @@ This class will cache data derived during various searches.")
;; Notify dependants by clearing their indices.
(semanticdb-notify-references
(oref idx table)
- (lambda (tab me)
+ (lambda (tab _me)
(semantic-reset (semanticdb-get-table-index tab))))
)
;; Else, not an include, by just a type.
@@ -240,7 +240,7 @@ This class will cache data derived during various searches.")
;; Notify dependants by clearing their indices.
(semanticdb-notify-references
(oref idx table)
- (lambda (tab me)
+ (lambda (tab _me)
(let ((tab-idx (semanticdb-get-table-index tab)))
;; Not a full reset?
(when (oref tab-idx type-cache)
@@ -426,17 +426,15 @@ Default action as described in `semanticdb-find-translate-path'."
;; searchable item, then instead do the regular thing without caching.
(semanticdb-find-translate-path-includes--internal path))))
-(defvar semanticdb-find-lost-includes nil
+(defvar-local semanticdb-find-lost-includes nil
"Include files that we cannot find associated with this buffer.")
-(make-variable-buffer-local 'semanticdb-find-lost-includes)
-(defvar semanticdb-find-scanned-include-tags nil
+(defvar-local semanticdb-find-scanned-include-tags nil
"All include tags scanned, plus action taken on the tag.
Each entry is an alist:
(ACTION . TAG)
where ACTION is one of `scanned', `duplicate', `lost'
and TAG is a clone of the include tag that was found.")
-(make-variable-buffer-local 'semanticdb-find-scanned-include-tags)
(defvar semanticdb-implied-include-tags nil
"Include tags implied for all files of a given mode.
@@ -793,7 +791,8 @@ PREBUTTONTEXT is some text between prefix and the overlay button."
(file (semantic-tag-file-name tag))
(str1 (format "%S %s" mode name))
(str2 (format " : %s" file))
- (tip nil))
+ ;; (tip nil)
+ )
(insert prefix prebuttontext str1)
(setq end (point))
(insert str2)
@@ -809,7 +808,7 @@ PREBUTTONTEXT is some text between prefix and the overlay button."
(put-text-property start end 'ddebug (cdr consdata))
(put-text-property start end 'ddebug-indent(length prefix))
(put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
+ ;; (put-text-property start end 'help-echo tip)
(put-text-property start end 'ddebug-function
'data-debug-insert-tag-parts-from-point)
(insert "\n")
@@ -1011,7 +1010,7 @@ is still made current."
(when norm
;; The normalized tags can now be found based on that
;; tags table.
- (condition-case foo
+ (condition-case nil
(progn
(semanticdb-set-buffer (car norm))
;; Now reset ans
@@ -1245,7 +1244,7 @@ See `semanticdb-find-translate-path' for details on PATH.
The argument BRUTISH will be set so that searching includes all tables
in the current project.
FIND-FILE-MATCH indicates that any time a match is found, the file
-associated wit that tag should be loaded into a buffer."
+associated with that tag should be loaded into a buffer."
(semanticdb-find-tags-collector
(lambda (table tags)
(semanticdb-deep-find-tags-by-name-method table name tags))
@@ -1257,7 +1256,7 @@ See `semanticdb-find-translate-path' for details on PATH.
The argument BRUTISH will be set so that searching includes all tables
in the current project.
FIND-FILE-MATCH indicates that any time a match is found, the file
-associated wit that tag should be loaded into a buffer."
+associated with that tag should be loaded into a buffer."
(semanticdb-find-tags-collector
(lambda (table tags)
(semanticdb-deep-find-tags-for-completion-method table prefix tags))
diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el
index 2f40082d53c..fad24485ed2 100644
--- a/lisp/cedet/semantic/db-global.el
+++ b/lisp/cedet/semantic/db-global.el
@@ -1,4 +1,4 @@
-;;; semantic/db-global.el --- Semantic database extensions for GLOBAL
+;;; semantic/db-global.el --- Semantic database extensions for GLOBAL -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2006, 2008-2021 Free Software Foundation, Inc.
@@ -56,7 +56,7 @@ values."
(interactive
(list (completing-read
"Enable in Mode: " obarray
- #'(lambda (s) (get s 'mode-local-symbol-table))
+ (lambda (s) (get s 'mode-local-symbol-table))
t (symbol-name major-mode))))
;; First, make sure the version is ok.
@@ -69,7 +69,8 @@ values."
(let ((semanticdb--ih (mode-local-value mode 'semantic-init-mode-hook)))
(eval `(setq-mode-local
,mode semantic-init-mode-hook
- (cons 'semanticdb-enable-gnu-global-hook semanticdb--ih))))
+ (cons 'semanticdb-enable-gnu-global-hook ',semanticdb--ih))
+ t))
t
)
)
@@ -114,7 +115,7 @@ if optional DONT-ERR-IF-NOT-AVAILABLE is non-nil; else throw an error."
)
"A table for returning search results from GNU Global.")
-(cl-defmethod semanticdb-debug-info ((obj semanticdb-table-global))
+(cl-defmethod semanticdb-debug-info ((_obj semanticdb-table-global))
(list "(proxy)"))
(cl-defmethod cl-print-object ((obj semanticdb-table-global) stream)
@@ -123,7 +124,7 @@ Adds the number of tags in this file to the object print name."
(princ (eieio-object-name obj (semanticdb-debug-info obj))
stream))
-(cl-defmethod semanticdb-equivalent-mode ((table semanticdb-table-global) &optional buffer)
+(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-table-global) &optional _buffer)
"Return t, pretend that this table's mode is equivalent to BUFFER.
Equivalent modes are specified by the `semantic-equivalent-major-modes'
local variable."
@@ -146,7 +147,7 @@ For each file hit, get the traditional semantic table from that file."
(cl-call-next-method))
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-global) filename)
+(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-global) _filename)
"From OBJ, return FILENAME's associated table object."
;; We pass in "don't load". I wonder if we need to avoid that or not?
(car (semanticdb-get-database-tables obj))
@@ -157,7 +158,7 @@ For each file hit, get the traditional semantic table from that file."
;; Only NAME based searches work with GLOBAL as that is all it tracks.
;;
(cl-defmethod semanticdb-find-tags-by-name-method
- ((table semanticdb-table-global) name &optional tags)
+ ((_table semanticdb-table-global) name &optional tags)
"Find all tags named NAME in TABLE.
Return a list of tags."
(if tags
@@ -174,7 +175,7 @@ Return a list of tags."
)))
(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((table semanticdb-table-global) regex &optional tags)
+ ((_table semanticdb-table-global) regex &optional tags)
"Find all tags with name matching REGEX in TABLE.
Optional argument TAGS is a list of tags to search.
Return a list of tags."
@@ -187,7 +188,7 @@ Return a list of tags."
)))
(cl-defmethod semanticdb-find-tags-for-completion-method
- ((table semanticdb-table-global) prefix &optional tags)
+ ((_table semanticdb-table-global) prefix &optional tags)
"In TABLE, find all occurrences of tags matching PREFIX.
Optional argument TAGS is a list of tags to search.
Returns a table of all matching tags."
diff --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el
index 2b138866215..bf3d6122954 100644
--- a/lisp/cedet/semantic/db-javascript.el
+++ b/lisp/cedet/semantic/db-javascript.el
@@ -1,4 +1,4 @@
-;;; semantic/db-javascript.el --- Semantic database extensions for javascript
+;;; semantic/db-javascript.el --- Semantic database extensions for javascript -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -80,7 +80,7 @@ See bottom of this file for instructions on managing this list.")
;;; Classes:
(defclass semanticdb-table-javascript (semanticdb-search-results-table)
- ((major-mode :initform javascript-mode)
+ ((major-mode :initform #'javascript-mode)
)
"A table for returning search results from javascript.")
@@ -88,7 +88,7 @@ See bottom of this file for instructions on managing this list.")
(semanticdb-project-database
eieio-singleton ;this db is for js globals, so singleton is appropriate
)
- ((new-table-class :initform semanticdb-table-javascript
+ ((new-table-class :initform 'semanticdb-table-javascript
:type class
:documentation
"New tables created for this database are of this class.")
@@ -129,20 +129,20 @@ Create one of our special tables that can act as an intermediary."
(cl-call-next-method)
)
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename)
+(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) _filename)
"From OBJ, return FILENAME's associated table object."
;; NOTE: See not for `semanticdb-get-database-tables'.
(car (semanticdb-get-database-tables obj))
)
-(cl-defmethod semanticdb-get-tags ((table semanticdb-table-javascript ))
+(cl-defmethod semanticdb-get-tags ((_table semanticdb-table-javascript ))
"Return the list of tags belonging to TABLE."
;; NOTE: Omniscient databases probably don't want to keep large tables
;; lolly-gagging about. Keep internal Emacs tables empty and
;; refer to alternate databases when you need something.
semanticdb-javascript-tags)
-(cl-defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &optional buffer)
+(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-table-javascript) &optional buffer)
"Return non-nil if TABLE's mode is equivalent to BUFFER.
Equivalent modes are specified by the `semantic-equivalent-major-modes'
local variable."
@@ -193,7 +193,7 @@ database (if available.)"
result))
(cl-defmethod semanticdb-find-tags-by-name-method
- ((table semanticdb-table-javascript) name &optional tags)
+ ((_table semanticdb-table-javascript) name &optional tags)
"Find all tags named NAME in TABLE.
Return a list of tags."
(if tags
@@ -203,7 +203,7 @@ Return a list of tags."
))
(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((table semanticdb-table-javascript) regex &optional tags)
+ ((_table semanticdb-table-javascript) regex &optional tags)
"Find all tags with name matching REGEX in TABLE.
Optional argument TAGS is a list of tags to search.
Return a list of tags."
@@ -214,7 +214,7 @@ Return a list of tags."
))
(cl-defmethod semanticdb-find-tags-for-completion-method
- ((table semanticdb-table-javascript) prefix &optional tags)
+ ((_table semanticdb-table-javascript) prefix &optional tags)
"In TABLE, find all occurrences of tags matching PREFIX.
Optional argument TAGS is a list of tags to search.
Returns a table of all matching tags."
@@ -224,7 +224,7 @@ Returns a table of all matching tags."
))
(cl-defmethod semanticdb-find-tags-by-class-method
- ((table semanticdb-table-javascript) class &optional tags)
+ ((_table semanticdb-table-javascript) _class &optional tags)
"In TABLE, find all occurrences of tags of CLASS.
Optional argument TAGS is a list of tags to search.
Returns a table of all matching tags."
@@ -268,7 +268,7 @@ Like `semanticdb-find-tags-for-completion-method' for javascript."
;;; Advanced Searches
;;
(cl-defmethod semanticdb-find-tags-external-children-of-type-method
- ((table semanticdb-table-javascript) type &optional tags)
+ ((_table semanticdb-table-javascript) _type &optional tags)
"Find all nonterminals which are child elements of TYPE.
Optional argument TAGS is a list of tags to search.
Return a list of tags."
diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el
index d23aebfc754..839dcb8172d 100644
--- a/lisp/cedet/semantic/db-mode.el
+++ b/lisp/cedet/semantic/db-mode.el
@@ -1,4 +1,4 @@
-;;; semantic/db-mode.el --- Semanticdb Minor Mode
+;;; semantic/db-mode.el --- Semanticdb Minor Mode -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -69,10 +69,6 @@ database, which can be saved for future Emacs sessions."
(dolist (elt semanticdb-hooks)
(remove-hook (cadr elt) (car elt)))))
-(semantic-varalias-obsolete 'semanticdb-mode-hooks
- 'global-semanticdb-minor-mode-hook "23.2")
-
-
(defun semanticdb-toggle-global-mode ()
"Toggle use of the Semantic Database feature.
Update the environment of Semantic enabled buffers accordingly."
diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el
index da09f9830a7..10108d39772 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
+;;; semantic/db-ref.el --- Handle cross-db file references -*- lexical-binding: t; -*-
-;;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -67,7 +67,7 @@ will be added to the database that INCLUDE-TAG refers to."
(object-add-to-list refdbt 'db-refs dbt)
t)))
-(cl-defmethod semanticdb-check-references ((dbt semanticdb-abstract-table))
+(cl-defmethod semanticdb-check-references ((_dbt semanticdb-abstract-table))
"Check and cleanup references in the database DBT.
Abstract tables would be difficult to reference."
;; Not sure how an abstract table can have references.
@@ -109,7 +109,7 @@ refers to DBT will be removed."
))
(setq refs (cdr refs)))))
-(cl-defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table))
+(cl-defmethod semanticdb-refresh-references ((_dbt semanticdb-abstract-table))
"Refresh references to DBT in other files."
;; alternate tables can't be edited, so can't be changed.
nil
diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el
index 139759a6dd1..c0fee3b2bd9 100644
--- a/lisp/cedet/semantic/db-typecache.el
+++ b/lisp/cedet/semantic/db-typecache.el
@@ -1,4 +1,4 @@
-;;; semantic/db-typecache.el --- Manage Datatypes
+;;; semantic/db-typecache.el --- Manage Datatypes -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -74,14 +74,14 @@ Said object must support `semantic-reset' methods.")
(oset tc stream nil)
- (mapc 'semantic-reset (oref tc dependants))
+ (mapc #'semantic-reset (oref tc dependants))
(oset tc dependants nil)
)
(cl-defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
"Do a reset from a notify from a table we depend on."
(oset tc includestream nil)
- (mapc 'semantic-reset (oref tc dependants))
+ (mapc #'semantic-reset (oref tc dependants))
(oset tc dependants nil)
)
@@ -90,7 +90,7 @@ Said object must support `semantic-reset' methods.")
"Reset the typecache based on a partial reparse."
(when (semantic-find-tags-by-class 'include new-tags)
(oset tc includestream nil)
- (mapc 'semantic-reset (oref tc dependants))
+ (mapc #'semantic-reset (oref tc dependants))
(oset tc dependants nil)
)
@@ -167,15 +167,15 @@ If there is no table, create one, and fill it in."
(oset tc stream nil)
)
-(cl-defmethod semanticdb-synchronize ((cache semanticdb-database-typecache)
- new-tags)
+(cl-defmethod semanticdb-synchronize ((_cache semanticdb-database-typecache)
+ _new-tags)
"Synchronize a CACHE with some NEW-TAGS."
- )
+ nil)
-(cl-defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache)
- new-tags)
+(cl-defmethod semanticdb-partial-synchronize ((_cache semanticdb-database-typecache)
+ _new-tags)
"Synchronize a CACHE with some changed NEW-TAGS."
- )
+ nil)
(cl-defmethod semanticdb-get-typecache ((db semanticdb-project-database))
"Retrieve the typecache from the semantic database DB.
@@ -312,7 +312,7 @@ If TAG has fully qualified names, expand it to a series of nested
namespaces instead."
tag)
-(cl-defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table))
+(cl-defmethod semanticdb-typecache-file-tags ((_table semanticdb-abstract-table))
"No tags available from non-file based tables."
nil)
@@ -338,12 +338,12 @@ all included files."
(oref cache filestream)
))
-(cl-defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table))
+(cl-defmethod semanticdb-typecache-include-tags ((_table semanticdb-abstract-table))
"No tags available from non-file based tables."
nil)
(cl-defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
- "Update the typecache for TABLE, and return the merged types from the include tags.
+ "Update typecache for TABLE, and return the merged types from the include tags.
Include-tags are the tags brought in via includes, all merged together into
a master list."
(let* ((cache (semanticdb-get-typecache table))
@@ -611,7 +611,7 @@ If there isn't one, create it.
(require 'data-debug)
(let* ((tab semanticdb-current-table)
(idx (semanticdb-get-table-index tab))
- (junk (oset idx type-cache nil)) ;; flush!
+ (_ (oset idx type-cache nil)) ;; flush!
(start (current-time))
(tc (semanticdb-typecache-for-database (oref tab parent-db)))
(end (current-time))
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 2f9729d7e2e..38e2b34b0db 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -50,27 +50,23 @@
(defvar semanticdb-database-list nil
"List of all active databases.")
-(defvar semanticdb-new-database-class 'semanticdb-project-database-file
+(defvar-local semanticdb-new-database-class 'semanticdb-project-database-file
"The default type of database created for new files.
This can be changed on a per file basis, so that some directories
are saved using one mechanism, and some directories via a different
mechanism.")
-(make-variable-buffer-local 'semanticdb-new-database-class)
-(defvar semanticdb-default-find-index-class 'semanticdb-find-search-index
+(defvar-local semanticdb-default-find-index-class 'semanticdb-find-search-index
"The default type of search index to use for a `semanticdb-table's.
This can be changed to try out new types of search indices.")
-(make-variable-buffer-local 'semanticdb-default-find=index-class)
;;;###autoload
-(defvar semanticdb-current-database nil
+(defvar-local semanticdb-current-database nil
"For a given buffer, this is the currently active database.")
-(make-variable-buffer-local 'semanticdb-current-database)
;;;###autoload
-(defvar semanticdb-current-table nil
+(defvar-local semanticdb-current-table nil
"For a given buffer, this is the currently active database table.")
-(make-variable-buffer-local 'semanticdb-current-table)
;;; ABSTRACT CLASSES
;;
@@ -89,7 +85,7 @@ same major mode as the current buffer.")
:documentation "The tags belonging to this table.")
(db-refs :initform nil
:documentation
- "List of `semanticdb-table' objects refering to this one.
+ "List of `semanticdb-table' objects referring to this one.
These aren't saved, but are instead recalculated after load.
See the file semanticdb-ref.el for how this slot is used.")
(index :type semanticdb-abstract-search-index
@@ -325,12 +321,12 @@ Adds the number of tags in this file to the object print name."
'(list-of semanticdb-abstract-table))
(defclass semanticdb-project-database (eieio-instance-tracker)
- ((tracking-symbol :initform semanticdb-database-list)
+ ((tracking-symbol :initform 'semanticdb-database-list)
(reference-directory :type string
:documentation "Directory this database refers to.
When a cache directory is specified, then this refers to the directory
this database contains symbols for.")
- (new-table-class :initform semanticdb-table
+ (new-table-class :initform 'semanticdb-table
:type class
:documentation
"New tables created for this database are of this class.")
@@ -764,7 +760,7 @@ If a particular major mode wants to search any mode, put the
Do not set the value of this variable permanently.")
(defmacro semanticdb-with-match-any-mode (&rest body)
- "A Semanticdb search occurring withing BODY will search tags in all modes.
+ "A Semanticdb search occurring within BODY will search tags in all modes.
This temporarily sets `semanticdb-match-any-mode' while executing BODY."
(declare (indent 0) (debug t))
`(let ((semanticdb-match-any-mode t))
@@ -825,13 +821,12 @@ must return a string, (the root directory) or a list of strings (multiple
root directories in a more complex system). This variable should be used
by project management programs like EDE or JDE.")
-(defvar semanticdb-project-system-databases nil
+(defvar-local semanticdb-project-system-databases nil
"List of databases containing system library information.
Mode authors can create their own system databases which know
detailed information about the system libraries for querying purposes.
Put those into this variable as a buffer-local, or mode-local
value.")
-(make-variable-buffer-local 'semanticdb-project-system-databases)
(defvar semanticdb-search-system-databases t
"Non-nil if search routines are to include a system database.")
@@ -1016,10 +1011,9 @@ DONTLOAD does not affect the creation of new database objects."
)
)))
-(defvar semanticdb-out-of-buffer-create-table-fcn nil
+(defvar-local semanticdb-out-of-buffer-create-table-fcn nil
"When non-nil, a function for creating a semanticdb table.
This should take a filename to be parsed.")
-(make-variable-buffer-local 'semanticdb-out-of-buffer-create-table-fcn)
(defun semanticdb-create-table-for-file-not-in-buffer (filename)
"Create a table for the file FILENAME.
diff --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el
index b3e8f076d07..4f96746166b 100644
--- a/lisp/cedet/semantic/debug.el
+++ b/lisp/cedet/semantic/debug.el
@@ -1,4 +1,4 @@
-;;; semantic/debug.el --- Language Debugger framework
+;;; semantic/debug.el --- Language Debugger framework -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2005, 2008-2021 Free Software Foundation, Inc.
@@ -44,24 +44,18 @@
;;; Code:
;;;###autoload
-(defvar semantic-debug-parser-source nil
+(defvar-local semantic-debug-parser-source nil
"For any buffer, the file name (no path) of the parser.
This would be a parser for a specific language, not the source
to one of the parser generators.")
-;;;###autoload
-(make-variable-buffer-local 'semantic-debug-parser-source)
;;;###autoload
-(defvar semantic-debug-parser-class nil
+(defvar-local semantic-debug-parser-class nil
"Class to create when building a debug parser object.")
-;;;###autoload
-(make-variable-buffer-local 'semantic-debug-parser-class)
;;;###autoload
-(defvar semantic-debug-parser-debugger-source nil
+(defvar-local semantic-debug-parser-debugger-source nil
"Location of the debug parser class.")
-;;;###autoload
-(make-variable-buffer-local 'semantic-debug-parser-source)
(defvar semantic-debug-enabled nil
"Non-nil when debugging a parser.")
@@ -271,12 +265,12 @@ on different types of return values."
)
"One frame representation.")
-(cl-defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame))
+(cl-defmethod semantic-debug-frame-highlight ((_frame semantic-debug-frame))
"Highlight one parser frame."
)
-(cl-defmethod semantic-debug-frame-info ((frame semantic-debug-frame))
+(cl-defmethod semantic-debug-frame-info ((_frame semantic-debug-frame))
"Display info about this one parser frame."
)
@@ -285,21 +279,21 @@ on different types of return values."
;;
(defvar semantic-debug-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km "n" 'semantic-debug-next)
- (define-key km " " 'semantic-debug-next)
- (define-key km "s" 'semantic-debug-step)
- (define-key km "u" 'semantic-debug-up)
- (define-key km "d" 'semantic-debug-down)
- (define-key km "f" 'semantic-debug-fail-match)
- (define-key km "h" 'semantic-debug-print-state)
- (define-key km "s" 'semantic-debug-jump-to-source)
- (define-key km "p" 'semantic-debug-jump-to-parser)
- (define-key km "q" 'semantic-debug-quit)
- (define-key km "a" 'semantic-debug-abort)
- (define-key km "g" 'semantic-debug-go)
- (define-key km "b" 'semantic-debug-set-breakpoint)
+ (define-key km "n" #'semantic-debug-next)
+ (define-key km " " #'semantic-debug-next)
+ (define-key km "s" #'semantic-debug-step)
+ (define-key km "u" #'semantic-debug-up)
+ (define-key km "d" #'semantic-debug-down)
+ (define-key km "f" #'semantic-debug-fail-match)
+ (define-key km "h" #'semantic-debug-print-state)
+ (define-key km "s" #'semantic-debug-jump-to-source)
+ (define-key km "p" #'semantic-debug-jump-to-parser)
+ (define-key km "q" #'semantic-debug-quit)
+ (define-key km "a" #'semantic-debug-abort)
+ (define-key km "g" #'semantic-debug-go)
+ (define-key km "b" #'semantic-debug-set-breakpoint)
;; Some boring bindings.
- (define-key km "e" 'eval-expression)
+ (define-key km "e" #'eval-expression)
km)
"Keymap used when in semantic-debug-node.")
@@ -520,49 +514,49 @@ by overriding one of the command methods. Be sure to use
down to your parser later."
:abstract t)
-(cl-defmethod semantic-debug-parser-next ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-next ((_parser semantic-debug-parser))
"Execute next for this PARSER."
(setq semantic-debug-user-command 'next)
)
-(cl-defmethod semantic-debug-parser-step ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-step ((_parser semantic-debug-parser))
"Execute a step for this PARSER."
(setq semantic-debug-user-command 'step)
)
-(cl-defmethod semantic-debug-parser-go ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-go ((_parser semantic-debug-parser))
"Continue execution in this PARSER until the next breakpoint."
(setq semantic-debug-user-command 'go)
)
-(cl-defmethod semantic-debug-parser-fail ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-fail ((_parser semantic-debug-parser))
"Continue execution in this PARSER until the next breakpoint."
(setq semantic-debug-user-command 'fail)
)
-(cl-defmethod semantic-debug-parser-quit ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-quit ((_parser semantic-debug-parser))
"Continue execution in this PARSER until the next breakpoint."
(setq semantic-debug-user-command 'quit)
)
-(cl-defmethod semantic-debug-parser-abort ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-abort ((_parser semantic-debug-parser))
"Continue execution in this PARSER until the next breakpoint."
(setq semantic-debug-user-command 'abort)
)
-(cl-defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-print-state ((_parser semantic-debug-parser))
"Print state for this PARSER at the current breakpoint."
(with-slots (current-frame) semantic-debug-current-interface
(when current-frame
(semantic-debug-frame-info current-frame)
)))
-(cl-defmethod semantic-debug-parser-break ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-break ((_parser semantic-debug-parser))
"Set a breakpoint for this PARSER."
)
;; Stack stuff
-(cl-defmethod semantic-debug-parser-frames ((parser semantic-debug-parser))
+(cl-defmethod semantic-debug-parser-frames ((_parser semantic-debug-parser))
"Return a list of frames for the current parser.
A frame is of the form:
( .. .what ? .. )
diff --git a/lisp/cedet/semantic/decorate.el b/lisp/cedet/semantic/decorate.el
index 53c54ab4cc8..3e6651df152 100644
--- a/lisp/cedet/semantic/decorate.el
+++ b/lisp/cedet/semantic/decorate.el
@@ -1,7 +1,6 @@
-;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
+;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. -*- lexical-binding: t; -*-
-;;; Copyright (C) 1999-2003, 2005-2007, 2009-2021 Free Software
-;;; Foundation, Inc.
+;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -51,7 +50,7 @@ Optional FACE specifies the face to use."
))
;;; Momentary Highlighting - One line
-(defun semantic-momentary-highlight-one-tag-line (tag &optional face)
+(defun semantic-momentary-highlight-one-tag-line (tag &optional _face)
"Highlight the first line of TAG, unhighlighting before next command.
Optional argument FACE specifies the face to do the highlighting."
(save-excursion
@@ -88,7 +87,7 @@ If VISIBLE is non-nil, make the text visible."
(overlay-get (semantic-tag-overlay tag) 'invisible))
(defun semantic-overlay-signal-read-only
- (overlay after start end &optional len)
+ (overlay after start end &optional _len)
"Hook used in modification hooks to prevent modification.
Allows deletion of the entire text.
Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
@@ -261,7 +260,7 @@ nil implies the tag should be fully shown."
(declare-function semantic-current-tag "semantic/find")
-(defun semantic-set-tag-folded-isearch (overlay)
+(defun semantic-set-tag-folded-isearch (_overlay)
"Called by isearch if it discovers text in the folded region.
OVERLAY is passed in by isearch."
(semantic-set-tag-folded (semantic-current-tag) nil)
diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el
index ee7fad1fc5f..a3bf4e252f7 100644
--- a/lisp/cedet/semantic/decorate/include.el
+++ b/lisp/cedet/semantic/decorate/include.el
@@ -1,4 +1,4 @@
-;;; semantic/decorate/include.el --- Decoration modes for include statements
+;;; semantic/decorate/include.el --- Decoration modes for include statements -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@ Used by the decoration style: `semantic-decoration-on-includes'."
(defvar semantic-decoration-on-include-map
(let ((km (make-sparse-keymap)))
- (define-key km semantic-decoration-mouse-3 'semantic-decoration-include-menu)
+ (define-key km semantic-decoration-mouse-3 #'semantic-decoration-include-menu)
km)
"Keymap used on includes.")
@@ -114,7 +114,7 @@ Used by the decoration style: `semantic-decoration-on-unknown-includes'."
(defvar semantic-decoration-on-unknown-include-map
(let ((km (make-sparse-keymap)))
;(define-key km [ mouse-2 ] 'semantic-decoration-unknown-include-describe)
- (define-key km semantic-decoration-mouse-3 'semantic-decoration-unknown-include-menu)
+ (define-key km semantic-decoration-mouse-3 #'semantic-decoration-unknown-include-menu)
km)
"Keymap used on unparsed includes.")
@@ -169,7 +169,7 @@ Used by the decoration style: `semantic-decoration-on-fileless-includes'."
(defvar semantic-decoration-on-fileless-include-map
(let ((km (make-sparse-keymap)))
;(define-key km [ mouse-2 ] 'semantic-decoration-fileless-include-describe)
- (define-key km semantic-decoration-mouse-3 'semantic-decoration-fileless-include-menu)
+ (define-key km semantic-decoration-mouse-3 #'semantic-decoration-fileless-include-menu)
km)
"Keymap used on unparsed includes.")
@@ -223,7 +223,7 @@ Used by the decoration style: `semantic-decoration-on-unparsed-includes'."
(defvar semantic-decoration-on-unparsed-include-map
(let ((km (make-sparse-keymap)))
- (define-key km semantic-decoration-mouse-3 'semantic-decoration-unparsed-include-menu)
+ (define-key km semantic-decoration-mouse-3 #'semantic-decoration-unparsed-include-menu)
km)
"Keymap used on unparsed includes.")
@@ -535,7 +535,7 @@ Argument EVENT is the mouse clicked event."
(interactive)
(let* ((tag (semantic-current-tag))
(table (semanticdb-find-table-for-include tag (current-buffer)))
- (mm major-mode))
+ ) ;; (mm major-mode)
(with-output-to-temp-buffer (help-buffer) ; "*Help*"
(help-setup-xref (list #'semantic-decoration-fileless-include-describe)
(called-interactively-p 'interactive))
@@ -793,7 +793,7 @@ any decorated referring includes.")
(let ((table (oref obj table)))
;; This is a hack. Add in something better?
(semanticdb-notify-references
- table (lambda (tab me)
+ table (lambda (tab _me)
(semantic-decoration-unparsed-include-refrence-reset tab)
))
))
@@ -805,7 +805,7 @@ any decorated referring includes.")
(semantic-reset cache)))
(cl-defmethod semanticdb-synchronize ((cache semantic-decoration-unparsed-include-cache)
- new-tags)
+ _new-tags)
"Synchronize a CACHE with some NEW-TAGS."
(semantic-reset cache))
diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el
index 0d4b1dc275f..c6bf15205fd 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -1,4 +1,4 @@
-;;; semantic/decorate/mode.el --- Minor mode for decorating tags
+;;; semantic/decorate/mode.el --- Minor mode for decorating tags -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2005, 2007-2021 Free Software Foundation, Inc.
@@ -204,9 +204,6 @@ Also make sure old decorations in the area are completely flushed."
(defvar semantic-decorate-pending-decoration-hook nil
"Normal hook run to perform pending decoration changes.")
-(semantic-varalias-obsolete 'semantic-decorate-pending-decoration-hooks
- 'semantic-decorate-pending-decoration-hook "23.2")
-
(defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
"Add a pending decoration change represented by FCN.
Applies only to the current BUFFER.
@@ -257,7 +254,7 @@ 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
+ :lighter nil
(if semantic-decoration-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -267,9 +264,9 @@ non-nil if the minor mode is enabled."
(buffer-name)))
;; Add hooks
(add-hook 'semantic-after-partial-cache-change-hook
- 'semantic-decorate-tags-after-partial-reparse nil t)
+ #'semantic-decorate-tags-after-partial-reparse nil t)
(add-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-decorate-tags-after-full-reparse nil t)
+ #'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.
;; However, don't do this immediately, because EDE will be
@@ -285,9 +282,9 @@ non-nil if the minor mode is enabled."
(semantic-decorate-flush-decorations)
;; Remove hooks
(remove-hook 'semantic-after-partial-cache-change-hook
- 'semantic-decorate-tags-after-partial-reparse t)
+ #'semantic-decorate-tags-after-partial-reparse t)
(remove-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-decorate-tags-after-full-reparse t)))
+ #'semantic-decorate-tags-after-full-reparse t)))
(semantic-add-minor-mode 'semantic-decoration-mode
"")
@@ -353,20 +350,18 @@ Return non-nil if the decoration style is enabled."
(defun semantic-decoration-build-style-menu (style)
"Build a menu item for controlling a specific decoration STYLE."
- (vector (car style)
- `(lambda () (interactive)
- (semantic-toggle-decoration-style
- ,(car style)))
- :style 'toggle
- :selected `(semantic-decoration-style-enabled-p ,(car style))
- ))
-
-(defun semantic-build-decoration-mode-menu (&rest ignore)
+ (let ((s (car style)))
+ (vector s
+ (lambda () (interactive) (semantic-toggle-decoration-style s))
+ :style 'toggle
+ :selected `(semantic-decoration-style-enabled-p ',s))))
+
+(defun semantic-build-decoration-mode-menu (&rest _ignore)
"Create a menu listing all the known decorations for toggling.
IGNORE any input arguments."
(or semantic-decoration-menu-cache
(setq semantic-decoration-menu-cache
- (mapcar 'semantic-decoration-build-style-menu
+ (mapcar #'semantic-decoration-build-style-menu
(reverse semantic-decoration-styles))
)))
diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el
index 4087eb4799c..efebe21a945 100644
--- a/lisp/cedet/semantic/dep.el
+++ b/lisp/cedet/semantic/dep.el
@@ -1,4 +1,4 @@
-;;; semantic/dep.el --- Methods for tracking dependencies (include files)
+;;; semantic/dep.el --- Methods for tracking dependencies (include files) -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -39,7 +39,7 @@
;;; Code:
-(defvar semantic-dependency-include-path nil
+(defvar-local semantic-dependency-include-path nil
"Defines the include path used when searching for files.
This should be a list of directories to search which is specific
to the file being included.
@@ -56,9 +56,8 @@ reparsed, the cache will be reset.
TODO: use ffap.el to locate such items?
NOTE: Obsolete this, or use as special user")
-(make-variable-buffer-local 'semantic-dependency-include-path)
-(defvar semantic-dependency-system-include-path nil
+(defvar-local semantic-dependency-system-include-path nil
"Defines the system include path.
This should be set with either `defvar-mode-local', or with
`semantic-add-system-include'.
@@ -71,7 +70,6 @@ When searching for a file associated with a name found in a tag of
class include, this path will be inspected for includes of type
`system'. Some include tags are agnostic to this setting and will
check both the project and system directories.")
-(make-variable-buffer-local 'semantic-dependency-system-include-path)
(defmacro defcustom-mode-local-semantic-dependency-system-include-path
(mode name value &optional docstring)
@@ -125,12 +123,12 @@ Changes made by this function are not persistent."
(if (not mode) (setq mode major-mode))
(let ((dirtmp (file-name-as-directory dir))
(value
- (mode-local-value mode 'semantic-dependency-system-include-path))
- )
- (add-to-list 'value dirtmp t)
+ (mode-local-value mode 'semantic-dependency-system-include-path)))
(eval `(setq-mode-local ,mode
- semantic-dependency-system-include-path value))
- ))
+ semantic-dependency-system-include-path
+ ',(if (member dirtmp value) value
+ (append value (list dirtmp))))
+ t)))
;;;###autoload
(defun semantic-remove-system-include (dir &optional mode)
@@ -148,10 +146,10 @@ Changes made by this function are not persistent."
(value
(mode-local-value mode 'semantic-dependency-system-include-path))
)
- (setq value (delete dirtmp value))
+ (setq value (remove dirtmp value))
(eval `(setq-mode-local ,mode semantic-dependency-system-include-path
- value))
- ))
+ ',value)
+ t)))
;;;###autoload
(defun semantic-reset-system-include (&optional mode)
@@ -159,10 +157,10 @@ Changes made by this function are not persistent."
Modifies a mode-local version of
`semantic-dependency-system-include-path'."
(interactive)
- (if (not mode) (setq mode major-mode))
- (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
- nil))
- )
+ (eval `(setq-mode-local ,(or mode major-mode)
+ semantic-dependency-system-include-path
+ nil)
+ t))
;;;###autoload
(defun semantic-customize-system-include-path (&optional mode)
@@ -183,16 +181,8 @@ macro `defcustom-mode-local-semantic-dependency-system-include-path'."
;;
;; methods for finding files on a provided path.
(defmacro semantic--dependency-find-file-on-path (file path)
- (if (fboundp 'locate-file)
- `(locate-file ,file ,path)
- `(let ((p ,path)
- (found nil))
- (while (and p (not found))
- (let ((f (expand-file-name ,file (car p))))
- (if (file-exists-p f)
- (setq found f)))
- (setq p (cdr p)))
- found)))
+ (declare (obsolete locate-file "28.1"))
+ `(locate-file ,file ,path))
(defvar ede-minor-mode)
(defvar ede-object)
@@ -216,11 +206,11 @@ provided mode, not from the current major mode."
(when (file-exists-p file)
(setq found file))
(when (and (not found) (not systemp))
- (setq found (semantic--dependency-find-file-on-path file locp)))
+ (setq found (locate-file file locp)))
(when (and (not found) edesys)
- (setq found (semantic--dependency-find-file-on-path file edesys)))
+ (setq found (locate-file file edesys)))
(when (not found)
- (setq found (semantic--dependency-find-file-on-path file sysp)))
+ (setq found (locate-file file sysp)))
(if found (expand-file-name found))))
diff --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el
index 951bd853f9e..413ed83a154 100644
--- a/lisp/cedet/semantic/doc.el
+++ b/lisp/cedet/semantic/doc.el
@@ -1,4 +1,4 @@
-;;; semantic/doc.el --- Routines for documentation strings
+;;; semantic/doc.el --- Routines for documentation strings -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2003, 2005, 2008-2021 Free Software Foundation,
;; Inc.
@@ -40,7 +40,7 @@ TAG might have DOCUMENTATION set in it already. If not, there may be
some documentation in a comment preceding TAG's definition which we
can look for. When appropriate, this can be overridden by a language specific
enhancement.
-Optional argument NOSNARF means to only return the lexical analyzer token for it.
+Optional argument NOSNARF means return only the lexical analyzer token for it.
If NOSNARF is `lex', then only return the lex token."
(if (not tag) (setq tag (semantic-current-tag)))
(save-excursion
@@ -85,7 +85,7 @@ just the lexical token and not the string."
))
(define-obsolete-function-alias
'semantic-documentation-comment-preceeding-tag
- 'semantic-documentation-comment-preceding-tag
+ #'semantic-documentation-comment-preceding-tag
"25.1")
(defun semantic-doc-snarf-comment-for-tag (nosnarf)
@@ -93,8 +93,7 @@ just the lexical token and not the string."
Attempt to strip out comment syntactic sugar.
Argument NOSNARF means don't modify the found text.
If NOSNARF is `lex', then return the lex token."
- (let* ((semantic-ignore-comments nil)
- (semantic-lex-analyzer #'semantic-comment-lexer))
+ (let* ((semantic-lex-analyzer #'semantic-comment-lexer))
(if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility
(car (semantic-lex (point) (1+ (point))))
(let ((ct (semantic-lex-token-text
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index 89b7f9f4b91..19d4184fa45 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -1,4 +1,4 @@
-;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
+;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2004, 2007-2021 Free Software Foundation, Inc.
@@ -30,6 +30,7 @@
(require 'ede/pconf)
(require 'ede/proj-elisp)
(require 'semantic/grammar)
+(eval-when-compile (require 'cl-lib))
;;; Code:
(defclass semantic-ede-proj-target-grammar (ede-proj-target-elisp)
@@ -37,13 +38,13 @@
(keybindings :initform nil)
(phony :initform t)
(sourcetype :initform
- (semantic-ede-source-grammar-wisent
- semantic-ede-source-grammar-bovine
- ))
+ '(semantic-ede-source-grammar-wisent
+ semantic-ede-source-grammar-bovine
+ ))
(availablecompilers :initform
- (semantic-ede-grammar-compiler-wisent
- semantic-ede-grammar-compiler-bovine
- ))
+ '(semantic-ede-grammar-compiler-wisent
+ semantic-ede-grammar-compiler-bovine
+ ))
(aux-packages :initform '("semantic" "cedet-compat"))
(pre-load-packages :initform '("cedet-compat" "semantic/grammar" "semantic/bovine/grammar" "semantic/wisent/grammar"))
)
@@ -118,7 +119,7 @@ For Emacs Lisp, return addsuffix command on source files."
"Compile Emacs Lisp programs.")
;;; Target options.
-(cl-defmethod ede-buffer-mine ((this semantic-ede-proj-target-grammar) buffer)
+(cl-defmethod ede-buffer-mine ((_this semantic-ede-proj-target-grammar) buffer)
"Return t if object THIS lays claim to the file in BUFFER.
Lays claim to all -by.el, and -wy.el files."
;; We need to be a little more careful than this, but at the moment it
@@ -130,7 +131,7 @@ Lays claim to all -by.el, and -wy.el files."
(cl-defmethod project-compile-target ((obj semantic-ede-proj-target-grammar))
"Compile all sources in a Lisp target OBJ."
- (let* ((cb (current-buffer))
+ (let* (;; (cb (current-buffer))
(proj (ede-target-parent obj))
(default-directory (oref proj directory))
(comp 0)
@@ -141,20 +142,10 @@ Lays claim to all -by.el, and -wy.el files."
(fname (progn (string-match ".*/\\(.+\\.el\\)" package)
(match-string 1 package)))
(src (ede-expand-filename obj fname))
- (csrc (concat (file-name-sans-extension src) ".elc")))
- (if (< emacs-major-version 24)
- ;; Does not have `byte-recompile-file'
- (if (or (not (file-exists-p csrc))
- (file-newer-than-file-p src csrc))
- (progn
- (setq comp (1+ comp))
- (byte-compile-file src))
- (setq utd (1+ utd)))
- ;; Emacs 24 and newer
- (with-no-warnings
- (if (eq (byte-recompile-file src nil 0) t)
- (setq comp (1+ comp))
- (setq utd (1+ utd))))))))
+ ;; (csrc (concat (file-name-sans-extension src) ".elc"))
+ )
+ (cl-incf (if (eq (byte-recompile-file src nil 0) t)
+ comp utd)))))
(oref obj source))
(message "All Semantic Grammar sources are up to date in %s" (eieio-object-name obj))
(cons comp utd)))
@@ -171,10 +162,9 @@ Lays claim to all -by.el, and -wy.el files."
"Insert variables needed by target THIS."
(ede-proj-makefile-insert-loadpath-items
(ede-proj-elisp-packages-to-loadpath
- (list "eieio" "semantic" "inversion" "ede")))
+ (list "eieio" "semantic" "ede")))
;; eieio for object system needed in ede
;; semantic because it is
- ;; Inversion for versioning system.
;; ede for project regeneration
(ede-pmake-insert-variable-shared
(concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
@@ -183,8 +173,7 @@ Lays claim to all -by.el, and -wy.el files."
(with-current-buffer (find-file-noselect src)
(concat (semantic-grammar-package) ".el")))
(oref this source)
- " ")))
- )
+ " "))))
(cl-defmethod ede-proj-makefile-insert-rules :after ((this semantic-ede-proj-target-grammar))
"Insert rules needed by THIS target.
diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el
index c11b451f213..b2e56360cf7 100644
--- a/lisp/cedet/semantic/edit.el
+++ b/lisp/cedet/semantic/edit.el
@@ -1,4 +1,4 @@
-;;; semantic/edit.el --- Edit Management for Semantic
+;;; semantic/edit.el --- Edit Management for Semantic -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -121,9 +121,6 @@ incremental reparse.")
"Hook run after the incremental parser fails.
When this happens, the buffer is marked as needing a full reparse.")
-(semantic-varalias-obsolete 'semantic-edits-incremental-reparse-failed-hooks
- 'semantic-edits-incremental-reparse-failed-hook "23.2")
-
(defcustom semantic-edits-verbose-flag nil
"Non-nil means the incremental parser is verbose.
If nil, errors are still displayed, but informative messages are not."
@@ -157,10 +154,10 @@ Optional argument BUFFER is the buffer to search for changes in."
(when (overlay-get (car ol) 'semantic-change)
(setq ret (cons (car ol) ret)))
(setq ol (cdr ol)))
- (sort ret #'(lambda (a b) (< (overlay-start a)
- (overlay-start b)))))))
+ (sort ret (lambda (a b) (< (overlay-start a)
+ (overlay-start b)))))))
-(defun semantic-edits-change-function-handle-changes (start end length)
+(defun semantic-edits-change-function-handle-changes (start end _length)
"Run whenever a buffer controlled by `semantic-mode' change.
Tracks when and how the buffer is re-parsed.
Argument START, END, and LENGTH specify the bounds of the change."
@@ -359,7 +356,7 @@ See `semantic-edits-change-leaf-tag' for details on parents."
start end)))
(parent nil)
(overlapped-tags nil)
- inner-start inner-end
+ inner-end ;; inner-start
(list-to-search nil))
;; By the time this is already called, we know that it is
;; not a leaf change, nor a between tag change. That leaves
@@ -373,7 +370,7 @@ See `semantic-edits-change-leaf-tag' for details on parents."
(progn
;; We encompass one whole change.
(setq overlapped-tags (list (car tags))
- inner-start (semantic-tag-start (car tags))
+ ;; inner-start (semantic-tag-start (car tags))
inner-end (semantic-tag-end (car tags))
tags (cdr tags))
;; Keep looping while tags are inside the change.
@@ -389,13 +386,14 @@ See `semantic-edits-change-leaf-tag' for details on parents."
;; This is a parent. Drop the children found
;; so far.
(setq overlapped-tags (list (car tags))
- inner-start (semantic-tag-start (car tags))
+ ;; inner-start (semantic-tag-start (car tags))
inner-end (semantic-tag-end (car tags))
)
;; It is not a parent encompassing tag
(setq overlapped-tags (cons (car tags)
overlapped-tags)
- inner-start (semantic-tag-start (car tags))))
+ ;; inner-start (semantic-tag-start (car tags))
+ ))
(setq tags (cdr tags)))
(if (not tags)
;; There are no tags left, and all tags originally
@@ -536,6 +534,7 @@ This function is for internal use by `semantic-edits-incremental-parser'."
;query this when debugging to find
;source of bugs.
)
+ (ignore last-cond) ;; Don't warn about the var not being used.
(or changes
;; If we were called, and there are no changes, then we
;; don't know what to do. Force a full reparse.
@@ -831,8 +830,7 @@ This function is for internal use by `semantic-edits-incremental-parser'."
;; Make it the default changes parser
;;;###autoload
-(defalias 'semantic-parse-changes-default
- 'semantic-edits-incremental-parser)
+(defalias 'semantic-parse-changes-default #'semantic-edits-incremental-parser)
;;; Cache Splicing
;;
diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el
index 706892b4861..17fb20fa0a0 100644
--- a/lisp/cedet/semantic/find.el
+++ b/lisp/cedet/semantic/find.el
@@ -1,4 +1,4 @@
-;;; semantic/find.el --- Search routines for Semantic
+;;; semantic/find.el --- Search routines for Semantic -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2005, 2008-2021 Free Software Foundation, Inc.
@@ -583,7 +583,7 @@ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
)
(defun semantic-brute-find-tag-by-function
- (function streamorbuffer &optional search-parts search-includes)
+ (function streamorbuffer &optional search-parts _search-includes)
"Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER.
FUNCTION must return non-nil if an element of STREAM will be included
in the new list.
@@ -620,7 +620,7 @@ This parameter hasn't be active for a while and is obsolete."
nl))
(defun semantic-brute-find-first-tag-by-function
- (function streamorbuffer &optional search-parts search-includes)
+ (function streamorbuffer &optional _search-parts _search-includes)
"Find the first tag which FUNCTION match within STREAMORBUFFER.
FUNCTION must return non-nil if an element of STREAM will be included
in the new list.
diff --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el
index f079a3e6c48..a68ef8064d1 100644
--- a/lisp/cedet/semantic/format.el
+++ b/lisp/cedet/semantic/format.el
@@ -1,4 +1,4 @@
-;;; semantic/format.el --- Routines for formatting tags
+;;; semantic/format.el --- Routines for formatting tags -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
@@ -32,7 +32,6 @@
;;
;;; Code:
-(eval-when-compile (require 'font-lock))
(require 'semantic)
(require 'semantic/tag-ls)
(require 'ezimage)
@@ -79,13 +78,11 @@ Images can be used as icons instead of some types of text strings."
:group 'semantic
:type 'boolean)
-(defvar semantic-function-argument-separator ","
+(defvar-local semantic-function-argument-separator ","
"Text used to separate arguments when creating text from tags.")
-(make-variable-buffer-local 'semantic-function-argument-separator)
-(defvar semantic-format-parent-separator "::"
+(defvar-local semantic-format-parent-separator "::"
"Text used to separate names when between namespaces/classes and functions.")
-(make-variable-buffer-local 'semantic-format-parent-separator)
(defvar semantic-format-face-alist
`( (function . font-lock-function-name-face)
@@ -119,12 +116,10 @@ be used unless font lock is a feature.")
"Apply onto TEXT a color associated with FACE-CLASS.
FACE-CLASS is a tag type found in `semantic-format-face-alist'.
See that variable for details on adding new types."
- (if (featurep 'font-lock)
- (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
- (newtext (concat text)))
- (put-text-property 0 (length text) 'face face newtext)
- newtext)
- text))
+ (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
+ (newtext (concat text)))
+ (put-text-property 0 (length text) 'face face newtext)
+ newtext))
(defun semantic--format-colorize-merge-text (precoloredtext face-class)
"Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
@@ -167,7 +162,7 @@ COLOR specifies if color should be used."
(car args) nil color 'variable))
out)
(setq args (cdr args)))
- (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
+ (mapconcat #'identity (nreverse out) semantic-function-argument-separator)
))
;;; Data Type
@@ -205,7 +200,7 @@ Argument COLOR specifies to colorize the text."
;;; Abstract formatting functions
;;
-(defun semantic-format-tag-prin1 (tag &optional parent color)
+(defun semantic-format-tag-prin1 (tag &optional _parent _color)
"Convert TAG to a string that is the print name for TAG.
PARENT and COLOR are ignored."
(format "%S" tag))
@@ -242,7 +237,7 @@ The name is the shortest possible representation.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors.")
-(defun semantic-format-tag-name-default (tag &optional parent color)
+(defun semantic-format-tag-name-default (tag &optional _parent color)
"Return an abbreviated string describing TAG.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
@@ -505,7 +500,7 @@ Optional argument COLOR means highlight the prototype with font-lock colors."
args
(if (eq class 'type) "}" ")"))))
(when mods
- (setq mods (concat (mapconcat 'identity mods " ") " ")))
+ (setq mods (concat (mapconcat #'identity mods " ") " ")))
(concat (or mods "")
(if type (concat type " "))
name
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index e6952700102..4ad70ff7c64 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -1,6 +1,6 @@
-;;; semantic/fw.el --- Framework for Semantic
+;;; semantic/fw.el --- Framework for Semantic -*- lexical-binding: t; -*-
-;;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@@ -34,29 +34,29 @@
;;; Compatibility
;;
-(define-obsolete-function-alias 'semantic-overlay-live-p 'overlay-buffer "27.1")
-(define-obsolete-function-alias 'semantic-make-overlay 'make-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlay-put 'overlay-put "27.1")
-(define-obsolete-function-alias 'semantic-overlay-get 'overlay-get "27.1")
+(define-obsolete-function-alias 'semantic-overlay-live-p #'overlay-buffer "27.1")
+(define-obsolete-function-alias 'semantic-make-overlay #'make-overlay "27.1")
+(define-obsolete-function-alias 'semantic-overlay-put #'overlay-put "27.1")
+(define-obsolete-function-alias 'semantic-overlay-get #'overlay-get "27.1")
(define-obsolete-function-alias 'semantic-overlay-properties
- 'overlay-properties "27.1")
-(define-obsolete-function-alias 'semantic-overlay-move 'move-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlay-delete 'delete-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlays-at 'overlays-at "27.1")
-(define-obsolete-function-alias 'semantic-overlays-in 'overlays-in "27.1")
-(define-obsolete-function-alias 'semantic-overlay-buffer 'overlay-buffer "27.1")
-(define-obsolete-function-alias 'semantic-overlay-start 'overlay-start "27.1")
-(define-obsolete-function-alias 'semantic-overlay-end 'overlay-end "27.1")
+ #'overlay-properties "27.1")
+(define-obsolete-function-alias 'semantic-overlay-move #'move-overlay "27.1")
+(define-obsolete-function-alias 'semantic-overlay-delete #'delete-overlay "27.1")
+(define-obsolete-function-alias 'semantic-overlays-at #'overlays-at "27.1")
+(define-obsolete-function-alias 'semantic-overlays-in #'overlays-in "27.1")
+(define-obsolete-function-alias 'semantic-overlay-buffer #'overlay-buffer "27.1")
+(define-obsolete-function-alias 'semantic-overlay-start #'overlay-start "27.1")
+(define-obsolete-function-alias 'semantic-overlay-end #'overlay-end "27.1")
(define-obsolete-function-alias 'semantic-overlay-next-change
- 'next-overlay-change "27.1")
+ #'next-overlay-change "27.1")
(define-obsolete-function-alias 'semantic-overlay-previous-change
- 'previous-overlay-change "27.1")
-(define-obsolete-function-alias 'semantic-overlay-lists 'overlay-lists "27.1")
-(define-obsolete-function-alias 'semantic-overlay-p 'overlayp "27.1")
-(define-obsolete-function-alias 'semantic-read-event 'read-event "27.1")
-(define-obsolete-function-alias 'semantic-popup-menu 'popup-menu "27.1")
+ #'previous-overlay-change "27.1")
+(define-obsolete-function-alias 'semantic-overlay-lists #'overlay-lists "27.1")
+(define-obsolete-function-alias 'semantic-overlay-p #'overlayp "27.1")
+(define-obsolete-function-alias 'semantic-read-event #'read-event "27.1")
+(define-obsolete-function-alias 'semantic-popup-menu #'popup-menu "27.1")
(define-obsolete-function-alias 'semantic-buffer-local-value
- 'buffer-local-value "27.1")
+ #'buffer-local-value "27.1")
(defun semantic-event-window (event)
"Extract the window from EVENT."
@@ -68,13 +68,11 @@
;; Since Emacs 22 major mode functions should use `run-mode-hooks' to
;; run major mode hooks.
-(defalias 'semantic-run-mode-hooks
- (if (fboundp 'run-mode-hooks)
- 'run-mode-hooks
- 'run-hooks))
+(define-obsolete-function-alias 'semantic-run-mode-hooks #'run-mode-hooks "28.1")
- ;; Fancy compat usage now handled in cedet-compat
-(defalias 'semantic-subst-char-in-string 'subst-char-in-string)
+;; Fancy compat usage now handled in cedet-compat
+(define-obsolete-function-alias 'semantic-subst-char-in-string
+ #'subst-char-in-string "28.1")
(defun semantic-delete-overlay-maybe (overlay)
"Delete OVERLAY if it is a semantic token overlay."
@@ -113,7 +111,7 @@ Possible Lifespans are:
(setq semantic-cache-data-overlays
(cons o semantic-cache-data-overlays))
;;(message "Adding to cache: %s" o)
- (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook)
+ (add-hook 'post-command-hook #'semantic-cache-data-post-command-hook)
))
(defun semantic-cache-data-post-command-hook ()
@@ -139,7 +137,7 @@ Remove self from `post-command-hook' if it is empty."
;; Remove ourselves if we have removed all overlays.
(unless semantic-cache-data-overlays
(remove-hook 'post-command-hook
- 'semantic-cache-data-post-command-hook)))
+ #'semantic-cache-data-post-command-hook)))
(defun semantic-get-cache-data (name &optional point)
"Get cached data with NAME from optional POINT."
@@ -175,6 +173,7 @@ Remove self from `post-command-hook' if it is empty."
;;
(defun semantic-overload-symbol-from-function (name)
"Return the symbol for overload used by NAME, the defined symbol."
+ (declare (obsolete define-obsolete-function-alias "28.1"))
(let ((sym-name (symbol-name name)))
(if (string-match "^semantic-" sym-name)
(intern (substring sym-name (match-end 0)))
@@ -184,34 +183,34 @@ Remove self from `post-command-hook' if it is empty."
"Make OLDFNALIAS an alias for NEWFN.
Mark OLDFNALIAS as obsolete, such that the byte compiler
will throw a warning when it encounters this symbol."
+ (declare (obsolete define-obsolete-function-alias "28.1"))
(defalias oldfnalias newfn)
(make-obsolete oldfnalias newfn when)
(when (and (mode-local--function-overload-p newfn)
(not (mode-local--overload-obsoleted-by newfn))
;; Only throw this warning when byte compiling things.
- (boundp 'byte-compile-current-file)
- byte-compile-current-file
- (not (string-match "cedet" byte-compile-current-file))
+ (macroexp-compiling-p)
+ (not (string-match "cedet" (macroexp-file-name)))
)
(make-obsolete-overload oldfnalias newfn when)
(byte-compile-warn
"%s: `%s' obsoletes overload `%s'"
- byte-compile-current-file
+ (macroexp-file-name)
newfn
- (semantic-overload-symbol-from-function oldfnalias))
- ))
+ (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
+ (semantic-overload-symbol-from-function oldfnalias)))))
(defun semantic-varalias-obsolete (oldvaralias newvar when)
"Make OLDVARALIAS an alias for variable NEWVAR.
Mark OLDVARALIAS as obsolete, such that the byte compiler
will throw a warning when it encounters this symbol."
+ (declare (obsolete define-obsolete-variable-alias "28.1"))
(make-obsolete-variable oldvaralias newvar when)
(condition-case nil
(defvaralias oldvaralias newvar)
(error
;; Only throw this warning when byte compiling things.
- (when (and (boundp 'byte-compile-current-file)
- byte-compile-current-file)
+ (when (macroexp-compiling-p)
(byte-compile-warn
"variable `%s' obsoletes, but isn't alias of `%s'"
newvar oldvaralias)
@@ -242,9 +241,8 @@ Avoid using a large BODY since it is duplicated."
;;; Misc utilities
;;
-(defvar semantic-new-buffer-fcn-was-run nil
+(defvar-local semantic-new-buffer-fcn-was-run nil
"Non-nil after `semantic-new-buffer-fcn' has been executed.")
-(make-variable-buffer-local 'semantic-new-buffer-fcn-was-run)
(defsubst semantic-active-p ()
"Return non-nil if the current buffer was set up for parsing."
@@ -256,10 +254,7 @@ FUNCTION does not have arguments. When FUNCTION is entered
`current-buffer' is a selected Semantic enabled buffer."
(mode-local-map-file-buffers function #'semantic-active-p))
-(defalias 'semantic-map-mode-buffers 'mode-local-map-mode-buffers)
-
-(semantic-alias-obsolete 'define-mode-overload-implementation
- 'define-mode-local-override "23.2")
+(defalias 'semantic-map-mode-buffers #'mode-local-map-mode-buffers)
(defun semantic-install-function-overrides (overrides &optional transient)
"Install the function OVERRIDES in the specified environment.
@@ -275,11 +270,11 @@ later installation should be done in MODE hook."
(mode-local-bind
;; Add the semantic- prefix to OVERLOAD short names.
(mapcar
- #'(lambda (e)
- (let ((name (symbol-name (car e))))
- (if (string-match "^semantic-" name)
- e
- (cons (intern (format "semantic-%s" name)) (cdr e)))))
+ (lambda (e)
+ (let ((name (symbol-name (car e))))
+ (if (string-match "^semantic-" name)
+ e
+ (cons (intern (format "semantic-%s" name)) (cdr e)))))
overrides)
(list 'constant-flag (not transient)
'override-flag t)))
@@ -323,21 +318,17 @@ calling this one."
;;; Special versions of Find File
;;
+(defvar recentf-exclude)
+(defvar semantic-init-hook)
+(defvar ede-auto-add-method)
+(defvar flymake-start-syntax-check-on-find-file)
+(defvar auto-insert)
+
(defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards)
"Call `find-file-noselect' with various features turned off.
Use this when referencing a file that will be soon deleted.
FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'."
- ;; Hack -
- ;; Check if we are in set-auto-mode, and if so, warn about this.
- (when (boundp 'keep-mode-if-same)
- (let ((filename (or (and (boundp 'filename) filename)
- "(unknown)")))
- (message "WARNING: semantic-find-file-noselect called for \
-%s while in set-auto-mode for %s. You should call the responsible function \
-into `mode-local-init-hook'." file filename)
- (sit-for 1)))
-
- (let* ((recentf-exclude '( (lambda (f) t) ))
+ (let* ((recentf-exclude #'always)
;; This is a brave statement. Don't waste time loading in
;; lots of modes. Especially decoration mode can waste a lot
;; of time for a buffer we intend to kill.
@@ -398,13 +389,10 @@ into `mode-local-init-hook'." file filename)
;; "define-lex-regex-type-analyzer"
;; "define-lex-string-type-analyzer"
;; "define-lex-block-type-analyzer"
-;; ;;"define-mode-overload-implementation"
;; ;;"define-semantic-child-mode"
;; "define-semantic-idle-service"
;; "define-semantic-decoration-style"
;; "define-wisent-lexer"
-;; "semantic-alias-obsolete"
-;; "semantic-varalias-obsolete"
;; "semantic-make-obsolete-overload"
;; "defcustom-mode-local-semantic-dependency-system-include-path"
;; ))
diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el
deleted file mode 100644
index 12c9c047fc5..00000000000
--- a/lisp/cedet/semantic/grammar-wy.el
+++ /dev/null
@@ -1,496 +0,0 @@
-;;; semantic/grammar-wy.el --- Generated parser support file
-
-;; Copyright (C) 2002-2004, 2009-2021 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file was generated from admin/grammars/grammar.wy.
-
-;;; Code:
-
-(require 'semantic)
-
-;;; Prologue
-;;
-(defvar semantic-grammar-lex-c-char-re)
-
-;; Current parsed nonterminal name.
-(defvar semantic-grammar-wy--nterm nil)
-;; Index of rule in a nonterminal clause.
-(defvar semantic-grammar-wy--rindx nil)
-
-;;; Declarations
-;;
-(defconst semantic-grammar-wy--keyword-table
- (semantic-lex-make-keyword-table
- '(("%default-prec" . DEFAULT-PREC)
- ("%no-default-prec" . NO-DEFAULT-PREC)
- ("%keyword" . KEYWORD)
- ("%expectedconflicts" . EXPECTEDCONFLICTS)
- ("%languagemode" . LANGUAGEMODE)
- ("%left" . LEFT)
- ("%nonassoc" . NONASSOC)
- ("%package" . PACKAGE)
- ("%provide" . PROVIDE)
- ("%prec" . PREC)
- ("%put" . PUT)
- ("%quotemode" . QUOTEMODE)
- ("%right" . RIGHT)
- ("%scopestart" . SCOPESTART)
- ("%start" . START)
- ("%token" . TOKEN)
- ("%type" . TYPE)
- ("%use-macros" . USE-MACROS))
- 'nil)
- "Table of language keywords.")
-
-(defconst semantic-grammar-wy--token-table
- (semantic-lex-make-type-table
- '(("punctuation"
- (GT . ">")
- (LT . "<")
- (OR . "|")
- (SEMI . ";")
- (COLON . ":"))
- ("close-paren"
- (RBRACE . "}")
- (RPAREN . ")"))
- ("open-paren"
- (LBRACE . "{")
- (LPAREN . "("))
- ("block"
- (BRACE_BLOCK . "(LBRACE RBRACE)")
- (PAREN_BLOCK . "(LPAREN RPAREN)"))
- ("code"
- (EPILOGUE . "%%...EOF")
- (PROLOGUE . "%{...%}"))
- ("sexp"
- (SEXP))
- ("qlist"
- (PREFIXED_LIST))
- ("char"
- (CHARACTER))
- ("symbol"
- (PERCENT_PERCENT . "\\`%%\\'")
- (SYMBOL))
- ("string"
- (STRING)))
- '(("punctuation" :declared t)
- ("block" :declared t)
- ("sexp" matchdatatype sexp)
- ("sexp" syntax "\\=")
- ("sexp" :declared t)
- ("qlist" matchdatatype sexp)
- ("qlist" syntax "\\s'\\s-*(")
- ("qlist" :declared t)
- ("char" syntax semantic-grammar-lex-c-char-re)
- ("char" :declared t)
- ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
- ("symbol" :declared t)
- ("string" :declared t)
- ("keyword" :declared t)))
- "Table of lexical tokens.")
-
-(defconst semantic-grammar-wy--parse-table
- (progn
- (eval-when-compile
- (require 'semantic/wisent/comp))
- (wisent-compile-grammar
- '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE EXPECTEDCONFLICTS LEFT NONASSOC PACKAGE PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
- nil
- (grammar
- ((prologue))
- ((epilogue))
- ((declaration))
- ((nonterminal))
- ((PERCENT_PERCENT)))
- (prologue
- ((PROLOGUE)
- (wisent-raw-tag
- (semantic-tag-new-code "prologue" nil))))
- (epilogue
- ((EPILOGUE)
- (wisent-raw-tag
- (semantic-tag-new-code "epilogue" nil))))
- (declaration
- ((decl)
- (eval $1)))
- (decl
- ((default_prec_decl))
- ((no_default_prec_decl))
- ((languagemode_decl))
- ((expectedconflicts_decl))
- ((package_decl))
- ((provide_decl))
- ((precedence_decl))
- ((put_decl))
- ((quotemode_decl))
- ((scopestart_decl))
- ((start_decl))
- ((keyword_decl))
- ((token_decl))
- ((type_decl))
- ((use_macros_decl)))
- (default_prec_decl
- ((DEFAULT-PREC)
- `(wisent-raw-tag
- (semantic-tag "default-prec" 'assoc :value
- '("t")))))
- (no_default_prec_decl
- ((NO-DEFAULT-PREC)
- `(wisent-raw-tag
- (semantic-tag "default-prec" 'assoc :value
- '("nil")))))
- (languagemode_decl
- ((LANGUAGEMODE symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'languagemode :rest ',(cdr $2)))))
- (expectedconflicts_decl
- ((EXPECTEDCONFLICTS symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'expectedconflicts :rest ',(cdr $2)))))
- (package_decl
- ((PACKAGE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag-new-package ',$2 nil))))
- (provide_decl
- ((PROVIDE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'provide))))
- (precedence_decl
- ((associativity token_type_opt items)
- `(wisent-raw-tag
- (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
- (associativity
- ((LEFT)
- (progn "left"))
- ((RIGHT)
- (progn "right"))
- ((NONASSOC)
- (progn "nonassoc")))
- (put_decl
- ((PUT put_name put_value)
- `(wisent-raw-tag
- (semantic-tag ',$2 'put :value ',(list $3))))
- ((PUT put_name put_value_list)
- `(wisent-raw-tag
- (semantic-tag ',$2 'put :value ',$3)))
- ((PUT put_name_list put_value)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'put :rest ',(cdr $2)
- :value ',(list $3))))
- ((PUT put_name_list put_value_list)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'put :rest ',(cdr $2)
- :value ',$3))))
- (put_name_list
- ((BRACE_BLOCK)
- (mapcar 'semantic-tag-name
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'put_names 1))))
- (put_names
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((put_name)
- (wisent-raw-tag
- (semantic-tag $1 'put-name))))
- (put_name
- ((SYMBOL))
- ((token_type)))
- (put_value_list
- ((BRACE_BLOCK)
- (mapcar 'semantic-tag-code-detail
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'put_values 1))))
- (put_values
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((put_value)
- (wisent-raw-tag
- (semantic-tag-new-code "put-value" $1))))
- (put_value
- ((SYMBOL any_value)
- (cons $1 $2)))
- (scopestart_decl
- ((SCOPESTART SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'scopestart))))
- (quotemode_decl
- ((QUOTEMODE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'quotemode))))
- (start_decl
- ((START symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'start :rest ',(cdr $2)))))
- (keyword_decl
- ((KEYWORD SYMBOL string_value)
- `(wisent-raw-tag
- (semantic-tag ',$2 'keyword :value ',$3))))
- (token_decl
- ((TOKEN token_type_opt SYMBOL string_value)
- `(wisent-raw-tag
- (semantic-tag ',$3 ',(if $2 'token 'keyword)
- :type ',$2 :value ',$4)))
- ((TOKEN token_type_opt symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $3)
- 'token :type ',$2 :rest ',(cdr $3)))))
- (token_type_opt
- (nil)
- ((token_type)))
- (token_type
- ((LT SYMBOL GT)
- (progn $2)))
- (type_decl
- ((TYPE token_type plist_opt)
- `(wisent-raw-tag
- (semantic-tag ',$2 'type :value ',$3))))
- (plist_opt
- (nil)
- ((plist)))
- (plist
- ((plist put_value)
- (append
- (list $2)
- $1))
- ((put_value)
- (list $1)))
- (use_name_list
- ((BRACE_BLOCK)
- (mapcar 'semantic-tag-name
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'use_names 1))))
- (use_names
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((SYMBOL)
- (wisent-raw-tag
- (semantic-tag $1 'use-name))))
- (use_macros_decl
- ((USE-MACROS SYMBOL use_name_list)
- `(wisent-raw-tag
- (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
- (string_value
- ((STRING)
- (read $1)))
- (any_value
- ((SYMBOL))
- ((STRING))
- ((PAREN_BLOCK))
- ((PREFIXED_LIST))
- ((SEXP)))
- (symbols
- ((lifo_symbols)
- (nreverse $1)))
- (lifo_symbols
- ((lifo_symbols SYMBOL)
- (cons $2 $1))
- ((SYMBOL)
- (list $1)))
- (nonterminal
- ((SYMBOL
- (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
- COLON rules SEMI)
- (wisent-raw-tag
- (semantic-tag $1 'nonterminal :children $4))))
- (rules
- ((lifo_rules)
- (apply 'nconc
- (nreverse $1))))
- (lifo_rules
- ((lifo_rules OR rule)
- (cons $3 $1))
- ((rule)
- (list $1)))
- (rule
- ((rhs)
- (let*
- ((nterm semantic-grammar-wy--nterm)
- (rindx semantic-grammar-wy--rindx)
- (rhs $1)
- comps prec action elt)
- (setq semantic-grammar-wy--rindx
- (1+ semantic-grammar-wy--rindx))
- (while rhs
- (setq elt
- (car rhs)
- rhs
- (cdr rhs))
- (cond
- ((vectorp elt)
- (if prec
- (error "Duplicate %%prec in `%s:%d' rule" nterm rindx))
- (setq prec
- (aref elt 0)))
- ((consp elt)
- (if
- (or action comps)
- (setq comps
- (cons elt comps)
- semantic-grammar-wy--rindx
- (1+ semantic-grammar-wy--rindx))
- (setq action
- (car elt))))
- (t
- (setq comps
- (cons elt comps)))))
- (wisent-cook-tag
- (wisent-raw-tag
- (semantic-tag
- (format "%s:%d" nterm rindx)
- 'rule :type
- (if comps "group" "empty")
- :value comps :prec prec :expr action))))))
- (rhs
- (nil)
- ((rhs item)
- (cons $2 $1))
- ((rhs action)
- (cons
- (list $2)
- $1))
- ((rhs PREC item)
- (cons
- (vector $3)
- $1)))
- (action
- ((PAREN_BLOCK))
- ((PREFIXED_LIST))
- ((BRACE_BLOCK)
- (format "(progn\n%s)"
- (let
- ((s $1))
- (if
- (string-match "^{[\r\n\t ]*" s)
- (setq s
- (substring s
- (match-end 0))))
- (if
- (string-match "[\r\n\t ]*}$" s)
- (setq s
- (substring s 0
- (match-beginning 0))))
- s))))
- (items
- ((lifo_items)
- (nreverse $1)))
- (lifo_items
- ((lifo_items item)
- (cons $2 $1))
- ((item)
- (list $1)))
- (item
- ((SYMBOL))
- ((CHARACTER))))
- '(grammar prologue epilogue declaration nonterminal rule put_names put_values use_names)))
- "Parser table.")
-
-(defun semantic-grammar-wy--install-parser ()
- "Setup the Semantic Parser."
- (semantic-install-function-overrides
- '((semantic-parse-stream . wisent-parse-stream)))
- (setq semantic-parser-name "LALR"
- semantic--parse-table semantic-grammar-wy--parse-table
- semantic-debug-parser-source "grammar.wy"
- semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
- semantic-lex-types-obarray semantic-grammar-wy--token-table)
- ;; Collect unmatched syntax lexical tokens
- (add-hook 'wisent-discarding-token-functions
- 'wisent-collect-unmatched-syntax nil t))
-
-
-;;; Analyzers
-;;
-(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
- "block analyzer for <block> tokens."
- "\\s(\\|\\s)"
- '((("(" LPAREN PAREN_BLOCK)
- ("{" LBRACE BRACE_BLOCK))
- (")" RPAREN)
- ("}" RBRACE))
- )
-
-(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
- "regexp analyzer for <char> tokens."
- semantic-grammar-lex-c-char-re
- nil
- 'CHARACTER)
-
-(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
- "regexp analyzer for <symbol> tokens."
- ":?\\(\\sw\\|\\s_\\)+"
- '((PERCENT_PERCENT . "\\`%%\\'"))
- 'SYMBOL)
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
- "sexp analyzer for <qlist> tokens."
- "\\s'\\s-*("
- 'PREFIXED_LIST)
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
- "sexp analyzer for <string> tokens."
- "\\s\""
- 'STRING)
-
-(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
- "string analyzer for <punctuation> tokens."
- "\\(\\s.\\|\\s$\\|\\s'\\)+"
- '((GT . ">")
- (LT . "<")
- (OR . "|")
- (SEMI . ";")
- (COLON . ":"))
- 'punctuation)
-
-(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
- "keyword analyzer for <keyword> tokens."
- "\\(\\sw\\|\\s_\\)+")
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
- "sexp analyzer for <sexp> tokens."
- "\\="
- 'SEXP)
-
-
-;;; Epilogue
-;;
-
-
-
-
-(provide 'semantic/grammar-wy)
-
-;;; semantic/grammar-wy.el ends here
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 10bc5b66522..4c3bb6c238b 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -1,4 +1,4 @@
-;;; semantic/grammar.el --- Major mode framework for Semantic grammars
+;;; semantic/grammar.el --- Major mode framework for Semantic grammars -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2005, 2007-2021 Free Software Foundation, Inc.
@@ -23,9 +23,6 @@
;;
;; Major mode framework for editing Semantic's input grammar files.
-;;; History:
-;;
-
;;; Code:
(require 'semantic)
@@ -34,7 +31,12 @@
(require 'semantic/format)
;; FIXME this is a generated file, but we need to load this file to
;; generate it!
-(require 'semantic/grammar-wy)
+;; We need `semantic/grammar-wy.el' but we're also needed to generate
+;; that file from `grammar.wy', so to break the dependency, we keep
+;; a bootstrap copy of `grammar-wy.el' in `grm-wy-boot.el'. See bug#16008.
+(eval-and-compile
+ (unless (require 'semantic/grammar-wy nil t)
+ (load "semantic/grm-wy-boot")))
(require 'semantic/idle)
(require 'help-fns)
(require 'semantic/analyze)
@@ -142,13 +144,13 @@ It ignores whitespaces, newlines and comments."
"Return expansion of built-in ASSOC expression.
ARGS are ASSOC's key value list."
(let ((key t))
- `(semantic-tag-make-assoc-list
- ,@(mapcar #'(lambda (i)
- (prog1
- (if key
- (list 'quote i)
- i)
- (setq key (not key))))
+ `(semantic-tag-make-plist
+ ,@(mapcar (lambda (i)
+ (prog1
+ (if key
+ (list 'quote i)
+ i)
+ (setq key (not key))))
args))))
(defsubst semantic-grammar-quote-p (sym)
@@ -191,13 +193,13 @@ Warn if other tags of class CLASS exist."
That is tag names plus names defined in tag attribute `:rest'."
(let* ((tags (semantic-find-tags-by-class
class (current-buffer))))
- (apply 'append
+ (apply #'append
(mapcar
- #'(lambda (tag)
- (mapcar
- 'intern
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
+ (lambda (tag)
+ (mapcar
+ #'intern
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
tags))))
(defsubst semantic-grammar-item-text (item)
@@ -298,9 +300,9 @@ foo.by it is foo-by."
That is an alist of (VALUE . TOKEN) where VALUE is the string value of
the keyword and TOKEN is the terminal symbol identifying the keyword."
(mapcar
- #'(lambda (key)
- (cons (semantic-tag-get-attribute key :value)
- (intern (semantic-tag-name key))))
+ (lambda (key)
+ (cons (semantic-tag-get-attribute key :value)
+ (intern (semantic-tag-name key))))
(semantic-find-tags-by-class 'keyword (current-buffer))))
(defun semantic-grammar-keyword-properties (keywords)
@@ -312,7 +314,7 @@ the keyword and TOKEN is the terminal symbol identifying the keyword."
(setq put (car puts)
puts (cdr puts)
keys (mapcar
- 'intern
+ #'intern
(cons (semantic-tag-name put)
(semantic-tag-get-attribute put :rest))))
(while keys
@@ -432,9 +434,8 @@ Also load the specified macro libraries."
defs)))
(nreverse defs)))
-(defvar semantic-grammar-macros nil
+(defvar-local semantic-grammar-macros nil
"List of associations (MACRO-NAME . EXPANDER).")
-(make-variable-buffer-local 'semantic-grammar-macros)
(defun semantic-grammar-macros ()
"Build and return the alist of defined macros."
@@ -566,6 +567,10 @@ Typically a DEFINE expression should look like this:
(goto-char start)
(indent-sexp))))
+(defvar semantic-grammar-require-form
+ '(eval-when-compile (require 'semantic/bovine))
+ "The form to use to load the parser engine.")
+
(defconst semantic-grammar-header-template
'("\
;;; " file " --- Generated parser support file
@@ -597,13 +602,10 @@ Typically a DEFINE expression should look like this:
;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
;; generated from the grammar file " gram ".
-;;; History:
-;;
-
;;; Code:
(require 'semantic/lex)
-(eval-when-compile (require 'semantic/bovine))
+" require-form "
")
"Generated header template.
The symbols in the template are local variables in
@@ -652,6 +654,7 @@ The symbols in the list are local variables in
semantic--grammar-output-buffer))
(gram . ,(semantic-grammar-buffer-file))
(date . ,(format-time-string "%Y-%m-%d %T%z"))
+ (require-form . ,(format "%S" semantic-grammar-require-form))
(vcid . ,(concat "$" "Id" "$")) ;; Avoid expansion
;; Try to get the copyright from the input grammar, or
;; generate a new one if not found.
@@ -819,7 +822,7 @@ Block definitions are read from the current table of lexical types."
(let ((semantic-lex-types-obarray
(semantic-lex-make-type-table tokens props))
semantic-grammar--lex-block-specs)
- (mapatoms 'semantic-grammar-insert-defanalyzer
+ (mapatoms #'semantic-grammar-insert-defanalyzer
semantic-lex-types-obarray))))
;;; Generation of the grammar support file.
@@ -847,7 +850,8 @@ Lisp code."
(semantic--grammar-package (semantic-grammar-package))
(semantic--grammar-provide (semantic-grammar-first-tag-name 'provide))
(output (concat (or semantic--grammar-provide
- semantic--grammar-package) ".el"))
+ semantic--grammar-package)
+ ".el"))
(semantic--grammar-input-buffer (current-buffer))
(semantic--grammar-output-buffer
(find-file-noselect
@@ -1054,8 +1058,7 @@ See also the variable `semantic-grammar-file-regexp'."
;;;; Macros highlighting
;;;;
-(defvar semantic--grammar-macros-regexp-1 nil)
-(make-variable-buffer-local 'semantic--grammar-macros-regexp-1)
+(defvar-local semantic--grammar-macros-regexp-1 nil)
(defun semantic--grammar-macros-regexp-1 ()
"Return font-lock keyword regexp for pre-installed macro names."
@@ -1065,7 +1068,7 @@ See also the variable `semantic-grammar-file-regexp'."
(setq semantic--grammar-macros-regexp-1
(concat "(\\s-*"
(regexp-opt
- (mapcar #'(lambda (e) (symbol-name (car e)))
+ (mapcar (lambda (e) (symbol-name (car e)))
semantic-grammar-macros)
t)
"\\>"))
@@ -1076,8 +1079,7 @@ See also the variable `semantic-grammar-file-regexp'."
"\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
"Regexp that matches a macro declaration statement.")
-(defvar semantic--grammar-macros-regexp-2 nil)
-(make-variable-buffer-local 'semantic--grammar-macros-regexp-2)
+(defvar-local semantic--grammar-macros-regexp-2 nil)
(defun semantic--grammar-clear-macros-regexp-2 (&rest _)
"Clear the cached regexp that match macros local in this grammar.
@@ -1200,20 +1202,20 @@ END is the limit of the search."
(defvar semantic-grammar-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km "|" 'semantic-grammar-electric-punctuation)
- (define-key km ";" 'semantic-grammar-electric-punctuation)
- (define-key km "%" 'semantic-grammar-electric-punctuation)
- (define-key km "(" 'semantic-grammar-electric-punctuation)
- (define-key km ")" 'semantic-grammar-electric-punctuation)
- (define-key km ":" 'semantic-grammar-electric-punctuation)
-
- (define-key km "\t" 'semantic-grammar-indent)
- (define-key km "\M-\t" 'semantic-grammar-complete)
- (define-key km "\C-c\C-c" 'semantic-grammar-create-package)
- (define-key km "\C-cm" 'semantic-grammar-find-macro-expander)
- (define-key km "\C-cik" 'semantic-grammar-insert-keyword)
-;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load)
-;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule)
+ (define-key km "|" #'semantic-grammar-electric-punctuation)
+ (define-key km ";" #'semantic-grammar-electric-punctuation)
+ (define-key km "%" #'semantic-grammar-electric-punctuation)
+ (define-key km "(" #'semantic-grammar-electric-punctuation)
+ (define-key km ")" #'semantic-grammar-electric-punctuation)
+ (define-key km ":" #'semantic-grammar-electric-punctuation)
+
+ (define-key km "\t" #'semantic-grammar-indent)
+ (define-key km "\M-\t" #'semantic-grammar-complete)
+ (define-key km "\C-c\C-c" #'semantic-grammar-create-package)
+ (define-key km "\C-cm" #'semantic-grammar-find-macro-expander)
+ (define-key km "\C-cik" #'semantic-grammar-insert-keyword)
+;; (define-key km "\C-cc" #'semantic-grammar-generate-and-load)
+;; (define-key km "\C-cr" #'semantic-grammar-generate-one-rule)
km)
"Keymap used in `semantic-grammar-mode'.")
@@ -1251,13 +1253,15 @@ common grammar menu."
"Setup an XEmacs grammar menu in variable SYMBOL.
MODE-MENU is an optional specific menu whose items are appended to the
common grammar menu."
+ (declare (obsolete nil "28.1"))
(let ((items (make-symbol "items"))
(path (make-symbol "path")))
`(progn
(unless (boundp ',symbol)
(easy-menu-define ,symbol nil
"Grammar Menu" (copy-sequence semantic-grammar-menu)))
- (easy-menu-add ,symbol)
+ (when (featurep 'xemacs)
+ (easy-menu-add ,symbol))
(let ((,items (cdr ,mode-menu))
(,path (list (car ,symbol))))
(when ,items
@@ -1301,32 +1305,29 @@ the change bounds to encompass the whole nonterminal tag."
"Initialize a buffer for editing Semantic grammars.
\\{semantic-grammar-mode-map}"
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'comment-start) ";;")
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local comment-start ";;")
;; Look within the line for a ; following an even number of backslashes
;; after either a non-backslash or the line beginning.
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (set (make-local-variable 'indent-line-function)
- 'semantic-grammar-indent)
- (set (make-local-variable 'fill-paragraph-function)
- 'lisp-fill-paragraph)
- (set (make-local-variable 'font-lock-multiline)
- 'undecided)
- (set (make-local-variable 'font-lock-defaults)
- '((semantic-grammar-mode-keywords
- semantic-grammar-mode-keywords-1
- semantic-grammar-mode-keywords-2
- semantic-grammar-mode-keywords-3)
- nil ;; perform string/comment fontification
- nil ;; keywords are case sensitive.
- ;; This puts _ & - as a word constituent,
- ;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w"))))
+ (setq-local comment-start-skip
+ "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (setq-local indent-line-function #'semantic-grammar-indent)
+ (setq-local fill-paragraph-function #'lisp-fill-paragraph)
+ (setq-local font-lock-multiline 'undecided)
+ (setq-local font-lock-defaults
+ '((semantic-grammar-mode-keywords
+ semantic-grammar-mode-keywords-1
+ semantic-grammar-mode-keywords-2
+ semantic-grammar-mode-keywords-3)
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituent,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w"))))
;; Setup Semantic to parse grammar
(semantic-grammar-wy--install-parser)
(setq semantic-lex-comment-regex ";;"
- semantic-lex-analyzer 'semantic-grammar-lexer
+ semantic-lex-analyzer #'semantic-grammar-lexer
semantic-type-relation-separator-character '(":")
semantic-symbol->name-assoc-list
'(
@@ -1336,23 +1337,21 @@ the change bounds to encompass the whole nonterminal tag."
(nonterminal . "Nonterminal")
(rule . "Rule")
))
- (set (make-local-variable 'semantic-format-face-alist)
- '(
- (code . default)
- (keyword . font-lock-keyword-face)
- (token . font-lock-type-face)
- (nonterminal . font-lock-function-name-face)
- (rule . default)
- ))
- (set (make-local-variable 'semantic-stickyfunc-sticky-classes)
- '(nonterminal))
+ (setq-local semantic-format-face-alist
+ '((code . default)
+ (keyword . font-lock-keyword-face)
+ (token . font-lock-type-face)
+ (nonterminal . font-lock-function-name-face)
+ (rule . default)))
+ (setq-local semantic-stickyfunc-sticky-classes
+ '(nonterminal))
;; Before each change, clear the cached regexp used to highlight
;; macros local in this grammar.
(add-hook 'before-change-functions
- 'semantic--grammar-clear-macros-regexp-2 nil t)
+ #'semantic--grammar-clear-macros-regexp-2 nil t)
;; Handle safe re-parse of grammar rules.
(add-hook 'semantic-edits-new-change-functions
- 'semantic-grammar-edits-new-change-hook-fcn
+ #'semantic-grammar-edits-new-change-hook-fcn
nil t))
;;;;
@@ -1663,6 +1662,42 @@ Select the buffer containing the tag's definition, and move point there."
(defvar semantic-grammar-eldoc-last-data (cons nil nil))
+(defun semantic--docstring-format-sym-doc (prefix doc &optional face)
+ "Combine PREFIX and DOC, and shorten the result to fit in the echo area.
+
+When PREFIX is a symbol, propertize its symbol name with FACE
+before combining it with DOC. If FACE is not provided, just
+apply the nil face.
+
+See also: `eldoc-echo-area-use-multiline-p'."
+ ;; Hoisted from old `eldoc-docstring-format-sym-doc'.
+ ;; If the entire line cannot fit in the echo area, the symbol name may be
+ ;; truncated or eliminated entirely from the output to make room for the
+ ;; description.
+ (when (symbolp prefix)
+ (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": ")))
+ (let* ((ea-multi eldoc-echo-area-use-multiline-p)
+ ;; Subtract 1 from window width since emacs will not write
+ ;; any chars to the last column, or in later versions, will
+ ;; cause a wraparound and resize of the echo area.
+ (ea-width (1- (window-width (minibuffer-window))))
+ (strip (- (+ (length prefix)
+ (length doc))
+ ea-width)))
+ (cond ((or (<= strip 0)
+ (eq ea-multi t)
+ (and ea-multi (> (length doc) ea-width)))
+ (concat prefix doc))
+ ((> (length doc) ea-width)
+ (substring (format "%s" doc) 0 ea-width))
+ ((>= strip (string-match-p ":? *\\'" prefix))
+ doc)
+ (t
+ ;; Show the end of the partial symbol name, rather
+ ;; than the beginning, since the former is more likely
+ ;; to be unique given package namespace conventions.
+ (concat (substring prefix strip) doc)))))
+
(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
"Return a one-line docstring for the given grammar MACRO.
EXPANDER is the name of the function that expands MACRO."
@@ -1681,19 +1716,18 @@ EXPANDER is the name of the function that expands MACRO."
(setq doc (eldoc-function-argstring expander))))
(when doc
(setq doc
- (eldoc-docstring-format-sym-doc
+ (semantic--docstring-format-sym-doc
macro (format "==> %s %s" expander doc) 'default))
(setq semantic-grammar-eldoc-last-data (cons expander doc)))
doc))
((fboundp 'elisp-get-fnsym-args-string) ;; Emacs≥25
- (elisp-get-fnsym-args-string
- expander nil
- (concat (propertize (symbol-name macro)
+ (concat (propertize (symbol-name macro)
'face 'font-lock-keyword-face)
" ==> "
(propertize (symbol-name macro)
'face 'font-lock-function-name-face)
- ": ")))))
+ ": "
+ (elisp-get-fnsym-args-string expander nil )))))
(define-mode-local-override semantic-idle-summary-current-symbol-info
semantic-grammar-mode ()
@@ -1705,7 +1739,7 @@ If it is a macro name, return a description of the associated expander
function parameter list.
If it is a function name, return a description of this function
parameter list.
-It it is a variable name, return a brief (one-line) documentation
+If it is a variable name, return a brief (one-line) documentation
string for the variable.
If a default description of the current context can be obtained,
return it.
@@ -1827,11 +1861,11 @@ Optional argument COLOR determines if color is added to the text."
(setq label "Keyword: ")
(let (summary)
(semantic--find-tags-by-function
- #'(lambda (put)
- (unless summary
- (setq summary (cdr (assoc "summary"
- (semantic-tag-get-attribute
- put :value))))))
+ (lambda (put)
+ (unless summary
+ (setq summary (cdr (assoc "summary"
+ (semantic-tag-get-attribute
+ put :value))))))
;; Get `put' tag with TAG name.
(semantic-find-tags-by-name-regexp
(regexp-quote (semantic-tag-name tag))
@@ -1847,7 +1881,7 @@ Optional argument COLOR determines if color is added to the text."
(names (semantic-tag-get-attribute tag :rest))
(type (semantic-tag-type tag)))
(if names
- (setq name (mapconcat 'identity (cons name names) " ")))
+ (setq name (mapconcat #'identity (cons name names) " ")))
(setq desc (concat
(if type
(format " <%s>" type)
@@ -1864,7 +1898,7 @@ Optional argument COLOR determines if color is added to the text."
(format " <%s>" type)
"")
(if val
- (concat " " (mapconcat 'identity val " "))
+ (concat " " (mapconcat #'identity val " "))
"")))))
(t
(setq desc (semantic-format-tag-abbreviate tag parent color))))
@@ -1915,7 +1949,7 @@ Optional argument COLOR determines if color is added to the text."
context-return)))
(define-mode-local-override semantic-analyze-possible-completions
- semantic-grammar-mode (context &rest flags)
+ semantic-grammar-mode (context &rest _flags)
"Return a list of possible completions based on CONTEXT."
(require 'semantic/analyze/complete)
(if (semantic-grammar-in-lisp-p)
diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el
new file mode 100644
index 00000000000..a6bf211713a
--- /dev/null
+++ b/lisp/cedet/semantic/grm-wy-boot.el
@@ -0,0 +1,503 @@
+;;; semantic/grammar-wy.el --- Generated parser support file -*- lexical-binding:t -*-
+
+;; Copyright (C) 2002-2021 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This file was generated from admin/grammars/grammar.wy.
+
+;;; Code:
+
+(require 'semantic/lex)
+(require 'semantic/wisent)
+
+;;; Prologue
+;;
+(defvar semantic-grammar-lex-c-char-re)
+
+;; Current parsed nonterminal name.
+(defvar semantic-grammar-wy--nterm nil)
+;; Index of rule in a nonterminal clause.
+(defvar semantic-grammar-wy--rindx nil)
+
+;;; Declarations
+;;
+(eval-and-compile (defconst semantic-grammar-wy--expected-conflicts
+ nil
+ "The number of expected shift/reduce conflicts in this grammar."))
+
+(defconst semantic-grammar-wy--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("%default-prec" . DEFAULT-PREC)
+ ("%no-default-prec" . NO-DEFAULT-PREC)
+ ("%keyword" . KEYWORD)
+ ("%languagemode" . LANGUAGEMODE)
+ ("%left" . LEFT)
+ ("%nonassoc" . NONASSOC)
+ ("%package" . PACKAGE)
+ ("%expectedconflicts" . EXPECTEDCONFLICTS)
+ ("%provide" . PROVIDE)
+ ("%prec" . PREC)
+ ("%put" . PUT)
+ ("%quotemode" . QUOTEMODE)
+ ("%right" . RIGHT)
+ ("%scopestart" . SCOPESTART)
+ ("%start" . START)
+ ("%token" . TOKEN)
+ ("%type" . TYPE)
+ ("%use-macros" . USE-MACROS))
+ 'nil)
+ "Table of language keywords.")
+
+(defconst semantic-grammar-wy--token-table
+ (semantic-lex-make-type-table
+ '(("punctuation"
+ (GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ ("close-paren"
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("block"
+ (BRACE_BLOCK . "(LBRACE RBRACE)")
+ (PAREN_BLOCK . "(LPAREN RPAREN)"))
+ ("code"
+ (EPILOGUE . "%%...EOF")
+ (PROLOGUE . "%{...%}"))
+ ("sexp"
+ (SEXP))
+ ("qlist"
+ (PREFIXED_LIST))
+ ("char"
+ (CHARACTER))
+ ("symbol"
+ (PERCENT_PERCENT . "\\`%%\\'")
+ (SYMBOL))
+ ("string"
+ (STRING)))
+ '(("punctuation" :declared t)
+ ("block" :declared t)
+ ("sexp" matchdatatype sexp)
+ ("sexp" syntax "\\=")
+ ("sexp" :declared t)
+ ("qlist" matchdatatype sexp)
+ ("qlist" syntax "\\s'\\s-*(")
+ ("qlist" :declared t)
+ ("char" syntax semantic-grammar-lex-c-char-re)
+ ("char" :declared t)
+ ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
+ ("symbol" :declared t)
+ ("string" :declared t)
+ ("keyword" :declared t)))
+ "Table of lexical tokens.")
+
+(defconst semantic-grammar-wy--parse-table
+ (wisent-compiled-grammar
+ ((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE EXPECTEDCONFLICTS PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
+ nil
+ (grammar
+ ((prologue))
+ ((epilogue))
+ ((declaration))
+ ((nonterminal))
+ ((PERCENT_PERCENT)))
+ (prologue
+ ((PROLOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "prologue" nil))))
+ (epilogue
+ ((EPILOGUE)
+ (wisent-raw-tag
+ (semantic-tag-new-code "epilogue" nil))))
+ (declaration
+ ((decl)
+ (eval $1 t)))
+ (decl
+ ((default_prec_decl))
+ ((no_default_prec_decl))
+ ((languagemode_decl))
+ ((package_decl))
+ ((expectedconflicts_decl))
+ ((provide_decl))
+ ((precedence_decl))
+ ((put_decl))
+ ((quotemode_decl))
+ ((scopestart_decl))
+ ((start_decl))
+ ((keyword_decl))
+ ((token_decl))
+ ((type_decl))
+ ((use_macros_decl)))
+ (default_prec_decl
+ ((DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("t")))))
+ (no_default_prec_decl
+ ((NO-DEFAULT-PREC)
+ `(wisent-raw-tag
+ (semantic-tag "default-prec" 'assoc :value
+ '("nil")))))
+ (languagemode_decl
+ ((LANGUAGEMODE symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'languagemode :rest ',(cdr $2)))))
+ (package_decl
+ ((PACKAGE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag-new-package ',$2 nil))))
+ (expectedconflicts_decl
+ ((EXPECTEDCONFLICTS symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'expectedconflicts :rest ',(cdr $2)))))
+ (provide_decl
+ ((PROVIDE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'provide))))
+ (precedence_decl
+ ((associativity token_type_opt items)
+ `(wisent-raw-tag
+ (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
+ (associativity
+ ((LEFT)
+ (progn "left"))
+ ((RIGHT)
+ (progn "right"))
+ ((NONASSOC)
+ (progn "nonassoc")))
+ (put_decl
+ ((PUT put_name put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',(list $3))))
+ ((PUT put_name put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'put :value ',$3)))
+ ((PUT put_name_list put_value)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',(list $3))))
+ ((PUT put_name_list put_value_list)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'put :rest ',(cdr $2)
+ :value ',$3))))
+ (put_name_list
+ ((BRACE_BLOCK)
+ (mapcar #'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_names 1))))
+ (put_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_name)
+ (wisent-raw-tag
+ (semantic-tag $1 'put-name))))
+ (put_name
+ ((SYMBOL))
+ ((token_type)))
+ (put_value_list
+ ((BRACE_BLOCK)
+ (mapcar #'semantic-tag-code-detail
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'put_values 1))))
+ (put_values
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((put_value)
+ (wisent-raw-tag
+ (semantic-tag-new-code "put-value" $1))))
+ (put_value
+ ((SYMBOL any_value)
+ (cons $1 $2)))
+ (scopestart_decl
+ ((SCOPESTART SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'scopestart))))
+ (quotemode_decl
+ ((QUOTEMODE SYMBOL)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'quotemode))))
+ (start_decl
+ ((START symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $2)
+ 'start :rest ',(cdr $2)))))
+ (keyword_decl
+ ((KEYWORD SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'keyword :value ',$3))))
+ (token_decl
+ ((TOKEN token_type_opt SYMBOL string_value)
+ `(wisent-raw-tag
+ (semantic-tag ',$3 ',(if $2 'token 'keyword)
+ :type ',$2 :value ',$4)))
+ ((TOKEN token_type_opt symbols)
+ `(wisent-raw-tag
+ (semantic-tag ',(car $3)
+ 'token :type ',$2 :rest ',(cdr $3)))))
+ (token_type_opt
+ (nil)
+ ((token_type)))
+ (token_type
+ ((LT SYMBOL GT)
+ (progn $2)))
+ (type_decl
+ ((TYPE token_type plist_opt)
+ `(wisent-raw-tag
+ (semantic-tag ',$2 'type :value ',$3))))
+ (plist_opt
+ (nil)
+ ((plist)))
+ (plist
+ ((plist put_value)
+ (append
+ (list $2)
+ $1))
+ ((put_value)
+ (list $1)))
+ (use_name_list
+ ((BRACE_BLOCK)
+ (mapcar #'semantic-tag-name
+ (semantic-parse-region
+ (car $region1)
+ (cdr $region1)
+ 'use_names 1))))
+ (use_names
+ ((LBRACE)
+ nil)
+ ((RBRACE)
+ nil)
+ ((SYMBOL)
+ (wisent-raw-tag
+ (semantic-tag $1 'use-name))))
+ (use_macros_decl
+ ((USE-MACROS SYMBOL use_name_list)
+ `(wisent-raw-tag
+ (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
+ (string_value
+ ((STRING)
+ (read $1)))
+ (any_value
+ ((SYMBOL))
+ ((STRING))
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((SEXP)))
+ (symbols
+ ((lifo_symbols)
+ (nreverse $1)))
+ (lifo_symbols
+ ((lifo_symbols SYMBOL)
+ (cons $2 $1))
+ ((SYMBOL)
+ (list $1)))
+ (nonterminal
+ ((SYMBOL
+ (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
+ COLON rules SEMI)
+ (wisent-raw-tag
+ (semantic-tag $1 'nonterminal :children $4))))
+ (rules
+ ((lifo_rules)
+ (apply #'nconc
+ (nreverse $1))))
+ (lifo_rules
+ ((lifo_rules OR rule)
+ (cons $3 $1))
+ ((rule)
+ (list $1)))
+ (rule
+ ((rhs)
+ (let*
+ ((nterm semantic-grammar-wy--nterm)
+ (rindx semantic-grammar-wy--rindx)
+ (rhs $1)
+ comps prec action elt)
+ (setq semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (while rhs
+ (setq elt
+ (car rhs)
+ rhs
+ (cdr rhs))
+ (cond
+ ((vectorp elt)
+ (if prec
+ (error "Duplicate %%prec in `%s:%d' rule" nterm rindx))
+ (setq prec
+ (aref elt 0)))
+ ((consp elt)
+ (if
+ (or action comps)
+ (setq comps
+ (cons elt comps)
+ semantic-grammar-wy--rindx
+ (1+ semantic-grammar-wy--rindx))
+ (setq action
+ (car elt))))
+ (t
+ (setq comps
+ (cons elt comps)))))
+ (wisent-cook-tag
+ (wisent-raw-tag
+ (semantic-tag
+ (format "%s:%d" nterm rindx)
+ 'rule :type
+ (if comps "group" "empty")
+ :value comps :prec prec :expr action))))))
+ (rhs
+ (nil)
+ ((rhs item)
+ (cons $2 $1))
+ ((rhs action)
+ (cons
+ (list $2)
+ $1))
+ ((rhs PREC item)
+ (cons
+ (vector $3)
+ $1)))
+ (action
+ ((PAREN_BLOCK))
+ ((PREFIXED_LIST))
+ ((BRACE_BLOCK)
+ (format "(progn\n%s)"
+ (let
+ ((s $1))
+ (if
+ (string-match "^{[ \n ]*" s)
+ (setq s
+ (substring s
+ (match-end 0))))
+ (if
+ (string-match "[ \n ]*}$" s)
+ (setq s
+ (substring s 0
+ (match-beginning 0))))
+ s))))
+ (items
+ ((lifo_items)
+ (nreverse $1)))
+ (lifo_items
+ ((lifo_items item)
+ (cons $2 $1))
+ ((item)
+ (list $1)))
+ (item
+ ((SYMBOL))
+ ((CHARACTER))))
+ (grammar prologue epilogue declaration nonterminal rule put_names put_values use_names))
+ "Parser table.")
+
+(defun semantic-grammar-wy--install-parser ()
+ "Setup the Semantic Parser."
+ (semantic-install-function-overrides
+ '((semantic-parse-stream . wisent-parse-stream)))
+ (setq semantic-parser-name "LALR"
+ semantic--parse-table semantic-grammar-wy--parse-table
+ semantic-debug-parser-source "grammar.wy"
+ semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
+ semantic-lex-types-obarray semantic-grammar-wy--token-table)
+ ;; Collect unmatched syntax lexical tokens
+ (add-hook 'wisent-discarding-token-functions
+ #'wisent-collect-unmatched-syntax nil t))
+
+
+;;; Analyzers
+;;
+(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
+ "keyword analyzer for <keyword> tokens."
+ "\\(\\sw\\|\\s_\\)+")
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
+ "regexp analyzer for <char> tokens."
+ semantic-grammar-lex-c-char-re
+ nil
+ 'CHARACTER)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
+ "sexp analyzer for <string> tokens."
+ "\\s\""
+ 'STRING)
+
+(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
+ "block analyzer for <block> tokens."
+ "\\s(\\|\\s)"
+ '((("(" LPAREN PAREN_BLOCK)
+ ("{" LBRACE BRACE_BLOCK))
+ (")" RPAREN)
+ ("}" RBRACE))
+ )
+
+(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
+ "string analyzer for <punctuation> tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)+"
+ '((GT . ">")
+ (LT . "<")
+ (OR . "|")
+ (SEMI . ";")
+ (COLON . ":"))
+ 'punctuation)
+
+(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
+ "regexp analyzer for <symbol> tokens."
+ ":?\\(\\sw\\|\\s_\\)+"
+ '((PERCENT_PERCENT . "\\`%%\\'"))
+ 'SYMBOL)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
+ "sexp analyzer for <qlist> tokens."
+ "\\s'\\s-*("
+ 'PREFIXED_LIST)
+
+(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
+ "sexp analyzer for <sexp> tokens."
+ "\\="
+ 'SEXP)
+
+
+;;; Epilogue
+;;
+
+
+
+
+(provide 'semantic/grammar-wy)
+
+;; Local Variables:
+;; version-control: never
+;; no-update-autoloads: t
+;; End:
+
+;;; semantic/grammar-wy.el ends here
diff --git a/lisp/cedet/semantic/html.el b/lisp/cedet/semantic/html.el
index 658d218a4a3..ad5d2c798fb 100644
--- a/lisp/cedet/semantic/html.el
+++ b/lisp/cedet/semantic/html.el
@@ -1,4 +1,4 @@
-;;; semantic/html.el --- Semantic details for html files
+;;; semantic/html.el --- Semantic details for html files -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2005, 2007-2021 Free Software Foundation, Inc.
@@ -59,14 +59,14 @@
"Alist of sectioning commands and their relative level.")
(define-mode-local-override semantic-parse-region
- html-mode (&rest ignore)
+ html-mode (&rest _ignore)
"Parse the current html buffer for semantic tags.
IGNORE any arguments. Always parse the whole buffer.
Each tag returned is of the form:
(\"NAME\" section (:members CHILDREN))
or
(\"NAME\" anchor)"
- (mapcar 'semantic-html-expand-tag
+ (mapcar #'semantic-html-expand-tag
(semantic-html-parse-headings)))
(define-mode-local-override semantic-parse-changes
@@ -79,7 +79,7 @@ or
(let ((chil (semantic-html-components tag)))
(if chil
(semantic-tag-put-attribute
- tag :members (mapcar 'semantic-html-expand-tag chil)))
+ tag :members (mapcar #'semantic-html-expand-tag chil)))
(car (semantic--tag-expand tag))))
(defun semantic-html-components (tag)
@@ -233,7 +233,7 @@ tag with greater section value than LEVEL is found."
;; This will use our parser.
(setq semantic-parser-name "HTML"
semantic--parse-table t
- imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function #'semantic-create-imenu-index
semantic-command-separation-character ">"
semantic-type-relation-separator-character '(":")
semantic-symbol->name-assoc-list '((section . "Section")
diff --git a/lisp/cedet/semantic/ia-sb.el b/lisp/cedet/semantic/ia-sb.el
index b132d41cd4a..12a2f1db92a 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
+;;; semantic/ia-sb.el --- Speedbar analysis display interactor -*- lexical-binding: t; -*-
-;;; Copyright (C) 2002-2004, 2006, 2008-2021 Free Software Foundation,
-;;; Inc.
+;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -30,18 +29,14 @@
(require 'speedbar)
;;; Code:
-(defvar semantic-ia-sb-key-map nil
+(defvar semantic-ia-sb-key-map
+ (let ((map (speedbar-make-specialized-keymap)))
+ ;; Basic features.
+ (define-key map "\C-m" #'speedbar-edit-line)
+ (define-key map "I" #'semantic-ia-sb-show-tag-info)
+ map)
"Keymap used when in semantic analysis display mode.")
-(if semantic-ia-sb-key-map
- nil
- (setq semantic-ia-sb-key-map (speedbar-make-specialized-keymap))
-
- ;; Basic features.
- (define-key semantic-ia-sb-key-map "\C-m" 'speedbar-edit-line)
- (define-key semantic-ia-sb-key-map "I" 'semantic-ia-sb-show-tag-info)
- )
-
(defvar semantic-ia-sb-easymenu-definition
'( "---"
; [ "Expand" speedbar-expand-line nil ]
@@ -75,7 +70,7 @@ list of possible completions."
(speedbar-change-initial-expansion-list "Analyze")
)
-(defun semantic-ia-speedbar (directory zero)
+(defun semantic-ia-speedbar (_directory _zero)
"Create buttons in speedbar which define the current analysis at POINT.
DIRECTORY is the current directory, which is ignored, and ZERO is 0."
(let ((analysis nil)
@@ -195,7 +190,7 @@ DIRECTORY is the current directory, which is ignored, and ZERO is 0."
;; An index for the argument the prefix is in:
(let ((arg (oref context argument))
(args (semantic-tag-function-arguments (car func)))
- (idx 0)
+ ;; (idx 0)
)
(speedbar-insert-separator
(format "Argument #%d" (oref context index)))
@@ -275,7 +270,7 @@ See `semantic-ia-sb-tag-info' for more."
(setq tok (get-text-property (point) 'speedbar-token)))
(semantic-ia-sb-tag-info nil tok 0)))
-(defun semantic-ia-sb-tag-info (text tag indent)
+(defun semantic-ia-sb-tag-info (_text tag _indent)
"Display as much information as we can about tag.
Show the information in a shrunk split-buffer and expand
out as many details as possible.
@@ -322,16 +317,15 @@ TEXT, TAG, and INDENT are speedbar function arguments."
(get-buffer-window "*Tag Information*")))
(select-frame speedbar-frame))))
-(defun semantic-ia-sb-line-path (&optional depth)
+(defun semantic-ia-sb-line-path (&optional _depth)
"Return the file name associated with DEPTH."
(save-match-data
(let* ((tok (speedbar-line-token))
- (buff (if (semantic-tag-buffer tok)
- (semantic-tag-buffer tok)
- (current-buffer))))
+ (buff (or (semantic-tag-buffer tok)
+ (current-buffer))))
(buffer-file-name buff))))
-(defun semantic-ia-sb-complete (text tag indent)
+(defun semantic-ia-sb-complete (_text tag _indent)
"At point in the attached buffer, complete the symbol clicked on.
TEXT TAG and INDENT are the details."
;; Find the specified bounds from the current analysis.
diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el
index 1f6bb6aa54a..7186a781235 100644
--- a/lisp/cedet/semantic/ia.el
+++ b/lisp/cedet/semantic/ia.el
@@ -1,6 +1,6 @@
-;;; semantic/ia.el --- Interactive Analysis functions
+;;; semantic/ia.el --- Interactive Analysis functions -*- lexical-binding: t; -*-
-;;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -79,15 +79,9 @@
(insert "("))
(t nil))))
-(defalias 'semantic-ia-get-completions 'semantic-ia-get-completions-deprecated
- "`Semantic-ia-get-completions' is obsolete.
-Use `semantic-analyze-possible-completions' instead.")
-
-(defun semantic-ia-get-completions-deprecated (context point)
- "A function to help transition away from `semantic-ia-get-completions'.
-Return completions based on CONTEXT at POINT.
-You should not use this, nor the aliased version.
-Use `semantic-analyze-possible-completions' instead."
+(defun semantic-ia-get-completions (context _point)
+ "Fetch the completion of CONTEXT at POINT."
+ (declare (obsolete semantic-analyze-possible-completions "28.1"))
(semantic-analyze-possible-completions context))
;;;###autoload
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index d18dec99948..b883573a30f 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -1,4 +1,4 @@
-;;; idle.el --- Schedule parsing tasks in idle time
+;;; idle.el --- Schedule parsing tasks in idle time -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2006, 2008-2021 Free Software Foundation, Inc.
@@ -47,8 +47,6 @@
;; For the semantic-find-tags-by-name macro.
(eval-when-compile (require 'semantic/find))
-(defvar eldoc-last-message)
-(declare-function eldoc-message "eldoc")
(declare-function semantic-analyze-unsplit-name "semantic/analyze/fcn")
(declare-function semantic-complete-analyze-inline-idle "semantic/complete")
(declare-function semanticdb-deep-find-tags-by-name "semantic/db-find")
@@ -135,10 +133,9 @@ it is unlikely the user would be ready to type again right away."
:group 'semantic
:type 'hook)
-(defvar semantic-idle-scheduler-mode nil
+(defvar-local semantic-idle-scheduler-mode nil
"Non-nil if idle-scheduler minor mode is enabled.
Use the command `semantic-idle-scheduler-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-idle-scheduler-mode)
(defcustom semantic-idle-scheduler-max-buffer-size 0
"Maximum size in bytes of buffers where idle-scheduler is enabled.
@@ -174,7 +171,8 @@ date, and reparses while the user is idle (not typing.)
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." nil nil nil
+non-nil if the minor mode is enabled."
+ :lighter nil
(if semantic-idle-scheduler-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -219,22 +217,22 @@ And also manages services that depend on tag values."
(let* ((inhibit-quit nil)
(buffers (delq (current-buffer)
(delq nil
- (mapcar #'(lambda (b)
- (and (buffer-file-name b)
- b))
+ (mapcar (lambda (b)
+ (and (buffer-file-name b)
+ b))
(buffer-list)))))
- safe ;; This safe is not used, but could be.
+ ;; safe ;; This safe is not used, but could be.
others
mode)
(when (semantic-idle-scheduler-enabled-p)
(save-excursion
;; First, reparse the current buffer.
- (setq mode major-mode
- safe (semantic-safe "Idle Parse Error: %S"
- ;(error "Goofy error 1")
- (semantic-idle-scheduler-refresh-tags)
- )
- )
+ (setq mode major-mode)
+ ;; (setq safe
+ (semantic-safe "Idle Parse Error: %S"
+ ;(error "Goofy error 1")
+ (semantic-idle-scheduler-refresh-tags))
+
;; Now loop over other buffers with same major mode, trying to
;; update them as well. Stop on keypress.
(dolist (b buffers)
@@ -351,54 +349,56 @@ Returns t if all processing succeeded."
Visits Semantic controlled buffers, and makes sure all needed
include files have been parsed, and that the typecache is up to date.
Uses `semantic-idle-work-for-on-buffer' to do the work."
- (let ((errbuf nil)
- (interrupted
- (semantic-exit-on-input 'idle-work-timer
- (let* ((inhibit-quit nil)
- (cb (current-buffer))
- (buffers (delq (current-buffer)
- (delq nil
- (mapcar #'(lambda (b)
- (and (buffer-file-name b)
- b))
- (buffer-list)))))
- safe errbuf)
- ;; First, handle long tasks in the current buffer.
- (when (semantic-idle-scheduler-enabled-p)
- (save-excursion
- (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
- )))
- (when (not safe) (push (current-buffer) errbuf))
-
- ;; Now loop over other buffers with same major mode, trying to
- ;; update them as well. Stop on keypress.
- (dolist (b buffers)
- (semantic-throw-on-input 'parsing-mode-buffers)
- (with-current-buffer b
- (when (semantic-idle-scheduler-enabled-p)
- (and (semantic-idle-scheduler-enabled-p)
- (unless (semantic-idle-work-for-one-buffer (current-buffer))
- (push (current-buffer) errbuf)))
- ))
- )
-
- (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
- ;; Save everything.
- (semanticdb-save-all-db-idle)
-
- ;; Parse up files near our active buffer
- (when semantic-idle-work-parse-neighboring-files-flag
- (semantic-safe "Idle Work Parse Neighboring Files: %S"
- (set-buffer cb)
- (semantic-idle-scheduler-work-parse-neighboring-files))
- t)
+ (let*
+ ((errbuf nil)
+ (interrupted
+ (semantic-exit-on-input 'idle-work-timer
+ (let* ((inhibit-quit nil)
+ (cb (current-buffer))
+ (buffers (delq (current-buffer)
+ (delq nil
+ (mapcar (lambda (b)
+ (and (buffer-file-name b)
+ b))
+ (buffer-list)))))
+ safe) ;; errbuf
+ ;; First, handle long tasks in the current buffer.
+ (when (semantic-idle-scheduler-enabled-p)
+ (save-excursion
+ (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
+ )))
+ (when (not safe) (push (current-buffer) errbuf))
+
+ ;; Now loop over other buffers with same major mode, trying to
+ ;; update them as well. Stop on keypress.
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (with-current-buffer b
+ (when (semantic-idle-scheduler-enabled-p)
+ (and (semantic-idle-scheduler-enabled-p)
+ (unless (semantic-idle-work-for-one-buffer
+ (current-buffer))
+ (push (current-buffer) errbuf)))
+ ))
+ )
- ;; Save everything... again
- (semanticdb-save-all-db-idle)
- )
+ (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ ;; Save everything.
+ (semanticdb-save-all-db-idle)
+
+ ;; Parse up files near our active buffer
+ (when semantic-idle-work-parse-neighboring-files-flag
+ (semantic-safe "Idle Work Parse Neighboring Files: %S"
+ (set-buffer cb)
+ (semantic-idle-scheduler-work-parse-neighboring-files))
+ t)
+
+ ;; Save everything... again
+ (semanticdb-save-all-db-idle)
+ )
- ;; Done w/ processing
- nil))))
+ ;; Done w/ processing
+ nil))))
;; Done
(if interrupted
@@ -431,6 +431,8 @@ datasets."
(message "Long Work Idle Timer...%s" exit-type)))
)
+(defvar ede-auto-add-method)
+
(defun semantic-idle-scheduler-work-parse-neighboring-files ()
"Parse all the files in similar directories to buffers being edited."
;; Let's tell EDE to ignore all the files we're about to load
@@ -472,11 +474,6 @@ This hook is not protected from lexical errors.")
If any hook function throws an error, this variable is reset to nil.
This hook is not protected from lexical errors.")
-(semantic-varalias-obsolete 'semantic-before-idle-scheduler-reparse-hooks
- 'semantic-before-idle-scheduler-reparse-hook "23.2")
-(semantic-varalias-obsolete 'semantic-after-idle-scheduler-reparse-hooks
- 'semantic-after-idle-scheduler-reparse-hook "23.2")
-
(defun semantic-idle-scheduler-refresh-tags ()
"Refreshes the current buffer's tags.
This is called by `semantic-idle-scheduler-function' to update the
@@ -570,11 +567,12 @@ DOC will be a documentation string describing FORMS.
FORMS will be called during idle time after the current buffer's
semantic tag information has been updated.
This routine creates the following functions and variables:"
+ (declare (indent 1) (debug (&define name stringp def-body)))
(let ((global (intern (concat "global-" (symbol-name name) "-mode")))
(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")))
+ ;; (setup (intern (concat (symbol-name name) "-mode-setup")))
(func (intern (concat (symbol-name name) "-idle-function"))))
`(progn
@@ -624,11 +622,6 @@ turned on in every Semantic-supported buffer.")
,(concat "Perform idle activity for the minor mode `"
(symbol-name mode) "'.")
,@forms))))
-(put 'define-semantic-idle-service 'lisp-indent-function 1)
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec define-semantic-idle-service
- (&define name stringp def-body))))
;;; SUMMARY MODE
;;
@@ -722,8 +715,7 @@ specific to a major mode. For example, in jde mode:
(defun semantic-idle-summary-useful-context-p ()
"Non-nil if we should show a summary based on context."
- (if (and (boundp 'font-lock-mode)
- font-lock-mode
+ (if (and font-lock-mode
(memq (get-text-property (point) 'face)
semantic-idle-summary-out-of-context-faces))
;; The best I can think of at the moment is to disable
@@ -734,41 +726,24 @@ specific to a major mode. For example, in jde mode:
(define-overloadable-function semantic-idle-summary-current-symbol-info ()
"Return a string message describing the current context.")
-(make-obsolete-overload 'semantic-eldoc-current-symbol-info
- 'semantic-idle-summary-current-symbol-info
- "23.2")
-
(defcustom semantic-idle-summary-mode-hook nil
"Hook run at the end of `semantic-idle-summary'."
:group 'semantic
:type 'hook)
-(defun semantic-idle-summary-idle-function ()
- "Display a tag summary of the lexical token under the cursor.
+(defun semantic--eldoc-info (_callback &rest _)
+ "Return the eldoc info for the current symbol.
Call `semantic-idle-summary-current-symbol-info' for getting the
current tag to display information."
(or (eq major-mode 'emacs-lisp-mode)
(not (semantic-idle-summary-useful-context-p))
- (let* ((found (semantic-idle-summary-current-symbol-info))
+ (let* ((found (save-excursion
+ (semantic-idle-summary-current-symbol-info)))
(str (cond ((stringp found) found)
((semantic-tag-p found)
(funcall semantic-idle-summary-function
found nil t)))))
- ;; Show the message with eldoc functions
- (unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
- eldoc-echo-area-use-multiline-p)
- (let ((w (1- (window-width (minibuffer-window)))))
- (if (> (length str) w)
- (setq str (substring str 0 w)))))
- ;; I borrowed some bits from eldoc to shorten the
- ;; message.
- (when semantic-idle-truncate-long-summaries
- (let ((ea-width (1- (window-width (minibuffer-window))))
- (strlen (length str)))
- (when (> strlen ea-width)
- (setq str (substring str 0 ea-width)))))
- ;; Display it
- (eldoc-message str))))
+ str)))
(define-minor-mode semantic-idle-summary-mode
"Toggle Semantic Idle Summary mode.
@@ -777,30 +752,16 @@ 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
- (if semantic-idle-summary-mode
- ;; Enable the mode
- (progn
- (unless (and (featurep 'semantic) (semantic-active-p))
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-idle-summary-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- (require 'eldoc)
- (semantic-idle-scheduler-add 'semantic-idle-summary-idle-function)
- (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)))
-
-(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))))
+ (remove-hook 'eldoc-documentation-functions #'semantic--eldoc-info t)
+ (when semantic-idle-summary-mode
+ ;; Enable the mode
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-idle-summary-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ (add-hook 'eldoc-documentation-functions #'semantic--eldoc-info nil t)
+ (eldoc-mode 1)))
(semantic-add-minor-mode 'semantic-idle-summary-mode "")
@@ -832,6 +793,8 @@ turned on in every Semantic-supported buffer."
(make-obsolete-variable 'semantic-idle-symbol-highlight-face
"customize the face `semantic-idle-symbol-highlight' instead" "24.4" 'set)
+(defvar pulse-flag)
+
(defun semantic-idle-symbol-maybe-highlight (tag)
"Perhaps add highlighting to the symbol represented by TAG.
TAG was found as the symbol under point. If it happens to be
@@ -909,7 +872,7 @@ Call `semantic-symref-hits-in-region' to identify local references."
(when (semantic-tag-p target)
(require 'semantic/symref/filter)
(semantic-symref-hits-in-region
- target (lambda (start end prefix)
+ target (lambda (start end _prefix)
(when (/= start (car Hbounds))
(pulse-momentary-highlight-region
start end semantic-idle-symbol-highlight-face))
@@ -1076,21 +1039,20 @@ be called."
(popup-menu semantic-idle-breadcrumbs-popup-menu)
(select-window old-window)))
-(defmacro semantic-idle-breadcrumbs--tag-function (function)
+(defun semantic-idle-breadcrumbs--tag-function (function)
"Return lambda expression calling FUNCTION when called from a popup."
- `(lambda (event)
- (interactive "e")
- (let* ((old-window (selected-window))
- (window (semantic-event-window event))
- (column (car (nth 6 (nth 1 event)))) ;; TODO semantic-event-column?
- (tag (progn
- (select-window window t)
- (plist-get
- (text-properties-at column header-line-format)
- 'tag))))
- (,function tag)
- (select-window old-window)))
- )
+ (lambda (event)
+ (interactive "e")
+ (let* ((old-window (selected-window))
+ (window (semantic-event-window event))
+ (column (car (nth 6 (nth 1 event)))) ;; TODO semantic-event-column?
+ (tag (progn
+ (select-window window t)
+ (plist-get
+ (text-properties-at column header-line-format)
+ 'tag))))
+ (funcall function tag)
+ (select-window old-window))))
;; TODO does this work for mode-line case?
(defvar semantic-idle-breadcrumbs-popup-map
@@ -1098,12 +1060,11 @@ be called."
;; mouse-1 goes to clicked tag
(define-key map
[ header-line mouse-1 ]
- (semantic-idle-breadcrumbs--tag-function
- semantic-go-to-tag))
+ (semantic-idle-breadcrumbs--tag-function #'semantic-go-to-tag))
;; mouse-3 pops up a context menu
(define-key map
[ header-line mouse-3 ]
- 'semantic-idle-breadcrumbs--popup-menu)
+ #'semantic-idle-breadcrumbs--popup-menu)
map)
"Keymap for semantic idle breadcrumbs minor mode.")
@@ -1115,8 +1076,7 @@ be called."
"Breadcrumb Tag"
(vector
"Go to Tag"
- (semantic-idle-breadcrumbs--tag-function
- semantic-go-to-tag)
+ (semantic-idle-breadcrumbs--tag-function #'semantic-go-to-tag)
:active t
:help "Jump to this tag")
;; TODO these entries need minor changes (optional tag argument) in
@@ -1124,37 +1084,32 @@ be called."
;; (semantic-menu-item
;; (vector
;; "Copy Tag"
- ;; (semantic-idle-breadcrumbs--tag-function
- ;; senator-copy-tag)
+ ;; (semantic-idle-breadcrumbs--tag-function #'senator-copy-tag)
;; :active t
;; :help "Copy this tag"))
;; (semantic-menu-item
;; (vector
;; "Kill Tag"
- ;; (semantic-idle-breadcrumbs--tag-function
- ;; senator-kill-tag)
+ ;; (semantic-idle-breadcrumbs--tag-function #'senator-kill-tag)
;; :active t
;; :help "Kill tag text to the kill ring, and copy the tag to
;; the tag ring"))
;; (semantic-menu-item
;; (vector
;; "Copy Tag to Register"
- ;; (semantic-idle-breadcrumbs--tag-function
- ;; senator-copy-tag-to-register)
+ ;; (semantic-idle-breadcrumbs--tag-function #'senator-copy-tag-to-register)
;; :active t
;; :help "Copy this tag"))
;; (semantic-menu-item
;; (vector
;; "Narrow to Tag"
- ;; (semantic-idle-breadcrumbs--tag-function
- ;; senator-narrow-to-defun)
+ ;; (semantic-idle-breadcrumbs--tag-function #'senator-narrow-to-defun)
;; :active t
;; :help "Narrow to the bounds of the current tag"))
;; (semantic-menu-item
;; (vector
;; "Fold Tag"
- ;; (semantic-idle-breadcrumbs--tag-function
- ;; senator-fold-tag-toggle)
+ ;; (semantic-idle-breadcrumbs--tag-function #'senator-fold-tag-toggle)
;; :active t
;; :style 'toggle
;; :selected '(let ((tag (semantic-current-tag)))
@@ -1242,7 +1197,7 @@ shortened at the beginning."
)
(defun semantic-idle-breadcrumbs--format-linear
- (tag-list &optional max-length)
+ (tag-list &optional _max-length)
"Format TAG-LIST as a linear list, starting with the outermost tag.
MAX-LENGTH is not used."
(require 'semantic/analyze/fcn)
diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el
index 70f9a11a92e..a5db85bb512 100644
--- a/lisp/cedet/semantic/imenu.el
+++ b/lisp/cedet/semantic/imenu.el
@@ -1,4 +1,4 @@
-;;; semantic/imenu.el --- Use Semantic as an imenu tag generator
+;;; semantic/imenu.el --- Use Semantic as an imenu tag generator -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2005, 2007-2008, 2010-2021 Free Software
;; Foundation, Inc.
@@ -44,9 +44,8 @@
;; Because semantic imenu tags will hose the current imenu handling
;; code in speedbar, force semantic/sb in.
-(if (featurep 'speedbar)
- (require 'semantic/sb)
- (add-hook 'speedbar-load-hook (lambda () (require 'semantic/sb))))
+(with-eval-after-load 'speedbar
+ (require 'semantic/sb))
(defgroup semantic-imenu nil
"Semantic interface to Imenu."
@@ -58,14 +57,12 @@
(defcustom semantic-imenu-summary-function 'semantic-format-tag-abbreviate
"Function to use when creating items in Imenu.
Some useful functions are found in `semantic-format-tag-functions'."
- :group 'semantic-imenu
:type semantic-format-tag-custom-list)
(make-variable-buffer-local 'semantic-imenu-summary-function)
;;;###autoload
(defcustom semantic-imenu-bucketize-file t
"Non-nil if tags in a file are to be grouped into buckets."
- :group 'semantic-imenu
:type 'boolean)
(make-variable-buffer-local 'semantic-imenu-bucketize-file)
@@ -73,39 +70,31 @@ Some useful functions are found in `semantic-format-tag-functions'."
"Non-nil if types in a file should adopt externally defined members.
C++ and CLOS can define methods that are not in the body of a class
definition."
- :group 'semantic-imenu
:type 'boolean)
(defcustom semantic-imenu-buckets-to-submenu t
"Non-nil if buckets of tags are to be turned into submenus.
This option is ignored if `semantic-imenu-bucketize-file' is nil."
- :group 'semantic-imenu
:type 'boolean)
(make-variable-buffer-local 'semantic-imenu-buckets-to-submenu)
;;;###autoload
(defcustom semantic-imenu-expand-type-members t
"Non-nil if types should have submenus with members in them."
- :group 'semantic-imenu
:type 'boolean)
(make-variable-buffer-local 'semantic-imenu-expand-type-members)
-(semantic-varalias-obsolete 'semantic-imenu-expand-type-parts
- 'semantic-imenu-expand-type-members "23.2")
(defcustom semantic-imenu-bucketize-type-members t
"Non-nil if members of a type should be grouped into buckets.
A nil value means to keep them in the same order.
Overridden to nil if `semantic-imenu-bucketize-file' is nil."
- :group 'semantic-imenu
:type 'boolean)
(make-variable-buffer-local 'semantic-imenu-bucketize-type-members)
-(semantic-varalias-obsolete 'semantic-imenu-bucketize-type-parts
- 'semantic-imenu-bucketize-type-members "23.2")
(defcustom semantic-imenu-sort-bucket-function nil
"Function to use when sorting tags in the buckets of functions.
-See `semantic-bucketize' and the FILTER argument for more details on this function."
- :group 'semantic-imenu
+See `semantic-bucketize' and the FILTER argument for more details
+on this function."
:type '(radio (const :tag "No Sorting" nil)
(const semantic-sort-tags-by-name-increasing)
(const semantic-sort-tags-by-name-decreasing)
@@ -123,14 +112,12 @@ See `semantic-bucketize' and the FILTER argument for more details on this functi
Doesn't actually parse the entire directory, but displays tags for all files
currently listed in the current Semantic database.
This variable has no meaning if semanticdb is not active."
- :group 'semantic-imenu
:type 'boolean)
(defcustom semantic-imenu-auto-rebuild-directory-indexes nil
"If non-nil automatically rebuild directory index imenus.
That is when a directory index imenu is updated, automatically rebuild
other buffer local ones based on the same semanticdb."
- :group 'semantic-imenu
:type 'boolean)
(defvar semantic-imenu-directory-current-file nil
@@ -140,14 +127,11 @@ other buffer local ones based on the same semanticdb."
"Non-nil if `semantic-imenu-rebuild-directory-indexes' is running.")
;;;###autoload
-(defvar semantic-imenu-expandable-tag-classes '(type)
+(defvar-local semantic-imenu-expandable-tag-classes '(type)
"List of expandable tag classes.
Tags of those classes will be given submenu with children.
By default, a `type' has interesting children. In Texinfo, however, a
`section' has interesting children.")
-(make-variable-buffer-local 'semantic-imenu-expandable-tag-classes)
-(semantic-varalias-obsolete 'semantic-imenu-expandable-token
- 'semantic-imenu-expandable-tag-classes "23.2")
;;; Code:
(defun semantic-imenu-tag-overlay (tag)
@@ -213,7 +197,7 @@ Optional argument REST is some extra stuff."
(setq imenu--index-alist nil)))))
))
-(defun semantic-imenu-flush-fcn (&optional ignore)
+(defun semantic-imenu-flush-fcn (&optional _ignore)
"This function is called as a hook to clear the imenu cache.
It is cleared after any parsing.
IGNORE arguments."
@@ -221,9 +205,9 @@ IGNORE arguments."
(setq imenu--index-alist nil
imenu-menubar-modified-tick 0))
(remove-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-imenu-flush-fcn t)
+ #'semantic-imenu-flush-fcn t)
(remove-hook 'semantic-after-partial-cache-change-hook
- 'semantic-imenu-flush-fcn t)
+ #'semantic-imenu-flush-fcn t)
)
;;;###autoload
@@ -231,7 +215,7 @@ IGNORE arguments."
"Create an imenu index for any buffer which supports Semantic.
Uses the output of the Semantic parser to create the index.
Optional argument STREAM is an optional stream of tags used to create menus."
- (setq imenu-default-goto-function 'semantic-imenu-goto-function)
+ (setq imenu-default-goto-function #'semantic-imenu-goto-function)
(prog1
(if (and semantic-imenu-index-directory
(featurep 'semantic/db)
@@ -241,9 +225,9 @@ Optional argument STREAM is an optional stream of tags used to create menus."
(semantic-create-imenu-index-1
(or stream (semantic-fetch-tags-fast)) nil))
(add-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-imenu-flush-fcn nil t)
+ #'semantic-imenu-flush-fcn nil t)
(add-hook 'semantic-after-partial-cache-change-hook
- 'semantic-imenu-flush-fcn nil t)))
+ #'semantic-imenu-flush-fcn nil t)))
(defun semantic-create-imenu-directory-index (&optional stream)
"Create an imenu tag index based on all files active in semanticdb.
@@ -445,14 +429,14 @@ Optional argument PARENT is a tag parent of STREAM."
Clears all imenu menus that may be depending on the database."
(require 'semantic/db-mode)
(semantic-map-buffers
- #'(lambda ()
- ;; Set up semanticdb environment if enabled.
- (if (semanticdb-minor-mode-p)
- (semanticdb-semantic-init-hook-fcn))
- ;; Clear imenu cache to redraw the imenu.
- (semantic-imenu-flush-fcn))))
+ (lambda ()
+ ;; Set up semanticdb environment if enabled.
+ (if (semanticdb-minor-mode-p)
+ (semanticdb-semantic-init-hook-fcn))
+ ;; Clear imenu cache to redraw the imenu.
+ (semantic-imenu-flush-fcn))))
-(add-hook 'semanticdb-mode-hook 'semantic-imenu-semanticdb-hook)
+(add-hook 'semanticdb-mode-hook #'semantic-imenu-semanticdb-hook)
;;; Interactive Utilities
;;
@@ -491,7 +475,6 @@ Clears all imenu menus that may be depending on the database."
(defcustom semantic-which-function-use-color nil
"Use color when displaying the current function with `which-function'."
- :group 'semantic-imenu
:type 'boolean)
(defun semantic-default-which-function (taglist)
diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el
index d6b75127457..f48b835fe39 100644
--- a/lisp/cedet/semantic/java.el
+++ b/lisp/cedet/semantic/java.el
@@ -1,6 +1,6 @@
-;;; semantic/java.el --- Semantic functions for Java
+;;; semantic/java.el --- Semantic functions for Java -*- lexical-binding: t; -*-
-;;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
@@ -148,7 +148,7 @@ corresponding compound declaration."
(let* ((name (semantic-tag-name tag))
(rsplit (nreverse (split-string name "\\." t)))
(newclassname (car rsplit))
- (newpkg (mapconcat 'identity (reverse (cdr rsplit)) ".")))
+ (newpkg (mapconcat #'identity (reverse (cdr rsplit)) ".")))
(semantic-tag-set-name tag newclassname)
(setq xpand
(list tag
@@ -169,7 +169,7 @@ corresponding compound declaration."
(define-mode-local-override semantic-ctxt-scoped-types
java-mode (&optional point)
"Return a list of type names currently in scope at POINT."
- (mapcar 'semantic-tag-name
+ (mapcar #'semantic-tag-name
(semantic-find-tags-by-class
'type (semantic-find-tag-by-overlay point))))
@@ -184,7 +184,7 @@ Override function for `semantic-tag-protection'."
;; Prototype handler
;;
-(defun semantic-java-prototype-function (tag &optional parent color)
+(defun semantic-java-prototype-function (tag &optional _parent color)
"Return a function (method) prototype for TAG.
Optional argument PARENT is a parent (containing) item.
Optional argument COLOR indicates that color should be mixed in.
@@ -212,7 +212,7 @@ See also `semantic-format-tag-prototype'."
(or type "") (if type " " "")
name "(" argp ")")))
-(defun semantic-java-prototype-variable (tag &optional parent color)
+(defun semantic-java-prototype-variable (tag &optional _parent color)
"Return a variable (field) prototype for TAG.
Optional argument PARENT is a parent (containing) item.
Optional argument COLOR indicates that color should be mixed in.
@@ -227,7 +227,7 @@ See also `semantic-format-tag-prototype'."
(semantic--format-colorize-text name 'variable)
name))))
-(defun semantic-java-prototype-type (tag &optional parent color)
+(defun semantic-java-prototype-type (tag &optional _parent color)
"Return a type (class/interface) prototype for TAG.
Optional argument PARENT is a parent (containing) item.
Optional argument COLOR indicates that color should be mixed in.
@@ -253,9 +253,6 @@ Optional argument COLOR indicates that color should be mixed in."
'semantic-format-tag-prototype-default)
tag parent color)))
-(semantic-alias-obsolete 'semantic-java-prototype-nonterminal
- 'semantic-format-tag-prototype-java-mode "23.2")
-
;; Include Tag Name
;;
@@ -263,7 +260,7 @@ Optional argument COLOR indicates that color should be mixed in."
(define-mode-local-override semantic-tag-include-filename java-mode (tag)
"Return a suitable path for (some) Java imports."
(let ((name (semantic-tag-name tag)))
- (concat (mapconcat 'identity (split-string name "\\.") "/") ".java")))
+ (concat (mapconcat #'identity (split-string name "\\.") "/") ".java")))
;; Documentation handler
;;
@@ -324,7 +321,7 @@ If NOSNARF is `lex', then return the semantic lex token."
(defvar semantic-java-doc-line-tags nil
"Valid javadoc line tags.
Ordered following Sun's Tag Convention at
-<http://java.sun.com/products/jdk/javadoc/writingdoccomments/index.html>")
+<https://java.sun.com/products/jdk/javadoc/writingdoccomments/index.html>")
(defvar semantic-java-doc-with-name-tags nil
"Javadoc tags which have a name.")
@@ -398,11 +395,11 @@ receives two arguments: the javadoc keyword and its associated
removed from the result list."
(delq nil
(mapcar
- #'(lambda (k)
- (let* ((tag (semantic-java-doc-tag k))
- (plist (semantic-lex-keyword-get tag 'javadoc)))
- (if (or (not property) (plist-get plist property))
- (funcall fun k plist))))
+ (lambda (k)
+ (let* ((tag (semantic-java-doc-tag k))
+ (plist (semantic-lex-keyword-get tag 'javadoc)))
+ (if (or (not property) (plist-get plist property))
+ (funcall fun k plist))))
semantic-java-doc-line-tags)))
@@ -420,61 +417,59 @@ removed from the result list."
(or semantic-java-doc-with-name-tags
(setq semantic-java-doc-with-name-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- k)
+ (lambda (k _p) k)
'with-name)))
(or semantic-java-doc-with-ref-tags
(setq semantic-java-doc-with-ref-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- k)
+ (lambda (k _p) k)
'with-ref)))
(or semantic-java-doc-extra-type-tags
(setq semantic-java-doc-extra-type-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'type (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-extra-function-tags
(setq semantic-java-doc-extra-function-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'function (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-extra-variable-tags
(setq semantic-java-doc-extra-variable-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'variable (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-type-tags
(setq semantic-java-doc-type-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'type (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k)))))
(or semantic-java-doc-function-tags
(setq semantic-java-doc-function-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'function (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k)))))
(or semantic-java-doc-variable-tags
(setq semantic-java-doc-variable-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'variable (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k)))))
)
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 0e4e5faf0a9..8073640a8bd 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -1,4 +1,4 @@
-;;; semantic/lex-spp.el --- Semantic Lexical Pre-processor
+;;; semantic/lex-spp.el --- Semantic Lexical Pre-processor -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -70,31 +70,27 @@
(require 'semantic)
(require 'semantic/lex)
-(declare-function semantic-c-end-of-macro "semantic/bovine/c")
+(declare-function c-end-of-macro "cc-engine")
;;; Code:
-(defvar semantic-lex-spp-macro-symbol-obarray nil
+(defvar-local semantic-lex-spp-macro-symbol-obarray nil
"Table of macro keywords used by the Semantic Preprocessor.
These symbols will be used in addition to those in
`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
-(make-variable-buffer-local 'semantic-lex-spp-macro-symbol-obarray)
-(defvar semantic-lex-spp-project-macro-symbol-obarray nil
+(defvar-local semantic-lex-spp-project-macro-symbol-obarray nil
"Table of macro keywords for this project.
These symbols will be used in addition to those in
`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
-(make-variable-buffer-local 'semantic-lex-spp-project-macro-symbol-obarray)
-(defvar semantic-lex-spp-dynamic-macro-symbol-obarray nil
+(defvar-local semantic-lex-spp-dynamic-macro-symbol-obarray nil
"Table of macro keywords used during lexical analysis.
Macros are lexical symbols which are replaced by other lexical
tokens during lexical analysis. During analysis symbols can be
added and removed from this symbol table.")
-(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray)
-(defvar semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
+(defvar-local semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
"A stack of obarrays for temporarily scoped macro values.")
-(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray-stack)
(defvar semantic-lex-spp-expanded-macro-stack nil
"The stack of lexical SPP macros we have expanded.")
@@ -110,22 +106,12 @@ added and removed from this symbol table.")
Pushes NAME into the macro stack. The above stack is checked
by `semantic-lex-spp-symbol' to not return true for any symbol
currently being expanded."
+ (declare (indent 1) (debug (symbolp def-body)))
`(unwind-protect
(progn
(push ,name semantic-lex-spp-expanded-macro-stack)
,@body)
(pop semantic-lex-spp-expanded-macro-stack)))
-(put 'semantic-lex-with-macro-used 'lisp-indent-function 1)
-
-(add-hook
- 'edebug-setup-hook
- #'(lambda ()
-
- (def-edebug-spec semantic-lex-with-macro-used
- (symbolp def-body)
- )
-
- ))
;;; MACRO TABLE UTILS
;;
@@ -194,7 +180,7 @@ Disable debugging by entering nothing."
(setq semantic-lex-spp-debug-symbol nil)
(setq semantic-lex-spp-debug-symbol sym)))
-(defmacro semantic-lex-spp-validate-value (name value)
+(defmacro semantic-lex-spp-validate-value (_name _value)
"Validate the NAME and VALUE of a macro before it is set."
; `(progn
; (when (not (semantic-lex-spp-value-valid-p ,value))
@@ -216,12 +202,11 @@ the dynamic map."
(semantic-lex-spp-dynamic-map)))
value))
-(defsubst semantic-lex-spp-symbol-remove (name &optional obarray)
+(defsubst semantic-lex-spp-symbol-remove (name &optional map)
"Remove the spp symbol with NAME.
-If optional OBARRAY is non-nil, then use that obarray instead of
+If optional obarray MAP is non-nil, then use that obarray instead of
the dynamic map."
- (unintern name (or obarray
- (semantic-lex-spp-dynamic-map))))
+ (unintern name (or map (semantic-lex-spp-dynamic-map))))
(defun semantic-lex-spp-symbol-push (name value)
"Push macro NAME with VALUE into the map.
@@ -250,7 +235,7 @@ Reverse with `semantic-lex-spp-symbol-pop'."
(stack (semantic-lex-spp-dynamic-map-stack))
(mapsym (intern name map))
(stacksym (intern name stack))
- (oldvalue nil)
+ ;; (oldvalue nil)
)
(if (or (not (boundp stacksym) )
(= (length (symbol-value stacksym)) 0))
@@ -293,10 +278,10 @@ The return list is meant to be saved in a semanticdb table."
(let (macros)
(when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons (cons (symbol-name symbol)
- (symbol-value symbol))
- macros)))
+ (lambda (symbol)
+ (setq macros (cons (cons (symbol-name symbol)
+ (symbol-value symbol))
+ macros)))
semantic-lex-spp-dynamic-macro-symbol-obarray))
macros))
@@ -306,18 +291,18 @@ The value of each symbol is the replacement stream."
(let (macros)
(when (obarrayp semantic-lex-spp-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-macro-symbol-obarray))
(when (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-project-macro-symbol-obarray))
(when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-dynamic-macro-symbol-obarray))
macros))
@@ -328,7 +313,7 @@ For use with semanticdb restoration of state."
;; Default obarray for below is the dynamic map.
(semantic-lex-spp-symbol-set (car e) (cdr e))))
-(defun semantic-lex-spp-reset-hook (start end)
+(defun semantic-lex-spp-reset-hook (start _end)
"Reset anything needed by SPP for parsing.
In this case, reset the dynamic macro symbol table if
START is (point-min).
@@ -358,7 +343,7 @@ Return non-nil if it matches"
(string-match regex value))
))
-(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end argvalues)
+(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end _argvalues)
"Convert lexical macro contents VAL into a macro expansion stream.
These are for simple macro expansions that a user may have typed in directly.
As such, we need to analyze the input text, to figure out what kind of real
@@ -823,7 +808,7 @@ ARGVALUES are values for any arg list, or nil."
;; An analyzer that will push tokens from a macro in place
;; of the macro symbol.
;;
-(defun semantic-lex-spp-analyzer-do-replace (sym val beg end)
+(defun semantic-lex-spp-analyzer-do-replace (_sym val beg end)
"Do the lexical replacement for SYM with VAL.
Argument BEG and END specify the bounds of SYM in the buffer."
(if (not val)
@@ -865,7 +850,7 @@ Argument BEG and END specify the bounds of SYM in the buffer."
))
(define-obsolete-function-alias
'semantic-lex-spp-anlyzer-do-replace
- 'semantic-lex-spp-analyzer-do-replace "25.1")
+ #'semantic-lex-spp-analyzer-do-replace "25.1")
(defvar semantic-lex-spp-replacements-enabled t
"Non-nil means do replacements when finding keywords.
@@ -946,7 +931,7 @@ by another macro."
(save-excursion
(let ((start (match-beginning 0))
(end (match-end 0))
- (peom (save-excursion (semantic-c-end-of-macro) (point))))
+ (peom (save-excursion (c-end-of-macro) (point))))
(condition-case nil
(progn
;; This will throw an error if no closing paren can be found.
@@ -1049,7 +1034,7 @@ and variable state from the current buffer."
(fresh-toks nil)
(toks nil)
(origbuff (current-buffer))
- (analyzer semantic-lex-analyzer)
+ ;; (analyzer semantic-lex-analyzer)
(important-vars '(semantic-lex-spp-macro-symbol-obarray
semantic-lex-spp-project-macro-symbol-obarray
semantic-lex-spp-dynamic-macro-symbol-obarray
@@ -1085,7 +1070,7 @@ and variable state from the current buffer."
(semantic-lex-init)
(semantic-clear-toplevel-cache)
(remove-hook 'semantic-lex-reset-functions
- 'semantic-lex-spp-reset-hook t)
+ #'semantic-lex-spp-reset-hook t)
))
;; Second Cheat: copy key variables regarding macro state from the
@@ -1180,6 +1165,7 @@ of type `spp-macro-def' is to be created.
VALFORM are forms that return the value to be saved for this macro, or nil.
When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
to convert text into a lexical stream for storage in the macro."
+ (declare (debug (&define name stringp stringp form def-body)))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
(val (make-symbol "val"))
@@ -1213,6 +1199,7 @@ REGEXP is a regular expression for the analyzer to match.
See `define-lex-regex-analyzer' for more on regexp.
TOKIDX is an index into REGEXP for which a new lexical token
of type `spp-macro-undef' is to be created."
+ (declare (debug (&define name stringp stringp form)))
(let ((start (make-symbol "start"))
(end (make-symbol "end")))
`(define-lex-regex-analyzer ,name
@@ -1248,7 +1235,7 @@ Note: Not implemented yet."
:group 'semantic
:type 'boolean)
-(defun semantic-lex-spp-merge-header (name)
+(defun semantic-lex-spp-merge-header (_name)
"Extract and merge any macros from the header with NAME.
Finds the header file belonging to NAME, gets the macros
from that file, and then merge the macros with our current
@@ -1273,6 +1260,7 @@ type of include. The return value should be of the form:
(NAME . TYPE)
where NAME is the name of the include, and TYPE is the type of the include,
where a valid symbol is `system', or nil."
+ (declare (debug (&define name stringp stringp form def-body)))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
(val (make-symbol "val"))
@@ -1373,23 +1361,6 @@ If BUFFER is not provided, use the current buffer."
(princ "\n")
))))
-;;; EDEBUG Handlers
-;;
-(add-hook
- 'edebug-setup-hook
- #'(lambda ()
-
- (def-edebug-spec define-lex-spp-macro-declaration-analyzer
- (&define name stringp stringp form def-body)
- )
-
- (def-edebug-spec define-lex-spp-macro-undeclaration-analyzer
- (&define name stringp stringp form)
- )
-
- (def-edebug-spec define-lex-spp-include-analyzer
- (&define name stringp stringp form def-body))))
-
(provide 'semantic/lex-spp)
;; Local variables:
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index fb1a0911106..69f20deeb76 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -192,9 +192,9 @@ If optional PROPERTY is non-nil, call FUN only on every symbol which
as a PROPERTY value. FUN receives a symbol as argument."
(if (obarrayp table)
(mapatoms
- #'(lambda (symbol)
- (if (or (null property) (get symbol property))
- (funcall fun symbol)))
+ (lambda (symbol)
+ (if (or (null property) (get symbol property))
+ (funcall fun symbol)))
table)))
;;; Lexical keyword table handling.
@@ -202,10 +202,9 @@ as a PROPERTY value. FUN receives a symbol as argument."
;; These keywords are keywords defined for using in a grammar with the
;; %keyword declaration, and are not keywords used in Emacs Lisp.
-(defvar semantic-flex-keywords-obarray nil
+(defvar-local semantic-flex-keywords-obarray nil
"Buffer local keyword obarray for the lexical analyzer.
These keywords are matched explicitly, and converted into special symbols.")
-(make-variable-buffer-local 'semantic-flex-keywords-obarray)
(defmacro semantic-lex-keyword-invalid (name)
"Signal that NAME is an invalid keyword name."
@@ -287,7 +286,7 @@ If optional PROPERTY is non-nil, return only keywords which have a
PROPERTY set."
(let (keywords)
(semantic-lex-map-keywords
- #'(lambda (symbol) (setq keywords (cons symbol keywords)))
+ (lambda (symbol) (setq keywords (cons symbol keywords)))
property)
keywords))
@@ -333,9 +332,8 @@ so that analysis can continue, if possible."
;; with the %type declaration. Types represent different syntaxes.
;; See code for `semantic-lex-preset-default-types' for the classic
;; types of syntax.
-(defvar semantic-lex-types-obarray nil
+(defvar-local semantic-lex-types-obarray nil
"Buffer local types obarray for the lexical analyzer.")
-(make-variable-buffer-local 'semantic-lex-types-obarray)
(defun semantic-lex-type-invalid (type)
"Signal that TYPE is an invalid lexical type name."
@@ -464,19 +462,16 @@ If optional PROPERTY is non-nil, return only type symbols which have
PROPERTY set."
(let (types)
(semantic-lex-map-types
- #'(lambda (symbol) (setq types (cons symbol types)))
+ (lambda (symbol) (setq types (cons symbol types)))
property)
types))
;;; Lexical Analyzer framework settings
;;
-;; FIXME change to non-obsolete default.
-(defvar semantic-lex-analyzer 'semantic-flex
+(defvar-local semantic-lex-analyzer #'semantic-lex
"The lexical analyzer used for a given buffer.
-See `semantic-lex' for documentation.
-For compatibility with Semantic 1.x it defaults to `semantic-flex'.")
-(make-variable-buffer-local 'semantic-lex-analyzer)
+See `semantic-lex' for documentation.")
(defvar semantic-lex-tokens
'(
@@ -558,7 +553,7 @@ The key to this alist is the symbol representing token type that
- whitespace: Characters that match `\\s-+' regexp.
This token is produced with `semantic-lex-whitespace'.")
-(defvar semantic-lex-syntax-modifications nil
+(defvar-local semantic-lex-syntax-modifications nil
"Changes to the syntax table for this buffer.
These changes are active only while the buffer is being flexed.
This is a list where each element has the form:
@@ -566,20 +561,17 @@ This is a list where each element has the form:
CHAR is the char passed to `modify-syntax-entry',
and CLASS is the string also passed to `modify-syntax-entry' to define
what syntax class CHAR has.")
-(make-variable-buffer-local 'semantic-lex-syntax-modifications)
-(defvar semantic-lex-syntax-table nil
+(defvar-local semantic-lex-syntax-table nil
"Syntax table used by lexical analysis.
See also `semantic-lex-syntax-modifications'.")
-(make-variable-buffer-local 'semantic-lex-syntax-table)
-(defvar semantic-lex-comment-regex nil
+(defvar-local semantic-lex-comment-regex nil
"Regular expression for identifying comment start during lexical analysis.
This may be automatically set when semantic initializes in a mode, but
may need to be overridden for some special languages.")
-(make-variable-buffer-local 'semantic-lex-comment-regex)
-(defvar semantic-lex-number-expression
+(defvar-local semantic-lex-number-expression
;; This expression was written by David Ponce for Java, and copied
;; here for C and any other similar language.
(eval-when-compile
@@ -628,12 +620,10 @@ FLOATING_POINT_LITERAL:
| [0-9]+<EXPONENT>[fFdD]?
| [0-9]+<EXPONENT>?[fFdD]
;")
-(make-variable-buffer-local 'semantic-lex-number-expression)
-(defvar semantic-lex-depth 0
+(defvar-local semantic-lex-depth 0
"Default lexing depth.
This specifies how many lists to create tokens in.")
-(make-variable-buffer-local 'semantic-lex-depth)
(defvar semantic-lex-unterminated-syntax-end-function
(lambda (_syntax _syntax-start lex-end) lex-end)
@@ -770,6 +760,7 @@ If two analyzers can match the same text, it is important to order the
analyzers so that the one you want to match first occurs first. For
example, it is good to put a number analyzer in front of a symbol
analyzer which might mistake a number for a symbol."
+ (declare (debug (&define name stringp (&rest symbolp))))
`(defun ,name (start end &optional depth length)
,(concat doc "\nSee `semantic-lex' for more information.")
;; Make sure the state of block parsing starts over.
@@ -1069,19 +1060,18 @@ Only in effect if `debug-on-error' is also non-nil."
"For SYNTAX, execute FORMS with protection for unterminated syntax.
If FORMS throws an error, treat this as a syntax problem, and
execute the unterminated syntax code. FORMS should return a position.
-Irregardless of an error, the cursor should be moved to the end of
+Regardless of an error, the cursor should be moved to the end of
the desired syntax, and a position returned.
If `debug-on-error' is set, errors are not caught, so that you can
debug them.
Avoid using a large FORMS since it is duplicated."
+ (declare (indent 1) (debug t))
`(if (and debug-on-error semantic-lex-debug-analyzers)
(progn ,@forms)
(condition-case nil
(progn ,@forms)
(error
(semantic-lex-unterminated-syntax-detected ,syntax)))))
-(put 'semantic-lex-unterminated-syntax-protection
- 'lisp-indent-function 1)
(defmacro define-lex-analyzer (name doc condition &rest forms)
"Create a single lexical analyzer NAME with DOC.
@@ -1106,32 +1096,29 @@ Proper action in FORMS is to move the value of `semantic-lex-end-point' to
after the location of the analyzed entry, and to add any discovered tokens
at the beginning of `semantic-lex-token-stream'.
This can be done by using `semantic-lex-push-token'."
+ (declare (debug (&define name stringp form def-body)))
`(eval-and-compile
- (defvar ,name nil ,doc)
- (defun ,name nil)
- ;; Do this part separately so that re-evaluation rebuilds this code.
- (setq ,name '(,condition ,@forms))
+ ;; This is the real info used by `define-lex' (via semantic-lex-one-token).
+ (defconst ,name '(,condition ,@forms) ,doc)
;; Build a single lexical analyzer function, so the doc for
;; function help is automatically provided, and perhaps the
;; function could be useful for testing and debugging one
;; analyzer.
- (fset ',name (lambda () ,doc
- (let ((semantic-lex-token-stream nil)
- (semantic-lex-end-point (point))
- (semantic-lex-analysis-bounds
- (cons (point) (point-max)))
- (semantic-lex-current-depth 0)
- (semantic-lex-maximum-depth
- semantic-lex-depth)
- )
- (when ,condition ,@forms)
- semantic-lex-token-stream)))
- ))
+ (defun ,name ()
+ ,doc
+ (let ((semantic-lex-token-stream nil)
+ (semantic-lex-end-point (point))
+ (semantic-lex-analysis-bounds (cons (point) (point-max)))
+ (semantic-lex-current-depth 0)
+ (semantic-lex-maximum-depth semantic-lex-depth))
+ (when ,condition ,@forms)
+ semantic-lex-token-stream))))
(defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
"Create a lexical analyzer with NAME and DOC that will match REGEXP.
FORMS are evaluated upon a successful match.
See `define-lex-analyzer' for more about analyzers."
+ (declare (debug (&define name stringp form def-body)))
`(define-lex-analyzer ,name
,doc
(looking-at ,regexp)
@@ -1149,6 +1136,8 @@ expression.
FORMS are evaluated upon a successful match BEFORE the new token is
created. It is valid to ignore FORMS.
See `define-lex-analyzer' for more about analyzers."
+ (declare (debug
+ (&define name stringp form symbolp [ &optional form ] def-body)))
`(define-lex-analyzer ,name
,doc
(looking-at ,regexp)
@@ -1173,6 +1162,7 @@ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM
and CLOSE-DELIM are respectively the open and close delimiters
identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
symbols returned in open and close tokens."
+ (declare (debug (&define name stringp form (&rest form))))
(let ((specs (cons spec1 specs))
spec open olist clist)
(while specs
@@ -1694,6 +1684,7 @@ the error will be caught here without the buffer's cache being thrown
out of date.
If there is an error, the syntax that failed is returned.
If there is no error, then the last value of FORMS is returned."
+ (declare (indent 1) (debug (symbolp def-body)))
(let ((ret (make-symbol "ret"))
(syntax (make-symbol "syntax"))
(start (make-symbol "start"))
@@ -1701,9 +1692,6 @@ If there is no error, then the last value of FORMS is returned."
`(let* ((semantic-lex-unterminated-syntax-end-function
(lambda (,syntax ,start ,end)
(throw ',symbol ,syntax)))
- ;; Delete the below when semantic-flex is fully retired.
- (semantic-flex-unterminated-syntax-end-function
- semantic-lex-unterminated-syntax-end-function)
(,ret (catch ',symbol
(save-excursion
,@forms
@@ -1720,63 +1708,15 @@ If there is no error, then the last value of FORMS is returned."
;;(message "Buffer not currently parsable (%S)." ,ret)
(semantic-parse-tree-unparseable))
,ret)))
-(put 'semantic-lex-catch-errors 'lisp-indent-function 1)
-
-
-;;; Interfacing with edebug
-;;
-(add-hook
- 'edebug-setup-hook
- #'(lambda ()
-
- (def-edebug-spec define-lex
- (&define name stringp (&rest symbolp))
- )
- (def-edebug-spec define-lex-analyzer
- (&define name stringp form def-body)
- )
- (def-edebug-spec define-lex-regex-analyzer
- (&define name stringp form def-body)
- )
- (def-edebug-spec define-lex-simple-regex-analyzer
- (&define name stringp form symbolp [ &optional form ] def-body)
- )
- (def-edebug-spec define-lex-block-analyzer
- (&define name stringp form (&rest form))
- )
- (def-edebug-spec semantic-lex-catch-errors
- (symbolp def-body)
- )
- ))
;;; Compatibility with Semantic 1.x lexical analysis
-;;
-;; NOTE: DELETE THIS SOMEDAY SOON
-
-(semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start "23.2")
-(semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end "23.2")
-(semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text "23.2")
-(semantic-alias-obsolete 'semantic-flex-make-keyword-table 'semantic-lex-make-keyword-table "23.2")
-(semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p "23.2")
-(semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put "23.2")
-(semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get "23.2")
-(semantic-alias-obsolete 'semantic-flex-map-keywords 'semantic-lex-map-keywords "23.2")
-(semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords "23.2")
-(semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer "23.2")
-(semantic-alias-obsolete 'semantic-flex-list 'semantic-lex-list "23.2")
-
-;; This simple scanner uses the syntax table to generate a stream of
-;; simple tokens of the form:
-;;
-;; (SYMBOL START . END)
-;;
-;; Where symbol is the type of thing it is. START and END mark that
-;; objects boundary.
(defvar semantic-flex-tokens semantic-lex-tokens
"An alist of semantic token types.
See variable `semantic-lex-tokens'.")
+(make-obsolete-variable 'semantic-flex-tokens
+ 'semantic-lex-tokens "28.1")
(defvar semantic-flex-unterminated-syntax-end-function
(lambda (_syntax _syntax-start flex-end) flex-end)
@@ -1788,8 +1728,10 @@ FLEX-END is where the lexical analysis was asked to end.
This function can be used for languages that can intelligently fix up
broken syntax, or the exit lexical analysis via `throw' or `signal'
when finding unterminated syntax.")
+(make-obsolete-variable 'semantic-flex-unterminated-syntax-end-function
+ nil "28.1")
-(defvar semantic-flex-extensions nil
+(defvar-local semantic-flex-extensions nil
"Buffer local extensions to the lexical analyzer.
This should contain an alist with a key of a regex and a data element of
a function. The function should both move point, and return a lexical
@@ -1798,9 +1740,9 @@ token of the form:
nil is also a valid return value.
TYPE can be any type of symbol, as long as it doesn't occur as a
nonterminal in the language definition.")
-(make-variable-buffer-local 'semantic-flex-extensions)
+(make-obsolete-variable 'semantic-flex-extensions nil "28.1")
-(defvar semantic-flex-syntax-modifications nil
+(defvar-local semantic-flex-syntax-modifications nil
"Changes to the syntax table for this buffer.
These changes are active only while the buffer is being flexed.
This is a list where each element has the form:
@@ -1808,238 +1750,41 @@ This is a list where each element has the form:
CHAR is the char passed to `modify-syntax-entry',
and CLASS is the string also passed to `modify-syntax-entry' to define
what syntax class CHAR has.")
-(make-variable-buffer-local 'semantic-flex-syntax-modifications)
+(make-obsolete-variable 'semantic-flex-syntax-modifications nil "28.1")
-(defvar semantic-ignore-comments t
+(defvar-local semantic-ignore-comments t
"Default comment handling.
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)
+(make-obsolete-variable 'semantic-ignore-comments nil "28.1")
-(defvar semantic-flex-enable-newlines nil
+(defvar-local semantic-flex-enable-newlines nil
"When flexing, report newlines as syntactic elements.
Useful for languages where the newline is a special case terminator.
Only set this on a per mode basis, not globally.")
-(make-variable-buffer-local 'semantic-flex-enable-newlines)
+(make-obsolete-variable 'semantic-flex-enable-newlines nil "28.1")
-(defvar semantic-flex-enable-whitespace nil
+(defvar-local semantic-flex-enable-whitespace nil
"When flexing, report whitespace as syntactic elements.
Useful for languages where the syntax is whitespace dependent.
Only set this on a per mode basis, not globally.")
-(make-variable-buffer-local 'semantic-flex-enable-whitespace)
+(make-obsolete-variable 'semantic-flex-enable-whitespace nil "28.1")
-(defvar semantic-flex-enable-bol nil
+(defvar-local semantic-flex-enable-bol nil
"When flexing, report beginning of lines as syntactic elements.
Useful for languages like python which are indentation sensitive.
Only set this on a per mode basis, not globally.")
-(make-variable-buffer-local 'semantic-flex-enable-bol)
+(make-obsolete-variable 'semantic-flex-enable-bol nil "28.1")
-(defvar semantic-number-expression semantic-lex-number-expression
+(defvar-local semantic-number-expression semantic-lex-number-expression
"See variable `semantic-lex-number-expression'.")
-(make-variable-buffer-local 'semantic-number-expression)
+(make-obsolete-variable 'semantic-number-expression
+ 'semantic-lex-number-expression "28.1")
-(defvar semantic-flex-depth 0
+(defvar-local semantic-flex-depth 0
"Default flexing depth.
This specifies how many lists to create tokens in.")
-(make-variable-buffer-local 'semantic-flex-depth)
-
-(defun semantic-flex (start end &optional depth length)
- "Using the syntax table, do something roughly equivalent to flex.
-Semantically check between START and END. Optional argument DEPTH
-indicates at what level to scan over entire lists.
-The return value is a token stream. Each element is a list, such of
-the form (symbol start-expression . end-expression) where SYMBOL
-denotes the token type.
-See `semantic-flex-tokens' variable for details on token types.
-END does not mark the end of the text scanned, only the end of the
-beginning of text scanned. Thus, if a string extends past END, the
-end of the return token will be larger than END. To truly restrict
-scanning, use `narrow-to-region'.
-The last argument, LENGTH specifies that `semantic-flex' should only
-return LENGTH tokens."
- (declare (obsolete define-lex "23.2"))
- (if (not semantic-flex-keywords-obarray)
- (setq semantic-flex-keywords-obarray [ nil ]))
- (let ((ts nil)
- (pos (point))
- (ep nil)
- (curdepth 0)
- (cs (if comment-start-skip
- (concat "\\(\\s<\\|" comment-start-skip "\\)")
- (concat "\\(\\s<\\)")))
- (newsyntax (copy-syntax-table (syntax-table)))
- (mods semantic-flex-syntax-modifications)
- ;; Use the default depth if it is not specified.
- (depth (or depth semantic-flex-depth)))
- ;; Update the syntax table
- (while mods
- (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax)
- (setq mods (cdr mods)))
- (with-syntax-table newsyntax
- (goto-char start)
- (while (and (< (point) end) (or (not length) (<= (length ts) length)))
- (cond
- ;; catch beginning of lines when needed.
- ;; Must be done before catching any other tokens!
- ((and semantic-flex-enable-bol
- (bolp)
- ;; Just insert a (bol N . N) token in the token stream,
- ;; without moving the point. N is the point at the
- ;; beginning of line.
- (setq ts (cons (cons 'bol (cons (point) (point))) ts))
- nil)) ;; CONTINUE
- ;; special extensions, includes whitespace, nl, etc.
- ((and semantic-flex-extensions
- (let ((fe semantic-flex-extensions)
- (r nil))
- (while fe
- (if (looking-at (car (car fe)))
- (setq ts (cons (funcall (cdr (car fe))) ts)
- r t
- fe nil
- ep (point)))
- (setq fe (cdr fe)))
- (if (and r (not (car ts))) (setq ts (cdr ts)))
- r)))
- ;; catch newlines when needed
- ((looking-at "\\s-*\\(\n\\|\\s>\\)")
- (if semantic-flex-enable-newlines
- (setq ep (match-end 1)
- ts (cons (cons 'newline
- (cons (match-beginning 1) ep))
- ts))))
- ;; catch whitespace when needed
- ((looking-at "\\s-+")
- (if semantic-flex-enable-whitespace
- ;; Language wants whitespaces, link them together.
- (if (eq (car (car ts)) 'whitespace)
- (setcdr (cdr (car ts)) (match-end 0))
- (setq ts (cons (cons 'whitespace
- (cons (match-beginning 0)
- (match-end 0)))
- ts)))))
- ;; numbers
- ((and semantic-number-expression
- (looking-at semantic-number-expression))
- (setq ts (cons (cons 'number
- (cons (match-beginning 0)
- (match-end 0)))
- ts)))
- ;; symbols
- ((looking-at "\\(\\sw\\|\\s_\\)+")
- (setq ts (cons (cons
- ;; Get info on if this is a keyword or not
- (or (semantic-lex-keyword-p (match-string 0))
- 'symbol)
- (cons (match-beginning 0) (match-end 0)))
- ts)))
- ;; Character quoting characters (ie, \n as newline)
- ((looking-at "\\s\\+")
- (setq ts (cons (cons 'charquote
- (cons (match-beginning 0) (match-end 0)))
- ts)))
- ;; Open parens, or semantic-lists.
- ((looking-at "\\s(")
- (if (or (not depth) (< curdepth depth))
- (progn
- (setq curdepth (1+ curdepth))
- (setq ts (cons (cons 'open-paren
- (cons (match-beginning 0) (match-end 0)))
- ts)))
- (setq ts (cons
- (cons 'semantic-list
- (cons (match-beginning 0)
- (save-excursion
- (condition-case nil
- (forward-list 1)
- ;; This case makes flex robust
- ;; to broken lists.
- (error
- (goto-char
- (funcall
- semantic-flex-unterminated-syntax-end-function
- 'semantic-list
- start end))))
- (setq ep (point)))))
- ts))))
- ;; Close parens
- ((looking-at "\\s)")
- (setq ts (cons (cons 'close-paren
- (cons (match-beginning 0) (match-end 0)))
- ts))
- (setq curdepth (1- curdepth)))
- ;; String initiators
- ((looking-at "\\s\"")
- ;; Zing to the end of this string.
- (setq ts (cons (cons 'string
- (cons (match-beginning 0)
- (save-excursion
- (condition-case nil
- (forward-sexp 1)
- ;; This case makes flex
- ;; robust to broken strings.
- (error
- (goto-char
- (funcall
- semantic-flex-unterminated-syntax-end-function
- 'string
- start end))))
- (setq ep (point)))))
- ts)))
- ;; comments
- ((looking-at cs)
- (if (and semantic-ignore-comments
- (not semantic-flex-enable-whitespace))
- ;; If the language doesn't deal with comments nor
- ;; whitespaces, ignore them here.
- (let ((comment-start-point (point)))
- (forward-comment 1)
- (if (eq (point) comment-start-point)
- ;; In this case our start-skip string failed
- ;; to work properly. Lets try and move over
- ;; whatever white space we matched to begin
- ;; with.
- (skip-syntax-forward "-.'" (point-at-eol))
- ;;(forward-comment 1)
- ;; Generate newline token if enabled
- (if (and semantic-flex-enable-newlines
- (bolp))
- (backward-char 1)))
- (if (eq (point) comment-start-point)
- (error "Strange comment syntax prevents lexical analysis"))
- (setq ep (point)))
- (let ((tk (if semantic-ignore-comments 'whitespace 'comment)))
- (save-excursion
- (forward-comment 1)
- ;; Generate newline token if enabled
- (if (and semantic-flex-enable-newlines
- (bolp))
- (backward-char 1))
- (setq ep (point)))
- ;; Language wants comments or want them as whitespaces,
- ;; link them together.
- (if (eq (car (car ts)) tk)
- (setcdr (cdr (car ts)) ep)
- (setq ts (cons (cons tk (cons (match-beginning 0) ep))
- ts))))))
- ;; punctuation
- ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)")
- (setq ts (cons (cons 'punctuation
- (cons (match-beginning 0) (match-end 0)))
- ts)))
- ;; unknown token
- (t
- (error "What is that?")))
- (goto-char (or ep (match-end 0)))
- (setq ep nil)))
- ;; maybe catch the last beginning of line when needed
- (and semantic-flex-enable-bol
- (= (point) end)
- (bolp)
- (setq ts (cons (cons 'bol (cons (point) (point))) ts)))
- (goto-char pos)
- ;;(message "Flexing muscles...done")
- (nreverse ts)))
+(make-obsolete-variable 'semantic-flex-depth nil "28.1")
(provide 'semantic/lex)
diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el
index 956eb681f2c..2e77e6b75fb 100644
--- a/lisp/cedet/semantic/mru-bookmark.el
+++ b/lisp/cedet/semantic/mru-bookmark.el
@@ -1,4 +1,4 @@
-;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
+;;; semantic/mru-bookmark.el --- Automatic bookmark tracking -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -85,7 +85,7 @@ Nice values include the following:
)
"A single bookmark.")
-(cl-defmethod initialize-instance :after ((sbm semantic-bookmark) &rest fields)
+(cl-defmethod initialize-instance :after ((sbm semantic-bookmark) &rest _fields)
"Initialize the bookmark SBM with details about :tag."
(condition-case nil
(save-excursion
@@ -216,7 +216,7 @@ Cause tags in the ring to become unlinked."
(setq idx (1+ idx)))))
(add-hook 'semantic-before-toplevel-cache-flush-hook
- 'semantic-mrub-cache-flush-fcn)
+ #'semantic-mrub-cache-flush-fcn)
;;; EDIT tracker
;;
@@ -246,8 +246,8 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
:group 'semantic-modes
:type 'boolean
:require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
+ :initialize #'custom-initialize-default
+ :set (lambda (_sym val)
(global-semantic-mru-bookmark-mode (if val 1 -1))))
;;;###autoload
@@ -266,7 +266,7 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
(defvar semantic-mru-bookmark-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km "\C-xB" 'semantic-mrub-switch-tags)
+ (define-key km "\C-xB" #'semantic-mrub-switch-tags)
km)
"Keymap for mru-bookmark minor mode.")
@@ -289,14 +289,14 @@ non-nil if the minor mode is enabled."
(error "Buffer %s was not set up for parsing"
(buffer-name)))
(add-hook 'semantic-edits-new-change-functions
- 'semantic-mru-bookmark-change-hook-fcn nil t)
+ #'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-functions
- 'semantic-mru-bookmark-change-hook-fcn t)
+ #'semantic-mru-bookmark-change-hook-fcn t)
(remove-hook 'semantic-edits-move-change-hooks
- 'semantic-mru-bookmark-change-hook-fcn t)))
+ #'semantic-mru-bookmark-change-hook-fcn t)))
(semantic-add-minor-mode 'semantic-mru-bookmark-mode
"k")
diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el
index d7cd8e1940c..debdfd1dc04 100644
--- a/lisp/cedet/semantic/sb.el
+++ b/lisp/cedet/semantic/sb.el
@@ -1,4 +1,4 @@
-;;; semantic/sb.el --- Semantic tag display for speedbar
+;;; semantic/sb.el --- Semantic tag display for speedbar -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -73,10 +73,10 @@ use the `speedbar-line-file' to get this info if needed."
(defmacro semantic-sb-with-tag-buffer (tag &rest forms)
"Set the current buffer to the origin of TAG and execute FORMS.
Restore the old current buffer when completed."
+ (declare (indent 1) (debug t))
`(save-excursion
(semantic-sb-tag-set-buffer ,tag)
,@forms))
-(put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1)
;;; Button Generation
;;
@@ -294,7 +294,7 @@ TEXT TOKEN and INDENT are the details."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun semantic-sb-token-jump (text token indent)
+(defun semantic-sb-token-jump (_text token indent)
"Jump to the location specified in token.
TEXT TOKEN and INDENT are the details."
(let ((file
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el
index 31576d29bc6..2d806e58eeb 100644
--- a/lisp/cedet/semantic/scope.el
+++ b/lisp/cedet/semantic/scope.el
@@ -1,4 +1,4 @@
-;;; semantic/scope.el --- Analyzer Scope Calculations
+;;; semantic/scope.el --- Analyzer Scope Calculations -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -115,7 +115,7 @@ Saves scoping information between runs of the analyzer.")
)
(cl-defmethod semanticdb-synchronize ((cache semantic-scope-cache)
- new-tags)
+ _new-tags)
"Synchronize a CACHE with some NEW-TAGS."
(semantic-reset cache))
@@ -262,7 +262,7 @@ are from nesting data types."
(semantic-go-to-tag pparent)
(setq stack (semantic-find-tag-by-overlay (point)))
;; Step one, find the merged version of stack in the typecache.
- (let* ((stacknames (reverse (mapcar 'semantic-tag-name stack)))
+ (let* ((stacknames (reverse (mapcar #'semantic-tag-name stack)))
(tc nil)
)
;; @todo - can we use the typecache ability to
@@ -317,7 +317,7 @@ are from nesting data types."
;; returnlist is empty.
(while snlist
(setq fullsearchname
- (append (mapcar 'semantic-tag-name returnlist)
+ (append (mapcar #'semantic-tag-name returnlist)
(list (car snlist)))) ;; Next one
(setq ptag
(semanticdb-typecache-find fullsearchname))
@@ -325,8 +325,8 @@ are from nesting data types."
(when (or (not ptag)
(not (semantic-tag-of-class-p ptag 'type)))
(let ((rawscope
- (apply 'append
- (mapcar 'semantic-tag-type-members
+ (apply #'append
+ (mapcar #'semantic-tag-type-members
(cons (car returnlist) scopetypes)
)))
)
@@ -541,7 +541,7 @@ tag is not something you can complete from within TYPE."
(setq leftover (cons S leftover)))))
(nreverse leftover)))
-(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit protection)
+(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit _protection)
"Return all parts of TYPE, a tag representing a TYPE declaration.
SCOPE is the scope object.
NOINHERIT turns off searching of inherited tags.
@@ -562,7 +562,7 @@ such as `public' or `private'."
;; @TODO - is this line needed?? Try w/out for a while
;; @note - I think C++ says no. elisp might, but methods
;; look like defuns, so it makes no difference.
- (extmeth nil) ; (semantic-tag-external-member-children type t))
+ ;;(extmeth nil) ; (semantic-tag-external-member-children type t))
;; INHERITED are tags found in classes that our TYPE tag
;; inherits from. Do not do this if it was not requested.
@@ -584,7 +584,7 @@ such as `public' or `private'."
(setq slots (nreverse copyslots))
))
;; Flatten the database output.
- (append slots extmeth inherited)
+ (append slots nil inherited) ;; extmeth
)))
(defun semantic-analyze-scoped-inherited-tags (type scope access)
diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el
index 63327d1817e..19530094fbe 100644
--- a/lisp/cedet/semantic/senator.el
+++ b/lisp/cedet/semantic/senator.el
@@ -1,4 +1,4 @@
-;;; semantic/senator.el --- SEmantic NAvigaTOR
+;;; semantic/senator.el --- SEmantic NAvigaTOR -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -60,7 +60,6 @@ A tag class is a symbol, such as `variable', `function', or `type'.
As a special exception, if the value is nil, Senator's navigation
commands recognize all tag classes."
- :group 'senator
:type '(repeat (symbol)))
;;;###autoload
(make-variable-buffer-local 'senator-step-at-tag-classes)
@@ -78,7 +77,6 @@ commands stop at the beginning of every tag.
If t, the navigation commands stop at the start and end of any
tag, where possible."
- :group 'senator
:type '(choice :tag "Identifiers"
(repeat :menu-tag "Symbols" (symbol))
(const :tag "All" t)))
@@ -87,7 +85,6 @@ tag, where possible."
(defcustom senator-highlight-found nil
"If non-nil, Senator commands momentarily highlight found tags."
- :group 'senator
:type 'boolean)
(make-variable-buffer-local 'senator-highlight-found)
@@ -193,7 +190,6 @@ source."
'(code block)
"List of ignored tag classes.
Tags of those classes are excluded from search."
- :group 'senator
:type '(repeat (symbol :tag "class")))
(defun senator-search-default-tag-filter (tag)
@@ -461,7 +457,7 @@ filters in `senator-search-tag-filter-functions' remain active."
((symbolp classes)
(list classes))
((stringp classes)
- (mapcar 'read (split-string classes)))
+ (mapcar #'read (split-string classes)))
(t
(signal 'wrong-type-argument (list classes)))
))
@@ -470,11 +466,10 @@ filters in `senator-search-tag-filter-functions' remain active."
senator--search-filter t)
(kill-local-variable 'senator--search-filter)
(if classes
- (let ((tag (make-symbol "tag"))
- (names (mapconcat 'symbol-name classes "', `")))
- (set (make-local-variable 'senator--search-filter)
- `(lambda (,tag)
- (memq (semantic-tag-class ,tag) ',classes)))
+ (let ((names (mapconcat #'symbol-name classes "', `")))
+ (setq-local senator--search-filter
+ (lambda (tag)
+ (memq (semantic-tag-class tag) classes)))
(add-hook 'senator-search-tag-filter-functions
senator--search-filter nil t)
(message "Limit search to `%s' tags" names))
@@ -601,12 +596,11 @@ Makes C/C++ language like assumptions."
)
(t nil)))
-(defvar senator-isearch-semantic-mode nil
+(defvar-local senator-isearch-semantic-mode nil
"Non-nil if isearch does semantic search.
This is a buffer local variable.")
-(make-variable-buffer-local 'senator-isearch-semantic-mode)
-(defun senator-beginning-of-defun (&optional arg)
+(defun senator-beginning-of-defun (&optional _arg)
"Move backward to the beginning of a defun.
Use semantic tags to navigate.
ARG is the number of tags to navigate (not yet implemented)."
@@ -621,7 +615,7 @@ ARG is the number of tags to navigate (not yet implemented)."
(goto-char (semantic-tag-start tag)))
(beginning-of-line))))
-(defun senator-end-of-defun (&optional arg)
+(defun senator-end-of-defun (&optional _arg)
"Move forward to next end of defun.
Use semantic tags to navigate.
ARG is the number of tags to navigate (not yet implemented)."
@@ -810,7 +804,7 @@ if available."
(defun senator-lazy-highlight-update ()
"Force lazy highlight update."
(lazy-highlight-cleanup t)
- (set 'isearch-lazy-highlight-last-string nil)
+ (setq isearch-lazy-highlight-last-string nil)
(setq isearch-adjusted t)
(isearch-update))
@@ -857,17 +851,17 @@ Use a senator search function when semantic isearch mode is enabled."
;; senator one.
(when (and (local-variable-p 'isearch-search-fun-function)
(not (local-variable-p 'senator-old-isearch-search-fun)))
- (set (make-local-variable 'senator-old-isearch-search-fun)
- isearch-search-fun-function))
- (set (make-local-variable 'isearch-search-fun-function)
- 'senator-isearch-search-fun))
+ (setq-local senator-old-isearch-search-fun
+ isearch-search-fun-function))
+ (setq-local isearch-search-fun-function
+ #'senator-isearch-search-fun))
;; When `senator-isearch-semantic-mode' is off restore the
;; previous `isearch-search-fun-function'.
(when (eq isearch-search-fun-function 'senator-isearch-search-fun)
(if (local-variable-p 'senator-old-isearch-search-fun)
(progn
- (set (make-local-variable 'isearch-search-fun-function)
- senator-old-isearch-search-fun)
+ (setq-local isearch-search-fun-function
+ senator-old-isearch-search-fun)
(kill-local-variable 'senator-old-isearch-search-fun))
(kill-local-variable 'isearch-search-fun-function)))))
diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el
index b0e938d98c7..b4b09dc02c8 100644
--- a/lisp/cedet/semantic/sort.el
+++ b/lisp/cedet/semantic/sort.el
@@ -1,6 +1,6 @@
-;;; semantic/sort.el --- Utilities for sorting and re-arranging tag tables.
+;;; semantic/sort.el --- Utilities for sorting and re-arranging tag tables. -*- lexical-binding: t; -*-
-;;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -46,11 +46,7 @@
(defun semantic-string-lessp-ci (s1 s2)
"Case insensitive version of `string-lessp'.
Argument S1 and S2 are the strings to compare."
- ;; Use downcase instead of upcase because an average name
- ;; has more lower case characters.
- (if (fboundp 'compare-strings)
- (eq (compare-strings s1 0 nil s2 0 nil t) -1)
- (string-lessp (downcase s1) (downcase s2))))
+ (eq (compare-strings s1 0 nil s2 0 nil t) -1))
(defun semantic-sort-tag-type (tag)
"Return a type string for TAG guaranteed to be a string."
@@ -237,8 +233,7 @@ unmodified as components of their parent tags."
(semantic-flatten-tags-table components)
lists)))))
table)
- (apply 'append (nreverse lists))
- ))
+ (apply #'append (nreverse lists))))
;;; Buckets:
@@ -314,11 +309,10 @@ may re-organize the list with side-effects."
;; external members, and bring them together in a cloned copy of the
;; class tag.
;;
-(defvar semantic-orphaned-member-metaparent-type "class"
+(defvar-local semantic-orphaned-member-metaparent-type "class"
"In `semantic-adopt-external-members', the type of 'type for metaparents.
A metaparent is a made-up type semantic token used to hold the child list
of orphaned members of a named type.")
-(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
(defvar semantic-mark-external-member-function nil
"Function called when an externally defined orphan is found.
@@ -525,12 +519,11 @@ See `semantic-tag-external-member-children' for details."
(semantic-tag-name tag) tag)))
(if m (apply #'append (mapcar #'cdr m))))
(semantic--find-tags-by-function
- `(lambda (tok)
- ;; This bit of annoying backquote forces the contents of
- ;; tag into the generated lambda.
- (semantic-tag-external-member-p ',tag tok))
- (current-buffer))
- ))
+ (lambda (tok)
+ ;; This bit of annoying backquote forces the contents of
+ ;; tag into the generated lambda.
+ (semantic-tag-external-member-p tag tok))
+ (current-buffer))))
(define-overloadable-function semantic-tag-external-class (tag)
"Return a list of real tags that faux TAG might represent.
@@ -545,6 +538,8 @@ likely derived, then this function is needed."
(:override)
)
+(defvar semanticdb-search-system-databases)
+
(defun semantic-tag-external-class-default (tag)
"Return a list of real tags that faux TAG might represent.
See `semantic-tag-external-class' for details."
diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el
index c053747a560..701f9ad3e03 100644
--- a/lisp/cedet/semantic/symref.el
+++ b/lisp/cedet/semantic/symref.el
@@ -1,4 +1,4 @@
-;;; semantic/symref.el --- Symbol Reference API
+;;; semantic/symref.el --- Symbol Reference API -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -144,7 +144,7 @@ ARGS are the initialization arguments to pass to the created class."
)
(when (not (class-p class))
(error "Unknown symref tool %s" semantic-symref-tool))
- (setq inst (apply 'make-instance class args))
+ (setq inst (apply #'make-instance class args))
inst))
(defvar semantic-symref-last-result nil
@@ -427,7 +427,7 @@ until the next command is executed."
(kill-buffer buff)))
semantic-symref-recently-opened-buffers)
(setq semantic-symref-recently-opened-buffers nil)
- (remove-hook 'post-command-hook 'semantic-symref-cleanup-recent-buffers-fcn)
+ (remove-hook 'post-command-hook #'semantic-symref-cleanup-recent-buffers-fcn)
)
(cl-defmethod semantic-symref-result-get-tags ((result semantic-symref-result)
@@ -453,7 +453,7 @@ already."
lines)))
;; Kill off dead buffers, unless we were requested to leave them open.
(if (not open-buffers)
- (add-hook 'post-command-hook 'semantic-symref-cleanup-recent-buffers-fcn)
+ (add-hook 'post-command-hook #'semantic-symref-cleanup-recent-buffers-fcn)
;; Else, just clear the saved buffers so they aren't deleted later.
(setq semantic-symref-recently-opened-buffers nil)
)
@@ -511,9 +511,10 @@ Optional OPEN-BUFFERS, when nil will use a faster version of
`find-file' when a file needs to be opened. If non-nil, then
normal buffer initialization will be used.
This function will leave buffers loaded from a file open, but
-will add buffers that must be opened to `semantic-symref-recently-opened-buffers'.
-Any caller MUST deal with that variable, either clearing it, or deleting the
-buffers that were opened."
+will add buffers that must be opened to
+`semantic-symref-recently-opened-buffers'.
+Any caller MUST deal with that variable, either clearing it, or
+deleting the buffers that were opened."
(let* ((line (car hit))
(file (cdr hit))
(buff (find-buffer-visiting file))
diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el
index 3686e519460..e63b7a7e914 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.
+;;; semantic/symref/cscope.el --- Semantic-symref support via cscope -*- lexical-binding: t; -*-
-;;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el
index a40ce13f3d6..7ef3cd90d67 100644
--- a/lisp/cedet/semantic/symref/filter.el
+++ b/lisp/cedet/semantic/symref/filter.el
@@ -1,4 +1,4 @@
-;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy.
+;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -48,7 +48,7 @@
"Determine if the tag TARGET is used at POSITION in the current buffer.
Return non-nil for a match."
(semantic-analyze-current-symbol
- (lambda (start end prefix)
+ (lambda (_start _end prefix)
(let ((tag (car (nreverse prefix))))
(and (semantic-tag-p tag)
(semantic-equivalent-tag-p target tag))))
@@ -97,7 +97,7 @@ tag that contains point, and return that."
(Lcount 0))
(when (semantic-tag-p target)
(semantic-symref-hits-in-region
- target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
+ target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount)))
(semantic-tag-start tag)
(semantic-tag-end tag))
(when (called-interactively-p 'interactive)
@@ -106,6 +106,8 @@ tag that contains point, and return that."
(semantic-elapsed-time start nil)))
Lcount)))
+(defvar srecode-field-archive)
+
(defun semantic-symref-rename-local-variable ()
"Fancy way to rename the local variable under point.
Depends on the SRecode Field editing API."
@@ -140,7 +142,7 @@ Depends on the SRecode Field editing API."
(region nil)
)
(semantic-symref-hits-in-region
- target (lambda (start end prefix)
+ target (lambda (start end _prefix)
;; For every valid hit, create one field.
(srecode-field "LOCAL" :name "LOCAL" :start start :end end))
(semantic-tag-start tag) (semantic-tag-end tag))
diff --git a/lisp/cedet/semantic/symref/global.el b/lisp/cedet/semantic/symref/global.el
index 7f63e4ddbc0..23e40349a6b 100644
--- a/lisp/cedet/semantic/symref/global.el
+++ b/lisp/cedet/semantic/symref/global.el
@@ -1,4 +1,4 @@
-;;; semantic/symref/global.el --- Use GNU Global for symbol references
+;;; semantic/symref/global.el --- Use GNU Global for symbol references -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el
index c08dbd6f997..180d779a780 100644
--- a/lisp/cedet/semantic/symref/grep.el
+++ b/lisp/cedet/semantic/symref/grep.el
@@ -1,4 +1,4 @@
-;;; semantic/symref/grep.el --- Symref implementation using find/grep
+;;; semantic/symref/grep.el --- Symref implementation using find/grep -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -167,24 +167,11 @@ This shell should support pipe redirect syntax."
(with-current-buffer b
(erase-buffer)
(setq default-directory rootdir)
-
- (if (not (fboundp 'grep-compute-defaults))
-
- ;; find . -type f -print0 | xargs -0 -e grep -nH -e
- ;; Note : I removed -e as it is not posix, nor necessary it seems.
-
- (let ((cmd (concat "find " (file-local-name rootdir)
- " -type f " filepattern " -print0 "
- "| xargs -0 grep -H " grepflags "-e " greppat)))
- ;;(message "Old command: %s" cmd)
- (process-file semantic-symref-grep-shell nil b nil
- shell-command-switch cmd)
- )
- (let ((cmd (semantic-symref-grep-use-template
- (file-local-name rootdir) filepattern grepflags greppat)))
- (process-file semantic-symref-grep-shell nil b nil
- shell-command-switch cmd))
- ))
+ (let ((cmd (semantic-symref-grep-use-template
+ (directory-file-name (file-local-name rootdir))
+ filepattern grepflags greppat)))
+ (process-file semantic-symref-grep-shell nil b nil
+ shell-command-switch cmd)))
(setq ans (semantic-symref-parse-tool-output tool b))
;; Return the answer
ans))
diff --git a/lisp/cedet/semantic/symref/idutils.el b/lisp/cedet/semantic/symref/idutils.el
index 4a41355dd69..3e3e3b0a940 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
+;;; semantic/symref/idutils.el --- Symref implementation for idutils -*- lexical-binding: t; -*-
-;;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el
index afbef147943..2e447bbc582 100644
--- a/lisp/cedet/semantic/symref/list.el
+++ b/lisp/cedet/semantic/symref/list.el
@@ -1,4 +1,4 @@
-;;; semantic/symref/list.el --- Symref Output List UI.
+;;; semantic/symref/list.el --- Symref Output List UI -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -85,10 +85,12 @@ current project to find references to the input SYM. The
references are the organized by file and the name of the function
they are used in.
Display the references in `semantic-symref-results-mode'."
- (interactive (list (let ((tag (semantic-current-tag)))
- (read-string " Symrefs for: " nil nil
- (when tag
- (regexp-quote (semantic-tag-name tag)))))))
+ (interactive (list (let* ((tag (semantic-current-tag))
+ (default (when tag
+ (regexp-quote
+ (semantic-tag-name tag)))))
+ (read-string (format-prompt " Symrefs for" default)
+ nil nil default))))
;; FIXME: Shouldn't the input be in Emacs regexp format, for
;; consistency? Converting it to extended is not hard.
(semantic-fetch-tags)
@@ -106,20 +108,20 @@ Display the references in `semantic-symref-results-mode'."
(defvar semantic-symref-results-mode-map
(let ((km (make-sparse-keymap)))
(suppress-keymap km)
- (define-key km "\C-i" 'forward-button)
- (define-key km "\M-C-i" 'backward-button)
- (define-key km " " 'push-button)
- (define-key km "-" 'semantic-symref-list-toggle-showing)
- (define-key km "=" 'semantic-symref-list-toggle-showing)
- (define-key km "+" 'semantic-symref-list-toggle-showing)
- (define-key km "n" 'semantic-symref-list-next-line)
- (define-key km "p" 'semantic-symref-list-prev-line)
- (define-key km "q" 'quit-window)
- (define-key km "\C-c\C-e" 'semantic-symref-list-expand-all)
- (define-key km "\C-c\C-r" 'semantic-symref-list-contract-all)
- (define-key km "R" 'semantic-symref-list-rename-open-hits)
- (define-key km "(" 'semantic-symref-list-create-macro-on-open-hit)
- (define-key km "E" 'semantic-symref-list-call-macro-on-open-hits)
+ (define-key km "\C-i" #'forward-button)
+ (define-key km "\M-C-i" #'backward-button)
+ (define-key km " " #'push-button)
+ (define-key km "-" #'semantic-symref-list-toggle-showing)
+ (define-key km "=" #'semantic-symref-list-toggle-showing)
+ (define-key km "+" #'semantic-symref-list-toggle-showing)
+ (define-key km "n" #'semantic-symref-list-next-line)
+ (define-key km "p" #'semantic-symref-list-prev-line)
+ (define-key km "q" #'quit-window)
+ (define-key km "\C-c\C-e" #'semantic-symref-list-expand-all)
+ (define-key km "\C-c\C-r" #'semantic-symref-list-contract-all)
+ (define-key km "R" #'semantic-symref-list-rename-open-hits)
+ (define-key km "(" #'semantic-symref-list-create-macro-on-open-hit)
+ (define-key km "E" #'semantic-symref-list-call-macro-on-open-hits)
km)
"Keymap used in `semantic-symref-results-mode'.")
@@ -174,7 +176,7 @@ Display the references in `semantic-symref-results-mode'."
(switch-to-buffer-other-window buff)
(set-buffer buff)
(semantic-symref-results-mode)
- (set (make-local-variable 'semantic-symref-current-results) res)
+ (setq-local semantic-symref-current-results res)
(semantic-symref-results-dump res)
(goto-char (point-min))))
@@ -182,7 +184,7 @@ Display the references in `semantic-symref-results-mode'."
"Major-mode for displaying Semantic Symbol Reference results."
(buffer-disable-undo)
;; FIXME: Why bother turning off font-lock?
- (set (make-local-variable 'font-lock-global-modes) nil)
+ (setq-local font-lock-global-modes nil)
(font-lock-mode -1))
(defcustom semantic-symref-results-summary-function 'semantic-format-tag-prototype
diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el
index a55cdd50b6e..06dd274b323 100644
--- a/lisp/cedet/semantic/tag-file.el
+++ b/lisp/cedet/semantic/tag-file.el
@@ -1,4 +1,4 @@
-;;; semantic/tag-file.el --- Routines that find files based on tags.
+;;; semantic/tag-file.el --- Routines that find files based on tags. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
@@ -101,9 +101,6 @@ PARENT can also be a `semanticdb-table' object."
)
)
-(make-obsolete-overload 'semantic-find-nonterminal
- 'semantic-go-to-tag "23.2")
-
;;; Dependencies
;;
;; A tag which is of type 'include specifies a dependency.
@@ -175,9 +172,6 @@ Depends on `semantic-dependency-include-path' for searching. Always searches
nil)
)))
-(make-obsolete-overload 'semantic-find-dependency
- 'semantic-dependency-tag-file "23.2")
-
;;; PROTOTYPE FILE
;;
;; In C, a function in the .c file often has a representation in a
@@ -199,13 +193,6 @@ file prototypes belong in."
(if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
(match-string 1))))))
-(semantic-alias-obsolete 'semantic-find-nonterminal
- 'semantic-go-to-tag "23.2")
-
-(semantic-alias-obsolete 'semantic-find-dependency
- 'semantic-dependency-tag-file "23.2")
-
-
(provide 'semantic/tag-file)
;; Local variables:
diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el
index 9d101cf6e8c..3aa1a62901c 100644
--- a/lisp/cedet/semantic/tag-ls.el
+++ b/lisp/cedet/semantic/tag-ls.el
@@ -1,4 +1,4 @@
-;;; semantic/tag-ls.el --- Language Specific override functions for tags
+;;; semantic/tag-ls.el --- Language Specific override functions for tags -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2004, 2006-2021 Free Software Foundation, Inc.
@@ -93,10 +93,11 @@ for a given mode at a more granular level.
Note that :type, :name, and anything in IGNORABLE-ATTRIBUTES will
not be passed to this function.
-Modes that override this function can call `semantic--tag-attribute-similar-p-default'
-to do the default equality tests if ATTR is not special for that mode.")
+Modes that override this function can call
+`semantic--tag-attribute-similar-p-default' to do the default equality tests if
+ATTR is not special for that mode.")
-(defun semantic--tag-attribute-similar-p-default (attr value1 value2 ignorable-attributes)
+(defun semantic--tag-attribute-similar-p-default (_attr value1 value2 ignorable-attributes)
"For ATTR, VALUE1, VALUE2 and IGNORABLE-ATTRIBUTES, test for similarity."
(cond
;; Tag sublists require special testing.
@@ -108,7 +109,7 @@ to do the default equality tests if ATTR is not special for that mode.")
(when (not (eq (length taglist1) (length taglist2)))
(setq ans nil))
(while (and ans taglist1 taglist2)
- (setq ans (apply 'semantic-tag-similar-p
+ (setq ans (apply #'semantic-tag-similar-p
(car taglist1) (car taglist2)
ignorable-attributes)
taglist1 (cdr taglist1)
@@ -190,7 +191,7 @@ See `semantic-tag-similar-p' for details."
;; will contain the info needed to determine the full name.
(define-overloadable-function semantic-tag-full-package (tag &optional stream-or-buffer)
"Return the fully qualified package name of TAG in a package hierarchy.
-STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
+STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-tag-table',
but must be a toplevel semantic tag stream that contains TAG.
A Package Hierarchy is defined in UML by the way classes and methods
are organized on disk. Some languages use this concept such that a
@@ -204,7 +205,7 @@ stream for a tag of class `package', and return that."
(or stream-or-buffer tag))))
(:override-with-args (tag stream))))
-(defun semantic-tag-full-package-default (tag stream)
+(defun semantic-tag-full-package-default (_tag stream)
"Default method for `semantic-tag-full-package' for TAG.
Return the name of the first tag of class `package' in STREAM."
(let ((pack (car-safe (semantic-find-tags-by-class 'package stream))))
@@ -213,7 +214,7 @@ Return the name of the first tag of class `package' in STREAM."
(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
"Return the fully qualified name of TAG in the package hierarchy.
-STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
+STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-tag-table',
but must be a toplevel semantic tag stream that contains TAG.
A Package Hierarchy is defined in UML by the way classes and methods
are organized on disk. Some languages use this concept such that a
@@ -233,9 +234,6 @@ resolve issues where a method in a class in a package is present."
(or stream-or-buffer tag))))
(:override-with-args (tag stream))))
-(make-obsolete-overload 'semantic-nonterminal-full-name
- 'semantic-tag-full-name "23.2")
-
(defun semantic-tag-full-name-default (tag stream)
"Default method for `semantic-tag-full-name'.
Return the name of TAG found in the toplevel STREAM."
@@ -287,10 +285,7 @@ is to return a symbol based on type modifiers."
(setq parent (semantic-tag-calculate-parent tag)))
(:override))
-(make-obsolete-overload 'semantic-nonterminal-protection
- 'semantic-tag-protection "23.2")
-
-(defun semantic-tag-protection-default (tag &optional parent)
+(defun semantic-tag-protection-default (tag &optional _parent)
"Return the protection of TAG as a child of PARENT default action.
See `semantic-tag-protection'."
(let ((mods (semantic-tag-modifiers tag))
@@ -300,9 +295,7 @@ See `semantic-tag-protection'."
(let ((s (car mods)))
(setq prot
;; A few silly defaults to get things started.
- (cond ((or (string= s "public")
- (string= s "extern")
- (string= s "export"))
+ (cond ((member s '("public" "extern" "export"))
'public)
((string= s "private")
'private)
@@ -377,18 +370,14 @@ in how methods are overridden. In UML, abstract methods are italicized.
The default behavior (if not overridden with `tag-abstract-p'
is to return true if `abstract' is in the type modifiers.")
-(make-obsolete-overload 'semantic-nonterminal-abstract
- 'semantic-tag-abstract-p "23.2")
-
-(defun semantic-tag-abstract-p-default (tag &optional parent)
+(defun semantic-tag-abstract-p-default (tag &optional _parent)
"Return non-nil if TAG is abstract as a child of PARENT default action.
See `semantic-tag-abstract-p'."
(let ((mods (semantic-tag-modifiers tag))
(abs nil))
(while (and (not abs) mods)
(if (stringp (car mods))
- (setq abs (or (string= (car mods) "abstract")
- (string= (car mods) "virtual"))))
+ (setq abs (member (car mods) '("abstract" "virtual"))))
(setq mods (cdr mods)))
abs))
@@ -400,10 +389,7 @@ In UML, leaf methods and classes have special meaning and behavior.
The default behavior (if not overridden with `tag-leaf-p'
is to return true if `leaf' is in the type modifiers.")
-(make-obsolete-overload 'semantic-nonterminal-leaf
- 'semantic-tag-leaf-p "23.2")
-
-(defun semantic-tag-leaf-p-default (tag &optional parent)
+(defun semantic-tag-leaf-p-default (tag &optional _parent)
"Return non-nil if TAG is leaf as a child of PARENT default action.
See `semantic-tag-leaf-p'."
(let ((mods (semantic-tag-modifiers tag))
@@ -423,7 +409,7 @@ In UML, static methods and attributes mean that they are allocated
in the parent class, and are not instance specific.
UML notation specifies that STATIC entries are underlined.")
-(defun semantic-tag-static-p-default (tag &optional parent)
+(defun semantic-tag-static-p-default (tag &optional _parent)
"Return non-nil if TAG is static as a child of PARENT default action.
See `semantic-tag-static-p'."
(let ((mods (semantic-tag-modifiers tag))
diff --git a/lisp/cedet/semantic/tag-write.el b/lisp/cedet/semantic/tag-write.el
index f705c89c904..9d5aeea098b 100644
--- a/lisp/cedet/semantic/tag-write.el
+++ b/lisp/cedet/semantic/tag-write.el
@@ -1,4 +1,4 @@
-;;; semantic/tag-write.el --- Write tags to a text stream
+;;; semantic/tag-write.el --- Write tags to a text stream -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -88,7 +88,7 @@ INDENT is the amount of indentation to use for this tag."
(if (semantic-tag-with-position-p tag)
(let ((bounds (semantic-tag-bounds tag)))
(princ " ")
- (prin1 (apply 'vector bounds))
+ (prin1 (apply #'vector bounds))
)
(princ " nil"))
;; End it.
diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el
index e5b4adeefc7..b6386d71db0 100644
--- a/lisp/cedet/semantic/tag.el
+++ b/lisp/cedet/semantic/tag.el
@@ -1,4 +1,4 @@
-;;; semantic/tag.el --- tag creation and access
+;;; semantic/tag.el --- Tag creation and access -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
@@ -53,6 +53,11 @@
(declare-function semantic-clear-toplevel-cache "semantic")
(declare-function semantic-tag-similar-p "semantic/tag-ls")
+(define-obsolete-variable-alias 'semantic-token-version
+ 'semantic-tag-version "28.1")
+(define-obsolete-variable-alias 'semantic-token-incompatible-version
+ 'semantic-tag-incompatible-version "28.1")
+
(defconst semantic-tag-version "2.0"
"Version string of semantic tags made with this code.")
@@ -224,6 +229,28 @@ See also the function `semantic-ctxt-current-mode'."
(require 'semantic/ctxt)
(semantic-ctxt-current-mode)))))
+;; Is this function still necessary?
+(defun semantic-tag-make-plist (args)
+ "Create a property list with ARGS.
+Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
+Where KEY is a symbol, and VALUE is the value for that symbol.
+The return value will be a new property list, with these KEY/VALUE
+pairs eliminated:
+
+ - KEY associated to nil VALUE.
+ - KEY associated to an empty string VALUE.
+ - KEY associated to a zero VALUE."
+ (let (plist key val)
+ (while args
+ (setq key (car args)
+ val (nth 1 args)
+ args (nthcdr 2 args))
+ (or (member val '("" nil))
+ (and (numberp val) (zerop val))
+ (setq plist (cons key (cons val plist)))))
+ ;; It is not useful to reverse the new plist.
+ plist))
+
(defsubst semantic--tag-attributes-cdr (tag)
"Return the cons cell whose car is the ATTRIBUTES part of TAG.
That function is for internal use only."
@@ -436,28 +463,6 @@ class to store those methods."
;;; Tag creation
;;
-;; Is this function still necessary?
-(defun semantic-tag-make-plist (args)
- "Create a property list with ARGS.
-Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
-Where KEY is a symbol, and VALUE is the value for that symbol.
-The return value will be a new property list, with these KEY/VALUE
-pairs eliminated:
-
- - KEY associated to nil VALUE.
- - KEY associated to an empty string VALUE.
- - KEY associated to a zero VALUE."
- (let (plist key val)
- (while args
- (setq key (car args)
- val (nth 1 args)
- args (nthcdr 2 args))
- (or (member val '("" nil))
- (and (numberp val) (zerop val))
- (setq plist (cons key (cons val plist)))))
- ;; It is not useful to reverse the new plist.
- plist))
-
(defsubst semantic-tag (name class &rest attributes)
"Create a generic semantic tag.
NAME is a string representing the name of this tag.
@@ -473,7 +478,7 @@ TYPE is a string or semantic tag representing the type of this variable.
Optional DEFAULT-VALUE is a string representing the default value of this
variable.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'variable
+ (apply #'semantic-tag name 'variable
:type type
:default-value default-value
attributes))
@@ -485,7 +490,7 @@ TYPE is a string or semantic tag representing the type of this function.
ARG-LIST is a list of strings or semantic tags representing the
arguments of this function.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'function
+ (apply #'semantic-tag name 'function
:type type
:arguments arg-list
attributes))
@@ -508,7 +513,7 @@ This slot can be interesting because the form:
is a valid parent where there is no explicit parent, and only an
interface.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'type
+ (apply #'semantic-tag name 'type
:type type
:members members
:superclasses (car parents)
@@ -521,7 +526,7 @@ NAME is the name of this include.
SYSTEM-FLAG represents that we were able to identify this include as
belonging to the system, as opposed to belonging to the local project.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'include
+ (apply #'semantic-tag name 'include
:system-flag system-flag
attributes))
@@ -531,7 +536,7 @@ NAME is the name of this package.
DETAIL is extra information about this package, such as a location
where it can be found.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'package
+ (apply #'semantic-tag name 'package
:detail detail
attributes))
@@ -540,7 +545,7 @@ ATTRIBUTES is a list of additional attributes belonging to this tag."
NAME is a name for this code.
DETAIL is extra information about the code.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'code
+ (apply #'semantic-tag name 'code
:detail detail
attributes))
@@ -680,7 +685,7 @@ FILTER takes TAG as an argument, and should return a `semantic-tag'.
It is safe for FILTER to modify the input tag and return it."
(when (not filter) (setq filter 'identity))
(when (not (semantic-tag-p tag))
- (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
+ (signal 'wrong-type-argument (list tag #'semantic-tag-p)))
(let ((ol (semantic-tag-overlay tag))
(fn (semantic-tag-file-name tag)))
(funcall filter (list (semantic-tag-name tag)
@@ -932,7 +937,7 @@ NAME is a name for this alias.
META-TAG-CLASS is the class of the tag this tag is an alias.
VALUE is the aliased definition.
ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply 'semantic-tag name 'alias
+ (apply #'semantic-tag name 'alias
:aliasclass meta-tag-class
:definition value
attributes))
@@ -1033,25 +1038,17 @@ See `semantic-tag-bounds'."
(defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body)
"Execute BODY with the buffer narrowed to the current tag."
+ (declare (indent 0) (debug t))
`(save-restriction
(semantic-narrow-to-tag (semantic-current-tag))
,@body))
-(put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0)
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag
- (def-body))))
(defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body)
"Narrow to TAG, and execute BODY."
+ (declare (indent 1) (debug t))
`(save-restriction
(semantic-narrow-to-tag ,tag)
,@body))
-(put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1)
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec semantic-with-buffer-narrowed-to-tag
- (def-body))))
;;; Tag Hooks
;;
@@ -1096,7 +1093,7 @@ For any given situation, additional ARGS may be passed."
(condition-case err
;; If a hook bombs, ignore it! Usually this is tied into
;; some sort of critical system.
- (apply 'run-hook-with-args 'semantic--tag-hook-value arglist)
+ (apply #'run-hook-with-args 'semantic--tag-hook-value arglist)
(error (message "Error: %S" err)))))
;;; Tags and Overlays
@@ -1107,7 +1104,7 @@ For any given situation, additional ARGS may be passed."
(defsubst semantic--tag-unlink-list-from-buffer (tags)
"Convert TAGS from using an overlay to using an overlay proxy.
This function is for internal use only."
- (mapcar 'semantic--tag-unlink-from-buffer tags))
+ (mapcar #'semantic--tag-unlink-from-buffer tags))
(defun semantic--tag-unlink-from-buffer (tag)
"Convert TAG from using an overlay to using an overlay proxy.
@@ -1128,7 +1125,7 @@ This function is for internal use only."
(defsubst semantic--tag-link-list-to-buffer (tags)
"Convert TAGS from using an overlay proxy to using an overlay.
This function is for internal use only."
- (mapc 'semantic--tag-link-to-buffer tags))
+ (mapc #'semantic--tag-link-to-buffer tags))
(defun semantic--tag-link-to-buffer (tag)
"Convert TAG from using an overlay proxy to using an overlay.
@@ -1189,7 +1186,7 @@ See also the function `semantic--expand-tag'."
(setq tag (cdr tag)))
(null tag)))
-(defvar semantic-tag-expand-function nil
+(defvar-local semantic-tag-expand-function nil
"Function used to expand a tag.
It is passed each tag production, and must return a list of tags
derived from it, or nil if it does not need to be expanded.
@@ -1202,7 +1199,6 @@ following definition is easily parsed into one tag:
This function should take this compound tag and turn it into two tags,
one for A, and the other for B.")
-(make-variable-buffer-local 'semantic-tag-expand-function)
(defun semantic--tag-expand (tag)
"Convert TAG from a raw state to a cooked state, and expand it.
@@ -1321,32 +1317,6 @@ This function is overridable with the symbol `insert-foreign-tag'."
"Insert foreign tags into log-edit mode."
(insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
-;;; Compatibility
-;;
-(defconst semantic-token-version
- semantic-tag-version)
-(defconst semantic-token-incompatible-version
- semantic-tag-incompatible-version)
-
-(defsubst semantic-token-type-parent (tag)
- "Return the parent of the type that TAG describes.
-The return value is a list. A value of nil means no parents.
-The `car' of the list is either the parent class, or a list
-of parent classes. The `cdr' of the list is the list of
-interfaces, or abstract classes which are parents of TAG."
- (cons (semantic-tag-get-attribute tag :superclasses)
- (semantic-tag-type-interfaces tag)))
-
-(make-obsolete 'semantic-token-type-parent
- "\
-use `semantic-tag-type-superclass' \
-and `semantic-tag-type-interfaces' instead" "23.2")
-
-(semantic-alias-obsolete 'semantic-tag-make-assoc-list
- 'semantic-tag-make-plist "23.2")
-
-(semantic-varalias-obsolete 'semantic-expand-nonterminal
- 'semantic-tag-expand-function "23.2")
(provide 'semantic/tag)
diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el
index 377cec5455d..5a38280d2a2 100644
--- a/lisp/cedet/semantic/texi.el
+++ b/lisp/cedet/semantic/texi.el
@@ -1,4 +1,4 @@
-;;; semantic/texi.el --- Semantic details for Texinfo files
+;;; semantic/texi.el --- Semantic details for Texinfo files -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2005, 2007-2021 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@ The field position is the field number (based at 1) where the
name of this section is.")
;;; Code:
-(defun semantic-texi-parse-region (&rest ignore)
+(defun semantic-texi-parse-region (&rest _ignore)
"Parse the current texinfo buffer for semantic tags.
IGNORE any arguments, always parse the whole buffer.
Each tag returned is of the form:
@@ -79,7 +79,7 @@ function `semantic-install-function-overrides'."
(let ((chil (semantic-tag-components tag)))
(if chil
(semantic-tag-put-attribute
- tag :members (mapcar 'semantic-texi-expand-tag chil)))
+ tag :members (mapcar #'semantic-texi-expand-tag chil)))
(car (semantic--tag-expand tag))))
(defun semantic-texi-parse-headings ()
@@ -297,7 +297,7 @@ can handle the @menu environment.")
nil))
(define-mode-local-override semantic-ctxt-current-class-list
- texinfo-mode (&optional point)
+ texinfo-mode (&optional _point)
"Determine the class of tags that can be used at POINT.
For texinfo, there two possibilities returned.
1) `function' - for a call to a texinfo function
@@ -368,7 +368,7 @@ Optional argument POINT is where to look for the environment."
(declare-function semantic-analyze-context "semantic/analyze")
(define-mode-local-override semantic-analyze-current-context
- texinfo-mode (point)
+ texinfo-mode (_point)
"Analysis context makes no sense for texinfo. Return nil."
(let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
(prefix (car prefixandbounds))
@@ -408,7 +408,7 @@ Optional argument POINT is where to look for the environment."
"List of commands that we might bother completing.")
(define-mode-local-override semantic-analyze-possible-completions
- texinfo-mode (context &rest flags)
+ texinfo-mode (context &rest _flags)
"List smart completions at point.
Since texinfo is not a programming language the default version is not
useful. Instead, look at the current symbol. If it is a command
@@ -451,7 +451,7 @@ that start with that symbol."
(setq semantic-parser-name "TEXI"
;; Setup a dummy parser table to enable parsing!
semantic--parse-table t
- imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function #'semantic-create-imenu-index
semantic-command-separation-character "@"
semantic-type-relation-separator-character '(":")
semantic-symbol->name-assoc-list '((section . "Section")
@@ -466,7 +466,7 @@ that start with that symbol."
;; (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi)
)
-(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup)
+(add-hook 'texinfo-mode-hook #'semantic-default-texi-setup)
;;; Special features of Texinfo tag streams
@@ -500,7 +500,7 @@ that start with that symbol."
;; Turns out this might not be useful.
;; Delete later if that is true.
-(defun semantic-texi-find-documentation (name &optional type)
+(defun semantic-texi-find-documentation (name &optional _type)
"Find the function or variable NAME of TYPE in the texinfo source.
NAME is a string representing some functional symbol.
TYPE is a string, such as \"variable\" or \"Command\" used to find
diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el
index 1f0986a547d..106862837a1 100644
--- a/lisp/cedet/semantic/util-modes.el
+++ b/lisp/cedet/semantic/util-modes.el
@@ -1,4 +1,4 @@
-;;; semantic/util-modes.el --- Semantic minor modes
+;;; semantic/util-modes.el --- Semantic minor modes -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2005, 2007-2021 Free Software Foundation, Inc.
@@ -48,7 +48,7 @@ line."
:group 'semantic
:type 'boolean
:require 'semantic/util-modes
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
;; Update status of all Semantic enabled buffers
@@ -60,7 +60,7 @@ line."
:group 'semantic
:type 'string
:require 'semantic/util-modes
- :initialize 'custom-initialize-default)
+ :initialize #'custom-initialize-default)
(defvar semantic-minor-modes-format nil
"Mode line format showing Semantic minor modes which are locally enabled.
@@ -93,7 +93,7 @@ Only minor modes that are locally enabled are shown in the mode line."
(match-string 1 semantic-mode-line-prefix)
"S")))
(setq semantic-minor-modes-format
- `((:eval (if (or ,@(mapcar 'car locals))
+ `((: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
@@ -111,7 +111,7 @@ Only minor modes that are locally enabled are shown in the mode line."
(cons elem minor-mode-alist)))))
(setcdr tail (nconc locals (cdr tail)))))))))
-(defun semantic-desktop-ignore-this-minor-mode (buffer)
+(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)
@@ -162,7 +162,7 @@ too an interactive function used to toggle the mode."
;; 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))))
+ (semantic-map-buffers (lambda () (funcall mode arg))))
;;;;
;;;; Minor mode to highlight areas that a user edits.
@@ -221,10 +221,10 @@ non-nil if the minor mode is enabled."
(error "Buffer %s was not set up for parsing"
(buffer-name)))
(add-hook 'semantic-edits-new-change-functions
- '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-functions
- 'semantic-highlight-edits-new-change-hook-fcn t)))
+ #'semantic-highlight-edits-new-change-hook-fcn t)))
(semantic-add-minor-mode 'semantic-highlight-edits-mode
"e")
@@ -345,7 +345,7 @@ Do not search past BOUND if non-nil."
(defvar semantic-show-unmatched-syntax-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km "\C-c,`" 'semantic-show-unmatched-syntax-next)
+ (define-key km "\C-c,`" #'semantic-show-unmatched-syntax-next)
km)
"Keymap for command `semantic-show-unmatched-syntax-mode'.")
@@ -372,18 +372,18 @@ non-nil if the minor mode is enabled.
(buffer-name)))
;; Add hooks
(add-hook 'semantic-unmatched-syntax-hook
- 'semantic-show-unmatched-syntax nil t)
+ #'semantic-show-unmatched-syntax nil t)
(add-hook 'semantic-pre-clean-token-hooks
- 'semantic-clean-token-of-unmatched-syntax nil t)
+ #'semantic-clean-token-of-unmatched-syntax nil t)
;; Show unmatched syntax elements
(if (not (semantic--umatched-syntax-needs-refresh-p))
(semantic-show-unmatched-syntax
(semantic-unmatched-syntax-tokens))))
;; Remove hooks
(remove-hook 'semantic-unmatched-syntax-hook
- 'semantic-show-unmatched-syntax t)
+ #'semantic-show-unmatched-syntax t)
(remove-hook 'semantic-pre-clean-token-hooks
- 'semantic-clean-token-of-unmatched-syntax t)
+ #'semantic-clean-token-of-unmatched-syntax t)
;; Cleanup unmatched-syntax highlighting
(semantic-clean-unmatched-syntax-in-buffer)))
@@ -454,56 +454,55 @@ non-nil if the minor mode is enabled."
'(semantic-show-parser-state-string))))
;; Add hooks
(add-hook 'semantic-edits-new-change-functions
- 'semantic-show-parser-state-marker nil t)
+ #'semantic-show-parser-state-marker nil t)
(add-hook 'semantic-edits-incremental-reparse-failed-hook
- 'semantic-show-parser-state-marker nil t)
+ #'semantic-show-parser-state-marker nil t)
(add-hook 'semantic-after-partial-cache-change-hook
- 'semantic-show-parser-state-marker nil t)
+ #'semantic-show-parser-state-marker nil t)
(add-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-show-parser-state-marker nil t)
+ #'semantic-show-parser-state-marker nil t)
(semantic-show-parser-state-marker)
(add-hook 'semantic-before-auto-parse-hooks
- 'semantic-show-parser-state-auto-marker nil t)
+ #'semantic-show-parser-state-auto-marker nil t)
(add-hook 'semantic-after-auto-parse-hooks
- 'semantic-show-parser-state-marker nil t)
+ #'semantic-show-parser-state-marker nil t)
(add-hook 'semantic-before-idle-scheduler-reparse-hook
- 'semantic-show-parser-state-auto-marker nil t)
+ #'semantic-show-parser-state-auto-marker nil t)
(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))
;; Remove hooks
(remove-hook 'semantic-edits-new-change-functions
- 'semantic-show-parser-state-marker t)
+ #'semantic-show-parser-state-marker t)
(remove-hook 'semantic-edits-incremental-reparse-failed-hook
- 'semantic-show-parser-state-marker t)
+ #'semantic-show-parser-state-marker t)
(remove-hook 'semantic-after-partial-cache-change-hook
- 'semantic-show-parser-state-marker t)
+ #'semantic-show-parser-state-marker t)
(remove-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-show-parser-state-marker t)
+ #'semantic-show-parser-state-marker t)
(remove-hook 'semantic-before-auto-parse-hooks
- 'semantic-show-parser-state-auto-marker t)
+ #'semantic-show-parser-state-auto-marker t)
(remove-hook 'semantic-after-auto-parse-hooks
- 'semantic-show-parser-state-marker t)
+ #'semantic-show-parser-state-marker t)
(remove-hook 'semantic-before-idle-scheduler-reparse-hook
- 'semantic-show-parser-state-auto-marker t)
+ #'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-marker t)))
(semantic-add-minor-mode 'semantic-show-parser-state-mode
"")
-(defvar semantic-show-parser-state-string nil
+(defvar-local semantic-show-parser-state-string nil
"String showing the parser state for this buffer.
See `semantic-show-parser-state-marker' for details.")
-(make-variable-buffer-local 'semantic-show-parser-state-string)
-(defun semantic-show-parser-state-marker (&rest ignore)
+(defun semantic-show-parser-state-marker (&rest _ignore)
"Set `semantic-show-parser-state-string' to indicate parser state.
This marker is one of the following:
`-' -> The cache is up to date.
@@ -556,7 +555,7 @@ to indicate a parse in progress."
(defvar semantic-stickyfunc-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km [ header-line down-mouse-1 ] 'semantic-stickyfunc-menu)
+ (define-key km [ header-line down-mouse-1 ] #'semantic-stickyfunc-menu)
km)
"Keymap for stickyfunc minor mode.")
@@ -692,17 +691,13 @@ non-nil if the minor mode is enabled."
;; Disable minor mode if semantic stuff not available
(setq semantic-stickyfunc-mode nil)
(error "Buffer %s was not set up for parsing" (buffer-name)))
- (unless (boundp 'header-line-format)
- ;; Disable if there are no header lines to use.
- (setq semantic-stickyfunc-mode nil)
- (error "Sticky Function mode requires Emacs"))
;; Enable the mode
;; Save previous buffer local value of header line format.
(when (and (local-variable-p 'header-line-format (current-buffer))
(not (eq header-line-format
semantic-stickyfunc-header-line-format)))
- (set (make-local-variable 'semantic-stickyfunc-old-hlf)
- header-line-format))
+ (setq-local semantic-stickyfunc-old-hlf
+ 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
@@ -713,10 +708,9 @@ non-nil if the minor mode is enabled."
(setq header-line-format semantic-stickyfunc-old-hlf)
(kill-local-variable 'semantic-stickyfunc-old-hlf)))))
-(defvar semantic-stickyfunc-sticky-classes
+(defvar-local semantic-stickyfunc-sticky-classes
'(function type)
"List of tag classes which stickyfunc will display in the header line.")
-(make-variable-buffer-local 'semantic-stickyfunc-sticky-classes)
(defcustom semantic-stickyfunc-show-only-functions-p nil
"Non-nil means don't show lines that aren't part of a tag.
@@ -832,12 +826,13 @@ Argument EVENT describes the event that caused this function to be called."
(defvar semantic-highlight-func-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km [mouse-3] 'semantic-highlight-func-menu)
+ (define-key km [mouse-3] #'semantic-highlight-func-menu)
km)
"Keymap for highlight-func minor mode.")
(defvar semantic-highlight-func-popup-menu nil
- "Menu used if the user clicks on the header line used by `semantic-highlight-func-mode'.")
+ "Menu used if the user clicks on the header line.
+Used by `semantic-highlight-func-mode'.")
(easy-menu-define
semantic-highlight-func-popup-menu
@@ -885,9 +880,8 @@ Argument EVENT describes the event that caused this function to be called."
)
(select-window startwin)))
-(defvar semantic-highlight-func-ct-overlay nil
+(defvar-local 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)
(defface semantic-highlight-func-current-tag-face
'((((class color) (background dark))
@@ -922,10 +916,10 @@ non-nil if the minor mode is enabled."
(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))
+ #'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-highlight-current-tag t)))
(defun semantic-highlight-func-highlight-current-tag (&optional disable)
diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el
index 152cc302238..bfc923c75b4 100644
--- a/lisp/cedet/semantic/util.el
+++ b/lisp/cedet/semantic/util.el
@@ -1,6 +1,6 @@
-;;; semantic/util.el --- Utilities for use with semantic tag tables
+;;; semantic/util.el --- Utilities for use with semantic tag tables -*- lexical-binding: t; -*-
-;;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
@@ -39,20 +39,18 @@
;;; Code:
-(defvar semantic-type-relation-separator-character '(".")
+(defvar-local semantic-type-relation-separator-character '(".")
"Character strings used to separate a parent/child relationship.
This list of strings are used for displaying or finding separators
in variable field dereferencing. The first character will be used for
display. In C, a type field is separated like this: \"type.field\"
thus, the character is a \".\". In C, and additional value of \"->\"
would be in the list, so that \"type->field\" could be found.")
-(make-variable-buffer-local 'semantic-type-relation-separator-character)
-(defvar semantic-equivalent-major-modes nil
+(defvar-local semantic-equivalent-major-modes nil
"List of major modes which are considered equivalent.
Equivalent modes share a parser, and a set of override methods.
A value of nil means that the current major mode is the only one.")
-(make-variable-buffer-local 'semantic-equivalent-major-modes)
(declare-function semanticdb-file-stream "semantic/db" (file))
@@ -79,9 +77,6 @@ If FILE is not loaded, and semanticdb is not available, find the file
(with-current-buffer (find-file-noselect file)
(semantic-fetch-tags))))))
-(semantic-alias-obsolete 'semantic-file-token-stream
- 'semantic-file-tag-table "23.2")
-
(declare-function semanticdb-abstract-table-child-p "semantic/db" (obj) t)
(declare-function semanticdb-refresh-table "semantic/db")
(declare-function semanticdb-get-tags "semantic/db" (arg &rest args) t)
@@ -119,7 +114,10 @@ buffer, or a filename. If SOMETHING is nil return nil."
((and (featurep 'semantic/db)
(require 'semantic/db-mode)
(semanticdb-minor-mode-p)
- (cl-typep something 'semanticdb-abstract-table))
+ (progn
+ (declare-function semanticdb-abstract-table--eieio-childp
+ "semantic/db")
+ (cl-typep something 'semanticdb-abstract-table)))
(semanticdb-refresh-table something)
(semanticdb-get-tags something))
;; Semanticdb find-results
@@ -137,9 +135,6 @@ buffer, or a filename. If SOMETHING is nil return nil."
;; don't know what it is
(t nil)))
-(semantic-alias-obsolete 'semantic-something-to-stream
- 'semantic-something-to-tag-table "23.2")
-
;;; Completion APIs
;;
;; These functions provide minibuffer reading/completion for lists of
@@ -307,7 +302,6 @@ If TAG is not specified, use the tag at point."
semantic-init-db-hook
semantic-unmatched-syntax-hook
semantic--before-fetch-tags-hook
- semantic-after-toplevel-bovinate-hook
semantic-after-toplevel-cache-change-hook
semantic-before-toplevel-cache-flush-hook
semantic-dump-parse
@@ -436,7 +430,7 @@ determining which symbols are considered."
(setq completion (try-completion pattern collection predicate))
(if (string= pattern completion)
(let ((list (all-completions pattern collection predicate)))
- (setq list (sort list 'string<))
+ (setq list (sort list #'string<))
(if (> (length list) 1)
(with-output-to-temp-buffer "*Completions*"
(display-completion-list
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index de0245d8734..f5f381d4079 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -1,4 +1,4 @@
-;;; semantic/wisent.el --- Wisent - Semantic gateway
+;;; semantic/wisent.el --- Wisent - Semantic gateway -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2007, 2009-2021 Free Software Foundation, Inc.
@@ -22,13 +22,10 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; Here are functions necessary to use the Wisent LALR parser from
;; Semantic environment.
-;;; History:
-;;
-
;;; Code:
(require 'semantic)
@@ -43,11 +40,6 @@
"Extra lookahead token.
When non-nil it is directly returned by `wisent-lex-function'.")
-;; Maintain this alias for compatibility until all WY grammars have
-;; been translated again to Elisp code.
-(semantic-alias-obsolete 'wisent-lex-make-token-table
- 'semantic-lex-make-type-table "23.2")
-
(defmacro wisent-lex-eoi ()
"Return an End-Of-Input lexical token.
The EOI token is like this: ($EOI \"\" POINT-MAX . POINT-MAX)."
@@ -74,6 +66,7 @@ Returned tokens must have the form:
(TOKSYM VALUE START . END)
where VALUE is the buffer substring between START and END positions."
+ (declare (debug (&define name stringp def-body)))
`(defun
,name () ,doc
(cond
@@ -98,15 +91,13 @@ it to a form suitable for the Wisent's parser."
;;; Syntax analysis
;;
-(defvar wisent-error-function nil
+(defvar-local wisent-error-function nil
"Function used to report parse error.
By default use the function `wisent-message'.")
-(make-variable-buffer-local 'wisent-error-function)
-(defvar wisent-lexer-function 'wisent-lex
+(defvar-local wisent-lexer-function 'wisent-lex
"Function used to obtain the next lexical token in input.
Should be a lexical analyzer created with `define-wisent-lexer'.")
-(make-variable-buffer-local 'wisent-lexer-function)
;; Tag production
;;
@@ -230,7 +221,7 @@ the standard function `semantic-parse-stream'."
(error-message-string error-to-filter))
(message "wisent-parse-max-stack-size \
might need to be increased"))
- (apply 'signal error-to-filter))))))
+ (apply #'signal error-to-filter))))))
;; Manage returned lookahead token
(if wisent-lookahead
(if (eq (caar la-elt) wisent-lookahead)
@@ -258,6 +249,17 @@ might need to be increased"))
(if (consp cache) cache '(nil))
)))
+(defmacro wisent-compiled-grammar (grammar &optional start-list)
+ "Return a compiled form of the LALR(1) Wisent GRAMMAR.
+See `wisent--compile-grammar' for a description of the arguments
+and return value."
+ ;; Ensure that the grammar compiler is available.
+ (require 'semantic/wisent/comp)
+ (declare-function wisent-automaton-lisp-form "semantic/wisent/comp" (x))
+ (declare-function wisent--compile-grammar "semantic/wisent/comp" (grm st))
+ (wisent-automaton-lisp-form
+ (wisent--compile-grammar grammar start-list)))
+
(defun wisent-parse-region (start end &optional goal depth returnonerror)
"Parse the area between START and END using the Wisent LALR parser.
Return the list of semantic tags found.
@@ -326,18 +328,6 @@ the standard function `semantic-parse-region'."
(point-max))))))
;; Return parse tree
(nreverse ptree)))
-
-;;; Interfacing with edebug
-;;
-(add-hook
- 'edebug-setup-hook
- #'(lambda ()
-
- (def-edebug-spec define-wisent-lexer
- (&define name stringp def-body)
- )
-
- ))
(provide 'semantic/wisent)
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el
index c07a81c10f6..a87ed518909 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -1,4 +1,4 @@
-;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler
+;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler -*- lexical-binding: t; -*-
;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000-2007, 2009-2021 Free
;; Software Foundation, Inc.
@@ -35,9 +35,6 @@
;;
;; For more details on Wisent itself read the Wisent manual.
-;;; History:
-;;
-
;;; Code:
(require 'semantic/wisent)
(eval-when-compile (require 'cl-lib))
@@ -54,21 +51,22 @@
;; bound locally, without all these "reference to free variable"
;; compiler warnings!
-(defmacro wisent-context-name (name)
- "Return the context name from NAME."
- `(if (and ,name (symbolp ,name))
- (intern (format "wisent-context-%s" ,name))
- (error "Invalid context name: %S" ,name)))
+(eval-when-compile
+ (defun wisent-context-name (name)
+ "Return the context name from NAME."
+ (if (and name (symbolp name))
+ (intern (format "wisent-context-%s" name))
+ (error "Invalid context name: %S" name)))
-(defmacro wisent-context-bindings (name)
- "Return the variables in context NAME."
- `(symbol-value (wisent-context-name ,name)))
+ (defun wisent-context-bindings (name)
+ "Return the variables in context NAME."
+ (symbol-value (wisent-context-name name))))
(defmacro wisent-defcontext (name &rest vars)
"Define a context NAME that will bind variables VARS."
(declare (indent 1))
(let* ((context (wisent-context-name name))
- (declarations (mapcar #'(lambda (v) (list 'defvar v)) vars)))
+ (declarations (mapcar (lambda (v) (list 'defvar v)) vars)))
`(progn
,@declarations
(eval-when-compile
@@ -77,12 +75,8 @@
(defmacro wisent-with-context (name &rest body)
"Bind variables in context NAME then eval BODY."
(declare (indent 1))
- (let ((bindings (wisent-context-bindings name)))
- `(progn
- ,@(mapcar (lambda (binding) `(defvar ,(or (car-safe binding) binding)))
- bindings)
- (let* ,bindings
- ,@body))))
+ `(dlet ,(wisent-context-bindings name)
+ ,@body))
;; Other utilities
@@ -101,6 +95,8 @@ If optional LEFT is non-nil insert spaces on left."
;;;; Environment dependencies
;;;; ------------------------
+;; FIXME: Use bignums or bool-vectors?
+
(defconst wisent-BITS-PER-WORD (logcount most-positive-fixnum))
(defsubst wisent-WORDSIZE (n)
@@ -159,13 +155,9 @@ Its name is defined in constant `wisent-log-buffer-name'."
'(with-current-buffer (wisent-log-buffer)
(erase-buffer)))
-(defvar byte-compile-current-file)
-
(defun wisent-source ()
"Return the current source file name or nil."
- (let ((source (or (and (boundp 'byte-compile-current-file)
- byte-compile-current-file)
- load-file-name (buffer-file-name))))
+ (let ((source (macroexp-file-name)))
(if source
(file-relative-name source))))
@@ -2241,7 +2233,7 @@ there are any reduce/reduce conflicts."
;; output warnings.
(and src
(intern (format "wisent-%s--expected-conflicts"
- (replace-regexp-in-string "\\.el$" "" src))))))
+ (replace-regexp-in-string "\\.el\\'" "" src))))))
(when (or (not (zerop rrc-total))
(and (not (zerop src-total))
(not (= src-total (or wisent-expected-conflicts 0)))
@@ -2778,7 +2770,7 @@ that likes a token gets to handle it."
"Figure out the actions for every state.
Return the action table."
;; Store the semantic action obarray in (unused) RCODE[0].
- (aset rcode 0 (make-vector 13 0))
+ (aset rcode 0 (obarray-make 13))
(let (i j action-table actrow action)
(setq action-table (make-vector nstates nil)
actrow (make-vector ntokens nil)
@@ -3053,7 +3045,7 @@ one.")
(defsubst wisent-ISVALID-TOKEN (x)
"Return non-nil if X is a character or an allowed symbol."
- (or (wisent-char-p x)
+ (or (characterp x)
(wisent-ISVALID-VAR x)))
(defun wisent-push-token (symbol &optional nocheck)
@@ -3143,7 +3135,7 @@ the rule."
(cond
((or (memq item token-list) (memq item var-list)))
;; Create new literal character token
- ((wisent-char-p item) (wisent-push-token item t))
+ ((characterp item) (wisent-push-token item t))
((error "Symbol `%s' is used, but is not defined as a token and has no rules"
item))))
(setq rhl (1+ rhl)
@@ -3392,7 +3384,7 @@ NONTERMS is the list of non terminal definitions (see function
;;;; Compile input grammar
;;;; ---------------------
-(defun wisent-compile-grammar (grammar &optional start-list)
+(defun wisent--compile-grammar (grammar start-list)
"Compile the LALR(1) GRAMMAR.
GRAMMAR is a list (TOKENS ASSOCS . NONTERMS) where:
@@ -3435,7 +3427,7 @@ where:
(if (wisent-automaton-p grammar)
grammar ;; Grammar already compiled just return it
(wisent-with-context compile-grammar
- (let* ((gc-cons-threshold 1000000))
+ (let* ((gc-cons-threshold (max gc-cons-threshold 1000000)))
(garbage-collect)
(setq wisent-new-log-flag t)
;; Parse input grammar
@@ -3444,7 +3436,7 @@ where:
(wisent-parser-automaton)))))
;;;; --------------------------
-;;;; Byte compile input grammar
+;;;; Obsolete byte compile support
;;;; --------------------------
(require 'bytecomp)
@@ -3453,25 +3445,32 @@ where:
"Byte compile the `wisent-compile-grammar' FORM.
Automatically called by the Emacs Lisp byte compiler as a
`byte-compile' handler."
- ;; Eval the `wisent-compile-grammar' form to obtain an LALR
- ;; 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
- ;; 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)))))
+ (wisent-automaton-lisp-form (eval form t)))))
-;; 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-compile-grammar (grammar &optional start-list)
+ ;; This is kept for compatibility with FOO-wy.el files generated
+ ;; with older Emacsen.
+ (declare (obsolete wisent-compiled-grammar "Mar 2021"))
+ (wisent--compile-grammar grammar start-list))
+
+(put 'wisent-compile-grammar 'byte-compile #'wisent-byte-compile-grammar)
+
+;;;; --------------------------
+;;;; Byte compile input grammar
+;;;; --------------------------
+;; `wisent--compile-grammar' generates the actual parse table
+;; we need at run-time, but in order to be able to compile the code it
+;; contains, we need to "reify" it back into a piece of ELisp code
+;; which (re)builds it.
+;; This is needed for 2 reasons:
+;; - The parse tables include an obarray and these don't survive the print+read
+;; steps involved in generating a `.elc' file and reading it back in.
+;; - Within the parse table vectors/obarrays we have ELisp functions which
+;; we want to byte-compile, but if we were to just `quote' the table
+;; we'd get them with the same non-compiled functions.
(defun wisent-automaton-lisp-form (automaton)
"Return a Lisp form that produces AUTOMATON.
See also `wisent-compile-grammar' for more details on AUTOMATON."
@@ -3481,16 +3480,16 @@ See also `wisent-compile-grammar' for more details on AUTOMATON."
(let ((obn (make-symbol "ob")) ; Generated obarray name
(obv (aref automaton 3)) ; Semantic actions obarray
)
- `(let ((,obn (make-vector 13 0)))
+ `(let ((,obn (obarray-make 13)))
;; Generate code to initialize the semantic actions obarray,
;; in local variable OBN.
,@(let (obcode)
(mapatoms
- #'(lambda (s)
- (setq obcode
- (cons `(fset (intern ,(symbol-name s) ,obn)
- #',(symbol-function s))
- obcode)))
+ (lambda (s)
+ (setq obcode
+ (cons `(fset (intern ,(symbol-name s) ,obn)
+ #',(symbol-function s))
+ obcode)))
obv)
obcode)
;; Generate code to create the automaton.
@@ -3500,18 +3499,20 @@ See also `wisent-compile-grammar' for more details on AUTOMATON."
;; obarray.
(vector
,@(mapcar
- #'(lambda (state) ;; for each state
- `(list
- ,@(mapcar
- #'(lambda (tr) ;; for each transition
- (let ((k (car tr)) ; token
- (a (cdr tr))) ; action
- (if (and (symbolp a)
- (intern-soft (symbol-name a) obv))
- `(cons ,(if (symbolp k) `(quote ,k) k)
- (intern-soft ,(symbol-name a) ,obn))
- `(quote ,tr))))
- state)))
+ ;; Use name `st' rather than `state' since `state' is
+ ;; defined as dynbound in `semantic-actions' context above :-( !
+ (lambda (st) ;; for each state
+ `(list
+ ,@(mapcar
+ (lambda (tr) ;; for each transition
+ (let ((k (car tr)) ; token
+ (a (cdr tr))) ; action
+ (if (and (symbolp a)
+ (intern-soft (symbol-name a) obv))
+ `(cons ,(if (symbolp k) `(quote ,k) k)
+ (intern-soft ,(symbol-name a) ,obn))
+ `(quote ,tr))))
+ st)))
(aref automaton 0)))
;; The code of the goto table is unchanged.
,(aref automaton 1)
diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el
index 962b46d1982..c5e4554082e 100644
--- a/lisp/cedet/semantic/wisent/grammar.el
+++ b/lisp/cedet/semantic/wisent/grammar.el
@@ -1,4 +1,4 @@
-;;; semantic/wisent/grammar.el --- Wisent's input grammar mode
+;;; semantic/wisent/grammar.el --- Wisent's input grammar mode -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;;
@@ -198,10 +198,10 @@ See also the function `wisent-skip-token'."
(defun wisent-grammar-assocs ()
"Return associativity and precedence level definitions."
(mapcar
- #'(lambda (tag)
- (cons (intern (semantic-tag-name tag))
- (mapcar #'semantic-grammar-item-value
- (semantic-tag-get-attribute tag :value))))
+ (lambda (tag)
+ (cons (intern (semantic-tag-name tag))
+ (mapcar #'semantic-grammar-item-value
+ (semantic-tag-get-attribute tag :value))))
(semantic-find-tags-by-class 'assoc (current-buffer))))
(defun wisent-grammar-terminals ()
@@ -209,14 +209,14 @@ See also the function `wisent-skip-token'."
Keep order of declaration in the WY file without duplicates."
(let (terms)
(mapc
- #'(lambda (tag)
- (mapcar #'(lambda (name)
- (add-to-list 'terms (intern name)))
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
+ (lambda (tag)
+ (mapcar (lambda (name)
+ (add-to-list 'terms (intern name)))
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
(semantic--find-tags-by-function
- #'(lambda (tag)
- (memq (semantic-tag-class tag) '(token keyword)))
+ (lambda (tag)
+ (memq (semantic-tag-class tag) '(token keyword)))
(current-buffer)))
(nreverse terms)))
@@ -228,7 +228,7 @@ Keep order of declaration in the WY file without duplicates."
Return the expanded expression."
(if (or (atom expr) (semantic-grammar-quote-p (car expr)))
expr ;; Just return atom or quoted expression.
- (let* ((expr (mapcar 'wisent-grammar-expand-macros expr))
+ (let* ((expr (mapcar #'wisent-grammar-expand-macros expr))
(macro (assq (car expr) wisent--grammar-macros)))
(if macro ;; Expand Semantic built-in.
(apply (cdr macro) (cdr expr))
@@ -286,12 +286,9 @@ Return the expanded expression."
(defun wisent-grammar-parsetable-builder ()
"Return the value of the parser table."
- `(progn
- ;; Ensure that the grammar [byte-]compiler is available.
- (eval-when-compile (require 'semantic/wisent/comp))
- (wisent-compile-grammar
- ',(wisent-grammar-grammar)
- ',(semantic-grammar-start))))
+ `(wisent-compiled-grammar
+ ,(wisent-grammar-grammar)
+ ,(semantic-grammar-start)))
(defun wisent-grammar-setupcode-builder ()
"Return the parser setup code."
@@ -305,7 +302,7 @@ Return the expanded expression."
semantic-lex-types-obarray %s)\n\
;; Collect unmatched syntax lexical tokens\n\
(add-hook 'wisent-discarding-token-functions\n\
- 'wisent-collect-unmatched-syntax nil t)"
+ #'wisent-collect-unmatched-syntax nil t)"
(semantic-grammar-parsetable)
(buffer-name)
(semantic-grammar-keywordtable)
@@ -325,6 +322,7 @@ Menu items are appended to the common grammar menu.")
(define-derived-mode wisent-grammar-mode semantic-grammar-mode "WY"
"Major mode for editing Wisent grammars."
(semantic-grammar-setup-menu wisent-grammar-menu)
+ (setq-local semantic-grammar-require-form '(require 'semantic/wisent))
(semantic-install-function-overrides
'((semantic-grammar-parsetable-builder . wisent-grammar-parsetable-builder)
(semantic-grammar-setupcode-builder . wisent-grammar-setupcode-builder))))
@@ -427,7 +425,7 @@ Menu items are appended to the common grammar menu.")
"\n;; It is derived from the grammar in the ECMAScript Language
;; Specification published at
;;
-;; http://www.ecma-international.org/publications/standards/Ecma-262.htm
+;; https://www.ecma-international.org/publications/standards/Ecma-262.htm
;;
;; and redistributed under the following license:
;;
@@ -479,7 +477,7 @@ Menu items are appended to the common grammar menu.")
(condition-case err
(with-current-buffer (find-file-noselect infile)
(if outdir (setq default-directory outdir))
- (semantic-grammar-create-package nil t))
+ (semantic-grammar-create-package t t))
(error (message "%s" (error-message-string err)) nil)))
output-data)
(when (setq output-data (assoc packagename wisent-make-parsers--parser-file-name))
@@ -514,7 +512,8 @@ Menu items are appended to the common grammar menu.")
(goto-char (point-min))
(delete-region (point-min) (line-end-position))
(insert ";;; " packagename
- " --- Generated parser support file")
+ " --- Generated parser support file "
+ "-*- lexical-binding:t -*-")
(re-search-forward ";;; \\(.*\\) ends here")
(replace-match packagename nil nil nil 1)
(delete-trailing-whitespace))))))
diff --git a/lisp/cedet/semantic/wisent/java-tags.el b/lisp/cedet/semantic/wisent/java-tags.el
index d455c02d1b5..90dd40c51a0 100644
--- a/lisp/cedet/semantic/wisent/java-tags.el
+++ b/lisp/cedet/semantic/wisent/java-tags.el
@@ -1,4 +1,4 @@
-;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs
+;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2006, 2009-2021 Free Software Foundation, Inc.
@@ -24,9 +24,6 @@
;;; Commentary:
;;
-;;; History:
-;;
-
;;; Code:
(require 'semantic/wisent)
@@ -92,7 +89,7 @@ This function override `get-local-variables'."
(define-mode-local-override semantic-analyze-unsplit-name java-mode (namelist)
"Assemble the list of names NAMELIST into a namespace name."
- (mapconcat 'identity namelist "."))
+ (mapconcat #'identity namelist "."))
@@ -111,12 +108,12 @@ Use the alternate LALR(1) parser."
(setq
;; Lexical analysis
semantic-lex-number-expression semantic-java-number-regexp
- semantic-lex-analyzer 'wisent-java-tags-lexer
+ semantic-lex-analyzer #'wisent-java-tags-lexer
;; Parsing
- semantic-tag-expand-function 'semantic-java-expand-tag
+ semantic-tag-expand-function #'semantic-java-expand-tag
;; Environment
- semantic-imenu-summary-function 'semantic-format-tag-prototype
- imenu-create-index-function 'semantic-create-imenu-index
+ semantic-imenu-summary-function #'semantic-format-tag-prototype
+ imenu-create-index-function #'semantic-create-imenu-index
semantic-type-relation-separator-character '(".")
semantic-command-separation-character ";"
;; speedbar and imenu buckets name
diff --git a/lisp/cedet/semantic/wisent/javascript.el b/lisp/cedet/semantic/wisent/javascript.el
index 684eea1d93d..1932f205ee0 100644
--- a/lisp/cedet/semantic/wisent/javascript.el
+++ b/lisp/cedet/semantic/wisent/javascript.el
@@ -1,4 +1,4 @@
-;;; semantic/wisent/javascript.el --- javascript parser support
+;;; semantic/wisent/javascript.el --- javascript parser support -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2009-2021 Free Software Foundation, Inc.
@@ -70,7 +70,7 @@ This function overrides `get-local-variables'."
;; Does javascript have identifiable local variables?
nil)
-(define-mode-local-override semantic-tag-protection js-mode (tag &optional parent)
+(define-mode-local-override semantic-tag-protection js-mode (_tag &optional _parent)
"Return protection information about TAG with optional PARENT.
This function returns on of the following symbols:
nil - No special protection. Language dependent.
@@ -85,7 +85,7 @@ The default behavior (if not overridden with `tag-protection'
is to return a symbol based on type modifiers."
nil)
-(define-mode-local-override semantic-analyze-scope-calculate-access js-mode (type scope)
+(define-mode-local-override semantic-analyze-scope-calculate-access js-mode (_type _scope)
"Calculate the access class for TYPE as defined by the current SCOPE.
Access is related to the :parents in SCOPE. If type is a member of SCOPE
then access would be `private'. If TYPE is inherited by a member of SCOPE,
@@ -101,7 +101,7 @@ This is currently needed for the mozrepl omniscient database."
(save-excursion
(if point (goto-char point))
(let* ((case-fold-search semantic-case-fold)
- symlist tmp end)
+ tmp end) ;; symlist
(with-syntax-table semantic-lex-syntax-table
(save-excursion
(when (looking-at "\\w\\|\\s_")
@@ -110,10 +110,11 @@ This is currently needed for the mozrepl omniscient database."
(unless (re-search-backward "\\s-" (point-at-bol) t)
(beginning-of-line))
(setq tmp (buffer-substring-no-properties (point) end))
+ ;; (setq symlist
(if (string-match "\\(.+\\)\\." tmp)
- (setq symlist (list (match-string 1 tmp)
- (substring tmp (1+ (match-end 1)) (length tmp))))
- (setq symlist (list tmp))))))))
+ (list (match-string 1 tmp)
+ (substring tmp (1+ (match-end 1)) (length tmp)))
+ (list tmp)))))));; )
;;; Setup Function
;;
@@ -127,14 +128,14 @@ This is currently needed for the mozrepl omniscient database."
(wisent-javascript-jv-wy--install-parser)
(setq
;; Lexical Analysis
- semantic-lex-analyzer 'javascript-lexer-jv
+ semantic-lex-analyzer #'javascript-lexer-jv
semantic-lex-number-expression semantic-java-number-regexp
;; semantic-lex-depth nil ;; Full lexical analysis
;; Parsing
- semantic-tag-expand-function 'wisent-javascript-jv-expand-tag
+ semantic-tag-expand-function #'wisent-javascript-jv-expand-tag
;; Environment
- semantic-imenu-summary-function 'semantic-format-tag-name
- imenu-create-index-function 'semantic-create-imenu-index
+ semantic-imenu-summary-function #'semantic-format-tag-name
+ imenu-create-index-function #'semantic-create-imenu-index
semantic-command-separation-character ";"
))
diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el
index 0f22321c24c..9ac4ed9f518 100644
--- a/lisp/cedet/semantic/wisent/python.el
+++ b/lisp/cedet/semantic/wisent/python.el
@@ -1,4 +1,4 @@
-;;; wisent-python.el --- Semantic support for Python
+;;; wisent-python.el --- Semantic support for Python -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
@@ -27,8 +27,6 @@
;;; Code:
-(require 'rx)
-
;; Try to load python support, but fail silently since it is only used
;; for optional functionality
(require 'python nil t)
@@ -464,19 +462,19 @@ To be implemented for Python! For now just return nil."
(define-mode-local-override semantic-tag-include-filename python-mode (tag)
"Return a suitable path for (some) Python imports."
(let ((name (semantic-tag-name tag)))
- (concat (mapconcat 'identity (split-string name "\\.") "/") ".py")))
+ (concat (mapconcat #'identity (split-string name "\\.") "/") ".py")))
;; Override ctxt-current-function/assignment defaults, since they do
;; not work properly with Python code, even leading to endless loops
;; (see bug #xxxxx).
-(define-mode-local-override semantic-ctxt-current-function python-mode (&optional point)
+(define-mode-local-override semantic-ctxt-current-function python-mode (&optional _point)
"Return the current function call the cursor is in at POINT.
The function returned is the one accepting the arguments that
the cursor is currently in. It will not return function symbol if the
cursor is on the text representing that function."
nil)
-(define-mode-local-override semantic-ctxt-current-assignment python-mode (&optional point)
+(define-mode-local-override semantic-ctxt-current-assignment python-mode (&optional _point)
"Return the current assignment near the cursor at POINT.
Return a list as per `semantic-ctxt-current-symbol'.
Return nil if there is nothing relevant."
@@ -503,21 +501,21 @@ Shortens `code' tags, but passes through for others."
(defun wisent-python-default-setup ()
"Setup buffer for parse."
(wisent-python-wy--install-parser)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (setq-local parse-sexp-ignore-comments t)
;; Give python modes the possibility to overwrite this:
(if (not comment-start-skip)
- (set (make-local-variable 'comment-start-skip) "#+\\s-*"))
+ (setq-local comment-start-skip "#+\\s-*"))
(setq
;; Character used to separation a parent/child relationship
semantic-type-relation-separator-character '(".")
semantic-command-separation-character ";"
;; Parsing
- semantic-tag-expand-function 'semantic-python-expand-tag
+ semantic-tag-expand-function #'semantic-python-expand-tag
;; Semantic to take over from the one provided by python.
;; The python one, if it uses the senator advice, will hang
;; Emacs unrecoverably.
- imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function #'semantic-create-imenu-index
;; I need a python guru to update this list:
semantic-symbol->name-assoc-list-for-type-parts '((variable . "Variables")
diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el
index 0d3eba00e93..62d99ef6972 100644
--- a/lisp/cedet/semantic/wisent/wisent.el
+++ b/lisp/cedet/semantic/wisent/wisent.el
@@ -1,6 +1,6 @@
-;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime
+;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime -*- lexical-binding: t; -*-
-;;; Copyright (C) 2002-2007, 2009-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Created: 30 January 2002
@@ -34,9 +34,6 @@
;;
;; For more details on Wisent itself read the Wisent manual.
-;;; History:
-;;
-
;;; Code:
(defgroup wisent nil
@@ -55,11 +52,8 @@
;;;; Runtime stuff
;;;; -------------
-;;; Compatibility
-(eval-and-compile
- (if (fboundp 'char-valid-p)
- (defalias 'wisent-char-p 'char-valid-p)
- (defalias 'wisent-char-p 'char-or-char-int-p)))
+(define-obsolete-function-alias 'wisent-char-p
+ #'characterp "28.1")
;;; Printed representation of terminals and nonterminals
(defconst wisent-escape-sequence-strings
@@ -80,7 +74,7 @@
(defsubst wisent-item-to-string (item)
"Return a printed representation of ITEM.
ITEM can be a nonterminal or terminal symbol, or a character literal."
- (if (wisent-char-p item)
+ (if (characterp item)
(or (cdr (assq item wisent-escape-sequence-strings))
(format "'%c'" item))
(symbol-name item)))
@@ -142,7 +136,7 @@ POSITIONS are available."
"Print a one-line message if `wisent-parse-verbose-flag' is set.
Pass STRING and ARGS arguments to `message'."
(and wisent-parse-verbose-flag
- (apply 'message string args)))
+ (apply #'message string args)))
;;;; --------------------
;;;; The LR parser engine
@@ -150,13 +144,11 @@ Pass STRING and ARGS arguments to `message'."
(defcustom wisent-parse-max-stack-size 500
"The parser stack size."
- :type 'integer
- :group 'wisent)
+ :type 'integer)
(defcustom wisent-parse-max-recover 3
"Number of tokens to shift before turning off error status."
- :type 'integer
- :group 'wisent)
+ :type 'integer)
(defvar wisent-discarding-token-functions nil
"List of functions to be called when discarding a lexical token.
@@ -400,9 +392,9 @@ automaton has only one entry point."
(wisent-error
(format "Syntax error, unexpected %s, expecting %s"
(wisent-token-to-string wisent-input)
- (mapconcat 'wisent-item-to-string
+ (mapconcat #'wisent-item-to-string
(delq wisent-error-term
- (mapcar 'car (cdr choices)))
+ (mapcar #'car (cdr choices)))
", "))))
;; Increment the error counter
(setq wisent-nerrs (1+ wisent-nerrs))
diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el
index 79cba94ab02..83e9754a608 100644
--- a/lisp/cedet/srecode.el
+++ b/lisp/cedet/srecode.el
@@ -1,6 +1,6 @@
-;;; srecode.el --- Semantic buffer evaluator.
+;;; srecode.el --- Semantic buffer evaluator. -*- lexical-binding: t -*-
-;;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el
index 24c5f22f2e7..79d2700c5d9 100644
--- a/lisp/cedet/srecode/args.el
+++ b/lisp/cedet/srecode/args.el
@@ -1,4 +1,4 @@
-;;; srecode/args.el --- Provide some simple template arguments
+;;; srecode/args.el --- Provide some simple template arguments -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el
index 7146b643836..15107ef1e43 100644
--- a/lisp/cedet/srecode/compile.el
+++ b/lisp/cedet/srecode/compile.el
@@ -1,4 +1,4 @@
-;;; srecode/compile --- Compilation of srecode template files.
+;;; srecode/compile --- Compilation of srecode template files. -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
@@ -110,7 +110,12 @@ stack is broken."
:type (or null string)
:documentation
"If there is a colon in the inserter's name, it represents
-additional static argument data."))
+additional static argument data.")
+ (key :initform nil :allocation :class
+ :documentation
+ "The character code used to identify inserters of this style.
+All children of this class should specify `key' slot with appropriate
+:initform value."))
"This represents an item to be inserted via a template macro.
Plain text strings are not handled via this baseclass."
:abstract t)
@@ -499,7 +504,7 @@ PROPS are additional properties that might need to be passed
to the inserter constructor."
;;(message "Compile: %s %S" name props)
(if (not key)
- (apply 'srecode-template-inserter-variable name props)
+ (apply #'make-instance 'srecode-template-inserter-variable name props)
(let ((classes (eieio-class-children 'srecode-template-inserter))
(new nil))
;; Loop over the various subclasses and
@@ -510,7 +515,7 @@ to the inserter constructor."
(when (and (not (class-abstract-p (car classes)))
(equal (oref-default (car classes) key) key))
;; Create the new class, and apply state.
- (setq new (apply (car classes) name props))
+ (setq new (apply #'make-instance (car classes) name props))
(srecode-inserter-apply-state new STATE)
)
(setq classes (cdr classes)))
diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el
index 1b9610f3f1b..dc5e8da5cdb 100644
--- a/lisp/cedet/srecode/cpp.el
+++ b/lisp/cedet/srecode/cpp.el
@@ -1,4 +1,4 @@
-;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
+;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder -*- lexical-binding: t; -*-
;; Copyright (C) 2007, 2009-2021 Free Software Foundation, Inc.
@@ -44,7 +44,6 @@
A dictionary entry of the named PREFIX_NAMESPACE with the value
NAMESPACE:: is created for each namespace unless the current
buffer contains a using NAMESPACE; statement."
- :group 'srecode-cpp
:type '(repeat string))
;;; :c ARGUMENT HANDLING
@@ -165,7 +164,7 @@ specified in a C file."
;; when they make sense. My best bet would be
;; (semantic-tag-function-parent tag), but it is not there, when
;; the function is defined in the scope of a class.
- (let ((member t)
+ (let (;; (member t)
(templates (semantic-tag-get-attribute tag :template))
(modifiers (semantic-tag-modifiers tag)))
@@ -186,7 +185,7 @@ specified in a C file."
;; When the function is a member function, it can have
;; additional modifiers.
- (when member
+ (when t ;; member
;; For member functions, constness is called
;; 'methodconst-flag'.
diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el
index 20334f95838..c49237b94cf 100644
--- a/lisp/cedet/srecode/ctxt.el
+++ b/lisp/cedet/srecode/ctxt.el
@@ -1,4 +1,4 @@
-;;; srecode/ctxt.el --- Derive a context from the source buffer.
+;;; srecode/ctxt.el --- Derive a context from the source buffer. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el
index c1fe4b2c34e..5da045e17f1 100644
--- a/lisp/cedet/srecode/dictionary.el
+++ b/lisp/cedet/srecode/dictionary.el
@@ -1,4 +1,4 @@
-;;; srecode/dictionary.el --- Dictionary code for the semantic recoder.
+;;; srecode/dictionary.el --- Dictionary code for the semantic recoder. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -443,8 +443,8 @@ The root dictionary is usually for a current or active insertion."
;; for use in converting the compound value into something insertable.
(cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
- function
- dictionary)
+ _function
+ _dictionary)
"Convert the compound dictionary value CP to a string.
If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
of the compound value. The FUNCTION could be a fraction
@@ -457,14 +457,15 @@ standard out is a buffer, and using `insert'."
(eieio-object-name cp))
(cl-defmethod srecode-dump ((cp srecode-dictionary-compound-value)
- &optional indent)
+ &optional _indent)
"Display information about this compound value."
(princ (eieio-object-name cp))
)
-(cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
- function
- dictionary)
+(cl-defmethod srecode-compound-toString
+ ((cp srecode-dictionary-compound-variable)
+ _function
+ dictionary)
"Convert the compound dictionary variable value CP into a string.
FUNCTION and DICTIONARY are as for the baseclass."
(require 'srecode/insert)
@@ -606,9 +607,9 @@ STATE is the current compiler state."
(require 'srecode/find)
(let* ((modesym major-mode)
(start (current-time))
- (junk (or (progn (srecode-load-tables-for-mode modesym)
- (srecode-get-mode-table modesym))
- (error "No table found for mode %S" modesym)))
+ (_ (or (progn (srecode-load-tables-for-mode modesym)
+ (srecode-get-mode-table modesym))
+ (error "No table found for mode %S" modesym)))
(dict (srecode-create-dictionary (current-buffer)))
)
(message "Creating a dictionary took %.2f seconds."
diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el
index 989267cf55a..270b80d9013 100644
--- a/lisp/cedet/srecode/document.el
+++ b/lisp/cedet/srecode/document.el
@@ -1,4 +1,4 @@
-;;; srecode/document.el --- Documentation (comment) generation
+;;; srecode/document.el --- Documentation (comment) generation -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -88,8 +88,7 @@ versions of names. This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-function-alist
@@ -144,8 +143,7 @@ A string may end in a space, in which case, last-alist is searched to
see how best to describe what can be returned.
Doesn't always work correctly, but that is just because English
doesn't always work correctly."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-common-nouns-abbrevs
@@ -175,8 +173,7 @@ versions of names. This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-return-first-alist
@@ -192,8 +189,7 @@ This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-return-last-alist
@@ -213,8 +209,7 @@ This is an alist with each element of the form:
MATCH is a regexp to match in the type field.
RESULT is a string, which can contain %s, which is replaced with
`match-string' 1."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-param-alist
@@ -233,8 +228,7 @@ MATCH is a regexp to match in the type field.
RESULT is a string of text to use to describe MATCH.
When one is encountered, document-insert-parameters will automatically
place this comment after the parameter name."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
(defcustom srecode-document-autocomment-param-type-alist
@@ -258,8 +252,7 @@ This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
- :group 'document
- :type '(repeat (cons (string :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
;;;###autoload
@@ -716,7 +709,7 @@ allocating something based on its type."
(setq al (cdr al)))))
news))
-(defun srecode-document-parameter-comment (param &optional commentlist)
+(defun srecode-document-parameter-comment (param &optional _commentlist)
"Convert tag or string PARAM into a name,comment pair.
Optional COMMENTLIST is list of previously existing comments to
use instead in alist form. If the name doesn't appear in the list of
diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el
index 7e9dd10fd42..974a4fac727 100644
--- a/lisp/cedet/srecode/el.el
+++ b/lisp/cedet/srecode/el.el
@@ -1,4 +1,4 @@
-;;; srecode/el.el --- Emacs Lisp specific arguments
+;;; srecode/el.el --- Emacs Lisp specific arguments -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el
index cdb29d16b71..a40d5aec24d 100644
--- a/lisp/cedet/srecode/expandproto.el
+++ b/lisp/cedet/srecode/expandproto.el
@@ -1,4 +1,4 @@
-;;; srecode/expandproto.el --- Expanding prototypes.
+;;; srecode/expandproto.el --- Expanding prototypes. -*- lexical-binding: t; -*-
;; Copyright (C) 2007, 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el
index 625b854b776..9e6a98fd769 100644
--- a/lisp/cedet/srecode/extract.el
+++ b/lisp/cedet/srecode/extract.el
@@ -1,4 +1,4 @@
-;;; srecode/extract.el --- Extract content from previously inserted macro.
+;;; srecode/extract.el --- Extract content from previously inserted macro. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -139,24 +139,24 @@ Uses STATE to maintain the current extraction state."
;;; Inserter Base Extractors
;;
-(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter))
+(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter))
"Return non-nil if this inserter can extract values."
nil)
-(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter)
- start end dict state)
+(cl-defmethod srecode-inserter-extract ((_ins srecode-template-inserter)
+ _start _end _dict _state)
"Extract text from START/END and store in DICT.
Return nil as this inserter will extract nothing."
nil)
;;; Variable extractor is simple and can extract later.
;;
-(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable))
+(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-variable))
"Return non-nil if this inserter can extract values."
'later)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
- start end vdict state)
+ start end vdict _state)
"Extract text from START/END and store in VDICT.
Return t if something was extracted.
Return nil if this inserter doesn't need to extract anything."
@@ -168,12 +168,12 @@ Return nil if this inserter doesn't need to extract anything."
;;; Section Inserter
;;
-(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start))
+(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-section-start))
"Return non-nil if this inserter can extract values."
'now)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start)
- start end indict state)
+ _start _end indict state)
"Extract text from START/END and store in INDICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."
@@ -201,12 +201,12 @@ Return nil if nothing was extracted."
;;; Include Extractor must extract now.
;;
-(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include))
+(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-include))
"Return non-nil if this inserter can extract values."
'now)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
- start end dict state)
+ start _end dict state)
"Extract text from START/END and store in DICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el
index 4a585731a40..e65e3194320 100644
--- a/lisp/cedet/srecode/fields.el
+++ b/lisp/cedet/srecode/fields.el
@@ -1,4 +1,4 @@
-;;; srecode/fields.el --- Handling type-in fields in a buffer.
+;;; srecode/fields.el --- Handling type-in fields in a buffer. -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;;
@@ -164,7 +164,7 @@ Has virtual :start and :end initializers.")
(cl-defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to)
"Return the text under OLAID.
-If SET-TO is a string, then replace the text of OLAID wit SET-TO."
+If SET-TO is a string, then replace the text of OLAID with SET-TO."
(let* ((ol (oref olaid overlay))
(start (overlay-start ol)))
(if (not (stringp set-to))
@@ -193,7 +193,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
"Manage a buffer region in which fields exist.")
(cl-defmethod initialize-instance ((ir srecode-template-inserted-region)
- &rest args)
+ &rest _args)
"Initialize IR, capturing the active fields, and creating the overlay."
;; Fill in the fields
(oset ir fields srecode-field-archive)
@@ -221,7 +221,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
(oset ir active-region ir)
;; Setup the post command hook.
- (add-hook 'post-command-hook 'srecode-field-post-command t t)
+ (add-hook 'post-command-hook #'srecode-field-post-command t t)
)
(cl-defmethod srecode-delete ((ir srecode-template-inserted-region))
@@ -229,12 +229,11 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
;; Clear us out of the baseclass.
(oset ir active-region nil)
;; Clear our fields.
- (mapc 'srecode-delete (oref ir fields))
+ (mapc #'srecode-delete (oref ir fields))
;; Call to our base
(cl-call-next-method)
;; Clear our hook.
- (remove-hook 'post-command-hook 'srecode-field-post-command t)
- )
+ (remove-hook 'post-command-hook #'srecode-field-post-command t))
(defsubst srecode-active-template-region ()
"Return the active region for template fields."
@@ -246,7 +245,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
)
(if (not ar)
;; Find a bug and fix it.
- (remove-hook 'post-command-hook 'srecode-field-post-command t)
+ (remove-hook 'post-command-hook #'srecode-field-post-command t)
(if (srecode-point-in-region-p ar)
nil ;; Keep going
;; We moved out of the template. Cancel the edits.
@@ -277,16 +276,16 @@ Try to use this to provide useful completion when available.")
(defvar srecode-field-keymap
(let ((km (make-sparse-keymap)))
- (define-key km "\C-i" 'srecode-field-next)
- (define-key km "\M-\C-i" 'srecode-field-prev)
- (define-key km "\C-e" 'srecode-field-end)
- (define-key km "\C-a" 'srecode-field-start)
- (define-key km "\M-m" 'srecode-field-start)
- (define-key km "\C-c\C-c" 'srecode-field-exit-ask)
+ (define-key km "\C-i" #'srecode-field-next)
+ (define-key km "\M-\C-i" #'srecode-field-prev)
+ (define-key km "\C-e" #'srecode-field-end)
+ (define-key km "\C-a" #'srecode-field-start)
+ (define-key km "\M-m" #'srecode-field-start)
+ (define-key km "\C-c\C-c" #'srecode-field-exit-ask)
km)
"Keymap applied to field overlays.")
-(cl-defmethod initialize-instance ((field srecode-field) &optional args)
+(cl-defmethod initialize-instance ((field srecode-field) &optional _args)
"Initialize FIELD, being sure it archived."
(add-to-list 'srecode-field-archive field t)
(cl-call-next-method)
@@ -327,7 +326,7 @@ Try to use this to provide useful completion when available.")
(defvar srecode-field-replication-max-size 100
"Maximum size of a field before canceling replication.")
-(defun srecode-field-mod-hook (ol after start end &optional pre-len)
+(defun srecode-field-mod-hook (ol after _start _end &optional _pre-len)
"Modification hook for the field overlay.
OL is the overlay.
AFTER is non-nil if it is called after the change.
@@ -374,7 +373,7 @@ AFTER is non-nil if it is called after the change.
START and END are the bounds of the change.
PRE-LEN is used in the after mode for the length of the changed text."
(when after
- (let* ((field (overlay-get ol 'srecode))
+ (let* (;; (field (overlay-get ol 'srecode))
)
(move-overlay ol (overlay-start ol) end)
(srecode-field-mod-hook ol after start end pre-len))
diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el
index 4a996cf6f12..b76ce2c94bf 100644
--- a/lisp/cedet/srecode/filters.el
+++ b/lisp/cedet/srecode/filters.el
@@ -1,4 +1,4 @@
-;;; srecode/filters.el --- Filters for use in template variables.
+;;; srecode/filters.el --- Filters for use in template variables. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el
index aec73dce5a5..1c208d0f328 100644
--- a/lisp/cedet/srecode/find.el
+++ b/lisp/cedet/srecode/find.el
@@ -1,4 +1,4 @@
-;;;; srecode/find.el --- Tools for finding templates in the database.
+;;;; srecode/find.el --- Tools for finding templates in the database. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -58,17 +58,14 @@ See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case,
all template files for that application will be loaded."
(let ((files
- (if appname
- (apply 'append
- (mapcar
+ (apply #'append
+ (mapcar
+ (if appname
(lambda (map)
(srecode-map-entries-for-app-and-mode map appname mmode))
- (srecode-get-maps)))
- (apply 'append
- (mapcar
(lambda (map)
- (srecode-map-entries-for-mode map mmode))
- (srecode-get-maps)))))
+ (srecode-map-entries-for-mode map mmode)))
+ (srecode-get-maps))))
)
;; Don't recurse if we are already the 'default state.
(when (not (eq mmode 'default))
@@ -112,8 +109,8 @@ If TAB is nil, then always return t."
;; Find a given template based on name, and features of the current
;; buffer.
(cl-defmethod srecode-template-get-table ((tab srecode-template-table)
- template-name &optional
- context application)
+ template-name &optional
+ context _application)
"Find in the template in table TAB, the template with TEMPLATE-NAME.
Optional argument CONTEXT specifies that the template should part
of a particular context.
@@ -218,7 +215,7 @@ tables that do not belong to an application will be searched."
(defvar srecode-read-template-name-history nil
"History for completing reads for template names.")
-(defun srecode-user-template-p (template)
+(defun srecode-user-template-p (_template)
"Non-nil if TEMPLATE is intended for user insertion.
Templates not matching this predicate are used for code
generation or other internal purposes."
@@ -264,7 +261,7 @@ with `srecode-calculate-context'."
;; the prefix for the completing read
(concat (nth 0 ctxt) ":"))))
-(defun srecode-read-template-name (prompt &optional initial hist default)
+(defun srecode-read-template-name (prompt &optional initial hist _default)
"Completing read for Semantic Recoder template names.
PROMPT is used to query for the name of the template desired.
INITIAL is the initial string to use.
diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el
index 1e4888655f9..ce4c818c709 100644
--- a/lisp/cedet/srecode/getset.el
+++ b/lisp/cedet/srecode/getset.el
@@ -1,4 +1,4 @@
-;;; srecode/getset.el --- Package for inserting new get/set methods.
+;;; srecode/getset.el --- Package for inserting new get/set methods. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -33,6 +33,8 @@
(defvar srecode-insert-getset-fully-automatic-flag nil
"Non-nil means accept choices srecode comes up with without asking.")
+(defvar srecode-semantic-selected-tag)
+
;;;###autoload
(defun srecode-insert-getset (&optional class-in field-in)
"Insert get/set methods for the current class.
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el
index ab0503c8d36..f20842b1d8a 100644
--- a/lisp/cedet/srecode/insert.el
+++ b/lisp/cedet/srecode/insert.el
@@ -89,6 +89,8 @@ DICT-ENTRIES are additional dictionary values to add."
;; for this insertion step.
))
+(eieio-declare-slots (point :allocation :class))
+
(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
"Insert TEMPLATE using DICTIONARY into STREAM.
Optional SKIPRESOLVER means to avoid refreshing the tag list,
@@ -134,13 +136,13 @@ has set everything up already."
)
(srecode-insert-method template dictionary))
;; Handle specialization of the POINT inserter.
- (when (and (bufferp standard-output)
- (slot-boundp 'srecode-template-inserter-point 'point)
- )
- (set-buffer standard-output)
- (setq end-mark (point-marker))
- (goto-char (oref-default 'srecode-template-inserter-point point)))
- (oset-default 'srecode-template-inserter-point point eieio-unbound)
+ (when (bufferp standard-output)
+ (let ((point (oref-default 'srecode-template-inserter-point point)))
+ (when point
+ (set-buffer standard-output)
+ (setq end-mark (point-marker))
+ (goto-char point))))
+ (oset-default 'srecode-template-inserter-point point nil)
;; Return the end-mark.
(or end-mark (point)))
@@ -733,6 +735,7 @@ DEPTH.")
"The character code used to identify inserters of this style.")
(point :type (or null marker)
:allocation :class
+ :initform nil
:documentation
"Record the value of (point) in this class slot.
It is the responsibility of the inserter algorithm to clear this
diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el
index 768d48a7c5b..0f0a80ee299 100644
--- a/lisp/cedet/srecode/java.el
+++ b/lisp/cedet/srecode/java.el
@@ -1,4 +1,4 @@
-;;; srecode/java.el --- Srecode Java support
+;;; srecode/java.el --- Srecode Java support -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index a94db0bb8d9..254b15e6e04 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -1,4 +1,4 @@
-;;; srecode/map.el --- Manage a template file map
+;;; srecode/map.el --- Manage a template file map -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -245,7 +245,7 @@ Optional argument RESET forces a reset of the current map."
(princ "\n")
))
-(defun srecode-map-file-still-valid-p (filename map)
+(defun srecode-map-file-still-valid-p (filename _map)
"Return t if FILENAME should be in MAP still."
(let ((valid nil))
(and (file-exists-p filename)
@@ -407,7 +407,7 @@ Return non-nil if the map changed."
"Global load path for SRecode template files."
:group 'srecode
:type '(repeat file)
- :set 'srecode-map-load-path-set)
+ :set #'srecode-map-load-path-set)
(provide 'srecode/map)
diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el
index 159dc7a999b..9b1c8491a12 100644
--- a/lisp/cedet/srecode/mode.el
+++ b/lisp/cedet/srecode/mode.el
@@ -1,4 +1,4 @@
-;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
+;;; srecode/mode.el --- Minor mode for managing and using SRecode templates -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -54,14 +54,14 @@
(defvar srecode-prefix-map
(let ((km (make-sparse-keymap)))
;; Basic template codes
- (define-key km "/" 'srecode-insert)
- (define-key km [insert] 'srecode-insert)
- (define-key km "." 'srecode-insert-again)
- (define-key km "E" 'srecode-edit)
+ (define-key km "/" #'srecode-insert)
+ (define-key km [insert] #'srecode-insert)
+ (define-key km "." #'srecode-insert-again)
+ (define-key km "E" #'srecode-edit)
;; Template indirect binding
(let ((k ?a))
(while (<= k ?z)
- (define-key km (format "%c" k) 'srecode-bind-insert)
+ (define-key km (format "%c" k) #'srecode-bind-insert)
(setq k (1+ k))))
km)
"Keymap used behind the srecode prefix key in srecode minor mode.")
@@ -141,16 +141,17 @@ non-nil if the minor mode is enabled.
;; this mode first.
(if srecode-minor-mode
(if (not (apply
- 'append
+ #'append
(mapcar (lambda (map)
(srecode-map-entries-for-mode map major-mode))
(srecode-get-maps))))
(setq srecode-minor-mode nil)
;; Else, we have success, do stuff
- (add-hook 'cedet-m3-menu-do-hooks 'srecode-m3-items nil t)
- )
- (remove-hook 'cedet-m3-menu-do-hooks 'srecode-m3-items t)
- )
+ ;; FIXME: Where are `cedet-m3-menu-do-hooks' nor `srecode-m3-items'?
+ (when (fboundp 'srecode-m3-items)
+ (add-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items nil t)))
+ (when (fboundp 'srecode-m3-items)
+ (remove-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items t)))
;; Run hooks if we are turning this on.
(when srecode-minor-mode
(run-hooks 'srecode-minor-mode-hook))
@@ -170,7 +171,7 @@ non-nil if the minor mode is enabled.
;;; Menu Filters
;;
-(defun srecode-minor-mode-templates-menu (menu-def)
+(defun srecode-minor-mode-templates-menu (_menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.
@@ -223,13 +224,11 @@ MENU-DEF is the menu to bind this into."
(if bind
(concat name " (" bind ")")
name)
- `(lambda () (interactive)
- (srecode-insert (concat ,ctxt ":" ,name)))
+ (lambda () (interactive)
+ (srecode-insert (concat ctxt ":" name)))
t)))
- (setcdr ctxtcons (cons
- new
- (cdr ctxtcons)))))
+ (push new (cdr ctxtcons))))
(setq ltab (cdr ltab))))
(setq subtab (cdr subtab)))
@@ -246,7 +245,7 @@ MENU-DEF is the menu to bind this into."
(defvar srecode-minor-mode-generators nil
"List of code generators to be displayed in the srecoder menu.")
-(defun srecode-minor-mode-generate-menu (menu-def)
+(defun srecode-minor-mode-generate-menu (_menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.
diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el
index bbe1778c418..101246cae6f 100644
--- a/lisp/cedet/srecode/semantic.el
+++ b/lisp/cedet/srecode/semantic.el
@@ -1,4 +1,4 @@
-;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
+;;; srecode/semantic.el --- Semantic specific extensions to SRecode -*- lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -57,7 +57,7 @@ This class will be used to derive dictionary values.")
(cl-defmethod srecode-compound-toString((cp srecode-semantic-tag)
function
- dictionary)
+ _dictionary)
"Convert the compound dictionary value CP to a string.
If FUNCTION is non-nil, then FUNCTION is somehow applied to an
aspect of the compound value."
@@ -201,7 +201,7 @@ variable default values, and other things."
(let ((tag (or srecode-semantic-selected-tag
(srecode-semantic-tag-from-kill-ring))))
(when (not tag)
- "No tag for current template. Use the semantic kill-ring.")
+ (error "No tag for current template. Use the semantic kill-ring."))
(srecode-semantic-apply-tag-to-dict
(srecode-semantic-tag (semantic-tag-name tag)
:prime tag)
@@ -410,7 +410,9 @@ as `function' will leave point where code might be inserted."
;; Insert the template.
(let ((endpt (srecode-insert-fcn temp dict nil t)))
- (run-hook-with-args 'point-insert-fcn tag)
+ (if (functionp point-insert-fcn)
+ (funcall point-insert-fcn tag)
+ (dolist (f point-insert-fcn) (funcall f tag)))
;;(sit-for 1)
(cond
diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el
index a8c633277f7..71579158494 100644
--- a/lisp/cedet/srecode/srt-mode.el
+++ b/lisp/cedet/srecode/srt-mode.el
@@ -1,4 +1,4 @@
-;;; srecode/srt-mode.el --- Major mode for writing screcode macros
+;;; srecode/srt-mode.el --- Major mode for writing screcode macros -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
@@ -181,9 +181,9 @@ we can tell font lock about them.")
(defvar srecode-template-mode-map
(let ((km (make-sparse-keymap)))
- (define-key km "\C-c\C-c" 'srecode-compile-templates)
- (define-key km "\C-c\C-m" 'srecode-macro-help)
- (define-key km "/" 'srecode-self-insert-complete-end-macro)
+ (define-key km "\C-c\C-c" #'srecode-compile-templates)
+ (define-key km "\C-c\C-m" #'srecode-macro-help)
+ (define-key km "/" #'srecode-self-insert-complete-end-macro)
km)
"Keymap used in srecode mode.")
@@ -191,21 +191,21 @@ we can tell font lock about them.")
(define-derived-mode srecode-template-mode fundamental-mode "SRecode"
;; FIXME: Shouldn't it derive from prog-mode?
"Major-mode for writing SRecode macros."
- (set (make-local-variable 'comment-start) ";;")
- (set (make-local-variable 'comment-end) "")
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (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 constituent,
- ;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w")))))
+ (setq-local comment-start ";;")
+ (setq-local comment-end "")
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local comment-start-skip
+ "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (setq-local font-lock-defaults
+ '(srecode-font-lock-keywords
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituent,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w")))))
;;;###autoload
-(defalias 'srt-mode 'srecode-template-mode)
+(defalias 'srt-mode #'srecode-template-mode)
;;; Template Commands
;;
@@ -436,7 +436,7 @@ Moves to the end of one named section."
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(args (semantic-tag-function-arguments tag))
- (argsym (mapcar 'intern args))
+ (argsym (mapcar #'intern args))
(argvars nil)
;; Create a temporary dictionary in which the
;; arguments can be resolved so we can extract
@@ -475,7 +475,7 @@ section or ? for an ask variable."
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (point))
(macrostart nil)
- (raw nil)
+ ;; (raw nil)
)
(when (and tag (semantic-tag-of-class-p tag 'function)
(srecode-in-macro-p point)
@@ -627,7 +627,7 @@ section or ? for an ask variable."
context-return)))
(define-mode-local-override semantic-analyze-possible-completions
- srecode-template-mode (context &rest flags)
+ srecode-template-mode (context &rest _flags)
"Return a list of possible completions based on NONTEXT."
(with-current-buffer (oref context buffer)
(let* ((prefix (car (last (oref context prefix))))
diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el
index e222997708b..161b5105b51 100644
--- a/lisp/cedet/srecode/srt.el
+++ b/lisp/cedet/srecode/srt.el
@@ -1,4 +1,4 @@
-;;; srecode/srt.el --- argument handlers for SRT files
+;;; srecode/srt.el --- argument handlers for SRT files -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -43,7 +43,7 @@ DEFAULT is the default if RET is hit."
(currfcn (semantic-current-tag))
)
(srecode-resolve-argument-list
- (mapcar 'read
+ (mapcar #'read
(semantic-tag-get-attribute currfcn :arguments))
newdict)
@@ -56,7 +56,7 @@ DEFAULT is the default if RET is hit."
(defvar srecode-read-major-mode-history nil
"History for `srecode-read-variable-name'.")
-(defun srecode-read-major-mode-name (prompt &optional initial hist default)
+(defun srecode-read-major-mode-name (prompt &optional initial hist _default)
"Read in the name of a desired `major-mode'.
PROMPT is the prompt to use.
INITIAL is the initial string.
@@ -64,7 +64,7 @@ HIST is the history value, otherwise `srecode-read-variable-name-history'
is used.
DEFAULT is the default if RET is hit."
(completing-read prompt obarray
- (lambda (s) (string-match "-mode$" (symbol-name s)))
+ (lambda (s) (string-match "-mode\\'" (symbol-name s)))
nil initial (or hist 'srecode-read-major-mode-history))
)
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
index 60a466f89d9..7ce5cc73b61 100644
--- a/lisp/cedet/srecode/table.el
+++ b/lisp/cedet/srecode/table.el
@@ -1,4 +1,4 @@
-;;; srecode/table.el --- Tables of Semantic Recoders
+;;; srecode/table.el --- Tables of Semantic Recoders -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -169,7 +169,7 @@ calculate all inherited templates from parent modes."
:modetables nil
:tables nil)))
;; Save this new mode table in that mode's variable.
- (eval `(setq-mode-local ,mode srecode-table ,new))
+ (eval `(setq-mode-local ,mode srecode-table ,new) t)
new))))
@@ -184,7 +184,7 @@ INIT are the initialization parameters for the new template table."
(let* ((mt (srecode-make-mode-table mode))
(old (srecode-mode-table-find mt file))
(attr (file-attributes file))
- (new (apply 'srecode-template-table
+ (new (apply #'srecode-template-table
(file-name-nondirectory file)
:file file
:filesize (file-attribute-size attr)
diff --git a/lisp/cedet/srecode/template.el b/lisp/cedet/srecode/template.el
index e9e5115128f..1f6f0d345da 100644
--- a/lisp/cedet/srecode/template.el
+++ b/lisp/cedet/srecode/template.el
@@ -1,4 +1,4 @@
-;;; srecode/template.el --- SRecoder template language parser support.
+;;; srecode/template.el --- SRecoder template language parser support. -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
@@ -49,11 +49,11 @@
(setq
;; Lexical Analysis
- semantic-lex-analyzer 'wisent-srecode-template-lexer
+ semantic-lex-analyzer #'wisent-srecode-template-lexer
;; Parsing
;; Environment
- semantic-imenu-summary-function 'semantic-format-tag-name
- imenu-create-index-function 'semantic-create-imenu-index
+ semantic-imenu-summary-function #'semantic-format-tag-name
+ imenu-create-index-function #'semantic-create-imenu-index
semantic-command-separation-character "\n"
semantic-lex-comment-regex ";;"
;; Speedbar
diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el
index 892ae4e2e31..1312a55a898 100644
--- a/lisp/cedet/srecode/texi.el
+++ b/lisp/cedet/srecode/texi.el
@@ -1,4 +1,4 @@
-;;; srecode/texi.el --- Srecode texinfo support.
+;;; srecode/texi.el --- Srecode texinfo support. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -224,7 +224,7 @@ Takes a few very generic guesses as to what the formatting is."
;; Return our modified doc string.
docstring))
-(defun srecode-texi-massage-to-texinfo (tag buffer string)
+(defun srecode-texi-massage-to-texinfo (_tag buffer string)
"Massage TAG's documentation from BUFFER as STRING.
This is to take advantage of TeXinfo's markup symbols."
(save-excursion
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index bfc64da66f0..46a3f93d0af 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -324,6 +324,13 @@ from which to start."
(while (< i end)
(pcase (aref string i)
(?\s (setq spaces (1+ spaces)))
+ ((pred (lambda (c) (and char-fold-symmetric
+ (if isearch-regexp
+ isearch-regexp-lax-whitespace
+ isearch-lax-whitespace)
+ (stringp search-whitespace-regexp)
+ (string-match-p search-whitespace-regexp (char-to-string c)))))
+ (setq spaces (1+ spaces)))
(c (when (> spaces 0)
(push (char-fold--make-space-string spaces) out)
(setq spaces 0))
@@ -370,11 +377,7 @@ from which to start."
(setq i (1+ i)))
(when (> spaces 0)
(push (char-fold--make-space-string spaces) out))
- (let ((regexp (apply #'concat (nreverse out))))
- ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'.
- (if (> (length regexp) 5000)
- (regexp-quote string)
- regexp))))
+ (apply #'concat (nreverse out))))
;;; Commands provided for completeness.
diff --git a/lisp/chistory.el b/lisp/chistory.el
index 82c016f3474..95c1b49cd8b 100644
--- a/lisp/chistory.el
+++ b/lisp/chistory.el
@@ -1,4 +1,4 @@
-;;; chistory.el --- list command history
+;;; chistory.el --- list command history -*- lexical-binding: t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -71,8 +71,7 @@ If that function is given a list whose car is an element of this list,
then it will return non-nil (indicating the list should be discarded from
the history).
Initially, all commands related to the command history are discarded."
- :type '(repeat symbol)
- :group 'chistory)
+ :type '(repeat symbol))
(defvar list-command-history-filter 'default-command-history-filter
"Predicate to test which commands should be excluded from the history listing.
@@ -90,8 +89,7 @@ from the command history."
(defcustom list-command-history-max 32
"If non-nil, maximum length of the listing produced by `list-command-history'."
- :type '(choice integer (const nil))
- :group 'chistory)
+ :type '(choice integer (const nil)))
;;;###autoload
(defun list-command-history ()
@@ -127,10 +125,10 @@ The buffer is left in Command History mode."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (make-composed-keymap lisp-mode-shared-map
special-mode-map))
- (define-key map "x" 'command-history-repeat)
- (define-key map "\n" 'next-line)
- (define-key map "\r" 'next-line)
- (define-key map "\177" 'previous-line)
+ (define-key map "x" #'command-history-repeat)
+ (define-key map "\n" #'next-line)
+ (define-key map "\r" #'next-line)
+ (define-key map "\177" #'previous-line)
map)
"Keymap for `command-history-mode'.")
@@ -140,13 +138,12 @@ The buffer is left in Command History mode."
Keybindings:
\\{command-history-mode-map}"
(lisp-mode-variables nil)
- (set (make-local-variable 'revert-buffer-function) 'command-history-revert)
+ (setq-local revert-buffer-function 'command-history-revert)
(set-syntax-table emacs-lisp-mode-syntax-table))
(defcustom command-history-hook nil
"If non-nil, its value is called on entry to `command-history-mode'."
- :type 'hook
- :group 'chistory)
+ :type 'hook)
(defun command-history-revert (_ignore-auto _noconfirm)
(list-command-history))
@@ -165,7 +162,7 @@ The buffer for that command is the previous current buffer."
;;;###autoload
(defun command-history ()
- "Examine commands from `command-history' in a buffer.
+ "Examine commands from variable `command-history' in a buffer.
The number of commands listed is controlled by `list-command-history-max'.
The command history is filtered by `list-command-history-filter' if non-nil.
Use \\<command-history-map>\\[command-history-repeat] to repeat the command on the current line.
diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el
index eb6ed59ad5c..18087da9ac9 100644
--- a/lisp/cmuscheme.el
+++ b/lisp/cmuscheme.el
@@ -1,7 +1,6 @@
-;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el
+;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el -*- lexical-binding: t -*-
-;; Copyright (C) 1988, 1994, 1997, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1988-2021 Free Software Foundation, Inc.
;; Author: Olin Shivers <olin.shivers@cs.cmu.edu>
;; Maintainer: emacs-devel@gnu.org
@@ -26,20 +25,18 @@
;; This is a customization of comint-mode (see comint.el)
;;
-;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
+;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al..
;; 8/88
;;
;; Please send me bug reports, bug fixes, and extensions, so that I can
;; merge them into the master source.
;;
-;; The changelog is at the end of this file.
-;;
;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user
;; interface that communicates process state back to the superior emacs by
-;; outputting special control sequences. The Emacs package, xscheme.el, has
+;; outputting special control sequences. The Emacs package, xscheme.el, has
;; lots and lots of special purpose code to read these control sequences, and
-;; so is very tightly integrated with the cscheme process. The cscheme
+;; so is very tightly integrated with the cscheme process. The cscheme
;; interrupt handler and debugger read single character commands in cbreak
;; mode; when this happens, xscheme.el switches to special keymaps that bind
;; the single letter command keys to emacs functions that directly send the
@@ -49,18 +46,18 @@
;;
;; Here's a summary of the pros and cons, as I see them.
;; xscheme: Tightly integrated with inferior cscheme process! A few commands
-;; not in cmuscheme. But. Integration is a bit of a hack. Input
-;; history only keeps the immediately prior input. Bizarre
+;; not in cmuscheme. But. Integration is a bit of a hack. Input
+;; history only keeps the immediately prior input. Bizarre
;; keybindings.
;;
;; cmuscheme: Not tightly integrated with inferior cscheme process. But.
;; Carefully integrated functionality with the entire suite of
-;; comint-derived CMU process modes. Keybindings reminiscent of
-;; Zwei and Hemlock. Good input history. A few commands not in
+;; comint-derived CMU process modes. Keybindings reminiscent of
+;; Zwei and Hemlock. Good input history. A few commands not in
;; xscheme.
;;
-;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
-;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
+;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
+;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
;; Cscheme-specific; you must use cmuscheme.el. Interested parties are
;; invited to port xscheme functionality on top of comint mode...
@@ -70,18 +67,18 @@
;; Created.
;;
;; 2/15/89 Olin
-;; Removed -emacs flag from process invocation. It's only useful for
+;; Removed -emacs flag from process invocation. It's only useful for
;; cscheme, and makes cscheme assume it's running under xscheme.el,
-;; which messes things up royally. A bug.
+;; which messes things up royally. A bug.
;;
;; 5/22/90 Olin
;; - Upgraded to use comint-send-string and comint-send-region.
;; - run-scheme now offers to let you edit the command line if
-;; you invoke it with a prefix-arg. M-x scheme is redundant, and
+;; you invoke it with a prefix-arg. M-x scheme is redundant, and
;; has been removed.
;; - Explicit references to process "scheme" have been replaced with
-;; (scheme-proc). This allows better handling of multiple process bufs.
-;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
+;; (scheme-proc). This allows better handling of multiple process bufs.
+;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist
;; and friends, but interested hackers might find a useful application
;; of this facility.
@@ -95,42 +92,37 @@
(require 'scheme)
(require 'comint)
-
(defgroup cmuscheme nil
"Run a scheme process in a buffer."
:group 'scheme)
-;;; INFERIOR SCHEME MODE STUFF
-;;;============================================================================
-
(defcustom inferior-scheme-mode-hook nil
"Hook for customizing inferior-scheme mode."
- :type 'hook
- :group 'cmuscheme)
+ :type 'hook)
(defvar inferior-scheme-mode-map
(let ((m (make-sparse-keymap)))
- (define-key m "\M-\C-x" 'scheme-send-definition) ;gnu convention
- (define-key m "\C-x\C-e" 'scheme-send-last-sexp)
- (define-key m "\C-c\C-l" 'scheme-load-file)
- (define-key m "\C-c\C-k" 'scheme-compile-file)
+ (define-key m "\M-\C-x" #'scheme-send-definition) ;gnu convention
+ (define-key m "\C-x\C-e" #'scheme-send-last-sexp)
+ (define-key m "\C-c\C-l" #'scheme-load-file)
+ (define-key m "\C-c\C-k" #'scheme-compile-file)
(scheme-mode-commands m)
m))
;; Install the process communication commands in the scheme-mode keymap.
-(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention
-(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention
-(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition)
-(define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go)
-(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region)
-(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go)
-(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition)
-(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go)
-(define-key scheme-mode-map "\C-c\C-t" 'scheme-trace-procedure)
-(define-key scheme-mode-map "\C-c\C-x" 'scheme-expand-current-form)
-(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme)
-(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file)
-(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile"
+(define-key scheme-mode-map "\M-\C-x" #'scheme-send-definition);gnu convention
+(define-key scheme-mode-map "\C-x\C-e" #'scheme-send-last-sexp);gnu convention
+(define-key scheme-mode-map "\C-c\C-e" #'scheme-send-definition)
+(define-key scheme-mode-map "\C-c\M-e" #'scheme-send-definition-and-go)
+(define-key scheme-mode-map "\C-c\C-r" #'scheme-send-region)
+(define-key scheme-mode-map "\C-c\M-r" #'scheme-send-region-and-go)
+(define-key scheme-mode-map "\C-c\M-c" #'scheme-compile-definition)
+(define-key scheme-mode-map "\C-c\C-c" #'scheme-compile-definition-and-go)
+(define-key scheme-mode-map "\C-c\C-t" #'scheme-trace-procedure)
+(define-key scheme-mode-map "\C-c\C-x" #'scheme-expand-current-form)
+(define-key scheme-mode-map "\C-c\C-z" #'switch-to-scheme)
+(define-key scheme-mode-map "\C-c\C-l" #'scheme-load-file)
+(define-key scheme-mode-map "\C-c\C-k" #'scheme-compile-file) ;k for "kompile"
(let ((map (lookup-key scheme-mode-map [menu-bar scheme])))
(define-key map [separator-eval] '("--"))
@@ -157,8 +149,7 @@
(define-key map [send-region]
'("Evaluate Region" . scheme-send-region))
(define-key map [send-sexp]
- '("Evaluate Last S-expression" . scheme-send-last-sexp))
- )
+ '("Evaluate Last S-expression" . scheme-send-last-sexp)))
(defvar scheme-buffer)
@@ -209,8 +200,7 @@ to continue it."
(defcustom inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
"Input matching this regexp are not saved on the history list.
Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters."
- :type 'regexp
- :group 'cmuscheme)
+ :type 'regexp)
(defun scheme-input-filter (str)
"Don't save anything matching `inferior-scheme-filter-regexp'."
@@ -242,7 +232,7 @@ is run).
scheme-program-name)))
(if (not (comint-check-proc "*scheme*"))
(let ((cmdlist (split-string-and-unquote cmd)))
- (set-buffer (apply 'make-comint "scheme" (car cmdlist)
+ (set-buffer (apply #'make-comint "scheme" (car cmdlist)
(scheme-start-file (car cmdlist)) (cdr cmdlist)))
(inferior-scheme-mode)))
(setq scheme-program-name cmd)
@@ -282,8 +272,7 @@ in this order. Return nil if no start file found."
(defcustom scheme-compile-exp-command "(compile '%s)"
"Template for issuing commands to compile arbitrary Scheme expressions."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-compile-region (start end)
"Compile the current region in the inferior Scheme process.
@@ -311,15 +300,12 @@ For PLT-Scheme, e.g., one should use
(setq scheme-trace-command \"(begin (require (lib \\\"trace.ss\\\")) (trace %s))\")
For Scheme 48 and Scsh use \",trace %s\"."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defcustom scheme-untrace-command "(untrace %s)"
"Template for switching off tracing of a Scheme procedure.
Scheme 48 and Scsh users should set this variable to \",untrace %s\"."
-
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-trace-procedure (proc &optional untrace)
"Trace procedure PROC in the inferior Scheme process.
@@ -327,9 +313,8 @@ With a prefix argument switch off tracing of procedure PROC."
(interactive
(list (let ((current (symbol-at-point))
(action (if current-prefix-arg "Untrace" "Trace")))
- (if current
- (read-string (format "%s procedure [%s]: " action current) nil nil (symbol-name current))
- (read-string (format "%s procedure: " action))))
+ (read-string (format-prompt "%s procedure" current action)
+ nil nil (and current (symbol-name current))))
current-prefix-arg))
(when (= (length proc) 0)
(error "Invalid procedure name"))
@@ -342,8 +327,7 @@ With a prefix argument switch off tracing of procedure PROC."
(defcustom scheme-macro-expand-command "(expand %s)"
"Template for macro-expanding a Scheme form.
For Scheme 48 and Scsh use \",expand %s\"."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-expand-current-form ()
"Macro-expand the form at point in the inferior Scheme process."
@@ -411,8 +395,7 @@ Then switch to the process buffer."
If it's loaded into a buffer that is in one of these major modes, it's
considered a scheme source file by `scheme-load-file' and `scheme-compile-file'.
Used by these commands to determine defaults."
- :type '(repeat function)
- :group 'cmuscheme)
+ :type '(repeat function))
(defvar scheme-prev-l/c-dir/file nil
"Caches the last (directory . file) pair.
@@ -422,7 +405,7 @@ in the next one.")
(defun scheme-load-file (file-name)
"Load a Scheme file FILE-NAME into the inferior Scheme process."
- (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file
+ (interactive (comint-get-source "Load Scheme file" scheme-prev-l/c-dir/file
scheme-source-modes t)) ; t because `load'
; needs an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
@@ -434,7 +417,7 @@ in the next one.")
(defun scheme-compile-file (file-name)
"Compile a Scheme file FILE-NAME in the inferior Scheme process."
- (interactive (comint-get-source "Compile Scheme file: "
+ (interactive (comint-get-source "Compile Scheme file"
scheme-prev-l/c-dir/file
scheme-source-modes
nil)) ; nil because COMPILE doesn't
@@ -515,8 +498,9 @@ command to run."
(defcustom cmuscheme-load-hook nil
"This hook is run when cmuscheme is loaded in.
This is a good place to put keybindings."
- :type 'hook
- :group 'cmuscheme)
+ :type 'hook)
+(make-obsolete-variable 'cmuscheme-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'cmuscheme-load-hook)
diff --git a/lisp/color.el b/lisp/color.el
index 258acbe4053..fec36eecc33 100644
--- a/lisp/color.el
+++ b/lisp/color.el
@@ -33,11 +33,6 @@
;;; Code:
-;; 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.
diff --git a/lisp/comint.el b/lisp/comint.el
index 24ef0f239b2..40f58f2da7b 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -54,7 +54,7 @@
;; instead of shell-mode, see the notes at the end of this file.
-;; Brief Command Documentation:
+;;; Brief Command Documentation:
;;============================================================================
;; Comint Mode Commands: (common to all derived modes, like shell & cmulisp
;; mode)
@@ -104,8 +104,9 @@
(require 'ring)
(require 'ansi-color)
(require 'regexp-opt) ;For regexp-opt-charset.
+(eval-when-compile (require 'subr-x))
-;; Buffer Local Variables:
+;;; Buffer Local Variables:
;;============================================================================
;; Comint mode buffer local variables:
;; comint-prompt-regexp string comint-bol uses to match prompt
@@ -149,10 +150,10 @@
:group 'comint)
;; Unused.
-;;; (defgroup comint-source nil
-;;; "Source finding facilities in comint."
-;;; :prefix "comint-"
-;;; :group 'comint)
+;; (defgroup comint-source nil
+;; "Source finding facilities in comint."
+;; :prefix "comint-"
+;; :group 'comint)
(defvar comint-prompt-regexp "^"
"Regexp to recognize prompts in the inferior process.
@@ -223,6 +224,13 @@ This variable is buffer-local."
(other :tag "on" t))
:group 'comint)
+(defcustom comint-highlight-input t
+ "If non-nil, highlight input with `comint-highlight-input' face.
+Otherwise keep the original highlighting untouched."
+ :version "28.1"
+ :type 'boolean
+ :group 'comint)
+
(defface comint-highlight-input '((t (:weight bold)))
"Face to use to highlight user input."
:group 'comint)
@@ -249,6 +257,10 @@ to set this in a mode hook, rather than customize the default value."
file)
:group 'comint)
+(defvar comint-input-ring-file-prefix nil
+ "The prefix to skip when parsing the input ring file.
+This is useful in Zsh when the extended_history option is on.")
+
(defcustom comint-scroll-to-bottom-on-input nil
"Controls whether input to interpreter causes window to scroll.
If nil, then do not scroll. If t or `all', scroll all windows showing buffer.
@@ -351,15 +363,18 @@ This variable is buffer-local."
;; Some implementations of passwd use "Password (again)" as the 2nd prompt.
;; Something called "perforce" uses "Enter password:".
;; OpenVPN prints a prompt like: "Enter Auth Password:".
+;; OpenBSD doas prints "doas (user@host) password:".
;; See ert test `comint-test-password-regexp'.
(defcustom comint-password-prompt-regexp
+ ;; When extending this, please also add a corresponding test where
+ ;; possible (see `comint-testsuite-password-strings').
(concat
"\\(^ *\\|"
(regexp-opt
'("Enter" "enter" "Enter same" "enter same" "Enter the" "enter the"
"Enter Auth" "enter auth" "Old" "old" "New" "new" "'s" "login"
"Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" "SUDO"
- "[sudo]" "Repeat" "Bad" "Retype")
+ "[sudo]" "doas" "Repeat" "Bad" "Retype" "Verify")
t)
;; Allow for user name to precede password equivalent (Bug#31075).
" +.*\\)"
@@ -369,7 +384,7 @@ This variable is buffer-local."
"\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:space:]]*\\'")
"Regexp matching prompts for passwords in the inferior process.
This is used by `comint-watch-for-password-prompt'."
- :version "27.1"
+ :version "28.1"
:type 'regexp
:group 'comint)
@@ -599,6 +614,7 @@ The command \\[comint-accumulate] sets this.")
(put 'comint-replace-by-expanded-history 'menu-enable 'comint-input-autoexpand)
(put 'comint-input-ring 'permanent-local t)
+(put 'comint-input-ring-file-name 'permanent-local t)
(put 'comint-input-ring-index 'permanent-local t)
(put 'comint-save-input-ring-index 'permanent-local t)
(put 'comint-input-autoexpand 'permanent-local t)
@@ -687,8 +703,7 @@ Entry to this mode runs the hooks on `comint-mode-hook'."
;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00827.html
;;
;; This makes it really work to keep point at the bottom.
- ;; (make-local-variable 'scroll-conservatively)
- ;; (setq scroll-conservatively 10000)
+ ;; (setq-local scroll-conservatively 10000)
(add-hook 'pre-command-hook 'comint-preinput-scroll-to-bottom t t)
(make-local-variable 'comint-ptyp)
(make-local-variable 'comint-process-echoes)
@@ -731,7 +746,7 @@ contents are sent to the process as its initial input.
If PROGRAM is a string, any more args are arguments to PROGRAM.
Return the (possibly newly created) process buffer."
- (or (fboundp 'start-file-process)
+ (or (fboundp 'make-process)
(error "Multi-processing is not supported for this system"))
(setq buffer (get-buffer-create (or buffer (concat "*" name "*"))))
;; If no process, or nuked process, crank up a new one and put buffer in
@@ -809,18 +824,10 @@ series of processes in the same Comint buffer. The hook
(goto-char (point-max))
(set-marker (process-mark proc) (point))
;; Feed it the startfile.
- (cond (startfile
- ;;This is guaranteed to wait long enough
- ;;but has bad results if the comint does not prompt at all
- ;; (while (= size (buffer-size))
- ;; (sleep-for 1))
- ;;I hope 1 second is enough!
- (sleep-for 1)
- (goto-char (point-max))
- (insert-file-contents startfile)
- (setq startfile (buffer-substring (point) (point-max)))
- (delete-region (point) (point-max))
- (comint-send-string proc startfile)))
+ (when startfile
+ (comint-send-string proc (with-temp-buffer
+ (insert-file-contents startfile)
+ (buffer-string))))
(run-hooks 'comint-exec-hook)
buffer)))
@@ -917,8 +924,8 @@ by the global keymap (usually `mouse-yank-at-click')."
;; Insert the input at point
(insert input)))))
-;; Input history processing in a buffer
-;; ===========================================================================
+;;; Input history processing in a buffer
+;;============================================================================
;; Useful input history functions, courtesy of the Ergo group.
;; Eleven commands:
@@ -974,6 +981,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'."
(ring (make-ring ring-size))
;; Use possibly buffer-local values of these variables.
(ring-separator comint-input-ring-separator)
+ (ring-file-prefix comint-input-ring-file-prefix)
(history-ignore comint-input-history-ignore)
(ignoredups comint-input-ignoredups))
(with-temp-buffer
@@ -985,12 +993,15 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'."
(while (and (< count comint-input-ring-size)
(re-search-backward ring-separator nil t)
(setq end (match-beginning 0)))
- (setq start
- (if (re-search-backward ring-separator nil t)
- (match-end 0)
- (point-min)))
+ (goto-char (if (re-search-backward ring-separator nil t)
+ (match-end 0)
+ (point-min)))
+ (when (and ring-file-prefix
+ (looking-at ring-file-prefix))
+ ;; Skip zsh extended_history stamps
+ (goto-char (match-end 0)))
+ (setq start (point))
(setq history (buffer-substring start end))
- (goto-char start)
(when (and (not (string-match history-ignore history))
(or (null ignoredups)
(ring-empty-p ring)
@@ -1207,7 +1218,7 @@ Moves relative to START, or `comint-input-ring-index'."
(process-mark (get-buffer-process (current-buffer))))
(point-max)))
-(defun comint-previous-matching-input (regexp n)
+(defun comint-previous-matching-input (regexp n &optional restore)
"Search backwards through input history for match for REGEXP.
\(Previous history elements are earlier commands.)
With prefix argument N, search for Nth previous match.
@@ -1218,16 +1229,24 @@ If N is negative, find the next or Nth next match."
;; Has a match been found?
(if (null pos)
(user-error "Not found")
- ;; If leaving the edit line, save partial input
- (if (null comint-input-ring-index) ;not yet on ring
- (setq comint-stored-incomplete-input
- (funcall comint-get-old-input)))
- (setq comint-input-ring-index pos)
- (unless isearch-mode
- (let ((message-log-max nil)) ; Do not write to *Messages*.
- (message "History item: %d" (1+ pos))))
- (comint-delete-input)
- (insert (ring-ref comint-input-ring pos)))))
+ (if (and comint-input-ring-index
+ restore
+ (or (and (< n 0)
+ (< comint-input-ring-index pos))
+ (and (> n 0)
+ (> comint-input-ring-index pos))))
+ ;; We have a wrap; restore contents.
+ (comint-restore-input)
+ ;; If leaving the edit line, save partial input
+ (if (null comint-input-ring-index) ;not yet on ring
+ (setq comint-stored-incomplete-input
+ (funcall comint-get-old-input)))
+ (setq comint-input-ring-index pos)
+ (unless isearch-mode
+ (let ((message-log-max nil)) ; Do not write to *Messages*.
+ (message "History item: %d" (1+ pos))))
+ (comint-delete-input)
+ (insert (ring-ref comint-input-ring pos))))))
(defun comint-next-matching-input (regexp n)
"Search forwards through input history for match for REGEXP.
@@ -1255,7 +1274,7 @@ If N is negative, search forwards for the -Nth following match."
comint-input-ring-index nil))
(comint-previous-matching-input
(concat "^" (regexp-quote comint-matching-input-from-input-string))
- n)
+ n t)
(when (eq comint-move-point-for-matching-input 'after-input)
(goto-char opoint))))
@@ -1608,7 +1627,6 @@ or to the last history element for a backward search."
(if isearch-forward
(comint-goto-input (1- (ring-length comint-input-ring)))
(comint-goto-input nil))
- (setq isearch-success t)
(goto-char (if isearch-forward (comint-line-beginning-position) (point-max))))
(defun comint-history-isearch-push-state ()
@@ -1758,7 +1776,7 @@ Argument 0 is the command name."
((>= mth 0) (1- (- count mth)))
(t (1- (- mth))))))
(mapconcat
- (function (lambda (a) a)) (nthcdr n (nreverse (nthcdr m args))) " "))))
+ (lambda (a) a) (nthcdr n (nreverse (nthcdr m args))) " "))))
;;
;; Input processing stuff
@@ -1779,6 +1797,10 @@ Ignore duplicates if `comint-input-ignoredups' is non-nil."
(min size (- comint-input-ring-size size)))))
(ring-insert comint-input-ring cmd)))
+(defconst comint--prompt-rear-nonsticky
+ '(field inhibit-line-move-field-capture read-only font-lock-face)
+ "Text properties we set on the prompt and don't want to leak past it.")
+
(defun comint-send-input (&optional no-newline artificial)
"Send input to process.
After the process output mark, sends all text from the process mark to
@@ -1881,9 +1903,10 @@ Similarly for Soar, Scheme, etc."
(end (if no-newline (point) (1- (point)))))
(with-silent-modifications
(when (> end beg)
- (add-text-properties beg end
- '(front-sticky t
- font-lock-face comint-highlight-input))
+ (when comint-highlight-input
+ (add-text-properties beg end
+ '( font-lock-face comint-highlight-input
+ front-sticky t )))
(unless comint-use-prompt-regexp
;; Give old user input a field property of `input', to
;; distinguish it from both process output and unsent
@@ -1897,7 +1920,8 @@ Similarly for Soar, Scheme, etc."
(unless (or no-newline comint-use-prompt-regexp)
;; Cover the terminating newline
(add-text-properties end (1+ end)
- '(rear-nonsticky t
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky
field boundary
inhibit-line-move-field-capture t)))))
@@ -2104,9 +2128,10 @@ Make backspaces delete the previous character."
(unless comint-use-prompt-regexp
(with-silent-modifications
(add-text-properties comint-last-output-start (point)
- '(front-sticky
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky
+ front-sticky
(field inhibit-line-move-field-capture)
- rear-nonsticky t
field output
inhibit-line-move-field-capture t))))
@@ -2132,10 +2157,12 @@ Make backspaces delete the previous character."
'comint-highlight-prompt))
(setq comint-last-prompt
(cons (copy-marker prompt-start) (point-marker)))
- (font-lock-prepend-text-property prompt-start (point)
- 'font-lock-face
- 'comint-highlight-prompt)
- (add-text-properties prompt-start (point) '(rear-nonsticky t)))
+ (font-lock-append-text-property prompt-start (point)
+ 'font-lock-face
+ 'comint-highlight-prompt)
+ (add-text-properties prompt-start (point)
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky)))
(goto-char saved-point)))))))
(defun comint-preinput-scroll-to-bottom ()
@@ -2231,19 +2258,27 @@ 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 interactive)
"Strip trailing `^M' characters from the current output group.
This function could be on `comint-output-filter-functions' or bound to a key."
- (interactive)
- (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
- (save-excursion
- (condition-case nil
- (goto-char
- (if (called-interactively-p 'interactive)
- comint-last-input-end comint-last-output-start))
- (error nil))
- (while (re-search-forward "\r+$" pmark t)
- (replace-match "" t t)))))
+ (interactive (list nil t))
+ (let ((process (get-buffer-process (current-buffer))))
+ (if (not process)
+ ;; This function may be used in
+ ;; `comint-output-filter-functions', and in that case, if
+ ;; there's no process, then we should do nothing. If
+ ;; interactive, report an error.
+ (when interactive
+ (error "No process in the current buffer"))
+ (let ((pmark (process-mark process)))
+ (save-excursion
+ (condition-case nil
+ (goto-char
+ (if interactive
+ comint-last-input-end comint-last-output-start))
+ (error nil))
+ (while (re-search-forward "\r+$" pmark t)
+ (replace-match "" t t)))))))
(define-obsolete-function-alias 'shell-strip-ctrl-m #'comint-strip-ctrl-m "27.1")
(defun comint-show-maximum-output ()
@@ -2350,18 +2385,18 @@ a buffer local variable."
;; For compatibility.
(defun comint-read-noecho (prompt &optional _ignore)
+ (declare (obsolete read-passwd "28.1"))
(read-passwd prompt))
;; These three functions are for entering text you don't want echoed or
;; saved -- typically passwords to ftp, telnet, or somesuch.
;; Just enter m-x comint-send-invisible and type in your line.
-(defvar comint-password-function nil
+(defvar-local comint-password-function nil
"Abnormal hook run when prompted for a password.
This function gets one argument, a string containing the prompt.
It may return a string containing the password, or nil if normal
password prompting should occur.")
-(make-variable-buffer-local 'comint-password-function)
(defun comint-send-invisible (&optional prompt)
"Read a string without echoing.
@@ -2398,19 +2433,18 @@ Security bug: your string can still be temporarily recovered with
(defun comint-watch-for-password-prompt (string)
"Prompt in the minibuffer for password and send without echoing.
Looks for a match to `comint-password-prompt-regexp' in order
-to detect the need to (prompt and) send a password.
+to detect the need to (prompt and) send a password. Ignores any
+carriage returns (\\r) in STRING.
This function could be in the list `comint-output-filter-functions'."
(when (let ((case-fold-search t))
- (string-match comint-password-prompt-regexp string))
- (when (string-match "^[ \n\r\t\v\f\b\a]+" string)
- (setq string (replace-match "" t t string)))
- (when (string-match "\n+\\'" string)
- (setq string (replace-match "" t t string)))
+ (string-match comint-password-prompt-regexp
+ (replace-regexp-in-string "\r" "" string)))
(let ((comint--prompt-recursion-depth (1+ comint--prompt-recursion-depth)))
(if (> comint--prompt-recursion-depth 10)
(message "Password prompt recursion too deep")
- (comint-send-invisible string)))))
+ (comint-send-invisible
+ (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+"))))))
;; Low-level process communication
@@ -2437,10 +2471,13 @@ This function could be in the list `comint-output-filter-functions'."
;; Random input hackage
-(defun comint-delete-output ()
+(defun comint-delete-output (&optional kill)
"Delete all output from interpreter since last input.
-Does not delete the prompt."
- (interactive)
+If KILL (interactively, the prefix), save the killed text in the
+kill ring.
+
+This command does not delete the prompt."
+ (interactive "P")
(let ((proc (get-buffer-process (current-buffer)))
(replacement nil)
(inhibit-read-only t))
@@ -2448,6 +2485,8 @@ Does not delete the prompt."
(let ((pmark (progn (goto-char (process-mark proc))
(forward-line 0)
(point-marker))))
+ (when kill
+ (copy-region-as-kill comint-last-input-end pmark))
(delete-region comint-last-input-end pmark)
(goto-char (process-mark proc))
(setq replacement (concat "*** output flushed ***\n"
@@ -2813,7 +2852,7 @@ updated using `comint-update-fence', if necessary."
(kill-region beg end)
(comint-update-fence))))))
-;; Support for source-file processing commands.
+;;; Support for source-file processing commands.
;;============================================================================
;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
;; commands that process files of source text (e.g. loading or compiling
@@ -2919,7 +2958,7 @@ two arguments are used for determining defaults.) If MUSTMATCH-P is true,
then the filename reader will only accept a file that exists.
A typical use:
- (interactive (comint-get-source \"Compile file: \" prev-lisp-dir/file
+ (interactive (comint-get-source \"Compile file\" prev-lisp-dir/file
\\='(lisp-mode) t))"
(let* ((def (comint-source-default prev-dir/file source-modes))
(stringfile (comint-extract-string))
@@ -2932,9 +2971,7 @@ A typical use:
(car def)))
(deffile (if sfile-p (file-name-nondirectory stringfile)
(cdr def)))
- (ans (read-file-name (if deffile (format "%s(default %s) "
- prompt deffile)
- prompt)
+ (ans (read-file-name (format-prompt prompt deffile)
defdir
(concat defdir deffile)
mustmatch-p)))
@@ -2949,8 +2986,8 @@ A typical use:
;; -Olin
-;; Simple process query facility.
-;; ===========================================================================
+;;; Simple process query facility.
+;;============================================================================
;; This function is for commands that want to send a query to the process
;; and show the response to the user. For example, a command to get the
;; arglist for a Common Lisp function might send a "(arglist 'foo)" query
@@ -2986,8 +3023,8 @@ its response can be seen."
(set-window-point proc-win opoint)))))))
-;; Filename/command/history completion in a buffer
-;; ===========================================================================
+;;; Filename/command/history completion in a buffer
+;;============================================================================
;; Useful completion functions, courtesy of the Ergo group.
;; Six commands:
@@ -3126,7 +3163,7 @@ See `comint-word'."
"\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)"
"\\|{\\(?1:[^{}]+\\)}\\)"
(when (memq system-type '(ms-dos windows-nt))
- "\\|%\\(?1:[^\\\\/]*\\)%")
+ "\\|%\\(?1:[^\\/]*\\)%")
(when comint-file-name-quote-list
"\\|\\\\\\(.\\)")))
(qupos nil)
@@ -3427,7 +3464,7 @@ the completions."
(eq (window-buffer (posn-window (event-start first)))
(get-buffer "*Completions*"))
(memq (key-binding key)
- '(mouse-choose-completion choose-completion))))
+ '(choose-completion))))
;; If the user does choose-completion with the mouse,
;; execute the command, then delete the completion window.
(progn
@@ -3643,7 +3680,7 @@ and does not normally need to be invoked by the end user or programmer."
(setq-local comint-redirect-previous-input-string "")
(setq mode-line-process
- (if mode-line-process
+ (if (and mode-line-process (stringp (elt mode-line-process 0)))
(list (concat (elt mode-line-process 0) " Redirection"))
(list ":%s Redirection")))))
@@ -3844,11 +3881,15 @@ REGEXP-GROUP is the regular expression group in REGEXP to use."
(push (buffer-substring-no-properties
(match-beginning regexp-group)
(match-end regexp-group))
- results))
+ results)
+ (when (zerop (length (match-string 0)))
+ ;; If the regexp can be empty (for instance, "^.*$"), we
+ ;; don't advance, so ensure forward progress.
+ (forward-line 1)))
(nreverse results))))
-;; Converting process modes to use comint mode
-;; ===========================================================================
+;;; Converting process modes to use comint mode
+;;============================================================================
;; The code in the Emacs 19 distribution has all been modified to use comint
;; where needed. However, there are `third-party' packages out there that
;; still use the old shell mode. Here's a guide to conversion.
diff --git a/lisp/completion.el b/lisp/completion.el
index fcd3b02879b..93a869e86f4 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -1,7 +1,6 @@
-;;; completion.el --- dynamic word-completion code
+;;; completion.el --- dynamic word-completion code -*- lexical-binding: t; -*-
-;; Copyright (C) 1990, 1993, 1995, 1997, 2001-2021 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1990-2021 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: abbrev convenience
@@ -286,62 +285,52 @@
(defcustom enable-completion t
"Non-nil means enable recording and saving of completions.
If nil, no new words are added to the database or saved to the init file."
- :type 'boolean
- :group 'completion)
+ :type 'boolean)
(defcustom save-completions-flag t
"Non-nil means save most-used completions when exiting Emacs.
See also `save-completions-retention-time'."
- :type 'boolean
- :group 'completion)
+ :type 'boolean)
(defcustom save-completions-file-name
(locate-user-emacs-file "completions" ".completions")
"The filename to save completions to."
- :type 'file
- :group 'completion)
+ :type 'file)
(defcustom save-completions-retention-time 336
"Discard a completion if unused for this many hours.
\(1 day = 24, 1 week = 168). If this is 0, non-permanent completions
will not be saved unless these are used. Default is two weeks."
- :type 'integer
- :group 'completion)
+ :type 'integer)
(defcustom completion-on-separator-character nil
"Non-nil means separator characters mark previous word as used.
This means the word will be saved as a completion."
- :type 'boolean
- :group 'completion)
+ :type 'boolean)
(defcustom completions-file-versions-kept kept-new-versions
"Number of versions to keep for the saved completions file."
- :type 'integer
- :group 'completion)
+ :type 'integer)
(defcustom completion-prompt-speed-threshold 4800
"Minimum output speed at which to display next potential completion."
- :type 'integer
- :group 'completion)
+ :type 'integer)
(defcustom completion-cdabbrev-prompt-flag nil
"If non-nil, the next completion prompt does a cdabbrev search.
This can be time consuming."
- :type 'boolean
- :group 'completion)
+ :type 'boolean)
(defcustom completion-search-distance 15000
"How far to search in the buffer when looking for completions.
In number of characters. If nil, search the whole buffer."
- :type 'integer
- :group 'completion)
+ :type 'integer)
(defcustom completions-merging-modes '(lisp c)
"List of modes {`c' or `lisp'} for automatic completions merging.
Definitions from visited files which have these modes
are automatically added to the completion database."
- :type '(set (const lisp) (const c))
- :group 'completion)
+ :type '(set (const lisp) (const c)))
;;(defvar *completion-auto-save-period* 1800
;; "The period in seconds to wait for emacs to be idle before autosaving
@@ -399,13 +388,6 @@ Used to decide whether to save completions.")
:up)
(t :neither))))))
-;; Tests -
-;; (cmpl-string-case-type "123ABCDEF456") --> :up
-;; (cmpl-string-case-type "123abcdef456") --> :down
-;; (cmpl-string-case-type "123aBcDeF456") --> :mixed
-;; (cmpl-string-case-type "123456") --> :neither
-;; (cmpl-string-case-type "Abcde123") --> :capitalized
-
(defun cmpl-coerce-string-case (string case-type)
(cond ((eq case-type :down) (downcase string))
((eq case-type :up) (upcase string))
@@ -424,12 +406,6 @@ Used to decide whether to save completions.")
;; as is
string-to-coerce))))
-;; Tests -
-;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456
-;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456
-;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456
-;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456
-
(defun cmpl-hours-since-origin ()
(floor (time-convert nil 'integer) 3600))
@@ -518,9 +494,8 @@ Used to decide whether to save completions.")
;; Old name, non-namespace-clean.
(defvaralias 'cmpl-syntax-table 'completion-syntax-table)
-(defvar completion-syntax-table completion-standard-syntax-table
+(defvar-local completion-syntax-table completion-standard-syntax-table
"This variable holds the current completion syntax table.")
-(make-variable-buffer-local 'completion-syntax-table)
;;-----------------------------------------------
;; Symbol functions
@@ -964,9 +939,9 @@ Each symbol is bound to a single completion entry.")
;; READER Macros
-(defalias 'cmpl-prefix-entry-head 'car)
+(defalias 'cmpl-prefix-entry-head #'car)
-(defalias 'cmpl-prefix-entry-tail 'cdr)
+(defalias 'cmpl-prefix-entry-tail #'cdr)
;; WRITER Macros
@@ -992,31 +967,27 @@ Each symbol is bound to a single completion entry.")
(setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0))
(setq cmpl-obarray (make-vector cmpl-obarray-length 0)))
-(defvar completions-list-return-value)
-
(defun list-all-completions ()
"Return a list of all the known completion entries."
- (let ((completions-list-return-value nil))
- (mapatoms 'list-all-completions-1 cmpl-prefix-obarray)
- completions-list-return-value))
-
-(defun list-all-completions-1 (prefix-symbol)
- (if (boundp prefix-symbol)
- (setq completions-list-return-value
- (append (cmpl-prefix-entry-head (symbol-value prefix-symbol))
- completions-list-return-value))))
-
-(defun list-all-completions-by-hash-bucket ()
+ (let ((return-value nil))
+ (mapatoms (lambda (prefix-symbol)
+ (if (boundp prefix-symbol)
+ (setq return-value
+ (append (cmpl-prefix-entry-head
+ (symbol-value prefix-symbol))
+ return-value))))
+ cmpl-prefix-obarray)
+ return-value))
+
+(defun list-all-completions-by-hash-bucket () ;FIXME: Unused!
"Return list of lists of known completion entries, organized by hash bucket."
- (let ((completions-list-return-value nil))
- (mapatoms 'list-all-completions-by-hash-bucket-1 cmpl-prefix-obarray)
- completions-list-return-value))
-
-(defun list-all-completions-by-hash-bucket-1 (prefix-symbol)
- (if (boundp prefix-symbol)
- (setq completions-list-return-value
- (cons (cmpl-prefix-entry-head (symbol-value prefix-symbol))
- completions-list-return-value))))
+ (let ((return-value nil))
+ (mapatoms (lambda (prefix-symbol)
+ (if (boundp prefix-symbol)
+ (push (cmpl-prefix-entry-head (symbol-value prefix-symbol))
+ return-value)))
+ cmpl-prefix-obarray)
+ return-value))
;;-----------------------------------------------
@@ -1226,45 +1197,6 @@ String must be longer than `completion-prefix-min-length'."
(set cmpl-db-prefix-symbol nil)))))
(error "Unknown completion `%s'" completion-string))))
-;; Tests --
-;; - Add and Find -
-;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
-;; (find-exact-completion "banana") --> ("banana" 0 nil 0)
-;; (find-exact-completion "bana") --> nil
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;; (add-completion-to-head "banish") --> ("banish" 0 nil 0)
-;; (find-exact-completion "banish") --> ("banish" 0 nil 0)
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;;
-;; - Deleting -
-;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
-;; (delete-completion "banner")
-;; (find-exact-completion "banner") --> nil
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
-;; (delete-completion "banana")
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;; (delete-completion "banner")
-;; (delete-completion "banish")
-;; (find-cmpl-prefix-entry "ban") --> nil
-;; (delete-completion "banner") --> error
-;;
-;; - Tail -
-;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0)
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0)
-;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...))
-;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...))
-;;
-
;;---------------------------------------------------------------------------
;; Database Update :: Interface level routines
@@ -1276,11 +1208,7 @@ String must be longer than `completion-prefix-min-length'."
(defun interactive-completion-string-reader (prompt)
(let* ((default (symbol-under-or-before-point))
- (new-prompt
- (if default
- (format "%s (default %s): " prompt default)
- (format "%s: " prompt)))
- (read (completing-read new-prompt cmpl-obarray)))
+ (read (completing-read (format-prompt prompt default) cmpl-obarray)))
(if (zerop (length read)) (setq read (or default "")))
(list read)))
@@ -1365,29 +1293,6 @@ Completions added this way will automatically be saved if
(set-completion-num-uses entry 1)
(setq cmpl-completions-accepted-p t)))))))
-;; Tests --
-;; - Add and Find -
-;; (add-completion "banana" 5 10)
-;; (find-exact-completion "banana") --> ("banana" 5 10 0)
-;; (add-completion "banana" 6)
-;; (find-exact-completion "banana") --> ("banana" 6 10 0)
-;; (add-completion "banish")
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
-;;
-;; - Accepting -
-;; (setq completion-to-accept "banana")
-;; (accept-completion)
-;; (find-exact-completion "banana") --> ("banana" 7 10)
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;; (setq completion-to-accept "banish")
-;; (add-completion "banner")
-;; (car (find-cmpl-prefix-entry "ban"))
-;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...))
-;;
-;; - Deleting -
-;; (kill-completion "banish")
-;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...))
-
;;---------------------------------------------------------------------------
;; Searching the database
@@ -1509,46 +1414,6 @@ If there are no more entries, try cdabbrev and then return only a string."
;; Completely unsuccessful, return nil
))
-;; Tests --
-;; - Add and Find -
-;; (add-completion "banana")
-;; (completion-search-reset "ban")
-;; (completion-search-next 0) --> "banana"
-;;
-;; - Discrimination -
-;; (add-completion "cumberland")
-;; (add-completion "cumberbund")
-;; cumbering
-;; (completion-search-reset "cumb")
-;; (completion-search-peek t) --> "cumberbund"
-;; (completion-search-next 0) --> "cumberbund"
-;; (completion-search-peek t) --> "cumberland"
-;; (completion-search-next 1) --> "cumberland"
-;; (completion-search-peek nil) --> nil
-;; (completion-search-next 2) --> "cumbering" {cdabbrev}
-;; (completion-search-next 3) --> nil or "cumming"{depends on context}
-;; (completion-search-next 1) --> "cumberland"
-;; (completion-search-peek t) --> "cumbering" {cdabbrev}
-;;
-;; - Accepting -
-;; (completion-search-next 1) --> "cumberland"
-;; (setq completion-to-accept "cumberland")
-;; (completion-search-reset "foo")
-;; (completion-search-reset "cum")
-;; (completion-search-next 0) --> "cumberland"
-;;
-;; - Deleting -
-;; (kill-completion "cumberland")
-;; cummings
-;; (completion-search-reset "cum")
-;; (completion-search-next 0) --> "cumberbund"
-;; (completion-search-next 1) --> "cummings"
-;;
-;; - Ignoring Capitalization -
-;; (completion-search-reset "CuMb")
-;; (completion-search-next 0) --> "cumberbund"
-
-
;;-----------------------------------------------
;; COMPLETE
@@ -1737,12 +1602,6 @@ Prefix args ::
"\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
"A regexp that searches for Lisp definition form.")
-;; Tests -
-;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8
-;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9
-;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10
-;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9
-
;; Parses all the definition names from a Lisp mode buffer and adds them to
;; the completion database.
(defun add-completions-from-lisp-buffer ()
@@ -2058,68 +1917,64 @@ If file is not specified, then use `save-completions-file-name'."
(clear-visited-file-modtime)
(erase-buffer)
- (let ((insert-okay-p nil)
- (buffer (current-buffer))
+ (let ((buffer (current-buffer))
string entry last-use-time
cmpl-entry cmpl-last-use-time
(current-completion-source cmpl-source-init-file)
(total-in-file 0) (total-perm 0))
;; insert the file into a buffer
(condition-case nil
- (progn (insert-file-contents filename t)
- (setq insert-okay-p t))
-
+ (insert-file-contents filename t)
(file-error
(message "File error trying to load completion file %s."
- filename)))
- ;; parse it
- (if insert-okay-p
- (progn
- (goto-char (point-min))
-
- (condition-case nil
- (while t
- (setq entry (read buffer))
- (setq total-in-file (1+ total-in-file))
- (cond
- ((and (consp entry)
- (stringp (setq string (car entry)))
- (cond
- ((eq (setq last-use-time (cdr entry)) 'T)
- ;; handle case sensitivity
- (setq total-perm (1+ total-perm))
- (setq last-use-time t))
- ((eq last-use-time t)
- (setq total-perm (1+ total-perm)))
- ((integerp last-use-time))))
- ;; Valid entry
- ;; add it in
- (setq cmpl-last-use-time
- (completion-last-use-time
- (setq cmpl-entry
- (add-completion-to-tail-if-new string))))
- (if (or (eq last-use-time t)
- (and (> last-use-time 1000);;backcompatibility
- (not (eq cmpl-last-use-time t))
- (or (not cmpl-last-use-time)
- ;; more recent
- (> last-use-time cmpl-last-use-time))))
- ;; update last-use-time
- (set-completion-last-use-time cmpl-entry last-use-time)))
- (t
- ;; Bad format
- (message "Error: invalid saved completion - %s"
- (prin1-to-string entry))
- ;; try to get back in sync
- (search-forward "\n("))))
- (search-failed
- (message "End of file while reading completions."))
- (end-of-file
- (if (= (point) (point-max))
- (if (not no-message-p)
- (message "Loading completions from file %s . . . Done."
- filename))
- (message "End of file while reading completions."))))))
+ filename))
+ (:success
+ ;; parse it
+ (goto-char (point-min))
+
+ (condition-case nil
+ (while t
+ (setq entry (read buffer))
+ (setq total-in-file (1+ total-in-file))
+ (cond
+ ((and (consp entry)
+ (stringp (setq string (car entry)))
+ (cond
+ ((eq (setq last-use-time (cdr entry)) 'T)
+ ;; handle case sensitivity
+ (setq total-perm (1+ total-perm))
+ (setq last-use-time t))
+ ((eq last-use-time t)
+ (setq total-perm (1+ total-perm)))
+ ((integerp last-use-time))))
+ ;; Valid entry
+ ;; add it in
+ (setq cmpl-last-use-time
+ (completion-last-use-time
+ (setq cmpl-entry
+ (add-completion-to-tail-if-new string))))
+ (if (or (eq last-use-time t)
+ (and (> last-use-time 1000);;backcompatibility
+ (not (eq cmpl-last-use-time t))
+ (or (not cmpl-last-use-time)
+ ;; more recent
+ (> last-use-time cmpl-last-use-time))))
+ ;; update last-use-time
+ (set-completion-last-use-time cmpl-entry last-use-time)))
+ (t
+ ;; Bad format
+ (message "Error: invalid saved completion - %s"
+ (prin1-to-string entry))
+ ;; try to get back in sync
+ (search-forward "\n("))))
+ (search-failed
+ (message "End of file while reading completions."))
+ (end-of-file
+ (if (= (point) (point-max))
+ (if (not no-message-p)
+ (message "Loading completions from file %s . . . Done."
+ filename))
+ (message "End of file while reading completions."))))))
))))))
(defun completion-initialize ()
@@ -2166,7 +2021,7 @@ Patched to remove the most recent completion."
;; All common separators (eg. space "(" ")" """) characters go through a
;; function to add new words to the list of words to complete from.
-;; If the character before this was an alpha-numeric then this adds the
+;; If the character before this was an alphanumeric then this adds the
;; symbol before point to the completion list (using ADD-COMPLETION).
(defvar completion-separator-chars
@@ -2281,7 +2136,6 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
(define-minor-mode dynamic-completion-mode
"Toggle dynamic word-completion on or off."
:global t
- :group 'completion
;; This is always good, not specific to dynamic-completion-mode.
(define-key function-key-map [C-return] [?\C-\r])
@@ -2365,7 +2219,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under."
(completion-def-wrapper 'delete-backward-char-untabify :backward)
;; Old name, non-namespace-clean.
-(defalias 'initialize-completions 'completion-initialize)
+(defalias 'initialize-completions #'completion-initialize)
(provide 'completion)
diff --git a/lisp/composite.el b/lisp/composite.el
index b77d8b1fd6a..6f654df15aa 100644
--- a/lisp/composite.el
+++ b/lisp/composite.el
@@ -1,4 +1,4 @@
-;;; composite.el --- support character composition
+;;; composite.el --- support character composition -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -593,7 +593,6 @@ All non-spacing characters have this function in
(as (lglyph-ascent glyph))
(de (lglyph-descent glyph))
(ce (/ (+ lb rb) 2))
- (w (lglyph-width glyph))
xoff yoff)
(cond
((and class (>= class 200) (<= class 240))
@@ -653,14 +652,15 @@ All non-spacing characters have this function in
((and (= class 0)
(eq (get-char-code-property (lglyph-char glyph)
;; Me = enclosing mark
- 'general-category) 'Me))
+ 'general-category)
+ 'Me))
;; Artificially laying out glyphs in an enclosing
;; mark is difficult. All we can do is to adjust
;; the x-offset and width of the base glyph to
;; align it at the center of the glyph of the
;; enclosing mark hoping that the enclosing mark
;; is big enough. We also have to adjust the
- ;; x-offset and width of the mark ifself properly
+ ;; x-offset and width of the mark itself properly
;; depending on how the glyph is designed.
;; (non-spacing or not). For instance, when we
@@ -695,9 +695,7 @@ All non-spacing characters have this function in
(defun compose-gstring-for-dotted-circle (gstring direction)
(let* ((dc (lgstring-glyph gstring 0)) ; glyph of dotted-circle
- (dc-id (lglyph-code dc))
(fc (lgstring-glyph gstring 1)) ; glyph of the following char
- (fc-id (lglyph-code fc))
(gstr (and nil (font-shape-gstring gstring direction))))
(if (and gstr
(or (= (lgstring-glyph-len gstr) 1)
@@ -747,7 +745,18 @@ All non-spacing characters have this function in
unicode-category-table))
;; for dotted-circle
(aset composition-function-table #x25CC
- `([,(purecopy ".\\c^") 0 compose-gstring-for-dotted-circle])))
+ `([,(purecopy ".\\c^") 0 compose-gstring-for-dotted-circle]))
+ ;; For prettier display of fractions
+ (set-char-table-range
+ composition-function-table
+ #x2044
+ ;; We use font-shape-gstring so that if the font doesn't support
+ ;; fractional display, the characters are shown separately, not as
+ ;; a composed cluster.
+ (list (vector (purecopy "[1-9][0-9][0-9]\u2044[0-9]+")
+ 3 'font-shape-gstring)
+ (vector (purecopy "[1-9][0-9]\u2044[0-9]+") 2 'font-shape-gstring)
+ (vector (purecopy "[1-9]\u2044[0-9]+") 1 'font-shape-gstring))))
(defun compose-gstring-for-terminal (gstring _direction)
"Compose glyph-string GSTRING for terminal display.
diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el
index 8dd2fe01f84..31a896088a5 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -1,4 +1,4 @@
-;;; cus-dep.el --- find customization dependencies
+;;; cus-dep.el --- find customization dependencies -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;;
@@ -51,6 +51,25 @@ ldefs-boot\\|cus-load\\|finder-inf\\|esh-groups\\|subdirs\\)\\.el$\\)"
(defalias sym e))))
'(defcustom defface defgroup)))
+(defun custom--get-def (expr)
+ (if (not (memq (car-safe expr)
+ '( define-minor-mode define-globalized-minor-mode)))
+ expr
+ ;; For define-minor-mode, we don't want to evaluate the whole
+ ;; expression, because it tends to define functions which aren't
+ ;; usable (because they call other functions that were skipped).
+ ;; Concretely it gave us an error
+ ;; "void-function bug-reference--run-auto-setup"
+ ;; when subsequently loading `cus-load.el'.
+ (let ((es (list (macroexpand-all expr)))
+ defs)
+ (while es
+ (let ((e (pop es)))
+ (pcase e
+ (`(progn . ,exps) (setq es (append exps es)))
+ (`(custom-declare-variable . ,_) (push e defs)))))
+ (macroexp-progn (nreverse defs)))))
+
(defun custom-make-dependencies ()
"Batch function to extract custom dependencies from .el files.
Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
@@ -70,7 +89,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(directory-files subdir nil
"\\`[^=.].*\\.el\\'"))))
(progress (make-progress-reporter
- (byte-compile-info-string "Scanning files for custom")
+ (byte-compile-info "Scanning files for custom")
0 (length files) nil 10)))
(with-temp-buffer
(dolist (elem files)
@@ -90,6 +109,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(string-match "\\`\\(.*\\)\\.el\\'" file)
(let ((name (or generated-autoload-load-name ; see bug#5277
(file-name-nondirectory (match-string 1 file))))
+ (load-true-file-name file)
(load-file-name file))
(if (save-excursion
(re-search-forward
@@ -102,13 +122,17 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
"^(def\\(custom\\|face\\|group\\|ine\\(?:-globalized\\)?-minor-mode\\)" nil t)
(beginning-of-line)
(let ((type (match-string 1))
- (expr (read (current-buffer))))
+ (expr (custom--get-def (read (current-buffer)))))
(condition-case nil
- (let ((custom-dont-initialize t))
+ (let ((custom-dont-initialize t)
+ (sym (nth 1 expr)))
+ (put (if (eq (car-safe sym) 'quote)
+ (cadr sym)
+ sym)
+ 'custom-where name)
;; Eval to get the 'custom-group, -tag,
;; -version, group-documentation etc properties.
- (put (nth 1 expr) 'custom-where name)
- (eval expr))
+ (eval expr t))
;; Eval failed for some reason. Eg maybe the
;; defcustom uses something defined earlier
;; in the file (we haven't loaded the file).
@@ -127,8 +151,8 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
type)))))))))))
(error nil)))))))
(progress-reporter-done progress))
- (byte-compile-info-message "Generating %s..."
- generated-custom-dependencies-file)
+ (byte-compile-info
+ (format "Generating %s..." generated-custom-dependencies-file) t)
(set-buffer (find-file-noselect generated-custom-dependencies-file))
(setq buffer-undo-list t)
(erase-buffer)
@@ -140,7 +164,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(let ((members (get symbol 'custom-group))
where found)
(when members
- (dolist (member (mapcar 'car members))
+ (dolist (member (mapcar #'car members))
(setq where (get member 'custom-where))
(unless (or (null where)
(member where found))
@@ -148,13 +172,14 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(when found
(push (cons (symbol-name symbol)
(with-output-to-string
- (prin1 (sort found 'string<)))) alist))))))
+ (prin1 (sort found #'string<))))
+ alist))))))
(dolist (e (sort alist (lambda (e1 e2) (string< (car e1) (car e2)))))
(insert "(put '" (car e) " 'custom-loads '" (cdr e) ")\n")))
(insert "\
;; The remainder of this file is for handling :version.
-;; We provide a minimum of information so that `customize-changed-options'
+;; We provide a minimum of information so that `customize-changed'
;; can do its job.
;; For groups we set `custom-version', `group-documentation' and
@@ -180,7 +205,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(setq where (get symbol 'custom-where))
(when where
(if (or (custom-variable-p symbol)
- (custom-facep symbol))
+ (facep symbol))
;; This means it's a variable or a face.
(progn
(if (assoc version version-alist)
@@ -215,10 +240,10 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
This is an alist whose members have as car a version string, and as
elements the files that have variables or faces that contain that
version. These files should be loaded before showing the customization
-buffer that `customize-changed-options' generates.\")\n\n"))
+buffer that `customize-changed' generates.\")\n\n"))
(save-buffer)
- (byte-compile-info-message "Generating %s...done"
- generated-custom-dependencies-file))
+ (byte-compile-info
+ (format "Generating %s...done" generated-custom-dependencies-file) t))
(provide 'cus-dep)
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 25b4ccdb64d..980a1cc7179 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -408,10 +408,6 @@ Use group `text' for this instead. This group is deprecated."
"Input from the menus."
:group 'environment)
-(defgroup dnd nil
- "Handling data from drag and drop."
- :group 'environment)
-
(defgroup auto-save nil
"Preventing accidental loss of data."
:group 'files)
@@ -485,14 +481,20 @@ Return a list suitable for use in `interactive'."
(default (and (symbolp v) (custom-variable-p v) (symbol-name v)))
(enable-recursive-minibuffers t)
val)
- (setq val (completing-read
- (if default (format "Customize variable (default %s): " default)
- "Customize variable: ")
- obarray 'custom-variable-p t nil nil default))
+ (setq val (completing-read (format-prompt "Customize variable" default)
+ obarray 'custom-variable-p t nil nil default))
(list (if (equal val "")
(if (symbolp v) v nil)
(intern val)))))
+(defvar custom-actioned-widget nil
+ "Widget for which to show the menu of available actions.
+
+When showing a menu for a custom-variable, custom-face or custom-group widget,
+the respective custom-*-action functions bind this variable to that widget, and
+the respective custom-*-menu menus use the binding in their :enable and
+:selected forms.")
+
(defun custom-menu-filter (menu widget)
"Convert MENU to the form used by `widget-choose'.
MENU should be in the same format as `custom-variable-menu'.
@@ -561,7 +563,7 @@ value unless you are sure you know what it does."
(unless no-suffix
(goto-char (point-max))
(insert "..."))
- (buffer-string)))))
+ (propertize (buffer-string) 'custom-data symbol)))))
(defcustom custom-unlispify-tag-names t
"Display tag names as words instead of symbols if non-nil."
@@ -728,48 +730,86 @@ 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
- '((" Apply " Custom-set t
- "Apply settings (for the current session only)."
- "index"
- "Apply")
- (" Apply and Save " Custom-save
- (or custom-file user-init-file)
- "Apply settings and save for future sessions."
- "save"
- "Save")
+ '((" Apply " Custom-set t "Apply settings (for the current session only)."
+ "index" "Apply" (modified))
+ (" Apply and Save " Custom-save (or custom-file user-init-file)
+ "Apply settings and save for future sessions." "save" "Save"
+ (modified set changed rogue))
(" Undo Edits " Custom-reset-current t
"Restore customization buffer to reflect existing settings."
- "refresh"
- "Undo")
+ "refresh" "Undo" (modified))
(" Reset Customizations " Custom-reset-saved t
- "Undo any settings applied only for the current session."
- "undo"
- "Reset")
+ "Undo any settings applied only for the current session." "undo" "Reset"
+ (modified set changed rogue))
(" Erase Customizations " Custom-reset-standard
(or custom-file user-init-file)
- "Un-customize settings in this and future sessions."
- "delete"
- "Uncustomize")
- (" Help for Customize " Custom-help t
- "Get help for using Customize."
- "help"
- "Help")
- (" Exit " Custom-buffer-done t "Exit Customize." "exit" "Exit")))
+ "Un-customize settings in this and future sessions." "delete" "Uncustomize"
+ (modified set changed rogue saved))
+ (" Help for Customize " Custom-help t "Get help for using Customize."
+ "help" "Help" t)
+ (" Exit " Custom-buffer-done t "Exit Customize." "exit" "Exit" t))
+ "Alist of specifications for Customize menu items, tool bar icons and buttons.
+Each member has the format (TAG COMMAND VISIBLE HELP ICON LABEL ENABLE).
+TAG is a string, used as the :tag property of a widget.
+COMMAND is the command that the item or button runs.
+VISIBLE should be a form, suitable to pass as the :visible property for menu
+or tool bar items.
+HELP should be a string that can be used as the help echo property for tooltips
+and the like.
+ICON is a string that names the image to use for the tool bar item, like in the
+first argument of `tool-bar-local-item'.
+LABEL should be a string, used as the name of the menu items.
+ENABLE should be a list of custom states or t. When ENABLE is t, the item is
+always enabled. Otherwise, it is enabled only if at least one option displayed
+in the Custom buffer is in a state present in ENABLE.")
+
+(defvar-local custom-command-buttons nil
+ "A list that holds the buttons that act on all settings in a Custom buffer.
+`custom-buffer-create-internal' adds the buttons to this list.
+Changes in the state of the custom options should notify the buttons via the
+:notify property, so buttons can be enabled/disabled correctly at all times.")
(defun Custom-help ()
"Read the node on Easy Customization in the Emacs manual."
(interactive)
(info "(emacs)Easy Customization"))
-(defvar custom-reset-menu
- '(("Undo Edits in Customization Buffer" . Custom-reset-current)
- ("Revert This Session's Customizations" . Custom-reset-saved)
- ("Erase Customizations" . Custom-reset-standard))
- "Alist of actions for the `Reset' button.
+(defvar custom-reset-menu nil
+ "If non-nil, an alist of actions for the `Reset' button.
+
+This variable is kept for backward compatibility reasons, please use
+`custom-reset-extended-menu' instead.
+
The key is a string containing the name of the action, the value is a
Lisp function taking the widget as an element which will be called
when the action is chosen.")
+(defvar custom-reset-extended-menu
+ (let ((map (make-sparse-keymap)))
+ (define-key-after map [Custom-reset-current]
+ '(menu-item "Undo Edits in Customization Buffer" Custom-reset-current
+ :enable (seq-some (lambda (option)
+ (eq (widget-get option :custom-state)
+ 'modified))
+ custom-options)))
+ (define-key-after map [Custom-reset-saved]
+ '(menu-item "Revert This Session's Customizations" Custom-reset-saved
+ :enable (seq-some (lambda (option)
+ (memq (widget-get option :custom-state)
+ '(modified set changed rogue)))
+ custom-options)))
+ (when (or custom-file user-init-file)
+ (define-key-after map [Custom-reset-standard]
+ '(menu-item "Erase Customizations" Custom-reset-standard
+ :enable (seq-some
+ (lambda (option)
+ (memq (widget-get option :custom-state)
+ '(modified set changed rogue saved)))
+ custom-options))))
+ map)
+ "A menu for the \"Revert...\" button.
+Used in `custom-reset' to show a menu to the user.")
+
(defvar custom-options nil
"Customization widgets in the current buffer.")
@@ -801,22 +841,26 @@ has been executed, nil otherwise."
If a setting was edited and set before, this saves it. If a
setting was merely edited before, this sets it then saves it."
(interactive)
- (when (custom-command-apply
- (lambda (child)
- (when (memq (widget-get child :custom-state)
- '(modified set changed rogue))
- (widget-apply child :custom-mark-to-save)))
- "Save all settings in this buffer? " t)
- ;; Save changes to buffer and redraw.
- (custom-save-all)
- (dolist (child custom-options)
- (widget-apply child :custom-state-set-and-redraw))))
+ (let (edited-widgets)
+ (when (custom-command-apply
+ (lambda (child)
+ (when (memq (widget-get child :custom-state)
+ '(modified set changed rogue))
+ (push child edited-widgets)
+ (widget-apply child :custom-mark-to-save)))
+ "Save all settings in this buffer? " t)
+ ;; Save changes to buffer.
+ (custom-save-all)
+ ;; Redraw and recalculate the state when necessary.
+ (dolist (widget edited-widgets)
+ (widget-apply widget :custom-state-set-and-redraw)))))
(defun custom-reset (_widget &optional event)
"Select item from reset menu."
(let* ((completion-ignore-case t)
(answer (widget-choose "Reset settings"
- custom-reset-menu
+ (or custom-reset-menu
+ custom-reset-extended-menu)
event)))
(if answer
(funcall answer))))
@@ -1081,9 +1125,7 @@ for the MODE to customize."
(if (and group (not current-prefix-arg))
major-mode
(intern
- (completing-read (if group
- (format "Mode (default %s): " major-mode)
- "Mode: ")
+ (completing-read (format-prompt "Mode" (and group major-mode))
obarray
'custom-group-of-mode
t nil nil (if group (symbol-name major-mode))))))))
@@ -1164,7 +1206,7 @@ Show the buffer in another window, but don't select it."
(message "`%s' is an alias for `%s'" symbol basevar))))
(defvar customize-changed-options-previous-release "26.3"
- "Version for `customize-changed-options' to refer back to by default.")
+ "Version for `customize-changed' to refer back to by default.")
;; Packages will update this variable, so make it available.
;;;###autoload
@@ -1200,10 +1242,11 @@ the user might see the value in an error message, a good choice is
the official name of the package, such as MH-E or Gnus.")
;;;###autoload
-(defalias 'customize-changed 'customize-changed-options)
+(define-obsolete-function-alias 'customize-changed-options
+ #'customize-changed "28.1")
;;;###autoload
-(defun customize-changed-options (&optional since-version)
+(defun customize-changed (&optional since-version)
"Customize all settings whose meanings have changed in Emacs itself.
This includes new user options and faces, and new customization
groups, as well as older options and faces whose meanings or
@@ -1216,8 +1259,8 @@ that were added or redefined since that version."
(interactive
(list
(read-from-minibuffer
- (format "Customize options changed, since version (default %s): "
- customize-changed-options-previous-release))))
+ (format-prompt "Customize options changed, since version"
+ customize-changed-options-previous-release))))
(if (equal since-version "")
(setq since-version nil)
(unless (condition-case nil
@@ -1253,10 +1296,11 @@ that were added or redefined since that version."
(push (list symbol 'custom-group) found))
(if (custom-variable-p symbol)
(push (list symbol 'custom-variable) found))
- (if (custom-facep symbol)
+ (if (facep symbol)
(push (list symbol 'custom-face) found)))))))
(if found
- (custom-buffer-create (custom-sort-items found t 'first)
+ (custom-buffer-create (custom--filter-obsolete-variables
+ (custom-sort-items found t 'first))
"*Customize Changed Options*")
(user-error "No user option defaults have been changed since Emacs %s"
since-version))))
@@ -1363,7 +1407,7 @@ symbols `custom-face' or `custom-variable'."
(mapatoms (lambda (symbol)
(and (or (get symbol 'customized-face)
(get symbol 'customized-face-comment))
- (custom-facep symbol)
+ (facep symbol)
(push (list symbol 'custom-face) found))
(and (or (get symbol 'customized-value)
(get symbol 'customized-variable-comment))
@@ -1410,7 +1454,7 @@ symbols `custom-face' or `custom-variable'."
(mapatoms (lambda (symbol)
(and (or (get symbol 'saved-face)
(get symbol 'saved-face-comment))
- (custom-facep symbol)
+ (facep symbol)
(push (list symbol 'custom-face) found))
(and (or (get symbol 'saved-value)
(get symbol 'saved-variable-comment))
@@ -1448,7 +1492,7 @@ If TYPE is `groups', include only groups."
(if (get symbol 'custom-group)
(push (list symbol 'custom-group) found)))
(if (memq type '(nil faces))
- (if (custom-facep symbol)
+ (if (facep symbol)
(push (list symbol 'custom-face) found)))
(if (memq type '(nil options))
(if (and (boundp symbol)
@@ -1462,7 +1506,8 @@ If TYPE is `groups', include only groups."
(symbol-name type))
pattern))
(custom-buffer-create
- (custom-sort-items found t custom-buffer-order-groups)
+ (custom--filter-obsolete-variables
+ (custom-sort-items found t custom-buffer-order-groups))
"*Customize Apropos*")))
;;;###autoload
@@ -1552,7 +1597,10 @@ that option.
DESCRIPTION is unused."
(pop-to-buffer-same-window
(custom-get-fresh-buffer (or name "*Customization*")))
- (custom-buffer-create-internal options))
+ (custom-buffer-create-internal options)
+ ;; Notify the command buttons, to correctly enable/disable them.
+ (dolist (btn custom-command-buttons)
+ (widget-apply btn :notify)))
;;;###autoload
(defun custom-buffer-create-other-window (options &optional name _description)
@@ -1617,8 +1665,11 @@ Otherwise use brackets."
'custom-button-pressed
'custom-button-pressed-unraised))))
+(defvar custom--invocation-options nil)
+
(defun custom-buffer-create-internal (options &optional _description)
(Custom-mode)
+ (setq custom--invocation-options options)
(let ((init-file (or custom-file user-init-file)))
;; Insert verbose help at the top of the custom buffer.
(when custom-buffer-verbose-help
@@ -1669,11 +1720,24 @@ or a regular expression.")
(if custom-buffer-verbose-help
(widget-insert "
Operate on all settings in this buffer:\n"))
- (let ((button (lambda (tag action active help _icon _label)
+ (let ((button (lambda (tag action visible help _icon _label active)
(widget-insert " ")
- (if (eval active)
- (widget-create 'push-button :tag tag
- :help-echo help :action action))))
+ (if (eval visible)
+ (push (widget-create
+ 'push-button :tag tag
+ :help-echo help :action action
+ :notify
+ (lambda (widget)
+ (when (listp active)
+ (if (seq-some
+ (lambda (widget)
+ (memq
+ (widget-get widget :custom-state)
+ active))
+ custom-options)
+ (widget-apply widget :activate)
+ (widget-apply widget :deactivate)))))
+ custom-command-buttons))))
(commands custom-commands))
(if custom-reset-button-menu
(progn
@@ -2212,7 +2276,11 @@ and `face'."
(let ((state (widget-get widget :custom-state)))
(unless (eq state 'modified)
(unless (memq state '(nil unknown hidden))
- (widget-put widget :custom-state 'modified))
+ (widget-put widget :custom-state 'modified)
+ ;; Tell our buttons and the tool bar that we changed the widget's state.
+ (force-mode-line-update)
+ (dolist (btn custom-command-buttons)
+ (widget-apply btn :notify)))
;; Update the status text (usually from "STANDARD" to "EDITED
;; bla bla" in the buffer after the command has run. Otherwise
;; commands like `M-u' (that work on a region in the buffer)
@@ -2251,7 +2319,10 @@ and `face'."
(custom-group-state-update widget)))
(t
(setq widget nil)))))
- (widget-setup))
+ (widget-setup)
+ (force-mode-line-update)
+ (dolist (btn custom-command-buttons)
+ (widget-apply btn :notify)))
(defun custom-show (widget value)
"Non-nil if WIDGET should be shown with VALUE by default."
@@ -2667,11 +2738,15 @@ try matching its doc string against `custom-guess-doc-alist'."
buttons)
(insert " ")
(let* ((format (widget-get type :format))
- tag-format value-format)
- (unless (string-match ":" format)
+ tag-format)
+ ;; We used to drop the widget tag when creating TYPE, passing
+ ;; everything after the colon (including whitespace characters
+ ;; after it) as the :format for TYPE. We don't drop the tag
+ ;; anymore, but we should keep an immediate whitespace character,
+ ;; if present, and it's easier to do it here.
+ (unless (string-match ":\\s-?" format)
(error "Bad format"))
(setq tag-format (substring format 0 (match-end 0)))
- (setq value-format (substring format (match-end 0)))
(push (widget-create-child-and-convert
widget 'item
:format tag-format
@@ -2682,11 +2757,10 @@ try matching its doc string against `custom-guess-doc-alist'."
:sample-face (if obsolete
'custom-variable-obsolete
'custom-variable-tag)
- tag)
+ :tag tag)
buttons)
(push (widget-create-child-and-convert
widget type
- :format value-format
:value value)
children))))
(unless (eq custom-buffer-style 'tree)
@@ -2750,7 +2824,7 @@ the present value is saved to its :shown-value property instead."
(list (widget-value
(car-safe
(widget-get widget :children)))))
- (error "There are unsaved changes")))
+ (message "Note: There are unsaved changes")))
(widget-put widget :documentation-shown nil)
(widget-put widget :custom-state 'hidden))
(custom-redraw widget)
@@ -2786,7 +2860,9 @@ Possible return values are `standard', `saved', `set', `themed',
(and (equal value (eval (car tmp)))
(equal comment temp))
(error nil))
- 'set
+ (if (equal value (eval (car (get symbol 'standard-value))))
+ 'standard
+ 'set)
'changed))
((progn (setq tmp (get symbol 'theme-value))
(setq temp (get symbol 'saved-variable-comment))
@@ -2831,14 +2907,20 @@ Modified means that the widget that holds the value has been edited by the user
in a customize buffer.
To check for other states, call `custom-variable-state'."
(catch 'get-error
- (let* ((symbol (widget-get widget :value))
+ (let* ((form (widget-get widget :custom-form))
+ (symbol (widget-get widget :value))
(get (or (get symbol 'custom-get) 'default-value))
(value (if (default-boundp symbol)
(condition-case nil
(funcall get symbol)
(error (throw 'get-error t)))
- (symbol-value symbol))))
- (not (equal value (widget-value (car (widget-get widget :children))))))))
+ (symbol-value symbol)))
+ (orig-value (widget-value (car (widget-get widget :children)))))
+ (not (equal (if (memq form '(lisp mismatch))
+ ;; Mimic `custom-variable-value-create'.
+ (custom-quote value)
+ value)
+ orig-value)))))
(defun custom-variable-state-set (widget &optional state)
"Set the state of WIDGET to STATE.
@@ -2856,53 +2938,93 @@ otherwise."
(defun custom-variable-standard-value (widget)
(get (widget-value widget) 'standard-value))
-(defvar custom-variable-menu
- `(("Set for Current Session" custom-variable-set
- (lambda (widget)
- (eq (widget-get widget :custom-state) 'modified)))
- ;; Note that in all the backquoted code in this file, we test
- ;; init-file-user rather than user-init-file. This is in case
- ;; cus-edit is loaded by something in site-start.el, because
- ;; user-init-file is not set at that stage.
- ;; https://lists.gnu.org/r/emacs-devel/2007-10/msg00310.html
- ,@(when (or custom-file init-file-user)
- '(("Save for Future Sessions" custom-variable-save
- (lambda (widget)
- (memq (widget-get widget :custom-state)
- '(modified set changed rogue))))))
- ("Undo Edits" custom-redraw
- (lambda (widget)
- (and (default-boundp (widget-value widget))
- (memq (widget-get widget :custom-state) '(modified changed)))))
- ("Revert This Session's Customization" custom-variable-reset-saved
- (lambda (widget)
- (memq (widget-get widget :custom-state)
- '(modified set changed rogue))))
- ,@(when (or custom-file init-file-user)
- '(("Erase Customization" custom-variable-reset-standard
- (lambda (widget)
- (and (get (widget-value widget) 'standard-value)
- (memq (widget-get widget :custom-state)
- '(modified set changed saved rogue)))))))
- ("Set to Backup Value" custom-variable-reset-backup
- (lambda (widget)
- (get (widget-value widget) 'backup-value)))
- ("---" ignore ignore)
- ("Add Comment" custom-comment-show custom-comment-invisible-p)
- ("---" ignore ignore)
- ("Show Current Value" custom-variable-edit
- (lambda (widget)
- (eq (widget-get widget :custom-form) 'lisp)))
- ("Show Saved Lisp Expression" custom-variable-edit-lisp
- (lambda (widget)
- (eq (widget-get widget :custom-form) 'edit))))
- "Alist of actions for the `custom-variable' widget.
+(defun custom-variable-current-value (widget)
+ "Return the current value of the variable edited by WIDGET.
+
+WIDGET should be a custom-variable widget."
+ (let* ((symbol (widget-value widget))
+ (get (or (get symbol 'custom-get) 'default-value))
+ (type (custom-variable-type symbol))
+ (conv (widget-convert type)))
+ (if (default-boundp symbol)
+ (funcall get symbol)
+ (widget-get conv :value))))
+
+(defvar custom-variable-menu nil
+ "If non-nil, an alist of actions for the `custom-variable' widget.
+
+This variable is kept for backward compatibility reasons, please use
+`custom-variable-extended-menu' instead.
+
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
menu is selected, and FILTER is a predicate which takes a `custom-variable'
widget as an argument, and returns non-nil if ACTION is valid on that
widget. If FILTER is nil, ACTION is always valid.")
+(defvar custom-variable-extended-menu
+ ;; No need to give the keymap a prompt, `widget-choose' takes care of it.
+ (let ((map (make-sparse-keymap)))
+ (define-key-after map [custom-variable-set]
+ '(menu-item "Set for Current Session" custom-variable-set
+ :enable (eq (widget-get custom-actioned-widget :custom-state)
+ 'modified)))
+ ;; Conditionally add items that depend on having loaded the custom-file,
+ ;; rather than giving it a :visible form, because we used to conditionally
+ ;; add this item when using simplified menus.
+ ;; Note that we test init-file-user rather than user-init-file. This is
+ ;; in case cus-edit is loaded by something in site-start.el, because
+ ;; user-init-file is not set at that stage.
+ ;; https://lists.gnu.org/r/emacs-devel/2007-10/msg00310.html
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-variable-save]
+ '(menu-item "Save for Future Sessions" custom-variable-save
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set changed rogue)))))
+ (define-key-after map [custom-redraw]
+ '(menu-item "Undo Edits" custom-redraw
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified changed))))
+ (define-key-after map [custom-variable-reset-saved]
+ '(menu-item "Revert This Session's Customization"
+ custom-variable-reset-saved
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set changed rogue))))
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-variable-reset-standard]
+ '(menu-item "Erase Customization" custom-variable-reset-standard
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set changed saved rogue)))))
+ (define-key-after map [custom-variable-reset-backup]
+ '(menu-item "Set to Backup Value" custom-variable-reset-backup
+ :enable (get
+ (widget-value custom-actioned-widget)
+ 'backup-value)))
+ (define-key-after map [sep0]
+ '(menu-item "---"))
+ (define-key-after map [custom-comment-show]
+ '(menu-item "Add Comment" custom-comment-show
+ :enable (custom-comment-invisible-p custom-actioned-widget)))
+ (define-key-after map [sep1]
+ '(menu-item "---"))
+ (define-key-after map [custom-variable-edit]
+ '(menu-item "Show Current Value" custom-variable-edit
+ :button (:radio . (eq (widget-get custom-actioned-widget
+ :custom-form)
+ 'edit))))
+ (define-key-after map [custom-variable-edit-lisp]
+ '(menu-item "Show Saved Lisp Expression" custom-variable-edit-lisp
+ :button (:radio . (eq (widget-get custom-actioned-widget
+ :custom-form)
+ 'lisp))))
+ map)
+ "A menu for `custom-variable' widgets.
+Used in `custom-variable-action' to show a menu to the user.")
+
(defun custom-variable-action (widget &optional event)
"Show the menu for `custom-variable' WIDGET.
Optional EVENT is the location for the menu."
@@ -2912,12 +3034,17 @@ Optional EVENT is the location for the menu."
(custom-variable-state-set widget))
(custom-redraw-magic widget)
(let* ((completion-ignore-case t)
+ (custom-actioned-widget widget)
(answer (widget-choose (concat "Operation on "
- (custom-unlispify-tag-name
- (widget-get widget :value)))
- (custom-menu-filter custom-variable-menu
- widget)
- event)))
+ (custom-unlispify-tag-name
+ (widget-get widget :value)))
+ ;; Get rid of checks like this one if we ever
+ ;; remove the simplified menus.
+ (if custom-variable-menu
+ (custom-menu-filter custom-variable-menu
+ widget)
+ custom-variable-extended-menu)
+ event)))
(if answer
(funcall answer widget)))))
@@ -2953,10 +3080,12 @@ Optional EVENT is the location for the menu."
(setq comment nil)
;; Make the comment invisible by hand if it's empty
(custom-comment-hide comment-widget))
- (custom-variable-backup-value widget)
+ (setq val (widget-value child))
+ (unless (equal (eval val) (custom-variable-current-value widget))
+ (custom-variable-backup-value widget))
(custom-push-theme 'theme-value symbol 'user
- 'set (custom-quote (widget-value child)))
- (funcall set symbol (eval (setq val (widget-value child))))
+ 'set (custom-quote val))
+ (funcall set symbol (eval val))
(put symbol 'customized-value (list val))
(put symbol 'variable-comment comment)
(put symbol 'customized-variable-comment comment))
@@ -2965,10 +3094,12 @@ Optional EVENT is the location for the menu."
(setq comment nil)
;; Make the comment invisible by hand if it's empty
(custom-comment-hide comment-widget))
- (custom-variable-backup-value widget)
+ (setq val (widget-value child))
+ (unless (equal val (custom-variable-current-value widget))
+ (custom-variable-backup-value widget))
(custom-push-theme 'theme-value symbol 'user
- 'set (custom-quote (widget-value child)))
- (funcall set symbol (setq val (widget-value child)))
+ 'set (custom-quote val))
+ (funcall set symbol val)
(put symbol 'customized-value (list (custom-quote val)))
(put symbol 'variable-comment comment)
(put symbol 'customized-variable-comment comment)))
@@ -3037,17 +3168,23 @@ before this operation becomes the backup value."
(let* ((symbol (widget-value widget))
(saved-value (get symbol 'saved-value))
(comment (get symbol 'saved-variable-comment))
+ (old-value (custom-variable-current-value widget))
value)
- (custom-variable-backup-value widget)
(if (not (or saved-value comment))
- ;; If there is no saved value, remove the setting.
- (custom-push-theme 'theme-value symbol 'user 'reset)
+ (progn
+ (setq value (car (get symbol 'standard-value)))
+ ;; If there is no saved value, remove the setting.
+ (custom-push-theme 'theme-value symbol 'user 'reset)
+ ;; And reset this property too.
+ (put symbol 'variable-comment nil))
(setq value (car-safe saved-value))
(custom-push-theme 'theme-value symbol 'user 'set value)
(put symbol 'variable-comment comment))
+ (unless (equal (eval value) old-value)
+ (custom-variable-backup-value widget))
(ignore-errors
(funcall (or (get symbol 'custom-set) #'set-default) symbol
- (eval (or value (car (get symbol 'standard-value))))))
+ (eval value)))
(put symbol 'customized-value nil)
(put symbol 'customized-variable-comment nil)
(widget-put widget :custom-state 'unknown)
@@ -3060,7 +3197,9 @@ If `custom-reset-standard-variables-list' is nil, save, reset and
redraw the widget immediately."
(let* ((symbol (widget-value widget)))
(if (get symbol 'standard-value)
- (custom-variable-backup-value widget)
+ (unless (equal (custom-variable-current-value widget)
+ (eval (car (get symbol 'standard-value))))
+ (custom-variable-backup-value widget))
(user-error "No standard setting known for %S" symbol))
(put symbol 'variable-comment nil)
(put symbol 'customized-value nil)
@@ -3097,13 +3236,8 @@ becomes the backup value, so you can get it again."
(defun custom-variable-backup-value (widget)
"Back up the current value for WIDGET's variable.
The backup value is kept in the car of the `backup-value' property."
- (let* ((symbol (widget-value widget))
- (get (or (get symbol 'custom-get) 'default-value))
- (type (custom-variable-type symbol))
- (conv (widget-convert type))
- (value (if (default-boundp symbol)
- (funcall get symbol)
- (widget-get conv :value))))
+ (let ((symbol (widget-value widget))
+ (value (custom-variable-current-value widget)))
(put symbol 'backup-value (list value))))
(defun custom-variable-reset-backup (widget)
@@ -3169,6 +3303,7 @@ face attributes (as specified by a `default' defface entry)."
:convert-widget 'custom-face-edit-convert-widget
:args (mapcar (lambda (att)
(list 'group :inline t
+ :format "%v"
:sibling-args (widget-get (nth 1 att) :sibling-args)
(list 'const :format "" :value (nth 0 att))
(nth 1 att)))
@@ -3565,19 +3700,24 @@ the present value is saved to its :shown-value property instead."
(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)))
+ ;; 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 " ")
+ (push (widget-create-child-and-convert
+ widget 'face-link
+ :button-face 'link
+ :tag tag
+ :action (lambda (&rest _x)
+ (find-face-definition symbol)))
+ buttons)
(insert
(cond ((eq custom-buffer-style 'face) " ")
((string-match-p "face\\'" tag) ":")
@@ -3676,39 +3816,74 @@ the present value is saved to its :shown-value property instead."
(widget-put widget :children children)
(custom-face-state-set widget))))))
-(defvar custom-face-menu
- `(("Set for Current Session" custom-face-set)
- ,@(when (or custom-file init-file-user)
- '(("Save for Future Sessions" custom-face-save)))
- ("Undo Edits" custom-redraw
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified changed))))
- ("Revert This Session's Customization" custom-face-reset-saved
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set changed))))
- ,@(when (or custom-file init-file-user)
- '(("Erase Customization" custom-face-reset-standard
- (lambda (widget)
- (get (widget-value widget) 'face-defface-spec)))))
- ("---" ignore ignore)
- ("Add Comment" custom-comment-show custom-comment-invisible-p)
- ("---" ignore ignore)
- ("For Current Display" custom-face-edit-selected
- (lambda (widget)
- (not (eq (widget-get widget :custom-form) 'selected))))
- ("For All Kinds of Displays" custom-face-edit-all
- (lambda (widget)
- (not (eq (widget-get widget :custom-form) 'all))))
- ("Show Lisp Expression" custom-face-edit-lisp
- (lambda (widget)
- (not (eq (widget-get widget :custom-form) 'lisp)))))
- "Alist of actions for the `custom-face' widget.
+(defun cus--face-link (widget _format)
+ (widget-create-child-and-convert
+ widget 'face-link
+ :button-face 'link
+ :tag "link"
+ :action (lambda (&rest _x)
+ (customize-face (widget-value widget)))))
+
+(defvar custom-face-menu nil
+ "If non-nil, an alist of actions for the `custom-face' widget.
+
+This variable is kept for backward compatibility reasons, please use
+`custom-face-extended-menu' instead.
+
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
menu is selected, and FILTER is a predicate which takes a `custom-face'
widget as an argument, and returns non-nil if ACTION is valid on that
widget. If FILTER is nil, ACTION is always valid.")
+(defvar custom-face-extended-menu
+ (let ((map (make-sparse-keymap)))
+ (define-key-after map [custom-face-set]
+ '(menu-item "Set for Current Session" custom-face-set))
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-face-save]
+ '(menu-item "Save for Future Sessions" custom-face-save)))
+ (define-key-after map [custom-redraw]
+ '(menu-item "Undo Edits" custom-redraw
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified changed))))
+ (define-key-after map [custom-face-reset-saved]
+ '(menu-item "Revert This Session's Customization" custom-face-reset-saved
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set changed))))
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-face-reset-standard]
+ '(menu-item "Erase Customization" custom-face-reset-standard
+ :enable (get (widget-value custom-actioned-widget)
+ 'face-defface-spec))))
+ (define-key-after map [sep0]
+ '(menu-item "---"))
+ (define-key-after map [custom-comment-show]
+ '(menu-item "Add Comment" custom-comment-show
+ :enable (custom-comment-invisible-p custom-actioned-widget)))
+ (define-key-after map [sep1]
+ '(menu-item "---"))
+ (define-key-after map [custom-face-edit-selected]
+ '(menu-item "For Current Display" custom-face-edit-selected
+ :button (:radio . (eq (widget-get custom-actioned-widget
+ :custom-form)
+ 'selected))))
+ (define-key-after map [custom-face-edit-all]
+ '(menu-item "For All Kinds of Displays" custom-face-edit-all
+ :button (:radio . (eq (widget-get custom-actioned-widget
+ :custom-form)
+ 'all))))
+ (define-key-after map [custom-face-edit-lisp]
+ '(menu-item "Show Lisp Expression" custom-face-edit-lisp
+ :button (:radio . (eq (widget-get custom-actioned-widget
+ :custom-form)
+ 'lisp))))
+ map)
+ "A menu for `custom-face' widgets.
+Used in `custom-face-action' to show a menu to the user.")
+
(defun custom-face-edit-selected (widget)
"Edit selected attributes of the value of WIDGET."
(widget-put widget :custom-state 'unknown)
@@ -3775,12 +3950,15 @@ Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
(custom-toggle-hide widget)
(let* ((completion-ignore-case t)
+ (custom-actioned-widget widget)
(symbol (widget-get widget :value))
(answer (widget-choose (concat "Operation on "
(custom-unlispify-tag-name symbol))
- (custom-menu-filter custom-face-menu
- widget)
- event)))
+ (if custom-face-menu
+ (custom-menu-filter custom-face-menu
+ widget)
+ custom-face-extended-menu)
+ event)))
(if answer
(funcall answer widget)))))
@@ -3825,7 +4003,22 @@ Optional EVENT is the location for the menu."
(defun custom-face-save (widget)
"Save the face edited by WIDGET."
- (custom-face-mark-to-save widget)
+ (let ((form (widget-get widget :custom-form)))
+ (if (memq form '(all lisp))
+ (custom-face-mark-to-save widget)
+ ;; The user is working on only a selected terminal type;
+ ;; make sure we save the entire spec to `custom-file'. (Bug #40866)
+ ;; If recreating a widget that may have been edited by the user, remember
+ ;; to always save the edited value into the :shown-value property, so
+ ;; we use that value for the recreated widget. (Bug#44331)
+ (widget-put widget :shown-value (custom-face-widget-to-spec widget))
+ (custom-face-edit-all widget)
+ (widget-put widget :shown-value nil) ; Reset it after we used it.
+ (custom-face-mark-to-save widget)
+ (if (eq form 'selected)
+ (custom-face-edit-selected widget)
+ ;; `form' is edit or mismatch; can't happen.
+ (widget-put widget :custom-form form))))
(custom-save-all)
(custom-face-state-set-and-redraw widget))
@@ -3905,7 +4098,7 @@ restoring it to the state of a face that has never been customized."
(define-widget 'face 'symbol
"A Lisp face name (with sample)."
- :format "%{%t%}: (%{sample%}) %v"
+ :format "%{%t%}: %f (%{sample%}) %v"
:tag "Face"
:value 'default
:sample-face-get 'widget-face-sample-face-get
@@ -3915,6 +4108,7 @@ restoring it to the state of a face that has never been customized."
obarray #'facep 'strict)
:prompt-match 'facep
:prompt-history 'widget-face-prompt-value-history
+ :format-handler 'cus--face-link
:validate (lambda (widget)
(unless (facep (widget-value widget))
(widget-put widget
@@ -4053,6 +4247,13 @@ and so forth. The remaining group tags are shown with `custom-group-tag'."
(insert "--------")))
(widget-default-create widget))
+(defun custom--filter-obsolete-variables (items)
+ "Filter obsolete variables from ITEMS."
+ (seq-remove (lambda (item)
+ (and (eq (nth 1 item) 'custom-variable)
+ (get (nth 0 item) 'byte-obsolete-variable)))
+ items))
+
(defun custom-group-members (symbol groups-only)
"Return SYMBOL's custom group members.
If GROUPS-ONLY is non-nil, return only those members that are groups."
@@ -4258,12 +4459,13 @@ This works for both graphical and text displays."
?\s))
;; Members.
(message "Creating group...")
- (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))
+ (let* ((members (custom--filter-obsolete-variables
+ (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))
(have-subtitle (and (not (eq symbol 'emacs))
@@ -4300,43 +4502,65 @@ This works for both graphical and text displays."
(insert "\n")
(custom-group--draw-horizontal-line)))))
-(defvar custom-group-menu
- `(("Set for Current Session" custom-group-set
- (lambda (widget)
- (eq (widget-get widget :custom-state) 'modified)))
- ,@(when (or custom-file init-file-user)
- '(("Save for Future Sessions" custom-group-save
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set))))))
- ("Undo Edits" custom-group-reset-current
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified))))
- ("Revert This Session's Customizations" custom-group-reset-saved
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set))))
- ,@(when (or custom-file init-file-user)
- '(("Erase Customization" custom-group-reset-standard
- (lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set saved)))))))
- "Alist of actions for the `custom-group' widget.
+(defvar custom-group-menu nil
+ "If non-nil, an alist of actions for the `custom-group' widget.
+
+This variable is kept for backward compatibility reasons, please use
+`custom-group-extended-menu' instead.
+
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
menu is selected, and FILTER is a predicate which takes a `custom-group'
widget as an argument, and returns non-nil if ACTION is valid on that
widget. If FILTER is nil, ACTION is always valid.")
+(defvar custom-group-extended-menu
+ (let ((map (make-sparse-keymap)))
+ (define-key-after map [custom-group-set]
+ '(menu-item "Set for Current Session" custom-group-set
+ :enable (eq (widget-get custom-actioned-widget :custom-state)
+ 'modified)))
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-group-save]
+ '(menu-item "Save for Future Sessions" custom-group-save
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set)))))
+ (define-key-after map [custom-group-reset-current]
+ '(menu-item "Undo Edits" custom-group-reset-current
+ :enable (eq (widget-get custom-actioned-widget :custom-state)
+ 'modified)))
+ (define-key-after map [custom-group-reset-saved]
+ '(menu-item "Revert This Session's Customizations"
+ custom-group-reset-saved
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set))))
+ (when (or custom-file init-file-user)
+ (define-key-after map [custom-group-reset-standard]
+ '(menu-item "Erase Customization" custom-group-reset-standard
+ :enable (memq
+ (widget-get custom-actioned-widget :custom-state)
+ '(modified set saved)))))
+ map)
+ "A menu for `custom-group' widgets.
+Used in `custom-group-action' to show a menu to the user.")
+
(defun custom-group-action (widget &optional event)
"Show the menu for `custom-group' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
(custom-toggle-hide widget)
(let* ((completion-ignore-case t)
+ (custom-actioned-widget widget)
(answer (widget-choose (concat "Operation on "
(custom-unlispify-tag-name
(widget-get widget :value)))
- (custom-menu-filter custom-group-menu
- widget)
- event)))
+ (if custom-group-menu
+ (custom-menu-filter custom-group-menu
+ widget)
+ custom-group-extended-menu)
+ event)))
(if answer
(funcall answer widget)))))
@@ -4500,8 +4724,9 @@ if only the first line of the docstring is shown."))
(let ((inhibit-read-only t)
(print-length nil)
(print-level nil))
- (custom-save-variables)
- (custom-save-faces))
+ (atomic-change-group
+ (custom-save-variables)
+ (custom-save-faces)))
(let ((file-precious-flag t))
(save-buffer))
(if old-buffer
@@ -4578,15 +4803,12 @@ 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
(custom-save-delete 'custom-set-variables)
(let ((standard-output (current-buffer))
- (saved-list (make-list 1 0))
- sort-fold-case)
+ (saved-list (make-list 1 0)))
;; First create a sorted list of saved variables.
(mapatoms
(lambda (symbol)
@@ -4668,8 +4890,7 @@ This function does not save the buffer."
(custom-save-delete 'custom-reset-faces)
(custom-save-delete 'custom-set-faces)
(let ((standard-output (current-buffer))
- (saved-list (make-list 1 0))
- sort-fold-case)
+ (saved-list (make-list 1 0)))
;; First create a sorted list of saved faces.
(mapatoms
(lambda (symbol)
@@ -4691,7 +4912,7 @@ This function does not save the buffer."
(let ((spec (car-safe (get symbol 'theme-face)))
(value (get symbol 'saved-face))
(now (not (or (get symbol 'face-defface-spec)
- (and (not (custom-facep symbol))
+ (and (not (facep symbol))
(not (get symbol 'force-face))))))
(comment (get symbol 'saved-face-comment)))
(when (or (and spec (eq (nth 0 spec) 'user))
@@ -4810,9 +5031,19 @@ The format is suitable for use with `easy-menu-define'."
(mapcar (lambda (arg)
(let ((tag (nth 0 arg))
(command (nth 1 arg))
- (active (nth 2 arg))
- (help (nth 3 arg)))
- (vector tag command :active (eval active) :help help)))
+ (visible (nth 2 arg))
+ (help (nth 3 arg))
+ (active (nth 6 arg)))
+ (vector tag command :visible (eval visible)
+ :active
+ `(or (eq t ',active)
+ (seq-some ,(lambda (widget)
+ (memq
+ (widget-get widget
+ :custom-state)
+ active))
+ custom-options))
+ :help help)))
custom-commands)))
(defvar tool-bar-map)
@@ -4831,7 +5062,10 @@ The format is suitable for use with `easy-menu-define'."
(error "You can't edit this part of the Custom buffer"))
(defun Custom-newline (pos &optional event)
- "Invoke button at POS, or refuse to allow editing of Custom buffer."
+ "Invoke button at POS, or refuse to allow editing of Custom buffer.
+
+To see what function the widget will call, use the
+`widget-describe' command."
(interactive "@d")
(let ((button (get-char-property pos 'button)))
;; If there is no button at point, then use the one at the start
@@ -4855,8 +5089,6 @@ If several parents are listed, go to the first of them."
(parent (downcase (widget-get button :tag))))
(customize-group parent)))))
-(define-obsolete-variable-alias 'custom-mode-hook 'Custom-mode-hook "23.1")
-
(defcustom Custom-mode-hook nil
"Hook called when entering Custom mode."
:type 'hook
@@ -4908,7 +5140,6 @@ Erase customizations; set options
Entry to this mode calls the value of `Custom-mode-hook'
if that value is non-nil."
(use-local-map custom-mode-map)
- (easy-menu-add Custom-mode-menu)
(setq-local tool-bar-map
(or custom-tool-bar-map
;; Set up `custom-tool-bar-map'.
@@ -4920,16 +5151,20 @@ if that value is non-nil."
:label (nth 5 arg)))
custom-commands)
(setq custom-tool-bar-map map))))
+ (setq-local custom--invocation-options nil)
+ (setq-local revert-buffer-function #'custom--revert-buffer)
(make-local-variable 'custom-options)
(make-local-variable 'custom-local-buffer)
(custom--initialize-widget-variables)
(add-hook 'widget-edit-functions 'custom-state-buffer-message nil t))
-(put 'Custom-mode 'mode-class 'special)
-
-(define-obsolete-function-alias 'custom-mode 'Custom-mode "23.1")
+(defun custom--revert-buffer (_ignore-auto _noconfirm)
+ (unless custom--invocation-options
+ (error "Insufficient data to revert"))
+ (custom-buffer-create custom--invocation-options
+ (buffer-name)))
-;;; The End.
+(put 'Custom-mode 'mode-class 'special)
(provide 'cus-edit)
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 5a1ffda1809..6c0052bf860 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -1,4 +1,4 @@
-;;; cus-face.el --- customization support for faces
+;;; cus-face.el --- customization support for faces -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1996-1997, 1999-2021 Free Software Foundation, Inc.
;;
@@ -27,8 +27,6 @@
;;; Code:
-(defalias 'custom-facep 'facep)
-
;;; Declaring a face.
(defun custom-declare-face (face spec doc &rest args)
@@ -166,30 +164,37 @@
:help-echo "Control box around text."
(const :tag "Off" nil)
(list :tag "Box"
- :value (:line-width 2 :color "grey75" :style released-button)
- (const :format "" :value :line-width)
- (integer :tag "Width")
+ :value (:line-width (2 . 2) :color "grey75" :style released-button)
+ (const :format "" :value :line-width)
+ (cons :tag "Width" :extra-offset 2
+ (integer :tag "Vertical")
+ (integer :tag "Horizontal"))
(const :format "" :value :color)
(choice :tag "Color" (const :tag "*" nil) color)
(const :format "" :value :style)
(choice :tag "Style"
(const :tag "Raised" released-button)
(const :tag "Sunken" pressed-button)
+ (const :tag "Flat" flat-button)
(const :tag "None" nil))))
;; filter to make value suitable for customize
(lambda (real-value)
(and real-value
(let ((lwidth
(or (and (consp real-value)
- (plist-get real-value :line-width))
+ (if (listp (cdr real-value))
+ (plist-get real-value :line-width)
+ real-value))
(and (integerp real-value) real-value)
- 1))
+ '(1 . 1)))
(color
(or (and (consp real-value) (plist-get real-value :color))
(and (stringp real-value) real-value)
nil))
(style
(and (consp real-value) (plist-get real-value :style))))
+ (if (integerp lwidth)
+ (setq lwidth (cons (abs lwidth) lwidth)))
(list :line-width lwidth :color color :style style))))
;; filter to make customized-value suitable for storing
(lambda (cus-value)
@@ -388,7 +393,7 @@ Each of the arguments ARGS has this form:
This means reset FACE to its value in FROM-THEME."
(apply 'custom-theme-reset-faces 'user args))
-;;; The End.
+(define-obsolete-function-alias 'custom-facep #'facep "28.1")
(provide 'cus-face)
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index b7f0d7e2a85..7df70d704ef 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -36,7 +36,7 @@
(defun minibuffer-prompt-properties--setter (symbol value)
(set-default symbol value)
(if (memq 'cursor-intangible value)
- (add-hook 'minibuffer-setup-hook 'cursor-intangible-mode)
+ (add-hook 'minibuffer-setup-hook #'cursor-intangible-mode)
;; Removing it is a bit trickier since it could have been added by someone
;; else as well, so let's just not bother.
))
@@ -73,9 +73,11 @@
'(choice
(const :tag "Frame default" t)
(const :tag "Filled box" box)
+ (cons :tag "Box with specified size"
+ (const box) integer)
(const :tag "Hollow cursor" hollow)
(const :tag "Vertical bar" bar)
- (cons :tag "Vertical bar with specified width"
+ (cons :tag "Vertical bar with specified height"
(const bar) integer)
(const :tag "Horizontal bar" hbar)
(cons :tag "Horizontal bar with specified width"
@@ -98,6 +100,11 @@
(ctl-arrow display boolean)
(truncate-lines display boolean)
(word-wrap display boolean)
+ (word-wrap-by-category
+ display boolean "28.1"
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (when value (require 'kinsoku))))
(selective-display-ellipses display boolean)
(indicate-empty-lines fringe boolean)
(indicate-buffer-boundaries
@@ -278,6 +285,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP")
;; See bug#7135.
(let* (file-name-handler-alist
+ (default-directory "/")
(tmp (ignore-errors
(shell-command-to-string
"getconf DARWIN_USER_TEMP_DIR"))))
@@ -295,10 +303,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; fns.c
(use-dialog-box menu boolean "21.1")
(use-file-dialog menu boolean "22.1")
+ (use-short-answers menu boolean "28.1")
(focus-follows-mouse
frames (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "On (t)" :value t)
+ (const :tag "Off" :value nil)
+ (const :tag "On" :value t)
(const :tag "Auto-raise" :value auto-raise)) "26.1")
;; fontset.c
;; FIXME nil is the initial value, fontset.el setqs it.
@@ -387,6 +396,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; (directory :format "%v"))))
(load-prefer-newer lisp boolean "24.4")
;; minibuf.c
+ (minibuffer-follows-selected-frame
+ minibuffer (choice (const :tag "Always" t)
+ (const :tag "When used" hybrid)
+ (const :tag "Never" nil))
+ "28.1")
(enable-recursive-minibuffers minibuffer boolean)
(history-length minibuffer
(choice (const :tag "Infinite" t) integer)
@@ -589,27 +603,29 @@ since it could result in memory overflow and make Emacs crash."
(next-screen-context-lines windows integer)
(scroll-preserve-screen-position
windows (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "Full screen (t)" :value t)
- (other :tag "Always" 1)) "22.1")
+ (const :tag "Off" :value nil)
+ (const :tag "Full screen" :value t)
+ (other :tag "Always" 1))
+ "22.1")
(recenter-redisplay
windows (choice
- (const :tag "Never (nil)" :value nil)
+ (const :tag "Never" :value nil)
(const :tag "Only on ttys" :value tty)
- (other :tag "Always" t)) "23.1")
+ (other :tag "Always" t))
+ "23.1")
(window-combination-resize windows boolean "24.1")
(window-combination-limit
windows (choice
- (const :tag "Never (nil)" :value nil)
- (const :tag "If requested via buffer display alist (window-size)"
+ (const :tag "Never" :value nil)
+ (const :tag "If requested via buffer display alist"
:value window-size)
- (const :tag "With Temp Buffer Resize mode (temp-buffer-resize)"
+ (const :tag "With Temp Buffer Resize mode"
:value temp-buffer-resize)
- (const :tag "For temporary buffers (temp-buffer)"
+ (const :tag "For temporary buffers"
:value temp-buffer)
- (const :tag "For buffer display (display-buffer)"
+ (const :tag "For buffer display"
:value display-buffer)
- (other :tag "Always (t)" :value t))
+ (other :tag "Always" :value t))
"26.1")
(fast-but-imprecise-scrolling scrolling boolean "25.1")
(window-resize-pixelwise windows boolean "24.4")
@@ -617,12 +633,20 @@ since it could result in memory overflow and make Emacs crash."
;; The whitespace group is for whitespace.el.
(show-trailing-whitespace editing-basics boolean nil
:safe booleanp)
+ (mode-line-compact
+ mode-line
+ (choice (const :tag "Never" :value nil)
+ (const :tag "Only if wider than window" :value long)
+ (const :tag "Always" :value t))
+ "28.1")
(scroll-step windows integer)
(scroll-conservatively windows integer)
(scroll-margin windows integer)
(maximum-scroll-margin windows float "26.1")
(hscroll-margin windows integer "22.1")
- (hscroll-step windows number "22.1")
+ (hscroll-step windows
+ (choice (const :tag "Center horizontally" nil)
+ number) "22.1")
(truncate-partial-width-windows
display
(choice (integer :tag "Truncate if narrower than")
@@ -652,7 +676,7 @@ since it could result in memory overflow and make Emacs crash."
(underline-minimum-offset display integer "23.1")
(mouse-autoselect-window
display (choice
- (const :tag "Off (nil)" :value nil)
+ (const :tag "Off" :value nil)
(const :tag "Immediate" :value t)
(number :tag "Delay by secs" :value 0.5)) "22.1")
(tool-bar-style
@@ -697,15 +721,15 @@ since it could result in memory overflow and make Emacs crash."
(hourglass-delay cursor number)
(resize-mini-windows
windows (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "Fit (t)" :value t)
+ (const :tag "Off" :value nil)
+ (const :tag "Fit" :value t)
(const :tag "Grow only" :value grow-only))
"25.1")
(display-raw-bytes-as-hex display boolean "26.1")
(display-line-numbers
display-line-numbers
(choice
- (const :tag "Off (nil)" :value nil)
+ (const :tag "Off" :value nil)
(const :tag "Absolute line numbers"
:value t)
(const :tag "Relative line numbers"
@@ -782,7 +806,11 @@ since it could result in memory overflow and make Emacs crash."
"27.1"
:safe (lambda (value) (or (characterp value) (null value))))
;; xfaces.c
- (scalable-fonts-allowed display boolean "22.1")
+ (scalable-fonts-allowed
+ display (choice (const :tag "Don't allow scalable fonts" nil)
+ (const :tag "Allow any scalable font" t)
+ (repeat regexp))
+ "22.1")
;; xfns.c
(x-bitmap-file-path installation
(repeat (directory :format "%v")))
@@ -862,7 +890,7 @@ since it could result in memory overflow and make Emacs crash."
;; Don't re-add to custom-delayed-init-variables post-startup.
(unless after-init-time
;; Note this is the _only_ initialize property we handle.
- (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay)
+ (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay)
;; These vars are defined early and should hence be initialized
;; early, even if this file happens to be loaded late. so add them
;; to the end of custom-delayed-init-variables. Otherwise,
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index 3c4cb276fc9..f4885d0f52b 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -1,7 +1,7 @@
-;;; cus-theme.el -- custom theme creation user interface -*- lexical-binding: t -*-
-;;
+;;; cus-theme.el --- custom theme creation user interface -*- lexical-binding: t -*-
+
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
-;;
+
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: help, faces
@@ -108,60 +108,16 @@ named *Custom Theme*."
(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"))
-
- (widget-create 'push-button
- :tag " Visit Theme "
- :help-echo "Insert the settings of a pre-defined theme."
- :action (lambda (_widget &optional _event)
- (call-interactively #'custom-theme-visit-theme)))
- (widget-insert " ")
- (widget-create 'push-button
- :tag " Merge Theme "
- :help-echo "Merge in the settings of a pre-defined theme."
- :action (lambda (_widget &optional _event)
- (call-interactively #'custom-theme-merge-theme)))
- (widget-insert " ")
- (widget-create 'push-button
- :tag " Revert "
- :help-echo "Revert this buffer to its original state."
- :action (lambda (&rest ignored) (revert-buffer)))
-
- (widget-insert "\n\nTheme name : ")
- (setq custom-theme-name
- (widget-create 'editable-field
- :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-create 'push-button
- :notify #'custom-theme-write
- " 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 nil t))
+ (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")
+ (load-theme theme nil t))
+
(dolist (setting (get theme 'theme-settings))
(if (eq (car setting) 'theme-value)
(progn (push (nth 1 setting) vars)
@@ -169,6 +125,50 @@ remove them from your saved Custom file.\n\n"))
(push (nth 1 setting) faces)
(push (nth 3 setting) face-specs))))
+ (widget-create 'push-button
+ :tag " Visit Theme "
+ :help-echo "Insert the settings of a pre-defined theme."
+ :action (lambda (_widget &optional _event)
+ (call-interactively #'custom-theme-visit-theme)))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :tag " Merge Theme "
+ :help-echo "Merge in the settings of a pre-defined theme."
+ :action (lambda (_widget &optional _event)
+ (call-interactively #'custom-theme-merge-theme)))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :tag " Revert "
+ :help-echo "Revert this buffer to its original state."
+ :action (lambda (&rest ignored) (revert-buffer)))
+
+ (widget-insert "\n\nTheme name : ")
+ (setq custom-theme-name
+ (widget-create 'editable-field
+ :value (if (and theme (not (eq theme 'user)))
+ (symbol-name theme)
+ "")))
+ (widget-insert "Description: ")
+ (setq custom-theme-description
+ (widget-create 'text :format "%v"
+ :value (or (get theme 'theme-documentation)
+ (format-time-string "Created %Y-%m-%d."))))
+ (widget-create 'push-button
+ :notify #'custom-theme-write
+ " 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)))))
+
;; 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 ")
@@ -419,14 +419,13 @@ It includes all variables in list VARS."
(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 ")")))))
+ (unless (bolp)
+ (princ "\n"))
+ (princ " '(")
+ (prin1 symbol)
+ (princ " ")
+ (prin1 (custom-quote value))
+ (princ ")"))))
(if (bolp)
(princ " "))
(princ ")")
@@ -454,7 +453,7 @@ It includes all faces in list FACES."
;; Child is null if the widget is closed (hidden).
((widget-get widget :shown-value))
(t (custom-face-get-current-spec symbol)))))
- (when (and (facep symbol) value)
+ (when value
(princ (if (bolp) " '(" "\n '("))
(prin1 symbol)
(princ " ")
@@ -658,10 +657,12 @@ Theme files are named *-theme.el in `"))
(insert-file-contents fn)
(let ((sexp (let ((read-circle nil))
(condition-case nil
- (read (current-buffer))
- (end-of-file nil)))))
- (and (eq (car-safe sexp) 'deftheme)
- (setq doc (nth 2 sexp))))))))
+ (progn
+ (re-search-forward "^(deftheme")
+ (beginning-of-line)
+ (read (current-buffer)))
+ (error nil)))))
+ (setq doc (nth 2 sexp)))))))
(cond ((null doc)
"(no documentation available)")
((string-match ".*" doc)
diff --git a/lisp/custom.el b/lisp/custom.el
index 97cbd0eb5a2..f392bd8d369 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -117,30 +117,28 @@ For the standard setting, use `set-default'."
(set-default symbol (eval exp)))))))
(defvar custom-delayed-init-variables nil
- "List of variables whose initialization is pending.")
+ "List of variables whose initialization is pending until startup.
+Once this list has been processed, this var is set to a non-list value.")
-(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
context rather than the build-time context. This also has the
side-effect that the (delayed) initialization is performed with
-the :set function.
-
-For variables in preloaded files, you can simply use this
-function for the :initialize property. For autoloaded variables,
-you will also need to add an autoload stanza calling this
-function, and another one setting the standard-value property.
-Or you can wrap the defcustom in a progn, to force the autoloader
-to include all of it." ; see eg vc-sccs-search-project-dir
- ;; No longer true:
- ;; "See `send-mail-function' in sendmail.el for an example."
+the :set function."
+ ;; Defvar it so as to mark it special, etc (bug#25770).
+ (internal--define-uninitialized-variable symbol)
;; Until the var is actually initialized, it is kept unbound.
;; This seemed to be at least as good as setting it to an arbitrary
;; value like nil (evaluating `value' is not an option because it
;; may have undesirable side-effects).
- (push symbol custom-delayed-init-variables))
+ (if (listp custom-delayed-init-variables)
+ (push symbol custom-delayed-init-variables)
+ ;; In case this is called after startup, there is no "later" to which to
+ ;; delay it, so initialize it "normally" (bug#47072).
+ (custom-initialize-reset symbol value)))
(defun custom-declare-variable (symbol default doc &rest args)
"Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
@@ -161,7 +159,9 @@ set to nil, as the value is no longer rogue."
;; Whether automatically buffer-local.
buffer-local)
(unless (memq :group args)
- (custom-add-to-group (custom-current-group) symbol 'custom-variable))
+ (let ((cg (custom-current-group)))
+ (when cg
+ (custom-add-to-group cg symbol 'custom-variable))))
(while args
(let ((keyword (pop args)))
(unless (symbolp keyword)
@@ -207,7 +207,22 @@ set to nil, as the value is no longer rogue."
(put symbol 'custom-requests requests)
;; Do the actual initialization.
(unless custom-dont-initialize
- (funcall initialize symbol default))
+ (funcall initialize symbol default)
+ ;; If there is a value under saved-value that wasn't saved by the user,
+ ;; reset it: we used that property to stash the value, but we don't need
+ ;; it anymore.
+ ;; This can happen given the following:
+ ;; 1. The user loaded a theme that had a setting for an unbound
+ ;; variable, so we stashed the theme setting under the saved-value
+ ;; property in `custom-theme-recalc-variable'.
+ ;; 2. Then, Emacs evaluated the defcustom for the option
+ ;; (e.g., something required the file where the option is defined).
+ ;; If we don't reset it and the user later sets this variable via
+ ;; Customize, we might end up saving the theme setting in the custom-file.
+ ;; See the test `custom-test-no-saved-value-after-customizing-option'.
+ (let ((theme (caar (get symbol 'theme-value))))
+ (when (and theme (not (eq theme 'user)) (get symbol 'saved-value))
+ (put symbol 'saved-value nil))))
(when buffer-local
(make-variable-buffer-local symbol)))
(run-hooks 'custom-define-hook)
@@ -235,6 +250,8 @@ The following keywords are meaningful:
:type VALUE should be a widget type for editing the symbol's value.
Every `defcustom' should specify a value for this keyword.
+ See Info node `(elisp) Customization Types' for a list of
+ base types and useful composite types.
:options VALUE should be a list of valid members of the widget type.
:initialize
VALUE should be a function used to initialize the
@@ -353,7 +370,7 @@ for more information."
;; if you need to recompile all the Lisp files using interpreted code.
`(custom-declare-variable
',symbol
- ,(if lexical-binding ;FIXME: This is not reliable, but is all we have.
+ ,(if lexical-binding
;; The STANDARD arg should be an expression that evaluates to
;; the standard value. The use of `eval' for it is spread
;; over many different places and hence difficult to
@@ -525,7 +542,9 @@ If no such group is found, return nil."
"For customization option SYMBOL, handle keyword arguments ARGS.
Third argument TYPE is the custom option type."
(unless (memq :group args)
- (custom-add-to-group (custom-current-group) symbol type))
+ (let ((cg (custom-current-group)))
+ (when cg
+ (custom-add-to-group cg symbol type))))
(while args
(let ((arg (car args)))
(setq args (cdr args))
@@ -628,6 +647,10 @@ property, or (ii) an alias for another customizable variable."
(or (get variable 'standard-value)
(get variable 'custom-autoload))))
+(defun custom--standard-value (variable)
+ "Return the standard value of VARIABLE."
+ (eval (car (get variable 'standard-value)) t))
+
(define-obsolete-function-alias 'user-variable-p 'custom-variable-p "24.3")
(defun custom-note-var-changed (variable)
@@ -762,6 +785,9 @@ Return non-nil if the `customized-value' property actually changed."
(progn (put symbol 'customized-value (list (custom-quote value)))
(custom-push-theme 'theme-value symbol 'user 'set
(custom-quote value)))
+ (custom-push-theme 'theme-value symbol 'user
+ (if (get symbol 'saved-value) 'set 'reset)
+ (custom-quote value))
(put symbol 'customized-value nil))
;; Changed?
(not (equal customized (get symbol 'customized-value)))))
@@ -771,8 +797,7 @@ Return non-nil if the `customized-value' property actually changed."
Use the :set function to do so. This is useful for customizable options
that are defined before their standard value can really be computed.
E.g. dumped variables whose default depends on run-time information."
- ;; If it has never been set at all, defvar it so as to mark it
- ;; special, etc (bug#25770). This means we are initializing
+ ;; We are initializing
;; the variable, and normally any :set function would not apply.
;; For custom-initialize-delay, however, it is documented that "the
;; (delayed) initialization is performed with the :set function".
@@ -780,11 +805,10 @@ E.g. dumped variables whose default depends on run-time information."
;; custom-initialize-delay but needs the :set function custom-set-minor-mode
;; to also run during initialization. So, long story short, we
;; always do the funcall step, even if symbol was not bound before.
- (or (default-boundp symbol)
- (eval `(defvar ,symbol nil))) ; reset below, so any value is fine
(funcall (or (get symbol 'custom-set) #'set-default)
symbol
- (eval (car (or (get symbol 'saved-value) (get symbol 'standard-value))))))
+ (eval (car (or (get symbol 'saved-value)
+ (get symbol 'standard-value))))))
;;; Custom Themes
@@ -902,13 +926,21 @@ See `custom-known-themes' for a list of known themes."
;; the value to a fake theme, `changed'. If the theme is
;; later disabled, we use this to bring back the old value.
;;
- ;; For faces, we just use `face-new-frame-defaults' to
+ ;; For faces, we just use `face--new-frame-defaults' to
;; recompute when the theme is disabled.
(when (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))
+ (unless (or
+ ;; We only do this trick if the current value
+ ;; is different from the standard value.
+ (and sv (equal (eval (car sv)) val))
+ ;; And we don't do it if we would end up recording
+ ;; the same value for the user theme. This way we avoid
+ ;; having ((user VALUE) (changed VALUE)). That would be
+ ;; useless, because we don't disable the user theme.
+ (and (eq theme 'user) (equal (custom-quote val) value)))
(setq old `((changed ,(custom-quote val))))))))
(put symbol prop (cons (list theme value) old)))
(put theme 'theme-settings
@@ -1003,7 +1035,10 @@ COMMENT is a comment string about SYMBOL."
set)
(when requests
(put symbol 'custom-requests requests)
- (mapc #'require requests))
+ ;; Load any libraries that the setting has specified as
+ ;; being required, but don't error out if the package has
+ ;; been removed.
+ (mapc (lambda (lib) (require lib nil t)) requests))
(setq set (or (get symbol 'custom-set) #'custom-set-default))
(put symbol 'saved-value (list value))
(put symbol 'saved-variable-comment comment)
@@ -1185,6 +1220,32 @@ property `theme-feature' (which is usually a symbol created by
(custom-check-theme theme)
(provide (get theme 'theme-feature)))
+(defun require-theme (feature &optional noerror)
+ "Load FEATURE from a file along `custom-theme-load-path'.
+
+This function is like `require', but searches along
+`custom-theme-load-path' instead of `load-path'. It can be used
+by Custom themes to load supporting Lisp files when `require' is
+unsuitable.
+
+If FEATURE is not already loaded, search for a file named FEATURE
+with an added `.elc' or `.el' suffix, in that order, in the
+directories specified by `custom-theme-load-path'.
+
+Return FEATURE if the file is successfully found and loaded, or
+if FEATURE was already loaded. If the file fails to load, signal
+an error. If optional argument NOERROR is non-nil, return nil
+instead of signaling an error. If the file loads but does not
+provide FEATURE, signal an error. This cannot be suppressed."
+ (cond
+ ((featurep feature) feature)
+ ((let* ((path (custom-theme--load-path))
+ (file (locate-file (symbol-name feature) path '(".elc" ".el"))))
+ (and file (require feature (file-name-sans-extension file) noerror))))
+ ((not noerror)
+ (signal 'file-missing `("Cannot open load file" "No such file or directory"
+ ,(symbol-name feature))))))
+
(defcustom custom-safe-themes '(default)
"Themes that are considered safe to load.
If the value is a list, each element should be either the SHA-256
@@ -1369,13 +1430,36 @@ function runs. To disable other themes, use `disable-theme'."
obarray (lambda (sym) (get sym 'theme-settings)) t))))
(unless (custom-theme-p theme)
(error "Undefined Custom theme %s" theme))
- (let ((settings (get theme 'theme-settings)))
+ (let ((settings (get theme 'theme-settings)) ; '(prop symbol theme value)
+ ;; We are enabling the theme, so don't inhibit enabling it. (Bug#34027)
+ (custom--inhibit-theme-enable nil))
;; 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)))
+ (symbol (cadr s))
+ (spec-list (get symbol prop))
+ (sv (get symbol 'standard-value))
+ (val (and (boundp symbol) (symbol-value symbol))))
+ ;; We can't call `custom-push-theme' when enabling the theme: it's not
+ ;; that the theme settings have changed, it's just that we want to
+ ;; enable those settings. But we might need to save a user setting
+ ;; outside of Customize, in order to get back to it when disabling
+ ;; the theme, just like in `custom-push-theme'.
+ (when (and (custom--should-apply-setting theme)
+ ;; Only do it for variables; for faces, using
+ ;; `face-new-frame-defaults' is enough.
+ (eq prop 'theme-value)
+ (boundp symbol)
+ (not (or spec-list
+ ;; Only if the current value is different from
+ ;; the standard value.
+ (and sv (equal (eval (car sv)) val))
+ ;; And only if the changed value is different
+ ;; from the new value under the user theme.
+ (and (eq theme 'user)
+ (equal (custom-quote val) (nth 3 s))))))
+ (setq spec-list `((changed ,(custom-quote val)))))
+ (put symbol prop (cons (cddr s) (assq-delete-all theme spec-list)))
(cond
((eq prop 'theme-face)
(custom-theme-recalc-face symbol))
@@ -1444,10 +1528,18 @@ See `custom-enabled-themes' for a list of enabled themes."
(let* ((prop (car s))
(symbol (cadr s))
(val (assq-delete-all theme (get symbol prop))))
- (put symbol prop val)
+ (put symbol prop val)
(cond
((eq prop 'theme-value)
- (custom-theme-recalc-variable symbol))
+ (custom-theme-recalc-variable symbol)
+ ;; We might have to reset the stashed value of the variable, if
+ ;; no other theme is customizing it. Without this, loading a theme
+ ;; that has a setting for an unbound user option and then disabling
+ ;; it will leave this lingering setting for the option, and if then
+ ;; Emacs evaluates the defcustom the saved-value might be used to
+ ;; set the variable. (Bug#20766)
+ (unless (get symbol 'theme-value)
+ (put symbol 'saved-value nil)))
((eq prop 'theme-face)
;; If the face spec specified by this theme is in the
;; saved-face property, reset that property.
@@ -1496,8 +1588,16 @@ This function returns nil if no custom theme specifies a value for VARIABLE."
(defun custom-theme-recalc-variable (variable)
"Set VARIABLE according to currently enabled custom themes."
(let ((valspec (custom-variable-theme-value variable)))
- (if valspec
- (put variable 'saved-value valspec)
+ ;; We used to save VALSPEC under the saved-value property unconditionally,
+ ;; but that is a recipe for trouble because we might end up saving session
+ ;; customizations if the user loads a theme. (Bug#21355)
+ ;; It's better to only use the saved-value property to stash the value only
+ ;; if we really need to stash it (i.e., VARIABLE is void).
+ (condition-case nil
+ (default-toplevel-value variable) ; See if it doesn't fail.
+ (void-variable (when valspec
+ (put variable 'saved-value valspec))))
+ (unless valspec
(setq valspec (get variable 'standard-value)))
(if (and valspec
(or (get variable 'force-value)
@@ -1545,7 +1645,19 @@ Each of the arguments ARGS has this form:
This means reset VARIABLE. (The argument IGNORED is ignored)."
(apply #'custom-theme-reset-variables 'user args))
-;;; The End.
+(defun custom-add-choice (variable choice)
+ "Add CHOICE to the custom type of VARIABLE.
+If a choice with the same tag already exists, no action is taken."
+ (let ((choices (get variable 'custom-type)))
+ (unless (eq (car choices) 'choice)
+ (error "Not a choice type: %s" choices))
+ (unless (seq-find (lambda (elem)
+ (equal (caddr (member :tag elem))
+ (caddr (member :tag choice))))
+ (cdr choices))
+ ;; Put the new choice at the end.
+ (put variable 'custom-type
+ (append choices (list choice))))))
(provide 'custom)
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el
index ab2a832a060..e113cc94c33 100644
--- a/lisp/dabbrev.el
+++ b/lisp/dabbrev.el
@@ -45,7 +45,7 @@
;; dabbrev-case-replace nil t
;;
;; Set the variables you want special for your mode like this:
-;; (set (make-local-variable 'dabbrev-case-replace) nil)
+;; (setq-local dabbrev-case-replace nil)
;; Then you don't interfere with other modes.
;;
;; If your mode handles buffers that refers to other buffers
@@ -59,10 +59,10 @@
;; Example for GNUS (when we write a reply, we want dabbrev to look in
;; the article for expansion):
-;; (set (make-local-variable 'dabbrev-friend-buffer-function)
-;; (lambda (buffer)
-;; (with-current-buffer buffer
-;; (memq major-mode '(news-reply-mode gnus-article-mode)))))
+;; (setq-local dabbrev-friend-buffer-function
+;; (lambda (buffer)
+;; (with-current-buffer buffer
+;; (memq major-mode '(news-reply-mode gnus-article-mode)))))
;; Known bugs and limitations.
diff --git a/lisp/delim-col.el b/lisp/delim-col.el
index bd895c3e758..cd945d8de45 100644
--- a/lisp/delim-col.el
+++ b/lisp/delim-col.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Version: 2.1
+;; Old-Version: 2.1
;; Keywords: convenience text
;; X-URL: https://www.emacswiki.org/emacs/ViniciusJoseLatorre
diff --git a/lisp/delsel.el b/lisp/delsel.el
index 0e84695c62f..3c99dd2344c 100644
--- a/lisp/delsel.el
+++ b/lisp/delsel.el
@@ -84,9 +84,12 @@ information on adapting behavior of commands in Delete Selection mode."
(defvar delsel--replace-text-or-position nil)
+;;;###autoload
(defun delete-active-region (&optional killp)
"Delete the active region.
-If KILLP in not-nil, the active region is killed instead of deleted."
+If KILLP is non-nil, or if called interactively with a prefix argument,
+the active region is killed instead of deleted."
+ (interactive "P")
(cond
(killp
;; Don't allow `kill-region' to change the value of `this-command'.
@@ -105,7 +108,7 @@ If KILLP in not-nil, the active region is killed instead of deleted."
"Repeat replacing text of highlighted region with typed text.
Search for the next stretch of text identical to the region last replaced
by typing text over it and replaces it with the same stretch of text.
-With ARG, repeat that many times. `C-u' means until end of buffer."
+With ARG, repeat that many times. `\\[universal-argument]' means until end of buffer."
(interactive "P")
(let ((old-text (and delete-selection-save-to-register
(get-register delete-selection-save-to-register)))
@@ -217,6 +220,10 @@ With ARG, repeat that many times. `C-u' means until end of buffer."
(self-insert-command
(prefix-numeric-value current-prefix-arg))
(setq this-command 'ignore)))))
+ ;; If the user has quit here (for instance, if the user is
+ ;; presented with a "changed on disk; really edit the buffer?"
+ ;; prompt, but hit `C-g'), just ding.
+ (quit (ding))
;; If ask-user-about-supersession-threat signals an error,
;; stop safe_run_hooks from clearing out pre-command-hook.
(file-supersession (message "%s" (cadr data)) (ding))
@@ -270,6 +277,8 @@ to `delete-selection-mode'."
(put 'quoted-insert 'delete-selection t)
(put 'yank 'delete-selection 'yank)
+(put 'yank-pop 'delete-selection 'yank)
+(put 'yank-from-kill-ring 'delete-selection 'yank)
(put 'clipboard-yank 'delete-selection 'yank)
(put 'insert-register 'delete-selection t)
;; delete-backward-char and delete-forward-char already delete the selection by
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 31b7452448e..85017de5d5e 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -54,10 +54,12 @@
(<= (length pp) (- (window-width) (current-column))))
(insert pp)
(insert-text-button
- "[Show]" 'action (lambda (&rest _ignore)
- (with-output-to-temp-buffer
- "*Pp Eval Output*"
- (princ pp)))
+ "[Show]"
+ 'follow-link t
+ 'action (lambda (&rest _ignore)
+ (with-output-to-temp-buffer
+ "*Pp Eval Output*"
+ (princ pp)))
'help-echo "mouse-2, RET: pretty print value in another buffer"))))
(defun describe-property-list (properties)
@@ -141,8 +143,7 @@ otherwise."
(wid-field (get-char-property pos 'field))
(wid-button (get-char-property pos 'button))
(wid-doc (get-char-property pos 'widget-doc))
- ;; If button.el is not loaded, we have no buttons in the text.
- (button (and (fboundp 'button-at) (button-at pos)))
+ (button (button-at pos))
(button-type (and button (button-type button)))
(button-label (and button (button-label button)))
(widget (or wid-field wid-button wid-doc)))
@@ -211,7 +212,7 @@ multilingual development.
This is a fairly large file, not typically present on GNU systems.
At the time of writing it is at the URL
-`http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'."
+`https://www.unicode.org/Public/UNIDATA/UnicodeData.txt'."
:group 'mule
:version "22.1"
:type '(choice (const :tag "None" nil)
@@ -688,7 +689,8 @@ The character information includes:
(save-excursion (goto-char pos)
(looking-at-p "[ \t]+$")))
'trailing-whitespace)
- ((and nobreak-char-display char (eq char '#xa0))
+ ((and nobreak-char-display char
+ (eq (get-char-code-property char 'general-category) 'Zs))
'nobreak-space)
((and nobreak-char-display char
(memq char '(#xad #x2010 #x2011)))
@@ -763,6 +765,8 @@ The character information includes:
(to (nth 4 composition))
glyph)
(if (fontp font)
+ ;; GUI frame: show composition in terms of
+ ;; font glyphs and characters.
(progn
(insert " using this font:\n "
(symbol-name (font-get font :type))
@@ -772,12 +776,25 @@ The character information includes:
(while (and (<= from to)
(setq glyph (lgstring-glyph gstring from)))
(insert (format " %S\n" glyph))
- (setq from (1+ from))))
+ (setq from (1+ from)))
+ (when (and (stringp (car composition))
+ (string-match "\"\\([^\"]+\\)\"" (car composition)))
+ (insert "with these character(s):\n")
+ (let ((chars (match-string 1 (car composition))))
+ (dotimes (i (length chars))
+ (let ((char (aref chars i)))
+ (insert (format " %s (#x%x) %s\n"
+ (describe-char-padded-string char) char
+ (get-char-code-property
+ char 'name))))))))
+ ;; TTY frame: show composition in terms of characters.
(insert " by these characters:\n")
(while (and (<= from to)
(setq glyph (lgstring-glyph gstring from)))
- (insert (format " %c (#x%x)\n"
- (lglyph-char glyph) (lglyph-char glyph)))
+ (insert (format " %c (#x%x) %s\n"
+ (lglyph-char glyph) (lglyph-char glyph)
+ (get-char-code-property
+ (lglyph-char glyph) 'name)))
(setq from (1+ from)))))
(insert " by the rule:\n\t(")
(let ((first t))
@@ -919,7 +936,7 @@ condition, the function may return string longer than WIDTH, see
(t name)))))))
;;;###autoload
-(defun describe-char-eldoc ()
+(defun describe-char-eldoc (_callback &rest _)
"Return a description of character at point for use by ElDoc mode.
Return nil if character at point is a printable ASCII
@@ -929,10 +946,17 @@ Otherwise return a description formatted by
of `eldoc-echo-area-use-multiline-p' variable and width of
minibuffer window for width limit.
-This function is meant to be used as a value of
-`eldoc-documentation-function' variable."
+This function can be used as a value of
+`eldoc-documentation-functions' variable."
(let ((ch (following-char)))
(when (and (not (zerop ch)) (or (< ch 32) (> ch 127)))
+ ;; TODO: investigate if the new `eldoc-documentation-functions'
+ ;; API could significantly improve this. JT@2020-07-07: Indeed,
+ ;; instead of returning a string tailored here for the echo area
+ ;; exclusively, we could call the (now unused) argument
+ ;; _CALLBACK with hints on how to shorten the string if needed,
+ ;; or with multiple usable strings which ElDoc picks according
+ ;; to its space constraints.
(describe-char-eldoc--format
ch
(unless (eq eldoc-echo-area-use-multiline-p t)
diff --git a/lisp/desktop.el b/lisp/desktop.el
index f2afaed7ebf..3b257132163 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -344,7 +344,7 @@ to the value obtained by evaluating FORM."
Each element is a regular expression. Buffers with a name matched by any of
these won't be deleted."
:version "23.3" ; added Warnings - bug#6336
- :type '(repeat string)
+ :type '(repeat regexp)
:group 'desktop)
;;;###autoload
@@ -534,7 +534,7 @@ can guess how to load the mode's definition.")
'((defining-kbd-macro nil)
(isearch-mode nil)
(vc-mode nil)
- (vc-dired-mode nil)
+ (vc-dir-mode nil)
(erc-track-minor-mode nil)
(savehist-mode nil))
"Table mapping minor mode variables to minor mode functions.
@@ -706,8 +706,9 @@ if different)."
"\\)\\'")))
(dolist (buffer (buffer-list))
(let ((bufname (buffer-name buffer)))
- (unless (or (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers
- (string-match-p preserve-regexp bufname))
+ (unless (or (null bufname)
+ (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers
+ (string-match-p preserve-regexp bufname))
(kill-buffer buffer)))))
(delete-other-windows)
(when (and desktop-restore-frames
@@ -731,7 +732,7 @@ if different)."
;; ----------------------------------------------------------------------------
(unless noninteractive
- (add-hook 'kill-emacs-hook #'desktop-kill))
+ (add-hook 'kill-emacs-query-functions #'desktop-kill))
(defun desktop-kill ()
"If `desktop-save-mode' is non-nil, do what `desktop-save' says to do.
@@ -759,7 +760,11 @@ is nil, ask the user where to save the desktop."
(unless (yes-or-no-p "Error while saving the desktop. Ignore? ")
(signal (car err) (cdr err))))))
;; If we own it, we don't anymore.
- (when (eq (emacs-pid) (desktop-owner)) (desktop-release-lock)))
+ (when (eq (emacs-pid) (desktop-owner))
+ ;; Allow exiting Emacs even if we can't delete the desktop file.
+ (ignore-error 'file-error
+ (desktop-release-lock)))
+ t)
;; ----------------------------------------------------------------------------
(defun desktop-list* (&rest args)
@@ -1222,7 +1227,13 @@ This function is a no-op when Emacs is running in batch mode.
It returns t if a desktop file was loaded, nil otherwise.
\n(fn DIRNAME)"
(interactive "i\nP")
- (unless noninteractive
+ (if (or noninteractive
+ (and (desktop-owner)
+ (= (desktop-owner) (emacs-pid))))
+ (message "Not reloading the desktop%s"
+ (if noninteractive
+ ""
+ "; already loaded"))
(setq desktop-dirname
(file-name-as-directory
(expand-file-name
diff --git a/lisp/dframe.el b/lisp/dframe.el
index 305d79df108..1ddf11a8aac 100644
--- a/lisp/dframe.el
+++ b/lisp/dframe.el
@@ -1,13 +1,10 @@
-;;; dframe --- dedicate frame support modes -*- lexical-binding:t -*-
+;;; dframe.el --- dedicate frame support modes -*- lexical-binding:t -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
-(defvar dframe-version "1.3"
- "The current version of the dedicated frame library.")
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -149,42 +146,35 @@ selected frame and the focus will change to that frame."
:group 'dframe
:type 'hook)
-(defvar dframe-track-mouse-function nil
+(defvar-local dframe-track-mouse-function nil
"A function to call when the mouse is moved in the given frame.
Typically used to display info about the line under the mouse.")
-(make-variable-buffer-local 'dframe-track-mouse-function)
-(defvar dframe-help-echo-function nil
+(defvar-local dframe-help-echo-function nil
"A function to call when help-echo is used in newer versions of Emacs.
Typically used to display info about the line under the mouse.")
-(make-variable-buffer-local 'dframe-help-echo-function)
-(defvar dframe-mouse-click-function nil
+(defvar-local dframe-mouse-click-function nil
"A function to call when the mouse is clicked.
Valid clicks are mouse 2, our double mouse 1.")
-(make-variable-buffer-local 'dframe-mouse-click-function)
-(defvar dframe-mouse-position-function nil
+(defvar-local dframe-mouse-position-function nil
"A function to call to position the cursor for a mouse click.")
-(make-variable-buffer-local 'dframe-mouse-position-function)
(defvar dframe-power-click nil
"Never set this by hand. Value is t when S-mouse activity occurs.")
-(defvar dframe-timer nil
+(defvar-local dframe-timer nil
"The dframe timer used for updating the buffer.")
-(make-variable-buffer-local 'dframe-timer)
-(defvar dframe-attached-frame nil
+(defvar-local dframe-attached-frame nil
"The frame which started a frame mode.
This is the frame from which all interesting activities will go
for the mode using dframe.")
-(make-variable-buffer-local 'dframe-attached-frame)
-(defvar dframe-controlled nil
+(defvar-local dframe-controlled nil
"Is this buffer controlled by a dedicated frame.
Local to those buffers, as a function called that created it.")
-(make-variable-buffer-local 'dframe-controlled)
(defun dframe-update-keymap (map)
"Update the keymap MAP for dframe default bindings."
@@ -279,17 +269,18 @@ CREATE-HOOK is a hook to run after creating a frame."
;; Enable mouse tracking in emacs
(if dframe-track-mouse-function
- (set (make-local-variable 'track-mouse) t)) ;this could be messy.
+ (setq-local track-mouse t)) ;this could be messy.
;; Override `temp-buffer-show-hook' so that help and such
;; put their stuff into a frame other than our own.
;; Correct use of `temp-buffer-show-function': Bob Weiner
(if (and (boundp 'temp-buffer-show-hook)
(boundp 'temp-buffer-show-function))
- (progn (make-local-variable 'temp-buffer-show-hook)
- (setq temp-buffer-show-hook temp-buffer-show-function)))
- (make-local-variable 'temp-buffer-show-function)
- (setq temp-buffer-show-function 'dframe-temp-buffer-show-function)
+ ;; FIXME: Doesn't this get us into an inf-loop when the
+ ;; `temp-buffer-show-function' runs `temp-buffer-show-hook'
+ ;; (as is normally the case)?
+ (setq-local temp-buffer-show-hook temp-buffer-show-function))
+ (setq-local temp-buffer-show-function 'dframe-temp-buffer-show-function)
;; If this buffer is killed, we must make sure that we destroy
;; the frame the dedicated window is in.
(add-hook 'kill-buffer-hook (lambda ()
@@ -684,28 +675,26 @@ Evaluates all cached timer functions in sequence."
(funcall (car l)))
(setq l (cdr l)))))
-(defalias 'dframe-popup-kludge
- (lambda (e)
- "Pop up a menu related to the clicked on item.
+(defun dframe-popup-kludge (e)
+ "Pop up a menu related to the clicked on item.
Must be bound to event E."
- (interactive "e")
- (save-excursion
- (mouse-set-point e)
- ;; This gets the cursor where the user can see it.
- (if (not (bolp)) (forward-char -1))
- (sit-for 0)
- (popup-menu (mouse-menu-major-mode-map) e))))
+ (interactive "e")
+ (save-excursion
+ (mouse-set-point e)
+ ;; This gets the cursor where the user can see it.
+ (if (not (bolp)) (forward-char -1))
+ (sit-for 0)
+ (popup-menu (mouse-menu-major-mode-map) e)))
;;; Interactive user functions for the mouse
;;
-(defalias 'dframe-mouse-event-p
- (lambda (event)
- "Return t if the event is a mouse related event."
- (if (and (listp event)
- (member (event-basic-type event)
- '(mouse-1 mouse-2 mouse-3)))
- t
- nil)))
+(defun dframe-mouse-event-p (event)
+ "Return t if the event is a mouse related event."
+ (if (and (listp event)
+ (member (event-basic-type event)
+ '(mouse-1 mouse-2 mouse-3)))
+ t
+ nil))
(defun dframe-track-mouse (event)
"For motion EVENT, display info about the current line."
@@ -834,6 +823,13 @@ the mode-line."
(t (dframe-message
"Click on the edge of the mode line to scroll left/right")))))
+
+;;; Obsolete
+
+(defvar dframe-version "1.3"
+ "The current version of the dedicated frame library.")
+(make-obsolete-variable 'dframe-version 'emacs-version "28.1")
+
(provide 'dframe)
;;; dframe.el ends here
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 6c7908118a8..060f3a84111 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -33,6 +33,7 @@
;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>.
;; Finished up by rms in 1992.
+
;;; Code:
(require 'cl-lib)
@@ -45,9 +46,8 @@
Functions that operate recursively can store additional names
into this list; they also should call `dired-log' to log the errors.")
-;;; 15K
-;;;###begin dired-cmd.el
-;; Diffing and compressing
+
+;;; Diffing and compressing
(defconst dired-star-subst-regexp "\\(^\\|[ \t]\\)\\*\\([ \t]\\|$\\)")
(defconst dired-quark-subst-regexp "\\(^\\|[ \t]\\)\\?\\([ \t]\\|$\\)")
@@ -60,24 +60,132 @@ Isolated means that STRING is surrounded by spaces or at the beginning/end
of a string followed/prefixed with an space.
The regexp capture the preceding blank, STRING and the following blank as
the groups 1, 2 and 3 respectively."
- (format "\\(\\`\\|[ \t]\\)\\(%s\\)\\([ \t]\\|\\'\\)" string))
+ (format "\\(?1:\\`\\|[ \t]\\)\\(?2:%s\\)\\(?3:[ \t]\\|\\'\\)" string))
-(defun dired--star-or-qmark-p (string match &optional keep)
+(defun dired--star-or-qmark-p (string match &optional keep start)
"Return non-nil if STRING contains isolated MATCH or `\\=`?\\=`'.
MATCH should be the strings \"?\", `\\=`?\\=`', \"*\" or nil. The latter
means STRING contains either \"?\" or `\\=`?\\=`' or \"*\".
If optional arg KEEP is non-nil, then preserve the match data. Otherwise,
this function changes it and saves MATCH as the second match group.
+START is the position to start matching from.
Isolated means that MATCH is surrounded by spaces or at the beginning/end
of STRING followed/prefixed with an space. A match to `\\=`?\\=`',
isolated or not, is also valid."
- (let ((regexps (list (dired-isolated-string-re (if match (regexp-quote match) "[*?]")))))
+ (let ((regexp (dired-isolated-string-re (if match (regexp-quote match) "[*?]"))))
(when (or (null match) (equal match "?"))
- (setq regexps (append (list "\\(\\)\\(`\\?`\\)\\(\\)") regexps)))
- (cl-some (lambda (x)
- (funcall (if keep #'string-match-p #'string-match) x string))
- regexps)))
+ (cl-callf concat regexp "\\|\\(?1:\\)\\(?2:`\\?`\\)\\(?3:\\)"))
+ (funcall (if keep #'string-match-p #'string-match) regexp string start)))
+
+(defun dired--need-confirm-positions (command string)
+ "Search for non-isolated matches of STRING in COMMAND.
+Return a list of positions that match STRING, but would not be
+considered \"isolated\" by `dired--star-or-qmark-p'."
+ (cl-assert (= (length string) 1))
+ (let ((start 0)
+ (isolated-char-positions nil)
+ (confirm-positions nil)
+ (regexp (regexp-quote string)))
+ ;; Collect all ? and * surrounded by spaces and `?`.
+ (while (dired--star-or-qmark-p command string nil start)
+ (push (cons (match-beginning 2) (match-end 2))
+ isolated-char-positions)
+ (setq start (match-end 2)))
+ ;; Now collect any remaining ? and *.
+ (setq start 0)
+ (while (string-match regexp command start)
+ (unless (cl-member (match-beginning 0) isolated-char-positions
+ :test (lambda (pos match)
+ (<= (car match) pos (cdr match))))
+ (push (match-beginning 0) confirm-positions))
+ (setq start (match-end 0)))
+ confirm-positions))
+
+(defun dired--mark-positions (positions)
+ (let ((markers (make-string
+ (1+ (apply #'max positions))
+ ?\s)))
+ (dolist (pos positions)
+ (setf (aref markers pos) ?^))
+ markers))
+
+(defun dired--highlight-no-subst-chars (positions command mark)
+ (cl-callf substring-no-properties command)
+ (dolist (pos positions)
+ (add-face-text-property pos (1+ pos) 'warning nil command))
+ (if mark
+ (concat command "\n" (dired--mark-positions positions))
+ command))
+
+(defun dired--no-subst-explain (buf char-positions command mark-positions)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert
+ (format-message "\
+If your command contains occurrences of `*' surrounded by
+whitespace, `dired-do-shell-command' substitutes them for the
+entire file list to process. Otherwise, if your command contains
+occurrences of `?' surrounded by whitespace or `%s', Dired will
+run the command once for each file, substituting `?' for each
+file name.
+
+Your command contains occurrences of `%s' that will not be
+substituted, and will be passed through normally to the shell.
+
+%s
+
+\(Press ^ to %s markers below these occurrences.)
+"
+ "`"
+ (string (aref command (car char-positions)))
+ (dired--highlight-no-subst-chars char-positions command mark-positions)
+ (if mark-positions "remove" "add")))))
+
+(defun dired--no-subst-ask (char nb-occur details)
+ (let ((hilit-char (propertize (string char) 'face 'warning))
+ (choices `(?y ?n ?? ,@(when details '(?^)))))
+ (read-char-choice
+ (format-message
+ (ngettext
+ "%d occurrence of `%s' will not be substituted. Proceed? (%s) "
+ "%d occurrences of `%s' will not be substituted. Proceed? (%s) "
+ nb-occur)
+ nb-occur hilit-char (mapconcat #'string choices ", "))
+ choices)))
+
+(defun dired--no-subst-confirm (char-positions command)
+ (let ((help-buf (get-buffer-create "*Dired help*"))
+ (char (aref command (car char-positions)))
+ (nb-occur (length char-positions))
+ (done nil)
+ (details nil)
+ (markers nil)
+ proceed)
+ (unwind-protect
+ (save-window-excursion
+ (while (not done)
+ (cl-case (dired--no-subst-ask char nb-occur details)
+ (?y
+ (setq done t
+ proceed t))
+ (?n
+ (setq done t
+ proceed nil))
+ (??
+ (if details
+ (progn
+ (quit-window nil details)
+ (setq details nil))
+ (dired--no-subst-explain
+ help-buf char-positions command markers)
+ (setq details (display-buffer help-buf))))
+ (?^
+ (setq markers (not markers))
+ (dired--no-subst-explain
+ help-buf char-positions command markers)))))
+ (kill-buffer help-buf))
+ proceed))
;;;###autoload
(defun dired-diff (file &optional switches)
@@ -134,16 +242,27 @@ the string of command switches used as the third argument of `diff'."
(file-name-directory default)
(dired-current-directory))
(dired-dwim-target-directory)))
- (defaults (dired-dwim-target-defaults (list current) target-dir)))
+ (defaults (append
+ (if (backup-file-name-p current)
+ ;; This is a backup file -- put the other
+ ;; main file, and the other backup files into
+ ;; the `M-n' list.
+ (delete (expand-file-name current)
+ (cons (expand-file-name
+ (file-name-sans-versions current))
+ (file-backup-file-names
+ (file-name-sans-versions current))))
+ ;; Non-backup file -- use the backup files as
+ ;; `M-n' candidates.
+ (file-backup-file-names current))
+ (dired-dwim-target-defaults (list current) target-dir))))
(list
(minibuffer-with-setup-hook
(lambda ()
- (set (make-local-variable 'minibuffer-default-add-function) nil)
+ (setq-local minibuffer-default-add-function nil)
(setq minibuffer-default defaults))
- (read-file-name
- (format "Diff %s with%s: " current
- (if default (format " (default %s)" default) ""))
- target-dir default t))
+ (read-file-name (format-prompt "Diff %s with" default current)
+ target-dir default t))
(if current-prefix-arg
(read-string "Options for diff: "
(if (stringp diff-switches)
@@ -169,12 +288,12 @@ If this file is a backup, diff it with its original.
The backup file is the first file given to `diff'.
With prefix arg, prompt for argument SWITCHES which is options for `diff'."
(interactive
- (if current-prefix-arg
- (list (read-string "Options for diff: "
- (if (stringp diff-switches)
- diff-switches
- (mapconcat #'identity diff-switches " "))))
- nil))
+ (if current-prefix-arg
+ (list (read-string "Options for diff: "
+ (if (stringp diff-switches)
+ diff-switches
+ (mapconcat #'identity diff-switches " "))))
+ nil))
(diff-backup (dired-get-filename) switches))
;;;###autoload
@@ -205,14 +324,17 @@ Examples of PREDICATE:
(not (and (= (file-attribute-user-id fa1) - mark files with different UID
(file-attribute-user-id fa2))
(= (file-attribute-group-id fa1) - and GID.
- (file-attribute-group-id fa2))))"
+ (file-attribute-group-id fa2))))
+
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil."
(interactive
(list
(let* ((target-dir (dired-dwim-target-directory))
(defaults (dired-dwim-target-defaults nil target-dir)))
(minibuffer-with-setup-hook
(lambda ()
- (set (make-local-variable 'minibuffer-default-add-function) nil)
+ (setq-local minibuffer-default-add-function nil)
(setq minibuffer-default defaults))
(read-directory-name (format "Compare %s with: "
(dired-current-directory))
@@ -296,6 +418,7 @@ List has a form of (file-name full-file-name (attribute-list))."
full-file-name
(file-attributes full-file-name))))
(directory-files dir)))
+
;;; Change file attributes
@@ -409,7 +532,8 @@ has no effect on MS-Windows."
(set-file-modes
file
(if num-modes num-modes
- (file-modes-symbolic-to-number modes (file-modes file)))))
+ (file-modes-symbolic-to-number modes (file-modes file 'nofollow)))
+ 'nofollow))
(dired-do-redisplay arg)))
;;;###autoload
@@ -513,7 +637,7 @@ Uses the shell command coming from variables `lpr-command' and
(dired-run-shell-command (dired-shell-stuff-it command file-list nil))))
(defun dired-mark-read-string (prompt initial op-symbol arg files
- &optional default-value collection)
+ &optional default-value collection)
"Read args for a Dired marked-files command, prompting with PROMPT.
Return the user input (a string).
@@ -532,8 +656,9 @@ passed as the second arg to `completing-read'."
'completing-read
(format prompt (dired-mark-prompt arg files))
collection nil nil initial nil default-value nil))
+
-;;; Cleaning a directory: flagging some backups for deletion.
+;;; Cleaning a directory: flagging some backups for deletion
(defvar dired-file-version-alist)
@@ -576,7 +701,8 @@ with a prefix argument."
(dired-map-dired-file-lines #'dired-trample-file-versions)
(message "Cleaning numerical backups...done")))
-;;; Subroutines of dired-clean-directory.
+
+;;; Subroutines of dired-clean-directory
(defun dired-map-dired-file-lines (fun)
;; Perform FUN with point at the end of each non-directory line.
@@ -627,6 +753,7 @@ with a prefix argument."
(progn (beginning-of-line)
(delete-char 1)
(insert dired-del-marker)))))
+
;;; Shell commands
@@ -684,7 +811,7 @@ are executed in the background on each file sequentially waiting
for each command to terminate before running the next command.
In shell syntax this means separating the individual commands with `;'.
-The output appears in the buffer `*Async Shell Command*'."
+The output appears in the buffer named by `shell-command-buffer-name-async'."
(interactive
(let ((files (dired-get-marked-files t current-prefix-arg nil nil t)))
(list
@@ -722,16 +849,16 @@ it, write `*\"\"' in place of just `*'. This is equivalent to just
`*' in the shell, but avoids Dired's special handling.
If COMMAND ends in `&', `;', or `;&', it is executed in the
-background asynchronously, and the output appears in the buffer
-`*Async Shell Command*'. When operating on multiple files and COMMAND
-ends in `&', the shell command is executed on each file in parallel.
-However, when COMMAND ends in `;' or `;&' then commands are executed
-in the background on each file sequentially waiting for each command
-to terminate before running the next command. You can also use
-`dired-do-async-shell-command' that automatically adds `&'.
+background asynchronously, and the output appears in the buffer named
+by `shell-command-buffer-name-async'. When operating on multiple files
+and COMMAND ends in `&', the shell command is executed on each file
+in parallel. However, when COMMAND ends in `;' or `;&', then commands
+are executed in the background on each file sequentially waiting for
+each command to terminate before running the next command. You can
+also use `dired-do-async-shell-command' that automatically adds `&'.
Otherwise, COMMAND is executed synchronously, and the output
-appears in the buffer `*Shell Command Output*'.
+appears in the buffer named by `shell-command-buffer-name'.
This feature does not try to redisplay Dired buffers afterward, as
there's no telling what files COMMAND may have changed.
@@ -748,8 +875,8 @@ can be produced by `dired-get-marked-files', for example.
`dired-guess-shell-alist-default' and
`dired-guess-shell-alist-user' are consulted when the user is
prompted for the shell command to use interactively."
-;;Functions dired-run-shell-command and dired-shell-stuff-it do the
-;;actual work and can be redefined for customization.
+ ;; Functions dired-run-shell-command and dired-shell-stuff-it do the
+ ;; actual work and can be redefined for customization.
(interactive
(let ((files (dired-get-marked-files t current-prefix-arg nil nil t)))
(list
@@ -757,28 +884,19 @@ prompted for the shell command to use interactively."
(dired-read-shell-command "! on %s: " current-prefix-arg files)
current-prefix-arg
files)))
- (cl-flet ((need-confirm-p
- (cmd str)
- (let ((res cmd)
- (regexp (regexp-quote str)))
- ;; Drop all ? and * surrounded by spaces and `?`.
- (while (and (string-match regexp res)
- (dired--star-or-qmark-p res str))
- (setq res (replace-match "" t t res 2)))
- (string-match regexp res))))
(let* ((on-each (not (dired--star-or-qmark-p command "*" 'keep)))
(no-subst (not (dired--star-or-qmark-p command "?" 'keep)))
+ (confirmations nil)
;; Get confirmation for wildcards that may have been meant
;; to control substitution of a file name or the file name list.
- (ok (cond ((not (or on-each no-subst))
- (error "You can not combine `*' and `?' substitution marks"))
- ((need-confirm-p command "*")
- (y-or-n-p (format-message
- "Confirm--do you mean to use `*' as a wildcard? ")))
- ((need-confirm-p command "?")
- (y-or-n-p (format-message
- "Confirm--do you mean to use `?' as a wildcard? ")))
- (t))))
+ (ok (cond
+ ((not (or on-each no-subst))
+ (error "You can not combine `*' and `?' substitution marks"))
+ ((setq confirmations (dired--need-confirm-positions command "*"))
+ (dired--no-subst-confirm confirmations command))
+ ((setq confirmations (dired--need-confirm-positions command "?"))
+ (dired--no-subst-confirm confirmations command))
+ (t))))
(cond ((not ok) (message "Command canceled"))
(t
(if on-each
@@ -789,7 +907,7 @@ prompted for the shell command to use interactively."
nil file-list)
;; execute the shell command
(dired-run-shell-command
- (dired-shell-stuff-it command file-list nil arg))))))))
+ (dired-shell-stuff-it command file-list nil arg)))))))
;; Might use {,} for bash or csh:
(defvar dired-mark-prefix ""
@@ -800,13 +918,13 @@ prompted for the shell command to use interactively."
"Separates marked files in dired shell commands.")
(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.
-;; FILE-LIST's elements will be quoted for the shell."
-;; Might be redefined for smarter things and could then use RAW-ARG
-;; (coming from interactive P and currently ignored) to decide what to do.
-;; Smart would be a way to access basename or extension of file names.
+ ;; "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.
+ ;; FILE-LIST's elements will be quoted for the shell."
+ ;; Might be redefined for smarter things and could then use RAW-ARG
+ ;; (coming from interactive P and currently ignored) to decide what to do.
+ ;; Smart would be a way to access basename or extension of file names.
(let* ((in-background (string-match "[ \t]*&[ \t]*\\'" command))
(command (if in-background
(substring command 0 (match-beginning 0))
@@ -872,8 +990,8 @@ prompted for the shell command to use interactively."
(shell-command command)))
;; Return nil for sake of nconc in dired-bunch-files.
nil)
-
+
(defun dired-check-process (msg program &rest arguments)
"Display MSG while running PROGRAM, and check for output.
Remaining arguments are strings passed as command arguments to PROGRAM.
@@ -918,8 +1036,9 @@ Return the result of `process-file' - zero for success."
(unless (zerop res)
(pop-to-buffer out-buffer))
res))))
+
-;; Commands that delete or redisplay part of the dired buffer.
+;;; Commands that delete or redisplay part of the dired buffer
(defun dired-kill-line (&optional arg)
"Kill the current line (not the files).
@@ -948,14 +1067,18 @@ With a prefix argument, kill that many lines starting with the current line.
"Kill all marked lines (not the files).
With a prefix argument, kill that many lines starting with the current line.
\(A negative argument kills backward.)
+
If you use this command with a prefix argument to kill the line
for a file that is a directory, which you have inserted in the
Dired buffer as a subdirectory, then it deletes that subdirectory
from the buffer as well.
+
To kill an entire subdirectory \(without killing its line in the
parent directory), go to its directory header line and use this
command with a prefix argument (the value does not matter).
+To undo the killing, the undo command can be used as normally.
+
This function returns the number of killed lines.
FMT is a format string used for messaging the user about the
@@ -980,10 +1103,8 @@ present. A FMT of \"\" will suppress the messaging."
(message (or fmt "Killed %d line%s.") count (dired-plural-s count)))
count))))
-;;;###end dired-cmd.el
-;;; 30K
-;;;###begin dired-cp.el
+;;; Compression
(defun dired-compress ()
;; Compress or uncompress the current file.
@@ -1011,9 +1132,10 @@ present. A FMT of \"\" will suppress the messaging."
(defvar dired-compress-file-suffixes
'(
;; "tar -zxf" isn't used because it's not available on the
- ;; Solaris10 version of tar. Solaris10 becomes obsolete in 2021.
- ;; Same thing on AIX 7.1.
+ ;; Solaris 10 version of tar (obsolete in 2024?).
+ ;; Same thing on AIX 7.1 (obsolete 2023?) and 7.2 (obsolete 2022?).
("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -")
+ ("\\.tar\\.xz\\'" "" "xz -dc %i | tar -xf -")
("\\.tgz\\'" "" "gzip -dc %i | tar -xf -")
("\\.gz\\'" "" "gunzip")
("\\.lz\\'" "" "lzip -d")
@@ -1031,10 +1153,7 @@ present. A FMT of \"\" will suppress the messaging."
("\\.zst\\'" "" "unzstd --rm")
("\\.7z\\'" "" "7z x -aoa -o%o %i")
;; This item controls naming for compression.
- ("\\.tar\\'" ".tgz" nil)
- ;; This item controls the compression of directories. Its REGEXP
- ;; element should never match any valid file name.
- ("\000" ".tar.gz" "tar -cf - %i | gzip -c9 > %o"))
+ ("\\.tar\\'" ".tgz" nil))
"Control changes in file name suffixes for compression and uncompression.
Each element specifies one transformation rule, and has the form:
(REGEXP NEW-SUFFIX PROGRAM)
@@ -1050,22 +1169,51 @@ output file.
Otherwise, the rule is a compression rule, and compression is done with gzip.
ARGS are command switches passed to PROGRAM.")
+(defcustom dired-compress-file-default-suffix nil
+ "Default suffix for compressing a single file.
+If nil, \".gz\" will be used."
+ :type '(choice (const :tag ".gz" nil) string)
+ :group 'dired
+ :version "28.1")
+
+(defvar dired-compress-file-alist
+ '(("\\.gz\\'" . "gzip -9f %i")
+ ("\\.bz2\\'" . "bzip2 -9f %i")
+ ("\\.xz\\'" . "xz -9f %i")
+ ("\\.zst\\'" . "zstd -qf -19 --rm -o %o %i"))
+ "Controls the compression shell command for `dired-do-compress-to'.
+
+Each element is (REGEXP . CMD), where REGEXP is the name of the
+archive to which you want to compress, and CMD is the
+corresponding command.
+
+Within CMD, %i denotes the input file(s), and %o denotes the
+output file. %i path(s) are relative, while %o is absolute.")
+
+(defcustom dired-compress-directory-default-suffix nil
+ "Default suffix for compressing a directory.
+If nil, \".tar.gz\" will be used."
+ :type '(choice (const :tag ".tar.gz" nil) string)
+ :group 'dired
+ :version "28.1")
+
(defvar dired-compress-files-alist
'(("\\.tar\\.gz\\'" . "tar -cf - %i | gzip -c9 > %o")
("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o")
("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o")
("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o")
- ("\\.zip\\'" . "zip %o -r --filesync %i"))
- "Control the compression shell command for `dired-do-compress-to'.
+ ("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o")
+ ("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o")
+ ("\\.zip\\'" . "zip %o -r --filesync %i")
+ ("\\.pax\\'" . "pax -wf %o %i"))
+ "Controls the compression shell command for `dired-do-compress-to'.
Each element is (REGEXP . CMD), where REGEXP is the name of the
archive to which you want to compress, and CMD is the
corresponding command.
Within CMD, %i denotes the input file(s), and %o denotes the
-output file. %i path(s) are relative, while %o is absolute.")
-
-(declare-function format-spec "format-spec.el" (format specification))
+output file. %i path(s) are relative, while %o is absolute.")
;;;###autoload
(defun dired-do-compress-to ()
@@ -1074,7 +1222,6 @@ Prompt for the archive file name.
Choose the archiving command based on the archive file-name extension
and `dired-compress-files-alist'."
(interactive)
- (require 'format-spec)
(let* ((in-files (dired-get-marked-files nil nil nil nil t))
(out-file (expand-file-name (read-file-name "Compress to: ")))
(rule (cl-find-if
@@ -1094,12 +1241,12 @@ and `dired-compress-files-alist'."
(when (zerop
(dired-shell-command
(format-spec (cdr rule)
- `((?\o . ,(shell-quote-argument out-file))
- (?\i . ,(mapconcat
- (lambda (file-desc)
- (shell-quote-argument (file-name-nondirectory
- file-desc)))
- in-files " "))))))
+ `((?o . ,(shell-quote-argument out-file))
+ (?i . ,(mapconcat
+ (lambda (in-file)
+ (shell-quote-argument
+ (file-name-nondirectory in-file)))
+ in-files " "))))))
(message (ngettext "Compressed %d file to %s"
"Compressed %d files to %s"
(length in-files))
@@ -1157,37 +1304,62 @@ Return nil if no change in files."
;; Try gzip; if we don't have that, use compress.
(condition-case nil
(if (file-directory-p file)
- (progn
- (setq suffix (cdr (assoc "\000" dired-compress-file-suffixes)))
- (when suffix
- (let ((out-name (concat file (car suffix)))
- (default-directory (file-name-directory file)))
- (dired-shell-command
- (replace-regexp-in-string
- "%o" (shell-quote-argument out-name)
+ (let* ((suffix
+ (or dired-compress-directory-default-suffix
+ ".tar.gz"))
+ (rule (cl-find-if
+ (lambda (x) (string-match-p (car x) suffix))
+ dired-compress-files-alist)))
+ (if rule
+ (let ((out-name (concat file suffix))
+ (default-directory (file-name-directory file)))
+ (dired-shell-command
+ (replace-regexp-in-string
+ "%o" (shell-quote-argument out-name)
+ (replace-regexp-in-string
+ "%i" (shell-quote-argument
+ (file-name-nondirectory file))
+ (cdr rule)
+ nil t)
+ nil t))
+ out-name)
+ (user-error
+ "No compression rule found for \
+`dired-compress-directory-default-suffix' %s, see `dired-compress-files-alist' for\
+ the supported suffixes list."
+ dired-compress-directory-default-suffix)))
+ (let* ((suffix (or dired-compress-file-default-suffix ".gz"))
+ (out-name (concat file suffix))
+ (rule (cl-find-if
+ (lambda (x) (string-match-p (car x) suffix))
+ dired-compress-file-alist)))
+ (if (not rule)
+ (user-error "No compression rule found for suffix %s, \
+see `dired-compress-file-alist' for the supported suffixes list."
+ dired-compress-file-default-suffix)
+ (and (file-exists-p file)
+ (or (not (file-exists-p out-name))
+ (y-or-n-p
+ (format
+ "File %s already exists. Really compress? "
+ out-name)))
+ (dired-shell-command
(replace-regexp-in-string
- "%i" (shell-quote-argument (file-name-nondirectory file))
- (cadr suffix)
- nil t)
- nil t))
- out-name)))
- (let ((out-name (concat file ".gz")))
- (and (or (not (file-exists-p out-name))
- (y-or-n-p
- (format "File %s already exists. Really compress? "
- out-name)))
- (not
- (dired-check-process (concat "Compressing " file)
- "gzip" "-f" file))
- (or (file-exists-p out-name)
- (setq out-name (concat file ".z")))
- ;; Rename the compressed file to NEWNAME
- ;; if it hasn't got that name already.
- (if (and newname (not (equal newname out-name)))
- (progn
- (rename-file out-name newname t)
- newname)
- out-name))))
+ "%o" (shell-quote-argument out-name)
+ (replace-regexp-in-string
+ "%i" (shell-quote-argument file)
+ (cdr rule)
+ nil t)
+ nil t))
+ (or (file-exists-p out-name)
+ (setq out-name (concat file ".z")))
+ ;; Rename the compressed file to NEWNAME
+ ;; if it hasn't got that name already.
+ (if (and newname (not (equal newname out-name)))
+ (progn
+ (rename-file out-name newname t)
+ newname)
+ out-name)))))
(file-error
(if (not (dired-check-process (concat "Compressing " file)
"compress" "-f" file))
@@ -1213,19 +1385,19 @@ Return nil if no change in files."
(dired-mark-prompt arg files) "? ")))))
(defun dired-map-over-marks-check (fun arg op-symbol &optional show-progress)
-; "Map FUN over marked files (with second ARG like in dired-map-over-marks)
-; and display failures.
+ ;; "Map FUN over marked files (with second ARG like in dired-map-over-marks)
+ ;; and display failures.
-; FUN takes zero args. It returns non-nil (the offending object, e.g.
-; the short form of the filename) for a failure and probably logs a
-; detailed error explanation using function `dired-log'.
+ ;; FUN takes zero args. It returns non-nil (the offending object, e.g.
+ ;; the short form of the filename) for a failure and probably logs a
+ ;; detailed error explanation using function `dired-log'.
-; OP-SYMBOL is a symbol describing the operation performed (e.g.
-; `compress'). It is used with `dired-mark-pop-up' to prompt the user
-; (e.g. with `Compress * [2 files]? ') and to display errors (e.g.
-; `Failed to compress 1 of 2 files - type W to see why ("foo")')
+ ;; OP-SYMBOL is a symbol describing the operation performed (e.g.
+ ;; `compress'). It is used with `dired-mark-pop-up' to prompt the user
+ ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g.
+ ;; `Failed to compress 1 of 2 files - type W to see why ("foo")')
-; SHOW-PROGRESS if non-nil means redisplay dired after each file."
+ ;; SHOW-PROGRESS if non-nil means redisplay dired after each file."
(if (dired-mark-confirm op-symbol arg)
(let* ((total-list;; all of FUN's return values
(dired-map-over-marks (funcall fun) arg show-progress))
@@ -1285,7 +1457,8 @@ uncompress and unpack all the files in the archive."
(interactive "P")
(dired-map-over-marks-check #'dired-compress arg 'compress t))
-;; Commands for Emacs Lisp files - load and byte compile
+
+;;; Commands for Emacs Lisp files - load and byte compile
(defun dired-byte-compile ()
;; Return nil for success, offending file name else.
@@ -1317,7 +1490,7 @@ uncompress and unpack all the files in the archive."
;; Return nil for success, offending file name else.
(let ((file (dired-get-filename)) failure)
(condition-case err
- (load file nil nil t)
+ (load file nil nil t)
(error (setq failure err)))
(if (not failure)
nil
@@ -1377,6 +1550,7 @@ See Info node `(emacs)Subdir switches' for more details."
(interactive)
(setq dired-switches-alist nil)
(revert-buffer))
+
(defun dired-update-file-line (file)
;; Delete the current line, and insert an entry for FILE.
@@ -1531,22 +1705,18 @@ files matching `dired-omit-regexp'."
(forward-line 1)
(while (and (not (eolp)) ; don't cross subdir boundary
(not (dired-move-to-filename)))
- (forward-line 1))
+ (forward-line 1))
(point)))
;;;###autoload
(defun dired-remove-file (file)
+ "Remove entry FILE on each dired buffer.
+Note this doesn't delete FILE in the file system.
+See `dired-delete-file' in case you wish that."
(dired-fun-in-all-buffers
(file-name-directory file) (file-name-nondirectory file)
#'dired-remove-entry file))
-(defun dired-remove-entry (file)
- (save-excursion
- (and (dired-goto-file file)
- (let (buffer-read-only)
- (delete-region (progn (beginning-of-line) (point))
- (line-beginning-position 2))))))
-
;;;###autoload
(defun dired-relist-file (file)
"Create or update the line for FILE in all Dired buffers it would belong in."
@@ -1569,6 +1739,7 @@ files matching `dired-omit-regexp'."
(line-beginning-position 2)))
(setq file (directory-file-name file))
(dired-add-entry file (if (eq ?\s marker) nil marker)))))
+
;;; Copy, move/rename, making hard and symbolic links
@@ -1604,7 +1775,7 @@ Special value `always' suppresses confirmation."
(defun dired-copy-file (from to ok-flag)
(dired-handle-overwrite to)
(dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t
- dired-recursive-copies))
+ dired-recursive-copies dired-copy-dereference))
(declare-function make-symbolic-link "fileio.c")
@@ -1627,7 +1798,8 @@ If `ask', ask for user confirmation."
(dired-create-directory dir))))
(defun dired-copy-file-recursive (from to ok-flag &optional
- preserve-time top recursive)
+ preserve-time top recursive
+ dereference)
(when (and (eq t (file-attribute-type (file-attributes from)))
(file-in-directory-p to from))
(error "Cannot copy `%s' into its subdirectory `%s'" from to))
@@ -1639,7 +1811,8 @@ If `ask', ask for user confirmation."
(copy-directory from to preserve-time)
(or top (dired-handle-overwrite to))
(condition-case err
- (if (stringp (file-attribute-type attrs))
+ (if (and (not dereference)
+ (stringp (file-attribute-type attrs)))
;; It is a symlink
(make-symbolic-link (file-attribute-type attrs) to ok-flag)
(dired-maybe-create-dirs (file-name-directory to))
@@ -1661,6 +1834,9 @@ rename them using `vc-rename-file'."
;;;###autoload
(defun dired-rename-file (file newname ok-if-already-exists)
+ "Rename FILE to NEWNAME.
+Signal a `file-already-exists' error if a file NEWNAME already exists
+unless OK-IF-ALREADY-EXISTS is non-nil."
(dired-handle-overwrite newname)
(dired-maybe-create-dirs (file-name-directory newname))
(if (and dired-vc-rename-file
@@ -1675,7 +1851,8 @@ rename them using `vc-rename-file'."
(set-visited-file-name newname nil t)))
(dired-remove-file file)
;; See if it's an inserted subdir, and rename that, too.
- (dired-rename-subdir file newname))
+ (when (file-directory-p file)
+ (dired-rename-subdir file newname)))
(defun dired-rename-subdir (from-dir to-dir)
(setq from-dir (file-name-as-directory from-dir)
@@ -1688,9 +1865,9 @@ rename them using `vc-rename-file'."
(while blist
(with-current-buffer (car blist)
(if (and buffer-file-name
- (dired-in-this-tree-p buffer-file-name expanded-from-dir))
+ (file-in-directory-p buffer-file-name expanded-from-dir))
(let ((modflag (buffer-modified-p))
- (to-file (dired-replace-in-string
+ (to-file (replace-regexp-in-string
(concat "^" (regexp-quote from-dir))
to-dir
buffer-file-name)))
@@ -1707,7 +1884,7 @@ rename them using `vc-rename-file'."
(while alist
(setq elt (car alist)
alist (cdr alist))
- (if (dired-in-this-tree-p (car elt) expanded-dir)
+ (if (file-in-directory-p (car elt) expanded-dir)
;; ELT's subdir is affected by the rename
(dired-rename-subdir-2 elt dir to)))
(if (equal dir default-directory)
@@ -1754,7 +1931,7 @@ rename them using `vc-rename-file'."
;; Update buffer-local dired-subdir-alist and dired-switches-alist
(let ((cons (assoc-string (car elt) dired-switches-alist))
(cur-dir (dired-normalize-subdir
- (dired-replace-in-string regexp newtext (car elt)))))
+ (replace-regexp-in-string regexp newtext (car elt)))))
(setcar elt cur-dir)
(when cons (setcar cons cur-dir))))))
@@ -1762,7 +1939,9 @@ rename them using `vc-rename-file'."
(defvar overwrite-query)
(defvar overwrite-backup-query)
-;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
+
+;;; 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.
@@ -1792,6 +1971,9 @@ or with the current marker character if MARKER-CHAR is t."
(let (to overwrite-query
overwrite-backup-query) ; for dired-handle-overwrite
(dolist (from fn-list)
+ ;; Position point on the current file -- this is useful if
+ ;; handling a number of files to show where we're working at.
+ (dired-goto-file from)
(setq to (funcall name-constructor from))
(if (equal to from)
(progn
@@ -1842,6 +2024,11 @@ ESC or `q' to not overwrite any of the remaining files,
(file-in-directory-p destname from)
(error "Cannot copy `%s' into its subdirectory `%s'"
from to)))
+ ;; Check, that `dired-do-symlink' does not create symlinks
+ ;; on different hosts.
+ (when (and (eq file-creator 'make-symbolic-link)
+ (not (equal (file-remote-p from) (file-remote-p to))))
+ (error "Cannot symlink `%s' to `%s' on another host" from to))
(condition-case err
(progn
(funcall file-creator from to dired-overwrite-confirmed)
@@ -1888,7 +2075,27 @@ ESC or `q' to not overwrite any of the remaining files,
success-count)
operation success-count))))
(dired-move-to-filename))
+
+(defcustom dired-do-revert-buffer nil
+ "Automatically revert Dired buffers after `dired-do' operations.
+This option controls whether to refresh the directory listing in a
+Dired buffer that is the destination of one of these operations:
+`dired-do-copy', `dired-do-rename', `dired-do-symlink', `dired-do-hardlink'.
+If the value is t, always revert the Dired buffer updated in the result
+of these operations.
+If the value is a function, it is called with the destination directory name
+as a single argument, and the buffer is reverted after Dired operations
+if the function returns non-nil."
+ :type '(choice
+ (const :tag "Don't revert" nil)
+ (const :tag "Always revert destination directory" t)
+ (const :tag "Revert only local Dired buffers"
+ (lambda (dir) (not (file-remote-p dir))))
+ (function :tag "Predicate function"))
+ :group 'dired
+ :version "28.1")
+
(defun dired-do-create-files (op-symbol file-creator operation arg
&optional marker-char op1
how-to)
@@ -1937,7 +2144,7 @@ Optional arg HOW-TO determines how to treat the target.
(target (expand-file-name ; fluid variable inside dired-create-files
(minibuffer-with-setup-hook
(lambda ()
- (set (make-local-variable 'minibuffer-default-add-function) nil)
+ (setq-local minibuffer-default-add-function nil)
(setq minibuffer-default defaults))
(dired-mark-read-file-name
(format "%s %%s %s: "
@@ -1978,17 +2185,27 @@ Optional arg HOW-TO determines how to treat the target.
(apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
(if (not (or dired-one-file into-dir))
(error "Marked %s: target must be a directory: %s" operation target))
+ (if (and (not (file-directory-p (car fn-list)))
+ (not (file-directory-p target))
+ (directory-name-p target))
+ (error "%s: Target directory does not exist: %s" operation target))
;; rename-file bombs when moving directories unless we do this:
(or into-dir (setq target (directory-file-name target)))
- (dired-create-files
- file-creator operation fn-list
- (if into-dir ; target is a directory
- ;; This function uses fluid variable target when called
- ;; inside dired-create-files:
- (lambda (from)
- (expand-file-name (file-name-nondirectory from) target))
- (lambda (_from) target))
- marker-char))))
+ (prog1
+ (dired-create-files
+ file-creator operation fn-list
+ (if into-dir ; target is a directory
+ ;; This function uses fluid variable target when called
+ ;; inside dired-create-files:
+ (lambda (from)
+ (expand-file-name (file-name-nondirectory from) target))
+ (lambda (_from) target))
+ marker-char)
+ (when (or (eq dired-do-revert-buffer t)
+ (and (functionp dired-do-revert-buffer)
+ (funcall dired-do-revert-buffer target)))
+ (dired-fun-in-all-buffers (file-name-directory target) nil
+ #'revert-buffer))))))
;; Read arguments for a marked-files command that wants a file name,
;; perhaps popping up the list of marked files.
@@ -2091,7 +2308,6 @@ Optional arg HOW-TO determines how to treat the target.
dired-dirs)))
-
;; We use this function in `dired-create-directory' and
;; `dired-create-empty-file'; the return value is the new entry
;; in the updated Dired buffer.
@@ -2161,6 +2377,9 @@ See HOW-TO argument for `dired-do-create-files'.")
;;;###autoload
(defun dired-do-copy (&optional arg)
"Copy all marked (or next ARG) files, or copy the current file.
+ARG has to be numeric for above functionality. See
+`dired-get-marked-files' for more details.
+
When operating on just the current file, prompt for the new name.
When operating on multiple or marked files, prompt for a target
@@ -2174,10 +2393,18 @@ If `dired-copy-preserve-time' is non-nil, this command preserves
the modification time of each old file in the copy, similar to
the \"-p\" option for the \"cp\" shell command.
-This command copies symbolic links by creating new ones, similar
-to the \"-d\" option for the \"cp\" shell command."
+This command copies symbolic links by creating new ones,
+similar to the \"-d\" option for the \"cp\" shell command.
+But if `dired-copy-dereference' is non-nil, the symbolic
+links are dereferenced and then copied, similar to the \"-L\"
+option for the \"cp\" shell command. If ARG is a cons with
+element 4 (`\\[universal-argument]'), the inverted value of
+`dired-copy-dereference' will be used."
(interactive "P")
- (let ((dired-recursive-copies dired-recursive-copies))
+ (let ((dired-recursive-copies dired-recursive-copies)
+ (dired-copy-dereference (if (equal arg '(4))
+ (not dired-copy-dereference)
+ dired-copy-dereference)))
(dired-do-create-files 'copy #'dired-copy-file
"Copy"
arg dired-keep-marker-copy
@@ -2196,7 +2423,7 @@ suggested for the target directory depends on the value of
For relative symlinks, use \\[dired-do-relsymlink]."
(interactive "P")
(dired-do-create-files 'symlink #'make-symbolic-link
- "Symlink" arg dired-keep-marker-symlink))
+ "Symlink" arg dired-keep-marker-symlink))
;;;###autoload
(defun dired-do-hardlink (&optional arg)
@@ -2209,7 +2436,7 @@ suggested for the target directory depends on the value of
`dired-dwim-target', which see."
(interactive "P")
(dired-do-create-files 'hardlink #'dired-hardlink
- "Hardlink" arg dired-keep-marker-hardlink))
+ "Hardlink" arg dired-keep-marker-hardlink))
(defun dired-hardlink (file newname &optional ok-if-already-exists)
(dired-handle-overwrite newname)
@@ -2229,14 +2456,14 @@ of `dired-dwim-target', which see."
(interactive "P")
(dired-do-create-files 'move #'dired-rename-file
"Move" arg dired-keep-marker-rename "Rename"))
-;;;###end dired-cp.el
+
-;;; 5K
-;;;###begin dired-re.el
+;;; Operate on files matched by regexp
+
(defvar rename-regexp-query)
(defun dired-do-create-files-regexp
- (file-creator operation arg regexp newname &optional whole-name marker-char)
+ (file-creator operation arg regexp newname &optional whole-name marker-char)
;; Create a new file for each marked file using regexps.
;; FILE-CREATOR and OPERATION as in dired-create-files.
;; ARG as in dired-get-marked-files.
@@ -2353,10 +2580,13 @@ See function `dired-do-rename-regexp' for more info."
#'make-symbolic-link
"SymLink" arg regexp newname whole-name dired-keep-marker-symlink))
+
+;;; Change case of file names
+
(defvar rename-non-directory-query)
(defun dired-create-files-non-directory
- (file-creator basename-constructor operation arg)
+ (file-creator basename-constructor operation arg)
;; Perform FILE-CREATOR on the non-directory part of marked files
;; using function BASENAME-CONSTRUCTOR, with query for each file.
;; OPERATION like in dired-create-files, ARG as in dired-get-marked-files.
@@ -2398,10 +2628,8 @@ Type SPC or `y' to %s one file, DEL or `n' to skip to next,
(interactive "P")
(dired-rename-non-directory #'downcase "Rename downcase" arg))
-;;;###end dired-re.el
-;;; 13K
-;;;###begin dired-ins.el
+;;; Insert subdirectory
;;;###autoload
(defun dired-maybe-insert-subdir (dirname &optional
@@ -2485,10 +2713,10 @@ This function takes some pains to conform to `ls -lR' output."
(push (cons dirname switches) dired-switches-alist)))
(when switches-have-R
(dired-build-subdir-alist switches)
- (setq switches (dired-replace-in-string "R" "" switches))
+ (setq switches (string-replace "R" "" switches))
(dolist (cur-ass dired-subdir-alist)
(let ((cur-dir (car cur-ass)))
- (and (dired-in-this-tree-p cur-dir dirname)
+ (and (file-in-directory-p cur-dir dirname)
(let ((cur-cons (assoc-string cur-dir dired-switches-alist)))
(if cur-cons
(setcdr cur-cons switches)
@@ -2500,7 +2728,7 @@ This function takes some pains to conform to `ls -lR' output."
(defun dired-insert-subdir-validate (dirname &optional switches)
;; Check that it is valid to insert DIRNAME with SWITCHES.
;; Signal an error if invalid (e.g. user typed `i' on `..').
- (or (dired-in-this-tree-p dirname (expand-file-name default-directory))
+ (or (file-in-directory-p dirname (expand-file-name default-directory))
(error "%s: not in this directory tree" dirname))
(let ((real-switches (or switches dired-subdir-switches)))
(when real-switches
@@ -2541,7 +2769,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
(setq dir (car (car s-alist))
s-alist (cdr s-alist))
(and (or kill-root (not (string-equal dir dirname)))
- (dired-in-this-tree-p dir dirname)
+ (file-in-directory-p dir dirname)
(dired-goto-subdir dir)
(setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
m-alist))
@@ -2586,7 +2814,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
(let ((dired-actual-switches
(or switches
dired-subdir-switches
- (dired-replace-in-string "R" "" dired-actual-switches))))
+ (string-replace "R" "" dired-actual-switches))))
(if (equal dirname (car (car (last dired-subdir-alist))))
;; If doing the top level directory of the buffer,
;; redo it as specified in dired-directory.
@@ -2675,8 +2903,9 @@ is always equal to STRING."
(setq result
(cons (substring str end) result)))
(nreverse result)))
+
-;;; moving by subdirectories
+;;; Moving by subdirectories
;;;###autoload
(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip)
@@ -2690,12 +2919,6 @@ When called interactively and not on a subdir line, go to this subdir's line."
(if (dired-get-subdir) 1 0))))
(dired-next-subdir (- arg) no-error-if-not-found no-skip))
-(defun dired-subdir-min ()
- (save-excursion
- (if (not (dired-prev-subdir 0 t t))
- (error "Not in a subdir!")
- (point))))
-
;;;###autoload
(defun dired-goto-subdir (dir)
"Go to end of header line of DIR in this dired buffer.
@@ -2779,23 +3002,15 @@ Lower levels are unaffected."
(while rest
(setq elt (car rest)
rest (cdr rest))
- (if (dired-in-this-tree-p (directory-file-name (car elt)) dir)
+ (if (file-in-directory-p (directory-file-name (car elt)) dir)
(setq rest nil
pos (dired-goto-subdir (car elt))))))
(if pos
(goto-char pos)
(error "At the bottom"))))
-
-;;; hiding
-
-(defun dired-unhide-subdir ()
- (with-silent-modifications
- (dired--unhide (dired-subdir-min) (dired-subdir-max))))
-(defun dired-subdir-hidden-p (dir)
- (save-excursion
- (dired-goto-subdir dir)
- (dired--hidden-p)))
+
+;;; Hiding
;;;###autoload
(defun dired-hide-subdir (arg)
@@ -2839,10 +3054,8 @@ Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
(dired--hide start end))
(setq pos (cdr subdir))))))) ; prev dir gets current dir
-;;;###end dired-ins.el
-
-;; Search only in file names in the Dired buffer.
+;;; Search only in file names in the Dired buffer
(defcustom dired-isearch-filenames nil
"Non-nil to Isearch in file names only.
@@ -2860,7 +3073,7 @@ a file name. Otherwise, it searches the whole buffer without restrictions."
When on, Isearch skips matches outside file names using the predicate
`dired-isearch-filter-filenames' that matches only at file names.
When off, it uses the original predicate."
- nil nil nil
+ :lighter nil
(if dired-isearch-filenames-mode
(add-function :before-while (local 'isearch-filter-predicate)
#'dired-isearch-filter-filenames
@@ -2901,18 +3114,18 @@ is part of a file name (i.e., has the text property `dired-filename')."
(defun dired-isearch-filenames ()
"Search for a string using Isearch only in file names in the Dired buffer."
(interactive)
- (set (make-local-variable 'dired-isearch-filenames) t)
+ (setq-local dired-isearch-filenames t)
(isearch-forward nil t))
;;;###autoload
(defun dired-isearch-filenames-regexp ()
"Search for a regexp using Isearch only in file names in the Dired buffer."
(interactive)
- (set (make-local-variable 'dired-isearch-filenames) t)
+ (setq-local dired-isearch-filenames t)
(isearch-forward-regexp nil t))
-;; Functions for searching in tags style among marked files.
+;;; Functions for searching in tags style among marked files
;;;###autoload
(defun dired-do-isearch ()
@@ -3004,10 +3217,12 @@ REGEXP should use constructs supported by your local `grep' command."
files))
(push mark files)))
(nreverse marks))
+ (message "Searching...")
(setq xrefs
(xref-matches-in-files regexp files))
(unless xrefs
(user-error "No matches for: %s" regexp))
+ (message "Searching...done")
xrefs))))
(xref--show-xrefs fetcher nil)))
@@ -3033,7 +3248,7 @@ REGEXP should use constructs supported by your local `grep' command."
(with-current-buffer
(let ((xref-show-xrefs-function
;; Some future-proofing (bug#44905).
- (eval (car (get 'xref-show-xrefs-function 'standard-value)))))
+ (custom--standard-value 'xref-show-xrefs-function)))
(dired-do-find-regexp from))
(xref-query-replace-in-results from to)))
@@ -3056,6 +3271,69 @@ instead."
(backward-delete-char 1))
(message "%s" (buffer-string)))))
+
+;;; Version control from dired
+
+(declare-function vc-dir-unmark-all-files "vc-dir")
+(declare-function vc-dir-mark-files "vc-dir")
+
+;;;###autoload
+(defun dired-vc-next-action (verbose)
+ "Do the next version control operation on marked files/directories.
+When only files are marked then call `vc-next-action' with the
+same value of the VERBOSE argument.
+When also directories are marked then call `vc-dir' and mark
+the same files/directories in the VC-Dir buffer that were marked
+in the Dired buffer."
+ (interactive "P")
+ (let* ((marked-files
+ (dired-get-marked-files nil nil nil nil t))
+ (mark-files
+ (when (cl-some #'file-directory-p marked-files)
+ ;; Fix deficiency of Dired by adding slash to dirs
+ (mapcar (lambda (file)
+ (if (file-directory-p file)
+ (file-name-as-directory file)
+ file))
+ marked-files))))
+ (if mark-files
+ (let ((transient-hook (make-symbol "vc-dir-mark-files")))
+ (fset transient-hook
+ (lambda ()
+ (remove-hook 'vc-dir-refresh-hook transient-hook t)
+ (vc-dir-unmark-all-files t)
+ (vc-dir-mark-files mark-files)))
+ (vc-dir-root)
+ (add-hook 'vc-dir-refresh-hook transient-hook nil t))
+ (vc-next-action verbose))))
+
+(declare-function vc-compatible-state "vc")
+
+;;;###autoload
+(defun dired-vc-deduce-fileset (&optional state-model-only-files not-state-changing)
+ (let ((backend (vc-responsible-backend default-directory))
+ (files (dired-get-marked-files nil nil nil nil t))
+ only-files-list
+ state
+ model)
+ (when (and (not not-state-changing) (cl-some #'file-directory-p files))
+ (user-error "State changing VC operations on directories supported only in `vc-dir'"))
+
+ (when state-model-only-files
+ (setq only-files-list (mapcar (lambda (file) (cons file (vc-state file))) files))
+ (setq state (cdar only-files-list))
+ ;; Check that all files are in a consistent state, since we use that
+ ;; state to decide which operation to perform.
+ (dolist (crt (cdr only-files-list))
+ (unless (vc-compatible-state (cdr crt) state)
+ (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s"
+ (car crt) (cdr crt) (caar only-files-list) state)))
+ (setq only-files-list (mapcar 'car only-files-list))
+ (when (and state (not (eq state 'unregistered)))
+ (setq model (vc-checkout-model backend only-files-list))))
+ (list backend files only-files-list state model)))
+
+
(provide 'dired-aux)
;; Local Variables:
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 747561be5c9..a7bfae759ed 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -44,7 +44,8 @@
;; but maybe not if a dired-x function is being autoloaded.
(require 'dired)
-;;; User-defined variables.
+
+;;; User-defined variables
(defgroup dired-x nil
"Extended directory editing (dired-x)."
@@ -64,21 +65,8 @@ mbox format, and so cannot be distinguished in this way."
:type 'boolean
:group 'dired-keys)
-(defcustom dired-bind-jump t
- "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 ctl-x-map "\C-j" 'dired-jump)
- (define-key ctl-x-4-map "\C-j" 'dired-jump-other-window))
- (if (eq 'dired-jump (lookup-key ctl-x-map "\C-j"))
- (define-key ctl-x-map "\C-j" nil))
- (if (eq 'dired-jump-other-window (lookup-key ctl-x-4-map "\C-j"))
- (define-key ctl-x-4-map "\C-j" nil))))
- :group 'dired-keys)
+(defvar dired-bind-jump t)
+(make-obsolete-variable 'dired-bind-jump "not used." "28.1")
(defcustom dired-bind-man t
"Non-nil means bind `dired-man' to \"N\" in Dired, otherwise do not.
@@ -137,6 +125,7 @@ folding to be used on case-insensitive filesystems only."
(file-name-case-insensitive-p dir)
dired-omit-case-fold))
+;;;###autoload
(define-minor-mode dired-omit-mode
"Toggle omission of uninteresting files in Dired (Dired-Omit mode).
@@ -229,7 +218,9 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
:type 'boolean
:group 'dired-x)
-;;; KEY BINDINGS.
+
+;;; Key bindings
+
(when (keymapp (lookup-key dired-mode-map "*"))
(define-key dired-mode-map "*(" 'dired-mark-sexp)
(define-key dired-mode-map "*O" 'dired-mark-omitted)
@@ -246,9 +237,8 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
(define-key dired-mode-map "Y" 'dired-do-relsymlink)
(define-key dired-mode-map "V" 'dired-do-run-mail)
-;;; MENU BINDINGS
-
-(require 'easymenu)
+
+;;; Menu bindings
(when-let ((menu (lookup-key dired-mode-map [menu-bar])))
(easy-menu-add-item menu '("Operate")
@@ -288,7 +278,7 @@ files"]
"Refresh"))
-;; Install into appropriate hooks.
+;;; Install into appropriate hooks
(add-hook 'dired-mode-hook 'dired-extra-startup)
(add-hook 'dired-after-readin-hook 'dired-omit-expunge)
@@ -307,7 +297,6 @@ 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'
`dired-man'
`dired-vm'
`dired-rmail'
@@ -318,7 +307,7 @@ See also the functions:
(dired-omit-startup))
-;;; EXTENSION MARKING FUNCTIONS.
+;;; Extension marking functions
(defun dired--mark-suffix-interactive-spec ()
(let* ((default
@@ -326,21 +315,19 @@ See also the functions:
(when file
(file-name-extension file))))
(suffix
- (read-string (format "%s extension%s: "
- (if (equal current-prefix-arg '(4))
- "UNmarking"
- "Marking")
- (if default
- (format " (default %s)" default)
- "")) nil nil default))
+ (read-string (format-prompt
+ "%s extension" default
+ (if (equal current-prefix-arg '(4))
+ "UNmarking"
+ "Marking"))
+ nil nil default))
(marker
(pcase current-prefix-arg
('(4) ?\s)
('(16)
(let* ((dflt (char-to-string dired-marker-char))
(input (read-string
- (format
- "Marker character to use (default %s): " dflt)
+ (format-prompt "Marker character to use" dflt)
nil nil dflt)))
(aref input 0)))
(_ dired-marker-char))))
@@ -447,70 +434,9 @@ See variables `dired-texinfo-unclean-extensions',
dired-bibtex-unclean-extensions
dired-tex-unclean-extensions
(list ".dvi"))))
-
-(defvar archive-superior-buffer)
-(defvar tar-superior-buffer)
-;;; JUMP.
-;;;###autoload
-(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.
-When OTHER-WINDOW is non-nil, jump to Dired buffer in other window.
-When FILE-NAME is non-nil, jump to its line in Dired.
-Interactively with prefix argument, read FILE-NAME."
- (interactive
- (list nil (and current-prefix-arg
- (read-file-name "Jump to Dired file: "))))
- (cond
- ((and (bound-and-true-p archive-subfile-mode)
- (buffer-live-p archive-superior-buffer))
- (switch-to-buffer archive-superior-buffer))
- ((and (bound-and-true-p tar-subfile-mode)
- (buffer-live-p tar-superior-buffer))
- (switch-to-buffer tar-superior-buffer))
- (t
- ;; Expand file-name before `dired-goto-file' call:
- ;; `dired-goto-file' requires its argument to be an absolute
- ;; file name; the result of `read-file-name' could be
- ;; an abbreviated file name (Bug#24409).
- (let* ((file (or (and file-name (expand-file-name file-name))
- buffer-file-name))
- (dir (if file (file-name-directory file) default-directory)))
- (if (and (eq major-mode 'dired-mode) (null file-name))
- (progn
- (setq dir (dired-current-directory))
- (dired-up-directory other-window)
- (unless (dired-goto-file dir)
- ;; refresh and try again
- (dired-insert-subdir (file-name-directory dir))
- (dired-goto-file dir)))
- (if other-window
- (dired-other-window dir)
- (dired dir))
- (if file
- (or (dired-goto-file file)
- ;; refresh and try again
- (progn
- (dired-insert-subdir (file-name-directory file))
- (dired-goto-file file))
- ;; Toggle omitting, if it is on, and try again.
- (when dired-omit-mode
- (dired-omit-mode)
- (dired-goto-file file)))))))))
-
-;;;###autoload
-(defun dired-jump-other-window (&optional file-name)
- "Like \\[dired-jump] (`dired-jump') but in other window."
- (interactive
- (list (and current-prefix-arg
- (read-file-name "Jump to Dired file: "))))
- (dired-jump t file-name))
-;;; OMITTING.
+;;; Omitting
;; Enhanced omitting of lines from directory listings.
;; Marked files are never omitted.
@@ -523,7 +449,7 @@ If it is `no-dir', omitting is much faster, but you can only match
against the non-directory part of the file name. Set it to nil if you
need to match the entire file name.")
-;; \017=^O for Omit - other packages can chose other control characters.
+;; \017=^O for Omit - other packages can choose other control characters.
(defvar dired-omit-marker-char ?\017
"Temporary marker used by Dired-Omit.
Should never be used as marker by the user or other packages.")
@@ -623,7 +549,9 @@ interactively, prompt for REGEXP.
With prefix argument, unflag all those files.
Optional fourth argument LOCALP is as in `dired-get-filename'.
Optional fifth argument CASE-FOLD-P specifies the value of
-`case-fold-search' used for matching REGEXP."
+`case-fold-search' used for matching REGEXP.
+If the region is active in Transient Mark mode, operate only on
+files in the active region if `dired-mark-region' is non-nil."
(interactive
(list (read-regexp
"Mark unmarked files matching regexp (default all): "
@@ -646,13 +574,13 @@ Optional fifth argument CASE-FOLD-P specifies the value of
msg)))
-;;; VIRTUAL DIRED MODE.
+;;; Virtual dired mode
;; For browsing `ls -lR' listings in a dired-like fashion.
(defalias 'virtual-dired 'dired-virtual)
(defun dired-virtual (dirname &optional switches)
- "Put this buffer into Virtual Dired mode.
+ "Put this Dired buffer into Virtual Dired mode.
In Virtual Dired mode, all commands that do not actually consult the
filesystem will work.
@@ -684,7 +612,8 @@ you can relist single subdirs using \\[dired-do-redisplay]."
;; hand if you want them.
(interactive
- (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir))))
+ (list (read-directory-name "Virtual Dired directory: "
+ nil (dired-virtual-guess-dir))))
(goto-char (point-min))
(or (looking-at-p " ")
;; if not already indented, do it now:
@@ -698,7 +627,7 @@ you can relist single subdirs using \\[dired-do-redisplay]."
(and (looking-at "^ wildcard ")
(buffer-substring (match-end 0)
(line-end-position))))))
- (if wildcard
+ (if wildcard
(setq dirname (expand-file-name wildcard default-directory))))
;; If raw ls listing (not a saved old dired buffer), give it a
;; decent subdir headerline:
@@ -710,7 +639,7 @@ you can relist single subdirs using \\[dired-do-redisplay]."
(dired-mode dirname (or switches dired-listing-switches))
(setq mode-name "Virtual Dired"
revert-buffer-function 'dired-virtual-revert)
- (set (make-local-variable 'dired-subdir-alist) nil)
+ (setq-local dired-subdir-alist nil)
(dired-build-subdir-alist)
(goto-char (point-min))
(dired-initial-position dirname))
@@ -768,7 +697,7 @@ Also useful for `auto-mode-alist' like this:
(dired-virtual (dired-virtual-guess-dir)))
-;;; SMART SHELL.
+;;; Smart shell
;; An Emacs buffer can have but one working directory, stored in the
;; buffer-local variable `default-directory'. A Dired buffer may have
@@ -795,30 +724,30 @@ Also useful for `auto-mode-alist' like this:
(shell-command command output-buffer error-buffer)))
-;;; GUESS SHELL COMMAND.
+;;; Guess shell command
;; Brief Description:
-;;;
+;;
;; * `dired-do-shell-command' is bound to `!' by dired.el.
-;;;
+;;
;; * `dired-guess-shell-command' provides smarter defaults for
-;;; dired-aux.el's `dired-read-shell-command'.
-;;;
+;; dired-aux.el's `dired-read-shell-command'.
+;;
;; * `dired-guess-shell-command' calls `dired-guess-default' with list of
-;;; marked files.
-;;;
+;; marked files.
+;;
;; * Parse `dired-guess-shell-alist-user' and
-;;; `dired-guess-shell-alist-default' (in that order) for the first REGEXP
-;;; that matches the first file in the file list.
-;;;
+;; `dired-guess-shell-alist-default' (in that order) for the first REGEXP
+;; that matches the first file in the file list.
+;;
;; * If the REGEXP matches all the entries of the file list then evaluate
-;;; COMMAND, which is either a string or a Lisp expression returning a
-;;; string. COMMAND may be a list of commands.
-;;;
+;; COMMAND, which is either a string or a Lisp expression returning a
+;; string. COMMAND may be a list of commands.
+;;
;; * Return this command to `dired-guess-shell-command' which prompts user
-;;; with it. The list of commands is put into the list of default values.
-;;; If a command is used successfully then it is stored permanently in
-;;; `dired-shell-command-history'.
+;; with it. The list of commands is put into the list of default values.
+;; If a command is used successfully then it is stored permanently in
+;; `dired-shell-command-history'.
;; Guess what shell command to apply to a file.
(defvar dired-shell-command-history nil
@@ -1016,10 +945,15 @@ Each element of this list looks like
(REGEXP COMMAND...)
-where each COMMAND can either be a string or a Lisp expression that evaluates
+COMMAND will be used if REGEXP matches the file to be processed.
+If several files are to be processed, REGEXP has to match all the
+files.
+
+Each COMMAND can either be a string or a Lisp expression that evaluates
to a string. If this expression needs to consult the name of the file for
which the shell commands are being requested, it can access that file name
as the variable `file'.
+
If several COMMANDs are given, the first one will be the default
and the rest will be added temporarily to the history and can be retrieved
with \\[previous-history-element] (M-p) .
@@ -1038,38 +972,26 @@ REGEXP is matched case-sensitively."
(defun dired-guess-default (files)
"Return a shell command, or a list of commands, appropriate for FILES.
See `dired-guess-shell-alist-user'."
-
(let* ((case-fold-search dired-guess-shell-case-fold-search)
- ;; Prepend the user's alist to the default alist.
- (alist (append dired-guess-shell-alist-user
- dired-guess-shell-alist-default))
- (file (car files))
- (flist (cdr files))
- elt regexp cmds)
-
- ;; Find the first match in the alist for first file in FILES.
- (while alist
- (setq elt (car alist)
- regexp (car elt)
- alist (cdr alist))
- (if (string-match-p regexp file)
- (setq cmds (cdr elt)
- alist nil)))
-
- ;; If more than one file, see if all of FILES match regular expression.
- (while (and flist
- (string-match-p regexp (car flist)))
- (setq flist (cdr flist)))
-
- ;; If flist is still non-nil, then do not guess since this means that not
- ;; all the files in FILES were matched by the regexp.
- (setq cmds (and (not flist) cmds))
-
- ;; Return commands or nil if flist is still non-nil.
- ;; Evaluate the commands in order that any logical testing will be done.
- (if (cdr cmds)
- (delete-dups (mapcar (lambda (cmd) (eval cmd `((file . ,file)))) cmds))
- (eval (car cmds) `((file . ,file)))))) ; single command
+ (programs
+ (delete-dups
+ (mapcar
+ (lambda (command)
+ (eval command `((file . ,(car files)))))
+ (seq-reduce
+ #'append
+ (mapcar #'cdr
+ (seq-filter (lambda (elem)
+ (seq-every-p
+ (lambda (file)
+ (string-match-p (car elem) file))
+ files))
+ (append dired-guess-shell-alist-user
+ dired-guess-shell-alist-default)))
+ nil)))))
+ (if (length= programs 1)
+ (car programs)
+ programs)))
(defun dired-guess-shell-command (prompt files)
"Ask user with PROMPT for a shell command, guessing a default from FILES."
@@ -1098,7 +1020,7 @@ See `dired-guess-shell-alist-user'."
(if (equal val "") default val))))
-;;; RELATIVE SYMBOLIC LINKS.
+;;; Relative symbolic links
(declare-function make-symbolic-link "fileio.c")
@@ -1159,7 +1081,7 @@ results in
;;;###autoload
(defun dired-do-relsymlink (&optional arg)
- "Relative symlink all marked (or next ARG) files into a directory.
+ "Relative symlink all marked (or next ARG) files into a directory.
Otherwise make a relative symbolic link to the current file.
This creates relative symbolic links like
@@ -1172,7 +1094,7 @@ not absolute ones like
For absolute symlinks, use \\[dired-do-symlink]."
(interactive "P")
(dired-do-create-files 'relsymlink #'dired-make-relative-symlink
- "RelSymLink" arg dired-keep-marker-relsymlink))
+ "RelSymLink" arg dired-keep-marker-relsymlink))
(autoload 'dired-mark-read-regexp "dired-aux")
(autoload 'dired-do-create-files-regexp "dired-aux")
@@ -1187,30 +1109,30 @@ for more info."
"RelSymLink" arg regexp newname whole-name dired-keep-marker-relsymlink))
-;;; VISIT ALL MARKED FILES SIMULTANEOUSLY.
+;;; Visit all marked files simultaneously
;; Brief Description:
-;;;
+;;
;; `dired-do-find-marked-files' is bound to `F' by dired-x.el.
-;;;
+;;
;; * Use `dired-get-marked-files' to collect the marked files in the current
-;;; Dired Buffer into a list of filenames `FILE-LIST'.
-;;;
+;; Dired Buffer into a list of filenames `FILE-LIST'.
+;;
;; * Pass FILE-LIST to `dired-simultaneous-find-file' all with
-;;; `dired-do-find-marked-files''s prefix argument NOSELECT.
-;;;
+;; `dired-do-find-marked-files''s prefix argument NOSELECT.
+;;
;; * `dired-simultaneous-find-file' runs through FILE-LIST decrementing the
-;;; list each time.
-;;;
+;; list each time.
+;;
;; * If NOSELECT is non-nil then just run `find-file-noselect' on each
-;;; element of FILE-LIST.
-;;;
+;; element of FILE-LIST.
+;;
;; * If NOSELECT is nil then calculate the `size' of the window for each file
-;;; by dividing the `window-height' by length of FILE-LIST. Thus, `size' is
-;;; cognizant of the window-configuration.
-;;;
+;; by dividing the `window-height' by length of FILE-LIST. Thus, `size' is
+;; cognizant of the window-configuration.
+;;
;; * If `size' is too small abort, otherwise run `find-file' on each element
-;;; of FILE-LIST giving each a window of height `size'.
+;; of FILE-LIST giving each a window of height `size'.
(defun dired-do-find-marked-files (&optional noselect)
"Find all marked files displaying all of them simultaneously.
@@ -1256,7 +1178,7 @@ NOSELECT the files are merely found but not selected."
(find-file file)))))
-;;; MISCELLANEOUS COMMANDS.
+;;; Miscellaneous commands
;; Run man on files.
@@ -1266,8 +1188,8 @@ NOSELECT the files are merely found but not selected."
(defun dired-man ()
"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.
+ ;; 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))
@@ -1300,7 +1222,7 @@ Otherwise obeys the value of `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)))
+ (setq-local vm-folder-directory dir)))
(defun dired-rmail ()
"Run RMAIL on this file."
@@ -1324,7 +1246,7 @@ otherwise."
(dired-rmail)))))
-;;; MISCELLANEOUS INTERNAL FUNCTIONS.
+;;; Miscellaneous internal functions
;; This should be a builtin
(defun dired-buffer-more-recently-used-p (buffer1 buffer2)
@@ -1334,7 +1256,6 @@ Considers buffers closer to the car of `buffer-list' to be more recent."
(memq buffer1 (buffer-list))
(not (memq buffer1 (memq buffer2 (buffer-list))))))
-
;; Needed if ls -lh is supported and also for GNU ls -ls.
(defun dired-x--string-to-number (str)
"Like `string-to-number' but recognize a trailing unit prefix.
@@ -1386,7 +1307,9 @@ present for some values of `ls-lisp-emulation'.
This function operates only on the buffer content and does not
refer at all to the underlying file system. Contrast this with
-`find-dired', which might be preferable for the task at hand."
+`find-dired', which might be preferable for the task at hand.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil."
;; Using sym="" instead of nil avoids the trap of
;; (string-match "foo" sym) into which a user would soon fall.
;; Give `equal' instead of `=' in the example, as this works on
@@ -1505,7 +1428,7 @@ refer at all to the underlying file system. Contrast this with
(format "'%s file" predicate))))
-;;; FIND FILE AT POINT.
+;;; Find file at point
(defcustom dired-x-hands-off-my-keys t
"Non-nil means don't remap `find-file' to `dired-x-find-file'.
@@ -1552,10 +1475,13 @@ 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.
+
+;;; Internal functions
;; Fixme: This should probably use `thing-at-point'. -- fx
-(defun dired-filename-at-point ()
+(define-obsolete-function-alias 'dired-filename-at-point
+ #'dired-x-guess-file-name-at-point "28.1")
+(defun dired-x-guess-file-name-at-point ()
"Return the filename closest to point, expanded.
Point should be in or after a filename."
(save-excursion
@@ -1589,7 +1515,7 @@ Point should be in or after a filename."
"Return filename prompting with PROMPT with completion.
If `current-prefix-arg' is non-nil, uses name at point as guess."
(if current-prefix-arg
- (let ((guess (dired-filename-at-point)))
+ (let ((guess (dired-x-guess-file-name-at-point)))
(read-file-name prompt
(file-name-directory guess)
guess
@@ -1598,8 +1524,9 @@ If `current-prefix-arg' is non-nil, uses name at point as guess."
(define-obsolete-function-alias 'read-filename-at-point
'dired-x-read-filename-at-point "24.1") ; is this even needed?
+
-;;; BUG REPORTS
+;;; Epilog
(define-obsolete-function-alias 'dired-x-submit-report 'report-emacs-bug "24.1")
diff --git a/lisp/dired.el b/lisp/dired.el
index af16c5f5c40..28448be06ce 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -41,6 +41,7 @@
(declare-function dired-buffer-more-recently-used-p
"dired-x" (buffer1 buffer2))
+
;;; Customizable variables
(defgroup dired nil
@@ -53,17 +54,21 @@
:prefix "dired-"
:group 'dired)
-
;;;###autoload
(defcustom dired-listing-switches (purecopy "-al")
"Switches passed to `ls' for Dired. MUST contain the `l' option.
May contain all other options that don't contradict `-l';
may contain even `F', `b', `i' and `s'. See also the variable
`dired-ls-F-marks-symlinks' concerning the `F' switch.
+
+If you have files with names with embedded newline characters, adding
+`b' to the switches will allow Dired to handle those files better.
+
Options that include embedded whitespace must be quoted
like this: \"--option=value with spaces\"; you can use
`combine-and-quote-strings' to produce the correct quoting of
each option.
+
On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
some of the `ls' switches are not supported; see the doc string of
`insert-directory' in `ls-lisp.el' for more details."
@@ -73,9 +78,30 @@ some of the `ls' switches are not supported; see the doc string of
(defcustom dired-subdir-switches nil
"If non-nil, switches passed to `ls' for inserting subdirectories.
If nil, `dired-listing-switches' is used."
- :group 'dired
- :type '(choice (const :tag "Use dired-listing-switches" nil)
- (string :tag "Switches")))
+ :group 'dired
+ :type '(choice (const :tag "Use dired-listing-switches" nil)
+ (string :tag "Switches")))
+
+(defcustom dired-maybe-use-globstar nil
+ "If non-nil, enable globstar if the shell supports it.
+Some shells enable this feature by default (e.g. zsh or fish).
+
+See `dired-enable-globstar-in-shell' for a list of shells
+that support globstar and disable it by default.
+
+Note that the implementations of globstar have small differences
+between shells. You must check your shell documentation to see
+what to expect."
+ :type 'boolean
+ :group 'dired
+ :version "28.1")
+
+(defconst dired-enable-globstar-in-shell
+ '(("ksh" . "set -G")
+ ("bash" . "shopt -s globstar"))
+ "Alist of (SHELL . COMMAND), where COMMAND enables globstar in SHELL.
+If `dired-maybe-use-globstar' is non-nil, then `dired-insert-directory'
+checks this alist to enable globstar in the shell subprocess.")
(defcustom dired-chown-program
(purecopy (cond ((executable-find "chown") "chown")
@@ -118,14 +144,14 @@ For more details, see Info node `(emacs)ls in Lisp'."
(defcustom dired-touch-program "touch"
"Name of touch command (usually `touch')."
- :group 'dired
- :type 'file)
+ :group 'dired
+ :type 'file)
(defcustom dired-ls-F-marks-symlinks nil
"Informs Dired about how `ls -lF' marks symbolic links.
Set this to t if `ls' (or whatever program is specified by
`insert-directory-program') with `-lF' marks the symbolic link
-itself with a trailing @ (usually the case under Ultrix).
+itself with a trailing @ (usually the case under Ultrix and macOS).
Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to
nil (the default), if it gives `bar@ -> foo', set it to t.
@@ -137,7 +163,7 @@ always set this variable to t."
:type 'boolean
:group 'dired-mark)
-(defcustom dired-trivial-filenames (purecopy "\\`\\.\\.?\\'\\|\\`#")
+(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.
A value of t means move to first file."
@@ -194,7 +220,7 @@ or the most recently used window with a Dired buffer, or to use any other
function. When the value is a function, it will be called with no
arguments and is expected to return a list of directories which will
be used as defaults (i.e. default target and \"future history\")
-(though, `dired-dwim-target-defaults' might modify it a bit).
+\(though, `dired-dwim-target-defaults' might modify it a bit).
The value t prefers the next windows on the same frame.
The target is used in the prompt for file copy, rename etc."
@@ -216,20 +242,26 @@ The target is used in the prompt for file copy, rename etc."
:type 'boolean
:group 'dired)
-; These variables were deleted and the replacements are on files.el.
-; We leave aliases behind for back-compatibility.
+(defcustom dired-copy-dereference nil
+ "If non-nil, Dired dereferences symlinks when copying them.
+This is similar to the \"-L\" option for the \"cp\" shell command."
+ :type 'boolean
+ :group 'dired)
+
+;; These variables were deleted and the replacements are on files.el.
+;; We leave aliases behind for back-compatibility.
(define-obsolete-variable-alias 'dired-free-space-program
'directory-free-space-program "27.1")
(define-obsolete-variable-alias 'dired-free-space-args
'directory-free-space-args "27.1")
-;;; Hook variables
-
(defcustom dired-load-hook nil
"Run after loading Dired.
You can customize key bindings or load extensions with this."
:group 'dired
:type 'hook)
+(make-obsolete-variable 'dired-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom dired-mode-hook nil
"Run at the very end of `dired-mode'."
@@ -294,7 +326,43 @@ new Dired buffers."
:version "26.1"
:group 'dired)
-;; Internal variables
+(defcustom dired-mark-region 'file
+ "Defines what commands that mark files do with the active region.
+
+When nil, marking commands don't operate on all files in the
+active region. They process their prefix arguments as usual.
+
+When the value of this option is non-nil, then all Dired commands
+that mark or unmark files will operate on all files in the region
+if the region is active in Transient Mark mode.
+
+When `file', the region marking is based on the file name.
+This means don't mark the file if the end of the region is
+before the file name displayed on the Dired line, so the file name
+is visually outside the region. This behavior is consistent with
+marking files without the region using the key `m' that advances
+point to the next line after marking the file. Thus the number
+of keys used to mark files is the same as the number of keys
+used to select the region, e.g. `M-2 m' marks 2 files, and
+`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files.
+
+When `line', the region marking is based on Dired lines,
+so include the file into marking if the end of the region
+is anywhere on its Dired line, except the beginning of the line."
+ :type '(choice
+ (const :tag "Don't mark files in active region" nil)
+ (const :tag "Exclude file name outside of region" file)
+ (const :tag "Include the file at region end line" line))
+ :group 'dired
+ :version "28.1")
+
+(defcustom dired-kill-when-opening-new-dired-buffer nil
+ "If non-nil, kill the current buffer when selecting a new directory."
+ :type 'boolean
+ :version "28.1")
+
+
+;;; Internal variables
(defvar dired-marker-char ?* ; the answer is 42
;; so that you can write things like
@@ -312,8 +380,8 @@ This is what the do-commands look for, and what the mark-commands store.")
"Character used to flag files for deletion.")
(defvar dired-shrink-to-fit t
-;; I see no reason ever to make this nil -- rms.
-;; (> baud-rate search-slow-speed)
+ ;; I see no reason ever to make this nil -- rms.
+ ;; (> baud-rate search-slow-speed)
"Non-nil means Dired shrinks the display buffer to fit the marked files.")
(make-obsolete-variable 'dired-shrink-to-fit
"use the Customization interface to add a new rule
@@ -361,7 +429,7 @@ The directory name must be absolute, but need not be fully expanded.")
"[bcsp][^:]"))
(defvar dired-re-exe;; match ls permission string of an executable file
(mapconcat (lambda (x)
- (concat dired-re-maybe-mark dired-re-inode-size x))
+ (concat dired-re-maybe-mark dired-re-inode-size x))
'("-[-r][-w][xs][-r][-w].[-r][-w]."
"-[-r][-w].[-r][-w][xs][-r][-w]."
"-[-r][-w].[-r][-w].[-r][-w][xst]")
@@ -394,6 +462,9 @@ The match starts at the beginning of the line and ends after the end
of the line.
Subexpression 2 must end right before the \\n.")
+
+;;; Faces
+
(defgroup dired-faces nil
"Faces used by Dired."
:group 'dired
@@ -475,6 +546,14 @@ Subexpression 2 must end right before the \\n.")
(defvar dired-symlink-face 'dired-symlink
"Face name used for symbolic links.")
+(defface dired-broken-symlink
+ '((((class color))
+ :foreground "yellow1" :background "red1" :weight bold)
+ (t :weight bold :slant italic :underline t))
+ "Face used for broken symbolic links."
+ :group 'dired-faces
+ :version "28.1")
+
(defface dired-special
'((t (:inherit font-lock-variable-name-face)))
"Face used for sockets, pipes, block devices and char devices."
@@ -489,6 +568,9 @@ Subexpression 2 must end right before the \\n.")
(defvar dired-ignored-face 'dired-ignored
"Face name used for files suffixed with `completion-ignored-extensions'.")
+
+;;; Font-lock
+
(defvar dired-font-lock-keywords
(list
;;
@@ -538,6 +620,45 @@ Subexpression 2 must end right before the \\n.")
(list dired-re-dir
'(".+" (dired-move-to-filename) nil (0 dired-directory-face)))
;;
+ ;; Files suffixed with `completion-ignored-extensions'.
+ '(eval .
+ ;; It is quicker to first find just an extension, then go back to the
+ ;; start of that file name. So we do this complex MATCH-ANCHORED form.
+ (list (concat
+ "\\(" (regexp-opt completion-ignored-extensions)
+ "\\|#\\|\\.#.+\\)$")
+ '(".+" (dired-move-to-filename) nil (0 dired-ignored-face))))
+ ;;
+ ;; Files suffixed with `completion-ignored-extensions'
+ ;; plus a character put in by -F.
+ '(eval .
+ (list (concat "\\(" (regexp-opt completion-ignored-extensions)
+ "\\|#\\|\\.#.+\\)[*=|]$")
+ '(".+" (progn
+ (end-of-line)
+ ;; If the last character is not part of the filename,
+ ;; move back to the start of the filename
+ ;; so it can be fontified.
+ ;; Otherwise, leave point at the end of the line;
+ ;; that way, nothing is fontified.
+ (unless (get-text-property (1- (point)) 'mouse-face)
+ (dired-move-to-filename)))
+ nil (0 dired-ignored-face))))
+ ;;
+ ;; Broken Symbolic link.
+ (list dired-re-sym
+ (list (lambda (end)
+ (let* ((file (dired-file-name-at-point))
+ (truename (ignore-errors (file-truename file))))
+ ;; either not existent target or circular link
+ (and (not (and truename (file-exists-p truename)))
+ (search-forward-regexp "\\(.+\\) \\(->\\) ?\\(.+\\)" end t))))
+ '(dired-move-to-filename)
+ nil
+ '(1 'dired-broken-symlink)
+ '(2 dired-symlink-face)
+ '(3 'dired-broken-symlink)))
+ ;;
;; Symbolic link to a directory.
(list dired-re-sym
(list (lambda (end)
@@ -568,29 +689,6 @@ Subexpression 2 must end right before the \\n.")
(list dired-re-special
'(".+" (dired-move-to-filename) nil (0 'dired-special)))
;;
- ;; Files suffixed with `completion-ignored-extensions'.
- '(eval .
- ;; It is quicker to first find just an extension, then go back to the
- ;; start of that file name. So we do this complex MATCH-ANCHORED form.
- (list (concat "\\(" (regexp-opt completion-ignored-extensions) "\\|#\\)$")
- '(".+" (dired-move-to-filename) nil (0 dired-ignored-face))))
- ;;
- ;; Files suffixed with `completion-ignored-extensions'
- ;; plus a character put in by -F.
- '(eval .
- (list (concat "\\(" (regexp-opt completion-ignored-extensions)
- "\\|#\\)[*=|]$")
- '(".+" (progn
- (end-of-line)
- ;; If the last character is not part of the filename,
- ;; move back to the start of the filename
- ;; so it can be fontified.
- ;; Otherwise, leave point at the end of the line;
- ;; that way, nothing is fontified.
- (unless (get-text-property (1- (point)) 'mouse-face)
- (dired-move-to-filename)))
- nil (0 dired-ignored-face))))
- ;;
;; Explicitly put the default face on file names ending in a colon to
;; avoid fontifying them as directory header.
(list (concat dired-re-maybe-mark dired-re-inode-size dired-re-perms ".*:$")
@@ -598,24 +696,35 @@ Subexpression 2 must end right before the \\n.")
;;
;; Directory headers.
(list dired-subdir-regexp '(1 dired-header-face))
-)
+ )
"Additional expressions to highlight in Dired mode.")
(defvar dnd-protocol-alist)
+
-;;; Macros must be defined before they are used, for the byte compiler.
+;;; Macros
+
+;; Macros must be defined before they are used, for the byte compiler.
(defmacro dired-mark-if (predicate msg)
"Mark files for PREDICATE, according to `dired-marker-char'.
PREDICATE is evaluated on each line, with point at beginning of line.
MSG is a noun phrase for the type of files being marked.
It should end with a noun that can be pluralized by adding `s'.
+
+In Transient Mark mode, if the mark is active, operate on the contents
+of the region if `dired-mark-region' is non-nil. Otherwise, operate
+on the whole buffer.
+
Return value is the number of files marked, or nil if none were marked."
- `(let ((inhibit-read-only t) count)
+ `(let ((inhibit-read-only t) count
+ (use-region-p (dired-mark--region-use-p))
+ (beg (dired-mark--region-beginning))
+ (end (dired-mark--region-end)))
(save-excursion
(setq count 0)
(when ,msg
- (message "%s %ss%s..."
+ (message "%s %ss%s%s..."
(cond ((eq dired-marker-char ?\s) "Unmarking")
((eq dired-del-marker dired-marker-char)
"Flagging")
@@ -623,22 +732,28 @@ Return value is the number of files marked, or nil if none were marked."
,msg
(if (eq dired-del-marker dired-marker-char)
" for deletion"
- "")))
- (goto-char (point-min))
- (while (not (eobp))
+ "")
+ (if use-region-p
+ " in region"
+ "")))
+ (goto-char beg)
+ (while (< (point) end)
(when ,predicate
(unless (= (following-char) dired-marker-char)
(delete-char 1)
(insert dired-marker-char)
(setq count (1+ count))))
(forward-line 1))
- (when ,msg (message "%s %s%s %s%s"
+ (when ,msg (message "%s %s%s %s%s%s"
count
,msg
(dired-plural-s count)
(if (eq dired-marker-char ?\s) "un" "")
(if (eq dired-marker-char dired-del-marker)
- "flagged" "marked"))))
+ "flagged" "marked")
+ (if use-region-p
+ " in region"
+ ""))))
(and (> count 0) count)))
(defmacro dired-map-over-marks (body arg &optional show-progress
@@ -757,8 +872,34 @@ ERROR can be a string with the error message."
(user-error (if (stringp error) error "No files specified")))
result))
+(defun dired-mark--region-use-p ()
+ "Whether Dired marking commands should act on region."
+ (and dired-mark-region
+ (region-active-p)
+ (> (region-end) (region-beginning))))
+
+(defun dired-mark--region-beginning ()
+ "Return the value of the region beginning aligned to Dired file lines."
+ (if (dired-mark--region-use-p)
+ (save-excursion
+ (goto-char (region-beginning))
+ (line-beginning-position))
+ (point-min)))
+
+(defun dired-mark--region-end ()
+ "Return the value of the region end aligned to Dired file lines."
+ (if (dired-mark--region-use-p)
+ (save-excursion
+ (goto-char (region-end))
+ (if (if (eq dired-mark-region 'line)
+ (not (bolp))
+ (get-text-property (1- (point)) 'dired-filename))
+ (line-end-position)
+ (line-beginning-position)))
+ (point-max)))
+
-;; The dired command
+;;; The dired command
(defun dired-read-dir-and-switches (str)
;; For use in interactive.
@@ -849,7 +990,6 @@ If a directory or nothing is found at point, return nil."
(if (and file-name
(not (file-directory-p file-name)))
file-name)))
-(put 'dired-mode 'grep-read-files 'dired-grep-read-files)
;;;###autoload (define-key ctl-x-map "d" 'dired)
;;;###autoload
@@ -1139,7 +1279,7 @@ The return value is the target column for the file names."
found)))
-;; Read in a new dired buffer
+;;; Read in a new dired buffer
(defun dired-readin ()
"Read in a new Dired buffer.
@@ -1149,15 +1289,11 @@ wildcards, erases the buffer, and builds the subdir-alist anew
;; default-directory and dired-actual-switches must be buffer-local
;; and initialized by now.
- (let (dirname
- ;; This makes read-in much faster.
- ;; In particular, it prevents the font lock hook from running
- ;; until the directory is all read in.
- (inhibit-modification-hooks t))
- (if (consp dired-directory)
- (setq dirname (car dired-directory))
- (setq dirname dired-directory))
- (setq dirname (expand-file-name dirname))
+ (let ((dirname
+ (expand-file-name
+ (if (consp dired-directory)
+ (car dired-directory)
+ dired-directory))))
(save-excursion
;; This hook which may want to modify dired-actual-switches
;; based on dired-directory, e.g. with ange-ftp to a SysV host
@@ -1167,17 +1303,25 @@ wildcards, erases the buffer, and builds the subdir-alist anew
(setq buffer-undo-list nil))
(setq-local file-name-coding-system
(or coding-system-for-read file-name-coding-system))
- (let ((inhibit-read-only t)
- ;; Don't make undo entries for readin.
- (buffer-undo-list t))
- (widen)
- (erase-buffer)
- (dired-readin-insert))
- (goto-char (point-min))
- ;; Must first make alist buffer local and set it to nil because
- ;; dired-build-subdir-alist will call dired-clear-alist first
- (setq-local dired-subdir-alist nil)
- (dired-build-subdir-alist)
+ (widen)
+ ;; We used to bind `inhibit-modification-hooks' to try and speed up
+ ;; execution, in particular, to prevent the font-lock hook from running
+ ;; until the directory is all read in.
+ ;; It's not clear why font-lock would be a significant issue
+ ;; here, but I used `combine-change-calls' which should provide the
+ ;; same performance advantages without the problem of breaking
+ ;; users of after/before-change-functions.
+ (combine-change-calls (point-min) (point-max)
+ (let ((inhibit-read-only t)
+ ;; Don't make undo entries for readin.
+ (buffer-undo-list t))
+ (erase-buffer)
+ (dired-readin-insert))
+ (goto-char (point-min))
+ ;; Must first make alist buffer local and set it to nil because
+ ;; dired-build-subdir-alist will call dired-clear-alist first
+ (setq-local dired-subdir-alist nil)
+ (dired-build-subdir-alist))
(let ((attributes (file-attributes dirname)))
(if (eq (car attributes) t)
(set-visited-file-modtime (file-attribute-modification-time
@@ -1380,15 +1524,21 @@ see `dired-use-ls-dired' for more details.")
;; "--dired", so we cannot add it to the `process-file'
;; call for wildcards.
(when (file-remote-p dir)
- (setq switches (dired-replace-in-string "--dired" "" switches)))
+ (setq switches (string-replace "--dired" "" switches)))
(let* ((default-directory (car dir-wildcard))
(script (format "ls %s %s" switches (cdr dir-wildcard)))
(remotep (file-remote-p dir))
(sh (or (and remotep "/bin/sh")
- (and (bound-and-true-p explicit-shell-file-name)
- (executable-find explicit-shell-file-name))
+ (executable-find shell-file-name)
(executable-find "sh")))
(switch (if remotep "-c" shell-command-switch)))
+ ;; Enable globstar
+ (when-let ((globstar dired-maybe-use-globstar)
+ (enable-it
+ (assoc-default
+ (file-truename sh) dired-enable-globstar-in-shell
+ (lambda (reg shell) (string-match reg shell)))))
+ (setq script (format "%s; %s" enable-it script)))
(unless
(zerop
(process-file sh nil (current-buffer) nil switch script))
@@ -1493,8 +1643,9 @@ see `dired-use-ls-dired' for more details.")
(put-text-property (+ (point) 4) (line-end-position)
'invisible 'dired-hide-details-link))))
(forward-line 1))))
+
-;; Reverting a dired buffer
+;;; Reverting a dired buffer
(defun dired-revert (&optional _arg _noconfirm)
"Reread the Dired buffer.
@@ -1681,8 +1832,9 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(let ((handler (find-file-name-handler dir 'dired-uncache)))
(if handler
(funcall handler 'dired-uncache dir))))
+
-;; dired mode key bindings and initialization
+;;; Dired mode key bindings and menus
(defvar dired-mode-map
;; This looks ugly when substitute-command-keys uses C-d instead d:
@@ -1811,6 +1963,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map "\177" 'dired-unmark-backward)
(define-key map [remap undo] 'dired-undo)
(define-key map [remap advertised-undo] 'dired-undo)
+ (define-key map [remap vc-next-action] 'dired-vc-next-action)
;; thumbnail manipulation (image-dired)
(define-key map "\C-td" 'image-dired-display-thumbs)
(define-key map "\C-tt" 'image-dired-tag-files)
@@ -1830,325 +1983,224 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map ":s" 'epa-dired-do-sign)
(define-key map ":e" 'epa-dired-do-encrypt)
- ;; Make menu bar items.
-
;; No need to do this, now that top-level items are fewer.
;;;;
;; Get rid of the Edit menu bar item to save space.
- ;(define-key map [menu-bar edit] 'undefined)
-
- (define-key map [menu-bar subdir]
- (cons "Subdir" (make-sparse-keymap "Subdir")))
-
- (define-key map [menu-bar subdir hide-all]
- '(menu-item "Hide All" dired-hide-all
- :help "Hide all subdirectories, leave only header lines"))
- (define-key map [menu-bar subdir hide-subdir]
- '(menu-item "Hide/UnHide Subdir" dired-hide-subdir
- :help "Hide or unhide current directory listing"))
- (define-key map [menu-bar subdir tree-down]
- '(menu-item "Tree Down" dired-tree-down
- :help "Go to first subdirectory header down the tree"))
- (define-key map [menu-bar subdir tree-up]
- '(menu-item "Tree Up" dired-tree-up
- :help "Go to first subdirectory header up the tree"))
- (define-key map [menu-bar subdir up]
- '(menu-item "Up Directory" dired-up-directory
- :help "Edit the parent directory"))
- (define-key map [menu-bar subdir prev-subdir]
- '(menu-item "Prev Subdir" dired-prev-subdir
- :help "Go to previous subdirectory header line"))
- (define-key map [menu-bar subdir next-subdir]
- '(menu-item "Next Subdir" dired-next-subdir
- :help "Go to next subdirectory header line"))
- (define-key map [menu-bar subdir prev-dirline]
- '(menu-item "Prev Dirline" dired-prev-dirline
- :help "Move to next directory-file line"))
- (define-key map [menu-bar subdir next-dirline]
- '(menu-item "Next Dirline" dired-next-dirline
- :help "Move to previous directory-file line"))
- (define-key map [menu-bar subdir insert]
- '(menu-item "Insert This Subdir" dired-maybe-insert-subdir
- :help "Insert contents of subdirectory"
- :enable (let ((f (dired-get-filename nil t)))
- (and f (file-directory-p f)))))
- (define-key map [menu-bar immediate]
- (cons "Immediate" (make-sparse-keymap "Immediate")))
-
- (define-key map
- [menu-bar immediate image-dired-dired-display-external]
- '(menu-item "Display Image Externally" image-dired-dired-display-external
- :help "Display image in external viewer"))
- (define-key map
- [menu-bar immediate image-dired-dired-display-image]
- '(menu-item "Display Image" image-dired-dired-display-image
- :help "Display sized image in a separate window"))
- (define-key map
- [menu-bar immediate image-dired-dired-toggle-marked-thumbs]
- '(menu-item "Toggle Image Thumbnails in This Buffer" image-dired-dired-toggle-marked-thumbs
- :help "Add or remove image thumbnails in front of marked file names"))
-
- (define-key map [menu-bar immediate hide-details]
- '(menu-item "Hide Details" dired-hide-details-mode
- :help "Hide details in buffer"
- :button (:toggle . dired-hide-details-mode)))
- (define-key map [menu-bar immediate revert-buffer]
- '(menu-item "Refresh" revert-buffer
- :help "Update contents of shown directories"))
- (define-key map [menu-bar immediate dired-number-of-marked-files]
- '(menu-item "#Marked Files" dired-number-of-marked-files
- :help "Display the number and size of the marked files"))
-
- (define-key map [menu-bar immediate dashes]
- '("--"))
-
- (define-key map [menu-bar immediate isearch-filenames-regexp]
- '(menu-item "Isearch Regexp in File Names..." dired-isearch-filenames-regexp
- :help "Incrementally search for regexp in file names only"))
- (define-key map [menu-bar immediate isearch-filenames]
- '(menu-item "Isearch in File Names..." dired-isearch-filenames
- :help "Incrementally search for string in file names only."))
- (define-key map [menu-bar immediate compare-directories]
- '(menu-item "Compare Directories..." dired-compare-directories
- :help "Mark files with different attributes in two Dired buffers"))
- (define-key map [menu-bar immediate backup-diff]
- '(menu-item "Compare with Backup" dired-backup-diff
- :help "Diff file at cursor with its latest backup"))
- (define-key map [menu-bar immediate diff]
- '(menu-item "Diff..." dired-diff
- :help "Compare file at cursor with another file"))
- (define-key map [menu-bar immediate view]
- '(menu-item "View This File" dired-view-file
- :help "Examine file at cursor in read-only mode"))
- (define-key map [menu-bar immediate display]
- '(menu-item "Display in Other Window" dired-display-file
- :help "Display file at cursor in other window"))
- (define-key map [menu-bar immediate find-file-other-window]
- '(menu-item "Find in Other Window" dired-find-file-other-window
- :help "Edit file at cursor in other window"))
- (define-key map [menu-bar immediate find-file]
- '(menu-item "Find This File" dired-find-file
- :help "Edit file at cursor"))
- (define-key map [menu-bar immediate create-directory]
- '(menu-item "Create Directory..." dired-create-directory
- :help "Create a directory"))
- (define-key map [menu-bar immediate create-empty-file]
- '(menu-item "Create Empty file..." dired-create-empty-file
- :help "Create an empty file"))
- (define-key map [menu-bar immediate wdired-mode]
- '(menu-item "Edit File Names" wdired-change-to-wdired-mode
- :help "Put a Dired buffer in a mode in which filenames are editable"
- :keys "C-x C-q"
- :filter (lambda (x) (if (eq major-mode 'dired-mode) x))))
-
- (define-key map [menu-bar regexp]
- (cons "Regexp" (make-sparse-keymap "Regexp")))
-
- (define-key map
- [menu-bar regexp image-dired-mark-tagged-files]
- '(menu-item "Mark From Image Tag..." image-dired-mark-tagged-files
- :help "Mark files whose image tags matches regexp"))
-
- (define-key map [menu-bar regexp dashes-1]
- '("--"))
-
- (define-key map [menu-bar regexp downcase]
- '(menu-item "Downcase" dired-downcase
- ;; When running on plain MS-DOS, there's only one
- ;; letter-case for file names.
- :enable (or (not (fboundp 'msdos-long-file-names))
- (msdos-long-file-names))
- :help "Rename marked files to lower-case name"))
- (define-key map [menu-bar regexp upcase]
- '(menu-item "Upcase" dired-upcase
- :enable (or (not (fboundp 'msdos-long-file-names))
- (msdos-long-file-names))
- :help "Rename marked files to upper-case name"))
- (define-key map [menu-bar regexp hardlink]
- '(menu-item "Hardlink..." dired-do-hardlink-regexp
- :help "Make hard links for files matching regexp"))
- (define-key map [menu-bar regexp symlink]
- '(menu-item "Symlink..." dired-do-symlink-regexp
- :visible (fboundp 'make-symbolic-link)
- :help "Make symbolic links for files matching regexp"))
- (define-key map [menu-bar regexp rename]
- '(menu-item "Rename..." dired-do-rename-regexp
- :help "Rename marked files matching regexp"))
- (define-key map [menu-bar regexp copy]
- '(menu-item "Copy..." dired-do-copy-regexp
- :help "Copy marked files matching regexp"))
- (define-key map [menu-bar regexp flag]
- '(menu-item "Flag..." dired-flag-files-regexp
- :help "Flag files matching regexp for deletion"))
- (define-key map [menu-bar regexp mark]
- '(menu-item "Mark..." dired-mark-files-regexp
- :help "Mark files matching regexp for future operations"))
- (define-key map [menu-bar regexp mark-cont]
- '(menu-item "Mark Containing..." dired-mark-files-containing-regexp
- :help "Mark files whose contents matches regexp"))
-
- (define-key map [menu-bar mark]
- (cons "Mark" (make-sparse-keymap "Mark")))
-
- (define-key map [menu-bar mark prev]
- '(menu-item "Previous Marked" dired-prev-marked-file
- :help "Move to previous marked file"))
- (define-key map [menu-bar mark next]
- '(menu-item "Next Marked" dired-next-marked-file
- :help "Move to next marked file"))
- (define-key map [menu-bar mark marks]
- '(menu-item "Change Marks..." dired-change-marks
- :help "Replace marker with another character"))
- (define-key map [menu-bar mark unmark-all]
- '(menu-item "Unmark All" dired-unmark-all-marks))
- (define-key map [menu-bar mark symlinks]
- '(menu-item "Mark Symlinks" dired-mark-symlinks
- :visible (fboundp 'make-symbolic-link)
- :help "Mark all symbolic links"))
- (define-key map [menu-bar mark directories]
- '(menu-item "Mark Directories" dired-mark-directories
- :help "Mark all directories except `.' and `..'"))
- (define-key map [menu-bar mark directory]
- '(menu-item "Mark Old Backups" dired-clean-directory
- :help "Flag old numbered backups for deletion"))
- (define-key map [menu-bar mark executables]
- '(menu-item "Mark Executables" dired-mark-executables
- :help "Mark all executable files"))
- (define-key map [menu-bar mark garbage-files]
- '(menu-item "Flag Garbage Files" dired-flag-garbage-files
- :help "Flag unneeded files for deletion"))
- (define-key map [menu-bar mark backup-files]
- '(menu-item "Flag Backup Files" dired-flag-backup-files
- :help "Flag all backup files for deletion"))
- (define-key map [menu-bar mark auto-save-files]
- '(menu-item "Flag Auto-save Files" dired-flag-auto-save-files
- :help "Flag auto-save files for deletion"))
- (define-key map [menu-bar mark deletion]
- '(menu-item "Flag" dired-flag-file-deletion
- :help "Flag current line's file for deletion"))
- (define-key map [menu-bar mark unmark]
- '(menu-item "Unmark" dired-unmark
- :help "Unmark or unflag current line's file"))
- (define-key map [menu-bar mark mark]
- '(menu-item "Mark" dired-mark
- :help "Mark current line's file for future operations"))
- (define-key map [menu-bar mark toggle-marks]
- '(menu-item "Toggle Marks" dired-toggle-marks
- :help "Mark unmarked files, unmark marked ones"))
-
- (define-key map [menu-bar operate]
- (cons "Operate" (make-sparse-keymap "Operate")))
-
- (define-key map
- [menu-bar operate image-dired-delete-tag]
- '(menu-item "Delete Image Tag..." image-dired-delete-tag
- :help "Delete image tag from current or marked files"))
- (define-key map
- [menu-bar operate image-dired-tag-files]
- '(menu-item "Add Image Tags..." image-dired-tag-files
- :help "Add image tags to current or marked files"))
- (define-key map
- [menu-bar operate image-dired-dired-comment-files]
- '(menu-item "Add Image Comment..." image-dired-dired-comment-files
- :help "Add image comment to current or marked files"))
- (define-key map
- [menu-bar operate image-dired-display-thumbs]
- '(menu-item "Display Image Thumbnails" image-dired-display-thumbs
- :help "Display image thumbnails for current or marked image files"))
-
- (define-key map [menu-bar operate dashes-4]
- '("--"))
-
- (define-key map
- [menu-bar operate epa-dired-do-decrypt]
- '(menu-item "Decrypt..." epa-dired-do-decrypt
- :help "Decrypt current or marked files"))
-
- (define-key map
- [menu-bar operate epa-dired-do-verify]
- '(menu-item "Verify" epa-dired-do-verify
- :help "Verify digital signature of current or marked files"))
-
- (define-key map
- [menu-bar operate epa-dired-do-sign]
- '(menu-item "Sign..." epa-dired-do-sign
- :help "Create digital signature of current or marked files"))
-
- (define-key map
- [menu-bar operate epa-dired-do-encrypt]
- '(menu-item "Encrypt..." epa-dired-do-encrypt
- :help "Encrypt current or marked files"))
-
- (define-key map [menu-bar operate dashes-3]
- '("--"))
-
- (define-key map [menu-bar operate query-replace]
- '(menu-item "Query Replace in Files..." dired-do-find-regexp-and-replace
- :help "Replace regexp matches in marked files"))
- (define-key map [menu-bar operate search]
- '(menu-item "Search Files..." dired-do-find-regexp
- :help "Search marked files for matches of regexp"))
- (define-key map [menu-bar operate isearch-regexp]
- '(menu-item "Isearch Regexp Files..." dired-do-isearch-regexp
- :help "Incrementally search marked files for regexp"))
- (define-key map [menu-bar operate isearch]
- '(menu-item "Isearch Files..." dired-do-isearch
- :help "Incrementally search marked files for string"))
- (define-key map [menu-bar operate chown]
- '(menu-item "Change Owner..." dired-do-chown
- :visible (not (memq system-type '(ms-dos windows-nt)))
- :help "Change the owner of marked files"))
- (define-key map [menu-bar operate chgrp]
- '(menu-item "Change Group..." dired-do-chgrp
- :visible (not (memq system-type '(ms-dos windows-nt)))
- :help "Change the group of marked files"))
- (define-key map [menu-bar operate chmod]
- '(menu-item "Change Mode..." dired-do-chmod
- :help "Change mode (attributes) of marked files"))
- (define-key map [menu-bar operate touch]
- '(menu-item "Change Timestamp..." dired-do-touch
- :help "Change timestamp of marked files"))
- (define-key map [menu-bar operate load]
- '(menu-item "Load" dired-do-load
- :help "Load marked Emacs Lisp files"))
- (define-key map [menu-bar operate compile]
- '(menu-item "Byte-compile" dired-do-byte-compile
- :help "Byte-compile marked Emacs Lisp files"))
- (define-key map [menu-bar operate compress]
- '(menu-item "Compress" dired-do-compress
- :help "Compress/uncompress marked files"))
- (define-key map [menu-bar operate print]
- '(menu-item "Print..." dired-do-print
- :help "Ask for print command and print marked files"))
- (define-key map [menu-bar operate hardlink]
- '(menu-item "Hardlink to..." dired-do-hardlink
- :help "Make hard links for current or marked files"))
- (define-key map [menu-bar operate symlink]
- '(menu-item "Symlink to..." dired-do-symlink
- :visible (fboundp 'make-symbolic-link)
- :help "Make symbolic links for current or marked files"))
- (define-key map [menu-bar operate async-command]
- '(menu-item "Asynchronous Shell Command..." dired-do-async-shell-command
- :help "Run a shell command asynchronously on current or marked files"))
- (define-key map [menu-bar operate command]
- '(menu-item "Shell Command..." dired-do-shell-command
- :help "Run a shell command on current or marked files"))
- (define-key map [menu-bar operate delete]
- '(menu-item "Delete" dired-do-delete
- :help "Delete current file or all marked files"))
- (define-key map [menu-bar operate rename]
- '(menu-item "Rename to..." dired-do-rename
- :help "Rename current file or move marked files"))
- (define-key map [menu-bar operate copy]
- '(menu-item "Copy to..." dired-do-copy
- :help "Copy current file or all marked files"))
+ ;;(define-key map [menu-bar edit] 'undefined)
map)
"Local keymap for Dired mode buffers.")
+
+(easy-menu-define dired-mode-subdir-menu dired-mode-map
+ "Subdir menu for Dired mode."
+ '("Subdir"
+ ["Insert This Subdir" dired-maybe-insert-subdir
+ :help "Insert contents of subdirectory"
+ :enable (let ((f (dired-get-filename nil t)))
+ (and f (file-directory-p f)))]
+ ["Next Dirline" dired-next-dirline
+ :help "Move to previous directory-file line"]
+ ["Prev Dirline" dired-prev-dirline
+ :help "Move to next directory-file line"]
+ ["Next Subdir" dired-next-subdir
+ :help "Go to next subdirectory header line"]
+ ["Prev Subdir" dired-prev-subdir
+ :help "Go to previous subdirectory header line"]
+ ["Up Directory" dired-up-directory
+ :help "Edit the parent directory"]
+ ["Tree Up" dired-tree-up
+ :help "Go to first subdirectory header up the tree"]
+ ["Tree Down" dired-tree-down
+ :help "Go to first subdirectory header down the tree"]
+ ["Hide/UnHide Subdir" dired-hide-subdir
+ :help "Hide or unhide current directory listing"]
+ ["Hide All" dired-hide-all
+ :help "Hide all subdirectories, leave only header lines"]))
+
+(easy-menu-define dired-mode-immediate-menu dired-mode-map
+ "Immediate menu for Dired mode."
+ '("Immediate"
+ ["Edit File Names" wdired-change-to-wdired-mode
+ :help "Put a Dired buffer in a mode in which filenames are editable"
+ :keys "C-x C-q"
+ :filter (lambda (x) (if (eq major-mode 'dired-mode) x))]
+ ["Create Empty file..." dired-create-empty-file
+ :help "Create an empty file"]
+ ["Create Directory..." dired-create-directory
+ :help "Create a directory"]
+ ["Find This File" dired-find-file
+ :help "Edit file at cursor"]
+ ["Find in Other Window" dired-find-file-other-window
+ :help "Edit file at cursor in other window"]
+ ["Display in Other Window" dired-display-file
+ :help "Display file at cursor in other window"]
+ ["View This File" dired-view-file
+ :help "Examine file at cursor in read-only mode"]
+ ["Diff..." dired-diff
+ :help "Compare file at cursor with another file"]
+ ["Compare with Backup" dired-backup-diff
+ :help "Diff file at cursor with its latest backup"]
+ ["Compare Directories..." dired-compare-directories
+ :help "Mark files with different attributes in two Dired buffers"]
+ ["Isearch in File Names..." dired-isearch-filenames
+ :help "Incrementally search for string in file names only."]
+ ["Isearch Regexp in File Names..." dired-isearch-filenames-regexp
+ :help "Incrementally search for regexp in file names only"]
+ "---"
+ ["#Marked Files" dired-number-of-marked-files
+ :help "Display the number and size of the marked files"]
+ ["Refresh" revert-buffer
+ :help "Update contents of shown directories"]
+ ["Hide Details" dired-hide-details-mode
+ :help "Hide details in buffer"
+ :style toggle
+ :selected dired-hide-details-mode]
+ ["Toggle Image Thumbnails in This Buffer" image-dired-dired-toggle-marked-thumbs
+ :help "Add or remove image thumbnails in front of marked file names"]
+ ["Display Image" image-dired-dired-display-image
+ :help "Display sized image in a separate window"]
+ ["Display Image Externally" image-dired-dired-display-external
+ :help "Display image in external viewer"]))
+
+(easy-menu-define dired-mode-regexp-menu dired-mode-map
+ "Regexp menu for Dired mode."
+ '("Regexp"
+ ["Mark Containing..." dired-mark-files-containing-regexp
+ :help "Mark files whose contents matches regexp"]
+ ["Mark..." dired-mark-files-regexp
+ :help "Mark files matching regexp for future operations"]
+ ["Flag..." dired-flag-files-regexp
+ :help "Flag files matching regexp for deletion"]
+ ["Copy..." dired-do-copy-regexp
+ :help "Copy marked files matching regexp"]
+ ["Rename..." dired-do-rename-regexp
+ :help "Rename marked files matching regexp"]
+ ["Symlink..." dired-do-symlink-regexp
+ :visible (fboundp 'make-symbolic-link)
+ :help "Make symbolic links for files matching regexp"]
+ ["Hardlink..." dired-do-hardlink-regexp
+ :help "Make hard links for files matching regexp"]
+ ["Upcase" dired-upcase
+ :enable (or (not (fboundp 'msdos-long-file-names))
+ (msdos-long-file-names))
+ :help "Rename marked files to upper-case name"]
+ ["Downcase" dired-downcase
+ ;; When running on plain MS-DOS, there's only one
+ ;; letter-case for file names.
+ :enable (or (not (fboundp 'msdos-long-file-names))
+ (msdos-long-file-names))
+ :help "Rename marked files to lower-case name"]
+ "---"
+ ["Mark From Image Tag..." image-dired-mark-tagged-files
+ :help "Mark files whose image tags matches regexp"]))
+
+(easy-menu-define dired-mode-mark-menu dired-mode-map
+ "Mark menu for Dired mode."
+ '("Mark"
+ ["Toggle Marks" dired-toggle-marks
+ :help "Mark unmarked files, unmark marked ones"]
+ ["Mark" dired-mark
+ :help "Mark current line's file for future operations"]
+ ["Unmark" dired-unmark
+ :help "Unmark or unflag current line's file"]
+ ["Flag" dired-flag-file-deletion
+ :help "Flag current line's file for deletion"]
+ ["Flag Auto-save Files" dired-flag-auto-save-files
+ :help "Flag auto-save files for deletion"]
+ ["Flag Backup Files" dired-flag-backup-files
+ :help "Flag all backup files for deletion"]
+ ["Flag Garbage Files" dired-flag-garbage-files
+ :help "Flag unneeded files for deletion"]
+ ["Mark Executables" dired-mark-executables
+ :help "Mark all executable files"]
+ ["Mark Old Backups" dired-clean-directory
+ :help "Flag old numbered backups for deletion"]
+ ["Mark Directories" dired-mark-directories
+ :help "Mark all directories except `.' and `..'"]
+ ["Mark Symlinks" dired-mark-symlinks
+ :visible (fboundp 'make-symbolic-link)
+ :help "Mark all symbolic links"]
+ ["Unmark All" dired-unmark-all-marks]
+ ["Change Marks..." dired-change-marks
+ :help "Replace marker with another character"]
+ ["Next Marked" dired-next-marked-file
+ :help "Move to next marked file"]
+ ["Previous Marked" dired-prev-marked-file
+ :help "Move to previous marked file"]))
+
+(easy-menu-define dired-mode-operate-menu dired-mode-map
+ "Operate menu for Dired mode."
+ '("Operate"
+ ["Copy to..." dired-do-copy
+ :help "Copy current file or all marked files"]
+ ["Rename to..." dired-do-rename
+ :help "Rename current file or move marked files"]
+ ("Delete"
+ ["Delete Flagged Files" dired-do-flagged-delete
+ :help "Delete all files flagged for deletion (D)"]
+ ["Delete Marked (Not Flagged) Files" dired-do-delete
+ :help "Delete current file or all marked files (excluding flagged files)"])
+ ["Shell Command..." dired-do-shell-command
+ :help "Run a shell command on current or marked files"]
+ ["Asynchronous Shell Command..." dired-do-async-shell-command
+ :help "Run a shell command asynchronously on current or marked files"]
+ ["Symlink to..." dired-do-symlink
+ :visible (fboundp 'make-symbolic-link)
+ :help "Make symbolic links for current or marked files"]
+ ["Hardlink to..." dired-do-hardlink
+ :help "Make hard links for current or marked files"]
+ ["Print..." dired-do-print
+ :help "Ask for print command and print marked files"]
+ ["Compress" dired-do-compress
+ :help "Compress/uncompress marked files"]
+ ["Byte-compile" dired-do-byte-compile
+ :help "Byte-compile marked Emacs Lisp files"]
+ ["Load" dired-do-load
+ :help "Load marked Emacs Lisp files"]
+ ["Change Timestamp..." dired-do-touch
+ :help "Change timestamp of marked files"]
+ ["Change Mode..." dired-do-chmod
+ :help "Change mode (attributes) of marked files"]
+ ["Change Group..." dired-do-chgrp
+ :visible (not (memq system-type '(ms-dos windows-nt)))
+ :help "Change the group of marked files"]
+ ["Change Owner..." dired-do-chown
+ :visible (not (memq system-type '(ms-dos windows-nt)))
+ :help "Change the owner of marked files"]
+ ["Isearch Files..." dired-do-isearch
+ :help "Incrementally search marked files for string"]
+ ["Isearch Regexp Files..." dired-do-isearch-regexp
+ :help "Incrementally search marked files for regexp"]
+ ["Search Files..." dired-do-find-regexp
+ :help "Search marked files for matches of regexp"]
+ ["Query Replace in Files..." dired-do-find-regexp-and-replace
+ :help "Replace regexp matches in marked files"]
+ "---"
+ ["Encrypt..." epa-dired-do-encrypt
+ :help "Encrypt current or marked files"]
+ ["Sign..." epa-dired-do-sign
+ :help "Create digital signature of current or marked files"]
+ ["Verify" epa-dired-do-verify
+ :help "Verify digital signature of current or marked files"]
+ ["Decrypt..." epa-dired-do-decrypt
+ :help "Decrypt current or marked files"]
+ "---"
+ ["Display Image Thumbnails" image-dired-display-thumbs
+ :help "Display image thumbnails for current or marked image files"]
+ ["Add Image Comment..." image-dired-dired-comment-files
+ :help "Add image comment to current or marked files"]
+ ["Add Image Tags..." image-dired-tag-files
+ :help "Add image tags to current or marked files"]
+ ["Delete Image Tag..." image-dired-delete-tag
+ :help "Delete image tag from current or marked files"]))
+
+;;; Dired mode
+
;; Dired mode is suitable only for specially formatted data.
(put 'dired-mode 'mode-class 'special)
+(defvar grep-read-files-function)
;; Autoload cookie needed by desktop.el
;;;###autoload
(defun dired-mode (&optional dirname switches)
@@ -2193,24 +2245,13 @@ to relist the file at point or the marked files or a
subdirectory, or type \\[dired-build-subdir-alist] to parse the buffer
again for the directory tree.
-Customization variables (rename this buffer and type \\[describe-variable] on each line
-for more info):
+See the `dired' customization group for a list of user options.
- `dired-listing-switches'
- `dired-trivial-filenames'
- `dired-marker-char'
- `dired-del-marker'
- `dired-keep-marker-rename'
- `dired-keep-marker-copy'
- `dired-keep-marker-hardlink'
- `dired-keep-marker-symlink'
-
-Hooks (use \\[describe-variable] to see their documentation):
+This mode runs the following hooks:
`dired-before-readin-hook'
`dired-after-readin-hook'
`dired-mode-hook'
- `dired-load-hook'
Keybindings:
\\{dired-mode-map}"
@@ -2243,6 +2284,7 @@ Keybindings:
(setq-local font-lock-defaults
'(dired-font-lock-keywords t nil nil beginning-of-line))
(setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data)
+ (setq-local grep-read-files-function #'dired-grep-read-files)
(setq dired-switches-alist nil)
(hack-dir-local-variables-non-file-buffer) ; before sorting
(dired-sort-other dired-actual-switches t)
@@ -2252,14 +2294,16 @@ Keybindings:
(add-hook 'file-name-at-point-functions #'dired-file-name-at-point nil t)
(add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t)
(run-mode-hooks 'dired-mode-hook))
+
-;; Idiosyncratic dired commands that don't deal with marks.
+;;; Idiosyncratic dired commands that don't deal with marks
(defun dired-summary ()
"Summarize basic Dired commands and show recent Dired errors."
(interactive)
(dired-why)
- ;>> this should check the key-bindings and use substitute-command-keys if non-standard
+ ;; FIXME this should check the key-bindings and use
+ ;; substitute-command-keys if non-standard
(message
"d-elete, u-ndelete, x-punge, f-ind, o-ther window, R-ename, C-opy, h-elp"))
@@ -2280,6 +2324,10 @@ If the current buffer can be edited with Wdired, (i.e. the major
mode is `dired-mode'), call `wdired-change-to-wdired-mode'.
Otherwise, toggle `read-only-mode'."
(interactive)
+ (when (and (not (file-writable-p default-directory))
+ (not (y-or-n-p
+ "Directory isn't writable; edit anyway? ")))
+ (user-error "Directory %s isn't writable" default-directory))
(if (derived-mode-p 'dired-mode)
(wdired-change-to-wdired-mode)
(read-only-mode 'toggle)))
@@ -2336,7 +2384,7 @@ directory in another window."
(progn
(if other-window
(dired-other-window up)
- (dired up))
+ (dired--find-possibly-alternative-file up))
(dired-goto-file dir)))))
(defun dired-get-file-for-visit ()
@@ -2360,6 +2408,19 @@ directory in another window."
(defun dired-find-file ()
"In Dired, visit the file or directory named on this line."
(interactive)
+ (dired--find-possibly-alternative-file (dired-get-file-for-visit)))
+
+(defun dired--find-possibly-alternative-file (file)
+ "Find FILE, but respect `dired-kill-when-opening-new-dired-buffer'."
+ (if (and dired-kill-when-opening-new-dired-buffer
+ (file-directory-p file))
+ (progn
+ (set-buffer-modified-p nil)
+ (dired--find-file #'find-alternate-file file))
+ (dired--find-file #'find-file file)))
+
+(defun dired--find-file (find-file-function file)
+ "Call FIND-FILE-FUNCTION on FILE, but bind some relevant variables."
;; Bind `find-file-run-dired' so that the command works on directories
;; too, independent of the user's setting.
(let ((find-file-run-dired t)
@@ -2372,7 +2433,7 @@ directory in another window."
(if dired-auto-revert-buffer
nil
switch-to-buffer-preserve-window-point)))
- (find-file (dired-get-file-for-visit))))
+ (funcall find-file-function file)))
(defun dired-find-alternate-file ()
"In Dired, visit file or directory on current line via `find-alternate-file'.
@@ -2408,7 +2469,7 @@ respectively."
(select-window window)
(funcall find-dir-func file)))
(select-window window)
- (funcall find-file-func (file-name-sans-versions file t)))))
+ (dired--find-file find-file-func (file-name-sans-versions file t)))))
(defun dired-mouse-find-file-other-window (event)
"In Dired, visit the file or directory name you click on in another window."
@@ -2435,15 +2496,31 @@ Otherwise, display it in another buffer."
(defun dired-find-file-other-window ()
"In Dired, visit this file or directory in another window."
(interactive)
- (find-file-other-window (dired-get-file-for-visit)))
+ (dired--find-file #'find-file-other-window (dired-get-file-for-visit)))
(defun dired-display-file ()
"In Dired, display this file or directory in another window."
(interactive)
(display-buffer (find-file-noselect (dired-get-file-for-visit))
t))
+
-;;; Functions for extracting and manipulating file names in Dired buffers.
+;;; Functions for extracting and manipulating file names in Dired buffers
+
+(defun dired-unhide-subdir ()
+ (with-silent-modifications
+ (dired--unhide (dired-subdir-min) (dired-subdir-max))))
+
+(defun dired-subdir-hidden-p (dir)
+ (save-excursion
+ (dired-goto-subdir dir)
+ (dired--hidden-p)))
+
+(defun dired-subdir-min ()
+ (save-excursion
+ (if (not (dired-prev-subdir 0 t t))
+ (error "Not in a subdir!")
+ (point))))
(defun dired-get-filename (&optional localp no-error-if-not-filep)
"In Dired, return name of file mentioned on this line.
@@ -2455,10 +2532,17 @@ it occurs in the buffer, and a value of t means construct name relative to
Optional arg NO-ERROR-IF-NOT-FILEP means treat `.' and `..' as
regular filenames and return nil if no filename on this line.
Otherwise, an error occurs in these cases."
- (let (case-fold-search file p1 p2 already-absolute)
+ (let ((hidden (and dired-subdir-alist
+ (dired-subdir-hidden-p
+ (dired-current-directory))))
+ case-fold-search file p1 p2 already-absolute)
+ (when hidden
+ (dired-unhide-subdir))
(save-excursion
(if (setq p1 (dired-move-to-filename (not no-error-if-not-filep)))
(setq p2 (dired-move-to-end-of-filename no-error-if-not-filep))))
+ (when hidden
+ (dired-hide-subdir 1))
;; nil if no file on this line, but no-error-if-not-filep is t:
(if (setq file (and p1 p2 (buffer-substring p1 p2)))
(progn
@@ -2528,7 +2612,7 @@ Otherwise, an error occurs in these cases."
(concat (dired-current-directory localp) file)))))
(defun dired-string-replace-match (regexp string newtext
- &optional literal global)
+ &optional literal global)
"Replace first match of REGEXP in STRING with NEWTEXT.
If it does not match, nil is returned instead of the new string.
Optional arg LITERAL means to take NEWTEXT literally.
@@ -2539,7 +2623,7 @@ Optional arg GLOBAL means to replace all matches."
(let ((from-end (- (length string) (match-end 0))))
(setq ret (setq string (replace-match newtext t literal string)))
(setq start (- (length string) from-end))))
- ret)
+ ret)
(if (not (string-match regexp string 0))
nil
(replace-match newtext t literal string))))
@@ -2566,7 +2650,10 @@ unchanged."
(if (string-match (concat "^" (regexp-quote dir)) file)
(substring file (match-end 0))
file))
+
+;;; Mode to hide details
+
(define-minor-mode dired-hide-details-mode
"Toggle visibility of detailed information in current Dired buffer.
When this minor mode is enabled, details such as file ownership and
@@ -2603,6 +2690,7 @@ See options: `dired-hide-details-hide-symlink-targets' and
'add-to-invisibility-spec
'remove-from-invisibility-spec)
'dired-hide-details-link))
+
;;; Functions to hide/unhide text
@@ -2632,7 +2720,7 @@ See options: `dired-hide-details-hide-symlink-targets' and
(progn (goto-char end) (line-end-position))
'(invisible))))
-;;; Functions for finding the file name in a dired buffer line.
+;;; Functions for finding the file name in a dired buffer line
(defvar dired-permission-flags-regexp
"\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"
@@ -2723,15 +2811,15 @@ If EOL, it should be an position to use instead of
(or no-error
(not (eq opoint (point)))
(error "%s" (if hidden
- (substitute-command-keys
- "File line is hidden, type \\[dired-hide-subdir] to unhide")
- "No file on this line")))
+ (substitute-command-keys
+ "File line is hidden, type \\[dired-hide-subdir] to unhide")
+ "No file on this line")))
(if (eq opoint (point))
nil
(point)))))
-;;; COPY NAMES OF MARKED FILES INTO KILL-RING.
+;;; Copy names of marked files into kill-ring
(defun dired-copy-filename-as-kill (&optional arg)
"Copy names of marked (or next ARG) files into the kill ring.
@@ -2765,15 +2853,17 @@ You can then feed the file name(s) to other commands with \\[yank]."
(message "%s" string))))
-;; Keeping Dired buffers in sync with the filesystem and with each other
-
-(defun dired-buffers-for-dir (dir &optional file)
-;; Return a list of buffers for DIR (top level or in-situ subdir).
-;; If FILE is non-nil, include only those whose wildcard pattern (if any)
-;; matches FILE.
-;; The list is in reverse order of buffer creation, most recent last.
-;; As a side effect, killed dired buffers for DIR are removed from
-;; dired-buffers.
+;;; Keeping Dired buffers in sync with the filesystem and with each other
+
+(defun dired-buffers-for-dir (dir &optional file subdirs)
+ "Return a list of buffers for DIR (top level or in-situ subdir).
+If FILE is non-nil, include only those whose wildcard pattern (if any)
+matches FILE.
+If SUBDIRS is non-nil, also include the dired buffers of
+directories below DIR.
+The list is in reverse order of buffer creation, most recent last.
+As a side effect, killed dired buffers for DIR are removed from
+dired-buffers."
(setq dir (file-name-as-directory dir))
(let (result buf)
(dolist (elt dired-buffers)
@@ -2782,19 +2872,20 @@ You can then feed the file name(s) to other commands with \\[yank]."
((null (buffer-name buf))
;; Buffer is killed - clean up:
(setq dired-buffers (delq elt dired-buffers)))
- ((dired-in-this-tree-p dir (car elt))
+ ((file-in-directory-p (car elt) dir)
(with-current-buffer buf
- (and (assoc dir dired-subdir-alist)
- (or (null file)
- (if (stringp dired-directory)
- (let ((wildcards (file-name-nondirectory
- dired-directory)))
- (or (zerop (length wildcards))
- (string-match-p (dired-glob-regexp wildcards)
- file)))
- (member (expand-file-name file dir)
- (cdr dired-directory))))
- (setq result (cons buf result)))))))
+ (when (and (or subdirs
+ (assoc dir dired-subdir-alist))
+ (or (null file)
+ (if (stringp dired-directory)
+ (let ((wildcards (file-name-nondirectory
+ dired-directory)))
+ (or (zerop (length wildcards))
+ (string-match-p (dired-glob-regexp wildcards)
+ file)))
+ (member (expand-file-name file dir)
+ (cdr dired-directory)))))
+ (setq result (cons buf result)))))))
result))
(defun dired-glob-regexp (pattern)
@@ -2831,8 +2922,6 @@ You can then feed the file name(s) to other commands with \\[yank]."
(substring pattern matched-in-pattern))
"\\'")))
-
-
(defun dired-advertise ()
;;"Advertise in variable `dired-buffers' that we dired `default-directory'."
;; With wildcards we actually advertise too much.
@@ -2850,15 +2939,15 @@ You can then feed the file name(s) to other commands with \\[yank]."
;; Removing is also done as a side-effect in dired-buffer-for-dir.
(setq dired-buffers
(delq (assoc (expand-file-name dir) dired-buffers) dired-buffers)))
-
-;; Tree Dired
-;;; utility functions
+
+;;; Utility functions
(defun dired-in-this-tree-p (file dir)
;;"Is FILE part of the directory tree starting at DIR?"
(let (case-fold-search)
(string-match-p (concat "^" (regexp-quote dir)) file)))
+(make-obsolete 'dired-in-this-tree-p 'file-in-directory-p "28.1")
(define-obsolete-function-alias 'dired-in-this-tree
'dired-in-this-tree-p "27.1")
@@ -2879,8 +2968,8 @@ You can then feed the file name(s) to other commands with \\[yank]."
(beginning-of-line) ; alist stores b-o-l positions
(and (zerop (- (point)
(cdr (assoc cur-dir
- dired-subdir-alist))))
- cur-dir))))
+ dired-subdir-alist))))
+ cur-dir))))
(define-obsolete-function-alias 'dired-get-subdir-min 'cdr "27.1")
@@ -2989,11 +3078,11 @@ instead of `dired-actual-switches'."
new-dir-name)
(setq new-dir-name res)))
(dired-alist-add-1 new-dir-name
- ;; Place a sub directory boundary between lines.
- (save-excursion
- (goto-char (match-beginning 0))
- (beginning-of-line)
- (point-marker)))))
+ ;; Place a sub directory boundary between lines.
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (beginning-of-line)
+ (point-marker)))))
(if (and (> count 1) (called-interactively-p 'interactive))
(message "Buffer includes %d directories" count)))
;; We don't need to sort it because it is in buffer order per
@@ -3112,7 +3201,7 @@ It runs the hook `dired-initial-position-hook'."
(dired-goto-subdir dirname))
(if dired-trivial-filenames (dired-goto-next-nontrivial-file))
(run-hooks 'dired-initial-position-hook))
-
+
;; These are hooks which make tree dired work.
;; They are in this file because other parts of dired need to call them.
;; But they don't call the rest of tree dired unless there are subdirs loaded.
@@ -3151,8 +3240,9 @@ is the directory where the file on this line resides."
(if (or (null (cdr dired-subdir-alist)) (not (dired-next-subdir 1 t t)))
(point-max)
(point))))
+
-;; Deleting files
+;;; Deleting files
(defcustom dired-recursive-deletes 'top
"Whether Dired deletes directories recursively.
@@ -3170,8 +3260,8 @@ Any other value means to ask for each directory."
(const :tag "Confirm for each top directory only" top))
:group 'dired)
-;; Match anything but `.' and `..'.
-(defvar dired-re-no-dot (rx (or (not ".") "...")))
+(define-obsolete-variable-alias 'dired-re-no-dot
+ 'directory-files-no-dot-files-regexp "28.1")
;; Delete file, possibly delete a directory and all its files.
;; This function is useful outside of dired. One could change its name
@@ -3193,7 +3283,9 @@ TRASH non-nil means to trash the file instead of deleting, provided
;; but more efficient
(if (not (eq t (car (file-attributes file))))
(delete-file file trash)
- (let* ((empty-dir-p (null (directory-files file t dired-re-no-dot))))
+ (let* ((empty-dir-p (null (directory-files
+ file t
+ directory-files-no-dot-files-regexp))))
(if (and recursive (not empty-dir-p))
(unless (eq recursive 'always)
(let ((prompt
@@ -3225,15 +3317,19 @@ non-empty directories is allowed."
(interactive)
(let* ((dired-marker-char dired-del-marker)
(regexp (dired-marker-regexp))
- case-fold-search)
+ case-fold-search markers)
(if (save-excursion (goto-char (point-min))
(re-search-forward regexp nil t))
(dired-internal-do-deletions
(nreverse
;; this can't move point since ARG is nil
- (dired-map-over-marks (cons (dired-get-filename) (point))
+ (dired-map-over-marks (cons (dired-get-filename)
+ (let ((m (point-marker)))
+ (push m markers)
+ m))
nil))
nil t)
+ (dolist (m markers) (set-marker m nil))
(or nomessage
(message "(No deletions requested)")))))
@@ -3244,12 +3340,17 @@ non-empty directories is allowed."
;; This is more consistent with the file marking feature than
;; dired-do-flagged-delete.
(interactive "P")
- (dired-internal-do-deletions
- (nreverse
- ;; this may move point if ARG is an integer
- (dired-map-over-marks (cons (dired-get-filename) (point))
- arg))
- arg t))
+ (let (markers)
+ (dired-internal-do-deletions
+ (nreverse
+ ;; this may move point if ARG is an integer
+ (dired-map-over-marks (cons (dired-get-filename)
+ (let ((m (point-marker)))
+ (push m markers)
+ m))
+ arg))
+ arg t)
+ (dolist (m markers) (set-marker m nil))))
(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p?
@@ -3257,11 +3358,6 @@ non-empty directories is allowed."
;; L is an alist of files to delete, with their buffer positions.
;; ARG is the prefix arg.
;; Filenames are absolute.
- ;; (car L) *must* be the *last* (bottommost) file in the dired buffer.
- ;; That way as changes are made in the buffer they do not shift the
- ;; 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 #'car l))
(count (length l))
(succ 0)
@@ -3282,9 +3378,10 @@ non-empty directories is allowed."
(make-progress-reporter
(if trashing "Trashing..." "Deleting...")
succ count))
- failures) ;; files better be in reverse order for this loop!
+ failures)
(while l
- (goto-char (cdr (car l)))
+ (goto-char (marker-position (cdr (car l))))
+ (dired-move-to-filename)
(let ((inhibit-read-only t))
(condition-case err
(let ((fn (car (car l))))
@@ -3314,24 +3411,34 @@ non-empty directories is allowed."
(defun dired-fun-in-all-buffers (directory file fun &rest args)
"In all buffers dired'ing DIRECTORY, run FUN with ARGS.
If the buffer has a wildcard pattern, check that it matches FILE.
-(FILE does not include a directory component.)
+\(FILE does not include a directory component.)
FILE may be nil, in which case ignore it.
Return list of buffers where FUN succeeded (i.e., returned non-nil)."
(let (success-list)
(dolist (buf (dired-buffers-for-dir (expand-file-name directory) file))
(with-current-buffer buf
- (if (apply fun args)
- (push buf success-list))))
+ (when (apply fun args)
+ (push (buffer-name buf) success-list))))
;; FIXME: AFAICT, this return value is not used by any of the callers!
success-list))
;; Delete the entry for FILE from
-(defun dired-delete-entry (file)
+(defun dired-remove-entry (file)
+ "Remove entry FILE in the current dired buffer.
+Note this doesn't delete FILE in the file system.
+See `dired-delete-file' in case you wish that."
(save-excursion
(and (dired-goto-file file)
(let ((inhibit-read-only t))
(delete-region (progn (beginning-of-line) (point))
- (save-excursion (forward-line 1) (point))))))
+ (line-beginning-position 2))))))
+
+(defun dired-delete-entry (file)
+ "Remove entry FILE in the current dired buffer.
+Like `dired-remove-entry' followed by `dired-clean-up-after-deletion'.
+Note this doesn't delete FILE in the file system.
+See `dired-delete-file' in case you wish that."
+ (dired-remove-entry file)
(dired-clean-up-after-deletion file))
(defvar dired-clean-up-buffers-too)
@@ -3351,23 +3458,32 @@ confirmation. To disable the confirmation, see
(when (and (featurep 'dired-x) dired-clean-up-buffers-too)
(let ((buf (get-file-buffer fn)))
(and buf
- (and dired-clean-confirm-killing-deleted-buffers
- (funcall #'y-or-n-p
- (format "Kill buffer of %s, too? "
- (file-name-nondirectory fn))))
+ (or (and dired-clean-confirm-killing-deleted-buffers
+ (funcall #'y-or-n-p
+ (format "Kill buffer of %s, too? "
+ (file-name-nondirectory fn))))
+ (not dired-clean-confirm-killing-deleted-buffers))
(kill-buffer buf)))
- (let ((buf-list (dired-buffers-for-dir (expand-file-name fn))))
+ (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)
+ nil 'subdirs)))
(and buf-list
- (and dired-clean-confirm-killing-deleted-buffers
- (y-or-n-p (format (ngettext "Kill Dired buffer of %s, too? "
- "Kill Dired buffers of %s, too? "
- (length buf-list))
- (file-name-nondirectory fn))))
+ (or (and dired-clean-confirm-killing-deleted-buffers
+ (y-or-n-p
+ (format
+ (ngettext "Kill Dired buffer of %s, too? "
+ "Kill Dired buffers of %s, too? "
+ (length buf-list))
+ (file-name-nondirectory
+ ;; FN may end in a / if `dired-listing-switches'
+ ;; contains -p, so we need to strip that
+ ;; (bug#48301).
+ (directory-file-name fn)))))
+ (not dired-clean-confirm-killing-deleted-buffers))
(dolist (buf buf-list)
(kill-buffer buf))))))
-;; Confirmation
+;;; Confirmation
(defun dired-marker-regexp ()
(concat "^" (regexp-quote (char-to-string dired-marker-char))))
@@ -3460,33 +3576,35 @@ argument or confirmation)."
;; Mark *Marked Files* window as softly-dedicated, to prevent
;; other buffers e.g. *Completions* from reusing it (bug#17554).
(display-buffer-mark-dedicated 'soft))
- (with-displayed-buffer-window
+ (with-current-buffer-window
buffer
- (cons 'display-buffer-below-selected
- '((window-height . fit-window-to-buffer)
- (preserve-size . (nil . t))))
+ `(display-buffer-below-selected
+ (window-height . fit-window-to-buffer)
+ (preserve-size . (nil . t))
+ (body-function
+ . ,#'(lambda (_window)
+ ;; Handle (t FILE) just like (FILE), here. That value is
+ ;; used (only in some cases), to mean just one file that was
+ ;; marked, rather than the current line file.
+ (dired-format-columns-of-files
+ (if (eq (car files) t) (cdr files) files))
+ (remove-text-properties (point-min) (point-max)
+ '(mouse-face nil help-echo nil))
+ (setq tab-line-exclude nil))))
#'(lambda (window _value)
(with-selected-window window
(unwind-protect
(apply function args)
(when (window-live-p window)
- (quit-restore-window window 'kill)))))
- ;; Handle (t FILE) just like (FILE), here. That value is
- ;; used (only in some cases), to mean just one file that was
- ;; marked, rather than the current line file.
- (with-current-buffer buffer
- (dired-format-columns-of-files
- (if (eq (car files) t) (cdr files) files))
- (remove-text-properties (point-min) (point-max)
- '(mouse-face nil help-echo nil))
- (setq tab-line-exclude nil))))))
+ (quit-restore-window window 'kill)))))))))
(defun dired-format-columns-of-files (files)
(let ((beg (point)))
(completion--insert-strings files)
(put-text-property beg (point) 'mouse-face nil)))
+
-;; Commands to mark or flag file(s) at or near current line.
+;;; Commands to mark or flag file(s) at or near current line
(defun dired-repeat-over-lines (arg function)
;; This version skips non-file lines.
@@ -3578,7 +3696,8 @@ no ARGth marked file is found before this line."
(defun dired-mark (arg &optional interactive)
"Mark the file at point in the Dired buffer.
-If the region is active, mark all files in the region.
+If the region is active in Transient Mark mode, mark all files
+in the region if `dired-mark-region' is non-nil.
Otherwise, with a prefix arg, mark files on the next ARG lines.
If on a subdir headerline, mark all its files except `.' and `..'.
@@ -3589,13 +3708,20 @@ this subdir."
(interactive (list current-prefix-arg t))
(cond
;; Mark files in the active region.
- ((and interactive (use-region-p))
+ ((and interactive dired-mark-region
+ (region-active-p)
+ (> (region-end) (region-beginning)))
(save-excursion
(let ((beg (region-beginning))
(end (region-end)))
(dired-mark-files-in-region
(progn (goto-char beg) (line-beginning-position))
- (progn (goto-char end) (line-beginning-position))))))
+ (progn (goto-char end)
+ (if (if (eq dired-mark-region 'line)
+ (not (bolp))
+ (get-text-property (1- (point)) 'dired-filename))
+ (line-end-position)
+ (line-beginning-position)))))))
;; Mark subdir files from the subdir headerline.
((dired-get-subdir)
(save-excursion (dired-mark-subdir-files)))
@@ -3643,12 +3769,18 @@ in the active region."
"Toggle marks: marked files become unmarked, and vice versa.
Flagged files (indicated with flags such as `C' and `D', not
with `*') are not affected, and `.' and `..' are never toggled.
-As always, hidden subdirs are not affected."
+As always, hidden subdirs are not affected.
+
+In Transient Mark mode, if the mark is active, operate on the contents
+of the region if `dired-mark-region' is non-nil. Otherwise, operate
+on the whole buffer."
(interactive)
(save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t))
- (while (not (eobp))
+ (let ((inhibit-read-only t)
+ (beg (dired-mark--region-beginning))
+ (end (dired-mark--region-end)))
+ (goto-char beg)
+ (while (< (point) end)
(or (dired-between-files)
(looking-at-p dired-re-dot)
;; use subst instead of insdel because it does not move
@@ -3660,8 +3792,9 @@ As always, hidden subdirs are not affected."
(list ?\s dired-marker-char)
(list dired-marker-char ?\s))))
(forward-line 1)))))
+
-;;; Commands to mark or flag files based on their characteristics or names.
+;;; Commands to mark or flag files based on their characteristics or names
(defvar dired-regexp-history nil
"History list of regular expressions used in Dired commands.")
@@ -3676,6 +3809,9 @@ As always, hidden subdirs are not affected."
A prefix argument means to unmark them instead.
`.' and `..' are never marked.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil.
+
REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for
object files--just `.o' will mark more than you might think."
(interactive
@@ -3714,19 +3850,22 @@ object files--just `.o' will mark more than you might think."
when (stringp file)
sum (file-attribute-size (file-attributes file)))))
(if (zerop nmarked)
- (message "No marked files"))
- (message "%d marked file%s (%s total size)"
- nmarked
- (if (= nmarked 1)
- ""
- "s")
- (funcall byte-count-to-string-function size))))
+ (message "No marked files")
+ (message "%d marked file%s (%s total size)"
+ nmarked
+ (if (= nmarked 1)
+ ""
+ "s")
+ (funcall byte-count-to-string-function size)))))
(defun dired-mark-files-containing-regexp (regexp &optional marker-char)
"Mark all files with contents containing REGEXP for use in later commands.
A prefix argument means to unmark them instead.
`.' and `..' are never marked.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil.
+
Note that if a file is visited in an Emacs buffer, and
`dired-always-read-filesystem' is nil, this command will
look in the buffer without revisiting the file, so the results might
@@ -3756,8 +3895,7 @@ since it was last visited."
(with-temp-buffer
(insert-file-contents fn)
(goto-char (point-min))
- (re-search-forward regexp nil t))))
- )))
+ (re-search-forward regexp nil t)))))))
"matching file")))
(defun dired-flag-files-regexp (regexp)
@@ -3771,14 +3909,18 @@ The match is against the non-directory part of the filename. Use `^'
(defun dired-mark-symlinks (unflag-p)
"Mark all symbolic links.
-With prefix argument, unmark or unflag all those files."
+With prefix argument, unmark or unflag all those files.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil."
(interactive "P")
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-sym) "symbolic link")))
(defun dired-mark-directories (unflag-p)
"Mark all directory file lines except `.' and `..'.
-With prefix argument, unmark or unflag all those files."
+With prefix argument, unmark or unflag all those files.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil."
(interactive "P")
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (and (looking-at-p dired-re-dir)
@@ -3787,7 +3929,9 @@ With prefix argument, unmark or unflag all those files."
(defun dired-mark-executables (unflag-p)
"Mark all executable files.
-With prefix argument, unmark or unflag all those files."
+With prefix argument, unmark or unflag all those files.
+If the region is active in Transient Mark mode, mark files
+only in the active region if `dired-mark-region' is non-nil."
(interactive "P")
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-exe) "executable file")))
@@ -3797,7 +3941,9 @@ With prefix argument, unmark or unflag all those files."
(defun dired-flag-auto-save-files (&optional unflag-p)
"Flag for deletion files whose names suggest they are auto save files.
-A prefix argument says to unmark or unflag those files instead."
+A prefix argument says to unmark or unflag those files instead.
+If the region is active in Transient Mark mode, flag files
+only in the active region if `dired-mark-region' is non-nil."
(interactive "P")
(let ((dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
@@ -3837,7 +3983,9 @@ A prefix argument says to unmark or unflag those files instead."
(defun dired-flag-backup-files (&optional unflag-p)
"Flag all backup files (names ending with `~') for deletion.
-With prefix argument, unmark or unflag these files."
+With prefix argument, unmark or unflag these files.
+If the region is active in Transient Mark mode, flag files
+only in the active region if `dired-mark-region' is non-nil."
(interactive "P")
(let ((dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
@@ -3860,25 +4008,28 @@ With prefix argument, unmark or unflag these files."
(defun dired-change-marks (&optional old new)
"Change all OLD marks to NEW marks.
OLD and NEW are both characters used to mark files."
+ (declare (advertised-calling-convention (old new) "28.1"))
(interactive
(let* ((cursor-in-echo-area t)
(old (progn (message "Change (old mark): ") (read-char)))
(new (progn (message "Change %c marks to (new mark): " old)
(read-char))))
(list old new)))
- (if (or (eq old ?\r) (eq new ?\r))
- (ding)
- (let ((string (format "\n%c" old))
- (inhibit-read-only t))
- (save-excursion
- (goto-char (point-min))
- (while (search-forward string nil t)
- (if (if (= old ?\s)
- (save-match-data
- (dired-get-filename 'no-dir t))
- t)
- (subst-char-in-region (match-beginning 0)
- (match-end 0) old new)))))))
+ (dolist (c (list new old))
+ (if (or (not (char-displayable-p c))
+ (eq c ?\r))
+ (user-error "Invalid mark character: `%c'" c)))
+ (let ((string (format "\n%c" old))
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char (point-min))
+ (while (search-forward string nil t)
+ (if (if (= old ?\s)
+ (save-match-data
+ (dired-get-filename 'no-dir t))
+ t)
+ (subst-char-in-region (match-beginning 0)
+ (match-end 0) old new))))))
(defun dired-unmark-all-marks ()
"Remove all marks from all files in the Dired buffer."
@@ -3919,8 +4070,9 @@ Type SPC or `y' to unmark one file, DEL or `n' to skip to next,
(message (if (= count 1) "1 mark removed"
"%d marks removed")
count))))
+
-;; Logging failures operating on files, and showing the results.
+;;; Logging failures operating on files, and showing the results
(defvar dired-log-buffer "*Dired log*")
@@ -3985,6 +4137,7 @@ or nil if file names are not applicable."
;; Log a summary describing a bunch of errors.
(dired-log (concat "\n" string "\n"))
(dired-log t))
+
;;; Sorting
@@ -4019,22 +4172,51 @@ format, use `\\[universal-argument] \\[dired]'.")
"Non-nil means the Dired sort command is disabled.
The idea is to set this buffer-locally in special Dired buffers.")
+(defcustom dired-switches-in-mode-line nil
+ "How to indicate `dired-actual-switches' in mode-line.
+Possible values:
+ * `nil': Indicate name-or-date sort order, if possible.
+ Else show full switches.
+ * `as-is': Show full switches.
+ * Integer: Show only the first N chars of full switches.
+ * Function: Pass `dired-actual-switches' as arg and show result."
+ :group 'dired
+ :version "28.1"
+ :type '(choice
+ (const :tag "Indicate by name or date, else full" nil)
+ (const :tag "Show full switches" as-is)
+ (integer :tag "Show first N chars of switches" :value 10)
+ (function :tag "Format with function" :value identity)))
+
(defun dired-sort-set-mode-line ()
- ;; Set mode line display according to dired-actual-switches.
- ;; Mode line display of "by name" or "by date" guarantees the user a
- ;; match with the corresponding regexps. Non-matching switches are
- ;; shown literally.
+ "Set mode-line according to option `dired-switches-in-mode-line'."
(when (eq major-mode 'dired-mode)
(setq mode-name
- (let (case-fold-search)
- (cond ((string-match-p
- dired-sort-by-name-regexp dired-actual-switches)
- "Dired by name")
- ((string-match-p
- dired-sort-by-date-regexp dired-actual-switches)
- "Dired by date")
- (t
- (concat "Dired " dired-actual-switches)))))
+ (let ((case-fold-search nil))
+ (if dired-switches-in-mode-line
+ (concat
+ "Dired"
+ (cond ((integerp dired-switches-in-mode-line)
+ (let* ((l1 (length dired-actual-switches))
+ (xs (substring
+ dired-actual-switches
+ 0 (min l1 dired-switches-in-mode-line)))
+ (l2 (length xs)))
+ (if (zerop l2)
+ xs
+ (concat " " xs (and (< l2 l1) "…")))))
+ ((functionp dired-switches-in-mode-line)
+ (format " %s" (funcall
+ dired-switches-in-mode-line
+ dired-actual-switches)))
+ (t (concat " " dired-actual-switches))))
+ (cond ((string-match-p dired-sort-by-name-regexp
+ dired-actual-switches)
+ "Dired by name")
+ ((string-match-p dired-sort-by-date-regexp
+ dired-actual-switches)
+ "Dired by date")
+ (t (concat "Dired " dired-actual-switches))))))
(force-mode-line-update)))
(define-obsolete-function-alias 'dired-sort-set-modeline
@@ -4082,11 +4264,10 @@ With a prefix argument, edit the current listing switches instead."
(dired-sort-set-mode-line)
(revert-buffer))
-;; Some user code loads dired especially for this.
-;; Don't do that--use replace-regexp-in-string instead.
(defun dired-replace-in-string (regexp newtext string)
;; Replace REGEXP with NEWTEXT everywhere in STRING and return result.
;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.
+ (declare (obsolete replace-regexp-in-string "28.1"))
(let ((result "") (start 0) mb me)
(while (string-match regexp string start)
(setq mb (match-beginning 0)
@@ -4138,9 +4319,9 @@ To be called first in body of `dired-sort-other', etc."
;; No pre-R subdir alist, so revert to main directory
;; listing:
(list (car (reverse dired-subdir-alist))))))))
-
-;;;; Drag and drop support
+
+;;; Drag and drop support
(defcustom dired-recursive-copies 'top
"Whether Dired copies directories recursively.
@@ -4242,9 +4423,9 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(let ((local-file (dnd-get-local-file-uri uri)))
(if local-file (dired-dnd-handle-local-file local-file action)
nil)))
-
-;;;; Desktop support
+
+;;; Desktop support
(eval-when-compile (require 'desktop))
(declare-function desktop-file-name "desktop" (filename dirname))
@@ -4261,10 +4442,10 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(desktop-file-name dired-directory dirname))
;; Subdirectories in `dired-subdir-alist'.
(cdr
- (nreverse
- (mapcar
- (lambda (f) (desktop-file-name (car f) dirname))
- dired-subdir-alist)))))
+ (nreverse
+ (mapcar
+ (lambda (f) (desktop-file-name (car f) dirname))
+ dired-subdir-alist)))))
(defun dired-restore-desktop-buffer (_file-name
_buffer-name
@@ -4289,6 +4470,70 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(add-to-list 'desktop-buffer-mode-handlers
'(dired-mode . dired-restore-desktop-buffer))
+
+;;; Jump to Dired
+
+(defvar archive-superior-buffer)
+(defvar tar-superior-buffer)
+
+;;;###autoload
+(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.
+When OTHER-WINDOW is non-nil, jump to Dired buffer in other window.
+When FILE-NAME is non-nil, jump to its line in Dired.
+Interactively with prefix argument, read FILE-NAME."
+ (interactive
+ (list nil (and current-prefix-arg
+ (read-file-name "Jump to Dired file: "))))
+ (cond
+ ((and (bound-and-true-p archive-subfile-mode)
+ (buffer-live-p archive-superior-buffer))
+ (switch-to-buffer archive-superior-buffer))
+ ((and (bound-and-true-p tar-subfile-mode)
+ (buffer-live-p tar-superior-buffer))
+ (switch-to-buffer tar-superior-buffer))
+ (t
+ ;; Expand file-name before `dired-goto-file' call:
+ ;; `dired-goto-file' requires its argument to be an absolute
+ ;; file name; the result of `read-file-name' could be
+ ;; an abbreviated file name (Bug#24409).
+ (let* ((file (or (and file-name (expand-file-name file-name))
+ buffer-file-name))
+ (dir (if file (file-name-directory file) default-directory)))
+ (if (and (eq major-mode 'dired-mode) (null file-name))
+ (progn
+ (setq dir (dired-current-directory))
+ (dired-up-directory other-window)
+ (unless (dired-goto-file dir)
+ ;; refresh and try again
+ (dired-insert-subdir (file-name-directory dir))
+ (dired-goto-file dir)))
+ (if other-window
+ (dired-other-window dir)
+ (dired dir))
+ (if file
+ (or (dired-goto-file file)
+ ;; refresh and try again
+ (progn
+ (dired-insert-subdir (file-name-directory file))
+ (dired-goto-file file))
+ ;; Toggle omitting, if it is on, and try again.
+ (when (bound-and-true-p dired-omit-mode)
+ (dired-omit-mode)
+ (dired-goto-file file)))))))))
+
+;;;###autoload
+(defun dired-jump-other-window (&optional file-name)
+ "Like \\[dired-jump] (`dired-jump') but in other window."
+ (interactive
+ (list (and current-prefix-arg
+ (read-file-name "Jump to Dired file: "))))
+ (dired-jump t file-name))
+
(provide 'dired)
(run-hooks 'dired-load-hook) ; for your customizations
diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el
index 012a5a97540..be8db75c967 100644
--- a/lisp/dirtrack.el
+++ b/lisp/dirtrack.el
@@ -1,4 +1,4 @@
-;;; dirtrack.el --- Directory Tracking by watching the prompt
+;;; dirtrack.el --- Directory Tracking by watching the prompt -*- lexical-binding: t -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -77,7 +77,7 @@
;; Running under tcsh:
;; (setq-default dirtrack-list '("^%E \\([^ ]+\\)" 1))
;;
-;; It might be worth mentioning in your file that emacs sources start up
+;; It might be worth mentioning in your file that Emacs sources start up
;; files of the form: ~/.emacs_<SHELL> where <SHELL> is the name of the
;; shell. So for example, I have the following in ~/.emacs_tcsh:
;;
@@ -123,7 +123,6 @@
"List for directory tracking.
First item is a regexp that describes where to find the path in a prompt.
Second is a number, the regexp group to match."
- :group 'dirtrack
:type '(sexp (regexp :tag "Prompt Expression")
(integer :tag "Regexp Group"))
:version "24.1")
@@ -132,12 +131,10 @@ Second is a number, the regexp group to match."
(defcustom dirtrack-debug nil
"If non-nil, the function `dirtrack' will report debugging info."
- :group 'dirtrack
:type 'boolean)
(defcustom dirtrack-debug-buffer "*Directory Tracking Log*"
"Buffer in which to write directory tracking debug information."
- :group 'dirtrack
:type 'string)
(defcustom dirtrack-directory-function
@@ -145,19 +142,16 @@ Second is a number, the regexp group to match."
'dirtrack-windows-directory-function
'file-name-as-directory)
"Function to apply to the prompt directory for comparison purposes."
- :group 'dirtrack
:type 'function)
(defcustom dirtrack-canonicalize-function
(if (memq system-type '(ms-dos windows-nt cygwin))
'downcase 'identity)
"Function to apply to the default directory for comparison purposes."
- :group 'dirtrack
:type 'function)
(defcustom dirtrack-directory-change-hook nil
"Hook that is called when a directory change is made."
- :group 'dirtrack
:type 'hook)
@@ -190,18 +184,15 @@ working directory at all times, and that you set the variable
This is an alternative to `shell-dirtrack-mode', which works by
tracking `cd' and similar commands which change the shell working
directory."
- nil nil nil
+ :lighter nil
(if dirtrack-mode
(add-hook 'comint-preoutput-filter-functions 'dirtrack nil t)
(remove-hook 'comint-preoutput-filter-functions 'dirtrack t)))
-(define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode
- "23.1")
-(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1")
(define-minor-mode dirtrack-debug-mode
"Toggle Dirtrack debugging."
- nil nil nil
+ :lighter nil
(if dirtrack-debug-mode
(display-buffer (get-buffer-create dirtrack-debug-buffer))))
diff --git a/lisp/disp-table.el b/lisp/disp-table.el
index 99860d8eb62..a7fc8f0a76e 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -1,4 +1,4 @@
-;;; disp-table.el --- functions for dealing with char tables
+;;; disp-table.el --- functions for dealing with char tables -*- lexical-binding: t; -*-
;; Copyright (C) 1987, 1994-1995, 1999, 2001-2021 Free Software
;; Foundation, Inc.
@@ -220,8 +220,6 @@ for a graphical frame."
;;;###autoload
(defun make-glyph-code (char &optional face)
"Return a glyph code representing char CHAR with face FACE."
- ;; Due to limitations on Emacs integer values, faces with
- ;; face id greater that 512 are silently ignored.
(if (not face)
char
(let ((fid (face-id face)))
diff --git a/lisp/display-fill-column-indicator.el b/lisp/display-fill-column-indicator.el
index d26b6bc8569..50252af4533 100644
--- a/lisp/display-fill-column-indicator.el
+++ b/lisp/display-fill-column-indicator.el
@@ -59,12 +59,13 @@ See Info node `Displaying Boundaries' for details."
(progn
(setq display-fill-column-indicator t)
(unless display-fill-column-indicator-character
- (if (and (char-displayable-p ?\u2502)
- (or (not (display-graphic-p))
- (eq (aref (query-font (car (internal-char-font nil ?\u2502))) 0)
- (face-font 'default))))
- (setq display-fill-column-indicator-character ?\u2502)
- (setq display-fill-column-indicator-character ?|))))
+ (setq display-fill-column-indicator-character
+ (if (and (char-displayable-p ?\u2502)
+ (or (not (display-graphic-p))
+ (eq (aref (query-font (car (internal-char-font nil ?\u2502))) 0)
+ (face-font 'default))))
+ ?\u2502
+ ?|))))
(setq display-fill-column-indicator nil)))
(defun display-fill-column-indicator--turn-on ()
@@ -76,8 +77,7 @@ See Info node `Displaying Boundaries' for details."
;;;###autoload
(define-globalized-minor-mode global-display-fill-column-indicator-mode
display-fill-column-indicator-mode display-fill-column-indicator--turn-on
- ;; See bug#41145
- :group 'display-fill-column-indicator)
+ :predicate '((not special-mode) t))
(provide 'display-fill-column-indicator)
diff --git a/lisp/display-line-numbers.el b/lisp/display-line-numbers.el
index a6fa813afe7..72928492bb2 100644
--- a/lisp/display-line-numbers.el
+++ b/lisp/display-line-numbers.el
@@ -56,12 +56,17 @@ See `display-line-numbers' for value options."
(defcustom display-line-numbers-width-start nil
"If non-nil, count number of lines to use for line number width.
-When `display-line-numbers-mode' is turned on,
-`display-line-numbers-width' is set to the minimum width necessary
-to display all line numbers in the buffer."
+When `display-line-numbers-mode' is turned on, if this option is
+non-nil, `display-line-numbers-width' is set up front to a width
+necessary to display all line numbers in the buffer. If the value
+is a positive number, it is interpreted as extra lines to account
+for when computing the required width; this should be set to the
+number of lines in the tallest window in which you want to prevent
+the line-number width from changing."
:group 'display-line-numbers
- :type 'boolean
- :version "26.1")
+ :type '(choice (boolean :tag "Minimum width for buffer's line count")
+ (integer :tag "Number of extra lines to account for"))
+ :version "28.1")
(defun display-line-numbers-update-width ()
"Prevent the line number width from shrinking."
@@ -83,7 +88,11 @@ the mode is on, set `display-line-numbers' directly."
(when display-line-numbers-width-start
(setq display-line-numbers-width
(length (number-to-string
- (count-lines (point-min) (point-max))))))
+ (+ (count-lines (point-min) (point-max))
+ (if (and (numberp display-line-numbers-width-start)
+ (> display-line-numbers-width-start 0))
+ display-line-numbers-width-start
+ 0))))))
(when display-line-numbers-grow-only
(add-hook 'pre-command-hook #'display-line-numbers-update-width nil t))
(setq display-line-numbers display-line-numbers-type))
diff --git a/lisp/dnd.el b/lisp/dnd.el
index e1662a022be..e641b2843a9 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -1,4 +1,4 @@
-;;; dnd.el --- drag and drop support
+;;; dnd.el --- drag and drop support -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -33,6 +33,9 @@
;;; Customizable variables
+(defgroup dnd nil
+ "Handling data from drag and drop."
+ :group 'environment)
;;;###autoload
(defcustom dnd-protocol-alist
@@ -54,14 +57,13 @@ If no match is found, the URL is inserted as text by calling `dnd-insert-text'.
The function shall return the action done (move, copy, link or private)
if some action was made, or nil if the URL is ignored."
:version "22.1"
- :type '(repeat (cons (regexp) (function)))
- :group 'dnd)
+ :type '(repeat (cons (regexp) (function))))
(defcustom dnd-open-remote-file-function
(if (eq system-type 'windows-nt)
- 'dnd-open-local-file
- 'dnd-open-remote-url)
+ #'dnd-open-local-file
+ #'dnd-open-remote-url)
"The function to call when opening a file on a remote machine.
The function will be called with two arguments, URI and ACTION.
See `dnd-open-file' for details.
@@ -71,15 +73,13 @@ Predefined functions are `dnd-open-local-file' and `dnd-open-remote-url'.
is the default on MS-Windows. `dnd-open-remote-url' uses `url-handler-mode'
and is the default except for MS-Windows."
:version "22.1"
- :type 'function
- :group 'dnd)
+ :type 'function)
(defcustom dnd-open-file-other-window nil
"If non-nil, always use find-file-other-window to open dropped files."
:version "22.1"
- :type 'boolean
- :group 'dnd)
+ :type 'boolean)
;; Functions
@@ -87,13 +87,11 @@ and is the default except for MS-Windows."
(defun dnd-handle-one-url (window action url)
"Handle one dropped url by calling the appropriate handler.
The handler is first located by looking at `dnd-protocol-alist'.
-If no match is found here, and the value of `browse-url-browser-function'
-is a pair of (REGEXP . FUNCTION), those regexps are tried for a match.
-If no match is found, just call `dnd-insert-text'.
-WINDOW is where the drop happened, ACTION is the action for the drop,
-URL is what has been dropped.
-Returns ACTION."
- (require 'browse-url)
+If no match is found here, `browse-url-handlers' and
+`browse-url-default-handlers' are searched for a match.
+If no match is found, just call `dnd-insert-text'. WINDOW is
+where the drop happened, ACTION is the action for the drop, URL
+is what has been dropped. Returns ACTION."
(let (ret)
(or
(catch 'done
@@ -102,14 +100,13 @@ Returns ACTION."
(setq ret (funcall (cdr bf) url action))
(throw 'done t)))
nil)
- (when (not (functionp browse-url-browser-function))
- (catch 'done
- (dolist (bf browse-url-browser-function)
- (when (string-match (car bf) url)
- (setq ret 'private)
- (funcall (cdr bf) url action)
- (throw 'done t)))
- nil))
+ (catch 'done
+ (let ((browser (browse-url-select-handler url 'internal)))
+ (when browser
+ (setq ret 'private)
+ (funcall browser url action)
+ (throw 'done t)))
+ nil)
(progn
(dnd-insert-text window action url)
(setq ret 'private)))
@@ -136,7 +133,8 @@ Return nil if URI is not a local file."
(string-equal sysname-no-dot hostname)))
(concat "file://" (substring uri (+ 7 (length hostname))))))))
-(defsubst dnd-unescape-uri (uri)
+(defun dnd--unescape-uri (uri)
+ ;; Merge with corresponding code in URL library.
(replace-regexp-in-string
"%[[:xdigit:]][[:xdigit:]]"
(lambda (arg)
@@ -160,7 +158,7 @@ Return nil if URI is not a local file."
'utf-8
(or file-name-coding-system
default-file-name-coding-system))))
- (and f (setq f (decode-coding-string (dnd-unescape-uri f) coding)))
+ (and f (setq f (decode-coding-string (dnd--unescape-uri f) coding)))
(when (and f must-exist (not (file-readable-p f)))
(setq f nil))
f))
@@ -182,6 +180,7 @@ An alternative for systems that do not support unc file names is
(if dnd-open-file-other-window
(find-file-other-window f)
(find-file f))
+ (file-name-history--add f)
'private)
(error "Can not read %s" uri))))
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 2c7463e4225..a0ffcac9f80 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -24,8 +24,8 @@
;; Viewing PS/PDF/DVI files requires Ghostscript, `dvipdf' (comes with
;; Ghostscript) or `dvipdfm' (comes with teTeX or TeXLive) and
-;; `pdftotext', which comes with xpdf (http://www.foolabs.com/xpdf/)
-;; or poppler (http://poppler.freedesktop.org/).
+;; `pdftotext', which comes with xpdf (https://www.foolabs.com/xpdf/)
+;; or poppler (https://poppler.freedesktop.org/).
;; Djvu documents require `ddjvu' (from DjVuLibre).
;; ODF files require `soffice' (from LibreOffice).
@@ -439,6 +439,9 @@ Typically \"page-%s.png\".")
(define-key map (kbd "c m") 'doc-view-set-slice-using-mouse)
(define-key map (kbd "c b") 'doc-view-set-slice-from-bounding-box)
(define-key map (kbd "c r") 'doc-view-reset-slice)
+ ;; Centering the image
+ (define-key map (kbd "c h") 'doc-view-center-page-horizontally)
+ (define-key map (kbd "c v") 'doc-view-center-page-vertically)
;; Searching
(define-key map (kbd "C-s") 'doc-view-search)
(define-key map (kbd "<find>") 'doc-view-search)
@@ -697,8 +700,6 @@ at the top edge of the page moves to the previous page."
;; time-window of loose permissions otherwise.
(with-file-modes #o0700 (make-directory dir))
(file-already-exists
- (when (file-symlink-p dir)
- (error "Danger: %s points to a symbolic link" dir))
;; In case it was created earlier with looser rights.
;; We could check the mode info returned by file-attributes, but it's
;; a pain to parse and it may not tell you what we want under
@@ -708,7 +709,7 @@ at the top edge of the page moves to the previous page."
;; sure we have write-access to the directory and that we own it, thus
;; closing a bunch of security holes.
(condition-case error
- (set-file-modes dir #o0700)
+ (set-file-modes dir #o0700 'nofollow)
(file-error
(error
(format "Unable to use temporary directory %s: %s"
@@ -746,8 +747,7 @@ It's a subdirectory of `doc-view-cache-directory'."
Document types are symbols like `dvi', `ps', `pdf', or `odf' (any
OpenDocument format)."
(and (display-graphic-p)
- (or (image-type-available-p 'imagemagick)
- (image-type-available-p 'png))
+ (image-type-available-p 'png)
(cond
((eq type 'dvi)
(and (doc-view-mode-p 'pdf)
@@ -775,10 +775,7 @@ OpenDocument format)."
(defun doc-view-enlarge (factor)
"Enlarge the document by FACTOR."
(interactive (list doc-view-shrink-factor))
- (if (and doc-view-scale-internally
- (eq (plist-get (cdr (doc-view-current-image)) :type)
- 'imagemagick))
- ;; ImageMagick supports on-the-fly-rescaling.
+ (if doc-view-scale-internally
(let ((new (ceiling (* factor doc-view-image-width))))
(unless (equal new doc-view-image-width)
(setq-local doc-view-image-width new)
@@ -798,9 +795,7 @@ OpenDocument format)."
(defun doc-view-scale-reset ()
"Reset the document size/zoom level to the initial one."
(interactive)
- (if (and doc-view-scale-internally
- (eq (plist-get (cdr (doc-view-current-image)) :type)
- 'imagemagick))
+ (if doc-view-scale-internally
(progn
(kill-local-variable 'doc-view-image-width)
(doc-view-insert-image
@@ -919,20 +914,56 @@ Resize the containing frame if needed."
(width-diff (- img-width win-width))
(height-diff (- img-height win-height))
(new-frame-params
+ ;; If we can't resize the window, try and resize the frame.
+ ;; We used to compare the `window-width/height` and the
+ ;; `frame-width/height` instead of catching the errors, but
+ ;; it's too fiddly (e.g. in the presence of the miniwindow,
+ ;; the height the frame should be equal to the height of the
+ ;; root window +1).
(append
- (if (= (window-width) (frame-width))
- `((width . (text-pixels
- . ,(+ (frame-text-width) width-diff))))
- (enlarge-window (/ width-diff (frame-char-width)) 'horiz)
- nil)
- (if (= (window-height) (frame-height))
- `((height . (text-pixels
- . ,(+ (frame-text-height) height-diff))))
- (enlarge-window (/ height-diff (frame-char-height)) nil)
- nil))))
+ (condition-case nil
+ (progn
+ (enlarge-window (/ width-diff (frame-char-width)) 'horiz)
+ nil)
+ (error
+ `((width . (text-pixels
+ . ,(+ (frame-text-width) width-diff))))))
+ (condition-case nil
+ (progn
+ (enlarge-window (/ height-diff (frame-char-height)) nil)
+ nil)
+ (error
+ `((height . (text-pixels
+ . ,(+ (frame-text-height) height-diff)))))))))
(when new-frame-params
(modify-frame-parameters (selected-frame) new-frame-params))))
+(defun doc-view-center-page-horizontally ()
+ "Center page horizontally when page is wider than window."
+ (interactive)
+ (let ((page-width (car (image-size (doc-view-current-image) 'pixel)))
+ (window-width (window-body-width nil 'pixel))
+ ;; How much do we scroll in order to center the page?
+ (pixel-hscroll 0)
+ ;; How many pixels are there in a column?
+ (col-in-pixel (/ (window-body-width nil 'pixel)
+ (window-body-width nil))))
+ (when (> page-width window-width)
+ (setq pixel-hscroll (/ (- page-width window-width) 2))
+ (set-window-hscroll (selected-window)
+ (/ pixel-hscroll col-in-pixel)))))
+
+(defun doc-view-center-page-vertically ()
+ "Center page vertically when page is wider than window."
+ (interactive)
+ (let ((page-height (cdr (image-size (doc-view-current-image) 'pixel)))
+ (window-height (window-body-height nil 'pixel))
+ ;; How much do we scroll in order to center the page?
+ (pixel-scroll 0))
+ (when (> page-height window-height)
+ (setq pixel-scroll (/ (- page-height window-height) 2))
+ (set-window-vscroll (selected-window) pixel-scroll 'pixel))))
+
(defun doc-view-reconvert-doc ()
"Reconvert the current document.
Should be invoked when the cached images aren't up-to-date."
@@ -1303,26 +1334,31 @@ dragging it to its bottom-right corner. See also
(defun doc-view-get-bounding-box ()
"Get the BoundingBox information of the current page."
- (let* ((page (doc-view-current-page))
- (doc (let ((cache-doc (doc-view-current-cache-doc-pdf)))
- (if (file-exists-p cache-doc)
- cache-doc
- doc-view--buffer-file-name)))
- (o (shell-command-to-string
- (concat doc-view-ghostscript-program
- " -dSAFER -dBATCH -dNOPAUSE -q -sDEVICE=bbox "
- (format "-dFirstPage=%s -dLastPage=%s %s"
- page page doc)))))
- (save-match-data
- (when (string-match (concat "%%BoundingBox: "
- "\\([[:digit:]]+\\) \\([[:digit:]]+\\) "
- "\\([[:digit:]]+\\) \\([[:digit:]]+\\)")
- o)
- (mapcar #'string-to-number
- (list (match-string 1 o)
- (match-string 2 o)
- (match-string 3 o)
- (match-string 4 o)))))))
+ (let ((page (doc-view-current-page))
+ (doc (let ((cache-doc (doc-view-current-cache-doc-pdf)))
+ (if (file-exists-p cache-doc)
+ cache-doc
+ doc-view--buffer-file-name))))
+ (with-temp-buffer
+ (when (eq 0 (ignore-errors
+ (process-file doc-view-ghostscript-program nil t
+ nil "-dSAFER" "-dBATCH" "-dNOPAUSE" "-q"
+ "-sDEVICE=bbox"
+ (format "-dFirstPage=%s" page)
+ (format "-dLastPage=%s" page)
+ doc)))
+ (goto-char (point-min))
+ (save-match-data
+ (when (re-search-forward
+ (concat "%%BoundingBox: "
+ "\\([[:digit:]]+\\) \\([[:digit:]]+\\) "
+ "\\([[:digit:]]+\\) \\([[:digit:]]+\\)")
+ nil t)
+ (mapcar #'string-to-number
+ (list (match-string 1)
+ (match-string 2)
+ (match-string 3)
+ (match-string 4)))))))))
(defvar doc-view-paper-sizes
'((a4 595 842)
@@ -1399,12 +1435,13 @@ ARGS is a list of image descriptors."
;; Only insert the image if the buffer is visible.
(when (window-live-p (overlay-get ol 'window))
(let* ((image (if (and file (file-readable-p file))
- (if (not (and doc-view-scale-internally
- (fboundp 'imagemagick-types)))
+ (if (not doc-view-scale-internally)
(apply #'create-image file doc-view--image-type nil args)
(unless (member :width args)
(setq args `(,@args :width ,doc-view-image-width)))
- (apply #'create-image file 'imagemagick nil args))))
+ (unless (member :transform-smoothing args)
+ (setq args `(,@args :transform-smoothing t)))
+ (apply #'create-image file doc-view--image-type nil args))))
(slice (doc-view-current-slice))
(img-width (and image (car (image-size image))))
(displayed-img-width (if (and image slice)
@@ -1765,11 +1802,6 @@ If BACKWARD is non-nil, jump to the previous match."
(remove-overlays (point-min) (point-max) 'doc-view t)
(if (consp image-mode-winprops-alist) (setq image-mode-winprops-alist nil)))
-(defun doc-view-intersection (l1 l2)
- (let ((l ()))
- (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
@@ -1804,7 +1836,7 @@ If BACKWARD is non-nil, jump to the previous match."
((looking-at "AT&TFORM") '(djvu))))))
(setq-local
doc-view-doc-type
- (car (or (doc-view-intersection name-types content-types)
+ (car (or (nreverse (seq-intersection name-types content-types #'eq))
(when (and name-types content-types)
(error "Conflicting types: name says %s but content says %s"
name-types content-types))
@@ -1881,6 +1913,11 @@ toggle between displaying the document or editing it as text.
(unless (memq doc-view-doc-type '(ps))
(setq-local require-final-newline nil))
+ ;; These modes will just display "1", so they're not very useful
+ ;; in this mode.
+ (setq-local global-linum-mode nil
+ display-line-numbers-mode nil)
+
(doc-view-make-safe-dir doc-view-cache-directory)
;; Handle compressed files, remote files, files inside archives
(setq-local doc-view--buffer-file-name
@@ -2021,7 +2058,7 @@ See the command `doc-view-mode' for more information on this mode."
:init-value nil :keymap doc-view-presentation-mode-map
(if doc-view-presentation-mode
(progn
- (set (make-local-variable 'mode-line-format) nil)
+ (setq-local mode-line-format nil)
(doc-view-fit-page-to-window)
;; (doc-view-convert-all-pages)
)
@@ -2056,8 +2093,8 @@ See the command `doc-view-mode' for more information on this mode."
(when (memq (selected-frame) (alist-get 'frames attrs))
(let ((geom (alist-get 'geometry attrs)))
(when geom
- (setq monitor-top (nth 0 geom))
- (setq monitor-left (nth 1 geom))
+ (setq monitor-left (nth 0 geom))
+ (setq monitor-top (nth 1 geom))
(setq monitor-width (nth 2 geom))
(setq monitor-height (nth 3 geom))))))
(let ((frame (make-frame
@@ -2109,6 +2146,12 @@ See the command `doc-view-mode' for more information on this mode."
(add-hook 'bookmark-after-jump-hook show-fn-sym)
(bookmark-default-handler bmk)))
+;; Obsolete.
+
+(defun doc-view-intersection (l1 l2)
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection l1 l2 #'eq)))
+
(provide 'doc-view)
;; Local Variables:
diff --git a/lisp/dom.el b/lisp/dom.el
index 23be6f1b997..71793c0d673 100644
--- a/lisp/dom.el
+++ b/lisp/dom.el
@@ -67,6 +67,12 @@
(setcdr old value)
(setcar (cdr node) (nconc (cadr node) (list (cons attribute value)))))))
+(defun dom-remove-attribute (node attribute)
+ "Remove ATTRIBUTE from NODE."
+ (setq node (dom-ensure-node node))
+ (when-let ((old (assoc attribute (cadr node))))
+ (setcar (cdr node) (delq old (cadr node)))))
+
(defmacro dom-attr (node attr)
"Return the attribute ATTR from NODE.
A typical attribute is `href'."
@@ -263,6 +269,50 @@ white-space."
(insert ")")
(insert "\n" (make-string (1+ column) ? ))))))))
+(defun dom-print (dom &optional pretty xml)
+ "Print DOM at point as HTML/XML.
+If PRETTY, indent the HTML/XML logically.
+If XML, generate XML instead of HTML."
+ (let ((column (current-column)))
+ (insert (format "<%s" (dom-tag dom)))
+ (let ((attr (dom-attributes dom)))
+ (dolist (elem attr)
+ ;; In HTML, these are boolean attributes that should not have
+ ;; an = value.
+ (if (and (memq (car elem)
+ '(async autofocus autoplay checked
+ contenteditable controls default
+ defer disabled formNoValidate frameborder
+ hidden ismap itemscope loop
+ multiple muted nomodule novalidate open
+ readonly required reversed
+ scoped selected typemustmatch))
+ (cdr elem)
+ (not xml))
+ (insert (format " %s" (car elem)))
+ (insert (format " %s=%S" (car elem) (cdr elem))))))
+ (let* ((children (dom-children dom))
+ (non-text nil))
+ (if (null children)
+ (insert " />")
+ (insert ">")
+ (dolist (child children)
+ (if (stringp child)
+ (insert child)
+ (setq non-text t)
+ (when pretty
+ (insert "\n" (make-string (+ column 2) ? )))
+ (dom-print child pretty xml)))
+ ;; If we inserted non-text child nodes, or a text node that
+ ;; ends with a newline, then we indent the end tag.
+ (when (and pretty
+ (or (bolp)
+ non-text))
+ (unless (bolp)
+ (insert "\n"))
+ (insert (make-string column ? )))
+ (insert (format "</%s>" (dom-tag dom)))))))
+
(provide 'dom)
;;; dom.el ends here
diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index 5d4aa7843f1..255edd0f371 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -1,4 +1,4 @@
-;;; dos-fns.el --- MS-Dos specific functions
+;;; dos-fns.el --- MS-Dos specific functions -*- lexical-binding: t; -*-
;; Copyright (C) 1991, 1993, 1995-1996, 2001-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/dos-vars.el b/lisp/dos-vars.el
index a9dbae24ee7..2f7b3760e3f 100644
--- a/lisp/dos-vars.el
+++ b/lisp/dos-vars.el
@@ -1,4 +1,4 @@
-;;; dos-vars.el --- MS-Dos specific user options
+;;; dos-vars.el --- MS-Dos specific user options -*- lexical-binding:t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
@@ -31,15 +31,13 @@
(defcustom msdos-shells '("command.com" "4dos.com" "ndos.com")
"List of shells that use `/c' instead of `-c' and a backslashed command."
- :type '(repeat string)
- :group 'dos-fns)
+ :type '(repeat string))
(defcustom dos-codepage-setup-hook nil
"List of functions to be called after the DOS terminal and coding
systems are set up. This is the place, e.g., to set specific entries
in `standard-display-table' as appropriate for your codepage, if
`IT-display-table-setup' doesn't do a perfect job."
- :group 'dos-fns
:type '(hook)
:version "20.3.3")
diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el
index e902491446c..45daaad8eff 100644
--- a/lisp/dos-w32.el
+++ b/lisp/dos-w32.el
@@ -1,4 +1,4 @@
-;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms
+;;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -154,13 +154,15 @@ when writing the file."
;; FIXME: Can't we use find-file-literally for the same purposes?
(interactive "FFind file binary: ")
(let ((coding-system-for-read 'no-conversion)) ;; FIXME: undecided-unix?
- (find-file filename)))
+ (with-suppressed-warnings ((interactive-only find-file))
+ (find-file filename))))
(defun find-file-text (filename)
"Visit file FILENAME and treat it as a text file."
(interactive "FFind file text: ")
(let ((coding-system-for-read 'undecided-dos))
- (find-file filename)))
+ (with-suppressed-warnings ((interactive-only find-file))
+ (find-file filename))))
(defun w32-find-file-not-found-set-buffer-file-coding-system ()
(with-current-buffer (current-buffer)
@@ -261,6 +263,8 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"."
:group 'dos-fns
:group 'w32)
+(defvar w32-quote-process-args)
+
;; Function to actually send data to the printer port.
;; Supports writing directly, and using various programs.
(defun w32-direct-print-region-helper (printer
diff --git a/lisp/double.el b/lisp/double.el
index 05441e69688..f9227a8bbd9 100644
--- a/lisp/double.el
+++ b/lisp/double.el
@@ -1,4 +1,4 @@
-;;; double.el --- support for keyboard remapping with double clicking
+;;; double.el --- support for keyboard remapping with double clicking -*- lexical-binding: t -*-
;; Copyright (C) 1994, 1997-1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -67,7 +67,6 @@ Each entry is a list with three elements:
1. The key activating the translation.
2. The string to be inserted when the key is pressed once.
3. The string to be inserted when the key is pressed twice."
- :group 'double
:type '(repeat (list (character :tag "Key")
(string :tag "Once")
(string :tag "Twice"))))
@@ -76,7 +75,6 @@ Each entry is a list with three elements:
"Non-nil means that Double mode mapping only works for prefix keys.
That is, for any key `X' in `double-map', `X' alone will be mapped
but not `C-u X' or `ESC X' since the X is not the prefix key."
- :group 'double
:type 'boolean)
;;; Read Event
@@ -95,11 +93,10 @@ but not `C-u X' or `ESC X' since the X is not the prefix key."
(global-set-key [ignore] 'ignore)
-(or (boundp 'isearch-mode-map)
- (load-library "isearch"))
+(require 'isearch)
(define-key isearch-mode-map [ignore]
- (function (lambda () (interactive) (isearch-update))))
+ (lambda () (interactive) (isearch-update)))
(defun double-translate-key (prompt)
;; Translate input events using double map.
@@ -141,12 +138,6 @@ but not `C-u X' or `ESC X' since the X is not the prefix key."
;;; Mode
-;; This feature seemed useless and it confused describe-mode,
-;; so I deleted it.
-;; (defvar double-mode-name "Double")
-;; ;; Name of current double mode.
-;; (make-variable-buffer-local 'double-mode-name)
-
;;;###autoload
(define-minor-mode double-mode
"Toggle special insertion on double keypresses (Double mode).
diff --git a/lisp/dynamic-setting.el b/lisp/dynamic-setting.el
index d6952ed59f3..6b037aa2a6c 100644
--- a/lisp/dynamic-setting.el
+++ b/lisp/dynamic-setting.el
@@ -1,4 +1,4 @@
-;;; dynamic-setting.el --- Support dynamic changes
+;;; dynamic-setting.el --- Support dynamic changes -*- lexical-binding: t -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -24,8 +24,8 @@
;;; Commentary:
-;; This file provides the lisp part of the GConf and XSetting code in
-;; xsetting.c. But it is nothing that prevents it from being used by
+;; This file provides the Lisp part of the GConf and XSetting code in
+;; xsetting.c. But there is nothing that prevents it from being used by
;; other configuration schemes.
;;; Code:
@@ -91,4 +91,7 @@ Changes can be
((eq type 'tool-bar-style) (force-mode-line-update t)))))
(define-key special-event-map [config-changed-event]
- 'dynamic-setting-handle-config-changed-event)
+ #'dynamic-setting-handle-config-changed-event)
+
+(provide 'dynamic-setting)
+;;; dynamic-setting.el ends here
diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el
index 94ca5aa51aa..7fecf1a5045 100644
--- a/lisp/ebuff-menu.el
+++ b/lisp/ebuff-menu.el
@@ -1,4 +1,4 @@
-;;; ebuff-menu.el --- electric-buffer-list mode
+;;; ebuff-menu.el --- electric-buffer-list mode -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -34,55 +34,53 @@
(defvar electric-buffer-menu-mode-map
(let ((map (make-keymap)))
- (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined)
+ (fillarray (car (cdr map)) #'Electric-buffer-menu-undefined)
(define-key map "\e" nil)
- (define-key map "\C-z" 'suspend-frame)
- (define-key map "v" 'Electric-buffer-menu-mode-view-buffer)
- (define-key map (char-to-string help-char) 'Helper-help)
- (define-key map "?" 'Helper-describe-bindings)
+ (define-key map "\C-z" #'suspend-frame)
+ (define-key map "v" #'Electric-buffer-menu-mode-view-buffer)
+ (define-key map (char-to-string help-char) #'Helper-help)
+ (define-key map "?" #'Helper-describe-bindings)
(define-key map "\C-c" nil)
- (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit)
- (define-key map "\C-]" 'Electric-buffer-menu-quit)
- (define-key map "q" 'Electric-buffer-menu-quit)
- (define-key map " " 'Electric-buffer-menu-select)
- (define-key map "\C-m" 'Electric-buffer-menu-select)
- (define-key map "\C-l" 'recenter)
- (define-key map "s" 'Buffer-menu-save)
- (define-key map "d" 'Buffer-menu-delete)
- (define-key map "k" 'Buffer-menu-delete)
- (define-key map "\C-d" 'Buffer-menu-delete-backwards)
- ;; (define-key map "\C-k" 'Buffer-menu-delete)
- (define-key map "\177" 'Buffer-menu-backup-unmark)
- (define-key map "~" 'Buffer-menu-not-modified)
- (define-key map "u" 'Buffer-menu-unmark)
- (define-key map "\M-\177" 'Buffer-menu-unmark-all-buffers)
- (define-key map "U" 'Buffer-menu-unmark-all)
- (let ((i ?0))
- (while (<= i ?9)
- (define-key map (char-to-string i) 'digit-argument)
- (define-key map (concat "\e" (char-to-string i)) 'digit-argument)
- (setq i (1+ i))))
- (define-key map "-" 'negative-argument)
- (define-key map "\e-" 'negative-argument)
- (define-key map "m" 'Buffer-menu-mark)
- (define-key map "\C-u" 'universal-argument)
- (define-key map "\C-p" 'previous-line)
- (define-key map "\C-n" 'next-line)
- (define-key map "p" 'previous-line)
- (define-key map "n" 'next-line)
- (define-key map "\C-v" 'scroll-up-command)
- (define-key map "\ev" 'scroll-down-command)
- (define-key map ">" 'scroll-right)
- (define-key map "<" 'scroll-left)
- (define-key map "\e\C-v" 'scroll-other-window)
- (define-key map "\e>" 'end-of-buffer)
- (define-key map "\e<" 'beginning-of-buffer)
+ (define-key map "\C-c\C-c" #'Electric-buffer-menu-quit)
+ (define-key map "\C-]" #'Electric-buffer-menu-quit)
+ (define-key map "q" #'Electric-buffer-menu-quit)
+ (define-key map " " #'Electric-buffer-menu-select)
+ (define-key map "\C-m" #'Electric-buffer-menu-select)
+ (define-key map "\C-l" #'recenter)
+ (define-key map "s" #'Buffer-menu-save)
+ (define-key map "d" #'Buffer-menu-delete)
+ (define-key map "k" #'Buffer-menu-delete)
+ (define-key map "\C-d" #'Buffer-menu-delete-backwards)
+ ;; (define-key map "\C-k" #'Buffer-menu-delete)
+ (define-key map "\177" #'Buffer-menu-backup-unmark)
+ (define-key map "~" #'Buffer-menu-not-modified)
+ (define-key map "u" #'Buffer-menu-unmark)
+ (define-key map "\M-\177" #'Buffer-menu-unmark-all-buffers)
+ (define-key map "U" #'Buffer-menu-unmark-all)
+ (dotimes (i 10)
+ (define-key map (char-to-string i) #'digit-argument)
+ (define-key map (concat "\e" (char-to-string i)) #'digit-argument))
+ (define-key map "-" #'negative-argument)
+ (define-key map "\e-" #'negative-argument)
+ (define-key map "m" #'Buffer-menu-mark)
+ (define-key map "\C-u" #'universal-argument)
+ (define-key map "\C-p" #'previous-line)
+ (define-key map "\C-n" #'next-line)
+ (define-key map "p" #'previous-line)
+ (define-key map "n" #'next-line)
+ (define-key map "\C-v" #'scroll-up-command)
+ (define-key map "\ev" #'scroll-down-command)
+ (define-key map ">" #'scroll-right)
+ (define-key map "<" #'scroll-left)
+ (define-key map "\e\C-v" #'scroll-other-window)
+ (define-key map "\e>" #'end-of-buffer)
+ (define-key map "\e<" #'beginning-of-buffer)
(define-key map "\e\e" nil)
- (define-key map "\e\e\e" 'Electric-buffer-menu-quit)
+ (define-key map "\e\e\e" #'Electric-buffer-menu-quit)
;; This binding prevents the "escape => ESC" function-key-map mapping from
;; kicking in!
- ;; (define-key map [escape escape escape] 'Electric-buffer-menu-quit)
- (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select)
+ ;; (define-key map [escape escape escape] #'Electric-buffer-menu-quit)
+ (define-key map [mouse-2] #'Electric-buffer-menu-mouse-select)
map))
(put 'Electric-buffer-menu-quit :advertised-binding "\C-c\C-c")
@@ -202,11 +200,10 @@ Electric Buffer Menu mode is a minor mode which is automatically
enabled and disabled by the \\[electric-buffer-list] command.
See the documentation of `electric-buffer-list' for details."
(setq mode-line-buffer-identification "Electric Buffer List")
- (set (make-local-variable 'Helper-return-blurb)
- "return to buffer editing"))
+ (setq-local Helper-return-blurb "return to buffer editing"))
(define-obsolete-function-alias 'Electric-buffer-menu-mode
- 'electric-buffer-menu-mode "24.3")
+ #'electric-buffer-menu-mode "24.3")
;; generally the same as Buffer-menu-mode-map
;; (except we don't indirect to global-map)
@@ -270,8 +267,8 @@ Return to Electric Buffer Menu when done."
(when (derived-mode-p 'electric-buffer-menu-mode)
;; Make sure we have an overlay to use.
(or electric-buffer-overlay
- (set (make-local-variable 'electric-buffer-overlay)
- (make-overlay (point) (point))))
+ (setq-local electric-buffer-overlay
+ (make-overlay (point) (point))))
(move-overlay electric-buffer-overlay
(line-beginning-position)
(line-end-position))
diff --git a/lisp/echistory.el b/lisp/echistory.el
index 8f787e7fa1c..15679b13d5c 100644
--- a/lisp/echistory.el
+++ b/lisp/echistory.el
@@ -1,4 +1,4 @@
-;;; echistory.el --- Electric Command History Mode
+;;; echistory.el --- Electric Command History Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -44,44 +44,43 @@ With prefix arg NOCONFIRM, execute current line as-is without editing."
(defvar electric-history-map
(let ((map (make-sparse-keymap)))
- (define-key map [t] 'Electric-history-undefined)
+ (define-key map [t] #'Electric-history-undefined)
(define-key map "\e" (make-sparse-keymap))
- (define-key map [?\e t] 'Electric-history-undefined)
- (define-key map "\C-u" 'universal-argument)
- (define-key map " " 'Electric-command-history-redo-expression)
- (define-key map "!" 'Electric-command-history-redo-expression)
- (define-key map "\e\C-x" 'eval-sexp)
- (define-key map "\e\C-d" 'down-list)
- (define-key map "\e\C-u" 'backward-up-list)
- (define-key map "\e\C-b" 'backward-sexp)
- (define-key map "\e\C-f" 'forward-sexp)
- (define-key map "\e\C-a" 'beginning-of-defun)
- (define-key map "\e\C-e" 'end-of-defun)
- (define-key map "\e\C-n" 'forward-list)
- (define-key map "\e\C-p" 'backward-list)
- (define-key map "q" 'Electric-history-quit)
+ (define-key map [?\e t] #'Electric-history-undefined)
+ (define-key map "\C-u" #'universal-argument)
+ (define-key map " " #'Electric-command-history-redo-expression)
+ (define-key map "!" #'Electric-command-history-redo-expression)
+ (define-key map "\e\C-d" #'down-list)
+ (define-key map "\e\C-u" #'backward-up-list)
+ (define-key map "\e\C-b" #'backward-sexp)
+ (define-key map "\e\C-f" #'forward-sexp)
+ (define-key map "\e\C-a" #'beginning-of-defun)
+ (define-key map "\e\C-e" #'end-of-defun)
+ (define-key map "\e\C-n" #'forward-list)
+ (define-key map "\e\C-p" #'backward-list)
+ (define-key map "q" #'Electric-history-quit)
(define-key map "\C-c" nil)
- (define-key map "\C-c\C-c" 'Electric-history-quit)
- (define-key map "\C-]" 'Electric-history-quit)
- (define-key map "\C-z" 'suspend-frame)
- (define-key map (char-to-string help-char) 'Helper-help)
- (define-key map "?" 'Helper-describe-bindings)
- (define-key map "\e>" 'end-of-buffer)
- (define-key map "\e<" 'beginning-of-buffer)
- (define-key map "\n" 'next-line)
- (define-key map "\r" 'next-line)
- (define-key map "\177" 'previous-line)
- (define-key map "\C-n" 'next-line)
- (define-key map "\C-p" 'previous-line)
- (define-key map "\ev" 'scroll-down)
- (define-key map "\C-v" 'scroll-up)
- (define-key map [home] 'beginning-of-buffer)
- (define-key map [down] 'next-line)
- (define-key map [up] 'previous-line)
- (define-key map [prior] 'scroll-down)
- (define-key map [next] 'scroll-up)
- (define-key map "\C-l" 'recenter)
- (define-key map "\e\C-v" 'scroll-other-window)
+ (define-key map "\C-c\C-c" #'Electric-history-quit)
+ (define-key map "\C-]" #'Electric-history-quit)
+ (define-key map "\C-z" #'suspend-frame)
+ (define-key map (char-to-string help-char) #'Helper-help)
+ (define-key map "?" #'Helper-describe-bindings)
+ (define-key map "\e>" #'end-of-buffer)
+ (define-key map "\e<" #'beginning-of-buffer)
+ (define-key map "\n" #'next-line)
+ (define-key map "\r" #'next-line)
+ (define-key map "\177" #'previous-line)
+ (define-key map "\C-n" #'next-line)
+ (define-key map "\C-p" #'previous-line)
+ (define-key map "\ev" #'scroll-down)
+ (define-key map "\C-v" #'scroll-up)
+ (define-key map [home] #'beginning-of-buffer)
+ (define-key map [down] #'next-line)
+ (define-key map [up] #'previous-line)
+ (define-key map [prior] #'scroll-down)
+ (define-key map [next] #'scroll-up)
+ (define-key map "\C-l" #'recenter)
+ (define-key map "\e\C-v" #'scroll-other-window)
map)
"Keymap for Electric Command History mode.")
@@ -141,7 +140,9 @@ The Command History listing is recomputed each time this mode is invoked."
(defun Electric-history-undefined ()
(interactive)
(ding)
- (message "%s" (substitute-command-keys "Type \\[Helper-help] for help, ? for commands, C-c C-c to quit, Space to execute"))
+ (message "%s" (substitute-command-keys "Type \\[Helper-help] for help, \
+\\[Helper-describe-bindings] for commands, \\[Electric-history-quit] to quit, \
+\\[Electric-command-history-redo-expression] to execute"))
(sit-for 4))
(defun Electric-history-quit ()
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 9105f661ebd..84de69a2ce1 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -1,9 +1,8 @@
-;;; edmacro.el --- keyboard macro editor
+;;; edmacro.el --- keyboard macro editor -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
-;; Version: 2.01
;; Keywords: abbrev
;; This file is part of GNU Emacs.
@@ -75,8 +74,8 @@ Default nil means to write characters above \\177 in octal notation."
(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)
+ (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)
@@ -152,9 +151,9 @@ With a prefix argument, format the macro in a more concise way."
(setq buffer-read-only nil)
(setq major-mode 'edmacro-mode)
(setq mode-name "Edit Macro")
- (set (make-local-variable 'edmacro-original-buffer) oldbuf)
- (set (make-local-variable 'edmacro-finish-hook) finish-hook)
- (set (make-local-variable 'edmacro-store-hook) store-hook)
+ (setq-local edmacro-original-buffer oldbuf)
+ (setq-local edmacro-finish-hook finish-hook)
+ (setq-local edmacro-store-hook store-hook)
(erase-buffer)
(insert ";; Keyboard Macro Editor. Press C-c C-c to finish; "
"press C-x k RET to cancel.\n")
@@ -178,8 +177,8 @@ With a prefix argument, format the macro in a more concise way."
(set-buffer-modified-p nil))
(run-hooks 'edmacro-format-hook)))))
-;;; The next two commands are provided for convenience and backward
-;;; compatibility.
+;; The next two commands are provided for convenience and backward
+;; compatibility.
;;;###autoload
(defun edit-last-kbd-macro (&optional prefix)
@@ -238,8 +237,7 @@ or nil, use a compact 80-column format."
((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
(when edmacro-store-hook
(error "\"Command\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq cmd (and (not (equal str "none"))
(intern str)))
@@ -254,8 +252,7 @@ or nil, use a compact 80-column format."
(when edmacro-store-hook
(error "\"Key\" line not allowed in this context"))
(let ((key (edmacro-parse-keys
- (buffer-substring (match-beginning 1)
- (match-end 1)))))
+ (match-string 1))))
(unless (equal key "")
(if (equal key "none")
(setq no-keys t)
@@ -275,16 +272,14 @@ or nil, use a compact 80-column format."
((looking-at "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
(when edmacro-store-hook
(error "\"Counter\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq mac-counter (string-to-number str))))
t)
((looking-at "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$")
(when edmacro-store-hook
(error "\"Format\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq mac-format str)))
t)
@@ -476,7 +471,7 @@ doubt, use whitespace."
(and (not (memq (aref rest-mac i) pkeys))
(prog1 (vconcat "C-u " (cl-subseq rest-mac 1 i) " ")
(cl-callf cl-subseq rest-mac i)))))))
- (bind-len (apply 'max 1
+ (bind-len (apply #'max 1
(cl-loop for map in maps
for b = (lookup-key map rest-mac)
when b collect b)))
@@ -507,7 +502,7 @@ doubt, use whitespace."
finally return i))
desc)
(if (stringp bind) (setq bind nil))
- (cond ((and (eq bind 'self-insert-command) (not prefix)
+ (cond ((and (eq bind #'self-insert-command) (not prefix)
(> text 1) (integerp first)
(> first 32) (<= first maxkey) (/= first 92)
(progn
@@ -521,11 +516,11 @@ doubt, use whitespace."
desc))))
(when (or (string-match "^\\^.$" desc)
(member desc res-words))
- (setq desc (mapconcat 'char-to-string desc " ")))
+ (setq desc (mapconcat #'char-to-string desc " ")))
(when verbose
(setq bind (format "%s * %d" bind text)))
(setq bind-len text))
- ((and (eq bind 'execute-extended-command)
+ ((and (eq bind #'execute-extended-command)
(> text bind-len)
(memq (aref rest-mac text) '(return 13))
(progn
@@ -536,32 +531,31 @@ doubt, use whitespace."
(setq bind-len (1+ text)))
(t
(setq desc (mapconcat
- (function
- (lambda (ch)
- (cond
- ((integerp ch)
- (concat
- (cl-loop for pf across "ACHMsS"
- for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@
- ?\M-\^@ ?\s-\^@ ?\S-\^@)
- when (/= (logand ch bit) 0)
- concat (format "%c-" pf))
- (let ((ch2 (logand ch (1- (ash 1 18)))))
- (cond ((<= ch2 32)
- (pcase ch2
- (0 "NUL") (9 "TAB") (10 "LFD")
- (13 "RET") (27 "ESC") (32 "SPC")
- (_
- (format "C-%c"
- (+ (if (<= ch2 26) 96 64)
- ch2)))))
- ((= ch2 127) "DEL")
- ((<= ch2 maxkey) (char-to-string ch2))
- (t (format "\\%o" ch2))))))
- ((symbolp ch)
- (format "<%s>" ch))
- (t
- (error "Unrecognized item in macro: %s" ch)))))
+ (lambda (ch)
+ (cond
+ ((integerp ch)
+ (concat
+ (cl-loop for pf across "ACHMsS"
+ for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@
+ ?\M-\^@ ?\s-\^@ ?\S-\^@)
+ when (/= (logand ch bit) 0)
+ concat (format "%c-" pf))
+ (let ((ch2 (logand ch (1- (ash 1 18)))))
+ (cond ((<= ch2 32)
+ (pcase ch2
+ (0 "NUL") (9 "TAB") (10 "LFD")
+ (13 "RET") (27 "ESC") (32 "SPC")
+ (_
+ (format "C-%c"
+ (+ (if (<= ch2 26) 96 64)
+ ch2)))))
+ ((= ch2 127) "DEL")
+ ((<= ch2 maxkey) (char-to-string ch2))
+ (t (format "\\%o" ch2))))))
+ ((symbolp ch)
+ (format "<%s>" ch))
+ (t
+ (error "Unrecognized item in macro: %s" ch))))
(or fkey key) " "))))
(if prefix
(setq desc (concat (edmacro-sanitize-for-string prefix) desc)))
@@ -669,10 +663,8 @@ This function assumes that the events can be stored in a string."
(substring word 2 -2) "\r")))
((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
(progn
- (setq word (concat (substring word (match-beginning 1)
- (match-end 1))
- (substring word (match-beginning 3)
- (match-end 3))))
+ (setq word (concat (match-string 1 word)
+ (match-string 3 word)))
(not (string-match
"\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
word))))
diff --git a/lisp/ehelp.el b/lisp/ehelp.el
index 0c3d539a502..aa809d6f6f0 100644
--- a/lisp/ehelp.el
+++ b/lisp/ehelp.el
@@ -31,7 +31,6 @@
;; buffer.
;; To make this the default, you must do
-;; (require 'ehelp)
;; (define-key global-map "\C-h" 'ehelp-command)
;; (define-key global-map [help] 'ehelp-command)
;; (define-key global-map [f1] 'ehelp-command)
@@ -96,8 +95,7 @@
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)
+(defvar-local electric-help-orig-major-mode nil)
(defun electric-help-mode ()
"`with-electric-help' temporarily places its buffer in this mode.
@@ -219,7 +217,7 @@ BUFFER is put back into its original major mode."
'electric-help-retain))))
(Electric-command-loop
'exit
- (function (lambda ()
+ (lambda ()
(sit-for 0) ;necessary if last command was end-of-buffer or
;beginning-of-buffer - otherwise pos-visible-in-window-p
;will yield a wrong result.
@@ -241,7 +239,7 @@ BUFFER is put back into its original major mode."
(t
(cond (standard "Press SPC to scroll, DEL to scroll back, q to exit, r to retain ")
(both)
- (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit, \\[electric-help-retain] to retain ")))))))))
+ (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit, \\[electric-help-retain] to retain "))))))))
t))))
diff --git a/lisp/electric.el b/lisp/electric.el
index 506e9aa0f7c..4394fae4366 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -1,4 +1,4 @@
-;;; electric.el --- window maker and Command loop for `electric' modes
+;;; electric.el --- window maker and Command loop for `electric' modes -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1995, 2001-2021 Free Software Foundation,
;; Inc.
@@ -245,10 +245,7 @@ or comment."
'electric-indent-functions
last-command-event)
(memq last-command-event electric-indent-chars))))
- (not
- (or (memq act '(nil no-indent))
- ;; In a string or comment.
- (unless (eq act 'do-indent) (nth 8 (syntax-ppss))))))))
+ (not (memq act '(nil no-indent))))))
;; If we error during indent, silently give up since this is an
;; automatic action that the user didn't explicitly request.
;; But we don't want to suppress errors from elsewhere in *this*
@@ -385,6 +382,8 @@ If multiple rules match, only first one is executed.")
(when electric-layout-mode
(electric-layout-post-self-insert-function-1)))
+(defvar electric-pair-open-newline-between-pairs)
+
;; for edebug's sake, a separate function
(defun electric-layout-post-self-insert-function-1 ()
(let* ((pos (electric--after-char-pos))
diff --git a/lisp/elide-head.el b/lisp/elide-head.el
index cb12271b01c..c0857e3938a 100644
--- a/lisp/elide-head.el
+++ b/lisp/elide-head.el
@@ -1,4 +1,4 @@
-;;; elide-head.el --- hide headers in files
+;;; elide-head.el --- hide headers in files -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2001-2021 Free Software Foundation, Inc.
@@ -63,12 +63,10 @@ The cars of elements of the list are searched for in order. Text is
elided with an invisible overlay from the end of the line where the
first match is found to the end of the match for the corresponding
cdr."
- :group 'elide-head
- :type '(alist :key-type (string :tag "Start regexp")
- :value-type (string :tag "End regexp")))
+ :type '(alist :key-type (regexp :tag "Start regexp")
+ :value-type (regexp :tag "End regexp")))
-(defvar elide-head-overlay nil)
-(make-variable-buffer-local 'elide-head-overlay)
+(defvar-local elide-head-overlay nil)
;;;###autoload
(defun elide-head (&optional arg)
@@ -108,7 +106,7 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks."
(overlay-put elide-head-overlay 'after-string "...")))))))
(defun elide-head-show ()
- "Show a header elided current buffer by \\[elide-head]."
+ "Show a header in the current buffer elided by \\[elide-head]."
(interactive)
(if (and (overlayp elide-head-overlay)
(overlay-buffer elide-head-overlay))
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index aaa12e8e3f9..8e8d0e22651 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1840,8 +1840,7 @@ function at point for which PREDICATE returns non-nil)."
(or default
;; Prefer func name at point, if it's an advised function etc.
(let ((function (progn
- (require 'help)
- (function-called-at-point))))
+ (function-called-at-point))))
(and function
(member (symbol-name function) ad-advised-functions)
(or (null predicate)
@@ -1856,7 +1855,7 @@ function at point for which PREDICATE returns non-nil)."
"There are no qualifying advised functions")))
(let* ((function
(completing-read
- (format "%s (default %s): " (or prompt "Function") default)
+ (format-prompt (or prompt "Function") default)
ad-advised-functions
(if predicate
(lambda (function)
@@ -1884,7 +1883,7 @@ class of FUNCTION)."
(cl-return class)))
(error "ad-read-advice-class: `%s' has no advices" function)))
(let ((class (completing-read
- (format "%s (default %s): " (or prompt "Class") default)
+ (format-prompt (or prompt "Class") default)
ad-advice-class-completion-table nil t)))
(if (equal class "")
default
@@ -1894,16 +1893,16 @@ class of FUNCTION)."
"Read name of existing advice of CLASS for FUNCTION with completion.
An optional PROMPT is used to prompt for the name."
(let* ((name-completion-table
- (mapcar (function (lambda (advice)
- (list (symbol-name (ad-advice-name advice)))))
+ (mapcar (lambda (advice)
+ (list (symbol-name (ad-advice-name advice))))
(ad-get-advice-info-field function class)))
(default
(if (null name-completion-table)
(error "ad-read-advice-name: `%s' has no %s advice"
function class)
(car (car name-completion-table))))
- (prompt (format "%s (default %s): " (or prompt "Name") default))
- (name (completing-read prompt name-completion-table nil t)))
+ (name (completing-read (format-prompt (or prompt "Name") default)
+ name-completion-table nil t)))
(if (equal name "")
(intern default)
(intern name))))
@@ -1923,9 +1922,9 @@ be used to prompt for the function."
(defun ad-read-regexp (&optional prompt)
"Read a regular expression from the minibuffer."
(let ((regexp (read-from-minibuffer
- (concat (or prompt "Regular expression")
- (if (equal ad-last-regexp "") ": "
- (format " (default %s): " ad-last-regexp))))))
+ (format-prompt (or prompt "Regular expression")
+ (and (not (equal ad-last-regexp ""))
+ ad-last-regexp)))))
(setq ad-last-regexp
(if (equal regexp "") ad-last-regexp regexp))))
@@ -2052,6 +2051,8 @@ in that CLASS."
function class name)))
(error "ad-remove-advice: `%s' is not advised" function)))
+(declare-function comp-subr-trampoline-install "comp")
+
;;;###autoload
(defun ad-add-advice (function advice class position)
"Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
@@ -2075,6 +2076,9 @@ mapped to the closest extremal position).
If FUNCTION was not advised already, its advice info will be
initialized. Redefining a piece of advice whose name is part of
the cache-id will clear the cache."
+ (when (and (featurep 'native-compile)
+ (subr-primitive-p (symbol-function function)))
+ (comp-subr-trampoline-install function))
(cond ((not (ad-is-advised function))
(ad-initialize-advice-info function)
(ad-set-advice-info-field
@@ -2224,8 +2228,6 @@ For that it has to be fbound with a non-autoload definition."
(let ((byte-compile-warnings byte-compile-warnings)
;; Don't pop up windows showing byte-compiler warnings.
(warning-suppress-types '((bytecomp))))
- (if (featurep 'cl)
- (byte-compile-disable-warning 'cl-functions))
(byte-compile (ad-get-advice-info-field function 'advicefunname))))
;; @@@ Accessing argument lists:
@@ -2255,13 +2257,11 @@ element is its actual current value, and the third element is either
(let* ((parsed-arglist (ad-parse-arglist arglist))
(rest (nth 2 parsed-arglist)))
`(list
- ,@(mapcar (function
- (lambda (req)
- `(list ',req ,req 'required)))
+ ,@(mapcar (lambda (req)
+ `(list ',req ,req 'required))
(nth 0 parsed-arglist))
- ,@(mapcar (function
- (lambda (opt)
- `(list ',opt ,opt 'optional)))
+ ,@(mapcar (lambda (opt)
+ `(list ',opt ,opt 'optional))
(nth 1 parsed-arglist))
,@(if rest (list `(list ',rest ,rest 'rest))))))
@@ -2372,28 +2372,26 @@ The assignment starts at position INDEX."
(defun ad-insert-argument-access-forms (definition arglist)
"Expands arg-access text macros in DEFINITION according to ARGLIST."
(ad-substitute-tree
- (function
- (lambda (form)
- (or (eq form 'ad-arg-bindings)
- (and (memq (car-safe form)
- '(ad-get-arg ad-get-args ad-set-arg ad-set-args))
- (integerp (car-safe (cdr form)))))))
- (function
- (lambda (form)
- (if (eq form 'ad-arg-bindings)
- (ad-retrieve-args-form arglist)
- (let ((accessor (car form))
- (index (car (cdr form)))
- (val (car (cdr (ad-insert-argument-access-forms
- (cdr form) arglist)))))
- (cond ((eq accessor 'ad-get-arg)
- (ad-get-argument arglist index))
- ((eq accessor 'ad-set-arg)
- (ad-set-argument arglist index val))
- ((eq accessor 'ad-get-args)
- (ad-get-arguments arglist index))
- ((eq accessor 'ad-set-args)
- (ad-set-arguments arglist index val)))))))
+ (lambda (form)
+ (or (eq form 'ad-arg-bindings)
+ (and (memq (car-safe form)
+ '(ad-get-arg ad-get-args ad-set-arg ad-set-args))
+ (integerp (car-safe (cdr form))))))
+ (lambda (form)
+ (if (eq form 'ad-arg-bindings)
+ (ad-retrieve-args-form arglist)
+ (let ((accessor (car form))
+ (index (car (cdr form)))
+ (val (car (cdr (ad-insert-argument-access-forms
+ (cdr form) arglist)))))
+ (cond ((eq accessor 'ad-get-arg)
+ (ad-get-argument arglist index))
+ ((eq accessor 'ad-set-arg)
+ (ad-set-argument arglist index val))
+ ((eq accessor 'ad-get-args)
+ (ad-get-arguments arglist index))
+ ((eq accessor 'ad-set-args)
+ (ad-set-arguments arglist index val))))))
definition))
;; @@@ Mapping argument lists:
@@ -2412,8 +2410,9 @@ as if they had been supplied to a function with TARGET-ARGLIST directly.
Excess source arguments will be neglected, missing source arguments will be
supplied as nil. Returns a `funcall' or `apply' form with the second element
being `function' which has to be replaced by an actual function argument.
-Example: (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return
- (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))."
+Example:
+ (ad-map-arglists \\='(a &rest args) \\='(w x y z)) will return
+ (funcall ad--addoit-function a (car args) (car (cdr args)) (nth 2 args))."
(let* ((parsed-source-arglist (ad-parse-arglist source-arglist))
(source-reqopt-args (append (nth 0 parsed-source-arglist)
(nth 1 parsed-source-arglist)))
@@ -2623,8 +2622,8 @@ should be modified. The assembled function will be returned."
(defun ad-make-hook-form (function hook-name)
"Make hook-form from FUNCTION's advice bodies in class HOOK-NAME."
(let ((hook-forms
- (mapcar (function (lambda (advice)
- (ad-body-forms (ad-advice-definition advice))))
+ (mapcar (lambda (advice)
+ (ad-body-forms (ad-advice-definition advice)))
(ad-get-enabled-advices function hook-name))))
(if hook-forms
(macroexp-progn (apply 'append hook-forms)))))
@@ -3167,15 +3166,14 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
(setq args (cdr args)))))
(flags
(mapcar
- (function
- (lambda (flag)
+ (lambda (flag)
(let ((completion
(try-completion (symbol-name flag) ad-defadvice-flags)))
(cond ((eq completion t) flag)
((member completion ad-defadvice-flags)
(intern completion))
(t (error "defadvice: Invalid or ambiguous flag: %s"
- flag))))))
+ flag)))))
args))
(advice (ad-make-advice
name (memq 'protect flags)
@@ -3217,11 +3215,10 @@ undone on exit of this macro."
(let* ((index -1)
;; Make let-variables to store current definitions:
(current-bindings
- (mapcar (function
- (lambda (function)
+ (mapcar (lambda (function)
(setq index (1+ index))
(list (intern (format "ad-oRiGdEf-%d" index))
- `(symbol-function ',function))))
+ `(symbol-function ',function)))
functions)))
`(let ,current-bindings
(unwind-protect
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 36afeee9f02..e9a20634af8 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,4 +1,4 @@
-;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*-
+;;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*-
;; Copyright (C) 1991-1997, 2001-2021 Free Software Foundation, Inc.
@@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently."
((stringp (car-safe rest)) (car rest))))
;; Look for an interactive spec.
(interactive (pcase body
- ((or `((interactive . ,_) . ,_)
- `(,_ (interactive . ,_) . ,_))
- t))))
+ ((or `((interactive . ,iargs) . ,_)
+ `(,_ (interactive . ,iargs) . ,_))
+ ;; List of modes or just t.
+ (if (nthcdr 1 iargs)
+ (list 'quote (nthcdr 1 iargs))
+ t)))))
;; Add the usage form at the end where describe-function-1
;; can recover it.
(when (consp args) (setq doc (help-add-fundoc-usage doc args)))
@@ -167,7 +170,9 @@ expression, in which case we want to handle forms differently."
define-inline cl-defun cl-defmacro cl-defgeneric
cl-defstruct pcase-defmacro))
(macrop car)
- (setq expand (let ((load-file-name file)) (macroexpand form)))
+ (setq expand (let ((load-true-file-name file)
+ (load-file-name file))
+ (macroexpand form)))
(memq (car expand) '(progn prog1 defalias)))
(make-autoload expand file 'expansion)) ;Recurse on the expansion.
@@ -207,7 +212,11 @@ expression, in which case we want to handle forms differently."
easy-mmode-define-minor-mode
define-minor-mode))
t)
- (eq (car-safe (car body)) 'interactive))
+ (and (eq (car-safe (car body)) 'interactive)
+ ;; List of modes or just t.
+ (or (if (nthcdr 1 (car body))
+ (list 'quote (nthcdr 1 (car body)))
+ t))))
,(if macrop ''macro nil))))
;; For defclass forms, use `eieio-defclass-autoload'.
@@ -220,17 +229,31 @@ expression, in which case we want to handle forms differently."
;; Convert defcustom to less space-consuming data.
((eq car 'defcustom)
- (let ((varname (car-safe (cdr-safe form)))
- (init (car-safe (cdr-safe (cdr-safe form))))
- (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form)))))
- ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form)))))
- )
+ (let* ((varname (car-safe (cdr-safe form)))
+ (props (nthcdr 4 form))
+ (initializer (plist-get props :initialize))
+ (init (car-safe (cdr-safe (cdr-safe form))))
+ (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form)))))
+ ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form)))))
+ )
`(progn
- (defvar ,varname ,init ,doc)
+ ,(if (not (member initializer '(nil 'custom-initialize-default
+ #'custom-initialize-default
+ 'custom-initialize-reset
+ #'custom-initialize-reset)))
+ form
+ `(defvar ,varname ,init ,doc))
+ ;; When we include the complete `form', this `custom-autoload'
+ ;; is not indispensable, but it still helps in case the `defcustom'
+ ;; doesn't specify its group explicitly, and probably in a few other
+ ;; corner cases.
(custom-autoload ',varname ,file
,(condition-case nil
- (null (cadr (memq :set form)))
- (error nil))))))
+ (null (plist-get props :set))
+ (error nil)))
+ ;; Propagate the :safe property to the loaddefs file.
+ ,@(when-let ((safe (plist-get props :safe)))
+ `((put ',varname 'safe-local-variable ,safe))))))
((eq car 'defgroup)
;; In Emacs this is normally handled separately by cus-dep.el, but for
@@ -254,12 +277,12 @@ expression, in which case we want to handle forms differently."
;; the doc-string in FORM.
;; Those properties are now set in lisp-mode.el.
-(defun autoload-find-generated-file ()
+(defun autoload-find-generated-file (file)
"Visit the autoload file for the current buffer, and return its buffer."
(let ((enable-local-variables :safe)
(enable-local-eval nil)
- (delay-mode-hooks t)
- (file (autoload-generated-file)))
+ (find-file-hook nil)
+ (delay-mode-hooks t))
;; We used to use `raw-text' to read this file, but this causes
;; problems when the file contains non-ASCII characters.
(with-current-buffer (find-file-noselect
@@ -267,18 +290,20 @@ expression, in which case we want to handle forms differently."
(if (zerop (buffer-size)) (insert (autoload-rubric file nil t)))
(current-buffer))))
-(defun autoload-generated-file ()
- "Return `generated-autoload-file' as an absolute name.
-If local to the current buffer, expand using the default directory;
-otherwise, using `source-directory'/lisp."
- (expand-file-name generated-autoload-file
+(defun autoload-generated-file (outfile)
+ "Return OUTFILE as an absolute name.
+If `generated-autoload-file' is bound locally in the current
+buffer, that is used instead, and it is expanded using the
+default directory; otherwise, `source-directory'/lisp is used."
+ (expand-file-name (if (local-variable-p 'generated-autoload-file)
+ generated-autoload-file
+ outfile)
;; File-local settings of generated-autoload-file should
;; be interpreted relative to the file's location,
;; of course.
(if (not (local-variable-p 'generated-autoload-file))
(expand-file-name "lisp" source-directory))))
-
(defun autoload-read-section-header ()
"Read a section header form.
Since continuation lines have been marked as comments,
@@ -366,7 +391,8 @@ FILE's name."
(let ((basename (file-name-nondirectory file))
(lp (if (equal type "package") (setq type "autoloads"))))
(concat ";;; " basename
- " --- automatically extracted " (or type "autoloads") "\n"
+ " --- automatically extracted " (or type "autoloads")
+ " -*- lexical-binding: t -*-\n"
";;\n"
";;; Code:\n\n"
(if lp
@@ -453,13 +479,12 @@ which lists the file name and which functions are in it, etc."
(defvar no-update-autoloads nil
"File local variable to prevent scanning this file for autoload cookies.")
-(defun autoload-file-load-name (file)
+(defun autoload-file-load-name (file outfile)
"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)))
+ (let* ((name (file-relative-name file (file-name-directory outfile)))
(names '())
(dir (file-name-directory outfile)))
;; If `name' has directory components, only keep the
@@ -489,8 +514,9 @@ 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: ")
- (let ((generated-autoload-file buffer-file-name))
- (autoload-generate-file-autoloads file (current-buffer))))
+ (let ((autoload-modified-buffers nil))
+ (autoload-generate-file-autoloads file (current-buffer) buffer-file-name)
+ autoload-modified-buffers))
(defvar autoload-compute-prefixes t
"If non-nil, autoload will add code to register the prefixes used in a file.
@@ -600,15 +626,14 @@ Don't try to split prefixes that are already longer than that.")
(radix-tree-iter-mappings
(cdr x) (lambda (s _)
(push (concat prefix s) dropped)))
- (message "Not registering prefix \"%s\" from %s. Affects: %S"
- prefix file dropped)
+ (message "%s:0: Warning: Not registering prefix \"%s\". Affects: %S"
+ file prefix dropped)
nil))))
prefixes)))
- `(if (fboundp 'register-definition-prefixes)
- (register-definition-prefixes ,file ',(sort (delq nil strings)
- 'string<)))))))
+ `(register-definition-prefixes ,file ',(sort (delq nil strings)
+ 'string<))))))
-(defun autoload--setup-output (otherbuf outbuf absfile load-name)
+(defun autoload--setup-output (otherbuf outbuf absfile load-name output-file)
(let ((outbuf
(or (if otherbuf
;; A file-local setting of
@@ -616,7 +641,7 @@ Don't try to split prefixes that are already longer than that.")
;; should ignore OUTBUF.
nil
outbuf)
- (autoload-find-destination absfile load-name)
+ (autoload-find-destination absfile load-name output-file)
;; The file has autoload cookies, but they're
;; already up-to-date. If OUTFILE is nil, the
;; entries are in the expected OUTBUF,
@@ -673,23 +698,16 @@ Don't try to split prefixes that are already longer than that.")
More specifically those definitions will not be considered for the
`register-definition-prefixes' call.")
-;; When called from `generate-file-autoloads' we should ignore
-;; `generated-autoload-file' altogether. When called from
-;; `update-file-autoloads' we don't know `outbuf'. And when called from
-;; `update-directory-autoloads' it's in between: we know the default
-;; `outbuf' but we should obey any file-local setting of
-;; `generated-autoload-file'.
(defun autoload-generate-file-autoloads (file &optional outbuf outfile)
"Insert an autoload section for FILE in the appropriate buffer.
Autoloads are generated for defuns and defmacros in FILE
marked by `generate-autoload-cookie' (which see).
+
If FILE is being visited in a buffer, the contents of the buffer are used.
OUTBUF is the buffer in which the autoload statements should be inserted.
-If OUTBUF is nil, it will be determined by `autoload-generated-file'.
-If provided, OUTFILE is expected to be the file name of OUTBUF.
-If OUTFILE is non-nil and FILE specifies a `generated-autoload-file'
-different from OUTFILE, then OUTBUF is ignored.
+If OUTBUF is nil, the output will go to OUTFILE, unless there's a
+buffer-local setting of `generated-autoload-file' in FILE.
Return non-nil if and only if FILE adds no autoloads to OUTFILE
\(or OUTBUF if OUTFILE is nil). The actual return value is
@@ -717,16 +735,19 @@ FILE's modification time."
(setq load-name
(if (stringp generated-autoload-load-name)
generated-autoload-load-name
- (autoload-file-load-name absfile)))
+ (autoload-file-load-name absfile outfile)))
;; FIXME? Comparing file-names for equality with just equal
;; is fragile, eg if one has an automounter prefix and one
;; does not, but both refer to the same physical file.
(when (and outfile
+ (not outbuf)
(not
(if (memq system-type '(ms-dos windows-nt))
(equal (downcase outfile)
- (downcase (autoload-generated-file)))
- (equal outfile (autoload-generated-file)))))
+ (downcase (autoload-generated-file
+ outfile)))
+ (equal outfile (autoload-generated-file
+ outfile)))))
(setq otherbuf t))
(save-excursion
(save-restriction
@@ -740,7 +761,8 @@ FILE's modification time."
(file-name-sans-extension
(file-name-nondirectory file))))
(setq output-start (autoload--setup-output
- otherbuf outbuf absfile load-name))
+ otherbuf outbuf absfile
+ load-name outfile))
(let ((standard-output (marker-buffer output-start))
(print-quoted t))
(princ `(push (purecopy
@@ -758,7 +780,8 @@ FILE's modification time."
;; If not done yet, figure out where to insert this text.
(unless output-start
(setq output-start (autoload--setup-output
- otherbuf outbuf absfile load-name)))
+ otherbuf outbuf absfile
+ load-name outfile)))
(autoload--print-cookie-text output-start load-name file))
((= (following-char) ?\;)
;; Don't read the comment.
@@ -789,7 +812,7 @@ FILE's modification time."
((not otherbuf)
(unless output-start
(setq output-start (autoload--setup-output
- nil outbuf absfile load-name)))
+ nil outbuf absfile load-name outfile)))
(let ((autoload-print-form-outbuf
(marker-buffer output-start)))
(autoload-print-form form)))
@@ -801,9 +824,8 @@ FILE's modification time."
;; then passing otherbuf=nil is enough, but if
;; outbuf is nil, that won't cut it, so we
;; locally bind generated-autoload-file.
- (let ((generated-autoload-file
- (default-value 'generated-autoload-file)))
- (autoload--setup-output nil outbuf absfile load-name)))
+ (autoload--setup-output nil outbuf absfile load-name
+ outfile))
(autoload-print-form-outbuf
(marker-buffer other-output-start)))
(autoload-print-form form)
@@ -895,7 +917,7 @@ FILE's modification time."
(cons (lambda () (ignore-errors (delete-file tempfile)))
kill-emacs-hook)))
(unless (= temp-modes desired-modes)
- (set-file-modes tempfile desired-modes))
+ (set-file-modes tempfile desired-modes 'nofollow))
(write-region (point-min) (point-max) tempfile nil 1)
(backup-buffer)
(rename-file tempfile buffer-file-name t))
@@ -925,19 +947,23 @@ Return FILE if there was no autoload cookie in it, else 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)
+ (setq outfile (or outfile generated-autoload-file))
+ (let* ((autoload-modified-buffers nil)
;; We need this only if the output file handles more than one input.
;; See https://debbugs.gnu.org/22213#38 and subsequent.
(autoload-timestamps t)
- (no-autoloads (autoload-generate-file-autoloads file)))
+ (no-autoloads (autoload-generate-file-autoloads
+ file nil
+ (if (local-variable-p 'generated-autoload-file)
+ generated-autoload-file
+ outfile))))
(if autoload-modified-buffers
(if save-after (autoload-save-buffers))
(if (called-interactively-p 'interactive)
(message "Autoload section for %s is up to date." file)))
(if no-autoloads file)))
-(defun autoload-find-destination (file load-name)
+(defun autoload-find-destination (file load-name output-file)
"Find the destination point of the current buffer's autoloads.
FILE is the file name of the current buffer.
LOAD-NAME is the name as it appears in the output.
@@ -947,12 +973,12 @@ removes any prior now out-of-date autoload entries."
(catch 'up-to-date
(let* ((buf (current-buffer))
(existing-buffer (if buffer-file-name buf))
- (output-file (autoload-generated-file))
+ (output-file (autoload-generated-file output-file))
(output-time (if (file-exists-p output-file)
(file-attribute-modification-time
(file-attributes output-file))))
(found nil))
- (with-current-buffer (autoload-find-generated-file)
+ (with-current-buffer (autoload-find-generated-file output-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))
@@ -1033,12 +1059,31 @@ The function does NOT recursively descend into subdirectories of the
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."
+autoload definitions. 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."
+ (declare (obsolete make-directory-autoloads "28.1"))
(interactive "DUpdate autoloads from directory: ")
+ (make-directory-autoloads
+ dirs
+ (if (called-interactively-p 'interactive)
+ (read-file-name "Write autoload definitions to file: ")
+ generated-autoload-file)))
+
+;;;###autoload
+(defun make-directory-autoloads (dir output-file)
+ "Update autoload definitions for Lisp files in the directories DIRS.
+DIR can be either a single directory or a list of
+directories. (The latter usage is discouraged.)
+
+The autoloads will be written to OUTPUT-FILE. If any Lisp file
+binds `generated-autoload-file' as a file-local variable, write
+its autoloads into the specified file instead.
+
+The function does NOT recursively descend into subdirectories of the
+directory or directories specified."
+ (interactive "DUpdate autoloads from directory: \nFWrite to file: ")
(let* ((files-re (let ((tmp nil))
(dolist (suf (get-load-suffixes))
;; We don't use module-file-suffix below because
@@ -1049,10 +1094,10 @@ write its autoloads into the specified file instead."
(push suf tmp)))
(concat "\\`[^=.].*" (regexp-opt tmp t) "\\'")))
(files (apply #'nconc
- (mapcar (lambda (dir)
- (directory-files (expand-file-name dir)
- t files-re))
- dirs)))
+ (mapcar (lambda (d)
+ (directory-files (expand-file-name d)
+ t files-re))
+ (if (consp dir) dir (list dir)))))
(done ()) ;Files processed; to remove duplicates.
(changed nil) ;Non-nil if some change occurred.
(last-time)
@@ -1060,16 +1105,12 @@ write its autoloads into the specified file instead."
;; files because of file-local autoload-generated-file settings.
(no-autoloads nil)
(autoload-modified-buffers nil)
- (generated-autoload-file
- (if (called-interactively-p 'interactive)
- (read-file-name "Write autoload definitions to file: ")
- generated-autoload-file))
(output-time
- (if (file-exists-p generated-autoload-file)
- (file-attribute-modification-time
- (file-attributes generated-autoload-file)))))
+ (and (file-exists-p output-file)
+ (file-attribute-modification-time
+ (file-attributes output-file)))))
- (with-current-buffer (autoload-find-generated-file)
+ (with-current-buffer (autoload-find-generated-file output-file)
(save-excursion
;; Canonicalize file names and remove the autoload file itself.
(setq files (delete (file-relative-name buffer-file-name)
@@ -1124,10 +1165,9 @@ write its autoloads into the specified file instead."
;; Elements remaining in FILES have no existing autoload sections yet.
(let ((no-autoloads-time (or last-time '(0 0 0 0)))
(progress (make-progress-reporter
- (byte-compile-info-string
+ (byte-compile-info
(concat "Scraping files for "
- (file-relative-name
- generated-autoload-file)))
+ (file-relative-name output-file)))
0 (length files) nil 10))
(file-count 0)
file-time)
@@ -1167,6 +1207,19 @@ write its autoloads into the specified file instead."
;; file-local autoload-generated-file settings.
(autoload-save-buffers))))
+(defun batch-update-autoloads--summary (strings)
+ (let ((message ""))
+ (while strings
+ (when (> (length (concat message " " (car strings))) 64)
+ (byte-compile-info (concat message " ...") t "SCRAPE")
+ (setq message ""))
+ (setq message (if (zerop (length message))
+ (car strings)
+ (concat message " " (car strings))))
+ (setq strings (cdr strings)))
+ (when (> (length message) 0)
+ (byte-compile-info message t "SCRAPE"))))
+
;;;###autoload
(defun batch-update-autoloads ()
"Update loaddefs.el autoloads in batch mode.
@@ -1190,8 +1243,9 @@ should be non-nil)."
(or (string-match "\\`site-" file)
(push (expand-file-name file) autoload-excludes)))))))
(let ((args command-line-args-left))
+ (batch-update-autoloads--summary args)
(setq command-line-args-left nil)
- (apply #'update-directory-autoloads args)))
+ (make-directory-autoloads args generated-autoload-file)))
(provide 'autoload)
diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el
index 75c732269e2..4382985eb85 100644
--- a/lisp/emacs-lisp/avl-tree.el
+++ b/lisp/emacs-lisp/avl-tree.el
@@ -74,7 +74,7 @@
cmpfun)
(defmacro avl-tree--root (tree)
- ;; Return the root node for an AVL tree. INTERNAL USE ONLY.
+ "Return the root node for an AVL TREE. INTERNAL USE ONLY."
`(avl-tree--node-left (avl-tree--dummyroot ,tree)))
;; ----------------------------------------------------------------
@@ -117,11 +117,11 @@ NODE is the node, and BRANCH is the branch.
`(- 1 ,dir))
(defmacro avl-tree--dir-to-sign (dir)
- "Convert direction (0,1) to sign factor (-1,+1)."
+ "Convert direction DIR (0,1) to sign factor (-1,+1)."
`(1- (* 2 ,dir)))
(defmacro avl-tree--sign-to-dir (dir)
- "Convert sign factor (-x,+x) to direction (0,1)."
+ "Convert sign factor in DIR (-x,+x) to direction (0,1)."
`(if (< ,dir 0) 0 1))
@@ -129,7 +129,7 @@ NODE is the node, and BRANCH is the branch.
;; Deleting data
(defun avl-tree--del-balance (node branch dir)
- "Rebalance a tree after deleting a node.
+ "Rebalance a tree after deleting a NODE.
The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree
of the left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has shrunk."
@@ -247,9 +247,9 @@ the related data."
;; Entering data
(defun avl-tree--enter-balance (node branch dir)
- "Rebalance tree after an insertion
-into the left (DIR=0) or right (DIR=1) sub-tree of the
-left (BRANCH=0) or right (BRANCH=1) child of NODE.
+ "Rebalance tree after insertion of NODE.
+NODE was inserted into the left (DIR=0) or right (DIR=1) sub-tree
+of the left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has grown."
(let ((br (avl-tree--node-branch node branch))
;; opposite direction: 0,1 -> 1,0
@@ -337,7 +337,7 @@ inserted data."
))))
(defun avl-tree--check (tree)
- "Check the tree's balance."
+ "Check the balance of TREE."
(avl-tree--check-node (avl-tree--root tree)))
(defun avl-tree--check-node (node)
(if (null node) 0
@@ -379,7 +379,8 @@ itself."
;;; INTERNAL USE ONLY
(defun avl-tree--do-copy (root)
- "Copy the AVL tree with ROOT as root. Highly recursive."
+ "Copy the AVL tree wiath ROOT as root.
+This function is highly recursive."
(if (null root)
nil
(avl-tree--node-create
@@ -405,8 +406,9 @@ itself."
\n(fn OBJ)")
(defun avl-tree--stack-repopulate (stack)
- ;; Recursively push children of the node at the head of STACK onto the
- ;; front of the STACK, until a leaf is reached.
+ "Recursively push children of STACK onto the front.
+This pushes the children of the node at the head of STACK onto
+the front of STACK, until a leaf node is reached."
(let ((node (car (avl-tree--stack-store stack)))
(dir (if (avl-tree--stack-reverse stack) 1 0)))
(when node ; check for empty stack
@@ -429,7 +431,7 @@ and returns non-nil if A is less than B, and nil otherwise.
\n(fn TREE)")
(defun avl-tree-empty (tree)
- "Return t if AVL tree TREE is empty, otherwise return nil."
+ "Return t if AVL TREE is empty, otherwise return nil."
(null (avl-tree--root tree)))
(defun avl-tree-enter (tree data &optional updatefun)
@@ -451,7 +453,7 @@ Returns the new data."
0 data updatefun)))
(defun avl-tree-delete (tree data &optional test nilflag)
- "Delete the element matching DATA from the AVL tree TREE.
+ "Delete the element matching DATA from the AVL TREE.
Matching uses the comparison function previously specified in
`avl-tree-create' when TREE was created.
@@ -473,7 +475,7 @@ value is non-nil."
(defun avl-tree-member (tree data &optional nilflag)
- "Return the element in the AVL tree TREE which matches DATA.
+ "Return the element in the AVL TREE which matches DATA.
Matching uses the comparison function previously specified in
`avl-tree-create' when TREE was created.
@@ -496,7 +498,7 @@ for you.)"
(defun avl-tree-member-p (tree data)
- "Return t if an element matching DATA exists in the AVL tree TREE.
+ "Return t if an element matching DATA exists in the AVL TREE.
Otherwise return nil. Matching uses the comparison function
previously specified in `avl-tree-create' when TREE was created."
(let ((flag '(nil)))
@@ -504,13 +506,13 @@ previously specified in `avl-tree-create' when TREE was created."
(defun avl-tree-map (fun tree &optional reverse)
- "Modify all elements in the AVL tree TREE by applying FUNCTION.
+ "Modify all elements in the AVL TREE by applying function FUN.
-Each element is replaced by the return value of FUNCTION applied
-to that element.
+Each element is replaced by the return value of FUN applied to
+that element.
-FUNCTION is applied to the elements in ascending order, or
-descending order if REVERSE is non-nil."
+FUN is applied to the elements in ascending order, or descending
+order if REVERSE is non-nil."
(avl-tree--mapc
(lambda (node)
(setf (avl-tree--node-data node)
@@ -520,8 +522,7 @@ descending order if REVERSE is non-nil."
(defun avl-tree-mapc (fun tree &optional reverse)
- "Apply FUNCTION to all elements in AVL tree TREE,
-for side-effect only.
+ "Apply function FUN to all elements in AVL TREE, for side-effect only.
FUNCTION is applied to the elements in ascending order, or
descending order if REVERSE is non-nil."
@@ -534,8 +535,7 @@ descending order if REVERSE is non-nil."
(defun avl-tree-mapf
(fun combinator tree &optional reverse)
- "Apply FUNCTION to all elements in AVL tree TREE,
-and combine the results using COMBINATOR.
+ "Apply FUN to all elements in AVL TREE, combine results using COMBINATOR.
The FUNCTION is applied and the results are combined in ascending
order, or descending order if REVERSE is non-nil."
@@ -553,8 +553,7 @@ order, or descending order if REVERSE is non-nil."
(defun avl-tree-mapcar (fun tree &optional reverse)
- "Apply function FUN to all elements in AVL tree TREE,
-and make a list of the results.
+ "Apply FUN to all elements in AVL TREE, and make a list of the results.
The function is applied and the list constructed in ascending
order, or descending order if REVERSE is non-nil.
@@ -586,7 +585,7 @@ is more efficient."
(avl-tree--node-data node))))
(defun avl-tree-copy (tree)
- "Return a copy of the AVL tree TREE."
+ "Return a copy of the AVL TREE."
(let ((new-tree (avl-tree-create (avl-tree--cmpfun tree))))
(setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree)))
new-tree))
@@ -608,13 +607,12 @@ is more efficient."
treesize))
(defun avl-tree-clear (tree)
- "Clear the AVL tree TREE."
+ "Clear the AVL TREE."
(setf (avl-tree--root tree) nil))
(defun avl-tree-stack (tree &optional reverse)
- "Return an object that behaves like a sorted stack
-of all elements of TREE.
+ "Return an object that behaves like a sorted stack of all elements of TREE.
If REVERSE is non-nil, the stack is sorted in reverse order.
\(See also `avl-tree-stack-pop').
@@ -655,8 +653,7 @@ a null element stored in the AVL tree.)"
(defun avl-tree-stack-first (avl-tree-stack &optional nilflag)
- "Return the first element of AVL-TREE-STACK, without removing it
-from the stack.
+ "Return the first element of AVL-TREE-STACK, without removing it from stack.
Returns nil if the stack is empty, or NILFLAG if specified.
\(The latter allows an empty stack to be distinguished from
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index e4f786df8f7..173c11644d5 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -1,4 +1,4 @@
-;;; backquote.el --- implement the ` Lisp construct
+;;; backquote.el --- implement the ` Lisp construct -*- lexical-binding: t -*-
;; Copyright (C) 1990, 1992, 1994, 2001-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index 3e1c3292650..ea70baa9532 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -190,7 +190,7 @@ This is commonly used to recompute `backtrace-frames'.")
(defvar-local backtrace-print-function #'cl-prin1
"Function used to print values in the current Backtrace buffer.")
-(defvar-local backtrace-goto-source-functions nil
+(defvar backtrace-goto-source-functions nil
"Abnormal hook used to jump to the source code for the current frame.
Each hook function is called with no argument, and should return
non-nil if it is able to switch to the buffer containing the
@@ -638,10 +638,8 @@ content of the sexp."
(source-available (plist-get (backtrace-frame-flags frame)
:source-available)))
(unless (and source-available
- (catch 'done
- (dolist (func backtrace-goto-source-functions)
- (when (funcall func)
- (throw 'done t)))))
+ (run-hook-with-args-until-success
+ 'backtrace-goto-source-functions))
(user-error "Source code location not known"))))
(defun backtrace-help-follow-symbol (&optional pos)
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index 701e6c513f3..64c628822df 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -31,16 +31,72 @@
;;; Code:
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
(defmacro benchmark-elapse (&rest forms)
"Return the time in seconds elapsed for execution of FORMS."
(declare (indent 0) (debug t))
(let ((t1 (make-symbol "t1")))
- `(let (,t1)
- (setq ,t1 (current-time))
+ `(let ((,t1 (current-time)))
,@forms
(float-time (time-since ,t1)))))
;;;###autoload
+(defun benchmark-call (func &optional repetitions)
+ "Measure the run time of calling FUNC a number REPETITIONS of times.
+The result is a list (TIME GC GCTIME)
+where TIME is the total time it took, in seconds.
+GCTIME is the amount of time that was spent in the GC
+and GC is the number of times the GC was called.
+
+REPETITIONS can also be a floating point number, in which case it
+specifies a minimum number of seconds that the benchmark execution
+should take. In that case the return value is prepended with the
+number of repetitions actually used."
+ (if (floatp repetitions)
+ (benchmark--adaptive func repetitions)
+ (unless repetitions (setq repetitions 1))
+ (let ((gc gc-elapsed)
+ (gcs gcs-done)
+ (empty-func (lambda () 'empty-func)))
+ (list
+ (if (> repetitions 1)
+ (- (benchmark-elapse (dotimes (_ repetitions) (funcall func)))
+ (benchmark-elapse (dotimes (_ repetitions) (funcall empty-func))))
+ (- (benchmark-elapse (funcall func))
+ (benchmark-elapse (funcall empty-func))))
+ (- gcs-done gcs)
+ (- gc-elapsed gc)))))
+
+(defun benchmark--adaptive (func time)
+ "Measure the run time of FUNC, calling it enough times to last TIME seconds.
+Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'."
+ (named-let loop ((repetitions 1)
+ (data (let ((x (list 0))) (setcdr x x) x)))
+ ;; (message "Running %d iteration" repetitions)
+ (let ((newdata (benchmark-call func repetitions)))
+ (if (<= (car newdata) 0)
+ ;; This can happen if we're unlucky, e.g. the process got preempted
+ ;; (or the GC ran) just during the empty-func loop.
+ ;; Just try again, hopefully this won't repeat itself.
+ (progn
+ ;; (message "Ignoring the %d iterations" repetitions)
+ (loop (* 2 repetitions) data))
+ (let* ((sum (cl-mapcar #'+ data (cons repetitions newdata)))
+ (totaltime (nth 1 sum)))
+ (if (>= totaltime time)
+ sum
+ (let* ((iter-time (/ totaltime (car sum)))
+ (missing-time (- time totaltime))
+ (missing-iter (/ missing-time iter-time)))
+ ;; `iter-time' is approximate because of effects like the GC,
+ ;; so multiply at most by 10, in case we are wildly off the mark.
+ (loop (max repetitions
+ (min (ceiling missing-iter)
+ (* 10 repetitions)))
+ sum))))))))
+
+;;;###autoload
(defmacro benchmark-run (&optional repetitions &rest forms)
"Time execution of FORMS.
If REPETITIONS is supplied as a number, run FORMS that many times,
@@ -53,19 +109,7 @@ See also `benchmark-run-compiled'."
(unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
- (let ((i (make-symbol "i"))
- (gcs (make-symbol "gcs"))
- (gc (make-symbol "gc")))
- `(let ((,gc gc-elapsed)
- (,gcs gcs-done))
- (list ,(if (or (symbolp repetitions) (> repetitions 1))
- ;; Take account of the loop overhead.
- `(- (benchmark-elapse (dotimes (,i ,repetitions)
- ,@forms))
- (benchmark-elapse (dotimes (,i ,repetitions))))
- `(benchmark-elapse ,@forms))
- (- gcs-done ,gcs)
- (- gc-elapsed ,gc)))))
+ `(benchmark-call (lambda () ,@forms) ,repetitions))
;;;###autoload
(defmacro benchmark-run-compiled (&optional repetitions &rest forms)
@@ -77,21 +121,7 @@ result. The overhead of the `lambda's is accounted for."
(unless (or (natnump repetitions) (and repetitions (symbolp repetitions)))
(setq forms (cons repetitions forms)
repetitions 1))
- (let ((i (make-symbol "i"))
- (gcs (make-symbol "gcs"))
- (gc (make-symbol "gc"))
- (code (byte-compile `(lambda () ,@forms)))
- (lambda-code (byte-compile '(lambda ()))))
- `(let ((,gc gc-elapsed)
- (,gcs gcs-done))
- (list ,(if (or (symbolp repetitions) (> repetitions 1))
- ;; Take account of the loop overhead.
- `(- (benchmark-elapse (dotimes (,i ,repetitions)
- (funcall ,code)))
- (benchmark-elapse (dotimes (,i ,repetitions)
- (funcall ,lambda-code))))
- `(benchmark-elapse (funcall ,code)))
- (- gcs-done ,gcs) (- gc-elapsed ,gc)))))
+ `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions))
;;;###autoload
(defun benchmark (repetitions form)
@@ -99,9 +129,15 @@ result. The overhead of the `lambda's is accounted for."
Interactively, REPETITIONS is taken from the prefix arg, and
the command prompts for the form to benchmark.
For non-interactive use see also `benchmark-run' and
-`benchmark-run-compiled'."
+`benchmark-run-compiled'.
+FORM can also be a function in which case we measure the time it takes
+to call it without any argument."
(interactive "p\nxForm: ")
- (let ((result (eval `(benchmark-run ,repetitions ,form) t)))
+ (let ((result (benchmark-call (eval (pcase form
+ ((or `#',_ `(lambda . ,_)) form)
+ (_ `(lambda () ,form)))
+ t)
+ repetitions)))
(if (zerop (nth 1 result))
(message "Elapsed time: %fs" (car result))
(message "Elapsed time: %fs (%fs in %d GCs)" (car result)
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 8d384e2c240..247fb91379e 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -1,4 +1,4 @@
-;;; bindat.el --- binary data structure packing and unpacking.
+;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -26,7 +26,7 @@
;; Packing and unpacking of (binary) data structures.
;;
;; The data formats used in binary files and network protocols are
-;; often structed data which can be described by a C-style structure
+;; often structured data which can be described by a C-style structure
;; such as the one shown below. Using the bindat package, decoding
;; and encoding binary data formats like these is made simple using a
;; structure specification which closely resembles the C style
@@ -41,57 +41,61 @@
;; Consider the following C structures:
;;
;; struct header {
-;; unsigned long dest_ip;
-;; unsigned long src_ip;
-;; unsigned short dest_port;
-;; unsigned short src_port;
+;; uint32_t dest_ip;
+;; uint32_t src_ip;
+;; uint16_t dest_port;
+;; uint16_t src_port;
;; };
;;
;; struct data {
-;; unsigned char type;
-;; unsigned char opcode;
-;; unsigned long length; /* In little endian order */
+;; uint8_t type;
+;; uint8_t opcode;
+;; uint32_t length; /* In little endian order */
;; unsigned char id[8]; /* nul-terminated string */
;; unsigned char data[/* (length + 3) & ~3 */];
;; };
;;
;; struct packet {
;; struct header header;
-;; unsigned char items;
+;; uint8_t items;
;; unsigned char filler[3];
;; struct data item[/* items */];
;; };
;;
-;; The corresponding Lisp bindat specification looks like this:
+;; The corresponding Lisp bindat specification could look like this:
+;;
+;; (bindat-defmacro ip () '(vec 4 byte))
;;
;; (setq header-bindat-spec
-;; '((dest-ip ip)
+;; (bindat-type
+;; (dest-ip ip)
;; (src-ip ip)
-;; (dest-port u16)
-;; (src-port u16)))
+;; (dest-port uint 16)
+;; (src-port uint 16)))
;;
;; (setq data-bindat-spec
-;; '((type u8)
+;; (bindat-type
+;; (type u8)
;; (opcode u8)
-;; (length u16r) ;; little endian order
+;; (length uintr 32) ;; little endian order
;; (id strz 8)
-;; (data vec (length))
-;; (align 4)))
+;; (data vec length)
+;; (_ align 4)))
;;
;; (setq packet-bindat-spec
-;; '((header struct header-bindat-spec)
-;; (items u8)
-;; (fill 3)
-;; (item repeat (items)
-;; (struct data-bindat-spec))))
-;;
+;; (bindat-type
+;; (header type header-bindat-spec)
+;; (nitems u8)
+;; (_ fill 3)
+;; (items repeat nitems type data-bindat-spec)))
;;
;; A binary data representation may look like
;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0
;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0
;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ]
;;
-;; The corresponding decoded structure looks like
+;; The corresponding decoded structure returned by `bindat-unpack' (or taken
+;; by `bindat-pack') looks like:
;;
;; ((header
;; (dest-ip . [192 168 1 100])
@@ -111,97 +115,30 @@
;; (type . 1))))
;;
;; To access a specific value in this structure, use the function
-;; bindat-get-field with the structure as first arg followed by a list
+;; `bindat-get-field' with the structure as first arg followed by a list
;; of field names and array indexes, e.g. using the data above,
;; (bindat-get-field decoded-structure 'item 1 'id)
;; returns "BCDEFG".
-;; Binary Data Structure Specification Format
-;; ------------------------------------------
-
-;; We recommend using names that end in `-bindat-spec'; such names
-;; are recognized automatically as "risky" variables.
-
-;; The data specification is formatted as follows:
-
-;; SPEC ::= ( ITEM... )
-
-;; ITEM ::= ( [FIELD] TYPE )
-;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only
-;; | ( [FIELD] fill LEN ) -- skip LEN bytes
-;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes
-;; | ( [FIELD] struct SPEC_NAME )
-;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] )
-;; | ( [FIELD] repeat COUNT ITEM... )
-
-;; -- In (eval EXPR), the value of the last field is available in
-;; the dynamically bound variable `last'.
-
-;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE
-;; | u8 | byte -- length 1
-;; | u16 | word | short -- length 2, network byte order
-;; | u24 -- 3-byte value
-;; | u32 | dword | long -- length 4, network byte order
-;; | u16r | u24r | u32r -- little endian byte order.
-;; | str LEN -- LEN byte string
-;; | strz LEN -- LEN byte (zero-terminated) string
-;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8)
-;; | ip -- 4 byte vector
-;; | bits LEN -- List with bits set in LEN bytes.
-;;
-;; -- Note: 32 bit values may be limited by emacs' INTEGER
-;; implementation limits.
-;;
-;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13)
-;; and 0x1c 0x28 to (3 5 10 11 12).
-
-;; FIELD ::= ( eval EXPR ) -- use result as NAME
-;; | NAME
-
-;; LEN ::= ARG
-;; | <omitted> | nil -- LEN = 1
-
-
-;; TAG_VAL ::= ARG
-
-;; TAG ::= LISP_CONSTANT
-;; | ( eval EXPR ) -- return non-nil if tag match;
-;; current TAG_VAL in `tag'.
-
-;; ARG ::= ( eval EXPR ) -- interpret result as ARG
-;; | INTEGER_CONSTANT
-;; | DEREF
-
-;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative
-;; to current structure spec.
-;; -- see bindat-get-field
-
-;; A `union' specification
-;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)])
-;; is interpreted by evalling TAG_VAL and then comparing that to
-;; each TAG using equal; if a match is found, the corresponding SPEC
-;; is used.
-;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the
-;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil.
-;; Finally, if TAG is t, the corresponding SPEC is used unconditionally.
-;;
-;; An `eval' specification
-;; ([FIELD] eval FORM)
-;; is interpreted by evalling FORM for its side effects only.
-;; If FIELD is specified, the value is bound to that field.
-;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack').
-
;;; Code:
;; Helper functions for structure unpacking.
-;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX
+;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x)) ;For `named-let'.
+
+(cl-defstruct (bindat--type
+ (:predicate nil)
+ (:constructor bindat--make))
+ le ue pe)
(defvar bindat-raw)
(defvar bindat-idx)
-(defun bindat--unpack-u8 ()
+(defsubst bindat--unpack-u8 ()
(prog1
- (aref bindat-raw bindat-idx)
+ (aref bindat-raw bindat-idx)
(setq bindat-idx (1+ bindat-idx))))
(defun bindat--unpack-u16 ()
@@ -222,133 +159,140 @@
(defun bindat--unpack-u32r ()
(logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16)))
+(defun bindat--unpack-str (len)
+ (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
+ (setq bindat-idx (+ bindat-idx len))
+ (if (stringp s) s
+ (apply #'unibyte-string s))))
+
+(defun bindat--unpack-strz (len)
+ (let ((i 0) s)
+ (while (and (if len (< i len) t) (/= (aref bindat-raw (+ bindat-idx i)) 0))
+ (setq i (1+ i)))
+ (setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
+ (setq bindat-idx (+ bindat-idx len))
+ (if (stringp s) s
+ (apply #'unibyte-string s))))
+
+(defun bindat--unpack-bits (len)
+ (let ((bits nil) (bnum (1- (* 8 len))) j m)
+ (while (>= bnum 0)
+ (if (= (setq m (bindat--unpack-u8)) 0)
+ (setq bnum (- bnum 8))
+ (setq j 128)
+ (while (> j 0)
+ (if (/= 0 (logand m j))
+ (setq bits (cons bnum bits)))
+ (setq bnum (1- bnum)
+ j (ash j -1)))))
+ bits))
+
(defun bindat--unpack-item (type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
- (cond
- ((memq type '(u8 byte))
- (bindat--unpack-u8))
- ((memq type '(u16 word short))
- (bindat--unpack-u16))
- ((eq type 'u24)
- (bindat--unpack-u24))
- ((memq type '(u32 dword long))
- (bindat--unpack-u32))
- ((eq type 'u16r)
- (bindat--unpack-u16r))
- ((eq type 'u24r)
- (bindat--unpack-u24r))
- ((eq type 'u32r)
- (bindat--unpack-u32r))
- ((eq type 'bits)
- (let ((bits nil) (bnum (1- (* 8 len))) j m)
- (while (>= bnum 0)
- (if (= (setq m (bindat--unpack-u8)) 0)
- (setq bnum (- bnum 8))
- (setq j 128)
- (while (> j 0)
- (if (/= 0 (logand m j))
- (setq bits (cons bnum bits)))
- (setq bnum (1- bnum)
- j (ash j -1)))))
- bits))
- ((eq type 'str)
- (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
- (setq bindat-idx (+ bindat-idx len))
- (if (stringp s) s
- (apply #'unibyte-string s))))
- ((eq type 'strz)
- (let ((i 0) s)
- (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
- (setq i (1+ i)))
- (setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
- (setq bindat-idx (+ bindat-idx len))
- (if (stringp s) s
- (apply #'unibyte-string s))))
- ((eq type 'vec)
- (let ((v (make-vector len 0)) (i 0) (vlen 1))
+ (pcase type
+ ((or 'u8 'byte) (bindat--unpack-u8))
+ ((or 'u16 'word 'short) (bindat--unpack-u16))
+ ('u24 (bindat--unpack-u24))
+ ((or 'u32 'dword 'long) (bindat--unpack-u32))
+ ('u16r (bindat--unpack-u16r))
+ ('u24r (bindat--unpack-u24r))
+ ('u32r (bindat--unpack-u32r))
+ ('bits (bindat--unpack-bits len))
+ ('str (bindat--unpack-str len))
+ ('strz (bindat--unpack-strz len))
+ ('vec
+ (let ((v (make-vector len 0)) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
- (while (< i len)
- (aset v i (bindat--unpack-item type vlen vectype))
- (setq i (1+ i)))
+ (dotimes (i len)
+ (aset v i (bindat--unpack-item type vlen vectype)))
v))
- (t nil)))
+ (_ nil)))
+
+(defsubst bindat--align (n len)
+ (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way?
(defun bindat--unpack-group (spec)
+ ;; FIXME: Introduce a new primitive so we can mark `bindat-unpack'
+ ;; as obsolete (maybe that primitive should be a macro which takes
+ ;; a bindat type *expression* as argument).
+ (if (cl-typep spec 'bindat--type)
+ (funcall (bindat--type-ue spec))
+ (with-suppressed-warnings ((lexical struct last))
+ (defvar struct) (defvar last))
(let (struct last)
- (while spec
- (let* ((item (car spec))
- (field (car item))
+ (dolist (item spec)
+ (let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3)
data)
- (setq spec (cdr spec))
- (if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
+ (if (and (consp field) (eq (car field) 'eval))
+ (setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
- (setq len (apply 'bindat-get-field struct len)))
+ (setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
- (cond
- ((eq type 'eval)
+ (pcase type
+ ('eval
(if field
- (setq data (eval len))
- (eval len)))
- ((eq type 'fill)
+ (setq data (eval len t))
+ (eval len t)))
+ ('fill
(setq bindat-idx (+ bindat-idx len)))
- ((eq type 'align)
- (while (/= (% bindat-idx len) 0)
- (setq bindat-idx (1+ bindat-idx))))
- ((eq type 'struct)
- (setq data (bindat--unpack-group (eval len))))
- ((eq type 'repeat)
- (let ((index 0) (count len))
- (while (< index count)
- (setq data (cons (bindat--unpack-group (nthcdr tail item)) data))
- (setq index (1+ index)))
- (setq data (nreverse data))))
- ((eq type 'union)
+ ('align
+ (setq bindat-idx (bindat--align bindat-idx len)))
+ ('struct
+ (setq data (bindat--unpack-group (eval len t))))
+ ('repeat
+ (dotimes (_ len)
+ (push (bindat--unpack-group (nthcdr tail item)) data))
+ (setq data (nreverse data)))
+ ('union
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(setq data (bindat--unpack-group (cdr case))
cases nil)))))
- (t
+ ((pred integerp) (debug t))
+ (_
(setq data (bindat--unpack-item type len vectype)
last data)))
(if data
- (if field
- (setq struct (cons (cons field data) struct))
- (setq struct (append data struct))))))
- struct))
-
-(defun bindat-unpack (spec bindat-raw &optional bindat-idx)
- "Return structured data according to SPEC for binary data in BINDAT-RAW.
-BINDAT-RAW is a unibyte string or vector.
-Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW."
- (when (multibyte-string-p bindat-raw)
+ (setq struct (if field
+ (cons (cons field data) struct)
+ (append data struct))))))
+ struct)))
+
+(defun bindat-unpack (spec raw &optional idx)
+ "Return structured data according to SPEC for binary data in RAW.
+RAW is a unibyte string or vector.
+Optional third arg IDX specifies the starting offset in RAW."
+ (when (multibyte-string-p raw)
(error "String is multibyte"))
- (unless bindat-idx (setq bindat-idx 0))
- (bindat--unpack-group spec))
+ (let ((bindat-idx (or idx 0))
+ (bindat-raw raw))
+ (bindat--unpack-group spec)))
(defun bindat-get-field (struct &rest field)
"In structured data STRUCT, return value of field named FIELD.
@@ -359,14 +303,12 @@ An integer value in the field list is taken as an array index,
e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(while (and struct field)
(setq struct (if (integerp (car field))
- (nth (car field) struct)
- (let ((val (assq (car field) struct)))
- (if (consp val) (cdr val)))))
+ (elt struct (car field))
+ (cdr (assq (car field) struct))))
(setq field (cdr field)))
struct)
-
-;; Calculate bindat-raw length of structured data
+;;;; Calculate bindat-raw length of structured data
(defvar bindat--fixed-length-alist
'((u8 . 1) (byte . 1)
@@ -376,85 +318,85 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(ip . 4)))
(defun bindat--length-group (struct spec)
- (let (last)
- (while spec
- (let* ((item (car spec))
- (field (car item))
+ (if (cl-typep spec 'bindat--type)
+ (funcall (bindat--type-le spec) struct)
+ (with-suppressed-warnings ((lexical struct last))
+ (defvar struct) (defvar last))
+ (let ((struct struct) last)
+ (dolist (item spec)
+ (let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
- (setq spec (cdr spec))
- (if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
+ (if (and (consp field) (eq (car field) 'eval))
+ (setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
- (setq len (apply 'bindat-get-field struct len)))
+ (setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
(while (eq type 'vec)
- (let ((vlen 1))
- (if (consp vectype)
- (setq len (* len (nth 1 vectype))
- type (nth 2 vectype))
- (setq type (or vectype 'u8)
- vectype nil))))
- (cond
- ((eq type 'eval)
+ (if (consp vectype)
+ (setq len (* len (nth 1 vectype))
+ type (nth 2 vectype))
+ (setq type (or vectype 'u8)
+ vectype nil)))
+ (pcase type
+ ('eval
(if field
- (setq struct (cons (cons field (eval len)) struct))
- (eval len)))
- ((eq type 'fill)
+ (setq struct (cons (cons field (eval len t)) struct))
+ (eval len t)))
+ ('fill
(setq bindat-idx (+ bindat-idx len)))
- ((eq type 'align)
- (while (/= (% bindat-idx len) 0)
- (setq bindat-idx (1+ bindat-idx))))
- ((eq type 'struct)
+ ('align
+ (setq bindat-idx (bindat--align bindat-idx len)))
+ ('struct
(bindat--length-group
- (if field (bindat-get-field struct field) struct) (eval len)))
- ((eq type 'repeat)
- (let ((index 0) (count len))
- (while (< index count)
- (bindat--length-group
- (nth index (bindat-get-field struct field))
- (nthcdr tail item))
- (setq index (1+ index)))))
- ((eq type 'union)
+ (if field (bindat-get-field struct field) struct) (eval len t)))
+ ('repeat
+ (dotimes (index len)
+ (bindat--length-group
+ (nth index (bindat-get-field struct field))
+ (nthcdr tail item))))
+ ('union
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(progn
(bindat--length-group struct (cdr case))
(setq cases nil))))))
- (t
+ (_
(if (setq type (assq type bindat--fixed-length-alist))
(setq len (* len (cdr type))))
(if field
(setq last (bindat-get-field struct field)))
- (setq bindat-idx (+ bindat-idx len))))))))
+ (setq bindat-idx (+ bindat-idx len)))))))))
(defun bindat-length (spec struct)
- "Calculate bindat-raw length for STRUCT according to bindat SPEC."
+ "Calculate `bindat-raw' length for STRUCT according to bindat SPEC."
(let ((bindat-idx 0))
(bindat--length-group struct spec)
bindat-idx))
-;; Pack structured data into bindat-raw
+;;;; Pack structured data into bindat-raw
-(defun bindat--pack-u8 (v)
+(defsubst bindat--pack-u8 (v)
(aset bindat-raw bindat-idx (logand v 255))
(setq bindat-idx (1+ bindat-idx)))
@@ -471,6 +413,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-u16 (ash v -16))
(bindat--pack-u16 v))
+(defun bindat--pack-u64 (v)
+ (bindat--pack-u32 (ash v -32))
+ (bindat--pack-u32 v))
+
(defun bindat--pack-u16r (v)
(aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255))
(aset bindat-raw bindat-idx (logand v 255))
@@ -484,150 +430,147 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-u16r v)
(bindat--pack-u16r (ash v -16)))
+(defun bindat--pack-u64r (v)
+ (bindat--pack-u32r v)
+ (bindat--pack-u32r (ash v -32)))
+
+(defun bindat--pack-str (len v)
+ (dotimes (i (min len (length v)))
+ (aset bindat-raw (+ bindat-idx i) (aref v i)))
+ (setq bindat-idx (+ bindat-idx len)))
+
+(defun bindat--pack-strz (v)
+ (let ((len (length v)))
+ (dotimes (i len)
+ (aset bindat-raw (+ bindat-idx i) (aref v i)))
+ (setq bindat-idx (+ bindat-idx len 1))))
+
+(defun bindat--pack-bits (len v)
+ (let ((bnum (1- (* 8 len))) j m)
+ (while (>= bnum 0)
+ (setq m 0)
+ (if (null v)
+ (setq bnum (- bnum 8))
+ (setq j 128)
+ (while (> j 0)
+ (if (memq bnum v)
+ (setq m (logior m j)))
+ (setq bnum (1- bnum)
+ j (ash j -1))))
+ (bindat--pack-u8 m))))
+
(defun bindat--pack-item (v type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
- (cond
- ((null v)
- (setq bindat-idx (+ bindat-idx len)))
- ((memq type '(u8 byte))
- (bindat--pack-u8 v))
- ((memq type '(u16 word short))
- (bindat--pack-u16 v))
- ((eq type 'u24)
- (bindat--pack-u24 v))
- ((memq type '(u32 dword long))
- (bindat--pack-u32 v))
- ((eq type 'u16r)
- (bindat--pack-u16r v))
- ((eq type 'u24r)
- (bindat--pack-u24r v))
- ((eq type 'u32r)
- (bindat--pack-u32r v))
- ((eq type 'bits)
- (let ((bnum (1- (* 8 len))) j m)
- (while (>= bnum 0)
- (setq m 0)
- (if (null v)
- (setq bnum (- bnum 8))
- (setq j 128)
- (while (> j 0)
- (if (memq bnum v)
- (setq m (logior m j)))
- (setq bnum (1- bnum)
- j (ash j -1))))
- (bindat--pack-u8 m))))
- ((memq type '(str strz))
- (let ((l (length v)) (i 0))
- (if (> l len) (setq l len))
- (while (< i l)
- (aset bindat-raw (+ bindat-idx i) (aref v i))
- (setq i (1+ i)))
- (setq bindat-idx (+ bindat-idx len))))
- ((eq type 'vec)
- (let ((l (length v)) (i 0) (vlen 1))
+ (pcase type
+ ((guard (null v)) (setq bindat-idx (+ bindat-idx len)))
+ ((or 'u8 'byte) (bindat--pack-u8 v))
+ ((or 'u16 'word 'short) (bindat--pack-u16 v))
+ ('u24 (bindat--pack-u24 v))
+ ((or 'u32 'dword 'long) (bindat--pack-u32 v))
+ ('u16r (bindat--pack-u16r v))
+ ('u24r (bindat--pack-u24r v))
+ ('u32r (bindat--pack-u32r v))
+ ('bits (bindat--pack-bits len v))
+ ((or 'str 'strz) (bindat--pack-str len v))
+ ('vec
+ (let ((l (length v)) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
vectype (nth 2 vectype))
(setq type (or vectype 'u8)
vectype nil))
(if (> l len) (setq l len))
- (while (< i l)
- (bindat--pack-item (aref v i) type vlen vectype)
- (setq i (1+ i)))))
- (t
+ (dotimes (i l)
+ (bindat--pack-item (aref v i) type vlen vectype))))
+ (_
(setq bindat-idx (+ bindat-idx len)))))
(defun bindat--pack-group (struct spec)
- (let (last)
- (while spec
- (let* ((item (car spec))
- (field (car item))
+ (if (cl-typep spec 'bindat--type)
+ (funcall (bindat--type-pe spec) struct)
+ (with-suppressed-warnings ((lexical struct last))
+ (defvar struct) (defvar last))
+ (let ((struct struct) last)
+ (dolist (item spec)
+ (let* ((field (car item))
(type (nth 1 item))
(len (nth 2 item))
(vectype (and (eq type 'vec) (nth 3 item)))
(tail 3))
- (setq spec (cdr spec))
- (if (and (consp field) (eq (car field) 'eval))
- (setq field (eval (car (cdr field)))))
(if (and type (consp type) (eq (car type) 'eval))
- (setq type (eval (car (cdr type)))))
+ (setq type (eval (car (cdr type)) t)))
(if (and len (consp len) (eq (car len) 'eval))
- (setq len (eval (car (cdr len)))))
+ (setq len (eval (car (cdr len)) t)))
(if (memq field '(eval fill align struct union))
(setq tail 2
len type
type field
field nil))
+ (if (and (consp field) (eq (car field) 'eval))
+ (setq field (eval (car (cdr field)) t)))
(if (and (consp len) (not (eq type 'eval)))
- (setq len (apply 'bindat-get-field struct len)))
+ (setq len (apply #'bindat-get-field struct len)))
(if (not len)
(setq len 1))
- (cond
- ((eq type 'eval)
+ (pcase type
+ ('eval
(if field
- (setq struct (cons (cons field (eval len)) struct))
- (eval len)))
- ((eq type 'fill)
+ (setq struct (cons (cons field (eval len t)) struct))
+ (eval len t)))
+ ('fill
(setq bindat-idx (+ bindat-idx len)))
- ((eq type 'align)
- (while (/= (% bindat-idx len) 0)
- (setq bindat-idx (1+ bindat-idx))))
- ((eq type 'struct)
+ ('align
+ (setq bindat-idx (bindat--align bindat-idx len)))
+ ('struct
(bindat--pack-group
- (if field (bindat-get-field struct field) struct) (eval len)))
- ((eq type 'repeat)
- (let ((index 0) (count len))
- (while (< index count)
- (bindat--pack-group
- (nth index (bindat-get-field struct field))
- (nthcdr tail item))
- (setq index (1+ index)))))
- ((eq type 'union)
+ (if field (bindat-get-field struct field) struct) (eval len t)))
+ ('repeat
+ (dotimes (index len)
+ (bindat--pack-group
+ (nth index (bindat-get-field struct field))
+ (nthcdr tail item))))
+ ('union
+ (with-suppressed-warnings ((lexical tag))
+ (defvar tag))
(let ((tag len) (cases (nthcdr tail item)) case cc)
(while cases
(setq case (car cases)
cases (cdr cases)
cc (car case))
(if (or (equal cc tag) (equal cc t)
- (and (consp cc) (eval cc)))
+ (and (consp cc) (eval cc t)))
(progn
(bindat--pack-group struct (cdr case))
(setq cases nil))))))
- (t
+ (_
(setq last (bindat-get-field struct field))
(bindat--pack-item last type len vectype)
- ))))))
+ )))))))
-(defun bindat-pack (spec struct &optional bindat-raw bindat-idx)
+(defun bindat-pack (spec struct &optional raw idx)
"Return binary data packed according to SPEC for structured data STRUCT.
-Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to
+Optional third arg RAW is a pre-allocated unibyte string or vector to
pack into.
-Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW."
- (when (multibyte-string-p bindat-raw)
+Optional fourth arg IDX is the starting offset into RAW."
+ (when (multibyte-string-p raw)
(error "Pre-allocated string is multibyte"))
- (let ((no-return bindat-raw))
- (unless bindat-idx (setq bindat-idx 0))
- (unless bindat-raw
- (setq bindat-raw (make-string (+ bindat-idx (bindat-length spec struct)) 0)))
+ (let* ((bindat-idx (or idx 0))
+ (bindat-raw
+ (or raw
+ (make-string (+ bindat-idx (bindat-length spec struct)) 0))))
(bindat--pack-group struct spec)
- (if no-return nil bindat-raw)))
+ (if raw nil bindat-raw)))
-
-;; Misc. format conversions
+;;;; Misc. format conversions
(defun bindat-format-vector (vect fmt sep &optional len)
"Format vector VECT using element format FMT and separator SEP.
Result is a string with each element of VECT formatted using FMT and
separated by the string SEP. If optional fourth arg LEN is given, use
only that many elements from VECT."
- (unless len
- (setq len (length vect)))
- (let ((i len) (fmt2 (concat sep fmt)) (s nil))
- (while (> i 0)
- (setq i (1- i)
- s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s)))
- (apply 'concat s)))
+ (when len (setq vect (substring vect 0 len)))
+ (mapconcat (lambda (x) (format fmt x)) vect sep))
(defun bindat-vector-to-dec (vect &optional sep)
"Format vector VECT in decimal format separated by dots.
@@ -635,7 +578,7 @@ If optional second arg SEP is a string, use that as separator."
(bindat-format-vector vect "%d" (if (stringp sep) sep ".")))
(defun bindat-vector-to-hex (vect &optional sep)
- "Format vector VECT in hex format separated by dots.
+ "Format vector VECT in hex format separated by colons.
If optional second arg SEP is a string, use that as separator."
(bindat-format-vector vect "%02x" (if (stringp sep) sep ":")))
@@ -647,6 +590,393 @@ The port (if any) is omitted. IP can be a string, as well."
(format "%d.%d.%d.%d"
(aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3))))
+;;;; New approach based on macro-expansion
+
+;; Further improvements suggested by reading websocket.el:
+;; - Support for bit-sized fields?
+;;
+;; - Add some way to verify redundant/checksum fields's contents without
+;; having to provide a complete `:unpack-val' expression.
+;; The `:pack-val' thingy can work nicely to compute checksum fields
+;; based on previous fields's contents (without impacting or being impacted
+;; by the unpacked representation), but if we want to verify
+;; those checksums when unpacking, we have to use the :unpack-val
+;; and build the whole object by hand instead of being able to focus
+;; just on the checksum field.
+;; Maybe this could be related to `unit' type fields where we might like
+;; to make sure that the "value" we write into it is the same as the
+;; value it holds (tho those checks don't happen at the same time (pack
+;; vs unpack).
+;;
+;; - Support for packing/unpacking to/from something else than
+;; a unibyte string, e.g. from a buffer. Problems to do that are:
+;; - the `str' and `strz' types which use `substring' rather than reading
+;; one byte at a time.
+;; - the `align' and `fill' which just want to skip without reading/writing
+;; - the `pack-uint' case, which would prefer writing the LSB first.
+;; - the `align' case needs to now the current position in order to know
+;; how far to advance
+;;
+;; - Don't write triple code when the type is only ever used at a single place
+;; (e.g. to unpack).
+
+(defun bindat--unpack-uint (bitlen)
+ (let ((v 0) (bitsdone 0))
+ (while (< bitsdone bitlen)
+ (setq v (logior (ash v 8) (bindat--unpack-u8)))
+ (setq bitsdone (+ bitsdone 8)))
+ v))
+
+(defun bindat--unpack-uintr (bitlen)
+ (let ((v 0) (bitsdone 0))
+ (while (< bitsdone bitlen)
+ (setq v (logior v (ash (bindat--unpack-u8) bitsdone)))
+ (setq bitsdone (+ bitsdone 8)))
+ v))
+
+(defun bindat--pack-uint (bitlen v)
+ (let* ((len (/ bitlen 8))
+ (shift (- (* 8 (1- len)))))
+ (dotimes (_ len)
+ (bindat--pack-u8 (logand 255 (ash v shift)))
+ (setq shift (+ 8 shift)))))
+
+(defun bindat--pack-uintr (bitlen v)
+ (let* ((len (/ bitlen 8)))
+ (dotimes (_ len)
+ (bindat--pack-u8 (logand v 255))
+ (setq v (ash v -8)))))
+
+(defmacro bindat--pcase (&rest args)
+ "Like `pcase' but optimize the code under the assumption that it's exhaustive."
+ (declare (indent 1) (debug pcase))
+ `(pcase ,@args (pcase--dontcare nil)))
+
+(cl-defgeneric bindat--type (op head &rest args)
+ "Return the code for the operation OP of the Bindat type (HEAD . ARGS).
+OP can be one of: unpack', (pack VAL), or (length VAL) where VAL
+is the name of a variable that will hold the value we need to pack.")
+
+(cl-defmethod bindat--type (op (_ (eql byte)))
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-u8))
+ (`(length . ,_) `(cl-incf bindat-idx 1))
+ (`(pack . ,args) `(bindat--pack-u8 . ,args))))
+
+(cl-defmethod bindat--type (op (_ (eql uint)) n)
+ (if (eq n 8) (bindat--type op 'byte)
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-uint ,n))
+ (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8)))
+ (`(pack . ,args) `(bindat--pack-uint ,n . ,args)))))
+
+(cl-defmethod bindat--type (op (_ (eql uintr)) n)
+ (if (eq n 8) (bindat--type op 'byte)
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-uintr ,n))
+ (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8)))
+ (`(pack . ,args) `(bindat--pack-uintr ,n . ,args)))))
+
+(cl-defmethod bindat--type (op (_ (eql str)) len)
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-str ,len))
+ (`(length . ,_) `(cl-incf bindat-idx ,len))
+ (`(pack . ,args) `(bindat--pack-str ,len . ,args))))
+
+(cl-defmethod bindat--type (op (_ (eql strz)) &optional len)
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-strz ,len))
+ (`(length ,val)
+ `(cl-incf bindat-idx ,(cond
+ ((null len) `(length ,val))
+ ((numberp len) len)
+ (t `(or ,len (length ,val))))))
+ (`(pack . ,args)
+ (macroexp-let2 nil len len
+ `(if ,len
+ ;; Same as non-zero terminated strings since we don't actually add
+ ;; the terminating zero anyway (because we rely on the fact that
+ ;; `bindat-raw' was presumably initialized with all-zeroes before
+ ;; we started).
+ (bindat--pack-str ,len . ,args)
+ (bindat--pack-strz . ,args))))))
+
+(cl-defmethod bindat--type (op (_ (eql bits)) len)
+ (bindat--pcase op
+ ('unpack `(bindat--unpack-bits ,len))
+ (`(length . ,_) `(cl-incf bindat-idx ,len))
+ (`(pack . ,args) `(bindat--pack-bits ,len . ,args))))
+
+(cl-defmethod bindat--type (_op (_ (eql fill)) len)
+ `(progn (cl-incf bindat-idx ,len) nil))
+
+(cl-defmethod bindat--type (_op (_ (eql align)) len)
+ `(progn (cl-callf bindat--align bindat-idx ,len) nil))
+
+(cl-defmethod bindat--type (op (_ (eql type)) exp)
+ (bindat--pcase op
+ ('unpack `(funcall (bindat--type-ue ,exp)))
+ (`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args))
+ (`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args))))
+
+(cl-defmethod bindat--type (op (_ (eql vec)) count &rest type)
+ (unless type (setq type '(byte)))
+ (let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment)))
+ (bindat--pcase op
+ ('unpack
+ `(let* ((bindat--len ,count)
+ (bindat--v (make-vector bindat--len 0)))
+ (dotimes (bindat--i bindat--len)
+ (aset bindat--v bindat--i (funcall ,fun)))
+ bindat--v))
+ ((and `(length . ,_)
+ ;; FIXME: Improve the pattern match to recognize more complex
+ ;; "constant" functions?
+ (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun)
+ (guard (not (macroexp--fgrep `((,val)) len))))
+ ;; Optimize the case where the size of each element is constant.
+ `(cl-incf bindat-idx (* ,count ,len)))
+ ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)'
+ ;; which would be more efficient when `val' is a list,
+ ;; but that's only right if length of `val' is indeed `count'.
+ (`(,_ ,val)
+ `(dotimes (bindat--i ,count)
+ (funcall ,fun (elt ,val bindat--i)))))))
+
+(cl-defmethod bindat--type (op (_ (eql unit)) val)
+ (pcase op ('unpack val) (_ nil)))
+
+(cl-defmethod bindat--type (op (_ (eql struct)) &rest args)
+ (apply #'bindat--type op args))
+
+(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields)
+ (unless (consp (cdr fields))
+ (error "`:pack-var VAR' needs to be followed by fields"))
+ (bindat--pcase op
+ ((or 'unpack (guard (null var)))
+ (apply #'bindat--type op fields))
+ (`(,_ ,val)
+ `(let ((,var ,val)) ,(apply #'bindat--type op fields)))))
+
+(cl-defmethod bindat--type (op (field cons) &rest fields)
+ (named-let loop
+ ((fields (cons field fields))
+ (labels ()))
+ (bindat--pcase fields
+ ('nil
+ (bindat--pcase op
+ ('unpack
+ (let ((exp ()))
+ (pcase-dolist (`(,label . ,labelvar) labels)
+ (setq exp
+ (if (eq label '_)
+ (if exp `(nconc ,labelvar ,exp) labelvar)
+ `(cons (cons ',label ,labelvar) ,exp))))
+ exp))
+ (_ nil)))
+ (`(:unpack-val ,exp)
+ ;; Make it so `:kwd nil' is the same as the absence of the keyword arg.
+ (if exp (pcase op ('unpack exp)) (loop nil labels)))
+
+ (`((,label . ,type) . ,fields)
+ (let* ((get-field-val
+ (let ((tail (memq :pack-val type)))
+ ;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well
+ ;; when TYPE is a struct (a list of fields) or with extensions
+ ;; such as allowing TYPE to be `if ...'.
+ (if tail
+ (prog1 (cadr tail)
+ (setq type (butlast type (length tail)))))))
+ (fieldvar (make-symbol (format "field%d" (length fields))))
+ (labelvar
+ (cond
+ ((eq label '_) fieldvar)
+ ((keywordp label)
+ (intern (substring (symbol-name label) 1)))
+ (t label)))
+ (field-fun (bindat--fun type))
+ (rest-exp (loop fields `((,label . ,labelvar) . ,labels))))
+ (bindat--pcase op
+ ('unpack
+ (let ((code
+ `(let ((,labelvar (funcall ,field-fun)))
+ ,rest-exp)))
+ (if (or (eq label '_) (not (assq label labels)))
+ code
+ (macroexp-warn-and-return
+ (format "Duplicate label: %S" label)
+ code))))
+ (`(,_ ,val)
+ ;; `cdr-safe' is easier to optimize (can't signal an error).
+ `(let ((,fieldvar ,(or get-field-val
+ (if (eq label '_) val
+ `(cdr-safe (assq ',label ,val))))))
+ (funcall ,field-fun ,fieldvar)
+ ,@(when rest-exp
+ `((let ,(unless (eq labelvar fieldvar)
+ `((,labelvar ,fieldvar)))
+ (ignore ,labelvar)
+ ,rest-exp))))))))
+ (_ (error "Unrecognized format in bindat fields: %S" fields)))))
+
+(def-edebug-elem-spec 'bindat-struct
+ '([&rest (symbolp bindat-type &optional ":pack-val" def-form)]
+ &optional ":unpack-val" def-form))
+
+(def-edebug-elem-spec 'bindat-type
+ '(&or ["uint" def-form]
+ ["uintr" def-form]
+ ["str" def-form]
+ ["strz" &optional def-form]
+ ["bits" def-form]
+ ["fill" def-form]
+ ["align" def-form]
+ ["vec" def-form bindat-type]
+ ["repeat" def-form bindat-type]
+ ["type" def-form]
+ ["struct" bindat-struct]
+ ["unit" def-form]
+ [":pack-var" symbolp bindat-type]
+ symbolp ;; u8, u16, etc...
+ bindat-struct))
+
+(defmacro bindat-type (&rest type)
+ "Return the Bindat type value to pack&unpack TYPE.
+TYPE is a Bindat type expression. It can take the following forms:
+
+ uint BITLEN - Big-endian unsigned integer
+ uintr BITLEN - Little-endian unsigned integer
+ str LEN - Byte string
+ strz [LEN] - Zero-terminated byte-string
+ bits LEN - Bit vector (LEN is counted in bytes)
+ fill LEN - Just a filler
+ align LEN - Fill up to the next multiple of LEN bytes
+ vec COUNT TYPE - COUNT repetitions of TYPE
+ type EXP - Indirection; EXP should return a Bindat type value
+ unit EXP - 0-width type holding the value returned by EXP
+ struct FIELDS... - A composite type
+
+When the context makes it clear, the symbol `struct' can be omitted.
+A composite type is a list of FIELDS where each FIELD is of the form
+
+ (LABEL TYPE)
+
+where LABEL can be `_' if the field should not deserve a name.
+
+Composite types get normally packed/unpacked to/from alists, but this can be
+controlled in the following way:
+- If the list of fields ends with `:unpack-val EXP', then unpacking will
+ return the value of EXP (which has the previous fields in its scope).
+- If a field's TYPE is followed by `:pack-val EXP', then the value placed
+ into this field will be that returned by EXP instead of looking up the alist.
+- If the list of fields is preceded with `:pack-var VAR' then the object to
+ be packed is bound to VAR when evaluating the EXPs of `:pack-val'.
+
+All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated
+in the current lexical context extended with the previous fields.
+
+TYPE can additionally be one of the Bindat type macros defined with
+`bindat-defmacro' (and listed below) or an ELisp expression which returns
+a bindat type expression."
+ (declare (indent 0) (debug (bindat-type)))
+ `(progn
+ (defvar bindat-idx)
+ (bindat--make :ue ,(bindat--toplevel 'unpack type)
+ :le ,(bindat--toplevel 'length type)
+ :pe ,(bindat--toplevel 'pack type))))
+
+(eval-and-compile
+ (defconst bindat--primitives '(byte uint uintr str strz bits fill align
+ struct type vec unit)))
+
+(eval-and-compile
+ (defvar bindat--macroenv
+ (mapcar (lambda (s) (cons s (lambda (&rest args)
+ (bindat--makefun (cons s args)))))
+ bindat--primitives)))
+
+(defmacro bindat-defmacro (name args &rest body)
+ "Define a new Bindat type as a macro."
+ (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body)))
+ (let ((leaders ()))
+ (while (and (cdr body)
+ (or (stringp (car body))
+ (memq (car-safe (car body)) '(:documentation declare))))
+ (push (pop body) leaders))
+ ;; FIXME: Add support for Edebug decls to those macros.
+ `(eval-and-compile ;; Yuck! But needed to define types where you use them!
+ (setf (alist-get ',name bindat--macroenv)
+ (lambda ,args ,@(nreverse leaders)
+ (bindat--fun ,(macroexp-progn body)))))))
+
+(put 'bindat-type 'function-documentation '(bindat--make-docstring))
+(defun bindat--make-docstring ()
+ ;; Largely inspired from `pcase--make-docstring'.
+ (let* ((main (documentation (symbol-function 'bindat-type) 'raw))
+ (ud (help-split-fundoc main 'bindat-type)))
+ (require 'help-fns)
+ (declare-function help-fns--signature "help-fns")
+ (with-temp-buffer
+ (insert (or (cdr ud) main))
+ (pcase-dolist (`(,name . ,me) (reverse bindat--macroenv))
+ (unless (memq name bindat--primitives)
+ (let ((doc (documentation me 'raw)))
+ (insert "\n\n-- ")
+ (setq doc (help-fns--signature name doc me
+ (indirect-function me)
+ nil))
+ (insert "\n" (or doc "Not documented.")))))
+ (let ((combined-doc (buffer-string)))
+ (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
+
+(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte))
+(bindat-defmacro sint (bitlen r)
+ "Signed integer of size BITLEN.
+Bigendian if R is nil and little endian if not."
+ (let ((bl (make-symbol "bitlen"))
+ (max (make-symbol "max"))
+ (wrap (make-symbol "wrap")))
+ `(let* ((,bl ,bitlen)
+ (,max (ash 1 (1- ,bl)))
+ (,wrap (+ ,max ,max)))
+ (struct :pack-var v
+ (n if ,r (uintr ,bl) (uint ,bl)
+ :pack-val (if (< v 0) (+ v ,wrap) v))
+ :unpack-val (if (>= n ,max) (- n ,wrap) n)))))
+
+(bindat-defmacro repeat (count &rest type)
+ "Like `vec', but unpacks to a list rather than a vector."
+ `(:pack-var v
+ (v vec ,count ,@type :pack-val v)
+ :unpack-val (append v nil)))
+
+(defvar bindat--op nil
+ "The operation we're currently building.
+This is a simple symbol and can be one of: `unpack', `pack', or `length'.
+This is used during macroexpansion of `bindat-type' so that the
+macros know which code to generate.
+FIXME: this is closely related and very similar to the `op' argument passed
+to `bindat--type', yet it's annoyingly different.")
+
+(defun bindat--fun (type)
+ (if (or (keywordp (car type)) (consp (car type))) (cons 'struct type)
+ type))
+
+(defun bindat--makefun (type)
+ (let* ((v (make-symbol "v"))
+ (args (pcase bindat--op ('unpack ()) (_ (list v)))))
+ (pcase (apply #'bindat--type
+ (pcase bindat--op ('unpack 'unpack) (op `(,op . ,args)))
+ type)
+ (`(funcall ,f . ,(pred (equal args))) f) ;η-reduce.
+ (exp `(lambda ,args ,exp)))))
+
+(defun bindat--toplevel (op type)
+ (let* ((bindat--op op)
+ (env `(,@bindat--macroenv
+ ,@macroexpand-all-environment)))
+ (macroexpand-all (bindat--fun type) env)))
+
(provide 'bindat)
;;; bindat.el ends here
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 492218fcd7c..142f206428e 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -225,9 +225,17 @@
(byte-compile-log-lap-1 ,format-string ,@args)))
+(defvar byte-optimize--lexvars nil
+ "Lexical variables in scope, in reverse order of declaration.
+Each element is on the form (NAME KEEP [VALUE]), where:
+ NAME is the variable name,
+ KEEP is a boolean indicating whether the binding must be retained,
+ VALUE, if present, is a substitutable expression.
+Earlier variables shadow later ones with the same name.")
+
;;; byte-compile optimizers to support inlining
-(put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
+(put 'inline 'byte-optimizer #'byte-optimize-inline-handler)
(defun byte-optimize-inline-handler (form)
"byte-optimize-handler for the `inline' special-form."
@@ -266,106 +274,108 @@
((pred byte-code-function-p)
;; (message "Inlining byte-code for %S!" name)
;; The byte-code will be really inlined in byte-compile-unfold-bcf.
+ (byte-compile--check-arity-bytecode form fn)
`(,fn ,@(cdr form)))
((or `(lambda . ,_) `(closure . ,_))
- (if (not (or (eq fn localfn) ;From the same file => same mode.
- (eq (car fn) ;Same mode.
- (if lexical-binding 'closure 'lambda))))
- ;; 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.
- (progn
- ;; We can of course byte-compile the inlined function
- ;; first, and then inline its byte-code.
- (byte-compile name)
- `(,(symbol-function name) ,@(cdr form)))
- (let ((newfn (if (eq fn localfn)
- ;; If `fn' is from the same file, it has already
- ;; been preprocessed!
- `(function ,fn)
- (byte-compile-preprocess
- (byte-compile--reify-function fn)))))
- (if (eq (car-safe newfn) 'function)
- (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
- ;; This can happen because of macroexp-warn-and-return &co.
- (byte-compile-warn
- "Inlining closure %S failed" name)
- form))))
+ ;; 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.
+ ;; When the function comes from another file, we byte-compile
+ ;; the inlined function first, and then inline its byte-code.
+ ;; This also has the advantage that the final code does not
+ ;; depend on the order of compilation of ELisp files, making
+ ;; the build more reproducible.
+ (if (eq fn localfn)
+ ;; From the same file => same mode.
+ (macroexp--unfold-lambda `(,fn ,@(cdr form)))
+ ;; Since we are called from inside the optimiser, we need to make
+ ;; sure not to propagate lexvar values.
+ (let ((byte-optimize--lexvars nil)
+ ;; Silence all compilation warnings: the useful ones should
+ ;; be displayed when the function's source file will be
+ ;; compiled anyway, but more importantly we would otherwise
+ ;; emit spurious warnings here because we don't have the full
+ ;; context, such as `declare-functions' placed earlier in the
+ ;; source file's code or `with-suppressed-warnings' that
+ ;; surrounded the `defsubst'.
+ (byte-compile-warnings nil))
+ (byte-compile name))
+ (let ((bc (symbol-function name)))
+ (byte-compile--check-arity-bytecode form bc)
+ `(,bc ,@(cdr form)))))
(_ ;; 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))
- (arglist (nth 1 lambda))
- (body (cdr (cdr lambda)))
- optionalp restp
- bindings)
- (if (and (stringp (car body)) (cdr body))
- (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...
- ;; (if optionalp (error "multiple &optional keywords in %s" name))
- (if restp (error "&optional found after &rest in %s" name))
- (if (null (cdr arglist))
- (error "nothing after &optional in %s" name))
- (setq optionalp t))
- ((eq (car arglist) '&rest)
- ;; ...but it is by no stretch of the imagination a reasonable
- ;; thing that funcall_lambda() allows (&rest x y) and
- ;; (&rest x &optional y) in arglists.
- (if (null (cdr arglist))
- (error "nothing after &rest in %s" name))
- (if (cdr (cdr arglist))
- (error "multiple vars after &rest in %s" name))
- (setq restp t))
- (restp
- (setq bindings (cons (list (car arglist)
- (and values (cons 'list values)))
- bindings)
- values nil))
- ((and (not optionalp) (null values))
- (byte-compile-warn "attempt to open-code `%s' with too few arguments" name)
- (setq arglist nil values 'too-few))
- (t
- (setq bindings (cons (list (car arglist) (car values))
- bindings)
- values (cdr values))))
- (setq arglist (cdr arglist)))
- (if values
- (progn
- (or (eq values 'too-few)
- (byte-compile-warn
- "attempt to open-code `%s' with too many arguments" name))
- form)
-
- ;; The following leads to infinite recursion when loading a
- ;; file containing `(defsubst f () (f))', and then trying to
- ;; byte-compile that file.
- ;(setq body (mapcar 'byte-optimize-form body)))
-
- (let ((newform
- (if bindings
- (cons 'let (cons (nreverse bindings) body))
- (cons 'progn body))))
- (byte-compile-log " %s\t==>\t%s" form newform)
- newform))))
-
;;; implementing source-level optimizers
+(defvar byte-optimize--vars-outside-condition nil
+ "Alist of variables lexically bound outside conditionally executed code.
+Variables here are sensitive to mutation inside the conditional code,
+since their contents in sequentially later code depends on the path taken
+and may no longer be statically known.
+Same format as `byte-optimize--lexvars', with shared structure and contents.")
+
+(defvar byte-optimize--vars-outside-loop nil
+ "Alist of variables lexically bound outside the innermost `while' loop.
+Variables here are sensitive to mutation inside the loop, since this can
+occur an indeterminate number of times and thus have effect on code
+sequentially preceding the mutation itself.
+Same format as `byte-optimize--lexvars', with shared structure and contents.")
+
+(defvar byte-optimize--dynamic-vars nil
+ "List of variables declared as dynamic during optimisation.")
+
+(defun byte-optimize--substitutable-p (expr)
+ "Whether EXPR is a constant that can be propagated."
+ ;; Only consider numbers, symbols and strings to be values for substitution
+ ;; purposes. Numbers and symbols are immutable, and mutating string
+ ;; literals (or results from constant-evaluated string-returning functions)
+ ;; can be considered undefined.
+ ;; (What about other quoted values, like conses?)
+ (or (booleanp expr)
+ (numberp expr)
+ (stringp expr)
+ (and (consp expr)
+ (memq (car expr) '(quote function))
+ (symbolp (cadr expr)))
+ (keywordp expr)))
+
+(defmacro byte-optimize--pcase (exp &rest cases)
+ ;; When we do
+ ;;
+ ;; (pcase EXP
+ ;; (`(if ,exp ,then ,else) (DO-TEST))
+ ;; (`(plus ,e2 ,e2) (DO-ADD))
+ ;; (`(times ,e2 ,e2) (DO-MULT))
+ ;; ...)
+ ;;
+ ;; we usually don't want to fall back to the default case if
+ ;; the value of EXP is of a form like `(if E1 E2)' or `(plus E1)'
+ ;; or `(times E1 E2 E3)', instead we either want to signal an error
+ ;; that EXP has an unexpected shape, or we want to carry on as if
+ ;; it had the right shape (ignore the extra data and pretend the missing
+ ;; data is nil) because it should simply never happen.
+ ;;
+ ;; The macro below implements the second option by rewriting patterns
+ ;; like `(if ,exp ,then ,else)'
+ ;; to `(if . (or `(,exp ,then ,else) pcase--dontcare))'.
+ ;;
+ ;; The resulting macroexpansion is also significantly cleaner/smaller/faster.
+ (declare (indent 1) (debug pcase))
+ `(pcase ,exp
+ . ,(mapcar (lambda (case)
+ `(,(pcase (car case)
+ ((and `(,'\` (,_ . (,'\, ,_))) pat) pat)
+ (`(,'\` (,head . ,tail))
+ (list '\`
+ (cons head
+ (list '\, `(or ,(list '\` tail) pcase--dontcare)))))
+ (pat pat))
+ . ,(cdr case)))
+ cases)))
+
(defun byte-optimize-form-code-walker (form for-effect)
;;
;; For normal function calls, We can just mapcar the optimizer the cdr. But
@@ -374,228 +384,349 @@
;; the important aspect is that they are subrs that don't evaluate all of
;; their args.)
;;
- (let ((fn (car-safe form))
- tmp)
- (cond ((not (consp form))
- (if (not (and for-effect
- (or byte-compile-delete-errors
- (not (symbolp form))
- (eq form t))))
- form))
- ((eq fn 'quote)
- (if (cdr (cdr form))
- (byte-compile-warn "malformed quote form: `%s'"
- (prin1-to-string form)))
- ;; map (quote nil) to nil to simplify optimizer logic.
- ;; map quoted constants to nil if for-effect (just because).
- (and (nth 1 form)
- (not for-effect)
- form))
- ((eq (car-safe fn) 'lambda)
- (let ((newform (byte-compile-unfold-lambda form)))
- (if (eq newform form)
- ;; Some error occurred, avoid infinite recursion
- form
- (byte-optimize-form-code-walker newform for-effect))))
- ((eq (car-safe fn) 'closure) form)
- ((memq fn '(let let*))
- ;; recursively enter the optimizer for the bindings and body
- ;; of a let or let*. This for depth-firstness: forms that
- ;; are more deeply nested are optimized first.
- (cons fn
- (cons
- (mapcar (lambda (binding)
- (if (symbolp binding)
- binding
- (if (cdr (cdr binding))
- (byte-compile-warn "malformed let binding: `%s'"
- (prin1-to-string binding)))
- (list (car binding)
- (byte-optimize-form (nth 1 binding) nil))))
- (nth 1 form))
- (byte-optimize-body (cdr (cdr form)) for-effect))))
- ((eq fn 'cond)
- (cons fn
- (mapcar (lambda (clause)
- (if (consp clause)
- (cons
- (byte-optimize-form (car clause) nil)
- (byte-optimize-body (cdr clause) for-effect))
- (byte-compile-warn "malformed cond form: `%s'"
- (prin1-to-string clause))
- clause))
- (cdr form))))
- ((eq fn 'progn)
- ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
- (if (cdr (cdr form))
- (macroexp-progn (byte-optimize-body (cdr form) for-effect))
- (byte-optimize-form (nth 1 form) for-effect)))
- ((eq fn 'prog1)
- (if (cdr (cdr form))
- (cons 'prog1
- (cons (byte-optimize-form (nth 1 form) for-effect)
- (byte-optimize-body (cdr (cdr form)) t)))
- (byte-optimize-form (nth 1 form) for-effect)))
-
- ((memq fn '(save-excursion save-restriction save-current-buffer))
- ;; those subrs which have an implicit progn; it's not quite good
- ;; enough to treat these like normal function calls.
- ;; This can turn (save-excursion ...) into (save-excursion) which
- ;; will be optimized away in the lap-optimize pass.
- (cons fn (byte-optimize-body (cdr form) for-effect)))
-
- ((eq fn 'with-output-to-temp-buffer)
- ;; this is just like the above, except for the first argument.
- (cons fn
- (cons
- (byte-optimize-form (nth 1 form) nil)
- (byte-optimize-body (cdr (cdr form)) for-effect))))
-
- ((eq fn 'if)
- (when (< (length form) 3)
- (byte-compile-warn "too few arguments for `if'"))
- (cons fn
- (cons (byte-optimize-form (nth 1 form) nil)
- (cons
- (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.
- ;; 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.
- (if for-effect
- (let ((backwards (reverse (cdr form))))
- (while (and backwards
- (null (setcar backwards
- (byte-optimize-form (car backwards)
- for-effect))))
- (setq backwards (cdr backwards)))
- (if (and (cdr form) (null backwards))
- (byte-compile-log
- " all subforms of %s called for effect; deleted" form))
- (and backwards
- (cons fn (nreverse (mapcar 'byte-optimize-form
- backwards)))))
- (cons fn (mapcar 'byte-optimize-form (cdr form)))))
-
- ((eq fn 'interactive)
- (byte-compile-warn "misplaced interactive spec: `%s'"
- (prin1-to-string form))
- nil)
-
- ((eq fn 'function)
- ;; This forms is compiled as constant or by breaking out
- ;; all the subexpressions and compiling them separately.
- form)
-
- ((eq fn 'condition-case)
- (if byte-compile--use-old-handlers
- ;; Will be optimized later.
- form
- `(condition-case ,(nth 1 form) ;Not evaluated.
- ,(byte-optimize-form (nth 2 form) for-effect)
- ,@(mapcar (lambda (clause)
- `(,(car clause)
- ,@(byte-optimize-body (cdr clause) for-effect)))
- (nthcdr 3 form)))))
-
- ((eq fn 'unwind-protect)
- ;; the "protected" part of an unwind-protect is compiled (and thus
- ;; optimized) as a top-level form, so don't do it here. But the
- ;; non-protected part has the same for-effect status as the
- ;; unwind-protect itself. (The protected part is always for effect,
- ;; but that isn't handled properly yet.)
- (cons fn
- (cons (byte-optimize-form (nth 1 form) for-effect)
- (cdr (cdr form)))))
-
- ((eq fn 'catch)
- (cons fn
- (cons (byte-optimize-form (nth 1 form) nil)
- (if byte-compile--use-old-handlers
- ;; The body of a catch is compiled (and thus
- ;; optimized) as a top-level form, so don't do it
- ;; here.
- (cdr (cdr form))
- (byte-optimize-body (cdr form) for-effect)))))
-
- ((eq fn 'ignore)
- ;; Don't treat the args to `ignore' as being
- ;; computed for effect. We want to avoid the warnings
- ;; that might occur if they were treated that way.
- ;; However, don't actually bother calling `ignore'.
- `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
-
- ;; Needed 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"
- (prin1-to-string fn))
- form)
-
- ((and for-effect (setq tmp (get fn 'side-effect-free))
- (or byte-compile-delete-errors
- (eq tmp 'error-free)
- (progn
- (byte-compile-warn "value returned from %s is unused"
- (prin1-to-string form))
- nil)))
- (byte-compile-log " %s called for effect; deleted" fn)
- ;; appending a nil here might not be necessary, but it can't hurt.
- (byte-optimize-form
- (cons 'progn (append (cdr form) '(nil))) t))
+ ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably
+ ;; have no place in an optimizer: the corresponding tests should be
+ ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'.
+ (let ((fn (car-safe form)))
+ (byte-optimize--pcase form
+ ((pred (not consp))
+ (cond
+ ((and for-effect
+ (or byte-compile-delete-errors
+ (not (symbolp form))
+ (eq form t)
+ (keywordp form)))
+ nil)
+ ((symbolp form)
+ (let ((lexvar (assq form byte-optimize--lexvars)))
+ (cond
+ ((not lexvar) form)
+ (for-effect nil)
+ ((cddr lexvar) ; Value available?
+ (if (assq form byte-optimize--vars-outside-loop)
+ ;; Cannot substitute; mark for retention to avoid the
+ ;; variable being eliminated.
+ (progn
+ (setcar (cdr lexvar) t)
+ form)
+ ;; variable value to use
+ (caddr lexvar)))
+ (t form))))
+ (t form)))
+ (`(quote . ,v)
+ (if (or (not v) (cdr v))
+ (byte-compile-warn "malformed quote form: `%s'"
+ (prin1-to-string form)))
+ ;; Map (quote nil) to nil to simplify optimizer logic.
+ ;; Map quoted constants to nil if for-effect (just because).
+ (and (car v)
+ (not for-effect)
+ form))
+ (`(,(or 'let 'let*) . ,rest)
+ (cons fn (byte-optimize-let-form fn rest for-effect)))
+ (`(cond . ,clauses)
+ ;; The condition in the first clause is always executed, but
+ ;; right now we treat all of them as conditional for simplicity.
+ (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+ (cons fn
+ (mapcar (lambda (clause)
+ (if (consp clause)
+ (cons
+ (byte-optimize-form (car clause) nil)
+ (byte-optimize-body (cdr clause) for-effect))
+ (byte-compile-warn "malformed cond form: `%s'"
+ (prin1-to-string clause))
+ clause))
+ clauses))))
+ (`(progn . ,exps)
+ ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
+ (if (cdr exps)
+ (macroexp-progn (byte-optimize-body exps for-effect))
+ (byte-optimize-form (car exps) for-effect)))
+ (`(prog1 ,exp . ,exps)
+ (let ((exp-opt (byte-optimize-form exp for-effect)))
+ (if exps
+ (let ((exps-opt (byte-optimize-body exps t)))
+ (if (macroexp-const-p exp-opt)
+ `(progn ,@exps-opt ,exp-opt)
+ `(prog1 ,exp-opt ,@exps-opt)))
+ exp-opt)))
+
+ (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps)
+ ;; Those subrs which have an implicit progn; it's not quite good
+ ;; enough to treat these like normal function calls.
+ ;; This can turn (save-excursion ...) into (save-excursion) which
+ ;; will be optimized away in the lap-optimize pass.
+ (cons fn (byte-optimize-body exps for-effect)))
+
+ (`(if ,test ,then . ,else)
+ ;; FIXME: We are conservative here: any variable changed in the
+ ;; THEN branch will be barred from substitution in the ELSE
+ ;; branch, despite the branches being mutually exclusive.
+
+ ;; The test is always executed.
+ (let* ((test-opt (byte-optimize-form test nil))
+ (const (macroexp-const-p test-opt))
+ ;; The branches are traversed unconditionally when possible.
+ (byte-optimize--vars-outside-condition
+ (if const
+ byte-optimize--vars-outside-condition
+ byte-optimize--lexvars))
+ ;; Avoid traversing dead branches.
+ (then-opt (and test-opt (byte-optimize-form then for-effect)))
+ (else-opt (and (not (and test-opt const))
+ (byte-optimize-body else for-effect))))
+ `(if ,test-opt ,then-opt . ,else-opt)))
+
+ (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures.
+ ;; FIXME: We have to traverse the expressions in left-to-right
+ ;; order (because that is the order of evaluation and variable
+ ;; mutations must be found prior to their use), but doing so we miss
+ ;; some optimisation opportunities:
+ ;; consider (and A B) in a for-effect context, where B => nil.
+ ;; Then A could be optimised in a for-effect context too.
+ (let ((tail exps)
+ (args nil))
+ (when tail
+ ;; The first argument is always unconditional.
+ (push (byte-optimize-form
+ (car tail) (and for-effect (null (cdr tail))))
+ args)
+ (setq tail (cdr tail))
+ ;; Remaining arguments are conditional.
+ (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+ (while tail
+ (push (byte-optimize-form
+ (car tail) (and for-effect (null (cdr tail))))
+ args)
+ (setq tail (cdr tail)))))
+ (cons fn (nreverse args))))
+
+ (`(while ,exp . ,exps)
+ ;; FIXME: We conservatively prevent the substitution of any variable
+ ;; bound outside the loop in case it is mutated later in the loop,
+ ;; but this misses many opportunities: variables not mutated in the
+ ;; loop at all, and variables affecting the initial condition (which
+ ;; is always executed unconditionally).
+ (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars)
+ (byte-optimize--vars-outside-loop byte-optimize--lexvars)
+ (condition (byte-optimize-form exp nil))
+ (body (byte-optimize-body exps t)))
+ `(while ,condition . ,body)))
+
+
+ (`(interactive . ,_)
+ (byte-compile-warn "misplaced interactive spec: `%s'"
+ (prin1-to-string form))
+ nil)
+
+ (`(function . ,_)
+ ;; This forms is compiled as constant or by breaking out
+ ;; all the subexpressions and compiling them separately.
+ form)
- (t
- ;; Otherwise, no args can be considered to be for-effect,
- ;; even if the called function is for-effect, because we
- ;; don't know anything about that function.
- (let ((args (mapcar #'byte-optimize-form (cdr form))))
- (if (and (get fn 'pure)
- (byte-optimize-all-constp args))
- (list 'quote (apply fn (mapcar #'eval args)))
- (cons fn args)))))))
-
-(defun byte-optimize-all-constp (list)
- "Non-nil if all elements of LIST satisfy `macroexp-const-p'."
- (let ((constant t))
- (while (and list constant)
- (unless (macroexp-const-p (car list))
- (setq constant nil))
- (setq list (cdr list)))
- constant))
+ (`(condition-case ,var ,exp . ,clauses)
+ (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+ `(condition-case ,var ;Not evaluated.
+ ,(byte-optimize-form exp for-effect)
+ ,@(mapcar (lambda (clause)
+ (let ((byte-optimize--lexvars
+ (and lexical-binding
+ (if var
+ (cons (list var t)
+ byte-optimize--lexvars)
+ byte-optimize--lexvars))))
+ (cons (car clause)
+ (byte-optimize-body (cdr clause) for-effect))))
+ clauses))))
+
+ (`(unwind-protect ,exp . ,exps)
+ ;; The unwinding part of an unwind-protect is compiled (and thus
+ ;; optimized) as a top-level form, but run the optimizer for it here
+ ;; anyway for lexical variable usage and substitution. But the
+ ;; protected part has the same for-effect status as the
+ ;; unwind-protect itself. (The unwinding part is always for effect,
+ ;; but that isn't handled properly yet.)
+ (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars)
+ (bodyform (byte-optimize-form exp for-effect)))
+ (pcase exps
+ (`(:fun-body ,f)
+ `(unwind-protect ,bodyform
+ :fun-body ,(byte-optimize-form f nil)))
+ (_
+ `(unwind-protect ,bodyform
+ . ,(byte-optimize-body exps t))))))
+
+ (`(catch ,tag . ,exps)
+ (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+ `(catch ,(byte-optimize-form tag nil)
+ . ,(byte-optimize-body exps for-effect))))
+
+ (`(ignore . ,exps)
+ ;; Don't treat the args to `ignore' as being
+ ;; computed for effect. We want to avoid the warnings
+ ;; that might occur if they were treated that way.
+ ;; However, don't actually bother calling `ignore'.
+ `(progn ,@(mapcar #'byte-optimize-form exps) nil))
+
+ ;; Needed as long as we run byte-optimize-form after cconv.
+ (`(internal-make-closure . ,_)
+ ;; Look up free vars and mark them to be kept, so that they
+ ;; won't be optimised away.
+ (dolist (var (caddr form))
+ (let ((lexvar (assq var byte-optimize--lexvars)))
+ (when lexvar
+ (setcar (cdr lexvar) t))))
+ form)
-(defun byte-optimize-form (form &optional for-effect)
+ (`((lambda . ,_) . ,_)
+ (let ((newform (macroexp--unfold-lambda form)))
+ (if (eq newform form)
+ ;; Some error occurred, avoid infinite recursion.
+ form
+ (byte-optimize-form newform for-effect))))
+
+ ;; FIXME: Strictly speaking, I think this is a bug: (closure...)
+ ;; is a *value* and shouldn't appear in the car.
+ (`((closure . ,_) . ,_) form)
+
+ (`(setq . ,args)
+ (let ((var-expr-list nil))
+ (while args
+ (unless (and (consp args)
+ (symbolp (car args)) (consp (cdr args)))
+ (byte-compile-warn "malformed setq form: %S" form))
+ (let* ((var (car args))
+ (expr (cadr args))
+ (lexvar (assq var byte-optimize--lexvars))
+ (value (byte-optimize-form expr nil)))
+ (when lexvar
+ ;; Set a new value or inhibit further substitution.
+ (setcdr (cdr lexvar)
+ (and
+ ;; Inhibit if bound outside conditional code.
+ (not (assq var byte-optimize--vars-outside-condition))
+ ;; The new value must be substitutable.
+ (byte-optimize--substitutable-p value)
+ (list value)))
+ (setcar (cdr lexvar) t)) ; Mark variable to be kept.
+ (push var var-expr-list)
+ (push value var-expr-list))
+ (setq args (cddr args)))
+ (cons fn (nreverse var-expr-list))))
+
+ (`(defvar ,(and (pred symbolp) name) . ,rest)
+ (let ((optimized-rest (and rest
+ (cons (byte-optimize-form (car rest) nil)
+ (cdr rest)))))
+ (push name byte-optimize--dynamic-vars)
+ `(defvar ,name . ,optimized-rest)))
+
+ (`(,(pred byte-code-function-p) . ,exps)
+ (cons fn (mapcar #'byte-optimize-form exps)))
+
+ (`(,(pred (not symbolp)) . ,_)
+ (byte-compile-warn "`%s' is a malformed function"
+ (prin1-to-string fn))
+ form)
+
+ ((guard (when for-effect
+ (if-let ((tmp (get fn 'side-effect-free)))
+ (or byte-compile-delete-errors
+ (eq tmp 'error-free)
+ (progn
+ (byte-compile-warn "value returned from %s is unused"
+ (prin1-to-string form))
+ nil)))))
+ (byte-compile-log " %s called for effect; deleted" fn)
+ ;; appending a nil here might not be necessary, but it can't hurt.
+ (byte-optimize-form
+ (cons 'progn (append (cdr form) '(nil))) t))
+
+ (_
+ ;; Otherwise, no args can be considered to be for-effect,
+ ;; even if the called function is for-effect, because we
+ ;; don't know anything about that function.
+ (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
+ (if (get fn 'pure)
+ (byte-optimize-constant-args form)
+ form))))))
+
+(defun byte-optimize-one-form (form &optional for-effect)
"The source-level pass of the optimizer."
- ;;
- ;; First, optimize all sub-forms of this one.
- (setq form (byte-optimize-form-code-walker form for-effect))
- ;;
- ;; after optimizing all subforms, optimize this form until it doesn't
- ;; optimize any further. This means that some forms will be passed through
- ;; the optimizer many times, but that's necessary to make the for-effect
- ;; processing do as much as possible.
- ;;
- (let (opt new)
- (if (and (consp form)
- (symbolp (car form))
- (or ;; (and for-effect
- ;; ;; We don't have any of these yet, but we might.
- ;; (setq opt (get (car form)
- ;; 'byte-for-effect-optimizer)))
- (setq opt (function-get (car form) 'byte-optimizer)))
- (not (eq form (setq new (funcall opt form)))))
- (progn
-;; (if (equal form new) (error "bogus optimizer -- %s" opt))
- (byte-compile-log " %s\t==>\t%s" form new)
- (setq new (byte-optimize-form new for-effect))
- new)
- form)))
+ ;; Make optimiser aware of lexical arguments.
+ (let ((byte-optimize--lexvars
+ (mapcar (lambda (v) (list (car v) t))
+ byte-compile--lexical-environment)))
+ (byte-optimize-form form for-effect)))
+
+(defun byte-optimize-form (form &optional for-effect)
+ (while
+ (progn
+ ;; First, optimize all sub-forms of this one.
+ (setq form (byte-optimize-form-code-walker form for-effect))
+
+ ;; If a form-specific optimiser is available, run it and start over
+ ;; until a fixpoint has been reached.
+ (and (consp form)
+ (symbolp (car form))
+ (let ((opt (function-get (car form) 'byte-optimizer)))
+ (and opt
+ (let ((old form)
+ (new (funcall opt form)))
+ (byte-compile-log " %s\t==>\t%s" old new)
+ (setq form new)
+ (not (eq new old))))))))
+ form)
+
+(defun byte-optimize-let-form (head form for-effect)
+ ;; Recursively enter the optimizer for the bindings and body
+ ;; of a let or let*. This for depth-firstness: forms that
+ ;; are more deeply nested are optimized first.
+ (if lexical-binding
+ (let* ((byte-optimize--lexvars byte-optimize--lexvars)
+ (new-lexvars nil)
+ (let-vars nil))
+ (dolist (binding (car form))
+ (let* ((name (car binding))
+ (expr (byte-optimize-form (cadr binding) nil))
+ (value (and (byte-optimize--substitutable-p expr)
+ (list expr)))
+ (lexical (not (or (special-variable-p name)
+ (memq name byte-compile-bound-variables)
+ (memq name byte-optimize--dynamic-vars))))
+ (lexinfo (and lexical (cons name (cons nil value)))))
+ (push (cons name (cons expr (cdr lexinfo))) let-vars)
+ (when lexinfo
+ (push lexinfo (if (eq head 'let*)
+ byte-optimize--lexvars
+ new-lexvars)))))
+ (setq byte-optimize--lexvars
+ (append new-lexvars byte-optimize--lexvars))
+ ;; Walk the body expressions, which may mutate some of the records,
+ ;; and generate new bindings that exclude unused variables.
+ (let* ((byte-optimize--dynamic-vars byte-optimize--dynamic-vars)
+ (opt-body (byte-optimize-body (cdr form) for-effect))
+ (bindings nil))
+ (dolist (var let-vars)
+ ;; VAR is (NAME EXPR [KEEP [VALUE]])
+ (when (or (not (nthcdr 3 var)) (nth 2 var))
+ ;; Value not present, or variable marked to be kept.
+ (push (list (nth 0 var) (nth 1 var)) bindings)))
+ (cons bindings opt-body)))
+
+ ;; With dynamic binding, no substitutions are in effect.
+ (let ((byte-optimize--lexvars nil))
+ (cons
+ (mapcar (lambda (binding)
+ (if (symbolp binding)
+ binding
+ (when (or (atom binding) (cddr binding))
+ (byte-compile-warn "malformed let binding: `%S'" binding))
+ (list (car binding)
+ (byte-optimize-form (nth 1 binding) nil))))
+ (car form))
+ (byte-optimize-body (cdr form) for-effect)))))
(defun byte-optimize-body (forms all-for-effect)
@@ -664,45 +795,36 @@
(setq args (cons (car rest) args)))
(setq rest (cdr rest)))
(if (cdr constants)
- (if args
- (list (car form)
- (apply (car form) constants)
- (if (cdr args)
- (cons (car form) (nreverse args))
- (car args)))
- (apply (car form) constants))
- form)))
+ (let ((const (apply (car form) (nreverse constants))))
+ (if args
+ (append (list (car form) const)
+ (nreverse args))
+ const))
+ form)))
-;; Portable Emacs integers fall in this range.
-(defconst byte-opt--portable-max #x1fffffff)
-(defconst byte-opt--portable-min (- -1 byte-opt--portable-max))
-
-;; True if N is a number that works the same on all Emacs platforms.
-;; Portable Emacs fixnums are exactly representable as floats on all
-;; Emacs platforms, and (except for -0.0) any floating-point number
-;; that equals one of these integers must be the same on all
-;; platforms. Although other floating-point numbers such as 0.5 are
-;; also portable, it can be tricky to characterize them portably so
-;; they are not optimized.
-(defun byte-opt--portable-numberp (n)
- (and (numberp n)
- (<= byte-opt--portable-min n byte-opt--portable-max)
- (= n (floor n))
- (not (and (floatp n) (zerop n)
- (condition-case () (< (/ n) 0) (error))))))
-
-;; Use OP to reduce any leading prefix of portable numbers in the list
-;; (cons ACCUM ARGS) down to a single portable number, and return the
+(defun byte-optimize-min-max (form)
+ "Optimize `min' and `max'."
+ (let ((opt (byte-optimize-associative-math form)))
+ (if (and (consp opt) (memq (car opt) '(min max))
+ (= (length opt) 4))
+ ;; (OP x y z) -> (OP (OP x y) z), in order to use binary byte ops.
+ (list (car opt)
+ (list (car opt) (nth 1 opt) (nth 2 opt))
+ (nth 3 opt))
+ opt)))
+
+;; Use OP to reduce any leading prefix of constant numbers in the list
+;; (cons ACCUM ARGS) down to a single number, and return the
;; resulting list A of arguments. The idea is that applying OP to A
;; is equivalent to (but likely more efficient than) applying OP to
;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special
;; provision for (- X) or (/ X); for example, it is the caller’s
;; responsibility that (- 1 0) should not be "optimized" to (- 1).
(defun byte-opt--arith-reduce (op accum args)
- (when (byte-opt--portable-numberp accum)
+ (when (numberp accum)
(let (accum1)
- (while (and (byte-opt--portable-numberp (car args))
- (byte-opt--portable-numberp
+ (while (and (numberp (car args))
+ (numberp
(setq accum1 (condition-case ()
(funcall op accum (car args))
(error))))
@@ -725,6 +847,9 @@
(integer (if integer-is-first arg1 arg2))
(other (if integer-is-first arg2 arg1)))
(list (if (eq integer 1) '1+ '1-) other)))
+ ;; (+ x y z) -> (+ (+ x y) z)
+ ((= (length args) 3)
+ `(+ ,(byte-optimize-plus `(+ ,(car args) ,(cadr args))) ,@(cddr args)))
;; not further optimized
((equal args (cdr form)) form)
(t (cons '+ args)))))
@@ -747,35 +872,19 @@
;; (- x -1) --> (1+ x)
((equal (cdr args) '(-1))
(list '1+ (car args)))
- ;; (- n) -> -n, where n and -n are portable numbers.
+ ;; (- n) -> -n, where n and -n are constant numbers.
;; This must be done separately since byte-opt--arith-reduce
;; is not applied to (- n).
((and (null (cdr args))
- (byte-opt--portable-numberp (car args))
- (byte-opt--portable-numberp (- (car args))))
+ (numberp (car args)))
(- (car args)))
+ ;; (- x y z) -> (- (- x y) z)
+ ((= (length args) 3)
+ `(- ,(byte-optimize-minus `(- ,(car args) ,(cadr args))) ,@(cddr args)))
;; not further optimized
((equal args (cdr form)) form)
(t (cons '- args))))))
-(defun byte-optimize-1+ (form)
- (let ((args (cdr form)))
- (when (null (cdr args))
- (let ((n (car args)))
- (when (and (byte-opt--portable-numberp n)
- (byte-opt--portable-numberp (1+ n)))
- (setq form (1+ n))))))
- form)
-
-(defun byte-optimize-1- (form)
- (let ((args (cdr form)))
- (when (null (cdr args))
- (let ((n (car args)))
- (when (and (byte-opt--portable-numberp n)
- (byte-opt--portable-numberp (1- n)))
- (setq form (1- n))))))
- form)
-
(defun byte-optimize-multiply (form)
(let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form)))))
(cond
@@ -783,6 +892,10 @@
((null args) 1)
;; (* n) -> n, where n is a number
((and (null (cdr args)) (numberp (car args))) (car args))
+ ;; (* x y z) -> (* (* x y) z)
+ ((= (length args) 3)
+ `(* ,(byte-optimize-multiply `(* ,(car args) ,(cadr args)))
+ ,@(cddr args)))
;; not further optimized
((equal args (cdr form)) form)
(t (cons '* args)))))
@@ -811,10 +924,10 @@
(condition-case ()
(list 'quote (eval form))
(error form)))
- (t ;; This can enable some lapcode optimizations.
+ (t ;; Moving the constant to the end can enable some lapcode optimizations.
(list (car form) (nth 2 form) (nth 1 form)))))
-(defun byte-optimize-predicate (form)
+(defun byte-optimize-constant-args (form)
(let ((ok t)
(rest (cdr form)))
(while (and rest ok)
@@ -829,56 +942,80 @@
(defun byte-optimize-identity (form)
(if (and (cdr form) (null (cdr (cdr form))))
(nth 1 form)
- (byte-compile-warn "identity called with %d arg%s, but requires 1"
- (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s"))
form))
(defun byte-optimize--constant-symbol-p (expr)
"Whether EXPR is a constant symbol."
(and (macroexp-const-p expr) (symbolp (eval expr))))
+(defun byte-optimize--fixnump (o)
+ "Return whether O is guaranteed to be a fixnum in all Emacsen.
+See Info node `(elisp) Integer Basics'."
+ (and (fixnump o) (<= -536870912 o 536870911)))
+
(defun byte-optimize-equal (form)
- ;; Replace `equal' or `eql' with `eq' if at least one arg is a symbol.
+ ;; Replace `equal' or `eql' with `eq' if at least one arg is a
+ ;; symbol or fixnum.
(byte-optimize-binary-predicate
(if (= (length (cdr form)) 2)
(if (or (byte-optimize--constant-symbol-p (nth 1 form))
- (byte-optimize--constant-symbol-p (nth 2 form)))
+ (byte-optimize--constant-symbol-p (nth 2 form))
+ (byte-optimize--fixnump (nth 1 form))
+ (byte-optimize--fixnump (nth 2 form)))
(cons 'eq (cdr form))
form)
;; Arity errors reported elsewhere.
form)))
+(defun byte-optimize-eq (form)
+ (pcase (cdr form)
+ ((or `(,x nil) `(nil ,x)) `(not ,x))
+ (_ (byte-optimize-binary-predicate form))))
+
(defun byte-optimize-member (form)
;; Replace `member' or `memql' with `memq' if the first arg is a symbol,
- ;; or the second arg is a list of symbols.
+ ;; or the second arg is a list of symbols. Same with fixnums.
(if (= (length (cdr form)) 2)
(if (or (byte-optimize--constant-symbol-p (nth 1 form))
+ (byte-optimize--fixnump (nth 1 form))
(let ((arg2 (nth 2 form)))
(and (macroexp-const-p arg2)
(let ((listval (eval arg2)))
(and (listp listval)
- (not (memq nil (mapcar #'symbolp listval))))))))
+ (not (memq nil (mapcar
+ (lambda (o)
+ (or (symbolp o)
+ (byte-optimize--fixnump o)))
+ listval))))))))
(cons 'memq (cdr form))
form)
;; Arity errors reported elsewhere.
form))
+(defun byte-optimize-assoc (form)
+ ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq',
+ ;; if the first arg is a symbol or fixnum.
+ (cond
+ ((/= (length form) 3)
+ form)
+ ((or (byte-optimize--constant-symbol-p (nth 1 form))
+ (byte-optimize--fixnump (nth 1 form)))
+ (cons (if (eq (car form) 'assoc) 'assq 'rassq)
+ (cdr form)))
+ (t (byte-optimize-constant-args form))))
+
(defun byte-optimize-memq (form)
;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar))
- (if (/= (length (cdr form)) 2)
- (byte-compile-warn "memq called with %d arg%s, but requires 2"
- (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s"))
- (let ((list (nth 2 form)))
- (when (and (eq (car-safe list) 'quote)
+ (if (= (length (cdr form)) 2)
+ (let ((list (nth 2 form)))
+ (if (and (eq (car-safe list) 'quote)
(listp (setq list (cadr list)))
(= (length list) 1))
- (setq form (byte-optimize-and
- `(and ,(byte-optimize-predicate
- `(eq ,(nth 1 form) ',(nth 0 list)))
- ',list)))))
- (byte-optimize-predicate form)))
+ `(and (eq ,(nth 1 form) ',(nth 0 list))
+ ',list)
+ form))
+ ;; Arity errors reported elsewhere.
+ form))
(defun byte-optimize-concat (form)
"Merge adjacent constant arguments to `concat'."
@@ -907,62 +1044,38 @@
form ; No improvement.
(cons 'concat (nreverse newargs)))))
-(put 'identity 'byte-optimizer 'byte-optimize-identity)
-(put 'memq 'byte-optimizer 'byte-optimize-memq)
-(put 'memql 'byte-optimizer 'byte-optimize-member)
-(put 'member 'byte-optimizer 'byte-optimize-member)
-
-(put '+ 'byte-optimizer 'byte-optimize-plus)
-(put '* 'byte-optimizer 'byte-optimize-multiply)
-(put '- 'byte-optimizer 'byte-optimize-minus)
-(put '/ 'byte-optimizer 'byte-optimize-divide)
-(put 'max 'byte-optimizer 'byte-optimize-associative-math)
-(put 'min 'byte-optimizer 'byte-optimize-associative-math)
-
-(put '= 'byte-optimizer 'byte-optimize-binary-predicate)
-(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
-(put 'eql 'byte-optimizer 'byte-optimize-equal)
-(put 'equal 'byte-optimizer 'byte-optimize-equal)
-(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
-(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
-
-(put '< 'byte-optimizer 'byte-optimize-predicate)
-(put '> 'byte-optimizer 'byte-optimize-predicate)
-(put '<= 'byte-optimizer 'byte-optimize-predicate)
-(put '>= 'byte-optimizer 'byte-optimize-predicate)
-(put '1+ 'byte-optimizer 'byte-optimize-1+)
-(put '1- 'byte-optimizer 'byte-optimize-1-)
-(put 'not 'byte-optimizer 'byte-optimize-predicate)
-(put 'null 'byte-optimizer 'byte-optimize-predicate)
-(put 'consp 'byte-optimizer 'byte-optimize-predicate)
-(put 'listp 'byte-optimizer 'byte-optimize-predicate)
-(put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
-(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
-(put 'string< 'byte-optimizer 'byte-optimize-predicate)
-(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
-(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate)
-
-(put 'logand 'byte-optimizer 'byte-optimize-predicate)
-(put 'logior 'byte-optimizer 'byte-optimize-predicate)
-(put 'logxor 'byte-optimizer 'byte-optimize-predicate)
-(put 'lognot 'byte-optimizer 'byte-optimize-predicate)
-
-(put 'car 'byte-optimizer 'byte-optimize-predicate)
-(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
-(put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
-(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
-
-(put 'concat 'byte-optimizer 'byte-optimize-concat)
+(put 'identity 'byte-optimizer #'byte-optimize-identity)
+(put 'memq 'byte-optimizer #'byte-optimize-memq)
+(put 'memql 'byte-optimizer #'byte-optimize-member)
+(put 'member 'byte-optimizer #'byte-optimize-member)
+(put 'assoc 'byte-optimizer #'byte-optimize-assoc)
+(put 'rassoc 'byte-optimizer #'byte-optimize-assoc)
+
+(put '+ 'byte-optimizer #'byte-optimize-plus)
+(put '* 'byte-optimizer #'byte-optimize-multiply)
+(put '- 'byte-optimizer #'byte-optimize-minus)
+(put '/ 'byte-optimizer #'byte-optimize-divide)
+(put 'max 'byte-optimizer #'byte-optimize-min-max)
+(put 'min 'byte-optimizer #'byte-optimize-min-max)
+
+(put '= 'byte-optimizer #'byte-optimize-binary-predicate)
+(put 'eq 'byte-optimizer #'byte-optimize-eq)
+(put 'eql 'byte-optimizer #'byte-optimize-equal)
+(put 'equal 'byte-optimizer #'byte-optimize-equal)
+(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate)
+(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate)
+
+(put 'concat 'byte-optimizer #'byte-optimize-concat)
;; I'm not convinced that this is necessary. Doesn't the optimizer loop
;; take care of this? - Jamie
;; I think this may some times be necessary to reduce ie (quote 5) to 5,
;; so arithmetic optimizers recognize the numeric constant. - Hallvard
-(put 'quote 'byte-optimizer 'byte-optimize-quote)
+(put 'quote 'byte-optimizer #'byte-optimize-quote)
(defun byte-optimize-quote (form)
(if (or (consp (nth 1 form))
(and (symbolp (nth 1 form))
- (not (macroexp--const-symbol-p form))))
+ (not (macroexp--const-symbol-p (nth 1 form)))))
form
(nth 1 form)))
@@ -981,7 +1094,7 @@
nil))
((null (cdr (cdr form)))
(nth 1 form))
- ((byte-optimize-predicate form))))
+ ((byte-optimize-constant-args form))))
(defun byte-optimize-or (form)
;; Throw away nil's, and simplify if less than 2 args.
@@ -994,7 +1107,7 @@
(setq form (copy-sequence form)
rest (setcdr (memq (car rest) form) nil))))
(if (cdr (cdr form))
- (byte-optimize-predicate form)
+ (byte-optimize-constant-args form)
(nth 1 form))))
(defun byte-optimize-cond (form)
@@ -1076,16 +1189,16 @@
(if (nth 1 form)
form))
-(put 'and 'byte-optimizer 'byte-optimize-and)
-(put 'or 'byte-optimizer 'byte-optimize-or)
-(put 'cond 'byte-optimizer 'byte-optimize-cond)
-(put 'if 'byte-optimizer 'byte-optimize-if)
-(put 'while 'byte-optimizer 'byte-optimize-while)
+(put 'and 'byte-optimizer #'byte-optimize-and)
+(put 'or 'byte-optimizer #'byte-optimize-or)
+(put 'cond 'byte-optimizer #'byte-optimize-cond)
+(put 'if 'byte-optimizer #'byte-optimize-if)
+(put 'while 'byte-optimizer #'byte-optimize-while)
;; byte-compile-negation-optimizer lives in bytecomp.el
-(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
-(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
-(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
+(put '/= 'byte-optimizer #'byte-compile-negation-optimizer)
+(put 'atom 'byte-optimizer #'byte-compile-negation-optimizer)
+(put 'nlistp 'byte-optimizer #'byte-compile-negation-optimizer)
(defun byte-optimize-funcall (form)
@@ -1099,52 +1212,68 @@
(defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall.
;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
- (let ((fn (nth 1 form))
- (last (nth (1- (length form)) form))) ; I think this really is fastest
- (or (if (or (null last)
- (eq (car-safe last) 'quote))
- (if (listp (nth 1 last))
- (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
- (nconc (list 'funcall fn) butlast
- (mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn
- "last arg to apply can't be a literal atom: `%s'"
- (prin1-to-string last))
- nil))
- form)))
-
-(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
-(put 'apply 'byte-optimizer 'byte-optimize-apply)
-
-
-(put 'let 'byte-optimizer 'byte-optimize-letX)
-(put 'let* 'byte-optimizer 'byte-optimize-letX)
+ (if (= (length form) 2)
+ ;; single-argument `apply' is not worth optimizing (bug#40968)
+ form
+ (let ((fn (nth 1 form))
+ (last (nth (1- (length form)) form))) ; I think this really is fastest
+ (or (if (or (null last)
+ (eq (car-safe last) 'quote))
+ (if (listp (nth 1 last))
+ (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
+ (nconc (list 'funcall fn) butlast
+ (mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
+ (byte-compile-warn
+ "last arg to apply can't be a literal atom: `%s'"
+ (prin1-to-string last))
+ nil))
+ form))))
+
+(put 'funcall 'byte-optimizer #'byte-optimize-funcall)
+(put 'apply 'byte-optimizer #'byte-optimize-apply)
+
+
+(put 'let 'byte-optimizer #'byte-optimize-letX)
+(put 'let* 'byte-optimizer #'byte-optimize-letX)
(defun byte-optimize-letX (form)
- (cond ((null (nth 1 form))
- ;; No bindings
- (cons 'progn (cdr (cdr form))))
- ((or (nth 2 form) (nthcdr 3 form))
- form)
- ;; The body is nil
- ((eq (car form) 'let)
- (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form)))
- '(nil)))
- (t
- (let ((binds (reverse (nth 1 form))))
- (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil)))))
-
-
-(put 'nth 'byte-optimizer 'byte-optimize-nth)
+ (pcase form
+ ;; No bindings.
+ (`(,_ () . ,body)
+ `(progn . ,body))
+
+ ;; Body is empty or just contains a constant.
+ (`(,head ,bindings . ,(or '() `(,(and const (pred macroexp-const-p)))))
+ (if (eq head 'let)
+ `(progn ,@(mapcar (lambda (binding)
+ (and (consp binding) (cadr binding)))
+ bindings)
+ ,const)
+ `(let* ,(butlast bindings) ,(cadar (last bindings)) ,const)))
+
+ ;; Body is last variable.
+ (`(,head ,bindings ,(and var (pred symbolp) (pred (not keywordp))
+ (pred (not booleanp))
+ (guard (eq var (caar (last bindings))))))
+ (if (eq head 'let)
+ `(progn ,@(mapcar (lambda (binding)
+ (and (consp binding) (cadr binding)))
+ bindings))
+ `(let* ,(butlast bindings) ,(cadar (last bindings)))))
+
+ (_ form)))
+
+
+(put 'nth 'byte-optimizer #'byte-optimize-nth)
(defun byte-optimize-nth (form)
(if (= (safe-length form) 3)
(if (memq (nth 1 form) '(0 1))
(list 'car (if (zerop (nth 1 form))
(nth 2 form)
(list 'cdr (nth 2 form))))
- (byte-optimize-predicate form))
+ form)
form))
-(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr)
+(put 'nthcdr 'byte-optimizer #'byte-optimize-nthcdr)
(defun byte-optimize-nthcdr (form)
(if (= (safe-length form) 3)
(if (memq (nth 1 form) '(0 1 2))
@@ -1153,14 +1282,22 @@
(while (>= (setq count (1- count)) 0)
(setq form (list 'cdr form)))
form)
- (byte-optimize-predicate form))
+ form)
+ form))
+
+(put 'cons 'byte-optimizer #'byte-optimize-cons)
+(defun byte-optimize-cons (form)
+ ;; (cons X nil) => (list X)
+ (if (and (= (safe-length form) 3)
+ (null (nth 2 form)))
+ `(list ,(nth 1 form))
form))
;; Fixme: delete-char -> delete-region (byte-coded)
;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte,
;; string-make-multibyte for constant args.
-(put 'set 'byte-optimizer 'byte-optimize-set)
+(put 'set 'byte-optimizer #'byte-optimize-set)
(defun byte-optimize-set (form)
(let ((var (car-safe (cdr-safe form))))
(cond
@@ -1196,13 +1333,15 @@
;; I wonder if I missed any :-\)
(let ((side-effect-free-fns
'(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
- assoc assq
+ assq
+ bool-vector-count-consecutive bool-vector-count-population
+ bool-vector-subsetp
boundp buffer-file-name buffer-local-variables buffer-modified-p
buffer-substring byte-code-function-p
capitalize car-less-than-car car cdr ceiling char-after char-before
char-equal char-to-string char-width compare-strings
compare-window-configurations concat coordinates-in-window-p
- copy-alist copy-sequence copy-marker cos count-lines
+ copy-alist copy-sequence copy-marker copysign cos count-lines
current-time-string current-time-zone
decode-char
decode-time default-boundp default-value documentation downcase
@@ -1215,21 +1354,26 @@
frame-visible-p fround ftruncate
get gethash get-buffer get-buffer-window getenv get-file-buffer
hash-table-count
- int-to-string intern-soft
+ int-to-string intern-soft isnan
keymap-parent
- length line-beginning-position line-end-position
+ lax-plist-get ldexp
+ length length< length> length=
+ line-beginning-position line-end-position
local-variable-if-set-p local-variable-p locale-info
log log10 logand logb logcount logior lognot logxor lsh
- make-list make-string make-symbol marker-buffer max member memq min
- minibuffer-selected-window minibuffer-window
+ make-byte-code make-list make-string make-symbol mark marker-buffer max
+ member memq memql min minibuffer-selected-window minibuffer-window
mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
parse-colon-path plist-get plist-member
prefix-numeric-value previous-window prin1-to-string propertize
degrees-to-radians
- radians-to-degrees rassq rassoc read-from-string regexp-quote
- region-beginning region-end reverse round
- sin sqrt string string< string= string-equal string-lessp string-to-char
- string-to-number substring
+ radians-to-degrees rassq rassoc read-from-string regexp-opt
+ regexp-quote region-beginning region-end reverse round
+ sin sqrt string string< string= string-equal string-lessp
+ string> string-greaterp string-empty-p
+ string-prefix-p string-suffix-p string-blank-p
+ string-search string-to-char
+ string-to-number string-to-syntax substring
sxhash sxhash-equal sxhash-eq sxhash-eql
symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
string-make-multibyte string-as-multibyte string-as-unibyte
@@ -1252,7 +1396,7 @@
window-total-height window-total-width window-use-time window-vscroll
window-width zerop))
(side-effect-and-error-free-fns
- '(arrayp atom
+ '(always arrayp atom
bignump bobp bolp bool-vector-p
buffer-end buffer-list buffer-size buffer-string bufferp
car-safe case-table-p cdr-safe char-or-string-p characterp
@@ -1267,7 +1411,7 @@
invocation-directory invocation-name
keymapp keywordp
list listp
- make-marker mark mark-marker markerp max-char
+ make-marker mark-marker markerp max-char
memory-limit
mouse-movement-p
natnump nlistp not null number-or-marker-p numberp
@@ -1279,7 +1423,7 @@
standard-case-table standard-syntax-table stringp subrp symbolp
syntax-table syntax-table-p
this-command-keys this-command-keys-vector this-single-command-keys
- this-single-command-raw-keys
+ this-single-command-raw-keys type-of
user-real-login-name user-real-uid user-uid
vector vectorp visible-frame-list
wholenump window-configuration-p window-live-p
@@ -1296,9 +1440,9 @@
;; Pure functions are side-effect free functions whose values depend
;; only on their arguments, not on the platform. For these functions,
;; calls with constant arguments can be evaluated at compile time.
-;; This may shift runtime errors to compile time. For example, logand
-;; is pure since its results are machine-independent, whereas ash is
-;; not pure because (ash 1 29)'s value depends on machine word size.
+;; For example, ash is pure since its results are machine-independent,
+;; whereas lsh is not pure because (lsh -1 -1)'s value depends on the
+;; fixnum range.
;;
;; When deciding whether a function is pure, do not worry about
;; mutable strings or markers, as they are so unlikely in real code
@@ -1308,9 +1452,43 @@
;; values if a marker is moved.
(let ((pure-fns
- '(% concat logand logcount logior lognot logxor
- regexp-opt regexp-quote
- string-to-char string-to-syntax symbol-name)))
+ '(concat regexp-opt regexp-quote
+ string-to-char string-to-syntax symbol-name
+ eq eql
+ = /= < <= >= > min max
+ + - * / % mod abs ash 1+ 1- sqrt
+ logand logior lognot logxor logcount
+ copysign isnan ldexp float logb
+ floor ceiling round truncate
+ ffloor fceiling fround ftruncate
+ string= string-equal string< string-lessp string> string-greaterp
+ string-empty-p string-blank-p string-prefix-p string-suffix-p
+ string-search
+ consp atom listp nlistp proper-list-p
+ sequencep arrayp vectorp stringp bool-vector-p hash-table-p
+ null not
+ numberp integerp floatp natnump characterp
+ integer-or-marker-p number-or-marker-p char-or-string-p
+ symbolp keywordp
+ type-of
+ identity ignore
+
+ ;; The following functions are pure up to mutation of their
+ ;; arguments. This is pure enough for the purposes of
+ ;; constant folding, but not necessarily for all kinds of
+ ;; code motion.
+ car cdr car-safe cdr-safe nth nthcdr last
+ equal
+ length safe-length
+ memq memql member
+ ;; `assoc' and `assoc-default' are excluded since they are
+ ;; impure if the test function is (consider `string-match').
+ assq rassq rassoc
+ plist-get lax-plist-get plist-member
+ aref elt
+ bool-vector-subsetp
+ bool-vector-count-population bool-vector-count-consecutive
+ )))
(while pure-fns
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
@@ -1433,10 +1611,7 @@
;; so we create a copy of it, and replace the addresses with
;; TAGs.
(let ((orig-table last-constant))
- (cl-loop for e across constvec
- when (eq e last-constant)
- do (setq last-constant (copy-hash-table e))
- and return nil)
+ (setq last-constant (copy-hash-table last-constant))
;; Replace all addresses with TAGs.
(maphash #'(lambda (value offset)
(let ((match (assq offset tags)))
@@ -1473,10 +1648,10 @@
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
- (mapcar (function (lambda (elt)
- (if (numberp elt)
- elt
- (cdr elt))))
+ (mapcar (lambda (elt)
+ (if (numberp elt)
+ elt
+ (cdr elt)))
(nreverse lap))))
@@ -1510,13 +1685,13 @@
byte-current-buffer byte-stack-ref))
(defconst byte-compile-side-effect-free-ops
- (nconc
+ (append
'(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
- byte-member byte-assq byte-quo byte-rem)
+ byte-member byte-assq byte-quo byte-rem byte-substring)
byte-compile-side-effect-and-error-free-ops))
;; This crock is because of the way DEFVAR_BOOL variables work.
@@ -1574,467 +1749,548 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; You may notice that sequences like "dup varset discard" are
;; optimized but sequences like "dup varset TAG1: discard" are not.
;; You may be tempted to change this; resist that temptation.
- (cond ;;
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((and (eq 'byte-discard (car lap1))
- (memq (car lap0) side-effect-free))
- (setq keep-going t)
- (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
- (setq rest (cdr rest))
- (cond ((= tmp 1)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
- ((= tmp 0)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
- ((= tmp -1)
- (byte-compile-log-lap
- " %s discard\t-->\tdiscard discard" lap0)
- (setcar lap0 'byte-discard)
- (setcdr lap0 0))
- ((error "Optimizer error: too much on the stack"))))
- ;;
- ;; goto*-X X: --> X:
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (eq (cdr lap0) lap1))
- (cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
- (setq tmp "<deleted>"))
- ((memq (car lap0) byte-goto-always-pop-ops)
- (setcar lap0 (setq tmp 'byte-discard))
- (setcdr lap0 0))
- ((error "Depth conflict at tag %d" (nth 2 lap0))))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
- (nth 1 lap1) (nth 1 lap1)
- tmp (nth 1 lap1)))
- (setq keep-going t))
- ;;
- ;; varset-X varref-X --> dup varset-X
- ;; varbind-X varref-X --> dup varbind-X
- ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
- ;; 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 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)))
- (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
- (not (eq (car lap0) 'byte-constant)))
- nil
- (setq keep-going t)
- (if (memq (car lap0) '(byte-constant byte-dup))
- (progn
- (setq tmp (if (or (not tmp)
- (macroexp--const-symbol-p
- (car (cdr lap0))))
- (cdr lap0)
- (byte-compile-get-constant t)))
- (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
- lap0 lap1 lap2 lap0 lap1
- (cons (car lap0) tmp))
- (setcar lap2 (car lap0))
- (setcdr lap2 tmp))
- (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
- (setcar lap2 (car lap1))
- (setcar lap1 'byte-dup)
- (setcdr lap1 0)
- ;; The stack depth gets locally increased, so we will
- ;; increase maxdepth in case depth = maxdepth here.
- ;; This can cause the third argument to byte-code to
- ;; be larger than necessary.
- (setq add-depth 1))))
- ;;
- ;; 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
- 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)) (cl-decf (cdr lap1)))
- (setq lap (delq lap0 (delq lap2 lap))))
- ;;
- ;; not goto-X-if-nil --> goto-X-if-non-nil
- ;; not goto-X-if-non-nil --> goto-X-if-nil
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (eq 'byte-not (car lap0))
- (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
- (byte-compile-log-lap " not %s\t-->\t%s"
- lap1
- (cons
- (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil)
- (cdr lap1)))
- (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
- (setq keep-going t))
- ;;
- ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
- ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((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))
- 'byte-goto-if-not-nil 'byte-goto-if-nil)))
- (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
- lap0 lap1 lap2
- (cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
- (setcar lap1 inverse)
- (setq keep-going t)))
- ;;
- ;; const goto-if-* --> whatever
- ;;
- ((and (eq 'byte-constant (car 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
- (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))
- ;;
- ;; 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 (memq (car lap0) '(byte-varref byte-stack-ref))
- (progn
- (setq tmp (cdr rest))
- (setq tmp2 0)
- (while (eq (car (car tmp)) 'byte-dup)
- (setq tmp2 (1+ tmp2))
- (setq tmp (cdr tmp)))
- t)
- (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))
- (while (not (eq tmp tmp2))
- (setq tmp2 (cdr tmp2)
- str (concat str " dup")))
- (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
- lap0 str lap0 lap0 str)))
- (setq keep-going t)
- (setcar (car tmp) 'byte-dup)
- (setcdr (car tmp) 0)
- (setq rest tmp))
- ;;
- ;; TAG1: TAG2: --> TAG1: <deleted>
- ;; (and other references to TAG2 are replaced with TAG1)
- ;;
- ((and (eq (car lap0) 'TAG)
- (eq (car lap1) 'TAG))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " adjacent tags %d and %d merged"
- (nth 1 lap1) (nth 1 lap0)))
- (setq tmp3 lap)
- (while (setq tmp2 (rassq lap0 tmp3))
- (setcdr tmp2 lap1)
- (setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
- keep-going t)
- ;; replace references to tag in jump tables, if any
- (dolist (table byte-compile-jump-tables)
- (maphash #'(lambda (value tag)
- (when (equal tag lap0)
- (puthash value lap1 table)))
- table)))
- ;;
- ;; unused-TAG: --> <deleted>
- ;;
- ((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap))
- ;; make sure this tag isn't used in a jump-table
- (cl-loop for table in byte-compile-jump-tables
- when (member lap0 (hash-table-values table))
- return nil finally return t))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
- keep-going t))
- ;;
- ;; goto ... --> goto <delete until TAG or end>
- ;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
- ;;
- ((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
- (setq tmp rest)
- (let ((i 0)
- (opt-p (memq byte-optimize-log '(t lap)))
- str deleted)
- (while (and (setq tmp (cdr tmp))
- (not (eq 'TAG (car (car tmp)))))
- (if opt-p (setq deleted (cons (car tmp) deleted)
- str (concat str " %s")
- i (1+ i))))
- (if opt-p
- (let ((tagstr
- (if (eq 'TAG (car (car tmp)))
- (format "%d:" (car (cdr (car tmp))))
- (or (car tmp) ""))))
- (if (< i 6)
- (apply 'byte-compile-log-lap-1
- (concat " %s" str
- " %s\t-->\t%s <deleted> %s")
- lap0
- (nconc (nreverse deleted)
- (list tagstr lap0 tagstr)))
- (byte-compile-log-lap
- " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
- lap0 i (if (= i 1) "" "s")
- tagstr lap0 tagstr))))
- (rplacd rest tmp))
- (setq keep-going t))
- ;;
- ;; <safe-op> unbind --> unbind <safe-op>
- ;; (this may enable other optimizations.)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) byte-after-unbind-ops))
- (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
- (setcar rest lap1)
- (setcar (cdr rest) lap0)
- (setq keep-going t))
- ;;
- ;; varbind-X unbind-N --> discard unbind-(N-1)
- ;; save-excursion unbind-N --> unbind-(N-1)
- ;; save-restriction unbind-N --> unbind-(N-1)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) '(byte-varbind byte-save-excursion
- byte-save-restriction))
- (< 0 (cdr lap1)))
- (if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
- (if (eq (car lap0) 'byte-varbind)
- (setcar rest (cons 'byte-discard 0))
+ (cond
+ ;; <side-effect-free> pop --> <deleted>
+ ;; ...including:
+ ;; const-X pop --> <deleted>
+ ;; varref-X pop --> <deleted>
+ ;; dup pop --> <deleted>
+ ;;
+ ((and (eq 'byte-discard (car lap1))
+ (memq (car lap0) side-effect-free))
+ (setq keep-going t)
+ (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
+ (setq rest (cdr rest))
+ (cond ((= tmp 1)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted>" lap0)
+ (setq lap (delq lap0 (delq lap1 lap))))
+ ((= tmp 0)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
- (byte-compile-log-lap " %s %s\t-->\t%s %s"
- lap0 (cons (car lap1) (1+ (cdr lap1)))
- (if (eq (car lap0) 'byte-varbind)
- (car rest)
- (car (cdr rest)))
- (if (and (/= 0 (cdr lap1))
- (eq (car lap0) 'byte-varbind))
- (car (cdr rest))
- ""))
- (setq keep-going t))
- ;;
- ;; goto*-X ... X: goto-Y --> goto*-Y
- ;; goto-X ... X: return --> return
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
- '(byte-goto byte-return)))
- (cond ((and (not (eq tmp lap0))
- (or (eq (car lap0) 'byte-goto)
- (eq (car tmp) 'byte-goto)))
- (byte-compile-log-lap " %s [%s]\t-->\t%s"
- (car lap0) tmp tmp)
- (if (eq (car tmp) 'byte-return)
- (setcar lap0 'byte-return))
- (setcdr lap0 (cdr tmp))
- (setq keep-going t))))
- ;;
- ;; goto-*-else-pop X ... X: goto-if-* --> whatever
- ;; goto-*-else-pop X ... X: discard --> whatever
- ;;
- ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil-else-pop))
- (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap0 (car tmp))))
- (setq tmp2 (car tmp))
- (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
- byte-goto-if-nil)
- (byte-goto-if-not-nil-else-pop
- byte-goto-if-not-nil))))
- (if (memq (car tmp2) tmp3)
- (progn (setcar lap0 (car tmp2))
- (setcdr lap0 (cdr tmp2))
- (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
- (car lap0) tmp2 lap0))
- ;; Get rid of the -else-pop's and jump one step further.
+ ((= tmp -1)
+ (byte-compile-log-lap
+ " %s discard\t-->\tdiscard discard" lap0)
+ (setcar lap0 'byte-discard)
+ (setcdr lap0 0))
+ ((error "Optimizer error: too much on the stack"))))
+ ;;
+ ;; goto*-X X: --> X:
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (eq (cdr lap0) lap1))
+ (cond ((eq (car lap0) 'byte-goto)
+ (setq lap (delq lap0 lap))
+ (setq tmp "<deleted>"))
+ ((memq (car lap0) byte-goto-always-pop-ops)
+ (setcar lap0 (setq tmp 'byte-discard))
+ (setcdr lap0 0))
+ ((error "Depth conflict at tag %d" (nth 2 lap0))))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
+ (nth 1 lap1) (nth 1 lap1)
+ tmp (nth 1 lap1)))
+ (setq keep-going t))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; 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 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)))
+ (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+ (not (eq (car lap0) 'byte-constant)))
+ nil
+ (setq keep-going t)
+ (if (memq (car lap0) '(byte-constant byte-dup))
+ (progn
+ (setq tmp (if (or (not tmp)
+ (macroexp--const-symbol-p
+ (car (cdr lap0))))
+ (cdr lap0)
+ (byte-compile-get-constant t)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2 lap0 lap1
+ (cons (car lap0) tmp))
+ (setcar lap2 (car lap0))
+ (setcdr lap2 tmp))
+ (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
+ (setcar lap2 (car lap1))
+ (setcar lap1 'byte-dup)
+ (setcdr lap1 0)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))))
+ ;;
+ ;; 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
+ 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)) (cl-decf (cdr lap1)))
+ (setq lap (delq lap0 (delq lap2 lap))))
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+ (byte-compile-log-lap " not %s\t-->\t%s"
+ lap1
+ (cons
+ (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil)
+ (cdr lap1)))
+ (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))
+ ;;
+ ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
+ ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((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))
+ 'byte-goto-if-not-nil 'byte-goto-if-nil)))
+ (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
+ lap0 lap1 lap2
+ (cons inverse (cdr lap1)) lap2)
+ (setq lap (delq lap0 lap))
+ (setcar lap1 inverse)
+ (setq keep-going t)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car 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
+ (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))
+ ;;
+ ;; 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 (memq (car lap0) '(byte-varref byte-stack-ref))
+ (progn
+ (setq tmp (cdr rest))
+ (setq tmp2 0)
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
+ t)
+ (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))
+ (while (not (eq tmp tmp2))
+ (setq tmp2 (cdr tmp2)
+ str (concat str " dup")))
+ (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
+ lap0 str lap0 lap0 str)))
+ (setq keep-going t)
+ (setcar (car tmp) 'byte-dup)
+ (setcdr (car tmp) 0)
+ (setq rest tmp))
+ ;;
+ ;; TAG1: TAG2: --> TAG1: <deleted>
+ ;; (and other references to TAG2 are replaced with TAG1)
+ ;;
+ ((and (eq (car lap0) 'TAG)
+ (eq (car lap1) 'TAG))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " adjacent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0)))
+ (setq tmp3 lap)
+ (while (setq tmp2 (rassq lap0 tmp3))
+ (setcdr tmp2 lap1)
+ (setq tmp3 (cdr (memq tmp2 tmp3))))
+ (setq lap (delq lap0 lap)
+ keep-going t)
+ ;; replace references to tag in jump tables, if any
+ (dolist (table byte-compile-jump-tables)
+ (maphash #'(lambda (value tag)
+ (when (equal tag lap0)
+ (puthash value lap1 table)))
+ table)))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 lap))
+ ;; make sure this tag isn't used in a jump-table
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
+ (setq lap (delq lap0 lap)
+ keep-going t))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;; (unless a jump-table is being used, where deleting may affect
+ ;; other valid case bodies)
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil)))
+ ;; FIXME: Instead of deferring simply when jump-tables are
+ ;; being used, keep a list of tags used for switch tags and
+ ;; use them instead (see `byte-compile-inline-lapcode').
+ (not byte-compile-jump-tables))
+ (setq tmp rest)
+ (let ((i 0)
+ (opt-p (memq byte-optimize-log '(t lap)))
+ str deleted)
+ (while (and (setq tmp (cdr tmp))
+ (not (eq 'TAG (car (car tmp)))))
+ (if opt-p (setq deleted (cons (car tmp) deleted)
+ str (concat str " %s")
+ i (1+ i))))
+ (if opt-p
+ (let ((tagstr
+ (if (eq 'TAG (car (car tmp)))
+ (format "%d:" (car (cdr (car tmp))))
+ (or (car tmp) ""))))
+ (if (< i 6)
+ (apply 'byte-compile-log-lap-1
+ (concat " %s" str
+ " %s\t-->\t%s <deleted> %s")
+ lap0
+ (nconc (nreverse deleted)
+ (list tagstr lap0 tagstr)))
+ (byte-compile-log-lap
+ " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+ lap0 i (if (= i 1) "" "s")
+ tagstr lap0 tagstr))))
+ (rplacd rest tmp))
+ (setq keep-going t))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) byte-after-unbind-ops))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0)
+ (setq keep-going t))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) '(byte-varbind byte-save-excursion
+ byte-save-restriction))
+ (< 0 (cdr lap1)))
+ (if (zerop (setcdr lap1 (1- (cdr lap1))))
+ (delq lap1 rest))
+ (if (eq (car lap0) 'byte-varbind)
+ (setcar rest (cons 'byte-discard 0))
+ (setq lap (delq lap0 lap)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 (cons (car lap1) (1+ (cdr lap1)))
+ (if (eq (car lap0) 'byte-varbind)
+ (car rest)
+ (car (cdr rest)))
+ (if (and (/= 0 (cdr lap1))
+ (eq (car lap0) 'byte-varbind))
+ (car (cdr rest))
+ ""))
+ (setq keep-going t))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
+ '(byte-goto byte-return)))
+ (cond ((and (not (eq tmp lap0))
+ (or (eq (car lap0) 'byte-goto)
+ (eq (car tmp) 'byte-goto)))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s"
+ (car lap0) tmp tmp)
+ (if (eq (car tmp) 'byte-return)
+ (setcar lap0 'byte-return))
+ (setcdr lap0 (cdr tmp))
+ (setq keep-going t))))
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+ (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap0 (car tmp))))
+ (setq tmp2 (car tmp))
+ (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
+ byte-goto-if-nil)
+ (byte-goto-if-not-nil-else-pop
+ byte-goto-if-not-nil))))
+ (if (memq (car tmp2) tmp3)
+ (progn (setcar lap0 (car tmp2))
+ (setcdr lap0 (cdr tmp2))
+ (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
+ (car lap0) tmp2 lap0))
+ ;; Get rid of the -else-pop's and jump one step further.
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
+ (car lap0) tmp2 (nth 1 tmp3))
+ (setcar lap0 (nth 1 tmp3))
+ (setcdr lap0 (nth 1 tmp)))
+ (setq keep-going t))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-goto)
+ (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap1 (car tmp))))
+ (setq tmp2 (car tmp))
+ (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))
+ (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>"
+ lap0 tmp2)
(or (eq 'TAG (car (nth 1 tmp)))
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
- (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
- (car lap0) tmp2 (nth 1 tmp3))
- (setcar lap0 (nth 1 tmp3))
- (setcdr lap0 (nth 1 tmp)))
- (setq keep-going t))
- ;;
- ;; const goto-X ... X: goto-if-* --> whatever
- ;; const goto-X ... X: discard --> whatever
- ;;
- ((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-goto)
- (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap1 (car tmp))))
- (setq tmp2 (car tmp))
- (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))
- (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>"
- lap0 tmp2)
- (or (eq 'TAG (car (nth 1 tmp)))
- (setcdr tmp (cons (byte-compile-make-tag)
- (cdr tmp))))
- (setcdr lap1 (car (cdr tmp)))
- (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)
- (not (memq (cdr lap2) rest)) ;Backwards jump
- (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- 'byte-varref)
- (eq (cdr (car tmp)) (cdr lap1))
- (not (memq (car (cdr lap1)) byte-boolean-vars)))
- ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
- (nth 1 (cdr lap2)) (car tmp)
- lap1 lap2
- (nth 1 (cdr lap2)) (car tmp)
- (nth 1 newtag) 'byte-dup lap1
- (cons 'byte-goto newtag)
- )
- (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
- (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
- (setq add-depth 1)
- (setq keep-going t))
- ;;
- ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
- ;; (This can pull the loop test to the end of the loop)
- ;;
- ((and (eq (car lap0) 'byte-goto)
- (eq (car lap1) 'TAG)
- (eq lap1
- (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
- (memq (car (car tmp))
- '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
- byte-goto-if-nil-else-pop)))
-;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
-;; lap0 lap1 (cdr lap0) (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- "%s %s: ... %s: %s\t-->\t%s ... %s:"
- lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
- (cons (cdr (assq (car (car tmp))
- '((byte-goto-if-nil . byte-goto-if-not-nil)
- (byte-goto-if-not-nil . byte-goto-if-nil)
- (byte-goto-if-nil-else-pop .
- byte-goto-if-not-nil-else-pop)
- (byte-goto-if-not-nil-else-pop .
- byte-goto-if-nil-else-pop))))
- newtag)
-
- (nth 1 newtag)
- )
- (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
- (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
- ;; We can handle this case but not the -if-not-nil case,
- ;; because we won't know which non-nil constant to push.
- (setcdr rest (cons (cons 'byte-constant
- (byte-compile-get-constant nil))
- (cdr rest))))
- (setcar lap0 (nth 1 (memq (car (car tmp))
- '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil
- byte-goto-if-nil
- byte-goto-if-not-nil
- byte-goto byte-goto))))
- )
- (setq keep-going t))
- )
+ (setcdr lap1 (car (cdr tmp)))
+ (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)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
+ 'byte-varref)
+ (eq (cdr (car tmp)) (cdr lap1))
+ (not (memq (car (cdr lap1)) byte-boolean-vars)))
+ ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+ (nth 1 (cdr lap2)) (car tmp)
+ lap1 lap2
+ (nth 1 (cdr lap2)) (car tmp)
+ (nth 1 newtag) 'byte-dup lap1
+ (cons 'byte-goto newtag)
+ )
+ (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+ (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
+ (setq add-depth 1)
+ (setq keep-going t))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (eq (car lap1) 'TAG)
+ (eq lap1
+ (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
+ (memq (car (car tmp))
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
+ byte-goto-if-nil-else-pop)))
+ ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
+ ;; lap0 lap1 (cdr lap0) (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ "%s %s: ... %s: %s\t-->\t%s ... %s:"
+ lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+ (cons (cdr (assq (car (car tmp))
+ '((byte-goto-if-nil . byte-goto-if-not-nil)
+ (byte-goto-if-not-nil . byte-goto-if-nil)
+ (byte-goto-if-nil-else-pop .
+ byte-goto-if-not-nil-else-pop)
+ (byte-goto-if-not-nil-else-pop .
+ byte-goto-if-nil-else-pop))))
+ newtag)
+
+ (nth 1 newtag)
+ )
+ (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+ (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+ ;; We can handle this case but not the -if-not-nil case,
+ ;; because we won't know which non-nil constant to push.
+ (setcdr rest (cons (cons 'byte-constant
+ (byte-compile-get-constant nil))
+ (cdr rest))))
+ (setcar lap0 (nth 1 (memq (car (car tmp))
+ '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil
+ byte-goto-if-nil
+ byte-goto-if-not-nil
+ byte-goto byte-goto))))
+ )
+ (setq keep-going t))
+
+ ;;
+ ;; 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))
+
+ ;;
+ ;; 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))))
+ (setq keep-going t)
+ ;; 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))
+
+ ;;
+ ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (setq tmp (cdr (memq (cdr lap0) lap)))
+ (memq (caar tmp) '(byte-discard byte-discardN
+ byte-discardN-preserve-tos)))
+ (byte-compile-log-lap
+ " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+ (car tmp) (car tmp))
+ (setq keep-going t)
+ (let* ((newtag (byte-compile-make-tag))
+ ;; Make a copy, since we sometimes modify insts in-place!
+ (newdiscard (cons (caar tmp) (cdar tmp)))
+ (newjmp (cons (car lap0) newtag)))
+ (push newtag (cdr tmp)) ;Push new tag after the discard.
+ (setcar rest newdiscard)
+ (push newjmp (cdr rest))))
+
+ ;;
+ ;; const discardN-preserve-tos ==> discardN const
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-discardN-preserve-tos))
+ (setq keep-going t)
+ (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+ (byte-compile-log-lap
+ " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+ (setf (car rest) newdiscard)
+ (setf (cadr rest) lap0)))
+ )
(setq rest (cdr rest)))
)
;; Cleanup stage:
@@ -2098,41 +2354,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(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)
;;
@@ -2159,20 +2380,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(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)))
@@ -2186,6 +2393,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-optimize-form))
+ (subr-native-elisp-p (symbol-function 'byte-optimize-form))
(assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))
@@ -2195,7 +2403,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(or noninteractive (message "compiling %s...done" x)))
'(byte-optimize-form
byte-optimize-body
- byte-optimize-predicate
+ byte-optimize-constant-args
byte-optimize-binary-predicate
;; Inserted some more than necessary, to speed it up.
byte-optimize-form-code-walker
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 3ca32bf4211..aca5dcba62c 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -82,65 +82,105 @@ The return value of this function is not used."
;; We define macro-declaration-alist here because it is needed to
;; handle declarations in macro definitions and this is the first file
-;; loaded by loadup.el that uses declarations in macros.
+;; loaded by loadup.el that uses declarations in macros. We specify
+;; the values as named aliases so that `describe-variable' prints
+;; something useful; cf. Bug#40491. We can only use backquotes inside
+;; the lambdas and not for those properties that are used by functions
+;; loaded before backquote.el.
+
+(defalias 'byte-run--set-advertised-calling-convention
+ #'(lambda (f _args arglist when)
+ (list 'set-advertised-calling-convention
+ (list 'quote f) (list 'quote arglist) (list 'quote when))))
+
+(defalias 'byte-run--set-obsolete
+ #'(lambda (f _args new-name when)
+ (list 'make-obsolete
+ (list 'quote f) (list 'quote new-name) (list 'quote when))))
+
+(defalias 'byte-run--set-interactive-only
+ #'(lambda (f _args instead)
+ (list 'function-put (list 'quote f)
+ ''interactive-only (list 'quote instead))))
+
+(defalias 'byte-run--set-pure
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''pure (list 'quote val))))
+
+(defalias 'byte-run--set-side-effect-free
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''side-effect-free (list 'quote val))))
+
+(put 'compiler-macro 'edebug-declaration-spec
+ '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)))
+
+(defalias 'byte-run--set-compiler-macro
+ #'(lambda (f args compiler-function)
+ (if (not (eq (car-safe compiler-function) 'lambda))
+ `(eval-and-compile
+ (function-put ',f 'compiler-macro #',compiler-function))
+ (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))
+ ;; Avoid cadr/cddr so we can use `compiler-macro' before
+ ;; defining cadr/cddr.
+ (data (cdr compiler-function)))
+ `(progn
+ (eval-and-compile
+ (function-put ',f 'compiler-macro #',cfname))
+ ;; Don't autoload the compiler-macro itself, since the
+ ;; macroexpander will find this file via `f's autoload,
+ ;; if needed.
+ :autoload-end
+ (eval-and-compile
+ (defun ,cfname (,@(car data) ,@args)
+ ,@(cdr data))))))))
+
+(defalias 'byte-run--set-doc-string
+ #'(lambda (f _args pos)
+ (list 'function-put (list 'quote f)
+ ''doc-string-elt (list 'quote pos))))
+
+(defalias 'byte-run--set-indent
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''lisp-indent-function (list 'quote val))))
+
+(defalias 'byte-run--set-speed
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''speed (list 'quote val))))
+
+(defalias 'byte-run--set-completion
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''completion-predicate (list 'function val))))
+
+(defalias 'byte-run--set-modes
+ #'(lambda (f _args &rest val)
+ (list 'function-put (list 'quote f)
+ ''command-modes (list 'quote val))))
;; Add any new entries to info node `(elisp)Declare Form'.
(defvar defun-declarations-alist
(list
- ;; We can only use backquotes inside the lambdas and not for those
- ;; properties that are used by functions loaded before backquote.el.
(list 'advertised-calling-convention
- #'(lambda (f _args arglist when)
- (list 'set-advertised-calling-convention
- (list 'quote f) (list 'quote arglist) (list 'quote when))))
- (list 'obsolete
- #'(lambda (f _args new-name when)
- (list 'make-obsolete
- (list 'quote f) (list 'quote new-name) (list 'quote when))))
- (list 'interactive-only
- #'(lambda (f _args instead)
- (list 'function-put (list 'quote f)
- ''interactive-only (list 'quote instead))))
+ #'byte-run--set-advertised-calling-convention)
+ (list 'obsolete #'byte-run--set-obsolete)
+ (list 'interactive-only #'byte-run--set-interactive-only)
;; FIXME: Merge `pure' and `side-effect-free'.
- (list 'pure
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''pure (list 'quote val)))
+ (list 'pure #'byte-run--set-pure
"If non-nil, the compiler can replace calls with their return value.
This may shift errors from run-time to compile-time.")
- (list 'side-effect-free
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''side-effect-free (list 'quote val)))
+ (list 'side-effect-free #'byte-run--set-side-effect-free
"If non-nil, calls can be ignored if their value is unused.
If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
- (list 'compiler-macro
- #'(lambda (f args compiler-function)
- (if (not (eq (car-safe compiler-function) 'lambda))
- `(eval-and-compile
- (function-put ',f 'compiler-macro #',compiler-function))
- (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))
- ;; Avoid cadr/cddr so we can use `compiler-macro' before
- ;; defining cadr/cddr.
- (data (cdr compiler-function)))
- `(progn
- (eval-and-compile
- (function-put ',f 'compiler-macro #',cfname))
- ;; Don't autoload the compiler-macro itself, since the
- ;; macroexpander will find this file via `f's autoload,
- ;; if needed.
- :autoload-end
- (eval-and-compile
- (defun ,cfname (,@(car data) ,@args)
- ,@(cdr data))))))))
- (list 'doc-string
- #'(lambda (f _args pos)
- (list 'function-put (list 'quote f)
- ''doc-string-elt (list 'quote pos))))
- (list 'indent
- #'(lambda (f _args val)
- (list 'function-put (list 'quote f)
- ''lisp-indent-function (list 'quote val)))))
+ (list 'compiler-macro #'byte-run--set-compiler-macro)
+ (list 'doc-string #'byte-run--set-doc-string)
+ (list 'indent #'byte-run--set-indent)
+ (list 'speed #'byte-run--set-speed)
+ (list 'completion #'byte-run--set-completion)
+ (list 'modes #'byte-run--set-modes))
"List associating function properties to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is
a function. For each (PROP . VALUES) in a function's declaration,
@@ -150,18 +190,22 @@ to set this property.
This is used by `declare'.")
+(defalias 'byte-run--set-debug
+ #'(lambda (name _args spec)
+ (list 'progn :autoload-end
+ (list 'put (list 'quote name)
+ ''edebug-form-spec (list 'quote spec)))))
+
+(defalias 'byte-run--set-no-font-lock-keyword
+ #'(lambda (name _args val)
+ (list 'function-put (list 'quote name)
+ ''no-font-lock-keyword (list 'quote val))))
+
(defvar macro-declarations-alist
(cons
- (list 'debug
- #'(lambda (name _args spec)
- (list 'progn :autoload-end
- (list 'put (list 'quote name)
- ''edebug-form-spec (list 'quote spec)))))
+ (list 'debug #'byte-run--set-debug)
(cons
- (list 'no-font-lock-keyword
- #'(lambda (name _args val)
- (list 'function-put (list 'quote name)
- ''no-font-lock-keyword (list 'quote val))))
+ (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword)
defun-declarations-alist))
"List associating properties of macros to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is a function.
@@ -209,8 +253,11 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
- (message "Warning: Unknown macro property %S in %S"
- (car x) name))))
+ (macroexp-warn-and-return
+ (format-message
+ "Unknown macro property %S in %S"
+ (car x) name)
+ nil))))
decls)))
;; Refresh font-lock if this is a new macro, or it is an
;; existing macro whose 'no-font-lock-keyword declaration
@@ -278,9 +325,12 @@ The return value is undefined.
(cdr body)
body)))
nil)
- (t (message "Warning: Unknown defun property `%S' in %S"
- (car x) name)))))
- decls))
+ (t
+ (macroexp-warn-and-return
+ (format-message "Unknown defun property `%S' in %S"
+ (car x) name)
+ nil)))))
+ decls))
(def (list 'defalias
(list 'quote name)
(list 'function
@@ -337,6 +387,10 @@ You don't need this. (See bytecomp.el commentary for more details.)
`(prog1
(defun ,name ,arglist ,@body)
(eval-and-compile
+ ;; Never native-compile defsubsts as we need the byte
+ ;; definition in `byte-compile-unfold-bcf' to perform the
+ ;; inlining (Bug#42664, Bug#43280, Bug#44209).
+ ,(byte-run--set-speed name nil -1)
(put ',name 'byte-optimizer 'byte-compile-inline-expand))))
(defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))
@@ -349,7 +403,7 @@ convention was modified."
(puthash (indirect-function function) signature
advertised-signature-table))
-(defun make-obsolete (obsolete-name current-name &optional when)
+(defun make-obsolete (obsolete-name current-name when)
"Make the byte-compiler warn that function OBSOLETE-NAME is obsolete.
OBSOLETE-NAME should be a function name or macro name (a symbol).
@@ -358,17 +412,14 @@ If CURRENT-NAME is a string, that is the `use instead' message
\(it should end with a period, and not start with a capital).
WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
- (declare (advertised-calling-convention
- ;; New code should always provide the `when' argument.
- (obsolete-name current-name when) "23.1"))
(put obsolete-name 'byte-obsolete-info
;; The second entry used to hold the `byte-compile' handler, but
;; is not used any more nowadays.
(purecopy (list current-name nil when)))
obsolete-name)
-(defmacro define-obsolete-function-alias (obsolete-name current-name
- &optional when docstring)
+(defmacro define-obsolete-function-alias ( obsolete-name current-name when
+ &optional docstring)
"Set OBSOLETE-NAME's function definition to CURRENT-NAME and mark it obsolete.
\(define-obsolete-function-alias \\='old-fun \\='new-fun \"22.1\" \"old-fun's doc.\")
@@ -382,15 +433,13 @@ WHEN should be a string indicating when the function was first
made obsolete, for example a date or a release number.
See the docstrings of `defalias' and `make-obsolete' for more details."
- (declare (doc-string 4)
- (advertised-calling-convention
- ;; New code should always provide the `when' argument.
- (obsolete-name current-name when &optional docstring) "23.1"))
+ (declare (doc-string 4))
`(progn
(defalias ,obsolete-name ,current-name ,docstring)
(make-obsolete ,obsolete-name ,current-name ,when)))
-(defun make-obsolete-variable (obsolete-name current-name &optional when access-type)
+(defun make-obsolete-variable ( obsolete-name current-name when
+ &optional access-type)
"Make the byte-compiler warn that OBSOLETE-NAME is obsolete.
The warning will say that CURRENT-NAME should be used instead.
If CURRENT-NAME is a string, that is the `use instead' message.
@@ -398,18 +447,24 @@ WHEN should be a string indicating when the variable
was first made obsolete, for example a date or a release number.
ACCESS-TYPE if non-nil should specify the kind of access that will trigger
obsolescence warnings; it can be either `get' or `set'."
- (declare (advertised-calling-convention
- ;; New code should always provide the `when' argument.
- (obsolete-name current-name when &optional access-type) "23.1"))
(put obsolete-name 'byte-obsolete-variable
(purecopy (list current-name access-type when)))
obsolete-name)
-(defmacro define-obsolete-variable-alias (obsolete-name current-name
- &optional when docstring)
+(defmacro define-obsolete-variable-alias ( obsolete-name current-name when
+ &optional docstring)
"Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete.
-This uses `defvaralias' and `make-obsolete-variable' (which see).
+
+WHEN should be a string indicating when the variable was first
+made obsolete, for example a date or a release number.
+
+This macro evaluates all its parameters, and both OBSOLETE-NAME
+and CURRENT-NAME should be symbols, so a typical usage would look like:
+
+ (define-obsolete-variable-alias 'foo-thing 'bar-thing \"27.1\")
+
+This macro uses `defvaralias' and `make-obsolete-variable' (which see).
See the Info node `(elisp)Variable Aliases' for more details.
If CURRENT-NAME is a defcustom or a defvar (more generally, any variable
@@ -423,17 +478,11 @@ dumped with Emacs). This is so that any user customizations are
applied before the defcustom tries to initialize the
variable (this is due to the way `defvaralias' works).
-WHEN should be a string indicating when the variable was first
-made obsolete, for example a date or a release number.
-
For the benefit of Customize, if OBSOLETE-NAME has
any of the following properties, they are copied to
CURRENT-NAME, if it does not already have them:
`saved-value', `saved-variable-comment'."
- (declare (doc-string 4)
- (advertised-calling-convention
- ;; New code should always provide the `when' argument.
- (obsolete-name current-name when &optional docstring) "23.1"))
+ (declare (doc-string 4))
`(progn
(defvaralias ,obsolete-name ,current-name ,docstring)
;; See Bug#4706.
@@ -553,13 +602,26 @@ Otherwise, return nil. For internal use only."
(mapconcat (lambda (char) (format "`?\\%c'" char))
sorted ", ")))))
+(defun byte-compile-info (string &optional message type)
+ "Format STRING in a way that looks pleasing in the compilation output.
+If MESSAGE, output the message, too.
+
+If TYPE, it should be a string that says what the information
+type is. This defaults to \"INFO\"."
+ (let ((string (format " %-9s%s" (or type "INFO") string)))
+ (when message
+ (message "%s" string))
+ string))
+
(defun byte-compile-info-string (&rest args)
"Format ARGS in a way that looks pleasing in the compilation output."
- (format " %-9s%s" "INFO" (apply #'format args)))
+ (declare (obsolete byte-compile-info "28.1"))
+ (byte-compile-info (apply #'format args)))
(defun byte-compile-info-message (&rest args)
"Message format ARGS in a way that looks pleasing in the compilation output."
- (message "%s" (apply #'byte-compile-info-string args)))
+ (declare (obsolete byte-compile-info "28.1"))
+ (byte-compile-info (apply #'format args) t))
;; I nuked this because it's not a good idea for users to think of using it.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 9dc6a3037de..7bd642d2b23 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -144,7 +144,7 @@ is hard-coded in various places in Emacs.)"
;; Eg is_elc in Fload.
:type 'regexp)
-(defcustom byte-compile-dest-file-function nil
+(defcustom byte-compile-dest-file-function #'byte-compile--default-dest-file
"Function for the function `byte-compile-dest-file' to call.
It should take one argument, the name of an Emacs Lisp source
file name, and return the name of the compiled file.
@@ -177,23 +177,24 @@ function to do the work. Otherwise, if FILENAME matches
`emacs-lisp-file-regexp' (by default, files with the extension \".el\"),
replaces the matching part (and anything after it) with \".elc\";
otherwise adds \".elc\"."
- (if byte-compile-dest-file-function
- (funcall byte-compile-dest-file-function filename)
- (setq filename (file-name-sans-versions
- (byte-compiler-base-file-name filename)))
- (cond ((string-match emacs-lisp-file-regexp filename)
- (concat (substring filename 0 (match-beginning 0)) ".elc"))
- (t (concat filename ".elc")))))
-)
+ (funcall (or byte-compile-dest-file-function
+ #'byte-compile--default-dest-file)
+ filename)))
+
+(defun byte-compile--default-dest-file (filename)
+ (setq filename (file-name-sans-versions
+ (byte-compiler-base-file-name filename)))
+ (cond ((string-match emacs-lisp-file-regexp filename)
+ (concat (substring filename 0 (match-beginning 0)) ".elc"))
+ (t (concat filename ".elc"))))
;; This can be the 'byte-compile property of any symbol.
(autoload 'byte-compile-inline-expand "byte-opt")
;; This is the entry point to the lapcode optimizer pass1.
-(autoload 'byte-optimize-form "byte-opt")
+(autoload 'byte-optimize-one-form "byte-opt")
;; This is the entry point to the lapcode optimizer pass2.
(autoload 'byte-optimize-lapcode "byte-opt")
-(autoload 'byte-compile-unfold-lambda "byte-opt")
;; This is the entry point to the decompiler, which is used by the
;; disassembler. The disassembler just requires 'byte-compile, but
@@ -268,6 +269,13 @@ This option is enabled by default because it reduces Emacs memory usage."
(defconst byte-compile-log-buffer "*Compile-Log*"
"Name of the byte-compiler's log buffer.")
+(defvar byte-compile--known-dynamic-vars nil
+ "Variables known to be declared as dynamic, for warning purposes.
+Each element is (VAR . FILE), indicating that VAR is declared in FILE.")
+
+(defvar byte-compile--seen-defvars nil
+ "All dynamic variable declarations seen so far.")
+
(defcustom byte-optimize-log nil
"If non-nil, the byte-compiler will log its optimizations.
If this is `source', then only source-level optimizations will be logged.
@@ -284,13 +292,14 @@ The information is logged to `byte-compile-log-buffer'."
;; This needs to be autoloaded because it needs to be available to
;; Emacs before the byte compiler is loaded, otherwise Emacs will not
;; know that this variable is marked as safe until it is too late.
-;; (See https://lists.gnu.org/archive/html/emacs-devel/2018-01/msg00261.html )
+;; (See https://lists.gnu.org/r/emacs-devel/2018-01/msg00261.html )
;;;###autoload(put 'byte-compile-error-on-warn 'safe-local-variable 'booleanp)
(defconst byte-compile-warning-types
'(redefine callargs free-vars unresolved
- obsolete noruntime cl-functions interactive-only
- make-local mapcar constants suspicious lexical)
+ obsolete noruntime interactive-only
+ make-local mapcar constants suspicious lexical lexical-dynamic
+ docstrings)
"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).
@@ -305,14 +314,16 @@ Elements of the list may be:
obsolete obsolete variables and functions.
noruntime functions that may not be defined at runtime (typically
defined only under `eval-when-compile').
- cl-functions calls to runtime functions (as distinguished from macros and
- aliases) from the old CL package (not the newer cl-lib).
interactive-only
commands that normally shouldn't be called from Lisp code.
lexical global/dynamic variables lacking a prefix.
+ lexical-dynamic
+ lexically bound variable declared dynamic elsewhere
make-local calls to make-variable-buffer-local that may be incorrect.
mapcar mapcar called for effect.
constants let-binding of, or assignment to, constants/nonvariables.
+ docstrings docstrings that are too wide (longer than 80 characters,
+ or `fill-column', whichever is bigger)
suspicious constructs that usually don't do what the coder wanted.
If the list begins with `not', then the remaining elements specify warnings to
@@ -537,6 +548,10 @@ has the form (autoload . FILENAME).")
(defvar byte-compile-unresolved-functions nil
"Alist of undefined functions to which calls have been compiled.
+Each element in the list has the form (FUNCTION POSITION . CALLS)
+where CALLS is a list whose elements are integers (indicating the
+number of arguments passed in the function call) or the constant `t'
+if the function is called indirectly.
This variable is only significant whilst compiling an entire buffer.
Used for warnings when a function is not known to be defined or is later
defined with incorrect args.")
@@ -562,6 +577,46 @@ Each element is (INDEX . VALUE)")
(defvar byte-compile-depth 0 "Current depth of execution stack.")
(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
+;; The following is used by comp.el to spill data out of here.
+;;
+;; Spilling is done in 3 places:
+;;
+;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any
+;; code assembled.
+;;
+;; - `byte-compile-lambda' to obtain arglist doc and interactive spec
+;; af any lambda compiled (including anonymous).
+;;
+;; - `byte-compile-file-form-defmumble' to obtain the list of
+;; top-level forms as they would be outputted in the .elc file.
+;;
+
+(cl-defstruct byte-to-native-lambda
+ byte-func lap)
+
+;; Top level forms:
+(cl-defstruct byte-to-native-func-def
+ "Named function defined at top-level."
+ name c-name byte-func)
+(cl-defstruct byte-to-native-top-level
+ "All other top-level forms."
+ form lexical)
+
+(defvar byte-native-compiling nil
+ "Non-nil while native compiling.")
+(defvar byte-native-qualities nil
+ "To spill default qualities from the compiled file.")
+(defvar byte+native-compile nil
+ "Non-nil while producing at the same time byte and native code.")
+(defvar byte-to-native-lambdas-h nil
+ "Hash byte-code -> byte-to-native-lambda.")
+(defvar byte-to-native-top-level-forms nil
+ "List of top level forms.")
+(defvar byte-to-native-output-file nil
+ "Temporary file containing the byte-compilation output.")
+(defvar byte-to-native-plist-environment nil
+ "To spill `overriding-plist-environment'.")
+
;;; The byte codes; this information is duplicated in bytecomp.c
@@ -698,7 +753,8 @@ Each element is (INDEX . VALUE)")
;; These store their argument in the next two bytes
(byte-defop 129 1 byte-constant2
- "for reference to a constant with vector index >= byte-constant-limit")
+ "for reference to a constant with vector
+index >= byte-constant-limit")
(byte-defop 130 0 byte-goto "for unconditional jump")
(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil")
(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil")
@@ -718,15 +774,19 @@ otherwise pop it")
(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")
-(byte-defop 141 -1 byte-catch
- "for catch. Takes, on stack, the tag and an expression for the body")
+ "to make a binding to record the current buffer clipping
+restrictions")
+(byte-defop 141 -1 byte-catch-OBSOLETE ; Not generated since Emacs 25.
+ "for catch. Takes, on stack, the tag and an expression for
+the body")
(byte-defop 142 -1 byte-unwind-protect
- "for unwind-protect. Takes, on stack, an expression for the unwind-action")
+ "for unwind-protect. Takes, on stack, an expression for
+the unwind-action")
;; For condition-case. Takes, on stack, the variable to bind,
;; an expression for the body, and a list of clauses.
-(byte-defop 143 -2 byte-condition-case)
+;; Not generated since Emacs 25.
+(byte-defop 143 -2 byte-condition-case-OBSOLETE)
(byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE)
(byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE)
@@ -781,8 +841,8 @@ otherwise pop it")
(defconst byte-discardN-preserve-tos byte-discardN)
(byte-defop 183 -2 byte-switch
- "to take a hash table and a value from the stack, and jump to the address
-the value maps to, if any.")
+ "to take a hash table and a value from the stack, and jump to
+the address the value maps to, if any.")
;; unused: 182-191
@@ -953,16 +1013,16 @@ CONST2 may be evaluated multiple times."
;; it within 2 bytes in the byte string).
(puthash value pc hash-table))
hash-table))
- (apply 'unibyte-string (nreverse bytes))))
+ (let ((bytecode (apply 'unibyte-string (nreverse bytes))))
+ (when byte-native-compiling
+ ;; Spill LAP for the native compiler here.
+ (puthash bytecode (make-byte-to-native-lambda :lap lap)
+ byte-to-native-lambdas-h))
+ bytecode)))
;;; compile-time evaluation
-(defun byte-compile-cl-file-p (file)
- "Return non-nil if FILE is one of the CL files."
- (and (stringp file)
- (string-match "^cl\\.el" (file-name-nondirectory file))))
-
(defun byte-compile-eval (form)
"Eval FORM and mark the functions defined therein.
Each function's symbol gets added to `byte-compile-noruntime-functions'."
@@ -993,18 +1053,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(when (and (symbolp s) (not (memq s old-autoloads)))
(push s byte-compile-noruntime-functions))
(when (and (consp s) (eq t (car s)))
- (push (cdr s) old-autoloads)))))))
- (when (byte-compile-warning-enabled-p 'cl-functions)
- (let ((hist-new load-history))
- ;; Go through load-history, looking for the cl files.
- ;; Since new files are added at the start of load-history,
- ;; we scan the new history until the tail matches the old.
- (while (and (not byte-compile-cl-functions)
- hist-new (not (eq hist-new hist-orig)))
- ;; We used to check if the file had already been loaded,
- ;; but it is better to check non-nil byte-compile-cl-functions.
- (and (byte-compile-cl-file-p (car (pop hist-new)))
- (byte-compile-find-cl-functions))))))))
+ (push (cdr s) old-autoloads))))))))))
(defun byte-compile-eval-before-compile (form)
"Evaluate FORM for `eval-and-compile'."
@@ -1015,9 +1064,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; There are other ways to do this nowadays.
(let ((tem current-load-list))
(while (not (eq tem hist-nil-orig))
- (when (equal (car tem) '(require . cl))
- (byte-compile-disable-warning 'cl-functions))
- (setq tem (cdr tem)))))))
+ (setq tem (cdr tem)))))))
;;; byte compiler messages
@@ -1201,7 +1248,7 @@ message buffer `default-directory'."
byte-compile-last-warned-form))))
(insert (format "\nIn %s:\n" form)))
(when level
- (insert (format "%s%s" file pos))))
+ (insert (format "%s%s " file pos))))
(setq byte-compile-last-logged-file byte-compile-current-file
byte-compile-last-warned-form byte-compile-current-form)
entry)
@@ -1425,11 +1472,35 @@ when printing the error message."
;; Remember number of args in call.
(let ((cons (assq f byte-compile-unresolved-functions)))
(if cons
- (or (memq nargs (cdr cons))
- (push nargs (cdr cons)))
- (push (list f nargs)
+ (or (memq nargs (cddr cons))
+ (push nargs (cddr cons)))
+ (push (list f byte-compile-last-position nargs)
byte-compile-unresolved-functions)))))
+(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
+ (byte-compile-set-symbol-position name)
+ (byte-compile-warn
+ "%s called with %d argument%s, but %s %s"
+ name actual-args
+ (if (= 1 actual-args) "" "s")
+ (if (< actual-args min-args)
+ "requires"
+ "accepts only")
+ (byte-compile-arglist-signature-string (cons min-args max-args))))
+
+(defun byte-compile--check-arity-bytecode (form bytecode)
+ "Check that the call in FORM matches that allowed by BYTECODE."
+ (when (and (byte-code-function-p bytecode)
+ (byte-compile-warning-enabled-p 'callargs))
+ (let* ((actual-args (length (cdr form)))
+ (arity (func-arity bytecode))
+ (min-args (car arity))
+ (max-args (and (numberp (cdr arity)) (cdr arity))))
+ (when (or (< actual-args min-args)
+ (and max-args (> actual-args max-args)))
+ (byte-compile-emit-callargs-warn
+ (car form) actual-args min-args max-args)))))
+
;; Warn if the form is calling a function with the wrong number of arguments.
(defun byte-compile-callargs-warn (form)
(let* ((def (or (byte-compile-fdefinition (car form) nil)
@@ -1444,16 +1515,9 @@ when printing the error message."
(setcdr sig nil))
(if sig
(when (or (< ncall (car sig))
- (and (cdr sig) (> ncall (cdr sig))))
- (byte-compile-set-symbol-position (car form))
- (byte-compile-warn
- "%s called with %d argument%s, but %s %s"
- (car form) ncall
- (if (= 1 ncall) "" "s")
- (if (< ncall (car sig))
- "requires"
- "accepts only")
- (byte-compile-arglist-signature-string sig))))
+ (and (cdr sig) (> ncall (cdr sig))))
+ (byte-compile-emit-callargs-warn
+ (car form) ncall (car sig) (cdr sig))))
(byte-compile-format-warn form)
(byte-compile-function-warn (car form) (length (cdr form)) def)))
@@ -1527,14 +1591,14 @@ extra args."
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions))
(setq calls (delq t calls)) ;Ignore higher-order uses of the function.
- (when (cdr calls)
+ (when (cddr calls)
(when (and (symbolp name)
(eq (function-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 arglist)
- nums (sort (copy-sequence (cdr calls)) (function <))
+ nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums)
max (car (nreverse nums)))
(when (or (< min (car sig))
@@ -1567,95 +1631,99 @@ extra args."
(if (equal sig1 '(1 . 1)) "argument" "arguments")
(byte-compile-arglist-signature-string sig2)))))))
-(defvar byte-compile-cl-functions nil
- "List of functions defined in CL.")
-
-;; Can't just add this to cl-load-hook, because that runs just before
-;; the forms from cl.el get added to load-history.
-(defun byte-compile-find-cl-functions ()
- (unless byte-compile-cl-functions
- (dolist (elt load-history)
- (and (byte-compile-cl-file-p (car elt))
- (dolist (e (cdr elt))
- ;; Includes the cl-foo functions that cl autoloads.
- (when (memq (car-safe e) '(autoload defun))
- (push (cdr e) byte-compile-cl-functions)))))))
-
-(defun byte-compile-cl-warn (form)
- "Warn if FORM is a call of a function from the CL package."
- (let ((func (car-safe form)))
- (if (and byte-compile-cl-functions
- (memq func byte-compile-cl-functions)
- ;; Aliases which won't have been expanded at this point.
- ;; These aren't all aliases of subrs, so not trivial to
- ;; avoid hardwiring the list.
- (not (memq func
- '(cl--block-wrapper cl--block-throw
- multiple-value-call nth-value
- copy-seq first second rest endp cl-member
- ;; These are included in generated code
- ;; that can't be called except at compile time
- ;; or unless cl is loaded anyway.
- cl--defsubst-expand cl-struct-setf-expander
- ;; These would sometimes be warned about
- ;; but such warnings are never useful,
- ;; so don't warn about them.
- macroexpand
- cl--compiling-file))))
- (byte-compile-warn "function `%s' from cl package called at runtime"
- func)))
+(defvar byte-compile--wide-docstring-substitution-len 3
+ "Substitution width used in `byte-compile--wide-docstring-p'.
+This is a heuristic for guessing the width of a documentation
+string: `byte-compile--wide-docstring-p' assumes that any
+`substitute-command-keys' command substitutions are this long.")
+
+(defun byte-compile--wide-docstring-p (docstring col)
+ "Return t if string DOCSTRING is wider than COL.
+Ignore all `substitute-command-keys' substitutions, except for
+the `\\\\=[command]' ones that are assumed to be of length
+`byte-compile--wide-docstring-substitution-len'. Also ignore
+URLs."
+ (string-match
+ (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX.
+ (replace-regexp-in-string
+ (rx (or
+ ;; Ignore some URLs.
+ (seq "http" (? "s") "://" (* anychar))
+ ;; Ignore these `substitute-command-keys' substitutions.
+ (seq "\\" (or "="
+ (seq "<" (* (not ">")) ">")
+ (seq "{" (* (not "}")) "}")))
+ ;; Ignore the function signature that's stashed at the end of
+ ;; the doc string (in some circumstances).
+ (seq bol "(fn (" (* nonl))))
+ ""
+ ;; Heuristic: assume these substitutions are of some length N.
+ (replace-regexp-in-string
+ (rx "\\" (or (seq "[" (* (not "]")) "]")))
+ (make-string byte-compile--wide-docstring-substitution-len ?x)
+ docstring))))
+
+(defcustom byte-compile-docstring-max-column 80
+ "Recommended maximum width of doc string lines.
+The byte-compiler will emit a warning for documentation strings
+containing lines wider than this. If `fill-column' has a larger
+value, it will override this variable."
+ :group 'bytecomp
+ :type 'integer
+ :safe #'integerp
+ :version "28.1")
+
+(defun byte-compile-docstring-length-warn (form)
+ "Warn if documentation string of FORM is too wide.
+It is too wide if it has any lines longer than the largest of
+`fill-column' and `byte-compile-docstring-max-column'."
+ ;; This has some limitations that it would be nice to fix:
+ ;; 1. We don't try to handle defuns. It is somewhat tricky to get
+ ;; it right since `defun' is a macro. Also, some macros
+ ;; themselves produce defuns (e.g. `define-derived-mode').
+ ;; 2. We assume that any `subsititute-command-keys' command replacement has a
+ ;; given length. We can't reliably do these replacements, since the value
+ ;; of the keymaps in general can't be known at compile time.
+ (when (byte-compile-warning-enabled-p 'docstrings)
+ (let ((col (max byte-compile-docstring-max-column fill-column))
+ kind name docs)
+ (pcase (car form)
+ ((or 'autoload 'custom-declare-variable 'defalias
+ 'defconst 'define-abbrev-table
+ 'defvar 'defvaralias)
+ (setq kind (nth 0 form))
+ (setq name (nth 1 form))
+ (setq docs (nth 3 form)))
+ ;; Here is how one could add lambda's here:
+ ;; ('lambda
+ ;; (setq kind "") ; can't be "function", unfortunately
+ ;; (setq docs (and (stringp (nth 2 form))
+ ;; (nth 2 form))))
+ )
+ (when (and (consp name) (eq (car name) 'quote))
+ (setq name (cadr name)))
+ (setq name (if name (format " `%s'" name) ""))
+ (when (and kind docs (stringp docs)
+ (byte-compile--wide-docstring-p docs col))
+ (byte-compile-warn "%s%s docstring wider than %s characters"
+ kind name col))))
form)
-(defun byte-compile-print-syms (str1 strn syms)
- (when syms
- (byte-compile-set-symbol-position (car syms) t))
- (cond ((and (cdr syms) (not noninteractive))
- (let* ((str strn)
- (L (length str))
- s)
- (while syms
- (setq s (symbol-name (pop syms))
- L (+ L (length s) 2))
- (if (< L (1- (buffer-local-value 'fill-column
- (or (get-buffer
- byte-compile-log-buffer)
- (current-buffer)))))
- (setq str (concat str " " s (and syms ",")))
- (setq str (concat str "\n " s (and syms ","))
- L (+ (length s) 4))))
- (byte-compile-warn "%s" str)))
- ((cdr syms)
- (byte-compile-warn "%s %s"
- strn
- (mapconcat #'symbol-name syms ", ")))
-
- (syms
- (byte-compile-warn str1 (car syms)))))
-
;; If we have compiled any calls to functions which are not known to be
;; defined, issue a warning enumerating them.
;; `unresolved' in the list `byte-compile-warnings' disables this.
(defun byte-compile-warn-about-unresolved-functions ()
(when (byte-compile-warning-enabled-p 'unresolved)
- (let ((byte-compile-current-form :end)
- (noruntime nil)
- (unresolved nil))
+ (let ((byte-compile-current-form :end))
;; Separate the functions that will not be available at runtime
;; from the truly unresolved ones.
- (dolist (f byte-compile-unresolved-functions)
- (setq f (car f))
- (when (not (memq f byte-compile-new-defuns))
- (if (fboundp f) (push f noruntime) (push f unresolved))))
- ;; Complain about the no-run-time functions
- (byte-compile-print-syms
- "the function `%s' might not be defined at runtime."
- "the following functions might not be defined at runtime:"
- noruntime)
- ;; Complain about the unresolved functions
- (byte-compile-print-syms
- "the function `%s' is not known to be defined."
- "the following functions are not known to be defined:"
- unresolved)))
+ (dolist (urf byte-compile-unresolved-functions)
+ (let ((f (car urf)))
+ (when (not (memq f byte-compile-new-defuns))
+ (let ((byte-compile-last-position (cadr urf)))
+ (byte-compile-warn
+ (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.")
+ (car urf))))))))
nil)
@@ -1693,17 +1761,25 @@ extra args."
;; (byte-compile-generate-emacs19-bytecodes
;; byte-compile-generate-emacs19-bytecodes)
(byte-compile-warnings byte-compile-warnings)
+ ;; Indicate that we're not currently loading some file.
+ ;; This is used in `macroexp-file-name' to make sure that
+ ;; loading file A which does (byte-compile-file B) won't
+ ;; cause macro calls in B to think they come from A.
+ (current-load-list (list nil))
)
- ,@body))
+ (prog1
+ (progn ,@body)
+ (when byte-native-compiling
+ (setq byte-to-native-plist-environment
+ overriding-plist-environment)))))
(defmacro displaying-byte-compile-warnings (&rest body)
- (declare (debug t))
+ (declare (debug (def-body)))
`(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
(get-buffer byte-compile-log-buffer)))))
- (byte-compile-find-cl-functions)
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
;; warning-series does come from compilation,
@@ -1736,7 +1812,7 @@ Files in subdirectories of DIRECTORY are processed also."
(byte-recompile-directory directory nil t))
;;;###autoload
-(defun byte-recompile-directory (directory &optional arg force)
+(defun byte-recompile-directory (directory &optional arg force follow-symlinks)
"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 DIRECTORY are processed also.
@@ -1749,7 +1825,11 @@ compile it. A nonzero ARG also means ask about each subdirectory
before scanning it.
If the third argument FORCE is non-nil, recompile every `.el' file
-that already has a `.elc' file."
+that already has a `.elc' file.
+
+This command will normally not follow symlinks when compiling
+files. If FOLLOW-SYMLINKS is non-nil, symlinked `.el' files will
+also be compiled."
(interactive "DByte recompile directory: \nP")
(if arg (setq arg (prefix-numeric-value arg)))
(if noninteractive
@@ -1777,12 +1857,13 @@ that already has a `.elc' file."
(while directories
(setq directory (car directories))
(message "Checking %s..." directory)
- (dolist (file (directory-files directory))
- (let ((source (expand-file-name file directory)))
+ (dolist (source (directory-files directory t))
+ (let ((file (file-name-nondirectory source)))
(if (file-directory-p source)
(and (not (member file '("RCS" "CVS")))
(not (eq ?\. (aref file 0)))
- (not (file-symlink-p source))
+ (or follow-symlinks
+ (not (file-symlink-p source)))
;; This file is a subdirectory. Handle them differently.
(or (null arg) (eq 0 arg)
(y-or-n-p (concat "Check " source "? ")))
@@ -1793,8 +1874,7 @@ that already has a `.elc' file."
(file-readable-p source)
(not (string-match "\\`\\.#" file))
(not (auto-save-file-name-p source))
- (not (string-equal dir-locals-file
- (file-name-nondirectory source))))
+ (not (member source (dir-locals--all-files directory))))
(progn (cl-incf
(pcase (byte-recompile-file source force arg)
('no-byte-compile skip-count)
@@ -1835,10 +1915,9 @@ compile FILENAME. If optional argument ARG is 0, it compiles
the input file even if the `.elc' file does not exist.
Any other non-nil value of ARG means to ask the user.
-If optional argument LOAD is non-nil, loads the file after compiling.
-
If compilation is needed, this functions returns the result of
`byte-compile-file'; otherwise it returns `no-byte-compile'."
+ (declare (advertised-calling-convention (filename &optional force arg) "28.1"))
(interactive
(let ((file buffer-file-name)
(file-name nil)
@@ -1855,22 +1934,34 @@ If compilation is needed, this functions returns the result of
(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))
+ (prog1
+ (if (if (and dest (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))
+ 'no-byte-compile)
(when load
- (load (if (file-exists-p dest) dest filename)))
- 'no-byte-compile)))
+ (load (if (and dest (file-exists-p dest)) dest filename))))))
+
+(defun byte-compile--load-dynvars (file)
+ (and file (not (equal file ""))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (let ((vars nil)
+ var)
+ (while (ignore-errors (setq var (read (current-buffer))))
+ (push var vars))
+ vars))))
(defvar byte-compile-level 0 ; bug#13787
"Depth of a recursive byte compilation.")
@@ -1880,8 +1971,10 @@ If compilation is needed, this functions returns the result of
"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."
+The value is non-nil if there were no errors, nil if errors.
+
+See also `emacs-lisp-byte-compile-and-load'."
+ (declare (advertised-calling-convention (filename) "28.1"))
;; (interactive "fByte compile file: \nP")
(interactive
(let ((file buffer-file-name)
@@ -1910,8 +2003,11 @@ The value is non-nil if there were no errors, nil if errors."
(let ((byte-compile-current-file filename)
(byte-compile-current-group nil)
(set-auto-coding-for-load t)
+ (byte-compile--seen-defvars nil)
+ (byte-compile--known-dynamic-vars
+ (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
target-file input-buffer output-buffer
- byte-compile-dest-file)
+ byte-compile-dest-file byte-compiler-error-flag)
(setq target-file (byte-compile-dest-file filename))
(setq byte-compile-dest-file target-file)
(with-current-buffer
@@ -1964,7 +2060,7 @@ The value is non-nil if there were no errors, nil if errors."
;; (message "%s not compiled because of `no-byte-compile: %s'"
;; (byte-compile-abbreviate-file filename)
;; (with-current-buffer input-buffer no-byte-compile))
- (when (file-exists-p target-file)
+ (when (and target-file (file-exists-p target-file))
(message "%s deleted because of `no-byte-compile: %s'"
(byte-compile-abbreviate-file target-file)
(buffer-local-value 'no-byte-compile input-buffer))
@@ -1973,7 +2069,6 @@ The value is non-nil if there were no errors, nil if errors."
'no-byte-compile)
(when byte-compile-verbose
(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.
@@ -1987,46 +2082,73 @@ The value is non-nil if there were no errors, nil if errors."
(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)
+ (when (and target-file
+ (or (not byte-native-compiling)
+ (and byte-native-compiling byte+native-compile)))
+ (goto-char (point-max))
+ (insert "\n") ; aaah, unix.
+ (cond
+ ((and (file-writable-p target-file)
+ ;; We attempt to create a temporary file in the
+ ;; target directory, so the target directory must be
+ ;; writable.
+ (file-writable-p
+ (file-name-directory
+ ;; Need to expand in case TARGET-FILE doesn't
+ ;; include a directory (Bug#45287).
+ (expand-file-name target-file))))
;; We must disable any code conversion here.
- (progn
- (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-file (expand-file-name target-file)))
- (default-modes (default-file-modes))
- (temp-modes (logand default-modes #o600))
- (desired-modes (logand default-modes #o666))
- (kill-emacs-hook
- (cons (lambda () (ignore-errors
- (delete-file tempfile)))
- kill-emacs-hook)))
- (unless (= temp-modes desired-modes)
- (set-file-modes tempfile desired-modes))
- (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))
- (or noninteractive (message "Wrote %s" target-file)))
- ;; This is just to give a better error message than write-region
- (let ((exists (file-exists-p target-file)))
- (signal (if exists 'file-error 'file-missing)
- (list "Opening output file"
- (if exists
- "Cannot overwrite file"
- "Directory not writable or nonexistent")
- target-file))))
+ (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-file (when (file-writable-p target-file)
+ (expand-file-name target-file))))
+ (default-modes (default-file-modes))
+ (temp-modes (logand default-modes #o600))
+ (desired-modes (logand default-modes #o666))
+ (kill-emacs-hook
+ (cons (lambda () (ignore-errors
+ (delete-file tempfile)))
+ kill-emacs-hook)))
+ (unless (= temp-modes desired-modes)
+ (set-file-modes tempfile desired-modes 'nofollow))
+ (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.
+ (if byte-native-compiling
+ ;; Defer elc final renaming.
+ (setf byte-to-native-output-file
+ (cons tempfile target-file))
+ (rename-file tempfile target-file t)))
+ (or noninteractive
+ byte-native-compiling
+ (message "Wrote %s" target-file)))
+ ((file-writable-p target-file)
+ ;; In case the target directory isn't writable (see e.g. Bug#44631),
+ ;; try writing to the output file directly. We must disable any
+ ;; code conversion here.
+ (let ((coding-system-for-write 'no-conversion))
+ (with-file-modes (logand (default-file-modes) #o666)
+ (write-region (point-min) (point-max) target-file nil 1)))
+ (or noninteractive (message "Wrote %s" target-file)))
+ (t
+ ;; This is just to give a better error message than write-region
+ (let ((exists (file-exists-p target-file)))
+ (signal (if exists 'file-error 'file-missing)
+ (list "Opening output file"
+ (if exists
+ "Cannot overwrite file"
+ "Directory not writable or nonexistent")
+ target-file))))))
(kill-buffer (current-buffer)))
(if (and byte-compile-generate-call-tree
(or (eq t byte-compile-generate-call-tree)
@@ -2034,8 +2156,17 @@ The value is non-nil if there were no errors, nil if errors."
filename))))
(save-excursion
(display-call-tree filename)))
+ (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
+ (when (and gen-dynvars (not (equal gen-dynvars ""))
+ byte-compile--seen-defvars)
+ (let ((dynvar-file (concat target-file ".dynvars")))
+ (message "Generating %s" dynvar-file)
+ (with-temp-buffer
+ (dolist (var (delete-dups byte-compile--seen-defvars))
+ (insert (format "%S\n" (cons var filename))))
+ (write-region (point-min) (point-max) dynvar-file)))))
(if load
- (load target-file))
+ (load target-file))
t))))
;;; compiling a single function
@@ -2120,6 +2251,17 @@ With argument ARG, insert value in current buffer after the form."
(setq byte-compile-unresolved-functions nil)
(setq byte-compile-noruntime-functions nil)
(setq byte-compile-new-defuns nil)
+ (when byte-native-compiling
+ (defvar native-comp-speed)
+ (push `(native-comp-speed . ,native-comp-speed) byte-native-qualities)
+ (defvar native-comp-debug)
+ (push `(native-comp-debug . ,native-comp-debug) byte-native-qualities)
+ (defvar native-comp-driver-options)
+ (push `(native-comp-driver-options . ,native-comp-driver-options)
+ byte-native-qualities)
+ (defvar no-native-compile)
+ (push `(no-native-compile . ,no-native-compile)
+ byte-native-qualities))
;; Compile the forms from the input buffer.
(while (progn
@@ -2139,55 +2281,13 @@ With argument ARG, insert value in current buffer after the form."
;; Make warnings about unresolved functions
;; give the end of the file as their position.
(setq byte-compile-last-position (point-max))
- (byte-compile-warn-about-unresolved-functions))
- ;; Fix up the header at the front of the output
- ;; if the buffer contains multibyte characters.
- (and byte-compile-current-file
- (with-current-buffer byte-compile--outbuffer
- (byte-compile-fix-header byte-compile-current-file))))
+ (byte-compile-warn-about-unresolved-functions)))
byte-compile--outbuffer)))
-(defun byte-compile-fix-header (_filename)
- "If the current buffer has any multibyte characters, insert a version test."
- (when (< (point-max) (position-bytes (point-max)))
- (goto-char (point-min))
- ;; Find the comment that describes the version condition.
- (search-forward "\n;;; This file uses")
- (narrow-to-region (line-beginning-position) (point-max))
- ;; Find the first line of ballast semicolons.
- (search-forward ";;;;;;;;;;")
- (beginning-of-line)
- (narrow-to-region (point-min) (point))
- (let ((old-header-end (point))
- (minimum-version "23")
- delta)
- (delete-region (point-min) (point-max))
- (insert
- ";;; This file contains utf-8 non-ASCII characters,\n"
- ";;; and so cannot be loaded into Emacs 22 or earlier.\n"
- ;; Have to check if emacs-version is bound so that this works
- ;; in files loaded early in loadup.el.
- "(and (boundp 'emacs-version)\n"
- ;; If there is a name at the end of emacs-version,
- ;; don't try to check the version number.
- " (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
- (format " (string-lessp emacs-version \"%s\")\n" minimum-version)
- ;; Because the header must fit in a fixed width, we cannot
- ;; insert arbitrary-length file names (Bug#11585).
- " (error \"`%s' was compiled for "
- (format "Emacs %s or later\" #$))\n\n" minimum-version))
- ;; Now compensate for any change in size, to make sure all
- ;; positions in the file remain valid.
- (setq delta (- (point-max) old-header-end))
- (goto-char (point-max))
- (widen)
- (delete-char delta))))
-
(defun byte-compile-insert-header (_filename outbuffer)
"Insert a header at the start of OUTBUFFER.
Call from the source buffer."
- (let ((dynamic-docstrings byte-compile-dynamic-docstrings)
- (dynamic byte-compile-dynamic)
+ (let ((dynamic byte-compile-dynamic)
(optimize byte-optimize))
(with-current-buffer outbuffer
(goto-char (point-min))
@@ -2201,7 +2301,19 @@ Call from the source buffer."
;; 0 string ;ELC GNU Emacs Lisp compiled file,
;; >4 byte x version %d
(insert
- ";ELC" 23 "\000\000\000\n"
+ ";ELC"
+ (let ((version
+ (if (zerop emacs-minor-version)
+ ;; Let's allow silently loading into Emacs-27
+ ;; files compiled with Emacs-28.0.NN since the two can
+ ;; be almost identical (e.g. right after cutting the
+ ;; release branch) and people running the development
+ ;; branch can be presumed to know that it's risky anyway.
+ (1- emacs-major-version) emacs-major-version)))
+ ;; Make sure the version is a plain byte that doesn't end the comment!
+ (cl-assert (and (> version 13) (< version 128)))
+ version)
+ "\000\000\000\n"
";;; Compiled\n"
";;; in Emacs version " emacs-version "\n"
";;; with"
@@ -2213,19 +2325,7 @@ Call from the source buffer."
".\n"
(if dynamic ";;; Function definitions are lazy-loaded.\n"
"")
- "\n;;; This file uses "
- (if dynamic-docstrings
- "dynamic docstrings, first added in Emacs 19.29"
- "opcodes that do not exist in Emacs 18")
- ".\n\n"
- ;; Note that byte-compile-fix-header may change this.
- ";;; This file does not contain utf-8 non-ASCII characters,\n"
- ";;; and so can be loaded in Emacs versions earlier than 23.\n\n"
- ;; Insert semicolons as ballast, so that byte-compile-fix-header
- ;; can delete them so as to keep the buffer positions
- ;; constant for the actual compiled code.
- ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n"
- ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))))
+ "\n\n"))))
(defun byte-compile-output-file-form (form)
;; Write the given form to the output buffer, being careful of docstrings
@@ -2234,6 +2334,10 @@ 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.
+ (when byte-native-compiling
+ ;; Spill output for the native compiler here
+ (push (make-byte-to-native-top-level :form form :lexical lexical-binding)
+ byte-to-native-top-level-forms))
(let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
@@ -2351,7 +2455,7 @@ list that represents a doc string reference.
(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
- (setq form (byte-optimize-form form t)))
+ (setq form (byte-optimize-one-form form t)))
(if handler
(let ((byte-compile--for-effect t))
;; To avoid consing up monstrously large forms at load time, we split
@@ -2379,8 +2483,6 @@ list that represents a doc string reference.
byte-compile-output nil
byte-compile-jump-tables nil))))
-(defvar byte-compile-force-lexical-warnings 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
@@ -2391,7 +2493,6 @@ list that represents a doc string reference.
;; (setq form (byte-optimize-form form for-effect)))
(cond
(lexical-binding (cconv-closure-convert form))
- (byte-compile-force-lexical-warnings (cconv-warnings-only form))
(t form)))
;; byte-hunk-handlers cannot call this!
@@ -2449,24 +2550,29 @@ list that represents a doc string reference.
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- form
+ (prog1 form
+ (byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
-(defun byte-compile--declare-var (sym)
+(defun byte-compile--check-prefixed-var (sym)
(when (and (symbolp sym)
(not (string-match "[-*/:$]" (symbol-name sym)))
(byte-compile-warning-enabled-p 'lexical sym))
- (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
- sym))
+ (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym)))
+
+(defun byte-compile--declare-var (sym)
+ (byte-compile--check-prefixed-var sym)
(when (memq sym byte-compile-lexical-variables)
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
- (byte-compile-warn "Variable `%S' declared after its first use" sym))
- (push sym byte-compile-bound-variables))
+ (when (byte-compile-warning-enabled-p 'lexical sym)
+ (byte-compile-warn "Variable `%S' declared after its first use" sym)))
+ (push sym byte-compile-bound-variables)
+ (push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
(let ((sym (nth 1 form)))
@@ -2476,6 +2582,7 @@ list that represents a doc string reference.
(if (and (null (cddr form)) ;No `value' provided.
(eq (car form) 'defvar)) ;Just a declaration.
nil
+ (byte-compile-docstring-length-warn form)
(cond ((consp (nth 2 form))
(setq form (copy-sequence form))
(setcar (cdr (cdr form))
@@ -2499,6 +2606,7 @@ list that represents a doc string reference.
(if (byte-compile-warning-enabled-p 'suspicious)
(byte-compile-warn
"Alias for `%S' should be declared before its referent" newname)))))
+ (byte-compile-docstring-length-warn form)
(byte-compile-keep-pending form))
(put 'custom-declare-variable 'byte-hunk-handler
@@ -2511,8 +2619,7 @@ list that represents a doc string reference.
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
(let ((args (mapcar 'eval (cdr form)))
- (hist-orig load-history)
- hist-new prov-cons)
+ hist-new prov-cons)
(apply 'require args)
;; Record the functions defined by the require in `byte-compile-new-defuns'.
@@ -2525,21 +2632,7 @@ list that represents a doc string reference.
(dolist (x (car hist-new))
(when (and (consp x)
(memq (car x) '(defun t)))
- (push (cdr x) byte-compile-new-defuns))))
-
- (when (byte-compile-warning-enabled-p 'cl-functions)
- ;; Detect (require 'cl) in a way that works even if cl is already loaded.
- (if (member (car args) '("cl" cl))
- (progn
- (byte-compile-warn "cl package required at runtime")
- (byte-compile-disable-warning 'cl-functions))
- ;; We may have required something that causes cl to be loaded, eg
- ;; the uncompiled version of a file that requires cl when compiling.
- (setq hist-new load-history)
- (while (and (not byte-compile-cl-functions)
- hist-new (not (eq hist-new hist-orig)))
- (and (byte-compile-cl-file-p (car (pop hist-new)))
- (byte-compile-find-cl-functions))))))
+ (push (cdr x) byte-compile-new-defuns)))))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
@@ -2576,7 +2669,8 @@ list that represents a doc string reference.
;; and similar macros cleaner.
(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
(defun byte-compile-file-form-eval (form)
- (if (eq (car-safe (nth 1 form)) 'quote)
+ (if (and (eq (car-safe (nth 1 form)) 'quote)
+ (equal (nth 2 form) lexical-binding))
(nth 1 (nth 1 form))
(byte-compile-keep-pending form)))
@@ -2687,6 +2781,15 @@ not to take responsibility for the actual compilation of the code."
;; If there's no doc string, provide -1 as the "doc string
;; index" so that no element will be treated as a doc string.
(if (not (stringp (documentation code t))) -1 4)))
+ (when byte-native-compiling
+ ;; Spill output for the native compiler here.
+ (push (if macro
+ (make-byte-to-native-top-level
+ :form `(defalias ',name '(macro . ,code) nil)
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code))
+ byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
@@ -2754,16 +2857,12 @@ FUN should be either a `lambda' value or a `closure' value."
(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)))
+ (push `(,(car binding) ',(cdr binding)) renv))
((eq binding t))
(t (push `(defvar ,binding) body))))
(if (null renv)
`(lambda ,args ,@preamble ,@body)
- `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body)))))
+ `(let ,renv (lambda ,args ,@preamble ,@body)))))
;;;###autoload
(defun byte-compile (form)
@@ -2788,23 +2887,27 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (symbolp form) form "provided"))
fun)
(t
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun)))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent to the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun))))))
+ (let (final-eval)
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; `fun' is a function *value*, so try to recover its corresponding
+ ;; source code.
+ (setq lexical-binding (eq (car fun) 'closure))
+ (setq fun (byte-compile--reify-function fun))
+ (setq final-eval t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (if (symbolp form)
+ ;; byte-compile-top-level returns an *expression* equivalent to the
+ ;; `fun' expression, so we need to evaluate it, tho normally
+ ;; this is not needed because the expression is just a constant
+ ;; byte-code object, which is self-evaluating.
+ (setq fun (eval fun t)))
+ (if final-eval
+ (setq fun (eval fun t)))
+ (if macro (push 'macro fun))
+ (if (symbolp form) (fset form fun))
+ fun)))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -2830,7 +2933,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
((eq arg '&optional)
(when (memq '&optional (cdr list))
(error "Duplicate &optional")))
- ((memq arg vars)
+ ((and (memq arg vars)
+ ;; Allow repetitions for unused args.
+ (not (string-match "\\`_" (symbol-name arg))))
(byte-compile-warn "repeated variable %s in lambda-list" arg))
(t
(push arg vars))))
@@ -2872,6 +2977,16 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(ash nonrest 8)
(ash rest 7)))))
+(defun byte-compile--warn-lexical-dynamic (var context)
+ (when (byte-compile-warning-enabled-p 'lexical-dynamic var)
+ (byte-compile-warn
+ "`%s' lexically bound in %s here but declared dynamic in: %s"
+ var context
+ (mapconcat #'identity
+ (mapcan (lambda (v) (and (eq var (car v))
+ (list (cdr v))))
+ byte-compile--known-dynamic-vars)
+ ", "))))
(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
"Byte-compile a lambda-expression and return a valid function.
@@ -2886,6 +3001,7 @@ for symbols generated by the byte compiler itself."
(unless (eq 'lambda (car-safe fun))
(error "Not a lambda list: %S" fun))
(byte-compile-set-symbol-position 'lambda))
+ (byte-compile-docstring-length-warn fun)
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
(arglistvars (byte-compile-arglist-vars arglist))
@@ -2899,17 +3015,25 @@ for symbols generated by the byte compiler itself."
;; unless it is the last element of the body.
(if (cdr body)
(setq body (cdr body))))))
- (int (assq 'interactive body)))
+ (int (assq 'interactive body))
+ command-modes)
+ (when lexical-binding
+ (dolist (var arglistvars)
+ (when (assq var byte-compile--known-dynamic-vars)
+ (byte-compile--warn-lexical-dynamic var 'lambda))))
;; Process the interactive spec.
(when int
(byte-compile-set-symbol-position 'interactive)
;; Skip (interactive) if it is in front (the most usual location).
(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 int)))
+ (cond ((consp (cdr int)) ; There is an `interactive' spec.
+ ;; Check that the bit after the `interactive' spec is
+ ;; just a list of symbols (i.e., modes).
+ (unless (seq-every-p #'symbolp (cdr (cdr int)))
+ (byte-compile-warn "malformed interactive specc: %s"
+ (prin1-to-string int)))
+ (setq command-modes (cdr (cdr 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,
@@ -2920,15 +3044,14 @@ for symbols generated by the byte compiler itself."
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
- (if (and (eq (car-safe form) 'list)
- ;; For code using lexical-binding, form is not
- ;; valid lisp, but rather an intermediate form
- ;; which may include "calls" to
- ;; internal-make-closure (Bug#29988).
- (not lexical-binding))
- nil
- (setq int `(interactive ,newform)))))
- ((cdr int)
+ (when (or (not (eq (car-safe form) 'list))
+ ;; For code using lexical-binding, form is not
+ ;; valid lisp, but rather an intermediate form
+ ;; which may include "calls" to
+ ;; internal-make-closure (Bug#29988).
+ lexical-binding)
+ (setq int `(interactive ,newform)))))
+ ((cdr int) ; Invalid (interactive . something).
(byte-compile-warn "malformed interactive spec: %s"
(prin1-to-string int)))))
;; Process the body.
@@ -2944,23 +3067,37 @@ for symbols generated by the byte compiler itself."
reserved-csts)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe 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 ((and lexical-binding arglist)
- ;; byte-compile-make-args-desc lost the args's names,
- ;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc arglist)))
- ((or doc int)
- (list doc)))
- ;; optionally, the interactive spec.
- (if int
- (list (nth 1 int))))))))
+ (let ((out
+ (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 ((and lexical-binding arglist)
+ ;; byte-compile-make-args-desc lost the args's names,
+ ;; so preserve them in the docstring.
+ (list (help-add-fundoc-usage doc arglist)))
+ ((or doc int)
+ (list doc)))
+ ;; optionally, the interactive spec (and the modes the
+ ;; command applies to).
+ (cond
+ ;; We have some command modes, so use the vector form.
+ (command-modes
+ (list (vector (nth 1 int) command-modes)))
+ ;; No command modes, use the simple form with just the
+ ;; interactive spec.
+ (int
+ (list (nth 1 int))))))))
+ (when byte-native-compiling
+ (setf (byte-to-native-lambda-byte-func
+ (gethash (cadr compiled)
+ byte-to-native-lambdas-h))
+ out))
+ out))))
(defvar byte-compile-reserved-constants 0)
@@ -3018,7 +3155,7 @@ for symbols generated by the byte compiler itself."
(byte-compile-output nil)
(byte-compile-jump-tables nil))
(if (memq byte-optimize '(t source))
- (setq form (byte-optimize-form form byte-compile--for-effect)))
+ (setq form (byte-optimize-one-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.
@@ -3189,7 +3326,7 @@ for symbols generated by the byte compiler itself."
run-hook-with-args-until-failure))
(pcase (cdr form)
(`(',var . ,_)
- (when (assq var byte-compile-lexical-variables)
+ (when (memq var byte-compile-lexical-variables)
(byte-compile-report-error
(format-message "%s cannot use lexical var `%s'" fn var))))))
;; Warn about using obsolete hooks.
@@ -3215,7 +3352,8 @@ for symbols generated by the byte compiler itself."
(t "."))))
(if (eq (car-safe (symbol-function (car form))) 'macro)
(byte-compile-report-error
- (format "Forgot to expand macro %s in %S" (car form) form)))
+ (format "`%s' defined after use in %S (missing `require' of a library file?)"
+ (car form) form)))
(if (and handler
;; Make sure that function exists.
(and (functionp handler)
@@ -3224,16 +3362,14 @@ for symbols generated by the byte compiler itself."
;; differently now).
(not (eq handler 'cl-byte-compile-compiler-macro))))
(funcall handler form)
- (byte-compile-normal-call form))
- (if (byte-compile-warning-enabled-p 'cl-functions)
- (byte-compile-cl-warn form))))
+ (byte-compile-normal-call 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)))))
+ (not (eq form (setq form (macroexp--unfold-lambda form)))))
(byte-compile-form form byte-compile--for-effect)
(setq byte-compile--for-effect nil))
((byte-compile-normal-call form)))
@@ -3398,10 +3534,11 @@ for symbols generated by the byte compiler itself."
(and od
(not (memq var byte-compile-not-obsolete-vars))
(not (memq var byte-compile-global-not-obsolete-vars))
- (or (pcase (nth 1 od)
- ('set (not (eq access-type 'reference)))
- ('get (eq access-type 'reference))
- (_ t)))))
+ (not (memq var byte-compile-lexical-variables))
+ (pcase (nth 1 od)
+ ('set (not (eq access-type 'reference)))
+ ('get (eq access-type 'reference))
+ (_ t))))
(byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op var)
@@ -3417,6 +3554,27 @@ for symbols generated by the byte compiler itself."
(push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var))
+(defun byte-compile-free-vars-warn (var &optional assignment)
+ "Warn if symbol VAR refers to a free variable.
+VAR must not be lexically bound.
+If optional argument ASSIGNMENT is non-nil, this is treated as an
+assignment (i.e. `setq'). "
+ (unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
+ (boundp var)
+ (memq var byte-compile-bound-variables)
+ (memq var (if assignment
+ byte-compile-free-assignments
+ byte-compile-free-references)))
+ (let* ((varname (prin1-to-string var))
+ (desc (if assignment "assignment" "reference"))
+ (suggestions (help-uni-confusable-suggestions varname)))
+ (byte-compile-warn "%s to free variable `%s'%s"
+ desc varname
+ (if suggestions (concat "\n " suggestions) "")))
+ (push var (if assignment
+ byte-compile-free-assignments
+ byte-compile-free-references))))
+
(defun byte-compile-variable-ref (var)
"Generate code to push the value of the variable VAR on the stack."
(byte-compile-check-variable var 'reference)
@@ -3425,15 +3583,7 @@ for symbols generated by the byte compiler itself."
;; 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 var))
- (boundp var)
- (memq var byte-compile-bound-variables)
- (memq var byte-compile-free-references))
- (let* ((varname (prin1-to-string var))
- (suggestions (help-uni-confusable-suggestions varname)))
- (byte-compile-warn "reference to free variable `%s'%s" varname
- (if suggestions (concat "\n " suggestions) "")))
- (push var byte-compile-free-references))
+ (byte-compile-free-vars-warn var)
(byte-compile-dynamic-variable-op 'byte-varref var))))
(defun byte-compile-variable-set (var)
@@ -3444,15 +3594,7 @@ for symbols generated by the byte compiler itself."
;; 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 var))
- (boundp var)
- (memq var byte-compile-bound-variables)
- (memq var byte-compile-free-assignments))
- (let* ((varname (prin1-to-string var))
- (suggestions (help-uni-confusable-suggestions varname)))
- (byte-compile-warn "assignment to free variable `%s'%s" varname
- (if suggestions (concat "\n " suggestions) "")))
- (push var byte-compile-free-assignments))
+ (byte-compile-free-vars-warn var t)
(byte-compile-dynamic-variable-op 'byte-varset var))))
(defmacro byte-compile-get-constant (const)
@@ -3463,7 +3605,7 @@ for symbols generated by the byte compiler itself."
(if (equal-including-properties (car elt) ,const)
(setq result elt)))
result)
- (assq ,const byte-compile-constants))
+ (assoc ,const byte-compile-constants #'eql))
(car (setq byte-compile-constants
(cons (list ,const) byte-compile-constants)))))
@@ -3491,7 +3633,7 @@ the opcode to be used. If function is a list, the first element
is the function and the second element is the bytecode-symbol.
The second element may be nil, meaning there is no opcode.
COMPILE-HANDLER is the function to use to compile this byte-op, or
-may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
+may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3.
If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(let (opcode)
(if (symbolp function)
@@ -3510,6 +3652,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
(2-3 . byte-compile-two-or-three-args)
+ (1-3 . byte-compile-one-to-three-args)
)))
compile-handler
(intern (concat "byte-compile-"
@@ -3620,10 +3763,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler (% byte-rem) 2)
(byte-defop-compiler aset 3)
-(byte-defop-compiler max byte-compile-associative)
-(byte-defop-compiler min byte-compile-associative)
-(byte-defop-compiler (+ byte-plus) byte-compile-associative)
-(byte-defop-compiler (* byte-mult) byte-compile-associative)
+(byte-defop-compiler max byte-compile-min-max)
+(byte-defop-compiler min byte-compile-min-max)
+(byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric)
+(byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric)
;;####(byte-defop-compiler move-to-column 1)
(byte-defop-compiler-1 interactive byte-compile-noop)
@@ -3694,6 +3837,13 @@ These implicitly `and' together a bunch of two-arg bytecodes."
((= len 4) (byte-compile-three-args form))
(t (byte-compile-subr-wrong-args form "2-3")))))
+(defun byte-compile-one-to-three-args (form)
+ (let ((len (length form)))
+ (cond ((= len 2) (byte-compile-three-args (append form '(nil nil))))
+ ((= len 3) (byte-compile-three-args (append form '(nil))))
+ ((= len 4) (byte-compile-three-args form))
+ (t (byte-compile-subr-wrong-args form "1-3")))))
+
(defun byte-compile-noop (_form)
(byte-compile-constant nil))
@@ -3748,45 +3898,74 @@ discarding."
(cl-assert (or (> (length env) 0)
docstring-exp)) ;Otherwise, we don't need a closure.
(cl-assert (byte-code-function-p fun))
- (byte-compile-form `(make-byte-code
- ',(aref fun 0) ',(aref fun 1)
- (vconcat (vector . ,env) ',(aref fun 2))
- ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun))))
- (if docstring-exp
- `(,(car rest)
- ,docstring-exp
- ,@(cddr rest))
- rest)))))))
+ (byte-compile-form
+ (if (or (not docstring-exp) (stringp docstring-exp))
+ ;; Use symbols V0, V1 ... as placeholders for closure variables:
+ ;; they should be short (to save space in the .elc file), yet
+ ;; distinct when disassembled.
+ (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i)))
+ (number-sequence 0 (1- (length env)))))
+ (opt-args (mapcar (lambda (i) (aref fun i))
+ (number-sequence 4 (1- (length fun)))))
+ (proto-fun
+ (apply #'make-byte-code
+ (aref fun 0) (aref fun 1)
+ ;; Prepend dummy cells to the constant vector,
+ ;; to get the indices right when disassembling.
+ (vconcat dummy-vars (aref fun 2))
+ (aref fun 3)
+ (if docstring-exp
+ (cons docstring-exp (cdr opt-args))
+ opt-args))))
+ `(make-closure ,proto-fun ,@env))
+ ;; Nontrivial doc string expression: create a bytecode object
+ ;; from small pieces at run time.
+ `(make-byte-code
+ ',(aref fun 0) ',(aref fun 1)
+ (vconcat (vector . ,env) ',(aref fun 2))
+ ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun))))
+ (if docstring-exp
+ `(,(car rest)
+ ,docstring-exp
+ ,@(cddr rest))
+ rest))))
+ ))))
(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
-;; are done in the same order as in interpreted code.
-;; We treat the one-arg case, as in (+ x), like (+ x 0).
-;; in order to convert markers to numbers, and trigger expected errors.
-(defun byte-compile-associative (form)
+;; Compile a pure function that accepts zero or more numeric arguments
+;; and has an opcode for the binary case.
+;; Single-argument calls are assumed to be numeric identity and are
+;; compiled as (* x 1) in order to convert markers to numbers and
+;; trigger type errors.
+(defun byte-compile-variadic-numeric (form)
+ (pcase (length form)
+ (1
+ ;; No args: use the identity value for the operation.
+ (byte-compile-constant (eval form)))
+ (2
+ ;; One arg: compile (OP x) as (* x 1). This is identity for
+ ;; all numerical values including -0.0, infinities and NaNs.
+ (byte-compile-form (nth 1 form))
+ (byte-compile-constant 1)
+ (byte-compile-out (get '* 'byte-opcode) 0))
+ (3
+ (byte-compile-form (nth 1 form))
+ (byte-compile-form (nth 2 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (_
+ ;; >2 args: compile as a single function call.
+ (byte-compile-normal-call form))))
+
+(defun byte-compile-min-max (form)
+ "Byte-compile calls to `min' or `max'."
(if (cdr form)
- (let ((opcode (get (car form) 'byte-opcode))
- args)
- (if (and (< 3 (length form))
- (memq opcode (list (get '+ 'byte-opcode)
- (get '* 'byte-opcode))))
- ;; Don't use binary operations for > 2 operands, as that
- ;; may cause overflow/truncation in float operations.
- (byte-compile-normal-call form)
- (setq args (copy-sequence (cdr form)))
- (byte-compile-form (car args))
- (setq args (cdr args))
- (or args (setq args '(0)
- opcode (get '+ 'byte-opcode)))
- (dolist (arg args)
- (byte-compile-form arg)
- (byte-compile-out opcode 0))))
- (byte-compile-constant (eval form))))
+ (byte-compile-variadic-numeric form)
+ ;; No args: warn and emit code that raises an error when executed.
+ (byte-compile-normal-call form)))
;; more complicated compiler macros
@@ -3801,7 +3980,7 @@ discarding."
(byte-defop-compiler indent-to)
(byte-defop-compiler insert)
(byte-defop-compiler-1 function byte-compile-function-form)
-(byte-defop-compiler-1 - byte-compile-minus)
+(byte-defop-compiler (- byte-diff) byte-compile-minus)
(byte-defop-compiler (/ byte-quo) byte-compile-quo)
(byte-defop-compiler nconc)
@@ -3868,30 +4047,17 @@ discarding."
((byte-compile-normal-call form)))))
(defun byte-compile-minus (form)
- (let ((len (length form)))
- (cond
- ((= 1 len) (byte-compile-constant 0))
- ((= 2 len)
- (byte-compile-form (cadr form))
- (byte-compile-out 'byte-negate 0))
- ((= 3 len)
- (byte-compile-form (nth 1 form))
- (byte-compile-form (nth 2 form))
- (byte-compile-out 'byte-diff 0))
- ;; Don't use binary operations for > 2 operands, as that may
- ;; cause overflow/truncation in float operations.
- (t (byte-compile-normal-call form)))))
+ (if (/= (length form) 2)
+ (byte-compile-variadic-numeric form)
+ (byte-compile-form (cadr form))
+ (byte-compile-out 'byte-negate 0)))
(defun byte-compile-quo (form)
- (let ((len (length form)))
- (cond ((< len 2)
- (byte-compile-subr-wrong-args form "1 or more"))
- ((= len 3)
- (byte-compile-two-args form))
- (t
- ;; Don't use binary operations for > 2 operands, as that
- ;; may cause overflow/truncation in float operations.
- (byte-compile-normal-call form)))))
+ (if (= (length form) 3)
+ (byte-compile-two-args form)
+ ;; N-ary `/' is not the left-reduction of binary `/' because if any
+ ;; argument is a float, then everything is done in floating-point.
+ (byte-compile-normal-call form)))
(defun byte-compile-nconc (form)
(let ((len (length form)))
@@ -4097,9 +4263,15 @@ that suppresses all warnings during execution of BODY."
byte-compile-unresolved-functions))
(bound-list (byte-compile-find-bound-condition
,condition '(boundp default-boundp local-variable-p)))
+ (new-bound-list
+ ;; (seq-difference byte-compile-bound-variables))
+ (delq nil (mapcar (lambda (s)
+ (if (memq s byte-compile-bound-variables) nil s))
+ bound-list)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
- (append bound-list byte-compile-bound-variables)))
+ (append new-bound-list byte-compile-bound-variables)))
+ (mapc #'byte-compile--check-prefixed-var new-bound-list)
(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
@@ -4185,6 +4357,17 @@ Return (TAIL VAR TEST CASES), where:
(push value keys)
(push (cons (list value) (or body '(t))) cases))
t))))
+ ;; Treat (not X) as (eq X nil).
+ (`((,(or 'not 'null) ,(and var (pred symbolp))) . ,body)
+ (and (or (eq var switch-var) (not switch-var))
+ (progn
+ (setq switch-var var)
+ (setq switch-test
+ (byte-compile--common-test switch-test 'eq))
+ (unless (memq nil keys)
+ (push nil keys)
+ (push (cons (list nil) (or body '(t))) cases))
+ t)))
(`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body)
(and (symbolp var)
(or (eq var switch-var) (not switch-var))
@@ -4418,6 +4601,8 @@ Return non-nil if the TOS value was popped."
;; VAR is a simple stack-allocated lexical variable.
(progn (push (assq var init-lexenv)
byte-compile--lexical-environment)
+ (when (assq var byte-compile--known-dynamic-vars)
+ (byte-compile--warn-lexical-dynamic var 'let))
nil)
;; VAR should be dynamically bound.
(while (assq var byte-compile--lexical-environment)
@@ -4534,102 +4719,36 @@ binding slots have been popped."
;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro.
;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
-(defvar byte-compile--use-old-handlers nil
- "If nil, use new byte codes introduced in Emacs-24.4.")
-
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
- (if (not byte-compile--use-old-handlers)
- (let ((endtag (byte-compile-make-tag)))
- (byte-compile-goto 'byte-pushcatch endtag)
- (byte-compile-body (cddr form) nil)
- (byte-compile-out 'byte-pophandler)
- (byte-compile-out-tag endtag))
- (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)))
+ (let ((endtag (byte-compile-make-tag)))
+ (byte-compile-goto 'byte-pushcatch endtag)
+ (byte-compile-body (cddr form) nil)
+ (byte-compile-out 'byte-pophandler)
+ (byte-compile-out-tag endtag)))
(defun byte-compile-unwind-protect (form)
(pcase (cddr form)
(`(:fun-body ,f)
- (byte-compile-form
- (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f)))
+ (byte-compile-form f))
(handlers
- (if byte-compile--use-old-handlers
- (byte-compile-push-constant
- (byte-compile-top-level-body handlers t))
- (byte-compile-form `#'(lambda () ,@handlers)))))
+ (byte-compile-form `#'(lambda () ,@handlers))))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-condition-case (form)
- (if byte-compile--use-old-handlers
- (byte-compile-condition-case--old form)
- (byte-compile-condition-case--new form)))
-
-(defun byte-compile-condition-case--old (form)
- (let* ((var (nth 1 form))
- (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)
- (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-condition-case--new (form)
(let* ((var (nth 1 form))
(body (nth 2 form))
+ (handlers (nthcdr 3 form))
(depth byte-compile-depth)
+ (success-handler (assq :success handlers))
+ (failure-handlers (if success-handler
+ (remq success-handler handlers)
+ handlers))
(clauses (mapcar (lambda (clause)
(cons (byte-compile-make-tag) clause))
- (nthcdr 3 form)))
+ failure-handlers))
(endtag (byte-compile-make-tag)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
@@ -4655,30 +4774,40 @@ binding slots have been popped."
(byte-compile-form body) ;; byte-compile--for-effect
(dolist (_ clauses) (byte-compile-out 'byte-pophandler))
- (byte-compile-goto 'byte-goto endtag)
- (while clauses
- (let ((clause (pop clauses))
- (byte-compile-bound-variables byte-compile-bound-variables)
- (byte-compile--lexical-environment
- byte-compile--lexical-environment))
- (setq byte-compile-depth (1+ depth))
- (byte-compile-out-tag (pop clause))
- (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
- (cond
- ((null var) (byte-compile-discard))
- (lexical-binding
- (push (cons var (1- byte-compile-depth))
- byte-compile--lexical-environment))
- (t (byte-compile-dynamic-variable-bind var)))
- (byte-compile-body (cdr clause)) ;; byte-compile--for-effect
- (cond
- ((null var) nil)
- (lexical-binding (byte-compile-discard 1 'preserve-tos))
- (t (byte-compile-out 'byte-unbind 1)))
- (byte-compile-goto 'byte-goto endtag)))
+ (let ((compile-handler-body
+ (lambda (body)
+ (let ((byte-compile-bound-variables byte-compile-bound-variables)
+ (byte-compile--lexical-environment
+ byte-compile--lexical-environment))
+ (cond
+ ((null var) (byte-compile-discard))
+ (lexical-binding
+ (push (cons var (1- byte-compile-depth))
+ byte-compile--lexical-environment))
+ (t (byte-compile-dynamic-variable-bind var)))
- (byte-compile-out-tag endtag)))
+ (byte-compile-body body) ;; byte-compile--for-effect
+
+ (cond
+ ((null var))
+ (lexical-binding (byte-compile-discard 1 'preserve-tos))
+ (t (byte-compile-out 'byte-unbind 1)))))))
+
+ (when success-handler
+ (funcall compile-handler-body (cdr success-handler)))
+
+ (byte-compile-goto 'byte-goto endtag)
+
+ (while clauses
+ (let ((clause (pop clauses)))
+ (setq byte-compile-depth (1+ depth))
+ (byte-compile-out-tag (pop clause))
+ (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+ (funcall compile-handler-body (cdr clause))
+ (byte-compile-goto 'byte-goto endtag)))
+
+ (byte-compile-out-tag endtag))))
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
@@ -4726,6 +4855,7 @@ binding slots have been popped."
(byte-compile-warning-enabled-p 'lexical (nth 1 form)))
(byte-compile-warn "global/dynamic var `%s' lacks a prefix"
(nth 1 form)))
+ (byte-compile-docstring-length-warn form)
(let ((fun (nth 0 form))
(var (nth 1 form))
(value (nth 2 form))
@@ -4800,6 +4930,7 @@ binding slots have been popped."
;; - `arg' is the expression to which it is defined.
;; - `rest' is the rest of the arguments.
(`(,_ ',name ,arg . ,rest)
+ (byte-compile-docstring-length-warn form)
(pcase-let*
;; `macro' is non-nil if it defines a macro.
;; `fun' is the function part of `arg' (defaults to `arg').
@@ -4861,6 +4992,14 @@ binding slots have been popped."
(defun byte-compile-form-make-variable-buffer-local (form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
+;; Make `make-local-variable' declare the variable locally
+;; dynamic - this suppresses some unnecessary warnings
+(byte-defop-compiler-1 make-local-variable
+ byte-compile-make-local-variable)
+(defun byte-compile-make-local-variable (form)
+ (pcase form (`(,_ ',var) (byte-compile--declare-var var)))
+ (byte-compile-normal-call form))
+
(put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
(put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
(defun byte-compile-define-symbol-prop (form)
@@ -4876,10 +5015,10 @@ binding slots have been popped."
(byte-compile-push-constant op)
(byte-compile-form fun)
(byte-compile-form prop)
- (let* ((fun (eval fun))
- (prop (eval prop))
+ (let* ((fun (eval fun t))
+ (prop (eval prop t))
(val (if (macroexp-const-p val)
- (eval val)
+ (eval val t)
(byte-compile-lambda (cadr val)))))
(push `(,fun
. (,prop ,val ,@(alist-get fun overriding-plist-environment)))
@@ -5197,8 +5336,10 @@ already up-to-date."
"Reload any Lisp file that was changed since Emacs was dumped.
Use with caution."
(let* ((argv0 (car command-line-args))
- (emacs-file (executable-find argv0)))
- (if (not (and emacs-file (file-executable-p emacs-file)))
+ (emacs-file (or (and (fboundp 'pdumper-stats)
+ (cdr (nth 2 (pdumper-stats))))
+ (executable-find argv0))))
+ (if (not (and emacs-file (file-exists-p emacs-file)))
(message "Can't find %s to refresh preloaded Lisp files" argv0)
(dolist (f (reverse load-history))
(setq f (car f))
@@ -5211,7 +5352,7 @@ Use with caution."
;; so it can cause recompilation to fail.
(not (member (file-name-nondirectory f)
'("pcase.el" "bytecomp.el" "macroexp.el"
- "cconv.el" "byte-opt.el"))))
+ "cconv.el" "byte-opt.el" "comp.el"))))
(message "Reloading stale %s" (file-name-nondirectory f))
(condition-case nil
(load f 'noerror nil 'nosuffix)
@@ -5292,13 +5433,15 @@ and corresponding effects."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-compile-form))
+ (subr-native-elisp-p (symbol-function 'byte-compile-form))
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) ; do it fast
(byte-compile-warnings nil))
(mapc (lambda (x)
- (or noninteractive (message "compiling %s..." x))
- (byte-compile x)
- (or noninteractive (message "compiling %s...done" x)))
+ (unless (subr-native-elisp-p x)
+ (or noninteractive (message "compiling %s..." x))
+ (byte-compile x)
+ (or noninteractive (message "compiling %s...done" x))))
'(byte-compile-normal-call
byte-compile-form
byte-compile-body
@@ -5309,6 +5452,8 @@ and corresponding effects."
byte-compile-variable-ref))))
nil)
+(make-obsolete-variable 'bytecomp-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'bytecomp-load-hook)
;;; bytecomp.el ends here
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 5c76e47c377..3abbf716875 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -1,4 +1,4 @@
-;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
+;;; cconv.el --- Closure conversion for statically scoped Emacs Lisp. -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
@@ -121,19 +121,22 @@
(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)
+(defvar cconv-var-classification
+ ;; Alist mapping variables to a given class.
+ ;; The keys are of the form (BINDER . PARENTFORM) where BINDER
+ ;; is the (VAR VAL) that introduces it (or is just (VAR) for variables
+ ;; not introduced by let).
+ ;; The class can be one of:
+ ;; - :unused
+ ;; - :lambda-candidate
+ ;; - :captured+mutated
+ ;; - nil for "normal" variables, which would then just not appear
+ ;; in the alist at all.
+ )
+
+(defvar cconv-freevars-alist
+ ;; Alist associating to each function body the list of its free variables.
+ )
;;;###autoload
(defun cconv-closure-convert (form)
@@ -144,25 +147,13 @@ is less than this number.")
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 '()))
+ (cconv-var-classification '()))
;; Analyze form - fill these variables with new information.
(cconv-analyze-form form '())
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
(prog1 (cconv-convert form nil nil) ; Env initially empty.
(cl-assert (null cconv-freevars-alist)))))
-;;;###autoload
-(defun cconv-warnings-only (form)
- "Add the warnings that closure conversion would encounter."
- (let ((cconv-freevars-alist '())
- (cconv-lambda-candidates '())
- (cconv-captured+mutated '()))
- ;; Analyze form - fill these variables with new information.
- (cconv-analyze-form form '())
- ;; But don't perform the closure conversion.
- form))
-
(defconst cconv--dummy-var (make-symbol "ignored"))
(defun cconv--set-diff (s1 s2)
@@ -261,28 +252,56 @@ Returns a form where all lambdas don't have any free variables."
(nthcdr 3 mapping)))))
new-env))
+(defun cconv--warn-unused-msg (var varkind)
+ (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))
+ (let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
+ (format "Unused lexical %s `%S'%s"
+ varkind var
+ (if suggestions (concat "\n " suggestions) "")))))
+
+(define-inline cconv--var-classification (binder form)
+ (inline-quote
+ (alist-get (cons ,binder ,form) cconv-var-classification
+ nil nil #'equal)))
+
(defun cconv--convert-funcbody (funargs funcbody env parentform)
"Run `cconv-convert' on FUNCBODY, the forms of a lambda expression.
PARENTFORM is the form containing the lambda expression. ENV is a
lexical environment (same format as for `cconv-convert'), not
including FUNARGS, the function's argument list. Return a list
of converted forms."
- (let ((letbind ()))
+ (let ((wrappers ()))
(dolist (arg funargs)
- (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
- (if (assq arg env) (push `(,arg . nil) env))
- (push `(,arg . (car-safe ,arg)) env)
- (push `(,arg (list ,arg)) letbind)))
+ (pcase (cconv--var-classification (list arg) parentform)
+ (:captured+mutated
+ (push `(,arg . (car-safe ,arg)) env)
+ (push (lambda (body) `(let ((,arg (list ,arg))) ,body)) wrappers))
+ ((and :unused
+ (let (and (pred stringp) msg)
+ (cconv--warn-unused-msg arg "argument")))
+ (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed?
+ (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers))
+ (_
+ (if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
(cconv-convert form env nil))
funcbody))
- (if letbind
+ (if wrappers
(let ((special-forms '()))
;; Keep special forms at the beginning of the body.
- (while (or (stringp (car funcbody)) ;docstring.
- (memq (car-safe (car funcbody)) '(interactive declare)))
+ (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring.
+ (memq (car-safe (car funcbody))
+ '(interactive declare :documentation)))
(push (pop funcbody) special-forms))
- `(,@(nreverse special-forms) (let ,letbind . ,funcbody)))
+ (let ((body (macroexp-progn funcbody)))
+ (dolist (wrapper wrappers) (setq body (funcall wrapper body)))
+ `(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
funcbody)))
(defun cconv-convert (form env extend)
@@ -338,69 +357,91 @@ places where they originally did not directly appear."
"Malformed `%S' binding: %S"
letsym 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
- (cl-assert (and (eq (car value) 'function)
- (eq (car (cadr value)) 'lambda)))
- (cl-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)))
+ (car binder))))
+ (cond
+ ;; Ignore bindings without a valid name.
+ ((not (symbolp var))
+ (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
+ ((or (booleanp var) (keywordp var))
+ (byte-compile-warn "attempt to let-bind constant `%S'" var))
+ (t
+ (let ((new-val
+ (pcase (cconv--var-classification binder form)
+ ;; Check if var is a candidate for lambda lifting.
+ ((and :lambda-candidate
+ (guard
+ (progn
+ (cl-assert (and (eq (car value) 'function)
+ (eq (car (cadr value)) 'lambda)))
+ (cl-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))))))
+ (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)
- (cl-pushnew fv new-extend)
- (if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
- (not (memq fv funargs)))
- (push `(,fv . (car-safe ,fv)) funcbody-env)))
- `(function (lambda ,funcvars .
- ,(cconv--convert-funcbody
- funargs funcbody funcbody-env value)))))
-
- ;; 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-safe ,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)))))
-
- (when (and (eq letsym 'let*) (memq var new-extend))
- ;; One of the lambda-lifted vars is shadowed, so add
- ;; a reference to the outside binding and arrange to use
- ;; that reference.
- (let ((closedsym (make-symbol (format "closed-%s" var))))
- (setq new-env (cconv--remap-llv new-env var closedsym))
- (setq new-extend (cons closedsym (remq var 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
+ (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)
+ (cl-pushnew fv new-extend)
+ (if (and (eq 'car-safe (car-safe
+ (cdr (assq fv env))))
+ (not (memq fv funargs)))
+ (push `(,fv . (car-safe ,fv)) funcbody-env)))
+ `(function (lambda ,funcvars .
+ ,(cconv--convert-funcbody
+ funargs funcbody funcbody-env value)))))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:captured+mutated
+ ;; Declared variable is mutated and captured.
+ (push `(,var . (car-safe ,var)) new-env)
+ `(list ,(cconv-convert value env extend)))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:unused
+ ;; Declared variable is unused.
+ (if (assq var new-env)
+ (push `(,var) new-env)) ;FIXME:Needed?
+ (let ((newval
+ `(ignore ,(cconv-convert value env extend)))
+ (msg (cconv--warn-unused-msg var "variable")))
+ (if (null msg) newval
+ (macroexp--warn-wrap msg newval 'lexical))))
+
+ ;; Normal default case.
+ (_
+ (if (assq var new-env) (push `(,var) new-env))
+ (cconv-convert value env extend)))))
+
+ (when (and (eq letsym 'let*) (memq var new-extend))
+ ;; One of the lambda-lifted vars is shadowed, so add
+ ;; a reference to the outside binding and arrange to use
+ ;; that reference.
+ (let ((closedsym (make-symbol (format "closed-%s" var))))
+ (setq new-env (cconv--remap-llv new-env var closedsym))
+ (setq new-extend (cons closedsym (remq var 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
(when (not (eq letsym 'let*))
;; We can't do the cconv--remap-llv at the same place for let and
@@ -462,44 +503,35 @@ places where they originally did not directly appear."
;; and may be an invalid expression (e.g. ($# . 678)).
(cdr forms)))))
- ;condition-case
- ((and `(condition-case ,var ,protected-form . ,handlers)
- (guard byte-compile--use-old-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))))
-
- ; condition-case with new byte-codes.
+ ; condition-case
(`(condition-case ,var ,protected-form . ,handlers)
- `(condition-case ,var
- ,(cconv-convert protected-form env extend)
- ,@(let* ((cm (and var (member (cons (list var) form)
- cconv-captured+mutated)))
- (newenv
- (cond (cm (cons `(,var . (car-save ,var)) env))
- ((assq var env) (cons `(,var) env))
- (t env))))
- (mapcar
+ (let* ((class (and var (cconv--var-classification (list var) form)))
+ (newenv
+ (cond ((eq class :captured+mutated)
+ (cons `(,var . (car-safe ,var)) env))
+ ((assq var env) (cons `(,var) env))
+ (t env)))
+ (msg (when (eq class :unused)
+ (cconv--warn-unused-msg var "variable")))
+ (newprotform (cconv-convert protected-form env extend)))
+ `(condition-case ,var
+ ,(if msg
+ (macroexp--warn-wrap msg newprotform 'lexical)
+ newprotform)
+ ,@(mapcar
(lambda (handler)
`(,(car handler)
,@(let ((body
(mapcar (lambda (form)
(cconv-convert form newenv extend))
(cdr handler))))
- (if (not cm) body
+ (if (not (eq class :captured+mutated))
+ body
`((let ((,var (list ,var))) ,@body))))))
handlers))))
- (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers))
- 'unwind-protect))
- ,form . ,body)
- `(,head ,(cconv-convert form env extend)
+ (`(unwind-protect ,form . ,body)
+ `(unwind-protect ,(cconv-convert form env extend)
:fun-body ,(cconv--convert-function () body env form)))
(`(setq . ,forms) ; setq special form
@@ -563,9 +595,6 @@ places where they originally did not directly appear."
(_ (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))
(defvar byte-compile-lexical-variables)
(defun cconv--analyze-use (vardata form varkind)
@@ -578,29 +607,30 @@ FORM is the parent form that binds this var."
(`(,_ nil nil nil nil) nil)
(`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
+ ;; FIXME: Convert this warning to use `macroexp--warn-wrap'
+ ;; so as to give better position information and obey
+ ;; `byte-compile-warnings'.
(byte-compile-warn
- "%s `%S' not left unused" varkind var)))
+ "%s `%S' not left unused" varkind var))
+ ((and (let (or 'let* 'let) (car form))
+ `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
+ t nil ,_ ,_))
+ ;; FIXME: Convert this warning to use `macroexp--warn-wrap'
+ ;; so as to give better position information and obey
+ ;; `byte-compile-warnings'.
+ (unless (not (intern-soft var))
+ (byte-compile-warn "Variable `%S' left uninitialized" 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))
- (let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
- (byte-compile-warn "Unused lexical %s `%S'%s"
- varkind var
- (if suggestions (concat "\n " suggestions) "")))))
+ (`(,binder nil ,_ ,_ nil)
+ (push (cons (cons binder form) :unused) cconv-var-classification))
;; 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))
+ (push (cons (cons binder form) :captured+mutated)
+ cconv-var-classification))
(`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
- (push (cons binder form) cconv-lambda-candidates))))
+ (push (cons (cons binder form) :lambda-candidate)
+ cconv-var-classification))))
(defun cconv--analyze-function (args body env parentform)
(let* ((newvars nil)
@@ -653,8 +683,7 @@ Analyze lambdas if they are suitable for lambda lifting.
- 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."
+`cconv-var-classification' variable and updates the data stored in ENV."
(pcase form
; let special form
(`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms)
@@ -718,15 +747,6 @@ and updates the data stored in ENV."
(`(quote . ,_) nil) ; quote form
(`(function . ,_) nil) ; same as quote
- ((and `(condition-case ,var ,protected-form . ,handlers)
- (guard byte-compile--use-old-handlers))
- ;; FIXME: The bytecode for condition-case forces us to wrap the
- ;; form and handlers in closures.
- (cconv--analyze-function () (list protected-form) env form)
- (dolist (handler handlers)
- (cconv--analyze-function (if var (list var)) (cdr handler)
- env form)))
-
(`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
@@ -741,9 +761,7 @@ and updates the data stored in ENV."
form "variable"))))
;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind.
- (`(,(or (and 'catch (guard byte-compile--use-old-handlers))
- 'unwind-protect)
- ,form . ,body)
+ (`(unwind-protect ,form . ,body)
(cconv-analyze-form form env)
(cconv--analyze-function () body env form))
@@ -782,7 +800,7 @@ and updates the data stored in ENV."
(let ((dv (assq form env))) ; dv = declared and visible
(when dv
(setf (nth 1 dv) t))))))
-(define-obsolete-function-alias 'cconv-analyse-form 'cconv-analyze-form "25.1")
+(define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1")
(provide 'cconv)
;;; cconv.el ends here
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index d2d9807c0a0..0494497feaf 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -4,7 +4,7 @@
;; Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
+;; Old-Version: 0.2
;; Keywords: OO, chart, graph
;; This file is part of GNU Emacs.
@@ -67,9 +67,8 @@
(define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1")
(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.")
-(defvar chart-local-object nil
+(defvar-local chart-local-object nil
"Local variable containing the locally displayed chart object.")
-(make-variable-buffer-local 'chart-local-object)
(defvar chart-face-color-list '("red" "green" "blue"
"cyan" "yellow" "purple")
@@ -90,39 +89,43 @@ Useful if new Emacs is used on B&W display.")
(declare-function x-display-color-cells "xfns.c" (&optional terminal))
-(defvar chart-face-list
- (if (display-color-p)
- (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))
+(defvar chart-face-list #'chart--face-list
"Faces used to colorize charts.
+This should either be a list of faces, or a function that returns
+a list of faces.
+
List is limited currently, which is ok since you really can't display
too much in text characters anyways.")
+(defun chart--face-list ()
+ (and
+ (display-color-p)
+ (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)
+ (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)))
+
(define-derived-mode chart-mode special-mode "Chart"
"Define a mode in Emacs for displaying a chart."
(buffer-disable-undo)
- (set (make-local-variable 'font-lock-global-modes) nil)
+ (setq-local font-lock-global-modes nil)
(font-lock-mode -1) ;Isn't it off already? --Stef
)
@@ -190,7 +193,7 @@ Make sure the width/height is correct."
)
"Class used to display an axis which represents different named items.")
-(defclass chart-sequece ()
+(defclass chart-sequence ()
((data :initarg :data
:initform nil)
(name :initarg :name
@@ -200,7 +203,7 @@ Make sure the width/height is correct."
(defclass chart-bar (chart)
((direction :initarg :direction
- :initform vertical))
+ :initform 'vertical))
"Subclass for bar charts (vertical or horizontal).")
(cl-defmethod chart-draw ((c chart) &optional buff)
@@ -335,7 +338,8 @@ Automatically compensates for direction."
(cl-defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone _start _end)
"Draw axis information based upon A range to be spread along the edge.
Optional argument DIR is the direction of the chart.
-Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing."
+Optional arguments MARGIN, ZONE, START and END specify boundaries
+of the drawing."
(cl-call-next-method)
;; We prefer about 5 spaces between each value
(let* ((i 0)
@@ -376,7 +380,10 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing
(let* ((data (oref c sequences))
(dir (oref c direction))
(odir (if (eq dir 'vertical) 'horizontal 'vertical))
- )
+ (faces
+ (if (functionp chart-face-list)
+ (funcall chart-face-list)
+ chart-face-list)))
(while data
(if (stringp (car (oref (car data) data)))
;; skip string lists...
@@ -392,10 +399,9 @@ Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing
(zp (if (eq dir 'vertical)
(chart-translate-ypos c 0)
(chart-translate-xpos c 0)))
- (fc (if chart-face-list
- (nth (% i (length chart-face-list)) chart-face-list)
- 'default))
- )
+ (fc (if faces
+ (nth (% i (length faces)) faces)
+ 'default)))
(if (< dp zp)
(progn
(chart-draw-line dir (car rng) dp zp)
@@ -585,12 +591,12 @@ SORT-PRED if desired."
))
(iv (eq dir 'vertical)))
(chart-add-sequence nc
- (make-instance 'chart-sequece
+ (make-instance 'chart-sequence
:data namelst
:name nametitle)
(if iv 'x-axis 'y-axis))
(chart-add-sequence nc
- (make-instance 'chart-sequece
+ (make-instance 'chart-sequence
:data numlst
:name numtitle)
(if iv 'y-axis 'x-axis))
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index bea9df9e2b2..bec4ad92503 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -1,8 +1,9 @@
-;;; check-declare.el --- Check declare-function statements
+;;; check-declare.el --- Check declare-function statements -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Author: Glenn Morris <rgm@gnu.org>
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp, tools, maint
;; This file is part of GNU Emacs.
@@ -248,7 +249,7 @@ TYPE is a string giving the nature of the error.
Optional LINE is the claim's line number; otherwise, search for the claim.
Display warning in `check-declare-warning-buffer'."
(let ((warning-prefix-function
- (lambda (level entry)
+ (lambda (_level entry)
(insert (format "%s:%d:" (file-relative-name file) (or line 0)))
entry))
(warning-fill-prefix " "))
@@ -327,4 +328,4 @@ Returns non-nil if any false statements are found."
(provide 'check-declare)
-;;; check-declare.el ends here.
+;;; check-declare.el ends here
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index d82e86196ac..00cc7777e1a 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.6.2
+;; Old-Version: 0.6.2
;; Keywords: docs, maint, lisp
;; This file is part of GNU Emacs.
@@ -37,7 +37,6 @@
;; documentation whenever you evaluate Lisp code with C-M-x
;; or [menu-bar emacs-lisp eval-buffer]. Additional key-bindings
;; are also provided under C-c ? KEY
-;; (require 'checkdoc)
;; (add-hook 'emacs-lisp-mode-hook 'checkdoc-minor-mode)
;;
;; Using `checkdoc':
@@ -148,13 +147,6 @@
;;
;; See the above section "Checking Parameters" for details about
;; parameter checking.
-;;
-;; Dependencies:
-;;
-;; This file requires lisp-mnt (Lisp maintenance routines) for the
-;; comment checkers.
-;;
-;; Requires custom for Emacs v20.
;;; TO DO:
;; Hook into the byte compiler on a defun/defvar level to generate
@@ -168,8 +160,6 @@
;; not specifically docstring related. Would this even be useful?
;;; Code:
-(defvar checkdoc-version "0.6.2"
- "Release version of checkdoc you are currently running.")
(require 'cl-lib)
(require 'help-mode) ;; for help-xref-info-regexp
@@ -241,7 +231,12 @@ system. Possible values are:
defun - Spell-check when style checking a single defun.
buffer - Spell-check when style checking the whole buffer.
interactive - Spell-check during any interactive check.
- t - Always spell-check."
+ t - Always spell-check.
+
+There is a list of Lisp-specific words which checkdoc will
+install into Ispell on the fly, but only if Ispell is not already
+running. Use `ispell-kill-ispell' to make checkdoc restart it
+with these words enabled."
:type '(choice (const nil)
(const defun)
(const buffer)
@@ -933,16 +928,20 @@ don't move point."
;; Don't bug out if the file is empty (or a
;; definition ends prematurely.
(end-of-file)))
- (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice
- 'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro)
+ (`(,(and (pred symbolp) def
+ (let (and doc (guard doc)) (function-get def 'doc-string-elt)))
,(pred symbolp)
;; Require an initializer, i.e. ignore single-argument `defvar'
;; forms, which never have a doc string.
,_ . ,_)
(down-list)
- ;; Skip over function or macro name, symbol to be defined, and
- ;; initializer or argument list.
- (forward-sexp 3)
+ ;; Skip over function or macro name.
+ (forward-sexp 1)
+ ;; And now skip until the docstring.
+ (forward-sexp (1- ; We already skipped the function or macro name.
+ (cond
+ ((numberp doc) doc)
+ ((functionp doc) (funcall doc)))))
(skip-chars-forward " \n\t")
t)))
@@ -1243,18 +1242,13 @@ bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c
checking of documentation strings.
\\{checkdoc-minor-mode-map}"
- nil checkdoc-minor-mode-string nil
+ :lighter checkdoc-minor-mode-string
:group 'checkdoc)
;;; Subst utils
;;
-(defsubst checkdoc-run-hooks (hookvar &rest args)
- "Run hooks in HOOKVAR with ARGS."
- (if (fboundp 'run-hook-with-args-until-success)
- (apply #'run-hook-with-args-until-success hookvar args)
- ;; This method was similar to above. We ignore the warning
- ;; since we will use the above for future Emacs versions
- (apply #'run-hook-with-args hookvar args)))
+(define-obsolete-function-alias 'checkdoc-run-hooks
+ #'run-hook-with-args-until-success "28.1")
(defsubst checkdoc-create-common-verbs-regexp ()
"Rebuild the contents of `checkdoc-common-verbs-regexp'."
@@ -1577,7 +1571,8 @@ mouse-[0-3]\\)\\)\\>"))
;; a prefix.
(let ((disambiguate
(completing-read
- "Disambiguating Keyword (default variable): "
+ (format-prompt "Disambiguating Keyword"
+ "variable")
'(("function") ("command") ("variable")
("option") ("symbol"))
nil t nil nil "variable")))
@@ -1872,7 +1867,7 @@ Replace with \"%s\"? " original replace)
;; and reliance on the Ispell program.
(checkdoc-ispell-docstring-engine e take-notes)
;; User supplied checks
- (save-excursion (checkdoc-run-hooks 'checkdoc-style-functions fp e))
+ (save-excursion (run-hook-with-args-until-success 'checkdoc-style-functions fp e))
;; Done!
)))
@@ -2136,8 +2131,8 @@ buffer, otherwise stop after the first error."
(user-error "No spellchecker installed: check the variable `ispell-program-name'"))
(save-excursion
(skip-chars-forward "^a-zA-Z")
- (let (word sym case-fold-search err word-beginning word-end)
- (while (and (not err) (< (point) end))
+ (let (word sym case-fold-search word-beginning word-end) ;; err
+ (while (and (< (point) end)) ;; (not err)
(if (save-excursion (forward-char -1) (looking-at "[('`]"))
;; Skip lists describing meta-syntax, or bound variables
(forward-sexp 1)
@@ -2169,7 +2164,7 @@ buffer, otherwise stop after the first error."
(sit-for 0)
(message "Continuing..."))))))))
(skip-chars-forward "^a-zA-Z"))
- err))))
+ nil)))) ;; err
;;; Rogue space checking engine
;;
@@ -2361,7 +2356,9 @@ Code:, and others referenced in the style guide."
(checkdoc-create-error
(format "The footer should be: (provide '%s)\\n;;; %s%s ends here"
fn fn fe)
- (1- (point-max)) (point-max)))))
+ ;; The buffer may be empty.
+ (max (point-min) (1- (point-max)))
+ (point-max)))))
err))
;; The below checks will not return errors if the user says NO
@@ -2383,7 +2380,7 @@ Code:, and others referenced in the style guide."
err
(or
;; Generic Full-file checks (should be comment related)
- (checkdoc-run-hooks 'checkdoc-comment-style-functions)
+ (run-hook-with-args-until-success 'checkdoc-comment-style-functions)
err))
;; Done with full file comment checks
err)))
@@ -2592,7 +2589,7 @@ This function will not modify `match-data'."
;; going on.
(if checkdoc-bouncy-flag (message "%s -> done" question))
(delete-region start end)
- (insert replacewith)
+ (insert-before-markers replacewith)
(if checkdoc-bouncy-flag (sit-for 0))
(setq ret t)))
(delete-overlay o)
@@ -2642,7 +2639,7 @@ function called to create the messages."
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert "\n\n\C-l\n*** " label ": "
- check-type " V " checkdoc-version)))))
+ check-type)))))
(defun checkdoc-error (point msg)
"Store POINT and MSG as errors in the checkdoc diagnostic buffer."
@@ -2709,6 +2706,12 @@ function called to create the messages."
(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode)
+;; Obsolete
+
+(defvar checkdoc-version "0.6.2"
+ "Release version of checkdoc you are currently running.")
+(make-obsolete-variable 'checkdoc-version 'emacs-version "28.1")
+
(provide 'checkdoc)
;;; checkdoc.el ends here
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 9c9da4a0f90..3840d13ecff 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -72,8 +72,7 @@ strings case-insensitively."
(cond ((eq x y) t)
((stringp x)
(and (stringp y) (= (length x) (length y))
- (or (string-equal x y)
- (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
+ (eq (compare-strings x nil nil y nil nil t) t)))
((numberp x)
(and (numberp y) (= x y)))
((consp x)
@@ -95,7 +94,7 @@ strings case-insensitively."
(defun cl--mapcar-many (cl-func cl-seqs &optional acc)
(if (cdr (cdr cl-seqs))
(let* ((cl-res nil)
- (cl-n (apply 'min (mapcar 'length cl-seqs)))
+ (cl-n (apply #'min (mapcar #'length cl-seqs)))
(cl-i 0)
(cl-args (copy-sequence cl-seqs))
cl-p1 cl-p2)
@@ -132,7 +131,7 @@ strings case-insensitively."
"Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
TYPE is the sequence type to return.
\n(fn TYPE FUNCTION SEQUENCE...)"
- (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
+ (let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest)))
(and cl-type (cl-coerce cl-res cl-type))))
;;;###autoload
@@ -191,26 +190,29 @@ the elements themselves.
"Like `cl-mapcar', but nconc's together the values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(if cl-rest
- (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))
+ (apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest))
(mapcan cl-func cl-seq)))
;;;###autoload
(defun cl-mapcon (cl-func cl-list &rest cl-rest)
"Like `cl-maplist', but nconc's together the values returned by the function.
\n(fn FUNCTION LIST...)"
- (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
+ (apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest)))
;;;###autoload
(defun cl-some (cl-pred cl-seq &rest cl-rest)
- "Return true if PREDICATE is true of any element of SEQ or SEQs.
-If so, return the true (non-nil) value returned by PREDICATE.
+ "Say whether PREDICATE is true for any element in the SEQ sequences.
+More specifically, the return value of this function will be the
+same as the first return value of PREDICATE where PREDICATE has a
+non-nil value.
+
\n(fn PREDICATE SEQ...)"
(if (or cl-rest (nlistp cl-seq))
(catch 'cl-some
- (apply 'cl-map nil
- (function (lambda (&rest cl-x)
- (let ((cl-res (apply cl-pred cl-x)))
- (if cl-res (throw 'cl-some cl-res)))))
+ (apply #'cl-map nil
+ (lambda (&rest cl-x)
+ (let ((cl-res (apply cl-pred cl-x)))
+ (if cl-res (throw 'cl-some cl-res))))
cl-seq cl-rest) nil)
(let ((cl-x nil))
(while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
@@ -222,9 +224,9 @@ If so, return the true (non-nil) value returned by PREDICATE.
\n(fn PREDICATE SEQ...)"
(if (or cl-rest (nlistp cl-seq))
(catch 'cl-every
- (apply 'cl-map nil
- (function (lambda (&rest cl-x)
- (or (apply cl-pred cl-x) (throw 'cl-every nil))))
+ (apply #'cl-map nil
+ (lambda (&rest cl-x)
+ (or (apply cl-pred cl-x) (throw 'cl-every nil)))
cl-seq cl-rest) t)
(while (and cl-seq (funcall cl-pred (car cl-seq)))
(setq cl-seq (cdr cl-seq)))
@@ -234,27 +236,26 @@ If so, return the true (non-nil) value returned by PREDICATE.
(defun cl-notany (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
- (not (apply 'cl-some cl-pred cl-seq cl-rest)))
+ (not (apply #'cl-some cl-pred cl-seq cl-rest)))
;;;###autoload
(defun cl-notevery (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of some element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
- (not (apply 'cl-every cl-pred cl-seq cl-rest)))
+ (not (apply #'cl-every cl-pred cl-seq cl-rest)))
;;;###autoload
(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
(or cl-base
(setq cl-base (copy-sequence [0])))
(map-keymap
- (function
- (lambda (cl-key cl-bind)
- (aset cl-base (1- (length cl-base)) cl-key)
- (if (keymapp cl-bind)
- (cl--map-keymap-recursively
- cl-func-rec cl-bind
- (vconcat cl-base (list 0)))
- (funcall cl-func-rec cl-base cl-bind))))
+ (lambda (cl-key cl-bind)
+ (aset cl-base (1- (length cl-base)) cl-key)
+ (if (keymapp cl-bind)
+ (cl--map-keymap-recursively
+ cl-func-rec cl-bind
+ (vconcat cl-base (list 0)))
+ (funcall cl-func-rec cl-base cl-bind)))
cl-map))
;;;###autoload
@@ -553,10 +554,9 @@ too large if positive or too small if negative)."
(seq-subseq seq start end))
;;;###autoload
-(defun cl-concatenate (type &rest sequences)
+(defalias 'cl-concatenate #'seq-concatenate
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
-\n(fn TYPE SEQUENCE...)"
- (apply #'seq-concatenate type sequences))
+\n(fn TYPE SEQUENCE...)")
;;; List functions.
@@ -693,12 +693,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
"Expand macros in FORM and insert the pretty-printed result."
(declare (advertised-calling-convention (form) "27.1"))
(message "Expanding...")
- (let ((byte-compile-macro-environment nil))
- (setq form (macroexpand-all form))
- (message "Formatting...")
- (prog1
- (cl-prettyprint form)
- (message ""))))
+ (setq form (macroexpand-all form))
+ (message "Formatting...")
+ (prog1
+ (cl-prettyprint form)
+ (message "")))
;;; Integration into the online help system.
@@ -848,7 +847,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
"\n")))
"\n"))
-(defun cl--print-table (header rows)
+(defun cl--print-table (header rows &optional last-slot-on-next-line)
;; FIXME: Isn't this functionality already implemented elsewhere?
(let ((cols (apply #'vector (mapcar #'string-width header)))
(col-space 2))
@@ -878,7 +877,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
header))
"\n")
(dolist (row rows)
- (insert (apply #'format format row) "\n"))))))
+ (insert (apply #'format format row) "\n")
+ (when last-slot-on-next-line
+ (dolist (line (string-lines (car (last row))))
+ (insert " " line "\n"))
+ (insert "\n")))))))
(defun cl--describe-class-slots (class)
"Print help description for the slots in CLASS.
@@ -904,14 +907,15 @@ Outputs to the current buffer."
(setq has-doc t)
(substitute-command-keys doc)))))
slots)))
- (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc")))
- slots-strings))
+ (cl--print-table `("Name" "Type" "Default") slots-strings has-doc))
(insert "\n")
(when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
(mapc #'cl--describe-class-slot cslots))))
+(make-obsolete-variable 'cl-extra-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'cl-extra-load-hook)
;; Local variables:
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 9dbcadec3ce..544704be387 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
(setf (cl--generic name) (setq generic (cl--generic-make name))))
generic))
+(defvar cl--generic-edebug-name nil)
+
+(defun cl--generic-edebug-remember-name (name pf &rest specs)
+ ;; Remember the name in `cl-defgeneric' so we can use it when building
+ ;; the names of its `:methods'.
+ (let ((cl--generic-edebug-name (car name)))
+ (funcall pf specs)))
+
+(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args)
+ ;; The name to use in Edebug for a method: use the generic
+ ;; function's name plus all its qualifiers and finish with
+ ;; its specializers.
+ (pcase-let*
+ ((basename (if in:method cl--generic-edebug-name (pop quals-and-args)))
+ (args (car (last quals-and-args)))
+ (`(,spec-args . ,_) (cl--generic-split-args args))
+ (specializers (mapcar (lambda (spec-arg)
+ (if (eq '&context (car-safe (car spec-arg)))
+ spec-arg (cdr spec-arg)))
+ spec-args)))
+ (format "%s %s"
+ (mapconcat (lambda (sexp) (format "%s" sexp))
+ (cons basename (butlast quals-and-args))
+ " ")
+ specializers)))
+
;;;###autoload
(defmacro cl-defgeneric (name args &rest options-and-methods)
"Create a generic function NAME.
@@ -206,15 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method.
\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
(declare (indent 2) (doc-string 3)
(debug
- (&define [&or name ("setf" name :name setf)] listp
- lambda-doc
- [&rest [&or
- ("declare" &rest sexp)
- (":argument-precedence-order" &rest sexp)
- (&define ":method" [&rest atom]
- cl-generic-method-args lambda-doc
- def-body)]]
- def-body)))
+ (&define
+ &interpose
+ [&name sexp] ;Allow (setf ...) additionally to symbols.
+ cl--generic-edebug-remember-name
+ listp lambda-doc
+ [&rest [&or
+ ("declare" &rest sexp)
+ (":argument-precedence-order" &rest sexp)
+ (&define ":method"
+ [&name
+ [[&rest cl-generic--method-qualifier-p]
+ listp] ;Formal args
+ cl--generic-edebug-make-name in:method]
+ lambda-doc
+ def-body)]]
+ def-body)))
(let* ((doc (if (stringp (car-safe options-and-methods))
(pop options-and-methods)))
(declarations nil)
@@ -295,15 +328,6 @@ the specializer used will be the one returned by BODY."
(lambda ,args ,@body))))
(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
- (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
- "Check which of the symbols VARS appear in SEXP."
- (let ((res '()))
- (while (consp sexp)
- (dolist (var (cl--generic-fgrep vars (pop sexp)))
- (unless (memq var res) (push var res))))
- (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
- res))
-
(defun cl--generic-split-args (args)
"Return (SPEC-ARGS . PLAIN-ARGS)."
(let ((plain-args ())
@@ -366,11 +390,11 @@ the specializer used will be the one returned by BODY."
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
+ (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
(cons (not (not uses-cnm))
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
,@(car parsed-body)
- ,(if (not (memq nmp uses-cnm))
+ ,(if (not (assq nmp uses-cnm))
nbody
`(let ((,nmp (lambda ()
(cl--generic-isnot-nnm-p ,cnm))))
@@ -398,18 +422,45 @@ the specializer used will be the one returned by BODY."
(let ((combined-doc (buffer-string)))
(if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
+(defun cl-generic--method-qualifier-p (x)
+ (not (listp x)))
+
+(defun cl--defmethod-doc-pos ()
+ "Return the index of the docstring for a `cl-defmethod'.
+Presumes point is at the end of the `cl-defmethod' symbol."
+ (save-excursion
+ (let ((n 2))
+ (while (and (ignore-errors (forward-sexp 1) t)
+ (not (eq (char-before) ?\))))
+ (cl-incf n))
+ n)))
+
;;;###autoload
(defmacro cl-defmethod (name args &rest body)
"Define a new method for generic function NAME.
-I.e. it defines the implementation of NAME to use for invocations where the
-values of the dispatch arguments match the specified TYPEs.
+This defines an implementation of NAME to use for invocations
+of specific types of arguments.
+
+ARGS is a list of dispatch arguments (see `cl-defun'), but where
+each variable element is either just a single variable name VAR,
+or a list on the form (VAR TYPE).
+
+For instance:
+
+ (cl-defmethod foo (bar (format-string string) &optional zot)
+ (format format-string bar))
+
The dispatch arguments have to be among the mandatory arguments, and
all methods of NAME have to use the same set of arguments for dispatch.
Each dispatch argument and TYPE are specified in ARGS where the corresponding
formal argument appears as (VAR TYPE) rather than just VAR.
-The optional second argument QUALIFIER is a specifier that
-modifies how the method is combined with other methods, including:
+The optional EXTRA element, on the form `:extra STRING', allows
+you to add more methods for the same specializers and qualifiers.
+These are distinguished by STRING.
+
+The optional argument QUALIFIER is a specifier that modifies how
+the method is combined with other methods, including:
:before - Method will be called before the primary
:after - Method will be called after the primary
:around - Method will be called around everything else
@@ -426,20 +477,18 @@ method to be applicable.
The set of acceptable TYPEs (also called \"specializers\") is defined
\(and can be extended) by the various methods of `cl-generic-generalizers'.
-\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
- (declare (doc-string 3) (indent defun)
+\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
+ (declare (doc-string cl--defmethod-doc-pos) (indent defun)
(debug
(&define ; this means we are defining something
- [&or name ("setf" name :name setf)]
- ;; ^^ This is the methods symbol
- [ &rest atom ] ; Multiple qualifiers are allowed.
- ; Like in CLOS spec, we support
- ; any non-list values.
- cl-generic-method-args ; arguments
+ [&name [sexp ;Allow (setf ...) additionally to symbols.
+ [&rest cl-generic--method-qualifier-p] ;qualifiers
+ listp] ; arguments
+ cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
- (while (not (listp args))
+ (while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
(when (eq 'setf (car-safe name))
@@ -452,7 +501,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
@@ -519,17 +568,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(cons method mt)
;; Keep the ordering; important for methods with :extra qualifiers.
(mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
- (let ((sym (cl--generic-name generic))) ; Actual name (for aliases).
+ (let ((sym (cl--generic-name generic)) ; Actual name (for aliases).
+ ;; FIXME: Try to avoid re-constructing a new function if the old one
+ ;; is still valid (e.g. still empty method cache)?
+ (gfun (cl--generic-make-function generic)))
(unless (symbol-function sym)
(defalias sym 'dummy)) ;Record definition into load-history.
(cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format
(cl--generic-name generic)
qualifiers specializers))
current-load-list :test #'equal)
- ;; FIXME: Try to avoid re-constructing a new function if the old one
- ;; is still valid (e.g. still empty method cache)?
- (let ((gfun (cl--generic-make-function generic))
- ;; Prevent `defalias' from recording this as the definition site of
+ (let (;; Prevent `defalias' from recording this as the definition site of
;; the generic function.
current-load-list
;; BEWARE! Don't purify this function definition, since that leads
@@ -599,11 +648,11 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(lambda (,@fixedargs &rest args)
(let ,bindings
(apply (cl--generic-with-memoization
- (gethash ,tag-exp method-cache)
- (cl--generic-cache-miss
- generic ',dispatch-arg dispatches-left methods
- ,(if (cdr typescodes)
- `(append ,@typescodes) (car typescodes))))
+ (gethash ,tag-exp method-cache)
+ (cl--generic-cache-miss
+ generic ',dispatch-arg dispatches-left methods
+ ,(if (cdr typescodes)
+ `(append ,@typescodes) (car typescodes))))
,@fixedargs args)))))))))
(defun cl--generic-make-function (generic)
@@ -793,8 +842,8 @@ It should return a function that expects the same arguments as the methods, and
GENERIC is the generic function (mostly used for its name).
METHODS is the list of the selected methods.
The METHODS list is sorted from most specific first to most generic last.
-The function can use `cl-generic-call-method' to create functions that call those
-methods.")
+The function can use `cl-generic-call-method' to create functions that call
+those methods.")
(unless (ignore-errors (cl-generic-generalizers t))
;; Temporary definition to let the next defmethod succeed.
@@ -1092,7 +1141,8 @@ These match if the argument is a cons cell whose car is `eql' to VAL."
(if (not (eq (car-safe specializer) 'head))
(cl-call-next-method)
(cl--generic-with-memoization
- (gethash (cadr specializer) cl--generic-head-used) specializer)
+ (gethash (cadr specializer) cl--generic-head-used)
+ specializer)
(list cl--generic-head-generalizer)))
(cl--generic-prefill-dispatchers 0 (head eql))
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index a26598fab33..c88e15d5a8b 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -27,7 +27,7 @@
;; This package supplies a single entry point, common-lisp-indent-function,
;; which performs indentation in the preferred style for Common Lisp code.
-;; It is also a suitable function for indenting Emacs lisp code.
+;; It is also a suitable function for indenting Emacs Lisp code.
;;
;; To enable it:
;;
@@ -46,14 +46,12 @@
"Maximum depth to backtrack out from a sublist for structured indentation.
If this variable is 0, no backtracking will occur and forms such as `flet'
may not be correctly indented."
- :type 'integer
- :group 'lisp-indent)
+ :type 'integer)
(defcustom lisp-tag-indentation 1
"Indentation of tags relative to containing list.
This variable is used by the function `lisp-indent-tagbody'."
- :type 'integer
- :group 'lisp-indent)
+ :type 'integer)
(defcustom lisp-tag-body-indentation 3
"Indentation of non-tagged lines relative to containing list.
@@ -64,32 +62,30 @@ the special form. If the value is t, the body of tags will be indented
as a block at the same indentation as the first s-expression following
the tag. In this case, any forms before the first tag are indented
by `lisp-body-indent'."
- :type 'integer
- :group 'lisp-indent)
+ :type 'integer)
(defcustom lisp-backquote-indentation t
"Whether or not to indent backquoted lists as code.
If nil, indent backquoted lists as data, i.e., like quoted lists."
- :type 'boolean
- :group 'lisp-indent)
+ :type 'boolean)
-(defcustom lisp-loop-keyword-indentation 3
+(defcustom lisp-loop-keyword-indentation 6
"Indentation of loop keywords in extended loop forms."
:type 'integer
- :group 'lisp-indent)
+ :version "28.1")
-(defcustom lisp-loop-forms-indentation 5
+(defcustom lisp-loop-forms-indentation 6
"Indentation of forms in extended loop forms."
:type 'integer
- :group 'lisp-indent)
+ :version "28.1")
-(defcustom lisp-simple-loop-indentation 3
+(defcustom lisp-simple-loop-indentation 1
"Indentation of forms in simple loop forms."
:type 'integer
- :group 'lisp-indent)
+ :version "28.1")
(defcustom lisp-lambda-list-keyword-alignment nil
"Whether to vertically align lambda-list keywords together.
@@ -107,16 +103,14 @@ If non-nil, alignment is done with the first keyword
&key key1 key2)
#|...|#)"
:version "24.1"
- :type 'boolean
- :group 'lisp-indent)
+ :type 'boolean)
(defcustom lisp-lambda-list-keyword-parameter-indentation 2
"Indentation of lambda list keyword parameters.
See `lisp-lambda-list-keyword-parameter-alignment'
for more information."
:version "24.1"
- :type 'integer
- :group 'lisp-indent)
+ :type 'integer)
(defcustom lisp-lambda-list-keyword-parameter-alignment nil
"Whether to vertically align lambda-list keyword parameters together.
@@ -135,8 +129,7 @@ If non-nil, alignment is done with the first parameter
key3 key4)
#|...|#)"
:version "24.1"
- :type 'boolean
- :group 'lisp-indent)
+ :type 'boolean)
(defcustom lisp-indent-backquote-substitution-mode t
"How to indent substitutions in backquotes.
@@ -148,8 +141,7 @@ In any case, do not backtrack beyond a backquote substitution.
Until Emacs 25.1, the nil behavior was hard-wired."
:version "25.1"
- :type '(choice (const corrected) (const nil) (const t))
- :group 'lisp-indent)
+ :type '(choice (const corrected) (const nil) (const t)))
(defvar lisp-indent-defun-method '(4 &lambda &body)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index b669ee9981a..317a4c62309 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -140,7 +140,7 @@ to an element already in the list stored in PLACE.
\n(fn X PLACE [KEYWORD VALUE]...)"
(declare (debug
(form place &rest
- &or [[&or ":test" ":test-not" ":key"] function-form]
+ &or [[&or ":test" ":test-not" ":key"] form]
[keywordp form])))
(if (symbolp place)
(if (null keys)
@@ -232,13 +232,8 @@ one value.
;;; Declarations.
-(defvar cl--compiling-file nil)
-(defun cl--compiling-file ()
- (or cl--compiling-file
- (and (boundp 'byte-compile--outbuffer)
- (bufferp (symbol-value 'byte-compile--outbuffer))
- (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
- " *Compiler Output*"))))
+(define-obsolete-function-alias 'cl--compiling-file
+ #'macroexp-compiling-p "28.1")
(defvar cl--proclaims-deferred nil)
@@ -253,7 +248,7 @@ one value.
Puts `(cl-eval-when (compile load eval) ...)' around the declarations
so that they are registered at compile-time as well as run-time."
(let ((body (mapcar (lambda (x) `(cl-proclaim ',x)) specs)))
- (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body)
+ (if (macroexp-compiling-p) `(cl-eval-when (compile load eval) ,@body)
`(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when.
@@ -520,108 +515,6 @@ the process stops as soon as KEYS or VALUES run out.
If ALIST is non-nil, the new pairs are prepended to it."
(nconc (cl-mapcar 'cons keys values) alist))
-;;; Generalized variables.
-
-;; These used to be in cl-macs.el since all macros that use them (like setf)
-;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in
-;; core Elisp, they need to either be right here or be autoloaded via
-;; cl-loaddefs.el, which is more trouble than it is worth.
-
-;; Some more Emacs-related place types.
-(gv-define-simple-setter buffer-file-name set-visited-file-name t)
-(gv-define-setter buffer-modified-p (flag &optional buf)
- (macroexp-let2 nil buffer `(or ,buf (current-buffer))
- `(with-current-buffer ,buffer
- (set-buffer-modified-p ,flag))))
-(gv-define-simple-setter buffer-name rename-buffer t)
-(gv-define-setter buffer-string (store)
- `(insert (prog1 ,store (erase-buffer))))
-(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
-(gv-define-simple-setter current-buffer set-buffer)
-(gv-define-simple-setter current-column move-to-column t)
-(gv-define-simple-setter current-global-map use-global-map t)
-(gv-define-setter current-input-mode (store)
- `(progn (apply #'set-input-mode ,store) ,store))
-(gv-define-simple-setter current-local-map use-local-map t)
-(gv-define-simple-setter current-window-configuration
- set-window-configuration t)
-(gv-define-simple-setter default-file-modes set-default-file-modes t)
-(gv-define-simple-setter documentation-property put)
-(gv-define-setter face-background (x f &optional s)
- `(set-face-background ,f ,x ,s))
-(gv-define-setter face-background-pixmap (x f &optional s)
- `(set-face-background-pixmap ,f ,x ,s))
-(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s))
-(gv-define-setter face-foreground (x f &optional s)
- `(set-face-foreground ,f ,x ,s))
-(gv-define-setter face-underline-p (x f &optional s)
- `(set-face-underline ,f ,x ,s))
-(gv-define-simple-setter file-modes set-file-modes t)
-(gv-define-setter frame-height (x &optional frame)
- `(set-frame-height (or ,frame (selected-frame)) ,x))
-(gv-define-simple-setter frame-parameters modify-frame-parameters t)
-(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
-(gv-define-setter frame-width (x &optional frame)
- `(set-frame-width (or ,frame (selected-frame)) ,x))
-(gv-define-simple-setter getenv setenv t)
-(gv-define-simple-setter get-register set-register)
-(gv-define-simple-setter global-key-binding global-set-key)
-(gv-define-simple-setter local-key-binding local-set-key)
-(gv-define-simple-setter mark set-mark t)
-(gv-define-simple-setter mark-marker set-mark t)
-(gv-define-simple-setter marker-position set-marker t)
-(gv-define-setter mouse-position (store scr)
- `(set-mouse-position ,scr (car ,store) (cadr ,store)
- (cddr ,store)))
-(gv-define-simple-setter point goto-char)
-(gv-define-simple-setter point-marker goto-char t)
-(gv-define-setter point-max (store)
- `(progn (narrow-to-region (point-min) ,store) ,store))
-(gv-define-setter point-min (store)
- `(progn (narrow-to-region ,store (point-max)) ,store))
-(gv-define-setter read-mouse-position (store scr)
- `(set-mouse-position ,scr (car ,store) (cdr ,store)))
-(gv-define-simple-setter screen-height set-screen-height t)
-(gv-define-simple-setter screen-width set-screen-width t)
-(gv-define-simple-setter selected-window select-window)
-(gv-define-simple-setter selected-screen select-screen)
-(gv-define-simple-setter selected-frame select-frame)
-(gv-define-simple-setter standard-case-table set-standard-case-table)
-(gv-define-simple-setter syntax-table set-syntax-table)
-(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t)
-(gv-define-setter window-height (store)
- `(progn (enlarge-window (- ,store (window-height))) ,store))
-(gv-define-setter window-width (store)
- `(progn (enlarge-window (- ,store (window-width)) t) ,store))
-(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
-
-;; More complex setf-methods.
-
-;; 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.
-;; It turned out that :variable needed more flexibility anyway, so
-;; this doesn't seem too useful now.
-(gv-define-expander eq
- (lambda (do place val)
- (gv-letplace (getter setter) place
- (macroexp-let2 nil val val
- (funcall do `(eq ,getter ,val)
- (lambda (v)
- `(cond
- (,v ,(funcall setter val))
- ((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
-
-(gv-define-expander substring
- (lambda (do place from &optional to)
- (gv-letplace (getter setter) place
- (macroexp-let2* nil ((start from) (end to))
- (funcall do `(substring ,getter ,start ,end)
- (lambda (v)
- (funcall setter `(cl--set-substring
- ,getter ,start ,end ,v))))))))
-
;;; Miscellaneous.
(provide 'cl-lib)
@@ -660,6 +553,7 @@ This can be needed when using code byte-compiled using the old
macro-expansion of `cl-defstruct' that used vectors objects instead
of record objects."
:global t
+ :group 'tools
(cond
(cl-old-struct-compat-mode
(advice-add 'type-of :around #'cl--old-struct-type-of))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 339e4998dd6..caf8bba2f8c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -75,7 +75,7 @@
;; one, you may want to amend the other, too.
;;;###autoload
(define-obsolete-function-alias 'cl--compiler-macro-cXXr
- 'internal--compiler-macro-cXXr "25.1")
+ #'internal--compiler-macro-cXXr "25.1")
;;; Some predicates for analyzing Lisp forms.
;; These are used by various
@@ -186,43 +186,43 @@ The name is made by appending a number to PREFIX, default \"T\"."
;;; Program structure.
-(def-edebug-spec cl-declarations
- (&rest ("cl-declare" &rest sexp)))
+(def-edebug-elem-spec 'cl-declarations
+ '(&rest ("cl-declare" &rest sexp)))
-(def-edebug-spec cl-declarations-or-string
- (&or lambda-doc cl-declarations))
+(def-edebug-elem-spec 'cl-declarations-or-string
+ '(lambda-doc &or ("declare" def-declarations) cl-declarations))
-(def-edebug-spec cl-lambda-list
- (([&rest cl-lambda-arg]
+(def-edebug-elem-spec 'cl-lambda-list
+ '(([&rest cl-lambda-arg]
[&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
[&optional ["&rest" cl-lambda-arg]]
[&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
&optional "&allow-other-keys"]]
[&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
+ &or (cl-lambda-arg &optional def-form) arg]]
. [&or arg nil])))
-(def-edebug-spec cl-&optional-arg
- (&or (cl-lambda-arg &optional def-form arg) arg))
+(def-edebug-elem-spec 'cl-&optional-arg
+ '(&or (cl-lambda-arg &optional def-form arg) arg))
-(def-edebug-spec cl-&key-arg
- (&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg))
+(def-edebug-elem-spec 'cl-&key-arg
+ '(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg))
-(def-edebug-spec cl-lambda-arg
- (&or arg cl-lambda-list1))
+(def-edebug-elem-spec 'cl-lambda-arg
+ '(&or arg cl-lambda-list1))
-(def-edebug-spec cl-lambda-list1
- (([&optional ["&whole" arg]] ;; only allowed at lower levels
- [&rest cl-lambda-arg]
- [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
- [&optional ["&rest" cl-lambda-arg]]
- [&optional ["&key" cl-&key-arg &rest cl-&key-arg
- &optional "&allow-other-keys"]]
- [&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
- . [&or arg nil])))
+(def-edebug-elem-spec 'cl-lambda-list1
+ '(([&optional ["&whole" arg]] ;; only allowed at lower levels
+ [&rest cl-lambda-arg]
+ [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
+ [&optional ["&rest" cl-lambda-arg]]
+ [&optional ["&key" cl-&key-arg &rest cl-&key-arg
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (cl-lambda-arg &optional def-form) arg]]
+ . [&or arg nil])))
-(def-edebug-spec cl-type-spec sexp)
+(def-edebug-elem-spec 'cl-type-spec '(sexp))
(defconst cl--lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
@@ -328,8 +328,7 @@ FORM is of the form (ARGS . BODY)."
(setq cl--bind-lets (nreverse cl--bind-lets))
;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets))))
(list '&rest (car (pop cl--bind-lets))))))))
- `(nil
- (,@(nreverse simple-args) ,@rest-args)
+ `((,@(nreverse simple-args) ,@rest-args)
,@header
,(macroexp-let* cl--bind-lets
(macroexp-progn
@@ -359,16 +358,14 @@ more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
- (&define [&or name ("setf" :name setf name)]
+ (&define [&name sexp] ;Allow (setf ...) additionally to symbols.
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
def-body))
(doc-string 3)
(indent 2))
- (let* ((res (cl--transform-lambda (cons args body) name))
- (form `(defun ,name ,@(cdr res))))
- (if (car res) `(progn ,(car res) ,form) form)))
+ `(defun ,name ,@(cl--transform-lambda (cons args body) name)))
;;;###autoload
(defmacro cl-iter-defun (name args &rest body)
@@ -379,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as iter-defun but use cl-lambda-list.
- (&define [&or name ("setf" :name setf name)]
+ (&define [&name sexp] ;Allow (setf ...) additionally to symbols.
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@@ -387,47 +384,45 @@ and BODY is implicitly surrounded by (cl-block NAME ...).
(doc-string 3)
(indent 2))
(require 'generator)
- (let* ((res (cl--transform-lambda (cons args body) name))
- (form `(iter-defun ,name ,@(cdr res))))
- (if (car res) `(progn ,(car res) ,form) form)))
+ `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name)))
;; The lambda list for macros is different from that of normal lambdas.
;; Note that &environment is only allowed as first or last items in the
;; top level list.
-(def-edebug-spec cl-macro-list
- (([&optional "&environment" arg]
- [&rest cl-macro-arg]
- [&optional ["&optional" &rest
- &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
- [&optional [[&or "&rest" "&body"] cl-macro-arg]]
- [&optional ["&key" [&rest
- [&or ([&or (symbolp cl-macro-arg) arg]
- &optional def-form cl-macro-arg)
- arg]]
- &optional "&allow-other-keys"]]
- [&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
- [&optional "&environment" arg]
- )))
-
-(def-edebug-spec cl-macro-arg
- (&or arg cl-macro-list1))
-
-(def-edebug-spec cl-macro-list1
- (([&optional "&whole" arg] ;; only allowed at lower levels
- [&rest cl-macro-arg]
- [&optional ["&optional" &rest
- &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
- [&optional [[&or "&rest" "&body"] cl-macro-arg]]
- [&optional ["&key" [&rest
- [&or ([&or (symbolp cl-macro-arg) arg]
- &optional def-form cl-macro-arg)
- arg]]
- &optional "&allow-other-keys"]]
- [&optional ["&aux" &rest
- &or (symbolp &optional def-form) symbolp]]
- . [&or arg nil])))
+(def-edebug-elem-spec 'cl-macro-list
+ '(([&optional "&environment" arg]
+ [&rest cl-macro-arg]
+ [&optional ["&optional" &rest
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ [&optional [[&or "&rest" "&body"] cl-macro-arg]]
+ [&optional ["&key" [&rest
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (cl-macro-arg &optional def-form) arg]]
+ [&optional "&environment" arg]
+ )))
+
+(def-edebug-elem-spec 'cl-macro-arg
+ '(&or arg cl-macro-list1))
+
+(def-edebug-elem-spec 'cl-macro-list1
+ '(([&optional "&whole" arg] ;; only allowed at lower levels
+ [&rest cl-macro-arg]
+ [&optional ["&optional" &rest
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ [&optional [[&or "&rest" "&body"] cl-macro-arg]]
+ [&optional ["&key" [&rest
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (cl-macro-arg &optional def-form) arg]]
+ . [&or arg nil])))
;;;###autoload
(defmacro cl-defmacro (name args &rest body)
@@ -455,23 +450,21 @@ more details.
(&define name cl-macro-list cl-declarations-or-string def-body))
(doc-string 3)
(indent 2))
- (let* ((res (cl--transform-lambda (cons args body) name))
- (form `(defmacro ,name ,@(cdr res))))
- (if (car res) `(progn ,(car res) ,form) form)))
+ `(defmacro ,name ,@(cl--transform-lambda (cons args body) name)))
-(def-edebug-spec cl-lambda-expr
- (&define ("lambda" cl-lambda-list
- cl-declarations-or-string
- [&optional ("interactive" interactive)]
- def-body)))
+(def-edebug-elem-spec 'cl-lambda-expr
+ '(&define ("lambda" cl-lambda-list
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
+ def-body)))
;; Redefine function-form to also match cl-function
-(def-edebug-spec function-form
+(def-edebug-elem-spec 'function-form
;; form at the end could also handle "function",
;; but recognize it specially to avoid wrapping function forms.
- (&or ([&or "quote" "function"] &or symbolp lambda-expr)
- ("cl-function" cl-function)
- form))
+ '(&or ([&or "quote" "function"] &or symbolp lambda-expr)
+ ("cl-function" cl-function)
+ form))
;;;###autoload
(defmacro cl-function (func)
@@ -480,9 +473,7 @@ Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
(declare (debug (&or symbolp cl-lambda-expr)))
(if (eq (car-safe func) 'lambda)
- (let* ((res (cl--transform-lambda (cdr func) 'cl-none))
- (form `(function (lambda . ,(cdr res)))))
- (if (car res) `(progn ,(car res) ,form) form))
+ `(function (lambda . ,(cl--transform-lambda (cdr func) 'cl-none)))
`(function ,func)))
(defun cl--make-usage-var (x)
@@ -554,7 +545,7 @@ its argument list allows full Common Lisp conventions."
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((restarg (memq '&rest args))
- (safety (if (cl--compiling-file) cl--optimize-safety 3))
+ (safety (if (macroexp-compiling-p) cl--optimize-safety 3))
(keys t)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
@@ -574,7 +565,7 @@ its argument list allows full Common Lisp conventions."
,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
- (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
+ (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car-safe)
restarg)))
(cl--do-arglist
(pop args)
@@ -718,36 +709,36 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug (sexp body)))
- (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
+ (if (and (macroexp-compiling-p)
(not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge.
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(cl--not-toplevel t))
(if (or (memq 'load when) (memq :load-toplevel when))
- (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
+ (if comp (cons 'progn (mapcar #'cl--compile-time-too body))
`(if nil nil ,@body))
- (progn (if comp (eval (cons 'progn body))) nil)))
+ (progn (if comp (eval (cons 'progn body) lexical-binding)) nil)))
(and (or (memq 'eval when) (memq :execute when))
(cons 'progn body))))
(defun cl--compile-time-too (form)
(or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
(setq form (macroexpand
- form (cons '(cl-eval-when) byte-compile-macro-environment))))
+ form (cons '(cl-eval-when) macroexpand-all-environment))))
(cond ((eq (car-safe form) 'progn)
- (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
+ (cons 'progn (mapcar #'cl--compile-time-too (cdr form))))
((eq (car-safe form) 'cl-eval-when)
(let ((when (nth 1 form)))
(if (or (memq 'eval when) (memq :execute when))
`(cl-eval-when (compile ,@when) ,@(cddr form))
form)))
- (t (eval form) form)))
+ (t (eval form lexical-binding) form)))
;;;###autoload
(defmacro cl-load-time-value (form &optional _read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(declare (debug (form &optional sexp)))
- (if (cl--compiling-file)
+ (if (macroexp-compiling-p)
(let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(setq ,temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
@@ -766,7 +757,7 @@ The result of the body appears to the compiler as a quoted constant."
;; temp is set before we use it.
(print set byte-compile--outbuffer))
temp)
- `',(eval form)))
+ `',(eval form lexical-binding)))
;;; Conditional control structures.
@@ -828,16 +819,15 @@ final clause, and matches if no other keys match.
(cons
'cond
(mapcar
- (function
- (lambda (c)
- (cons (cond ((eq (car c) 'otherwise) t)
- ((eq (car c) 'cl--ecase-error-flag)
- `(error "cl-etypecase failed: %s, %s"
- ,temp ',(reverse type-list)))
- (t
- (push (car c) type-list)
- `(cl-typep ,temp ',(car c))))
- (or (cdr c) '(nil)))))
+ (lambda (c)
+ (cons (cond ((eq (car c) 'otherwise) t)
+ ((eq (car c) 'cl--ecase-error-flag)
+ `(error "cl-etypecase failed: %s, %s"
+ ,temp ',(reverse type-list)))
+ (t
+ (push (car c) type-list)
+ `(cl-typep ,temp ',(car c))))
+ (or (cdr c) '(nil))))
clauses)))))
;;;###autoload
@@ -889,7 +879,7 @@ This is compatible with Common Lisp, but note that `defun' and
;;; The "cl-loop" macro.
(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
-(defvar cl--loop-bindings) (defvar cl--loop-body)
+(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions)
(defvar cl--loop-finally)
(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop?
(defvar cl--loop-first-flag)
@@ -910,7 +900,8 @@ This is compatible with Common Lisp, but note that `defun' and
"The Common Lisp `loop' macro.
Valid clauses include:
For clauses:
- for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 [by EXPR3]
+ for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2
+ [by EXPR3]
for VAR = EXPR1 then EXPR2
for VAR in/on/in-ref LIST [by FUNC]
for VAR across/across-ref ARRAY
@@ -950,7 +941,8 @@ For more details, see Info node `(cl)Loop Facility'.
"above" "below" "by" "in" "on" "=" "across"
"repeat" "while" "until" "always" "never"
"thereis" "collect" "append" "nconc" "sum"
- "count" "maximize" "minimize" "if" "unless"
+ "count" "maximize" "minimize"
+ "if" "when" "unless"
"return"]
form]
["using" (symbolp symbolp)]
@@ -966,7 +958,8 @@ For more details, see Info node `(cl)Loop Facility'.
(cl--loop-accum-var nil) (cl--loop-accum-vars nil)
(cl--loop-initially nil) (cl--loop-finally nil)
(cl--loop-iterator-function nil) (cl--loop-first-flag nil)
- (cl--loop-symbol-macs nil))
+ (cl--loop-symbol-macs nil)
+ (cl--loop-conditions nil))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
;;
@@ -1034,6 +1027,13 @@ For more details, see Info node `(cl)Loop Facility'.
(list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
`(cl-block ,cl--loop-name ,@body)))))
+(defmacro cl--push-clause-loop-body (clause)
+ "Apply CLAUSE to both `cl--loop-conditions' and `cl--loop-body'."
+ (macroexp-let2 nil sym clause
+ `(progn
+ (push ,sym cl--loop-conditions)
+ (push ,sym cl--loop-body))))
+
;; Below is a complete spec for cl-loop, in several parts that correspond
;; to the syntax given in CLtL2. The specs do more than specify where
;; the forms are; it also specifies, as much as Edebug allows, all the
@@ -1052,20 +1052,20 @@ For more details, see Info node `(cl)Loop Facility'.
;; [&rest loop-clause]
;; ))
-;; (def-edebug-spec loop-with
-;; ("with" loop-var
+;; (def-edebug-elem-spec 'loop-with
+;; '("with" loop-var
;; loop-type-spec
;; [&optional ["=" form]]
;; &rest ["and" loop-var
;; loop-type-spec
;; [&optional ["=" form]]]))
-;; (def-edebug-spec loop-for-as
-;; ([&or "for" "as"] loop-for-as-subclause
+;; (def-edebug-elem-spec 'loop-for-as
+;; '([&or "for" "as"] loop-for-as-subclause
;; &rest ["and" loop-for-as-subclause]))
-;; (def-edebug-spec loop-for-as-subclause
-;; (loop-var
+;; (def-edebug-elem-spec 'loop-for-as-subclause
+;; '(loop-var
;; loop-type-spec
;; &or
;; [[&or "in" "on" "in-ref" "across-ref"]
@@ -1125,19 +1125,19 @@ For more details, see Info node `(cl)Loop Facility'.
;; [&optional ["by" form]]
;; ]))
-;; (def-edebug-spec loop-initial-final
-;; (&or ["initially"
+;; (def-edebug-elem-spec 'loop-initial-final
+;; '(&or ["initially"
;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this.
;; &rest loop-non-atomic-expr]
;; ["finally" &or
;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
;; ["return" form]]))
-;; (def-edebug-spec loop-and-clause
-;; (loop-clause &rest ["and" loop-clause]))
+;; (def-edebug-elem-spec 'loop-and-clause
+;; '(loop-clause &rest ["and" loop-clause]))
-;; (def-edebug-spec loop-clause
-;; (&or
+;; (def-edebug-elem-spec 'loop-clause
+;; '(&or
;; [[&or "while" "until" "always" "never" "thereis"] form]
;; [[&or "collect" "collecting"
@@ -1164,10 +1164,10 @@ For more details, see Info node `(cl)Loop Facility'.
;; loop-initial-final
;; ))
-;; (def-edebug-spec loop-non-atomic-expr
-;; ([&not atom] form))
+;; (def-edebug-elem-spec 'loop-non-atomic-expr
+;; '([&not atom] form))
-;; (def-edebug-spec loop-var
+;; (def-edebug-elem-spec 'loop-var
;; ;; The symbolp must be last alternative to recognize e.g. (a b . c)
;; ;; loop-var =>
;; ;; (loop-var . [&or nil loop-var])
@@ -1176,15 +1176,13 @@ For more details, see Info node `(cl)Loop Facility'.
;; ;; (symbolp . (symbolp . [&or nil loop-var]))
;; ;; (symbolp . (symbolp . loop-var))
;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp)
-;; (&or (loop-var . [&or nil loop-var]) [gate symbolp]))
-
-;; (def-edebug-spec loop-type-spec
-;; (&optional ["of-type" loop-d-type-spec]))
-
-;; (def-edebug-spec loop-d-type-spec
-;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
+;; '(&or (loop-var . [&or nil loop-var]) [gate symbolp]))
+;; (def-edebug-elem-spec 'loop-type-spec
+;; '(&optional ["of-type" loop-d-type-spec]))
+;; (def-edebug-elem-spec 'loop-d-type-spec
+;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
(defun cl--parse-loop-clause () ; uses loop-*
(let ((word (pop cl--loop-args))
@@ -1264,11 +1262,11 @@ For more details, see Info node `(cl)Loop Facility'.
(if end-var (push (list end-var end) loop-for-bindings))
(if step-var (push (list step-var step)
loop-for-bindings))
- (if end
- (push (list
- (if down (if excl '> '>=) (if excl '< '<=))
- var (or end-var end))
- cl--loop-body))
+ (when end
+ (cl--push-clause-loop-body
+ (list
+ (if down (if excl '> '>=) (if excl '< '<=))
+ var (or end-var end))))
(push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))
@@ -1278,7 +1276,7 @@ For more details, see Info node `(cl)Loop Facility'.
(temp (if (and on (symbolp var))
var (make-symbol "--cl-var--"))))
(push (list temp (pop cl--loop-args)) loop-for-bindings)
- (push `(consp ,temp) cl--loop-body)
+ (cl--push-clause-loop-body `(consp ,temp))
(if (eq word 'in-ref)
(push (list var `(car ,temp)) cl--loop-symbol-macs)
(or (eq temp var)
@@ -1301,33 +1299,31 @@ For more details, see Info node `(cl)Loop Facility'.
((eq word '=)
(let* ((start (pop cl--loop-args))
(then (if (eq (car cl--loop-args) 'then)
- (cl--pop2 cl--loop-args) start)))
+ (cl--pop2 cl--loop-args) start))
+ (first-assign (or cl--loop-first-flag
+ (setq cl--loop-first-flag
+ (make-symbol "--cl-var--")))))
(push (list var nil) loop-for-bindings)
(if (or ands (eq (car cl--loop-args) 'and))
(progn
- (push `(,var
- (if ,(or cl--loop-first-flag
- (setq cl--loop-first-flag
- (make-symbol "--cl-var--")))
- ,start ,var))
- loop-for-sets)
- (push (list var then) loop-for-steps))
- (push (list var
- (if (eq start then) start
- `(if ,(or cl--loop-first-flag
- (setq cl--loop-first-flag
- (make-symbol "--cl-var--")))
- ,start ,then)))
- loop-for-sets))))
+ (push `(,var (if ,first-assign ,start ,var)) loop-for-sets)
+ (push `(,var (if ,(car (cl--loop-build-ands
+ (nreverse cl--loop-conditions)))
+ ,then ,var))
+ loop-for-steps))
+ (push (if (eq start then)
+ `(,var ,then)
+ `(,var (if ,first-assign ,start ,then)))
+ loop-for-sets))))
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
(temp-idx (make-symbol "--cl-idx--")))
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
- (push `(< (setq ,temp-idx (1+ ,temp-idx))
- (length ,temp-vec))
- cl--loop-body)
+ (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body)
+ (cl--push-clause-loop-body
+ `(< ,temp-idx (length ,temp-vec)))
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
cl--loop-symbol-macs)
@@ -1351,17 +1347,16 @@ For more details, see Info node `(cl)Loop Facility'.
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-idx 0) loop-for-bindings)
(if ref
- (let ((temp-len (make-symbol "--cl-len--")))
+ (let ((temp-len (make-symbol "--cl-len--")))
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
(push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
- (push `(< ,temp-idx ,temp-len) cl--loop-body))
+ (cl--push-clause-loop-body `(< ,temp-idx ,temp-len)))
(push (list var nil) loop-for-bindings)
- (push `(and ,temp-seq
- (or (consp ,temp-seq)
- (< ,temp-idx (length ,temp-seq))))
- cl--loop-body)
+ (cl--push-clause-loop-body `(and ,temp-seq
+ (or (consp ,temp-seq)
+ (< ,temp-idx (length ,temp-seq)))))
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
(aref ,temp-seq ,temp-idx)))
@@ -1457,9 +1452,8 @@ For more details, see Info node `(cl)Loop Facility'.
(push (list var '(selected-frame))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
- (push `(prog1 (not (eq ,var ,temp))
- (or ,temp (setq ,temp ,var)))
- cl--loop-body)
+ (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp))
+ (or ,temp (setq ,temp ,var))))
(push (list var `(next-frame ,var))
loop-for-steps)))
@@ -1480,9 +1474,8 @@ For more details, see Info node `(cl)Loop Facility'.
(push (list minip `(minibufferp (window-buffer ,var)))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
- (push `(prog1 (not (eq ,var ,temp))
- (or ,temp (setq ,temp ,var)))
- cl--loop-body)
+ (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp))
+ (or ,temp (setq ,temp ,var))))
(push (list var `(next-window ,var ,minip))
loop-for-steps)))
@@ -1498,17 +1491,17 @@ For more details, see Info node `(cl)Loop Facility'.
(pop cl--loop-args))
(if (and ands loop-for-bindings)
(push (nreverse loop-for-bindings) cl--loop-bindings)
- (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings)
- cl--loop-bindings)))
+ (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings)
+ cl--loop-bindings)))
(if loop-for-sets
(push `(progn
,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
t)
cl--loop-body))
- (if loop-for-steps
- (push (cons (if ands 'cl-psetq 'setq)
- (apply 'append (nreverse loop-for-steps)))
- cl--loop-steps))))
+ (when loop-for-steps
+ (push (cons (if ands 'cl-psetq 'setq)
+ (apply #'append (nreverse loop-for-steps)))
+ cl--loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
@@ -1700,7 +1693,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings."
(push binding new))))
(if (eq body 'setq)
(let ((set (cons (if par 'cl-psetq 'setq)
- (apply 'nconc (nreverse new)))))
+ (apply #'nconc (nreverse new)))))
(if temps `(let* ,(nreverse temps) ,set) set))
`(,(if par 'let 'let*)
,(nconc (nreverse temps) (nreverse new)) ,@body))))
@@ -1826,7 +1819,7 @@ For more details, see `cl-do*' description in Info node `(cl) Iteration'.
(and sets
(list (cons (if (or star (not (cdr sets)))
'setq 'cl-psetq)
- (apply 'append sets))))))
+ (apply #'append sets))))))
,@(or (cdr endtest) '(nil)))))
;;;###autoload
@@ -1932,7 +1925,8 @@ from OBARRAY.
\(fn (VAR [OBARRAY [RESULT]]) BODY...)"
(declare (indent 1)
- (debug ((symbolp &optional form form) cl-declarations body)))
+ (debug ((symbolp &optional form form) cl-declarations
+ def-body)))
;; Apparently this doesn't have an implicit block.
`(cl-block nil
(let (,(car spec))
@@ -1972,7 +1966,7 @@ Each symbol in the first list is bound to the corresponding value in the
second list (or to nil if VALUES is shorter than SYMBOLS); then the
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
- (declare (indent 2) (debug (form form body)))
+ (declare (indent 2) (debug (form form def-body)))
(let ((bodyfun (make-symbol "body"))
(binds (make-symbol "binds"))
(syms (make-symbol "syms"))
@@ -1984,7 +1978,8 @@ a `let' form, except that the list of symbols can be computed at run-time."
(,binds ()))
(while ,syms
(push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
- (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
+ (eval (list 'let (nreverse ,binds)
+ (list 'funcall (list 'quote ,bodyfun))))))))
(defconst cl--labels-magic (make-symbol "cl--labels-magic"))
@@ -2024,7 +2019,13 @@ info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
- (debug ((&rest [&or (&define name function-form) (cl-defun)])
+ (debug ((&rest [&or (symbolp form)
+ (&define [&name symbolp "@cl-flet@"]
+ [&name [] gensym] ;Make it unique!
+ cl-lambda-list
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
+ def-body)])
cl-declarations body)))
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
@@ -2063,10 +2064,120 @@ Like `cl-flet' but the definitions can refer to previous ones.
((null (cdr bindings)) `(cl-flet ,bindings ,@body))
(t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body)))))
+(defun cl--self-tco (var fargs body)
+ ;; This tries to "optimize" tail calls for the specific case
+ ;; of recursive self-calls by replacing them with a `while' loop.
+ ;; It is quite far from a general tail-call optimization, since it doesn't
+ ;; even handle mutually recursive functions.
+ (letrec
+ ((done nil) ;; Non-nil if some TCO happened.
+ ;; This var always holds the value `nil' until (just before) we
+ ;; exit the loop.
+ (retvar (make-symbol "retval"))
+ (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s
+ (make-symbol (symbol-name s))))
+ fargs))
+ (opt-exps (lambda (exps) ;; `exps' is in tail position!
+ (append (butlast exps)
+ (list (funcall opt (car (last exps)))))))
+ (opt
+ (lambda (exp) ;; `exp' is in tail position!
+ (pcase exp
+ ;; FIXME: Optimize `apply'?
+ (`(funcall ,(pred (eq var)) . ,aargs)
+ ;; This is a self-recursive call in tail position.
+ (let ((sets nil)
+ (fargs ofargs))
+ (while fargs
+ (pcase (pop fargs)
+ ('&rest
+ (push (pop fargs) sets)
+ (push `(list . ,aargs) sets)
+ ;; (cl-assert (null fargs))
+ )
+ ('&optional nil)
+ (farg
+ (push farg sets)
+ (push (pop aargs) sets))))
+ (setq done t)
+ `(progn (setq . ,(nreverse sets))
+ :recurse)))
+ (`(progn . ,exps) `(progn . ,(funcall opt-exps exps)))
+ (`(if ,cond ,then . ,else)
+ `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else)))
+ (`(and . ,exps) `(and . ,(funcall opt-exps exps)))
+ (`(or ,arg) (funcall opt arg))
+ (`(or ,arg . ,args)
+ (let ((val (make-symbol "val")))
+ `(let ((,val ,arg))
+ (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args))))))
+ (`(cond . ,conds)
+ (let ((cs '()))
+ (while conds
+ (pcase (pop conds)
+ (`(,exp)
+ (push (if conds
+ ;; This returns the value of `exp' but it's
+ ;; only in tail position if it's the
+ ;; last condition.
+ ;; Note: This may set the var before we
+ ;; actually exit the loop, but luckily it's
+ ;; only the case if we set the var to nil,
+ ;; so it does preserve the invariant that
+ ;; the var is nil until we exit the loop.
+ `((setq ,retvar ,exp) nil)
+ `(,(funcall opt exp)))
+ cs))
+ (exps
+ (push (funcall opt-exps exps) cs))))
+ ;; No need to set `retvar' to return nil.
+ `(cond . ,(nreverse cs))))
+ ((and `(,(or 'let 'let*) ,bindings . ,exps)
+ (guard
+ ;; Note: it's OK for this `let' to shadow any
+ ;; of the formal arguments since we will only
+ ;; setq the fresh new `ofargs' vars instead ;-)
+ (let ((shadowings
+ (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)))
+ ;; If `var' is shadowed, then it clearly can't be
+ ;; tail-called any more.
+ (not (memq var shadowings)))))
+ `(,(car exp) ,bindings . ,(funcall opt-exps exps)))
+ ((and `(condition-case ,err-var ,bodyform . ,handlers)
+ (guard (not (eq err-var var))))
+ `(condition-case ,err-var
+ ,(if (assq :success handlers)
+ bodyform
+ `(progn (setq ,retvar ,bodyform) nil))
+ . ,(mapcar (lambda (h)
+ (cons (car h) (funcall opt-exps (cdr h))))
+ handlers)))
+ ('nil nil) ;No need to set `retvar' to return nil.
+ (_ `(progn (setq ,retvar ,exp) nil))))))
+
+ (let ((optimized-body (funcall opt-exps body)))
+ (if (not done)
+ (cons fargs body)
+ ;; We use two sets of vars: `ofargs' and `fargs' because we need
+ ;; to be careful that if a closure captures a formal argument
+ ;; in one iteration, it needs to capture a different binding
+ ;; then that of other iterations, e.g.
+ (cons
+ ofargs
+ `((let (,retvar)
+ (while (let ,(delq nil
+ (cl-mapcar
+ (lambda (a oa)
+ (unless (memq a cl--lambda-list-keywords)
+ (list a oa)))
+ fargs ofargs))
+ . ,optimized-body))
+ ,retvar)))))))
+
;;;###autoload
(defmacro cl-labels (bindings &rest body)
- "Make local (recursive) function definitions.
-Each definition can take the form (FUNC ARGLIST BODY...) where
+ "Make local (recursive) function definitions.
++BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where
FUNC is the function name, ARGLIST its arguments, and BODY the
forms of the function body. FUNC is defined in any BODY, as well
as FORM, so you can write recursive and mutually recursive
@@ -2078,17 +2189,47 @@ details.
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons var (cdr binding)) binds)
(push (cons (car binding)
(lambda (&rest args)
(if (eq (car args) cl--labels-magic)
(list cl--labels-magic var)
(cl-list* 'funcall var args))))
newenv)))
- (macroexpand-all `(letrec ,(nreverse binds) ,@body)
- ;; Don't override lexical-let's macro-expander.
- (if (assq 'function newenv) newenv
- (cons (cons 'function #'cl--labels-convert) newenv)))))
+ ;; Don't override lexical-let's macro-expander.
+ (unless (assq 'function newenv)
+ (push (cons 'function #'cl--labels-convert) newenv))
+ ;; Perform self-tail call elimination.
+ (setq binds (mapcar
+ (lambda (bind)
+ (pcase-let*
+ ((`(,var ,sargs . ,sbody) bind)
+ (`(function (lambda ,fargs . ,ebody))
+ (macroexpand-all `(cl-function (lambda ,sargs . ,sbody))
+ newenv))
+ (`(,ofargs . ,obody)
+ (cl--self-tco var fargs ebody)))
+ `(,var (function (lambda ,ofargs . ,obody)))))
+ (nreverse binds)))
+ `(letrec ,binds
+ . ,(macroexp-unprogn
+ (macroexpand-all
+ (macroexp-progn body)
+ newenv)))))
+
+(defvar edebug-lexical-macro-ctx)
+
+(defun cl--edebug-macrolet-interposer (bindings pf &rest specs)
+ ;; (cl-assert (null (cdr bindings)))
+ (setq bindings (car bindings))
+ (let ((edebug-lexical-macro-ctx
+ (nconc (mapcar (lambda (binding)
+ (cons (car binding)
+ (when (eq 'declare (car-safe (nth 2 binding)))
+ (nth 1 (assq 'debug (cdr (nth 2 binding)))))))
+ bindings)
+ edebug-lexical-macro-ctx)))
+ (funcall pf specs)))
;; The following ought to have a better definition for use with newer
;; byte compilers.
@@ -2099,16 +2240,21 @@ This is like `cl-flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
- (debug (cl-macrolet-expr)))
+ (debug (&interpose (&rest (&define [&name symbolp "@cl-macrolet@"]
+ [&name [] gensym] ;Make it unique!
+ cl-macro-list
+ cl-declarations-or-string
+ def-body))
+ cl--edebug-macrolet-interposer
+ cl-declarations body)))
(if (cdr bindings)
`(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
(if (null bindings) (macroexp-progn body)
(let* ((name (caar bindings))
(res (cl--transform-lambda (cdar bindings) name)))
- (eval (car res))
(macroexpand-all (macroexp-progn body)
(cons (cons name
- (eval `(cl-function (lambda ,@(cdr res))) t))
+ (eval `(function (lambda ,@res)) t))
macroexpand-all-environment))))))
(defun cl--sm-macroexpand (orig-fun exp &optional env)
@@ -2153,7 +2299,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros."
;; on this behavior (haven't found any yet).
;; Such code should explicitly use `cl-letf' instead, I think.
;;
- ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+ ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare))
;; (let ((letf nil) (found nil) (nbs ()))
;; (dolist (binding bindings)
;; (let* ((var (if (symbolp binding) binding (car binding)))
@@ -2176,7 +2322,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros."
;; The behavior of CL made sense in a dynamically scoped
;; language, but nowadays, lexical scoping semantics is more often
;; expected.
- (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare))
+ (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare))
(let ((nbs ()) (found nil))
(dolist (binding bindings)
(let* ((var (if (symbolp binding) binding (car binding)))
@@ -2271,7 +2417,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
(nreverse malformed-bindings))
expansion)
@@ -2333,7 +2479,15 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(defmacro cl-the (type form)
"Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
- (if (not (or (not (cl--compiling-file))
+ ;; When native compiling possibly add the appropriate type hint.
+ (when (and (boundp 'byte-native-compiling)
+ byte-native-compiling)
+ (setf form
+ (cl-case type
+ (fixnum `(comp-hint-fixnum ,form))
+ (cons `(comp-hint-cons ,form))
+ (otherwise form))))
+ (if (not (or (not (macroexp-compiling-p))
(< cl--optimize-speed 3)
(= cl--optimize-safety 3)))
form
@@ -2343,6 +2497,28 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(list ',type ,temp ',form)))
,temp))))
+;;;###autoload
+(or (assq 'cl-optimize defun-declarations-alist)
+ (let ((x (list 'cl-optimize #'cl--optimize)))
+ (push x macro-declarations-alist)
+ (push x defun-declarations-alist)))
+
+(defun cl--optimize (f _args &rest qualities)
+ "Serve 'cl-optimize' in function declarations.
+Example:
+(defun foo (x)
+ (declare (cl-optimize (speed 3) (safety 0)))
+ x)"
+ ;; FIXME this should make use of `cl--declare-stack' but I suspect
+ ;; this mechanism should be reviewed first.
+ (cl-loop for (qly val) in qualities
+ do (cl-ecase qly
+ (speed
+ (setf cl--optimize-speed val)
+ (byte-run--set-speed f nil val))
+ (safety
+ (setf cl--optimize-safety val)))))
+
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
@@ -2359,12 +2535,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
'(nil byte-compile-inline-expand))
(error "%s already has a byte-optimizer, can't make it inline"
(car spec)))
- (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
+ (put (car spec) 'byte-optimizer #'byte-compile-inline-expand)))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
(if (eq (get (car spec) 'byte-optimizer)
- 'byte-compile-inline-expand)
+ #'byte-compile-inline-expand)
(put (car spec) 'byte-optimizer nil))))
((eq (car-safe spec) 'optimize)
@@ -2400,7 +2576,7 @@ For instance
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
- (if (cl--compiling-file)
+ (if (macroexp-compiling-p)
(while specs
(if (listp cl--declare-stack) (push (car specs) cl--declare-stack))
(cl--do-proclaim (pop specs) nil)))
@@ -2472,7 +2648,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)"
(declare (debug (&rest place)))
- (if (not (memq nil (mapcar 'symbolp args)))
+ (if (not (memq nil (mapcar #'symbolp args)))
(and (cdr args)
(let ((sets nil)
(first (car args)))
@@ -2703,7 +2879,7 @@ Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where
SDEFAULT is the default value of that slot and SOPTIONS are keyword-value
pairs for that slot.
Supported keywords for slots are:
-- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'.
+- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'.
- `:documentation': this is a docstring describing the slot.
- `:type': the type of the field; currently only used for documentation.
@@ -2737,7 +2913,7 @@ Supported keywords for slots are:
(copier (intern (format "copy-%s" name)))
(predicate (intern (format "%s-p" name)))
(print-func nil) (print-auto nil)
- (safety (if (cl--compiling-file) cl--optimize-safety 3))
+ (safety (if (macroexp-compiling-p) cl--optimize-safety 3))
(include nil)
;; There are 4 types of structs:
;; - `vector' type: means we should use a vector, which can come
@@ -2767,7 +2943,7 @@ Supported keywords for slots are:
(unless (cl--struct-name-p name)
(signal 'wrong-type-argument (list 'cl-struct-name-p name 'name)))
(setq descs (cons '(cl-tag-slot)
- (mapcar (function (lambda (x) (if (consp x) x (list x))))
+ (mapcar (lambda (x) (if (consp x) x (list x)))
descs)))
(while opts
(let ((opt (if (consp (car opts)) (caar opts) (car opts)))
@@ -2794,9 +2970,8 @@ Supported keywords for slots are:
;; we include EIEIO classes rather than cl-structs!
(when include-name (error "Can't :include more than once"))
(setq include-name (car args))
- (setq include-descs (mapcar (function
- (lambda (x)
- (if (consp x) x (list x))))
+ (setq include-descs (mapcar (lambda (x)
+ (if (consp x) x (list x)))
(cdr args))))
((eq opt :print-function)
(setq print-func (car args)))
@@ -2872,7 +3047,9 @@ Supported keywords for slots are:
(append pred-form '(t))
`(and ,pred-form t)))
forms)
- (push `(put ',name 'cl-deftype-satisfies ',predicate) forms))
+ (push `(eval-and-compile
+ (put ',name 'cl-deftype-satisfies ',predicate))
+ forms))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
@@ -2909,7 +3086,7 @@ Supported keywords for slots are:
forms)
(when (cl-oddp (length desc))
(push
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name)
'nil)
@@ -2918,7 +3095,7 @@ Supported keywords for slots are:
(not (keywordp (car desc))))
(let ((kw (car defaults)))
(push
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(format " I'll take `%s' to be an option rather than a default value."
kw)
'nil)
@@ -2971,15 +3148,27 @@ Supported keywords for slots are:
constrs))
(pcase-dolist (`(,cname ,args ,doc) constrs)
(let* ((anames (cl--arglist-args args))
- (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
- slots defaults)))
- (push `(,cldefsym ,cname
+ (make (cl-mapcar (lambda (s d) (if (memq s anames) s d))
+ slots defaults))
+ ;; `cl-defsubst' is fundamentally broken: it substitutes
+ ;; its arguments into the body's `sexp' much too naively
+ ;; when inlinling, which results in various problems.
+ ;; For example it generates broken code if your
+ ;; argument's name happens to be the same as some
+ ;; function used within the body.
+ ;; E.g. (cl-defsubst sm-foo (list) (list list))
+ ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'!
+ ;; Try to catch this known case!
+ (con-fun (or type #'record))
+ (unsafe-cl-defsubst
+ (or (memq con-fun args) (assq con-fun args))))
+ (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname
(&cl-defs (nil ,@descs) ,@args)
,(if (stringp doc) doc
(format "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
- (,(or type #'record) ,@make))
+ (,con-fun ,@make))
forms)))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
;; Don't bother adding to cl-custom-print-functions since it's not used
@@ -3087,6 +3276,13 @@ STRUCT-TYPE is a symbol naming a struct type. Return `record',
(declare (side-effect-free t) (pure t))
(cl--struct-class-type (cl--struct-get-class struct-type)))
+(defun cl--alist-to-plist (alist)
+ (let ((res '()))
+ (dolist (x alist)
+ (push (car x) res)
+ (push (cdr x) res))
+ (nreverse res)))
+
(defun cl-struct-slot-info (struct-type)
"Return a list of slot names of struct STRUCT-TYPE.
Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a
@@ -3104,7 +3300,7 @@ slots skipped by :initial-offset may appear in the list."
,(cl--slot-descriptor-initform slot)
,@(if (not (eq (cl--slot-descriptor-type slot) t))
`(:type ,(cl--slot-descriptor-type slot)))
- ,@(cl--slot-descriptor-props slot))
+ ,@(cl--alist-to-plist (cl--slot-descriptor-props slot)))
descs)))
(nreverse descs)))
@@ -3122,23 +3318,44 @@ does not contain SLOT-NAME."
(signal 'cl-struct-unknown-slot (list struct-type slot-name))))
(defvar byte-compile-function-environment)
-(defvar byte-compile-macro-environment)
(defun cl--macroexp-fboundp (sym)
"Return non-nil if SYM will be bound when we run the code.
Of course, we really can't know that for sure, so it's just a heuristic."
(or (fboundp sym)
- (and (cl--compiling-file)
+ (and (macroexp-compiling-p)
(or (cdr (assq sym byte-compile-function-environment))
- (cdr (assq sym byte-compile-macro-environment))))))
-
-(put 'null 'cl-deftype-satisfies #'null)
-(put 'atom 'cl-deftype-satisfies #'atom)
-(put 'real 'cl-deftype-satisfies #'numberp)
-(put 'fixnum 'cl-deftype-satisfies #'integerp)
-(put 'base-char 'cl-deftype-satisfies #'characterp)
-(put 'character 'cl-deftype-satisfies #'natnump)
-
+ (cdr (assq sym macroexpand-all-environment))))))
+
+(pcase-dolist (`(,type . ,pred)
+ ;; Mostly kept in alphabetical order.
+ '((array . arrayp)
+ (atom . atom)
+ (base-char . characterp)
+ (boolean . booleanp)
+ (bool-vector . bool-vector-p)
+ (buffer . bufferp)
+ (character . natnump)
+ (char-table . char-table-p)
+ (hash-table . hash-table-p)
+ (cons . consp)
+ (fixnum . integerp)
+ (float . floatp)
+ (function . functionp)
+ (integer . integerp)
+ (keyword . keywordp)
+ (list . listp)
+ (number . numberp)
+ (null . null)
+ (real . numberp)
+ (sequence . sequencep)
+ (string . stringp)
+ (symbol . symbolp)
+ (vector . vectorp)
+ ;; FIXME: Do we really want to consider this a type?
+ (integer-or-marker . integer-or-marker-p)
+ ))
+ (put type 'cl-deftype-satisfies pred))
;;;###autoload
(define-inline cl-typep (val type)
@@ -3202,12 +3419,15 @@ Of course, we really can't know that for sure, so it's just a heuristic."
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
- (and (or (not (cl--compiling-file))
+ (and (or (not (macroexp-compiling-p))
(< cl--optimize-speed 3) (= cl--optimize-safety 3))
(macroexp-let2 macroexp-copyable-p temp form
`(progn (or (cl-typep ,temp ',type)
(signal 'wrong-type-argument
- (list ,(or string `',type) ,temp ',form)))
+ (list ,(or string `',(if (eq 'satisfies
+ (car-safe type))
+ (cadr type) type))
+ ,temp ',form)))
nil))))
;;;###autoload
@@ -3219,7 +3439,7 @@ Other args STRING and ARGS... are arguments to be passed to `error'.
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
- (and (or (not (cl--compiling-file))
+ (and (or (not (macroexp-compiling-p))
(< cl--optimize-speed 3) (= cl--optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
@@ -3349,8 +3569,8 @@ macro that returns its `&whole' argument."
(put y 'side-effect-free t))
;;; Things that are inline.
-(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
- cl-notevery cl-revappend cl-nreconc gethash))
+(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend
+ cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (function-put x 'side-effect-free t))
@@ -3375,6 +3595,10 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
(cl-deftype extended-char () '(and character (not base-char)))
+;; Define fixnum so `cl-typep' recognize it and the type check emitted
+;; by `cl-the' is effective.
+(cl-deftype fixnum () 'fixnump)
+(cl-deftype bignum () 'bignump)
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
@@ -3395,8 +3619,18 @@ STRUCT and SLOT-NAME are symbols. INST is a structure instance."
(nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst)
(aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name)))))))
+(make-obsolete-variable 'cl-macs-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'cl-macs-load-hook)
+;;; Pcase type pattern.
+
+;;;###autoload
+(pcase-defmacro cl-type (type)
+ "Pcase pattern that matches objects of TYPE.
+TYPE is a type descriptor as accepted by `cl-typep', which see."
+ `(pred (pcase--flip cl-typep ',type)))
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 7365e23186a..ef60b266f9e 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -124,12 +124,11 @@ supertypes from the most specific to least specific.")
(get name 'cl-struct-print))
(cl--find-class name)))))
-(defun cl--plist-remove (plist member)
- (cond
- ((null plist) nil)
- ((null member) plist)
- ((eq plist member) (cddr plist))
- (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member)))))
+(defun cl--plist-to-alist (plist)
+ (let ((res '()))
+ (while plist
+ (push (cons (pop plist) (pop plist)) res))
+ (nreverse res)))
(defun cl--struct-register-child (parent tag)
;; Can't use (cl-typep parent 'cl-structure-class) at this stage
@@ -164,12 +163,14 @@ supertypes from the most specific to least specific.")
(i 0)
(offset (if type 0 1)))
(dolist (slot slots)
- (let* ((props (cddr slot))
- (typep (plist-member props :type))
- (type (if typep (cadr typep) t)))
+ (let* ((props (cl--plist-to-alist (cddr slot)))
+ (typep (assq :type props))
+ (type (if (null typep) t
+ (setq props (delq typep props))
+ (cdr typep))))
(aset v i (cl--make-slot-desc
(car slot) (nth 1 slot)
- type (cl--plist-remove props typep))))
+ type props)))
(puthash (car slot) (+ i offset) index-table)
(cl-incf i))
v))
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 7cf02dfedd8..348da59fd97 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -33,8 +33,6 @@
;;; Code:
-(require 'button)
-
(defvar cl-print-readably nil
"If non-nil, try and make sure the result can be `read'.")
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index f5d745c1c84..329bd7c1b3b 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -69,10 +69,9 @@
(list 'or (list 'memq '(car cl-keys-temp)
(list 'quote
(mapcar
- (function
- (lambda (x)
- (if (consp x)
- (car x) x)))
+ (lambda (x)
+ (if (consp x)
+ (car x) x))
(append kwords
other-keys))))
'(car (cdr (memq (quote :allow-other-keys)
@@ -668,9 +667,9 @@ This is a destructive function; it reuses the storage of SEQ if possible.
(cl--parsing-keywords (:key) ()
(if (memq cl-key '(nil identity))
(sort cl-seq cl-pred)
- (sort cl-seq (function (lambda (cl-x cl-y)
- (funcall cl-pred (funcall cl-key cl-x)
- (funcall cl-key cl-y)))))))))
+ (sort cl-seq (lambda (cl-x cl-y)
+ (funcall cl-pred (funcall cl-key cl-x)
+ (funcall cl-key cl-y))))))))
;;;###autoload
(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys)
@@ -1042,6 +1041,8 @@ Atoms are compared by `eql'; cons cells are compared recursively.
(and (not (consp cl-x)) (not (consp cl-y)) (cl--check-match cl-x cl-y)))
+(make-obsolete-variable 'cl-seq-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'cl-seq-load-hook)
;; Local variables:
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
new file mode 100644
index 00000000000..3c5578217aa
--- /dev/null
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -0,0 +1,1197 @@
+;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.com>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Constraint library in use by the native compiler.
+
+;; In LIMPLE each non immediate value is represented by a `comp-mvar'.
+;; The part concerning the set of all values the `comp-mvar' can
+;; assume is described into its constraint `comp-cstr'. Each
+;; constraint consists in a triplet: type-set, value-set, range-set.
+;; This file provide set operations between constraints (union
+;; intersection and negation) plus routines to convert from and to a
+;; CL like type specifier.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst comp--typeof-types (mapcar (lambda (x)
+ (append x '(t)))
+ cl--typeof-types)
+ ;; TODO can we just add t in `cl--typeof-types'?
+ "Like `cl--typeof-types' but with t as common supertype.")
+
+(defconst comp--all-builtin-types
+ (append cl--all-builtin-types '(t))
+ "Likewise like `cl--all-builtin-types' but with t as common supertype.")
+
+(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr
+ (type &aux
+ (null (eq type 'null))
+ (integer (eq type 'integer))
+ (typeset (if (or null integer)
+ nil
+ (list type)))
+ (valset (when null
+ '(nil)))
+ (range (when integer
+ '((- . +))))))
+ (:constructor comp-value-to-cstr
+ (value &aux
+ (integer (integerp value))
+ (valset (unless integer
+ (list value)))
+ (range (when integer
+ `((,value . ,value))))
+ (typeset ())))
+ (:constructor comp-irange-to-cstr
+ (irange &aux
+ (range (list irange))
+ (typeset ())))
+ (:copier comp-cstr-shallow-copy))
+ "Internal representation of a type/value constraint."
+ (typeset '(t) :type list
+ :documentation "List of possible types the mvar can assume.
+Each element cannot be a subtype of any other element of this slot.")
+ (valset () :type list
+ :documentation "List of possible values the mvar can assume.
+Integer values are handled in the `range' slot.")
+ (range () :type list
+ :documentation "Integer interval.")
+ (neg nil :type boolean
+ :documentation "Non-nil if the constraint is negated"))
+
+(cl-defstruct comp-cstr-f
+ "Internal constraint representation for a function."
+ (args () :type list
+ :documentation "List of `comp-cstr' for its arguments.")
+ (ret nil :type (or comp-cstr comp-cstr-f)
+ :documentation "Returned value."))
+
+(cl-defstruct comp-cstr-ctxt
+ (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-union-typesets'.")
+ ;; TODO we should be able to just cons hash this.
+ (common-supertype-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-common-supertype'.")
+ (subtype-p-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-subtype-p-mem'.")
+ (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'.")
+ (union-1-mem-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'.")
+ (intersection-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`intersection-mem'."))
+
+(defmacro with-comp-cstr-accessors (&rest body)
+ "Define some quick accessor to reduce code vergosity in BODY."
+ (declare (debug (form body))
+ (indent defun))
+ `(cl-macrolet ((typeset (x)
+ `(comp-cstr-typeset ,x))
+ (valset (x)
+ `(comp-cstr-valset ,x))
+ (range (x)
+ `(comp-cstr-range ,x))
+ (neg (x)
+ `(comp-cstr-neg ,x)))
+ ,@body))
+
+(defun comp-cstr-copy (cstr)
+ "Return a deep copy of CSTR."
+ (with-comp-cstr-accessors
+ (make-comp-cstr :typeset (copy-sequence (typeset cstr))
+ :valset (copy-sequence (valset cstr))
+ :range (copy-tree (range cstr))
+ :neg (neg cstr))))
+
+(defsubst comp-cstr-empty-p (cstr)
+ "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise."
+ (with-comp-cstr-accessors
+ (and (null (typeset cstr))
+ (null (valset cstr))
+ (null (range cstr))
+ (null (neg cstr)))))
+
+(defsubst comp-cstr-null-p (cstr)
+ "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise."
+ (with-comp-cstr-accessors
+ (and (null (typeset cstr))
+ (null (range cstr))
+ (null (neg cstr))
+ (equal (valset cstr) '(nil)))))
+
+(defun comp-cstrs-homogeneous (cstrs)
+ "Check if constraints CSTRS are all homogeneously negated or non-negated.
+Return `pos' if they are all positive, `neg' if they are all
+negated or nil othewise."
+ (cl-loop
+ for cstr in cstrs
+ unless (comp-cstr-neg cstr)
+ count t into n-pos
+ else
+ count t into n-neg
+ finally
+ (cond
+ ((zerop n-neg) (cl-return 'pos))
+ ((zerop n-pos) (cl-return 'neg)))))
+
+(defun comp-split-pos-neg (cstrs)
+ "Split constraints CSTRS into non-negated and negated.
+Return them as multiple value."
+ (cl-loop
+ for cstr in cstrs
+ if (comp-cstr-neg cstr)
+ collect cstr into negatives
+ else
+ collect cstr into positives
+ finally return (cl-values positives negatives)))
+
+;; So we can load comp-cstr.el and comp.el in non native compiled
+;; builds.
+(defvar comp-ctxt nil)
+
+(defvar comp-cstr-one (comp-value-to-cstr 1)
+ "Represent the integer immediate one.")
+
+(defvar comp-cstr-t (comp-type-to-cstr t)
+ "Represent the superclass t.")
+
+
+;;; Value handling.
+
+(defun comp-normalize-valset (valset)
+ "Sort and remove duplicates from VALSET then return it."
+ (cl-sort (cl-remove-duplicates valset :test #'eq)
+ (lambda (x y)
+ (cond
+ ((and (symbolp x) (symbolp y))
+ (string< x y))
+ ((and (symbolp x) (not (symbolp y)))
+ t)
+ ((and (not (symbolp x)) (symbolp y))
+ nil)
+ (t
+ (< (sxhash-equal x)
+ (sxhash-equal y)))))))
+
+(defun comp-union-valsets (&rest valsets)
+ "Union values present into VALSETS."
+ (comp-normalize-valset (cl-reduce #'cl-union valsets)))
+
+(defun comp-intersection-valsets (&rest valsets)
+ "Union values present into VALSETS."
+ (comp-normalize-valset (cl-reduce #'cl-intersection valsets)))
+
+
+;;; Type handling.
+
+(defun comp-normalize-typeset (typeset)
+ "Sort TYPESET and return it."
+ (cl-sort (cl-remove-duplicates typeset)
+ (lambda (x y)
+ (string-lessp (symbol-name x)
+ (symbol-name y)))))
+
+(defun comp-supertypes (type)
+ "Return a list of pairs (supertype . hierarchy-level) for TYPE."
+ (cl-loop
+ named outer
+ with found = nil
+ for l in comp--typeof-types
+ do (cl-loop
+ for x in l
+ for i from (length l) downto 0
+ when (eq type x)
+ do (setf found t)
+ when found
+ collect `(,x . ,i) into res
+ finally (when found
+ (cl-return-from outer res)))))
+
+(defun comp-common-supertype-2 (type1 type2)
+ "Return the first common supertype of TYPE1 TYPE2."
+ (when-let ((types (cl-intersection
+ (comp-supertypes type1)
+ (comp-supertypes type2)
+ :key #'car)))
+ (car (cl-reduce (lambda (x y)
+ (if (> (cdr x) (cdr y)) x y))
+ types))))
+
+(defun comp-common-supertype (&rest types)
+ "Return the first common supertype of TYPES."
+ (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt))
+ (puthash types
+ (cl-reduce #'comp-common-supertype-2 types)
+ (comp-cstr-ctxt-common-supertype-mem comp-ctxt))))
+
+(defsubst comp-subtype-p (type1 type2)
+ "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
+ (let ((types (cons type1 type2)))
+ (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt))
+ (puthash types
+ (eq (comp-common-supertype-2 type1 type2) type2)
+ (comp-cstr-ctxt-subtype-p-mem comp-ctxt)))))
+
+(defun comp-union-typesets (&rest typesets)
+ "Union types present into TYPESETS."
+ (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
+ (puthash typesets
+ (cl-loop
+ with types = (apply #'append typesets)
+ with res = '()
+ for lane in comp--typeof-types
+ do (cl-loop
+ with last = nil
+ for x in lane
+ when (memq x types)
+ do (setf last x)
+ finally (when last
+ (push last res)))
+ finally return (comp-normalize-typeset res))
+ (comp-cstr-ctxt-union-typesets-mem comp-ctxt))))
+
+(defun comp-intersect-two-typesets (t1 t2)
+ "Intersect typesets T1 and T2."
+ (with-comp-cstr-accessors
+ (cl-loop
+ for types in (list t1 t2)
+ for other-types in (list t2 t1)
+ append
+ (cl-loop
+ for type in types
+ when (cl-some (lambda (x)
+ (comp-subtype-p type x))
+ other-types)
+ collect type))))
+
+(defun comp-intersect-typesets (&rest typesets)
+ "Intersect types present into TYPESETS."
+ (unless (cl-some #'null typesets)
+ (if (length= typesets 1)
+ (car typesets)
+ (comp-normalize-typeset
+ (cl-reduce #'comp-intersect-two-typesets typesets)))))
+
+
+;;; Integer range handling
+
+(defsubst comp-star-or-num-p (x)
+ (or (numberp x) (eq '* x)))
+
+(defsubst comp-range-1+ (x)
+ (if (symbolp x)
+ x
+ (1+ x)))
+
+(defsubst comp-range-1- (x)
+ (if (symbolp x)
+ x
+ (1- x)))
+
+(defsubst comp-range-+ (x y)
+ (pcase (cons x y)
+ ((or '(+ . -) '(- . +)) '??)
+ ((or `(- . ,_) `(,_ . -)) '-)
+ ((or `(+ . ,_) `(,_ . +)) '+)
+ (_ (+ x y))))
+
+(defsubst comp-range-- (x y)
+ (pcase (cons x y)
+ ((or '(+ . +) '(- . -)) '??)
+ ('(+ . -) '+)
+ ('(- . +) '-)
+ ((or `(+ . ,_) `(,_ . -)) '+)
+ ((or `(- . ,_) `(,_ . +)) '-)
+ (_ (- x y))))
+
+(defsubst comp-range-< (x y)
+ (cond
+ ((eq x '+) nil)
+ ((eq x '-) t)
+ ((eq y '+) t)
+ ((eq y '-) nil)
+ (t (< x y))))
+
+(defsubst comp-cstr-smallest-in-range (range)
+ "Smallest entry in RANGE."
+ (caar range))
+
+(defsubst comp-cstr-greatest-in-range (range)
+ "Greater entry in RANGE."
+ (cdar (last range)))
+
+(defun comp-range-union (&rest ranges)
+ "Combine integer intervals RANGES by union set operation."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (comp-range-1- (car x)) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ if (eq x 'l)
+ do
+ (when (zerop nest)
+ (setf low i))
+ (cl-incf nest)
+ else
+ do
+ (when (= nest 1)
+ (push `(,(comp-range-1+ low) . ,i) res))
+ (cl-decf nest)
+ finally return (reverse res)))
+
+(defun comp-range-intersection (&rest ranges)
+ "Combine integer intervals RANGES by intersecting."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with n-ranges = (length ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (car x) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ initially (when (cl-some #'null ranges)
+ ;; Intersecting with a null range always results in a
+ ;; null range.
+ (cl-return '()))
+ if (eq x 'l)
+ do
+ (cl-incf nest)
+ (when (= nest n-ranges)
+ (setf low i))
+ else
+ do
+ (when (= nest n-ranges)
+ (push `(,low . ,i)
+ res))
+ (cl-decf nest)
+ finally return (reverse res)))
+
+(defun comp-range-negation (range)
+ "Negate range RANGE."
+ (if (null range)
+ '((- . +))
+ (cl-loop
+ with res = ()
+ with last-h = '-
+ for (l . h) in range
+ unless (eq l '-)
+ do (push `(,(comp-range-1+ last-h) . ,(1- l)) res)
+ do (setf last-h h)
+ finally
+ (unless (eq '+ last-h)
+ (push `(,(1+ last-h) . +) res))
+ (cl-return (reverse res)))))
+
+(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range)
+ "Support range comparison functions."
+ (with-comp-cstr-accessors
+ (if ext-range
+ (setf (typeset dst) (when (cl-some (lambda (x)
+ (comp-subtype-p 'float x))
+ (typeset old-dst))
+ '(float))
+ (valset dst) ()
+ (range dst) (if (range old-dst)
+ (comp-range-intersection (range old-dst)
+ ext-range)
+ ext-range)
+ (neg dst) nil)
+ (setf (typeset dst) (typeset old-dst)
+ (valset dst) (valset old-dst)
+ (range dst) (range old-dst)
+ (neg dst) (neg old-dst)))))
+
+(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
+ ;; Prevent some code duplication for `comp-cstr-add-2'
+ ;; `comp-cstr-sub-2'.
+ (declare (debug (range-body))
+ (indent defun))
+ `(with-comp-cstr-accessors
+ (when-let ((r1 (range ,src1))
+ (r2 (range ,src2)))
+ (let* ((l1 (comp-cstr-smallest-in-range r1))
+ (l2 (comp-cstr-smallest-in-range r2))
+ (h1 (comp-cstr-greatest-in-range r1))
+ (h2 (comp-cstr-greatest-in-range r2)))
+ (setf (typeset ,dst) (when (cl-some (lambda (x)
+ (comp-subtype-p 'float x))
+ (append (typeset src1)
+ (typeset src2)))
+ '(float))
+ (range ,dst) ,@range-body)))))
+
+(defun comp-cstr-add-2 (dst src1 src2)
+ "Sum SRC1 and SRC2 into DST."
+ (comp-cstr-set-range-for-arithm dst src1 src2
+ `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2)))))
+
+(defun comp-cstr-sub-2 (dst src1 src2)
+ "Subtract SRC1 and SRC2 into DST."
+ (comp-cstr-set-range-for-arithm dst src1 src2
+ (let ((l (comp-range-- l1 h2))
+ (h (comp-range-- h1 l2)))
+ (if (or (eq l '??) (eq h '??))
+ '((- . +))
+ `((,l . ,h))))))
+
+
+;;; Union specific code.
+
+(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs)
+ "As `comp-cstr-union' but escluding the irange component.
+All SRCS constraints must be homogeneously negated or non-negated."
+
+ ;; Type propagation.
+ (setf (comp-cstr-typeset dst)
+ (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs)))
+
+ ;; Value propagation.
+ (setf (comp-cstr-valset dst)
+ (comp-normalize-valset
+ (cl-loop
+ with values = (mapcar #'comp-cstr-valset srcs)
+ ;; TODO sort.
+ for v in (cl-remove-duplicates (apply #'append values)
+ :test #'equal)
+ ;; We propagate only values those types are not already
+ ;; into typeset.
+ when (cl-notany (lambda (x)
+ (comp-subtype-p (type-of v) x))
+ (comp-cstr-typeset dst))
+ collect v)))
+
+ dst)
+
+(defun comp-cstr-union-homogeneous (range dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+All SRCS constraints must be homogeneously negated or non-negated.
+DST is returned."
+ (apply #'comp-cstr-union-homogeneous-no-range dst srcs)
+ ;; Range propagation.
+ (setf (comp-cstr-neg dst)
+ (when srcs
+ (comp-cstr-neg (car srcs)))
+
+ (comp-cstr-range dst)
+ (when (cl-notany (lambda (x)
+ (comp-subtype-p 'integer x))
+ (comp-cstr-typeset dst))
+ (if range
+ (apply #'comp-range-union
+ (mapcar #'comp-cstr-range srcs))
+ '((- . +)))))
+ dst)
+
+(cl-defun comp-cstr-union-1-no-mem (range &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+Non memoized version of `comp-cstr-union-1'.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let ((dst (make-comp-cstr)))
+ (cl-flet ((give-up ()
+ (setf (typeset dst) '(t)
+ (valset dst) ()
+ (range dst) ()
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst)))
+
+ ;; Check first if we are in the simple case of all input non-negate
+ ;; or negated so we don't have to cons.
+ (when-let ((res (comp-cstrs-homogeneous srcs)))
+ (apply #'comp-cstr-union-homogeneous range dst srcs)
+ (cl-return-from comp-cstr-union-1-no-mem dst))
+
+ ;; Some are negated and some are not
+ (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+ (let* ((pos (apply #'comp-cstr-union-homogeneous range
+ (make-comp-cstr) positives))
+ ;; We'll always use neg as result as this is almost
+ ;; always necessary for describing open intervals
+ ;; resulting from negated constraints.
+ (neg (apply #'comp-cstr-union-homogeneous range
+ (make-comp-cstr :neg t) negatives)))
+ ;; Type propagation.
+ (when (and (typeset pos)
+ ;; When every pos type is a subtype of some neg ones.
+ (cl-every (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p x y))
+ (append (typeset neg)
+ (when (range neg)
+ '(integer)))))
+ (typeset pos)))
+ ;; This is a conservative choice, ATM we can't represent such
+ ;; a disjoint set of types unless we decide to add a new slot
+ ;; into `comp-cstr' or adopt something like
+ ;; `intersection-type' `union-type' in SBCL. Keep it
+ ;; "simple" for now.
+ (give-up))
+
+ ;; When every neg type is a subtype of some pos one.
+ ;; In case return pos.
+ (when (and (typeset neg)
+ (cl-every (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p x y))
+ (append (typeset pos)
+ (when (range pos)
+ '(integer)))))
+ (typeset neg)))
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst))
+
+ ;; Verify disjoint condition between positive types and
+ ;; negative types coming from values, in case give-up.
+ (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
+ (when (range neg)
+ '(integer)))))
+ (when (cl-some (lambda (x)
+ (cl-some (lambda (y)
+ (and (not (eq y x))
+ (comp-subtype-p y x)))
+ neg-value-types))
+ (typeset pos))
+ (give-up)))
+
+ ;; Value propagation.
+ (cond
+ ((and (valset pos) (valset neg)
+ (equal (comp-union-valsets (valset pos) (valset neg))
+ (valset pos)))
+ ;; Pos is a superset of neg.
+ (give-up))
+ ((cl-some (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p y x))
+ (mapcar #'type-of (valset pos))))
+ (typeset neg))
+ (give-up))
+ (t
+ ;; pos is a subset or eq to neg
+ (setf (valset neg)
+ (cl-nset-difference (valset neg) (valset pos)))))
+
+ ;; Range propagation
+ (when range
+ ;; Handle apart (or (integer 1 1) (not (integer 1 1)))
+ ;; like cases.
+ (if (and (range pos) (range neg)
+ (equal (range pos) (range neg)))
+ (give-up)
+ (setf (range neg)
+ (comp-range-negation
+ (comp-range-union
+ (comp-range-negation (range neg))
+ (range pos))))))
+
+ (if (comp-cstr-empty-p neg)
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)
+ (setf (typeset dst) (typeset neg)
+ (valset dst) (valset neg)
+ (range dst) (range neg)
+ (neg dst) (neg neg)))))
+
+ ;; (not null) => t
+ (when (and (neg dst)
+ (null (typeset dst))
+ (null (valset dst))
+ (null (range dst)))
+ (give-up)))
+
+ dst)))
+
+(defun comp-cstr-union-1 (range dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let* ((mem-h (if range
+ (comp-cstr-ctxt-union-1-mem-range comp-ctxt)
+ (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))
+ (res (or (gethash srcs mem-h)
+ (puthash
+ (mapcar #'comp-cstr-copy srcs)
+ (apply #'comp-cstr-union-1-no-mem range srcs)
+ mem-h))))
+ (setf (typeset dst) (typeset res)
+ (valset dst) (valset res)
+ (range dst) (range res)
+ (neg dst) (neg res))
+ res)))
+
+(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+All SRCS constraints must be homogeneously negated or non-negated.
+DST is returned."
+
+ (with-comp-cstr-accessors
+ (when (cl-some #'comp-cstr-empty-p srcs)
+ (setf (valset dst) nil
+ (range dst) nil
+ (typeset dst) nil)
+ (cl-return-from comp-cstr-intersection-homogeneous dst))
+
+ (setf (neg dst) (when srcs
+ (neg (car srcs))))
+
+ ;; Type propagation.
+ (setf (typeset dst)
+ (apply #'comp-intersect-typesets
+ (mapcar #'comp-cstr-typeset srcs)))
+
+ ;; Value propagation.
+ (setf (valset dst)
+ (comp-normalize-valset
+ (cl-loop
+ for src in srcs
+ append
+ (cl-loop
+ for val in (valset src)
+ ;; If (member value) is subtypep of all other sources then
+ ;; is good to be colleted.
+ when (cl-every (lambda (s)
+ (or (memql val (valset s))
+ (cl-some (lambda (type)
+ (cl-typep val type))
+ (typeset s))))
+ (remq src srcs))
+ collect val))))
+
+ ;; Range propagation.
+ (setf (range dst)
+ ;; Do range propagation only if the destination typeset
+ ;; doesn't cover it already.
+ (unless (cl-some (lambda (type)
+ (comp-subtype-p 'integer type))
+ (typeset dst))
+ (apply #'comp-range-intersection
+ (cl-loop
+ for src in srcs
+ ;; Collect effective ranges.
+ collect (or (range src)
+ (when (cl-some (lambda (s)
+ (comp-subtype-p 'integer s))
+ (typeset src))
+ '((- . +))))))))
+
+ dst))
+
+(cl-defun comp-cstr-intersection-no-mem (&rest srcs)
+ "Combine SRCS by intersection set operation.
+Non memoized version of `comp-cstr-intersection-no-mem'."
+ (let ((dst (make-comp-cstr)))
+ (with-comp-cstr-accessors
+ (cl-flet ((return-empty ()
+ (setf (typeset dst) ()
+ (valset dst) ()
+ (range dst) ()
+ (neg dst) nil)
+ (cl-return-from comp-cstr-intersection-no-mem dst)))
+ (when-let ((res (comp-cstrs-homogeneous srcs)))
+ (if (eq res 'neg)
+ (apply #'comp-cstr-union-homogeneous t dst srcs)
+ (apply #'comp-cstr-intersection-homogeneous dst srcs))
+ (cl-return-from comp-cstr-intersection-no-mem dst))
+
+ ;; Some are negated and some are not
+ (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+ (let* ((pos (apply #'comp-cstr-intersection-homogeneous
+ (make-comp-cstr) positives))
+ (neg (apply #'comp-cstr-intersection-homogeneous
+ (make-comp-cstr) negatives)))
+
+ ;; In case pos is not relevant return directly the content
+ ;; of neg.
+ (when (equal (typeset pos) '(t))
+ (setf (typeset dst) (typeset neg)
+ (valset dst) (valset neg)
+ (range dst) (range neg)
+ (neg dst) t)
+
+ ;; (not t) => nil
+ (when (and (null (valset dst))
+ (null (range dst))
+ (neg dst)
+ (equal '(t) (typeset dst)))
+ (setf (typeset dst) ()
+ (neg dst) nil))
+
+ (cl-return-from comp-cstr-intersection-no-mem dst))
+
+ (when (cl-some
+ (lambda (ty)
+ (memq ty (typeset neg)))
+ (typeset pos))
+ (return-empty))
+
+ ;; Some negated types are subtypes of some non-negated one.
+ ;; Transform the corresponding set of types from neg to pos.
+ (cl-loop
+ for neg-type in (typeset neg)
+ do (cl-loop
+ for pos-type in (copy-sequence (typeset pos))
+ when (and (not (eq neg-type pos-type))
+ (comp-subtype-p neg-type pos-type))
+ do (cl-loop
+ with found
+ for (type . _) in (comp-supertypes neg-type)
+ when found
+ collect type into res
+ when (eq type pos-type)
+ do (setf (typeset pos) (cl-union (typeset pos) res))
+ (cl-return)
+ when (eq type neg-type)
+ do (setf found t))))
+
+ (setf (range pos)
+ (comp-range-intersection (range pos)
+ (comp-range-negation (range neg)))
+ (valset pos)
+ (cl-set-difference (valset pos) (valset neg)))
+
+ ;; Return a non negated form.
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)))
+ dst))))
+
+
+;;; Entry points.
+
+(defun comp-cstr-imm-vld-p (cstr)
+ "Return t if one and only one immediate value can be extracted from CSTR."
+ (with-comp-cstr-accessors
+ (when (and (null (typeset cstr))
+ (null (neg cstr)))
+ (let* ((v (valset cstr))
+ (r (range cstr))
+ (valset-len (length v))
+ (range-len (length r)))
+ (if (and (= valset-len 1)
+ (= range-len 0))
+ t
+ (when (and (= valset-len 0)
+ (= range-len 1))
+ (let* ((low (caar r))
+ (high (cdar r)))
+ (and (integerp low)
+ (integerp high)
+ (= low high)))))))))
+
+(defun comp-cstr-imm (cstr)
+ "Return the immediate value of CSTR.
+`comp-cstr-imm-vld-p' *must* be satisfied before calling
+`comp-cstr-imm'."
+ (declare (gv-setter
+ (lambda (val)
+ `(with-comp-cstr-accessors
+ (if (integerp ,val)
+ (setf (typeset ,cstr) nil
+ (range ,cstr) (list (cons ,val ,val)))
+ (setf (typeset ,cstr) nil
+ (valset ,cstr) (list ,val)))))))
+ (with-comp-cstr-accessors
+ (let ((v (valset cstr)))
+ (if (length= v 1)
+ (car v)
+ (caar (range cstr))))))
+
+(defun comp-cstr-fixnum-p (cstr)
+ "Return t if CSTR is certainly a fixnum."
+ (with-comp-cstr-accessors
+ (when (null (neg cstr))
+ (when-let (range (range cstr))
+ (let* ((low (caar range))
+ (high (cdar (last range))))
+ (unless (or (eq low '-)
+ (< low most-negative-fixnum)
+ (eq high '+)
+ (> high most-positive-fixnum))
+ t))))))
+
+(defun comp-cstr-symbol-p (cstr)
+ "Return t if CSTR is certainly a symbol."
+ (with-comp-cstr-accessors
+ (and (null (range cstr))
+ (null (neg cstr))
+ (or (and (null (valset cstr))
+ (equal (typeset cstr) '(symbol)))
+ (and (or (null (typeset cstr))
+ (equal (typeset cstr) '(symbol)))
+ (cl-every #'symbolp (valset cstr)))))))
+
+(defsubst comp-cstr-cons-p (cstr)
+ "Return t if CSTR is certainly a cons."
+ (with-comp-cstr-accessors
+ (and (null (valset cstr))
+ (null (range cstr))
+ (null (neg cstr))
+ (equal (typeset cstr) '(cons)))))
+
+(defun comp-cstr-= (dst op1 op2)
+ "Constraint OP1 being = OP2 setting the result into DST."
+ (with-comp-cstr-accessors
+ (cl-flet ((relax-cstr (cstr)
+ (setf cstr (comp-cstr-shallow-copy cstr))
+ ;; If can be any float extend it to all integers.
+ (when (memq 'float (typeset cstr))
+ (setf (range cstr) '((- . +))))
+ ;; For each float value that can be represented
+ ;; precisely as an integer add the integer as well.
+ (cl-loop
+ for v in (valset cstr)
+ do
+ (when-let* ((ok (floatp v))
+ (truncated (ignore-error overflow-error
+ (truncate v)))
+ (ok (= v truncated)))
+ (push (cons truncated truncated) (range cstr))))
+ (cl-loop
+ with vals-to-add
+ for (l . h) in (range cstr)
+ ;; If an integer range reduces to single value add
+ ;; its float value too.
+ if (eql l h)
+ do (push (float l) vals-to-add)
+ ;; Otherwise can be any float.
+ else
+ do (cl-pushnew 'float (typeset cstr))
+ (cl-return cstr)
+ finally (setf (valset cstr)
+ (append vals-to-add (valset cstr))))
+ (when (memql 0.0 (valset cstr))
+ (cl-pushnew -0.0 (valset cstr)))
+ (when (memql -0.0 (valset cstr))
+ (cl-pushnew 0.0 (valset cstr)))
+ cstr))
+ (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2)))))
+
+(defun comp-cstr-> (dst old-dst src)
+ "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((,(1+ src) . +))
+ (when-let* ((range (range src))
+ (low (comp-cstr-smallest-in-range range))
+ (okay (integerp low)))
+ `((,(1+ low) . +))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr->= (dst old-dst src)
+ "Constraint DST being >= than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((,src . +))
+ (when-let* ((range (range src))
+ (low (comp-cstr-smallest-in-range range))
+ (okay (integerp low)))
+ `((,low . +))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-< (dst old-dst src)
+ "Constraint DST being < than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((- . ,(1- src)))
+ (when-let* ((range (range src))
+ (low (comp-cstr-greatest-in-range range))
+ (okay (integerp low)))
+ `((- . ,(1- low)))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-<= (dst old-dst src)
+ "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((- . ,src))
+ (when-let* ((range (range src))
+ (low (comp-cstr-greatest-in-range range))
+ (okay (integerp low)))
+ `((- . ,low))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-add (dst srcs)
+ "Sum SRCS into DST."
+ (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs))
+ (cl-loop
+ for src in (nthcdr 2 srcs)
+ do (comp-cstr-add-2 dst dst src)))
+
+(defun comp-cstr-sub (dst srcs)
+ "Subtract SRCS into DST."
+ (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs))
+ (cl-loop
+ for src in (nthcdr 2 srcs)
+ do (comp-cstr-sub-2 dst dst src)))
+
+(defun comp-cstr-union-no-range (dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do not propagate the range component.
+DST is returned."
+ (apply #'comp-cstr-union-1 nil dst srcs))
+
+(defun comp-cstr-union (dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+DST is returned."
+ (apply #'comp-cstr-union-1 t dst srcs))
+
+(defun comp-cstr-union-make (&rest srcs)
+ "Combine SRCS by union set operation and return a new constraint."
+ (apply #'comp-cstr-union (make-comp-cstr) srcs))
+
+(defun comp-cstr-intersection (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))
+ (res (or (gethash srcs mem-h)
+ (puthash
+ (mapcar #'comp-cstr-copy srcs)
+ (apply #'comp-cstr-intersection-no-mem srcs)
+ mem-h))))
+ (setf (typeset dst) (typeset res)
+ (valset dst) (valset res)
+ (range dst) (range res)
+ (neg dst) (neg res))
+ res)))
+
+(defun comp-cstr-intersection-no-hashcons (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+Non hash consed values are not propagated as values but rather
+promoted to their types.
+DST is returned."
+ (with-comp-cstr-accessors
+ (apply #'comp-cstr-intersection dst srcs)
+ (if (and (neg dst)
+ (valset dst)
+ (cl-notevery #'symbolp (valset dst)))
+ (setf (valset dst) ()
+ (typeset dst) '(t)
+ (range dst) ()
+ (neg dst) nil)
+ (let (strip-values strip-types)
+ (cl-loop for v in (valset dst)
+ unless (symbolp v)
+ do (push v strip-values)
+ (push (type-of v) strip-types))
+ (when strip-values
+ (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types)
+ (valset dst) (cl-set-difference (valset dst) strip-values)))
+ (cl-loop for (l . h) in (range dst)
+ when (or (bignump l) (bignump h))
+ do (setf (range dst) '((- . +)))
+ (cl-return))))
+ dst))
+
+(defun comp-cstr-intersection-make (&rest srcs)
+ "Combine SRCS by intersection set operation and return a new constraint."
+ (apply #'comp-cstr-intersection (make-comp-cstr) srcs))
+
+(defun comp-cstr-negation (dst src)
+ "Negate SRC setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (cond
+ ((and (null (valset src))
+ (null (range src))
+ (null (neg src))
+ (equal (typeset src) '(t)))
+ (setf (typeset dst) ()
+ (valset dst) ()
+ (range dst) nil
+ (neg dst) nil))
+ ((and (null (valset src))
+ (null (range src))
+ (null (neg src))
+ (null (typeset src)))
+ (setf (typeset dst) '(t)
+ (valset dst) ()
+ (range dst) nil
+ (neg dst) nil))
+ (t (setf (typeset dst) (typeset src)
+ (valset dst) (valset src)
+ (range dst) (range src)
+ (neg dst) (not (neg src)))))
+ dst))
+
+(defun comp-cstr-value-negation (dst src)
+ "Negate values in SRC setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (if (or (valset src) (range src))
+ (setf (typeset dst) ()
+ (valset dst) (valset src)
+ (range dst) (range src)
+ (neg dst) (not (neg src)))
+ (setf (typeset dst) (typeset src)
+ (valset dst) ()
+ (range dst) ()))
+ dst))
+
+(defun comp-cstr-negation-make (src)
+ "Negate SRC and return a new constraint."
+ (comp-cstr-negation (make-comp-cstr) src))
+
+(defun comp-type-spec-to-cstr (type-spec &optional fn)
+ "Convert a type specifier TYPE-SPEC into a `comp-cstr'.
+FN non-nil indicates we are parsing a function lambda list."
+ (pcase type-spec
+ ((and (or '&optional '&rest) x)
+ (if fn
+ x
+ (error "Invalid `%s` in type specifier" x)))
+ ('nil
+ (make-comp-cstr :typeset ()))
+ ('fixnum
+ (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
+ ('boolean
+ (comp-type-spec-to-cstr '(member t nil)))
+ ('integer
+ (comp-irange-to-cstr '(- . +)))
+ ('null (comp-value-to-cstr nil))
+ ((pred atom)
+ (comp-type-to-cstr type-spec))
+ (`(or . ,rest)
+ (apply #'comp-cstr-union-make
+ (mapcar #'comp-type-spec-to-cstr rest)))
+ (`(and . ,rest)
+ (apply #'comp-cstr-intersection-make
+ (mapcar #'comp-type-spec-to-cstr rest)))
+ (`(not ,cstr)
+ (comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
+ (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(,l . ,h)))
+ (`(integer * ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(- . ,h)))
+ (`(integer ,(and (pred integerp) l) *)
+ (comp-irange-to-cstr `(,l . +)))
+ (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p))
+ ;; No float range support :/
+ (comp-type-to-cstr 'float))
+ (`(member . ,rest)
+ (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest)))
+ (`(function ,args ,ret)
+ (make-comp-cstr-f
+ :args (mapcar (lambda (x)
+ (comp-type-spec-to-cstr x t))
+ args)
+ :ret (comp-type-spec-to-cstr ret)))
+ (_ (error "Invalid type specifier"))))
+
+(defun comp-cstr-to-type-spec (cstr)
+ "Given CSTR return its type specifier."
+ (let ((valset (comp-cstr-valset cstr))
+ (typeset (comp-cstr-typeset cstr))
+ (range (comp-cstr-range cstr))
+ (negated (comp-cstr-neg cstr)))
+
+ (when valset
+ (when (memq nil valset)
+ (if (memq t valset)
+ (progn
+ ;; t and nil are values, convert into `boolean'.
+ (push 'boolean typeset)
+ (setf valset (remove t (remove nil valset))))
+ ;; Only nil is a value, convert it into a `null' type specifier.
+ (setf valset (remove nil valset))
+ (push 'null typeset))))
+
+ ;; Form proper integer type specifiers.
+ (setf range (cl-loop for (l . h) in range
+ for low = (if (integerp l) l '*)
+ for high = (if (integerp h) h '*)
+ if (and (eq low '*) (eq high '*))
+ collect 'integer
+ else
+ collect `(integer ,low , high))
+ valset (cl-remove-duplicates valset))
+
+ ;; Form the final type specifier.
+ (let* ((types-ints (append typeset range))
+ (res (cond
+ ((and types-ints valset)
+ `((member ,@valset) ,@types-ints))
+ (types-ints types-ints)
+ (valset `(member ,@valset))
+ (t
+ ;; Empty type specifier
+ nil)))
+ (final
+ (pcase res
+ ((or `(member . ,rest)
+ `(integer ,(pred comp-star-or-num-p)
+ ,(pred comp-star-or-num-p)))
+ (if rest
+ res
+ (car res)))
+ ((pred atom) res)
+ (`(,_first . ,rest)
+ (if rest
+ `(or ,@res)
+ (car res))))))
+ (if negated
+ `(not ,final)
+ final))))
+
+(provide 'comp-cstr)
+
+;;; comp-cstr.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
new file mode 100644
index 00000000000..638d4b274cc
--- /dev/null
+++ b/lisp/emacs-lisp/comp.el
@@ -0,0 +1,4231 @@
+;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*-
+
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.com>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This code is an attempt to make the pig fly.
+;; Or, to put it another way to make a 911 out of a turbocharged VW Bug.
+
+;;; Code:
+
+(require 'bytecomp)
+(require 'cl-extra)
+(require 'cl-lib)
+(require 'cl-macs)
+(require 'cl-seq)
+(require 'gv)
+(require 'rx)
+(require 'subr-x)
+(require 'warnings)
+(require 'comp-cstr)
+
+(defgroup comp nil
+ "Emacs Lisp native compiler."
+ :group 'lisp)
+
+(defcustom native-comp-speed 2
+ "Optimization level for native compilation, a number between -1 and 3.
+ -1 functions are kept in bytecode form and no native compilation is performed.
+ 0 native compilation is performed with no optimizations.
+ 1 light optimizations.
+ 2 max optimization level fully adherent to the language semantic.
+ 3 max optimization level, to be used only when necessary.
+ Warning: with 3, the compiler is free to perform dangerous optimizations."
+ :type 'integer
+ :safe #'integerp
+ :version "28.1")
+
+(defcustom native-comp-debug (if (eq 'windows-nt system-type) 1 0)
+ "Debug level for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no debug output.
+ 1 emit debug symbols.
+ 2 emit debug symbols and dump pseudo C code.
+ 3 emit debug symbols and dump: pseudo C code, GCC intermediate
+ passes and libgccjit log file."
+ :type 'integer
+ :safe #'natnump
+ :version "28.1")
+
+(defcustom native-comp-verbose 0
+ "Compiler verbosity for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no logging.
+ 1 final LIMPLE is logged.
+ 2 LAP, final LIMPLE, and some pass info are logged.
+ 3 max verbosity."
+ :type 'integer
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-always-compile nil
+ "Non-nil means unconditionally (re-)compile all files."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom native-comp-deferred-compilation-deny-list
+ '()
+ "List of regexps to exclude matching files from deferred native compilation.
+Files whose names match any regexp are excluded from native compilation."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom native-comp-bootstrap-deny-list
+ '()
+ "List of regexps to exclude files from native compilation during bootstrap.
+Files whose names match any regexp are excluded from native compilation
+during bootstrap."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom native-comp-never-optimize-functions
+ '(;; The following two are mandatory for Emacs to be working
+ ;; correctly (see comment in `advice--add-function'). DO NOT
+ ;; REMOVE.
+ macroexpand rename-buffer)
+ "Primitive functions to exclude from trampoline optimization."
+ :type '(repeat symbol)
+ :version "28.1")
+
+(defcustom native-comp-async-jobs-number 0
+ "Default number of subprocesses used for async native compilation.
+Value of zero means to use half the number of the CPU's execution units,
+or one if there's just one execution unit."
+ :type 'integer
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-async-cu-done-functions nil
+ "List of functions to call after asynchronously compiling one compilation unit.
+Called with one argument FILE, the filename used as input to
+compilation."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-all-done-hook nil
+ "Hook run after completing asynchronous compilation of all input files."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-env-modifier-form nil
+ "Form evaluated before compilation by each asynchronous compilation subprocess.
+Used to modify the compiler environment."
+ :type 'sexp
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-async-report-warnings-errors t
+ "Whether to report warnings and errors from asynchronous native compilation.
+
+When native compilation happens asynchronously, it can produce
+warnings and errors, some of which might not be emitted by a
+byte-compilation. The typical case for that is native-compiling
+a file that is missing some `require' of a necessary feature,
+while having it already loaded into the environment when
+byte-compiling.
+
+As asynchronous native compilation always starts from a pristine
+environment, it is more sensitive to such omissions, and might be
+unable to compile such Lisp source files correctly.
+
+Set this variable to nil to suppress warnings altogether, or to
+the symbol `silent' to log warnings but not pop up the *Warnings*
+buffer."
+ :type '(choice
+ (const :tag "Do not report warnings" nil)
+ (const :tag "Report and display warnings" t)
+ (const :tag "Report but do not display warnings" silent))
+ :version "28.1")
+
+(defcustom native-comp-async-query-on-exit nil
+ "Whether to query the user about killing async compilations when exiting.
+If this is non-nil, Emacs will ask for confirmation to exit and kill the
+asynchronous native compilations if any are running. If nil, when you
+exit Emacs, it will silently kill those asynchronous compilations even
+if `confirm-kill-processes' is non-nil."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom native-comp-driver-options nil
+ "Options passed verbatim to the native compiler's back-end driver.
+Note that not all options are meaningful; typically only the options
+affecting the assembler and linker are likely to be useful.
+
+Passing these options is only available in libgccjit version 9
+and above."
+ :type '(repeat string) ; FIXME is this right?
+ :version "28.1")
+
+(defcustom comp-libgccjit-reproducer nil
+ "When non-nil produce a libgccjit reproducer.
+The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in
+the .eln output directory."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom native-comp-warning-on-missing-source t
+ "Emit a warning if a byte-code file being loaded has no corresponding source.
+The source file is necessary for native code file look-up and deferred
+compilation mechanism."
+ :type 'boolean
+ :version "28.1")
+
+(defvar no-native-compile nil
+ "Non-nil to prevent native-compiling of Emacs Lisp code.
+Note that when `no-byte-compile' is set to non-nil it overrides the value of
+`no-native-compile'.
+This is normally set in local file variables at the end of the
+Emacs Lisp file:
+
+\;; Local Variables:\n;; no-native-compile: t\n;; End:")
+;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp)
+
+(defvar native-compile-target-directory nil
+ "When non-nil force the target directory for the eln files being compiled.")
+
+(defvar comp-log-time-report nil
+ "If non-nil, log a time report for each pass.")
+
+(defvar comp-dry-run nil
+ "If non-nil, run everything but the C back-end.")
+
+(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
+ "Regexp to match filename of valid input source files.")
+
+(defconst comp-log-buffer-name "*Native-compile-Log*"
+ "Name of the native-compiler log buffer.")
+
+(defconst comp-async-buffer-name "*Async-native-compile-log*"
+ "Name of the async compilation buffer log.")
+
+(defvar comp-native-compiling nil
+ "This gets bound to t during native compilation.
+Intended to be used by code that needs to work differently when
+native compilation runs.")
+
+(defvar comp-pass nil
+ "Every native-compilation pass can bind this to whatever it likes.")
+
+(defvar comp-curr-allocation-class 'd-default
+ "Current allocation class.
+Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.")
+
+(defconst comp-passes '(comp-spill-lap
+ comp-limplify
+ comp-fwprop
+ comp-call-optim
+ comp-ipa-pure
+ comp-add-cstrs
+ comp-fwprop
+ comp-tco
+ comp-fwprop
+ comp-remove-type-hints
+ comp-final)
+ "Passes to be executed in order.")
+
+(defvar comp-disabled-passes '()
+ "List of disabled passes.
+For internal use by the test suite only.")
+
+(defvar comp-post-pass-hooks '()
+ "Alist whose elements are of the form (PASS FUNCTIONS...).
+Each function in FUNCTIONS is run after PASS.
+Useful to hook into pass checkers.")
+
+;; FIXME this probably should not be here but... good for now.
+(defconst comp-known-type-specifiers
+ `(
+ ;; Functions we can trust not to be or if redefined should expose
+ ;; the same type. Vast majority of these is either pure or
+ ;; primitive, the original list is the union of pure +
+ ;; side-effect-free-fns + side-effect-and-error-free-fns:
+ (% (function ((or number marker) (or number marker)) number))
+ (* (function (&rest (or number marker)) number))
+ (+ (function (&rest (or number marker)) number))
+ (- (function (&rest (or number marker)) number))
+ (/ (function ((or number marker) &rest (or number marker)) number))
+ (/= (function ((or number marker) (or number marker)) boolean))
+ (1+ (function ((or number marker)) number))
+ (1- (function ((or number marker)) number))
+ (< (function ((or number marker) &rest (or number marker)) boolean))
+ (<= (function ((or number marker) &rest (or number marker)) boolean))
+ (= (function ((or number marker) &rest (or number marker)) boolean))
+ (> (function ((or number marker) &rest (or number marker)) boolean))
+ (>= (function ((or number marker) &rest (or number marker)) boolean))
+ (abs (function (number) number))
+ (acos (function (number) float))
+ (append (function (&rest t) t))
+ (aref (function (t fixnum) t))
+ (arrayp (function (t) boolean))
+ (ash (function (integer integer) integer))
+ (asin (function (number) float))
+ (assq (function (t list) list))
+ (atan (function (number &optional number) float))
+ (atom (function (t) boolean))
+ (bignump (function (t) boolean))
+ (bobp (function () boolean))
+ (bolp (function () boolean))
+ (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum))
+ (bool-vector-count-population (function (bool-vector) fixnum))
+ (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector))
+ (bool-vector-p (function (t) boolean))
+ (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
+ (boundp (function (symbol) boolean))
+ (buffer-end (function ((or number marker)) integer))
+ (buffer-file-name (function (&optional buffer) string))
+ (buffer-list (function (&optional frame) list))
+ (buffer-local-variables (function (&optional buffer) list))
+ (buffer-modified-p (function (&optional buffer) boolean))
+ (buffer-size (function (&optional buffer) integer))
+ (buffer-string (function () string))
+ (buffer-substring (function ((or integer marker) (or integer marker)) string))
+ (bufferp (function (t) boolean))
+ (byte-code-function-p (function (t) boolean))
+ (capitalize (function (or integer string) (or integer string)))
+ (car (function (list) t))
+ (car-less-than-car (function (list list) boolean))
+ (car-safe (function (t) t))
+ (case-table-p (function (t) boolean))
+ (cdr (function (list) t))
+ (cdr-safe (function (t) t))
+ (ceiling (function (number &optional number) integer))
+ (char-after (function (&optional (or marker integer)) fixnum))
+ (char-before (function (&optional (or marker integer)) fixnum))
+ (char-equal (function (integer integer) boolean))
+ (char-or-string-p (function (t) boolean))
+ (char-to-string (function (fixnum) string))
+ (char-width (function (fixnum) fixnum))
+ (characterp (function (t &optional t) boolean))
+ (charsetp (function (t) boolean))
+ (commandp (function (t &optional t) boolean))
+ (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum)))
+ (concat (function (&rest sequence) string))
+ (cons (function (t t) cons))
+ (consp (function (t) boolean))
+ (coordinates-in-window-p (function (cons window) boolean))
+ (copy-alist (function (list) list))
+ (copy-marker (function (&optional (or integer marker) boolean) marker))
+ (copy-sequence (function (sequence) sequence))
+ (copysign (function (float float) float))
+ (cos (function (number) float))
+ (count-lines (function ((or integer marker) (or integer marker) &optional t) integer))
+ (current-buffer (function () buffer))
+ (current-global-map (function () cons))
+ (current-indentation (function () integer))
+ (current-local-map (function () cons))
+ (current-minor-mode-maps (function () cons))
+ (current-time (function () cons))
+ (current-time-string (function (&optional string boolean) string))
+ (current-time-zone (function (&optional string boolean) cons))
+ (custom-variable-p (function (symbol) boolean))
+ (decode-char (function (cons t) (or fixnum null)))
+ (decode-time (function (&optional string symbol symbol) cons))
+ (default-boundp (function (symbol) boolean))
+ (default-value (function (symbol) t))
+ (degrees-to-radians (function (number) float))
+ (documentation (function ((or function symbol subr) &optional t) (or null string)))
+ (downcase (function ((or fixnum string)) (or fixnum string)))
+ (elt (function (sequence integer) t))
+ (encode-char (function (fixnum symbol) (or fixnum null)))
+ (encode-time (function (cons &rest t) cons))
+ (eobp (function () boolean))
+ (eolp (function () boolean))
+ (eq (function (t t) boolean))
+ (eql (function (t t) boolean))
+ (equal (function (t t) boolean))
+ (error-message-string (function (list) string))
+ (eventp (function (t) boolean))
+ (exp (function (number) float))
+ (expt (function (number number) float))
+ (fboundp (function (symbol) boolean))
+ (fceiling (function (float) float))
+ (featurep (function (symbol &optional symbol) boolean))
+ (ffloor (function (float) float))
+ (file-directory-p (function (string) boolean))
+ (file-exists-p (function (string) boolean))
+ (file-locked-p (function (string) boolean))
+ (file-name-absolute-p (function (string) boolean))
+ (file-newer-than-file-p (function (string string) boolean))
+ (file-readable-p (function (string) boolean))
+ (file-symlink-p (function (string) boolean))
+ (file-writable-p (function (string) boolean))
+ (fixnump (function (t) boolean))
+ (float (function (number) float))
+ (float-time (function (&optional cons) float))
+ (floatp (function (t) boolean))
+ (floor (function (number &optional number) integer))
+ (following-char (function () fixnum))
+ (format (function (string &rest t) string))
+ (format-time-string (function (string &optional cons symbol) string))
+ (frame-first-window (function ((or frame window)) window))
+ (frame-root-window (function (&optional (or frame window)) window))
+ (frame-selected-window (function (&optional (or frame window)) window))
+ (frame-visible-p (function (frame) boolean))
+ (framep (function (t) boolean))
+ (fround (function (float) float))
+ (ftruncate (function (float) float))
+ (get (function (symbol symbol) t))
+ (get-buffer (function ((or buffer string)) (or buffer null)))
+ (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window)))
+ (get-file-buffer (function (string) (or null buffer)))
+ (get-largest-window (function (&optional t t t) window))
+ (get-lru-window (function (&optional t t t) window))
+ (getenv (function (string &optional frame) (or null string)))
+ (gethash (function (t hash-table &optional t) t))
+ (hash-table-count (function (hash-table) integer))
+ (hash-table-p (function (t) boolean))
+ (identity (function (t) t))
+ (ignore (function (&rest t) null))
+ (int-to-string (function (number) string))
+ (integer-or-marker-p (function (t) boolean))
+ (integerp (function (t) boolean))
+ (interactive-p (function () boolean))
+ (intern-soft (function ((or string symbol) &optional vector) symbol))
+ (invocation-directory (function () string))
+ (invocation-name (function () string))
+ (isnan (function (float) boolean))
+ (keymap-parent (function (cons) (or cons null)))
+ (keymapp (function (t) boolean))
+ (keywordp (function (t) boolean))
+ (last (function (list &optional integer) list))
+ (lax-plist-get (function (list t) t))
+ (ldexp (function (number integer) float))
+ (length (function (t) (integer 0 *)))
+ (length< (function (sequence fixnum) boolean))
+ (length= (function (sequence fixnum) boolean))
+ (length> (function (sequence fixnum) boolean))
+ (line-beginning-position (function (&optional integer) integer))
+ (line-end-position (function (&optional integer) integer))
+ (list (function (&rest t) list))
+ (listp (function (t) boolean))
+ (local-variable-if-set-p (function (symbol &optional buffer) boolean))
+ (local-variable-p (function (symbol &optional buffer) boolean))
+ (locale-info (function ((member codeset days months paper)) (or null string)))
+ (log (function (number number) float))
+ (log10 (function (number) float))
+ (logand (function (&rest (or integer marker)) integer))
+ (logb (function (number) integer))
+ (logcount (function (integer) integer))
+ (logior (function (&rest (or integer marker)) integer))
+ (lognot (function (integer) integer))
+ (logxor (function (&rest (or integer marker)) integer))
+ ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
+ (lsh (function (integer integer) integer))
+ (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector))
+ (make-list (function (integer t) list))
+ (make-marker (function () marker))
+ (make-string (function (integer fixnum &optional t) string))
+ (make-symbol (function (string) symbol))
+ (mark (function (&optional t) (or integer null)))
+ (mark-marker (function () marker))
+ (marker-buffer (function (marker) buffer))
+ (markerp (function (t) boolean))
+ (max (function ((or number marker) &rest (or number marker)) number))
+ (max-char (function () fixnum))
+ (member (function (t list) list))
+ (memory-limit (function () integer))
+ (memq (function (t list) list))
+ (memql (function (t list) list))
+ (min (function ((or number marker) &rest (or number marker)) number))
+ (minibuffer-selected-window (function () window))
+ (minibuffer-window (function (&optional frame) window))
+ (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *))))
+ (mouse-movement-p (function (t) boolean))
+ (multibyte-char-to-unibyte (function (fixnum) fixnum))
+ (natnump (function (t) boolean))
+ (next-window (function (&optional window t t) window))
+ (nlistp (function (t) boolean))
+ (not (function (t) boolean))
+ (nth (function (integer list) t))
+ (nthcdr (function (integer t) t))
+ (null (function (t) boolean))
+ (number-or-marker-p (function (t) boolean))
+ (number-to-string (function (number) string))
+ (numberp (function (t) boolean))
+ (one-window-p (function (&optional t t) boolean))
+ (overlayp (function (t) boolean))
+ (parse-colon-path (function (string) cons))
+ (plist-get (function (list t) t))
+ (plist-member (function (list t) list))
+ (point (function () integer))
+ (point-marker (function () marker))
+ (point-max (function () integer))
+ (point-min (function () integer))
+ (preceding-char (function () fixnum))
+ (previous-window (function (&optional window t t) window))
+ (prin1-to-string (function (t &optional t) string))
+ (processp (function (t) boolean))
+ (proper-list-p (function (t) integer))
+ (propertize (function (string &rest t) string))
+ (radians-to-degrees (function (number) float))
+ (rassoc (function (t list) list))
+ (rassq (function (t list) list))
+ (read-from-string (function (string &optional integer integer) cons))
+ (recent-keys (function (&optional (or cons null)) vector))
+ (recursion-depth (function () integer))
+ (regexp-opt (function (list) string))
+ (regexp-quote (function (string) string))
+ (region-beginning (function () integer))
+ (region-end (function () integer))
+ (reverse (function (sequence) sequence))
+ (round (function (number &optional number) integer))
+ (safe-length (function (t) integer))
+ (selected-frame (function () frame))
+ (selected-window (function () window))
+ (sequencep (function (t) boolean))
+ (sin (function (number) float))
+ (sqrt (function (number) float))
+ (standard-case-table (function () char-table))
+ (standard-syntax-table (function () char-table))
+ (string (function (&rest fixnum) string))
+ (string-as-multibyte (function (string) string))
+ (string-as-unibyte (function (string) string))
+ (string-equal (function ((or string symbol) (or string symbol)) boolean))
+ (string-lessp (function ((or string symbol) (or string symbol)) boolean))
+ (string-make-multibyte (function (string) string))
+ (string-make-unibyte (function (string) string))
+ (string-search (function (string string &optional integer) (or integer null)))
+ (string-to-char (function (string) fixnum))
+ (string-to-multibyte (function (string) string))
+ (string-to-number (function (string &optional integer) number))
+ (string-to-syntax (function (string) cons))
+ (string< (function ((or string symbol) (or string symbol)) boolean))
+ (string= (function ((or string symbol) (or string symbol)) boolean))
+ (stringp (function (t) boolean))
+ (subrp (function (t) boolean))
+ (substring (function ((or string vector) &optional integer integer) (or string vector)))
+ (sxhash (function (t) integer))
+ (sxhash-eq (function (t) integer))
+ (sxhash-eql (function (t) integer))
+ (sxhash-equal (function (t) integer))
+ (symbol-function (function (symbol) t))
+ (symbol-name (function (symbol) string))
+ (symbol-plist (function (symbol) list))
+ (symbol-value (function (symbol) t))
+ (symbolp (function (t) boolean))
+ (syntax-table (function () char-table))
+ (syntax-table-p (function (t) boolean))
+ (tan (function (number) float))
+ (this-command-keys (function () string))
+ (this-command-keys-vector (function () vector))
+ (this-single-command-keys (function () vector))
+ (this-single-command-raw-keys (function () vector))
+ (time-convert (function (t &optional (or boolean integer)) cons))
+ (truncate (function (number &optional number) integer))
+ (type-of (function (t) symbol))
+ (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
+ (upcase (function ((or fixnum string)) (or fixnum string)))
+ (user-full-name (function (&optional integer) (or string null)))
+ (user-login-name (function (&optional integer) (or string null)))
+ (user-original-login-name (function (&optional integer) (or string null)))
+ (user-real-login-name (function () string))
+ (user-real-uid (function () integer))
+ (user-uid (function () integer))
+ (vconcat (function (&rest sequence) vector))
+ (vector (function (&rest t) vector))
+ (vectorp (function (t) boolean))
+ (visible-frame-list (function () list))
+ (wholenump (function (t) boolean))
+ (window-configuration-p (function (t) boolean))
+ (window-live-p (function (t) boolean))
+ (window-valid-p (function (t) boolean))
+ (windowp (function (t) boolean))
+ (zerop (function (number) boolean))
+ ;; Type hints
+ (comp-hint-fixnum (function (t) fixnum))
+ (comp-hint-cons (function (t) cons))
+ ;; Non returning functions
+ (throw (function (t t) nil))
+ (error (function (string &rest t) nil))
+ (signal (function (symbol t) nil)))
+ "Alist used for type propagation.")
+
+(defconst comp-known-func-cstr-h
+ (cl-loop
+ with comp-ctxt = (make-comp-cstr-ctxt)
+ with h = (make-hash-table :test #'eq)
+ for (f type-spec) in comp-known-type-specifiers
+ for cstr = (comp-type-spec-to-cstr type-spec)
+ do (puthash f cstr h)
+ finally return h)
+ "Hash table function -> `comp-constraint'.")
+
+(defconst comp-known-predicates
+ '((arrayp . array)
+ (atom . atom)
+ (characterp . fixnum)
+ (booleanp . boolean)
+ (bool-vector-p . bool-vector)
+ (bufferp . buffer)
+ (natnump . (integer 0 *))
+ (char-table-p . char-table)
+ (hash-table-p . hash-table)
+ (consp . cons)
+ (integerp . integer)
+ (floatp . float)
+ (functionp . (or function symbol))
+ (integerp . integer)
+ (keywordp . keyword)
+ (listp . list)
+ (numberp . number)
+ (null . null)
+ (numberp . number)
+ (sequencep . sequence)
+ (stringp . string)
+ (symbolp . symbol)
+ (vectorp . vector)
+ (integer-or-marker-p . integer-or-marker))
+ "Alist predicate -> matched type specifier.")
+
+(defconst comp-known-predicates-h
+ (cl-loop
+ with comp-ctxt = (make-comp-cstr-ctxt)
+ with h = (make-hash-table :test #'eq)
+ for (pred . type-spec) in comp-known-predicates
+ for cstr = (comp-type-spec-to-cstr type-spec)
+ do (puthash pred cstr h)
+ finally return h)
+ "Hash table function -> `comp-constraint'.")
+
+(defun comp-known-predicate-p (predicate)
+ "Return t if PREDICATE is known."
+ (when (gethash predicate comp-known-predicates-h) t))
+
+(defun comp-pred-to-cstr (predicate)
+ "Given PREDICATE, return the corresponding constraint."
+ (gethash predicate comp-known-predicates-h))
+
+(defconst comp-symbol-values-optimizable '(most-positive-fixnum
+ most-negative-fixnum)
+ "Symbol values we can resolve at compile-time.")
+
+(defconst comp-type-hints '(comp-hint-fixnum
+ comp-hint-cons)
+ "List of fake functions used to give compiler hints.")
+
+(defconst comp-limple-sets '(set
+ setimm
+ set-par-to-local
+ set-args-to-local
+ set-rest-args-to-local)
+ "Limple set operators.")
+
+(defconst comp-limple-assignments `(assume
+ fetch-handler
+ ,@comp-limple-sets)
+ "Limple operators that clobber the first m-var argument.")
+
+(defconst comp-limple-calls '(call
+ callref
+ direct-call
+ direct-callref)
+ "Limple operators used to call subrs.")
+
+(defconst comp-limple-branches '(jump cond-jump)
+ "Limple operators used for conditional and unconditional branches.")
+
+(defconst comp-limple-ops `(,@comp-limple-calls
+ ,@comp-limple-assignments
+ ,@comp-limple-branches
+ return)
+ "All Limple operators.")
+
+(defvar comp-func nil
+ "Bound to the current function by most passes.")
+
+(defvar comp-block nil
+ "Bound to the current basic block by some passes.")
+
+(define-error 'native-compiler-error-dyn-func
+ "can't native compile a non-lexically-scoped function"
+ 'native-compiler-error)
+(define-error 'native-compiler-error-empty-byte
+ "empty byte compiler output"
+ 'native-compiler-error)
+
+
+;; Moved early to avoid circularity when comp.el is loaded and
+;; `macroexpand' needs to be advised (bug#47049).
+;;;###autoload
+(defun comp-subr-trampoline-install (subr-name)
+ "Make SUBR-NAME effectively advice-able when called from native code."
+ (unless (or (null comp-enable-subr-trampolines)
+ (memq subr-name native-comp-never-optimize-functions)
+ (gethash subr-name comp-installed-trampolines-h))
+ (cl-assert (subr-primitive-p (symbol-function subr-name)))
+ (comp--install-trampoline
+ subr-name
+ (or (comp-trampoline-search subr-name)
+ (comp-trampoline-compile subr-name)
+ ;; Should never happen.
+ (cl-assert nil)))))
+
+
+(cl-defstruct (comp-vec (:copier nil))
+ "A re-sizable vector like object."
+ (data (make-hash-table :test #'eql) :type hash-table
+ :documentation "Payload data.")
+ (beg 0 :type integer)
+ (end 0 :type natnum))
+
+(defsubst comp-vec-copy (vec)
+ "Return a copy of VEC."
+ (make-comp-vec :data (copy-hash-table (comp-vec-data vec))
+ :beg (comp-vec-beg vec)
+ :end (comp-vec-end vec)))
+
+(defsubst comp-vec-length (vec)
+ "Return the number of elements of VEC."
+ (- (comp-vec-end vec) (comp-vec-beg vec)))
+
+(defsubst comp-vec--verify-idx (vec idx)
+ "Check whether IDX is in bounds for VEC."
+ (cl-assert (and (< idx (comp-vec-end vec))
+ (>= idx (comp-vec-beg vec)))))
+
+(defsubst comp-vec-aref (vec idx)
+ "Return the element of VEC whose index is IDX."
+ (declare (gv-setter (lambda (val)
+ `(comp-vec--verify-idx ,vec ,idx)
+ `(puthash ,idx ,val (comp-vec-data ,vec)))))
+ (comp-vec--verify-idx vec idx)
+ (gethash idx (comp-vec-data vec)))
+
+(defsubst comp-vec-append (vec elt)
+ "Append ELT into VEC.
+Returns ELT."
+ (puthash (comp-vec-end vec) elt (comp-vec-data vec))
+ (cl-incf (comp-vec-end vec))
+ elt)
+
+(defsubst comp-vec-prepend (vec elt)
+ "Prepend ELT into VEC.
+Returns ELT."
+ (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec))
+ (cl-decf (comp-vec-beg vec))
+ elt)
+
+
+
+(eval-when-compile
+ (defconst comp-op-stack-info
+ (cl-loop with h = (make-hash-table)
+ for k across byte-code-vector
+ for v across byte-stack+-info
+ when k
+ do (puthash k v h)
+ finally return h)
+ "Hash table lap-op -> stack adjustment."))
+
+(define-hash-table-test 'comp-imm-equal-test #'equal-including-properties
+ #'sxhash-equal-including-properties)
+
+(cl-defstruct comp-data-container
+ "Data relocation container structure."
+ (l () :type list
+ :documentation "Constant objects used by functions.")
+ (idx (make-hash-table :test 'comp-imm-equal-test) :type hash-table
+ :documentation "Obj -> position into the previous field."))
+
+(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt))
+ "Lisp side of the compiler context."
+ (output nil :type string
+ :documentation "Target output file-name for the compilation.")
+ (speed native-comp-speed :type number
+ :documentation "Default speed for this compilation unit.")
+ (debug native-comp-debug :type number
+ :documentation "Default debug level for this compilation unit.")
+ (driver-options native-comp-driver-options :type list
+ :documentation "Options for the GCC driver.")
+ (top-level-forms () :type list
+ :documentation "List of spilled top level forms.")
+ (funcs-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "c-name -> comp-func.")
+ (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table
+ :documentation "symbol-function -> c-name.
+This is only for optimizing intra CU calls at speed 3.")
+ (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "byte-function -> comp-func.
+Needed to replace immediate byte-compiled lambdas with the compiled reference.")
+ (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "Hash table byte-func -> mvar to fixup.")
+ (function-docs (make-hash-table :test #'eql) :type (or hash-table vector)
+ :documentation "Documentation index -> documentation")
+ (d-default (make-comp-data-container) :type comp-data-container
+ :documentation "Standard data relocated in use by functions.")
+ (d-impure (make-comp-data-container) :type comp-data-container
+ :documentation "Relocated data that cannot be moved into pure space.
+This is typically for top-level forms other than defun.")
+ (d-ephemeral (make-comp-data-container) :type comp-data-container
+ :documentation "Relocated data not necessary after load.")
+ (with-late-load nil :type boolean
+ :documentation "When non-nil support late load."))
+
+(cl-defstruct comp-args-base
+ (min nil :type integer
+ :documentation "Minimum number of arguments allowed."))
+
+(cl-defstruct (comp-args (:include comp-args-base))
+ (max nil :type integer
+ :documentation "Maximum number of arguments allowed."))
+
+(cl-defstruct (comp-nargs (:include comp-args-base))
+ "Describe args when the function signature is of kind:
+(ptrdiff_t nargs, Lisp_Object *args)."
+ (nonrest nil :type integer
+ :documentation "Number of non rest arguments.")
+ (rest nil :type boolean
+ :documentation "t if rest argument is present."))
+
+(cl-defstruct (comp-block (:copier nil)
+ (:constructor nil))
+ "A base class for basic blocks."
+ (name nil :type symbol)
+ (insns () :type list
+ :documentation "List of instructions.")
+ (closed nil :type boolean
+ :documentation "t if closed.")
+ ;; All the following are for SSA and CGF analysis.
+ ;; Keep in sync with `comp-clean-ssa'!!
+ (in-edges () :type list
+ :documentation "List of incoming edges.")
+ (out-edges () :type list
+ :documentation "List of out-coming edges.")
+ (idom nil :type (or null comp-block)
+ :documentation "Immediate dominator.")
+ (df (make-hash-table) :type (or null hash-table)
+ :documentation "Dominance frontier set. Block-name -> block")
+ (post-num nil :type (or null number)
+ :documentation "Post order number.")
+ (final-frame nil :type (or null comp-vec)
+ :documentation "This is a copy of the frame when leaving the block.
+Is in use to help the SSA rename pass."))
+
+(cl-defstruct (comp-block-lap (:copier nil)
+ (:include comp-block)
+ (:constructor make--comp-block-lap
+ (addr sp name))) ; Positional
+ "A basic block created from lap (real code)."
+ ;; These two slots are used during limplification.
+ (sp nil :type number
+ :documentation "When non-nil indicates the sp value while entering
+into it.")
+ (addr nil :type number
+ :documentation "Start block LAP address.")
+ (non-ret-insn nil :type list
+ :documentation "Insn known to perform a non local exit.
+`comp-fwprop' may identify and store here basic blocks performing
+non local exits and mark it rewrite it later.")
+ (no-ret nil :type boolean
+ :documentation "t when the block is known to perform a
+non local exit (ends with an `unreachable' insn)."))
+
+(cl-defstruct (comp-latch (:copier nil)
+ (:include comp-block))
+ "A basic block for a latch loop.")
+
+(cl-defstruct (comp-block-cstr (:copier nil)
+ (:include comp-block))
+ "A basic block holding only constraints.")
+
+(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge))
+ "An edge connecting two basic blocks."
+ (src nil :type (or null comp-block))
+ (dst nil :type (or null comp-block))
+ (number nil :type number
+ :documentation "The index number corresponding to this edge in the
+ edge hash."))
+
+(defun make-comp-edge (&rest args)
+ "Create a `comp-edge' with basic blocks SRC and DST."
+ (let ((n (funcall (comp-func-edge-cnt-gen comp-func))))
+ (puthash
+ n
+ (apply #'make--comp-edge :number n args)
+ (comp-func-edges-h comp-func))))
+
+(defun comp-block-preds (basic-block)
+ "Return the list of predecessors of BASIC-BLOCK."
+ (mapcar #'comp-edge-src (comp-block-in-edges basic-block)))
+
+(defun comp-gen-counter ()
+ "Return a sequential number generator."
+ (let ((n -1))
+ (lambda ()
+ (cl-incf n))))
+
+(cl-defstruct (comp-func (:copier nil))
+ "LIMPLE representation of a function."
+ (name nil :type symbol
+ :documentation "Function symbol name. Nil indicates anonymous.")
+ (c-name nil :type string
+ :documentation "The function name in the native world.")
+ (byte-func nil
+ :documentation "Byte-compiled version.")
+ (doc nil :type string
+ :documentation "Doc string.")
+ (int-spec nil :type list
+ :documentation "Interactive form.")
+ (lap () :type list
+ :documentation "LAP assembly representation.")
+ (ssa-status nil :type symbol
+ :documentation "SSA status either: 'nil', 'dirty' or 't'.
+Once in SSA form this *must* be set to 'dirty' every time the topology of the
+CFG is mutated by a pass.")
+ (frame-size nil :type integer)
+ (vframe-size 0 :type integer)
+ (blocks (make-hash-table :test #'eq) :type hash-table
+ :documentation "Basic block symbol -> basic block.")
+ (lap-block (make-hash-table :test #'equal) :type hash-table
+ :documentation "LAP label -> LIMPLE basic block name.")
+ (edges-h (make-hash-table) :type hash-table
+ :documentation "Hash edge-num -> edge connecting basic two blocks.")
+ (block-cnt-gen (funcall #'comp-gen-counter) :type function
+ :documentation "Generates block numbers.")
+ (edge-cnt-gen (funcall #'comp-gen-counter) :type function
+ :documentation "Generates edges numbers.")
+ (has-non-local nil :type boolean
+ :documentation "t if non local jumps are present.")
+ (speed nil :type number
+ :documentation "Optimization level (see `native-comp-speed').")
+ (pure nil :type boolean
+ :documentation "t if pure nil otherwise.")
+ (type nil :type (or null comp-mvar)
+ :documentation "Mvar holding the derived return type."))
+
+(cl-defstruct (comp-func-l (:include comp-func))
+ "Lexically-scoped function."
+ (args nil :type comp-args-base
+ :documentation "Argument specification of the function"))
+
+(cl-defstruct (comp-func-d (:include comp-func))
+ "Dynamically-scoped function."
+ (lambda-list nil :type list
+ :documentation "Original lambda-list."))
+
+(cl-defstruct (comp-mvar (:constructor make--comp-mvar)
+ (:include comp-cstr))
+ "A meta-variable being a slot in the meta-stack."
+ (id nil :type (or null number)
+ :documentation "Unique id when in SSA form.")
+ (slot nil :type (or fixnum symbol)
+ :documentation "Slot number in the array if a number or
+ 'scratch' for scratch slot."))
+
+(defun comp-mvar-type-hint-match-p (mvar type-hint)
+ "Match MVAR against TYPE-HINT.
+In use by the back-end."
+ (cl-ecase type-hint
+ (cons (comp-cstr-cons-p mvar))
+ (fixnum (comp-cstr-fixnum-p mvar))))
+
+
+
+(defun comp-ensure-native-compiler ()
+ "Make sure Emacs has native compiler support and libgccjit can be loaded.
+Signal an error otherwise.
+To be used by all entry points."
+ (cond
+ ((null (featurep 'native-compile))
+ (error "Emacs was not compiled with native compiler support (--with-native-compilation)"))
+ ((null (native-comp-available-p))
+ (error "Cannot find libgccjit library"))))
+
+(defun comp-equality-fun-p (function)
+ "Equality functions predicate for FUNCTION."
+ (when (memq function '(eq eql equal)) t))
+
+(defun comp-arithm-cmp-fun-p (function)
+ "Predicate for arithmetic comparison functions."
+ (when (memq function '(= > < >= <=)) t))
+
+(defun comp-set-op-p (op)
+ "Assignment predicate for OP."
+ (when (memq op comp-limple-sets) t))
+
+(defun comp-assign-op-p (op)
+ "Assignment predicate for OP."
+ (when (memq op comp-limple-assignments) t))
+
+(defun comp-call-op-p (op)
+ "Call predicate for OP."
+ (when (memq op comp-limple-calls) t))
+
+(defun comp-branch-op-p (op)
+ "Branch predicate for OP."
+ (when (memq op comp-limple-branches) t))
+
+(defsubst comp-limple-insn-call-p (insn)
+ "Limple INSN call predicate."
+ (comp-call-op-p (car-safe insn)))
+
+(defun comp-type-hint-p (func)
+ "Type-hint predicate for function name FUNC."
+ (when (memq func comp-type-hints) t))
+
+(defun comp-func-unique-in-cu-p (func)
+ "Return t if FUNC is known to be unique in the current compilation unit."
+ (if (symbolp func)
+ (cl-loop with h = (make-hash-table :test #'eq)
+ for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
+ for name = (comp-func-name f)
+ when (gethash name h)
+ return nil
+ do (puthash name t h)
+ finally return t)
+ t))
+
+(defsubst comp-symbol-func-to-fun (symbol-funcion)
+ "Given a function called SYMBOL-FUNCION return its `comp-func'."
+ (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h
+ comp-ctxt))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+(defun comp-function-pure-p (f)
+ "Return t if F is pure."
+ (or (get f 'pure)
+ (when-let ((func (comp-symbol-func-to-fun f)))
+ (comp-func-pure func))))
+
+(defun comp-alloc-class-to-container (alloc-class)
+ "Given ALLOC-CLASS, return the data container for the current context.
+Assume allocation class 'd-default as default."
+ (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt))
+
+(defsubst comp-add-const-to-relocs (obj)
+ "Keep track of OBJ into the ctxt relocations."
+ (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container
+ comp-curr-allocation-class))))
+
+
+;;; Log routines.
+
+(defconst comp-limple-lock-keywords
+ `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
+ (,(rx "#(" (group-n 1 "mvar"))
+ (1 font-lock-function-name-face))
+ (,(rx bol "(" (group-n 1 "phi"))
+ (1 font-lock-variable-name-face))
+ (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
+ (1 font-lock-warning-face))
+ (,(rx (group-n 1 (or "entry"
+ (seq (or "entry_" "entry_fallback_" "bb_")
+ (1+ num) (? (or "_latch"
+ (seq "_cstrs_" (1+ num))))))))
+ (1 font-lock-constant-face))
+ (,(rx-to-string
+ `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
+ (1 font-lock-keyword-face)))
+ "Highlights used by `native-comp-limple-mode'.")
+
+(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
+ "Syntax-highlight LIMPLE IR."
+ (setf font-lock-defaults '(comp-limple-lock-keywords)))
+
+(cl-defun comp-log (data &optional (level 1) quoted)
+ "Log DATA at LEVEL.
+LEVEL is a number from 1-3, and defaults to 1; if it is less
+than `native-comp-verbose', do nothing. If `noninteractive', log
+with `message'. Otherwise, log with `comp-log-to-buffer'."
+ (when (>= native-comp-verbose level)
+ (if noninteractive
+ (cl-typecase data
+ (atom (message "%s" data))
+ (t (dolist (elem data)
+ (message "%s" elem))))
+ (comp-log-to-buffer data quoted))))
+
+(cl-defun comp-log-to-buffer (data &optional quoted)
+ "Log DATA to `comp-log-buffer-name'."
+ (let* ((print-f (if quoted #'prin1 #'princ))
+ (log-buffer
+ (or (get-buffer comp-log-buffer-name)
+ (with-current-buffer (get-buffer-create comp-log-buffer-name)
+ (setf buffer-read-only t)
+ (current-buffer))))
+ (log-window (get-buffer-window log-buffer))
+ (inhibit-read-only t)
+ at-end-p)
+ (with-current-buffer log-buffer
+ (unless (eq major-mode 'native-comp-limple-mode)
+ (native-comp-limple-mode))
+ (when (= (point) (point-max))
+ (setf at-end-p t))
+ (save-excursion
+ (goto-char (point-max))
+ (cl-typecase data
+ (atom (funcall print-f data log-buffer))
+ (t (dolist (elem data)
+ (funcall print-f elem log-buffer)
+ (insert "\n"))))
+ (insert "\n"))
+ (when (and at-end-p log-window)
+ ;; When log window's point is at the end, follow the tail.
+ (with-selected-window log-window
+ (goto-char (point-max)))))))
+
+(defun comp-prettyformat-mvar (mvar)
+ (format "#(mvar %s %s %S)"
+ (comp-mvar-id mvar)
+ (comp-mvar-slot mvar)
+ (comp-cstr-to-type-spec mvar)))
+
+(defun comp-prettyformat-insn (insn)
+ (cl-typecase insn
+ (comp-mvar (comp-prettyformat-mvar insn))
+ (atom (prin1-to-string insn))
+ (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")"))))
+
+(defun comp-log-func (func verbosity)
+ "Log function FUNC at VERBOSITY.
+VERBOSITY is a number between 0 and 3."
+ (when (>= native-comp-verbose verbosity)
+ (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity)
+ (cl-loop
+ for block-name being each hash-keys of (comp-func-blocks func)
+ using (hash-value bb)
+ do (comp-log (concat "<" (symbol-name block-name) ">") verbosity)
+ (cl-loop
+ for insn in (comp-block-insns bb)
+ do (comp-log (comp-prettyformat-insn insn) verbosity)))))
+
+(defun comp-log-edges (func)
+ "Log edges in FUNC."
+ (let ((edges (comp-func-edges-h func)))
+ (comp-log (format "\nEdges in function: %s\n"
+ (comp-func-name func))
+ 2)
+ (maphash (lambda (_ e)
+ (comp-log (format "n: %d src: %s dst: %s\n"
+ (comp-edge-number e)
+ (comp-block-name (comp-edge-src e))
+ (comp-block-name (comp-edge-dst e)))
+ 2))
+ edges)))
+
+
+
+(defmacro comp-loop-insn-in-block (basic-block &rest body)
+ "Loop over all insns in BASIC-BLOCK executing BODY.
+Inside BODY, `insn' and `insn-cell'can be used to read or set the
+current instruction or its cell."
+ (declare (debug (form body))
+ (indent defun))
+ `(cl-symbol-macrolet ((insn (car insn-cell)))
+ (let ((insn-cell (comp-block-insns ,basic-block)))
+ (while insn-cell
+ ,@body
+ (setf insn-cell (cdr insn-cell))))))
+
+;;; spill-lap pass specific code.
+
+(defun comp-lex-byte-func-p (f)
+ "Return t if F is a lexically-scoped byte compiled function."
+ (and (byte-code-function-p f)
+ (fixnump (aref f 0))))
+
+(defun comp-spill-decl-spec (function-name spec)
+ "Return the declared specifier SPEC for FUNCTION-NAME."
+ (plist-get (cdr (assq function-name byte-to-native-plist-environment))
+ spec))
+
+(defun comp-spill-speed (function-name)
+ "Return the speed for FUNCTION-NAME."
+ (or (comp-spill-decl-spec function-name 'speed)
+ (comp-ctxt-speed comp-ctxt)))
+
+;; Autoloaded as might be used by `disassemble-internal'.
+;;;###autoload
+(defun comp-c-func-name (name prefix &optional first)
+ "Given NAME, return a name suitable for the native code.
+Add PREFIX in front of it. If FIRST is not nil, pick the first
+available name ignoring compilation context and potential name
+clashes."
+ ;; Unfortunately not all symbol names are valid as C function names...
+ ;; Nassi's algorithm here:
+ (let* ((orig-name (if (symbolp name) (symbol-name name) name))
+ (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0)
+ for j from 0 by 2
+ for i across orig-name
+ for byte = (format "%x" i)
+ do (aset str j (aref byte 0))
+ (aset str (1+ j) (aref byte 1))
+ finally return str))
+ (human-readable (replace-regexp-in-string
+ "-" "_" orig-name))
+ (human-readable (replace-regexp-in-string
+ (rx (not (any "0-9a-z_"))) "" human-readable)))
+ (if (null first)
+ ;; Prevent C namespace conflicts.
+ (cl-loop
+ with h = (comp-ctxt-funcs-h comp-ctxt)
+ for i from 0
+ for c-sym = (concat prefix crypted "_" human-readable "_"
+ (number-to-string i))
+ unless (gethash c-sym h)
+ return c-sym)
+ ;; When called out of a compilation context (ex disassembling)
+ ;; pick the first one.
+ (concat prefix crypted "_" human-readable "_0"))))
+
+(defun comp-decrypt-arg-list (x function-name)
+ "Decrypt argument list X for FUNCTION-NAME."
+ (unless (fixnump x)
+ (signal 'native-compiler-error-dyn-func function-name))
+ (let ((rest (not (= (logand x 128) 0)))
+ (mandatory (logand x 127))
+ (nonrest (ash x -8)))
+ (if (and (null rest)
+ (< nonrest 9)) ;; SUBR_MAX_ARGS
+ (make-comp-args :min mandatory
+ :max nonrest)
+ (make-comp-nargs :min mandatory
+ :nonrest nonrest
+ :rest rest))))
+
+(defsubst comp-byte-frame-size (byte-compiled-func)
+ "Return the frame size to be allocated for BYTE-COMPILED-FUNC."
+ (aref byte-compiled-func 3))
+
+(defun comp-add-func-to-ctxt (func)
+ "Add FUNC to the current compiler context."
+ (let ((name (comp-func-name func))
+ (c-name (comp-func-c-name func)))
+ (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
+ (puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
+
+(cl-defgeneric comp-spill-lap-function (input)
+ "Byte-compile INPUT and spill lap for further stages.")
+
+(cl-defmethod comp-spill-lap-function ((function-name symbol))
+ "Byte-compile FUNCTION-NAME, spilling data from the byte compiler."
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt)
+ (make-temp-file (comp-c-func-name function-name "freefn-")
+ nil ".eln")))
+ (let* ((f (symbol-function function-name))
+ (c-name (comp-c-func-name function-name "F"))
+ (func (make-comp-func-l :name function-name
+ :c-name c-name
+ :doc (documentation f t)
+ :int-spec (interactive-form f)
+ :speed (comp-spill-speed function-name)
+ :pure (comp-spill-decl-spec function-name
+ 'pure))))
+ (when (byte-code-function-p f)
+ (signal 'native-compiler-error
+ "can't native compile an already byte-compiled function"))
+ (setf (comp-func-byte-func func)
+ (byte-compile (comp-func-name func)))
+ (let ((lap (byte-to-native-lambda-lap
+ (gethash (aref (comp-func-byte-func func) 1)
+ byte-to-native-lambdas-h))))
+ (cl-assert lap)
+ (comp-log lap 2 t)
+ (let ((arg-list (aref (comp-func-byte-func func) 0)))
+ (setf (comp-func-l-args func)
+ (comp-decrypt-arg-list arg-list function-name)
+ (comp-func-lap func)
+ lap
+ (comp-func-frame-size func)
+ (comp-byte-frame-size (comp-func-byte-func func))))
+ (setf (comp-ctxt-top-level-forms comp-ctxt)
+ (list (make-byte-to-native-func-def :name function-name
+ :c-name c-name)))
+ (comp-add-func-to-ctxt func))))
+
+(cl-defmethod comp-spill-lap-function ((form list))
+ "Byte-compile FORM, spilling data from the byte compiler."
+ (unless (eq (car-safe form) 'lambda)
+ (signal 'native-compiler-error
+ "Cannot native-compile, form is not a lambda"))
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt)
+ (make-temp-file "comp-lambda-" nil ".eln")))
+ (let* ((byte-code (byte-compile form))
+ (c-name (comp-c-func-name "anonymous-lambda" "F"))
+ (func (if (comp-lex-byte-func-p byte-code)
+ (make-comp-func-l :c-name c-name
+ :doc (documentation form t)
+ :int-spec (interactive-form form)
+ :speed (comp-ctxt-speed comp-ctxt))
+ (make-comp-func-d :c-name c-name
+ :doc (documentation form t)
+ :int-spec (interactive-form form)
+ :speed (comp-ctxt-speed comp-ctxt)))))
+ (let ((lap (byte-to-native-lambda-lap
+ (gethash (aref byte-code 1)
+ byte-to-native-lambdas-h))))
+ (cl-assert lap)
+ (comp-log lap 2 t)
+ (if (comp-func-l-p func)
+ (setf (comp-func-l-args func)
+ (comp-decrypt-arg-list (aref byte-code 0) byte-code))
+ (setf (comp-func-d-lambda-list func) (cadr form)))
+ (setf (comp-func-lap func) lap
+ (comp-func-frame-size func) (comp-byte-frame-size
+ byte-code))
+ (setf (comp-func-byte-func func) byte-code
+ (comp-ctxt-top-level-forms comp-ctxt)
+ (list (make-byte-to-native-func-def :name '--anonymous-lambda
+ :c-name c-name)))
+ (comp-add-func-to-ctxt func))))
+
+(defun comp-intern-func-in-ctxt (_ obj)
+ "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'."
+ (when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
+ (let* ((lap (byte-to-native-lambda-lap obj))
+ (top-l-form (cl-loop
+ for form in (comp-ctxt-top-level-forms comp-ctxt)
+ when (and (byte-to-native-func-def-p form)
+ (eq (byte-to-native-func-def-byte-func form)
+ byte-func))
+ return form))
+ (name (when top-l-form
+ (byte-to-native-func-def-name top-l-form)))
+ (c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
+ (func (if (comp-lex-byte-func-p byte-func)
+ (make-comp-func-l
+ :args (comp-decrypt-arg-list (aref byte-func 0)
+ name))
+ (make-comp-func-d :lambda-list (aref byte-func 0)))))
+ (setf (comp-func-name func) name
+ (comp-func-byte-func func) byte-func
+ (comp-func-doc func) (documentation byte-func t)
+ (comp-func-int-spec func) (interactive-form byte-func)
+ (comp-func-c-name func) c-name
+ (comp-func-lap func) lap
+ (comp-func-frame-size func) (comp-byte-frame-size byte-func)
+ (comp-func-speed func) (comp-spill-speed name)
+ (comp-func-pure func) (comp-spill-decl-spec name 'pure))
+
+ ;; Store the c-name to have it retrievable from
+ ;; `comp-ctxt-top-level-forms'.
+ (when top-l-form
+ (setf (byte-to-native-func-def-c-name top-l-form) c-name))
+ (unless name
+ (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
+ (comp-add-func-to-ctxt func)
+ (comp-log (format "Function %s:\n" name) 1)
+ (comp-log lap 1 t))))
+
+(cl-defmethod comp-spill-lap-function ((filename string))
+ "Byte-compile FILENAME, spilling data from the byte compiler."
+ (byte-compile-file filename)
+ (when (or (null byte-native-qualities)
+ (alist-get 'no-native-compile byte-native-qualities))
+ (throw 'no-native-compile nil))
+ (unless byte-to-native-top-level-forms
+ (signal 'native-compiler-error-empty-byte filename))
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename
+ filename
+ (or native-compile-target-directory
+ (when byte+native-compile
+ (car (last native-comp-eln-load-path)))))))
+ (setf (comp-ctxt-speed comp-ctxt) (alist-get 'native-comp-speed
+ byte-native-qualities)
+ (comp-ctxt-debug comp-ctxt) (alist-get 'native-comp-debug
+ byte-native-qualities)
+ (comp-ctxt-driver-options comp-ctxt) (alist-get 'native-comp-driver-options
+ byte-native-qualities)
+ (comp-ctxt-top-level-forms comp-ctxt)
+ (cl-loop
+ for form in (reverse byte-to-native-top-level-forms)
+ collect
+ (if (and (byte-to-native-func-def-p form)
+ (eq -1
+ (comp-spill-speed (byte-to-native-func-def-name form))))
+ (let ((byte-code (byte-to-native-func-def-byte-func form)))
+ (remhash byte-code byte-to-native-lambdas-h)
+ (make-byte-to-native-top-level
+ :form `(defalias
+ ',(byte-to-native-func-def-name form)
+ ,byte-code
+ nil)
+ :lexical (comp-lex-byte-func-p byte-code)))
+ form)))
+ (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
+
+(defun comp-spill-lap (input)
+ "Byte-compile and spill the LAP representation for INPUT.
+If INPUT is a symbol, it is the function-name to be compiled.
+If INPUT is a string, it is the filename to be compiled."
+ (let ((byte-native-compiling t)
+ (byte-to-native-lambdas-h (make-hash-table :test #'eq))
+ (byte-to-native-top-level-forms ())
+ (byte-to-native-plist-environment ()))
+ (comp-spill-lap-function input)))
+
+
+;;; Limplification pass specific code.
+
+(cl-defstruct (comp-limplify (:copier nil))
+ "Support structure used during function limplification."
+ (frame nil :type (or null comp-vec)
+ :documentation "Meta-stack used to flat LAP.")
+ (curr-block nil :type comp-block
+ :documentation "Current block being limplified.")
+ (sp -1 :type number
+ :documentation "Current stack pointer while walking LAP.
+Points to the next slot to be filled.")
+ (pc 0 :type number
+ :documentation "Current program counter while walking LAP.")
+ (label-to-addr nil :type hash-table
+ :documentation "LAP hash table -> address.")
+ (pending-blocks () :type list
+ :documentation "List of blocks waiting for limplification."))
+
+(defconst comp-lap-eob-ops
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop byte-return byte-pushcatch
+ byte-switch byte-pushconditioncase)
+ "LAP end of basic blocks op codes.")
+
+(defun comp-lap-eob-p (inst)
+ "Return t if INST closes the current basic blocks, nil otherwise."
+ (when (memq (car inst) comp-lap-eob-ops)
+ t))
+
+(defun comp-lap-fall-through-p (inst)
+ "Return t if INST falls through, nil otherwise."
+ (when (not (memq (car inst) '(byte-goto byte-return)))
+ t))
+
+(defsubst comp-sp ()
+ "Current stack pointer."
+ (declare (gv-setter (lambda (val)
+ `(setf (comp-limplify-sp comp-pass) ,val))))
+ (comp-limplify-sp comp-pass))
+
+(defmacro comp-with-sp (sp &rest body)
+ "Execute BODY setting the stack pointer to SP.
+Restore the original value afterwards."
+ (declare (debug (form body))
+ (indent defun))
+ (let ((sym (gensym)))
+ `(let ((,sym (comp-sp)))
+ (setf (comp-sp) ,sp)
+ (progn ,@body)
+ (setf (comp-sp) ,sym))))
+
+(defsubst comp-slot-n (n)
+ "Slot N into the meta-stack."
+ (comp-vec-aref (comp-limplify-frame comp-pass) n))
+
+(defsubst comp-slot ()
+ "Current slot into the meta-stack pointed by sp."
+ (comp-slot-n (comp-sp)))
+
+(defsubst comp-slot+1 ()
+ "Slot into the meta-stack pointed by sp + 1."
+ (comp-slot-n (1+ (comp-sp))))
+
+(defsubst comp-label-to-addr (label)
+ "Find the address of LABEL."
+ (or (gethash label (comp-limplify-label-to-addr comp-pass))
+ (signal 'native-ice (list "label not found" label))))
+
+(defsubst comp-mark-curr-bb-closed ()
+ "Mark the current basic block as closed."
+ (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
+
+(defun comp-bb-maybe-add (lap-addr &optional sp)
+ "If necessary create a pending basic block for LAP-ADDR with stack depth SP.
+The basic block is returned regardless it was already declared or not."
+ (let ((bb (or (cl-loop ; See if the block was already limplified.
+ for bb being the hash-value in (comp-func-blocks comp-func)
+ when (and (comp-block-lap-p bb)
+ (equal (comp-block-lap-addr bb) lap-addr))
+ return bb)
+ (cl-find-if (lambda (bb) ; Look within the pendings blocks.
+ (and (comp-block-lap-p bb)
+ (= (comp-block-lap-addr bb) lap-addr)))
+ (comp-limplify-pending-blocks comp-pass)))))
+ (if bb
+ (progn
+ (unless (or (null sp) (= sp (comp-block-lap-sp bb)))
+ (signal 'native-ice (list "incoherent stack pointers"
+ sp (comp-block-lap-sp bb))))
+ bb)
+ (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym))
+ (comp-limplify-pending-blocks comp-pass))))))
+
+(defsubst comp-call (func &rest args)
+ "Emit a call for function FUNC with ARGS."
+ `(call ,func ,@args))
+
+(defun comp-callref (func nargs stack-off)
+ "Emit a call using narg abi for FUNC.
+NARGS is the number of arguments.
+STACK-OFF is the index of the first slot frame involved."
+ `(callref ,func ,@(cl-loop repeat nargs
+ for sp from stack-off
+ collect (comp-slot-n sp))))
+
+(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+ "`comp-mvar' initializer."
+ (let ((mvar (make--comp-mvar :slot slot)))
+ (when const-vld
+ (comp-add-const-to-relocs constant)
+ (setf (comp-cstr-imm mvar) constant))
+ (when type
+ (setf (comp-mvar-typeset mvar) (list type)))
+ mvar))
+
+(defun comp-new-frame (size vsize &optional ssa)
+ "Return a clean frame of meta variables of size SIZE and VSIZE.
+If SSA is non-nil, populate it with m-var in ssa form."
+ (cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
+ for i from (- vsize) below size
+ for mvar = (if ssa
+ (make-comp-ssa-mvar :slot i)
+ (make-comp-mvar :slot i))
+ do (setf (comp-vec-aref v i) mvar)
+ finally return v))
+
+(defun comp-emit (insn)
+ "Emit INSN into basic block BB."
+ (let ((bb (comp-limplify-curr-block comp-pass)))
+ (cl-assert (not (comp-block-closed bb)))
+ (push insn (comp-block-insns bb))))
+
+(defun comp-emit-set-call (call)
+ "Emit CALL assigning the result to the current slot frame.
+If the callee function is known to have a return type, propagate it."
+ (cl-assert call)
+ (comp-emit (list 'set (comp-slot) call)))
+
+(defun comp-copy-slot (src-n &optional dst-n)
+ "Set slot number DST-N to slot number SRC-N as source.
+If DST-N is specified, use it; otherwise assume it to be the current slot."
+ (comp-with-sp (or dst-n (comp-sp))
+ (let ((src-slot (comp-slot-n src-n)))
+ (cl-assert src-slot)
+ (comp-emit `(set ,(comp-slot) ,src-slot)))))
+
+(defsubst comp-emit-annotation (str)
+ "Emit annotation STR."
+ (comp-emit `(comment ,str)))
+
+(defsubst comp-emit-setimm (val)
+ "Set constant VAL to current slot."
+ (comp-add-const-to-relocs val)
+ ;; Leave relocation index nil on purpose, will be fixed-up in final
+ ;; by `comp-finalize-relocs'.
+ (comp-emit `(setimm ,(comp-slot) ,val)))
+
+(defun comp-make-curr-block (block-name entry-sp &optional addr)
+ "Create a basic block with BLOCK-NAME and set it as current block.
+ENTRY-SP is the sp value when entering.
+Add block to the current function and return it."
+ (let ((bb (make--comp-block-lap addr entry-sp block-name)))
+ (setf (comp-limplify-curr-block comp-pass) bb
+ (comp-limplify-pc comp-pass) addr
+ (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb)
+ (comp-block-lap-sp bb)))
+ (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
+ bb))
+
+(defun comp-latch-make-fill (target)
+ "Create a latch pointing to TARGET and fill it.
+Return the created latch."
+ (let ((latch (make-comp-latch :name (comp-new-block-sym "latch")))
+ (curr-bb (comp-limplify-curr-block comp-pass)))
+ ;; See `comp-make-curr-block'.
+ (setf (comp-limplify-curr-block comp-pass) latch)
+ (when (< (comp-func-speed comp-func) 3)
+ ;; At speed 3 the programmer is responsible to manually
+ ;; place `comp-maybe-gc-or-quit'.
+ (comp-emit '(call comp-maybe-gc-or-quit)))
+ ;; See `comp-emit-uncond-jump'.
+ (comp-emit `(jump ,(comp-block-name target)))
+ (comp-mark-curr-bb-closed)
+ (puthash (comp-block-name latch) latch (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) curr-bb)
+ latch))
+
+(defun comp-emit-uncond-jump (lap-label)
+ "Emit an unconditional branch to LAP-LABEL."
+ (cl-destructuring-bind (label-num . stack-depth) lap-label
+ (when stack-depth
+ (cl-assert (= (1- stack-depth) (comp-sp))))
+ (let* ((target-addr (comp-label-to-addr label-num))
+ (target (comp-bb-maybe-add target-addr
+ (comp-sp)))
+ (latch (when (< target-addr (comp-limplify-pc comp-pass))
+ (comp-latch-make-fill target)))
+ (eff-target-name (comp-block-name (or latch target))))
+ (comp-emit `(jump ,eff-target-name))
+ (comp-mark-curr-bb-closed))))
+
+(defun comp-emit-cond-jump (a b target-offset lap-label negated)
+ "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
+TARGET-OFFSET is the positive offset on the SP when branching to the target
+block.
+If NEGATED is non null, negate the tested condition.
+Return value is the fall-through block name."
+ (cl-destructuring-bind (label-num . label-sp) lap-label
+ (let* ((bb (comp-block-name (comp-bb-maybe-add
+ (1+ (comp-limplify-pc comp-pass))
+ (comp-sp)))) ; Fall through block.
+ (target-sp (+ target-offset (comp-sp)))
+ (target-addr (comp-label-to-addr label-num))
+ (target (comp-bb-maybe-add target-addr target-sp))
+ (latch (when (< target-addr (comp-limplify-pc comp-pass))
+ (comp-latch-make-fill target)))
+ (eff-target-name (comp-block-name (or latch target))))
+ (when label-sp
+ (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))))
+ (comp-emit (if negated
+ (list 'cond-jump a b bb eff-target-name)
+ (list 'cond-jump a b eff-target-name bb)))
+ (comp-mark-curr-bb-closed)
+ bb)))
+
+(defun comp-emit-handler (lap-label handler-type)
+ "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE."
+ (cl-destructuring-bind (label-num . label-sp) lap-label
+ (cl-assert (= (- label-sp 2) (comp-sp)))
+ (setf (comp-func-has-non-local comp-func) t)
+ (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp-sp)))
+ (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num)
+ (1+ (comp-sp))))
+ (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym))))
+ (comp-emit (list 'push-handler
+ handler-type
+ (comp-slot+1)
+ (comp-block-name pop-bb)
+ (comp-block-name guarded-bb)))
+ (comp-mark-curr-bb-closed)
+ ;; Emit the basic block to pop the handler if we got the non local.
+ (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) pop-bb)
+ (comp-emit `(fetch-handler ,(comp-slot+1)))
+ (comp-emit `(jump ,(comp-block-name handler-bb)))
+ (comp-mark-curr-bb-closed))))
+
+(defun comp-limplify-listn (n)
+ "Limplify list N."
+ (comp-with-sp (+ (comp-sp) n -1)
+ (comp-emit-set-call (comp-call 'cons
+ (comp-slot)
+ (make-comp-mvar :constant nil))))
+ (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp)
+ do (comp-with-sp sp
+ (comp-emit-set-call (comp-call 'cons
+ (comp-slot)
+ (comp-slot+1))))))
+
+(defun comp-new-block-sym (&optional postfix)
+ "Return a unique symbol postfixing POSTFIX naming the next new basic block."
+ (intern (format (if postfix "bb_%s_%s" "bb_%s")
+ (funcall (comp-func-block-cnt-gen comp-func))
+ postfix)))
+
+(defun comp-fill-label-h ()
+ "Fill label-to-addr hash table for the current function."
+ (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql))
+ (cl-loop for insn in (comp-func-lap comp-func)
+ for addr from 0
+ do (pcase insn
+ (`(TAG ,label . ,_)
+ (puthash label addr (comp-limplify-label-to-addr comp-pass))))))
+
+(defun comp-jump-table-optimizable (jmp-table)
+ "Return t if JMP-TABLE can be optimized out."
+ (cl-loop
+ with labels = (cl-loop for target-label being each hash-value of jmp-table
+ collect target-label)
+ with x = (car labels)
+ for l in (cdr-safe labels)
+ unless (= l x)
+ return nil
+ finally return t))
+
+(defun comp-emit-switch (var last-insn)
+ "Emit a Limple for a lap jump table given VAR and LAST-INSN."
+ ;; FIXME this not efficient for big jump tables. We should have a second
+ ;; strategy for this case.
+ (pcase last-insn
+ (`(setimm ,_ ,jmp-table)
+ (unless (comp-jump-table-optimizable jmp-table)
+ (cl-loop
+ for test being each hash-keys of jmp-table
+ using (hash-value target-label)
+ with len = (hash-table-count jmp-table)
+ with test-func = (hash-table-test jmp-table)
+ for n from 1
+ for last = (= n len)
+ for m-test = (make-comp-mvar :constant test)
+ for target-name = (comp-block-name (comp-bb-maybe-add
+ (comp-label-to-addr target-label)
+ (comp-sp)))
+ for ff-bb = (if last
+ (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp-sp))
+ (make--comp-block-lap nil
+ (comp-sp)
+ (comp-new-block-sym)))
+ for ff-bb-name = (comp-block-name ff-bb)
+ if (eq test-func 'eq)
+ do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name))
+ else
+ ;; Store the result of the comparison into the scratch slot before
+ ;; emitting the conditional jump.
+ do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
+ (comp-call test-func var m-test)))
+ (comp-emit (list 'cond-jump
+ (make-comp-mvar :slot 'scratch)
+ (make-comp-mvar :constant nil)
+ ff-bb-name target-name))
+ unless last
+ ;; All fall through are artificially created here except the last one.
+ do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) ff-bb))))
+ (_ (signal 'native-ice
+ "missing previous setimm while creating a switch"))))
+
+(defun comp-emit-set-call-subr (subr-name sp-delta)
+ "Emit a call for SUBR-NAME.
+SP-DELTA is the stack adjustment."
+ (let ((subr (symbol-function subr-name))
+ (nargs (1+ (- sp-delta))))
+ (let* ((arity (func-arity subr))
+ (minarg (car arity))
+ (maxarg (cdr arity)))
+ (when (eq maxarg 'unevalled)
+ (signal 'native-ice (list "subr contains unevalled args" subr-name)))
+ (if (eq maxarg 'many)
+ ;; callref case.
+ (comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
+ ;; Normal call.
+ (unless (and (>= maxarg nargs) (<= minarg nargs))
+ (signal 'native-ice
+ (list "incoherent stack adjustment" nargs maxarg minarg)))
+ (let* ((subr-name subr-name)
+ (slots (cl-loop for i from 0 below maxarg
+ collect (comp-slot-n (+ i (comp-sp))))))
+ (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))))
+
+(eval-when-compile
+ (defun comp-op-to-fun (x)
+ "Given the LAP op strip \"byte-\" to have the subr name."
+ (intern (replace-regexp-in-string "byte-" "" x)))
+
+ (defun comp-body-eff (body op-name sp-delta)
+ "Given the original BODY, compute the effective one.
+When BODY is `auto', guess function name from the LAP byte-code
+name. Otherwise expect lname fnname."
+ (pcase (car body)
+ ('auto
+ `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta)))
+ ((pred symbolp)
+ `((comp-emit-set-call-subr ',(car body) ,sp-delta)))
+ (_ body))))
+
+(defmacro comp-op-case (&rest cases)
+ "Expand CASES into the corresponding `pcase' expansion.
+This is responsible for generating the proper stack adjustment, when known,
+and the annotation emission."
+ (declare (debug (body))
+ (indent defun))
+ `(pcase op
+ ,@(cl-loop for (op . body) in cases
+ for sp-delta = (gethash op comp-op-stack-info)
+ for op-name = (symbol-name op)
+ if body
+ collect `(',op
+ ;; Log all LAP ops except the TAG one.
+ ;; ,(unless (eq op 'TAG)
+ ;; `(comp-emit-annotation
+ ;; ,(concat "LAP op " op-name)))
+ ;; Emit the stack adjustment if present.
+ ,(when (and sp-delta (not (eq 0 sp-delta)))
+ `(cl-incf (comp-sp) ,sp-delta))
+ ,@(comp-body-eff body op-name sp-delta))
+ else
+ collect `(',op (signal 'native-ice
+ (list "unsupported LAP op" ',op-name))))
+ (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
+
+(defun comp-limplify-lap-inst (insn)
+ "Limplify LAP instruction INSN pushing it in the proper basic block."
+ (let ((op (car insn))
+ (arg (if (consp (cdr insn))
+ (cadr insn)
+ (cdr insn))))
+ (comp-op-case
+ (TAG
+ (cl-destructuring-bind (_TAG label-num . label-sp) insn
+ ;; Paranoid?
+ (when label-sp
+ (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
+ (comp-emit-annotation (format "LAP TAG %d" label-num))))
+ (byte-stack-ref
+ (comp-copy-slot (- (comp-sp) arg 1)))
+ (byte-varref
+ (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar
+ :constant arg))))
+ (byte-varset
+ (comp-emit (comp-call 'set_internal
+ (make-comp-mvar :constant arg)
+ (comp-slot+1))))
+ (byte-varbind ;; Verify
+ (comp-emit (comp-call 'specbind
+ (make-comp-mvar :constant arg)
+ (comp-slot+1))))
+ (byte-call
+ (cl-incf (comp-sp) (- arg))
+ (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp))))
+ (byte-unbind
+ (comp-emit (comp-call 'helper_unbind_n
+ (make-comp-mvar :constant arg))))
+ (byte-pophandler
+ (comp-emit '(pop-handler)))
+ (byte-pushconditioncase
+ (comp-emit-handler (cddr insn) 'condition-case))
+ (byte-pushcatch
+ (comp-emit-handler (cddr insn) 'catcher))
+ (byte-nth auto)
+ (byte-symbolp auto)
+ (byte-consp auto)
+ (byte-stringp auto)
+ (byte-listp auto)
+ (byte-eq auto)
+ (byte-memq auto)
+ (byte-not
+ (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
+ (make-comp-mvar :constant nil))))
+ (byte-car auto)
+ (byte-cdr auto)
+ (byte-cons auto)
+ (byte-list1
+ (comp-limplify-listn 1))
+ (byte-list2
+ (comp-limplify-listn 2))
+ (byte-list3
+ (comp-limplify-listn 3))
+ (byte-list4
+ (comp-limplify-listn 4))
+ (byte-length auto)
+ (byte-aref auto)
+ (byte-aset auto)
+ (byte-symbol-value auto)
+ (byte-symbol-function auto)
+ (byte-set auto)
+ (byte-fset auto)
+ (byte-get auto)
+ (byte-substring auto)
+ (byte-concat2
+ (comp-emit-set-call (comp-callref 'concat 2 (comp-sp))))
+ (byte-concat3
+ (comp-emit-set-call (comp-callref 'concat 3 (comp-sp))))
+ (byte-concat4
+ (comp-emit-set-call (comp-callref 'concat 4 (comp-sp))))
+ (byte-sub1 1-)
+ (byte-add1 1+)
+ (byte-eqlsign =)
+ (byte-gtr >)
+ (byte-lss <)
+ (byte-leq <=)
+ (byte-geq >=)
+ (byte-diff -)
+ (byte-negate
+ (comp-emit-set-call (comp-call 'negate (comp-slot))))
+ (byte-plus +)
+ (byte-max auto)
+ (byte-min auto)
+ (byte-mult *)
+ (byte-point auto)
+ (byte-goto-char auto)
+ (byte-insert auto)
+ (byte-point-max auto)
+ (byte-point-min auto)
+ (byte-char-after auto)
+ (byte-following-char auto)
+ (byte-preceding-char preceding-char)
+ (byte-current-column auto)
+ (byte-indent-to
+ (comp-emit-set-call (comp-call 'indent-to
+ (comp-slot)
+ (make-comp-mvar :constant nil))))
+ (byte-scan-buffer-OBSOLETE)
+ (byte-eolp auto)
+ (byte-eobp auto)
+ (byte-bolp auto)
+ (byte-bobp auto)
+ (byte-current-buffer auto)
+ (byte-set-buffer auto)
+ (byte-save-current-buffer
+ (comp-emit (comp-call 'record_unwind_current_buffer)))
+ (byte-set-mark-OBSOLETE)
+ (byte-interactive-p-OBSOLETE)
+ (byte-forward-char auto)
+ (byte-forward-word auto)
+ (byte-skip-chars-forward auto)
+ (byte-skip-chars-backward auto)
+ (byte-forward-line auto)
+ (byte-char-syntax auto)
+ (byte-buffer-substring auto)
+ (byte-delete-region auto)
+ (byte-narrow-to-region
+ (comp-emit-set-call (comp-call 'narrow-to-region
+ (comp-slot)
+ (comp-slot+1))))
+ (byte-widen
+ (comp-emit-set-call (comp-call 'widen)))
+ (byte-end-of-line auto)
+ (byte-constant2) ; TODO
+ ;; Branches.
+ (byte-goto
+ (comp-emit-uncond-jump (cddr insn)))
+ (byte-goto-if-nil
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (cddr insn) nil))
+ (byte-goto-if-not-nil
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (cddr insn) t))
+ (byte-goto-if-nil-else-pop
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (cddr insn) nil))
+ (byte-goto-if-not-nil-else-pop
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (cddr insn) t))
+ (byte-return
+ (comp-emit `(return ,(comp-slot+1))))
+ (byte-discard 'pass)
+ (byte-dup
+ (comp-copy-slot (1- (comp-sp))))
+ (byte-save-excursion
+ (comp-emit (comp-call 'record_unwind_protect_excursion)))
+ (byte-save-window-excursion-OBSOLETE)
+ (byte-save-restriction
+ (comp-emit (comp-call 'helper_save_restriction)))
+ (byte-catch) ;; Obsolete
+ (byte-unwind-protect
+ (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1))))
+ (byte-condition-case) ;; Obsolete
+ (byte-temp-output-buffer-setup-OBSOLETE)
+ (byte-temp-output-buffer-show-OBSOLETE)
+ (byte-unbind-all) ;; Obsolete
+ (byte-set-marker auto)
+ (byte-match-beginning auto)
+ (byte-match-end auto)
+ (byte-upcase auto)
+ (byte-downcase auto)
+ (byte-string= string-equal)
+ (byte-string< string-lessp)
+ (byte-equal auto)
+ (byte-nthcdr auto)
+ (byte-elt auto)
+ (byte-member auto)
+ (byte-assq auto)
+ (byte-nreverse auto)
+ (byte-setcar auto)
+ (byte-setcdr auto)
+ (byte-car-safe auto)
+ (byte-cdr-safe auto)
+ (byte-nconc auto)
+ (byte-quo /)
+ (byte-rem %)
+ (byte-numberp auto)
+ (byte-integerp auto)
+ (byte-listN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'list arg (comp-sp))))
+ (byte-concatN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'concat arg (comp-sp))))
+ (byte-insertN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
+ (byte-stack-set
+ (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
+ (byte-stack-set2 (cl-assert nil)) ;; TODO
+ (byte-discardN
+ (cl-incf (comp-sp) (- arg)))
+ (byte-switch
+ ;; Assume to follow the emission of a setimm.
+ ;; This is checked into comp-emit-switch.
+ (comp-emit-switch (comp-slot+1)
+ (cl-first (comp-block-insns
+ (comp-limplify-curr-block comp-pass)))))
+ (byte-constant
+ (comp-emit-setimm arg))
+ (byte-discardN-preserve-tos
+ (cl-incf (comp-sp) (- arg))
+ (comp-copy-slot (+ arg (comp-sp)))))))
+
+(defun comp-emit-narg-prologue (minarg nonrest rest)
+ "Emit the prologue for a narg function."
+ (cl-loop for i below minarg
+ do (comp-emit `(set-args-to-local ,(comp-slot-n i)))
+ (comp-emit '(inc-args)))
+ (cl-loop for i from minarg below nonrest
+ for bb = (intern (format "entry_%s" i))
+ for fallback = (intern (format "entry_fallback_%s" i))
+ do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb))
+ (comp-make-curr-block bb (comp-sp))
+ (comp-emit `(set-args-to-local ,(comp-slot-n i)))
+ (comp-emit '(inc-args))
+ finally (comp-emit '(jump entry_rest_args)))
+ (when (/= minarg nonrest)
+ (cl-loop for i from minarg below nonrest
+ for bb = (intern (format "entry_fallback_%s" i))
+ for next-bb = (if (= (1+ i) nonrest)
+ 'entry_rest_args
+ (intern (format "entry_fallback_%s" (1+ i))))
+ do (comp-with-sp i
+ (comp-make-curr-block bb (comp-sp))
+ (comp-emit-setimm nil)
+ (comp-emit `(jump ,next-bb)))))
+ (comp-make-curr-block 'entry_rest_args (comp-sp))
+ (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))
+ (setf (comp-sp) nonrest)
+ (when (and (> nonrest 8) (null rest))
+ (cl-decf (comp-sp))))
+
+(defun comp-limplify-finalize-function (func)
+ "Reverse insns into all basic blocks of FUNC."
+ (cl-loop for bb being the hash-value in (comp-func-blocks func)
+ do (setf (comp-block-insns bb)
+ (nreverse (comp-block-insns bb))))
+ (comp-log-func func 2)
+ func)
+
+(cl-defgeneric comp-prepare-args-for-top-level (function)
+ "Given FUNCTION, return the two arguments for comp--register-...")
+
+(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l))
+ "Lexically-scoped FUNCTION."
+ (let ((args (comp-func-l-args function)))
+ (cons (make-comp-mvar :constant (comp-args-base-min args))
+ (make-comp-mvar :constant (if (comp-args-p args)
+ (comp-args-max args)
+ 'many)))))
+
+(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d))
+ "Dynamically scoped FUNCTION."
+ (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function)))
+ (let ((comp-curr-allocation-class 'd-default))
+ ;; Lambda-lists must stay in the same relocation class of
+ ;; the object referenced by code to respect uninterned
+ ;; symbols.
+ (make-comp-mvar :constant (comp-func-d-lambda-list function)))))
+
+(cl-defgeneric comp-emit-for-top-level (form for-late-load)
+ "Emit the Limple code for top level FORM.")
+
+(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def)
+ for-late-load)
+ (let* ((name (byte-to-native-func-def-name form))
+ (c-name (byte-to-native-func-def-c-name form))
+ (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
+ (args (comp-prepare-args-for-top-level f)))
+ (cl-assert (and name f))
+ (comp-emit
+ `(set ,(make-comp-mvar :slot 1)
+ ,(comp-call (if for-late-load
+ 'comp--late-register-subr
+ 'comp--register-subr)
+ (make-comp-mvar :constant name)
+ (make-comp-mvar :constant c-name)
+ (car args)
+ (cdr args)
+ (setf (comp-func-type f)
+ (make-comp-mvar :constant nil))
+ (make-comp-mvar
+ :constant
+ (list
+ (let* ((h (comp-ctxt-function-docs comp-ctxt))
+ (i (hash-table-count h)))
+ (puthash i (comp-func-doc f) h)
+ i)
+ (comp-func-int-spec f)))
+ ;; This is the compilation unit it-self passed as
+ ;; parameter.
+ (make-comp-mvar :slot 0))))))
+
+(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
+ for-late-load)
+ (unless for-late-load
+ (comp-emit
+ (comp-call 'eval
+ (let ((comp-curr-allocation-class 'd-impure))
+ (make-comp-mvar :constant
+ (byte-to-native-top-level-form form)))
+ (make-comp-mvar :constant
+ (byte-to-native-top-level-lexical form))))))
+
+(defun comp-emit-lambda-for-top-level (func)
+ "Emit the creation of subrs for lambda FUNC.
+These are stored in the reloc data array."
+ (let ((args (comp-prepare-args-for-top-level func)))
+ (let ((comp-curr-allocation-class 'd-impure))
+ (comp-add-const-to-relocs (comp-func-byte-func func)))
+ (comp-emit
+ (comp-call 'comp--register-lambda
+ ;; mvar to be fixed-up when containers are
+ ;; finalized.
+ (or (gethash (comp-func-byte-func func)
+ (comp-ctxt-lambda-fixups-h comp-ctxt))
+ (puthash (comp-func-byte-func func)
+ (make-comp-mvar :constant nil)
+ (comp-ctxt-lambda-fixups-h comp-ctxt)))
+ (make-comp-mvar :constant (comp-func-c-name func))
+ (car args)
+ (cdr args)
+ (setf (comp-func-type func)
+ (make-comp-mvar :constant nil))
+ (make-comp-mvar
+ :constant
+ (list
+ (let* ((h (comp-ctxt-function-docs comp-ctxt))
+ (i (hash-table-count h)))
+ (puthash i (comp-func-doc func) h)
+ i)
+ (comp-func-int-spec func)))
+ ;; This is the compilation unit it-self passed as
+ ;; parameter.
+ (make-comp-mvar :slot 0)))))
+
+(defun comp-limplify-top-level (for-late-load)
+ "Create a Limple function to modify the global environment at load.
+When FOR-LATE-LOAD is non-nil, the emitted function modifies only
+function definition.
+
+Synthesize a function called `top_level_run' that gets one single
+parameter (the compilation unit itself). To define native
+functions, `top_level_run' will call back `comp--register-subr'
+into the C code forwarding the compilation unit."
+ ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no
+ ;; reasons to be executed ever again. Therefore all objects can be
+ ;; just ephemeral.
+ (let* ((comp-curr-allocation-class 'd-ephemeral)
+ (func (make-comp-func-l :name (if for-late-load
+ 'late-top-level-run
+ 'top-level-run)
+ :c-name (if for-late-load
+ "late_top_level_run"
+ "top_level_run")
+ :args (make-comp-args :min 1 :max 1)
+ ;; Frame is 2 wide: Slot 0 is the
+ ;; compilation unit being loaded
+ ;; (incoming parameter). Slot 1 is
+ ;; the last function being
+ ;; registered.
+ :frame-size 2
+ :speed (comp-ctxt-speed comp-ctxt)))
+ (comp-func func)
+ (comp-pass (make-comp-limplify
+ :curr-block (make--comp-block-lap -1 0 'top-level)
+ :frame (comp-new-frame 1 0))))
+ (comp-make-curr-block 'entry (comp-sp))
+ (comp-emit-annotation (if for-late-load
+ "Late top level"
+ "Top level"))
+ ;; Assign the compilation unit incoming as parameter to the slot frame 0.
+ (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
+ (maphash (lambda (_ func)
+ (comp-emit-lambda-for-top-level func))
+ (comp-ctxt-byte-func-to-func-h comp-ctxt))
+ (mapc (lambda (x) (comp-emit-for-top-level x for-late-load))
+ (comp-ctxt-top-level-forms comp-ctxt))
+ (comp-emit `(return ,(make-comp-mvar :slot 1)))
+ (comp-limplify-finalize-function func)))
+
+(defun comp-addr-to-bb-name (addr)
+ "Search for a block starting at ADDR into pending or limplified blocks."
+ ;; FIXME Actually we could have another hash for this.
+ (cl-flet ((pred (bb)
+ (equal (comp-block-lap-addr bb) addr)))
+ (if-let ((pending (cl-find-if #'pred
+ (comp-limplify-pending-blocks comp-pass))))
+ (comp-block-name pending)
+ (cl-loop for bb being the hash-value in (comp-func-blocks comp-func)
+ when (pred bb)
+ return (comp-block-name bb)))))
+
+(defun comp-limplify-block (bb)
+ "Limplify basic-block BB and add it to the current function."
+ (setf (comp-limplify-curr-block comp-pass) bb
+ (comp-limplify-sp comp-pass) (comp-block-lap-sp bb)
+ (comp-limplify-pc comp-pass) (comp-block-lap-addr bb))
+ (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
+ (cl-loop
+ for inst-cell on (nthcdr (comp-limplify-pc comp-pass)
+ (comp-func-lap comp-func))
+ for inst = (car inst-cell)
+ for next-inst = (car-safe (cdr inst-cell))
+ do (comp-limplify-lap-inst inst)
+ (cl-incf (comp-limplify-pc comp-pass))
+ when (comp-lap-fall-through-p inst)
+ do (pcase next-inst
+ (`(TAG ,_label . ,label-sp)
+ (when label-sp
+ (cl-assert (= (1- label-sp) (comp-sp))))
+ (let* ((stack-depth (if label-sp
+ (1- label-sp)
+ (comp-sp)))
+ (next-bb (comp-block-name (comp-bb-maybe-add
+ (comp-limplify-pc comp-pass)
+ stack-depth))))
+ (unless (comp-block-closed bb)
+ (comp-emit `(jump ,next-bb))))
+ (cl-return)))
+ until (comp-lap-eob-p inst)))
+
+(defun comp-limplify-function (func)
+ "Limplify a single function FUNC."
+ (let* ((frame-size (comp-func-frame-size func))
+ (comp-func func)
+ (comp-pass (make-comp-limplify
+ :frame (comp-new-frame frame-size 0))))
+ (comp-fill-label-h)
+ ;; Prologue
+ (comp-make-curr-block 'entry (comp-sp))
+ (comp-emit-annotation (concat "Lisp function: "
+ (symbol-name (comp-func-name func))))
+ ;; Dynamic functions have parameters bound by the trampoline.
+ (when (comp-func-l-p func)
+ (let ((args (comp-func-l-args func)))
+ (if (comp-args-p args)
+ (cl-loop for i below (comp-args-max args)
+ do (cl-incf (comp-sp))
+ (comp-emit `(set-par-to-local ,(comp-slot) ,i)))
+ (comp-emit-narg-prologue (comp-args-base-min args)
+ (comp-nargs-nonrest args)
+ (comp-nargs-rest args)))))
+ (comp-emit '(jump bb_0))
+ ;; Body
+ (comp-bb-maybe-add 0 (comp-sp))
+ (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
+ while next-bb
+ do (comp-limplify-block next-bb))
+ ;; Sanity check against block duplication.
+ (cl-loop with addr-h = (make-hash-table)
+ for bb being the hash-value in (comp-func-blocks func)
+ for addr = (when (comp-block-lap-p bb)
+ (comp-block-lap-addr bb))
+ when addr
+ do (cl-assert (null (gethash addr addr-h)))
+ (puthash addr t addr-h))
+ (comp-limplify-finalize-function func)))
+
+(defun comp-limplify (_)
+ "Compute LIMPLE IR for forms in `comp-ctxt'."
+ (maphash (lambda (_ f) (comp-limplify-function f))
+ (comp-ctxt-funcs-h comp-ctxt))
+ (comp-add-func-to-ctxt (comp-limplify-top-level nil))
+ (when (comp-ctxt-with-late-load comp-ctxt)
+ (comp-add-func-to-ctxt (comp-limplify-top-level t))))
+
+
+;;; add-cstrs pass specific code.
+
+;; This pass is responsible for adding constraints, these are
+;; generated from:
+;;
+;; - Conditional branches: each branch taken or non taken can be used
+;; in the CFG to infer information on the tested variables.
+;;
+;; - Range propagation under test and branch (when the test is an
+;; arithmetic comparison).
+;;
+;; - Type constraint under test and branch (when the test is a
+;; known predicate).
+;;
+;; - Function calls: function calls to function assumed to be not
+;; redefinable can be used to add constrains on the function
+;; arguments. Ex: if we execute successfully (= x y) we know that
+;; afterwards both x and y must satisfy the (or number marker)
+;; type specifier.
+
+
+(defsubst comp-mvar-used-p (mvar)
+ "Non-nil when MVAR is used as lhs in the current function."
+ (declare (gv-setter (lambda (val)
+ `(puthash ,mvar ,val comp-pass))))
+ (gethash mvar comp-pass))
+
+(defun comp-collect-mvars (form)
+ "Add rhs m-var present in FORM into `comp-pass'."
+ (cl-loop for x in form
+ if (consp x)
+ do (comp-collect-mvars x)
+ else
+ when (comp-mvar-p x)
+ do (setf (comp-mvar-used-p x) t)))
+
+(defun comp-collect-rhs ()
+ "Collect all lhs mvars into `comp-pass'."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ for (op . args) = insn
+ if (comp-assign-op-p op)
+ do (comp-collect-mvars (cdr args))
+ else
+ do (comp-collect-mvars args))))
+
+(defun comp-negate-arithm-cmp-fun (function)
+ "Negate FUNCTION.
+Return nil if we don't want to emit constraints for its negation."
+ (cl-ecase function
+ (= nil)
+ (> '<=)
+ (< '>=)
+ (>= '<)
+ (<= '>)))
+
+(defun comp-reverse-arithm-fun (function)
+ "Reverse FUNCTION."
+ (cl-case function
+ (= '=)
+ (> '<)
+ (< '>)
+ (>= '<=)
+ (<= '>=)
+ (t function)))
+
+(defun comp-emit-assume (kind lhs rhs bb negated)
+ "Emit an assume of kind KIND for mvar LHS being RHS.
+When NEGATED is non-nil, the assumption is negated.
+The assume is emitted at the beginning of the block BB."
+ (let ((lhs-slot (comp-mvar-slot lhs)))
+ (cl-assert lhs-slot)
+ (pcase kind
+ ((or 'and 'and-nhc)
+ (if (comp-mvar-p rhs)
+ (let ((tmp-mvar (if negated
+ (make-comp-mvar :slot (comp-mvar-slot rhs))
+ rhs)))
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs ,tmp-mvar))
+ (comp-block-insns bb))
+ (if negated
+ (push `(assume ,tmp-mvar (not ,rhs))
+ (comp-block-insns bb))))
+ ;; If is only a constraint we can negate it directly.
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs ,(if negated
+ (comp-cstr-negation-make rhs)
+ rhs)))
+ (comp-block-insns bb))))
+ ((pred comp-arithm-cmp-fun-p)
+ (when-let ((kind (if negated
+ (comp-negate-arithm-cmp-fun kind)
+ kind)))
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs
+ ,(if-let* ((vld (comp-cstr-imm-vld-p rhs))
+ (val (comp-cstr-imm rhs))
+ (ok (and (integerp val)
+ (not (memq kind '(= !=))))))
+ val
+ (make-comp-mvar :slot (comp-mvar-slot rhs)))))
+ (comp-block-insns bb))))
+ (_ (cl-assert nil)))
+ (setf (comp-func-ssa-status comp-func) 'dirty)))
+
+(defun comp-maybe-add-vmvar (op cmp-res insns-seq)
+ "If CMP-RES is clobbering OP emit a new constrained mvar and return it.
+Return OP otherwise."
+ (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
+ (new-mvar (make-comp-mvar
+ :slot
+ (- (cl-incf (comp-func-vframe-size comp-func))))))
+ (progn
+ (push `(assume ,new-mvar ,op) (cdr insns-seq))
+ new-mvar)
+ op))
+
+(defun comp-add-new-block-between (bb-symbol bb-a bb-b)
+ "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
+ (cl-loop
+ with new-bb = (make-comp-block-cstr :name bb-symbol
+ :insns `((jump ,(comp-block-name bb-b))))
+ with new-edge = (make-comp-edge :src bb-a :dst new-bb)
+ for ed in (comp-block-in-edges bb-b)
+ when (eq (comp-edge-src ed) bb-a)
+ do
+ ;; Connect `ed' to `new-bb' and disconnect it from `bb-a'.
+ (cl-assert (memq ed (comp-block-out-edges bb-a)))
+ (setf (comp-edge-src ed) new-bb
+ (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a)))
+ (push ed (comp-block-out-edges new-bb))
+ ;; Connect `bb-a' `new-bb' with `new-edge'.
+ (push new-edge (comp-block-out-edges bb-a))
+ (push new-edge (comp-block-in-edges new-bb))
+ (setf (comp-func-ssa-status comp-func) 'dirty)
+ ;; Add `new-edge' to the current function and return it.
+ (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func)))
+ finally (cl-assert nil)))
+
+;; Cheap substitute to a copy propagation pass...
+(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb)
+ "Given MVAR, search in BB the original mvar MVAR got assigned from.
+Keep on searching till EXIT-INSN is encountered."
+ (cl-flet ((targetp (x)
+ ;; Ret t if x is an mvar and target the correct slot number.
+ (and (comp-mvar-p x)
+ (eql (comp-mvar-slot mvar) (comp-mvar-slot x)))))
+ (cl-loop
+ with res = nil
+ for insn in (comp-block-insns bb)
+ when (eq insn exit-insn)
+ do (cl-return (and (comp-mvar-p res) res))
+ do (pcase insn
+ (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs)
+ (setf res rhs)))
+ finally (cl-assert nil))))
+
+(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym)
+ "Return the appropriate basic block to add constraint assumptions into.
+CURR-BB is the current basic block.
+TARGET-BB-SYM is the symbol name of the target block."
+ (let* ((target-bb (gethash target-bb-sym
+ (comp-func-blocks comp-func)))
+ (target-bb-in-edges (comp-block-in-edges target-bb)))
+ (cl-assert target-bb-in-edges)
+ (if (length= target-bb-in-edges 1)
+ ;; If block has only one predecessor is already suitable for
+ ;; adding constraint assumptions.
+ target-bb
+ (cl-loop
+ ;; Search for the first suitable basic block name.
+ for i from 0
+ for new-name = (intern (format "%s_cstrs_%d" (symbol-name target-bb-sym)
+ i))
+ until (null (gethash new-name (comp-func-blocks comp-func)))
+ finally
+ ;; Add it.
+ (cl-return (comp-add-new-block-between new-name curr-bb target-bb))))))
+
+(defun comp-add-cond-cstrs-simple ()
+ "`comp-add-cstrs' worker function for each selected function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do
+ (cl-loop
+ named in-the-basic-block
+ for insn-seq on (comp-block-insns b)
+ do
+ (pcase insn-seq
+ (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(pred comp-mvar-p))
+ ;; (comment ,_comment-str)
+ (cond-jump ,tmp-mvar ,obj2 . ,blocks))
+ (cl-loop
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p tmp-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and tmp-mvar obj2 block-target negated))
+ finally (cl-return-from in-the-basic-block)))
+ (`((cond-jump ,obj1 ,obj2 . ,blocks))
+ (cl-loop
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p obj1)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and obj1 obj2 block-target negated))
+ finally (cl-return-from in-the-basic-block)))))))
+
+(defun comp-add-cond-cstrs ()
+ "`comp-add-cstrs' worker function for each selected function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do
+ (cl-loop
+ named in-the-basic-block
+ with prev-insns-seq
+ for insns-seq on (comp-block-insns b)
+ do
+ (pcase insns-seq
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (or (pred comp-equality-fun-p)
+ (pred comp-arithm-cmp-fun-p))
+ fun)
+ ,op1 ,op2))
+ ;; (comment ,_comment-str)
+ (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b)
+ with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(t nil)
+ for kind = (cl-case fun
+ (equal 'and-nhc)
+ (eql 'and-nhc)
+ (eq 'and)
+ (t fun))
+ when (or (comp-mvar-used-p target-mvar1)
+ (comp-mvar-used-p target-mvar2))
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (when (comp-mvar-used-p target-mvar1)
+ (comp-emit-assume kind target-mvar1
+ (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq)
+ block-target negated))
+ (when (comp-mvar-used-p target-mvar2)
+ (comp-emit-assume (comp-reverse-arithm-fun kind)
+ target-mvar2
+ (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq)
+ block-target negated)))
+ finally (cl-return-from in-the-basic-block)))
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (pred comp-known-predicate-p) fun)
+ ,op))
+ ;; (comment ,_comment-str)
+ (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with cstr = (comp-pred-to-cstr fun)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(t nil)
+ when (comp-mvar-used-p target-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and target-mvar cstr block-target negated))
+ finally (cl-return-from in-the-basic-block)))
+ ;; Match predicate on the negated branch (unless).
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (pred comp-known-predicate-p) fun)
+ ,op))
+ (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p)))
+ (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with cstr = (comp-pred-to-cstr fun)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p target-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and target-mvar cstr block-target negated))
+ finally (cl-return-from in-the-basic-block))))
+ (setf prev-insns-seq insns-seq))))
+
+(defsubst comp-insert-insn (insn insn-cell)
+ "Insert INSN as second insn of INSN-CELL."
+ (let ((next-cell (cdr insn-cell))
+ (new-cell `(,insn)))
+ (setf (cdr insn-cell) new-cell
+ (cdr new-cell) next-cell
+ (comp-func-ssa-status comp-func) 'dirty)))
+
+(defun comp-emit-call-cstr (mvar call-cell cstr)
+ "Emit a constraint CSTR for MVAR after CALL-CELL."
+ (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar)))
+ ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and
+ ;; fwprop convergence!!
+ (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))
+ (comp-insert-insn insn call-cell)))
+
+(defun comp-lambda-list-gen (lambda-list)
+ "Return a generator to iterate over LAMBDA-LIST."
+ (lambda ()
+ (cl-case (car lambda-list)
+ (&optional
+ (setf lambda-list (cdr lambda-list))
+ (prog1
+ (car lambda-list)
+ (setf lambda-list (cdr lambda-list))))
+ (&rest
+ (cadr lambda-list))
+ (t
+ (prog1
+ (car lambda-list)
+ (setf lambda-list (cdr lambda-list)))))))
+
+(defun comp-add-call-cstr ()
+ "Add args assumptions for each function of which the type specifier is known."
+ (cl-loop
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ do
+ (comp-loop-insn-in-block bb
+ (when-let ((match
+ (pcase insn
+ (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args))
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (cl-values f cstr-f lhs args)))
+ (`(,(pred comp-call-op-p) ,f . ,args)
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (cl-values f cstr-f nil args))))))
+ (cl-multiple-value-bind (f cstr-f lhs args) match
+ (cl-loop
+ with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
+ for arg in args
+ for cstr = (funcall gen)
+ for target = (comp-cond-cstrs-target-mvar arg insn bb)
+ unless (comp-cstr-p cstr)
+ do (signal 'native-ice
+ (list "Incoherent type specifier for function" f))
+ when (and target
+ ;; No need to add call constraints if this is t
+ ;; (bug#45812 bug#45705 bug#45751).
+ (not (equal comp-cstr-t cstr))
+ (or (null lhs)
+ (not (eql (comp-mvar-slot lhs)
+ (comp-mvar-slot target)))))
+ do (comp-emit-call-cstr target insn-cell cstr)))))))
+
+(defun comp-add-cstrs (_)
+ "Rewrite conditional branches adding appropriate 'assume' insns.
+This is introducing and placing 'assume' insns in use by fwprop
+to propagate conditional branch test information on target basic
+blocks."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 1)
+ ;; No point to run this on dynamic scope as
+ ;; this pass is effective only on local
+ ;; variables.
+ (comp-func-l-p f)
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f)
+ (comp-pass (make-hash-table :test #'eq)))
+ (comp-collect-rhs)
+ (comp-add-cond-cstrs-simple)
+ (comp-add-cond-cstrs)
+ (comp-add-call-cstr)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; pure-func pass specific code.
+
+;; Simple IPA pass to infer function purity of functions not
+;; explicitly declared as such. This is effective only at speed 3 to
+;; avoid optimizing-out functions and preventing their redefinition
+;; being effective.
+
+(defun comp-collect-calls (f)
+ "Return a list with all the functions called by F."
+ (cl-loop
+ with h = (make-hash-table :test #'eq)
+ for b being each hash-value of (comp-func-blocks f)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ do (pcase insn
+ (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest))
+ (puthash f t h))
+ (`(,(pred comp-call-op-p) ,f . ,_rest)
+ (puthash f t h))))
+ finally return (cl-loop
+ for f being each hash-key of h
+ collect (if (stringp f)
+ (comp-func-name
+ (gethash f
+ (comp-ctxt-funcs-h comp-ctxt)))
+ f))))
+
+(defun comp-pure-infer-func (f)
+ "If all functions called by F are pure then F is pure too."
+ (when (and (cl-every (lambda (x)
+ (or (comp-function-pure-p x)
+ (eq x (comp-func-name f))))
+ (comp-collect-calls f))
+ (not (eq (comp-func-pure f) t)))
+ (comp-log (format "%s inferred to be pure" (comp-func-name f)))
+ (setf (comp-func-pure f) t)))
+
+(defun comp-ipa-pure (_)
+ "Infer function purity."
+ (cl-loop
+ with pure-n = 0
+ for n from 1
+ while
+ (/= pure-n
+ (setf pure-n
+ (cl-loop
+ for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt)
+ when (and (>= (comp-func-speed f) 3)
+ (comp-func-l-p f)
+ (not (comp-func-pure f)))
+ do (comp-pure-infer-func f)
+ count (comp-func-pure f))))
+ finally (comp-log (format "ipa-pure iterated %d times" n))))
+
+
+;;; SSA pass specific code.
+;; After limplification no edges are present between basic blocks and an
+;; implicit phi is present for every slot at the beginning of every basic block.
+;; This pass is responsible for building all the edges and replace all m-vars
+;; plus placing the needed phis.
+;; Because the number of phis placed is (supposed) to be the minimum necessary
+;; this form is called 'minimal SSA form'.
+;; This pass should be run every time basic blocks or m-var are shuffled.
+
+(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
+ "Same as `make-comp-mvar' but set the `id' slot."
+ (let ((mvar (apply #'make-comp-mvar rest)))
+ (setf (comp-mvar-id mvar) (sxhash-eq mvar))
+ mvar))
+
+(defun comp-clean-ssa (f)
+ "Clean-up SSA for function F."
+ (setf (comp-func-edges-h f) (make-hash-table))
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks f)
+ do (setf (comp-block-in-edges b) ()
+ (comp-block-out-edges b) ()
+ (comp-block-idom b) nil
+ (comp-block-df b) (make-hash-table)
+ (comp-block-post-num b) nil
+ (comp-block-final-frame b) nil
+ ;; Prune all phis.
+ (comp-block-insns b) (cl-loop for insn in (comp-block-insns b)
+ unless (eq 'phi (car insn))
+ collect insn))))
+
+(defun comp-compute-edges ()
+ "Compute the basic block edges for the current function."
+ (cl-loop with blocks = (comp-func-blocks comp-func)
+ for bb being each hash-value of blocks
+ for last-insn = (car (last (comp-block-insns bb)))
+ for (op first second third forth) = last-insn
+ do (cl-case op
+ (jump
+ (make-comp-edge :src bb :dst (gethash first blocks)))
+ (cond-jump
+ (make-comp-edge :src bb :dst (gethash third blocks))
+ (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (cond-jump-narg-leq
+ (make-comp-edge :src bb :dst (gethash second blocks))
+ (make-comp-edge :src bb :dst (gethash third blocks)))
+ (push-handler
+ (make-comp-edge :src bb :dst (gethash third blocks))
+ (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (return)
+ (unreachable)
+ (otherwise
+ (signal 'native-ice
+ (list "block does not end with a branch"
+ bb
+ (comp-func-name comp-func)))))
+ ;; Update edge refs into blocks.
+ finally
+ (cl-loop
+ for edge being the hash-value in (comp-func-edges-h comp-func)
+ do
+ (push edge
+ (comp-block-out-edges (comp-edge-src edge)))
+ (push edge
+ (comp-block-in-edges (comp-edge-dst edge))))
+ (comp-log-edges comp-func)))
+
+(defun comp-collect-rev-post-order (basic-block)
+ "Walk BASIC-BLOCK children and return their name in reversed post-order."
+ (let ((visited (make-hash-table))
+ (acc ()))
+ (cl-labels ((collect-rec (bb)
+ (let ((name (comp-block-name bb)))
+ (unless (gethash name visited)
+ (puthash name t visited)
+ (cl-loop for e in (comp-block-out-edges bb)
+ for dst-block = (comp-edge-dst e)
+ do (collect-rec dst-block))
+ (push name acc)))))
+ (collect-rec basic-block)
+ acc)))
+
+(defun comp-compute-dominator-tree ()
+ "Compute immediate dominators for each basic block in current function."
+ ;; Originally based on: "A Simple, Fast Dominance Algorithm"
+ ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
+ (cl-flet ((intersect (b1 b2)
+ (let ((finger1 (comp-block-post-num b1))
+ (finger2 (comp-block-post-num b2)))
+ (while (not (= finger1 finger2))
+ (while (< finger1 finger2)
+ (setf b1 (comp-block-idom b1)
+ finger1 (comp-block-post-num b1)))
+ (while (< finger2 finger1)
+ (setf b2 (comp-block-idom b2)
+ finger2 (comp-block-post-num b2))))
+ b1))
+ (first-processed (l)
+ (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
+ p
+ (signal 'native-ice "cant't find first preprocessed"))))
+
+ (when-let ((blocks (comp-func-blocks comp-func))
+ (entry (gethash 'entry blocks))
+ ;; No point to go on if the only bb is 'entry'.
+ (bb0 (gethash 'bb_0 blocks)))
+ (cl-loop
+ with rev-bb-list = (comp-collect-rev-post-order entry)
+ with changed = t
+ while changed
+ initially (progn
+ (comp-log "Computing dominator tree...\n" 2)
+ (setf (comp-block-idom entry) entry)
+ ;; Set the post order number.
+ (cl-loop for name in (reverse rev-bb-list)
+ for b = (gethash name blocks)
+ for i from 0
+ do (setf (comp-block-post-num b) i)))
+ do (cl-loop
+ for name in (cdr rev-bb-list)
+ for b = (gethash name blocks)
+ for preds = (comp-block-preds b)
+ for new-idom = (first-processed preds)
+ initially (setf changed nil)
+ do (cl-loop for p in (delq new-idom preds)
+ when (comp-block-idom p)
+ do (setf new-idom (intersect p new-idom)))
+ unless (eq (comp-block-idom b) new-idom)
+ do (setf (comp-block-idom b) (unless (and (comp-block-lap-p new-idom)
+ (comp-block-lap-no-ret
+ new-idom))
+ new-idom)
+ changed t))))))
+
+(defun comp-compute-dominator-frontiers ()
+ "Compute the dominator frontier for each basic block in `comp-func'."
+ ;; Originally based on: "A Simple, Fast Dominance Algorithm"
+ ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
+ (cl-loop with blocks = (comp-func-blocks comp-func)
+ for b-name being each hash-keys of blocks
+ using (hash-value b)
+ for preds = (comp-block-preds b)
+ when (length> preds 1) ; All joins
+ do (cl-loop for p in preds
+ for runner = p
+ do (while (not (eq runner (comp-block-idom b)))
+ (puthash b-name b (comp-block-df runner))
+ (setf runner (comp-block-idom runner))))))
+
+(defun comp-log-block-info ()
+ "Log basic blocks info for the current function."
+ (maphash (lambda (name bb)
+ (let ((dom (comp-block-idom bb))
+ (df (comp-block-df bb)))
+ (comp-log (format "block: %s idom: %s DF %s\n"
+ name
+ (when dom (comp-block-name dom))
+ (cl-loop for b being each hash-keys of df
+ collect b))
+ 3)))
+ (comp-func-blocks comp-func)))
+
+(defun comp-place-phis ()
+ "Place phi insns into the current function."
+ ;; Originally based on: Static Single Assignment Book
+ ;; Algorithm 3.1: Standard algorithm for inserting phi-functions
+ (cl-flet ((add-phi (slot-n bb)
+ ;; Add a phi func for slot SLOT-N at the top of BB.
+ (push `(phi ,slot-n) (comp-block-insns bb)))
+ (slot-assigned-p (slot-n bb)
+ ;; Return t if a SLOT-N was assigned within BB.
+ (cl-loop for insn in (comp-block-insns bb)
+ for op = (car insn)
+ when (or (and (comp-assign-op-p op)
+ (eql slot-n (comp-mvar-slot (cadr insn))))
+ ;; fetch-handler is after a non local
+ ;; therefore clobbers all frame!!!
+ (eq op 'fetch-handler))
+ return t)))
+
+ (cl-loop for i from (- (comp-func-vframe-size comp-func))
+ below (comp-func-frame-size comp-func)
+ ;; List of blocks with a definition of mvar i
+ for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func)
+ for b being each hash-value of blocks
+ when (slot-assigned-p i b)
+ collect b)
+ ;; Set of basic blocks where phi is added.
+ for f = ()
+ ;; Worklist, set of basic blocks that contain definitions of v.
+ for w = defs-v
+ do
+ (while w
+ (let ((x (pop w)))
+ (cl-loop for y being each hash-value of (comp-block-df x)
+ unless (cl-find y f)
+ do (add-phi i y)
+ (push y f)
+ ;; Adding a phi implies mentioning the
+ ;; corresponding slot so in case adjust w.
+ (unless (cl-find y defs-v)
+ (push y w))))))))
+
+(defun comp-dom-tree-walker (bb pre-lambda post-lambda)
+ "Dominator tree walker function starting from basic block BB.
+PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
+ (when pre-lambda
+ (funcall pre-lambda bb))
+ (when-let ((out-edges (comp-block-out-edges bb)))
+ (cl-loop for ed in out-edges
+ for child = (comp-edge-dst ed)
+ when (eq bb (comp-block-idom child))
+ ;; Current block is the immediate dominator then recur.
+ do (comp-dom-tree-walker child pre-lambda post-lambda)))
+ (when post-lambda
+ (funcall post-lambda bb)))
+
+(cl-defstruct (comp-ssa (:copier nil))
+ "Support structure used while SSA renaming."
+ (frame (comp-new-frame (comp-func-frame-size comp-func)
+ (comp-func-vframe-size comp-func) t)
+ :type comp-vec
+ :documentation "`comp-vec' of m-vars."))
+
+(defun comp-ssa-rename-insn (insn frame)
+ (cl-loop
+ for slot-n from (- (comp-func-vframe-size comp-func))
+ below (comp-func-frame-size comp-func)
+ do
+ (cl-flet ((targetp (x)
+ ;; Ret t if x is an mvar and target the correct slot number.
+ (and (comp-mvar-p x)
+ (eql slot-n (comp-mvar-slot x))))
+ (new-lvalue ()
+ ;; If is an assignment make a new mvar and put it as l-value.
+ (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
+ (setf (comp-vec-aref frame slot-n) mvar
+ (cadr insn) mvar))))
+ (pcase insn
+ (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
+ (let ((mvar (comp-vec-aref frame slot-n)))
+ (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn))))
+ (new-lvalue))
+ (`(fetch-handler . ,_)
+ ;; Clobber all no matter what!
+ (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
+ (`(phi ,n)
+ (when (equal n slot-n)
+ (new-lvalue)))
+ (_
+ (let ((mvar (comp-vec-aref frame slot-n)))
+ (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
+
+(defun comp-ssa-rename ()
+ "Entry point to rename into SSA within the current function."
+ (comp-log "Renaming\n" 2)
+ (let ((visited (make-hash-table)))
+ (cl-labels ((ssa-rename-rec (bb in-frame)
+ (unless (gethash bb visited)
+ (puthash bb t visited)
+ (cl-loop for insn in (comp-block-insns bb)
+ do (comp-ssa-rename-insn insn in-frame))
+ (setf (comp-block-final-frame bb)
+ (copy-sequence in-frame))
+ (when-let ((out-edges (comp-block-out-edges bb)))
+ (cl-loop
+ for ed in out-edges
+ for child = (comp-edge-dst ed)
+ ;; Provide a copy of the same frame to all children.
+ do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
+
+ (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
+ (comp-new-frame (comp-func-frame-size comp-func)
+ (comp-func-vframe-size comp-func)
+ t)))))
+
+(defun comp-finalize-phis ()
+ "Fixup r-values into phis in all basic blocks."
+ (cl-flet ((finalize-phi (args b)
+ ;; Concatenate into args all incoming m-vars for this phi.
+ (setcdr args
+ (cl-loop with slot-n = (comp-mvar-slot (car args))
+ for e in (comp-block-in-edges b)
+ for b = (comp-edge-src e)
+ for in-frame = (comp-block-final-frame b)
+ collect (list (comp-vec-aref in-frame slot-n)
+ (comp-block-name b))))))
+
+ (cl-loop for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop for (op . args) in (comp-block-insns b)
+ when (eq op 'phi)
+ do (finalize-phi args b)))))
+
+(defun comp-remove-unreachable-blocks ()
+ "Remove unreachable basic blocks.
+Return t when one or more block was removed, nil otherwise."
+ (cl-loop
+ with ret
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ for bb-name = (comp-block-name bb)
+ when (and (not (eq 'entry bb-name))
+ (null (comp-block-idom bb)))
+ do
+ (comp-log (format "Removing block: %s" bb-name) 1)
+ (remhash bb-name (comp-func-blocks comp-func))
+ (setf (comp-func-ssa-status comp-func) t
+ ret t)
+ finally return ret))
+
+(defun comp-ssa ()
+ "Port all functions into minimal SSA form."
+ (maphash (lambda (_ f)
+ (let* ((comp-func f)
+ (ssa-status (comp-func-ssa-status f)))
+ (unless (eq ssa-status t)
+ (cl-loop
+ when (eq ssa-status 'dirty)
+ do (comp-clean-ssa f)
+ do (comp-compute-edges)
+ (comp-compute-dominator-tree)
+ until (null (comp-remove-unreachable-blocks)))
+ (comp-compute-dominator-frontiers)
+ (comp-log-block-info)
+ (comp-place-phis)
+ (comp-ssa-rename)
+ (comp-finalize-phis)
+ (comp-log-func comp-func 3)
+ (setf (comp-func-ssa-status f) t))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; propagate pass specific code.
+;; A very basic propagation pass follows.
+;; This propagates values and types plus ref property in the control flow graph.
+;; This is also responsible for removing function calls to pure functions if
+;; possible.
+
+(defconst comp-fwprop-max-insns-scan 4500
+ ;; Chosen as ~ the greatest required value for full convergence
+ ;; native compiling all Emacs code-base.
+ "Max number of scanned insn before giving-up.")
+
+(defun comp-copy-insn (insn)
+ "Deep copy INSN."
+ ;; Adapted from `copy-tree'.
+ (if (consp insn)
+ (let (result)
+ (while (consp insn)
+ (let ((newcar (car insn)))
+ (if (or (consp (car insn)) (comp-mvar-p (car insn)))
+ (setf newcar (comp-copy-insn (car insn))))
+ (push newcar result))
+ (setf insn (cdr insn)))
+ (nconc (nreverse result)
+ (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn)
+ (copy-comp-mvar insn)
+ insn)))
+
+(defmacro comp-apply-in-env (func &rest args)
+ "Apply FUNC to ARGS in the current compilation environment."
+ `(let ((env (cl-loop
+ for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
+ for func-name = (comp-func-name f)
+ for byte-code = (comp-func-byte-func f)
+ when func-name
+ collect `(,func-name . ,(symbol-function func-name))
+ and do
+ (setf (symbol-function func-name) byte-code))))
+ (unwind-protect
+ (apply ,func ,@args)
+ (cl-loop
+ for (func-name . def) in env
+ do (setf (symbol-function func-name) def)))))
+
+(defun comp-fwprop-prologue ()
+ "Prologue for the propagate pass.
+Here goes everything that can be done not iteratively (read once).
+Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked?
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ do (pcase insn
+ (`(setimm ,lval ,v)
+ (setf (comp-cstr-imm lval) v))))))
+
+(defun comp-mvar-propagate (lval rval)
+ "Propagate into LVAL properties of RVAL."
+ (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
+ (comp-mvar-valset lval) (comp-mvar-valset rval)
+ (comp-mvar-range lval) (comp-mvar-range rval)
+ (comp-mvar-neg lval) (comp-mvar-neg rval)))
+
+(defun comp-function-foldable-p (f args)
+ "Given function F called with ARGS, return non-nil when optimizable."
+ (and (comp-function-pure-p f)
+ (cl-every #'comp-cstr-imm-vld-p args)))
+
+(defun comp-function-call-maybe-fold (insn f args)
+ "Given INSN, when F is pure if all ARGS are known, remove the function call.
+Return non-nil if the function is folded successfully."
+ (cl-flet ((rewrite-insn-as-setimm (insn value)
+ ;; See `comp-emit-setimm'.
+ (comp-add-const-to-relocs value)
+ (setf (car insn) 'setimm
+ (cddr insn) `(,value))))
+ (cond
+ ((eq f 'symbol-value)
+ (when-let* ((arg0 (car args))
+ (const (comp-cstr-imm-vld-p arg0))
+ (ok-to-optim (member (comp-cstr-imm arg0)
+ comp-symbol-values-optimizable)))
+ (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm
+ (car args))))))
+ ((comp-function-foldable-p f args)
+ (ignore-errors
+ ;; No point to complain here in case of error because we
+ ;; should do basic block pruning in order to be sure that this
+ ;; is not dead-code. This is now left to gcc, to be
+ ;; implemented only if we want a reliable diagnostic here.
+ (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f))
+ ;; If the function is IN the compilation ctxt
+ ;; and know to be pure.
+ (comp-func-byte-func f-in-ctxt)
+ f))
+ (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args))))
+ (rewrite-insn-as-setimm insn value)))))))
+
+(defun comp-fwprop-call (insn lval f args)
+ "Propagate on a call INSN into LVAL.
+F is the function being called with arguments ARGS.
+Fold the call in case."
+ (unless (comp-function-call-maybe-fold insn f args)
+ (when (and (eq 'funcall f)
+ (comp-cstr-imm-vld-p (car args)))
+ (setf f (comp-cstr-imm (car args))
+ args (cdr args)))
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (let ((cstr (comp-cstr-f-ret cstr-f)))
+ (when (comp-cstr-empty-p cstr)
+ ;; Store it to be rewritten as non local exit.
+ (setf (comp-block-lap-non-ret-insn comp-block) insn))
+ (setf (comp-mvar-range lval) (comp-cstr-range cstr)
+ (comp-mvar-valset lval) (comp-cstr-valset cstr)
+ (comp-mvar-typeset lval) (comp-cstr-typeset cstr)
+ (comp-mvar-neg lval) (comp-cstr-neg cstr))))
+ (cl-case f
+ (+ (comp-cstr-add lval args))
+ (- (comp-cstr-sub lval args))
+ (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
+ (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
+
+(defun comp-fwprop-insn (insn)
+ "Propagate within INSN."
+ (pcase insn
+ (`(set ,lval ,rval)
+ (pcase rval
+ (`(,(or 'call 'callref) ,f . ,args)
+ (comp-fwprop-call insn lval f args))
+ (`(,(or 'direct-call 'direct-callref) ,f . ,args)
+ (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
+ (comp-fwprop-call insn lval f args)))
+ (_
+ (comp-mvar-propagate lval rval))))
+ (`(assume ,lval ,(and (pred comp-mvar-p) rval))
+ (comp-mvar-propagate lval rval))
+ (`(assume ,lval (,kind . ,operands))
+ (cl-case kind
+ (and
+ (apply #'comp-cstr-intersection lval operands))
+ (and-nhc
+ (apply #'comp-cstr-intersection-no-hashcons lval operands))
+ (not
+ ;; Prevent double negation!
+ (unless (comp-cstr-neg (car operands))
+ (comp-cstr-value-negation lval (car operands))))
+ (>
+ (comp-cstr-> lval (car operands) (cadr operands)))
+ (>=
+ (comp-cstr->= lval (car operands) (cadr operands)))
+ (<
+ (comp-cstr-< lval (car operands) (cadr operands)))
+ (<=
+ (comp-cstr-<= lval (car operands) (cadr operands)))
+ (=
+ (comp-cstr-= lval (car operands) (cadr operands)))))
+ (`(setimm ,lval ,v)
+ (setf (comp-cstr-imm lval) v))
+ (`(phi ,lval . ,rest)
+ (let* ((from-latch (cl-some
+ (lambda (x)
+ (let* ((bb-name (cadr x))
+ (bb (gethash bb-name
+ (comp-func-blocks comp-func))))
+ (or (comp-latch-p bb)
+ (when (comp-block-cstr-p bb)
+ (comp-latch-p (car (comp-block-preds bb)))))))
+ rest))
+ (prop-fn (if from-latch
+ #'comp-cstr-union-no-range
+ #'comp-cstr-union))
+ (rvals (mapcar #'car rest)))
+ (apply prop-fn lval rvals)))))
+
+(defun comp-fwprop* ()
+ "Propagate for set* and phi operands.
+Return t if something was changed."
+ (cl-loop named outer
+ with modified = nil
+ with i = 0
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ with comp-block = b
+ for insn in (comp-block-insns b)
+ for orig-insn = (unless modified
+ ;; Save consing after 1st change.
+ (comp-copy-insn insn))
+ do
+ (comp-fwprop-insn insn)
+ (cl-incf i)
+ when (and (null modified) (not (equal insn orig-insn)))
+ do (setf modified t))
+ when (> i comp-fwprop-max-insns-scan)
+ do (cl-return-from outer nil)
+ finally return modified))
+
+(defun comp-rewrite-non-locals ()
+ "Make explicit in LIMPLE non-local exits if identified."
+ (cl-loop
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ for non-local-insn = (and (comp-block-lap-p bb)
+ (comp-block-lap-non-ret-insn bb))
+ when non-local-insn
+ do
+ ;; Rework the current block.
+ (let* ((insn-seq (memq non-local-insn (comp-block-insns bb))))
+ (setf (comp-block-lap-non-ret-insn bb) ()
+ (comp-block-lap-no-ret bb) t
+ (comp-block-out-edges bb) ()
+ ;; Prune unnecessary insns!
+ (cdr insn-seq) '((unreachable))
+ (comp-func-ssa-status comp-func) 'dirty))))
+
+(defun comp-fwprop (_)
+ "Forward propagate types and consts within the lattice."
+ (comp-ssa)
+ (comp-dead-code)
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ ;; FIXME remove the following condition when tested.
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f))
+ (comp-fwprop-prologue)
+ (cl-loop
+ for i from 1 to 100
+ while (comp-fwprop*)
+ finally
+ (when (= i 100)
+ (display-warning
+ 'comp
+ (format "fwprop pass jammed into %s?" (comp-func-name f))))
+ (comp-log (format "Propagation run %d times\n" i) 2))
+ (comp-rewrite-non-locals)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Call optimizer pass specific code.
+;; This pass is responsible for the following optimizations:
+;; - Call to subrs that are in defined in the C source and are passing through
+;; funcall trampoline gets optimized into normal indirect calls.
+;; This makes effectively this calls equivalent to all the subrs that got
+;; dedicated byte-code ops.
+;; Triggered at native-comp-speed >= 2.
+;; - Recursive calls gets optimized into direct calls.
+;; Triggered at native-comp-speed >= 2.
+;; - Intra compilation unit procedure calls gets optimized into direct calls.
+;; This can be a big win and even allow gcc to inline but does not make
+;; function in the compilation unit re-definable safely without recompiling
+;; the full compilation unit.
+;; For this reason this is triggered only at native-comp-speed == 3.
+
+(defun comp-func-in-unit (func)
+ "Given FUNC return the `comp-fun' definition in the current context.
+FUNCTION can be a function-name or byte compiled function."
+ (if (symbolp func)
+ (comp-symbol-func-to-fun func)
+ (cl-assert (byte-code-function-p func))
+ (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
+
+(defun comp-call-optim-form-call (callee args)
+ (cl-flet ((fill-args (args total)
+ ;; Fill missing args to reach TOTAL
+ (append args (cl-loop repeat (- total (length args))
+ collect (make-comp-mvar :constant nil)))))
+ (when (and callee
+ (or (symbolp callee)
+ (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt)))
+ (not (memq callee native-comp-never-optimize-functions)))
+ (let* ((f (if (symbolp callee)
+ (symbol-function callee)
+ (cl-assert (byte-code-function-p callee))
+ callee))
+ (subrp (subrp f))
+ (comp-func-callee (comp-func-in-unit callee)))
+ (cond
+ ((and subrp (not (subr-native-elisp-p f)))
+ ;; Trampoline removal.
+ (let* ((callee (intern (subr-name f))) ; Fix aliased names.
+ (maxarg (cdr (subr-arity f)))
+ (call-type (if (if subrp
+ (not (numberp maxarg))
+ (comp-nargs-p comp-func-callee))
+ 'callref
+ 'call))
+ (args (if (eq call-type 'callref)
+ args
+ (fill-args args maxarg))))
+ `(,call-type ,callee ,@args)))
+ ;; Intra compilation unit procedure call optimization.
+ ;; Attention speed 3 triggers this for non self calls too!!
+ ((and comp-func-callee
+ (comp-func-c-name comp-func-callee)
+ (or (and (>= (comp-func-speed comp-func) 3)
+ (comp-func-unique-in-cu-p callee))
+ (and (>= (comp-func-speed comp-func) 2)
+ ;; Anonymous lambdas can't be redefined so are
+ ;; always safe to optimize.
+ (byte-code-function-p callee))))
+ (let* ((func-args (comp-func-l-args comp-func-callee))
+ (nargs (comp-nargs-p func-args))
+ (call-type (if nargs 'direct-callref 'direct-call))
+ (args (if (eq call-type 'direct-callref)
+ args
+ (fill-args args (comp-args-max func-args)))))
+ `(,call-type ,(comp-func-c-name comp-func-callee) ,@args)))
+ ((comp-type-hint-p callee)
+ `(call ,callee ,@args)))))))
+
+(defun comp-call-optim-func ()
+ "Perform the trampoline call optimization for the current function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (pcase insn
+ (`(set ,lval (callref funcall ,f . ,rest))
+ (when-let ((ok (comp-cstr-imm-vld-p f))
+ (new-form (comp-call-optim-form-call
+ (comp-cstr-imm f) rest)))
+ (setf insn `(set ,lval ,new-form))))
+ (`(callref funcall ,f . ,rest)
+ (when-let ((ok (comp-cstr-imm-vld-p f))
+ (new-form (comp-call-optim-form-call
+ (comp-cstr-imm f) rest)))
+ (setf insn new-form)))))))
+
+(defun comp-call-optim (_)
+ "Try to optimize out funcall trampoline usage when possible."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ (comp-func-l-p f))
+ (let ((comp-func f))
+ (comp-call-optim-func))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Dead code elimination pass specific code.
+;; This simple pass try to eliminate insns became useful after propagation.
+;; Even if gcc would take care of this is good to perform this here
+;; in the hope of removing memory references.
+;;
+;; This pass can be run as last optim.
+
+(defun comp-collect-mvar-ids (insn)
+ "Collect the m-var unique identifiers into INSN."
+ (cl-loop for x in insn
+ if (consp x)
+ append (comp-collect-mvar-ids x)
+ else
+ when (comp-mvar-p x)
+ collect (comp-mvar-id x)))
+
+(defun comp-dead-assignments-func ()
+ "Clean-up dead assignments into current function.
+Return the list of m-var ids nuked."
+ (let ((l-vals ())
+ (r-vals ()))
+ ;; Collect used r and l-values.
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ for (op arg0 . rest) = insn
+ if (comp-assign-op-p op)
+ do (push (comp-mvar-id arg0) l-vals)
+ (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals))
+ else
+ do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals))))
+ ;; Every l-value appearing that does not appear as r-value has no right to
+ ;; exist and gets nuked.
+ (let ((nuke-list (cl-set-difference l-vals r-vals)))
+ (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n"
+ (comp-func-name comp-func)
+ l-vals
+ r-vals
+ nuke-list)
+ 3)
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
+ (when (and (comp-assign-op-p op)
+ (memq (comp-mvar-id arg0) nuke-list))
+ (setf insn
+ (if (comp-limple-insn-call-p arg1)
+ arg1
+ `(comment ,(format "optimized out: %s"
+ insn))))))))
+ nuke-list)))
+
+(defun comp-dead-code ()
+ "Dead code elimination."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ ;; FIXME remove the following condition when tested.
+ (not (comp-func-has-non-local f)))
+ (cl-loop
+ for comp-func = f
+ for i from 1
+ while (comp-dead-assignments-func)
+ finally (comp-log (format "dead code rm run %d times\n" i) 2)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Tail Call Optimization pass specific code.
+
+(defun comp-form-tco-call-seq (args)
+ "Generate a TCO sequence for ARGS."
+ `(,@(cl-loop for arg in args
+ for i from 0
+ collect `(set ,(make-comp-mvar :slot i) ,arg))
+ (jump bb_0)))
+
+(defun comp-tco-func ()
+ "Try to pattern match and perform TCO within the current function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ named in-the-basic-block
+ for insns-seq on (comp-block-insns b)
+ do (pcase insns-seq
+ (`((set ,l-val (direct-call ,func . ,args))
+ ;; (comment ,_comment)
+ (return ,ret-val))
+ (when (and (string= func (comp-func-c-name comp-func))
+ (eq l-val ret-val))
+ (let ((tco-seq (comp-form-tco-call-seq args)))
+ (setf (car insns-seq) (car tco-seq)
+ (cdr insns-seq) (cdr tco-seq)
+ (comp-func-ssa-status comp-func) 'dirty)
+ (cl-return-from in-the-basic-block))))))))
+
+(defun comp-tco (_)
+ "Simple peephole pass performing self TCO."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 3)
+ (comp-func-l-p f)
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f))
+ (comp-tco-func)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Type hint removal pass specific code.
+
+;; This must run after all SSA prop not to have the type hint
+;; information overwritten.
+
+(defun comp-remove-type-hints-func ()
+ "Remove type hints from the current function.
+These are substituted with a normal 'set' op."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (pcase insn
+ (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val))
+ (setf insn `(set ,l-val ,r-val)))))))
+
+(defun comp-remove-type-hints (_)
+ "Dead code elimination."
+ (maphash (lambda (_ f)
+ (when (>= (comp-func-speed f) 2)
+ (let ((comp-func f))
+ (comp-remove-type-hints-func)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Final pass specific code.
+
+(defun comp-args-to-lambda-list (args)
+ "Return a lambda list for ARGS."
+ (cl-loop
+ with res
+ repeat (comp-args-base-min args)
+ do (push t res)
+ finally
+ (if (comp-args-p args)
+ (cl-loop
+ with n = (- (comp-args-max args) (comp-args-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res))
+ (cl-loop
+ with n = (- (comp-nargs-nonrest args) (comp-nargs-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res)
+ finally (when (comp-nargs-rest args)
+ (push '&rest res)
+ (push 't res))))
+ (cl-return (reverse res))))
+
+(defun comp-compute-function-type (_ func)
+ "Compute type specifier for `comp-func' FUNC.
+Set it into the `type' slot."
+ (when (and (comp-func-l-p func)
+ (comp-mvar-p (comp-func-type func)))
+ (let* ((comp-func (make-comp-func))
+ (res-mvar (apply #'comp-cstr-union
+ (make-comp-cstr)
+ (cl-loop
+ with res = nil
+ for bb being the hash-value in (comp-func-blocks
+ func)
+ do (cl-loop
+ for insn in (comp-block-insns bb)
+ ;; Collect over every exit point the returned
+ ;; mvars and union results.
+ do (pcase insn
+ (`(return ,mvar)
+ (push mvar res))))
+ finally return res)))
+ (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func))
+ ,(comp-cstr-to-type-spec res-mvar))))
+ (comp-add-const-to-relocs type)
+ ;; Fix it up.
+ (setf (comp-cstr-imm (comp-func-type func)) type))))
+
+(defun comp-finalize-container (cont)
+ "Finalize data container CONT."
+ (setf (comp-data-container-l cont)
+ (cl-loop with h = (comp-data-container-idx cont)
+ for obj each hash-keys of h
+ for i from 0
+ do (puthash obj i h)
+ ;; Prune byte-code objects coming from lambdas.
+ ;; These are not anymore necessary as they will be
+ ;; replaced at load time by native-elisp-subrs.
+ ;; Note: we leave the objects in the idx hash table
+ ;; to still be able to retrieve the correct index
+ ;; from the corresponding m-var.
+ collect (if (gethash obj
+ (comp-ctxt-byte-func-to-func-h comp-ctxt))
+ 'lambda-fixup
+ obj))))
+
+(defun comp-finalize-relocs ()
+ "Finalize data containers for each relocation class.
+Remove immediate duplicates within relocation classes.
+Update all insn accordingly."
+ ;; Symbols imported by C inlined functions. We do this here because
+ ;; is better to add all objs to the relocation containers before we
+ ;; compacting them.
+ (mapc #'comp-add-const-to-relocs '(nil t consp listp))
+
+ (let* ((d-default (comp-ctxt-d-default comp-ctxt))
+ (d-default-idx (comp-data-container-idx d-default))
+ (d-impure (comp-ctxt-d-impure comp-ctxt))
+ (d-impure-idx (comp-data-container-idx d-impure))
+ (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
+ (d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
+ ;; We never want compiled lambdas ending up in pure space. A copy must
+ ;; be already present in impure (see `comp-emit-lambda-for-top-level').
+ (cl-loop for obj being each hash-keys of d-default-idx
+ when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
+ do (cl-assert (gethash obj d-impure-idx))
+ (remhash obj d-default-idx))
+ ;; Remove entries in d-impure already present in d-default.
+ (cl-loop for obj being each hash-keys of d-impure-idx
+ when (gethash obj d-default-idx)
+ do (remhash obj d-impure-idx))
+ ;; Remove entries in d-ephemeral already present in d-default or
+ ;; d-impure.
+ (cl-loop for obj being each hash-keys of d-ephemeral-idx
+ when (or (gethash obj d-default-idx) (gethash obj d-impure-idx))
+ do (remhash obj d-ephemeral-idx))
+ ;; Fix-up indexes in each relocation class and fill corresponding
+ ;; reloc lists.
+ (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))
+ ;; Make a vector from the function documentation hash table.
+ (cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
+ with v = (make-vector (hash-table-count h) nil)
+ for idx being each hash-keys of h
+ for doc = (gethash idx h)
+ do (setf (aref v idx) doc)
+ finally
+ do (setf (comp-ctxt-function-docs comp-ctxt) v))
+ ;; And now we conclude with the following: We need to pass to
+ ;; `comp--register-lambda' the index in the impure relocation
+ ;; array to store revived lambdas, but given we know it only now
+ ;; we fix it up as last.
+ (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt)
+ using (hash-value mvar)
+ with reverse-h = (make-hash-table) ;; Make sure idx is unique.
+ for idx = (gethash f d-impure-idx)
+ do
+ (cl-assert (null (gethash idx reverse-h)))
+ (cl-assert (fixnump idx))
+ (setf (comp-mvar-valset mvar) ()
+ (comp-mvar-range mvar) (list (cons idx idx)))
+ (puthash idx t reverse-h))))
+
+(defun comp-compile-ctxt-to-file (name)
+ "Compile as native code the current context naming it NAME.
+Prepare every function for final compilation and drive the C back-end."
+ (let ((dir (file-name-directory name)))
+ (comp-finalize-relocs)
+ (maphash (lambda (_ f)
+ (comp-log-func f 1))
+ (comp-ctxt-funcs-h comp-ctxt))
+ (unless (file-exists-p dir)
+ ;; In case it's created in the meanwhile.
+ (ignore-error file-already-exists
+ (make-directory dir t)))
+ (comp--compile-ctxt-to-file name)))
+
+(defun comp-final1 ()
+ (let (compile-result)
+ (comp--init-ctxt)
+ (unwind-protect
+ (setf compile-result
+ (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))
+ (and (comp--release-ctxt)
+ compile-result))))
+
+(defvar comp-async-compilation nil
+ "Non-nil while executing an asynchronous native compilation.")
+
+(defun comp-final (_)
+ "Final pass driving the C back-end for code emission."
+ (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt))
+ (unless comp-dry-run
+ ;; Always run the C side of the compilation as a sub-process
+ ;; unless during bootstrap or async compilation (bug#45056). GCC
+ ;; leaks memory but also interfere with the ability of Emacs to
+ ;; detect when a sub-process completes (TODO understand why).
+ (if (or byte+native-compile comp-async-compilation)
+ (comp-final1)
+ ;; Call comp-final1 in a child process.
+ (let* ((output (comp-ctxt-output comp-ctxt))
+ (print-escape-newlines t)
+ (print-length nil)
+ (print-level nil)
+ (print-quoted t)
+ (print-gensym t)
+ (print-circle t)
+ (print-escape-multibyte t)
+ (expr `((require 'comp)
+ (setf native-comp-verbose ,native-comp-verbose
+ comp-libgccjit-reproducer ,comp-libgccjit-reproducer
+ comp-ctxt ,comp-ctxt
+ native-comp-eln-load-path ',native-comp-eln-load-path
+ native-comp-driver-options
+ ',native-comp-driver-options
+ load-path ',load-path)
+ ,native-comp-async-env-modifier-form
+ (message "Compiling %s..." ',output)
+ (comp-final1)))
+ (temp-file (make-temp-file
+ (concat "emacs-int-comp-"
+ (file-name-base output) "-")
+ nil ".el")))
+ (with-temp-file temp-file
+ (insert ";; -*-coding: nil; -*-\n")
+ (mapc (lambda (e)
+ (insert (prin1-to-string e)))
+ expr))
+ (with-temp-buffer
+ (unwind-protect
+ (if (zerop
+ (call-process (expand-file-name invocation-name
+ invocation-directory)
+ nil t t "--batch" "-l" temp-file))
+ (progn
+ (delete-file temp-file)
+ output)
+ (signal 'native-compiler-error (buffer-string)))
+ (comp-log-to-buffer (buffer-string))))))))
+
+
+;;; Compiler type hints.
+;; Public entry points to be used by user code to give comp
+;; suggestions about types. These are used to implement CL style
+;; `cl-the' and hopefully parameter type declaration.
+;; Note: types will propagates.
+;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions
+;; are assumed just to be true. Use with extreme caution...
+
+(defun comp-hint-fixnum (x)
+ (declare (gv-setter (lambda (val) `(setf ,x ,val))))
+ x)
+
+(defun comp-hint-cons (x)
+ (declare (gv-setter (lambda (val) `(setf ,x ,val))))
+ x)
+
+
+;; Primitive function advice machinery
+
+(defun comp-eln-load-path-eff ()
+ "Return a list of effective eln load directories.
+Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
+ (mapcar (lambda (dir)
+ (expand-file-name comp-native-version-dir
+ (file-name-as-directory
+ (expand-file-name dir invocation-directory))))
+ native-comp-eln-load-path))
+
+(defun comp-trampoline-filename (subr-name)
+ "Given SUBR-NAME return the filename containing the trampoline."
+ (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
+
+(defun comp-make-lambda-list-from-subr (subr)
+ "Given SUBR return the equivalent lambda-list."
+ (pcase-let ((`(,min . ,max) (subr-arity subr))
+ (lambda-list '()))
+ (cl-loop repeat min
+ do (push (gensym "arg") lambda-list))
+ (if (numberp max)
+ (cl-loop
+ initially (push '&optional lambda-list)
+ repeat (- max min)
+ do (push (gensym "arg") lambda-list))
+ (push '&rest lambda-list)
+ (push (gensym "arg") lambda-list))
+ (reverse lambda-list)))
+
+(defun comp-trampoline-search (subr-name)
+ "Search a trampoline file for SUBR-NAME.
+Return the trampoline if found or nil otherwise."
+ (cl-loop
+ with rel-filename = (comp-trampoline-filename subr-name)
+ for dir in (comp-eln-load-path-eff)
+ for filename = (expand-file-name rel-filename dir)
+ when (file-exists-p filename)
+ do (cl-return (native-elisp-load filename))))
+
+(defun comp-trampoline-compile (subr-name)
+ "Synthesize compile and return a trampoline for SUBR-NAME."
+ (let* ((lambda-list (comp-make-lambda-list-from-subr
+ (symbol-function subr-name)))
+ ;; The synthesized trampoline must expose the exact same ABI of
+ ;; the primitive we are replacing in the function reloc table.
+ (form `(lambda ,lambda-list
+ (let ((f #',subr-name))
+ (,(if (memq '&rest lambda-list) #'apply 'funcall)
+ f
+ ,@(cl-loop
+ for arg in lambda-list
+ unless (memq arg '(&optional &rest))
+ collect arg)))))
+ ;; Use speed 0 to maximize compilation speed and not to
+ ;; optimize away funcall calls!
+ (byte-optimize nil)
+ (native-comp-speed 1)
+ (lexical-binding t))
+ (comp--native-compile
+ form nil
+ (cl-loop
+ for dir in (comp-eln-load-path-eff)
+ for f = (expand-file-name
+ (comp-trampoline-filename subr-name)
+ dir)
+ unless (file-exists-p dir)
+ do (ignore-errors
+ (make-directory dir t)
+ (cl-return f))
+ when (file-writable-p f)
+ do (cl-return f)
+ finally (error "Cannot find suitable directory for output in \
+`native-comp-eln-load-path'")))))
+
+
+;; Some entry point support code.
+
+;;;###autoload
+(defun comp-clean-up-stale-eln (file)
+ "Given FILE remove all its *.eln files in `native-comp-eln-load-path'
+sharing the original source filename (including FILE)."
+ (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos)
+ file)
+ (cl-loop
+ with filename-hash = (match-string 1 file)
+ with regexp = (rx-to-string
+ `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos))
+ for dir in (comp-eln-load-path-eff)
+ do (cl-loop
+ for f in (when (file-exists-p dir)
+ (directory-files dir t regexp t))
+ ;; We may not be able to delete the file if we have no write
+ ;; permission.
+ do (ignore-error file-error
+ (comp-delete-or-replace-file f))))))
+
+(defun comp-delete-or-replace-file (oldfile &optional newfile)
+ "Replace OLDFILE with NEWFILE.
+When NEWFILE is nil just delete OLDFILE.
+Takes the necessary steps when dealing with OLDFILE being a
+shared library that might be currently loaded into a running Emacs
+session."
+ (cond ((eq 'windows-nt system-type)
+ (ignore-errors (delete-file oldfile))
+ (while
+ (condition-case _
+ (progn
+ ;; oldfile maybe recreated by another Emacs in
+ ;; between the following two rename-file calls
+ (if (file-exists-p oldfile)
+ (rename-file oldfile (make-temp-file-internal
+ (file-name-sans-extension oldfile)
+ nil ".eln.old" nil)
+ t))
+ (when newfile
+ (rename-file newfile oldfile nil))
+ ;; Keep on trying.
+ nil)
+ (file-already-exists
+ ;; Done
+ t))))
+ ;; Remove the old eln instead of copying the new one into it
+ ;; to get a new inode and prevent crashes in case the old one
+ ;; is currently loaded.
+ (t (delete-file oldfile)
+ (when newfile
+ (rename-file newfile oldfile)))))
+
+(defvar comp-files-queue ()
+ "List of Emacs Lisp files to be compiled.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+(defun comp-async-runnings ()
+ "Return the number of async compilations currently running.
+This function has the side effect of cleaning-up finished
+processes from `comp-async-compilations'"
+ (cl-loop
+ for file-name in (cl-loop
+ for file-name being each hash-key of comp-async-compilations
+ for prc = (gethash file-name comp-async-compilations)
+ unless (process-live-p prc)
+ collect file-name)
+ do (remhash file-name comp-async-compilations))
+ (hash-table-count comp-async-compilations))
+
+(declare-function w32-get-nproc "w32.c")
+(defvar comp-num-cpus nil)
+(defun comp-effective-async-max-jobs ()
+ "Compute the effective number of async jobs."
+ (if (zerop native-comp-async-jobs-number)
+ (or comp-num-cpus
+ (setf comp-num-cpus
+ ;; FIXME: we already have a function to determine
+ ;; the number of processors, see get_native_system_info in w32.c.
+ ;; The result needs to be exported to Lisp.
+ (max 1 (/ (cond ((eq 'windows-nt system-type)
+ (w32-get-nproc))
+ ((executable-find "nproc")
+ (string-to-number
+ (shell-command-to-string "nproc")))
+ ((eq 'berkeley-unix system-type)
+ (string-to-number
+ (shell-command-to-string "sysctl -n hw.ncpu")))
+ (t 1))
+ 2))))
+ native-comp-async-jobs-number))
+
+(defvar comp-last-scanned-async-output nil)
+(make-variable-buffer-local 'comp-last-scanned-async-output)
+(defun comp-accept-and-process-async-output (process)
+ "Accept PROCESS output and check for diagnostic messages."
+ (if native-comp-async-report-warnings-errors
+ (let ((warning-suppress-types
+ (if (eq native-comp-async-report-warnings-errors 'silent)
+ (cons '(comp) warning-suppress-types)
+ warning-suppress-types)))
+ (with-current-buffer (process-buffer process)
+ (save-excursion
+ (accept-process-output process)
+ (goto-char (or comp-last-scanned-async-output (point-min)))
+ (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$"
+ nil t)
+ (display-warning 'comp (match-string 0)))
+ (setq comp-last-scanned-async-output (point-max)))))
+ (accept-process-output process)))
+
+(defun comp-run-async-workers ()
+ "Start compiling files from `comp-files-queue' asynchronously.
+When compilation is finished, run `native-comp-async-all-done-hook' and
+display a message."
+ (if (or comp-files-queue
+ (> (comp-async-runnings) 0))
+ (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ (cl-loop
+ for (source-file . load) = (pop comp-files-queue)
+ while source-file
+ do (cl-assert (string-match-p comp-valid-source-re source-file) nil
+ "`comp-files-queue' should be \".el\" files: %s"
+ source-file)
+ when (or native-comp-always-compile
+ load ; Always compile when the compilation is
+ ; commanded for late load.
+ (file-newer-than-file-p
+ source-file (comp-el-to-eln-filename source-file)))
+ do (let* ((expr `((require 'comp)
+ ,(when (boundp 'backtrace-line-length)
+ `(setf backtrace-line-length ,backtrace-line-length))
+ (setf native-comp-speed ,native-comp-speed
+ native-comp-debug ,native-comp-debug
+ native-comp-verbose ,native-comp-verbose
+ comp-libgccjit-reproducer ,comp-libgccjit-reproducer
+ comp-async-compilation t
+ native-comp-eln-load-path ',native-comp-eln-load-path
+ native-comp-driver-options
+ ',native-comp-driver-options
+ load-path ',load-path
+ warning-fill-column most-positive-fixnum)
+ ,native-comp-async-env-modifier-form
+ (message "Compiling %s..." ,source-file)
+ (comp--native-compile ,source-file ,(and load t))))
+ (source-file1 source-file) ;; Make the closure works :/
+ (temp-file (make-temp-file
+ (concat "emacs-async-comp-"
+ (file-name-base source-file) "-")
+ nil ".el"))
+ (expr-strings (mapcar #'prin1-to-string expr))
+ (_ (progn
+ (with-temp-file temp-file
+ (mapc #'insert expr-strings))
+ (comp-log "\n")
+ (mapc #'comp-log expr-strings)))
+ (load1 load)
+ (process (make-process
+ :name (concat "Compiling: " source-file)
+ :buffer (with-current-buffer
+ (get-buffer-create
+ comp-async-buffer-name)
+ (setf buffer-read-only t)
+ (current-buffer))
+ :command (list
+ (expand-file-name invocation-name
+ invocation-directory)
+ "--batch" "-l" temp-file)
+ :sentinel
+ (lambda (process _event)
+ (run-hook-with-args
+ 'native-comp-async-cu-done-functions
+ source-file)
+ (comp-accept-and-process-async-output process)
+ (ignore-errors (delete-file temp-file))
+ (let ((eln-file (comp-el-to-eln-filename
+ source-file1)))
+ (when (and load1
+ (zerop (process-exit-status
+ process))
+ (file-exists-p eln-file))
+ (native-elisp-load eln-file
+ (eq load1 'late))))
+ (comp-run-async-workers))
+ :noquery (not native-comp-async-query-on-exit))))
+ (puthash source-file process comp-async-compilations))
+ when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ do (cl-return)))
+ ;; No files left to compile and all processes finished.
+ (run-hooks 'native-comp-async-all-done-hook)
+ (with-current-buffer (get-buffer-create comp-async-buffer-name)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (insert "Compilation finished.\n"))))
+ ;; `comp-deferred-pending-h' should be empty at this stage.
+ ;; Reset it anyway.
+ (clrhash comp-deferred-pending-h)))
+
+(defun comp--native-compile (function-or-file &optional with-late-load output)
+ "Compile FUNCTION-OR-FILE into native code.
+When WITH-LATE-LOAD is non-nil, mark the compilation unit for late
+load once it finishes compiling.
+This serves as internal implementation of `native-compile' but
+allowing for WITH-LATE-LOAD to be controlled is in use also for
+the deferred compilation mechanism."
+ (comp-ensure-native-compiler)
+ (unless (or (functionp function-or-file)
+ (stringp function-or-file))
+ (signal 'native-compiler-error
+ (list "Not a function symbol or file" function-or-file)))
+ (catch 'no-native-compile
+ (let* ((data function-or-file)
+ (comp-native-compiling t)
+ (byte-native-qualities nil)
+ ;; Have byte compiler signal an error when compilation fails.
+ (byte-compile-debug t)
+ (comp-ctxt (make-comp-ctxt :output output
+ :with-late-load with-late-load)))
+ (comp-log "\n \n" 1)
+ (condition-case err
+ (cl-loop
+ with report = nil
+ for t0 = (current-time)
+ for pass in comp-passes
+ unless (memq pass comp-disabled-passes)
+ do
+ (comp-log (format "(%s) Running pass %s:\n"
+ function-or-file pass)
+ 2)
+ (setf data (funcall pass data))
+ (push (cons pass (float-time (time-since t0))) report)
+ (cl-loop for f in (alist-get pass comp-post-pass-hooks)
+ do (funcall f data))
+ finally
+ (when comp-log-time-report
+ (comp-log (format "Done compiling %s" data) 0)
+ (cl-loop for (pass . time) in (reverse report)
+ do (comp-log (format "Pass %s took: %fs." pass time) 0))))
+ (native-compiler-skip)
+ (t
+ (let ((err-val (cdr err)))
+ ;; If we are doing an async native compilation print the
+ ;; error in the correct format so is parsable and abort.
+ (if (and comp-async-compilation
+ (not (eq (car err) 'native-compiler-error)))
+ (progn
+ (message (if err-val
+ "%s: Error: %s %s"
+ "%s: Error %s")
+ function-or-file
+ (get (car err) 'error-message)
+ (car-safe err-val))
+ (kill-emacs -1))
+ ;; Otherwise re-signal it adding the compilation input.
+ (signal (car err) (if (consp err-val)
+ (cons function-or-file err-val)
+ (list function-or-file err-val)))))))
+ (if (stringp function-or-file)
+ data
+ ;; So we return the compiled function.
+ (native-elisp-load data)))))
+
+(defun native-compile-async-skip-p (file load selector)
+ "Return non-nil if FILE's compilation should be skipped.
+
+LOAD and SELECTOR work as described in `native--compile-async'."
+ ;; Make sure we are not already compiling `file' (bug#40838).
+ (or (gethash file comp-async-compilations)
+ (cond
+ ((null selector) nil)
+ ((functionp selector) (not (funcall selector file)))
+ ((stringp selector) (not (string-match-p selector file)))
+ (t (error "SELECTOR must be a function a regexp or nil")))
+ ;; Also exclude files from deferred compilation if
+ ;; any of the regexps in
+ ;; `native-comp-deferred-compilation-deny-list' matches.
+ (and (eq load 'late)
+ (cl-some (lambda (re)
+ (string-match-p re file))
+ native-comp-deferred-compilation-deny-list))))
+
+(defun native--compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one filename or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+LOAD can also be the symbol `late'. This is used internally if
+the byte code has already been loaded when this function is
+called. It means that we request the special kind of load
+necessary in that situation, called \"late\" loading.
+
+During a \"late\" load, instead of executing all top-level forms
+of the original files, only function definitions are
+loaded (paying attention to have these effective only if the
+bytecode definition was not changed in the meantime)."
+ (comp-ensure-native-compiler)
+ (unless (member load '(nil t late))
+ (error "LOAD must be nil, t or 'late"))
+ (unless (listp files)
+ (setf files (list files)))
+ (let (file-list)
+ (dolist (path files)
+ (cond ((file-directory-p path)
+ (dolist (file (if recursively
+ (directory-files-recursively
+ path comp-valid-source-re)
+ (directory-files path t comp-valid-source-re)))
+ (push file file-list)))
+ ((file-exists-p path) (push path file-list))
+ (t (signal 'native-compiler-error
+ (list "Path not a file nor directory" path)))))
+ (dolist (file file-list)
+ (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=)))
+ ;; Most likely the byte-compiler has requested a deferred
+ ;; compilation, so update `comp-files-queue' to reflect that.
+ (unless (or (null load)
+ (eq load (cdr entry)))
+ (cl-substitute (cons file load) (car entry) comp-files-queue
+ :key #'car :test #'string=))
+
+ (unless (native-compile-async-skip-p file load selector)
+ (let* ((out-filename (comp-el-to-eln-filename file))
+ (out-dir (file-name-directory out-filename)))
+ (unless (file-exists-p out-dir)
+ (make-directory out-dir t))
+ (if (file-writable-p out-filename)
+ (setf comp-files-queue
+ (append comp-files-queue `((,file . ,load))))
+ (display-warning 'comp
+ (format "No write access for %s skipping."
+ out-filename)))))))
+ (when (zerop (comp-async-runnings))
+ (comp-run-async-workers))))
+
+
+;;; Compiler entry points.
+
+;;;###autoload
+(defun comp-lookup-eln (filename)
+ "Given a Lisp source FILENAME return the corresponding .eln file if found.
+Search happens in `native-comp-eln-load-path'."
+ (cl-loop
+ with eln-filename = (comp-el-to-eln-rel-filename filename)
+ for dir in native-comp-eln-load-path
+ for f = (expand-file-name eln-filename
+ (expand-file-name comp-native-version-dir
+ (expand-file-name
+ dir
+ invocation-directory)))
+ when (file-exists-p f)
+ do (cl-return f)))
+
+;;;###autoload
+(defun native-compile (function-or-file &optional output)
+ "Compile FUNCTION-OR-FILE into native code.
+This is the synchronous entry-point for the Emacs Lisp native
+compiler.
+FUNCTION-OR-FILE is a function symbol, a form, or the filename of
+an Emacs Lisp source file.
+If OUTPUT is non-nil, use it as the filename for the compiled
+object.
+If FUNCTION-OR-FILE is a filename, return the filename of the
+compiled object. If FUNCTION-OR-FILE is a function symbol or a
+form, return the compiled function."
+ (comp--native-compile function-or-file nil output))
+
+;;;###autoload
+(defun batch-native-compile ()
+ "Perform native compilation on remaining command-line arguments.
+Use this from the command line, with ‘-batch’;
+it won’t work in an interactive Emacs.
+Native compilation equivalent to `batch-byte-compile'."
+ (comp-ensure-native-compiler)
+ (cl-loop for file in command-line-args-left
+ if (or (null byte+native-compile)
+ (cl-notany (lambda (re) (string-match re file))
+ native-comp-bootstrap-deny-list))
+ do (comp--native-compile file)
+ else
+ do (byte-compile-file file)))
+
+;;;###autoload
+(defun batch-byte+native-compile ()
+ "Like `batch-native-compile', but used for bootstrap.
+Generate .elc files in addition to the .eln files.
+Force the produced .eln to be outputted in the eln system
+directory (the last entry in `native-comp-eln-load-path') unless
+`native-compile-target-directory' is non-nil. If the environment
+variable 'NATIVE_DISABLED' is set, only byte compile."
+ (comp-ensure-native-compiler)
+ (if (equal (getenv "NATIVE_DISABLED") "1")
+ (batch-byte-compile)
+ (cl-assert (length= command-line-args-left 1))
+ (let ((byte+native-compile t)
+ (byte-to-native-output-file nil))
+ (batch-native-compile)
+ (pcase byte-to-native-output-file
+ (`(,tempfile . ,target-file)
+ (rename-file tempfile target-file t))))))
+
+;;;###autoload
+(defun native-compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously."
+ ;; Normalize: we only want to pass t or nil, never e.g. `late'.
+ (let ((load (not (not load))))
+ (native--compile-async files recursively load selector)))
+
+(provide 'comp)
+
+;; LocalWords: limplified limplified limplification limplify Limple LIMPLE libgccjit elc eln
+
+;;; comp.el ends here
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 915fa0c4548..d2e4891acee 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -1,4 +1,4 @@
-;;; copyright.el --- update the copyright notice in current buffer
+;;; copyright.el --- update the copyright notice in current buffer -*- lexical-binding: t -*-
;; Copyright (C) 1991-1995, 1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -37,14 +37,12 @@
(defcustom copyright-limit 2000
"Don't try to update copyright beyond this position unless interactive.
A value of nil means to search whole buffer."
- :group 'copyright
:type '(choice (integer :tag "Limit")
(const :tag "No limit")))
(defcustom copyright-at-end-flag nil
"Non-nil means to search backwards from the end of the buffer for copyright.
This is useful for ChangeLogs."
- :group 'copyright
:type 'boolean
:version "23.1")
;;;###autoload(put 'copyright-at-end-flag 'safe-local-variable 'booleanp)
@@ -53,10 +51,9 @@ This is useful for ChangeLogs."
"\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\
\\|[Cc]opyright\\s *:?\\s *©\\)\
\\s *[^0-9\n]*\\s *\
-\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)"
+\\([1-9]\\([-0-9, ';/*%#\n\t–]\\|\\s<\\|\\s>\\)*[0-9]+\\)"
"What your copyright notice looks like.
The second \\( \\) construct must match the years."
- :group 'copyright
:type 'regexp)
(defcustom copyright-names-regexp ""
@@ -64,7 +61,6 @@ The second \\( \\) construct must match the years."
Only copyright lines where the name matches this regexp will be updated.
This allows you to avoid adding years to a copyright notice belonging to
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
@@ -73,10 +69,9 @@ someone else or to a group for which you do not work."
;;;###autoload(put 'copyright-names-regexp 'safe-local-variable 'stringp)
(defcustom copyright-years-regexp
- "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)"
+ "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t–]\\|\\s<\\|\\s>\\)*[0-9]+\\)"
"Match additional copyright notice years.
The second \\( \\) construct must match the years."
- :group 'copyright
:type 'regexp)
;; See "Copyright Notices" in maintain.info.
@@ -87,7 +82,6 @@ The second \\( \\) construct must match the years."
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-years' respects this variable."
- :group 'copyright
:type 'boolean
:version "24.1")
@@ -96,7 +90,6 @@ The function `copyright-fix-years' respects this variable."
(defcustom copyright-query 'function
"If non-nil, ask user before changing copyright.
When this is `function', only ask when called non-interactively."
- :group 'copyright
:type '(choice (const :tag "Do not ask")
(const :tag "Ask unless interactive" function)
(other :tag "Ask" t)))
@@ -151,11 +144,16 @@ This function sets the match-data that `copyright-update-year' uses."
(with-demoted-errors "Can't update copyright: %s"
;; (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)))
+ (let ((regexp (concat "\\(" copyright-regexp
+ "\\)\\([ \t]*\n\\)?.*\\(?:"
+ copyright-names-regexp "\\)")))
+ (when (copyright-re-search regexp (copyright-limit) t)
+ ;; We may accidentally have landed in the middle of a
+ ;; copyright line, so re-perform the search without the
+ ;; search. (Otherwise we may be inserting the new year in the
+ ;; middle of the list of years.)
+ (goto-char (match-beginning 0))
+ (copyright-re-search regexp nil t)))))
(defun copyright-find-end ()
"Possibly adjust the search performed by `copyright-find-copyright'.
@@ -204,8 +202,8 @@ skips to the end of all the years."
(point))))
100)
1)
- (or (eq (char-after (+ (point) size -1)) ?-)
- (eq (char-after (+ (point) size -2)) ?-)))
+ (or (memq (char-after (+ (point) size -1)) '(?- ?–))
+ (memq (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.
@@ -263,7 +261,7 @@ interactively."
(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)))
+ (setq-local copyright-update nil)))
;; If a write-file-hook returns non-nil, the file is presumed to be written.
nil))
@@ -294,7 +292,7 @@ independently replaces consecutive years with a range."
(setq year (string-to-number (match-string 0)))
(and (setq sep (char-before))
(/= (char-syntax sep) ?\s)
- (/= sep ?-)
+ (not (memq sep '(?- ?–)))
(insert " "))
(when (< year 100)
(insert (if (>= year 50) "19" "20"))
@@ -304,7 +302,7 @@ independently replaces consecutive years with a range."
;; 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 ?-)
+ (if (memq sep '(?- ?–))
(setq prev-year nil
year nil)
(if (and prev-year (= year (1+ prev-year)))
@@ -313,7 +311,7 @@ independently replaces consecutive years with a range."
(> prev-year first-year))
(goto-char range-end)
(delete-region range-start range-end)
- (insert (format "-%d" prev-year))
+ (insert (format "%c%d" sep prev-year))
(goto-char p))
(setq first-year year
range-start (point)))))
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index 76e1633d4b5..d24ea355a51 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -1,4 +1,4 @@
-;;; crm.el --- read multiple strings with completion
+;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc.
@@ -183,8 +183,7 @@ Return t if the current element is now a valid match; otherwise return nil."
Like `minibuffer-complete-word' but for `completing-read-multiple'."
(interactive)
(crm--completion-command beg end
- (completion-in-region--single-word
- beg end minibuffer-completion-table minibuffer-completion-predicate)))
+ (completion-in-region--single-word beg end)))
(defun crm-complete-and-exit ()
"If all of the minibuffer elements are valid completions then exit.
@@ -270,12 +269,6 @@ with empty strings removed."
(remove-hook 'choose-completion-string-functions
'crm--choose-completion-string)))
-(define-obsolete-function-alias 'crm-minibuffer-complete 'crm-complete "23.1")
-(define-obsolete-function-alias
- 'crm-minibuffer-completion-help 'crm-completion-help "23.1")
-(define-obsolete-function-alias
- 'crm-minibuffer-complete-and-exit 'crm-complete-and-exit "23.1")
-
;; testing and debugging
;; (defun crm-init-test-environ ()
;; "Set up some variables for testing."
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 5b3cbcd5be3..069c7a90ad0 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -29,7 +29,6 @@
(require 'cl-lib)
(require 'backtrace)
-(require 'button)
(defgroup debugger nil
"Debuggers and related commands for Emacs."
@@ -214,7 +213,7 @@ the debugger will not be entered."
last-input-event last-command-event last-nonmenu-event
last-event-frame
overriding-local-map
- load-read-function
+ (load-read-function #'read)
;; If we are inside a minibuffer, allow nesting
;; so that we don't get an error from the `e' command.
(enable-recursive-minibuffers
@@ -322,7 +321,7 @@ the debugger will not be entered."
(make-obsolete 'debugger-insert-backtrace
"use a `backtrace-mode' buffer or `backtrace-to-string'."
- "Emacs 27.1")
+ "27.1")
(defun debugger-insert-backtrace (frames do-xrefs)
"Format and insert the backtrace FRAMES at point.
@@ -670,9 +669,7 @@ Redefining FUNCTION also cancels it."
(when (special-form-p fn)
(setq fn nil))
(setq val (completing-read
- (if fn
- (format "Debug on entry to function (default %s): " fn)
- "Debug on entry to function: ")
+ (format-prompt "Debug on entry to function" fn)
obarray
#'(lambda (symbol)
(and (fboundp symbol)
@@ -775,8 +772,7 @@ another symbol also cancels it."
(let* ((var-at-point (variable-at-point))
(var (and (symbolp var-at-point) var-at-point))
(val (completing-read
- (concat "Debug when setting variable"
- (if var (format " (default %s): " var) ": "))
+ (format-prompt "Debug when setting variable" var)
obarray #'boundp
t nil nil (and var (symbol-name var)))))
(list (if (equal val "") var (intern val)))))
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 0a799923c32..43d6dfd3c81 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -1,4 +1,4 @@
-;;; derived.el --- allow inheritance of major modes
+;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*-
;; (formerly mode-clone.el)
;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation,
@@ -141,6 +141,9 @@ KEYWORD-ARGS:
:after-hook FORM
A single lisp form which is evaluated after the mode
hooks have been run. It should not be quoted.
+ :interactive BOOLEAN
+ Whether the derived mode should be `interactive' or not.
+ The default is t.
BODY: forms to execute just before running the
hooks for the new mode. Do not use `interactive' here.
@@ -194,6 +197,7 @@ See Info node `(elisp)Derived Modes' for more details.
(declare-syntax t)
(hook (derived-mode-hook-name child))
(group nil)
+ (interactive t)
(after-hook nil))
;; Process the keyword args.
@@ -203,6 +207,7 @@ See Info node `(elisp)Derived Modes' for more details.
(:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
(:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
(:after-hook (setq after-hook (pop body)))
+ (:interactive (setq interactive (pop body)))
(_ (pop body))))
(setq docstring (derived-mode-make-docstring
@@ -246,7 +251,7 @@ No problems result if this variable is not bound.
(defun ,child ()
,docstring
- (interactive)
+ ,(and interactive '(interactive))
; Run the parent.
(delay-mode-hooks
@@ -306,11 +311,13 @@ No problems result if this variable is not bound.
;; Use a default docstring.
(setq docstring
(if (null parent)
- ;; FIXME filling.
- (format "Major-mode.\nUses keymap `%s'%s%s." map
- (if abbrev (format "%s abbrev table `%s'"
- (if syntax "," " and") abbrev) "")
- (if syntax (format " and syntax-table `%s'" syntax) ""))
+ (concat
+ "Major-mode.\n"
+ (internal--format-docstring-line
+ "Uses keymap `%s'%s%s." map
+ (if abbrev (format "%s abbrev table `%s'"
+ (if syntax "," " and") abbrev) "")
+ (if syntax (format " and syntax-table `%s'" syntax) "")))
(format "Major mode derived from `%s' by `define-derived-mode'.
It inherits all of the parent's attributes, but has its own keymap%s:
@@ -336,20 +343,22 @@ which more-or-less shadow%s %s's corresponding table%s."
(unless (string-match (regexp-quote (symbol-name hook)) docstring)
;; Make sure the docstring mentions the mode's hook.
(setq docstring
- (concat docstring
- (if (null parent)
- "\n\nThis mode "
- (concat
- "\n\nIn addition to any hooks its parent mode "
- (if (string-match (format "[`‘]%s['’]"
- (regexp-quote
- (symbol-name parent)))
- docstring)
- nil
- (format "`%s' " parent))
- "might have run,\nthis mode "))
- (format "runs the hook `%s'" hook)
- ", as the final or penultimate step\nduring initialization.")))
+ (concat docstring "\n\n"
+ (internal--format-docstring-line
+ "%s%s%s"
+ (if (null parent)
+ "This mode "
+ (concat
+ "In addition to any hooks its parent mode "
+ (if (string-match (format "[`‘]%s['’]"
+ (regexp-quote
+ (symbol-name parent)))
+ docstring)
+ nil
+ (format "`%s' " parent))
+ "might have run, this mode "))
+ (format "runs the hook `%s'" hook)
+ ", as the final or penultimate step during initialization."))))
(unless (string-match "\\\\[{[]" docstring)
;; And don't forget to put the mode's keymap.
@@ -364,6 +373,7 @@ which more-or-less shadow%s %s's corresponding table%s."
(defsubst derived-mode-setup-function-name (mode)
"Construct a setup-function name based on a MODE name."
+ (declare (obsolete nil "28.1"))
(intern (concat (symbol-name mode) "-setup")))
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index d91900351db..6ac76f1c19d 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -43,6 +43,8 @@
;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
(require 'byte-compile "bytecomp")
+(declare-function comp-c-func-name "comp.el")
+
(defvar disassemble-column-1-indent 8 "*")
(defvar disassemble-column-2-indent 10 "*")
@@ -57,10 +59,9 @@ If OBJECT is not already compiled, we compile it, but do not
redefine OBJECT if it is a symbol."
(interactive
(let* ((fn (function-called-at-point))
- (prompt (if fn (format "Disassemble function (default %s): " fn)
- "Disassemble function: "))
(def (and fn (symbol-name fn))))
- (list (intern (completing-read prompt obarray 'fboundp t nil nil def))
+ (list (intern (completing-read (format-prompt "Disassemble function" fn)
+ obarray 'fboundp t nil nil def))
nil 0 t)))
(if (and (consp object) (not (functionp object)))
(setq object `(lambda () ,object)))
@@ -74,8 +75,9 @@ redefine OBJECT if it is a symbol."
(disassemble-internal object indent nil)))
nil)
-
-(defun disassemble-internal (obj indent interactive-p)
+(declare-function native-comp-unit-file "data.c")
+(declare-function subr-native-comp-unit "data.c")
+(cl-defun disassemble-internal (obj indent interactive-p)
(let ((macro 'nil)
(name (when (symbolp obj)
(prog1 obj
@@ -83,7 +85,27 @@ redefine OBJECT if it is a symbol."
args)
(setq obj (autoload-do-load obj name))
(if (subrp obj)
- (error "Can't disassemble #<subr %s>" name))
+ (if (and (fboundp 'subr-native-elisp-p)
+ (subr-native-elisp-p obj))
+ (progn
+ (require 'comp)
+ (call-process "objdump" nil (current-buffer) t "-S"
+ (native-comp-unit-file (subr-native-comp-unit obj)))
+ (goto-char (point-min))
+ (re-search-forward (concat "^.*"
+ (regexp-quote
+ (concat "<"
+ (comp-c-func-name
+ (subr-name obj) "F" t)
+ ">:"))))
+ (beginning-of-line)
+ (delete-region (point-min) (point))
+ (when (re-search-forward "^.*<.*>:" nil t 2)
+ (delete-region (match-beginning 0) (point-max)))
+ (asm-mode)
+ (setq buffer-read-only t)
+ (cl-return-from disassemble-internal))
+ (error "Can't disassemble #<subr %s>" name)))
(if (eq (car-safe obj) 'macro) ;Handle macros.
(setq macro t
obj (cdr obj)))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 7b8affd132e..3a00fdb454d 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -1,4 +1,4 @@
-;;; easy-mmode.el --- easy definition for major and minor modes
+;;; easy-mmode.el --- easy definition for major and minor modes -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc.
@@ -84,12 +84,22 @@ replacing its case-insensitive matches with the literal string in LIGHTER."
(defconst easy-mmode--arg-docstring
"
-If called interactively, enable %s if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp,
-also enable the mode if ARG is omitted or nil, and toggle it
-if ARG is `toggle'; disable the mode otherwise.")
+This is a minor mode. If called interactively, toggle the `%s'
+mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
-(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym)
+If called from Lisp, toggle the mode if ARG is `toggle'.
+Enable the mode if ARG is nil, omitted, or is a positive number.
+Disable the mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `%S'.
+
+The mode's hook is called both when the mode is enabled and when
+it is disabled.")
+
+(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym
+ getter)
(let ((doc (or doc (format "Toggle %s on or off.
\\{%s}" mode-pretty-name keymap-sym))))
@@ -98,7 +108,8 @@ if ARG is `toggle'; disable the mode otherwise.")
(let* ((fill-prefix nil)
(docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column))
(fill-column (if (integerp docs-fc) docs-fc 65))
- (argdoc (format easy-mmode--arg-docstring mode-pretty-name))
+ (argdoc (format easy-mmode--arg-docstring mode-pretty-name
+ getter))
(filled (if (fboundp 'fill-region)
(with-temp-buffer
(insert argdoc)
@@ -110,9 +121,9 @@ if ARG is `toggle'; disable the mode otherwise.")
doc nil nil 1)))))
;;;###autoload
-(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
+(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
;;;###autoload
-(defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body)
+(defmacro define-minor-mode (mode doc &rest body)
"Define a new minor mode MODE.
This defines the toggle command MODE and (by default) a control variable
MODE (you can override this with the :variable keyword, see below).
@@ -133,42 +144,35 @@ documenting what its argument does. If the word \"ARG\" does not
appear in DOC, a paragraph is added to DOC explaining
usage of the mode argument.
-Optional INIT-VALUE is the initial value of the mode's variable.
- Note that the minor mode function won't be called by setting
- this option, so the value *reflects* the minor mode's natural
- initial state, rather than *setting* it.
- In the vast majority of cases it should be nil.
-Optional LIGHTER is displayed in the mode line when the mode is on.
-Optional KEYMAP is the default keymap bound to the mode keymap.
- If non-nil, it should be a variable name (whose value is a keymap),
- or an expression that returns either a keymap or a list of
- (KEY . BINDING) pairs where KEY and BINDING are suitable for
- `define-key'. If you supply a KEYMAP argument that is not a
- symbol, this macro defines the variable MODE-map and gives it
- the value that KEYMAP specifies.
-
BODY contains code to execute each time the mode is enabled or disabled.
It is executed after toggling the mode, and before running MODE-hook.
Before the actual body code, you can write keyword arguments, i.e.
alternating keywords and values. If you provide BODY, then you must
- provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide
- at least one keyword argument, or both; otherwise, BODY would be
- misinterpreted as the first omitted argument. The following special
- keywords are supported (other keywords are passed to `defcustom' if
- the minor mode is global):
-
-:group GROUP Custom group name to use in all generated `defcustom' forms.
- Defaults to MODE without the possible trailing \"-mode\".
- Don't use this default group name unless you have written a
- `defgroup' to define that group properly.
+ provide at least one keyword argument (e.g. `:lighter nil`).
+ The following special keywords are supported (other keywords are passed
+ to `defcustom' if the minor mode is global):
+
:global GLOBAL If non-nil specifies that the minor mode is not meant to be
buffer-local, so don't make the variable MODE buffer-local.
By default, the mode is buffer-local.
-:init-value VAL Same as the INIT-VALUE argument.
+:init-value VAL the initial value of the mode's variable.
+ Note that the minor mode function won't be called by setting
+ this option, so the value *reflects* the minor mode's natural
+ initial state, rather than *setting* it.
+ In the vast majority of cases it should be nil.
Not used if you also specify :variable.
-:lighter SPEC Same as the LIGHTER argument.
-:keymap MAP Same as the KEYMAP argument.
-:require SYM Same as in `defcustom'.
+:lighter SPEC Text displayed in the mode line when the mode is on.
+:keymap MAP Keymap bound to the mode keymap. Defaults to `MODE-map'.
+ If non-nil, it should be a variable name (whose value is
+ a keymap), or an expression that returns either a keymap or
+ a list of (KEY . BINDING) pairs where KEY and BINDING are
+ suitable for `define-key'. If you supply a KEYMAP argument
+ that is not a symbol, this macro defines the variable MODE-map
+ and gives it the value that KEYMAP specifies.
+:interactive VAL Whether this mode should be a command or not. The default
+ is to make it one; use nil to avoid that. If VAL is a list,
+ it's interpreted as a list of major modes this minor mode
+ is useful in.
:variable PLACE The location to use instead of the variable MODE to store
the state of the mode. This can be simply a different
named variable, or a generalized variable.
@@ -178,14 +182,19 @@ BODY contains code to execute each time the mode is enabled or disabled.
sets it. If you specify a :variable, this function does
not define a MODE variable (nor any of the terms used
in :variable).
-
:after-hook A single lisp form which is evaluated after the mode hooks
have been run. It should not be quoted.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
:lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version \"27.5\"
- ...BODY CODE...)"
+ ...BODY CODE...)
+
+For backward compatibility with the Emacs<21 calling convention,
+the keywords can also be preceded by the obsolete triplet
+INIT-VALUE LIGHTER KEYMAP.
+
+\(fn MODE DOC [KEYWORD VAL ... &rest BODY])"
(declare (doc-string 2)
(debug (&define name string-or-null-p
[&optional [&not keywordp] sexp
@@ -194,23 +203,15 @@ For example, you could write
[&rest [keywordp sexp]]
def-body)))
- ;; Allow skipping the first three args.
- (cond
- ((keywordp init-value)
- (setq body (if keymap `(,init-value ,lighter ,keymap ,@body)
- `(,init-value ,lighter))
- init-value nil lighter nil keymap nil))
- ((keywordp lighter)
- (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil))
- ((keywordp keymap) (push keymap body) (setq keymap nil)))
-
(let* ((last-message (make-symbol "last-message"))
(mode-name (symbol-name mode))
- (pretty-name (easy-mmode-pretty-mode-name mode lighter))
+ (init-value nil)
+ (keymap nil)
+ (lighter nil)
+ (pretty-name nil)
(globalp nil)
(set nil)
(initialize nil)
- (group nil)
(type nil)
(extra-args nil)
(extra-keywords nil)
@@ -218,13 +219,26 @@ For example, you could write
(setter `(setq ,mode)) ;The beginning of the exp to set the mode var.
(getter mode) ;The exp to get the mode value.
(modefun mode) ;The minor mode function name we're defining.
- (require t)
(after-hook nil)
(hook (intern (concat mode-name "-hook")))
(hook-on (intern (concat mode-name "-on-hook")))
(hook-off (intern (concat mode-name "-off-hook")))
+ (interactive t)
+ (warnwrap (if (or (null body) (keywordp (car body))) #'identity
+ (lambda (exp)
+ (macroexp-warn-and-return
+ "Use keywords rather than deprecated positional arguments to `define-minor-mode'"
+ exp))))
keyw keymap-sym tmp)
+ ;; Allow BODY to start with the old INIT-VALUE LIGHTER KEYMAP triplet.
+ (unless (keywordp (car body))
+ (setq init-value (pop body))
+ (unless (keywordp (car body))
+ (setq lighter (pop body))
+ (unless (keywordp (car body))
+ (setq keymap (pop body)))))
+
;; Check keys.
(while (keywordp (setq keyw (car body)))
(setq body (cdr body))
@@ -238,10 +252,9 @@ For example, you could write
(:extra-args (setq extra-args (pop body)))
(:set (setq set (list :set (pop body))))
(:initialize (setq initialize (list :initialize (pop body))))
- (:group (setq group (nconc group (list :group (pop body)))))
(:type (setq type (list :type (pop body))))
- (:require (setq require (pop body)))
(:keymap (setq keymap (pop body)))
+ (:interactive (setq interactive (pop body)))
(:variable (setq variable (pop body))
(if (not (and (setq tmp (cdr-safe variable))
(or (symbolp tmp)
@@ -255,19 +268,14 @@ For example, you could write
(:after-hook (setq after-hook (pop body)))
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
+ (setq pretty-name (easy-mmode-pretty-mode-name mode lighter))
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
(intern (concat mode-name "-map"))))
(unless set (setq set '(:set #'custom-set-minor-mode)))
(unless initialize
- (setq initialize '(:initialize 'custom-initialize-default)))
-
- (unless group
- ;; We might as well provide a best-guess default group.
- (setq group
- `(:group ',(intern (replace-regexp-in-string
- "-mode\\'" "" mode-name)))))
+ (setq initialize '(:initialize #'custom-initialize-default)))
;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode.
(unless type (setq type '(:type 'boolean)))
@@ -281,9 +289,10 @@ For example, you could write
((not globalp)
`(progn
:autoload-end
- (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)))
+ (defvar-local ,mode ,init-value
+ ,(concat (format "Non-nil if %s is enabled.\n" pretty-name)
+ (internal--format-docstring-line
+ "Use the command `%s' to change this variable." mode)))))
(t
(let ((base-doc-string
(concat "Non-nil if %s is enabled.
@@ -297,42 +306,73 @@ or call the function `%s'."))))
,(format base-doc-string pretty-name mode mode)
,@set
,@initialize
- ,@group
,@type
- ,@(unless (eq require t) `(:require ,require))
,@(nreverse extra-keywords)))))
;; The actual function.
- (defun ,modefun (&optional arg ,@extra-args)
- ,(easy-mmode--mode-docstring doc pretty-name keymap-sym)
- ;; Use `toggle' rather than (if ,mode 0 1) so that using
- ;; repeat-command still does the toggling correctly.
- (interactive (list (or current-prefix-arg 'toggle)))
- (let ((,last-message (current-message)))
- (,@setter
- (if (eq arg 'toggle)
- (not ,getter)
- ;; 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 ,getter ',hook-on ',hook-off))
- (if (called-interactively-p 'any)
- (progn
- ,(if (and globalp (not variable))
- `(customize-mark-as-set ',mode))
- ;; Avoid overwriting a message shown by the body,
- ;; but do overwrite previous messages.
- (unless (and (current-message)
- (not (equal ,last-message
- (current-message))))
- (let ((local ,(if globalp "" " in current buffer")))
- (message ,(format "%s %%sabled%%s" pretty-name)
- (if ,getter "en" "dis") local)))))
- ,@(when after-hook `(,after-hook)))
- (force-mode-line-update)
- ;; Return the new setting.
- ,getter)
+ ,(funcall
+ warnwrap
+ `(defun ,modefun (&optional arg ,@extra-args)
+ ,(easy-mmode--mode-docstring doc pretty-name keymap-sym
+ getter)
+ ,(when interactive
+ ;; Use `toggle' rather than (if ,mode 0 1) so that using
+ ;; repeat-command still does the toggling correctly.
+ (if (consp interactive)
+ `(interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle))
+ ,@interactive)
+ '(interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle)))))
+ (let ((,last-message (current-message)))
+ (,@setter
+ (cond ((eq arg 'toggle)
+ (not ,getter))
+ ((and (numberp arg)
+ (< arg 1))
+ nil)
+ (t
+ t)))
+ ;; Keep minor modes list up to date.
+ ,@(if globalp
+ ;; When running this byte-compiled code in earlier
+ ;; Emacs versions, these variables may not be defined
+ ;; there. So check defensively, even if they're
+ ;; always defined in Emacs 28 and up.
+ `((when (boundp 'global-minor-modes)
+ (setq global-minor-modes
+ (delq ',modefun global-minor-modes))
+ (when ,getter
+ (push ',modefun global-minor-modes))))
+ ;; Ditto check.
+ `((when (boundp 'local-minor-modes)
+ (setq local-minor-modes
+ (delq ',modefun local-minor-modes))
+ (when ,getter
+ (push ',modefun local-minor-modes)))))
+ ,@body
+ ;; The on/off hooks are here for backward compatibility only.
+ (run-hooks ',hook (if ,getter ',hook-on ',hook-off))
+ (if (called-interactively-p 'any)
+ (progn
+ ,(if (and globalp (not variable))
+ `(customize-mark-as-set ',mode))
+ ;; Avoid overwriting a message shown by the body,
+ ;; but do overwrite previous messages.
+ (unless (and (current-message)
+ (not (equal ,last-message
+ (current-message))))
+ (let ((local ,(if globalp "" " in current buffer")))
+ (message ,(format "%s %%sabled%%s" pretty-name)
+ (if ,getter "en" "dis") local)))))
+ ,@(when after-hook `(,after-hook)))
+ (force-mode-line-update)
+ ;; Return the new setting.
+ ,getter))
;; Autoloading a define-minor-mode autoloads everything
;; up-to-here.
@@ -345,6 +385,9 @@ or call the function `%s'."))))
No problems result if this variable is not bound.
`add-hook' automatically binds it. (This is true for all hook variables.)"
modefun)))
+ ;; Allow using using `M-x customize-variable' on the hook.
+ (put ',hook 'custom-type 'hook)
+ (put ',hook 'standard-value (list nil))
;; Define the minor-mode keymap.
,(unless (symbolp keymap) ;nil is also a symbol.
@@ -371,25 +414,28 @@ No problems result if this variable is not bound.
;;;
;;;###autoload
-(defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode)
+(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode)
;;;###autoload
-(defalias 'define-global-minor-mode 'define-globalized-minor-mode)
+(defalias 'define-global-minor-mode #'define-globalized-minor-mode)
;;;###autoload
(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body)
"Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
TURN-ON is a function that will be called with no args in every buffer
- and that should try to turn MODE on if applicable for that buffer.
-Each of KEY VALUE is a pair of CL-style keyword arguments. As
- the minor mode defined by this function is always global, any
- :global keyword is ignored. Other keywords have the same
- meaning as in `define-minor-mode', which see. In particular,
- :group specifies the custom group. The most useful keywords
- are those that are passed on to the `defcustom'. It normally
- makes no sense to pass the :lighter or :keymap keywords to
- `define-globalized-minor-mode', since these are usually passed
- to the buffer-local version of the minor mode.
+and that should try to turn MODE on if applicable for that buffer.
+
+Each of KEY VALUE is a pair of CL-style keyword arguments. :predicate
+specifies which major modes the globalized minor mode should be switched on
+in. As the minor mode defined by this function is always global, any
+:global keyword is ignored. Other keywords have the same meaning as in
+`define-minor-mode', which see. In particular, :group specifies the custom
+group. The most useful keywords are those that are passed on to the
+`defcustom'. It normally makes no sense to pass the :lighter or :keymap
+keywords to `define-globalized-minor-mode', since these are usually passed
+to the buffer-local version of the minor mode.
+
BODY contains code to execute each time the mode is enabled or disabled.
- It is executed after toggling the mode, and before running GLOBAL-MODE-hook.
+It is executed after toggling the mode, and before running
+GLOBAL-MODE-hook.
If MODE's set-up depends on the major mode in effect when it was
enabled, then disabling and reenabling MODE should make MODE work
@@ -409,6 +455,7 @@ on if the hook has explicitly disabled it.
(pretty-global-name (easy-mmode-pretty-mode-name global-mode))
(group nil)
(extra-keywords nil)
+ (MODE-variable mode)
(MODE-buffers (intern (concat global-mode-name "-buffers")))
(MODE-enable-in-buffers
(intern (concat global-mode-name "-enable-in-buffers")))
@@ -418,7 +465,11 @@ on if the hook has explicitly disabled it.
(minor-MODE-hook (intern (concat mode-name "-hook")))
(MODE-set-explicitly (intern (concat mode-name "-set-explicitly")))
(MODE-major-mode (intern (concat (symbol-name mode) "-major-mode")))
- keyw)
+ (MODE-predicate (intern (concat (replace-regexp-in-string
+ "-mode\\'" "" global-mode-name)
+ "-modes")))
+ (turn-on-function `#',turn-on)
+ keyw predicate)
;; Check keys.
(while (keywordp (setq keyw (car body)))
@@ -426,47 +477,79 @@ on if the hook has explicitly disabled it.
(pcase keyw
(:group (setq group (nconc group (list :group (pop body)))))
(:global (pop body))
+ (:variable (setq MODE-variable (pop body)))
+ (:predicate
+ (setq predicate (list (pop body)))
+ (setq turn-on-function
+ `(lambda ()
+ (require 'easy-mmode)
+ (when (easy-mmode--globalized-predicate-p ,(car predicate))
+ (funcall ,turn-on-function)))))
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
`(progn
(progn
(put ',global-mode 'globalized-minor-mode t)
:autoload-end
- (defvar ,MODE-major-mode nil)
- (make-variable-buffer-local ',MODE-major-mode))
+ (defvar-local ,MODE-major-mode nil))
;; The actual global minor-mode
(define-minor-mode ,global-mode
- ;; Very short lines to avoid too long lines in the generated
- ;; doc string.
- ,(format "Toggle %s in all buffers.
-With prefix ARG, enable %s if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
-
-%s is enabled in all buffers where
-`%s' would do it.
-See `%s' for more information on %s."
- pretty-name pretty-global-name
- pretty-name turn-on mode pretty-name)
- :global t ,@group ,@(nreverse extra-keywords)
+ ,(concat (format "Toggle %s in all buffers.\n" pretty-name)
+ (internal--format-docstring-line
+ "With prefix ARG, enable %s if ARG is positive; otherwise, \
+disable it. If called from Lisp, enable the mode if ARG is omitted or nil.\n\n"
+ pretty-global-name)
+ (internal--format-docstring-line
+ "%s is enabled in all buffers where `%s' would do it.\n\n"
+ pretty-name turn-on)
+ (internal--format-docstring-line
+ "See `%s' for more information on %s."
+ mode pretty-name)
+ (if predicate
+ (concat
+ "\n\n"
+ (internal--format-docstring-line
+ "`%s' is used to control which modes this minor mode is used in."
+ MODE-predicate))
+ ""))
+ :global t ,@group ,@(nreverse extra-keywords)
;; Setup hook to handle future mode changes and new buffers.
(if ,global-mode
(progn
(add-hook 'after-change-major-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 'find-file-hook ',MODE-check-buffers)
- (remove-hook 'change-major-mode-hook ',MODE-cmhh))
+ #',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 'find-file-hook #',MODE-check-buffers)
+ (remove-hook 'change-major-mode-hook #',MODE-cmhh))
;; Go through existing buffers.
(dolist (buf (buffer-list))
(with-current-buffer buf
- (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1)))))
+ (if ,global-mode (funcall ,turn-on-function)
+ (when ,mode (,mode -1)))))
,@body)
+ ,(when predicate
+ `(defcustom ,MODE-predicate ,(car predicate)
+ ,(format "Which major modes `%s' is switched on in.
+This variable can be either t (all major modes), nil (no major modes),
+or a list of modes and (not modes) to switch use this minor mode or
+not. For instance
+
+ (c-mode (not message-mode mail-mode) text-mode)
+
+means \"use this mode in all modes derived from `c-mode', don't use in
+modes derived from `message-mode' or `mail-mode', but do use in other
+modes derived from `text-mode'\". An element with value t means \"use\"
+and nil means \"don't use\". There's an implicit nil at the end of the
+list."
+ mode)
+ :type '(repeat sexp)
+ :group ,group))
+
;; Autoloading define-globalized-minor-mode autoloads everything
;; up-to-here.
:autoload-end
@@ -480,7 +563,7 @@ See `%s' for more information on %s."
;; A function which checks whether MODE has been disabled in the major
;; mode hook which has just been run.
- (add-hook ',minor-MODE-hook ',MODE-set-explicitly)
+ (add-hook ',minor-MODE-hook #',MODE-set-explicitly)
;; List of buffers left to process.
(defvar ,MODE-buffers nil)
@@ -497,25 +580,52 @@ See `%s' for more information on %s."
(with-current-buffer buf
(unless ,MODE-set-explicitly
(unless (eq ,MODE-major-mode major-mode)
- (if ,mode
+ (if ,MODE-variable
(progn
(,mode -1)
- (funcall #',turn-on))
- (funcall #',turn-on))))
+ (funcall ,turn-on-function))
+ (funcall ,turn-on-function))))
(setq ,MODE-major-mode major-mode))))))
(put ',MODE-enable-in-buffers 'definition-name ',global-mode)
(defun ,MODE-check-buffers ()
(,MODE-enable-in-buffers)
- (remove-hook 'post-command-hook ',MODE-check-buffers))
+ (remove-hook 'post-command-hook #',MODE-check-buffers))
(put ',MODE-check-buffers 'definition-name ',global-mode)
;; The function that catches kill-all-local-variables.
(defun ,MODE-cmhh ()
(add-to-list ',MODE-buffers (current-buffer))
- (add-hook 'post-command-hook ',MODE-check-buffers))
+ (add-hook 'post-command-hook #',MODE-check-buffers))
(put ',MODE-cmhh 'definition-name ',global-mode))))
+(defun easy-mmode--globalized-predicate-p (predicate)
+ (cond
+ ((eq predicate t)
+ t)
+ ((eq predicate nil)
+ nil)
+ ((listp predicate)
+ ;; Legacy support for (not a b c).
+ (when (eq (car predicate) 'not)
+ (setq predicate (nconc (mapcar (lambda (e) (list 'not e))
+ (cdr predicate))
+ (list t))))
+ (catch 'found
+ (dolist (elem predicate)
+ (cond
+ ((eq elem t)
+ (throw 'found t))
+ ((eq elem nil)
+ (throw 'found nil))
+ ((and (consp elem)
+ (eq (car elem) 'not))
+ (when (apply #'derived-mode-p (cdr elem))
+ (throw 'found nil)))
+ ((symbolp elem)
+ (when (derived-mode-p elem)
+ (throw 'found t)))))))))
+
;;;
;;; easy-mmode-defmap
;;;
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index b907716f252..f6661541a16 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -23,26 +23,18 @@
;;; Commentary:
+;; The `easy-menu-define' macro provides a convenient way to define
+;; pop-up menus and/or menu bar menus.
+;;
;; This is compatible with easymenu.el by Per Abrahamsen
;; but it is much simpler as it doesn't try to support other Emacs versions.
;; The code was mostly derived from lmenu.el.
;;; Code:
-(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
-in a menu. If the variable is on, then this calculation gives a (maybe
-noticeable) delay when a mode is first entered. If the variable is off, then
-this delay will come when a menu is displayed the first time. If you never use
-menus, turn this variable off, otherwise it is probably better to keep it on.")
-(make-obsolete-variable
- 'easy-menu-precalculate-equivalent-keybindings nil "23.1")
-
(defsubst easy-menu-intern (s)
(if (stringp s) (intern s) s))
-;;;###autoload
(defmacro easy-menu-define (symbol maps doc menu)
"Define a pop-up menu and/or menu bar menu specified by MENU.
If SYMBOL is non-nil, define SYMBOL as a function to pop up the
@@ -150,7 +142,7 @@ solely of dashes is displayed as a menu separator.
Alternatively, a menu item can be a list with the same format as
MENU. This is a submenu."
- (declare (indent defun) (debug (symbolp body)))
+ (declare (indent defun) (debug (symbolp body)) (doc-string 3))
`(progn
,(if symbol `(defvar ,symbol nil ,doc))
(easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
@@ -173,7 +165,6 @@ This is expected to be bound to a mouse event."
""))
(cons menu props)))))
-;;;###autoload
(defun easy-menu-do-define (symbol maps doc menu)
;; We can't do anything that might differ between Emacs dialects in
;; `easy-menu-define' in order to make byte compiled files
@@ -191,12 +182,19 @@ This is expected to be bound to a mouse event."
(funcall
(or (plist-get (get symbol 'menu-prop)
:filter)
- 'identity)
+ #'identity)
(symbol-function symbol)))
- symbol)))))
+ symbol))))
+ ;; These symbols are commands, but not interesting for users
+ ;; to `M-x TAB'.
+ (function-put symbol 'completion-predicate #'ignore))
(dolist (map (if (keymapp maps) (list maps) maps))
(define-key map
- (vector 'menu-bar (easy-menu-intern (car menu)))
+ (vector 'menu-bar (if (symbolp (car menu))
+ (car menu)
+ ;; If a string, then use the downcased
+ ;; version for greater backwards compatibility.
+ (intern (downcase (car menu)))))
(easy-menu-binding keymap (car menu))))))
(defun easy-menu-filter-return (menu &optional name)
@@ -222,7 +220,6 @@ If NAME is provided, it is used for the keymap."
If it holds a list, this is expected to be a list of keys already seen in the
menu we're processing. Else it means we're not processing a menu.")
-;;;###autoload
(defun easy-menu-create-menu (menu-name menu-items)
"Create a menu called MENU-NAME with items described in MENU-ITEMS.
MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items
@@ -478,7 +475,6 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression
(eval `(lambda () (interactive) ,callback) t)))
command))
-;;;###autoload
(defun easy-menu-change (path name items &optional before map)
"Change menu found at PATH as item NAME to contain ITEMS.
PATH is a list of strings for locating the menu that
@@ -498,15 +494,14 @@ To implement dynamic menus, either call this from
`menu-bar-update-hook' or use a menu filter."
(easy-menu-add-item map path (easy-menu-create-menu name items) before))
-;; XEmacs needs the following two functions to add and remove menus.
-;; In Emacs this is done automatically when switching keymaps, so
-;; here easy-menu-remove and easy-menu-add are a noops.
-(defalias 'easy-menu-remove 'ignore
+(defalias 'easy-menu-remove #'ignore
"Remove MENU from the current menu bar.
Contrary to XEmacs, this is a nop on Emacs since menus are automatically
\(de)activated when the corresponding keymap is (de)activated.
\(fn MENU)")
+(make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \
+and can be safely removed." "28.1")
(defalias 'easy-menu-add #'ignore
"Add the menu to the menubar.
@@ -518,12 +513,15 @@ You should call this once the menu and keybindings are set up
completely and menu filter functions can be expected to work.
\(fn MENU &optional MAP)")
+(make-obsolete 'easy-menu-add "this was always a no-op in Emacs \
+and can be safely removed." "28.1")
(defun add-submenu (menu-path submenu &optional before in-menu)
"Add submenu SUBMENU in the menu at MENU-PATH.
If BEFORE is non-nil, add before the item named BEFORE.
If IN-MENU is non-nil, follow MENU-PATH in IN-MENU.
This is a compatibility function; use `easy-menu-add-item'."
+ (declare (obsolete easy-menu-add-item "28.1"))
(easy-menu-add-item (or in-menu (current-global-map))
(cons "menu-bar" menu-path)
submenu before))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 961d21aff9e..2aec8197dc9 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -55,6 +55,7 @@
(require 'backtrace)
(require 'macroexp)
(require 'cl-lib)
+(require 'seq)
(eval-when-compile (require 'pcase))
;;; Options
@@ -100,10 +101,6 @@ variable. You may wish to make it local to each buffer with
`emacs-lisp-mode-hook'."
:type 'boolean)
-;; edebug-all-defs and edebug-all-forms need to be autoloaded
-;; because the byte compiler binds them; as a result, if edebug
-;; is first loaded for a require in a compilation, they will be left unbound.
-
;;;###autoload
(defcustom edebug-all-forms nil
"Non-nil means evaluation of all forms will instrument for Edebug.
@@ -244,19 +241,30 @@ If the result is non-nil, then break. Errors are ignored."
;;; Form spec utilities.
-(defun get-edebug-spec (symbol)
+(defun edebug-get-spec (symbol)
+ "Return the Edebug spec of a given Lisp expression's head SYMBOL.
+The argument is usually a symbol, but it doesn't have to be."
;; Get the spec of symbol resolving all indirection.
(let ((spec nil)
(indirect symbol))
(while
- (progn
- (and (symbolp indirect)
- (setq indirect
- (function-get indirect 'edebug-form-spec 'macro))))
+ (and (symbolp indirect)
+ (setq indirect
+ (function-get indirect 'edebug-form-spec 'macro)))
;; (edebug-trace "indirection: %s" edebug-form-spec)
(setq spec indirect))
spec))
+(define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1")
+
+(defun edebug--get-elem-spec (elem)
+ "Return the specs of the Edebug element ELEM, if any.
+ELEM has to be a symbol."
+ (or (get elem 'edebug-elem-spec)
+ ;; For backward compatibility, we also allow the use of
+ ;; a form's name as a shorthand to refer to its spec.
+ (edebug-get-spec elem)))
+
;;;###autoload
(defun edebug-basic-spec (spec)
"Return t if SPEC uses only extant spec symbols.
@@ -309,9 +317,8 @@ A lambda list keyword is a symbol that starts with `&'."
(defun edebug-sort-alist (alist function)
;; Return the ALIST sorted with comparison function FUNCTION.
;; This uses 'sort so the sorting is destructive.
- (sort alist (function
- (lambda (e1 e2)
- (funcall function (car e1) (car e2))))))
+ (sort alist (lambda (e1 e2)
+ (funcall function (car e1) (car e2)))))
;; Not used.
'(defmacro edebug-save-restriction (&rest body)
@@ -342,7 +349,7 @@ Return the result of the last expression in BODY."
;; FIXME: We should probably just be using `pop-to-buffer'.
(setq window
(cond
- ((and (edebug-window-live-p window)
+ ((and (window-live-p window)
(eq (window-buffer window) buffer))
window)
((eq (window-buffer) buffer)
@@ -393,7 +400,7 @@ Return the result of the last expression in BODY."
;; Get either a full window configuration or some window information.
(if (listp which-windows)
(mapcar (lambda (window)
- (if (edebug-window-live-p window)
+ (if (window-live-p window)
(list window
(window-buffer window)
(window-point window)
@@ -407,14 +414,13 @@ Return the result of the last expression in BODY."
(if (listp window-info)
(mapcar (lambda (one-window-info)
(if one-window-info
- (apply (function
- (lambda (window buffer point start hscroll)
- (if (edebug-window-live-p window)
- (progn
- (set-window-buffer window buffer)
- (set-window-point window point)
- (set-window-start window start)
- (set-window-hscroll window hscroll)))))
+ (apply (lambda (window buffer point start hscroll)
+ (if (window-live-p window)
+ (progn
+ (set-window-buffer window buffer)
+ (set-window-point window point)
+ (set-window-start window start)
+ (set-window-hscroll window hscroll))))
one-window-info)))
window-info)
(set-window-configuration window-info)))
@@ -447,66 +453,27 @@ the option `edebug-all-forms'."
;; We should somehow arrange to be able to do this
;; without actually replacing the eval-defun command.
-(defun edebug-eval-defun (edebug-it)
- "Evaluate the top-level form containing point, or after point.
-
-If the current defun is actually a call to `defvar', then reset the
-variable using its initial value expression even if the variable
-already has some other value. (Normally `defvar' does not change the
-variable's value if it already has a value.) Treat `defcustom'
-similarly. Reinitialize the face according to `defface' specification.
-
-With a prefix argument, instrument the code for Edebug.
-
-Setting option `edebug-all-defs' to a non-nil value reverses the meaning
+(defun edebug--eval-defun (orig-fun edebug-it)
+ "Setting option `edebug-all-defs' to a non-nil value reverses the meaning
of the prefix argument. Code is then instrumented when this function is
invoked without a prefix argument.
If acting on a `defun' for FUNCTION, and the function was instrumented,
`Edebug: FUNCTION' is printed in the minibuffer. If not instrumented,
-just FUNCTION is printed.
+just FUNCTION is printed."
+ ;; Re-install our advice, in case `debug' re-bound `load-read-function' to
+ ;; its default value.
+ (add-function :around load-read-function #'edebug--read)
+ (let* ((edebug-all-forms (not (eq (not edebug-it) (not edebug-all-defs))))
+ (edebug-all-defs edebug-all-forms))
+ (funcall orig-fun nil)))
-If not acting on a `defun', the result of evaluation is displayed in
-the minibuffer."
+(defun edebug-eval-defun (edebug-it)
+ (declare (obsolete "use eval-defun or edebug--eval-defun instead" "28.1"))
(interactive "P")
- (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs))))
- (edebug-result)
- (form
- (let ((edebug-all-forms edebugging)
- (edebug-all-defs (eq edebug-all-defs (not edebug-it))))
- (edebug-read-top-level-form))))
- ;; This should be consistent with `eval-defun-1', but not the
- ;; same, since that gets a macroexpanded form.
- (cond ((and (eq (car form) 'defvar)
- (cdr-safe (cdr-safe form)))
- ;; Force variable to be bound.
- (makunbound (nth 1 form)))
- ((and (eq (car form) 'defcustom)
- (default-boundp (nth 1 form)))
- ;; Force variable to be bound.
- ;; 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
- (assq-delete-all (nth 1 form) face-new-frame-defaults))
- (put (nth 1 form) 'face-defface-spec nil)
- (put (nth 1 form) 'face-documentation (nth 3 form))
- ;; See comments in `eval-defun-1' for purpose of code below
- (setq form (prog1 `(prog1 ,form
- (put ',(nth 1 form) 'saved-face
- ',(get (nth 1 form) 'saved-face))
- (put ',(nth 1 form) 'customized-face
- ,(nth 2 form)))
- (put (nth 1 form) 'saved-face nil)))))
- (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding))
- (if (not edebugging)
- (prog1
- (prin1 edebug-result)
- (let ((str (eval-expression-print-format edebug-result)))
- (if str (princ str))))
- edebug-result)))
-
+ (if (advice-member-p #'edebug--eval-defun 'eval-defun)
+ (eval-defun edebug-it)
+ (edebug--eval-defun #'eval-defun edebug-it)))
;;;###autoload
(defalias 'edebug-defun 'edebug-eval-top-level-form)
@@ -555,7 +522,7 @@ already is one.)"
;; Compatibility with old versions.
-(defalias 'edebug-all-defuns 'edebug-all-defs)
+(define-obsolete-function-alias 'edebug-all-defuns #'edebug-all-defs "28.1")
;;;###autoload
(defun edebug-all-defs ()
@@ -578,12 +545,12 @@ already is one.)"
(defun edebug-install-read-eval-functions ()
(interactive)
(add-function :around load-read-function #'edebug--read)
- (advice-add 'eval-defun :override #'edebug-eval-defun))
+ (advice-add 'eval-defun :around #'edebug--eval-defun))
(defun edebug-uninstall-read-eval-functions ()
(interactive)
(remove-function load-read-function #'edebug--read)
- (advice-remove 'eval-defun #'edebug-eval-defun))
+ (advice-remove 'eval-defun #'edebug--eval-defun))
;;; Edebug internal data
@@ -594,7 +561,7 @@ already is one.)"
"A list of entries associating symbols with buffer regions.
Each entry is an `edebug--form-data' struct with fields:
SYMBOL, BEGIN-MARKER, and END-MARKER. The markers
-are at the beginning and end of an entry level form and SYMBOL is
+are at the beginning and end of an instrumented form and SYMBOL is
a symbol that holds all edebug related information for the form on its
property list.
@@ -741,6 +708,21 @@ Maybe clear the markers and delete the symbol's edebug property?"
;;; Offsets for reader
+(defun edebug-get-edebug-or-ghost (name)
+ "Get NAME's value of property `edebug' or property `ghost-edebug'.
+
+The idea is that should function NAME be recompiled whilst
+debugging is in progress, property `edebug' will get set to a
+marker. The needed data will then come from property
+`ghost-edebug'."
+ (let ((e (get name 'edebug)))
+ (if (consp e)
+ e
+ (let ((g (get name 'ghost-edebug)))
+ (if (consp g)
+ g
+ e)))))
+
;; Define a structure to represent offset positions of expressions.
;; Each offset structure looks like: (before . after) for constituents,
;; or for structures that have elements: (before <subexpressions> . after)
@@ -948,6 +930,18 @@ circular objects. Let `read' read everything else."
;;; Cursors for traversal of list and vector elements with offsets.
+;; Edebug's instrumentation is based on parsing the sexps, which come with
+;; auxiliary position information. Instead of keeping the position
+;; information together with the sexps, it is kept in a "parallel
+;; tree" of offsets.
+;;
+;; An "edebug cursor" is a pair of a *list of sexps* (called the
+;; "expressions") together with a matching list of offsets.
+;; When we're parsing the content of a list, the
+;; `edebug-cursor-expressions' is simply the list but when parsing
+;; a vector, the `edebug-cursor-expressions' is a list formed of the
+;; elements of the vector.
+
(defvar edebug-dotted-spec nil
"Set to t when matching after the dot in a dotted spec list.")
@@ -1002,8 +996,8 @@ circular objects. Let `read' read everything else."
;; The following test should always fail.
(if (edebug-empty-cursor cursor)
(edebug-no-match cursor "Not enough arguments."))
- (setcar cursor (cdr (car cursor)))
- (setcdr cursor (cdr (cdr cursor)))
+ (cl-callf cdr (car cursor))
+ (cl-callf cdr (cdr cursor))
cursor)
@@ -1054,8 +1048,6 @@ circular objects. Let `read' read everything else."
;; This data is shared by all embedded definitions.
(defvar edebug-top-window-data)
-(defvar edebug-&optional)
-(defvar edebug-&rest)
(defvar edebug-gate nil) ;; whether no-match forces an error.
(defvar edebug-def-name nil) ; name of definition, used by interactive-form
@@ -1106,8 +1098,6 @@ purpose by adding an entry to this alist, and setting
edebug-top-window-data
edebug-def-name;; make sure it is locally nil
;; I don't like these here!!
- edebug-&optional
- edebug-&rest
edebug-gate
edebug-best-error
edebug-error-point
@@ -1140,7 +1130,7 @@ purpose by adding an entry to this alist, and setting
(eq 'symbol (progn (forward-char 1) (edebug-next-token-class))))
;; Find out if this is a defining form from first symbol
(setq def-kind (read (current-buffer))
- spec (and (symbolp def-kind) (get-edebug-spec def-kind))
+ spec (and (symbolp def-kind) (edebug-get-spec def-kind))
defining-form-p (and (listp spec)
(eq '&define (car spec)))
;; This is incorrect in general!! But OK most of the time.
@@ -1151,6 +1141,9 @@ purpose by adding an entry to this alist, and setting
;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms)
(let ((result
(cond
+ ;; IIUC, `&define' is treated specially here so as to avoid
+ ;; entering Edebug during the actual function's definition:
+ ;; we only want to enter Edebug later when the thing is called.
(defining-form-p
(if (or edebug-all-defs edebug-all-forms)
;; If it is a defining form and we are edebugging defs,
@@ -1168,6 +1161,12 @@ purpose by adding an entry to this alist, and setting
;; Not edebugging this form, so reset the symbol's edebug
;; property to be just a marker at the definition's source code.
;; This only works for defs with simple names.
+
+ ;; Preserve the `edebug' property in case there's
+ ;; debugging still under way.
+ (let ((ghost (get def-name 'edebug)))
+ (if (consp ghost)
+ (put def-name 'ghost-edebug ghost)))
(put def-name 'edebug (point-marker))
;; Also nil out dependent defs.
'(mapcar (function
@@ -1192,26 +1191,12 @@ purpose by adding an entry to this alist, and setting
(funcall edebug-after-instrumentation-function result))))
(defvar edebug-def-args) ; args of defining form.
-(defvar edebug-def-interactive) ; is it an emacs interactive function?
(defvar edebug-inside-func) ;; whether code is inside function context.
;; Currently def-form sets this to nil; def-body sets it to t.
-(defvar edebug--cl-macrolet-defs) ;; Fully defined below.
-
-(defun edebug-interactive-p-name ()
- ;; Return a unique symbol for the variable used to store the
- ;; status of interactive-p for this function.
- (intern (format "edebug-%s-interactive-p" edebug-def-name)))
-
-
-(defun edebug-wrap-def-body (forms)
- "Wrap the FORMS of a definition body."
- (if edebug-def-interactive
- `(let ((,(edebug-interactive-p-name)
- (interactive-p)))
- ,(edebug-make-enter-wrapper forms))
- (edebug-make-enter-wrapper forms)))
+(defvar edebug-lexical-macro-ctx nil
+ "Alist mapping lexically scoped macro names to their debug spec.")
(defun edebug-make-enter-wrapper (forms)
;; Generate the enter wrapper for some forms of a definition.
@@ -1219,6 +1204,13 @@ purpose by adding an entry to this alist, and setting
;; since it wraps the list of forms with a call to `edebug-enter'.
;; Uses the dynamically bound vars edebug-def-name and edebug-def-args.
;; Do this after parsing since that may find a name.
+ (when (string-match-p (rx bos "edebug-anon" (+ digit) eos)
+ (symbol-name edebug-old-def-name))
+ ;; FIXME: Due to Bug#42701, we reset an anonymous name so that
+ ;; backtracking doesn't generate duplicate definitions. It would
+ ;; be better to not define wrappers in the case of a non-matching
+ ;; specification branch to begin with.
+ (setq edebug-old-def-name nil))
(setq edebug-def-name
(or edebug-def-name edebug-old-def-name (gensym "edebug-anon")))
`(edebug-enter
@@ -1354,7 +1346,6 @@ contains a circular object."
(edebug-old-def-name (edebug--form-data-name form-data-entry))
edebug-def-name
edebug-def-args
- edebug-def-interactive
edebug-inside-func;; whether wrapped code executes inside a function.
)
@@ -1411,6 +1402,8 @@ contains a circular object."
(cons window (window-start window)))))
;; Store the edebug data in symbol's property list.
+ ;; We actually want to remove this property entirely, but can't.
+ (put edebug-def-name 'ghost-edebug nil)
(put edebug-def-name 'edebug
;; A struct or vector would be better here!!
(list edebug-form-begin-marker
@@ -1423,8 +1416,8 @@ contains a circular object."
)))
(defun edebug--restore-breakpoints (name)
- (let ((data (get name 'edebug)))
- (when (listp data)
+ (let ((data (edebug-get-edebug-or-ghost name)))
+ (when (consp data)
(let ((offsets (nth 2 data))
(breakpoints (nth 1 data))
(start (nth 0 data))
@@ -1472,9 +1465,12 @@ contains a circular object."
((consp form)
;; The first offset for a list form is for the list form itself.
(if (eq 'quote (car form))
+ ;; This makes sure we don't instrument 'foo
+ ;; which would cause the debugger to single-step
+ ;; the trivial evaluation of a constant.
form
(let* ((head (car form))
- (spec (and (symbolp head) (get-edebug-spec head)))
+ (spec (and (symbolp head) (edebug-get-spec head)))
(new-cursor (edebug-new-cursor form offset)))
;; Find out if this is a defining form from first symbol.
;; An indirect spec would not work here, yet.
@@ -1514,13 +1510,10 @@ contains a circular object."
(defsubst edebug-list-form-args (head cursor)
;; Process the arguments of a list form given that head of form is a symbol.
;; Helper for edebug-list-form
- (let ((spec (get-edebug-spec head)))
+ (let* ((lex-spec (assq head edebug-lexical-macro-ctx))
+ (spec (if lex-spec (cdr lex-spec)
+ (edebug-get-spec head))))
(cond
- ;; Treat cl-macrolet bindings like macros with no spec.
- ((member head edebug--cl-macrolet-defs)
- (if edebug-eval-macro-args
- (edebug-forms cursor)
- (edebug-sexps cursor)))
(spec
(cond
((consp spec)
@@ -1534,7 +1527,7 @@ contains a circular object."
; but leave it in for compatibility.
))
;; No edebug-form-spec provided.
- ((macrop head)
+ ((or lex-spec (macrop head))
(if edebug-eval-macro-args
(edebug-forms cursor)
(edebug-sexps cursor)))
@@ -1547,10 +1540,7 @@ contains a circular object."
;; The after offset will be left in the cursor after processing the form.
(let ((head (edebug-top-element-required cursor "Expected elements"))
;; Prevent backtracking whenever instrumenting.
- (edebug-gate t)
- ;; A list form is never optional because it matches anything.
- (edebug-&optional nil)
- (edebug-&rest nil))
+ (edebug-gate t))
;; Skip the first offset.
(edebug-set-cursor cursor (edebug-cursor-expressions cursor)
(cdr (edebug-cursor-offsets cursor)))
@@ -1558,11 +1548,6 @@ contains a circular object."
((symbolp head)
(cond
((null head) nil) ; () is valid.
- ((eq head 'interactive-p)
- ;; Special case: replace (interactive-p) with variable
- (setq edebug-def-interactive 'check-it)
- (edebug-move-cursor cursor)
- (edebug-interactive-p-name))
(t
(cons head (edebug-list-form-args
head (edebug-move-cursor cursor))))))
@@ -1600,7 +1585,7 @@ contains a circular object."
(setq edebug-error-point (or edebug-error-point
(edebug-before-offset cursor))
edebug-best-error (or edebug-best-error args))
- (if (and edebug-gate (not edebug-&optional))
+ (if edebug-gate
(progn
(if edebug-error-point
(goto-char edebug-error-point))
@@ -1611,13 +1596,11 @@ contains a circular object."
(defun edebug-match (cursor specs)
;; Top level spec matching function.
;; Used also at each lower level of specs.
- (let (edebug-&optional
- edebug-&rest
- edebug-best-error
+ (let (edebug-best-error
edebug-error-point
(edebug-gate edebug-gate) ;; locally bound to limit effect
)
- (edebug-match-specs cursor specs 'edebug-match-specs)))
+ (edebug-match-specs cursor specs #'edebug-match-specs)))
(defun edebug-match-one-spec (cursor spec)
@@ -1659,10 +1642,10 @@ contains a circular object."
(first-char (and (symbolp spec) (aref (symbol-name spec) 0)))
(match (cond
((eq ?& first-char);; "&" symbols take all following specs.
- (funcall (get-edebug-spec spec) cursor (cdr specs)))
+ (edebug--match-&-spec-op spec cursor (cdr specs)))
((eq ?: first-char);; ":" symbols take one following spec.
(setq rest (cdr (cdr specs)))
- (funcall (get-edebug-spec spec) cursor (car (cdr specs))))
+ (edebug--handle-:-spec-op spec cursor (car (cdr specs))))
(t;; Any other normal spec.
(setq rest (cdr specs))
(edebug-match-one-spec cursor spec)))))
@@ -1693,36 +1676,23 @@ contains a circular object."
;; user may want to define macros or functions with the same names.
;; We could use an internal obarray for these primitive specs.
-(dolist (pair '((&optional . edebug-match-&optional)
- (&rest . edebug-match-&rest)
- (&or . edebug-match-&or)
- (form . edebug-match-form)
+(dolist (pair '((form . edebug-match-form)
(sexp . edebug-match-sexp)
(body . edebug-match-body)
- (&define . edebug-match-&define)
- (name . edebug-match-name)
- (:name . edebug-match-colon-name)
(arg . edebug-match-arg)
(def-body . edebug-match-def-body)
(def-form . edebug-match-def-form)
;; Less frequently used:
;; (function . edebug-match-function)
- (lambda-expr . edebug-match-lambda-expr)
- (cl-generic-method-args . edebug-match-cl-generic-method-args)
- (cl-macrolet-expr . edebug-match-cl-macrolet-expr)
- (cl-macrolet-name . edebug-match-cl-macrolet-name)
- (cl-macrolet-body . edebug-match-cl-macrolet-body)
- (&not . edebug-match-&not)
- (&key . edebug-match-&key)
(place . edebug-match-place)
(gate . edebug-match-gate)
;; (nil . edebug-match-nil) not this one - special case it.
))
- (put (car pair) 'edebug-form-spec (cdr pair)))
+ (put (car pair) 'edebug-elem-spec (cdr pair)))
(defun edebug-match-symbol (cursor symbol)
;; Match a symbol spec.
- (let* ((spec (get-edebug-spec symbol)))
+ (let* ((spec (edebug--get-elem-spec symbol)))
(cond
(spec
(if (consp spec)
@@ -1761,13 +1731,12 @@ contains a circular object."
(defsubst edebug-match-body (cursor) (edebug-forms cursor))
-(defun edebug-match-&optional (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &optional)) cursor specs)
;; Keep matching until one spec fails.
- (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper))
+ (edebug-&optional-wrapper cursor specs #'edebug-&optional-wrapper))
(defun edebug-&optional-wrapper (cursor specs remainder-handler)
(let (result
- (edebug-&optional specs)
(edebug-gate nil)
(this-form (edebug-cursor-expressions cursor))
(this-offset (edebug-cursor-offsets cursor)))
@@ -1782,20 +1751,24 @@ contains a circular object."
nil)))
-(defun edebug-&rest-wrapper (cursor specs remainder-handler)
- (if (null specs) (setq specs edebug-&rest))
- ;; Reuse the &optional handler with this as the remainder handler.
- (edebug-&optional-wrapper cursor specs remainder-handler))
+(cl-defgeneric edebug--match-&-spec-op (op cursor specs)
+ "Handle &foo spec operators.
+&foo spec operators operate on all the subsequent SPECS.")
-(defun edebug-match-&rest (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &rest)) cursor specs)
;; Repeatedly use specs until failure.
- (let ((edebug-&rest specs) ;; remember these
- edebug-best-error
+ (let (edebug-best-error
edebug-error-point)
- (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper)))
+ ;; Reuse the &optional handler with this as the remainder handler.
+ (edebug-&optional-wrapper
+ cursor specs
+ (lambda (c s rh)
+ ;; `s' is the remaining spec to match.
+ ;; When it's nil, start over matching `specs'.
+ (edebug-&optional-wrapper c (or s specs) rh)))))
-(defun edebug-match-&or (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &or)) cursor specs)
;; Keep matching until one spec succeeds, and return its results.
;; If none match, fail.
;; This needs to be optimized since most specs spend time here.
@@ -1819,27 +1792,49 @@ contains a circular object."
(apply #'edebug-no-match cursor "Expected one of" original-specs))
))
-
-(defun edebug-match-&not (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &interpose)) cursor specs)
+ "Compute the specs for `&interpose SPEC FUN ARGS...'.
+Extracts the head of the data by matching it against SPEC,
+and then matches the rest by calling (FUN HEAD PF ARGS...)
+where PF is the parsing function which FUN can call exactly once,
+passing it the specs that it needs to match.
+Note that HEAD will always be a list, since specs are defined to match
+a sequence of elements."
+ (pcase-let*
+ ((`(,spec ,fun . ,args) specs)
+ (exps (edebug-cursor-expressions cursor))
+ (instrumented-head (edebug-match-one-spec cursor spec))
+ (consumed (- (length exps)
+ (length (edebug-cursor-expressions cursor))))
+ (head (seq-subseq exps 0 consumed)))
+ (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
+ (apply fun `(,head
+ ,(lambda (newspecs)
+ ;; FIXME: What'd be the difference if we used
+ ;; `edebug-match-sublist', which is what
+ ;; `edebug-list-form-args' uses for the similar purpose
+ ;; when matching "normal" forms?
+ (append instrumented-head (edebug-match cursor newspecs)))
+ ,@args))))
+
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &not)) cursor specs)
;; If any specs match, then fail
(if (null (catch 'no-match
(let ((edebug-gate nil))
(save-excursion
- (edebug-match-&or cursor specs)))
+ (edebug--match-&-spec-op '&or cursor specs)))
nil))
;; This means something matched, so it is a no match.
(edebug-no-match cursor "Unexpected"))
;; This means nothing matched, so it is OK.
nil) ;; So, return nothing
-
-(def-edebug-spec &key edebug-match-&key)
-
-(defun edebug-match-&key (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &key)) cursor specs)
;; Following specs must look like (<name> <spec>) ...
;; where <name> is the name of a keyword, and spec is its spec.
;; This really doesn't save much over the expanded form and takes time.
- (edebug-match-&rest
+ (edebug--match-&-spec-op
+ '&rest
cursor
(cons '&or
(mapcar (lambda (pair)
@@ -1847,6 +1842,15 @@ contains a circular object."
(car (cdr pair))))
specs))))
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &error)) cursor specs)
+ ;; Signal an error, using the following string in the spec as argument.
+ (let ((error-string (car specs))
+ (edebug-error-point (edebug-before-offset cursor)))
+ (goto-char edebug-error-point)
+ (error "%s"
+ (if (stringp error-string)
+ error-string
+ "String expected after &error in edebug-spec"))))
(defun edebug-match-gate (_cursor)
;; Simply set the gate to prevent backtracking at this level.
@@ -1907,19 +1911,15 @@ contains a circular object."
(defun edebug-match-sublist (cursor specs)
;; Match a sublist of specs.
- (let (edebug-&optional
- ;;edebug-best-error
- ;;edebug-error-point
- )
- (prog1
- ;; match with edebug-match-specs so edebug-best-error is not bound.
- (edebug-match-specs cursor specs 'edebug-match-specs)
- (if (not (edebug-empty-cursor cursor))
- (if edebug-best-error
- (apply #'edebug-no-match cursor edebug-best-error)
- ;; A failed &rest or &optional spec may leave some args.
- (edebug-no-match cursor "Failed matching" specs)
- )))))
+ (prog1
+ ;; match with edebug-match-specs so edebug-best-error is not bound.
+ (edebug-match-specs cursor specs 'edebug-match-specs)
+ (if (not (edebug-empty-cursor cursor))
+ (if edebug-best-error
+ (apply #'edebug-no-match cursor edebug-best-error)
+ ;; A failed &rest or &optional spec may leave some args.
+ (edebug-no-match cursor "Failed matching" specs)
+ ))))
(defun edebug-match-string (cursor spec)
@@ -1942,61 +1942,83 @@ contains a circular object."
(defun edebug-match-function (_cursor)
(error "Use function-form instead of function in edebug spec"))
-(defun edebug-match-&define (cursor specs)
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &define)) cursor specs)
;; Match a defining form.
;; Normally, &define is interpreted specially other places.
;; This should only be called inside of a spec list to match the remainder
;; of the current list. e.g. ("lambda" &define args def-body)
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- ;; Find the last offset in the list.
- (let ((offsets (edebug-cursor-offsets cursor)))
- (while (consp offsets) (setq offsets (cdr offsets)))
- offsets)
- specs))
-
-(defun edebug-match-lambda-expr (cursor)
- ;; The expression must be a function.
- ;; This will match any list form that begins with a symbol
- ;; that has an edebug-form-spec beginning with &define. In
- ;; practice, only lambda expressions should be used.
- ;; I could add a &lambda specification to avoid confusion.
- (let* ((sexp (edebug-top-element-required
- cursor "Expected lambda expression"))
- (offset (edebug-top-offset cursor))
- (head (and (consp sexp) (car sexp)))
- (spec (and (symbolp head) (get-edebug-spec head)))
- (edebug-inside-func nil))
- ;; Find out if this is a defining form from first symbol.
- (if (and (consp spec) (eq '&define (car spec)))
- (prog1
- (list
- (edebug-defining-form
- (edebug-new-cursor sexp offset)
- (car offset);; before the sexp
- (edebug-after-offset cursor)
- (cons (symbol-name head) (cdr spec))))
- (edebug-move-cursor cursor))
- (edebug-no-match cursor "Expected lambda expression")
- )))
-
-
-(defun edebug-match-name (cursor)
- ;; Set the edebug-def-name bound in edebug-defining-form.
- (let ((name (edebug-top-element-required cursor "Expected name")))
- ;; Maybe strings and numbers could be used.
- (if (not (symbolp name))
- (edebug-no-match cursor "Symbol expected for name of definition"))
- (setq edebug-def-name
- (if edebug-def-name
- ;; Construct a new name by appending to previous name.
- (intern (format "%s@%s" edebug-def-name name))
- name))
- (edebug-move-cursor cursor)
- (list name)))
-
-(defun edebug-match-colon-name (_cursor spec)
+ (prog1 (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ ;; Find the last offset in the list.
+ (let ((offsets (edebug-cursor-offsets cursor)))
+ (while (consp offsets) (setq offsets (cdr offsets)))
+ offsets)
+ specs)
+ ;; Stop backtracking here (Bug#41988).
+ (setq edebug-gate t)))
+
+(cl-defmethod edebug--match-&-spec-op ((_ (eql &name)) cursor specs)
+ "Compute the name for `&name SPEC FUN` spec operator.
+
+The full syntax of that operator is:
+ &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS...
+
+Extracts the head of the data by matching it against SPEC,
+and then get the new name to use by calling
+ (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING])
+FUN should return either a string or a symbol.
+FUN can be missing in which case it defaults to concatenating
+the new name to the end of the old with an \"@\" char between the two.
+PRESTRING and POSTSTRING are optional strings that get prepended
+or appended to the actual name."
+ (pcase-let*
+ ((`(,spec ,fun . ,args) specs)
+ (prestrings (when (stringp spec)
+ (prog1 (list spec) (setq spec fun fun (pop args)))))
+ (poststrings (when (stringp fun)
+ (prog1 (list fun) (setq fun (pop args)))))
+ (exps (edebug-cursor-expressions cursor))
+ (instrumented (edebug-match-one-spec cursor spec))
+ (consumed (- (length exps)
+ (length (edebug-cursor-expressions cursor))))
+ (newname (apply (or fun #'edebug--concat-name)
+ `(,@args ,edebug-def-name
+ ,@prestrings
+ ,@(seq-subseq exps 0 consumed)
+ ,@poststrings))))
+ (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps)))
+ (setq edebug-def-name (if (stringp newname) (intern newname) newname))
+ instrumented))
+
+(defun edebug--concat-name (oldname &rest newnames)
+ (let ((newname (if (null (cdr newnames))
+ (car newnames)
+ ;; Put spaces between each name, but not for the
+ ;; leading and trailing strings, if any.
+ (let (beg mid end)
+ (dolist (name newnames)
+ (if (stringp name)
+ (push name (if mid end beg))
+ (when end (setq mid (nconc end mid) end nil))
+ (push name mid)))
+ (apply #'concat `(,@(nreverse beg)
+ ,(mapconcat (lambda (x) (format "%s" x))
+ (nreverse mid) " ")
+ ,@(nreverse end)))))))
+ (if (null oldname)
+ (if (or (stringp newname) (symbolp newname))
+ newname
+ (format "%s" newname))
+ (format "%s@%s" edebug-def-name newname))))
+
+(def-edebug-elem-spec 'name '(&name symbolp))
+
+(cl-defgeneric edebug--handle-:-spec-op (op cursor spec)
+ "Handle :foo spec operators.
+:foo spec operators operate on just the one subsequent SPEC element.")
+
+(cl-defmethod edebug--handle-:-spec-op ((_ (eql :name)) _cursor spec)
;; Set the edebug-def-name to the spec.
(setq edebug-def-name
(if edebug-def-name
@@ -2005,52 +2027,16 @@ contains a circular object."
spec))
nil)
-(defun edebug-match-cl-generic-method-args (cursor)
- (let ((args (edebug-top-element-required cursor "Expected arguments")))
- (if (not (consp args))
- (edebug-no-match cursor "List expected"))
- ;; Append the arguments to edebug-def-name.
+(cl-defmethod edebug--handle-:-spec-op ((_ (eql :unique)) _cursor spec)
+ "Match a `:unique PREFIX' specifier.
+SPEC is the symbol name prefix for `gensym'."
+ (let ((suffix (gensym spec)))
(setq edebug-def-name
- (intern (format "%s %s" edebug-def-name args)))
- (edebug-move-cursor cursor)
- (list args)))
-
-(defvar edebug--cl-macrolet-defs nil
- "List of symbols found within the bindings of enclosing `cl-macrolet' forms.")
-(defvar edebug--current-cl-macrolet-defs nil
- "List of symbols found within the bindings of the current `cl-macrolet' form.")
-
-(defun edebug-match-cl-macrolet-expr (cursor)
- "Match a `cl-macrolet' form at CURSOR."
- (let (edebug--current-cl-macrolet-defs)
- (edebug-match cursor
- '((&rest (&define cl-macrolet-name cl-macro-list
- cl-declarations-or-string
- def-body))
- cl-declarations cl-macrolet-body))))
-
-(defun edebug-match-cl-macrolet-name (cursor)
- "Match the name in a `cl-macrolet' binding at CURSOR.
-Collect the names in `edebug--cl-macrolet-defs' where they
-will be checked by `edebug-list-form-args' and treated as
-macros without a spec."
- (let ((name (edebug-top-element-required cursor "Expected name")))
- (when (not (symbolp name))
- (edebug-no-match cursor "Bad name:" name))
- ;; Change edebug-def-name to avoid conflicts with
- ;; names at global scope.
- (setq edebug-def-name (gensym "edebug-anon"))
- (edebug-move-cursor cursor)
- (push name edebug--current-cl-macrolet-defs)
- (list name)))
-
-(defun edebug-match-cl-macrolet-body (cursor)
- "Match the body of a `cl-macrolet' expression at CURSOR.
-Put the definitions collected in `edebug--current-cl-macrolet-defs'
-into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
- (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs
- edebug--cl-macrolet-defs)))
- (edebug-match-body cursor)))
+ (if edebug-def-name
+ ;; Construct a new name by appending to previous name.
+ (intern (format "%s@%s" edebug-def-name suffix))
+ suffix)))
+ nil)
(defun edebug-match-arg (cursor)
;; set the def-args bound in edebug-defining-form
@@ -2080,149 +2066,135 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
;; This happens to handle bug#20281, tho maybe a better fix would be to
;; improve the `defun' spec.
(when forms
- (list (edebug-wrap-def-body forms)))))
+ (list (edebug-make-enter-wrapper forms)))))
;;;; Edebug Form Specs
;;; ==========================================================
-;;;;* Spec for def-edebug-spec
-;;; Out of date.
-
-(defun edebug-spec-p (object)
- "Return non-nil if OBJECT is a symbol with an edebug-form-spec property."
- (and (symbolp object)
- (get object 'edebug-form-spec)))
-
-(def-edebug-spec def-edebug-spec
- ;; Top level is different from lower levels.
- (&define :name edebug-spec name
- &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec)))
-
-(def-edebug-spec edebug-spec-list
- ;; A list must have something in it, or it is nil, a symbolp
- ((edebug-spec . [&or nil edebug-spec])))
-
-(def-edebug-spec edebug-spec
- (&or
- (vector &rest edebug-spec) ; matches a vector
- ("vector" &rest edebug-spec) ; matches a vector spec
- ("quote" symbolp)
- edebug-spec-list
- stringp
- [edebug-lambda-list-keywordp &rest edebug-spec]
- [keywordp gate edebug-spec]
- edebug-spec-p ;; Including all the special ones e.g. form.
- symbolp;; a predicate
- ))
-
-
;;;* Emacs special forms and some functions.
-;; quote expects only one argument, although it allows any number.
-(def-edebug-spec quote sexp)
+(pcase-dolist
+ (`(,name ,spec)
+
+ '((quote (sexp)) ;quote expects only one arg, tho it allows any number.
+
+ ;; The standard defining forms.
+ (defvar (symbolp &optional form stringp))
+ (defconst defvar)
+
+ ;; Contrary to macros, special forms default to assuming that all args
+ ;; are normal forms, so we don't need to do anything about those
+ ;; special forms:
+ ;;(save-current-buffer t)
+ ;;(save-excursion t)
+ ;;...
+ ;;(progn t)
+
+ ;; `defun' and `defmacro' are not special forms (any more), but it's
+ ;; more convenient to define their Edebug spec here.
+ (defun ( &define name lambda-list lambda-doc
+ [&optional ("declare" def-declarations)]
+ [&optional ("interactive" &optional [&or stringp def-form]
+ &rest symbolp)]
+ def-body))
+
+ (defmacro ( &define name lambda-list lambda-doc
+ [&optional ("declare" def-declarations)]
+ def-body))
+
+ ;; function expects a symbol or a lambda or macro expression
+ ;; A macro is allowed by Emacs.
+ (function (&or symbolp lambda-expr))
+
+ ;; FIXME? The manual uses this form (maybe that's just
+ ;; for illustration purposes?):
+ ;; (let ((&rest &or symbolp (gate symbolp &optional form)) body))
+ (let ((&rest &or (symbolp &optional form) symbolp) body))
+ (let* let)
+
+ (setq (&rest symbolp form))
+ (cond (&rest (&rest form)))
+
+ (condition-case ( symbolp form
+ &rest ([&or symbolp (&rest symbolp)] body)))
+
+ (\` (backquote-form))
+
+ ;; Assume immediate quote in unquotes mean backquote at next
+ ;; higher level.
+ (\, (&or ("quote" edebug-\`) def-form))
+ (\,@ (&define ;; so (,@ form) is never wrapped.
+ &or ("quote" edebug-\`) def-form))
+ ))
+ (put name 'edebug-form-spec spec))
-;; The standard defining forms.
-(def-edebug-spec defconst defvar)
-(def-edebug-spec defvar (symbolp &optional form stringp))
+(defun edebug--match-declare-arg (head pf)
+ (funcall pf (get (car head) 'edebug-declaration-spec)))
-(def-edebug-spec defun
- (&define name lambda-list lambda-doc
- [&optional ("declare" &rest sexp)]
- [&optional ("interactive" interactive)]
- def-body))
-(def-edebug-spec defmacro
- ;; FIXME: Improve `declare' so we can Edebug gv-expander and
- ;; gv-setter declarations.
- (&define name lambda-list lambda-doc
- [&optional ("declare" &rest sexp)] def-body))
+(def-edebug-elem-spec 'def-declarations
+ '(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp))
+
+(def-edebug-elem-spec 'lambda-list
+ '(([&rest arg]
+ [&optional ["&optional" arg &rest arg]]
+ &optional ["&rest" arg]
+ )))
-(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list.
+(def-edebug-elem-spec 'lambda-expr
+ '(("lambda" &define lambda-list lambda-doc
+ [&optional ("interactive" interactive)]
+ def-body)))
-(def-edebug-spec lambda-list
- (([&rest arg]
- [&optional ["&optional" arg &rest arg]]
- &optional ["&rest" arg]
- )))
+(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list.
-(def-edebug-spec lambda-doc
- (&optional [&or stringp
- (&define ":documentation" def-form)]))
+(def-edebug-elem-spec 'lambda-doc
+ '(&optional [&or stringp
+ (&define ":documentation" def-form)]))
-(def-edebug-spec interactive
- (&optional &or stringp def-form))
+(def-edebug-elem-spec 'interactive '(&optional [&or stringp def-form]
+ &rest symbolp))
;; A function-form is for an argument that may be a function or a form.
;; This specially recognizes anonymous functions quoted with quote.
-(def-edebug-spec function-form
+(def-edebug-elem-spec 'function-form ;Deprecated, use `form'!
;; form at the end could also handle "function",
;; but recognize it specially to avoid wrapping function forms.
- (&or ([&or "quote" "function"] &or symbolp lambda-expr) form))
-
-;; function expects a symbol or a lambda or macro expression
-;; A macro is allowed by Emacs.
-(def-edebug-spec function (&or symbolp lambda-expr))
-
-;; A macro expression is a lambda expression with "macro" prepended.
-(def-edebug-spec macro (&define "lambda" lambda-list def-body))
-
-;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro])))
-
-;; Standard functions that take function-forms arguments.
-
-;; FIXME? The manual uses this form (maybe that's just for illustration?):
-;; (def-edebug-spec let
-;; ((&rest &or symbolp (gate symbolp &optional form))
-;; body))
-(def-edebug-spec let
- ((&rest &or (symbolp &optional form) symbolp)
- body))
-
-(def-edebug-spec let* let)
-
-(def-edebug-spec setq (&rest symbolp form))
-
-(def-edebug-spec cond (&rest (&rest form)))
-
-(def-edebug-spec condition-case
- (symbolp
- form
- &rest ([&or symbolp (&rest symbolp)] body)))
-
-
-(def-edebug-spec \` (backquote-form))
+ '(&or ([&or "quote" "function"] &or symbolp lambda-expr) form))
;; Supports quotes inside backquotes,
;; but only at the top level inside unquotes.
-(def-edebug-spec backquote-form
- (&or
- ;; Disallow instrumentation of , and ,@ inside a nested backquote, since
- ;; these are likely to be forms generated by a macro being debugged.
- ("`" nested-backquote-form)
- ([&or "," ",@"] &or ("quote" backquote-form) form)
- ;; The simple version:
- ;; (backquote-form &rest backquote-form)
- ;; doesn't handle (a . ,b). The straightforward fix:
- ;; (backquote-form . [&or nil backquote-form])
- ;; uses up too much stack space.
- ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it.
- (backquote-form [&rest [&not ","] backquote-form]
- . [&or nil backquote-form])
- ;; If you use dotted forms in backquotes, replace the previous line
- ;; with the following. This takes quite a bit more stack space, however.
- ;; (backquote-form . [&or nil backquote-form])
- (vector &rest backquote-form)
- sexp))
-
-(def-edebug-spec nested-backquote-form
- (&or
- ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or
- ;; (\,@ ...) matched on the next line.
- ([&or "," ",@"] backquote-form)
- (nested-backquote-form [&rest [&not "," ",@"] nested-backquote-form]
- . [&or nil nested-backquote-form])
- (vector &rest nested-backquote-form)
- sexp))
+(def-edebug-elem-spec 'backquote-form
+ '(&or
+ ;; Disallow instrumentation of , and ,@ inside a nested backquote, since
+ ;; these are likely to be forms generated by a macro being debugged.
+ ("`" nested-backquote-form)
+ ([&or "," ",@"] &or ("quote" backquote-form) form)
+ ;; The simple version:
+ ;; (backquote-form &rest backquote-form)
+ ;; doesn't handle (a . ,b). The straightforward fix:
+ ;; (backquote-form . [&or nil backquote-form])
+ ;; uses up too much stack space.
+ ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it.
+ (backquote-form [&rest [&not ","] backquote-form]
+ . [&or nil backquote-form])
+ ;; If you use dotted forms in backquotes, replace the previous line
+ ;; with the following. This takes quite a bit more stack space, however.
+ ;; (backquote-form . [&or nil backquote-form])
+ (vector &rest backquote-form)
+ sexp))
+
+(def-edebug-elem-spec 'nested-backquote-form
+ '(&or
+ ("`" &error "Triply nested backquotes (without commas \"between\" them) \
+are too difficult to instrument")
+ ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or
+ ;; (\,@ ...) matched on the next line.
+ ([&or "," ",@"] backquote-form)
+ (nested-backquote-form [&rest [&not "," ",@"] nested-backquote-form]
+ . [&or nil nested-backquote-form])
+ (vector &rest nested-backquote-form)
+ sexp))
;; Special version of backquote that instruments backquoted forms
;; destined to be evaluated, usually as the result of a
@@ -2237,20 +2209,9 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'."
;; ,@ might have some problems.
-(defalias 'edebug-\` '\`) ;; same macro as regular backquote.
-(def-edebug-spec edebug-\` (def-form))
-
-;; Assume immediate quote in unquotes mean backquote at next higher level.
-(def-edebug-spec \, (&or ("quote" edebug-\`) def-form))
-(def-edebug-spec \,@ (&define ;; so (,@ form) is never wrapped.
- &or ("quote" edebug-\`) def-form))
-
-;; New byte compiler.
-
-(def-edebug-spec save-selected-window t)
-(def-edebug-spec save-current-buffer t)
-
-;; Anything else?
+(defmacro edebug-\` (exp)
+ (declare (debug (def-form)))
+ (list '\` exp))
;;; The debugger itself
@@ -2424,11 +2385,10 @@ STATUS should be a list returned by `edebug-var-status'."
(edebug-print-trace-after
(format "%s result: %s" function edebug-result)))))
-(def-edebug-spec edebug-tracing (form body))
-
(defmacro edebug-tracing (msg &rest body)
"Print MSG in *edebug-trace* before and after evaluating BODY.
The result of BODY is also printed."
+ (declare (debug (form body)))
`(let ((edebug-stack-depth (1+ edebug-stack-depth))
edebug-result)
(edebug-print-trace-before ,msg)
@@ -2580,12 +2540,11 @@ See `edebug-behavior-alist' for implementations.")
;; window-start now stored with each function.
-;;(defvar edebug-window-start nil)
+;;(defvar-local edebug-window-start nil)
;; Remember where each buffers' window starts between edebug calls.
;; This is to avoid spurious recentering.
;; Does this still need to be buffer-local??
;;(setq-default edebug-window-start nil)
-;;(make-variable-buffer-local 'edebug-window-start)
;; Dynamically declared unbound vars
@@ -2602,9 +2561,6 @@ See `edebug-behavior-alist' for implementations.")
(defvar edebug-previous-result nil) ;; Last result returned.
-;; Emacs 19 adds an arg to mark and mark-marker.
-(defalias 'edebug-mark-marker 'mark-marker)
-
(defun edebug--display (value offset-index arg-mode)
;; edebug--display-1 is too big, we should split it. This function
;; here was just introduced to avoid making edebug--display-1
@@ -2631,7 +2587,7 @@ See `edebug-behavior-alist' for implementations.")
(edebug-outside-window (selected-window))
(edebug-outside-buffer (current-buffer))
(edebug-outside-point (point))
- (edebug-outside-mark (edebug-mark))
+ (edebug-outside-mark (mark t))
edebug-outside-windows ; Window or screen configuration.
edebug-buffer-points
@@ -2755,6 +2711,7 @@ See `edebug-behavior-alist' for implementations.")
(edebug-stop))
(edebug-overlay-arrow)
+ (edebug--overlay-breakpoints edebug-function)
(unwind-protect
(if (or edebug-stop
@@ -2799,7 +2756,7 @@ See `edebug-behavior-alist' for implementations.")
;; Unrestore edebug-buffer's window-start, if displayed.
(let ((window (car edebug-window-data)))
- (if (and (edebug-window-live-p window)
+ (if (and (window-live-p window)
(eq (window-buffer) edebug-buffer))
(progn
(set-window-start window (cdr edebug-window-data)
@@ -2818,7 +2775,7 @@ See `edebug-behavior-alist' for implementations.")
;; Since we may be in a save-excursion, in case of quit,
;; reselect the outside window only.
;; Only needed if we are not recovering windows??
- (if (edebug-window-live-p edebug-outside-window)
+ (if (window-live-p edebug-outside-window)
(select-window edebug-outside-window))
) ; if edebug-save-windows
@@ -2831,9 +2788,8 @@ See `edebug-behavior-alist' for implementations.")
;; But don't restore point if edebug-buffer is current buffer.
(if (not (eq edebug-buffer edebug-outside-buffer))
(goto-char edebug-outside-point))
- (if (marker-buffer (edebug-mark-marker))
- ;; Does zmacs-regions need to be nil while doing set-marker?
- (set-marker (edebug-mark-marker) edebug-outside-mark))
+ (if (marker-buffer (mark-marker))
+ (set-marker (mark-marker) edebug-outside-mark))
)) ; unwind-protect
;; None of the following is done if quit or signal occurs.
@@ -2844,6 +2800,7 @@ See `edebug-behavior-alist' for implementations.")
(goto-char edebug-buffer-outside-point))
;; ... nothing more.
)
+ (edebug--overlay-breakpoints-remove (point-min) (point-max))
;; Could be an option to keep eval display up.
(if edebug-eval-buffer (kill-buffer edebug-eval-buffer))
(with-timeout-unsuspend edebug-with-timeout-suspend)
@@ -2863,7 +2820,6 @@ See `edebug-behavior-alist' for implementations.")
(defvar edebug-outside-match-data) ; match data outside of edebug
(defvar edebug-backtrace-buffer) ; each recursive edit gets its own
(defvar edebug-inside-windows)
-(defvar edebug-interactive-p)
(defvar edebug-mode-map) ; will be defined fully later.
@@ -2879,7 +2835,6 @@ See `edebug-behavior-alist' for implementations.")
;;(edebug-number-of-recursions (1+ edebug-number-of-recursions))
(edebug-recursion-depth (recursion-depth))
edebug-entered ; bind locally to nil
- (edebug-interactive-p nil) ; again non-interactive
edebug-backtrace-buffer ; each recursive edit gets its own
;; The window configuration may be saved and restored
;; during a recursive-edit
@@ -3089,8 +3044,8 @@ before returning. The default is one second."
(goto-char edebug-outside-point)
(message "Current buffer: %s Point: %s Mark: %s"
(current-buffer) (point)
- (if (marker-buffer (edebug-mark-marker))
- (marker-position (edebug-mark-marker)) "<not set>"))
+ (if (marker-buffer (mark-marker))
+ (marker-position (mark-marker)) "<not set>"))
(sit-for arg)
(edebug-pop-to-buffer edebug-buffer (car edebug-window-data)))))
@@ -3118,7 +3073,7 @@ before returning. The default is one second."
;; Return (function . index) of the nearest edebug stop point.
(let* ((edebug-def-name (edebug-form-data-symbol))
(edebug-data
- (let ((data (get edebug-def-name 'edebug)))
+ (let ((data (edebug-get-edebug-or-ghost edebug-def-name)))
(if (or (null data) (markerp data))
(error "%s is not instrumented for Edebug" edebug-def-name))
data)) ; we could do it automatically, if data is a marker.
@@ -3155,7 +3110,7 @@ before returning. The default is one second."
(if edebug-stop-point
(let* ((edebug-def-name (car edebug-stop-point))
(index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
+ (edebug-data (edebug-get-edebug-or-ghost edebug-def-name))
;; pull out parts of edebug-data
(edebug-def-mark (car edebug-data))
@@ -3196,7 +3151,7 @@ the breakpoint."
(if edebug-stop-point
(let* ((edebug-def-name (car edebug-stop-point))
(index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
+ (edebug-data (edebug-get-edebug-or-ghost edebug-def-name))
;; pull out parts of edebug-data
(edebug-def-mark (car edebug-data))
@@ -3228,7 +3183,45 @@ the breakpoint."
(setcar (cdr edebug-data) edebug-breakpoints)
(goto-char position)
- ))))
+ (edebug--overlay-breakpoints edebug-def-name)))))
+
+(define-fringe-bitmap 'edebug-breakpoint
+ "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
+
+(defun edebug--overlay-breakpoints (function)
+ (let* ((data (edebug-get-edebug-or-ghost function))
+ (start (nth 0 data))
+ (breakpoints (nth 1 data))
+ (offsets (nth 2 data)))
+ ;; First remove all old breakpoint overlays.
+ (edebug--overlay-breakpoints-remove
+ start (+ start (aref offsets (1- (length offsets)))))
+ ;; Then make overlays for the breakpoints (but only when we are in
+ ;; edebug mode).
+ (when edebug-active
+ (dolist (breakpoint breakpoints)
+ (let* ((pos (+ start (aref offsets (car breakpoint))))
+ (overlay (make-overlay pos (1+ pos)))
+ (face (if (nth 4 breakpoint)
+ (progn
+ (overlay-put overlay
+ 'help-echo "Disabled breakpoint")
+ (overlay-put overlay
+ 'face 'edebug-disabled-breakpoint))
+ (overlay-put overlay 'help-echo "Breakpoint")
+ (overlay-put overlay 'face 'edebug-enabled-breakpoint))))
+ (overlay-put overlay 'edebug t)
+ (let ((fringe (make-overlay pos pos)))
+ (overlay-put fringe 'edebug t)
+ (overlay-put fringe 'before-string
+ (propertize
+ "x" 'display
+ `(left-fringe edebug-breakpoint ,face)))))))))
+
+(defun edebug--overlay-breakpoints-remove (start end)
+ (dolist (overlay (overlays-in start end))
+ (when (overlay-get overlay 'edebug)
+ (delete-overlay overlay))))
(defun edebug-set-breakpoint (arg)
"Set the breakpoint of nearest sexp.
@@ -3236,9 +3229,9 @@ With prefix argument, make it a temporary breakpoint."
(interactive "P")
;; If the form hasn't been instrumented yet, do it now.
(when (and (not edebug-active)
- (let ((data (get (edebug--form-data-name
- (edebug-get-form-data-entry (point)))
- 'edebug)))
+ (let ((data (edebug-get-edebug-or-ghost
+ (edebug--form-data-name
+ (edebug-get-form-data-entry (point))))))
(or (null data) (markerp data))))
(edebug-defun))
(edebug-modify-breakpoint t nil arg))
@@ -3252,7 +3245,7 @@ With prefix argument, make it a temporary breakpoint."
"Unset all the breakpoints in the current form."
(interactive)
(let* ((name (edebug-form-data-symbol))
- (breakpoints (nth 1 (get name 'edebug))))
+ (breakpoints (nth 1 (edebug-get-edebug-or-ghost name))))
(unless breakpoints
(user-error "There are no breakpoints in %s" name))
(save-excursion
@@ -3268,12 +3261,13 @@ With prefix argument, make it a temporary breakpoint."
(user-error "No stop point near point"))
(let* ((name (car stop-point))
(index (cdr stop-point))
- (data (get name 'edebug))
+ (data (edebug-get-edebug-or-ghost name))
(breakpoint (assq index (nth 1 data))))
(unless breakpoint
(user-error "No breakpoint near point"))
(setf (nth 4 breakpoint)
- (not (nth 4 breakpoint))))))
+ (not (nth 4 breakpoint)))
+ (edebug--overlay-breakpoints name))))
(defun edebug-set-global-break-condition (expression)
"Set `edebug-global-break-condition' to EXPRESSION."
@@ -3448,7 +3442,7 @@ instrument cannot be found, signal an error."
(goto-char func-marker)
(edebug-eval-top-level-form)
(list func)))
- ((consp func-marker)
+ ((and (consp func-marker) (consp (symbol-function func)))
(message "%s is already instrumented." func)
(list func))
(t
@@ -3504,7 +3498,10 @@ canceled the first time the function is entered."
;; Could store this in the edebug data instead.
(put function 'edebug-on-entry (if flag 'temp t)))
-(defalias 'edebug-cancel-edebug-on-entry #'cancel-edebug-on-entry)
+(define-obsolete-function-alias 'edebug-cancel-edebug-on-entry
+ #'edebug-cancel-on-entry "28.1")
+(define-obsolete-function-alias 'cancel-edebug-on-entry
+ #'edebug-cancel-on-entry "28.1")
(defun edebug--edebug-on-entry-functions ()
(let ((functions nil))
@@ -3516,9 +3513,9 @@ canceled the first time the function is entered."
obarray)
functions))
-(defun cancel-edebug-on-entry (function)
+(defun edebug-cancel-on-entry (function)
"Cause Edebug to not stop when FUNCTION is called.
-The removes the effect of `edebug-on-entry'. If FUNCTION is is
+The removes the effect of `edebug-on-entry'. If FUNCTION is
nil, remove `edebug-on-entry' on all functions."
(interactive
(list (let ((name (completing-read
@@ -3622,8 +3619,8 @@ Return the result of the last expression."
;; for us.
(with-current-buffer edebug-outside-buffer ; of edebug-buffer
(goto-char edebug-outside-point)
- (if (marker-buffer (edebug-mark-marker))
- (set-marker (edebug-mark-marker) edebug-outside-mark))
+ (if (marker-buffer (mark-marker))
+ (set-marker (mark-marker) edebug-outside-mark))
,@body)
;; Back to edebug-buffer. Restore rest of inside context.
@@ -3667,7 +3664,6 @@ Return the result of the last expression."
(prin1-to-string edebug-arg))
(cdr value) ", ")))
-(defvar print-readably) ; defined by lemacs
;; Alternatively, we could change the definition of
;; edebug-safe-prin1-to-string to only use these if defined.
@@ -3675,8 +3671,7 @@ Return the result of the last expression."
(let ((print-escape-newlines t)
(print-length (or edebug-print-length print-length))
(print-level (or edebug-print-level print-level))
- (print-circle (or edebug-print-circle print-circle))
- (print-readably nil)) ; lemacs uses this.
+ (print-circle (or edebug-print-circle print-circle)))
(edebug-prin1-to-string value)))
(defun edebug-compute-previous-result (previous-value)
@@ -3706,9 +3701,10 @@ Print result in minibuffer."
(interactive (list (read--expression "Eval: ")))
(princ
(edebug-outside-excursion
- (setq values (cons (edebug-eval expr) values))
- (concat (edebug-safe-prin1-to-string (car values))
- (eval-expression-print-format (car values))))))
+ (let ((result (edebug-eval expr)))
+ (values--store-value result)
+ (concat (edebug-safe-prin1-to-string result)
+ (eval-expression-print-format result))))))
(defun edebug-eval-last-sexp (&optional no-truncate)
"Evaluate sexp before point in the outside environment.
@@ -3841,10 +3837,14 @@ be installed in `emacs-lisp-mode-map'.")
;; Autoloading these global bindings doesn't make sense because
;; they cannot be used anyway unless Edebug is already loaded and active.
-(defvar global-edebug-prefix "\^XX"
+(define-obsolete-variable-alias 'global-edebug-prefix
+ 'edebug-global-prefix "28.1")
+(defvar edebug-global-prefix "\^XX"
"Prefix key for global edebug commands, available from any buffer.")
-(defvar global-edebug-map
+(define-obsolete-variable-alias 'global-edebug-map
+ 'edebug-global-map "28.1")
+(defvar edebug-global-map
(let ((map (make-sparse-keymap)))
(define-key map " " 'edebug-step-mode)
@@ -3877,9 +3877,9 @@ be installed in `emacs-lisp-mode-map'.")
map)
"Global map of edebug commands, available from any buffer.")
-(when global-edebug-prefix
- (global-unset-key global-edebug-prefix)
- (global-set-key global-edebug-prefix global-edebug-map))
+(when edebug-global-prefix
+ (global-unset-key edebug-global-prefix)
+ (global-set-key edebug-global-prefix edebug-global-map))
(defun edebug-help ()
@@ -3920,7 +3920,6 @@ Options:
`edebug-print-circle'
`edebug-on-error'
`edebug-on-quit'
-`edebug-on-signal'
`edebug-unwrap-results'
`edebug-global-break-condition'"
:lighter " *Debugging*"
@@ -4122,12 +4121,12 @@ This should be a list of `edebug---frame' objects.")
"Stack frames of the current Edebug Backtrace buffer with instrumentation.
This should be a list of `edebug---frame' objects.")
-;; Data structure for backtrace frames with information
-;; from Edebug instrumentation found in the backtrace.
(cl-defstruct
(edebug--frame
(:constructor edebug--make-frame)
(:include backtrace-frame))
+ "Data structure for backtrace frames with information
+from Edebug instrumentation found in the backtrace."
def-name before-index after-index)
(defun edebug-pop-to-backtrace ()
@@ -4142,7 +4141,8 @@ This should be a list of `edebug---frame' objects.")
(pop-to-buffer edebug-backtrace-buffer)
(unless (derived-mode-p 'backtrace-mode)
(backtrace-mode)
- (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source))
+ (add-hook 'backtrace-goto-source-functions
+ #'edebug--backtrace-goto-source nil t))
(setq edebug-instrumented-backtrace-frames
(backtrace-get-frames 'edebug-debugger
:constructor #'edebug--make-frame)
@@ -4223,7 +4223,7 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME."
(let* ((index (backtrace-get-index))
(frame (nth index backtrace-frames)))
(when (edebug--frame-def-name frame)
- (let* ((data (get (edebug--frame-def-name frame) 'edebug))
+ (let* ((data (edebug-get-edebug-or-ghost (edebug--frame-def-name frame)))
(marker (nth 0 data))
(offsets (nth 2 data)))
(pop-to-buffer (marker-buffer marker))
@@ -4307,7 +4307,7 @@ reinstrument it."
(let* ((function (edebug-form-data-symbol))
(counts (get function 'edebug-freq-count))
(coverages (get function 'edebug-coverage))
- (data (get function 'edebug))
+ (data (edebug-get-edebug-or-ghost function))
(def-mark (car data)) ; mark at def start
(edebug-points (nth 2 data))
(i (1- (length edebug-points)))
@@ -4360,7 +4360,6 @@ reinstrument it."
(defun edebug-temp-display-freq-count ()
"Temporarily display the frequency count data for the current definition.
It is removed when you hit any char."
- ;; This seems not to work with Emacs 18.59. It undoes too far.
(interactive)
(let ((inhibit-read-only t))
(undo-boundary)
@@ -4377,10 +4376,6 @@ It is removed when you hit any char."
(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.
-(require 'easymenu)
-
(defconst edebug-mode-menus
'("Edebug"
["Stop" edebug-stop t]
@@ -4447,11 +4442,6 @@ It is removed when you hit any char."
;;; Emacs version specific code
-(defalias 'edebug-window-live-p 'window-live-p)
-
-(defun edebug-mark ()
- (mark t))
-
(defun edebug-set-conditional-breakpoint (arg condition)
"Set a conditional breakpoint at nearest sexp.
The condition is evaluated in the outside context.
@@ -4465,7 +4455,7 @@ With prefix argument, make it a temporary breakpoint."
(if edebug-stop-point
(let* ((edebug-def-name (car edebug-stop-point))
(index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
+ (edebug-data (edebug-get-edebug-or-ghost edebug-def-name))
(edebug-breakpoints (car (cdr edebug-data)))
(edebug-break-data (assq index edebug-breakpoints))
(edebug-break-condition (car (cdr edebug-break-data)))
@@ -4479,17 +4469,6 @@ With prefix argument, make it a temporary breakpoint."
(edebug-modify-breakpoint t condition arg))
(easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus)
-
-;;; Autoloading of Edebug accessories
-
-;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
-(defun edebug--require-cl-read ()
- (require 'edebug-cl-read))
-
-(if (featurep 'cl-read)
- (add-hook 'edebug-setup-hook #'edebug--require-cl-read)
- ;; The following causes edebug-cl-read to be loaded when you load cl-read.el.
- (add-hook 'cl-read-load-hooks #'edebug--require-cl-read))
;;; Finalize Loading
@@ -4501,13 +4480,18 @@ With prefix argument, make it a temporary breakpoint."
(add-hook 'called-interactively-p-functions
#'edebug--called-interactively-skip)
(defun edebug--called-interactively-skip (i frame1 frame2)
- (when (and (eq (car-safe (nth 1 frame1)) 'lambda)
- (eq (nth 1 (nth 1 frame1)) '())
- (eq (nth 1 frame2) 'edebug-enter))
+ (when (and (memq (car-safe (nth 1 frame1)) '(lambda closure))
+ ;; Lambda value with no arguments.
+ (null (nth (if (eq (car-safe (nth 1 frame1)) 'lambda) 1 2)
+ (nth 1 frame1)))
+ (memq (nth 1 frame2) '(edebug-enter edebug-default-enter)))
;; `edebug-enter' calls itself on its first invocation.
- (if (eq (nth 1 (backtrace-frame i 'called-interactively-p))
- 'edebug-enter)
- 2 1)))
+ (let ((s 1))
+ (while (memq (nth 1 (backtrace-frame i 'called-interactively-p))
+ '(edebug-enter edebug-default-enter))
+ (cl-incf s)
+ (cl-incf i))
+ s)))
;; Finally, hook edebug into the rest of Emacs.
;; There are probably some other things that could go here.
@@ -4525,7 +4509,6 @@ With prefix argument, make it a temporary breakpoint."
(run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug)))))
(remove-hook 'called-interactively-p-functions
#'edebug--called-interactively-skip)
- (remove-hook 'cl-read-load-hooks #'edebug--require-cl-read)
(edebug-uninstall-read-eval-functions)
;; Continue standard unloading.
nil)
@@ -4579,5 +4562,15 @@ instrumentation for, defaulting to all functions."
(message "Removed edebug instrumentation from %s"
(mapconcat #'symbol-name functions ", ")))
+
+;;; Obsolete.
+
+(defun edebug-mark ()
+ (declare (obsolete mark "28.1"))
+ (mark t))
+
+(define-obsolete-function-alias 'edebug-mark-marker #'mark-marker "28.1")
+(define-obsolete-function-alias 'edebug-window-live-p #'window-live-p "28.1")
+
(provide 'edebug)
;;; edebug.el ends here
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index f09144c6258..ec7c899bddc 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -1,7 +1,6 @@
;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*-
-;;; Copyright (C) 2000-2002, 2004-2005, 2007-2021 Free Software
-;;; Foundation, Inc.
+;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
@@ -157,11 +156,64 @@ only one object ever exists."
;; NOTE TO SELF: In next version, make `slot-boundp' support classes
;; with class allocated slots or default values.
(let ((old (oref-default class singleton)))
- (if (eq old eieio-unbound)
+ (if (eq old eieio--unbound)
(oset-default class singleton (cl-call-next-method))
old)))
+;;; Named object
+
+(defclass eieio-named ()
+ ((object-name :initarg :object-name :initform nil))
+ "Object with a name."
+ :abstract t)
+
+(cl-defmethod eieio-object-name-string ((obj eieio-named))
+ "Return a string which is OBJ's name."
+ (or (slot-value obj 'object-name)
+ (cl-call-next-method)))
+
+(cl-defgeneric eieio-object-set-name-string (obj name)
+ "Set the string which is OBJ's NAME."
+ (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1"))
+ (cl-check-type name string)
+ (setf (gethash obj eieio--object-names) name))
+(define-obsolete-function-alias
+ 'object-set-name-string 'eieio-object-set-name-string "24.4")
+
+(with-suppressed-warnings ((obsolete eieio-object-set-name-string))
+ (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
+ "Set the string which is OBJ's NAME."
+ (cl-check-type name string)
+ (eieio-oset obj 'object-name name)))
+
+(cl-defmethod clone ((obj eieio-named) &rest params)
+ "Clone OBJ, initializing `:parent' to OBJ.
+All slots are unbound, except those initialized with PARAMS."
+ (let* ((newname (and (stringp (car params)) (pop params)))
+ (nobj (apply #'cl-call-next-method obj params))
+ (nm (slot-value nobj 'object-name)))
+ (eieio-oset nobj 'object-name
+ (or newname
+ (if (equal nm (slot-value obj 'object-name))
+ (save-match-data
+ (if (and nm (string-match "-\\([0-9]+\\)" nm))
+ (let ((num (1+ (string-to-number
+ (match-string 1 nm)))))
+ (concat (substring nm 0 (match-beginning 0))
+ "-" (int-to-string num)))
+ (concat nm "-1")))
+ nm)))
+ nobj))
+
+(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args)
+ (if (not (stringp (car args)))
+ (cl-call-next-method)
+ (funcall (if eieio-backward-compatibility #'ignore #'message)
+ "Obsolete: name passed without :object-name to %S constructor"
+ class)
+ (apply #'cl-call-next-method class :object-name args)))
+
;;; eieio-persistent
;;
;; For objects which must save themselves to disk. Provides an
@@ -252,119 +304,102 @@ being pedantic."
(error
"Invalid object: %s is not an object of class %s nor a subclass"
(car ret) class))
- (setq ret (eieio-persistent-convert-list-to-object ret))
+ (setq ret (eieio-persistent-make-instance (car ret) (cdr ret)))
(oset ret file filename))
(kill-buffer " *tmp eieio read*"))
ret))
-(defun eieio-persistent-convert-list-to-object (inputlist)
- "Convert the INPUTLIST, representing object creation to an object.
-While it is possible to just `eval' the INPUTLIST, this code instead
-validates the existing list, and explicitly creates objects instead of
-calling eval. This avoids the possibility of accidentally running
-malicious code.
-
-Note: This function recurses when a slot of :type of some object is
-identified, and needing more object creation."
- (let* ((objclass (nth 0 inputlist))
- ;; Earlier versions of `object-write' added a string name for
- ;; the object, now obsolete.
- (slots (nthcdr
- (if (stringp (nth 1 inputlist)) 2 1)
- inputlist))
- (createslots nil)
- (class
- (progn
- ;; If OBJCLASS is an eieio autoload object, then we need to
- ;; load it.
- (eieio--full-class-object objclass))))
-
- (while slots
- (let ((initarg (car slots))
- (value (car (cdr slots))))
-
- ;; Make sure that the value proposed for SLOT is valid.
- ;; In addition, strip out quotes, list functions, and update
- ;; object constructors as needed.
- (setq value (eieio-persistent-validate/fix-slot-value
- class (eieio--initarg-to-attribute class initarg) value))
-
- (push initarg createslots)
- (push value createslots)
- )
-
- (setq slots (cdr (cdr slots))))
-
- (apply #'make-instance objclass (nreverse createslots))
-
- ;;(eval inputlist)
- ))
-
-(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value)
- "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix.
-A limited number of functions, such as quote, list, and valid object
-constructor functions are considered valid.
-Second, any text properties will be stripped from strings."
+(cl-defgeneric eieio-persistent-make-instance (objclass inputlist)
+ "Convert INPUTLIST, representing slot values, to an instance of OBJCLASS.
+Clean slot values, and possibly recursively create additional
+objects found there."
+ (:method
+ ((objclass (subclass eieio-default-superclass)) inputlist)
+
+ (let* ((name nil)
+ (slots (if (stringp (car inputlist))
+ (progn
+ ;; Earlier versions of `object-write' added a
+ ;; string name for the object, now obsolete.
+ ;; Save as 'name' in case this object is subclass
+ ;; of eieio-named with no :object-name slot specified.
+ (setq name (car inputlist))
+ (cdr inputlist))
+ inputlist))
+ (createslots nil))
+ ;; If OBJCLASS is an eieio autoload object, then we need to
+ ;; load it (we don't need the return value).
+ (eieio--full-class-object objclass)
+ (while slots
+ (let ((initarg (car slots))
+ (value (car (cdr slots))))
+
+ ;; Strip out quotes, list functions, and update object
+ ;; constructors as needed.
+ (setq value (eieio-persistent-fix-value value))
+
+ (push initarg createslots)
+ (push value createslots))
+
+ (setq slots (cdr (cdr slots))))
+
+ (let ((newobj (apply #'make-instance objclass (nreverse createslots))))
+
+ ;; Check for special case of subclass of `eieio-named', and do
+ ;; name assignment.
+ (when (and eieio-backward-compatibility
+ (object-of-class-p newobj 'eieio-named)
+ (not (oref newobj object-name))
+ name)
+ (oset newobj object-name name))
+
+ newobj))))
+
+(defun eieio-persistent-fix-value (proposed-value)
+ "Fix PROPOSED-VALUE.
+Remove leading quotes from lists, and the symbol `list' from the
+head of lists. Explicitly construct any objects found, and strip
+any text properties from string values.
+
+This function will descend into the contents of lists, hash
+tables, and vectors."
(cond ((consp proposed-value)
;; Lists with something in them need special treatment.
- (let* ((slot-idx (- (eieio--slot-name-index class slot)
- (eval-when-compile eieio--object-num-slots)))
- (type (cl--slot-descriptor-type (aref (eieio--class-slots class)
- slot-idx)))
- (classtype (eieio-persistent-slot-type-is-class-p type)))
-
- (cond ((eq (car proposed-value) 'quote)
- (car (cdr proposed-value)))
-
- ;; An empty list sometimes shows up as (list), which is dumb, but
- ;; we need to support it for backward compat.
- ((and (eq (car proposed-value) 'list)
- (= (length proposed-value) 1))
- nil)
-
- ;; List of object constructors.
- ((and (eq (car proposed-value) 'list)
- ;; 2nd item is a list.
- (consp (car (cdr proposed-value)))
- ;; 1st elt of 2nd item is a class name.
- (class-p (car (car (cdr proposed-value))))
- )
-
- ;; Check the value against the input class type.
- ;; If something goes wrong, issue a smart warning
- ;; about how a :type is needed for this to work.
- (unless (and
- ;; Do we have a type?
- (consp classtype) (class-p (car classtype)))
- (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
- slot classtype))
-
- ;; We have a predicate, but it doesn't satisfy the predicate?
- (dolist (PV (cdr proposed-value))
- (unless (child-of-class-p (car PV) (car classtype))
- (error "Invalid object: slot member %s does not match class %s"
- (car PV) (car classtype))))
-
- ;; We have a list of objects here. Lets load them
- ;; in.
- (let ((objlist nil))
- (dolist (subobj (cdr proposed-value))
- (push (eieio-persistent-convert-list-to-object subobj)
- objlist))
- ;; return the list of objects ... reversed.
- (nreverse objlist)))
- ;; We have a slot with a single object that can be
- ;; saved here. Recurse and evaluate that
- ;; sub-object.
- ((and classtype
- (seq-some
- (lambda (elt)
- (child-of-class-p (car proposed-value) elt))
- (if (listp classtype) classtype (list classtype))))
- (eieio-persistent-convert-list-to-object
- proposed-value))
- (t
- proposed-value))))
+ (cond ((eq (car proposed-value) 'quote)
+ (while (eq (car-safe proposed-value) 'quote)
+ (setq proposed-value (car (cdr proposed-value))))
+ proposed-value)
+
+ ;; An empty list sometimes shows up as (list), which is dumb, but
+ ;; we need to support it for backward compar.
+ ((and (eq (car proposed-value) 'list)
+ (= (length proposed-value) 1))
+ nil)
+
+ ;; List of object constructors.
+ ((and (eq (car proposed-value) 'list)
+ ;; 2nd item is a list.
+ (consp (car (cdr proposed-value)))
+ ;; 1st elt of 2nd item is a class name.
+ (class-p (car (car (cdr proposed-value)))))
+
+ ;; We have a list of objects here. Lets load them
+ ;; in.
+ (let ((objlist nil))
+ (dolist (subobj (cdr proposed-value))
+ (push (eieio-persistent-make-instance
+ (car subobj) (cdr subobj))
+ objlist))
+ ;; return the list of objects ... reversed.
+ (nreverse objlist)))
+ ;; We have a slot with a single object that can be
+ ;; saved here. Recurse and evaluate that
+ ;; sub-object.
+ ((class-p (car proposed-value))
+ (eieio-persistent-make-instance
+ (car proposed-value) (cdr proposed-value)))
+ (t
+ proposed-value)))
;; For hash-tables and vectors, the top-level `read' will not
;; "look inside" member values, so we need to do that
;; explicitly. Because `eieio-override-prin1' is recursive in
@@ -375,10 +410,9 @@ Second, any text properties will be stripped from strings."
(lambda (key value)
(setf (gethash key proposed-value)
(if (class-p (car-safe value))
- (eieio-persistent-convert-list-to-object
- value)
- (eieio-persistent-validate/fix-slot-value
- class slot value))))
+ (eieio-persistent-make-instance
+ (car value) (cdr value))
+ (eieio-persistent-fix-value value))))
proposed-value)
proposed-value)
@@ -387,72 +421,18 @@ Second, any text properties will be stripped from strings."
(let ((val (aref proposed-value i)))
(aset proposed-value i
(if (class-p (car-safe val))
- (eieio-persistent-convert-list-to-object
- val)
- (eieio-persistent-validate/fix-slot-value
- class slot val)))))
+ (eieio-persistent-make-instance
+ (car val) (cdr val))
+ (eieio-persistent-fix-value val)))))
proposed-value)
- ((stringp proposed-value)
- ;; Else, check for strings, remove properties.
- (substring-no-properties proposed-value))
-
- (t
- ;; Else, just return whatever the constant was.
- proposed-value))
- )
-
-(defun eieio-persistent-slot-type-is-class-p (type)
- "Return the class referred to in TYPE.
-If no class is referenced there, then return nil."
- (cond ((class-p type)
- ;; If the type is a class, then return it.
- type)
- ((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
- ;; If it is the type of a list of a class, then return that class and
- ;; the type.
- (cons (cadr type) type))
-
- ((and (symbolp type) (get type 'cl-deftype-handler))
- ;; Macro-expand the type according to cl-deftype definitions.
- (eieio-persistent-slot-type-is-class-p
- (funcall (get type 'cl-deftype-handler))))
-
- ;; FIXME: foo-child should not be a valid type!
- ((and (symbolp type) (string-match "-child\\'" (symbol-name type))
- (class-p (intern-soft (substring (symbol-name type) 0
- (match-beginning 0)))))
- (unless eieio-backward-compatibility
- (error "Use of bogus %S type instead of %S"
- type (intern-soft (substring (symbol-name type) 0
- (match-beginning 0)))))
- ;; If it is the predicate ending with -child, then return
- ;; that class. Unfortunately, in EIEIO, typep of just the
- ;; class is the same as if we used -child, so no further work needed.
- (intern-soft (substring (symbol-name type) 0
- (match-beginning 0))))
- ;; FIXME: foo-list should not be a valid type!
- ((and (symbolp type) (string-match "-list\\'" (symbol-name type))
- (class-p (intern-soft (substring (symbol-name type) 0
- (match-beginning 0)))))
- (unless eieio-backward-compatibility
- (error "Use of bogus %S type instead of (list-of %S)"
- type (intern-soft (substring (symbol-name type) 0
- (match-beginning 0)))))
- ;; If it is the predicate ending with -list, then return
- ;; that class and the predicate to use.
- (cons (intern-soft (substring (symbol-name type) 0
- (match-beginning 0)))
- type))
-
- ((eq (car-safe type) 'or)
- ;; If type is a list, and is an `or', return all valid class
- ;; types within the `or' statement.
- (seq-filter #'eieio-persistent-slot-type-is-class-p (cdr type)))
+ ((stringp proposed-value)
+ ;; Else, check for strings, remove properties.
+ (substring-no-properties proposed-value))
(t
- ;; No match, not a class.
- nil)))
+ ;; Else, just return whatever the constant was.
+ proposed-value)))
(cl-defmethod object-write ((this eieio-persistent) &optional comment)
"Write persistent object THIS out to the current stream.
@@ -495,59 +475,6 @@ instance."
;; It should also set up some hooks to help it keep itself up to date.
-;;; Named object
-
-(defclass eieio-named ()
- ((object-name :initarg :object-name :initform nil))
- "Object with a name."
- :abstract t)
-
-(cl-defmethod eieio-object-name-string ((obj eieio-named))
- "Return a string which is OBJ's name."
- (or (slot-value obj 'object-name)
- (cl-call-next-method)))
-
-(cl-defgeneric eieio-object-set-name-string (obj name)
- "Set the string which is OBJ's NAME."
- (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1"))
- (cl-check-type name string)
- (setf (gethash obj eieio--object-names) name))
-(define-obsolete-function-alias
- 'object-set-name-string 'eieio-object-set-name-string "24.4")
-
-(with-suppressed-warnings ((obsolete eieio-object-set-name-string))
- (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name)
- "Set the string which is OBJ's NAME."
- (cl-check-type name string)
- (eieio-oset obj 'object-name name)))
-
-(cl-defmethod clone ((obj eieio-named) &rest params)
- "Clone OBJ, initializing `:parent' to OBJ.
-All slots are unbound, except those initialized with PARAMS."
- (let* ((newname (and (stringp (car params)) (pop params)))
- (nobj (apply #'cl-call-next-method obj params))
- (nm (slot-value nobj 'object-name)))
- (eieio-oset nobj 'object-name
- (or newname
- (if (equal nm (slot-value obj 'object-name))
- (save-match-data
- (if (and nm (string-match "-\\([0-9]+\\)" nm))
- (let ((num (1+ (string-to-number
- (match-string 1 nm)))))
- (concat (substring nm 0 (match-beginning 0))
- "-" (int-to-string num)))
- (concat nm "-1")))
- nm)))
- nobj))
-
-(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args)
- (if (not (stringp (car args)))
- (cl-call-next-method)
- (funcall (if eieio-backward-compatibility #'ignore #'message)
- "Obsolete: name passed without :object-name to %S constructor"
- class)
- (apply #'cl-call-next-method class :object-name args)))
-
(provide 'eieio-base)
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index db97d4ca4e8..6d84839c341 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -105,7 +105,7 @@ Summary:
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
(debug
(&define ; this means we are defining something
- [&or name ("setf" name :name setf)]
+ [&name sexp] ;Allow (setf ...) additionally to symbols.
;; ^^ This is the methods symbol
[ &optional symbolp ] ; this is key :before etc
cl-generic-method-args ; arguments
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index e73afabf9a0..b11ed3333f0 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -71,11 +71,10 @@ Currently under control of this var:
- Define <class>-child-p and <class>-list-p predicates.
- Allow object names in constructors.")
-(defconst eieio-unbound
- (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound))
- eieio-unbound
- (make-symbol "unbound"))
+(define-obsolete-variable-alias 'eieio-unbound 'eieio--unbound "28.1")
+(defvar eieio--unbound (make-symbol "eieio--unbound")
"Uninterned symbol representing an unbound slot in an object.")
+(defvar eieio--unbound-form (macroexp-quote eieio--unbound))
;; This is a bootstrap for eieio-default-superclass so it has a value
;; while it is being built itself.
@@ -169,7 +168,7 @@ Return nil if that option doesn't exist."
(and (recordp obj)
(eieio--class-p (eieio--object-class obj))))
-(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1")
+(define-obsolete-function-alias 'object-p #'eieio-object-p "25.1")
(defun class-abstract-p (class)
"Return non-nil if CLASS is abstract.
@@ -215,7 +214,8 @@ It creates an autoload function for CNAME's constructor."
;; turn this into a usable self-pointing symbol
(when eieio-backward-compatibility
(set cname cname)
- (make-obsolete-variable cname (format "use \\='%s instead" cname)
+ (make-obsolete-variable cname (format "\
+use \\='%s or turn off `eieio-backward-compatibility' instead" cname)
"25.1"))
(setf (cl--find-class cname) newc)
@@ -241,9 +241,9 @@ It creates an autoload function for CNAME's constructor."
(cl-deftype list-of (elem-type)
`(and list
- (satisfies (lambda (list)
- (cl-every (lambda (elem) (cl-typep elem ',elem-type))
- list)))))
+ (satisfies ,(lambda (list)
+ (cl-every (lambda (elem) (cl-typep elem elem-type))
+ list)))))
(defun eieio-make-class-predicate (class)
@@ -263,6 +263,7 @@ It creates an autoload function for CNAME's constructor."
(object-of-class-p obj class))))
(defvar eieio--known-slot-names nil)
+(defvar eieio--known-class-slot-names nil)
(defun eieio-defclass-internal (cname superclasses slots options)
"Define CNAME as a new subclass of SUPERCLASSES.
@@ -346,19 +347,20 @@ See `defclass' for more information."
(when eieio-backward-compatibility
(let ((csym (intern (concat (symbol-name cname) "-list-p"))))
(defalias csym
- `(lambda (obj)
- ,(format
- "Test OBJ to see if it a list of objects which are a child of type %s"
- cname)
- (when (listp obj)
- (let ((ans t)) ;; nil is valid
- ;; Loop over all the elements of the input list, test
- ;; each to make sure it is a child of the desired object class.
- (while (and obj ans)
- (setq ans (and (eieio-object-p (car obj))
- (object-of-class-p (car obj) ,cname)))
- (setq obj (cdr obj)))
- ans))))
+ (lambda (obj)
+ (:documentation
+ (format
+ "Test OBJ to see if it a list of objects which are a child of type %s"
+ cname))
+ (when (listp obj)
+ (let ((ans t)) ;; nil is valid
+ ;; Loop over all the elements of the input list, test
+ ;; each to make sure it is a child of the desired object class.
+ (while (and obj ans)
+ (setq ans (and (eieio-object-p (car obj))
+ (object-of-class-p (car obj) 'cname)))
+ (setq obj (cdr obj)))
+ ans))))
(make-obsolete csym (format
"use (cl-typep ... \\='(list-of %s)) instead"
cname)
@@ -379,7 +381,7 @@ See `defclass' for more information."
(pcase-dolist (`(,name . ,slot) slots)
(let* ((init (or (plist-get slot :initform)
(if (member :initform slot) nil
- eieio-unbound)))
+ eieio--unbound-form)))
(initarg (plist-get slot :initarg))
(docstr (plist-get slot :documentation))
(prot (plist-get slot :protection))
@@ -393,6 +395,14 @@ See `defclass' for more information."
(skip-nil (eieio--class-option-assoc options :allow-nil-initform))
)
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: We duplicate this test here and in `defclass' because
+ ;; if we move this part to `defclass' we may break some existing
+ ;; code (because the `fboundp' test in `eieio--eval-default-p'
+ ;; returns a different result at compile time).
+ (setq init (macroexp-quote init)))
+
;; Clean up the meaning of protection.
(setq prot
(pcase prot
@@ -455,8 +465,9 @@ See `defclass' for more information."
(n (length slots))
(v (make-vector n nil)))
(dotimes (i n)
- (setf (aref v i) (eieio-default-eval-maybe
- (cl--slot-descriptor-initform (aref slots i)))))
+ (setf (aref v i) (eval
+ (cl--slot-descriptor-initform (aref slots i))
+ t)))
(setf (eieio--class-class-allocation-values newc) v))
;; Attach slot symbols into a hash table, and store the index of
@@ -511,7 +522,7 @@ See `defclass' for more information."
cname
))
-(defsubst eieio-eval-default-p (val)
+(defun eieio--eval-default-p (val)
"Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val))))
@@ -520,10 +531,10 @@ See `defclass' for more information."
If SKIPNIL is non-nil, then if default value is nil return t instead."
(let ((value (cl--slot-descriptor-initform slot))
(spec (cl--slot-descriptor-type slot)))
- (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
+ (if (not (or (not (macroexp-const-p value))
eieio-skip-typecheck
(and skipnil (null value))
- (eieio--perform-slot-validation spec value)))
+ (eieio--perform-slot-validation spec (eval value t))))
(signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value)))))
(defun eieio--slot-override (old new skipnil)
@@ -544,7 +555,7 @@ If SKIPNIL is non-nil, then if default value is nil return t instead."
type tp a))
(setf (cl--slot-descriptor-type new) tp))
;; If we have a repeat, only update the initarg...
- (unless (eq d eieio-unbound)
+ (unless (eq d eieio--unbound-form)
(eieio--perform-slot-validation-for-default new skipnil)
(setf (cl--slot-descriptor-initform old) d))
@@ -587,8 +598,8 @@ If SKIPNIL is non-nil, then if default value is nil return t instead."
(defun eieio--add-new-slot (newc slot init alloc
&optional defaultoverride skipnil)
"Add into NEWC attribute SLOT.
-If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist,
-INIT is the initarg, if any.
+If a slot of that name already exists in NEWC, then do nothing.
+If it doesn't exist, INIT is the initarg, if any.
Argument ALLOC specifies if the slot is allocated per instance, or per class.
If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC,
we must override its value for a default.
@@ -602,6 +613,8 @@ if default value is nil."
(cold (car (cl-member a (eieio--class-class-slots newc)
:key #'cl--slot-descriptor-name))))
(cl-pushnew a eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew a eieio--known-class-slot-names))
(condition-case nil
(if (sequencep d) (setq d (copy-sequence d)))
;; This copy can fail on a cons cell with a non-cons in the cdr. Let's
@@ -677,7 +690,7 @@ the new child class."
(defun eieio--perform-slot-validation (spec value)
"Return non-nil if SPEC does not match VALUE."
(or (eq spec t) ; t always passes
- (eq value eieio-unbound) ; unbound always passes
+ (eq value eieio--unbound) ; unbound always passes
(cl-typep value spec)))
(defun eieio--validate-slot-value (class slot-idx value slot)
@@ -713,7 +726,7 @@ an error."
INSTANCE is the object being referenced. SLOTNAME is the offending
slot. If the slot is ok, return VALUE.
Argument FN is the function calling this verifier."
- (if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
+ (if (and (eq value eieio--unbound) (not eieio-skip-typecheck))
(slot-unbound instance (eieio--object-class instance) slotname fn)
value))
@@ -728,9 +741,11 @@ Argument FN is the function calling this verifier."
(pcase slot
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
- (macroexp--warn-and-return
- (format-message "Unknown slot `%S'" name) exp 'compile-only))
- (_ exp)))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
+ (_ exp))))
+ (gv-setter eieio-oset))
(cl-check-type slot symbol)
(cl-check-type obj (or eieio-object class))
(let* ((class (cond ((symbolp obj)
@@ -752,14 +767,30 @@ Argument FN is the function calling this verifier."
(eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
-(defun eieio-oref-default (obj slot)
+(defun eieio-oref-default (class slot)
"Do the work for the macro `oref-default' with similar parameters.
-Fills in OBJ's SLOT with its default value."
- (cl-check-type obj (or eieio-object class))
+Fills in CLASS's SLOT with its default value."
+ (declare (gv-setter eieio-oset-default)
+ (compiler-macro
+ (lambda (exp)
+ (ignore class)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp nil 'compile-only))
+ (_ exp)))))
+ (cl-check-type class (or eieio-object class))
(cl-check-type slot symbol)
- (let* ((cl (cond ((symbolp obj) (cl--find-class obj))
- ((eieio-object-p obj) (eieio--object-class obj))
- (t obj)))
+ (let* ((cl (cond ((symbolp class) (cl--find-class class))
+ ((eieio-object-p class) (eieio--object-class class))
+ (t class)))
(c (eieio--slot-name-index cl slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
@@ -769,27 +800,13 @@ Fills in OBJ's SLOT with its default value."
;; Oref that slot.
(aref (eieio--class-class-allocation-values cl)
c)
- (slot-missing obj slot 'oref-default))
+ (slot-missing class slot 'oref-default))
(eieio-barf-if-slot-unbound
(let ((val (cl--slot-descriptor-initform
(aref (eieio--class-slots cl)
(- c (eval-when-compile eieio--object-num-slots))))))
- (eieio-default-eval-maybe val))
- obj (eieio--class-name cl) 'oref-default))))
-
-(defun eieio-default-eval-maybe (val)
- "Check VAL, and return what `oref-default' would provide."
- ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate
- ;; variables as well? Why not just always call `eval'?
- (cond
- ;; Is it a function call? If so, evaluate it.
- ((eieio-eval-default-p val)
- (eval val))
- ;;;; check for quoted things, and unquote them
- ;;((and (consp val) (eq (car val) 'quote))
- ;; (car (cdr val)))
- ;; return it verbatim
- (t val)))
+ (eval val t))
+ class (eieio--class-name cl) 'oref-default))))
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
@@ -816,6 +833,21 @@ Fills in OBJ's SLOT with VALUE."
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE."
+ (declare (compiler-macro
+ (lambda (exp)
+ (ignore class value)
+ (pcase slot
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
+ ((and (or `',name (and name (pred keywordp)))
+ (guard (not (memq name eieio--known-class-slot-names))))
+ (macroexp-warn-and-return
+ (format-message "Slot `%S' is not class-allocated" name)
+ exp nil 'compile-only))
+ (_ exp)))))
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(cl-check-type slot symbol)
@@ -832,22 +864,18 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(signal 'invalid-slot-name (list (eieio--class-name class) slot)))
;; `oset-default' on an instance-allocated slot is allowed by EIEIO but
;; not by CLOS and is mildly inconsistent with the :initform thingy, so
- ;; it'd be nice to get of it. This said, it is/was used at one place by
- ;; gnus/registry.el, so it might be used elsewhere as well, so let's
- ;; keep it for now.
+ ;; it'd be nice to get rid of it.
+ ;; This said, it is/was used at one place by gnus/registry.el, so it
+ ;; might be used elsewhere as well, so let's keep it for now.
;; FIXME: Generate a compile-time warning for it!
;; (error "Can't `oset-default' an instance-allocated slot: %S of %S"
;; slot class)
(eieio--validate-slot-value class c value slot)
;; Set this into the storage for defaults.
- (if (eieio-eval-default-p value)
- (error "Can't set default to a sexp that gets evaluated again"))
(setf (cl--slot-descriptor-initform
- ;; FIXME: Apparently we set it both in `slots' and in
- ;; `object-cache', which seems redundant.
(aref (eieio--class-slots class)
(- c (eval-when-compile eieio--object-num-slots))))
- value)
+ (macroexp-quote value))
;; Take the value, and put it into our cache object.
(eieio-oset (eieio--class-default-object-cache class)
slot value)
@@ -1026,7 +1054,7 @@ method invocation orders of the involved classes."
(eieio--class-precedence-c3 class))))))
(define-obsolete-function-alias
- 'class-precedence-list 'eieio--class-precedence-list "24.4")
+ 'class-precedence-list #'eieio--class-precedence-list "24.4")
;;; Here are some special types of errors
@@ -1089,8 +1117,20 @@ These match if the argument is the name of a subclass of CLASS."
(defmacro eieio-declare-slots (&rest slots)
"Declare that SLOTS are known eieio object slot names."
- `(eval-when-compile
- (setq eieio--known-slot-names (append ',slots eieio--known-slot-names))))
+ (let ((slotnames (mapcar (lambda (s) (if (consp s) (car s) s)) slots))
+ (classslots (delq nil
+ (mapcar (lambda (s)
+ (when (and (consp s)
+ (eq :class (plist-get (cdr s)
+ :allocation)))
+ (car s)))
+ slots))))
+ `(eval-when-compile
+ ,@(when classslots
+ (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names ',s))
+ classslots))
+ ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s))
+ slotnames))))
(provide 'eieio-core)
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 24a34b2c012..d7d078b2d94 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -1,4 +1,4 @@
-;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*-
+;;; eieio-custom.el --- eieio object customization -*- lexical-binding:t -*-
;; Copyright (C) 1999-2001, 2005, 2007-2021 Free Software Foundation,
;; Inc.
@@ -33,7 +33,6 @@
(require 'eieio)
(require 'widget)
(require 'wid-edit)
-(require 'custom)
;;; Compatibility
@@ -47,7 +46,7 @@
:documentation "A string for testing custom.
This is the next line of documentation.")
(listostuff :initarg :listostuff
- :initform ("1" "2" "3")
+ :initform '("1" "2" "3")
:type list
:custom (repeat (string :tag "Stuff"))
:label "List of Strings"
@@ -366,8 +365,7 @@ These groups are specified with the `:group' slot flag."
(widget-insert "\n\n")
(widget-insert "Edit object " (eieio-object-name obj) "\n\n")
;; Create the widget editing the object.
- (make-local-variable 'eieio-wo)
- (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
+ (setq-local eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
;;Now generate the apply buttons
(widget-insert "\n")
(eieio-custom-object-apply-reset obj)
@@ -376,10 +374,8 @@ These groups are specified with the `:group' slot flag."
;;(widget-minor-mode)
(goto-char (point-min))
(widget-forward 3)
- (make-local-variable 'eieio-co)
- (setq eieio-co obj)
- (make-local-variable 'eieio-cog)
- (setq eieio-cog g)))
+ (setq-local eieio-co obj)
+ (setq-local eieio-cog g)))
(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
"Insert an Apply and Reset button into the object editor.
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 6e14a38139e..08a6debc203 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -1,4 +1,4 @@
-;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
+;;; eieio-opt.el --- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software
;; Foundation, Inc.
@@ -136,9 +136,9 @@ are not abstract."
(def (symbol-function ctr)))
(goto-char (point-min))
(prin1 ctr)
- (insert (format " is an %s object constructor function"
+ (insert (format " is an %sobject constructor function"
(if (autoloadp def)
- "autoloaded"
+ "autoloaded "
"")))
(when (and (autoloadp def)
(null location))
@@ -278,14 +278,7 @@ are not abstract."
(if eieio-class-speedbar-key-map
nil
- (if (not (featurep 'speedbar))
- (add-hook 'speedbar-load-hook (lambda ()
- (eieio-class-speedbar-make-map)
- (speedbar-add-expansion-list
- '("EIEIO"
- eieio-class-speedbar-menu
- eieio-class-speedbar-key-map
- eieio-class-speedbar))))
+ (with-eval-after-load 'speedbar
(eieio-class-speedbar-make-map)
(speedbar-add-expansion-list '("EIEIO"
eieio-class-speedbar-menu
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index 92a9f2a8de6..3f2a6537ab8 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -1,4 +1,4 @@
-;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*-
+;;; eieio-speedbar.el --- Classes for managing speedbar displays. -*- lexical-binding:t -*-
;; Copyright (C) 1999-2002, 2005, 2007-2021 Free Software Foundation,
;; Inc.
@@ -140,11 +140,7 @@ MENU-VAR is the symbol containing an easymenu compatible menu part to use.
MODENAME is a string used to identify this browser mode.
FETCHER is a generic function used to fetch the base object list used when
creating the speedbar display."
- (if (not (featurep 'speedbar))
- (add-hook 'speedbar-load-hook
- (list 'lambda nil
- (list 'eieio-speedbar-create-engine
- map-fn map-var menu-var modename fetcher)))
+ (with-eval-after-load 'speedbar
(eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher)))
(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher)
@@ -252,7 +248,7 @@ and take the appropriate action."
Possible values are those symbols supported by the `exp-button-type' argument
to `speedbar-make-tag-line'."
:allocation :class)
- (buttonface :initform speedbar-tag-face
+ (buttonface :initform 'speedbar-tag-face
:type (or symbol face)
:documentation
"The face used on the textual part of the button for this class.
@@ -269,15 +265,15 @@ Add one of the child classes to this class to the parent list of a class."
:abstract t)
(defclass eieio-speedbar-directory-button (eieio-speedbar)
- ((buttontype :initform angle)
- (buttonface :initform speedbar-directory-face))
+ ((buttontype :initform 'angle)
+ (buttonface :initform 'speedbar-directory-face))
"Class providing support for objects which behave like a directory."
:method-invocation-order :depth-first
:abstract t)
(defclass eieio-speedbar-file-button (eieio-speedbar)
- ((buttontype :initform bracket)
- (buttonface :initform speedbar-file-face))
+ ((buttontype :initform 'bracket)
+ (buttonface :initform 'speedbar-file-face))
"Class providing support for objects which behave like a file."
:method-invocation-order :depth-first
:abstract t)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 131997a7ef0..c16d8e110ec 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -53,6 +53,7 @@
(message eieio-version))
(require 'eieio-core)
+(eval-when-compile (require 'subr-x))
;;; Defining a new class
@@ -131,6 +132,7 @@ and reference them using the function `class-option'."
(let ((testsym1 (intern (concat (symbol-name name) "-p")))
(testsym2 (intern (format "%s--eieio-childp" name)))
+ (warnings '())
(accessors ()))
;; Collect the accessors we need to define.
@@ -145,6 +147,8 @@ and reference them using the function `class-option'."
;; Update eieio--known-slot-names already in case we compile code which
;; uses this before the class is loaded.
(cl-pushnew sname eieio--known-slot-names)
+ (when (eq alloc :class)
+ (cl-pushnew sname eieio--known-class-slot-names))
(if eieio-error-unsupported-class-tags
(let ((tmp soptions))
@@ -176,8 +180,22 @@ and reference them using the function `class-option'."
(signal 'invalid-slot-type (list :label label)))
;; Is there an initarg, but allocation of class?
- (if (and initarg (eq alloc :class))
- (message "Class allocated slots do not need :initarg"))
+ (when (and initarg (eq alloc :class))
+ (push (format "Meaningless :initarg for class allocated slot '%S'"
+ sname)
+ warnings))
+
+ (let ((init (plist-get soptions :initform)))
+ (unless (or (macroexp-const-p init)
+ (eieio--eval-default-p init))
+ ;; FIXME: Historically, EIEIO used a heuristic to try and guess
+ ;; whether the initform is a form to be evaluated or just
+ ;; a constant. We use `eieio--eval-default-p' to see what the
+ ;; heuristic says and if it disagrees with normal evaluation
+ ;; then tweak the initform to make it fit and emit
+ ;; a warning accordingly.
+ (push (format "Ambiguous initform needs quoting: %S" init)
+ warnings)))
;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
@@ -223,6 +241,9 @@ This method is obsolete."
))
`(progn
+ ,@(mapcar (lambda (w)
+ (macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
+ warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
;; pointers to itself.
@@ -233,7 +254,7 @@ This method is obsolete."
,@(when eieio-backward-compatibility
(let ((f (intern (format "%s-child-p" name))))
- `((defalias ',f ',testsym2)
+ `((defalias ',f #',testsym2)
(make-obsolete
',f ,(format "use (cl-typep ... \\='%s) instead" name)
"25.1"))))
@@ -269,7 +290,7 @@ This method is obsolete."
(lambda (whole)
(if (not (stringp (car slots)))
whole
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
@@ -282,23 +303,19 @@ This method is obsolete."
;;; Get/Set slots in an object.
;;
(defmacro oref (obj slot)
- "Retrieve the value stored in OBJ in the slot named by SLOT.
-Slot is the name of the slot when created by `defclass' or the label
-created by the :initarg tag."
+ "Retrieve the value stored in OBJ in the slot named by SLOT."
(declare (debug (form symbolp)))
`(eieio-oref ,obj (quote ,slot)))
-(defalias 'slot-value 'eieio-oref)
-(defalias 'set-slot-value 'eieio-oset)
+(defalias 'slot-value #'eieio-oref)
+(defalias 'set-slot-value #'eieio-oset)
(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1")
-(defmacro oref-default (obj slot)
- "Get the default value of OBJ (maybe a class) for SLOT.
-The default value is the value installed in a class with the :initform
-tag. SLOT can be the slot name, or the tag specified by the :initarg
-tag in the `defclass' call."
+(defmacro oref-default (class slot)
+ "Get the value of class allocated slot SLOT.
+CLASS can also be an object, in which case we use the object's class."
(declare (debug (form symbolp)))
- `(eieio-oref-default ,obj (quote ,slot)))
+ `(eieio-oref-default ,class (quote ,slot)))
;;; Handy CLOS macros
;;
@@ -351,24 +368,20 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the
contents of field NAME is matched against PAT, or they can be of
the form NAME which is a shorthand for (NAME NAME)."
(declare (debug (&rest [&or (sexp pcase-PAT) sexp])))
- (let ((is (make-symbol "table")))
- ;; FIXME: This generates a horrendous mess of redundant let bindings.
- ;; `pcase' needs to be improved somehow to introduce let-bindings more
- ;; sparingly, or the byte-compiler needs to be taught to optimize
- ;; them away.
- ;; FIXME: `pcase' does not do a good job here of sharing tests&code among
- ;; various branches.
- `(and (pred eieio-object-p)
- (app eieio-pcase-slot-index-table ,is)
- ,@(mapcar (lambda (field)
- (let* ((name (if (consp field) (car field) field))
- (pat (if (consp field) (cadr field) field))
- (i (make-symbol "index")))
- `(and (let (and ,i (pred natnump))
- (eieio-pcase-slot-index-from-index-table
- ,is ',name))
- (app (pcase--flip aref ,i) ,pat))))
- fields))))
+ ;; FIXME: This generates a horrendous mess of redundant let bindings.
+ ;; `pcase' needs to be improved somehow to introduce let-bindings more
+ ;; sparingly, or the byte-compiler needs to be taught to optimize
+ ;; them away.
+ ;; FIXME: `pcase' does not do a good job here of sharing tests&code among
+ ;; various branches.
+ `(and (pred eieio-object-p)
+ ,@(mapcar (lambda (field)
+ (pcase-exhaustive field
+ (`(,name ,pat)
+ `(app (pcase--flip eieio-oref ',name) ,pat))
+ ((pred symbolp)
+ `(app (pcase--flip eieio-oref ',field) ,field))))
+ fields)))
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
@@ -422,7 +435,7 @@ If EXTRA, include that in the string returned to represent the symbol."
(cl-check-type obj eieio-object)
(eieio-class-name (eieio--object-class obj)))
(define-obsolete-function-alias
- 'object-class-name 'eieio-object-class-name "24.4")
+ 'object-class-name #'eieio-object-class-name "24.4")
(defun eieio-class-parents (class)
;; FIXME: What does "(overload of variable)" mean here?
@@ -450,7 +463,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
(defmacro eieio-class-parent (class)
"Return first parent class to CLASS. (overload of variable)."
`(car (eieio-class-parents ,class)))
-(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4")
+(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4")
(defun same-class-p (obj class)
"Return t if OBJ is of class-type CLASS."
@@ -465,7 +478,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
;; class will be checked one layer down
(child-of-class-p (eieio--object-class obj) class))
;; Backwards compatibility
-(defalias 'obj-of-class-p 'object-of-class-p)
+(defalias 'obj-of-class-p #'object-of-class-p)
(defun child-of-class-p (child class)
"Return non-nil if CHILD class is a subclass of CLASS."
@@ -542,11 +555,11 @@ OBJECT can be an instance or a class."
((eieio-object-p object) (eieio-oref object slot))
((symbolp object) (eieio-oref-default object slot))
(t (signal 'wrong-type-argument (list 'eieio-object-p object))))
- eieio-unbound))))
+ eieio--unbound))))
(defun slot-makeunbound (object slot)
"In OBJECT, make SLOT unbound."
- (eieio-oset object slot eieio-unbound))
+ (eieio-oset object slot eieio--unbound))
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
@@ -649,14 +662,6 @@ If SLOT is unbound, do nothing."
nil
(eieio-oset object slot (delete item (eieio-oref object slot)))))
-;;; Here are some CLOS items that need the CL package
-;;
-
-;; FIXME: Shouldn't this be a more complex gv-expander which extracts the
-;; common code between oref and oset, so as to reduce the redundant work done
-;; in (push foo (oref bar baz)), like we do for the `nth' expander?
-(gv-define-simple-setter eieio-oref eieio-oset)
-
;;;
;; We want all objects created by EIEIO to have some default set of
@@ -677,7 +682,7 @@ This class is not stored in the `parent' slot of a class vector."
(setq eieio-default-superclass (cl--find-class 'eieio-default-superclass))
(define-obsolete-function-alias 'standard-class
- 'eieio-default-superclass "26.1")
+ #'eieio-default-superclass "26.1")
(cl-defgeneric make-instance (class &rest initargs)
"Make a new instance of CLASS based on INITARGS.
@@ -737,35 +742,37 @@ Called from the constructor routine."
"Construct the new object THIS based on SLOTS.")
(cl-defmethod initialize-instance ((this eieio-default-superclass)
- &optional slots)
- "Construct the new object THIS based on SLOTS.
-SLOTS is a tagged list where odd numbered elements are tags, and
+ &optional args)
+ "Construct the new object THIS based on ARGS.
+ARGS is a property list where odd numbered elements are tags, and
even numbered elements are the values to store in the tagged slot.
If you overload the `initialize-instance', there you will need to
call `shared-initialize' yourself, or you can call `call-next-method'
to have this constructor called automatically. If these steps are
not taken, then new objects of your class will not have their values
-dynamically set from SLOTS."
- ;; First, see if any of our defaults are `lambda', and
- ;; re-evaluate them and apply the value to our slots.
+dynamically set from ARGS."
(let* ((this-class (eieio--object-class this))
+ (initargs args)
(slots (eieio--class-slots this-class)))
(dotimes (i (length slots))
- ;; For each slot, see if we need to evaluate it.
- ;;
- ;; Paul Landes said in an email:
- ;; > CL evaluates it if it can, and otherwise, leaves it as
- ;; > the quoted thing as you already have. This is by the
- ;; > Sonya E. Keene book and other things I've look at on the
- ;; > web.
+ ;; For each slot, see if we need to evaluate its initform.
(let* ((slot (aref slots i))
- (initform (cl--slot-descriptor-initform slot))
- (dflt (eieio-default-eval-maybe initform)))
- (when (not (eq dflt initform))
- ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)!
- (eieio-oset this (cl--slot-descriptor-name slot) dflt)))))
- ;; Shared initialize will parse our slots for us.
- (shared-initialize this slots))
+ (slot-name (eieio-slot-descriptor-name slot))
+ (initform (cl--slot-descriptor-initform slot)))
+ (unless (or (when-let ((initarg
+ (car (rassq slot-name
+ (eieio--class-initarg-tuples
+ this-class)))))
+ (plist-get initargs initarg))
+ ;; Those slots whose initform is constant already have
+ ;; the right value set in the default-object.
+ (macroexp-const-p initform))
+ ;; FIXME: Use `aset' instead of `eieio-oset', relying on that
+ ;; vector returned by `eieio--class-slots'
+ ;; should be congruent with the object itself.
+ (eieio-oset this slot-name (eval initform t))))))
+ ;; Shared initialize will parse our args for us.
+ (shared-initialize this args))
(cl-defgeneric slot-missing (object slot-name _operation &optional _new-value)
"Method invoked when an attempt to access a slot in OBJECT fails.
@@ -887,7 +894,7 @@ this object."
;; Now output readable lisp to recreate this object
;; It should look like this:
;; (<constructor> <name> <slot> <slot> ... )
- ;; Each slot's slot is writen using its :writer.
+ ;; Each slot's slot is written using its :writer.
(when eieio-print-indentation
(princ (make-string (* eieio-print-depth 2) ? )))
(princ "(")
@@ -984,13 +991,13 @@ this object."
This may create or delete slots, but does not affect the return value
of `eq'."
(error "EIEIO: `change-class' is unimplemented"))
-(define-obsolete-function-alias 'change-class 'eieio-change-class "26.1")
+(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1")
;; Hook ourselves into help system for describing classes and methods.
;; FIXME: This is not actually needed any more since we can click on the
;; hyperlink from the constructor's docstring to see the type definition.
-(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
+(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor)
(provide 'eieio)
-;;; eieio ends here
+;;; eieio.el ends here
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 7cf5796db09..cec89cf3bc5 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -5,6 +5,11 @@
;; Author: Noah Friedman <friedman@splode.com>
;; Keywords: extensions
;; Created: 1995-10-06
+;; Version: 1.11.0
+;; Package-Requires: ((emacs "26.3"))
+
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
;; This file is part of GNU Emacs.
@@ -32,20 +37,18 @@
;; the one-line documentation for that variable instead, to remind you of
;; that variable's meaning.
-;; One useful way to enable this minor mode is to put the following in your
-;; .emacs:
-;;
-;; (add-hook 'emacs-lisp-mode-hook 'eldoc-mode)
-;; (add-hook 'lisp-interaction-mode-hook 'eldoc-mode)
-;; (add-hook 'ielm-mode-hook 'eldoc-mode)
-;; (add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-mode)
+;; This mode is now enabled by default in all major modes that provide
+;; support for it, such as `emacs-lisp-mode'.
+;; This is controlled by `global-eldoc-mode'.
-;; Major modes for other languages may use ElDoc by defining an
-;; appropriate function as the buffer-local value of
-;; `eldoc-documentation-function'.
+;; Major modes for other languages may use ElDoc by adding an
+;; appropriate function to the buffer-local value of
+;; `eldoc-documentation-functions'.
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup eldoc nil
"Show function arglist or variable docstring in echo area."
:group 'lisp
@@ -57,20 +60,23 @@ If user input arrives before this interval of time has elapsed after the
last input, no documentation will be printed.
If this variable is set to 0, no idle time is required."
- :type 'number
- :group 'eldoc)
+ :type 'number)
(defcustom eldoc-print-after-edit nil
- "If non-nil eldoc info is only shown when editing.
+ "If non-nil, eldoc info is only shown when editing.
Changing the value requires toggling `eldoc-mode'."
+ :type 'boolean)
+
+(defcustom eldoc-echo-area-display-truncation-message t
+ "If non-nil, provide verbose help when a message has been truncated.
+If nil, truncated messages will just have \"...\" appended."
:type 'boolean
- :group 'eldoc)
+ :version "28.1")
;;;###autoload
(defcustom eldoc-minor-mode-string (purecopy " ElDoc")
"String to display in mode line when ElDoc Mode is enabled; nil for none."
- :type '(choice string (const :tag "None" nil))
- :group 'eldoc)
+ :type '(choice string (const :tag "None" nil)))
(defcustom eldoc-argument-case #'identity
"Case to display argument names of functions, as a symbol.
@@ -79,42 +85,55 @@ Actually, any name of a function which takes a string as an argument and
returns another string is acceptable.
Note that this variable has no effect, unless
-`eldoc-documentation-function' handles it explicitly."
+`eldoc-documentation-strategy' handles it explicitly."
:type '(radio (function-item upcase)
(function-item downcase)
- function)
- :group 'eldoc)
+ function))
(make-obsolete-variable 'eldoc-argument-case nil "25.1")
(defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit
- "Allow long ElDoc messages to resize echo area display.
-If value is t, never attempt to truncate messages; complete symbol name
-and function arglist or 1-line variable documentation will be displayed
-even if echo area must be resized to fit.
-
-If value is any non-nil value other than t, symbol name may be truncated
-if it will enable the function arglist or documentation string to fit on a
-single line without resizing window. Otherwise, behavior is just like
-former case.
-
-If value is nil, messages are always truncated to fit in a single line of
-display in the echo area. Function or variable symbol name may be
-truncated to make more of the arglist or documentation string visible.
-
-Note that this variable has no effect, unless
-`eldoc-documentation-function' handles it explicitly."
- :type '(radio (const :tag "Always" t)
- (const :tag "Never" nil)
- (const :tag "Yes, but truncate symbol names if it will\
- enable argument list to fit on one line" truncate-sym-name-if-fit))
- :group 'eldoc)
+ "Allow long ElDoc doc strings to resize echo area display.
+If value is t, never attempt to truncate messages, even if the
+echo area must be resized to fit.
+
+If the value is a positive number, it is used to calculate a
+number of logical lines of documentation that ElDoc is allowed to
+put in the echo area. If a positive integer, the number is used
+directly, while a float specifies the number of lines as a
+proportion of the echo area frame's height.
+
+If value is the symbol `truncate-sym-name-if-fit' t, the part of
+the doc string that represents a symbol's name may be truncated
+if it will enable the rest of the doc string to fit on a single
+line, without resizing the echo area.
+
+If value is nil, a doc string is always truncated to fit in a
+single line of display in the echo area.
+
+Any resizing of the echo area additionally respects
+`max-mini-window-height'."
+ :type '(radio (const :tag "Always" t)
+ (float :tag "Fraction of frame height" 0.25)
+ (integer :tag "Number of lines" 5)
+ (const :tag "Never" nil)
+ (const :tag "Yes, but ask major-mode to truncate
+ symbol names if it will\ enable argument list to fit on one
+ line" truncate-sym-name-if-fit)))
+
+(defcustom eldoc-echo-area-prefer-doc-buffer nil
+ "Prefer ElDoc's documentation buffer if it is showing in some frame.
+If this variable's value is t, ElDoc will skip showing
+documentation in the echo area if the dedicated documentation
+buffer (given by `eldoc-doc-buffer') is being displayed in some
+window. If the value is the symbol `maybe', then the echo area
+is only skipped if the documentation doesn't fit there."
+ :type 'boolean)
(defface eldoc-highlight-function-argument
'((t (:inherit bold)))
"Face used for the argument at point in a function's argument list.
-Note that this face has no effect unless the `eldoc-documentation-function'
-handles it explicitly."
- :group 'eldoc)
+Note that this face has no effect unless the `eldoc-documentation-strategy'
+handles it explicitly.")
;;; No user options below here.
@@ -155,7 +174,7 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.")
This is used to determine if `eldoc-idle-delay' is changed by the user.")
(defvar eldoc-message-function #'eldoc-minibuffer-message
- "The function used by `eldoc-message' to display messages.
+ "The function used by `eldoc--message' to display messages.
It should receive the same arguments as `message'.")
(defun eldoc-edit-message-commands ()
@@ -182,8 +201,7 @@ area displays information about a function or variable in the
text where point is. If point is on a documented variable, it
displays the first line of that variable's doc string. Otherwise
it displays the argument list of the function called in the
-expression point is on."
- :group 'eldoc :lighter eldoc-minor-mode-string
+expression point is on." :lighter eldoc-minor-mode-string
(setq eldoc-last-message nil)
(cond
((not (eldoc--supported-p))
@@ -193,24 +211,23 @@ expression point is on."
(eldoc-mode
(when eldoc-print-after-edit
(setq-local eldoc-message-commands (eldoc-edit-message-commands)))
- (add-hook 'post-command-hook 'eldoc-schedule-timer nil t)
- (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area nil t))
+ (add-hook 'post-command-hook #'eldoc-schedule-timer nil t)
+ (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area nil t))
(t
(kill-local-variable 'eldoc-message-commands)
- (remove-hook 'post-command-hook 'eldoc-schedule-timer t)
- (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t)
+ (remove-hook 'post-command-hook #'eldoc-schedule-timer t)
+ (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area t)
(when eldoc-timer
(cancel-timer eldoc-timer)
(setq eldoc-timer nil)))))
;;;###autoload
(define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode
- :group 'eldoc
:initialize 'custom-initialize-delay
:init-value t
;; For `read--expression', the usual global mode mechanism of
;; `change-major-mode-hook' runs in the minibuffer before
- ;; `eldoc-documentation-function' is set, so `turn-on-eldoc-mode'
+ ;; `eldoc-documentation-strategy' is set, so `turn-on-eldoc-mode'
;; does nothing. Configure and enable eldoc from
;; `eval-expression-minibuffer-setup-hook' instead.
(if global-eldoc-mode
@@ -222,21 +239,26 @@ expression point is on."
(defun eldoc--eval-expression-setup ()
;; Setup `eldoc', similar to `emacs-lisp-mode'. FIXME: Call
;; `emacs-lisp-mode' itself?
- (add-function :before-until (local 'eldoc-documentation-function)
- #'elisp-eldoc-documentation-function)
+ (cond ((<= emacs-major-version 27)
+ (declare-function elisp-eldoc-documentation-function "elisp-mode")
+ (with-no-warnings
+ (add-function :before-until (local 'eldoc-documentation-function)
+ #'elisp-eldoc-documentation-function)))
+ (t (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-var-docstring nil t)
+ (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-funcall nil t)
+ (setq-local eldoc-documentation-strategy
+ 'eldoc-documentation-default)))
(eldoc-mode +1))
;;;###autoload
(defun turn-on-eldoc-mode ()
"Turn on `eldoc-mode' if the buffer has ElDoc support enabled.
-See `eldoc-documentation-function' for more detail."
+See `eldoc-documentation-strategy' for more detail."
(when (eldoc--supported-p)
(eldoc-mode 1)))
-(defun eldoc--supported-p ()
- "Non-nil if an ElDoc function is set for this buffer."
- (not (memq eldoc-documentation-function '(nil ignore))))
-
(defun eldoc-schedule-timer ()
"Ensure `eldoc-timer' is running.
@@ -252,7 +274,9 @@ reflect the change."
(when (or eldoc-mode
(and global-eldoc-mode
(eldoc--supported-p)))
- (eldoc-print-current-symbol-info))))))
+ ;; Don't ignore, but also don't full-on signal errors
+ (with-demoted-errors "eldoc error: %s"
+ (eldoc-print-current-symbol-info)) )))))
;; If user has changed the idle delay, update the timer.
(cond ((not (= eldoc-idle-delay eldoc-current-idle-delay))
@@ -277,28 +301,29 @@ Otherwise work like `message'."
(or (window-in-direction 'above (minibuffer-window))
(minibuffer-selected-window)
(get-largest-window)))
- (when mode-line-format
- (unless (and (listp mode-line-format)
- (assq 'eldoc-mode-line-string mode-line-format))
+ (when (and mode-line-format
+ (not (and (listp mode-line-format)
+ (assq 'eldoc-mode-line-string mode-line-format))))
(setq mode-line-format
(list "" '(eldoc-mode-line-string
(" " eldoc-mode-line-string " "))
- mode-line-format))))
+ mode-line-format)))
(setq eldoc-mode-line-string
(when (stringp format-string)
(apply #'format-message format-string args)))
(force-mode-line-update)))
- (apply 'message format-string args)))
+ (apply #'message format-string args)))
-(defun eldoc-message (&optional string)
+(make-obsolete
+ 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0")
+(defun eldoc-message (&optional string) (eldoc--message string))
+(defun eldoc--message (&optional string)
"Display STRING as an ElDoc message if it's non-nil.
Also store it in `eldoc-last-message' and return that value."
(let ((omessage eldoc-last-message))
(setq eldoc-last-message string)
- ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages
- ;; are recorded in a log. Do not put eldoc messages in that log since
- ;; they are Legion.
+ ;; Do not put eldoc messages in the log since they are Legion.
;; Emacs way of preventing log messages.
(let ((message-log-max nil))
(cond (eldoc-last-message
@@ -311,34 +336,45 @@ Also store it in `eldoc-last-message' and return that value."
(and (symbolp command)
(intern-soft (symbol-name command) eldoc-message-commands)))
-;; This function goes on pre-command-hook for XEmacs or when using idle
-;; timers in Emacs. Motion commands clear the echo area for some reason,
+;; This function goes on pre-command-hook.
+;; Motion commands clear the echo area for some reason,
;; which make eldoc messages flicker or disappear just before motion
;; begins. This function reprints the last eldoc message immediately
;; before the next command executes, which does away with the flicker.
;; This doesn't seem to be required for Emacs 19.28 and earlier.
+;; FIXME: The above comment suggests we don't really understand why
+;; this is needed. Maybe it's not needed any more, but if it is
+;; we should figure out why.
(defun eldoc-pre-command-refresh-echo-area ()
"Reprint `eldoc-last-message' in the echo area."
(and eldoc-last-message
(not (minibufferp)) ;We don't use the echo area when in minibuffer.
(if (and (eldoc-display-message-no-interference-p)
(eldoc--message-command-p this-command))
- (eldoc-message eldoc-last-message)
- ;; No need to call eldoc-message since the echo area will be cleared
+ (eldoc--message eldoc-last-message)
+ ;; No need to call eldoc--message since the echo area will be cleared
;; for us, but do note that the last-message will be gone.
(setq eldoc-last-message nil))))
-;; Decide whether now is a good time to display a message.
+;; The point of `eldoc--request-state' is not to over-request, which
+;; can happen if the idle timer is restarted on execution of command
+;; which is guaranteed not to change the conditions that warrant a new
+;; request for documentation.
+(defvar eldoc--last-request-state nil
+ "Tuple containing information about last ElDoc request.")
+(defun eldoc--request-state ()
+ "Compute information to store in `eldoc--last-request-state'."
+ (list (current-buffer) (buffer-modified-tick) (point)))
+
(defun eldoc-display-message-p ()
- "Return non-nil when it is appropriate to display an ElDoc message."
+ "Tell if ElDoc can use the echo area."
(and (eldoc-display-message-no-interference-p)
- ;; If this-command is non-nil while running via an idle
- ;; timer, we're still in the middle of executing a command,
- ;; e.g. a query-replace where it would be annoying to
- ;; overwrite the echo area.
(not this-command)
(eldoc--message-command-p last-command)))
+(make-obsolete 'eldoc-display-message-p
+ "Use `eldoc-documentation-functions' instead."
+ "eldoc-1.6.0")
;; Check various conditions about the current environment that might make
;; it undesirable to print eldoc messages right this instant.
@@ -347,75 +383,497 @@ Also store it in `eldoc-last-message' and return that value."
(not (or executing-kbd-macro (bound-and-true-p edebug-active))))
-;;;###autoload
-(defvar eldoc-documentation-function #'ignore
- "Function to call to return doc string.
-The function of no args should return a one-line string for displaying
-doc about a function etc. appropriate to the context around point.
-It should return nil if there's no doc appropriate for the context.
-Typically doc is returned if point is on a function-like name or in its
-arg list.
-
-The result is used as is, so the function must explicitly handle
-the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p',
-and the face `eldoc-highlight-function-argument', if they are to have any
-effect.
-
-Major modes should modify this variable using `add-function', for example:
- (add-function :before-until (local \\='eldoc-documentation-function)
- #\\='foo-mode-eldoc-function)
-so that the global documentation function (i.e. the default value of the
-variable) is taken into account if the major mode specific function does not
+(defvar eldoc-documentation-functions nil
+ "Hook of functions that produce doc strings.
+
+A doc string is typically relevant if point is on a function-like
+name, inside its arg list, or on any object with some associated
+information.
+
+Each hook function is called with at least one argument CALLBACK,
+a function, and decides whether to display a short doc string
+about the context around point.
+
+- If that decision can be taken quickly, the hook function may
+ call CALLBACK immediately, following the protocol described
+ below. Alternatively, it may ignore CALLBACK entirely and
+ return either the doc string, or nil if there's no doc
+ appropriate for the context.
+
+- If the computation of said doc string (or the decision whether
+ there is one at all) is expensive or can't be performed
+ directly, the hook function should return a non-nil, non-string
+ value and arrange for CALLBACK to be called at a later time,
+ using asynchronous processes or other asynchronous mechanisms.
+
+To call the CALLBACK function, the hook function must pass it an
+obligatory argument DOCSTRING, a string containing the
+documentation, followed by an optional list of arbitrary
+keyword-value pairs of the form (:KEY VALUE :KEY2 VALUE2...).
+The information contained in these pairs is understood by members
+of `eldoc-display-functions', allowing the
+documentation-producing backend to cooperate with specific
+documentation-displaying frontends. For example, KEY can be:
+
+* `:thing', VALUE being a short string or symbol designating what
+ is being reported on. It can, for example be the name of the
+ function whose signature is being documented, or the name of
+ the variable whose docstring is being documented.
+ `eldoc-display-in-echo-area', a member of
+ `eldoc-display-functions', sometimes omits this information
+ depending on space constraints;
+
+* `:face', VALUE being a symbol designating a face which both
+ `eldoc-display-in-echo-area' and `eldoc-display-in-buffer' will
+ use when displaying `:thing''s value.
+
+Finally, major modes should modify this hook locally, for
+example:
+ (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t)
+so that the global value (i.e. the default value of the hook) is
+taken into account if the major mode specific function does not
return any documentation.")
-(defun eldoc-print-current-symbol-info ()
- "Print the text produced by `eldoc-documentation-function'."
- ;; This is run from post-command-hook or some idle timer thing,
- ;; so we need to be careful that errors aren't ignored.
- (with-demoted-errors "eldoc error: %s"
- (if (not (eldoc-display-message-p))
- ;; Erase the last message if we won't display a new one.
- (when eldoc-last-message
- (eldoc-message nil))
- (let ((non-essential t))
- ;; Only keep looking for the info as long as the user hasn't
- ;; requested our attention. This also locally disables inhibit-quit.
- (while-no-input
- (eldoc-message (funcall eldoc-documentation-function)))))))
-
-;; If the entire line cannot fit in the echo area, the symbol name may be
-;; truncated or eliminated entirely from the output to make room for the
-;; description.
-(defun eldoc-docstring-format-sym-doc (prefix doc &optional face)
- "Combine PREFIX and DOC, and shorten the result to fit in the echo area.
-
-When PREFIX is a symbol, propertize its symbol name with FACE
-before combining it with DOC. If FACE is not provided, just
-apply the nil face.
-
-See also: `eldoc-echo-area-use-multiline-p'."
- (when (symbolp prefix)
- (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": ")))
- (let* ((ea-multi eldoc-echo-area-use-multiline-p)
- ;; Subtract 1 from window width since emacs will not write
- ;; any chars to the last column, or in later versions, will
- ;; cause a wraparound and resize of the echo area.
- (ea-width (1- (window-width (minibuffer-window))))
- (strip (- (+ (length prefix) (length doc)) ea-width)))
- (cond ((or (<= strip 0)
- (eq ea-multi t)
- (and ea-multi (> (length doc) ea-width)))
- (concat prefix doc))
- ((> (length doc) ea-width)
- (substring (format "%s" doc) 0 ea-width))
- ((>= strip (string-match-p ":? *\\'" prefix))
- doc)
+(defvar eldoc-display-functions
+ '(eldoc-display-in-echo-area eldoc-display-in-buffer)
+ "Hook of functions tasked with displaying ElDoc results.
+Each function is passed two arguments: DOCS and INTERACTIVE. DOCS
+is a list (DOC ...) where DOC looks like (STRING :KEY VALUE :KEY2
+VALUE2 ...). STRING is a string containing the documentation's
+text and the remainder of DOC is an optional list of
+keyword-value pairs denoting additional properties of that
+documentation. For commonly recognized properties, see
+`eldoc-documentation-functions'.
+
+INTERACTIVE says if the request to display doc strings came
+directly from the user or from ElDoc's automatic mechanisms'.")
+
+(defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.")
+
+(defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.")
+
+(defun eldoc-doc-buffer ()
+ "Display ElDoc documentation buffer.
+
+This holds the results of the last documentation request."
+ (interactive)
+ (unless (buffer-live-p eldoc--doc-buffer)
+ (user-error (format
+ "ElDoc buffer doesn't exist, maybe `%s' to produce one."
+ (substitute-command-keys "\\[eldoc]"))))
+ (with-current-buffer eldoc--doc-buffer
+ (rename-buffer (replace-regexp-in-string "^ *" ""
+ (buffer-name)))
+ (display-buffer (current-buffer))))
+
+(defun eldoc--format-doc-buffer (docs)
+ "Ensure DOCS are displayed in an *eldoc* buffer."
+ (with-current-buffer (if (buffer-live-p eldoc--doc-buffer)
+ eldoc--doc-buffer
+ (setq eldoc--doc-buffer
+ (get-buffer-create " *eldoc*")))
+ (unless (eq docs eldoc--doc-buffer-docs)
+ (setq-local eldoc--doc-buffer-docs docs)
+ (let ((inhibit-read-only t)
+ (things-reported-on))
+ (erase-buffer) (setq buffer-read-only t)
+ (local-set-key "q" 'quit-window)
+ (cl-loop for (docs . rest) on docs
+ for (this-doc . plist) = docs
+ for thing = (plist-get plist :thing)
+ when thing do
+ (cl-pushnew thing things-reported-on)
+ (setq this-doc
+ (concat
+ (propertize (format "%s" thing)
+ 'face (plist-get plist :face))
+ ": "
+ this-doc))
+ do (insert this-doc)
+ when rest do (insert "\n")
+ finally (goto-char (point-min)))
+ ;; Rename the buffer, taking into account whether it was
+ ;; hidden or not
+ (rename-buffer (format "%s*eldoc%s*"
+ (if (string-match "^ " (buffer-name)) " " "")
+ (if things-reported-on
+ (format " for %s"
+ (mapconcat
+ (lambda (s) (format "%s" s))
+ things-reported-on
+ ", "))
+ ""))))))
+ eldoc--doc-buffer)
+
+(defun eldoc--echo-area-substring (available)
+ "Given AVAILABLE lines, get buffer substring to display in echo area.
+Helper for `eldoc-display-in-echo-area'."
+ (let ((start (prog1 (progn
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n")
+ (point))
+ (goto-char (line-end-position available))
+ (skip-chars-backward " \t\n")))
+ (truncated (save-excursion
+ (skip-chars-forward " \t\n")
+ (not (eobp)))))
+ (cond ((eldoc--echo-area-prefer-doc-buffer-p truncated)
+ nil)
+ ((and truncated
+ (> available 1)
+ eldoc-echo-area-display-truncation-message)
+ (goto-char (line-end-position 0))
+ (concat (buffer-substring start (point))
+ (format
+ "\n(Documentation truncated. Use `%s' to see rest)"
+ (substitute-command-keys "\\[eldoc-doc-buffer]"))))
(t
- ;; Show the end of the partial symbol name, rather
- ;; than the beginning, since the former is more likely
- ;; to be unique given package namespace conventions.
- (concat (substring prefix strip) doc)))))
+ (buffer-substring start (point))))))
+
+(defun eldoc--echo-area-prefer-doc-buffer-p (truncatedp)
+ "Tell if display in the echo area should be skipped.
+Helper for `eldoc-display-in-echo-area'. If TRUNCATEDP the
+documentation to potentially appear in the echo are is truncated."
+ (and (or (eq eldoc-echo-area-prefer-doc-buffer t)
+ (and truncatedp
+ (eq eldoc-echo-area-prefer-doc-buffer
+ 'maybe)))
+ (get-buffer-window eldoc--doc-buffer 'visible)))
+
+(defun eldoc-display-in-echo-area (docs _interactive)
+ "Display DOCS in echo area.
+Honor `eldoc-echo-area-use-multiline-p' and
+`eldoc-echo-area-prefer-doc-buffer'."
+ (cond
+ (;; Check if he wave permission to mess with echo area at all. For
+ ;; example, if this-command is non-nil while running via an idle
+ ;; timer, we're still in the middle of executing a command, e.g. a
+ ;; query-replace where it would be annoying to overwrite the echo
+ ;; area.
+ (or
+ (not (eldoc-display-message-no-interference-p))
+ this-command
+ (not (eldoc--message-command-p last-command))))
+ (;; If we do but nothing to report, clear the echo area.
+ (null docs)
+ (eldoc--message nil))
+ (t
+ ;; Otherwise, establish some parameters.
+ (let*
+ ((width (1- (window-width (minibuffer-window))))
+ (val (if (and (symbolp eldoc-echo-area-use-multiline-p)
+ eldoc-echo-area-use-multiline-p)
+ max-mini-window-height
+ eldoc-echo-area-use-multiline-p))
+ (available (cl-typecase val
+ (float (truncate (* (frame-height) val)))
+ (integer val)
+ (t 'just-one-line)))
+ single-doc single-doc-sym)
+ (let ((echo-area-message
+ (cond
+ (;; To output to the echo area, we handle the
+ ;; `truncate-sym-name-if-fit' special case first, by
+ ;; checking for a lot of special conditions.
+ (and
+ (eq 'truncate-sym-name-if-fit eldoc-echo-area-use-multiline-p)
+ (null (cdr docs))
+ (setq single-doc (caar docs))
+ (setq single-doc-sym
+ (format "%s" (plist-get (cdar docs) :thing)))
+ (< (length single-doc) width)
+ (not (string-match "\n" single-doc))
+ (> (+ (length single-doc) (length single-doc-sym) 2) width))
+ single-doc)
+ ((and (numberp available)
+ (cl-plusp available))
+ ;; Else, given a positive number of logical lines, we
+ ;; format the *eldoc* buffer, using as most of its
+ ;; contents as we know will fit.
+ (with-current-buffer (eldoc--format-doc-buffer docs)
+ (save-excursion
+ (eldoc--echo-area-substring available))))
+ (t ;; this is the "truncate brutally" situation
+ (let ((string
+ (with-current-buffer (eldoc--format-doc-buffer docs)
+ (buffer-substring (goto-char (point-min))
+ (line-end-position 1)))))
+ (if (> (length string) width) ; truncation to happen
+ (unless (eldoc--echo-area-prefer-doc-buffer-p t)
+ (truncate-string-to-width string width))
+ (unless (eldoc--echo-area-prefer-doc-buffer-p nil)
+ string)))))))
+ (when echo-area-message
+ (eldoc--message echo-area-message)))))))
+
+(defun eldoc-display-in-buffer (docs interactive)
+ "Display DOCS in a dedicated buffer.
+If INTERACTIVE is t, also display the buffer."
+ (eldoc--format-doc-buffer docs)
+ (when interactive
+ (eldoc-doc-buffer)))
+
+(defun eldoc-documentation-default ()
+ "Show first doc string for item at point.
+Default value for `eldoc-documentation-strategy'."
+ (run-hook-with-args-until-success 'eldoc-documentation-functions
+ (eldoc--make-callback :patient)))
+
+(defun eldoc--documentation-compose-1 (eagerlyp)
+ "Helper function for composing multiple doc strings.
+If EAGERLYP is non-nil show documentation as soon as possible,
+else wait for all doc strings."
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (let* ((callback (eldoc--make-callback
+ (if eagerlyp :eager :patient)))
+ (str (funcall f callback)))
+ (if (or (null str) (stringp str)) (funcall callback str))
+ nil)))
+ t)
+
+(defun eldoc-documentation-compose ()
+ "Show multiple doc strings at once after waiting for all.
+Meant as a value for `eldoc-documentation-strategy'."
+ (eldoc--documentation-compose-1 nil))
+
+(defun eldoc-documentation-compose-eagerly ()
+ "Show multiple doc strings at once as soon as possible.
+Meant as a value for `eldoc-documentation-strategy'."
+ (eldoc--documentation-compose-1 t))
+
+(defun eldoc-documentation-enthusiast ()
+ "Show most important doc string produced so far.
+Meant as a value for `eldoc-documentation-strategy'."
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (let* ((callback (eldoc--make-callback :enthusiast))
+ (str (funcall f callback)))
+ (if (stringp str) (funcall callback str))
+ nil)))
+ t)
+
+;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't
+;; make the "old" `eldoc-documentation-function' point to the new
+;; `eldoc-documentation-strategy', so we do the reverse. This allows
+;; for ElDoc to be loaded in those older Emacs versions and work with
+;; whomever (major-modes, extensions, user) sets one or the other
+;; variable.
+(defmacro eldoc--documentation-strategy-defcustom
+ (main secondary value docstring &rest more)
+ "Defcustom helper macro for sorting `eldoc-documentation-strategy'."
+ (declare (indent 2))
+ `(if (< emacs-major-version 28)
+ (progn
+ (defcustom ,secondary ,value ,docstring ,@more)
+ (define-obsolete-variable-alias ',main ',secondary "eldoc-1.1.0"))
+ (progn
+ (defcustom ,main ,value ,docstring ,@more)
+ (defvaralias ',secondary ',main ,docstring))))
+
+(eldoc--documentation-strategy-defcustom eldoc-documentation-strategy
+ eldoc-documentation-function
+ #'eldoc-documentation-default
+ "How to collect and organize results of `eldoc-documentation-functions'.
+
+This variable controls how `eldoc-documentation-functions', which
+specifies the sources of documentation, is queried and how its
+results are organized before being displayed to the user. The
+following values are allowed:
+
+- `eldoc-documentation-default': calls functions in the special
+ hook in order until one is found that produces a doc string
+ value. Display only that value;
+
+- `eldoc-documentation-compose': calls all functions in the
+ special hook and displays all of the resulting doc strings
+ together. Wait for all strings to be ready, and preserve their
+ relative order as specified by the order of functions in the hook;
+
+- `eldoc-documentation-compose-eagerly': calls all functions in
+ the special hook and displays as many of the resulting doc
+ strings as possible, as soon as possible. Preserves the
+ relative order of doc strings;
+
+- `eldoc-documentation-enthusiast': calls all functions in the
+ special hook and displays only the most important resulting
+ docstring one at any given time. A function appearing first in
+ the special hook is considered more important.
+
+This variable can also be set to a function of no args that
+returns something other than a string or nil and allows for some
+or all of the special hook `eldoc-documentation-functions' to be
+run. In that case, the strategy function should follow that
+other variable's protocol closely and endeavor to display the
+resulting doc strings itself.
+
+For backward compatibility to the \"old\" protocol, this variable
+can also be set to a function that returns nil or a doc string,
+depending whether or not there is documentation to display at
+all."
+ :link '(info-link "(emacs) Lisp Doc")
+ :type '(radio (function-item eldoc-documentation-default)
+ (function-item eldoc-documentation-compose)
+ (function-item eldoc-documentation-compose-eagerly)
+ (function-item eldoc-documentation-enthusiast)
+ (function :tag "Other function"))
+ :version "28.1")
+
+(defun eldoc--supported-p ()
+ "Non-nil if an ElDoc function is set for this buffer."
+ (and (not (memq eldoc-documentation-strategy '(nil ignore)))
+ (or eldoc-documentation-functions
+ ;; The old API had major modes set `eldoc-documentation-function'
+ ;; to provide eldoc support. It's impossible now to determine
+ ;; reliably whether the `eldoc-documentation-strategy' provides
+ ;; eldoc support (as in the old API) or whether it just provides
+ ;; a way to combine the results of the
+ ;; `eldoc-documentation-functions' (as in the new API).
+ ;; But at least if it's set buffer-locally it's a good hint that
+ ;; there's some eldoc support in the current buffer.
+ (local-variable-p 'eldoc-documentation-strategy))))
+
+(defvar eldoc--enthusiasm-curbing-timer nil
+ "Timer used by the `eldoc-documentation-enthusiast' strategy.
+When a doc string is encountered, it must endure a certain amount
+of time unchallenged until it is displayed to the user. This
+prevents blinking if a lower priority docstring comes in shortly
+before a higher priority one.")
+
+(defalias 'eldoc #'eldoc-print-current-symbol-info)
+
+;; This variable should be unbound, but that confuses
+;; `describe-symbol' for some reason.
+(defvar eldoc--make-callback nil "Helper for function `eldoc--make-callback'.")
+
+;; JT@2020-07-08: the below docstring for the internal function
+;; `eldoc--invoke-strategy' could be moved to
+;; `eldoc-documentation-strategy' or thereabouts if/when we decide to
+;; extend or publish the `make-callback' protocol.
+(defun eldoc--make-callback (method)
+ "Make callback suitable for `eldoc-documentation-functions'.
+The return value is a function FN whose lambda list is (STRING
+&rest PLIST) and can be called by those functions. Its
+responsibility is always to register the docstring STRING along
+with options specified in PLIST as the documentation to display
+for each particular situation.
+
+METHOD specifies how the callback behaves relative to other
+competing elements in `eldoc-documentation-functions'. It can
+have the following values:
+
+- `:enthusiast' says to display STRING as soon as possible if
+ there's no higher priority doc string;
+
+- `:patient' says to display STRING along with all other
+ competing strings but only when all of all
+ `eldoc-documentation-functions' have been collected;
+
+- `:eager' says to display STRING along with all other competing
+ strings so far, as soon as possible."
+ (funcall eldoc--make-callback method))
+
+(defun eldoc--invoke-strategy (interactive)
+ "Invoke `eldoc-documentation-strategy' function.
+
+If INTERACTIVE is non-nil, the request came directly from a user
+command, otherwise it came from ElDoc's idle
+timer, `eldoc-timer'.
+
+That function's job is to run the `eldoc-documentation-functions'
+special hook, using the `run-hook' family of functions. ElDoc's
+built-in strategy functions play along with the
+`eldoc--make-callback' protocol, using it to produce a callback
+argument to feed the functions that the user places in
+`eldoc-documentation-functions'. Whenever the strategy
+determines it has information to display to the user, this
+function passes responsibility to the functions in
+`eldoc-display-functions'.
+
+Other third-party values of `eldoc-documentation-strategy' should
+not use `eldoc--make-callback'. They must find some alternate
+way to produce callbacks to feed to
+`eldoc-documentation-functions' and should endeavour to display
+the docstrings eventually produced, using
+`eldoc-display-functions'."
+ (let* (;; How many callbacks have been created by the strategy
+ ;; function and passed to elements of
+ ;; `eldoc-documentation-functions'.
+ (howmany 0)
+ ;; How many calls to callbacks we're still waiting on. Used
+ ;; by `:patient'.
+ (want 0)
+ ;; The doc strings and corresponding options registered so
+ ;; far.
+ (docs-registered '()))
+ (cl-labels
+ ((register-doc
+ (pos string plist)
+ (when (and string (> (length string) 0))
+ (push (cons pos (cons string plist)) docs-registered)))
+ (display-doc
+ ()
+ (run-hook-with-args
+ 'eldoc-display-functions (mapcar #'cdr
+ (setq docs-registered
+ (sort docs-registered
+ (lambda (a b) (< (car a) (car b))))))
+ interactive))
+ (make-callback
+ (method)
+ (let ((pos (prog1 howmany (cl-incf howmany))))
+ (cl-ecase method
+ (:enthusiast
+ (lambda (string &rest plist)
+ (when (and string (cl-loop for (p) in docs-registered
+ never (< p pos)))
+ (setq docs-registered '())
+ (register-doc pos string plist))
+ (when (and (timerp eldoc--enthusiasm-curbing-timer)
+ (memq eldoc--enthusiasm-curbing-timer
+ timer-list))
+ (cancel-timer eldoc--enthusiasm-curbing-timer))
+ (setq eldoc--enthusiasm-curbing-timer
+ (run-at-time (unless (zerop pos) 0.3)
+ nil #'display-doc))
+ t))
+ (:patient
+ (cl-incf want)
+ (lambda (string &rest plist)
+ (register-doc pos string plist)
+ (when (zerop (cl-decf want)) (display-doc))
+ t))
+ (:eager
+ (lambda (string &rest plist)
+ (register-doc pos string plist)
+ (display-doc)
+ t))))))
+ (let* ((eldoc--make-callback #'make-callback)
+ (res (funcall eldoc-documentation-strategy)))
+ ;; Observe the old and the new protocol:
+ (cond (;; Old protocol: got string, output immediately;
+ (stringp res) (register-doc 0 res nil) (display-doc))
+ (;; Old protocol: got nil, clear the echo area;
+ (null res) (eldoc--message nil))
+ (;; New protocol: trust callback will be called;
+ t))))))
+
+(defun eldoc-print-current-symbol-info (&optional interactive)
+ "Document thing at point."
+ (interactive '(t))
+ (let (token)
+ (cond (interactive
+ (eldoc--invoke-strategy t))
+ ((not (equal (setq token (eldoc--request-state))
+ eldoc--last-request-state))
+ (let ((non-essential t))
+ (setq eldoc--last-request-state token)
+ (eldoc--invoke-strategy nil))))))
+
+;; This section only affects ElDoc output to the echo area, as in
+;; `eldoc-display-in-echo-area'.
+;;
;; When point is in a sexp, the function args are not reprinted in the echo
;; area after every possible interactive command because some of them print
;; their own messages in the echo area; the eldoc functions would instantly
@@ -447,7 +905,6 @@ See also: `eldoc-echo-area-use-multiline-p'."
(apply #'eldoc-remove-command
(all-completions name eldoc-message-commands))))
-
;; Prime the command list.
(eldoc-add-command-completions
"back-to-indentation"
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index ccd0c8ade4e..0fba5938f3d 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -355,15 +355,14 @@ Returns the forms."
;; Env is up to date
elint-buffer-forms
;; Remake env
- (set (make-local-variable 'elint-buffer-forms) (elint-get-top-forms))
- (set (make-local-variable 'elint-features) nil)
- (set (make-local-variable 'elint-buffer-env)
- (elint-init-env elint-buffer-forms))
+ (setq-local elint-buffer-forms (elint-get-top-forms))
+ (setq-local elint-features nil)
+ (setq-local elint-buffer-env (elint-init-env elint-buffer-forms))
(if elint-preloaded-env
;; FIXME: This doesn't do anything! Should we setq the result to
;; elint-buffer-env?
(elint-env-add-env elint-preloaded-env elint-buffer-env))
- (set (make-local-variable 'elint-last-env-time) (buffer-modified-tick))
+ (setq-local elint-last-env-time (buffer-modified-tick))
elint-buffer-forms))
(defun elint-get-top-forms ()
@@ -456,8 +455,8 @@ Return nil if there are no more forms, t otherwise."
(= 4 (length form))
(eq (car-safe (cadr form)) 'quote)
(equal (nth 2 form) '(quote error-conditions)))
- (set (make-local-variable 'elint-extra-errors)
- (cons (cadr (cadr form)) elint-extra-errors)))
+ (setq-local elint-extra-errors
+ (cons (cadr (cadr form)) elint-extra-errors)))
((eq (car form) 'provide)
(add-to-list 'elint-features (eval (cadr form))))
;; Import variable definitions
@@ -522,7 +521,7 @@ Return nil if there are no more forms, t otherwise."
"The currently linted top form, or nil.")
(defvar elint-top-form-logged nil
- "The value t if the currently linted top form has been mentioned in the log buffer.")
+ "Non-nil if the currently linted top form has been mentioned in the log buffer.")
(defun elint-top-form (form)
"Lint a top FORM."
@@ -559,7 +558,8 @@ Return nil if there are no more forms, t otherwise."
(when . elint-check-conditional-form)
(unless . elint-check-conditional-form)
(and . elint-check-conditional-form)
- (or . elint-check-conditional-form))
+ (or . elint-check-conditional-form)
+ (require . elint-require-form))
"Functions to call when some special form should be linted.")
(defun elint-form (form env &optional nohandler)
@@ -954,6 +954,13 @@ Does basic handling of `featurep' tests."
(elint-form form env t))))
env)
+(defun elint-require-form (form _env)
+ "Load `require'd files."
+ (pcase form
+ (`(require ',x)
+ (require x)))
+ nil)
+
;;;
;;; Message functions
;;;
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 1be46ae7e3d..c2b026dc822 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -109,8 +109,7 @@
;; Boy Jim's profiler.el. Both were written for Emacs 18 and both were
;; pretty good first shots at profiling, but I found that they didn't
;; provide the functionality or interface that I wanted, so I wrote
-;; this. I've tested elp in XEmacs 19 and Emacs 19. There's no point
-;; in even trying to make this work with Emacs 18.
+;; this.
;; Unlike previous profilers, elp uses Emacs 19's built-in function
;; current-time to return interval times. This obviates the need for
@@ -341,9 +340,9 @@ Use optional LIST if provided instead."
(interactive
(list
(intern
- (completing-read "Master function: " obarray
- #'elp--instrumented-p
- t nil nil (if elp-master (symbol-name elp-master))))))
+ (let ((default (if elp-master (symbol-name elp-master))))
+ (completing-read (format-prompt "Master function" default)
+ obarray #'elp--instrumented-p t nil nil default)))))
;; When there's a master function, recording is turned off by default.
(setq elp-master funsym
elp-record-p nil)
@@ -484,6 +483,10 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
'face 'link
'help-echo "mouse-2 or RET jumps to definition")))
+(define-derived-mode elp-results-mode special-mode "ELP"
+ "Mode for ELP results."
+ :interactive nil)
+
;;;###autoload
(defun elp-results ()
"Display current profiling results.
@@ -491,11 +494,12 @@ If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions is reset after results are
displayed."
(interactive)
- (let ((curbuf (current-buffer))
- (resultsbuf (if elp-recycle-buffers-p
- (get-buffer-create elp-results-buffer)
- (generate-new-buffer elp-results-buffer))))
- (set-buffer resultsbuf)
+ (pop-to-buffer
+ (if elp-recycle-buffers-p
+ (get-buffer-create elp-results-buffer)
+ (generate-new-buffer elp-results-buffer)))
+ (elp-results-mode)
+ (let ((inhibit-read-only t))
(erase-buffer)
;; get the length of the longest function name being profiled
(let* ((longest 0)
@@ -566,9 +570,6 @@ displayed."
(if elp-sort-by-function
(setq resvec (sort resvec elp-sort-by-function)))
(mapc 'elp-output-result resvec))
- ;; now pop up results buffer
- (set-buffer curbuf)
- (pop-to-buffer resultsbuf)
;; copy results to standard-output?
(if (or elp-use-standard-output noninteractive)
(princ (buffer-substring (point-min) (point-max)))
@@ -583,7 +584,7 @@ displayed."
;; continue standard unloading
nil)
-(cl-defmethod loadhist-unload-element :before :extra "elp" ((x (head defun)))
+(cl-defmethod loadhist-unload-element :extra "elp" :before ((x (head defun)))
"Un-instrument before unloading a function."
(elp-restore-function (cdr x)))
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index a67f42bc386..59ec4d24849 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -30,6 +30,7 @@
(eval-when-compile (require 'cl-lib))
(require 'ert)
+(require 'subr-x) ; string-trim
;;; Test buffers.
@@ -97,19 +98,10 @@ 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 ((":name" form) body))
+ (declare (debug ((":name" form) def-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."
@@ -177,6 +169,18 @@ test for `called-interactively' in the command will fail."
(cl-assert (not unread-command-events) t)
return-value))
+(defmacro ert-simulate-keys (keys &rest body)
+ "Execute BODY with KEYS as pseudo-interactive input."
+ (declare (debug t) (indent 1))
+ `(let ((unread-command-events
+ ;; Add some C-g to try and make sure we still exit
+ ;; in case something goes wrong.
+ (append ,keys '(?\C-g ?\C-g ?\C-g)))
+ ;; Tell `read-from-minibuffer' not to read from stdin when in
+ ;; batch mode.
+ (executing-kbd-macro t))
+ ,@body))
+
(defun ert-run-idle-timers ()
"Run all idle timers (from `timer-idle-list')."
(dolist (timer (copy-sequence timer-idle-list))
@@ -341,6 +345,45 @@ convert it to a string and pass it to COLLECTOR first."
(funcall func object)))
(funcall func object printcharfun))))
+(defvar ert-resource-directory-format "%s-resources/"
+ "Format for `ert-resource-directory'.")
+(defvar ert-resource-directory-trim-left-regexp ""
+ "Regexp for `string-trim' (left) used by `ert-resource-directory'.")
+(defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el"
+ "Regexp for `string-trim' (right) used by `ert-resource-directory'.")
+
+;; Has to be a macro for `load-file-name'.
+(defmacro ert-resource-directory ()
+ "Return absolute file name of the resource (test data) directory.
+
+The path to the resource directory is the \"resources\" directory
+in the same directory as the test file this is called from.
+
+If that directory doesn't exist, find a directory based on the
+test file name. If the file is named \"foo-tests.el\", return
+the absolute file name for \"foo-resources\". If you want a
+different resource directory naming scheme, set the variable
+`ert-resource-directory-format'. Before formatting, the file
+name will be trimmed using `string-trim' with arguments
+`ert-resource-directory-trim-left-regexp' and
+`ert-resource-directory-trim-right-regexp'."
+ `(let* ((testfile ,(or (macroexp-file-name)
+ buffer-file-name))
+ (default-directory (file-name-directory testfile)))
+ (file-truename
+ (if (file-accessible-directory-p "resources/")
+ (expand-file-name "resources/")
+ (expand-file-name
+ (format ert-resource-directory-format
+ (string-trim testfile
+ ert-resource-directory-trim-left-regexp
+ ert-resource-directory-trim-right-regexp)))))))
+
+(defmacro ert-resource-file (file)
+ "Return file name of resource file named FILE.
+A resource file is in the resource directory as per
+`ert-resource-directory'."
+ `(expand-file-name ,file (ert-resource-directory)))
(provide 'ert-x)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index d519c0ff729..92acfe7246f 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -58,13 +58,10 @@
;;; Code:
(require 'cl-lib)
-(require 'button)
(require 'debug)
(require 'backtrace)
-(require 'easymenu)
(require 'ewoc)
(require 'find-func)
-(require 'help)
(require 'pp)
;;; UI customization options.
@@ -83,15 +80,13 @@ Use nil for no limit (caution: backtrace lines can be very long)."
:background "green1")
(((class color) (background dark))
:background "green3"))
- "Face used for expected results in the ERT results buffer."
- :group 'ert)
+ "Face used for expected results in the ERT results buffer.")
(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)
+ "Face used for unexpected results in the ERT results buffer.")
;;; Copies/reimplementations of cl functions.
@@ -198,8 +193,8 @@ it has to be wrapped in `(eval (quote ...))'.
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
[:tags \\='(TAG...)] BODY...)"
- (declare (debug (&define :name test
- name sexp [&optional stringp]
+ (declare (debug (&define [&name "test@" symbolp]
+ sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 3)
(indent 2))
@@ -226,16 +221,6 @@ it has to be wrapped in `(eval (quote ...))'.
:body (lambda () ,@body)))
',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
@@ -276,7 +261,7 @@ DATA is displayed to the user and should state the reason for skipping."
It should only be stopped when ran from inside ert--run-test-internal."
(when (and (not (symbolp debugger)) ; only run on anonymous debugger
(memq error-symbol '(ert-test-failed ert-test-skipped)))
- (funcall debugger 'error data)))
+ (funcall debugger 'error (cons error-symbol data))))
(defun ert--special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
@@ -292,14 +277,7 @@ It should only be stopped when ran from inside ert--run-test-internal."
(let ((form
;; catch macroexpansion errors
(condition-case err
- (macroexpand-all form
- (append (bound-and-true-p
- byte-compile-macro-environment)
- (cond
- ((boundp 'macroexpand-all-environment)
- macroexpand-all-environment)
- ((boundp 'cl-macro-environment)
- cl-macro-environment))))
+ (macroexpand-all form macroexpand-all-environment)
(error `(signal ',(car err) ',(cdr err))))))
(cond
((or (atom form) (ert--special-operator-p (car form)))
@@ -335,12 +313,13 @@ It should only be stopped when ran from inside ert--run-test-internal."
(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)))))
+ (unless (eql ,value ',default-value)
+ (let ((-explainer-
+ (and (symbolp ',fn-name)
+ (get ',fn-name 'ert-explainer))))
+ (when -explainer-
+ (list :explanation
+ (apply -explainer- ,args))))))
value)
,value))))))))
@@ -489,7 +468,7 @@ Errors during evaluation are caught and handled like nil."
Returns nil if they are."
(if (not (eq (type-of a) (type-of b)))
`(different-types ,a ,b)
- (pcase-exhaustive a
+ (pcase a
((pred consp)
(let ((a-length (proper-list-p a))
(b-length (proper-list-p b)))
@@ -515,7 +494,14 @@ Returns nil if they are."
`(cdr ,cdr-x)
(cl-assert (equal a b) t)
nil))))))))
- ((pred arrayp)
+ ((pred cl-struct-p)
+ (cl-loop for slot in (cl-struct-slot-info (type-of a))
+ for ai across a
+ for bi across b
+ for xf = (ert--explain-equal-rec ai bi)
+ do (when xf (cl-return `(struct-field ,(car slot) ,xf)))
+ finally (cl-assert (equal a b) t)))
+ ((or (pred arrayp) (pred recordp))
;; For mixed unibyte/multibyte string comparisons, make both multibyte.
(when (and (stringp a)
(xor (multibyte-string-p a) (multibyte-string-p b)))
@@ -533,7 +519,7 @@ Returns nil if they are."
for xi = (ert--explain-equal-rec ai bi)
do (when xi (cl-return `(array-elt ,i ,xi)))
finally (cl-assert (equal a b) t))))
- ((pred atom)
+ (_
(if (not (equal a b))
(if (and (symbolp a) (symbolp b) (string= a b))
`(different-symbols-with-the-same-name ,a ,b)
@@ -1294,11 +1280,29 @@ EXPECTEDP specifies whether the result was expected."
(ert-test-quit '("quit" "QUIT")))))
(elt s (if expectedp 0 1))))
+(defun ert-reason-for-test-result (result)
+ "Return the reason given for RESULT, as a string.
+
+The reason is the argument given when invoking `ert-fail' or `ert-skip'.
+It is output using `prin1' prefixed by two spaces.
+
+If no reason was given, or for a successful RESULT, return the
+empty string."
+ (let ((reason
+ (and
+ (ert-test-result-with-condition-p result)
+ (cadr (ert-test-result-with-condition-condition result))))
+ (print-escape-newlines t)
+ (print-level 6)
+ (print-length 10))
+ (if reason (format " %S" reason) "")))
+
(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-escape-newlines nil))
+ (pp-escape-newlines t)
+ (print-escape-control-characters t))
(pp object (current-buffer))
(unless (bolp) (insert "\n"))
(save-excursion
@@ -1383,18 +1387,24 @@ Returns the stats object."
(cl-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"
+ (message "%9s %S%s"
(ert-string-for-test-result result nil)
- (ert-test-name test))))
+ (ert-test-name test)
+ (if (getenv "EMACS_TEST_VERBOSE")
+ (ert-reason-for-test-result result)
+ ""))))
(message "%s" ""))
(unless (zerop skipped)
(message "%s skipped results:" skipped)
(cl-loop for test across (ert--stats-tests stats)
for result = (ert-test-most-recent-result test) do
(when (ert-test-result-type-p result :skipped)
- (message "%9s %S"
+ (message "%9s %S%s"
(ert-string-for-test-result result nil)
- (ert-test-name test))))
+ (ert-test-name test)
+ (if (getenv "EMACS_TEST_VERBOSE")
+ (ert-reason-for-test-result result)
+ ""))))
(message "%s" "")))))
(test-started
)
@@ -1542,7 +1552,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(when badtests
(message "%d files did not finish:" (length badtests))
(mapc (lambda (l) (message " %s" l)) badtests)
- (if (getenv "EMACS_HYDRA_CI")
+ (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
(with-temp-buffer
(dolist (f badtests)
(erase-buffer)
@@ -1557,9 +1567,9 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(message "------------------")
(setq tests (sort tests (lambda (x y) (> (car x) (car y)))))
(when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil))
- (message "%s" (mapconcat 'cdr tests "\n")))
- ;; More details on hydra, where the logs are harder to get to.
- (when (and (getenv "EMACS_HYDRA_CI")
+ (message "%s" (mapconcat #'cdr tests "\n")))
+ ;; More details on hydra and emba, where the logs are harder to get to.
+ (when (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
(not (zerop (+ nunexpected nskipped))))
(message "\nDETAILS")
(message "-------")
@@ -1628,9 +1638,7 @@ Signals an error if no test name was read."
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))))
+ (setq prompt (format-prompt 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
@@ -1649,7 +1657,7 @@ default (if any)."
(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: ")))
+ (interactive (list (ert-read-test-name-at-point "Find test definition")))
(find-function-do-it test-name 'ert--test 'switch-to-buffer-other-window))
(defun ert-delete-test (test-name)
@@ -1798,8 +1806,8 @@ Also sets `ert--results-progress-bar-button-begin'."
;; `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))))
+ (setq-local ert--results-progress-bar-button-begin
+ progress-bar-button-begin))))
(insert "\n\n")
(buffer-string))
;; footer
@@ -1975,15 +1983,15 @@ BUFFER-NAME, if non-nil, is the buffer name to use."
;; 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)
+ (setq-local 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)
+ (setq-local ert--results-ewoc ewoc)
+ (setq-local ert--results-stats stats)
+ (setq-local ert--results-progress-bar-string
+ (make-string (ert-stats-total stats)
+ (ert-char-for-test-result nil t)))
+ (setq-local ert--results-listener listener)
(cl-loop for test across (ert--stats-tests stats) do
(ewoc-enter-last ewoc
(make-ert--ewoc-entry :test test
@@ -2016,9 +2024,7 @@ and how to display message."
(car ert--selector-history)
"t")))
(read
- (completing-read (if (null default)
- "Run tests: "
- (format "Run tests (default %s): " default))
+ (completing-read (format-prompt "Run tests" default)
obarray #'ert-test-boundp nil nil
'ert--selector-history default nil)))
nil))
@@ -2088,7 +2094,7 @@ and how to display message."
(ert-run-tests selector listener t)))
;;;###autoload
-(defalias 'ert 'ert-run-tests-interactively)
+(defalias 'ert #'ert-run-tests-interactively)
;;; Simple view mode for auxiliary information like stack traces or
@@ -2101,6 +2107,7 @@ and how to display message."
(define-derived-mode ert-results-mode special-mode "ERT-Results"
"Major mode for viewing results of ERT test runs."
+ :interactive nil
(setq-local revert-buffer-function
(lambda (&rest _) (ert-results-rerun-all-tests))))
@@ -2196,7 +2203,7 @@ To be used in the ERT results buffer."
"Move point to the next test.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
"No tests below"))
@@ -2204,7 +2211,7 @@ To be used in the ERT results buffer."
"Move point to the previous test.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
"No tests above"))
@@ -2237,7 +2244,7 @@ user-error is signaled with the message ERROR-MESSAGE."
"Find the definition of the test at point in another window.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let ((name (ert-test-at-point)))
(unless name
(user-error "No test at point"))
@@ -2271,7 +2278,7 @@ To be used in the ERT results buffer."
;; 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)
+ (interactive nil ert-results-mode)
(let ((ewoc ert--results-ewoc)
(progress-bar-begin ert--results-progress-bar-button-begin))
(cond ((ert--results-test-node-or-null-at-point)
@@ -2388,7 +2395,7 @@ definition."
"Re-run all tests, using the same selector.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(cl-assert (eql major-mode 'ert-results-mode))
(let ((selector (ert--stats-selector ert--results-stats)))
(ert-run-tests-interactively selector (buffer-name))))
@@ -2397,7 +2404,7 @@ To be used in the ERT results buffer."
"Re-run the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(cl-destructuring-bind (test redefinition-state)
(ert--results-test-at-point-allow-redefinition)
(when (null test)
@@ -2432,7 +2439,7 @@ To be used in the ERT results buffer."
"Re-run the test at point with `ert-debug-on-error' bound to t.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let ((ert-debug-on-error t))
(ert-results-rerun-test-at-point)))
@@ -2440,7 +2447,7 @@ To be used in the ERT results buffer."
"Display the backtrace for the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let* ((test (ert--results-test-at-point-no-redefinition t))
(stats ert--results-stats)
(pos (ert--stats-test-pos stats test))
@@ -2467,7 +2474,7 @@ To be used in the ERT results buffer."
"Display the part of the *Messages* buffer generated during the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let* ((test (ert--results-test-at-point-no-redefinition t))
(stats ert--results-stats)
(pos (ert--stats-test-pos stats test))
@@ -2488,7 +2495,7 @@ To be used in the ERT results buffer."
"Display the list of `should' forms executed during the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let* ((test (ert--results-test-at-point-no-redefinition t))
(stats ert--results-stats)
(pos (ert--stats-test-pos stats test))
@@ -2524,7 +2531,7 @@ To be used in the ERT results buffer."
"Toggle how much of the condition to print for the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let* ((ewoc ert--results-ewoc)
(node (ert--results-test-node-at-point))
(entry (ewoc-data node)))
@@ -2536,7 +2543,7 @@ To be used in the ERT results buffer."
"Display test timings for the last run.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(let* ((stats ert--results-stats)
(buffer (get-buffer-create "*ERT timings*"))
(data (cl-loop for test across (ert--stats-tests stats)
@@ -2615,7 +2622,7 @@ To be used in the ERT results buffer."
"Display the documentation of the test at point.
To be used in the ERT results buffer."
- (interactive)
+ (interactive nil ert-results-mode)
(ert-describe-test (ert--results-test-at-point-no-redefinition t)))
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index c65837986d1..d3ace97945f 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -205,15 +205,26 @@ NODE and leaving the new node's start there. Return the new node."
(defun ewoc--refresh-node (pp node dll)
"Redisplay the element represented by NODE using the pretty-printer PP."
- (let ((inhibit-read-only t)
- (m (ewoc--node-start-marker node))
- (R (ewoc--node-right node)))
- ;; First, remove the string from the buffer:
- (delete-region m (ewoc--node-start-marker R))
- ;; Calculate and insert the string.
- (goto-char m)
- (funcall pp (ewoc--node-data node))
- (ewoc--adjust m (point) R dll)))
+ (let* ((m (ewoc--node-start-marker node))
+ (R (ewoc--node-right node))
+ (end (ewoc--node-start-marker R))
+ (inhibit-read-only t)
+ (offset (if (= (point) end)
+ 'end
+ (when (< m (point) end)
+ (- (point) m)))))
+ (save-excursion
+ ;; First, remove the string from the buffer:
+ (delete-region m end)
+ ;; Calculate and insert the string.
+ (goto-char m)
+ (funcall pp (ewoc--node-data node))
+ (setq end (point))
+ (ewoc--adjust m (point) R dll))
+ (when offset
+ (goto-char (if (eq offset 'end)
+ end
+ (min (+ m offset) (1- end)))))))
(defun ewoc--wrap (func)
(lambda (data)
@@ -342,11 +353,10 @@ arguments will be passed to MAP-FUNCTION."
((footer (ewoc--footer ewoc))
(pp (ewoc--pretty-printer ewoc))
(node (ewoc--node-nth dll 1)))
- (save-excursion
- (while (not (eq node footer))
- (if (apply map-function (ewoc--node-data node) args)
- (ewoc--refresh-node pp node dll))
- (setq node (ewoc--node-next dll node))))))
+ (while (not (eq node footer))
+ (if (apply map-function (ewoc--node-data node) args)
+ (ewoc--refresh-node pp node dll))
+ (setq node (ewoc--node-next dll node)))))
(defun ewoc-delete (ewoc &rest nodes)
"Delete NODES from EWOC."
@@ -461,9 +471,8 @@ If the EWOC is empty, nil is returned."
Delete current text first, thus effecting a \"refresh\"."
(ewoc--set-buffer-bind-dll-let* ewoc
((pp (ewoc--pretty-printer ewoc)))
- (save-excursion
- (dolist (node nodes)
- (ewoc--refresh-node pp node dll)))))
+ (dolist (node nodes)
+ (ewoc--refresh-node pp node dll))))
(defun ewoc-goto-prev (ewoc arg)
"Move point to the ARGth previous element in EWOC.
@@ -566,9 +575,8 @@ Return nil if the buffer has been deleted."
(hf-pp (ewoc--hf-pp ewoc)))
(setf (ewoc--node-data head) header
(ewoc--node-data foot) footer)
- (save-excursion
- (ewoc--refresh-node hf-pp head dll)
- (ewoc--refresh-node hf-pp foot dll))))
+ (ewoc--refresh-node hf-pp head dll)
+ (ewoc--refresh-node hf-pp foot dll)))
(provide 'ewoc)
diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el
index 6c3931f9829..162c39634ed 100644
--- a/lisp/emacs-lisp/faceup.el
+++ b/lisp/emacs-lisp/faceup.el
@@ -1170,11 +1170,6 @@ Intended to be called when a file is loaded."
;; File is being evaluated using, for example, `eval-buffer'.
default-directory)))
-
-;; ----------------------------------------------------------------------
-;; The end
-;;
-
(provide 'faceup)
;;; faceup.el ends here
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 0cbd2145432..7bc3e6b25ff 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -61,7 +61,7 @@
"^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\
ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
-menu-bar-make-toggle\\)"
+menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)"
find-function-space-re
"\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)")
"The regexp used by `find-function' to search for a function definition.
@@ -103,7 +103,7 @@ Please send improvements and fixes to the maintainer."
(defcustom find-feature-regexp
(concat ";;; Code:")
- "The regexp used by `xref-find-definitions' when searching for a feature definition.
+ "Regexp used by `xref-find-definitions' when searching for a feature definition.
Note it may contain up to one `%s' at the place where `format'
should insert the feature name."
;; We search for ";;; Code" rather than (feature '%s) because the
@@ -123,10 +123,18 @@ should insert the feature name."
:group 'xref
:version "25.1")
+(defun find-function--defface (symbol)
+ (catch 'found
+ (while (re-search-forward (format find-face-regexp symbol) nil t)
+ (unless (ppss-comment-or-string-start
+ (save-excursion (syntax-ppss (match-beginning 0))))
+ ;; We're not in a comment or a string.
+ (throw 'found t)))))
+
(defvar find-function-regexp-alist
'((nil . find-function-regexp)
(defvar . find-variable-regexp)
- (defface . find-face-regexp)
+ (defface . find-function--defface)
(feature . find-feature-regexp)
(defalias . find-alias-regexp))
"Alist mapping definition types into regexp variables.
@@ -178,13 +186,18 @@ See the functions `find-function' and `find-variable'."
(setq name rel))))
(unless (equal name library) name)))
+(defvar comp-eln-to-el-h)
+
(defun find-library-name (library)
"Return the absolute file name of the Emacs Lisp source of LIBRARY.
LIBRARY should be a string (the name of the library)."
;; If the library is byte-compiled, try to find a source library by
;; the same name.
- (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
+ (cond
+ ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
(setq library (replace-match "" t t library)))
+ ((string-match "\\.eln\\'" library)
+ (setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h))))
(or
(locate-file library
(or find-function-source-path load-path)
@@ -203,7 +216,7 @@ LIBRARY should be a string (the name of the library)."
(or find-function-source-path load-path)
load-file-rep-suffixes)))))
(find-library--from-load-history library)
- (error "Can't find library %s" library)))
+ (signal 'file-error (list "Can't find library" library))))
(defun find-library--from-load-history (library)
;; In `load-history', the file may be ".elc", ".el", ".el.gz", and
@@ -279,25 +292,17 @@ Interactively, prompt for LIBRARY using the one at or near point."
(switch-to-buffer (find-file-noselect (find-library-name library)))
(run-hooks 'find-function-after-hook)))
+;;;###autoload
(defun read-library-name ()
"Read and return a library name, defaulting to the one near point.
A library name is the filename of an Emacs Lisp library located
in a directory under `load-path' (or `find-function-source-path',
if non-nil)."
- (let* ((suffix-regexp (mapconcat
- (lambda (suffix)
- (concat (regexp-quote suffix) "\\'"))
- (find-library-suffixes)
- "\\|"))
- (table (cl-loop for dir in (or find-function-source-path load-path)
- when (file-readable-p dir)
- append (mapcar
- (lambda (file)
- (replace-regexp-in-string suffix-regexp
- "" file))
- (directory-files dir nil
- suffix-regexp))))
+ (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
@@ -313,9 +318,7 @@ if non-nil)."
(thing-at-point 'symbol))))
(when (and def (not (test-completion def table)))
(setq def nil))
- (completing-read (if def
- (format "Library name (default %s): " def)
- "Library name: ")
+ (completing-read (format-prompt "Library name" def)
table nil nil nil nil def)))
;;;###autoload
@@ -399,7 +402,70 @@ The search is done in the source for library LIBRARY."
(progn
(beginning-of-line)
(cons (current-buffer) (point)))
- (cons (current-buffer) nil)))))))))
+ ;; If the regexp search didn't find the location of
+ ;; the symbol (for example, because it is generated by
+ ;; a macro), try a slightly more expensive search that
+ ;; expands macros until it finds the symbol.
+ (cons (current-buffer)
+ (find-function--search-by-expanding-macros
+ (current-buffer) symbol type))))))))))
+
+(defun find-function--try-macroexpand (form)
+ "Try to macroexpand FORM in full or partially.
+This is a best-effort operation in which if macroexpansion fails,
+this function returns FORM as is."
+ (ignore-errors
+ (or
+ (macroexpand-all form)
+ (macroexpand-1 form)
+ form)))
+
+(defun find-function--any-subform-p (form pred)
+ "Walk FORM and apply PRED to its subexpressions.
+Return t if any PRED returns t."
+ (cond
+ ((not (consp form)) nil)
+ ((funcall pred form) t)
+ (t
+ (cl-destructuring-bind (left-child . right-child) form
+ (or
+ (find-function--any-subform-p left-child pred)
+ (find-function--any-subform-p right-child pred))))))
+
+(defun find-function--search-by-expanding-macros (buf symbol type)
+ "Expand macros in BUF to search for the definition of SYMBOL of TYPE."
+ (catch 'found
+ (with-current-buffer buf
+ (save-excursion
+ (goto-char (point-min))
+ (condition-case nil
+ (while t
+ (let ((form (read (current-buffer)))
+ (expected-symbol-p
+ (lambda (form)
+ (cond
+ ((null type)
+ ;; Check if a given form is a `defalias' to
+ ;; SYM, the function name we are searching
+ ;; for. All functions in Emacs Lisp
+ ;; ultimately expand to a `defalias' form
+ ;; after several steps of macroexpansion.
+ (and (eq (car-safe form) 'defalias)
+ (equal (car-safe (cdr form))
+ `(quote ,symbol))))
+ ((eq type 'defvar)
+ ;; Variables generated by macros ultimately
+ ;; expand to `defvar'.
+ (and (eq (car-safe form) 'defvar)
+ (eq (car-safe (cdr form)) symbol)))
+ (t nil)))))
+ (when (find-function--any-subform-p
+ (find-function--try-macroexpand form)
+ expected-symbol-p)
+ ;; We want to return the location at the beginning
+ ;; of the macro, so move back one sexp.
+ (throw 'found (progn (backward-sexp) (point))))))
+ (end-of-file nil))))))
(defun find-function-library (function &optional lisp-only verbose)
"Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION.
@@ -438,7 +504,7 @@ message about the whole chain of aliases."
(cons function
(cond
((autoloadp def) (nth 1 def))
- ((subrp def)
+ ((subr-primitive-p def)
(if lisp-only
(error "%s is a built-in function" function))
(help-C-file-name def 'subr))
@@ -483,12 +549,10 @@ otherwise uses `variable-at-point'."
(prompt-type (cdr (assq type '((nil . "function")
(defvar . "variable")
(defface . "face")))))
- (prompt (concat "Find " prompt-type
- (and symb (format " (default %s)" symb))
- ": "))
(enable-recursive-minibuffers t))
(list (intern (completing-read
- prompt obarray predicate
+ (format-prompt "Find %s" symb prompt-type)
+ obarray predicate
t nil nil (and symb (symbol-name symb)))))))
(defun find-function-do-it (symbol type switch-fn)
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index a245f6fe2e6..0e86b923c4a 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -1,4 +1,4 @@
-;;; float-sup.el --- define some constants useful for floating point numbers.
+;;; float-sup.el --- define some constants useful for floating point numbers. -*- lexical-binding:t -*-
;; Copyright (C) 1985-1987, 2001-2021 Free Software Foundation, Inc.
@@ -31,6 +31,7 @@
(with-suppressed-warnings ((lexical pi))
(defconst pi float-pi
"Obsolete since Emacs-23.3. Use `float-pi' instead."))
+(make-obsolete-variable 'pi 'float-pi "23.3")
(internal-make-var-non-special 'pi)
(defconst float-e (exp 1) "The value of e (2.7182818...).")
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index 13aec1e6785..4ae20ba4205 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -1,6 +1,6 @@
;;; generator.el --- generators -*- lexical-binding: t -*-
-;;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords: extensions, elisp
@@ -153,7 +153,7 @@ DYNAMIC-VAR bound to STATIC-VAR."
(defun cps--add-state (kind body)
"Create a new CPS state of KIND with BODY and return the state's name."
(declare (indent 1))
- (let* ((state (cps--gensym "cps-state-%s-" kind)))
+ (let ((state (cps--gensym "cps-state-%s-" kind)))
(push (list state body cps--cleanup-function) cps--states)
(push state cps--bindings)
state))
@@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun)
- (debug (&define name lambda-list lambda-doc def-body))
+ (debug (&define name lambda-list lambda-doc &rest sexp))
(doc-string 3))
(cl-assert lexical-binding)
(let* ((parsed-body (macroexp-parse-body body))
@@ -687,14 +687,14 @@ of values. Callers can retrieve each value using `iter-next'."
"Return a lambda generator.
`iter-lambda' is to `iter-defun' as `lambda' is to `defun'."
(declare (indent defun)
- (debug (&define lambda-list lambda-doc def-body)))
+ (debug (&define lambda-list lambda-doc &rest sexp)))
(cl-assert lexical-binding)
`(lambda ,arglist
,(cps-generate-evaluator body)))
(defmacro iter-make (&rest body)
"Return a new iterator."
- (declare (debug t))
+ (declare (debug (&rest sexp)))
(cps-generate-evaluator body))
(defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil))
@@ -720,22 +720,25 @@ is blocked."
Evaluate BODY with VAR bound to each value from ITERATOR.
Return the value with which ITERATOR finished iteration."
(declare (indent 1)
- (debug ((symbolp form) body)))
+ (debug ((symbolp form) &rest sexp)))
(let ((done-symbol (cps--gensym "iter-do-iterator-done"))
(condition-symbol (cps--gensym "iter-do-condition"))
(it-symbol (cps--gensym "iter-do-iterator"))
(result-symbol (cps--gensym "iter-do-result")))
- `(let (,var
- ,result-symbol
+ `(let (,result-symbol
(,done-symbol nil)
(,it-symbol ,iterator))
- (while (not ,done-symbol)
- (condition-case ,condition-symbol
- (setf ,var (iter-next ,it-symbol))
- (iter-end-of-sequence
- (setf ,result-symbol (cdr ,condition-symbol))
- (setf ,done-symbol t)))
- (unless ,done-symbol ,@body))
+ (while
+ (let ((,var
+ (condition-case ,condition-symbol
+ (iter-next ,it-symbol)
+ (iter-end-of-sequence
+ (setf ,result-symbol (cdr ,condition-symbol))
+ (setf ,done-symbol t)))))
+ (unless ,done-symbol
+ ,@body
+ ;; Loop until done-symbol is set.
+ t)))
,result-symbol)))
(defvar cl--loop-args)
diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el
index 56643906fbb..294aba66c3a 100644
--- a/lisp/emacs-lisp/generic.el
+++ b/lisp/emacs-lisp/generic.el
@@ -1,4 +1,4 @@
-;;; generic.el --- defining simple major modes with comment and font-lock
+;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;;
@@ -96,9 +96,8 @@
;; Internal Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar generic-font-lock-keywords nil
+(defvar-local generic-font-lock-keywords nil
"Keywords for `font-lock-defaults' in a generic mode.")
-(make-variable-buffer-local 'generic-font-lock-keywords)
;;;###autoload
(defvar generic-mode-list nil
@@ -116,6 +115,10 @@ instead (which see).")
function-list &optional docstring)
"Create a new generic mode MODE.
+A \"generic\" mode is a simple major mode with basic support for
+comment syntax and Font Lock mode, but otherwise does not have
+any special keystrokes or functionality available.
+
MODE is the name of the command for the generic mode; don't quote it.
The optional DOCSTRING is the documentation for the mode command. If
you do not supply it, `define-generic-mode' uses a default
@@ -241,7 +244,6 @@ Some generic modes are defined in `generic-x.el'."
"Set up comment functionality for generic mode."
(let ((chars nil)
(comstyles)
- (comstyle "")
(comment-start nil))
;; Go through all the comments.
@@ -265,14 +267,16 @@ Some generic modes are defined in `generic-x.el'."
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars)
(push (cons c1 (concat (cdr (assoc c1 chars))
- (concat "2" comstyle))) chars)))
+ (concat "2" comstyle)))
+ chars)))
(if (= (length end) 1)
(modify-syntax-entry (aref end 0)
(concat ">" comstyle) st)
(let ((c0 (aref end 0)) (c1 (aref end 1)))
;; Store the relevant info but don't update yet.
(push (cons c0 (concat (cdr (assoc c0 chars))
- (concat "3" comstyle))) chars)
+ (concat "3" comstyle)))
+ chars)
(push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars)))))
;; Process the chars that were part of a 2-char comment marker
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c9eac70d8f3..d6272a52469 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -135,7 +135,7 @@ The returned value will then be an Elisp expression that first evaluates
all the parts of PLACE that can be evaluated and then runs E.
\(fn (GETTER SETTER) PLACE &rest BODY)"
- (declare (indent 2) (debug (sexp form body)))
+ (declare (indent 2) (debug (sexp form def-body)))
`(gv-get ,place (lambda ,vars ,@body)))
;; Different ways to declare a generalized variable.
@@ -166,17 +166,34 @@ arguments as NAME. DO is a function as defined in `gv-get'."
;; (`(expand ,expander) `(gv-define-expand ,name ,expander))
(_ (message "Unknown %s declaration %S" symbol handler) nil))))
+;; Additions for `declare'. We specify the values as named aliases so
+;; that `describe-variable' prints something useful; cf. Bug#40491.
+
+;;;###autoload
+(defsubst gv--expander-defun-declaration (&rest args)
+ (apply #'gv--defun-declaration 'gv-expander args))
+
+;;;###autoload
+(defsubst gv--setter-defun-declaration (&rest args)
+ (apply #'gv--defun-declaration 'gv-setter args))
+
;;;###autoload
(or (assq 'gv-expander defun-declarations-alist)
- (let ((x `(gv-expander
- ,(apply-partially #'gv--defun-declaration 'gv-expander))))
+ (let ((x (list 'gv-expander #'gv--expander-defun-declaration)))
(push x macro-declarations-alist)
(push x defun-declarations-alist)))
;;;###autoload
(or (assq 'gv-setter defun-declarations-alist)
- (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter))
+ (push (list 'gv-setter #'gv--setter-defun-declaration)
defun-declarations-alist))
+;;;###autoload
+(let ((spec (get 'compiler-macro 'edebug-declaration-spec)))
+ ;; It so happens that it's the same spec for gv-* as for compiler-macros.
+ ;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))
+ (put 'gv-expander 'edebug-declaration-spec spec)
+ (put 'gv-setter 'edebug-declaration-spec spec))
+
;; (defmacro gv-define-expand (name expander)
;; "Use EXPANDER to handle NAME as a generalized var.
;; NAME is a symbol: the name of a function, macro, or special form.
@@ -214,7 +231,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression
which can do arbitrary things, whereas the other arguments are all guaranteed
to be pure and copyable. Example use:
(gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
- (declare (indent 2) (debug (&define name sexp def-body)))
+ (declare (indent 2)
+ (debug (&define [&name symbolp "@gv-setter"] sexp def-body)))
`(gv-define-expander ,name
(lambda (do &rest args)
(declare-function
@@ -297,7 +315,7 @@ The return value is the last VAL in the list.
;; Autoload this `put' since a user might use C-u C-M-x on an expression
;; containing a non-trivial `push' even before gv.el was loaded.
;;;###autoload
-(put 'gv-place 'edebug-form-spec 'edebug-match-form)
+(def-edebug-elem-spec 'gv-place '(form))
;; CL did the equivalent of:
;;(gv-define-macroexpand edebug-after (lambda (before index place) place))
@@ -406,6 +424,17 @@ The return value is the last VAL in the list.
`(delq ,p ,getter))))))
,v))))))))))
+(gv-define-expander plist-get
+ (lambda (do plist prop)
+ (macroexp-let2 macroexp-copyable-p key prop
+ (gv-letplace (getter setter) plist
+ (macroexp-let2 nil p `(cdr (plist-member ,getter ,key))
+ (funcall do
+ `(car ,p)
+ (lambda (val)
+ `(if ,p
+ (setcar ,p ,val)
+ ,(funcall setter `(cons ,key (cons ,val ,getter)))))))))))
;;; Some occasionally handy extensions.
@@ -482,6 +511,11 @@ The return value is the last VAL in the list.
(funcall do `(funcall (car ,gv))
(lambda (v) `(funcall (cdr ,gv) ,v))))))))
+(put 'error 'gv-expander
+ (lambda (do &rest args)
+ (funcall do `(error . ,args)
+ (lambda (v) `(progn ,v (error . ,args))))))
+
(defmacro gv-synthetic-place (getter setter)
"Special place described by its setter and getter.
GETTER and SETTER (typically obtained via `gv-letplace') get and
@@ -516,9 +550,12 @@ This macro only makes sense when used in a place."
(gv-letplace (dgetter dsetter) d
(funcall do
`(cons ,agetter ,dgetter)
- (lambda (v) `(progn
- ,(funcall asetter `(car ,v))
- ,(funcall dsetter `(cdr ,v)))))))))
+ (lambda (v)
+ (macroexp-let2 nil v v
+ `(progn
+ ,(funcall asetter `(car ,v))
+ ,(funcall dsetter `(cdr ,v))
+ ,v))))))))
(put 'logand 'gv-expander
(lambda (do place &rest masks)
@@ -528,9 +565,12 @@ This macro only makes sense when used in a place."
(funcall
do `(logand ,getter ,mask)
(lambda (v)
- (funcall setter
- `(logior (logand ,v ,mask)
- (logand ,getter (lognot ,mask))))))))))
+ (macroexp-let2 nil v v
+ `(progn
+ ,(funcall setter
+ `(logior (logand ,v ,mask)
+ (logand ,getter (lognot ,mask))))
+ ,v))))))))
;;; References
@@ -552,7 +592,7 @@ binding mode."
;; dynamic binding mode as well.
(eq (car-safe code) 'cons))
code
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
"Use of gv-ref probably requires lexical-binding"
code))))
@@ -574,5 +614,105 @@ REF must have been previously obtained with `gv-ref'."
;; (,(nth 1 vars) (v) (funcall ',setter v)))
;; ,@body)))
+;;; Generalized variables.
+
+;; Some Emacs-related place types.
+(gv-define-simple-setter buffer-file-name set-visited-file-name t)
+(gv-define-setter buffer-modified-p (flag &optional buf)
+ (macroexp-let2 nil buffer `(or ,buf (current-buffer))
+ `(with-current-buffer ,buffer
+ (set-buffer-modified-p ,flag))))
+(gv-define-simple-setter buffer-name rename-buffer t)
+(gv-define-setter buffer-string (store)
+ `(insert (prog1 ,store (erase-buffer))))
+(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
+(gv-define-simple-setter current-buffer set-buffer)
+(gv-define-simple-setter current-column move-to-column t)
+(gv-define-simple-setter current-global-map use-global-map t)
+(gv-define-setter current-input-mode (store)
+ `(progn (apply #'set-input-mode ,store) ,store))
+(gv-define-simple-setter current-local-map use-local-map t)
+(gv-define-simple-setter current-window-configuration
+ set-window-configuration t)
+(gv-define-simple-setter default-file-modes set-default-file-modes t)
+(gv-define-simple-setter documentation-property put)
+(gv-define-setter face-background (x f &optional s)
+ `(set-face-background ,f ,x ,s))
+(gv-define-setter face-background-pixmap (x f &optional s)
+ `(set-face-background-pixmap ,f ,x ,s))
+(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s))
+(gv-define-setter face-foreground (x f &optional s)
+ `(set-face-foreground ,f ,x ,s))
+(gv-define-setter face-underline-p (x f &optional s)
+ `(set-face-underline ,f ,x ,s))
+(gv-define-simple-setter file-modes set-file-modes t)
+(gv-define-setter frame-height (x &optional frame)
+ `(set-frame-height (or ,frame (selected-frame)) ,x))
+(gv-define-simple-setter frame-parameters modify-frame-parameters t)
+(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
+(gv-define-setter frame-width (x &optional frame)
+ `(set-frame-width (or ,frame (selected-frame)) ,x))
+(gv-define-simple-setter getenv setenv t)
+(gv-define-simple-setter get-register set-register)
+(gv-define-simple-setter global-key-binding global-set-key)
+(gv-define-simple-setter local-key-binding local-set-key)
+(gv-define-simple-setter mark set-mark t)
+(gv-define-simple-setter mark-marker set-mark t)
+(gv-define-simple-setter marker-position set-marker t)
+(gv-define-setter mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cadr ,store)
+ (cddr ,store)))
+(gv-define-simple-setter point goto-char)
+(gv-define-simple-setter point-marker goto-char t)
+(gv-define-setter point-max (store)
+ `(progn (narrow-to-region (point-min) ,store) ,store))
+(gv-define-setter point-min (store)
+ `(progn (narrow-to-region ,store (point-max)) ,store))
+(gv-define-setter read-mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cdr ,store)))
+(gv-define-simple-setter screen-height set-screen-height t)
+(gv-define-simple-setter screen-width set-screen-width t)
+(gv-define-simple-setter selected-window select-window)
+(gv-define-simple-setter selected-screen select-screen)
+(gv-define-simple-setter selected-frame select-frame)
+(gv-define-simple-setter standard-case-table set-standard-case-table)
+(gv-define-simple-setter syntax-table set-syntax-table)
+(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t)
+(gv-define-setter window-height (store)
+ `(progn (enlarge-window (- ,store (window-height))) ,store))
+(gv-define-setter window-width (store)
+ `(progn (enlarge-window (- ,store (window-width)) t) ,store))
+(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
+
+;; More complex setf-methods.
+
+;; 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.
+;; It turned out that :variable needed more flexibility anyway, so
+;; this doesn't seem too useful now.
+(gv-define-expander eq
+ (lambda (do place val)
+ (gv-letplace (getter setter) place
+ (macroexp-let2 nil val val
+ (funcall do `(eq ,getter ,val)
+ (lambda (v)
+ `(cond
+ (,v ,(funcall setter val))
+ ((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
+
+(gv-define-expander substring
+ (lambda (do place from &optional to)
+ (gv-letplace (getter setter) place
+ (macroexp-let2* nil ((start from) (end to))
+ (funcall do `(substring ,getter ,start ,end)
+ (lambda (v)
+ (macroexp-let2 nil v v
+ `(progn
+ ,(funcall setter `(cl--set-substring
+ ,getter ,start ,end ,v))
+ ,v))))))))
+
(provide 'gv)
;;; gv.el ends here
diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el
index 737f3ec2f33..a5f21a55924 100644
--- a/lisp/emacs-lisp/helper.el
+++ b/lisp/emacs-lisp/helper.el
@@ -1,4 +1,4 @@
-;;; helper.el --- utility help package supporting help in electric modes
+;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -39,20 +39,19 @@
;; keymap either.
-(defvar Helper-help-map nil)
-(if Helper-help-map
- nil
- (setq Helper-help-map (make-keymap))
- ;(fillarray Helper-help-map 'undefined)
- (define-key Helper-help-map "m" 'Helper-describe-mode)
- (define-key Helper-help-map "b" 'Helper-describe-bindings)
- (define-key Helper-help-map "c" 'Helper-describe-key-briefly)
- (define-key Helper-help-map "k" 'Helper-describe-key)
- ;(define-key Helper-help-map "f" 'Helper-describe-function)
- ;(define-key Helper-help-map "v" 'Helper-describe-variable)
- (define-key Helper-help-map "?" 'Helper-help-options)
- (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
- (fset 'Helper-help-map Helper-help-map))
+(defvar Helper-help-map
+ (let ((map (make-sparse-keymap)))
+ ;(fillarray map 'undefined)
+ (define-key map "m" 'Helper-describe-mode)
+ (define-key map "b" 'Helper-describe-bindings)
+ (define-key map "c" 'Helper-describe-key-briefly)
+ (define-key map "k" 'Helper-describe-key)
+ ;(define-key map "f" 'Helper-describe-function)
+ ;(define-key map "v" 'Helper-describe-variable)
+ (define-key map "?" 'Helper-help-options)
+ (define-key map (char-to-string help-char) 'Helper-help-options)
+ (fset 'Helper-help-map map)
+ map))
(defun Helper-help-scroller ()
(let ((blurb (or (and (boundp 'Helper-return-blurb)
diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el
new file mode 100644
index 00000000000..7466fc85df1
--- /dev/null
+++ b/lisp/emacs-lisp/hierarchy.el
@@ -0,0 +1,579 @@
+;;; hierarchy.el --- Library to create and display hierarchy structures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Damien Cassou <damien@cassou.me>
+;; Maintainer: emacs-devel@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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Library to create, query, navigate and display hierarchy structures.
+
+;; Creation: After having created a hierarchy with `hierarchy-new',
+;; populate it by calling `hierarchy-add-tree' or
+;; `hierarchy-add-trees'. You can then optionally sort its element
+;; with `hierarchy-sort'.
+
+;; Querying: You can learn more about your hierarchy by using
+;; functions such as `hierarchy-roots', `hierarchy-has-item',
+;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'.
+
+;; Navigation: When your hierarchy is ready, you can use
+;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply
+;; functions to elements of the hierarchy.
+
+;; Display: You can display a hierarchy as a tabulated list using
+;; `hierarchy-tabulated-display' and as an expandable/foldable tree
+;; using `hierarchy-convert-to-tree-widget'. The
+;; `hierarchy-labelfn-*' functions will help you display each item of
+;; the hierarchy the way you want it.
+
+;;; Limitation:
+
+;; - Current implementation uses #'equal to find and distinguish
+;; elements. Support for user-provided equality definition is
+;; desired but not yet implemented;
+;;
+;; - nil can't be added to a hierarchy;
+;;
+;; - the hierarchy is computed eagerly.
+
+;;; Code:
+
+(require 'seq)
+(require 'map)
+(require 'subr-x)
+(require 'cl-lib)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cl-defstruct (hierarchy
+ (:constructor hierarchy--make)
+ (:conc-name hierarchy--))
+ (roots (list)) ; list of the hierarchy roots (no parent)
+ (parents (make-hash-table :test 'equal)) ; map an item to its parent
+ (children (make-hash-table :test 'equal)) ; map an item to its childre
+ ;; cache containing the set of all items in the hierarchy
+ (seen-items (make-hash-table :test 'equal))) ; map an item to t
+
+(defun hierarchy--seen-items-add (hierarchy item)
+ "In HIERARCHY, add ITEM to seen items."
+ (map-put! (hierarchy--seen-items hierarchy) item t))
+
+(defun hierarchy--compute-roots (hierarchy)
+ "Search roots of HIERARCHY and return them."
+ (cl-set-difference
+ (map-keys (hierarchy--seen-items hierarchy))
+ (map-keys (hierarchy--parents hierarchy))
+ :test #'equal))
+
+(defun hierarchy--sort-roots (hierarchy sortfn)
+ "Compute, sort and store the roots of HIERARCHY.
+
+SORTFN is a function taking two items of the hierarchy as parameter and
+returning non-nil if the first parameter is lower than the second."
+ (setf (hierarchy--roots hierarchy)
+ (sort (hierarchy--compute-roots hierarchy)
+ sortfn)))
+
+(defun hierarchy--add-relation (hierarchy item parent acceptfn)
+ "In HIERARCHY, add ITEM as child of PARENT.
+
+ACCEPTFN is a function returning non-nil if its parameter (any object)
+should be an item of the hierarchy."
+ (let* ((existing-parent (hierarchy-parent hierarchy item))
+ (has-parent-p (funcall acceptfn existing-parent)))
+ (cond
+ ((and has-parent-p (not (equal existing-parent parent)))
+ (error "An item (%s) can only have one parent: '%s' vs '%s'"
+ item existing-parent parent))
+ ((not has-parent-p)
+ (let ((existing-children (map-elt (hierarchy--children hierarchy)
+ parent (list))))
+ (map-put! (hierarchy--children hierarchy)
+ parent (append existing-children (list item))))
+ (map-put! (hierarchy--parents hierarchy) item parent)))))
+
+(defun hierarchy--set-equal (list1 list2 &rest cl-keys)
+ "Return non-nil if LIST1 and LIST2 have same elements.
+
+I.e., if every element of LIST1 also appears in LIST2 and if
+every element of LIST2 also appears in LIST1.
+
+CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported
+keys are :key and :test."
+ (and (apply 'cl-subsetp list1 list2 cl-keys)
+ (apply 'cl-subsetp list2 list1 cl-keys)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Creation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-new ()
+ "Create a hierarchy and return it."
+ (hierarchy--make))
+
+(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn)
+ "In HIERARCHY, add ITEM.
+
+PARENTFN is either nil or a function defining the child-to-parent
+relationship: this function takes an item as parameter and should return
+the parent of this item in the hierarchy. If the item has no parent in the
+hierarchy (i.e., it should be a root), the function should return an object
+not accepted by acceptfn (i.e., nil for the default value of acceptfn).
+
+CHILDRENFN is either nil or a function defining the parent-to-children
+relationship: this function takes an item as parameter and should return a
+list of children of this item in the hierarchy.
+
+If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and
+CHILDRENFN are expected to be coherent with each other.
+
+ACCEPTFN is a function returning non-nil if its parameter (any object)
+should be an item of the hierarchy. By default, ACCEPTFN returns non-nil
+if its parameter is non-nil."
+ (unless (hierarchy-has-item hierarchy item)
+ (let ((acceptfn (or acceptfn #'identity)))
+ (hierarchy--seen-items-add hierarchy item)
+ (let ((parent (and parentfn (funcall parentfn item))))
+ (when (funcall acceptfn parent)
+ (hierarchy--add-relation hierarchy item parent acceptfn)
+ (hierarchy-add-tree hierarchy parent parentfn childrenfn)))
+ (let ((children (and childrenfn (funcall childrenfn item))))
+ (mapc (lambda (child)
+ (when (funcall acceptfn child)
+ (hierarchy--add-relation hierarchy child item acceptfn)
+ (hierarchy-add-tree hierarchy child parentfn childrenfn)))
+ children)))))
+
+(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn)
+ "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS.
+
+PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'."
+ (seq-map (lambda (item)
+ (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn))
+ items))
+
+(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn)
+ "Add to HIERARCHY the sub-lists in LIST.
+
+If WRAP is non-nil, allow duplicate items in LIST by wraping each
+item in a cons (id . item). The root's id is 1.
+
+CHILDRENFN is a function (defaults to `cdr') taking LIST as a
+parameter which should return LIST's children (a list). Each
+child is (recursively) passed as a parameter to CHILDRENFN to get
+its own children. Because of this parameter, LIST can be
+anything, not necessarily a list."
+ (let* ((childrenfn (or childrenfn #'cdr))
+ (id 0)
+ (wrapfn (lambda (item)
+ (if wrap
+ (cons (setq id (1+ id)) item)
+ item)))
+ (unwrapfn (if wrap #'cdr #'identity)))
+ (hierarchy-add-tree
+ hierarchy (funcall wrapfn list) nil
+ (lambda (item)
+ (mapcar wrapfn (funcall childrenfn
+ (funcall unwrapfn item)))))
+ hierarchy))
+
+(defun hierarchy-from-list (list &optional wrap childrenfn)
+ "Create and return a hierarchy built from LIST.
+
+This function passes LIST, WRAP and CHILDRENFN unchanged to
+`hierarchy-add-list'."
+ (hierarchy-add-list (hierarchy-new) list wrap childrenfn))
+
+(defun hierarchy-sort (hierarchy &optional sortfn)
+ "Modify HIERARCHY so that its roots and item's children are sorted.
+
+SORTFN is a function taking two items of the hierarchy as parameter and
+returning non-nil if the first parameter is lower than the second. By
+default, SORTFN is `string-lessp'."
+ (let ((sortfn (or sortfn #'string-lessp)))
+ (hierarchy--sort-roots hierarchy sortfn)
+ (mapc (lambda (parent)
+ (setf
+ (map-elt (hierarchy--children hierarchy) parent)
+ (sort (map-elt (hierarchy--children hierarchy) parent) sortfn)))
+ (map-keys (hierarchy--children hierarchy)))))
+
+(defun hierarchy-extract-tree (hierarchy item)
+ "Return a copy of HIERARCHY with ITEM's descendants and parents."
+ (if (not (hierarchy-has-item hierarchy item))
+ nil
+ (let ((tree (hierarchy-new)))
+ (hierarchy-add-tree tree item
+ (lambda (each) (hierarchy-parent hierarchy each))
+ (lambda (each)
+ (when (or (equal each item)
+ (hierarchy-descendant-p hierarchy each item))
+ (hierarchy-children hierarchy each))))
+ tree)))
+
+(defun hierarchy-copy (hierarchy)
+ "Return a copy of HIERARCHY.
+
+Items in HIERARCHY are shared, but structure is not."
+ (hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Querying
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-items (hierarchy)
+ "Return a list of all items of HIERARCHY."
+ (map-keys (hierarchy--seen-items hierarchy)))
+
+(defun hierarchy-has-item (hierarchy item)
+ "Return t if HIERARCHY includes ITEM."
+ (map-contains-key (hierarchy--seen-items hierarchy) item))
+
+(defun hierarchy-empty-p (hierarchy)
+ "Return t if HIERARCHY is empty."
+ (= 0 (hierarchy-length hierarchy)))
+
+(defun hierarchy-length (hierarchy)
+ "Return the number of items in HIERARCHY."
+ (hash-table-count (hierarchy--seen-items hierarchy)))
+
+(defun hierarchy-has-root (hierarchy item)
+ "Return t if one of HIERARCHY's roots is ITEM.
+
+A root is an item with no parent."
+ (seq-contains-p (hierarchy-roots hierarchy) item))
+
+(defun hierarchy-roots (hierarchy)
+ "Return all roots of HIERARCHY.
+
+A root is an item with no parent."
+ (let ((roots (hierarchy--roots hierarchy)))
+ (or roots
+ (hierarchy--compute-roots hierarchy))))
+
+(defun hierarchy-leafs (hierarchy &optional node)
+ "Return all leafs of HIERARCHY.
+
+A leaf is an item with no child.
+
+If NODE is an item of HIERARCHY, only return leafs under NODE."
+ (let ((leafs (cl-set-difference
+ (map-keys (hierarchy--seen-items hierarchy))
+ (map-keys (hierarchy--children hierarchy)))))
+ (if (hierarchy-has-item hierarchy node)
+ (seq-filter (lambda (item)
+ (hierarchy-descendant-p hierarchy item node))
+ leafs)
+ leafs)))
+
+(defun hierarchy-parent (hierarchy item)
+ "In HIERARCHY, return parent of ITEM."
+ (map-elt (hierarchy--parents hierarchy) item))
+
+(defun hierarchy-children (hierarchy parent)
+ "In HIERARCHY, return children of PARENT."
+ (map-elt (hierarchy--children hierarchy) parent (list)))
+
+(defun hierarchy-child-p (hierarchy item1 item2)
+ "In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2."
+ (equal (hierarchy-parent hierarchy item1) item2))
+
+(defun hierarchy-descendant-p (hierarchy item1 item2)
+ "In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2.
+
+ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY
+and either:
+
+- ITEM1 is child of ITEM2, or
+- ITEM1's parent is a descendant of ITEM2."
+ (and
+ (hierarchy-has-item hierarchy item1)
+ (hierarchy-has-item hierarchy item2)
+ (or
+ (hierarchy-child-p hierarchy item1 item2)
+ (hierarchy-descendant-p
+ hierarchy (hierarchy-parent hierarchy item1) item2))))
+
+(defun hierarchy-equal (hierarchy1 hierarchy2)
+ "Return t if HIERARCHY1 and HIERARCHY2 are equal.
+
+Two equal hierarchies share the same items and the same
+relationships among them."
+ (and (hierarchy-p hierarchy1)
+ (hierarchy-p hierarchy2)
+ (= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2))
+ ;; parents are the same
+ (seq-every-p (lambda (child)
+ (equal (hierarchy-parent hierarchy1 child)
+ (hierarchy-parent hierarchy2 child)))
+ (map-keys (hierarchy--parents hierarchy1)))
+ ;; children are the same
+ (seq-every-p (lambda (parent)
+ (hierarchy--set-equal
+ (hierarchy-children hierarchy1 parent)
+ (hierarchy-children hierarchy2 parent)
+ :test #'equal))
+ (map-keys (hierarchy--children hierarchy1)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Navigation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-map-item (func item hierarchy &optional indent)
+ "Return the result of applying FUNC to ITEM and its descendants in HIERARCHY.
+
+This function navigates the tree top-down: FUNCTION is first called on item
+and then on each of its children. Results are concatenated in a list.
+
+INDENT is a number (default 0) representing the indentation of ITEM in
+HIERARCHY. FUNC should take 2 argument: the item and its indentation
+level."
+ (let ((indent (or indent 0)))
+ (cons
+ (funcall func item indent)
+ (seq-mapcat (lambda (child) (hierarchy-map-item func child
+ hierarchy (1+ indent)))
+ (hierarchy-children hierarchy item)))))
+
+(defun hierarchy-map (func hierarchy &optional indent)
+ "Return the result of applying FUNC to each element of HIERARCHY.
+
+This function navigates the tree top-down: FUNCTION is first called on each
+root. To do so, it calls `hierarchy-map-item' on each root
+sequentially. Results are concatenated in a list.
+
+FUNC should take 2 arguments: the item and its indentation level.
+
+INDENT is a number (default 0) representing the indentation of HIERARCHY's
+roots."
+ (let ((indent (or indent 0)))
+ (seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent))
+ (hierarchy-roots hierarchy))))
+
+(defun hierarchy-map-tree (function hierarchy &optional item indent)
+ "Apply FUNCTION on each item of HIERARCHY under ITEM.
+
+This function navigates the tree bottom-up: FUNCTION is first called on
+leafs and the result is passed as parameter when calling FUNCTION on
+parents.
+
+FUNCTION should take 3 parameters: the current item, its indentation
+level (a number), and a list representing the result of applying
+`hierarchy-map-tree' to each child of the item.
+
+INDENT is 0 by default and is passed as second parameter to FUNCTION.
+INDENT is incremented by 1 at each level of the tree.
+
+This function returns the result of applying FUNCTION to ITEM (the first
+root if nil)."
+ (let ((item (or item (car (hierarchy-roots hierarchy))))
+ (indent (or indent 0)))
+ (funcall function item indent
+ (mapcar (lambda (child)
+ (hierarchy-map-tree function hierarchy
+ child (1+ indent)))
+ (hierarchy-children hierarchy item)))))
+
+(defun hierarchy-map-hierarchy (function hierarchy)
+ "Apply FUNCTION to each item of HIERARCHY in a new hierarchy.
+
+FUNCTION should take 2 parameters, the current item and its
+indentation level (a number), and should return an item to be
+added to the new hierarchy."
+ (let* ((items (make-hash-table :test #'equal))
+ (transform (lambda (item) (map-elt items item))))
+ ;; Make 'items', a table mapping original items to their
+ ;; transformation
+ (hierarchy-map (lambda (item indent)
+ (map-put! items item (funcall function item indent)))
+ hierarchy)
+ (hierarchy--make
+ :roots (mapcar transform (hierarchy-roots hierarchy))
+ :parents (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (child parent)
+ (map-put! result
+ (funcall transform child)
+ (funcall transform parent)))
+ (hierarchy--parents hierarchy))
+ result)
+ :children (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (parent children)
+ (map-put! result
+ (funcall transform parent)
+ (seq-map transform children)))
+ (hierarchy--children hierarchy))
+ result)
+ :seen-items (let ((result (make-hash-table :test #'equal)))
+ (map-apply (lambda (item v)
+ (map-put! result
+ (funcall transform item)
+ v))
+ (hierarchy--seen-items hierarchy))
+ result))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Display
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun hierarchy-labelfn-indent (labelfn &optional indent-string)
+ "Return a function rendering LABELFN indented with INDENT-STRING.
+
+INDENT-STRING defaults to a 2-space string. Indentation is
+multiplied by the depth of the displayed item."
+ (let ((indent-string (or indent-string " ")))
+ (lambda (item indent)
+ (dotimes (_ indent) (insert indent-string))
+ (funcall labelfn item indent))))
+
+(defun hierarchy-labelfn-button (labelfn actionfn)
+ "Return a function rendering LABELFN in a button.
+
+Clicking the button triggers ACTIONFN. ACTIONFN is a function
+taking an item of HIERARCHY and an indentation value (a number)
+as input. This function is called when an item is clicked. The
+return value of ACTIONFN is ignored."
+ (lambda (item indent)
+ (let ((start (point)))
+ (funcall labelfn item indent)
+ (make-text-button start (point)
+ 'action (lambda (_) (funcall actionfn item indent))))))
+
+(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn)
+ "Return a function rendering LABELFN as a button if BUTTONP.
+
+Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if
+BUTTONP is non-nil. Otherwise, render LABELFN without making it
+a button.
+
+BUTTONP is a function taking an item of HIERARCHY and an
+indentation value (a number) as input."
+ (lambda (item indent)
+ (if (funcall buttonp item indent)
+ (funcall (hierarchy-labelfn-button labelfn actionfn) item indent)
+ (funcall labelfn item indent))))
+
+(defun hierarchy-labelfn-to-string (labelfn item indent)
+ "Execute LABELFN on ITEM and INDENT. Return result as a string."
+ (with-temp-buffer
+ (funcall labelfn item indent)
+ (buffer-substring (point-min) (point-max))))
+
+(defun hierarchy-print (hierarchy &optional to-string)
+ "Insert HIERARCHY in current buffer as plain text.
+
+Use TO-STRING to convert each element to a string. TO-STRING is
+a function taking an item of HIERARCHY as input and returning a
+string. If nil, TO-STRING defaults to a call to `format' with \"%s\"."
+ (let ((to-string (or to-string (lambda (item) (format "%s" item)))))
+ (hierarchy-map
+ (hierarchy-labelfn-indent (lambda (item _)
+ (insert (funcall to-string item) "\n")))
+ hierarchy)))
+
+(defun hierarchy-to-string (hierarchy &optional to-string)
+ "Return a string representing HIERARCHY.
+
+TO-STRING is passed unchanged to `hierarchy-print'."
+ (with-temp-buffer
+ (hierarchy-print hierarchy to-string)
+ (buffer-substring (point-min) (point-max))))
+
+(defun hierarchy-tabulated-imenu-action (_item-name position)
+ "Move to ITEM-NAME at POSITION in current buffer."
+ (goto-char position)
+ (back-to-indentation))
+
+(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy tabulated"
+ "Major mode to display a hierarchy as a tabulated list."
+ (setq-local imenu-generic-expression
+ ;; debbugs: 26457 - Cannot pass a function to
+ ;; imenu-generic-expression. Add
+ ;; `hierarchy-tabulated-imenu-action' to the end of the
+ ;; list when bug is fixed
+ '(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1))))
+
+(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer)
+ "Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'.
+
+LABELFN is a function taking an item of HIERARCHY and an indentation
+level (a number) as input and inserting a string to be displayed in the
+table.
+
+The tabulated list is displayed in BUFFER, or a newly created buffer if
+nil. The buffer is returned."
+ (let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated"))))
+ (with-current-buffer buffer
+ (hierarchy-tabulated-mode)
+ (setq tabulated-list-format
+ (vector '("Item name" 0 nil)))
+ (setq tabulated-list-entries
+ (hierarchy-map (lambda (item indent)
+ (list item (vector (hierarchy-labelfn-to-string
+ labelfn item indent))))
+ hierarchy))
+ (tabulated-list-init-header)
+ (tabulated-list-print))
+ buffer))
+
+(declare-function widget-convert "wid-edit")
+(defun hierarchy-convert-to-tree-widget (hierarchy labelfn)
+ "Return a tree-widget for HIERARCHY.
+
+LABELFN is a function taking an item of HIERARCHY and an indentation
+value (a number) as parameter and inserting a string to be displayed as a
+node label."
+ (require 'wid-edit)
+ (require 'tree-widget)
+ (hierarchy-map-tree (lambda (item indent children)
+ (widget-convert
+ 'tree-widget
+ :tag (hierarchy-labelfn-to-string labelfn item indent)
+ :args children))
+ hierarchy))
+
+(defun hierarchy-tree-display (hierarchy labelfn &optional buffer)
+ "Display HIERARCHY as a tree widget in a new buffer.
+
+HIERARCHY and LABELFN are passed unchanged to
+`hierarchy-convert-to-tree-widget'.
+
+The tree widget is displayed in BUFFER, or a newly created buffer if
+nil. The buffer is returned."
+ (let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*")))
+ (tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn)))
+ (with-current-buffer buffer
+ (setq-local buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (widget-create tree-widget)
+ (goto-char (point-min))
+ (special-mode)))
+ buffer))
+
+(provide 'hierarchy)
+
+;;; hierarchy.el ends here
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index d6106fe35d0..36d71a8c04d 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -262,7 +262,7 @@ See Info node `(elisp)Defining Functions' for more details."
'(throw 'inline--just-use
;; FIXME: This would inf-loop by calling us right back when
;; macroexpand-all recurses to expand inline--form.
- ;; (macroexp--warn-and-return (format ,@args)
+ ;; (macroexp-warn-and-return (format ,@args)
;; inline--form)
inline--form))
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 9cba232e16f..83da495edf0 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -109,11 +109,6 @@
;; * Footer line --- marks end-of-file so it can be distinguished from
;; an expanded formfeed or the results of truncation.
-;;; Change Log:
-
-;; Tue Jul 14 23:44:17 1992 ESR
-;; * Created.
-
;;; Code:
;;; Variables:
@@ -208,6 +203,7 @@ a section."
(when start
(save-excursion
(goto-char start)
+ (looking-at outline-regexp)
(let ((level (lisp-outline-level))
(case-fold-search t)
next-section-found)
@@ -218,6 +214,7 @@ a section."
nil t))
(> (save-excursion
(beginning-of-line)
+ (looking-at outline-regexp)
(lisp-outline-level))
level)))
(min (if next-section-found
@@ -363,10 +360,10 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")"
"Split up an email address X into full name and real email address.
The value is a cons of the form (FULLNAME . ADDRESS)."
(cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
- (cons (match-string 1 x)
+ (cons (string-trim-right (match-string 1 x))
(match-string 2 x)))
((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
- (cons (match-string 2 x)
+ (cons (string-trim-right (match-string 2 x))
(match-string 1 x)))
((string-match "\\S-+@\\S-+" x)
(cons nil x))
@@ -381,14 +378,22 @@ the cdr is an email address."
(let ((authorlist (lm-header-multiline "author")))
(mapcar #'lm-crack-address authorlist))))
+(defun lm-maintainers (&optional file)
+ "Return the maintainer list of file FILE, or current buffer if FILE is nil.
+If the maintainers are unspecified, then return the authors.
+Each element of the list is a cons; the car is the full name,
+the cdr is an email address."
+ (lm-with-file file
+ (mapcar #'lm-crack-address
+ (or (lm-header-multiline "maintainer")
+ (lm-header-multiline "author")))))
+
(defun lm-maintainer (&optional file)
"Return the maintainer of file FILE, or current buffer if FILE is nil.
+If the maintainer is unspecified, then return the author.
The return value has the form (NAME . ADDRESS)."
- (lm-with-file file
- (let ((maint (lm-header "maintainer")))
- (if maint
- (lm-crack-address maint)
- (car (lm-authors))))))
+ (declare (obsolete lm-maintainers "28.1"))
+ (car (lm-maintainers file)))
(defun lm-creation-date (&optional file)
"Return the created date given in file FILE, or current buffer if FILE is nil."
@@ -485,7 +490,18 @@ absent, return nil."
(lm-with-file file
(let ((start (lm-commentary-start)))
(when start
- (buffer-substring-no-properties start (lm-commentary-end))))))
+ (replace-regexp-in-string ; Get rid of...
+ "[[:blank:]]*$" "" ; trailing white-space
+ (replace-regexp-in-string
+ (format "%s\\|%s\\|%s"
+ ;; commentary header
+ (concat "^;;;[[:blank:]]*\\("
+ lm-commentary-header
+ "\\):[[:blank:]\n]*")
+ "^;;[[:blank:]]?" ; double semicolon prefix
+ "[[:blank:]\n]*\\'") ; trailing new-lines
+ "" (buffer-substring-no-properties
+ start (lm-commentary-end))))))))
(defun lm-homepage (&optional file)
"Return the homepage in file FILE, or current buffer if FILE is nil."
@@ -537,7 +553,7 @@ copyright notice is allowed."
"Can't find package name")
((not (lm-authors))
"`Author:' tag missing")
- ((not (lm-maintainer))
+ ((not (lm-maintainers))
"`Maintainer:' tag missing")
((not (lm-summary))
"Can't find the one-line summary description")
@@ -605,7 +621,7 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer."
(interactive "sBug Subject: ")
(require 'emacsbug)
(let ((package (lm-get-package-name))
- (addr (lm-maintainer))
+ (addr (car (lm-maintainers)))
(version (lm-version)))
(compose-mail (if addr
(concat (car addr) " <" (cdr addr) ">")
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index ec76d805e59..51fb88502ab 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -38,7 +38,7 @@
(define-abbrev-table 'lisp-mode-abbrev-table ()
"Abbrev table for Lisp mode.")
-(defvar lisp--mode-syntax-table
+(defvar lisp-data-mode-syntax-table
(let ((table (make-syntax-table))
(i 0))
(while (< i ?0)
@@ -62,9 +62,6 @@
(modify-syntax-entry ?\t " " table)
(modify-syntax-entry ?\f " " table)
(modify-syntax-entry ?\n "> " table)
- ;; This is probably obsolete since nowadays such features use overlays.
- ;; ;; Give CR the same syntax as newline, for selective-display.
- ;; (modify-syntax-entry ?\^m "> " table)
(modify-syntax-entry ?\; "< " table)
(modify-syntax-entry ?` "' " table)
(modify-syntax-entry ?' "' " table)
@@ -77,11 +74,13 @@
(modify-syntax-entry ?\\ "\\ " table)
(modify-syntax-entry ?\( "() " table)
(modify-syntax-entry ?\) ")( " table)
+ (modify-syntax-entry ?\[ "(]" table)
+ (modify-syntax-entry ?\] ")[" table)
table)
"Parent syntax table used in Lisp modes.")
(defvar lisp-mode-syntax-table
- (let ((table (make-syntax-table lisp--mode-syntax-table)))
+ (let ((table (make-syntax-table lisp-data-mode-syntax-table)))
(modify-syntax-entry ?\[ "_ " table)
(modify-syntax-entry ?\] "_ " table)
(modify-syntax-entry ?# "' 14" table)
@@ -178,13 +177,16 @@
(defun lisp--match-hidden-arg (limit)
(let ((res nil))
+ (forward-line 0)
(while
- (let ((ppss (parse-partial-sexp (line-beginning-position)
+ (let ((ppss (parse-partial-sexp (point)
(line-end-position)
-1)))
(skip-syntax-forward " )")
(if (or (>= (car ppss) 0)
- (looking-at ";\\|$"))
+ (eolp)
+ (looking-at ";")
+ (nth 8 (syntax-ppss))) ;Within a string or comment.
(progn
(forward-line 1)
(< (point) limit))
@@ -196,39 +198,53 @@
(defun lisp--el-non-funcall-position-p (pos)
"Heuristically determine whether POS is an evaluated position."
+ (declare (obsolete lisp--el-funcall-position-p "28.1"))
+ (not (lisp--el-funcall-position-p pos)))
+
+(defun lisp--el-funcall-position-p (pos)
+ "Heuristically determine whether POS is an evaluated position."
(save-match-data
(save-excursion
(ignore-errors
(goto-char pos)
- (or (eql (char-before) ?\')
- (let* ((ppss (syntax-ppss))
- (paren-posns (nth 9 ppss))
- (parent
- (when paren-posns
- (goto-char (car (last paren-posns))) ;(up-list -1)
- (cond
- ((ignore-errors
- (and (eql (char-after) ?\()
- (when (cdr paren-posns)
- (goto-char (car (last paren-posns 2)))
- (looking-at "(\\_<let\\*?\\_>"))))
- (goto-char (match-end 0))
- 'let)
- ((looking-at
- (rx "("
- (group-n 1 (+ (or (syntax w) (syntax _))))
- symbol-end))
- (prog1 (intern-soft (match-string-no-properties 1))
- (goto-char (match-end 1))))))))
- (or (eq parent 'declare)
- (and (eq parent 'let)
- (progn
- (forward-sexp 1)
- (< pos (point))))
- (and (eq parent 'condition-case)
- (progn
- (forward-sexp 2)
- (< (point) pos))))))))))
+ ;; '(lambda ..) is not a funcall position, but #'(lambda ...) is.
+ (if (eql (char-before) ?\')
+ (eql (char-before (1- (point))) ?#)
+ (let* ((ppss (syntax-ppss))
+ (paren-posns (nth 9 ppss))
+ (parent
+ (when paren-posns
+ (goto-char (car (last paren-posns))) ;(up-list -1)
+ (cond
+ ((ignore-errors
+ (and (eql (char-after) ?\()
+ (when (cdr paren-posns)
+ (goto-char (car (last paren-posns 2)))
+ (looking-at "(\\_<let\\*?\\_>"))))
+ (goto-char (match-end 0))
+ 'let)
+ ((looking-at
+ (rx "("
+ (group-n 1 (+ (or (syntax w) (syntax _))))
+ symbol-end))
+ (prog1 (intern-soft (match-string-no-properties 1))
+ (goto-char (match-end 1))))))))
+ (pcase parent
+ ('declare nil)
+ ('let
+ (forward-sexp 1)
+ (>= pos (point)))
+ ('condition-case
+ ;; If (cdr paren-posns), then we're in the BODY
+ ;; of HANDLERS.
+ (or (cdr paren-posns)
+ (progn
+ (forward-sexp 1)
+ ;; If we're in the second form, then we're in
+ ;; a funcall position.
+ (< (point) pos (progn (forward-sexp 1)
+ (point))))))
+ (_ t))))))))
(defun lisp--el-match-keyword (limit)
;; FIXME: Move to elisp-mode.el.
@@ -238,11 +254,9 @@
(concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>"))
limit t)
(let ((sym (intern-soft (match-string 1))))
- (when (or (special-form-p sym)
- (and (macrop sym)
- (not (get sym 'no-font-lock-keyword))
- (not (lisp--el-non-funcall-position-p
- (match-beginning 0)))))
+ (when (and (or (special-form-p sym) (macrop sym))
+ (not (get sym 'no-font-lock-keyword))
+ (lisp--el-funcall-position-p (match-beginning 0)))
(throw 'found t))))))
(defmacro let-when-compile (bindings &rest body)
@@ -449,14 +463,13 @@ This will generate compile-time constants from BINDINGS."
("\\(\\\\\\)\\([^\"\\]\\)"
(1 (elisp--font-lock-backslash) prepend))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Constant values.
(,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>")
(0 font-lock-builtin-face))
;; ELisp and CLisp `&' keywords as types.
- (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>")
+ (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>")
. font-lock-type-face)
;; ELisp regexp grouping constructs
(,(lambda (bound)
@@ -476,7 +489,8 @@ This will generate compile-time constants from BINDINGS."
(3 'font-lock-regexp-grouping-construct prepend))
(lisp--match-hidden-arg
(0 '(face font-lock-warning-face
- help-echo "Hidden behind deeper element; move to another line?")))
+ help-echo "Easy to misread; consider moving the element to the next line")
+ prepend))
(lisp--match-confusable-symbol-character
0 '(face font-lock-warning-face
help-echo "Confusable character"))
@@ -499,30 +513,28 @@ This will generate compile-time constants from BINDINGS."
(,(concat "(" cl-errs-re "\\_>")
(1 font-lock-warning-face))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Uninterned symbols, e.g., (defpackage #:my-package ...)
;; must come before keywords below to have effect
- (,(concat "\\(#:\\)\\(" lisp-mode-symbol-regexp "\\)")
- (1 font-lock-comment-delimiter-face)
- (2 font-lock-doc-face))
+ (,(concat "#:" lisp-mode-symbol-regexp "") 0 font-lock-builtin-face)
;; Constant values.
(,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>")
(0 font-lock-builtin-face))
;; ELisp and CLisp `&' keywords as types.
- (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>")
+ (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>")
. font-lock-type-face)
;; This is too general -- rms.
;; A user complained that he has functions whose names start with `do'
;; and that they get the wrong color.
- ;; That user has violated the http://www.cliki.net/Naming+conventions:
+ ;; That user has violated the https://www.cliki.net/Naming+conventions:
;; CL (but not EL!) `with-' (context) and `do-' (iteration)
(,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)")
(1 font-lock-keyword-face))
(lisp--match-hidden-arg
(0 '(face font-lock-warning-face
- help-echo "Hidden behind deeper element; move to another line?")))
+ help-echo "Easy to misread; consider moving the element to the next line")
+ prepend))
))
"Gaudy level highlighting for Lisp modes.")))
@@ -611,6 +623,8 @@ Value for `adaptive-fill-function'."
;; a single docstring. Let's fix it here.
(if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") ""))
+;; Maybe this should be discouraged/obsoleted and users should be
+;; encouraged to use `lisp-data-mode` instead.
(defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive
elisp)
"Common initialization routine for lisp modes.
@@ -627,7 +641,7 @@ font-lock keywords will not be case sensitive."
;; and should make no difference for explicit fill
;; because lisp-fill-paragraph should do the job.
;; I believe that newcomment's auto-fill code properly deals with it -stef
- ;;(set (make-local-variable 'adaptive-fill-mode) nil)
+ ;;(setq-local adaptive-fill-mode nil)
(setq-local indent-line-function 'lisp-indent-line)
(setq-local indent-region-function 'lisp-indent-region)
(setq-local comment-indent-function #'lisp-comment-indent)
@@ -658,12 +672,26 @@ font-lock keywords will not be case sensitive."
(setq-local electric-pair-skip-whitespace 'chomp)
(setq-local electric-pair-open-newline-between-pairs nil))
+;;;###autoload
+(define-derived-mode lisp-data-mode prog-mode "Lisp-Data"
+ "Major mode for buffers holding data written in Lisp syntax."
+ :group 'lisp
+ (lisp-mode-variables nil t nil)
+ (setq-local electric-quote-string t)
+ (setq imenu-case-fold-search nil))
+
(defun lisp-outline-level ()
"Lisp mode `outline-level' function."
+ ;; Expects outline-regexp is ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|("
+ ;; and point is at the beginning of a matching line.
(let ((len (- (match-end 0) (match-beginning 0))))
- (if (looking-at "(\\|;;;###autoload")
- 1000
- len)))
+ (cond ((looking-at "(\\|;;;###autoload")
+ 1000)
+ ((looking-at ";;\\(;+\\) ")
+ (- (match-end 1) (match-beginning 1)))
+ ;; Above should match everything but just in case.
+ (t
+ len))))
(defun lisp-current-defun-name ()
"Return the name of the defun at point, or nil."
@@ -718,27 +746,26 @@ font-lock keywords will not be case sensitive."
;;; Generic Lisp mode.
(defvar lisp-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Lisp")))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\C-x" 'lisp-eval-defun)
(define-key map "\C-c\C-z" 'run-lisp)
- (bindings--define-key map [menu-bar lisp] (cons "Lisp" menu-map))
- (bindings--define-key menu-map [run-lisp]
- '(menu-item "Run inferior Lisp" run-lisp
- :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"))
- (bindings--define-key menu-map [ev-def]
- '(menu-item "Eval defun" lisp-eval-defun
- :help "Send the current defun to the Lisp process made by M-x run-lisp"))
- (bindings--define-key menu-map [ind-sexp]
- '(menu-item "Indent sexp" indent-sexp
- :help "Indent each line of the list starting just after point"))
map)
"Keymap for ordinary Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
-(define-derived-mode lisp-mode prog-mode "Lisp"
- "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
+(easy-menu-define lisp-mode-menu lisp-mode-map
+ "Menu for ordinary Lisp mode."
+ '("Lisp"
+ ["Indent sexp" indent-sexp
+ :help "Indent each line of the list starting just after point"]
+ ["Eval defun" lisp-eval-defun
+ :help "Send the current defun to the Lisp process made by M-x run-lisp"]
+ ["Run inferior Lisp" run-lisp
+ :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"]))
+
+(define-derived-mode lisp-mode lisp-data-mode "Lisp"
+ "Major mode for editing programs in Common Lisp and other similar Lisps.
Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs. Semicolons start comments.
@@ -746,10 +773,12 @@ Blank lines separate paragraphs. Semicolons start comments.
\\{lisp-mode-map}
Note that `run-lisp' may be used either to start an inferior Lisp job
or to switch back to an existing one."
- (lisp-mode-variables nil t)
+ (setq-local lisp-indent-function 'common-lisp-indent-function)
(setq-local find-tag-default-function 'lisp-find-tag-default)
(setq-local comment-start-skip
- "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
+ "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
+ (setq-local comment-end-skip "[ \t]*\\(\\s>\\||#\\)")
+ (setq-local font-lock-comment-end-skip "|#")
(setq imenu-case-fold-search t))
(defun lisp-find-tag-default ()
@@ -775,8 +804,6 @@ or to switch back to an existing one."
nil)))
(comment-indent-default)))
-(define-obsolete-function-alias 'lisp-mode-auto-fill 'do-auto-fill "23.1")
-
(defcustom lisp-indent-offset nil
"If non-nil, indent second line of expressions that many more columns."
:group 'lisp
@@ -946,6 +973,7 @@ is the buffer position of the start of the containing expression."
;; setting this to a number inhibits calling hook
(desired-indent nil)
(retry t)
+ whitespace-after-open-paren
calculate-lisp-indent-last-sexp containing-sexp)
(cond ((or (markerp parse-start) (integerp parse-start))
(goto-char parse-start))
@@ -975,6 +1003,7 @@ is the buffer position of the start of the containing expression."
nil
;; Innermost containing sexp found
(goto-char (1+ containing-sexp))
+ (setq whitespace-after-open-paren (looking-at (rx whitespace)))
(if (not calculate-lisp-indent-last-sexp)
;; indent-point immediately follows open paren.
;; Don't call hook.
@@ -989,9 +1018,11 @@ is the buffer position of the start of the containing expression."
calculate-lisp-indent-last-sexp)
;; This is the first line to start within the containing sexp.
;; It's almost certainly a function call.
- (if (= (point) calculate-lisp-indent-last-sexp)
+ (if (or (= (point) calculate-lisp-indent-last-sexp)
+ whitespace-after-open-paren)
;; Containing sexp has nothing before this line
- ;; except the first element. Indent under that element.
+ ;; except the first element, or the first element is
+ ;; preceded by whitespace. Indent under that element.
nil
;; Skip the first element, find start of second (the first
;; argument of the function call) and indent under.
@@ -1344,7 +1375,27 @@ and initial semicolons."
(derived-mode-p 'emacs-lisp-mode))
emacs-lisp-docstring-fill-column
fill-column)))
- (fill-paragraph justify))
+ (save-restriction
+ (save-excursion
+ (let ((ppss (syntax-ppss))
+ (start (point)))
+ ;; If we're in a string, then narrow (roughly) to that
+ ;; string before filling. This avoids filling Lisp
+ ;; statements that follow the string.
+ (when (ppss-string-terminator ppss)
+ (goto-char (ppss-comment-or-string-start ppss))
+ (beginning-of-line)
+ ;; The string may be unterminated -- in that case, don't
+ ;; narrow.
+ (when (ignore-errors
+ (progn
+ (forward-sexp 1)
+ t))
+ (narrow-to-region (ppss-comment-or-string-start ppss)
+ (point))))
+ ;; Move back to where we were.
+ (goto-char start)
+ (fill-paragraph justify)))))
;; Never return nil.
t))
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 26428af4555..2495277ba23 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -55,7 +55,7 @@ This affects `insert-parentheses' and `insert-pair'."
"If non-nil, `forward-sexp' delegates to this function.
Should take the same arguments and behave similarly to `forward-sexp'.")
-(defun forward-sexp (&optional arg)
+(defun forward-sexp (&optional arg interactive)
"Move forward across one balanced expression (sexp).
With ARG, do it that many times. Negative arg -N means move
backward across N balanced expressions. This command assumes
@@ -64,23 +64,32 @@ point is not in a string or comment. Calls
If unable to move over a sexp, signal `scan-error' with three
arguments: a message, the start of the obstacle (usually a
parenthesis or list marker of some kind), and end of the
-obstacle."
- (interactive "^p")
- (or arg (setq arg 1))
- (if forward-sexp-function
- (funcall forward-sexp-function arg)
- (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
- (if (< arg 0) (backward-prefix-chars))))
-
-(defun backward-sexp (&optional arg)
+obstacle. If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
+ (if interactive
+ (condition-case _
+ (forward-sexp arg nil)
+ (scan-error (user-error (if (> arg 0)
+ "No next sexp"
+ "No previous sexp"))))
+ (or arg (setq arg 1))
+ (if forward-sexp-function
+ (funcall forward-sexp-function arg)
+ (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
+ (if (< arg 0) (backward-prefix-chars)))))
+
+(defun backward-sexp (&optional arg interactive)
"Move backward across one balanced expression (sexp).
With ARG, do it that many times. Negative arg -N means
move forward across N balanced expressions.
This command assumes point is not in a string or comment.
-Uses `forward-sexp' to do the work."
- (interactive "^p")
+Uses `forward-sexp' to do the work.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
(or arg (setq arg 1))
- (forward-sexp (- arg)))
+ (forward-sexp (- arg) interactive))
(defun mark-sexp (&optional arg allow-extend)
"Set mark ARG sexps from point.
@@ -99,50 +108,78 @@ This command assumes point is not in a string or comment."
(set-mark
(save-excursion
(goto-char (mark))
- (forward-sexp arg)
+ (condition-case error
+ (forward-sexp arg)
+ (scan-error
+ (user-error (if (equal (cadr error)
+ "Containing expression ends prematurely")
+ "No more sexp to select"
+ (cadr error)))))
(point))))
(t
(push-mark
(save-excursion
- (forward-sexp (prefix-numeric-value arg))
+ (condition-case error
+ (forward-sexp (prefix-numeric-value arg))
+ (scan-error
+ (user-error (if (equal (cadr error)
+ "Containing expression ends prematurely")
+ "No sexp to select"
+ (cadr error)))))
(point))
nil t))))
-(defun forward-list (&optional arg)
+(defun forward-list (&optional arg interactive)
"Move forward across one balanced group of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do it that many times.
Negative arg -N means move backward across N groups of parentheses.
-This command assumes point is not in a string or comment."
- (interactive "^p")
- (or arg (setq arg 1))
- (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
-
-(defun backward-list (&optional arg)
+This command assumes point is not in a string or comment.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
+ (if interactive
+ (condition-case _
+ (forward-list arg nil)
+ (scan-error (user-error (if (> arg 0)
+ "No next group"
+ "No previous group"))))
+ (or arg (setq arg 1))
+ (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))))
+
+(defun backward-list (&optional arg interactive)
"Move backward across one balanced group of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do it that many times.
Negative arg -N means move forward across N groups of parentheses.
-This command assumes point is not in a string or comment."
- (interactive "^p")
+This command assumes point is not in a string or comment.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
(or arg (setq arg 1))
- (forward-list (- arg)))
+ (forward-list (- arg) interactive))
-(defun down-list (&optional arg)
+(defun down-list (&optional arg interactive)
"Move forward down one level of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do this that many times.
A negative argument means move backward but still go down a level.
-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)))
- (while (/= arg 0)
- (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
- (setq arg (- arg inc)))))
+This command assumes point is not in a string or comment.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
+ (if interactive
+ (condition-case _
+ (down-list arg nil)
+ (scan-error (user-error "At bottom level")))
+ (or arg (setq arg 1))
+ (let ((inc (if (> arg 0) 1 -1)))
+ (while (/= arg 0)
+ (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
+ (setq arg (- arg inc))))))
(defun backward-up-list (&optional arg escape-strings no-syntax-crossing)
"Move backward out of one level of parentheses.
@@ -229,26 +266,39 @@ point is unspecified."
(or (< inc 0)
(forward-comment 1))
(setf arg (+ arg inc)))
- (signal (car err) (cdr err))))))
+ (if no-syntax-crossing
+ ;; Assume called interactively; don't signal an error.
+ (user-error "At top level")
+ (signal (car err) (cdr err)))))))
(setq arg (- arg inc)))))
-(defun kill-sexp (&optional arg)
+(defun kill-sexp (&optional arg interactive)
"Kill the sexp (balanced expression) following point.
With ARG, kill that many sexps after point.
Negative arg -N means kill N sexps before point.
-This command assumes point is not in a string or comment."
- (interactive "p")
- (let ((opoint (point)))
- (forward-sexp (or arg 1))
- (kill-region opoint (point))))
-
-(defun backward-kill-sexp (&optional arg)
+This command assumes point is not in a string or comment.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "p\nd")
+ (if interactive
+ (condition-case _
+ (kill-sexp arg nil)
+ (scan-error (user-error (if (> arg 0)
+ "No next sexp"
+ "No previous sexp"))))
+ (let ((opoint (point)))
+ (forward-sexp (or arg 1))
+ (kill-region opoint (point)))))
+
+(defun backward-kill-sexp (&optional arg interactive)
"Kill the sexp (balanced expression) preceding point.
With ARG, kill that many sexps before point.
Negative arg -N means kill N sexps after point.
-This command assumes point is not in a string or comment."
- (interactive "p")
- (kill-sexp (- (or arg 1))))
+This command assumes point is not in a string or comment.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "p\nd")
+ (kill-sexp (- (or arg 1)) interactive))
;; After Zmacs:
(defun kill-backward-up-list (&optional arg)
@@ -453,7 +503,7 @@ If ARG is positive, that's the end of the buffer.
Otherwise, that's the beginning of the buffer."
(if (> arg 0) (point-max) (point-min)))
-(defun end-of-defun (&optional arg)
+(defun end-of-defun (&optional arg interactive)
"Move forward to next end of defun.
With argument, do it that many times.
Negative argument -N means move back to Nth preceding end of defun.
@@ -463,128 +513,145 @@ matches the open-parenthesis that starts a defun; see function
`beginning-of-defun'.
If variable `end-of-defun-function' is non-nil, its value
-is called as a function to find the defun's end."
- (interactive "^p")
- (or (not (eq this-command 'end-of-defun))
- (eq last-command 'end-of-defun)
- (and transient-mark-mode mark-active)
- (push-mark))
- (if (or (null arg) (= arg 0)) (setq arg 1))
- (let ((pos (point))
- (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point)))
- (skip (lambda ()
- ;; When comparing point against pos, we want to consider that if
- ;; point was right after the end of the function, it's still
- ;; considered as "in that function".
- ;; E.g. `eval-defun' from right after the last close-paren.
- (unless (bolp)
- (skip-chars-forward " \t")
- (if (looking-at "\\s<\\|\n")
- (forward-line 1))))))
- (funcall end-of-defun-function)
- (funcall skip)
- (cond
- ((> arg 0)
- ;; Moving forward.
- (if (> (point) pos)
- ;; We already moved forward by one because we started from
- ;; within a function.
- (setq arg (1- arg))
- ;; We started from after the end of the previous function.
- (goto-char pos))
- (unless (zerop arg)
- (beginning-of-defun-raw (- arg))
- (funcall end-of-defun-function)))
- ((< arg 0)
- ;; Moving backward.
- (if (< (point) pos)
- ;; We already moved backward because we started from between
- ;; two functions.
- (setq arg (1+ arg))
- ;; We started from inside a function.
- (goto-char beg))
- (unless (zerop arg)
+is called as a function to find the defun's end.
+
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "^p\nd")
+ (if interactive
+ (condition-case e
+ (end-of-defun arg nil)
+ (scan-error (user-error (cadr e))))
+ (or (not (eq this-command 'end-of-defun))
+ (eq last-command 'end-of-defun)
+ (and transient-mark-mode mark-active)
+ (push-mark))
+ (if (or (null arg) (= arg 0)) (setq arg 1))
+ (let ((pos (point))
+ (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point)))
+ (skip (lambda ()
+ ;; When comparing point against pos, we want to consider that
+ ;; if point was right after the end of the function, it's
+ ;; still considered as "in that function".
+ ;; E.g. `eval-defun' from right after the last close-paren.
+ (unless (bolp)
+ (skip-chars-forward " \t")
+ (if (looking-at "\\s<\\|\n")
+ (forward-line 1))))))
+ (funcall end-of-defun-function)
+ (when (<= arg 1)
+ (funcall skip))
+ (cond
+ ((> arg 0)
+ ;; Moving forward.
+ (if (> (point) pos)
+ ;; We already moved forward by one because we started from
+ ;; within a function.
+ (setq arg (1- arg))
+ ;; We started from after the end of the previous function.
+ (goto-char pos))
+ (unless (zerop arg)
+ (beginning-of-defun-raw (- arg))
+ (funcall end-of-defun-function)))
+ ((< arg 0)
+ ;; Moving backward.
+ (if (< (point) pos)
+ ;; We already moved backward because we started from between
+ ;; two functions.
+ (setq arg (1+ arg))
+ ;; We started from inside a function.
+ (goto-char beg))
+ (unless (zerop arg)
+ (beginning-of-defun-raw (- arg))
+ (setq beg (point))
+ (funcall end-of-defun-function))))
+ (funcall skip)
+ (while (and (< arg 0) (>= (point) pos))
+ ;; We intended to move backward, but this ended up not doing so:
+ ;; Try harder!
+ (goto-char beg)
(beginning-of-defun-raw (- arg))
- (setq beg (point))
- (funcall end-of-defun-function))))
- (funcall skip)
- (while (and (< arg 0) (>= (point) pos))
- ;; We intended to move backward, but this ended up not doing so:
- ;; Try harder!
- (goto-char beg)
- (beginning-of-defun-raw (- arg))
- (if (>= (point) beg)
- (setq arg 0)
- (setq beg (point))
- (funcall end-of-defun-function)
- (funcall skip)))))
-
-(defun mark-defun (&optional arg)
+ (if (>= (point) beg)
+ (setq arg 0)
+ (setq beg (point))
+ (funcall end-of-defun-function)
+ (funcall skip))))))
+
+(defun mark-defun (&optional arg interactive)
"Put mark at end of this defun, point at beginning.
The defun marked is the one that contains point or follows point.
With positive ARG, mark this and that many next defuns; with negative
ARG, change the direction of marking.
If the mark is active, it marks the next or previous defun(s) after
-the one(s) already marked."
- (interactive "p")
- (setq arg (or arg 1))
- ;; There is no `mark-defun-back' function - see
- ;; https://lists.gnu.org/r/bug-gnu-emacs/2016-11/msg00079.html
- ;; for explanation
- (when (eq last-command 'mark-defun-back)
- (setq arg (- arg)))
- (when (< arg 0)
- (setq this-command 'mark-defun-back))
- (cond ((use-region-p)
- (if (>= arg 0)
- (set-mark
- (save-excursion
- (goto-char (mark))
- ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed
- (dotimes (_ignore arg)
- (end-of-defun))
- (point)))
- (beginning-of-defun-comments (- arg))))
- (t
- (let ((opoint (point))
- beg end)
- (push-mark opoint)
- ;; Try first in this order for the sake of languages with nested
- ;; functions where several can end at the same place as with the
- ;; offside rule, e.g. Python.
- (beginning-of-defun-comments)
- (setq beg (point))
- (end-of-defun)
- (setq end (point))
- (when (or (and (<= (point) opoint)
- (> arg 0))
- (= beg (point-min))) ; we were before the first defun!
- ;; beginning-of-defun moved back one defun so we got the wrong
- ;; one. If ARG < 0, however, we actually want to go back.
- (goto-char opoint)
- (end-of-defun)
- (setq end (point))
- (beginning-of-defun-comments)
- (setq beg (point)))
- (goto-char beg)
- (cond ((> arg 0)
- ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed
+the one(s) already marked.
+
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "p\nd")
+ (if interactive
+ (condition-case e
+ (mark-defun arg nil)
+ (scan-error (user-error (cadr e))))
+ (setq arg (or arg 1))
+ ;; There is no `mark-defun-back' function - see
+ ;; https://lists.gnu.org/r/bug-gnu-emacs/2016-11/msg00079.html
+ ;; for explanation
+ (when (eq last-command 'mark-defun-back)
+ (setq arg (- arg)))
+ (when (< arg 0)
+ (setq this-command 'mark-defun-back))
+ (cond ((use-region-p)
+ (if (>= arg 0)
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ ;; change the dotimes below to (end-of-defun arg)
+ ;; once bug #24427 is fixed
(dotimes (_ignore arg)
(end-of-defun))
- (setq end (point))
- (push-mark end nil t)
- (goto-char beg))
- (t
- (goto-char beg)
- (unless (= arg -1) ; beginning-of-defun behaves
- ; strange with zero arg - see
- ; https://lists.gnu.org/r/bug-gnu-emacs/2017-02/msg00196.html
- (beginning-of-defun (1- (- arg))))
- (push-mark end nil t))))))
- (skip-chars-backward "[:space:]\n")
- (unless (bobp)
- (forward-line 1)))
+ (point)))
+ (beginning-of-defun-comments (- arg))))
+ (t
+ (let ((opoint (point))
+ beg end)
+ (push-mark opoint)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with the
+ ;; offside rule, e.g. Python.
+ (beginning-of-defun-comments)
+ (setq beg (point))
+ (end-of-defun)
+ (setq end (point))
+ (when (or (and (<= (point) opoint)
+ (> arg 0))
+ (= beg (point-min))) ; we were before the first defun!
+ ;; beginning-of-defun moved back one defun so we got the wrong
+ ;; one. If ARG < 0, however, we actually want to go back.
+ (goto-char opoint)
+ (end-of-defun)
+ (setq end (point))
+ (beginning-of-defun-comments)
+ (setq beg (point)))
+ (goto-char beg)
+ (cond ((> arg 0)
+ ;; change the dotimes below to (end-of-defun arg)
+ ;; once bug #24427 is fixed
+ (dotimes (_ignore arg)
+ (end-of-defun))
+ (setq end (point))
+ (push-mark end nil t)
+ (goto-char beg))
+ (t
+ (goto-char beg)
+ (unless (= arg -1)
+ ;; beginning-of-defun behaves strange with zero arg - see
+ ;; lists.gnu.org/r/bug-gnu-emacs/2017-02/msg00196.html
+ (beginning-of-defun (1- (- arg))))
+ (push-mark end nil t))))))
+ (skip-chars-backward "[:space:]\n")
+ (unless (bobp)
+ (forward-line 1))))
(defvar narrow-to-defun-include-comments nil
"If non-nil, `narrow-to-defun' will also show comments preceding the defun.")
@@ -733,13 +800,52 @@ This command assumes point is not in a string or comment."
(interactive "P")
(insert-pair arg ?\( ?\)))
+(defcustom delete-pair-blink-delay blink-matching-delay
+ "Time in seconds to delay after showing a paired character to delete.
+It's used by the command `delete-pair'. The value 0 disables blinking."
+ :type 'number
+ :group 'lisp
+ :version "28.1")
+
(defun delete-pair (&optional arg)
- "Delete a pair of characters enclosing ARG sexps following point.
-A negative ARG deletes a pair of characters around preceding ARG sexps."
- (interactive "p")
- (unless arg (setq arg 1))
- (save-excursion (forward-sexp arg) (delete-char (if (> arg 0) -1 1)))
- (delete-char (if (> arg 0) 1 -1)))
+ "Delete a pair of characters enclosing ARG sexps that follow point.
+A negative ARG deletes a pair around the preceding ARG sexps instead.
+The option `delete-pair-blink-delay' can disable blinking."
+ (interactive "P")
+ (if arg
+ (setq arg (prefix-numeric-value arg))
+ (setq arg 1))
+ (if (< arg 0)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (save-excursion
+ (let ((close-char (char-before)))
+ (forward-sexp arg)
+ (unless (member (list (char-after) close-char)
+ (mapcar (lambda (p)
+ (if (= (length p) 3) (cdr p) p))
+ insert-pair-alist))
+ (error "Not after matching pair"))
+ (when (and (numberp delete-pair-blink-delay)
+ (> delete-pair-blink-delay 0))
+ (sit-for delete-pair-blink-delay))
+ (delete-char 1)))
+ (delete-char -1))
+ (save-excursion
+ (skip-chars-forward " \t")
+ (save-excursion
+ (let ((open-char (char-after)))
+ (forward-sexp arg)
+ (unless (member (list open-char (char-before))
+ (mapcar (lambda (p)
+ (if (= (length p) 3) (cdr p) p))
+ insert-pair-alist))
+ (error "Not before matching pair"))
+ (when (and (numberp delete-pair-blink-delay)
+ (> delete-pair-blink-delay 0))
+ (sit-for delete-pair-blink-delay))
+ (delete-char -1)))
+ (delete-char 1))))
(defun raise-sexp (&optional arg)
"Raise ARG sexps higher up the tree."
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 82a8cd2d777..61c1ea490f0 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -112,7 +112,7 @@ and also to avoid outputting the warning during normal execution."
(funcall (eval (cadr form)))
(byte-compile-constant nil)))
-(defun macroexp--compiling-p ()
+(defun macroexp-compiling-p ()
"Return non-nil if we're macroexpanding for the compiler."
;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this
;; macro-expansion will be processed by the byte-compiler, we check
@@ -120,29 +120,55 @@ and also to avoid outputting the warning during normal execution."
(member '(declare-function . byte-compile-macroexpand-declare-function)
macroexpand-all-environment))
+(defun macroexp-file-name ()
+ "Return the name of the file from which the code comes.
+Returns nil when we do not know.
+A non-nil result is expected to be reliable when called from a macro in order
+to find the file in which the macro's call was found, and it should be
+reliable as well when used at the top-level of a file.
+Other uses risk returning non-nil value that point to the wrong file."
+ ;; `eval-buffer' binds `current-load-list' but not `load-file-name',
+ ;; so prefer using it over using `load-file-name'.
+ (let ((file (car (last current-load-list))))
+ (or (if (stringp file) file)
+ (bound-and-true-p byte-compile-current-file))))
+
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
-(defun macroexp--warn-and-return (msg form &optional compile-only)
- (let ((when-compiled (lambda () (byte-compile-warn "%s" msg))))
- (cond
- ((null msg) form)
- ((macroexp--compiling-p)
- (if (gethash form macroexp--warned)
- ;; Already wrapped this exp with a warning: avoid inf-looping
- ;; where we keep adding the same warning onto `form' because
- ;; macroexpand-all gets right back to macroexpanding `form'.
- form
- (puthash form form macroexp--warned)
- `(progn
- (macroexp--funcall-if-compiled ',when-compiled)
- ,form)))
- (t
- (unless compile-only
- (message "%s%s" (if (stringp load-file-name)
- (concat (file-relative-name load-file-name) ": ")
- "")
- msg))
- form))))
+(defun macroexp--warn-wrap (msg form category)
+ (let ((when-compiled (lambda ()
+ (when (byte-compile-warning-enabled-p category)
+ (byte-compile-warn "%s" msg)))))
+ `(progn
+ (macroexp--funcall-if-compiled ',when-compiled)
+ ,form)))
+
+(define-obsolete-function-alias 'macroexp--warn-and-return
+ #'macroexp-warn-and-return "28.1")
+(defun macroexp-warn-and-return (msg form &optional category compile-only)
+ "Return code equivalent to FORM labeled with warning MSG.
+CATEGORY is the category of the warning, like the categories that
+can appear in `byte-compile-warnings'.
+COMPILE-ONLY non-nil means no warning should be emitted if the code
+is executed without being compiled first."
+ (cond
+ ((null msg) form)
+ ((macroexp-compiling-p)
+ (if (and (consp form) (gethash form macroexp--warned))
+ ;; Already wrapped this exp with a warning: avoid inf-looping
+ ;; where we keep adding the same warning onto `form' because
+ ;; macroexpand-all gets right back to macroexpanding `form'.
+ form
+ (puthash form form macroexp--warned)
+ (macroexp--warn-wrap msg form category)))
+ (t
+ (unless compile-only
+ (message "%sWarning: %s"
+ (if (stringp load-file-name)
+ (concat (file-relative-name load-file-name) ": ")
+ "")
+ msg))
+ form)))
(defun macroexp--obsolete-warning (fun obsolescence-data type)
(let ((instead (car obsolescence-data))
@@ -180,24 +206,86 @@ and also to avoid outputting the warning during normal execution."
(defun macroexp-macroexpand (form env)
"Like `macroexpand' but checking obsolescence."
- (let ((new-form
- (macroexpand form env)))
+ (let* ((macroexpand-all-environment env)
+ (new-form
+ (macroexpand form env)))
(if (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
(symbolp (car form))
- (get (car form) 'byte-obsolete-info)
- (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p 'obsolete (car form))))
+ (get (car form) 'byte-obsolete-info))
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
"alias" "macro"))
- new-form))
+ new-form 'obsolete))
new-form)))
+(defun macroexp--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))
+ (arglist (nth 1 lambda))
+ (body (cdr (cdr lambda)))
+ optionalp restp
+ bindings)
+ (if (and (stringp (car body)) (cdr body))
+ (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...
+ ;; (if optionalp (error "multiple &optional keywords in %s" name))
+ (if restp (error "&optional found after &rest in %s" name))
+ (if (null (cdr arglist))
+ (error "nothing after &optional in %s" name))
+ (setq optionalp t))
+ ((eq (car arglist) '&rest)
+ ;; ...but it is by no stretch of the imagination a reasonable
+ ;; thing that funcall_lambda() allows (&rest x y) and
+ ;; (&rest x &optional y) in arglists.
+ (if (null (cdr arglist))
+ (error "nothing after &rest in %s" name))
+ (if (cdr (cdr arglist))
+ (error "multiple vars after &rest in %s" name))
+ (setq restp t))
+ (restp
+ (setq bindings (cons (list (car arglist)
+ (and values (cons 'list values)))
+ bindings)
+ values nil))
+ ((and (not optionalp) (null values))
+ (setq arglist nil values 'too-few))
+ (t
+ (setq bindings (cons (list (car arglist) (car values))
+ bindings)
+ values (cdr values))))
+ (setq arglist (cdr arglist)))
+ (if values
+ (macroexp-warn-and-return
+ (format (if (eq values 'too-few)
+ "attempt to open-code `%s' with too few arguments"
+ "attempt to open-code `%s' with too many arguments")
+ name)
+ form)
+
+ ;; The following leads to infinite recursion when loading a
+ ;; file containing `(defsubst f () (f))', and then trying to
+ ;; byte-compile that file.
+ ;;(setq body (mapcar 'byte-optimize-form body)))
+
+ (if bindings
+ `(let ,(nreverse bindings) . ,body)
+ (macroexp-progn body)))))
+
(defun macroexp--expand-all (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
@@ -211,10 +299,12 @@ Assumes the caller has bound `macroexpand-all-environment'."
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(setq form (macroexp-macroexpand form macroexpand-all-environment))
+ ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
+ ;; I tried it, it broke the bootstrap :-(
(pcase form
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
- (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
+ (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
(macroexp--cons
'condition-case
(macroexp--cons err
@@ -231,46 +321,59 @@ Assumes the caller has bound `macroexpand-all-environment'."
(cdr form))
form))
(`(,(or 'function 'quote) . ,_) form)
- (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
- (macroexp--cons fun
- (macroexp--cons (macroexp--all-clauses bindings 1)
- (macroexp--all-forms body)
- (cdr form))
- form))
+ (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
+ pcase--dontcare))
+ (macroexp--cons
+ fun
+ (macroexp--cons
+ (macroexp--all-clauses bindings 1)
+ (if (null body)
+ (macroexp-unprogn
+ (macroexp-warn-and-return
+ (format "Empty %s body" fun)
+ nil nil 'compile-only))
+ (macroexp--all-forms body))
+ (cdr form))
+ form))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
- (macroexp--cons (macroexp--all-forms fun 2)
- (macroexp--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 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc))
- ',(and f `(lambda . ,_)) . ,args)
- (macroexp--warn-and-return
- (format "%s quoted with ' rather than with #'"
- (list 'lambda (nth 1 f) '...))
- (macroexp--expand-all `(,fun ,f . ,args))))
- ;; Second arg is a function:
- (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
- (macroexp--warn-and-return
- (format "%s quoted with ' rather than with #'"
- (list 'lambda (nth 1 f) '...))
- (macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
- (`(funcall #',(and f (pred symbolp)) . ,args)
- ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
- ;; has a compiler-macro.
- (macroexp--expand-all `(,f . ,args)))
+ ;; If the byte-optimizer is loaded, try to unfold this,
+ ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
+ ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
+ ;; creation of a closure, thus resulting in much better code.
+ (let ((newform (macroexp--unfold-lambda form)))
+ (if (eq newform form)
+ ;; Unfolding failed for some reason, avoid infinite recursion.
+ (macroexp--cons (macroexp--all-forms fun 2)
+ (macroexp--all-forms args)
+ form)
+ (macroexp--expand-all newform))))
+
+ (`(funcall . ,(or `(,exp . ,args) pcase--dontcare))
+ (let ((eexp (macroexp--expand-all exp))
+ (eargs (macroexp--all-forms args)))
+ ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+ ;; has a compiler-macro, or to unfold it.
+ (pcase eexp
+ (`#',f (macroexp--expand-all `(,f . ,eargs)))
+ (_ `(funcall ,eexp . ,eargs)))))
(`(,func . ,_)
- ;; Macro expand compiler macros. This cannot be delayed to
- ;; byte-optimize-form because the output of the compiler-macro can
- ;; use macros.
- (let ((handler (function-get func 'compiler-macro)))
+ (let ((handler (function-get func 'compiler-macro))
+ (funargs (function-get func 'funarg-positions)))
+ ;; Check functions quoted with ' rather than with #'
+ (dolist (funarg funargs)
+ (let ((arg (nth funarg form)))
+ (when (and (eq 'quote (car-safe arg))
+ (eq 'lambda (car-safe (cadr arg))))
+ (setcar (nthcdr funarg form)
+ (macroexp-warn-and-return
+ (format "%S quoted with ' rather than with #'"
+ (let ((f (cadr arg)))
+ (if (symbolp f) f `(lambda ,(nth 1 f) ...))))
+ arg)))))
+ ;; Macro expand compiler macros. This cannot be delayed to
+ ;; byte-optimize-form because the output of the compiler-macro can
+ ;; use macros.
(if (null handler)
;; No compiler macro. We just expand each argument (for
;; setq/setq-default this works alright because the variable names
@@ -296,6 +399,19 @@ Assumes the caller has bound `macroexpand-all-environment'."
(_ form))))
+;; Record which arguments expect functions, so we can warn when those
+;; are accidentally quoted with ' rather than with #'
+(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash
+ map-char-table map-keymap map-keymap-internal))
+ (put f 'funarg-positions '(1)))
+(dolist (f '( add-hook remove-hook advice-remove advice--remove-function
+ defalias fset global-set-key run-after-idle-timeout
+ set-process-filter set-process-sentinel sort))
+ (put f 'funarg-positions '(2)))
+(dolist (f '( advice-add define-key
+ run-at-time run-with-idle-timer run-with-timer ))
+ (put f 'funarg-positions '(3)))
+
;;;###autoload
(defun macroexpand-all (form &optional environment)
"Return result of expanding macros at all levels in FORM.
@@ -358,12 +474,12 @@ Never returns an empty list."
(t
`(cond (,test ,@(macroexp-unprogn then))
(,(nth 1 else) ,@(macroexp-unprogn (nth 2 else)))
- (t ,@(nthcdr 3 else))))))
+ ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def))))))))
((eq (car-safe else) 'cond)
`(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else)))
;; Invert the test if that lets us reduce the depth of the tree.
((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
- (t `(if ,test ,then ,@(macroexp-unprogn else)))))
+ (t `(if ,test ,then ,@(if else (macroexp-unprogn else))))))
(defmacro macroexp-let2 (test sym exp &rest body)
"Evaluate BODY with SYM bound to an expression for EXP's value.
@@ -480,6 +596,50 @@ itself or not."
v
(list 'quote v)))
+(defun macroexp--fgrep (bindings sexp)
+ "Return those of the BINDINGS which might be used in SEXP.
+It is used as a poor-man's \"free variables\" test. It differs from a true
+test of free variables in the following ways:
+- It does not distinguish variables from functions, so it can be used
+ both to detect whether a given variable is used by SEXP and to
+ detect whether a given function is used by SEXP.
+- It does not actually know ELisp syntax, so it only looks for the presence
+ of symbols in SEXP and can't distinguish if those symbols are truly
+ references to the given variable (or function). That can make the result
+ include bindings which actually aren't used.
+- For the same reason it may cause the result to fail to include bindings
+ which will be used if SEXP is not yet fully macro-expanded and the
+ use of the binding will only be revealed by macro expansion."
+ (let ((res '())
+ ;; Cyclic code should not happen, but code can contain cyclic data :-(
+ (seen (make-hash-table :test #'eq))
+ (sexpss (list (list sexp))))
+ ;; Use a nested while loop to reduce the amount of heap allocations for
+ ;; pushes to `sexpss' and the `gethash' overhead.
+ (while (and sexpss bindings)
+ (let ((sexps (pop sexpss)))
+ (unless (gethash sexps seen)
+ (puthash sexps t seen) ;; Using `setf' here causes bootstrap problems.
+ (if (vectorp sexps) (setq sexps (mapcar #'identity sexps)))
+ (let ((tortoise sexps) (skip t))
+ (while sexps
+ (let ((sexp (if (consp sexps) (pop sexps)
+ (prog1 sexps (setq sexps nil)))))
+ (if skip
+ (setq skip nil)
+ (setq tortoise (cdr tortoise))
+ (if (eq tortoise sexps)
+ (setq sexps nil) ;; Found a cycle: we're done!
+ (setq skip t)))
+ (cond
+ ((or (consp sexp) (vectorp sexp)) (push sexp sexpss))
+ (t
+ (let ((tmp (assq sexp bindings)))
+ (when tmp
+ (push tmp res)
+ (setq bindings (remove tmp bindings))))))))))))
+ res))
+
;;; Load-time macro-expansion.
;; Because macro-expansion used to be more lazy, eager macro-expansion
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 8d3a42b09f6..0522b31f577 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -281,7 +281,8 @@ C-g to quit (cancel the whole command);
"If non-nil, `read-answer' accepts single-character answers.
If t, accept short (single key-press) answers to the question.
If nil, require long answers. If `auto', accept short answers if
-the function cell of `yes-or-no-p' is set to `y-or-n-p'."
+`use-short-answers' is non-nil, or the function cell of `yes-or-no-p'
+is set to `y-or-n-p'."
:type '(choice (const :tag "Accept short answers" t)
(const :tag "Require long answer" nil)
(const :tag "Guess preference" auto))
@@ -320,7 +321,8 @@ Return a long answer even in case of accepting short ones.
When `use-dialog-box' is t, pop up a dialog window to get user input."
(let* ((short (if (eq read-answer-short 'auto)
- (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)
+ (or use-short-answers
+ (eq (symbol-function 'yes-or-no-p) 'y-or-n-p))
read-answer-short))
(answers-with-help
(if (assoc "help" answers)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index 8fa36da6e17..5c76fb9eb95 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -3,12 +3,10 @@
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Author: Nicolas Petton <nicolas@petton.fr>
-;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 2.0
-;; Package-Requires: ((emacs "25"))
-;; Package: map
-
;; Maintainer: emacs-devel@gnu.org
+;; Keywords: extensions, lisp
+;; Version: 3.0
+;; Package-Requires: ((emacs "26"))
;; This file is part of GNU Emacs.
@@ -27,8 +25,9 @@
;;; Commentary:
-;; map.el provides map-manipulation functions that work on alists,
-;; hash-table and arrays. All functions are prefixed with "map-".
+;; map.el provides generic map-manipulation functions that work on
+;; alists, plists, hash-tables, and arrays. All functions are
+;; prefixed with "map-".
;;
;; Functions taking a predicate or iterating over a map using a
;; function take the function as their first argument. All other
@@ -54,10 +53,12 @@ ARGS is a list of elements to be matched in the map.
Each element of ARGS can be of the form (KEY PAT), in which case KEY is
evaluated and searched for in the map. The match fails if for any KEY
found in the map, the corresponding PAT doesn't match the value
-associated to the KEY.
+associated with the KEY.
-Each element can also be a SYMBOL, which is an abbreviation of a (KEY
-PAT) tuple of the form (\\='SYMBOL SYMBOL).
+Each element can also be a SYMBOL, which is an abbreviation of
+a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL
+is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL),
+useful for binding plist values.
Keys in ARGS not found in the map are ignored, and the match doesn't
fail."
@@ -73,7 +74,7 @@ bound to the looked up value in MAP.
KEYS can also be a list of (KEY VARNAME) pairs, in which case
KEY is an unquoted form.
-MAP can be a list, hash-table or array."
+MAP can be an alist, plist, hash-table, or array."
(declare (indent 2)
(debug ((&rest &or symbolp ([form symbolp])) form body)))
`(pcase-let ((,(map--make-pcase-patterns keys) ,map))
@@ -99,7 +100,7 @@ Returns the result of evaluating the form associated with MAP-VAR's type."
(define-error 'map-not-inplace "Cannot modify map in-place")
(defsubst map--plist-p (list)
- (and (consp list) (not (listp (car list)))))
+ (and (consp list) (atom (car list))))
(cl-defgeneric map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
@@ -107,7 +108,8 @@ If KEY is not found, return DEFAULT which defaults to nil.
TESTFN is deprecated. Its default depends on the MAP argument.
-In the base definition, MAP can be an alist, hash-table, or array."
+In the base definition, MAP can be an alist, plist, hash-table,
+or array."
(declare
(gv-expander
(lambda (do)
@@ -122,29 +124,30 @@ In the base definition, MAP can be an alist, hash-table, or array."
(with-no-warnings (map-put! ,mgetter ,key ,v ,testfn))
(map-not-inplace
,(funcall msetter
- `(map-insert ,mgetter ,key ,v))))))))))
+ `(map-insert ,mgetter ,key ,v))
+ ;; Always return the value.
+ ,v))))))))
;; `testfn' is deprecated.
(advertised-calling-convention (map key &optional default) "27.1"))
+ ;; Can't use `cl-defmethod' with `advertised-calling-convention'.
(map--dispatch map
:list (if (map--plist-p map)
- (let ((res (plist-get map key)))
- (if (and default (null res) (not (plist-member map key)))
- default
- res))
+ (let ((res (plist-member map key)))
+ (if res (cadr res) default))
(alist-get key map default nil testfn))
:hash-table (gethash key map default)
- :array (if (and (>= key 0) (< key (seq-length map)))
- (seq-elt map key)
+ :array (if (map-contains-key map key)
+ (aref map key)
default)))
(defmacro map-put (map key value &optional testfn)
"Associate KEY with VALUE in MAP and return VALUE.
If KEY is already present in MAP, replace the associated value
with VALUE.
-When MAP is a list, test equality with TESTFN if non-nil,
+When MAP is an alist, test equality with TESTFN if non-nil,
otherwise use `eql'.
-MAP can be a list, hash-table or array."
+MAP can be an alist, plist, hash-table, or array."
(declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1"))
`(setf (map-elt ,map ,key nil ,testfn) ,value))
@@ -166,23 +169,30 @@ MAP can be a list, hash-table or array."
(cl-defgeneric map-delete (map key)
"Delete KEY in-place from MAP and return MAP.
-No error is signaled if KEY is not a key of MAP.
-If MAP is an array, store nil at the index KEY."
- (map--dispatch map
- ;; FIXME: Signal map-not-inplace i.s.o returning a different list?
- :list (if (map--plist-p map)
- (setq map (map--plist-delete map key))
- (setf (alist-get key map nil t) nil))
- :hash-table (remhash key map)
- :array (and (>= key 0)
- (<= key (seq-length map))
- (aset map key nil)))
+Keys not present in MAP are ignored.")
+
+(cl-defmethod map-delete ((map list) key)
+ ;; FIXME: Signal map-not-inplace i.s.o returning a different list?
+ (if (map--plist-p map)
+ (map--plist-delete map key)
+ (setf (alist-get key map nil t) nil)
+ map))
+
+(cl-defmethod map-delete ((map hash-table) key)
+ (remhash key map)
+ map)
+
+(cl-defmethod map-delete ((map array) key)
+ "Store nil at index KEY."
+ (when (map-contains-key map key)
+ (aset map key nil))
map)
(defun map-nested-elt (map keys &optional default)
"Traverse MAP using KEYS and return the looked up value or DEFAULT if nil.
-Map can be a nested map composed of alists, hash-tables and arrays."
+MAP can be a nested map composed of alists, plists, hash-tables,
+and arrays."
(or (seq-reduce (lambda (acc key)
(when (mapp acc)
(map-elt acc key)))
@@ -200,30 +210,49 @@ The default implementation delegates to `map-apply'."
The default implementation delegates to `map-apply'."
(map-apply (lambda (_ value) value) map))
+(cl-defmethod map-values ((map array))
+ "Convert MAP into a list."
+ (append map ()))
+
(cl-defgeneric map-pairs (map)
- "Return the elements of MAP as key/value association lists.
+ "Return the key/value pairs in MAP as an alist.
The default implementation delegates to `map-apply'."
(map-apply #'cons map))
(cl-defgeneric map-length (map)
;; FIXME: Should we rename this to `map-size'?
- "Return the number of elements in the map.
-The default implementation counts `map-keys'."
- (cond
- ((hash-table-p map) (hash-table-count map))
- ((listp map)
- ;; FIXME: What about repeated/shadowed keys?
- (if (map--plist-p map) (/ (length map) 2) (length map)))
- ((arrayp map) (length map))
- (t (length (map-keys map)))))
+ "Return the number of key/value pairs in MAP.
+Note that this does not always reflect the number of unique keys.
+The default implementation delegates to `map-do'."
+ (let ((size 0))
+ (map-do (lambda (_k _v) (setq size (1+ size))) map)
+ size))
+
+(cl-defmethod map-length ((map hash-table))
+ (hash-table-count map))
+
+(cl-defmethod map-length ((map list))
+ (if (map--plist-p map)
+ (/ (length map) 2)
+ (length map)))
+
+(cl-defmethod map-length ((map array))
+ (length map))
(cl-defgeneric map-copy (map)
- "Return a copy of MAP."
- ;; FIXME: Clarify how deep is the copy!
- (map--dispatch map
- :list (seq-copy map) ;FIXME: Probably not deep enough for alists!
- :hash-table (copy-hash-table map)
- :array (seq-copy map)))
+ "Return a copy of MAP.")
+
+(cl-defmethod map-copy ((map list))
+ "Use `copy-alist' on alists and `copy-sequence' on plists."
+ (if (map--plist-p map)
+ (copy-sequence map)
+ (copy-alist map)))
+
+(cl-defmethod map-copy ((map hash-table))
+ (copy-hash-table map))
+
+(cl-defmethod map-copy ((map array))
+ (copy-sequence map))
(cl-defgeneric map-apply (function map)
"Apply FUNCTION to each element of MAP and return the result as a list.
@@ -241,26 +270,28 @@ FUNCTION is called with two arguments, the key and the value.")
(cl-defmethod map-do (function (map hash-table)) (maphash function map))
(cl-defgeneric map-keys-apply (function map)
- "Return the result of applying FUNCTION to each key of MAP.
+ "Return the result of applying FUNCTION to each key in MAP.
The default implementation delegates to `map-apply'."
(map-apply (lambda (key _)
(funcall function key))
map))
(cl-defgeneric map-values-apply (function map)
- "Return the result of applying FUNCTION to each value of MAP.
+ "Return the result of applying FUNCTION to each value in MAP.
The default implementation delegates to `map-apply'."
(map-apply (lambda (_ val)
(funcall function val))
map))
+(cl-defmethod map-values-apply (function (map array))
+ (mapcar function map))
+
(cl-defgeneric map-filter (pred map)
"Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP.
The default implementation delegates to `map-apply'."
(delq nil (map-apply (lambda (key val)
- (if (funcall pred key val)
- (cons key val)
- nil))
+ (and (funcall pred key val)
+ (cons key val)))
map)))
(cl-defgeneric map-remove (pred map)
@@ -270,7 +301,7 @@ The default implementation delegates to `map-filter'."
map))
(cl-defgeneric mapp (map)
- "Return non-nil if MAP is a map (alist, hash-table, array, ...)."
+ "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)."
(or (listp map)
(hash-table-p map)
(arrayp map)))
@@ -290,56 +321,58 @@ The default implementation delegates to `map-length'."
;; test function!
"Return non-nil if and only if MAP contains KEY.
TESTFN is deprecated. Its default depends on MAP.
-The default implementation delegates to `map-do'."
+The default implementation delegates to `map-some'."
(unless testfn (setq testfn #'equal))
- (catch 'map--catch
- (map-do (lambda (k _v)
- (if (funcall testfn key k) (throw 'map--catch t)))
- map)
- nil))
+ (map-some (lambda (k _v) (funcall testfn key k)) map))
(cl-defmethod map-contains-key ((map list) key &optional testfn)
- (let ((v '(nil)))
- (not (eq v (alist-get key map v nil (or testfn #'equal))))))
+ "Return non-nil if MAP contains KEY.
+If MAP is an alist, TESTFN defaults to `equal'.
+If MAP is a plist, `plist-member' is used instead."
+ (if (map--plist-p map)
+ (plist-member map key)
+ (let ((v '(nil)))
+ (not (eq v (alist-get key map v nil (or testfn #'equal)))))))
(cl-defmethod map-contains-key ((map array) key &optional _testfn)
- (and (integerp key)
- (>= key 0)
- (< key (length map))))
+ "Return non-nil if KEY is an index of MAP, ignoring TESTFN."
+ (and (natnump key) (< key (length map))))
(cl-defmethod map-contains-key ((map hash-table) key &optional _testfn)
+ "Return non-nil if MAP contains KEY, ignoring TESTFN."
(let ((v '(nil)))
(not (eq v (gethash key map v)))))
(cl-defgeneric map-some (pred map)
"Return the first non-nil (PRED key val) in MAP.
-The default implementation delegates to `map-apply'."
+Return nil if no such element is found.
+The default implementation delegates to `map-do'."
;; FIXME: Not sure if there's much benefit to defining it as defgeneric,
;; since as defined, I can't think of a map-type where we could provide an
;; algorithmically more efficient algorithm than the default.
(catch 'map--break
- (map-apply (lambda (key value)
- (let ((result (funcall pred key value)))
- (when result
- (throw 'map--break result))))
- map)
+ (map-do (lambda (key value)
+ (let ((result (funcall pred key value)))
+ (when result
+ (throw 'map--break result))))
+ map)
nil))
(cl-defgeneric map-every-p (pred map)
"Return non-nil if (PRED key val) is non-nil for all elements of MAP.
-The default implementation delegates to `map-apply'."
+The default implementation delegates to `map-do'."
;; FIXME: Not sure if there's much benefit to defining it as defgeneric,
;; since as defined, I can't think of a map-type where we could provide an
;; algorithmically more efficient algorithm than the default.
(catch 'map--break
- (map-apply (lambda (key value)
+ (map-do (lambda (key value)
(or (funcall pred key value)
(throw 'map--break nil)))
map)
t))
(defun map-merge (type &rest maps)
- "Merge into a map of type TYPE all the key/value pairs in MAPS.
+ "Merge into a map of TYPE all the key/value pairs in MAPS.
See `map-into' for all supported values of TYPE."
(let ((result (map-into (pop maps) type)))
(while maps
@@ -347,73 +380,88 @@ See `map-into' for all supported values of TYPE."
;; For small tables, this is fine, but for large tables, we
;; should probably use a hash-table internally which we convert
;; to an alist in the end.
- (map-apply (lambda (key value)
- (setf (map-elt result key) value))
- (pop maps)))
+ (map-do (lambda (key value)
+ (setf (map-elt result key) value))
+ (pop maps)))
result))
(defun map-merge-with (type function &rest maps)
- "Merge into a map of type TYPE all the key/value pairs in MAPS.
-When two maps contain the same key (`eql'), call FUNCTION on the two
+ "Merge into a map of TYPE all the key/value pairs in MAPS.
+When two maps contain the same (`eql') key, call FUNCTION on the two
values and use the value returned by it.
-MAP can be a list, hash-table or array.
+Each of MAPS can be an alist, plist, hash-table, or array.
See `map-into' for all supported values of TYPE."
(let ((result (map-into (pop maps) type))
- (not-found (cons nil nil)))
+ (not-found (list nil)))
(while maps
- (map-apply (lambda (key value)
- (cl-callf (lambda (old)
- (if (eql old not-found)
- value
- (funcall function old value)))
- (map-elt result key not-found)))
- (pop maps)))
+ (map-do (lambda (key value)
+ (cl-callf (lambda (old)
+ (if (eql old not-found)
+ value
+ (funcall function old value)))
+ (map-elt result key not-found)))
+ (pop maps)))
result))
(cl-defgeneric map-into (map type)
- "Convert the map MAP into a map of type TYPE.")
+ "Convert MAP into a map of TYPE.")
+
;; FIXME: I wish there was a way to avoid this η-redex!
-(cl-defmethod map-into (map (_type (eql list))) (map-pairs map))
-(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map))
+(cl-defmethod map-into (map (_type (eql list)))
+ "Convert MAP into an alist."
+ (map-pairs map))
+
+(cl-defmethod map-into (map (_type (eql alist)))
+ "Convert MAP into an alist."
+ (map-pairs map))
+
(cl-defmethod map-into (map (_type (eql plist)))
- (let ((plist '()))
- (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map)
- plist))
+ "Convert MAP into a plist."
+ (let (plist)
+ (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map)
+ (nreverse plist)))
(cl-defgeneric map-put! (map key value &optional testfn)
"Associate KEY with VALUE in MAP.
If KEY is already present in MAP, replace the associated value
with VALUE.
This operates by modifying MAP in place.
-If it cannot do that, it signals the `map-not-inplace' error.
-If you want to insert an element without modifying MAP, use `map-insert'."
+If it cannot do that, it signals a `map-not-inplace' error.
+To insert an element without modifying MAP, use `map-insert'."
;; `testfn' only exists for backward compatibility with `map-put'!
(declare (advertised-calling-convention (map key value) "27.1"))
- (map--dispatch map
- :list
- (if (map--plist-p map)
- (plist-put map key value)
- (let ((oldmap map))
- (setf (alist-get key map key nil (or testfn #'equal)) value)
- (unless (eq oldmap map)
- (signal 'map-not-inplace (list oldmap)))))
- :hash-table (puthash key value map)
- ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
- ;; and let `map-insert' grow the array?
- :array (aset map key value)))
-
-(define-error 'map-inplace "Can only modify map in place")
+ ;; Can't use `cl-defmethod' with `advertised-calling-convention'.
+ (map--dispatch
+ map
+ :list
+ (progn
+ (if (map--plist-p map)
+ (plist-put map key value)
+ (let ((oldmap map))
+ (setf (alist-get key map key nil (or testfn #'equal)) value)
+ (unless (eq oldmap map)
+ (signal 'map-not-inplace (list oldmap)))))
+ ;; Always return the value.
+ value)
+ :hash-table (puthash key value map)
+ ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
+ ;; and let `map-insert' grow the array?
+ :array (aset map key value)))
(cl-defgeneric map-insert (map key value)
"Return a new map like MAP except that it associates KEY with VALUE.
This does not modify MAP.
-If you want to insert an element in place, use `map-put!'."
- (if (listp map)
- (if (map--plist-p map)
- `(,key ,value ,@map)
- (cons (cons key value) map))
- ;; FIXME: Should we signal an error or use copy+put! ?
- (signal 'map-inplace (list map))))
+If you want to insert an element in place, use `map-put!'.
+The default implementation defaults to `map-copy' and `map-put!'."
+ (let ((copy (map-copy map)))
+ (map-put! copy key value)
+ copy))
+
+(cl-defmethod map-insert ((map list) key value)
+ "Cons KEY and VALUE to the front of MAP."
+ (if (map--plist-p map)
+ (cons key (cons value map))
+ (cons (cons key value) map)))
;; There shouldn't be old source code referring to `map--put', yet we do
;; need to keep it for backward compatibility with .elc files where the
@@ -423,11 +471,9 @@ If you want to insert an element in place, use `map-put!'."
(cl-defmethod map-apply (function (map list))
(if (map--plist-p map)
(cl-call-next-method)
- (seq-map (lambda (pair)
- (funcall function
- (car pair)
- (cdr pair)))
- map)))
+ (mapcar (lambda (pair)
+ (funcall function (car pair) (cdr pair)))
+ map)))
(cl-defmethod map-apply (function (map hash-table))
(let (result)
@@ -437,46 +483,40 @@ If you want to insert an element in place, use `map-put!'."
(nreverse result)))
(cl-defmethod map-apply (function (map array))
- (let ((index 0))
- (seq-map (lambda (elt)
- (prog1
- (funcall function index elt)
- (setq index (1+ index))))
- map)))
+ (seq-map-indexed (lambda (elt index)
+ (funcall function index elt))
+ map))
(cl-defmethod map-do (function (map list))
- "Private function used to iterate over ALIST using FUNCTION."
(if (map--plist-p map)
(while map
(funcall function (pop map) (pop map)))
- (seq-do (lambda (pair)
- (funcall function
- (car pair)
- (cdr pair)))
- map)))
+ (mapc (lambda (pair)
+ (funcall function (car pair) (cdr pair)))
+ map)
+ nil))
-(cl-defmethod map-do (function (array array))
- "Private function used to iterate over ARRAY using FUNCTION."
+(cl-defmethod map-do (function (map array))
(seq-do-indexed (lambda (elt index)
- (funcall function index elt))
- array))
+ (funcall function index elt))
+ map))
(defun map--into-hash (map keyword-args)
"Convert MAP into a hash-table.
KEYWORD-ARGS are forwarded to `make-hash-table'."
(let ((ht (apply #'make-hash-table keyword-args)))
- (map-apply (lambda (key value)
- (setf (gethash key ht) value))
- map)
+ (map-do (lambda (key value)
+ (puthash key value ht))
+ map)
ht))
(cl-defmethod map-into (map (_type (eql hash-table)))
- "Convert MAP into a hash-table."
- (map--into-hash map (list :size (map-length map) :test 'equal)))
+ "Convert MAP into a hash-table with keys compared with `equal'."
+ (map--into-hash map (list :size (map-length map) :test #'equal)))
(cl-defmethod map-into (map (type (head hash-table)))
"Convert MAP into a hash-table.
-TYPE is a list where the car is `hash-table' and the cdr are the
+TYPE is a list whose car is `hash-table' and cdr a list of
keyword-args forwarded to `make-hash-table'.
Example:
@@ -485,20 +525,23 @@ Example:
(defun map--make-pcase-bindings (args)
"Return a list of pcase bindings from ARGS to the elements of a map."
- (seq-map (lambda (elt)
- (if (consp elt)
- `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))
- `(app (pcase--flip map-elt ',elt) ,elt)))
- args))
+ (mapcar (lambda (elt)
+ (cond ((consp elt)
+ `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)))
+ ((keywordp elt)
+ (let ((var (intern (substring (symbol-name elt) 1))))
+ `(app (pcase--flip map-elt ,elt) ,var)))
+ (t `(app (pcase--flip map-elt ',elt) ,elt))))
+ args))
(defun map--make-pcase-patterns (args)
"Return a list of `(map ...)' pcase patterns built from ARGS."
(cons 'map
- (seq-map (lambda (elt)
- (if (and (consp elt) (eq 'map (car elt)))
- (map--make-pcase-patterns elt)
- elt))
- args)))
+ (mapcar (lambda (elt)
+ (if (eq (car-safe elt) 'map)
+ (map--make-pcase-patterns elt)
+ elt))
+ args)))
(provide 'map)
;;; map.el ends here
diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
new file mode 100644
index 00000000000..1125dde4055
--- /dev/null
+++ b/lisp/emacs-lisp/memory-report.el
@@ -0,0 +1,319 @@
+;;; memory-report.el --- Short function summaries -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Keywords: lisp, help
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Todo (possibly): Font cache, regexp cache, bidi cache, various
+;; buffer caches (newline cache, free_region_cache, etc), composition
+;; cache, face cache.
+
+;;; Code:
+
+(require 'seq)
+(require 'subr-x)
+(eval-when-compile (require 'cl-lib))
+
+(defvar memory-report--type-size (make-hash-table))
+
+;;;###autoload
+(defun memory-report ()
+ "Generate a report of how Emacs is using memory.
+
+This report is approximate, and will commonly over-count memory
+usage by variables, because shared data structures will usually
+by counted more than once."
+ (interactive)
+ (pop-to-buffer "*Memory Report*")
+ (special-mode)
+ (button-mode 1)
+ (setq-local revert-buffer-function (lambda (_ignore-auto _noconfirm)
+ (memory-report)))
+ (setq truncate-lines t)
+ (message "Gathering data...")
+ (let ((reports (append (memory-report--garbage-collect)
+ (memory-report--image-cache)
+ (memory-report--symbol-plist)
+ (memory-report--buffers)
+ (memory-report--largest-variables)))
+ (inhibit-read-only t)
+ summaries details)
+ (message "Gathering data...done")
+ (erase-buffer)
+ (insert (propertize "Estimated Emacs Memory Usage\n\n" 'face 'bold))
+ (dolist (report reports)
+ (if (listp report)
+ (push report summaries)
+ (push report details)))
+ (dolist (summary (seq-sort (lambda (e1 e2)
+ (> (cdr e1) (cdr e2)))
+ summaries))
+ (insert (format "%s %s\n"
+ (memory-report--format (cdr summary))
+ (car summary))))
+ (insert "\n")
+ (dolist (detail (nreverse details))
+ (insert detail "\n")))
+ (goto-char (point-min)))
+
+(defun memory-report-object-size (object)
+ "Return the size of OBJECT in bytes."
+ (unless memory-report--type-size
+ (memory-report--garbage-collect))
+ (memory-report--object-size (make-hash-table :test #'eq) object))
+
+(defun memory-report--size (type)
+ (or (gethash type memory-report--type-size)
+ (gethash 'object memory-report--type-size)))
+
+(defun memory-report--set-size (elems)
+ (setf (gethash 'string memory-report--type-size)
+ (cadr (assq 'strings elems)))
+ (setf (gethash 'cons memory-report--type-size)
+ (cadr (assq 'conses elems)))
+ (setf (gethash 'symbol memory-report--type-size)
+ (cadr (assq 'symbols elems)))
+ (setf (gethash 'object memory-report--type-size)
+ (cadr (assq 'vectors elems)))
+ (setf (gethash 'float memory-report--type-size)
+ (cadr (assq 'floats elems)))
+ (setf (gethash 'buffer memory-report--type-size)
+ (cadr (assq 'buffers elems))))
+
+(defun memory-report--garbage-collect ()
+ (let ((elems (garbage-collect)))
+ (memory-report--set-size elems)
+ (let ((data (list
+ (list 'strings
+ (+ (memory-report--gc-elem elems 'strings)
+ (memory-report--gc-elem elems 'string-bytes)))
+ (list 'vectors
+ (+ (memory-report--gc-elem elems 'vectors)
+ (memory-report--gc-elem elems 'vector-slots)))
+ (list 'floats (memory-report--gc-elem elems 'floats))
+ (list 'conses (memory-report--gc-elem elems 'conses))
+ (list 'symbols (memory-report--gc-elem elems 'symbols))
+ (list 'intervals (memory-report--gc-elem elems 'intervals))
+ (list 'buffer-objects
+ (memory-report--gc-elem elems 'buffers)))))
+ (list (cons "Overall Object Memory Usage"
+ (seq-reduce #'+ (mapcar (lambda (elem)
+ (* (nth 1 elem) (nth 2 elem)))
+ elems)
+ 0))
+ (cons "Reserved (But Unused) Object Memory"
+ (seq-reduce #'+ (mapcar (lambda (elem)
+ (if (nth 3 elem)
+ (* (nth 1 elem) (nth 3 elem))
+ 0))
+ elems)
+ 0))
+ (with-temp-buffer
+ (insert (propertize "Object Storage\n\n" 'face 'bold))
+ (dolist (object (seq-sort (lambda (e1 e2)
+ (> (cadr e1) (cadr e2)))
+ data))
+ (insert (format "%s %s\n"
+ (memory-report--format (cadr object))
+ (capitalize (symbol-name (car object))))))
+ (buffer-string))))))
+
+(defun memory-report--largest-variables ()
+ (let ((variables nil))
+ (mapatoms
+ (lambda (symbol)
+ (when (boundp symbol)
+ (let ((size (memory-report--object-size
+ (make-hash-table :test #'eq)
+ (symbol-value symbol))))
+ (when (> size 1000)
+ (push (cons symbol size) variables)))))
+ obarray)
+ (list
+ (cons (propertize "Memory Used By Global Variables"
+ 'help-echo "Upper bound; mutually overlapping data from different variables are counted several times")
+ (seq-reduce #'+ (mapcar #'cdr variables) 0))
+ (with-temp-buffer
+ (insert (propertize "Largest Variables\n\n" 'face 'bold))
+ (cl-loop for i from 1 upto 20
+ for (symbol . size) in (seq-sort (lambda (e1 e2)
+ (> (cdr e1) (cdr e2)))
+ variables)
+ do (insert (memory-report--format size)
+ " "
+ (symbol-name symbol)
+ "\n"))
+ (buffer-string)))))
+
+(defun memory-report--symbol-plist ()
+ (let ((counted (make-hash-table :test #'eq))
+ (total 0))
+ (mapatoms
+ (lambda (symbol)
+ (cl-incf total (memory-report--object-size
+ counted (symbol-plist symbol))))
+ obarray)
+ (list
+ (cons "Memory Used By Symbol Plists" total))))
+
+(defun memory-report--object-size (counted value)
+ (if (gethash value counted)
+ 0
+ (setf (gethash value counted) t)
+ (memory-report--object-size-1 counted value)))
+
+(cl-defgeneric memory-report--object-size-1 (_counted _value)
+ 0)
+
+(cl-defmethod memory-report--object-size-1 (_ (value symbol))
+ ;; Don't count global symbols -- makes sizes of lists of symbols too
+ ;; heavy.
+ (if (intern-soft value obarray)
+ 0
+ (memory-report--size 'symbol)))
+
+(cl-defmethod memory-report--object-size-1 (_ (_value buffer))
+ (memory-report--size 'buffer))
+
+(cl-defmethod memory-report--object-size-1 (counted (value string))
+ (+ (memory-report--size 'string)
+ (string-bytes value)
+ (memory-report--interval-size counted (object-intervals value))))
+
+(defun memory-report--interval-size (counted intervals)
+ ;; We get a list back of intervals, but only count the "inner list"
+ ;; (i.e., the actual text properties), and add the size of the
+ ;; intervals themselves.
+ (+ (* (memory-report--size 'interval) (length intervals))
+ (seq-reduce #'+ (mapcar
+ (lambda (interval)
+ (memory-report--object-size counted (nth 2 interval)))
+ intervals)
+ 0)))
+
+(cl-defmethod memory-report--object-size-1 (counted (value list))
+ (let ((total 0)
+ (size (memory-report--size 'cons)))
+ (while value
+ (cl-incf total size)
+ (setf (gethash value counted) t)
+ (when (car value)
+ (cl-incf total (memory-report--object-size counted (car value))))
+ (let ((next (cdr value)))
+ (setq value (when next
+ (if (consp next)
+ (unless (gethash next counted)
+ (cdr value))
+ (cl-incf total (memory-report--object-size
+ counted next))
+ nil)))))
+ total))
+
+(cl-defmethod memory-report--object-size-1 (counted (value vector))
+ (let ((total (+ (memory-report--size 'vector)
+ (* (memory-report--size 'object) (length value)))))
+ (cl-loop for elem across value
+ do (setf (gethash elem counted) t)
+ (cl-incf total (memory-report--object-size counted elem)))
+ total))
+
+(cl-defmethod memory-report--object-size-1 (counted (value hash-table))
+ (let ((total (+ (memory-report--size 'vector)
+ (* (memory-report--size 'object) (hash-table-size value)))))
+ (maphash
+ (lambda (key elem)
+ (setf (gethash key counted) t)
+ (setf (gethash elem counted) t)
+ (cl-incf total (memory-report--object-size counted key))
+ (cl-incf total (memory-report--object-size counted elem)))
+ value)
+ total))
+
+(defun memory-report--format (bytes)
+ (setq bytes (/ bytes 1024.0))
+ (let ((units '("KiB" "MiB" "GiB" "TiB")))
+ (while (>= bytes 1024)
+ (setq bytes (/ bytes 1024.0))
+ (setq units (cdr units)))
+ (format "%6.1f %s" bytes (car units))))
+
+(defun memory-report--gc-elem (elems type)
+ (* (nth 1 (assq type elems))
+ (nth 2 (assq type elems))))
+
+(defun memory-report--buffers ()
+ (let ((buffers (mapcar (lambda (buffer)
+ (cons buffer (memory-report--buffer buffer)))
+ (buffer-list))))
+ (list (cons "Total Buffer Memory Usage"
+ (seq-reduce #'+ (mapcar #'cdr buffers) 0))
+ (with-temp-buffer
+ (insert (propertize "Largest Buffers\n\n" 'face 'bold))
+ (cl-loop for i from 1 upto 20
+ for (buffer . size) in (seq-sort (lambda (e1 e2)
+ (> (cdr e1) (cdr e2)))
+ buffers)
+ do (insert (memory-report--format size)
+ " "
+ (button-buttonize
+ (buffer-name buffer)
+ #'memory-report--buffer-details buffer)
+ "\n"))
+ (buffer-string)))))
+
+(defun memory-report--buffer-details (buffer)
+ (with-current-buffer buffer
+ (apply
+ #'message
+ "Buffer text: %s; variables: %s; text properties: %s; overlays: %s"
+ (mapcar #'string-trim (mapcar #'memory-report--format
+ (memory-report--buffer-data buffer))))))
+
+(defun memory-report--buffer (buffer)
+ (seq-reduce #'+ (memory-report--buffer-data buffer) 0))
+
+(defun memory-report--buffer-data (buffer)
+ (with-current-buffer buffer
+ (list (save-restriction
+ (widen)
+ (+ (position-bytes (point-max))
+ (- (position-bytes (point-min)))
+ (gap-size)))
+ (seq-reduce #'+ (mapcar (lambda (elem)
+ (if (and (consp elem) (cdr elem))
+ (memory-report--object-size
+ (make-hash-table :test #'eq)
+ (cdr elem))
+ 0))
+ (buffer-local-variables buffer))
+ 0)
+ (memory-report--object-size (make-hash-table :test #'eq)
+ (object-intervals buffer))
+ (memory-report--object-size (make-hash-table :test #'eq)
+ (overlay-lists)))))
+
+(defun memory-report--image-cache ()
+ (list (cons "Total Image Cache Size" (if (fboundp 'image-cache-size)
+ (image-cache-size)
+ 0))))
+
+(provide 'memory-report)
+
+;;; memory-report.el ends here
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index ca60a041cf2..4804e859ebe 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -5,18 +5,20 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions, lisp, tools
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -314,8 +316,26 @@ is also interactive. There are 3 cases:
`(advice--add-function ,where (gv-ref ,(advice--normalize-place place))
,function ,props))
+(declare-function comp-subr-trampoline-install "comp")
+
;;;###autoload
(defun advice--add-function (where ref function props)
+ (when (and (featurep 'native-compile)
+ (subr-primitive-p (gv-deref ref)))
+ (let ((subr-name (intern (subr-name (gv-deref ref)))))
+ ;; Requiring the native compiler to advice `macroexpand' cause a
+ ;; circular dependency in eager macro expansion. uniquify is
+ ;; advising `rename-buffer' while being loaded in loadup.el.
+ ;; This would require the whole native compiler machinery but we
+ ;; don't want to include it in the dump. Because these two
+ ;; functions are already handled in
+ ;; `native-comp-never-optimize-functions' we hack the problem
+ ;; this way for now :/
+ (unless (memq subr-name '(macroexpand rename-buffer))
+ ;; Must require explicitly as during bootstrap we have no
+ ;; autoloads.
+ (require 'comp)
+ (comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref))))
(when a
@@ -483,7 +503,7 @@ arguments. Note if NAME is nil the advice is anonymous;
otherwise it is named `SYMBOL@NAME'.
\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)"
- (declare (indent 2) (doc-string 3) (debug (sexp sexp body)))
+ (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body)))
(or (listp args) (signal 'wrong-type-argument (list 'listp args)))
(or (<= 2 (length args) 4)
(signal 'wrong-number-of-arguments (list 2 4 (length args))))
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index 8a0853ce445..2e327d16de4 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -1,4 +1,4 @@
-;;; package-x.el --- Package extras
+;;; package-x.el --- Package extras -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -182,8 +182,7 @@ if it exists."
;; 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))))
+ (custom--standard-value 'package-archive-upload-base)))
(setq package-archive-upload-base
(read-directory-name
"Base directory for package archive: ")))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index ecb2573cab7..f1daa8d124a 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -73,9 +73,9 @@
;; 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.
+;; then "x" to execute) or deletion, 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
@@ -89,7 +89,7 @@
;; 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.
+;; formatted as with `package-install-from-buffer'.
;;; Thanks:
;;; (sorted by sort-lines):
@@ -173,12 +173,12 @@ with \"-q\").
Even if the value is nil, you can type \\[package-initialize] to
make installed packages available at any time, or you can
-call (package-initialize) in your init-file."
+call (package-activate-all) in your init-file."
:type 'boolean
:version "24.1")
(defcustom package-load-list '(all)
- "List of packages for `package-initialize' to make available.
+ "List of packages for `package-activate-all' to make available.
Each element in this list should be a list (NAME VERSION), or the
symbol `all'. The symbol `all' says to make available the latest
installed versions of all packages not specified by other
@@ -203,6 +203,9 @@ If VERSION is nil, the package is not made available (it is \"disabled\")."
(defcustom package-archives `(("gnu" .
,(format "http%s://elpa.gnu.org/packages/"
+ (if (gnutls-available-p) "s" "")))
+ ("nongnu" .
+ ,(format "http%s://elpa.nongnu.org/nongnu/"
(if (gnutls-available-p) "s" ""))))
"An alist of archives from which to fetch.
The default value points to the GNU Emacs package repository.
@@ -222,7 +225,7 @@ security."
:type '(alist :key-type (string :tag "Archive name")
:value-type (string :tag "URL or directory name"))
:risky t
- :version "26.1") ; gnutls test
+ :version "28.1")
(defcustom package-menu-hide-low-priority 'archive
"If non-nil, hide low priority packages from the packages menu.
@@ -289,15 +292,18 @@ the package will be unavailable."
:risky t
:version "24.4")
+;;;###autoload
(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
+ :initialize #'custom-initialize-delay
:risky t
:version "24.1")
+;;;###autoload
(defcustom package-directory-list
;; Defaults are subdirs named "elpa" in the site-lisp dirs.
(let (result)
@@ -312,6 +318,7 @@ 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)
+ :initialize #'custom-initialize-delay
:risky t
:version "24.1")
@@ -389,6 +396,12 @@ a sane initial value."
:version "25.1"
:type '(repeat symbol))
+(defcustom package-native-compile nil
+ "Non-nil means to native compile packages on installation."
+ :type '(boolean)
+ :risky t
+ :version "28.1")
+
(defcustom package-menu-async t
"If non-nil, package-menu will use async operations when possible.
Currently, only the refreshing of archive contents supports
@@ -397,6 +410,26 @@ synchronously."
:type 'boolean
:version "25.1")
+(defcustom package-name-column-width 30
+ "Column width for the Package name in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-version-column-width 14
+ "Column width for the Package version in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-status-column-width 12
+ "Column width for the Package status in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-archive-column-width 8
+ "Column width for the Package status in the package menu."
+ :type 'number
+ :version "28.1")
+
;;; `package-desc' object definition
;; This is the struct used internally to represent packages.
@@ -421,9 +454,9 @@ synchronously."
&aux
(name (intern name-string))
(version (version-to-list version-string))
- (reqs (mapcar #'(lambda (elt)
- (list (car elt)
- (version-to-list (cadr elt))))
+ (reqs (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
(if (eq 'quote (car requirements))
(nth 1 requirements)
requirements)))
@@ -564,9 +597,8 @@ package."
;;; Installed packages
;; The following variables store information about packages present in
;; the system. The most important of these is `package-alist'. The
-;; command `package-initialize' is also closely related to this
-;; section, but it is left for a later section because it also affects
-;; other stuff.
+;; command `package-activate-all' is also closely related to this
+;; section.
(defvar package--builtins nil
"Alist of built-in packages.
@@ -585,7 +617,7 @@ name (a symbol) and DESCS is a non-empty list of `package-desc'
structures, sorted by decreasing versions.
This variable is set automatically by `package-load-descriptor',
-called via `package-initialize'. To change which packages are
+called via `package-activate-all'. To change which packages are
loaded and/or activated, customize `package-load-list'.")
(put 'package-alist 'risky-local-variable t)
@@ -670,9 +702,9 @@ updates `package-alist'."
(progn (package-load-all-descriptors)
package-alist)))
-(defun define-package (_name-string _version-string
- &optional _docstring _requirements
- &rest _extra-properties)
+(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.
@@ -798,49 +830,68 @@ correspond to previously loaded files (those returned by
;; FIXME: not the friendliest, but simple.
(require 'info)
(info-initialize)
- (push pkg-dir Info-directory-list))
+ (add-to-list 'Info-directory-list pkg-dir))
(push name package-activated-list)
;; Don't return nil.
t)))
-(declare-function find-library-name "find-func" (library))
+(defun package--files-load-history ()
+ (delq nil
+ (mapcar (lambda (x)
+ (let ((f (car x)))
+ (and (stringp f)
+ (file-name-sans-extension (file-truename f)))))
+ load-history)))
+
+(defun package--list-of-conflicts (dir history)
+ (require 'find-func)
+ (declare-function find-library-name "find-func" (library))
+ (delq
+ nil
+ (mapcar
+ (lambda (x) (let* ((file (file-relative-name x dir))
+ ;; Previously loaded file, if any.
+ (previous
+ (ignore-error file-error ;"Can't find library"
+ (file-name-sans-extension
+ (file-truename (find-library-name file)))))
+ (pos (when previous (member previous history))))
+ ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
+ (when pos
+ (cons (file-name-sans-extension file) (length pos)))))
+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))
(defun package--list-loaded-files (dir)
"Recursively list all files in DIR which correspond to loaded features.
Returns the `file-name-sans-extension' of each file, relative to
DIR, sorted by most recently loaded last."
- (let* ((history (delq nil
- (mapcar (lambda (x)
- (let ((f (car x)))
- (and (stringp f)
- (file-name-sans-extension f))))
- load-history)))
+ (let* ((history (package--files-load-history))
(dir (file-truename dir))
;; List all files that have already been loaded.
- (list-of-conflicts
- (delq
- nil
- (mapcar
- (lambda (x) (let* ((file (file-relative-name x dir))
- ;; Previously loaded file, if any.
- (previous
- (ignore-errors
- (file-name-sans-extension
- (file-truename (find-library-name file)))))
- (pos (when previous (member previous history))))
- ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
- (when pos
- (cons (file-name-sans-extension file) (length pos)))))
- (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))))
+ (list-of-conflicts (package--list-of-conflicts dir history)))
;; Turn the list of (FILENAME . POS) back into a list of features. Files in
;; subdirectories are returned relative to DIR (so not actually features).
(let ((default-directory (file-name-as-directory dir)))
(mapcar (lambda (x) (file-truename (car x)))
- (sort list-of-conflicts
- ;; Sort the files by ascending HISTORY-POSITION.
- (lambda (x y) (< (cdr x) (cdr y))))))))
+ (sort list-of-conflicts
+ ;; Sort the files by ascending HISTORY-POSITION.
+ (lambda (x y) (< (cdr x) (cdr y))))))))
;;;; `package-activate'
+
+(defun package--get-activatable-pkg (pkg-name)
+ ;; Is "activatable" a word?
+ (let ((pkg-descs (cdr (assq pkg-name package-alist))))
+ ;; Check if PACKAGE is available in `package-alist'.
+ (while
+ (when pkg-descs
+ (let ((available-version (package-desc-version (car pkg-descs))))
+ (or (package-disabled-p pkg-name available-version)
+ ;; Prefer a builtin package.
+ (package-built-in-p pkg-name available-version))))
+ (setq pkg-descs (cdr pkg-descs)))
+ (car pkg-descs)))
+
;; This function activates a newer version of a package if an older
;; one was already activated. It also loads a features of this
;; package which were already loaded.
@@ -848,24 +899,16 @@ DIR, sorted by most recently loaded last."
"Activate the package named PACKAGE.
If FORCE is true, (re-)activate it if it's already activated.
Newer versions are always activated, regardless of FORCE."
- (let ((pkg-descs (cdr (assq package package-alist))))
- ;; Check if PACKAGE is available in `package-alist'.
- (while
- (when pkg-descs
- (let ((available-version (package-desc-version (car pkg-descs))))
- (or (package-disabled-p package available-version)
- ;; Prefer a builtin package.
- (package-built-in-p package available-version))))
- (setq pkg-descs (cdr pkg-descs)))
+ (let ((pkg-desc (package--get-activatable-pkg package)))
(cond
;; If no such package is found, maybe it's built-in.
- ((null pkg-descs)
+ ((null pkg-desc)
(package-built-in-p package))
;; If the package is already activated, just return t.
((and (memq package package-activated-list) (not force))
t)
;; Otherwise, proceed with activation.
- (t (package-activate-1 (car pkg-descs) nil 'deps)))))
+ (t (package-activate-1 pkg-desc nil 'deps)))))
;;; Installation -- Local operations
@@ -926,7 +969,6 @@ untar into a directory named DIR; otherwise, signal an error."
(if (> (length file-list) 1) 'tar 'single))))
('tar
(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)))
('single
@@ -949,6 +991,8 @@ untar into a directory named DIR; otherwise, signal an error."
;; E.g. for multi-package installs, we should first install all packages
;; and then compile them.
(package--compile new-desc)
+ (when package-native-compile
+ (package--native-compile-async new-desc))
;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions.
(package--load-files-for-activation new-desc :reload)))
@@ -995,7 +1039,6 @@ untar into a directory named DIR; otherwise, signal an error."
(write-region (autoload-rubric file "package" nil) nil file nil 'silent))
file)
-(defvar generated-autoload-file)
(defvar autoload-timestamps)
(defvar version-control)
@@ -1003,14 +1046,14 @@ untar into a directory named DIR; otherwise, signal an error."
"Generate autoloads in PKG-DIR for package named NAME."
(let* ((auto-name (format "%s-autoloads.el" name))
;;(ignore-name (concat name "-pkg.el"))
- (generated-autoload-file (expand-file-name auto-name pkg-dir))
+ (output-file (expand-file-name auto-name pkg-dir))
;; We don't need 'em, and this makes the output reproducible.
(autoload-timestamps nil)
(backup-inhibited t)
(version-control 'never))
- (package-autoload-ensure-default-file generated-autoload-file)
- (update-directory-autoloads pkg-dir)
- (let ((buf (find-buffer-visiting generated-autoload-file)))
+ (package-autoload-ensure-default-file output-file)
+ (make-directory-autoloads pkg-dir output-file)
+ (let ((buf (find-buffer-visiting output-file)))
(when buf (kill-buffer buf)))
auto-name))
@@ -1034,6 +1077,15 @@ This assumes that `pkg-desc' has already been activated with
(load-path load-path))
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
+(defun package--native-compile-async (pkg-desc)
+ "Native compile installed package PKG-DESC asynchronously.
+This assumes that `pkg-desc' has already been activated with
+`package-activate-1'."
+ (when (and (featurep 'native-compile)
+ (native-comp-available-p))
+ (let ((warning-minimum-level :error))
+ (native-compile-async (package-desc-dir pkg-desc) t))))
+
;;;; Inferring package from current buffer
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
@@ -1097,14 +1149,15 @@ boundaries."
;; Use some headers we've invented to drive the process.
(let* (;; 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"))))
+ (version-info
+ (or (lm-header "package-version") (lm-header "version")))
+ (pkg-version (package-strip-rcs-id version-info))
(keywords (lm-keywords-list))
(homepage (lm-homepage)))
(unless pkg-version
- (error
- "Package lacks a \"Version\" or \"Package-Version\" header"))
+ (if version-info
+ (error "Unrecognized package version: %s" version-info)
+ (error "Package lacks a \"Version\" or \"Package-Version\" header")))
(package-desc-from-define
file-name pkg-version desc
(and-let* ((require-lines (lm-header-multiline "package-requires")))
@@ -1201,8 +1254,8 @@ The return result is a `package-desc'."
cipher-algorithm
digest-algorithm
compress-algorithm))
-(declare-function epg-verify-string "epg" (context signature
- &optional signed-text))
+(declare-function epg-verify-string "epg" ( context signature
+ &optional signed-text))
(declare-function epg-context-result-for "epg" (context name))
(declare-function epg-signature-status "epg" (signature) t)
(declare-function epg-signature-to-string "epg" (signature))
@@ -1252,7 +1305,10 @@ is non-nil, don't propagate connection errors (does not apply to
errors signaled by ERROR-FORM or by BODY).
\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
- (declare (indent defun) (debug t))
+ (declare (indent defun)
+ ;; FIXME: This should be something like
+ ;; `form def-body &rest form', but that doesn't work.
+ (debug (form &rest sexp)))
(while (keywordp (car body))
(setq body (cdr (cdr body))))
`(package--with-response-buffer-1 ,url (lambda () ,@body)
@@ -1589,25 +1645,34 @@ that code in the early init-file."
;; `package--initialized' is t.
(package--build-compatibility-table))
-(defvar package-quickstart-file)
-
;;;###autoload
+(progn ;; Make the function usable without loading `package.el'.
(defun package-activate-all ()
"Activate all installed packages.
The variable `package-load-list' controls which packages to load."
(setq package--activated t)
- (if (file-readable-p package-quickstart-file)
- ;; Skip load-source-file-function which would slow us down by a factor
- ;; 2 (this assumes we were careful to save this file so it doesn't need
- ;; any decoding).
- (let ((load-source-file-function nil))
- (load package-quickstart-file nil 'nomessage))
- (dolist (elt (package--alist))
- (condition-case err
- (package-activate (car elt))
- ;; Don't let failure of activation of a package arbitrarily stop
- ;; activation of further packages.
- (error (message "%s" (error-message-string err)))))))
+ (let* ((elc (concat package-quickstart-file "c"))
+ (qs (if (file-readable-p elc) elc
+ (if (file-readable-p package-quickstart-file)
+ package-quickstart-file))))
+ (if qs
+ ;; Skip load-source-file-function which would slow us down by a factor
+ ;; 2 when loading the .el file (this assumes we were careful to
+ ;; save this file so it doesn't need any decoding).
+ (let ((load-source-file-function nil))
+ (unless (boundp 'package-activated-list)
+ (setq package-activated-list nil))
+ (load qs nil 'nomessage))
+ (require 'package)
+ (package--activate-all)))))
+
+(defun package--activate-all ()
+ (dolist (elt (package--alist))
+ (condition-case err
+ (package-activate (car elt))
+ ;; Don't let failure of activation of a package arbitrarily stop
+ ;; activation of further packages.
+ (error (message "%s" (error-message-string err))))))
;;;; Populating `package-archive-contents' from archives
;; This subsection populates the variables listed above from the
@@ -2035,6 +2100,13 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed
using `package-compute-transaction'."
(mapc #'package-install-from-archive packages))
+(defun package--archives-initialize ()
+ "Make sure the list of installed and remote packages are initialized."
+ (unless package--initialized
+ (package-initialize t))
+ (unless package-archive-contents
+ (package-refresh-contents)))
+
;;;###autoload
(defun package-install (pkg &optional dont-select)
"Install the package PKG.
@@ -2055,10 +2127,7 @@ to install it but still mark it as selected."
(progn
;; Initialize the package system to get the list of package
;; symbols for completion.
- (unless package--initialized
- (package-initialize t))
- (unless package-archive-contents
- (package-refresh-contents))
+ (package--archives-initialize)
(list (intern (completing-read
"Install package: "
(delq nil
@@ -2068,6 +2137,7 @@ to install it but still mark it as selected."
package-archive-contents))
nil t))
nil)))
+ (package--archives-initialize)
(add-hook 'post-command-hook #'package-menu--post-refresh)
(let ((name (if (package-desc-p pkg)
(package-desc-name pkg)
@@ -2083,7 +2153,8 @@ to install it but still mark it as selected."
(package-compute-transaction () (list (list pkg))))))
(progn
(package-download-transaction transaction)
- (package--quickstart-maybe-refresh))
+ (package--quickstart-maybe-refresh)
+ (message "Package `%s' installed." name))
(message "`%s' is already installed" name))))
(defun package-strip-rcs-id (str)
@@ -2093,8 +2164,10 @@ Otherwise return nil."
(when str
(when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
(setq str (substring str (match-end 0))))
- (ignore-errors
- (if (version-to-list str) str))))
+ (let ((l (version-to-list str)))
+ ;; Don't return `str' but (package-version-join (version-to-list str))
+ ;; to make sure we use a "canonical name"!
+ (if l (package-version-join l)))))
(declare-function lm-homepage "lisp-mnt" (&optional file))
@@ -2122,8 +2195,24 @@ Downloads and installs required packages as needed."
((derived-mode-p 'tar-mode)
(package-tar-file-info))
(t
- (save-excursion
- (package-buffer-info)))))
+ ;; Package headers should be parsed from decoded text
+ ;; (see Bug#48137) where possible.
+ (if (and (eq buffer-file-coding-system 'no-conversion)
+ buffer-file-name)
+ (let* ((package-buffer (current-buffer))
+ (decoding-system
+ (car (find-operation-coding-system
+ 'insert-file-contents
+ (cons buffer-file-name
+ package-buffer)))))
+ (with-temp-buffer
+ (insert-buffer-substring package-buffer)
+ (decode-coding-region (point-min) (point-max)
+ decoding-system)
+ (package-buffer-info)))
+
+ (save-excursion
+ (package-buffer-info))))))
(name (package-desc-name pkg-desc)))
;; Download and install the dependencies.
(let* ((requires (package-desc-reqs pkg-desc))
@@ -2134,6 +2223,7 @@ Downloads and installs required packages as needed."
(unless (package--user-selected-p name)
(package--save-selected-packages
(cons name package-selected-packages)))
+ (package--quickstart-maybe-refresh)
pkg-desc))
;;;###autoload
@@ -2148,14 +2238,18 @@ directory."
(setq default-directory file)
(dired-mode))
(insert-file-contents-literally file)
+ (set-visited-file-name file)
(when (string-match "\\.tar\\'" file) (tar-mode)))
(package-install-from-buffer)))
;;;###autoload
-(defun package-install-selected-packages ()
+(defun package-install-selected-packages (&optional noconfirm)
"Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them."
+If some packages are not installed, propose to install them.
+If optional argument NOCONFIRM is non-nil, don't ask for
+confirmation to install packages."
(interactive)
+ (package--archives-initialize)
;; We don't need to populate `package-selected-packages' before
;; using here, because the outcome is the same either way (nothing
;; gets installed).
@@ -2166,10 +2260,11 @@ If some packages are not installed propose to install them."
(difference (- (length not-installed) (length available))))
(cond
(available
- (when (y-or-n-p
- (format "Packages to install: %d (%s), proceed? "
- (length available)
- (mapconcat #'symbol-name available " ")))
+ (when (or noconfirm
+ (y-or-n-p
+ (format "Packages to install: %d (%s), proceed? "
+ (length available)
+ (mapconcat #'symbol-name available " "))))
(mapc (lambda (p) (package-install p 'dont-select)) available)))
((> difference 0)
(message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'"
@@ -2185,6 +2280,17 @@ If some packages are not installed propose to install them."
(equal (cadr (assq (package-desc-name pkg) package-alist))
pkg))
+(declare-function comp-el-to-eln-filename "comp.c")
+(defun package--delete-directory (dir)
+ "Delete DIR recursively.
+Clean-up the corresponding .eln files if Emacs is native
+compiled."
+ (when (featurep 'native-compile)
+ (cl-loop
+ for file in (directory-files-recursively dir "\\.el\\'")
+ do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
+ (delete-directory dir t))
+
(defun package-delete (pkg-desc &optional force nosave)
"Delete package PKG-DESC.
@@ -2237,7 +2343,7 @@ If NOSAVE is non-nil, the package is not removed from
(package-desc-name pkg-used-elsewhere-by)))
(t
(add-hook 'post-command-hook #'package-menu--post-refresh)
- (delete-directory dir t)
+ (package--delete-directory dir)
;; Remove NAME-VERSION.signed and NAME-readme.txt files.
;;
;; NAME-readme.txt files are no longer created, but they
@@ -2319,10 +2425,7 @@ will be deleted."
(setq guess nil))
(setq packages (mapcar #'symbol-name packages))
(let ((val
- (completing-read (if guess
- (format "Describe package (default %s): "
- guess)
- "Describe package: ")
+ (completing-read (format-prompt "Describe package" guess)
packages nil t nil nil (when guess
(symbol-name guess)))))
(list (and (> (length val) 0) (intern val)))))))
@@ -2378,18 +2481,9 @@ The description is read from the installed package files."
result
;; Look for Commentary header.
- (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc))
- srcdir)))
- (when (file-readable-p mainsrcfile)
- (with-temp-buffer
- (insert (or (lm-commentary mainsrcfile) ""))
- (goto-char (point-min))
- (when (re-search-forward "^;;; Commentary:\n" nil t)
- (replace-match ""))
- (while (re-search-forward "^\\(;+ ?\\)" nil t)
- (replace-match ""))
- (buffer-string))))
- )))
+ (lm-commentary (expand-file-name
+ (format "%s.el" (package-desc-name desc)) srcdir))
+ "")))
(defun describe-package-1 (pkg)
"Insert the package description for PKG.
@@ -2584,16 +2678,10 @@ Helper function for `describe-package'."
(if built-in
;; For built-in packages, get the description from the
;; Commentary header.
- (let ((fn (locate-file (format "%s.el" name) 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 ""))))
+ (insert (or (lm-commentary (locate-file (format "%s.el" name)
+ load-path
+ load-file-rep-suffixes))
+ ""))
(if (package-installed-p desc)
;; For installed packages, get the description from the
@@ -2630,8 +2718,7 @@ Used for the `action' property of buttons in the buffer created by
(when (y-or-n-p (format-message "Install package `%s'? "
(package-desc-full-name pkg-desc)))
(package-install pkg-desc nil)
- (revert-buffer nil t)
- (goto-char (point-min)))))
+ (describe-package (package-desc-name pkg-desc)))))
(defun package-delete-button-action (button)
"Run `package-delete' on the package BUTTON points to.
@@ -2641,8 +2728,7 @@ Used for the `action' property of buttons in the buffer created by
(when (y-or-n-p (format-message "Delete package `%s'? "
(package-desc-full-name pkg-desc)))
(package-delete pkg-desc)
- (revert-buffer nil t)
- (goto-char (point-min)))))
+ (describe-package (package-desc-name pkg-desc)))))
(defun package-keyword-button-action (button)
"Show filtered \"*Packages*\" buffer for BUTTON.
@@ -2658,9 +2744,9 @@ PROPERTIES are passed to `insert-text-button', for which this
function is a convenience wrapper used by `describe-package-1'."
(let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
(button-face (if (display-graphic-p)
- '(:box (:line-width 2 :color "dark grey")
- :background "light grey"
- :foreground "black")
+ (progn
+ (require 'cus-edit) ; for the custom-button face
+ 'custom-button)
'link)))
(apply #'insert-text-button button-text 'face button-face 'follow-link t
properties)))
@@ -2696,15 +2782,23 @@ either a full name or nil, and EMAIL is a valid email address."
(define-key map "i" 'package-menu-mark-install)
(define-key map "U" 'package-menu-mark-upgrades)
(define-key map "r" 'revert-buffer)
- (define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
- (define-key map (kbd "/ n") 'package-menu-filter-by-name)
- (define-key map (kbd "/ /") 'package-menu-clear-filter)
(define-key map "~" 'package-menu-mark-obsolete-for-deletion)
+ (define-key map "w" 'package-browse-url)
(define-key map "x" 'package-menu-execute)
(define-key map "h" 'package-menu-quick-help)
(define-key map "H" #'package-menu-hide-package)
(define-key map "?" 'package-menu-describe-package)
(define-key map "(" #'package-menu-toggle-hiding)
+ (define-key map (kbd "/ /") 'package-menu-clear-filter)
+ (define-key map (kbd "/ a") 'package-menu-filter-by-archive)
+ (define-key map (kbd "/ d") 'package-menu-filter-by-description)
+ (define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
+ (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description)
+ (define-key map (kbd "/ n") 'package-menu-filter-by-name)
+ (define-key map (kbd "/ s") 'package-menu-filter-by-status)
+ (define-key map (kbd "/ v") 'package-menu-filter-by-version)
+ (define-key map (kbd "/ m") 'package-menu-filter-marked)
+ (define-key map (kbd "/ u") 'package-menu-filter-upgradable)
map)
"Local keymap for `package-menu-mode' buffers.")
@@ -2712,6 +2806,8 @@ either a full name or nil, and EMAIL is a valid email address."
"Menu for `package-menu-mode'."
'("Package"
["Describe Package" package-menu-describe-package :help "Display information about this package"]
+ ["Open Package Homepage" package-browse-url
+ :help "Open the homepage of this package"]
["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
"--"
["Refresh Package List" revert-buffer
@@ -2730,8 +2826,15 @@ either a full name or nil, and EMAIL is a valid email address."
"--"
("Filter Packages"
+ ["Filter by Archive" package-menu-filter-by-archive :help "Filter packages by archive"]
+ ["Filter by Description" package-menu-filter-by-description :help "Filter packages by description"]
["Filter by Keyword" package-menu-filter-by-keyword :help "Filter packages by keyword"]
["Filter by Name" package-menu-filter-by-name :help "Filter packages by name"]
+ ["Filter by Name or Description" package-menu-filter-by-name-or-description
+ :help "Filter packages by name or description"]
+ ["Filter by Status" package-menu-filter-by-status :help "Filter packages by status"]
+ ["Filter by Version" package-menu-filter-by-version :help "Filter packages by version"]
+ ["Filter Marked" package-menu-filter-marked :help "Filter packages marked for upgrade"]
["Clear Filter" package-menu-clear-filter :help "Clear package list filter"])
["Hide by Regexp" package-menu-hide-package :help "Hide all packages matching a regexp"]
@@ -2754,15 +2857,16 @@ either a full name or nil, and EMAIL is a valid email address."
Letters do not insert themselves; instead, they are commands.
\\<package-menu-mode-map>
\\{package-menu-mode-map}"
+ :interactive nil
(setq mode-line-process '((package--downloads-in-progress ":Loading")
(package-menu--transaction-status
package-menu--transaction-status)))
(setq tabulated-list-format
- `[("Package" 18 package-menu--name-predicate)
- ("Version" 13 package-menu--version-predicate)
- ("Status" 10 package-menu--status-predicate)
+ `[("Package" ,package-name-column-width package-menu--name-predicate)
+ ("Version" ,package-version-column-width package-menu--version-predicate)
+ ("Status" ,package-status-column-width package-menu--status-predicate)
,@(if (cdr package-archives)
- '(("Archive" 10 package-menu--archive-predicate)))
+ `(("Archive" ,package-archive-column-width package-menu--archive-predicate)))
("Description" 0 package-menu--description-predicate)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
@@ -2876,7 +2980,7 @@ Installed obsolete packages are always displayed.")
Also hide packages whose name matches a regexp in user option
`package-hidden-regexps' (a list). To add regexps to this list,
use `package-menu-hide-package'."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(setq package-menu--hide-packages
(not package-menu--hide-packages))
@@ -3041,8 +3145,21 @@ When none are given, the package matches."
found)
t))
-(defun package-menu--generate (remember-pos packages &optional keywords)
- "Populate the Package Menu.
+(defun package-menu--display (remember-pos suffix)
+ "Display the Package Menu.
+If REMEMBER-POS is non-nil, keep point on the same entry.
+
+If SUFFIX is non-nil, append that to \"Package\" for the first
+column in the header line."
+ (setf (car (aref tabulated-list-format 0))
+ (if suffix
+ (concat "Package[" suffix "]")
+ "Package"))
+ (tabulated-list-init-header)
+ (tabulated-list-print remember-pos))
+
+(defun package-menu--generate (remember-pos &optional packages keywords)
+ "Populate and display 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.
@@ -3050,13 +3167,10 @@ or a list of package names (symbols) to display.
With KEYWORDS given, only packages with those keywords are
shown."
(package-menu--refresh packages keywords)
- (setf (car (aref tabulated-list-format 0))
- (if keywords
- (let ((filters (mapconcat #'identity keywords ",")))
- (concat "Package[" filters "]"))
- "Package"))
- (tabulated-list-init-header)
- (tabulated-list-print remember-pos))
+ (package-menu--display remember-pos
+ (when keywords
+ (let ((filters (mapconcat #'identity keywords ",")))
+ (concat "Package[" filters "]")))))
(defun package-menu--print-info (pkg)
"Return a package entry suitable for `tabulated-list-entries'.
@@ -3202,9 +3316,9 @@ To unhide a package, type
`\\[customize-variable] RET package-hidden-regexps'.
Type \\[package-menu-toggle-hiding] to toggle package hiding."
- (interactive)
- (package--ensure-package-menu-mode)
(declare (interactive-only "change `package-hidden-regexps' instead."))
+ (interactive nil package-menu-mode)
+ (package--ensure-package-menu-mode)
(let* ((name (when (derived-mode-p 'package-menu-mode)
(concat "\\`" (regexp-quote (symbol-name (package-desc-name
(tabulated-list-get-id))))
@@ -3227,7 +3341,7 @@ Type \\[package-menu-toggle-hiding] to toggle package hiding."
(defun package-menu-describe-package (&optional button)
"Describe the current package.
If optional arg BUTTON is non-nil, describe its associated package."
- (interactive)
+ (interactive nil package-menu-mode)
(let ((pkg-desc (if button (button-get button 'package-desc)
(tabulated-list-get-id))))
(if pkg-desc
@@ -3237,7 +3351,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
;; fixme numeric argument
(defun package-menu-mark-delete (&optional _num)
"Mark a package for deletion and move to the next line."
- (interactive "p")
+ (interactive "p" package-menu-mode)
(package--ensure-package-menu-mode)
(if (member (package-menu-get-status)
'("installed" "dependency" "obsolete" "unsigned"))
@@ -3246,7 +3360,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
(defun package-menu-mark-install (&optional _num)
"Mark a package for installation and move to the next line."
- (interactive "p")
+ (interactive "p" package-menu-mode)
(package--ensure-package-menu-mode)
(if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency"))
(tabulated-list-put-tag "I" t)
@@ -3254,20 +3368,20 @@ If optional arg BUTTON is non-nil, describe its associated package."
(defun package-menu-mark-unmark (&optional _num)
"Clear any marks on a package and move to the next line."
- (interactive "p")
+ (interactive "p" package-menu-mode)
(package--ensure-package-menu-mode)
(tabulated-list-put-tag " " t))
(defun package-menu-backup-unmark ()
"Back up one line and clear any marks on that package."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(forward-line -1)
(tabulated-list-put-tag " "))
(defun package-menu-mark-obsolete-for-deletion ()
"Mark all obsolete packages for deletion."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(save-excursion
(goto-char (point-min))
@@ -3277,7 +3391,8 @@ If optional arg BUTTON is non-nil, describe its associated package."
(forward-line 1)))))
(defvar package--quick-help-keys
- '(("install," "delete," "unmark," ("execute" . 1))
+ '((("mark for installation," . 9)
+ ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1))
("next," "previous")
("Hide-package," "(-toggle-hidden")
("g-refresh-contents," "/-filter," "help")))
@@ -3298,7 +3413,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
(defun package-menu-quick-help ()
"Show short key binding help for `package-menu-mode'.
The full list of keys can be viewed with \\[describe-mode]."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(message (mapconcat #'package--prettify-quick-help-key
package--quick-help-keys "\n")))
@@ -3394,7 +3509,7 @@ call will upgrade the package.
If there's an async refresh operation in progress, the flags will
be placed as part of `package-menu--post-refresh' instead of
immediately."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(if (not package--downloads-in-progress)
(package-menu--mark-upgrades-1)
@@ -3488,7 +3603,7 @@ packages list, respectively."
Packages marked for installation are downloaded and installed;
packages marked for deletion are removed.
Optional argument NOQUERY non-nil means do not ask the user to confirm."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(let (install-list delete-list cmd pkg-desc)
(save-excursion
@@ -3675,7 +3790,7 @@ short description."
(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)))
+ (pop-to-buffer-same-window buf)))
;;;###autoload
(defalias 'package-list-packages 'list-packages)
@@ -3700,52 +3815,256 @@ shown."
(select-window win)
(switch-to-buffer buf))))
+(defun package-menu--filter-by (predicate suffix)
+ "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header.
+PREDICATE is a function which will be called with one argument, a
+`package-desc' object, and returns t if that object should be
+listed in the Package Menu.
+
+SUFFIX is passed on to `package-menu--display' and is added to
+the header line of the first column."
+ ;; Update `tabulated-list-entries' so that it contains all
+ ;; packages before searching.
+ (package-menu--refresh t nil)
+ (let (found-entries)
+ (dolist (entry tabulated-list-entries)
+ (when (funcall predicate (car entry))
+ (push entry found-entries)))
+ (if found-entries
+ (progn
+ (setq tabulated-list-entries found-entries)
+ (package-menu--display t suffix))
+ (user-error "No packages found"))))
+
+(defun package-menu-filter-by-archive (archive)
+ "Filter the \"*Packages*\" buffer by ARCHIVE.
+Display only packages from package archive ARCHIVE.
+
+When called interactively, prompt for ARCHIVE, which can be a
+comma-separated string. If ARCHIVE is empty, show all packages.
+
+When called from Lisp, ARCHIVE can be a string or a list of
+strings. If ARCHIVE is nil or the empty string, show all
+packages."
+ (interactive (list (completing-read-multiple
+ "Filter by archive (comma separated): "
+ (mapcar #'car package-archives)))
+ package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (let ((re (if (listp archive)
+ (regexp-opt archive)
+ archive)))
+ (package-menu--filter-by (lambda (pkg-desc)
+ (let ((pkg-archive (package-desc-archive pkg-desc)))
+ (and pkg-archive
+ (string-match-p re pkg-archive))))
+ (concat "archive:" (if (listp archive)
+ (string-join archive ",")
+ archive)))))
+
+(defun package-menu-filter-by-description (description)
+ "Filter the \"*Packages*\" buffer by DESCRIPTION regexp.
+Display only packages with a description that matches regexp
+DESCRIPTION.
+
+When called interactively, prompt for DESCRIPTION.
+
+If DESCRIPTION is nil or the empty string, show all packages."
+ (interactive (list (read-regexp "Filter by description (regexp)"))
+ package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (if (or (not description) (string-empty-p description))
+ (package-menu--generate t t)
+ (package-menu--filter-by (lambda (pkg-desc)
+ (string-match description
+ (package-desc-summary pkg-desc)))
+ (format "desc:%s" description))))
+
(defun package-menu-filter-by-keyword (keyword)
"Filter the \"*Packages*\" buffer by KEYWORD.
-Show only those items that relate to the specified KEYWORD.
-
-KEYWORD can be a string or a list of strings. If it is a list, a
-package will be displayed if it matches any of the keywords.
-Interactively, it is a list of strings separated by commas.
-
-KEYWORD can also be used to filter by status or archive name by
-using keywords like \"arc:gnu\" and \"status:available\".
-Statuses available include \"incompat\", \"available\",
-\"built-in\" and \"installed\"."
- (interactive
- (list (completing-read-multiple
- "Keywords (comma separated): " (package-all-keywords))))
+Display only packages with specified KEYWORD.
+
+When called interactively, prompt for KEYWORD, which can be a
+comma-separated string. If KEYWORD is empty, show all packages.
+
+When called from Lisp, KEYWORD can be a string or a list of
+strings. If KEYWORD is nil or the empty string, show all
+packages."
+ (interactive (list (completing-read-multiple
+ "Keywords (comma separated): "
+ (package-all-keywords)))
+ package-menu-mode)
(package--ensure-package-menu-mode)
- (package-show-package-list t (if (stringp keyword)
- (list keyword)
- keyword)))
+ (when (stringp keyword)
+ (setq keyword (list keyword)))
+ (if (not keyword)
+ (package-menu--generate t t)
+ (package-menu--filter-by (lambda (pkg-desc)
+ (package--has-keyword-p pkg-desc keyword))
+ (concat "keyword:" (string-join keyword ",")))))
(define-obsolete-function-alias
'package-menu-filter #'package-menu-filter-by-keyword "27.1")
+(defun package-menu-filter-by-name-or-description (name-or-description)
+ "Filter the \"*Packages*\" buffer by NAME-OR-DESCRIPTION regexp.
+Display only packages with a name-or-description that matches regexp
+NAME-OR-DESCRIPTION.
+
+When called interactively, prompt for NAME-OR-DESCRIPTION.
+
+If NAME-OR-DESCRIPTION is nil or the empty string, show all
+packages."
+ (interactive (list (read-regexp "Filter by name or description (regexp)"))
+ package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (if (or (not name-or-description) (string-empty-p name-or-description))
+ (package-menu--generate t t)
+ (package-menu--filter-by (lambda (pkg-desc)
+ (or (string-match name-or-description
+ (package-desc-summary pkg-desc))
+ (string-match name-or-description
+ (symbol-name
+ (package-desc-name pkg-desc)))))
+ (format "name-or-desc:%s" name-or-description))))
+
(defun package-menu-filter-by-name (name)
- "Filter the \"*Packages*\" buffer by NAME.
-Show only those items whose name matches the regular expression
-NAME. If NAME is nil or the empty string, show all packages."
- (interactive (list (read-from-minibuffer "Filter by name (regexp): ")))
+ "Filter the \"*Packages*\" buffer by NAME regexp.
+Display only packages with name that matches regexp NAME.
+
+When called interactively, prompt for NAME.
+
+If NAME is nil or the empty string, show all packages."
+ (interactive (list (read-regexp "Filter by name (regexp)"))
+ package-menu-mode)
(package--ensure-package-menu-mode)
(if (or (not name) (string-empty-p name))
- (package-show-package-list t nil)
- ;; Update `tabulated-list-entries' so that it contains all
- ;; packages before searching.
- (package-menu--refresh t nil)
- (let (matched)
- (dolist (entry tabulated-list-entries)
- (let* ((pkg-name (package-desc-name (car entry))))
- (when (string-match name (symbol-name pkg-name))
- (push pkg-name matched))))
- (if matched
- (package-show-package-list matched nil)
- (user-error "No packages found")))))
+ (package-menu--generate t t)
+ (package-menu--filter-by (lambda (pkg-desc)
+ (string-match-p name (symbol-name
+ (package-desc-name pkg-desc))))
+ (format "name:%s" name))))
+
+(defun package-menu-filter-by-status (status)
+ "Filter the \"*Packages*\" buffer by STATUS.
+Display only packages with specified STATUS.
+
+When called interactively, prompt for STATUS, which can be a
+comma-separated string. If STATUS is empty, show all packages.
+
+When called from Lisp, STATUS can be a string or a list of
+strings. If STATUS is nil or the empty string, show all
+packages."
+ (interactive (list (completing-read "Filter by status: "
+ '("avail-obso"
+ "available"
+ "built-in"
+ "dependency"
+ "disabled"
+ "external"
+ "held"
+ "incompat"
+ "installed"
+ "new"
+ "unsigned")))
+ package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (if (or (not status) (string-empty-p status))
+ (package-menu--generate t t)
+ (let ((status-list
+ (if (listp status)
+ status
+ (split-string status ","))))
+ (package-menu--filter-by
+ (lambda (pkg-desc)
+ (member (package-desc-status pkg-desc) status-list))
+ (format "status:%s" (string-join status-list ","))))))
+
+(defun package-menu-filter-by-version (version predicate)
+ "Filter the \"*Packages*\" buffer by VERSION and PREDICATE.
+Display only packages with a matching version.
+
+When called interactively, prompt for one of the qualifiers `<',
+`>' or `=', and a package version. Show only packages that has a
+lower (`<'), equal (`=') or higher (`>') version than the
+specified one.
+
+When called from Lisp, VERSION should be a version string and
+PREDICATE should be the symbol `=', `<' or `>'.
+
+If VERSION is nil or the empty string, show all packages."
+ (interactive (let ((choice (intern
+ (char-to-string
+ (read-char-choice
+ "Filter by version? [Type =, <, > or q] "
+ '(?< ?> ?= ?q))))))
+ (if (eq choice 'q)
+ '(quit nil)
+ (list (read-from-minibuffer
+ (concat "Filter by version ("
+ (pcase choice
+ ('= "= equal to")
+ ('< "< less than")
+ ('> "> greater than"))
+ "): "))
+ choice)))
+ package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (unless (equal predicate 'quit)
+ (if (or (not version) (string-empty-p version))
+ (package-menu--generate t t)
+ (package-menu--filter-by
+ (let ((fun (pcase predicate
+ ('= #'version-list-=)
+ ('< #'version-list-<)
+ ('> (lambda (a b) (not (version-list-<= a b))))
+ (_ (error "Unknown predicate: %s" predicate))))
+ (ver (version-to-list version)))
+ (lambda (pkg-desc)
+ (funcall fun (package-desc-version pkg-desc) ver)))
+ (format "versions:%s%s" predicate version)))))
+
+(defun package-menu-filter-marked ()
+ "Filter \"*Packages*\" buffer by non-empty upgrade mark.
+Unlike other filters, this leaves the marks intact."
+ (interactive nil package-menu-mode)
+ (package--ensure-package-menu-mode)
+ (widen)
+ (let (found-entries mark pkg-id entry marks)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq mark (char-after))
+ (unless (eq mark ?\s)
+ (setq pkg-id (tabulated-list-get-id))
+ (setq entry (package-menu--print-info-simple pkg-id))
+ (push entry found-entries)
+ ;; remember the mark
+ (push (cons pkg-id mark) marks))
+ (forward-line))
+ (if found-entries
+ (progn
+ (setq tabulated-list-entries found-entries)
+ (package-menu--display t nil)
+ ;; redo the marks, but we must remember the marks!!
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq mark (cdr (assq (tabulated-list-get-id) marks)))
+ (tabulated-list-put-tag (char-to-string mark) t)))
+ (user-error "No packages found")))))
+
+(defun package-menu-filter-upgradable ()
+ "Filter \"*Packages*\" buffer to show only upgradable packages."
+ (interactive nil package-menu-mode)
+ (let ((pkgs (mapcar #'car (package-menu--find-upgrades))))
+ (package-menu--filter-by
+ (lambda (pkg)
+ (memql (package-desc-name pkg) pkgs))
+ "upgradable")))
(defun package-menu-clear-filter ()
"Clear any filter currently applied to the \"*Packages*\" buffer."
- (interactive)
+ (interactive nil package-menu-mode)
(package--ensure-package-menu-mode)
(package-menu--generate t t))
@@ -3766,10 +4085,7 @@ The return value is a string (or nil in case we can't find it)."
;; the version at compile time and hardcodes it into the .elc file!
(declare (pure t))
;; Hack alert!
- (let ((file
- (or (if (boundp 'byte-compile-current-file) byte-compile-current-file)
- load-file-name
- buffer-file-name)))
+ (let ((file (or (macroexp-file-name) buffer-file-name)))
(cond
((null file) nil)
;; Packages are normally installed into directories named "<pkg>-<vers>",
@@ -3790,6 +4106,7 @@ The return value is a string (or nil in case we can't find it)."
(or (lm-header "package-version")
(lm-header "version")))))))))
+
;;;; Quickstart: precompute activation actions for faster start up.
;; Activating packages via `package-initialize' is costly: for N installed
@@ -3811,10 +4128,12 @@ activations need to be changed, such as when `package-load-list' is modified."
:type 'boolean
:version "27.1")
+;;;###autoload
(defcustom package-quickstart-file
(locate-user-emacs-file "package-quickstart.el")
"Location of the file used to speed up activation of packages at startup."
:type 'file
+ :initialize #'custom-initialize-delay
:version "27.1")
(defun package--quickstart-maybe-refresh ()
@@ -3822,6 +4141,7 @@ activations need to be changed, such as when `package-load-list' is modified."
;; FIXME: Delay refresh in case we're installing/deleting
;; several packages!
(package-quickstart-refresh)
+ (delete-file (concat package-quickstart-file "c"))
(delete-file package-quickstart-file)))
(defun package-quickstart-refresh ()
@@ -3852,7 +4172,8 @@ activations need to be changed, such as when `package-load-list' is modified."
(let ((load-suffixes '(".el" ".elc")))
(locate-library (package--autoloads-file-name pkg))))
(pfile (prin1-to-string file)))
- (insert "(let ((load-file-name " pfile "))\n")
+ (insert "(let ((load-true-file-name " pfile ")\
+(load-file-name " pfile "))\n")
(insert-file-contents file)
;; Fixup the special #$ reader form and throw away comments.
(while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
@@ -3876,10 +4197,12 @@ activations need to be changed, such as when `package-load-list' is modified."
(insert "
;; Local\sVariables:
;; version-control: never
-;;\sno-byte-compile: t
;; no-update-autoloads: t
;; End:
-"))))
+"))
+ ;; FIXME: Do it asynchronously in an Emacs subprocess, and
+ ;; don't show the byte-compiler warnings.
+ (byte-compile-file package-quickstart-file)))
(defun package--imenu-prev-index-position-function ()
"Move point to previous line in package-menu buffer.
@@ -3899,6 +4222,31 @@ beginning of the line."
(package-version-join (package-desc-version package-desc))
(package-desc-summary package-desc))))
+(defun package-browse-url (desc &optional secondary)
+ "Open the home page of the package under point in a browser.
+`browse-url' is used to determine the browser to be used.
+If SECONDARY (interactively, the prefix), use the secondary browser."
+ (interactive (list (tabulated-list-get-id)
+ current-prefix-arg)
+ package-menu-mode)
+ (unless desc
+ (user-error "No package here"))
+ (let ((url (cdr (assoc :url (package-desc-extras desc)))))
+ (unless url
+ (user-error "No home page for %s" (package-desc-name desc)))
+ (if secondary
+ (funcall browse-url-secondary-browser-function url)
+ (browse-url url))))
+
+;;;; Introspection
+
+(defun package-get-descriptor (pkg-name)
+ "Return the `package-desc' of PKG-NAME."
+ (unless package--initialized (package-initialize 'no-activate))
+ (or (package--get-activatable-pkg pkg-name)
+ (cadr (assq pkg-name package-alist))
+ (cadr (assq pkg-name package-archive-contents))))
+
(provide 'package)
;;; package.el ends here
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 9656053ca12..006517db759 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
+;; Keywords: extensions
;; This file is part of GNU Emacs.
@@ -27,22 +27,13 @@
;; 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.
+;; - Allow to provide new `pcase--split-<foo>' thingy.
;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound.
-;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
-;; this :-()
+;; - provide a way to continue matching to subsequent cases
+;; (e.g. Like Racket's (=> ID).
;; - 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:
+;; to reduce the number of leaves that need to be turned into functions:
;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better do it first so it's shared).
;; - then choose the test that discriminates more (?).
@@ -71,44 +62,37 @@
(defvar pcase--dontwarn-upats '(pcase--dontcare))
-(def-edebug-spec
- pcase-PAT
- (&or symbolp
- ("or" &rest pcase-PAT)
- ("and" &rest pcase-PAT)
- ("guard" form)
- ("let" pcase-PAT form)
- ("pred" pcase-FUN)
- ("app" pcase-FUN pcase-PAT)
- pcase-MACRO
- sexp))
-
-(def-edebug-spec
- pcase-FUN
- (&or lambda-expr
- ;; Punt on macros/special forms.
- (functionp &rest form)
- sexp))
-
-;; See bug#24717
-(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro)
+(def-edebug-elem-spec 'pcase-PAT
+ '(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp))
+
+(def-edebug-elem-spec 'pcase-FUN
+ '(&or lambda-expr
+ ;; Punt on macros/special forms.
+ (functionp &rest form)
+ sexp))
;; Only called from edebug.
-(declare-function get-edebug-spec "edebug" (symbol))
-(declare-function edebug-match "edebug" (cursor specs))
-
-(defun pcase--edebug-match-macro (cursor)
- (let (specs)
- (mapatoms
- (lambda (s)
- (let ((m (get s 'pcase-macroexpander)))
- (when (and m (get-edebug-spec m))
- (push (cons (symbol-name s) (get-edebug-spec m))
- specs)))))
- (edebug-match cursor (cons '&or specs))))
+(declare-function edebug-get-spec "edebug" (symbol))
+(defun pcase--edebug-match-pat-args (head pf)
+ ;; (cl-assert (null (cdr head)))
+ (setq head (car head))
+ (or (alist-get head '((quote sexp)
+ (or &rest pcase-PAT)
+ (and &rest pcase-PAT)
+ (guard form)
+ (pred &or ("not" pcase-FUN) pcase-FUN)
+ (app pcase-FUN pcase-PAT)))
+ (let ((me (pcase--get-macroexpander head)))
+ (funcall pf (and me (symbolp me) (edebug-get-spec me))))))
+
+(defun pcase--get-macroexpander (s)
+ "Return the macroexpander for pcase pattern head S, or nil"
+ (get s 'pcase-macroexpander))
;;;###autoload
(defmacro pcase (exp &rest cases)
+ ;; FIXME: Add some "global pattern" to wrap every case?
+ ;; Could be used to wrap all cases in a `
"Evaluate EXP to get EXPVAL; try passing control to one of CASES.
CASES is a list of elements of the form (PATTERN CODE...).
For the first CASE whose PATTERN \"matches\" EXPVAL,
@@ -128,9 +112,9 @@ PATTERN matches. PATTERN can take one of the forms:
If a SYMBOL is used twice in the same pattern
the second occurrence becomes an `eq'uality test.
(pred FUN) matches if FUN called on EXPVAL returns non-nil.
+ (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
(app FUN PAT) matches if FUN called on EXPVAL matches PAT.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
- (let PAT EXPR) matches if EXPR matches PAT.
(and PAT...) matches if all the patterns match.
(or PAT...) matches if any of the patterns matches.
@@ -140,7 +124,7 @@ FUN in `pred' and `app' can take one of the forms:
(F ARG1 .. ARGn)
call F with ARG1..ARGn and EXPVAL as n+1'th argument
-FUN, BOOLEXP, EXPR, and subsequent PAT can refer to variables
+FUN, BOOLEXP, and subsequent PAT can refer to variables
bound earlier in the pattern by a SYMBOL pattern.
Additional patterns can be defined using `pcase-defmacro'.
@@ -193,7 +177,7 @@ Emacs Lisp manual for more information and examples."
(let (more)
;; Collect all the extensions.
(mapatoms (lambda (symbol)
- (let ((me (get symbol 'pcase-macroexpander)))
+ (let ((me (pcase--get-macroexpander symbol)))
(when me
(push (cons symbol me)
more)))))
@@ -223,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled."
(pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
(pcase--expand
;; FIXME: Could we add the FILE:LINE data in the error message?
+ ;; FILE is available from `macroexp-file-name'.
exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
;;;###autoload
@@ -336,77 +321,124 @@ of the elements of LIST is performed as if by `pcase-let'.
(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))
+(defun pcase-compile-patterns (exp cases)
+ "Compile the set of patterns in CASES.
+EXP is the expression that will be matched against the patterns.
+CASES is a list of elements (PAT . CODEGEN)
+where CODEGEN is a function that returns the code to use when
+PAT matches. That code has to be in the form of a cons cell.
+
+CODEGEN will be called with at least 2 arguments, VARVALS and COUNT.
+VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR
+is a variable bound by the pattern and VAL is a duplicable expression
+that returns the value this variable should be bound to.
+If the pattern PAT uses `or', CODEGEN may be called multiple times,
+in which case it may want to generate the code differently to avoid
+a potential code explosion. For this reason the COUNT argument indicates
+how many time this CODEGEN is called."
(macroexp-let2 macroexp-copyable-p val exp
- (let* ((defs ())
- (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)))
- ;; If some of `vars' were not found in `prevvars', that's
- ;; OK it just means those vars aren't present in all
- ;; branches, so they can be used within the pattern
- ;; (e.g. by a `guard/let/pred') but not in the branch.
- ;; FIXME: But if some of `prevvars' are not in `vars' we
- ;; should remove them from `prevvars'!
- `(funcall ,res ,@args)))))))
- (used-cases ())
+ (let* ((seen '())
+ (phcounter 0)
(main
(pcase--u
- (mapcar (lambda (case)
- `(,(pcase--match val (pcase--macroexpand (car case)))
- ,(lambda (vars)
- (unless (memq case used-cases)
- ;; Keep track of the cases that are used.
- (push case used-cases))
- (funcall
- (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)
- vars))))
- cases))))
+ (mapcar
+ (lambda (case)
+ `(,(pcase--match val (pcase--macroexpand (car case)))
+ ,(lambda (vars)
+ (let ((prev (assq case seen)))
+ (unless prev
+ ;; Keep track of the cases that are used.
+ (push (setq prev (list case)) seen))
+ ;; Put a counter in the cdr just so that not
+ ;; all branches look identical (to avoid things
+ ;; like `macroexp--if' optimizing them too
+ ;; optimistically).
+ (let ((ph (cons 'pcase--placeholder
+ (setq phcounter (1+ phcounter)))))
+ (setcdr prev (cons (cons vars ph) (cdr prev)))
+ ph)))))
+ cases))))
+ ;; Take care of the place holders now.
+ (dolist (branch seen)
+ (let ((codegen (cdar branch))
+ (uses (cdr branch)))
+ ;; Find all the vars that are in scope (the union of the
+ ;; vars provided in each use case).
+ (let* ((allvarinfo '())
+ (_ (dolist (use uses)
+ (dolist (v (car use))
+ (let ((vi (assq (car v) allvarinfo)))
+ (if vi
+ (if (cddr v) (setcdr vi 'used))
+ (push (cons (car v) (cddr v)) allvarinfo))))))
+ (allvars (mapcar #'car allvarinfo)))
+ (dolist (use uses)
+ (let* ((vars (car use))
+ (varvals
+ (mapcar (lambda (v)
+ `(,v ,(cadr (assq v vars))
+ ,(cdr (assq v allvarinfo))))
+ allvars))
+ (placeholder (cdr use))
+ (code (funcall codegen varvals (length uses))))
+ ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
+ (setcar placeholder (car code))
+ (setcdr placeholder (cdr code)))))))
(dolist (case cases)
- (unless (or (memq case used-cases)
+ (unless (or (assq case seen)
(memq (car case) pcase--dontwarn-upats))
- (message "Redundant pcase pattern: %S" (car case))))
- (macroexp-let* defs main))))
+ (setq main
+ (macroexp-warn-and-return
+ (format "pcase pattern %S shadowed by previous pcase pattern"
+ (car case))
+ main))))
+ main)))
+
+(defun pcase--expand (exp cases)
+ ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
+ ;; (emacs-pid) exp (sxhash cases))
+ (let* ((defs ())
+ (codegen
+ (lambda (code)
+ (if (member code '(nil (nil) ('nil)))
+ (lambda (&rest _) ''nil)
+ (let ((bsym ()))
+ (lambda (varvals count &rest _)
+ (let* ((ignored-vars
+ (delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv)))
+ varvals)))
+ (ignores (if ignored-vars
+ `((ignore . ,ignored-vars)))))
+ ;; 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.
+ (if (or (< count 2) (pcase--small-branch-p code))
+ `(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
+ varvals)
+ ;; Try and silence some of the most common
+ ;; spurious "unused var" warnings.
+ ,@ignores
+ ,@code)
+ ;; Several occurrence of this non-small branch in
+ ;; the output.
+ (unless bsym
+ (setq bsym (make-symbol
+ (format "pcase-%d" (length defs))))
+ (push `(,bsym (lambda ,(mapcar #'car varvals)
+ ,@ignores ,@code))
+ defs))
+ `(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
+ (main
+ (pcase-compile-patterns
+ exp
+ (mapcar (lambda (case)
+ (cons (car case) (funcall codegen (cdr case))))
+ cases))))
+ (macroexp-let* defs main)))
(defun pcase--macroexpand (pat)
"Expands all macro-patterns in PAT."
@@ -416,10 +448,9 @@ of the elements of LIST is performed as if by `pcase-let'.
(if (pcase--self-quoting-p pat) `',pat pat))
((memq head '(pred guard quote)) pat)
((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
- ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
(t
- (let* ((expander (get head 'pcase-macroexpander))
+ (let* ((expander (pcase--get-macroexpander head))
(npat (if expander (apply expander (cdr pat)))))
(if (null npat)
(error (if expander
@@ -444,7 +475,13 @@ for the result of evaluating EXP (first arg to `pcase').
(decl (assq 'declare body)))
(when decl (setq body (remove decl body)))
`(progn
- (defun ,fsym ,args ,@body)
+ ;; FIXME: We use `eval-and-compile' here so that the pcase macro can be
+ ;; used in the same file where it's defined, but ideally, we should
+ ;; handle this using something similar to `overriding-plist-environment'
+ ;; but for `symbol-function' slots so compiling a file doesn't have the
+ ;; side-effect of defining the function.
+ (eval-and-compile
+ (defun ,fsym ,args ,@body))
(define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
(define-symbol-prop ',name 'pcase-macroexpander #',fsym))))
@@ -460,15 +497,6 @@ for the result of evaluating EXP (first arg to `pcase').
(t
`(match ,val . ,upat))))
-(defun pcase-codegen (code vars)
- ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
- ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
- ;; codegen from later metamorphosing this let into a funcall.
- (if vars
- `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
- ,@code)
- `(progn ,@code)))
-
(defun pcase--small-branch-p (code)
(and (= 1 (length code))
(or (not (consp (car code)))
@@ -481,8 +509,10 @@ for the result of evaluating EXP (first arg to `pcase').
;; 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 else :pcase--dontcare) `(progn (ignore ,test) ,then))
+ ;; This happens very rarely. Known case:
+ ;; (pcase EXP ((and 1 pcase--dontcare) FOO))
+ ((eq then :pcase--dontcare) `(progn (ignore ,test) ,else))
(t (macroexp-if test then else))))
;; Note about MATCH:
@@ -507,11 +537,14 @@ for the result of evaluating EXP (first arg to `pcase').
"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 . PAT)
(and MATCH ...)
- (or MATCH ...)"
+ (or MATCH ...)
+VARS is the set of vars already bound by earlier matches.
+It is a list of (NAME VAL . USED) where NAME is the variable's symbol,
+VAL is the expression to which it should be bound and USED is a boolean
+recording whether the var has been referenced by earlier parts of the match."
(when (setq branches (delq nil branches))
(let* ((carbranch (car branches))
(match (car carbranch)) (cdarbranch (cdr carbranch))
@@ -590,7 +623,7 @@ MATCH is the pattern that needs to be matched, of the form:
((null (cdr else-alts)) (car else-alts))
(t (cons (car match) (nreverse else-alts)))))))
((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
- (t (error "Uknown MATCH %s" match))))
+ (t (error "Unknown MATCH %s" match))))
(defun pcase--split-rest (sym splitter rest)
(let ((then-rest '())
@@ -653,6 +686,14 @@ MATCH is the pattern that needs to be matched, of the form:
'(:pcase--succeed . nil))))
(defun pcase--split-pred (vars upat pat)
+ "Indicate the overlap or mutual-exclusion between UPAT and PAT.
+More specifically returns a pair (A . B) where A indicates whether PAT
+can match when UPAT has matched, and B does the same for the case
+where UPAT failed to match.
+A and B can be one of:
+- nil if we don't know
+- `:pcase--fail' if UPAT match's result implies that PAT can't match
+- `:pcase--succeed' if UPAT match's result implies that PAT matches"
(let (test)
(cond
((and (equal upat pat)
@@ -663,21 +704,44 @@ MATCH is the pattern that needs to be matched, of the form:
;; run, but we don't have the environment in which `pat' will
;; run, so we can't do a reliable verification. But let's try
;; and catch at least the easy cases such as (bug#14773).
- (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
+ (not (macroexp--fgrep vars (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
- ((and (eq 'pred (car upat))
- (let ((otherpred
- (cond ((eq 'pred (car-safe pat)) (cadr pat))
- ((not (eq 'quote (car-safe pat))) nil)
- ((consp (cadr pat)) #'consp)
- ((stringp (cadr pat)) #'stringp)
- ((vectorp (cadr pat)) #'vectorp)
- ((byte-code-function-p (cadr pat))
- #'byte-code-function-p))))
- (pcase--mutually-exclusive-p (cadr upat) otherpred)))
+ ;; In case PAT is of the form (pred (not PRED))
+ ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
+ (let* ((test (cadr (cadr pat)))
+ (res (pcase--split-pred vars upat `(pred ,test)))
+ (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
+ ((eq x :pcase--fail) :pcase--succeed)))))
+ (cons (funcall reverse (car res))
+ (funcall reverse (cdr res)))))
+ ;; All the rest below presumes UPAT is of the form (pred ...).
+ ((not (eq 'pred (car upat))) nil)
+ ;; In case UPAT is of the form (pred (not PRED))
+ ((eq 'not (car-safe (cadr upat)))
+ (let* ((test (cadr (cadr upat)))
+ (res (pcase--split-pred vars `(pred ,test) pat)))
+ (cons (cdr res) (car res))))
+ ((let ((otherpred
+ (cond ((eq 'pred (car-safe pat)) (cadr pat))
+ ((not (eq 'quote (car-safe pat))) nil)
+ ((consp (cadr pat)) #'consp)
+ ((stringp (cadr pat)) #'stringp)
+ ((vectorp (cadr pat)) #'vectorp)
+ ((byte-code-function-p (cadr pat))
+ #'byte-code-function-p))))
+ (pcase--mutually-exclusive-p (cadr upat) otherpred))
'(:pcase--fail . nil))
- ((and (eq 'pred (car upat))
- (eq 'quote (car-safe pat))
+ ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+ ;; try and preserve the info we get from that memq test.
+ ((and (eq 'pcase--flip (car-safe (cadr upat)))
+ (memq (cadr (cadr upat)) '(memq member memql))
+ (eq 'quote (car-safe (nth 2 (cadr upat))))
+ (eq 'quote (car-safe pat)))
+ (let ((set (cadr (nth 2 (cadr upat)))))
+ (if (member (cadr pat) set)
+ '(nil . :pcase--fail)
+ '(:pcase--fail . nil))))
+ ((and (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)
@@ -687,15 +751,6 @@ MATCH is the pattern that needs to be matched, of the form:
'(nil . :pcase--fail)
'(:pcase--fail . nil))))))
-(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))
-
(defun pcase--self-quoting-p (upat)
(or (keywordp upat) (integerp upat) (stringp upat)))
@@ -713,7 +768,7 @@ MATCH is the pattern that needs to be matched, of the form:
(pcase--app-subst-match match sym fun nsym))
(cdr match))))
((memq match '(:pcase--succeed :pcase--fail)) match)
- (t (error "Uknown MATCH %s" match))))
+ (t (error "Unknown MATCH %s" match))))
(defun pcase--app-subst-rest (rest sym fun nsym)
(mapcar (lambda (branch)
@@ -732,37 +787,44 @@ MATCH is the pattern that needs to be matched, of the form:
(defun pcase--funcall (fun arg vars)
"Build a function call to FUN with arg ARG."
- (if (symbolp fun)
- `(,fun ,arg)
- (let* (;; `vs' is an upper bound on the vars we need.
- (vs (pcase--fgrep (mapcar #'car vars) fun))
- (env (mapcar (lambda (var)
- (list var (cdr (assq var vars))))
- vs))
+ (cond
+ ((symbolp fun) `(,fun ,arg))
+ ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
+ (t
+ (let* (;; `env' is hopefully an upper bound on the bindings we need,
+ ;; FIXME: See bug#46786 for a counter example :-(
+ (env (mapcar (lambda (x)
+ (setcdr (cdr x) 'used)
+ (list (car x) (cadr x)))
+ (macroexp--fgrep vars fun)))
(call (progn
- (when (memq arg vs)
+ (when (assq arg env)
;; `arg' is shadowed by `env'.
(let ((newsym (gensym "x")))
(push (list newsym arg) env)
(setq arg newsym)))
- (if (functionp fun)
+ (if (or (functionp fun) (not (consp fun)))
`(funcall #',fun ,arg)
`(,@fun ,arg)))))
- (if (null vs)
+ (if (null env)
call
;; Let's not replace `vars' in `fun' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `fun'.
- `(let* ,env ,call)))))
+ `(let* ,env ,call))))))
(defun pcase--eval (exp vars)
"Build an expression that will evaluate EXP."
(let* ((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 (macroexp-let* env exp) exp)))))
+ (if found (progn (setcdr (cdr found) 'used) (cadr found))
+ (let* ((env (macroexp--fgrep vars exp)))
+ (if env
+ (macroexp-let* (mapcar (lambda (x)
+ (setcdr (cdr x) 'used)
+ (list (car x) (cadr x)))
+ env)
+ exp)
+ exp)))))
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
@@ -772,7 +834,7 @@ 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
+ ;; to be careful to choose 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
@@ -833,7 +895,7 @@ Otherwise, it defers to REST which is a list of branches of the form
((memq upat '(t _))
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
- (macroexp--warn-and-return
+ (macroexp-warn-and-return
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
@@ -851,21 +913,14 @@ Otherwise, it defers to REST which is a list of branches of the form
(pcase--u else-rest))))
((and (symbolp upat) upat)
(pcase--mark-used sym)
- (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)
- (macroexp-let2
- macroexp-copyable-p sym
- (pcase--eval (nth 2 upat) vars)
- (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
- code vars rest)))
+ (let ((v (assq upat vars)))
+ (if (not v)
+ (pcase--u1 matches code (cons (list upat sym) vars) rest)
+ ;; Non-linear pattern. Turn it into an `eq' test.
+ (setcdr (cdr v) 'used)
+ (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v))))
+ matches)
+ code vars rest))))
((eq (car-safe upat) 'app)
;; A upat of the form (app FUN PAT)
(pcase--mark-used sym)
@@ -923,14 +978,13 @@ Otherwise, it defers to REST which is a list of branches of the form
(t (error "Unknown pattern `%S'" upat)))))
(t (error "Incorrect MATCH %S" (car matches)))))
-(def-edebug-spec
- pcase-QPAT
+(def-edebug-elem-spec 'pcase-QPAT
;; Cf. edebug spec for `backquote-form' in edebug.el.
- (&or ("," pcase-PAT)
- (pcase-QPAT [&rest [&not ","] pcase-QPAT]
- . [&or nil pcase-QPAT])
- (vector &rest pcase-QPAT)
- sexp))
+ '(&or ("," pcase-PAT)
+ (pcase-QPAT [&rest [&not ","] pcase-QPAT]
+ . [&or nil pcase-QPAT])
+ (vector &rest pcase-QPAT)
+ sexp))
(pcase-defmacro \` (qpat)
"Backquote-style pcase patterns: \\=`QPAT
@@ -969,13 +1023,23 @@ The predicate is the logical-AND of:
(nreverse upats))))
((consp qpat)
`(and (pred consp)
- (app car ,(list '\` (car qpat)))
- (app cdr ,(list '\` (cdr qpat)))))
+ (app car-safe ,(list '\` (car qpat)))
+ (app cdr-safe ,(list '\` (cdr qpat)))))
((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
;; In all other cases just raise an error so we can't break
;; backward compatibility when adding \` support for other
;; compounded values that are not `consp'
(t (error "Unknown QPAT: %S" qpat))))
+(pcase-defmacro let (pat expr)
+ "Matches if EXPR matches PAT."
+ (declare (debug (pcase-PAT form)))
+ `(app (lambda (_) ,expr) ,pat))
+
+;; (pcase-defmacro guard (expr)
+;; "Matches if EXPR is non-nil."
+;; (declare (debug (form)))
+;; `(pred (lambda (_) ,expr)))
+
(provide 'pcase)
;;; pcase.el ends here
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 6889d924c0f..0bf774dffd8 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -94,33 +94,31 @@ after OUT-BUFFER-NAME."
;; This function either decides not to display it at all
;; or displays it in the usual way.
(temp-buffer-show-function
- (function
- (lambda (buf)
- (with-current-buffer buf
- (goto-char (point-min))
- (end-of-line 1)
- (if (or (< (1+ (point)) (point-max))
- (>= (- (point) (point-min)) (frame-width)))
- (let ((temp-buffer-show-function old-show-function)
- (old-selected (selected-window))
- (window (display-buffer buf)))
- (goto-char (point-min)) ; expected by some hooks ...
- (make-frame-visible (window-frame window))
- (unwind-protect
- (progn
- (select-window window)
- (run-hooks 'temp-buffer-show-hook))
- (when (window-live-p old-selected)
- (select-window old-selected))
- (message "See buffer %s." out-buffer-name)))
- (message "%s" (buffer-substring (point-min) (point)))
- ))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (end-of-line 1)
+ (if (or (< (1+ (point)) (point-max))
+ (>= (- (point) (point-min)) (frame-width)))
+ (let ((temp-buffer-show-function old-show-function)
+ (old-selected (selected-window))
+ (window (display-buffer buf)))
+ (goto-char (point-min)) ; expected by some hooks ...
+ (make-frame-visible (window-frame window))
+ (unwind-protect
+ (progn
+ (select-window window)
+ (run-hooks 'temp-buffer-show-hook))
+ (when (window-live-p old-selected)
+ (select-window old-selected))
+ (message "See buffer %s." out-buffer-name)))
+ (message "%s" (buffer-substring (point-min) (point))))))))
(with-output-to-temp-buffer out-buffer-name
(pp expression)
(with-current-buffer standard-output
(emacs-lisp-mode)
(setq buffer-read-only nil)
- (set (make-local-variable 'font-lock-verbose) nil)))))
+ (setq-local font-lock-verbose nil)))))
;;;###autoload
(defun pp-eval-expression (expression)
@@ -129,8 +127,9 @@ Also add the value to the front of the list in the variable `values'."
(interactive
(list (read--expression "Eval: ")))
(message "Evaluating...")
- (push (eval expression lexical-binding) values)
- (pp-display-expression (car values) "*Pp Eval Output*"))
+ (let ((result (eval expression lexical-binding)))
+ (values--store-value result)
+ (pp-display-expression result "*Pp Eval Output*")))
;;;###autoload
(defun pp-macroexpand-expression (expression)
@@ -164,8 +163,11 @@ With ARG, pretty-print output into current buffer.
Ignores leading comment characters."
(interactive "P")
(if arg
- (insert (pp-to-string (eval (pp-last-sexp) lexical-binding)))
- (pp-eval-expression (pp-last-sexp))))
+ (insert (pp-to-string (eval (elisp--eval-defun-1
+ (macroexpand (pp-last-sexp)))
+ lexical-binding)))
+ (pp-eval-expression (elisp--eval-defun-1
+ (macroexpand (pp-last-sexp))))))
;;;###autoload
(defun pp-macroexpand-last-sexp (arg)
diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el
index 6a483a6d498..fb659753501 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -194,13 +194,13 @@ If not found, return nil."
"Return an alist of all bindings in TREE for prefixes of STRING."
(radix-tree--prefixes tree string 0 nil))
-(eval-and-compile
- (pcase-defmacro radix-tree-leaf (vpat)
- "Pattern which matches a radix-tree leaf.
+(pcase-defmacro radix-tree-leaf (vpat)
+ "Pattern which matches a radix-tree leaf.
The pattern VPAT is matched against the leaf's carried value."
- ;; FIXME: We'd like to use a negative pattern (not consp), but pcase
- ;; doesn't support it. Using `atom' works but generates sub-optimal code.
- `(or `(t . ,,vpat) (and (pred atom) ,vpat))))
+ ;; We used to use `(pred atom)', but `pcase' doesn't understand that
+ ;; `atom' is equivalent to the negation of `consp' and hence generates
+ ;; suboptimal code.
+ `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))
(defun radix-tree-iter-subtrees (tree fun)
"Apply FUN to every immediate subtree of radix TREE.
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index 86215f6519c..396949d59a2 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -96,7 +96,7 @@
;; out.
;; Q: But how can I then make out the sub-expressions?
-;; A: Thats where the `sub-expression mode' comes in. In it only the
+;; A: That's where the `sub-expression mode' comes in. In it only the
;; digit keys are assigned to perform an update that will flash the
;; corresponding subexp only.
@@ -187,14 +187,14 @@ Set it to nil if you don't want limits here."
(defvar reb-target-window nil
"Window to which the RE is applied to.")
-(defvar reb-regexp nil
+(defvar-local reb-regexp nil
"Last regexp used by RE Builder.")
-(defvar reb-regexp-src nil
+(defvar-local reb-regexp-src nil
"Last regexp used by RE Builder before processing it.
Except for Lisp syntax this is the same as `reb-regexp'.")
-(defvar reb-overlays nil
+(defvar-local reb-overlays nil
"List of overlays of the RE Builder.")
(defvar reb-window-config nil
@@ -212,17 +212,12 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(defvar reb-valid-string ""
"String in mode line showing validity of RE.")
-(make-variable-buffer-local 'reb-overlays)
-(make-variable-buffer-local 'reb-regexp)
-(make-variable-buffer-local 'reb-regexp-src)
-
(defconst reb-buffer "*RE-Builder*"
"Buffer to use for the RE Builder.")
;; Define the local "\C-c" keymap
(defvar reb-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-c" 'reb-toggle-case)
(define-key map "\C-c\C-q" 'reb-quit)
(define-key map "\C-c\C-w" 'reb-copy)
@@ -232,46 +227,40 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(define-key map "\C-c\C-e" 'reb-enter-subexp-mode)
(define-key map "\C-c\C-b" 'reb-change-target-buffer)
(define-key map "\C-c\C-u" 'reb-force-update)
- (define-key map [menu-bar reb-mode] (cons "Re-Builder" menu-map))
- (define-key menu-map [rq]
- '(menu-item "Quit" reb-quit
- :help "Quit the RE Builder mode"))
- (define-key menu-map [div1] '(menu-item "--"))
- (define-key menu-map [rt]
- '(menu-item "Case sensitive" reb-toggle-case
- :button (:toggle . (with-current-buffer
- reb-target-buffer
- (null case-fold-search)))
- :help "Toggle case sensitivity of searches for RE Builder target buffer"))
- (define-key menu-map [rb]
- '(menu-item "Change target buffer..." reb-change-target-buffer
- :help "Change the target buffer and display it in the target window"))
- (define-key menu-map [rs]
- '(menu-item "Change syntax..." reb-change-syntax
- :help "Change the syntax used by the RE Builder"))
- (define-key menu-map [div2] '(menu-item "--"))
- (define-key menu-map [re]
- '(menu-item "Enter subexpression mode" reb-enter-subexp-mode
- :help "Enter the subexpression mode in the RE Builder"))
- (define-key menu-map [ru]
- '(menu-item "Force update" reb-force-update
- :help "Force an update in the RE Builder target window without a match limit"))
- (define-key menu-map [rn]
- '(menu-item "Go to next match" reb-next-match
- :help "Go to next match in the RE Builder target window"))
- (define-key menu-map [rp]
- '(menu-item "Go to previous match" reb-prev-match
- :help "Go to previous match in the RE Builder target window"))
- (define-key menu-map [div3] '(menu-item "--"))
- (define-key menu-map [rc]
- '(menu-item "Copy current RE" reb-copy
- :help "Copy current RE into the kill ring for later insertion"))
map)
"Keymap used by the RE Builder.")
+(easy-menu-define reb-mode-menu reb-mode-map
+ "Menu for the RE Builder."
+ '("Re-Builder"
+ ["Copy current RE" reb-copy
+ :help "Copy current RE into the kill ring for later insertion"]
+ "---"
+ ["Go to previous match" reb-prev-match
+ :help "Go to previous match in the RE Builder target window"]
+ ["Go to next match" reb-next-match
+ :help "Go to next match in the RE Builder target window"]
+ ["Force update" reb-force-update
+ :help "Force an update in the RE Builder target window without a match limit"]
+ ["Enter subexpression mode" reb-enter-subexp-mode
+ :help "Enter the subexpression mode in the RE Builder"]
+ "---"
+ ["Change syntax..." reb-change-syntax
+ :help "Change the syntax used by the RE Builder"]
+ ["Change target buffer..." reb-change-target-buffer
+ :help "Change the target buffer and display it in the target window"]
+ ["Case sensitive" reb-toggle-case
+ :style toggle
+ :selected (with-current-buffer reb-target-buffer
+ (null case-fold-search))
+ :help "Toggle case sensitivity of searches for RE Builder target buffer"]
+ "---"
+ ["Quit" reb-quit
+ :help "Quit the RE Builder mode"]))
+
(define-derived-mode reb-mode nil "RE Builder"
"Major mode for interactively building Regular Expressions."
- (set (make-local-variable 'blink-matching-paren) nil)
+ (setq-local blink-matching-paren nil)
(reb-mode-common))
(defvar reb-lisp-mode-map
@@ -352,7 +341,12 @@ the regexp builder. It displays a buffer named \"*RE-Builder*\"
in another window, initially containing an empty regexp.
As you edit the regexp in the \"*RE-Builder*\" buffer, the
-matching parts of the target buffer will be highlighted."
+matching parts of the target buffer will be highlighted.
+
+Case-sensitivity can be toggled with \\[reb-toggle-case]. The
+regexp builder supports three different forms of input which can
+be set with \\[reb-change-syntax]. More options and details are
+provided in the Commentary section of this library."
(interactive)
(if (and (string= (buffer-name) reb-buffer)
(reb-mode-buffer-p))
@@ -361,18 +355,22 @@ matching parts of the target buffer will be highlighted."
(reb-delete-overlays))
(setq reb-target-buffer (current-buffer)
reb-target-window (selected-window))
- (select-window (or (get-buffer-window reb-buffer)
- (progn
- (setq reb-window-config (current-window-configuration))
- (split-window (selected-window) (- (window-height) 4)))))
- (switch-to-buffer (get-buffer-create reb-buffer))
+ (select-window
+ (or (get-buffer-window reb-buffer)
+ (let ((dir (if (window-parameter nil 'window-side)
+ 'bottom 'down)))
+ (setq reb-window-config (current-window-configuration))
+ (display-buffer
+ (get-buffer-create reb-buffer)
+ `((display-buffer-in-direction)
+ (direction . ,dir)
+ (dedicated . t))))))
(font-lock-mode 1)
(reb-initialize-buffer)))
(defun reb-change-target-buffer (buf)
"Change the target buffer and display it in the target window."
(interactive "bSet target buffer to: ")
-
(let ((buffer (get-buffer buf)))
(if (not buffer)
(error "No such buffer")
@@ -385,7 +383,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-force-update ()
"Force an update in the RE Builder target window without a match limit."
(interactive)
-
(let ((reb-auto-match-limit nil))
(reb-update-overlays
(if reb-subexp-mode reb-subexp-displayed nil))))
@@ -393,7 +390,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-quit ()
"Quit the RE Builder mode."
(interactive)
-
(setq reb-subexp-mode nil
reb-subexp-displayed nil)
(reb-delete-overlays)
@@ -403,7 +399,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-next-match ()
"Go to next match in the RE Builder target window."
(interactive)
-
(reb-assert-buffer-in-window)
(with-selected-window reb-target-window
(if (not (re-search-forward reb-regexp (point-max) t))
@@ -415,7 +410,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-prev-match ()
"Go to previous match in the RE Builder target window."
(interactive)
-
(reb-assert-buffer-in-window)
(with-selected-window reb-target-window
(let ((p (point)))
@@ -430,7 +424,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-toggle-case ()
"Toggle case sensitivity of searches for RE Builder target buffer."
(interactive)
-
(with-current-buffer reb-target-buffer
(setq case-fold-search (not case-fold-search)))
(reb-update-modestring)
@@ -439,7 +432,6 @@ matching parts of the target buffer will be highlighted."
(defun reb-copy ()
"Copy current RE into the kill ring for later insertion."
(interactive)
-
(reb-update-regexp)
(let ((re (with-output-to-string
(print (reb-target-binding reb-regexp)))))
@@ -489,7 +481,7 @@ Optional argument SYNTAX must be specified if called non-interactively."
(interactive
(list (intern
(completing-read
- (format "Select syntax (default %s): " reb-re-syntax)
+ (format-prompt "Select syntax" reb-re-syntax)
'(read string sregex rx)
nil t nil nil (symbol-name reb-re-syntax)
'reb-change-syntax-hist))))
@@ -507,7 +499,6 @@ Optional argument SYNTAX must be specified if called non-interactively."
(defun reb-do-update (&optional subexp)
"Update matches in the RE Builder target window.
If SUBEXP is non-nil mark only the corresponding sub-expressions."
-
(reb-assert-buffer-in-window)
(reb-update-regexp)
(reb-update-overlays subexp))
@@ -545,7 +536,6 @@ optional fourth argument FORCE is non-nil."
(defun reb-assert-buffer-in-window ()
"Assert that `reb-target-buffer' is displayed in `reb-target-window'."
-
(if (not (eq reb-target-buffer (window-buffer reb-target-window)))
(set-window-buffer reb-target-window reb-target-buffer)))
@@ -564,7 +554,6 @@ optional fourth argument FORCE is non-nil."
(defun reb-display-subexp (&optional subexp)
"Highlight only subexpression SUBEXP in the RE Builder."
(interactive)
-
(setq reb-subexp-displayed
(or subexp (string-to-number (format "%c" last-command-event))))
(reb-update-modestring)
@@ -572,7 +561,6 @@ optional fourth argument FORCE is non-nil."
(defun reb-kill-buffer ()
"When the RE Builder buffer is killed make sure no overlays stay around."
-
(when (reb-mode-buffer-p)
(reb-delete-overlays)))
@@ -604,7 +592,6 @@ optional fourth argument FORCE is non-nil."
(defun reb-insert-regexp ()
"Insert current RE."
-
(let ((re (or (reb-target-binding reb-regexp)
(reb-empty-regexp))))
(cond ((eq reb-re-syntax 'read)
@@ -640,7 +627,6 @@ Return t if the (cooked) expression changed."
;; And now the real core of the whole thing
(defun reb-count-subexps (re)
"Return number of sub-expressions in the regexp RE."
-
(let ((i 0) (beg 0))
(while (string-match "\\\\(" re beg)
(setq i (1+ i)
@@ -832,8 +818,8 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(let ((font-lock-is-on font-lock-mode))
(font-lock-mode -1)
(kill-local-variable 'font-lock-set-defaults)
- ;;(set (make-local-variable 'reb-re-syntax) 'string)
- ;;(set (make-local-variable 'reb-re-syntax) 'rx)
+ ;;(setq-local reb-re-syntax 'string)
+ ;;(setq-local reb-re-syntax 'rx)
(setq font-lock-defaults
(cond
((memq reb-re-syntax '(read string))
diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el
index da520f94566..527af1ddf24 100644
--- a/lisp/emacs-lisp/regi.el
+++ b/lisp/emacs-lisp/regi.el
@@ -1,10 +1,10 @@
-;;; regi.el --- REGular expression Interpreting engine
+;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
;; Created: 24-Feb-1993
-;; Version: 1.8
+;; Old-Version: 1.8
;; Last Modified: 1993/06/01 21:33:00
;; Keywords: extensions, matching
@@ -153,7 +153,7 @@ useful information:
;; set up the narrowed region
(and start
end
- (let* ((tstart start)
+ (let* (;; (tstart start)
(start (min start end))
(end (max start end)))
(narrow-to-region
@@ -163,18 +163,15 @@ useful information:
;; let's find the special tags and remove them from the working
;; frame. note that only the last special tag is used.
(mapc
- (function
- (lambda (entry)
- (let ((pred (car entry))
- (func (car (cdr entry))))
- (cond
- ((eq pred 'begin) (setq begin-tag func))
- ((eq pred 'end) (setq end-tag func))
- ((eq pred 'every) (setq every-tag func))
- (t
- (setq working-frame (append working-frame (list entry))))
- ) ; end-cond
- )))
+ (lambda (entry)
+ (let ((pred (car entry))
+ (func (car (cdr entry))))
+ (cond
+ ((eq pred 'begin) (setq begin-tag func))
+ ((eq pred 'end) (setq end-tag func))
+ ((eq pred 'every) (setq every-tag func))
+ (t
+ (setq working-frame (append working-frame (list entry)))))))
frame) ; end-mapcar
;; execute the begin entry
@@ -209,30 +206,33 @@ useful information:
;; if the line matched, package up the argument list and
;; funcall the FUNC
(if match-p
- (let* ((curline (buffer-substring
- (regi-pos 'bol)
- (regi-pos 'eol)))
- (curframe current-frame)
- (curentry entry)
- (result (eval func))
- (step (or (cdr (assq 'step result)) 1))
- )
- ;; changing frame on the fly?
- (if (assq 'frame result)
- (setq working-frame (cdr (assq 'frame result))))
-
- ;; continue processing current frame?
- (if (memq 'continue result)
- (setq current-frame (cdr current-frame))
- (forward-line step)
- (setq current-frame working-frame))
-
- ;; abort current frame?
- (if (memq 'abort result)
- (progn
- (setq donep t)
- (throw 'regi-throw-top t)))
- ) ; end-let
+ (with-suppressed-warnings
+ ((lexical curframe curentry curline))
+ (defvar curframe) (defvar curentry) (defvar curline)
+ (let* ((curline (buffer-substring
+ (regi-pos 'bol)
+ (regi-pos 'eol)))
+ (curframe current-frame)
+ (curentry entry)
+ (result (eval func))
+ (step (or (cdr (assq 'step result)) 1))
+ )
+ ;; changing frame on the fly?
+ (if (assq 'frame result)
+ (setq working-frame (cdr (assq 'frame result))))
+
+ ;; continue processing current frame?
+ (if (memq 'continue result)
+ (setq current-frame (cdr current-frame))
+ (forward-line step)
+ (setq current-frame working-frame))
+
+ ;; abort current frame?
+ (if (memq 'abort result)
+ (progn
+ (setq donep t)
+ (throw 'regi-throw-top t)))
+ )) ; end-let
;; else if no match occurred, then process the next
;; frame-entry on the current line
diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el
index 96894655b45..ea27bb3c31b 100644
--- a/lisp/emacs-lisp/ring.el
+++ b/lisp/emacs-lisp/ring.el
@@ -248,8 +248,6 @@ If SEQ is already a ring, return it."
(ring-insert-at-beginning ring (elt seq count))))
ring)))
-;;; provide ourself:
-
(provide 'ring)
;;; ring.el ends here
diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
index bedf598d442..8abe570e64b 100644
--- a/lisp/emacs-lisp/rmc.el
+++ b/lisp/emacs-lisp/rmc.el
@@ -26,29 +26,38 @@
(require 'seq)
;;;###autoload
-(defun read-multiple-choice (prompt choices)
- "Ask user a multiple choice question.
-PROMPT should be a string that will be displayed as the prompt.
-
-CHOICES is a list of (KEY NAME [DESCRIPTION]). KEY is a
-character to be entered. NAME is a short name for the entry to
-be displayed while prompting (if there's room, it might be
-shortened). DESCRIPTION is an optional longer explanation that
-will be displayed in a help buffer if the user requests more
-help.
+(defun read-multiple-choice (prompt choices &optional help-string)
+ "Ask user to select an entry from CHOICES, promting with PROMPT.
+This function allows to ask the user a multiple-choice question.
+
+CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
+KEY is a character the user should type to select the entry.
+NAME is a short name for the entry to be displayed while prompting
+\(if there's no room, it might be shortened).
+DESCRIPTION is an optional longer description of the entry; it will
+be displayed in a help buffer if the user requests more help. This
+help description has a fixed format in columns. For greater
+flexibility, instead of passing a DESCRIPTION, the caller can pass
+the optional argument HELP-STRING. This argument is a string that
+should contain a more detailed description of all of the possible
+choices. `read-multiple-choice' will display that description in a
+help buffer if the user requests that.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
-that variable for more information. In this case, the useful
-bindings are `recenter', `scroll-up', and `scroll-down'. If the
-user enters `recenter', `scroll-up', or `scroll-down' responses,
-perform the requested window recentering or scrolling and ask
-again.
-
-When `use-dialog-box' is t (the default), this function can pop
-up a dialog window to collect the user input. That functionality
-requires `display-popup-menus-p' to return t. Otherwise, a
-text dialog will be used.
+that variable for more information. The relevant bindings for the
+purposes of this function are `recenter', `scroll-up', `scroll-down',
+and `edit'.
+If the user types the `recenter', `scroll-up', or `scroll-down'
+responses, the function performs the requested window recentering or
+scrolling, and then asks the question again. If the user enters `edit',
+the function starts a recursive edit. When the user exit the recursive
+edit, the multiple-choice prompt gains focus again.
+
+When `use-dialog-box' is t (the default), and the command using this
+function was invoked via the mouse, this function pops up a GUI dialog
+to collect the user input, but only if Emacs is capable of using GUI
+dialogs. Otherwise, the function will always use text-mode dialogs.
The return value is the matching entry from the CHOICES list.
@@ -133,6 +142,13 @@ Usage example:
(ignore-errors (scroll-other-window)) t)
((eq answer 'scroll-other-window-down)
(ignore-errors (scroll-other-window-down)) t)
+ ((eq answer 'edit)
+ (save-match-data
+ (save-excursion
+ (message "%s"
+ (substitute-command-keys
+ "Recursive edit; type \\[exit-recursive-edit] to return to help screen"))
+ (recursive-edit))))
(t tchar)))
(when (eq tchar t)
(setq wrong-char nil
@@ -141,57 +157,61 @@ Usage example:
;; help messages.
(when (and (not (eq tchar nil))
(not (assq tchar choices)))
- (setq wrong-char (not (memq tchar '(?? ?\C-h)))
+ (setq wrong-char (not (memq tchar `(?? ,help-char)))
tchar nil)
(when wrong-char
(ding))
- (with-help-window (setq buf (get-buffer-create
- "*Multiple Choice Help*"))
- (with-current-buffer buf
- (erase-buffer)
- (pop-to-buffer buf)
- (insert prompt "\n\n")
- (let* ((columns (/ (window-width) 25))
- (fill-column 21)
- (times 0)
- (start (point)))
- (dolist (elem choices)
- (goto-char start)
- (unless (zerop times)
- (if (zerop (mod times columns))
- ;; Go to the next "line".
- (goto-char (setq start (point-max)))
- ;; Add padding.
- (while (not (eobp))
- (end-of-line)
- (insert (make-string (max (- (* (mod times columns)
- (+ fill-column 4))
- (current-column))
- 0)
- ?\s))
- (forward-line 1))))
- (setq times (1+ times))
- (let ((text
- (with-temp-buffer
- (insert (format
- "%c: %s\n"
- (car elem)
- (cdr (assq (car elem) altered-names))))
- (fill-region (point-min) (point-max))
- (when (nth 2 elem)
- (let ((start (point)))
- (insert (nth 2 elem))
- (unless (bolp)
- (insert "\n"))
- (fill-region start (point-max))))
- (buffer-string))))
+ (setq buf (get-buffer-create "*Multiple Choice Help*"))
+ (if (stringp help-string)
+ (with-help-window buf
+ (with-current-buffer buf
+ (insert help-string)))
+ (with-help-window buf
+ (with-current-buffer buf
+ (erase-buffer)
+ (pop-to-buffer buf)
+ (insert prompt "\n\n")
+ (let* ((columns (/ (window-width) 25))
+ (fill-column 21)
+ (times 0)
+ (start (point)))
+ (dolist (elem choices)
(goto-char start)
- (dolist (line (split-string text "\n"))
- (end-of-line)
- (if (bolp)
- (insert line "\n")
- (insert line))
- (forward-line 1)))))))))))
+ (unless (zerop times)
+ (if (zerop (mod times columns))
+ ;; Go to the next "line".
+ (goto-char (setq start (point-max)))
+ ;; Add padding.
+ (while (not (eobp))
+ (end-of-line)
+ (insert (make-string (max (- (* (mod times columns)
+ (+ fill-column 4))
+ (current-column))
+ 0)
+ ?\s))
+ (forward-line 1))))
+ (setq times (1+ times))
+ (let ((text
+ (with-temp-buffer
+ (insert (format
+ "%c: %s\n"
+ (car elem)
+ (cdr (assq (car elem) altered-names))))
+ (fill-region (point-min) (point-max))
+ (when (nth 2 elem)
+ (let ((start (point)))
+ (insert (nth 2 elem))
+ (unless (bolp)
+ (insert "\n"))
+ (fill-region start (point-max))))
+ (buffer-string))))
+ (goto-char start)
+ (dolist (line (split-string text "\n"))
+ (end-of-line)
+ (if (bolp)
+ (insert line "\n")
+ (insert line))
+ (forward-line 1))))))))))))
(when (buffer-live-p buf)
(kill-buffer buf))
(assq tchar choices)))
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 8de98b4cfb4..071d390f0e4 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -890,7 +890,7 @@ Return (REGEXP . PRECEDENCE)."
(* (or (seq "[:" (+ (any "a-z")) ":]")
(not (any "]"))))
"]")
- anything
+ (not (any "*+?^$[\\"))
(seq "\\"
(or anything
(seq (any "sScC_") anything)
@@ -1210,7 +1210,7 @@ unmatchable Never match anything at all.
CHARCLASS Match a character from a character class. One of:
alpha, alphabetic, letter Alphabetic characters (defined by Unicode).
alnum, alphanumeric Alphabetic or decimal digit chars (Unicode).
- digit numeric, num 0-9.
+ digit, numeric, num 0-9.
xdigit, hex-digit, hex 0-9, A-F, a-f.
cntrl, control ASCII codes 0-31.
blank Horizontal whitespace (Unicode).
@@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx',
For more details, see Info node `(elisp) Extending Rx'.
\(fn NAME [(ARGS...)] RX)"
- (declare (indent 1))
+ (declare (indent defun))
`(eval-and-compile
(put ',name 'rx-definition ',(rx--make-binding name definition))
',name))
@@ -1418,6 +1418,13 @@ into a plain rx-expression, collecting names into `rx--pcase-vars'."
(cons head (mapcar #'rx--pcase-transform rest)))
(_ rx)))
+(defun rx--reduce-right (f l)
+ "Right-reduction on L by F. L must be non-empty."
+ (if (cdr l)
+ (funcall f (car l) (rx--reduce-right f (cdr l)))
+ (car l)))
+
+;;;###autoload
(pcase-defmacro rx (&rest regexps)
"A pattern that matches strings against `rx' REGEXPS in sexp form.
REGEXPS are interpreted as in `rx'. The pattern matches any
@@ -1436,12 +1443,37 @@ following constructs:
construct."
(let* ((rx--pcase-vars nil)
(regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps)))))
- `(and (pred (string-match ,regexp))
- ,@(let ((i 0))
- (mapcar (lambda (name)
- (setq i (1+ i))
- `(app (match-string ,i) ,name))
- (reverse rx--pcase-vars))))))
+ `(and (pred stringp)
+ ,(pcase (length rx--pcase-vars)
+ (0
+ ;; No variables bound: a single predicate suffices.
+ `(pred (string-match ,regexp)))
+ (1
+ ;; Create a match value that on a successful regexp match
+ ;; is the submatch value, 0 on failure. We can't use nil
+ ;; for failure because it is a valid submatch value.
+ `(app (lambda (s)
+ (if (string-match ,regexp s)
+ (match-string 1 s)
+ 0))
+ (and ,(car rx--pcase-vars) (pred (not numberp)))))
+ (nvars
+ ;; Pack the submatches into a dotted list which is then
+ ;; immediately destructured into individual variables again.
+ ;; This is of course slightly inefficient.
+ ;; A dotted list is used to reduce the number of conses
+ ;; to create and take apart.
+ `(app (lambda (s)
+ (and (string-match ,regexp s)
+ ,(rx--reduce-right
+ (lambda (a b) `(cons ,a ,b))
+ (mapcar (lambda (i) `(match-string ,i s))
+ (number-sequence 1 nvars)))))
+ ,(list '\`
+ (rx--reduce-right
+ #'cons
+ (mapcar (lambda (name) (list '\, name))
+ (reverse rx--pcase-vars))))))))))
;; Obsolete internal symbol, used in old versions of the `flycheck' package.
(define-obsolete-function-alias 'rx-submatch-n 'rx-to-string "27.1")
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index ef2b1092c83..e8fc4a28145 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Keywords: sequences
-;; Version: 2.21
+;; Version: 2.22
;; Package: seq
;; Maintainer: emacs-devel@gnu.org
@@ -134,9 +134,10 @@ Unlike `seq-map', FUNCTION takes two arguments: the element of
the sequence, and its index within the sequence."
(let ((index 0))
(seq-do (lambda (elt)
- (funcall function elt index)
- (setq index (1+ index)))
- sequence)))
+ (funcall function elt index)
+ (setq index (1+ index)))
+ sequence))
+ nil)
(cl-defgeneric seqp (object)
"Return non-nil if OBJECT is a sequence, nil otherwise."
@@ -146,6 +147,7 @@ the sequence, and its index within the sequence."
"Return a shallow copy of SEQUENCE."
(copy-sequence sequence))
+;;;###autoload
(cl-defgeneric seq-subseq (sequence start &optional end)
"Return the sequence of elements of SEQUENCE from START to END.
END is exclusive.
@@ -284,9 +286,6 @@ sorted. FUNCTION must be a function of one argument."
(cl-defmethod seq-reverse ((sequence sequence))
(reverse sequence))
-;; We are autoloading seq-concatenate because cl-concatenate needs
-;; that when it's inlined, per the cl-proclaim in cl-macs.el.
-;;;###autoload
(cl-defgeneric seq-concatenate (type &rest sequences)
"Concatenate SEQUENCES into a single sequence of type TYPE.
TYPE must be one of following symbols: vector, string or list.
@@ -320,7 +319,7 @@ list."
;;;###autoload
(cl-defgeneric seq-filter (pred sequence)
- "Return a list of all the elements for which (PRED element) is non-nil in SEQUENCE."
+ "Return a list of all elements for which (PRED element) is non-nil in SEQUENCE."
(let ((exclude (make-symbol "exclude")))
(delq exclude (seq-map (lambda (elt)
(if (funcall pred elt)
@@ -353,6 +352,7 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
(setq acc (funcall function acc elt)))
acc)))
+;;;###autoload
(cl-defgeneric seq-every-p (pred sequence)
"Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE."
(catch 'seq--break
@@ -394,14 +394,15 @@ found or not."
(setq count (+ 1 count))))
count))
-(cl-defgeneric seq-contains (sequence elt &optional testfn)
- (declare (obsolete seq-contains-p "27.1"))
- "Return the first element in SEQUENCE that is equal to ELT.
+(with-suppressed-warnings ((obsolete seq-contains))
+ (cl-defgeneric seq-contains (sequence elt &optional testfn)
+ "Return the first element in SEQUENCE that is equal to ELT.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
- (seq-some (lambda (e)
- (when (funcall (or testfn #'equal) elt e)
- e))
- sequence))
+ (declare (obsolete seq-contains-p "27.1"))
+ (seq-some (lambda (e)
+ (when (funcall (or testfn #'equal) elt e)
+ e))
+ sequence)))
(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
"Return non-nil if SEQUENCE contains an element equal to ELT.
@@ -413,7 +414,8 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
nil))
(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn)
- "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of order.
+ "Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements.
+This does not depend on the order of the elements.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
(and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1)
(seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2)))
@@ -430,6 +432,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(setq index (1+ index)))
nil)))
+;;;###autoload
(cl-defgeneric seq-uniq (sequence &optional testfn)
"Return a list of the elements of SEQUENCE with duplicates removed.
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
@@ -446,7 +449,7 @@ The result is a sequence of type TYPE, or a list if TYPE is nil."
(seq-map function sequence)))
(cl-defgeneric seq-partition (sequence n)
- "Return a list of the elements of SEQUENCE grouped into sub-sequences of length N.
+ "Return list of elements of SEQUENCE grouped into sub-sequences of length N.
The last sequence may contain less than N elements. If N is a
negative integer or 0, nil is returned."
(unless (< n 1)
@@ -456,6 +459,7 @@ negative integer or 0, nil is returned."
(setq sequence (seq-drop sequence n)))
(nreverse result))))
+;;;###autoload
(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
@@ -466,6 +470,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reverse sequence1)
'()))
+;;;###autoload
(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
@@ -476,6 +481,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil."
(seq-reverse sequence1)
'()))
+;;;###autoload
(cl-defgeneric seq-group-by (function sequence)
"Apply FUNCTION to each element of SEQUENCE.
Separate the elements of SEQUENCE into an alist using the results as
@@ -496,6 +502,7 @@ keys. Keys are compared using `equal'."
SEQUENCE must be a sequence of numbers or markers."
(apply #'min (seq-into sequence 'list)))
+;;;###autoload
(cl-defgeneric seq-max (sequence)
"Return the largest element of SEQUENCE.
SEQUENCE must be a sequence of numbers or markers."
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index 6b6b8d966dd..02f2ad3d816 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -1,4 +1,4 @@
-;;; shadow.el --- locate Emacs Lisp file shadowings
+;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -55,14 +55,10 @@
:prefix "load-path-shadows-"
:group 'lisp)
-(define-obsolete-variable-alias 'shadows-compare-text-p
- 'load-path-shadows-compare-text "23.3")
-
(defcustom load-path-shadows-compare-text nil
"If non-nil, then shadowing files are reported only if their text differs.
This is slower, but filters out some innocuous shadowing."
- :type 'boolean
- :group 'lisp-shadow)
+ :type 'boolean)
(defun load-path-shadows-find (&optional path)
"Return a list of Emacs Lisp files that create shadows.
@@ -81,8 +77,7 @@ See the documentation for `list-load-path-shadows' for further information."
dir-case-insensitive ; `file-name-case-insensitive-p' of dir.
curr-files ; This dir's Emacs Lisp files.
orig-dir ; Where the file was first seen.
- files-seen-this-dir ; Files seen so far in this dir.
- file) ; The current file.
+ files-seen-this-dir) ; Files seen so far in this dir.
(dolist (pp (or path load-path))
(setq dir (directory-file-name (file-truename (or pp "."))))
(if (member dir true-names)
@@ -112,7 +107,7 @@ See the documentation for `list-load-path-shadows' for further information."
(dolist (file curr-files)
- (if (string-match "\\.gz$" file)
+ (if (string-match "\\.gz\\'" file)
(setq file (substring file 0 -3)))
(setq file (substring
file 0 (if (string= (substring file -1) "c") -4 -3)))
@@ -120,17 +115,24 @@ See the documentation for `list-load-path-shadows' for further information."
;; FILE now contains the current file name, with no suffix.
(unless (or (member file files-seen-this-dir)
;; Ignore these files.
- (member file (list "subdirs" "leim-list"
- (file-name-sans-extension
- dir-locals-file))))
+ (member file
+ (list "subdirs" "leim-list"
+ (file-name-sans-extension dir-locals-file)
+ (concat
+ (file-name-sans-extension dir-locals-file)
+ "-2"))))
;; File has not been seen yet in this directory.
;; This test prevents us declaring that XXX.el shadows
;; XXX.elc (or vice-versa) when they are in the same directory.
(setq files-seen-this-dir (cons file files-seen-this-dir))
- (if (setq orig-dir (assoc file files
- (when dir-case-insensitive
- (lambda (f1 f2) (eq (compare-strings f1 nil nil f2 nil nil t) t)))))
+ (if (setq orig-dir
+ (assoc file files
+ (when dir-case-insensitive
+ (lambda (f1 f2)
+ (eq (compare-strings f1 nil nil
+ f2 nil nil t)
+ t)))))
;; This file was seen before, we have a shadowing.
;; Report it unless the files are identical.
(let ((base1 (concat (cdr orig-dir) "/" (car orig-dir)))
@@ -145,7 +147,7 @@ See the documentation for `list-load-path-shadows' for further information."
(append shadows (list base1 base2)))))
;; Not seen before, add it to the list of seen files.
- (setq files (cons (cons file dir) files)))))))
+ (push (cons file dir) files))))))
;; Return the list of shadowings.
shadows))
@@ -180,13 +182,12 @@ See the documentation for `list-load-path-shadows' for further information."
(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-local 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
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
new file mode 100644
index 00000000000..a74a5a4225c
--- /dev/null
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -0,0 +1,1360 @@
+;;; shortdoc.el --- Short function summaries -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Keywords: lisp, help
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'seq)
+(require 'text-property-search)
+(eval-when-compile (require 'cl-lib))
+
+(defgroup shortdoc nil
+ "Short documentation."
+ :group 'lisp)
+
+(defface shortdoc-heading
+ '((t :inherit variable-pitch :height 1.3 :weight bold))
+ "Face used for a heading."
+ :version "28.1")
+
+(defface shortdoc-section
+ '((t :inherit variable-pitch))
+ "Face used for a section.")
+
+(defvar shortdoc--groups nil)
+
+(defmacro define-short-documentation-group (group &rest functions)
+ "Add GROUP to the list of defined documentation groups.
+FUNCTIONS is a list of elements on the form:
+
+ (fun
+ :no-manual BOOL
+ :args ARGS
+ :eval EXAMPLE-FORM
+ :no-eval EXAMPLE-FORM
+ :no-eval* EXAMPLE-FORM
+ :no-value EXAMPLE-FORM
+ :result RESULT-FORM
+ :result-string RESULT-FORM
+ :eg-result RESULT-FORM
+ :eg-result-string RESULT-FORM)
+
+BOOL should be non-nil if the function isn't documented in the
+manual.
+
+ARGS is optional; the function's signature is displayed if ARGS
+is not present.
+
+If EVAL isn't a string, it will be printed with `prin1', and then
+evaluated to give a result, which is also printed. If it's a
+string, it'll be inserted as is, then the string will be `read',
+and then evaluated.
+
+There can be any number of :example/:result elements."
+ `(progn
+ (setq shortdoc--groups (delq (assq ',group shortdoc--groups)
+ shortdoc--groups))
+ (push (cons ',group ',functions) shortdoc--groups)))
+
+(define-short-documentation-group alist
+ "Alist Basics"
+ (assoc
+ :eval (assoc 'foo '((foo . bar) (zot . baz))))
+ (rassoc
+ :eval (rassoc 'bar '((foo . bar) (zot . baz))))
+ (assq
+ :eval (assq 'foo '((foo . bar) (zot . baz))))
+ (rassq
+ :eval (rassq 'bar '((foo . bar) (zot . baz))))
+ (assoc-string
+ :eval (assoc-string "foo" '(("foo" . "bar") ("zot" "baz"))))
+ "Manipulating Alists"
+ (assoc-delete-all
+ :eval (assoc-delete-all "foo" '(("foo" . "bar") ("zot" . "baz")) #'equal))
+ (assq-delete-all
+ :eval (assq-delete-all 'foo '((foo . bar) (zot . baz))))
+ (rassq-delete-all
+ :eval (rassq-delete-all 'bar '((foo . bar) (zot . baz))))
+ (alist-get
+ :eval (let ((foo '((bar . baz))))
+ (setf (alist-get 'bar foo) 'zot)
+ foo))
+ "Misc"
+ (assoc-default
+ :eval (assoc-default "foobar" '(("foo" . baz)) #'string-match))
+ (copy-alist
+ :eval (let* ((old '((foo . bar)))
+ (new (copy-alist old)))
+ (eq old new)))
+ ;; FIXME: Outputs "\.rose" for the symbol `.rose'.
+ ;; (let-alist
+ ;; :eval (let ((colors '((rose . red)
+ ;; (lily . white))))
+ ;; (let-alist colors
+ ;; (if (eq .rose 'red)
+ ;; .lily))))
+ )
+
+(define-short-documentation-group string
+ "Making Strings"
+ (make-string
+ :args (length init)
+ :eval "(make-string 5 ?x)")
+ (string
+ :eval "(string ?a ?b ?c)")
+ (concat
+ :eval (concat "foo" "bar" "zot"))
+ (string-join
+ :no-manual t
+ :eval (string-join '("foo" "bar" "zot") " "))
+ (mapconcat
+ :eval (mapconcat (lambda (a) (concat "[" a "]"))
+ '("foo" "bar" "zot") " "))
+ (string-pad
+ :eval (string-pad "foo" 5)
+ :eval (string-pad "foobar" 5)
+ :eval (string-pad "foo" 5 ?- t))
+ (mapcar
+ :eval (mapcar #'identity "123"))
+ (format
+ :eval (format "This number is %d" 4))
+ "Manipulating Strings"
+ (substring
+ :eval (substring "foobar" 0 3)
+ :eval (substring "foobar" 3))
+ (string-limit
+ :eval (string-limit "foobar" 3)
+ :eval (string-limit "foobar" 3 t)
+ :eval (string-limit "foobar" 10)
+ :eval (string-limit "fo好" 3 nil 'utf-8))
+ (truncate-string-to-width
+ :eval (truncate-string-to-width "foobar" 3)
+ :eval (truncate-string-to-width "你好bar" 5))
+ (split-string
+ :eval (split-string "foo bar")
+ :eval (split-string "|foo|bar|" "|")
+ :eval (split-string "|foo|bar|" "|" t))
+ (split-string-and-unquote
+ :eval (split-string-and-unquote "foo \"bar zot\""))
+ (split-string-shell-command
+ :eval (split-string-shell-command "ls /tmp/'foo bar'"))
+ (string-lines
+ :eval (string-lines "foo\n\nbar")
+ :eval (string-lines "foo\n\nbar" t))
+ (string-replace
+ :eval (string-replace "foo" "bar" "foozot"))
+ (replace-regexp-in-string
+ :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*"))
+ (string-trim
+ :args (string)
+ :doc "Trim STRING of leading and trailing white space."
+ :eval (string-trim " foo "))
+ (string-trim-left
+ :eval (string-trim-left "oofoo" "o+"))
+ (string-trim-right
+ :eval (string-trim-right "barkss" "s+"))
+ (string-truncate-left
+ :no-manual t
+ :eval (string-truncate-left "longstring" 8))
+ (string-remove-suffix
+ :no-manual t
+ :eval (string-remove-suffix "bar" "foobar"))
+ (string-remove-prefix
+ :no-manual t
+ :eval (string-remove-prefix "foo" "foobar"))
+ (string-chop-newline
+ :eval (string-chop-newline "foo\n"))
+ (string-clean-whitespace
+ :eval (string-clean-whitespace " foo bar "))
+ (string-fill
+ :eval (string-fill "Three short words" 12)
+ :eval (string-fill "Long-word" 3))
+ (reverse
+ :eval (reverse "foo"))
+ (substring-no-properties
+ :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3))
+ (try-completion
+ :eval (try-completion "foo" '("foobar" "foozot" "gazonk")))
+ "Predicates for Strings"
+ (string-equal
+ :eval (string-equal "foo" "foo"))
+ (eq
+ :eval (eq "foo" "foo"))
+ (eql
+ :eval (eql "foo" "foo"))
+ (equal
+ :eval (equal "foo" "foo"))
+ (cl-equalp
+ :eval (cl-equalp "Foo" "foo"))
+ (stringp
+ :eval "(stringp ?a)")
+ (string-empty-p
+ :no-manual t
+ :eval (string-empty-p ""))
+ (string-blank-p
+ :no-manual t
+ :eval (string-blank-p " \n"))
+ (string-lessp
+ :eval (string-lessp "foo" "bar"))
+ (string-greaterp
+ :eval (string-greaterp "foo" "bar"))
+ (string-version-lessp
+ :eval (string-version-lessp "pic4.png" "pic32.png"))
+ (string-prefix-p
+ :eval (string-prefix-p "foo" "foobar"))
+ (string-suffix-p
+ :eval (string-suffix-p "bar" "foobar"))
+ "Case Manipulation"
+ (upcase
+ :eval (upcase "foo"))
+ (downcase
+ :eval (downcase "FOObar"))
+ (capitalize
+ :eval (capitalize "foo bar zot"))
+ (upcase-initials
+ :eval (upcase-initials "The CAT in the hAt"))
+ "Converting Strings"
+ (string-to-number
+ :eval (string-to-number "42")
+ :eval (string-to-number "deadbeef" 16))
+ (number-to-string
+ :eval (number-to-string 42))
+ "Data About Strings"
+ (length
+ :eval (length "foo"))
+ (string-search
+ :eval (string-search "bar" "foobarzot"))
+ (assoc-string
+ :eval (assoc-string "foo" '(("a" 1) (foo 2))))
+ (seq-position
+ :eval "(seq-position \"foobarzot\" ?z)"))
+
+(define-short-documentation-group file-name
+ "File Name Manipulation"
+ (file-name-directory
+ :eval (file-name-directory "/tmp/foo")
+ :eval (file-name-directory "/tmp/foo/"))
+ (file-name-nondirectory
+ :eval (file-name-nondirectory "/tmp/foo")
+ :eval (file-name-nondirectory "/tmp/foo/"))
+ (file-name-sans-versions
+ :args (filename)
+ :eval (file-name-sans-versions "/tmp/foo~"))
+ (file-name-extension
+ :eval (file-name-extension "/tmp/foo.txt"))
+ (file-name-sans-extension
+ :eval (file-name-sans-extension "/tmp/foo.txt"))
+ (file-name-with-extension
+ :eval (file-name-with-extension "foo.txt" "bin")
+ :eval (file-name-with-extension "foo" "bin"))
+ (file-name-base
+ :eval (file-name-base "/tmp/foo.txt"))
+ (file-relative-name
+ :eval (file-relative-name "/tmp/foo" "/tmp"))
+ (make-temp-name
+ :eval (make-temp-name "/tmp/foo-"))
+ (file-name-concat
+ :eval (file-name-concat "/tmp/" "foo")
+ :eval (file-name-concat "/tmp" "foo")
+ :eval (file-name-concat "/tmp" "foo" "bar/" "zot")
+ :eval (file-name-concat "/tmp" "~"))
+ (expand-file-name
+ :eval (expand-file-name "foo" "/tmp/")
+ :eval (expand-file-name "foo" "/tmp///")
+ :eval (expand-file-name "foo" "/tmp/foo/.././")
+ :eval (expand-file-name "~" "/tmp/"))
+ (substitute-in-file-name
+ :eval (substitute-in-file-name "$HOME/foo"))
+ "Directory Functions"
+ (file-name-as-directory
+ :eval (file-name-as-directory "/tmp/foo"))
+ (directory-file-name
+ :eval (directory-file-name "/tmp/foo/"))
+ (abbreviate-file-name
+ :no-eval (abbreviate-file-name "/home/some-user")
+ :eg-result "~some-user")
+ "Quoted File Names"
+ (file-name-quote
+ :args (name)
+ :eval (file-name-quote "/tmp/foo"))
+ (file-name-unquote
+ :args (name)
+ :eval (file-name-unquote "/:/tmp/foo"))
+ "Predicates"
+ (file-name-absolute-p
+ :eval (file-name-absolute-p "/tmp/foo")
+ :eval (file-name-absolute-p "foo"))
+ (directory-name-p
+ :eval (directory-name-p "/tmp/foo/"))
+ (file-name-quoted-p
+ :eval (file-name-quoted-p "/:/tmp/foo")))
+
+(define-short-documentation-group file
+ "Inserting Contents"
+ (insert-file-contents
+ :no-eval (insert-file-contents "/tmp/foo")
+ :eg-result ("/tmp/foo" 6))
+ (insert-file-contents-literally
+ :no-eval (insert-file-contents-literally "/tmp/foo")
+ :eg-result ("/tmp/foo" 6))
+ (find-file
+ :no-eval (find-file "/tmp/foo")
+ :eg-result-string "#<buffer foo>")
+ "Predicates"
+ (file-symlink-p
+ :no-eval (file-symlink-p "/tmp/foo")
+ :eg-result t)
+ (file-directory-p
+ :no-eval (file-directory-p "/tmp")
+ :eg-result t)
+ (file-regular-p
+ :no-eval (file-regular-p "/tmp/foo")
+ :eg-result t)
+ (file-exists-p
+ :no-eval (file-exists-p "/tmp/foo")
+ :eg-result t)
+ (file-readable-p
+ :no-eval (file-readable-p "/tmp/foo")
+ :eg-result t)
+ (file-writeable-p
+ :no-eval (file-writeable-p "/tmp/foo")
+ :eg-result t)
+ (file-accessible-directory-p
+ :no-eval (file-accessible-directory-p "/tmp")
+ :eg-result t)
+ (file-executable-p
+ :no-eval (file-executable-p "/bin/cat")
+ :eg-result t)
+ (file-newer-than-file-p
+ :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar")
+ :eg-result nil)
+ (file-equal-p
+ :no-eval (file-equal-p "/tmp/foo" "/tmp/bar")
+ :eg-result nil)
+ (file-in-directory-p
+ :no-eval (file-in-directory-p "/tmp/foo" "/tmp/")
+ :eg-result t)
+ (file-locked-p
+ :no-eval (file-locked-p "/tmp/foo")
+ :eg-result nil)
+ "Information"
+ (file-attributes
+ :no-eval* (file-attributes "/tmp"))
+ (file-truename
+ :no-eval (file-truename "/tmp/foo/bar")
+ :eg-result "/tmp/foo/zot")
+ (file-chase-links
+ :no-eval (file-chase-links "/tmp/foo/bar")
+ :eg-result "/tmp/foo/zot")
+ (vc-responsible-backend
+ :args (file &optional no-error)
+ :no-eval (vc-responsible-backend "/src/foo/bar.c")
+ :eg-result Git)
+ (file-acl
+ :no-eval (file-acl "/tmp/foo")
+ :eg-result "user::rw-\ngroup::r--\nother::r--\n")
+ (file-extended-attributes
+ :no-eval* (file-extended-attributes "/tmp/foo"))
+ (file-selinux-context
+ :no-eval* (file-selinux-context "/tmp/foo"))
+ (locate-file
+ :no-eval (locate-file "syslog" '("/var/log" "/usr/bin"))
+ :eg-result "/var/log/syslog")
+ (executable-find
+ :no-eval (executable-find "ls")
+ :eg-result "/usr/bin/ls")
+ "Creating"
+ (make-temp-file
+ :no-eval (make-temp-file "/tmp/foo-")
+ :eg-result "/tmp/foo-ZcXFMj")
+ (make-nearby-temp-file
+ :no-eval (make-nearby-temp-file "/tmp/foo-")
+ :eg-result "/tmp/foo-xe8iON")
+ (write-region
+ :no-value (write-region (point-min) (point-max) "/tmp/foo"))
+ "Directories"
+ (make-directory
+ :no-value (make-directory "/tmp/bar/zot/" t))
+ (directory-files
+ :no-eval (directory-files "/tmp/")
+ :eg-result ("." ".." ".ICE-unix" ".Test-unix"))
+ (directory-files-recursively
+ :no-eval (directory-files-recursively "/tmp/" "\\.png\\'")
+ :eg-result ("/tmp/foo.png" "/tmp/zot.png" "/tmp/bar/foobar.png"))
+ (directory-files-and-attributes
+ :no-eval* (directory-files-and-attributes "/tmp/foo"))
+ (file-expand-wildcards
+ :no-eval (file-expand-wildcards "/tmp/*.png")
+ :eg-result ("/tmp/foo.png" "/tmp/zot.png"))
+ (locate-dominating-file
+ :no-eval (locate-dominating-file "foo.png" "/tmp/foo/bar/zot")
+ :eg-result "/tmp/foo.png")
+ (copy-directory
+ :no-value (copy-directory "/tmp/bar/" "/tmp/barcopy"))
+ (delete-directory
+ :no-value (delete-directory "/tmp/bar/"))
+ "File Operations"
+ (rename-file
+ :no-value (rename-file "/tmp/foo" "/tmp/newname"))
+ (copy-file
+ :no-value (copy-file "/tmp/foo" "/tmp/foocopy"))
+ (delete-file
+ :no-value (delete-file "/tmp/foo"))
+ (make-empty-file
+ :no-value (make-empty-file "/tmp/foo"))
+ (make-symbolic-link
+ :no-value (make-symbolic-link "/tmp/foo" "/tmp/foosymlink"))
+ (add-name-to-file
+ :no-value (add-name-to-file "/tmp/foo" "/tmp/bar"))
+ (set-file-modes
+ :no-value "(set-file-modes \"/tmp/foo\" #o644)")
+ (set-file-times
+ :no-value (set-file-times "/tmp/foo" (current-time)))
+ "File Modes"
+ (set-default-file-modes
+ :no-value "(set-default-file-modes #o755)")
+ (default-file-modes
+ :no-eval (default-file-modes)
+ :eg-result-string "#o755")
+ (file-modes-symbolic-to-number
+ :no-eval (file-modes-symbolic-to-number "a+r")
+ :eg-result-string "#o444")
+ (file-modes-number-to-symbolic
+ :eval "(file-modes-number-to-symbolic #o444)")
+ (set-file-extended-attributes
+ :no-eval (set-file-extended-attributes
+ "/tmp/foo" '((acl . "group::rxx")))
+ :eg-result t)
+ (set-file-selinux-context
+ :no-eval (set-file-selinux-context
+ "/tmp/foo" '(unconfined_u object_r user_home_t s0))
+ :eg-result t)
+ (set-file-acl
+ :no-eval (set-file-acl "/tmp/foo" "group::rxx")
+ :eg-result t))
+
+(define-short-documentation-group hash-table
+ "Hash Table Basics"
+ (make-hash-table
+ :no-eval (make-hash-table)
+ :result-string "#s(hash-table ...)")
+ (puthash
+ :no-eval (puthash 'key "value" table))
+ (gethash
+ :no-eval (gethash 'key table)
+ :eg-result "value")
+ (remhash
+ :no-eval (remhash 'key table)
+ :result nil)
+ (clrhash
+ :no-eval (clrhash table)
+ :result-string "#s(hash-table ...)")
+ (maphash
+ :no-eval (maphash (lambda (key value) (message value)) table)
+ :result nil)
+ "Other Hash Table Functions"
+ (hash-table-p
+ :eval (hash-table-p 123))
+ (copy-hash-table
+ :no-eval (copy-hash-table table)
+ :result-string "#s(hash-table ...)")
+ (hash-table-count
+ :no-eval (hash-table-count table)
+ :eg-result 15)
+ (hash-table-size
+ :no-eval (hash-table-size table)
+ :eg-result 65))
+
+(define-short-documentation-group list
+ "Making Lists"
+ (make-list
+ :eval (make-list 5 'a))
+ (cons
+ :eval (cons 1 '(2 3 4)))
+ (list
+ :eval (list 1 2 3))
+ (number-sequence
+ :eval (number-sequence 5 8))
+ "Operations on Lists"
+ (append
+ :eval (append '("foo" "bar") '("zot")))
+ (copy-tree
+ :eval (copy-tree '(1 (2 3) 4)))
+ (flatten-tree
+ :eval (flatten-tree '(1 (2 3) 4)))
+ (car
+ :eval (car '(one two three))
+ :eval (car '(one . two))
+ :eval (car nil))
+ (cdr
+ :eval (cdr '(one two three))
+ :eval (cdr '(one . two))
+ :eval (cdr nil))
+ (last
+ :eval (last '(one two three)))
+ (butlast
+ :eval (butlast '(one two three)))
+ (nbutlast
+ :eval (nbutlast (list 'one 'two 'three)))
+ (nth
+ :eval (nth 1 '(one two three)))
+ (nthcdr
+ :eval (nthcdr 1 '(one two three)))
+ (elt
+ :eval (elt '(one two three) 1))
+ (car-safe
+ :eval (car-safe '(one two three)))
+ (cdr-safe
+ :eval (cdr-safe '(one two three)))
+ (push
+ :no-eval* (push 'a list))
+ (pop
+ :no-eval* (pop list))
+ (setcar
+ :no-eval (setcar list 'c)
+ :result c)
+ (setcdr
+ :no-eval (setcdr list (list c))
+ :result '(c))
+ (nconc
+ :eval (nconc (list 1) (list 2 3 4)))
+ (delq
+ :eval (delq 2 (list 1 2 3 4))
+ :eval (delq "a" (list "a" "b" "c" "d")))
+ (delete
+ :eval (delete 2 (list 1 2 3 4))
+ :eval (delete "a" (list "a" "b" "c" "d")))
+ (remove
+ :eval (remove 2 '(1 2 3 4))
+ :eval (remove "a" '("a" "b" "c" "d")))
+ (delete-dups
+ :eval (delete-dups (list 1 2 4 3 2 4)))
+ "Mapping Over Lists"
+ (mapcar
+ :eval (mapcar #'list '(1 2 3)))
+ (mapcan
+ :eval (mapcan #'list '(1 2 3)))
+ (mapc
+ :eval (mapc #'insert '("1" "2" "3")))
+ (reduce
+ :eval (reduce #'+ '(1 2 3)))
+ (mapconcat
+ :eval (mapconcat #'identity '("foo" "bar") "|"))
+ "Predicates"
+ (listp
+ :eval (listp '(1 2 3))
+ :eval (listp nil)
+ :eval (listp '(1 . 2)))
+ (consp
+ :eval (consp '(1 2 3))
+ :eval (consp nil))
+ (proper-list-p
+ :eval (proper-list-p '(1 2 3))
+ :eval (proper-list-p nil)
+ :eval (proper-list-p '(1 . 2)))
+ (null
+ :eval (null nil))
+ (atom
+ :eval (atom 'a))
+ (nlistp
+ :eval (nlistp '(1 2 3))
+ :eval (nlistp t)
+ :eval (nlistp '(1 . 2)))
+ "Finding Elements"
+ (memq
+ :eval (memq 2 '(1 2 3))
+ :eval (memq 2.0 '(1.0 2.0 3.0))
+ :eval (memq "b" '("a" "b" "c")))
+ (member
+ :eval (member 2 '(1 2 3))
+ :eval (member "b" '("a" "b" "c")))
+ (remq
+ :eval (remq 2 '(1 2 3 2 4 2))
+ :eval (remq "b" '("a" "b" "c")))
+ (memql
+ :eval (memql 2.0 '(1.0 2.0 3.0)))
+ (member-ignore-case
+ :eval (member-ignore-case "foo" '("bar" "Foo" "zot")))
+ "Association Lists"
+ (assoc
+ :eval (assoc 'b '((a 1) (b 2))))
+ (rassoc
+ :eval (rassoc '2 '((a . 1) (b . 2))))
+ (assq
+ :eval (assq 'b '((a 1) (b 2)))
+ :eval (assq "a" '(("a" 1) ("b" 2))))
+ (rassq
+ :eval (rassq '2 '((a . 1) (b . 2))))
+ (assoc-string
+ :eval (assoc-string "foo" '(("a" 1) (foo 2))))
+ (alist-get
+ :eval (alist-get 2 '((1 . a) (2 . b))))
+ (assoc-default
+ :eval (assoc-default 2 '((1 . a) (2 . b) #'=)))
+ (copy-alist
+ :eval (copy-alist '((1 . a) (2 . b))))
+ (assq-delete-all
+ :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c))))
+ (assoc-delete-all
+ :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c))))
+ "Property Lists"
+ (plist-get
+ :eval (plist-get '(a 1 b 2 c 3) 'b))
+ (plist-put
+ :no-eval (setq plist (plist-put plist 'd 4))
+ :eq-result (a 1 b 2 c 3 d 4))
+ (lax-plist-get
+ :eval (lax-plist-get '("a" 1 "b" 2 "c" 3) "b"))
+ (lax-plist-put
+ :no-eval (setq plist (lax-plist-put plist "d" 4))
+ :eq-result '("a" 1 "b" 2 "c" 3 "d" 4))
+ (plist-member
+ :eval (plist-member '(a 1 b 2 c 3) 'b))
+ "Data About Lists"
+ (length
+ :eval (length '(a b c)))
+ (length<
+ :eval (length< '(a b c) 1))
+ (length>
+ :eval (length> '(a b c) 1))
+ (length=
+ :eval (length= '(a b c) 3))
+ (safe-length
+ :eval (safe-length '(a b c))))
+
+
+(define-short-documentation-group vector
+ (make-vector
+ :eval (make-vector 5 "foo"))
+ (vector
+ :eval (vector 1 "b" 3))
+ (vectorp
+ :eval (vectorp [1])
+ :eval (vectorp "1"))
+ (vconcat
+ :eval (vconcat '(1 2) [3 4]))
+ (append
+ :eval (append [1 2] nil))
+ (length
+ :eval (length [1 2 3]))
+ (mapcar
+ :eval (mapcar #'identity [1 2 3]))
+ (reduce
+ :eval (reduce #'+ [1 2 3]))
+ (seq-subseq
+ :eval (seq-subseq [1 2 3 4 5] 1 3)
+ :eval (seq-subseq [1 2 3 4 5] 1)))
+
+(define-short-documentation-group regexp
+ "Matching Strings"
+ (replace-regexp-in-string
+ :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*"))
+ (string-match-p
+ :eval (string-match-p "^[fo]+" "foobar"))
+ "Looking in Buffers"
+ (re-search-forward
+ :no-eval (re-search-forward "^foo$" nil t)
+ :eg-result 43)
+ (re-search-backward
+ :no-eval (re-search-backward "^foo$" nil t)
+ :eg-result 43)
+ (looking-at-p
+ :no-eval (looking-at-p "f[0-9]")
+ :eg-result t)
+ "Match Data"
+ (match-string
+ :eval (and (string-match "^\\([fo]+\\)b" "foobar")
+ (match-string 0 "foobar")))
+ (match-beginning
+ :no-eval (match-beginning 1)
+ :eg-result 0)
+ (match-end
+ :no-eval (match-end 1)
+ :eg-result 3)
+ (save-match-data
+ :no-eval (save-match-data ...))
+ "Replacing Match"
+ (replace-match
+ :no-eval (replace-match "new")
+ :eg-result nil)
+ (match-substitute-replacement
+ :no-eval (match-substitute-replacement "new")
+ :eg-result "new")
+ "Utilities"
+ (regexp-quote
+ :eval (regexp-quote "foo.*bar"))
+ (regexp-opt
+ :eval (regexp-opt '("foo" "bar")))
+ (regexp-opt-depth
+ :eval (regexp-opt-depth "\\(a\\(b\\)\\)"))
+ (regexp-opt-charset
+ :eval (regexp-opt-charset '(?a ?b ?c ?d ?e)))
+ "The `rx' Structured Regexp Notation"
+ (rx
+ :eval (rx "IP=" (+ digit) (= 3 "." (+ digit))))
+ (rx-to-string
+ :eval (rx-to-string '(| "foo" "bar")))
+ (rx-define
+ :no-eval "(and (rx-define haskell-comment (seq \"--\" (zero-or-more nonl)))
+ (rx haskell-comment))"
+ :result "--.*")
+ (rx-let
+ :eval "(rx-let ((comma-separated (item) (seq item (0+ \",\" item)))
+ (number (1+ digit))
+ (numbers (comma-separated number)))
+ (rx \"(\" numbers \")\"))"
+ :result "([[:digit:]]+\\(?:,[[:digit:]]+\\)*)")
+ (rx-let-eval
+ :eval "(rx-let-eval
+ '((ponder (x) (seq \"Where have all the \" x \" gone?\")))
+ (rx-to-string
+ '(ponder (or \"flowers\" \"cars\" \"socks\"))))"
+ :result "\\(?:Where have all the \\(?:\\(?:car\\|flower\\|sock\\)s\\) gone\\?\\)"))
+
+(define-short-documentation-group sequence
+ "Sequence Predicates"
+ (seq-contains-p
+ :eval (seq-contains-p '(a b c) 'b)
+ :eval (seq-contains-p '(a b c) 'd))
+ (seq-every-p
+ :eval (seq-every-p #'numberp '(1 2 3)))
+ (seq-empty-p
+ :eval (seq-empty-p []))
+ (seq-set-equal-p
+ :eval (seq-set-equal-p '(1 2 3) '(3 1 2)))
+ (seq-some
+ :eval (seq-some #'cl-evenp '(1 2 3)))
+ "Building Sequences"
+ (seq-concatenate
+ :eval (seq-concatenate 'vector '(1 2) '(c d)))
+ (seq-copy
+ :eval (seq-copy '(a 2)))
+ (seq-into
+ :eval (seq-into '(1 2 3) 'vector))
+ "Utility Functions"
+ (seq-count
+ :eval (seq-count #'numberp '(1 b c 4)))
+ (seq-elt
+ :eval (seq-elt '(a b c) 1))
+ (seq-random-elt
+ :no-eval (seq-random-elt '(a b c))
+ :eg-result c)
+ (seq-find
+ :eval (seq-find #'numberp '(a b 3 4 f 6)))
+ (seq-position
+ :eval (seq-position '(a b c) 'c))
+ (seq-length
+ :eval (seq-length "abcde"))
+ (seq-max
+ :eval (seq-max [1 2 3]))
+ (seq-min
+ :eval (seq-min [1 2 3]))
+ (seq-first
+ :eval (seq-first [a b c]))
+ (seq-rest
+ :eval (seq-rest '[1 2 3]))
+ (seq-reverse
+ :eval (seq-reverse '(1 2 3)))
+ (seq-sort
+ :eval (seq-sort #'> '(1 2 3)))
+ (seq-sort-by
+ :eval (seq-sort-by (lambda (a) (/ 1.0 a)) #'< '(1 2 3)))
+ "Mapping Over Sequences"
+ (seq-map
+ :eval (seq-map #'1+ '(1 2 3)))
+ (seq-map-indexed
+ :eval (seq-map-indexed (lambda (a i) (cons i a)) '(a b c)))
+ (seq-mapcat
+ :eval (seq-mapcat #'upcase '("a" "b" "c") 'string))
+ (seq-do
+ :no-eval (seq-do (lambda (a) (insert a)) '("foo" "bar"))
+ :eg-result ("foo" "bar"))
+ (seq-do-indexed
+ :no-eval (seq-do-indexed
+ (lambda (a index) (message "%s:%s" index a))
+ '("foo" "bar"))
+ :eg-result nil)
+ (seq-reduce
+ :eval (seq-reduce #'* [1 2 3] 2))
+ "Excerpting Sequences"
+ (seq-drop
+ :eval (seq-drop '(a b c) 2))
+ (seq-drop-while
+ :eval (seq-drop-while #'numberp '(1 2 c d 5)))
+ (seq-filter
+ :eval (seq-filter #'numberp '(a b 3 4 f 6)))
+ (seq-remove
+ :eval (seq-remove #'numberp '(1 2 c d 5)))
+ (seq-group-by
+ :eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6)))
+ (seq-difference
+ :eval (seq-difference '(1 2 3) '(2 3 4)))
+ (seq-intersection
+ :eval (seq-intersection '(1 2 3) '(2 3 4)))
+ (seq-partition
+ :eval (seq-partition '(a b c d e f g h) 3))
+ (seq-subseq
+ :eval (seq-subseq '(a b c d e) 2 4))
+ (seq-take
+ :eval (seq-take '(a b c d e) 3))
+ (seq-take-while
+ :eval (seq-take-while #'cl-evenp [2 4 9 6 5]))
+ (seq-uniq
+ :eval (seq-uniq '(a b d b a c))))
+
+(define-short-documentation-group buffer
+ "Buffer Basics"
+ (current-buffer
+ :no-eval (current-buffer)
+ :eg-result-string "#<buffer shortdoc.el>")
+ (bufferp
+ :eval (bufferp 23))
+ (buffer-live-p
+ :no-eval (buffer-live-p some-buffer)
+ :eg-result t)
+ (buffer-modified-p
+ :eval (buffer-modified-p (current-buffer)))
+ (buffer-name
+ :eval (buffer-name))
+ (window-buffer
+ :eval (window-buffer))
+ "Selecting Buffers"
+ (get-buffer-create
+ :no-eval (get-buffer-create "*foo*")
+ :eg-result-string "#<buffer *foo*>")
+ (pop-to-buffer
+ :no-eval (pop-to-buffer "*foo*")
+ :eg-result-string "#<buffer *foo*>")
+ (with-current-buffer
+ :no-eval* (with-current-buffer buffer (buffer-size)))
+ "Points and Positions"
+ (point
+ :eval (point))
+ (point-min
+ :eval (point-min))
+ (point-max
+ :eval (point-max))
+ (line-beginning-position
+ :eval (line-beginning-position))
+ (line-end-position
+ :eval (line-end-position))
+ (buffer-size
+ :eval (buffer-size))
+ "Moving Around"
+ (goto-char
+ :no-eval (goto-char (point-max))
+ :eg-result 342)
+ (search-forward
+ :no-eval (search-forward "some-string" nil t)
+ :eg-result 245)
+ (re-search-forward
+ :no-eval (re-search-forward "some-s.*g" nil t)
+ :eg-result 245)
+ (forward-line
+ :no-eval (forward-line 1)
+ :eg-result 0
+ :no-eval (forward-line -2)
+ :eg-result 0)
+ "Strings from Buffers"
+ (buffer-string
+ :no-eval* (buffer-string))
+ (buffer-substring
+ :eval (buffer-substring (point-min) (+ (point-min) 10)))
+ (buffer-substring-no-properties
+ :eval (buffer-substring-no-properties (point-min) (+ (point-min) 10)))
+ (following-char
+ :no-eval (following-char)
+ :eg-result 67)
+ (char-after
+ :eval (char-after 45))
+ "Altering Buffers"
+ (delete-region
+ :no-value (delete-region (point-min) (point-max)))
+ (erase-buffer
+ :no-value (erase-buffer))
+ (insert
+ :no-value (insert "This string will be inserted in the buffer\n"))
+ "Locking"
+ (lock-buffer
+ :no-value (lock-buffer "/tmp/foo"))
+ (unlock-buffer
+ :no-value (unlock-buffer)))
+
+(define-short-documentation-group overlay
+ "Predicates"
+ (overlayp
+ :no-eval (overlayp some-overlay)
+ :eg-result t)
+ "Creation and Deletion"
+ (make-overlay
+ :args (beg end &optional buffer)
+ :no-eval (make-overlay 1 10)
+ :eg-result-string "#<overlay from 1 to 10 in *foo*>")
+ (delete-overlay
+ :no-eval (delete-overlay foo)
+ :eg-result t)
+ "Searching Overlays"
+ (overlays-at
+ :no-eval (overlays-at 15)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (overlays-in
+ :no-eval (overlays-in 1 30)
+ :eg-result-string "(#<overlay from 1 to 10 in *foo*>)")
+ (next-overlay-change
+ :no-eval (next-overlay-change 1)
+ :eg-result 20)
+ (previous-overlay-change
+ :no-eval (previous-overlay-change 30)
+ :eg-result 20)
+ "Overlay Properties"
+ (overlay-start
+ :no-eval (overlay-start foo)
+ :eg-result 1)
+ (overlay-end
+ :no-eval (overlay-end foo)
+ :eg-result 10)
+ (overlay-put
+ :no-eval (overlay-put foo 'happy t)
+ :eg-result t)
+ (overlay-get
+ :no-eval (overlay-get foo 'happy)
+ :eg-result t)
+ (overlay-buffer
+ :no-eval (overlay-buffer foo))
+ "Moving Overlays"
+ (move-overlay
+ :no-eval (move-overlay foo 5 20)
+ :eg-result-string "#<overlay from 5 to 20 in *foo*>"))
+
+(define-short-documentation-group process
+ (make-process
+ :no-eval (make-process :name "foo" :command '("cat" "/tmp/foo"))
+ :eg-result-string "#<process foo>")
+ (processp
+ :eval (processp t))
+ (delete-process
+ :no-value (delete-process process))
+ (kill-process
+ :no-value (kill-process process))
+ (set-process-sentinel
+ :no-value (set-process-sentinel process (lambda (proc string))))
+ (process-buffer
+ :no-eval (process-buffer process)
+ :eg-result-string "#<buffer *foo*>")
+ (get-buffer-process
+ :no-eval (get-buffer-process buffer)
+ :eg-result-string "#<process foo>")
+ (process-live-p
+ :no-eval (process-live-p process)
+ :eg-result t))
+
+(define-short-documentation-group number
+ "Arithmetic"
+ (+
+ :args (&rest numbers)
+ :eval (+ 1 2)
+ :eval (+ 1 2 3 4))
+ (-
+ :args (&rest numbers)
+ :eval (- 3 2)
+ :eval (- 6 3 2))
+ (*
+ :args (&rest numbers)
+ :eval (* 3 4 5))
+ (/
+ :eval (/ 10 5)
+ :eval (/ 10 6)
+ :eval (/ 10.0 6)
+ :eval (/ 10.0 3 3))
+ (%
+ :eval (% 10 5)
+ :eval (% 10 6))
+ (mod
+ :eval (mod 10 5)
+ :eval (mod 10 6)
+ :eval (mod 10.5 6))
+ (1+
+ :eval (1+ 2))
+ (1-
+ :eval (1- 4))
+ "Predicates"
+ (=
+ :args (number &rest numbers)
+ :eval (= 4 4)
+ :eval (= 4.0 4.0)
+ :eval (= 4 5 6 7))
+ (eq
+ :eval (eq 4 4)
+ :eval (eq 4.0 4.0))
+ (eql
+ :eval (eql 4 4)
+ :eval (eql 4 "4")
+ :eval (eql 4.0 4.0))
+ (/=
+ :eval (/= 4 4))
+ (<
+ :args (number &rest numbers)
+ :eval (< 4 4)
+ :eval (< 1 2 3))
+ (<=
+ :args (number &rest numbers)
+ :eval (<= 4 4)
+ :eval (<= 1 2 3))
+ (>
+ :args (number &rest numbers)
+ :eval (> 4 4)
+ :eval (> 1 2 3))
+ (>=
+ :args (number &rest numbers)
+ :eval (>= 4 4)
+ :eval (>= 1 2 3))
+ (zerop
+ :eval (zerop 0))
+ (cl-plusp
+ :eval (cl-plusp 0)
+ :eval (cl-plusp 1))
+ (cl-minusp
+ :eval (cl-minusp 0)
+ :eval (cl-minusp -1))
+ (cl-oddp
+ :eval (cl-oddp 3))
+ (cl-evenp
+ :eval (cl-evenp 6))
+ (natnump
+ :eval (natnump -1)
+ :eval (natnump 23))
+ (bignump
+ :eval (bignump 4)
+ :eval (bignump (expt 2 90)))
+ (fixnump
+ :eval (fixnump 4)
+ :eval (fixnump (expt 2 90)))
+ (floatp
+ :eval (floatp 5.4))
+ (integerp
+ :eval (integerp 5.4))
+ (numberp
+ :eval (numberp "5.4"))
+ (cl-digit-char-p
+ :eval (cl-digit-char-p ?5 10)
+ :eval (cl-digit-char-p ?f 16))
+ "Operations"
+ (max
+ :args (number &rest numbers)
+ :eval (max 7 9 3))
+ (min
+ :args (number &rest numbers)
+ :eval (min 7 9 3))
+ (abs
+ :eval (abs -4))
+ (float
+ :eval (float 2))
+ (truncate
+ :eval (truncate 1.2)
+ :eval (truncate -1.2)
+ :eval (truncate 5.4 2))
+ (floor
+ :eval (floor 1.2)
+ :eval (floor -1.2)
+ :eval (floor 5.4 2))
+ (ceiling
+ :eval (ceiling 1.2)
+ :eval (ceiling -1.2)
+ :eval (ceiling 5.4 2))
+ (round
+ :eval (round 1.2)
+ :eval (round -1.2)
+ :eval (round 5.4 2))
+ (random
+ :eval (random 6))
+ "Bit Operations"
+ (ash
+ :eval (ash 1 4)
+ :eval (ash 16 -1))
+ (lsh
+ :eval (lsh 1 4)
+ :eval (lsh 16 -1))
+ (logand
+ :no-eval "(logand #b10 #b111)"
+ :result-string "#b10")
+ (logior
+ :eval (logior 4 16))
+ (logxor
+ :eval (logxor 4 16))
+ (lognot
+ :eval (lognot 5))
+ (logcount
+ :eval (logcount 5))
+ "Floating Point"
+ (isnan
+ :eval (isnan 5.0))
+ (frexp
+ :eval (frexp 5.7))
+ (ldexp
+ :eval (ldexp 0.7125 3))
+ (logb
+ :eval (logb 10.5))
+ (ffloor
+ :eval (ffloor 1.2))
+ (fceiling
+ :eval (fceiling 1.2))
+ (ftruncate
+ :eval (ftruncate 1.2))
+ (fround
+ :eval (fround 1.2))
+ "Standard Math Functions"
+ (sin
+ :eval (sin float-pi))
+ (cos
+ :eval (cos float-pi))
+ (tan
+ :eval (tan float-pi))
+ (asin
+ :eval (asin float-pi))
+ (acos
+ :eval (acos float-pi))
+ (atan
+ :eval (atan float-pi))
+ (exp
+ :eval (exp 4))
+ (log
+ :eval (log 54.59))
+ (expt
+ :eval (expt 2 16))
+ (sqrt
+ :eval (sqrt -1)))
+
+;;;###autoload
+(defun shortdoc-display-group (group &optional function)
+ "Pop to a buffer with short documentation summary for functions in GROUP.
+If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)."
+ (interactive (list (completing-read "Show summary for functions in: "
+ (mapcar #'car shortdoc--groups))))
+ (when (stringp group)
+ (setq group (intern group)))
+ (unless (assq group shortdoc--groups)
+ (error "No such documentation group %s" group))
+ (pop-to-buffer (format "*Shortdoc %s*" group))
+ (let ((inhibit-read-only t)
+ (prev nil))
+ (erase-buffer)
+ (shortdoc-mode)
+ (button-mode)
+ (mapc
+ (lambda (data)
+ (cond
+ ((stringp data)
+ (setq prev nil)
+ (unless (bobp)
+ (insert "\n"))
+ (insert (propertize
+ (concat (substitute-command-keys data) "\n\n")
+ 'face 'shortdoc-heading
+ 'shortdoc-section t)))
+ ;; There may be functions not yet defined in the data.
+ ((fboundp (car data))
+ (when prev
+ (insert (make-separator-line)))
+ (setq prev t)
+ (shortdoc--display-function data))))
+ (cdr (assq group shortdoc--groups))))
+ (goto-char (point-min))
+ (when function
+ (text-property-search-forward 'shortdoc-function function t)
+ (beginning-of-line)))
+
+(defun shortdoc--display-function (data)
+ (let ((function (pop data))
+ (start-section (point))
+ arglist-start)
+ ;; Function calling convention.
+ (insert (propertize "(" 'shortdoc-function function))
+ (if (plist-get data :no-manual)
+ (insert-text-button
+ (symbol-name function)
+ 'face 'button
+ 'action (lambda (_)
+ (describe-function function))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: describe function"))
+ (insert-text-button
+ (symbol-name function)
+ 'face 'button
+ 'action (lambda (_)
+ (info-lookup-symbol function 'emacs-lisp-mode))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show \
+function's documentation in the Info manual")))
+ (setq arglist-start (point))
+ (insert ")\n")
+ ;; Doc string.
+ (insert " "
+ (or (plist-get data :doc)
+ (car (split-string (documentation function) "\n"))))
+ (insert "\n")
+ (add-face-text-property start-section (point) 'shortdoc-section t)
+ (let ((print-escape-newlines t)
+ (double-arrow (if (char-displayable-p ?⇒)
+ "⇒"
+ "=>"))
+ (single-arrow (if (char-displayable-p ?→)
+ "→"
+ "->")))
+ (cl-loop for (type value) on data by #'cddr
+ do
+ (cl-case type
+ (:eval
+ (if (stringp value)
+ (insert " " value "\n")
+ (insert " ")
+ (prin1 value (current-buffer))
+ (insert "\n")
+ (insert " " double-arrow " ")
+ (prin1 (eval value) (current-buffer))
+ (insert "\n")))
+ (:no-eval*
+ (if (stringp value)
+ (insert " " value "\n")
+ (insert " ")
+ (prin1 value (current-buffer)))
+ (insert "\n " single-arrow " "
+ (propertize "[it depends]"
+ 'face 'shortdoc-section)
+ "\n"))
+ (:no-value
+ (if (stringp value)
+ (insert " " value)
+ (insert " ")
+ (prin1 value (current-buffer)))
+ (insert "\n"))
+ (:no-eval
+ (if (stringp value)
+ (insert " " value)
+ (insert " ")
+ (prin1 value (current-buffer)))
+ (insert "\n"))
+ (:result
+ (insert " " double-arrow " ")
+ (prin1 value (current-buffer))
+ (insert "\n"))
+ (:result-string
+ (insert " " double-arrow " ")
+ (princ value (current-buffer))
+ (insert "\n"))
+ (:eg-result
+ (insert " eg. " double-arrow " ")
+ (prin1 value (current-buffer))
+ (insert "\n"))
+ (:eg-result-string
+ (insert " eg. " double-arrow " ")
+ (princ value (current-buffer))
+ (insert "\n")))))
+ ;; Insert the arglist after doing the evals, in case that's pulled
+ ;; in the function definition.
+ (save-excursion
+ (goto-char arglist-start)
+ (dolist (param (or (plist-get data :args)
+ (help-function-arglist function t)))
+ (insert " " (symbol-name param)))
+ (add-face-text-property arglist-start (point) 'shortdoc-section t))))
+
+(defun shortdoc-function-groups (function)
+ "Return all shortdoc groups FUNCTION appears in."
+ (cl-loop for group in shortdoc--groups
+ when (assq function (cdr group))
+ collect (car group)))
+
+(defun shortdoc-add-function (group section elem)
+ "Add ELEM to shortdoc GROUP in SECTION.
+If GROUP doesn't exist, it will be created.
+If SECTION doesn't exist, it will be added.
+
+Example:
+
+ (shortdoc-add-function
+ 'file \"Predicates\"
+ '(file-locked-p :no-eval (file-locked-p \"/tmp\")))"
+ (let ((glist (assq group shortdoc--groups)))
+ (unless glist
+ (setq glist (list group))
+ (push glist shortdoc--groups))
+ (let ((slist (member section glist)))
+ (unless slist
+ (setq slist (list section))
+ (nconc glist slist))
+ (while (and (cdr slist)
+ (not (stringp (cadr slist))))
+ (setq slist (cdr slist)))
+ (setcdr slist (cons elem (cdr slist))))))
+
+(defvar shortdoc-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "n") 'shortdoc-next)
+ (define-key map (kbd "p") 'shortdoc-previous)
+ (define-key map (kbd "C-c C-n") 'shortdoc-next-section)
+ (define-key map (kbd "C-c C-p") 'shortdoc-previous-section)
+ map)
+ "Keymap for `shortdoc-mode'.")
+
+(define-derived-mode shortdoc-mode special-mode "shortdoc"
+ "Mode for shortdoc.")
+
+(defun shortdoc--goto-section (arg sym &optional reverse)
+ (unless (natnump arg)
+ (setq arg 1))
+ (while (> arg 0)
+ (funcall
+ (if reverse 'text-property-search-backward
+ 'text-property-search-forward)
+ sym nil t t)
+ (setq arg (1- arg))))
+
+(defun shortdoc-next (&optional arg)
+ "Move cursor to the next function.
+With ARG, do it that many times."
+ (interactive "p")
+ (shortdoc--goto-section arg 'shortdoc-function))
+
+(defun shortdoc-previous (&optional arg)
+ "Move cursor to the previous function.
+With ARG, do it that many times."
+ (interactive "p")
+ (shortdoc--goto-section arg 'shortdoc-function t)
+ (backward-char 1))
+
+(defun shortdoc-next-section (&optional arg)
+ "Move cursor to the next section.
+With ARG, do it that many times."
+ (interactive "p")
+ (shortdoc--goto-section arg 'shortdoc-section))
+
+(defun shortdoc-previous-section (&optional arg)
+ "Move cursor to the previous section.
+With ARG, do it that many times."
+ (interactive "p")
+ (shortdoc--goto-section arg 'shortdoc-section t)
+ (forward-line -2))
+
+(provide 'shortdoc)
+
+;;; shortdoc.el ends here
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index 26aa9b91927..ab3cb3c5ace 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -52,16 +52,24 @@
;; error because the parser just automatically does something. Better yet,
;; we can afford to use a sloppy grammar.
+;; The benefits of this approach were presented in the following article,
+;; which includes a kind of tutorial to get started with SMIE:
+;;
+;; SMIE: Weakness is Power! Auto-indentation with incomplete information
+;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1.
+;; doi: 10.22152/programming-journal.org/2021/5/1
+
;; A good background to understand the development (especially the parts
;; building the 2D precedence tables and then computing the precedence levels
;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune
;; and Ceriel Jacobs (BookBody.pdf available at
-;; http://dickgrune.com/Books/PTAPG_1st_Edition/).
+;; https://dickgrune.com/Books/PTAPG_1st_Edition/).
;;
;; OTOH we had to kill many chickens, read many coffee grounds, and practice
;; untold numbers of black magic spells, to come up with the indentation code.
;; Since then, some of that code has been beaten into submission, but the
-;; smie-indent-keyword is still pretty obscure.
+;; `smie-indent-keyword' function is still pretty obscure.
+
;; Conflict resolution:
;;
@@ -239,7 +247,7 @@ be either:
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
;; the repetition, maybe).
- (let* ((nts (mapcar 'car bnf)) ;Non-terminals.
+ (let* ((nts (mapcar #'car bnf)) ;Non-terminals.
(first-ops-table ())
(last-ops-table ())
(first-nts-table ())
@@ -258,7 +266,7 @@ be either:
(push resolver precs))
(t (error "Unknown resolver %S" resolver))))
(apply #'smie-merge-prec2s over
- (mapcar 'smie-precs->prec2 precs))))
+ (mapcar #'smie-precs->prec2 precs))))
again)
(dolist (rules bnf)
(let ((nt (car rules))
@@ -489,7 +497,7 @@ CSTS is a list of pairs representing arcs in a graph."
res))
cycle)))
(mapconcat
- (lambda (elems) (mapconcat 'identity elems "="))
+ (lambda (elems) (mapconcat #'identity elems "="))
(append names (list (car names)))
" < ")))
@@ -559,7 +567,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or
;; Then eliminate trivial constraints iteratively.
(let ((i 0))
(while csts
- (let ((rhvs (mapcar 'cdr csts))
+ (let ((rhvs (mapcar #'cdr csts))
(progress nil))
(dolist (cst csts)
(unless (memq (car cst) rhvs)
@@ -649,8 +657,8 @@ use syntax-tables to handle them in efficient C code.")
Same calling convention as `smie-forward-token-function' except
it should move backward to the beginning of the previous token.")
-(defalias 'smie-op-left 'car)
-(defalias 'smie-op-right 'cadr)
+(defalias 'smie-op-left #'car)
+(defalias 'smie-op-right #'cadr)
(defun smie-default-backward-token ()
(forward-comment (- (point)))
@@ -966,8 +974,7 @@ I.e. a good choice can be:
(defcustom smie-blink-matching-inners t
"Whether SMIE should blink to matching opener for inner keywords.
If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"."
- :type 'boolean
- :group 'smie)
+ :type 'boolean)
(defun smie-blink-matching-check (start end)
(save-excursion
@@ -1133,8 +1140,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer."
(defcustom smie-indent-basic 4
"Basic amount of indentation."
- :type 'integer
- :group 'smie)
+ :type 'integer)
(defvar smie-rules-function #'ignore
"Function providing the indentation rules.
@@ -1181,7 +1187,7 @@ designed specifically for use in this function.")
(and ;; (looking-at comment-start-skip) ;(bug#16041).
(forward-comment (point-max))))))
-(defalias 'smie-rule-hanging-p 'smie-indent--hanging-p)
+(defalias 'smie-rule-hanging-p #'smie-indent--hanging-p)
(defun smie-indent--hanging-p ()
"Return non-nil if the current token is \"hanging\".
A hanging keyword is one that's at the end of a line except it's not at
@@ -1197,7 +1203,7 @@ the beginning of a line."
(funcall smie--hanging-eolp-function)
(point))))))
-(defalias 'smie-rule-bolp 'smie-indent--bolp)
+(defalias 'smie-rule-bolp #'smie-indent--bolp)
(defun smie-indent--bolp ()
"Return non-nil if the current token is the first on the line."
(save-excursion (skip-chars-backward " \t") (bolp)))
@@ -1356,9 +1362,9 @@ Only meaningful when called from within `smie-rules-function'."
(funcall smie-rules-function :elem 'basic))
smie-indent-basic))
-(defun smie-indent--rule (method token
- ;; FIXME: Too many parameters.
- &optional after parent base-pos)
+(defun smie-indent--rule ( method token
+ ;; FIXME: Too many parameters.
+ &optional after parent base-pos)
"Compute indentation column according to `smie-rules-function'.
METHOD and TOKEN are passed to `smie-rules-function'.
AFTER is the position after TOKEN, if known.
@@ -1413,7 +1419,7 @@ BASE-POS is the position relative to which offsets should be applied."
(forward-sexp 1)
nil)
((eobp) nil)
- (t (error "Bumped into unknown token")))))
+ (t (error "Bumped into unknown token: %S" tok)))))
(defun smie-indent-backward-token ()
"Skip token backward and return it, along with its levels."
@@ -1802,9 +1808,11 @@ Each function is called with no argument, shouldn't move point, and should
return either nil if it has no opinion, or an integer representing the column
to which that point should be aligned, if we were to reindent it.")
+(defalias 'smie--funcall #'funcall) ;Debugging/tracing convenience indirection.
+
(defun smie-indent-calculate ()
"Compute the indentation to use for point."
- (run-hook-with-args-until-success 'smie-indent-functions))
+ (run-hook-wrapped 'smie-indent-functions #'smie--funcall))
(defun smie-indent-line ()
"Indent current line using the SMIE indentation engine."
@@ -1883,9 +1891,9 @@ KEYWORDS are additional arguments, which can use the following keywords:
(v (pop keywords)))
(pcase k
(:forward-token
- (set (make-local-variable 'smie-forward-token-function) v))
+ (setq-local smie-forward-token-function v))
(:backward-token
- (set (make-local-variable 'smie-backward-token-function) v))
+ (setq-local smie-backward-token-function v))
(_ (message "smie-setup: ignoring unknown keyword %s" k)))))
(let ((ca (cdr (assq :smie-closer-alist grammar))))
(when ca
@@ -2008,7 +2016,7 @@ value with which to replace it."
;; FIXME improve value-type.
:type '(choice (const nil)
(alist :key-type symbol))
- :initialize 'custom-initialize-set
+ :initialize #'custom-initialize-set
:set #'smie-config--setter)
(defun smie-config-local (rules)
@@ -2112,10 +2120,9 @@ position corresponding to each rule."
(throw 'found (list kind token
(or (nth 3 rewrite) res)))))))))
(default-new (smie-config--guess-value sig))
- (newstr (read-string (format "Adjust rule (%S %S -> %S) to%s: "
- (nth 0 sig) (nth 1 sig) (nth 2 sig)
- (if (not default-new) ""
- (format " (default %S)" default-new)))
+ (newstr (read-string (format-prompt
+ "Adjust rule (%S %S -> %S) to" default-new
+ (nth 0 sig) (nth 1 sig) (nth 2 sig))
nil nil (format "%S" default-new)))
(new (car (read-from-string newstr))))
(let ((old (rassoc sig smie-config--buffer-local)))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index a53cec4d625..468d124c0e2 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -127,7 +127,7 @@ This is like `if-let' but doesn't handle a VARLIST of the form
\(SYMBOL SOMETHING) specially."
(declare (indent 2)
(debug ((&rest [&or symbolp (symbolp form) (form)])
- form body)))
+ body)))
(if varlist
`(let* ,(setq varlist (internal--build-bindings varlist))
(if ,(caar (last varlist))
@@ -146,9 +146,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form
"Bind variables according to VARLIST and conditionally evaluate BODY.
Like `when-let*', except if BODY is empty and all the bindings
are non-nil, then the result is non-nil."
- (declare (indent 1)
- (debug ((&rest [&or symbolp (symbolp form) (form)])
- body)))
+ (declare (indent 1) (debug if-let*))
(let (res)
(if varlist
`(let* ,(setq varlist (internal--build-bindings varlist))
@@ -156,6 +154,7 @@ are non-nil, then the result is non-nil."
,@(or body `(,res))))
`(let* () ,@(or body '(t))))))
+;;;###autoload
(defmacro if-let (spec then &rest else)
"Bind variables according to SPEC and evaluate THEN or ELSE.
Evaluate each binding in turn, as in `let*', stopping if a
@@ -173,9 +172,9 @@ As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING)
like \((SYMBOL SOMETHING)). This exists for backward compatibility
with an old syntax that accepted only one binding."
(declare (indent 2)
- (debug ([&or (&rest [&or symbolp (symbolp form) (form)])
- (symbolp form)]
- form body)))
+ (debug ([&or (symbolp form) ; must be first, Bug#48489
+ (&rest [&or symbolp (symbolp form) (form)])]
+ body)))
(when (and (<= (length spec) 2)
(not (listp (car spec))))
;; Adjust the single binding case
@@ -214,27 +213,14 @@ The variable list SPEC is the same as in `if-let'."
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
-(defsubst string-trim-left (string &optional regexp)
- "Trim STRING of leading string matching REGEXP.
-
-REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
- (substring string (match-end 0))
- string))
-
-(defsubst string-trim-right (string &optional regexp)
- "Trim STRING of trailing string matching REGEXP.
-
-REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
- string)))
- (if i (substring string 0 i) string)))
-
-(defsubst string-trim (string &optional trim-left trim-right)
- "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
-
-TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
- (string-trim-left (string-trim-right string trim-right) trim-left))
+;;;###autoload
+(defun string-truncate-left (string length)
+ "Truncate STRING to LENGTH, replacing initial surplus with \"...\"."
+ (let ((strlen (length string)))
+ (if (<= strlen length)
+ string
+ (setq length (max 0 (- length 3)))
+ (concat "..." (substring string (max 0 (- strlen 1 length)))))))
(defsubst string-blank-p (string)
"Check whether STRING is either empty or only whitespace.
@@ -254,6 +240,115 @@ carriage return."
(substring string 0 (- (length string) (length suffix)))
string))
+(defun string-clean-whitespace (string)
+ "Clean up whitespace in STRING.
+All sequences of whitespaces in STRING are collapsed into a
+single space character, and leading/trailing whitespace is
+removed."
+ (let ((blank "[[:blank:]\r\n]+"))
+ (string-trim (replace-regexp-in-string blank " " string t t)
+ blank blank)))
+
+(defun string-fill (string length)
+ "Try to word-wrap STRING so that no lines are longer than LENGTH.
+Wrapping is done where there is whitespace. If there are
+individual words in STRING that are longer than LENGTH, the
+result will have lines that are longer than LENGTH."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (let ((fill-column length)
+ (adaptive-fill-mode nil))
+ (fill-region (point-min) (point-max)))
+ (buffer-string)))
+
+(defun string-limit (string length &optional end coding-system)
+ "Return (up to) a LENGTH substring of STRING.
+If STRING is shorter than or equal to LENGTH, the entire string
+is returned unchanged.
+
+If STRING is longer than LENGTH, return a substring consisting of
+the first LENGTH characters of STRING. If END is non-nil, return
+the last LENGTH characters instead.
+
+If CODING-SYSTEM is non-nil, STRING will be encoded before
+limiting, and LENGTH is interpreted as the number of bytes to
+limit the string to. The result will be a unibyte string that is
+shorter than LENGTH, but will not contain \"partial\" characters,
+even if CODING-SYSTEM encodes characters with several bytes per
+character.
+
+When shortening strings for display purposes,
+`truncate-string-to-width' is almost always a better alternative
+than this function."
+ (unless (natnump length)
+ (signal 'wrong-type-argument (list 'natnump length)))
+ (if coding-system
+ (let ((result nil)
+ (result-length 0)
+ (index (if end (1- (length string)) 0)))
+ ;; FIXME: This implementation, which uses encode-coding-char
+ ;; to encode the string one character at a time, is in general
+ ;; incorrect: coding-systems that produce prefix or suffix
+ ;; bytes, such as ISO-2022-based or UTF-8/16 with BOM, will
+ ;; produce those bytes for each character, instead of just
+ ;; once for the entire string. encode-coding-char attempts to
+ ;; remove those extra bytes at least in some situations, but
+ ;; it cannot do that in all cases. And in any case, producing
+ ;; what is supposed to be a UTF-16 or ISO-2022-CN encoded
+ ;; string which lacks the BOM bytes at the beginning and the
+ ;; charset designation sequences at the head and tail of the
+ ;; result will definitely surprise the callers in some cases.
+ (while (let ((encoded (encode-coding-char
+ (aref string index) coding-system)))
+ (and (<= (+ (length encoded) result-length) length)
+ (progn
+ (push encoded result)
+ (cl-incf result-length (length encoded))
+ (setq index (if end (1- index)
+ (1+ index))))
+ (if end (> index -1)
+ (< index (length string)))))
+ ;; No body.
+ )
+ (apply #'concat (if end result (nreverse result))))
+ (cond
+ ((<= (length string) length) string)
+ (end (substring string (- (length string) length)))
+ (t (substring string 0 length)))))
+
+;;;###autoload
+(defun string-lines (string &optional omit-nulls)
+ "Split STRING into a list of lines.
+If OMIT-NULLS, empty lines will be removed from the results."
+ (split-string string "\n" omit-nulls))
+
+(defun string-pad (string length &optional padding start)
+ "Pad STRING to LENGTH using PADDING.
+If PADDING is nil, the space character is used. If not nil, it
+should be a character.
+
+If STRING is longer than the absolute value of LENGTH, no padding
+is done.
+
+If START is nil (or not present), the padding is done to the end
+of the string, and if non-nil, padding is done to the start of
+the string."
+ (unless (natnump length)
+ (signal 'wrong-type-argument (list 'natnump length)))
+ (let ((pad-length (- length (length string))))
+ (if (< pad-length 0)
+ string
+ (concat (and start
+ (make-string pad-length (or padding ?\s)))
+ string
+ (and (not start)
+ (make-string pad-length (or padding ?\s)))))))
+
+(defun string-chop-newline (string)
+ "Remove the final newline (if any) from STRING."
+ (string-remove-suffix "\n" string))
+
(defun replace-region-contents (beg end replace-fn
&optional max-secs max-costs)
"Replace the region between BEG and END using REPLACE-FN.
@@ -283,6 +378,28 @@ it makes no sense to convert it to a string using
(set-buffer source-buffer)
(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
+(defmacro named-let (name bindings &rest body)
+ "Looping construct taken from Scheme.
+Like `let', bind variables in BINDINGS and then evaluate BODY,
+but with the twist that BODY can evaluate itself recursively by
+calling NAME, where the arguments passed to NAME are used
+as the new values of the bound variables in the recursive invocation."
+ (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
+ (require 'cl-lib)
+ (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
+ (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
+ ;; According to the Scheme semantics of named let, `name' is not in scope
+ ;; while evaluating the expressions in `bindings', and for this reason, the
+ ;; "initial" function call below needs to be outside of the `cl-labels'.
+ ;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
+ ;; expands to a lambda which the byte-compiler then combines with the
+ ;; funcall to make a `let' so we end up with a plain `while' loop and no
+ ;; remaining `lambda' at all.
+ `(funcall
+ (cl-labels ((,name ,fargs . ,body)) #',name)
+ . ,aargs)))
+
+
(provide 'subr-x)
;;; subr-x.el ends here
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index e0639118d80..0bb1b8916b1 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -63,9 +63,10 @@ override the buffer's syntax table for special syntactic constructs that
cannot be handled just by the buffer's syntax-table.
The specified function may 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.
+before END, but if it calls `syntax-ppss' on some
+position and later modifies the buffer on some earlier position,
+then it is its responsibility to call `syntax-ppss-flush-cache' to flush
+the now obsolete ppss info from the cache.
Note: When this variable is a function, it must apply _all_ the
`syntax-table' properties needed in the given text interval.
@@ -74,7 +75,7 @@ properties won't work properly.")
(defvar syntax-propertize-chunk-size 500)
-(defvar syntax-propertize-extend-region-functions
+(defvar-local 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
@@ -88,7 +89,6 @@ 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)
(cl-defstruct (ppss
(:constructor make-ppss)
@@ -125,6 +125,10 @@ otherwise nil. That construct can be a two character comment
delimiter or an Escaped or Char-quoted character."))
(defun syntax-propertize-wholelines (start end)
+ "Extend the region delimited by START and END to whole lines.
+This function is useful for
+`syntax-propertize-extend-region-functions';
+see Info node `(elisp) Syntax Properties'."
(goto-char start)
(cons (line-beginning-position)
(progn (goto-char end)
@@ -143,14 +147,28 @@ delimiter or an Escaped or Char-quoted character."))
(point-max))))
(cons beg end))
-(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))
+(defun syntax-propertize--shift-groups-and-backrefs (re n)
+ (let ((new-re (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))
+ (pos 0))
+ (while (string-match "\\\\\\([0-9]+\\)" new-re pos)
+ (setq pos (+ 1 (match-beginning 1)))
+ (when (save-match-data
+ ;; With \N, the \ must be in a subregexp context, i.e.,
+ ;; not in a character class or in a \{\} repetition.
+ (subregexp-context-p new-re (match-beginning 0)))
+ (let ((shifted (+ n (string-to-number (match-string 1 new-re)))))
+ (when (> shifted 9)
+ (error "There may be at most nine back-references"))
+ (setq new-re (replace-match (number-to-string shifted)
+ t t new-re 1)))))
+ new-re))
(defmacro syntax-propertize-precompile-rules (&rest rules)
"Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
@@ -194,7 +212,8 @@ 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."
+Note: There may be at most nine back-references in the REGEXPs of
+all RULES in total."
(declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
(form &rest
(numberp
@@ -223,7 +242,7 @@ Note: back-references in REGEXPs do not work."
;; tell when *this* match 0 has succeeded.
(cl-incf offset)
(setq re (concat "\\(" re "\\)")))
- (setq re (syntax-propertize--shift-groups re offset))
+ (setq re (syntax-propertize--shift-groups-and-backrefs re offset))
(let ((code '())
(condition
(cond
@@ -275,12 +294,13 @@ Note: back-references in REGEXPs do not work."
',(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)))))
+ (me (match-end ,gn)))
+ ,(macroexp-let2 nil syntax (nth 1 action)
+ `(progn
+ (if ,syntax
+ (put-text-property
+ mb me 'syntax-table ,syntax))
+ ,@(nthcdr 2 action)))))))
(t
`((let ((mb (match-beginning ,gn))
(me (match-end ,gn))
@@ -325,6 +345,11 @@ END) suitable for `syntax-propertize-function'."
(defvar-local syntax-ppss-table nil
"Syntax-table to use during `syntax-ppss', if any.")
+(defvar-local syntax-propertize--inhibit-flush nil
+ "If non-nil, `syntax-ppss-flush-cache' only flushes the ppss cache.
+Otherwise it flushes both the ppss cache and the properties
+set by `syntax-propertize'")
+
(defun syntax-propertize (pos)
"Ensure that syntax-table properties are set until POS (a buffer point)."
(when (< syntax-propertize--done pos)
@@ -332,7 +357,7 @@ END) suitable for `syntax-propertize-function'."
(setq syntax-propertize--done (max (point-max) pos))
;; (message "Needs to syntax-propertize from %s to %s"
;; syntax-propertize--done pos)
- (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ (setq-local parse-sexp-lookup-properties t)
(when (< syntax-propertize--done (point-min))
;; *Usually* syntax-propertize is called via syntax-ppss which
;; takes care of adding syntax-ppss-flush-cache to b-c-f, but this
@@ -350,23 +375,27 @@ END) suitable for `syntax-propertize-function'."
(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))
- ;; Avoid recursion!
- (syntax-propertize--done most-positive-fixnum))
- (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)))))
+ (first t)
+ (repeat t))
+ (while repeat
+ (setq repeat nil)
+ (run-hook-wrapped
+ 'syntax-propertize-extend-region-functions
+ (lambda (f)
+ (let ((new (funcall f start end))
+ ;; Avoid recursion!
+ (syntax-propertize--done most-positive-fixnum))
+ (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 first (setq repeat t))))
+ (setq first nil))))
;; Flush ppss cache between the original value of `start' and that
;; set above by syntax-propertize-extend-region-functions.
(syntax-ppss-flush-cache start)
@@ -376,8 +405,13 @@ END) suitable for `syntax-propertize-function'."
;; (message "syntax-propertizing from %s to %s" start end)
(remove-text-properties start end
'(syntax-table nil syntax-multiline nil))
- ;; Avoid recursion!
- (let ((syntax-propertize--done most-positive-fixnum))
+ ;; Make sure we only let-bind it buffer-locally.
+ (make-local-variable 'syntax-propertize--inhibit-flush)
+ ;; Let-bind `syntax-propertize--done' to avoid infinite recursion!
+ (let ((syntax-propertize--done most-positive-fixnum)
+ ;; Let `syntax-propertize-function' call
+ ;; `syntax-ppss-flush-cache' without worries.
+ (syntax-propertize--inhibit-flush t))
(funcall syntax-propertize-function start end)))))))))
;;; Link syntax-propertize with syntax.c.
@@ -456,7 +490,8 @@ These are valid when the buffer has no restriction.")
(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))
+ (unless syntax-propertize--inhibit-flush
+ (setq syntax-propertize--done (min beg syntax-propertize--done)))
;; Flush invalid cache entries.
(dolist (cell (list syntax-ppss-wide syntax-ppss-narrow))
(pcase cell
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index e9bb8a8ac0d..f0ee78745ac 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -36,6 +36,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup tabulated-list nil
"Tabulated-list customization group."
:group 'convenience
@@ -212,6 +214,8 @@ If ADVANCE is non-nil, move forward by one line afterwards."
special-mode-map))
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
+ (define-key map (kbd "M-<left>") 'tabulated-list-previous-column)
+ (define-key map (kbd "M-<right>") 'tabulated-list-next-column)
(define-key map "S" 'tabulated-list-sort)
(define-key map "}" 'tabulated-list-widen-current-column)
(define-key map "{" 'tabulated-list-narrow-current-column)
@@ -269,42 +273,48 @@ Populated by `tabulated-list-init-header'.")
;; FIXME: Should share code with tabulated-list-print-col!
(let ((x (max tabulated-list-padding 0))
(button-props `(help-echo "Click to sort by column"
- mouse-face header-line-highlight
- keymap ,tabulated-list-sort-button-map))
+ mouse-face header-line-highlight
+ keymap ,tabulated-list-sort-button-map))
+ (len (length tabulated-list-format))
(cols nil))
(if display-line-numbers
(setq x (+ x (tabulated-list-line-number-width))))
(push (propertize " " 'display `(space :align-to ,x)) cols)
- (dotimes (n (length tabulated-list-format))
+ (dotimes (n len)
(let* ((col (aref tabulated-list-format n))
+ (not-last-col (< n (1- len)))
(label (nth 0 col))
+ (lablen (length label))
+ (pname label)
(width (nth 1 col))
(props (nthcdr 3 col))
(pad-right (or (plist-get props :pad-right) 1))
(right-align (plist-get props :right-align))
(next-x (+ x pad-right width)))
+ (when (and (>= lablen 3) (> lablen width) not-last-col)
+ (setq label (truncate-string-to-width label (- lablen 1) nil nil t)))
(push
(cond
;; An unsortable column
((not (nth 2 col))
- (propertize label 'tabulated-list-column-name label))
+ (propertize label 'tabulated-list-column-name pname))
;; 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)
+ (concat label
+ (cond
+ ((and (< lablen 3) not-last-col) "")
+ ((cdr tabulated-list-sort-key)
(format " %c"
tabulated-list-gui-sort-indicator-desc))
- (t (format " %c"
+ (t (format " %c"
tabulated-list-gui-sort-indicator-asc))))
- 'face 'bold
- 'tabulated-list-column-name label
- button-props))
+ 'face 'bold
+ 'tabulated-list-column-name pname
+ button-props))
;; Unselected sortable column.
(t (apply 'propertize label
- 'tabulated-list-column-name label
+ 'tabulated-list-column-name pname
button-props)))
cols)
(when right-align
@@ -404,8 +414,7 @@ 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 and
-recenter window line accordingly.
+to the entry with the same ID element as the current line.
Non-nil UPDATE argument means to use an alternative printing
method which is faster if most entries haven't changed since the
@@ -418,18 +427,10 @@ changing `tabulated-list-sort-key'."
(funcall tabulated-list-entries)
tabulated-list-entries))
(sorter (tabulated-list--get-sorter))
- entry-id saved-pt saved-col window-line)
+ entry-id saved-pt saved-col)
(and remember-pos
(setq entry-id (tabulated-list-get-id))
- (setq saved-col (current-column))
- (when (eq (window-buffer) (current-buffer))
- (setq window-line
- (save-excursion
- (save-restriction
- (widen)
- (narrow-to-region (window-start) (point))
- (goto-char (point-min))
- (vertical-motion (buffer-size)))))))
+ (setq saved-col (current-column)))
;; Sort the entries, if necessary.
(when sorter
(setq entries (sort entries sorter)))
@@ -484,9 +485,7 @@ changing `tabulated-list-sort-key'."
;; If REMEMBER-POS was specified, move to the "old" location.
(if saved-pt
(progn (goto-char saved-pt)
- (move-to-column saved-col)
- (when window-line
- (recenter window-line)))
+ (move-to-column saved-col))
(goto-char (point-min)))))
(defun tabulated-list-print-entry (id cols)
@@ -547,10 +546,10 @@ Return the column number after insertion."
;; Don't truncate to `width' if the next column is align-right
;; and has some space left, truncate to `available-space' instead.
(when (and not-last-col
- (> label-width available-space)
- (setq label (truncate-string-to-width
- label available-space nil nil t t)
- label-width available-space)))
+ (> label-width available-space))
+ (setq label (truncate-string-to-width
+ label available-space nil nil t t)
+ label-width available-space))
(setq label (bidi-string-mark-left-to-right label))
(when (and right-align (> width label-width))
(let ((shift (- width label-width)))
@@ -650,18 +649,41 @@ this is the vector stored within it."
(defun tabulated-list-sort (&optional n)
"Sort Tabulated List entries by the column at point.
-With a numeric prefix argument N, sort the Nth column."
+With a numeric prefix argument N, sort the Nth column.
+
+If the numeric prefix is -1, restore order the list was
+originally displayed in."
(interactive "P")
- (let ((name (if n
- (car (aref tabulated-list-format n))
- (get-text-property (point)
- 'tabulated-list-column-name))))
- (if (nth 2 (assoc name (append tabulated-list-format nil)))
- (tabulated-list--sort-by-column-name name)
- (user-error "Cannot sort by %s" name))))
+ (if (equal n -1)
+ ;; Restore original order.
+ (progn
+ (unless tabulated-list--original-order
+ (error "Order is already in original order"))
+ (setq tabulated-list-entries
+ (sort tabulated-list-entries
+ (lambda (e1 e2)
+ (< (gethash e1 tabulated-list--original-order)
+ (gethash e2 tabulated-list--original-order)))))
+ (setq tabulated-list-sort-key nil)
+ (tabulated-list-init-header)
+ (tabulated-list-print t))
+ ;; Sort based on a column name.
+ (let ((name (if n
+ (car (aref tabulated-list-format n))
+ (get-text-property (point)
+ 'tabulated-list-column-name))))
+ (if (nth 2 (assoc name (append tabulated-list-format nil)))
+ (tabulated-list--sort-by-column-name name)
+ (user-error "Cannot sort by %s" name)))))
(defun tabulated-list--sort-by-column-name (name)
(when (and name (derived-mode-p 'tabulated-list-mode))
+ (unless tabulated-list--original-order
+ ;; Store the original order so that we can restore it later.
+ (setq tabulated-list--original-order (make-hash-table))
+ (cl-loop for elem in tabulated-list-entries
+ for i from 0
+ do (setf (gethash elem tabulated-list--original-order) i)))
;; Flip the sort order on a second click.
(if (equal name (car tabulated-list-sort-key))
(setcdr tabulated-list-sort-key
@@ -720,8 +742,32 @@ Interactively, N is the prefix numeric argument, and defaults to
(setq-local tabulated-list--current-lnum-width lnum-width)
(tabulated-list-init-header)))))
+(defun tabulated-list-next-column (&optional arg)
+ "Go to the start of the next column after point on the current line.
+If ARG is provided, move that many columns."
+ (interactive "p")
+ (dotimes (_ (or arg 1))
+ (let ((next (or (next-single-property-change
+ (point) 'tabulated-list-column-name)
+ (point-max))))
+ (when (<= next (line-end-position))
+ (goto-char next)))))
+
+(defun tabulated-list-previous-column (&optional arg)
+ "Go to the start of the column point is in on the current line.
+If ARG is provided, move that many columns."
+ (interactive "p")
+ (dotimes (_ (or arg 1))
+ (let ((prev (or (previous-single-property-change
+ (point) 'tabulated-list-column-name)
+ 1)))
+ (unless (< prev (line-beginning-position))
+ (goto-char prev)))))
+
;;; The mode definition:
+(defvar tabulated-list--original-order nil)
+
(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
@@ -761,6 +807,8 @@ as the ewoc pretty-printer."
(setq-local revert-buffer-function #'tabulated-list-revert)
(setq-local glyphless-char-display
(tabulated-list-make-glyphless-char-display-table))
+ (setq-local text-scale-remap-header-line t)
+ (setq-local tabulated-list--original-order nil)
;; Avoid messing up the entries' display just because the first
;; column of the first entry happens to begin with a R2L letter.
(setq bidi-paragraph-direction 'left-to-right)
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index 7de9d547ce4..4460fef97bd 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -1,4 +1,4 @@
-;;;; testcover-ses.el -- Example use of `testcover' to test "SES"
+;;; tcover-ses.el --- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -6,6 +6,8 @@
;; Keywords: spreadsheet lisp utility
;; Package: testcover
+;; 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
@@ -19,26 +21,19 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-(require 'testcover)
+;;; Commentary:
-(defvar ses-initial-global-parameters)
-(defvar ses-mode-map)
+;; FIXME: Convert to ERT and move to `test/'?
-(declare-function ses-set-curcell "ses")
-(declare-function ses-update-cells "ses")
-(declare-function ses-load "ses")
-(declare-function ses-vector-delete "ses")
-(declare-function ses-create-header-string "ses")
-(declare-function ses-read-cell "ses")
-(declare-function ses-read-symbol "ses")
-(declare-function ses-command-hook "ses")
-(declare-function ses-jump "ses")
+;;; Code:
+(require 'testcover)
+(require 'ses)
;;;Here are some macros that exercise SES. Set `pause' to t if you want the
;;;macros to pause after each step.
-(let* ((pause nil)
- (x (if pause "\^Xq" ""))
+(let* (;; (pause nil)
+ (x (if nil "\^Xq" "")) ;; pause
(y "\^X\^Fses-test.ses\r\^[<"))
;;Fiddle with the existing spreadsheet
(fset 'ses-exercise-example
@@ -652,6 +647,7 @@ spreadsheet files with invalid formatting."
(testcover-start "ses.el" t))
(require 'unsafep)) ;In case user has safe-functions = t!
+(defvar ses--curcell-overlay)
;;;#########################################################################
(defun ses-exercise ()
@@ -674,8 +670,8 @@ spreadsheet files with invalid formatting."
(ses-load))
;;ses-vector-delete is always called from buffer-undo-list with the same
;;symbol as argument. We'll give it a different one here.
- (let ((x [1 2 3]))
- (ses-vector-delete 'x 0 0))
+ (dlet ((tcover-ses--x [1 2 3]))
+ (ses-vector-delete 'tcover-ses--x 0 0))
;;ses-create-header-string behaves differently in a non-window environment
;;but we always test under windows.
(let ((window-system (not window-system)))
@@ -704,7 +700,7 @@ spreadsheet files with invalid formatting."
(ses-mode)))))
;;Test error-handling in command hook, outside a macro.
;;This will ring the bell.
- (let (curcell-overlay)
+ (let (ses--curcell-overlay)
(ses-command-hook))
;;Due to use of run-with-timer, ses-command-hook sometimes gets called
;;after we switch to another buffer.
@@ -720,4 +716,4 @@ spreadsheet files with invalid formatting."
;;Could do this here: (testcover-end "ses.el")
(message "Done"))
-;; testcover-ses.el ends here.
+;;; tcover-ses.el ends here
diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el
deleted file mode 100644
index 7a75755a529..00000000000
--- a/lisp/emacs-lisp/tcover-unsafep.el
+++ /dev/null
@@ -1,140 +0,0 @@
-;;;; testcover-unsafep.el -- Use testcover to test unsafep's code coverage
-
-;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
-
-;; Author: Jonathan Yavner <jyavner@member.fsf.org>
-;; Keywords: safety lisp utility
-;; Package: testcover
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-(require 'testcover)
-
-(defvar safe-functions)
-
-;;;These forms are all considered safe
-(defconst testcover-unsafep-safe
- '(((lambda (x) (* x 2)) 14)
- (apply 'cdr (mapcar (lambda (x) (car x)) y))
- (cond ((= x 4) 5) (t 27))
- (condition-case x (car y) (error (car x)))
- (dolist (x y) (message "here: %s" x))
- (dotimes (x 14 (* x 2)) (message "here: %d" x))
- (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x)))
- (let (x) (apply (lambda (x) (* x 2)) 14))
- (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2))
- (let ((x 1) (y 2)) (setq x (+ x y)))
- (let ((x 1)) (let ((y (+ x 3))) (* x y)))
- (let* nil (current-time))
- (let* ((x 1) (y (+ x 3))) (* x y))
- (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3))
- (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ")
- (setq buffer-display-count 14 mark-active t)
- ;;This is not safe if you insert it into a buffer!
- (propertize "x" 'display '(height (progn (delete-file "x") 1))))
- "List of forms that `unsafep' should decide are safe.")
-
-;;;These forms are considered unsafe
-(defconst testcover-unsafep-unsafe
- '(( (add-to-list x y)
- . (unquoted x))
- ( (add-to-list y x)
- . (unquoted y))
- ( (add-to-list 'y x)
- . (global-variable y))
- ( (not (delete-file "unsafep.el"))
- . (function delete-file))
- ( (cond (t (aset local-abbrev-table 0 0)))
- . (function aset))
- ( (cond (t (setq unsafep-vars "")))
- . (risky-local-variable unsafep-vars))
- ( (condition-case format-alist 1)
- . (risky-local-variable format-alist))
- ( (condition-case x 1 (error (setq format-alist "")))
- . (risky-local-variable format-alist))
- ( (dolist (x (sort globalvar 'car)) (princ x))
- . (function sort))
- ( (dotimes (x 14) (delete-file "x"))
- . (function delete-file))
- ( (let ((post-command-hook "/tmp/")) 1)
- . (risky-local-variable post-command-hook))
- ( (let ((x (delete-file "x"))) 2)
- . (function delete-file))
- ( (let (x) (add-to-list 'x (delete-file "x")))
- . (function delete-file))
- ( (let (x) (condition-case y (setq x 1 z 2)))
- . (global-variable z))
- ( (let (x) (condition-case z 1 (error (delete-file "x"))))
- . (function delete-file))
- ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4))))
- . (function setcar))
- ( (let (y) (push (delete-file "x") y))
- . (function delete-file))
- ( (let* ((x 1)) (setq y 14))
- . (global-variable y))
- ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el")))
- . (function kill-buffer))
- ( (mapcar x y)
- . (unquoted x))
- ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el"))
- . (function rename-file))
- ( (mapconcat x1 x2 " ")
- . (unquoted x1))
- ( (pop format-alist)
- . (risky-local-variable format-alist))
- ( (push 1 format-alist)
- . (risky-local-variable format-alist))
- ( (setq buffer-display-count (delete-file "x"))
- . (function delete-file))
- ;;These are actually safe (they signal errors)
- ( (apply '(x) '(1 2 3))
- . (function (x)))
- ( (let (((x))) 1)
- . (variable (x)))
- ( (let (1) 2)
- . (variable 1))
- )
- "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.")
-
-(declare-function unsafep-function "unsafep" (fun))
-
-;;;#########################################################################
-(defun testcover-unsafep ()
- "Executes all unsafep tests and displays the coverage results."
- (interactive)
- (testcover-unmark-all "unsafep.el")
- (testcover-start "unsafep.el")
- (let (save-functions)
- (dolist (x testcover-unsafep-safe)
- (if (unsafep x)
- (error "%S should be safe" x)))
- (dolist (x testcover-unsafep-unsafe)
- (if (not (equal (unsafep (car x)) (cdr x)))
- (error "%S should be unsafe: %s" (car x) (cdr x))))
- (setq safe-functions t)
- (if (or (unsafep '(delete-file "x"))
- (unsafep-function 'delete-file))
- (error "safe-functions=t should allow delete-file"))
- (setq safe-functions '(setcar))
- (if (unsafep '(setcar x 1))
- (error "safe-functions=(setcar) should allow setcar"))
- (if (not (unsafep '(setcdr x 1)))
- (error "safe-functions=(setcar) should not allow setcdr")))
- (testcover-mark-all "unsafep.el")
- (testcover-end "unsafep.el")
- (message "Done"))
-
-;; testcover-unsafep.el ends here.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 312e38769c5..e75f15140aa 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -1,4 +1,4 @@
-;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*-
+;;; testcover.el --- Visual code-coverage tool -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -258,10 +258,10 @@ vector. Return VALUE."
(aset testcover-vector after-index (testcover--copy-object value)))
((eq 'maybe old-result)
(aset testcover-vector after-index 'edebug-ok-coverage))
- ((eq '1value old-result)
+ ((eq 'testcover-1value old-result)
(aset testcover-vector after-index
(cons old-result (testcover--copy-object value))))
- ((and (eq (car-safe old-result) '1value)
+ ((and (eq (car-safe old-result) 'testcover-1value)
(not (condition-case ()
(equal (cdr old-result) value)
(circular-list t))))
@@ -358,11 +358,11 @@ eliminated by adding more test cases."
data (aref coverage len))
(when (and (not (eq data 'edebug-ok-coverage))
(not (memq (car-safe data)
- '(1value maybe noreturn)))
+ '(testcover-1value maybe noreturn)))
(setq j (+ def-mark (aref points len))))
(setq ov (make-overlay (1- j) j))
(overlay-put ov 'face
- (if (memq data '(edebug-unknown maybe 1value))
+ (if (memq data '(edebug-unknown maybe testcover-1value))
'testcover-nohits
'testcover-1value))))
(set-buffer-modified-p changed))))
@@ -450,12 +450,12 @@ or return multiple values."
(`(defconst ,sym . ,args)
(push sym testcover-module-constants)
(testcover-analyze-coverage-progn args)
- '1value)
+ 'testcover-1value)
(`(defun ,name ,_ . ,doc-and-body)
(let ((val (testcover-analyze-coverage-progn doc-and-body)))
(cl-case val
- ((1value) (push name testcover-module-1value-functions))
+ ((testcover-1value) (push name testcover-module-1value-functions))
((maybe) (push name testcover-module-potentially-1value-functions)))
nil))
@@ -466,13 +466,13 @@ or return multiple values."
;; To avoid infinite recursion, don't examine quoted objects.
;; This will cause the coverage marks on an instrumented quoted
;; form to look odd. See bug#25316.
- '1value)
+ 'testcover-1value)
(`(\` ,bq-form)
(testcover-analyze-coverage-backquote-form bq-form))
((or 't 'nil (pred keywordp))
- '1value)
+ 'testcover-1value)
((pred vectorp)
(testcover-analyze-coverage-compose (append form nil)
@@ -482,7 +482,7 @@ or return multiple values."
nil)
((pred atom)
- '1value)
+ 'testcover-1value)
(_
;; Whatever we have here, it's not wrapped, so treat it as a list of forms.
@@ -494,7 +494,7 @@ Analyze all the forms in FORMS and return 1value, maybe or nil
depending on the analysis of the last one. Find the coverage
vectors referenced by `edebug-enter' forms nested within FORMS and
update them with the results of the analysis."
- (let ((result '1value))
+ (let ((result 'testcover-1value))
(while (consp forms)
(setq result (testcover-analyze-coverage (pop forms))))
result))
@@ -518,7 +518,7 @@ form to be treated accordingly."
(setq val (testcover-analyze-coverage-wrapped-form wrapped-form))
(when (or (eq wrapper '1value) val)
;; The form is 1-valued or potentially 1-valued.
- (aset testcover-vector after-id (or val '1value)))
+ (aset testcover-vector after-id (or val 'testcover-1value)))
(cond
((or (eq wrapper 'noreturn)
@@ -526,13 +526,13 @@ form to be treated accordingly."
;; This function won't return, so indicate to testcover-before that
;; it should record coverage.
(aset testcover-vector before-id (cons 'noreturn after-id))
- (aset testcover-vector after-id '1value)
- (setq val '1value))
+ (aset testcover-vector after-id 'testcover-1value)
+ (setq val 'testcover-1value))
((eq (car-safe wrapped-form) '1value)
;; This function is always supposed to return the same value.
- (setq val '1value)
- (aset testcover-vector after-id '1value)))
+ (setq val 'testcover-1value)
+ (aset testcover-vector after-id 'testcover-1value)))
val))
(defun testcover-analyze-coverage-wrapped-form (form)
@@ -540,26 +540,26 @@ form to be treated accordingly."
FORM is treated as if it will be evaluated."
(pcase form
((pred keywordp)
- '1value)
+ 'testcover-1value)
((pred symbolp)
(when (or (memq form testcover-constants)
(memq form testcover-module-constants))
- '1value))
+ 'testcover-1value))
((pred atom)
- '1value)
+ 'testcover-1value)
(`(\` ,bq-form)
(testcover-analyze-coverage-backquote-form bq-form))
(`(defconst ,sym ,val . ,_)
(push sym testcover-module-constants)
(testcover-analyze-coverage val)
- '1value)
+ 'testcover-1value)
(`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body)
;; These always return RESULT if provided.
(testcover-analyze-coverage expr)
(testcover-analyze-coverage-progn body)
(let ((val (testcover-analyze-coverage-progn result)))
;; If the third value is not present, the loop always returns nil.
- (if result val '1value)))
+ (if result val 'testcover-1value)))
(`(,(or 'let 'let*) ,bindings . ,body)
(testcover-analyze-coverage-progn bindings)
(testcover-analyze-coverage-progn body))
@@ -604,12 +604,12 @@ FORM is treated as if it will be evaluated."
(defun testcover-analyze-coverage-wrapped-application (func args)
"Analyze the application of FUNC to ARGS for code coverage."
(cond
- ((eq func 'quote) '1value)
+ ((eq func 'quote) 'testcover-1value)
((or (memq func testcover-1value-functions)
(memq func testcover-module-1value-functions))
;; The function should always return the same value.
(testcover-analyze-coverage-progn args)
- '1value)
+ 'testcover-1value)
((or (memq func testcover-potentially-1value-functions)
(memq func testcover-module-potentially-1value-functions))
;; The function might always return the same value.
@@ -635,14 +635,14 @@ If either argument is nil, return nil, otherwise if either
argument is maybe, return maybe. Return 1value only if both arguments
are 1value."
(cl-case val
- (1value result)
+ (testcover-1value result)
(maybe (and result 'maybe))
(nil nil)))
(defun testcover-analyze-coverage-compose (forms func)
"Analyze a list of FORMS for code coverage using FUNC.
The list is 1valued if all of its constituent elements are also 1valued."
- (let ((result '1value))
+ (let ((result 'testcover-1value))
(while (consp forms)
(setq result (testcover-coverage-combine result (funcall func (car forms))))
(setq forms (cdr forms)))
@@ -652,7 +652,7 @@ The list is 1valued if all of its constituent elements are also 1valued."
(defun testcover-analyze-coverage-backquote (bq-list)
"Analyze BQ-LIST, the body of a backquoted list, for code coverage."
- (let ((result '1value))
+ (let ((result 'testcover-1value))
(while (consp bq-list)
(let ((form (car bq-list))
val)
@@ -670,9 +670,9 @@ The list is 1valued if all of its constituent elements are also 1valued."
"Analyze a single FORM from a backquoted list for code coverage."
(cond
((vectorp form) (testcover-analyze-coverage-backquote (append form nil)))
- ((atom form) '1value)
+ ((atom form) 'testcover-1value)
((memq (car form) (list '\, '\,@))
(testcover-analyze-coverage (cadr form)))
(t (testcover-analyze-coverage-backquote form))))
-;; testcover.el ends here.
+;;; testcover.el ends here
diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el
index 6b315a11066..7da02a9cb2d 100644
--- a/lisp/emacs-lisp/text-property-search.el
+++ b/lisp/emacs-lisp/text-property-search.el
@@ -31,28 +31,40 @@
(defun text-property-search-forward (property &optional value predicate
not-current)
- "Search for the next region of text whose PROPERTY matches VALUE.
-
-If not found, return nil and don't move point.
-If found, move point to end of the region and return a `prop-match'
-object describing the match. To access the details of the match,
-use `prop-match-beginning' and `prop-match-end' for the buffer
-positions that limit the region, and `prop-match-value' for the
-value of PROPERTY in the region.
-
+ "Search for the next region of text where PREDICATE is true.
PREDICATE is used to decide whether a value of PROPERTY should be
considered as matching VALUE.
-If PREDICATE is t, that means a value must `equal' VALUE to be
-considered a match.
-If PREDICATE is nil, a value will match if it is non-nil and
-is NOT `equal' to VALUE.
+
If PREDICATE is a function, it will be called with two arguments:
VALUE and the value of PROPERTY. The function should return
non-nil if these two values are to be considered a match.
+Two special values of PREDICATE can also be used:
+If PREDICATE is t, that means a value must `equal' VALUE to be
+considered a match.
+If PREDICATE is nil (which is the default value), a value will
+match if is not `equal' to VALUE. Furthermore, a nil PREDICATE
+means that the match region is ended if the value changes. For
+instance, this means that if you loop with
+
+ (while (setq prop (text-property-search-forward 'face))
+ ...)
+
+you will get all distinct regions with non-nil `face' values in
+the buffer, and the `prop' object will have the details about the
+match. See the manual for more details and examples about how
+VALUE and PREDICATE interact.
+
If NOT-CURRENT is non-nil, the function will search for the first
region that doesn't include point and has a value of PROPERTY
-that matches VALUE."
+that matches VALUE.
+
+If no matches can be found, return nil and don't move point.
+If found, move point to the end of the region and return a
+`prop-match' object describing the match. To access the details
+of the match, use `prop-match-beginning' and `prop-match-end' for
+the buffer positions that limit the region, and
+`prop-match-value' for the value of PROPERTY in the region."
(interactive
(list
(let ((string (completing-read "Search for property: " obarray)))
@@ -125,7 +137,7 @@ that matches VALUE."
"Search for the previous region of text whose PROPERTY matches VALUE.
Like `text-property-search-forward', which see, but searches backward,
-and if a matching region is found, moves point to its beginning."
+and if a matching region is found, place point at the start of the region."
(interactive
(list
(let ((string (completing-read "Search for property: " obarray)))
@@ -137,11 +149,19 @@ and if a matching region is found, moves point to its beginning."
nil)
;; We're standing in the property we're looking for, so find the
;; end.
- ((and (text-property--match-p
- value (get-text-property (1- (point)) property)
- predicate)
- (not not-current))
- (text-property--find-end-backward (1- (point)) property value predicate))
+ ((text-property--match-p
+ value (get-text-property (1- (point)) property)
+ predicate)
+ (let ((origin (point))
+ (match (text-property--find-end-backward
+ (1- (point)) property value predicate)))
+ ;; When we want to ignore the current element, then repeat the
+ ;; search if we haven't moved out of it yet.
+ (if (and not-current
+ (equal (get-text-property (point) property)
+ (get-text-property origin property)))
+ (text-property-search-backward property value predicate)
+ match)))
(t
(let ((origin (point))
(ended nil)
@@ -206,3 +226,5 @@ and if a matching region is found, moves point to its beginning."
(funcall predicate value prop-value))
(provide 'text-property-search)
+
+;;; text-property-search.el ends here
diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el
index f8b56f12a2a..7e349d22a49 100644
--- a/lisp/emacs-lisp/thunk.el
+++ b/lisp/emacs-lisp/thunk.el
@@ -52,7 +52,7 @@
(defmacro thunk-delay (&rest body)
"Delay the evaluation of BODY."
- (declare (debug t))
+ (declare (debug (def-body)))
(cl-assert lexical-binding)
`(let (forced
(val (lambda () ,@body)))
@@ -122,7 +122,7 @@ Using `thunk-let' and `thunk-let*' requires `lexical-binding'."
(declare (indent 1) (debug let))
(cl-reduce
(lambda (expr binding) `(thunk-let (,binding) ,expr))
- (nreverse bindings)
+ (reverse bindings)
:initial-value (macroexp-progn body)))
;; (defalias 'lazy-let #'thunk-let)
diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el
index 28fef48fe2e..d5bbe7d72cd 100644
--- a/lisp/emacs-lisp/timer-list.el
+++ b/lisp/emacs-lisp/timer-list.el
@@ -32,41 +32,51 @@
"List all timers in a buffer."
(interactive)
(pop-to-buffer-same-window (get-buffer-create "*timer-list*"))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (timer-list-mode)
- (dolist (timer (append timer-list timer-idle-list))
- (insert (format "%4s %10s %8s %s"
- ;; Idle.
- (if (aref timer 7) "*" " ")
- ;; Next time.
- (let ((time (list (aref timer 1)
- (aref timer 2)
- (aref timer 3))))
- (format "%.2f"
- (float-time
- (if (aref timer 7)
- time
- (time-subtract time nil)))))
- ;; Repeat.
- (let ((repeat (aref timer 4)))
- (cond
- ((numberp repeat)
- (format "%.2f" (/ repeat 60)))
- ((null repeat)
- "-")
- (t
- (format "%s" repeat))))
- ;; Function.
- (let ((cl-print-compiled 'static)
- (cl-print-compiled-button nil)
- (print-escape-newlines t))
- (cl-prin1-to-string (aref timer 5)))))
- (put-text-property (line-beginning-position)
- (1+ (line-beginning-position))
- 'timer timer)
- (insert "\n")))
- (goto-char (point-min)))
+ (timer-list-mode)
+ (tabulated-list-init-header)
+ (setq tabulated-list-entries
+ (mapcar
+ (lambda (timer)
+ (list
+ nil
+ `[ ;; Idle.
+ ,(propertize
+ (if (aref timer 7) " *" " ")
+ 'help-echo "* marks idle timers"
+ 'timer timer)
+ ;; Next time.
+ ,(propertize
+ (let ((time (list (aref timer 1)
+ (aref timer 2)
+ (aref timer 3))))
+ (format "%12s"
+ (format-seconds "%dd %hh %mm %z%,1ss"
+ (float-time
+ (if (aref timer 7)
+ time
+ (time-subtract time nil))))))
+ 'help-echo "Time until next invocation")
+ ;; Repeat.
+ ,(let ((repeat (aref timer 4)))
+ (cond
+ ((numberp repeat)
+ (propertize
+ (format "%12s" (format-seconds
+ "%dd %hh %mm %z%,1ss" repeat))
+ 'help-echo "Repeat interval"))
+ ((null repeat)
+ (propertize " -" 'help-echo "Runs once"))
+ (t
+ (format "%12s" repeat))))
+ ;; Function.
+ ,(propertize
+ (let ((cl-print-compiled 'static)
+ (cl-print-compiled-button nil)
+ (print-escape-newlines t))
+ (cl-prin1-to-string (aref timer 5)))
+ 'help-echo "Function called by timer")]))
+ (append timer-list timer-idle-list)))
+ (tabulated-list-print))
;; This command can be destructive if they don't know what they are
;; doing. Kids, don't try this at home!
;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.")
@@ -74,24 +84,47 @@
(defvar timer-list-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "c" 'timer-list-cancel)
- (define-key map "n" 'next-line)
- (define-key map "p" 'previous-line)
(easy-menu-define nil map ""
'("Timers"
["Cancel" timer-list-cancel t]))
map))
-(define-derived-mode timer-list-mode special-mode "Timer-List"
+(define-derived-mode timer-list-mode tabulated-list-mode "Timer-List"
"Mode for listing and controlling timers."
- (setq bidi-paragraph-direction 'left-to-right)
- (setq truncate-lines t)
(buffer-disable-undo)
(setq-local revert-buffer-function #'list-timers)
- (setq buffer-read-only t)
- (setq header-line-format
- (concat (propertize " " 'display '(space :align-to 0))
- (format "%4s %10s %8s %s"
- "Idle" "Next" "Repeat" "Function"))))
+ (setq tabulated-list-format
+ '[("Idle" 6 timer-list--idle-predicate)
+ ("Next" 12 timer-list--next-predicate :right-align t :pad-right 1)
+ ("Repeat" 12 timer-list--repeat-predicate :right-align t :pad-right 1)
+ ("Function" 10 timer-list--function-predicate)]))
+
+(defun timer-list--idle-predicate (A B)
+ "Predicate to sort Timer-List by the Idle column."
+ (let ((iA (aref (cadr A) 0))
+ (iB (aref (cadr B) 0)))
+ (cond ((string= iA iB)
+ (timer-list--next-predicate A B))
+ ((string= iA " *") nil)
+ (t t))))
+
+(defun timer-list--next-predicate (A B)
+ "Predicate to sort Timer-List by the Next column."
+ (let ((nA (string-to-number (aref (cadr A) 1)))
+ (nB (string-to-number (aref (cadr B) 1))))
+ (< nA nB)))
+
+(defun timer-list--repeat-predicate (A B)
+ "Predicate to sort Timer-List by the Repeat column."
+ (let ((rA (aref (cadr A) 2))
+ (rB (aref (cadr B) 2)))
+ (string< rA rB)))
+
+(defun timer-list--function-predicate (A B)
+ "Predicate to sort Timer-List by the Function column."
+ (let ((fA (aref (cadr A) 3))
+ (fB (aref (cadr B) 3)))
+ (string< fA fB)))
(defun timer-list-cancel ()
"Cancel the timer on the line under point."
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 5561c5fe834..36de29a73a8 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -378,9 +378,6 @@ This function returns a timer object which you can use in
(decoded-time-year now)
(decoded-time-zone now)))))))
- (or (time-equal-p time time)
- (error "Invalid time format"))
-
(let ((timer (timer-create)))
(timer-set-time timer time repeat)
(timer-set-function timer function args)
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 68759335df5..9354687b081 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -161,7 +161,7 @@
"Helper function to get internal values.
You can call this function to add internal values in the trace buffer."
(unless inhibit-trace
- (with-current-buffer trace-buffer
+ (with-current-buffer (get-buffer-create trace-buffer)
(goto-char (point-max))
(insert
(trace-entry-message
@@ -174,7 +174,7 @@ and CONTEXT is a string describing the dynamic context (e.g. values of
some global variables)."
(let ((print-circle t))
(format "%s%s%d -> %S%s\n"
- (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
+ (mapconcat 'char-to-string (make-string (max 0 (1- level)) ?|) " ")
(if (> level 1) " " "")
level
;; FIXME: Make it so we can click the function name to jump to its
@@ -225,7 +225,7 @@ be printed along with the arguments in the trace."
(ctx (funcall context)))
(unless inhibit-trace
(with-current-buffer trace-buffer
- (set (make-local-variable 'window-point-insertion-type) t)
+ (setq-local window-point-insertion-type t)
(unless background (trace--display-buffer trace-buffer))
(goto-char (point-max))
;; Insert a separator from previous trace output:
@@ -265,20 +265,13 @@ be printed along with the arguments in the trace."
If `current-prefix-arg' is non-nil, also read a buffer and a \"context\"
\(Lisp expression). Return (FUNCTION BUFFER FUNCTION-CONTEXT)."
(cons
- (let ((default (function-called-at-point))
- (beg (string-match ":[ \t]*\\'" prompt)))
- (intern (completing-read (if default
- (format
- "%s (default %s)%s"
- (substring prompt 0 beg)
- default
- (if beg (substring prompt beg) ": "))
- prompt)
+ (let ((default (function-called-at-point)))
+ (intern (completing-read (format-prompt prompt default)
obarray 'fboundp t nil nil
(if default (symbol-name default)))))
(when current-prefix-arg
(list
- (read-buffer "Output to buffer: " trace-buffer)
+ (read-buffer (format-prompt "Output to buffer" trace-buffer))
(let ((exp
(let ((minibuffer-completing-symbol t))
(read-from-minibuffer "Context expression: "
@@ -308,7 +301,7 @@ functions that switch buffers, or do any other display-oriented
stuff - use `trace-function-background' instead.
To stop tracing a function, use `untrace-function' or `untrace-all'."
- (interactive (trace--read-args "Trace function: "))
+ (interactive (trace--read-args "Trace function"))
(trace-function-internal function buffer nil context))
;;;###autoload
@@ -316,7 +309,7 @@ To stop tracing a function, use `untrace-function' or `untrace-all'."
"Trace calls to function FUNCTION, quietly.
This is like `trace-function-foreground', but without popping up
the output buffer or changing the window configuration."
- (interactive (trace--read-args "Trace function in background: "))
+ (interactive (trace--read-args "Trace function in background"))
(trace-function-internal function buffer t context))
;;;###autoload
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index 05013abb7dc..fa4e0583ed3 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -1,4 +1,4 @@
-;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate
+;;; unsafep.el --- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -91,29 +91,54 @@
in the parse.")
(put 'unsafep-vars 'risky-local-variable t)
-;;Other safe functions
+;; Other safe forms.
+;;
+;; A function, macro or special form may be put here only if all of
+;; the following statements are true:
+;;
+;; * It is not already marked `pure' or `side-effect-free', or handled
+;; explicitly by `unsafep'.
+;;
+;; * It is not inherently unsafe; eg, would allow the execution of
+;; arbitrary code, interact with the file system, network or other
+;; processes, or otherwise exfiltrate information from the running
+;; Emacs process or manipulate the user's environment.
+;;
+;; * It does not have side-effects that can make other code behave in
+;; unsafe and/or unexpected ways; eg, set variables, mutate data, or
+;; change control flow.
+;; Any side effect must be innocuous; altering the match data is
+;; explicitly permitted.
+;;
+;; * It does not allow Emacs to behave deceptively to the user; eg,
+;; display arbitrary messages.
+;;
+;; * It does not present a potentially large attack surface; eg,
+;; play arbitrary audio files.
+
(dolist (x '(;;Special forms
- and catch if or prog1 prog2 progn while unwind-protect
+ and if or prog1 prog2 progn while unwind-protect
;;Safe subrs that have some side-effects
- ding error random signal sleep-for string-match throw
+ ding random sleep-for string-match
;;Defsubst functions from subr.el
caar cadr cdar cddr
;;Macros from subr.el
save-match-data unless when
;;Functions from subr.el that have side effects
- split-string replace-regexp-in-string play-sound-file))
+ split-string))
(put x 'safe-function t))
;;;###autoload
-(defun unsafep (form &optional unsafep-vars)
+(defun unsafep (form &optional vars)
"Return nil if evaluating FORM couldn't possibly do any harm.
Otherwise result is a reason why FORM is unsafe.
-UNSAFEP-VARS is a list of symbols with local bindings."
+VARS is a list of symbols with local bindings like `unsafep-vars'."
(catch 'unsafep
(if (or (eq safe-functions t) ;User turned off safety-checking
(atom form)) ;Atoms are never unsafe
(throw 'unsafep nil))
- (let* ((fun (car form))
+ (let* ((unsafep-vars vars)
+ (fun (car form))
(reason (unsafep-function fun))
arg)
(cond
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index bb707e52b6d..67de690e67d 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -1,4 +1,4 @@
-;;; warnings.el --- log and display warnings
+;;; warnings.el --- log and display warnings -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -67,26 +67,27 @@ Level :debug is ignored by default (see `warning-minimum-level').")
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.")
+(make-obsolete-variable 'warning-level-aliases 'warning-levels "28.1")
-(defvaralias 'display-warning-minimum-level 'warning-minimum-level)
+(define-obsolete-variable-alias 'display-warning-minimum-level
+ 'warning-minimum-level "28.1")
(defcustom warning-minimum-level :warning
"Minimum severity level for displaying the warning buffer.
If a warning's severity level is lower than this,
the warning is logged in the warnings buffer, but the buffer
is not immediately displayed. See also `warning-minimum-log-level'."
- :group 'warnings
:type '(choice (const :emergency) (const :error)
(const :warning) (const :debug))
:version "22.1")
-(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
+(define-obsolete-variable-alias 'log-warning-minimum-level
+ 'warning-minimum-log-level "28.1")
(defcustom warning-minimum-log-level :warning
"Minimum severity level for logging a warning.
If a warning severity level is lower than this,
the warning is completely ignored.
Value must be lower or equal than `warning-minimum-level',
because warnings not logged aren't displayed either."
- :group 'warnings
:type '(choice (const :emergency) (const :error)
(const :warning) (const :debug))
:version "22.1")
@@ -100,7 +101,6 @@ Thus, (foo bar) as an element matches (foo bar)
or (foo bar ANYTHING...) as TYPE.
If TYPE is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it."
- :group 'warnings
:type '(repeat (repeat symbol))
:version "22.1")
@@ -115,7 +115,6 @@ or (foo bar ANYTHING...) as TYPE.
If TYPE is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it.
See also `warning-suppress-log-types'."
- :group 'warnings
:type '(repeat (repeat symbol))
:version "22.1")
@@ -202,6 +201,21 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress."
;; we return t.
some-match))
+(define-button-type 'warning-suppress-warning
+ 'action #'warning-suppress-action
+ 'help-echo "mouse-2, RET: Don't display this warning automatically")
+(defun warning-suppress-action (button)
+ (customize-save-variable 'warning-suppress-types
+ (cons (list (button-get button 'warning-type))
+ warning-suppress-types)))
+(define-button-type 'warning-suppress-log-warning
+ 'action #'warning-suppress-log-action
+ 'help-echo "mouse-2, RET: Don't log this warning")
+(defun warning-suppress-log-action (button)
+ (customize-save-variable 'warning-suppress-log-types
+ (cons (list (button-get button 'warning-type))
+ warning-suppress-types)))
+
;;;###autoload
(defun display-warning (type message &optional level buffer-name)
"Display a warning message, MESSAGE.
@@ -229,7 +243,12 @@ See the `warnings' custom group for user customization features.
See also `warning-series', `warning-prefix-function',
`warning-fill-prefix', and `warning-fill-column' for additional
-programming features."
+programming features.
+
+This will also display buttons allowing the user to permanently
+disable automatic display of the warning or disable the warning
+entirely by setting `warning-suppress-types' or
+`warning-suppress-log-types' on their behalf."
(if (not (or after-init-time noninteractive (daemonp)))
;; Ensure warnings that happen early in the startup sequence
;; are visible when startup completes (bug#20792).
@@ -238,8 +257,10 @@ programming features."
(setq level :warning))
(unless buffer-name
(setq buffer-name "*Warnings*"))
- (if (assq level warning-level-aliases)
- (setq level (cdr (assq level warning-level-aliases))))
+ (with-suppressed-warnings ((obsolete warning-level-aliases))
+ (when-let ((new (cdr (assq level warning-level-aliases))))
+ (warn "Warning level `%s' is obsolete; use `%s' instead" level new)
+ (setq level new)))
(or (< (warning-numeric-level level)
(warning-numeric-level warning-minimum-log-level))
(warning-suppress-p type warning-suppress-log-types)
@@ -274,6 +295,17 @@ programming features."
(insert (format (nth 1 level-info)
(format warning-type-format typename))
message)
+ ;; Don't output the buttons when doing batch compilation
+ ;; and similar.
+ (unless (or noninteractive (eq type 'bytecomp))
+ (insert " ")
+ (insert-button "Disable showing"
+ 'type 'warning-suppress-warning
+ 'warning-type type)
+ (insert " ")
+ (insert-button "Disable logging"
+ 'type 'warning-suppress-log-warning
+ 'warning-type type))
(funcall newline)
(when (and warning-fill-prefix (not (string-match "\n" message)))
(let ((fill-prefix warning-fill-prefix)
diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el
index a65ce52214b..5c436f599ef 100644
--- a/lisp/emacs-lock.el
+++ b/lisp/emacs-lock.el
@@ -176,11 +176,12 @@ Return a value appropriate for `kill-buffer-query-functions' (which see)."
arg)
((and (eq arg current-prefix-arg) (consp current-prefix-arg))
;; called with C-u M-x emacs-lock-mode, so ask the user
- (intern (completing-read "Locking mode: "
- '("all" "exit" "kill")
- nil t nil nil
- (symbol-name
- emacs-lock-default-locking-mode))))
+ (intern (completing-read
+ (format-prompt "Locking mode"
+ emacs-lock-default-locking-mode)
+ '("all" "exit" "kill")
+ nil t nil nil
+ (symbol-name emacs-lock-default-locking-mode))))
((eq mode t)
;; turn on, so use previous setting, or customized default
(or emacs-lock--old-mode emacs-lock-default-locking-mode))
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 0bd6f564cd8..54f881bde8a 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -1,4 +1,4 @@
-;;; cua-base.el --- emulate CUA key bindings
+;;; cua-base.el --- emulate CUA key bindings -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -272,19 +272,16 @@ a shifted movement key. If the value is nil, these keys are never
enabled."
:type '(choice (const :tag "Disabled" nil)
(const :tag "Shift region only" shift)
- (other :tag "Enabled" t))
- :group 'cua)
+ (other :tag "Enabled" t)))
(defcustom cua-remap-control-v t
"If non-nil, C-v binding is used for paste (yank).
Also, M-v is mapped to `delete-selection-repeat-replace-region'."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-remap-control-z t
"If non-nil, C-z binding is used for undo."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-highlight-region-shift-only nil
"If non-nil, only highlight region if marked with S-<move>.
@@ -292,8 +289,7 @@ 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
is not turned on."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(make-obsolete-variable 'cua-highlight-region-shift-only
'transient-mark-mode "24.4")
@@ -307,33 +303,28 @@ first prefix key is discarded, so typing a prefix key twice in quick
succession will also inhibit overriding the prefix key.
If the value is nil, use a shifted prefix key to inhibit the override."
:type '(choice (number :tag "Inhibit delay")
- (const :tag "No delay" nil))
- :group 'cua)
+ (const :tag "No delay" nil)))
(defcustom cua-delete-selection t
"If non-nil, typed text replaces text in the active selection."
:type '(choice (const :tag "Disabled" nil)
- (other :tag "Enabled" t))
- :group 'cua)
+ (other :tag "Enabled" t)))
(defcustom cua-keep-region-after-copy nil
"If non-nil, don't deselect the region after copying."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-toggle-set-mark t
"If non-nil, the `cua-set-mark' command toggles the mark."
:type '(choice (const :tag "Disabled" nil)
- (other :tag "Enabled" t))
- :group 'cua)
+ (other :tag "Enabled" t)))
(defcustom cua-auto-mark-last-change nil
"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."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-enable-register-prefix 'not-ctrl-u
"If non-nil, registers are supported via numeric prefix arg.
@@ -346,42 +337,36 @@ interpreted as a register number."
:type '(choice (const :tag "Disabled" nil)
(const :tag "Enabled, but C-u arg is not a register" not-ctrl-u)
(const :tag "Enabled, but only for C-u arg" ctrl-u-only)
- (other :tag "Enabled" t))
- :group 'cua)
+ (other :tag "Enabled" t)))
(defcustom cua-delete-copy-to-register-0 t
;; FIXME: Obey delete-selection-save-to-register rather than hardcoding
;; register 0.
"If non-nil, save last deleted region or rectangle to register 0."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-enable-region-auto-help nil
"If non-nil, automatically show help for active region."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-enable-modeline-indications nil
"If non-nil, use minor-mode hook to show status in mode line."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-check-pending-input t
"If non-nil, don't override prefix key if input pending.
It is rumored 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)
+ :type 'boolean)
(defcustom cua-paste-pop-rotate-temporarily nil
"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'.
-With prefix arg, \\[universal-argument] \\[yank-pop] inserts the same text as the most
-recent \\[yank-pop] (or \\[yank]) command."
- :type 'boolean
- :group 'cua)
+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'.
+With prefix arg, \\[universal-argument] \\[yank-pop] inserts the same text as the
+most recent \\[yank-pop] (or \\[yank]) command."
+ :type 'boolean)
;;; Rectangle Customization
@@ -390,8 +375,7 @@ recent \\[yank-pop] (or \\[yank]) command."
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."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-auto-tabify-rectangles 1000
"If non-nil, automatically tabify after rectangle commands.
@@ -403,11 +387,12 @@ present. The number specifies then number of characters before
and after the region marked by the rectangle to search."
:type '(choice (number :tag "Auto detect (limit)")
(const :tag "Disabled" nil)
- (other :tag "Enabled" t))
- :group 'cua)
+ (other :tag "Enabled" t)))
(defvar cua-global-keymap) ; forward
(defvar cua--region-keymap) ; forward
+(declare-function cua-clear-rectangle-mark "cua-rect" ())
+(declare-function cua-mouse-set-rectangle-mark "cua-rect" (event))
(defcustom cua-rectangle-mark-key [(control return)]
"Global key used to toggle the cua rectangle mark."
@@ -416,14 +401,13 @@ and after the region marked by the rectangle to search."
(when (and (boundp 'cua--keymaps-initialized)
cua--keymaps-initialized)
(define-key cua-global-keymap value
- 'cua-set-rectangle-mark)
+ #'cua-set-rectangle-mark)
(when (boundp 'cua--rectangle-keymap)
(define-key cua--rectangle-keymap value
- 'cua-clear-rectangle-mark)
+ #'cua-clear-rectangle-mark)
(define-key cua--region-keymap value
- 'cua-toggle-rectangle-mark))))
- :type 'key-sequence
- :group 'cua)
+ #'cua-toggle-rectangle-mark))))
+ :type 'key-sequence)
(defcustom cua-rectangle-modifier-key 'meta
"Modifier key used for rectangle commands bindings.
@@ -432,8 +416,7 @@ Must be set prior to enabling CUA."
:type '(choice (const :tag "Meta key" meta)
(const :tag "Alt key" alt)
(const :tag "Hyper key" hyper)
- (const :tag "Super key" super))
- :group 'cua)
+ (const :tag "Super key" super)))
(defcustom cua-rectangle-terminal-modifier-key 'meta
"Modifier key used for rectangle commands bindings in terminals.
@@ -442,54 +425,46 @@ Must be set prior to enabling CUA."
(const :tag "Alt key" alt)
(const :tag "Hyper key" hyper)
(const :tag "Super key" super))
- :group 'cua
:version "27.1")
(defcustom cua-enable-rectangle-auto-help t
"If non-nil, automatically show help for region, rectangle and global mark."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defface cua-rectangle
'((default :inherit region)
(((class color)) :foreground "white" :background "maroon"))
- "Font used by CUA for highlighting the rectangle."
- :group 'cua)
+ "Font used by CUA for highlighting the rectangle.")
(defface cua-rectangle-noselect
'((default :inherit region)
(((class color)) :foreground "white" :background "dimgray"))
- "Font used by CUA for highlighting the non-selected rectangle lines."
- :group 'cua)
+ "Font used by CUA for highlighting the non-selected rectangle lines.")
;;; Global Mark Customization
(defcustom cua-global-mark-keep-visible t
"If non-nil, always keep global mark visible in other window."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defface cua-global-mark
'((((min-colors 88)(class color)) :foreground "black" :background "yellow1")
(((class color)) :foreground "black" :background "yellow")
(t :weight bold))
- "Font used by CUA for highlighting the global mark."
- :group 'cua)
+ "Font used by CUA for highlighting the global mark.")
(defcustom cua-global-mark-blink-cursor-interval 0.20
"Blink cursor at this interval when global mark is active."
:type '(choice (number :tag "Blink interval")
- (const :tag "No blink" nil))
- :group 'cua)
+ (const :tag "No blink" nil)))
;;; Cursor Indication Customization
(defcustom cua-enable-cursor-indications nil
"If non-nil, use different cursor colors for indications."
- :type 'boolean
- :group 'cua)
+ :type 'boolean)
(defcustom cua-normal-cursor-color (or (and (boundp 'initial-cursor-color) initial-cursor-color)
(and (boundp 'initial-frame-alist)
@@ -507,7 +482,7 @@ If the value is a COLOR name, then only the `cursor-color' attribute will be
affected. If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
then only the `cursor-type' property will be affected. If the value is
a cons (TYPE . COLOR), then both properties are affected."
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:type '(choice
(color :tag "Color")
(choice :tag "Type"
@@ -521,8 +496,7 @@ a cons (TYPE . COLOR), then both properties are affected."
(const :tag "Vertical bar" bar)
(const :tag "Horizontal bar" hbar)
(const :tag "Hollow box" hollow))
- (color :tag "Color")))
- :group 'cua)
+ (color :tag "Color"))))
(defcustom cua-read-only-cursor-color "darkgreen"
"Cursor color used in read-only buffers, if non-nil.
@@ -545,8 +519,7 @@ a cons (TYPE . COLOR), then both properties are affected."
(const :tag "Vertical bar" bar)
(const :tag "Horizontal bar" hbar)
(const :tag "Hollow box" hollow))
- (color :tag "Color")))
- :group 'cua)
+ (color :tag "Color"))))
(defcustom cua-overwrite-cursor-color "yellow"
"Cursor color used when overwrite mode is set, if non-nil.
@@ -569,8 +542,7 @@ a cons (TYPE . COLOR), then both properties are affected."
(const :tag "Vertical bar" bar)
(const :tag "Horizontal bar" hbar)
(const :tag "Hollow box" hollow))
- (color :tag "Color")))
- :group 'cua)
+ (color :tag "Color"))))
(defcustom cua-global-mark-cursor-color "cyan"
"Indication for active global mark.
@@ -594,8 +566,7 @@ a cons (TYPE . COLOR), then both properties are affected."
(const :tag "Vertical bar" bar)
(const :tag "Horizontal bar" hbar)
(const :tag "Hollow box" hollow))
- (color :tag "Color")))
- :group 'cua)
+ (color :tag "Color"))))
;;; Rectangle support is in cua-rect.el
@@ -634,9 +605,8 @@ a cons (TYPE . COLOR), then both properties are affected."
;;; Low-level Interface
-(defvar cua-inhibit-cua-keys nil
+(defvar-local cua-inhibit-cua-keys nil
"Buffer-local variable that may disable the CUA keymappings.")
-(make-variable-buffer-local 'cua-inhibit-cua-keys)
;;; Aux. variables
@@ -644,9 +614,8 @@ a cons (TYPE . COLOR), then both properties are affected."
;; checked in post-command hook to see if point was moved
(defvar cua--buffer-and-point-before-command nil)
-;; status string for mode line indications
-(defvar cua--status-string nil)
-(make-variable-buffer-local 'cua--status-string)
+(defvar-local cua--status-string nil
+ "Status string for mode line indications.")
(defvar cua--debug nil)
@@ -712,7 +681,7 @@ a cons (TYPE . COLOR), then both properties are affected."
(<= cua-prefix-override-inhibit-delay 0)
;; In state [1], start [T] and change to state [2]
(run-with-timer cua-prefix-override-inhibit-delay nil
- 'cua--prefix-override-timeout)))
+ #'cua--prefix-override-timeout)))
;; Don't record this command
(setq this-command last-command)
;; Restore the prefix arg
@@ -860,7 +829,7 @@ With numeric prefix arg, copy to register 0-9 instead."
(defun cua-cancel ()
"Cancel the active region, rectangle, or global mark."
(interactive)
- (setq mark-active nil)
+ (deactivate-mark)
(if (fboundp 'cua--cancel-rectangle)
(cua--cancel-rectangle)))
@@ -1245,6 +1214,8 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(interactive)
(cua--shift-control-prefix ?\C-x))
+(declare-function delete-selection-repeat-replace-region "delsel" (arg))
+
(defun cua--init-keymaps ()
;; Cache actual rectangle modifier key.
(setq cua--rectangle-modifier-key
@@ -1252,68 +1223,84 @@ If ARG is the atom `-', scroll upward by nearly full screen."
cua-rectangle-terminal-modifier-key
cua-rectangle-modifier-key))
;; C-return always toggles rectangle mark
- (define-key cua-global-keymap cua-rectangle-mark-key 'cua-set-rectangle-mark)
+ (define-key cua-global-keymap cua-rectangle-mark-key #'cua-set-rectangle-mark)
(unless (eq cua--rectangle-modifier-key 'meta)
- (cua--M/H-key cua-global-keymap ?\s 'cua-set-rectangle-mark)
+ (cua--M/H-key cua-global-keymap ?\s #'cua-set-rectangle-mark)
(define-key cua-global-keymap
- (vector (list cua--rectangle-modifier-key 'mouse-1)) 'cua-mouse-set-rectangle-mark))
+ (vector (list cua--rectangle-modifier-key 'mouse-1))
+ #'cua-mouse-set-rectangle-mark))
- (define-key cua-global-keymap [(shift control ?\s)] 'cua-toggle-global-mark)
+ (define-key cua-global-keymap [(shift control ?\s)] #'cua-toggle-global-mark)
;; replace region with rectangle or element on kill ring
- (define-key cua-global-keymap [remap yank] 'cua-paste)
- (define-key cua-global-keymap [remap clipboard-yank] 'cua-paste)
- (define-key cua-global-keymap [remap x-clipboard-yank] 'cua-paste)
+ (define-key cua-global-keymap [remap yank] #'cua-paste)
+ (define-key cua-global-keymap [remap clipboard-yank] #'cua-paste)
+ (define-key cua-global-keymap [remap x-clipboard-yank] #'cua-paste)
;; replace current yank with previous kill ring element
- (define-key cua-global-keymap [remap yank-pop] 'cua-paste-pop)
+ (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)
+ (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-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)
+ (define-key cua--cua-keys-keymap [(control x) timeout] #'kill-region)
+ (define-key cua--cua-keys-keymap [(control c) timeout] #'copy-region-as-kill)
(when cua-remap-control-z
- (define-key cua--cua-keys-keymap [(control z)] 'undo))
+ (define-key cua--cua-keys-keymap [(control z)] #'undo))
(when cua-remap-control-v
- (define-key cua--cua-keys-keymap [(control v)] 'yank)
+ (define-key cua--cua-keys-keymap [(control v)] #'yank)
(define-key cua--cua-keys-keymap [(meta v)]
- 'delete-selection-repeat-replace-region))
+ #'delete-selection-repeat-replace-region))
- (define-key cua--prefix-override-keymap [(control x)] 'cua--prefix-override-handler)
- (define-key cua--prefix-override-keymap [(control c)] 'cua--prefix-override-handler)
+ (define-key cua--prefix-override-keymap [(control x)]
+ #'cua--prefix-override-handler)
+ (define-key cua--prefix-override-keymap [(control c)]
+ #'cua--prefix-override-handler)
- (define-key cua--prefix-repeat-keymap [(control x) (control x)] 'cua--prefix-repeat-handler)
- (define-key cua--prefix-repeat-keymap [(control c) (control c)] 'cua--prefix-repeat-handler)
+ (define-key cua--prefix-repeat-keymap [(control x) (control x)]
+ #'cua--prefix-repeat-handler)
+ (define-key cua--prefix-repeat-keymap [(control c) (control c)]
+ #'cua--prefix-repeat-handler)
(dolist (key '(up down left right home end next prior))
- (define-key cua--prefix-repeat-keymap (vector '(control x) key) 'cua--prefix-cut-handler)
- (define-key cua--prefix-repeat-keymap (vector '(control c) key) 'cua--prefix-copy-handler))
+ (define-key cua--prefix-repeat-keymap (vector '(control x) key)
+ #'cua--prefix-cut-handler)
+ (define-key cua--prefix-repeat-keymap (vector '(control c) key)
+ #'cua--prefix-copy-handler))
;; Enable shifted fallbacks for C-x and C-c when region is active
- (define-key cua--region-keymap [(shift control x)] 'cua--shift-control-x-prefix)
- (define-key cua--region-keymap [(shift control c)] 'cua--shift-control-c-prefix)
+ (define-key cua--region-keymap [(shift control x)]
+ #'cua--shift-control-x-prefix)
+ (define-key cua--region-keymap [(shift control c)]
+ #'cua--shift-control-c-prefix)
;; delete current region
- (define-key cua--region-keymap [remap delete-backward-char] 'cua-delete-region)
- (define-key cua--region-keymap [remap backward-delete-char] 'cua-delete-region)
- (define-key cua--region-keymap [remap backward-delete-char-untabify] 'cua-delete-region)
- (define-key cua--region-keymap [remap delete-char] 'cua-delete-region)
- (define-key cua--region-keymap [remap delete-forward-char] 'cua-delete-region)
+ (define-key cua--region-keymap [remap delete-backward-char]
+ #'cua-delete-region)
+ (define-key cua--region-keymap [remap backward-delete-char]
+ #'cua-delete-region)
+ (define-key cua--region-keymap [remap backward-delete-char-untabify]
+ #'cua-delete-region)
+ (define-key cua--region-keymap [remap delete-char]
+ #'cua-delete-region)
+ (define-key cua--region-keymap [remap delete-forward-char]
+ #'cua-delete-region)
;; kill region
- (define-key cua--region-keymap [remap kill-region] 'cua-cut-region)
- (define-key cua--region-keymap [remap clipboard-kill-region] 'cua-cut-region)
+ (define-key cua--region-keymap [remap kill-region] #'cua-cut-region)
+ (define-key cua--region-keymap [remap clipboard-kill-region] #'cua-cut-region)
;; copy region
- (define-key cua--region-keymap [remap copy-region-as-kill] 'cua-copy-region)
- (define-key cua--region-keymap [remap kill-ring-save] 'cua-copy-region)
- (define-key cua--region-keymap [remap clipboard-kill-ring-save] 'cua-copy-region)
+ (define-key cua--region-keymap [remap copy-region-as-kill] #'cua-copy-region)
+ (define-key cua--region-keymap [remap kill-ring-save] #'cua-copy-region)
+ (define-key cua--region-keymap [remap clipboard-kill-ring-save]
+ #'cua-copy-region)
;; cancel current region/rectangle
- (define-key cua--region-keymap [remap keyboard-escape-quit] 'cua-cancel)
- (define-key cua--region-keymap [remap keyboard-quit] 'cua-cancel)
+ (define-key cua--region-keymap [remap keyboard-escape-quit] #'cua-cancel)
+ (define-key cua--region-keymap [remap keyboard-quit] #'cua-cancel)
)
@@ -1346,11 +1333,9 @@ You can customize `cua-enable-cua-keys' to completely disable the
CUA bindings, or `cua-prefix-override-inhibit-delay' to change
the prefix fallback behavior."
:global t
- :group 'cua
:set-after '(cua-enable-modeline-indications
cua-remap-control-v cua-remap-control-z
cua-rectangle-mark-key cua-rectangle-modifier-key)
- :require 'cua-base
:link '(emacs-commentary-link "cua-base.el")
(setq mark-even-if-inactive t)
(setq highlight-nonselected-windows nil)
@@ -1361,15 +1346,15 @@ the prefix fallback behavior."
(if cua-mode
(progn
- (add-hook 'pre-command-hook 'cua--pre-command-handler)
- (add-hook 'post-command-hook 'cua--post-command-handler)
+ (add-hook 'pre-command-hook #'cua--pre-command-handler)
+ (add-hook 'post-command-hook #'cua--post-command-handler)
(if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist)))
(setq minor-mode-alist (cons '(cua-mode cua--status-string) minor-mode-alist)))
(if cua-enable-cursor-indications
(cua--update-indications)))
- (remove-hook 'pre-command-hook 'cua--pre-command-handler)
- (remove-hook 'post-command-hook 'cua--post-command-handler))
+ (remove-hook 'pre-command-hook #'cua--pre-command-handler)
+ (remove-hook 'post-command-hook #'cua--post-command-handler))
(if (not cua-mode)
(setq emulation-mode-map-alists
@@ -1379,9 +1364,10 @@ the prefix fallback behavior."
(cond
(cua-mode
- (setq cua--saved-state
- (list
- (and (boundp 'delete-selection-mode) delete-selection-mode)))
+ (unless cua--saved-state
+ (setq cua--saved-state
+ (list
+ (and (boundp 'delete-selection-mode) delete-selection-mode))))
(if cua-delete-selection
(delete-selection-mode 1)
(if (and (boundp 'delete-selection-mode) delete-selection-mode)
diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el
index 195bba1f317..7014330b6ef 100644
--- a/lisp/emulation/cua-gmrk.el
+++ b/lisp/emulation/cua-gmrk.el
@@ -1,4 +1,4 @@
-;;; cua-gmrk.el --- CUA unified global mark support
+;;; cua-gmrk.el --- CUA unified global mark support -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -87,9 +87,11 @@
(defun cua-toggle-global-mark (stay)
"Set or cancel the global marker.
-When the global marker is set, CUA cut and copy commands will automatically
-insert the deleted or copied text before the global marker, even when the
-global marker is in another buffer.
+When the global marker is set, CUA cut and copy commands will
+automatically insert the inserted, deleted or copied text before
+the global marker, even when the global marker is in another
+buffer.
+
If the global marker isn't set, set the global marker at point in the current
buffer. Otherwise jump to the global marker position and cancel it.
With prefix argument, don't jump to global mark when canceling it."
@@ -184,7 +186,7 @@ With prefix argument, don't jump to global mark when canceling it."
(defun cua--copy-rectangle-to-global-mark (as-text)
;; Copy rectangle to global mark buffer/position.
(if (cua--global-mark-active)
- (let ((src-buf (current-buffer))
+ (let (;; (src-buf (current-buffer))
(text (cua--extract-rectangle)))
(with-current-buffer (marker-buffer cua--global-mark-marker)
(goto-char (marker-position cua--global-mark-marker))
@@ -349,29 +351,44 @@ With prefix argument, don't jump to global mark when canceling it."
;;; Initialization
(defun cua--init-global-mark ()
- (define-key cua--global-mark-keymap [remap copy-region-as-kill] 'cua-copy-to-global-mark)
- (define-key cua--global-mark-keymap [remap kill-ring-save] 'cua-copy-to-global-mark)
- (define-key cua--global-mark-keymap [remap kill-region] 'cua-cut-to-global-mark)
- (define-key cua--global-mark-keymap [remap yank] 'cua-copy-next-to-global-mark)
-
- (define-key cua--global-mark-keymap [remap keyboard-escape-quit] 'cua-cancel-global-mark)
- (define-key cua--global-mark-keymap [remap keyboard-quit] 'cua-cancel-global-mark)
-
- (define-key cua--global-mark-keymap [(control ?d)] 'cua-cut-next-to-global-mark)
- (define-key cua--global-mark-keymap [remap delete-backward-char] 'cua-delete-backward-char-at-global-mark)
- (define-key cua--global-mark-keymap [remap backward-delete-char] 'cua-delete-backward-char-at-global-mark)
- (define-key cua--global-mark-keymap [remap backward-delete-char-untabify] 'cua-delete-backward-char-at-global-mark)
- (define-key cua--global-mark-keymap [remap self-insert-command] 'cua-insert-char-at-global-mark)
+ (define-key cua--global-mark-keymap [remap copy-region-as-kill]
+ #'cua-copy-to-global-mark)
+ (define-key cua--global-mark-keymap [remap kill-ring-save]
+ #'cua-copy-to-global-mark)
+ (define-key cua--global-mark-keymap [remap kill-region]
+ #'cua-cut-to-global-mark)
+ (define-key cua--global-mark-keymap [remap yank]
+ #'cua-copy-next-to-global-mark)
+
+ (define-key cua--global-mark-keymap [remap keyboard-escape-quit]
+ #'cua-cancel-global-mark)
+ (define-key cua--global-mark-keymap [remap keyboard-quit]
+ #'cua-cancel-global-mark)
+
+ (define-key cua--global-mark-keymap [(control ?d)]
+ #'cua-cut-next-to-global-mark)
+ (define-key cua--global-mark-keymap [remap delete-backward-char]
+ #'cua-delete-backward-char-at-global-mark)
+ (define-key cua--global-mark-keymap [remap backward-delete-char]
+ #'cua-delete-backward-char-at-global-mark)
+ (define-key cua--global-mark-keymap [remap backward-delete-char-untabify]
+ #'cua-delete-backward-char-at-global-mark)
+ (define-key cua--global-mark-keymap [remap self-insert-command]
+ #'cua-insert-char-at-global-mark)
;; Catch self-inserting characters which are "stolen" by other modes
(define-key cua--global-mark-keymap [t]
'(menu-item "sic" cua-insert-char-at-global-mark :filter cua--self-insert-char-p))
- (define-key cua--global-mark-keymap [remap newline] 'cua-insert-newline-at-global-mark)
- (define-key cua--global-mark-keymap [remap newline-and-indent] 'cua-insert-newline-at-global-mark)
- (define-key cua--global-mark-keymap "\r" 'cua-insert-newline-at-global-mark)
+ (define-key cua--global-mark-keymap [remap newline]
+ #'cua-insert-newline-at-global-mark)
+ (define-key cua--global-mark-keymap [remap newline-and-indent]
+ #'cua-insert-newline-at-global-mark)
+ (define-key cua--global-mark-keymap "\r"
+ #'cua-insert-newline-at-global-mark)
- (define-key cua--global-mark-keymap "\t" 'cua-indent-to-global-mark-column)
+ (define-key cua--global-mark-keymap "\t"
+ #'cua-indent-to-global-mark-column)
(setq cua--global-mark-initialized t))
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index c3288e2b820..0039092fd6e 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -1,4 +1,4 @@
-;;; cua-rect.el --- CUA unified rectangle support
+;;; cua-rect.el --- CUA unified rectangle support -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -37,32 +37,60 @@
(require 'rect)
-;; If non-nil, restrict current region to this rectangle.
-;; Value is a vector [top bot left right corner ins virt select].
-;; CORNER specifies currently active corner 0=t/l 1=t/r 2=b/l 3=b/r.
-;; INS specifies whether to insert on left(nil) or right(t) side.
-;; If VIRT is non-nil, virtual straight edges are enabled.
-;; If SELECT is a regexp, only lines starting with that regexp are affected.")
-(defvar cua--rectangle nil)
-(make-variable-buffer-local 'cua--rectangle)
+(defvar-local cua--rectangle nil
+ "If non-nil, restrict current region to this rectangle.
+A cua-rectangle definition is a vector used for all actions in
+`cua-rectangle-mark-mode', of the form:
-;; Most recent rectangle geometry. Note: car is buffer.
-(defvar cua--last-rectangle nil)
+ [top bot left right corner ins virt select]
-;; Rectangle restored by undo.
-(defvar cua--restored-rectangle nil)
+TOP is the upper-left corner point.
+
+BOTTOM is the point at the end of line after the lower-right
+corner point.
+
+LEFT and RIGHT are column numbers.
+
+CORNER specifies currently active corner 0=t/l 1=t/r 2=b/l 3=b/r.
+
+INS specifies whether to insert on left(nil) or right(t) side.
+
+If VIRT is non-nil, virtual straight edges are enabled.
+
+If SELECT is a regexp, only lines starting with that regexp are
+affected.")
+
+(defvar cua--last-rectangle nil
+ "Most recent rectangle geometry.
+A CONS cell, the car of which is the rectangle's buffer, and the
+cdr of which is a cua-rectangle definition.
+See `cua--rectangle'.")
+
+
+(defvar cua--restored-rectangle nil
+ "Rectangle restored by undo.")
;; Last rectangle copied/killed; nil if last kill was not a rectangle.
+;; FIXME: The above seems to be incorrect:
+;; + It seems to be the two most recent killed rectangles, and is not
+;; reset upon either a `kill-region' or `kill-line'
+;; + In the following example, the rectangle full of question marks
+;; was killed prior to the rectangle with the string "active".
+;; (#("???e\n??? \n???i\n???," 0 19
+;; (yank-handler
+;; (rectangle--insert-for-yank
+;; ("???e" "??? " "???i" "???,")
+;; t)))
+;; "active " "sert on" " straig" " lines ")
(defvar cua--last-killed-rectangle nil)
-;; List of overlays used to display current rectangle.
-(defvar cua--rectangle-overlays nil)
-(make-variable-buffer-local 'cua--rectangle-overlays)
+(defvar-local cua--rectangle-overlays nil
+ "List of overlays used to display current rectangle.")
(put 'cua--rectangle-overlays 'permanent-local t)
(defvar cua--overlay-keymap
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'cua-rotate-rectangle)))
+ (define-key map "\r" #'cua-rotate-rectangle)))
(defvar cua--virtual-edges-debug nil)
@@ -76,7 +104,7 @@
(e (cua--rect-end-position)))
(undo-boundary)
(push (list 'apply 0 s e
- 'cua--rect-undo-handler
+ #'cua--rect-undo-handler
(copy-sequence cua--rectangle) t s e)
buffer-undo-list))))
@@ -86,7 +114,7 @@
(setq cua--restored-rectangle (copy-sequence rect))
(setq cua--buffer-and-point-before-command nil))
(push (list 'apply 0 s (if on e s)
- 'cua--rect-undo-handler rect on s e)
+ #'cua--rect-undo-handler rect on s e)
buffer-undo-list))
;;;###autoload
@@ -522,7 +550,7 @@ If command is repeated at same position, delete the rectangle."
;;; Operations on current rectangle
(defun cua--tabify-start (start end)
- ;; Return position where auto-tabify should start (or nil if not required).
+ "Return position where auto-tabify should start (or nil if not required)."
(save-excursion
(save-restriction
(widen)
@@ -538,15 +566,16 @@ If command is repeated at same position, delete the rectangle."
start)))))
(defun cua--rectangle-operation (keep-clear visible undo pad tabify &optional fct post-fct)
- ;; Call FCT for each line of region with 4 parameters:
- ;; Region start, end, left-col, right-col
- ;; Point is at start when FCT is called
- ;; Call fct with (s,e) = whole lines if VISIBLE non-nil.
- ;; Only call fct for visible lines if VISIBLE==t.
- ;; Set undo boundary if UNDO is non-nil.
- ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges)
- ;; Perform auto-tabify after operation if TABIFY is non-nil.
- ;; Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear.
+ "Call FCT for each line of region with 4 parameters:
+Region start, end, left-col, right-col.
+Point is at start when FCT is called.
+Call fct with (s,e) = whole lines if VISIBLE non-nil.
+Only call fct for visible lines if VISIBLE==t.
+Set undo boundary if UNDO is non-nil.
+Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges)
+Perform auto-tabify after operation if TABIFY is non-nil.
+Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear."
+ (declare (indent 4))
(let* ((inhibit-field-text-motion t)
(start (cua--rectangle-top))
(end (cua--rectangle-bot))
@@ -617,8 +646,6 @@ If command is repeated at same position, delete the rectangle."
(cua--keep-active)))
(setq cua--buffer-and-point-before-command nil)))
-(put 'cua--rectangle-operation 'lisp-indent-function 4)
-
(defun cua--delete-rectangle ()
(let ((lines 0))
(if (not (cua--rectangle-virtual-edges))
@@ -683,9 +710,9 @@ If command is repeated at same position, delete the rectangle."
(nreverse rect)))
(defun cua--insert-rectangle (rect &optional below paste-column line-count)
- ;; Insert rectangle as insert-rectangle, but don't set mark and exit with
- ;; point at either next to top right or below bottom left corner
- ;; Notice: In overwrite mode, the rectangle is inserted as separate text lines.
+ "Insert rectangle as insert-rectangle, but don't set mark and exit with
+point at either next to top right or below bottom left corner
+Notice: In overwrite mode, the rectangle is inserted as separate text lines."
(if (eq below 'auto)
(setq below (and (bolp)
(or (eolp) (eobp) (= (1+ (point)) (point-max))))))
@@ -735,7 +762,7 @@ If command is repeated at same position, delete the rectangle."
(setq cua--last-killed-rectangle (cons (and kill-ring (car kill-ring)) killed-rectangle))
(if ring
(kill-new (mapconcat
- (function (lambda (row) (concat row "\n")))
+ (lambda (row) (concat row "\n"))
killed-rectangle "")))))
(defun cua--activate-rectangle ()
@@ -1071,7 +1098,7 @@ The text previously in the rectangle is overwritten by the blanks."
(cua--copy-rectangle-to-global-mark t))
(let* ((rect (cua--extract-rectangle))
(text (mapconcat
- (function (lambda (row) (concat row "\n")))
+ (lambda (row) (concat row "\n"))
rect "")))
(setq arg (cua--prefix-arg arg))
(if cua--register
@@ -1150,9 +1177,9 @@ The numbers are formatted according to the FORMAT string."
(list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
(string-to-number
- (read-string "Start value: (0) " nil nil "0")))
+ (read-string (format-prompt "Start value" 0) nil nil "0")))
(string-to-number
- (read-string "Increment: (1) " nil nil "1"))
+ (read-string (format-prompt "Increment" 1) nil nil "1"))
(read-string (concat "Format: (" cua--rectangle-seq-format ") "))))
(if (= (length format) 0)
(setq format cua--rectangle-seq-format)
@@ -1192,6 +1219,7 @@ The numbers are formatted according to the FORMAT string."
;;; Replace/rearrange text in current rectangle
(defun cua--rectangle-aux-replace (width adjust keep replace pad format-fct &optional setup-fct)
+ (declare (indent 4))
;; Process text inserted by calling SETUP-FCT or current rectangle if nil.
;; Then call FORMAT-FCT on text (if non-nil); takes two args: start and end.
;; Fill to WIDTH characters if > 0 or fill to current width if == 0.
@@ -1251,8 +1279,6 @@ The numbers are formatted according to the FORMAT string."
(if keep
(cua--rectangle-resized)))))
-(put 'cua--rectangle-aux-replace 'lisp-indent-function 4)
-
(defun cua--left-fill-rectangle (_start _end)
(beginning-of-line)
(while (< (point) (point-max))
@@ -1457,79 +1483,79 @@ With prefix arg, indent to that column."
(cua--M/H-key cua--rectangle-keymap key cmd))
(defun cua--init-rectangles ()
- (define-key cua--rectangle-keymap cua-rectangle-mark-key 'cua-clear-rectangle-mark)
- (define-key cua--region-keymap cua-rectangle-mark-key 'cua-toggle-rectangle-mark)
+ (define-key cua--rectangle-keymap cua-rectangle-mark-key #'cua-clear-rectangle-mark)
+ (define-key cua--region-keymap cua-rectangle-mark-key #'cua-toggle-rectangle-mark)
(unless (eq cua--rectangle-modifier-key 'meta)
- (cua--rect-M/H-key ?\s 'cua-clear-rectangle-mark)
- (cua--M/H-key cua--region-keymap ?\s 'cua-toggle-rectangle-mark))
-
- (define-key cua--rectangle-keymap [remap set-mark-command] 'cua-toggle-rectangle-mark)
-
- (define-key cua--rectangle-keymap [remap forward-char] 'cua-resize-rectangle-right)
- (define-key cua--rectangle-keymap [remap right-char] 'cua-resize-rectangle-right)
- (define-key cua--rectangle-keymap [remap backward-char] 'cua-resize-rectangle-left)
- (define-key cua--rectangle-keymap [remap left-char] 'cua-resize-rectangle-left)
- (define-key cua--rectangle-keymap [remap next-line] 'cua-resize-rectangle-down)
- (define-key cua--rectangle-keymap [remap previous-line] 'cua-resize-rectangle-up)
- (define-key cua--rectangle-keymap [remap end-of-line] 'cua-resize-rectangle-eol)
- (define-key cua--rectangle-keymap [remap beginning-of-line] 'cua-resize-rectangle-bol)
- (define-key cua--rectangle-keymap [remap end-of-buffer] 'cua-resize-rectangle-bot)
- (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)
- (define-key cua--rectangle-keymap [remap backward-delete-char-untabify] 'cua-delete-char-rectangle)
- (define-key cua--rectangle-keymap [remap self-insert-command] 'cua-insert-char-rectangle)
+ (cua--rect-M/H-key ?\s #'cua-clear-rectangle-mark)
+ (cua--M/H-key cua--region-keymap ?\s #'cua-toggle-rectangle-mark))
+
+ (define-key cua--rectangle-keymap [remap set-mark-command] #'cua-toggle-rectangle-mark)
+
+ (define-key cua--rectangle-keymap [remap forward-char] #'cua-resize-rectangle-right)
+ (define-key cua--rectangle-keymap [remap right-char] #'cua-resize-rectangle-right)
+ (define-key cua--rectangle-keymap [remap backward-char] #'cua-resize-rectangle-left)
+ (define-key cua--rectangle-keymap [remap left-char] #'cua-resize-rectangle-left)
+ (define-key cua--rectangle-keymap [remap next-line] #'cua-resize-rectangle-down)
+ (define-key cua--rectangle-keymap [remap previous-line] #'cua-resize-rectangle-up)
+ (define-key cua--rectangle-keymap [remap end-of-line] #'cua-resize-rectangle-eol)
+ (define-key cua--rectangle-keymap [remap beginning-of-line] #'cua-resize-rectangle-bol)
+ (define-key cua--rectangle-keymap [remap end-of-buffer] #'cua-resize-rectangle-bot)
+ (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)
+ (define-key cua--rectangle-keymap [remap backward-delete-char-untabify] #'cua-delete-char-rectangle)
+ (define-key cua--rectangle-keymap [remap self-insert-command] #'cua-insert-char-rectangle)
;; Catch self-inserting characters which are "stolen" by other modes
(define-key cua--rectangle-keymap [t]
'(menu-item "sic" cua-insert-char-rectangle :filter cua--self-insert-char-p))
- (define-key cua--rectangle-keymap "\r" 'cua-rotate-rectangle)
- (define-key cua--rectangle-keymap "\t" 'cua-indent-rectangle)
-
- (define-key cua--rectangle-keymap [(control ??)] 'cua-help-for-rectangle)
-
- (define-key cua--rectangle-keymap [mouse-1] 'cua-mouse-set-rectangle-mark)
- (define-key cua--rectangle-keymap [down-mouse-1] 'cua--mouse-ignore)
- (define-key cua--rectangle-keymap [drag-mouse-1] 'cua--mouse-ignore)
- (define-key cua--rectangle-keymap [mouse-3] 'cua-mouse-save-then-kill-rectangle)
- (define-key cua--rectangle-keymap [down-mouse-3] 'cua--mouse-ignore)
- (define-key cua--rectangle-keymap [drag-mouse-3] 'cua--mouse-ignore)
-
- (cua--rect-M/H-key 'up 'cua-move-rectangle-up)
- (cua--rect-M/H-key 'down 'cua-move-rectangle-down)
- (cua--rect-M/H-key 'left 'cua-move-rectangle-left)
- (cua--rect-M/H-key 'right 'cua-move-rectangle-right)
-
- (cua--rect-M/H-key '(control up) 'cua-scroll-rectangle-up)
- (cua--rect-M/H-key '(control down) 'cua-scroll-rectangle-down)
-
- (cua--rect-M/H-key ?a 'cua-align-rectangle)
- (cua--rect-M/H-key ?b 'cua-blank-rectangle)
- (cua--rect-M/H-key ?c 'cua-close-rectangle)
- (cua--rect-M/H-key ?f 'cua-fill-char-rectangle)
- (cua--rect-M/H-key ?i 'cua-incr-rectangle)
- (cua--rect-M/H-key ?k 'cua-cut-rectangle-as-text)
- (cua--rect-M/H-key ?l 'cua-downcase-rectangle)
- (cua--rect-M/H-key ?m 'cua-copy-rectangle-as-text)
- (cua--rect-M/H-key ?n 'cua-sequence-rectangle)
- (cua--rect-M/H-key ?o 'cua-open-rectangle)
- (cua--rect-M/H-key ?p 'cua-toggle-rectangle-virtual-edges)
- (cua--rect-M/H-key ?P 'cua-do-rectangle-padding)
- (cua--rect-M/H-key ?q 'cua-refill-rectangle)
- (cua--rect-M/H-key ?r 'cua-replace-in-rectangle)
- (cua--rect-M/H-key ?R 'cua-reverse-rectangle)
- (cua--rect-M/H-key ?s 'cua-string-rectangle)
- (cua--rect-M/H-key ?t 'cua-text-fill-rectangle)
- (cua--rect-M/H-key ?u 'cua-upcase-rectangle)
- (cua--rect-M/H-key ?| 'cua-shell-command-on-rectangle)
- (cua--rect-M/H-key ?' 'cua-restrict-prefix-rectangle)
- (cua--rect-M/H-key ?/ 'cua-restrict-regexp-rectangle)
+ (define-key cua--rectangle-keymap "\r" #'cua-rotate-rectangle)
+ (define-key cua--rectangle-keymap "\t" #'cua-indent-rectangle)
+
+ (define-key cua--rectangle-keymap [(control ??)] #'cua-help-for-rectangle)
+
+ (define-key cua--rectangle-keymap [mouse-1] #'cua-mouse-set-rectangle-mark)
+ (define-key cua--rectangle-keymap [down-mouse-1] #'cua--mouse-ignore)
+ (define-key cua--rectangle-keymap [drag-mouse-1] #'cua--mouse-ignore)
+ (define-key cua--rectangle-keymap [mouse-3] #'cua-mouse-save-then-kill-rectangle)
+ (define-key cua--rectangle-keymap [down-mouse-3] #'cua--mouse-ignore)
+ (define-key cua--rectangle-keymap [drag-mouse-3] #'cua--mouse-ignore)
+
+ (cua--rect-M/H-key 'up #'cua-move-rectangle-up)
+ (cua--rect-M/H-key 'down #'cua-move-rectangle-down)
+ (cua--rect-M/H-key 'left #'cua-move-rectangle-left)
+ (cua--rect-M/H-key 'right #'cua-move-rectangle-right)
+
+ (cua--rect-M/H-key '(control up) #'cua-scroll-rectangle-up)
+ (cua--rect-M/H-key '(control down) #'cua-scroll-rectangle-down)
+
+ (cua--rect-M/H-key ?a #'cua-align-rectangle)
+ (cua--rect-M/H-key ?b #'cua-blank-rectangle)
+ (cua--rect-M/H-key ?c #'cua-close-rectangle)
+ (cua--rect-M/H-key ?f #'cua-fill-char-rectangle)
+ (cua--rect-M/H-key ?i #'cua-incr-rectangle)
+ (cua--rect-M/H-key ?k #'cua-cut-rectangle-as-text)
+ (cua--rect-M/H-key ?l #'cua-downcase-rectangle)
+ (cua--rect-M/H-key ?m #'cua-copy-rectangle-as-text)
+ (cua--rect-M/H-key ?n #'cua-sequence-rectangle)
+ (cua--rect-M/H-key ?o #'cua-open-rectangle)
+ (cua--rect-M/H-key ?p #'cua-toggle-rectangle-virtual-edges)
+ (cua--rect-M/H-key ?P #'cua-do-rectangle-padding)
+ (cua--rect-M/H-key ?q #'cua-refill-rectangle)
+ (cua--rect-M/H-key ?r #'cua-replace-in-rectangle)
+ (cua--rect-M/H-key ?R #'cua-reverse-rectangle)
+ (cua--rect-M/H-key ?s #'cua-string-rectangle)
+ (cua--rect-M/H-key ?t #'cua-text-fill-rectangle)
+ (cua--rect-M/H-key ?u #'cua-upcase-rectangle)
+ (cua--rect-M/H-key ?| #'cua-shell-command-on-rectangle)
+ (cua--rect-M/H-key ?' #'cua-restrict-prefix-rectangle)
+ (cua--rect-M/H-key ?/ #'cua-restrict-regexp-rectangle)
(setq cua--rectangle-initialized t))
diff --git a/lisp/emulation/edt-lk201.el b/lisp/emulation/edt-lk201.el
index 4fc9f966bc9..b616fdf4298 100644
--- a/lisp/emulation/edt-lk201.el
+++ b/lisp/emulation/edt-lk201.el
@@ -1,4 +1,4 @@
-;;; edt-lk201.el --- enhanced EDT keypad mode emulation for LK-201 keyboards
+;;; edt-lk201.el --- enhanced EDT keypad mode emulation for LK-201 keyboards -*- lexical-binding: t -*-
;; Copyright (C) 1986, 1992-1993, 1995, 2001-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index 452e9b0f9f9..a723dbdbb90 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -1,4 +1,4 @@
-;;; edt-mapper.el --- create an EDT LK-201 map file for X-Windows Emacs
+;;; edt-mapper.el --- create an EDT LK-201 map file for X-Windows Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2000-2021 Free Software Foundation, Inc.
@@ -26,7 +26,7 @@
;; [Part of the GNU Emacs EDT Emulation.]
-;; This emacs lisp program can be used to create an emacs lisp file
+;; This Emacs Lisp program can be used to create an Emacs Lisp file
;; that defines the mapping of the user's keyboard to the LK-201
;; keyboard function keys and keypad keys (around which EDT has been
;; designed). Please read the "Usage" AND "Known Problems" sections
@@ -101,6 +101,8 @@
(define-obsolete-variable-alias 'edt-window-system 'window-system "27.1")
(defconst edt-xserver (when (eq window-system 'x)
+ (declare-function x-server-vendor "xfns.c"
+ (&optional terminal))
;; The Cygwin window manager has a `/' in its
;; name, which breaks the generated file name of
;; the custom key map file. Replace `/' with a
@@ -176,7 +178,7 @@
(mapc
(lambda (function-key)
(if (not (lookup-key (current-global-map) function-key))
- (define-key (current-global-map) function-key 'forward-char)))
+ (define-key (current-global-map) function-key #'forward-char)))
'([kp-0] [kp-1] [kp-2] [kp-3] [kp-4]
[kp-5] [kp-6] [kp-7] [kp-8] [kp-9]
[kp-space]
@@ -510,7 +512,8 @@
(if window-system (concat "-" (upcase (symbol-name window-system))))
"-keys")))
(set-visited-file-name
- (read-file-name (format "Save key mapping to file (default %s): " file) nil file)))
+ (read-file-name (format-prompt "Save key mapping to file" file)
+ nil file)))
(save-buffer)
(message "That's it! Press any key to exit")
diff --git a/lisp/emulation/edt-pc.el b/lisp/emulation/edt-pc.el
index 94125806f87..3131c8f873e 100644
--- a/lisp/emulation/edt-pc.el
+++ b/lisp/emulation/edt-pc.el
@@ -1,4 +1,4 @@
-;;; edt-pc.el --- enhanced EDT keypad mode emulation for PC 101 keyboards
+;;; edt-pc.el --- enhanced EDT keypad mode emulation for PC 101 keyboards -*- lexical-binding: t -*-
;; Copyright (C) 1986, 1994-1995, 2001-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/emulation/edt-vt100.el b/lisp/emulation/edt-vt100.el
index 75e80f3b23c..8174d83eaa1 100644
--- a/lisp/emulation/edt-vt100.el
+++ b/lisp/emulation/edt-vt100.el
@@ -1,4 +1,4 @@
-;;; edt-vt100.el --- enhanced EDT keypad mode emulation for VT series terminals
+;;; edt-vt100.el --- enhanced EDT keypad mode emulation for VT series terminals -*- lexical-binding: t -*-
;; Copyright (C) 1986, 1992-1993, 1995, 2002-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 9bd7a0276c4..f11afb1d02d 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -1,4 +1,4 @@
-;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs
+;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986, 1992-1995, 2000-2021 Free Software Foundation,
;; Inc.
@@ -179,11 +179,6 @@
(defvar rect-start-point)
;;;
-;;; Version Information
-;;;
-(defconst edt-version "4.0" "EDT Emulation version number.")
-
-;;;
;;; User Configurable Variables
;;;
@@ -194,8 +189,7 @@ Emulation. If set to nil (the default), the `page-delimiter' variable
is set to \"\\f\" when edt-emulation-on is first invoked. This
setting replicates EDT's page delimiter behavior. The original value
is restored when edt-emulation-off is called."
- :type 'boolean
- :group 'edt)
+ :type 'boolean)
(defcustom edt-use-EDT-control-key-bindings nil
"Emacs MUST be restarted for a change in value to take effect!
@@ -203,8 +197,7 @@ 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
use within the EDT emulation."
- :type 'boolean
- :group 'edt)
+ :type 'boolean)
(defcustom edt-word-entities '(?\t)
"Specifies the list of EDT word entity characters.
@@ -228,22 +221,19 @@ representations, which you can also use:
In EDT Emulation movement-by-word commands, each character in the list
will be treated as if it were a separate word."
- :type '(repeat integer)
- :group 'edt)
+ :type '(repeat integer))
(defcustom edt-top-scroll-margin 10
"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)
+ :type 'integer)
(defcustom edt-bottom-scroll-margin 15
"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
- :group 'edt)
+ :type 'integer)
;;;
;;; Internal Variables
@@ -306,6 +296,8 @@ This means that an edt-user.el file was found in the user's `load-path'.")
;;; o edt-emulation-on o edt-load-keys
;;;
(defconst edt-xserver (when (eq window-system 'x)
+ (declare-function x-server-vendor "xfns.c"
+ (&optional terminal))
;; The Cygwin window manager has a `/' in its
;; name, which breaks the generated file name of
;; the custom key map file. Replace `/' with a
@@ -325,31 +317,31 @@ This means that an edt-user.el file was found in the user's `load-path'.")
;;;; EDT Emulation Commands
;;;;
-;;; Almost all of EDT's keypad mode commands have equivalent Emacs
-;;; function counterparts. But many of these counterparts behave
-;;; somewhat differently in Emacs.
-;;;
-;;; So, the following Emacs functions emulate, where practical, the
-;;; exact behavior of the corresponding EDT keypad mode commands. In
-;;; a few cases, the emulation is not exact, but it should be close
-;;; enough for most EDT die-hards.
-;;;
+;; Almost all of EDT's keypad mode commands have equivalent Emacs
+;; function counterparts. But many of these counterparts behave
+;; somewhat differently in Emacs.
+;;
+;; So, the following Emacs functions emulate, where practical, the
+;; exact behavior of the corresponding EDT keypad mode commands. In
+;; a few cases, the emulation is not exact, but it should be close
+;; enough for most EDT die-hards.
+;;
;;;
;;; PAGE
;;;
-;;; Emacs uses the regexp assigned to page-delimiter to determine what
-;;; marks a page break. This is normally "^\f", which causes the
-;;; edt-page command to ignore form feeds not located at the beginning
-;;; of a line. To emulate the EDT PAGE command exactly,
-;;; page-delimiter is set to "\f" when EDT emulation is turned on, and
-;;; restored to its original value when EDT emulation is turned off.
-;;; But this can be overridden if the EDT definition is not desired by
-;;; placing
-;;;
-;;; (setq edt-keep-current-page-delimiter t)
-;;;
-;;; in your init file.
+;; Emacs uses the regexp assigned to page-delimiter to determine what
+;; marks a page break. This is normally "^\f", which causes the
+;; edt-page command to ignore form feeds not located at the beginning
+;; of a line. To emulate the EDT PAGE command exactly,
+;; page-delimiter is set to "\f" when EDT emulation is turned on, and
+;; restored to its original value when EDT emulation is turned off.
+;; But this can be overridden if the EDT definition is not desired by
+;; placing
+;;
+;; (setq edt-keep-current-page-delimiter t)
+;;
+;; in your init file.
(defun edt-page-forward (num)
"Move forward to just after next page delimiter.
@@ -386,12 +378,12 @@ Argument NUM is the number of page delimiters to move."
;;;
;;; SECT
;;;
-;;; EDT defaults a section size to be 16 lines of its one and only
-;;; 24-line window. That's two-thirds of the window at a time. The
-;;; EDT SECT commands moves the cursor, not the window.
-;;;
-;;; This emulation of EDT's SECT moves the cursor approximately
-;;; two-thirds of the current window at a time.
+;; EDT defaults a section size to be 16 lines of its one and only
+;; 24-line window. That's two-thirds of the window at a time. The
+;; EDT SECT commands moves the cursor, not the window.
+;;
+;; This emulation of EDT's SECT moves the cursor approximately
+;; two-thirds of the current window at a time.
(defun edt-sect-forward (num)
"Move cursor forward two-thirds of a window's number of lines.
@@ -419,8 +411,8 @@ Argument NUM is the number of sections to move."
;;;
;;; BEGINNING OF LINE
;;;
-;;; EDT's beginning-of-line command is not affected by current
-;;; direction, for some unknown reason.
+;; EDT's beginning-of-line command is not affected by current
+;; direction, for some unknown reason.
(defun edt-beginning-of-line (num)
"Move backward to next beginning of line mark.
@@ -472,13 +464,13 @@ Argument NUM is the number of EOL marks to move."
;;;
;;; WORD
;;;
-;;; This one is a tad messy. To emulate EDT's behavior everywhere in
-;;; the file (beginning of file, end of file, beginning of line, end
-;;; of line, etc.) it takes a bit of special handling.
-;;;
-;;; The variable edt-word-entities contains a list of characters which
-;;; are to be viewed as distinct words wherever they appear in the
-;;; buffer. This emulates the EDT line mode command SET ENTITY WORD.
+;; This one is a tad messy. To emulate EDT's behavior everywhere in
+;; the file (beginning of file, end of file, beginning of line, end
+;; of line, etc.) it takes a bit of special handling.
+;;
+;; The variable edt-word-entities contains a list of characters which
+;; are to be viewed as distinct words wherever they appear in the
+;; buffer. This emulates the EDT line mode command SET ENTITY WORD.
(defun edt-one-word-forward ()
@@ -569,9 +561,9 @@ Argument NUM is the number of characters to move."
;;;
;;; LINE
;;;
-;;; When direction is set to BACKUP, LINE behaves just like BEGINNING
-;;; OF LINE in EDT. So edt-line-backward is not really needed as a
-;;; separate function.
+;; When direction is set to BACKUP, LINE behaves just like BEGINNING
+;; OF LINE in EDT. So edt-line-backward is not really needed as a
+;; separate function.
(defun edt-line-backward (num)
"Move backward to next beginning of line mark.
@@ -642,8 +634,7 @@ Argument NUM is the number of lines to move."
(defmacro edt-with-position (&rest body)
"Execute BODY with some position-related variables bound."
- `(let* ((left nil)
- (beg (edt-current-line))
+ `(let* ((beg (edt-current-line))
(height (window-height))
(top-percent
(if (zerop edt-top-scroll-margin) 10 edt-top-scroll-margin))
@@ -657,6 +648,7 @@ Argument NUM is the number of lines to move."
(far (save-excursion
(goto-char bottom)
(point-at-bol (1- height)))))
+ (ignore top far)
,@body))
;;;
@@ -674,9 +666,10 @@ Optional argument FIND is t is this function is called from `edt-find'."
(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)))
+ (let ((left (save-excursion (forward-line height))))
+ (recenter (if (zerop left)
+ top-margin
+ (- left bottom-up-margin))))
(and (> (point) bottom) (recenter bottom-margin))))))
(defun edt-find-backward (&optional find)
@@ -693,7 +686,7 @@ Optional argument FIND is t if this function is called from `edt-find'."
(defun edt-find ()
"Find first occurrence of string in current direction and save it."
(interactive)
- (set 'edt-find-last-text (read-string "Search: "))
+ (setq edt-find-last-text (read-string "Search: "))
(if (equal edt-direction-string edt-forward-string)
(edt-find-forward t)
(edt-find-backward t)))
@@ -713,9 +706,9 @@ Optional argument FIND is t if this function is called from `edt-find'."
(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)))
+ (let ((left (save-excursion (forward-line height))))
+ (recenter (if (zerop left) top-margin
+ (- left bottom-up-margin))))
(and (> (point) bottom) (recenter bottom-margin))))
(backward-char 1)
(error "Search failed: \"%s\"" edt-find-last-text))))
@@ -790,7 +783,7 @@ Argument NUM is the number of lines to delete."
In select mode, selected text is highlighted."
(if arg
(progn
- (set (make-local-variable 'edt-select-mode) 'edt-select-mode-current)
+ (setq-local edt-select-mode 'edt-select-mode-current)
(setq rect-start-point (window-point)))
(progn
(kill-local-variable 'edt-select-mode)))
@@ -1205,9 +1198,9 @@ Argument BOTTOM is the bottom margin in number of lines or percent of window."
;;;;
;;;
-;;; Several enhancements and additions to EDT keypad mode commands are
-;;; provided here. Some of these have been motivated by similar
-;;; TPU/EVE and EVE-Plus commands. Others are new.
+;; Several enhancements and additions to EDT keypad mode commands are
+;; provided here. Some of these have been motivated by similar
+;; TPU/EVE and EVE-Plus commands. Others are new.
;;;
;;; CHANGE DIRECTION
@@ -1247,9 +1240,8 @@ Argument NUM is the positive number of sentences to move."
(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)))
+ (let ((left (save-excursion (forward-line height))))
+ (recenter (if (zerop left) top-margin (- left bottom-up-margin))))
(and (> (point) bottom) (recenter bottom-margin)))))
(defun edt-sentence-backward (num)
@@ -1288,9 +1280,8 @@ Argument NUM is the positive number of paragraphs to move."
(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)))
+ (let ((left (save-excursion (forward-line height))))
+ (recenter (if (zerop left) top-margin (- left bottom-up-margin))))
(and (> (point) bottom) (recenter bottom-margin)))))
(defun edt-paragraph-backward (num)
@@ -1323,8 +1314,8 @@ Definition is stored in `edt-last-replaced-key-definition'."
(if edt-last-replaced-key-definition
(progn
(let (edt-key-definition)
- (set 'edt-key-definition
- (read-key-sequence "Press the key to be restored: "))
+ (setq edt-key-definition
+ (read-key-sequence "Press the key to be restored: "))
(if (string-equal "\C-m" edt-key-definition)
(message "Key not restored")
(progn
@@ -1380,8 +1371,8 @@ Definition is stored in `edt-last-replaced-key-definition'."
;;;
;;; SCROLL WINDOW
;;;
-;;; Scroll a window (less one line) at a time. Leave cursor in center of
-;;; window.
+;; Scroll a window (less one line) at a time. Leave cursor in center of
+;; window.
(defun edt-scroll-window-forward (num)
"Scroll forward one window in buffer, less one line.
@@ -1641,12 +1632,12 @@ Argument NUM is the number of times to duplicate the line."
(progn
(end-kbd-macro nil)
(let (edt-key-definition)
- (set 'edt-key-definition
- (read-key-sequence "Enter key for binding: "))
+ (setq edt-key-definition
+ (read-key-sequence "Enter key for binding: "))
(if (string-equal "\C-m" edt-key-definition)
(message "Key sequence not remembered")
(progn
- (set 'edt-learn-macro-count (+ edt-learn-macro-count 1))
+ (setq edt-learn-macro-count (+ edt-learn-macro-count 1))
(setq edt-last-replaced-key-definition
(lookup-key (current-global-map)
edt-key-definition))
@@ -2053,7 +2044,7 @@ Optional argument USER-SETUP non-nil means called from function
(fset 'edt-emulation-on (symbol-function 'edt-select-default-global-map))
(edt-select-default-global-map)))
;; Keep the menu bar Buffers menu up-to-date in edt-default-global-map.
- (add-hook 'menu-bar-update-hook 'edt-default-menu-bar-update-buffers))
+ (add-hook 'menu-bar-update-hook #'edt-default-menu-bar-update-buffers))
(defun edt-user-emulation-setup ()
"Setup user custom emulation of DEC's EDT editor."
@@ -2074,7 +2065,7 @@ Optional argument USER-SETUP non-nil means called from function
(edt-setup-user-bindings))
(edt-select-user-global-map)
;; Keep the menu bar Buffers menu up-to-date in edt-user-global-map.
- (add-hook 'menu-bar-update-hook 'edt-user-menu-bar-update-buffers))
+ (add-hook 'menu-bar-update-hook #'edt-user-menu-bar-update-buffers))
(defun edt-select-default-global-map()
"Select default EDT emulation key bindings."
@@ -2163,8 +2154,7 @@ Argument KEY is the name of a key. It can be a standard key or a function key.
Argument BINDING is the Emacs function to be bound to <KEY>."
(define-key edt-user-global-map key binding))
-;; For backward compatibility to existing edt-user.el files.
-(fset 'edt-bind-standard-key (symbol-function 'edt-bind-key))
+(define-obsolete-function-alias 'edt-bind-standard-key #'edt-bind-key "28.1")
(defun edt-bind-gold-key (key gold-binding)
"Binds <GOLD> standard key sequences to custom bindings in the EDT Emulator.
@@ -2493,7 +2483,7 @@ G-C-\\: Split Window | FNDNXT | Yank | CUT |
(and b
(with-current-buffer b
(set-buffer-modified-p t)))
- (fset 'help-print-return-message 'ignore)
+ (fset 'help-print-return-message #'ignore)
(call-interactively fun)
(and (get-buffer name)
(get-buffer-window (get-buffer name))
@@ -2540,6 +2530,9 @@ G-C-\\: Split Window | FNDNXT | Yank | CUT |
(set-frame-width nil 132)
(message "Terminal width 132"))
+(defconst edt-version "4.0" "EDT Emulation version number.")
+(make-obsolete-variable 'edt-version 'emacs-version "28.1")
+
(provide 'edt)
;;; edt.el ends here
diff --git a/lisp/emulation/keypad.el b/lisp/emulation/keypad.el
index e4f3c4d53ec..56202c7fff8 100644
--- a/lisp/emulation/keypad.el
+++ b/lisp/emulation/keypad.el
@@ -1,4 +1,4 @@
-;;; keypad.el --- simplified keypad bindings
+;;; keypad.el --- simplified keypad bindings -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -101,10 +101,10 @@
"Specifies the keypad setup for unshifted keypad keys when NumLock is off.
When selecting the plain numeric keypad setup, the character returned by the
decimal key must be specified."
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(if value
(keypad-setup value nil nil value)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:link '(emacs-commentary-link "keypad.el")
:version "22.1"
:type '(choice (const :tag "Plain numeric keypad" numeric)
@@ -124,10 +124,10 @@ decimal key must be specified."
"Specifies the keypad setup for unshifted keypad keys when NumLock is on.
When selecting the plain numeric keypad setup, the character returned by the
decimal key must be specified."
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(if value
(keypad-setup value t nil value)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:link '(emacs-commentary-link "keypad.el")
:version "22.1"
:type '(choice (const :tag "Plain numeric keypad" numeric)
@@ -147,10 +147,10 @@ decimal key must be specified."
"Specifies the keypad setup for shifted keypad keys when NumLock is off.
When selecting the plain numeric keypad setup, the character returned by the
decimal key must be specified."
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(if value
(keypad-setup value nil t value)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:link '(emacs-commentary-link "keypad.el")
:version "22.1"
:type '(choice (const :tag "Plain numeric keypad" numeric)
@@ -170,10 +170,10 @@ decimal key must be specified."
"Specifies the keypad setup for shifted keypad keys when NumLock is off.
When selecting the plain numeric keypad setup, the character returned by the
decimal key must be specified."
- :set (lambda (symbol value)
+ :set (lambda (_symbol value)
(if value
(keypad-setup value t t value)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:link '(emacs-commentary-link "keypad.el")
:version "22.1"
:type '(choice (const :tag "Plain numeric keypad" numeric)
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 9fcf60d0165..728f790a962 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -24,8 +24,6 @@
;;; Code:
-(provide 'viper-cmd)
-
;; Compiler pacifier
(defvar viper-minibuffer-current-face)
(defvar viper-minibuffer-insert-face)
@@ -293,15 +291,15 @@
;; desirable that viper-pre-command-sentinel is the last hook and
;; viper-post-command-sentinel is the first hook.
- (remove-hook 'post-command-hook 'viper-post-command-sentinel)
- (add-hook 'post-command-hook 'viper-post-command-sentinel)
- (remove-hook 'pre-command-hook 'viper-pre-command-sentinel)
- (add-hook 'pre-command-hook 'viper-pre-command-sentinel t)
+ (remove-hook 'post-command-hook #'viper-post-command-sentinel)
+ (add-hook 'post-command-hook #'viper-post-command-sentinel)
+ (remove-hook 'pre-command-hook #'viper-pre-command-sentinel)
+ (add-hook 'pre-command-hook #'viper-pre-command-sentinel t)
;; These hooks will be added back if switching to insert/replace mode
(remove-hook 'viper-post-command-hooks
- 'viper-insert-state-post-command-sentinel 'local)
+ #'viper-insert-state-post-command-sentinel 'local)
(remove-hook 'viper-pre-command-hooks
- 'viper-insert-state-pre-command-sentinel 'local)
+ #'viper-insert-state-pre-command-sentinel 'local)
(setq viper-intermediate-command nil)
(cond ((eq new-state 'vi-state)
(cond ((member viper-current-state '(insert-state replace-state))
@@ -344,9 +342,9 @@
(viper-move-marker-locally
'viper-last-posn-while-in-insert-state (point))
(add-hook 'viper-post-command-hooks
- 'viper-insert-state-post-command-sentinel t 'local)
+ #'viper-insert-state-post-command-sentinel t 'local)
(add-hook 'viper-pre-command-hooks
- 'viper-insert-state-pre-command-sentinel t 'local))
+ #'viper-insert-state-pre-command-sentinel t 'local))
) ; outermost cond
;; Nothing needs to be done to switch to emacs mode! Just set some
@@ -378,12 +376,12 @@
(cond ((memq state '(insert-state replace-state))
(if viper-auto-indent
(progn
- (define-key viper-insert-basic-map "\C-m" 'viper-autoindent)
+ (define-key viper-insert-basic-map "\C-m" #'viper-autoindent)
(if viper-want-emacs-keys-in-insert
;; expert
(define-key viper-insert-basic-map "\C-j" nil)
;; novice
- (define-key viper-insert-basic-map "\C-j" 'viper-autoindent)))
+ (define-key viper-insert-basic-map "\C-j" #'viper-autoindent)))
(define-key viper-insert-basic-map "\C-m" nil)
(define-key viper-insert-basic-map "\C-j" nil))
@@ -392,25 +390,24 @@
(if viper-want-ctl-h-help
(progn
- (define-key viper-insert-basic-map "\C-h" 'help-command)
- (define-key viper-replace-map "\C-h" 'help-command))
+ (define-key viper-insert-basic-map "\C-h" #'help-command)
+ (define-key viper-replace-map "\C-h" #'help-command))
(define-key viper-insert-basic-map
- "\C-h" 'viper-del-backward-char-in-insert)
+ "\C-h" #'viper-del-backward-char-in-insert)
(define-key viper-replace-map
- "\C-h" 'viper-del-backward-char-in-replace))
+ "\C-h" #'viper-del-backward-char-in-replace))
;; In XEmacs, C-h overrides backspace, so we make sure it doesn't.
(define-key viper-insert-basic-map
- [backspace] 'viper-del-backward-char-in-insert)
+ [backspace] #'viper-del-backward-char-in-insert)
(define-key viper-replace-map
- [backspace] 'viper-del-backward-char-in-replace)
+ [backspace] #'viper-del-backward-char-in-replace)
) ; end insert/replace case
(t ; Vi state
(setq viper-vi-diehard-minor-mode (not viper-want-emacs-keys-in-vi))
- (if viper-want-ctl-h-help
- (define-key viper-vi-basic-map "\C-h" 'help-command)
- (define-key viper-vi-basic-map "\C-h" 'viper-backward-char))
+ (define-key viper-vi-basic-map "\C-h"
+ (if viper-want-ctl-h-help #'help-command #'viper-backward-char))
;; In XEmacs, C-h overrides backspace, so we make sure it doesn't.
- (define-key viper-vi-basic-map [backspace] 'viper-backward-char))
+ (define-key viper-vi-basic-map [backspace] #'viper-backward-char))
))
@@ -466,24 +463,7 @@
(assoc major-mode viper-emacs-state-modifier-alist)))
(cdr
(assoc major-mode viper-emacs-state-modifier-alist))
- viper-empty-keymap))
- ))
-
- ;; This var is not local in Emacs, so we make it local. It must be local
- ;; because although the stack of minor modes can be the same for all buffers,
- ;; the associated *keymaps* can be different. In Viper,
- ;; viper-vi-local-user-map, viper-insert-local-user-map, and others can have
- ;; different keymaps for different buffers. Also, the keymaps associated
- ;; with viper-vi/insert-state-modifier-minor-mode can be different.
- ;; ***This is needed only in case emulation-mode-map-alists is not defined.
- ;; In emacs with emulation-mode-map-alists, nothing needs to be done
- (unless
- (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- (set (make-local-variable 'minor-mode-map-alist)
- (viper-append-filter-alist
- (append viper--intercept-key-maps viper--key-maps)
- minor-mode-map-alist)))
- )
+ viper-empty-keymap)))))
@@ -491,7 +471,7 @@
;; Modifies mode-line-buffer-identification.
(defun viper-refresh-mode-line ()
- (set (make-local-variable 'viper-mode-string)
+ (setq-local viper-mode-string
(cond ((eq viper-current-state 'emacs-state) viper-emacs-state-id)
((eq viper-current-state 'vi-state) viper-vi-state-id)
((eq viper-current-state 'replace-state) viper-replace-state-id)
@@ -711,7 +691,7 @@
ARG is used as the prefix value for the executed command. If
EVENTS is a list of events, which become the beginning of the command."
(interactive "P")
- (if (viper= (viper-last-command-char) ?\\)
+ (if (viper= last-command-event ?\\)
(message "Switched to EMACS state for the next command..."))
(viper-escape-to-state arg events 'emacs-state))
@@ -848,7 +828,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to
(condition-case nil
(let (viper-vi-kbd-minor-mode) ; execute without kbd macros
- (setq result (eval form)))
+ (setq result (eval form t)))
(error
(signal 'quit nil)))
@@ -864,7 +844,7 @@ Similar to `viper-escape-to-emacs', but accepts forms rather than keystrokes."
(let ((buff (current-buffer))
result)
(viper-set-mode-vars-for 'emacs-state)
- (setq result (eval form))
+ (setq result (eval form t))
(if (not (equal buff (current-buffer))) ; cmd switched buffer
(with-current-buffer buff
(viper-set-mode-vars-for viper-current-state)))
@@ -893,16 +873,7 @@ LOAD-FILE is the name of the file where the specific minor mode is defined.
Suffixes such as .el or .elc should be stripped."
(interactive "sEnter name of the load file: ")
-
- (eval-after-load load-file '(viper-normalize-minor-mode-map-alist))
-
- ;; Change the default for minor-mode-map-alist each time a harnessed minor
- ;; mode adds its own keymap to the a-list.
- (unless
- (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- (eval-after-load
- load-file '(setq-default minor-mode-map-alist minor-mode-map-alist)))
- )
+ (eval-after-load load-file '(viper-normalize-minor-mode-map-alist)))
(defun viper-ESC (arg)
@@ -1175,7 +1146,7 @@ as a Meta key and any number of multiple escapes are allowed."
"Begin numeric argument for the next command."
(interactive "P")
(viper-prefix-arg-value
- (viper-last-command-char) (if (consp arg) (cdr arg) nil)))
+ last-command-event (if (consp arg) (cdr arg) nil)))
(defun viper-command-argument (arg)
"Accept a motion command as an argument."
@@ -1183,7 +1154,7 @@ as a Meta key and any number of multiple escapes are allowed."
(let ((viper-intermediate-command 'viper-command-argument))
(condition-case nil
(viper-prefix-arg-com
- (viper-last-command-char)
+ last-command-event
(cond ((null arg) nil)
((consp arg) (car arg))
((integerp arg) arg)
@@ -1437,17 +1408,17 @@ as a Meta key and any number of multiple escapes are allowed."
;; without affecting other functions. Buffer search can now be bound
;; to any character.
-(aset viper-exec-array ?c 'viper-exec-change)
-(aset viper-exec-array ?C 'viper-exec-Change)
-(aset viper-exec-array ?d 'viper-exec-delete)
-(aset viper-exec-array ?D 'viper-exec-Delete)
-(aset viper-exec-array ?y 'viper-exec-yank)
-(aset viper-exec-array ?Y 'viper-exec-Yank)
-(aset viper-exec-array ?r 'viper-exec-dummy)
-(aset viper-exec-array ?! 'viper-exec-bang)
-(aset viper-exec-array ?< 'viper-exec-shift)
-(aset viper-exec-array ?> 'viper-exec-shift)
-(aset viper-exec-array ?= 'viper-exec-equals)
+(aset viper-exec-array ?c #'viper-exec-change)
+(aset viper-exec-array ?C #'viper-exec-Change)
+(aset viper-exec-array ?d #'viper-exec-delete)
+(aset viper-exec-array ?D #'viper-exec-Delete)
+(aset viper-exec-array ?y #'viper-exec-yank)
+(aset viper-exec-array ?Y #'viper-exec-Yank)
+(aset viper-exec-array ?r #'viper-exec-dummy)
+(aset viper-exec-array ?! #'viper-exec-bang)
+(aset viper-exec-array ?< #'viper-exec-shift)
+(aset viper-exec-array ?> #'viper-exec-shift)
+(aset viper-exec-array ?= #'viper-exec-equals)
@@ -1586,17 +1557,17 @@ invokes the command before that, etc."
(defun viper-undo-sentinel (beg end length)
(run-hook-with-args 'viper-undo-functions beg end length))
-(add-hook 'after-change-functions 'viper-undo-sentinel)
+(add-hook 'after-change-functions #'viper-undo-sentinel)
;; Hook used in viper-undo
(defun viper-after-change-undo-hook (beg end _len)
- (if (and (boundp 'undo-in-progress) undo-in-progress)
+ (if undo-in-progress
(setq undo-beg-posn beg
undo-end-posn (or end beg))
;; some other hooks may be changing various text properties in
;; the buffer in response to 'undo'; so remove this hook to avoid
;; its repeated invocation
- (remove-hook 'viper-undo-functions 'viper-after-change-undo-hook 'local)
+ (remove-hook 'viper-undo-functions #'viper-after-change-undo-hook 'local)
))
(defun viper-undo ()
@@ -1607,7 +1578,7 @@ invokes the command before that, etc."
undo-beg-posn undo-end-posn)
;; the viper-after-change-undo-hook removes itself after the 1st invocation
- (add-hook 'viper-undo-functions 'viper-after-change-undo-hook nil 'local)
+ (add-hook 'viper-undo-functions #'viper-after-change-undo-hook nil 'local)
(undo-start)
(undo-more 2)
@@ -1624,9 +1595,9 @@ invokes the command before that, etc."
(pos-visible-in-window-p before-undo-pt))
(progn
(push-mark (point-marker) t)
- (viper-sit-for-short 300)
+ (sit-for 0.3)
(goto-char undo-end-posn)
- (viper-sit-for-short 300)
+ (sit-for 0.3)
(if (pos-visible-in-window-p undo-beg-posn)
(goto-char before-undo-pt)
(goto-char undo-beg-posn)))
@@ -1650,7 +1621,7 @@ invokes the command before that, etc."
;; The following two functions are used to set up undo properly.
;; In VI, unlike Emacs, if you open a line, say, and add a bunch of lines,
;; they are undone all at once.
-(viper-deflocalvar viper--undo-change-group-handle nil)
+(defvar-local viper--undo-change-group-handle nil)
(put 'viper--undo-change-group-handle 'permanent-local t)
(defun viper-adjust-undo ()
@@ -1815,7 +1786,7 @@ Undo previous insertion and inserts new."
(do-not-change-default t))
(setq quote-str
(viper-read-string-with-history
- "Quote string: "
+ "Quote string"
nil
'viper-quote-region-history
;; FIXME: Use comment-region.
@@ -1879,8 +1850,8 @@ Undo previous insertion and inserts new."
;;; Minibuffer business
(defsubst viper-set-minibuffer-style ()
- (add-hook 'minibuffer-setup-hook 'viper-minibuffer-setup-sentinel)
- (add-hook 'post-command-hook 'viper-minibuffer-post-command-hook))
+ (add-hook 'minibuffer-setup-hook #'viper-minibuffer-setup-sentinel)
+ (add-hook 'post-command-hook #'viper-minibuffer-post-command-hook))
(defun viper-minibuffer-setup-sentinel ()
@@ -1891,14 +1862,10 @@ Undo previous insertion and inserts new."
;; minibuffer and vice versa. Otherwise, command arguments will affect
;; minibuffer ops and insertions from the minibuffer will change those in
;; the normal buffers
- (make-local-variable 'viper-d-com)
- (make-local-variable 'viper-last-insertion)
- (make-local-variable 'viper-command-ring)
- (setq viper-d-com nil
- viper-last-insertion nil
- viper-command-ring nil)
- (funcall hook)
- ))
+ (setq-local viper-d-com nil)
+ (setq-local viper-last-insertion nil)
+ (setq-local viper-command-ring nil)
+ (funcall hook)))
;; This is a temp hook that uses free variables viper--init-message and viper-initial.
;; A dirty feature, but it is the simplest way to have it do the right thing.
@@ -1912,15 +1879,11 @@ Undo previous insertion and inserts new."
(or unread-command-events
executing-kbd-macro
(sit-for 840))
- (if (fboundp 'minibuffer-prompt-end)
- (delete-region (minibuffer-prompt-end) (point-max))
- (erase-buffer))
+ (delete-region (minibuffer-prompt-end) (point-max))
(insert viper-initial)))
(defsubst viper-minibuffer-real-start ()
- (if (fboundp 'minibuffer-prompt-end)
- (minibuffer-prompt-end)
- (point-min)))
+ (minibuffer-prompt-end))
(defun viper-minibuffer-post-command-hook()
(when (active-minibuffer-window)
@@ -1934,7 +1897,7 @@ Undo previous insertion and inserts new."
"Exit minibuffer Viper way."
(interactive)
(let (command)
- (setq command (local-key-binding (char-to-string (viper-last-command-char))))
+ (setq command (local-key-binding (char-to-string last-command-event)))
(run-hooks 'viper-minibuffer-exit-hook)
(if command
(command-execute command)
@@ -2032,30 +1995,24 @@ problems."
#'viper-minibuffer-standard-hook
(if (or (not (listp old)) (eq (car old) 'lambda))
(list old) old))))
- (val "")
- (padding "")
- temp-msg)
+ (val ""))
(setq keymap (or keymap minibuffer-local-map)
initial (or initial "")
- viper-initial initial
- temp-msg (if default
- (format "(default %s) " default)
- ""))
+ viper-initial initial)
(setq viper-incomplete-ex-cmd nil)
- (setq val (read-from-minibuffer prompt
- (concat temp-msg initial val padding)
- keymap nil history-var))
- (setq minibuffer-setup-hook nil
- padding (viper-array-to-string (this-command-keys))
- temp-msg "")
+ (setq val (read-from-minibuffer (format-prompt prompt default)
+ nil
+ keymap nil history-var default))
+ (setq minibuffer-setup-hook nil)
;; the following tries to be smart about what to put in history
- (if (not (string= val (car (eval history-var))))
- (set history-var (cons val (eval history-var))))
- (if (or (string= (nth 0 (eval history-var)) (nth 1 (eval history-var)))
- (string= (nth 0 (eval history-var)) ""))
- (set history-var (cdr (eval history-var))))
+ (if (not (string= val (car (symbol-value history-var))))
+ (push val (symbol-value history-var)))
+ (if (or (string= (nth 0 (symbol-value history-var))
+ (nth 1 (symbol-value history-var)))
+ (string= (nth 0 (symbol-value history-var)) ""))
+ (pop (symbol-value history-var)))
;; If the user enters nothing but the prev cmd wasn't viper-ex,
;; viper-command-argument, or `! shell-command', this probably means
;; that the user typed something then erased. Return "" in this case, not
@@ -2226,22 +2183,22 @@ problems."
viper-sitting-in-replace t
viper-replace-chars-to-delete 0)
(add-hook
- 'viper-after-change-functions 'viper-replace-mode-spy-after t 'local)
+ 'viper-after-change-functions #'viper-replace-mode-spy-after t 'local)
(add-hook
- 'viper-before-change-functions 'viper-replace-mode-spy-before t 'local)
+ 'viper-before-change-functions #'viper-replace-mode-spy-before t 'local)
;; this will get added repeatedly, but no harm
- (add-hook 'after-change-functions 'viper-after-change-sentinel t)
- (add-hook 'before-change-functions 'viper-before-change-sentinel t)
+ (add-hook 'after-change-functions #'viper-after-change-sentinel t)
+ (add-hook 'before-change-functions #'viper-before-change-sentinel t)
(viper-move-marker-locally
'viper-last-posn-in-replace-region (viper-replace-start))
(add-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel
t 'local)
(add-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel t 'local)
;; guard against a smarty who switched from R-replace to normal replace
(remove-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel 'local)
(if overwrite-mode (overwrite-mode -1))
)
@@ -2315,13 +2272,13 @@ problems."
;; Don't delete anything if current point is past the end of the overlay.
(defun viper-finish-change ()
(remove-hook
- 'viper-after-change-functions 'viper-replace-mode-spy-after 'local)
+ 'viper-after-change-functions #'viper-replace-mode-spy-after 'local)
(remove-hook
- 'viper-before-change-functions 'viper-replace-mode-spy-before 'local)
+ 'viper-before-change-functions #'viper-replace-mode-spy-before 'local)
(remove-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel 'local)
(remove-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel 'local)
(viper-restore-cursor-color 'after-replace-mode)
(setq viper-sitting-in-replace nil) ; just in case we'll need to know it
(save-excursion
@@ -2351,21 +2308,21 @@ problems."
(defun viper-finish-R-mode ()
(remove-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel 'local)
(remove-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel 'local)
(viper-downgrade-to-insert))
(defun viper-start-R-mode ()
;; Leave arg as 1, not t: XEmacs insists that it must be a pos number
(overwrite-mode 1)
(add-hook
- 'viper-post-command-hooks 'viper-R-state-post-command-sentinel t 'local)
+ 'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local)
(add-hook
- 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t 'local)
+ 'viper-pre-command-hooks #'viper-replace-state-pre-command-sentinel t 'local)
;; guard against a smarty who switched from R-replace to normal replace
(remove-hook
- 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel 'local)
+ 'viper-post-command-hooks #'viper-replace-state-post-command-sentinel 'local)
)
@@ -2909,7 +2866,7 @@ If point is on a widget or a button, simulate clicking on that widget/button."
(and (consp widget)
(get (widget-type widget) 'widget-type))))
(widget-button-press (point))
- (if (and (fboundp 'button-at) (fboundp 'push-button) (button-at (point)))
+ (if (button-at (point))
(push-button)
;; not a widget or a button
(save-excursion
@@ -3501,7 +3458,8 @@ controlled by the sign of prefix numeric value."
'(viper-command-argument viper-digit-argument viper-repeat))
(setq viper-this-command-keys (this-command-keys)))
(let* ((keymap (let ((keymap (copy-keymap minibuffer-local-map)))
- (define-key keymap [(control ?s)] 'viper-insert-isearch-string)
+ (define-key keymap [(control ?s)]
+ #'viper-insert-isearch-string)
keymap))
(s (viper-read-string-with-history
prompt
@@ -3810,8 +3768,8 @@ Null string will repeat previous search."
(char-to-string viper-buffer-search-char))
(t (error "viper-buffer-search-char: wrong value type, %S"
viper-buffer-search-char)))
- 'viper-command-argument)
- (aset viper-exec-array viper-buffer-search-char 'viper-exec-buffer-search)
+ #'viper-command-argument)
+ (aset viper-exec-array viper-buffer-search-char #'viper-exec-buffer-search)
(setq viper-prefix-commands
(cons viper-buffer-search-char viper-prefix-commands)))
@@ -3860,7 +3818,7 @@ Null string will repeat previous search."
(let (buffer buffer-name)
(setq buffer-name
(funcall viper-read-buffer-function
- (format "Kill buffer (%s): "
+ (format-prompt "Kill buffer"
(buffer-name (current-buffer)))))
(setq buffer
(if (null buffer-name)
@@ -4206,8 +4164,8 @@ and regexp replace."
(interactive)
(let (str)
(setq str (viper-read-string-with-history
- (if viper-re-query-replace "Query replace regexp: "
- "Query replace: ")
+ (if viper-re-query-replace "Query replace regexp"
+ "Query replace")
nil ; no initial
'viper-replace1-history
(car viper-replace1-history) ; default
@@ -4222,7 +4180,7 @@ and regexp replace."
(query-replace-regexp
str
(viper-read-string-with-history
- (format-message "Query replace regexp `%s' with: " str)
+ (format-message "Query replace regexp `%s' with" str)
nil ; no initial
'viper-replace1-history
(car viper-replace1-history) ; default
@@ -4230,7 +4188,7 @@ and regexp replace."
(query-replace
str
(viper-read-string-with-history
- (format-message "Query replace `%s' with: " str)
+ (format-message "Query replace `%s' with" str)
nil ; no initial
'viper-replace1-history
(car viper-replace1-history) ; default
@@ -4402,7 +4360,7 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back."
;; Input Mode Indentation
-(define-obsolete-function-alias 'viper-looking-back 'looking-back "24.4")
+(define-obsolete-function-alias 'viper-looking-back #'looking-back "24.4")
(defun viper-forward-indent ()
@@ -4545,8 +4503,8 @@ One can use \\=`\\=` and \\='\\=' to temporarily jump 1 step back."
;; standard value. Otherwise, get the value saved in the alist STORAGE. If
;; STORAGE is nil, use viper-saved-user-settings.
(defun viper-standard-value (symbol &optional storage)
- (or (eval (car (get symbol 'customized-value)))
- (eval (car (get symbol 'saved-value)))
+ (or (eval (car (get symbol 'customized-value)) t)
+ (eval (car (get symbol 'saved-value)) t)
(nth 1 (assoc symbol (or storage viper-saved-user-settings)))))
@@ -4721,8 +4679,7 @@ Please, specify your level now: "))
(interactive "cViper register to point: ")
(let ((val (get-register char)))
(cond
- ((and (fboundp 'frame-configuration-p)
- (frame-configuration-p val))
+ ((frame-configuration-p val)
(set-frame-configuration val))
((window-configuration-p val)
(set-window-configuration val))
@@ -4765,8 +4722,7 @@ Please, specify your level now: "))
(viper-color-display-p (if (viper-window-display-p)
(viper-color-display-p)
'non-x))
- (viper-frame-parameters (if (fboundp 'frame-parameters)
- (frame-parameters (selected-frame))))
+ (viper-frame-parameters (frame-parameters (selected-frame)))
(viper-minibuffer-emacs-face (if (viper-has-face-support-p)
(facep
viper-minibuffer-emacs-face)
@@ -4885,7 +4841,5 @@ Mail anyway (y or n)? ")
nil 'delete-other-windows
salutation)))
-
-
-
+(provide 'viper-cmd)
;;; viper-cmd.el ends here
diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el
index 238faed069f..5b2fa048a09 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -1,4 +1,4 @@
-;;; viper-ex.el --- functions implementing the Ex commands for Viper
+;;; viper-ex.el --- functions implementing the Ex commands for Viper -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1998, 2000-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Code:
-(provide 'viper-ex)
-
;; Compiler pacifier
(defvar read-file-name-map)
(defvar viper-use-register)
@@ -190,7 +188,7 @@
;; Executes the function associated with the command
(defun ex-cmd-execute (cmd)
- (eval (cadr cmd)))
+ (eval (cadr cmd) t))
;; If this is a one-letter magic command, splice in args.
(defun ex-splice-args-in-1-letr-cmd (key list)
@@ -299,8 +297,7 @@
"\\)")
shell-file-name)))
"Is the user using a unix-type shell under a non-OS?"
- :type 'boolean
- :group 'viper-ex)
+ :type 'boolean)
(defcustom ex-unix-type-shell-options
(let ((case-fold-search t))
@@ -312,13 +309,11 @@
)))
"Options to pass to the Unix-style shell.
Don't put `-c' here, as it is added automatically."
- :type '(choice (const nil) string)
- :group 'viper-ex)
+ :type '(choice (const nil) string))
(defcustom ex-compile-command "make"
"The command to run when the user types :make."
- :type 'string
- :group 'viper-ex)
+ :type 'string)
(defcustom viper-glob-function
(cond (ex-unix-type-shell 'viper-glob-unix-files)
@@ -331,8 +326,7 @@ The default tries to set this variable to work with Unix or MS Windows.
However, if it doesn't work right for some types of Unix shells or some OS,
the user should supply the appropriate function and set this variable to the
corresponding function symbol."
- :type 'symbol
- :group 'viper-ex)
+ :type 'symbol)
;; Remembers the previous Ex tag.
@@ -363,13 +357,11 @@ corresponding function symbol."
"If t, :n and :b cycles through files and buffers in other window.
Then :N and :B cycles in the current window. If nil, this behavior is
reversed."
- :type 'boolean
- :group 'viper-ex)
+ :type 'boolean)
(defcustom ex-cycle-through-non-files nil
"Cycle through *scratch* and other buffers that don't visit any file."
- :type 'boolean
- :group 'viper-ex)
+ :type 'boolean)
;; Last shell command executed with :! command.
(defvar viper-ex-last-shell-com nil)
@@ -1314,7 +1306,7 @@ reversed."
(let ((nonstandard-filename-chars "[^-a-zA-Z0-9_./,~$\\]"))
(cond ((file-exists-p filespec) (find-file filespec))
((string-match nonstandard-filename-chars filespec)
- (mapcar 'find-file (funcall viper-glob-function filespec)))
+ (mapcar #'find-file (funcall viper-glob-function filespec)))
(t (find-file filespec)))
))
@@ -1639,7 +1631,7 @@ reversed."
;; this function fixes ex-history for some commands like ex-read, ex-edit
(defun ex-fixup-history (&rest args)
(setq viper-ex-history
- (cons (mapconcat 'identity args " ") (cdr viper-ex-history))))
+ (cons (mapconcat #'identity args " ") (cdr viper-ex-history))))
;; Ex recover from emacs \#file\#
@@ -1672,8 +1664,8 @@ reversed."
(cursor-in-echo-area t)
str batch)
(define-key
- minibuffer-local-completion-map " " 'minibuffer-complete-and-exit)
- (define-key minibuffer-local-completion-map "=" 'exit-minibuffer)
+ minibuffer-local-completion-map " " #'minibuffer-complete-and-exit)
+ (define-key minibuffer-local-completion-map "=" #'exit-minibuffer)
(if (viper-set-unread-command-events
(ex-get-inline-cmd-args "[ \t]*[a-zA-Z]*[ \t]*" nil "\C-m"))
(progn
@@ -1837,7 +1829,7 @@ reversed."
(format "%S" val)
val)))
(if actual-lisp-cmd
- (eval (car (read-from-string actual-lisp-cmd))))
+ (eval (car (read-from-string actual-lisp-cmd)) t))
(if (string= var "fill-column")
(if (> val2 0)
(auto-fill-mode 1)
@@ -2319,4 +2311,5 @@ Type `mak ' (including the space) to run make with no args."
(with-output-to-temp-buffer " *viper-info*"
(princ lines))))))
+(provide 'viper-ex)
;;; viper-ex.el ends here
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index a8e9d96bab6..8188971c0d0 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -1,4 +1,4 @@
-;;; viper-init.el --- some common definitions for Viper
+;;; viper-init.el --- some common definitions for Viper -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -46,7 +46,7 @@
;; Tell whether we are running as a window application or on a TTY
-(define-obsolete-function-alias 'viper-device-type 'window-system "27.1")
+(define-obsolete-function-alias 'viper-device-type #'window-system "27.1")
(defun viper-color-display-p ()
(condition-case nil
@@ -91,11 +91,9 @@ In all likelihood, you don't need to bother with this setting."
"Define VAR as a buffer-local variable.
DEFAULT-VALUE is the default value, and DOCUMENTATION is the
docstring. The variable becomes buffer-local whenever set."
- (declare (indent defun))
- `(progn
- (defvar ,var ,default-value
- ,(format "%s\n(buffer local)" documentation))
- (make-variable-buffer-local ',var)))
+ (declare (indent defun)
+ (obsolete defvar-local "28.1"))
+ `(defvar-local ,var ,default-value ,documentation))
;; (viper-loop COUNT BODY) Execute BODY COUNT times.
(defmacro viper-loop (count &rest body)
@@ -143,7 +141,7 @@ docstring. The variable becomes buffer-local whenever set."
(append (vconcat string) nil))
(defsubst viper-charlist-to-string (list)
- (mapconcat 'char-to-string list ""))
+ (mapconcat #'char-to-string list ""))
;; like char-after/before, but saves typing
(defun viper-char-at-pos (direction &optional offset)
@@ -161,87 +159,87 @@ docstring. The variable becomes buffer-local whenever set."
;;; Viper minor modes
;; Mode for vital things like \e, C-z.
-(viper-deflocalvar viper-vi-intercept-minor-mode nil)
+(defvar-local viper-vi-intercept-minor-mode nil)
-(viper-deflocalvar viper-vi-basic-minor-mode nil
+(defvar-local viper-vi-basic-minor-mode nil
"Viper's minor mode for Vi bindings.")
-(viper-deflocalvar viper-vi-local-user-minor-mode nil
+(defvar-local viper-vi-local-user-minor-mode nil
"Auxiliary minor mode for user-defined local bindings in Vi state.")
-(viper-deflocalvar viper-vi-global-user-minor-mode nil
+(defvar-local viper-vi-global-user-minor-mode nil
"Auxiliary minor mode for user-defined global bindings in Vi state.")
-(viper-deflocalvar viper-vi-state-modifier-minor-mode nil
+(defvar-local viper-vi-state-modifier-minor-mode nil
"Minor mode used to make major-mode-specific modification to Vi state.")
-(viper-deflocalvar viper-vi-diehard-minor-mode nil
+(defvar-local viper-vi-diehard-minor-mode nil
"This minor mode is in effect when the user wants Viper to be Vi.")
-(viper-deflocalvar viper-vi-kbd-minor-mode nil
+(defvar-local viper-vi-kbd-minor-mode nil
"Minor mode for Ex command macros in Vi state.
The corresponding keymap stores key bindings of Vi macros defined with
the Ex command :map.")
;; Mode for vital things like \e, C-z.
-(viper-deflocalvar viper-insert-intercept-minor-mode nil)
+(defvar-local viper-insert-intercept-minor-mode nil)
-(viper-deflocalvar viper-insert-basic-minor-mode nil
+(defvar-local viper-insert-basic-minor-mode nil
"Viper's minor mode for bindings in Insert mode.")
-(viper-deflocalvar viper-insert-local-user-minor-mode nil
+(defvar-local viper-insert-local-user-minor-mode nil
"Auxiliary minor mode for buffer-local user-defined bindings in Insert state.
This is a way to overshadow normal Insert mode bindings locally to certain
designated buffers.")
-(viper-deflocalvar viper-insert-global-user-minor-mode nil
+(defvar-local viper-insert-global-user-minor-mode nil
"Auxiliary minor mode for global user-defined bindings in Insert state.")
-(viper-deflocalvar viper-insert-state-modifier-minor-mode nil
+(defvar-local viper-insert-state-modifier-minor-mode nil
"Minor mode used to make major-mode-specific modification to Insert state.")
-(viper-deflocalvar viper-insert-diehard-minor-mode nil
+(defvar-local viper-insert-diehard-minor-mode nil
"Minor mode that simulates Vi very closely.
Not recommended, except for the novice user.")
-(viper-deflocalvar viper-insert-kbd-minor-mode nil
+(defvar-local viper-insert-kbd-minor-mode nil
"Minor mode for Ex command macros Insert state.
The corresponding keymap stores key bindings of Vi macros defined with
the Ex command :map!.")
-(viper-deflocalvar viper-replace-minor-mode nil
+(defvar-local viper-replace-minor-mode nil
"Minor mode in effect in replace state (cw, C, and the like commands).")
;; Mode for vital things like \C-z and \C-x) This is set to t, when viper-mode
;; is invoked. So, any new buffer will have C-z defined as switch to Vi,
;; unless we switched states in this buffer
-(viper-deflocalvar viper-emacs-intercept-minor-mode nil)
+(defvar-local viper-emacs-intercept-minor-mode nil)
-(viper-deflocalvar viper-emacs-local-user-minor-mode nil
+(defvar-local viper-emacs-local-user-minor-mode nil
"Minor mode for local user bindings effective in Emacs state.
Users can use it to override Emacs bindings when Viper is in its Emacs
state.")
-(viper-deflocalvar viper-emacs-global-user-minor-mode nil
+(defvar-local viper-emacs-global-user-minor-mode nil
"Minor mode for global user bindings in effect in Emacs state.
Users can use it to override Emacs bindings when Viper is in its Emacs
state.")
-(viper-deflocalvar viper-emacs-kbd-minor-mode nil
+(defvar-local viper-emacs-kbd-minor-mode nil
"Minor mode for Vi style macros in Emacs state.
The corresponding keymap stores key bindings of Vi macros defined with
`viper-record-kbd-macro' command. There is no Ex-level command to do this
interactively.")
-(viper-deflocalvar viper-emacs-state-modifier-minor-mode nil
+(defvar-local viper-emacs-state-modifier-minor-mode nil
"Minor mode used to make major-mode-specific modification to Emacs state.
For instance, a Vi purist may want to bind `dd' in Dired mode to a function
that deletes a file.")
-(viper-deflocalvar viper-vi-minibuffer-minor-mode nil
+(defvar-local viper-vi-minibuffer-minor-mode nil
"Minor mode that forces Vi-style when the Minibuffer is in Vi state.")
-(viper-deflocalvar viper-insert-minibuffer-minor-mode nil
+(defvar-local viper-insert-minibuffer-minor-mode nil
"Minor mode that forces Vi-style when the Minibuffer is in Insert state.")
@@ -284,7 +282,7 @@ Use `\\[viper-set-expert-level]' to change this.")
;; If non-nil, ISO accents will be turned on in insert/replace emacs states and
;; turned off in vi-state. For some users, this behavior may be too
;; primitive. In this case, use insert/emacs/vi state hooks.
-(viper-deflocalvar viper-automatic-iso-accents nil "")
+(defvar-local viper-automatic-iso-accents nil "")
;; Set iso-accents-mode to ARG. Check if it is bound first
(defsubst viper-set-iso-accents-mode (arg)
(if (boundp 'iso-accents-mode)
@@ -294,7 +292,7 @@ Use `\\[viper-set-expert-level]' to change this.")
;; Don't change this!
(defvar viper-mule-hook-flag t)
;; If non-nil, the default intl. input method is turned on.
-(viper-deflocalvar viper-special-input-method nil "")
+(defvar-local viper-special-input-method nil "")
;; viper hook to run on input-method activation
(defun viper-activate-input-method-action ()
@@ -357,7 +355,7 @@ it better fits your working style."
;; Replace mode and changing text
;; Hack used to pass global states around for short period of time
-(viper-deflocalvar viper-intermediate-command nil "")
+(defvar-local viper-intermediate-command nil "")
;; This is used to pass the right Vi command key sequence to
;; viper-set-destructive-command whenever (this-command-keys) doesn't give the
@@ -367,7 +365,7 @@ it better fits your working style."
(defconst viper-this-command-keys nil)
;; Indicates that the current destructive command has started in replace mode.
-(viper-deflocalvar viper-began-as-replace nil "")
+(defvar-local viper-began-as-replace nil "")
(defcustom viper-allow-multiline-replace-regions t
"If non-nil, Viper will allow multi-line replace regions.
@@ -398,7 +396,7 @@ delete the text being replaced, as in standard Vi."
;; internal var, used to remember the default cursor color of emacs frames
(defvar viper-vi-state-cursor-color nil)
-(viper-deflocalvar viper-replace-overlay nil "")
+(defvar-local viper-replace-overlay nil "")
(put 'viper-replace-overlay 'permanent-local t)
(defcustom viper-replace-region-end-delimiter "$"
@@ -430,24 +428,24 @@ color displays. By default, the delimiters are used only on TTYs."
;; `viper-move-marker-locally'
;;
;; Remember the last position inside the replace region.
-(viper-deflocalvar viper-last-posn-in-replace-region nil)
+(defvar-local viper-last-posn-in-replace-region nil)
;; Remember the last position while inserting
-(viper-deflocalvar viper-last-posn-while-in-insert-state nil)
+(defvar-local viper-last-posn-while-in-insert-state nil)
(put 'viper-last-posn-in-replace-region 'permanent-local t)
(put 'viper-last-posn-while-in-insert-state 'permanent-local t)
-(viper-deflocalvar viper-sitting-in-replace nil "")
+(defvar-local viper-sitting-in-replace nil "")
(put 'viper-sitting-in-replace 'permanent-local t)
;; Remember the number of characters that have to be deleted in replace
;; mode to compensate for the inserted characters.
-(viper-deflocalvar viper-replace-chars-to-delete 0 "")
+(defvar-local viper-replace-chars-to-delete 0 "")
;; This variable is used internally by the before/after changed functions to
;; determine how many chars were deleted by the change. This can't be
;; determined inside after-change-functions because those get the length of the
;; deleted region, not the number of chars deleted (which are two different
;; things under MULE).
-(viper-deflocalvar viper-replace-region-chars-deleted 0 "")
+(defvar-local viper-replace-region-chars-deleted 0 "")
;; Insertion ring and command ring
(defcustom viper-insertion-ring-size 14
@@ -475,7 +473,8 @@ text."
;; Fast keyseq and ESC keyseq timeouts
(defcustom viper-fast-keyseq-timeout 200
- "Key sequence separated by no more than this many milliseconds is viewed as a Vi-style macro, if such a macro is defined.
+ "Max milliseconds for a key sequence to be regarded as a Vi-style macro.
+Only regard key sequence as a macro if it is defined.
Setting this too high may slow down your typing. Setting this value too low
will make it hard to use Vi-style timeout macros."
:type 'integer
@@ -489,28 +488,28 @@ will make it hard to use Vi-style timeout macros."
;; Modes and related variables
;; Current mode. One of: `emacs-state', `vi-state', `insert-state'
-(viper-deflocalvar viper-current-state 'emacs-state)
+(defvar-local viper-current-state 'emacs-state)
;; Autoindent in insert
;; Variable that keeps track of whether C-t has been pressed.
-(viper-deflocalvar viper-cted nil "")
+(defvar-local viper-cted nil "")
;; Preserve the indent value, used by C-d in insert mode.
-(viper-deflocalvar viper-current-indent 0)
+(defvar-local viper-current-indent 0)
;; Whether to preserve the indent, used by C-d in insert mode.
-(viper-deflocalvar viper-preserve-indent nil)
+(defvar-local viper-preserve-indent nil)
-(viper-deflocalvar viper-auto-indent nil "")
+(defvar-local viper-auto-indent nil "")
(defcustom viper-auto-indent nil
"Enable autoindent, if t.
This is a buffer-local variable."
:type 'boolean
:group 'viper)
-(viper-deflocalvar viper-electric-mode t "")
+(defvar-local viper-electric-mode t "")
(defcustom viper-electric-mode t
"If t, electrify Viper.
Currently, this only electrifies auto-indentation, making it appropriate to the
@@ -540,7 +539,7 @@ to a new place after repeating previous Vi command."
;; Remember insert point as a marker. This is a local marker that must be
;; initialized to nil and moved with `viper-move-marker-locally'.
-(viper-deflocalvar viper-insert-point nil)
+(defvar-local viper-insert-point nil)
(put 'viper-insert-point 'permanent-local t)
;; This remembers the point before dabbrev-expand was called.
@@ -561,7 +560,7 @@ to a new place after repeating previous Vi command."
;; problem. However, the same trick can be used if such a command is
;; discovered later.
;;
-(viper-deflocalvar viper-pre-command-point nil)
+(defvar-local viper-pre-command-point nil)
(put 'viper-pre-command-point 'permanent-local t) ; this is probably an overkill
;; This is used for saving inserted text.
@@ -572,7 +571,7 @@ to a new place after repeating previous Vi command."
;; Remember com point as a marker.
;; This is a local marker. Should be moved with `viper-move-marker-locally'
-(viper-deflocalvar viper-com-point nil)
+(defvar-local viper-com-point nil)
;; If non-nil, the value is a list (M-COM VAL COM REG inserted-text cmd-keys)
;; It is used to re-execute last destructive command.
@@ -659,14 +658,14 @@ negative number."
:type 'boolean
:group 'viper)
-(viper-deflocalvar viper-ex-style-motion t "")
+(defvar-local viper-ex-style-motion t "")
(defcustom viper-ex-style-motion t
"If t, the commands l,h do not cross lines, etc (Ex-style).
If nil, these commands cross line boundaries."
:type 'boolean
:group 'viper)
-(viper-deflocalvar viper-ex-style-editing t "")
+(defvar-local viper-ex-style-editing t "")
(defcustom viper-ex-style-editing t
"If t, Ex-style behavior while editing in Vi command and insert states.
`Backspace' and `Delete' don't cross line boundaries in insert.
@@ -678,14 +677,14 @@ If nil, the above commands can work across lines."
:type 'boolean
:group 'viper)
-(viper-deflocalvar viper-ESC-moves-cursor-back viper-ex-style-editing "")
+(defvar-local viper-ESC-moves-cursor-back viper-ex-style-editing "")
(defcustom viper-ESC-moves-cursor-back nil
"If t, ESC moves cursor back when changing from insert to vi state.
If nil, the cursor stays where it was when ESC was hit."
:type 'boolean
:group 'viper)
-(viper-deflocalvar viper-delete-backwards-in-replace nil "")
+(defvar-local viper-delete-backwards-in-replace nil "")
(defcustom viper-delete-backwards-in-replace nil
"If t, DEL key will delete characters while moving the cursor backwards.
If nil, the cursor will move backwards without deleting anything."
@@ -703,21 +702,21 @@ If nil, the cursor will move backwards without deleting anything."
:tag "Search Wraps Around"
:group 'viper-search)
-(viper-deflocalvar viper-related-files-and-buffers-ring nil "")
+(defvar-local viper-related-files-and-buffers-ring nil "")
(defcustom viper-related-files-and-buffers-ring nil
- "List of file and buffer names that are considered to be related to the current buffer.
+ "List of file and buffer names to consider related to the current buffer.
Related buffers can be cycled through via :R and :P commands."
:type 'boolean
:group 'viper-misc)
(put 'viper-related-files-and-buffers-ring 'permanent-local t)
;; Used to find out if we are done with searching the current buffer.
-(viper-deflocalvar viper-local-search-start-marker nil)
+(defvar-local viper-local-search-start-marker nil)
;; As above, but global
(defvar viper-search-start-marker (make-marker))
;; the search overlay
-(viper-deflocalvar viper-search-overlay nil)
+(defvar-local viper-search-overlay nil)
(defvar viper-heading-start
@@ -744,9 +743,9 @@ Related buffers can be cycled through via :R and :P commands."
;; inside the lines.
;; Remembers position of the last jump done using ``'.
-(viper-deflocalvar viper-last-jump nil)
+(defvar-local viper-last-jump nil)
;; Remembers position of the last jump done using `''.
-(viper-deflocalvar viper-last-jump-ignore 0)
+(defvar-local viper-last-jump-ignore 0)
;; History variables
@@ -840,7 +839,7 @@ to customize the actual face object `viper-minibuffer-vi'
this variable represents.")
;; the current face to be used in the minibuffer
-(viper-deflocalvar
+(defvar-local
viper-minibuffer-current-face viper-minibuffer-emacs-face "")
@@ -876,7 +875,7 @@ Should be set in `viper-custom-file-name'."
:group 'viper)
;; overlay used in the minibuffer to indicate which state it is in
-(viper-deflocalvar viper-minibuffer-overlay nil)
+(defvar-local viper-minibuffer-overlay nil)
(put 'viper-minibuffer-overlay 'permanent-local t)
;; Hook, specific to Viper, which is run just *before* exiting the minibuffer.
@@ -922,6 +921,8 @@ Should be set in `viper-custom-file-name'."
"Hooks run just after loading Viper."
:type 'hook
:group 'viper-hooks)
+(make-obsolete-variable 'viper-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defun viper-restore-cursor-type ()
(condition-case nil
@@ -943,9 +944,4 @@ on a dumb terminal."
(provide 'viper-init)
-
-;; Local Variables:
-;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;; End:
-
;;; viper-init.el ends here
diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el
index 431808fdecb..4a9070e84be 100644
--- a/lisp/emulation/viper-keym.el
+++ b/lisp/emulation/viper-keym.el
@@ -69,7 +69,7 @@ major mode in effect."
:group 'viper)
(defcustom viper-want-ctl-h-help nil
- "If non-nil, C-h gets bound to help-command; otherwise, C-h gets the usual Vi bindings."
+ "If non-nil, bind C-h to help-command; otherwise, C-h gets the usual Vi bindings."
:type 'boolean
:group 'viper)
@@ -82,7 +82,7 @@ major mode in effect."
(defvar viper-insert-intercept-map (make-sparse-keymap))
(defvar viper-emacs-intercept-map (make-sparse-keymap))
-(viper-deflocalvar viper-vi-local-user-map (make-sparse-keymap)
+(defvar-local viper-vi-local-user-map (make-sparse-keymap)
"Keymap for user-defined local bindings.
Useful for changing bindings such as ZZ in certain major modes.
For instance, in letter-mode, one may want to bind ZZ to
@@ -106,7 +106,7 @@ This map is global, shared by all buffers.")
This happens when viper-expert-level is 1 or 2. See viper-set-expert-level.")
-(viper-deflocalvar viper-insert-local-user-map (make-sparse-keymap)
+(defvar-local viper-insert-local-user-map (make-sparse-keymap)
"Auxiliary map for per-buffer user-defined keybindings in Insert state.")
(put 'viper-insert-local-user-map 'permanent-local t)
@@ -133,7 +133,7 @@ viper-insert-basic-map. Not recommended, except for novice users.")
(defvar viper-emacs-kbd-map (make-sparse-keymap)
"This keymap keeps Vi-style kbd macros for Emacs mode.")
-(viper-deflocalvar viper-emacs-local-user-map (make-sparse-keymap)
+(defvar-local viper-emacs-local-user-map (make-sparse-keymap)
"Auxiliary map for local user-defined bindings in Emacs state.")
(put 'viper-emacs-local-user-map 'permanent-local t)
@@ -155,36 +155,33 @@ In insert mode, this key also functions as Meta."
(let ((old-value (if (boundp 'viper-toggle-key)
viper-toggle-key
[(control ?z)])))
- (mapc
- (lambda (buf)
- (with-current-buffer buf
- (when (and (boundp 'viper-insert-basic-map)
- (keymapp viper-insert-basic-map))
- (when old-value
- (define-key viper-insert-basic-map old-value nil))
- (define-key viper-insert-basic-map value 'viper-escape-to-vi))
- (when (and (boundp 'viper-vi-intercept-map)
- (keymapp viper-vi-intercept-map))
- (when old-value
- (define-key viper-vi-intercept-map old-value nil))
- (define-key
- viper-vi-intercept-map value 'viper-toggle-key-action))
- (when (and (boundp 'viper-emacs-intercept-map)
- (keymapp viper-emacs-intercept-map))
- (define-key viper-emacs-intercept-map old-value nil)
- (define-key
- viper-emacs-intercept-map value 'viper-change-state-to-vi))
- ))
- (buffer-list))
- (set-default symbol value)
- )))
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (and (boundp 'viper-insert-basic-map)
+ (keymapp viper-insert-basic-map))
+ (when old-value
+ (define-key viper-insert-basic-map old-value nil))
+ (define-key viper-insert-basic-map value 'viper-escape-to-vi))
+ (when (and (boundp 'viper-vi-intercept-map)
+ (keymapp viper-vi-intercept-map))
+ (when old-value
+ (define-key viper-vi-intercept-map old-value nil))
+ (define-key
+ viper-vi-intercept-map value 'viper-toggle-key-action))
+ (when (and (boundp 'viper-emacs-intercept-map)
+ (keymapp viper-emacs-intercept-map))
+ (define-key viper-emacs-intercept-map old-value nil)
+ (define-key
+ viper-emacs-intercept-map value 'viper-change-state-to-vi))
+ ))
+ (set-default symbol value))))
(defcustom viper-quoted-insert-key "\C-v"
"The key used to quote special characters when inserting them in Insert state."
:type 'string
:group 'viper)
-(defconst viper-ESC-key [escape]
+(defconst viper-ESC-key (kbd "ESC")
"Key used to ESC.")
@@ -209,22 +206,22 @@ In insert mode, this key also functions as Meta."
(defvar viper-emacs-state-modifier-alist nil)
;; The list of viper keymaps. Set by viper-normalize-minor-mode-map-alist
-(viper-deflocalvar viper--key-maps nil)
-(viper-deflocalvar viper--intercept-key-maps nil)
+(defvar-local viper--key-maps nil)
+(defvar-local viper--intercept-key-maps nil)
;; Tells viper-add-local-keys to create a new viper-vi-local-user-map for new
;; buffers. Not a user option.
-(viper-deflocalvar viper-need-new-vi-local-map t "")
+(defvar-local viper-need-new-vi-local-map t "")
(put 'viper-need-new-vi-local-map 'permanent-local t)
;; Tells viper-add-local-keys to create a new viper-insert-local-user-map for
;; new buffers. Not a user option.
-(viper-deflocalvar viper-need-new-insert-local-map t "")
+(defvar-local viper-need-new-insert-local-map t "")
(put 'viper-need-new-insert-local-map 'permanent-local t)
;; Tells viper-add-local-keys to create a new viper-emacs-local-user-map for
;; new buffers. Not a user option.
-(viper-deflocalvar viper-need-new-emacs-local-map t "")
+(defvar-local viper-need-new-emacs-local-map t "")
(put 'viper-need-new-emacs-local-map 'permanent-local t)
@@ -257,7 +254,7 @@ In insert mode, this key also functions as Meta."
(let ((i ?\ ))
(while (<= i ?~)
- (define-key viper-insert-diehard-map (make-string 1 i) 'self-insert-command)
+ (define-key viper-insert-diehard-map (string i) #'self-insert-command)
(setq i (1+ i))))
;; Insert mode map when user wants emacs style
@@ -490,7 +487,7 @@ Useful in some modes, such as Gnus, MH, etc.")
The effect is seen in the current buffer only.
Useful for customizing mailer buffers, gnus, etc.
STATE is `vi-state', `insert-state', or `emacs-state'.
-ALIST is of the form ((key . func) (key . func) ...)
+ALIST is of the form ((KEY . FUNC) (KEY . FUNC) ...)
Normally, this would be called from a hook to a major mode or
on a per buffer basis.
Usage:
@@ -548,14 +545,11 @@ The above needs not to be done for major modes that come up in Vi or Insert
state by default.
Arguments: (major-mode viper-state keymap)"
- (let ((alist
- (cond ((eq state 'vi-state) 'viper-vi-state-modifier-alist)
- ((eq state 'insert-state) 'viper-insert-state-modifier-alist)
- ((eq state 'emacs-state) 'viper-emacs-state-modifier-alist)))
- elt)
- (if (setq elt (assoc mode (eval alist)))
- (set alist (delq elt (eval alist))))
- (set alist (cons (cons mode keymap) (eval alist)))
+ (let* ((alist
+ (cond ((eq state 'vi-state) 'viper-vi-state-modifier-alist)
+ ((eq state 'insert-state) 'viper-insert-state-modifier-alist)
+ ((eq state 'emacs-state) 'viper-emacs-state-modifier-alist))))
+ (setf (alist-get mode (symbol-value alist)) keymap)
;; Normalization usually doesn't help here, since one needs to
;; normalize in the actual buffer where changes to the keymap are
@@ -646,18 +640,12 @@ Arguments: (major-mode viper-state keymap)"
(cdr mapsrc)))
(defun viper-modify-keymap (map alist)
- "Modifies MAP with bindings specified in the ALIST. The alist has the
-form ((key . function) (key . function) ... )."
- (mapcar (lambda (p) (define-key map (eval (car p)) (cdr p)))
+ "Modifies MAP with bindings specified in the ALIST.
+The ALIST has the form ((KEY . FUNCTION) (KEY . FUNCTION) ... )."
+ (mapcar (lambda (p) (define-key map (eval (car p) t) (cdr p)))
alist))
(provide 'viper-keym)
-
-;; Local Variables:
-;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;; End:
-
-
;;; viper-keym.el ends here
diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el
index 039ddabcdc3..94ab8178925 100644
--- a/lisp/emulation/viper-macs.el
+++ b/lisp/emulation/viper-macs.el
@@ -24,8 +24,6 @@
;;; Code:
-(provide 'viper-macs)
-
;; compiler pacifier
(defvar viper-ex-work-buf)
(defvar viper-custom-file-name)
@@ -37,7 +35,7 @@
(require 'viper-util)
(require 'viper-keym)
-
+(require 'seq)
;;; Variables
@@ -102,9 +100,11 @@ a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g.,
;; if defining macro for insert, switch there for authentic WYSIWYG
(if ins (viper-change-state-to-insert))
(start-kbd-macro nil)
- (define-key viper-vi-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro)
- (define-key viper-insert-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro)
- (define-key viper-emacs-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro)
+ (define-key viper-vi-intercept-map "\C-x)" #'viper-end-mapping-kbd-macro)
+ (define-key viper-insert-intercept-map "\C-x)"
+ #'viper-end-mapping-kbd-macro)
+ (define-key viper-emacs-intercept-map "\C-x)"
+ #'viper-end-mapping-kbd-macro)
(message "Mapping %S in %s state. Type macro definition followed by `C-x )'"
(viper-display-macro macro-name)
(if ins "Insert" "Vi")))
@@ -442,7 +442,7 @@ If SCOPE is nil, the user is asked to specify the scope."
(list nil (list (cons scope nil)) (cons t nil)))
((stringp scope)
(list (list (cons scope nil)) nil (cons t nil))))))
- (setq old-elt (assoc macro-name (eval macro-alist-var)))
+ (setq old-elt (assoc macro-name (symbol-value macro-alist-var)))
(if (null old-elt)
(progn
@@ -450,8 +450,8 @@ If SCOPE is nil, the user is asked to specify the scope."
(define-key
keymap
(vector (viper-key-to-emacs-key (aref macro-name 0)))
- 'viper-exec-mapped-kbd-macro)
- (setq lis (eval macro-alist-var))
+ #'viper-exec-mapped-kbd-macro)
+ (setq lis (symbol-value macro-alist-var))
(while (and lis (string< (viper-array-to-string (car (car lis)))
(viper-array-to-string macro-name)))
(setq lis2 (cons (car lis) lis2))
@@ -514,7 +514,7 @@ mistakes in macro names to be passed to this function is to use
(if (viper-char-array-p macro-name)
(setq macro-name (viper-char-array-to-macro macro-name)))
- (setq macro-entry (assoc macro-name (eval macro-alist-var)))
+ (setq macro-entry (assoc macro-name (symbol-value macro-alist-var)))
(if (= (length macro-name) 0)
(error "Can't unmap an empty macro name"))
(if (null macro-entry)
@@ -557,9 +557,10 @@ mistakes in macro names to be passed to this function is to use
(cdr mode-mapping)
(cdr global-mapping)
(progn
- (set macro-alist-var (delq macro-entry (eval macro-alist-var)))
+ (set macro-alist-var (delq macro-entry
+ (symbol-value macro-alist-var)))
(if (viper-can-release-key (aref macro-name 0)
- (eval macro-alist-var))
+ (symbol-value macro-alist-var))
(define-key
keymap
(vector (viper-key-to-emacs-key (aref macro-name 0)))
@@ -649,11 +650,11 @@ mistakes in macro names to be passed to this function is to use
(interactive)
(with-output-to-temp-buffer " *viper-info*"
(princ "Macros in Vi state:\n===================\n")
- (mapc 'viper-describe-one-macro viper-vi-kbd-macro-alist)
+ (mapc #'viper-describe-one-macro viper-vi-kbd-macro-alist)
(princ "\n\nMacros in Insert and Replace states:\n====================================\n")
- (mapc 'viper-describe-one-macro viper-insert-kbd-macro-alist)
+ (mapc #'viper-describe-one-macro viper-insert-kbd-macro-alist)
(princ "\n\nMacros in Emacs state:\n======================\n")
- (mapcar 'viper-describe-one-macro viper-emacs-kbd-macro-alist)
+ (mapc #'viper-describe-one-macro viper-emacs-kbd-macro-alist)
))
(defun viper-describe-one-macro (macro)
@@ -661,11 +662,11 @@ mistakes in macro names to be passed to this function is to use
(viper-display-macro (car macro))))
(princ " ** Buffer-specific:")
(if (viper-kbd-buf-alist macro)
- (mapc 'viper-describe-one-macro-elt (viper-kbd-buf-alist macro))
+ (mapc #'viper-describe-one-macro-elt (viper-kbd-buf-alist macro))
(princ " none\n"))
(princ "\n ** Mode-specific:")
(if (viper-kbd-mode-alist macro)
- (mapc 'viper-describe-one-macro-elt (viper-kbd-mode-alist macro))
+ (mapc #'viper-describe-one-macro-elt (viper-kbd-mode-alist macro))
(princ " none\n"))
(princ "\n ** Global:")
(if (viper-kbd-global-definition macro)
@@ -683,10 +684,9 @@ mistakes in macro names to be passed to this function is to use
;; check if SEQ is a prefix of some car of an element in ALIST
(defun viper-keyseq-is-a-possible-macro (seq alist)
(let ((converted-seq (viper-events-to-macro seq)))
- (eval (cons 'or
- (mapcar
- (lambda (elt) (viper-prefix-subseq-p converted-seq elt))
- (viper-this-buffer-macros alist))))))
+ (seq-some
+ (lambda (elt) (viper-prefix-subseq-p converted-seq elt))
+ (viper-this-buffer-macros alist))))
;; whether SEQ1 is a prefix of SEQ2
(defun viper-prefix-subseq-p (seq1 seq2)
@@ -704,11 +704,10 @@ mistakes in macro names to be passed to this function is to use
len)
(if (= (length seqs) 0)
(setq len 0)
- (setq len (apply 'min (mapcar 'length seqs))))
+ (setq len (apply #'min (mapcar #'length seqs))))
(while (< idx len)
- (if (eval (cons 'and
- (mapcar (lambda (s) (equal (elt first idx) (elt s idx)))
- rest)))
+ (if (seq-every-p (lambda (s) (equal (elt first idx) (elt s idx)))
+ rest)
(setq pref (vconcat pref (vector (elt first idx)))))
(setq idx (1+ idx)))
pref))
@@ -720,7 +719,7 @@ mistakes in macro names to be passed to this function is to use
(defun viper-do-sequence-completion (seq alist compl-message)
(let* ((matches (viper-extract-matching-alist-members seq alist))
- (new-seq (apply 'viper-common-seq-prefix matches))
+ (new-seq (apply #'viper-common-seq-prefix matches))
)
(cond ((and (equal seq new-seq) (= (length matches) 1))
(message "%s (Sole completion)" compl-message)
@@ -741,8 +740,8 @@ mistakes in macro names to be passed to this function is to use
(defun viper-display-vector-completions (list)
(with-output-to-temp-buffer "*Completions*"
(display-completion-list
- (mapcar 'prin1-to-string
- (mapcar 'viper-display-macro list)))))
+ (mapcar #'prin1-to-string
+ (mapcar #'viper-display-macro list)))))
@@ -793,9 +792,9 @@ mistakes in macro names to be passed to this function is to use
;; string--do so. Otherwise, do nothing.
(defun viper-display-macro (macro-name-or-body)
(cond ((viper-char-symbol-sequence-p macro-name-or-body)
- (mapconcat 'symbol-name macro-name-or-body ""))
+ (mapconcat #'symbol-name macro-name-or-body ""))
((viper-char-array-p macro-name-or-body)
- (mapconcat 'char-to-string macro-name-or-body ""))
+ (mapconcat #'char-to-string macro-name-or-body ""))
(t macro-name-or-body)))
;; convert sequence of events (that came presumably from emacs kbd macro) into
@@ -815,7 +814,7 @@ mistakes in macro names to be passed to this function is to use
;; convert strings or arrays of characters to Viper macro form
(defun viper-char-array-to-macro (array)
- (vconcat (mapcar 'viper-event-key (vconcat array))))
+ (vconcat (mapcar #'viper-event-key (vconcat array))))
;; For macros bodies and names, goes over MACRO and checks if all members are
;; names of keys (actually, it only checks if they are symbols or lists
@@ -850,7 +849,7 @@ mistakes in macro names to be passed to this function is to use
macro)))
(defun viper-macro-to-events (macro-body)
- (vconcat (mapcar 'viper-key-to-emacs-key macro-body)))
+ (vconcat (mapcar #'viper-key-to-emacs-key macro-body)))
@@ -929,5 +928,5 @@ mistakes in macro names to be passed to this function is to use
(beginning-of-line)
(call-last-kbd-macro)))
-
+(provide 'viper-macs)
;;; viper-macs.el ends here
diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el
index 56893d7ffb8..83fc5afafa5 100644
--- a/lisp/emulation/viper-mous.el
+++ b/lisp/emulation/viper-mous.el
@@ -1,4 +1,4 @@
-;;; viper-mous.el --- mouse support for Viper
+;;; viper-mous.el --- mouse support for Viper -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1997, 2001-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Code:
-(provide 'viper-mous)
-
;; compiler pacifier
(defvar double-click-time)
(defvar mouse-track-multi-click-time)
@@ -60,31 +58,22 @@
Takes two parameters: a COUNT, indicating how many words to return,
and CLICK-COUNT, telling whether this is the first click, a double-click,
or a triple-click."
- :type 'symbol
- :group 'viper-mouse)
+ :type 'symbol)
;; time interval in millisecond within which successive clicks are
;; considered related
(defcustom viper-multiclick-timeout (if (viper-window-display-p)
- (if (featurep 'xemacs)
- mouse-track-multi-click-time
- double-click-time)
+ double-click-time
500)
"Time interval in millisecond within which successive mouse clicks are
considered related."
- :type 'integer
- :group 'viper-mouse)
-
-;; current event click count; XEmacs only
-(defvar viper-current-click-count 0)
-;; time stamp of the last click event; XEmacs only
-(defvar viper-last-click-event-timestamp 0)
+ :type 'integer)
;; Local variable used to toggle wraparound search on click.
-(viper-deflocalvar viper-mouse-click-search-noerror t)
+(defvar-local viper-mouse-click-search-noerror t)
;; Local variable used to delimit search after wraparound.
-(viper-deflocalvar viper-mouse-click-search-limit nil)
+(defvar-local viper-mouse-click-search-limit nil)
;; remembers prefix argument to pass along to commands invoked by second
;; click.
@@ -105,7 +94,7 @@ considered related."
;;; Code
(defsubst viper-multiclick-p ()
- (not (viper-sit-for-short viper-multiclick-timeout t)))
+ (not (sit-for (/ viper-multiclick-timeout 1000.0) t)))
;; Returns window where click occurs
(defun viper-mouse-click-window (click)
@@ -279,11 +268,9 @@ See `viper-surrounding-word' for the definition of a word in this case."
(setq interrupting-event (read-event))
(viper-mouse-event-p last-input-event)))
(progn ; interrupted wait
- (setq viper-global-prefix-argument arg)
- ;; count this click for XEmacs
- (viper-event-click-count click))
+ (setq viper-global-prefix-argument arg))
;; uninterrupted wait or the interrupting event wasn't a mouse event
- (setq click-count (viper-event-click-count click))
+ (setq click-count (event-click-count click))
(if (> click-count 1)
(setq arg viper-global-prefix-argument
viper-global-prefix-argument nil))
@@ -300,33 +287,8 @@ See `viper-surrounding-word' for the definition of a word in this case."
(string-match "\\(mouse-\\|frame\\|screen\\|track\\)"
(prin1-to-string (viper-event-key event)))))
-;; XEmacs has no double-click events. So, we must simulate.
-;; So, we have to simulate event-click-count.
-(defun viper-event-click-count (click)
- (if (featurep 'xemacs) (viper-event-click-count-xemacs click)
- (event-click-count click)))
-
-(when (featurep 'xemacs)
-
- ;; kind of semaphore for updating viper-current-click-count
- (defvar viper-counting-clicks-p nil)
-
- (defun viper-event-click-count-xemacs (click)
- (let ((time-delta (- (event-timestamp click)
- viper-last-click-event-timestamp))
- inhibit-quit)
- (while viper-counting-clicks-p
- (ignore))
- (setq viper-counting-clicks-p t)
- (if (> time-delta viper-multiclick-timeout)
- (setq viper-current-click-count 0))
- (discard-input)
- (setq viper-current-click-count (1+ viper-current-click-count)
- viper-last-click-event-timestamp (event-timestamp click))
- (setq viper-counting-clicks-p nil)
- (if (viper-sit-for-short viper-multiclick-timeout t)
- viper-current-click-count
- 0))))
+(define-obsolete-function-alias 'viper-event-click-count
+ #'event-click-count "28.1")
(declare-function viper-forward-word "viper-cmd" (arg))
(declare-function viper-adjust-window "viper-cmd" ())
@@ -364,11 +326,9 @@ this command.
(setq viper-global-prefix-argument (or viper-global-prefix-argument
arg)
;; remember command that was before the multiclick
- this-command last-command)
- ;; make sure we counted this event---needed for XEmacs only
- (viper-event-click-count click))
+ this-command last-command))
;; uninterrupted wait
- (setq click-count (viper-event-click-count click))
+ (setq click-count (event-click-count click))
(setq click-word (viper-mouse-click-get-word click nil click-count))
(if (> click-count 1)
@@ -443,7 +403,7 @@ this command.
(setq arg (1- arg)))
))))
-(defun viper-mouse-catch-frame-switch (event arg)
+(defun viper-mouse-catch-frame-switch (_event arg)
"Catch the event of switching frame.
Usually is bound to a `down-mouse' event to work properly. See sample
bindings in the Viper manual."
@@ -472,8 +432,9 @@ bindings in the Viper manual."
;; until you do something other than viper-mouse-click-* command.
;; In XEmacs, you have to manually select frame B (with the mouse click) in
;; order to shift focus to frame B.
-(defsubst viper-remember-current-frame (frame)
- (setq last-command 'handle-switch-frame
+(defun viper-remember-current-frame (&rest _)
+ "Remember the selected frame before the switch-frame event."
+ (setq last-command #'handle-switch-frame
viper-current-frame-saved (selected-frame)))
@@ -482,8 +443,8 @@ bindings in the Viper manual."
;; Emacs. EVENT-TYPE is either `up' or `down'. Up returns button-up key; down
;; returns button-down key.
(defun viper-parse-mouse-key (key-var event-type)
- (let ((key (eval key-var))
- button-spec meta-spec shift-spec control-spec key-spec)
+ (let ((key (symbol-value key-var))
+ button-spec meta-spec shift-spec control-spec)
(if (null key)
;; just return nil
()
@@ -506,10 +467,9 @@ bindings in the Viper manual."
control-spec
(if (memq 'control key) "C-" ""))
- (setq key-spec
- (vector
- (intern (concat control-spec meta-spec
- shift-spec button-spec)))))))
+ (vector
+ (intern (concat control-spec meta-spec
+ shift-spec button-spec))))))
(defun viper-unbind-mouse-search-key ()
(if viper-mouse-up-search-key-parsed
@@ -533,8 +493,8 @@ bindings in the Viper manual."
(viper-parse-mouse-key 'viper-mouse-search-key 'up)
viper-mouse-down-search-key-parsed
(viper-parse-mouse-key 'viper-mouse-search-key 'down))
- (cond ((or (null viper-mouse-up-search-key-parsed)
- (null viper-mouse-down-search-key-parsed))
+ (cond ((not (and viper-mouse-up-search-key-parsed
+ viper-mouse-down-search-key-parsed))
nil) ; just quit
((and (null force)
(key-binding viper-mouse-up-search-key-parsed)
@@ -552,9 +512,9 @@ bindings in the Viper manual."
viper-mouse-down-search-key-parsed))
(t
(global-set-key viper-mouse-up-search-key-parsed
- 'viper-mouse-click-search-word)
+ #'viper-mouse-click-search-word)
(global-set-key viper-mouse-down-search-key-parsed
- 'viper-mouse-catch-frame-switch))))
+ #'viper-mouse-catch-frame-switch))))
;; If FORCE, bind even if this mouse action is already bound to something else
(defun viper-bind-mouse-insert-key (&optional force)
@@ -562,8 +522,8 @@ bindings in the Viper manual."
(viper-parse-mouse-key 'viper-mouse-insert-key 'up)
viper-mouse-down-insert-key-parsed
(viper-parse-mouse-key 'viper-mouse-insert-key 'down))
- (cond ((or (null viper-mouse-up-insert-key-parsed)
- (null viper-mouse-down-insert-key-parsed))
+ (cond ((not (and viper-mouse-up-insert-key-parsed
+ viper-mouse-down-insert-key-parsed))
nil) ; just quit
((and (null force)
(key-binding viper-mouse-up-insert-key-parsed)
@@ -581,9 +541,9 @@ bindings in the Viper manual."
viper-mouse-down-insert-key-parsed))
(t
(global-set-key viper-mouse-up-insert-key-parsed
- 'viper-mouse-click-insert-word)
+ #'viper-mouse-click-insert-word)
(global-set-key viper-mouse-down-insert-key-parsed
- 'viper-mouse-catch-frame-switch))))
+ #'viper-mouse-catch-frame-switch))))
(defun viper-reset-mouse-search-key (symb val)
(viper-unbind-mouse-search-key)
@@ -609,8 +569,7 @@ This buffer may be different from the one where the click occurred."
(const :format "%v " shift)
(const control))
(integer :tag "Button"))
- :set 'viper-reset-mouse-search-key
- :group 'viper-mouse)
+ :set #'viper-reset-mouse-search-key)
(defcustom viper-mouse-insert-key '(meta shift 2)
"Key used to click-insert in Viper.
@@ -625,14 +584,7 @@ This buffer may be different from the one where the click occurred."
(const :format "%v " shift)
(const control))
(integer :tag "Button"))
- :set 'viper-reset-mouse-insert-key
- :group 'viper-mouse)
-
-
-
-;; Local Variables:
-;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;; End:
-
+ :set #'viper-reset-mouse-insert-key)
+(provide 'viper-mous)
;;; viper-mous.el ends here
diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 9b79a8b5a38..51f7406ad26 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -24,8 +24,7 @@
;;; Code:
-(provide 'viper-util)
-
+(require 'seq)
;; Compiler pacifier
(defvar viper-minibuffer-current-face)
@@ -47,22 +46,22 @@
-(define-obsolete-function-alias 'viper-overlay-p 'overlayp "27.1")
-(define-obsolete-function-alias 'viper-make-overlay 'make-overlay "27.1")
-(define-obsolete-function-alias 'viper-overlay-live-p 'overlayp "27.1")
-(define-obsolete-function-alias 'viper-move-overlay 'move-overlay "27.1")
-(define-obsolete-function-alias 'viper-overlay-start 'overlay-start "27.1")
-(define-obsolete-function-alias 'viper-overlay-end 'overlay-end "27.1")
-(define-obsolete-function-alias 'viper-overlay-get 'overlay-get "27.1")
-(define-obsolete-function-alias 'viper-overlay-put 'overlay-put "27.1")
-(define-obsolete-function-alias 'viper-read-event 'read-event "27.1")
-(define-obsolete-function-alias 'viper-characterp 'integerp "27.1")
-(define-obsolete-function-alias 'viper-int-to-char 'identity "27.1")
-(define-obsolete-function-alias 'viper-get-face 'facep "27.1")
+(define-obsolete-function-alias 'viper-overlay-p #'overlayp "27.1")
+(define-obsolete-function-alias 'viper-make-overlay #'make-overlay "27.1")
+(define-obsolete-function-alias 'viper-overlay-live-p #'overlayp "27.1")
+(define-obsolete-function-alias 'viper-move-overlay #'move-overlay "27.1")
+(define-obsolete-function-alias 'viper-overlay-start #'overlay-start "27.1")
+(define-obsolete-function-alias 'viper-overlay-end #'overlay-end "27.1")
+(define-obsolete-function-alias 'viper-overlay-get #'overlay-get "27.1")
+(define-obsolete-function-alias 'viper-overlay-put #'overlay-put "27.1")
+(define-obsolete-function-alias 'viper-read-event #'read-event "27.1")
+(define-obsolete-function-alias 'viper-characterp #'integerp "27.1")
+(define-obsolete-function-alias 'viper-int-to-char #'identity "27.1")
+(define-obsolete-function-alias 'viper-get-face #'facep "27.1")
(define-obsolete-function-alias 'viper-color-defined-p
- 'x-color-defined-p "27.1")
+ #'x-color-defined-p "27.1")
(define-obsolete-function-alias 'viper-iconify
- 'iconify-or-deiconify-frame "27.1")
+ #'iconify-or-deiconify-frame "27.1")
;; CHAR is supposed to be a char or an integer (positive or negative)
@@ -205,6 +204,7 @@ Otherwise return the normal value."
;; incorrect. However, this gives correct result in our cases, since we are
;; testing for sufficiently high Emacs versions.
(defun viper-check-version (op major minor &optional type-of-emacs)
+ (declare (obsolete nil "28.1"))
(if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version))
(and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs))
((eq type-of-emacs 'emacs) (featurep 'emacs))
@@ -248,15 +248,7 @@ Otherwise return the normal value."
(goto-char cur-pos)
result))
-;; Emacs used to count each multibyte character as several positions in the buffer,
-;; so we had to use Emacs's chars-in-region to count characters. Since 20.3,
-;; Emacs counts multibyte characters as 1 position. XEmacs has always been
-;; counting each char as just one pos. So, now we can simply subtract beg from
-;; end to determine the number of characters in a region.
(defun viper-chars-in-region (beg end &optional preserve-sign)
- ;;(let ((count (abs (if (fboundp 'chars-in-region)
- ;; (chars-in-region beg end)
- ;; (- end beg)))))
(let ((count (abs (- end beg))))
(if (and (< end beg) preserve-sign)
(- count)
@@ -276,10 +268,10 @@ Otherwise return the normal value."
;; Then, each time this var is used in `viper-move-marker-locally' in a new
;; buffer, a new marker will be created.
(defun viper-move-marker-locally (var pos &optional buffer)
- (if (markerp (eval var))
+ (if (markerp (symbol-value var))
()
(set var (make-marker)))
- (move-marker (eval var) pos buffer))
+ (move-marker (symbol-value var) pos buffer))
;; Print CONDITIONS as a message.
@@ -287,7 +279,7 @@ Otherwise return the normal value."
(let ((case (car conditions)) (msg (cdr conditions)))
(if (null msg)
(message "%s" case)
- (message "%s: %s" case (mapconcat 'prin1-to-string msg " ")))
+ (message "%s: %s" case (mapconcat #'prin1-to-string msg " ")))
(beep 1)))
@@ -460,7 +452,7 @@ Otherwise return the normal value."
"$"))
tmp2))
(setq tmp (cdr tmp)))
- (reverse (apply 'append tmp2)))))
+ (reverse (apply #'append tmp2)))))
;;; Insertion ring
@@ -495,11 +487,11 @@ Otherwise return the normal value."
;; Push item onto ring. The second argument is a ring-variable, not value.
(defun viper-push-onto-ring (item ring-var)
- (or (ring-p (eval ring-var))
- (set ring-var (make-ring (eval (intern (format "%S-size" ring-var))))))
+ (or (ring-p (symbol-value ring-var))
+ (set ring-var (make-ring (symbol-value (intern (format "%S-size" ring-var))))))
(or (null item) ; don't push nil
(and (stringp item) (string= item "")) ; or empty strings
- (equal item (viper-current-ring-item (eval ring-var))) ; or old stuff
+ (equal item (viper-current-ring-item (symbol-value ring-var))) ; or old stuff
;; Since viper-set-destructive-command checks if we are inside
;; viper-repeat, we don't check whether this-command-keys is a `.'. The
;; cmd viper-repeat makes a call to the current function only if `.' is
@@ -512,7 +504,7 @@ Otherwise return the normal value."
(and (eq ring-var 'viper-command-ring)
(string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)"
(viper-array-to-string (this-command-keys))))
- (viper-ring-insert (eval ring-var) item))
+ (viper-ring-insert (symbol-value ring-var) item))
)
@@ -602,8 +594,8 @@ Otherwise return the normal value."
;; Arguments: var message file &optional erase-message
(defun viper-save-setting (var message file &optional erase-msg)
(let* ((var-name (symbol-name var))
- (var-val (if (boundp var) (eval var)))
- (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name))
+ (var-val (if (boundp var) (symbol-value var)))
+ (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z0-9---_']*[ \t\n)]" var-name))
(buf (find-file-noselect (substitute-in-file-name file)))
)
(message "%s" (or message ""))
@@ -785,14 +777,11 @@ Otherwise return the normal value."
(defun viper-check-minibuffer-overlay ()
(if (overlayp viper-minibuffer-overlay)
(move-overlay
- viper-minibuffer-overlay
- (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
- (1+ (buffer-size)))
+ viper-minibuffer-overlay (minibuffer-prompt-end) (1+ (buffer-size)))
(setq viper-minibuffer-overlay
;; make overlay open-ended
(make-overlay
- (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1)
- (1+ (buffer-size))
+ (minibuffer-prompt-end) (1+ (buffer-size))
(current-buffer) nil 'rear-advance))))
@@ -805,11 +794,10 @@ Otherwise return the normal value."
;;; XEmacs compatibility
(define-obsolete-function-alias 'viper-abbreviate-file-name
- 'abbreviate-file-name "27.1")
+ #'abbreviate-file-name "27.1")
-;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg
-;; in sit-for, so this function smooths out the differences.
(defsubst viper-sit-for-short (val &optional nodisp)
+ (declare (obsolete nil "28.1"))
(sit-for (/ val 1000.0) nodisp))
;; EVENT may be a single event of a sequence of events
@@ -826,7 +814,7 @@ Otherwise return the normal value."
(with-current-buffer buf
(and (<= pos (point-max)) (<= (point-min) pos))))))
-(define-obsolete-function-alias 'viper-mark-marker 'mark-marker "27.1")
+(define-obsolete-function-alias 'viper-mark-marker #'mark-marker "27.1")
(defvar viper-saved-mark nil
"Where viper saves mark. This mark is resurrected by m^.")
@@ -842,9 +830,9 @@ Otherwise return the normal value."
;; highlighted due to Viper's pushing marks. So, we deactivate marks,
;; unless the user explicitly wants highlighting, e.g., by hitting ''
;; or ``
-(define-obsolete-function-alias 'viper-deactivate-mark 'deactivate-mark "27.1")
+(define-obsolete-function-alias 'viper-deactivate-mark #'deactivate-mark "27.1")
-(define-obsolete-function-alias 'viper-leave-region-active 'ignore "27.1")
+(define-obsolete-function-alias 'viper-leave-region-active #'ignore "27.1")
;; Check if arg is a valid character for register
;; TYPE is a list that can contain `letter', `Letter', and `digit'.
@@ -863,18 +851,17 @@ Otherwise return the normal value."
-(define-obsolete-function-alias 'viper-copy-event 'identity "27.1")
+(define-obsolete-function-alias 'viper-copy-event #'identity "27.1")
;; Uses different timeouts for ESC-sequences and others
(defun viper-fast-keysequence-p ()
- (not (viper-sit-for-short
- (if (viper-ESC-event-p last-input-event)
- (viper-ESC-keyseq-timeout)
- viper-fast-keyseq-timeout)
- t)))
+ (not (sit-for (/ (if (viper-ESC-event-p last-input-event)
+ (viper-ESC-keyseq-timeout)
+ viper-fast-keyseq-timeout) 1000.0)
+ t)))
(define-obsolete-function-alias 'viper-read-event-convert-to-char
- 'read-event "27.1")
+ #'read-event "27.1")
;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil)
@@ -919,6 +906,7 @@ Otherwise return the normal value."
basis)))
(defun viper-last-command-char ()
+ (declare (obsolete nil "28.1"))
last-command-event)
(defun viper-key-to-emacs-key (key)
@@ -952,20 +940,20 @@ Otherwise return the normal value."
(car (read-from-string
(concat
"?\\"
- (mapconcat 'identity mod-char-list "-\\")
+ (mapconcat #'identity mod-char-list "-\\")
"-"
base-key-name))))
(setq key-name
(intern
(concat
- (mapconcat 'identity mod-char-list "-")
+ (mapconcat #'identity mod-char-list "-")
"-"
base-key-name))))))
))
;; LIS is assumed to be a list of events of characters
-(define-obsolete-function-alias 'viper-eventify-list-xemacs 'ignore "27.1")
+(define-obsolete-function-alias 'viper-eventify-list-xemacs #'ignore "27.1")
;; Arg is a character, an event, a list of events or a sequence of
@@ -996,22 +984,20 @@ Otherwise return the normal value."
;; XEmacs only
(defun viper-event-vector-p (vec)
(and (vectorp vec)
- (eval (cons 'and (mapcar (lambda (elt) (if (eventp elt) t)) vec)))))
+ (seq-every-p (lambda (elt) (if (eventp elt) t)) vec)))
;; check if vec is a vector of character symbols
(defun viper-char-symbol-sequence-p (vec)
(and
(sequencep vec)
- (eval
- (cons 'and
- (mapcar (lambda (elt)
- (and (symbolp elt) (= (length (symbol-name elt)) 1)))
- vec)))))
+ (seq-every-p (lambda (elt)
+ (and (symbolp elt) (= (length (symbol-name elt)) 1)))
+ vec)))
(defun viper-char-array-p (array)
- (eval (cons 'and (mapcar 'characterp array))))
+ (seq-every-p #'characterp array))
;; Args can be a sequence of events, a string, or a Viper macro. Will try to
@@ -1023,19 +1009,19 @@ Otherwise return the normal value."
(let (temp temp2)
(cond ((stringp event-seq) event-seq)
((viper-event-vector-p event-seq)
- (setq temp (mapcar 'viper-event-key event-seq))
+ (setq temp (mapcar #'viper-event-key event-seq))
(cond ((viper-char-symbol-sequence-p temp)
- (mapconcat 'symbol-name temp ""))
+ (mapconcat #'symbol-name temp ""))
((and (viper-char-array-p
- (setq temp2 (mapcar 'viper-key-to-character temp))))
- (mapconcat 'char-to-string temp2 ""))
+ (setq temp2 (mapcar #'viper-key-to-character temp))))
+ (mapconcat #'char-to-string temp2 ""))
(t (prin1-to-string (vconcat temp)))))
((viper-char-symbol-sequence-p event-seq)
- (mapconcat 'symbol-name event-seq ""))
+ (mapconcat #'symbol-name event-seq ""))
((and (vectorp event-seq)
(viper-char-array-p
- (setq temp (mapcar 'viper-key-to-character event-seq))))
- (mapconcat 'char-to-string temp ""))
+ (setq temp (mapcar #'viper-key-to-character event-seq))))
+ (mapconcat #'char-to-string temp ""))
(t (prin1-to-string event-seq)))))
(defun viper-key-press-events-to-chars (events)
@@ -1096,10 +1082,10 @@ the `Local variables' section of a file."
;; These are characters that are not to be considered as parts of a word in
;; Viper.
;; Set each time state changes and at loading time
-(viper-deflocalvar viper-non-word-characters nil)
+(defvar-local viper-non-word-characters nil)
;; must be buffer-local
-(viper-deflocalvar viper-ALPHA-char-class "w"
+(defvar-local viper-ALPHA-char-class "w"
"String of syntax classes characterizing Viper's alphanumeric symbols.
In addition, the symbol `_' may be considered alphanumeric if
`viper-syntax-preference' is `strict-vi' or `reformed-vi'.")
@@ -1183,7 +1169,7 @@ syntax tables.
This option is appropriate if you like Emacs-style words."
:type '(radio (const strict-vi) (const reformed-vi)
(const extended) (const emacs))
- :set 'viper-set-syntax-preference
+ :set #'viper-set-syntax-preference
:group 'viper)
(make-variable-buffer-local 'viper-syntax-preference)
@@ -1386,10 +1372,5 @@ This option is appropriate if you like Emacs-style words."
(setq i (1+ i) start (1+ start)))
res))))))
-
-
-;; Local Variables:
-;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;; End:
-
+(provide 'viper-util)
;;; viper-util.el ends here
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index 5e2d2fba0c9..cce51174336 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -617,7 +617,7 @@ This startup message appears whenever you load Viper, unless you type `y' now."
;; This hook designed to enable Vi-style editing in comint-based modes."
(defun viper-comint-mode-hook ()
- (set (make-local-variable 'require-final-newline) nil)
+ (setq-local require-final-newline nil)
(setq viper-ex-style-editing nil
viper-ex-style-motion nil)
(viper-change-state-to-insert))
@@ -695,9 +695,6 @@ It also can't undo some Viper settings."
'mark-even-if-inactive viper-saved-non-viper-variables))
;; Ideally, we would like to be able to de-localize local variables
- (unless
- (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- (viper-delocalize-var 'minor-mode-map-alist))
(viper-delocalize-var 'require-final-newline)
;; deactivate all advices done by Viper.
@@ -705,11 +702,9 @@ It also can't undo some Viper settings."
(setq viper-mode nil)
- (when (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- (setq emulation-mode-map-alists
- (delq 'viper--intercept-key-maps
- (delq 'viper--key-maps emulation-mode-map-alists))
- ))
+ (setq emulation-mode-map-alists
+ (delq 'viper--intercept-key-maps
+ (delq 'viper--key-maps emulation-mode-map-alists)))
(viper-delocalize-var 'viper-vi-minibuffer-minor-mode)
(viper-delocalize-var 'viper-insert-minibuffer-minor-mode)
@@ -943,13 +938,11 @@ Two differences:
(setq viper-vi-state-cursor-color color-name)))
- (when (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- ;; needs to be as early as possible
- (add-to-ordered-list
- 'emulation-mode-map-alists 'viper--intercept-key-maps 100)
- ;; needs to be after cua-mode
- (add-to-ordered-list 'emulation-mode-map-alists 'viper--key-maps 500)
- )
+ ;; needs to be as early as possible
+ (add-to-ordered-list
+ 'emulation-mode-map-alists 'viper--intercept-key-maps 100)
+ ;; needs to be after cua-mode
+ (add-to-ordered-list 'emulation-mode-map-alists 'viper--key-maps 500)
;; Emacs shell, ange-ftp, and comint-based modes
(add-hook 'comint-mode-hook #'viper-comint-mode-hook) ; comint
@@ -1062,18 +1055,13 @@ This may be needed if the previous `:map' command terminated abnormally."
(viper--advice-add 'add-minor-mode :after
(lambda (&rest _)
"Run viper-normalize-minor-mode-map-alist after adding a minor mode."
- (viper-normalize-minor-mode-map-alist)
- (unless
- (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists))
- (setq-default minor-mode-map-alist minor-mode-map-alist))))
+ (viper-normalize-minor-mode-map-alist)))
;; catch frame switching event
(if (viper-window-display-p)
(viper--advice-add
'handle-switch-frame :before
- (lambda (&rest _)
- "Remember the selected frame before the switch-frame event."
- (viper-remember-current-frame (selected-frame)))))
+ #'viper-remember-current-frame))
) ; end viper-non-hook-settings
@@ -1201,7 +1189,7 @@ These two lines must come in the order given."))
;; The default viper-toggle-key is \C-z; for the novice, it suspends or
;; iconifies Emacs
-(define-key viper-vi-intercept-map viper-toggle-key 'viper-toggle-key-action)
+(define-key viper-vi-intercept-map viper-toggle-key #'viper-toggle-key-action)
(define-key
viper-emacs-intercept-map viper-toggle-key #'viper-change-state-to-vi)
@@ -1221,7 +1209,6 @@ These two lines must come in the order given."))
(viper-harness-minor-mode "outline")
(viper-harness-minor-mode "allout")
(viper-harness-minor-mode "xref")
- (viper-harness-minor-mode "lmenu")
(viper-harness-minor-mode "vc")
(viper-harness-minor-mode "ltx-math") ; LaTeX-math-mode in AUC-TeX, which
(viper-harness-minor-mode "latex") ; sits in one of these two files
@@ -1254,12 +1241,7 @@ These two lines must come in the order given."))
;; Without setting the default, new buffers that come up in emacs mode have
;; minor-mode-map-alist = nil, unless we call viper-change-state-*
(when (eq viper-current-state 'emacs-state)
- (viper-change-state-to-emacs)
- (unless
- (and (fboundp 'add-to-ordered-list)
- (boundp 'emulation-mode-map-alists))
- (setq-default minor-mode-map-alist minor-mode-map-alist))
- )
+ (viper-change-state-to-emacs))
(if (this-major-mode-requires-vi-state major-mode)
(viper-mode))
@@ -1272,9 +1254,4 @@ These two lines must come in the order given."))
(provide 'viper)
-
-;; Local Variables:
-;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
-;; End:
-
;;; viper.el ends here
diff --git a/lisp/epa-dired.el b/lisp/epa-dired.el
index 10c4053d783..8a4f8933bf8 100644
--- a/lisp/epa-dired.el
+++ b/lisp/epa-dired.el
@@ -1,4 +1,5 @@
;;; epa-dired.el --- the EasyPG Assistant, dired extension -*- lexical-binding: t -*-
+
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -29,48 +30,40 @@
(defun epa-dired-do-decrypt ()
"Decrypt marked files."
(interactive)
- (let ((file-list (dired-get-marked-files)))
- (while file-list
- (epa-decrypt-file (expand-file-name (car file-list)))
- (setq file-list (cdr file-list)))
- (revert-buffer)))
+ (dolist (file (dired-get-marked-files))
+ (epa-decrypt-file (expand-file-name file)))
+ (revert-buffer))
;;;###autoload
(defun epa-dired-do-verify ()
"Verify marked files."
(interactive)
- (let ((file-list (dired-get-marked-files)))
- (while file-list
- (epa-verify-file (expand-file-name (car file-list)))
- (setq file-list (cdr file-list)))))
+ (dolist (file (dired-get-marked-files))
+ (epa-verify-file (expand-file-name file))))
;;;###autoload
(defun epa-dired-do-sign ()
"Sign marked files."
(interactive)
- (let ((file-list (dired-get-marked-files)))
- (while file-list
- (epa-sign-file
- (expand-file-name (car file-list))
- (epa-select-keys (epg-make-context) "Select keys for signing.
+ (dolist (file (dired-get-marked-files))
+ (epa-sign-file
+ (expand-file-name file)
+ (epa-select-keys (epg-make-context) "Select keys for signing.
If no one is selected, default secret key is used. "
- nil t)
- (y-or-n-p "Make a detached signature? "))
- (setq file-list (cdr file-list)))
- (revert-buffer)))
+ nil t)
+ (y-or-n-p "Make a detached signature? ")))
+ (revert-buffer))
;;;###autoload
(defun epa-dired-do-encrypt ()
"Encrypt marked files."
(interactive)
- (let ((file-list (dired-get-marked-files)))
- (while file-list
- (epa-encrypt-file
- (expand-file-name (car file-list))
- (epa-select-keys (epg-make-context) "Select recipients for encryption.
-If no one is selected, symmetric encryption will be performed. "))
- (setq file-list (cdr file-list)))
- (revert-buffer)))
+ (dolist (file (dired-get-marked-files))
+ (epa-encrypt-file
+ (expand-file-name file)
+ (epa-select-keys (epg-make-context) "Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed. ")))
+ (revert-buffer))
(provide 'epa-dired)
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index c44a00b985b..33bf5adabe6 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -1,4 +1,5 @@
;;; epa-file.el --- the EasyPG Assistant, transparent file encryption -*- lexical-binding: t -*-
+
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -21,9 +22,13 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+;;; Dependencies
(require 'epa)
(require 'epa-hook)
+(eval-when-compile (require 'subr-x))
+
+;;; Options
(defcustom epa-file-cache-passphrase-for-symmetric-encryption nil
"If non-nil, cache passphrase for symmetric encryption.
@@ -40,26 +45,18 @@ Note that this option has no effect if you use GnuPG 2.0."
(defcustom epa-file-select-keys nil
"Control whether or not to pop up the key selection dialog.
-If t, always asks user to select recipients.
+If t, always ask 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
+If neither t nor nil, don'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)
-
-(eval-and-compile
- (if (fboundp 'encode-coding-string)
- (defalias 'epa-file--encode-coding-string 'encode-coding-string)
- (defalias 'epa-file--encode-coding-string 'identity)))
+;;; Other
-(eval-and-compile
- (if (fboundp 'decode-coding-string)
- (defalias 'epa-file--decode-coding-string 'decode-coding-string)
- (defalias 'epa-file--decode-coding-string 'identity)))
+(defvar epa-file-passphrase-alist nil)
(defun epa-file-passphrase-callback-function (context key-id file)
(if (and epa-file-cache-passphrase-for-symmetric-encryption
@@ -71,8 +68,8 @@ encryption is used."
(or (copy-sequence (cdr entry))
(progn
(unless entry
- (setq entry (list file)
- epa-file-passphrase-alist
+ (setq entry (list file))
+ (setq epa-file-passphrase-alist
(cons entry
epa-file-passphrase-alist)))
(setq passphrase (epa-passphrase-callback-function context
@@ -82,6 +79,8 @@ encryption is used."
passphrase))))
(epa-passphrase-callback-function context key-id file)))
+;;; File Handler
+
(defvar epa-inhibit nil
"Non-nil means don't try to decrypt .gpg files when operating on them.")
@@ -117,8 +116,17 @@ encryption is used."
(let ((error epa-file-error))
(save-window-excursion
(kill-buffer))
- (signal 'file-missing
- (cons "Opening input file" (cdr error)))))
+ (if (nth 3 error)
+ (user-error "Wrong passphrase: %s" (nth 3 error))
+ (signal 'file-missing
+ (cons "Opening input file" (cdr error))))))
+
+(defun epa--wrong-password-p (context)
+ (let ((error-string (epg-context-error-output context)))
+ (and (string-match
+ "decryption failed: \\(Bad session key\\|No secret key\\)"
+ error-string)
+ (match-string 1 error-string))))
(defvar last-coding-system-used)
(defun epa-file-insert-file-contents (file &optional visit beg end replace)
@@ -161,15 +169,28 @@ encryption is used."
(nth 3 error)))
(let ((exists (file-exists-p local-file)))
(when exists
- ;; 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'.
- (setq-local epa-file-error error)
- (add-hook 'find-file-not-found-functions
- 'epa-file--find-file-not-found-function
- nil t)
- (epa-display-error context))
+ (if-let ((wrong-password (epa--wrong-password-p context)))
+ ;; Don't display the *error* buffer if we just
+ ;; have a wrong password; let the later error
+ ;; handler notify the user.
+ (setq error (append error (list wrong-password)))
+ (epa-display-error context))
+ ;; When the .gpg file isn't an encrypted file (e.g.,
+ ;; it's a keyring.gpg file instead), then gpg will
+ ;; say "Unexpected exit" as the error message. In
+ ;; that case, just display the bytes.
+ (if (equal (caddr error) "Unexpected; Exit")
+ (setq string (with-temp-buffer
+ (insert-file-contents-literally local-file)
+ (buffer-string)))
+ ;; 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'.
+ (setq-local epa-file-error error)
+ (add-hook 'find-file-not-found-functions
+ 'epa-file--find-file-not-found-function
+ nil t)))
(signal (if exists 'file-error 'file-missing)
(cons "Opening input file" (cdr error))))))
(set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)!
@@ -177,7 +198,9 @@ encryption is used."
(mapcar #'car (epg-context-result-for
context 'encrypted-to)))
(if (or beg end)
- (setq string (substring string (or beg 0) end)))
+ (setq string (substring string
+ (or beg 0)
+ (and end (min end (length string))))))
(save-excursion
;; If visiting, bind off buffer-file-name so that
;; file-locking will not ask whether we should
@@ -236,11 +259,7 @@ encryption is used."
(setq file (expand-file-name file))
(let* ((coding-system (or coding-system-for-write
(if (fboundp 'select-safe-coding-system)
- ;; This is needed since Emacs 22 has
- ;; no-conversion setting for *.gpg in
- ;; `auto-coding-alist'.
- (let ((buffer-file-name
- (file-name-sans-extension file)))
+ (let ((buffer-file-name file))
(select-safe-coding-system
(point-min) (point-max)))
buffer-file-coding-system)))
@@ -266,7 +285,7 @@ encryption is used."
(epg-encrypt-string
context
(if (stringp start)
- (epa-file--encode-coding-string start coding-system)
+ (encode-coding-string start coding-system)
(unless start
(setq start (point-min)
end (point-max)))
@@ -280,8 +299,8 @@ encryption is used."
;; decrypted contents.
(format-encode-buffer (with-current-buffer buffer
buffer-file-format))
- (epa-file--encode-coding-string (buffer-string)
- coding-system)))
+ (encode-coding-string (buffer-string)
+ coding-system)))
(if (or (eq epa-file-select-keys t)
(and (null epa-file-select-keys)
(not (local-variable-p 'epa-file-encrypt-to
@@ -292,7 +311,8 @@ encryption is used."
If no one is selected, symmetric encryption will be performed. "
recipients)
(if epa-file-encrypt-to
- (epg-list-keys context recipients)))))
+ (epg--filter-revoked-keys
+ (epg-list-keys context recipients))))))
(error
(epa-display-error context)
(if (setq entry (assoc file epa-file-passphrase-alist))
@@ -317,6 +337,8 @@ If no one is selected, symmetric encryption will be performed. "
(message "Wrote %s" buffer-file-name))))
(put 'write-region 'epa-file 'epa-file-write-region)
+;;; Commands
+
(defun epa-file-select-keys ()
"Select recipients for encryption."
(interactive)
diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el
index 9480c868cde..9ad952c6813 100644
--- a/lisp/epa-hook.el
+++ b/lisp/epa-hook.el
@@ -1,4 +1,5 @@
;;; epa-hook.el --- preloaded code to enable epa-file.el -*- lexical-binding: t -*-
+
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -35,10 +36,10 @@
(defcustom epa-file-name-regexp (purecopy "\\.gpg\\(~\\|\\.~[0-9]+~\\)?\\'")
"Regexp which matches filenames to be encrypted with GnuPG.
-If you set this outside Custom while epa-file is already enabled, you
-have to call `epa-file-name-regexp-update' after setting it to
-properly update file-name-handler-alist. Setting this through Custom
-does that automatically."
+If you set this outside Custom while epa-file is already enabled,
+you have to call `epa-file-name-regexp-update' after setting it
+to properly update `file-name-handler-alist'. Setting this
+through Custom does that automatically."
:type 'regexp
:group 'epa-file
:set 'epa-file--file-name-regexp-set)
@@ -72,6 +73,9 @@ May either be a string or a list of strings.")
(list epa-file-name-regexp nil 'epa-file))
(defun epa-file-name-regexp-update ()
+ "Update `file-name-handler-alist' after configuring outside Custom.
+After setting `epa-file-name-regexp-update' outside the Custom
+interface, update `file-name-handler-alist'."
(interactive)
(unless (equal (car epa-file-handler) epa-file-name-regexp)
(setcar epa-file-handler epa-file-name-regexp)))
diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el
new file mode 100644
index 00000000000..ebdb1274218
--- /dev/null
+++ b/lisp/epa-ks.el
@@ -0,0 +1,345 @@
+;;; epa-ks.el --- EasyPG Key Server Client -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Philip K. <philipk@posteo.net>
+;; Keywords: PGP, GnuPG
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Keyserver client in Emacs.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'epa)
+(require 'subr-x)
+(require 'tabulated-list)
+(require 'url)
+(require 'url-http)
+
+(defgroup epa-ks nil
+ "The EasyPG Assistant Keyserver client."
+ :version "28.1"
+ :group 'epa)
+
+(defcustom epa-keyserver "pgp.mit.edu"
+ "Domain of keyserver.
+
+This is used by `epa-ks-lookup-key', for looking up public keys."
+ :type '(choice :tag "Keyserver"
+ (repeat :tag "Random pool"
+ (string :tag "Keyserver address"))
+ (const "keyring.debian.org")
+ (const "keys.gnupg.net")
+ (const "keyserver.ubuntu.com")
+ (const "pgp.mit.edu")
+ (const "pool.sks-keyservers.net")
+ (const "zimmermann.mayfirst.org")
+ (string :tag "Custom keyserver"))
+ :version "28.1")
+
+(cl-defstruct epa-ks-key
+ "Structure to hold key data."
+ id algo len created expires names flags)
+
+(cl-defstruct epa-ks-name
+ "Structure to hold user associated with keys data."
+ uid created expires flags)
+
+(defvar epa-ks-last-query nil
+ "List of arguments to pass to `epa-search-keys'.
+This is used when reverting a buffer to restart search.")
+
+(defvar epa-ks-search-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map (kbd "f") #'epa-ks-mark-key-to-fetch)
+ (define-key map (kbd "i") #'epa-ks-inspect-key-to-fetch)
+ (define-key map (kbd "u") #'epa-ks-unmark-key-to-fetch)
+ (define-key map (kbd "x") #'epa-ks-do-key-to-fetch)
+ map))
+
+(define-derived-mode epa-ks-search-mode tabulated-list-mode "Keyserver"
+ "Major mode for listing public key search results."
+ (buffer-disable-undo)
+ (setq tabulated-list-format [("ID" 8 t)
+ ("Algo." 5 nil)
+ ("Created" 10 t)
+ ("Expires" 10 t)
+ ("User" 0 t)]
+ tabulated-list-sort-key '("User" . nil)
+ tabulated-list-padding 2)
+ (add-hook 'tabulated-list-revert-hook
+ #'epa-ks--restart-search
+ nil t)
+ (tabulated-list-init-header))
+
+(defun epa-ks-inspect-key-to-fetch ()
+ "Display full ID of key under point in the minibuffer."
+ (interactive)
+ (message "Full ID: %s" (epa-ks-key-id (car (tabulated-list-get-id)))))
+
+(defun epa-ks-unmark-key-to-fetch ()
+ "Remove fetch mark for key under point.
+
+If a region is active, unmark all keys in active region."
+ (interactive)
+ (epa-ks-mark-key-to-fetch ""))
+
+(defun epa-ks-mark-key-to-fetch (tag)
+ "Add fetch-mark to key under point.
+
+If a region is active, mark all keys in active region.
+
+When all keys have been selected, use \\[epa-ks-do-key-to-fetch] to
+actually import the keys.
+
+When called interactively, `epa-ks-mark-key-to-fetch' will always
+add a \"F\" tag. Non-interactivly the tag must be specified by
+setting the TAG parameter."
+ (interactive (list "F"))
+ (if (region-active-p)
+ (save-mark-and-excursion
+ (save-restriction
+ (narrow-to-region (region-beginning) (1- (region-end)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (tabulated-list-put-tag tag t))))
+ (tabulated-list-put-tag tag t)))
+
+(defun epa-ks-do-key-to-fetch ()
+ "Fetch all marked keys from keyserver and import them.
+
+Keys are marked using `epa-ks-mark-key-to-fetch'."
+ (interactive)
+ (save-excursion
+ (let (keys)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (looking-at-p (rx bol "F"))
+ (push (epa-ks-key-id (car (tabulated-list-get-id)))
+ keys))
+ (forward-line))
+ (when (yes-or-no-p (format "Proceed with fetching all %d key(s)? "
+ (length keys))))
+ (dolist (id keys)
+ (epa-ks--fetch-key id))))
+ (tabulated-list-clear-all-tags))
+
+(defun epa-ks--query-url (query exact)
+ "Return URL for QUERY.
+If EXACT is non-nil, don't accept approximate matches."
+ (format "https://%s/pks/lookup?%s"
+ (cond ((null epa-keyserver)
+ (user-error "Empty keyserver pool"))
+ ((listp epa-keyserver)
+ (nth (random (length epa-keyserver))
+ epa-keyserver))
+ ((stringp epa-keyserver)
+ epa-keyserver)
+ ((error "Invalid type for `epa-keyserver'")))
+ (url-build-query-string
+ (append `(("search" ,query)
+ ("options" "mr")
+ ("op" "index"))
+ (and exact '(("exact" "on")))))))
+
+(defun epa-ks--fetch-key (id)
+ "Send request to import key with specified ID."
+ (url-retrieve
+ (epa-ks--query-url (concat "0x" (url-hexify-string id)) t)
+ (lambda (status)
+ (when (plist-get status :error)
+ (error "Request failed: %s"
+ (caddr (assq (caddr (plist-get status :error))
+ url-http-codes))))
+ (forward-paragraph)
+ (save-excursion
+ (goto-char (point-max))
+ (while (memq (char-before) '(?\s ?\t ?\n))
+ (forward-char -1))
+ (delete-region (point) (point-max)))
+ (let ((epa-popup-info-window nil))
+ (epa-import-armor-in-region (point) (point-max)))
+ (kill-buffer))))
+
+(defun epa-ks--display-keys (buf keys)
+ "Prepare KEYS for `tabulated-list-mode', for buffer BUF.
+
+KEYS is a list of `epa-ks-key' structures, as parsed by
+`epa-ks-parse-result'."
+ (when (buffer-live-p buf)
+ (let (entries)
+ (dolist (key keys)
+ (dolist (name (epa-ks-key-names key))
+ (push (list (cons key name)
+ (vector
+ (substring (epa-ks-key-id key) -8)
+ (cdr (epa-ks-key-algo key))
+ (if (epa-ks-key-created key)
+ (format-time-string "%F" (epa-ks-key-created key))
+ "N/A")
+ (if (epa-ks-key-expires key)
+ (let* ((date (epa-ks-key-expires key))
+ (str (format-time-string "%F" date)))
+ (when (< 0 (time-to-seconds (time-since date)))
+ (setq str (propertize str 'face
+ 'font-lock-warning-face)))
+ str)
+ (propertize "N/A" 'face 'shadow))
+ (decode-coding-string
+ (epa-ks-name-uid name)
+ (select-safe-coding-system (epa-ks-name-uid name)
+ nil 'utf-8))))
+ entries)))
+ (with-current-buffer buf
+ (setq tabulated-list-entries entries)
+ (tabulated-list-print t t))
+ (message "Press `f' to mark a key, `x' to fetch all marked keys."))))
+
+(defun epa-ks--restart-search ()
+ (when epa-ks-last-query
+ (apply #'epa-search-keys epa-ks-last-query)))
+
+;;;###autoload
+(defun epa-search-keys (query exact)
+ "Ask a keyserver for all keys matching QUERY.
+
+The keyserver to be used is specified by `epa-keyserver'.
+
+If EXACT is non-nil (interactively, prefix argument), require
+exact matches.
+
+Note that the request may fail if the query is not specific
+enough, since keyservers have strict timeout settings."
+ (interactive (list (read-string "Search for: ")
+ current-prefix-arg))
+ (when (string-empty-p query)
+ (user-error "No query"))
+ (let ((buf (get-buffer-create "*Key search*")))
+ (with-current-buffer buf
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (epa-ks-search-mode))
+ (url-retrieve
+ (epa-ks--query-url query exact)
+ (lambda (status)
+ (when (plist-get status :error)
+ (when buf
+ (kill-buffer buf))
+ (error "Request failed: %s"
+ (caddr (assq (caddr (plist-get status :error))
+ url-http-codes))))
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (goto-char (point-min))
+ (re-search-forward "\n\n")
+ (let (keys)
+ (save-match-data
+ (setq keys (epa-ks--parse-buffer))
+ (kill-buffer (current-buffer)))
+ (when buf
+ (epa-ks--display-keys buf keys) keys))))
+ (pop-to-buffer buf)
+ (setq epa-ks-last-query (list query exact)))
+ (message "Searching keys..."))
+
+(defun epa-ks--parse-buffer ()
+ ;; parse machine readable response according to
+ ;; https://tools.ietf.org/html/draft-shaw-openpgp-hkp-00#section-5.2
+ (when (looking-at (rx bol "info:" (group (+ digit))
+ ":" (* digit) eol))
+ (unless (string= (match-string 1) "1")
+ (error "Unsupported keyserver version")))
+ (forward-line 1)
+ (let (key keys)
+ (while (and (not (eobp))
+ (not (looking-at "[ \t]*\n")))
+ (cond
+ ((looking-at (rx bol "pub:" (group (+ alnum))
+ ":" (group (* digit))
+ ":" (group (* digit))
+ ":" (group (* digit))
+ ":" (group (* digit))
+ ":" (group (* (any ?r ?d ?e)))
+ eol))
+ (setq key
+ (make-epa-ks-key
+ :id (match-string 1)
+ :algo
+ (and (match-string 2)
+ (not (string-empty-p (match-string 2)))
+ (assoc (string-to-number (match-string 2))
+ epg-pubkey-algorithm-alist))
+ :len
+ (and (match-string 3)
+ (not (string-empty-p (match-string 3)))
+ (string-to-number (match-string 3)))
+ :created
+ (and (match-string 4)
+ (not (string-empty-p (match-string 4)))
+ (seconds-to-time
+ (string-to-number (match-string 4))))
+ :expires
+ (and (match-string 5)
+ (not (string-empty-p (match-string 5)))
+ (seconds-to-time
+ (string-to-number (match-string 5))))
+ :flags
+ (mapcar (lambda (flag)
+ (cdr (assq flag '((?r revoked)
+ (?d disabled)
+ (?e expired)))))
+ (match-string 6))))
+ (push key keys))
+ ((looking-at (rx bol "uid:" (group (+ (not ":")))
+ ":" (group (* digit))
+ ":" (group (* digit))
+ ":" (group (* (any ?r ?d ?e)))
+ eol))
+ (push (make-epa-ks-name
+ :uid (url-unhex-string (match-string 1) t)
+ :created
+ (and (match-string 2)
+ (not (string-empty-p (match-string 2)))
+ (decode-time (seconds-to-time
+ (string-to-number
+ (match-string 2)))))
+ :expires
+ (and (match-string 3)
+ (not (string-empty-p (match-string 3)))
+ (decode-time (seconds-to-time
+ (string-to-number
+ (match-string 3)))))
+ :flags
+ (mapcar (lambda (flag)
+ (cdr (assq flag '((?r revoked)
+ (?d disabled)
+ (?e expired)))))
+ (match-string 4)))
+ (epa-ks-key-names key)))
+ ((looking-at-p (rx bol "uat:"))
+ ;; user attribute fields are ignored
+ nil)
+ (t (error "Invalid server response")))
+ (forward-line))
+ keys))
+
+;;; epa-ks.el ends here
diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el
index 260911d0be3..bed0c065aea 100644
--- a/lisp/epa-mail.el
+++ b/lisp/epa-mail.el
@@ -1,4 +1,5 @@
;;; epa-mail.el --- the EasyPG Assistant, minor-mode for mail composer -*- lexical-binding: t -*-
+
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -21,10 +22,13 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+;;; Dependencies
(require 'epa)
(require 'mail-utils)
+;;; Local Mode
+
(defvar epa-mail-mode-map
(let ((keymap (make-sparse-keymap)))
(define-key keymap "\C-c\C-ed" 'epa-mail-decrypt)
@@ -45,10 +49,19 @@
(defvar epa-mail-mode-on-hook nil)
(defvar epa-mail-mode-off-hook nil)
+(defcustom epa-mail-offer-skip t
+ "If non-nil, when a recipient has no key, ask whether to skip it.
+Otherwise, signal an error."
+ :type 'boolean
+ :version "28.1"
+ :group 'epa-mail)
+
;;;###autoload
(define-minor-mode epa-mail-mode
"A minor-mode for composing encrypted/clearsigned mails."
- nil " epa-mail" epa-mail-mode-map)
+ :lighter " epa-mail")
+
+;;; Utilities
(defun epa-mail--find-usable-key (keys usage)
"Find a usable key from KEYS for USAGE.
@@ -64,6 +77,8 @@ USAGE would be `sign' or `encrypt'."
(setq pointer (cdr pointer))))
(setq keys (cdr keys)))))
+;;; Commands
+
;;;###autoload
(defun epa-mail-decrypt ()
"Decrypt OpenPGP armors in the current buffer.
@@ -93,8 +108,9 @@ use from your key ring."
(interactive
(save-excursion
(goto-char (point-min))
- (if (search-forward mail-header-separator nil t)
- (forward-line))
+ (rfc822-goto-eoh)
+ (unless (eobp)
+ (forward-line))
(setq epa-last-coding-system-specified
(or coding-system-for-write
(select-safe-coding-system (point) (point-max))))
@@ -120,9 +136,7 @@ If no one is selected, default secret key is used. "
(goto-char (point-min))
(save-restriction
(narrow-to-region (point)
- (if (search-forward mail-header-separator nil 0)
- (match-beginning 0)
- (point)))
+ (progn (rfc822-goto-eoh) (point)))
(setq recipients-string
(mapconcat #'identity
(nconc (mail-fetch-field "to" nil nil t)
@@ -155,7 +169,7 @@ If no one is selected, default secret key is used. "
(apply #'nconc
(mapcar
(lambda (recipient)
- (let ((tem (assoc recipient epa-mail-aliases)))
+ (let ((tem (assoc (downcase recipient) epa-mail-aliases)))
(if tem (copy-sequence (cdr tem))
(list recipient))))
real-recipients)))
@@ -210,23 +224,31 @@ If no one is selected, symmetric encryption will be performed. "
recipient))
'encrypt)))
(unless (or recipient-key
- (y-or-n-p
- (format
- "No public key for %s; skip it? "
- recipient)))
+ (and epa-mail-offer-skip
+ (y-or-n-p
+ (format
+ "No public key for %s; skip it? "
+ recipient)))
+ )
(error "No public key for %s" recipient))
(if recipient-key (list recipient-key))))
default-recipients)))))
(goto-char (point-min))
- (if (search-forward mail-header-separator nil t)
- (forward-line))
+ (rfc822-goto-eoh)
+ (unless (eobp)
+ (forward-line))
(setq start (point))
(setq epa-last-coding-system-specified
(or coding-system-for-write
(select-safe-coding-system (point) (point-max)))))
+ ;; Insert contents of requested attachments, if any.
+ (when (and (eq major-mode 'mail-mode) mail-encode-mml)
+ (mml-to-mime)
+ (setq mail-encode-mml nil))
+
;; Don't let some read-only text stop us from encrypting.
(let ((inhibit-read-only t))
(with-suppressed-warnings ((interactive-only epa-encrypt-region))
@@ -241,6 +263,8 @@ The buffer is expected to contain a mail message."
(interactive)
(epa-import-armor-in-region (point-min) (point-max)))
+;;; Global Mode
+
;;;###autoload
(define-minor-mode epa-global-mail-mode
"Minor mode to hook EasyPG into Mail mode."
diff --git a/lisp/epa.el b/lisp/epa.el
index e584a53a118..2698b39ffe3 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -21,13 +21,14 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+;;; Dependencies
(require 'epg)
-(require 'font-lock)
-(require 'widget)
-(eval-when-compile (require 'wid-edit))
+(eval-when-compile (require 'subr-x))
(require 'derived)
+;;; Options
+
(defgroup epa nil
"The EasyPG Assistant"
:version "23.1"
@@ -56,11 +57,6 @@ If neither t nor nil, ask user for confirmation."
:type 'integer
:group 'epa)
-(defgroup epa-faces nil
- "Faces for epa-mode."
- :version "23.1"
- :group 'epa)
-
(defcustom epa-mail-aliases nil
"Alist of aliases of email addresses that stand for encryption keys.
Each element is a list of email addresses (ALIAS EXPANSIONS...).
@@ -76,6 +72,13 @@ The command `epa-mail-encrypt' uses this."
:group 'epa
:version "24.4")
+;;; Faces
+
+(defgroup epa-faces nil
+ "Faces for epa-mode."
+ :version "23.1"
+ :group 'epa)
+
(defface epa-validity-high
'((default :weight bold)
(((class color) (background dark)) :foreground "PaleTurquoise"))
@@ -117,13 +120,15 @@ The command `epa-mail-encrypt' uses this."
'((default :weight bold)
(((class color) (background dark)) :foreground "PaleTurquoise"))
"Face for the name of the attribute field."
- :group 'epa)
+ :version "28.1"
+ :group 'epa-faces)
(defface epa-field-body
'((default :slant italic)
(((class color) (background dark)) :foreground "turquoise"))
"Face for the body of the attribute field."
- :group 'epa)
+ :version "28.1"
+ :group 'epa-faces)
(defcustom epa-validity-face-alist
'((unknown . epa-validity-disabled)
@@ -138,16 +143,11 @@ The command `epa-mail-encrypt' uses this."
(full . epa-validity-high)
(ultimate . epa-validity-high))
"An alist mapping validity values to faces."
+ :version "28.1"
:type '(repeat (cons symbol face))
- :group 'epa)
+ :group 'epa-faces)
-(defvar epa-font-lock-keywords
- '(("^\\*"
- (0 'epa-mark))
- ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
- (1 'epa-field-name)
- (2 'epa-field-body)))
- "Default expressions to addon in epa-mode.")
+;;; Variables
(defconst epa-pubkey-algorithm-letter-alist
'((1 . ?R)
@@ -183,8 +183,10 @@ You should bind this variable with `let', but do not set it globally.")
(defvar epa-last-coding-system-specified nil)
(defvar epa-key-list-mode-map
- (let ((keymap (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((keymap (make-sparse-keymap)))
+ (define-key keymap "\C-m" 'epa-show-key)
+ (define-key keymap [?\t] 'forward-button)
+ (define-key keymap [backtab] 'backward-button)
(define-key keymap "m" 'epa-mark-key)
(define-key keymap "u" 'epa-unmark-key)
(define-key keymap "d" 'epa-decrypt-file)
@@ -201,38 +203,32 @@ You should bind this variable with `let', but do not set it globally.")
(define-key keymap [?\S-\ ] 'scroll-down-command)
(define-key keymap [delete] 'scroll-down-command)
(define-key keymap "q" 'epa-exit-buffer)
- (define-key keymap [menu-bar epa-key-list-mode] (cons "Keys" menu-map))
- (define-key menu-map [epa-key-list-unmark-key]
- '(menu-item "Unmark Key" epa-unmark-key
- :help "Unmark a key"))
- (define-key menu-map [epa-key-list-mark-key]
- '(menu-item "Mark Key" epa-mark-key
- :help "Mark a key"))
- (define-key menu-map [separator-epa-file] '(menu-item "--"))
- (define-key menu-map [epa-verify-file]
- '(menu-item "Verify File..." epa-verify-file
- :help "Verify FILE"))
- (define-key menu-map [epa-sign-file]
- '(menu-item "Sign File..." epa-sign-file
- :help "Sign FILE by SIGNERS keys selected"))
- (define-key menu-map [epa-decrypt-file]
- '(menu-item "Decrypt File..." epa-decrypt-file
- :help "Decrypt FILE"))
- (define-key menu-map [epa-encrypt-file]
- '(menu-item "Encrypt File..." epa-encrypt-file
- :help "Encrypt FILE for RECIPIENTS"))
- (define-key menu-map [separator-epa-key-list] '(menu-item "--"))
- (define-key menu-map [epa-key-list-delete-keys]
- '(menu-item "Delete Keys" epa-delete-keys
- :help "Delete Marked Keys"))
- (define-key menu-map [epa-key-list-import-keys]
- '(menu-item "Import Keys" epa-import-keys
- :help "Import keys from a file"))
- (define-key menu-map [epa-key-list-export-keys]
- '(menu-item "Export Keys" epa-export-keys
- :help "Export marked keys to a file"))
keymap))
+(easy-menu-define epa-key-list-mode-menu epa-key-list-mode-map
+ "Menu for `epa-key-list-mode'."
+ '("Keys"
+ ["Export Keys" epa-export-keys
+ :help "Export marked keys to a file"]
+ ["Import Keys" epa-import-keys
+ :help "Import keys from a file"]
+ ["Delete Keys" epa-delete-keys
+ :help "Delete Marked Keys"]
+ "---"
+ ["Encrypt File..." epa-encrypt-file
+ :help "Encrypt file for recipients"]
+ ["Decrypt File..." epa-decrypt-file
+ :help "Decrypt file"]
+ ["Sign File..." epa-sign-file
+ :help "Sign file by signers keys selected"]
+ ["Verify File..." epa-verify-file
+ :help "Verify file"]
+ "---"
+ ["Mark Key" epa-mark-key
+ :help "Mark a key"]
+ ["Unmark Key" epa-unmark-key
+ :help "Unmark a key"]))
+
(defvar epa-key-mode-map
(let ((keymap (make-sparse-keymap)))
(define-key keymap "q" 'epa-exit-buffer)
@@ -245,53 +241,43 @@ You should bind this variable with `let', but do not set it globally.")
(defvar epa-exit-buffer-function #'quit-window)
-(define-widget 'epa-key 'push-button
- "Button for representing an epg-key object."
- :format "%[%v%]"
- :button-face-get 'epa--key-widget-button-face-get
- :value-create 'epa--key-widget-value-create
- :action 'epa--key-widget-action
- :help-echo 'epa--key-widget-help-echo)
-
-(defun epa--key-widget-action (widget &optional _event)
- (save-selected-window
- (epa--show-key (widget-get widget :value))))
-
-(defun epa--key-widget-value-create (widget)
- (let* ((key (widget-get widget :value))
- (primary-sub-key (car (epg-key-sub-key-list key)))
- (primary-user-id (car (epg-key-user-id-list key))))
- (insert (format "%c "
- (if (epg-sub-key-validity primary-sub-key)
- (car (rassq (epg-sub-key-validity primary-sub-key)
- epg-key-validity-alist))
- ? ))
- (epg-sub-key-id primary-sub-key)
- " "
- (if primary-user-id
- (if (stringp (epg-user-id-string primary-user-id))
- (epg-user-id-string primary-user-id)
- (epg-decode-dn (epg-user-id-string primary-user-id)))
- ""))))
-
-(defun epa--key-widget-button-face-get (widget)
- (let ((validity (epg-sub-key-validity (car (epg-key-sub-key-list
- (widget-get widget :value))))))
- (if validity
- (cdr (assq validity epa-validity-face-alist))
- 'default)))
-
-(defun epa--key-widget-help-echo (widget)
- (format "Show %s"
- (epg-sub-key-id (car (epg-key-sub-key-list
- (widget-get widget :value))))))
+(defun epa--button-key-text (key)
+ (let ((primary-sub-key (car (epg-key-sub-key-list key)))
+ (primary-user-id (car (epg-key-user-id-list key)))
+ (validity (epg-sub-key-validity (car (epg-key-sub-key-list key)))))
+ (propertize
+ (concat
+ (propertize
+ (format "%c "
+ (if (epg-sub-key-validity primary-sub-key)
+ (car (rassq (epg-sub-key-validity primary-sub-key)
+ epg-key-validity-alist))
+ ? ))
+ 'help-echo (format "Validity: %s"
+ (epg-sub-key-validity primary-sub-key)))
+ (propertize
+ (concat
+ (epg-sub-key-id primary-sub-key)
+ " "
+ (if primary-user-id
+ (if (stringp (epg-user-id-string primary-user-id))
+ (epg-user-id-string primary-user-id)
+ (epg-decode-dn (epg-user-id-string primary-user-id)))
+ ""))
+ 'help-echo (format "Show %s"
+ (epg-sub-key-id (car (epg-key-sub-key-list key))))))
+ 'face
+ (if validity
+ (cdr (assq validity epa-validity-face-alist))
+ 'default))))
+
+;;; Modes
(define-derived-mode epa-key-list-mode special-mode "EPA Keys"
"Major mode for `epa-list-keys'."
(buffer-disable-undo)
(setq truncate-lines t
buffer-read-only t)
- (setq-local font-lock-defaults '(epa-font-lock-keywords t))
(make-local-variable 'epa-exit-buffer-function)
(setq-local revert-buffer-function #'epa--key-list-revert-buffer))
@@ -300,7 +286,6 @@ You should bind this variable with `let', but do not set it globally.")
(buffer-disable-undo)
(setq truncate-lines t
buffer-read-only t)
- (setq-local font-lock-defaults '(epa-font-lock-keywords t))
(make-local-variable 'epa-exit-buffer-function))
(define-derived-mode epa-info-mode special-mode "EPA Info"
@@ -309,6 +294,9 @@ You should bind this variable with `let', but do not set it globally.")
(setq truncate-lines t
buffer-read-only t))
+;;; Commands
+;;;; Marking
+
(defun epa-mark-key (&optional arg)
"Mark a key on the current line.
If ARG is non-nil, unmark the key."
@@ -331,37 +319,30 @@ If ARG is non-nil, mark the key."
(interactive "P")
(epa-mark-key (not arg)))
+;;;; Quitting
+
(defun epa-exit-buffer ()
- "Exit the current buffer.
-`epa-exit-buffer-function' is called if it is set."
+ "Exit the current buffer using `epa-exit-buffer-function'."
(interactive)
(funcall epa-exit-buffer-function))
-(defun epa--insert-keys (keys)
- (save-excursion
- (save-restriction
- (narrow-to-region (point) (point))
- (let (point)
- (while keys
- (setq point (point))
- (insert " ")
- (add-text-properties point (point)
- (list 'epa-key (car keys)
- 'front-sticky nil
- 'rear-nonsticky t
- 'start-open t
- 'end-open t))
- (widget-create 'epa-key :value (car keys))
- (insert "\n")
- (setq keys (cdr keys))))
- (add-text-properties (point-min) (point-max)
- (list 'epa-list-keys t
- 'front-sticky nil
- 'rear-nonsticky t
- 'start-open t
- 'end-open t)))))
+;;;; Listing and Selecting
-(defun epa--list-keys (name secret)
+(defun epa--insert-keys (keys)
+ (dolist (key keys)
+ (insert
+ (propertize
+ (concat " " (epa--button-key-text key))
+ 'epa-key key
+ ;; Allow TAB to tab to the key.
+ 'button t
+ 'category t))
+ (insert "\n")))
+
+(defun epa--list-keys (name secret &optional doc)
+ "NAME specifies which key to list.
+SECRET says list data on the secret key (default, the public key).
+DOC is documentation text to insert at the start."
(unless (and epa-keys-buffer
(buffer-live-p epa-keys-buffer))
(setq epa-keys-buffer (generate-new-buffer "*Keys*")))
@@ -371,18 +352,30 @@ If ARG is non-nil, mark the key."
buffer-read-only
(point (point-min))
(context (epg-make-context epa-protocol)))
- (unless (get-text-property point 'epa-list-keys)
- (setq point (next-single-property-change point 'epa-list-keys)))
+
+ ;; Find the end of the documentation text at the start.
+ ;; Set POINT to where it ends, or nil if ends at eob.
+ (unless (get-text-property point 'epa-key)
+ (setq point (next-single-property-change point 'epa-key)))
+
+ ;; If caller specified documentation text for that, replace the old
+ ;; documentation text (if any) with what was specified.
+ ;; Otherwise, preserve whatever intro text is present.
+ (when doc
+ (if (or point (not (eobp)))
+ (delete-region (point-min) point))
+ (insert doc)
+ (setq point (point)))
+
+ ;; Now delete the key description text, if any.
(when point
(delete-region point
(or (next-single-property-change point 'epa-list-keys)
(point-max)))
(goto-char point))
- (epa--insert-keys (epg-list-keys context name secret))
- (widget-setup)
- (set-keymap-parent (current-local-map) widget-keymap))
- (make-local-variable 'epa-list-keys-arguments)
- (setq epa-list-keys-arguments (list name secret))
+
+ (epa--insert-keys (epg-list-keys context name secret)))
+ (setq-local epa-list-keys-arguments (list name secret))
(goto-char (point-min))
(pop-to-buffer (current-buffer)))
@@ -396,7 +389,13 @@ If ARG is non-nil, mark the key."
(car epa-list-keys-arguments)))))
(list (if (equal name "") nil name)))
(list nil)))
- (epa--list-keys name nil))
+ (epa--list-keys name nil
+ "The letters at the start of a line have these meanings.
+e expired key. n never trust. m trust marginally. u trust ultimately.
+f trust fully (keys you have signed, usually).
+q trust status questionable. - trust status unspecified.
+ See GPG documentation for more explanation.
+\n"))
;;;###autoload
(defun epa-list-secret-keys (&optional name)
@@ -430,40 +429,34 @@ If ARG is non-nil, mark the key."
(unless (and epa-keys-buffer
(buffer-live-p epa-keys-buffer))
(setq epa-keys-buffer (generate-new-buffer "*Keys*")))
- (with-current-buffer epa-keys-buffer
- (epa-key-list-mode)
- ;; C-c C-c is the usual way to finish the selection (bug#11159).
- (define-key (current-local-map) "\C-c\C-c" 'exit-recursive-edit)
- (let ((inhibit-read-only t)
- buffer-read-only)
- (erase-buffer)
- (insert prompt "\n"
- (substitute-command-keys "\
+ (save-window-excursion
+ (with-current-buffer epa-keys-buffer
+ (epa-key-list-mode)
+ ;; C-c C-c is the usual way to finish the selection (bug#11159).
+ (define-key (current-local-map) "\C-c\C-c" 'exit-recursive-edit)
+ (let ((inhibit-read-only t)
+ buffer-read-only)
+ (erase-buffer)
+ (insert prompt "\n"
+ (substitute-command-keys "\
- `\\[epa-mark-key]' to mark a key on the line
- `\\[epa-unmark-key]' to unmark a key on the line\n"))
- (widget-create 'push-button
- :notify (lambda (&rest _ignore) (abort-recursive-edit))
- :help-echo
- "Click here or \\[abort-recursive-edit] to cancel"
- "Cancel")
- (widget-create 'push-button
- :notify (lambda (&rest _ignore) (exit-recursive-edit))
- :help-echo
- "Click here or \\[exit-recursive-edit] to finish"
- "OK")
- (insert "\n\n")
- (epa--insert-keys keys)
- (widget-setup)
- (set-keymap-parent (current-local-map) widget-keymap)
- (setq epa-exit-buffer-function #'abort-recursive-edit)
- (goto-char (point-min))
- (let ((display-buffer-mark-dedicated 'soft))
- (pop-to-buffer (current-buffer))))
- (unwind-protect
- (progn
- (recursive-edit)
- (epa--marked-keys))
- (kill-buffer epa-keys-buffer))))
+ (insert-button "[Cancel]"
+ 'action (lambda (_button) (abort-recursive-edit)))
+ (insert " ")
+ (insert-button "[OK]"
+ 'action (lambda (_button) (exit-recursive-edit)))
+ (insert "\n\n")
+ (epa--insert-keys keys)
+ (setq epa-exit-buffer-function #'abort-recursive-edit)
+ (goto-char (point-min))
+ (let ((display-buffer-mark-dedicated 'soft))
+ (pop-to-buffer (current-buffer))))
+ (unwind-protect
+ (progn
+ (recursive-edit)
+ (epa--marked-keys))
+ (kill-buffer epa-keys-buffer)))))
;;;###autoload
(defun epa-select-keys (context prompt &optional names secret)
@@ -476,6 +469,16 @@ If SECRET is non-nil, list secret keys instead of public keys."
(let ((keys (epg-list-keys context names secret)))
(epa--select-keys prompt keys)))
+;;;; Key Details
+
+(defun epa-show-key ()
+ "Show a key on the current line."
+ (interactive)
+ (if-let ((key (get-text-property (point) 'epa-key)))
+ (save-selected-window
+ (epa--show-key key))
+ (error "No key on this line")))
+
(defun epa--show-key (key)
(let* ((primary-sub-key (car (epg-key-sub-key-list key)))
(entry (assoc (epg-sub-key-id primary-sub-key)
@@ -492,8 +495,7 @@ If SECRET is non-nil, list secret keys instead of public keys."
(format "*Key*%s" (epg-sub-key-id primary-sub-key)))))
(set-buffer (cdr entry))
(epa-key-mode)
- (make-local-variable 'epa-key)
- (setq epa-key key)
+ (setq-local epa-key key)
(erase-buffer)
(setq pointer (epg-key-user-id-list key))
(while pointer
@@ -554,6 +556,8 @@ If SECRET is non-nil, list secret keys instead of public keys."
(goto-char (point-min))
(pop-to-buffer (current-buffer))))
+;;;; Encryption and Signatures
+
(defun epa-display-info (info)
(if epa-popup-info-window
(save-selected-window
@@ -607,10 +611,6 @@ If SECRET is non-nil, list secret keys instead of public keys."
(goto-char (point-min)))
(display-buffer buffer)))))
-(defun epa-display-verify-result (verify-result)
- (declare (obsolete epa-display-info "23.1"))
- (epa-display-info (epg-verify-result-to-string verify-result)))
-
(defun epa-passphrase-callback-function (context key-id handback)
(if (eq key-id 'SYM)
(read-passwd
@@ -1064,20 +1064,9 @@ If no one is selected, default secret key is used. "
(list 'epa-coding-system-used
epa-last-coding-system-specified
'front-sticky nil
- 'rear-nonsticky t
- 'start-open t
- 'end-open t)))))
-
-(defalias 'epa--derived-mode-p
- (if (fboundp 'derived-mode-p)
- #'derived-mode-p
- (lambda (&rest modes)
- "Non-nil if the current major mode is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards."
- (let ((parent major-mode))
- (while (and (not (memq parent modes))
- (setq parent (get parent 'derived-mode-parent))))
- parent))))
+ 'rear-nonsticky t)))))
+
+(define-obsolete-function-alias 'epa--derived-mode-p 'derived-mode-p "28.1")
;;;###autoload
(defun epa-encrypt-region (start end recipients sign signers)
@@ -1150,9 +1139,9 @@ If no one is selected, symmetric encryption will be performed. ")
(list 'epa-coding-system-used
epa-last-coding-system-specified
'front-sticky nil
- 'rear-nonsticky t
- 'start-open t
- 'end-open t)))))
+ 'rear-nonsticky t)))))
+
+;;;; Key Management
;;;###autoload
(defun epa-delete-keys (keys &optional allow-secret)
@@ -1190,7 +1179,7 @@ If no one is selected, symmetric encryption will be performed. ")
(if (epg-context-result-for context 'import)
(epa-display-info (epg-import-result-to-string
(epg-context-result-for context 'import))))
- ;; FIXME: Why not use the (otherwise unused) epa--derived-mode-p?
+ ;; FIXME: Why not use the derived-mode-p?
(if (eq major-mode 'epa-key-list-mode)
(apply #'epa--list-keys epa-list-keys-arguments))))
diff --git a/lisp/epg-config.el b/lisp/epg-config.el
index 8f9bf1d670f..d32c8c897c7 100644
--- a/lisp/epg-config.el
+++ b/lisp/epg-config.el
@@ -1,4 +1,4 @@
-;;; epg-config.el --- configuration of the EasyPG Library
+;;; epg-config.el --- configuration of the EasyPG Library -*- lexical-binding: t -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -21,7 +21,10 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+;;; Commentary:
+
;;; Code:
+;;; Prelude
(eval-when-compile (require 'cl-lib))
@@ -34,6 +37,8 @@
(define-obsolete-variable-alias 'epg-bug-report-address
'report-emacs-bug-address "27.1")
+;;; Options
+
(defgroup epg ()
"Interface to the GNU Privacy Guard (GnuPG)."
:tag "EasyPG"
@@ -106,6 +111,8 @@ through the minibuffer, instead of external Pinentry program."
Note that the buffer name starts with a space."
:type 'boolean)
+;;; Constants
+
(defconst epg-gpg-minimum-version "1.4.3")
(defconst epg-gpg2-minimum-version "2.1.6")
@@ -133,6 +140,8 @@ The first element of each entry is protocol symbol, which is
either `OpenPGP' or `CMS'. The second element is a function
which constructs a configuration object (actually a plist).")
+;;; "Configuration"
+
(defvar epg--configurations nil)
;;;###autoload
@@ -150,7 +159,7 @@ version requirement is met."
(setq program-alist epg-config--program-alist))
(let ((entry (assq protocol program-alist)))
(unless entry
- (error "Unknown protocol %S" protocol))
+ (error "Unknown protocol `%S'" protocol))
(cl-destructuring-bind (symbol . alist)
(cdr entry)
(let ((constructor
@@ -202,13 +211,13 @@ version requirement is met."
(cond
((eq type 'group)
(if (string-match "\\`\\([^:]+\\):" args)
- (setq groups
- (cons (cons (downcase (match-string 1 args))
- (delete "" (split-string
- (substring args
- (match-end 0))
- ";")))
- groups))
+ (setq groups
+ (cons (cons (downcase (match-string 1 args))
+ (delete "" (split-string
+ (substring args
+ (match-end 0))
+ ";")))
+ groups))
(if epg-debug
(message "Invalid group configuration: %S" args))))
((memq type '(pubkey cipher digest compress))
diff --git a/lisp/epg.el b/lisp/epg.el
index 0eb5b93be2c..36515ef4e5f 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -1,4 +1,5 @@
;;; epg.el --- the EasyPG Library -*- lexical-binding: t -*-
+
;; Copyright (C) 1999-2000, 2002-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
@@ -21,10 +22,15 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+;;; Prelude
(require 'epg-config)
(eval-when-compile (require 'cl-lib))
+(define-error 'epg-error "GPG error")
+
+;;; Variables
+
(defvar epg-user-id nil
"GnuPG ID of your default identity.")
@@ -41,6 +47,8 @@
(defvar epg-agent-file nil)
(defvar epg-agent-mtime nil)
+;;; Enums
+
;; from gnupg/common/openpgpdefs.h
(defconst epg-cipher-algorithm-alist
'((0 . "NONE")
@@ -123,7 +131,7 @@
(defconst epg-no-data-reason-alist
'((1 . "No armored data")
- (2 . "Expected a packet but did not found one")
+ (2 . "Expected a packet but did not find one")
(3 . "Invalid packet found, this may indicate a non OpenPGP message")
(4 . "Signature expected but not found")))
@@ -169,7 +177,8 @@
(defvar epg-prompt-alist nil)
-(define-error 'epg-error "GPG error")
+;;; Structs
+;;;; Data Struct
(cl-defstruct (epg-data
(:constructor nil)
@@ -180,6 +189,9 @@
(file nil :read-only t)
(string nil :read-only t))
+;;;; Context Struct
+(declare-function epa-passphrase-callback-function "epa.el")
+
(cl-defstruct (epg-context
(:constructor nil)
(:constructor epg-context--make
@@ -204,7 +216,7 @@
cipher-algorithm
digest-algorithm
compress-algorithm
- (passphrase-callback (list #'epg-passphrase-callback-function))
+ (passphrase-callback (list #'epa-passphrase-callback-function))
progress-callback
edit-callback
signers
@@ -218,6 +230,8 @@
(error-output "")
error-buffer)
+;;;; Context Methods
+
;; This is not an alias, just so we can mark it as autoloaded.
;;;###autoload
(defun epg-make-context (&optional protocol armor textmode include-certs
@@ -281,6 +295,8 @@ callback data (if any)."
(declare (obsolete setf "25.1"))
(setf (epg-context-signers context) signers))
+;;;; Other Structs
+
(cl-defstruct (epg-signature
(:constructor nil)
(:constructor epg-make-signature
@@ -316,7 +332,6 @@ callback data (if any)."
(cl-defstruct (epg-key
(:constructor nil)
(:constructor epg-make-key (owner-trust))
- (:copier nil)
(:predicate nil))
(owner-trust nil :read-only t)
sub-key-list user-id-list)
@@ -385,6 +400,8 @@ callback data (if any)."
secret-unchanged not-imported
imports)
+;;; Functions
+
(defun epg-context-result-for (context name)
"Return the result of CONTEXT associated with NAME."
(cdr (assq name (epg-context-result context))))
@@ -404,37 +421,28 @@ callback data (if any)."
(pubkey-algorithm (epg-signature-pubkey-algorithm signature))
(key-id (epg-signature-key-id signature)))
(concat
- (cond ((eq (epg-signature-status signature) 'good)
- "Good signature from ")
- ((eq (epg-signature-status signature) 'bad)
- "Bad signature from ")
- ((eq (epg-signature-status signature) 'expired)
- "Expired signature from ")
- ((eq (epg-signature-status signature) 'expired-key)
- "Signature made by expired key ")
- ((eq (epg-signature-status signature) 'revoked-key)
- "Signature made by revoked key ")
- ((eq (epg-signature-status signature) 'no-pubkey)
- "No public key for "))
+ (cl-case (epg-signature-status signature)
+ (good "Good signature from ")
+ (bad "Bad signature from ")
+ (expired "Expired signature from ")
+ (expired-key "Signature made by expired key ")
+ (revoked-key "Signature made by revoked key ")
+ (no-pubkey "No public key for "))
key-id
- (if user-id
- (concat " "
- (if (stringp user-id)
- (epg--decode-percent-escape-as-utf-8 user-id)
- (epg-decode-dn user-id)))
- "")
- (if (epg-signature-validity signature)
- (format " (trust %s)" (epg-signature-validity signature))
- "")
- (if (epg-signature-creation-time signature)
- (format-time-string " created at %Y-%m-%dT%T%z"
- (epg-signature-creation-time signature))
- "")
- (if pubkey-algorithm
- (concat " using "
- (or (cdr (assq pubkey-algorithm epg-pubkey-algorithm-alist))
- (format "(unknown algorithm %d)" pubkey-algorithm)))
- ""))))
+ (and user-id
+ (concat " "
+ (if (stringp user-id)
+ (epg--decode-percent-escape-as-utf-8 user-id)
+ (epg-decode-dn user-id))))
+ (and (epg-signature-validity signature)
+ (format " (trust %s)" (epg-signature-validity signature)))
+ (and (epg-signature-creation-time signature)
+ (format-time-string " created at %Y-%m-%dT%T%z"
+ (epg-signature-creation-time signature)))
+ (and pubkey-algorithm
+ (concat " using "
+ (or (cdr (assq pubkey-algorithm epg-pubkey-algorithm-alist))
+ (format "(unknown algorithm %d)" pubkey-algorithm)))))))
(defun epg-verify-result-to-string (verify-result)
"Convert VERIFY-RESULT to a human readable string."
@@ -633,22 +641,14 @@ callback data (if any)."
(with-current-buffer buffer
(if (fboundp 'set-buffer-multibyte)
(set-buffer-multibyte nil))
- (make-local-variable 'epg-last-status)
- (setq epg-last-status nil)
- (make-local-variable 'epg-read-point)
- (setq epg-read-point (point-min))
- (make-local-variable 'epg-process-filter-running)
- (setq epg-process-filter-running nil)
- (make-local-variable 'epg-pending-status-list)
- (setq epg-pending-status-list nil)
- (make-local-variable 'epg-key-id)
- (setq epg-key-id nil)
- (make-local-variable 'epg-context)
- (setq epg-context context)
- (make-local-variable 'epg-agent-file)
- (setq epg-agent-file agent-file)
- (make-local-variable 'epg-agent-mtime)
- (setq epg-agent-mtime agent-mtime))
+ (setq-local epg-last-status nil)
+ (setq-local epg-read-point (point-min))
+ (setq-local epg-process-filter-running nil)
+ (setq-local epg-pending-status-list nil)
+ (setq-local epg-key-id nil)
+ (setq-local epg-context context)
+ (setq-local epg-agent-file agent-file)
+ (setq-local epg-agent-mtime agent-mtime))
(setq error-process
(make-pipe-process :name "epg-error"
:buffer (generate-new-buffer " *epg-error*")
@@ -859,6 +859,8 @@ callback data (if any)."
(format "Untrusted key %s %s. Use anyway? " key-id user-id))
"Use untrusted key anyway? ")))
+;;; Status Functions
+
(defun epg--status-GET_BOOL (context string)
(let (inhibit-quit)
(condition-case nil
@@ -1234,18 +1236,7 @@ callback data (if any)."
(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)
- (declare (obsolete epa-passphrase-callback-function "23.1"))
- (if (eq key-id 'SYM)
- (read-passwd "Passphrase for symmetric encryption: "
- (eq (epg-context-operation context) 'encrypt))
- (read-passwd
- (if (eq key-id 'PIN)
- "Passphrase for PIN: "
- (let ((entry (assoc key-id epg-user-id-alist)))
- (if entry
- (format "Passphrase for %s %s: " key-id (cdr entry))
- (format "Passphrase for %s: " key-id)))))))
+;;; Functions
(defun epg--list-keys-1 (context name mode)
(let ((args (append (if (epg-context-home-directory context)
@@ -1303,6 +1294,8 @@ callback data (if any)."
(if (aref line 6)
(epg--time-from-seconds (aref line 6)))))
+;;; Public Functions
+
(defun epg-list-keys (context &optional name mode)
"Return a list of epg-key objects matched with NAME.
If MODE is nil or `public', only public keyring should be searched.
@@ -1380,6 +1373,24 @@ NAME is either a string or a list of strings."
(setq pointer (cdr pointer)))
keys))
+(defun epg--filter-revoked-keys (keys)
+ (mapcar
+ (lambda (key)
+ ;; We have something revoked, so copy the key and remove the
+ ;; revoked bits.
+ (if (seq-find (lambda (user)
+ (eq (epg-user-id-validity user) 'revoked))
+ (epg-key-user-id-list key))
+ (let ((copy (copy-epg-key key)))
+ (setf (epg-key-user-id-list copy)
+ (seq-remove (lambda (user)
+ (eq (epg-user-id-validity user) 'revoked))
+ (epg-key-user-id-list copy)))
+ copy)
+ ;; Nothing to delete; return the key.
+ key))
+ keys))
+
(defun epg--args-from-sig-notations (notations)
(apply #'nconc
(mapcar
@@ -1683,7 +1694,8 @@ Otherwise, it makes a cleartext signature."
(if (epg-context-result-for context 'error)
(let ((errors (epg-context-result-for context 'error)))
(signal 'epg-error
- (list "Sign failed" (epg-errors-to-string errors))))))
+ (list "Sign failed" (epg-errors-to-string errors))))
+ (signal 'epg-error '("Signing failed (unknown reason)"))))
(epg-read-output context))
(epg-delete-output-file context)
(if input-file
@@ -2031,6 +2043,8 @@ If you are unsure, use synchronous version of this function
(epg-errors-to-string errors))))))
(epg-reset context)))
+;;; Decode Functions
+
(defun epg--decode-percent-escape (string)
(setq string (encode-coding-string string 'raw-text))
(let ((index 0))
diff --git a/lisp/erc/ChangeLog.1 b/lisp/erc/ChangeLog.1
index f015150cdef..26c1bd689ef 100644
--- a/lisp/erc/ChangeLog.1
+++ b/lisp/erc/ChangeLog.1
@@ -7296,7 +7296,7 @@
again.
(erc): Require cl for delete-if.
(erc-button-remove-old-buttons): Rewrote using delete-if to
- prevent excesive consing. Having the marker list is still ugly,
+ prevent excessive consing. Having the marker list is still ugly,
so another solution needs to be found.
2003-01-17 Jorgen Schaefer <forcer@users.sourceforge.net>
@@ -9116,7 +9116,7 @@
2002-11-10 Alex Schroeder <alex@gnu.org>
* TODO:
- TODO: moved it to http://www.emacswiki.org/cgi-bin/wiki.pl?ErcTODO
+ TODO: moved it to https://www.emacswiki.org/cgi-bin/wiki.pl?ErcTODO
* erc.el(with-erc-channel-buffer): Rudimentary doc string.
@@ -10260,7 +10260,7 @@
Upcased the command defuns (erc-cmd-join is now erc-cmd-JOIN)
Fixed erc-complete to not require erc-command-table.
Implemented erc-cmd-HELP
- (You have to try that, its tooo coool!)
+ (You have to try that, its too coool!)
e.g. /help auto-q
fixed autoloads for erc-add-pal and so on to be interactive.
@@ -11242,7 +11242,7 @@
2001-10-29 Mario Lang <mlang@delysid.org>
* erc.el:
- Imenu fixed somehow, added IRC services interactive function for indentify to NickServ. Read the diff
+ Imenu fixed somehow, added IRC services interactive function for identify to NickServ. Read the diff
2001-10-26 Gergely Nagy <algernon@debian.org>
@@ -11316,7 +11316,7 @@
* erc-speak.el:
* Very important fix! Now erc-speak is really complete. Messages don't get cut anymore. Be sure to use auditory icons,
- it's reallllly cool now!!!
+ it's really cool now!!!
* erc-speak.el: *** empty log message ***
diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el
index cdb11f85f91..1a13aa95cd2 100644
--- a/lisp/erc/erc-autoaway.el
+++ b/lisp/erc/erc-autoaway.el
@@ -1,4 +1,4 @@
-;;; erc-autoaway.el --- Provides autoaway for ERC
+;;; erc-autoaway.el --- Provides autoaway for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2004, 2006-2021 Free Software Foundation, Inc.
@@ -54,11 +54,11 @@ If `erc-autoaway-idle-method' is `emacs', you must call this
function each time you change `erc-autoaway-idle-seconds'."
(interactive)
(when erc-autoaway-idletimer
- (erc-cancel-timer erc-autoaway-idletimer))
+ (cancel-timer erc-autoaway-idletimer))
(setq erc-autoaway-idletimer
(run-with-idle-timer erc-autoaway-idle-seconds
t
- 'erc-autoaway-set-away
+ #'erc-autoaway-set-away
erc-autoaway-idle-seconds)))
(defun erc-autoaway-some-server-buffer ()
@@ -66,21 +66,21 @@ function each time you change `erc-autoaway-idle-seconds'."
If none is found, return nil."
(car (erc-buffer-list #'erc-open-server-buffer-p)))
-(defun erc-autoaway-insinuate-maybe (&optional server &rest ignored)
+(defun erc-autoaway-insinuate-maybe (&optional server &rest _ignored)
"Add autoaway reset function to `post-command-hook' if at least one
ERC process is alive.
This is used when `erc-autoaway-idle-method' is `user'."
(when (or server (erc-autoaway-some-server-buffer))
- (add-hook 'post-command-hook 'erc-autoaway-reset-idle-user)))
+ (add-hook 'post-command-hook #'erc-autoaway-reset-idle-user)))
-(defun erc-autoaway-remove-maybe (&rest ignored)
+(defun erc-autoaway-remove-maybe (&rest _ignored)
"Remove the autoaway reset function from `post-command-hook' if
no ERC process is alive.
This is used when `erc-autoaway-idle-method' is `user'."
(unless (erc-autoaway-some-server-buffer)
- (remove-hook 'post-command-hook 'erc-autoaway-reset-idle-user)))
+ (remove-hook 'post-command-hook #'erc-autoaway-reset-idle-user)))
;;;###autoload(autoload 'erc-autoaway-mode "erc-autoaway")
(define-erc-module autoaway nil
@@ -107,36 +107,36 @@ set you no longer away.
Related variables: `erc-public-away-p' and `erc-away-nickname'."
;; Enable:
((when (boundp 'erc-autoaway-idle-method)
- (add-hook 'erc-connect-pre-hook 'erc-autoaway-reset-indicators)
+ (add-hook 'erc-connect-pre-hook #'erc-autoaway-reset-indicators)
(setq erc-autoaway-last-sent-time (erc-current-time))
(cond
((eq erc-autoaway-idle-method 'irc)
- (add-hook 'erc-send-completed-hook 'erc-autoaway-reset-idle-irc)
- (add-hook 'erc-server-001-functions 'erc-autoaway-reset-idle-irc))
+ (add-hook 'erc-send-completed-hook #'erc-autoaway-reset-idle-irc)
+ (add-hook 'erc-server-001-functions #'erc-autoaway-reset-idle-irc))
((eq erc-autoaway-idle-method 'user)
- (add-hook 'erc-after-connect 'erc-autoaway-insinuate-maybe)
- (add-hook 'erc-disconnected-hook 'erc-autoaway-remove-maybe)
+ (add-hook 'erc-after-connect #'erc-autoaway-insinuate-maybe)
+ (add-hook 'erc-disconnected-hook #'erc-autoaway-remove-maybe)
(erc-autoaway-insinuate-maybe))
((eq erc-autoaway-idle-method 'emacs)
(erc-autoaway-reestablish-idletimer)))
- (add-hook 'erc-timer-hook 'erc-autoaway-possibly-set-away)
- (add-hook 'erc-server-305-functions 'erc-autoaway-reset-indicators)))
+ (add-hook 'erc-timer-hook #'erc-autoaway-possibly-set-away)
+ (add-hook 'erc-server-305-functions #'erc-autoaway-reset-indicators)))
;; Disable:
((when (boundp 'erc-autoaway-idle-method)
- (remove-hook 'erc-connect-pre-hook 'erc-autoaway-reset-indicators)
+ (remove-hook 'erc-connect-pre-hook #'erc-autoaway-reset-indicators)
(cond
((eq erc-autoaway-idle-method 'irc)
- (remove-hook 'erc-send-completed-hook 'erc-autoaway-reset-idle-irc)
- (remove-hook 'erc-server-001-functions 'erc-autoaway-reset-idle-irc))
+ (remove-hook 'erc-send-completed-hook #'erc-autoaway-reset-idle-irc)
+ (remove-hook 'erc-server-001-functions #'erc-autoaway-reset-idle-irc))
((eq erc-autoaway-idle-method 'user)
- (remove-hook 'post-command-hook 'erc-autoaway-reset-idle-user)
- (remove-hook 'erc-after-connect 'erc-autoaway-insinuate-maybe)
- (remove-hook 'erc-disconnected-hook 'erc-autoaway-remove-maybe))
+ (remove-hook 'post-command-hook #'erc-autoaway-reset-idle-user)
+ (remove-hook 'erc-after-connect #'erc-autoaway-insinuate-maybe)
+ (remove-hook 'erc-disconnected-hook #'erc-autoaway-remove-maybe))
((eq erc-autoaway-idle-method 'emacs)
- (erc-cancel-timer erc-autoaway-idletimer)
+ (cancel-timer erc-autoaway-idletimer)
(setq erc-autoaway-idletimer nil)))
- (remove-hook 'erc-timer-hook 'erc-autoaway-possibly-set-away)
- (remove-hook 'erc-server-305-functions 'erc-autoaway-reset-indicators))))
+ (remove-hook 'erc-timer-hook #'erc-autoaway-possibly-set-away)
+ (remove-hook 'erc-server-305-functions #'erc-autoaway-reset-indicators))))
(defcustom erc-autoaway-idle-method 'user
"The method used to determine how long you have been idle.
@@ -148,7 +148,6 @@ The time itself is specified by `erc-autoaway-idle-seconds'.
See `erc-autoaway-mode' for more information on the various
definitions of being idle."
- :group 'erc-autoaway
:type '(choice (const :tag "User idle time" user)
(const :tag "Emacs idle time" emacs)
(const :tag "Last IRC action" irc))
@@ -166,7 +165,6 @@ ERC autoaway mode can set you away when you idle, and set you no
longer away when you type something. This variable controls whether
you will be set away when you idle. See `erc-auto-discard-away' for
the other half."
- :group 'erc-autoaway
:type 'boolean)
(defcustom erc-auto-discard-away t
@@ -176,20 +174,17 @@ longer away when you type something. This variable controls whether
you will be set no longer away when you type something. See
`erc-auto-set-away' for the other half.
See also `erc-autoaway-no-auto-discard-regexp'."
- :group 'erc-autoaway
:type 'boolean)
(defcustom erc-autoaway-no-auto-discard-regexp "^/g?away.*$"
"Input that matches this will not automatically discard away status.
See `erc-auto-discard-away'."
- :group 'erc-autoaway
:type 'regexp)
(defcustom erc-autoaway-idle-seconds 1800
"Number of seconds after which ERC will set you automatically away.
If you are changing this variable using lisp instead of customizing it,
you have to run `erc-autoaway-reestablish-idletimer' afterwards."
- :group 'erc-autoaway
:set (lambda (sym val)
(set-default sym val)
(when (eq erc-autoaway-idle-method 'emacs)
@@ -201,10 +196,9 @@ you have to run `erc-autoaway-reestablish-idletimer' afterwards."
"Message ERC will use when setting you automatically away.
It is used as a `format' string with the argument of the idletime
in seconds."
- :group 'erc-autoaway
:type 'string)
-(defun erc-autoaway-reset-idle-user (&rest stuff)
+(defun erc-autoaway-reset-idle-user (&rest _stuff)
"Reset the stored user idle time.
This is one global variable since a user talking on one net can
talk on another net too."
@@ -212,7 +206,7 @@ talk on another net too."
(erc-autoaway-set-back #'erc-autoaway-remove-maybe))
(setq erc-autoaway-last-sent-time (erc-current-time)))
-(defun erc-autoaway-reset-idle-irc (line &rest stuff)
+(defun erc-autoaway-reset-idle-irc (line &rest _stuff)
"Reset the stored IRC idle time.
This is one global variable since a user talking on one net can
talk on another net too."
@@ -272,7 +266,7 @@ active server buffer available."
(setq erc-autoaway-caused-away t)
(erc-cmd-GAWAY (format-message erc-autoaway-message idle-time))))
-(defun erc-autoaway-reset-indicators (&rest stuff)
+(defun erc-autoaway-reset-indicators (&rest _stuff)
"Reset indicators used by the erc-autoaway module."
(setq erc-autoaway-last-sent-time (erc-current-time))
(setq erc-autoaway-caused-away nil))
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 2c2f62e76ed..7a17ee233fd 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -6,7 +6,7 @@
;; Author: Lawrence Mitchell <wence@gmx.li>
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; Created: 2004-05-7
-;; Keywords: IRC chat client internet
+;; Keywords: comm, IRC, chat, client, internet
;; This file is part of GNU Emacs.
@@ -98,7 +98,6 @@
;;; Code:
-(require 'erc-compat)
(eval-when-compile (require 'cl-lib))
;; There's a fairly strong mutual dependency between erc.el and erc-backend.el.
;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the
@@ -121,38 +120,38 @@
;;; User data
-(defvar erc-server-current-nick nil
+(defvar-local erc-server-current-nick nil
"Nickname on the current server.
Use `erc-current-nick' to access this.")
-(make-variable-buffer-local 'erc-server-current-nick)
;;; Server attributes
-(defvar erc-server-process nil
+(defvar-local erc-server-process nil
"The process object of the corresponding server connection.")
-(make-variable-buffer-local 'erc-server-process)
-(defvar erc-session-server nil
+(defvar-local erc-session-server nil
"The server name used to connect to for this session.")
-(make-variable-buffer-local 'erc-session-server)
-(defvar erc-session-connector nil
+(defvar-local erc-session-connector nil
"The function used to connect to this session (nil for the default).")
-(make-variable-buffer-local 'erc-session-connector)
-(defvar erc-session-port nil
+(defvar-local erc-session-port nil
"The port used to connect to.")
-(make-variable-buffer-local 'erc-session-port)
-(defvar erc-server-announced-name nil
+(defvar-local erc-session-client-certificate nil
+ "TLS client certificate used when connecting over TLS.
+If non-nil, should either be a list where the first element is
+the certificate key file name, and the second element is the
+certificate file name itself, or t, which means that
+`auth-source' will be queried for the key and the certificate.")
+
+(defvar-local erc-server-announced-name nil
"The name the server announced to use.")
-(make-variable-buffer-local 'erc-server-announced-name)
-(defvar erc-server-version nil
+(defvar-local erc-server-version nil
"The name and version of the server's ircd.")
-(make-variable-buffer-local 'erc-server-version)
-(defvar erc-server-parameters nil
+(defvar-local erc-server-parameters nil
"Alist listing the supported server parameters.
This is only set if the server sends 005 messages saying what is
@@ -178,86 +177,70 @@ RFC2812 - server supports RFC 2812 features
SILENCE=10 - supports the SILENCE command, maximum allowed number of entries
TOPICLEN=160 - maximum allowed topic length
WALLCHOPS - supports sending messages to all operators in a channel")
-(make-variable-buffer-local 'erc-server-parameters)
;;; Server and connection state
(defvar erc-server-ping-timer-alist nil
"Mapping of server buffers to their specific ping timer.")
-(defvar erc-server-connected nil
+(defvar-local erc-server-connected nil
"Non-nil if the current buffer has been used by ERC to establish
an IRC connection.
If you wish to determine whether an IRC connection is currently
active, use the `erc-server-process-alive' function instead.")
-(make-variable-buffer-local 'erc-server-connected)
-(defvar erc-server-reconnect-count 0
+(defvar-local erc-server-reconnect-count 0
"Number of times we have failed to reconnect to the current server.")
-(make-variable-buffer-local 'erc-server-reconnect-count)
-(defvar erc-server-quitting nil
+(defvar-local erc-server-quitting nil
"Non-nil if the user requests a quit.")
-(make-variable-buffer-local 'erc-server-quitting)
-(defvar erc-server-reconnecting nil
+(defvar-local erc-server-reconnecting nil
"Non-nil if the user requests an explicit reconnect, and the
current IRC process is still alive.")
-(make-variable-buffer-local 'erc-server-reconnecting)
-(defvar erc-server-timed-out nil
+(defvar-local erc-server-timed-out nil
"Non-nil if the IRC server failed to respond to a ping.")
-(make-variable-buffer-local 'erc-server-timed-out)
-(defvar erc-server-banned nil
+(defvar-local erc-server-banned nil
"Non-nil if the user is denied access because of a server ban.")
-(make-variable-buffer-local 'erc-server-banned)
-(defvar erc-server-error-occurred nil
+(defvar-local erc-server-error-occurred nil
"Non-nil if the user triggers some server error.")
-(make-variable-buffer-local 'erc-server-error-occurred)
-(defvar erc-server-lines-sent nil
+(defvar-local erc-server-lines-sent nil
"Line counter.")
-(make-variable-buffer-local 'erc-server-lines-sent)
-(defvar erc-server-last-peers '(nil . nil)
+(defvar-local erc-server-last-peers '(nil . nil)
"Last peers used, both sender and receiver.
Those are used for /MSG destination shortcuts.")
-(make-variable-buffer-local 'erc-server-last-peers)
-(defvar erc-server-last-sent-time nil
+(defvar-local erc-server-last-sent-time nil
"Time the message was sent.
This is useful for flood protection.")
-(make-variable-buffer-local 'erc-server-last-sent-time)
-(defvar erc-server-last-ping-time nil
+(defvar-local erc-server-last-ping-time nil
"Time the last ping was sent.
This is useful for flood protection.")
-(make-variable-buffer-local 'erc-server-last-ping-time)
-(defvar erc-server-last-received-time nil
+(defvar-local erc-server-last-received-time nil
"Time the last message was received from the server.
This is useful for detecting hung connections.")
-(make-variable-buffer-local 'erc-server-last-received-time)
-(defvar erc-server-lag nil
+(defvar-local erc-server-lag nil
"Calculated server lag time in seconds.
This variable is only set in a server buffer.")
-(make-variable-buffer-local 'erc-server-lag)
-(defvar erc-server-filter-data nil
+(defvar-local erc-server-filter-data nil
"The data that arrived from the server
but has not been processed yet.")
-(make-variable-buffer-local 'erc-server-filter-data)
-(defvar erc-server-duplicates (make-hash-table :test 'equal)
+(defvar-local erc-server-duplicates (make-hash-table :test 'equal)
"Internal variable used to track duplicate messages.")
-(make-variable-buffer-local 'erc-server-duplicates)
;; From Circe
-(defvar erc-server-processing-p nil
+(defvar-local erc-server-processing-p nil
"Non-nil when we're currently processing a message.
When ERC receives a private message, it sets up a new buffer for
@@ -268,23 +251,19 @@ network exceptions. So, if someone sends you two messages
quickly after each other, ispell is started for the first, but
might take long enough for the second message to be processed
first.")
-(make-variable-buffer-local 'erc-server-processing-p)
-(defvar erc-server-flood-last-message 0
+(defvar-local erc-server-flood-last-message 0
"When we sent the last message.
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm.")
-(make-variable-buffer-local 'erc-server-flood-last-message)
-(defvar erc-server-flood-queue nil
+(defvar-local erc-server-flood-queue nil
"The queue of messages waiting to be sent to the server.
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm.")
-(make-variable-buffer-local 'erc-server-flood-queue)
-(defvar erc-server-flood-timer nil
+(defvar-local erc-server-flood-timer nil
"The timer to resume sending.")
-(make-variable-buffer-local 'erc-server-flood-timer)
;;; IRC protocol and misc options
@@ -296,7 +275,6 @@ protection algorithm.")
"Non-nil means that ERC will attempt to reestablish broken connections.
Reconnection will happen automatically for any unexpected disconnection."
- :group 'erc-server
:type 'boolean)
(defcustom erc-server-reconnect-attempts 2
@@ -304,7 +282,6 @@ Reconnection will happen automatically for any unexpected disconnection."
broken connection, or t to always attempt to reconnect.
This only has an effect if `erc-server-auto-reconnect' is non-nil."
- :group 'erc-server
:type '(choice (const :tag "Always reconnect" t)
integer))
@@ -313,7 +290,6 @@ This only has an effect if `erc-server-auto-reconnect' is non-nil."
successive reconnect attempts.
If a key is pressed while ERC is waiting, it will stop waiting."
- :group 'erc-server
:type 'number)
(defcustom erc-split-line-length 440
@@ -327,14 +303,12 @@ And a typical message looks like this:
You can limit here the maximum length of the \"Hello!\" part.
Good luck."
- :type 'integer
- :group 'erc-server)
+ :type 'integer)
(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
:version "24.1"
:type '(repeat coding-system))
@@ -359,7 +333,6 @@ If you need to send non-ASCII text to people not using a client that
does decoding on its own, you must tell ERC what encoding to use.
Emacs cannot guess it, since it does not know what the people on the
other end of the line are using."
- :group 'erc-server
:type '(choice (const :tag "None" nil)
coding-system
(cons (coding-system :tag "encoding" :value utf-8)
@@ -374,42 +347,37 @@ current target as returned by `erc-default-target'.
Example: If you know that the channel #linux-ru uses the coding-system
`cyrillic-koi8', then add (\"#linux-ru\" . cyrillic-koi8) to the
alist."
- :group 'erc-server
- :type '(repeat (cons (string :tag "Target")
+ :type '(repeat (cons (regexp :tag "Target")
coding-system)))
(defcustom erc-server-connect-function #'erc-open-network-stream
"Function used to initiate a connection.
It should take same arguments as `open-network-stream' does."
- :group 'erc-server
:type 'function)
(defcustom erc-server-prevent-duplicates '("301")
"Either nil or a list of strings.
Each string is a IRC message type, like PRIVMSG or NOTICE.
All Message types in that list of subjected to duplicate prevention."
- :type '(choice (const nil) (list string))
- :group 'erc-server)
+ :type '(choice (const nil) (list string)))
(defcustom erc-server-duplicate-timeout 60
"The time allowed in seconds between duplicate messages.
If two identical messages arrive within this value of one another, the second
isn't displayed."
- :type 'integer
- :group 'erc-server)
+ :type 'integer)
(defcustom erc-server-timestamp-format "%Y-%m-%d %T"
"Timestamp format used with server response messages.
This string is processed using `format-time-string'."
:version "24.3"
- :type 'string
- :group 'erc-server)
+ :type 'string)
;;; Flood-related
;; Most of this is courtesy of Jorgen Schaefer and Circe
-;; (http://www.nongnu.org/circe)
+;; (https://www.nongnu.org/circe)
(defcustom erc-server-flood-margin 10
"A margin on how much excess data we send.
@@ -423,22 +391,19 @@ detailed in RFC 2813, section 5.8 \"Flood control of clients\".
time, send a message, and increase
`erc-server-flood-last-message' by
`erc-server-flood-penalty' for each message."
- :type 'integer
- :group 'erc-server)
+ :type 'integer)
(defcustom erc-server-flood-penalty 3
"How much we penalize a message.
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm."
- :type 'integer
- :group 'erc-server)
+ :type 'integer)
;; Ping handling
(defcustom erc-server-send-ping-interval 30
"Interval of sending pings to the server, in seconds.
If this is set to nil, pinging the server is disabled."
- :group 'erc-server
:type '(choice (const :tag "Disabled" nil)
(integer :tag "Seconds")))
@@ -450,13 +415,11 @@ This must be greater than or equal to the value for
`erc-server-send-ping-interval'.
If this is set to nil, never try to reconnect."
- :group 'erc-server
:type '(choice (const :tag "Disabled" nil)
(integer :tag "Seconds")))
-(defvar erc-server-ping-handler nil
+(defvar-local erc-server-ping-handler nil
"This variable holds the periodic ping timer.")
-(make-variable-buffer-local 'erc-server-ping-handler)
;;;; Helper functions
@@ -520,7 +483,8 @@ If no subword-mode is active, then this is
"Set up a timer to periodically ping the current server.
The current buffer is given by BUFFER."
(with-current-buffer buffer
- (and erc-server-ping-handler (erc-cancel-timer erc-server-ping-handler))
+ (when erc-server-ping-handler
+ (cancel-timer erc-server-ping-handler))
(when erc-server-send-ping-interval
(setq erc-server-ping-handler (run-with-timer
4 erc-server-send-ping-interval
@@ -533,7 +497,7 @@ The current buffer is given by BUFFER."
(if timer-tuple
;; this buffer already has a timer. Cancel it and set the new one
(progn
- (erc-cancel-timer (cdr timer-tuple))
+ (cancel-timer (cdr timer-tuple))
(setf (cdr (assq buffer erc-server-ping-timer-alist)) erc-server-ping-handler))
;; no existing timer for this buffer. Add new one
@@ -548,18 +512,23 @@ The current buffer is given by BUFFER."
(memq (process-status erc-server-process) '(run open)))))
;;;; Connecting to a server
-(defun erc-open-network-stream (name buffer host service)
- "As `open-network-stream', but does non-blocking IO"
- (make-network-process :name name :buffer buffer
- :host host :service service :nowait t))
+(defun erc-open-network-stream (name buffer host service &rest parameters)
+ "Like `open-network-stream', but does non-blocking IO."
+ (let ((p (plist-put parameters :nowait t)))
+ (apply #'open-network-stream name buffer host service p)))
-(defun erc-server-connect (server port buffer)
+(defun erc-server-connect (server port buffer &optional client-certificate)
"Perform the connection and login using the specified SERVER and PORT.
-We will store server variables in the buffer given by BUFFER."
- (let ((msg (erc-format-message 'connect ?S server ?p port)) process)
+We will store server variables in the buffer given by BUFFER.
+CLIENT-CERTIFICATE may optionally be used to specify a TLS client
+certificate to use for authentication when connecting over
+TLS (see `erc-session-client-certificate' for more details)."
+ (let ((msg (erc-format-message 'connect ?S server ?p port)) process
+ (args `(,(format "erc-%s-%s" server port) nil ,server ,port)))
+ (when client-certificate
+ (setq args `(,@args :client-certificate ,client-certificate)))
(message "%s" msg)
- (setq process (funcall erc-server-connect-function
- (format "erc-%s-%s" server port) nil server port))
+ (setq process (apply erc-server-connect-function args))
(unless (processp process)
(error "Connection attempt failed"))
;; Misc server variables
@@ -731,7 +700,7 @@ Conditionally try to reconnect and take appropriate action."
(erc-with-all-buffers-of-server cproc nil
(setq erc-server-connected nil))
(when erc-server-ping-handler
- (progn (erc-cancel-timer erc-server-ping-handler)
+ (progn (cancel-timer erc-server-ping-handler)
(setq erc-server-ping-handler nil)))
(run-hook-with-args 'erc-disconnected-hook
(erc-current-nick) (system-name) "")
@@ -781,7 +750,7 @@ value of `erc-server-coding-system'."
(pop precedence))
(when precedence
(setq coding (car precedence)))))
- (erc-decode-coding-string str coding)))
+ (decode-coding-string str coding t)))
;; proposed name, not used by anything yet
(defun erc-send-line (text display-fn)
@@ -856,7 +825,7 @@ Additionally, detect whether the IRC process has hung."
;; remove timer if the server buffer has been killed
(let ((timer (assq buf erc-server-ping-timer-alist)))
(when timer
- (erc-cancel-timer (cdr timer))
+ (cancel-timer (cdr timer))
(setcdr timer nil)))))
;; From Circe
@@ -864,41 +833,42 @@ Additionally, detect whether the IRC process has hung."
"Send messages in `erc-server-flood-queue'.
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm."
- (with-current-buffer buffer
- (let ((now (current-time)))
- (when erc-server-flood-timer
- (erc-cancel-timer erc-server-flood-timer)
- (setq erc-server-flood-timer nil))
- (when (time-less-p erc-server-flood-last-message now)
- (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now)))
- (while (and erc-server-flood-queue
- (time-less-p erc-server-flood-last-message
- (time-add now erc-server-flood-margin)))
- (let ((msg (caar erc-server-flood-queue))
- (encoding (cdar erc-server-flood-queue)))
- (setq erc-server-flood-queue (cdr erc-server-flood-queue)
- erc-server-flood-last-message
- (+ erc-server-flood-last-message
- erc-server-flood-penalty))
- (erc-log-irc-protocol msg 'outbound)
- (erc-log (concat "erc-server-send-queue: "
- msg "(" (buffer-name buffer) ")"))
- (when (erc-server-process-alive)
- (condition-case nil
- ;; Set encoding just before sending the string
- (progn
- (when (fboundp 'set-process-coding-system)
- (set-process-coding-system erc-server-process
- 'raw-text encoding))
- (process-send-string erc-server-process msg))
- ;; Sometimes the send can occur while the process is
- ;; being killed, which results in a weird SIGPIPE error.
- ;; Catch this and ignore it.
- (error nil)))))
- (when erc-server-flood-queue
- (setq erc-server-flood-timer
- (run-at-time (+ 0.2 erc-server-flood-penalty)
- nil #'erc-server-send-queue buffer))))))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((now (current-time)))
+ (when erc-server-flood-timer
+ (cancel-timer erc-server-flood-timer)
+ (setq erc-server-flood-timer nil))
+ (when (time-less-p erc-server-flood-last-message now)
+ (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now)))
+ (while (and erc-server-flood-queue
+ (time-less-p erc-server-flood-last-message
+ (time-add now erc-server-flood-margin)))
+ (let ((msg (caar erc-server-flood-queue))
+ (encoding (cdar erc-server-flood-queue)))
+ (setq erc-server-flood-queue (cdr erc-server-flood-queue)
+ erc-server-flood-last-message
+ (+ erc-server-flood-last-message
+ erc-server-flood-penalty))
+ (erc-log-irc-protocol msg 'outbound)
+ (erc-log (concat "erc-server-send-queue: "
+ msg "(" (buffer-name buffer) ")"))
+ (when (erc-server-process-alive)
+ (condition-case nil
+ ;; Set encoding just before sending the string
+ (progn
+ (when (fboundp 'set-process-coding-system)
+ (set-process-coding-system erc-server-process
+ 'raw-text encoding))
+ (process-send-string erc-server-process msg))
+ ;; Sometimes the send can occur while the process is
+ ;; being killed, which results in a weird SIGPIPE error.
+ ;; Catch this and ignore it.
+ (error nil)))))
+ (when erc-server-flood-queue
+ (setq erc-server-flood-timer
+ (run-at-time (+ 0.2 erc-server-flood-penalty)
+ nil #'erc-server-send-queue buffer)))))))
(defun erc-message (message-command line &optional force)
"Send LINE to the server as a privmsg or a notice.
@@ -1106,14 +1076,9 @@ Finds hooks by looking in the `erc-server-responses' hash table."
(erc-display-message parsed 'notice proc line)))
-(put 'define-erc-response-handler 'edebug-form-spec
- '(&define :name erc-response-handler
- (name &rest name)
- &optional sexp sexp def-body))
-
(cl-defmacro define-erc-response-handler ((name &rest aliases)
- &optional extra-fn-doc extra-var-doc
- &rest fn-body)
+ &optional extra-fn-doc extra-var-doc
+ &rest fn-body)
"Define an ERC handler hook/function pair.
NAME is the response name as sent by the server (see the IRC RFC for
meanings).
@@ -1193,6 +1158,9 @@ Would expand to:
See also `erc-server-311'.\"))
\(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)"
+ (declare (debug (&define [&name "erc-response-handler@"
+ (symbolp &rest symbolp)]
+ &optional sexp sexp def-body)))
(if (numberp name) (setq name (intern (format "%03i" name))))
(setq aliases (mapcar (lambda (a)
(if (numberp a)
@@ -1255,8 +1223,8 @@ add things to `%s' instead."
,@(cl-loop for fn in fn-alternates
for var in var-alternates
for a in aliases
- nconc (list `(defalias ',fn ',fn-name)
- `(defvar ,var ',fn-name ,(format hook-doc a))
+ nconc (list `(defalias ',fn #',fn-name)
+ `(defvar ,var #',fn-name ,(format hook-doc a))
`(put ',var 'definition-name ',hook-name))))))
(define-erc-response-handler (ERROR)
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index c0172461487..5953471ae8e 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -1,10 +1,10 @@
-;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*- lexical-binding:t -*-
+;;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*- lexical-binding:t -*-
;; Copyright (C) 1996-2004, 2006-2021 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: irc, button, url, regexp
+;; Keywords: comm, irc, button, url, regexp
;; URL: https://www.emacswiki.org/emacs/ErcButton
;; This file is part of GNU Emacs.
@@ -52,14 +52,14 @@
;;;###autoload(autoload 'erc-button-mode "erc-button" nil t)
(define-erc-module button nil
"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-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-function)
- (remove-hook 'erc-mode-hook 'erc-button-setup)))
+ ((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-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-function)
+ (remove-hook 'erc-mode-hook #'erc-button-setup)))
;;; Variables
@@ -91,7 +91,6 @@ above them."
(defcustom erc-button-url-regexp browse-url-button-regexp
"Regular expression that matches URLs."
:version "27.1"
- :group 'erc-button
:type 'regexp)
(defcustom erc-button-wrap-long-urls nil
@@ -100,28 +99,25 @@ above them."
If this variable is a number, consider URLs longer than its value to
be \"long\". If t, URLs will be considered \"long\" if they are
longer than `erc-fill-column'."
- :group 'erc-button
:type '(choice integer boolean))
(defcustom erc-button-buttonize-nicks t
"Flag indicating whether nicks should be buttonized or not."
- :group 'erc-button
:type 'boolean)
-(defcustom erc-button-rfc-url "http://www.faqs.org/rfcs/rfc%s.html"
- "URL used to browse rfc references.
+(defcustom erc-button-rfc-url "https://tools.ietf.org/html/rfc%s"
+ "URL used to browse RFC references.
%s is replaced by the number."
- :group 'erc-button
- :type 'string)
+ :type 'string
+ :version "28.1")
(define-obsolete-variable-alias 'erc-button-google-url
'erc-button-search-url "27.1")
-(defcustom erc-button-search-url "http://duckduckgo.com/?q=%s"
+(defcustom erc-button-search-url "https://duckduckgo.com/?q=%s"
"URL used to search for a term.
%s is replaced by the search string."
- :version "27.1"
- :group 'erc-button
+ :version "28.1"
:type 'string)
(defcustom erc-button-alist
@@ -134,7 +130,8 @@ longer than `erc-fill-column'."
("<URL: *\\([^<> ]+\\) *>" 0 t browse-url-button-open-url 1)
;;; ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3)
;; emacs internal
- ("[`]\\([a-zA-Z][-a-zA-Z_0-9]+\\)[']" 1 t erc-button-describe-symbol 1)
+ ("[`]\\([a-zA-Z][-a-zA-Z_0-9!*<=>+]+\\)[']"
+ 1 t erc-button-describe-symbol 1)
;; pseudo links
("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1)
("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)"
@@ -179,7 +176,6 @@ PAR is a number of a regexp grouping whose text will be passed to
CALLBACK. There can be several PAR arguments. If REGEXP is
\\='nicknames, these are ignored, and CALLBACK will be called with
the nickname matched as the argument."
- :group 'erc-button
:version "24.1" ; remove finger (bug#4443)
:type '(repeat
(list :tag "Button"
@@ -198,22 +194,20 @@ PAR is a number of a regexp grouping whose text will be passed to
:inline t
(integer :tag "Regexp section number")))))
-(defcustom erc-emacswiki-url "http://www.emacswiki.org/cgi-bin/wiki.pl?"
+(defcustom erc-emacswiki-url "https://www.emacswiki.org/cgi-bin/wiki.pl?"
"URL of the EmacsWiki Homepage."
- :group 'erc-button
:type 'string)
-(defcustom erc-emacswiki-lisp-url "http://www.emacswiki.org/elisp/"
+(defcustom erc-emacswiki-lisp-url "https://www.emacswiki.org/elisp/"
"URL of the EmacsWiki ELisp area."
- :group 'erc-button
:type 'string)
(defvar erc-button-keymap
(let ((map (make-sparse-keymap)))
- (define-key map (kbd "RET") 'erc-button-press-button)
- (define-key map (kbd "<mouse-2>") 'erc-button-click-button)
- (define-key map (kbd "TAB") 'erc-button-next)
- (define-key map (kbd "<backtab>") 'erc-button-previous)
+ (define-key map (kbd "RET") #'erc-button-press-button)
+ (define-key map (kbd "<mouse-2>") #'erc-button-click-button)
+ (define-key map (kbd "TAB") #'erc-button-next)
+ (define-key map (kbd "<backtab>") #'erc-button-previous)
(define-key map [follow-link] 'mouse-face)
(set-keymap-parent map erc-mode-map)
map)
@@ -242,10 +236,9 @@ global-level ERC button keys yet.")
(defun erc-button-setup ()
"Add ERC mode-level button movement keys. This is only done once."
- ;; Make XEmacs use `erc-button-face'.
;; Add keys.
(unless erc-button-keys-added
- (define-key erc-mode-map (kbd "<backtab>") 'erc-button-previous)
+ (define-key erc-mode-map (kbd "<backtab>") #'erc-button-previous)
(setq erc-button-keys-added t)))
(defun erc-button-add-buttons ()
@@ -288,7 +281,7 @@ specified by `erc-button-alist'."
(fun (nth 3 entry))
bounds word)
(when (or (eq t form)
- (eval form))
+ (eval form t))
(goto-char (point-min))
(while (erc-forward-word)
(when (setq bounds (erc-bounds-of-word-at-point))
@@ -307,9 +300,9 @@ specified by `erc-button-alist'."
(end (match-end (nth 1 entry)))
(form (nth 2 entry))
(fun (nth 3 entry))
- (data (mapcar 'match-string (nthcdr 4 entry))))
+ (data (mapcar #'match-string-no-properties (nthcdr 4 entry))))
(when (or (eq t form)
- (eval form))
+ (eval form t))
(erc-button-add-button start end fun nil data regexp)))))
(defun erc-button-remove-old-buttons ()
@@ -484,7 +477,6 @@ Examples:
(format
\"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\"
nick)))"
- :group 'erc-button
:type '(repeat (cons (string :tag "Op")
sexp)))
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index efed116cecc..19bc2dbb8ec 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -1,4 +1,4 @@
-;;; erc-capab.el --- support for dancer-ircd and hyperion's CAPAB
+;;; erc-capab.el --- support for dancer-ircd and hyperion's CAPAB -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -40,8 +40,8 @@
;; disable this module, it will continue removing message flags, but the
;; unidentified nickname prefix will not be added to messages.
-;; Visit <http://freenode.net/faq.shtml#spoofing> and
-;; <http://freenode.net/faq.shtml#registering> to find further
+;; Visit <https://freenode.net/kb/answer/cloaks> and
+;; <https://freenode.net/kb/answer/registration> to find further
;; explanations of this capability.
;; From freenode.net's web site (not there anymore) on how to mark
@@ -80,12 +80,10 @@
If you change this from the default \"*\", be sure to use a
character not found in IRC nicknames to avoid confusion."
- :group 'erc-capab
:type '(choice string (const nil)))
(defface erc-capab-identify-unidentified '((t)) ; same as `erc-default-face'
"Face to use for `erc-capab-identify-prefix'."
- :group 'erc-capab
:group 'erc-faces)
;;; Define module:
@@ -94,36 +92,34 @@ character not found in IRC nicknames to avoid confusion."
(define-erc-module capab-identify nil
"Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP."
;; append so that `erc-server-parameters' is already set by `erc-server-005'
- ((add-hook 'erc-server-005-functions 'erc-capab-identify-setup t)
- (add-hook 'erc-server-290-functions 'erc-capab-identify-activate)
+ ((add-hook 'erc-server-005-functions #'erc-capab-identify-setup t)
+ (add-hook 'erc-server-290-functions #'erc-capab-identify-activate)
(add-hook 'erc-server-PRIVMSG-functions
- 'erc-capab-identify-remove/set-identified-flag)
+ #'erc-capab-identify-remove/set-identified-flag)
(add-hook 'erc-server-NOTICE-functions
- 'erc-capab-identify-remove/set-identified-flag)
- (add-hook 'erc-insert-modify-hook 'erc-capab-identify-add-prefix t)
+ #'erc-capab-identify-remove/set-identified-flag)
+ (add-hook 'erc-insert-modify-hook #'erc-capab-identify-add-prefix t)
(mapc (lambda (buffer)
(when buffer
(with-current-buffer buffer (erc-capab-identify-setup))))
- (erc-buffer-list 'erc-open-server-buffer-p)))
- ((remove-hook 'erc-server-005-functions 'erc-capab-identify-setup)
- (remove-hook 'erc-server-290-functions 'erc-capab-identify-activate)
+ (erc-buffer-list #'erc-open-server-buffer-p)))
+ ((remove-hook 'erc-server-005-functions #'erc-capab-identify-setup)
+ (remove-hook 'erc-server-290-functions #'erc-capab-identify-activate)
;; we don't remove the `erc-capab-identify-remove/set-identified-flag' hooks
;; because there doesn't seem to be a way to tell the server to turn it off
- (remove-hook 'erc-insert-modify-hook 'erc-capab-identify-add-prefix)))
+ (remove-hook 'erc-insert-modify-hook #'erc-capab-identify-add-prefix)))
;;; Variables:
-(defvar erc-capab-identify-activated nil
+(defvar-local erc-capab-identify-activated nil
"CAPAB IDENTIFY-MSG has been activated.")
-(make-variable-buffer-local 'erc-capab-identify-activated)
-(defvar erc-capab-identify-sent nil
+(defvar-local erc-capab-identify-sent nil
"CAPAB IDENTIFY-MSG and IDENTIFY-CTCP messages have been sent.")
-(make-variable-buffer-local 'erc-capab-identify-sent)
;;; Functions:
-(defun erc-capab-identify-setup (&optional proc parsed)
+(defun erc-capab-identify-setup (&optional _proc _parsed)
"Set up CAPAB IDENTIFY on the current server.
Optional argument PROC is the current server's process.
@@ -148,19 +144,19 @@ These arguments are sent to this function when called as a hook in
(setq erc-capab-identify-sent t)))
-(defun erc-capab-identify-activate (proc parsed)
+(defun erc-capab-identify-activate (_proc parsed)
"Set `erc-capab-identify-activated' and display an activation message.
PROC is the current server's process.
PARSED is an `erc-parsed' response struct."
- (when (or (string= "IDENTIFY-MSG" (erc-response.contents parsed))
- (string= "IDENTIFY-CTCP" (erc-response.contents parsed)))
+ (when (member (erc-response.contents parsed)
+ '("IDENTIFY-MSG" "IDENTIFY-CTCP"))
(setq erc-capab-identify-activated t)
(erc-display-message
parsed 'notice 'active (format "%s activated"
(erc-response.contents parsed)))))
-(defun erc-capab-identify-remove/set-identified-flag (proc parsed)
+(defun erc-capab-identify-remove/set-identified-flag (_proc parsed)
"Remove PARSED message's id flag and add the `erc-identified' text property.
PROC is the current server's process.
@@ -170,11 +166,11 @@ PARSED is an `erc-parsed' response struct."
(string-match "^\\([-\\+]\\)\\(.+\\)$" msg))
(setf (erc-response.contents parsed)
(if erc-capab-identify-mode
- (erc-propertize (match-string 2 msg)
- 'erc-identified
- (if (string= (match-string 1 msg) "+")
- 1
- 0))
+ (propertize (match-string 2 msg)
+ 'erc-identified
+ (if (string= (match-string 1 msg) "+")
+ 1
+ 0))
(match-string 2 msg)))
nil)))
@@ -190,9 +186,9 @@ PARSED is an `erc-parsed' response struct."
;; assuming the first use of `nickname' is the sender's nick
(re-search-forward (regexp-quote nickname) nil t))
(goto-char (match-beginning 0))
- (insert (erc-propertize erc-capab-identify-prefix
- 'font-lock-face
- 'erc-capab-identify-unidentified))))))
+ (insert (propertize erc-capab-identify-prefix
+ 'font-lock-face
+ 'erc-capab-identify-unidentified))))))
(defun erc-capab-identify-get-unidentified-nickname (parsed)
"Return the nickname of the user if unidentified.
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index da4928ce427..219af3741fa 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -1,4 +1,4 @@
-;;; erc-dcc.el --- CTCP DCC module for ERC
+;;; erc-dcc.el --- CTCP DCC module for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2021 Free Software
;; Foundation, Inc.
@@ -7,7 +7,7 @@
;; Noah Friedman <friedman@prep.ai.mit.edu>
;; Per Persson <pp@sno.pp.se>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, processes
+;; Keywords: comm
;; Created: 1994-01-23
;; This file is part of GNU Emacs.
@@ -55,12 +55,6 @@
;; Require at run-time too to silence compiler.
(require 'pcomplete)
-;;;###autoload(autoload 'erc-dcc-mode "erc-dcc")
-(define-erc-module dcc nil
- "Provide Direct Client-to-Client support for ERC."
- ((add-hook 'erc-server-401-functions 'erc-dcc-no-such-nick))
- ((remove-hook 'erc-server-401-functions 'erc-dcc-no-such-nick)))
-
(defgroup erc-dcc nil
"DCC stands for Direct Client Communication, where you and your
friend's client programs connect directly to each other,
@@ -71,9 +65,14 @@ Using DCC get and send, you can transfer files directly from and to other
IRC users."
:group 'erc)
+;;;###autoload(autoload 'erc-dcc-mode "erc-dcc")
+(define-erc-module dcc nil
+ "Provide Direct Client-to-Client support for ERC."
+ ((add-hook 'erc-server-401-functions #'erc-dcc-no-such-nick))
+ ((remove-hook 'erc-server-401-functions #'erc-dcc-no-such-nick)))
+
(defcustom erc-dcc-verbose nil
"If non-nil, be verbose about DCC activity reporting."
- :group 'erc-dcc
:type 'boolean)
(defconst erc-dcc-connection-types
@@ -83,7 +82,8 @@ All values of the list must be uppercase strings.")
(defvar erc-dcc-list nil
"List of DCC connections. Looks like:
- ((:nick \"nick!user@host\" :type GET :peer proc :parent proc :size size :file file)
+ ((:nick \"nick!user@host\" :type GET :peer proc
+ :parent proc :size size :file file)
(:nick \"nick!user@host\" :type CHAT :peer proc :parent proc)
(:nick \"nick\" :type SEND :peer server-proc :parent parent-proc :file
file :sent <marker> :confirmed <marker>))
@@ -119,7 +119,8 @@ All values of the list must be uppercase strings.")
;; more: the entry data from erc-dcc-list for this particular process.
(defvar erc-dcc-connect-function 'erc-dcc-open-network-stream)
-(defun erc-dcc-open-network-stream (procname buffer addr port entry)
+(defun erc-dcc-open-network-stream (procname buffer addr port _entry)
+ ;; FIXME: Time to try activating this again!?
(if nil; (fboundp 'open-network-stream-nowait) ;; this currently crashes
;; cvs emacs
(open-network-stream-nowait procname buffer addr port)
@@ -285,7 +286,6 @@ The result is also a string."
"IP address to listen on when offering files.
Should be set to a string or nil. If nil, automatic detection of
the host interface to use will be attempted."
- :group 'erc-dcc
:type (list 'choice (list 'const :tag "Auto-detect" nil)
(list 'string :tag "IP-address"
:valid-regexp erc-dcc-ipv4-regexp)))
@@ -294,7 +294,6 @@ the host interface to use will be attempted."
"IP address to use for outgoing DCC offers.
Should be set to a string or nil. If nil, use the value of
`erc-dcc-listen-host'."
- :group 'erc-dcc
:type (list 'choice (list 'const :tag "Same as erc-dcc-listen-host" nil)
(list 'string :tag "IP-address"
:valid-regexp erc-dcc-ipv4-regexp)))
@@ -305,7 +304,6 @@ Should be set to a string or nil. If nil, use the value of
You might want to set `erc-dcc-auto-masks' for this.
`auto' - Automatically accept the request and begin downloading the file
`ignore' - Ignore incoming DCC Send requests completely."
- :group 'erc-dcc
:type '(choice (const ask) (const auto) (const ignore)))
(defun erc-dcc-get-host (proc)
@@ -322,7 +320,6 @@ If variable `erc-dcc-host' is non-nil, use it. Otherwise call
(defcustom erc-dcc-port-range nil
"If nil, any available user port is used for outgoing DCC connections.
If set to a cons, it specifies a range of ports to use in the form (min . max)"
- :group 'erc-dcc
:type '(choice
(const :tag "Any port" nil)
(cons :tag "Port range"
@@ -334,7 +331,6 @@ If set to a cons, it specifies a range of ports to use in the form (min . max)"
accepted automatically. A user identifier has the form \"nick!login@host\".
For instance, to accept all incoming DCC send offers automatically, add the
string \".*!.*@.*\" to this list."
- :group 'erc-dcc
:type '(repeat regexp))
(defun erc-dcc-server (name filter sentinel)
@@ -390,7 +386,6 @@ the accepted connection."
(defcustom erc-dcc-get-default-directory nil
"Default directory for incoming DCC file transfers.
If this is nil, then the current value of `default-directory' is used."
- :group 'erc-dcc
:type '(choice (const nil :tag "Default directory") directory))
;;;###autoload
@@ -419,34 +414,34 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 1)))
('chat (mapcar (lambda (elt) (plist-get elt :nick))
- (erc-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type) 'CHAT))
+ (cl-remove-if-not
+ (lambda (elt)
+ (eq (plist-get elt :type) 'CHAT))
erc-dcc-list)))
- ('close (erc-delete-dups
+ ('close (delete-dups
(mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
erc-dcc-list)))
('get (mapcar #'erc-dcc-nick
- (erc-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type) 'GET))
+ (cl-remove-if-not
+ (lambda (elt)
+ (eq (plist-get elt :type) 'GET))
erc-dcc-list)))
('send (pcomplete-erc-all-nicks))))
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 2)))
('get (mapcar (lambda (elt) (plist-get elt :file))
- (erc-remove-if-not
- #'(lambda (elt)
- (and (eq (plist-get elt :type) 'GET)
- (erc-nick-equal-p (erc-extract-nick
- (plist-get elt :nick))
- (pcomplete-arg 1))))
+ (cl-remove-if-not
+ (lambda (elt)
+ (and (eq (plist-get elt :type) 'GET)
+ (erc-nick-equal-p (erc-extract-nick
+ (plist-get elt :nick))
+ (pcomplete-arg 1))))
erc-dcc-list)))
('close (mapcar #'erc-dcc-nick
- (erc-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type)
- (intern (upcase (pcomplete-arg 1)))))
+ (cl-remove-if-not
+ (lambda (elt)
+ (eq (plist-get elt :type)
+ (intern (upcase (pcomplete-arg 1)))))
erc-dcc-list)))
('send (pcomplete-entries)))))
@@ -467,7 +462,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
'dcc-chat-offer ?n nick)
t))))
-(defun erc-dcc-do-CLOSE-command (proc &optional type nick)
+(defun erc-dcc-do-CLOSE-command (_proc &optional type nick)
"Close a connection. Usage: /dcc close type nick.
At least one of TYPE and NICK must be provided."
;; disambiguate type and nick if only one is provided
@@ -516,8 +511,8 @@ PROC is the server process."
(filename (or file (plist-get elt :file) "unknown")))
(if elt
(let* ((file (read-file-name
- (format "Local filename (default %s): "
- (file-name-nondirectory filename))
+ (format-prompt "Local filename"
+ (file-name-nondirectory filename))
(or erc-dcc-get-default-directory
default-directory)
(expand-file-name (file-name-nondirectory filename)
@@ -537,10 +532,9 @@ PROC is the server process."
nil '(notice error) 'active
'dcc-get-notfound ?n nick ?f filename))))
-(defvar erc-dcc-byte-count nil)
-(make-variable-buffer-local 'erc-dcc-byte-count)
+(defvar-local erc-dcc-byte-count nil)
-(defun erc-dcc-do-LIST-command (proc)
+(defun erc-dcc-do-LIST-command (_proc)
"This is the handler for the /dcc list command.
It lists the current state of `erc-dcc-list' in an easy to read manner."
(let ((alist erc-dcc-list)
@@ -627,17 +621,17 @@ that subcommand."
?q query ?n nick ?u login ?h host))))
(defconst erc-dcc-ctcp-query-send-regexp
- (concat "^DCC SEND \\("
+ (concat "^DCC SEND \\(?:"
;; Following part matches either filename without spaces
;; or filename enclosed in double quotes with any number
;; of escaped double quotes inside.
- "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)"
+ "\"\\(\\(?:\\\\\"\\|[^\"\\]\\)+\\)\"\\|\\([^ ]+\\)"
"\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)"))
(define-inline erc-dcc-unquote-filename (filename)
(inline-quote
- (erc-replace-regexp-in-string "\\\\\\\\" "\\"
- (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t)))
+ (replace-regexp-in-string "\\\\\\\\" "\\"
+ (replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t)))
(defun erc-dcc-handle-ctcp-send (proc query nick login host to)
"This is called if a CTCP DCC SEND subcommand is sent to the client.
@@ -653,11 +647,11 @@ It extracts the information about the dcc request and adds it to
?r "SEND" ?n nick ?u login ?h host))
((string-match erc-dcc-ctcp-query-send-regexp query)
(let ((filename
- (or (match-string 5 query)
- (erc-dcc-unquote-filename (match-string 2 query))))
- (ip (erc-decimal-to-ip (match-string 6 query)))
- (port (match-string 7 query))
- (size (match-string 8 query)))
+ (or (match-string 2 query)
+ (erc-dcc-unquote-filename (match-string 1 query))))
+ (ip (erc-decimal-to-ip (match-string 3 query)))
+ (port (match-string 4 query))
+ (size (match-string 5 query)))
;; FIXME: a warning really should also be sent
;; if the ip address != the host the dcc sender is on.
(erc-display-message
@@ -703,7 +697,6 @@ the matching regexp, or nil if none found."
`ask' - Report the Chat request, and wait for the user to manually accept it
`auto' - Automatically accept the request and open a new chat window
`ignore' - Ignore incoming DCC chat requests completely."
- :group 'erc-dcc
:type '(choice (const ask) (const auto) (const ignore)))
(defun erc-dcc-handle-ctcp-chat (proc query nick login host to)
@@ -750,21 +743,18 @@ the matching regexp, or nil if none found."
'dcc-malformed ?n nick ?u login ?h host ?q query)))))
-(defvar erc-dcc-entry-data nil
+(defvar-local erc-dcc-entry-data nil
"Holds the `erc-dcc-list' entry for this DCC connection.")
-(make-variable-buffer-local 'erc-dcc-entry-data)
;;; SEND handling
(defcustom erc-dcc-block-size 1024
"Block size to use for DCC SEND sessions."
- :group 'erc-dcc
:type 'integer)
(defcustom erc-dcc-pump-bytes nil
"If set to an integer, keep sending until that number of bytes are
unconfirmed."
- :group 'erc-dcc
:type '(choice (const nil) integer))
(define-inline erc-dcc-get-parent (proc)
@@ -838,7 +828,6 @@ bytes sent."
'(erc-dcc-display-send erc-dcc-send-block)
"Hook run whenever the remote end of a DCC SEND offer connected to your
listening port."
- :group 'erc-dcc
:type 'hook)
(defun erc-dcc-nick (plist)
@@ -901,11 +890,9 @@ other client."
(defcustom erc-dcc-receive-cache (* 1024 512)
"Number of bytes to let the receive buffer grow before flushing it."
- :group 'erc-dcc
:type 'integer)
-(defvar erc-dcc-file-name nil)
-(make-variable-buffer-local 'erc-dcc-file-name)
+(defvar-local erc-dcc-file-name nil)
(defun erc-dcc-get-file (entry file parent-proc)
"Set up a transfer from the remote client to the local over a TCP connection.
@@ -944,12 +931,12 @@ and making the connection."
(set-process-coding-system proc 'binary 'binary)
(set-buffer-file-coding-system 'binary t)
- (set-process-filter proc 'erc-dcc-get-filter)
- (set-process-sentinel proc 'erc-dcc-get-sentinel)
+ (set-process-filter proc #'erc-dcc-get-filter)
+ (set-process-sentinel proc #'erc-dcc-get-sentinel)
(setq entry (plist-put entry :start-time (erc-current-time)))
(setq entry (plist-put entry :peer proc)))))
-(defun erc-dcc-append-contents (buffer file)
+(defun erc-dcc-append-contents (buffer _file)
"Append the contents of BUFFER to FILE.
The contents of the BUFFER will then be erased."
(with-current-buffer buffer
@@ -1002,7 +989,7 @@ rather than every 1024 byte block, but nobody seems to care."
proc (erc-pack-int received-bytes)))))))
-(defun erc-dcc-get-sentinel (proc event)
+(defun erc-dcc-get-sentinel (proc _event)
"This is the process sentinel for CTCP DCC SEND connections.
It shuts down the connection and notifies the user that the
transfer is complete."
@@ -1027,25 +1014,21 @@ transfer is complete."
(defcustom erc-dcc-chat-buffer-name-format "DCC-CHAT-%s"
"Format to use for DCC Chat buffer names."
- :group 'erc-dcc
:type 'string)
(defcustom erc-dcc-chat-mode-hook nil
"Hook calls when `erc-dcc-chat-mode' finished setting up the buffer."
- :group 'erc-dcc
:type 'hook)
(defcustom erc-dcc-chat-connect-hook nil
""
- :group 'erc-dcc
:type 'hook)
(defcustom erc-dcc-chat-exit-hook nil
""
- :group 'erc-dcc
:type 'hook)
-(defun erc-cmd-CREQ (line &optional force)
+(defun erc-cmd-CREQ (line &optional _force)
"Set or get the DCC chat request flag.
Possible values are: ask, auto, ignore."
(when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line)
@@ -1060,7 +1043,7 @@ Possible values are: ask, auto, ignore."
erc-dcc-chat-request)))
t)))
-(defun erc-cmd-SREQ (line &optional force)
+(defun erc-cmd-SREQ (line &optional _force)
"Set or get the DCC send request flag.
Possible values are: ask, auto, ignore."
(when (string-match "^\\s-*\\(auto\\|ask\\|ignore\\)?$" line)
@@ -1077,7 +1060,7 @@ Possible values are: ask, auto, ignore."
(defun pcomplete/erc-mode/CREQ ()
(pcomplete-here '("auto" "ask" "ignore")))
-(defalias 'pcomplete/erc-mode/SREQ 'pcomplete/erc-mode/CREQ)
+(defalias 'pcomplete/erc-mode/SREQ #'pcomplete/erc-mode/CREQ)
(define-obsolete-variable-alias 'erc-dcc-chat-filter-hook
'erc-dcc-chat-filter-functions "24.3")
@@ -1089,19 +1072,19 @@ the unprocessed output.")
(defvar erc-dcc-chat-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map (kbd "RET") 'erc-send-current-line)
- (define-key map "\t" 'completion-at-point)
+ (define-key map (kbd "RET") #'erc-send-current-line)
+ (define-key map "\t" #'completion-at-point)
map)
"Keymap for `erc-dcc-mode'.")
(define-derived-mode erc-dcc-chat-mode fundamental-mode "DCC-Chat"
"Major mode for wasting time via DCC chat."
(setq mode-line-process '(":%s")
- erc-send-input-line-function 'erc-dcc-chat-send-input-line
+ erc-send-input-line-function #'erc-dcc-chat-send-input-line
erc-default-recipients '(dcc))
- (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
+ (add-hook 'completion-at-point-functions #'erc-complete-word-at-point nil t))
-(defun erc-dcc-chat-send-input-line (recipient line &optional force)
+(defun erc-dcc-chat-send-input-line (recipient line &optional _force)
"Send LINE to the remote end.
Argument RECIPIENT should always be the symbol dcc, and force
is ignored."
@@ -1152,14 +1135,14 @@ other client."
(setq erc-input-marker (make-marker))
(erc-display-prompt buffer (point-max))
(set-process-buffer proc buffer)
- (add-hook 'kill-buffer-hook 'erc-dcc-chat-buffer-killed nil t)
+ (add-hook 'kill-buffer-hook #'erc-dcc-chat-buffer-killed nil t)
(run-hook-with-args 'erc-dcc-chat-connect-hook proc)
buffer))
(defun erc-dcc-chat-accept (entry parent-proc)
"Accept an incoming DCC connection and open a DCC window."
- (let* ((nick (erc-extract-nick (plist-get entry :nick)))
- buffer proc)
+ (let* (;; (nick (erc-extract-nick (plist-get entry :nick)))
+ proc) ;; buffer
(setq proc
(funcall erc-dcc-connect-function
"dcc-chat" nil
@@ -1169,9 +1152,10 @@ other client."
;; XXX: connected, should we kill the ip/port properties?
(setq entry (plist-put entry :peer proc))
(setq entry (plist-put entry :parent parent-proc))
- (set-process-filter proc 'erc-dcc-chat-filter)
- (set-process-sentinel proc 'erc-dcc-chat-sentinel)
- (setq buffer (erc-dcc-chat-setup entry))))
+ (set-process-filter proc #'erc-dcc-chat-filter)
+ (set-process-sentinel proc #'erc-dcc-chat-sentinel)
+ ;; (setq buffer
+ (erc-dcc-chat-setup entry))) ;; )
(defun erc-dcc-chat-filter (proc str)
(let ((orig-buffer (current-buffer)))
@@ -1193,8 +1177,8 @@ other client."
(setq posn (match-end 0))
(erc-display-message
nil nil proc
- 'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'font-lock-face
- 'erc-nick-default-face) ?m line))
+ 'dcc-chat-privmsg ?n (propertize erc-dcc-from 'font-lock-face
+ 'erc-nick-default-face) ?m line))
(setq erc-dcc-unprocessed-output (substring str posn)))))
(defun erc-dcc-chat-buffer-killed ()
diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el
index 03b56d10fcc..9838b239537 100644
--- a/lisp/erc/erc-desktop-notifications.el
+++ b/lisp/erc/erc-desktop-notifications.el
@@ -1,4 +1,4 @@
-;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions -*- lexical-binding:t -*-
+;;; erc-desktop-notifications.el --- Send notification on PRIVMSG or mentions -*- lexical-binding:t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
@@ -31,6 +31,7 @@
(require 'erc)
(require 'xml)
(require 'notifications)
+(require 'erc-goodies)
(require 'erc-match)
(require 'dbus)
@@ -44,13 +45,11 @@
(defcustom erc-notifications-icon nil
"Icon to use for notification."
- :group 'erc-notifications
:type '(choice (const :tag "No icon" nil) file))
(defcustom erc-notifications-bus :session
"D-Bus bus to use for notification."
:version "25.1"
- :group 'erc-notifications
:type '(choice (const :tag "Session bus" :session) string))
(defvar dbus-debug) ; used in the macroexpansion of dbus-ignore-errors
@@ -62,12 +61,12 @@ This will replace the last notification sent with this function."
;; setting the current buffer to the existing query buffer)
(dbus-ignore-errors
(setq erc-notifications-last-notification
- (let ((channel (if privp (erc-get-buffer nick) (current-buffer))))
+ (let* ((channel (if privp (erc-get-buffer nick) (current-buffer)))
+ (title (format "%s in %s" (xml-escape-string nick t) channel))
+ (body (xml-escape-string (erc-controls-strip msg) t)))
(notifications-notify :bus erc-notifications-bus
- :title (format "%s in %s"
- (xml-escape-string nick)
- channel)
- :body (xml-escape-string msg)
+ :title title
+ :body body
:replaces-id erc-notifications-last-notification
:app-icon erc-notifications-icon
:actions '("default" "Switch to buffer")
@@ -98,11 +97,11 @@ This will replace the last notification sent with this function."
(define-erc-module notifications nil
"Send notifications on private message reception and mentions."
;; Enable
- ((add-hook 'erc-server-PRIVMSG-functions 'erc-notifications-PRIVMSG)
- (add-hook 'erc-text-matched-hook 'erc-notifications-notify-on-match))
+ ((add-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG)
+ (add-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match))
;; Disable
- ((remove-hook 'erc-server-PRIVMSG-functions 'erc-notifications-PRIVMSG)
- (remove-hook 'erc-text-matched-hook 'erc-notifications-notify-on-match)))
+ ((remove-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG)
+ (remove-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match)))
(provide 'erc-desktop-notifications)
diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el
index 182f3c9e6e0..331d29a7b5b 100644
--- a/lisp/erc/erc-ezbounce.el
+++ b/lisp/erc/erc-ezbounce.el
@@ -1,4 +1,4 @@
-;;; erc-ezbounce.el --- Handle EZBounce bouncer commands
+;;; erc-ezbounce.el --- Handle EZBounce bouncer commands -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
@@ -33,8 +33,7 @@
(defcustom erc-ezb-regexp "^ezbounce!srv$"
"Regexp used by the EZBouncer to identify itself to the user."
- :group 'erc-ezbounce
- :type 'string)
+ :type 'regexp)
(defcustom erc-ezb-login-alist '()
"Alist of logins suitable for the server we're connecting to.
@@ -44,7 +43,6 @@ The alist's format is as follows:
(((server . port) . (username . password))
((server . port) . (username . password))
...)"
- :group 'erc-ezbounce
:type '(repeat
(cons (cons :tag "Server"
string
@@ -61,15 +59,14 @@ The alist's format is as follows:
"Alist of actions to take on NOTICEs from EZBounce.")
-(defvar erc-ezb-session-list '()
+(defvar-local erc-ezb-session-list '()
"List of detached EZBounce sessions.")
-(make-variable-buffer-local 'erc-ezb-session-list)
(defvar erc-ezb-inside-session-listing nil
"Indicate whether current notices are expected to be EZB session listings.")
;;;###autoload
-(defun erc-cmd-ezb (line &optional force)
+(defun erc-cmd-ezb (line &optional _force)
"Send EZB commands to the EZBouncer verbatim."
(erc-server-send (concat "EZB " line)))
(put 'erc-cmd-EZB 'do-not-parse-args t)
@@ -103,7 +100,7 @@ in the alist is nil, prompt for the appropriate values."
found))
;;;###autoload
-(defun erc-ezb-notice-autodetect (proc parsed)
+(defun erc-ezb-notice-autodetect (_proc parsed)
"React on an EZBounce NOTICE request."
(let* ((sender (erc-response.sender parsed))
(message (erc-response.contents parsed))
@@ -114,7 +111,7 @@ in the alist is nil, prompt for the appropriate values."
nil)
;;;###autoload
-(defun erc-ezb-identify (message)
+(defun erc-ezb-identify (_message)
"Identify to the EZBouncer server."
(let ((login (erc-ezb-get-login erc-session-server (erc-port-to-string erc-session-port))))
(unless (null login)
@@ -123,13 +120,13 @@ in the alist is nil, prompt for the appropriate values."
(erc-server-send (concat "LOGIN " username " " pass))))))
;;;###autoload
-(defun erc-ezb-init-session-list (message)
+(defun erc-ezb-init-session-list (_message)
"Reset the EZBounce session list to nil."
(setq erc-ezb-session-list nil)
(setq erc-ezb-inside-session-listing t))
;;;###autoload
-(defun erc-ezb-end-of-session-list (message)
+(defun erc-ezb-end-of-session-list (_message)
"Indicate the end of the EZBounce session listing."
(setq erc-ezb-inside-session-listing nil))
@@ -144,7 +141,7 @@ in the alist is nil, prompt for the appropriate values."
(add-to-list 'erc-ezb-session-list (list id nick to)))))
;;;###autoload
-(defun erc-ezb-select (message)
+(defun erc-ezb-select (_message)
"Select an IRC server to use by EZBounce, in ERC style."
(unless (and erc-ezb-session-list
(erc-ezb-select-session))
@@ -170,7 +167,7 @@ in the alist is nil, prompt for the appropriate values."
;;;###autoload
(defun erc-ezb-initialize ()
"Add EZBouncer convenience functions to ERC."
- (add-hook 'erc-server-NOTICE-functions 'erc-ezb-notice-autodetect))
+ (add-hook 'erc-server-NOTICE-functions #'erc-ezb-notice-autodetect))
(provide 'erc-ezbounce)
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index 8d0c3b20117..41256682c00 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -1,4 +1,4 @@
-;;; erc-fill.el --- Filling IRC messages in various ways
+;;; erc-fill.el --- Filling IRC messages in various ways -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2004, 2006-2021 Free Software Foundation, Inc.
@@ -38,7 +38,7 @@
:group 'erc)
;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t)
-(erc-define-minor-mode erc-fill-mode
+(define-minor-mode erc-fill-mode
"Toggle ERC fill mode.
With a prefix argument ARG, enable ERC fill mode if ARG is
positive, and disable it otherwise. If called from Lisp, enable
@@ -46,8 +46,7 @@ the mode if ARG is omitted or nil.
ERC fill mode is a global minor mode. When enabled, messages in
the channel buffers are filled."
- nil nil nil
- :global t :group 'erc-fill
+ :global t
(if erc-fill-mode
(erc-fill-enable)
(erc-fill-disable)))
@@ -55,19 +54,18 @@ the channel buffers are filled."
(defun erc-fill-enable ()
"Setup hooks for `erc-fill-mode'."
(interactive)
- (add-hook 'erc-insert-modify-hook 'erc-fill)
- (add-hook 'erc-send-modify-hook 'erc-fill))
+ (add-hook 'erc-insert-modify-hook #'erc-fill)
+ (add-hook 'erc-send-modify-hook #'erc-fill))
(defun erc-fill-disable ()
"Cleanup hooks, disable `erc-fill-mode'."
(interactive)
- (remove-hook 'erc-insert-modify-hook 'erc-fill)
- (remove-hook 'erc-send-modify-hook 'erc-fill))
+ (remove-hook 'erc-insert-modify-hook #'erc-fill)
+ (remove-hook 'erc-send-modify-hook #'erc-fill))
(defcustom erc-fill-prefix nil
"Values used as `fill-prefix' for `erc-fill-variable'.
nil means fill with space, a string means fill with this string."
- :group 'erc-fill
:type '(choice (const nil) string))
(defcustom erc-fill-function 'erc-fill-variable
@@ -94,7 +92,6 @@ These two styles are implemented using `erc-fill-variable' and
`erc-fill-static'. You can, of course, define your own filling
function. Narrowing to the region in question is in effect while your
function is called."
- :group 'erc-fill
:type '(choice (const :tag "Variable Filling" erc-fill-variable)
(const :tag "Static Filling" erc-fill-static)
function))
@@ -104,18 +101,15 @@ function is called."
centered. This column denotes the point where the ` ' character
between <nickname> and the entered text will be put, thus aligning
nick names right and text left."
- :group 'erc-fill
:type 'integer)
(defcustom erc-fill-variable-maximum-indentation 17
"If we indent a line after a long nick, don't indent more then this
characters. Set to nil to disable."
- :group 'erc-fill
:type 'integer)
(defcustom erc-fill-column 78
"The column at which a filled paragraph is broken."
- :group 'erc-fill
:type 'integer)
;;;###autoload
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index b402cdf1eea..fc9a8d39ef4 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -1,4 +1,4 @@
-;; erc-goodies.el --- Collection of ERC modules
+;;; erc-goodies.el --- Collection of ERC modules -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -35,10 +35,9 @@
(defun erc-imenu-setup ()
"Setup Imenu support in an ERC buffer."
- (set (make-local-variable 'imenu-create-index-function)
- 'erc-create-imenu-index))
+ (setq-local imenu-create-index-function #'erc-create-imenu-index))
-(add-hook 'erc-mode-hook 'erc-imenu-setup)
+(add-hook 'erc-mode-hook #'erc-imenu-setup)
(autoload 'erc-create-imenu-index "erc-imenu" "Imenu index creation function")
;;; Automatically scroll to bottom
@@ -54,16 +53,16 @@ argument to `recenter'."
(define-erc-module scrolltobottom nil
"This mode causes the prompt to stay at the end of the window."
- ((add-hook 'erc-mode-hook 'erc-add-scroll-to-bottom)
- (add-hook 'erc-insert-done-hook 'erc-possibly-scroll-to-bottom)
+ ((add-hook 'erc-mode-hook #'erc-add-scroll-to-bottom)
+ (add-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer
(erc-add-scroll-to-bottom))))
- ((remove-hook 'erc-mode-hook 'erc-add-scroll-to-bottom)
- (remove-hook 'erc-insert-done-hook 'erc-possibly-scroll-to-bottom)
+ ((remove-hook 'erc-mode-hook #'erc-add-scroll-to-bottom)
+ (remove-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer
- (remove-hook 'post-command-hook 'erc-scroll-to-bottom t)))))
+ (remove-hook 'post-command-hook #'erc-scroll-to-bottom t)))))
(defun erc-possibly-scroll-to-bottom ()
"Like `erc-add-scroll-to-bottom', but only if window is selected."
@@ -78,7 +77,7 @@ the value of `erc-input-line-position'.
This works whenever scrolling happens, so it's added to
`window-scroll-functions' rather than `erc-insert-post-hook'."
- (add-hook 'post-command-hook 'erc-scroll-to-bottom nil t))
+ (add-hook 'post-command-hook #'erc-scroll-to-bottom nil t))
(defun erc-scroll-to-bottom ()
"Recenter WINDOW so that `point' is on the last line.
@@ -105,10 +104,10 @@ variable `erc-input-line-position'."
;;; Make read only
(define-erc-module readonly nil
"This mode causes all inserted text to be read-only."
- ((add-hook 'erc-insert-post-hook 'erc-make-read-only)
- (add-hook 'erc-send-post-hook 'erc-make-read-only))
- ((remove-hook 'erc-insert-post-hook 'erc-make-read-only)
- (remove-hook 'erc-send-post-hook 'erc-make-read-only)))
+ ((add-hook 'erc-insert-post-hook #'erc-make-read-only)
+ (add-hook 'erc-send-post-hook #'erc-make-read-only))
+ ((remove-hook 'erc-insert-post-hook #'erc-make-read-only)
+ (remove-hook 'erc-send-post-hook #'erc-make-read-only)))
(defun erc-make-read-only ()
"Make all the text in the current buffer read-only.
@@ -120,14 +119,14 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
;;; Move to prompt when typing text
(define-erc-module move-to-prompt nil
"This mode causes the point to be moved to the prompt when typing text."
- ((add-hook 'erc-mode-hook 'erc-move-to-prompt-setup)
+ ((add-hook 'erc-mode-hook #'erc-move-to-prompt-setup)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer
(erc-move-to-prompt-setup))))
- ((remove-hook 'erc-mode-hook 'erc-move-to-prompt-setup)
+ ((remove-hook 'erc-mode-hook #'erc-move-to-prompt-setup)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer
- (remove-hook 'pre-command-hook 'erc-move-to-prompt t)))))
+ (remove-hook 'pre-command-hook #'erc-move-to-prompt t)))))
(defun erc-move-to-prompt ()
"Move the point to the ERC prompt if this is a self-inserting command."
@@ -139,15 +138,15 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
(defun erc-move-to-prompt-setup ()
"Initialize the move-to-prompt module for XEmacs."
- (add-hook 'pre-command-hook 'erc-move-to-prompt nil t))
+ (add-hook 'pre-command-hook #'erc-move-to-prompt nil t))
;;; Keep place in unvisited channels
(define-erc-module keep-place nil
"Leave point above un-viewed text in other channels."
- ((add-hook 'erc-insert-pre-hook 'erc-keep-place))
- ((remove-hook 'erc-insert-pre-hook 'erc-keep-place)))
+ ((add-hook 'erc-insert-pre-hook #'erc-keep-place))
+ ((remove-hook 'erc-insert-pre-hook #'erc-keep-place)))
-(defun erc-keep-place (ignored)
+(defun erc-keep-place (_ignored)
"Move point away from the last line in a non-selected ERC buffer."
(when (and (not (eq (window-buffer (selected-window))
(current-buffer)))
@@ -184,8 +183,8 @@ does not appear in the ERC buffer after the user presses ENTER.")
"This mode distinguishes non-commands.
Commands listed in `erc-insert-this' know how to display
themselves."
- ((add-hook 'erc-pre-send-functions 'erc-send-distinguish-noncommands))
- ((remove-hook 'erc-pre-send-functions 'erc-send-distinguish-noncommands)))
+ ((add-hook 'erc-pre-send-functions #'erc-send-distinguish-noncommands))
+ ((remove-hook 'erc-pre-send-functions #'erc-send-distinguish-noncommands)))
(defun erc-send-distinguish-noncommands (state)
"If STR is an ERC non-command, set `insertp' in STATE to nil."
@@ -212,26 +211,27 @@ highlighting effects. When this variable is non-nil, it can cause Emacs to run
slowly on systems lacking sufficient CPU speed. In chatty channels, or in an
emergency (message flood) it can be turned off to save processing time. See
`erc-toggle-interpret-controls'."
- :group 'erc-control-characters
:type '(choice (const :tag "Highlight control characters" t)
(const :tag "Remove control characters" remove)
(const :tag "Display raw control characters" nil)))
(defcustom erc-interpret-mirc-color nil
"If non-nil, ERC will interpret mIRC color codes."
- :group 'erc-control-characters
:type 'boolean)
(defcustom erc-beep-p nil
"Beep if C-g is in the server message.
The value `erc-interpret-controls-p' must also be t for this to work."
- :group 'erc-control-characters
:type 'boolean)
(defface erc-bold-face '((t :weight bold))
"ERC bold face."
:group 'erc-faces)
+(defface erc-italic-face '((t :slant italic))
+ "ERC italic face."
+ :group 'erc-faces)
+
(defface erc-inverse-face
'((t :foreground "White" :background "Black"))
"ERC inverse face."
@@ -369,10 +369,10 @@ The value `erc-interpret-controls-p' must also be t for this to work."
(define-erc-module irccontrols nil
"This mode enables the interpretation of IRC control chars."
- ((add-hook 'erc-insert-modify-hook 'erc-controls-highlight)
- (add-hook 'erc-send-modify-hook 'erc-controls-highlight))
- ((remove-hook 'erc-insert-modify-hook 'erc-controls-highlight)
- (remove-hook 'erc-send-modify-hook 'erc-controls-highlight)))
+ ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight)
+ (add-hook 'erc-send-modify-hook #'erc-controls-highlight))
+ ((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight)
+ (remove-hook 'erc-send-modify-hook #'erc-controls-highlight)))
(defun erc-controls-interpret (str)
"Return a copy of STR after dealing with IRC control characters.
@@ -383,6 +383,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
(erc-controls-strip s))
(erc-interpret-controls-p
(let ((boldp nil)
+ (italicp nil)
(inversep nil)
(underlinep nil)
(fg nil)
@@ -394,13 +395,14 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
(start (match-beginning 0))
(end (+ (match-beginning 0)
(length (match-string 5 s)))))
- (setq s (erc-replace-match-subexpression-in-string
- "" s control 1 start))
+ (setq s (replace-match "" nil nil s 1))
(cond ((and erc-interpret-mirc-color (or fg-color bg-color))
(setq fg fg-color)
(setq bg bg-color))
((string= control "\C-b")
(setq boldp (not boldp)))
+ ((string= control "\C-]")
+ (setq italicp (not italicp)))
((string= control "\C-v")
(setq inversep (not inversep)))
((string= control "\C-_")
@@ -413,13 +415,14 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
(ding)))
((string= control "\C-o")
(setq boldp nil
+ italicp nil
inversep nil
underlinep nil
fg nil
bg nil))
(t nil))
(erc-controls-propertize
- start end boldp inversep underlinep fg bg s)))
+ start end boldp italicp inversep underlinep fg bg s)))
s))
(t s)))))
@@ -432,13 +435,13 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
s)))
(defvar erc-controls-remove-regexp
- "\C-b\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?"
+ "\C-b\\|\C-]\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?"
"Regular expression which matches control characters to remove.")
(defvar erc-controls-highlight-regexp
- (concat "\\(\C-b\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|"
+ (concat "\\(\C-b\\|\C-]\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|"
"\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)"
- "\\([^\C-b\C-v\C-_\C-c\C-g\C-o\n]*\\)")
+ "\\([^\C-b\C-]\C-v\C-_\C-c\C-g\C-o\n]*\\)")
"Regular expression which matches control chars and the text to highlight.")
(defun erc-controls-highlight ()
@@ -451,6 +454,7 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
(replace-match "")))
(erc-interpret-controls-p
(let ((boldp nil)
+ (italicp nil)
(inversep nil)
(underlinep nil)
(fg nil)
@@ -467,6 +471,8 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
(setq bg bg-color))
((string= control "\C-b")
(setq boldp (not boldp)))
+ ((string= control "\C-]")
+ (setq italicp (not italicp)))
((string= control "\C-v")
(setq inversep (not inversep)))
((string= control "\C-_")
@@ -479,16 +485,17 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
(ding)))
((string= control "\C-o")
(setq boldp nil
+ italicp nil
inversep nil
underlinep nil
fg nil
bg nil))
(t nil))
(erc-controls-propertize start end
- boldp inversep underlinep fg bg)))))
+ boldp italicp inversep underlinep fg bg)))))
(t nil)))
-(defun erc-controls-propertize (from to boldp inversep underlinep fg bg
+(defun erc-controls-propertize (from to boldp italicp inversep underlinep fg bg
&optional str)
"Prepend properties from IRC control characters between FROM and TO.
If optional argument STR is provided, apply to STR, otherwise prepend properties
@@ -500,6 +507,9 @@ to a region in the current buffer."
(append (if boldp
'(erc-bold-face)
nil)
+ (if italicp
+ '(erc-italic-face)
+ nil)
(if inversep
'(erc-inverse-face)
nil)
@@ -533,10 +543,10 @@ Else interpretation is turned off."
"This mode translates text-smileys such as :-) into pictures.
This requires the function `smiley-region', which is defined in
smiley.el, which is part of Gnus."
- ((add-hook 'erc-insert-modify-hook 'erc-smiley)
- (add-hook 'erc-send-modify-hook 'erc-smiley))
- ((remove-hook 'erc-insert-modify-hook 'erc-smiley)
- (remove-hook 'erc-send-modify-hook 'erc-smiley)))
+ ((add-hook 'erc-insert-modify-hook #'erc-smiley)
+ (add-hook 'erc-send-modify-hook #'erc-smiley))
+ ((remove-hook 'erc-insert-modify-hook #'erc-smiley)
+ (remove-hook 'erc-send-modify-hook #'erc-smiley)))
(defun erc-smiley ()
"Smilify a region.
@@ -547,8 +557,8 @@ This function should be used with `erc-insert-modify-hook'."
;; Unmorse
(define-erc-module unmorse nil
"This mode causes morse code in the current channel to be unmorsed."
- ((add-hook 'erc-insert-modify-hook 'erc-unmorse))
- ((remove-hook 'erc-insert-modify-hook 'erc-unmorse)))
+ ((add-hook 'erc-insert-modify-hook #'erc-unmorse))
+ ((remove-hook 'erc-insert-modify-hook #'erc-unmorse)))
(defun erc-unmorse ()
"Unmorse some text.
diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el
index 8ff548de29d..31e59a6d3e4 100644
--- a/lisp/erc/erc-ibuffer.el
+++ b/lisp/erc/erc-ibuffer.el
@@ -1,4 +1,4 @@
-;;; erc-ibuffer.el --- ibuffer integration with ERC
+;;; erc-ibuffer.el --- ibuffer integration with ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
@@ -39,20 +39,16 @@
(defcustom erc-ibuffer-keyword-char ?k
"Char used to indicate a channel which had keyword traffic lately (hidden)."
- :group 'erc-ibuffer
:type 'character)
(defcustom erc-ibuffer-pal-char ?p
"Char used to indicate a channel which had pal traffic lately (hidden)."
- :group 'erc-ibuffer
:type 'character)
(defcustom erc-ibuffer-fool-char ?f
"Char used to indicate a channel which had fool traffic lately (hidden)."
- :group 'erc-ibuffer
:type 'character)
(defcustom erc-ibuffer-dangerous-host-char ?d
"Char used to indicate a channel which had dangerous-host traffic lately
\(hidden)."
- :group 'erc-ibuffer
:type 'character)
(define-ibuffer-filter erc-server
@@ -92,10 +88,14 @@
" "))
(define-ibuffer-column erc-server-name (:name "Server")
- (if (and erc-server-process (processp erc-server-process))
- (with-current-buffer (process-buffer erc-server-process)
- (or erc-server-announced-name erc-session-server))
- ""))
+ (or
+ (when (and erc-server-process (processp erc-server-process))
+ (let ((buffer (process-buffer erc-server-process)))
+ (if (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (or erc-server-announced-name erc-session-server))
+ "(closed)")))
+ ""))
(define-ibuffer-column erc-target (:name "Target")
(if (eq major-mode 'erc-mode)
@@ -149,7 +149,7 @@
(if (and (eq major-mode 'erc-mode)
(or (> (length erc-channel-modes) 0)
erc-channel-user-limit))
- (concat (apply 'concat
+ (concat (apply #'concat
"(+" erc-channel-modes)
(if erc-channel-user-limit
(format "l %d" erc-channel-user-limit)
@@ -177,6 +177,7 @@
(defvar erc-ibuffer-limit-map nil
"Prefix keymap to use for ERC related limiting.")
(define-prefix-command 'erc-ibuffer-limit-map)
+;; FIXME: Where is `ibuffer-limit-by-erc-server' defined?
(define-key 'erc-ibuffer-limit-map (kbd "s") 'ibuffer-limit-by-erc-server)
(define-key ibuffer-mode-map (kbd "/ \C-e") 'erc-ibuffer-limit-map)
diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el
index 5f1aab1784b..3821e298cda 100644
--- a/lisp/erc/erc-identd.el
+++ b/lisp/erc/erc-identd.el
@@ -1,10 +1,10 @@
-;;; erc-identd.el --- RFC1413 (identd authentication protocol) server
+;;; erc-identd.el --- RFC1413 (identd authentication protocol) server -*- lexical-binding: t; -*-
;; Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, processes
+;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -50,7 +50,6 @@
`erc-identd-start'.
This can be either a string or a number."
- :group 'erc-identd
:type '(choice (const :tag "None" nil)
(integer :tag "Port number")
(string :tag "Port string")))
@@ -58,10 +57,10 @@ This can be either a string or a number."
;;;###autoload(autoload 'erc-identd-mode "erc-identd")
(define-erc-module identd nil
"This mode launches an identd server on port 8113."
- ((add-hook 'erc-connect-pre-hook 'erc-identd-quickstart)
- (add-hook 'erc-disconnected-hook 'erc-identd-stop))
- ((remove-hook 'erc-connect-pre-hook 'erc-identd-quickstart)
- (remove-hook 'erc-disconnected-hook 'erc-identd-stop)))
+ ((add-hook 'erc-connect-pre-hook #'erc-identd-quickstart)
+ (add-hook 'erc-disconnected-hook #'erc-identd-stop))
+ ((remove-hook 'erc-connect-pre-hook #'erc-identd-quickstart)
+ (remove-hook 'erc-disconnected-hook #'erc-identd-stop)))
(defun erc-identd-filter (proc string)
"This filter implements RFC1413 (identd authentication protocol)."
@@ -95,16 +94,16 @@ system."
:buffer nil
:host 'local :service port
:server t :noquery t :nowait t
- :filter 'erc-identd-filter))
+ :filter #'erc-identd-filter))
(set-process-query-on-exit-flag erc-identd-process nil))
-(defun erc-identd-quickstart (&rest ignored)
+(defun erc-identd-quickstart (&rest _ignored)
"Start the identd server with the default port.
The default port is specified by `erc-identd-port'."
(erc-identd-start))
;;;###autoload
-(defun erc-identd-stop (&rest ignore)
+(defun erc-identd-stop (&rest _ignore)
(interactive)
(when erc-identd-process
(delete-process erc-identd-process)
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index 1a2d8e2755f..dcf6db7407a 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -1,4 +1,4 @@
-;;; erc-imenu.el -- Imenu support for ERC
+;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
;; Inc.
@@ -71,15 +71,13 @@ Don't rely on this function, read it first!"
(message-alist '())
(mode-change-alist '())
(topic-change-alist '())
- prev-pos)
+ ) ;; prev-pos
(goto-char (point-max))
- (imenu-progress-message prev-pos 0)
(while (if (bolp)
(> (forward-line -1)
-1)
(progn (forward-line 0)
t))
- (imenu-progress-message prev-pos nil t)
(save-match-data
(when (looking-at (concat (regexp-quote erc-notice-prefix)
"\\(.+\\)$"))
@@ -108,7 +106,8 @@ Don't rely on this function, read it first!"
"^\\(\\S-+\\) (.+) has set the topic for \\S-+: \\(.*\\)$"
notice-text)
(push (cons (concat (match-string 1 notice-text) ": "
- (match-string 2 notice-text)) pos)
+ (match-string 2 notice-text))
+ pos)
topic-change-alist)))))
(when (looking-at "<\\(\\S-+\\)> \\(.+\\)$")
(let ((from (match-string 1))
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index 52304272ee1..2ad9c8bd941 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -1,10 +1,10 @@
-;;; erc-join.el --- autojoin channels on connect and reconnects
+;;; erc-join.el --- autojoin channels on connect and reconnects -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2004, 2006-2021 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: irc
+;; Keywords: comm, irc
;; URL: https://www.emacswiki.org/emacs/ErcAutoJoin
;; This file is part of GNU Emacs.
@@ -42,14 +42,14 @@
;;;###autoload(autoload 'erc-autojoin-mode "erc-join" nil t)
(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)))
+ ((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)))
(defcustom erc-autojoin-channels-alist nil
"Alist of channels to autojoin on IRC networks.
@@ -70,7 +70,6 @@ keeps track of what channels you are on, and will join them
again when you get disconnected. When you restart Emacs, however,
those changes are lost, and the customization you saved the last
time is used again."
- :group 'erc-autojoin
:type '(repeat (cons :tag "Server"
(regexp :tag "Name")
(repeat :tag "Channels"
@@ -82,7 +81,6 @@ 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
:version "24.1"
:type '(choice (const :tag "On Connection" connect)
(const :tag "When Identified" ident)))
@@ -92,7 +90,6 @@ Any other value means the same as `connect'."
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
:version "24.1"
:type 'integer)
@@ -102,18 +99,16 @@ If non-nil, and a channel on the server a.b.c is joined, then
only b.c is used as the server for `erc-autojoin-channels-alist'.
This is important for networks that redirect you to other
servers, presumably in the same domain."
- :group 'erc-autojoin
:type 'boolean)
-(defvar erc--autojoin-timer nil)
-(make-variable-buffer-local 'erc--autojoin-timer)
+(defvar-local erc--autojoin-timer nil)
(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)))
+ (cancel-timer erc--autojoin-timer)))
(with-current-buffer buffer
;; Don't kick of another delayed autojoin or try to wait for
;; another ident response:
@@ -122,12 +117,12 @@ This is called from a timer set up by `erc-autojoin-channels'."
(erc-log "Delayed autojoin started (no ident success detected yet)")
(erc-autojoin-channels server nick))))
-(defun erc-autojoin-after-ident (network 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)))
+ (cancel-timer erc--autojoin-timer)))
(when (eq erc-autojoin-timing 'ident)
(let ((server (or erc-session-server erc-server-announced-name))
(joined (mapcar (lambda (buf)
@@ -150,21 +145,23 @@ This function is run from `erc-nickserv-identified-hook'."
(when (> erc-autojoin-delay 0)
(setq erc--autojoin-timer
(run-with-timer erc-autojoin-delay nil
- 'erc-autojoin-channels-delayed
+ #'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)
- (let ((server (or erc-session-server erc-server-announced-name)))
+ (let ((server (or erc-session-server erc-server-announced-name)))
+ (dolist (l erc-autojoin-channels-alist)
+ (when (string-match-p (car l) server)
(dolist (chan (cdr l))
- (let ((buffer (erc-get-buffer chan)))
- ;; Only auto-join the channels that we aren't already in
- ;; using a different nick.
+ (let ((buffer
+ (car (erc-buffer-filter
+ (lambda ()
+ (let ((current (erc-default-target)))
+ (and (stringp current)
+ (string-match-p (car l)
+ (or erc-session-server erc-server-announced-name))
+ (string-equal (erc-downcase chan)
+ (erc-downcase current)))))))))
(when (or (not buffer)
- ;; If the same channel is joined on another
- ;; server the best-effort is to just join
- (not (string-match (car l)
- (process-name erc-server-process)))
(not (with-current-buffer buffer
(erc-server-process-alive))))
(erc-server-join-channel server chan))))))))
diff --git a/lisp/erc/erc-lang.el b/lisp/erc/erc-lang.el
index b86a8d0be2b..136131ca36b 100644
--- a/lisp/erc/erc-lang.el
+++ b/lisp/erc/erc-lang.el
@@ -1,4 +1,4 @@
-;;; erc-lang.el --- provide the LANG command to ERC
+;;; erc-lang.el --- provide the LANG command to ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
@@ -6,7 +6,7 @@
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; Old-Version: 1.0.0
;; URL: https://www.emacswiki.org/emacs/ErcLang
-;; Keywords: comm languages processes
+;; Keywords: comm
;; This file is part of GNU Emacs.
diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el
index 1d576376d2b..31693a7b77a 100644
--- a/lisp/erc/erc-list.el
+++ b/lisp/erc/erc-list.el
@@ -59,25 +59,25 @@
;;;###autoload(autoload 'erc-list-mode "erc-list")
(define-erc-module list nil
"List channels nicely in a separate buffer."
- ((remove-hook 'erc-server-321-functions 'erc-server-321-message)
- (remove-hook 'erc-server-322-functions 'erc-server-322-message))
+ ((remove-hook 'erc-server-321-functions #'erc-server-321-message)
+ (remove-hook 'erc-server-322-functions #'erc-server-322-message))
((erc-with-all-buffers-of-server nil
#'erc-open-server-buffer-p
- (remove-hook 'erc-server-322-functions 'erc-list-handle-322 t))
- (add-hook 'erc-server-321-functions 'erc-server-321-message t)
- (add-hook 'erc-server-322-functions 'erc-server-322-message t)))
+ (remove-hook 'erc-server-322-functions #'erc-list-handle-322 t))
+ (add-hook 'erc-server-321-functions #'erc-server-321-message t)
+ (add-hook 'erc-server-322-functions #'erc-server-322-message t)))
;; Format a record for display.
(defun erc-list-make-string (channel users topic)
(concat
channel
- (erc-propertize " "
- 'display (list 'space :align-to erc-list-nusers-column)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display (list 'space :align-to erc-list-nusers-column)
+ 'face 'fixed-pitch)
users
- (erc-propertize " "
- 'display (list 'space :align-to erc-list-topic-column)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display (list 'space :align-to erc-list-topic-column)
+ 'face 'fixed-pitch)
topic))
;; Insert a record into the list buffer.
@@ -126,36 +126,36 @@
(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)
+ (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.")
(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 [header-line mouse-1] #'erc-list-menu-sort-by-column)
(define-key map [follow-link] 'mouse-face)
map)
"Local keymap for ERC list menu mode sorting buttons.")
;; Helper function that makes a buttonized column header.
(defun erc-list-button (title column)
- (erc-propertize title
- 'column-number column
- 'help-echo "mouse-1: sort by column"
- 'mouse-face 'header-line-highlight
- 'keymap erc-list-menu-sort-button-map))
+ (propertize title
+ 'column-number column
+ 'help-echo "mouse-1: sort by column"
+ 'mouse-face 'header-line-highlight
+ 'keymap erc-list-menu-sort-button-map))
(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
- (erc-propertize " "
- 'display '(space :align-to 0)
- 'face 'fixed-pitch)
+ (propertize " "
+ 'display '(space :align-to 0)
+ 'face 'fixed-pitch)
(erc-list-make-string (erc-list-button "Channel" 1)
(erc-list-button "# Users" 2)
"Topic")))
@@ -181,22 +181,22 @@
(defun erc-list-install-322-handler (server-buffer)
(with-current-buffer server-buffer
;; Arrange for 322 responses to insert into our buffer.
- (add-hook 'erc-server-322-functions 'erc-list-handle-322 t t)
+ (add-hook 'erc-server-322-functions #'erc-list-handle-322 t t)
;; Arrange for 323 (end of list) to end this.
(erc-once-with-server-event
323
(lambda (_proc _parsed)
- (remove-hook 'erc-server-322-functions 'erc-list-handle-322 t)))
+ (remove-hook 'erc-server-322-functions #'erc-list-handle-322 t)))
;; Find the list buffer, empty it, and display it.
- (set (make-local-variable 'erc-list-buffer)
- (get-buffer-create (concat "*Channels of "
- erc-server-announced-name
- "*")))
+ (setq-local erc-list-buffer
+ (get-buffer-create (concat "*Channels of "
+ erc-server-announced-name
+ "*")))
(with-current-buffer erc-list-buffer
(erc-list-menu-mode)
(setq buffer-read-only nil)
(erase-buffer)
- (set (make-local-variable 'erc-list-server-buffer) server-buffer)
+ (setq-local erc-list-server-buffer server-buffer)
(setq buffer-read-only t))
(pop-to-buffer erc-list-buffer))
t)
@@ -211,7 +211,7 @@ should usually be one or more channels, separated by commas.
Please note that this function only works with IRC servers which conform
to RFC and send the LIST header (#321) at start of list transmission."
(erc-with-server-buffer
- (set (make-local-variable 'erc-list-last-argument) line)
+ (setq-local erc-list-last-argument line)
(erc-once-with-server-event
321
(let ((buf (current-buffer)))
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index c3075f5bba8..ddd00afd73b 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -1,11 +1,11 @@
-;;; erc-log.el --- Logging facilities for ERC.
+;;; erc-log.el --- Logging facilities for ERC. -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
;; Author: Lawrence Mitchell <wence@gmx.li>
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; URL: https://www.emacswiki.org/emacs/ErcLogging
-;; Keywords: IRC, chat, client, Internet, logging
+;; Keywords: comm, IRC, chat, client, Internet, logging
;; Created 2003-04-26
;; Logging code taken from erc.el and modified to use markers.
@@ -112,7 +112,6 @@ SERVER and PORT are the parameters that were used to connect to BUFFERs
If you want to write logs into different directories, make a
custom function which returns the directory part and set
`erc-log-channels-directory' to its name."
- :group 'erc-log
:type '(choice (const :tag "#channel!nick@server:port.txt"
erc-generate-log-file-name-long)
(const :tag "#channel!nick@network.txt"
@@ -124,7 +123,6 @@ custom function which returns the directory part and set
(defcustom erc-truncate-buffer-on-save nil
"Erase the contents of any ERC (channel, query, server) buffer when it is saved."
- :group 'erc-log
:type 'boolean)
(defcustom erc-enable-logging t
@@ -138,7 +136,6 @@ This variable is buffer local. Setting it via \\[customize] sets the
default value.
Log files are stored in `erc-log-channels-directory'."
- :group 'erc-log
:type '(choice boolean
function))
(make-variable-buffer-local 'erc-enable-logging)
@@ -153,14 +150,12 @@ If this is the name of a function, the function will be called
with the buffer, target, nick, server, and port arguments. See
`erc-generate-log-file-name-function' for a description of these
arguments."
- :group 'erc-log
:type '(choice directory
(function "Function")
(const :tag "Disable logging" nil)))
(defcustom erc-log-insert-log-on-open nil
"Insert log file contents into the buffer if a log file exists."
- :group 'erc-log
:type 'boolean)
(defcustom erc-save-buffer-on-part t
@@ -168,7 +163,6 @@ arguments."
If you set this to nil, you may want to enable both
`erc-log-write-after-send' and `erc-log-write-after-insert'."
- :group 'erc-log
:type 'boolean)
(defcustom erc-save-queries-on-quit t
@@ -176,7 +170,6 @@ If you set this to nil, you may want to enable both
If you set this to nil, you may want to enable both
`erc-log-write-after-send' and `erc-log-write-after-insert'."
- :group 'erc-log
:type 'boolean)
(defcustom erc-log-write-after-send nil
@@ -184,7 +177,6 @@ If you set this to nil, you may want to enable both
If you set this to nil, you may want to enable both
`erc-save-buffer-on-part' and `erc-save-queries-on-quit'."
- :group 'erc-log
:type 'boolean)
(defcustom erc-log-write-after-insert nil
@@ -193,7 +185,6 @@ logged ERC buffer.
If you set this to nil, you may want to enable both
`erc-save-buffer-on-part' and `erc-save-queries-on-quit'."
- :group 'erc-log
:type 'boolean)
(defcustom erc-log-file-coding-system 'emacs-mule
@@ -201,15 +192,13 @@ If you set this to nil, you may want to enable both
This should ideally, be a \"catch-all\" coding system, like
`emacs-mule', or `iso-2022-7bit'."
- :type 'coding-system
- :group 'erc-log)
+ :type 'coding-system)
(defcustom erc-log-filter-function nil
"If non-nil, pass text through the given function before writing it to
a log file.
The function should take one argument, which is the text to filter."
- :group 'erc-log
:type '(choice (function "Function")
(const :tag "No filtering" nil)))
@@ -232,31 +221,31 @@ also be a predicate function. To only log when you are not set away, use:
(null (erc-away-time)))))"
;; enable
((when erc-log-write-after-insert
- (add-hook 'erc-insert-post-hook 'erc-save-buffer-in-logs))
+ (add-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs))
(when erc-log-write-after-send
- (add-hook 'erc-send-post-hook 'erc-save-buffer-in-logs))
- (add-hook 'erc-kill-buffer-hook 'erc-save-buffer-in-logs)
- (add-hook 'erc-kill-channel-hook 'erc-save-buffer-in-logs)
- (add-hook 'kill-emacs-hook 'erc-log-save-all-buffers)
- (add-hook 'erc-quit-hook 'erc-conditional-save-queries)
- (add-hook 'erc-part-hook 'erc-conditional-save-buffer)
+ (add-hook 'erc-send-post-hook #'erc-save-buffer-in-logs))
+ (add-hook 'erc-kill-buffer-hook #'erc-save-buffer-in-logs)
+ (add-hook 'erc-kill-channel-hook #'erc-save-buffer-in-logs)
+ (add-hook 'kill-emacs-hook #'erc-log-save-all-buffers)
+ (add-hook 'erc-quit-hook #'erc-conditional-save-queries)
+ (add-hook 'erc-part-hook #'erc-conditional-save-buffer)
;; append, so that 'erc-initialize-log-marker runs first
- (add-hook 'erc-connect-pre-hook 'erc-log-setup-logging 'append)
+ (add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append)
(dolist (buffer (erc-buffer-list))
(erc-log-setup-logging buffer)))
;; disable
- ((remove-hook 'erc-insert-post-hook 'erc-save-buffer-in-logs)
- (remove-hook 'erc-send-post-hook 'erc-save-buffer-in-logs)
- (remove-hook 'erc-kill-buffer-hook 'erc-save-buffer-in-logs)
- (remove-hook 'erc-kill-channel-hook 'erc-save-buffer-in-logs)
- (remove-hook 'kill-emacs-hook 'erc-log-save-all-buffers)
- (remove-hook 'erc-quit-hook 'erc-conditional-save-queries)
- (remove-hook 'erc-part-hook 'erc-conditional-save-buffer)
- (remove-hook 'erc-connect-pre-hook 'erc-log-setup-logging)
+ ((remove-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs)
+ (remove-hook 'erc-send-post-hook #'erc-save-buffer-in-logs)
+ (remove-hook 'erc-kill-buffer-hook #'erc-save-buffer-in-logs)
+ (remove-hook 'erc-kill-channel-hook #'erc-save-buffer-in-logs)
+ (remove-hook 'kill-emacs-hook #'erc-log-save-all-buffers)
+ (remove-hook 'erc-quit-hook #'erc-conditional-save-queries)
+ (remove-hook 'erc-part-hook #'erc-conditional-save-buffer)
+ (remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging)
(dolist (buffer (erc-buffer-list))
(erc-log-disable-logging buffer))))
-(define-key erc-mode-map "\C-c\C-l" 'erc-save-buffer-in-logs)
+(define-key erc-mode-map "\C-c\C-l" #'erc-save-buffer-in-logs)
;;; functionality referenced from erc.el
(defun erc-log-setup-logging (buffer)
@@ -267,7 +256,7 @@ The current buffer is given by BUFFER."
(with-current-buffer buffer
(auto-save-mode -1)
(setq buffer-file-name nil)
- (erc-set-write-file-functions '(erc-save-buffer-in-logs))
+ (add-hook 'write-file-functions #'erc-save-buffer-in-logs nil t)
(when erc-log-insert-log-on-open
(ignore-errors
(save-excursion
@@ -334,7 +323,7 @@ This will not work with full paths, only names.
Any unsafe characters in the name are replaced with \"!\". The
filename is downcased."
- (downcase (erc-replace-regexp-in-string
+ (downcase (replace-regexp-in-string
"[/\\]" "!" (convert-standard-filename filename))))
(defun erc-current-logfile (&optional buffer)
@@ -357,13 +346,13 @@ The result is converted to lowercase, as IRC is case-insensitive."
buffer target nick server port)
erc-log-channels-directory)))))
-(defun erc-generate-log-file-name-with-date (buffer &rest ignore)
+(defun erc-generate-log-file-name-with-date (buffer &rest _ignore)
"This function computes a short log file name.
The name of the log file is composed of BUFFER and the current date.
This function is a possible value for `erc-generate-log-file-name-function'."
(concat (buffer-name buffer) "-" (format-time-string "%Y-%m-%d") ".txt"))
-(defun erc-generate-log-file-name-short (buffer &rest ignore)
+(defun erc-generate-log-file-name-short (buffer &rest _ignore)
"This function computes a short log file name.
In fact, it only uses the buffer name of the BUFFER argument, so
you can affect that using `rename-buffer' and the-like. This
@@ -371,7 +360,7 @@ function is a possible value for
`erc-generate-log-file-name-function'."
(concat (buffer-name buffer) ".txt"))
-(defun erc-generate-log-file-name-long (buffer target nick server port)
+(defun erc-generate-log-file-name-long (_buffer target nick server port)
"Generates a log-file name in the way ERC always did it.
This results in a file name of the form #channel!nick@server:port.txt.
This function is a possible value for `erc-generate-log-file-name-function'."
@@ -385,7 +374,7 @@ This function is a possible value for `erc-generate-log-file-name-function'."
(declare-function erc-network-name "erc-networks" ())
-(defun erc-generate-log-file-name-network (buffer target nick server port)
+(defun erc-generate-log-file-name-network (buffer target nick server _port)
"Generates a log-file name using the network name rather than server name.
This results in a file name of the form #channel!nick@network.txt.
This function is a possible value for `erc-generate-log-file-name-function'."
@@ -414,8 +403,7 @@ You can save every individual message by putting this function on
(or buffer (setq buffer (current-buffer)))
(when (erc-logging-enabled buffer)
(let ((file (erc-current-logfile buffer))
- (coding-system erc-log-file-coding-system)
- (inhibit-clash-detection t)) ; needed for XEmacs
+ (coding-system erc-log-file-coding-system))
(save-excursion
(with-current-buffer buffer
(save-restriction
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index b5200418eb7..43fbca3e666 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -1,10 +1,10 @@
-;;; erc-match.el --- Highlight messages matching certain regexps
+;;; erc-match.el --- Highlight messages matching certain regexps -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: Andreas Fuchs <asf@void.at>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, faces
+;; Keywords: comm
;; URL: https://www.emacswiki.org/emacs/ErcMatch
;; This file is part of GNU Emacs.
@@ -52,19 +52,17 @@ they are hidden or highlighted. This is controlled via the variables
`erc-current-nick-highlight-type'. For all these highlighting types,
you can decide whether the entire message or only the sending nick is
highlighted."
- ((add-hook 'erc-insert-modify-hook 'erc-match-message 'append))
- ((remove-hook 'erc-insert-modify-hook 'erc-match-message)))
+ ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append))
+ ((remove-hook 'erc-insert-modify-hook #'erc-match-message)))
;; Remaining customizations
(defcustom erc-pals nil
"List of pals on IRC."
- :group 'erc-match
:type '(repeat regexp))
(defcustom erc-fools nil
"List of fools on IRC."
- :group 'erc-match
:type '(repeat regexp))
(defcustom erc-keywords nil
@@ -72,14 +70,12 @@ highlighted."
Each entry in the list is either a regexp, or a cons cell with the
regexp in the car and the face to use in the cdr. If no face is
specified, `erc-keyword-face' is used."
- :group 'erc-match
:type '(repeat (choice regexp
(list regexp face))))
(defcustom erc-dangerous-hosts nil
"List of regexps for hosts to highlight.
Useful to mark nicks from dangerous hosts."
- :group 'erc-match
:type '(repeat regexp))
(defcustom erc-current-nick-highlight-type 'keyword
@@ -94,14 +90,16 @@ The following values are allowed:
`nick-or-keyword' - highlight the nick of the user who typed your nickname,
or all instances of the current nickname if there was
no sending user
- `all' - highlight the entire message where current nickname occurs
+ `message' - highlight the entire message where current nickname occurs
+ `all' - highlight the entire message (including the nick) where
+ current nickname occurs
Any other value disables highlighting of current nickname altogether."
- :group 'erc-match
:type '(choice (const nil)
(const nick)
(const keyword)
(const nick-or-keyword)
+ (const message)
(const all)))
(defcustom erc-pal-highlight-type 'nick
@@ -110,14 +108,16 @@ See `erc-pals'.
The following values are allowed:
- nil - do not highlight the message at all
- `nick' - highlight pal's nickname only
- `all' - highlight the entire message from pal
+ nil - do not highlight the message at all
+ `nick' - highlight pal's nickname only
+ `message' - highlight the entire message from pal
+ `all' - highlight the entire message (including the nick)
+ from pal
Any other value disables pal highlighting altogether."
- :group 'erc-match
:type '(choice (const nil)
(const nick)
+ (const message)
(const all)))
(defcustom erc-fool-highlight-type 'nick
@@ -126,14 +126,16 @@ See `erc-fools'.
The following values are allowed:
- nil - do not highlight the message at all
- `nick' - highlight fool's nickname only
- `all' - highlight the entire message from fool
+ nil - do not highlight the message at all
+ `nick' - highlight fool's nickname only
+ `message' - highlight the entire message from fool
+ `all' - highlight the entire message (including the nick)
+ from fool
Any other value disables fool highlighting altogether."
- :group 'erc-match
:type '(choice (const nil)
(const nick)
+ (const message)
(const all)))
(defcustom erc-keyword-highlight-type 'keyword
@@ -143,12 +145,14 @@ See variable `erc-keywords'.
The following values are allowed:
`keyword' - highlight keyword only
- `all' - highlight the entire message containing keyword
+ `message' - highlight the entire message containing keyword
+ `all' - highlight the entire message (including the nick)
+ containing keyword
Any other value disables keyword highlighting altogether."
- :group 'erc-match
:type '(choice (const nil)
(const keyword)
+ (const message)
(const all)))
(defcustom erc-dangerous-host-highlight-type 'nick
@@ -157,13 +161,15 @@ See `erc-dangerous-hosts'.
The following values are allowed:
- `nick' - highlight nick from dangerous-host only
- `all' - highlight the entire message from dangerous-host
+ `nick' - highlight nick from dangerous-host only
+ `message' - highlight the entire message from dangerous-host
+ `all' - highlight the entire message (including the nick)
+ from dangerous-host
Any other value disables dangerous-host highlighting altogether."
- :group 'erc-match
:type '(choice (const nil)
(const nick)
+ (const message)
(const all)))
@@ -178,7 +184,6 @@ Valid match type keys are:
The other element of each cons pair in this list is the buffer name to
use for the logged message."
- :group 'erc-match
:type '(repeat (cons (choice :tag "Key"
(const keyword)
(const pal)
@@ -192,7 +197,6 @@ use for the logged message."
When nil, don't log any matched messages.
When t, log messages.
When `away', log messages only when away."
- :group 'erc-match
:type '(choice (const nil)
(const away)
(const t)))
@@ -207,14 +211,12 @@ will be formatted. The various format specs are:
%u Nickname!user@host of sender
%c Channel in which this was received
%m Message"
- :group 'erc-match
:type 'string)
(defcustom erc-beep-match-types '(current-nick)
"Types of matches to beep for when a match occurs.
The function `erc-beep-on-match' needs to be added to `erc-text-matched-hook'
for beeping to work."
- :group 'erc-match
:type '(choice (repeat :tag "Beep on match" (choice
(const current-nick)
(const keyword)
@@ -229,14 +231,12 @@ Functions in this hook are passed as arguments:
\(match-type nick!user@host message) where MATCH-TYPE is a symbol of:
current-nick, keyword, pal, dangerous-host, fool."
:options '(erc-log-matches erc-hide-fools erc-beep-on-match)
- :group 'erc-match
:type 'hook)
(defcustom erc-match-exclude-server-buffer nil
"If true, don't perform match on the server buffer; this is
useful for excluding all the things like MOTDs from the server
and other miscellaneous functions."
- :group 'erc-match
:version "24.3"
:type 'boolean)
@@ -375,7 +375,7 @@ car is the string."
(interactive)
(erc-remove-entry-from-list 'erc-dangerous-hosts "Delete dangerous-host: "))
-(defun erc-match-current-nick-p (nickuserhost msg)
+(defun erc-match-current-nick-p (_nickuserhost msg)
"Check whether the current nickname is in MSG.
NICKUSERHOST will be ignored."
(with-syntax-table erc-match-syntax-table
@@ -385,7 +385,7 @@ NICKUSERHOST will be ignored."
"\\b")
msg))))
-(defun erc-match-pal-p (nickuserhost msg)
+(defun erc-match-pal-p (nickuserhost _msg)
"Check whether NICKUSERHOST is in `erc-pals'.
MSG will be ignored."
(and nickuserhost
@@ -397,7 +397,7 @@ MSG will be ignored."
(or (erc-list-match erc-fools nickuserhost)
(erc-match-directed-at-fool-p msg))))
-(defun erc-match-keyword-p (nickuserhost msg)
+(defun erc-match-keyword-p (_nickuserhost msg)
"Check whether any keyword of `erc-keywords' matches for MSG.
NICKUSERHOST will be ignored."
(and msg
@@ -409,7 +409,7 @@ NICKUSERHOST will be ignored."
erc-keywords)
msg)))
-(defun erc-match-dangerous-host-p (nickuserhost msg)
+(defun erc-match-dangerous-host-p (nickuserhost _msg)
"Check whether NICKUSERHOST is in `erc-dangerous-hosts'.
MSG will be ignored."
(and nickuserhost
@@ -442,26 +442,25 @@ Use this defun with `erc-insert-modify-hook'."
(nickuserhost (erc-get-parsed-vector-nick vector))
(nickname (and nickuserhost
(nth 0 (erc-parse-user nickuserhost))))
- (old-pt (point))
+ ;; (old-pt (point))
(nick-beg (and nickname
(re-search-forward (regexp-quote nickname)
(point-max) t)
(match-beginning 0)))
(nick-end (when nick-beg
(match-end 0)))
- (message (buffer-substring
- (if (and nick-end
- (<= (+ 2 nick-end) (point-max)))
- ;; Message starts 2 characters after the nick
- ;; except for CTCP ACTION messages. Nick
- ;; surrounded by angle brackets only in normal
- ;; messages.
- (+ nick-end
- (if (eq ?> (char-after nick-end))
- 2
- 1))
- (point-min))
- (point-max))))
+ (message-beg (if (and nick-end
+ (<= (+ 2 nick-end) (point-max)))
+ ;; Message starts 2 characters after the
+ ;; nick except for CTCP ACTION messages.
+ ;; Nick surrounded by angle brackets only in
+ ;; normal messages.
+ (+ nick-end
+ (if (eq ?> (char-after nick-end))
+ 2
+ 1))
+ (point-min)))
+ (message (buffer-substring message-beg (point-max))))
(when (and vector
(not (and erc-match-exclude-server-buffer
(erc-server-buffer-p))))
@@ -470,11 +469,12 @@ Use this defun with `erc-insert-modify-hook'."
(goto-char (point-min))
(let* ((match-prefix (concat "erc-" match-type))
(match-pred (intern (concat "erc-match-" match-type "-p")))
- (match-htype (eval (intern (concat match-prefix
- "-highlight-type"))))
+ (match-htype (symbol-value (intern (concat match-prefix
+ "-highlight-type"))))
(match-regex (if (string= match-type "current-nick")
(regexp-quote (erc-current-nick))
- (eval (intern (concat match-prefix "s")))))
+ (symbol-value
+ (intern (concat match-prefix "s")))))
(match-face (intern (concat match-prefix "-face"))))
(when (funcall match-pred nickuserhost message)
(cond
@@ -498,7 +498,12 @@ Use this defun with `erc-insert-modify-hook'."
(while (re-search-forward match-regex nil t)
(erc-put-text-property (match-beginning 0) (match-end 0)
'font-lock-face match-face))))
- ;; Highlight the whole message
+ ;; Highlight the whole message (not including the nick)
+ ((eq match-htype 'message)
+ (erc-put-text-property
+ message-beg (point-max)
+ 'font-lock-face match-face (current-buffer)))
+ ;; Highlight the whole message (including the nick)
((eq match-htype 'all)
(erc-put-text-property
(point-min) (point-max)
@@ -555,16 +560,15 @@ See `erc-log-match-format'."
(and (eq erc-log-matches-flag 'away)
(erc-away-time)))
match-buffer-name)
- (let ((line (format-spec erc-log-match-format
- (format-spec-make
- ?n nick
- ?t (format-time-string
- (or (and (boundp 'erc-timestamp-format)
- erc-timestamp-format)
- "[%Y-%m-%d %H:%M] "))
- ?c (or (erc-default-target) "")
- ?m message
- ?u nickuserhost))))
+ (let ((line (format-spec
+ erc-log-match-format
+ `((?n . ,nick)
+ (?t . ,(format-time-string
+ (or (bound-and-true-p erc-timestamp-format)
+ "[%Y-%m-%d %H:%M] ")))
+ (?c . ,(or (erc-default-target) ""))
+ (?m . ,message)
+ (?u . ,nickuserhost)))))
(with-current-buffer (erc-log-matches-make-buffer match-buffer-name)
(let ((inhibit-read-only t))
(goto-char (point-max))
@@ -578,12 +582,12 @@ See `erc-log-match-format'."
(with-current-buffer buffer
(unless buffer-already
(insert " == Type \"q\" to dismiss messages ==\n")
- (erc-view-mode-enter nil (lambda (buffer)
- (when (y-or-n-p "Discard messages? ")
- (kill-buffer buffer)))))
+ (view-mode-enter nil (lambda (buffer)
+ (when (y-or-n-p "Discard messages? ")
+ (kill-buffer buffer)))))
buffer)))
-(defun erc-log-matches-come-back (proc parsed)
+(defun erc-log-matches-come-back (_proc _parsed)
"Display a notice that messages were logged while away."
(when (and (erc-away-time)
(eq erc-log-matches-flag 'away))
@@ -611,7 +615,7 @@ See `erc-log-match-format'."
nil)
; This handler must be run _before_ erc-process-away is.
-(add-hook 'erc-server-305-functions 'erc-log-matches-come-back nil)
+(add-hook 'erc-server-305-functions #'erc-log-matches-come-back nil)
(defun erc-go-to-log-matches-buffer ()
"Interactively open an erc-log-matches buffer."
@@ -624,9 +628,9 @@ See `erc-log-match-format'."
(get-buffer (car buffer-cons))))))
(switch-to-buffer buffer-name)))
-(define-key erc-mode-map "\C-c\C-k" 'erc-go-to-log-matches-buffer)
+(define-key erc-mode-map "\C-c\C-k" #'erc-go-to-log-matches-buffer)
-(defun erc-hide-fools (match-type nickuserhost message)
+(defun erc-hide-fools (match-type _nickuserhost _message)
"Hide foolish comments.
This function should be called from `erc-text-matched-hook'."
(when (eq match-type 'fool)
@@ -634,7 +638,7 @@ This function should be called from `erc-text-matched-hook'."
'(invisible intangible)
(current-buffer))))
-(defun erc-beep-on-match (match-type nickuserhost message)
+(defun erc-beep-on-match (match-type _nickuserhost _message)
"Beep when text matches.
This function is meant to be called from `erc-text-matched-hook'."
(when (member match-type erc-beep-match-types)
diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el
index 0737a26e5d0..1bee6ff2a67 100644
--- a/lisp/erc/erc-menu.el
+++ b/lisp/erc/erc-menu.el
@@ -1,10 +1,10 @@
-;; erc-menu.el -- Menu-bar definitions for ERC
+;;; erc-menu.el --- Menu-bar definitions for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004-2021 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, processes, menu
+;; Keywords: comm, menu
;; This file is part of GNU Emacs.
@@ -28,7 +28,6 @@
;;; Code:
(require 'erc)
-(require 'easymenu)
(defgroup erc-menu nil
"ERC menu support."
@@ -111,25 +110,22 @@ ERC menu yet.")
(define-erc-module menu nil
"Enable a menu in ERC buffers."
((unless erc-menu-defined
- ;; make sure the menu only gets defined once, since Emacs 22
+ ;; make sure the menu only gets defined once, since Emacs
;; activates it immediately
(easy-menu-define erc-menu erc-mode-map "ERC menu" erc-menu-definition)
- (setq erc-menu-defined t))
- (erc-menu-add))
- ((erc-menu-remove)
- ;; `easy-menu-remove' is a no-op in Emacs 22
+ (setq erc-menu-defined t)))
+ (;; `easy-menu-remove' is a no-op in Emacs
(message "You might have to restart Emacs to remove the ERC menu")))
-;; silence byte-compiler warning
-(defvar erc-menu)
-
(defun erc-menu-add ()
"Add the ERC menu to the current buffer."
- (easy-menu-add erc-menu erc-mode-map))
+ (declare (obsolete nil "28.1"))
+ nil)
(defun erc-menu-remove ()
"Remove the ERC menu from the current buffer."
- (easy-menu-remove erc-menu))
+ (declare (obsolete nil "28.1"))
+ nil)
(provide 'erc-menu)
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el
index 9fd3cfe1cc4..9cfb947003c 100644
--- a/lisp/erc/erc-netsplit.el
+++ b/lisp/erc/erc-netsplit.el
@@ -1,4 +1,4 @@
-;;; erc-netsplit.el --- Reduce JOIN/QUIT messages on netsplits
+;;; erc-netsplit.el --- Reduce JOIN/QUIT messages on netsplits -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2004, 2006-2021 Free Software Foundation, Inc.
@@ -42,30 +42,27 @@ netsplits, so that it can filter the JOIN messages on a netjoin too."
(define-erc-module netsplit nil
"This mode hides quit/join messages if a netsplit occurs."
((erc-netsplit-install-message-catalogs)
- (add-hook 'erc-server-JOIN-functions 'erc-netsplit-JOIN)
- (add-hook 'erc-server-MODE-functions 'erc-netsplit-MODE)
- (add-hook 'erc-server-QUIT-functions 'erc-netsplit-QUIT)
- (add-hook 'erc-timer-hook 'erc-netsplit-timer))
- ((remove-hook 'erc-server-JOIN-functions 'erc-netsplit-JOIN)
- (remove-hook 'erc-server-MODE-functions 'erc-netsplit-MODE)
- (remove-hook 'erc-server-QUIT-functions 'erc-netsplit-QUIT)
- (remove-hook 'erc-timer-hook 'erc-netsplit-timer)))
+ (add-hook 'erc-server-JOIN-functions #'erc-netsplit-JOIN)
+ (add-hook 'erc-server-MODE-functions #'erc-netsplit-MODE)
+ (add-hook 'erc-server-QUIT-functions #'erc-netsplit-QUIT)
+ (add-hook 'erc-timer-hook #'erc-netsplit-timer))
+ ((remove-hook 'erc-server-JOIN-functions #'erc-netsplit-JOIN)
+ (remove-hook 'erc-server-MODE-functions #'erc-netsplit-MODE)
+ (remove-hook 'erc-server-QUIT-functions #'erc-netsplit-QUIT)
+ (remove-hook 'erc-timer-hook #'erc-netsplit-timer)))
(defcustom erc-netsplit-show-server-mode-changes-flag nil
"Set to t to enable display of server mode changes."
- :group 'erc-netsplit
:type 'boolean)
(defcustom erc-netsplit-debug nil
"If non-nil, debug messages will be shown in the sever buffer."
- :group 'erc-netsplit
:type 'boolean)
(defcustom erc-netsplit-regexp
"^[^ @!\"\n]+\\.[^ @!\n]+ [^ @!\n]+\\.[^ @!\"\n]+$"
"This regular expression should match quit reasons produced
by netsplits."
- :group 'erc-netsplit
:type 'regexp)
(defcustom erc-netsplit-hook nil
@@ -82,12 +79,11 @@ Args: PROC is the process the netjoin originated from and
:group 'erc-hooks
:type 'hook)
-(defvar erc-netsplit-list nil
+(defvar-local erc-netsplit-list nil
"This is a list of the form
\((\"a.b.c.d e.f.g\" TIMESTAMP FIRST-JOIN \"nick1\" ... \"nickn\") ...)
where FIRST-JOIN is t or nil, depending on whether or not the first
join from that split has been detected or not.")
-(make-variable-buffer-local 'erc-netsplit-list)
(defun erc-netsplit-install-message-catalogs ()
(erc-define-catalog
@@ -191,13 +187,13 @@ join from that split has been detected or not.")
(erc-display-message
nil 'notice 'active
'netsplit-wholeft ?s (car elt)
- ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ")
+ ?n (mapconcat #'erc-extract-nick (nthcdr 3 elt) " ")
?t (if (nth 2 elt)
"(joining)"
"")))))
t)
-(defalias 'erc-cmd-WL 'erc-cmd-WHOLEFT)
+(defalias 'erc-cmd-WL #'erc-cmd-WHOLEFT)
(provide 'erc-netsplit)
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index ac32b294d3c..54502b2df05 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -1,4 +1,4 @@
-;;; erc-networks.el --- IRC networks
+;;; erc-networks.el --- IRC networks -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004-2021 Free Software Foundation, Inc.
@@ -152,7 +152,7 @@
("EFnet: EU, PL, Warszawa" EFnet "irc.efnet.pl" 6667)
("EFnet: EU, RU, Moscow" EFnet "irc.rt.ru" ((6661 6669)))
("EFnet: EU, SE, Dalarna" EFnet "irc.du.se" ((6666 6669)))
- ("EFnet: EU, SE, Gothenberg" EFnet "irc.hemmet.chalmers.se" ((6666 7000)))
+ ("EFnet: EU, SE, Gothenburg" EFnet "irc.hemmet.chalmers.se" ((6666 7000)))
("EFnet: EU, SE, Sweden" EFnet "irc.light.se" 6667)
("EFnet: EU, UK, London (carrier)" EFnet "irc.carrier1.net.uk" ((6666 6669)))
("EFnet: EU, UK, London (demon)" EFnet "efnet.demon.co.uk" ((6665 6669)))
@@ -190,9 +190,9 @@
("Fraggers: Random server" Fraggers "irc.fraggers.co.uk" ((6661 6669) (7000 7001) ))
("FreedomChat: Random server" FreedomChat "chat.freedomchat.net" 6667)
("FreedomIRC: Random server" FreedomIRC "irc.freedomirc.net" 6667)
- ("Freenode: Random server" freenode "irc.freenode.net" 6667)
- ("Freenode: Random EU server" freenode "irc.eu.freenode.net" 6667)
- ("Freenode: Random US server" freenode "irc.us.freenode.net" 6667)
+ ("Freenode: Random server" freenode "chat.freenode.net" 6667)
+ ("Freenode: Random EU server" freenode "chat.eu.freenode.net" 6667)
+ ("Freenode: Random US server" freenode "chat.us.freenode.net" 6667)
("FunNet: Random server" FunNet "irc.funnet.org" 6667)
("Galaxynet: Random server" GalaxyNet "irc.galaxynet.org" ((6662 6668) 7000 ))
("Galaxynet: AU, NZ, Auckland" GalaxyNet "auckland.nz.galaxynet.org" ((6661 6669)))
@@ -450,7 +450,6 @@ NET is a symbol indicating to which network from `erc-networks-alist'
this server corresponds,
HOST is the servers hostname and
PORTS is either a number, a list of numbers, or a list of port ranges."
- :group 'erc-networks
:type '(alist :key-type (string :tag "Name")
:value-type
(group symbol (string :tag "Hostname")
@@ -722,7 +721,6 @@ MATCHER is used to find a corresponding network to a server while
connected to it. If it is regexp, it's used to match against
`erc-server-announced-name'. It can also be a function (predicate).
Then it is executed with the server buffer as current-buffer."
- :group 'erc-networks
:type '(repeat
(list :tag "Network"
(symbol :tag "Network name")
@@ -730,9 +728,8 @@ MATCHER is used to find a corresponding network to a server while
(regexp)
(const :tag "Network has no common server ending" nil)))))
-(defvar erc-network nil
+(defvar-local erc-network nil
"The name of the network you are connected to (a symbol).")
-(make-variable-buffer-local 'erc-network)
;; Functions:
@@ -764,32 +761,32 @@ Return the name of this server's network as a symbol."
(erc-with-server-buffer
(intern (downcase (symbol-name erc-network)))))
-(erc-make-obsolete 'erc-current-network 'erc-network
- "Obsolete since erc-networks 1.5")
+(make-obsolete 'erc-current-network 'erc-network
+ "Obsolete since erc-networks 1.5")
(defun erc-network-name ()
"Return the name of the current network as a string."
(erc-with-server-buffer (symbol-name erc-network)))
-(defun erc-set-network-name (proc parsed)
+(defun erc-set-network-name (_proc _parsed)
"Set `erc-network' to the value returned by `erc-determine-network'."
(unless erc-server-connected
(setq erc-network (erc-determine-network)))
nil)
-(defun erc-unset-network-name (nick ip reason)
+(defun erc-unset-network-name (_nick _ip _reason)
"Set `erc-network' to nil."
(setq erc-network nil)
nil)
(define-erc-module networks nil
"Provide data about IRC networks."
- ((add-hook 'erc-server-375-functions 'erc-set-network-name)
- (add-hook 'erc-server-422-functions 'erc-set-network-name)
- (add-hook 'erc-disconnected-hook 'erc-unset-network-name))
- ((remove-hook 'erc-server-375-functions 'erc-set-network-name)
- (remove-hook 'erc-server-422-functions 'erc-set-network-name)
- (remove-hook 'erc-disconnected-hook 'erc-unset-network-name)))
+ ((add-hook 'erc-server-375-functions #'erc-set-network-name)
+ (add-hook 'erc-server-422-functions #'erc-set-network-name)
+ (add-hook 'erc-disconnected-hook #'erc-unset-network-name))
+ ((remove-hook 'erc-server-375-functions #'erc-set-network-name)
+ (remove-hook 'erc-server-422-functions #'erc-set-network-name)
+ (remove-hook 'erc-disconnected-hook #'erc-unset-network-name)))
(defun erc-ports-list (ports)
"Return a list of PORTS.
@@ -820,7 +817,7 @@ As an example:
(let* ((completion-ignore-case t)
(net (intern
(completing-read "Network: "
- (erc-delete-dups
+ (delete-dups
(mapcar (lambda (x)
(list (symbol-name (nth 1 x))))
erc-server-alist)))))
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el
index 05767be42d7..1ed056c277d 100644
--- a/lisp/erc/erc-notify.el
+++ b/lisp/erc/erc-notify.el
@@ -42,20 +42,17 @@
(defcustom erc-notify-list nil
"List of nicknames you want to be notified about online/offline
status change."
- :group 'erc-notify
:type '(repeat string))
(defcustom erc-notify-interval 60
"Time interval (in seconds) for checking online status of notified
people."
- :group 'erc-notify
:type 'integer)
(defcustom erc-notify-signon-hook nil
"Hook run after someone on `erc-notify-list' has signed on.
Two arguments are passed to the function, SERVER and NICK, both
strings."
- :group 'erc-notify
:type 'hook
:options '(erc-notify-signon))
@@ -63,7 +60,6 @@ strings."
"Hook run after someone on `erc-notify-list' has signed off.
Two arguments are passed to the function, SERVER and NICK, both
strings."
- :group 'erc-notify
:type 'hook
:options '(erc-notify-signoff))
@@ -75,13 +71,11 @@ strings."
;;;; Internal variables
-(defvar erc-last-ison nil
+(defvar-local erc-last-ison nil
"Last ISON information received through `erc-notify-timer'.")
-(make-variable-buffer-local 'erc-last-ison)
-(defvar erc-last-ison-time 0
+(defvar-local erc-last-ison-time 0
"Last time ISON was sent to the server in `erc-notify-timer'.")
-(make-variable-buffer-local 'erc-last-ison-time)
;;;; Setup
@@ -97,14 +91,14 @@ strings."
(define-erc-module notify nil
"Periodically check for the online status of certain users and report
changes."
- ((add-hook 'erc-timer-hook 'erc-notify-timer)
- (add-hook 'erc-server-JOIN-functions 'erc-notify-JOIN)
- (add-hook 'erc-server-NICK-functions 'erc-notify-NICK)
- (add-hook 'erc-server-QUIT-functions 'erc-notify-QUIT))
- ((remove-hook 'erc-timer-hook 'erc-notify-timer)
- (remove-hook 'erc-server-JOIN-functions 'erc-notify-JOIN)
- (remove-hook 'erc-server-NICK-functions 'erc-notify-NICK)
- (remove-hook 'erc-server-QUIT-functions 'erc-notify-QUIT)))
+ ((add-hook 'erc-timer-hook #'erc-notify-timer)
+ (add-hook 'erc-server-JOIN-functions #'erc-notify-JOIN)
+ (add-hook 'erc-server-NICK-functions #'erc-notify-NICK)
+ (add-hook 'erc-server-QUIT-functions #'erc-notify-QUIT))
+ ((remove-hook 'erc-timer-hook #'erc-notify-timer)
+ (remove-hook 'erc-server-JOIN-functions #'erc-notify-JOIN)
+ (remove-hook 'erc-server-NICK-functions #'erc-notify-NICK)
+ (remove-hook 'erc-server-QUIT-functions #'erc-notify-QUIT)))
;;;; Timer handler
@@ -139,7 +133,7 @@ changes."
(setq erc-last-ison ison-list)
t)))
(erc-server-send
- (concat "ISON " (mapconcat 'identity erc-notify-list " ")))
+ (concat "ISON " (mapconcat #'identity erc-notify-list " ")))
(setq erc-last-ison-time now)))
(defun erc-notify-JOIN (proc parsed)
@@ -181,7 +175,7 @@ nick from `erc-last-ison' to prevent any further notifications."
(let ((nick (erc-extract-nick (erc-response.sender parsed))))
(when (and (erc-member-ignore-case nick erc-notify-list)
(erc-member-ignore-case nick erc-last-ison))
- (setq erc-last-ison (erc-delete-if
+ (setq erc-last-ison (cl-delete-if
(let ((nick-down (erc-downcase nick)))
(lambda (el)
(string= nick-down (erc-downcase el))))
@@ -213,7 +207,7 @@ with args, toggle notify status of people."
'notify_current ?l ison))))
((string= (car args) "-l")
(erc-display-message nil 'notice 'active
- 'notify_list ?l (mapconcat 'identity erc-notify-list
+ 'notify_list ?l (mapconcat #'identity erc-notify-list
" ")))
(t
(while args
@@ -233,7 +227,7 @@ with args, toggle notify status of people."
(setq args (cdr args)))
(erc-display-message
nil 'notice 'active
- 'notify_list ?l (mapconcat 'identity erc-notify-list " "))))
+ 'notify_list ?l (mapconcat #'identity erc-notify-list " "))))
t)
(autoload 'pcomplete-erc-all-nicks "erc-pcomplete")
diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el
index 0cb60f5efa0..457e8cd4684 100644
--- a/lisp/erc/erc-page.el
+++ b/lisp/erc/erc-page.el
@@ -1,4 +1,4 @@
-;; erc-page.el - CTCP PAGE support for ERC
+;;; erc-page.el --- CTCP PAGE support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
@@ -30,6 +30,10 @@
(require 'erc)
+(defgroup erc-page nil
+ "React to CTCP PAGE messages."
+ :group 'erc)
+
;;;###autoload(autoload 'erc-page-mode "erc-page")
(define-erc-module page ctcp-page
"Process CTCP PAGE requests from IRC."
@@ -37,10 +41,6 @@
(erc-define-catalog-entry 'english 'CTCP-PAGE "Page from %n (%u@%h): %m")
-(defgroup erc-page nil
- "React to CTCP PAGE messages."
- :group 'erc)
-
(defcustom erc-page-function nil
"A function to process a \"page\" request.
If nil, this prints the page message in the minibuffer and calls
@@ -53,20 +53,18 @@ Example for your init file:
(lambda (sender msg)
(play-sound-file \"/home/alex/elisp/erc/sounds/ni.wav\")
(message \"IRC Page from %s: %s\" sender msg)))"
- :group 'erc-page
:type '(choice (const nil)
(function)))
-(defcustom erc-ctcp-query-PAGE-hook '(erc-ctcp-query-PAGE)
+(defcustom erc-ctcp-query-PAGE-hook (list #'erc-ctcp-query-PAGE)
"List of functions to be called when a CTCP PAGE is received.
This is called from `erc-process-ctcp-query'. The functions are called
with six arguments: PROC NICK LOGIN HOST TO MSG. Note that you can
also set `erc-page-function' to a function, which only gets two arguments,
SENDER and MSG, so that might be easier to use."
- :group 'erc-page
:type '(repeat function))
-(defun erc-ctcp-query-PAGE (proc nick login host to msg)
+(defun erc-ctcp-query-PAGE (_proc nick login host _to msg)
"Deal with an CTCP PAGE query, if `erc-page-mode' is non-nil.
This will call `erc-page-function', if defined, or it will just print
a message and `beep'. In addition to that, the page message is also
@@ -91,7 +89,7 @@ inserted into the server buffer."
nil 'notice nil text)))
nil)
-(defun erc-cmd-PAGE (line &optional force)
+(defun erc-cmd-PAGE (line &optional _force)
"Send a CTCP page to the user given as the first word in LINE.
The rest of LINE is the message to send. Note that you will only
receive pages if `erc-page-mode' is on."
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el
index a150168e2dd..8ea37c7f290 100644
--- a/lisp/erc/erc-pcomplete.el
+++ b/lisp/erc/erc-pcomplete.el
@@ -1,10 +1,10 @@
-;;; erc-pcomplete.el --- Provides programmable completion for ERC
+;;; erc-pcomplete.el --- Provides programmable completion for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2004, 2006-2021 Free Software Foundation, Inc.
;; Author: Sacha Chua <sacha@free.net.ph>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, convenience
+;; Keywords: comm
;; URL: https://www.emacswiki.org/emacs/ErcCompletion
;; This file is part of GNU Emacs.
@@ -41,7 +41,6 @@
(require 'pcomplete)
(require 'erc)
-(require 'erc-compat)
(require 'time-date)
(defgroup erc-pcomplete nil
@@ -51,23 +50,21 @@
(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
:type 'string)
(defcustom erc-pcomplete-order-nickname-completions t
"If t, channel nickname completions will be ordered such that
the most recent speakers are listed first."
- :group 'erc-pcomplete
:type 'boolean)
;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t)
(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-pcompletions-at-point)
+ ((add-hook 'erc-mode-hook #'pcomplete-erc-setup)
+ (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-pcompletions-at-point)))
+ ((remove-hook 'erc-mode-hook #'pcomplete-erc-setup)
+ (remove-hook 'erc-complete-functions #'erc-pcompletions-at-point)))
(defun erc-pcompletions-at-point ()
"ERC completion data from pcomplete.
@@ -90,18 +87,16 @@ for use on `completion-at-point-function'."
(defun pcomplete-erc-setup ()
"Setup `erc-mode' to use pcomplete."
- (set (make-local-variable 'pcomplete-ignore-case)
- t)
- (set (make-local-variable 'pcomplete-use-paring)
- nil)
- (set (make-local-variable 'pcomplete-parse-arguments-function)
- 'pcomplete-erc-parse-arguments)
- (set (make-local-variable 'pcomplete-command-completion-function)
- 'pcomplete/erc-mode/complete-command)
- (set (make-local-variable 'pcomplete-command-name-function)
- 'pcomplete-erc-command-name)
- (set (make-local-variable 'pcomplete-default-completion-function)
- (lambda () (pcomplete-here (pcomplete-erc-nicks)))))
+ (setq-local completion-ignore-case t)
+ (setq-local pcomplete-use-paring nil)
+ (setq-local pcomplete-parse-arguments-function
+ #'pcomplete-erc-parse-arguments)
+ (setq-local pcomplete-command-completion-function
+ #'pcomplete/erc-mode/complete-command)
+ (setq-local pcomplete-command-name-function
+ #'pcomplete-erc-command-name)
+ (setq-local pcomplete-default-completion-function
+ (lambda () (pcomplete-here (pcomplete-erc-nicks)))))
;;; Programmable completion logic
@@ -157,7 +152,7 @@ for use on `completion-at-point-function'."
(defun pcomplete/erc-mode/NAMES ()
(while (pcomplete-here (pcomplete-erc-channels))))
-(defalias 'pcomplete/erc-mode/NOTICE 'pcomplete/erc-mode/MSG)
+(defalias 'pcomplete/erc-mode/NOTICE #'pcomplete/erc-mode/MSG)
(defun pcomplete/erc-mode/OP ()
(while (pcomplete-here (pcomplete-erc-not-ops))))
@@ -165,7 +160,7 @@ for use on `completion-at-point-function'."
(defun pcomplete/erc-mode/PART ()
(pcomplete-here (pcomplete-erc-channels)))
-(defalias 'pcomplete/erc-mode/LEAVE 'pcomplete/erc-mode/PART)
+(defalias 'pcomplete/erc-mode/LEAVE #'pcomplete/erc-mode/PART)
(defun pcomplete/erc-mode/QUERY ()
(pcomplete-here (append (pcomplete-erc-all-nicks)
diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el
index 91fafbb6308..3f69c4cb9cc 100644
--- a/lisp/erc/erc-replace.el
+++ b/lisp/erc/erc-replace.el
@@ -1,4 +1,4 @@
-;; erc-replace.el -- wash and massage messages inserted into the buffer
+;;; erc-replace.el --- wash and massage messages inserted into the buffer -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
;; Inc.
@@ -6,7 +6,7 @@
;; Author: Andreas Fuchs <asf@void.at>
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; URL: https://www.emacswiki.org/emacs/ErcReplace
-;; Keywords: IRC, client, Internet
+;; Keywords: comm, IRC, client, Internet
;; This file is part of GNU Emacs.
@@ -49,7 +49,6 @@ expression or a variable, or any sexp, TO can be a string or a
function to call, or any sexp. If a function, it will be called with
one argument, the string to be replaced, and it should return a
replacement string."
- :group 'erc-replace
:type '(repeat (cons :tag "Search & Replace"
(choice :tag "From"
regexp
@@ -68,23 +67,23 @@ It replaces text according to `erc-replace-alist'."
(let ((from (car elt))
(to (cdr elt)))
(unless (stringp from)
- (setq from (eval from)))
+ (setq from (eval from t)))
(while (re-search-forward from nil t)
(cond ((stringp to)
(replace-match to))
- ((and (symbolp to) (fboundp to))
+ ((functionp to)
(replace-match (funcall to (match-string 0))))
(t
- (eval to))))))
+ (eval to t))))))
erc-replace-alist))
;;;###autoload(autoload 'erc-replace-mode "erc-replace")
(define-erc-module replace nil
"This mode replaces incoming text according to `erc-replace-alist'."
((add-hook 'erc-insert-modify-hook
- 'erc-replace-insert))
+ #'erc-replace-insert))
((remove-hook 'erc-insert-modify-hook
- 'erc-replace-insert)))
+ #'erc-replace-insert)))
(provide 'erc-replace)
diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el
index 3813eafe004..666fd585926 100644
--- a/lisp/erc/erc-ring.el
+++ b/lisp/erc/erc-ring.el
@@ -1,4 +1,4 @@
-;; erc-ring.el -- Command history handling for erc using ring.el
+;;; erc-ring.el --- Command history handling for erc using ring.el -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2004, 2006-2021 Free Software Foundation, Inc.
@@ -46,23 +46,21 @@
(define-erc-module ring nil
"Stores input in a ring so that previous commands and messages can
be recalled using M-p and M-n."
- ((add-hook 'erc-pre-send-functions 'erc-add-to-input-ring)
- (define-key erc-mode-map "\M-p" 'erc-previous-command)
- (define-key erc-mode-map "\M-n" 'erc-next-command))
- ((remove-hook 'erc-pre-send-functions 'erc-add-to-input-ring)
- (define-key erc-mode-map "\M-p" 'undefined)
- (define-key erc-mode-map "\M-n" 'undefined)))
+ ((add-hook 'erc-pre-send-functions #'erc-add-to-input-ring)
+ (define-key erc-mode-map "\M-p" #'erc-previous-command)
+ (define-key erc-mode-map "\M-n" #'erc-next-command))
+ ((remove-hook 'erc-pre-send-functions #'erc-add-to-input-ring)
+ (define-key erc-mode-map "\M-p" #'undefined)
+ (define-key erc-mode-map "\M-n" #'undefined)))
-(defvar erc-input-ring nil "Input ring for erc.")
-(make-variable-buffer-local 'erc-input-ring)
+(defvar-local erc-input-ring nil "Input ring for erc.")
-(defvar erc-input-ring-index nil
+(defvar-local erc-input-ring-index nil
"Position in the input ring for erc.
If nil, the input line is blank and the user is conceptually after
the most recently added item in the ring. If an integer, the input
line is non-blank and displays the item from the ring indexed by this
variable.")
-(make-variable-buffer-local 'erc-input-ring-index)
(defun erc-input-ring-setup ()
"Do the setup required so that we can use comint style input rings.
@@ -71,10 +69,13 @@ Call this function when setting up the mode."
(setq erc-input-ring (make-ring comint-input-ring-size)))
(setq erc-input-ring-index nil))
-(defun erc-add-to-input-ring (state)
- "Add string S to the input ring and reset history position."
+(defun erc-add-to-input-ring (state-or-string)
+ "Add STATE-OR-STRING to input ring and reset history position.
+STATE-OR-STRING should be a string or an erc-input object."
(unless erc-input-ring (erc-input-ring-setup))
- (ring-insert erc-input-ring (erc-input-string state))
+ (ring-insert erc-input-ring (if (erc-input-p state-or-string)
+ (erc-input-string state-or-string)
+ state-or-string)) ; string
(setq erc-input-ring-index nil))
(defun erc-clear-input-ring ()
@@ -103,11 +104,10 @@ containing a password."
;; area, push it on the history ring before moving back through
;; the input history, so it will be there when we return to the
;; front.
- (if (null erc-input-ring-index)
- (when (> (point-max) erc-input-marker)
- (erc-add-to-input-ring (buffer-substring erc-input-marker
- (point-max)))
- (setq erc-input-ring-index 0)))
+ (when (and (null erc-input-ring-index)
+ (> (point-max) erc-input-marker))
+ (erc-add-to-input-ring (erc-user-input))
+ (setq erc-input-ring-index 0))
(setq erc-input-ring-index (if erc-input-ring-index
(ring-plus1 erc-input-ring-index
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index f04da183c64..61006e0c028 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -92,7 +92,6 @@ Possible settings are:.
nil - Disables automatic Nickserv identification.
You can also use \\[erc-nickserv-identify-mode] to change modes."
- :group 'erc-services
:type '(choice (const autodetect)
(const nick-change)
(const both)
@@ -108,13 +107,13 @@ You can also use \\[erc-nickserv-identify-mode] to change modes."
"This mode automates communication with services."
((erc-nickserv-identify-mode erc-nickserv-identify-mode))
((remove-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identify-autodetect)
+ #'erc-nickserv-identify-autodetect)
(remove-hook 'erc-after-connect
- 'erc-nickserv-identify-on-connect)
+ #'erc-nickserv-identify-on-connect)
(remove-hook 'erc-nick-changed-functions
- 'erc-nickserv-identify-on-nick-change)
+ #'erc-nickserv-identify-on-nick-change)
(remove-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identification-autodetect)))
+ #'erc-nickserv-identification-autodetect)))
;;;###autoload
(defun erc-nickserv-identify-mode (mode)
@@ -124,7 +123,7 @@ You can also use \\[erc-nickserv-identify-mode] to change modes."
"Choose Nickserv identify mode (RET to disable): "
'(("autodetect") ("nick-change") ("both")) nil t))))
(add-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identification-autodetect)
+ #'erc-nickserv-identification-autodetect)
(unless erc-networks-mode
;; Force-enable networks module, because we need it to set
;; erc-network for us.
@@ -132,52 +131,60 @@ You can also use \\[erc-nickserv-identify-mode] to change modes."
(cond ((eq mode 'autodetect)
(setq erc-nickserv-identify-mode 'autodetect)
(add-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identify-autodetect)
+ #'erc-nickserv-identify-autodetect)
(remove-hook 'erc-nick-changed-functions
- 'erc-nickserv-identify-on-nick-change)
+ #'erc-nickserv-identify-on-nick-change)
(remove-hook 'erc-after-connect
- 'erc-nickserv-identify-on-connect))
+ #'erc-nickserv-identify-on-connect))
((eq mode 'nick-change)
(setq erc-nickserv-identify-mode 'nick-change)
(add-hook 'erc-after-connect
- 'erc-nickserv-identify-on-connect)
+ #'erc-nickserv-identify-on-connect)
(add-hook 'erc-nick-changed-functions
- 'erc-nickserv-identify-on-nick-change)
+ #'erc-nickserv-identify-on-nick-change)
(remove-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identify-autodetect))
+ #'erc-nickserv-identify-autodetect))
((eq mode 'both)
(setq erc-nickserv-identify-mode 'both)
(add-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identify-autodetect)
+ #'erc-nickserv-identify-autodetect)
(add-hook 'erc-after-connect
- 'erc-nickserv-identify-on-connect)
+ #'erc-nickserv-identify-on-connect)
(add-hook 'erc-nick-changed-functions
- 'erc-nickserv-identify-on-nick-change))
+ #'erc-nickserv-identify-on-nick-change))
(t
(setq erc-nickserv-identify-mode nil)
(remove-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identify-autodetect)
+ #'erc-nickserv-identify-autodetect)
(remove-hook 'erc-after-connect
- 'erc-nickserv-identify-on-connect)
+ #'erc-nickserv-identify-on-connect)
(remove-hook 'erc-nick-changed-functions
- 'erc-nickserv-identify-on-nick-change)
+ #'erc-nickserv-identify-on-nick-change)
(remove-hook 'erc-server-NOTICE-functions
- 'erc-nickserv-identification-autodetect))))
+ #'erc-nickserv-identification-autodetect))))
(defcustom erc-prompt-for-nickserv-password t
"Ask for the password when identifying to NickServ."
- :group 'erc-services
+ :type 'boolean)
+
+(defcustom erc-use-auth-source-for-nickserv-password nil
+ "Query auth-source for a password when identifiying to NickServ.
+This option has an no effect if `erc-prompt-for-nickserv-password'
+is non-nil, and passwords from `erc-nickserv-passwords' take
+precedence."
+ :version "28.1"
:type 'boolean)
(defcustom erc-nickserv-passwords nil
"Passwords used when identifying to NickServ automatically.
+`erc-prompt-for-nickserv-password' must be nil for these
+passwords to be used.
Example of use:
(setq erc-nickserv-passwords
\\='((Libera.Chat ((\"nick-one\" . \"password\")
(\"nick-two\" . \"password\")))
(DALnet ((\"nick\" . \"password\")))))"
- :group 'erc-services
:type '(repeat
(list :tag "Network"
(choice :tag "Network name"
@@ -305,7 +312,6 @@ ANSWER is the command to use for the answer. The default is `privmsg'.
SUCCESS-REGEXP is a regular expression matching the message nickserv
sends when you've successfully identified.
The last two elements are optional."
- :group 'erc-services
:type '(repeat
(list :tag "Nickserv data"
(symbol :tag "Network name")
@@ -357,7 +363,6 @@ The last two elements are optional."
(defcustom erc-nickserv-identified-hook nil
"Run this hook when NickServ acknowledged successful identification.
Hooks are called with arguments (NETWORK NICK)."
- :group 'erc-services
:type 'hook)
(defun erc-nickserv-identification-autodetect (_proc parsed)
@@ -386,7 +391,8 @@ Make sure it is the real NickServ for this network.
If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the
password for this nickname, otherwise try to send it automatically."
(unless (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
(let* ((network (erc-network))
(sender (erc-nickserv-alist-sender network))
(identify-regex (erc-nickserv-alist-regexp network))
@@ -405,30 +411,49 @@ password for this nickname, otherwise try to send it automatically."
(defun erc-nickserv-identify-on-connect (_server nick)
"Identify to Nickserv after the connection to the server is established."
(unless (or (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
- (and (eq erc-nickserv-identify-mode 'both)
- (erc-nickserv-alist-regexp (erc-network))))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
+ (and (eq erc-nickserv-identify-mode 'both)
+ (erc-nickserv-alist-regexp (erc-network))))
(erc-nickserv-call-identify-function nick)))
(defun erc-nickserv-identify-on-nick-change (nick _old-nick)
"Identify to Nickserv whenever your nick changes."
(unless (or (and (null erc-nickserv-passwords)
- (null erc-prompt-for-nickserv-password))
- (and (eq erc-nickserv-identify-mode 'both)
- (erc-nickserv-alist-regexp (erc-network))))
+ (null erc-prompt-for-nickserv-password)
+ (null erc-use-auth-source-for-nickserv-password))
+ (and (eq erc-nickserv-identify-mode 'both)
+ (erc-nickserv-alist-regexp (erc-network))))
(erc-nickserv-call-identify-function nick)))
+(defun erc-nickserv-get-password (nickname)
+ "Return the password for NICKNAME from configured sources.
+
+It uses `erc-nickserv-passwords' and additionally auth-source
+when `erc-use-auth-source-for-nickserv-password' is not nil."
+ (or
+ (when erc-nickserv-passwords
+ (cdr (assoc nickname
+ (nth 1 (assoc (erc-network)
+ erc-nickserv-passwords)))))
+ (when erc-use-auth-source-for-nickserv-password
+ (let* ((secret (nth 0 (auth-source-search
+ :max 1 :require '(:secret)
+ :host (erc-with-server-buffer erc-session-server)
+ :port (format ; ensure we have a string
+ "%s" (erc-with-server-buffer erc-session-port))
+ :user nickname))))
+ (when secret
+ (let ((passwd (plist-get secret :secret)))
+ (if (functionp passwd) (funcall passwd) passwd)))))))
+
(defun erc-nickserv-call-identify-function (nickname)
"Call `erc-nickserv-identify'.
Either call it interactively or run it with NICKNAME's password,
depending on the value of `erc-prompt-for-nickserv-password'."
(if erc-prompt-for-nickserv-password
(call-interactively 'erc-nickserv-identify)
- (when erc-nickserv-passwords
- (erc-nickserv-identify
- (cdr (assoc nickname
- (nth 1 (assoc (erc-network)
- erc-nickserv-passwords))))))))
+ (erc-nickserv-identify (erc-nickserv-get-password nickname))))
(defvar erc-auto-discard-away)
@@ -462,6 +487,7 @@ When called interactively, read the password using `read-passwd'."
(provide 'erc-services)
+
;;; erc-services.el ends here
;;
;; Local Variables:
diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el
index edde9737ff9..92759d206a3 100644
--- a/lisp/erc/erc-sound.el
+++ b/lisp/erc/erc-sound.el
@@ -1,4 +1,4 @@
-;;; erc-sound.el --- CTCP SOUND support for ERC
+;;; erc-sound.el --- CTCP SOUND support for ERC -*- lexical-binding: t -*-
;; Copyright (C) 2002-2003, 2006-2021 Free Software Foundation, Inc.
@@ -52,11 +52,11 @@
"In ERC sound mode, the client will respond to CTCP SOUND requests
and play sound files as requested."
;; Enable:
- ((add-hook 'erc-ctcp-query-SOUND-hook 'erc-ctcp-query-SOUND)
- (define-key erc-mode-map "\C-c\C-s" 'erc-toggle-sound))
+ ((add-hook 'erc-ctcp-query-SOUND-hook #'erc-ctcp-query-SOUND)
+ (define-key erc-mode-map "\C-c\C-s" #'erc-toggle-sound))
;; Disable:
- ((remove-hook 'erc-ctcp-query-SOUND-hook 'erc-ctcp-query-SOUND)
- (define-key erc-mode-map "\C-c\C-s" 'undefined)))
+ ((remove-hook 'erc-ctcp-query-SOUND-hook #'erc-ctcp-query-SOUND)
+ (define-key erc-mode-map "\C-c\C-s" #'undefined)))
(erc-define-catalog-entry 'english 'CTCP-SOUND "%n (%u@%h) plays %s:%m")
@@ -66,18 +66,15 @@ and play sound files as requested."
(defcustom erc-play-sound t
"Play sounds when you receive CTCP SOUND requests."
- :group 'erc-sound
:type 'boolean)
(defcustom erc-sound-path nil
"List of directories that contain sound samples to play on SOUND events."
- :group 'erc-sound
:type '(repeat directory))
(defcustom erc-default-sound nil
"Play this sound if the requested file was not found.
If this is set to nil or the file doesn't exist a beep will sound."
- :group 'erc-sound
:type '(choice (const nil)
file))
@@ -108,7 +105,7 @@ LINE is the text entered, including the command."
t))
(t nil)))
-(defun erc-ctcp-query-SOUND (proc nick login host to msg)
+(defun erc-ctcp-query-SOUND (_proc nick login host _to msg)
"Display a CTCP SOUND message and play sound if `erc-play-sound' is non-nil."
(when (string-match "^SOUND\\s-+\\(\\S-+\\)\\(\\(\\s-+.*\\)\\|\\(\\s-*\\)\\)$" msg)
(let ((sound (match-string 1 msg))
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index bb421c13ffa..bb858445235 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -1,4 +1,4 @@
-;;; erc-speedbar.el --- Speedbar support for ERC
+;;; erc-speedbar.el --- Speedbar support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2004, 2006-2021 Free Software Foundation, Inc.
@@ -52,7 +52,6 @@
`activity' - Sort users by channel activity
`alphabetical' - Sort users alphabetically
nil - Do not sort users"
- :group 'erc-speedbar
:type '(choice (const :tag "Sort users by channel activity" activity)
(const :tag "Sort users alphabetically" alphabetical)
(const :tag "Do not sort users" nil)))
@@ -67,11 +66,11 @@ nil - Do not sort users"
(setq erc-speedbar-key-map (speedbar-make-specialized-keymap))
;; Basic tree features
- (define-key erc-speedbar-key-map "e" 'speedbar-edit-line)
- (define-key erc-speedbar-key-map "\C-m" 'speedbar-edit-line)
- (define-key erc-speedbar-key-map "+" 'speedbar-expand-line)
- (define-key erc-speedbar-key-map "=" 'speedbar-expand-line)
- (define-key erc-speedbar-key-map "-" 'speedbar-contract-line))
+ (define-key erc-speedbar-key-map "e" #'speedbar-edit-line)
+ (define-key erc-speedbar-key-map "\C-m" #'speedbar-edit-line)
+ (define-key erc-speedbar-key-map "+" #'speedbar-expand-line)
+ (define-key erc-speedbar-key-map "=" #'speedbar-expand-line)
+ (define-key erc-speedbar-key-map "-" #'speedbar-contract-line))
(speedbar-add-expansion-list '("ERC" erc-speedbar-menu-items
erc-speedbar-key-map
@@ -90,9 +89,8 @@ nil - Do not sort users"
"Additional menu-items to add to speedbar frame.")
;; Make sure our special speedbar major mode is loaded
-(if (featurep 'speedbar)
- (erc-install-speedbar-variables)
- (add-hook 'speedbar-load-hook 'erc-install-speedbar-variables))
+(with-eval-after-load 'speedbar
+ (erc-install-speedbar-variables))
;;; ERC hierarchy display method
;;;###autoload
@@ -125,7 +123,7 @@ This will add a speedbar major display mode."
(erc-speedbar-insert-target buffer 0))
(t (ignore)))))
-(defun erc-speedbar-server-buttons (directory depth)
+(defun erc-speedbar-server-buttons (_directory depth)
"Insert the initial list of servers you are connected to."
(let ((servers (erc-buffer-list
(lambda ()
@@ -155,7 +153,7 @@ This will add a speedbar major display mode."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun erc-speedbar-channel-buttons (directory depth server-buffer)
+(defun erc-speedbar-channel-buttons (_directory depth server-buffer)
(when (get-buffer server-buffer)
(let* ((proc (with-current-buffer server-buffer erc-server-process))
(targets (erc-buffer-list
@@ -192,7 +190,7 @@ INDENT is the current indentation level."
(save-excursion
(end-of-line) (forward-char 1)
(let ((modes (with-current-buffer channel
- (concat (apply 'concat
+ (concat (apply #'concat
erc-channel-modes)
(cond
((and erc-channel-user-limit
@@ -315,7 +313,7 @@ The update is only done when the channel is actually expanded already."
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun erc-speedbar-goto-buffer (text buffer indent)
+(defun erc-speedbar-goto-buffer (_text buffer _indent)
"When user clicks on TEXT, goto an ERC buffer.
The INDENT level is ignored."
(if (featurep 'dframe)
diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el
index 44a3e358812..950a821e3c4 100644
--- a/lisp/erc/erc-spelling.el
+++ b/lisp/erc/erc-spelling.el
@@ -1,10 +1,10 @@
-;;; erc-spelling.el --- use flyspell in ERC
+;;; erc-spelling.el --- use flyspell in ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
;; Author: Jorgen Schaefer <forcer@forcix.cx>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: irc
+;; Keywords: comm, irc
;; URL: https://www.emacswiki.org/emacs/ErcSpelling
;; This file is part of GNU Emacs.
@@ -38,10 +38,10 @@
"Enable flyspell mode in ERC buffers."
;; Use erc-connect-pre-hook instead of erc-mode-hook as pre-hook is
;; called AFTER the server buffer is initialized.
- ((add-hook 'erc-connect-pre-hook 'erc-spelling-init)
+ ((add-hook 'erc-connect-pre-hook #'erc-spelling-init)
(dolist (buffer (erc-buffer-list))
(erc-spelling-init buffer)))
- ((remove-hook 'erc-connect-pre-hook 'erc-spelling-init)
+ ((remove-hook 'erc-connect-pre-hook #'erc-spelling-init)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer (flyspell-mode 0)))))
@@ -104,7 +104,7 @@ The cadr is the beginning and the caddr is the end."
(put 'erc-mode
'flyspell-mode-predicate
- 'erc-spelling-flyspell-verify)
+ #'erc-spelling-flyspell-verify)
(provide 'erc-spelling)
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 07148002468..31de9e80697 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -4,7 +4,7 @@
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, processes, timestamp
+;; Keywords: comm, timestamp
;; URL: https://www.emacswiki.org/emacs/ErcStamp
;; This file is part of GNU Emacs.
@@ -35,7 +35,6 @@
;;; Code:
(require 'erc)
-(require 'erc-compat)
(defgroup erc-stamp nil
"For long conversation on IRC it is sometimes quite
@@ -53,7 +52,6 @@ This string is processed using `format-time-string'.
Good examples are \"%T\" and \"%H:%M\".
If nil, timestamping is turned off."
- :group 'erc-stamp
:type '(choice (const nil)
(string)))
@@ -67,7 +65,6 @@ screen when `erc-insert-timestamp-function' is set to
`erc-insert-timestamp-left-and-right'.
If nil, timestamping is turned off."
- :group 'erc-stamp
:type '(choice (const nil)
(string)))
@@ -81,7 +78,6 @@ screen when `erc-insert-timestamp-function' is set to
`erc-insert-timestamp-left-and-right'.
If nil, timestamping is turned off."
- :group 'erc-stamp
:type '(choice (const nil)
(string)))
@@ -96,7 +92,6 @@ operate on.
You will probably want to set
`erc-insert-away-timestamp-function' to the same value."
- :group 'erc-stamp
:type '(choice (const :tag "Both sides" erc-insert-timestamp-left-and-right)
(const :tag "Right" erc-insert-timestamp-right)
(const :tag "Left" erc-insert-timestamp-left)
@@ -109,7 +104,6 @@ If nil, timestamping is turned off when away unless `erc-timestamp-format'
is set.
If `erc-timestamp-format' is set, this will not be used."
- :group 'erc-stamp
:type '(choice (const nil)
(string)))
@@ -118,7 +112,6 @@ If `erc-timestamp-format' is set, this will not be used."
"Function to use to insert the away timestamp.
See `erc-insert-timestamp-function' for details."
- :group 'erc-stamp
:type '(choice (const :tag "Both sides" erc-insert-timestamp-left-and-right)
(const :tag "Right" erc-insert-timestamp-right)
(const :tag "Left" erc-insert-timestamp-left)
@@ -129,7 +122,6 @@ See `erc-insert-timestamp-function' for details."
This is useful for logging, because, although timestamps will be
hidden, they will still be present in the logs."
- :group 'erc-stamp
:type 'boolean)
(defcustom erc-echo-timestamps nil
@@ -137,20 +129,17 @@ hidden, they will still be present in the logs."
Using this variable, you can turn off normal timestamping,
and simply move point to an irc message to see its timestamp
printed in the minibuffer."
- :group 'erc-stamp
:type 'boolean)
(defcustom erc-echo-timestamp-format "Timestamped %A, %H:%M:%S"
"Format string to be used when `erc-echo-timestamps' is non-nil.
This string specifies the format of the timestamp being echoed in
the minibuffer."
- :group 'erc-stamp
:type 'string)
(defcustom erc-timestamp-intangible nil
"Whether the timestamps should be intangible, i.e. prevent the point
from entering them and instead jump over them."
- :group 'erc-stamp
:version "24.5"
:type 'boolean)
@@ -192,21 +181,18 @@ or `erc-send-modify-hook'."
(list (lambda (_window _before dir)
(erc-echo-timestamp dir ct))))))))
-(defvar erc-timestamp-last-inserted nil
+(defvar-local erc-timestamp-last-inserted nil
"Last timestamp inserted into the buffer.")
-(make-variable-buffer-local 'erc-timestamp-last-inserted)
-(defvar erc-timestamp-last-inserted-left nil
+(defvar-local erc-timestamp-last-inserted-left nil
"Last timestamp inserted into the left side of the buffer.
This is used when `erc-insert-timestamp-function' is set to
`erc-timestamp-left-and-right'")
-(make-variable-buffer-local 'erc-timestamp-last-inserted-left)
-(defvar erc-timestamp-last-inserted-right nil
+(defvar-local erc-timestamp-last-inserted-right nil
"Last timestamp inserted into the right side of the buffer.
This is used when `erc-insert-timestamp-function' is set to
`erc-timestamp-left-and-right'")
-(make-variable-buffer-local 'erc-timestamp-last-inserted-right)
(defcustom erc-timestamp-only-if-changed-flag t
"Insert timestamp only if its value changed since last insertion.
@@ -215,7 +201,6 @@ string of spaces which is the same size as the timestamp is added to
the beginning of the line in its place. If you use
`erc-insert-timestamp-right', nothing gets inserted in place of the
timestamp."
- :group 'erc-stamp
:type 'boolean)
(defcustom erc-timestamp-right-column nil
@@ -223,7 +208,6 @@ timestamp."
if the timestamp is to be printed to the right. If nil,
`erc-insert-timestamp-right' will use other means to determine
the correct column."
- :group 'erc-stamp
:type '(choice
(integer :tag "Column number")
(const :tag "Unspecified" nil)))
@@ -235,7 +219,6 @@ Asian language characters and math symbols) precede a timestamp.
A side effect of enabling this is that there will only be one
space before a right timestamp in any saved logs."
- :group 'erc-stamp
:type 'boolean)
(defun erc-insert-timestamp-left (string)
diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el
new file mode 100644
index 00000000000..a75a74bb6fd
--- /dev/null
+++ b/lisp/erc/erc-status-sidebar.el
@@ -0,0 +1,303 @@
+;;; erc-status-sidebar.el --- HexChat-like activity overview for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017, 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Andrew Barbarello
+;; Maintainer: Amin Bandali <bandali@gnu.org>
+;; URL: https://github.com/drewbarbs/erc-status-sidebar
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides a HexChat-like sidebar for joined channels in
+;; ERC. It relies on the `erc-track' module, and displays all of the
+;; same information that `erc-track' does in the mode line, but in an
+;; alternative format in form of a sidebar.
+
+;; Shout out to sidebar.el <https://github.com/sebastiencs/sidebar.el>
+;; and outline-toc.el <https://github.com/abingham/outline-toc.el> for
+;; the sidebar window management ideas.
+
+;; Usage:
+
+;; Use M-x erc-status-sidebar-open RET to open the ERC status sidebar
+;; in the current frame. Make sure that the `erc-track' module is
+;; active (this is the default).
+
+;; Use M-x erc-status-sidebar-close RET to close the sidebar on the
+;; current frame. With a prefix argument, it closes the sidebar on
+;; all frames.
+
+;; Use M-x erc-status-sidebar-kill RET to kill the sidebar buffer and
+;; close the sidebar on all frames.
+
+;;; Code:
+
+(require 'erc)
+(require 'erc-track)
+(require 'fringe)
+(require 'seq)
+
+(defgroup erc-status-sidebar nil
+ "A sidebar for ERC channel status."
+ :group 'convenience)
+
+(defcustom erc-status-sidebar-buffer-name "*ERC Status*"
+ "Name of the sidebar buffer."
+ :type 'string)
+
+(defcustom erc-status-sidebar-mode-line-format "ERC Status"
+ "Mode line format for the status sidebar."
+ :type 'string)
+
+(defcustom erc-status-sidebar-header-line-format nil
+ "Header line format for the status sidebar."
+ :type '(choice (const :tag "No header line" nil)
+ string))
+
+(defcustom erc-status-sidebar-width 15
+ "Default width of the sidebar (in columns)."
+ :type 'number)
+
+(defcustom erc-status-sidebar-channel-sort
+ 'erc-status-sidebar-default-chansort
+ "Sorting function used to determine order of channels in the sidebar."
+ :type 'function)
+
+(defcustom erc-status-sidebar-channel-format
+ 'erc-status-sidebar-default-chan-format
+ "Function used to format channel names for display in the sidebar."
+ :type 'function)
+
+(defun erc-status-sidebar-display-window ()
+ "Display the status buffer in a side window. Return the new window."
+ (display-buffer
+ (erc-status-sidebar-get-buffer)
+ `(display-buffer-in-side-window . ((side . left)
+ (window-width . ,erc-status-sidebar-width)))))
+
+(defun erc-status-sidebar-get-window (&optional no-creation)
+ "Return the created/existing window displaying the status buffer.
+
+If NO-CREATION is non-nil, the window is not created."
+ (let ((sidebar-window (get-buffer-window erc-status-sidebar-buffer-name)))
+ (unless (or sidebar-window no-creation)
+ (with-current-buffer (erc-status-sidebar-get-buffer)
+ (setq-local vertical-scroll-bar nil))
+ (setq sidebar-window (erc-status-sidebar-display-window))
+ (set-window-dedicated-p sidebar-window t)
+ (set-window-parameter sidebar-window 'no-delete-other-windows t)
+ ;; Don't cycle to this window with `other-window'.
+ (set-window-parameter sidebar-window 'no-other-window t)
+ (internal-show-cursor sidebar-window nil)
+ (set-window-fringes sidebar-window 0 0)
+ ;; Set a custom display table so the window doesn't show a
+ ;; truncation symbol when a channel name is too big.
+ (let ((dt (make-display-table)))
+ (set-window-display-table sidebar-window dt)
+ (set-display-table-slot dt 'truncation ?\ )))
+ sidebar-window))
+
+(defun erc-status-sidebar-buffer-exists-p ()
+ "Check if the sidebar buffer exists."
+ (get-buffer erc-status-sidebar-buffer-name))
+
+(defun erc-status-sidebar-get-buffer ()
+ "Return the sidebar buffer, creating it if it doesn't exist."
+ (get-buffer-create erc-status-sidebar-buffer-name))
+
+(defun erc-status-sidebar-close (&optional all-frames)
+ "Close the sidebar.
+
+If called with prefix argument (ALL-FRAMES non-nil), the sidebar
+will be closed on all frames.
+
+The erc-status-sidebar buffer is left alone, but the window
+containing it on the current frame is closed. See
+`erc-status-sidebar-kill'."
+ (interactive "P")
+ (mapcar #'delete-window
+ (get-buffer-window-list (erc-status-sidebar-get-buffer)
+ nil (if all-frames t))))
+
+(defmacro erc-status-sidebar-writable (&rest body)
+ "Make the status buffer writable while executing BODY."
+ `(let ((buffer-read-only nil))
+ ,@body))
+
+;;;###autoload
+(defun erc-status-sidebar-open ()
+ "Open or create a sidebar."
+ (interactive)
+ (save-excursion
+ (let ((sidebar-exists (erc-status-sidebar-buffer-exists-p))
+ (sidebar-buffer (erc-status-sidebar-get-buffer))
+ ;; (sidebar-window (erc-status-sidebar-get-window))
+ )
+ (unless sidebar-exists
+ (with-current-buffer sidebar-buffer
+ (erc-status-sidebar-mode)
+ (erc-status-sidebar-refresh))))))
+
+;;;###autoload
+(defun erc-status-sidebar-toggle ()
+ "Toggle the sidebar open/closed on the current frame."
+ (interactive)
+ (if (get-buffer-window erc-status-sidebar-buffer-name nil)
+ (erc-status-sidebar-close)
+ (erc-status-sidebar-open)))
+
+(defun erc-status-sidebar-get-channame (buffer)
+ "Return name of BUFFER with all leading \"#\" characters removed."
+ (let ((s (buffer-name buffer)))
+ (if (string-match "^#\\{1,2\\}" s)
+ (setq s (replace-match "" t t s)))
+ (downcase s)))
+
+(defun erc-status-sidebar-default-chansort (chanlist)
+ "Sort CHANLIST case-insensitively for display in the sidebar."
+ (sort chanlist (lambda (x y)
+ (string< (erc-status-sidebar-get-channame x)
+ (erc-status-sidebar-get-channame y)))))
+
+(defun erc-status-sidebar-default-chan-format (channame
+ &optional num-messages erc-face)
+ "Format CHANNAME for display in the sidebar.
+
+If NUM-MESSAGES is non-nil, append it to the channel name. If
+ERC-FACE is non-nil, apply it to channel name. If it is equal to
+`erc-default-face', also apply bold property to make the channel
+name stand out."
+ (when num-messages
+ (setq channame (format "%s [%d]" channame num-messages)))
+ (when erc-face
+ (put-text-property 0 (length channame) 'face erc-face channame)
+ (when (eq erc-face 'erc-default-face)
+ (add-face-text-property 0 (length channame) 'bold t channame)))
+ channame)
+
+(defun erc-status-sidebar-refresh ()
+ "Update the content of the sidebar."
+ (interactive)
+ (let ((chanlist (apply erc-status-sidebar-channel-sort
+ (erc-channel-list nil) nil)))
+ (with-current-buffer (erc-status-sidebar-get-buffer)
+ (erc-status-sidebar-writable
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (dolist (chanbuf chanlist)
+ (let* ((tup (seq-find (lambda (tup) (eq (car tup) chanbuf))
+ erc-modified-channels-alist))
+ (count (if tup (cadr tup)))
+ (face (if tup (cddr tup)))
+ (channame (apply erc-status-sidebar-channel-format
+ (buffer-name chanbuf) count face nil))
+ (cnlen (length channame)))
+ (put-text-property 0 cnlen 'erc-buf chanbuf channame)
+ (put-text-property 0 cnlen 'mouse-face 'highlight channame)
+ (put-text-property
+ 0 cnlen 'help-echo
+ "mouse-1: switch to buffer in other window" channame)
+ (insert channame "\n")))))))
+
+(defun erc-status-sidebar-kill ()
+ "Close the ERC status sidebar and its buffer."
+ (interactive)
+ (ignore-errors (kill-buffer erc-status-sidebar-buffer-name)))
+
+(defun erc-status-sidebar-click (event)
+ "Handle click EVENT in `erc-status-sidebar-mode-map'."
+ (interactive "e")
+ (save-excursion
+ (let ((window (posn-window (event-end event)))
+ (pos (posn-point (event-end event))))
+ (set-buffer (window-buffer window))
+ (let ((buf (get-text-property pos 'erc-buf)))
+ (when buf
+ (select-window window)
+ (switch-to-buffer-other-window buf))))))
+
+(defvar erc-status-sidebar-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map special-mode-map)
+ (define-key map [mouse-1] #'erc-status-sidebar-click)
+ map))
+
+(defvar erc-status-sidebar-refresh-triggers
+ '(erc-track-list-changed-hook
+ erc-join-hook
+ erc-part-hook
+ erc-kill-buffer-hook
+ erc-kill-channel-hook
+ erc-kill-server-hook
+ erc-kick-hook
+ erc-disconnected-hook
+ erc-quit-hook))
+
+(defun erc-status-sidebar--post-refresh (&rest _ignore)
+ "Schedule sidebar refresh for execution after command stack is cleared.
+
+Ignore arguments in IGNORE, allowing this function to be added to
+hooks that invoke it with arguments."
+ (run-at-time 0 nil #'erc-status-sidebar-refresh))
+
+(defun erc-status-sidebar-mode--unhook ()
+ "Remove hooks installed by `erc-status-sidebar-mode'."
+ (dolist (hk erc-status-sidebar-refresh-triggers)
+ (remove-hook hk #'erc-status-sidebar--post-refresh))
+ (remove-hook 'window-configuration-change-hook
+ #'erc-status-sidebar-set-window-preserve-size))
+
+(defun erc-status-sidebar-set-window-preserve-size ()
+ "Tell Emacs to preserve the current height/width of the ERC sidebar window.
+
+Note that preserve status needs to be reset when the window is
+manually resized, so `erc-status-sidebar-mode' adds this function
+to the `window-configuration-change-hook'."
+ (when (and (eq (selected-window) (erc-status-sidebar-get-window))
+ (fboundp 'window-preserve-size))
+ (unless (eq (window-total-width) (window-min-size nil t))
+ (apply #'window-preserve-size (selected-window) t t nil))))
+
+(define-derived-mode erc-status-sidebar-mode special-mode "ERC Sidebar"
+ "Major mode for ERC status sidebar"
+ ;; Don't scroll the buffer horizontally, if a channel name is
+ ;; obscured then the window can be resized.
+ (setq-local auto-hscroll-mode nil)
+ (setq cursor-type nil
+ buffer-read-only t
+ mode-line-format erc-status-sidebar-mode-line-format
+ header-line-format erc-status-sidebar-header-line-format)
+ (erc-status-sidebar-set-window-preserve-size)
+
+ (add-hook 'window-configuration-change-hook
+ #'erc-status-sidebar-set-window-preserve-size nil t)
+ (dolist (hk erc-status-sidebar-refresh-triggers)
+ (add-hook hk #'erc-status-sidebar--post-refresh))
+
+ ;; `change-major-mode-hook' is run *before* the
+ ;; erc-status-sidebar-mode initialization code, so it won't undo the
+ ;; add-hook's we did in the previous expressions.
+ (add-hook 'change-major-mode-hook #'erc-status-sidebar-mode--unhook nil t)
+ (add-hook 'kill-buffer-hook #'erc-status-sidebar-mode--unhook nil t))
+
+(provide 'erc-status-sidebar)
+;;; erc-status-sidebar.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index 11270770659..2364d45d6f3 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -4,7 +4,7 @@
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, faces
+;; Keywords: comm
;; URL: https://www.emacswiki.org/emacs/ErcChannelTracking
;; This file is part of GNU Emacs.
@@ -36,7 +36,6 @@
(eval-when-compile (require 'cl-lib))
(require 'erc)
-(require 'erc-compat)
(require 'erc-match)
;;; Code:
@@ -61,7 +60,6 @@ The reason for using this default value is to both (1) adhere to
the Emacs development guidelines which say not to touch keys of
the form C-c C-<something> and also (2) to meet the expectations
of long-time ERC users, many of whom rely on these keybindings."
- :group 'erc-track
:type '(choice (const :tag "Ask, if used already" ask)
(const :tag "Enable" t)
(const :tag "Disable" nil)))
@@ -81,7 +79,6 @@ nil - only the selected frame
selected-visible - only the selected frame if it is visible
Activity means that there was no user input in the last 10 seconds."
- :group 'erc-track
:type '(choice (const :tag "All frames" t)
(const :tag "All visible frames" visible)
(const :tag "Only the selected frame" nil)
@@ -90,13 +87,11 @@ Activity means that there was no user input in the last 10 seconds."
(defcustom erc-track-exclude nil
"A list targets (channel names or query targets) which should not be tracked."
- :group 'erc-track
:type '(repeat string))
(defcustom erc-track-remove-disconnected-buffers nil
"If true, remove buffers associated with a server that is
disconnected from `erc-modified-channels-alist'."
- :group 'erc-track
:type 'boolean)
(defcustom erc-track-exclude-types '("NICK" "333" "353")
@@ -106,25 +101,21 @@ This list could look like (\"JOIN\" \"PART\").
By default, exclude changes of nicknames (NICK), display of who
set the channel topic (333), and listing of users on the current
channel (353)."
- :group 'erc-track
:type 'erc-message-type)
(defcustom erc-track-exclude-server-buffer nil
"If true, don't perform tracking on the server buffer; this is
useful for excluding all the things like MOTDs from the server and
other miscellaneous functions."
- :group 'erc-track
:type 'boolean)
(defcustom erc-track-shorten-start 1
"This number specifies the minimum number of characters a channel name in
the mode-line should be reduced to."
- :group 'erc-track
:type 'number)
(defcustom erc-track-shorten-cutoff 4
"All channel names longer than this value will be shortened."
- :group 'erc-track
:type 'number)
(defcustom erc-track-shorten-aggressively nil
@@ -145,7 +136,6 @@ not compared to #electronica -- only to #vi, therefore it can be shortened
even more and the result is #e and #v.
This setting is used by `erc-track-shorten-names'."
- :group 'erc-track
:type '(choice (const :tag "No" nil)
(const :tag "Yes" t)
(const :tag "Max" max)))
@@ -155,7 +145,6 @@ This setting is used by `erc-track-shorten-names'."
It takes one argument, CHANNEL-NAMES which is a list of strings.
It should return a list of strings of the same number of elements.
If nil instead of a function, shortening is disabled."
- :group 'erc-track
:type '(choice (const :tag "Disabled")
function))
@@ -166,14 +155,12 @@ If nil instead of a function, shortening is disabled."
This is useful for people that don't use the default mode-line
notification but instead use a separate mechanism to provide
notification of channel activity."
- :group 'erc-track
:type 'hook)
(defcustom erc-track-use-faces t
"Use faces in the mode-line.
The faces used are the same as used for text in the buffers.
\(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)"
- :group 'erc-track
:type 'boolean)
(defcustom erc-track-faces-priority-list
@@ -200,7 +187,6 @@ The faces used are the same as used for text in the buffers.
"A list of faces used to highlight active buffer names in the mode line.
If a message contains one of the faces in this list, the buffer name will
be highlighted using that face. The first matching face is used."
- :group 'erc-track
:type '(repeat (choice face
(repeat :tag "Combination" face))))
@@ -215,7 +201,6 @@ this feature.
Note: If you have a lot of faces listed in `erc-track-faces-priority-list',
setting this variable might not be very useful."
- :group 'erc-track
:type '(choice (const nil)
(repeat string)
(const all)))
@@ -238,21 +223,17 @@ message. This gives a rough indication that active conversations
are occurring in these channels.
The effect may be disabled by setting this variable to nil."
- :group 'erc-track
:type '(repeat (choice face
(repeat :tag "Combination" face))))
(defcustom erc-track-position-in-mode-line 'before-modes
"Where to show modified channel information in the mode-line.
-Setting this variable only has effect in GNU Emacs versions above 21.3.
-
Choices are:
`before-modes' - add to the beginning of `mode-line-modes',
`after-modes' - add to the end of `mode-line-modes',
t - add to the end of `global-mode-string',
nil - don't add to mode line."
- :group 'erc-track
:type '(choice (const :tag "Just before mode information" before-modes)
(const :tag "Just after mode information" after-modes)
(const :tag "After all other information" t)
@@ -269,7 +250,7 @@ nil - don't add to mode line."
(if strings
(concat (if (eq erc-track-position-in-mode-line 'after-modes)
"[" " [")
- (mapconcat 'identity (nreverse strings) ",")
+ (mapconcat #'identity (nreverse strings) ",")
(if (eq erc-track-position-in-mode-line 'before-modes)
"] " "]"))
""))
@@ -292,20 +273,17 @@ while the buffer was not visible.")
(defcustom erc-track-showcount nil
"If non-nil, count of unseen messages will be shown for each channel."
- :type 'boolean
- :group 'erc-track)
+ :type 'boolean)
(defcustom erc-track-showcount-string ":"
"The string to display between buffer name and the count in the mode line.
The default is a colon, resulting in \"#emacs:9\"."
- :type 'string
- :group 'erc-track)
+ :type 'string)
(defcustom erc-track-switch-from-erc t
"If non-nil, `erc-track-switch-buffer' will return to the last non-erc buffer
when there are no more active channels."
- :type 'boolean
- :group 'erc-track)
+ :type 'boolean)
(defcustom erc-track-switch-direction 'oldest
"Direction `erc-track-switch-buffer' should switch.
@@ -319,7 +297,6 @@ when there are no more active channels."
If set to `importance', the importance is determined by position
in `erc-track-faces-priority-list', where first is most
important."
- :group 'erc-track
:type '(choice (const importance)
(const oldest)
(const newest)
@@ -329,9 +306,8 @@ important."
(defun erc-track-remove-from-mode-line ()
"Remove `erc-track-modified-channels' from the mode-line."
- (when (boundp 'mode-line-modes)
- (setq mode-line-modes
- (remove '(t erc-modified-channels-object) mode-line-modes)))
+ (setq mode-line-modes
+ (remove '(t erc-modified-channels-object) mode-line-modes))
(when (consp global-mode-string)
(setq global-mode-string
(delq 'erc-modified-channels-object global-mode-string))))
@@ -341,12 +317,10 @@ important."
See `erc-track-position-in-mode-line' for possible values."
;; CVS Emacs has a new format string, and global-mode-string
;; is very far to the right.
- (cond ((and (eq position 'before-modes)
- (boundp 'mode-line-modes))
+ (cond ((eq position 'before-modes)
(add-to-list 'mode-line-modes
'(t erc-modified-channels-object)))
- ((and (eq position 'after-modes)
- (boundp 'mode-line-modes))
+ ((eq position 'after-modes)
(add-to-list 'mode-line-modes
'(t erc-modified-channels-object) t))
((eq position t)
@@ -478,9 +452,9 @@ START is the minimum length of the name used."
(defvar erc-track-minor-mode-map (make-sparse-keymap)
"Keymap for rcirc track minor mode.")
-(define-key erc-track-minor-mode-map (kbd "C-c C-@") 'erc-track-switch-buffer)
+(define-key erc-track-minor-mode-map (kbd "C-c C-@") #'erc-track-switch-buffer)
(define-key erc-track-minor-mode-map (kbd "C-c C-SPC")
- 'erc-track-switch-buffer)
+ #'erc-track-switch-buffer)
;;;###autoload
(define-minor-mode erc-track-minor-mode
@@ -490,11 +464,7 @@ ERC Track minor mode is a global minor mode. It exists for the
sole purpose of providing the C-c C-SPC and C-c C-@ keybindings.
Make sure that you have enabled the track module, otherwise the
keybindings will not do anything useful."
- :init-value nil
- :lighter ""
- :keymap erc-track-minor-mode-map
- :global t
- :group 'erc-track)
+ :global t)
(defun erc-track-minor-mode-maybe (&optional buffer)
"Enable `erc-track-minor-mode', depending on `erc-track-enable-keybindings'."
@@ -536,17 +506,17 @@ keybindings will not do anything useful."
((when (boundp 'erc-track-when-inactive)
(if erc-track-when-inactive
(progn
- (add-hook 'window-configuration-change-hook 'erc-user-is-active)
- (add-hook 'erc-send-completed-hook 'erc-user-is-active)
- (add-hook 'erc-server-001-functions 'erc-user-is-active))
+ (add-hook 'window-configuration-change-hook #'erc-user-is-active)
+ (add-hook 'erc-send-completed-hook #'erc-user-is-active)
+ (add-hook 'erc-server-001-functions #'erc-user-is-active))
(erc-track-add-to-mode-line erc-track-position-in-mode-line)
(erc-update-mode-line)
(add-hook 'window-configuration-change-hook
- 'erc-window-configuration-change)
- (add-hook 'erc-insert-post-hook 'erc-track-modified-channels)
- (add-hook 'erc-disconnected-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
- (add-hook 'erc-connect-pre-hook 'erc-track-minor-mode-maybe)
+ (add-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe)
(erc-track-minor-mode-maybe)))
;; Disable:
((when (boundp 'erc-track-when-inactive)
@@ -554,23 +524,22 @@ keybindings will not do anything useful."
(if erc-track-when-inactive
(progn
(remove-hook 'window-configuration-change-hook
- 'erc-user-is-active)
- (remove-hook 'erc-send-completed-hook 'erc-user-is-active)
- (remove-hook 'erc-server-001-functions 'erc-user-is-active)
- (remove-hook 'erc-timer-hook 'erc-user-is-active))
+ #'erc-user-is-active)
+ (remove-hook 'erc-send-completed-hook #'erc-user-is-active)
+ (remove-hook 'erc-server-001-functions #'erc-user-is-active)
+ (remove-hook 'erc-timer-hook #'erc-user-is-active))
(remove-hook 'window-configuration-change-hook
- 'erc-window-configuration-change)
- (remove-hook 'erc-disconnected-hook 'erc-modified-channels-update)
- (remove-hook 'erc-insert-post-hook 'erc-track-modified-channels))
+ #'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
- (remove-hook 'erc-connect-pre-hook 'erc-track-minor-mode-maybe)
+ (remove-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe)
(when erc-track-minor-mode
(erc-track-minor-mode -1)))))
(defcustom erc-track-when-inactive nil
"Enable channel tracking even for visible buffers, if you are
inactive."
- :group 'erc-track
:type 'boolean
:set (lambda (sym val)
(if erc-track-mode
@@ -711,12 +680,12 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
;; four lists we use to create a new
;; `erc-modified-channels-object' using
;; `erc-make-mode-line-buffer-name'.
- (let* ((buffers (mapcar 'car erc-modified-channels-alist))
- (counts (mapcar 'cadr erc-modified-channels-alist))
- (faces (mapcar 'cddr erc-modified-channels-alist))
- (long-names (mapcar #'(lambda (buf)
- (or (buffer-name buf)
- ""))
+ (let* ((buffers (mapcar #'car erc-modified-channels-alist))
+ (counts (mapcar #'cadr erc-modified-channels-alist))
+ (faces (mapcar #'cddr erc-modified-channels-alist))
+ (long-names (mapcar (lambda (buf)
+ (or (buffer-name buf)
+ ""))
buffers))
(short-names (if (functionp erc-track-shorten-function)
(funcall erc-track-shorten-function
diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el
index f4514ca1371..ff33fbc5570 100644
--- a/lisp/erc/erc-truncate.el
+++ b/lisp/erc/erc-truncate.el
@@ -1,4 +1,4 @@
-;;; erc-truncate.el --- Functions for truncating ERC buffers
+;;; erc-truncate.el --- Functions for truncating ERC buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2004, 2006-2021 Free Software Foundation, Inc.
@@ -41,7 +41,6 @@
"Maximum size in chars of each ERC buffer.
Used only when auto-truncation is enabled.
\(see `erc-truncate-buffer' and `erc-insert-post-hook')."
- :group 'erc-truncate
:type 'integer)
;;;###autoload(autoload 'erc-truncate-mode "erc-truncate" nil t)
@@ -51,9 +50,9 @@ This prevents the query buffer from getting too large, which can
bring any grown Emacs to its knees after a few days worth of
tracking heavy-traffic channels."
;;enable
- ((add-hook 'erc-insert-post-hook 'erc-truncate-buffer))
+ ((add-hook 'erc-insert-post-hook #'erc-truncate-buffer))
;; disable
- ((remove-hook 'erc-insert-post-hook 'erc-truncate-buffer)))
+ ((remove-hook 'erc-insert-post-hook #'erc-truncate-buffer)))
;;;###autoload
(defun erc-truncate-buffer-to-size (size &optional buffer)
diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el
index 6808f24911d..e1b9f0de3a7 100644
--- a/lisp/erc/erc-xdcc.el
+++ b/lisp/erc/erc-xdcc.el
@@ -1,10 +1,10 @@
-;;; erc-xdcc.el --- XDCC file-server support for ERC
+;;; erc-xdcc.el --- XDCC file-server support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2004, 2006-2021 Free Software Foundation, Inc.
;; Author: Mario Lang <mlang@delysid.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
-;; Keywords: comm, processes
+;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -51,7 +51,7 @@ Your friends should issue \"/ctcp yournick XDCC list\" to see this."
(defcustom erc-xdcc-help-text
'(("Hey " nick ", wondering how this works? Pretty easy.")
("Available commands: XDCC ["
- (mapconcat 'car erc-xdcc-handler-alist "|") "]")
+ (mapconcat #'car erc-xdcc-handler-alist "|") "]")
("Type \"/ctcp " (erc-current-nick)
" XDCC list\" to see the list of offered files, then type \"/ctcp "
(erc-current-nick) " XDCC send #\" to get a particular file number."))
@@ -82,7 +82,7 @@ being evaluated and should return strings."
(defvar erc-ctcp-query-XDCC-hook '(erc-xdcc)
"Hook called whenever a CTCP XDCC message is received.")
-(defun erc-xdcc (proc nick login host to query)
+(defun erc-xdcc (proc nick login host _to query)
"Handle incoming CTCP XDCC queries."
(when erc-xdcc-verbose-flag
(erc-display-message nil 'notice proc
@@ -96,15 +96,15 @@ being evaluated and should return strings."
(format "Unknown XDCC sub-command, try \"/ctcp %s XDCC help\""
(erc-current-nick))))))
-(defun erc-xdcc-help (proc nick login host args)
+(defun erc-xdcc-help (proc nick _login _host _args)
"Send basic help information to NICK."
(mapc
(lambda (msg)
(erc-xdcc-reply proc nick
- (mapconcat (lambda (elt) (if (stringp elt) elt (eval elt))) msg "")))
+ (mapconcat (lambda (elt) (if (stringp elt) elt (eval elt t))) msg "")))
erc-xdcc-help-text))
-(defun erc-xdcc-list (proc nick login host args)
+(defun erc-xdcc-list (proc nick _login _host _args)
"Show the contents of `erc-xdcc-files' via privmsg to NICK."
(if (null erc-xdcc-files)
(erc-xdcc-reply proc nick "No files offered, sorry")
@@ -117,7 +117,7 @@ being evaluated and should return strings."
(setq n (1+ n))
(erc-dcc-file-to-name file)))))))
-(defun erc-xdcc-send (proc nick login host args)
+(defun erc-xdcc-send (proc nick _login _host args)
"Send a file to NICK."
(let ((n (string-to-number (car args)))
(len (length erc-xdcc-files)))
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 2bd58ba9379..026c6f84164 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -1,4 +1,4 @@
-;; erc.el --- An Emacs Internet Relay Chat client -*- lexical-binding:t -*-
+;;; erc.el --- An Emacs Internet Relay Chat client -*- lexical-binding:t -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -9,6 +9,7 @@
;; Andreas Fuchs (afs@void.at)
;; Gergely Nagy (algernon@midgard.debian.net)
;; David Edmondson (dme@dme.org)
+;; Michael Olson (mwolson@gnu.org)
;; Kelvin White (kwhite@gnu.org)
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; Keywords: IRC, chat, client, Internet
@@ -47,22 +48,24 @@
;;
;; M-x erc RET
;;
-;; After you are connected to a server, you can use C-h m or have a look at
-;; the ERC menu.
-
-;;; History:
+;; or
+;;
+;; M-x erc-tls RET
;;
+;; to connect over TLS (encrypted). Once you are connected to a
+;; server, you can use C-h m or have a look at the ERC menu.
;;; Code:
(load "erc-loaddefs" nil t)
-(eval-when-compile (require 'cl-lib))
-(require 'font-lock)
+(require 'cl-lib)
+(require 'format-spec)
(require 'pp)
(require 'thingatpt)
(require 'auth-source)
-(require 'erc-compat)
+(require 'time-date)
+(require 'iso8601)
(eval-when-compile (require 'subr-x))
(defvar erc-official-location
@@ -113,17 +116,6 @@
"Running scripts at startup and with /LOAD"
:group 'erc)
-;; compatibility with older ERC releases
-
-(define-obsolete-variable-alias 'erc-announced-server-name
- 'erc-server-announced-name "ERC 5.1")
-(define-obsolete-variable-alias 'erc-process 'erc-server-process "ERC 5.1")
-(define-obsolete-variable-alias 'erc-default-coding-system
- 'erc-server-coding-system "ERC 5.1")
-
-(define-obsolete-function-alias 'erc-send-command
- 'erc-server-send "ERC 5.1")
-
(require 'erc-backend)
;; tunable connection and authentication parameters
@@ -269,9 +261,8 @@ A typical value would be \((\"#emacs\" \"QUIT\" \"JOIN\")
:group 'erc-ignore
:type 'erc-message-type)
-(defvar erc-session-password nil
+(defvar-local erc-session-password nil
"The password used for the current session.")
-(make-variable-buffer-local 'erc-session-password)
(defcustom erc-disconnected-hook nil
"Run this hook with arguments (NICK IP REASON) when disconnected.
@@ -336,18 +327,16 @@ Functions are passed a buffer as the first argument."
:type 'hook)
-(defvar erc-channel-users nil
+(defvar-local erc-channel-users nil
"A hash table of members in the current channel, which
associates nicknames with cons cells of the form:
\(USER . MEMBER-DATA) where USER is a pointer to an
erc-server-user struct, and MEMBER-DATA is a pointer to an
erc-channel-user struct.")
-(make-variable-buffer-local 'erc-channel-users)
-(defvar erc-server-users nil
+(defvar-local erc-server-users nil
"A hash table of users on the current server, which associates
nicknames with erc-server-user struct instances.")
-(make-variable-buffer-local 'erc-server-users)
(defun erc-downcase (string)
"Convert STRING to IRC standard conforming downcase."
@@ -631,23 +620,19 @@ See also: `erc-get-channel-user-list'."
(or (not nicky)
(string-lessp nickx nicky))))))))
-(defvar erc-channel-topic nil
+(defvar-local erc-channel-topic nil
"A topic string for the channel. Should only be used in channel-buffers.")
-(make-variable-buffer-local 'erc-channel-topic)
-(defvar erc-channel-modes nil
+(defvar-local erc-channel-modes nil
"List of strings representing channel modes.
E.g. (\"i\" \"m\" \"s\" \"b Quake!*@*\")
\(not sure the ban list will be here, but why not)")
-(make-variable-buffer-local 'erc-channel-modes)
-(defvar erc-insert-marker nil
+(defvar-local erc-insert-marker nil
"The place where insertion of new text in erc buffers should happen.")
-(make-variable-buffer-local 'erc-insert-marker)
-(defvar erc-input-marker nil
+(defvar-local erc-input-marker nil
"The marker where input should be inserted.")
-(make-variable-buffer-local 'erc-input-marker)
(defun erc-string-no-properties (string)
"Return a copy of STRING will all text-properties removed."
@@ -875,8 +860,8 @@ See `erc-server-flood-margin' for other flood-related parameters.")
;; Script parameters
(defcustom erc-startup-file-list
- (list (concat erc-user-emacs-directory ".ercrc.el")
- (concat erc-user-emacs-directory ".ercrc")
+ (list (concat user-emacs-directory ".ercrc.el")
+ (concat user-emacs-directory ".ercrc")
"~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc")
"List of files to try for a startup script.
The first existent and readable one will get executed.
@@ -899,9 +884,8 @@ directory in the list."
:group 'erc-scripts
:type 'boolean)
-(defvar erc-last-saved-position nil
+(defvar-local erc-last-saved-position nil
"A marker containing the position the current buffer was last saved at.")
-(make-variable-buffer-local 'erc-last-saved-position)
(defcustom erc-kill-buffer-on-part nil
"Kill the channel buffer on PART.
@@ -1045,8 +1029,8 @@ anyway."
(make-obsolete-variable 'erc-send-pre-hook 'erc-pre-send-functions "27.1")
(defcustom erc-pre-send-functions nil
- "List of functions called to possibly alter the string that is sent.
-The functions are called with one argument, a `erc-input' struct,
+ "Special hook run to possibly alter the string that is sent.
+The functions are called with one argument, an `erc-input' struct,
and should alter that struct.
The struct has three slots:
@@ -1055,7 +1039,7 @@ The struct has three slots:
`insertp': Whether the string should be inserted into the erc buffer.
`sendp': Whether the string should be sent to the irc server."
:group 'erc
- :type '(repeat function)
+ :type 'hook
:version "27.1")
(defvar erc-insert-this t
@@ -1151,31 +1135,31 @@ which the local user typed."
(defvar erc-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-m" 'erc-send-current-line)
- (define-key map "\C-a" 'erc-bol)
- (define-key map [home] 'erc-bol)
- (define-key map "\C-c\C-a" 'erc-bol)
- (define-key map "\C-c\C-b" 'erc-switch-to-buffer)
- (define-key map "\C-c\C-c" 'erc-toggle-interpret-controls)
- (define-key map "\C-c\C-d" 'erc-input-action)
- (define-key map "\C-c\C-e" 'erc-toggle-ctcp-autoresponse)
- (define-key map "\C-c\C-f" 'erc-toggle-flood-control)
- (define-key map "\C-c\C-i" 'erc-invite-only-mode)
- (define-key map "\C-c\C-j" 'erc-join-channel)
- (define-key map "\C-c\C-n" 'erc-channel-names)
- (define-key map "\C-c\C-o" 'erc-get-channel-mode-from-keypress)
- (define-key map "\C-c\C-p" 'erc-part-from-channel)
- (define-key map "\C-c\C-q" 'erc-quit-server)
- (define-key map "\C-c\C-r" 'erc-remove-text-properties-region)
- (define-key map "\C-c\C-t" 'erc-set-topic)
- (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" 'completion-at-point)
+ (define-key map "\C-m" #'erc-send-current-line)
+ (define-key map "\C-a" #'erc-bol)
+ (define-key map [home] #'erc-bol)
+ (define-key map "\C-c\C-a" #'erc-bol)
+ (define-key map "\C-c\C-b" #'erc-switch-to-buffer)
+ (define-key map "\C-c\C-c" #'erc-toggle-interpret-controls)
+ (define-key map "\C-c\C-d" #'erc-input-action)
+ (define-key map "\C-c\C-e" #'erc-toggle-ctcp-autoresponse)
+ (define-key map "\C-c\C-f" #'erc-toggle-flood-control)
+ (define-key map "\C-c\C-i" #'erc-invite-only-mode)
+ (define-key map "\C-c\C-j" #'erc-join-channel)
+ (define-key map "\C-c\C-n" #'erc-channel-names)
+ (define-key map "\C-c\C-o" #'erc-get-channel-mode-from-keypress)
+ (define-key map "\C-c\C-p" #'erc-part-from-channel)
+ (define-key map "\C-c\C-q" #'erc-quit-server)
+ (define-key map "\C-c\C-r" #'erc-remove-text-properties-region)
+ (define-key map "\C-c\C-t" #'erc-set-topic)
+ (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" #'completion-at-point)
;; Suppress `font-lock-fontify-block' key binding since it
;; destroys face properties.
- (define-key map [remap font-lock-fontify-block] 'undefined)
+ (define-key map [remap font-lock-fontify-block] #'undefined)
map)
"ERC keymap.")
@@ -1212,7 +1196,7 @@ which the local user typed."
:group 'erc-faces)
(defface erc-header-line
- '((t :foreground "grey20" :background "grey90"))
+ '((t :inherit header-line))
"ERC face used for the header line.
This will only be used if `erc-header-line-face-method' is non-nil."
@@ -1270,8 +1254,7 @@ See also `erc-show-my-nick'."
(defvar erc-debug-log-file (expand-file-name "ERC.debug")
"Debug log file name.")
-(defvar erc-dbuf nil)
-(make-variable-buffer-local 'erc-dbuf)
+(defvar-local erc-dbuf nil)
(defmacro define-erc-module (name alias doc enable-body disable-body
&optional local-p)
@@ -1294,9 +1277,9 @@ Example:
(define-erc-module replace nil
\"This mode replaces incoming text according to `erc-replace-alist'.\"
((add-hook \\='erc-insert-modify-hook
- \\='erc-replace-insert))
+ #\\='erc-replace-insert))
((remove-hook \\='erc-insert-modify-hook
- \\='erc-replace-insert)))"
+ #\\='erc-replace-insert)))"
(declare (doc-string 3))
(let* ((sn (symbol-name name))
(mode (intern (format "erc-%s-mode" (downcase sn))))
@@ -1304,14 +1287,16 @@ Example:
(enable (intern (format "erc-%s-enable" (downcase sn))))
(disable (intern (format "erc-%s-disable" (downcase sn)))))
`(progn
- (erc-define-minor-mode
+ (define-minor-mode
,mode
,(format "Toggle ERC %S mode.
With a prefix argument ARG, enable %s if ARG is positive,
and disable it otherwise. If called from Lisp, enable the mode
if ARG is omitted or nil.
%s" name name doc)
- nil nil nil
+ ;; FIXME: We don't know if this group exists, so this `:group' may
+ ;; actually just silence a valid warning about the fact that the var
+ ;; is not associated with any group.
:global ,(not local-p) :group (quote ,group)
(if ,mode
(,enable)
@@ -1332,12 +1317,10 @@ if ARG is omitted or nil.
,@disable-body)
,(when (and alias (not (eq name alias)))
`(defalias
- (quote
- ,(intern
+ ',(intern
(format "erc-%s-mode"
- (downcase (symbol-name alias)))))
- (quote
- ,mode)))
+ (downcase (symbol-name alias))))
+ #',mode))
;; For find-function and find-variable.
(put ',mode 'definition-name ',name)
(put ',enable 'definition-name ',name)
@@ -1461,11 +1444,10 @@ If BUFFER is nil, the current buffer is used."
;; Last active buffer, to print server messages in the right place
-(defvar erc-active-buffer nil
+(defvar-local erc-active-buffer nil
"The current active buffer, the one where the user typed the last command.
Defaults to the server buffer, and should only be set in the
server buffer.")
-(make-variable-buffer-local 'erc-active-buffer)
(defun erc-active-buffer ()
"Return the value of `erc-active-buffer' for the current server.
@@ -1487,15 +1469,14 @@ Defaults to the server buffer."
(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-local next-line-add-newlines nil)
(setq line-move-ignore-invisible t)
- (set (make-local-variable 'paragraph-separate)
- (concat "\C-l\\|\\(^" (regexp-quote (erc-prompt)) "\\)"))
- (set (make-local-variable 'paragraph-start)
- (concat "\\(" (regexp-quote (erc-prompt)) "\\)"))
+ (setq-local paragraph-separate
+ (concat "\C-l\\|\\(^" (regexp-quote (erc-prompt)) "\\)"))
+ (setq-local paragraph-start
+ (concat "\\(" (regexp-quote (erc-prompt)) "\\)"))
(setq-local completion-ignore-case t)
- (add-hook 'completion-at-point-functions 'erc-complete-word-at-point nil t))
+ (add-hook 'completion-at-point-functions #'erc-complete-word-at-point nil t))
;; activation
@@ -1606,33 +1587,47 @@ symbol, it may have these values:
(defun erc-generate-new-buffer-name (server port target)
"Create a new buffer name based on the arguments."
(when (numberp port) (setq port (number-to-string port)))
- (let ((buf-name (or target
- (or (let ((name (concat server ":" port)))
- (when (> (length name) 1)
- name))
- ;; This fallback should in fact never happen
- "*erc-server-buffer*")))
- buffer-name)
+ (let* ((buf-name (or target
+ (let ((name (concat server ":" port)))
+ (when (> (length name) 1)
+ name))
+ ;; This fallback should in fact never happen.
+ "*erc-server-buffer*"))
+ (full-buf-name (concat buf-name "/" server))
+ (dup-buf-name (buffer-name (car (erc-channel-list nil))))
+ buffer-name)
;; Reuse existing buffers, but not if the buffer is a connected server
;; buffer and not if its associated with a different server than the
;; current ERC buffer.
- ;; if buf-name is taken by a different connection (or by something !erc)
- ;; then see if "buf-name/server" meets the same criteria
- (dolist (candidate (list buf-name (concat buf-name "/" server)))
- (if (and (not buffer-name)
- erc-reuse-buffers
- (or (not (get-buffer candidate))
- (or target
- (with-current-buffer (get-buffer candidate)
- (and (erc-server-buffer-p)
- (not (erc-server-process-alive)))))
- (with-current-buffer (get-buffer candidate)
- (and (string= erc-session-server server)
- (erc-port-equal erc-session-port port)))))
- (setq buffer-name candidate)))
- ;; if buffer-name is unset, neither candidate worked out for us,
+ ;; If buf-name is taken by a different connection (or by something !erc)
+ ;; then see if "buf-name/server" meets the same criteria.
+ (if (and dup-buf-name (string-match-p (concat buf-name "/") dup-buf-name))
+ (setq buffer-name full-buf-name) ; ERC buffer with full name already exists.
+ (dolist (candidate (list buf-name full-buf-name))
+ (if (and (not buffer-name)
+ erc-reuse-buffers
+ (or (not (get-buffer candidate))
+ ;; Looking for a server buffer, so there's no target.
+ (and (not target)
+ (with-current-buffer (get-buffer candidate)
+ (and (erc-server-buffer-p)
+ (not (erc-server-process-alive)))))
+ ;; Channel buffer; check that it's from the right server.
+ (and target
+ (with-current-buffer (get-buffer candidate)
+ (and (string= erc-session-server server)
+ (erc-port-equal erc-session-port port))))))
+ (setq buffer-name candidate)
+ (when (and (not buffer-name) (get-buffer buf-name) erc-reuse-buffers)
+ ;; A new buffer will be created with the name buf-name/server, rename
+ ;; the existing name-duplicated buffer with the same format as well.
+ (with-current-buffer (get-buffer buf-name)
+ (when (derived-mode-p 'erc-mode) ; ensure it's an erc buffer
+ (rename-buffer
+ (concat buf-name "/" (or erc-session-server erc-server-announced-name)))))))))
+ ;; If buffer-name is unset, neither candidate worked out for us,
;; fallback to the old <N> uniquification method:
- (or buffer-name (generate-new-buffer-name (concat buf-name "/" server)))))
+ (or buffer-name (generate-new-buffer-name full-buf-name))))
(defun erc-get-buffer-create (server port target)
"Create a new buffer based on the arguments."
@@ -1752,7 +1747,7 @@ nil."
(ignore res)
res)))
-(define-obsolete-function-alias 'erc-iswitchb 'erc-switch-to-buffer "25.1")
+(define-obsolete-function-alias 'erc-iswitchb #'erc-switch-to-buffer "25.1")
(defun erc--switch-to-buffer (&optional arg)
(read-buffer "Switch to ERC buffer: "
(when (boundp 'erc-modified-channels-alist)
@@ -1806,59 +1801,48 @@ all channel buffers on all servers."
;; Some local variables
-(defvar erc-default-recipients nil
+(defvar-local erc-default-recipients nil
"List of default recipients of the current buffer.")
-(make-variable-buffer-local 'erc-default-recipients)
-(defvar erc-session-user-full-name nil
+(defvar-local erc-session-user-full-name nil
"Full name of the user on the current server.")
-(make-variable-buffer-local 'erc-session-user-full-name)
-(defvar erc-channel-user-limit nil
+(defvar-local erc-channel-user-limit nil
"Limit of users per channel.")
-(make-variable-buffer-local 'erc-channel-user-limit)
-(defvar erc-channel-key nil
+(defvar-local erc-channel-key nil
"Key needed to join channel.")
-(make-variable-buffer-local 'erc-channel-key)
-(defvar erc-invitation nil
+(defvar-local erc-invitation nil
"Last invitation channel.")
-(make-variable-buffer-local 'erc-invitation)
-(defvar erc-away nil
+(defvar-local erc-away nil
"Non-nil indicates that we are away.
Use `erc-away-time' to access this if you might be in a channel
buffer rather than a server buffer.")
-(make-variable-buffer-local 'erc-away)
-(defvar erc-channel-list nil
+(defvar-local erc-channel-list nil
"Server channel list.")
-(make-variable-buffer-local 'erc-channel-list)
-(defvar erc-bad-nick nil
+(defvar-local erc-bad-nick nil
"Non-nil indicates that we got a `nick in use' error while connecting.")
-(make-variable-buffer-local 'erc-bad-nick)
-(defvar erc-logged-in nil
+(defvar-local erc-logged-in nil
"Non-nil indicates that we are logged in.")
-(make-variable-buffer-local 'erc-logged-in)
-(defvar erc-default-nicks nil
+(defvar-local erc-default-nicks nil
"The local copy of `erc-nick' - the list of nicks to choose from.")
-(make-variable-buffer-local 'erc-default-nicks)
-(defvar erc-nick-change-attempt-count 0
+(defvar-local erc-nick-change-attempt-count 0
"Used to keep track of how many times an attempt at changing nick is made.")
-(make-variable-buffer-local 'erc-nick-change-attempt-count)
(defun erc-migrate-modules (mods)
"Migrate old names of ERC modules to new ones."
;; modify `transforms' to specify what needs to be changed
;; each item is in the format '(old . new)
(let ((transforms '((pcomplete . completion))))
- (erc-delete-dups
+ (delete-dups
(mapcar (lambda (m) (or (cdr (assoc m transforms)) m))
mods))))
@@ -1872,7 +1856,7 @@ removed from the list will be disabled."
:get (lambda (sym)
;; replace outdated names with their newer equivalents
(erc-migrate-modules (symbol-value sym)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
;; disable modules which have just been removed
(when (and (boundp 'erc-modules) erc-modules val)
@@ -1988,7 +1972,8 @@ removed from the list will be disabled."
(switch-to-buffer buffer)))))
(defun erc-open (&optional server port nick full-name
- connect passwd tgt-list channel process)
+ connect passwd tgt-list channel process
+ client-certificate)
"Connect to SERVER on PORT as NICK with FULL-NAME.
If CONNECT is non-nil, connect to the server. Otherwise assume
@@ -1998,6 +1983,13 @@ target CHANNEL.
Use PASSWD as user password on the server. If TGT-LIST is
non-nil, use it to initialize `erc-default-recipients'.
+CLIENT-CERTIFICATE, if non-nil, should either be a list where the
+first element is the file name of the private key corresponding
+to a client certificate and the second element is the file name
+of the client certificate itself to use when connecting over TLS,
+or t, which means that `auth-source' will be queried for the
+private key and the certificate.
+
Returns the buffer for the given server or channel."
(let ((server-announced-name (when (and (boundp 'erc-session-server)
(string= server erc-session-server))
@@ -2080,6 +2072,8 @@ Returns the buffer for the given server or channel."
(if (functionp secret)
(funcall secret)
secret))))
+ ;; client certificate (only useful if connecting over TLS)
+ (setq erc-session-client-certificate client-certificate)
;; debug output buffer
(setq erc-dbuf
(when erc-log-p
@@ -2100,7 +2094,10 @@ Returns the buffer for the given server or channel."
(run-hook-with-args 'erc-connect-pre-hook buffer)
(when connect
- (erc-server-connect erc-session-server erc-session-port buffer))
+ (erc-server-connect erc-session-server
+ erc-session-port
+ buffer
+ erc-session-client-certificate))
(erc-update-mode-line)
;; Now display the buffer in a window as per user wishes.
@@ -2143,33 +2140,34 @@ If no buffer matches, return nil."
(erc-current-nick-p nick)))))
(defcustom erc-before-connect nil
- "Hook called before connecting to a server.
-This hook gets executed before `erc' actually invokes `erc-mode'
-with your input data. The functions in here get called with three
-parameters, SERVER, PORT and NICK."
+ "Functions called before connecting to a server.
+The functions in this variable gets executed before `erc'
+actually invokes `erc-mode' with your input data. The functions
+in here get called with three parameters, SERVER, PORT and NICK."
:group 'erc-hooks
- :type 'hook)
+ :type '(repeat function))
(defcustom erc-after-connect nil
- "Hook called after connecting to a server.
-This hook gets executed when an end of MOTD has been received. All
-functions in here get called with the parameters SERVER and NICK."
+ "Functions called after connecting to a server.
+This functions in this variable gets executed when an end of MOTD
+has been received. All functions in here get called with the
+parameters SERVER and NICK."
:group 'erc-hooks
- :type 'hook)
+ :type '(repeat function))
;;;###autoload
(defun erc-select-read-args ()
"Prompt the user for values of nick, server, port, and password."
(let (user-input server port nick passwd)
- (setq user-input (read-from-minibuffer
+ (setq user-input (read-string
"IRC server: "
- (erc-compute-server) nil nil 'erc-server-history-list))
+ (erc-compute-server) 'erc-server-history-list))
(if (string-match "\\(.*\\):\\(.*\\)\\'" user-input)
(setq port (erc-string-to-port (match-string 2 user-input))
user-input (match-string 1 user-input))
(setq port
- (erc-string-to-port (read-from-minibuffer
+ (erc-string-to-port (read-string
"IRC port: " (erc-port-to-string
(erc-compute-port))))))
@@ -2178,13 +2176,12 @@ functions in here get called with the parameters SERVER and NICK."
user-input (match-string 2 user-input))
(setq nick
(if (erc-already-logged-in server port nick)
- (read-from-minibuffer
+ (read-string
(erc-format-message 'nick-in-use ?n nick)
- nick
- nil nil 'erc-nick-history-list)
- (read-from-minibuffer
+ nick 'erc-nick-history-list)
+ (read-string
"Nickname: " (erc-compute-nick nick)
- nil nil 'erc-nick-history-list))))
+ 'erc-nick-history-list))))
(setq server user-input)
@@ -2203,10 +2200,9 @@ functions in here get called with the parameters SERVER and NICK."
;; bnc with the same nick. actually it would be nice to have
;; bncs transparent, so that erc-compute-buffer-name displays
;; the server one is connected to.
- (setq nick (read-from-minibuffer
+ (setq nick (read-string
(erc-format-message 'nick-in-use ?n nick)
- nick
- nil nil 'erc-nick-history-list)))
+ nick 'erc-nick-history-list)))
(list :server server :port port :nick nick :password passwd)))
;;;###autoload
@@ -2218,45 +2214,90 @@ functions in here get called with the parameters SERVER and NICK."
"ERC is a powerful, modular, and extensible IRC client.
This function is the main entry point for ERC.
-It permits you to select connection parameters, and then starts ERC.
+It allows selecting connection parameters, and then starts ERC.
Non-interactively, it takes the keyword arguments
(server (erc-compute-server))
(port (erc-compute-port))
(nick (erc-compute-nick))
password
- (full-name (erc-compute-full-name)))
+ (full-name (erc-compute-full-name))
That is, if called with
(erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-then the server and full-name will be set to those values, whereas
-`erc-compute-port', `erc-compute-nick' and `erc-compute-full-name' will
-be invoked for the values of the other parameters."
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of the other parameters."
(interactive (erc-select-read-args))
(erc-open server port nick full-name t password))
;;;###autoload
-(defalias 'erc-select 'erc)
-(defalias 'erc-ssl 'erc-tls)
+(defalias 'erc-select #'erc)
+(defalias 'erc-ssl #'erc-tls)
;;;###autoload
-(defun erc-tls (&rest r)
- "Interactively select TLS connection parameters and run ERC.
-Arguments are the same as for `erc'."
+(cl-defun erc-tls (&key (server (erc-compute-server))
+ (port (erc-compute-port))
+ (nick (erc-compute-nick))
+ password
+ (full-name (erc-compute-full-name))
+ client-certificate)
+ "ERC is a powerful, modular, and extensible IRC client.
+This function is the main entry point for ERC over TLS.
+
+It allows selecting connection parameters, and then starts ERC
+over TLS.
+
+Non-interactively, it takes the keyword arguments
+ (server (erc-compute-server))
+ (port (erc-compute-port))
+ (nick (erc-compute-nick))
+ password
+ (full-name (erc-compute-full-name))
+ client-certificate
+
+That is, if called with
+
+ (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
+
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of their respective parameters.
+
+CLIENT-CERTIFICATE, if non-nil, should either be a list where the
+first element is the certificate key file name, and the second
+element is the certificate file name itself, or t, which means
+that `auth-source' will be queried for the key and the
+certificate. Authenticating using a TLS client certificate is
+also refered to as \"CertFP\" (Certificate Fingerprint)
+authentication by various IRC networks.
+
+Example usage:
+
+ (erc-tls :server \"irc.libera.chat\" :port 6697
+ :client-certificate
+ '(\"/home/bandali/my-cert.key\"
+ \"/home/bandali/my-cert.crt\"))"
(interactive (let ((erc-default-port erc-default-port-tls))
(erc-select-read-args)))
(let ((erc-server-connect-function 'erc-open-tls-stream))
- (apply #'erc r)))
+ (erc-open server port nick full-name t password
+ nil nil nil client-certificate)))
-(defun erc-open-tls-stream (name buffer host port)
+(defun erc-open-tls-stream (name buffer host port &rest parameters)
"Open an TLS stream to an IRC server.
-The process will be given the name NAME, its target buffer will be
-BUFFER. HOST and PORT specify the connection target."
- (open-network-stream name buffer host port
- :nowait t
- :type 'tls))
+The process will be given the name NAME, its target buffer will
+be BUFFER. HOST and PORT specify the connection target.
+PARAMETERS should be a sequence of keywords and values, per
+`open-network-stream'."
+ (let ((p (plist-put parameters :type 'tls))
+ args)
+ (unless (plist-member p :nowait)
+ (setq p (plist-put p :nowait t)))
+ (setq args `(,name ,buffer ,host ,port ,@p))
+ (apply #'open-network-stream args)))
;;; Displaying error messages
@@ -2311,7 +2352,7 @@ and appears in face `erc-input-face' in the buffer."
(setq result (concat result network-name
" << " line "\n")))
result)
- (erc-propertize
+ (propertize
(concat network-name " >> " string
(if (/= ?\n
(aref string
@@ -2334,7 +2375,7 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(interactive "P")
(let* ((buf (get-buffer-create "*erc-protocol*")))
(with-current-buffer buf
- (erc-view-mode-enter)
+ (view-mode-enter)
(when (null (current-local-map))
(let ((inhibit-read-only t))
(insert (erc-make-notice "This buffer displays all IRC protocol traffic exchanged with each server.\n"))
@@ -2342,7 +2383,7 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(use-local-map (make-sparse-keymap))
(local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol))
(add-hook 'kill-buffer-hook
- #'(lambda () (setq erc-debug-irc-protocol nil))
+ (lambda () (setq erc-debug-irc-protocol nil))
nil 'local)
(goto-char (point-max))
(let ((inhibit-read-only t))
@@ -2571,7 +2612,7 @@ This function adds `erc-lurker-update-status' to
most recent PRIVMSG as well as initializing the state variable
storing this information."
(setq erc-lurker-state (make-hash-table :test 'equal))
- (add-hook 'erc-insert-pre-hook 'erc-lurker-update-status))
+ (add-hook 'erc-insert-pre-hook #'erc-lurker-update-status))
(defun erc-lurker-cleanup ()
"Remove all last PRIVMSG state older than `erc-lurker-threshold-time'.
@@ -2672,7 +2713,7 @@ displayed hostnames."
otherwise `erc-server-announced-name'. SERVER is matched against
`erc-common-server-suffixes'."
(when server
- (or (cdar (erc-remove-if-not
+ (or (cdar (cl-remove-if-not
(lambda (net) (string-match (car net) server))
erc-common-server-suffixes))
erc-server-announced-name)))
@@ -2680,7 +2721,7 @@ otherwise `erc-server-announced-name'. SERVER is matched against
(defun erc-add-targets (scope target-list)
(let ((targets
(mapcar (lambda (targets) (member scope targets)) target-list)))
- (cdr (apply 'append (delete nil targets)))))
+ (cdr (apply #'append (delete nil targets)))))
(defun erc-hide-current-message-p (parsed)
"Predicate indicating whether the parsed ERC response PARSED should be hidden.
@@ -2750,8 +2791,7 @@ present."
(let ((prop-val (erc-get-parsed-vector position)))
(and prop-val (member (erc-response.command prop-val) list))))
-(defvar erc-send-input-line-function 'erc-send-input-line)
-(make-variable-buffer-local 'erc-send-input-line-function)
+(defvar-local erc-send-input-line-function 'erc-send-input-line)
(defun erc-send-input-line (target line &optional force)
"Send LINE to TARGET.
@@ -2768,7 +2808,7 @@ See also `erc-server-send'."
(defun erc-get-arglist (fun)
"Return the argument list of a function without the parens."
- (let ((arglist (format "%S" (erc-function-arglist fun))))
+ (let ((arglist (format "%S" (help-function-arglist fun))))
(if (string-match "\\`(\\(.*\\))\\'" arglist)
(match-string 1 arglist)
arglist)))
@@ -2861,14 +2901,14 @@ VALUE is computed by evaluating the rest of LINE in Lisp."
(val (read (match-string 2 line))))
(if (boundp var)
(progn
- (set var (eval val))
+ (set var (eval val t))
(erc-display-message
nil nil 'active (format "Set %S to %S" var val))
t)
(setq var (read (match-string 1 line)))
(if (boundp var)
(progn
- (set var (eval val))
+ (set var (eval val t))
(erc-display-message
nil nil 'active (format "Set %S to %S" var val))
t)
@@ -2890,8 +2930,8 @@ VALUE is computed by evaluating the rest of LINE in Lisp."
(current-buffer))
t)
(t nil)))
-(defalias 'erc-cmd-VAR 'erc-cmd-SET)
-(defalias 'erc-cmd-VARIABLE 'erc-cmd-SET)
+(defalias 'erc-cmd-VAR #'erc-cmd-SET)
+(defalias 'erc-cmd-VARIABLE #'erc-cmd-SET)
(put 'erc-cmd-SET 'do-not-parse-args t)
(put 'erc-cmd-SET 'process-not-needed t)
@@ -2905,6 +2945,44 @@ therefore has to contain the command itself as well."
(erc-server-send (substring line 1))
t)
+(defvar erc--read-time-period-history nil)
+
+(defun erc--read-time-period (prompt)
+ "Read a time period on the \"2h\" format.
+If there's no letter spec, the input is interpreted as a number of seconds.
+
+If input is blank, this function returns nil. Otherwise it
+returns the time spec converted to a number of seconds."
+ (let ((period (string-trim
+ (read-string prompt nil 'erc--read-time-period-history))))
+ (cond
+ ;; Blank input.
+ ((zerop (length period))
+ nil)
+ ;; All-number -- interpret as seconds.
+ ((string-match-p "\\`[0-9]+\\'" period)
+ (string-to-number period))
+ ;; Parse as a time spec.
+ (t
+ (let ((time (condition-case nil
+ (iso8601-parse-duration
+ (concat (cond
+ ((string-match-p "\\`P" (upcase period))
+ ;; Somebody typed in a full ISO8601 period.
+ (upcase period))
+ ((string-match-p "[YD]" (upcase period))
+ ;; If we have a year/day element,
+ ;; we have a full spec.
+ "P")
+ (t
+ ;; Otherwise it's just a sub-day spec.
+ "PT"))
+ (upcase period)))
+ (wrong-type-argument nil))))
+ (unless time
+ (user-error "%s is not a valid time period" period))
+ (decoded-time-period time))))))
+
(defun erc-cmd-IGNORE (&optional user)
"Ignore USER. This should be a regexp matching nick!user@host.
If no USER argument is specified, list the contents of `erc-ignore-list'."
@@ -2914,16 +2992,24 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(y-or-n-p (format "Use regexp-quoted form (%s) instead? "
quoted)))
(setq user quoted))
- (erc-display-line
- (erc-make-notice (format "Now ignoring %s" user))
- 'active)
- (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))
+ (let ((timeout
+ (erc--read-time-period
+ "Add a timeout? (Blank for no, or a time spec like 2h): "))
+ (buffer (current-buffer)))
+ (when timeout
+ (run-at-time timeout nil
+ (lambda ()
+ (erc--unignore-user user buffer))))
+ (erc-display-line
+ (erc-make-notice (format "Now ignoring %s" user))
+ 'active)
+ (erc-with-server-buffer (add-to-list 'erc-ignore-list user))))
(if (null (erc-with-server-buffer erc-ignore-list))
(erc-display-line (erc-make-notice "Ignore list is empty") 'active)
(erc-display-line (erc-make-notice "Ignore list:") 'active)
- (mapc #'(lambda (item)
- (erc-display-line (erc-make-notice item)
- 'active))
+ (mapc (lambda (item)
+ (erc-display-line (erc-make-notice item)
+ 'active))
(erc-with-server-buffer erc-ignore-list))))
t)
@@ -2941,12 +3027,17 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(erc-make-notice (format "%s is not currently ignored!" user))
'active)))
(when ignored-nick
+ (erc--unignore-user user (current-buffer))))
+ t)
+
+(defun erc--unignore-user (user buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
(erc-display-line
(erc-make-notice (format "No longer ignoring %s" user))
'active)
(erc-with-server-buffer
- (setq erc-ignore-list (delete ignored-nick erc-ignore-list)))))
- t)
+ (setq erc-ignore-list (delete user erc-ignore-list))))))
(defun erc-cmd-CLEAR ()
"Clear the window content."
@@ -2968,12 +3059,12 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(car user-data))
ops)))))
erc-channel-users))
- (setq ops (sort ops 'string-lessp))
+ (setq ops (sort ops #'string-lessp))
(if ops
(erc-display-message
nil 'notice (current-buffer) 'ops
?i (length ops) ?s (if (> (length ops) 1) "s" "")
- ?o (mapconcat 'identity ops " "))
+ ?o (mapconcat #'identity ops " "))
(erc-display-message nil 'notice (current-buffer) 'ops-none)))
t)
@@ -3067,7 +3158,7 @@ For a list of user commands (/join /part, ...):
(message "Type C-h m to get additional information about keybindings.")
t))
-(defalias 'erc-cmd-H 'erc-cmd-HELP)
+(defalias 'erc-cmd-H #'erc-cmd-HELP)
(put 'erc-cmd-HELP 'process-not-needed t)
(defun erc-server-join-channel (server channel &optional secret)
@@ -3099,27 +3190,28 @@ were most recently invited. See also `invitation'."
(setq chnl (erc-ensure-channel-name channel)))
(when chnl
;; Prevent double joining of same channel on same server.
- (let ((joined-channels
- (mapcar #'(lambda (chanbuf)
- (with-current-buffer chanbuf (erc-default-target)))
- (erc-channel-list erc-server-process))))
- (if (erc-member-ignore-case chnl joined-channels)
- (switch-to-buffer (car (erc-member-ignore-case chnl
- joined-channels)))
- (let ((server (with-current-buffer (process-buffer erc-server-process)
- (or erc-session-server erc-server-announced-name))))
- (erc-server-join-channel server chnl key))))))
+ (let* ((joined-channels
+ (mapcar (lambda (chanbuf)
+ (with-current-buffer chanbuf (erc-default-target)))
+ (erc-channel-list erc-server-process)))
+ (server (with-current-buffer (process-buffer erc-server-process)
+ (or erc-session-server erc-server-announced-name)))
+ (chnl-name (car (erc-member-ignore-case chnl joined-channels))))
+ (if chnl-name
+ (switch-to-buffer (if (get-buffer chnl-name)
+ chnl-name
+ (concat chnl-name "/" server)))
+ (erc-server-join-channel server chnl key)))))
t)
-(defalias 'erc-cmd-CHANNEL 'erc-cmd-JOIN)
-(defalias 'erc-cmd-J 'erc-cmd-JOIN)
+(defalias 'erc-cmd-CHANNEL #'erc-cmd-JOIN)
+(defalias 'erc-cmd-J #'erc-cmd-JOIN)
-(defvar erc-channel-new-member-names nil
+(defvar-local erc-channel-new-member-names nil
"If non-nil, a names list is currently being received.
If non-nil, this variable is a hash-table that associates
received nicks with t.")
-(make-variable-buffer-local 'erc-channel-new-member-names)
(defun erc-cmd-NAMES (&optional channel)
"Display the users in CHANNEL.
@@ -3137,12 +3229,12 @@ command."
(erc-server-send (concat "NAMES " tgt)))
(erc-display-message nil 'error (current-buffer) 'no-default-channel)))
t)
-(defalias 'erc-cmd-N 'erc-cmd-NAMES)
+(defalias 'erc-cmd-N #'erc-cmd-NAMES)
(defun erc-cmd-KICK (target &optional reason-or-nick &rest reasonwords)
"Kick the user indicated in LINE from the current channel.
LINE has the format: \"#CHANNEL NICK REASON\" or \"NICK REASON\"."
- (let ((reasonstring (mapconcat 'identity reasonwords " ")))
+ (let ((reasonstring (mapconcat #'identity reasonwords " ")))
(if (string= "" reasonstring)
(setq reasonstring (format "Kicked by %s" (erc-current-nick))))
(if (erc-channel-p target)
@@ -3207,7 +3299,7 @@ If SERVER is non-nil, use that, rather than the current server."
(erc-log (format "cmd: %s" send))
(erc-server-send send)
t))
-(defalias 'erc-cmd-WI 'erc-cmd-WHOIS)
+(defalias 'erc-cmd-WI #'erc-cmd-WHOIS)
(defun erc-cmd-WHOAMI ()
"Display whois information about yourself."
@@ -3379,7 +3471,7 @@ The rest is the message to send."
The rest of LINE is the message to send."
(erc-message "PRIVMSG" line))
-(defalias 'erc-cmd-M 'erc-cmd-MSG)
+(defalias 'erc-cmd-M #'erc-cmd-MSG)
(put 'erc-cmd-MSG 'do-not-parse-args t)
(defun erc-cmd-SQUERY (line)
@@ -3434,7 +3526,7 @@ Otherwise leave the channel indicated by LINE."
(t nil)))
(put 'erc-cmd-PART 'do-not-parse-args t)
-(defalias 'erc-cmd-LEAVE 'erc-cmd-PART)
+(defalias 'erc-cmd-LEAVE #'erc-cmd-PART)
(defun erc-cmd-PING (recipient)
"Ping RECIPIENT."
@@ -3478,7 +3570,7 @@ The type of query window/frame/etc will depend on the value of
If USER is omitted, close the current query buffer if one exists
- except this is broken now ;-)"
(interactive
- (list (read-from-minibuffer "Start a query with: " nil)))
+ (list (read-string "Start a query with: ")))
(let ((session-buffer (erc-server-buffer))
(erc-join-buffer erc-query-display))
(if user
@@ -3486,7 +3578,7 @@ If USER is omitted, close the current query buffer if one exists
;; currently broken, evil hack to display help anyway
;(erc-delete-query))))
(signal 'wrong-number-of-arguments ""))))
-(defalias 'erc-cmd-Q 'erc-cmd-QUERY)
+(defalias 'erc-cmd-Q #'erc-cmd-QUERY)
(defun erc-quit/part-reason-default ()
"Default quit/part message."
@@ -3505,7 +3597,7 @@ If S is non-nil, it will be used as the quit reason."
If S is non-nil, it will be used as the quit reason."
(or s
(if (fboundp 'yow)
- (erc-replace-regexp-in-string "\n" "" (yow))
+ (replace-regexp-in-string "\n" "" (yow))
(erc-quit/part-reason-default))))
(make-obsolete 'erc-quit-reason-zippy "it will be removed." "24.4")
@@ -3532,7 +3624,7 @@ If S is non-nil, it will be used as the part reason."
If S is non-nil, it will be used as the quit reason."
(or s
(if (fboundp 'yow)
- (erc-replace-regexp-in-string "\n" "" (yow))
+ (replace-regexp-in-string "\n" "" (yow))
(erc-quit/part-reason-default))))
(make-obsolete 'erc-part-reason-zippy "it will be removed." "24.4")
@@ -3581,9 +3673,9 @@ the message given by REASON."
t)
(t nil)))
-(defalias 'erc-cmd-BYE 'erc-cmd-QUIT)
-(defalias 'erc-cmd-EXIT 'erc-cmd-QUIT)
-(defalias 'erc-cmd-SIGNOFF 'erc-cmd-QUIT)
+(defalias 'erc-cmd-BYE #'erc-cmd-QUIT)
+(defalias 'erc-cmd-EXIT #'erc-cmd-QUIT)
+(defalias 'erc-cmd-SIGNOFF #'erc-cmd-QUIT)
(put 'erc-cmd-QUIT 'do-not-parse-args t)
(put 'erc-cmd-QUIT 'process-not-needed t)
@@ -3602,7 +3694,7 @@ the message given by REASON."
(kill-buffer buffer)))))
t)
-(defalias 'erc-cmd-GQ 'erc-cmd-GQUIT)
+(defalias 'erc-cmd-GQ #'erc-cmd-GQUIT)
(put 'erc-cmd-GQUIT 'do-not-parse-args t)
(put 'erc-cmd-GQUIT 'process-not-needed t)
@@ -3659,8 +3751,9 @@ the message given by REASON."
x-toolkit-scroll-bars)))
"")
(if (featurep 'multi-tty) ", multi-tty" ""))
- (if erc-emacs-build-time
- (concat " of " erc-emacs-build-time)
+ (if emacs-build-time
+ (concat " of " (format-time-string
+ "%Y-%m-%d" emacs-build-time))
"")))
t)
@@ -3677,7 +3770,7 @@ the message given by REASON."
" -"
(make-string (length people) ?o)
" "
- (mapconcat 'identity people " ")))
+ (mapconcat #'identity people " ")))
t))
(defun erc-cmd-OP (&rest people)
@@ -3687,7 +3780,7 @@ the message given by REASON."
" +"
(make-string (length people) ?o)
" "
- (mapconcat 'identity people " ")))
+ (mapconcat #'identity people " ")))
t))
(defun erc-cmd-TIME (&optional line)
@@ -3699,7 +3792,7 @@ the message given by REASON."
(erc-server-send (concat "TIME " args)))
t)
(t (erc-server-send "TIME"))))
-(defalias 'erc-cmd-DATE 'erc-cmd-TIME)
+(defalias 'erc-cmd-DATE #'erc-cmd-TIME)
(defun erc-cmd-TOPIC (topic)
"Set or request the topic for a channel.
@@ -3740,7 +3833,7 @@ be displayed."
(erc-display-message nil 'error (current-buffer) 'no-target)))
t)
(t nil)))
-(defalias 'erc-cmd-T 'erc-cmd-TOPIC)
+(defalias 'erc-cmd-T #'erc-cmd-TOPIC)
(put 'erc-cmd-TOPIC 'do-not-parse-args t)
(defun erc-cmd-APPENDTOPIC (topic)
@@ -3752,7 +3845,7 @@ be displayed."
;; strip trailing ^O
(when (string-match "\\(.*\\)\C-o" oldtopic)
(erc-cmd-TOPIC (concat (match-string 1 oldtopic) topic)))))
-(defalias 'erc-cmd-AT 'erc-cmd-APPENDTOPIC)
+(defalias 'erc-cmd-AT #'erc-cmd-APPENDTOPIC)
(put 'erc-cmd-APPENDTOPIC 'do-not-parse-args t)
(defun erc-cmd-CLEARTOPIC (&optional channel)
@@ -3766,7 +3859,7 @@ If CHANNEL is not specified, clear the topic for the default channel."
;;; Banlists
-(defvar erc-channel-banlist nil
+(defvar-local erc-channel-banlist nil
"A list of bans seen for the current channel.
Each ban is an alist of the form:
@@ -3774,9 +3867,10 @@ Each ban is an alist of the form:
The property `received-from-server' indicates whether
or not the ban list has been requested from the server.")
-(make-variable-buffer-local 'erc-channel-banlist)
(put 'erc-channel-banlist 'received-from-server nil)
+(defvar erc-fill-column)
+
(defun erc-cmd-BANLIST ()
"Pretty-print the contents of `erc-channel-banlist'.
@@ -3847,7 +3941,7 @@ The ban list is fetched from the server if necessary."
(put 'erc-channel-banlist 'received-from-server nil)))))
t)
-(defalias 'erc-cmd-BL 'erc-cmd-BANLIST)
+(defalias 'erc-cmd-BL #'erc-cmd-BANLIST)
(defun erc-cmd-MASSUNBAN ()
"Mass Unban.
@@ -3885,11 +3979,11 @@ Unban all currently banned users in the current channel."
(erc-server-send
(format "MODE %s -%s %s" (erc-default-target)
(make-string (length x) ?b)
- (mapconcat 'identity x " "))))
+ (mapconcat #'identity x " "))))
(erc-group-list bans 3))))
t))))
-(defalias 'erc-cmd-MUB 'erc-cmd-MASSUNBAN)
+(defalias 'erc-cmd-MUB #'erc-cmd-MASSUNBAN)
;;;; End of IRC commands
@@ -3948,13 +4042,12 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil,
;; Do not extend the text properties when typing at the end
;; of the prompt, but stuff typed in front of the prompt
;; shall remain part of the prompt.
- (setq prompt (erc-propertize prompt
- 'start-open t ; XEmacs
- 'rear-nonsticky t ; Emacs
- 'erc-prompt t
- 'field t
- 'front-sticky t
- 'read-only t))
+ (setq prompt (propertize prompt
+ 'rear-nonsticky t
+ 'erc-prompt t
+ 'field t
+ 'front-sticky t
+ 'read-only t))
(erc-put-text-property 0 (1- (length prompt))
'font-lock-face (or face 'erc-prompt-face)
prompt)
@@ -3991,8 +4084,7 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil,
"Interactively input a user action and send it to IRC."
(interactive "")
(erc-set-active-buffer (current-buffer))
- (let ((action (read-from-minibuffer
- "Action: " nil nil nil 'erc-action-history-list)))
+ (let ((action (read-string "Action: " nil 'erc-action-history-list)))
(if (not (string-match "^\\s-*$" action))
(erc-send-action (erc-default-target) action))))
@@ -4006,26 +4098,28 @@ If `point' is at the beginning of a channel name, use that as default."
(table (when (erc-server-buffer-live-p)
(set-buffer (process-buffer erc-server-process))
erc-channel-list)))
- (completing-read "Join channel: " table nil nil nil nil chnl))
+ (completing-read (format-prompt "Join channel" chnl)
+ table nil nil nil nil chnl))
(when (or current-prefix-arg erc-prompt-for-channel-key)
- (read-from-minibuffer "Channel key (RET for none): " nil))))
+ (read-string "Channel key (RET for none): "))))
(erc-cmd-JOIN channel (when (>= (length key) 1) key)))
(defun erc-part-from-channel (reason)
"Part from the current channel and prompt for a REASON."
(interactive
+ ;; FIXME: Has this ever worked? We're in the interactive-spec, so the
+ ;; argument `reason' can't be in scope yet!
+ ;;(if (and (boundp 'reason) (stringp reason) (not (string= reason "")))
+ ;; reason
(list
- (if (and (boundp 'reason) (stringp reason) (not (string= reason "")))
- reason
- (read-from-minibuffer (concat "Reason for leaving " (erc-default-target)
- ": ")))))
+ (read-string (concat "Reason for leaving " (erc-default-target) ": "))))
(erc-cmd-PART (concat (erc-default-target)" " reason)))
(defun erc-set-topic (topic)
"Prompt for a TOPIC for the current channel."
(interactive
(list
- (read-from-minibuffer
+ (read-string
(concat "Set topic of " (erc-default-target) ": ")
(when erc-channel-topic
(let ((ss (split-string erc-channel-topic "\C-o")))
@@ -4037,7 +4131,7 @@ If `point' is at the beginning of a channel name, use that as default."
(defun erc-set-channel-limit (&optional limit)
"Set a LIMIT for the current channel. Remove limit if nil.
Prompt for one if called interactively."
- (interactive (list (read-from-minibuffer
+ (interactive (list (read-string
(format "Limit for %s (RET to remove limit): "
(erc-default-target)))))
(let ((tgt (erc-default-target)))
@@ -4048,7 +4142,7 @@ Prompt for one if called interactively."
(defun erc-set-channel-key (&optional key)
"Set a KEY for the current channel. Remove key if nil.
Prompt for one if called interactively."
- (interactive (list (read-from-minibuffer
+ (interactive (list (read-string
(format "Key for %s (RET to remove key): "
(erc-default-target)))))
(let ((tgt (erc-default-target)))
@@ -4059,7 +4153,7 @@ Prompt for one if called interactively."
(defun erc-quit-server (reason)
"Disconnect from current server after prompting for REASON.
`erc-quit-reason' works with this just like with `erc-cmd-QUIT'."
- (interactive (list (read-from-minibuffer
+ (interactive (list (read-string
(format "Reason for quitting %s: "
(or erc-server-announced-name
erc-session-server)))))
@@ -4090,7 +4184,7 @@ This places `point' just after the prompt, or at the beginning of the line."
(defun erc-complete-word-at-point ()
(run-hook-with-args-until-success 'erc-complete-functions))
-(define-obsolete-function-alias 'erc-complete-word 'completion-at-point "24.1")
+(define-obsolete-function-alias 'erc-complete-word #'completion-at-point "24.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -4116,11 +4210,11 @@ Displays PROC and PARSED appropriately using `erc-display-message'."
(erc-display-message
parsed 'notice proc
(mapconcat
- 'identity
+ #'identity
(let (res)
- (mapc #'(lambda (x)
- (if (stringp x)
- (setq res (append res (list x)))))
+ (mapc (lambda (x)
+ (if (stringp x)
+ (setq res (append res (list x)))))
parsed)
res)
" ")))
@@ -4337,15 +4431,15 @@ See also `erc-format-nick-function'."
(defun erc-get-user-mode-prefix (user)
(when user
(cond ((erc-channel-user-owner-p user)
- (erc-propertize "~" 'help-echo "owner"))
+ (propertize "~" 'help-echo "owner"))
((erc-channel-user-admin-p user)
- (erc-propertize "&" 'help-echo "admin"))
+ (propertize "&" 'help-echo "admin"))
((erc-channel-user-op-p user)
- (erc-propertize "@" 'help-echo "operator"))
+ (propertize "@" 'help-echo "operator"))
((erc-channel-user-halfop-p user)
- (erc-propertize "%" 'help-echo "half-op"))
+ (propertize "%" 'help-echo "half-op"))
((erc-channel-user-voice-p user)
- (erc-propertize "+" 'help-echo "voice"))
+ (propertize "+" 'help-echo "voice"))
(t ""))))
(defun erc-format-@nick (&optional user _channel-data)
@@ -4356,7 +4450,7 @@ prefix. Use CHANNEL-DATA to determine op and voice status. See
also `erc-format-nick-function'."
(when user
(let ((nick (erc-server-user-nickname user)))
- (concat (erc-propertize
+ (concat (propertize
(erc-get-user-mode-prefix nick)
'font-lock-face 'erc-nick-prefix-face)
nick))))
@@ -4369,12 +4463,12 @@ also `erc-format-nick-function'."
(nick (erc-current-nick))
(mode (erc-get-user-mode-prefix nick)))
(concat
- (erc-propertize open 'font-lock-face 'erc-default-face)
- (erc-propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
- (erc-propertize nick 'font-lock-face 'erc-my-nick-face)
- (erc-propertize close 'font-lock-face 'erc-default-face)))
+ (propertize open 'font-lock-face 'erc-default-face)
+ (propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
+ (propertize nick 'font-lock-face 'erc-my-nick-face)
+ (propertize close 'font-lock-face 'erc-default-face)))
(let ((prefix "> "))
- (erc-propertize prefix 'font-lock-face 'erc-default-face))))
+ (propertize prefix 'font-lock-face 'erc-default-face))))
(defun erc-echo-notice-in-default-buffer (s parsed buffer _sender)
"Echos a private notice in the default buffer, namely the
@@ -4507,11 +4601,11 @@ See also: `erc-echo-notice-in-user-buffers',
((string-match "^-" mode)
;; Remove the unbanned masks from the ban list
(setq erc-channel-banlist
- (erc-delete-if
- #'(lambda (y)
- (member (upcase (cdr y))
- (mapcar #'upcase
- (cdr (split-string mode)))))
+ (cl-delete-if
+ (lambda (y)
+ (member (upcase (cdr y))
+ (mapcar #'upcase
+ (cdr (split-string mode)))))
erc-channel-banlist)))
((string-match "^\\+" mode)
;; Add the banned mask(s) to the ban list
@@ -4528,7 +4622,7 @@ See also: `erc-echo-notice-in-user-buffers',
"Group LIST into sublists of length N."
(cond ((null list) nil)
((null (nthcdr n list)) (list list))
- (t (cons (erc-subseq list 0 n) (erc-group-list (nthcdr n list) n)))))
+ (t (cons (cl-subseq list 0 n) (erc-group-list (nthcdr n list) n)))))
;;; MOTD numreplies
@@ -5138,7 +5232,7 @@ TOPIC string to the current topic."
"Sort LIST-OF-STRINGS in lexicographic order.
Side-effect free."
- (sort (copy-sequence list-of-strings) 'string<))
+ (sort (copy-sequence list-of-strings) #'string<))
(defun erc-parse-modes (mode-string)
"Parse MODE-STRING into a list.
@@ -5405,6 +5499,10 @@ submitted line to be intentional."
(time-less-p erc-accidental-paste-threshold-seconds
(time-subtract now erc-last-input-time)))
(save-restriction
+ ;; If there's an abbrev at the end of the line, expand it.
+ (when (and abbrev-mode
+ (eolp))
+ (expand-abbrev))
(widen)
(if (< (point) (erc-beg-of-input-line))
(erc-error "Point is not in the input area")
@@ -5482,12 +5580,10 @@ This returns non-nil only if we actually send anything."
;; Instead `erc-pre-send-functions' is used as a filter to do
;; allow both changing and suppressing the string.
(run-hook-with-args 'erc-send-pre-hook input)
- (setq state (make-erc-input :string str
+ (setq state (make-erc-input :string str ;May be != from `input' now!
:insertp erc-insert-this
:sendp erc-send-this))
- (dolist (func erc-pre-send-functions)
- ;; The functions can return nil to inhibit sending.
- (funcall func state))
+ (run-hook-with-args 'erc-pre-send-functions state)
(when (and (erc-input-sendp state)
erc-send-this)
(let ((string (erc-input-string state)))
@@ -5508,26 +5604,26 @@ This returns non-nil only if we actually send anything."
(erc-process-input-line (concat string "\n") t nil))
t))))))
-(defun erc-display-command (line)
- (when erc-insert-this
- (let ((insert-position (point)))
- (unless erc-hide-prompt
- (erc-display-prompt nil nil (erc-command-indicator)
- (and (erc-command-indicator)
- 'erc-command-indicator-face)))
- (let ((beg (point)))
- (insert line)
- (erc-put-text-property beg (point)
- 'font-lock-face 'erc-command-indicator-face)
- (insert "\n"))
- (when (processp erc-server-process)
- (set-marker (process-mark erc-server-process) (point)))
- (set-marker erc-insert-marker (point))
- (save-excursion
- (save-restriction
- (narrow-to-region insert-position (point))
- (run-hooks 'erc-send-modify-hook)
- (run-hooks 'erc-send-post-hook))))))
+;; (defun erc-display-command (line)
+;; (when erc-insert-this
+;; (let ((insert-position (point)))
+;; (unless erc-hide-prompt
+;; (erc-display-prompt nil nil (erc-command-indicator)
+;; (and (erc-command-indicator)
+;; 'erc-command-indicator-face)))
+;; (let ((beg (point)))
+;; (insert line)
+;; (erc-put-text-property beg (point)
+;; 'font-lock-face 'erc-command-indicator-face)
+;; (insert "\n"))
+;; (when (processp erc-server-process)
+;; (set-marker (process-mark erc-server-process) (point)))
+;; (set-marker erc-insert-marker (point))
+;; (save-excursion
+;; (save-restriction
+;; (narrow-to-region insert-position (point))
+;; (run-hooks 'erc-send-modify-hook)
+;; (run-hooks 'erc-send-post-hook))))))
(defun erc-display-msg (line)
"Display LINE as a message of the user to the current target at the
@@ -6073,11 +6169,11 @@ non-nil value is found.
;; time routines
-(define-obsolete-function-alias 'erc-string-to-emacs-time 'string-to-number
+(define-obsolete-function-alias 'erc-string-to-emacs-time #'string-to-number
"27.1")
-(defalias 'erc-emacs-time-to-erc-time 'float-time)
-(defalias 'erc-current-time 'float-time)
+(defalias 'erc-emacs-time-to-erc-time #'float-time)
+(defalias 'erc-current-time #'float-time)
(defun erc-time-diff (t1 t2)
"Return the absolute value of the difference in seconds between T1 and T2."
@@ -6117,8 +6213,7 @@ non-nil value is found.
output (apply #'format format-args))
;; Change all "1 units" to "1 unit".
(while (string-match "\\([^0-9]\\|^\\)1 \\S-+\\(s\\)" output)
- (setq output (erc-replace-match-subexpression-in-string
- "" output (match-string 2 output) 2 (match-beginning 2))))
+ (setq output (replace-match "" nil nil output 2)))
output))
@@ -6245,7 +6340,6 @@ The following characters are replaced:
(defcustom erc-header-line-format "%n on %t (%m,%l) %o"
"A string to be formatted and shown in the header-line in `erc-mode'.
-Only used starting in Emacs 21.
Set this to nil if you do not want the header line to be
displayed.
@@ -6394,17 +6488,16 @@ if `erc-away' is non-nil."
(defun erc-update-mode-line-buffer (buffer)
"Update the mode line in a single ERC buffer BUFFER."
(with-current-buffer buffer
- (let ((spec (format-spec-make
- ?a (erc-format-away-status)
- ?l (erc-format-lag-time)
- ?m (erc-format-channel-modes)
- ?n (or (erc-current-nick) "")
- ?N (erc-format-network)
- ?o (or (erc-controls-strip erc-channel-topic) "")
- ?p (erc-port-to-string erc-session-port)
- ?s (erc-format-target-and/or-server)
- ?S (erc-format-target-and/or-network)
- ?t (erc-format-target)))
+ (let ((spec `((?a . ,(erc-format-away-status))
+ (?l . ,(erc-format-lag-time))
+ (?m . ,(erc-format-channel-modes))
+ (?n . ,(or (erc-current-nick) ""))
+ (?N . ,(erc-format-network))
+ (?o . ,(or (erc-controls-strip erc-channel-topic) ""))
+ (?p . ,(erc-port-to-string erc-session-port))
+ (?s . ,(erc-format-target-and/or-server))
+ (?S . ,(erc-format-target-and/or-network))
+ (?t . ,(erc-format-target))))
(process-status (cond ((and (erc-server-process-alive)
(not erc-server-connected))
":connecting")
@@ -6421,33 +6514,31 @@ if `erc-away' is non-nil."
(setq mode-line-buffer-identification
(list (format-spec erc-mode-line-format spec)))
(setq mode-line-process (list process-status))
- (when (boundp 'header-line-format)
- (let ((header (if erc-header-line-format
- (format-spec erc-header-line-format spec)
- nil)))
- (cond (erc-header-line-uses-tabbar-p
- (set (make-local-variable 'tabbar--local-hlf)
- header-line-format)
- (kill-local-variable 'header-line-format))
- ((null header)
- (setq header-line-format nil))
- (erc-header-line-uses-help-echo-p
- (let ((help-echo (with-temp-buffer
- (insert header)
- (fill-region (point-min) (point-max))
- (buffer-string))))
- (setq header-line-format
- (erc-replace-regexp-in-string
- "%"
- "%%"
- (if face
- (erc-propertize header 'help-echo help-echo
- 'face face)
- (erc-propertize header 'help-echo help-echo))))))
- (t (setq header-line-format
- (if face
- (erc-propertize header 'face face)
- header)))))))
+ (let ((header (if erc-header-line-format
+ (format-spec erc-header-line-format spec)
+ nil)))
+ (cond (erc-header-line-uses-tabbar-p
+ (setq-local tabbar--local-hlf header-line-format)
+ (kill-local-variable 'header-line-format))
+ ((null header)
+ (setq header-line-format nil))
+ (erc-header-line-uses-help-echo-p
+ (let ((help-echo (with-temp-buffer
+ (insert header)
+ (fill-region (point-min) (point-max))
+ (buffer-string))))
+ (setq header-line-format
+ (replace-regexp-in-string
+ "%"
+ "%%"
+ (if face
+ (propertize header 'help-echo help-echo
+ 'face face)
+ (propertize header 'help-echo help-echo))))))
+ (t (setq header-line-format
+ (if face
+ (propertize header 'face face)
+ header))))))
(force-mode-line-update)))
(defun erc-update-mode-line (&optional buffer)
@@ -6495,7 +6586,7 @@ If optional argument HERE is non-nil, insert version number at point."
If optional argument HERE is non-nil, insert version number at point."
(interactive "P")
(let ((string
- (mapconcat 'identity
+ (mapconcat #'identity
(let (modes (case-fold-search nil))
(dolist (var (apropos-internal "^erc-.*mode$"))
(when (and (boundp var)
@@ -6713,12 +6804,11 @@ functions."
nick user host channel
(if (not (string= reason ""))
(format ": %s"
- (erc-replace-regexp-in-string "%" "%%" reason))
+ (replace-regexp-in-string "%" "%%" reason))
"")))))
-(defvar erc-current-message-catalog 'english)
-(make-variable-buffer-local 'erc-current-message-catalog)
+(defvar-local erc-current-message-catalog 'english)
(defun erc-retrieve-catalog-entry (entry &optional catalog)
"Retrieve ENTRY from CATALOG.
@@ -6749,7 +6839,8 @@ See also `format-spec'."
;;; Various hook functions
-(add-hook 'kill-buffer-hook 'erc-kill-buffer-function)
+;; FIXME: Don't set the hook globally!
+(add-hook 'kill-buffer-hook #'erc-kill-buffer-function)
(defcustom erc-kill-server-hook '(erc-kill-server)
"Invoked whenever a server buffer is killed via `kill-buffer'."
@@ -6864,7 +6955,3 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL."
(require 'erc-goodies)
;;; erc.el ends here
-;;
-;; Local Variables:
-;; outline-regexp: ";;+"
-;; End:
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index 7e58982c583..64fc7e7f03b 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -90,11 +90,10 @@ or `eshell-printn' for display."
(car args))
(t
(mapcar
- (function
- (lambda (arg)
- (if (stringp arg)
- (set-text-properties 0 (length arg) nil arg))
- arg))
+ (lambda (arg)
+ (if (stringp arg)
+ (set-text-properties 0 (length arg) nil arg))
+ arg)
args)))))
(if output-newline
(cond
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index faf749d8362..cbfe0b81545 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -91,31 +91,30 @@ variable names, arguments, etc."
(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)
+ :type 'hook)
(defcustom eshell-show-lisp-completions nil
"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)
+ :type 'boolean)
(defcustom eshell-show-lisp-alternatives t
"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)
+ :type 'boolean)
(defcustom eshell-no-completion-during-jobs t
"If non-nil, don't allow completion while a process is running."
- :type 'boolean
- :group 'eshell-cmpl)
+ :type 'boolean)
(defcustom eshell-command-completions-alist
'(("acroread" . "\\.pdf\\'")
("xpdf" . "\\.pdf\\'")
+ ("gunzip" . "\\.t?gz\\'")
+ ("bunzip2" . "\\.t?bz2\\'")
+ ("unxz" . "\\.t?xz\\'")
("ar" . "\\.[ao]\\'")
("gcc" . "\\.[Cc]\\([Cc]\\|[Pp][Pp]\\)?\\'")
("g++" . "\\.[Cc]\\([Cc]\\|[Pp][Pp]\\)?\\'")
@@ -133,8 +132,7 @@ is non-nil."
"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))
- :group 'eshell-cmpl)
+ :type '(repeat (cons string regexp)))
(defun eshell-cmpl--custom-variable-docstring (pcomplete-var)
"Generate the docstring of a variable derived from a pcomplete-* variable."
@@ -145,23 +143,19 @@ to writing a completion function."
(defcustom eshell-cmpl-file-ignore "~\\'"
(eshell-cmpl--custom-variable-docstring 'pcomplete-file-ignore)
- :type (get 'pcomplete-file-ignore 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-file-ignore 'custom-type))
(defcustom eshell-cmpl-dir-ignore "\\`\\(\\.\\.?\\|CVS\\)/\\'"
(eshell-cmpl--custom-variable-docstring 'pcomplete-dir-ignore)
- :type (get 'pcomplete-dir-ignore 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-dir-ignore 'custom-type))
(defcustom eshell-cmpl-ignore-case (eshell-under-windows-p)
- (eshell-cmpl--custom-variable-docstring 'pcomplete-ignore-case)
- :type (get 'pcomplete-ignore-case 'custom-type)
- :group 'eshell-cmpl)
+ (eshell-cmpl--custom-variable-docstring 'completion-ignore-case)
+ :type (get 'completion-ignore-case 'custom-type))
(defcustom eshell-cmpl-autolist nil
(eshell-cmpl--custom-variable-docstring 'pcomplete-autolist)
- :type (get 'pcomplete-autolist 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-autolist 'custom-type))
(defcustom eshell-cmpl-suffix-list (list ?/ ?:)
(eshell-cmpl--custom-variable-docstring 'pcomplete-suffix-list)
@@ -173,68 +167,55 @@ to writing a completion function."
(defcustom eshell-cmpl-recexact nil
(eshell-cmpl--custom-variable-docstring 'pcomplete-recexact)
- :type (get 'pcomplete-recexact 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-recexact 'custom-type))
-(defcustom eshell-cmpl-man-function 'man
+(defcustom eshell-cmpl-man-function #'man
(eshell-cmpl--custom-variable-docstring 'pcomplete-man-function)
- :type (get 'pcomplete-man-function 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-man-function 'custom-type))
-(defcustom eshell-cmpl-compare-entry-function 'file-newer-than-file-p
+(defcustom eshell-cmpl-compare-entry-function #'file-newer-than-file-p
(eshell-cmpl--custom-variable-docstring 'pcomplete-compare-entry-function)
- :type (get 'pcomplete-compare-entry-function 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-compare-entry-function 'custom-type))
(defcustom eshell-cmpl-expand-before-complete nil
(eshell-cmpl--custom-variable-docstring 'pcomplete-expand-before-complete)
- :type (get 'pcomplete-expand-before-complete 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-expand-before-complete 'custom-type))
(defcustom eshell-cmpl-cycle-completions t
(eshell-cmpl--custom-variable-docstring 'pcomplete-cycle-completions)
- :type (get 'pcomplete-cycle-completions 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-cycle-completions 'custom-type))
(defcustom eshell-cmpl-cycle-cutoff-length 5
(eshell-cmpl--custom-variable-docstring 'pcomplete-cycle-cutoff-length)
- :type (get 'pcomplete-cycle-cutoff-length 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-cycle-cutoff-length 'custom-type))
(defcustom eshell-cmpl-restore-window-delay 1
(eshell-cmpl--custom-variable-docstring 'pcomplete-restore-window-delay)
- :type (get 'pcomplete-restore-window-delay 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-restore-window-delay 'custom-type))
(defcustom eshell-command-completion-function
- (function
- (lambda ()
- (pcomplete-here (eshell-complete-commands-list))))
+ (lambda ()
+ (pcomplete-here (eshell--complete-commands-list)))
(eshell-cmpl--custom-variable-docstring 'pcomplete-command-completion-function)
- :type (get 'pcomplete-command-completion-function 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-command-completion-function 'custom-type))
(defcustom eshell-cmpl-command-name-function
- 'eshell-completion-command-name
+ #'eshell-completion-command-name
(eshell-cmpl--custom-variable-docstring 'pcomplete-command-name-function)
- :type (get 'pcomplete-command-name-function 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-command-name-function 'custom-type))
(defcustom eshell-default-completion-function
- (function
- (lambda ()
- (while (pcomplete-here
- (pcomplete-dirs-or-entries
- (cdr (assoc (funcall eshell-cmpl-command-name-function)
- eshell-command-completions-alist)))))))
+ (lambda ()
+ (while (pcomplete-here
+ (pcomplete-dirs-or-entries
+ (cdr (assoc (funcall eshell-cmpl-command-name-function)
+ eshell-command-completions-alist))))))
(eshell-cmpl--custom-variable-docstring 'pcomplete-default-completion-function)
- :type (get 'pcomplete-default-completion-function 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-default-completion-function 'custom-type))
(defcustom eshell-cmpl-use-paring t
(eshell-cmpl--custom-variable-docstring 'pcomplete-use-paring)
- :type (get 'pcomplete-use-paring 'custom-type)
- :group 'eshell-cmpl)
+ :type (get 'pcomplete-use-paring 'custom-type))
;;; Functions:
@@ -244,69 +225,75 @@ to writing a completion function."
(let ((completion-at-point-functions '(elisp-completion-at-point)))
(completion-at-point)))
+(defvar eshell-cmpl-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [(control ?i)] #'completion-at-point)
+ ;; jww (1999-10-19): Will this work on anything but X?
+ (define-key map [backtab] #'pcomplete-reverse)
+ (define-key map [(meta ??)] #'completion-help-at-point)
+ (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol)
+ ;; C-c prefix:
+ (define-key map (kbd "C-c M-h") #'eshell-completion-help)
+ (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete)
+ (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete)
+ (define-key map (kbd "C-c SPC") #'pcomplete-expand)
+ map))
+
+(define-minor-mode eshell-cmpl-mode
+ "Minor mode that provides a keymap when `eshell-cmpl' active.
+
+\\{eshell-cmpl-mode-map}"
+ :keymap eshell-cmpl-mode-map)
+
(defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the completions module."
- (set (make-local-variable 'pcomplete-command-completion-function)
- eshell-command-completion-function)
- (set (make-local-variable 'pcomplete-command-name-function)
- eshell-cmpl-command-name-function)
- (set (make-local-variable 'pcomplete-default-completion-function)
- eshell-default-completion-function)
- (set (make-local-variable 'pcomplete-parse-arguments-function)
- 'eshell-complete-parse-arguments)
- (set (make-local-variable 'pcomplete-file-ignore)
- eshell-cmpl-file-ignore)
- (set (make-local-variable 'pcomplete-dir-ignore)
- eshell-cmpl-dir-ignore)
- (set (make-local-variable 'pcomplete-ignore-case)
- eshell-cmpl-ignore-case)
- (set (make-local-variable 'pcomplete-autolist)
- eshell-cmpl-autolist)
+ (setq-local pcomplete-command-completion-function
+ eshell-command-completion-function)
+ (setq-local pcomplete-command-name-function
+ eshell-cmpl-command-name-function)
+ (setq-local pcomplete-default-completion-function
+ eshell-default-completion-function)
+ (setq-local pcomplete-parse-arguments-function
+ #'eshell-complete-parse-arguments)
+ (setq-local pcomplete-file-ignore
+ eshell-cmpl-file-ignore)
+ (setq-local pcomplete-dir-ignore
+ eshell-cmpl-dir-ignore)
+ (setq-local completion-ignore-case
+ eshell-cmpl-ignore-case)
+ (setq-local pcomplete-autolist
+ eshell-cmpl-autolist)
(if (boundp 'pcomplete-suffix-list)
- (set (make-local-variable 'pcomplete-suffix-list)
- eshell-cmpl-suffix-list))
- (set (make-local-variable 'pcomplete-recexact)
- eshell-cmpl-recexact)
- (set (make-local-variable 'pcomplete-man-function)
- eshell-cmpl-man-function)
- (set (make-local-variable 'pcomplete-compare-entry-function)
- eshell-cmpl-compare-entry-function)
- (set (make-local-variable 'pcomplete-expand-before-complete)
- eshell-cmpl-expand-before-complete)
- (set (make-local-variable 'pcomplete-cycle-completions)
- eshell-cmpl-cycle-completions)
- (set (make-local-variable 'pcomplete-cycle-cutoff-length)
- eshell-cmpl-cycle-cutoff-length)
- (set (make-local-variable 'pcomplete-restore-window-delay)
- eshell-cmpl-restore-window-delay)
- (set (make-local-variable 'pcomplete-use-paring)
- eshell-cmpl-use-paring)
+ (setq-local pcomplete-suffix-list
+ eshell-cmpl-suffix-list))
+ (setq-local pcomplete-recexact
+ eshell-cmpl-recexact)
+ (setq-local pcomplete-man-function
+ eshell-cmpl-man-function)
+ (setq-local pcomplete-compare-entry-function
+ eshell-cmpl-compare-entry-function)
+ (setq-local pcomplete-expand-before-complete
+ eshell-cmpl-expand-before-complete)
+ (setq-local pcomplete-cycle-completions
+ eshell-cmpl-cycle-completions)
+ (setq-local pcomplete-cycle-cutoff-length
+ eshell-cmpl-cycle-cutoff-length)
+ (setq-local pcomplete-restore-window-delay
+ eshell-cmpl-restore-window-delay)
+ (setq-local pcomplete-use-paring
+ eshell-cmpl-use-paring)
;; `comint-file-name-quote-list' should only be set after all the
;; load-hooks for any other extension modules have been run, which
;; is true at the time `eshell-mode-hook' is run
(add-hook 'eshell-mode-hook
- (function
- (lambda ()
- (set (make-local-variable 'comint-file-name-quote-list)
- eshell-special-chars-outside-quoting)))
+ (lambda ()
+ (setq-local comint-file-name-quote-list
+ eshell-special-chars-outside-quoting))
nil t)
(add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t)
- ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant
- (define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol)
- (define-key eshell-command-map [(meta ?h)] 'eshell-completion-help)
- (define-key eshell-command-map [tab] 'pcomplete-expand-and-complete)
- (define-key eshell-command-map [(control ?i)]
- 'pcomplete-expand-and-complete)
- (define-key eshell-command-map [space] 'pcomplete-expand)
- (define-key eshell-command-map [? ] 'pcomplete-expand)
- ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant!
- (define-key eshell-mode-map [(control ?i)] 'completion-at-point)
(add-hook 'completion-at-point-functions
#'pcomplete-completions-at-point nil t)
- ;; jww (1999-10-19): Will this work on anything but X?
- (define-key eshell-mode-map
- (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse)
- (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point))
+ (eshell-cmpl-mode))
(defun eshell-completion-command-name ()
"Return the command name, possibly sans globbing."
@@ -381,81 +368,80 @@ to writing a completion function."
(nconc args (list ""))
(nconc posns (list (point))))
(cons (mapcar
- (function
- (lambda (arg)
- (let ((val
- (if (listp arg)
- (let ((result
- (eshell-do-eval
- (list 'eshell-commands arg) t)))
- (cl-assert (eq (car result) 'quote))
- (cadr result))
- arg)))
- (if (numberp val)
- (setq val (number-to-string val)))
- (or val ""))))
+ (lambda (arg)
+ (let ((val
+ (if (listp arg)
+ (let ((result
+ (eshell-do-eval
+ (list 'eshell-commands arg) t)))
+ (cl-assert (eq (car result) 'quote))
+ (cadr result))
+ arg)))
+ (if (numberp val)
+ (setq val (number-to-string val)))
+ (or val "")))
args)
posns)))
-(defun eshell-complete-commands-list ()
+(defun eshell--complete-commands-list ()
"Generate list of applicable, visible commands."
- (let ((filename (pcomplete-arg)) glob-name)
- (if (file-name-directory filename)
- (if eshell-force-execution
- (pcomplete-dirs-or-entries nil #'file-readable-p)
- (pcomplete-executables))
- (if (and (> (length filename) 0)
- (eq (aref filename 0) eshell-explicit-command-char))
- (setq filename (substring filename 1)
- pcomplete-stub filename
- glob-name t))
- (let* ((paths (eshell-get-path))
- (cwd (file-name-as-directory
- (expand-file-name default-directory)))
- (path "") (comps-in-path ())
- (file "") (filepath "") (completions ()))
- ;; Go thru each path in the search path, finding completions.
- (while paths
- (setq path (file-name-as-directory
- (expand-file-name (or (car paths) ".")))
- comps-in-path
- (and (file-accessible-directory-p path)
- (file-name-all-completions filename path)))
- ;; Go thru each completion found, to see whether it should
- ;; be used.
- (while comps-in-path
- (setq file (car comps-in-path)
- filepath (concat path file))
- (if (and (not (member file completions)) ;
- (or (string-equal path cwd)
- (not (file-directory-p filepath)))
- (if eshell-force-execution
- (file-readable-p filepath)
- (file-executable-p filepath)))
- (setq completions (cons file completions)))
- (setq comps-in-path (cdr comps-in-path)))
- (setq paths (cdr paths)))
- ;; Add aliases which are currently visible, and Lisp functions.
- (pcomplete-uniquify-list
- (if glob-name
- completions
- (setq completions
- (append (if (fboundp 'eshell-alias-completions)
- (eshell-alias-completions filename))
- (eshell-winnow-list
- (mapcar
- (function
- (lambda (name)
- (substring name 7)))
- (all-completions (concat "eshell/" filename)
- obarray #'functionp))
- nil '(eshell-find-alias-function))
- completions))
- (append (and (or eshell-show-lisp-completions
- (and eshell-show-lisp-alternatives
- (null completions)))
- (all-completions filename obarray #'functionp))
- completions)))))))
+ ;; Building the commands list can take quite a while, especially over Tramp
+ ;; (bug#41423), so do it lazily.
+ (let ((glob-name
+ ;; When a command is specified using `eshell-explicit-command-char',
+ ;; that char is not part of the command and hence not part of what
+ ;; we complete. Adjust `pcomplete-stub' accordingly!
+ (if (and (> (length pcomplete-stub) 0)
+ (eq (aref pcomplete-stub 0) eshell-explicit-command-char))
+ (setq pcomplete-stub (substring pcomplete-stub 1)))))
+ (completion-table-dynamic
+ (lambda (filename)
+ (if (file-name-directory filename)
+ (if eshell-force-execution
+ (pcomplete-dirs-or-entries nil #'file-readable-p)
+ (pcomplete-executables))
+ (let* ((paths (eshell-get-path))
+ (cwd (file-name-as-directory
+ (expand-file-name default-directory)))
+ (filepath "") (completions ()))
+ ;; Go thru each path in the search path, finding completions.
+ (dolist (path paths)
+ (setq path (file-name-as-directory
+ (expand-file-name (or path "."))))
+ ;; Go thru each completion found, to see whether it should
+ ;; be used.
+ (dolist (file (and (file-accessible-directory-p path)
+ (file-name-all-completions filename path)))
+ (setq filepath (concat path file))
+ (if (and (not (member file completions)) ;
+ (or (string-equal path cwd)
+ (not (file-directory-p filepath)))
+ ;; FIXME: Those repeated file tests end up
+ ;; very costly over Tramp, we should cache the result.
+ (if eshell-force-execution
+ (file-readable-p filepath)
+ (file-executable-p filepath)))
+ (push file completions))))
+ ;; Add aliases which are currently visible, and Lisp functions.
+ (pcomplete-uniquify-list
+ (if glob-name
+ completions
+ (setq completions
+ (append (if (fboundp 'eshell-alias-completions)
+ (eshell-alias-completions filename))
+ (eshell-winnow-list
+ (mapcar
+ (lambda (name)
+ (substring name 7))
+ (all-completions (concat "eshell/" filename)
+ obarray #'functionp))
+ nil '(eshell-find-alias-function))
+ completions))
+ (append (and (or eshell-show-lisp-completions
+ (and eshell-show-lisp-alternatives
+ (null completions)))
+ (all-completions filename obarray #'functionp))
+ completions)))))))))
(define-obsolete-function-alias 'eshell-pcomplete #'completion-at-point "27.1")
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index c22c6bcdb0e..ee9057f50e8 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -168,12 +168,14 @@ Thus, this does not include the current directory.")
(defvar eshell-last-dir-ring nil
"The last directory that Eshell was in.")
+(defconst eshell-inside-emacs (format "%s,eshell" emacs-version)
+ "Value for the `INSIDE_EMACS' environment variable.")
+
;;; Functions:
(defun eshell-dirs-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the builtin functions for Eshell."
- (make-local-variable 'eshell-variable-aliases-list)
- (setq eshell-variable-aliases-list
+ (setq-local eshell-variable-aliases-list
(append
eshell-variable-aliases-list
`(("-" ,(lambda (indices)
@@ -191,15 +193,16 @@ Thus, this does not include the current directory.")
(unless (ring-empty-p eshell-last-dir-ring)
(expand-file-name
(ring-ref eshell-last-dir-ring 0))))
+ t)
+ ("INSIDE_EMACS" eshell-inside-emacs
t))))
(when eshell-cd-on-directory
- (make-local-variable 'eshell-interpreter-alist)
- (setq eshell-interpreter-alist
- (cons (cons #'(lambda (file _args)
- (eshell-lone-directory-p file))
- 'eshell-dirs-substitute-cd)
- eshell-interpreter-alist)))
+ (setq-local eshell-interpreter-alist
+ (cons (cons (lambda (file _args)
+ (eshell-lone-directory-p file))
+ 'eshell-dirs-substitute-cd)
+ eshell-interpreter-alist)))
(add-hook 'eshell-parse-argument-hook
#'eshell-parse-user-reference nil t)
@@ -221,7 +224,7 @@ Thus, this does not include the current directory.")
(add-hook 'eshell-exit-hook #'eshell-write-last-dir-ring nil t)
- (add-hook 'kill-emacs-hook #'eshell-save-some-last-dir))
+ (add-hook 'kill-emacs-query-functions #'eshell-save-some-last-dir))
(defun eshell-save-some-last-dir ()
"Save the list-dir-ring for any open Eshell buffers."
@@ -235,7 +238,8 @@ Thus, this does not include the current directory.")
(format-message
"Save last dir ring for Eshell buffer `%s'? "
(buffer-name buf)))))
- (eshell-write-last-dir-ring))))))
+ (eshell-write-last-dir-ring)))))
+ t)
(defun eshell-lone-directory-p (file)
"Test whether FILE is just a directory name, and not a command name."
@@ -284,9 +288,8 @@ Thus, this does not include the current directory.")
(eshell-read-user-names)
(pcomplete-uniquify-list
(mapcar
- (function
- (lambda (user)
- (file-name-as-directory (cdr user))))
+ (lambda (user)
+ (file-name-as-directory (cdr user)))
eshell-user-names)))))))
(defun eshell/pwd (&rest _args)
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index ccbaed0c4f7..316094b17e4 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -129,7 +129,7 @@ This option slows down recursive glob processing by quite a bit."
"Initialize the extended globbing code."
;; it's important that `eshell-glob-chars-list' come first
(when (boundp 'eshell-special-chars-outside-quoting)
- (set (make-local-variable 'eshell-special-chars-outside-quoting)
+ (setq-local eshell-special-chars-outside-quoting
(append eshell-glob-chars-list eshell-special-chars-outside-quoting)))
(add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars t t)
(add-hook 'eshell-pre-rewrite-command-hook
@@ -205,7 +205,7 @@ resulting regular expression."
regexp)
(while (string-match
(or eshell-glob-chars-regexp
- (set (make-local-variable 'eshell-glob-chars-regexp)
+ (setq-local eshell-glob-chars-regexp
(format "[%s]+" (apply 'string eshell-glob-chars-list))))
pattern matched-in-pattern)
(let* ((op-begin (match-beginning 0))
@@ -232,8 +232,6 @@ resulting regular expression."
(regexp-quote (substring pattern matched-in-pattern))
"\\'")))
-(defvar ange-cache) ; XEmacs? See esh-util
-
(defun eshell-extended-glob (glob)
"Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY.
This function almost fully supports zsh style filename generation
@@ -252,7 +250,7 @@ the form:
(INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))"
(let ((paths (eshell-split-path glob))
- eshell-glob-matches message-shown ange-cache)
+ eshell-glob-matches message-shown)
(unwind-protect
(if (and (cdr paths)
(file-name-absolute-p (car paths)))
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index ef31bdd264c..d82946add00 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -75,17 +75,14 @@
(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)
+ :type 'hook)
(defcustom eshell-hist-unload-hook
(list
- (function
- (lambda ()
- (remove-hook 'kill-emacs-hook 'eshell-save-some-history))))
+ (lambda ()
+ (remove-hook 'kill-emacs-hook 'eshell-save-some-history)))
"A hook that gets run when `eshell-hist' is unloaded."
- :type 'hook
- :group 'eshell-hist)
+ :type 'hook)
(defcustom eshell-history-file-name
(expand-file-name "history" eshell-directory-name)
@@ -93,20 +90,21 @@
See also `eshell-read-history' and `eshell-write-history'.
If it is nil, Eshell will use the value of HISTFILE."
:type '(choice (const :tag "Use HISTFILE" nil)
- file)
- :group 'eshell-hist)
+ file))
(defcustom eshell-history-size 128
"Size of the input history ring. If nil, use envvar HISTSIZE."
:type '(choice (const :tag "Use HISTSIZE" nil)
- integer)
- :group 'eshell-hist)
+ integer))
(defcustom eshell-hist-ignoredups nil
"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)
+The value `erase' mirrors the \"erasedups\" value of HISTCONTROL
+in bash, and any other non-nil value mirrors the \"ignoredups\"
+value."
+ :type '(choice (const :tag "Don't ignore anything" nil)
+ (const :tag "Ignore consecutive duplicates" t)
+ (const :tag "Only keep last duplicate" 'erase)))
(defcustom eshell-save-history-on-exit t
"Determine if history should be automatically saved.
@@ -118,8 +116,7 @@ If set to `ask', ask if any Eshell buffers are open at exit time.
If set to t, history will always be saved, silently."
:type '(choice (const :tag "Never" nil)
(const :tag "Ask" ask)
- (const :tag "Always save" t))
- :group 'eshell-hist)
+ (const :tag "Always save" t)))
(defcustom eshell-input-filter 'eshell-input-filter-default
"Predicate for filtering additions to input history.
@@ -128,8 +125,7 @@ the input history list. Default is to save anything that isn't all
whitespace."
:type '(radio (function-item eshell-input-filter-default)
(function-item eshell-input-filter-initial-space)
- (function :tag "Other function"))
- :group 'eshell-hist)
+ (function :tag "Other function")))
(put 'eshell-input-filter 'risky-local-variable t)
@@ -138,31 +134,26 @@ whitespace."
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."
- :type 'boolean
- :group 'eshell-hist)
+ :type 'boolean)
(defcustom eshell-hist-move-to-end t
"If non-nil, move to the end of the buffer before cycling history."
- :type 'boolean
- :group 'eshell-hist)
+ :type 'boolean)
(defcustom eshell-hist-event-designator
"^!\\(!\\|-?[0-9]+\\|\\??[^:^$%*?]+\\??\\|#\\)"
"The regexp used to identifier history event designators."
- :type 'regexp
- :group 'eshell-hist)
+ :type 'regexp)
(defcustom eshell-hist-word-designator
"^:?\\([0-9]+\\|[$^%*]\\)?\\(-[0-9]*\\|[$^%*]\\)?"
"The regexp used to identify history word designators."
- :type 'regexp
- :group 'eshell-hist)
+ :type 'regexp)
(defcustom eshell-hist-modifier
"^\\(:\\([hretpqx&g]\\|s/\\([^/]*\\)/\\([^/]*\\)/\\)\\)*"
"The regexp used to identity history modifiers."
- :type 'regexp
- :group 'eshell-hist)
+ :type 'regexp)
(defcustom eshell-hist-rebind-keys-alist
'(([(control ?p)] . eshell-previous-input)
@@ -180,8 +171,7 @@ element, regardless of any text on the command line. In that case,
"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")))
- :group 'eshell-hist)
+ (function :tag "Command"))))
;;; Internal Variables:
@@ -202,6 +192,32 @@ element, regardless of any text on the command line. In that case,
map)
"Keymap used in isearch in Eshell.")
+(defvar eshell-hist-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [up] #'eshell-previous-matching-input-from-input)
+ (define-key map [down] #'eshell-next-matching-input-from-input)
+ (define-key map [(control up)] #'eshell-previous-input)
+ (define-key map [(control down)] #'eshell-next-input)
+ (define-key map [(meta ?r)] #'eshell-previous-matching-input)
+ (define-key map [(meta ?s)] #'eshell-next-matching-input)
+ (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input)
+ (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input)
+ ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_
+ ;; em-hist is loaded and won't respect changes.
+ (if eshell-hist-match-partial
+ (progn
+ (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input)
+ (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input)
+ (define-key map (kbd "C-c M-p") #'eshell-previous-input)
+ (define-key map (kbd "C-c M-n") #'eshell-next-input))
+ (define-key map [(meta ?p)] #'eshell-previous-input)
+ (define-key map [(meta ?n)] #'eshell-next-input)
+ (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input)
+ (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input))
+ (define-key map (kbd "C-c C-l") #'eshell-list-history)
+ (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history)
+ map))
+
(defvar eshell-rebind-keys-alist)
;;; Functions:
@@ -216,6 +232,12 @@ Returns non-nil if INPUT is blank."
Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(not (string-match-p "\\`\\s-+" input)))
+(define-minor-mode eshell-hist-mode
+ "Minor mode for the eshell-hist module.
+
+\\{eshell-hist-mode-map}"
+ :keymap eshell-hist-mode-map)
+
(defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the history management code for one Eshell buffer."
(when (eshell-using-module 'eshell-cmpl)
@@ -225,47 +247,21 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(if (and (eshell-using-module 'eshell-rebind)
(not eshell-non-interactive-p))
(let ((rebind-alist eshell-rebind-keys-alist))
- (make-local-variable 'eshell-rebind-keys-alist)
- (setq eshell-rebind-keys-alist
+ (setq-local eshell-rebind-keys-alist
(append rebind-alist eshell-hist-rebind-keys-alist))
- (set (make-local-variable 'search-invisible) t)
- (set (make-local-variable 'search-exit-option) t)
+ (setq-local search-invisible t)
+ (setq-local search-exit-option t)
(add-hook 'isearch-mode-hook
- (function
- (lambda ()
- (if (>= (point) eshell-last-output-end)
- (setq overriding-terminal-local-map
- eshell-isearch-map))))
+ (lambda ()
+ (if (>= (point) eshell-last-output-end)
+ (setq overriding-terminal-local-map
+ eshell-isearch-map)))
nil t)
(add-hook 'isearch-mode-end-hook
- (function
- (lambda ()
- (setq overriding-terminal-local-map nil)))
+ (lambda ()
+ (setq overriding-terminal-local-map nil))
nil t))
- (define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input)
- (define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input)
- (define-key eshell-mode-map [(control up)] 'eshell-previous-input)
- (define-key eshell-mode-map [(control down)] 'eshell-next-input)
- (define-key eshell-mode-map [(meta ?r)] 'eshell-previous-matching-input)
- (define-key eshell-mode-map [(meta ?s)] 'eshell-next-matching-input)
- (define-key eshell-command-map [(meta ?r)]
- 'eshell-previous-matching-input-from-input)
- (define-key eshell-command-map [(meta ?s)]
- 'eshell-next-matching-input-from-input)
- (if eshell-hist-match-partial
- (progn
- (define-key eshell-mode-map [(meta ?p)]
- 'eshell-previous-matching-input-from-input)
- (define-key eshell-mode-map [(meta ?n)]
- 'eshell-next-matching-input-from-input)
- (define-key eshell-command-map [(meta ?p)] 'eshell-previous-input)
- (define-key eshell-command-map [(meta ?n)] 'eshell-next-input))
- (define-key eshell-mode-map [(meta ?p)] 'eshell-previous-input)
- (define-key eshell-mode-map [(meta ?n)] 'eshell-next-input)
- (define-key eshell-command-map [(meta ?p)]
- 'eshell-previous-matching-input-from-input)
- (define-key eshell-command-map [(meta ?n)]
- 'eshell-next-matching-input-from-input)))
+ (eshell-hist-mode))
(make-local-variable 'eshell-history-size)
(or eshell-history-size
@@ -285,8 +281,8 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(make-local-variable 'eshell-save-history-index)
(if (minibuffer-window-active-p (selected-window))
- (set (make-local-variable 'eshell-save-history-on-exit) nil)
- (set (make-local-variable 'eshell-history-ring) nil)
+ (setq-local eshell-save-history-on-exit nil)
+ (setq-local eshell-history-ring nil)
(if eshell-history-file-name
(eshell-read-history nil t))
@@ -297,13 +293,9 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(add-hook 'eshell-exit-hook #'eshell-write-history nil t)
- (add-hook 'kill-emacs-hook #'eshell-save-some-history)
-
- (make-local-variable 'eshell-input-filter-functions)
- (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t)
+ (add-hook 'kill-emacs-query-functions #'eshell-save-some-history)
- (define-key eshell-command-map [(control ?l)] 'eshell-list-history)
- (define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history))
+ (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t))
(defun eshell-save-some-history ()
"Save the history for any open Eshell buffers."
@@ -318,7 +310,8 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(format-message
"Save input history for Eshell buffer `%s'? "
(buffer-name buf)))))
- (eshell-write-history))))))
+ (eshell-write-history)))))
+ t)
(defun eshell/history (&rest args)
"List in help buffer the buffer's input history."
@@ -383,12 +376,22 @@ unless a different file is specified on the command line.")
Input is entered into the input history ring, if the value of
variable `eshell-input-filter' returns non-nil when called on the
input."
- (if (and (funcall eshell-input-filter input)
- (or (null eshell-hist-ignoredups)
- (not (ring-p eshell-history-ring))
- (ring-empty-p eshell-history-ring)
- (not (string-equal (eshell-get-history 0) input))))
- (eshell-put-history input))
+ (when (and (funcall eshell-input-filter input)
+ (if (eq eshell-hist-ignoredups 'erase)
+ ;; Remove any old occurrences of the input, and put
+ ;; the new one at the end.
+ (unless (ring-empty-p eshell-history-ring)
+ (ring-remove eshell-history-ring
+ (ring-member eshell-history-ring input))
+ t)
+ ;; Always add...
+ (or (null eshell-hist-ignoredups)
+ ;; ... or add if it's not already present at the
+ ;; end.
+ (not (ring-p eshell-history-ring))
+ (ring-empty-p eshell-history-ring)
+ (not (string-equal (eshell-get-history 0) input)))))
+ (eshell-put-history input))
(setq eshell-save-history-index eshell-history-index)
(setq eshell-history-index nil))
@@ -756,7 +759,7 @@ matched."
(setq nth (eshell-hist-word-reference nth)))
(unless (numberp mth)
(setq mth (eshell-hist-word-reference mth)))
- (cons (mapconcat #'identity (eshell-sublist textargs nth mth) " ")
+ (cons (mapconcat #'identity (seq-subseq textargs nth (1+ mth)) " ")
end))))
(defun eshell-hist-parse-modifier (hist reference)
@@ -856,7 +859,7 @@ Moves relative to START, or `eshell-history-index'."
(setq prev n
n (mod (+ n motion) len))
;; If we haven't reached a match, step some more.
- (while (and (< n len) (not tried-each-ring-item)
+ (while (and (not tried-each-ring-item)
(not (string-match regexp (eshell-get-history n))))
(setq n (mod (+ n motion) len)
;; If we have gone all the way around in this search.
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index 1d80de1139b..3d7c43b404b 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -239,7 +239,6 @@ scope during the evaluation of TEST-SEXP."
(defvar show-recursive)
(defvar show-size)
(defvar sort-method)
-(defvar ange-cache)
(defvar dired-flag)
;;; Functions:
@@ -271,14 +270,13 @@ instead."
eshell-current-subjob-p
font-lock-mode)
;; use the fancy highlighting in `eshell-ls' rather than font-lock
- (when (and eshell-ls-use-colors
- (featurep 'font-lock))
+ (when eshell-ls-use-colors
(font-lock-mode -1)
(setq font-lock-defaults nil)
(if (boundp 'font-lock-buffers)
- (set 'font-lock-buffers
- (delq (current-buffer)
- (symbol-value 'font-lock-buffers)))))
+ (setq font-lock-buffers
+ (delq (current-buffer)
+ (symbol-value 'font-lock-buffers)))))
(require 'em-glob)
(let* ((insert-func 'insert)
(error-func 'insert)
@@ -406,7 +404,7 @@ Sort entries alphabetically across.")
(setq listing-style 'by-columns))
(unless args
(setq args (list ".")))
- (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp) ange-cache)
+ (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp))
(when ignore-pattern
(unless (eshell-using-module 'eshell-glob)
(error (concat "-I option requires that `eshell-glob'"
@@ -632,38 +630,37 @@ In Eshell's implementation of ls, ENTRIES is always reversed."
(if (eq sort-method 'unsorted)
(nreverse entries)
(sort entries
- (function
- (lambda (l r)
- (let ((result
- (cond
- ((eq sort-method 'by-atime)
- (eshell-ls-compare-entries l r 4 'time-less-p))
- ((eq sort-method 'by-mtime)
- (eshell-ls-compare-entries l r 5 'time-less-p))
- ((eq sort-method 'by-ctime)
- (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)
- (let ((lx (file-name-extension
- (directory-file-name (car l))))
- (rx (file-name-extension
- (directory-file-name (car r)))))
- (cond
- ((or (and (not lx) (not rx))
- (equal lx rx))
- (string-lessp (directory-file-name (car l))
- (directory-file-name (car r))))
- ((not lx) t)
- ((not rx) nil)
- (t
- (string-lessp lx rx)))))
- (t
- (string-lessp (directory-file-name (car l))
- (directory-file-name (car r)))))))
- (if reverse-list
- (not result)
- result)))))))
+ (lambda (l r)
+ (let ((result
+ (cond
+ ((eq sort-method 'by-atime)
+ (eshell-ls-compare-entries l r 4 'time-less-p))
+ ((eq sort-method 'by-mtime)
+ (eshell-ls-compare-entries l r 5 'time-less-p))
+ ((eq sort-method 'by-ctime)
+ (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)
+ (let ((lx (file-name-extension
+ (directory-file-name (car l))))
+ (rx (file-name-extension
+ (directory-file-name (car r)))))
+ (cond
+ ((or (and (not lx) (not rx))
+ (equal lx rx))
+ (string-lessp (directory-file-name (car l))
+ (directory-file-name (car r))))
+ ((not lx) t)
+ ((not rx) nil)
+ (t
+ (string-lessp lx rx)))))
+ (t
+ (string-lessp (directory-file-name (car l))
+ (directory-file-name (car r)))))))
+ (if reverse-list
+ (not result)
+ result))))))
(defun eshell-ls-files (files &optional size-width copy-fileinfo)
"Output a list of FILES.
@@ -683,12 +680,12 @@ Each member of FILES is either a string or a cons cell of the form
(let ((f files)
last-f
display-files
- ignore)
+ ) ;; ignore
(while f
(if (cdar f)
(setq last-f f
f (cdr f))
- (unless ignore
+ (unless nil ;; ignore
(funcall error-func
(format "%s: No such file or directory\n" (caar f))))
(if (eq f files)
@@ -701,7 +698,7 @@ Each member of FILES is either a string or a cons cell of the form
(setcar f (cadr f))
(setcdr f (cddr f))))))
(if (not show-size)
- (setq display-files (mapcar 'eshell-ls-annotate files))
+ (setq display-files (mapcar #'eshell-ls-annotate files))
(dolist (file files)
(let* ((str (eshell-ls-printable-size (file-attribute-size (cdr file)) t))
(len (length str)))
@@ -800,9 +797,8 @@ to use, and each member of which is the width of that column
(width 0)
(widths
(mapcar
- (function
- (lambda (file)
- (+ 2 (length (car file)))))
+ (lambda (file)
+ (+ 2 (length (car file))))
files))
;; must account for the added space...
(max-width (+ (window-width) 2))
@@ -847,9 +843,8 @@ to use, and each member of which is the width of that column
(width 0)
(widths
(mapcar
- (function
- (lambda (file)
- (+ 2 (length (car file)))))
+ (lambda (file)
+ (+ 2 (length (car file))))
files))
(max-width (+ (window-width) 2))
col-widths
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index 011b6c8d47e..def52f42e55 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -63,8 +63,7 @@ ordinary strings."
(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)
+ :type 'hook)
(defcustom eshell-predicate-alist
'((?/ . (eshell-pred-file-type ?d)) ; directories
@@ -73,30 +72,30 @@ ordinary strings."
(?p . (eshell-pred-file-type ?p)) ; named pipes
(?@ . (eshell-pred-file-type ?l)) ; symbolic links
(?% . (eshell-pred-file-type ?%)) ; allow user to specify (c def.)
- (?r . (eshell-pred-file-mode 0400)) ; owner-readable
- (?w . (eshell-pred-file-mode 0200)) ; owner-writable
- (?x . (eshell-pred-file-mode 0100)) ; owner-executable
- (?A . (eshell-pred-file-mode 0040)) ; group-readable
- (?I . (eshell-pred-file-mode 0020)) ; group-writable
- (?E . (eshell-pred-file-mode 0010)) ; group-executable
- (?R . (eshell-pred-file-mode 0004)) ; world-readable
- (?W . (eshell-pred-file-mode 0002)) ; world-writable
- (?X . (eshell-pred-file-mode 0001)) ; world-executable
- (?s . (eshell-pred-file-mode 4000)) ; setuid
- (?S . (eshell-pred-file-mode 2000)) ; setgid
- (?t . (eshell-pred-file-mode 1000)) ; sticky bit
- (?U . #'(lambda (file) ; owned by effective uid
- (if (file-exists-p file)
- (= (file-attribute-user-id (file-attributes file))
- (user-uid)))))
- ;; (?G . #'(lambda (file) ; owned by effective gid
- ;; (if (file-exists-p file)
- ;; (= (file-attribute-user-id (file-attributes file))
- ;; (user-uid)))))
- (?* . #'(lambda (file)
- (and (file-regular-p file)
- (not (file-symlink-p file))
- (file-executable-p file))))
+ (?r . (eshell-pred-file-mode #o0400)) ; owner-readable
+ (?w . (eshell-pred-file-mode #o0200)) ; owner-writable
+ (?x . (eshell-pred-file-mode #o0100)) ; owner-executable
+ (?A . (eshell-pred-file-mode #o0040)) ; group-readable
+ (?I . (eshell-pred-file-mode #o0020)) ; group-writable
+ (?E . (eshell-pred-file-mode #o0010)) ; group-executable
+ (?R . (eshell-pred-file-mode #o0004)) ; world-readable
+ (?W . (eshell-pred-file-mode #o0002)) ; world-writable
+ (?X . (eshell-pred-file-mode #o0001)) ; world-executable
+ (?s . (eshell-pred-file-mode #o4000)) ; setuid
+ (?S . (eshell-pred-file-mode #o2000)) ; setgid
+ (?t . (eshell-pred-file-mode #o1000)) ; sticky bit
+ (?U . (lambda (file) ; owned by effective uid
+ (if (file-exists-p file)
+ (= (file-attribute-user-id (file-attributes file))
+ (user-uid)))))
+ ;; (?G . (lambda (file) ; owned by effective gid
+ ;; (if (file-exists-p file)
+ ;; (= (file-attribute-user-id (file-attributes file))
+ ;; (user-uid)))))
+ (?* . (lambda (file)
+ (and (file-regular-p file)
+ (not (file-symlink-p file))
+ (file-executable-p file))))
(?l . (eshell-pred-file-links))
(?u . (eshell-pred-user-or-group ?u "user" 2 'eshell-user-id))
(?g . (eshell-pred-user-or-group ?g "group" 3 'eshell-group-id))
@@ -108,32 +107,30 @@ ordinary strings."
The format of each entry is
(CHAR . PREDICATE-FUNC-SEXP)"
- :type '(repeat (cons character sexp))
- :group 'eshell-pred)
+ :type '(repeat (cons character sexp)))
(put 'eshell-predicate-alist 'risky-local-variable t)
(defcustom eshell-modifier-alist
- '((?E . #'(lambda (lst)
- (mapcar
- (function
- (lambda (str)
- (eshell-stringify
- (car (eshell-parse-argument str)))))
- lst)))
- (?L . #'(lambda (lst) (mapcar 'downcase lst)))
- (?U . #'(lambda (lst) (mapcar 'upcase lst)))
- (?C . #'(lambda (lst) (mapcar 'capitalize lst)))
- (?h . #'(lambda (lst) (mapcar 'file-name-directory lst)))
+ '((?E . (lambda (lst)
+ (mapcar
+ (lambda (str)
+ (eshell-stringify
+ (car (eshell-parse-argument str))))
+ lst)))
+ (?L . (lambda (lst) (mapcar #'downcase lst)))
+ (?U . (lambda (lst) (mapcar #'upcase lst)))
+ (?C . (lambda (lst) (mapcar #'capitalize lst)))
+ (?h . (lambda (lst) (mapcar #'file-name-directory lst)))
(?i . (eshell-include-members))
(?x . (eshell-include-members t))
- (?r . #'(lambda (lst) (mapcar 'file-name-sans-extension lst)))
- (?e . #'(lambda (lst) (mapcar 'file-name-extension lst)))
- (?t . #'(lambda (lst) (mapcar 'file-name-nondirectory lst)))
- (?q . #'(lambda (lst) (mapcar 'eshell-escape-arg lst)))
- (?u . #'(lambda (lst) (eshell-uniquify-list lst)))
- (?o . #'(lambda (lst) (sort lst 'string-lessp)))
- (?O . #'(lambda (lst) (nreverse (sort lst 'string-lessp))))
+ (?r . (lambda (lst) (mapcar #'file-name-sans-extension lst)))
+ (?e . (lambda (lst) (mapcar #'file-name-extension lst)))
+ (?t . (lambda (lst) (mapcar #'file-name-nondirectory lst)))
+ (?q . (lambda (lst) (mapcar #'eshell-escape-arg lst)))
+ (?u . (lambda (lst) (seq-uniq lst)))
+ (?o . (lambda (lst) (sort lst #'string-lessp)))
+ (?O . (lambda (lst) (nreverse (sort lst #'string-lessp))))
(?j . (eshell-join-members))
(?S . (eshell-split-members))
(?R . 'reverse)
@@ -147,8 +144,7 @@ The format of each entry is
The format of each entry is
(CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)"
- :type '(repeat (cons character sexp))
- :group 'eshell-pred)
+ :type '(repeat (cons character sexp)))
(put 'eshell-modifier-alist 'risky-local-variable t)
@@ -229,28 +225,37 @@ FOR LISTS OF ARGUMENTS:
EXAMPLES:
*.c(:o) sorted list of .c files")
+(defvar eshell-pred-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help)
+ (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help)
+ map))
+
;;; Functions:
(defun eshell-display-predicate-help ()
(interactive)
(with-electric-help
- (function
- (lambda ()
- (insert eshell-predicate-help-string)))))
+ (lambda ()
+ (insert eshell-predicate-help-string))))
(defun eshell-display-modifier-help ()
(interactive)
(with-electric-help
- (function
- (lambda ()
- (insert eshell-modifier-help-string)))))
+ (lambda ()
+ (insert eshell-modifier-help-string))))
+
+(define-minor-mode eshell-pred-mode
+ "Minor mode for the eshell-pred module.
+
+\\{eshell-pred-mode-map}"
+ :keymap eshell-pred-mode-map)
(defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the predicate/modifier code."
(add-hook 'eshell-parse-argument-hook
#'eshell-parse-arg-modifier t t)
- (define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help)
- (define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help))
+ (eshell-pred-mode))
(defun eshell-apply-modifiers (lst predicates modifiers)
"Apply to LIST a series of PREDICATES and MODIFIERS."
@@ -289,9 +294,9 @@ This function is specially for adding onto `eshell-parse-argument-hook'."
(append
eshell-current-modifiers
(list
- `(lambda (lst)
- (eshell-apply-modifiers
- lst (quote ,preds) (quote ,mods)))))))))
+ (lambda (lst)
+ (eshell-apply-modifiers
+ lst preds mods))))))))
(goto-char (1+ end))
(eshell-finish-arg))))))
@@ -316,7 +321,7 @@ resultant list of strings."
(if (looking-at "[^|':]")
(let ((func (read (current-buffer))))
(if (and func (functionp func))
- (setq preds (eshell-add-pred-func func preds
+ (setq preds (eshell-add-pred-func (eval func t) preds
negate follow))
(error "Invalid function predicate `%s'"
(eshell-stringify func))))
@@ -333,8 +338,7 @@ resultant list of strings."
(let ((func (read (current-buffer))))
(if (and func (functionp func))
(setq mods
- (cons `(lambda (lst)
- (mapcar (function ,func) lst))
+ (cons (lambda (lst) (mapcar func lst))
mods))
(error "Invalid function modifier `%s'"
(eshell-stringify func))))
@@ -345,14 +349,14 @@ resultant list of strings."
(if (not mod)
(error "Unknown modifier character `%c'" (char-after))
(forward-char)
- (setq mods (cons (eval (cdr mod)) mods)))))
+ (setq mods (cons (eval (cdr mod) t) mods)))))
(t
(let ((pred (assq char eshell-predicate-alist)))
(if (not pred)
(error "Unknown predicate character `%c'" char)
(forward-char)
(setq preds
- (eshell-add-pred-func (eval (cdr pred)) preds
+ (eshell-add-pred-func (eval (cdr pred) t) preds
negate follow))))))))
(end-of-buffer
(error "Predicate or modifier ended prematurely")))
@@ -361,11 +365,11 @@ resultant list of strings."
(defun eshell-add-pred-func (pred funcs negate follow)
"Add the predicate function PRED to FUNCS."
(if negate
- (setq pred `(lambda (file)
- (not (funcall ,pred file)))))
+ (setq pred (lambda (file)
+ (not (funcall pred file)))))
(if follow
- (setq pred `(lambda (file)
- (funcall ,pred (file-truename file)))))
+ (setq pred (lambda (file)
+ (funcall pred (file-truename file)))))
(cons pred funcs))
(defun eshell-pred-user-or-group (mod-char mod-type attr-index get-id-func)
@@ -391,10 +395,10 @@ resultant list of strings."
(unless ugid
(error "Unknown %s name specified for modifier `%c'"
mod-type mod-char))
- `(lambda (file)
- (let ((attrs (file-attributes file)))
- (if attrs
- (= (nth ,attr-index attrs) ,ugid))))))
+ (lambda (file)
+ (let ((attrs (file-attributes file)))
+ (if attrs
+ (= (nth attr-index attrs) ugid))))))
(defun eshell-pred-file-time (mod-char mod-type attr-index)
"Return a predicate to test whether a file matches a certain time."
@@ -437,15 +441,13 @@ resultant list of strings."
(error "Cannot stat file `%s'" file))
(setq when (nth attr-index attrs)))
(goto-char (1+ end)))
- `(lambda (file)
- (let ((attrs (file-attributes file)))
- (if attrs
- (,(if (eq qual ?-)
- 'time-less-p
- (if (eq qual ?+)
- '(lambda (a b) (time-less-p b a))
- 'time-equal-p))
- ,when (nth ,attr-index attrs)))))))
+ (let ((f (cond ((eq qual ?-) #'time-less-p)
+ ((eq qual ?+) (lambda (a b) (time-less-p b a)))
+ (#'time-equal-p))))
+ (lambda (file)
+ (let ((attrs (file-attributes file)))
+ (if attrs
+ (funcall f when (nth attr-index attrs))))))))
(defun eshell-pred-file-type (type)
"Return a test which tests that the file is of a certain TYPE.
@@ -456,20 +458,20 @@ that `ls -l' will show in the first column of its display."
(if (memq type '(?b ?c))
(forward-char)
(setq type ?%)))
- `(lambda (file)
- (let ((attrs (eshell-file-attributes (directory-file-name file))))
- (if attrs
- (memq (aref (file-attribute-modes attrs) 0)
- ,(if (eq type ?%)
- '(?b ?c)
- (list 'quote (list type))))))))
+ (let ((set (if (eq type ?%)
+ '(?b ?c)
+ (list type))))
+ (lambda (file)
+ (let ((attrs (eshell-file-attributes (directory-file-name file))))
+ (if attrs
+ (memq (aref (file-attribute-modes attrs) 0) set))))))
(defsubst eshell-pred-file-mode (mode)
"Return a test which tests that MODE pertains to the file."
- `(lambda (file)
- (let ((modes (file-modes file)))
- (if modes
- (logand ,mode modes)))))
+ (lambda (file)
+ (let ((modes (file-modes file 'nofollow)))
+ (if modes
+ (not (zerop (logand mode modes)))))))
(defun eshell-pred-file-links ()
"Return a predicate to test whether a file has a given number of links."
@@ -481,15 +483,15 @@ that `ls -l' will show in the first column of its display."
(error "Invalid file link count modifier `l'"))
(setq amount (string-to-number (match-string 0)))
(goto-char (match-end 0))
- `(lambda (file)
- (let ((attrs (eshell-file-attributes file)))
- (if attrs
- (,(if (eq qual ?-)
- '<
- (if (eq qual ?+)
- '>
- '=))
- (file-attribute-link-number attrs) ,amount))))))
+ (let ((f (if (eq qual ?-)
+ #'<
+ (if (eq qual ?+)
+ #'>
+ #'=))))
+ (lambda (file)
+ (let ((attrs (eshell-file-attributes file)))
+ (if attrs
+ (funcall f (file-attribute-link-number attrs) amount)))))))
(defun eshell-pred-file-size ()
"Return a predicate to test whether a file is of a given size."
@@ -511,15 +513,15 @@ that `ls -l' will show in the first column of its display."
(error "Invalid file size modifier `L'"))
(setq amount (* (string-to-number (match-string 0)) quantum))
(goto-char (match-end 0))
- `(lambda (file)
- (let ((attrs (eshell-file-attributes file)))
- (if attrs
- (,(if (eq qual ?-)
- '<
- (if (eq qual ?+)
- '>
- '=))
- (file-attribute-size attrs) ,amount))))))
+ (let ((f (if (eq qual ?-)
+ #'<
+ (if (eq qual ?+)
+ #'>
+ #'=))))
+ (lambda (file)
+ (let ((attrs (eshell-file-attributes file)))
+ (if attrs
+ (funcall f (file-attribute-size attrs) amount)))))))
(defun eshell-pred-substitute (&optional repeat)
"Return a modifier function that will substitute matches."
@@ -533,22 +535,22 @@ that `ls -l' will show in the first column of its display."
replace (buffer-substring-no-properties (point) end))
(goto-char (1+ end))
(if repeat
- `(lambda (lst)
- (mapcar
- (function
- (lambda (str)
- (let ((i 0))
- (while (setq i (string-match ,match str i))
- (setq str (replace-match ,replace t nil str))))
- str)) lst))
- `(lambda (lst)
- (mapcar
- (function
- (lambda (str)
- (if (string-match ,match str)
- (setq str (replace-match ,replace t nil str))
- (error (concat str ": substitution failed")))
- str)) lst)))))
+ (lambda (lst)
+ (mapcar
+ (lambda (str)
+ (let ((i 0))
+ (while (setq i (string-match match str i))
+ (setq str (replace-match replace t nil str))))
+ str)
+ lst))
+ (lambda (lst)
+ (mapcar
+ (lambda (str)
+ (if (string-match match str)
+ (setq str (replace-match replace t nil str))
+ (error (concat str ": substitution failed")))
+ str)
+ lst)))))
(defun eshell-include-members (&optional invert-p)
"Include only lisp members matching a regexp."
@@ -558,12 +560,12 @@ that `ls -l' will show in the first column of its display."
(setq end (eshell-find-delimiter delim delim nil nil t)
regexp (buffer-substring-no-properties (point) end))
(goto-char (1+ end))
- `(lambda (lst)
- (eshell-winnow-list
- lst nil '((lambda (elem)
- ,(if invert-p
- `(not (string-match ,regexp elem))
- `(string-match ,regexp elem))))))))
+ (let ((predicates
+ (list (if invert-p
+ (lambda (elem) (not (string-match regexp elem)))
+ (lambda (elem) (string-match regexp elem))))))
+ (lambda (lst)
+ (eshell-winnow-list lst nil predicates)))))
(defun eshell-join-members ()
"Return a modifier function that join matches."
@@ -575,8 +577,8 @@ that `ls -l' will show in the first column of its display."
(setq end (eshell-find-delimiter delim delim nil nil t)
str (buffer-substring-no-properties (point) end))
(goto-char (1+ end)))
- `(lambda (lst)
- (mapconcat 'identity lst ,str))))
+ (lambda (lst)
+ (mapconcat #'identity lst str))))
(defun eshell-split-members ()
"Return a modifier function that splits members."
@@ -587,11 +589,11 @@ that `ls -l' will show in the first column of its display."
(setq end (eshell-find-delimiter delim delim nil nil t)
sep (buffer-substring-no-properties (point) end))
(goto-char (1+ end)))
- `(lambda (lst)
- (mapcar
- (function
- (lambda (str)
- (split-string str ,sep))) lst))))
+ (lambda (lst)
+ (mapcar
+ (lambda (str)
+ (split-string str sep))
+ lst))))
(provide 'em-pred)
diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el
index b0d57c4482d..aa96166087a 100644
--- a/lisp/eshell/em-prompt.el
+++ b/lisp/eshell/em-prompt.el
@@ -48,10 +48,9 @@ as is common with most shells."
(autoload 'eshell/pwd "em-dirs")
(defcustom eshell-prompt-function
- (function
- (lambda ()
- (concat (abbreviate-file-name (eshell/pwd))
- (if (= (user-uid) 0) " # " " $ "))))
+ (lambda ()
+ (concat (abbreviate-file-name (eshell/pwd))
+ (if (= (user-uid) 0) " # " " $ ")))
"A function that returns the Eshell prompt string.
Make sure to update `eshell-prompt-regexp' so that it will match your
prompt."
@@ -97,8 +96,20 @@ arriving, or after."
:options '(eshell-show-maximum-output)
:group 'eshell-prompt)
+(defvar eshell-prompt-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-n") #'eshell-next-prompt)
+ (define-key map (kbd "C-c C-p") #'eshell-previous-prompt)
+ map))
+
;;; Functions:
+(define-minor-mode eshell-prompt-mode
+ "Minor mode for eshell-prompt module.
+
+\\{eshell-prompt-mode-map}"
+ :keymap eshell-prompt-mode-map)
+
(defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the prompting code."
(unless eshell-non-interactive-p
@@ -106,13 +117,10 @@ arriving, or after."
(make-local-variable 'eshell-prompt-regexp)
(if eshell-prompt-regexp
- (set (make-local-variable 'paragraph-start) eshell-prompt-regexp))
-
- (set (make-local-variable 'eshell-skip-prompt-function)
- 'eshell-skip-prompt)
+ (setq-local paragraph-start eshell-prompt-regexp))
- (define-key eshell-command-map [(control ?n)] 'eshell-next-prompt)
- (define-key eshell-command-map [(control ?p)] 'eshell-previous-prompt)))
+ (setq-local eshell-skip-prompt-function #'eshell-skip-prompt)
+ (eshell-prompt-mode)))
(defun eshell-emit-prompt ()
"Emit a prompt if eshell is being used interactively."
diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el
index 68353f58492..fa61fffaec8 100644
--- a/lisp/eshell/em-rebind.el
+++ b/lisp/eshell/em-rebind.el
@@ -114,7 +114,6 @@ This is default behavior of shells like bash."
backward-list
forward-page
backward-page
- forward-point
forward-paragraph
backward-paragraph
backward-prefix-chars
@@ -137,6 +136,11 @@ This is default behavior of shells like bash."
:type '(repeat function)
:group 'eshell-rebind)
+(defvar eshell-rebind-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c M-l") #'eshell-lock-local-map)
+ map))
+
;; Internal Variables:
(defvar eshell-input-keymap)
@@ -145,6 +149,12 @@ This is default behavior of shells like bash."
;;; Functions:
+(define-minor-mode eshell-rebind-mode
+ "Minor mode for the eshell-rebind module.
+
+\\{eshell-rebind-mode-map}"
+ :keymap eshell-rebind-mode-map)
+
(defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the inputting code."
(unless eshell-non-interactive-p
@@ -153,8 +163,8 @@ This is default behavior of shells like bash."
(add-hook 'pre-command-hook 'eshell-save-previous-point nil t)
(make-local-variable 'overriding-local-map)
(add-hook 'post-command-hook 'eshell-rebind-input-map nil t)
- (set (make-local-variable 'eshell-lock-keymap) nil)
- (define-key eshell-command-map [(meta ?l)] 'eshell-lock-local-map)))
+ (setq-local eshell-lock-keymap nil)
+ (eshell-rebind-mode)))
(defun eshell-lock-local-map (&optional arg)
"Lock or unlock the current local keymap.
@@ -209,8 +219,7 @@ lock it at that."
(defun eshell-setup-input-keymap ()
"Setup the input keymap to be used during input editing."
- (make-local-variable 'eshell-input-keymap)
- (setq eshell-input-keymap (make-sparse-keymap))
+ (setq-local eshell-input-keymap (make-sparse-keymap))
(set-keymap-parent eshell-input-keymap eshell-mode-map)
(let ((bindings eshell-rebind-keys-alist))
(while bindings
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index 8c864dc114a..1f08e891919 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -58,15 +58,14 @@ This includes when running `eshell-command'."
(defun eshell-script-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the script parsing code."
- (make-local-variable 'eshell-interpreter-alist)
- (setq eshell-interpreter-alist
- (cons (cons #'(lambda (file _args)
- (string= (file-name-nondirectory file)
- "eshell"))
- 'eshell/source)
- eshell-interpreter-alist))
- (make-local-variable 'eshell-complex-commands)
- (setq eshell-complex-commands
+ (setq-local eshell-interpreter-alist
+ (cons (cons (lambda (file _args)
+ (and (file-regular-p file)
+ (string= (file-name-nondirectory file)
+ "eshell")))
+ 'eshell/source)
+ eshell-interpreter-alist))
+ (setq-local eshell-complex-commands
(append '("source" ".") eshell-complex-commands))
;; these two variables are changed through usage, but we don't want
;; to ruin it for other modules
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index 0ff4adb9864..d1c83db188a 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -94,10 +94,9 @@ it to get a real sense of how it works."
(defcustom eshell-smart-unload-hook
(list
- (function
- (lambda ()
- (remove-hook 'window-configuration-change-hook
- 'eshell-refresh-windows))))
+ (lambda ()
+ (remove-hook 'window-configuration-change-hook
+ 'eshell-refresh-windows)))
"A hook that gets run when `eshell-smart' is unloaded."
:type 'hook
:group 'eshell-smart)
@@ -171,9 +170,9 @@ The options are `begin', `after' or `end'."
(unless eshell-non-interactive-p
;; override a few variables, since they would interfere with the
;; smart display functionality.
- (set (make-local-variable 'eshell-scroll-to-bottom-on-output) nil)
- (set (make-local-variable 'eshell-scroll-to-bottom-on-input) nil)
- (set (make-local-variable 'eshell-scroll-show-maximum-output) t)
+ (setq-local eshell-scroll-to-bottom-on-output nil)
+ (setq-local eshell-scroll-to-bottom-on-input nil)
+ (setq-local eshell-scroll-show-maximum-output t)
(add-hook 'window-scroll-functions 'eshell-smart-scroll-window nil t)
(add-hook 'window-configuration-change-hook 'eshell-refresh-windows)
@@ -186,9 +185,8 @@ The options are `begin', `after' or `end'."
(make-local-variable 'eshell-smart-command-done)
(add-hook 'eshell-post-command-hook
- (function
- (lambda ()
- (setq eshell-smart-command-done t)))
+ (lambda ()
+ (setq eshell-smart-command-done t))
t t)
(unless (eq eshell-review-quick-commands t)
@@ -208,13 +206,12 @@ The options are `begin', `after' or `end'."
"Refresh all visible Eshell buffers."
(let (affected)
(walk-windows
- (function
- (lambda (wind)
- (with-current-buffer (window-buffer wind)
- (if eshell-mode
- (let (window-scroll-functions) ;;FIXME: Why?
- (eshell-smart-scroll-window wind (window-start))
- (setq affected t))))))
+ (lambda (wind)
+ (with-current-buffer (window-buffer wind)
+ (if eshell-mode
+ (let (window-scroll-functions) ;;FIXME: Why?
+ (eshell-smart-scroll-window wind (window-start))
+ (setq affected t)))))
0 frame)
(if affected
(let (window-scroll-functions) ;;FIXME: Why?
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index 875fd044b76..d199a939a31 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -143,8 +143,7 @@ behavior for short-lived processes, see bug#18108."
(defun eshell-term-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the `term' interface code."
- (make-local-variable 'eshell-interpreter-alist)
- (setq eshell-interpreter-alist
+ (setq-local eshell-interpreter-alist
(cons (cons #'eshell-visual-command-p
'eshell-exec-visual)
eshell-interpreter-alist)))
@@ -179,9 +178,8 @@ allowed."
(save-current-buffer
(switch-to-buffer term-buf)
(term-mode)
- (set (make-local-variable 'term-term-name) eshell-term-name)
- (make-local-variable 'eshell-parent-buffer)
- (setq eshell-parent-buffer eshell-buf)
+ (setq-local term-term-name eshell-term-name)
+ (setq-local eshell-parent-buffer eshell-buf)
(term-exec term-buf program program nil args)
(let ((proc (get-buffer-process term-buf)))
(if (and proc (eq 'run (process-status proc)))
diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el
index c3943ba644d..e29e9e3e3af 100644
--- a/lisp/eshell/em-tramp.el
+++ b/lisp/eshell/em-tramp.el
@@ -51,10 +51,9 @@
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
'eshell-complete-host-reference nil t))
- (make-local-variable 'eshell-complex-commands)
- (setq eshell-complex-commands
- (append '("su" "sudo")
- eshell-complex-commands)))
+ (setq-local eshell-complex-commands
+ (append '("su" "sudo")
+ eshell-complex-commands)))
(autoload 'eshell-parse-command "esh-cmd")
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index 97dd2d09bdc..7e48a9c7578 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -144,8 +144,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
(when (eshell-using-module 'eshell-cmpl)
(add-hook 'pcomplete-try-first-hook
'eshell-complete-host-reference nil t))
- (make-local-variable 'eshell-complex-commands)
- (setq eshell-complex-commands
+ (setq-local eshell-complex-commands
(append '("grep" "egrep" "fgrep" "agrep" "glimpse" "locate"
"cat" "time" "cp" "mv" "make" "du" "diff")
eshell-complex-commands)))
@@ -170,7 +169,8 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
`info' => goes to top info window
`info arg1' => IF arg1 is a file, then visits arg1
`info arg1' => OTHERWISE goes to top info window and then menu item arg1
- `info arg1 arg2' => does action for arg1 (either visit-file or menu-item) and then menu item arg2
+ `info arg1 arg2' => does action for arg1 (either visit-file or menu-item) and
+ then menu item arg2
etc."
(eval-and-compile (require 'info))
(let ((file (cond
@@ -419,9 +419,8 @@ Remove the DIRECTORY(ies), if they are empty.")
(apply 'eshell-shuffle-files
command action
(mapcar
- (function
- (lambda (file)
- (concat source "/" file)))
+ (lambda (file)
+ (concat source "/" file))
(directory-files source))
target func t args)
(when (eq func 'rename-file)
@@ -439,7 +438,10 @@ Remove the DIRECTORY(ies), if they are empty.")
(setq link (file-symlink-p source)))
(progn
(apply 'eshell-funcalln 'make-symbolic-link
- link target args)
+ link target
+ ;; `make-symbolic-link' doesn't have
+ ;; KEEP-TIME; just OK-IF-ALREADY-EXISTS.
+ (list (car args)))
(if (eq func 'rename-file)
(if (and (file-directory-p source)
(not (file-symlink-p source)))
@@ -469,8 +471,6 @@ Remove the DIRECTORY(ies), if they are empty.")
(eshell-parse-command
(format "tar %s %s" tar-args archive) args))))
-(defvar ange-cache) ; XEmacs? See esh-util
-
;; this is to avoid duplicating code...
(defmacro eshell-mvcpln-template (command action func query-var
force-var &optional preserve)
@@ -488,8 +488,7 @@ Remove the DIRECTORY(ies), if they are empty.")
(or (not no-dereference)
(not (file-symlink-p (car args)))))))
(eshell-shorthand-tar-command ,command args)
- (let ((target (car (last args)))
- ange-cache)
+ (let ((target (car (last args))))
(setcdr (last args 2) nil)
(eshell-shuffle-files
,command ,action args target ,func nil
@@ -755,15 +754,12 @@ external command."
(eshell-stringify-list
(flatten-tree args)))
" "))
- (cmd (progn
- (set-text-properties 0 (length args)
- '(invisible t) args)
- (format "%s -n %s"
- (pcase command
- ("egrep" "grep -E")
- ("fgrep" "grep -F")
- (x x))
- args)))
+ (cmd (format "%s -nH %s"
+ (pcase command
+ ("egrep" "grep -E")
+ ("fgrep" "grep -F")
+ (x x))
+ args))
compilation-scroll-output)
(grep cmd)))))
@@ -790,9 +786,9 @@ external command."
;; completions rules for some common UNIX commands
-(defsubst eshell-complete-hostname ()
- "Complete a command that wants a hostname for an argument."
- (pcomplete-here (eshell-read-host-names)))
+(autoload 'pcmpl-unix-complete-hostname "pcmpl-unix")
+(define-obsolete-function-alias 'eshell-complete-hostname
+ #'pcmpl-unix-complete-hostname "28.1")
(defun eshell-complete-host-reference ()
"If there is a host reference, complete it."
@@ -801,26 +797,7 @@ external command."
(when (setq index (string-match "@[a-z.]*\\'" arg))
(setq pcomplete-stub (substring arg (1+ index))
pcomplete-last-completion-raw t)
- (throw 'pcomplete-completions (eshell-read-host-names)))))
-
-(defalias 'pcomplete/ftp 'eshell-complete-hostname)
-(defalias 'pcomplete/ncftp 'eshell-complete-hostname)
-(defalias 'pcomplete/ping 'eshell-complete-hostname)
-(defalias 'pcomplete/rlogin 'eshell-complete-hostname)
-
-(defun pcomplete/telnet ()
- (require 'pcmpl-unix)
- (pcomplete-opt "xl(pcmpl-unix-user-names)")
- (eshell-complete-hostname))
-
-(defun pcomplete/rsh ()
- "Complete `rsh', which, after the user and hostname, is like xargs."
- (require 'pcmpl-unix)
- (pcomplete-opt "l(pcmpl-unix-user-names)")
- (eshell-complete-hostname)
- (pcomplete-here (funcall pcomplete-command-completion-function))
- (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1))
- pcomplete-default-completion-function)))
+ (throw 'pcomplete-completions (pcomplete-read-host-names)))))
(defvar block-size)
(defvar by-bytes)
@@ -924,7 +901,7 @@ Summarize disk usage of each FILE, recursively for directories.")
;; filesystem support means nothing under Windows
(if (eshell-under-windows-p)
(setq only-one-filesystem nil))
- (let ((size 0.0) ange-cache)
+ (let ((size 0.0))
(while args
(if only-one-filesystem
(setq only-one-filesystem
@@ -1026,18 +1003,17 @@ Show wall-clock time elapsed during execution of COMMAND.")
(throw 'eshell-replace-command
(eshell-parse-command "*diff" orig-args))))
(when (fboundp 'diff-mode)
- (make-local-variable 'compilation-finish-functions)
(add-hook
'compilation-finish-functions
- `(lambda (buff msg)
+ (lambda (buff _msg)
(with-current-buffer buff
(diff-mode)
- (set (make-local-variable 'eshell-diff-window-config)
- ,config)
- (local-set-key [?q] 'eshell-diff-quit)
+ (setq-local eshell-diff-window-config config)
+ (local-set-key [?q] #'eshell-diff-quit)
(if (fboundp 'turn-on-font-lock-if-enabled)
(turn-on-font-lock-if-enabled))
- (goto-char (point-min))))))
+ (goto-char (point-min))))
+ nil t))
(pop-to-buffer (current-buffer))))))
nil)
diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el
index 0faa42ee4c2..f58e1b85cbd 100644
--- a/lisp/eshell/em-xtra.el
+++ b/lisp/eshell/em-xtra.el
@@ -23,13 +23,10 @@
;;; Code:
+(require 'cl-lib)
(require 'esh-util)
(eval-when-compile
(require 'eshell))
-;; Strictly speaking, should only be needed at compile time.
-;; Require at run-time too to silence compiler.
-(require 'pcomplete)
-(require 'compile)
;; There are no items in this custom group, but eshell modules (ab)use
;; custom groups.
@@ -49,80 +46,45 @@ naturally accessible within Emacs."
(defun eshell/expr (&rest args)
"Implementation of expr, using the calc package."
- (if (not (fboundp 'calc-eval))
- (throw 'eshell-replace-command
- (eshell-parse-command "*expr" (flatten-tree args)))
- ;; to fool the byte-compiler...
- (let ((func 'calc-eval))
- (funcall func (eshell-flatten-and-stringify args)))))
+ (calc-eval (eshell-flatten-and-stringify args)))
(defun eshell/substitute (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'substitute (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-substitute', for comparing lists of strings."
+ (apply #'cl-substitute (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/count (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'count (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-count', for comparing lists of strings."
+ (apply #'cl-count (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/mismatch (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'mismatch (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-mismatch', for comparing lists of strings."
+ (apply #'cl-mismatch (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/union (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'union (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-union', for comparing lists of strings."
+ (apply #'cl-union (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/intersection (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'intersection (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-intersection', for comparing lists of strings."
+ (apply #'cl-intersection (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/set-difference (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'set-difference (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-set-difference', for comparing lists of strings."
+ (apply #'cl-set-difference (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/set-exclusive-or (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'set-exclusive-or (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-set-exclusive-or', for comparing lists of strings."
+ (apply #'cl-set-exclusive-or (car args) (cadr args) :test #'equal
(cddr args)))
-(defalias 'eshell/ff 'find-name-dired)
-(defalias 'eshell/gf 'find-grep-dired)
-
-(defun pcomplete/bcc32 ()
- "Completion function for Borland's C++ compiler."
- (let ((cur (pcomplete-arg 0)))
- (cond
- ((string-match "\\`-w\\([^;]+;\\)*\\([^;]*\\)\\'" cur)
- (pcomplete-here
- '("ali" "amb" "amp" "asc" "asm" "aus" "bbf" "bei" "big" "ccc"
- "cln" "cod" "com" "cpt" "csu" "def" "dig" "dpu" "dsz" "dup"
- "eas" "eff" "ext" "hch" "hid" "ias" "ibc" "ifr" "ill" "nil"
- "lin" "lvc" "mcs" "mes" "mpc" "mpd" "msg" "nak" "ncf" "nci"
- "ncl" "nfd" "ngu" "nin" "nma" "nmu" "nod" "nop" "npp" "nsf"
- "nst" "ntd" "nto" "nvf" "obi" "obs" "ofp" "osh" "ovf" "par"
- "pch" "pck" "pia" "pin" "pow" "prc" "pre" "pro" "rch" "ret"
- "rng" "rpt" "rvl" "sig" "spa" "stl" "stu" "stv" "sus" "tai"
- "tes" "thr" "ucp" "use" "voi" "zdi") (match-string 2 cur)))
- ((string-match "\\`-[LIn]\\([^;]+;\\)*\\([^;]*\\)\\'" cur)
- (pcomplete-here (pcomplete-dirs) (match-string 2 cur)))
- ((string-match "\\`-[Ee]\\(.*\\)\\'" cur)
- (pcomplete-here (pcomplete-dirs-or-entries "\\.[Ee][Xx][Ee]\\'")
- (match-string 1 cur)))
- ((string-match "\\`-o\\(.*\\)\\'" cur)
- (pcomplete-here (pcomplete-dirs-or-entries "\\.[Oo][Bb][Jj]\\'")
- (match-string 1 cur)))
- (t
- (pcomplete-opt "3456ABCDEHIKLMNOPRSTUVXabcdefgijklnoptuvwxyz"))))
- (while (pcomplete-here
- (pcomplete-dirs-or-entries "\\.[iCc]\\([Pp][Pp]\\)?\\'"))))
-
-(defalias 'pcomplete/bcc 'pcomplete/bcc32)
+(defalias 'eshell/ff #'find-name-dired)
+(defalias 'eshell/gf #'find-grep-dired)
(provide 'em-xtra)
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index a509d300578..3cf80e45187 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -85,51 +85,48 @@ If POS is nil, the location of point is checked."
'eshell-parse-special-reference
;; numbers convert to numbers if they stand alone
- (function
- (lambda ()
- (when (and (not eshell-current-argument)
- (not eshell-current-quoted)
- (looking-at eshell-number-regexp)
- (eshell-arg-delimiter (match-end 0)))
- (goto-char (match-end 0))
- (let ((str (match-string 0)))
- (if (> (length str) 0)
- (add-text-properties 0 (length str) '(number t) str))
- str))))
+ (lambda ()
+ (when (and (not eshell-current-argument)
+ (not eshell-current-quoted)
+ (looking-at eshell-number-regexp)
+ (eshell-arg-delimiter (match-end 0)))
+ (goto-char (match-end 0))
+ (let ((str (match-string 0)))
+ (if (> (length str) 0)
+ (add-text-properties 0 (length str) '(number t) str))
+ str)))
;; parse any non-special characters, based on the current context
- (function
- (lambda ()
- (unless eshell-inside-quote-regexp
- (setq eshell-inside-quote-regexp
- (format "[^%s]+"
- (apply 'string eshell-special-chars-inside-quoting))))
- (unless eshell-outside-quote-regexp
- (setq eshell-outside-quote-regexp
- (format "[^%s]+"
- (apply 'string eshell-special-chars-outside-quoting))))
- (when (looking-at (if eshell-current-quoted
- eshell-inside-quote-regexp
- eshell-outside-quote-regexp))
- (goto-char (match-end 0))
- (let ((str (match-string 0)))
- (if str
- (set-text-properties 0 (length str) nil str))
- str))))
+ (lambda ()
+ (unless eshell-inside-quote-regexp
+ (setq eshell-inside-quote-regexp
+ (format "[^%s]+"
+ (apply 'string eshell-special-chars-inside-quoting))))
+ (unless eshell-outside-quote-regexp
+ (setq eshell-outside-quote-regexp
+ (format "[^%s]+"
+ (apply 'string eshell-special-chars-outside-quoting))))
+ (when (looking-at (if eshell-current-quoted
+ eshell-inside-quote-regexp
+ eshell-outside-quote-regexp))
+ (goto-char (match-end 0))
+ (let ((str (match-string 0)))
+ (if str
+ (set-text-properties 0 (length str) nil str))
+ str)))
;; whitespace or a comment is an argument delimiter
- (function
- (lambda ()
- (let (comment-p)
- (when (or (looking-at "[ \t]+")
- (and (not eshell-current-argument)
- (looking-at "#\\([^<'].*\\|$\\)")
- (setq comment-p t)))
- (if comment-p
- (add-text-properties (match-beginning 0) (match-end 0)
- '(comment t)))
- (goto-char (match-end 0))
- (eshell-finish-arg)))))
+ (lambda ()
+ (let (comment-p)
+ (when (or (looking-at "[ \t]+")
+ (and (not eshell-current-argument)
+ (looking-at "#\\([^<'].*\\|$\\)")
+ (setq comment-p t)))
+ (if comment-p
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(comment t)))
+ (goto-char (match-end 0))
+ (eshell-finish-arg))))
;; parse backslash and the character after
'eshell-parse-backslash
@@ -155,16 +152,24 @@ treated as a literal character."
:type 'hook
:group 'eshell-arg)
+(defvar eshell-arg-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name)
+ map))
+
;;; Functions:
+(define-minor-mode eshell-arg-mode
+ "Minor mode for the arg eshell module.
+
+\\{eshell-arg-mode-map}"
+ :keymap eshell-arg-mode-map)
+
(defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the argument parsing code."
- ;; This is supposedly run after enabling esh-mode, when eshell-mode-map
- ;; already exists.
- (defvar eshell-command-map)
- (define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name)
- (set (make-local-variable 'eshell-inside-quote-regexp) nil)
- (set (make-local-variable 'eshell-outside-quote-regexp) nil))
+ (eshell-arg-mode)
+ (setq-local eshell-inside-quote-regexp nil)
+ (setq-local eshell-outside-quote-regexp nil))
(defun eshell-insert-buffer-name (buffer-name)
"Insert BUFFER-NAME into the current buffer at point."
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index d6a26674e4a..daca035ea49 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -290,12 +290,12 @@ otherwise t.")
(defun eshell-cmd-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the Eshell command processing module."
- (set (make-local-variable 'eshell-current-command) nil)
- (set (make-local-variable 'eshell-command-name) nil)
- (set (make-local-variable 'eshell-command-arguments) nil)
- (set (make-local-variable 'eshell-last-arguments) nil)
- (set (make-local-variable 'eshell-last-command-name) nil)
- (set (make-local-variable 'eshell-last-async-proc) nil)
+ (setq-local eshell-current-command nil)
+ (setq-local eshell-command-name nil)
+ (setq-local eshell-command-arguments nil)
+ (setq-local eshell-last-arguments nil)
+ (setq-local eshell-last-command-name nil)
+ (setq-local eshell-last-async-proc nil)
(add-hook 'eshell-kill-hook #'eshell-resume-command nil t)
@@ -304,10 +304,9 @@ otherwise t.")
;; situation can occur, for example, if a Lisp function results in
;; `debug' being called, and the user then types \\[top-level]
(add-hook 'eshell-post-command-hook
- (function
- (lambda ()
- (setq eshell-current-command nil
- eshell-last-async-proc nil)))
+ (lambda ()
+ (setq eshell-current-command nil
+ eshell-last-async-proc nil))
nil t)
(add-hook 'eshell-parse-argument-hook
@@ -355,18 +354,17 @@ hooks should be run before and after the command."
args))
(commands
(mapcar
- (function
- (lambda (cmd)
- (setq cmd
- (if (or (not (car eshell--sep-terms))
- (string= (car eshell--sep-terms) ";"))
- (eshell-parse-pipeline cmd)
- `(eshell-do-subjob
- (list ,(eshell-parse-pipeline cmd)))))
- (setq eshell--sep-terms (cdr eshell--sep-terms))
- (if eshell-in-pipeline-p
- cmd
- `(eshell-trap-errors ,cmd))))
+ (lambda (cmd)
+ (setq cmd
+ (if (or (not (car eshell--sep-terms))
+ (string= (car eshell--sep-terms) ";"))
+ (eshell-parse-pipeline cmd)
+ `(eshell-do-subjob
+ (list ,(eshell-parse-pipeline cmd)))))
+ (setq eshell--sep-terms (cdr eshell--sep-terms))
+ (if eshell-in-pipeline-p
+ cmd
+ `(eshell-trap-errors ,cmd)))
(eshell-separate-commands terms "[&;]" nil 'eshell--sep-terms))))
(let ((cmd commands))
(while cmd
@@ -920,7 +918,7 @@ at the moment are:
(funcall pred name))
(throw 'simple nil)))
t))
- (fboundp (intern-soft (concat "eshell/" name))))))
+ (eshell-find-alias-function name))))
(defun eshell-eval-command (command &optional input)
"Evaluate the given COMMAND iteratively."
@@ -1003,7 +1001,7 @@ be finished later after the completion of an asynchronous subprocess."
;; expand any macros directly into the form. This is done so that
;; we can modify any `let' forms to evaluate only once.
(if (macrop (car form))
- (let ((exp (eshell-copy-tree (macroexpand form))))
+ (let ((exp (copy-tree (macroexpand form))))
(eshell-manipulate (format-message "expanding macro `%s'"
(symbol-name (car form)))
(setcar form (car exp))
@@ -1011,7 +1009,7 @@ be finished later after the completion of an asynchronous subprocess."
(let ((args (cdr form)))
(cond
((eq (car form) 'while)
- ;; `eshell-copy-tree' is needed here so that the test argument
+ ;; `copy-tree' is needed here so that the test argument
;; doesn't get modified and thus always yield the same result.
(when (car eshell-command-body)
(cl-assert (not synchronous-p))
@@ -1019,27 +1017,27 @@ be finished later after the completion of an asynchronous subprocess."
(setcar eshell-command-body nil)
(setcar eshell-test-body nil))
(unless (car eshell-test-body)
- (setcar eshell-test-body (eshell-copy-tree (car args))))
+ (setcar eshell-test-body (copy-tree (car args))))
(while (cadr (eshell-do-eval (car eshell-test-body)))
(setcar eshell-command-body
(if (cddr args)
- `(progn ,@(eshell-copy-tree (cdr args)))
- (eshell-copy-tree (cadr args))))
+ `(progn ,@(copy-tree (cdr args)))
+ (copy-tree (cadr args))))
(eshell-do-eval (car eshell-command-body) synchronous-p)
(setcar eshell-command-body nil)
- (setcar eshell-test-body (eshell-copy-tree (car args))))
+ (setcar eshell-test-body (copy-tree (car args))))
(setcar eshell-command-body nil))
((eq (car form) 'if)
- ;; `eshell-copy-tree' is needed here so that the test argument
+ ;; `copy-tree' is needed here so that the test argument
;; doesn't get modified and thus always yield the same result.
(if (car eshell-command-body)
(progn
(cl-assert (not synchronous-p))
(eshell-do-eval (car eshell-command-body)))
(unless (car eshell-test-body)
- (setcar eshell-test-body (eshell-copy-tree (car args))))
+ (setcar eshell-test-body (copy-tree (car args))))
(setcar eshell-command-body
- (eshell-copy-tree
+ (copy-tree
(if (cadr (eshell-do-eval (car eshell-test-body)))
(cadr args)
(car (cddr args)))))
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index ea12d7e7ac5..0e98aa0049e 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -344,8 +344,8 @@ it defaults to `insert'."
(if buffer-file-read-only
(error "Cannot write to read-only file `%s'" target))
(setq buffer-read-only nil)
- (set (make-local-variable 'eshell-output-file-buffer)
- (if (eq exists buf) 0 t))
+ (setq-local eshell-output-file-buffer
+ (if (eq exists buf) 0 t))
(cond ((eq mode 'overwrite)
(erase-buffer))
((eq mode 'append)
@@ -382,13 +382,7 @@ it defaults to `insert'."
"Set handle INDEX, using MODE, to point to TARGET."
(when target
(if (and (stringp target)
- (or (cond
- ((boundp 'null-device)
- (string= target null-device))
- ((boundp 'grep-null-device)
- (string= target grep-null-device))
- (t nil))
- (string= target "/dev/null")))
+ (string= target (null-device)))
(aset eshell-current-handles index nil)
(let ((where (eshell-get-target target mode))
(current (car (aref eshell-current-handles index))))
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index 04b7a02a187..f9dbce9770d 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -72,51 +72,43 @@
(defcustom eshell-mode-unload-hook nil
"A hook that gets run when `eshell-mode' is unloaded."
- :type 'hook
- :group 'eshell-mode)
+ :type 'hook)
(defcustom eshell-mode-hook nil
"A hook that gets run when `eshell-mode' is entered."
- :type 'hook
- :group 'eshell-mode)
+ :type 'hook)
(defcustom eshell-first-time-mode-hook nil
"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)
+ :type 'hook)
(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)
+ :type 'hook)
(defcustom eshell-kill-on-exit t
"If non-nil, kill the Eshell buffer on the `exit' command.
Otherwise, the buffer will simply be buried."
- :type 'boolean
- :group 'eshell-mode)
+ :type 'boolean)
(defcustom eshell-input-filter-functions nil
"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)
+ :type 'hook)
(defcustom eshell-send-direct-to-subprocesses nil
"If t, send any input immediately to a subprocess."
- :type 'boolean
- :group 'eshell-mode)
+ :type 'boolean)
(defcustom eshell-expand-input-functions nil
"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)
+ :type 'hook)
(defcustom eshell-scroll-to-bottom-on-input nil
"Controls whether input to interpreter causes window to scroll.
@@ -126,8 +118,7 @@ buffer. If `this', scroll only the selected window.
See `eshell-preinput-scroll-to-bottom'."
:type '(radio (const :tag "Do not scroll Eshell windows" nil)
(const :tag "Scroll all windows showing the buffer" all)
- (const :tag "Scroll only the selected window" this))
- :group 'eshell-mode)
+ (const :tag "Scroll only the selected window" this)))
(defcustom eshell-scroll-to-bottom-on-output nil
"Controls whether interpreter output causes window to scroll.
@@ -140,8 +131,7 @@ See variable `eshell-scroll-show-maximum-output' and function
:type '(radio (const :tag "Do not scroll Eshell windows" nil)
(const :tag "Scroll all windows showing the buffer" all)
(const :tag "Scroll only the selected window" this)
- (const :tag "Scroll all windows other than selected" others))
- :group 'eshell-mode)
+ (const :tag "Scroll all windows other than selected" others)))
(defcustom eshell-scroll-show-maximum-output t
"Controls how interpreter output causes window to scroll.
@@ -149,16 +139,14 @@ If non-nil, then show the maximum output when the window is scrolled.
See variable `eshell-scroll-to-bottom-on-output' and function
`eshell-postoutput-scroll-to-bottom'."
- :type 'boolean
- :group 'eshell-mode)
+ :type 'boolean)
(defcustom eshell-buffer-maximum-lines 1024
"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'."
- :type 'integer
- :group 'eshell-mode)
+ :type 'integer)
(defcustom eshell-output-filter-functions
'(eshell-postoutput-scroll-to-bottom
@@ -168,36 +156,31 @@ number, if the function `eshell-truncate-buffer' is on
"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)
+ :type 'hook)
(defcustom eshell-preoutput-filter-functions nil
"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
- :group 'eshell-mode)
+ :type 'hook)
(defcustom eshell-password-prompt-regexp
(format "\\(%s\\)[^::៖]*[::៖]\\s *\\'" (regexp-opt password-word-equivalents))
"Regexp matching prompts for passwords in the inferior process.
This is used by `eshell-watch-for-password-prompt'."
:type 'regexp
- :version "27.1"
- :group 'eshell-mode)
+ :version "27.1")
(defcustom eshell-skip-prompt-function nil
"A function called from beginning of line to skip the prompt."
- :type '(choice (const nil) function)
- :group 'eshell-mode)
+ :type '(choice (const nil) function))
(define-obsolete-variable-alias 'eshell-status-in-modeline
'eshell-status-in-mode-line "24.3")
(defcustom eshell-status-in-mode-line t
"If non-nil, let the user know a command is running in the mode line."
- :type 'boolean
- :group 'eshell-mode)
+ :type 'boolean)
(defcustom eshell-directory-name
(locate-user-emacs-file "eshell/" ".eshell/")
@@ -213,10 +196,7 @@ This is used by `eshell-watch-for-password-prompt'."
;; these are only set to nil initially for the sake of the
;; byte-compiler, when compiling other files which `require' this one
(defvar eshell-mode nil)
-(defvar eshell-mode-map nil)
(defvar eshell-command-running-string "--")
-(defvar eshell-command-map nil)
-(defvar eshell-command-prefix nil)
(defvar eshell-last-input-start nil)
(defvar eshell-last-input-end nil)
(defvar eshell-last-output-start nil)
@@ -280,6 +260,32 @@ This is used by `eshell-watch-for-password-prompt'."
(standard-syntax-table))
st))
+(defvar eshell-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [(control ?c)] 'eshell-command-map)
+ (define-key map "\r" #'eshell-send-input)
+ (define-key map "\M-\r" #'eshell-queue-input)
+ (define-key map [(meta control ?l)] #'eshell-show-output)
+ (define-key map [(control ?a)] #'eshell-bol)
+ map))
+
+(defvar eshell-command-map
+ (let ((map (define-prefix-command 'eshell-command-map)))
+ (define-key map [(meta ?o)] #'eshell-mark-output)
+ (define-key map [(meta ?d)] #'eshell-toggle-direct-send)
+ (define-key map [(control ?a)] #'eshell-bol)
+ (define-key map [(control ?b)] #'eshell-backward-argument)
+ (define-key map [(control ?e)] #'eshell-show-maximum-output)
+ (define-key map [(control ?f)] #'eshell-forward-argument)
+ (define-key map [(control ?m)] #'eshell-copy-old-input)
+ (define-key map [(control ?o)] #'eshell-kill-output)
+ (define-key map [(control ?r)] #'eshell-show-output)
+ (define-key map [(control ?t)] #'eshell-truncate-buffer)
+ (define-key map [(control ?u)] #'eshell-kill-input)
+ (define-key map [(control ?w)] #'backward-kill-word)
+ (define-key map [(control ?y)] #'eshell-repeat-argument)
+ map))
+
;;; User Functions:
(defun eshell-kill-buffer-function ()
@@ -298,10 +304,6 @@ and the hook `eshell-exit-hook'."
"Emacs shell interactive mode."
(setq-local eshell-mode t)
- ;; FIXME: What the hell!?
- (setq-local eshell-mode-map (make-sparse-keymap))
- (use-local-map eshell-mode-map)
-
(when eshell-status-in-mode-line
(make-local-variable 'eshell-command-running-string)
(let ((fmt (copy-sequence mode-line-format)))
@@ -310,68 +312,38 @@ and the hook `eshell-exit-hook'."
(if mode-line-elt
(setcar mode-line-elt 'eshell-command-running-string))))
- (define-key eshell-mode-map "\r" 'eshell-send-input)
- (define-key eshell-mode-map "\M-\r" 'eshell-queue-input)
- (define-key eshell-mode-map [(meta control ?l)] 'eshell-show-output)
- (define-key eshell-mode-map [(control ?a)] 'eshell-bol)
-
- (setq-local eshell-command-prefix (make-symbol "eshell-command-prefix"))
- (fset eshell-command-prefix (make-sparse-keymap))
- (setq-local eshell-command-map (symbol-function eshell-command-prefix))
- (define-key eshell-mode-map [(control ?c)] eshell-command-prefix)
-
- (define-key eshell-command-map [(meta ?o)] 'eshell-mark-output)
- (define-key eshell-command-map [(meta ?d)] 'eshell-toggle-direct-send)
-
- (define-key eshell-command-map [(control ?a)] 'eshell-bol)
- (define-key eshell-command-map [(control ?b)] 'eshell-backward-argument)
- (define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output)
- (define-key eshell-command-map [(control ?f)] 'eshell-forward-argument)
- (define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input)
- (define-key eshell-command-map [(control ?o)] 'eshell-kill-output)
- (define-key eshell-command-map [(control ?r)] 'eshell-show-output)
- (define-key eshell-command-map [(control ?t)] 'eshell-truncate-buffer)
- (define-key eshell-command-map [(control ?u)] 'eshell-kill-input)
- (define-key eshell-command-map [(control ?w)] 'backward-kill-word)
- (define-key eshell-command-map [(control ?y)] 'eshell-repeat-argument)
-
+ (setq-local bookmark-make-record-function #'eshell-bookmark-make-record)
(setq local-abbrev-table eshell-mode-abbrev-table)
- (set (make-local-variable 'list-buffers-directory)
- (expand-file-name default-directory))
+ (setq-local list-buffers-directory (expand-file-name default-directory))
;; always set the tab width to 8 in Eshell buffers, since external
;; commands which do their own formatting almost always expect this
- (set (make-local-variable 'tab-width) 8)
+ (setq-local tab-width 8)
;; don't ever use auto-fill in Eshell buffers
(setq auto-fill-function nil)
;; always display everything from a return value
- (if (boundp 'print-length)
- (set (make-local-variable 'print-length) nil))
- (if (boundp 'print-level)
- (set (make-local-variable 'print-level) nil))
+ (setq-local print-length nil)
+ (setq-local print-level nil)
;; set require-final-newline to nil; otherwise, all redirected
;; output will end with a newline, whether or not the source
;; indicated it!
- (set (make-local-variable 'require-final-newline) nil)
+ (setq-local require-final-newline nil)
- (set (make-local-variable 'max-lisp-eval-depth)
- (max 3000 max-lisp-eval-depth))
- (set (make-local-variable 'max-specpdl-size)
- (max 6000 max-lisp-eval-depth))
+ (setq-local max-lisp-eval-depth (max 3000 max-lisp-eval-depth))
+ (setq-local max-specpdl-size (max 6000 max-lisp-eval-depth))
- (set (make-local-variable 'eshell-last-input-start) (point-marker))
- (set (make-local-variable 'eshell-last-input-end) (point-marker))
- (set (make-local-variable 'eshell-last-output-start) (point-marker))
- (set (make-local-variable 'eshell-last-output-end) (point-marker))
- (set (make-local-variable 'eshell-last-output-block-begin) (point))
+ (setq-local eshell-last-input-start (point-marker))
+ (setq-local eshell-last-input-end (point-marker))
+ (setq-local eshell-last-output-start (point-marker))
+ (setq-local eshell-last-output-end (point-marker))
+ (setq-local eshell-last-output-block-begin (point))
(let ((modules-list (copy-sequence eshell-modules-list)))
- (make-local-variable 'eshell-modules-list)
- (setq eshell-modules-list modules-list))
+ (setq-local eshell-modules-list modules-list))
;; This is to avoid making the paragraph base direction
;; right-to-left if the first word just happens to start with a
@@ -412,7 +384,7 @@ and the hook `eshell-exit-hook'."
(add-hook 'pre-command-hook #'eshell-preinput-scroll-to-bottom t t))
(when eshell-scroll-show-maximum-output
- (set (make-local-variable 'scroll-conservatively) 1000))
+ (setq-local scroll-conservatively 1000))
(when eshell-status-in-mode-line
(add-hook 'eshell-pre-command-hook #'eshell-command-started nil t)
@@ -486,7 +458,7 @@ and the hook `eshell-exit-hook'."
(let ((inhibit-read-only t)
(no-default (eobp))
(find-tag-default-function 'ignore))
- (setq tagname (car (find-tag-interactive "Find tag: " no-default)))
+ (setq tagname (car (find-tag-interactive "Find tag" no-default)))
(with-suppressed-warnings ((obsolete find-tag))
(find-tag tagname next-p regexp-p))))
@@ -696,46 +668,47 @@ newline."
"Send the output from PROCESS (STRING) to the interactive display.
This is done after all necessary filtering has been done."
(let ((oprocbuf (if process (process-buffer process)
- (current-buffer)))
- (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t))
- (let ((functions eshell-preoutput-filter-functions))
- (while (and functions string)
- (setq string (funcall (car functions) string))
- (setq functions (cdr functions))))
- (if (and string oprocbuf (buffer-name oprocbuf))
- (let (opoint obeg oend)
- (with-current-buffer oprocbuf
- (setq opoint (point))
- (setq obeg (point-min))
- (setq oend (point-max))
- (let ((buffer-read-only nil)
- (nchars (length string))
- (ostart nil))
- (widen)
- (goto-char eshell-last-output-end)
- (setq ostart (point))
- (if (<= (point) opoint)
- (setq opoint (+ opoint nchars)))
- (if (< (point) obeg)
- (setq obeg (+ obeg nchars)))
- (if (<= (point) oend)
- (setq oend (+ oend nchars)))
+ (current-buffer)))
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t))
+ (when (and string oprocbuf (buffer-name oprocbuf))
+ (with-current-buffer oprocbuf
+ (let ((functions eshell-preoutput-filter-functions))
+ (while (and functions string)
+ (setq string (funcall (car functions) string))
+ (setq functions (cdr functions))))
+ (when string
+ (let (opoint obeg oend)
+ (setq opoint (point))
+ (setq obeg (point-min))
+ (setq oend (point-max))
+ (let ((buffer-read-only nil)
+ (nchars (length string))
+ (ostart nil))
+ (widen)
+ (goto-char eshell-last-output-end)
+ (setq ostart (point))
+ (if (<= (point) opoint)
+ (setq opoint (+ opoint nchars)))
+ (if (< (point) obeg)
+ (setq obeg (+ obeg nchars)))
+ (if (<= (point) oend)
+ (setq oend (+ oend nchars)))
;; Let the ansi-color overlay hooks run.
(let ((inhibit-modification-hooks nil))
(insert-before-markers string))
- (if (= (window-start) (point))
- (set-window-start (selected-window)
- (- (point) nchars)))
- (if (= (point) eshell-last-input-end)
- (set-marker eshell-last-input-end
- (- eshell-last-input-end nchars)))
- (set-marker eshell-last-output-start ostart)
- (set-marker eshell-last-output-end (point))
- (force-mode-line-update))
- (narrow-to-region obeg oend)
- (goto-char opoint)
- (eshell-run-output-filters))))))
+ (if (= (window-start) (point))
+ (set-window-start (selected-window)
+ (- (point) nchars)))
+ (if (= (point) eshell-last-input-end)
+ (set-marker eshell-last-input-end
+ (- eshell-last-input-end nchars)))
+ (set-marker eshell-last-output-start ostart)
+ (set-marker eshell-last-output-end (point))
+ (force-mode-line-update))
+ (narrow-to-region obeg oend)
+ (goto-char opoint)
+ (eshell-run-output-filters)))))))
(defun eshell-run-output-filters ()
"Run the `eshell-output-filter-functions' on the current output."
@@ -762,13 +735,12 @@ This function should be a pre-command hook."
(if (eq scroll 'this)
(goto-char (point-max))
(walk-windows
- (function
- (lambda (window)
- (when (and (eq (window-buffer window) current)
- (or (eq scroll t) (eq scroll 'all)))
- (select-window window)
- (goto-char (point-max))
- (select-window selected))))
+ (lambda (window)
+ (when (and (eq (window-buffer window) current)
+ (or (eq scroll t) (eq scroll 'all)))
+ (select-window window)
+ (goto-char (point-max))
+ (select-window selected)))
nil t))))))
;;; jww (1999-10-23): this needs testing
@@ -784,29 +756,28 @@ This function should be in the list `eshell-output-filter-functions'."
(scroll eshell-scroll-to-bottom-on-output))
(unwind-protect
(walk-windows
- (function
- (lambda (window)
- (if (eq (window-buffer window) current)
- (progn
- (select-window window)
- (if (and (< (point) eshell-last-output-end)
- (or (eq scroll t) (eq scroll 'all)
- ;; Maybe user wants point to jump to end.
- (and (eq scroll 'this)
- (eq selected window))
- (and (eq scroll 'others)
- (not (eq selected window)))
- ;; If point was at the end, keep it at end.
- (>= (point) eshell-last-output-start)))
- (goto-char eshell-last-output-end))
- ;; Optionally scroll so that the text
- ;; ends at the bottom of the window.
- (if (and eshell-scroll-show-maximum-output
- (>= (point) eshell-last-output-end))
- (save-excursion
- (goto-char (point-max))
- (recenter -1)))
- (select-window selected)))))
+ (lambda (window)
+ (if (eq (window-buffer window) current)
+ (progn
+ (select-window window)
+ (if (and (< (point) eshell-last-output-end)
+ (or (eq scroll t) (eq scroll 'all)
+ ;; Maybe user wants point to jump to end.
+ (and (eq scroll 'this)
+ (eq selected window))
+ (and (eq scroll 'others)
+ (not (eq selected window)))
+ ;; If point was at the end, keep it at end.
+ (>= (point) eshell-last-output-start)))
+ (goto-char eshell-last-output-end))
+ ;; Optionally scroll so that the text
+ ;; ends at the bottom of the window.
+ (if (and eshell-scroll-show-maximum-output
+ (>= (point) eshell-last-output-end))
+ (save-excursion
+ (goto-char (point-max))
+ (recenter -1)))
+ (select-window selected))))
nil t)
(set-buffer current))))
@@ -1020,5 +991,29 @@ This function could be in the list `eshell-output-filter-functions'."
(custom-add-option 'eshell-output-filter-functions
'eshell-handle-ansi-color)
+;;; Bookmark support:
+
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+
+(defun eshell-bookmark-name ()
+ (format "eshell-%s"
+ (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory default-directory)))))
+
+(defun eshell-bookmark-make-record ()
+ "Create a bookmark for the current Eshell buffer."
+ `(,(eshell-bookmark-name)
+ (location . ,default-directory)
+ (handler . eshell-bookmark-jump)))
+
+;;;###autoload
+(defun eshell-bookmark-jump (bookmark)
+ "Default bookmark handler for Eshell buffers."
+ (let ((default-directory (bookmark-prop-get bookmark 'location)))
+ (eshell)))
+
(provide 'esh-mode)
;;; esh-mode.el ends here
diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el
index ca141515bf5..703179504c1 100644
--- a/lisp/eshell/esh-module.el
+++ b/lisp/eshell/esh-module.el
@@ -65,16 +65,15 @@ Changes will only take effect in future Eshell buffers."
:type (append
(list 'set ':tag "Supported modules")
(mapcar
- (function
- (lambda (modname)
- (let ((modsym (intern modname)))
- (list 'const
- ':tag (format "%s -- %s" modname
- (get modsym 'custom-tag))
- ':link (caar (get modsym 'custom-links))
- ':doc (concat "\n" (get modsym 'group-documentation)
- "\n ")
- modsym))))
+ (lambda (modname)
+ (let ((modsym (intern modname)))
+ (list 'const
+ ':tag (format "%s -- %s" modname
+ (get modsym 'custom-tag))
+ ':link (caar (get modsym 'custom-links))
+ ':doc (concat "\n" (get modsym 'group-documentation)
+ "\n ")
+ modsym)))
(sort (mapcar 'symbol-name
(eshell-subgroups 'eshell-module))
'string-lessp))
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index c1db484be56..7d31845528b 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -23,14 +23,6 @@
;;; Code:
-
-;; Unused.
-;; (defgroup eshell-opt nil
-;; "The options processing code handles command argument parsing for
-;; Eshell commands implemented in Lisp."
-;; :tag "Command options processing"
-;; :group 'eshell)
-
;;; User Functions:
;; Macro expansion of eshell-eval-using-options refers to eshell-stringify-list
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index de246a25ccc..96c9a60deab 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -37,23 +37,19 @@ finish."
(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)
+ :type 'hook)
(defcustom eshell-process-wait-seconds 0
"The number of seconds to delay waiting for a synchronous process."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-process-wait-milliseconds 50
"The number of milliseconds to delay waiting for a synchronous process."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-done-messages-in-minibuffer t
"If non-nil, subjob \"Done\" messages will display in minibuffer."
- :type 'boolean
- :group 'eshell-proc)
+ :type 'boolean)
(defcustom eshell-delete-exited-processes t
"If nil, process entries will stick around until `jobs' is run.
@@ -72,14 +68,12 @@ subjob is done is that it will no longer appear in the
Note that Eshell will have to be restarted for a change in this
variable's value to take effect."
- :type 'boolean
- :group 'eshell-proc)
+ :type 'boolean)
(defcustom eshell-reset-signals
"^\\(interrupt\\|killed\\|quit\\|stopped\\)"
"If a termination signal matches this regexp, the terminal will be reset."
- :type 'regexp
- :group 'eshell-proc)
+ :type 'regexp)
(defcustom eshell-exec-hook nil
"Called each time a process is exec'd by `eshell-gather-process-output'.
@@ -88,8 +82,7 @@ It is useful for things that must be done each time a process is
executed in an eshell mode buffer (e.g., `set-process-query-on-exit-flag').
In contrast, `eshell-mode-hook' is only executed once, when the buffer
is created."
- :type 'hook
- :group 'eshell-proc)
+ :type 'hook)
(defcustom eshell-kill-hook nil
"Called when a process run by `eshell-gather-process-output' has ended.
@@ -99,8 +92,7 @@ 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)
+ :type 'hook)
;;; Internal Variables:
@@ -109,6 +101,16 @@ information, for example."
(defvar eshell-process-list nil
"A list of the current status of subprocesses.")
+(defvar eshell-proc-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c M-i") #'eshell-insert-process)
+ (define-key map (kbd "C-c C-c") #'eshell-interrupt-process)
+ (define-key map (kbd "C-c C-k") #'eshell-kill-process)
+ (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process)
+ (define-key map (kbd "C-c C-s") #'list-processes)
+ (define-key map (kbd "C-c C-\\") #'eshell-quit-process)
+ map))
+
;;; Functions:
(defun eshell-kill-process-function (proc status)
@@ -116,25 +118,20 @@ information, for example."
Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments
PROC and STATUS to functions on the latter."
;; Was there till 24.1, but it is not optional.
- (if (memq #'eshell-reset-after-proc eshell-kill-hook)
- (setq eshell-kill-hook (delq #'eshell-reset-after-proc eshell-kill-hook)))
+ (remove-hook 'eshell-kill-hook #'eshell-reset-after-proc)
(eshell-reset-after-proc status)
(run-hook-with-args 'eshell-kill-hook proc status))
+(define-minor-mode eshell-proc-mode
+ "Minor mode for the proc eshell module.
+
+\\{eshell-proc-mode-map}"
+ :keymap eshell-proc-mode-map)
+
(defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the process handling code."
(make-local-variable 'eshell-process-list)
- ;; This is supposedly run after enabling esh-mode, when eshell-command-map
- ;; already exists.
- (defvar eshell-command-map)
- (define-key eshell-command-map [(meta ?i)] 'eshell-insert-process)
- (define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process)
- (define-key eshell-command-map [(control ?k)] 'eshell-kill-process)
- (define-key eshell-command-map [(control ?d)] 'eshell-send-eof-to-process)
-; (define-key eshell-command-map [(control ?q)] 'eshell-continue-process)
- (define-key eshell-command-map [(control ?s)] 'list-processes)
-; (define-key eshell-command-map [(control ?z)] 'eshell-stop-process)
- (define-key eshell-command-map [(control ?\\)] 'eshell-quit-process))
+ (eshell-proc-mode))
(defun eshell-reset-after-proc (status)
"Reset the command input location after a process terminates.
@@ -159,7 +156,7 @@ The signals which will cause this to happen are matched by
eshell-process-wait-milliseconds))))
(setq procs (cdr procs))))
-(defalias 'eshell/wait 'eshell-wait-for-process)
+(defalias 'eshell/wait #'eshell-wait-for-process)
(defun eshell/jobs (&rest _args)
"List processes, if there are any."
@@ -209,9 +206,8 @@ and signal names."
The prompt will be set to PROMPT."
(completing-read prompt
(mapcar
- (function
- (lambda (proc)
- (cons (process-name proc) t)))
+ (lambda (proc)
+ (cons (process-name proc) t))
(process-list))
nil t))
@@ -289,7 +285,7 @@ See `eshell-needs-pipe'."
(process-environment (eshell-environment-variables))
proc decoding encoding changed)
(cond
- ((fboundp 'start-file-process)
+ ((fboundp 'make-process)
(setq proc
(let ((process-connection-type
(unless (eshell-needs-pipe-p command)
@@ -452,8 +448,7 @@ If QUERY is non-nil, query the user with QUERY before calling FUNC."
(defcustom eshell-kill-process-wait-time 5
"Seconds to wait between sending termination signals to a subprocess."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-kill-process-signals '(SIGINT SIGQUIT SIGKILL)
"Signals used to kill processes when an Eshell buffer exits.
@@ -461,8 +456,7 @@ 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
tries the next signal in the list."
- :type '(repeat symbol)
- :group 'eshell-proc)
+ :type '(repeat symbol))
(defcustom eshell-kill-processes-on-exit nil
"If non-nil, kill active processes when exiting an Eshell buffer.
@@ -484,8 +478,7 @@ long to delay between signals."
:type '(choice (const :tag "Kill all, don't ask" t)
(const :tag "Ask before killing" ask)
(const :tag "Ask for each process" every)
- (const :tag "Don't kill subprocesses" nil))
- :group 'eshell-proc)
+ (const :tag "Don't kill subprocesses" nil)))
(defun eshell-round-robin-kill (&optional query)
"Kill current process by trying various signals in sequence.
@@ -493,9 +486,8 @@ See the variable `eshell-kill-processes-on-exit'."
(let ((sigs eshell-kill-process-signals))
(while sigs
(eshell-process-interact
- (function
- (lambda (proc)
- (signal-process (process-id proc) (car sigs)))) t query)
+ (lambda (proc)
+ (signal-process (process-id proc) (car sigs))) t query)
(setq query nil)
(if (not eshell-process-list)
(setq sigs nil)
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index fa5c6bb980d..30104816f07 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -23,6 +23,7 @@
;;; Code:
+(require 'seq)
(eval-when-compile (require 'cl-lib))
(defgroup eshell-util nil
@@ -37,46 +38,44 @@
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."
- :type 'boolean
- :group 'eshell-util)
+ :type 'boolean)
(defcustom eshell-group-file "/etc/group"
"If non-nil, the name of the group file on your system."
- :type '(choice (const :tag "No group file" nil) file)
- :group 'eshell-util)
+ :type '(choice (const :tag "No group file" nil) file))
(defcustom eshell-passwd-file "/etc/passwd"
"If non-nil, the name of the passwd file on your system."
- :type '(choice (const :tag "No passwd file" nil) file)
- :group 'eshell-util)
+ :type '(choice (const :tag "No passwd file" nil) file))
(defcustom eshell-hosts-file "/etc/hosts"
- "The name of the /etc/hosts file."
- :type '(choice (const :tag "No hosts file" nil) file)
- :group 'eshell-util)
+ "The name of the /etc/hosts file.
+Use `pcomplete-hosts-file' instead; this variable is obsolete and
+has no effect."
+ :type '(choice (const :tag "No hosts file" nil) file))
+;; Don't make it into an alias, because it doesn't really work with
+;; custom and risks creating duplicate entries. Just point users to
+;; the other variable, which is less frustrating.
+(make-obsolete-variable 'eshell-hosts-file nil "28.1")
(defcustom eshell-handle-errors t
"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)
+ :type 'boolean)
(defcustom eshell-private-file-modes 384 ; umask 177
"The file-modes value to use for creating \"private\" files."
- :type 'integer
- :group 'eshell-util)
+ :type 'integer)
(defcustom eshell-private-directory-modes 448 ; umask 077
"The file-modes value to use for creating \"private\" directories."
- :type 'integer
- :group 'eshell-util)
+ :type 'integer)
(defcustom eshell-tar-regexp
"\\.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)
+ :type 'regexp)
(defcustom eshell-convert-numeric-arguments t
"If non-nil, converting arguments of numeric form to Lisp numbers.
@@ -93,16 +92,14 @@ following in your init file:
Any function with the property `eshell-no-numeric-conversions' set to
a non-nil value, will be passed strings, not numbers, even when an
argument matches `eshell-number-regexp'."
- :type 'boolean
- :group 'eshell-util)
+ :type 'boolean)
(defcustom eshell-number-regexp "-?\\([0-9]*\\.\\)?[0-9]+\\(e[-0-9.]+\\)?"
"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'."
- :type 'regexp
- :group 'eshell-util)
+ :type 'regexp)
(defcustom eshell-ange-ls-uids nil
"List of user/host/id strings, used to determine remote ownership."
@@ -110,8 +107,7 @@ function `string-to-number'."
(string :tag "Hostname")
(repeat (cons :tag "User/UID List"
(string :tag "Username")
- (repeat :tag "UIDs" string)))))
- :group 'eshell-util)
+ (repeat :tag "UIDs" string))))))
;;; Internal Variables:
@@ -127,11 +123,14 @@ function `string-to-number'."
(defvar eshell-user-timestamp nil
"A timestamp of when the user file was read.")
-(defvar eshell-host-names nil
- "A cache the names of frequently accessed hosts.")
+;;; Obsolete variables:
-(defvar eshell-host-timestamp nil
- "A timestamp of when the hosts file was read.")
+(define-obsolete-variable-alias 'eshell-host-names
+ 'pcomplete--host-name-cache "28.1")
+(define-obsolete-variable-alias 'eshell-host-timestamp
+ 'pcomplete--host-name-cache-timestamp "28.1")
+(defvar pcomplete--host-name-cache)
+(defvar pcomplete--host-name-cache-timestamp)
;;; Functions:
@@ -214,23 +213,10 @@ then quoting is done by a backslash, rather than a doubled delimiter."
(string-to-number string)
string))))))
-(defun eshell-sublist (l &optional n m)
- "Return from LIST the N to M elements.
-If N or M is nil, it means the end of the list."
- (let ((a (copy-sequence l)))
- (if (and m (consp (nthcdr m a)))
- (setcdr (nthcdr m a) nil))
- (if n
- (setq a (nthcdr n a))
- (setq n (1- (length a))
- a (last a)))
- a))
-
-(defvar eshell-path-env (getenv "PATH")
+(defvar-local eshell-path-env (getenv "PATH")
"Content of $PATH.
It might be different from \(getenv \"PATH\"), when
`default-directory' points to a remote host.")
-(make-variable-buffer-local 'eshell-path-env)
(defun eshell-get-path ()
"Return $PATH as a list.
@@ -295,20 +281,6 @@ Prepend remote identification of `default-directory', if any."
(define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1")
-(defun eshell-uniquify-list (l)
- "Remove occurring multiples in L. You probably want to sort first."
- (let ((m l))
- (while m
- (while (and (cdr m)
- (string= (car m)
- (cadr m)))
- (setcdr m (cddr m)))
- (setq m (cdr m))))
- l)
-(define-obsolete-function-alias
- 'eshell-uniqify-list
- 'eshell-uniquify-list "27.1")
-
(defun eshell-stringify (object)
"Convert OBJECT into a string value."
(cond
@@ -326,11 +298,11 @@ Prepend remote identification of `default-directory', if any."
(defsubst eshell-stringify-list (args)
"Convert each element of ARGS into a string value."
- (mapcar 'eshell-stringify args))
+ (mapcar #'eshell-stringify args))
(defsubst eshell-flatten-and-stringify (&rest args)
"Flatten and stringify all of the ARGS into a single string."
- (mapconcat 'eshell-stringify (flatten-tree args) " "))
+ (mapconcat #'eshell-stringify (flatten-tree args) " "))
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
@@ -477,43 +449,19 @@ list."
"Return the user id for user NAME."
(car (rassoc name (eshell-read-user-names))))
-(defalias 'eshell-user-name 'user-login-name)
-
-(defun eshell-read-hosts-file (filename)
- "Read in the hosts from FILENAME, default `eshell-hosts-file'."
- (let (hosts)
- (with-temp-buffer
- (insert-file-contents (or filename eshell-hosts-file))
- (goto-char (point-min))
- (while (re-search-forward
- ;; "^ \t\\([^# \t\n]+\\)[ \t]+\\([^ \t\n]+\\)\\([ \t]*\\([^ \t\n]+\\)\\)?"
- "^[ \t]*\\([^# \t\n]+\\)[ \t]+\\([^ \t\n].+\\)" nil t)
- (push (cons (match-string 1)
- (split-string (match-string 2)))
- hosts)))
- (nreverse hosts)))
-
-(defun eshell-read-hosts (file result-var timestamp-var)
- "Read the contents of /etc/hosts for host names."
- (if (or (not (symbol-value result-var))
- (not (symbol-value timestamp-var))
- (time-less-p
- (symbol-value timestamp-var)
- (file-attribute-modification-time (file-attributes file))))
- (progn
- (set result-var (apply #'nconc (eshell-read-hosts-file file)))
- (set timestamp-var (current-time))))
- (symbol-value result-var))
-
-(defun eshell-read-host-names ()
- "Read the contents of /etc/hosts for host names."
- (if eshell-hosts-file
- (eshell-read-hosts eshell-hosts-file 'eshell-host-names
- 'eshell-host-timestamp)))
+(autoload 'pcomplete-read-hosts-file "pcomplete")
+(autoload 'pcomplete-read-hosts "pcomplete")
+(autoload 'pcomplete-read-host-names "pcomplete")
+(define-obsolete-function-alias 'eshell-read-hosts-file
+ #'pcomplete-read-hosts-file "28.1")
+(define-obsolete-function-alias 'eshell-read-hosts
+ #'pcomplete-read-hosts "28.1")
+(define-obsolete-function-alias 'eshell-read-host-names
+ #'pcomplete-read-host-names "28.1")
(defsubst eshell-copy-environment ()
"Return an unrelated copy of `process-environment'."
- (mapcar 'concat process-environment))
+ (mapcar #'concat process-environment))
(defun eshell-subgroups (groupsym)
"Return all of the subgroups of GROUPSYM."
@@ -647,14 +595,8 @@ gid format. Valid values are `string' and `integer', defaulting to
(let ((base (file-name-nondirectory file))
(dir (file-name-directory file)))
(if (string-equal "" base) (setq base "."))
- (if (boundp 'ange-cache)
- (setq entry (cdr (assoc base (cdr (assoc dir ange-cache))))))
(unless entry
(setq entry (eshell-parse-ange-ls dir))
- (if (boundp 'ange-cache)
- (setq ange-cache
- (cons (cons dir entry)
- ange-cache)))
(if entry
(let ((fentry (assoc base (cdr entry))))
(if fentry
@@ -663,76 +605,85 @@ gid format. Valid values are `string' and `integer', defaulting to
entry)
(file-attributes file id-format))))
-(defalias 'eshell-copy-tree 'copy-tree)
-
(defsubst eshell-processp (proc)
"If the `processp' function does not exist, PROC is not a process."
(and (fboundp 'processp) (processp proc)))
-; (defun eshell-copy-file
-; (file newname &optional ok-if-already-exists keep-date)
-; "Copy FILE to NEWNAME. See docs for `copy-file'."
-; (let (copied)
-; (if (string-match "\\`\\([^:]+\\):\\(.*\\)" file)
-; (let ((front (match-string 1 file))
-; (back (match-string 2 file))
-; buffer)
-; (if (and front (string-match eshell-tar-regexp front)
-; (setq buffer (find-file-noselect front)))
-; (with-current-buffer buffer
-; (goto-char (point-min))
-; (if (re-search-forward (concat " " (regexp-quote back)
-; "$") nil t)
-; (progn
-; (tar-copy (if (file-directory-p newname)
-; (expand-file-name
-; (file-name-nondirectory back) newname)
-; newname))
-; (setq copied t))
-; (error "%s not found in tar file %s" back front))))))
-; (unless copied
-; (copy-file file newname ok-if-already-exists keep-date))))
-
-; (defun eshell-file-attributes (filename)
-; "Return a list of attributes of file FILENAME.
-; See the documentation for `file-attributes'."
-; (let (result)
-; (when (string-match "\\`\\([^:]+\\):\\(.*\\)\\'" filename)
-; (let ((front (match-string 1 filename))
-; (back (match-string 2 filename))
-; buffer)
-; (when (and front (string-match eshell-tar-regexp front)
-; (setq buffer (find-file-noselect front)))
-; (with-current-buffer buffer
-; (goto-char (point-min))
-; (when (re-search-forward (concat " " (regexp-quote back)
-; "\\s-*$") nil t)
-; (let* ((descrip (tar-current-descriptor))
-; (tokens (tar-desc-tokens descrip)))
-; (setq result
-; (list
-; (cond
-; ((eq (tar-header-link-type tokens) 5)
-; t)
-; ((eq (tar-header-link-type tokens) t)
-; (tar-header-link-name tokens)))
-; 1
-; (tar-header-uid tokens)
-; (tar-header-gid tokens)
-; (tar-header-date tokens)
-; (tar-header-date tokens)
-; (tar-header-date tokens)
-; (tar-header-size tokens)
-; (concat
-; (cond
-; ((eq (tar-header-link-type tokens) 5) "d")
-; ((eq (tar-header-link-type tokens) t) "l")
-; (t "-"))
-; (tar-grind-file-mode (tar-header-mode tokens)
-; (make-string 9 ? ) 0))
-; nil nil nil))))))))
-; (or result
-; (file-attributes filename))))
+;; (defun eshell-copy-file
+;; (file newname &optional ok-if-already-exists keep-date)
+;; "Copy FILE to NEWNAME. See docs for `copy-file'."
+;; (let (copied)
+;; (if (string-match "\\`\\([^:]+\\):\\(.*\\)" file)
+;; (let ((front (match-string 1 file))
+;; (back (match-string 2 file))
+;; buffer)
+;; (if (and front (string-match eshell-tar-regexp front)
+;; (setq buffer (find-file-noselect front)))
+;; (with-current-buffer buffer
+;; (goto-char (point-min))
+;; (if (re-search-forward (concat " " (regexp-quote back)
+;; "$") nil t)
+;; (progn
+;; (tar-copy (if (file-directory-p newname)
+;; (expand-file-name
+;; (file-name-nondirectory back) newname)
+;; newname))
+;; (setq copied t))
+;; (error "%s not found in tar file %s" back front))))))
+;; (unless copied
+;; (copy-file file newname ok-if-already-exists keep-date))))
+
+;; (defun eshell-file-attributes (filename)
+;; "Return a list of attributes of file FILENAME.
+;; See the documentation for `file-attributes'."
+;; (let (result)
+;; (when (string-match "\\`\\([^:]+\\):\\(.*\\)\\'" filename)
+;; (let ((front (match-string 1 filename))
+;; (back (match-string 2 filename))
+;; buffer)
+;; (when (and front (string-match eshell-tar-regexp front)
+;; (setq buffer (find-file-noselect front)))
+;; (with-current-buffer buffer
+;; (goto-char (point-min))
+;; (when (re-search-forward (concat " " (regexp-quote back)
+;; "\\s-*$") nil t)
+;; (let* ((descrip (tar-current-descriptor))
+;; (tokens (tar-desc-tokens descrip)))
+;; (setq result
+;; (list
+;; (cond
+;; ((eq (tar-header-link-type tokens) 5)
+;; t)
+;; ((eq (tar-header-link-type tokens) t)
+;; (tar-header-link-name tokens)))
+;; 1
+;; (tar-header-uid tokens)
+;; (tar-header-gid tokens)
+;; (tar-header-date tokens)
+;; (tar-header-date tokens)
+;; (tar-header-date tokens)
+;; (tar-header-size tokens)
+;; (file-modes-number-to-symbolic
+;; (logior (tar-header-mode tokens)
+;; (cond
+;; ((eq (tar-header-link-type tokens) 5) 16384)
+;; ((eq (tar-header-link-type tokens) t) 32768))))
+;; nil nil nil))))))))
+;; (or result
+;; (file-attributes filename))))
+
+;; Obsolete.
+
+(define-obsolete-function-alias 'eshell-uniquify-list #'seq-uniq "28.1")
+(define-obsolete-function-alias 'eshell-uniqify-list #'seq-uniq "28.1")
+(define-obsolete-function-alias 'eshell-copy-tree #'copy-tree "28.1")
+(define-obsolete-function-alias 'eshell-user-name #'user-login-name "28.1")
+
+(defun eshell-sublist (l &optional n m)
+ "Return from LIST the N to M elements.
+If N or M is nil, it means the end of the list."
+ (declare (obsolete seq-subseq "28.1"))
+ (seq-subseq l n (1+ m)))
(provide 'esh-util)
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index 98a998538af..9fccc6b1c9d 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -113,7 +113,6 @@
(require 'esh-io)
(require 'pcomplete)
-(require 'env)
(require 'ring)
(defgroup eshell-var nil
@@ -179,42 +178,60 @@ if they are quoted with a backslash."
(eshell-apply-indices eshell-command-arguments
indices)))))
"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 the name of a command,
-and the Lisp value to return for that variable if it is accessed
-via the syntax `$NAME'.
-
-If the value is a function, that function will be called with two
-arguments: the list of the indices that was used in the reference, and
-whether the user is requesting the length of the ultimate element.
-For example, a reference of `$NAME[10][20]' would result in the
-function for alias `NAME' being called (assuming it were aliased to a
-function), and the arguments passed to this function would be the list
-'(10 20)', and nil."
+Each member defines the name of a variable, and a Lisp value used to
+compute the string value that will be returned when the variable is
+accessed via the syntax `$NAME'.
+
+If the value is a function, call that function with two arguments: the
+list of the indices that was used in the reference, and whether the
+user is requesting the length of the ultimate element. For example, a
+reference of `$NAME[10][20]' would result in the function for alias
+`NAME' being called (assuming it were aliased to a function), and the
+arguments passed to this function would be the list '(10 20)', and
+nil.
+
+If the value is a string, return the value for the variable with that
+name in the current environment. If no variable with that name exists
+in the environment, but if a symbol with that same name exists and has
+a value bound to it, return its value instead. You can prioritize
+symbol values over environment values by setting
+`eshell-prefer-lisp-variables' to t.
+
+If the value is a symbol, return the value bound to it.
+
+If the value has any other type, signal an error.
+
+Additionally, each member may specify if it should be copied to the
+environment of created subprocesses."
:type '(repeat (list string sexp
(choice (const :tag "Copy to environment" t)
(const :tag "Use only in Eshell" nil)))))
(put 'eshell-variable-aliases-list 'risky-local-variable t)
+(defvar eshell-var-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c M-v") #'eshell-insert-envvar)
+ map))
+
;;; Functions:
+(define-minor-mode eshell-var-mode
+ "Minor mode for the esh-var module.
+
+\\{eshell-var-mode-map}"
+ :keymap eshell-var-mode-map)
+
(defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the variable handle code."
;; Break the association with our parent's environment. Otherwise,
;; changing a variable will affect all of Emacs.
(unless eshell-modify-global-environment
- (set (make-local-variable 'process-environment)
- (eshell-copy-environment)))
-
- ;; This is supposedly run after enabling esh-mode, when eshell-command-map
- ;; already exists.
- (defvar eshell-command-map)
- (define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar)
+ (setq-local process-environment (eshell-copy-environment)))
- (set (make-local-variable 'eshell-special-chars-inside-quoting)
+ (setq-local eshell-special-chars-inside-quoting
(append eshell-special-chars-inside-quoting '(?$)))
- (set (make-local-variable 'eshell-special-chars-outside-quoting)
+ (setq-local eshell-special-chars-outside-quoting
(append eshell-special-chars-outside-quoting '(?$)))
(add-hook 'eshell-parse-argument-hook #'eshell-interpolate-variable t t)
@@ -338,7 +355,7 @@ This function is explicit for adding to `eshell-parse-argument-hook'."
(defun pcomplete/eshell-mode/setq ()
"Completion function for Eshell's `setq'."
(while (and (pcomplete-here (all-completions pcomplete-stub
- obarray 'boundp))
+ obarray #'boundp))
(pcomplete-here))))
;; FIXME the real "env" command does more than this, it runs a program
@@ -363,9 +380,8 @@ This function is explicit for adding to `eshell-parse-argument-hook'."
(defun eshell-envvar-names (&optional environment)
"Return a list of currently visible environment variable names."
- (mapcar (function
- (lambda (x)
- (substring x 0 (string-match "=" x))))
+ (mapcar (lambda (x)
+ (substring x 0 (string-match "=" x)))
(or environment process-environment)))
(defun eshell-environment-variables ()
@@ -444,8 +460,8 @@ Possible options are:
(eshell-as-subcommand ,(eshell-parse-command cmd))
(ignore
(nconc eshell-this-command-hook
- (list (function (lambda ()
- (delete-file ,temp))))))
+ (list (lambda ()
+ (delete-file ,temp)))))
(quote ,temp)))
(goto-char (1+ end)))))))
((eq (char-after) ?\()
@@ -599,14 +615,13 @@ For example, to retrieve the second element of a user's record in
(sort
(append
(mapcar
- (function
- (lambda (varname)
- (let ((value (eshell-get-variable varname)))
- (if (and value
- (stringp value)
- (file-directory-p value))
- (concat varname "/")
- varname))))
+ (lambda (varname)
+ (let ((value (eshell-get-variable varname)))
+ (if (and value
+ (stringp value)
+ (file-directory-p value))
+ (concat varname "/")
+ varname)))
(eshell-envvar-names (eshell-environment-variables)))
(all-completions argname obarray 'boundp)
completions)
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index ace7064255d..101ac860346 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -265,14 +265,18 @@ information on Eshell, see Info node `(eshell)Top'."
(eshell-mode))
buf))
-(defun eshell-return-exits-minibuffer ()
- ;; This is supposedly run after enabling esh-mode, when eshell-mode-map
- ;; already exists.
- (defvar eshell-mode-map)
- (define-key eshell-mode-map [(control ?g)] 'abort-recursive-edit)
- (define-key eshell-mode-map [(control ?m)] 'exit-minibuffer)
- (define-key eshell-mode-map [(control ?j)] 'exit-minibuffer)
- (define-key eshell-mode-map [(meta control ?m)] 'exit-minibuffer))
+(define-minor-mode eshell-command-mode
+ "Minor mode for `eshell-command' input.
+\\{eshell-command-mode-map}"
+ :keymap (let ((map (make-sparse-keymap)))
+ (define-key map [(control ?g)] 'abort-recursive-edit)
+ (define-key map [(control ?m)] 'exit-minibuffer)
+ (define-key map [(control ?j)] 'exit-minibuffer)
+ (define-key map [(meta control ?m)] 'exit-minibuffer)
+ map))
+
+(define-obsolete-function-alias 'eshell-return-exits-minibuffer
+ #'eshell-command-mode "28.1")
(defvar eshell-non-interactive-p nil
"A variable which is non-nil when Eshell is not running interactively.
@@ -290,9 +294,9 @@ With prefix ARG, insert output into the current buffer at point."
(setq arg current-prefix-arg))
(let ((eshell-non-interactive-p t))
;; Enable `eshell-mode' only in this minibuffer.
- (minibuffer-with-setup-hook #'(lambda ()
- (eshell-mode)
- (eshell-return-exits-minibuffer))
+ (minibuffer-with-setup-hook (lambda ()
+ (eshell-mode)
+ (eshell-command-mode +1))
(unless command
(setq command (read-from-minibuffer "Emacs shell command: "))
(if (eshell-using-module 'eshell-hist)
@@ -380,15 +384,6 @@ corresponding to a successful execution."
(set status-var eshell-last-command-status))
(cadr result))))))
-;;;_* Reporting bugs
-;;
-;; If you do encounter a bug, on any system, please report
-;; it -- in addition to any particular oddities in your configuration
-;; -- so that the problem may be corrected for the benefit of others.
-
-;;;###autoload
-(define-obsolete-function-alias 'eshell-report-bug 'report-emacs-bug "23.1")
-
;;; Code:
(defun eshell-unload-all-modules ()
diff --git a/lisp/expand.el b/lisp/expand.el
index 165b89b71e7..1b722014f89 100644
--- a/lisp/expand.el
+++ b/lisp/expand.el
@@ -1,4 +1,4 @@
-;;; expand.el --- make abbreviations more usable
+;;; expand.el --- make abbreviations more usable -*- lexical-binding: t -*-
;; Copyright (C) 1995-1996, 2001-2021 Free Software Foundation, Inc.
@@ -55,10 +55,8 @@
;;
;; you can also init some post-process hooks :
;;
-;; (add-hook 'expand-load-hook
-;; (lambda ()
-;; (add-hook 'expand-expand-hook 'indent-according-to-mode)
-;; (add-hook 'expand-jump-hook 'indent-according-to-mode)))
+;; (add-hook 'expand-expand-hook 'indent-according-to-mode)
+;; (add-hook 'expand-jump-hook 'indent-according-to-mode)
;;
;; Remarks:
;;
@@ -76,18 +74,17 @@
(defcustom expand-load-hook nil
"Hooks run when `expand.el' is loaded."
- :type 'hook
- :group 'expand)
+ :type 'hook)
+(make-obsolete-variable 'expand-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom expand-expand-hook nil
"Hooks run when an abbrev made by `expand-add-abbrevs' is expanded."
- :type 'hook
- :group 'expand)
+ :type 'hook)
(defcustom expand-jump-hook nil
"Hooks run by `expand-jump-to-previous-slot' and `expand-jump-to-next-slot'."
- :type 'hook
- :group 'expand)
+ :type 'hook)
;;; Samples:
@@ -289,17 +286,14 @@ If ARG is omitted, point is placed at the end of the expanded text."
(defvar expand-list nil "Temporary variable used by the Expand package.")
-(defvar expand-pos nil
- "If non-nil, stores a vector containing markers to positions defined by the last expansion.")
-(make-variable-buffer-local 'expand-pos)
+(defvar-local expand-pos nil
+ "If non-nil, store a vector with position markers defined by the last expansion.")
-(defvar expand-index 0
+(defvar-local expand-index 0
"Index of the last marker used in `expand-pos'.")
-(make-variable-buffer-local 'expand-index)
-(defvar expand-point nil
+(defvar-local expand-point nil
"End of the expanded region.")
-(make-variable-buffer-local 'expand-point)
(defun expand-add-abbrev (table abbrev expansion arg)
"Add one abbreviation and provide the hook to move to the specified positions."
@@ -322,8 +316,7 @@ If ARG is omitted, point is placed at the end of the expanded text."
nil)
(if (and (symbolp expansion) (fboundp expansion))
expansion
- nil)
- )
+ nil))
'expand-abbrev-hook)))
(put 'expand-abbrev-hook 'no-self-insert t)
@@ -371,13 +364,12 @@ See `expand-add-abbrevs'. Value is non-nil if expansion was done."
(insert text)
(setq expand-point (point))))
(if jump-args
- (funcall 'expand-build-list (car jump-args) (cdr jump-args)))
+ (funcall #'expand-build-list (car jump-args) (cdr jump-args)))
(if position
(backward-char position))
(if hook
(funcall hook))
- t)
- )
+ t))
(defun expand-abbrev-from-expand (word)
"Test if an abbrev has a hook."
@@ -431,8 +423,7 @@ This is used only in conjunction with `expand-add-abbrevs'."
(lenlist (length expand-list)))
(while (< i lenlist)
(aset expand-list i (- len (1- (aref expand-list i))))
- (setq i (1+ i))))
- )
+ (setq i (1+ i)))))
(defun expand-build-marks (p)
"Transform the offsets vector into a marker vector."
@@ -493,7 +484,6 @@ This is used only in conjunction with `expand-add-abbrevs'."
(provide 'expand)
-;; run load hooks
(run-hooks 'expand-load-hook)
;;; expand.el ends here
diff --git a/lisp/ezimage.el b/lisp/ezimage.el
index 9c1d8599101..13f5c039a7f 100644
--- a/lisp/ezimage.el
+++ b/lisp/ezimage.el
@@ -1,4 +1,4 @@
-;;; ezimage --- Generalized Image management
+;;; ezimage.el --- Generalized Image management -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 6c3f4082fdf..5914ee4a202 100644
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -217,17 +217,35 @@ Each positive or negative step scales the default face height by this amount."
:type 'number
:version "23.1")
-;; current remapping cookie for text-scale-mode
-(defvar text-scale-mode-remapping nil)
-(make-variable-buffer-local 'text-scale-mode-remapping)
-
-;; Lighter displayed for text-scale-mode in mode-line minor-mode list
-(defvar text-scale-mode-lighter "+0")
-(make-variable-buffer-local 'text-scale-mode-lighter)
-
-;; Number of steps that text-scale-mode will increase/decrease text height
-(defvar text-scale-mode-amount 0)
-(make-variable-buffer-local 'text-scale-mode-amount)
+(defvar-local text-scale-mode-remapping nil
+ "Current remapping cookie for text-scale-mode.")
+
+(defvar-local text-scale-mode-lighter "+0"
+ "Lighter displayed for text-scale-mode in mode-line minor-mode list.")
+
+(defvar-local text-scale-mode-amount 0
+ "Number of steps that text-scale-mode will increase/decrease text height.")
+
+(defvar-local text-scale-remap-header-line nil
+ "If non-nil, text scaling may change font size of header lines too.")
+
+(defun face-remap--clear-remappings ()
+ (dolist (remapping
+ ;; This is a bit messy to stay backwards compatible.
+ ;; In the future, this can be simplified to just use
+ ;; `text-scale-mode-remapping'.
+ (if (consp (car-safe text-scale-mode-remapping))
+ text-scale-mode-remapping
+ (list text-scale-mode-remapping)))
+ (face-remap-remove-relative remapping))
+ (setq text-scale-mode-remapping nil))
+
+(defun face-remap--remap-face (sym)
+ (push (face-remap-add-relative sym
+ :height
+ (expt text-scale-mode-step
+ text-scale-mode-amount))
+ text-scale-mode-remapping))
(define-minor-mode text-scale-mode
"Minor mode for displaying buffer text in a larger/smaller font.
@@ -240,21 +258,32 @@ face size by the value of the variable `text-scale-mode-step'
The `text-scale-increase', `text-scale-decrease', and
`text-scale-set' functions may be used to interactively modify
the variable `text-scale-mode-amount' (they also enable or
-disable `text-scale-mode' as necessary)."
+disable `text-scale-mode' as necessary).
+
+If `text-scale-remap-header-line' is non-nil, also change
+the font size of the header line."
:lighter (" " text-scale-mode-lighter)
- (when text-scale-mode-remapping
- (face-remap-remove-relative text-scale-mode-remapping))
+ (face-remap--clear-remappings)
(setq text-scale-mode-lighter
(format (if (>= text-scale-mode-amount 0) "+%d" "%d")
text-scale-mode-amount))
- (setq text-scale-mode-remapping
- (and text-scale-mode
- (face-remap-add-relative 'default
- :height
- (expt text-scale-mode-step
- text-scale-mode-amount))))
+ (when text-scale-mode
+ (face-remap--remap-face 'default)
+ (when text-scale-remap-header-line
+ (face-remap--remap-face 'header-line)))
(force-window-update (current-buffer)))
+(defun text-scale--refresh (symbol newval operation where)
+ "Watcher for `text-scale-remap-header-line'.
+See `add-variable-watcher'."
+ (when (and (eq symbol 'text-scale-remap-header-line)
+ (eq operation 'set)
+ text-scale-mode)
+ (with-current-buffer where
+ (let ((text-scale-remap-header-line newval))
+ (text-scale-mode 1)))))
+(add-variable-watcher 'text-scale-remap-header-line #'text-scale--refresh)
+
(defun text-scale-min-amount ()
"Return the minimum amount of text-scaling we allow."
;; When the resulting pixel-height of characters will become smaller
@@ -380,8 +409,7 @@ plist, etc."
:version "23.1")
;; current remapping cookie for buffer-face-mode
-(defvar buffer-face-mode-remapping nil)
-(make-variable-buffer-local 'buffer-face-mode-remapping)
+(defvar-local buffer-face-mode-remapping nil)
;;;###autoload
(define-minor-mode buffer-face-mode
@@ -413,7 +441,7 @@ local, and sets it to FACE."
(setq specs (car specs)))
(if (null specs)
(buffer-face-mode 0)
- (set (make-local-variable 'buffer-face-mode-face) specs)
+ (setq-local buffer-face-mode-face specs)
(buffer-face-mode t)))
;;;###autoload
@@ -437,7 +465,7 @@ buffer local, and set it to SPECS."
(if (or (null specs)
(and buffer-face-mode (equal buffer-face-mode-face specs)))
(buffer-face-mode 0)
- (set (make-local-variable 'buffer-face-mode-face) specs)
+ (setq-local buffer-face-mode-face specs)
(buffer-face-mode t)))
(defun buffer-face-mode-invoke (specs arg &optional interactive)
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 2a7b4375078..7229d6163df 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -1,4 +1,4 @@
-;;; facemenu.el --- create a face menu for interactively adding fonts to text
+;;; facemenu.el --- create a face menu for interactively adding fonts to text -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1996, 2001-2021 Free Software Foundation, Inc.
@@ -85,26 +85,17 @@
;;; Code:
-(eval-when-compile
- (require 'help)
- (require 'button))
-
-;; Global bindings:
-(define-key global-map [C-down-mouse-2] 'facemenu-menu)
-(define-key global-map "\M-o" 'facemenu-keymap)
-
(defgroup facemenu nil
"Create a face menu for interactively adding fonts to text."
:group 'faces
:prefix "facemenu-")
(defcustom facemenu-keybindings
- (mapcar 'purecopy
'((default . "d")
(bold . "b")
(italic . "i")
- (bold-italic . "l") ; {bold} intersect {italic} = {l}
- (underline . "u")))
+ (bold-italic . "l") ; {bold} intersect {italic} = {l}
+ (underline . "u"))
"Alist of interesting faces and keybindings.
Each element is itself a list: the car is the name of the face,
the next element is the key to use as a keyboard equivalent of the menu item;
@@ -155,7 +146,7 @@ it will remove any faces not explicitly in the list."
(defvar facemenu-face-menu
(let ((map (make-sparse-keymap "Face")))
- (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
+ (define-key map "o" (cons "Other..." 'facemenu-set-face))
map)
"Menu keymap for faces.")
(defalias 'facemenu-face-menu facemenu-face-menu)
@@ -163,7 +154,7 @@ it will remove any faces not explicitly in the list."
(defvar facemenu-foreground-menu
(let ((map (make-sparse-keymap "Foreground Color")))
- (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground))
+ (define-key map "o" (cons "Other..." 'facemenu-set-foreground))
map)
"Menu keymap for foreground colors.")
(defalias 'facemenu-foreground-menu facemenu-foreground-menu)
@@ -171,12 +162,20 @@ it will remove any faces not explicitly in the list."
(defvar facemenu-background-menu
(let ((map (make-sparse-keymap "Background Color")))
- (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background))
+ (define-key map "o" (cons "Other..." 'facemenu-set-background))
map)
"Menu keymap for background colors.")
(defalias 'facemenu-background-menu facemenu-background-menu)
(put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
+(defcustom facemenu-add-face-function nil
+ "Function called at beginning of text to change or nil.
+This function is passed the FACE to set and END of text to change, and must
+return a string which is inserted. It may set `facemenu-end-add-face'."
+ :type '(choice (const :tag "None" nil)
+ function)
+ :group 'facemenu)
+
;;; Condition for enabling menu items that set faces.
(defun facemenu-enable-faces-p ()
;; Enable the facemenu if facemenu-add-face-function is defined
@@ -186,27 +185,22 @@ it will remove any faces not explicitly in the list."
(defvar facemenu-special-menu
(let ((map (make-sparse-keymap "Special")))
- (define-key map [?s] (cons (purecopy "Remove Special")
- 'facemenu-remove-special))
- (define-key map [?c] (cons (purecopy "Charset")
- 'facemenu-set-charset))
- (define-key map [?t] (cons (purecopy "Intangible")
- 'facemenu-set-intangible))
- (define-key map [?v] (cons (purecopy "Invisible")
- 'facemenu-set-invisible))
- (define-key map [?r] (cons (purecopy "Read-Only")
- 'facemenu-set-read-only))
+ (define-key map [?s] (cons "Remove Special" 'facemenu-remove-special))
+ (define-key map [?c] (cons "Charset" 'facemenu-set-charset))
+ (define-key map [?t] (cons "Intangible" 'facemenu-set-intangible))
+ (define-key map [?v] (cons "Invisible" 'facemenu-set-invisible))
+ (define-key map [?r] (cons "Read-Only" 'facemenu-set-read-only))
map)
"Menu keymap for non-face text-properties.")
(defalias 'facemenu-special-menu facemenu-special-menu)
(defvar facemenu-justification-menu
(let ((map (make-sparse-keymap "Justification")))
- (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
- (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
- (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
- (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
- (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
+ (define-key map [?c] (cons "Center" 'set-justification-center))
+ (define-key map [?b] (cons "Full" 'set-justification-full))
+ (define-key map [?r] (cons "Right" 'set-justification-right))
+ (define-key map [?l] (cons "Left" 'set-justification-left))
+ (define-key map [?u] (cons "Unfilled" 'set-justification-none))
map)
"Submenu for text justification commands.")
(defalias 'facemenu-justification-menu facemenu-justification-menu)
@@ -214,13 +208,13 @@ it will remove any faces not explicitly in the list."
(defvar facemenu-indentation-menu
(let ((map (make-sparse-keymap "Indentation")))
(define-key map [decrease-right-margin]
- (cons (purecopy "Indent Right Less") 'decrease-right-margin))
+ (cons "Indent Right Less" 'decrease-right-margin))
(define-key map [increase-right-margin]
- (cons (purecopy "Indent Right More") 'increase-right-margin))
+ (cons "Indent Right More" 'increase-right-margin))
(define-key map [decrease-left-margin]
- (cons (purecopy "Indent Less") 'decrease-left-margin))
+ (cons "Indent Less" 'decrease-left-margin))
(define-key map [increase-left-margin]
- (cons (purecopy "Indent More") 'increase-left-margin))
+ (cons "Indent More" 'increase-left-margin))
map)
"Submenu for indentation commands.")
(defalias 'facemenu-indentation-menu facemenu-indentation-menu)
@@ -230,36 +224,37 @@ it will remove any faces not explicitly in the list."
"Facemenu top-level menu keymap.")
(setq facemenu-menu (make-sparse-keymap "Text Properties"))
(let ((map facemenu-menu))
- (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
- (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
- (define-key map [dp] (cons (purecopy "Describe Properties")
- 'describe-text-properties))
- (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties")
+ (define-key map [dc] (cons "Display Colors" 'list-colors-display))
+ (define-key map [df] (cons "Display Faces" 'list-faces-display))
+ (define-key map [dp] (cons "Describe Properties" 'describe-text-properties))
+ (define-key map [ra] (list 'menu-item "Remove Text Properties"
'facemenu-remove-all
:enable 'mark-active))
- (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties")
+ (define-key map [rm] (list 'menu-item "Remove Face Properties"
'facemenu-remove-face-props
:enable 'mark-active))
- (define-key map [s1] (list (purecopy "--"))))
+ (define-key map [s1] (list "--")))
(let ((map facemenu-menu))
- (define-key map [in] (cons (purecopy "Indentation")
- 'facemenu-indentation-menu))
- (define-key map [ju] (cons (purecopy "Justification")
- 'facemenu-justification-menu))
- (define-key map [s2] (list (purecopy "--")))
- (define-key map [sp] (cons (purecopy "Special Properties")
- 'facemenu-special-menu))
- (define-key map [bg] (cons (purecopy "Background Color")
- 'facemenu-background-menu))
- (define-key map [fg] (cons (purecopy "Foreground Color")
- 'facemenu-foreground-menu))
- (define-key map [fc] (cons (purecopy "Face")
- 'facemenu-face-menu)))
+ (define-key map [in] (cons "Indentation" 'facemenu-indentation-menu))
+ (define-key map [ju] (cons "Justification" 'facemenu-justification-menu))
+ (define-key map [s2] (list "--"))
+ (define-key map [sp] (cons "Special Properties" 'facemenu-special-menu))
+ (define-key map [bg] (cons "Background Color" 'facemenu-background-menu))
+ (define-key map [fg] (cons "Foreground Color" 'facemenu-foreground-menu))
+ (define-key map [fc] (cons "Face" 'facemenu-face-menu)))
(defalias 'facemenu-menu facemenu-menu)
+;;;###autoload (autoload 'facemenu-menu "facemenu" nil nil 'keymap)
+;;;###autoload
+(define-key global-map [C-down-mouse-2] 'facemenu-menu)
+
+(easy-menu-add-item
+ menu-bar-edit-menu nil
+ ["Text Properties" facemenu-menu])
+
(defvar facemenu-keymap
(let ((map (make-sparse-keymap "Set face")))
- (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
+ (define-key map "o" (cons "Other..." 'facemenu-set-face))
(define-key map "\M-o" 'font-lock-fontify-block)
map)
"Keymap for face-changing commands.
@@ -268,14 +263,6 @@ requested in `facemenu-keybindings'.")
(defalias 'facemenu-keymap facemenu-keymap)
-(defcustom facemenu-add-face-function nil
- "Function called at beginning of text to change or nil.
-This function is passed the FACE to set and END of text to change, and must
-return a string which is inserted. It may set `facemenu-end-add-face'."
- :type '(choice (const :tag "None" nil)
- function)
- :group 'facemenu)
-
(defcustom facemenu-end-add-face nil
"String to insert or function called at end of text to change or nil.
This function is passed the FACE to set, and must return a string which is
@@ -299,6 +286,7 @@ May also be t meaning to use `facemenu-add-face-function'."
(defvar facemenu-color-alist nil
"Alist of colors, used for completion.
If this is nil, then the value of (defined-colors) is used.")
+(make-obsolete-variable 'facemenu-color-alist nil "28.1")
(defun facemenu-update ()
"Add or update the \"Face\" menu in the menu bar.
@@ -445,7 +433,7 @@ sets the CHARSET property of the character at point."
(interactive (list (progn
(barf-if-buffer-read-only)
(read-charset
- (format "Use charset (default %s): " (charset-after))
+ (format-prompt "Use charset" (charset-after))
(charset-after)))
(if (and mark-active (not current-prefix-arg))
(region-beginning))
@@ -546,6 +534,7 @@ filter out the color from the output."
This is installed as a `revert-buffer-function' in the *Colors* buffer."
(list-colors-display nil (buffer-name) list-colors-callback))
+;;;###autoload
(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
@@ -610,9 +599,14 @@ color. The function should accept a single argument, the color name."
(defun list-colors-print (list &optional callback)
(let ((callback-fn
- (if callback
- `(lambda (button)
- (funcall ,callback (button-get button 'color-name))))))
+ ;; Expect CALLBACK to be a function, but allow it to be a form that
+ ;; evaluates to a function, for backward-compatibility. (Bug#45831)
+ (cond ((functionp callback)
+ (lambda (button)
+ (funcall callback (button-get button 'color-name))))
+ (callback
+ `(lambda (button)
+ (funcall ,callback (button-get button 'color-name)))))))
(dolist (color list)
(if (consp color)
(if (cdr color)
@@ -621,12 +615,11 @@ color. The function should accept a single argument, the color name."
(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))))
+ (fg (readable-foreground-color (car color))))
(insert (car color))
(indent-to 22)
- (put-text-property opoint (point) 'face `(:background ,(car color)))
+ (put-text-property opoint (point) 'face `(:background ,(car color)
+ :foreground ,fg))
(put-text-property
(prog1 (point)
(insert " ")
@@ -639,7 +632,7 @@ color. The function should accept a single argument, the color name."
(insert (propertize
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (c) (ash c -8))
- color-values))
+ (color-values (car color))))
'mouse-face 'highlight
'help-echo
(let ((hsv (apply 'color-rgb-to-hsv
@@ -651,7 +644,7 @@ color. The function should accept a single argument, the color name."
opoint (point)
'follow-link t
'mouse-face (list :background (car color)
- :foreground (if light-p "black" "white"))
+ :foreground fg)
'color-name (car color)
'action callback-fn)))
(insert "\n"))
@@ -725,7 +718,13 @@ they are used to set the face information.
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")
+ (interactive (list (progn
+ (barf-if-buffer-read-only)
+ (read-face-name "Use face" (face-at-point t)))
+ (if (and mark-active (not current-prefix-arg))
+ (region-beginning))
+ (if (and mark-active (not current-prefix-arg))
+ (region-end))))
(cond
((and (eq face 'default)
(not (eq facemenu-remove-face-function t)))
@@ -821,11 +820,11 @@ This is called whenever you create a new face, and at other times."
symbol (intern name)))
(setq menu 'facemenu-face-menu)
(setq docstring
- (purecopy (format "Select face `%s' for subsequent insertion.
+ (format "Select face `%s' for subsequent insertion.
If the mark is active and there is no prefix argument,
apply face `%s' to the region instead.
This command was defined by `facemenu-add-new-face'."
- name name)))
+ name name))
(cond ((facemenu-iterate ; check if equivalent face is already in the menu
(lambda (m) (and (listp m)
(symbolp (car m))
@@ -838,15 +837,15 @@ This command was defined by `facemenu-add-new-face'."
(key
(setq function (intern (concat "facemenu-set-" name)))
(fset function
- `(lambda ()
- ,docstring
- (interactive)
- (facemenu-set-face
- (quote ,symbol)
- (if (and mark-active (not current-prefix-arg))
- (region-beginning))
- (if (and mark-active (not current-prefix-arg))
- (region-end)))))
+ (lambda ()
+ (:documentation docstring)
+ (interactive)
+ (facemenu-set-face
+ symbol
+ (if (and mark-active (not current-prefix-arg))
+ (region-beginning))
+ (if (and mark-active (not current-prefix-arg))
+ (region-end)))))
(define-key 'facemenu-keymap key (cons name function))
(define-key menu key (cons name function)))
;; Faces with no keyboard equivalent. Figure out where to put it:
diff --git a/lisp/faces.el b/lisp/faces.el
index 794343e88a9..4bb3a2b00fc 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -46,7 +46,7 @@ the terminal-initialization file to be loaded."
("vt320" . "vt200")
("vt400" . "vt200")
("vt420" . "vt200")
- )
+ ("alacritty" . "xterm"))
"Alist of terminal type aliases.
Entries are of the form (TYPE . ALIAS), where both elements are strings.
This means to treat a terminal of type TYPE as if it were of type ALIAS."
@@ -176,10 +176,28 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
;;; Creation, copying.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(make-obsolete-variable 'face-new-frame-defaults
+ "use `face--new-frame-defaults' or `face-alist' instead." "28.1")
+
+(defun frame-face-alist (&optional frame)
+ "Return an alist of frame-local faces defined on FRAME.
+This alist is a copy of the contents of `frame--face-hash-table'.
+For internal use only."
+ (declare (obsolete frame--face-hash-table "28.1"))
+ (let (faces)
+ (maphash (lambda (face spec)
+ (let ((face-id (car (gethash face face--new-frame-defaults))))
+ (push `(,face-id ,face . ,spec) faces)))
+ (frame--face-hash-table frame))
+ (mapcar #'cdr (sort faces (lambda (f1 f2) (< (car f1) (car f2)))))))
(defun face-list ()
"Return a list of all defined faces."
- (mapcar #'car face-new-frame-defaults))
+ (let (faces)
+ (maphash (lambda (face spec)
+ (push `(,(car spec) . ,face) faces))
+ face--new-frame-defaults)
+ (mapcar #'cdr (sort faces (lambda (f1 f2) (< (car f1) (car f2)))))))
(defun make-face (face)
"Define a new face with name FACE, a symbol.
@@ -272,7 +290,7 @@ of a face name is the same for all frames."
(defun face-equal (face1 face2 &optional frame)
"Non-nil if faces FACE1 and FACE2 are equal.
Faces are considered equal if all their attributes are equal.
-If the optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
+If optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames).
If FRAME is omitted or nil, use the selected frame."
(internal-lisp-face-equal-p face1 face2 frame))
@@ -484,7 +502,7 @@ FACES may be either a single face or a list of faces.
(defmacro face-attribute-specified-or (value &rest body)
- "Return VALUE, unless it's `unspecified', in which case evaluate BODY and return the result."
+ "Return VALUE or, if it's `unspecified', the result of evaluating BODY."
(let ((temp (make-symbol "value")))
`(let ((,temp ,value))
(if (not (eq ,temp 'unspecified))
@@ -1214,10 +1232,7 @@ Value is the new attribute value."
(setq name (concat (upcase (substring name 0 1)) (substring name 1)))
(let* ((completion-ignore-case t)
(value (completing-read
- (format-message (if default
- "%s for face `%s' (default %s): "
- "%s for face `%s': ")
- name face default)
+ (format-prompt "%s for face `%s'" default name face)
completion-alist nil nil nil nil default)))
(if (equal value "") default value)))
@@ -1264,7 +1279,15 @@ of a global face. Value is the new attribute value."
(or (car (rassoc old-value valid))
(format "%s" old-value))))
(setq new-value
- (face-read-string face default attribute-name valid))
+ (if (memq attribute '(:foreground :background))
+ (let ((color
+ (read-color
+ (format-prompt "%s for face `%s'"
+ default attribute-name face))))
+ (if (equal (string-trim color) "")
+ default
+ color))
+ (face-read-string face default attribute-name valid)))
(if (equal new-value default)
;; Nothing changed, so don't bother with all the stuff
;; below. In particular, this avoids a non-tty color
@@ -1562,7 +1585,7 @@ is given, in which case return its value instead."
;; return it to the caller. Since there will most definitely be something to
;; return in this case, there's no need to know/check if a match was found.
(if defaults
- (append result defaults)
+ (append defaults result)
(if match-found
result
no-match-retval))))
@@ -1787,16 +1810,42 @@ with the color they represent as background color."
(defined-colors frame)))
(defun readable-foreground-color (color)
- "Return a readable foreground color for background COLOR."
- (let* ((rgb (color-values color))
- (max (apply #'max rgb))
- (black (car (color-values "black")))
- (white (car (color-values "white"))))
- ;; Select black or white depending on which one is less similar to
- ;; the brightest component.
- (if (> (abs (- max black)) (abs (- max white)))
- "black"
- "white")))
+ "Return a readable foreground color for background COLOR.
+The returned value is a string representing black or white, depending
+on which one provides better contrast with COLOR."
+ ;; We use #ffffff instead of "white", because the latter is sometimes
+ ;; less than white. That way, we get the best contrast possible.
+ (if (color-dark-p (mapcar (lambda (c) (/ c 65535.0))
+ (color-values color)))
+ "#ffffff" "black"))
+
+(defconst color-luminance-dark-limit 0.325
+ "The relative luminance below which a color is considered 'dark'.
+A 'dark' color in this sense provides better contrast with white
+than with black; see `color-dark-p'.
+This value was determined experimentally.")
+
+(defun color-dark-p (rgb)
+ "Whether RGB is more readable against white than black.
+RGB is a 3-element list (R G B), each component in the range [0,1].
+This predicate can be used both for determining a suitable (black or white)
+contrast colour with RGB as background and as foreground."
+ (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)
+ (error "RGB components %S not in [0,1]" rgb))
+ ;; Compute the relative luminance after gamma-correcting (assuming sRGB),
+ ;; and compare to a cut-off value determined experimentally.
+ ;; See https://en.wikipedia.org/wiki/Relative_luminance for details.
+ (let* ((sr (nth 0 rgb))
+ (sg (nth 1 rgb))
+ (sb (nth 2 rgb))
+ ;; Gamma-correct the RGB components to linear values.
+ ;; Use the power 2.2 as an approximation to sRGB gamma;
+ ;; it should be good enough for the purpose of this function.
+ (r (expt sr 2.2))
+ (g (expt sg 2.2))
+ (b (expt sb 2.2))
+ (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
+ (< y color-luminance-dark-limit)))
(declare-function xw-color-defined-p "xfns.c" (color &optional frame))
@@ -1824,7 +1873,7 @@ 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).
+and 65535 inclusive.
Use `color-name-to-rgb' if you want RGB floating-point values
normalized to 1.0.
@@ -1896,12 +1945,11 @@ 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 (or facemenu-color-alist
- (append '("foreground at point" "background at point")
- (if allow-empty-name '(""))
- (if (display-color-p)
- (defined-colors-with-face-attributes)
- (defined-colors)))))
+ (colors (append '("foreground at point" "background at point")
+ (if allow-empty-name '(""))
+ (if (display-color-p)
+ (defined-colors-with-face-attributes)
+ (defined-colors))))
(color (completing-read
(or prompt "Color (name or #RGB triplet): ")
;; Completing function for reading colors, accepting
@@ -2085,10 +2133,28 @@ the X resource \"reverseVideo\" is present, handle that."
(unwind-protect
(progn
(x-setup-function-keys frame)
+ (dolist (face (nreverse (face-list)))
+ (face-spec-recalc face frame))
(x-handle-reverse-video frame parameters)
(frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
- (if (null visibility-spec)
+ ;; Mark frame as 'was-invisible' when it was created as
+ ;; invisible or iconified and PARAMETERS contains either a
+ ;; width or height specification. This should be sufficient
+ ;; to handle Bug#24526 (where a frame is initially iconified
+ ;; to allow manipulating its size in a non-obtrusive way) and
+ ;; avoid that a tiling window manager for GTK3 gets a resize
+ ;; request it cannot handle (Bug#48268). The 'was-invisible'
+ ;; flag is eventually processed in xterm.c after we receive a
+ ;; MapNotify event; non-X builds ignore it.
+ (frame--set-was-invisible
+ frame
+ (and visibility-spec
+ (memq (cdr visibility-spec) '(nil icon))
+ (or (assq 'width parameters)
+ (assq 'height parameters))))
+
+ (if (null visibility-spec)
(make-frame-visible frame)
(modify-frame-parameters frame (list visibility-spec)))
(setq success t))
@@ -2099,7 +2165,7 @@ the X resource \"reverseVideo\" is present, handle that."
(defun face-set-after-frame-default (frame &optional parameters)
"Initialize the frame-local faces of FRAME.
Calculate the face definitions using the face specs, custom theme
-settings, X resources, and `face-new-frame-defaults'.
+settings, X resources, and `face--new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
frame parameters in PARAMETERS."
;; The `reverse' is so that `default' goes first.
@@ -2108,7 +2174,7 @@ frame parameters in PARAMETERS."
(progn
;; Initialize faces from face spec and custom theme.
(face-spec-recalc face frame)
- ;; Apply attributes specified by face-new-frame-defaults
+ ;; 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)))
@@ -2178,7 +2244,7 @@ the above example."
(not (funcall pred type)))
;; Strip off last hyphen and what follows, then try again
(setq type
- (if (setq hyphend (string-match-p "[-_][^-_]+$" type))
+ (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type))
(substring type 0 hyphend)
nil))))
type)
@@ -2214,7 +2280,8 @@ If you set `term-file-prefix' to nil, this function does nothing."
(let ((file (locate-library (concat term-file-prefix type))))
(and file
(or (assoc file load-history)
- (load file t t)))))
+ (load (file-name-sans-extension file)
+ t t)))))
type)
;; Next, try to find a matching initialization function, and call it.
(tty-find-type #'(lambda (type)
@@ -2557,7 +2624,7 @@ non-nil."
:group 'basic-faces)
(defface mode-line-highlight
- '((((class color) (min-colors 88))
+ '((((supports :box t) (class color) (min-colors 88))
:box (:line-width 2 :color "grey40" :style released-button))
(t
:inherit highlight))
@@ -2616,9 +2683,9 @@ Use the face `mode-line-highlight' for features that can be selected."
:version "21.1"
:group 'basic-faces)
-(defface header-line-highlight '((t :inherit highlight))
+(defface header-line-highlight '((t :inherit mode-line-highlight))
"Basic header line face for highlighting."
- :version "26.1"
+ :version "28.1"
:group 'basic-faces)
(defface vertical-border
@@ -2662,11 +2729,20 @@ the same as `window-divider' face."
(defface internal-border
'((t nil))
- "Basic face for the internal border."
+ "Basic face for the internal border.
+For the internal border of child frames see `child-frame-border'."
:version "26.1"
:group 'frames
:group 'basic-faces)
+(defface child-frame-border
+ '((t nil))
+ "Basic face for the internal border of child frames.
+For the internal border of non-child frames see `internal-border'."
+ :version "28.1"
+ :group 'frames
+ :group 'basic-faces)
+
(defface minibuffer-prompt
'((((background dark)) :foreground "cyan")
;; Don't use blue because many users of the MS-DOS port customize
@@ -2695,9 +2771,11 @@ used to display the prompt text."
:group 'frames
:group 'basic-faces)
-(defface scroll-bar '((t nil))
+(defface scroll-bar
+ '((((background light)) :foreground "black")
+ (((background dark)) :foreground "white"))
"Basic face for the scroll bar colors under X."
- :version "21.1"
+ :version "28.1"
:group 'frames
:group 'basic-faces)
@@ -2783,6 +2861,30 @@ Note: Other faces cannot inherit from the cursor face."
"Face to highlight argument names in *Help* buffers."
:group 'help)
+(defface help-key-binding
+ '((((class color) (min-colors 88) (background light))
+ :background "grey96" :foreground "DarkBlue"
+ ;; We use negative thickness of the horizontal box border line to
+ ;; avoid enlarging the height of the echo-area display, which
+ ;; would then move the mode line a few pixels up.
+ :box (:line-width (1 . -1) :color "grey80"))
+ (((class color) (min-colors 88) (background dark))
+ :background "grey19" :foreground "LightBlue"
+ :box (:line-width (1 . -1) :color "grey35"))
+ (((class color grayscale) (background light)) :background "grey90")
+ (((class color grayscale) (background dark)) :background "grey25")
+ (t :background "grey90"))
+ "Face for keybindings in *Help* buffers.
+
+This face is added by `substitute-command-keys', which see.
+
+Note that this face will also be used for key bindings in
+tooltips. This means that, for example, changing the :height of
+this face will increase the height of any tooltip containing key
+bindings. See also the face `tooltip'."
+ :version "28.1"
+ :group 'help)
+
(defface glyphless-char
'((((type tty)) :inherit underline)
(((type pc)) :inherit escape-glyph)
@@ -2831,23 +2933,30 @@ It is used for characters of no fonts too."
;; Faces for TTY menus.
(defface tty-menu-enabled-face
- '((t
- :foreground "yellow" :background "blue" :weight bold))
+ '((((class color))
+ :foreground "yellow" :background "blue" :weight bold)
+ (t :weight bold))
"Face for displaying enabled items in TTY menus."
- :group 'basic-faces)
+ :group 'basic-faces
+ :version "28.1")
(defface tty-menu-disabled-face
'((((class color) (min-colors 16))
:foreground "lightgray" :background "blue")
- (t
- :foreground "white" :background "blue"))
+ (((class color))
+ :foreground "white" :background "blue")
+ (t :inherit shadow))
"Face for displaying disabled items in TTY menus."
- :group 'basic-faces)
+ :group 'basic-faces
+ :version "28.1")
(defface tty-menu-selected-face
- '((t :background "red"))
+ '((((class color))
+ :background "red")
+ (t :inverse-video t))
"Face for displaying the currently selected item in TTY menus."
- :group 'basic-faces)
+ :group 'basic-faces
+ :version "28.1")
(defgroup paren-showing-faces nil
"Faces used to highlight paren matches."
diff --git a/lisp/ffap.el b/lisp/ffap.el
index 88920ef5fff..b398d1c9f21 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -1,4 +1,4 @@
-;;; ffap.el --- find file (or url) at point
+;;; ffap.el --- find file (or url) at point -*- lexical-binding: t -*-
;; Copyright (C) 1995-1997, 2000-2021 Free Software Foundation, Inc.
@@ -54,6 +54,8 @@
;; C-x 5 r ffap-read-only-other-frame
;; C-x 5 d ffap-dired-other-frame
;;
+;; C-x t f ffap-other-tab
+;;
;; S-mouse-3 ffap-at-mouse
;; C-S-mouse-3 ffap-menu
;;
@@ -108,8 +110,6 @@
(require 'url-parse)
(require 'thingatpt)
-(define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2")
-
(defgroup ffap nil
"Find file or URL at point."
:group 'matching
@@ -260,6 +260,7 @@ ffap most of the time."
:type 'boolean
:group 'ffap)
+;;;###autoload
(defcustom ffap-file-finder 'find-file
"The command called by `find-file-at-point' to find a file."
:type 'function
@@ -301,15 +302,14 @@ disable ffap most of the time."
:version "20.3")
-;;; Compatibility:
-;;
-;; This version of ffap supports only the Emacs it is distributed in.
-;; See the ftp site for a more general version. The following
-;; functions are necessary "leftovers" from the more general version.
+;;; Obsolete:
(defun ffap-mouse-event () ; current mouse event, or nil
+ (declare (obsolete nil "28.1"))
(and (listp last-nonmenu-event) last-nonmenu-event))
+
(defun ffap-event-buffer (event)
+ (declare (obsolete nil "28.1"))
(window-buffer (car (event-start event))))
@@ -690,14 +690,13 @@ Optional DEPTH limits search depth."
(setq depth (1- depth))
(cons dir
(and (not (eq depth -1))
- (apply 'nconc
+ (apply #'nconc
(mapcar
- (function
- (lambda (d)
- (cond
- ((not (file-directory-p d)) nil)
- ((file-symlink-p d) (list d))
- (t (ffap-all-subdirs-loop d depth)))))
+ (lambda (d)
+ (cond
+ ((not (file-directory-p d)) nil)
+ ((file-symlink-p d) (list d))
+ (t (ffap-all-subdirs-loop d depth))))
(directory-files dir t "\\`[^.]")
)))))
@@ -710,13 +709,12 @@ Set to 0 to avoid all searching, or nil for no limit.")
The subdirs begin with the original directory, and the depth of the
search is bounded by `ffap-kpathsea-depth'. This is intended to mimic
kpathsea, a library used by some versions of TeX."
- (apply 'nconc
+ (apply #'nconc
(mapcar
- (function
- (lambda (dir)
- (if (string-match "[^/]//\\'" dir)
- (ffap-all-subdirs (substring dir 0 -2) ffap-kpathsea-depth)
- (list dir))))
+ (lambda (dir)
+ (if (string-match "[^/]//\\'" dir)
+ (ffap-all-subdirs (substring dir 0 -2) ffap-kpathsea-depth)
+ (list dir)))
path)))
(defun ffap-locate-file (file nosuffix path)
@@ -1049,22 +1047,19 @@ out of NAME."
"/pub/gnu/emacs/elisp-archive/"))
(substring name 2))))
-(defcustom ffap-rfc-path
- (concat (ffap-host-to-filename "ftp.rfc-editor.org") "/in-notes/rfc%s.txt")
+(defcustom ffap-rfc-path "https://www.rfc-editor.org/in-notes/rfc%s.txt"
"A `format' string making a filename for RFC documents.
-This can be an ange-ftp or Tramp remote filename to download, or
-a local filename if you have full set of RFCs locally. See also
-`ffap-rfc-directories'."
+This can be an URL, an ange-ftp or Tramp remote filename to
+download, or a local filename if you have the full set of RFCs
+locally. See also `ffap-rfc-directories'."
:type 'string
- :version "23.1"
- :group 'ffap)
+ :version "28.1")
(defcustom ffap-rfc-directories nil
"A list of directories to look for RFC files.
If a given RFC isn't in these then `ffap-rfc-path' is offered."
:type '(repeat directory)
- :version "23.1"
- :group 'ffap)
+ :version "23.1")
(defun ffap-rfc (name)
(let ((num (match-string 1 name)))
@@ -1080,7 +1075,7 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered."
;; Slightly controversial decisions:
;; * strip trailing "@", ":" and enclosing "{"/"}".
;; * no commas (good for latex)
- (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "{<@" "@>;.,!:}")
+ (file "--:\\\\${}+<>@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}")
;; An url, or maybe an email/news message-id:
(url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?")
;; Find a string that does *not* contain a colon:
@@ -1107,6 +1102,121 @@ The arguments CHARS, BEG and END are handled as described in
;; Added at suggestion of RHOGEE (for ff-paths), 7/24/95.
"Last string returned by the function `ffap-string-at-point'.")
+(defcustom ffap-file-name-with-spaces nil
+ "If non-nil, enable looking for paths with spaces in `ffap-string-at-point'.
+Enabling this variable may lead to `find-file-at-point' guessing
+wrong more often when trying to find a file name intermingled
+with normal text, but can be useful when working on systems that
+normally use spaces in file names (like Microsoft Windows and the
+like)."
+ :type 'boolean
+ :version "28.1")
+
+(defun ffap-search-backward-file-end (&optional dir-separator end)
+ "Search backward position point where file would probably end.
+Optional DIR-SEPARATOR defaults to \"/\". The search maximum is
+`line-end-position' or optional END point.
+
+Suppose the cursor is somewhere that might be near end of file,
+the guessing would position point before punctuation (like comma)
+after the file extension:
+
+ C:\temp\file.log, which contain ....
+ =============================== (before)
+ ---------------- (after)
+
+
+ C:\temp\file.log on Windows or /tmp/file.log on Unix
+ =============================== (before)
+ ---------------- (after)
+
+The strategy is to search backward until DIR-SEPARATOR which defaults to
+\"/\" and then take educated guesses.
+
+Move point and return point if an adjustment was done."
+ (unless dir-separator
+ (setq dir-separator "/"))
+ (let ((opoint (point))
+ point punct whitespace-p)
+ (when (re-search-backward
+ (regexp-quote dir-separator) (line-beginning-position) t)
+ ;; Move to the beginning of the match..
+ (forward-char 1)
+ ;; ... until typical punctuation.
+ (when (re-search-forward "\\([][<>()\"'`,.:;]\\)"
+ (or end
+ (line-end-position))
+ t)
+ (setq end (match-end 0))
+ (setq punct (match-string 1))
+ (setq whitespace-p (looking-at "[ \t\r\n]\\|$"))
+ (goto-char end)
+ (cond
+ ((and (string-equal punct ".")
+ whitespace-p) ;end of sentence
+ (setq point (1- (point))))
+ ((and (string-equal punct ".")
+ (looking-at "[a-zA-Z0-9.]+")) ;possibly file extension
+ (setq point (match-end 0)))
+ (t
+ (setq point (point)))))
+ (goto-char opoint)
+ (when point
+ (goto-char point)
+ point))))
+
+(defun ffap-search-forward-file-end (&optional dir-separator)
+ "Search DIR-SEPARATOR and position point at file's maximum ending.
+This includes spaces.
+Optional DIR-SEPARATOR defaults to \"/\".
+Call `ffap-search-backward-file-end' to refine the ending point."
+ (unless dir-separator
+ (setq dir-separator "/"))
+ (let* ((chars ;expected chars in file name
+ (concat "[^][^<>()\"'`;,#*|"
+ ;; exclude the opposite as we know the separator
+ (if (string-equal dir-separator "/")
+ "\\\\"
+ "/")
+ "\t\r\n]"))
+ (re (concat
+ chars "*"
+ (if dir-separator
+ (regexp-quote dir-separator)
+ "/")
+ chars "*")))
+ (when (looking-at re)
+ (goto-char (match-end 0)))))
+
+(defun ffap-dir-separator-near-point ()
+ "Search backward and forward for closest slash or backlash in line.
+Return string slash or backslash. Point is moved to closest position."
+ (let ((point (point))
+ str pos)
+ (when (looking-at ".*?/")
+ (setq str "/"
+ pos (match-end 0)))
+ (when (and (looking-at ".*?\\\\")
+ (or (null pos)
+ (< (match-end 0) pos)))
+ (setq str "\\"
+ pos (match-end 0)))
+ (goto-char point)
+ (when (and (re-search-backward "/" (line-beginning-position) t)
+ (or (null pos)
+ (< (- point (point)) (- pos point))))
+ (setq str "/"
+ pos (1+ (point)))) ;1+ to keep cursor at the end of char
+ (goto-char point)
+ (when (and (re-search-backward "\\\\" (line-beginning-position) t)
+ (or (null pos)
+ (< (- point (point)) (- pos point))))
+ (setq str "\\"
+ pos (1+ (point))))
+ (when pos
+ (goto-char pos))
+ str))
+
(defun ffap-string-at-point (&optional mode)
"Return a string of characters from around point.
@@ -1126,7 +1236,8 @@ Set the variables `ffap-string-at-point' and
When the region is active and larger than `ffap-max-region-length',
return an empty string, and set `ffap-string-at-point-region' to '(1 1)."
- (let* ((args
+ (let* (dir-separator
+ (args
(cdr
(or (assq (or mode major-mode) ffap-string-at-point-mode-alist)
(assq 'file ffap-string-at-point-mode-alist))))
@@ -1135,14 +1246,25 @@ return an empty string, and set `ffap-string-at-point-region' to '(1 1)."
(beg (if region-selected
(region-beginning)
(save-excursion
- (skip-chars-backward (car args))
- (skip-chars-forward (nth 1 args) pt)
+ (if (and ffap-file-name-with-spaces
+ (memq mode '(nil file)))
+ (when (setq dir-separator (ffap-dir-separator-near-point))
+ (while (re-search-backward
+ (regexp-quote dir-separator)
+ (line-beginning-position) t)
+ (goto-char (match-beginning 0))))
+ (skip-chars-backward (car args))
+ (skip-chars-forward (nth 1 args) pt))
(point))))
(end (if region-selected
(region-end)
(save-excursion
(skip-chars-forward (car args))
(skip-chars-backward (nth 2 args) pt)
+ (when (and ffap-file-name-with-spaces
+ (memq mode '(nil file)))
+ (ffap-search-forward-file-end dir-separator)
+ (ffap-search-backward-file-end dir-separator))
(point))))
(region-len (- (max beg end) (min beg end))))
@@ -1236,12 +1358,14 @@ Set to nil to disable matching gopher bookmarks.")
(defun ffap--gopher-var-on-line ()
"Return (KEY . VALUE) of gopher bookmark on current line."
(save-excursion
- (let ((eol (progn (end-of-line) (skip-chars-backward " ") (point)))
- (bol (progn (beginning-of-line) (point))))
- (when (re-search-forward ffap-gopher-regexp eol t)
- (let ((key (match-string 1))
- (val (buffer-substring-no-properties (match-end 0) eol)))
- (cons (intern (downcase key)) val))))))
+ (end-of-line)
+ (skip-chars-backward " ")
+ (let ((eol (point)))
+ (beginning-of-line)
+ (when (re-search-forward ffap-gopher-regexp eol t)
+ (let ((key (match-string 1))
+ (val (buffer-substring-no-properties (match-end 0) eol)))
+ (cons (intern (downcase key)) val))))))
(defun ffap-gopher-at-point ()
"If point is inside a gopher bookmark block, return its URL.
@@ -1256,7 +1380,8 @@ Sets the variable `ffap-string-at-point-region' to the bounds of URL, if any."
(point)))
(bookmark (cl-loop for keyval = (ffap--gopher-var-on-line)
while keyval collect keyval
- do (forward-line 1))))
+ do (forward-line 1)
+ until (eobp))))
(when bookmark
(setq ffap-string-at-point-region (list beg (point)))
(let-alist (nconc bookmark '((type . "1") (port . "70")))
@@ -1400,24 +1525,40 @@ which may actually result in an URL rather than a filename."
;; The solution here is to forcefully activate url-handler-mode, which
;; takes care of it for us.
+(defun ffap--url-file-handler (operation &rest args)
+ (let ((inhibit-file-name-handlers
+ (cons 'ffap--url-file-handler inhibit-file-name-handlers))
+ (inhibit-file-name-operation operation))
+ (cl-case operation
+ ;; We mainly just want to disable these bits:
+ (substitute-in-file-name (car args))
+ (expand-file-name
+ (if (equal (car args) "http://<remove>")
+ ""
+ (car args)))
+ (otherwise
+ (apply operation args)))))
+
(defun ffap-read-file-or-url (prompt guess)
"Read file or URL from minibuffer, with PROMPT and initial GUESS."
- (or guess (setq guess default-directory))
- ;; Tricky: guess may have or be a local directory, like "w3/w3.elc"
- ;; or "w3/" or "../el/ffap.el" or "../../../"
- (if (ffap-url-p guess)
- ;; FIXME: We earlier tried to make use of `url-file-handler' so
- ;; `read-file-name' could also be used for URLs, but it
- ;; introduced all kinds of subtle breakage such as:
- ;; - (file-name-directory "http://a") returning "http://a/"
- ;; - Trying to contact remote hosts with no justification
- ;; These should be fixed in url-handler-mode before we can try
- ;; using it here again.
- (read-string prompt guess nil nil t)
- (unless (ffap-file-remote-p guess)
- (setq guess (abbreviate-file-name (expand-file-name guess))))
- (read-file-name prompt (file-name-directory guess) nil nil
- (file-name-nondirectory guess))))
+ (let ((elem (cons ffap-url-regexp #'ffap--url-file-handler)))
+ (unwind-protect
+ (progn
+ (push elem file-name-handler-alist)
+ (if (ffap-url-p guess)
+ (read-file-name prompt "http://<remove>" nil nil guess)
+ (unless guess
+ (setq guess default-directory))
+ (unless (ffap-file-remote-p guess)
+ (setq guess (abbreviate-file-name (expand-file-name guess))))
+ (read-file-name prompt
+ (file-name-directory guess) nil nil
+ (file-name-nondirectory guess))))
+ ;; Remove the special handler manually. We used to just let-bind
+ ;; file-name-handler-alist to preserve its value, but that caused
+ ;; other modifications to be lost (e.g. when Tramp gets loaded
+ ;; during the completing-read call).
+ (setq file-name-handler-alist (delq elem file-name-handler-alist)))))
;; The rest of this page is just to work with package complete.el.
;; This code assumes that you load ffap.el after complete.el.
@@ -1551,9 +1692,8 @@ For example, try \":/\" for URL (and some FTP) references."
:type '(choice (const nil) regexp)
:group 'ffap)
-(defvar ffap-menu-alist nil
+(defvar-local ffap-menu-alist nil
"Buffer local cache of menu presented by `ffap-menu'.")
-(make-variable-buffer-local 'ffap-menu-alist)
(defvar ffap-menu-text-plist
(cond
@@ -1607,11 +1747,13 @@ Each ALIST entry looks like (STRING . DATA) and defines one choice.
Function CONT is applied to the entry chosen by the user."
;; Note: this function is used with a different continuation
;; by the ffap-url add-on package.
- ;; Could try rewriting to use easymenu.el or lmenu.el.
+ ;; Could try rewriting to use easymenu.el.
(let (choice)
(cond
;; Emacs mouse:
- ((and (fboundp 'x-popup-menu) (ffap-mouse-event))
+ ((and (fboundp 'x-popup-menu)
+ (listp last-nonmenu-event)
+ last-nonmenu-event)
(setq choice
(x-popup-menu
t
@@ -1624,7 +1766,7 @@ Function CONT is applied to the entry chosen by the user."
;; Bug: prompting may assume unique strings, no "".
(setq choice
(completing-read
- (format "%s (default %s): " title (car (car alist)))
+ (format-prompt title (car (car alist)))
alist nil t
;; (cons (car (car alist)) 0)
nil)))
@@ -1666,8 +1808,7 @@ Applies `ffap-menu-text-plist' text properties at all matches."
;; Remove duplicates.
(setq ffap-menu-alist ; sort by item
(sort ffap-menu-alist
- (function
- (lambda (a b) (string-lessp (car a) (car b))))))
+ (lambda (a b) (string-lessp (car a) (car b)))))
(let ((ptr ffap-menu-alist)) ; remove duplicates
(while (cdr ptr)
(if (equal (car (car ptr)) (car (car (cdr ptr))))
@@ -1675,8 +1816,7 @@ Applies `ffap-menu-text-plist' text properties at all matches."
(setq ptr (cdr ptr)))))
(setq ffap-menu-alist ; sort by position
(sort ffap-menu-alist
- (function
- (lambda (a b) (< (cdr a) (cdr b)))))))
+ (lambda (a b) (< (cdr a) (cdr b))))))
;;; Mouse Support (`ffap-at-mouse'):
@@ -1706,7 +1846,7 @@ Return value:
(ffap-guesser))))
(cond
(guess
- (set-buffer (ffap-event-buffer e))
+ (set-buffer (window-buffer (car (event-start e))))
(ffap-highlight)
(unwind-protect
(progn
@@ -1758,6 +1898,14 @@ Only intended for interactive use."
(set-window-dedicated-p win wdp))
value))
+(defun ffap-other-tab (filename)
+ "Like `ffap', but put buffer in another tab.
+Only intended for interactive use."
+ (interactive (list (ffap-prompter nil " other tab")))
+ (pcase (save-window-excursion (find-file-at-point filename))
+ ((or (and (pred bufferp) b) `(,(and (pred bufferp) b) . ,_))
+ (switch-to-buffer-other-tab b))))
+
(defun ffap--toggle-read-only (buffer-or-list)
(dolist (buffer (if (listp buffer-or-list)
buffer-or-list
@@ -1791,6 +1939,14 @@ Only intended for interactive use."
(ffap--toggle-read-only value)
value))
+(defun ffap-read-only-other-tab (filename)
+ "Like `ffap', but put buffer in another tab and mark as read-only.
+Only intended for interactive use."
+ (interactive (list (ffap-prompter nil " read only other tab")))
+ (let ((value (window-buffer (ffap-other-tab filename))))
+ (ffap--toggle-read-only value)
+ value))
+
(defun ffap-alternate-file (filename)
"Like `ffap' and `find-alternate-file'.
Only intended for interactive use."
@@ -1815,12 +1971,6 @@ Only intended for interactive use."
(defalias 'find-file-literally-at-point 'ffap-literally)
-;;; Bug Reporter:
-
-(define-obsolete-function-alias 'ffap-bug 'report-emacs-bug "23.1")
-(define-obsolete-function-alias 'ffap-submit-bug 'report-emacs-bug "23.1")
-
-
;;; Hooks for Gnus, VM, Rmail:
;;
;; If you do not like these bindings, write versions with whatever
@@ -2013,6 +2163,7 @@ This hook is intended to be put in `file-name-at-point-functions'."
(global-set-key [remap find-file-other-window] 'ffap-other-window)
(global-set-key [remap find-file-other-frame] 'ffap-other-frame)
+ (global-set-key [remap find-file-other-tab] 'ffap-other-tab)
(global-set-key [remap find-file-read-only-other-window] 'ffap-read-only-other-window)
(global-set-key [remap find-file-read-only-other-frame] 'ffap-read-only-other-frame)
diff --git a/lisp/filecache.el b/lisp/filecache.el
index 084f99f67ce..4223878b0e7 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -516,6 +516,16 @@ If called interactively, read the directory names one by one."
(concat directory "/")
directory)))
+(defun file-cache-cycle (name)
+ "Cycle through the directories that NAME is available in."
+ (let ((file-name (file-cache-file-name name)))
+ (if (string= file-name (minibuffer-contents))
+ (minibuffer-message file-cache-sole-match-message)
+ (delete-minibuffer-contents)
+ (insert file-name)
+ (if file-cache-multiple-directory-message
+ (minibuffer-message file-cache-multiple-directory-message)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Minibuffer functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -545,13 +555,7 @@ the name is considered already unique; only the second substitution
(cond
;; If it's the only match, replace the original contents
((or arg (eq completion t))
- (let ((file-name (file-cache-file-name string)))
- (if (string= file-name (minibuffer-contents))
- (minibuffer-message file-cache-sole-match-message)
- (delete-minibuffer-contents)
- (insert file-name)
- (if file-cache-multiple-directory-message
- (minibuffer-message file-cache-multiple-directory-message)))))
+ (file-cache-cycle string))
;; If it's the longest match, insert it
((consp completion)
@@ -564,10 +568,7 @@ the name is considered already unique; only the second substitution
file-cache-ignore-case))
(if (and (eq last-command this-command)
(string= file-cache-last-completion newstring))
- (progn
- (delete-minibuffer-contents)
- (insert (file-cache-file-name newstring))
- (setq file-cache-last-completion nil))
+ (file-cache-cycle newstring)
(minibuffer-message file-cache-non-unique-message)
(setq file-cache-last-completion string))
(setq file-cache-last-completion string)
@@ -579,20 +580,12 @@ the name is considered already unique; only the second substitution
(if (> (length completion-list) 1)
(progn
(delete-region (- (point-max) (length string)) (point-max))
- (save-excursion (insert newstring))
- (forward-char newpoint)
+ (insert newstring)
(with-output-to-temp-buffer file-cache-completions-buffer
(display-completion-list completion-list)
;; Add our own setup function to the Completions Buffer
(file-cache-completion-setup-function)))
- (let ((file-name (file-cache-file-name newstring)))
- (if (string= file-name (minibuffer-contents))
- (minibuffer-message file-cache-sole-match-message)
- (delete-minibuffer-contents)
- (insert file-name)
- (if file-cache-multiple-directory-message
- (minibuffer-message
- file-cache-multiple-directory-message)))))))))
+ (file-cache-cycle newstring))))))
;; No match
((eq completion nil)
@@ -614,9 +607,6 @@ the name is considered already unique; only the second substitution
(select-window (active-minibuffer-window))
(file-cache-minibuffer-complete nil)))
-(define-obsolete-function-alias 'file-cache-mouse-choose-completion
- #'file-cache-choose-completion "23.2")
-
(defun file-cache-complete ()
"Complete the word at point, using the filecache."
(interactive)
@@ -677,10 +667,6 @@ match REGEXP."
(insert (nth 1 item) (nth 0 item) "\n"))
(pop-to-buffer buf))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Keybindings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(provide 'filecache)
;;; filecache.el ends here
diff --git a/lisp/fileloop.el b/lisp/fileloop.el
index 2cd5bf1f714..45b9cea9397 100644
--- a/lisp/fileloop.el
+++ b/lisp/fileloop.el
@@ -4,18 +4,20 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -118,7 +120,10 @@ operating on the next file and nil otherwise."
(kill-all-local-variables)
(erase-buffer)
(setq new next)
- (insert-file-contents new nil))
+ (condition-case nil
+ (insert-file-contents new nil)
+ (file-missing
+ (fileloop-next-file novisit))))
new)))
(defun fileloop-continue ()
@@ -169,7 +174,8 @@ operating on the next file and nil otherwise."
(goto-char pos))
(push-mark original-point t))
- (switch-to-buffer (current-buffer))
+ (let (switch-to-buffer-preserve-window-point)
+ (switch-to-buffer (current-buffer)))
;; Now operate on the file.
;; If value is non-nil, continue to scan the next file.
@@ -204,30 +210,34 @@ operating on the next file and nil otherwise."
;;;###autoload
(defun fileloop-initialize-replace (from to files case-fold &optional delimited)
"Initialize a new round of query&replace on several files.
- FROM is a regexp and TO is the replacement to use.
- FILES describes the files, as in `fileloop-initialize'.
- CASE-FOLD can be t, nil, or `default':
- if it is nil, matching of FROM is case-sensitive.
- if it is t, matching of FROM is case-insensitive, except
- when `search-upper-case' is non-nil and FROM includes
- upper-case letters.
- if it is `default', the function uses the value of
- `case-fold-search' instead.
- DELIMITED if non-nil means replace only word-delimited matches."
+FROM is a regexp and TO is the replacement to use.
+FILES describes the files, as in `fileloop-initialize'.
+CASE-FOLD can be t, nil, or `default':
+ if it is nil, matching of FROM is case-sensitive.
+ if it is t, matching of FROM is case-insensitive, except
+ when `search-upper-case' is non-nil and FROM includes
+ upper-case letters.
+ if it is `default', the function uses the value of
+ `case-fold-search' instead.
+DELIMITED if non-nil means replace only word-delimited matches."
;; FIXME: Not sure how the delimited-flag interacts with the regexp-flag in
;; `perform-replace', so I just try to mimic the old code.
- (fileloop-initialize
- files
- (lambda ()
- (let ((case-fold-search (fileloop--case-fold from case-fold)))
- (if (re-search-forward from nil t)
- ;; When we find a match, move back
- ;; to the beginning of it so perform-replace
- ;; will see it.
- (goto-char (match-beginning 0)))))
- (lambda ()
- (let ((case-fold-search (fileloop--case-fold from case-fold)))
- (perform-replace from to t t delimited nil multi-query-replace-map)))))
+ (let ((mstart (make-hash-table :test 'eq)))
+ (fileloop-initialize
+ files
+ (lambda ()
+ (let ((case-fold-search (fileloop--case-fold from case-fold)))
+ (when (re-search-forward from nil t)
+ ;; When we find a match, save its beginning for
+ ;; `perform-replace' (we used to just set point, but this
+ ;; is unreliable in the face of
+ ;; `switch-to-buffer-preserve-window-point').
+ (puthash (current-buffer) (match-beginning 0) mstart))))
+ (lambda ()
+ (let ((case-fold-search (fileloop--case-fold from case-fold)))
+ (perform-replace from to t t delimited nil multi-query-replace-map
+ (gethash (current-buffer) mstart (point-min))
+ (point-max)))))))
(provide 'fileloop)
;;; fileloop.el ends here
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index 78571776a39..4fc7f0a8ec0 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -100,6 +100,7 @@ If it is registered in `file-notify-descriptors', a `stopped' event is sent."
"Handle a file system monitoring event, coming from backends.
If OBJECT is a filewatch event, call its callback.
Otherwise, signal a `file-notify-error'."
+ (declare (completion ignore))
(interactive "e")
(when file-notify-debug
(message "file-notify-handle-event %S" object))
@@ -504,7 +505,6 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'."
;; due to the way events are propagated during idle time. Note: This
;; may be perfectly acceptable.
-;; The end:
(provide 'filenotify)
;;; filenotify.el ends here
diff --git a/lisp/files-x.el b/lisp/files-x.el
index aaf842a3c22..9e1954256a6 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -1,4 +1,4 @@
-;;; files-x.el --- extended file handling commands
+;;; files-x.el --- extended file handling commands -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -45,9 +45,7 @@ Intended to be used in the `interactive' spec of
(symbol-name default)))
(variable
(completing-read
- (if default
- (format "%s (default %s): " prompt default)
- (format "%s: " prompt))
+ (format-prompt prompt default)
obarray
(lambda (sym)
(or (custom-variable-p sym)
@@ -65,9 +63,7 @@ Intended to be used in the `interactive' spec of
(let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
(value
(completing-read
- (if default
- (format "Add %s with value (default %s): " variable default)
- (format "Add %s with value: " variable))
+ (format-prompt "Add %s with value" default variable)
obarray
(lambda (sym)
(string-match-p "-mode\\'" (symbol-name sym)))
@@ -79,11 +75,8 @@ Intended to be used in the `interactive' spec of
((eq variable 'coding)
(let ((default (and (symbolp buffer-file-coding-system)
(symbol-name buffer-file-coding-system))))
- (read-coding-system
- (if default
- (format "Add %s with value (default %s): " variable default)
- (format "Add %s with value: " variable))
- default)))
+ (read-coding-system (format-prompt "Add %s with value" default variable)
+ default)))
(t
(let ((default (format "%S"
(cond ((eq variable 'unibyte) t)
@@ -102,9 +95,7 @@ Intended to be used in the `interactive' spec of
(let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
(mode
(completing-read
- (if default
- (format "Mode or subdirectory (default %s): " default)
- (format "Mode or subdirectory: "))
+ (format-prompt "Mode or subdirectory" default)
obarray
(lambda (sym)
(and (string-match-p "-mode\\'" (symbol-name sym))
@@ -579,13 +570,12 @@ from the MODE alist ignoring the input argument VALUE."
(defvar enable-connection-local-variables t
"Non-nil means enable use of connection-local variables.")
-(defvar connection-local-variables-alist nil
+(defvar-local connection-local-variables-alist nil
"Alist of connection-local variable settings in the current buffer.
Each element in this list has the form (VAR . VALUE), where VAR
is a connection-local variable (a symbol) and VALUE is its value.
The actual value in the buffer may differ from VALUE, if it is
changed by the user.")
-(make-variable-buffer-local 'connection-local-variables-alist)
(setq ignored-local-variables
(cons 'connection-local-variables-alist ignored-local-variables))
@@ -612,7 +602,7 @@ PROFILES is a list of connection profiles (symbols).")
"Normalize plist CRITERIA according to properties.
Return a reordered plist."
(apply
- 'append
+ #'append
(mapcar
(lambda (property)
(when (and (plist-member criteria property) (plist-get criteria property))
@@ -709,13 +699,14 @@ will not be changed."
(copy-tree connection-local-variables-alist)))
(hack-local-variables-apply)))
-(defsubst connection-local-criteria-for-default-directory ()
- "Return a connection-local criteria, which represents `default-directory'."
+(defsubst connection-local-criteria-for-default-directory (&optional application)
+ "Return a connection-local criteria, which represents `default-directory'.
+If APPLICATION is nil, the symbol `tramp' is used."
(when (file-remote-p default-directory)
- `(:application tramp
- :protocol ,(file-remote-p default-directory 'method)
- :user ,(file-remote-p default-directory 'user)
- :machine ,(file-remote-p default-directory 'host))))
+ `(:application ,(or application 'tramp)
+ :protocol ,(file-remote-p default-directory 'method)
+ :user ,(file-remote-p default-directory 'user)
+ :machine ,(file-remote-p default-directory 'host))))
;;;###autoload
(defmacro with-connection-local-variables (&rest body)
@@ -739,6 +730,16 @@ Execute BODY, and unwind connection-local variables."
;; No connection-local variables to apply.
,@body))
+;;;###autoload
+(defun path-separator ()
+ "The connection-local value of `path-separator'."
+ (with-connection-local-variables path-separator))
+
+;;;###autoload
+(defun null-device ()
+ "The connection-local value of `null-device'."
+ (with-connection-local-variables null-device))
+
(provide 'files-x)
diff --git a/lisp/files.el b/lisp/files.el
index 0a00b8b828a..2b13d04bcbe 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -191,20 +191,18 @@ if the file has changed on disk and you have not edited the buffer."
:type '(repeat regexp)
:group 'find-file)
-(defvar buffer-file-number nil
+(defvar-local buffer-file-number nil
"The device number and file number of the file visited in the current buffer.
The value is a list of the form (FILENUM DEVNUM).
This pair of numbers uniquely identifies the file.
If the buffer is visiting a new file, the value is nil.")
-(make-variable-buffer-local 'buffer-file-number)
(put 'buffer-file-number 'permanent-local t)
(defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt)))
"Non-nil means that `buffer-file-number' uniquely identifies files.")
-(defvar buffer-file-read-only nil
+(defvar-local buffer-file-read-only nil
"Non-nil if visited file was read-only when visited.")
-(make-variable-buffer-local 'buffer-file-read-only)
(defcustom small-temporary-file-directory
(if (eq system-type 'ms-dos) (getenv "TMPDIR"))
@@ -393,6 +391,10 @@ constructed by taking the directory part of the replaced file-name,
concatenated with the buffer file name with all directory separators
changed to `!' to prevent clashes. This will not work
correctly if your filesystem truncates the resulting name.
+If UNIQUIFY is one of the members of `secure-hash-algorithms',
+Emacs constructs the nondirectory part of the auto-save file name
+by applying that `secure-hash' to the buffer file name. This
+avoids any risk of excessively long file names.
All the transforms in the list are tried, in the order they are listed.
When one transform applies, its result is final;
@@ -405,7 +407,7 @@ editing a remote file.
On MS-DOS filesystems without long names this variable is always
ignored."
:group 'auto-save
- :type '(repeat (list (string :tag "Regexp") (string :tag "Replacement")
+ :type '(repeat (list (regexp :tag "Regexp") (string :tag "Replacement")
(boolean :tag "Uniquify")))
:initialize 'custom-initialize-delay
:version "21.1")
@@ -430,7 +432,13 @@ idle for `auto-save-visited-interval' seconds."
Unlike `auto-save-mode', this mode will auto-save buffer contents
to the visited files directly and will also run all save-related
-hooks. See Info node `Saving' for details of the save process."
+hooks. See Info node `Saving' for details of the save process.
+
+You can also set the buffer-local value of the variable
+`auto-save-visited-mode' to nil. A buffer where the buffer-local
+value of this variable is nil is ignored for the purpose of
+`auto-save-visited-mode', even if `auto-save-visited-mode' is
+enabled."
:group 'auto-save
:global t
(when auto-save--timer (cancel-timer auto-save--timer))
@@ -441,6 +449,7 @@ hooks. See Info node `Saving' for details of the save process."
#'save-some-buffers :no-prompt
(lambda ()
(and buffer-file-name
+ auto-save-visited-mode
(not (and buffer-auto-save-file-name
auto-save-visited-file-name))))))))
@@ -456,6 +465,31 @@ If `silently', don't ask the user before saving."
:type '(choice (const t) (const nil) (const silently))
:group 'abbrev)
+(defcustom lock-file-name-transforms nil
+ "Transforms to apply to buffer file name before making a lock file name.
+This has the same syntax as
+`auto-save-file-name-transforms' (which see), but instead of
+applying to auto-save file names, it's applied to lock file names.
+
+By default, a lock file is put into the same directory as the
+file it's locking, and it has the same name, but with \".#\" prepended."
+ :group 'files
+ :type '(repeat (list (regexp :tag "Regexp")
+ (string :tag "Replacement")
+ (boolean :tag "Uniquify")))
+ :version "28.1")
+
+(defcustom remote-file-name-inhibit-locks nil
+ "Whether to use file locks for remote files."
+ :group 'files
+ :version "28.1"
+ :type 'boolean)
+
+(define-minor-mode lock-file-mode
+ "Toggle file locking in the current buffer (Lock File mode)."
+ :version "28.1"
+ (setq-local create-lockfiles (and lock-file-mode t)))
+
(defcustom find-file-run-dired t
"Non-nil means allow `find-file' to visit directories.
To visit the directory, `find-file' runs `find-directory-functions'."
@@ -522,15 +556,14 @@ updates before the buffer is saved, use `before-save-hook'.")
(put 'write-file-functions 'permanent-local t)
;; I found some files still using the obsolete form in 2018.
-(defvar local-write-file-hooks nil)
-(make-variable-buffer-local 'local-write-file-hooks)
+(defvar-local local-write-file-hooks nil)
(put 'local-write-file-hooks 'permanent-local t)
(make-obsolete-variable 'local-write-file-hooks 'write-file-functions "22.1")
;; I found some files still using the obsolete form in 2018.
(define-obsolete-variable-alias 'write-contents-hooks
'write-contents-functions "22.1")
-(defvar write-contents-functions nil
+(defvar-local write-contents-functions nil
"List of functions to be called before writing out a buffer to a file.
Used only by `save-buffer'. If one of them returns non-nil, the
@@ -549,7 +582,6 @@ For hooks that _do_ pertain to the particular visited file, use
`write-file-functions' relate to how a buffer is saved to file.
To perform various checks or updates before the buffer is saved,
use `before-save-hook'.")
-(make-variable-buffer-local 'write-contents-functions)
(defcustom enable-local-variables t
"Control use of local variables in files you visit.
@@ -574,7 +606,9 @@ a -*- line.
The command \\[normal-mode], when used interactively,
always obeys file local variable specifications and the -*- line,
-and ignores this variable."
+and ignores this variable.
+
+Also see the `permanently-enabled-local-variables' variable."
:risky t
:type '(choice (const :tag "Query Unsafe" t)
(const :tag "Safe Only" :safe)
@@ -590,7 +624,7 @@ settings being applied, but still respect file-local ones.")
;; This is an odd variable IMO.
;; You might wonder why it is needed, when we could just do:
-;; (set (make-local-variable 'enable-local-variables) nil)
+;; (setq-local enable-local-variables nil)
;; These two are not precisely the same.
;; Setting this variable does not cause -*- mode settings to be
;; ignored, whereas setting enable-local-variables does.
@@ -745,10 +779,16 @@ resulting list of directory names. For an empty path element (i.e.,
a leading or trailing separator, or two adjacent separators), return
nil (meaning `default-directory') as the associated list element."
(when (stringp search-path)
- (mapcar (lambda (f)
- (if (equal "" f) nil
- (substitute-in-file-name (file-name-as-directory f))))
- (split-string search-path path-separator))))
+ (let ((spath (substitute-env-vars search-path)))
+ (mapcar (lambda (f)
+ (if (equal "" f) nil
+ (let ((dir (expand-file-name (file-name-as-directory f))))
+ ;; Previous implementation used `substitute-in-file-name'
+ ;; which collapse multiple "/" in front. Do the same for
+ ;; backward compatibility.
+ (if (string-match "\\`/+" dir)
+ (substring dir (1- (match-end 0))) dir))))
+ (split-string spath path-separator)))))
(defun cd-absolute (dir)
"Change current directory to given absolute file name DIR."
@@ -814,7 +854,9 @@ The path separator is colon in GNU and GNU-like systems."
(expand-file-name dir))
(locate-file dir cd-path nil
(lambda (f) (and (file-directory-p f) 'dir-ok)))
- (error "No such directory found via CDPATH environment variable"))))
+ (if (getenv "CDPATH")
+ (error "No such directory found via CDPATH environment variable: %s" dir)
+ (error "No such directory: %s" dir)))))
(defun directory-files-recursively (dir regexp
&optional include-directories predicate
@@ -875,6 +917,16 @@ recursion."
(push (concat dir "/" file) files)))))
(nconc result (nreverse files))))
+(defun directory-empty-p (dir)
+ "Return t if DIR names an existing directory containing no other files.
+Return nil if DIR does not name a directory, or if there was
+trouble determining whether DIR is a directory or empty.
+
+Symbolic links to directories count as directories.
+See `file-symlink-p' to distinguish symlinks."
+ (and (file-directory-p dir)
+ (null (directory-files dir nil directory-files-no-dot-files-regexp t 1))))
+
(defvar module-file-suffix)
(defun load-file (file)
@@ -887,6 +939,8 @@ recursion."
(read-file-name "Load file: " nil nil 'lambda))))
(load (expand-file-name file) nil nil t))
+(defvar comp-eln-to-el-h)
+
(defun locate-file (filename path &optional suffixes predicate)
"Search for FILENAME through PATH.
If found, return the absolute file name of FILENAME; otherwise
@@ -913,7 +967,10 @@ one or more of those symbols."
(logior (if (memq 'executable predicate) 1 0)
(if (memq 'writable predicate) 2 0)
(if (memq 'readable predicate) 4 0))))
- (locate-file-internal filename path suffixes predicate))
+ (let ((file (locate-file-internal filename path suffixes predicate)))
+ (if (and file (string-match "\\.eln\\'" file))
+ (gethash (file-name-nondirectory file) comp-eln-to-el-h)
+ file)))
(defun locate-file-completion-table (dirs suffixes string pred action)
"Do completion for file names passed to `locate-file'."
@@ -972,14 +1029,6 @@ one or more of those symbols."
(completion-table-with-context
string-dir names string-file pred action)))))
-(defun locate-file-completion (string path-and-suffixes action)
- "Do completion for file names passed to `locate-file'.
-PATH-AND-SUFFIXES is a pair of lists, (DIRECTORIES . SUFFIXES)."
- (declare (obsolete locate-file-completion-table "23.1"))
- (locate-file-completion-table (car path-and-suffixes)
- (cdr path-and-suffixes)
- string nil action))
-
(defvar locate-dominating-stop-dir-regexp
(purecopy "\\`\\(?:[\\/][\\/][^\\/]+[\\/]\\|/\\(?:net\\|afs\\|\\.\\.\\.\\)/\\)\\'")
"Regexp of directory names that stop the search in `locate-dominating-file'.
@@ -987,7 +1036,7 @@ Any directory whose name matches this regexp will be treated like
a kind of root directory by `locate-dominating-file', which will stop its
search when it bumps into it.
The default regexp prevents fruitless and time-consuming attempts to find
-special files in directories in which filenames are interpreted as hostnames,
+special files in directories in which file names are interpreted as host names,
or mount points potentially requiring authentication as a different user.")
(defun locate-dominating-file (file name)
@@ -1094,6 +1143,8 @@ REMOTE is non-nil, search on the remote host indicated by
(let ((default-directory (file-name-quote default-directory 'top)))
(locate-file command exec-path exec-suffixes 1))))
+(declare-function read-library-name "find-func" nil)
+
(defun load-library (library)
"Load the Emacs Lisp library named LIBRARY.
LIBRARY should be a string.
@@ -1103,12 +1154,7 @@ well as `load-file-rep-suffixes').
See Info node `(emacs)Lisp Libraries' for more details.
See `load-file' for a different interface to `load'."
- (interactive
- (let (completion-ignored-extensions)
- (list (completing-read "Load library: "
- (apply-partially 'locate-file-completion-table
- load-path
- (get-load-suffixes))))))
+ (interactive (list (read-library-name)))
(load library))
(defun file-remote-p (file &optional identification connected)
@@ -1390,7 +1436,7 @@ it means chase no more than that many links and then stop."
newname))
;; A handy function to display file sizes in human-readable form.
-;; See http://en.wikipedia.org/wiki/Kibibyte for the reference.
+;; See https://en.wikipedia.org/wiki/Kibibyte for the reference.
(defun file-size-human-readable (file-size &optional flavor space unit)
"Produce a string showing FILE-SIZE in human-readable form.
@@ -1561,8 +1607,8 @@ use with M-x."
(and (not (memq 'eight-bit-control charsets))
(not (memq 'eight-bit-graphic charsets)))))
(setq from-coding (read-coding-system
- (format "Recode filename %s from (default %s): "
- filename default-coding)
+ (format-prompt "Recode filename %s from"
+ filename default-coding)
default-coding))
(setq from-coding (read-coding-system
(format "Recode filename %s from: " filename))))
@@ -1574,8 +1620,8 @@ use with M-x."
(format "Recode filename %s from %s to: "
filename from-coding)))
(setq to-coding (read-coding-system
- (format "Recode filename %s from %s to (default %s): "
- filename from-coding default-coding)
+ (format-prompt "Recode filename %s from %s to"
+ default-coding filename from-coding)
default-coding)))
(list filename from-coding to-coding)))
@@ -1631,20 +1677,21 @@ called additional times).
This macro actually adds an auxiliary function that calls FUN,
rather than FUN itself, to `minibuffer-setup-hook'."
- (declare (indent 1) (debug t))
+ (declare (indent 1) (debug ([&or (":append" form) [&or symbolp form]] body)))
(let ((hook (make-symbol "setup-hook"))
(funsym (make-symbol "fun"))
(append nil))
(when (eq (car-safe fun) :append)
(setq append '(t) fun (cadr fun)))
`(let ((,funsym ,fun)
- ,hook)
- (setq ,hook
- (lambda ()
- ;; Clear out this hook so it does not interfere
- ;; with any recursive minibuffer usage.
- (remove-hook 'minibuffer-setup-hook ,hook)
- (funcall ,funsym)))
+ ;; Use a symbol to make sure `add-hook' doesn't waste time
+ ;; in `equal'ity testing (bug#46326).
+ (,hook (make-symbol "minibuffer-setup")))
+ (fset ,hook (lambda ()
+ ;; Clear out this hook so it does not interfere
+ ;; with any recursive minibuffer usage.
+ (remove-hook 'minibuffer-setup-hook ,hook)
+ (funcall ,funsym)))
(unwind-protect
(progn
(add-hook 'minibuffer-setup-hook ,hook ,@append)
@@ -1655,6 +1702,10 @@ rather than FUN itself, to `minibuffer-setup-hook'."
(list (read-file-name prompt nil default-directory mustmatch)
t))
+(defun file-name-history--add (file)
+ "Add FILE to `file-name-history'."
+ (add-to-history 'file-name-history (abbreviate-file-name file)))
+
(defun find-file (filename &optional wildcards)
"Edit file FILENAME.
Switch to a buffer visiting file FILENAME,
@@ -1838,6 +1889,10 @@ expand wildcards (if any) and replace the file with multiple files."
The buffer being killed is current while the hook is running.
See `kill-buffer'.
+This hook is not run for internal or temporary buffers created by
+`get-buffer-create' or `generate-new-buffer' with argument
+INHIBIT-BUFFER-HOOKS non-nil.
+
Note: Be careful with let-binding this hook considering it is
frequently used for cleanup.")
@@ -1917,6 +1972,8 @@ killed."
(setq buffer-file-truename otrue)
(setq dired-directory odir)
(lock-buffer)
+ (if (get-buffer oname)
+ (kill-buffer oname))
(rename-buffer oname)))
(unless (eq (current-buffer) obuf)
(with-current-buffer obuf
@@ -1937,7 +1994,7 @@ this function prepends a \"|\" to the final result if necessary."
(let ((lastname (file-name-nondirectory filename)))
(if (string= lastname "")
(setq lastname filename))
- (generate-new-buffer (if (string-match-p "\\` " lastname)
+ (generate-new-buffer (if (string-prefix-p " " lastname)
(concat "|" lastname)
lastname))))
@@ -2105,29 +2162,75 @@ think it does, because \"free\" is pretty hard to define in practice."
:version "25.1"
:type '(choice integer (const :tag "Never issue warning" nil)))
+(defcustom query-about-changed-file t
+ "If non-nil, query the user when re-visiting a file that has changed.
+This happens if the file is already visited in a buffer, the
+file was changed externally, and the user re-visits the file.
+
+If nil, don't prompt the user, but instead provide instructions for
+reverting, after switching to the buffer with its contents before
+the external changes."
+ :group 'files
+ :group 'find-file
+ :version "28.1"
+ :type 'boolean)
+
(declare-function x-popup-dialog "menu.c" (position contents &optional header))
+(defun files--ask-user-about-large-file-help-text (op-type size)
+ "Format the text that explains the options to open large files in Emacs.
+OP-TYPE contains the kind of file operation that will be
+performed. SIZE is the size of the large file."
+ (format
+ "The file that you want to %s is large (%s), which exceeds the
+ threshold above which Emacs asks for confirmation (%s).
+
+ Large files may be slow to edit or navigate so Emacs asks you
+ before you try to %s such files.
+
+ You can press:
+ 'y' to %s the file.
+ 'n' to abort, and not %s the file.
+ 'l' (the letter ell) to %s the file literally, which means that
+ Emacs will %s the file without doing any format or character code
+ conversion and in Fundamental mode, without loading any potentially
+ expensive features.
+
+ You can customize the option `large-file-warning-threshold' to be the
+ file size, in bytes, from which Emacs will ask for confirmation. Set
+ it to nil to never request confirmation."
+ op-type
+ size
+ (funcall byte-count-to-string-function large-file-warning-threshold)
+ op-type
+ op-type
+ op-type
+ op-type
+ op-type))
+
(defun files--ask-user-about-large-file (size op-type filename offer-raw)
+ "Query the user about what to do with large files.
+Files are \"large\" if file SIZE is larger than `large-file-warning-threshold'.
+
+OP-TYPE specifies the file operation being performed on FILENAME.
+
+If OFFER-RAW is true, give user the additional option to open the
+file literally."
(let ((prompt (format "File %s is large (%s), really %s?"
(file-name-nondirectory filename)
(funcall byte-count-to-string-function size) op-type)))
(if (not offer-raw)
(if (y-or-n-p prompt) nil 'abort)
- (let* ((use-dialog (and (display-popup-menus-p)
- last-input-event
- (listp last-nonmenu-event)
- use-dialog-box))
- (choice
- (if use-dialog
- (x-popup-dialog t `(,prompt
- ("Yes" . ?y)
- ("No" . ?n)
- ("Open literally" . ?l)))
- (read-char-from-minibuffer
- (concat prompt " (y)es or (n)o or (l)iterally ")
- '(?y ?Y ?n ?N ?l ?L)))))
- (cond ((memq choice '(?y ?Y)) nil)
- ((memq choice '(?l ?L)) 'raw)
+ (let ((choice
+ (car
+ (read-multiple-choice
+ prompt '((?y "yes")
+ (?n "no")
+ (?l "literally"))
+ (files--ask-user-about-large-file-help-text
+ op-type (funcall byte-count-to-string-function size))))))
+ (cond ((eq choice ?y) nil)
+ ((eq choice ?l) 'raw)
(t 'abort))))))
(defun abort-if-file-too-large (size op-type filename &optional offer-raw)
@@ -2227,7 +2330,8 @@ the various files."
;; Check to see if the file looks uncommonly large.
(when (not (or buf nowarn))
(when (eq (abort-if-file-too-large
- (file-attribute-size attributes) "open" filename t)
+ (file-attribute-size attributes) "open" filename
+ (not rawfile))
'raw)
(setf rawfile t))
(warn-maybe-out-of-memory (file-attribute-size attributes)))
@@ -2253,6 +2357,14 @@ the various files."
(message "Reverting file %s..." filename)
(revert-buffer t t)
(message "Reverting file %s...done" filename)))
+ ((not query-about-changed-file)
+ (message
+ (substitute-command-keys
+ "File %s changed on disk. \\[revert-buffer] to load new contents%s")
+ (file-name-nondirectory filename)
+ (if (buffer-modified-p buf)
+ " and discard your edits"
+ "")))
((yes-or-no-p
(if (string= (file-name-nondirectory filename)
(buffer-name buf))
@@ -2296,53 +2408,52 @@ the various files."
;; hexl-mode or image-mode.
(memq major-mode '(hexl-mode image-mode)))
(if (buffer-modified-p)
- (if (y-or-n-p
- (format
- (if rawfile
- "The file %s is already visited normally,
+ (if (let ((help-form
+ (format-message
+ (if rawfile "\
+The file %s is already visited normally,
and you have edited the buffer. Now you have asked to visit it literally,
meaning no coding system handling, format conversion, or local variables.
-Emacs can visit a file in only one way at a time.
-
-Do you want to save the file, and visit it literally instead? "
- "The file %s is already visited literally,
+Emacs can visit a file in only one way at a time."
+ "\
+The file %s is already visited literally,
meaning no coding system handling, format conversion, or local variables.
You have edited the buffer. Now you have asked to visit the file normally,
-but Emacs can visit a file in only one way at a time.
-
-Do you want to save the file, and visit it normally instead? ")
- (file-name-nondirectory filename)))
+but Emacs can visit a file in only one way at a time.")
+ (file-name-nondirectory filename))))
+ (y-or-n-p
+ (if rawfile "\
+Do you want to save the file, and visit it literally instead? " "\
+Do you want to save the file, and visit it normally instead? ")))
(progn
(save-buffer)
(find-file-noselect-1 buf filename nowarn
rawfile truename number))
(if (y-or-n-p
- (format
- (if rawfile
- "\
-Do you want to discard your changes, and visit the file literally now? "
- "\
-Do you want to discard your changes, and visit the file normally now? ")))
+ (if rawfile "\
+Do you want to discard your changes, and visit the file literally now? " "\
+Do you want to discard your changes, and visit the file normally now? "))
(find-file-noselect-1 buf filename nowarn
rawfile truename number)
(error (if rawfile "File already visited non-literally"
"File already visited literally"))))
- (if (y-or-n-p
- (format
- (if rawfile
- "The file %s is already visited normally.
+ (if (let ((help-form
+ (format-message
+ (if rawfile "\
+The file %s is already visited normally.
You have asked to visit it literally,
meaning no coding system decoding, format conversion, or local variables.
-But Emacs can visit a file in only one way at a time.
-
-Do you want to revisit the file literally now? "
- "The file %s is already visited literally,
+But Emacs can visit a file in only one way at a time."
+ "\
+The file %s is already visited literally,
meaning no coding system decoding, format conversion, or local variables.
You have asked to visit it normally,
-but Emacs can visit a file in only one way at a time.
-
-Do you want to revisit the file normally now? ")
- (file-name-nondirectory filename)))
+but Emacs can visit a file in only one way at a time.")
+ (file-name-nondirectory filename))))
+ (y-or-n-p
+ (if rawfile "\
+Do you want to revisit the file literally now? " "\
+Do you want to revisit the file normally now? ")))
(find-file-noselect-1 buf filename nowarn
rawfile truename number)
(error (if rawfile "File already visited non-literally"
@@ -2369,7 +2480,8 @@ Do you want to revisit the file normally now? ")
(set-buffer-multibyte t))
(if rawfile
(condition-case ()
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ (enable-local-variables nil))
(insert-file-contents-literally filename t))
(file-error
(when (and (file-exists-p filename)
@@ -2406,11 +2518,9 @@ Do you want to revisit the file normally now? ")
;; this is a permanent local, the major mode won't eliminate it.
(and backup-enable-predicate
(not (funcall backup-enable-predicate buffer-file-name))
- (progn
- (make-local-variable 'backup-inhibited)
- (setq backup-inhibited t)))
+ (setq-local backup-inhibited t))
(if rawfile
- (progn
+ (let ((enable-local-variables nil))
(set-buffer-multibyte nil)
(setq buffer-file-coding-system 'no-conversion)
(set-buffer-major-mode buf)
@@ -2518,23 +2628,20 @@ unless NOMODES is non-nil."
(let* (not-serious
(msg
(cond
- ((not warn) nil)
- ((and error (file-attributes buffer-file-name))
+ ((and error (file-exists-p buffer-file-name))
(setq buffer-read-only t)
- (if (and (file-symlink-p buffer-file-name)
- (not (file-exists-p
- (file-chase-links buffer-file-name))))
- "Symbolic link that points to nonexistent file"
- "File exists, but cannot be read"))
+ "File exists, but cannot be read")
+ ((and error (file-symlink-p buffer-file-name))
+ "Symbolic link that points to nonexistent file")
((not buffer-read-only)
- (if (and warn
- ;; No need to warn if buffer is auto-saved
- ;; under the name of the visited file.
- (not (and buffer-file-name
- auto-save-visited-file-name))
- (file-newer-than-file-p (or buffer-auto-save-file-name
- (make-auto-save-file-name))
- buffer-file-name))
+ (if (and
+ ;; No need to warn if buffer is auto-saved
+ ;; under the name of the visited file.
+ (not (and buffer-file-name
+ auto-save-visited-file-name))
+ (file-newer-than-file-p (or buffer-auto-save-file-name
+ (make-auto-save-file-name))
+ buffer-file-name))
(format "%s has auto save data; consider M-x recover-this-file"
(file-name-nondirectory buffer-file-name))
(setq not-serious t)
@@ -2542,14 +2649,13 @@ unless NOMODES is non-nil."
((not error)
(setq not-serious t)
"Note: file is write protected")
- ((file-attributes (directory-file-name default-directory))
+ ((file-accessible-directory-p default-directory)
"File not found and directory write-protected")
- ((file-exists-p (file-name-directory buffer-file-name))
- (setq buffer-read-only nil))
(t
(setq buffer-read-only nil)
- "Use M-x make-directory RET RET to create the directory and its parents"))))
- (when msg
+ (unless (file-directory-p default-directory)
+ "Use M-x make-directory RET RET to create the directory and its parents")))))
+ (when (and warn msg)
(message "%s" msg)
(or not-serious (sit-for 1 t))))
(when (and auto-save-default (not noauto))
@@ -2660,6 +2766,14 @@ since only a single case-insensitive search through the alist is made."
("\\.ltx\\'" . latex-mode)
("\\.dtx\\'" . doctex-mode)
("\\.org\\'" . org-mode)
+ ;; .dir-locals.el is not really Elisp. Could use the
+ ;; `dir-locals-file' constant if it weren't defined below.
+ ("\\.dir-locals\\(?:-2\\)?\\.el\\'" . lisp-data-mode)
+ ("eww-bookmarks\\'" . lisp-data-mode)
+ ("tramp\\'" . lisp-data-mode)
+ ("/archive-contents\\'" . lisp-data-mode)
+ ("places\\'" . lisp-data-mode)
+ ("\\.emacs-places\\'" . lisp-data-mode)
("\\.el\\'" . emacs-lisp-mode)
("Project\\.ede\\'" . emacs-lisp-mode)
("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode)
@@ -2670,8 +2784,6 @@ since only a single case-insensitive search through the alist is made."
("\\.p\\'" . pascal-mode)
("\\.pas\\'" . pascal-mode)
("\\.\\(dpr\\|DPR\\)\\'" . delphi-mode)
- ("\\.ad[abs]\\'" . ada-mode)
- ("\\.ad[bs]\\.dg\\'" . ada-mode)
("\\.\\([pP]\\([Llm]\\|erl\\|od\\)\\|al\\)\\'" . perl-mode)
("Imakefile\\'" . makefile-imake-mode)
("Makeppfile\\(?:\\.mk\\)?\\'" . makefile-makepp-mode) ; Put this before .mk
@@ -2709,6 +2821,7 @@ since only a single case-insensitive search through the alist is made."
("\\.scm\\.[0-9]*\\'" . scheme-mode)
("\\.[ckz]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode)
("\\.bash\\'" . sh-mode)
+ ("/PKGBUILD\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(bash_\\(profile\\|history\\|log\\(in\\|out\\)\\)\\|z?log\\(in\\|out\\)\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\(shrc\\|zshrc\\|m?kshrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode)
("\\(/\\|\\`\\)\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode)
@@ -2749,8 +2862,8 @@ 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\\|cbr\\|7z\\|\
-ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\)\\'" . archive-mode)
+arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|cbr\\|7z\\|squashfs\\|\
+ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . archive-mode)
("\\.oxt\\'" . archive-mode) ;(Open|Libre)Office extensions.
("\\.\\(deb\\|[oi]pk\\)\\'" . archive-mode) ; Debian/Opkg packages.
;; Mailer puts message to be edited in
@@ -2896,7 +3009,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\)\\'" . archive-mo
("\\.xmp\\'" . image-mode)
("\\.xwd\\'" . image-mode)
("\\.yuv\\'" . image-mode)))
- "Alist of filename patterns vs corresponding major mode functions.
+ "Alist of file name patterns vs corresponding major mode functions.
Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL).
\(NON-NIL stands for anything that is not nil; the value does not matter.)
Visiting a file whose name matches REGEXP specifies FUNCTION as the
@@ -3058,7 +3171,7 @@ If FUNCTION is nil, then it is not called. (That is a way of saying
"\\(?:!DOCTYPE[ \t\r\n]+[^>]*>[ \t\r\n]*<[ \t\r\n]*" comment-re "*\\)?"
"[Hh][Tt][Mm][Ll]"))
. mhtml-mode)
- ("<!DOCTYPE[ \t\r\n]+[Hh][Tt][Mm][Ll]" . mhtml-mode)
+ ("<![Dd][Oo][Cc][Tt][Yy][Pp][Ee][ \t\r\n]+[Hh][Tt][Mm][Ll]" . mhtml-mode)
;; These two must come after html, because they are more general:
("<\\?xml " . xml-mode)
(,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)")
@@ -3082,14 +3195,73 @@ If FUNCTION is nil, then it is not called.")
"Upper limit on `magic-mode-alist' regexp matches.
Also applies to `magic-fallback-mode-alist'.")
+(defun set-auto-mode--apply-alist (alist keep-mode-if-same dir-local)
+ "Helper function for `set-auto-mode'.
+This function takes an alist of the same form as
+`auto-mode-alist'. It then tries to find the appropriate match
+in the alist for the current buffer; setting the mode if
+possible.
+Return non-nil if the mode was set, nil otherwise.
+DIR-LOCAL non-nil means this call is via directory-locals, and
+extra checks should be done."
+ (if buffer-file-name
+ (let (mode
+ (name buffer-file-name)
+ (remote-id (file-remote-p buffer-file-name))
+ (case-insensitive-p (file-name-case-insensitive-p
+ buffer-file-name)))
+ ;; Remove backup-suffixes from file name.
+ (setq name (file-name-sans-versions name))
+ ;; Remove remote file name identification.
+ (when (and (stringp remote-id)
+ (string-match (regexp-quote remote-id) name))
+ (setq name (substring name (match-end 0))))
+ (while name
+ ;; Find first matching alist entry.
+ (setq mode
+ (if case-insensitive-p
+ ;; Filesystem is case-insensitive.
+ (let ((case-fold-search t))
+ (assoc-default name alist 'string-match))
+ ;; Filesystem is case-sensitive.
+ (or
+ ;; First match case-sensitively.
+ (let ((case-fold-search nil))
+ (assoc-default name alist 'string-match))
+ ;; Fallback to case-insensitive match.
+ (and auto-mode-case-fold
+ (let ((case-fold-search t))
+ (assoc-default name alist 'string-match))))))
+ (if (and mode
+ (consp mode)
+ (cadr mode))
+ (setq mode (car mode)
+ name (substring name 0 (match-beginning 0)))
+ (setq name nil)))
+ (when (and dir-local mode
+ (not (set-auto-mode--dir-local-valid-p mode)))
+ (message "Ignoring invalid mode `%s'" mode)
+ (setq mode nil))
+ (when mode
+ (set-auto-mode-0 mode keep-mode-if-same)
+ t))))
+
+(defun set-auto-mode--dir-local-valid-p (mode)
+ "Say whether MODE can be used in a .dir-local.el `auto-mode-alist'."
+ (and (symbolp mode)
+ (string-suffix-p "-mode" (symbol-name mode))
+ (commandp mode)
+ (not (provided-mode-derived-p mode 'special-mode))))
+
(defun set-auto-mode (&optional keep-mode-if-same)
"Select major mode appropriate for current buffer.
To find the right major mode, this function checks for a -*- mode tag
checks for a `mode:' entry in the Local Variables section of the file,
+checks if there an `auto-mode-alist' entry in `.dir-locals.el',
checks if it uses an interpreter listed in `interpreter-mode-alist',
matches the buffer beginning against `magic-mode-alist',
-compares the filename against the entries in `auto-mode-alist',
+compares the file name against the entries in `auto-mode-alist',
then matches the buffer beginning against `magic-fallback-mode-alist'.
If `enable-local-variables' is nil, or if the file name matches
@@ -3143,13 +3315,16 @@ we don't actually set it to the same mode the buffer already has."
(or (set-auto-mode-0 mode keep-mode-if-same)
;; continuing would call minor modes again, toggling them off
(throw 'nop nil))))))
- ;; hack-local-variables checks local-enable-local-variables etc, but
- ;; we might as well be explicit here for the sake of clarity.
+ ;; Check for auto-mode-alist entry in dir-locals.
+ (unless done
+ (with-demoted-errors "Directory-local variables error: %s"
+ ;; Note this is a no-op if enable-local-variables is nil.
+ (let* ((mode-alist (cdr (hack-dir-local--get-variables
+ (lambda (key) (eq key 'auto-mode-alist))))))
+ (setq done (set-auto-mode--apply-alist mode-alist
+ keep-mode-if-same t)))))
(and (not done)
- enable-local-variables
- local-enable-local-variables
- try-locals
- (setq mode (hack-local-variables t))
+ (setq mode (hack-local-variables t (not try-locals)))
(not (memq mode modes)) ; already tried and failed
(if (not (functionp mode))
(message "Ignoring unknown mode `%s'" mode)
@@ -3199,45 +3374,8 @@ we don't actually set it to the same mode the buffer already has."
(set-auto-mode-0 done keep-mode-if-same)))
;; Next compare the filename against the entries in auto-mode-alist.
(unless done
- (if buffer-file-name
- (let ((name buffer-file-name)
- (remote-id (file-remote-p buffer-file-name))
- (case-insensitive-p (file-name-case-insensitive-p
- buffer-file-name)))
- ;; Remove backup-suffixes from file name.
- (setq name (file-name-sans-versions name))
- ;; Remove remote file name identification.
- (when (and (stringp remote-id)
- (string-match (regexp-quote remote-id) name))
- (setq name (substring name (match-end 0))))
- (while name
- ;; Find first matching alist entry.
- (setq mode
- (if case-insensitive-p
- ;; Filesystem is case-insensitive.
- (let ((case-fold-search t))
- (assoc-default name auto-mode-alist
- 'string-match))
- ;; Filesystem is case-sensitive.
- (or
- ;; First match case-sensitively.
- (let ((case-fold-search nil))
- (assoc-default name auto-mode-alist
- 'string-match))
- ;; Fallback to case-insensitive match.
- (and auto-mode-case-fold
- (let ((case-fold-search t))
- (assoc-default name auto-mode-alist
- 'string-match))))))
- (if (and mode
- (consp mode)
- (cadr mode))
- (setq mode (car mode)
- name (substring name 0 (match-beginning 0)))
- (setq name nil))
- (when mode
- (set-auto-mode-0 mode keep-mode-if-same)
- (setq done t))))))
+ (setq done (set-auto-mode--apply-alist auto-mode-alist
+ keep-mode-if-same nil)))
;; Next try matching the buffer beginning against magic-fallback-mode-alist.
(unless done
(if (setq done (save-excursion
@@ -3331,13 +3469,27 @@ Major modes can use this to examine user-specified local variables
in order to initialize other data structure based on them.")
(defcustom safe-local-variable-values nil
- "List variable-value pairs that are considered safe.
+ "List of variable-value pairs that are considered safe.
Each element is a cons cell (VAR . VAL), where VAR is a variable
-symbol and VAL is a value that is considered safe."
+symbol and VAL is a value that is considered safe.
+
+Also see `ignored-local-variable-values'."
:risky t
:group 'find-file
:type 'alist)
+(defcustom ignored-local-variable-values nil
+ "List of variable-value pairs that should always be ignored.
+Each element is a cons cell (VAR . VAL), where VAR is a variable
+symbol and VAL is its value; if VAR is set to VAL by a file-local
+variables section, that setting should be ignored.
+
+Also see `safe-local-variable-values'."
+ :risky t
+ :group 'find-file
+ :type 'alist
+ :version "28.1")
+
(defcustom safe-local-eval-forms
;; This should be here at least as long as Emacs supports write-file-hooks.
'((add-hook 'write-file-hooks 'time-stamp)
@@ -3422,23 +3574,21 @@ asking you for confirmation."
(put 'c-set-style 'safe-local-eval-function t)
-(defvar file-local-variables-alist nil
+(defvar-local file-local-variables-alist nil
"Alist of file-local variable settings in the current buffer.
Each element in this list has the form (VAR . VALUE), where VAR
is a file-local variable (a symbol) and VALUE is the value
specified. The actual value in the buffer may differ from VALUE,
if it is changed by the major or minor modes, or by the user.")
-(make-variable-buffer-local 'file-local-variables-alist)
(put 'file-local-variables-alist 'permanent-local t)
-(defvar dir-local-variables-alist nil
+(defvar-local dir-local-variables-alist nil
"Alist of directory-local variable settings in the current buffer.
Each element in this list has the form (VAR . VALUE), where VAR
is a directory-local variable (a symbol) and VALUE is the value
specified in .dir-locals.el. The actual value in the buffer
may differ from VALUE, if it is changed by the major or minor modes,
or by the user.")
-(make-variable-buffer-local 'dir-local-variables-alist)
(defvar before-hack-local-variables-hook nil
"Normal hook run before setting file-local variables.
@@ -3450,6 +3600,10 @@ function is allowed to change the contents of this alist.
This hook is called only if there is at least one file-local
variable to set.")
+(defvar permanently-enabled-local-variables '(lexical-binding)
+ "A list of local variables that are always enabled.
+This overrides any `enable-local-variables' setting.")
+
(defun hack-local-variables-confirm (all-vars unsafe-vars risky-vars dir-name)
"Get confirmation before setting up local variable values.
ALL-VARS is the list of all variables to be set up.
@@ -3486,7 +3640,9 @@ n -- to ignore the local variables list.")
(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")
+ values (*) as safe (in the future, they will be set automatically.)
+i -- to ignore the local variables list, and permanently mark these
+ values (*) as ignored\n\n")
(insert "\n\n"))
(dolist (elt all-vars)
(cond ((member elt unsafe-vars)
@@ -3501,7 +3657,7 @@ n -- to ignore the local variables list.")
(let ((print-escape-newlines t))
(prin1 (cdr elt) buf))
(insert "\n"))
- (set (make-local-variable 'cursor-type) nil)
+ (setq-local cursor-type nil)
(set-buffer-modified-p nil)
(goto-char (point-min)))
@@ -3510,16 +3666,24 @@ n -- to ignore the local variables list.")
(pop-to-buffer buf '(display-buffer--maybe-at-bottom))
(let* ((exit-chars '(?y ?n ?\s))
(prompt (format "Please type %s%s: "
- (if offer-save "y, n, or !" "y or n")
+ (if offer-save "y, n, ! or i" "y or n")
(if (< (line-number-at-pos (point-max))
(window-body-height))
""
", or C-v/M-v to scroll")))
char)
- (if offer-save (push ?! exit-chars))
- (setq char (read-char-from-minibuffer prompt exit-chars))
- (when (and offer-save (= char ?!) unsafe-vars)
- (customize-push-and-save 'safe-local-variable-values unsafe-vars))
+ (when offer-save
+ (push ?i exit-chars)
+ (push ?! exit-chars))
+ (setq char (read-char-choice prompt exit-chars))
+ (when (and offer-save
+ (or (= char ?!) (= char ?i))
+ unsafe-vars)
+ (customize-push-and-save
+ (if (= char ?!)
+ 'safe-local-variable-values
+ 'ignored-local-variable-values)
+ unsafe-vars))
(prog1 (memq char '(?! ?\s ?y))
(quit-window t)))))))
@@ -3612,13 +3776,18 @@ 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)
+ (let (all-vars risky-vars unsafe-vars ignored)
(dolist (elt variables)
(let ((var (car elt))
(val (cdr elt)))
(cond ((memq var ignored-local-variables)
;; Ignore any variable in `ignored-local-variables'.
nil)
+ ((seq-some (lambda (elem)
+ (and (eq (car elem) var)
+ (eq (cdr elem) val)))
+ ignored-local-variable-values)
+ nil)
;; Obey `enable-local-eval'.
((eq var 'eval)
(when enable-local-eval
@@ -3663,25 +3832,26 @@ DIR-NAME is the name of the associated directory. Otherwise it is nil."
;; TODO? Warn once per file rather than once per session?
(defvar hack-local-variables--warned-lexical nil)
-(defun hack-local-variables (&optional handle-mode)
+(defun hack-local-variables (&optional handle-mode inhibit-locals)
"Parse and put into effect this buffer's local variables spec.
For buffers visiting files, also puts into effect directory-local
variables.
-Uses `hack-local-variables-apply' to apply the variables.
-If HANDLE-MODE is nil, we apply all the specified local
-variables. If HANDLE-MODE is neither nil nor t, we do the same,
-except that any settings of `mode' are ignored.
+Uses `hack-local-variables-apply' to apply the variables.
-If HANDLE-MODE is t, all we do is check whether a \"mode:\"
-is specified, and return the corresponding mode symbol, or nil.
-In this case, we try to ignore minor-modes, and return only a
-major-mode.
+See `hack-local-variables--find-variables' for the meaning of
+HANDLE-MODE.
-If `enable-local-variables' or `local-enable-local-variables' is nil,
-this function does nothing. If `inhibit-local-variables-regexps'
+If `enable-local-variables' or `local-enable-local-variables' is
+nil, or INHIBIT-LOCALS is non-nil, this function disregards all
+normal local variables. If `inhibit-local-variables-regexps'
applies to the file in question, the file is not scanned for
-local variables, but directory-local variables may still be applied."
+local variables, but directory-local variables may still be
+applied.
+
+Variables present in `permanently-enabled-local-variables' will
+still be evaluated, even if local variables are otherwise
+inhibited."
;; We don't let inhibit-local-variables-p influence the value of
;; enable-local-variables, because then it would affect dir-local
;; variables. We don't want to search eg tar files for file local
@@ -3689,9 +3859,18 @@ local variables, but directory-local variables may still be applied."
;; to them. The real meaning of inhibit-local-variables-p is "do
;; not scan this file for local variables".
(let ((enable-local-variables
- (and local-enable-local-variables enable-local-variables))
- result)
- (unless (eq handle-mode t)
+ (and (not inhibit-locals)
+ local-enable-local-variables enable-local-variables)))
+ (if (eq handle-mode t)
+ ;; We're looking just for the major mode setting.
+ (and enable-local-variables
+ (not (inhibit-local-variables-p))
+ ;; If HANDLE-MODE is t, and the prop line specifies a
+ ;; mode, then we're done, and have no need to scan further.
+ (or (hack-local-variables-prop-line t)
+ ;; Look for the mode elsewhere in the buffer.
+ (hack-local-variables--find-variables t)))
+ ;; Normal handling of local variables.
(setq file-local-variables-alist nil)
(when (and (file-remote-p default-directory)
(fboundp 'hack-connection-local-variables)
@@ -3702,133 +3881,138 @@ local variables, but directory-local variables may still be applied."
(connection-local-criteria-for-default-directory))))
(with-demoted-errors "Directory-local variables error: %s"
;; Note this is a no-op if enable-local-variables is nil.
- (hack-dir-local-variables)))
- ;; This entire function is basically a no-op if enable-local-variables
- ;; is nil. All it does is set file-local-variables-alist to nil.
- (when enable-local-variables
- ;; This part used to ignore enable-local-variables when handle-mode
- ;; was t. That was inappropriate, eg consider the
- ;; (artificial) example of:
- ;; (setq local-enable-local-variables nil)
- ;; Open a file foo.txt that contains "mode: sh".
- ;; It correctly opens in text-mode.
- ;; M-x set-visited-file name foo.c, and it incorrectly stays in text-mode.
- (unless (or (inhibit-local-variables-p)
- ;; If HANDLE-MODE is t, and the prop line specifies a
- ;; mode, then we're done, and have no need to scan further.
- (and (setq result (hack-local-variables-prop-line
- handle-mode))
- (eq handle-mode t)))
- ;; Look for "Local variables:" line in last page.
- (save-excursion
- (goto-char (point-max))
- (search-backward "\n\^L" (max (- (point-max) 3000) (point-min))
- 'move)
- (when (let ((case-fold-search t))
- (search-forward "Local Variables:" nil t))
- (skip-chars-forward " \t")
- ;; suffix is what comes after "local variables:" in its line.
- ;; prefix is what comes before "local variables:" in its line.
- (let ((suffix
- (concat
- (regexp-quote (buffer-substring (point)
- (line-end-position)))
- "$"))
- (prefix
- (concat "^" (regexp-quote
- (buffer-substring (line-beginning-position)
- (match-beginning 0))))))
-
- (forward-line 1)
- (let ((startpos (point))
- endpos
- (thisbuf (current-buffer)))
- (save-excursion
- (unless (let ((case-fold-search t))
- (re-search-forward
- (concat prefix "[ \t]*End:[ \t]*" suffix)
- nil t))
- ;; This used to be an error, but really all it means is
- ;; that this may simply not be a local-variables section,
- ;; so just ignore it.
- (message "Local variables list is not properly terminated"))
- (beginning-of-line)
- (setq endpos (point)))
-
- (with-temp-buffer
- (insert-buffer-substring thisbuf startpos endpos)
- (goto-char (point-min))
- (subst-char-in-region (point) (point-max) ?\^m ?\n)
- (while (not (eobp))
- ;; Discard the prefix.
- (if (looking-at prefix)
- (delete-region (point) (match-end 0))
- (error "Local variables entry is missing the prefix"))
- (end-of-line)
- ;; Discard the suffix.
- (if (looking-back suffix (line-beginning-position))
- (delete-region (match-beginning 0) (point))
- (error "Local variables entry is missing the suffix"))
- (forward-line 1))
- (goto-char (point-min))
-
- (while (not (or (eobp)
- (and (eq handle-mode t) result)))
- ;; Find the variable name;
- (unless (looking-at hack-local-variable-regexp)
- (error "Malformed local variable line: %S"
- (buffer-substring-no-properties
- (point) (line-end-position))))
- (goto-char (match-end 1))
- (let* ((str (match-string 1))
- (var (intern str))
- val val2)
- (and (equal (downcase (symbol-name var)) "mode")
- (setq var 'mode))
- ;; Read the variable value.
- (skip-chars-forward "^:")
- (forward-char 1)
- ;; As a defensive measure, we do not allow
- ;; circular data in the file-local data.
- (let ((read-circle nil))
- (setq val (read (current-buffer))))
- (if (eq handle-mode t)
- (and (eq var 'mode)
- ;; Specifying minor-modes via mode: is
- ;; deprecated, but try to reject them anyway.
- (not (string-match
- "-minor\\'"
- (setq val2 (downcase (symbol-name val)))))
- (setq result (intern (concat val2 "-mode"))))
- (cond ((eq var 'coding))
- ((eq var 'lexical-binding)
- (unless hack-local-variables--warned-lexical
- (setq hack-local-variables--warned-lexical t)
- (display-warning
- 'files
- (format-message
- "%s: `lexical-binding' at end of file unreliable"
- (file-name-nondirectory
- ;; We are called from
- ;; 'with-temp-buffer', so we need
- ;; to use 'thisbuf's name in the
- ;; warning message.
- (or (buffer-file-name thisbuf) ""))))))
- ((and (eq var 'mode) handle-mode))
- (t
- (ignore-errors
- (push (cons (if (eq var 'eval)
- 'eval
- (indirect-variable var))
- val)
- result))))))
- (forward-line 1))))))))
- ;; Now we've read all the local variables.
- ;; If HANDLE-MODE is t, return whether the mode was specified.
- (if (eq handle-mode t) result
- ;; Otherwise, set the variables.
- (hack-local-variables-filter result nil)
- (hack-local-variables-apply)))))
+ (hack-dir-local-variables))
+ (let ((result (append (hack-local-variables--find-variables)
+ (hack-local-variables-prop-line))))
+ (if (and enable-local-variables
+ (not (inhibit-local-variables-p)))
+ (progn
+ ;; Set the variables.
+ (hack-local-variables-filter result nil)
+ (hack-local-variables-apply))
+ ;; Handle `lexical-binding' and other special local
+ ;; variables.
+ (dolist (variable permanently-enabled-local-variables)
+ (when-let ((elem (assq variable result)))
+ (push elem file-local-variables-alist)))
+ (hack-local-variables-apply))))))
+
+(defun hack-local-variables--find-variables (&optional handle-mode)
+ "Return all local variables in the ucrrent buffer.
+If HANDLE-MODE is nil, we gather all the specified local
+variables. If HANDLE-MODE is neither nil nor t, we do the same,
+except that any settings of `mode' are ignored.
+
+If HANDLE-MODE is t, all we do is check whether a \"mode:\"
+is specified, and return the corresponding mode symbol, or nil.
+In this case, we try to ignore minor-modes, and return only a
+major-mode."
+ (let ((result nil))
+ ;; Look for "Local variables:" line in last page.
+ (save-excursion
+ (goto-char (point-max))
+ (search-backward "\n\^L" (max (- (point-max) 3000) (point-min))
+ 'move)
+ (when (let ((case-fold-search t))
+ (search-forward "Local Variables:" nil t))
+ (skip-chars-forward " \t")
+ ;; suffix is what comes after "local variables:" in its line.
+ ;; prefix is what comes before "local variables:" in its line.
+ (let ((suffix
+ (concat
+ (regexp-quote (buffer-substring (point)
+ (line-end-position)))
+ "$"))
+ (prefix
+ (concat "^" (regexp-quote
+ (buffer-substring (line-beginning-position)
+ (match-beginning 0))))))
+
+ (forward-line 1)
+ (let ((startpos (point))
+ endpos
+ (thisbuf (current-buffer)))
+ (save-excursion
+ (unless (let ((case-fold-search t))
+ (re-search-forward
+ (concat prefix "[ \t]*End:[ \t]*" suffix)
+ nil t))
+ ;; This used to be an error, but really all it means is
+ ;; that this may simply not be a local-variables section,
+ ;; so just ignore it.
+ (message "Local variables list is not properly terminated"))
+ (beginning-of-line)
+ (setq endpos (point)))
+
+ (with-temp-buffer
+ (insert-buffer-substring thisbuf startpos endpos)
+ (goto-char (point-min))
+ (subst-char-in-region (point) (point-max) ?\^m ?\n)
+ (while (not (eobp))
+ ;; Discard the prefix.
+ (if (looking-at prefix)
+ (delete-region (point) (match-end 0))
+ (error "Local variables entry is missing the prefix"))
+ (end-of-line)
+ ;; Discard the suffix.
+ (if (looking-back suffix (line-beginning-position))
+ (delete-region (match-beginning 0) (point))
+ (error "Local variables entry is missing the suffix"))
+ (forward-line 1))
+ (goto-char (point-min))
+
+ (while (not (or (eobp)
+ (and (eq handle-mode t) result)))
+ ;; Find the variable name;
+ (unless (looking-at hack-local-variable-regexp)
+ (error "Malformed local variable line: %S"
+ (buffer-substring-no-properties
+ (point) (line-end-position))))
+ (goto-char (match-end 1))
+ (let* ((str (match-string 1))
+ (var (intern str))
+ val val2)
+ (and (equal (downcase (symbol-name var)) "mode")
+ (setq var 'mode))
+ ;; Read the variable value.
+ (skip-chars-forward "^:")
+ (forward-char 1)
+ ;; As a defensive measure, we do not allow
+ ;; circular data in the file-local data.
+ (let ((read-circle nil))
+ (setq val (read (current-buffer))))
+ (if (eq handle-mode t)
+ (and (eq var 'mode)
+ ;; Specifying minor-modes via mode: is
+ ;; deprecated, but try to reject them anyway.
+ (not (string-match
+ "-minor\\'"
+ (setq val2 (downcase (symbol-name val)))))
+ (setq result (intern (concat val2 "-mode"))))
+ (cond ((eq var 'coding))
+ ((eq var 'lexical-binding)
+ (unless hack-local-variables--warned-lexical
+ (setq hack-local-variables--warned-lexical t)
+ (display-warning
+ 'files
+ (format-message
+ "%s: `lexical-binding' at end of file unreliable"
+ (file-name-nondirectory
+ ;; We are called from
+ ;; 'with-temp-buffer', so we need
+ ;; to use 'thisbuf's name in the
+ ;; warning message.
+ (or (buffer-file-name thisbuf) ""))))))
+ ((and (eq var 'mode) handle-mode))
+ (t
+ (ignore-errors
+ (push (cons (if (eq var 'eval)
+ 'eval
+ (indirect-variable var))
+ val)
+ result))))))
+ (forward-line 1)))))))
+ result))
(defun hack-local-variables-apply ()
"Apply the elements of `file-local-variables-alist'.
@@ -3966,7 +4150,7 @@ already the major mode."
('eval
(pcase val
(`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook)))
- (save-excursion (eval val)))
+ (save-excursion (eval val t)))
(_
(hack-one-local-variable--obsolete var)
;; Make sure the string has no text properties.
@@ -4012,10 +4196,13 @@ Returns the new list."
;; Need a new cons in case we setcdr later.
(push (cons variable value) variables)))))
-(defun dir-locals-collect-variables (class-variables root variables)
+(defun dir-locals-collect-variables (class-variables root variables
+ &optional predicate)
"Collect entries from CLASS-VARIABLES into VARIABLES.
ROOT is the root directory of the project.
-Return the new variables list."
+Return the new variables list.
+If PREDICATE is given, it is used to test a symbol key in the alist
+to see whether it should be considered."
(let* ((file-name (or (buffer-file-name)
;; Handle non-file buffers, too.
(expand-file-name default-directory)))
@@ -4034,20 +4221,22 @@ Return the new variables list."
(>= (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))
+ (cdr entry) root variables predicate))))
+ ((if predicate
+ (funcall predicate key)
+ (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))
+ (setq alist (remq 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))
+ (equal root (expand-file-name default-directory)))
(setq variables (dir-locals-collect-mode-variables
alist variables))))))))
(error
@@ -4286,15 +4475,36 @@ Return the new class name, which is a symbol named DIR."
(let ((read-circle nil))
(read (current-buffer)))
(end-of-file nil))))
+ (unless (listp newvars)
+ (message "Invalid data in %s: %s" file newvars)
+ (setq newvars nil))
(setq variables
;; Try and avoid loading `map' since that also loads cl-lib
;; which then might hamper bytecomp warnings (bug#30635).
(if (not (and newvars variables))
(or newvars variables)
(require 'map)
- (map-merge-with 'list (lambda (a b) (map-merge 'list a b))
- variables
- newvars))))))
+ ;; We want to make the variable setting from
+ ;; newvars (the second .dir-locals file) take
+ ;; presedence over the old variables, but we also
+ ;; want to preserve all `eval' elements as is from
+ ;; both lists.
+ (map-merge-with
+ 'list
+ (lambda (a b)
+ (let ((ag
+ (seq-group-by
+ (lambda (e) (eq (car e) 'eval)) a))
+ (bg
+ (seq-group-by
+ (lambda (e) (eq (car e) 'eval)) b)))
+ (append (map-merge 'list
+ (assoc-default nil ag)
+ (assoc-default nil bg))
+ (assoc-default t ag)
+ (assoc-default t bg))))
+ variables
+ newvars))))))
(setq success latest))
(setq variables (dir-locals--sort-variables variables))
(dir-locals-set-class-variables class-name variables)
@@ -4312,13 +4522,13 @@ Return the new class name, which is a symbol named DIR."
(defvar hack-dir-local-variables--warned-coding nil)
-(defun hack-dir-local-variables ()
+(defun hack-dir-local--get-variables (predicate)
"Read per-directory local variables for the current buffer.
-Store the directory-local variables in `dir-local-variables-alist'
-and `file-local-variables-alist', without applying them.
-
-This does nothing if either `enable-local-variables' or
-`enable-dir-local-variables' are nil."
+Return a cons of the form (DIR . ALIST), where DIR is the
+directory name (maybe nil) and ALIST is an alist of all variables
+that might apply. These will be filtered according to the
+buffer's directory, but not according to its mode.
+PREDICATE is passed to `dir-locals-collect-variables'."
(when (and enable-local-variables
enable-dir-local-variables
(or enable-remote-dir-locals
@@ -4337,21 +4547,33 @@ This does nothing if either `enable-local-variables' or
(setq dir-name (nth 0 dir-or-cache))
(setq class (nth 1 dir-or-cache))))
(when class
- (let ((variables
- (dir-locals-collect-variables
- (dir-locals-get-class-variables class) dir-name nil)))
- (when variables
- (dolist (elt variables)
- (if (eq (car elt) 'coding)
- (unless hack-dir-local-variables--warned-coding
- (setq hack-dir-local-variables--warned-coding t)
- (display-warning 'files
- "Coding cannot be specified by dir-locals"))
- (unless (memq (car elt) '(eval mode))
- (setq dir-local-variables-alist
- (assq-delete-all (car elt) dir-local-variables-alist)))
- (push elt dir-local-variables-alist)))
- (hack-local-variables-filter variables dir-name)))))))
+ (cons dir-name
+ (dir-locals-collect-variables
+ (dir-locals-get-class-variables class)
+ dir-name nil predicate))))))
+
+(defun hack-dir-local-variables ()
+ "Read per-directory local variables for the current buffer.
+Store the directory-local variables in `dir-local-variables-alist'
+and `file-local-variables-alist', without applying them.
+
+This does nothing if either `enable-local-variables' or
+`enable-dir-local-variables' are nil."
+ (let* ((items (hack-dir-local--get-variables nil))
+ (dir-name (car items))
+ (variables (cdr items)))
+ (when variables
+ (dolist (elt variables)
+ (if (eq (car elt) 'coding)
+ (unless hack-dir-local-variables--warned-coding
+ (setq hack-dir-local-variables--warned-coding t)
+ (display-warning 'files
+ "Coding cannot be specified by dir-locals"))
+ (unless (memq (car elt) '(eval mode))
+ (setq dir-local-variables-alist
+ (assq-delete-all (car elt) dir-local-variables-alist)))
+ (push elt dir-local-variables-alist)))
+ (hack-local-variables-filter variables dir-name))))
(defun hack-dir-local-variables-non-file-buffer ()
"Apply directory-local variables to a non-file buffer.
@@ -4455,9 +4677,7 @@ the old visited file has been renamed to the new name FILENAME."
(and buffer-file-name
backup-enable-predicate
(not (funcall backup-enable-predicate buffer-file-name))
- (progn
- (make-local-variable 'backup-inhibited)
- (setq backup-inhibited t)))
+ (setq-local backup-inhibited t))
(let ((oauto buffer-auto-save-file-name))
(cond ((null filename)
(setq buffer-auto-save-file-name nil))
@@ -4674,6 +4894,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
;; Create temp files with strict access rights. It's easy to
;; loosen them later, whereas it's impossible to close the
;; time-window of loose permissions otherwise.
+ (let (nofollow-flag)
(with-file-modes ?\700
(when (condition-case nil
;; Try to overwrite old backup first.
@@ -4684,6 +4905,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(when (file-exists-p to-name)
(delete-file to-name))
(copy-file from-name to-name nil t t)
+ (setq nofollow-flag 'nofollow)
nil)
(file-already-exists t))
;; The file was somehow created by someone else between
@@ -4696,7 +4918,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(with-demoted-errors
(set-file-extended-attributes to-name extended-attributes)))
(and modes
- (set-file-modes to-name (logand modes #o1777)))))
+ (set-file-modes to-name (logand modes #o1777) nofollow-flag)))))
(defvar file-name-version-regexp
"\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)"
@@ -4798,6 +5020,27 @@ extension, the value is \"\"."
(if period
"")))))
+(defun file-name-with-extension (filename extension)
+ "Set the EXTENSION of a FILENAME.
+The extension (in a file name) is the part that begins with the last \".\".
+
+Trims a leading dot from the EXTENSION so that either \"foo\" or
+\".foo\" can be given.
+
+Errors if the FILENAME or EXTENSION are empty, or if the given
+FILENAME has the format of a directory.
+
+See also `file-name-sans-extension'."
+ (let ((extn (string-trim-left extension "[.]")))
+ (cond ((string-empty-p filename)
+ (error "Empty filename: %s" filename))
+ ((string-empty-p extn)
+ (error "Malformed extension: %s" extension))
+ ((directory-name-p filename)
+ (error "Filename is a directory: %s" filename))
+ (t
+ (concat (file-name-sans-extension filename) "." extn)))))
+
(defun file-name-base (&optional filename)
"Return the base name of the FILENAME: no directory, no extension."
(declare (advertised-calling-convention (filename) "27.1"))
@@ -4824,7 +5067,7 @@ See also `backup-directory-alist'."
(function :tag "Function")))
(defcustom backup-directory-alist nil
- "Alist of filename patterns and backup directory names.
+ "Alist of file name patterns and backup directory names.
Each element looks like (REGEXP . DIRECTORY). Backups of files with
names matching REGEXP will be made in DIRECTORY. DIRECTORY may be
relative or absolute. If it is absolute, so that all matching files
@@ -4837,7 +5080,7 @@ For the common case of all backups going into one directory, the alist
should contain a single element pairing \".\" with the appropriate
directory name.
-If this variable is nil, or it fails to match a filename, the backup
+If this variable is nil, or it fails to match a file name, the backup
is made in the original file's directory.
On MS-DOS filesystems without long names this variable is always
@@ -5194,7 +5437,7 @@ Used only by `save-buffer'."
:type 'hook
:group 'files)
-(defvar save-buffer-coding-system nil
+(defvar-local save-buffer-coding-system nil
"If non-nil, use this coding system for saving the buffer.
More precisely, use this coding system in place of the
value of `buffer-file-coding-system', when saving the buffer.
@@ -5202,7 +5445,6 @@ Calling `write-region' for any purpose other than saving the buffer
will still use `buffer-file-coding-system'; this variable has no effect
in such cases.")
-(make-variable-buffer-local 'save-buffer-coding-system)
(put 'save-buffer-coding-system 'permanent-local t)
(defun basic-save-buffer (&optional called-interactively)
@@ -5471,9 +5713,8 @@ Before and after saving the buffer, this function runs
"ACTION-ALIST argument used in call to `map-y-or-n-p'.")
(put 'save-some-buffers-action-alist 'risky-local-variable t)
-(defvar buffer-save-without-query nil
+(defvar-local buffer-save-without-query nil
"Non-nil means `save-some-buffers' should save this buffer without asking.")
-(make-variable-buffer-local 'buffer-save-without-query)
(defcustom save-some-buffers-default-predicate nil
"Default predicate for `save-some-buffers'.
@@ -5555,10 +5796,28 @@ change the additional actions you can take on files."
t
(setq queried t)
(if (buffer-file-name buffer)
- (format "Save file %s? "
- (buffer-file-name buffer))
- (format "Save buffer %s? "
- (buffer-name buffer))))))
+ (if (or
+ (equal (buffer-name buffer)
+ (file-name-nondirectory
+ (buffer-file-name buffer)))
+ (string-match
+ (concat "\\<"
+ (regexp-quote
+ (file-name-nondirectory
+ (buffer-file-name buffer)))
+ "<[^>]*>\\'")
+ (buffer-name buffer)))
+ ;; The buffer name is similar to the
+ ;; file name.
+ (format "Save file %s? "
+ (buffer-file-name buffer))
+ ;; The buffer and file names are
+ ;; dissimilar; display both.
+ (format "Save file %s (buffer %s)? "
+ (buffer-file-name buffer)
+ (buffer-name buffer)))
+ ;; No file name
+ (format "Save buffer %s? " (buffer-name buffer))))))
(lambda (buffer)
(with-current-buffer buffer
(save-buffer)))
@@ -5644,25 +5903,28 @@ like `write-region' does."
(defun file-newest-backup (filename)
"Return most recent backup file for FILENAME or nil if no backups exist."
+ (car (file-backup-file-names filename)))
+
+(defun file-backup-file-names (filename)
+ "Return a list of backup files for FILENAME.
+The list will be sorted by modification time so that the most
+recent files are first."
;; `make-backup-file-name' will get us the right directory for
;; ordinary or numeric backups. It might create a directory for
;; backups as a side-effect, according to `backup-directory-alist'.
(let* ((filename (file-name-sans-versions
(make-backup-file-name (expand-file-name filename))))
- (file (file-name-nondirectory filename))
- (dir (file-name-directory filename))
- (comp (file-name-all-completions file dir))
- (newest nil)
- tem)
- (while comp
- (setq tem (pop comp))
- (cond ((and (backup-file-name-p tem)
- (string= (file-name-sans-versions tem) file))
- (setq tem (concat dir tem))
- (if (or (null newest)
- (file-newer-than-file-p tem newest))
- (setq newest tem)))))
- newest))
+ (dir (file-name-directory filename)))
+ (sort
+ (seq-filter
+ (lambda (candidate)
+ (and (backup-file-name-p candidate)
+ (string= (file-name-sans-versions candidate) filename)))
+ (mapcar
+ (lambda (file)
+ (concat dir file))
+ (file-name-all-completions (file-name-nondirectory filename) dir)))
+ #'file-newer-than-file-p)))
(defun rename-uniquely ()
"Rename current buffer to a similar name not already taken.
@@ -5755,7 +6017,10 @@ If called interactively, then PARENTS is non-nil."
(defconst directory-files-no-dot-files-regexp
"[^.]\\|\\.\\.\\."
- "Regexp matching any file name except \".\" and \"..\".")
+ "Regexp matching any file name except \".\" and \"..\".
+More precisely, it matches parts of any nonempty string except those two.
+It is useful as the regexp argument to `directory-files' and
+`directory-files-and-attributes'.")
(defun files--force (no-such fn &rest args)
"Use NO-SUCH to affect behavior of function FN applied to list ARGS.
@@ -5804,10 +6069,7 @@ RECURSIVE if DIRECTORY is nonempty."
;; case, where the operation fails in delete-directory-internal.
;; As `move-file-to-trash' trashes directories (empty or
;; otherwise) as a unit, we do not need to recurse here.
- (if (and (not recursive)
- ;; Check if directory is empty apart from "." and "..".
- (directory-files
- directory 'full directory-files-no-dot-files-regexp))
+ (if (not (or recursive (directory-empty-p directory)))
(error "Directory is not empty, not moving to trash")
(move-file-to-trash directory)))
;; Otherwise, call ourselves recursively if needed.
@@ -5880,9 +6142,9 @@ last-modified time as the old ones. (This works on only some systems.)
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.
+Noninteractively, the PARENTS argument says whether to create
+parent directories if they don't exist. Interactively, this
+happens by default.
If NEWNAME is a directory name, copy DIRECTORY as a subdirectory
there. However, if called from Lisp with a non-nil optional
@@ -5902,7 +6164,8 @@ into NEWNAME instead."
;; 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)
- (find-file-name-handler newname 'copy-directory))))
+ (find-file-name-handler newname 'copy-directory)))
+ (follow parents))
(if handler
(funcall handler 'copy-directory directory
newname keep-time parents copy-contents)
@@ -5922,7 +6185,8 @@ into NEWNAME instead."
(or parents (not (file-directory-p newname)))
(setq newname (concat newname
(file-name-nondirectory directory))))
- (make-directory (directory-file-name newname) parents)))
+ (make-directory (directory-file-name newname) parents))
+ (t (setq follow t)))
;; Copy recursively.
(dolist (file
@@ -5942,9 +6206,10 @@ into NEWNAME instead."
;; Set directory attributes.
(let ((modes (file-modes directory))
(times (and keep-time (file-attribute-modification-time
- (file-attributes directory)))))
- (if modes (set-file-modes newname modes))
- (if times (set-file-times newname times))))))
+ (file-attributes directory))))
+ (follow-flag (unless follow 'nofollow)))
+ (if modes (set-file-modes newname modes follow-flag))
+ (if times (set-file-times newname times follow-flag))))))
;; At time of writing, only info uses this.
@@ -6085,7 +6350,12 @@ This function binds `revert-buffer-in-progress-p' non-nil while it operates.
This function calls the function that `revert-buffer-function' specifies
to do the work, with arguments IGNORE-AUTO and NOCONFIRM.
The default function runs the hooks `before-revert-hook' and
-`after-revert-hook'."
+`after-revert-hook'
+
+Reverting a buffer will try to preserve markers in the buffer,
+but it cannot always preserve all of them. For better results,
+use `revert-buffer-with-fine-grain', which tries harder to
+preserve markers and overlays, at the price of being slower."
;; I admit it's odd to reverse the sense of the prefix argument, but
;; there is a lot of code out there that assumes that the first
;; argument should be t to avoid consulting the auto-save file, and
@@ -6129,8 +6399,11 @@ Non-file buffers need a custom function."
(dolist (regexp revert-without-query)
(when (string-match regexp file-name)
(throw 'found t)))))
- (yes-or-no-p (format "Revert buffer from file %s? "
- file-name)))
+ (yes-or-no-p
+ (format (if (buffer-modified-p)
+ "Discard edits and reread from %s? "
+ "Revert buffer from file %s? ")
+ file-name)))
(run-hooks 'before-revert-hook)
;; If file was backed up but has changed since,
;; we should make another backup.
@@ -6156,7 +6429,7 @@ Non-file buffers need a custom function."
;; Run after-revert-hook as it was before we reverted.
(setq-default revert-buffer-internal-hook global-hook)
(if local-hook
- (set (make-local-variable 'revert-buffer-internal-hook)
+ (setq-local revert-buffer-internal-hook
local-hook)
(kill-local-variable 'revert-buffer-internal-hook))
(run-hooks 'revert-buffer-internal-hook))
@@ -6179,11 +6452,6 @@ an auto-save file."
"Cannot revert unreadable file %s")
file-name))
(t
- ;; Bind buffer-file-name to nil
- ;; so that we don't try to lock the file.
- (let ((buffer-file-name nil))
- (or auto-save-p
- (unlock-buffer)))
(widen)
(let ((coding-system-for-read
;; Auto-saved file should be read by Emacs's
@@ -6216,6 +6484,82 @@ an auto-save file."
(insert-file-contents file-name (not auto-save-p)
nil nil t))))))
+(defvar revert-buffer-with-fine-grain-max-seconds 2.0
+ "Maximum time that `revert-buffer-with-fine-grain' should use.
+The command tries to preserve markers, properties and overlays.
+If the operation takes more than this time, a single
+delete+insert is performed. Actually, this value is passed as
+the MAX-SECS argument to the function `replace-buffer-contents',
+so it is not ensured that the whole execution won't take longer.
+See `replace-buffer-contents' for more details.")
+
+(defun revert-buffer-insert-file-contents-delicately (file-name _auto-save-p)
+ "Optional function for `revert-buffer-insert-file-contents-function'.
+The function `revert-buffer-with-fine-grain' uses this function by binding
+`revert-buffer-insert-file-contents-function' to it.
+
+As with `revert-buffer-insert-file-contents--default-function', FILE-NAME is
+the name of the file and AUTO-SAVE-P is non-nil if this is an auto-save file.
+Since calling `replace-buffer-contents' can take a long time, depending of
+the number of changes made to the buffer, it uses the value of the variable
+`revert-buffer-with-fine-grain-max-seconds' as a maximum time to try delicately
+reverting the buffer. If it fails, it does a delete+insert. For more details,
+see `replace-buffer-contents'."
+ (cond
+ ((not (file-exists-p file-name))
+ (error (if buffer-file-number
+ "File %s no longer exists"
+ "Cannot revert nonexistent file %s")
+ file-name))
+ ((not (file-readable-p file-name))
+ (error (if buffer-file-number
+ "File %s no longer readable"
+ "Cannot revert unreadable file %s")
+ file-name))
+ (t
+ (let* ((buf (current-buffer)) ; current-buffer is the buffer to revert.
+ (success
+ (save-excursion
+ (save-restriction
+ (widen)
+ (with-temp-buffer
+ (insert-file-contents file-name)
+ (let ((temp-buf (current-buffer)))
+ (set-buffer buf)
+ (let ((buffer-file-name nil))
+ (replace-buffer-contents
+ temp-buf
+ revert-buffer-with-fine-grain-max-seconds))))))))
+ ;; See comments in revert-buffer-with-fine-grain for an explanation.
+ (defun revert-buffer-with-fine-grain-success-p ()
+ success))
+ (set-buffer-modified-p nil))))
+
+(defun revert-buffer-with-fine-grain (&optional ignore-auto noconfirm)
+ "Revert buffer preserving markers, overlays, etc.
+This command is an alternative to `revert-buffer' because it tries to be as
+non-destructive as possible, preserving markers, properties and overlays.
+Binds `revert-buffer-insert-file-contents-function' to the function
+`revert-buffer-insert-file-contents-delicately'.
+
+With a prefix argument, offer to revert from latest auto-save file. For more
+details on the arguments, see `revert-buffer'."
+ ;; See revert-buffer for an explanation of this.
+ (interactive (list (not current-prefix-arg)))
+ ;; Simply bind revert-buffer-insert-file-contents-function to the specialized
+ ;; function, and call revert-buffer.
+ (let ((revert-buffer-insert-file-contents-function
+ #'revert-buffer-insert-file-contents-delicately))
+ (revert-buffer ignore-auto noconfirm t)
+ ;; This closure is defined in revert-buffer-insert-file-contents-function.
+ ;; It is needed because revert-buffer--default always returns t after
+ ;; reverting, and it might be needed to report the success/failure of
+ ;; reverting delicately.
+ (when (fboundp 'revert-buffer-with-fine-grain-success-p)
+ (prog1
+ (revert-buffer-with-fine-grain-success-p)
+ (fmakunbound 'revert-buffer-with-fine-grain-success-p)))))
+
(defun recover-this-file ()
"Recover the visited file--get contents from its last auto-save file."
(interactive)
@@ -6271,7 +6615,8 @@ an auto-save file."
(coding-system-for-read 'auto-save-coding))
(erase-buffer)
(insert-file-contents file-name nil)
- (set-buffer-file-coding-system coding-system))
+ (set-buffer-file-coding-system coding-system)
+ (set-buffer-auto-saved))
(after-find-file nil nil t))
(t (user-error "Recover-file canceled")))))
@@ -6445,64 +6790,18 @@ Also rename any existing auto save file, if it was made in this session."
(defun make-auto-save-file-name ()
"Return file name to use for auto-saves of current buffer.
Does not consider `auto-save-visited-file-name' as that variable is checked
-before calling this function. You can redefine this for customization.
+before calling this function.
See also `auto-save-file-name-p'."
(if buffer-file-name
- (let ((handler (find-file-name-handler buffer-file-name
- 'make-auto-save-file-name)))
+ (let ((handler (find-file-name-handler
+ buffer-file-name 'make-auto-save-file-name)))
(if handler
(funcall handler 'make-auto-save-file-name)
- (let ((list auto-save-file-name-transforms)
- (filename buffer-file-name)
- result uniq)
- ;; Apply user-specified translations
- ;; to the file name.
- (while (and list (not result))
- (if (string-match (car (car list)) filename)
- (setq result (replace-match (cadr (car list)) t nil
- filename)
- uniq (car (cddr (car list)))))
- (setq list (cdr list)))
- (if result
- (if uniq
- (setq filename (concat
- (file-name-directory result)
- (subst-char-in-string
- ?/ ?!
- (replace-regexp-in-string "!" "!!"
- filename))))
- (setq filename result)))
- (setq result
- (if (and (eq system-type 'ms-dos)
- (not (msdos-long-file-names)))
- ;; We truncate the file name to DOS 8+3 limits
- ;; before doing anything else, because the regexp
- ;; passed to string-match below cannot handle
- ;; extensions longer than 3 characters, multiple
- ;; dots, and other atrocities.
- (let ((fn (dos-8+3-filename
- (file-name-nondirectory buffer-file-name))))
- (string-match
- "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'"
- fn)
- (concat (file-name-directory buffer-file-name)
- "#" (match-string 1 fn)
- "." (match-string 3 fn) "#"))
- (concat (file-name-directory filename)
- "#"
- (file-name-nondirectory filename)
- "#")))
- ;; Make sure auto-save file names don't contain characters
- ;; invalid for the underlying filesystem.
- (if (and (memq system-type '(ms-dos windows-nt cygwin))
- ;; Don't modify remote filenames
- (not (file-remote-p result)))
- (convert-standard-filename result)
- result))))
-
+ (files--transform-file-name
+ buffer-file-name auto-save-file-name-transforms
+ "#" "#")))
;; Deal with buffers that don't have any associated files. (Mail
;; mode tends to create a good number of these.)
-
(let ((buffer-name (buffer-name))
(limit 0)
file-name)
@@ -6550,14 +6849,83 @@ See also `auto-save-file-name-p'."
(file-error nil))
file-name)))
+(defun files--transform-file-name (filename transforms prefix suffix)
+ "Transform FILENAME according to TRANSFORMS.
+See `auto-save-file-name-transforms' for the format of
+TRANSFORMS. PREFIX is prepended to the non-directory portion of
+the resulting file name, and SUFFIX is appended."
+ (save-match-data
+ (let (result uniq)
+ ;; Apply user-specified translations to the file name.
+ (while (and transforms (not result))
+ (if (string-match (car (car transforms)) filename)
+ (setq result (replace-match (cadr (car transforms)) t nil
+ filename)
+ uniq (car (cddr (car transforms)))))
+ (setq transforms (cdr transforms)))
+ (when result
+ (setq filename
+ (cond
+ ((memq uniq (secure-hash-algorithms))
+ (concat
+ (file-name-directory result)
+ (secure-hash uniq filename)))
+ (uniq
+ (concat
+ (file-name-directory result)
+ (subst-char-in-string
+ ?/ ?!
+ (replace-regexp-in-string
+ "!" "!!" filename))))
+ (t result))))
+ (setq result
+ (if (and (eq system-type 'ms-dos)
+ (not (msdos-long-file-names)))
+ ;; We truncate the file name to DOS 8+3 limits before
+ ;; doing anything else, because the regexp passed to
+ ;; string-match below cannot handle extensions longer
+ ;; than 3 characters, multiple dots, and other
+ ;; atrocities.
+ (let ((fn (dos-8+3-filename
+ (file-name-nondirectory buffer-file-name))))
+ (string-match
+ "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'"
+ fn)
+ (concat (file-name-directory buffer-file-name)
+ prefix (match-string 1 fn)
+ "." (match-string 3 fn) suffix))
+ (concat (file-name-directory filename)
+ prefix
+ (file-name-nondirectory filename)
+ suffix)))
+ ;; Make sure auto-save file names don't contain characters
+ ;; invalid for the underlying filesystem.
+ (expand-file-name
+ (if (and (memq system-type '(ms-dos windows-nt cygwin))
+ ;; Don't modify remote filenames
+ (not (file-remote-p result)))
+ (convert-standard-filename result)
+ result)))))
+
+(defun make-lock-file-name (filename)
+ "Make a lock file name for FILENAME.
+By default, this just prepends \".#\" to the non-directory part
+of FILENAME, but the transforms in `lock-file-name-transforms'
+are done first."
+ (let ((handler (find-file-name-handler filename 'make-lock-file-name)))
+ (if handler
+ (funcall handler 'make-lock-file-name filename)
+ (files--transform-file-name filename lock-file-name-transforms ".#" ""))))
+
(defun auto-save-file-name-p (filename)
"Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'.
-FILENAME should lack slashes. You can redefine this for customization."
+FILENAME should lack slashes.
+See also `make-auto-save-file-name'."
(string-match "\\`#.*#\\'" filename))
(defun wildcard-to-regexp (wildcard)
"Given a shell file name pattern WILDCARD, return an equivalent regexp.
-The generated regexp will match a filename only if the filename
+The generated regexp will match a file name only if the file name
matches that wildcard according to shell rules. Only wildcards known
by `sh' are supported."
(let* ((i (string-match "[[.*+\\^$?]" wildcard))
@@ -6775,9 +7143,7 @@ We assume the output has the format of `df'.
The value of this variable must be just a command name or file name;
if you want to specify options, use `directory-free-space-args'.
-A value of nil disables this feature.
-
-This variable is obsolete; Emacs no longer uses it."
+A value of nil disables this feature."
:type '(choice (string :tag "Program") (const :tag "None" nil))
:group 'dired)
(make-obsolete-variable 'directory-free-space-program
@@ -6823,6 +7189,9 @@ If DIR's free space cannot be obtained, this function returns nil."
s "+"
"\\(" HH:MM "\\|" yyyy "\\)"))
(western-comma (concat month s "+" dd "," s "+" yyyy))
+ ;; This represents the date in strftime(3) format "%e-%b-%Y"
+ ;; (aka "%v"), as it is the default for many ls incarnations.
+ (DD-MMM-YYYY (concat dd "-" month "-" yyyy s HH:MM))
;; Japanese MS-Windows ls-lisp has one-digit months, and
;; omits the Kanji characters after month and day-of-month.
;; On Mac OS X 10.3, the date format in East Asian locales is
@@ -6850,7 +7219,8 @@ If DIR's free space cannot be obtained, this function returns nil."
;; This is not supported yet.
(purecopy (concat "\\([0-9][BkKMGTPEZY]? " iso
"\\|.*[0-9][BkKMGTPEZY]? "
- "\\(" western "\\|" western-comma "\\|" east-asian "\\)"
+ "\\(" western "\\|" western-comma
+ "\\|" DD-MMM-YYYY "\\|" east-asian "\\)"
"\\) +")))
"Regular expression to match up to the file name in a directory listing.
The default value is designed to recognize dates and times
@@ -7031,6 +7401,8 @@ normally equivalent short `-D' option is just passed on to
((stringp switches) (concat switches " -d"))
((member "-d" switches) switches)
(t (append switches '("-d"))))))
+ (if (string-match "\\`~" file)
+ (setq file (expand-file-name file)))
(apply 'call-process
insert-directory-program nil t nil
(append
@@ -7041,14 +7413,7 @@ normally equivalent short `-D' option is just passed on to
(split-string-and-unquote switches)))
;; Avoid lossage if FILE starts with `-'.
'("--")
- (progn
- (if (string-match "\\`~" file)
- (setq file (expand-file-name file)))
- (list
- (if full-directory-p
- ;; (concat (file-name-as-directory file) ".")
- file
- file))))))))
+ (list file))))))
;; If we got "//DIRED//" in the output, it means we got a real
;; directory listing, even if `ls' returned nonzero.
@@ -7233,9 +7598,9 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
(save-some-buffers arg t)
(let ((confirm confirm-kill-emacs))
(and
- (or (not (memq t (mapcar (function
- (lambda (buf) (and (buffer-file-name buf)
- (buffer-modified-p buf))))
+ (or (not (memq t (mapcar (lambda (buf)
+ (and (buffer-file-name buf)
+ (buffer-modified-p buf)))
(buffer-list))))
(progn (setq confirm nil)
(yes-or-no-p "Modified buffers exist; exit anyway? ")))
@@ -7250,10 +7615,15 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
(setq active t))
(setq processes (cdr processes)))
(or (not active)
- (with-displayed-buffer-window
+ (with-current-buffer-window
(get-buffer-create "*Process List*")
- '(display-buffer--maybe-at-bottom
- (dedicated . t))
+ `(display-buffer--maybe-at-bottom
+ (dedicated . t)
+ (window-height . fit-window-to-buffer)
+ (preserve-size . (nil . t))
+ (body-function
+ . ,#'(lambda (_window)
+ (list-processes t))))
#'(lambda (window _value)
(with-selected-window window
(unwind-protect
@@ -7261,8 +7631,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it."
(setq confirm nil)
(yes-or-no-p "Active processes exist; kill them and exit anyway? "))
(when (window-live-p window)
- (quit-restore-window window 'kill)))))
- (list-processes t)))))
+ (quit-restore-window window 'kill)))))))))
;; Query the user for other things, perhaps.
(run-hook-with-args-until-failure 'kill-emacs-query-functions)
(or (null confirm)
@@ -7276,7 +7645,7 @@ If the current frame has no client, kill Emacs itself using
With prefix ARG, silently save all file-visiting buffers, then kill.
-If emacsclient was started with a list of filenames to edit, then
+If emacsclient was started with a list of file names to edit, then
only these files will be asked to be saved."
(interactive "P")
(if (frame-parameter nil 'client)
@@ -7297,12 +7666,11 @@ only these files will be asked to be saved."
;; operations, which return a file name. See Bug#29579.
(defun file-name-non-special (operation &rest arguments)
- (let (;; In general, we don't want any file name handler. For some
- ;; few cases, operations with two file name arguments which
- ;; might be bound to different file name handlers, we still
- ;; need this.
- (saved-file-name-handler-alist file-name-handler-alist)
- file-name-handler-alist
+ (let ((inhibit-file-name-handlers
+ (cons 'file-name-non-special
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation)
;; Some operations respect file name handlers in
;; `default-directory'. Because core function like
;; `call-process' don't care about file name handlers in
@@ -7384,69 +7752,73 @@ only these files will be asked to be saved."
(when (car pair)
(setcar pair (file-name-unquote (car pair) t))))
(setq file-arg-indices (cdr file-arg-indices))))
- (pcase method
- ('identity (car arguments))
- ('add (file-name-quote (apply operation arguments) t))
- ('buffer-file-name
- (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
- (apply operation arguments)))
- ('insert-file-contents
- (let ((visit (nth 1 arguments)))
- (unwind-protect
- (apply operation arguments)
- (when (and visit buffer-file-name)
- (setq buffer-file-name (file-name-quote buffer-file-name t))))))
- ('unquote-then-quote
- ;; We can't use `cl-letf' with `(buffer-local-value)' here
- ;; because it wouldn't work during bootstrapping.
- (let ((buffer (current-buffer)))
- ;; `unquote-then-quote' is used only for the
- ;; `verify-visited-file-modtime' action, which takes a buffer
- ;; as only optional argument.
- (with-current-buffer (or (car arguments) buffer)
- (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
- ;; Make sure to hide the temporary buffer change from the
- ;; underlying operation.
- (with-current-buffer buffer
- (apply operation arguments))))))
- ('local-copy
- (let* ((file-name-handler-alist saved-file-name-handler-alist)
- (source (car arguments))
- (target (car (cdr arguments)))
- (prefix (expand-file-name
- "file-name-non-special" temporary-file-directory))
- tmpfile)
- (cond
- ;; If source is remote, we must create a local copy.
- ((file-remote-p source)
- (setq tmpfile (make-temp-name prefix))
- (apply operation source tmpfile (cddr arguments))
- (setq source tmpfile))
- ;; If source is quoted, and the unquoted source looks
- ;; remote, we must create a local copy.
- ((file-name-quoted-p source t)
- (setq source (file-name-unquote source t))
- (when (file-remote-p source)
+ ;; In general, we don't want any file name handler, see Bug#47625,
+ ;; Bug#48349. For some few cases, operations with two file name
+ ;; arguments which might be bound to different file name handlers,
+ ;; we still need this.
+ (let ((tramp-mode (and tramp-mode (eq method 'local-copy))))
+ (pcase method
+ ('identity (car arguments))
+ ('add (file-name-quote (apply operation arguments) t))
+ ('buffer-file-name
+ (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
+ (apply operation arguments)))
+ ('insert-file-contents
+ (let ((visit (nth 1 arguments)))
+ (unwind-protect
+ (apply operation arguments)
+ (when (and visit buffer-file-name)
+ (setq buffer-file-name (file-name-quote buffer-file-name t))))))
+ ('unquote-then-quote
+ ;; We can't use `cl-letf' with `(buffer-local-value)' here
+ ;; because it wouldn't work during bootstrapping.
+ (let ((buffer (current-buffer)))
+ ;; `unquote-then-quote' is used only for the
+ ;; `verify-visited-file-modtime' action, which takes a
+ ;; buffer as only optional argument.
+ (with-current-buffer (or (car arguments) buffer)
+ (let ((buffer-file-name (file-name-unquote buffer-file-name t)))
+ ;; Make sure to hide the temporary buffer change from
+ ;; the underlying operation.
+ (with-current-buffer buffer
+ (apply operation arguments))))))
+ ('local-copy
+ (let ((source (car arguments))
+ (target (car (cdr arguments)))
+ (prefix (expand-file-name
+ "file-name-non-special" temporary-file-directory))
+ tmpfile)
+ (cond
+ ;; If source is remote, we must create a local copy.
+ ((file-remote-p source)
(setq tmpfile (make-temp-name prefix))
- (let (file-name-handler-alist)
- (apply operation source tmpfile (cddr arguments)))
- (setq source tmpfile))))
- ;; If target is quoted, and the unquoted target looks remote,
- ;; we must disable the file name handler.
- (when (file-name-quoted-p target t)
- (setq target (file-name-unquote target t))
- (when (file-remote-p target)
- (setq file-name-handler-alist nil)))
- ;; Do it.
- (setcar arguments source)
- (setcar (cdr arguments) target)
- (apply operation arguments)
- ;; Cleanup.
- (when (and tmpfile (file-exists-p tmpfile))
- (if (file-directory-p tmpfile)
- (delete-directory tmpfile 'recursive) (delete-file tmpfile)))))
- (_
- (apply operation arguments)))))
+ (apply operation source tmpfile (cddr arguments))
+ (setq source tmpfile))
+ ;; If source is quoted, and the unquoted source looks
+ ;; remote, we must create a local copy.
+ ((file-name-quoted-p source t)
+ (setq source (file-name-unquote source t))
+ (when (file-remote-p source)
+ (setq tmpfile (make-temp-name prefix))
+ (let (file-name-handler-alist)
+ (apply operation source tmpfile (cddr arguments)))
+ (setq source tmpfile))))
+ ;; If target is quoted, and the unquoted target looks
+ ;; remote, we must disable the file name handler.
+ (when (file-name-quoted-p target t)
+ (setq target (file-name-unquote target t))
+ (when (file-remote-p target)
+ (setq file-name-handler-alist nil)))
+ ;; Do it.
+ (setcar arguments source)
+ (setcar (cdr arguments) target)
+ (apply operation arguments)
+ ;; Cleanup.
+ (when (and tmpfile (file-exists-p tmpfile))
+ (if (file-directory-p tmpfile)
+ (delete-directory tmpfile 'recursive) (delete-file tmpfile)))))
+ (_
+ (apply operation arguments))))))
(defsubst file-name-quoted-p (name &optional top)
"Whether NAME is quoted with prefix \"/:\".
@@ -7502,6 +7874,9 @@ If CHAR is in [Xugo], the value is taken from FROM (or 0 if omitted)."
;; Rights relative to the previous file modes.
((= char ?X) (if (= (logand from #o111) 0) 0 #o0111))
((= char ?u) (let ((uright (logand #o4700 from)))
+ ;; FIXME: These divisions/shifts seem to be right
+ ;; for the `7' part of the #o4700 mask, but not
+ ;; for the `4' part. Same below for `g' and `o'.
(+ uright (/ uright #o10) (/ uright #o100))))
((= char ?g) (let ((gright (logand #o2070 from)))
(+ gright (/ gright #o10) (* gright #o10))))
@@ -7536,6 +7911,44 @@ as in \"og+rX-w\"."
op char-right)))
num-rights))
+(defun file-modes-number-to-symbolic (mode &optional filetype)
+ "Return a string describing a file's MODE.
+For instance, if MODE is #o700, then it produces `-rwx------'.
+FILETYPE if provided should be a character denoting the type of file,
+such as `?d' for a directory, or `?l' for a symbolic link and will override
+the leading `-' char."
+ (string
+ (or filetype
+ (pcase (lsh mode -12)
+ ;; POSIX specifies that the file type is included in st_mode
+ ;; and provides names for the file types but values only for
+ ;; the permissions (e.g., S_IWOTH=2).
+
+ ;; (#o017 ??) ;; #define S_IFMT 00170000
+ (#o014 ?s) ;; #define S_IFSOCK 0140000
+ (#o012 ?l) ;; #define S_IFLNK 0120000
+ ;; (8 ??) ;; #define S_IFREG 0100000
+ (#o006 ?b) ;; #define S_IFBLK 0060000
+ (#o004 ?d) ;; #define S_IFDIR 0040000
+ (#o002 ?c) ;; #define S_IFCHR 0020000
+ (#o001 ?p) ;; #define S_IFIFO 0010000
+ (_ ?-)))
+ (if (zerop (logand 256 mode)) ?- ?r)
+ (if (zerop (logand 128 mode)) ?- ?w)
+ (if (zerop (logand 64 mode))
+ (if (zerop (logand 2048 mode)) ?- ?S)
+ (if (zerop (logand 2048 mode)) ?x ?s))
+ (if (zerop (logand 32 mode)) ?- ?r)
+ (if (zerop (logand 16 mode)) ?- ?w)
+ (if (zerop (logand 8 mode))
+ (if (zerop (logand 1024 mode)) ?- ?S)
+ (if (zerop (logand 1024 mode)) ?x ?s))
+ (if (zerop (logand 4 mode)) ?- ?r)
+ (if (zerop (logand 2 mode)) ?- ?w)
+ (if (zerop (logand 512 mode))
+ (if (zerop (logand 1 mode)) ?- ?x)
+ (if (zerop (logand 1 mode)) ?T ?t))))
+
(defun file-modes-symbolic-to-number (modes &optional from)
"Convert symbolic file modes to numeric file modes.
MODES is the string to convert, it should match
@@ -7643,7 +8056,7 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
(let (delete-by-moving-to-trash)
(rename-file fn new-fn))))
;; Otherwise, use the freedesktop.org method, as specified at
- ;; http://freedesktop.org/wiki/Specifications/trash-spec
+ ;; https://freedesktop.org/wiki/Specifications/trash-spec
(t
(let* ((xdg-data-dir
(directory-file-name
@@ -7706,9 +8119,24 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
;; Make a .trashinfo file. Use O_EXCL, as per trash-spec 1.0.
(let* ((files-base (file-name-nondirectory fn))
- (info-fn (expand-file-name
- (concat files-base ".trashinfo")
- trash-info-dir)))
+ (is-directory (file-directory-p fn))
+ (overwrite nil)
+ info-fn)
+ ;; We're checking further down whether the info file
+ ;; exists, but the file name may exist in the trash
+ ;; directory even if there is no info file for it.
+ (when (file-exists-p
+ (file-name-concat trash-files-dir files-base))
+ (setq overwrite t
+ files-base (file-name-nondirectory
+ (make-temp-file
+ (file-name-concat
+ trash-files-dir files-base)
+ is-directory))))
+ (setq info-fn (file-name-concat
+ trash-info-dir
+ (concat files-base ".trashinfo")))
+ ;; Re-check the existence (sort of).
(condition-case nil
(write-region nil nil info-fn nil 'quiet info-fn 'excl)
(file-already-exists
@@ -7716,15 +8144,15 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
;; like Emacs-style backup file names. E.g.:
;; https://bugs.kde.org/170956
(setq info-fn (make-temp-file
- (expand-file-name files-base trash-info-dir)
+ (file-name-concat trash-info-dir files-base)
nil ".trashinfo"))
(setq files-base (substring (file-name-nondirectory info-fn)
0 (- (length ".trashinfo"))))
(write-region nil nil info-fn nil 'quiet info-fn)))
;; Finally, try to move the file to the trashcan.
(let ((delete-by-moving-to-trash nil)
- (new-fn (expand-file-name files-base trash-files-dir)))
- (rename-file fn new-fn)))))))))
+ (new-fn (file-name-concat trash-files-dir files-base)))
+ (rename-file fn new-fn overwrite)))))))))
(defsubst file-attribute-type (attributes)
"The type field in ATTRIBUTES returned by `file-attributes'.
diff --git a/lisp/filesets.el b/lisp/filesets.el
index 9f1dbc2301d..8e9fae80f69 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -1,4 +1,4 @@
-;;; filesets.el --- handle group of files
+;;; filesets.el --- handle group of files -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -35,7 +35,7 @@
;; inclusion group (i.e. a base file including other files).
;; Usage:
-;; 1. Put (require 'filesets) and (filesets-init) in your init file.
+;; 1. Put (filesets-init) in your init file.
;; 2. Type ;; M-x filesets-edit or choose "Edit Filesets" from the menu.
;; 3. Save your customizations.
@@ -88,7 +88,8 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
+(require 'seq)
;;; Some variables
@@ -152,58 +153,31 @@ COND-FN takes one argument: the current element."
; (cl-remove 'dummy lst :test (lambda (dummy elt)
; (not (funcall cond-fn elt)))))
(let ((rv nil))
- (dolist (elt lst rv)
+ (dolist (elt lst)
(when (funcall cond-fn elt)
- (setq rv (append rv (list elt)))))))
+ (push elt rv)))
+ (nreverse rv)))
(defun filesets-ormap (fsom-pred lst)
"Return the tail of LST for the head of which FSOM-PRED is non-nil."
(let ((fsom-lst lst)
(fsom-rv nil))
- (while (and (not (null fsom-lst))
+ (while (and fsom-lst
(null fsom-rv))
(if (funcall fsom-pred (car fsom-lst))
(setq fsom-rv fsom-lst)
(setq fsom-lst (cdr fsom-lst))))
fsom-rv))
-(defun filesets-some (fss-pred fss-lst)
- "Return non-nil if FSS-PRED is non-nil for any element of FSS-LST.
-Like `some', return the first value of FSS-PRED that is non-nil."
- (catch 'exit
- (dolist (fss-this fss-lst nil)
- (let ((fss-rv (funcall fss-pred fss-this)))
- (when fss-rv
- (throw 'exit fss-rv))))))
-;(fset 'filesets-some 'cl-some) ;; or use the cl function
-
-(defun filesets-member (fsm-item fsm-lst &rest fsm-keys)
- "Find the first occurrence of FSM-ITEM in FSM-LST.
-It is supposed to work like cl's `member*'. At the moment only the :test
-key is supported."
- (let ((fsm-test (or (plist-get fsm-keys ':test)
- (function equal))))
- (filesets-ormap (lambda (fsm-this)
- (funcall fsm-test fsm-item fsm-this))
- fsm-lst)))
-;(fset 'filesets-member 'cl-member) ;; or use the cl function
-
-(defun filesets-sublist (lst beg &optional end)
- "Get the sublist of LST from BEG to END - 1."
- (let ((rv nil)
- (i beg)
- (top (or end
- (length lst))))
- (while (< i top)
- (setq rv (append rv (list (nth i lst))))
- (setq i (+ i 1)))
- rv))
+(define-obsolete-function-alias 'filesets-some #'cl-some "28.1")
+(define-obsolete-function-alias 'filesets-member #'cl-member "28.1")
+(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1")
(defun filesets-select-command (cmd-list)
"Select one command from CMD-LIST -- a string with space separated names."
(let ((this (shell-command-to-string
- (format "which --skip-alias %s 2> /dev/null | head -n 1"
- cmd-list))))
+ (format "which --skip-alias %s 2> %s | head -n 1"
+ cmd-list null-device))))
(if (equal this "")
nil
(file-name-nondirectory (substring this 0 (- (length this) 1))))))
@@ -221,7 +195,7 @@ key is supported."
(defun filesets-message (level &rest args)
"Show a message only if LEVEL is greater or equal then `filesets-verbosity'."
(when (<= level (abs filesets-verbosity))
- (apply 'message args)))
+ (apply #'message args)))
;;; config file
@@ -232,9 +206,9 @@ key is supported."
(defun filesets-reset-fileset (&optional fileset no-cache)
"Reset the cached values for one or all filesets."
- (if fileset
- (setq filesets-submenus (lax-plist-put filesets-submenus fileset nil))
- (setq filesets-submenus nil))
+ (setq filesets-submenus (if fileset
+ (lax-plist-put filesets-submenus fileset nil)
+ nil))
(setq filesets-has-changed-flag t)
(setq filesets-update-cache-file-flag (or filesets-update-cache-file-flag
(not no-cache))))
@@ -302,50 +276,46 @@ SYM to VAL and return t. If INIT-FLAG is non-nil, set with
(defcustom filesets-menu-name "Filesets"
"Filesets' menu name."
- :set (function filesets-set-default)
- :type 'string
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'string)
(defcustom filesets-menu-path '("File") ; cf recentf-menu-path
"The menu under which the filesets menu should be inserted.
-See `add-submenu' for documentation."
- :set (function filesets-set-default)
+See `easy-menu-add-item' for documentation."
+ :set #'filesets-set-default
:type '(choice (const :tag "Top Level" nil)
(sexp :tag "Menu Path"))
:version "23.1" ; was nil
- :group 'filesets)
+ )
(defcustom filesets-menu-before "Open File..." ; cf recentf-menu-before
"The name of a menu before which this menu should be added.
-See `add-submenu' for documentation."
- :set (function filesets-set-default)
+See `easy-menu-add-item' for documentation."
+ :set #'filesets-set-default
:type '(choice (string :tag "Name")
(const :tag "Last" nil))
:version "23.1" ; was "File"
- :group 'filesets)
+ )
(defcustom filesets-menu-in-menu nil
"Use that instead of `current-menubar' as the menu to change.
-See `add-submenu' for documentation."
- :set (function filesets-set-default)
- :type 'sexp
- :group 'filesets)
+See `easy-menu-add-item' for documentation."
+ :set #'filesets-set-default
+ :type 'sexp)
(defcustom filesets-menu-shortcuts-flag t
"Non-nil means to prepend menus with hopefully unique shortcuts."
- :set (function filesets-set-default!)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default!
+ :type 'boolean)
(defcustom filesets-menu-shortcuts-marker "%_"
"String for marking menu shortcuts."
- :set (function filesets-set-default!)
- :type 'string
- :group 'filesets)
+ :set #'filesets-set-default!
+ :type 'string)
;;(defcustom filesets-menu-cnvfp-flag nil
;; "Non-nil means show \"Convert :pattern to :files\" entry for :pattern menus."
-;; :set (function filesets-set-default!)
+;; :set #'filesets-set-default!
;; :type 'boolean
;; :group 'filesets)
@@ -354,9 +324,8 @@ See `add-submenu' for documentation."
"File to be used for saving the filesets menu between sessions.
Set this to \"\", to disable caching of menus.
Don't forget to check out `filesets-menu-ensure-use-cached'."
- :set (function filesets-set-default)
- :type 'file
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'file)
(put 'filesets-menu-cache-file 'risky-local-variable t)
(defcustom filesets-menu-cache-contents
@@ -382,7 +351,7 @@ If you want caching to work properly, at least `filesets-submenus',
list.
Don't forget to check out `filesets-menu-ensure-use-cached'."
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(repeat
(choice :tag "Variable"
(const :tag "filesets-submenus"
@@ -399,8 +368,7 @@ Don't forget to check out `filesets-menu-ensure-use-cached'."
:value filesets-ingroup-patterns)
(const :tag "filesets-be-docile-flag"
:value filesets-be-docile-flag)
- (sexp :tag "Other" :value nil)))
- :group 'filesets)
+ (sexp :tag "Other" :value nil))))
(define-obsolete-variable-alias 'filesets-cache-fill-content-hooks
'filesets-cache-fill-content-hook "24.3")
@@ -422,48 +390,43 @@ configuration file, you can add a something like this
to this hook.
Don't forget to check out `filesets-menu-ensure-use-cached'."
- :set (function filesets-set-default)
- :type 'hook
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'hook)
(defcustom filesets-cache-hostname-flag nil
"Non-nil means cache the hostname.
If the current name differs from the cached one,
rebuild the menu and create a new cache file."
- :set (function filesets-set-default)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'boolean)
(defcustom filesets-cache-save-often-flag nil
"Non-nil means save buffer on every change of the filesets menu.
If this variable is set to nil and if Emacs crashes, the cache and
filesets-data could get out of sync. Set this to t if this happens from
time to time or if the fileset cache causes troubles."
- :set (function filesets-set-default)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'boolean)
(defcustom filesets-max-submenu-length 25
"Maximum length of submenus.
Set this value to 0 to turn menu splitting off. BTW, parts of submenus
will not be rewrapped if their length exceeds this value."
- :set (function filesets-set-default)
- :type 'integer
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'integer)
(defcustom filesets-max-entry-length 50
"Truncate names of split submenus to this length."
- :set (function filesets-set-default)
- :type 'integer
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'integer)
-(defcustom filesets-browse-dir-function 'dired
+(defcustom filesets-browse-dir-function #'dired
"A function or command used for browsing directories.
When using an external command, \"%s\" will be replaced with the
directory's name.
Note: You have to manually rebuild the menu if you change this value."
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "dired"
:value dired)
@@ -472,10 +435,9 @@ Note: You have to manually rebuild the menu if you change this value."
(string :tag "Name")
(string :tag "Arguments"))
(function :tag "Function"
- :value nil))
- :group 'filesets)
+ :value nil)))
-(defcustom filesets-open-file-function 'filesets-find-or-display-file
+(defcustom filesets-open-file-function #'filesets-find-or-display-file
"The function used for opening files.
`filesets-find-or-display-file' ... Filesets' default function for
@@ -488,26 +450,24 @@ for a specific file type. Either this viewer, if defined, or
readable, will not be opened.
Caveat: Changes will take effect only after rebuilding the menu."
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "filesets-find-or-display-file"
:value filesets-find-or-display-file)
(const :tag "filesets-find-file"
:value filesets-find-file)
(function :tag "Function"
- :value nil))
- :group 'filesets)
+ :value nil)))
-(defcustom filesets-save-buffer-function 'save-buffer
+(defcustom filesets-save-buffer-function #'save-buffer
"The function used to save a buffer.
Caveat: Changes will take effect after rebuilding the menu."
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "save-buffer"
:value save-buffer)
(function :tag "Function"
- :value nil))
- :group 'filesets)
+ :value nil)))
(defcustom filesets-find-file-delay
(if (and (featurep 'xemacs) gutter-buffers-tab-visible-p)
@@ -518,29 +478,25 @@ This is for calls via `filesets-find-or-display-file'
or `filesets-find-file'.
Set this to 0, if you don't use XEmacs's buffer tabs."
- :set (function filesets-set-default)
- :type 'number
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'number)
(defcustom filesets-be-docile-flag nil
"Non-nil means don't complain if a file or a directory doesn't exist.
This is useful if you want to use the same startup files in different
computer environments."
- :set (function filesets-set-default)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'boolean)
(defcustom filesets-sort-menu-flag t
"Non-nil means sort the filesets menu alphabetically."
- :set (function filesets-set-default)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'boolean)
(defcustom filesets-sort-case-sensitive-flag t
"Non-nil means sorting of the filesets menu is case sensitive."
- :set (function filesets-set-default)
- :type 'boolean
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'boolean)
(defcustom filesets-tree-max-level 3
"Maximum scan depth for directory trees.
@@ -560,9 +516,8 @@ i.e. how deep the menu should be. Try something like
and it should become clear what this option is about. In any case,
including directory trees to the menu can take a lot of memory."
- :set (function filesets-set-default)
- :type 'integer
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'integer)
(defcustom filesets-commands
'(("Isearch"
@@ -589,7 +544,7 @@ function that returns one) to be run on a filesets' files.
The argument <file-name> or <<file-name>> (quoted) will be replaced with
the filename."
- :set (function filesets-set-default+)
+ :set #'filesets-set-default+
:type '(repeat :tag "Commands"
(list :tag "Definition" :value ("")
(string "Name")
@@ -605,8 +560,7 @@ the filename."
(string :tag "Quoted File Name"
:value "<<file-name>>")
(function :tag "Function"
- :value nil)))))
- :group 'filesets)
+ :value nil))))))
(put 'filesets-commands 'risky-local-variable t)
(defcustom filesets-external-viewers
@@ -626,28 +580,33 @@ the filename."
(dvi-cmd "xdvi")
(doc-cmd "antiword")
(pic-cmd "gqview"))
- `(("^.+\\..?html?$" browse-url
+ `((".\\..?html?\\'" browse-url
((:ignore-on-open-all t)))
- ("^.+\\.pdf$" ,pdf-cmd
+ (".\\.pdf\\'" ,pdf-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
- (:constraint-flag ,pdf-cmd)))
- ("^.+\\.e?ps\\(.gz\\)?$" ,ps-cmd
+ ;; (:constraintp ,pdf-cmd)
+ ))
+ (".\\.e?ps\\(?:\\.gz\\)?\\'" ,ps-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
- (:constraint-flag ,ps-cmd)))
- ("^.+\\.dvi$" ,dvi-cmd
+ ;; (:constraintp ,ps-cmd)
+ ))
+ (".\\.dvi\\'" ,dvi-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
- (:constraint-flag ,dvi-cmd)))
- ("^.+\\.doc$" ,doc-cmd
+ ;; (:constraintp ,dvi-cmd)
+ ))
+ (".\\.doc\\'" ,doc-cmd
((:capture-output t)
(:ignore-on-read-text t)
- (:constraint-flag ,doc-cmd)))
- ("^.+\\.\\(tiff\\|xpm\\|gif\\|pgn\\)$" ,pic-cmd
+ ;; (:constraintp ,doc-cmd)
+ ))
+ (".\\.\\(tiff\\|xpm\\|gif\\|pgn\\)\\'" ,pic-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
- (:constraint-flag ,pic-cmd)))))
+ ;; (:constraintp ,pic-cmd)
+ ))))
"Association list of file patterns and external viewers for use with
`filesets-find-or-display-file'.
@@ -664,10 +623,8 @@ i.e. on open-all-files-events or when running commands
:constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil
-:constraint-flag SEXP ... use this viewer only if SEXP evaluates to non-nil
-
-:open-hook HOOK ... run hooks after spawning the viewer -- mainly useful
-in conjunction with :capture-output
+:open-hook FUNCTIONs ... run FUNCTIONs after spawning the viewer -- mainly
+useful in conjunction with :capture-output
:args (FORMAT-STRING or SYMBOL or FUNCTION) ... a list of arguments
\(defaults to (list \"%S\")) when using shell commands
@@ -692,7 +649,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
(:constraintp (lambda ()
(and (filesets-which-command-p \"rtf2htm\")
(filesets-which-command-p \"w3m\"))))))"
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(repeat :tag "Viewer"
(list :tag "Definition"
:value ("^.+\\.suffix$" "")
@@ -707,7 +664,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
(const :format ""
:value :constraintp)
(function :tag "Function"))
- (list :tag ":constraint-flag"
+ (list :tag ":constraint-flag (obsolete)"
:value (:constraint-flag)
(const :format ""
:value :constraint-flag)
@@ -748,8 +705,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
:value (:capture-output t)
(const :format ""
:value :capture-output)
- (boolean :tag "Boolean"))))))
- :group 'filesets)
+ (boolean :tag "Boolean")))))))
(put 'filesets-external-viewers 'risky-local-variable t)
(defcustom filesets-ingroup-patterns
@@ -890,7 +846,7 @@ With duplicates removed, it would be:
M + A - X
B"
- :set (function filesets-set-default)
+ :set #'filesets-set-default
:type '(repeat
:tag "Include"
(list
@@ -936,8 +892,7 @@ With duplicates removed, it would be:
(list :tag ":preprocess"
:value (:preprocess)
(const :format "" :value :preprocess)
- (function :tag "Function")))))))
- :group 'filesets)
+ (function :tag "Function"))))))))
(put 'filesets-ingroup-patterns 'risky-local-variable t)
(defcustom filesets-data nil
@@ -1008,8 +963,7 @@ is used.
Before using :ingroup, make sure that the file type is already
defined in `filesets-ingroup-patterns'."
- :group 'filesets
- :set (function filesets-data-set-default)
+ :set #'filesets-data-set-default
:type '(repeat
(cons :tag "Fileset"
(string :tag "Name" :value "")
@@ -1071,22 +1025,9 @@ defined in `filesets-ingroup-patterns'."
(defcustom filesets-query-user-limit 15
"Query the user before opening a fileset with that many files."
- :set (function filesets-set-default)
- :type 'integer
- :group 'filesets)
+ :set #'filesets-set-default
+ :type 'integer)
-;;; Emacs compatibility
-(eval-and-compile
- (if (featurep 'xemacs)
- (fset 'filesets-error 'error)
-
- (require 'easymenu)
-
- (defun filesets-error (_class &rest args)
- "`error' wrapper."
- (error "%s" (mapconcat 'identity args " ")))
-
- ))
(defun filesets-filter-dir-names (lst &optional negative)
"Remove non-directory names from a list of strings.
@@ -1138,16 +1079,16 @@ Return full path if FULL-FLAG is non-nil."
(string-match-p pattern this))
(filesets-message 5 "Filesets: matched dir %S with pattern %S"
this pattern)
- (setq dirs (cons this dirs))))
+ (push this dirs)))
(t
(when (or (not pattern)
(string-match-p pattern this))
(filesets-message 5 "Filesets: matched file %S with pattern %S"
this pattern)
- (setq files (cons (if full-flag
- (concat (file-name-as-directory dir) this)
- this)
- files))))))
+ (push (if full-flag
+ (concat (file-name-as-directory dir) this)
+ this)
+ files)))))
(cond
((equal what ':dirs)
(filesets-conditional-sort dirs))
@@ -1160,7 +1101,7 @@ Return full path if FULL-FLAG is non-nil."
(filesets-message 1 "Filesets: %S doesn't exist" dir)
nil)
(t
- (filesets-error 'error "Filesets: " dir " does not exist"))))
+ (error "Filesets: %s does not exist" dir))))
(defun filesets-quote (txt)
"Return TXT in quotes."
@@ -1172,7 +1113,7 @@ Return full path if FULL-FLAG is non-nil."
(p (point)))
(if m
(buffer-substring (min m p) (max m p))
- (filesets-error 'error "No selection."))))
+ (error "No selection"))))
(defun filesets-get-quoted-selection ()
"Return the currently selected text in quotes."
@@ -1204,7 +1145,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-convert-path-list (string)
"Return a path-list given as STRING as list."
(if string
- (mapcar (lambda (x) (file-name-as-directory x))
+ (mapcar #'file-name-as-directory
(split-string string path-separator))
nil))
@@ -1214,17 +1155,17 @@ Return full path if FULL-FLAG is non-nil."
filename)))
(if (file-exists-p f)
f
- (filesets-some
+ (cl-some
(lambda (dir)
(let ((dir (file-name-as-directory dir))
(files (if (file-exists-p dir)
(filesets-directory-files dir nil ':files)
nil)))
- (filesets-some (lambda (file)
- (if (equal filename (file-name-nondirectory file))
- (concat dir file)
- nil))
- files)))
+ (cl-some (lambda (file)
+ (if (equal filename (file-name-nondirectory file))
+ (concat dir file)
+ nil))
+ files)))
path-list))))
@@ -1234,20 +1175,22 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-eviewer-constraint-p (entry)
(let* ((props (filesets-eviewer-get-props entry))
- (constraint (assoc ':constraintp props))
- (constraint-flag (assoc ':constraint-flag props)))
+ (constraint (assoc :constraintp props))
+ (constraint-flag (assoc :constraint-flag props)))
(cond
(constraint
(funcall (cadr constraint)))
(constraint-flag
- (eval (cadr constraint-flag)))
+ (message "Obsolete :constraint-flag %S, use :constraintp instead"
+ (cadr constraint-flag))
+ (eval (cadr constraint-flag) t))
(t
t))))
(defun filesets-get-external-viewer (file)
"Find an external viewer for FILE."
(let ((filename (file-name-nondirectory file)))
- (filesets-some
+ (cl-some
(lambda (entry)
(when (and (string-match-p (nth 0 entry) filename)
(filesets-eviewer-constraint-p entry))
@@ -1257,7 +1200,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-get-external-viewer-by-name (name)
"Get the external viewer definition called NAME."
(when name
- (filesets-some
+ (cl-some
(lambda (entry)
(when (and (string-equal (nth 1 entry) name)
(filesets-eviewer-constraint-p entry))
@@ -1319,17 +1262,13 @@ Use the viewer defined in EV-ENTRY (a valid element of
(oh (filesets-filetype-get-prop ':open-hook file entry))
(args (let ((fmt (filesets-filetype-get-prop ':args file entry)))
(if fmt
- (let ((rv ""))
- (dolist (this fmt rv)
- (setq rv (concat rv
- (cond
- ((stringp this)
- (format this file))
- ((and (symbolp this)
- (fboundp this))
- (format "%S" (funcall this)))
- (t
- (format "%S" this)))))))
+ (mapconcat
+ (lambda (this)
+ (if (stringp this) (format this file)
+ (format "%S" (if (functionp this)
+ (funcall this)
+ this))))
+ fmt "")
(format "%S" file))))
(output
(cond
@@ -1347,18 +1286,18 @@ Use the viewer defined in EV-ENTRY (a valid element of
(progn
(switch-to-buffer (format "Filesets: %s %s" vwr file))
(insert output)
- (make-local-variable 'filesets-output-buffer-flag)
- (setq filesets-output-buffer-flag t)
+ (setq-local filesets-output-buffer-flag t)
(set-visited-file-name file t)
- (when oh
- (run-hooks 'oh))
+ (if (functionp oh)
+ (funcall oh)
+ (mapc #'funcall oh))
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(goto-char (point-min)))
- (when oh
- (run-hooks 'oh))))
- (filesets-error 'error
- "Filesets: general error when spawning external viewer"))))
+ (if (functionp oh)
+ (funcall oh)
+ (mapc #'funcall oh))))
+ (error "Filesets: general error when spawning external viewer"))))
(defun filesets-find-file (file)
"Call `find-file' after a possible delay (see `filesets-find-file-delay').
@@ -1368,7 +1307,8 @@ not be opened."
(when (or (file-readable-p file)
(not filesets-be-docile-flag))
(sit-for filesets-find-file-delay)
- (find-file file)))
+ (with-suppressed-warnings ((interactive-only find-file))
+ (find-file file))))
(defun filesets-find-or-display-file (&optional file viewer)
"Visit FILE using an external VIEWER or open it in an Emacs buffer."
@@ -1407,7 +1347,8 @@ not be opened."
(if (functionp filesets-browse-dir-function)
(funcall filesets-browse-dir-function dir)
(let ((name (car filesets-browse-dir-function))
- (args (format (cadr filesets-browse-dir-function) (expand-file-name dir))))
+ (args (format (cadr filesets-browse-dir-function)
+ (expand-file-name dir))))
(with-temp-buffer
(start-process (concat "Filesets:" name)
"*Filesets external directory browser*"
@@ -1458,7 +1399,7 @@ Return DEFAULT if not found. Return (car VALUE) if CARP is non-nil."
"Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup.
See `filesets-data'."
(let ((data (filesets-data-get-data entry)))
- (filesets-some
+ (cl-some
(lambda (x)
(if (assoc x data)
x))
@@ -1570,16 +1511,15 @@ SAVE-FUNCTION takes no argument, but works on the current buffer."
(assoc cmd-name filesets-commands))
(defun filesets-cmd-get-args (cmd-name)
- (let ((args (let ((def (filesets-cmd-get-def cmd-name)))
- (nth 2 def)))
- (rv nil))
- (dolist (this args rv)
- (cond
- ((and (symbolp this) (fboundp this))
- (let ((x (funcall this)))
- (setq rv (append rv (if (listp x) x (list x))))))
- (t
- (setq rv (append rv (list this))))))))
+ (mapcan (lambda (this)
+ (cond
+ ((and (symbolp this) (fboundp this))
+ (let ((x (funcall this)))
+ (if (listp x) x (list x))))
+ (t
+ (list this))))
+ (let ((def (filesets-cmd-get-def cmd-name)))
+ (nth 2 def))))
(defun filesets-cmd-get-fn (cmd-name)
(let ((def (filesets-cmd-get-def cmd-name)))
@@ -1617,18 +1557,20 @@ Replace <file-name> or <<file-name>> with filename."
(completing-read "Select fileset: " filesets-data nil t))))
(when (and cmd-name name)
(let* ((event (if (equal cmd-name "Grep <<selection>>")
- 'on-grep
+ 'on-grep
'on-cmd))
(files (if (and fileset
- (or (equal mode ':ingroup)
- (equal mode ':tree)))
+ (or (equal mode :ingroup)
+ (equal mode :tree)))
(filesets-get-filelist fileset mode event)
- (filesets-get-filelist
- (filesets-get-fileset-from-name name)
- mode event))))
+ (filesets-get-filelist
+ (filesets-get-fileset-from-name name)
+ mode event))))
(when files
(let ((fn (filesets-cmd-get-fn cmd-name))
- (args (filesets-cmd-get-args cmd-name)))
+ (args
+ (dlet ((filesets--files files))
+ (filesets-cmd-get-args cmd-name))))
(if (memq fn '(multi-isearch-files multi-isearch-files-regexp))
(apply fn args)
(dolist (this files nil)
@@ -1637,32 +1579,27 @@ Replace <file-name> or <<file-name>> with filename."
(let ((buffer (filesets-find-file this)))
(when buffer
(goto-char (point-min))
- (progn
- (cond
- ((stringp fn)
- (let* ((args
- (let ((txt ""))
- (dolist (this args txt)
- (setq txt
- (concat txt
- (filesets-run-cmd--repl-fn
- this
- (lambda (this)
- (if (equal txt "") "" " ")
- (format "%s" this))))))))
- (cmd (concat fn " " args)))
- (filesets-cmd-show-result
- cmd (shell-command-to-string cmd))))
- ((symbolp fn)
- (let ((args
- (let ((argl nil))
- (dolist (this args argl)
- (setq argl
- (append argl
- (filesets-run-cmd--repl-fn
- this
- 'list)))))))
- (apply fn args)))))))))))))))))
+ (cond
+ ((stringp fn)
+ (let* ((args
+ (mapconcat
+ (lambda (this)
+ (filesets-run-cmd--repl-fn
+ this
+ (lambda (this)
+ (format "%s" this))))
+ args
+ " "))
+ (cmd (concat fn " " args)))
+ (filesets-cmd-show-result
+ cmd (shell-command-to-string cmd))))
+ ((symbolp fn)
+ (apply fn
+ (mapcan (lambda (this)
+ (filesets-run-cmd--repl-fn
+ this
+ 'list))
+ args))))))))))))))))
(defun filesets-get-cmd-menu ()
"Create filesets command menu."
@@ -1688,7 +1625,7 @@ Replace <file-name> or <<file-name>> with filename."
(defun filesets-cmd-isearch-getargs ()
"Get arguments for `multi-isearch-files' and `multi-isearch-files-regexp'."
- (and (boundp 'files) (list files)))
+ (and (boundp 'filesets--files) (list filesets--files)))
(defun filesets-cmd-shell-command-getargs ()
"Get arguments for `filesets-cmd-shell-command'."
@@ -1730,9 +1667,12 @@ Assume MODE (see `filesets-entry-mode'), if provided."
(filesets-entry-get-master entry)))))
(cons entry (filesets-ingroup-cache-get entry))))
(:tree
- (let ((dir (nth 0 entry))
- (patt (nth 1 entry)))
- (filesets-directory-files dir patt ':files t)))
+ (let* ((dirpatt (filesets-entry-get-tree entry))
+ (dir (nth 0 dirpatt))
+ (patt (nth 1 dirpatt))
+ (depth (or (filesets-entry-get-tree-max-level entry)
+ filesets-tree-max-level)))
+ (filesets-files-under 0 depth entry dir patt)))
(:pattern
(let ((dirpatt (filesets-entry-get-pattern entry)))
(if dirpatt
@@ -1741,12 +1681,39 @@ Assume MODE (see `filesets-entry-mode'), if provided."
;;(filesets-message 3 "Filesets: scanning %s" dirpatt)
(filesets-directory-files dir patt ':files t))
;; (message "Filesets: malformed entry: %s" entry)))))))
- (filesets-error 'error "Filesets: malformed entry: "
- entry)))))))
+ (error "Filesets: malformed entry: %s" entry)))))))
(filesets-filter-list fl
(lambda (file)
(not (filesets-filetype-property file event))))))
+(defun filesets-files-under (level depth entry dir patt &optional relativep)
+ "Files under DIR that match PATT.
+LEVEL is the current level under DIR.
+DEPTH is the maximal tree scanning depth for ENTRY.
+ENTRY is a fileset.
+DIR is a directory.
+PATT is a regexp that included file names must match.
+RELATIVEP non-nil means use relative file names."
+ (and (or (= depth 0) (< level depth))
+ (let* ((dir (file-name-as-directory dir))
+ (files-here (filesets-directory-files
+ dir patt nil (not relativep)
+ (filesets-entry-get-filter-dirs-flag entry)))
+ (subdirs (filesets-filter-dir-names files-here))
+ (files
+ (filesets-filter-dir-names
+ (apply #'append
+ files-here
+ (mapcar
+ (lambda (subdir)
+ (let* ((subdir (file-name-as-directory subdir))
+ (full-subdir (concat dir subdir)))
+ (filesets-files-under (+ level 1) depth entry
+ full-subdir patt)))
+ subdirs))
+ t)))
+ files)))
+
(defun filesets-open (&optional mode name lookup-name)
"Open the fileset called NAME.
Use LOOKUP-NAME for searching additional data if provided."
@@ -1768,7 +1735,7 @@ Use LOOKUP-NAME for searching additional data if provided."
(dolist (this files nil)
(filesets-file-open open-function this))
(message "Filesets: canceled")))
- (filesets-error 'error "Filesets: Unknown fileset: " name))))
+ (error "Filesets: Unknown fileset: %s" name))))
(defun filesets-close (&optional mode name lookup-name)
"Close all buffers belonging to the fileset called NAME.
@@ -1789,7 +1756,7 @@ Use LOOKUP-NAME for deducing the save-function, if provided."
(if buffer
(filesets-file-close save-function buffer)))))
; (message "Filesets: Unknown fileset: `%s'" name))))
- (filesets-error 'error "Filesets: Unknown fileset: " name))))
+ (error "Filesets: Unknown fileset: %s" name))))
(defun filesets-add-buffer (&optional name buffer)
"Add BUFFER (or current buffer) to the fileset called NAME.
@@ -1815,8 +1782,8 @@ User will be queried, if no fileset name is provided."
(if entry
(let* ((files (filesets-entry-get-files entry))
(this (buffer-file-name buffer))
- (inlist (filesets-member this files
- :test 'filesets-files-equalp)))
+ (inlist (cl-member this files
+ :test #'filesets-files-equalp)))
(cond
(inlist
(message "Filesets: `%s' is already in `%s'" this name))
@@ -1841,8 +1808,8 @@ User will be queried, if no fileset name is provided."
(if entry
(let* ((files (filesets-entry-get-files entry))
(this (buffer-file-name buffer))
- (inlist (filesets-member this files
- :test 'filesets-files-equalp)))
+ (inlist (cl-member this files
+ :test #'filesets-files-equalp)))
;;(message "%s %s %s" files this inlist)
(if (and files this inlist)
(let ((new (list (cons ':files (delete (car inlist) files)))))
@@ -1891,7 +1858,7 @@ User will be queried, if no fileset name is provided."
(substring (elt submenu 0) 2))))
(if (listp submenu)
(cons name (cdr submenu))
- (apply 'vector (list name (cdr (append submenu nil)))))))
+ (apply #'vector (list name (cadr (append submenu nil)))))))
; (vconcat `[,name] (subseq submenu 1)))))
(defun filesets-wrap-submenu (submenu-body)
@@ -1909,12 +1876,14 @@ User will be queried, if no fileset name is provided."
((or (> count bl)
(null data)))
;; (let ((sl (subseq submenu-body count
- (let ((sl (filesets-sublist submenu-body count
- (let ((x (+ count factor)))
- (if (>= bl x)
- x
- nil)))))
+ (let ((sl (seq-subseq submenu-body count
+ (let ((x (+ count factor)))
+ (if (>= bl x)
+ x
+ nil)))))
(when sl
+ ;; FIXME: O(n²) performance bug because of repeated `append':
+ ;; use `mapcan'?
(setq result
(append
result
@@ -1931,6 +1900,8 @@ User will be queried, if no fileset name is provided."
(if (null (cdr x))
""
", "))))
+ ;; FIXME: O(n²) performance bug because of
+ ;; repeated `concat': use `mapconcat'?
(setq rv
(concat
rv
@@ -1997,7 +1968,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
`(["Rebuild this submenu"
(filesets-rebuild-this-submenu ',lookup-name)]))))
(_
- (filesets-error 'error "Filesets: malformed definition of " something))))
+ (error "Filesets: malformed definition of %s" something))))
(defun filesets-ingroup-get-data (master pos &optional fun)
"Access to `filesets-ingroup-patterns'. Extract data section."
@@ -2006,11 +1977,11 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(and (stringp a)
(stringp b)
(string-match-p a b))))))
- (filesets-some (lambda (x)
- (if (funcall fn (car x) masterfile)
- (nth pos x)
- nil))
- filesets-ingroup-patterns)))
+ (cl-some (lambda (x)
+ (if (funcall fn (car x) masterfile)
+ (nth pos x)
+ nil))
+ filesets-ingroup-patterns)))
(defun filesets-ingroup-get-pattern (master)
"Access to `filesets-ingroup-patterns'. Extract patterns."
@@ -2022,12 +1993,8 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(defun filesets-ingroup-collect-finder (patt case-sensitivep)
"Helper function for `filesets-ingroup-collect'. Find pattern PATT."
- (let ((cfs case-fold-search)
- (rv (progn
- (setq case-fold-search (not case-sensitivep))
- (re-search-forward patt nil t))))
- (setq case-fold-search cfs)
- rv))
+ (let ((case-fold-search (not case-sensitivep)))
+ (re-search-forward patt nil t)))
(defun filesets-ingroup-cache-get (master)
"Access to `filesets-ingroup-cache'."
@@ -2070,8 +2037,7 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(lst nil))
(cond
((not this-patt)
- (filesets-error 'error "Filesets: malformed :ingroup definition "
- this-def))
+ (error "Filesets: malformed :ingroup definition %s" this-def))
((< this-sd 0)
nil)
(t
@@ -2086,9 +2052,9 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(when (and f
(not (member f flist))
(or (not remdupl-flag)
- (not (filesets-member
+ (not (cl-member
f filesets-ingroup-files
- :test 'filesets-files-equalp))))
+ :test #'filesets-files-equalp))))
(let ((no-stub-flag
(and (not this-stub-flag)
(if this-stubp
@@ -2100,16 +2066,18 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(cons f filesets-ingroup-files))
(when no-stub-flag
(filesets-ingroup-cache-put master f))
- (setq lst (append lst (list f))))))))
+ (push f lst))))))
(when lst
(setq rv
+ ;; FIXME: O(n²) performance bug because of repeated
+ ;; `nconc'.
(nconc rv
(mapcar (lambda (this)
`((,this ,this-name)
,@(filesets-ingroup-collect-files
fs remdupl-flag this
(- this-sd 1))))
- lst))))))))
+ (nreverse lst)))))))))
(filesets-message 2 "Filesets: no patterns defined for %S" master)))))
(defun filesets-ingroup-collect-build-menu (fs flist &optional other-count)
@@ -2119,42 +2087,41 @@ FS is a fileset's name. FLIST is a list returned by
(if (null flist)
nil
(let ((count 0)
- (fsn fs)
- (rv nil))
- (dolist (this flist rv)
- (setq count (+ count 1))
- (let* ((def (if (listp this) (car this) (list this "")))
- (files (if (listp this) (cdr this) nil))
- (master (nth 0 def))
- (name (nth 1 def))
- (nm (concat (filesets-get-shortcut (if (or (not other-count) files)
- count other-count))
- (if (or (null name) (equal name ""))
- ""
- (format "%s: " name))
- (file-name-nondirectory master))))
- (setq rv
- (append rv
- (if files
- `((,nm
- [,(concat "Inclusion Group: "
- (file-name-nondirectory master))
- (filesets-open ':ingroup ',master ',fsn)]
- "---"
- [,master (filesets-file-open nil ',master ',fsn)]
- "---"
- ,@(let ((count 0))
- (mapcar
- (lambda (this)
- (setq count (+ count 1))
- (let ((ff (filesets-ingroup-collect-build-menu
- fs (list this) count)))
- (if (= (length ff) 1)
- (car ff)
- ff)))
- files))
- ,@(filesets-get-menu-epilog master ':ingroup fsn)))
- `([,nm (filesets-file-open nil ',master ',fsn)])))))))))
+ (fsn fs))
+ (mapcan (lambda (this)
+ (setq count (+ count 1))
+ (let* ((def (if (listp this) (car this) (list this "")))
+ (files (if (listp this) (cdr this) nil))
+ (master (nth 0 def))
+ (name (nth 1 def))
+ (nm (concat (filesets-get-shortcut
+ (if (or (not other-count) files)
+ count other-count))
+ (if (or (null name) (equal name ""))
+ ""
+ (format "%s: " name))
+ (file-name-nondirectory master))))
+ (if files
+ `((,nm
+ [,(concat "Inclusion Group: "
+ (file-name-nondirectory master))
+ (filesets-open ':ingroup ',master ',fsn)]
+ "---"
+ [,master (filesets-file-open nil ',master ',fsn)]
+ "---"
+ ,@(let ((count 0))
+ (mapcar
+ (lambda (this)
+ (setq count (+ count 1))
+ (let ((ff (filesets-ingroup-collect-build-menu
+ fs (list this) count)))
+ (if (= (length ff) 1)
+ (car ff)
+ ff)))
+ files))
+ ,@(filesets-get-menu-epilog master ':ingroup fsn)))
+ `([,nm (filesets-file-open nil ',master ',fsn)]))))
+ flist))))
(defun filesets-ingroup-collect (fs remdupl-flag master)
"Collect names of included files and build submenu."
@@ -2174,7 +2141,7 @@ FS is a fileset's name. FLIST is a list returned by
(progn
(message "Filesets: can't parse %s" master)
nil)
- (filesets-error 'error "Filesets: can't parse " master))))
+ (error "Filesets: can't parse %s" master))))
(defun filesets-build-dir-submenu-now (level depth entry lookup-name dir patt fd
&optional rebuild-flag)
@@ -2259,7 +2226,7 @@ Construct a shortcut from COUNT."
(:pattern
(let* ((files (filesets-get-filelist entry mode 'on-ls))
(dirpatt (filesets-entry-get-pattern entry))
- (pattname (apply 'concat (cons "Pattern: " dirpatt)))
+ (pattname (apply #'concat (cons "Pattern: " dirpatt)))
(count 0))
;;(filesets-message 3 "Filesets: scanning %S" pattname)
`([,pattname
@@ -2349,21 +2316,20 @@ bottom up, set `filesets-submenus' to nil, first.)"
(filesets-menu-cache-file-save-maybe)))
(let ((cb (current-buffer)))
(when (not (member cb filesets-updated-buffers))
- (add-submenu
- filesets-menu-path
- `(,filesets-menu-name
- ("# Filesets"
- ["Edit Filesets" filesets-edit]
- ["Save Filesets" filesets-save-config]
- ["Save Menu Cache" filesets-menu-cache-file-save]
- ["Rebuild Menu" filesets-build-menu]
- ["Customize" filesets-customize]
- ["About" filesets-info])
- ,(filesets-get-cmd-menu)
- "---"
- ,@filesets-menu-cache)
- filesets-menu-before
- filesets-menu-in-menu)
+ (easy-menu-add-item (or filesets-menu-in-menu (current-global-map))
+ (cons "menu-bar" filesets-menu-path)
+ `(,filesets-menu-name
+ ("# Filesets"
+ ["Edit Filesets" filesets-edit]
+ ["Save Filesets" filesets-save-config]
+ ["Save Menu Cache" filesets-menu-cache-file-save]
+ ["Rebuild Menu" filesets-build-menu]
+ ["Customize" filesets-customize]
+ ["About" filesets-info])
+ ,(filesets-get-cmd-menu)
+ "---"
+ ,@filesets-menu-cache)
+ filesets-menu-before)
(setq filesets-updated-buffers
(cons cb filesets-updated-buffers))
;; This wipes out other messages in the echo area.
@@ -2403,14 +2369,14 @@ fileset thinks this is necessary or not."
(dolist (this filesets-menu-cache-contents)
(if (get this 'custom-type)
(progn
- (insert (format "(setq-default %s '%S)" this (eval this)))
+ (insert (format "(setq-default %s '%S)" this (eval this t)))
(when filesets-menu-ensure-use-cached
(newline)
(insert (format "(setq %s (cons '%s %s))"
'filesets-ignore-next-set-default
this
'filesets-ignore-next-set-default))))
- (insert (format "(setq %s '%S)" this (eval this))))
+ (insert (format "(setq %s '%S)" this (eval this t))))
(newline 2))
(insert (format "(setq filesets-cache-version %S)" filesets-version))
(newline 2)
@@ -2474,7 +2440,7 @@ We apologize for the inconvenience.")))
(insert msg)
(when (y-or-n-p (format "Edit startup (%s) file now? " cf))
(find-file-other-window cf))
- (filesets-error 'error msg))))
+ (error msg))))
(defun filesets-update (cached-version)
"Do some cleanup after updating filesets.el."
@@ -2510,11 +2476,10 @@ We apologize for the inconvenience.")))
(defun filesets-init ()
"Filesets initialization.
Set up hooks, load the cache file -- if existing -- and build the menu."
- (add-hook (if (featurep 'xemacs) 'activate-menubar-hook 'menu-bar-update-hook)
- (function filesets-build-menu-maybe))
- (add-hook 'kill-buffer-hook (function filesets-remove-from-ubl))
- (add-hook 'first-change-hook (function filesets-reset-filename-on-change))
- (add-hook 'kill-emacs-hook (function filesets-exit))
+ (add-hook 'menu-bar-update-hook #'filesets-build-menu-maybe)
+ (add-hook 'kill-buffer-hook #'filesets-remove-from-ubl)
+ (add-hook 'first-change-hook #'filesets-reset-filename-on-change)
+ (add-hook 'kill-emacs-hook #'filesets-exit)
(if (filesets-menu-cache-file-load)
(progn
(filesets-build-menu-maybe)
@@ -2525,6 +2490,10 @@ Set up hooks, load the cache file -- if existing -- and build the menu."
(setq filesets-menu-use-cached-flag t)))
(filesets-build-menu)))
+(defun filesets-error (_class &rest args)
+ "`error' wrapper."
+ (declare (obsolete error "28.1"))
+ (error "%s" (mapconcat #'identity args " ")))
(provide 'filesets)
diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el
index 5866b308551..bb2e97d8662 100644
--- a/lisp/find-cmd.el
+++ b/lisp/find-cmd.el
@@ -1,4 +1,4 @@
-;;; find-cmd.el --- Build a valid find(1) command with sexps
+;;; find-cmd.el --- Build a valid find(1) command with sexps -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -28,7 +28,7 @@
;; (find-cmd '(prune (name ".svn" ".git" ".CVS"))
;; '(and (or (name "*.pl" "*.pm" "*.t")
;; (mtime "+1"))
-;; (fstype "nfs" "ufs"))))
+;; (fstype "nfs" "ufs")))
;; will become (un-wrapped):
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index a45cf7e670d..87a7407a866 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -85,8 +85,8 @@ the options \"-dilsb\".
While the option `find -ls' often produces unsorted output, the option
`find -exec ls -ld' maintains the sorting order only on short output,
-whereas `find -print | sort | xargs' produced sorted output even
-on the large number of files."
+whereas `find -print | sort | xargs' produces sorted output even
+on a large number of files."
:version "27.1" ; add choice of predefined set of options
:type `(choice
(cons :tag "find -ls"
@@ -164,7 +164,10 @@ The command run (after changing into DIR) is essentially
find . \\( ARGS \\) -ls
except that the car of the variable `find-ls-option' specifies what to
-use in place of \"-ls\" as the final argument."
+use in place of \"-ls\" as the final argument.
+
+Collect output in the \"*Find*\" buffer. To kill the job before
+it finishes, type \\[kill-find]."
(interactive (list (read-directory-name "Run find in directory: " nil "" t)
(read-string "Run find (with args): " find-args
'(find-args-history . 1))))
@@ -215,17 +218,15 @@ use in place of \"-ls\" as the final argument."
(car find-ls-option))))
;; Start the find process.
(shell-command (concat args "&") (current-buffer))
- ;; The next statement will bomb in classic dired (no optional arg allowed)
(dired-mode dir (cdr find-ls-option))
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (current-local-map))
(define-key map "\C-c\C-k" 'kill-find)
(use-local-map map))
- (make-local-variable 'dired-sort-inhibit)
- (setq dired-sort-inhibit t)
- (set (make-local-variable 'revert-buffer-function)
- `(lambda (ignore-auto noconfirm)
- (find-dired ,dir ,find-args)))
+ (setq-local dired-sort-inhibit t)
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (find-dired dir find-args)))
;; Set subdir-alist so that Tree Dired will work:
(if (fboundp 'dired-simple-subdir-alist)
;; will work even with nested dired format (dired-nstd.el,v 1.15
@@ -233,9 +234,9 @@ use in place of \"-ls\" as the final argument."
(dired-simple-subdir-alist)
;; else we have an ancient tree dired (or classic dired, where
;; this does no harm)
- (set (make-local-variable 'dired-subdir-alist)
- (list (cons default-directory (point-min-marker)))))
- (set (make-local-variable 'dired-subdir-switches) find-ls-subdir-switches)
+ (setq-local dired-subdir-alist
+ (list (cons default-directory (point-min-marker)))))
+ (setq-local dired-subdir-switches find-ls-subdir-switches)
(setq buffer-read-only nil)
;; Subdir headlerline must come first because the first marker in
;; subdir-alist points there.
@@ -247,8 +248,8 @@ use in place of \"-ls\" as the final argument."
(dired-insert-set-properties point (point)))
(setq buffer-read-only t)
(let ((proc (get-buffer-process (current-buffer))))
- (set-process-filter proc (function find-dired-filter))
- (set-process-sentinel proc (function find-dired-sentinel))
+ (set-process-filter proc #'find-dired-filter)
+ (set-process-sentinel proc #'find-dired-sentinel)
;; Initialize the process marker; it is used by the filter.
(move-marker (process-mark proc) (point) (current-buffer)))
(setq mode-line-process '(":%s"))))
@@ -258,7 +259,7 @@ use in place of \"-ls\" as the final argument."
(interactive)
(let ((find (get-buffer-process (current-buffer))))
(and find (eq (process-status find) 'run)
- (eq (process-filter find) (function find-dired-filter))
+ (eq (process-filter find) #'find-dired-filter)
(condition-case nil
(delete-process find)
(error nil)))))
diff --git a/lisp/find-file.el b/lisp/find-file.el
index 4ad36a017b7..4fd4f4e06b8 100644
--- a/lisp/find-file.el
+++ b/lisp/find-file.el
@@ -1,4 +1,4 @@
-;;; find-file.el --- find a file corresponding to this one given a pattern
+;;; find-file.el --- find a file corresponding to this one given a pattern -*- lexical-binding: t; -*-
;; Author: Henry Guillaume <henri@tibco.com, henry@c032.aone.net.au>
;; Maintainer: emacs-devel@gnu.org
@@ -39,8 +39,8 @@
;; and just has a different extension as described by the ff-other-file-alist
;; variable:
;;
-;; '(("\\.cc$" (".hh" ".h"))
-;; ("\\.hh$" (".cc" ".C" ".CC" ".cxx" ".cpp")))
+;; '(("\\.cc\\'" (".hh" ".h"))
+;; ("\\.hh\\'" (".cc" ".C" ".CC" ".cxx" ".cpp")))
;;
;; If the current file has a .cc extension, ff-find-other-file will attempt
;; to look for a .hh file, and then a .h file in some directory as described
@@ -55,8 +55,8 @@
;; format above can be changed to include a function to be called when the
;; current file matches the regexp:
;;
-;; '(("\\.cc$" cc--function)
-;; ("\\.hh$" hh-function))
+;; '(("\\.cc\\'" cc--function)
+;; ("\\.hh\\'" hh-function))
;;
;; These functions must return a list consisting of the possible names of the
;; corresponding file, with or without path. There is no real need for more
@@ -64,10 +64,10 @@
;; file-alist:
;;
;; (setq cc-other-file-alist
-;; '(("\\.cc$" ff-cc-hh-converter)
-;; ("\\.hh$" ff-cc-hh-converter)
-;; ("\\.c$" (".h"))
-;; ("\\.h$" (".c" ".cc" ".C" ".CC" ".cxx" ".cpp"))))
+;; '(("\\.cc\\'" ff-cc-hh-converter)
+;; ("\\.hh\\'" ff-cc-hh-converter)
+;; ("\\.c\\'" (".h"))
+;; ("\\.h\\'" (".c" ".cc" ".C" ".CC" ".cxx" ".cpp"))))
;;
;; ff-cc-hh-converter is included at the end of this file as a reference.
;;
@@ -109,8 +109,8 @@
;; file.
;; CREDITS:
-;; Many thanks go to TUSC Computer Systems Pty Ltd for providing an environ-
-;; ment that made the development of this package possible.
+;; Many thanks go to TUSC Computer Systems Pty Ltd for providing an
+;; environment that made the development of this package possible.
;;
;; Many thanks also go to all those who provided valuable feedback throughout
;; the development of this package:
@@ -130,62 +130,51 @@
(defcustom ff-pre-find-hook nil
"List of functions to be called before the search for the file starts."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-pre-load-hook nil
"List of functions to be called before the other file is loaded."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-post-load-hook nil
"List of functions to be called after the other file is loaded."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-not-found-hook nil
"List of functions to be called if the other file could not be found."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-file-created-hook nil
"List of functions to be called if the other file needs to be created."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-case-fold-search nil
"Non-nil means ignore cases in matches (see `case-fold-search').
If you have extensions in different cases, you will want this to be nil."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-always-in-other-window nil
"If non-nil, find the corresponding file in another window by default.
To override this, give an argument to `ff-find-other-file'."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-ignore-include nil
"If non-nil, ignore `#include' lines."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-always-try-to-create t
"If non-nil, always attempt to create the other file if it was not found."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-quiet-mode nil
"If non-nil, trace which directories are being searched."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
;;;###autoload
(defcustom ff-special-constructs
;; C/C++ include, for NeXTstep too
`((,(purecopy "^#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") .
- (lambda ()
- (buffer-substring (match-beginning 2) (match-end 2)))))
+ ,(lambda () (match-string 2))))
;; We include `ff-treat-as-special' documentation here so that autoload
;; can make it available to be read prior to loading this file.
"List of special constructs recognized by `ff-treat-as-special'.
@@ -194,8 +183,7 @@ If REGEXP matches the current line (from the beginning of the line),
`ff-treat-as-special' calls function EXTRACT with no args.
If EXTRACT returns nil, keep trying. Otherwise, return the
filename that EXTRACT returned."
- :type '(repeat (cons regexp function))
- :group 'ff)
+ :type '(repeat (cons regexp function)))
(defvaralias 'ff-related-file-alist 'ff-other-file-alist)
(defcustom ff-other-file-alist 'cc-other-file-alist
@@ -207,8 +195,7 @@ directory specified in `ff-search-directories'. If a file is not found,
a new one is created with the first matching extension (`.cc' yields `.hh').
This alist should be set by the major mode."
:type '(choice (repeat (list regexp (choice (repeat string) function)))
- symbol)
- :group 'ff)
+ symbol))
(defcustom ff-search-directories 'cc-search-directories
"List of directories to search for a specific file.
@@ -231,14 +218,12 @@ not exist, it is replaced (silently) with an empty string.
The stars are *not* wildcards: they are searched for together with
the preceding slash. The star represents all the subdirectories except
`..', and each of these subdirectories will be searched in turn."
- :type '(choice (repeat directory) symbol)
- :group 'ff)
+ :type '(choice (repeat directory) symbol))
(defcustom cc-search-directories
'("." "/usr/include" "/usr/local/include/*")
"See the description of the `ff-search-directories' variable."
- :type '(repeat directory)
- :group 'ff)
+ :type '(repeat directory))
(defcustom cc-other-file-alist
'(("\\.cc\\'" (".hh" ".h"))
@@ -269,17 +254,15 @@ since the search algorithm searches sequentially through each directory
specified in `ff-search-directories'. If a file is not found, a new one
is created with the first matching extension (`.cc' yields `.hh')."
:version "24.4" ; add .m
- :type '(repeat (list regexp (choice (repeat string) function)))
- :group 'ff)
+ :type '(repeat (list regexp (choice (repeat string) function))))
(defcustom modula2-other-file-alist
'(
- ("\\.mi$" (".md")) ;; Modula-2 module definition
- ("\\.md$" (".mi")) ;; and implementation.
+ ("\\.mi\\'" (".md")) ;; Modula-2 module definition
+ ("\\.md\\'" (".mi")) ;; and implementation.
)
"See the description for the `ff-search-directories' variable."
- :type '(repeat (list regexp (choice (repeat string) function)))
- :group 'ff)
+ :type '(repeat (list regexp (choice (repeat string) function))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -308,22 +291,24 @@ See also the documentation for `ff-find-other-file'.
If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
(interactive "P")
- (let ((ignore ff-ignore-include))
- (setq ff-ignore-include t)
- (ff-find-the-other-file in-other-window)
- (setq ff-ignore-include ignore)))
+ (let ((ff-ignore-include t))
+ (ff-find-the-other-file in-other-window)))
;;;###autoload
-(defalias 'ff-find-related-file 'ff-find-other-file)
+(defalias 'ff-find-related-file #'ff-find-other-file)
;;;###autoload
-(defun ff-find-other-file (&optional in-other-window ignore-include)
+(defun ff-find-other-file (&optional in-other-window ignore-include event)
"Find the header or source file corresponding to this file.
Being on a `#include' line pulls in that file.
If optional IN-OTHER-WINDOW is non-nil, find the file in the other window.
If optional IGNORE-INCLUDE is non-nil, ignore being on `#include' lines.
+If optional EVENT is non-nil (default `last-nonmenu-event', move
+point to the end position of that event before calling the
+various ff-* hooks.
+
Variables of interest include:
- `ff-case-fold-search'
@@ -369,11 +354,17 @@ Variables of interest include:
- `ff-file-created-hook'
List of functions to be called if the other file has been created."
- (interactive "P")
- (let ((ignore ff-ignore-include))
- (setq ff-ignore-include ignore-include)
- (ff-find-the-other-file in-other-window)
- (setq ff-ignore-include ignore)))
+ (interactive (list current-prefix-arg nil last-nonmenu-event))
+ ;; We want to preserve point in the current buffer. But the point of
+ ;; ff-find-the-other-file is to make the the other file buffer
+ ;; current, so we can't use save-excursion here (see bug 48535).
+ (let ((start-buffer (current-buffer))
+ (start-point (point)))
+ (posn-set-point (event-end event))
+ (let ((ff-ignore-include ignore-include))
+ (ff-find-the-other-file in-other-window))
+ (with-current-buffer start-buffer
+ (goto-char start-point))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support functions
@@ -413,9 +404,9 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
(message "Working...")
(setq dirs
- (if (symbolp ff-search-directories)
- (ff-list-replace-env-vars (symbol-value ff-search-directories))
- (ff-list-replace-env-vars ff-search-directories)))
+ (ff-list-replace-env-vars (if (symbolp ff-search-directories)
+ (symbol-value ff-search-directories)
+ ff-search-directories)))
(setq fname (ff-treat-as-special))
@@ -454,11 +445,10 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
;; if we have a function to generate new names,
;; invoke it with the name of the current file
(if (and (atom action) (fboundp action))
- (progn
- (setq suffixes (funcall action (ff-buffer-file-name))
- match (cons (car match) (list suffixes))
- stub nil
- default-name (car suffixes)))
+ (setq suffixes (funcall action (ff-buffer-file-name))
+ match (cons (car match) (list suffixes))
+ stub nil
+ default-name (car suffixes))
;; otherwise build our filename stub
(cond
@@ -472,7 +462,8 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
(t
(setq format (concat "\\(.+\\)" (car match)))
(string-match format fname)
- (setq stub (substring fname (match-beginning 1) (match-end 1)))
+ ;; FIXME: What if `string-match' failed?
+ (setq stub (match-string 1 fname))
))
;; if we find nothing, we should try to get a file like this one
@@ -522,89 +513,6 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
found)) ;; return buffer-name or filename
-(defun ff-other-file-name ()
- "Return name of the header or source file corresponding to the current file.
-Being on a `#include' line pulls in that file, but see the help on
-the `ff-ignore-include' variable."
-
- (let (match ;; matching regexp for this file
- suffixes ;; set of replacing regexps for the matching regexp
- action ;; function to generate the names of the other files
- fname ;; basename of this file
- pos ;; where we start matching filenames
- stub ;; name of the file without extension
- alist ;; working copy of the list of file extensions
- pathname ;; the pathname of the file or the #include line
- format ;; what we have to match
- found ;; name of the file or buffer found - nil if none
- dirs) ;; local value of ff-search-directories
-
- (message "Working...")
-
- (setq dirs
- (if (symbolp ff-search-directories)
- (ff-list-replace-env-vars (symbol-value ff-search-directories))
- (ff-list-replace-env-vars ff-search-directories)))
-
- (setq fname (ff-treat-as-special))
-
- (cond
- ((and (not ff-ignore-include) fname)
- (setq found (ff-get-file-name dirs fname nil)))
-
- ;; let's just get the corresponding file
- (t
- (setq alist (if (symbolp ff-other-file-alist)
- (symbol-value ff-other-file-alist)
- ff-other-file-alist)
- pathname (or (ff-buffer-file-name) "/none.none"))
-
- (setq fname (file-name-nondirectory pathname)
- match (car alist))
-
- ;; find the table entry corresponding to this file
- (setq pos (ff-string-match (car match) fname))
- (while (and match (if (and pos (>= pos 0)) nil (not pos)))
- (setq alist (cdr alist))
- (setq match (car alist))
- (setq pos (ff-string-match (car match) fname)))
-
- ;; no point going on if we haven't found anything
- (when match
-
- ;; otherwise, suffixes contains what we need
- (setq suffixes (car (cdr match))
- action (car (cdr match))
- found nil)
-
- ;; if we have a function to generate new names,
- ;; invoke it with the name of the current file
- (if (and (atom action) (fboundp action))
- (progn
- (setq suffixes (funcall action (ff-buffer-file-name))
- match (cons (car match) (list suffixes))
- stub nil))
-
- ;; otherwise build our filename stub
- (cond
-
- ;; get around the problem that 0 and nil both mean false!
- ((= pos 0)
- (setq format "")
- (setq stub "")
- )
-
- (t
- (setq format (concat "\\(.+\\)" (car match)))
- (string-match format fname)
- (setq stub (substring fname (match-beginning 1) (match-end 1)))
- )))
-
- ;; do the real work - find the file
- (setq found
- (ff-get-file-name dirs stub suffixes)))))
- found)) ;; return buffer-name or filename
-
(defun ff-get-file (search-dirs filename &optional suffix-list other-window)
"Find a file in the SEARCH-DIRS with the given FILENAME (or filename stub).
If (optional) SUFFIX-LIST is nil, search for FILENAME, otherwise search
@@ -709,11 +617,10 @@ name of the first file found."
;; otherwise dir matches the '/*', so search each dir separately
(progn
- (if (match-beginning 2)
- (setq rest (substring dir (match-beginning 2) (match-end 2)))
- (setq rest "")
- )
- (setq dir (substring dir (match-beginning 1) (match-end 1)))
+ (setq rest (if (match-beginning 2)
+ (match-string 2 dir)
+ ""))
+ (setq dir (match-string 1 dir))
(let ((dirlist (ff-all-dirs-under dir '("..")))
this-dir compl-dirs)
@@ -743,8 +650,8 @@ name of the first file found."
(defun ff-string-match (regexp string &optional start)
"Like `string-match', but set `case-fold-search' temporarily.
The value used comes from `ff-case-fold-search'."
- (let ((case-fold-search ff-case-fold-search))
- (if regexp
+ (if regexp
+ (let ((case-fold-search ff-case-fold-search))
(string-match regexp string start))))
(defun ff-list-replace-env-vars (search-list)
@@ -752,12 +659,12 @@ The value used comes from `ff-case-fold-search'."
(let (list
(var (car search-list)))
(while search-list
- (if (string-match "\\(.*\\)\\$[({]*\\([a-zA-Z0-9_]+\\)[)}]*\\(.*\\)" var)
+ (if (string-match "\\(.*\\)\\$[({]*\\([[:alnum:]_]+\\)[)}]*\\(.*\\)" var)
(setq var
(concat
- (substring var (match-beginning 1) (match-end 1))
- (getenv (substring var (match-beginning 2) (match-end 2)))
- (substring var (match-beginning 3) (match-end 3)))))
+ (match-string 1 var)
+ (getenv (match-string 2 var))
+ (match-string 3 var))))
(setq search-list (cdr search-list))
(setq list (cons var list))
(setq var (car search-list)))
@@ -782,11 +689,7 @@ See variable `ff-special-constructs'."
(setq match (cdr elem)))
fname)))
-(defun ff-basename (string)
- "Return the basename of pathname STRING."
- (setq string (concat "/" string))
- (string-match ".*/\\([^/]+\\)$" string)
- (setq string (substring string (match-beginning 1) (match-end 1))))
+(define-obsolete-function-alias 'ff-basename #'file-name-nondirectory "28.1")
(defun ff-all-dirs-under (here &optional exclude)
"Get all the directory files under directory HERE.
@@ -800,7 +703,7 @@ Exclude all files in the optional EXCLUDE list."
(setq file (car files))
(if (and
(file-directory-p file)
- (not (member (ff-basename file) exclude)))
+ (not (member (file-name-nondirectory file) exclude)))
(setq dirlist (cons file dirlist)))
(setq files (cdr files)))
(setq dirlist (reverse dirlist))))
@@ -820,84 +723,65 @@ or `switch-to-buffer' / `switch-to-buffer-other-window' function pairs.
If optional NEW-FILE is t, then a special hook (`ff-file-created-hook') is
called before `ff-post-load-hook'."
(run-hooks 'ff-pre-load-hook 'ff-pre-load-hooks)
- (if (or
- (and in-other-window (not ff-always-in-other-window))
- (and (not in-other-window) ff-always-in-other-window))
- (funcall f2 file)
- (funcall f1 file))
+ (funcall (if (or
+ (and in-other-window (not ff-always-in-other-window))
+ (and (not in-other-window) ff-always-in-other-window))
+ f2 f1)
+ file)
(if new-file
(run-hooks 'ff-file-created-hook 'ff-file-created-hooks))
(run-hooks 'ff-post-load-hook 'ff-post-load-hooks))
(defun ff-find-file (file &optional in-other-window new-file)
"Like `find-file', but may show the file in another window."
- (ff-switch-file 'find-file
- 'find-file-other-window
+ (ff-switch-file #'find-file
+ #'find-file-other-window
file in-other-window new-file))
(defun ff-switch-to-buffer (buffer-or-name &optional in-other-window)
"Like `switch-to-buffer', but may show the buffer in another window."
- (ff-switch-file 'switch-to-buffer
- 'switch-to-buffer-other-window
+ (ff-switch-file #'switch-to-buffer
+ #'switch-to-buffer-other-window
buffer-or-name in-other-window nil))
;;;###autoload
-(defun ff-mouse-find-other-file (event)
- "Visit the file you click on."
- (interactive "e")
- (save-excursion
- (mouse-set-point event)
- (ff-find-other-file nil)))
+(define-obsolete-function-alias
+ 'ff-mouse-find-other-file #'ff-find-other-file "28.1")
;;;###autoload
-(defun ff-mouse-find-other-file-other-window (event)
- "Visit the file you click on in another window."
- (interactive "e")
- (save-excursion
- (mouse-set-point event)
- (ff-find-other-file t)))
+(define-obsolete-function-alias
+ 'ff-mouse-find-other-file-other-window #'ff-find-other-file-other-window "28.1")
+;;;###autoload
+(defun ff-find-other-file-other-window (event)
+ "Visit the file you point at in another window."
+ (interactive (list last-nonmenu-event))
+ (ff-find-other-file t nil event))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This section offers an example of user defined function to select files
-(defun ff-upcase-p (string &optional start end)
- "Return t if STRING is all uppercase.
-Given START and/or END, checks between these characters."
- (let (match str)
- (if (not start)
- (setq start 0))
- (if (not end)
- (setq end (length string)))
- (if (= start end)
- (setq end (1+ end)))
- (setq str (substring string start end))
- (if (and
- (ff-string-match "[A-Z]+" str)
- (setq match (match-data))
- (= (car match) 0)
- (= (car (cdr match)) (length str)))
- t
- nil)))
+(defun ff-upcase-p (string)
+ "Return t if STRING is all uppercase."
+ ;; FIXME: Why `ff-string-match' since `[:upper:]' only makes
+ ;; sense when `case-fold-search' is nil?
+ (ff-string-match "\\`[[:upper:]]*\\'" string))
(defun ff-cc-hh-converter (arg)
"Discriminate file extensions.
Build up a new file list based possibly on part of the directory name
and the name of the file passed in."
(ff-string-match "\\(.*\\)/\\([^/]+\\)/\\([^.]+\\).\\([^/]+\\)$" arg)
- (let ((dire (if (match-beginning 2)
- (substring arg (match-beginning 2) (match-end 2)) nil))
- (file (if (match-beginning 3)
- (substring arg (match-beginning 3) (match-end 3)) nil))
- (extn (if (match-beginning 4)
- (substring arg (match-beginning 4) (match-end 4)) nil))
+ (let ((dire (match-string 2 arg))
+ (file (match-string 3 arg))
+ (extn (match-string 4 arg))
return-list)
(cond
;; fooZapJunk.cc => ZapJunk.{hh,h} or fooZapJunk.{hh,h}
((and (string= extn "cc")
- (ff-string-match "^\\([a-z]+\\)\\([A-Z].+\\)$" file))
- (let ((stub (substring file (match-beginning 2) (match-end 2))))
- (setq dire (upcase (substring file (match-beginning 1) (match-end 1))))
+ (ff-string-match "^\\([[:lower:]]+\\)\\([[:upper:]].+\\)$" file))
+ (let ((stub (match-string 2 file)))
+ (setq dire (upcase (match-string 1 file)))
(setq return-list (list (concat stub ".hh")
(concat stub ".h")
(concat file ".hh")
diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el
index 3428a151522..2f432936033 100644
--- a/lisp/find-lisp.el
+++ b/lisp/find-lisp.el
@@ -212,24 +212,17 @@ It is a function which takes two arguments, the directory and its parent."
(use-local-map (append (make-sparse-keymap) (current-local-map)))
- (make-local-variable 'find-lisp-file-predicate)
- (setq find-lisp-file-predicate file-predicate)
- (make-local-variable 'find-lisp-directory-predicate)
- (setq find-lisp-directory-predicate directory-predicate)
- (make-local-variable 'find-lisp-regexp)
- (setq find-lisp-regexp regexp)
-
- (make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function
- (function
- (lambda (_ignore1 _ignore2)
- (find-lisp-insert-directory
- default-directory
- find-lisp-file-predicate
- find-lisp-directory-predicate
- 'ignore)
- )
- ))
+ (setq-local find-lisp-file-predicate file-predicate)
+ (setq-local find-lisp-directory-predicate directory-predicate)
+ (setq-local find-lisp-regexp regexp)
+
+ (setq-local revert-buffer-function
+ (lambda (_ignore1 _ignore2)
+ (find-lisp-insert-directory
+ default-directory
+ find-lisp-file-predicate
+ find-lisp-directory-predicate
+ 'ignore)))
;; Set subdir-alist so that Tree Dired will work:
(if (fboundp 'dired-simple-subdir-alist)
@@ -238,8 +231,8 @@ It is a function which takes two arguments, the directory and its parent."
(dired-simple-subdir-alist)
;; else we have an ancient tree dired (or classic dired, where
;; this does no harm)
- (set (make-local-variable 'dired-subdir-alist)
- (list (cons default-directory (point-min-marker)))))
+ (setq-local dired-subdir-alist
+ (list (cons default-directory (point-min-marker)))))
(find-lisp-insert-directory
dir file-predicate directory-predicate 'ignore)
(goto-char (point-min))
@@ -267,11 +260,10 @@ It is a function which takes two arguments, the directory and its parent."
(insert find-lisp-line-indent "\n")
;; Run the find function
(mapc
- (function
- (lambda (file)
- (find-lisp-find-dired-insert-file
- (substring file len)
- (current-buffer))))
+ (lambda (file)
+ (find-lisp-find-dired-insert-file
+ (substring file len)
+ (current-buffer)))
(sort files 'string-lessp))
;; FIXME: Sort function is ignored for now
;; (funcall sort-function files))
diff --git a/lisp/finder.el b/lisp/finder.el
index d79b9c99f66..c2d5806c0cd 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -1,11 +1,10 @@
-;;; finder.el --- topic & keyword-based code finder
+;;; finder.el --- topic & keyword-based code finder -*- lexical-binding: t -*-
;; Copyright (C) 1992, 1997-1999, 2001-2021 Free Software Foundation,
;; Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Created: 16 Jun 1992
-;; Version: 1.0
;; Keywords: help
;; This file is part of GNU Emacs.
@@ -78,8 +77,7 @@
Each element has the form (KEYWORD . DESCRIPTION).")
(defvar finder-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Finder")))
+ (let ((map (make-sparse-keymap)))
(define-key map " " 'finder-select)
(define-key map "f" 'finder-select)
(define-key map [follow-link] 'mouse-face)
@@ -90,24 +88,21 @@ Each element has the form (KEYWORD . DESCRIPTION).")
(define-key map "p" 'previous-line)
(define-key map "q" 'finder-exit)
(define-key map "d" 'finder-list-keywords)
-
- (define-key map [menu-bar finder-mode]
- (cons "Finder" menu-map))
- (define-key menu-map [finder-exit]
- '(menu-item "Quit" finder-exit
- :help "Exit Finder mode"))
- (define-key menu-map [finder-summary]
- '(menu-item "Summary" finder-summary
- :help "Summary item on current line in a finder buffer"))
- (define-key menu-map [finder-list-keywords]
- '(menu-item "List keywords" finder-list-keywords
- :help "Display descriptions of the keywords in the Finder buffer"))
- (define-key menu-map [finder-select]
- '(menu-item "Select" finder-select
- :help "Select item on current line in a finder buffer"))
map)
"Keymap used in `finder-mode'.")
+(easy-menu-define finder-mode-menu finder-mode-map
+ "Menu for `finder-mode'."
+ '("Finder"
+ ["Select" finder-select
+ :help "Select item on current line in a finder buffer"]
+ ["List keywords" finder-list-keywords
+ :help "Display descriptions of the keywords in the Finder buffer"]
+ ["Summary" finder-summary
+ :help "Summary item on current line in a finder buffer"]
+ ["Quit" finder-exit
+ :help "Exit Finder mode"]))
+
(defvar finder-mode-syntax-table
(let ((st (make-syntax-table emacs-lisp-mode-syntax-table)))
(modify-syntax-entry ?\; ". " st)
@@ -200,10 +195,9 @@ from; the default is `load-path'."
(cons d f))
(directory-files d nil el-file-regexp))))
(progress (make-progress-reporter
- (byte-compile-info-string "Scanning files for finder")
+ (byte-compile-info "Scanning files for finder")
0 (length files)))
- package-override base-name ; processed
- summary keywords package version entry desc)
+ base-name summary keywords package version entry desc)
(dolist (elem files)
(let* ((d (car elem))
(f (cdr elem))
@@ -233,7 +227,7 @@ from; the default is `load-path'."
;; (push base-name processed)
(with-temp-buffer
(insert-file-contents (expand-file-name f d))
- (setq keywords (mapcar 'intern (lm-keywords-list))
+ (setq keywords (mapcar #'intern (lm-keywords-list))
package (or package-override
(let ((str (lm-header "package")))
(if str (intern str)))
@@ -293,7 +287,7 @@ from; the default is `load-path'."
(defun finder-compile-keywords-make-dist ()
"Regenerate `finder-inf.el' for the Emacs distribution."
- (apply 'finder-compile-keywords command-line-args-left)
+ (apply #'finder-compile-keywords command-line-args-left)
(kill-emacs))
;;; Now the retrieval code
@@ -302,7 +296,7 @@ from; the default is `load-path'."
"Insert, at column COLUMN, other args STRINGS."
(if (>= (current-column) column) (insert "\n"))
(move-to-column column t)
- (apply 'insert strings))
+ (apply #'insert strings))
(defvar finder-help-echo nil)
@@ -319,7 +313,7 @@ from; the default is `load-path'."
(keys (nconc (where-is-internal
'finder-mouse-select finder-mode-map)
keys1)))
- (concat (mapconcat 'key-description keys ", ")
+ (concat (mapconcat #'key-description keys ", ")
": select item"))))
(add-text-properties
(line-beginning-position) (line-end-position)
@@ -371,7 +365,7 @@ not `finder-known-keywords'."
(define-button-type 'finder-xref 'action #'finder-goto-xref)
(defun finder-goto-xref (button)
- "Jump to a lisp file for the BUTTON at point."
+ "Jump to a Lisp file for the BUTTON at point."
(let* ((file (button-get button 'xref))
(lib (locate-library file)))
(if lib (finder-commentary lib)
@@ -397,13 +391,6 @@ FILE should be in a form suitable for passing to `locate-library'."
(erase-buffer)
(insert str)
(goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-max))
- (delete-blank-lines)
- (goto-char (point-min))
- (while (re-search-forward "^;+ ?" nil t)
- (replace-match "" nil nil))
- (goto-char (point-min))
(while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
(if (locate-library (match-string 1))
(make-text-button (match-beginning 1) (match-end 1)
@@ -428,7 +415,7 @@ FILE should be in a form suitable for passing to `locate-library'."
(defun finder-select ()
"Select item on current line in a Finder buffer."
- (interactive)
+ (interactive nil finder-mode)
(let ((key (finder-current-item)))
(if (string-match "\\.el$" key)
(finder-commentary key)
@@ -444,6 +431,7 @@ FILE should be in a form suitable for passing to `locate-library'."
;;;###autoload
(defun finder-by-keyword ()
"Find packages matching a given keyword."
+ ;; FIXME: Why does this function exist? Should it just be an alias?
(interactive)
(finder-list-keywords))
@@ -453,13 +441,14 @@ 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
+ :interactive nil
(setq buffer-read-only t
buffer-undo-list t)
- (set (make-local-variable 'finder-headmark) nil))
+ (setq-local finder-headmark nil))
(defun finder-summary ()
"Summarize basic Finder commands."
- (interactive)
+ (interactive nil finder-mode)
(message "%s"
(substitute-command-keys
"\\<finder-mode-map>\\[finder-select] = select, \
@@ -469,7 +458,7 @@ finder directory, \\[finder-exit] = quit, \\[finder-summary] = help")))
(defun finder-exit ()
"Exit Finder mode.
Quit the window and kill all Finder-related buffers."
- (interactive)
+ (interactive nil finder-mode)
(quit-window t)
(dolist (buf (list finder-buffer "*Finder-package*"))
(and (get-buffer buf) (kill-buffer buf))))
diff --git a/lisp/flow-ctrl.el b/lisp/flow-ctrl.el
index 656edf2eb09..adb52d7253a 100644
--- a/lisp/flow-ctrl.el
+++ b/lisp/flow-ctrl.el
@@ -1,4 +1,4 @@
-;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control
+;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control -*- lexical-binding: t -*-
;; Copyright (C) 1990-1991, 1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -64,12 +64,11 @@ With arg, enable flow control mode if arg is positive, otherwise disable."
(progn
;; Turn flow control off, and stop exchanging chars.
(set-input-mode t nil (nth 2 (current-input-mode)))
- (if keyboard-translate-table
- (progn
- (aset keyboard-translate-table flow-control-c-s-replacement nil)
- (aset keyboard-translate-table ?\^s nil)
- (aset keyboard-translate-table flow-control-c-q-replacement nil)
- (aset keyboard-translate-table ?\^q nil))))
+ (when keyboard-translate-table
+ (aset keyboard-translate-table flow-control-c-s-replacement nil)
+ (aset keyboard-translate-table ?\^s nil)
+ (aset keyboard-translate-table flow-control-c-q-replacement nil)
+ (aset keyboard-translate-table ?\^q nil)))
;; Turn flow control on.
;; Tell emacs to pass C-s and C-q to OS.
(set-input-mode nil t (nth 2 (current-input-mode)))
diff --git a/lisp/foldout.el b/lisp/foldout.el
index 31636714608..cadf2746ba1 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -1,4 +1,4 @@
-;;; foldout.el --- folding extensions for outline-mode and outline-minor-mode
+;;; foldout.el --- folding extensions for outline-mode and outline-minor-mode -*- lexical-binding: t -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
@@ -33,7 +33,7 @@
;; hidden under one of these headings. Normally you'd do C-c C-e (show-entry)
;; to expose the body or C-c C-i to expose the child (level-2) headings.
;;
-;; With foldout, you do C-c C-z (foldout-zoom-subtree). This exposes the body
+;; With foldout, you do C-c C-z (`foldout-zoom-subtree'). This exposes the body
;; and child subheadings and narrows the buffer so that only the level-1
;; heading, the body and the level-2 headings are visible. If you now want to
;; look under one of the level-2 headings, position the cursor on it and do C-c
@@ -57,7 +57,7 @@
;; zoomed-in heading. This is useful for restricting changes to a particular
;; chapter or section of your document.
;;
-;; You unzoom (exit) a fold by doing C-c C-x (foldout-exit-fold). This hides
+;; You unzoom (exit) a fold by doing C-c C-x (`foldout-exit-fold'). This hides
;; all the text and subheadings under the top-level heading and returns you to
;; the previous view of the buffer. Specifying a numeric argument exits that
;; many folds. Specifying a zero argument exits *all* folds.
@@ -209,14 +209,14 @@
(require 'outline)
-(defvar foldout-fold-list nil
+(defvar-local foldout-fold-list nil
"List of start and end markers for the folds currently entered.
An end marker of nil means the fold ends after (point-max).")
-(make-variable-buffer-local 'foldout-fold-list)
-(defvar foldout-mode-line-string nil
+(defvar-local foldout-mode-line-string nil
"Mode line string announcing that we are in an outline fold.")
-(make-variable-buffer-local 'foldout-mode-line-string)
+
+;; FIXME: This should be rewritten as a proper minor mode.
;; put our minor mode string immediately following outline-minor-mode's
(or (assq 'foldout-mode-line-string minor-mode-alist)
@@ -229,17 +229,8 @@ An end marker of nil means the fold ends after (point-max).")
(error "Can't find outline-minor-mode in minor-mode-alist"))
;; slip our fold announcement into the list
- (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))
- ))
-
-;; outline-flag-region has different `flag' values in outline.el and
-;; noutline.el for hiding and showing text.
-
-(defconst foldout-hide-flag
- (if (featurep 'noutline) t ?\^M))
+ (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))))
-(defconst foldout-show-flag
- (if (featurep 'noutline) nil ?\n))
(defun foldout-zoom-subtree (&optional exposure)
@@ -285,16 +276,14 @@ optional arg EXPOSURE \(interactively with prefix arg) changes this:-
((> exposure-value 0)
(outline-show-children exposure-value))
(t
- (outline-show-subtree))
- )
+ (outline-show-subtree)))
;; save the location of the fold we are entering
(setq foldout-fold-list (cons (cons start-marker end-marker)
foldout-fold-list))
;; update the mode line
- (foldout-update-mode-line)
- )))
+ (foldout-update-mode-line))))
(defun foldout-exit-fold (&optional num-folds)
@@ -318,8 +307,7 @@ exited and text is left visible."
;; have we been told not to hide the fold?
((< num-folds 0)
(setq hide-fold nil
- num-folds (- num-folds)))
- )
+ num-folds (- num-folds))))
;; limit the number of folds if we've been told to exit too many
(setq num-folds (min num-folds (length foldout-fold-list)))
@@ -366,8 +354,7 @@ exited and text is left visible."
;; make sure the next heading is exposed
(if end-marker
- (outline-flag-region end-of-subtree beginning-of-heading
- foldout-show-flag)))
+ (outline-flag-region end-of-subtree beginning-of-heading nil)))
;; zap the markers so they don't slow down editing
(set-marker start-marker nil)
@@ -487,14 +474,14 @@ What happens depends on the number of mouse clicks:-
Signal an error if the final event isn't the same type as the first one."
(let ((initial-event-type (event-basic-type event)))
(while (null (sit-for (/ double-click-time 1000.0) 'nodisplay))
- (setq event (read-event)))
+ (setq event (read--potential-mouse-event)))
(or (eq initial-event-type (event-basic-type event))
(error "")))
event)
(defun foldout-mouse-goto-heading (event)
- "Go to the heading where the mouse event started. Signal an error
-if the event didn't occur on a heading."
+ "Go to the heading where the mouse EVENT started.
+Signal an error if the event didn't occur on a heading."
(goto-char (posn-point (event-start event)))
(or (outline-on-heading-p)
;; outline.el sometimes treats beginning-of-buffer as a heading
@@ -516,43 +503,48 @@ M-C-down-mouse-{1,2,3}.
Valid modifiers are shift, control, meta, alt, hyper and super.")
-(if foldout-inhibit-key-bindings
- ()
- (define-key outline-mode-map "\C-c\C-z" 'foldout-zoom-subtree)
- (define-key outline-mode-map "\C-c\C-x" 'foldout-exit-fold)
+(unless foldout-inhibit-key-bindings
+ (define-key outline-mode-map "\C-c\C-z" #'foldout-zoom-subtree)
+ (define-key outline-mode-map "\C-c\C-x" #'foldout-exit-fold)
(let ((map (lookup-key outline-minor-mode-map outline-minor-mode-prefix)))
(unless map
(setq map (make-sparse-keymap))
(define-key outline-minor-mode-map outline-minor-mode-prefix map))
- (define-key map "\C-z" 'foldout-zoom-subtree)
- (define-key map "\C-x" 'foldout-exit-fold))
- (let* ((modifiers (apply 'concat
- (mapcar (function
- (lambda (modifier)
- (vector
- (cond
- ((eq modifier 'shift) ?S)
- ((eq modifier 'control) ?C)
- ((eq modifier 'meta) ?M)
- ((eq modifier 'alt) ?A)
- ((eq modifier 'hyper) ?H)
- ((eq modifier 'super) ?s)
- (t (error "invalid mouse modifier %s"
- modifier)))
- ?-)))
+ (define-key map "\C-z" #'foldout-zoom-subtree)
+ (define-key map "\C-x" #'foldout-exit-fold))
+ (let* ((modifiers (apply #'concat
+ (mapcar (lambda (modifier)
+ (vector
+ (cond
+ ((eq modifier 'shift) ?S)
+ ((eq modifier 'control) ?C)
+ ((eq modifier 'meta) ?M)
+ ((eq modifier 'alt) ?A)
+ ((eq modifier 'hyper) ?H)
+ ((eq modifier 'super) ?s)
+ (t (error "Invalid mouse modifier %s"
+ modifier)))
+ ?-))
foldout-mouse-modifiers)))
(mouse-1 (vector (intern (concat modifiers "down-mouse-1"))))
(mouse-2 (vector (intern (concat modifiers "down-mouse-2"))))
(mouse-3 (vector (intern (concat modifiers "down-mouse-3")))))
- (define-key outline-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-mode-map mouse-3 'foldout-mouse-hide-or-exit)
+ (define-key outline-mode-map mouse-1 #'foldout-mouse-zoom)
+ (define-key outline-mode-map mouse-2 #'foldout-mouse-show)
+ (define-key outline-mode-map mouse-3 #'foldout-mouse-hide-or-exit)
+
+ (define-key outline-minor-mode-map mouse-1 #'foldout-mouse-zoom)
+ (define-key outline-minor-mode-map mouse-2 #'foldout-mouse-show)
+ (define-key outline-minor-mode-map mouse-3 #'foldout-mouse-hide-or-exit)))
+
+;; Obsolete.
+
+(defconst foldout-hide-flag t)
+(make-obsolete-variable 'foldout-hide-flag nil "28.1")
- (define-key outline-minor-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-minor-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-minor-mode-map mouse-3 'foldout-mouse-hide-or-exit)
- ))
+(defconst foldout-show-flag nil)
+(make-obsolete-variable 'foldout-show-flag nil "28.1")
(provide 'foldout)
diff --git a/lisp/follow.el b/lisp/follow.el
index 292dc4a0225..dde140d0fd5 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -1,4 +1,4 @@
-;;; follow.el --- synchronize windows showing the same buffer
+;;; follow.el --- synchronize windows showing the same buffer -*- lexical-binding: t -*-
;; Copyright (C) 1995-1997, 1999, 2001-2021 Free Software Foundation,
;; Inc.
@@ -25,7 +25,7 @@
;;; Commentary:
-;; `Follow mode' is a minor mode that combines windows into one tall
+;; `follow-mode' is a minor mode that combines windows into one tall
;; virtual window.
;;
;; The feeling of a "virtual window" has been accomplished by the use
@@ -81,7 +81,7 @@
;; text. Enter long lines spanning several lines, or several
;; windows.
;;
-;; * Should you find `Follow' mode annoying, just type
+;; * Should you find Follow mode annoying, just type
;; M-x follow-mode <RETURN>
;; to turn it off.
@@ -93,25 +93,24 @@
;; key map. To do so, add the following lines (replacing `[f7]' and
;; `[f8]' with your favorite keys) to the init file:
;;
-;; (global-set-key [f8] 'follow-mode)
-;; (global-set-key [f7] 'follow-delete-other-windows-and-split)
+;; (global-set-key [f8] #'follow-mode)
+;; (global-set-key [f7] #'follow-delete-other-windows-and-split)
;; There exist two system variables that control the appearance of
;; lines wider than the window containing them. The default is to
;; truncate long lines whenever a window isn't as wide as the frame.
;;
-;; To make sure lines are never truncated, please place the following
-;; lines in your init file:
+;; To make sure lines are never truncated, place the following lines
+;; in your Init file:
;;
;; (setq truncate-lines nil)
;; (setq truncate-partial-width-windows nil)
-;; The correct way to configure Follow mode, or any other mode for
-;; that matter, is to create one or more functions that do
-;; whatever you would like to do. These functions are then added to
-;; a hook.
+;; One way to configure Follow mode is to create one or more functions
+;; that do whatever you would like to do. These functions are then
+;; added to a hook.
;;
;; The keymap `follow-mode-map' contains key bindings activated by
;; `follow-mode'.
@@ -120,8 +119,8 @@
;; (add-hook 'follow-mode-hook 'my-follow-mode-hook)
;;
;; (defun my-follow-mode-hook ()
-;; (define-key follow-mode-map "\C-ca" 'your-favorite-function)
-;; (define-key follow-mode-map "\C-cb" 'another-function))
+;; (define-key follow-mode-map "\C-ca" #'your-favorite-function)
+;; (define-key follow-mode-map "\C-cb" #'another-function))
;; Usage:
@@ -129,60 +128,60 @@
;; To activate, issue the command "M-x follow-mode"
;; and press Return. To deactivate, do it again.
;;
-;; The following is a list of commands useful when follow-mode is active.
+;; The following is a list of commands useful when `follow-mode' is active.
;;
-;; follow-scroll-up C-c . C-v
+;; `follow-scroll-up' C-c . C-v
;; Scroll text in a Follow mode window chain up.
;;
-;; follow-scroll-down C-c . v
+;; `follow-scroll-down' C-c . v
;; Like `follow-scroll-up', but in the other direction.
;;
-;; follow-delete-other-windows-and-split C-c . 1
+;; `follow-delete-other-windows-and-split' C-c . 1
;; Maximize the visible area of the current buffer,
-;; and enter Follow mode. This is a very convenient
+;; and enter Follow mode. This is a very convenient
;; way to start Follow mode, hence we recommend that
;; this command be added to the global keymap.
;;
-;; follow-recenter C-c . C-l
+;; `follow-recenter' C-c . C-l
;; Place point in the center of the middle window,
;; or a specified number of lines from either top or bottom.
;;
-;; follow-switch-to-buffer C-c . b
+;; `follow-switch-to-buffer' C-c . b
;; Switch buffer in all windows displaying the current buffer
;; in this frame.
;;
-;; follow-switch-to-buffer-all C-c . C-b
+;; `follow-switch-to-buffer-all' C-c . C-b
;; Switch buffer in all windows in the selected frame.
;;
-;; follow-switch-to-current-buffer-all
+;; `follow-switch-to-current-buffer-all'
;; Show the current buffer in all windows on the current
;; frame and turn on `follow-mode'.
;;
-;; follow-first-window C-c . <
+;; `follow-first-window' C-c . <
;; Select the first window in the frame showing the same buffer.
;;
-;; follow-last-window C-c . >
+;; `follow-last-window' C-c . >
;; Select the last window in the frame showing the same buffer.
;;
-;; follow-next-window C-c . n
+;; `follow-next-window' C-c . n
;; Select the next window in the frame showing the same buffer.
;;
-;; follow-previous-window C-c . p
+;; `follow-previous-window' C-c . p
;; Select the previous window showing the same buffer.
;; Well, it seems ok, but what if I really want to look at two different
-;; positions in the text? Here are two simple methods to use:
+;; positions in the text? Here are two simple methods to use:
;;
;; 1) Use multiple frames; `follow' mode only affects windows displayed
-;; in the same frame. (My apologies to you who can't use frames.)
+;; in the same frame. (My apologies to you who can't use frames.)
;;
;; 2) Bind `follow-mode' to key so you can turn it off whenever
-;; you want to view two locations. Of course, `follow' mode can
+;; you want to view two locations. Of course, `follow-mode' can
;; be reactivated by hitting the same key again.
;;
;; Example from my ~/.emacs:
-;; (global-set-key [f8] 'follow-mode)
+;; (global-set-key [f8] #'follow-mode)
;; Implementation:
;;
@@ -201,7 +200,6 @@
;;; Code:
-(require 'easymenu)
(eval-when-compile (require 'cl-lib))
;;; Variables
@@ -236,17 +234,17 @@ After that, changing the prefix key requires manipulating keymaps."
(defvar follow-mode-map
(let ((mainmap (make-sparse-keymap))
(map (make-sparse-keymap)))
- (define-key map "\C-v" 'follow-scroll-up)
- (define-key map "\M-v" 'follow-scroll-down)
- (define-key map "v" 'follow-scroll-down)
- (define-key map "1" 'follow-delete-other-windows-and-split)
- (define-key map "b" 'follow-switch-to-buffer)
- (define-key map "\C-b" 'follow-switch-to-buffer-all)
- (define-key map "\C-l" 'follow-recenter)
- (define-key map "<" 'follow-first-window)
- (define-key map ">" 'follow-last-window)
- (define-key map "n" 'follow-next-window)
- (define-key map "p" 'follow-previous-window)
+ (define-key map "\C-v" #'follow-scroll-up)
+ (define-key map "\M-v" #'follow-scroll-down)
+ (define-key map "v" #'follow-scroll-down)
+ (define-key map "1" #'follow-delete-other-windows-and-split)
+ (define-key map "b" #'follow-switch-to-buffer)
+ (define-key map "\C-b" #'follow-switch-to-buffer-all)
+ (define-key map "\C-l" #'follow-recenter)
+ (define-key map "<" #'follow-first-window)
+ (define-key map ">" #'follow-last-window)
+ (define-key map "n" #'follow-next-window)
+ (define-key map "p" #'follow-previous-window)
(define-key mainmap follow-mode-prefix map)
@@ -255,13 +253,13 @@ After that, changing the prefix key requires manipulating keymaps."
;; could be enhanced in Follow mode. End-of-buffer is a special
;; case since it is very simple to define and it greatly enhances
;; the look and feel of Follow mode.)
- (define-key mainmap [remap end-of-buffer] 'follow-end-of-buffer)
+ (define-key mainmap [remap end-of-buffer] #'follow-end-of-buffer)
- (define-key mainmap [remap scroll-bar-toolkit-scroll] 'follow-scroll-bar-toolkit-scroll)
- (define-key mainmap [remap scroll-bar-drag] 'follow-scroll-bar-drag)
- (define-key mainmap [remap scroll-bar-scroll-up] 'follow-scroll-bar-scroll-up)
- (define-key mainmap [remap scroll-bar-scroll-down] 'follow-scroll-bar-scroll-down)
- (define-key mainmap [remap mwheel-scroll] 'follow-mwheel-scroll)
+ (define-key mainmap [remap scroll-bar-toolkit-scroll] #'follow-scroll-bar-toolkit-scroll)
+ (define-key mainmap [remap scroll-bar-drag] #'follow-scroll-bar-drag)
+ (define-key mainmap [remap scroll-bar-scroll-up] #'follow-scroll-bar-scroll-up)
+ (define-key mainmap [remap scroll-bar-scroll-down] #'follow-scroll-bar-scroll-down)
+ (define-key mainmap [remap mwheel-scroll] #'follow-mwheel-scroll)
mainmap)
"Minor mode keymap for Follow mode.")
@@ -343,7 +341,7 @@ property `follow-mode-use-cache' to non-nil.")
;; Internal variables:
(defvar follow-internal-force-redisplay nil
- "True when Follow mode should redisplay the windows.")
+ "Non-nil when Follow mode should redisplay the windows.")
(defvar follow-active-menu nil
"The menu visible when Follow mode is active.")
@@ -370,7 +368,7 @@ This is typically set by explicit scrolling commands.")
(defsubst follow-debug-message (&rest args)
"Like `message', but only active when `follow-debug' is non-nil."
(if (and (boundp 'follow-debug) follow-debug)
- (apply 'message args)))
+ (apply #'message args)))
;;; Cache
@@ -1020,8 +1018,8 @@ returned by `follow-windows-start-end'."
(setq win-start-end (cdr win-start-end)))
result))
-;; Check if point is visible in all windows. (So that
-;; no one will be recentered.)
+;; Check if point is visible in all windows.
+;; (So that no one will be recentered.)
(defun follow-point-visible-all-windows-p (win-start-end)
"Non-nil when the `window-point' is visible in all windows."
@@ -1070,11 +1068,11 @@ Return the selected window."
win))
;; Lets select a window showing the end. Make sure we only select it if
-;; it wasn't just moved here. (I.e. M-> shall not unconditionally place
+;; it wasn't just moved here. (I.e. M-> shall not unconditionally place
;; point in the selected window.)
;;
;; (Compatibility kludge: in Emacs `window-end' is equal to `point-max';
-;; in XEmacs, it is equal to `point-max + 1'. Should I really bother
+;; in XEmacs, it is equal to `point-max + 1'. Should I really bother
;; checking `window-end' now when I check `end-of-buffer' explicitly?)
(defun follow-select-if-end-visible (win-start-end)
@@ -1098,7 +1096,7 @@ Return the selected window."
;; Select a window that will display point if the windows would
-;; be redisplayed with the first window fixed. This is useful for
+;; be redisplayed with the first window fixed. This is useful for
;; example when the user has pressed return at the bottom of a window
;; as point is not visible in any window.
@@ -1140,9 +1138,8 @@ Otherwise, return nil."
;; is nil. Start every window directly after the end of the previous
;; window, to make sure long lines are displayed correctly.
-(defvar follow-start-end-invalid t
+(defvar-local follow-start-end-invalid t
"When non-nil, indicates `follow-windows-start-end-cache' is invalid.")
-(make-variable-buffer-local 'follow-start-end-invalid)
(defun follow-redisplay (&optional windows win preserve-win)
"Reposition the WINDOWS around WIN.
@@ -1204,7 +1201,7 @@ should be a member of WINDOWS, starts at position START."
(goto-char guess)
(while (not done)
(if (not (= (vertical-motion 1 (car windows)) 1))
- ;; Hit bottom! (Can we really do this?)
+ ;; Hit bottom! (Can we really do this?)
;; We'll keep it, since it ensures termination.
(progn
(setq done t)
@@ -1285,7 +1282,7 @@ non-first windows in Follow mode."
(defvar follow-prev-buffer nil
"The buffer current at the last call to `follow-adjust-window' or nil.
-follow-mode is not necessarily enabled in this buffer.")
+`follow-mode' is not necessarily enabled in this buffer.")
;; This function is added to `pre-display-function' and is thus called
;; before each redisplay operation. It supersedes (2018-09) the
@@ -1333,7 +1330,7 @@ follow-mode is not necessarily enabled in this buffer.")
;; .
(defun follow-adjust-window (win)
- ;; Adjust the window WIN and its followers.
+ "Adjust the window WIN and its followers."
(cl-assert (eq (window-buffer win) (current-buffer)))
;; Have we moved out of or into a follow-mode window group?
@@ -1648,17 +1645,17 @@ This is updated by redisplay or by calling
(defun follow-window-end (&optional window update)
"Return position at which display currently ends in the Follow
- Mode group of windows which includes WINDOW.
+Mode group of windows which includes WINDOW.
- WINDOW must be a live window and defaults to the selected one.
- This is updated by redisplay, when it runs to completion.
- Simply changing the buffer text or setting `window-start' does
- not update this value.
-
- Return nil if there is no recorded value. (This can happen if
- the last redisplay of WINDOW was preempted, and did not
- finish.) If UPDATE is non-nil, compute the up-to-date position
- if it isn't already recorded."
+WINDOW must be a live window and defaults to the selected one.
+This is updated by redisplay, when it runs to completion.
+Simply changing the buffer text or setting `window-start' does
+not update this value.
+
+Return nil if there is no recorded value. (This can happen if
+the last redisplay of WINDOW was preempted, and did not
+finish.) If UPDATE is non-nil, compute the up-to-date position
+if it isn't already recorded."
(let* ((windows (follow-all-followers window))
(last (car (last windows))))
(when (and update follow-start-end-invalid)
@@ -1678,7 +1675,7 @@ overriding motion of point in order to display at this exact start."
(defun follow-pos-visible-in-window-p (&optional pos window partially)
"Return non-nil if position POS is currently on the frame in one of
- the windows in the Follow Mode group which includes WINDOW.
+the windows in the Follow Mode group which includes WINDOW.
WINDOW must be a live window and defaults to the selected one.
@@ -1697,8 +1694,7 @@ omitted if the character after POS is fully visible; otherwise, RTOP
and RBOT are the number of pixels off-window at the top and bottom of
the screen line (\"row\") containing POS, ROWH is the visible height
of that row, and VPOS is the row number \(zero-based)."
- (let* ((windows (follow-all-followers window))
- (last (car (last windows))))
+ (let* ((windows (follow-all-followers window)))
(when follow-start-end-invalid
(follow-redisplay windows (car windows)))
(let* ((cache (follow-windows-start-end windows))
@@ -1726,7 +1722,7 @@ zero means top of the first window in the group, negative means
(start-end (follow-windows-start-end windows))
(rev-start-end (reverse start-end))
(lines 0)
- middle-window elt count)
+ elt count)
(select-window
(cond
((null arg)
diff --git a/lisp/font-core.el b/lisp/font-core.el
index db76f95412f..db06a607660 100644
--- a/lisp/font-core.el
+++ b/lisp/font-core.el
@@ -1,4 +1,4 @@
-;;; font-core.el --- Core interface to font-lock
+;;; font-core.el --- Core interface to font-lock -*- lexical-binding: t; -*-
;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
@@ -26,7 +26,7 @@
;; This variable is used by mode packages that support Font Lock mode by
;; defining their own keywords to use for `font-lock-keywords'. (The mode
;; command should make it buffer-local and set it to provide the set up.)
-(defvar font-lock-defaults nil
+(defvar-local font-lock-defaults nil
"Defaults for Font Lock mode specified by the major mode.
Defaults should be of the form:
@@ -66,7 +66,6 @@ functions, `font-lock-fontify-buffer-function',
`font-lock-unfontify-region-function', and `font-lock-inhibit-thing-lock'.")
;;;###autoload
(put 'font-lock-defaults 'risky-local-variable t)
-(make-variable-buffer-local 'font-lock-defaults)
(defvar font-lock-function 'font-lock-default-function
"A function which is called when `font-lock-mode' is toggled.
@@ -127,7 +126,6 @@ buffer local value for `font-lock-defaults', via its mode hook.
The above is the default behavior of `font-lock-mode'; you may
specify your own function which is called when `font-lock-mode'
is toggled via `font-lock-function'."
- nil nil nil
:after-hook (font-lock-initial-fontify)
;; Don't turn on Font Lock mode if we don't have a display (we're running a
;; batch job) or if the buffer is invisible (the name starts with a space).
@@ -160,8 +158,8 @@ this function onto `change-major-mode-hook'."
(defun font-lock-default-function (mode)
;; Turn on Font Lock mode.
(when mode
- (set (make-local-variable 'char-property-alias-alist)
- (copy-tree char-property-alias-alist))
+ (setq-local char-property-alias-alist
+ (copy-tree char-property-alias-alist))
;; Add `font-lock-face' as an alias for the `face' property.
(let ((elt (assq 'face char-property-alias-alist)))
(if elt
@@ -171,8 +169,8 @@ this function onto `change-major-mode-hook'."
;; Turn off Font Lock mode.
(unless mode
;; Remove `font-lock-face' as an alias for the `face' property.
- (set (make-local-variable 'char-property-alias-alist)
- (copy-tree char-property-alias-alist))
+ (setq-local char-property-alias-alist
+ (copy-tree char-property-alias-alist))
(let ((elt (assq 'face char-property-alias-alist)))
(when elt
(setcdr elt (remq 'font-lock-face (cdr elt)))
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 7812ad7b2ed..4dc42d9cf6a 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -51,7 +51,7 @@
;; also the variable `font-lock-maximum-size'. Support modes for Font Lock
;; mode can be used to speed up Font Lock mode. See `font-lock-support-mode'.
-;;; How Font Lock mode fontifies:
+;;;; How Font Lock mode fontifies:
;; When Font Lock mode is turned on in a buffer, it (a) fontifies the entire
;; buffer and (b) installs one of its fontification functions on one of the
@@ -96,7 +96,7 @@
;; some syntactic parsers for common languages and a son-of-font-lock.el could
;; use them rather then relying so heavily on the keyword (regexp) pass.
-;;; How Font Lock mode supports modes or is supported by modes:
+;;;; How Font Lock mode supports modes or is supported by modes:
;; 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
@@ -112,7 +112,7 @@
;; Font Lock mode fontification behavior can be modified in a number of ways.
;; See the below comments and the comments distributed throughout this file.
-;;; Constructing patterns:
+;;;; Constructing patterns:
;; See the documentation for the variable `font-lock-keywords'.
;;
@@ -120,7 +120,7 @@
;; `font-lock-syntactic-keywords' can be generated via the function
;; `regexp-opt'.
-;;; Adding patterns for modes that already support Font Lock:
+;;;; Adding patterns for modes that already support Font Lock:
;; Though Font Lock highlighting patterns already exist for many modes, it's
;; likely there's something that you want fontified that currently isn't, even
@@ -135,7 +135,7 @@
;; other variables. For example, additional C types can be specified via the
;; variable `c-font-lock-extra-types'.
-;;; Adding patterns for modes that do not support Font Lock:
+;;;; Adding patterns for modes that do not support Font Lock:
;; Not all modes support Font Lock mode. If you (as a user of the mode) add
;; patterns for a new mode, you must define in your ~/.emacs a variable or
@@ -152,10 +152,10 @@
;;
;; (add-hook 'foo-mode-hook
;; (lambda ()
-;; (set (make-local-variable 'font-lock-defaults)
-;; '(foo-font-lock-keywords t))))
+;; (setq-local font-lock-defaults
+;; '(foo-font-lock-keywords t))))
-;;; Adding Font Lock support for modes:
+;;;; Adding Font Lock support for modes:
;; Of course, it would be better that the mode already supports Font Lock mode.
;; The package author would do something similar to above. The mode must
@@ -173,8 +173,8 @@
;;
;; and within `bar-mode' there could be:
;;
-;; (set (make-local-variable 'font-lock-defaults)
-;; '(bar-font-lock-keywords nil t))
+;; (setq-local font-lock-defaults
+;; '(bar-font-lock-keywords nil t))
;; What is fontification for? You might say, "It's to make my code look nice."
;; I think it should be for adding information in the form of cues. These cues
@@ -515,17 +515,15 @@ This is normally set via `font-lock-add-keywords' and
"Non-nil means Font Lock should not fontify comments or strings.
This is normally set via `font-lock-defaults'.")
-(defvar font-lock-keywords-case-fold-search nil
+(defvar-local font-lock-keywords-case-fold-search nil
"Non-nil means the patterns in `font-lock-keywords' are case-insensitive.
This is set via the function `font-lock-set-defaults', based on
the CASE-FOLD argument of `font-lock-defaults'.")
-(make-variable-buffer-local 'font-lock-keywords-case-fold-search)
-(defvar font-lock-syntactically-fontified 0
+(defvar-local font-lock-syntactically-fontified 0
"Point up to which `font-lock-syntactic-keywords' has been applied.
If nil, this is ignored, in which case the syntactic fontification may
sometimes be slightly incorrect.")
-(make-variable-buffer-local 'font-lock-syntactically-fontified)
(defvar font-lock-syntactic-face-function
(lambda (state)
@@ -575,6 +573,7 @@ This is normally set via `font-lock-defaults'.")
"Non-nil means use this syntax table for fontifying.
If this is nil, the major mode's syntax table is used.
This is normally set via `font-lock-defaults'.")
+(defvar-local font-lock--syntax-table-affects-ppss nil)
(defvar font-lock-mark-block-function nil
"Non-nil means use this function to mark a block of text.
@@ -732,7 +731,7 @@ see the variables `c-font-lock-extra-types', `c++-font-lock-extra-types',
;; font-lock-mode it only enabled the font-core.el part, not the
;; font-lock-mode-internal. Try again.
(font-lock-mode -1)
- (set (make-local-variable 'font-lock-defaults) '(nil t))
+ (setq-local font-lock-defaults '(nil t))
(font-lock-mode 1))
;; Otherwise set or add the keywords now.
;; This is a no-op if it has been done already in this buffer
@@ -932,18 +931,15 @@ The value of this variable is used when Font Lock mode is turned on."
;; Prepare for jit-lock
(remove-hook 'after-change-functions
#'font-lock-after-change-function t)
- (set (make-local-variable 'font-lock-flush-function)
- #'jit-lock-refontify)
- (set (make-local-variable 'font-lock-ensure-function)
- #'jit-lock-fontify-now)
+ (setq-local font-lock-flush-function #'jit-lock-refontify)
+ (setq-local font-lock-ensure-function #'jit-lock-fontify-now)
;; Prevent font-lock-fontify-buffer from fontifying eagerly the whole
;; buffer. This is important for things like CWarn mode which
;; adds/removes a few keywords and does a refontify (which takes ages on
;; large files).
- (set (make-local-variable 'font-lock-fontify-buffer-function)
- #'jit-lock-refontify)
+ (setq-local 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)
+ (setq-local font-lock-fontified t)
;; Use jit-lock.
(jit-lock-register #'font-lock-fontify-region
(not font-lock-keywords-only))
@@ -985,7 +981,7 @@ The value of this variable is used when Font Lock mode is turned on."
((bound-and-true-p lazy-lock-mode)
(lazy-lock-after-unfontify-buffer))))
-;;; End of Font Lock Support mode.
+;; End of Font Lock Support mode.
;;; Fontification functions.
@@ -1028,7 +1024,7 @@ The value of this variable is used when Font Lock mode is turned on."
;; directives correctly and cleanly. (It is the same problem as fontifying
;; multi-line strings and comments; regexps are not appropriate for the job.)
-(defvar font-lock-extend-after-change-region-function nil
+(defvar-local font-lock-extend-after-change-region-function nil
"A function that determines the region to refontify after a change.
This variable is either nil, or is a function that determines the
@@ -1042,7 +1038,6 @@ and end buffer positions \(in that order) of the region to refontify, or nil
\(which directs the caller to fontify a default region).
This function should preserve the match-data.
The region it returns may start or end in the middle of a line.")
-(make-variable-buffer-local 'font-lock-extend-after-change-region-function)
(defun font-lock-fontify-buffer (&optional interactively)
"Fontify the current buffer the way the function `font-lock-mode' would."
@@ -1106,8 +1101,8 @@ Called with two arguments BEG and END.")
"Reinitialize the font-lock machinery and (re-)fontify the buffer.
This functions is a convenience functions when developing font
locking for a mode, and is not meant to be called from lisp functions."
- (interactive)
(declare (interactive-only t))
+ (interactive)
;; Make font-lock recalculate all the mode-specific data.
(setq font-lock-major-mode nil)
;; Make the syntax machinery discard all information.
@@ -1120,9 +1115,22 @@ locking for a mode, and is not meant to be called from lisp functions."
"Make sure the region BEG...END has been fontified.
If the region is not specified, it defaults to the entire accessible
portion of the buffer."
- (font-lock-set-defaults)
- (funcall font-lock-ensure-function
- (or beg (point-min)) (or end (point-max))))
+ (when (font-lock-specified-p t)
+ (font-lock-set-defaults)
+ (funcall font-lock-ensure-function
+ (or beg (point-min)) (or end (point-max)))))
+
+(defun font-lock-update (&optional arg)
+ "Updates the syntax highlighting in this buffer.
+Refontify the accessible portion of this buffer, or enable Font Lock mode
+in this buffer if it is currently disabled. With prefix ARG, toggle Font
+Lock mode."
+ (interactive "P")
+ (save-excursion
+ (if (and (not arg) font-lock-mode)
+ (font-lock-fontify-region (point-min) (point-max))
+ (font-lock-unfontify-region (point-min) (point-max))
+ (font-lock-mode 'toggle))))
(defun font-lock-default-fontify-buffer ()
"Fontify the whole buffer using `font-lock-fontify-region-function'."
@@ -1160,7 +1168,7 @@ a very meaningful entity to highlight.")
(defvar font-lock-beg) (defvar font-lock-end)
-(defvar font-lock-extend-region-functions
+(defvar-local font-lock-extend-region-functions
'(font-lock-extend-region-wholelines
;; This use of font-lock-multiline property is unreliable but is just
;; a handy heuristic: in case you don't have a function that does
@@ -1182,7 +1190,6 @@ 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 'font-lock-extend-region-functions)
(defun font-lock-extend-region-multiline ()
"Move fontification boundaries away from any `font-lock-multiline' property."
@@ -1391,7 +1398,7 @@ delimit the region to fontify."
(font-lock-fontify-region (point) (mark)))
((error quit) (message "Fontifying block...%s" error-data)))))))
-;;; End of Fontification functions.
+;; End of Fontification functions.
;;; Additional text property functions.
@@ -1483,7 +1490,7 @@ Optional argument OBJECT is the string or buffer containing the text."
(put-text-property start next prop new object))))))
(setq start (text-property-not-all next end prop nil object)))))
-;;; End of Additional text property functions.
+;; End of Additional text property functions.
;;; Syntactic regexp fontification functions.
@@ -1556,7 +1563,7 @@ START should be at the beginning of a line."
(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))
+ (setq-local 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
@@ -1589,7 +1596,7 @@ START should be at the beginning of a line."
(setq highlights (cdr highlights))))
(setq keywords (cdr keywords)))))
-;;; End of Syntactic regexp fontification functions.
+;; End of Syntactic regexp fontification functions.
;;; Syntactic fontification functions.
@@ -1597,19 +1604,24 @@ START should be at the beginning of a line."
"If non-nil, Font Lock mode uses this instead of `comment-start-skip'.")
(defvar font-lock-comment-end-skip nil
- "If non-nil, Font Lock mode uses this instead of `comment-end'.")
+ "If non-nil, Font Lock mode uses this instead of `comment-end-skip'.")
(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.
(with-syntax-table (or syntax-ppss-table (syntax-table))
- (let ((comment-end-regexp
- (or font-lock-comment-end-skip
- (regexp-quote
- (replace-regexp-in-string "^ *" "" comment-end))))
- ;; Find the `start' state.
- (state (syntax-ppss start))
+ (when (and comment-start (not comment-end-skip)) (comment-normalize-vars))
+ (let (;; Find the `start' state.
+ (state (if (or syntax-ppss-table
+ (not font-lock--syntax-table-affects-ppss))
+ (syntax-ppss start)
+ ;; If `syntax-ppss' doesn't have its own syntax-table and
+ ;; we have installed our own syntax-table which
+ ;; differs from the standard one in ways which affects PPSS,
+ ;; then we can't use `syntax-ppss' since that would pollute
+ ;; and be polluted by its cache.
+ (parse-partial-sexp (point-min) start)))
face beg)
(if loudly (message "Fontifying %s... (syntactically...)" (buffer-name)))
;;
@@ -1633,14 +1645,16 @@ START should be at the beginning of a line."
comment-start-skip))
(put-text-property beg (match-end 0) 'face
font-lock-comment-delimiter-face)))
- (if (looking-back comment-end-regexp (point-at-bol) t)
+ (if (looking-back (or font-lock-comment-end-skip
+ comment-end-skip)
+ (point-at-bol) t)
(put-text-property (match-beginning 0) (point) 'face
font-lock-comment-delimiter-face))))
(< (point) end))
(setq state (parse-partial-sexp (point) end nil nil state
'syntax-table))))))
-;;; End of Syntactic fontification functions.
+;; End of Syntactic fontification functions.
;;; Keyword regexp fontification functions.
@@ -1774,9 +1788,9 @@ LOUDLY, if non-nil, allows progress-meter bar."
(setq keywords (cdr keywords)))
(set-marker pos nil)))
-;;; End of Keyword regexp fontification functions.
+;; End of Keyword regexp fontification functions.
-;; Various functions.
+;;; Various functions.
(defun font-lock-compile-keywords (keywords &optional syntactic-keywords)
"Compile KEYWORDS into the form (t KEYWORDS COMPILED...)
@@ -1881,9 +1895,8 @@ preserve `hi-lock-mode' highlighting patterns."
(kill-local-variable 'font-lock-set-defaults)
(font-lock-mode 1))
-(defvar font-lock-major-mode nil
+(defvar-local font-lock-major-mode nil
"Major mode for which the font-lock settings have been setup.")
-(make-variable-buffer-local 'font-lock-major-mode)
(defun font-lock-set-defaults ()
"Set fontification defaults appropriately for this mode.
@@ -1906,6 +1919,7 @@ Sets various variables using `font-lock-defaults' and
;; Case fold during regexp fontification?
(setq-local font-lock-keywords-case-fold-search (nth 2 defaults))
;; Syntax table for regexp and syntactic fontification?
+ (kill-local-variable 'font-lock--syntax-table-affects-ppss)
(if (null (nth 3 defaults))
(setq-local font-lock-syntax-table nil)
(setq-local font-lock-syntax-table (copy-syntax-table (syntax-table)))
@@ -1915,7 +1929,14 @@ Sets various variables using `font-lock-defaults' and
(dolist (char (if (numberp (car selem))
(list (car selem))
(mapcar #'identity (car selem))))
- (modify-syntax-entry char syntax font-lock-syntax-table)))))
+ (unless (memq (car (aref font-lock-syntax-table char))
+ '(1 2 3)) ;"." "w" "_"
+ (setq font-lock--syntax-table-affects-ppss t))
+ (modify-syntax-entry char syntax font-lock-syntax-table)
+ (unless (memq (car (aref font-lock-syntax-table char))
+ '(1 2 3)) ;"." "w" "_"
+ (setq font-lock--syntax-table-affects-ppss t))
+ ))))
;; (nth 4 defaults) used to hold `font-lock-beginning-of-syntax-function',
;; but that was removed in 25.1, so if it's a cons cell, we assume that
;; it's part of the variable alist.
@@ -1924,8 +1945,8 @@ Sets various variables using `font-lock-defaults' and
(set (make-local-variable (car x)) (cdr x)))
;; Set up `font-lock-keywords' last because its value might depend
;; on other settings.
- (set (make-local-variable 'font-lock-keywords)
- (font-lock-eval-keywords keywords))
+ (setq-local font-lock-keywords
+ (font-lock-eval-keywords keywords))
;; Local fontification?
(while local
(font-lock-add-keywords nil (car (car local)) (cdr (car local)))
@@ -2084,7 +2105,7 @@ Sets various variables using `font-lock-defaults' and
"Font Lock mode face used to highlight grouping constructs in Lisp regexps."
:group 'font-lock-faces)
-;;; End of Color etc. support.
+;; End of Color etc. support.
;;; Menu support.
@@ -2186,7 +2207,7 @@ Sets various variables using `font-lock-defaults' and
;; ;; Deactivate less/more fontification entries.
;; (setq font-lock-fontify-level nil))
-;;; End of Menu support.
+;; End of Menu support.
;;; Various regexp information shared by several modes.
;; ;; Information specific to a single mode should go in its load library.
@@ -2265,8 +2286,8 @@ This function could be MATCHER in a MATCH-ANCHORED `font-lock-keywords' item."
;; "ifndef" "import" "include" "line" "pragma" "undef" "warning")))
;;
(defconst cpp-font-lock-keywords-source-depth 0
- "An integer representing regular expression depth of `cpp-font-lock-keywords-source-directives'.
-Used in `cpp-font-lock-keywords'.")
+ "Regular expression depth of `cpp-font-lock-keywords-source-directives'.
+This should be an integer. Used in `cpp-font-lock-keywords'.")
(defconst cpp-font-lock-keywords
(let* ((directives cpp-font-lock-keywords-source-directives)
diff --git a/lisp/format-spec.el b/lisp/format-spec.el
index ea3434b6168..202d65d8fca 100644
--- a/lisp/format-spec.el
+++ b/lisp/format-spec.el
@@ -1,4 +1,4 @@
-;;; format-spec.el --- functions for formatting arbitrary formatting strings
+;;; format-spec.el --- format arbitrary formatting strings -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -24,10 +24,8 @@
;;; Code:
-(eval-when-compile
- (require 'subr-x))
-
-(defun format-spec (format specification &optional only-present)
+;;;###autoload
+(defun format-spec (format specification &optional ignore-missing split)
"Return a string based on FORMAT and SPECIFICATION.
FORMAT is a string containing `format'-like specs like \"su - %u %k\".
SPECIFICATION is an alist mapping format specification characters
@@ -39,22 +37,22 @@ For instance:
\\=`((?u . ,(user-login-name))
(?l . \"ls\")))
-Each %-spec may contain optional flag and width modifiers, as
-follows:
+Each %-spec may contain optional flag, width, and precision
+modifiers, as follows:
- %<flags><width>character
+ %<flags><width><precision>character
The following flags are allowed:
* 0: Pad to the width, if given, with zeros instead of spaces.
* -: Pad to the width, if given, on the right instead of the left.
-* <: Truncate to the width, if given, on the left.
-* >: Truncate to the width, if given, on the right.
+* <: Truncate to the width and precision, if given, on the left.
+* >: Truncate to the width and precision, if given, on the right.
* ^: Convert to upper case.
* _: Convert to lower case.
-The width modifier behaves like the corresponding one in `format'
-when applied to %s.
+The width and truncation modifiers behave like the corresponding
+ones in `format' when applied to %s.
For example, \"%<010b\" means \"substitute into the output the
value associated with ?b in SPECIFICATION, either padding it with
@@ -64,89 +62,123 @@ characters wide\".
Any text properties of FORMAT are copied to the result, with any
text properties of a %-spec itself copied to its substitution.
-ONLY-PRESENT indicates how to handle %-spec characters not
+IGNORE-MISSING indicates how to handle %-spec characters not
present in SPECIFICATION. If it is nil or omitted, emit an
-error; otherwise leave those %-specs and any occurrences of
-\"%%\" in FORMAT verbatim in the result, including their text
-properties, if any."
+error; if it is the symbol `ignore', leave those %-specs verbatim
+in the result, including their text properties, if any; if it is
+the symbol `delete', remove those %-specs from the result;
+otherwise do the same as for the symbol `ignore', but also leave
+any occurrences of \"%%\" in FORMAT verbatim in the result.
+
+If SPLIT, instead of returning a single string, a list of strings
+is returned, where each format spec is its own element."
(with-temp-buffer
- (insert format)
- (goto-char (point-min))
- (while (search-forward "%" nil t)
- (cond
- ;; Quoted percent sign.
- ((eq (char-after) ?%)
- (unless only-present
- (delete-char 1)))
- ;; Valid format spec.
- ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)")
- (let* ((modifiers (match-string 1))
- (num (match-string 2))
- (spec (string-to-char (match-string 3)))
- (val (assq spec specification)))
- (if (not val)
- (unless only-present
- (error "Invalid format character: `%%%c'" spec))
- (setq val (cdr val)
- modifiers (format-spec--parse-modifiers modifiers))
- ;; Pad result to desired length.
- (let ((text (format "%s" val)))
- (when num
- (setq num (string-to-number num))
- (setq text (format-spec--pad text num modifiers))
- (when (> (length text) num)
- (cond
- ((memq :chop-left modifiers)
- (setq text (substring text (- (length text) num))))
- ((memq :chop-right modifiers)
- (setq text (substring text 0 num))))))
- (when (memq :uppercase modifiers)
- (setq text (upcase text)))
- (when (memq :lowercase modifiers)
- (setq text (downcase text)))
- ;; Insert first, to preserve text properties.
- (insert-and-inherit text)
- ;; Delete the specifier body.
- (delete-region (+ (match-beginning 0) (length text))
- (+ (match-end 0) (length text)))
- ;; Delete the percent sign.
- (delete-region (1- (match-beginning 0)) (match-beginning 0))))))
- ;; Signal an error on bogus format strings.
- (t
- (unless only-present
- (error "Invalid format string")))))
- (buffer-string)))
-
-(defun format-spec--pad (text total-length modifiers)
- (if (> (length text) total-length)
- ;; The text is longer than the specified length; do nothing.
- text
- (let ((padding (make-string (- total-length (length text))
- (if (memq :zero-pad modifiers)
- ?0
- ?\s))))
- (if (memq :right-pad modifiers)
- (concat text padding)
- (concat padding text)))))
-
-(defun format-spec--parse-modifiers (modifiers)
+ (let ((split-start (point-min))
+ (split-result nil))
+ (insert format)
+ (goto-char (point-min))
+ (while (search-forward "%" nil t)
+ (cond
+ ;; Quoted percent sign.
+ ((= (following-char) ?%)
+ (when (memq ignore-missing '(nil ignore delete))
+ (delete-char 1)))
+ ;; Valid format spec.
+ ((looking-at (rx (? (group (+ (in " 0<>^_-"))))
+ (? (group (+ digit)))
+ (? (group ?. (+ digit)))
+ (group alpha)))
+ (let* ((beg (point))
+ (end (match-end 0))
+ (flags (match-string 1))
+ (width (match-string 2))
+ (trunc (match-string 3))
+ (char (string-to-char (match-string 4)))
+ (text (assq char specification)))
+ (when (and split
+ (not (= (1- beg) split-start)))
+ (push (buffer-substring split-start (1- beg)) split-result))
+ (cond (text
+ ;; Handle flags.
+ (setq text (format-spec--do-flags
+ (format "%s" (cdr text))
+ (format-spec--parse-flags flags)
+ (and width (string-to-number width))
+ (and trunc (car (read-from-string trunc 1)))))
+ ;; Insert first, to preserve text properties.
+ (insert-and-inherit text)
+ ;; Delete the specifier body.
+ (delete-region (point) (+ end (length text)))
+ ;; Delete the percent sign.
+ (delete-region (1- beg) beg))
+ ((eq ignore-missing 'delete)
+ ;; Delete the whole format spec.
+ (delete-region (1- beg) end))
+ ((not ignore-missing)
+ (error "Invalid format character: `%%%c'" char)))
+ (when split
+ (push (buffer-substring (1- beg) (point)) split-result)
+ (setq split-start (point)))))
+ ;; Signal an error on bogus format strings.
+ ((not ignore-missing)
+ (error "Invalid format string"))))
+ (if (not split)
+ (buffer-string)
+ (unless (= split-start (point-max))
+ (push (buffer-substring split-start (point-max)) split-result))
+ (nreverse split-result)))))
+
+(defun format-spec--do-flags (str flags width trunc)
+ "Return STR formatted according to FLAGS, WIDTH, and TRUNC.
+FLAGS is a list of keywords as returned by
+`format-spec--parse-flags'. WIDTH and TRUNC are either nil or
+string widths corresponding to `format-spec' modifiers."
+ (let (diff str-width)
+ ;; Truncate original string first, like `format' does.
+ (when trunc
+ (setq str-width (string-width str))
+ (when (> (setq diff (- str-width trunc)) 0)
+ (setq str (if (memq :chop-left flags)
+ (truncate-string-to-width str str-width diff)
+ (format (format "%%.%ds" trunc) str))
+ ;; We know the new width so save it for later.
+ str-width trunc)))
+ ;; Pad or chop to width.
+ (when width
+ (setq str-width (or str-width (string-width str))
+ diff (- width str-width))
+ (cond ((zerop diff))
+ ((> diff 0)
+ (let ((pad (make-string diff (if (memq :pad-zero flags) ?0 ?\s))))
+ (setq str (if (memq :pad-right flags)
+ (concat str pad)
+ (concat pad str)))))
+ ((memq :chop-left flags)
+ (setq str (truncate-string-to-width str str-width (- diff))))
+ ((memq :chop-right flags)
+ (setq str (format (format "%%.%ds" width) str))))))
+ ;; Fiddle case.
+ (cond ((memq :upcase flags)
+ (upcase str))
+ ((memq :downcase flags)
+ (downcase str))
+ (str)))
+
+(defun format-spec--parse-flags (flags)
+ "Convert sequence of FLAGS to list of human-readable keywords."
(mapcan (lambda (char)
- (when-let ((modifier
- (pcase char
- (?0 :zero-pad)
- (?\s :space-pad)
- (?^ :uppercase)
- (?_ :lowercase)
- (?- :right-pad)
- (?< :chop-left)
- (?> :chop-right))))
- (list modifier)))
- modifiers))
+ (pcase char
+ (?0 (list :pad-zero))
+ (?- (list :pad-right))
+ (?< (list :chop-left))
+ (?> (list :chop-right))
+ (?^ (list :upcase))
+ (?_ (list :downcase))))
+ flags))
(defun format-spec-make (&rest pairs)
"Return an alist suitable for use in `format-spec' based on PAIRS.
-PAIRS is a list where every other element is a character and a value,
-starting with a character."
+PAIRS is a property list with characters as keys."
(let (alist)
(while pairs
(unless (cdr pairs)
diff --git a/lisp/format.el b/lisp/format.el
index db5f5b961f8..1e87d252844 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -1,4 +1,4 @@
-;;; format.el --- read and save files in multiple formats
+;;; format.el --- read and save files in multiple formats -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 1997, 1999, 2001-2021 Free Software
;; Foundation, Inc.
@@ -181,7 +181,7 @@ it should be a Lisp function. BUFFER is currently ignored."
;; We should perhaps go via a temporary buffer and copy it
;; back, in case of errors.
(if (and (zerop (save-window-excursion
- (shell-command-on-region from to method t t
+ (shell-command-on-region from to method t 'no-mark
error-buff)))
;; gzip gives zero exit status with bad args, for instance.
(zerop (with-current-buffer error-buff
@@ -237,9 +237,8 @@ For most purposes, consider using `format-encode-region' instead."
;; delete the buffer once the write is done, but do
;; it after running to-fn so it doesn't affect
;; write-region calls in to-fn.
- (set (make-local-variable
- 'write-region-post-annotation-function)
- 'kill-buffer)))
+ (setq-local write-region-post-annotation-function
+ #'kill-buffer)))
nil)
;; Otherwise just call function, it will return annotations.
(funcall to-fn from to orig-buf)))))
@@ -342,8 +341,8 @@ for identifying regular expressions at the beginning of the region."
FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the
formats defined in `format-alist', or a list of such symbols."
(interactive
- (list (format-read (format "Translate buffer to format (default %s): "
- buffer-file-format))))
+ (list (format-read (format-prompt "Translate buffer to format"
+ buffer-file-format))))
(format-encode-region (point-min) (point-max) format))
(defun format-encode-region (beg end &optional format)
@@ -352,8 +351,8 @@ FORMAT defaults to `buffer-file-format'. It is a symbol naming
one of the formats defined in `format-alist', or a list of such symbols."
(interactive
(list (region-beginning) (region-end)
- (format-read (format "Translate region to format (default %s): "
- buffer-file-format))))
+ (format-read (format-prompt "Translate region to format"
+ buffer-file-format))))
(if (null format) (setq format buffer-file-format))
(if (symbolp format) (setq format (list format)))
(save-excursion
@@ -420,7 +419,8 @@ If FORMAT is nil then do not do any format conversion."
(file-name-nondirectory file)))))
(list file fmt)))
(let ((format-alist nil))
- (find-file filename))
+ (with-suppressed-warnings ((interactive-only find-file))
+ (find-file filename)))
(if format
(format-decode-buffer format)))
@@ -747,13 +747,17 @@ to write these unknown annotations back into the file."
(if (numberp val) ; add to ambient value if numeric
(format-property-increment-region from to prop val 0)
- (put-text-property
- from to prop
- (cond ((get prop 'format-list-valued) ; value gets consed onto
- ; list-valued properties
- (let ((prev (get-text-property from prop)))
- (cons val (if (listp prev) prev (list prev)))))
- (t val))))) ; normally, just set to val.
+ ;; Kludge alert: ignore items with reversed order of
+ ;; FROM and TO. They seem to be redundant anyway, and
+ ;; in one case I've seen them refer to EOB.
+ (when (<= from to)
+ (put-text-property
+ from to prop
+ (cond ((get prop 'format-list-valued) ; value gets consed onto
+ ; list-valued properties
+ (let ((prev (get-text-property from prop)))
+ (cons val (if (listp prev) prev (list prev)))))
+ (t val)))))) ; normally, just set to val.
(setq todo (cdr todo)))
(if unknown-ans
diff --git a/lisp/forms.el b/lisp/forms.el
index 808fb60fd58..8696aea98ee 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
+;;; forms.el --- Forms mode: edit a file as a form to fill in -*- lexical-binding: t; -*-
-;; Copyright (C) 1991, 1994-1997, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
;; Author: Johan Vromans <jvromans@squirrel.nl>
@@ -168,10 +167,9 @@
;; modified (using text-property `read-only').
;; Also, the read-write fields are shown using a
;; distinct face, if possible.
-;; As of emacs 19.29, the `intangible' text property
-;; is used to prevent moving into read-only fields.
-;; This variable defaults to t if running Emacs 19 or
-;; later with text properties.
+;; The `intangible' text property is used to
+;; prevent moving into read-only fields.
+;; This variable defaults to t.
;; The default face to show read-write fields is
;; copied from face `region'.
;;
@@ -299,7 +297,6 @@
(defcustom forms-mode-hook nil
"Hook run upon entering Forms mode."
- :group 'forms
:type 'hook)
;;; Mandatory variables - must be set by evaluating the control file.
@@ -317,7 +314,6 @@
(defcustom forms-check-number-of-fields t
"If non-nil, warn about records with wrong number of fields."
- :group 'forms
:type 'boolean)
(defvar forms-field-sep "\t"
@@ -333,13 +329,11 @@ If not nil: use this character to separate multi-line fields (default C-k).")
(defcustom forms-forms-scroll nil
"Non-nil means replace scroll-up/down commands in Forms mode.
The replacement commands performs forms-next/prev-record."
- :group 'forms
:type 'boolean)
(defcustom forms-forms-jump nil
"Non-nil means redefine beginning/end-of-buffer in Forms mode.
The replacement commands performs forms-first/last-record."
- :group 'forms
:type 'boolean)
(defvar forms-read-file-filter nil
@@ -363,25 +357,20 @@ This variable is for use by the filter routines only.
The contents may NOT be modified.")
(defcustom forms-use-text-properties t
- "Non-nil means: use text properties.
-Defaults to t if this Emacs is capable of handling text properties."
- :group 'forms
+ "Non-nil means to use text properties. "
:type 'boolean)
(defcustom forms-insert-after nil
"Non-nil means: inserts of new records go after current record.
Also, initial position is at last record."
- :group 'forms
:type 'boolean)
(defcustom forms-ro-face 'default
"The face (a symbol) that is used to display read-only text on the screen."
- :group 'forms
:type 'face)
(defcustom forms-rw-face 'region
"The face (a symbol) that is used to display read-write text on the screen."
- :group 'forms
:type 'face)
;;; Internal variables.
@@ -420,9 +409,8 @@ Also, initial position is at last record."
(defvar forms--parser nil
"Forms parser routine.")
-(defvar forms--mode-setup nil
+(defvar-local forms--mode-setup nil
"To keep track of forms-mode being set-up.")
-(make-variable-buffer-local 'forms--mode-setup)
(defvar forms--dynamic-text nil
"Array that holds dynamic texts to insert between fields.")
@@ -438,6 +426,14 @@ Also, initial position is at last record."
(defvar read-file-filter) ; bound in forms--intuit-from-file
+;; The code used to use `run-hooks' but in a way that's actually
+;; incompatible with hooks (and with lexical scoping), so this function
+;; approximates the actual behavior that `run-hooks' provided.
+(defun forms--run-functions (functions)
+ (if (functionp functions)
+ (funcall functions)
+ (mapc #'funcall functions)))
+
;;;###autoload
(defun forms-mode (&optional primary)
;; FIXME: use define-derived-mode
@@ -504,12 +500,9 @@ Commands: Equivalent keys in read-only mode:
(setq forms-new-record-filter nil)
(setq forms-modified-record-filter nil)
- ;; If running Emacs 19 under X, setup faces to show read-only and
- ;; read-write fields.
- (if (fboundp 'make-face)
- (progn
- (make-local-variable 'forms-ro-face)
- (make-local-variable 'forms-rw-face)))
+ ;; Setup faces to show read-only and read-write fields.
+ (make-local-variable 'forms-ro-face)
+ (make-local-variable 'forms-rw-face)
;; eval the buffer, should set variables
;;(message "forms: processing control file...")
@@ -552,8 +545,6 @@ Commands: Equivalent keys in read-only mode:
"`forms-multi-line' is equal to `forms-field-sep'")))
(error (concat "Forms control file error: "
"`forms-multi-line' must be nil or a one-character string"))))
- (or (fboundp 'set-text-properties)
- (setq forms-use-text-properties nil))
;; Validate and process forms-format-list.
;;(message "forms: pre-processing format list...")
@@ -573,12 +564,12 @@ Commands: Equivalent keys in read-only mode:
;; Check if record filters are defined.
(if (and forms-new-record-filter
- (not (fboundp forms-new-record-filter)))
+ (not (functionp forms-new-record-filter)))
(error (concat "Forms control file error: "
"`forms-new-record-filter' is not a function")))
(if (and forms-modified-record-filter
- (not (fboundp forms-modified-record-filter)))
+ (not (functionp forms-modified-record-filter)))
(error (concat "Forms control file error: "
"`forms-modified-record-filter' is not a function")))
@@ -609,16 +600,14 @@ Commands: Equivalent keys in read-only mode:
(setq forms--mode-setup t)
;; Copy desired faces to the actual variables used by the forms formatter.
- (if (fboundp 'make-face)
+ (make-local-variable 'forms--ro-face)
+ (make-local-variable 'forms--rw-face)
+ (if forms-read-only
(progn
- (make-local-variable 'forms--ro-face)
- (make-local-variable 'forms--rw-face)
- (if forms-read-only
- (progn
- (setq forms--ro-face forms-ro-face)
- (setq forms--rw-face forms-ro-face))
- (setq forms--ro-face forms-ro-face)
- (setq forms--rw-face forms-rw-face))))
+ (setq forms--ro-face forms-ro-face)
+ (setq forms--rw-face forms-ro-face))
+ (setq forms--ro-face forms-ro-face)
+ (setq forms--rw-face forms-rw-face))
;; Make more local variables.
(make-local-variable 'forms--file-buffer)
@@ -654,7 +643,7 @@ Commands: Equivalent keys in read-only mode:
(with-current-buffer forms--file-buffer
(let ((inhibit-read-only t)
(file-modified (buffer-modified-p)))
- (mapc #'funcall read-file-filter)
+ (forms--run-functions read-file-filter)
(if (not file-modified) (set-buffer-modified-p nil)))
(if write-file-filter
(add-hook 'write-file-functions write-file-filter nil t)))
@@ -769,7 +758,7 @@ Commands: Equivalent keys in read-only mode:
;; If it is a symbol, eval it first.
(if (and (symbolp el)
(boundp el))
- (setq el (eval el)))
+ (setq el (symbol-value el)))
(cond
@@ -882,8 +871,7 @@ Commands: Equivalent keys in read-only mode:
(list 'face forms--rw-face 'front-sticky '(face))))
;; Enable `post-command-hook' to restore the properties.
- (setq post-command-hook
- (append (list 'forms--iif-post-command-hook) post-command-hook)))
+ (add-hook 'post-command-hook #'forms--iif-post-command-hook))
;; No action needed. Clear marker.
(setq forms--iif-start nil)))
@@ -892,8 +880,7 @@ Commands: Equivalent keys in read-only mode:
"`post-command-hook' function for read-only segments."
;; Disable `post-command-hook'.
- (setq post-command-hook
- (delq 'forms--iif-hook-post-command-hook post-command-hook))
+ (remove-hook 'post-command-hook #'forms--iif-post-command-hook)
;; Restore properties.
(if forms--iif-start
@@ -923,7 +910,7 @@ Commands: Equivalent keys in read-only mode:
(if forms-use-text-properties
`(lambda (arg)
(let ((inhibit-read-only t))
- ,@(apply 'append
+ ,@(apply #'append
(mapcar #'forms--make-format-elt-using-text-properties
forms-format-list))
;; Prevent insertion before the first text.
@@ -936,7 +923,7 @@ Commands: Equivalent keys in read-only mode:
'(rear-nonsticky nil)))
(setq forms--iif-start nil))
`(lambda (arg)
- ,@(apply 'append
+ ,@(apply #'append
(mapcar #'forms--make-format-elt forms-format-list)))))
;; We have tallied the number of markers and dynamic texts,
@@ -1107,7 +1094,7 @@ Commands: Equivalent keys in read-only mode:
`(lambda nil
(let (here)
(goto-char (point-min))
- ,@(apply 'append
+ ,@(apply #'append
(mapcar
#'forms--make-parser-elt
(append forms-format-list (list nil)))))))))
@@ -1226,7 +1213,7 @@ Commands: Equivalent keys in read-only mode:
(setq the-record
(with-current-buffer forms--file-buffer
(let ((inhibit-read-only t))
- (run-hooks 'read-file-filter))
+ (forms--run-functions read-file-filter))
(goto-char (point-min))
(forms--get-record)))
@@ -1265,35 +1252,35 @@ Commands: Equivalent keys in read-only mode:
;; `forms-mode-map' is always accessible via \C-c prefix.
(setq forms-mode-map (make-keymap))
- (define-key forms-mode-map "\t" 'forms-next-field)
- (define-key forms-mode-map "\C-k" 'forms-delete-record)
- (define-key forms-mode-map "\C-q" 'forms-toggle-read-only)
- (define-key forms-mode-map "\C-o" 'forms-insert-record)
- (define-key forms-mode-map "\C-l" 'forms-jump-record)
- (define-key forms-mode-map "\C-n" 'forms-next-record)
- (define-key forms-mode-map "\C-p" 'forms-prev-record)
- (define-key forms-mode-map "\C-r" 'forms-search-backward)
- (define-key forms-mode-map "\C-s" 'forms-search-forward)
- (define-key forms-mode-map "\C-x" 'forms-exit)
- (define-key forms-mode-map "<" 'forms-first-record)
- (define-key forms-mode-map ">" 'forms-last-record)
- (define-key forms-mode-map "\C-?" 'forms-prev-record)
+ (define-key forms-mode-map "\t" #'forms-next-field)
+ (define-key forms-mode-map "\C-k" #'forms-delete-record)
+ (define-key forms-mode-map "\C-q" #'forms-toggle-read-only)
+ (define-key forms-mode-map "\C-o" #'forms-insert-record)
+ (define-key forms-mode-map "\C-l" #'forms-jump-record)
+ (define-key forms-mode-map "\C-n" #'forms-next-record)
+ (define-key forms-mode-map "\C-p" #'forms-prev-record)
+ (define-key forms-mode-map "\C-r" #'forms-search-backward)
+ (define-key forms-mode-map "\C-s" #'forms-search-forward)
+ (define-key forms-mode-map "\C-x" #'forms-exit)
+ (define-key forms-mode-map "<" #'forms-first-record)
+ (define-key forms-mode-map ">" #'forms-last-record)
+ (define-key forms-mode-map "\C-?" #'forms-prev-record)
;; `forms-mode-ro-map' replaces the local map when in read-only mode.
(setq forms-mode-ro-map (make-keymap))
(suppress-keymap forms-mode-ro-map)
(define-key forms-mode-ro-map "\C-c" forms-mode-map)
- (define-key forms-mode-ro-map "q" 'forms-toggle-read-only)
- (define-key forms-mode-ro-map "l" 'forms-jump-record)
- (define-key forms-mode-ro-map "n" 'forms-next-record)
- (define-key forms-mode-ro-map "p" 'forms-prev-record)
- (define-key forms-mode-ro-map "r" 'forms-search-backward)
- (define-key forms-mode-ro-map "s" 'forms-search-forward)
- (define-key forms-mode-ro-map "x" 'forms-exit)
- (define-key forms-mode-ro-map "<" 'forms-first-record)
- (define-key forms-mode-ro-map ">" 'forms-last-record)
- (define-key forms-mode-ro-map "?" 'describe-mode)
- (define-key forms-mode-ro-map " " 'forms-next-record)
+ (define-key forms-mode-ro-map "q" #'forms-toggle-read-only)
+ (define-key forms-mode-ro-map "l" #'forms-jump-record)
+ (define-key forms-mode-ro-map "n" #'forms-next-record)
+ (define-key forms-mode-ro-map "p" #'forms-prev-record)
+ (define-key forms-mode-ro-map "r" #'forms-search-backward)
+ (define-key forms-mode-ro-map "s" #'forms-search-forward)
+ (define-key forms-mode-ro-map "x" #'forms-exit)
+ (define-key forms-mode-ro-map "<" #'forms-first-record)
+ (define-key forms-mode-ro-map ">" #'forms-last-record)
+ (define-key forms-mode-ro-map "?" #'describe-mode)
+ (define-key forms-mode-ro-map " " #'forms-next-record)
(forms--mode-commands1 forms-mode-ro-map)
(forms--mode-menu-ro forms-mode-ro-map)
@@ -1399,13 +1386,13 @@ Commands: Equivalent keys in read-only mode:
(defun forms--mode-commands1 (map)
"Helper routine to define keys."
- (define-key map "\t" 'forms-next-field)
- (define-key map [S-tab] 'forms-prev-field)
- (define-key map [next] 'forms-next-record)
- (define-key map [prior] 'forms-prev-record)
- (define-key map [begin] 'forms-first-record)
- (define-key map [last] 'forms-last-record)
- (define-key map [backtab] 'forms-prev-field)
+ (define-key map "\t" #'forms-next-field)
+ (define-key map [S-tab] #'forms-prev-field)
+ (define-key map [next] #'forms-next-record)
+ (define-key map [prior] #'forms-prev-record)
+ (define-key map [begin] #'forms-first-record)
+ (define-key map [last] #'forms-last-record)
+ (define-key map [backtab] #'forms-prev-field)
)
;;; Changed functions
@@ -1434,7 +1421,7 @@ Commands: Equivalent keys in read-only mode:
;;
;; We have our own revert function - use it.
(make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function 'forms--revert-buffer)
+ (setq revert-buffer-function #'forms--revert-buffer)
t)
@@ -1907,7 +1894,7 @@ after writing out the data."
;; Write file hooks are run via write-file-functions.
;; (if write-file-filter
;; (save-excursion
- ;; (run-hooks 'write-file-filter)))
+ ;; (forms--run-functions write-file-filter)))
;; If they have a write-file-filter, force the buffer to be
;; saved even if it doesn't seem to be changed. First, they
@@ -1919,7 +1906,7 @@ after writing out the data."
(save-buffer args)
(if read-file-filter
(save-excursion
- (run-hooks 'read-file-filter)))
+ (forms--run-functions read-file-filter)))
(set-buffer-modified-p nil)))
;; Make sure we end up with the same record number as we started.
;; Since read-file-filter may perform arbitrary transformations on
@@ -2038,26 +2025,24 @@ Usage: (setq forms-number-of-fields
(defcustom forms--debug nil
"If non-nil, enable Forms mode debugging."
- :type 'boolean
- :group 'forms)
+ :type 'boolean)
(defun forms--debug (&rest args)
"Internal debugging routine."
(if forms--debug
- (let ((ret nil))
- (while args
- (let ((el (car-safe args)))
- (setq args (cdr-safe args))
- (if (stringp el)
- (setq ret (concat ret el))
- (setq ret (concat ret (prin1-to-string el) " = "))
- (if (boundp el)
- (let ((vel (eval el)))
- (setq ret (concat ret (prin1-to-string vel) "\n")))
- (setq ret (concat ret "<unbound>" "\n")))
- (if (fboundp el)
- (setq ret (concat ret (prin1-to-string (symbol-function el))
- "\n"))))))
+ (let ((ret
+ (mapconcat
+ (lambda (el)
+ (if (stringp el) el
+ (concat (prin1-to-string el) " = "
+ (if (boundp el)
+ (prin1-to-string (symbol-value el))
+ "<unbound>")
+ "\n"
+ (if (fboundp el)
+ (concat (prin1-to-string (symbol-function el))
+ "\n")))))
+ args "")))
(with-current-buffer (get-buffer-create "*forms-mode debug*")
(if (zerop (buffer-size))
(emacs-lisp-mode))
diff --git a/lisp/frame.el b/lisp/frame.el
index b7fd71e9053..9b3d120598b 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -301,7 +301,7 @@ This function runs the abnormal hook `move-frame-functions'."
(declare-function tool-bar-mode "tool-bar" (&optional arg))
(declare-function tool-bar-height "xdisp.c" (&optional frame pixelwise))
-(defalias 'tool-bar-lines-needed 'tool-bar-height)
+(defalias 'tool-bar-lines-needed #'tool-bar-height)
;; startup.el calls this function after loading the user's init
;; file. Now default-frame-alist and initial-frame-alist contain
@@ -367,6 +367,7 @@ there (in decreasing order of priority)."
;; by the lines added in x-create-frame for the tab-bar and
;; switch `tab-bar-mode' off.
(when (display-graphic-p)
+ (declare-function tab-bar-height "xdisp.c" (&optional frame pixelwise))
(let* ((init-lines
(assq 'tab-bar-lines initial-frame-alist))
(other-lines
@@ -614,15 +615,6 @@ there (in decreasing order of priority)."
(face-set-after-frame-default frame-initial-frame)
(setq newparms (delq new-bg newparms)))
- (when (numberp (car frame-size-history))
- (setq frame-size-history
- (cons (1- (car frame-size-history))
- (cons
- (list frame-initial-frame
- "FRAME-NOTICE-USER"
- nil newparms)
- (cdr frame-size-history)))))
-
(modify-frame-parameters frame-initial-frame newparms)))))
;; Restore the original buffer.
@@ -689,8 +681,8 @@ is not considered (see `next-frame')."
0))
(select-frame-set-input-focus (selected-frame)))
-(defalias 'next-multiframe-window 'next-window-any-frame)
-(defalias 'previous-multiframe-window 'previous-window-any-frame)
+(defalias 'next-multiframe-window #'next-window-any-frame)
+(defalias 'previous-multiframe-window #'previous-window-any-frame)
(defun window-system-for-display (display)
"Return the window system for DISPLAY.
@@ -708,11 +700,25 @@ Return nil if we don't know how to interpret DISPLAY."
(defun make-frame-on-display (display &optional parameters)
"Make a frame on display DISPLAY.
The optional argument PARAMETERS specifies additional frame parameters."
- (interactive (list (completing-read
- (format "Make frame on display: ")
- (x-display-list))))
+ (interactive (if (fboundp 'x-display-list)
+ (list (completing-read
+ (format "Make frame on display: ")
+ (x-display-list)))
+ (user-error "This Emacs build does not support X displays")))
(make-frame (cons (cons 'display display) parameters)))
+(defun make-frame-on-current-monitor (&optional parameters)
+ "Make a frame on the currently selected monitor.
+Like `make-frame-on-monitor' and with the same PARAMETERS as in `make-frame'."
+ (interactive)
+ (let* ((monitor-workarea
+ (cdr (assq 'workarea (frame-monitor-attributes))))
+ (geometry-parameters
+ (when monitor-workarea
+ `((top . ,(nth 1 monitor-workarea))
+ (left . ,(nth 0 monitor-workarea))))))
+ (make-frame (append geometry-parameters parameters))))
+
(defun make-frame-on-monitor (monitor &optional display parameters)
"Make a frame on monitor MONITOR.
The optional argument DISPLAY can be a display name, and the optional
@@ -721,7 +727,7 @@ argument PARAMETERS specifies additional frame parameters."
(list
(let* ((default (cdr (assq 'name (frame-monitor-attributes)))))
(completing-read
- (format "Make frame on monitor (default %s): " default)
+ (format-prompt "Make frame on monitor" default)
(or (delq nil (mapcar (lambda (a)
(cdr (assq 'name a)))
(display-monitor-attributes-list)))
@@ -748,7 +754,7 @@ If DISPLAY is nil, that stands for the selected frame's display."
(list
(let* ((default (frame-parameter nil 'display))
(display (completing-read
- (format "Close display (default %s): " default)
+ (format-prompt "Close display" default)
(delete-dups
(mapcar (lambda (frame)
(frame-parameter frame 'display))
@@ -767,7 +773,7 @@ If DISPLAY is nil, that stands for the selected frame's display."
(format "Delete %s frames? " (length frames))
(format "Delete %s ? " (car frames))))))
(error "Abort!")
- (mapc 'delete-frame frames)
+ (mapc #'delete-frame frames)
(x-close-connection display))))
(defun make-frame-command ()
@@ -911,12 +917,6 @@ the new frame according to its own rules."
(let ((val (frame-parameter oldframe param)))
(when val (set-frame-parameter frame param val)))))
- (when (numberp (car frame-size-history))
- (setq frame-size-history
- (cons (1- (car frame-size-history))
- (cons (list frame "MAKE-FRAME")
- (cdr frame-size-history)))))
-
;; We can run `window-configuration-change-hook' for this frame now.
(frame-after-make-frame frame t)
(run-hook-with-args 'after-make-frame-functions frame)
@@ -1058,6 +1058,23 @@ that variable should be nil."
(setq arg (1+ arg)))
(select-frame-set-input-focus frame)))
+(defun other-frame-prefix ()
+ "Display the buffer of the next command in a new frame.
+The next buffer is the buffer displayed by the next command invoked
+immediately after this command (ignoring reading from the minibuffer).
+Creates a new frame before displaying the buffer.
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ (interactive)
+ (display-buffer-override-next-command
+ (lambda (buffer alist)
+ (cons (display-buffer-pop-up-frame
+ buffer (append '((inhibit-same-window . t))
+ alist))
+ 'frame))
+ nil "[other-frame]")
+ (message "Display next command buffer in a new frame..."))
+
(defun iconify-or-deiconify-frame ()
"Iconify the selected frame, or deiconify if it's currently an icon."
(interactive)
@@ -1101,7 +1118,7 @@ If there is no frame by that name, signal an error."
(let* ((frame-names-alist (make-frame-names-alist))
(default (car (car frame-names-alist)))
(input (completing-read
- (format "Select Frame (default %s): " default)
+ (format-prompt "Select Frame" default)
frame-names-alist nil t nil 'frame-name-history)))
(if (= (length input) 0)
(list default)
@@ -1130,8 +1147,8 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))."
:group 'faces
:set #'(lambda (var value)
(set-default var value)
- (mapc 'frame-set-background-mode (frame-list)))
- :initialize 'custom-initialize-changed
+ (mapc #'frame-set-background-mode (frame-list)))
+ :initialize #'custom-initialize-changed
:type '(choice (const dark)
(const light)
(const :tag "automatic" nil)))
@@ -1144,6 +1161,27 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))."
(defvar inhibit-frame-set-background-mode nil)
+(defun frame--current-backround-mode (frame)
+ (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame))
+ (bg-color (frame-parameter frame 'background-color))
+ (tty-type (tty-type frame))
+ (default-bg-mode
+ (if (or (window-system frame)
+ (and tty-type
+ (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
+ tty-type)))
+ 'light
+ 'dark)))
+ (cond (frame-default-bg-mode)
+ ((equal bg-color "unspecified-fg") ; inverted colors
+ (if (eq default-bg-mode 'light) 'dark 'light))
+ ((not (color-values bg-color frame))
+ default-bg-mode)
+ ((color-dark-p (mapcar (lambda (c) (/ c 65535.0))
+ (color-values bg-color frame)))
+ 'dark)
+ (t 'light))))
+
(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
@@ -1152,30 +1190,8 @@ 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* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame))
- (bg-color (frame-parameter frame 'background-color))
- (tty-type (tty-type frame))
- (default-bg-mode
- (if (or (window-system frame)
- (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type)))
- 'light
- 'dark))
- (non-default-bg-mode (if (eq default-bg-mode 'light) 'dark 'light))
- (bg-mode
- (cond (frame-default-bg-mode)
- ((equal bg-color "unspecified-fg") ; inverted colors
- non-default-bg-mode)
- ((not (color-values bg-color frame))
- default-bg-mode)
- ((>= (apply '+ (color-values bg-color frame))
- ;; Just looking at the screen, colors whose
- ;; values add up to .6 of the white total
- ;; still look dark to me.
- (* (apply '+ (color-values "white" frame)) .6))
- 'light)
- (t 'dark)))
+ (let* ((bg-mode
+ (frame--current-backround-mode frame))
(display-type
(cond ((null (window-system frame))
(if (tty-display-color-p frame) 'color 'mono))
@@ -1215,13 +1231,10 @@ face specs for the new background mode."
;; during startup with -rv on the command
;; line for the initial frame, because frames
;; are not recorded in the pdump file.
- (assq face (frame-face-alist))
+ (gethash face (frame--face-hash-table))
(face-spec-match-p face
(face-user-default-spec face)
- ;; FIXME: why selected-frame and
- ;; not the frame that is the
- ;; argument to this function?
- (selected-frame))))
+ frame)))
(push face locally-modified-faces)))
;; Now change to the new frame parameters
(modify-frame-parameters frame params)
@@ -1244,6 +1257,26 @@ the `background-mode' terminal parameter."
(intern (downcase bg-resource))))
(terminal-parameter frame 'background-mode)))
+;; FIXME: This needs to be significantly improved before we can use it:
+;; - Fix the "scope" to be consistent: the code below is partly per-frame
+;; and partly all-frames :-(
+;; - Make it interact correctly with color themes (e.g. modus-themes).
+;; Maybe automatically disabling color themes that disagree with the
+;; selected value of `dark-mode'.
+;; - Check interaction with "(in|re)verse-video".
+;;
+;; (define-minor-mode dark-mode
+;; "Use light text on dark background."
+;; :global t
+;; :group 'faces
+;; (when (eq dark-mode
+;; (eq 'light (frame--current-backround-mode (selected-frame))))
+;; ;; FIXME: Change the face's SPEC instead?
+;; (set-face-attribute 'default nil
+;; :foreground (face-attribute 'default :background)
+;; :background (face-attribute 'default :foreground))
+;; (frame-set-background-mode (selected-frame))))
+
;;;; Frame configurations
@@ -1328,9 +1361,9 @@ differing font heights."
If FRAME is omitted, describe the currently selected frame."
(cdr (assq 'width (frame-parameters frame))))
-(defalias 'frame-border-width 'frame-internal-border-width)
-(defalias 'frame-pixel-width 'frame-native-width)
-(defalias 'frame-pixel-height 'frame-native-height)
+(defalias 'frame-border-width #'frame-internal-border-width)
+(defalias 'frame-pixel-width #'frame-native-width)
+(defalias 'frame-pixel-height #'frame-native-height)
(defun frame-inner-width (&optional frame)
"Return inner width of FRAME in pixels.
@@ -1364,7 +1397,7 @@ FRAME defaults to the selected frame."
(declare-function x-list-fonts "xfaces.c"
(pattern &optional face frame maximum width))
-(defun set-frame-font (font &optional keep-size frames)
+(defun set-frame-font (font &optional keep-size frames inhibit-customize)
"Set the default font to FONT.
When called interactively, prompt for the name of a font, and use
that font on the selected frame. When called from Lisp, FONT
@@ -1381,15 +1414,18 @@ If FRAMES is non-nil, it should be a list of frames to act upon,
or t meaning all existing graphical frames.
Also, if FRAMES is non-nil, alter the user's Customization settings
as though the font-related attributes of the `default' face had been
-\"set in this session\", so that the font is applied to future frames."
+\"set in this session\", so that the font is applied to future frames.
+
+If INHIBIT-CUSTOMIZE is non-nil, don't update the user's
+Customization settings."
(interactive
(let* ((completion-ignore-case t)
- (font (completing-read "Font name: "
+ (default (frame-parameter nil 'font))
+ (font (completing-read (format-prompt "Font name" default)
;; x-list-fonts will fail with an error
;; if this frame doesn't support fonts.
(x-list-fonts "*" nil (selected-frame))
- nil nil nil nil
- (frame-parameter nil 'font))))
+ nil nil nil nil default)))
(list font current-prefix-arg nil)))
(when (or (stringp font) (fontp font))
(let* ((this-frame (selected-frame))
@@ -1418,7 +1454,8 @@ as though the font-related attributes of the `default' face had been
f
(list (cons 'height (round height (frame-char-height f)))
(cons 'width (round width (frame-char-width f))))))))
- (when frames
+ (when (and frames
+ (not inhibit-customize))
;; Alter the user's Custom setting of the `default' face, but
;; only for font-related attributes.
(let ((specs (cadr (assq 'user (get 'default 'theme-face))))
@@ -1553,8 +1590,9 @@ When called interactively, prompt for the name of the frame.
On text terminals, the frame name is displayed on the mode line.
On graphical displays, it is displayed on the frame's title bar."
(interactive
- (list (read-string "Frame name: " nil nil
- (cdr (assq 'name (frame-parameters))))))
+ (let ((default (cdr (assq 'name (frame-parameters)))))
+ (list (read-string (format-prompt "Frame name" default) nil nil
+ default))))
(modify-frame-parameters (selected-frame)
(list (cons 'name name))))
@@ -1646,26 +1684,104 @@ and width values are in pixels.
(defun frame--size-history (&optional frame)
"Print history of resize operations for FRAME.
-Print prettified version of `frame-size-history' into a buffer
-called *frame-size-history*. Optional argument FRAME denotes the
-frame whose history will be printed. FRAME defaults to the
-selected frame."
+This function dumps a prettified version of `frame-size-history'
+into a buffer called *frame-size-history*. The optional argument
+FRAME denotes the frame whose history will be dumped; it defaults
+to the selected frame.
+
+Storing information about resize operations is off by default.
+If you set the variable `frame-size-history' like this
+
+(setq frame-size-history '(100))
+
+then Emacs will save information about the next 100 significant
+operations affecting any frame's size in that variable. This
+function prints the entries for FRAME stored in that variable in
+a more legible way.
+
+All lines start with an indication of the requested action. An
+entry like `menu-bar-lines' or `scroll-bar-width' indicates that
+a change of the corresponding frame parameter or Lisp variable
+was requested. An entry like gui_figure_window_size indicates
+that that C function was executed, an entry like ConfigureNotify
+indicates that that event was received.
+
+In long entries, a number in parentheses displays the INHIBIT
+parameter passed to the C function adjust_frame_size. Such
+entries may also display changes of frame rectangles in a form
+like R=n1xn2~>n3xn4 where R denotes the rectangle type (TS for
+text, NS for native and IS for inner frame rectangle sizes, all
+in pixels, TC for text rectangle sizes in frame columns and
+lines), n1 and n2 denote the old width and height and n3 and n4
+the new width and height in the according units. MS stands for
+the minimum inner frame size in pixels, IH and IV, if present,
+indicate that resizing horizontally and/or vertically was
+inhibited (either by `frame-inhibit-implied-resize' or because of
+the frame's fullscreen state).
+
+Shorter entries represent C functions that process width and
+height changes of the native rectangle where PS stands for the
+frame's present pixel width and height, XS for a requested pixel
+width and height and DS for some earlier requested but so far
+delayed pixel width and height.
+
+Very short entries represent calls of C functions that do not
+directly ask for size changes but may indirectly affect the size
+of frames like calls to map a frame or change its visibility."
(let ((history (reverse frame-size-history))
- entry)
+ entry item)
(setq frame (window-normalize-frame frame))
(with-current-buffer (get-buffer-create "*frame-size-history*")
(erase-buffer)
(insert (format "Frame size history of %s\n" frame))
(while (consp (setq entry (pop history)))
- (when (eq (car entry) frame)
- (pop entry)
- (insert (format "%s" (pop entry)))
- (move-to-column 24 t)
- (while entry
- (insert (format " %s" (pop entry))))
- (insert "\n")))
- (unless frame-size-history
- (insert "Frame size history is nil.\n")))))
+ (setq item (car entry))
+ (cond
+ ((not (consp item))
+ ;; An item added quickly for debugging purposes.
+ (insert (format "%s\n" entry)))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 1))
+ ;; Length 1 is a "plain event".
+ (insert (format "%s\n" (nth 2 item))))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 2))
+ ;; Length 2 is an "extra" item.
+ (insert (format "%s" (nth 2 item)))
+ (setq item (nth 0 (cdr entry)))
+ (insert (format ", PS=%sx%s" (nth 0 item) (nth 1 item)))
+ (when (or (>= (nth 2 item) 0) (>= (nth 3 item) 0))
+ (insert (format ", XS=%sx%s" (nth 2 item) (nth 3 item))))
+ (setq item (nth 1 (cdr entry)))
+ (when (or (>= (nth 0 item) 0) (>= (nth 1 item) 0))
+ (insert (format ", DS=%sx%s" (nth 0 item) (nth 1 item))))
+ (insert "\n"))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 5))
+ ;; Length 5 is an `adjust-frame-size' item.
+ (insert (format "%s (%s)" (nth 3 item) (nth 2 item)))
+ (setq item (nth 0 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", TS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3 item))))
+ (setq item (nth 1 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", TC=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3 item))))
+ (setq item (nth 2 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", NS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3 item))))
+ (setq item (nth 3 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", IS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3 item))))
+ (setq item (nth 4 (cdr entry)))
+ (insert (format ", MS=%sx%s" (nth 0 item) (nth 1 item)))
+ (when (nth 2 item) (insert " IH"))
+ (when (nth 3 item) (insert " IV"))
+ (insert "\n")))))))
(declare-function x-frame-edges "xfns.c" (&optional frame type))
(declare-function w32-frame-edges "w32fns.c" (&optional frame type))
@@ -1908,7 +2024,7 @@ for FRAME."
;; features change, it will be easy to find all the tests for such
;; capabilities by a simple text search. See more about the history
;; and the intent of these functions in
-;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2019-04/msg00004.html
+;; https://lists.gnu.org/archive/html/bug-gnu-emacs/2019-04/msg00004.html
;; or in https://debbugs.gnu.org/cgi/bugreport.cgi?bug=35058#17.
(declare-function msdos-mouse-p "dosfns.c")
@@ -1961,9 +2077,9 @@ frame's display)."
(fboundp 'image-mask-p)
(fboundp 'image-size)))
-(defalias 'display-blink-cursor-p 'display-graphic-p)
-(defalias 'display-multi-frame-p 'display-graphic-p)
-(defalias 'display-multi-font-p 'display-graphic-p)
+(defalias 'display-blink-cursor-p #'display-graphic-p)
+(defalias 'display-multi-frame-p #'display-graphic-p)
+(defalias 'display-multi-font-p #'display-graphic-p)
(defun display-selections-p (&optional display)
"Return non-nil if DISPLAY supports selections.
@@ -2310,13 +2426,15 @@ 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) frame)))
-(defun delete-other-frames (&optional frame)
+(defun delete-other-frames (&optional frame iconify)
"Delete all frames on FRAME's terminal, except FRAME.
If FRAME uses another frame's minibuffer, the minibuffer frame is
left untouched. Do not delete any of FRAME's child frames. If
FRAME is a child frame, delete its siblings only. FRAME must be
-a live frame and defaults to the selected one."
- (interactive)
+a live frame and defaults to the selected one.
+If the prefix arg ICONIFY is non-nil, just iconify the frames rather than
+deleting them."
+ (interactive "i\nP")
(setq frame (window-normalize-frame frame))
(let ((minibuffer-frame (window-frame (minibuffer-window frame)))
(this (next-frame frame t))
@@ -2331,7 +2449,7 @@ a live frame and defaults to the selected one."
(and parent (not (eq (frame-parent this) parent)))
;; Do not delete a child frame of FRAME.
(eq (frame-parent this) frame))
- (delete-frame this))
+ (if iconify (iconify-frame this) (delete-frame this)))
(setq this next))
;; In a second round consider all remaining frames.
(setq this (next-frame frame t))
@@ -2343,7 +2461,7 @@ a live frame and defaults to the selected one."
(and parent (not (eq (frame-parent this) parent)))
;; Do not delete a child frame of FRAME.
(eq (frame-parent this) frame))
- (delete-frame this))
+ (if iconify (iconify-frame this) (delete-frame this)))
(setq this next))))
@@ -2369,7 +2487,7 @@ parameters `bottom-divider-width' and `right-divider-width'."
:type '(choice (const :tag "Bottom only" bottom-only)
(const :tag "Right only" right-only)
(const :tag "Bottom and right" t))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2390,7 +2508,7 @@ parameter `bottom-divider-width'."
:type '(restricted-sexp
:tag "Default width of bottom dividers"
:match-alternatives (window-divider-width-valid-p))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2407,7 +2525,7 @@ parameter `right-divider-width'."
:type '(restricted-sexp
:tag "Default width of right dividers"
:match-alternatives (window-divider-width-valid-p))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2526,13 +2644,15 @@ Use 0 or negative value to blink forever."
This starts the timer `blink-cursor-timer', which makes the cursor blink
if appropriate. It also arranges to cancel that timer when the next
command starts, by installing a pre-command hook."
- (when (null blink-cursor-timer)
+ (cond
+ ((null blink-cursor-mode) (blink-cursor-mode -1))
+ ((null blink-cursor-timer)
;; Set up the timer first, so that if this signals an error,
;; blink-cursor-end is not added to pre-command-hook.
(setq blink-cursor-blinks-done 1)
(blink-cursor--start-timer)
- (add-hook 'pre-command-hook 'blink-cursor-end)
- (internal-show-cursor nil nil)))
+ (add-hook 'pre-command-hook #'blink-cursor-end)
+ (internal-show-cursor nil nil))))
(defun blink-cursor-timer-function ()
"Timer function of timer `blink-cursor-timer'."
@@ -2546,14 +2666,14 @@ command starts, by installing a pre-command hook."
(when (and (> blink-cursor-blinks 0)
(<= (* 2 blink-cursor-blinks) blink-cursor-blinks-done))
(blink-cursor-suspend)
- (add-hook 'post-command-hook 'blink-cursor-check)))
+ (add-hook 'post-command-hook #'blink-cursor-check)))
(defun blink-cursor-end ()
"Stop cursor blinking.
This is installed as a pre-command hook by `blink-cursor-start'.
When run, it cancels the timer `blink-cursor-timer' and removes
itself as a pre-command hook."
- (remove-hook 'pre-command-hook 'blink-cursor-end)
+ (remove-hook 'pre-command-hook #'blink-cursor-end)
(internal-show-cursor nil t)
(when blink-cursor-timer
(cancel-timer blink-cursor-timer)
@@ -2589,7 +2709,7 @@ stopped by `blink-cursor-suspend'. Internally calls
`blink-cursor--should-blink' and returns its result."
(let ((should-blink (blink-cursor--should-blink)))
(when (and should-blink (not blink-cursor-idle-timer))
- (remove-hook 'post-command-hook 'blink-cursor-check)
+ (remove-hook 'post-command-hook #'blink-cursor-check)
(blink-cursor--start-idle-timer))
should-blink))
@@ -2611,18 +2731,18 @@ This command is effective only on graphical frames. On text-only
terminals, cursor blinking is controlled by the terminal."
:init-value (not (or noninteractive
no-blinking-cursor
- (eq system-type 'ms-dos)
- (not (display-blink-cursor-p))))
- :initialize 'custom-initialize-delay
+ (eq system-type 'ms-dos)))
+ :initialize #'custom-initialize-delay
:group 'cursor
:global t
(blink-cursor-suspend)
(remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
(remove-function after-focus-change-function #'blink-cursor--rescan-frames)
(when blink-cursor-mode
- (add-function :after after-focus-change-function #'blink-cursor--rescan-frames)
+ (add-function :after after-focus-change-function
+ #'blink-cursor--rescan-frames)
(add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
- (blink-cursor--start-idle-timer)))
+ (blink-cursor-check)))
;; Frame maximization/fullscreen
@@ -2677,22 +2797,19 @@ See also `toggle-frame-maximized'."
(set-frame-parameter frame 'fullscreen fullscreen-restore)
(set-frame-parameter frame 'fullscreen nil)))
(modify-frame-parameters
- frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen))))
- ;; Manipulating a frame without waiting for the fullscreen
- ;; animation to complete can cause a crash, or other unexpected
- ;; behavior, on macOS (bug#28496).
- (when (featurep 'cocoa) (sleep-for 0.5))))
+ frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen))))))
;;;; Key bindings
-(define-key ctl-x-5-map "2" 'make-frame-command)
-(define-key ctl-x-5-map "1" 'delete-other-frames)
-(define-key ctl-x-5-map "0" 'delete-frame)
-(define-key ctl-x-5-map "o" 'other-frame)
-(define-key global-map [f11] 'toggle-frame-fullscreen)
-(define-key global-map [(meta f10)] 'toggle-frame-maximized)
-(define-key esc-map [f10] 'toggle-frame-maximized)
+(define-key ctl-x-5-map "2" #'make-frame-command)
+(define-key ctl-x-5-map "1" #'delete-other-frames)
+(define-key ctl-x-5-map "0" #'delete-frame)
+(define-key ctl-x-5-map "o" #'other-frame)
+(define-key ctl-x-5-map "5" #'other-frame-prefix)
+(define-key global-map [f11] #'toggle-frame-fullscreen)
+(define-key global-map [(meta f10)] #'toggle-frame-maximized)
+(define-key esc-map [f10] #'toggle-frame-maximized)
;; Misc.
@@ -2707,6 +2824,14 @@ See also `toggle-frame-maximized'."
(make-obsolete-variable
'window-system-version "it does not give useful information." "24.3")
+(defun set-frame-property--interactive (prompt number)
+ "Get a value for `set-frame-width' or `set-frame-height', prompting with PROMPT.
+Offer NUMBER as default value, if it is a natural number."
+ (if (and current-prefix-arg (not (consp current-prefix-arg)))
+ (list (selected-frame) (prefix-numeric-value current-prefix-arg))
+ (let ((default (and (natnump number) number)))
+ (list (selected-frame) (read-number prompt default)))))
+
;; Variables whose change of value should trigger redisplay of the
;; current buffer.
;; To test whether a given variable needs to be added to this list,
diff --git a/lisp/frameset.el b/lisp/frameset.el
index 7ed7b079bd3..e698d5401db 100644
--- a/lisp/frameset.el
+++ b/lisp/frameset.el
@@ -396,17 +396,17 @@ Properties can be set with
;; or, if you're only changing a few items,
;;
;; (defvar my-filter-alist
-;; (nconc '((my-param1 . :never)
-;; (my-param2 . my-filtering-function))
-;; frameset-filter-alist)
+;; (append '((my-param1 . :never)
+;; (my-param2 . my-filtering-function))
+;; frameset-filter-alist)
;; "My brief customized parameter filter alist.")
;;
;; and pass it to the FILTER arg of the save/restore functions,
;; ALWAYS taking care of not modifying the original lists; if you're
;; going to do any modifying of my-filter-alist, please use
;;
-;; (nconc '((my-param1 . :never) ...)
-;; (copy-sequence frameset-filter-alist))
+;; (append '((my-param1 . :never) ...)
+;; (copy-sequence frameset-filter-alist))
;;
;; One thing you shouldn't forget is that they are alists, so searching
;; in them is sequential. If you just want to change the default of
@@ -445,7 +445,7 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.")
;;;###autoload
(defvar frameset-persistent-filter-alist
- (nconc
+ (append
'((background-color . frameset-filter-sanitize-color)
(buffer-list . :never)
(buffer-predicate . :never)
diff --git a/lisp/fringe.el b/lisp/fringe.el
index e2d7968adde..d73aae0459e 100644
--- a/lisp/fringe.el
+++ b/lisp/fringe.el
@@ -181,7 +181,11 @@ When setting this variable in a Lisp program, call
`set-fringe-mode' afterward to make it take real effect.
To modify the appearance of the fringe in a specific frame, use
-the interactive function `set-fringe-style'."
+the interactive function `set-fringe-style'.
+
+Note that, despite the name, this is not a variable that controls
+a (major or minor) Emacs mode, but controls the appearance of the
+fringes."
:type `(choice
,@ (mapcar (lambda (style)
(let ((name
@@ -248,7 +252,10 @@ Fringe widths set by `set-window-fringes' override the default
fringe widths set by this command. This command applies to all
frames that exist and frames to be created in the future. If you
want to set the default appearance of fringes on the selected
-frame only, see the command `set-fringe-style'."
+frame only, see the command `set-fringe-style'.
+
+Note that, despite the name, this is not a (major or minor) Emacs
+mode, but a command that controls the appearance of the fringes."
(interactive (list (fringe-query-style 'all-frames)))
(set-fringe-mode mode))
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index 0f56ddf0796..4505d8513f9 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -1,4 +1,4 @@
-;;; generic-x.el --- A collection of generic modes
+;;; generic-x.el --- A collection of generic modes -*- lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; This file contains a collection of generic modes.
;;
;; INSTALLATION:
@@ -107,8 +107,6 @@
;;; Code:
-(eval-when-compile (require 'font-lock))
-
(defgroup generic-x nil
"A collection of generic modes."
:prefix "generic-"
@@ -123,14 +121,12 @@
"If non-nil, add a hook to enter `default-generic-mode' automatically.
This is done if the first few lines of a file in fundamental mode
start with a hash comment character."
- :group 'generic-x
:type 'boolean)
(defcustom generic-lines-to-scan 3
"Number of lines that `generic-mode-find-file-hook' looks at.
Relevant when deciding whether to enter Default-Generic mode automatically.
This variable should be set to a small positive number."
- :group 'generic-x
:type 'integer)
(defcustom generic-find-file-regexp "^#"
@@ -139,7 +135,6 @@ Files in fundamental mode whose first few lines contain a match
for this regexp, should be put into Default-Generic mode instead.
The number of lines tested for the matches is specified by the
value of the variable `generic-lines-to-scan', which see."
- :group 'generic-x
:type 'regexp)
(defcustom generic-ignore-files-regexp "[Tt][Aa][Gg][Ss]\\'"
@@ -148,7 +143,6 @@ Files whose names match this regular expression should not be put
into Default-Generic mode, even if they have lines which match
the regexp in `generic-find-file-regexp'. If the value is nil,
`generic-mode-find-file-hook' does not check the file names."
- :group 'generic-x
:type '(choice (const :tag "Don't check file names" nil) regexp))
;; This generic mode is always defined
@@ -251,7 +245,6 @@ This hook will be installed if the variable
Each entry in the list should be a symbol. If you set this variable
directly, without using customize, you must reload generic-x to put
your changes into effect."
- :group 'generic-x
:type (let (list)
(dolist (mode
(sort (append generic-default-modes
@@ -280,12 +273,11 @@ your changes into effect."
("^\\s-*\\(\\sw+\\)\\s-" 1 font-lock-variable-name-face))
'("srm\\.conf\\'" "httpd\\.conf\\'" "access\\.conf\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\)" 1)
- ("*Directories*" "^\\s-*<Directory\\s-*\\([^>]+\\)>" 1)
- ("*Locations*" "^\\s-*<Location\\s-*\\([^>]+\\)>" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([-A-Za-z0-9_]+\\)" 1)
+ ("*Directories*" "^\\s-*<Directory\\s-*\\([^>]+\\)>" 1)
+ ("*Locations*" "^\\s-*<Location\\s-*\\([^>]+\\)>" 1)))))
"Generic mode for Apache or HTTPD configuration files."))
(when (memq 'apache-log-generic-mode generic-extras-enable-list)
@@ -368,7 +360,8 @@ your changes into effect."
(define-generic-mode hosts-generic-mode
'(?#)
'("localhost")
- '(("\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" 1 font-lock-constant-face))
+ '(("\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" 1 font-lock-constant-face)
+ ("\\<\\([0-9A-Fa-f:]+\\)\\>" 1 font-lock-constant-face))
'("[hH][oO][sS][tT][sS]\\'")
nil
"Generic mode for HOSTS files."))
@@ -401,11 +394,10 @@ your changes into effect."
(2 font-lock-variable-name-face)))
'("\\.[iI][nN][iI]\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\[\\(.*\\)\\]" 1)
- ("*Variables*" "^\\s-*\\([^=]+\\)\\s-*=" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\[\\(.*\\)\\]" 1)
+ ("*Variables*" "^\\s-*\\([^=]+\\)\\s-*=" 1)))))
"Generic mode for MS-Windows INI files.
You can use `ini-generic-mode-find-file-hook' to enter this mode
automatically for INI files whose names do not end in \".ini\".")
@@ -419,7 +411,8 @@ like an INI file. You can add this hook to `find-file-hook'."
(goto-char (point-min))
(and (looking-at "^\\s-*\\[.*\\]")
(ini-generic-mode)))))
-(defalias 'generic-mode-ini-file-find-file-hook 'ini-generic-mode-find-file-hook))
+(define-obsolete-function-alias 'generic-mode-ini-file-find-file-hook
+ 'ini-generic-mode-find-file-hook "28.1"))
;;; Windows REG files
;;; Unfortunately, Windows 95 and Windows NT have different REG file syntax!
@@ -432,10 +425,9 @@ like an INI file. You can add this hook to `find-file-hook'."
("^\\([^\n\r]*\\)\\s-*=" 1 font-lock-variable-name-face))
'("\\.[rR][eE][gG]\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\s-*\\(.*\\)\\s-*=" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\s-*\\(.*\\)\\s-*=" 1)))))
"Generic mode for MS-Windows Registry files."))
(declare-function w32-shell-name "w32-fns" ())
@@ -456,10 +448,9 @@ like an INI file. You can add this hook to `find-file-hook'."
("\\s-/\\([^/]+\\)/[i, \t\n]" 1 font-lock-constant-face))
'("\\.rules\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "\\s-/\\([^/]+\\)/[i, \t\n]" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "\\s-/\\([^/]+\\)/[i, \t\n]" 1)))))
"Generic mode for Mailagent rules files."))
;; Solaris/Sys V prototype files
@@ -548,13 +539,12 @@ like an INI file. You can add this hook to `find-file-hook'."
(2 font-lock-variable-name-face)))
'("\\.wrl\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([A-Za-z0-9_]+\\)\\s-*{" 1)
- ("*Definitions*"
- "DEF\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([A-Za-z0-9]+\\)\\s-*{"
- 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([A-Za-z0-9_]+\\)\\s-*{" 1)
+ ("*Definitions*"
+ "DEF\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([A-Za-z0-9]+\\)\\s-*{"
+ 1)))))
"Generic Mode for VRML files."))
;; Java Manifests
@@ -594,20 +584,18 @@ like an INI file. You can add this hook to `find-file-hook'."
;; * an equal sign
;; * a colon
(mapcar
- (function
- (lambda (elt)
- (list
- (concat "^" java-properties-key elt java-properties-value "$")
- '(1 font-lock-constant-face)
- '(4 font-lock-variable-name-face))))
+ (lambda (elt)
+ (list
+ (concat "^" java-properties-key elt java-properties-value "$")
+ '(1 font-lock-constant-face)
+ '(4 font-lock-variable-name-face)))
;; These are the separators
'(":\\s-*" "\\s-+" "\\s-*=\\s-*"))))
nil
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([^#! \t\n\r=:]+\\)" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([^#! \t\n\r=:]+\\)" 1)))))
"Generic mode for Java properties files."))
;; C shell alias definitions
@@ -622,10 +610,9 @@ like an INI file. You can add this hook to `find-file-hook'."
(1 font-lock-variable-name-face)))
'("alias\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\(alias\\|unalias\\)\\s-+\\([-a-zA-Z0-9_]+\\)" 2))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\(alias\\|unalias\\)\\s-+\\([-a-zA-Z0-9_]+\\)" 2)))))
"Generic mode for C Shell alias files."))
;; Ansible inventory files
@@ -643,13 +630,12 @@ like an INI file. You can add this hook to `find-file-hook'."
("\\([^ =\n\r]+\\)=\\([^ \n\r]*\\)"
(1 font-lock-variable-name-face)
(2 font-lock-keyword-face)))
- '("inventory")
+ '("inventory\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\s-*\\[\\(.*\\)\\]" 1)
- ("*Variables*" "\\s-+\\([^ =\n\r]+\\)=" 1))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\s-*\\[\\(.*\\)\\]" 1)
+ ("*Variables*" "\\s-+\\([^ =\n\r]+\\)=" 1)))))
"Generic mode for Ansible inventory files."))
;;; Windows RC files
@@ -1307,19 +1293,16 @@ like an INI file. You can add this hook to `find-file-hook'."
;; here manually instead
(defun generic-rul-mode-setup-function ()
- (make-local-variable 'parse-sexp-ignore-comments)
- (make-local-variable 'comment-start)
(make-local-variable 'comment-start-skip)
- (make-local-variable 'comment-end)
(setq imenu-generic-expression
- '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1))
- parse-sexp-ignore-comments t
- comment-end "*/"
- comment-start "/*"
-;;; comment-end ""
-;;; comment-start "//"
-;;; comment-start-skip ""
- )
+ '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1)))
+ (setq-local parse-sexp-ignore-comments t
+ comment-end "*/"
+ comment-start "/*"
+;;; comment-end ""
+;;; comment-start "//"
+;;; comment-start-skip ""
+ )
;; (set-syntax-table rul-generic-mode-syntax-table)
(setq-local font-lock-syntax-table rul-generic-mode-syntax-table))
@@ -1432,10 +1415,9 @@ like an INI file. You can add this hook to `find-file-hook'."
'(("^\\([-A-Za-z0-9_]+\\)" 1 font-lock-type-face))
'("/etc/inetd\\.conf\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\)" 1))))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([-A-Za-z0-9_]+\\)" 1)))))))
;; Services
(when (memq 'etc-services-generic-mode generic-extras-enable-list)
@@ -1450,10 +1432,9 @@ like an INI file. You can add this hook to `find-file-hook'."
(2 font-lock-variable-name-face)))
'("/etc/services\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\)" 1))))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([-A-Za-z0-9_]+\\)" 1)))))))
;; Password and Group files
(when (memq 'etc-passwd-generic-mode generic-extras-enable-list)
@@ -1471,7 +1452,7 @@ like an INI file. You can add this hook to `find-file-hook'."
":"
;; Password, UID and GID
(mapconcat
- 'identity
+ #'identity
(make-list 3 "\\([^:]+\\)")
":")
":"
@@ -1493,10 +1474,9 @@ like an INI file. You can add this hook to `find-file-hook'."
;; /etc/passwd- is a backup file for /etc/passwd, so is group- and shadow-
'("/etc/passwd-?\\'" "/etc/group-?\\'" "/etc/shadow-?\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\):" 1))))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([-A-Za-z0-9_]+\\):" 1)))))))
;; Fstab
(when (memq 'etc-fstab-generic-mode generic-extras-enable-list)
@@ -1504,41 +1484,104 @@ like an INI file. You can add this hook to `find-file-hook'."
(define-generic-mode etc-fstab-generic-mode
'(?#)
'("adfs"
+ "ados"
"affs"
+ "anon_inodefs"
+ "atfs"
+ "audiofs"
"autofs"
+ "bdev"
+ "befs"
+ "bfs"
+ "binfmt_misc"
+ "btrfs"
+ "cd9660"
+ "cfs"
+ "cgroup"
+ "cifs"
"coda"
"coherent"
+ "configfs"
+ "cpuset"
"cramfs"
+ "devfs"
"devpts"
+ "devtmpfs"
+ "e2compr"
"efs"
"ext2"
+ "ext2fs"
"ext3"
"ext4"
+ "fdesc"
+ "ffs"
+ "filecore"
+ "fuse"
+ "fuseblk"
+ "fusectl"
"hfs"
"hpfs"
+ "hugetlbfs"
"iso9660"
+ "jffs"
+ "jffs2"
"jfs"
+ "kernfs"
+ "lfs"
+ "linprocfs"
+ "mfs"
"minix"
+ "mqueue"
"msdos"
"ncpfs"
"nfs"
+ "nfsd"
+ "nilfs2"
+ "none"
"ntfs"
+ "null"
+ "nwfs"
+ "overlay"
+ "ovlfs"
+ "pipefs"
+ "portal"
"proc"
+ "procfs"
+ "pstore"
+ "ptyfs"
"qnx4"
+ "ramfs"
"reiserfs"
"romfs"
+ "securityfs"
+ "shm"
"smbfs"
- "cifs"
- "usbdevfs"
- "sysv"
+ "sockfs"
+ "squashfs"
+ "sshfs"
+ "std"
+ "subfs"
"sysfs"
+ "sysv"
+ "tcfs"
"tmpfs"
"udf"
"ufs"
+ "umap"
"umsdos"
+ "union"
+ "usbdevfs"
+ "usbfs"
+ "userfs"
"vfat"
+ "vs3fs"
+ "vxfs"
+ "wrapfs"
+ "wvfs"
+ "xenfs"
"xenix"
"xfs"
+ "zisofs"
"swap"
"auto"
"ignore")
@@ -1547,10 +1590,9 @@ like an INI file. You can add this hook to `find-file-hook'."
(2 font-lock-variable-name-face t)))
'("/etc/[v]*fstab\\'")
(list
- (function
- (lambda ()
- (setq imenu-generic-expression
- '((nil "^\\([^# \t]+\\)\\s-+" 1))))))))
+ (lambda ()
+ (setq imenu-generic-expression
+ '((nil "^\\([^# \t]+\\)\\s-+" 1)))))))
;; /etc/sudoers
(when (memq 'etc-sudoers-generic-mode generic-extras-enable-list)
@@ -1590,8 +1632,7 @@ like an INI file. You can add this hook to `find-file-hook'."
(((class color) (min-colors 88)) (:background "red1"))
(((class color)) (:background "red"))
(t (:weight bold)))
- "Font Lock mode face used to highlight TABs."
- :group 'generic-x)
+ "Font Lock mode face used to highlight TABs.")
(defface show-tabs-space
'((((class grayscale) (background light)) (:background "DimGray" :weight bold))
@@ -1599,8 +1640,7 @@ like an INI file. You can add this hook to `find-file-hook'."
(((class color) (min-colors 88)) (:background "yellow1"))
(((class color)) (:background "yellow"))
(t (:weight bold)))
- "Font Lock mode face used to highlight spaces."
- :group 'generic-x)
+ "Font Lock mode face used to highlight spaces.")
(define-generic-mode show-tabs-generic-mode
nil ;; no comment char
@@ -1710,9 +1750,8 @@ like an INI file. You can add this hook to `find-file-hook'."
(list
'generic-bracket-support
;; Make keywords case-insensitive
- (function
- (lambda()
- (setq font-lock-defaults '(generic-font-lock-keywords nil t)))))
+ (lambda ()
+ (setq font-lock-defaults '(generic-font-lock-keywords nil t))))
"Generic mode for SPICE circuit netlist files."))
(when (memq 'ibis-generic-mode generic-extras-enable-list)
@@ -1758,9 +1797,8 @@ like an INI file. You can add this hook to `find-file-hook'."
(list
'generic-bracket-support
;; Make keywords case-insensitive
- (function
- (lambda()
- (setq font-lock-defaults '(generic-font-lock-keywords nil t)))))
+ (lambda ()
+ (setq font-lock-defaults '(generic-font-lock-keywords nil t))))
"Generic mode for ASTAP circuit netlist files."))
(when (memq 'etc-modules-conf-generic-mode generic-extras-enable-list)
diff --git a/lisp/gnus/.dir-locals.el b/lisp/gnus/.dir-locals.el
deleted file mode 100644
index fb968e13a36..00000000000
--- a/lisp/gnus/.dir-locals.el
+++ /dev/null
@@ -1,4 +0,0 @@
-((emacs-lisp-mode . ((show-trailing-whitespace . t))))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2
index d67d3f12a51..35402dffd07 100644
--- a/lisp/gnus/ChangeLog.2
+++ b/lisp/gnus/ChangeLog.2
@@ -3378,7 +3378,7 @@
* gnus-async.el (gnus-asynchronous): Move defcustom of
gnus-asynchronous away from defgroup of gnus-asynchronous.
- This seems to fix an intermittant error in which loading gnus-async
+ This seems to fix an intermittent error in which loading gnus-async
fails to define gnus-asynchronous (the variable).
* gnus-sum.el: Concur with Steve Young, 5th argument to 'load' is
@@ -7096,7 +7096,7 @@
* nnimap.el (nnimap-callback-callback-function):
(nnimap-callback-buffer): Remove, these cannot be global but must
be embedded into the callback.
- (nnimap-make-callback): New. Embedd article number, callback and
+ (nnimap-make-callback): New. Embed article number, callback and
buffer in function.
(nnimap-callback, nnimap-request-article-part): Update.
@@ -8031,7 +8031,7 @@
(message-xpost-fup2-header, message-xpost-insert-note)
(message-xpost-fup2, message-reduce-to-to-cc): New functions
adopted from message-utils.el. Add functions to the keymap, mode
- describtion and menu.
+ description and menu.
(message-change-subject, message-xpost-fup2): Signal error if
current header is empty.
(message-xpost-insert-note): Change insert position.
@@ -8612,7 +8612,7 @@
2002-06-11 Simon Josefsson <jas@extundo.com>
* gnus-int.el (gnus-request-move-article): Agent expire article if
- successfuly moved.
+ successfully moved.
2002-06-11 Niklas Morberg <niklas.morberg@axis.com>
@@ -9073,7 +9073,7 @@
2002-04-13 Josh Huber <huber@alum.wpi.edu>
- * mml-sec.el (mml-secure-message): Change to support arbritrary
+ * mml-sec.el (mml-secure-message): Change to support arbitrary
modes.
* mml-sec.el (mml-secure-message-encrypt-(smime|pgp|pgpmime)):
changed to support "signencrypt" mode.
diff --git a/lisp/gnus/ChangeLog.3 b/lisp/gnus/ChangeLog.3
index 90844b54e4e..2aba3a5706f 100644
--- a/lisp/gnus/ChangeLog.3
+++ b/lisp/gnus/ChangeLog.3
@@ -170,7 +170,7 @@
2015-02-09 Lars Ingebrigtsen <larsi@gnus.org>
* mm-decode.el (mm-convert-shr-links): Don't overwrite the faces from
- shr, beacause that breaks folding.
+ shr, because that breaks folding.
(mm-shr): Don't shorten the width when using fonts.
2015-02-05 Teodor Zlatanov <tzz@lifelogs.com>
@@ -596,7 +596,7 @@
2014-06-05 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (gnus-article-edit-part): Don't modifiy markers.
+ * gnus-art.el (gnus-article-edit-part): Don't modify markers.
(gnus-article-read-summary-keys):
Don't bug out when there is no article in the summary buffer.
(gnus-mime-buttonize-attachments-in-header):
@@ -1318,7 +1318,7 @@
2013-08-06 Jan Tatarik <jan.tatarik@gmail.com>
* gnus-icalendar.el (gnus-icalendar-event-from-ical): Replace pcase
- with cond for backwards compatability.
+ with cond for backwards compatibility.
2013-08-06 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -2221,7 +2221,7 @@
2013-04-04 Katsumi Yamaoka <yamaoka@jpl.org>
- * mml.el (mml-minibuffer-read-description): Use `default' insted of
+ * mml.el (mml-minibuffer-read-description): Use `default' instead of
`initial-input' for the argument name.
Suggested by Stefan Monnier <monnier@iro.umontreal.ca>.
@@ -5541,7 +5541,7 @@
(registry-prune-hard): Use it.
* gnus-registry.el (gnus-registry-fixup-registry): Set prune-factor to
- 0.1 expicitly.
+ 0.1 explicitly.
2011-05-13 Glenn Morris <rgm@gnu.org>
@@ -8758,7 +8758,7 @@
* shr.el (shr-generic): The text nodes should be text, not :text.
- * nnir.el (nnir-search-engine): Ressurect variable, since it's used
+ * nnir.el (nnir-search-engine): Resurrect variable, since it's used
later in the file.
2010-10-30 Andrew Cohen <cohen@andy.bu.edu>
@@ -9481,7 +9481,7 @@
nil.
* gnus-start.el (gnus-get-unread-articles): Require gnus-agent before
- bidning gnus-agent variables.
+ binding gnus-agent variables.
* shr.el (shr-render-td): Use a cache for the table rendering function
to avoid getting an exponential rendering behavior in nested tables.
@@ -11849,7 +11849,7 @@
2010-08-13 Teodor Zlatanov <tzz@lifelogs.com>
- Doc fixes and keep unknown groups (ammended for nunion bug fix).
+ Doc fixes and keep unknown groups (amended for nunion bug fix).
* gnus-sync.el: Fix docs.
(gnus-sync-save): Keep unknown groups in `gnus-sync-newsrc-loader'.
@@ -18925,7 +18925,7 @@
* message.el: Autoload gmm-image-load-path.
(message-tool-bar-retro): Prepend "gnus/" subdirectory to some
icon file names. Use old Emacs 21 "mail_send.xpm" icon for
- consitency.
+ consistency.
* gmm-utils.el (gmm-image-load-path): Also search in
"../etc/images". Don't set gmm-image-load-path if we don't find
@@ -19523,7 +19523,7 @@
* nnml.el: Don't require gnus-bcklg. Autoload it.
(nnml-use-compressed-files, nnml-save-mail): Support other
- comression programs such as bzip2.
+ compression programs such as bzip2.
2005-12-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -21227,7 +21227,7 @@
(nntp-with-open-group): Allow debugging.
* nnheader.el (mail-header-set-extra): Make into a function
- because I just could't understand how to quote the list properly.
+ because I just couldn't understand how to quote the list properly.
* dns.el (query-dns-cached): New function.
@@ -24966,7 +24966,7 @@
functions as needing (default), or not needing,
gnus-convert-old-newsrc's "backup before upgrading warning".
(gnus-convert-converter-needs-prompt): Tests whether the user
- should be protected from potentially irreversable changes by the
+ should be protected from potentially irreversible changes by the
function.
* legacy-gnus-agent.el: New. Provides converters that are only
diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el
index 6c8c1a5927a..dbdbaa83d7e 100644
--- a/lisp/gnus/canlock.el
+++ b/lisp/gnus/canlock.el
@@ -1,4 +1,4 @@
-;;; canlock.el --- functions for Cancel-Lock feature
+;;; canlock.el --- functions for Cancel-Lock feature -*- lexical-binding: t; -*-
;; Copyright (C) 1998-1999, 2001-2021 Free Software Foundation, Inc.
@@ -30,7 +30,7 @@
;; Key) header in a news article by using a hook which will be evaluated
;; just before sending an article as follows:
;;
-;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t)
+;; (add-hook '*e**a*e-header-hook #'canlock-insert-header t)
;;
;; Verifying Cancel-Lock is mainly a function of news servers, however,
;; you can verify your own article using the command `canlock-verify' in
@@ -52,20 +52,17 @@
(defcustom canlock-password nil
"Password to use when signing a Cancel-Lock or a Cancel-Key header."
:type '(radio (const :format "Not specified " nil)
- (string :tag "Password"))
- :group 'canlock)
+ (string :tag "Password")))
(defcustom canlock-password-for-verify canlock-password
"Password to use when verifying a Cancel-Lock or a Cancel-Key header."
:type '(radio (const :format "Not specified " nil)
- (string :tag "Password"))
- :group 'canlock)
+ (string :tag "Password")))
(defcustom canlock-force-insert-header nil
"If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the
buffer does not look like a news message."
- :type 'boolean
- :group 'canlock)
+ :type 'boolean)
(defun canlock-sha1 (message)
"Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes."
diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el
index 0e00b75fad1..e6c4630a67b 100644
--- a/lisp/gnus/deuglify.el
+++ b/lisp/gnus/deuglify.el
@@ -1,4 +1,4 @@
-;;; deuglify.el --- deuglify broken Outlook (Express) articles
+;;; deuglify.el --- deuglify broken Outlook (Express) articles -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -155,15 +155,15 @@
;; To automatically invoke deuglification on every article you read,
;; put something like that in your .gnus:
;;
-;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-unwrap-lines)
+;; (add-hook 'gnus-article-decode-hook #'gnus-article-outlook-unwrap-lines)
;;
;; or _one_ of the following lines:
;;
;; ;; repair broken attribution lines
-;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-repair-attribution)
+;; (add-hook 'gnus-article-decode-hook #'gnus-article-outlook-repair-attribution)
;;
;; ;; repair broken attribution lines and citations
-;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-rearrange-citation)
+;; (add-hook 'gnus-article-decode-hook #'gnus-article-outlook-rearrange-citation)
;;
;; Note that there always may be some false positives, so I suggest
;; using the manual invocation. After deuglification you may want to
@@ -234,61 +234,56 @@
(defcustom gnus-outlook-deuglify-unwrap-min 45
"Minimum length of the cited line above the (possibly) wrapped line."
:version "22.1"
- :type 'integer
- :group 'gnus-outlook-deuglify)
+ :type 'integer)
(defcustom gnus-outlook-deuglify-unwrap-max 95
"Maximum length of the cited line after unwrapping."
:version "22.1"
- :type 'integer
- :group 'gnus-outlook-deuglify)
+ :type 'integer)
(defcustom gnus-outlook-deuglify-cite-marks ">|#%"
"Characters that indicate cited lines."
:version "22.1"
- :type 'string
- :group 'gnus-outlook-deuglify)
+ :type 'string)
(defcustom gnus-outlook-deuglify-unwrap-stop-chars nil ;; ".?!" or nil
- "Characters that inhibit unwrapping if they are the last one on the cited line above the possible wrapped line."
+ "Characters that, when at end of cited line, inhibit unwrapping.
+When one of these characters is the last one on the cited line
+above the possibly wrapped line, it disallows unwrapping."
:version "22.1"
:type '(radio (const :format "None " nil)
- (string :value ".?!"))
- :group 'gnus-outlook-deuglify)
+ (string :value ".?!")))
(defcustom gnus-outlook-deuglify-no-wrap-chars "`"
- "Characters that inhibit unwrapping if they are the first one in the possibly wrapped line."
+ "Characters that, when at beginning of line, inhibit unwrapping.
+When one of these characters is the first one in the possibly
+wrapped line, it disallows unwrapping."
:version "22.1"
- :type 'string
- :group 'gnus-outlook-deuglify)
+ :type 'string)
(defcustom gnus-outlook-deuglify-attrib-cut-regexp
"\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, "
- "Regular expression matching the beginning of an attribution line that should be cut off."
+ "Regexp matching beginning of attribution line that should be cut off."
:version "22.1"
- :type 'string
- :group 'gnus-outlook-deuglify)
+ :type 'regexp)
(defcustom gnus-outlook-deuglify-attrib-verb-regexp
"wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió"
"Regular expression matching the verb used in an attribution line."
:version "22.1"
- :type 'string
- :group 'gnus-outlook-deuglify)
+ :type 'regexp)
(defcustom gnus-outlook-deuglify-attrib-end-regexp
": *\\|\\.\\.\\."
"Regular expression matching the end of an attribution line."
:version "22.1"
- :type 'string
- :group 'gnus-outlook-deuglify)
+ :type 'regexp)
(defcustom gnus-outlook-display-hook nil
"A hook called after a deuglified article has been prepared.
It is run after `gnus-article-prepare-hook'."
:version "22.1"
- :type 'hook
- :group 'gnus-outlook-deuglify)
+ :type 'hook)
;; Functions
@@ -315,7 +310,7 @@ You can control what lines will be unwrapped by frobbing
`gnus-outlook-deuglify-unwrap-min' and `gnus-outlook-deuglify-unwrap-max',
indicating the minimum and maximum length of an unwrapped citation line. If
NODISPLAY is non-nil, don't redisplay the article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks)
@@ -338,10 +333,11 @@ NODISPLAY is non-nil, don't redisplay the article buffer."
(unless nodisplay (gnus-outlook-display-article-buffer)))
(defun gnus-outlook-rearrange-article (attr-start)
- "Put the text from ATTR-START to the end of buffer at the top of the article buffer."
+ "Put text from ATTR-START to the end of buffer at the top of the article buffer."
;; FIXME: 1. (*) text/plain ( ) text/html
(let ((inhibit-read-only t)
- (cite-marks gnus-outlook-deuglify-cite-marks))
+ ;; (cite-marks gnus-outlook-deuglify-cite-marks)
+ )
(gnus-with-article-buffer
(article-goto-body)
;; article does not start with attribution
@@ -403,9 +399,9 @@ NODISPLAY is non-nil, don't redisplay the article buffer."
(gnus-with-article-buffer
(article-goto-body)
(when (re-search-forward
- (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n"
+ (concat "^[" cite-marks " \t]*--*[^-]+ [^-]+--*\\s *\n"
"[^\n:]+:[ \t]*\\([^\n]+\\)\n"
- "\\([^\n:]+:[ \t]*[^\n]+\n\\)+")
+ "\\([^\n:]+:[^\n]+\n\\)+")
nil t)
(gnus-kill-all-overlays)
(replace-match "\\1 wrote:\n")
@@ -434,7 +430,7 @@ NODISPLAY is non-nil, don't redisplay the article buffer."
(defun gnus-article-outlook-repair-attribution (&optional nodisplay)
"Repair a broken attribution line.
If NODISPLAY is non-nil, don't redisplay the article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((attrib-start
(or
(gnus-outlook-repair-attribution-other)
@@ -446,7 +442,7 @@ If NODISPLAY is non-nil, don't redisplay the article buffer."
(defun gnus-article-outlook-rearrange-citation (&optional nodisplay)
"Repair broken citations.
If NODISPLAY is non-nil, don't redisplay the article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((attrib-start (gnus-article-outlook-repair-attribution 'nodisplay)))
;; rearrange citations if an attribution line has been recognized
(if attrib-start
@@ -459,7 +455,7 @@ If NODISPLAY is non-nil, don't redisplay the article buffer."
Treat \"smartquotes\", unwrap lines, repair attribution and
rearrange citation. If NODISPLAY is non-nil, don't redisplay the
article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
;; apply treatment of dumb quotes
(gnus-article-treat-smartquotes)
;; repair wrapped cited lines
@@ -471,7 +467,7 @@ article buffer."
;;;###autoload
(defun gnus-article-outlook-deuglify-article ()
"Deuglify broken Outlook (Express) articles and redisplay."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-outlook-deuglify-article nil))
(provide 'deuglify)
diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el
index 62fcf2f2540..bcf8dd014bc 100644
--- a/lisp/gnus/gmm-utils.el
+++ b/lisp/gnus/gmm-utils.el
@@ -1,4 +1,4 @@
-;;; gmm-utils.el --- Utility functions for Gnus, Message and MML
+;;; gmm-utils.el --- Utility functions for Gnus, Message and MML -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -42,8 +42,7 @@ The higher the number, the more messages will flash to say what
it did. At zero, it will be totally mute; at five, it will
display most important messages; and at ten, it will keep on
jabbering all the time."
- :type 'integer
- :group 'gmm)
+ :type 'integer)
;;;###autoload
(defun gmm-regexp-concat (regexp)
@@ -69,18 +68,18 @@ Guideline for numbers:
7 - not very important messages on stuff
9 - messages inside loops."
(if (<= level gmm-verbose)
- (apply 'message args)
+ (apply #'message args)
;; 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)))
+ (apply #'format args)))
;;;###autoload
(defun gmm-error (level &rest args)
"Beep an error if LEVEL is equal to or less than `gmm-verbose'.
ARGS are passed to `message'."
(when (<= (floor level) gmm-verbose)
- (apply 'message args)
+ (apply #'message args)
(ding)
(let (duration)
(when (and (floatp level)
@@ -168,15 +167,14 @@ ARGS are passed to `message'."
(defcustom gmm-tool-bar-style
(if (and (boundp 'tool-bar-mode)
tool-bar-mode
- (memq (display-visual-class)
- (list 'static-gray 'gray-scale
- 'static-color 'pseudo-color)))
+ (not (memq (display-visual-class)
+ (list 'static-gray 'gray-scale
+ 'static-color 'pseudo-color))))
'gnome
'retro)
"Preferred tool bar style."
:type '(choice (const :tag "GNOME style" gnome)
- (const :tag "Retro look" retro))
- :group 'gmm)
+ (const :tag "Retro look" retro)))
(defvar tool-bar-map)
@@ -215,25 +213,25 @@ DEFAULT-MAP specifies the default key map for ICON-LIST."
;; The dummy `gmm-ignore', see `gmm-tool-bar-item'
;; widget. Suppress tooltip by adding `:enable nil'.
(if (fboundp 'tool-bar-local-item)
- (apply 'tool-bar-local-item icon nil nil
+ (apply #'tool-bar-local-item icon nil nil
map :enable nil props)
;; (tool-bar-local-item ICON DEF KEY MAP &rest PROPS)
;; (tool-bar-add-item ICON DEF KEY &rest PROPS)
- (apply 'tool-bar-add-item icon nil nil :enable nil props)))
+ (apply #'tool-bar-add-item icon nil nil :enable nil props)))
((equal fmap t) ;; Not a menu command
- (apply 'tool-bar-local-item
+ (apply #'tool-bar-local-item
icon command
(intern icon) ;; reuse icon or fmap here?
map props))
(t ;; A menu command
- (apply '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 map (symbol-value fmap)
props)))
t))
(if (symbolp icon-list)
- (eval icon-list)
+ (symbol-value icon-list)
icon-list))
map))
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index d7211a4f016..cbe3505cd10 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -1,4 +1,4 @@
-;;; gnus-agent.el --- unplugged support for Gnus
+;;; gnus-agent.el --- unplugged support for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -248,9 +248,9 @@ Actually a hash table holding subjects mapped to t.")
(gnus-agent-read-servers)
(gnus-category-read)
(gnus-agent-create-buffer)
- (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
- (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
- (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
+ (add-hook 'gnus-group-mode-hook #'gnus-agent-mode)
+ (add-hook 'gnus-summary-mode-hook #'gnus-agent-mode)
+ (add-hook 'gnus-server-mode-hook #'gnus-agent-mode))
(defun gnus-agent-create-buffer ()
(if (gnus-buffer-live-p gnus-agent-overview-buffer)
@@ -422,15 +422,13 @@ manipulated as follows:
(defmacro gnus-agent-with-fetch (&rest forms)
"Do FORMS safely."
+ (declare (indent 0) (debug t))
`(unwind-protect
(let ((gnus-agent-fetching t))
(gnus-agent-start-fetch)
,@forms)
(gnus-agent-stop-fetch)))
-(put 'gnus-agent-with-fetch 'lisp-indent-function 0)
-(put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
-
(defmacro gnus-agent-append-to-list (tail value)
`(setq ,tail (setcdr ,tail (cons ,value nil))))
@@ -454,7 +452,7 @@ manipulated as follows:
(symbol-name major-mode))
(match-string 1 (symbol-name major-mode))))
(mode (intern (format "gnus-agent-%s-mode" buffer))))
- (set (make-local-variable 'gnus-agent-mode) t)
+ (setq-local gnus-agent-mode t)
(set mode nil)
(set (make-local-variable mode) t)
;; Set up the menu.
@@ -573,14 +571,12 @@ manipulated as follows:
(set-buffer-modified-p t))
(defmacro gnus-agent-while-plugged (&rest body)
+ (declare (indent 0) (debug t))
`(let ((original-gnus-plugged gnus-plugged))
- (unwind-protect
- (progn (gnus-agent-toggle-plugged t)
- ,@body)
- (gnus-agent-toggle-plugged original-gnus-plugged))))
-
-(put 'gnus-agent-while-plugged 'lisp-indent-function 0)
-(put 'gnus-agent-while-plugged 'edebug-form-spec '(body))
+ (unwind-protect
+ (progn (gnus-agent-toggle-plugged t)
+ ,@body)
+ (gnus-agent-toggle-plugged original-gnus-plugged))))
(defun gnus-agent-close-connections ()
"Close all methods covered by the Gnus agent."
@@ -603,11 +599,22 @@ manipulated as follows:
(gnus))
;;;###autoload
+(defun gnus-child-unplugged (&optional arg)
+ "Read news as a child unplugged."
+ (interactive "P")
+ (setq gnus-plugged nil)
+ (gnus arg nil 'child))
+
+;;;###autoload
(defun gnus-slave-unplugged (&optional arg)
- "Read news as a slave unplugged."
+ "Read news as a child unplugged."
(interactive "P")
(setq gnus-plugged nil)
- (gnus arg nil 'slave))
+ (gnus arg nil 'child))
+(make-obsolete 'gnus-slave-unplugged 'gnus-child-unplugged "28.1")
+
+
+
;;;###autoload
(defun gnus-agentize ()
@@ -694,7 +701,7 @@ be a select method."
(message-narrow-to-headers)
(let* ((gcc (mail-fetch-field "gcc" nil t))
(methods (and gcc
- (mapcar 'gnus-inews-group-method
+ (mapcar #'gnus-inews-group-method
(message-unquote-tokens
(message-tokenize-header
gcc " ,")))))
@@ -728,7 +735,7 @@ be a select method."
(interactive "P")
(unless gnus-plugged
(error "Groups can't be fetched when Gnus is unplugged"))
- (gnus-group-iterate n 'gnus-agent-fetch-group))
+ (gnus-group-iterate n #'gnus-agent-fetch-group))
(defun gnus-agent-fetch-group (&optional group)
"Put all new articles in GROUP into the Agent."
@@ -799,7 +806,7 @@ be a select method."
(let ((gnus-command-method method)
(gnus-agent nil))
(when (file-exists-p (gnus-agent-lib-file "flags"))
- (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
+ (set-buffer (gnus-get-buffer-create " *Gnus Agent flag synchronize*"))
(erase-buffer)
(nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
(cond ((null gnus-plugged)
@@ -813,7 +820,7 @@ be a select method."
(condition-case err
(while t
(let ((bgn (point)))
- (eval (read (current-buffer)))
+ (eval (read (current-buffer)) t)
(delete-region bgn (point))))
(end-of-file
(delete-file (gnus-agent-lib-file "flags")))
@@ -1045,12 +1052,13 @@ article's mark is toggled."
(defun gnus-agent-get-undownloaded-list ()
"Construct list of articles that have not been downloaded."
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
- (when (set (make-local-variable 'gnus-newsgroup-agentized)
- (gnus-agent-method-p gnus-command-method))
+ (when (setq-local gnus-newsgroup-agentized
+ (gnus-agent-method-p gnus-command-method))
(let* ((alist (gnus-agent-load-alist gnus-newsgroup-name))
(headers (sort (mapcar (lambda (h)
(mail-header-number h))
- gnus-newsgroup-headers) '<))
+ gnus-newsgroup-headers)
+ #'<))
(cached (and gnus-use-cache gnus-newsgroup-cached))
(undownloaded (list nil))
(tail-undownloaded undownloaded)
@@ -1121,7 +1129,7 @@ downloadable."
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
(let* ((dl gnus-newsgroup-downloadable)
- (processable (sort (copy-tree gnus-newsgroup-processable) '<))
+ (processable (sort (copy-tree gnus-newsgroup-processable) #'<))
(gnus-newsgroup-downloadable processable))
(gnus-agent-summary-fetch-group)
@@ -1293,7 +1301,7 @@ downloaded into the agent."
;; gnus doesn't waste resources trying to fetch them.
;; NOTE: I don't do this for smaller gaps (< 100) as I don't
- ;; want to modify the local file everytime someone restarts
+ ;; want to modify the local file every time someone restarts
;; gnus. The small gap will cause a tiny performance hit
;; when gnus tries, and fails, to retrieve the articles.
;; Still that should be smaller than opening a buffer,
@@ -1429,7 +1437,7 @@ downloaded into the agent."
(let ((file (gnus-agent-lib-file "history")))
(when (file-exists-p file)
(nnheader-insert-file-contents file))
- (set (make-local-variable 'gnus-agent-file-name) file))))
+ (setq-local gnus-agent-file-name file))))
(defun gnus-agent-close-history ()
(when (gnus-buffer-live-p gnus-agent-current-history)
@@ -1813,7 +1821,7 @@ article numbers will be returned."
(dolist (arts (gnus-info-marks (gnus-get-info group)))
(unless (memq (car arts) '(seen recent killed cache))
(setq articles (gnus-range-add articles (cdr arts)))))
- (setq articles (sort (gnus-uncompress-sequence articles) '<)))
+ (setq articles (sort (gnus-uncompress-sequence articles) #'<)))
;; At this point, I have the list of articles to consider for
;; fetching. This is the list that I'll return to my caller. Some
@@ -1890,7 +1898,8 @@ article numbers will be returned."
articles))
(defsubst gnus-agent-read-article-number ()
- "Reads the article number at point. Returns nil when a valid article number can not be read."
+ "Read the article number at point.
+Return nil when a valid article number can not be read."
(when (looking-at "[0-9]+\t")
(read (current-buffer))))
@@ -2058,7 +2067,7 @@ doesn't exist, to valid the overview buffer."
alist (cdr alist))
(while sequence
(push (cons (pop sequence) state) uncomp)))
- (setq alist (sort uncomp 'car-less-than-car)))
+ (setq alist (sort uncomp #'car-less-than-car)))
(setq changed-version (not (= 2 gnus-agent-article-alist-save-format)))))
(when changed-version
(let ((gnus-agent-article-alist alist))
@@ -2400,13 +2409,13 @@ modified) original contents, they are first saved to their own file."
(setq marked-articles (nconc (gnus-uncompress-range arts)
marked-articles))
))))
- (setq marked-articles (sort marked-articles '<))
+ (setq marked-articles (sort marked-articles #'<))
;; Fetch any new articles from the server
(setq articles (gnus-agent-fetch-headers group))
;; Merge new articles with marked
- (setq articles (sort (append marked-articles articles) '<))
+ (setq articles (sort (append marked-articles articles) #'<))
(when articles
;; Parse them and see which articles we want to fetch.
@@ -2657,7 +2666,7 @@ The following commands are available:
(point)
(prog1 (1+ (point))
;; Insert the text.
- (eval gnus-category-line-format-spec))
+ (eval gnus-category-line-format-spec t))
(list 'gnus-category gnus-tmp-name))))
(defun gnus-enter-category-buffer ()
@@ -2767,16 +2776,15 @@ The following commands are available:
(gnus-edit-form
(gnus-agent-cat-predicate info)
(format "Editing the select predicate for category %s" category)
- `(lambda (predicate)
- ;; Avoid run-time execution of setf form
- ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist))
- ;; predicate)
- ;; use its expansion instead:
- (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
- 'agent-predicate predicate)
-
- (gnus-category-write)
- (gnus-category-list)))))
+ (lambda (predicate)
+ ;; Avoid run-time execution of setf form
+ ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist))
+ ;; predicate)
+ ;; use its expansion instead:
+ (gnus-agent-cat-set-property (assq category gnus-category-alist)
+ 'agent-predicate predicate)
+ (gnus-category-write)
+ (gnus-category-list)))))
(defun gnus-category-edit-score (category)
"Edit the score expression for CATEGORY."
@@ -2785,16 +2793,15 @@ The following commands are available:
(gnus-edit-form
(gnus-agent-cat-score-file info)
(format "Editing the score expression for category %s" category)
- `(lambda (score-file)
- ;; Avoid run-time execution of setf form
- ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist))
- ;; score-file)
- ;; use its expansion instead:
- (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
- 'agent-score-file score-file)
-
- (gnus-category-write)
- (gnus-category-list)))))
+ (lambda (score-file)
+ ;; Avoid run-time execution of setf form
+ ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist))
+ ;; score-file)
+ ;; use its expansion instead:
+ (gnus-agent-cat-set-property (assq category gnus-category-alist)
+ 'agent-score-file score-file)
+ (gnus-category-write)
+ (gnus-category-list)))))
(defun gnus-category-edit-groups (category)
"Edit the group list for CATEGORY."
@@ -2803,16 +2810,15 @@ The following commands are available:
(gnus-edit-form
(gnus-agent-cat-groups info)
(format "Editing the group list for category %s" category)
- `(lambda (groups)
- ;; Avoid run-time execution of setf form
- ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist))
- ;; groups)
- ;; use its expansion instead:
- (gnus-agent-set-cat-groups (assq ',category gnus-category-alist)
- groups)
-
- (gnus-category-write)
- (gnus-category-list)))))
+ (lambda (groups)
+ ;; Avoid run-time execution of setf form
+ ;; (setf (gnus-agent-cat-groups (assq category gnus-category-alist))
+ ;; groups)
+ ;; use its expansion instead:
+ (gnus-agent-set-cat-groups (assq category gnus-category-alist)
+ groups)
+ (gnus-category-write)
+ (gnus-category-list)))))
(defun gnus-category-kill (category)
"Kill the current category."
@@ -3119,7 +3125,7 @@ FORCE is equivalent to setting the expiration predicates to true."
(gnus-uncompress-range
(cons (caar alist)
(caar (last alist))))
- (sort articles '<)))))
+ (sort articles #'<)))))
(marked ;; More articles that are excluded from the
;; expiration process
(cond (gnus-agent-expire-all
@@ -3556,22 +3562,21 @@ articles in every agentized group? "))
(let* (delete-recursive
files f
(delete-recursive
- (function
- (lambda (f-or-d)
- (ignore-errors
- (if (file-directory-p f-or-d)
- (condition-case nil
- (delete-directory f-or-d)
- (file-error
- (setq files (directory-files f-or-d))
- (while files
- (setq f (pop files))
- (or (member f '("." ".."))
- (funcall delete-recursive
- (nnheader-concat
- f-or-d f))))
- (delete-directory f-or-d)))
- (delete-file f-or-d)))))))
+ (lambda (f-or-d)
+ (ignore-errors
+ (if (file-directory-p f-or-d)
+ (condition-case nil
+ (delete-directory f-or-d)
+ (file-error
+ (setq files (directory-files f-or-d))
+ (while files
+ (setq f (pop files))
+ (or (member f '("." ".."))
+ (funcall delete-recursive
+ (nnheader-concat
+ f-or-d f))))
+ (delete-directory f-or-d)))
+ (delete-file f-or-d))))))
(funcall delete-recursive dir)))))))))
;;;###autoload
@@ -3852,7 +3857,7 @@ If REREAD is not nil, downloaded articles are marked as unread."
(string-to-number name)))
(directory-files
dir nil "\\`[0-9]+\\'" t)))
- '>)
+ #'>)
(progn (gnus-make-directory dir) nil)))
nov-arts
alist header
@@ -3923,7 +3928,7 @@ If REREAD is not nil, downloaded articles are marked as unread."
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(nnheader-remove-body)
- (setq header (nnheader-parse-naked-head)))
+ (setq header (nnheader-parse-head t)))
(setf (mail-header-number header) (car downloaded))
(if nov-arts
(let ((key (concat "^" (int-to-string (car nov-arts))
@@ -4022,11 +4027,11 @@ If REREAD is not nil, downloaded articles are marked as unread."
(list (list
(if (listp reread)
reread
- (delq nil (mapcar (function (lambda (c)
- (cond ((eq reread t)
- (car c))
- ((cdr c)
- (car c)))))
+ (delq nil (mapcar (lambda (c)
+ (cond ((eq reread t)
+ (car c))
+ ((cdr c)
+ (car c))))
gnus-agent-article-alist)))
'del '(read)))
gnus-command-method)
@@ -4156,7 +4161,7 @@ modified."
(path (gnus-agent-group-pathname group))
(entry (gethash path gnus-agent-total-fetched-hashtb)))
(if entry
- (apply '+ entry)
+ (apply #'+ entry)
(let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
(+
(gnus-agent-update-view-total-fetched-for group nil method path)
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 4d069bbbf70..fb0295d0703 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1,4 +1,4 @@
-;;; gnus-art.el --- article mode commands for Gnus
+;;; gnus-art.el --- article mode commands for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -170,12 +170,17 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored."
"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."
- :type '(choice
- (repeat :value-to-internal (lambda (widget value)
- (custom-split-regexp-maybe value))
- :match (lambda (widget value)
- (or (stringp value)
- (widget-editable-list-match widget value)))
+ :type `(choice
+ (repeat :value-to-internal
+ ,(lambda (_widget value)
+ ;; FIXME: Are we sure this can't be used without
+ ;; loading cus-edit?
+ (declare-function custom-split-regexp-maybe
+ "cus-edit" (regexp))
+ (custom-split-regexp-maybe value))
+ :match ,(lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
regexp)
(const :tag "Use gnus-ignored-headers" nil)
regexp)
@@ -274,6 +279,7 @@ This can also be a list of the above values."
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type '(choice string
+ (const :tag "None" nil)
(function-item gnus-display-x-face-in-from)
function)
:version "27.1"
@@ -288,7 +294,9 @@ asynchronously. The compressed face will be piped to this command."
(defcustom gnus-article-banner-alist nil
"Banner alist for stripping.
For example,
- ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
+ ((egroups . (concat \"^[ \\t\\n]*-------------------+\\\\\"
+ \"( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?\"
+ \"....\\n\\\\(.+\\n\\\\)+\")))"
:version "21.1"
:type '(repeat (cons symbol regexp))
:group 'gnus-article-washing)
@@ -399,14 +407,14 @@ the entire emphasized word. The third is a number that says what
regexp grouping should be displayed and highlighted. The fourth
is the face used for highlighting."
:type
- '(repeat
+ `(repeat
(menu-choice
:format "%[Customizing Style%]\n%v"
:indent 2
(group :tag "Default"
:value ("" 0 0 default)
:value-create
- (lambda (widget)
+ ,(lambda (widget)
(let ((value (widget-get
(cadr (widget-get (widget-get widget :parent)
:args))
@@ -534,6 +542,13 @@ that the symbol of the saver function, which is specified by
:group 'gnus-article-saving
:type 'regexp)
+(defcustom gnus-global-groups nil
+ "Groups that should be considered like \"news\" groups.
+This means that images will be automatically loaded, for instance."
+ :type '(repeat string)
+ :version "28.1"
+ :group 'gnus-article)
+
;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
"A function to save articles in your favorite format.
@@ -718,9 +733,6 @@ Each element is a regular expression."
:type '(repeat regexp)
:group 'gnus-article-various)
-(make-obsolete-variable 'gnus-article-hide-pgp-hook nil
- "Gnus 5.10 (Emacs 22.1)")
-
(defface gnus-button
'((t (:weight bold)))
"Face used for highlighting a button in the article buffer."
@@ -964,7 +976,7 @@ see http://www.cs.indiana.edu/picons/ftp/index.html"
:version "22.1"
:type '(repeat directory)
:link '(url-link :tag "download"
- "http://www.cs.indiana.edu/picons/ftp/index.html")
+ "http://www.cs.indiana.edu/picons/ftp/index.html")
:link '(custom-manual "(gnus)Picons")
:group 'gnus-picon)
@@ -1051,7 +1063,7 @@ used."
("view the part" . gnus-mime-view-part)
("pipe to command" . gnus-mime-pipe-part)
("toggle display" . gnus-article-press-button)
- ("toggle display" . gnus-article-view-part-as-charset)
+ ("view as charset" . gnus-mime-view-part-as-charset)
("view as type" . gnus-mime-view-part-as-type)
("view internally" . gnus-mime-view-part-internally)
("view externally" . gnus-mime-view-part-externally))
@@ -1254,9 +1266,6 @@ 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)")
-
(defcustom gnus-treat-strip-pem nil
"Strip PEM signatures.
Valid values are nil, t, `head', `first', `last', an integer or a
@@ -1386,9 +1395,6 @@ predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(make-obsolete-variable 'gnus-treat-display-xface
- 'gnus-treat-display-x-face "Emacs 22.1")
-
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
(gnus-image-type-available-p 'xbm)
@@ -1413,17 +1419,7 @@ See Info node `(gnus)Customizing Articles' and Info node
symbol
(cond ((or (boundp symbol) (get symbol 'saved-value))
value)
- ((boundp 'gnus-treat-display-xface)
- (message "\
-** gnus-treat-display-xface is an obsolete variable;\
- use gnus-treat-display-x-face instead")
- (default-value 'gnus-treat-display-xface))
- ((get 'gnus-treat-display-xface 'saved-value)
- (message "\
-** gnus-treat-display-xface is an obsolete variable;\
- use gnus-treat-display-x-face instead")
- (eval (car (get 'gnus-treat-display-xface 'saved-value))))
- (t
+ (t
value)))))
(put 'gnus-treat-display-x-face 'highlight t)
@@ -1613,7 +1609,7 @@ It is a string, such as \"PGP\". If nil, ask user."
:group 'gnus-article
:type 'boolean)
-(defcustom gnus-blocked-images 'gnus-block-private-groups
+(defcustom gnus-blocked-images #'gnus-block-private-groups
"Images that have URLs matching this regexp will be blocked.
Note that the main reason external images are included in HTML
emails (these days) is to allow tracking whether you've read the
@@ -1728,6 +1724,7 @@ Initialized from `text-mode-syntax-table'.")
;;; Macros for dealing with the article buffer.
(defmacro gnus-with-article-headers (&rest forms)
+ (declare (indent 0) (debug t))
`(with-current-buffer gnus-article-buffer
(save-restriction
(let ((inhibit-read-only t)
@@ -1736,18 +1733,13 @@ Initialized from `text-mode-syntax-table'.")
(article-narrow-to-head)
,@forms))))
-(put 'gnus-with-article-headers 'lisp-indent-function 0)
-(put 'gnus-with-article-headers 'edebug-form-spec '(body))
-
(defmacro gnus-with-article-buffer (&rest forms)
+ (declare (indent 0) (debug t))
`(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))
-
(defun gnus-article-goto-header (header)
"Go to HEADER, which is a regular expression."
(re-search-forward (concat "^\\(" header "\\):") nil t))
@@ -1817,7 +1809,7 @@ Initialized from `text-mode-syntax-table'.")
(defun article-hide-headers (&optional _arg _delete)
"Hide unwanted headers and possibly sort them as well."
- (interactive)
+ (interactive nil gnus-article-mode)
;; This function might be inhibited.
(unless gnus-inhibit-hiding
(let ((inhibit-read-only t)
@@ -1885,7 +1877,7 @@ Initialized from `text-mode-syntax-table'.")
"Toggle hiding of headers that aren't very interesting.
If given a negative prefix, always show; if given a positive prefix,
always hide."
- (interactive (gnus-article-hidden-arg))
+ (interactive (gnus-article-hidden-arg) gnus-article-mode)
(when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
(not gnus-show-all-headers))
(save-excursion
@@ -2044,7 +2036,7 @@ always hide."
(defun article-normalize-headers ()
"Make all header lines 40 characters long."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((inhibit-read-only t)
column)
(save-excursion
@@ -2080,7 +2072,7 @@ iso-8859-1 character map in an attempt to provide more quoting
characters. If you see something like \\222 or \\264 where
you're expecting some kind of apostrophe or quotation mark, then
try this wash."
- (interactive)
+ (interactive nil gnus-article-mode)
(article-translate-strings gnus-article-smartquotes-map))
(define-obsolete-function-alias 'article-treat-dumbquotes
#'article-treat-smartquotes "27.1")
@@ -2089,7 +2081,7 @@ try this wash."
(defun article-treat-non-ascii ()
"Translate many Unicode characters into their ASCII equivalents."
- (interactive)
+ (interactive nil gnus-article-mode)
(require 'org-entities)
(let ((table (make-char-table nil)))
(dolist (elem org-entities)
@@ -2132,7 +2124,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")."
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(when (article-goto-body)
(let ((inhibit-read-only t))
@@ -2156,19 +2148,23 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")."
(put-text-property
(point) (1+ (point)) 'face 'underline)))))))))
+(defvar ansi-color-context-region)
+
(defun article-treat-ansi-sequences ()
"Translate ANSI SGR control sequences into overlays or extents."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(when (article-goto-body)
- (let ((inhibit-read-only t))
+ (require 'ansi-color)
+ (let ((inhibit-read-only t)
+ (ansi-color-context-region nil))
(ansi-color-apply-on-region (point) (point-max))))))
(defun gnus-article-treat-unfold-headers ()
"Unfold folded message headers.
Only the headers that fit into the current window width will be
unfolded."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(let (length)
(while (not (eobp))
@@ -2194,7 +2190,7 @@ unfolded."
(defun gnus-article-treat-fold-headers ()
"Fold message headers."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(while (not (eobp))
(save-restriction
@@ -2204,7 +2200,7 @@ unfolded."
(defun gnus-treat-smiley ()
"Toggle display of textual emoticons (\"smileys\") as small graphical icons."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(if (memq 'smiley gnus-article-wash-types)
(gnus-delete-images 'smiley)
@@ -2217,7 +2213,7 @@ unfolded."
(defun gnus-article-remove-images ()
"Remove all images from the article buffer."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(save-restriction
(widen)
@@ -2229,7 +2225,11 @@ unfolded."
(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)
+ (interactive nil gnus-article-mode gnus-summary-mode)
+ ;; Reselect for image display.
+ (let ((gnus-blocked-images nil)
+ (gnus-inhibit-images nil))
+ (gnus-summary-select-article))
(gnus-with-article-buffer
(save-restriction
(widen)
@@ -2245,7 +2245,7 @@ This only works if the article in question is HTML."
(defun gnus-article-treat-fold-newsgroups ()
"Fold the Newsgroups and Followup-To message headers."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(while (gnus-article-goto-header "newsgroups\\|followup-to")
(save-restriction
@@ -2269,7 +2269,7 @@ predicate. See Info node `(gnus)Customizing Articles'."
If ARG is non-nil and not a number, toggle
`gnus-article-truncate-lines' too. If ARG is a number, truncate
long lines if and only if arg is positive."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(cond
((and (numberp arg) (> arg 0))
(setq gnus-article-truncate-lines t))
@@ -2288,7 +2288,7 @@ long lines if and only if arg is positive."
(defun gnus-article-treat-body-boundary ()
"Place a boundary line at the end of the headers."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(when (and gnus-body-boundary-delimiter
(> (length gnus-body-boundary-delimiter) 0))
(gnus-with-article-headers
@@ -2303,21 +2303,27 @@ long lines if and only if arg is positive."
"\n")
(put-text-property start (point) 'gnus-decoration 'header)))))
-(defun article-fill-long-lines ()
- "Fill lines that are wider than the window width."
- (interactive)
+(defun article-fill-long-lines (&optional width)
+ "Fill lines that are wider than the window width or `fill-column'.
+If WIDTH (interactively, the numeric prefix), use that as the
+fill width."
+ (interactive "P" gnus-article-mode)
(save-excursion
- (let ((inhibit-read-only t)
- (width (window-width (get-buffer-window (current-buffer)))))
+ (let* ((inhibit-read-only t)
+ (window-width (window-width (get-buffer-window (current-buffer))))
+ (width (if width
+ (prefix-numeric-value width)
+ (min fill-column window-width))))
(save-restriction
(article-goto-body)
(let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
- (when (>= (current-column) (min fill-column width))
+ (when (>= (current-column) width)
(narrow-to-region (min (1+ (point)) (point-max))
(point-at-bol))
- (let ((goback (point-marker)))
+ (let ((goback (point-marker))
+ (fill-column width))
(fill-paragraph nil)
(goto-char (marker-position goback)))
(widen))
@@ -2325,7 +2331,7 @@ long lines if and only if arg is positive."
(defun article-capitalize-sentences ()
"Capitalize the first word in each sentence."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t)
(paragraph-start "^[\n\^L]"))
@@ -2336,7 +2342,7 @@ long lines if and only if arg is positive."
(defun article-remove-cr ()
"Remove trailing CRs and then translate remaining CRs into LFs."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t))
(goto-char (point-min))
@@ -2348,7 +2354,7 @@ long lines if and only if arg is positive."
(defun article-remove-trailing-blank-lines ()
"Remove all trailing blank lines from the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t))
(goto-char (point-max))
@@ -2367,7 +2373,7 @@ long lines if and only if arg is positive."
(defun article-display-face (&optional force)
"Display any Face headers in the header."
- (interactive (list 'force))
+ (interactive (list 'force) gnus-article-mode gnus-summary-mode)
(let ((wash-face-p buffer-read-only))
(gnus-with-article-headers
;; When displaying parts, this function can be called several times on
@@ -2415,7 +2421,7 @@ long lines if and only if arg is positive."
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
- (interactive (list 'force))
+ (interactive (list 'force) gnus-article-mode gnus-summary-mode)
(let ((wash-face-p buffer-read-only)) ;; When type `W f'
(gnus-with-article-headers
;; Delete the old process, if any.
@@ -2477,7 +2483,7 @@ long lines if and only if arg is positive."
(defun article-decode-mime-words ()
"Decode all MIME-encoded words in the article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
(mail-parse-charset gnus-newsgroup-charset)
@@ -2489,7 +2495,7 @@ long lines if and only if arg is positive."
(defun article-decode-charset (&optional prompt)
"Decode charset-encoded text in the article.
If PROMPT (the prefix), prompt for a coding system to use."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(let ((inhibit-point-motion-hooks t) (case-fold-search t)
(inhibit-read-only t)
(mail-parse-charset gnus-newsgroup-charset)
@@ -2611,7 +2617,7 @@ Mail-Reply-To: and Mail-Followup-To:."
If FORCE, decode the article whether it is marked as quoted-printable
or not.
If READ-CHARSET, ask for a coding system."
- (interactive (list 'force current-prefix-arg))
+ (interactive (list 'force current-prefix-arg) gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
@@ -2639,7 +2645,7 @@ If READ-CHARSET, ask for a coding system."
"Translate a base64 article.
If FORCE, decode the article whether it is marked as base64 not.
If READ-CHARSET, ask for a coding system."
- (interactive (list 'force current-prefix-arg))
+ (interactive (list 'force current-prefix-arg) gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
@@ -2671,7 +2677,7 @@ If READ-CHARSET, ask for a coding system."
(defun article-decode-HZ ()
"Translate a HZ-encoded article."
- (interactive)
+ (interactive nil gnus-article-mode)
(require 'rfc1843)
(save-excursion
(let ((inhibit-read-only t))
@@ -2679,7 +2685,7 @@ If READ-CHARSET, ask for a coding system."
(defun article-unsplit-urls ()
"Remove the newlines that some other mailers insert into URLs."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-read-only t))
(goto-char (point-min))
@@ -2691,9 +2697,9 @@ If READ-CHARSET, ask for a coding system."
(defun article-wash-html ()
"Format an HTML article."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((handles nil)
- (buffer-read-only nil))
+ (inhibit-read-only t))
(when (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(setq handles (mm-dissect-buffer t t))))
@@ -2879,7 +2885,7 @@ message header will be added to the bodies of the \"text/html\" parts."
(t "<br>\n"))))
(goto-char (point-min))
(while (re-search-forward "^[\t ]+" nil t)
- (dotimes (i (prog1
+ (dotimes (_ (prog1
(current-column)
(delete-region (match-beginning 0)
(match-end 0))))
@@ -2973,7 +2979,7 @@ message header will be added to the bodies of the \"text/html\" parts."
(when tmp-file
(add-to-list 'gnus-article-browse-html-temp-list tmp-file))
(add-hook 'gnus-summary-prepare-exit-hook
- 'gnus-article-browse-delete-temp-files)
+ #'gnus-article-browse-delete-temp-files)
(add-hook 'gnus-exit-gnus-hook
(lambda ()
(gnus-article-browse-delete-temp-files t)))
@@ -2994,8 +3000,7 @@ message header will be added to the bodies of the \"text/html\" parts."
(when header
(article-decode-encoded-words)
(let ((gnus-visible-headers
- (or (get 'gnus-visible-headers 'standard-value)
- gnus-visible-headers)))
+ (custom--standard-value 'gnus-visible-headers)))
(article-hide-headers))
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
@@ -3007,6 +3012,8 @@ message header will be added to the bodies of the \"text/html\" parts."
(setq showed t)))))
showed))
+(defvar gnus-mime-display-attachment-buttons-in-header)
+
(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
@@ -3024,11 +3031,11 @@ 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")
+ (interactive "P" gnus-article-mode)
(if arg
(gnus-summary-show-article)
- (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
- gnus-visible-headers))
+ (let ((gnus-visible-headers
+ (custom--standard-value 'gnus-visible-headers))
(gnus-mime-display-attachment-buttons-in-header nil)
;; As we insert a <hr>, there's no need for the body boundary.
(gnus-treat-body-boundary nil))
@@ -3061,7 +3068,7 @@ images if any to the browser, and deletes them when exiting the group
(defun article-hide-list-identifiers ()
"Remove list identifiers from the Subject header.
The `gnus-list-identifiers' variable specifies what to do."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((inhibit-point-motion-hooks t)
(regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
(inhibit-read-only t))
@@ -3083,7 +3090,7 @@ The `gnus-list-identifiers' variable specifies what to do."
"Toggle hiding of any PEM headers and signatures in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
- (interactive (gnus-article-hidden-arg))
+ (interactive (gnus-article-hidden-arg) gnus-article-mode)
(unless (gnus-article-check-hidden-text 'pem arg)
(save-excursion
(let ((inhibit-read-only t) end)
@@ -3109,7 +3116,7 @@ always hide."
(defun article-strip-banner ()
"Strip the banners specified by the `banner' group parameter and by
`gnus-article-address-banner-alist'."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t))
@@ -3158,7 +3165,7 @@ always hide."
(defun article-babel ()
"Translate article using an online translation service."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(require 'babel)
(gnus-with-article-buffer
(when (article-goto-body)
@@ -3175,7 +3182,7 @@ always hide."
"Hide the signature in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
- (interactive (gnus-article-hidden-arg))
+ (interactive (gnus-article-hidden-arg) gnus-article-mode)
(unless (gnus-article-check-hidden-text 'signature arg)
(save-excursion
(save-restriction
@@ -3187,7 +3194,7 @@ always hide."
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(article-goto-body)
(let ((case-fold-search t))
@@ -3196,7 +3203,7 @@ always hide."
(defun article-strip-leading-blank-lines ()
"Remove all blank lines from the beginning of the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
@@ -3238,7 +3245,7 @@ Point is left at the beginning of the narrowed-to region."
(defun article-strip-multiple-blank-lines ()
"Replace consecutive blank lines with one empty line."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
@@ -3257,7 +3264,7 @@ Point is left at the beginning of the narrowed-to region."
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
@@ -3267,7 +3274,7 @@ Point is left at the beginning of the narrowed-to region."
(defun article-strip-trailing-space ()
"Remove all white space from the end of the lines in the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
@@ -3277,14 +3284,14 @@ Point is left at the beginning of the narrowed-to region."
(defun article-strip-blank-lines ()
"Strip leading, trailing and multiple blank lines."
- (interactive)
+ (interactive nil gnus-article-mode)
(article-strip-leading-blank-lines)
(article-remove-trailing-blank-lines)
(article-strip-multiple-blank-lines))
(defun article-strip-all-blank-lines ()
"Strip all blank lines."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
@@ -3416,7 +3423,7 @@ lines forward."
"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))
+ (interactive (list 'ut t) gnus-article-mode)
(let* ((case-fold-search t)
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
@@ -3660,29 +3667,29 @@ possible values."
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'local highlight))
(defun article-date-english (&optional highlight)
"Convert the current article date to something that is proper English."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'english highlight))
(defun article-date-original (&optional highlight)
"Convert the current article date to what it was originally.
This is only useful if you have used some other date conversion
function and want to see what the date was before converting."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'original highlight))
(defun article-date-lapsed (&optional highlight)
"Convert the current article date to time lapsed since it was sent."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(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))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'combined-lapsed highlight))
(defun article-update-date-lapsed ()
@@ -3731,16 +3738,16 @@ function and want to see what the date was before converting."
"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")
+ (interactive "p" gnus-article-mode)
(unless n
(setq n 1))
(gnus-stop-date-timer)
(setq article-lapsed-timer
- (run-at-time 1 n 'article-update-date-lapsed)))
+ (run-at-time 1 n #'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
"Stop the Date timer."
- (interactive)
+ (interactive nil gnus-article-mode)
(when article-lapsed-timer
(cancel-timer article-lapsed-timer)
(setq article-lapsed-timer nil)))
@@ -3748,12 +3755,12 @@ is to run."
(defun article-date-user (&optional highlight)
"Convert the current article date to the user-defined format.
This format is defined by the `gnus-article-time-format' variable."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'user-defined highlight))
(defun article-date-iso8601 (&optional highlight)
"Convert the current article date to ISO8601."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode)
(article-date-ut 'iso8601 highlight))
(defmacro gnus-article-save-original-date (&rest forms)
@@ -3786,7 +3793,7 @@ This format is defined by the `gnus-article-time-format' variable."
(defun article-remove-leading-whitespace ()
"Remove excessive whitespace from all headers."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(save-restriction
(let ((inhibit-read-only t))
@@ -3797,7 +3804,7 @@ This format is defined by the `gnus-article-time-format' variable."
(defun article-emphasize (&optional arg)
"Emphasize text according to `gnus-emphasis-alist'."
- (interactive (gnus-article-hidden-arg))
+ (interactive (gnus-article-hidden-arg) gnus-article-mode)
(unless (gnus-article-check-hidden-text 'emphasis arg)
(save-excursion
(let ((alist (or
@@ -3834,8 +3841,7 @@ This format is defined by the `gnus-article-time-format' variable."
(unless gnus-article-emphasis-alist
(let ((name (and gnus-newsgroup-name
(gnus-group-real-name gnus-newsgroup-name))))
- (make-local-variable 'gnus-article-emphasis-alist)
- (setq gnus-article-emphasis-alist
+ (setq-local gnus-article-emphasis-alist
(nconc
(let ((alist gnus-group-highlight-words-alist) elem highlight)
(while (setq elem (pop alist))
@@ -4231,7 +4237,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(defun article-verify-x-pgp-sig ()
"Verify X-PGP-Sig."
;; <https://ftp.isc.org/pub/pgpcontrol/FORMAT>
- (interactive)
+ (interactive nil gnus-article-mode)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(let ((sig (with-current-buffer gnus-original-article-buffer
(gnus-fetch-field "X-PGP-Sig")))
@@ -4305,78 +4311,69 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(defun article-verify-cancel-lock ()
"Verify Cancel-Lock header."
- (interactive)
+ (interactive nil gnus-article-mode)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(canlock-verify gnus-original-article-buffer)))
-(eval-and-compile
- (mapc
- (lambda (func)
- (let (afunc gfunc)
- (if (consp func)
- (setq afunc (car func)
- gfunc (cdr func))
- (setq afunc func
- gfunc (intern (format "gnus-%s" func))))
- (defalias gfunc
- (when (fboundp afunc)
- `(lambda (&optional interactive &rest args)
- ,(documentation afunc t)
- (interactive (list t))
- (with-current-buffer gnus-article-buffer
- (if interactive
- (call-interactively ',afunc)
- (apply #',afunc args))))))))
- '(article-hide-headers
- article-verify-x-pgp-sig
- article-verify-cancel-lock
- article-hide-boring-headers
- article-treat-overstrike
- article-treat-ansi-sequences
- article-fill-long-lines
- article-capitalize-sentences
- article-remove-cr
- article-remove-leading-whitespace
- article-display-x-face
- article-display-face
- article-de-quoted-unreadable
- article-de-base64-unreadable
- article-decode-HZ
- article-wash-html
- article-unsplit-urls
- article-hide-list-identifiers
- article-strip-banner
- article-babel
- article-hide-pem
- article-hide-signature
- article-strip-headers-in-body
- article-remove-trailing-blank-lines
- article-strip-leading-blank-lines
- article-strip-multiple-blank-lines
- article-strip-leading-space
- article-strip-trailing-space
- article-strip-blank-lines
- article-strip-all-blank-lines
- article-date-local
- 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-smartquotes
- ;; Obsolete alias.
- article-treat-dumbquotes
- article-treat-non-ascii
- article-normalize-headers)))
+(gnus--\,@
+ (mapcar (lambda (func)
+ `(defun ,(intern (format "gnus-%s" func))
+ (&optional interactive &rest args)
+ ,(format "Run `%s' in the article buffer." func)
+ (interactive (list t) gnus-article-mode gnus-summary-mode)
+ (with-current-buffer gnus-article-buffer
+ (if interactive
+ (call-interactively #',func)
+ (apply #',func args)))))
+ '(article-hide-headers
+ article-verify-x-pgp-sig
+ article-verify-cancel-lock
+ article-hide-boring-headers
+ article-treat-overstrike
+ article-treat-ansi-sequences
+ article-fill-long-lines
+ article-capitalize-sentences
+ article-remove-cr
+ article-remove-leading-whitespace
+ article-display-x-face
+ article-display-face
+ article-de-quoted-unreadable
+ article-de-base64-unreadable
+ article-decode-HZ
+ article-wash-html
+ article-unsplit-urls
+ article-hide-list-identifiers
+ article-strip-banner
+ article-babel
+ article-hide-pem
+ article-hide-signature
+ article-strip-headers-in-body
+ article-remove-trailing-blank-lines
+ article-strip-leading-blank-lines
+ article-strip-multiple-blank-lines
+ article-strip-leading-space
+ article-strip-trailing-space
+ article-strip-blank-lines
+ article-strip-all-blank-lines
+ article-date-local
+ 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-smartquotes
+ ;;article-treat-dumbquotes ;; Obsolete alias.
+ article-treat-non-ascii
+ article-normalize-headers)))
(define-obsolete-function-alias 'gnus-article-treat-dumbquotes
- 'gnus-article-treat-smartquotes "27.1")
+ #'gnus-article-treat-smartquotes "27.1")
;;;
;;; Gnus article mode
@@ -4406,13 +4403,14 @@ If variable `gnus-use-long-file-name' is non-nil, it is
"e" gnus-article-read-summary-keys
"\C-d" gnus-article-read-summary-keys
+ "\C-c\C-f" gnus-summary-mail-forward
"\M-*" gnus-article-read-summary-keys
"\M-#" gnus-article-read-summary-keys
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
(substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+ #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map)
(defvar gnus-article-send-map)
(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
@@ -4478,10 +4476,10 @@ commands:
(when (gnus-visual-p 'article-menu 'menu)
(gnus-article-make-menu-bar)
(when gnus-summary-tool-bar-map
- (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
+ (setq-local tool-bar-map gnus-summary-tool-bar-map)))
(gnus-update-format-specifications nil 'article-mode)
- (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
- (set (make-local-variable 'gnus-page-broken) nil)
+ (setq-local page-delimiter gnus-page-delimiter)
+ (setq-local gnus-page-broken nil)
(make-local-variable 'gnus-article-current-summary)
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
@@ -4490,13 +4488,12 @@ commands:
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
- (set (make-local-variable 'bookmark-make-record-function)
- 'gnus-summary-bookmark-make-record)
+ (setq-local bookmark-make-record-function #'gnus-summary-bookmark-make-record)
;; Prevent Emacs from displaying non-break space with
;; `nobreak-space' face.
- (set (make-local-variable 'nobreak-char-display) nil)
+ (setq-local 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-local shr-put-image-function #'gnus-shr-put-image)
(unless gnus-article-show-cursor
(setq cursor-in-non-selected-windows nil))
(gnus-set-default-directory)
@@ -4540,7 +4537,7 @@ commands:
t)))
(let ((summary gnus-summary-buffer))
(with-current-buffer name
- (set (make-local-variable 'gnus-article-edit-mode) nil)
+ (setq-local gnus-article-edit-mode nil)
(gnus-article-stop-animations)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
@@ -4551,14 +4548,14 @@ commands:
(setq buffer-read-only t)
(unless (derived-mode-p 'gnus-article-mode)
(gnus-article-mode))
- (set (make-local-variable 'gnus-summary-buffer) summary)
+ (setq-local gnus-summary-buffer summary)
(setq truncate-lines gnus-article-truncate-lines)
(current-buffer)))
(let ((summary gnus-summary-buffer))
(with-current-buffer (gnus-get-buffer-create name)
(gnus-article-mode)
(setq truncate-lines gnus-article-truncate-lines)
- (set (make-local-variable 'gnus-summary-buffer) summary)
+ (setq-local gnus-summary-buffer summary)
(gnus-summary-set-local-parameters gnus-newsgroup-name)
(when article-lapsed-timer
(gnus-stop-date-timer))
@@ -4704,8 +4701,6 @@ If ALL-HEADERS is non-nil, no headers are hidden."
(gnus-run-hooks 'gnus-article-prepare-hook)
t))))))
-(defvar gnus-mime-display-attachment-buttons-in-header)
-
;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
@@ -4733,21 +4728,22 @@ If ALL-HEADERS is non-nil, no headers are hidden."
(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
"Mode for sticky articles."
;; Release bindings that won't work.
- (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
+ (substitute-key-definition #'gnus-article-read-summary-keys #'undefined
gnus-sticky-article-mode-map)
- (substitute-key-definition 'gnus-article-refer-article 'undefined
+ (substitute-key-definition #'gnus-article-refer-article #'undefined
gnus-sticky-article-mode-map)
(dolist (k '("e" "h" "s" "F" "R"))
(define-key gnus-sticky-article-mode-map k nil))
- (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
- (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
- (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
- (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
+ (define-key gnus-sticky-article-mode-map "k"
+ #'gnus-kill-sticky-article-buffer)
+ (define-key gnus-sticky-article-mode-map "q" #'bury-buffer)
+ (define-key gnus-sticky-article-mode-map "\C-hc" #'describe-key-briefly)
+ (define-key gnus-sticky-article-mode-map "\C-hk" #'describe-key))
(defun gnus-sticky-article (arg)
"Make the current article sticky.
If a prefix ARG is given, ask for a name for this sticky article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(gnus-summary-show-thread)
(gnus-summary-select-article nil nil 'pseudo)
(let (new-art-buf-name)
@@ -4791,7 +4787,7 @@ If a prefix ARG is given, ask for a name for this sticky article buffer."
"Kill the given sticky article BUFFER.
If none is given, assume the current buffer and kill it if it has
`gnus-sticky-article-mode'."
- (interactive)
+ (interactive nil gnus-article-mode)
(unless buffer
(setq buffer (current-buffer)))
(with-current-buffer buffer
@@ -4801,7 +4797,7 @@ If none is given, assume the current buffer and kill it if it has
(defun gnus-kill-sticky-article-buffers (arg)
"Kill all sticky article buffers.
If a prefix ARG is given, ask for confirmation."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(dolist (buf (gnus-buffers))
(with-current-buffer buf
(and (derived-mode-p 'gnus-sticky-article-mode)
@@ -4873,9 +4869,9 @@ General format specifiers can also be used. See Info node
(defvar gnus-mime-button-map
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'gnus-article-push-button)
- (define-key map [mouse-2] 'gnus-article-push-button)
- (define-key map [down-mouse-3] 'gnus-mime-button-menu)
+ (define-key map "\r" #'gnus-article-push-button)
+ (define-key map [mouse-2] #'gnus-article-push-button)
+ (define-key map [down-mouse-3] #'gnus-mime-button-menu)
(dolist (c gnus-mime-button-commands)
(define-key map (cadr c) (car c)))
map))
@@ -4943,7 +4939,7 @@ General format specifiers can also be used. See Info node
(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
- (interactive)
+ (interactive nil gnus-article-mode)
(with-current-buffer gnus-article-buffer
(let ((handles (or handles gnus-article-mime-handles))
(mail-parse-charset gnus-newsgroup-charset)
@@ -4960,7 +4956,7 @@ General format specifiers can also be used. See Info node
(defun gnus-article-jump-to-part (n)
"Jump to MIME part N."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(let ((parts (with-current-buffer gnus-article-buffer
(length gnus-article-mime-handle-alist))))
(when (zerop parts)
@@ -4992,53 +4988,53 @@ General format specifiers can also be used. See Info node
"ID of a mime part that should be buttonized.
`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.")
+(defvar message-options-set-recipient)
+
(eval-when-compile
(defsubst gnus-article-edit-part (handles &optional current-id)
"Edit an article in order to delete a mime part.
This function is exclusively used by `gnus-mime-save-part-and-strip'
and `gnus-mime-delete-part', and not provided at run-time normally."
- (gnus-article-edit-article
- `(lambda ()
- (buffer-disable-undo)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (mail-parse-ignored-charsets
- (or gnus-article-ignored-charsets
- ',gnus-newsgroup-ignored-charsets))
- (mbl mml-buffer-list))
- (setq mml-buffer-list nil)
- ;; A new text must be inserted before deleting existing ones
- ;; at the end so as not to move existing markers of which
- ;; the insertion type is t.
- (delete-region
- (point-min)
- (prog1
- (goto-char (point-max))
- (insert-buffer-substring gnus-original-article-buffer)))
- (mime-to-mml ',handles)
- (setq gnus-article-mime-handles nil)
- (let ((mbl1 mml-buffer-list))
- (setq mml-buffer-list mbl)
- (set (make-local-variable 'mml-buffer-list) mbl1))
- (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
- `(lambda (no-highlight)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (message-options message-options)
- (message-options-set-recipient)
- (mail-parse-ignored-charsets
- (or gnus-article-ignored-charsets
- ',gnus-newsgroup-ignored-charsets)))
- (mml-to-mime)
- (mml-destroy-buffers)
- (remove-hook 'kill-buffer-hook
- 'mml-destroy-buffers t)
- (kill-local-variable 'mml-buffer-list))
- (gnus-summary-edit-article-done
- ,(or (mail-header-references gnus-current-headers) "")
- ,(gnus-group-read-only-p)
- ,gnus-summary-buffer no-highlight))
- t)
+ (let ((charset gnus-newsgroup-charset)
+ (ign-cs gnus-newsgroup-ignored-charsets)
+ (gch (or (mail-header-references gnus-current-headers) ""))
+ (ro (gnus-group-read-only-p))
+ (buf gnus-summary-buffer))
+ (gnus-article-edit-article
+ (lambda ()
+ (buffer-disable-undo)
+ (let ((mail-parse-charset (or gnus-article-charset charset))
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets ign-cs))
+ (mbl mml-buffer-list))
+ (setq mml-buffer-list nil)
+ ;; A new text must be inserted before deleting existing ones
+ ;; at the end so as not to move existing markers of which
+ ;; the insertion type is t.
+ (delete-region
+ (point-min)
+ (prog1
+ (goto-char (point-max))
+ (insert-buffer-substring gnus-original-article-buffer)))
+ (mime-to-mml handles)
+ (setq gnus-article-mime-handles nil)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl)
+ (setq-local mml-buffer-list mbl1))
+ (add-hook 'kill-buffer-hook #'mml-destroy-buffers t t)))
+ (lambda (no-highlight)
+ (let ((mail-parse-charset (or gnus-article-charset charset))
+ (message-options message-options)
+ (message-options-set-recipient)
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets ign-cs)))
+ (mml-to-mime)
+ (mml-destroy-buffers)
+ (remove-hook 'kill-buffer-hook
+ #'mml-destroy-buffers t)
+ (kill-local-variable 'mml-buffer-list))
+ (gnus-summary-edit-article-done gch ro buf no-highlight))
+ t))
;; Force buttonizing this part.
(let ((gnus-mime-buttonized-part-id current-id))
(gnus-article-edit-done))
@@ -5056,60 +5052,63 @@ and `gnus-mime-delete-part', and not provided at run-time normally."
(defun gnus-mime-replace-part (file)
"Replace MIME part under point with an external body."
;; Useful if file has already been saved to disk
- (interactive
- (list
- (read-file-name "Replace MIME part with file: "
- (or mm-default-directory default-directory)
- nil t)))
+ (interactive (list
+ (read-file-name "Replace MIME part with file: "
+ (or mm-default-directory default-directory)
+ nil t))
+ gnus-article-mode)
(unless (file-regular-p (file-truename file))
(error "Can't replace part with %s, which isn't a regular file"
file))
(gnus-mime-save-part-and-strip file))
-(defun gnus-mime-save-part-and-strip (&optional file)
+(defun gnus-mime-save-part-and-strip (&optional file event)
"Save the MIME part under point then replace it with an external body.
If FILE is given, use it for the external part."
- (interactive)
- (gnus-article-check-buffer)
- (when (gnus-group-read-only-p)
- (error "The current group does not support deleting of parts"))
- (when (mm-complicated-handles gnus-article-mime-handles)
- (error "\
+ (interactive (list nil last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (when (gnus-group-read-only-p)
+ (error "The current group does not support deleting of parts"))
+ (when (mm-complicated-handles gnus-article-mime-handles)
+ (error "\
The current article has a complicated MIME structure, giving up..."))
- (let* ((data (get-text-property (point) 'gnus-data))
- (id (get-text-property (point) 'gnus-part))
- (handles gnus-article-mime-handles))
- (unless file
- (setq file
- (and data (mm-save-part data "Delete MIME part and save to: "))))
- (when file
- (with-current-buffer (mm-handle-buffer data)
- (erase-buffer)
- (insert "Content-Type: " (mm-handle-media-type data))
- (mml-insert-parameter-string (cdr (mm-handle-type data))
- '(charset))
- ;; Add a filename for the sake of saving the part again.
- (mml-insert-parameter
- (mail-header-encode-parameter "name" (file-name-nondirectory file)))
- (insert "\n")
- (insert "Content-ID: " (message-make-message-id) "\n")
- (insert "Content-Transfer-Encoding: binary\n")
- (insert "\n"))
- (setcdr data
- (cdr (mm-make-handle nil
- `("message/external-body"
- (access-type . "LOCAL-FILE")
- (name . ,file)))))
- ;; (set-buffer gnus-summary-buffer)
- (gnus-article-edit-part handles id))))
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (id (get-text-property (point) 'gnus-part))
+ (handles gnus-article-mime-handles))
+ (unless file
+ (setq file
+ (and data (mm-save-part data "Delete MIME part and save to: "))))
+ (when file
+ (with-current-buffer (mm-handle-buffer data)
+ (erase-buffer)
+ (insert "Content-Type: " (mm-handle-media-type data))
+ (mml-insert-parameter-string (cdr (mm-handle-type data))
+ '(charset))
+ ;; Add a filename for the sake of saving the part again.
+ (mml-insert-parameter
+ (mail-header-encode-parameter "name" (file-name-nondirectory file)))
+ (insert "\n")
+ (insert "Content-ID: " (message-make-message-id) "\n")
+ (insert "Content-Transfer-Encoding: binary\n")
+ (insert "\n"))
+ (setcdr data
+ (cdr (mm-make-handle nil
+ `("message/external-body"
+ (access-type . "LOCAL-FILE")
+ (name . ,file)))))
+ ;; (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-part handles id)))))
;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
;; parts...>') but with stripping would be nice.
-(defun gnus-mime-delete-part ()
+(defun gnus-mime-delete-part (&optional event)
"Delete the MIME part under point.
Replace it with some information about the removed part."
- (interactive)
+ (interactive (list last-nonmenu-event) gnus-article-mode)
+ (mouse-set-point event)
(gnus-article-check-buffer)
(when (gnus-group-read-only-p)
(error "The current group does not support deleting of parts"))
@@ -5155,33 +5154,37 @@ Deleting parts may malfunction or destroy the article; continue? "))
;; (set-buffer gnus-summary-buffer)
(gnus-article-edit-part handles id))))
-(defun gnus-mime-save-part ()
+(defun gnus-mime-save-part (&optional event)
"Save the MIME part under point."
- (interactive)
+ (interactive (list last-nonmenu-event) gnus-article-mode)
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
(mm-save-part data))))
-(defun gnus-mime-pipe-part (&optional cmd)
+(defun gnus-mime-pipe-part (&optional cmd event)
"Pipe the MIME part under point to a process.
Use CMD as the process."
- (interactive)
+ (interactive (list nil last-nonmenu-event) gnus-article-mode)
+ (mouse-set-point event)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
(mm-pipe-part data cmd))))
-(defun gnus-mime-view-part ()
+(defun gnus-mime-view-part (&optional event)
"Interactively choose a viewing method for the MIME part under point."
- (interactive)
- (gnus-article-check-buffer)
- (let ((data (get-text-property (point) 'gnus-data)))
- (when data
- (setq gnus-article-mime-handles
- (mm-merge-handles
- gnus-article-mime-handles (setq data (copy-sequence data))))
- (mm-interactively-view-part data))))
+ (interactive (list last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (when data
+ (setq gnus-article-mime-handles
+ (mm-merge-handles
+ gnus-article-mime-handles (setq data (copy-sequence data))))
+ (mm-interactively-view-part data)))))
(defun gnus-mime-view-part-as-type-internal ()
(gnus-article-check-buffer)
@@ -5191,55 +5194,59 @@ Use CMD as the process."
(mail-content-type-get (mm-handle-type handle) 'name)
;; Content-Disposition: attachment; filename=...
(cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
- (def-type (and name (mm-default-file-encoding name))))
+ (def-type (and name (mm-default-file-type name))))
(or (and def-type (cons def-type 0))
(and handle
(equal (mm-handle-media-supertype handle) "text")
'("text/plain" . 0))
'("application/octet-stream" . 0))))
-(defun gnus-mime-view-part-as-type (&optional mime-type pred)
+(defun gnus-mime-view-part-as-type (&optional mime-type pred event)
"Choose a MIME media type, and view the part as such.
If non-nil, PRED is a predicate to use during completion to limit the
available media-types."
- (interactive)
- (unless mime-type
- (setq mime-type
- (let ((default (gnus-mime-view-part-as-type-internal)))
- (gnus-completing-read
- "View as MIME type"
- (if pred
- (seq-filter pred (mailcap-mime-types))
- (mailcap-mime-types))
- nil nil nil
- (car default)))))
- (gnus-article-check-buffer)
- (let ((handle (get-text-property (point) 'gnus-data)))
- (when handle
- (when (equal (mm-handle-media-type handle) "message/external-body")
- (unless (mm-handle-cache handle)
- (mm-extern-cache-contents handle))
- (setq handle (mm-handle-cache handle)))
- (setq handle
- (mm-make-handle (mm-handle-buffer handle)
- (cons mime-type (cdr (mm-handle-type handle)))
- (mm-handle-encoding handle)
- (mm-handle-undisplayer handle)
- (mm-handle-disposition handle)
- (mm-handle-description handle)
- nil
- (mm-handle-id handle)))
- (setq gnus-article-mime-handles
- (mm-merge-handles gnus-article-mime-handles handle))
- (when (mm-handle-displayed-p handle)
- (mm-remove-part handle))
- (gnus-mm-display-part handle))))
-
-(defun gnus-mime-copy-part (&optional handle arg)
+ (interactive (list nil nil last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (if event (mouse-set-point event))
+ (unless mime-type
+ (setq mime-type
+ (let ((default (gnus-mime-view-part-as-type-internal)))
+ (gnus-completing-read
+ "View as MIME type"
+ (if pred
+ (seq-filter pred (mailcap-mime-types))
+ (mailcap-mime-types))
+ nil nil nil
+ (car default)))))
+ (gnus-article-check-buffer)
+ (let ((handle (get-text-property (point) 'gnus-data)))
+ (when handle
+ (when (equal (mm-handle-media-type handle) "message/external-body")
+ (unless (mm-handle-cache handle)
+ (mm-extern-cache-contents handle))
+ (setq handle (mm-handle-cache handle)))
+ (setq handle
+ (mm-make-handle (mm-handle-buffer handle)
+ (cons mime-type (cdr (mm-handle-type handle)))
+ (mm-handle-encoding handle)
+ (mm-handle-undisplayer handle)
+ (mm-handle-disposition handle)
+ (mm-handle-description handle)
+ nil
+ (mm-handle-id handle)))
+ (setq gnus-article-mime-handles
+ (mm-merge-handles gnus-article-mime-handles handle))
+ (when (mm-handle-displayed-p handle)
+ (mm-remove-part handle))
+ (gnus-mm-display-part handle)))))
+
+(defun gnus-mime-copy-part (&optional handle arg event)
"Put the MIME part under point into a new buffer.
If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
are decompressed."
- (interactive (list nil current-prefix-arg))
+ (interactive (list nil current-prefix-arg last-nonmenu-event)
+ gnus-article-mode)
+ (mouse-set-point event)
(gnus-article-check-buffer)
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
@@ -5291,15 +5298,19 @@ are decompressed."
(setq buffer-file-name nil))
(goto-char (point-min)))))
-(defun gnus-mime-print-part (&optional handle filename)
+(defun gnus-mime-print-part (&optional handle filename event)
"Print the MIME part under point."
- (interactive (list nil (ps-print-preprint current-prefix-arg)))
- (gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (contents (and handle (mm-get-part handle)))
- (file (make-temp-file (expand-file-name "mm." mm-tmp-directory)))
- (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
- (when contents
+ (interactive
+ (list nil (ps-print-preprint current-prefix-arg) last-nonmenu-event)
+ gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (contents (and handle (mm-get-part handle)))
+ (file (make-temp-file (expand-file-name "mm." mm-tmp-directory)))
+ (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
+ (when contents
(if printer
(unwind-protect
(progn
@@ -5314,12 +5325,14 @@ are decompressed."
(with-temp-buffer
(insert contents)
(gnus-print-buffer))
- (ps-despool filename)))))
+ (ps-despool filename))))))
-(defun gnus-mime-inline-part (&optional handle arg)
+(defun gnus-mime-inline-part (&optional handle arg event)
"Insert the MIME part under point into the current buffer.
Compressed files like .gz and .bz2 are decompressed."
- (interactive (list nil current-prefix-arg))
+ (interactive (list nil current-prefix-arg last-nonmenu-event)
+ gnus-article-mode)
+ (if event (mouse-set-point event))
(gnus-article-check-buffer)
(let* ((inhibit-read-only t)
(b (point))
@@ -5413,87 +5426,96 @@ CHARSET may either be a string or a symbol."
(setcdr param charset)
(setcdr type (cons (cons 'charset charset) (cdr type)))))))
-(defun gnus-mime-view-part-as-charset (&optional handle arg)
+(defun gnus-mime-view-part-as-charset (&optional handle arg event)
"Insert the MIME part under point into the current buffer using the
specified charset."
- (interactive (list nil current-prefix-arg))
- (gnus-article-check-buffer)
- (let ((handle (or handle (get-text-property (point) 'gnus-data)))
- (fun (get-text-property (point) 'gnus-callback))
- (gnus-newsgroup-ignored-charsets 'gnus-all)
- charset form preferred parts)
- (when handle
- (when (prog1
- (and fun
- (setq charset
- (or (cdr (assq
- arg
- gnus-summary-show-article-charset-alist))
- (read-coding-system "Charset: "))))
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)))
- (gnus-mime-set-charset-parameters handle charset)
- (when (and (consp (setq form (cdr-safe fun)))
- (setq form (ignore-errors
- (assq 'gnus-mime-display-alternative form)))
- (setq preferred (caddr form))
- (progn
- (when (eq (car preferred) 'quote)
- (setq preferred (cadr preferred)))
- (not (equal preferred
- (get-text-property (point) 'gnus-data))))
- (setq parts (get-text-property (point) 'gnus-part))
- (setq parts (cdr (assq parts
- gnus-article-mime-handle-alist)))
- (equal (mm-handle-media-type parts) "multipart/alternative")
- (setq parts (reverse (cdr parts))))
- (setcar (cddr form)
- (list 'quote (or (cadr (member preferred parts))
- (car parts)))))
- (funcall fun handle)))))
-
-(defun gnus-mime-view-part-externally (&optional handle)
- "View the MIME part under point with an external viewer."
- (interactive)
- (gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (mm-inlined-types nil)
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-ignored-charsets))
- (type (mm-handle-media-type handle))
- (method (mailcap-mime-info type))
- (mm-enable-external t))
- (if (not (stringp method))
- (gnus-mime-view-part-as-type
- nil (lambda (type) (stringp (mailcap-mime-info type))))
+ (interactive (list nil current-prefix-arg last-nonmenu-event)
+ gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (fun (get-text-property (point) 'gnus-callback))
+ (gnus-newsgroup-ignored-charsets 'gnus-all)
+ charset form preferred parts)
(when handle
- (mm-display-part handle nil t)))))
-
-(defun gnus-mime-view-part-internally (&optional handle)
+ (when (prog1
+ (and fun
+ (setq charset
+ (or (cdr (assq
+ arg
+ gnus-summary-show-article-charset-alist))
+ (read-coding-system "Charset: "))))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)))
+ (gnus-mime-set-charset-parameters handle charset)
+ (when (and (consp (setq form (cdr-safe fun)))
+ (setq form (ignore-errors
+ (assq 'gnus-mime-display-alternative form)))
+ (setq preferred (caddr form))
+ (progn
+ (when (eq (car preferred) 'quote)
+ (setq preferred (cadr preferred)))
+ (not (equal preferred
+ (get-text-property (point) 'gnus-data))))
+ (setq parts (get-text-property (point) 'gnus-part))
+ (setq parts (cdr (assq parts
+ gnus-article-mime-handle-alist)))
+ (equal (mm-handle-media-type parts) "multipart/alternative")
+ (setq parts (reverse (cdr parts))))
+ (setcar (cddr form)
+ (list 'quote (or (cadr (member preferred parts))
+ (car parts)))))
+ (funcall fun handle))))))
+
+(defun gnus-mime-view-part-externally (&optional handle event)
+ "View the MIME part under point with an external viewer."
+ (interactive (list nil last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (mm-inlined-types nil)
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))
+ (type (mm-handle-media-type handle))
+ (method (mailcap-mime-info type))
+ (mm-enable-external t))
+ (if (not (stringp method))
+ (gnus-mime-view-part-as-type
+ nil (lambda (type) (stringp (mailcap-mime-info type))))
+ (when handle
+ (mm-display-part handle nil t))))))
+
+(defun gnus-mime-view-part-internally (&optional handle event)
"View the MIME part under point with an internal viewer.
If no internal viewer is available, use an external viewer."
- (interactive)
- (gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (mm-inlined-types '(".*"))
- (mm-inline-large-images t)
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-ignored-charsets))
- (inhibit-read-only t))
- (if (not (mm-inlinable-p handle))
- (gnus-mime-view-part-as-type
- nil (lambda (type) (mm-inlinable-p handle type)))
- (when handle
- (gnus-bind-mm-vars (mm-display-part handle nil t))))))
+ (interactive (list nil last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (mouse-set-point event)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (mm-inlined-types '(".*"))
+ (mm-inline-large-images t)
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))
+ (inhibit-read-only t))
+ (if (not (mm-inlinable-p handle))
+ (gnus-mime-view-part-as-type
+ nil (lambda (type) (mm-inlinable-p handle type)))
+ (when handle
+ (gnus-bind-mm-vars (mm-display-part handle nil t)))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at (point)."
(interactive
- (list (gnus-completing-read "Action" (mapcar #'car gnus-mime-action-alist) t)))
+ (list (gnus-completing-read
+ "Action" (mapcar #'car gnus-mime-action-alist) t))
+ gnus-article-mode)
(gnus-article-check-buffer)
(let ((action-pair (assoc action gnus-mime-action-alist)))
(if action-pair
@@ -5586,62 +5608,62 @@ If INTERACTIVE, call FUNCTION interactively."
(defun gnus-article-pipe-part (n)
"Pipe MIME part N, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'mm-pipe-part))
(defun gnus-article-save-part (n)
"Save MIME part N, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'mm-save-part))
(defun gnus-article-interactively-view-part (n)
"View MIME part N interactively, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'mm-interactively-view-part))
(defun gnus-article-copy-part (n)
"Copy MIME part N, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
(defun gnus-article-view-part-as-charset (n)
"View MIME part N using a specified charset.
N is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
(defun gnus-article-view-part-externally (n)
"View MIME part N externally, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
(defun gnus-article-inline-part (n)
"Inline MIME part N, which is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
(defun gnus-article-save-part-and-strip (n)
"Save MIME part N and replace it with an external body.
N is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
(defun gnus-article-replace-part (n)
"Replace MIME part N with an external body.
N is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
(defun gnus-article-delete-part (n)
"Delete MIME part N and add some information about the removed part.
N is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-delete-part t))
(defun gnus-article-view-part-as-type (n)
"Choose a MIME media type, and view part N as such.
N is the numerical prefix."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
(defun gnus-article-mime-match-handle-first (condition)
@@ -5668,7 +5690,7 @@ N 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")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(or (numberp n) (setq n (gnus-article-mime-match-handle-first
gnus-article-mime-match-handle-function)))
@@ -5738,10 +5760,11 @@ all parts."
(mm-handle-media-type handle))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(copy-marker (point-min) t)
- ,(point-max-marker)))))))
+ (let ((beg (copy-marker (point-min) t))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))
(part
(mm-display-inline handle))))))
(when (markerp point)
@@ -5833,6 +5856,7 @@ all parts."
"" "..."))
(gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
(buffer-size)))
+ (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options")
gnus-tmp-type-long b e)
(when (string-match ".*/" gnus-tmp-name)
(setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
@@ -5841,6 +5865,19 @@ all parts."
(concat "; " gnus-tmp-name))))
(unless (equal gnus-tmp-description "")
(setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (when (and (zerop gnus-tmp-length)
+ ;; Only nnimap supports partial fetches so far.
+ nnimap-fetch-partial-articles
+ (string-match "^nnimap\\+" gnus-newsgroup-name))
+ (setq gnus-tmp-type-long
+ (concat
+ gnus-tmp-type-long
+ (substitute-command-keys
+ (concat "\\<gnus-summary-mode-map> (not downloaded, "
+ "\\[gnus-summary-show-complete-article] to fetch.)"))))
+ (setq help-echo
+ (concat "Type \\[gnus-summary-show-complete-article] "
+ "to download complete article. " help-echo)))
(setq b (point))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
@@ -5859,8 +5896,7 @@ all parts."
'keymap gnus-mime-button-map
'face gnus-article-button-face
'follow-link t
- 'help-echo
- "mouse-2: toggle the MIME part; down-mouse-3: more options")))
+ 'help-echo help-echo)))
(defvar gnus-displaying-mime nil)
@@ -6001,8 +6037,30 @@ If nil, don't show those extra buttons."
(defun gnus-mime-display-single (handle)
(let ((type (mm-handle-media-type handle))
(ignored gnus-ignored-mime-types)
+ (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight))
(not-attachment t)
- display text)
+ ;; Arrange a callback from `mm-inline-message' if we're
+ ;; displaying a message/rfc822 part.
+ (mm-inline-message-prepare-function
+ (lambda (charset)
+ (let ((handles
+ (let (gnus-article-mime-handles
+ ;; disable prepare hook
+ gnus-article-prepare-hook
+ (gnus-newsgroup-charset
+ ;; mm-uu might set it.
+ (unless (eq charset 'gnus-decoded)
+ (or charset gnus-newsgroup-charset))))
+ (let ((gnus-original-article-buffer
+ (mm-handle-buffer handle)))
+ (run-hooks 'gnus-article-decode-hook))
+ (gnus-article-prepare-display)
+ gnus-article-mime-handles)))
+ (when handles
+ (setq gnus-article-mime-handles
+ (mm-merge-handles gnus-article-mime-handles handles))))))
+ display text
+ gnus-displaying-mime)
(catch 'ignored
(progn
(while ignored
@@ -6107,7 +6165,7 @@ If nil, don't show those extra buttons."
(let* ((preferred (or preferred (mm-preferred-alternative handles)))
(ihandles handles)
(point (point))
- handle (inhibit-read-only t) from begend not-pref)
+ (inhibit-read-only t) begend not-pref) ;; from
(save-window-excursion
(save-restriction
(when ibegend
@@ -6121,56 +6179,58 @@ If nil, don't show those extra buttons."
(mm-remove-parts handles))
(setq begend (list (point-marker)))
;; Do the toggle.
- (unless (setq not-pref (cadr (member preferred ihandles)))
- (setq not-pref (car ihandles)))
+ (setq not-pref (or (cadr (member preferred ihandles))
+ (car ihandles)))
(when (or ibegend
(not preferred)
(not (gnus-unbuttonized-mime-type-p
"multipart/alternative")))
(add-text-properties
- (setq from (point))
+ ;; (setq from
+ (point);; )
(progn
(insert (format "%d. " id))
(point))
- `(gnus-callback
- (lambda (handles)
- (unless ,(not ibegend)
- (setq gnus-article-mime-handle-alist
- ',gnus-article-mime-handle-alist))
- (gnus-mime-display-alternative
- ',ihandles ',not-pref ',begend ,id))
- keymap ,gnus-mime-button-map
- mouse-face ,gnus-article-mouse-face
- face ,gnus-article-button-face
- follow-link t
- gnus-part ,id
- button t
- article-type multipart
- rear-nonsticky t))
+ (let ((gamha gnus-article-mime-handle-alist))
+ `(gnus-callback
+ ,(lambda (_handles)
+ (unless (not ibegend)
+ (setq gnus-article-mime-handle-alist gamha))
+ (gnus-mime-display-alternative
+ ihandles not-pref begend id))
+ keymap ,gnus-mime-button-map
+ mouse-face ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ follow-link t
+ gnus-part ,id
+ article-type multipart
+ rear-nonsticky t)))
;; Do the handles
- (while (setq handle (pop handles))
+ (dolist (handle handles)
(add-text-properties
- (setq from (point))
+ ;; (setq from
+ (point) ;; )
(progn
(insert (format "(%c) %-18s"
(if (equal handle preferred) ?* ? )
(mm-handle-media-type handle)))
(point))
- `(gnus-callback
- (lambda (handles)
- (unless ,(not ibegend)
- (setq gnus-article-mime-handle-alist
- ',gnus-article-mime-handle-alist))
- (gnus-mime-display-alternative
- ',ihandles ',handle ',begend ,id))
- keymap ,gnus-mime-button-map
- mouse-face ,gnus-article-mouse-face
- face ,gnus-article-button-face
- follow-link t
- gnus-part ,id
- button t
- gnus-data ,handle
- rear-nonsticky t))
+ (let ((gamha gnus-article-mime-handle-alist))
+ `(gnus-callback
+ ,(lambda (_handles)
+ (unless (not ibegend)
+ (setq gnus-article-mime-handle-alist gamha))
+ (gnus-mime-display-alternative
+ ihandles handle begend id))
+ keymap ,gnus-mime-button-map
+ mouse-face ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ follow-link t
+ gnus-part ,id
+ button t
+ category t
+ gnus-data ,handle
+ rear-nonsticky t)))
(insert " "))
(insert "\n\n"))
(when preferred
@@ -6178,8 +6238,9 @@ If nil, don't show those extra buttons."
(gnus-display-mime preferred)
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-ignored-charsets)))
+ (and (buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))))
(gnus-bind-mm-vars (mm-display-part preferred))
;; Do highlighting.
(save-excursion
@@ -6275,7 +6336,8 @@ is the string to use when it is inactive.")
(setq gnus-article-image-alist (delq entry gnus-article-image-alist))
(gnus-delete-wash-type category)))
-(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
+(defalias 'gnus-article-hide-headers-if-wanted
+ #'gnus-article-maybe-hide-headers)
(defun gnus-article-maybe-hide-headers ()
"Hide unwanted headers if `gnus-have-all-headers' is nil.
@@ -6341,7 +6403,7 @@ Provided for backwards compatibility."
This function toggles the display when called interactively. Note that
buttons to be added to the header are only the ones that aren't inlined
in the body. Use `gnus-header-face-alist' to highlight buttons."
- (interactive (list t))
+ (interactive (list t) gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(let ((case-fold-search t) buttons st)
(save-excursion
@@ -6446,7 +6508,7 @@ the coding cookie."
(defun gnus-narrow-to-page (&optional arg)
"Narrow the article buffer to a page.
If given a numerical ARG, move forward ARG pages."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(setq arg (if arg (prefix-numeric-value arg) 0))
(with-current-buffer gnus-article-buffer
(widen)
@@ -6499,7 +6561,7 @@ If given a numerical ARG, move forward ARG pages."
(defun gnus-article-goto-next-page ()
"Show the next page of the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(when (gnus-article-next-page)
(goto-char (point-min))
(gnus-article-read-summary-keys nil ?n)))
@@ -6507,7 +6569,7 @@ If given a numerical ARG, move forward ARG pages."
(defun gnus-article-goto-prev-page ()
"Show the previous page of the article."
- (interactive)
+ (interactive nil gnus-article-mode)
(if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
(gnus-article-read-summary-keys nil ?p)
(gnus-article-prev-page nil)))
@@ -6530,7 +6592,7 @@ If given a numerical ARG, move forward ARG pages."
"Show the next page of the current article.
If end of article, return non-nil. Otherwise return nil.
Argument LINES specifies lines to be scrolled up."
- (interactive "p")
+ (interactive "p" gnus-article-mode)
(move-to-window-line (- -1 scroll-margin))
(if (and (not (and gnus-article-over-scroll
(> (count-lines (window-start) (point-max))
@@ -6586,7 +6648,7 @@ specifies."
(defun gnus-article-prev-page (&optional lines)
"Show previous page of current article.
Argument LINES specifies lines to be scrolled down."
- (interactive "p")
+ (interactive "p" gnus-article-mode)
(move-to-window-line 0)
(if (and gnus-page-broken
(bobp)
@@ -6619,15 +6681,16 @@ not have a face in `gnus-article-boring-faces'."
(catch 'only-boring
(while (re-search-forward "\\b\\w\\w" nil t)
(forward-char -1)
- (when (not (gnus-intersection
+ (when (not (seq-intersection
(gnus-faces-at (point))
- (symbol-value 'gnus-article-boring-faces)))
+ (symbol-value 'gnus-article-boring-faces)
+ #'eq))
(throw 'only-boring nil)))
(throw 'only-boring t))))))
(defun gnus-article-refer-article ()
"Read article specified by message-id around point."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(re-search-backward "[ \t]\\|^" (point-at-bol) t)
(re-search-forward "<?news:<?\\|<" (point-at-eol) t)
@@ -6639,7 +6702,7 @@ not have a face in `gnus-article-boring-faces'."
(defun gnus-article-show-summary ()
"Reconfigure windows to show summary buffer."
- (interactive)
+ (interactive nil gnus-article-mode)
(if (not (gnus-buffer-live-p gnus-summary-buffer))
(error "There is no summary buffer for this article buffer")
(gnus-article-set-globals)
@@ -6649,7 +6712,7 @@ not have a face in `gnus-article-boring-faces'."
(defun gnus-article-describe-briefly ()
"Describe article mode commands briefly."
- (interactive)
+ (interactive nil gnus-article-mode)
(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 ()
@@ -6661,10 +6724,10 @@ not have a face in `gnus-article-boring-faces'."
(defun gnus-article-read-summary-keys (&optional _arg key not-restore-window)
"Read a summary buffer key sequence and execute it from the article buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(gnus-article-check-buffer)
(let ((nosaves
- '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW"
+ '("q" "Q" "r" "m" "a" "f" "WDD" "WDW"
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
@@ -6772,7 +6835,7 @@ not have a face in `gnus-article-boring-faces'."
(ding))))))))
(defun gnus-article-read-summary-send-keys ()
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((unread-command-events (list ?S)))
(gnus-article-read-summary-keys)))
@@ -6780,7 +6843,8 @@ not have a face in `gnus-article-boring-faces'."
"Display documentation of the function invoked by KEY.
KEY is a string or a vector."
(interactive (list (let ((cursor-in-echo-area t))
- (read-key-sequence "Describe key: "))))
+ (read-key-sequence "Describe key: ")))
+ gnus-article-mode)
(gnus-article-check-buffer)
(if (memq (key-binding key t) '(gnus-article-read-summary-keys
gnus-article-read-summary-send-keys))
@@ -6802,7 +6866,8 @@ KEY is a string or a vector."
KEY is a string or a vector."
(interactive (list (let ((cursor-in-echo-area t))
(read-key-sequence "Describe key: "))
- current-prefix-arg))
+ current-prefix-arg)
+ gnus-article-mode)
(gnus-article-check-buffer)
(if (memq (key-binding key t) '(gnus-article-read-summary-keys
gnus-article-read-summary-send-keys))
@@ -6829,7 +6894,7 @@ KEY is a string or a vector."
"Show a list of all defined keys, and their definitions.
The optional argument PREFIX, if non-nil, should be a key sequence;
then we display only bindings that start with that prefix."
- (interactive)
+ (interactive nil gnus-article-mode)
(gnus-article-check-buffer)
(let ((keymap (copy-keymap gnus-article-mode-map))
(map (copy-keymap gnus-article-send-map))
@@ -6838,7 +6903,7 @@ then we display only bindings that start with that prefix."
parent agent draft)
(define-key keymap "S" map)
(define-key map [t] nil)
- (define-key summap [t] 'undefined)
+ (define-key summap [t] #'undefined)
(with-current-buffer gnus-article-current-summary
(dolist (key sumkeys)
(define-key summap key (key-binding key (current-local-map))))
@@ -6871,13 +6936,14 @@ then we display only bindings that start with that prefix."
(setq draft gnus-draft-mode)))
(with-temp-buffer
(use-local-map keymap)
- (set (make-local-variable 'gnus-agent-summary-mode) agent)
- (set (make-local-variable 'gnus-draft-mode) draft)
+ (setq-local gnus-agent-summary-mode agent)
+ (setq-local gnus-draft-mode draft)
(describe-bindings prefix))
- (let ((item `((lambda (prefix)
- (with-current-buffer ,(current-buffer)
- (gnus-article-describe-bindings prefix)))
- ,prefix)))
+ (let* ((cb (current-buffer))
+ (item `(,(lambda (prefix)
+ (with-current-buffer cb
+ (gnus-article-describe-bindings prefix)))
+ ,prefix)))
;; Loading `help-mode' here is necessary if `describe-bindings'
;; is replaced with something, e.g. `helm-descbinds'.
(require 'help-mode)
@@ -6888,7 +6954,7 @@ then we display only bindings that start with that prefix."
"Start composing a reply mail to the current message.
The text in the region will be yanked. If the region isn't active,
the entire article will be yanked."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((article (cdr gnus-article-current))
contents)
(if (not (and transient-mark-mode mark-active))
@@ -6906,14 +6972,14 @@ the entire article will be yanked."
"Start composing a wide reply mail to the current message.
The text in the region will be yanked. If the region isn't active,
the entire article will be yanked."
- (interactive)
+ (interactive nil gnus-article-mode)
(gnus-article-reply-with-original t))
(defun gnus-article-followup-with-original ()
"Compose a followup to the current article.
The text in the region will be yanked. If the region isn't active,
the entire article will be yanked."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((article (cdr gnus-article-current))
contents)
(if (not (and transient-mark-mode mark-active))
@@ -6932,7 +6998,8 @@ the entire article will be yanked."
This means that signatures, cited text and (some) headers will be
hidden.
If given a prefix, show the hidden text instead."
- (interactive (append (gnus-article-hidden-arg) (list 'force)))
+ (interactive (append (gnus-article-hidden-arg) (list 'force))
+ gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(article-hide-headers arg)
(article-hide-list-identifiers)
@@ -7065,6 +7132,7 @@ If given a prefix, show the hidden text instead."
(gnus-backlog-enter-article
group article (current-buffer)))
(when (and gnus-agent
+ gnus-agent-eagerly-store-articles
(gnus-agent-group-covered-p group))
(gnus-agent-store-article article group)))
(setq result 'article))
@@ -7108,19 +7176,18 @@ If given a prefix, show the hidden text instead."
(when (and do-update-line
(or (numberp article)
(stringp article)))
- (let ((buf (current-buffer)))
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-summary-update-article do-update-line sparse-header)
(gnus-summary-goto-subject do-update-line nil t)
(set-window-point (gnus-get-buffer-window (current-buffer) t)
- (point))
- (set-buffer buf))))))
+ (point)))))))
(defun gnus-block-private-groups (group)
"Allows images in newsgroups to be shown, blocks images in all
other groups."
(if (or (gnus-news-group-p group)
- (gnus-member-of-valid 'global group))
+ (gnus-member-of-valid 'global group)
+ (member group gnus-global-groups))
;; Block nothing in news groups.
nil
;; Block everything anywhere else.
@@ -7214,11 +7281,9 @@ This is an extended text-mode.
\\{gnus-article-edit-mode-map}"
(make-local-variable 'gnus-article-edit-done-function)
(make-local-variable 'gnus-prev-winconf)
- (set (make-local-variable 'font-lock-defaults)
- '(message-font-lock-keywords t))
- (set (make-local-variable 'mail-header-separator) "")
- (set (make-local-variable 'gnus-article-edit-mode) t)
- (easy-menu-add message-mode-field-menu message-mode-map)
+ (setq-local font-lock-defaults '(message-font-lock-keywords t))
+ (setq-local mail-header-separator "")
+ (setq-local gnus-article-edit-mode t)
(mml-mode)
(setq buffer-read-only nil)
(buffer-enable-undo)
@@ -7229,19 +7294,20 @@ This is an extended text-mode.
This will have permanent effect only in mail groups.
If FORCE is non-nil, allow editing of articles even in read-only
groups."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(when (and (not force)
(gnus-group-read-only-p))
(error "The current newsgroup does not support article editing"))
(gnus-with-article-buffer
(article-date-original))
(gnus-article-edit-article
- 'ignore
- `(lambda (no-highlight)
- 'ignore
- (gnus-summary-edit-article-done
- ,(or (mail-header-references gnus-current-headers) "")
- ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
+ #'ignore
+ (let ((gch (or (mail-header-references gnus-current-headers) ""))
+ (ro (gnus-group-read-only-p))
+ (buf gnus-summary-buffer))
+ (lambda (no-highlight)
+ 'ignore
+ (gnus-summary-edit-article-done gch ro buf no-highlight)))))
(defun gnus-article-edit-article (start-func exit-func &optional quiet)
"Start editing the contents of the current article buffer."
@@ -7261,7 +7327,7 @@ groups."
(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start))
@@ -7295,7 +7361,7 @@ groups."
(defun gnus-article-edit-exit ()
"Exit the article editing without updating."
- (interactive)
+ (interactive nil gnus-article-mode)
(when (or (not (buffer-modified-p))
(yes-or-no-p "Article modified; kill anyway? "))
(let ((curbuf (current-buffer))
@@ -7309,15 +7375,14 @@ groups."
(gnus-article-mode)
(set-window-configuration winconf)
;; Tippy-toe some to make sure that point remains where it was.
- (save-current-buffer
- (set-buffer curbuf)
+ (with-current-buffer curbuf
(set-window-start (get-buffer-window (current-buffer)) window-start)
(goto-char p))))
(gnus-summary-show-article)))
(defun gnus-article-edit-full-stops ()
"Interactively repair spacing at end of sentences."
- (interactive)
+ (interactive nil gnus-article-mode)
(save-excursion
(goto-char (point-min))
(search-forward-regexp "^$" nil t)
@@ -7578,7 +7643,7 @@ Calls `describe-variable' or `describe-function'."
"Call `describe-key' when pushing the corresponding URL button."
(let* ((key-string
(replace-regexp-in-string gnus-button-handle-describe-prefix "" url))
- (keys (ignore-errors (eval `(kbd ,key-string)))))
+ (keys (ignore-errors (kbd key-string))))
(if keys
(describe-key keys)
(gnus-message 3 "Invalid key sequence in button: %s" key-string))))
@@ -7708,6 +7773,15 @@ positives are possible."
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\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
+ ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
+ ("<URL: *\\([^\n<>]*\\)>"
+ 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
+ ;; RFC 2396 (2.4.3., delims) ...
+ ("\"URL: *\\([^\n\"]*\\)\""
+ 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
+ ;; Raw URLs.
+ (gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0)
;; The following entries may lead to many false positives so don't enable
;; them by default (use a high button level).
("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]"
@@ -7731,15 +7805,6 @@ positives are possible."
;; Unlike the other regexps we really have to require quoting
;; here to determine where it ends.
1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
- ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
- ("<URL: *\\([^\n<>]*\\)>"
- 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
- ;; RFC 2396 (2.4.3., delims) ...
- ("\"URL: *\\([^\n\"]*\\)\""
- 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
- ;; Raw URLs.
- (gnus-button-url-regexp
- 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0)
;; man pages
("\\b\\([a-z][a-z]+([1-9])\\)\\W"
0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
@@ -7835,7 +7900,7 @@ HEADER is a regexp to match a header. For a fuller explanation, see
"Check text under the mouse pointer for a callback function.
If the text under the mouse pointer has a `gnus-callback' property,
call it with the value of the `gnus-data' text property."
- (interactive "e")
+ (interactive "e" gnus-article-mode)
(set-buffer (window-buffer (posn-window (event-start event))))
(let* ((pos (posn-point (event-start event)))
(data (get-text-property pos 'gnus-data))
@@ -7844,15 +7909,17 @@ call it with the value of the `gnus-data' text property."
(when fun
(funcall fun data))))
-(defun gnus-article-press-button ()
+(defun gnus-article-press-button (&optional event)
"Check text at point for a callback function.
If the text at point has a `gnus-callback' property,
call it with the value of the `gnus-data' text property."
- (interactive)
- (let ((data (get-text-property (point) 'gnus-data))
- (fun (get-text-property (point) 'gnus-callback)))
- (when fun
- (funcall fun data))))
+ (interactive (list last-nonmenu-event) gnus-article-mode)
+ (save-excursion
+ (when event
+ (mouse-set-point event))
+ (let ((fun (get-text-property (point) 'gnus-callback)))
+ (when fun
+ (funcall fun (get-text-property (point) 'gnus-data))))))
(defun gnus-article-highlight (&optional force)
"Highlight current article.
@@ -7860,7 +7927,7 @@ This function calls `gnus-article-highlight-headers',
`gnus-article-highlight-citation',
`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
do the highlighting. See the documentation for those functions."
- (interactive (list 'force))
+ (interactive (list 'force) gnus-article-mode)
(gnus-article-highlight-headers)
(gnus-article-highlight-citation force)
(gnus-article-highlight-signature)
@@ -7872,14 +7939,14 @@ do the highlighting. See the documentation for those functions."
This function calls `gnus-article-highlight-headers',
`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
do the highlighting. See the documentation for those functions."
- (interactive (list 'force))
+ (interactive (list 'force) gnus-article-mode)
(gnus-article-highlight-headers)
(gnus-article-highlight-signature)
(gnus-article-add-buttons))
(defun gnus-article-highlight-headers ()
"Highlight article headers as specified by `gnus-header-face-alist'."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(let (regexp header-face field-face from hpoints fpoints)
(dolist (entry gnus-header-face-alist)
@@ -7913,7 +7980,7 @@ do the highlighting. See the documentation for those functions."
"Highlight the signature in an article.
It does this by highlighting everything after
`gnus-signature-separator' using the face `gnus-signature'."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t))
(save-restriction
@@ -7936,7 +8003,7 @@ It does this by highlighting everything after
"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)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
@@ -7946,13 +8013,13 @@ specified by `gnus-button-alist'."
(article-goto-body)
(setq beg (point))
(while (setq entry (pop alist))
- (setq regexp (eval (car entry)))
+ (setq regexp (eval (car entry) t))
(goto-char beg)
(while (re-search-forward regexp nil t)
(let ((start (match-beginning (nth 1 entry)))
(end (match-end (nth 1 entry)))
(from (match-beginning 0)))
- (when (and (eval (nth 2 entry))
+ (when (and (eval (nth 2 entry) t)
(not (gnus-button-in-region-p
start end 'gnus-callback)))
;; That optional form returned non-nil, so we add the
@@ -8030,7 +8097,7 @@ url is put as the `gnus-button-url' overlay property on the button."
;; Add buttons to the head of an article.
(defun gnus-article-add-buttons-to-head ()
"Add buttons to the head of the article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(let (beg end)
(dolist (entry gnus-header-button-alist)
@@ -8043,14 +8110,14 @@ url is put as the `gnus-button-url' overlay property on the button."
(match-beginning 0))
(point-max)))
(goto-char beg)
- (while (re-search-forward (eval (nth 1 entry)) end t)
+ (while (re-search-forward (eval (nth 1 entry) t) end t)
;; Each match within a header.
(let* ((entry (cdr entry))
(start (match-beginning (nth 1 entry)))
(end (match-end (nth 1 entry)))
(form (nth 2 entry)))
(goto-char (match-end 0))
- (when (eval form)
+ (when (eval form t)
(gnus-article-add-button
start end (nth 3 entry)
(buffer-substring (match-beginning (nth 4 entry))
@@ -8059,7 +8126,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 text)
+(defun gnus-article-add-button (from to fun &optional data _text)
"Create a button between FROM and TO with callback FUN and data DATA."
(add-text-properties
from to
@@ -8078,7 +8145,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-article-copy-string ()
"Copy the string in the button to the kill ring."
- (interactive)
+ (interactive nil gnus-article-mode)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-string)))
(when data
@@ -8194,7 +8261,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-button-patch (library line)
"Visit an Emacs Lisp library LIBRARY on line LINE."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((file (locate-library (file-name-nondirectory library))))
(unless file
(error "Couldn't find library %s" library))
@@ -8272,7 +8339,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(setq indx (match-string 1 indx))
(Info-index indx)
(when comma
- (dotimes (i (with-temp-buffer
+ (dotimes (_ (with-temp-buffer
(insert comma)
;; Note: the XEmacs version of `how-many' takes
;; no optional argument.
@@ -8323,6 +8390,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(and (match-end 6) (list (string-to-number (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
+ (declare (obsolete message-parse-mailto-url "28.1"))
(let (retval pairs cur key val)
(setq pairs (split-string query "&"))
(while pairs
@@ -8342,31 +8410,8 @@ 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* ((args (gnus-url-parse-query-string
- (if (string-match "^\\?" url)
- (substring url 1)
- (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
- (concat "to=" (match-string 1 url) "&"
- (match-string 2 url))
- (concat "to=" url)))))
- (subject (cdr-safe (assoc "subject" args)))
- func)
- (gnus-msg-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (replace-regexp-in-string
- "\r\n" "\n"
- (mapconcat #'identity (reverse (cdar args)) ", ") nil t))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject))))
+ (gnus-msg-mail)
+ (message-mailto-1 url))
(defun gnus-button-embedded-url (address)
"Activate ADDRESS with `browse-url'."
@@ -8379,14 +8424,14 @@ url is put as the `gnus-button-url' overlay property on the button."
(defvar gnus-prev-page-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'gnus-button-prev-page)
- (define-key map "\r" 'gnus-button-prev-page)
+ (define-key map [mouse-2] #'gnus-button-prev-page)
+ (define-key map "\r" #'gnus-button-prev-page)
map))
(defvar gnus-next-page-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'gnus-button-next-page)
- (define-key map "\r" 'gnus-button-next-page)
+ (define-key map [mouse-2] #'gnus-button-next-page)
+ (define-key map "\r" #'gnus-button-next-page)
map))
(defun gnus-insert-prev-page-button ()
@@ -8408,7 +8453,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-button-next-page (&optional _args _more-args)
"Go to the next page."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((win (selected-window)))
(select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
@@ -8416,7 +8461,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-button-prev-page (&optional _args _more-args)
"Go to the prev page."
- (interactive)
+ (interactive nil gnus-article-mode)
(let ((win (selected-window)))
(select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
@@ -8440,7 +8485,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-article-button-next-page (_arg)
"Go to the next page."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(let ((win (selected-window)))
(select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
@@ -8448,7 +8493,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-article-button-prev-page (_arg)
"Go to the prev page."
- (interactive "P")
+ (interactive "P" gnus-article-mode)
(let ((win (selected-window)))
(select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
@@ -8498,8 +8543,8 @@ For example:
(defvar gnus-inhibit-article-treatments nil)
;; Dynamic variables.
-(defvar part-number) ;FIXME: Lacks a "gnus-" prefix.
-(defvar total-parts) ;FIXME: Lacks a "gnus-" prefix.
+(defvar gnus-treat-part-number)
+(defvar gnus-treat-total-parts)
(defvar gnus-treat-type)
(defvar gnus-treat-condition)
(defvar gnus-treat-length)
@@ -8507,8 +8552,8 @@ For example:
(defun gnus-treat-article (condition
&optional part-num total type)
(let ((gnus-treat-condition condition)
- (part-number part-num)
- (total-parts total)
+ (gnus-treat-part-number part-num)
+ (gnus-treat-total-parts total)
(gnus-treat-type type)
(gnus-treat-length (- (point-max) (point-min)))
(alist gnus-treatment-function-alist)
@@ -8568,9 +8613,9 @@ For example:
((eq val 'head)
nil)
((eq val 'first)
- (eq part-number 1))
+ (eq gnus-treat-part-number 1))
((eq val 'last)
- (eq part-number total-parts))
+ (eq gnus-treat-part-number gnus-treat-total-parts))
((numberp val)
(< gnus-treat-length val))
(t
@@ -8582,9 +8627,10 @@ For example:
(list
(or gnus-article-encrypt-protocol
(gnus-completing-read "Encrypt protocol"
- (mapcar #'car gnus-article-encrypt-protocol-alist)
- t))
- current-prefix-arg))
+ (mapcar #'car gnus-article-encrypt-protocol-alist)
+ t))
+ current-prefix-arg)
+ gnus-article-mode)
;; User might hit `K E' instead of `K e', so prompt once.
(when (and gnus-article-encrypt-protocol
gnus-novice-user)
@@ -8689,9 +8735,9 @@ For example:
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'gnus-article-push-button)
- (define-key map [mouse-2] 'gnus-article-push-button)
- (define-key map [down-mouse-3] 'gnus-mime-security-button-menu)
+ (define-key map "\r" #'gnus-article-push-button)
+ (define-key map [mouse-2] #'gnus-article-push-button)
+ (define-key map [down-mouse-3] #'gnus-mime-security-button-menu)
(dolist (c gnus-mime-security-button-commands)
(define-key map (cadr c) (car c)))
map))
@@ -8708,7 +8754,7 @@ For example:
(defun gnus-mime-security-button-menu (event prefix)
"Construct a context-sensitive menu of security commands."
- (interactive "e\nP")
+ (interactive "e\nP" gnus-article-mode)
(save-window-excursion
(let ((pos (event-start event)))
(select-window (posn-window pos))
@@ -8865,12 +8911,12 @@ For example:
(defun gnus-mime-security-save-part ()
"Save the security part under point."
- (interactive)
+ (interactive nil gnus-article-mode)
(gnus-mime-security-run-function 'mm-save-part))
(defun gnus-mime-security-pipe-part ()
"Pipe the security part under point to a process."
- (interactive)
+ (interactive nil gnus-article-mode)
(gnus-mime-security-run-function 'mm-pipe-part))
(provide 'gnus-art)
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index 46bf621e57c..fefd02c7bfb 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -227,6 +227,7 @@ that was fetched."
(narrow-to-region mark (point-max))
;; Put the articles into the agent, if they aren't already.
(when (and gnus-agent
+ gnus-agent-eagerly-store-articles
(gnus-agent-group-covered-p group))
(save-restriction
(narrow-to-region mark (point-max))
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index d6f53e4b380..6c7ad0c4744 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -1,4 +1,4 @@
-;;; gnus-bcklg.el --- backlog functions for Gnus
+;;; gnus-bcklg.el --- backlog functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el
index c1b7f7d53a7..8c2a928ab98 100644
--- a/lisp/gnus/gnus-bookmark.el
+++ b/lisp/gnus/gnus-bookmark.el
@@ -1,4 +1,4 @@
-;;; gnus-bookmark.el --- Bookmarks in Gnus
+;;; gnus-bookmark.el --- Bookmarks in Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -78,22 +78,19 @@
((file-exists-p "~/.gnus.bmk") "~/.gnus.bmk")
(t (nnheader-concat gnus-directory "bookmarks.el")))
"The default Gnus bookmarks file."
- :type 'string
- :group 'gnus-bookmark)
+ :type 'string)
(defcustom gnus-bookmark-file-coding-system
(if (mm-coding-system-p 'iso-2022-7bit)
'iso-2022-7bit)
"Coding system used for writing Gnus bookmark files."
- :type '(symbol :tag "Coding system")
- :group 'gnus-bookmark)
+ :type '(symbol :tag "Coding system"))
(defcustom gnus-bookmark-sort-flag t
"Non-nil means Gnus bookmarks are sorted by bookmark names.
Otherwise they will be displayed in LIFO order (that is,
most recently set ones come first, oldest ones come last)."
- :type 'boolean
- :group 'gnus-bookmark)
+ :type 'boolean)
(defcustom gnus-bookmark-bmenu-toggle-infos t
"Non-nil means show details when listing Gnus bookmarks.
@@ -102,19 +99,16 @@ This may result in truncated bookmark names. To disable this, put the
following in your `.emacs' file:
\(setq gnus-bookmark-bmenu-toggle-infos nil)"
- :type 'boolean
- :group 'gnus-bookmark)
+ :type 'boolean)
(defcustom gnus-bookmark-bmenu-file-column 30
"Column at which to display details in a buffer listing Gnus bookmarks.
You can toggle whether details are shown with \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-toggle-infos]."
- :type 'integer
- :group 'gnus-bookmark)
+ :type 'integer)
(defcustom gnus-bookmark-use-annotations nil
"If non-nil, ask for an annotation when setting a bookmark."
- :type 'boolean
- :group 'gnus-bookmark)
+ :type 'boolean)
(defcustom gnus-bookmark-bookmark-inline-details '(author)
"Details to be shown with `gnus-bookmark-bmenu-toggle-infos'.
@@ -125,8 +119,7 @@ The default value is \(subject)."
(const :tag "Subject" subject)
(const :tag "Date" date)
(const :tag "Group" group)
- (const :tag "Message-id" message-id)))
- :group 'gnus-bookmark)
+ (const :tag "Message-id" message-id))))
(defcustom gnus-bookmark-bookmark-details
'(author subject date group annotation)
@@ -139,14 +132,12 @@ The default value is \(author subject date group annotation)."
(const :tag "Date" date)
(const :tag "Group" group)
(const :tag "Message-id" message-id)
- (const :tag "Annotation" annotation)))
- :group 'gnus-bookmark)
+ (const :tag "Annotation" annotation))))
(defface gnus-bookmark-menu-heading
'((t (:inherit font-lock-type-face)))
"Face used to highlight the heading in Gnus bookmark menu buffers."
- :version "23.1" ;; No Gnus
- :group 'gnus-bookmark)
+ :version "23.1") ;; No Gnus
(defconst gnus-bookmark-end-of-version-stamp-marker
"-*- End Of Bookmark File Format Version Stamp -*-\n"
@@ -177,7 +168,7 @@ So the cdr of each bookmark is an alist too.")
;;;###autoload
(defun gnus-bookmark-set ()
"Set a bookmark for this article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-bookmark-maybe-load-default-file)
(if (or (not (derived-mode-p 'gnus-summary-mode))
(not gnus-article-current))
@@ -242,7 +233,7 @@ So the cdr of each bookmark is an alist too.")
(save-window-excursion
;; Avoid warnings?
;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file)
- (set-buffer (get-buffer-create " *Gnus bookmarks*"))
+ (set-buffer (gnus-get-buffer-create " *Gnus bookmarks*"))
(erase-buffer)
(gnus-bookmark-insert-file-format-version-stamp)
(pp gnus-bookmark-alist (current-buffer))
@@ -279,7 +270,7 @@ So the cdr of each bookmark is an alist too.")
(gnus-bookmark-maybe-load-default-file)
(let* ((bookmark (or bmk-name
(gnus-completing-read "Jump to bookmarked article"
- (mapcar 'car gnus-bookmark-alist))))
+ (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))))
@@ -345,8 +336,7 @@ copy of the alist."
(when gnus-bookmark-sort-flag
(setq gnus-bookmark-alist
(sort (copy-alist gnus-bookmark-alist)
- (function
- (lambda (x y) (string-lessp (car x) (car y))))))))
+ (lambda (x y) (string-lessp (car x) (car y)))))))
;;;###autoload
(defun gnus-bookmark-bmenu-list ()
@@ -357,10 +347,10 @@ deletion, or > if it is flagged for displaying."
(interactive)
(gnus-bookmark-maybe-load-default-file)
(if (called-interactively-p 'any)
- (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*"))
- (set-buffer (get-buffer-create "*Gnus Bookmark List*")))
+ (switch-to-buffer (gnus-get-buffer-create "*Gnus Bookmark List*"))
+ (set-buffer (gnus-get-buffer-create "*Gnus Bookmark List*")))
(let ((inhibit-read-only t)
- alist name start end)
+ alist name) ;; start end
(erase-buffer)
(insert "% Gnus Bookmark\n- --------\n")
(add-text-properties (point-min) (point)
@@ -493,7 +483,7 @@ Gnus bookmarks names preceded by a \"*\" have annotations.
(defun gnus-bookmark-bmenu-toggle-infos (&optional show)
"Toggle whether details are shown in the Gnus bookmark list.
Optional argument SHOW means show them unconditionally."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(cond
(show
(setq gnus-bookmark-bmenu-toggle-infos nil)
@@ -648,7 +638,7 @@ reposition and try again, else return nil."
(details gnus-bookmark-bookmark-details)
detail)
(save-excursion
- (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t)
+ (pop-to-buffer (gnus-get-buffer-create "*Gnus Bookmark Annotation*") t)
(erase-buffer)
(while details
(setq detail (pop details))
@@ -659,14 +649,14 @@ reposition and try again, else return nil."
(defun gnus-bookmark-bmenu-show-details ()
"Show the annotation for the current bookmark in another window."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(let ((bookmark (gnus-bookmark-bmenu-bookmark)))
(if (gnus-bookmark-bmenu-check-position)
(gnus-bookmark-show-details bookmark))))
(defun gnus-bookmark-bmenu-mark ()
"Mark bookmark on this line to be displayed by \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-select]."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(let ((inhibit-read-only t))
@@ -678,7 +668,7 @@ reposition and try again, else return nil."
(defun gnus-bookmark-bmenu-unmark (&optional backup)
"Cancel all requested operations on bookmark on this line and move down.
Optional BACKUP means move up."
- (interactive "P")
+ (interactive "P" gnus-bookmark-bmenu-mode)
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(progn
@@ -693,7 +683,7 @@ Optional BACKUP means move up."
(defun gnus-bookmark-bmenu-backup-unmark ()
"Move up and cancel all requested operations on bookmark on line above."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(forward-line -1)
(if (gnus-bookmark-bmenu-check-position)
(progn
@@ -705,7 +695,7 @@ Optional BACKUP means move up."
"Mark Gnus bookmark on this line to be deleted.
To carry out the deletions that you've marked, use
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(let ((inhibit-read-only t))
@@ -718,7 +708,7 @@ To carry out the deletions that you've marked, use
"Mark bookmark on this line to be deleted, then move up one line.
To carry out the deletions that you've marked, use
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(gnus-bookmark-bmenu-delete)
(forward-line -2)
(if (gnus-bookmark-bmenu-check-position)
@@ -730,7 +720,7 @@ To carry out the deletions that you've marked, use
You can mark bookmarks with the
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-mark]
command."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(if (gnus-bookmark-bmenu-check-position)
(let ((bmrk (gnus-bookmark-bmenu-bookmark))
(menu (current-buffer)))
@@ -740,13 +730,13 @@ command."
(bury-buffer menu))))
(defun gnus-bookmark-bmenu-select-by-mouse (event)
- (interactive "e")
+ (interactive "e" gnus-bookmark-bmenu-mode)
(mouse-set-point event)
(gnus-bookmark-bmenu-select))
(defun gnus-bookmark-bmenu-load ()
"Load the Gnus bookmark file and rebuild the bookmark menu-buffer."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(if (gnus-bookmark-bmenu-check-position)
(save-excursion
(save-window-excursion
@@ -755,7 +745,7 @@ command."
(defun gnus-bookmark-bmenu-execute-deletions ()
"Delete Gnus bookmarks marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands."
- (interactive)
+ (interactive nil gnus-bookmark-bmenu-mode)
(message "Deleting Gnus bookmarks...")
(let ((hide-em gnus-bookmark-bmenu-toggle-infos)
(o-point (point))
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index b34d8934c02..34dba54c11d 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -1,4 +1,4 @@
-;;; gnus-cache.el --- cache interface for Gnus
+;;; gnus-cache.el --- cache interface for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -29,9 +29,7 @@
(require 'gnus)
(require 'gnus-sum)
-(eval-when-compile
- (unless (fboundp 'gnus-agent-load-alist)
- (defun gnus-agent-load-alist (group))))
+(declare-function gnus-agent-load-alist "gnus-agent" (group))
(defcustom gnus-cache-active-file
(expand-file-name "active" gnus-cache-directory)
@@ -55,7 +53,7 @@
If you only want to cache your nntp groups, you could set this
variable to \"^nntp\".
-If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
+If a group matches both `gnus-cacheable-groups' and `gnus-uncacheable-groups'
it's not cached."
:group 'gnus-cache
:type '(choice (const :tag "off" nil)
@@ -93,6 +91,8 @@ it's not cached."
(autoload 'nnml-generate-nov-databases-directory "nnml")
(autoload 'nnvirtual-find-group-art "nnvirtual")
+(autoload 'nnselect-article-group "nnselect")
+(autoload 'nnselect-article-number "nnselect")
@@ -148,6 +148,8 @@ it's not cached."
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
+(defvar gnus-article-decode-hook)
+
(defun gnus-cache-possibly-enter-article
(group article ticked dormant unread &optional force)
(when (and (or force (not (eq gnus-use-cache 'passive)))
@@ -158,8 +160,12 @@ it's not cached."
(file-name-coding-system nnmail-pathname-coding-system))
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
- (let ((result (nnvirtual-find-group-art
- (gnus-group-real-name group) article)))
+ (let ((result (if (gnus-nnselect-group-p group)
+ (with-current-buffer gnus-summary-buffer
+ (cons (nnselect-article-group article)
+ (nnselect-article-number article)))
+ (nnvirtual-find-group-art
+ (gnus-group-real-name group) article))))
(setq group (car result)
number (cdr result))))
(when (and number
@@ -186,7 +192,7 @@ it's not cached."
(gnus-cache-update-file-total-fetched-for group file))
(setq lines-chars (nnheader-get-lines-and-char))
(nnheader-remove-body)
- (setq headers (nnheader-parse-naked-head))
+ (setq headers (nnheader-parse-head t))
(setf (mail-header-number headers) number)
(setf (mail-header-lines headers) (car lines-chars))
(setf (mail-header-chars headers) (cadr lines-chars))
@@ -232,8 +238,14 @@ it's not cached."
(let ((arts gnus-cache-removable-articles)
ga)
(while arts
- (when (setq ga (nnvirtual-find-group-art
- (gnus-group-real-name gnus-newsgroup-name) (pop arts)))
+ (when (setq ga
+ (if (gnus-nnselect-group-p gnus-newsgroup-name)
+ (with-current-buffer gnus-summary-buffer
+ (let ((article (pop arts)))
+ (cons (nnselect-article-group article)
+ (nnselect-article-number article))))
+ (nnvirtual-find-group-art
+ (gnus-group-real-name gnus-newsgroup-name) (pop arts))))
(let ((gnus-cache-removable-articles (list (cdr ga)))
(gnus-newsgroup-name (car ga)))
(gnus-cache-possibly-remove-articles-1)))))
@@ -330,7 +342,7 @@ it's not cached."
"Enter the next N articles into the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let (out)
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-remove-process-mark article)
@@ -351,7 +363,7 @@ Returns the list of articles entered."
"Remove the next N articles from the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles removed."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-cache-change-buffer gnus-newsgroup-name)
(let (out)
(dolist (article (gnus-summary-work-articles n))
@@ -376,7 +388,7 @@ Returns the list of articles removed."
(defun gnus-summary-insert-cached-articles ()
"Insert all the articles cached for this group into the current buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((gnus-verbose (max 6 gnus-verbose)))
(cond
((not gnus-newsgroup-cached)
@@ -389,7 +401,7 @@ Returns the list of articles removed."
(defun gnus-summary-limit-include-cached ()
"Limit the summary buffer to articles that are cached."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((gnus-verbose (max 6 gnus-verbose)))
(if gnus-newsgroup-cached
(progn
@@ -467,8 +479,12 @@ Returns the list of articles removed."
(file-name-coding-system nnmail-pathname-coding-system))
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
- (let ((result (nnvirtual-find-group-art
- (gnus-group-real-name group) article)))
+ (let ((result (if (gnus-nnselect-group-p group)
+ (with-current-buffer gnus-summary-buffer
+ (cons (nnselect-article-group article)
+ (nnselect-article-number article)))
+ (nnvirtual-find-group-art
+ (gnus-group-real-name group) article))))
(setq group (car result)
number (cdr result))))
(setq file (gnus-cache-file-name group number))
@@ -502,7 +518,7 @@ Returns the list of articles removed."
(setq articles
(sort (mapcar (lambda (name) (string-to-number name))
(directory-files dir nil "\\`[0-9]+\\'" t))
- '<))
+ #'<))
;; Update the cache active file, just to synch more.
(if articles
(progn
@@ -698,7 +714,7 @@ If LOW, update the lower bound instead."
(push (string-to-number (file-name-nondirectory (pop files))) nums)
(push (pop files) alphs)))
;; If we have nums, then this is probably a valid group.
- (when (setq nums (sort nums '<))
+ (when (setq nums (sort nums #'<))
(puthash group
(cons (car nums) (car (last nums)))
gnus-cache-active-hashtb))
@@ -714,6 +730,8 @@ If LOW, update the lower bound instead."
(gnus-cache-write-active t)
(gnus-message 5 "Generating the cache active file...done"))))
+(defvar nnml-generate-active-function)
+
;;;###autoload
(defun gnus-cache-generate-nov-databases (dir)
"Generate NOV files recursively starting in DIR."
@@ -868,7 +886,7 @@ supported."
(setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000)))
(let* ((entry (gethash group gnus-cache-total-fetched-hashtb)))
(if entry
- (apply '+ entry)
+ (apply #'+ entry)
(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
(+
(gnus-cache-update-overview-total-fetched-for group nil)
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index d02e898e230..34947cece89 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -1,4 +1,4 @@
-;;; gnus-cite.el --- parse citations in articles for Gnus
+;;; gnus-cite.el --- parse citations in articles for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -38,19 +38,16 @@
(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n"
"Format of opened cited text buttons."
- :group 'gnus-cite
:type 'string)
(defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n"
"Format of closed cited text buttons."
- :group 'gnus-cite
:type 'string)
(defcustom gnus-cited-lines-visible nil
"The number of lines of hidden cited text to remain visible.
Or a pair (cons) of numbers which are the number of lines at the top
and bottom of the text, respectively, to remain visible."
- :group 'gnus-cite
:type '(choice (const :tag "none" nil)
integer
(cons :tag "Top and Bottom" integer integer)))
@@ -58,13 +55,11 @@ and bottom of the text, respectively, to remain visible."
(defcustom gnus-cite-parse-max-size 25000
"Maximum article size (in bytes) where parsing citations is allowed.
Set it to nil to parse all articles."
- :group 'gnus-cite
:type '(choice (const :tag "all" nil)
integer))
(defcustom gnus-cite-max-prefix 20
"Maximum possible length for a citation prefix."
- :group 'gnus-cite
:type 'integer)
(defcustom gnus-supercite-regexp
@@ -72,18 +67,15 @@ Set it to nil to parse all articles."
">>>>> +\"\\([^\"\n]+\\)\" +==")
"Regexp matching normal Supercite attribution lines.
The first grouping must match prefixes added by other packages."
- :group 'gnus-cite
:type 'regexp)
(defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
"Regexp matching mangled Supercite attribution lines.
The first regexp group should match the Supercite attribution."
- :group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-minimum-match-count 2
"Minimum number of identical prefixes before we believe it's a citation."
- :group 'gnus-cite
:type 'integer)
;; Some Microsoft products put in a citation that extends to the
@@ -106,21 +98,18 @@ The first regexp group should match the Supercite attribution."
(defcustom gnus-cite-attribution-prefix
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----"
"Regexp matching the beginning of an attribution line."
- :group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-attribution-suffix
"\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$"
"Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button."
- :group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-unsightly-citation-regexp
"^-----Original Message-----\nFrom: \\(.+\n\\)+\n"
"Regexp matching Microsoft-type rest-of-message citations."
:version "22.1"
- :group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-ignore-quoted-from t
@@ -128,18 +117,15 @@ The text matching the first grouping will be used as a button."
Those lines may have been quoted by MTAs in order not to mix up with
the envelope From line."
:version "22.1"
- :group 'gnus-cite
:type 'boolean)
(defface gnus-cite-attribution '((t (:italic t)))
- "Face used for attribution lines."
- :group 'gnus-cite)
+ "Face used for attribution lines.")
(defcustom gnus-cite-attribution-face 'gnus-cite-attribution
"Face used for attribution lines.
It is merged with the face for the cited text belonging to the attribution."
:version "22.1"
- :group 'gnus-cite
:type 'face)
(defface gnus-cite-1 '((((class color)
@@ -150,8 +136,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "MidnightBlue"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-2 '((((class color)
(background dark))
@@ -161,8 +146,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "firebrick"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-3 '((((class color)
(background dark))
@@ -172,8 +156,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "dark green"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-4 '((((class color)
(background dark))
@@ -183,8 +166,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "OrangeRed"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-5 '((((class color)
(background dark))
@@ -194,8 +176,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "dark khaki"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-6 '((((class color)
(background dark))
@@ -205,8 +186,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "dark violet"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-7 '((((class color)
(background dark))
@@ -216,8 +196,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "SteelBlue4"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-8 '((((class color)
(background dark))
@@ -227,8 +206,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "magenta"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-9 '((((class color)
(background dark))
@@ -238,8 +216,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "violet"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-10 '((((class color)
(background dark))
@@ -249,8 +226,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "medium purple"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defface gnus-cite-11 '((((class color)
(background dark))
@@ -260,8 +236,7 @@ It is merged with the face for the cited text belonging to the attribution."
(:foreground "turquoise"))
(t
(:italic t)))
- "Citation face."
- :group 'gnus-cite)
+ "Citation face.")
(defcustom gnus-cite-face-list
'(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6
@@ -271,7 +246,6 @@ It is merged with the face for the cited text belonging to the attribution."
When there are citations from multiple articles in the same message,
Gnus will try to give each citation from each article its own face.
This should make it easier to see who wrote what."
- :group 'gnus-cite
:type '(repeat face)
:set (lambda (symbol value)
(prog1
@@ -290,17 +264,14 @@ This should make it easier to see who wrote what."
(defcustom gnus-cite-hide-percentage 50
"Only hide excess citation if above this percentage of the body."
- :group 'gnus-cite
:type 'number)
(defcustom gnus-cite-hide-absolute 10
"Only hide excess citation if above this number of lines in the body."
- :group 'gnus-cite
:type 'integer)
(defcustom gnus-cite-blank-line-after-header t
"If non-nil, put a blank line between the citation header and the button."
- :group 'gnus-cite
:type 'boolean)
;; This has to go here because its default value depends on
@@ -364,7 +335,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))
+ (interactive (list 'force) gnus-article-mode gnus-summary-mode)
(with-current-buffer (if same-buffer (current-buffer) gnus-article-buffer)
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
@@ -445,7 +416,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(gnus-article-search-signature)
(push (cons (point-marker) "") marks)
;; Sort the marks.
- (setq marks (sort marks 'car-less-than-car))
+ (setq marks (sort marks #'car-less-than-car))
(let ((omarks marks))
(setq marks nil)
(while (cdr omarks)
@@ -488,7 +459,7 @@ frame width.
Sections that are heuristically interpreted as not being
text (i.e., computer code and the like) will not be folded."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
@@ -553,12 +524,13 @@ text (i.e., computer code and the like) will not be folded."
;; like code? Check for ragged edges on the left.
(< (length columns) 3))))
-(defun gnus-article-hide-citation (&optional arg force)
+(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'.
If given a negative prefix, always show; if given a positive prefix,
always hide."
- (interactive (append (gnus-article-hidden-arg) (list 'force)))
+ (interactive (append (gnus-article-hidden-arg) (list 'force))
+ gnus-article-mode gnus-summary-mode)
(gnus-set-format 'cited-opened-text-button t)
(gnus-set-format 'cited-closed-text-button t)
(with-current-buffer gnus-article-buffer
@@ -623,7 +595,7 @@ always hide."
(progn
(gnus-article-add-button
(point)
- (progn (eval gnus-cited-closed-text-button-line-format-spec)
+ (progn (eval gnus-cited-closed-text-button-line-format-spec t)
(point))
'gnus-article-toggle-cited-text
(list (cons beg end) start))
@@ -673,7 +645,8 @@ means show, nil means toggle."
(progn (eval
(if hidden
gnus-cited-opened-text-button-line-format-spec
- gnus-cited-closed-text-button-line-format-spec))
+ gnus-cited-closed-text-button-line-format-spec)
+ t)
(point))
'gnus-article-toggle-cited-text
args)
@@ -689,7 +662,8 @@ percent and at least `gnus-cite-hide-absolute' lines of the body is
cited text with attributions. When called interactively, these two
variables are ignored.
See also the documentation for `gnus-article-highlight-citation'."
- (interactive (append (gnus-article-hidden-arg) '(force)))
+ (interactive (append (gnus-article-hidden-arg) '(force))
+ gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-delete-wash-type 'cite)
(unless (gnus-article-check-hidden-text 'cite arg)
@@ -717,7 +691,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(let ((article (cdr gnus-article-current)))
(unless (with-current-buffer gnus-summary-buffer
@@ -726,7 +700,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;;; Internal functions:
-(defun gnus-cite-parse-maybe (&optional force no-overlay)
+(defun gnus-cite-parse-maybe (&optional _force no-overlay)
"Always parse the buffer."
(gnus-cite-localize)
;;Reset parser information.
@@ -865,7 +839,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(setq current (car loop)
loop (cdr loop))
(setcdr current
- (gnus-set-difference (cdr current) numbers)))))))))
+ (seq-difference (cdr current) numbers #'eq)))))))))
(defun gnus-cite-parse-attributions ()
(let (al-alist)
@@ -919,25 +893,25 @@ See also the documentation for `gnus-article-highlight-citation'."
(regexp-quote tag) ">"))))
;; Find loose supercite citations after attributions.
(gnus-cite-match-attributions 'small t
- (lambda (prefix tag)
+ (lambda (_prefix tag)
(when tag
(concat "\\<"
(regexp-quote tag)
"\\>"))))
;; Find loose supercite citations anywhere.
(gnus-cite-match-attributions 'small nil
- (lambda (prefix tag)
+ (lambda (_prefix tag)
(when tag
(concat "\\<"
(regexp-quote tag)
"\\>"))))
;; Find nested citations after attributions.
(gnus-cite-match-attributions 'small-if-unique t
- (lambda (prefix tag)
+ (lambda (prefix _tag)
(concat "\\`" (regexp-quote prefix) ".+")))
;; Find nested citations anywhere.
(gnus-cite-match-attributions 'small nil
- (lambda (prefix tag)
+ (lambda (prefix _tag)
(concat "\\`" (regexp-quote prefix) ".+")))
;; Remove loose prefixes with too few lines.
(let ((alist gnus-cite-loose-prefix-alist)
@@ -999,7 +973,7 @@ See also the documentation for `gnus-article-highlight-citation'."
cites (cdr cites)
candidate (car cite)
numbers (cdr cite)
- first (apply 'min numbers)
+ first (apply #'min numbers)
compare (if size (length candidate) first))
(and (> first limit)
regexp
@@ -1025,7 +999,7 @@ See also the documentation for `gnus-article-highlight-citation'."
loop (cdr loop))
(if (eq current best)
()
- (setcdr current (gnus-set-difference (cdr current) numbers))
+ (setcdr current (seq-difference (cdr current) numbers #'eq))
(when (null (cdr current))
(setq gnus-cite-loose-prefix-alist
(delq current gnus-cite-loose-prefix-alist)
@@ -1125,7 +1099,7 @@ See also the documentation for `gnus-article-highlight-citation'."
"Search for a cited line and set match data accordingly.
Returns nil if there is no such line before LIMIT, t otherwise."
(when (re-search-forward gnus-message-cite-prefix-regexp limit t)
- (let ((cdepth (min (length (apply 'concat
+ (let ((cdepth (min (length (apply #'concat
(split-string
(match-string-no-properties 0)
"[\t [:alnum:]]+")))
@@ -1160,13 +1134,11 @@ Returns nil if there is no such line before LIMIT, t otherwise."
(define-minor-mode gnus-message-citation-mode
"Minor mode providing more font-lock support for nested citations.
When enabled, it automatically turns on `font-lock-mode'."
- nil ;; init-value
- "" ;; lighter
- nil ;; keymap
+ :lighter ""
(when (derived-mode-p 'message-mode)
;; FIXME: Use font-lock-add-keywords!
(let ((defaults (car font-lock-defaults))
- default keywords)
+ default) ;; keywords
(while defaults
(setq default (if (consp defaults)
(pop defaults)
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index e0f5f33efae..3bc94f11e79 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -1,4 +1,4 @@
-;;; gnus-cloud.el --- storing and retrieving data via IMAP
+;;; gnus-cloud.el --- storing and retrieving data via IMAP -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
@@ -52,14 +52,12 @@ Each element may be either a string or a property list.
The latter should have a :directory element whose value is a string,
and a :match element whose value is a regular expression to match
against the basename of files in said directory."
- :group 'gnus-cloud
:type '(repeat (choice (string :tag "File")
(plist :tag "Property list"))))
(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip)
"Storage method for cloud data, defaults to EPG if that's available."
:version "26.1"
- :group 'gnus-cloud
:type '(radio (const :tag "No encoding" nil)
(const :tag "Base64" base64)
(const :tag "Base64+gzip" base64-gzip)
@@ -68,7 +66,6 @@ against the basename of files in said directory."
(defcustom gnus-cloud-interactive t
"Whether Gnus Cloud changes should be confirmed."
:version "26.1"
- :group 'gnus-cloud
:type 'boolean)
(defvar gnus-cloud-group-name "Emacs-Cloud")
@@ -81,7 +78,6 @@ against the basename of files in said directory."
"The IMAP select method used to store the cloud data.
See also `gnus-server-set-cloud-method-server' for an
easy interactive way to set this from the Server buffer."
- :group 'gnus-cloud
:type '(radio (const :tag "Not set" nil)
(string :tag "A Gnus server name as a string")))
@@ -132,7 +128,7 @@ easy interactive way to set this from the Server buffer."
((eq gnus-cloud-storage-method 'epg)
(let ((context (epg-make-context 'OpenPGP))
- cipher)
+ ) ;; cipher
(setf (epg-context-armor context) t)
(setf (epg-context-textmode context) t)
(let ((data (epg-encrypt-string context
@@ -223,13 +219,10 @@ easy interactive way to set this from the Server buffer."
(t
(gnus-message 1 "Unknown type %s; ignoring" type))))))
-(defun gnus-cloud-update-newsrc-data (group elem &optional force-older)
- "Update the newsrc data for GROUP from ELEM.
-Use old data if FORCE-OLDER is not nil."
+(defun gnus-cloud-update-newsrc-data (group elem)
+ "Update the newsrc data for GROUP from ELEM."
(let* ((contents (plist-get elem :contents))
(date (or (plist-get elem :timestamp) "0"))
- (now (gnus-cloud-timestamp nil))
- (newer (string-lessp date now))
(group-info (gnus-get-info group)))
(if (and contents
(stringp (nth 0 contents))
@@ -238,15 +231,13 @@ Use old data if FORCE-OLDER is not nil."
(if (equal (format "%S" group-info)
(format "%S" contents))
(gnus-message 3 "Skipping cloud update of group %s, the info is the same" group)
- (if (and newer (not force-older))
- (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now)
- (when (or (not gnus-cloud-interactive)
- (gnus-y-or-n-p
- (format "%s has older different info in the cloud as of %s, update it here? "
- group date))))
- (gnus-message 2 "Installing cloud update of group %s" group)
- (gnus-set-info group contents)
- (gnus-group-update-group group)))
+ (when (or (not gnus-cloud-interactive)
+ (gnus-y-or-n-p
+ (format "%s has different info in the cloud from %s, update it here? "
+ group date)))
+ (gnus-message 2 "Installing cloud update of group %s" group)
+ (gnus-set-info group contents)
+ (gnus-group-update-group group)))
(gnus-error 1 "Sorry, group %s is not subscribed" group))
(gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)"
group elem))))
@@ -285,8 +276,8 @@ Use old data if FORCE-OLDER is not nil."
(insert new-contents)
(when (file-exists-p file-name)
(rename-file file-name (car (find-backup-file-name file-name))))
- (write-region (point-min) (point-max) file-name)
- (set-file-times file-name (parse-iso8601-time-string date))))
+ (write-region (point-min) (point-max) file-name nil nil nil 'excl)
+ (set-file-times file-name (parse-iso8601-time-string date) 'nofollow)))
(defun gnus-cloud-file-covered-p (file-name)
(let ((matched nil))
@@ -353,15 +344,15 @@ Use old data if FORCE-OLDER is not nil."
(group &optional previous method))
(defun gnus-cloud-ensure-cloud-group ()
- (let ((method (if (stringp gnus-cloud-method)
- (gnus-server-to-method gnus-cloud-method)
- gnus-cloud-method)))
+ ;; (let ((method (if (stringp gnus-cloud-method)
+ ;; (gnus-server-to-method gnus-cloud-method)
+ ;; gnus-cloud-method)))
(unless (or (gnus-active gnus-cloud-group-name)
(gnus-activate-group gnus-cloud-group-name nil nil
gnus-cloud-method))
(and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method)
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
- (gnus-subscribe-group gnus-cloud-group-name)))))
+ (gnus-subscribe-group gnus-cloud-group-name)))) ;; )
(defun gnus-cloud-upload-all-data ()
"Upload all data (newsrc and files) to the Gnus Cloud."
@@ -380,8 +371,9 @@ When FULL is t, upload everything, not just a difference from the last full."
(gnus-cloud-files-to-upload full)
(gnus-cloud-collect-full-newsrc)))
(group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)))
+ (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
(insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
- (or gnus-cloud-sequence "UNKNOWN")
+ gnus-cloud-sequence
(if full :full :partial)
gnus-cloud-storage-method))
(insert "From: nobody@gnus.cloud.invalid\n")
@@ -390,12 +382,13 @@ When FULL is t, upload everything, not just a difference from the last full."
(if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
t t)
(progn
- (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
(gnus-cloud-add-timestamps elems)
(gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group)
(gnus-group-refresh-group group))
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
+(defvar gnus-alter-header-function)
+
(defun gnus-cloud-add-timestamps (elems)
(dolist (elem elems)
(let* ((file-name (plist-get elem :file-name))
@@ -414,8 +407,9 @@ When FULL is t, upload everything, not just a difference from the last full."
(when (gnus-retrieve-headers (gnus-uncompress-range active) group)
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
- (while (and (not (eobp))
- (setq head (nnheader-parse-head)))
+ (while (setq head (nnheader-parse-head))
+ (when gnus-alter-header-function
+ (funcall gnus-alter-header-function head))
(push head headers))))
(sort (nreverse headers)
(lambda (h1 h2)
@@ -459,18 +453,21 @@ instead of `gnus-cloud-sequence'.
When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
Otherwise, returns the Gnus Cloud data chunks."
(let ((articles nil)
+ (highest-sequence-seen gnus-cloud-sequence)
chunks)
(dolist (header (gnus-cloud-available-chunks))
- (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
- (or sequence-override gnus-cloud-sequence -1))
-
- (if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
- (mail-header-subject header))
- (push (mail-header-number header) articles)
- (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
- (mail-header-number header)
- gnus-cloud-storage-method
- (mail-header-subject header)))))
+ (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header))))
+ (when (> this-sequence (or sequence-override gnus-cloud-sequence -1))
+
+ (if (string-match (format "storage-method: %s" gnus-cloud-storage-method)
+ (mail-header-subject header))
+ (progn
+ (push (mail-header-number header) articles)
+ (setq highest-sequence-seen (max highest-sequence-seen this-sequence)))
+ (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s"
+ (mail-header-number header)
+ gnus-cloud-storage-method
+ (mail-header-subject header))))))
(when articles
(nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
(with-current-buffer nntp-server-buffer
@@ -480,7 +477,8 @@ Otherwise, returns the Gnus Cloud data chunks."
(push (gnus-cloud-parse-chunk) chunks)
(forward-line 1))))
(if update
- (mapcar #'gnus-cloud-update-all chunks)
+ (prog1 (mapcar #'gnus-cloud-update-all chunks)
+ (setq gnus-cloud-sequence highest-sequence-seen))
chunks)))
(defun gnus-cloud-server-p (server)
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index 88f304d9a0f..e7af94ff509 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -1,4 +1,4 @@
-;;; gnus-cus.el --- customization commands for Gnus
+;;; gnus-cus.el --- customization commands for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1999-2021 Free Software Foundation, Inc.
@@ -49,18 +49,15 @@ if that value is non-nil."
;; Emacs stuff:
(when (and (facep 'custom-button-face)
(facep 'custom-button-pressed-face))
- (set (make-local-variable 'widget-button-face)
- 'custom-button-face)
- (set (make-local-variable 'widget-button-pressed-face)
- 'custom-button-pressed-face)
- (set (make-local-variable 'widget-mouse-face)
- 'custom-button-pressed-face))
+ (setq-local widget-button-face 'custom-button-face)
+ (setq-local widget-button-pressed-face 'custom-button-pressed-face)
+ (setq-local widget-mouse-face 'custom-button-pressed-face))
(when (and (boundp 'custom-raised-buttons)
(symbol-value '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-local widget-push-button-prefix "")
+ (setq-local widget-push-button-suffix "")
+ (setq-local widget-link-prefix "")
+ (setq-local widget-link-suffix "")))
;;; Group Customization:
@@ -340,7 +337,8 @@ category."))
(defun gnus-group-customize (group &optional topic)
"Edit the group or topic on the current line."
- (interactive (list (gnus-group-group-name) (gnus-group-topic-name)))
+ (interactive (list (gnus-group-group-name) (gnus-group-topic-name))
+ gnus-group-mode)
(let (info
(types (mapcar (lambda (entry)
`(cons :format "%v%h\n"
@@ -380,10 +378,8 @@ category."))
(gnus-kill-buffer "*Gnus Customize*")
(switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-custom-mode)
- (make-local-variable 'gnus-custom-group)
- (setq gnus-custom-group group)
- (make-local-variable 'gnus-custom-topic)
- (setq gnus-custom-topic topic)
+ (setq-local gnus-custom-group group)
+ (setq-local gnus-custom-topic topic)
(buffer-disable-undo)
(widget-insert "Customize the ")
(if group
@@ -422,7 +418,7 @@ category."))
(setq tmp (cdr tmp))))
(setq gnus-custom-params
- (apply 'widget-create 'group
+ (apply #'widget-create 'group
:value values
(delq nil
(list `(set :inline t
@@ -488,9 +484,9 @@ form, but who cares?"
(buffer-enable-undo)
(goto-char (point-min))))
-(defun gnus-group-customize-done (&rest ignore)
+(defun gnus-group-customize-done (&rest _ignore)
"Apply changes and bury the buffer."
- (interactive)
+ (interactive nil gnus-custom-mode)
(let ((params (widget-value gnus-custom-params)))
(if gnus-custom-topic
(gnus-topic-set-parameters gnus-custom-topic params)
@@ -834,7 +830,7 @@ eh?")))
"Customize score file FILE.
When called interactively, FILE defaults to the current score file.
This can be changed using the `\\[gnus-score-change-score-file]' command."
- (interactive (list gnus-current-score-file))
+ (interactive (list gnus-current-score-file) gnus-summary-mode)
(unless file
(error "No score file for %s" gnus-newsgroup-name))
(let ((scores (gnus-score-load file))
@@ -848,8 +844,7 @@ This can be changed using the `\\[gnus-score-change-score-file]' command."
(kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-custom-mode)
- (make-local-variable 'gnus-custom-score-alist)
- (setq gnus-custom-score-alist scores)
+ (setq-local gnus-custom-score-alist scores)
(widget-insert "Customize the ")
(widget-create 'info-link
:help-echo "Push me to learn more."
@@ -867,8 +862,7 @@ 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-insert "\n\n")
- (make-local-variable 'gnus-custom-scores)
- (setq gnus-custom-scores
+ (setq-local gnus-custom-scores
(widget-create 'group
:value scores
`(checklist :inline t
@@ -934,7 +928,7 @@ articles in the thread.
(use-local-map widget-keymap)
(widget-setup)))
-(defun gnus-score-customize-done (&rest ignore)
+(defun gnus-score-customize-done (&rest _ignore)
"Reset the score alist with the present value."
(let ((alist gnus-custom-score-alist)
(value (widget-value gnus-custom-scores)))
@@ -1007,7 +1001,7 @@ articles in the thread.
(defun gnus-agent-customize-category (category)
"Edit the CATEGORY."
- (interactive (list (gnus-category-name)))
+ (interactive (list (gnus-category-name)) gnus-custom-mode)
(let ((info (assq category gnus-category-alist))
(defaults (list nil '(agent-predicate . false)
(cons 'agent-enable-expiration
@@ -1034,14 +1028,15 @@ articles in the thread.
(widget-create
'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(let* ((info (assq gnus-agent-cat-name gnus-category-alist))
(widgets category-fields))
(while widgets
(let* ((widget (pop widgets))
(value (condition-case nil (widget-value widget) (error))))
(eval `(setf (,(widget-get widget :accessor) ',info)
- ',value)))))
+ ',value)
+ t))))
(gnus-category-write)
(gnus-kill-buffer (current-buffer))
(when (get-buffer gnus-category-buffer)
@@ -1052,10 +1047,9 @@ articles in the thread.
"\n Note: Empty fields default to the customizable global\
variables.\n\n")
- (set (make-local-variable 'gnus-agent-cat-name)
- name))
+ (setq-local gnus-agent-cat-name name))
- (set (make-local-variable 'category-fields) nil)
+ (setq-local category-fields nil)
(gnus-agent-cat-prepare-category-field agent-predicate)
(gnus-agent-cat-prepare-category-field agent-score)
@@ -1108,8 +1102,6 @@ articles in the thread.
(widget-setup)
(buffer-enable-undo))))
-;;; The End:
-
(provide 'gnus-cus)
;;; gnus-cus.el ends here
diff --git a/lisp/gnus/gnus-dbus.el b/lisp/gnus/gnus-dbus.el
new file mode 100644
index 00000000000..12bf7bb926a
--- /dev/null
+++ b/lisp/gnus/gnus-dbus.el
@@ -0,0 +1,70 @@
+;;; gnus-dbus.el --- DBUS integration for Gnus -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library contains some Gnus integration for systems using DBUS.
+;; At present it registers a signal to close all Gnus servers before
+;; system sleep or hibernation.
+
+;;; Code:
+
+(require 'gnus)
+(require 'dbus)
+(declare-function gnus-close-all-servers "gnus-start")
+
+(defcustom gnus-dbus-close-on-sleep nil
+ "When non-nil, close Gnus servers on system sleep."
+ :group 'gnus-dbus
+ :type 'boolean)
+
+(defvar gnus-dbus-sleep-registration-object nil
+ "Object returned from `dbus-register-signal'.
+Used to unregister the signal.")
+
+(defun gnus-dbus-register-sleep-signal ()
+ "Use `dbus-register-signal' to close servers on sleep."
+ (when (featurep 'dbusbind)
+ (setq gnus-dbus-sleep-registration-object
+ (dbus-register-signal :system
+ "org.freedesktop.login1"
+ "/org/freedesktop/login1"
+ "org.freedesktop.login1.Manager"
+ "PrepareForSleep"
+ #'gnus-dbus-sleep-handler))
+ (gnus-add-shutdown #'gnus-dbus-unregister-sleep-signal 'gnus)))
+
+(defun gnus-dbus-sleep-handler (sleep-start)
+ ;; Sleep-start is t before sleeping.
+ (when (and sleep-start
+ (gnus-alive-p))
+ (condition-case nil
+ (gnus-close-all-servers)
+ (error nil))))
+
+(defun gnus-dbus-unregister-sleep-signal ()
+ (condition-case nil
+ (dbus-unregister-object
+ gnus-dbus-sleep-registration-object)
+ (wrong-type-argument nil)))
+
+(provide 'gnus-dbus)
+;;; gnus-dbus.el ends here
diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el
index 97a094ae63a..944fd9795a2 100644
--- a/lisp/gnus/gnus-delay.el
+++ b/lisp/gnus/gnus-delay.el
@@ -1,4 +1,4 @@
-;;; gnus-delay.el --- Delayed posting of articles
+;;; gnus-delay.el --- Delayed posting of articles -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -44,24 +44,20 @@
(defcustom gnus-delay-group "delayed"
"Group name for storing delayed articles."
- :type 'string
- :group 'gnus-delay)
+ :type 'string)
(defcustom gnus-delay-header "X-Gnus-Delayed"
"Header name for storing info about delayed articles."
- :type 'string
- :group 'gnus-delay)
+ :type 'string)
(defcustom gnus-delay-default-delay "3d"
"Default length of delay."
- :type 'string
- :group 'gnus-delay)
+ :type 'string)
(defcustom gnus-delay-default-hour 8
"If deadline is given as date, then assume this time of day."
:version "22.1"
- :type 'integer
- :group 'gnus-delay)
+ :type 'integer)
;;;###autoload
(defun gnus-delay-article (delay)
@@ -75,14 +71,18 @@ DELAY is a string, giving the length of the time. Possible values are:
variable `gnus-delay-default-hour', minute and second are zero.
* hh:mm for a specific time. Use 24h format. If it is later than this
- time, then the deadline is tomorrow, else today."
- (interactive
- (list (read-string
- "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): "
- gnus-delay-default-delay)))
+ time, then the deadline is tomorrow, else today.
+
+The value of `message-draft-headers' determines which headers are
+generated when the article is delayed. Remaining headers are
+generated when the article is sent."
+ (interactive (list (read-string
+ "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): "
+ gnus-delay-default-delay))
+ message-mode)
;; Allow spell checking etc.
(run-hooks 'message-send-hook)
- (let (num unit days year month day hour minute deadline)
+ (let (num unit year month day hour minute deadline) ;; days
(cond ((string-match
"\\([0-9][0-9][0-9]?[0-9]?\\)-\\([0-9]+\\)-\\([0-9]+\\)"
delay)
@@ -167,7 +167,7 @@ DELAY is a string, giving the length of the time. Possible values are:
(message "Delay header missing for article %d" article)))))))
;;;###autoload
-(defun gnus-delay-initialize (&optional no-keymap no-check)
+(defun gnus-delay-initialize (&optional _no-keymap no-check)
"Initialize the gnus-delay package.
This sets up a key binding in `message-mode' to delay a message.
This tells Gnus to look for delayed messages after getting new news.
@@ -175,7 +175,7 @@ This tells Gnus to look for delayed messages after getting new news.
The optional arg NO-KEYMAP is ignored.
Checking delayed messages is skipped if optional arg NO-CHECK is non-nil."
(unless no-check
- (add-hook 'gnus-get-new-news-hook 'gnus-delay-send-queue)))
+ (add-hook 'gnus-get-new-news-hook #'gnus-delay-send-queue)))
(provide 'gnus-delay)
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index 219f15e2227..e99247c0ca9 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -1,4 +1,4 @@
-;;; gnus-demon.el --- daemonic Gnus behavior
+;;; gnus-demon.el --- daemonic Gnus behavior -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -52,7 +52,6 @@ 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"
(const :tag "never" nil)
@@ -65,7 +64,6 @@ Emacs has been idle for IDLE `gnus-demon-timestep's."
(defcustom gnus-demon-timestep 60
"Number of seconds in each demon timestep."
- :group 'gnus-demon
:type 'integer)
;;; Internal variables.
diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el
index 78f1e53ff7a..e2cbca9007d 100644
--- a/lisp/gnus/gnus-diary.el
+++ b/lisp/gnus/gnus-diary.el
@@ -1,4 +1,4 @@
-;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end
+;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -32,11 +32,6 @@
;; gnus-diary is a utility toolkit used on top of the nndiary back end. It is
;; now fully documented in the Gnus manual.
-
-;; Bugs / Todo:
-;; ===========
-
-
;;; Code:
(require 'nndiary)
@@ -57,8 +52,7 @@
(defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M"
"Time format to display appointments in nndiary summary buffers.
Please refer to `format-time-string' for information on possible values."
- :type 'string
- :group 'gnus-diary)
+ :type 'string)
(defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english
"Function called to format a diary delay string.
@@ -73,8 +67,7 @@ There are currently two built-in format functions:
`gnus-diary-delay-format-french'"
:type '(choice (const :tag "english" gnus-diary-delay-format-english)
(const :tag "french" gnus-diary-delay-format-french)
- (symbol :tag "other"))
- :group 'gnus-diary)
+ (symbol :tag "other")))
(defconst gnus-diary-version nndiary-version
"Current Diary back end version.")
@@ -216,7 +209,7 @@ There are currently two built-in format functions:
(defun gnus-summary-sort-by-schedule (&optional reverse)
"Sort nndiary summary buffers by schedule of appointments.
Optional prefix (or REVERSE argument) means sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'schedule reverse))
(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
@@ -276,13 +269,13 @@ Optional prefix (or REVERSE argument) means sort in reverse order."
(gnus-diary-update-group-parameters group)))
(add-hook 'nndiary-request-create-group-functions
- 'gnus-diary-update-group-parameters)
+ #'gnus-diary-update-group-parameters)
;; Now that we have `gnus-subscribe-newsgroup-functions', this is not needed
;; anymore. Maybe I should remove this completely.
(add-hook 'nndiary-request-update-info-functions
- 'gnus-diary-update-group-parameters)
+ #'gnus-diary-update-group-parameters)
(add-hook 'gnus-subscribe-newsgroup-functions
- 'gnus-diary-maybe-update-group-parameters)
+ #'gnus-diary-maybe-update-group-parameters)
;; Diary Message Checking ===================================================
@@ -324,7 +317,7 @@ This function checks that all NNDiary required headers are present and
valid, and prompts for values / correction otherwise.
If ARG (or prefix) is non-nil, force prompting for all fields."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-excursion
(mapcar
(lambda (head)
@@ -360,7 +353,7 @@ If ARG (or prefix) is non-nil, force prompting for all fields."
header ": ")))
(setq value
(if (listp (nth 1 head))
- (gnus-completing-read prompt (cons "*" (mapcar 'car (nth 1 head)))
+ (gnus-completing-read prompt (cons "*" (mapcar #'car (nth 1 head)))
t value
'gnus-diary-header-value-history)
(read-string prompt value
diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el
index 6f231c4fbb8..af0b782202a 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -1,4 +1,4 @@
-;;; gnus-dired.el --- utility functions where gnus and dired meet
+;;; gnus-dired.el --- utility functions where gnus and dired meet -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2001-2021 Free Software Foundation, Inc.
@@ -29,7 +29,7 @@
;; following in your ~/.gnus:
;; (require 'gnus-dired) ;, isn't needed due to autoload cookies
-;; (add-hook 'dired-mode-hook 'turn-on-gnus-dired-mode)
+;; (add-hook 'dired-mode-hook #'turn-on-gnus-dired-mode)
;; Note that if you visit dired buffers before your ~/.gnus file has
;; been read, those dired buffers won't have the keybindings in
@@ -40,7 +40,6 @@
(require 'dired)
(autoload 'mml-attach-file "mml")
-(autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'?
(autoload 'mailcap-extension-to-mime "mailcap")
(autoload 'mailcap-mime-info "mailcap")
@@ -125,7 +124,8 @@ 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 (dired-map-over-marks (dired-get-filename) nil)))))
+ dired-mode)
(let ((destination nil)
(files-str nil)
(bufs nil))
@@ -166,8 +166,9 @@ filenames."
(goto-char (point-max)) ;attach at end of buffer
(while files-to-attach
(mml-attach-file (car files-to-attach)
- (or (mm-default-file-encoding (car files-to-attach))
- "application/octet-stream") nil)
+ (or (mm-default-file-type (car files-to-attach))
+ "application/octet-stream")
+ nil)
(setq files-to-attach (cdr files-to-attach)))
(message "Attached file(s) %s" files-str))))
@@ -178,7 +179,8 @@ filenames."
If ARG is non-nil, open it in a new buffer."
(interactive (list
(file-name-sans-versions (dired-get-filename) t)
- current-prefix-arg))
+ current-prefix-arg)
+ dired-mode)
(mailcap-parse-mailcaps)
(if (file-exists-p file-name)
(let (mime-type method)
@@ -216,7 +218,8 @@ that name. If PRINT-TO is a number, prompt the user for the name
of the file to save in."
(interactive (list
(file-name-sans-versions (dired-get-filename) t)
- (ps-print-preprint current-prefix-arg)))
+ (ps-print-preprint current-prefix-arg))
+ dired-mode)
(mailcap-parse-mailcaps)
(cond
((file-directory-p file-name)
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 86a599a33f6..9a0f21359f8 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -1,4 +1,4 @@
-;;; gnus-draft.el --- draft message support for Gnus
+;;; gnus-draft.el --- draft message support for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -65,13 +65,13 @@
;; 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))))
+ (add-hook 'gnus-summary-prepare-exit-hook #'gnus-draft-clear-marks t t))))
;;; Commands
(defun gnus-draft-toggle-sending (article)
"Toggle whether to send an article or not."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number)) gnus-summary-mode)
(if (gnus-draft-article-sendable-p article)
(progn
(push article gnus-newsgroup-unsendable)
@@ -83,7 +83,7 @@
(defun gnus-draft-edit-message ()
"Enter a mail/post buffer to edit and send the draft."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((article (gnus-summary-article-number))
(group gnus-newsgroup-name))
(gnus-draft-check-draft-articles (list article))
@@ -99,17 +99,17 @@
(let ((gnus-verbose-backends nil))
(gnus-request-expire-articles (list article) group t))
(push
- `((lambda ()
- (when (gnus-buffer-live-p ,gnus-summary-buffer)
- (save-excursion
- (set-buffer ,gnus-summary-buffer)
- (gnus-cache-possibly-remove-article ,article nil nil nil t)))))
+ (let ((buf gnus-summary-buffer))
+ (lambda ()
+ (when (gnus-buffer-live-p buf)
+ (with-current-buffer buf
+ (gnus-cache-possibly-remove-article article nil nil nil t)))))
message-send-actions)))
(defun gnus-draft-send-message (&optional n)
"Send the current draft(s).
Obeys the standard process/prefix convention."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let* ((articles (gnus-summary-work-articles n))
(total (length articles))
article)
@@ -248,7 +248,7 @@ If DONT-POP is nil, display the buffer after setting it up."
(let ((article narticle))
(message-mail nil nil nil nil
(if dont-pop
- (lambda (buf) (set-buffer (get-buffer-create buf)))))
+ (lambda (buf) (set-buffer (gnus-get-buffer-create buf)))))
(let ((inhibit-read-only t))
(erase-buffer))
(if (not (gnus-request-restore-buffer article group))
@@ -275,8 +275,7 @@ If DONT-POP is nil, display the buffer after setting it up."
(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))))
+ (lambda (arg) (gnus-post-method arg (car ga))))
(unless (equal (cadr ga) "")
(dolist (article (cdr ga))
(message-add-action
diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el
index f7d61bb35fc..e4f3da94573 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -40,17 +40,14 @@
"If non-nil, save the duplicate list when shutting down Gnus.
If nil, duplicate suppression will only work on duplicates
seen in the same session."
- :group 'gnus-duplicate
:type 'boolean)
(defcustom gnus-duplicate-list-length 10000
"The maximum number of duplicate Message-IDs to keep track of."
- :group 'gnus-duplicate
:type 'integer)
(defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression")
"The name of the file to store the duplicate suppression list."
- :group 'gnus-duplicate
:type 'file)
;;; Internal variables
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index 184b08418db..3fd8bf51de4 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -1,4 +1,4 @@
-;;; gnus-eform.el --- a mode for editing forms for Gnus
+;;; gnus-eform.el --- a mode for editing forms for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -37,12 +37,10 @@
(defcustom gnus-edit-form-mode-hook nil
"Hook run in `gnus-edit-form-mode' buffers."
- :group 'gnus-edit-form
:type 'hook)
(defcustom gnus-edit-form-menu-hook nil
"Hook run when creating menus in `gnus-edit-form-mode' buffers."
- :group 'gnus-edit-form
:type 'hook)
;;; Internal variables
@@ -50,13 +48,13 @@
(defvar gnus-edit-form-buffer "*Gnus edit form*")
(defvar gnus-edit-form-done-function nil)
-(defvar gnus-edit-form-mode-map nil)
-(unless gnus-edit-form-mode-map
- (setq gnus-edit-form-mode-map (make-sparse-keymap))
- (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map)
- (gnus-define-keys gnus-edit-form-mode-map
- "\C-c\C-c" gnus-edit-form-done
- "\C-c\C-k" gnus-edit-form-exit))
+(defvar gnus-edit-form-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map emacs-lisp-mode-map)
+ (gnus-define-keys map
+ "\C-c\C-c" gnus-edit-form-done
+ "\C-c\C-k" gnus-edit-form-exit)
+ map))
(defun gnus-edit-form-make-menu-bar ()
(unless (boundp 'gnus-edit-form-menu)
@@ -67,9 +65,9 @@
["Exit" gnus-edit-form-exit t]))
(gnus-run-hooks 'gnus-edit-form-menu-hook)))
-(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form"
+(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form"
"Major mode for editing forms.
-It is a slightly enhanced emacs-lisp-mode.
+It is a slightly enhanced `lisp-data-mode'.
\\{gnus-edit-form-mode-map}"
(when (gnus-visual-p 'group-menu 'menu)
@@ -106,7 +104,7 @@ The optional LAYOUT overrides the `edit-form' window layout."
(defun gnus-edit-form-done ()
"Update changes and kill the current buffer."
- (interactive)
+ (interactive nil gnus-edit-form-mode)
(goto-char (point-min))
(let ((form (condition-case nil
(read (current-buffer))
@@ -117,7 +115,7 @@ The optional LAYOUT overrides the `edit-form' window layout."
(defun gnus-edit-form-exit ()
"Kill the current buffer."
- (interactive)
+ (interactive nil gnus-edit-form-mode)
(let ((winconf gnus-prev-winconf))
(kill-buffer (current-buffer))
(set-window-configuration winconf)))
diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el
index e12795994e1..8bca4ffe38f 100644
--- a/lisp/gnus/gnus-fun.el
+++ b/lisp/gnus/gnus-fun.el
@@ -1,4 +1,4 @@
-;;; gnus-fun.el --- various frivolous extension functions to Gnus
+;;; gnus-fun.el --- various frivolous extension functions to Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -40,7 +40,7 @@
"Regexp to match faces in `gnus-x-face-directory' to be omitted."
:version "25.1"
:group 'gnus-fun
- :type '(choice (const nil) string))
+ :type '(choice (const nil) regexp))
(defcustom gnus-face-directory (expand-file-name "faces" gnus-directory)
"Directory where Face PNG files are stored."
@@ -52,7 +52,7 @@
"Regexp to match faces in `gnus-face-directory' to be omitted."
:version "25.1"
:group 'gnus-fun
- :type '(choice (const nil) string))
+ :type '(choice (const nil) regexp))
(defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
"Command for converting a PBM to an X-Face."
@@ -132,11 +132,12 @@ For instance, to insert an X-Face use `gnus-random-x-face' as FUN
Files matching `gnus-x-face-omit-files' are not considered."
(interactive)
- (gnus--random-face-with-type gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files
- (lambda (file)
- (gnus-shell-command-to-string
- (format gnus-convert-pbm-to-x-face-command
- (shell-quote-argument file))))))
+ (gnus--random-face-with-type
+ gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files
+ (lambda (file)
+ (gnus-shell-command-to-string
+ (format gnus-convert-pbm-to-x-face-command
+ (shell-quote-argument file))))))
;;;###autoload
(defun gnus-insert-random-x-face-header ()
@@ -230,8 +231,8 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to
Files matching `gnus-face-omit-files' are not considered."
(interactive)
(gnus--random-face-with-type gnus-face-directory "\\.png$"
- gnus-face-omit-files
- 'gnus-convert-png-to-face))
+ gnus-face-omit-files
+ 'gnus-convert-png-to-face))
;;;###autoload
(defun gnus-insert-random-face-header ()
@@ -267,16 +268,15 @@ colors of the displayed X-Faces."
'xface
(gnus-put-image
(if (gnus-image-type-available-p 'xface)
- (apply 'gnus-create-image (concat "X-Face: " data) 'xface t
+ (apply #'gnus-create-image (concat "X-Face: " data) 'xface t
(cdr (assq 'xface gnus-face-properties-alist)))
- (apply 'gnus-create-image pbm 'pbm t
+ (apply #'gnus-create-image pbm 'pbm t
(cdr (assq 'pbm gnus-face-properties-alist))))
nil 'xface))
(gnus-add-wash-type 'xface))))))
(defun gnus-grab-cam-x-face ()
"Grab a picture off the camera and make it into an X-Face."
- (interactive)
(shell-command "xawtv-remote snap ppm")
(let ((file nil))
(while (null (setq file (directory-files "/tftpboot/sparky/tmp"
@@ -285,16 +285,14 @@ colors of the displayed X-Faces."
(setq file (car file))
(with-temp-buffer
(shell-command
- (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface"
- file)
+ (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>%s | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface"
+ file null-device)
(current-buffer))
- ;;(sleep-for 3)
(delete-file file)
(buffer-string))))
(defun gnus-grab-cam-face ()
"Grab a picture off the camera and make it into an X-Face."
- (interactive)
(shell-command "xawtv-remote snap ppm")
(let ((file nil)
(tempfile (make-temp-file "gnus-face-" nil ".ppm"))
@@ -311,7 +309,6 @@ colors of the displayed X-Faces."
(gnus-fun-ppm-change-string))))
(setq result (gnus-face-from-file tempfile)))
(delete-file file)
- ;;(delete-file tempfile) ; FIXME why are we not deleting it?!
result))
(defun gnus-fun-ppm-change-string ()
@@ -324,7 +321,7 @@ colors of the displayed X-Faces."
(dotimes (i 255)
(push (format format i i i i i i)
values))
- (mapconcat 'identity values " ")))
+ (mapconcat #'identity values " ")))
(defun gnus-funcall-no-warning (function &rest args)
(when (fboundp function)
diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el
index 52dde7aad3c..be57774fe96 100644
--- a/lisp/gnus/gnus-gravatar.el
+++ b/lisp/gnus/gnus-gravatar.el
@@ -38,21 +38,18 @@
If nil, default to `gravatar-size'."
:type '(choice (const :tag "Default" nil)
(integer :tag "Pixels"))
- :version "24.1"
- :group 'gnus-gravatar)
+ :version "24.1")
(defcustom gnus-gravatar-properties '(:ascent center :relief 1)
"List of image properties applied to Gravatar images."
:type 'plist
- :version "24.1"
- :group 'gnus-gravatar)
+ :version "24.1")
(defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly
"Regexp matching posters whose avatar shouldn't be shown automatically.
If nil, show all avatars."
:type '(choice regexp (const :tag "Allow all" nil))
- :version "24.1"
- :group 'gnus-gravatar)
+ :version "24.1")
(defun gnus-gravatar-transform-address (header category &optional force)
(gnus-with-article-headers
@@ -109,14 +106,16 @@ callback for `gravatar-retrieve'."
;; If we're on the " quoting the name, go backward.
(when (looking-at-p "[\"<]")
(goto-char (1- (point))))
- ;; Do not do anything if there's already a gravatar. This can
- ;; happen 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 (get-text-property (point) 'gnus-gravatar)
+ ;; Do not do anything if there's already a gravatar.
+ ;; This can happen 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 (get-text-property (1- (point)) 'gnus-gravatar)
(let ((pos (point)))
(setq gravatar (append gravatar gnus-gravatar-properties))
- (gnus-put-image gravatar (buffer-substring pos (1+ pos)) category)
+ (gnus-put-image gravatar (buffer-substring pos (1+ pos))
+ category)
(put-text-property pos (point) 'gnus-gravatar address)
(gnus-add-wash-type category)
(gnus-add-image category gravatar)))))
@@ -126,7 +125,7 @@ callback for `gravatar-retrieve'."
(defun gnus-treat-from-gravatar (&optional force)
"Display gravatar in the From header.
If gravatar is already displayed, remove it."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(if (memq 'from-gravatar gnus-article-wash-types)
(gnus-delete-images 'from-gravatar)
@@ -136,7 +135,7 @@ If gravatar is already displayed, remove it."
(defun gnus-treat-mail-gravatar (&optional force)
"Display gravatars in the Cc and To headers.
If gravatars are already displayed, remove them."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(if (memq 'mail-gravatar gnus-article-wash-types)
(gnus-delete-images 'mail-gravatar)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 18499091541..6202567344f 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1,4 +1,4 @@
-;;; gnus-group.el --- group mode commands for Gnus
+;;; gnus-group.el --- group mode commands for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -39,28 +39,29 @@
(eval-when-compile
(require 'mm-url)
(require 'subr-x)
- (let ((features (cons 'gnus-group features)))
- (require 'gnus-sum))
- (unless (boundp 'gnus-cache-active-hashtb)
- (defvar gnus-cache-active-hashtb nil)))
+ (with-suppressed-warnings ((lexical features))
+ (dlet ((features (cons 'gnus-group features)))
+ (require 'gnus-sum))))
+
+(defvar gnus-cache-active-hashtb)
(defvar tool-bar-mode)
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
-(autoload 'gnus-group-make-nnir-group "nnir")
-
(autoload 'gnus-cloud-upload-all-data "gnus-cloud")
(autoload 'gnus-cloud-download-all-data "gnus-cloud")
+(autoload 'gnus-topic-find-groups "gnus-topic")
+
(defcustom gnus-no-groups-message "No news is good news"
"Message displayed by Gnus when no groups are available."
:group 'gnus-start
:type 'string)
(defcustom gnus-keep-same-level nil
- "Non-nil means that the next newsgroup after the current will be on the same level.
+ "Non-nil means that the newsgroup after this one will be on the same level.
When you type, for instance, `n' after reading the last article in the
current newsgroup, you will go to the next newsgroup. If this variable
is nil, the next newsgroup will be the next from the group
@@ -366,13 +367,16 @@ requires an understanding of Lisp expressions. Hopefully this will
change in a future release. For now, you can use the following
variables in the Lisp expression:
-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.
-level: The level of the group.
-score: The score of the group.
-ticked: The number of ticked articles."
+`group': The name of the group.
+`unread': The number of unread articles in the group.
+`method': The select method used.
+`total': The total number of articles in the group.
+`mailp': Whether it's a mail group or not.
+`level': The level of the group.
+`score': The score of the group.
+`ticked': The number of ticked articles.
+`group-age': Time in seconds since the group was last read
+ (see info node `(gnus)Group Timestamp')."
:group 'gnus-group-visual
:type '(repeat (cons (sexp :tag "Form") face)))
(put 'gnus-group-highlight 'risky-local-variable t)
@@ -400,16 +404,8 @@ file.
It is also possible to change and add form fields, but currently that
requires an understanding of Lisp expressions. Hopefully this will
-change in a future release. For now, you can use the following
-variables in the Lisp expression:
-
-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.
-level: The level of the group.
-score: The score of the group.
-ticked: The number of ticked articles."
+change in a future release. For now, you can use the same
+variables in the Lisp expression as in `gnus-group-highlight'."
:group 'gnus-group-icons
:type '(repeat (cons (sexp :tag "Form") file)))
(put 'gnus-group-icon-list 'risky-local-variable t)
@@ -476,20 +472,31 @@ simple manner."
(defvar gnus-group-edit-buffer nil)
-(defvar gnus-tmp-news-method)
+(defvar gnus-tmp-active)
(defvar gnus-tmp-colon)
-(defvar gnus-tmp-news-server)
-(defvar gnus-tmp-header)
-(defvar gnus-tmp-process-marked)
-(defvar gnus-tmp-summary-live)
-(defvar gnus-tmp-news-method-string)
+(defvar gnus-tmp-comment)
+(defvar gnus-tmp-group)
(defvar gnus-tmp-group-icon)
+(defvar gnus-tmp-header)
+(defvar gnus-tmp-level)
+(defvar gnus-tmp-marked)
+(defvar gnus-tmp-marked-mark)
+(defvar gnus-tmp-method)
+(defvar gnus-tmp-moderated)
(defvar gnus-tmp-moderated-string)
(defvar gnus-tmp-newsgroup-description)
-(defvar gnus-tmp-comment)
+(defvar gnus-tmp-news-method)
+(defvar gnus-tmp-news-method-string)
+(defvar gnus-tmp-news-server)
+(defvar gnus-tmp-number-of-read)
+(defvar gnus-tmp-number-of-unread)
+(defvar gnus-tmp-number-total)
+(defvar gnus-tmp-process-marked)
(defvar gnus-tmp-qualified-group)
(defvar gnus-tmp-subscribed)
-(defvar gnus-tmp-number-of-read)
+(defvar gnus-tmp-summary-live)
+(defvar gnus-tmp-user-defined)
+
(defvar gnus-inhibit-demon)
(defvar gnus-pick-mode)
(defvar gnus-tmp-marked-mark)
@@ -505,7 +512,8 @@ simple manner."
(+ number
(gnus-range-length (cdr (assq 'dormant gnus-tmp-marked)))
(gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))))
- (t number)) ?s)
+ (t number))
+ ?s)
(?R gnus-tmp-number-of-read ?s)
(?U (if (gnus-active gnus-tmp-group)
(gnus-number-of-unseen-articles-in-group gnus-tmp-group)
@@ -516,7 +524,8 @@ simple manner."
(?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
(?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d)
(?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked)))
- (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d)
+ (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))
+ ?d)
(?g gnus-tmp-group ?s)
(?G gnus-tmp-qualified-group ?s)
(?c (gnus-short-group-name gnus-tmp-group)
@@ -580,8 +589,8 @@ simple manner."
"\M-p" gnus-group-prev-unread-group-same-level
"," gnus-group-best-unread-group
"." gnus-group-first-unread-group
- "u" gnus-group-unsubscribe-current-group
- "U" gnus-group-unsubscribe-group
+ "u" gnus-group-toggle-subscription-at-point
+ "U" gnus-group-toggle-subscription
"c" gnus-group-catchup-current
"C" gnus-group-catchup-current-all
"\M-c" gnus-group-clear-data
@@ -663,7 +672,8 @@ 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
+ "G" gnus-group-read-ephemeral-search-group
+ "g" gnus-group-make-search-group
"M" gnus-group-read-ephemeral-group
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
@@ -757,8 +767,8 @@ simple manner."
(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
"l" gnus-group-set-current-level
- "t" gnus-group-unsubscribe-current-group
- "s" gnus-group-unsubscribe-group
+ "t" gnus-group-toggle-subscription-at-point
+ "s" gnus-group-toggle-subscription
"k" gnus-group-kill-group
"y" gnus-group-yank-group
"w" gnus-group-kill-region
@@ -804,7 +814,7 @@ simple manner."
["Check for new articles " gnus-topic-get-new-news-this-topic
:included (gnus-topic-mode-p)
:help "Check for new messages in current group or topic"]
- ["Toggle subscription" gnus-group-unsubscribe-current-group
+ ["Toggle subscription" gnus-group-toggle-subscription-at-point
(gnus-group-group-name)]
["Kill" gnus-group-kill-group :active (gnus-group-group-name)
:help "Kill (remove) current group"]
@@ -884,20 +894,20 @@ simple manner."
["Sort by real name" gnus-group-sort-selected-groups-by-real-name
(not (gnus-topic-mode-p))])
("Mark"
- ["Mark group" gnus-group-mark-group
+ ["Toggle/Set mark" gnus-group-mark-group
(and (gnus-group-group-name)
(not (memq (gnus-group-group-name) gnus-group-marked)))]
- ["Unmark group" gnus-group-unmark-group
+ ["Remove mark" gnus-group-unmark-group
(and (gnus-group-group-name)
(memq (gnus-group-group-name) gnus-group-marked))]
- ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked]
- ["Mark regexp..." gnus-group-mark-regexp t]
+ ["Remove all marks" gnus-group-unmark-all-groups gnus-group-marked]
+ ["Mark by regexp..." gnus-group-mark-regexp t]
["Mark region" gnus-group-mark-region :active mark-active]
["Mark buffer" gnus-group-mark-buffer t]
["Execute command" gnus-group-universal-argument
(or gnus-group-marked (gnus-group-group-name))])
("Subscribe"
- ["Subscribe to a group..." gnus-group-unsubscribe-group t]
+ ["Toggle subscription..." gnus-group-toggle-subscription t]
["Kill all newsgroups in region" gnus-group-kill-region
:active mark-active]
["Kill all zombie groups" gnus-group-kill-all-zombies
@@ -909,7 +919,8 @@ simple manner."
["Add the help group" gnus-group-make-help-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
- ["Make a search group..." gnus-group-make-nnir-group t]
+ ["Read a search group..." gnus-group-read-ephemeral-search-group t]
+ ["Make a search group..." gnus-group-make-search-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]
@@ -1031,7 +1042,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and
;; (gnus-group-find-new-groups "???" nil)
(gnus-group-save-newsrc "save")
(gnus-group-describe-group "describe")
- (gnus-group-unsubscribe-current-group "gnus/toggle-subscription")
+ (gnus-group-toggle-subscription-at-point "gnus/toggle-subscription")
(gnus-group-prev-unread-group "left-arrow")
(gnus-group-next-unread-group "right-arrow")
(gnus-group-exit "exit")
@@ -1096,7 +1107,7 @@ When FORCE, rebuild the tool bar."
gnus-group-tool-bar-zap-list
'gnus-group-mode-map)))
(if map
- (set (make-local-variable 'tool-bar-map) map))))
+ (setq-local tool-bar-map map))))
gnus-group-tool-bar-map)
(define-derived-mode gnus-group-mode gnus-mode "Group"
@@ -1108,7 +1119,7 @@ The group buffer lists (some of) the groups available. For instance,
lists all zombie groups.
Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe
-to a group not displayed, type `\\[gnus-group-unsubscribe-group]'.
+to a group not displayed, type `\\[gnus-group-toggle-subscription]'.
For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
@@ -1129,8 +1140,8 @@ The following commands are available:
(gnus-update-group-mark-positions)
(when gnus-use-undo
(gnus-undo-mode 1))
- (when gnus-slave
- (gnus-slave-mode)))
+ (when gnus-child
+ (gnus-child-mode)))
(defun gnus-update-group-mark-positions ()
(save-excursion
@@ -1149,7 +1160,7 @@ The following commands are available:
(defun gnus-mouse-pick-group (e)
"Enter the group under the mouse pointer."
- (interactive "e")
+ (interactive "e" gnus-group-mode)
(mouse-set-point e)
(gnus-group-read-group nil))
@@ -1230,7 +1241,8 @@ Also see the `gnus-group-use-permanent-levels' variable."
(or
(gnus-group-default-level nil t)
(gnus-group-default-list-level)
- gnus-level-subscribed))))
+ gnus-level-subscribed)))
+ gnus-group-mode)
(unless level
(setq level (car gnus-group-list-mode)
unread (cdr gnus-group-list-mode)))
@@ -1281,7 +1293,7 @@ Also see the `gnus-group-use-permanent-levels' variable."
(defun gnus-group-list-level (level &optional all)
"List groups on LEVEL.
If ALL (the prefix), also list groups that have no unread articles."
- (interactive "nList groups on level: \nP")
+ (interactive "nList groups on level: \nP" gnus-group-mode)
(gnus-group-list-groups level all level))
(defun gnus-group-prepare-logic (group test)
@@ -1359,7 +1371,7 @@ if it is a string, only list groups matching REGEXP."
(and (>= level gnus-level-zombie)
(<= lowest gnus-level-zombie)))
(gnus-group-prepare-flat-list-dead
- (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ (setq gnus-zombie-list (sort gnus-zombie-list #'string<))
gnus-level-zombie ?Z
regexp))
(when not-in-list
@@ -1370,7 +1382,7 @@ if it is a string, only list groups matching REGEXP."
(gnus-group-prepare-flat-list-dead
(cl-union
not-in-list
- (setq gnus-killed-list (sort gnus-killed-list 'string<))
+ (setq gnus-killed-list (sort gnus-killed-list #'string<))
:test 'equal)
gnus-level-killed ?K regexp))
@@ -1495,12 +1507,16 @@ if it is a string, only list groups matching REGEXP."
(gnus-group-get-new-news 0))))
:type 'boolean)
-(defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level
- gnus-tmp-marked number
- gnus-tmp-method)
+(defun gnus-group-insert-group-line (group level marked number method)
"Insert a group line in the group buffer."
- (let* ((gnus-tmp-method
- (gnus-server-get-method gnus-tmp-group gnus-tmp-method))
+ (with-suppressed-warnings ((lexical number))
+ (defvar number)) ;FIXME: Used in `gnus-group-line-format-alist'.
+ (let* ((number number)
+ (gnus-tmp-level level)
+ (gnus-tmp-marked marked)
+ (gnus-tmp-group group)
+ (gnus-tmp-method
+ (gnus-server-get-method gnus-tmp-group method))
(gnus-tmp-active (gnus-active gnus-tmp-group))
(gnus-tmp-number-total
(if gnus-tmp-active
@@ -1539,7 +1555,8 @@ if it is a string, only list groups matching REGEXP."
(gnus-tmp-news-method-string
(if gnus-tmp-method
(format "(%s:%s)" (car gnus-tmp-method)
- (cadr gnus-tmp-method)) ""))
+ (cadr gnus-tmp-method))
+ ""))
(gnus-tmp-marked-mark
(if (and (numberp number)
(zerop number)
@@ -1562,7 +1579,7 @@ if it is a string, only list groups matching REGEXP."
(point)
(prog1 (1+ (point))
;; Insert the text.
- (eval gnus-group-line-format-spec))
+ (eval gnus-group-line-format-spec t))
`(gnus-group ,gnus-tmp-group
gnus-unread ,(if (numberp number)
(string-to-number gnus-tmp-number-of-unread)
@@ -1603,10 +1620,12 @@ Some value are bound so the form can use them."
(marked (gnus-info-marks info))
(env
(list
+ (cons 'group group)
(cons 'unread (if (numberp (car entry)) (car entry) 0))
+ (cons 'method method)
(cons 'total (if active (1+ (- (cdr active) (car active))) 0))
(cons 'mailp (apply
- 'append
+ #'append
(mapcar
(lambda (x)
(memq x (assoc
@@ -1733,7 +1752,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(buffer-modified-p gnus-dribble-buffer)
(with-current-buffer gnus-dribble-buffer
(not (zerop (buffer-size))))))
- (mode-string (eval gformat)))
+ (mode-string (eval gformat t)))
;; Say whether the dribble buffer has been modified.
(setq mode-line-modified
(if modified "**" "--"))
@@ -1743,7 +1762,8 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(prog1
(setq mode-line-buffer-identification
(gnus-mode-line-buffer-identification
- (list mode-string)))
+ (list (propertize mode-string
+ 'face 'mode-line-buffer-id))))
(set-buffer-modified-p modified))))))
(defun gnus-group-group-name ()
@@ -1768,7 +1788,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(get-text-property (point-at-bol) 'gnus-unread))
(defun gnus-group-new-mail (group)
- (if (nnmail-new-mail-p (gnus-group-real-name group))
+ (if (nnmail-new-mail-p group)
gnus-new-mail-mark
?\s))
@@ -1845,9 +1865,9 @@ If FIRST-TOO, the current line is also eligible as a target."
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(eq (char-after) gnus-process-mark)))
-(defun gnus-group-mark-group (n &optional unmark no-advance)
+(defun gnus-group-mark-group (n &optional unmark no-advance no-toggle)
"Mark the current group."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(let ((buffer-read-only nil)
group)
(while (and (> n 0)
@@ -1857,50 +1877,60 @@ If FIRST-TOO, the current line is also eligible as a target."
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(delete-char 1)
- (if unmark
- (progn
- (setq gnus-group-marked (delete group gnus-group-marked))
- (insert-char ?\s 1 t))
- (setq gnus-group-marked
- (cons group (delete group gnus-group-marked)))
- (insert-char gnus-process-mark 1 t)))
+ (if (and gnus-process-mark-toggle (not no-toggle))
+ (if (memq group gnus-group-marked)
+ (gnus-group-mark-update group t)
+ (gnus-group-mark-update group))
+ (gnus-group-mark-update group unmark)))
(unless no-advance
(gnus-group-next-group 1))
(cl-decf n))
(gnus-group-position-point)
n))
+(defun gnus-group-mark-update (n &optional unmark)
+ "Set the process mark on current group and update the group line."
+ (if unmark
+ (progn
+ (setq gnus-group-marked
+ (delete n gnus-group-marked))
+ (insert-char ?\s 1 t))
+ (progn
+ (setq gnus-group-marked
+ (cons n (delete n gnus-group-marked)))
+ (insert-char gnus-process-mark 1 t))))
+
(defun gnus-group-unmark-group (n)
"Remove the mark from the current group."
- (interactive "p")
- (gnus-group-mark-group n 'unmark)
+ (interactive "p" gnus-group-mode)
+ (gnus-group-mark-group n 'unmark nil t)
(gnus-group-position-point))
(defun gnus-group-unmark-all-groups ()
"Unmark all groups."
- (interactive)
+ (interactive nil gnus-group-mode)
(save-excursion
- (mapc 'gnus-group-remove-mark gnus-group-marked))
+ (mapc #'gnus-group-remove-mark gnus-group-marked))
(gnus-group-position-point))
(defun gnus-group-mark-region (unmark beg end)
"Mark all groups between point and mark.
If UNMARK, remove the mark instead."
- (interactive "P\nr")
+ (interactive "P\nr" gnus-group-mode)
(let ((num (count-lines beg end)))
(save-excursion
(goto-char beg)
- (- num (gnus-group-mark-group num unmark)))))
+ (- num (gnus-group-mark-group num unmark nil t)))))
(defun gnus-group-mark-buffer (&optional unmark)
"Mark all groups in the buffer.
If UNMARK, remove the mark instead."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-mark-region unmark (point-min) (point-max)))
(defun gnus-group-mark-regexp (regexp)
"Mark all groups that match some regexp."
- (interactive "sMark (regexp): ")
+ (interactive "sMark (regexp): " gnus-group-mode)
(let ((alist (cdr gnus-newsrc-alist))
group)
(save-excursion
@@ -1915,7 +1945,7 @@ If UNMARK, remove the mark instead."
Return nil if the group isn't displayed."
(if (gnus-group-goto-group group nil test-marked)
(save-excursion
- (gnus-group-mark-group 1 'unmark t)
+ (gnus-group-mark-group 1 'unmark t t)
t)
(setq gnus-group-marked
(delete group gnus-group-marked))
@@ -1925,10 +1955,10 @@ Return nil if the group isn't displayed."
"Set the process mark on GROUP."
(if (gnus-group-goto-group group)
(save-excursion
- (gnus-group-mark-group 1 nil t))
+ (gnus-group-mark-group 1 nil t t))
(setq gnus-group-marked (cons group (delete group gnus-group-marked)))))
-(defun gnus-group-universal-argument (arg &optional groups func)
+(defun gnus-group-universal-argument (arg &optional _groups func)
"Perform any command on all groups according to the process/prefix convention."
(interactive "P")
(if (eq (setq func (or func
@@ -1939,7 +1969,7 @@ Return nil if the group isn't displayed."
'undefined)
(gnus-error 1 "Undefined key")
(gnus-group-iterate arg
- (lambda (group)
+ (lambda (_group)
(command-execute func))))
(gnus-group-position-point))
@@ -1982,31 +2012,18 @@ Take into consideration N (the prefix) and the list of marked groups."
(let ((group (gnus-group-group-name)))
(and group (list group))))))
-;;; !!!Surely gnus-group-iterate should be a macro instead? I can't
-;;; imagine why I went through these contortions...
-(eval-and-compile
- (let ((function (make-symbol "gnus-group-iterate-function"))
- (window (make-symbol "gnus-group-iterate-window"))
- (groups (make-symbol "gnus-group-iterate-groups"))
- (group (make-symbol "gnus-group-iterate-group")))
- (eval
- `(defun gnus-group-iterate (arg ,function)
- "Iterate FUNCTION over all process/prefixed groups.
+(defun gnus-group-iterate (arg function)
+ "Iterate FUNCTION over all process/prefixed groups.
FUNCTION will be called with the group name as the parameter
and with point over the group in question."
- (let ((,groups (gnus-group-process-prefix arg))
- (,window (selected-window))
- ,group)
- (while ,groups
- (setq ,group (car ,groups)
- ,groups (cdr ,groups))
- (select-window ,window)
- (gnus-group-remove-mark ,group)
- (save-selected-window
- (save-excursion
- (funcall ,function ,group)))))))))
-
-(put 'gnus-group-iterate 'lisp-indent-function 1)
+ (declare (indent 1))
+ (let ((window (selected-window)))
+ (dolist (group (gnus-group-process-prefix arg))
+ (select-window window)
+ (gnus-group-remove-mark group)
+ (save-selected-window
+ (save-excursion
+ (funcall function group))))))
;; Selecting groups.
@@ -2022,7 +2039,7 @@ number of the earliest articles in the group.
If the optional argument NO-ARTICLE is non-nil, no article will
be auto-selected upon group entry. If GROUP is non-nil, fetch
that group."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((no-display (eq all 0))
(group (or group (gnus-group-group-name)))
number active marked entry)
@@ -2056,11 +2073,17 @@ If ALL is a positive number, fetch this number of the latest
articles in the group.
If ALL is a negative number, fetch this number of the earliest
articles in the group."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(when (and (eobp) (not (gnus-group-group-name)))
(forward-line -1))
(gnus-group-read-group all t))
+(defvar gnus-visual)
+(defvar gnus-score-find-score-files-function)
+(defvar gnus-home-score-file)
+(defvar gnus-apply-kill-hook)
+(defvar gnus-summary-expunge-below)
+
(defun gnus-group-quick-select-group (&optional all group)
"Select the GROUP \"quickly\".
This means that no highlighting or scoring will be performed. If
@@ -2069,7 +2092,7 @@ buffer. If GROUP is nil, use current group.
This might be useful if you want to toggle threading
before entering the group."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(require 'gnus-score)
(let (gnus-visual
gnus-score-find-score-files-function
@@ -2080,7 +2103,7 @@ before entering the group."
(defun gnus-group-visible-select-group (&optional all)
"Select the current group without hiding any articles."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((gnus-inhibit-limiting t))
(gnus-group-read-group all t)))
@@ -2089,7 +2112,7 @@ before entering the group."
You will actually be entered into a group that's a copy of
the current group; no changes you make while in this group will
be permanent."
- (interactive)
+ (interactive nil gnus-group-mode)
(require 'gnus-score)
(let* (gnus-visual
gnus-score-find-score-files-function gnus-apply-kill-hook
@@ -2321,7 +2344,8 @@ specified by `gnus-gmane-group-download-format'."
(list
(gnus-group-completing-read "Gmane group")
(read-number "Start article number: ")
- (read-number "How many articles: ")))
+ (read-number "How many articles: "))
+ gnus-group-mode)
(unless range (setq range 500))
(when (< range 1)
(error "Invalid range: %s" range))
@@ -2355,8 +2379,7 @@ Valid input formats include:
;; - The URLs should be added to `gnus-button-alist'. Probably we should
;; 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")))
+ (interactive (list (gnus-group-completing-read "Gmane URL")) gnus-group-mode)
(let (group start range)
(cond
;; URLs providing `group', `start' and `range':
@@ -2411,13 +2434,13 @@ the bug number, and browsing the URL must return mbox output."
(require 'bug-reference)
(let ((def (cond ((thing-at-point-looking-at bug-reference-bug-regexp 500)
(match-string 2))
- ((number-at-point)))))
+ ((and (number-at-point)
+ (abs (number-at-point)))))))
;; Pass DEF as the value of COLLECTION instead of DEF because:
;; a) null input should not cause DEF to be returned and
;; b) TAB and M-n still work this way.
- (or (completing-read-multiple
- (format "Bug IDs%s: " (if def (format " (default %s)" def) ""))
- (and def (list (format "%s" def))))
+ (or (completing-read-multiple (format-prompt "Bug IDs" def)
+ (and def (list (format "%s" def))))
def)))
(defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf)
@@ -2449,7 +2472,8 @@ the ephemeral group."
(with-temp-file tmpfile
(mm-disable-multibyte)
(dolist (id ids)
- (let ((file (concat "~/.emacs.d/debbugs-cache/" id)))
+ (let ((file (expand-file-name id (locate-user-emacs-file
+ "debbugs-cache"))))
(if (and (not gnus-plugged)
(file-exists-p file))
(insert-file-contents file)
@@ -2518,7 +2542,7 @@ The arguments have the same meaning as those of
(if (stringp id) (setq id (string-to-number id)))
(setq-local debbugs-gnu-bug-number id)))))
-(defun gnus-group-jump-to-group (group &optional prompt)
+(defun gnus-group-jump-to-group (group &optional _prompt)
"Jump to newsgroup GROUP.
If PROMPT (the prefix) is a number, use the prompt specified in
@@ -2531,7 +2555,8 @@ If PROMPT (the prefix) is a number, use the prompt specified in
(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)))))))
+ (and (stringp p) p))))))
+ gnus-group-mode)
(when (equal group "")
(error "Empty group name"))
@@ -2600,7 +2625,7 @@ Return nil if GROUP is not found."
If N is negative, search backward instead.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(gnus-group-next-unread-group n t nil silent))
(defun gnus-group-next-unread-group (n &optional all level silent)
@@ -2612,7 +2637,7 @@ such group can be found, the next group with a level higher than
LEVEL.
Returns the difference between N and the number of skips actually
made."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(let ((backward (< n 0))
(n (abs n)))
(while (and (> n 0)
@@ -2629,14 +2654,14 @@ made."
"Go to previous N'th newsgroup.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(gnus-group-next-unread-group (- n) t))
(defun gnus-group-prev-unread-group (n)
"Go to previous N'th unread newsgroup.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(gnus-group-next-unread-group (- n)))
(defun gnus-group-next-unread-group-same-level (n)
@@ -2644,7 +2669,7 @@ done."
If N is negative, search backward instead.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(gnus-group-next-unread-group n t (gnus-group-group-level))
(gnus-group-position-point))
@@ -2652,14 +2677,14 @@ done."
"Go to next N'th unread newsgroup on the same level.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(gnus-group-next-unread-group (- n) t (gnus-group-group-level))
(gnus-group-position-point))
(defun gnus-group-best-unread-group (&optional exclude-group)
"Go to the group with the highest level.
If EXCLUDE-GROUP, do not go to that group."
- (interactive)
+ (interactive nil gnus-group-mode)
(goto-char (point-min))
(let ((best 100000)
unread best-point)
@@ -2699,7 +2724,7 @@ If EXCLUDE-GROUP, do not go to that group."
(defun gnus-group-first-unread-group ()
"Go to the first group with unread articles."
- (interactive)
+ (interactive nil gnus-group-mode)
(prog1
(let ((opoint (point))
unread)
@@ -2715,13 +2740,13 @@ If EXCLUDE-GROUP, do not go to that group."
(defun gnus-group-enter-server-mode ()
"Jump to the server buffer."
- (interactive)
+ (interactive nil gnus-group-mode)
(gnus-enter-server-buffer))
(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)))
+ (interactive (list (gnus-group-completing-read)) gnus-group-mode)
(gnus-group-make-group (gnus-group-real-name group)
(gnus-group-server group)
nil nil))
@@ -2737,7 +2762,8 @@ server."
(interactive
(list
(gnus-read-group "Group name: ")
- (gnus-read-method "Select method for new group (use tab for completion)")))
+ (gnus-read-method "Select method for new group (use tab for completion)"))
+ gnus-group-mode)
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
@@ -2782,7 +2808,7 @@ server."
(defun gnus-group-delete-groups (&optional arg)
"Delete the current group. Only meaningful with editable groups."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((n (length (gnus-group-process-prefix arg))))
(when (gnus-yes-or-no-p
(if (= n 1)
@@ -2797,14 +2823,14 @@ server."
If OLDP (the prefix), only delete articles that are \"old\",
according to the expiry settings. Note that this will delete old
not-expirable articles, too."
- (interactive (list (gnus-group-group-name)
- current-prefix-arg))
+ (interactive (list (gnus-group-group-name) current-prefix-arg)
+ gnus-group-mode)
(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
- (if current-prefix-arg
+ (if oldp
nil
'force)))))
@@ -2817,9 +2843,8 @@ doing the deletion.
Note that you also have to specify FORCE if you want the group to
be removed from the server, even when it's empty."
- (interactive
- (list (gnus-group-group-name)
- current-prefix-arg))
+ (interactive (list (gnus-group-group-name) current-prefix-arg)
+ gnus-group-mode)
(unless group
(error "No group to delete"))
(unless (gnus-check-backend-function 'request-delete-group group)
@@ -2853,7 +2878,8 @@ and NEW-NAME will be prompted for."
"Rename group to: "
(gnus-group-real-name group))
method (gnus-info-method (gnus-get-info group)))
- (list group (gnus-group-prefixed-name new-name method))))
+ (list group (gnus-group-prefixed-name new-name method)))
+ gnus-group-mode)
(unless (gnus-check-backend-function 'request-rename-group group)
(error "This back end does not support renaming groups"))
@@ -2899,7 +2925,7 @@ and NEW-NAME will be prompted for."
(defun gnus-group-edit-group (group &optional part)
"Edit the group on the current line."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(let ((part (or part 'info))
info)
(unless group
@@ -2923,8 +2949,8 @@ and NEW-NAME will be prompted for."
((eq part 'params) "group parameters")
(t "group info"))
group)
- `(lambda (form)
- (gnus-group-edit-group-done ',part ,group form)))
+ (lambda (form)
+ (gnus-group-edit-group-done part group form)))
(local-set-key
"\C-c\C-i"
(gnus-create-info-command
@@ -2938,12 +2964,12 @@ and NEW-NAME will be prompted for."
(defun gnus-group-edit-group-method (group)
"Edit the select method of GROUP."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(gnus-group-edit-group group 'method))
(defun gnus-group-edit-group-parameters (group)
"Edit the group parameters of GROUP."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(gnus-group-edit-group group 'params))
(defun gnus-group-edit-group-done (part group form)
@@ -2981,18 +3007,20 @@ 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 (gnus-completing-read "Create group"
- (mapcar 'car gnus-useful-groups)
- 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'
- ;; form won't be expanded.
- (car (cddr entry)))))
+ ;; Don't use `caddr' here since macros within the
+ ;; `interactive' form won't be expanded.
+ (car (cddr entry))))
+ gnus-group-mode)
(setq method (copy-tree method))
(let (entry)
(while (setq entry (memq (assq 'eval method) method))
- (setcar entry (eval (cadar entry)))))
+ (setcar entry (eval (cadar entry) t))))
(gnus-group-make-group group method))
(defun gnus-group-make-help-group (&optional noerror)
@@ -3002,7 +3030,7 @@ group already exists:
- if not given, and error is signaled,
- if t, stay silent,
- if anything else, just print a message."
- (interactive)
+ (interactive nil gnus-group-mode)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
(file (nnheader-find-etc-directory "gnus-tut.txt" t)))
(if (gnus-group-entry name)
@@ -3028,9 +3056,9 @@ group already exists:
"Create a group that uses a single file as the source.
If called with a prefix argument, ask for the file type."
- (interactive
- (list (read-file-name "File name: ")
- (and current-prefix-arg 'ask)))
+ (interactive (list (read-file-name "File name: ")
+ (and current-prefix-arg 'ask))
+ gnus-group-mode)
(when (eq type 'ask)
(let ((err "")
char found)
@@ -3065,7 +3093,7 @@ If called with a prefix argument, ask for the file type."
(defun gnus-group-make-web-group (&optional solid)
"Create an ephemeral nnweb group.
If SOLID (the prefix), create a solid group."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(require 'nnweb)
(let* ((group
(if solid (gnus-read-group "Group name: ")
@@ -3105,7 +3133,7 @@ If SOLID (the prefix), create a solid group."
(defun gnus-group-make-rss-group (&optional url)
"Given a URL, discover if there is an RSS feed.
If there is, use Gnus to create an nnrss group"
- (interactive)
+ (interactive nil gnus-group-mode)
(require 'nnrss)
(if (not url)
(setq url (read-from-minibuffer "URL to Search for RSS: ")))
@@ -3115,7 +3143,7 @@ If there is, use Gnus to create an nnrss group"
(read-from-minibuffer "Title: "
(gnus-newsgroup-savable-name
(mapconcat
- 'identity
+ #'identity
(split-string
(or (cdr (assoc 'title
feedinfo))
@@ -3123,7 +3151,7 @@ If there is, use Gnus to create an nnrss group"
" ")))))
(desc (read-from-minibuffer "Description: "
(mapconcat
- 'identity
+ #'identity
(split-string
(or (cdr (assoc 'description
feedinfo))
@@ -3146,8 +3174,8 @@ If there is, use Gnus to create an nnrss 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-directory-name "Create group from directory: ")))
+ (interactive (list (read-directory-name "Create group from directory: "))
+ gnus-group-mode)
(unless (file-exists-p dir)
(error "No such directory"))
(unless (file-directory-p dir)
@@ -3165,12 +3193,119 @@ 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)))))
+(autoload 'gnus-group-topic-name "gnus-topic")
+(autoload 'gnus-search-make-spec "gnus-search")
+
+;; Temporary to make group creation easier
+(defun gnus-group-make-search-group (no-parse &optional specs)
+ "Make a group based on a search.
+Prompt for a search query and determine the groups to search as
+follows: if called from the *Server* buffer search all groups
+belonging to the server on the current line; if called from the
+*Group* buffer search any marked groups, or the group on the
+current line, or all the groups under the current topic. A
+prefix arg NO-PARSE means that Gnus should not parse the search
+query before passing it to the underlying search engine. A
+non-nil SPECS arg must be an alist with `search-query-spec' and
+`search-group-spec' keys, and skips all prompting."
+ (interactive "P" gnus-group-mode)
+ (let ((name (gnus-read-group "Group name: ")))
+ (with-current-buffer gnus-group-buffer
+ (let* ((group-spec
+ (or
+ (cdr (assq 'search-group-spec specs))
+ (cdr (assq 'nnir-group-spec specs))
+ (if (gnus-server-server-name)
+ (list (list (gnus-server-server-name)))
+ (seq-group-by
+ (lambda (elt) (gnus-group-server elt))
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (mapcar #'caadr
+ (gnus-topic-find-groups
+ (gnus-group-topic-name)
+ nil 'all nil t))))))))
+ (query-spec
+ (or
+ (cdr (assq 'search-query-spec specs))
+ (cdr (assq 'nnir-query-spec specs))
+ (gnus-search-make-spec no-parse))))
+ ;; If our query came via an old call to nnir, we know not to
+ ;; parse the query.
+ (when (assq 'nnir-query-spec specs)
+ (setf (alist-get 'raw query-spec) t))
+ (gnus-group-make-group
+ name
+ (list 'nnselect "nnselect")
+ nil
+ (list
+ (cons 'nnselect-specs
+ (list
+ (cons 'nnselect-function 'gnus-search-run-query)
+ (cons 'nnselect-args
+ (list (cons 'search-query-spec query-spec)
+ (cons 'search-group-spec group-spec)))))
+ (cons 'nnselect-artlist nil)))))))
+
+(define-obsolete-function-alias 'gnus-group-make-nnir-group
+ 'gnus-group-read-ephemeral-search-group "28.1")
+
+(defun gnus-group-read-ephemeral-search-group (no-parse &optional specs)
+ "Read an nnselect group based on a search.
+Prompt for a search query and determine the groups to search as
+follows: if called from the *Server* buffer search all groups
+belonging to the server on the current line; if called from the
+*Group* buffer search any marked groups, or the group on the
+current line, or all the groups under the current topic. A
+prefix arg NO-PARSE means that Gnus should not parse the search
+query before passing it to the underlying search engine. A
+non-nil SPECS arg must be an alist with `search-query-spec' and
+`search-group-spec' keys, and skips all prompting."
+ (interactive "P" gnus-group-mode)
+ (let* ((group-spec
+ (or (cdr (assq 'search-group-spec specs))
+ (cdr (assq 'nnir-group-spec specs))
+ (if (gnus-server-server-name)
+ (list (list (gnus-server-server-name)))
+ (seq-group-by
+ (lambda (elt) (gnus-group-server elt))
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (mapcar #'caadr
+ (gnus-topic-find-groups
+ (gnus-group-topic-name)
+ nil 'all nil t))))))))
+ (query-spec
+ (or (cdr (assq 'search-query-spec specs))
+ (cdr (assq 'nnir-query-spec specs))
+ (gnus-search-make-spec no-parse))))
+ ;; If our query came via an old call to nnir, we know not to parse
+ ;; the query.
+ (when (assq 'nnir-query-spec specs)
+ (setf (alist-get 'raw query-spec) t))
+ (gnus-group-read-ephemeral-group
+ (concat "nnselect-" (message-unique-id))
+ (list 'nnselect "nnselect")
+ nil
+ (cons (current-buffer) gnus-current-window-configuration)
+ nil nil
+ (list
+ (cons 'nnselect-specs
+ (list
+ (cons 'nnselect-function 'gnus-search-run-query)
+ (cons 'nnselect-args
+ (list (cons 'search-query-spec query-spec)
+ (cons 'search-group-spec group-spec)))))
+ (cons 'nnselect-artlist nil)))))
+
(defun gnus-group-add-to-virtual (n vgroup)
"Add the current group to a virtual group."
- (interactive
- (list current-prefix-arg
- (gnus-group-completing-read "Add to virtual group"
- nil t "nnvirtual:")))
+ (interactive (list current-prefix-arg
+ (gnus-group-completing-read "Add to virtual group"
+ nil t "nnvirtual:"))
+ gnus-group-mode)
(unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
(error "%s is not an nnvirtual group" vgroup))
(gnus-close-group vgroup)
@@ -3188,7 +3323,7 @@ mail messages or news articles in files that have numeric names."
(defun gnus-group-make-empty-virtual (group)
"Create a new, fresh, empty virtual group."
- (interactive "sCreate new, empty virtual group: ")
+ (interactive "sCreate new, empty virtual group: " gnus-group-mode)
(let* ((method (list 'nnvirtual "^$"))
(pgroup (gnus-group-prefixed-name group method)))
;; Check whether it exists already.
@@ -3202,7 +3337,7 @@ mail messages or news articles in files that have numeric names."
(defun gnus-group-enter-directory (dir)
"Enter an ephemeral nneething group."
- (interactive "DDirectory to read: ")
+ (interactive "DDirectory to read: " gnus-group-mode)
(let* ((method (list 'nneething dir '(nneething-read-only t)))
(leaf (gnus-group-prefixed-name
(file-name-nondirectory (directory-file-name dir))
@@ -3217,7 +3352,7 @@ mail messages or news articles in files that have numeric names."
(defun gnus-group-expunge-group (group)
"Expunge deleted articles in current nnimap GROUP."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(let ((method (gnus-find-method-for-group group)))
(if (not (gnus-check-backend-function
'request-expunge-group (car method)))
@@ -3229,7 +3364,7 @@ mail messages or news articles in files that have numeric names."
(defun gnus-group-nnimap-edit-acl (group)
"Edit the Access Control List of current nnimap GROUP."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(let ((mailbox (gnus-group-real-name group)) method acl)
(unless group
(error "No group on current line"))
@@ -3264,9 +3399,9 @@ Editing the access control list for `%s'.
implementation-defined hierarchy, RENAME or DELETE mailbox)
d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
a - administer (perform SETACL)" group)
- `(lambda (form)
- (nnimap-acl-edit
- ,mailbox ',method ',acl form)))))
+ (lambda (form)
+ (nnimap-acl-edit
+ mailbox method acl form)))))
;; Group sorting commands
;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
@@ -3276,7 +3411,8 @@ Editing the access control list for `%s'.
When used interactively, the sorting function used will be
determined by the `gnus-group-sort-function' variable.
If REVERSE (the prefix), reverse the sorting order."
- (interactive (list gnus-group-sort-function current-prefix-arg))
+ (interactive (list gnus-group-sort-function current-prefix-arg)
+ gnus-group-mode)
(funcall gnus-group-sort-alist-function
(gnus-make-sort-function func) reverse)
(gnus-group-unmark-all-groups)
@@ -3309,56 +3445,57 @@ value is disregarded."
(defun gnus-group-sort-groups-by-alphabet (&optional reverse)
"Sort the group buffer alphabetically by group name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse))
(defun gnus-group-sort-groups-by-real-name (&optional reverse)
"Sort the group buffer alphabetically by real (unprefixed) group name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse))
(defun gnus-group-sort-groups-by-unread (&optional reverse)
"Sort the group buffer by number of unread articles.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-unread reverse))
(defun gnus-group-sort-groups-by-level (&optional reverse)
"Sort the group buffer by group level.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-level reverse))
(defun gnus-group-sort-groups-by-score (&optional reverse)
"Sort the group buffer by group score.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-score reverse))
(defun gnus-group-sort-groups-by-rank (&optional reverse)
"Sort the group buffer by group rank.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-rank reverse))
(defun gnus-group-sort-groups-by-method (&optional reverse)
"Sort the group buffer alphabetically by back end name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-method reverse))
(defun gnus-group-sort-groups-by-server (&optional reverse)
"Sort the group buffer alphabetically by server name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-sort-groups 'gnus-group-sort-by-server reverse))
;;; Selected group sorting.
(defun gnus-group-sort-selected-groups (n func &optional reverse)
"Sort the process/prefixed groups."
- (interactive (list current-prefix-arg gnus-group-sort-function))
+ (interactive (list current-prefix-arg gnus-group-sort-function)
+ gnus-group-mode)
(let ((groups (gnus-group-process-prefix n)))
(funcall gnus-group-sort-selected-function
groups (gnus-make-sort-function func) reverse)
@@ -3390,49 +3527,49 @@ If REVERSE is non-nil, reverse the sorting."
"Sort the group buffer alphabetically by group name.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
(defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse)
"Sort the group buffer alphabetically by real group name.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-real-name reverse))
(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
"Sort the group buffer by number of unread articles.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
"Sort the group buffer by group level.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
"Sort the group buffer by group score.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
"Sort the group buffer by group rank.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
"Sort the group buffer alphabetically by back end name.
Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
sort in reverse order."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-group-mode)
(gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
;;; Sorting predicates.
@@ -3490,7 +3627,7 @@ sort in reverse order."
(defun gnus-group-clear-data (&optional arg)
"Clear all marks and read ranges from the current group.
Obeys the process/prefix convention."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(when (gnus-y-or-n-p "Really clear data? ")
(gnus-group-iterate arg
(lambda (group)
@@ -3502,7 +3639,7 @@ Obeys the process/prefix convention."
(defun gnus-group-clear-data-on-native-groups ()
"Clear all marks and read ranges from all native groups."
- (interactive)
+ (interactive nil gnus-group-mode)
(when (gnus-yes-or-no-p "Really clear all data from almost all groups? ")
(let ((alist (cdr gnus-newsrc-alist))
info)
@@ -3546,7 +3683,7 @@ caught up. If ALL is non-nil, marked articles will also be marked as
read. Cross references (Xref: header) of articles are ignored.
The number of newsgroups that this function was unable to catch
up is returned."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((groups (gnus-group-process-prefix n))
(ret 0)
group)
@@ -3585,7 +3722,7 @@ up is returned."
(defun gnus-group-catchup-current-all (&optional n)
"Mark all articles in current newsgroup as read.
Cross references (Xref: header) of articles are ignored."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-catchup-current n 'all))
(declare-function gnus-sequence-of-unread-articles "gnus-sum" (group))
@@ -3600,7 +3737,7 @@ or nil if no action could be taken."
(marks (gnus-info-marks (nth 1 entry)))
(unread (gnus-sequence-of-unread-articles group)))
;; Remove entries for this group.
- (nnmail-purge-split-history (gnus-group-real-name group))
+ (nnmail-purge-split-history group)
;; Do the updating only if the newsgroup isn't killed.
(if (not (numberp (car entry)))
(gnus-message 1 "Can't catch up %s; non-active group" group)
@@ -3632,7 +3769,7 @@ or nil if no action could be taken."
(defun gnus-group-expire-articles (&optional n)
"Expire all expirable articles in the current newsgroup.
Uses the process/prefix convention."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((groups (gnus-group-process-prefix n))
group)
(unless groups
@@ -3678,7 +3815,7 @@ Uses the process/prefix convention."
(defun gnus-group-expire-all-groups ()
"Expire all expirable articles in all newsgroups."
- (interactive)
+ (interactive nil gnus-group-mode)
(save-excursion
(gnus-message 5 "Expiring...")
(let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info))
@@ -3697,13 +3834,13 @@ Uses the process/prefix convention."
(error "No group on the current line"))
(string-to-number
(let ((s (read-string
- (format "Level (default %s): "
- (or (gnus-group-group-level)
- gnus-level-default-subscribed)))))
+ (format-prompt "Level" (or (gnus-group-group-level)
+ gnus-level-default-subscribed)))))
(if (string-match "^\\s-*$" s)
(int-to-string (or (gnus-group-group-level)
gnus-level-default-subscribed))
- s))))))
+ s)))))
+ gnus-group-mode)
(unless (and (>= level 1) (<= level gnus-level-killed))
(error "Invalid level: %d" level))
(dolist (group (gnus-group-process-prefix n))
@@ -3719,61 +3856,91 @@ Uses the process/prefix convention."
(defun gnus-group-unsubscribe (&optional n)
"Unsubscribe the current group."
- (interactive "P")
- (gnus-group-unsubscribe-current-group n 'unsubscribe))
+ (interactive "P" gnus-group-mode)
+ (gnus-group-set-subscription-at-point n 'unsubscribe))
(defun gnus-group-subscribe (&optional n)
"Subscribe the current group."
- (interactive "P")
- (gnus-group-unsubscribe-current-group n 'subscribe))
+ (interactive "P" gnus-group-mode)
+ (gnus-group-set-subscription-at-point n 'subscribe))
+
+(defsubst gnus-group-unsubscribe-current-group (&optional n do-sub)
+ (if do-sub
+ (gnus-group-set-subscription-at-point n do-sub)
+ (gnus-group-toggle-subscription-at-point n)))
+
+(defsubst gnus-group-unsubscribe-group (group &optional level silent)
+ (if level
+ (gnus-group-set-subscription group level silent)
+ (gnus-group-toggle-subscription group silent)))
+
+(make-obsolete 'gnus-group-unsubscribe-current-group
+ 'gnus-group-toggle-subscription-at-point "28.1")
-(defun gnus-group-unsubscribe-current-group (&optional n do-sub)
+(make-obsolete 'gnus-group-unsubscribe-group
+ 'gnus-group-toggle-subscription "28.1")
+
+(defun gnus-group-toggle-subscription-at-point (&optional n)
"Toggle subscription of the current group.
If given numerical prefix, toggle the N next groups."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
+ (gnus-group-set-subscription-at-point n 'toggle))
+
+(defun gnus-group-set-subscription-at-point (n do-sub)
+ "Set subscription of the current group for next N groups."
(dolist (group (gnus-group-process-prefix n))
(gnus-group-remove-mark group)
- (gnus-group-unsubscribe-group
+ (gnus-group-set-subscription
group
- (cond
- ((eq do-sub 'unsubscribe)
- gnus-level-default-unsubscribed)
- ((eq do-sub 'subscribe)
- gnus-level-default-subscribed)
- ((<= (gnus-group-group-level) gnus-level-subscribed)
- gnus-level-default-unsubscribed)
- (t
- gnus-level-default-subscribed))
+ (cl-case do-sub
+ (unsubscribe gnus-level-default-unsubscribed)
+ (subscribe gnus-level-default-subscribed)
+ (toggle (if (<= (gnus-group-group-level) gnus-level-subscribed)
+ gnus-level-default-unsubscribed
+ gnus-level-default-subscribed))
+ (t (error "Unknown subscription setting %s" do-sub)))
t)
(gnus-group-update-group-line))
(gnus-group-next-group 1))
-(defun gnus-group-unsubscribe-group (group &optional level silent)
- "Toggle subscription to GROUP.
+(defun gnus-group-toggle-subscription (group &optional silent)
+ (interactive (list (gnus-group-completing-read
+ nil nil (gnus-read-active-file-p)))
+ gnus-group-mode)
+ (let* ((newsrc (gnus-group-entry group))
+ (level (cond
+ (newsrc
+ ;; Toggle subscription flag.
+ (if (<= (gnus-info-level (nth 1 newsrc))
+ gnus-level-subscribed)
+ (1+ gnus-level-subscribed)
+ gnus-level-default-subscribed))
+ ((and (stringp group)
+ (or (not (gnus-read-active-file-p))
+ (gnus-active group)))
+ ;; Add new newsgroup.
+ gnus-level-default-subscribed)
+ (t 'unsubscribe))))
+ (gnus-group-set-subscription group level silent)))
+
+(defun gnus-group-set-subscription (group level &optional silent)
+ "Set subscription of GROUP to LEVEL.
Killed newsgroups are subscribed. If SILENT, don't try to update the
group line."
- (interactive (list (gnus-group-completing-read
- nil nil (gnus-read-active-file-p))))
(let ((newsrc (gnus-group-entry group)))
(cond
((string-match "\\`[ \t]*\\'" group)
(error "Empty group name"))
(newsrc
- ;; Toggle subscription flag.
- (gnus-group-change-level
- newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc))
- gnus-level-subscribed)
- (1+ gnus-level-subscribed)
- gnus-level-default-subscribed)))
+ (gnus-group-change-level newsrc level)
(unless silent
(gnus-group-update-group group)))
((and (stringp group)
(or (not (gnus-read-active-file-p))
(gnus-active group)))
- ;; Add new newsgroup.
(gnus-group-change-level
group
- (if level level gnus-level-default-subscribed)
+ level
(or (and (member group gnus-zombie-list)
gnus-level-zombie)
gnus-level-killed)
@@ -3787,7 +3954,7 @@ group line."
"Move the current newsgroup up N places.
If given a negative prefix, move down instead. The difference between
N and the number of steps taken is returned."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(unless (gnus-group-group-name)
(error "No group on current line"))
(gnus-group-kill-group 1)
@@ -3799,7 +3966,8 @@ N and the number of steps taken is returned."
(defun gnus-group-kill-all-zombies (&optional dummy)
"Kill all zombie newsgroups.
The optional DUMMY should always be nil."
- (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? "))))
+ (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? ")))
+ gnus-group-mode)
(unless dummy
(setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
(setq gnus-zombie-list nil)
@@ -3809,7 +3977,7 @@ The optional DUMMY should always be nil."
(defun gnus-group-kill-region (begin end)
"Kill newsgroups in current region (excluding current point).
The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
- (interactive "r")
+ (interactive "r" gnus-group-mode)
(let ((lines
;; Count lines.
(save-excursion
@@ -3831,7 +3999,7 @@ However, only groups that were alive can be yanked; already killed
groups or zombie groups can't be yanked.
The return value is the name of the group that was killed, or a list
of groups killed."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((buffer-read-only nil)
(groups (gnus-group-process-prefix n))
group entry level out)
@@ -3891,7 +4059,7 @@ of groups killed."
The numeric ARG specifies how many newsgroups are to be yanked. The
name of the newsgroup yanked is returned, or (if several groups are
yanked) a list of yanked groups is returned."
- (interactive "p")
+ (interactive "p" gnus-group-mode)
(setq arg (or arg 1))
(let (info group prev out)
(while (>= (cl-decf arg) 0)
@@ -3916,7 +4084,7 @@ yanked) a list of yanked groups is returned."
(defun gnus-group-kill-level (level)
"Kill all groups that is on a certain LEVEL."
- (interactive "nKill all groups on level: ")
+ (interactive "nKill all groups on level: " gnus-group-mode)
(cond
((= level gnus-level-zombie)
(setq gnus-killed-list
@@ -3947,7 +4115,7 @@ yanked) a list of yanked groups is returned."
"List all newsgroups with level ARG or lower.
Default is `gnus-level-unsubscribed', which lists all subscribed and most
unsubscribed groups."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-group-list-groups (or arg gnus-level-unsubscribed) t))
;; Redefine this to list ALL killed groups if prefix arg used.
@@ -3956,7 +4124,7 @@ unsubscribed groups."
"List all killed newsgroups in the group buffer.
If ARG is non-nil, list ALL killed groups known to Gnus. This may
entail asking the server for the groups."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
;; Find all possible killed newsgroups if arg.
(when arg
(gnus-get-killed-groups))
@@ -3970,7 +4138,7 @@ entail asking the server for the groups."
(defun gnus-group-list-zombies ()
"List all zombie newsgroups in the group buffer."
- (interactive)
+ (interactive nil gnus-group-mode)
(if (not gnus-zombie-list)
(gnus-message 6 "No zombie groups")
(let (gnus-group-list-mode)
@@ -3981,7 +4149,7 @@ entail asking the server for the groups."
(defun gnus-group-list-active ()
"List all groups that are available from the server(s)."
- (interactive)
+ (interactive nil gnus-group-mode)
;; First we make sure that we have really read the active file.
(unless (gnus-read-active-file-p)
(let ((gnus-read-active-file t)
@@ -4003,7 +4171,7 @@ entail asking the server for the groups."
(defun gnus-activate-all-groups (level)
"Activate absolutely all groups."
- (interactive (list gnus-level-unsubscribed))
+ (interactive (list gnus-level-unsubscribed) gnus-group-mode)
(let ((gnus-activate-level level)
(gnus-activate-foreign-newsgroups level))
(gnus-group-get-new-news)))
@@ -4015,7 +4183,7 @@ re-scanning. If ARG is non-nil and not a number, this will force
\"hard\" re-reading of the active files from all servers.
If ONE-LEVEL is not nil, then re-scan only the specified level,
otherwise all levels below ARG will be scanned too."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(require 'nnmail)
(let ((gnus-inhibit-demon t)
;; Binding this variable will inhibit multiple fetchings
@@ -4024,9 +4192,9 @@ otherwise all levels below ARG will be scanned too."
(gnus-run-hooks 'gnus-get-top-new-news-hook)
(gnus-run-hooks 'gnus-get-new-news-hook)
- ;; Read any slave files.
- (unless gnus-slave
- (gnus-master-read-slave-newsrc))
+ ;; Read any child files.
+ (unless gnus-child
+ (gnus-parent-read-child-newsrc))
(gnus-get-unread-articles (gnus-group-default-level arg t)
nil one-level)
@@ -4045,7 +4213,7 @@ otherwise all levels below ARG will be scanned too."
The difference between N and the number of newsgroup checked is returned.
If N is negative, this group and the N-1 previous groups will be checked.
If DONT-SCAN is non-nil, scan non-activated groups as well."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let* ((groups (gnus-group-process-prefix n))
(ret (if (numberp n) (- n (length groups)) 0))
(beg (unless n
@@ -4090,7 +4258,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(defun gnus-group-describe-group (force &optional group)
"Display a description of the current newsgroup."
- (interactive (list current-prefix-arg (gnus-group-group-name)))
+ (interactive (list current-prefix-arg (gnus-group-group-name))
+ gnus-group-mode)
(let* ((method (gnus-find-method-for-group group))
(mname (gnus-group-prefixed-name "" method))
desc)
@@ -4112,7 +4281,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-group-describe-all-groups (&optional force)
"Pop up a buffer with descriptions of all newsgroups."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(when force
(setq gnus-description-hashtb nil))
(when (not (or gnus-description-hashtb
@@ -4137,7 +4306,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
;; Suggested by Daniel Quinlan <quinlan@best.com>.
(defun gnus-group-apropos (regexp &optional search-description)
"List all newsgroups that have names that match a regexp."
- (interactive "sGnus apropos (regexp): ")
+ (interactive "sGnus apropos (regexp): " gnus-group-mode)
(let ((prev "")
(obuf (current-buffer))
groups des)
@@ -4159,7 +4328,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(pop-to-buffer "*Gnus Help*")
(buffer-disable-undo)
(erase-buffer)
- (setq groups (sort groups 'string<))
+ (setq groups (sort groups #'string<))
(while groups
;; Groups may be entered twice into the list of groups.
(when (not (string= (car groups) prev))
@@ -4176,7 +4345,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(defun gnus-group-description-apropos (regexp)
"List all newsgroups that have names or descriptions that match REGEXP."
- (interactive "sGnus description apropos (regexp): ")
+ (interactive "sGnus description apropos (regexp): " gnus-group-mode)
(when (not (or gnus-description-hashtb
(gnus-read-all-descriptions-files)))
(error "Couldn't request descriptions file"))
@@ -4191,7 +4360,7 @@ If ALL, also list groups with no unread articles.
If LOWEST, don't list groups with level lower than LOWEST.
This command may read the active file."
- (interactive "P\nsList newsgroups matching: ")
+ (interactive "P\nsList newsgroups matching: " gnus-group-mode)
;; First make sure active file has been read.
(when (and level
(> (prefix-numeric-value level) gnus-level-killed))
@@ -4206,7 +4375,7 @@ This command may read the active file."
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."
- (interactive "P\nsList newsgroups matching: ")
+ (interactive "P\nsList newsgroups matching: " gnus-group-mode)
(when level
(setq level (prefix-numeric-value level)))
(gnus-group-list-matching (or level gnus-level-killed) regexp t lowest))
@@ -4215,12 +4384,12 @@ If LOWEST, don't list groups with level lower than LOWEST."
(defun gnus-group-save-newsrc (&optional force)
"Save the Gnus startup files.
If FORCE, force saving whether it is necessary or not."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-save-newsrc-file force))
-(defun gnus-group-restart (&optional arg)
+(defun gnus-group-restart (&optional _arg)
"Force Gnus to read the .newsrc file."
- (interactive "P")
+ (interactive nil gnus-group-mode)
(when (gnus-yes-or-no-p
(format "Are you sure you want to restart Gnus? "))
(gnus-save-newsrc-file)
@@ -4229,7 +4398,7 @@ If FORCE, force saving whether it is necessary or not."
(defun gnus-group-read-init-file ()
"Read the Gnus elisp init file."
- (interactive)
+ (interactive nil gnus-group-mode)
(gnus-read-init-file)
(gnus-message 5 "Read %s" gnus-init-file))
@@ -4237,7 +4406,7 @@ If FORCE, force saving whether it is necessary or not."
"Check bogus newsgroups.
If given a prefix, don't ask for confirmation before removing a bogus
group."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user)))
(gnus-group-list-groups))
@@ -4248,7 +4417,7 @@ With 1 C-u, use the `ask-server' method to query the server for new
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")
+ (interactive "p" gnus-group-mode)
(let ((new-groups (gnus-find-new-newsgroups (or arg 1)))
current-group)
(gnus-group-list-groups)
@@ -4261,7 +4430,7 @@ for new groups, and subscribe the new groups as zombies."
(defun gnus-group-edit-global-kill (&optional article group)
"Edit the global kill file.
If GROUP, edit that local kill file instead."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(setq gnus-current-kill-article article)
(gnus-kill-file-edit-file group)
(gnus-message 6 "Editing a %s kill file (Type %s to exit)"
@@ -4270,12 +4439,12 @@ If GROUP, edit that local kill file instead."
(defun gnus-group-edit-local-kill (article group)
"Edit a local kill file."
- (interactive (list nil (gnus-group-group-name)))
+ (interactive (list nil (gnus-group-group-name)) gnus-group-mode)
(gnus-group-edit-global-kill article group))
(defun gnus-group-force-update ()
"Update `.newsrc' file."
- (interactive)
+ (interactive nil gnus-group-mode)
(gnus-save-newsrc-file))
(defvar gnus-backlog-articles)
@@ -4284,7 +4453,7 @@ If GROUP, edit that local kill file instead."
"Suspend the current Gnus session.
In fact, cleanup buffers except for group mode buffer.
The hook `gnus-suspend-gnus-hook' is called before actually suspending."
- (interactive)
+ (interactive nil gnus-group-mode)
(gnus-run-hooks 'gnus-suspend-gnus-hook)
(gnus-offer-save-summaries)
;; Kill Gnus buffers except for group mode buffer.
@@ -4300,22 +4469,21 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending."
;; Closing all the backends is useful (for instance) when when the
;; IP addresses have changed and you need to reconnect.
(dolist (elem gnus-opened-servers)
- (gnus-close-server (car elem))
- (setcar (cdr elem) 'closed))
+ (gnus-close-server (car elem)))
(when group-buf
(bury-buffer group-buf)
(delete-windows-on group-buf t))))
(defun gnus-group-clear-dribble ()
"Clear all information from the dribble buffer."
- (interactive)
+ (interactive nil gnus-group-mode)
(gnus-dribble-clear)
(gnus-message 7 "Cleared dribble buffer"))
(defun gnus-group-exit ()
"Quit reading news after updating .newsrc.eld and .newsrc.
The hook `gnus-exit-gnus-hook' is called before actually exiting."
- (interactive)
+ (interactive nil gnus-group-mode)
(when
(or noninteractive ;For gnus-batch-kill
(not gnus-interactive-exit) ;Without confirmation
@@ -4349,7 +4517,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
(defun gnus-group-quit ()
"Quit reading news without updating .newsrc.eld or .newsrc.
The hook `gnus-exit-gnus-hook' is called before actually exiting."
- (interactive)
+ (interactive nil gnus-group-mode)
(when (or noninteractive ;For gnus-batch-kill
(zerop (buffer-size))
(not (gnus-server-opened gnus-select-method))
@@ -4374,7 +4542,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)
+ (interactive nil gnus-group-mode)
(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)
@@ -4386,8 +4554,8 @@ and the second element is the address."
(interactive
(list (let ((how (gnus-completing-read
"Which back end"
- (mapcar 'car (append gnus-valid-select-methods
- gnus-server-alist))
+ (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.
@@ -4403,7 +4571,8 @@ and the second element is the address."
gnus-secondary-servers
(cdr gnus-select-method))))
;; We got a server name.
- how))))
+ how)))
+ gnus-group-mode)
(gnus-browse-foreign-server method))
(defun gnus-group-set-info (info &optional method-only-group part)
@@ -4508,7 +4677,9 @@ and the second element is the address."
(setcdr m (gnus-compress-sequence articles t)))
(setcdr m (gnus-compress-sequence
(sort (nconc (gnus-uncompress-range (cdr m))
- (copy-sequence articles)) '<) t))))))
+ (copy-sequence articles))
+ #'<)
+ t))))))
(declare-function gnus-summary-add-mark "gnus-sum" (article type))
@@ -4559,27 +4730,27 @@ 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")
+ (interactive "P" gnus-group-mode)
(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 'cache marks)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'cache marks)))
lowest
- #'(lambda (group)
- (or (gethash group
- gnus-cache-active-hashtb)
- ;; Cache active file might use "."
- ;; instead of ":".
- (gethash
- (mapconcat 'identity
- (split-string group ":")
- ".")
- gnus-cache-active-hashtb))))
+ (lambda (group)
+ (or (gethash group
+ gnus-cache-active-hashtb)
+ ;; Cache active file might use "."
+ ;; instead of ":".
+ (gethash
+ (mapconcat #'identity
+ (split-string group ":")
+ ".")
+ gnus-cache-active-hashtb))))
(goto-char (point-min))
(gnus-group-position-point))
@@ -4590,16 +4761,16 @@ 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")
+ (interactive "P" gnus-group-mode)
(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 'dormant marks)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'dormant marks)))
lowest
'ignore)
(goto-char (point-min))
@@ -4612,16 +4783,16 @@ 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")
+ (interactive "P" gnus-group-mode)
(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)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'tick marks)))
lowest
'ignore)
(goto-char (point-min))
@@ -4638,9 +4809,9 @@ This command may read the active file."
(forward-char 1))
groups))
-(defun gnus-group-list-plus (&optional args)
+(defun gnus-group-list-plus (&optional _args)
"List groups plus the current selection."
- (interactive "P")
+ (interactive nil gnus-group-mode)
(let ((gnus-group-listed-groups (gnus-group-listed-groups))
(gnus-group-list-mode gnus-group-list-mode) ;; Save it.
func)
@@ -4656,7 +4827,7 @@ This command may read the active file."
(defun gnus-group-list-flush (&optional args)
"Flush groups from the current selection."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((gnus-group-list-option 'flush))
(gnus-group-list-plus args)))
@@ -4667,7 +4838,7 @@ with this command. If you've first limited to groups with
dormant articles with `A ?', you can then further limit with
`A / c', which will then limit to groups with cached articles, giving
you the groups that have both dormant articles and cached articles."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
(let ((gnus-group-list-option 'limit))
(gnus-group-list-plus args)))
@@ -4700,7 +4871,7 @@ you the groups that have both dormant articles and cached articles."
(push n gnus-newsgroup-unselected))
(setq n (1+ n)))
(setq gnus-newsgroup-unselected
- (sort gnus-newsgroup-unselected '<)))))
+ (sort gnus-newsgroup-unselected #'<)))))
(gnus-activate-group group)
(gnus-group-make-articles-read group (list article))
(when (and (gnus-group-auto-expirable-p group)
@@ -4720,7 +4891,7 @@ operation is only meaningful for back ends using one file per article
\(e.g. nnml).
Note: currently only implemented in nnml."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-group-mode)
(unless group
(error "No group to compact"))
(unless (gnus-check-backend-function 'request-compact-group group)
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index bb1ee5a806a..be62bfd81f5 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -1,4 +1,4 @@
-;;; gnus-html.el --- Render HTML in a buffer.
+;;; gnus-html.el --- Render HTML in a buffer. -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -151,8 +151,8 @@ fit these criteria."
(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)
+ (let ( parameters start end ;; tag string images
+ inhibit-images blocked-images)
(if (buffer-live-p gnus-summary-buffer)
(with-current-buffer gnus-summary-buffer
(setq inhibit-images gnus-inhibit-images
@@ -169,67 +169,67 @@ fit these criteria."
(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))))
- (add-text-properties
- start end
- (list 'image-url url
- 'image-displayer `(lambda (url start end)
- (gnus-html-display-image url start end
- ,alt-text))
- 'help-echo alt-text
- 'button t
- 'keymap gnus-html-image-map
- 'gnus-image (list url start end alt-text)))
- (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))
+ (let ((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-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
+ (add-text-properties
+ start end
+ (list 'image-url url
+ 'image-displayer (lambda (url start end)
+ (gnus-html-display-image url start end
+ alt-text))
+ 'help-echo alt-text
+ 'button t
+ 'keymap gnus-html-image-map
+ 'gnus-image (list url start end alt-text)))
+ (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))
+ (make-text-button start end
+ 'help-echo url
+ 'keymap gnus-html-image-map)))
+ ;; Normal, external URL.
+ (if (or inhibit-images
+ (gnus-html-image-url-blocked-p url blocked-images))
(make-text-button start end
'help-echo url
- 'keymap gnus-html-image-map)))
- ;; Normal, external URL.
- (if (or inhibit-images
- (gnus-html-image-url-blocked-p url blocked-images))
- (make-text-button start end
- 'help-echo url
- '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)
+ '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 "*"))
@@ -248,7 +248,7 @@ Use ALT-TEXT for the image string."
(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)
+ (let (tag parameters start end url) ;; string images
(gnus-html-pre-wash)
(gnus-html-wash-images)
@@ -329,10 +329,10 @@ Use ALT-TEXT for the image string."
(replace-match "" t t))
(mm-url-decode-entities)))
-(defun gnus-html-insert-image (&rest args)
+(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)))
+ (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."
diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el
index e683e6bc294..1b2743c1484 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -5,18 +5,20 @@
;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
;; Keywords: mail, icalendar, org
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -132,11 +134,27 @@
(cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
"Return recurring interval of EVENT."
(let ((rrule (gnus-icalendar-event:recur event))
- (default-interval 1))
+ (default-interval "1"))
+
+ (if (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
+ (match-string 1 rrule)
+ default-interval)))
- (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
- (or (match-string 1 rrule)
- default-interval)))
+(cl-defmethod gnus-icalendar-event:recurring-days ((event gnus-icalendar-event))
+ "Return, when available, the week day numbers on which the EVENT recurs."
+ (let ((rrule (gnus-icalendar-event:recur event))
+ (weekday-map '(("SU" . 0)
+ ("MO" . 1)
+ ("TU" . 2)
+ ("WE" . 3)
+ ("TH" . 4)
+ ("FR" . 5)
+ ("SA" . 6))))
+ (when (and rrule (string-match "BYDAY=\\([^;]+\\)" rrule))
+ (let ((bydays (split-string (match-string 1 rrule) ",")))
+ (seq-map
+ (lambda (x) (cdr (assoc x weekday-map)))
+ (seq-filter (lambda (x) (string-match "^[A-Z]\\{2\\}$" x)) bydays))))))
(cl-defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
(format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
@@ -162,8 +180,10 @@
(or (member (attendee-name prop) name-or-email)
(let ((att-email (attendee-email prop)))
(gnus-icalendar-find-if
- (lambda (email)
- (string-match email att-email))
+ (lambda (str-or-fun)
+ (if (functionp str-or-fun)
+ (funcall str-or-fun att-email)
+ (string-match str-or-fun att-email)))
name-or-email))))))
(gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
@@ -244,7 +264,14 @@
(map-property ical-property))
args)))))
(mapc #'accumulate-args prop-map)
- (apply #'make-instance event-class args))))
+ (apply
+ #'make-instance
+ event-class
+ (cl-loop for slot in (eieio-class-slots event-class)
+ for keyword = (intern
+ (format ":%s" (eieio-slot-descriptor-name slot)))
+ when (plist-member args keyword)
+ append (list keyword (plist-get args keyword)))))))
(defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
"Parse RFC5545 iCalendar in buffer BUF and return an event object.
@@ -312,7 +339,8 @@ status will be retrieved from the first matching attendee record."
(unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
reply-event-lines)
- (error "Could not find an event attendee matching given identity"))
+ (lwarn 'gnus-icalendar :warning
+ "Could not find an event attendee matching given identity"))
(mapconcat #'identity `("BEGIN:VEVENT"
,@(nreverse reply-event-lines)
@@ -400,21 +428,26 @@ Return nil for non-recurring EVENT."
(when org-freq
(format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
-(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
- "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
- (let* ((start (gnus-icalendar-event:start-time event))
- (end (gnus-icalendar-event:end-time event))
- (start-date (format-time-string "%Y-%m-%d" start))
+(defun gnus-icalendar--find-day (start-date end-date day)
+ (let ((time-1-day 86400))
+ (if (= (decoded-time-weekday (decode-time start-date))
+ day)
+ (list start-date end-date)
+ (gnus-icalendar--find-day (time-add start-date time-1-day)
+ (time-add end-date time-1-day)
+ day))))
+
+(defun gnus-icalendar-event--org-timestamp (start end org-repeat)
+ (let* ((start-date (format-time-string "%Y-%m-%d" start))
(start-time (format-time-string "%H:%M" start))
(start-at-midnight (string= start-time "00:00"))
(end-date (format-time-string "%Y-%m-%d" end))
(end-time (format-time-string "%H:%M" end))
(end-at-midnight (string= end-time "00:00"))
(start-end-date-diff
- (time-to-number-of-days (time-subtract
- (org-time-string-to-time end-date)
- (org-time-string-to-time start-date))))
- (org-repeat (gnus-icalendar-event:org-repeat event))
+ (time-to-number-of-days
+ (time-subtract (org-time-string-to-time end-date)
+ (org-time-string-to-time start-date))))
(repeat (if org-repeat (concat " " org-repeat) ""))
(time-1-day 86400))
@@ -445,7 +478,31 @@ Return nil for non-recurring EVENT."
;; A .:. - A .:. -> A .:.-.:.
;; A .:. - B .:.
((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
- (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
+ (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time))))
+ )
+
+(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
+ "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
+ ;; if org-repeat +1d or +1w and byday: generate one timestamp per
+ ;; byday, starting at start-date. Change +1d to +7d.
+ (let ((start (gnus-icalendar-event:start-time event))
+ (end (gnus-icalendar-event:end-time event))
+ (org-repeat (gnus-icalendar-event:org-repeat event))
+ (recurring-days (gnus-icalendar-event:recurring-days event)))
+ (if (and (or (string= org-repeat "+1d")
+ (string= org-repeat "+1w"))
+ recurring-days)
+ (let ((repeat "+1w")
+ (dates (seq-sort-by
+ 'car
+ 'time-less-p
+ (seq-map (lambda (x)
+ (gnus-icalendar--find-day start end x))
+ recurring-days))))
+ (mapconcat (lambda (x)
+ (gnus-icalendar-event--org-timestamp (car x) (cadr x)
+ repeat)) dates "\n"))
+ (gnus-icalendar-event--org-timestamp start end org-repeat))))
(defun gnus-icalendar--format-summary-line (summary &optional location)
(if location
@@ -715,9 +772,8 @@ These will be used to retrieve the RSVP information from ical events."
(lambda (x) (if (listp x) x (list x)))
(list user-full-name (regexp-quote user-mail-address)
;; NOTE: these can be lists
- gnus-ignored-from-addresses ; already regexp-quoted
- (unless (functionp message-alternative-emails) ; String or function.
- message-alternative-emails)
+ gnus-ignored-from-addresses ; String or function.
+ message-alternative-emails ; String or function.
(mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
;; TODO: make the template customizable
@@ -756,7 +812,7 @@ These will be used to retrieve the RSVP information from ical events."
`(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
(with-temp-buffer
(mm-insert-part ,handle)
- (when (string= (downcase ,charset) "utf-8")
+ (when (and ,charset (string= (downcase ,charset) "utf-8"))
(decode-coding-region (point-min) (point-max) 'utf-8))
,@body))))
@@ -779,6 +835,7 @@ These will be used to retrieve the RSVP information from ical events."
keymap ,gnus-mime-button-map
face ,gnus-article-button-face
follow-link t
+ category t
button t
gnus-data ,data))))
@@ -814,7 +871,7 @@ These will be used to retrieve the RSVP information from ical events."
(let ((subject (concat (capitalize (symbol-name status))
": " (gnus-icalendar-event:summary event))))
- (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
+ (with-current-buffer (gnus-get-buffer-create gnus-icalendar-reply-bufname)
(delete-region (point-min) (point-max))
(insert reply)
(fold-icalendar-buffer)
@@ -913,7 +970,7 @@ These will be used to retrieve the RSVP information from ical events."
(defun gnus-icalendar-save-event ()
"Save the Calendar event in the text/calendar part under point."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
@@ -921,28 +978,28 @@ These will be used to retrieve the RSVP information from ical events."
(defun gnus-icalendar-reply-accept ()
"Accept invitation in the current article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
(setq-local gnus-icalendar-reply-status 'accepted)))
(defun gnus-icalendar-reply-tentative ()
"Send tentative response to invitation in the current article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
(setq-local gnus-icalendar-reply-status 'tentative)))
(defun gnus-icalendar-reply-decline ()
"Decline invitation in the current article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
(setq-local gnus-icalendar-reply-status 'declined)))
(defun gnus-icalendar-event-export ()
"Export calendar event to `org-mode', or update existing agenda entry."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(with-current-buffer gnus-article-buffer
(gnus-icalendar-sync-event-to-org gnus-icalendar-event))
;; refresh article buffer in case the reply had been sent before initial org
@@ -952,14 +1009,14 @@ These will be used to retrieve the RSVP information from ical events."
(defun gnus-icalendar-event-show ()
"Display `org-mode' agenda entry related to the calendar event."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-icalendar--show-org-event
(with-current-buffer gnus-article-buffer
gnus-icalendar-event)))
(defun gnus-icalendar-event-check-agenda ()
"Display `org-mode' agenda for days between event start and end dates."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-icalendar-show-org-agenda
(with-current-buffer gnus-article-buffer gnus-icalendar-event)))
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index 59424a663f3..01053797b3a 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -1,4 +1,4 @@
-;;; gnus-int.el --- backend interface functions for Gnus
+;;; gnus-int.el --- backend interface functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -76,23 +76,25 @@ server denied."
"The current method, for the registry.")
-(defun gnus-server-opened (gnus-command-method)
- "Check whether a connection to GNUS-COMMAND-METHOD has been opened."
- (unless (eq (gnus-server-status gnus-command-method)
+(defun gnus-server-opened (command-method)
+ "Check whether a connection to COMMAND-METHOD has been opened."
+ (unless (eq (gnus-server-status command-method)
'denied)
- (when (stringp gnus-command-method)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
- (nth 1 gnus-command-method))))
-
-(defun gnus-status-message (gnus-command-method)
- "Return the status message from GNUS-COMMAND-METHOD.
-If GNUS-COMMAND-METHOD is a string, it is interpreted as a group
-name. The method this group uses will be queried."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
+ (nth 1 gnus-command-method)))))
+
+(defun gnus-status-message (command-method)
+ "Return the status message from COMMAND-METHOD.
+If COMMAND-METHOD is a string, it is interpreted as a group name.
+The method this group uses will be queried."
(let ((gnus-command-method
- (if (stringp gnus-command-method)
- (gnus-find-method-for-group gnus-command-method)
- gnus-command-method)))
+ (if (stringp command-method)
+ (gnus-find-method-for-group command-method)
+ command-method)))
(funcall (gnus-get-function gnus-command-method 'status-message)
(nth 1 gnus-command-method))))
@@ -253,7 +255,7 @@ If it is down, start it up (again)."
(defun gnus-backend-trace (type form)
(when gnus-backend-trace
- (with-current-buffer (get-buffer-create "*gnus trace*")
+ (with-current-buffer (gnus-get-buffer-create "*gnus trace*")
(buffer-disable-undo)
(goto-char (point-max))
(insert (format-time-string "%H:%M:%S")
@@ -265,13 +267,14 @@ If it is down, start it up (again)."
type form))
(setq gnus-backend-trace-elapsed (float-time)))))
-(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)))
+(defun gnus-open-server (command-method)
+ "Open a connection to COMMAND-METHOD."
(gnus-backend-trace :opening gnus-command-method)
- (let ((elem (assoc gnus-command-method gnus-opened-servers))
- (server (gnus-method-to-server-name gnus-command-method)))
+ (let* ((gnus-command-method (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method))
+ (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.
(if (eq (nth 1 elem) 'denied)
(progn
@@ -347,62 +350,121 @@ If it is down, start it up (again)."
(gnus-backend-trace :opened gnus-command-method)
result)))))
-(defun gnus-close-server (gnus-command-method)
- "Close the connection to 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 'close-server)
- (nth 1 gnus-command-method)
- (nthcdr 2 gnus-command-method)))
-
-(defun gnus-request-list (gnus-command-method)
- "Request the active file 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 '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)))
+(defun gnus-close-server (command-method)
+ "Close the connection to COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (prog1
+ (funcall (gnus-get-function gnus-command-method 'close-server)
+ (nth 1 gnus-command-method)
+ (nthcdr 2 gnus-command-method))
+ (when-let ((elem (assoc gnus-command-method gnus-opened-servers)))
+ (setf (nth 1 elem) 'closed)))))
+
+(defun gnus-request-list (command-method)
+ "Request the active file from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-list)
+ (nth 1 gnus-command-method))))
+
+(defun gnus-server-get-active (server &optional ignored)
+ "Return the active list for SERVER.
+Groups matching the IGNORED regexp are excluded."
+ (let ((method (gnus-server-to-method server))
+ groups)
+ (gnus-request-list method)
+ (with-current-buffer nntp-server-buffer
+ (let ((cur (current-buffer)))
+ (goto-char (point-min))
+ (unless (or (null ignored)
+ (string= ignored ""))
+ (delete-matching-lines ignored))
+ (if (eq (car method) 'nntp)
+ (while (not (eobp))
+ (ignore-errors
+ (push (gnus-group-full-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point)))
+ method)
+ groups))
+ (forward-line))
+ (while (not (eobp))
+ (ignore-errors
+ (push (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 gnus-finish-retrieve-group-infos (command-method infos data)
+ "Read and update infos from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
(gnus-backend-trace :finishing gnus-command-method)
(prog1
(funcall (gnus-get-function gnus-command-method
'finish-retrieve-group-infos)
(nth 1 gnus-command-method)
infos data)
- (gnus-backend-trace :finished gnus-command-method)))
-
-(defun gnus-retrieve-group-data-early (gnus-command-method infos)
- "Start early async retrieval 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)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
- (nth 1 gnus-command-method)))
-
-(defun gnus-request-newgroups (date gnus-command-method)
- "Request all new groups since DATE from GNUS-COMMAND-METHOD."
- (when (stringp gnus-command-method)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
- (when func
- (funcall func date (nth 1 gnus-command-method)))))
-
-(defun gnus-request-regenerate (gnus-command-method)
- "Request a data generation 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 'request-regenerate)
- (nth 1 gnus-command-method)))
+ (gnus-backend-trace :finished gnus-command-method))))
+
+(defun gnus-retrieve-group-data-early (command-method infos)
+ "Start early async retrieval of data from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early)
+ (nth 1 gnus-command-method)
+ infos)))
+
+(defun gnus-request-list-newsgroups (command-method)
+ "Request the newsgroups file from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
+ (nth 1 gnus-command-method))))
+
+(defun gnus-request-newgroups (date command-method)
+ "Request all new groups since DATE from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
+ (when func
+ (funcall func date (nth 1 gnus-command-method))))))
+
+(defun gnus-request-regenerate (command-method)
+ "Request a data generation from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-regenerate)
+ (nth 1 gnus-command-method))))
(defun gnus-request-compact-group (group)
(let* ((method (gnus-find-method-for-group group))
@@ -414,17 +476,19 @@ If it is down, start it up (again)."
(nth 1 gnus-command-method) t)))
result))
-(defun gnus-request-compact (gnus-command-method)
- "Request groups compaction 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 'request-compact)
- (nth 1 gnus-command-method)))
+(defun gnus-request-compact (command-method)
+ "Request groups compaction from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (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 info)
+(defun gnus-request-group (group &optional dont-check 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)))))
+ (or 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))))
@@ -477,12 +541,14 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
articles (gnus-group-real-name group)
(nth 1 gnus-command-method))))
-(defun gnus-retrieve-groups (groups gnus-command-method)
- "Request active information on GROUPS 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-groups)
- groups (nth 1 gnus-command-method)))
+(defun gnus-retrieve-groups (groups command-method)
+ "Request active information on GROUPS from COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'retrieve-groups)
+ groups (nth 1 gnus-command-method))))
(defun gnus-request-type (group &optional article)
"Return the type (`post' or `mail') of GROUP (and ARTICLE)."
@@ -583,7 +649,7 @@ the group's summary.
article-number)
;; Clean up the new summary and propagate the error
(error (when group-is-new (gnus-summary-exit))
- (apply 'signal err)))))
+ (apply #'signal err)))))
(defun gnus-simplify-group-name (group)
"Return the simplest representation of the name of GROUP.
@@ -596,7 +662,7 @@ This is the string that Gnus uses to identify the group."
"Look up the current article in the group where it originated.
This command only makes sense for groups shows articles gathered
from other groups -- for instance, search results and the like."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((gnus-command-method
(gnus-find-method-for-group gnus-newsgroup-name)))
(or
@@ -670,26 +736,33 @@ from other groups -- for instance, search results and the like."
(delete-region (point-min) (1- (point))))))
res))
-(defun gnus-request-post (gnus-command-method)
- "Post the current buffer using 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-post)
- (nth 1 gnus-command-method)))
+(defun gnus-request-post (command-method)
+ "Post the current buffer using COMMAND-METHOD."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-post)
+ (nth 1 gnus-command-method))))
-(defun gnus-request-expunge-group (group gnus-command-method)
+(defun gnus-request-expunge-group (group 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."
(let ((gnus-command-method
- (if group (gnus-find-method-for-group group) gnus-command-method))
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-expunge-group)
+ (gnus-group-real-name group)
+ (nth 1 gnus-command-method))))
+
+(defvar mail-source-plugged)
+(defvar gnus-inhibit-demon)
+
+(defun gnus-request-scan (group command-method)
+ "Request a SCAN being performed in GROUP from COMMAND-METHOD.
+If GROUP is nil, all groups on COMMAND-METHOD are scanned."
+ (let ((gnus-command-method
+ (if group (gnus-find-method-for-group group) command-method))
(gnus-inhibit-demon t)
(mail-source-plugged gnus-plugged))
(when (or gnus-plugged
@@ -699,36 +772,40 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(and group (gnus-group-real-name group))
(nth 1 gnus-command-method)))))
-(defun gnus-request-update-info (info gnus-command-method)
+(defun gnus-request-update-info (info 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-marks (car gnus-command-method))
- (let ((group (gnus-info-group 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
- ;; smaller article numbers are known not to exist; we'll
- ;; artificially add those to the 'read range.
- (let* ((active (gnus-active group))
- (min (car active)))
- (when (> min 1)
- (let* ((range (if (= min 2) 1 (cons 1 (1- min))))
- (read (gnus-info-read info))
- (new-read (gnus-range-add read (list range))))
- (setf (gnus-info-read info) new-read)))
- info)))))
+ 'request-update-info (car command-method))
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ 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 command-method)
+ "Request that COMMAND-METHOD update INFO."
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (when (gnus-check-backend-function
+ 'request-marks (car gnus-command-method))
+ (let ((group (gnus-info-group 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
+ ;; smaller article numbers are known not to exist; we'll
+ ;; artificially add those to the 'read range.
+ (let* ((active (gnus-active group))
+ (min (car active)))
+ (when (> min 1)
+ (let* ((range (if (= min 2) 1 (cons 1 (1- min))))
+ (read (gnus-info-read info))
+ (new-read (gnus-range-add read (list range))))
+ (setf (gnus-info-read info) new-read)))
+ info))))))
(defun gnus-request-expire-articles (articles group &optional force)
(let* ((gnus-command-method (gnus-find-method-for-group group))
@@ -749,7 +826,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(gnus-agent-expire expired-articles group 'force))))
not-deleted))
-(defun gnus-request-move-article (article group server accept-function
+(defun gnus-request-move-article (article group _server accept-function
&optional last move-is-internal)
(let* ((gnus-command-method (gnus-find-method-for-group group))
(result (funcall (gnus-get-function gnus-command-method
@@ -762,38 +839,40 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(gnus-agent-unfetch-articles group (list article)))
result))
-(defun gnus-request-accept-article (group &optional gnus-command-method last
+(defun gnus-request-accept-article (group &optional command-method last
no-encode)
- (when (stringp gnus-command-method)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (when (and (not gnus-command-method)
- (stringp group))
- (setq gnus-command-method (or (gnus-find-method-for-group group)
- (gnus-group-name-to-method group))))
- (goto-char (point-max))
- ;; Make sure there's a newline at the end of the article.
- (unless (bolp)
- (insert "\n"))
- (unless no-encode
- (let ((message-options message-options))
- (message-options-set-recipient)
- (save-restriction
- (message-narrow-to-head)
- (mail-encode-encoded-word-buffer))
- (message-encode-message-body)))
- (let ((gnus-command-method (or gnus-command-method
- (gnus-find-method-for-group group)))
- (result
- (funcall
- (gnus-get-function gnus-command-method 'request-accept-article)
- (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)
- (cdr result))
- (gnus-agent-regenerate-group group (list (cdr result))))
- result))
+ (let ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)))
+ (when (and (not gnus-command-method)
+ (stringp group))
+ (setq gnus-command-method (or (gnus-find-method-for-group group)
+ (gnus-group-name-to-method group))))
+ (goto-char (point-max))
+ ;; Make sure there's a newline at the end of the article.
+ (unless (bolp)
+ (insert "\n"))
+ (unless no-encode
+ (let ((message-options message-options))
+ (message-options-set-recipient)
+ (save-restriction
+ (message-narrow-to-head)
+ (mail-encode-encoded-word-buffer))
+ (message-encode-message-body)))
+ (let ((gnus-command-method (or gnus-command-method
+ (gnus-find-method-for-group group)))
+ (result
+ (funcall
+ (gnus-get-function gnus-command-method 'request-accept-article)
+ (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)
+ (cdr result))
+ (gnus-agent-regenerate-group group (list (cdr result))))
+ result)))
(defun gnus-request-replace-article (article group buffer &optional no-encode)
(unless no-encode
@@ -817,13 +896,14 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
article (gnus-group-real-name group)
(nth 1 gnus-command-method))))
-(defun gnus-request-create-group (group &optional gnus-command-method args)
- (when (stringp gnus-command-method)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (let ((gnus-command-method
- (or gnus-command-method (gnus-find-method-for-group group))))
+(defun gnus-request-create-group (group &optional command-method args)
+ (let* ((gnus-command-method
+ (or (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method)
+ (gnus-find-method-for-group group))))
(funcall (gnus-get-function gnus-command-method 'request-create-group)
- (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
+ (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
(defun gnus-request-delete-group (group &optional force)
(let* ((gnus-command-method (gnus-find-method-for-group group))
@@ -857,15 +937,18 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
"-request-close"))))
(funcall func)))))
-(defun gnus-asynchronous-p (gnus-command-method)
- (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t)))
+(defun gnus-asynchronous-p (command-method)
+ (let ((func (gnus-get-function command-method 'asynchronous-p t)))
(when (fboundp func)
- (funcall func))))
-
-(defun gnus-remove-denial (gnus-command-method)
- (when (stringp gnus-command-method)
- (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
- (let* ((elem (assoc gnus-command-method gnus-opened-servers))
+ (let ((gnus-command-method command-method))
+ (funcall func)))))
+
+(defun gnus-remove-denial (command-method)
+ (let* ((gnus-command-method
+ (if (stringp command-method)
+ (gnus-server-to-method command-method)
+ command-method))
+ (elem (assoc gnus-command-method gnus-opened-servers))
(status (cadr elem)))
;; If this hasn't been opened before, we add it to the list.
(when (eq status 'denied)
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index ee8145e9c7f..f73627a6480 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -1,4 +1,4 @@
-;;; gnus-kill.el --- kill commands for Gnus
+;;; gnus-kill.el --- kill commands for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -275,7 +275,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(save-excursion
(save-window-excursion
(pop-to-buffer gnus-summary-buffer)
- (eval (car (read-from-string string)))))))
+ (eval (car (read-from-string string)) t)))))
(defun gnus-kill-file-apply-last-sexp ()
"Apply sexp before point in current buffer to current newsgroup."
@@ -289,7 +289,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(save-excursion
(save-window-excursion
(pop-to-buffer gnus-summary-buffer)
- (eval (car (read-from-string string))))))
+ (eval (car (read-from-string string)) t))))
(ding) (gnus-message 2 "No newsgroup is selected.")))
(defun gnus-kill-file-exit ()
@@ -337,7 +337,7 @@ Returns the number of articles marked as read."
(gnus-newsgroup-kill-file gnus-newsgroup-name)))
(unreads (length gnus-newsgroup-unreads))
(gnus-summary-inhibit-highlight t)
- beg)
+ ) ;; beg
(setq gnus-newsgroup-kill-headers nil)
;; If there are any previously scored articles, we remove these
;; from the `gnus-newsgroup-headers' list that the score functions
@@ -381,7 +381,7 @@ Returns the number of articles marked as read."
(gnus-set-mode-line 'summary)
- (if beg
+ (if nil ;; beg
(let ((nunreads (- unreads (length gnus-newsgroup-unreads))))
(or (eq nunreads 0)
(gnus-message 6 "Marked %d articles as read" nunreads))
@@ -403,9 +403,9 @@ Returns the number of articles marked as read."
(eq (car form) 'gnus-lower))
(progn
(delete-region beg (point))
- (insert (or (eval form) "")))
+ (insert (or (eval form t) "")))
(with-current-buffer gnus-summary-buffer
- (ignore-errors (eval form)))))
+ (ignore-errors (eval form t)))))
(and (buffer-modified-p)
gnus-kill-save-kill-file
(save-buffer))
@@ -560,7 +560,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence."
((functionp form)
(funcall form))
(t
- (eval form)))))
+ (eval form t)))))
;; Search article body.
(let ((gnus-current-article nil) ;Save article pointer.
(gnus-last-article nil)
@@ -578,7 +578,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence."
((functionp form)
(funcall form))
(t
- (eval form)))))))
+ (eval form t)))))))
did-kill)))
(defun gnus-execute (field regexp form &optional backward unread)
@@ -606,12 +606,10 @@ marked as read or ticked are ignored."
(downcase (symbol-name header)))
gnus-extra-headers)))
(setq function
- `(lambda (h)
- (gnus-extra-header
- (quote ,(nth (- (length gnus-extra-headers)
- (length extras))
- gnus-extra-headers))
- h)))))))
+ (let ((type (nth (- (length gnus-extra-headers)
+ (length extras))
+ gnus-extra-headers)))
+ (lambda (h) (gnus-extra-header type h))))))))
;; Signal error.
(t
(error "Unknown header field: \"%s\"" field)))
@@ -641,7 +639,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(let* ((gnus-newsrc-options-n
(gnus-newsrc-parse-options
(concat "options -n "
- (mapconcat 'identity command-line-args-left " "))))
+ (mapconcat #'identity command-line-args-left " "))))
(gnus-expert-user t)
(mail-sources nil)
(gnus-use-dribble-file nil)
@@ -653,7 +651,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
gnus-options-not-subscribe)
;; Eat all arguments.
(setq command-line-args-left nil)
- (gnus-slave)
+ (gnus-child)
;; Apply kills to specified newsgroups in command line arguments.
(setq newsrc (cdr gnus-newsrc-alist))
(while (setq info (pop newsrc))
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index 105222d6797..cdfdc9b7319 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -1,4 +1,4 @@
-;;; gnus-logic.el --- advanced scoring code for Gnus
+;;; gnus-logic.el --- advanced scoring code for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el
index b26b736d055..df076c11759 100644
--- a/lisp/gnus/gnus-mh.el
+++ b/lisp/gnus/gnus-mh.el
@@ -1,4 +1,4 @@
-;;; gnus-mh.el --- mh-e interface for Gnus
+;;; gnus-mh.el --- mh-e interface for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
@@ -53,7 +53,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-in-folder))
(gnus-summary-save-article arg)))
@@ -95,7 +95,7 @@ Optional argument FOLDER specifies folder name."
(kill-buffer errbuf))))
(setq gnus-newsgroup-last-folder folder)))
-(defun gnus-Folder-save-name (newsgroup headers &optional last-folder)
+(defun gnus-Folder-save-name (newsgroup _headers &optional last-folder)
"Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
If variable `gnus-use-long-file-name' is nil, it is +News.group.
Otherwise, it is like +news/group."
@@ -105,7 +105,7 @@ Otherwise, it is like +news/group."
(gnus-capitalize-newsgroup newsgroup)
(gnus-newsgroup-directory-form newsgroup)))))
-(defun gnus-folder-save-name (newsgroup headers &optional last-folder)
+(defun gnus-folder-save-name (newsgroup _headers &optional last-folder)
"Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
If variable `gnus-use-long-file-name' is nil, it is +news.group.
Otherwise, it is like +news/group."
diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el
index a47c15525a3..3b2b5a07c1d 100644
--- a/lisp/gnus/gnus-ml.el
+++ b/lisp/gnus/gnus-ml.el
@@ -1,4 +1,4 @@
-;;; gnus-ml.el --- Mailing list minor mode for Gnus
+;;; gnus-ml.el --- Mailing list minor mode for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el
index ed8d15a2feb..d42f0971259 100644
--- a/lisp/gnus/gnus-mlspl.el
+++ b/lisp/gnus/gnus-mlspl.el
@@ -1,4 +1,4 @@
-;;; gnus-mlspl.el --- a group params-based mail splitting mechanism
+;;; gnus-mlspl.el --- a group params-based mail splitting mechanism -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -196,13 +196,13 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
(concat
"\\("
(mapconcat
- 'identity
+ #'identity
(append
(and to-address (list (regexp-quote to-address)))
(and to-list (list (regexp-quote to-list)))
(and extra-aliases
(if (listp extra-aliases)
- (mapcar 'regexp-quote extra-aliases)
+ (mapcar #'regexp-quote extra-aliases)
(list extra-aliases)))
(and split-regexp (list split-regexp)))
"\\|")
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 6cf09931871..db54237a767 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1,4 +1,4 @@
-;;; gnus-msg.el --- mail and post interface for Gnus
+;;; gnus-msg.el --- mail and post interface for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -143,9 +143,6 @@ See Info node `(gnus)Posting Styles'."
:group 'gnus-message
:type 'boolean)
-(make-obsolete-variable 'gnus-inews-mark-gcc-as-read
- 'gnus-gcc-mark-as-read "Emacs 22.1")
-
(defcustom gnus-gcc-externalize-attachments nil
"Should local-file attachments be included as external parts in Gcc copies?
If it is `all', attach files as external parts;
@@ -389,37 +386,41 @@ only affect the Gcc copy, but not the original message."
;;; Internal functions.
(defun gnus-inews-make-draft (articles)
- `(lambda ()
- (gnus-inews-make-draft-meta-information
- ,gnus-newsgroup-name ',articles)))
-
-(autoload 'nnir-article-number "nnir" nil nil 'macro)
-(autoload 'nnir-article-group "nnir" nil nil 'macro)
-(autoload 'gnus-nnir-group-p "nnir")
+ (let ((gn gnus-newsgroup-name))
+ (lambda ()
+ (gnus-inews-make-draft-meta-information
+ gn articles))))
+(autoload 'nnselect-article-number "nnselect" nil nil 'macro)
+(autoload 'nnselect-article-group "nnselect" nil nil 'macro)
+(autoload 'gnus-nnselect-group-p "nnselect")
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
+ (declare (indent 1) (debug t))
(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"))
+ (oarticle (make-symbol "gnus-setup-message-oarticle"))
(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 (if (and (gnus-nnir-group-p gnus-newsgroup-name)
- gnus-article-reply)
- (nnir-article-number (or (car-safe gnus-article-reply)
- gnus-article-reply))
- gnus-article-reply))
+ (,article (when gnus-article-reply
+ (or (nnselect-article-number
+ (or (car-safe gnus-article-reply)
+ gnus-article-reply))
+ gnus-article-reply)))
+ (,oarticle gnus-article-reply)
(,yanked gnus-article-yanked-articles)
- (,group (if (and (gnus-nnir-group-p gnus-newsgroup-name)
- gnus-article-reply)
- (nnir-article-group (or (car-safe gnus-article-reply)
- gnus-article-reply))
- gnus-newsgroup-name))
+ (,group (if gnus-article-reply
+ (or (nnselect-article-group
+ (or (car-safe gnus-article-reply)
+ gnus-article-reply))
+ gnus-newsgroup-name)
+ gnus-newsgroup-name))
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
(mbl mml-buffer-list)
@@ -460,24 +461,22 @@ only affect the Gcc copy, but not the original message."
(unwind-protect
(progn
,@forms)
- (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
+ (gnus-inews-add-send-actions ,winconf ,buffer ,oarticle ,config
,yanked ,winconf-name)
(setq gnus-message-buffer (current-buffer))
- (set (make-local-variable 'gnus-message-group-art)
- (cons ,group ,article))
- (set (make-local-variable 'gnus-newsgroup-name) ,group)
- ;; Enable highlighting of different citation levels
- (when gnus-message-highlight-citation
- (gnus-message-citation-mode 1))
- (gnus-run-hooks 'gnus-message-setup-hook)
- (if (eq major-mode 'message-mode)
- (let ((mbl1 mml-buffer-list))
- (setq mml-buffer-list mbl) ;; Global value
- (set (make-local-variable 'mml-buffer-list) mbl1);; Local value
- (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
- (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
- (mml-destroy-buffers)
- (setq mml-buffer-list mbl)))
+ (setq-local gnus-message-group-art (cons ,group ,article))
+ ;; Enable highlighting of different citation levels
+ (when gnus-message-highlight-citation
+ (gnus-message-citation-mode 1))
+ (gnus-run-hooks 'gnus-message-setup-hook)
+ (if (eq major-mode 'message-mode)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl) ;; Global value
+ (setq-local mml-buffer-list mbl1) ;; Local value
+ (add-hook 'change-major-mode-hook #'mml-destroy-buffers nil t)
+ (add-hook 'kill-buffer-hook #'mml-destroy-buffers t t))
+ (mml-destroy-buffers)
+ (setq mml-buffer-list mbl)))
(message-hide-headers)
(gnus-add-buffer)
(gnus-configure-windows ,config t)
@@ -517,16 +516,13 @@ instead."
switch-action yank-action send-actions return-action))
(let ((buf (current-buffer))
;; Don't use posting styles corresponding to any existing group.
- (group-name gnus-newsgroup-name)
+ ;; (group-name gnus-newsgroup-name)
mail-buf)
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name "")
- (gnus-setup-message 'message
- (message-mail to subject other-headers continue
- nil yank-action send-actions return-action)))
- (with-current-buffer buf
- (setq gnus-newsgroup-name group-name)))
+ (let ((gnus-newsgroup-name ""))
+ (gnus-setup-message
+ 'message
+ (message-mail to subject other-headers continue
+ nil yank-action send-actions return-action)))
(when switch-action
(setq mail-buf (current-buffer))
(switch-to-buffer buf)
@@ -568,16 +564,21 @@ instead."
(symbol-value (car elem))))
(throw 'found (cons (cadr elem) (caddr elem)))))))))
+(declare-function gnus-agent-possibly-do-gcc "gnus-agent" ())
+(declare-function gnus-cache-possibly-remove-article "gnus-cache"
+ (article ticked dormant unread &optional force))
+
(defun gnus-inews-add-send-actions (winconf buffer article
&optional config yanked
winconf-name)
- (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
- 'gnus-inews-do-gcc) nil t)
+ (add-hook 'message-sent-hook (if gnus-agent #'gnus-agent-possibly-do-gcc
+ #'gnus-inews-do-gcc)
+ nil t)
(when gnus-agent
- (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
+ (add-hook 'message-header-hook #'gnus-agent-possibly-save-gcc nil t))
(setq message-post-method
- `(lambda (&optional arg)
- (gnus-post-method arg ,gnus-newsgroup-name)))
+ (let ((gn gnus-newsgroup-name))
+ (lambda (&optional arg) (gnus-post-method arg gn))))
(message-add-action
`(progn
(setq gnus-current-window-configuration ',winconf-name)
@@ -599,9 +600,6 @@ instead."
`(gnus-summary-mark-article-as-replied ',to-be-marked)))))
'send)))
-(put 'gnus-setup-message 'lisp-indent-function 1)
-(put 'gnus-setup-message 'edebug-form-spec '(form body))
-
;;; Post news commands of Gnus group mode and summary mode
(defun gnus-group-mail (&optional arg)
@@ -609,26 +607,19 @@ instead."
If ARG, use the group under the point to find a posting style.
If ARG is 1, prompt for a group name to find the posting style."
(interactive "P")
- ;; We can't `let' gnus-newsgroup-name here, since that leads
- ;; to local variables leaking.
- (let ((group gnus-newsgroup-name)
- ;; make sure last viewed article doesn't affect posting styles:
- (gnus-article-copy)
- (buffer (current-buffer)))
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name
- (if arg
- (if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read
- "Use posting style of group"
- nil (gnus-read-active-file-p))
- (gnus-group-group-name))
- ""))
- ;; #### see comment in gnus-setup-message -- drv
- (gnus-setup-message 'message (message-mail)))
- (with-current-buffer buffer
- (setq gnus-newsgroup-name group)))))
+ (let* (;;(group gnus-newsgroup-name)
+ ;; make sure last viewed article doesn't affect posting styles:
+ (gnus-article-copy)
+ ;; (buffer (current-buffer))
+ (gnus-newsgroup-name
+ (if arg
+ (if (= 1 (prefix-numeric-value arg))
+ (gnus-group-completing-read
+ "Use posting style of group"
+ nil (gnus-read-active-file-p))
+ (gnus-group-group-name))
+ "")))
+ (gnus-setup-message 'message (message-mail))))
(defun gnus-group-news (&optional arg)
"Start composing a news.
@@ -639,34 +630,28 @@ This function prepares a news even when using mail groups. This is useful
for posting messages to mail groups without actually sending them over the
network. The corresponding back end must have a `request-post' method."
(interactive "P")
- ;; We can't `let' gnus-newsgroup-name here, since that leads
- ;; to local variables leaking.
- (let ((group gnus-newsgroup-name)
- ;; make sure last viewed article doesn't affect posting styles:
- (gnus-article-copy)
- (buffer (current-buffer)))
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name
- (if arg
- (if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group"
- nil
- (gnus-read-active-file-p))
- (gnus-group-group-name))
- ""))
- ;; #### see comment in gnus-setup-message -- drv
- (gnus-setup-message 'message
- (message-news (gnus-group-real-name gnus-newsgroup-name))))
- (with-current-buffer buffer
- (setq gnus-newsgroup-name group)))))
+ (let* (;;(group gnus-newsgroup-name)
+ ;; make sure last viewed article doesn't affect posting styles:
+ (gnus-article-copy)
+ ;; (buffer (current-buffer))
+ (gnus-newsgroup-name
+ (if arg
+ (if (= 1 (prefix-numeric-value arg))
+ (gnus-group-completing-read "Use group"
+ nil
+ (gnus-read-active-file-p))
+ (gnus-group-group-name))
+ "")))
+ (gnus-setup-message
+ 'message
+ (message-news (gnus-group-real-name gnus-newsgroup-name)))))
(defun gnus-group-post-news (&optional arg)
"Start composing a message (a news by default).
If ARG, post to group under point. If ARG is 1, prompt for group name.
Depending on the selected group, the message might be either a mail or
a news."
- (interactive "P")
+ (interactive "P" gnus-group-mode)
;; Bind this variable here to make message mode hooks work ok.
(let ((gnus-newsgroup-name
(if arg
@@ -685,27 +670,20 @@ a news."
Use the posting of the current group by default.
If ARG, don't do that. If ARG is 1, prompt for group name to find the
posting style."
- (interactive "P")
- ;; We can't `let' gnus-newsgroup-name here, since that leads
- ;; to local variables leaking.
- (let ((group gnus-newsgroup-name)
- ;; make sure last viewed article doesn't affect posting styles:
- (gnus-article-copy)
- (buffer (current-buffer)))
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name
- (if arg
- (if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group"
- nil
- (gnus-read-active-file-p))
- "")
- gnus-newsgroup-name))
- ;; #### see comment in gnus-setup-message -- drv
- (gnus-setup-message 'message (message-mail)))
- (with-current-buffer buffer
- (setq gnus-newsgroup-name group)))))
+ (interactive "P" gnus-summary-mode)
+ (let* (;;(group gnus-newsgroup-name)
+ ;; make sure last viewed article doesn't affect posting styles:
+ (gnus-article-copy)
+ ;; (buffer (current-buffer))
+ (gnus-newsgroup-name
+ (if arg
+ (if (= 1 (prefix-numeric-value arg))
+ (gnus-group-completing-read "Use group"
+ nil
+ (gnus-read-active-file-p))
+ "")
+ gnus-newsgroup-name)))
+ (gnus-setup-message 'message (message-mail))))
(defun gnus-summary-news-other-window (&optional arg)
"Start composing a news in another window.
@@ -715,40 +693,34 @@ If ARG, don't do that. If ARG is 1, prompt for group name to post to.
This function prepares a news even when using mail groups. This is useful
for posting messages to mail groups without actually sending them over the
network. The corresponding back end must have a `request-post' method."
- (interactive "P")
- ;; We can't `let' gnus-newsgroup-name here, since that leads
- ;; to local variables leaking.
- (let ((group gnus-newsgroup-name)
- ;; make sure last viewed article doesn't affect posting styles:
- (gnus-article-copy)
- (buffer (current-buffer)))
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name
- (if arg
- (if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group"
- nil
- (gnus-read-active-file-p))
- "")
- gnus-newsgroup-name))
- ;; #### see comment in gnus-setup-message -- drv
- (gnus-setup-message 'message
- (progn
- (message-news (gnus-group-real-name gnus-newsgroup-name))
- (set (make-local-variable 'gnus-discouraged-post-methods)
- (remove
- (car (gnus-find-method-for-group gnus-newsgroup-name))
- gnus-discouraged-post-methods)))))
- (with-current-buffer buffer
- (setq gnus-newsgroup-name group)))))
+ (interactive "P" gnus-summary-mode)
+ (let* (;;(group gnus-newsgroup-name)
+ ;; make sure last viewed article doesn't affect posting styles:
+ (gnus-article-copy)
+ ;; (buffer (current-buffer))
+ (gnus-newsgroup-name
+ (if arg
+ (if (= 1 (prefix-numeric-value arg))
+ (gnus-group-completing-read "Use group"
+ nil
+ (gnus-read-active-file-p))
+ "")
+ gnus-newsgroup-name)))
+ (gnus-setup-message
+ 'message
+ (progn
+ (message-news (gnus-group-real-name gnus-newsgroup-name))
+ (setq-local gnus-discouraged-post-methods
+ (remove
+ (car (gnus-find-method-for-group gnus-newsgroup-name))
+ gnus-discouraged-post-methods))))))
(defun gnus-summary-post-news (&optional arg)
"Start composing a message. Post to the current group by default.
If ARG, don't do that. If ARG is 1, prompt for a group name to post to.
Depending on the selected group, the message might be either a mail or
a news."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
;; Bind this variable here to make message mode hooks work ok.
(let ((gnus-newsgroup-name
(if arg
@@ -768,9 +740,9 @@ If prefix argument YANK is non-nil, the original article is yanked
automatically.
YANK is a list of elements, where the car of each element is the
article number, and the cdr is the string to be yanked."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
(when yank
(gnus-summary-goto-subject
(if (listp (car yank))
@@ -790,19 +762,19 @@ article number, and the cdr is the string to be yanked."
"Compose a followup to an article and include the original article.
The text in the region will be yanked. If the region isn't
active, the entire article will be yanked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-followup (gnus-summary-work-articles n) force-news))
(defun gnus-summary-followup-to-mail (&optional arg)
"Followup to the current mail message via news."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
(gnus-summary-followup arg t))
(defun gnus-summary-followup-to-mail-with-original (&optional arg)
"Followup to the current mail message via news."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-followup (gnus-summary-work-articles arg) t))
(defun gnus-inews-yank-articles (articles)
@@ -823,7 +795,7 @@ active, the entire article will be yanked."
(with-current-buffer gnus-article-copy
(save-restriction
(nnheader-narrow-to-headers)
- (nnheader-parse-naked-head)))))
+ (nnheader-parse-head t)))))
(message-yank-original)
(message-exchange-point-and-mark)
(setq beg (or beg (mark t))))
@@ -837,10 +809,10 @@ active, the entire article will be yanked."
Uses the process-prefix convention. If given the symbolic
prefix `a', cancel using the standard posting method; if not
post using the current select method."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-summary-mode)
(let ((message-post-method
- `(lambda (arg)
- (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
+ (let ((gn gnus-newsgroup-name))
+ (lambda (_arg) (gnus-post-method (eq symp 'a) gn))))
(custom-address user-mail-address))
(dolist (article (gnus-summary-work-articles n))
(when (gnus-summary-select-article t nil nil article)
@@ -867,7 +839,7 @@ post using the current select method."
"Compose an article that will supersede a previous article.
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((article (gnus-summary-article-number))
(mail-parse-charset gnus-newsgroup-charset))
(gnus-setup-message 'reply-yank
@@ -875,11 +847,12 @@ header line with the old Message-ID."
(set-buffer gnus-original-article-buffer)
(message-supersede)
(push
- `((lambda ()
- (when (gnus-buffer-live-p ,gnus-summary-buffer)
- (with-current-buffer ,gnus-summary-buffer
- (gnus-cache-possibly-remove-article ,article nil nil nil t)
- (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
+ (let ((buf gnus-summary-buffer))
+ (lambda ()
+ (when (gnus-buffer-live-p buf)
+ (with-current-buffer buf
+ (gnus-cache-possibly-remove-article article nil nil nil t)
+ (gnus-summary-mark-as-read article gnus-canceled-mark)))))
message-send-actions)
;; Add Gcc header.
(gnus-inews-insert-gcc))))
@@ -949,7 +922,7 @@ header line with the old Message-ID."
(run-hooks 'gnus-article-decode-hook)))))
gnus-article-copy)))
-(defun gnus-post-news (post &optional group header article-buffer yank subject
+(defun gnus-post-news (post &optional group header article-buffer yank _subject
force-news)
(when article-buffer
(gnus-copy-article-buffer))
@@ -1055,8 +1028,8 @@ If SILENT, don't prompt the user."
gnus-post-method
(list gnus-post-method)))
gnus-secondary-select-methods
- (mapcar 'cdr gnus-server-alist)
- (mapcar 'car gnus-opened-servers)
+ (mapcar #'cdr gnus-server-alist)
+ (mapcar #'car gnus-opened-servers)
(list gnus-select-method)
(list group-method)))
method-alist post-methods method)
@@ -1084,7 +1057,7 @@ If SILENT, don't prompt the user."
;; Just use the last value.
gnus-last-posting-server
(gnus-completing-read
- "Posting method" (mapcar 'car method-alist) t
+ "Posting method" (mapcar #'car method-alist) t
(cons (or gnus-last-posting-server "") 0))))
method-alist))))
;; Override normal method.
@@ -1105,7 +1078,6 @@ If SILENT, don't prompt the user."
(defun gnus-extended-version ()
"Stringified Gnus version and Emacs version.
See the variable `gnus-user-agent'."
- (interactive)
(if (stringp gnus-user-agent)
gnus-user-agent
;; `gnus-user-agent' is a list:
@@ -1134,9 +1106,9 @@ If prefix argument YANK is non-nil, the original article is yanked
automatically.
If WIDE, make a wide reply.
If VERY-WIDE, make a very wide reply."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
;; 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)
@@ -1204,14 +1176,14 @@ If VERY-WIDE, make a very wide reply."
(defun gnus-summary-reply-with-original (n &optional wide)
"Start composing a reply mail to the current message.
The original article will be yanked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-reply (gnus-summary-work-articles n) wide))
(defun gnus-summary-reply-to-list-with-original (n &optional wide)
"Start composing a reply mail to the current message.
The reply goes only to the mailing list.
The original article will be yanked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((message-reply-to-function
(lambda nil
`((To . ,(gnus-mailing-list-followup-to))))))
@@ -1223,32 +1195,32 @@ If prefix argument YANK is non-nil, the original article is yanked
automatically.
If WIDE, make a wide reply.
If VERY-WIDE, make a very wide reply."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
(let ((gnus-msg-force-broken-reply-to t))
(gnus-summary-reply yank wide very-wide)))
(defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide)
"Like `gnus-summary-reply-with-original' except removing reply-to field.
The original article will be yanked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide))
(defun gnus-summary-wide-reply (&optional yank)
"Start composing a wide reply mail to the current message.
If prefix argument YANK is non-nil, the original article is yanked
automatically."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
(gnus-summary-reply yank t))
(defun gnus-summary-wide-reply-with-original (n)
"Start composing a wide reply mail to the current message.
The original article(s) will be yanked.
Uses the process/prefix convention."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-reply-with-original n t))
(defun gnus-summary-very-wide-reply (&optional yank)
@@ -1261,9 +1233,9 @@ messages as the To/Cc headers.
If prefix argument YANK is non-nil, the original article(s) will
be yanked automatically."
- (interactive
- (list (and current-prefix-arg
- (gnus-summary-work-articles 1))))
+ (interactive (list (and current-prefix-arg
+ (gnus-summary-work-articles 1)))
+ gnus-summary-mode)
(gnus-summary-reply yank t (gnus-summary-work-articles yank)))
(defun gnus-summary-very-wide-reply-with-original (n)
@@ -1275,7 +1247,7 @@ The reply will include all From/Cc headers from the original
messages as the To/Cc headers.
The original article(s) will be yanked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-reply
(gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
@@ -1291,7 +1263,7 @@ otherwise, use flipped `message-forward-as-mime'.
If POST, post instead of mail.
For the \"inline\" alternatives, also see the variable
`message-forward-ignored-headers'."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(if (cdr (gnus-summary-work-articles nil))
;; Process marks are given.
(gnus-uu-digest-mail-forward nil post)
@@ -1358,16 +1330,18 @@ For the \"inline\" alternatives, also see the variable
self))
"\n"))
((null self)
- (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))
+ (insert "Gcc: " (mapconcat #'identity gcc ", ") "\n"))
((eq self 'no-gcc-self)
(when (setq gcc (delete
gnus-newsgroup-name
(delete (concat "\"" gnus-newsgroup-name "\"")
gcc)))
- (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n")))))))
+ (insert "Gcc: " (mapconcat #'identity gcc ", ") "\n")))))))
-(defun gnus-summary-resend-message (address n)
- "Resend the current article to ADDRESS."
+(defun gnus-summary-resend-message (address n &optional no-select)
+ "Resend the current article to ADDRESS.
+Uses the process/prefix convention. If NO-SELECT, don't display
+the message before resending."
(interactive
(list (message-read-from-minibuffer
"Resend message(s) to: "
@@ -1378,7 +1352,8 @@ For the \"inline\" alternatives, also see the variable
;; initial-contents.
(with-current-buffer gnus-original-article-buffer
(nnmail-fetch-field "to"))))
- current-prefix-arg))
+ current-prefix-arg)
+ gnus-summary-mode)
(let ((message-header-setup-hook (copy-sequence message-header-setup-hook))
(message-sent-hook (copy-sequence message-sent-hook))
;; Honor posting-style for `name' and `address' in Resent-From header.
@@ -1386,6 +1361,7 @@ For the \"inline\" alternatives, also see the variable
'posting-style t))
(user-full-name user-full-name)
(user-mail-address user-mail-address)
+ (group gnus-newsgroup-name)
tem)
(dolist (style styles)
(when (stringp (cadr style))
@@ -1401,19 +1377,27 @@ For the \"inline\" alternatives, also see the variable
(setq user-mail-address tem))))
;; `gnus-summary-resend-message-insert-gcc' must run last.
(add-hook 'message-header-setup-hook
- 'gnus-summary-resend-message-insert-gcc t)
+ #'gnus-summary-resend-message-insert-gcc t)
(add-hook 'message-sent-hook
- `(lambda ()
- (let ((rfc2047-encode-encoded-words nil))
- ,(if gnus-agent
- '(gnus-agent-possibly-do-gcc)
- '(gnus-inews-do-gcc)))))
+ (let ((agent gnus-agent))
+ (lambda ()
+ (let ((rfc2047-encode-encoded-words nil))
+ (if agent
+ (gnus-agent-possibly-do-gcc)
+ (gnus-inews-do-gcc))))))
(dolist (article (gnus-summary-work-articles n))
- (gnus-summary-select-article nil nil nil article)
- (with-current-buffer gnus-original-article-buffer
- (let ((gnus-gcc-externalize-attachments nil)
- (message-inhibit-body-encoding t))
- (message-resend address)))
+ (if no-select
+ (with-current-buffer " *nntpd*"
+ (erase-buffer)
+ (gnus-request-article article group)
+ (let ((gnus-gcc-externalize-attachments nil)
+ (message-inhibit-body-encoding t))
+ (message-resend address)))
+ (gnus-summary-select-article nil nil nil article)
+ (with-current-buffer gnus-original-article-buffer
+ (let ((gnus-gcc-externalize-attachments nil)
+ (message-inhibit-body-encoding t))
+ (message-resend address))))
(gnus-summary-mark-article-as-forwarded article))))
;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
@@ -1422,7 +1406,7 @@ For the \"inline\" alternatives, also see the variable
A new buffer will be created to allow the user to modify body and
contents of the message, and then, everything will happen as when
composing a new message."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((mail-parse-charset gnus-newsgroup-charset))
(gnus-setup-message 'reply-yank
(gnus-summary-select-article t)
@@ -1450,12 +1434,12 @@ composing a new message."
(defun gnus-summary-post-forward (&optional arg)
"Forward the current article to a newsgroup.
See `gnus-summary-mail-forward' for ARG."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-mail-forward arg t))
(defun gnus-summary-mail-crosspost-complaint (n)
"Send a complaint about crossposting to the current article(s)."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(dolist (article (gnus-summary-work-articles n))
(set-buffer gnus-summary-buffer)
(gnus-summary-goto-subject article)
@@ -1510,7 +1494,11 @@ If YANK is non-nil, include the original article."
(gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
(defun gnus-bug (subject)
- "Send a bug report to the Emacs maintainers."
+ "Send a bug report to the Emacs maintainers.
+
+Already submitted bugs can be found in the Emacs bug tracker:
+
+ https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1"
(interactive "sBug Subject: ")
(report-emacs-bug subject)
(save-excursion
@@ -1519,9 +1507,9 @@ 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 (gnus-completing-read "Buffer" (message-buffers) t)
- current-prefix-arg))
+ (interactive (list (gnus-completing-read "Buffer" (message-buffers) t)
+ current-prefix-arg)
+ gnus-summary-mode)
(gnus-summary-iterate n
(let ((gnus-inhibit-treatment t))
(gnus-summary-select-article))
@@ -1538,7 +1526,7 @@ contains some mail you have written which has been bounced back to
you.
If FETCH, try to fetch the article that this is a reply to, if indeed
this is a reply."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-select-article t)
(let (summary-buffer parent)
(if fetch
@@ -1581,7 +1569,6 @@ this is a reply."
;; Do Gcc handling, which copied the message over to some group.
(defun gnus-inews-do-gcc (&optional gcc)
- (interactive)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@@ -1594,7 +1581,7 @@ this is a reply."
(message-remove-header "gcc")
(widen)
(setq groups (message-unquote-tokens
- (message-tokenize-header gcc " ,")))
+ (message-tokenize-header gcc " ,\n\t")))
;; Copy the article over to some group(s).
(while (setq group (pop groups))
(setq method (gnus-inews-group-method group)
@@ -1610,6 +1597,10 @@ this is a reply."
(if (stringp gnus-gcc-externalize-attachments)
(string-match gnus-gcc-externalize-attachments group)
gnus-gcc-externalize-attachments))
+ ;; If we want to externalize stuff when GCC-ing, then we
+ ;; can't use the cache, because that has all the contents.
+ (when mml-externalize-attachments
+ (setq encoded-cache nil))
(save-excursion
(nnheader-set-temp-buffer " *acc*")
(setq message-options (with-current-buffer cur message-options))
@@ -1670,9 +1661,7 @@ this is a reply."
;; FIXME: Should gcc-mark-as-read work when
;; Gnus is not running?
(gnus-alive-p))
- (if (or gnus-gcc-mark-as-read
- (and (boundp 'gnus-inews-mark-gcc-as-read)
- (symbol-value 'gnus-inews-mark-gcc-as-read)))
+ (if gnus-gcc-mark-as-read
(gnus-group-mark-article-read group (cdr group-art))
(with-current-buffer gnus-group-buffer
(let ((gnus-group-marked (list group))
@@ -1737,7 +1726,7 @@ this is a reply."
;; Function.
(funcall (car var) group))
(t
- (eval (car var)))))))
+ (eval (car var) t))))))
(setq var (cdr var)))
result)))
name)
@@ -1794,7 +1783,7 @@ this is a reply."
(with-current-buffer gnus-summary-buffer
gnus-posting-styles)
gnus-posting-styles))
- style match attribute value v results matched-string
+ match value v results matched-string ;; style attribute
filep name address element)
;; If the group has a posting-style parameter, add it at the end with a
;; regexp matching everything, to be sure it takes precedence over all
@@ -1849,7 +1838,7 @@ this is a reply."
(setq matched-string header)))))))
(t
;; This is a form to be evalled.
- (eval match)))))
+ (eval match t)))))
;; We have a match, so we set the variables.
(dolist (attribute style)
(setq element (pop attribute)
@@ -1880,7 +1869,7 @@ this is a reply."
((boundp value)
(symbol-value value))))
((listp value)
- (eval value))))
+ (eval value t))))
;; Translate obsolescent value.
(cond
((eq element 'signature-file)
@@ -1919,49 +1908,51 @@ this is a reply."
(add-hook 'message-setup-hook
(cond
((eq 'eval (car result))
- 'ignore)
+ #'ignore)
((eq 'body (car result))
- `(lambda ()
- (save-excursion
- (message-goto-body)
- (insert ,(cdr result)))))
+ (let ((txt (cdr result)))
+ (lambda ()
+ (save-excursion
+ (message-goto-body)
+ (insert txt)))))
((eq 'signature (car result))
- (set (make-local-variable 'message-signature) nil)
- (set (make-local-variable 'message-signature-file) nil)
- (if (not (cdr result))
- 'ignore
- `(lambda ()
- (save-excursion
- (let ((message-signature ,(cdr result)))
- (when message-signature
- (message-insert-signature)))))))
+ (setq-local message-signature nil)
+ (setq-local message-signature-file nil)
+ (let ((txt (cdr result)))
+ (if (not txt)
+ #'ignore
+ (lambda ()
+ (save-excursion
+ (let ((message-signature txt))
+ (when message-signature
+ (message-insert-signature))))))))
(t
(let ((header
(if (symbolp (car result))
(capitalize (symbol-name (car result)))
- (car result))))
- `(lambda ()
- (save-excursion
- (message-remove-header ,header)
- (let ((value ,(cdr result)))
- (when value
- (message-goto-eoh)
- (insert ,header ": " value)
- (unless (bolp)
- (insert "\n")))))))))
+ (car result)))
+ (value (cdr result)))
+ (lambda ()
+ (save-excursion
+ (message-remove-header header)
+ (when value
+ (message-goto-eoh)
+ (insert header ": " value)
+ (unless (bolp)
+ (insert "\n"))))))))
nil 'local))
(when (or name address)
(add-hook 'message-setup-hook
- `(lambda ()
- (set (make-local-variable 'user-mail-address)
- ,(or (cdr address) user-mail-address))
- (let ((user-full-name ,(or (cdr name) (user-full-name)))
- (user-mail-address
- ,(or (cdr address) user-mail-address)))
- (save-excursion
- (message-remove-header "From")
- (message-goto-eoh)
- (insert "From: " (message-make-from) "\n"))))
+ (let ((name (or (cdr name) (user-full-name)))
+ (email (or (cdr address) user-mail-address)))
+ (lambda ()
+ (setq-local user-mail-address email)
+ (let ((user-full-name name)
+ (user-mail-address email))
+ (save-excursion
+ (message-remove-header "From")
+ (message-goto-eoh)
+ (insert "From: " (message-make-from) "\n")))))
nil 'local)))))
(defun gnus-summary-attach-article (n)
@@ -1972,7 +1963,7 @@ created.
This command uses the process/prefix convention, so if you
process-mark several articles, they will all be attached."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((buffers (message-buffers))
destination)
;; Set up the destination mail composition buffer.
@@ -1989,10 +1980,10 @@ process-mark several articles, they will all be attached."
(gnus-summary-iterate n
(gnus-summary-select-article)
(with-current-buffer destination
- ;; Attach at the end of the buffer.
- (save-excursion
- (goto-char (point-max))
- (message-forward-make-body-mime gnus-original-article-buffer))))
+ ;; Attach at the end of the buffer.
+ (save-excursion
+ (goto-char (point-max))
+ (message-forward-make-body-mime gnus-original-article-buffer))))
(gnus-configure-windows 'message t)))
(provide 'gnus-msg)
diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el
index e772dd8e625..8646904637c 100644
--- a/lisp/gnus/gnus-notifications.el
+++ b/lisp/gnus/gnus-notifications.el
@@ -1,4 +1,4 @@
-;; gnus-notifications.el -- Send notification on new message in Gnus
+;;; gnus-notifications.el --- Send notification on new message in Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
@@ -24,7 +24,7 @@
;; This implements notifications using `notifications-notify' on new
;; messages received.
-;; Use (add-hook 'gnus-after-getting-new-news-hook 'gnus-notifications)
+;; Use (add-hook 'gnus-after-getting-new-news-hook #'gnus-notifications)
;; to get notifications just after getting the new news.
;;; Code:
@@ -47,26 +47,22 @@
(defcustom gnus-notifications-use-google-contacts t
"Use Google Contacts to retrieve photo."
- :type 'boolean
- :group 'gnus-notifications)
+ :type 'boolean)
(defcustom gnus-notifications-use-gravatar t
"Use Gravatar to retrieve photo."
- :type 'boolean
- :group 'gnus-notifications)
+ :type 'boolean)
(defcustom gnus-notifications-minimum-level 1
"Minimum group level the message should have to be notified.
Any message in a group that has a greater value than this will
not get notifications."
- :type 'integer
- :group 'gnus-notifications)
+ :type 'integer)
(defcustom gnus-notifications-timeout nil
"Timeout used for notifications sent via `notifications-notify'."
:type '(choice (const :tag "Server default" nil)
- (integer :tag "Milliseconds"))
- :group 'gnus-notifications)
+ (integer :tag "Milliseconds")))
(defvar gnus-notifications-sent nil
"Notifications already sent.")
diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el
index 92def9a72d0..fd4d3b8a762 100644
--- a/lisp/gnus/gnus-picon.el
+++ b/lisp/gnus/gnus-picon.el
@@ -1,4 +1,4 @@
-;;; gnus-picon.el --- displaying pretty icons in Gnus
+;;; gnus-picon.el --- displaying pretty icons in Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -112,7 +112,7 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
(let* ((address (gnus-picon-split-address address))
(user (pop address))
(faddress address)
- database directory result instance base)
+ result base) ;; database directory instance
(catch 'found
(dolist (database gnus-picon-databases)
(dolist (directory directories)
@@ -120,7 +120,7 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
base (expand-file-name directory database))
(while address
(when (setq result (gnus-picon-find-image
- (concat base "/" (mapconcat 'downcase
+ (concat base "/" (mapconcat #'downcase
(reverse address)
"/")
"/" (downcase user) "/")))
@@ -158,7 +158,7 @@ replacement is added."
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
- (cdar (push (cons file (apply 'gnus-create-image
+ (cdar (push (cons file (apply #'gnus-create-image
file nil nil
gnus-picon-properties))
gnus-picon-glyph-alist))))
@@ -190,7 +190,7 @@ replacement is added."
(gnus-picon-find-face
(concat "unknown@"
(mapconcat
- 'identity (cdr spec) "."))
+ #'identity (cdr spec) "."))
gnus-picon-user-directories)))
(setcar spec (cons (gnus-picon-create-glyph file)
(car spec))))
@@ -201,7 +201,7 @@ replacement is added."
(when (setq file (gnus-picon-find-face
(concat "unknown@"
(mapconcat
- 'identity (nthcdr (1+ i) spec) "."))
+ #'identity (nthcdr (1+ i) spec) "."))
gnus-picon-domain-directories t))
(setcar (nthcdr (1+ i) spec)
(cons (gnus-picon-create-glyph file)
@@ -214,10 +214,11 @@ replacement is added."
(cl-case gnus-picon-style
(right
(when (= (length addresses) 1)
- (setq len (apply '+ (mapcar (lambda (x)
- (condition-case nil
- (car (image-size (car x)))
- (error 0))) spec)))
+ (setq len (apply #'+ (mapcar (lambda (x)
+ (condition-case nil
+ (car (image-size (car x)))
+ (error 0)))
+ spec)))
(when (> len 0)
(goto-char (point-at-eol))
(insert (propertize
@@ -243,12 +244,12 @@ replacement is added."
(gnus-picon-insert-glyph (pop spec) category))))))))))
(defun gnus-picon-transform-newsgroups (header)
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-with-article-headers
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(let ((groups (message-tokenize-header (mail-fetch-field header)))
- spec file point)
+ spec file) ;; point
(dolist (group groups)
(unless (setq spec (cdr (assoc group gnus-picon-cache)))
(setq spec (nreverse (split-string group "[.]")))
@@ -256,7 +257,7 @@ replacement is added."
(when (setq file (gnus-picon-find-face
(concat "unknown@"
(mapconcat
- 'identity (nthcdr i spec) "."))
+ #'identity (nthcdr i spec) "."))
gnus-picon-news-directories t))
(setcar (nthcdr i spec)
(cons (gnus-picon-create-glyph file)
@@ -282,7 +283,7 @@ replacement is added."
(defun gnus-treat-from-picon ()
"Display picons in the From header.
If picons are already displayed, remove them."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
@@ -293,7 +294,7 @@ If picons are already displayed, remove them."
(defun gnus-treat-mail-picon ()
"Display picons in the Cc and To headers.
If picons are already displayed, remove them."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types))
@@ -305,7 +306,7 @@ If picons are already displayed, remove them."
(defun gnus-treat-newsgroups-picon ()
"Display picons in the Newsgroups and Followup-To headers.
If picons are already displayed, remove them."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types))
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index 1e5d2a066f6..7d12ae9fdcc 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -1,4 +1,4 @@
-;;; gnus-range.el --- range and sequence functions for Gnus
+;;; gnus-range.el --- range and sequence functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -42,13 +42,8 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
(defun gnus-set-difference (list1 list2)
"Return a list of elements of LIST1 that do not appear in LIST2."
- (let ((hash2 (make-hash-table :test 'eq))
- (result nil))
- (dolist (elt list2) (puthash elt t hash2))
- (dolist (elt list1)
- (unless (gethash elt hash2)
- (setq result (cons elt result))))
- (nreverse result)))
+ (declare (obsolete seq-difference "28.1"))
+ (seq-difference list1 list2 #'eq))
(defun gnus-range-nconcat (&rest ranges)
"Return a range comprising all the RANGES, which are pre-sorted.
@@ -87,7 +82,7 @@ Both ranges must be in ascending order."
(setq range2 (gnus-range-normalize range2))
(let* ((new-range (cons nil (copy-sequence range1)))
(r new-range)
- (safe t))
+ ) ;; (safe t)
(while (cdr r)
(let* ((r1 (cadr r))
(r2 (car range2))
@@ -179,12 +174,8 @@ Both lists have to be sorted over <."
;;;###autoload
(defun gnus-intersection (list1 list2)
- (let ((result nil))
- (while list2
- (when (memq (car list2) list1)
- (setq result (cons (car list2) result)))
- (setq list2 (cdr list2)))
- result))
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection list1 list2 #'eq)))
;;;###autoload
(defun gnus-sorted-intersection (list1 list2)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 0b57650d4ef..0468d72edd0 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -1,4 +1,4 @@
-;;; gnus-registry.el --- article registry for Gnus
+;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -54,6 +54,9 @@
;; (: gnus-registry-split-fancy-with-parent)
+;; This won't work as expected unless `gnus-registry-register-all'
+;; is set to t.
+
;; You should also consider using the nnregistry backend to look up
;; articles. See the Gnus manual for more information.
@@ -62,10 +65,10 @@
;; show the marks as single characters (see the :char property in
;; `gnus-registry-marks'):
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
+;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars)
;; show the marks by name (see `gnus-registry-marks'):
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
+;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names)
;; TODO:
@@ -85,7 +88,6 @@
(require 'gnus-art)
(require 'gnus-util)
(require 'nnmail)
-(require 'easymenu)
(require 'registry)
(defvar gnus-adaptive-word-syntax-table)
@@ -128,7 +130,6 @@ 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-addresses
@@ -138,7 +139,6 @@ The addresses are matched, they don't have to be fully qualified.
In the messages, these addresses can be the sender or the
recipients."
:version "24.1"
- :group 'gnus-registry
:type '(repeat regexp))
(defcustom gnus-registry-unfollowed-groups
@@ -150,16 +150,19 @@ message into a group that matches one of these, regardless of
references.'
nnmairix groups are specifically excluded because they are ephemeral."
- :group 'gnus-registry
:type '(repeat regexp))
(defcustom gnus-registry-install 'ask
"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)))
+(defcustom gnus-registry-register-all t
+ "If non-nil, register all articles in the registry."
+ :type 'boolean
+ :version "28.1")
+
(defvar gnus-registry-enabled nil)
(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
@@ -173,7 +176,6 @@ nnmairix groups are specifically excluded because they are ephemeral."
"Whether the registry should track extra data about a message.
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)
@@ -197,7 +199,6 @@ 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
'(choice :tag "Splitting strategy"
(const :tag "Only use single choices, discard multiple matches" nil)
@@ -206,7 +207,6 @@ groups."
(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-extra-entries-precious '(mark)
@@ -217,20 +217,18 @@ 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
+ ;; FIXME: Use `locate-user-emacs-file'!
(nnheader-concat
(or gnus-dribble-directory gnus-home-directory "~/")
".gnus.registry.eieio")
"File where the Gnus registry will be stored."
- :group 'gnus-registry
:type 'file)
(defcustom gnus-registry-max-entries nil
"Maximum number of entries in the registry, nil for unlimited."
- :group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v")))
@@ -245,7 +243,6 @@ cut the registry back to \(- 50000 \(* 50000 0.1)) -> 45000
entries. The pruning process is constrained by the presence of
\"precious\" entries."
:version "25.1"
- :group 'gnus-registry
:type 'float)
(defcustom gnus-registry-default-sort-function
@@ -254,7 +251,6 @@ entries. The pruning process is constrained by the presence of
Entries that sort to the front of the list are pruned first.
This can slow pruning down. Set to nil to perform no sorting."
:version "25.1"
- :group 'gnus-registry
:type '(choice (const :tag "No sorting" nil) function))
(defun gnus-registry-sort-by-creation-time (l r)
@@ -323,9 +319,12 @@ Encode names if ENCODE is non-nil, otherwise decode."
(setf (oref db tracked)
(append gnus-registry-track-extra
'(mark group keyword)))
- (when (not (equal old (oref db tracked)))
+ (when (not (seq-set-equal-p old (oref db tracked)))
(gnus-message 9 "Reindexing the Gnus registry (tracked change)")
- (registry-reindex db))
+ (let ((message-log-max (if (< gnus-verbose 9)
+ nil
+ message-log-max)))
+ (registry-reindex db)))
(gnus-registry--munge-group-names db)))
db)
@@ -427,6 +426,8 @@ This is not required after changing `gnus-registry-cache-file'."
(gnus-message 4 "Removed %d ignored entries from the Gnus registry"
(- old-size (registry-size db)))))
+(declare-function gnus-nnselect-group-p "nnselect" (group))
+(declare-function nnselect-article-group "nnselect" (article))
;; article move/copy/spool/delete actions
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
@@ -437,7 +438,10 @@ This is not required after changing `gnus-registry-cache-file'."
(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))
+ (from (gnus-group-guess-full-name-from-command-method
+ (if (gnus-nnselect-group-p from)
+ (nnselect-article-group (mail-header-number data-header))
+ from)))
(to (if to (gnus-group-guess-full-name-from-command-method to) nil)))
(gnus-message 7 "Gnus registry: article %s %s from %s to %s"
id (if method "respooling" "going") from to)
@@ -449,19 +453,21 @@ This is not required after changing `gnus-registry-cache-file'."
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 "Gnus registry: article %s spooled to %s"
- id
- to)
- (gnus-registry-handle-action id nil to subject sender recipients)))
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (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 "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)
@@ -471,8 +477,8 @@ This is not required after changing `gnus-registry-cache-file'."
(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))
+ ;; Only retrieve an existing entry, don't create a new one.
+ (entry (gnus-registry-get-or-make-entry id t))
(subject (gnus-string-remove-all-properties
(gnus-registry-simplify-subject subject)))
(sender (gnus-string-remove-all-properties sender)))
@@ -481,27 +487,30 @@ This is not required after changing `gnus-registry-cache-file'."
;; 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 (cadr kv)
- (let ((new (or (assq (car kv) entry)
- (list (car kv)))))
- (dolist (toadd (cdr kv))
- (unless (member toadd new)
- (setq new (append new (list toadd)))))
- (setq entry (cons new
- (assq-delete-all (car kv) entry))))))
- (gnus-message 10 "Gnus registry: new entry for %s is %S"
- id
- entry)
- (gnus-registry-insert db id entry)))
+ (when entry
+ (registry-delete db (list id) nil)
+ (when from
+ (setq entry (cons (delete from (assoc 'group entry))
+ (assq-delete-all 'group entry))))
+ ;; Only keep the entry if the message is going to a new group, or
+ ;; it's still in some previous group.
+ (when (or to (alist-get 'group entry))
+ (dolist (kv `((group ,to)
+ (sender ,sender)
+ (recipient ,@recipients)
+ (subject ,subject)))
+ (when (cadr kv)
+ (let ((new (or (assq (car kv) entry)
+ (list (car kv)))))
+ (dolist (toadd (cdr kv))
+ (unless (member toadd new)
+ (setq new (append new (list toadd)))))
+ (setq entry (cons new
+ (assq-delete-all (car 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.
@@ -588,7 +597,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
subject
(< gnus-registry-minimum-subject-length (length subject)))
(let ((groups (apply
- 'append
+ #'append
(mapcar
(lambda (reference)
(gnus-registry-get-id-key reference 'group))
@@ -615,7 +624,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
sender
gnus-registry-unfollowed-addresses)))
(let ((groups (apply
- 'append
+ #'append
(mapcar
(lambda (reference)
(gnus-registry-get-id-key reference 'group))
@@ -644,7 +653,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(not (gnus-grep-in-list
recp
gnus-registry-unfollowed-addresses)))
- (let ((groups (apply 'append
+ (let ((groups (apply #'append
(mapcar
(lambda (reference)
(gnus-registry-get-id-key reference 'group))
@@ -663,7 +672,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;; 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)))
+ "recipients" (mapconcat #'identity recipients ", ") found)))
;; after the (cond) we extract the actual value safely
(car-safe found)))
@@ -784,14 +793,15 @@ Consults `gnus-registry-unfollowed-groups' and
Consults `gnus-registry-ignored-groups' and
`nnmail-split-fancy-with-parent-ignore-groups'."
(and group
- (or (gnus-grep-in-list
+ (or (gnus-virtual-group-p group) (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)))
+ (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)
@@ -805,7 +815,7 @@ Consults `gnus-registry-ignored-groups' and
(defun gnus-registry-wash-for-keywords (&optional force)
"Get the keywords of the current article.
Overrides existing keywords with FORCE set non-nil."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
word words)
(if (or (not (gnus-registry-get-id-key id 'keyword))
@@ -836,7 +846,8 @@ Overrides existing keywords with FORCE set non-nil."
(defun gnus-registry-register-message-ids ()
"Register the Message-ID of every article in the group."
- (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
+ (unless (or (gnus-parameter-registry-ignore gnus-newsgroup-name)
+ (null gnus-registry-register-all))
(dolist (article gnus-newsgroup-articles)
(let* ((id (gnus-registry-fetch-message-id-fast article))
(groups (gnus-registry-get-id-key id 'group)))
@@ -871,7 +882,7 @@ Addresses without a name will say \"noname\"."
(defun gnus-registry-sort-addresses (&rest addresses)
"Return a normalized and sorted list of ADDRESSES."
- (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp))
+ (sort (mapcan #'gnus-registry-extract-addresses addresses) #'string-lessp))
(defun gnus-registry-simplify-subject (subject)
(if (stringp subject)
@@ -961,16 +972,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(intern (format function-format variant-name)))
(shortcut (format "%c" (if remove (upcase data) data))))
(defalias function-name
- ;; If it weren't for the function's docstring, we could
- ;; use a closure, with lexical-let :-(
- `(lambda (&rest articles)
- ,(format
- "%s the %s mark over process-marked ARTICLES."
- (upcase-initials variant-name)
- mark)
- (interactive
- (gnus-summary-work-articles current-prefix-arg))
- (gnus-registry--set/remove-mark ',mark ',remove articles)))
+ (lambda (&rest articles)
+ (:documentation
+ (format
+ "%s the %s mark over process-marked ARTICLES."
+ (upcase-initials variant-name)
+ mark))
+ (interactive
+ (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry--set/remove-mark mark remove articles)))
(push function-name keys-plist)
(push shortcut keys-plist)
(push (vector (format "%s %s"
@@ -990,14 +1000,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
nil
(cons "Registry Marks" gnus-registry-misc-menus))))))
-(make-obsolete 'gnus-registry-user-format-function-M
- 'gnus-registry-article-marks-to-chars "24.1") ?
-
-(defalias 'gnus-registry-user-format-function-M
- 'gnus-registry-article-marks-to-chars)
+(define-obsolete-function-alias 'gnus-registry-user-format-function-M
+ #'gnus-registry-article-marks-to-chars "24.1")
;; use like this:
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
+;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars)
(defun gnus-registry-article-marks-to-chars (headers)
"Show the marks for an article by the :char property."
(if gnus-registry-enabled
@@ -1013,20 +1020,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
""))
;; use like this:
-;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
+;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names)
(defun gnus-registry-article-marks-to-names (headers)
"Show the marks for an article by name."
(if gnus-registry-enabled
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-get-id-key id 'mark))))
- (mapconcat (lambda (mark) (symbol-name mark)) marks ","))
+ (mapconcat #'symbol-name marks ","))
""))
(defun gnus-registry-read-mark ()
"Read a mark name from the user with completion."
(let ((mark (gnus-completing-read
"Label"
- (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
+ (mapcar #'symbol-name (mapcar #'car gnus-registry-marks))
nil nil nil
(symbol-name gnus-registry-default-mark))))
(when (stringp mark)
@@ -1034,13 +1041,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(defun gnus-registry-set-article-mark (&rest articles)
"Apply a mark to process-marked ARTICLES."
- (interactive (gnus-summary-work-articles current-prefix-arg))
+ (interactive (gnus-summary-work-articles current-prefix-arg)
+ gnus-article-mode gnus-summary-mode)
(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))
+ (interactive (gnus-summary-work-articles current-prefix-arg)
+ gnus-article-mode gnus-summary-mode)
(gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
articles t t))
@@ -1050,7 +1059,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
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* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
(marks (if remove marks (cons mark marks))))
@@ -1064,7 +1073,8 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
"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))
+ (interactive (gnus-summary-work-articles 1)
+ gnus-article-mode gnus-summary-mode)
(let* ((article (last articles))
(id (gnus-registry-fetch-message-id-fast article))
(marks (when id (gnus-registry-get-id-key id 'mark))))
@@ -1076,12 +1086,15 @@ only the last one's marks are returned."
"Get the number of groups of a message, based on the message ID."
(length (gnus-registry-get-id-key id 'group)))
-(defun gnus-registry-get-or-make-entry (id)
+(defun gnus-registry-get-or-make-entry (id &optional no-create)
+ "Return registry entry for ID.
+If entry is not found, create a new one, unless NO-CREATE is
+non-nil."
(let* ((db gnus-registry-db)
;; safe if not found
(entries (registry-lookup db (list id))))
- (when (null entries)
+ (unless (or entries no-create)
(gnus-registry-insert db id (list (list 'creation-time (current-time))
'(group) '(sender) '(subject)))
(setq entries (registry-lookup db (list id))))
@@ -1092,7 +1105,8 @@ only the last one's marks are returned."
(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))))
+ (cdr-safe (assq key (gnus-registry-get-or-make-entry
+ id (null gnus-registry-register-all)))))
(defun gnus-registry-set-id-key (id key vals)
(let* ((db gnus-registry-db)
@@ -1173,34 +1187,34 @@ only the last one's marks are returned."
(gnus-registry-install-shortcuts)
(if (gnus-alive-p)
(gnus-registry-load)
- (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)))
+ (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load)))
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
(setq gnus-registry-enabled t)
- (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
- (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
- (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
- (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
+ (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action)
+ (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action)
+ (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action)
+ (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action)
- (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
+ (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save)
- (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+ (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids))
(defun gnus-registry-unload-hook ()
"Uninstall the registry hooks."
- (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
- (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
- (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
- (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
+ (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action)
+ (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action)
+ (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action)
+ (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action)
- (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
- (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)
+ (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save)
+ (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load)
- (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+ (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)
(setq gnus-registry-enabled nil))
-(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
+(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook)
(defun gnus-registry-install-p ()
"Return non-nil if the registry is enabled (and maybe enable it first).
@@ -1217,7 +1231,7 @@ is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it."
(gnus-registry-initialize)))
gnus-registry-enabled)
-;; largely based on nnir-warp-to-article
+;; largely based on nnselect-warp-to-article
(defun gnus-try-warping-via-registry ()
"Try to warp via the registry.
This will be done via the current article's source group based on
@@ -1234,14 +1248,14 @@ data stored in the registry."
(seen-groups (list (gnus-group-group-name))))
(catch 'found
- (dolist (group (mapcar 'gnus-simplify-group-name groups))
+ (dolist (group (mapcar #'gnus-simplify-group-name groups))
;; skip over any groups we really don't want to warp to.
(unless (or (member group seen-groups)
(gnus-ephemeral-group-p group) ;; any ephemeral group
(memq (car (gnus-find-method-for-group group))
;; Specific methods; this list may need to expand.
- '(nnir)))
+ '(nnselect)))
;; remember that we've seen this group already
(push group seen-groups)
@@ -1270,7 +1284,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in
the docs of `gnus-registry-track-extra'. This command is useful
when you stop tracking some extra data and now want to purge it
from your existing entries."
- (interactive (list (mapcar 'intern
+ (interactive (list (mapcar #'intern
(completing-read-multiple
"Extra data: "
'("subject" "sender" "recipient")))))
@@ -1279,16 +1293,14 @@ from your existing entries."
(registry-reindex db)
(cl-loop for k being the hash-keys of (oref db data)
using (hash-value v)
- do (let ((newv (delq nil (mapcar #'(lambda (entry)
- (unless (member (car entry) extra)
- entry))
+ do (let ((newv (delq nil (mapcar (lambda (entry)
+ (unless (member (car entry) extra)
+ entry))
v))))
(registry-delete db (list k) nil)
(gnus-registry-insert db k newv)))
(registry-reindex db))))
-;; TODO: a few things
-
(provide 'gnus-registry)
;;; gnus-registry.el ends here
diff --git a/lisp/gnus/gnus-rfc1843.el b/lisp/gnus/gnus-rfc1843.el
index 107e96350bb..5697c870888 100644
--- a/lisp/gnus/gnus-rfc1843.el
+++ b/lisp/gnus/gnus-rfc1843.el
@@ -1,4 +1,4 @@
-;;; gnus-rfc1843.el --- HZ (rfc1843) decoding interface functions for Gnus
+;;; gnus-rfc1843.el --- HZ (rfc1843) decoding interface functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -56,11 +56,11 @@
(defun rfc1843-gnus-setup ()
"Setup HZ decoding for Gnus."
- (add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t)
+ (add-hook 'gnus-article-decode-hook #'rfc1843-decode-article-body t)
(setq gnus-decode-encoded-word-function
- 'gnus-multi-decode-encoded-word-string
+ #'gnus-multi-decode-encoded-word-string
gnus-decode-header-function
- 'gnus-multi-decode-header
+ #'gnus-multi-decode-header
gnus-decode-encoded-word-methods
(nconc gnus-decode-encoded-word-methods
(list
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index 0e0523fd91b..5b746a8efa9 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -1,4 +1,4 @@
-;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
+;;; gnus-salt.el --- alternate summary mode interfaces for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2001-2021 Free Software Foundation, Inc.
@@ -103,18 +103,18 @@ It accepts the same format specs that `gnus-summary-line-format' does."
((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))
+ (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)
+ (setq-local 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)
+ (add-hook 'gnus-message-setup-hook #'gnus-pick-setup-message)
+ (setq-local gnus-summary-goto-unread 'never)
;; Set up the menu.
(when (gnus-visual-p 'pick-menu 'menu)
(gnus-pick-make-menu-bar)))))
@@ -137,6 +137,8 @@ It accepts the same format specs that `gnus-summary-line-format' does."
"Start reading the picked articles.
If given a prefix, mark all unpicked articles as read."
(interactive "P")
+ (declare (completion (lambda (s b)
+ (completion-minor-mode-active-p s b 'gnus-pick-mode))))
(if gnus-newsgroup-processable
(progn
(gnus-summary-limit-to-articles nil)
@@ -333,10 +335,8 @@ This must be bound to a button-down mouse event."
((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)
+ (setq-local gnus-auto-select-first nil)
+ (setq-local 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)))))
@@ -464,7 +464,7 @@ Two predefined functions are available:
(defun gnus-tree-read-summary-keys (&optional arg)
"Read a summary buffer key sequence and execute it."
- (interactive "P")
+ (interactive "P" gnus-tree-mode)
(unless gnus-tree-inhibit
(let ((buf (current-buffer))
(gnus-tree-inhibit t)
@@ -479,7 +479,7 @@ Two predefined functions are available:
(defun gnus-tree-show-summary ()
"Reconfigure windows to show summary buffer."
- (interactive)
+ (interactive nil gnus-tree-mode)
(if (not (gnus-buffer-live-p gnus-summary-buffer))
(error "There is no summary buffer for this tree buffer")
(gnus-configure-windows 'article)
@@ -487,7 +487,7 @@ Two predefined functions are available:
(defun gnus-tree-select-article (article)
"Select the article under point, if any."
- (interactive (list (gnus-tree-article-number)))
+ (interactive (list (gnus-tree-article-number)) gnus-tree-mode)
(let ((buf (current-buffer)))
(when article
(with-current-buffer gnus-summary-buffer
@@ -496,7 +496,7 @@ Two predefined functions are available:
(defun gnus-tree-pick-article (e)
"Select the article under the mouse pointer."
- (interactive "e")
+ (interactive "e" gnus-tree-mode)
(mouse-set-point e)
(gnus-tree-select-article (gnus-tree-article-number)))
@@ -611,7 +611,7 @@ Two predefined functions are available:
beg end)
(add-text-properties
(setq beg (point))
- (setq end (progn (eval gnus-tree-line-format-spec) (point)))
+ (setq end (progn (eval gnus-tree-line-format-spec t) (point)))
(list 'gnus-number gnus-tmp-number))
(when (or t (gnus-visual-p 'tree-highlight 'highlight))
(gnus-tree-highlight-node gnus-tmp-number beg end))))
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index e270253e8a6..f40da9e9c4c 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -1,4 +1,4 @@
-;;; gnus-score.el --- scoring code for Gnus
+;;; gnus-score.el --- scoring code for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -25,8 +25,6 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
-
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-art)
@@ -35,6 +33,7 @@
(require 'message)
(require 'score-mode)
(require 'gmm-utils)
+(require 'cl-lib)
(defcustom gnus-global-score-files nil
"List of global score files and directories.
@@ -249,7 +248,7 @@ If you use score decays, you might want to set values higher than
(integer :tag "Score"))))))
(defcustom gnus-adaptive-word-length-limit nil
- "Words of a length lesser than this limit will be ignored when doing adaptive scoring."
+ "Words shorter than this limit will be ignored when doing adaptive scoring."
:version "22.1"
:group 'gnus-score-adapt
:type '(radio (const :format "Unlimited " nil)
@@ -497,6 +496,7 @@ of the last successful match.")
("head" -1 gnus-score-body)
("body" -1 gnus-score-body)
("all" -1 gnus-score-body)
+ (score-fn -1 nil)
("followup" 2 gnus-score-followup)
("thread" 5 gnus-score-thread)))
@@ -528,7 +528,8 @@ permanence, and the string to be used. The numerical prefix will
be used as SCORE. A symbolic prefix of `a' (the SYMP parameter)
says to use the `all.SCORE' file for the command instead of the
current score file."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny")
+ gnus-article-mode gnus-summary-mode)
(gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))
(defun gnus-score-kill-help-buffer ()
@@ -544,7 +545,8 @@ permanence, and the string to be used. The numerical prefix will
be used as SCORE. A symbolic prefix of `a' (the SYMP parameter)
says to use the `all.SCORE' file for the command instead of the
current score file."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny")
+ gnus-article-mode gnus-summary-mode)
(let* ((nscore (gnus-score-delta-default score))
(prefix (if (< nscore 0) ?L ?I))
(increase (> nscore 0))
@@ -683,7 +685,7 @@ current score file."
(and gnus-extra-headers
(equal (nth 1 entry) "extra")
(intern ; need symbol
- (let ((collection (mapcar 'symbol-name gnus-extra-headers)))
+ (let ((collection (mapcar #'symbol-name gnus-extra-headers)))
(gnus-completing-read
"Score extra header" ; prompt
collection ; completion list
@@ -862,6 +864,18 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
(setq match (string-to-number match)))
(set-text-properties 0 (length match) nil match))
+ ;; Modify match and type for article age scoring.
+ (if (string= "date" (nth 0 (assoc header gnus-header-index)))
+ (let ((age (string-to-number match)))
+ (if (or (< age 0)
+ (string= "0" match))
+ (user-error "Article age must be a positive number"))
+ (setq match age
+ type (cond ((eq type 'after)
+ '<)
+ ((eq type 'before)
+ '>)))))
+
(unless (eq date 'now)
;; Add the score entry to the score file.
(when (= score gnus-score-interactive-default-score)
@@ -919,15 +933,16 @@ TYPE is the score type.
SCORE is the score to add.
EXTRA is the possible non-standard header."
(interactive (list (gnus-completing-read "Header"
- (mapcar
- 'car
+ (mapcar
+ #'car
(seq-filter
(lambda (x) (fboundp (nth 2 x)))
gnus-header-index))
- t)
+ t)
(read-string "Match: ")
(if (y-or-n-p "Use regexp match? ") 'r 's)
- (string-to-number (read-string "Score: "))))
+ (string-to-number (read-string "Score: ")))
+ gnus-article-mode gnus-summary-mode)
(save-excursion
(unless (and (stringp match) (> (length match) 0))
(error "No match"))
@@ -962,7 +977,8 @@ EXTRA is the possible non-standard header."
"Automatically mark articles with score below SCORE as read."
(interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
- (string-to-number (read-string "Mark below: ")))))
+ (string-to-number (read-string "Mark below: "))))
+ gnus-article-mode gnus-summary-mode)
(setq score (or score gnus-summary-default-score 0))
(gnus-score-set 'mark (list score))
(gnus-score-set 'touched '(t))
@@ -996,14 +1012,15 @@ EXTRA is the possible non-standard header."
"Automatically expunge articles with score below SCORE."
(interactive
(list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
- (string-to-number (read-string "Set expunge below: ")))))
+ (string-to-number (read-string "Set expunge below: "))))
+ gnus-article-mode gnus-summary-mode)
(setq score (or score gnus-summary-default-score 0))
(gnus-score-set 'expunge (list score))
(gnus-score-set 'touched '(t)))
(defun gnus-score-followup-article (&optional score)
"Add SCORE to all followups to the article in the current buffer."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(setq score (gnus-score-delta-default score))
(when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
@@ -1018,7 +1035,7 @@ EXTRA is the possible non-standard header."
(defun gnus-score-followup-thread (&optional score)
"Add SCORE to all later articles in the thread the current buffer is part of."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(setq score (gnus-score-delta-default score))
(when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
@@ -1052,13 +1069,13 @@ EXTRA is the possible non-standard header."
(defun gnus-summary-raise-score (n)
"Raise the score of the current article by N."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(gnus-summary-set-score (+ (gnus-summary-article-score)
(or n gnus-score-interactive-default-score ))))
(defun gnus-summary-set-score (n)
"Set the score of the current article to N."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(save-excursion
(gnus-summary-show-thread)
(let ((buffer-read-only nil))
@@ -1077,7 +1094,7 @@ EXTRA is the possible non-standard header."
(defun gnus-summary-current-score (arg)
"Return the score of the current article.
With prefix ARG, return the total score of the current (sub)thread."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(message "%s" (if arg
(gnus-thread-total-score
(gnus-id-to-thread
@@ -1087,14 +1104,16 @@ EXTRA is the possible non-standard header."
(defun gnus-score-change-score-file (file)
"Change current score alist."
(interactive
- (list (read-file-name "Change to score file: " gnus-kill-files-directory)))
+ (list (read-file-name "Change to score file: " gnus-kill-files-directory))
+ gnus-article-mode gnus-summary-mode)
(gnus-score-load-file file)
(gnus-set-mode-line 'summary))
(defvar gnus-score-edit-exit-function)
(defun gnus-score-edit-current-scores (file)
"Edit the current score alist."
- (interactive (list gnus-current-score-file))
+ (interactive (list gnus-current-score-file)
+ gnus-article-mode gnus-summary-mode)
(if (not gnus-current-score-file)
(error "No current score file")
(let ((winconf (current-window-configuration)))
@@ -1105,8 +1124,7 @@ EXTRA is the possible non-standard header."
(gnus-configure-windows 'edit-score)
(gnus-score-mode)
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf))
+ (setq-local gnus-prev-winconf winconf))
(gnus-message
4 "%s" (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
@@ -1133,8 +1151,7 @@ EXTRA is the possible non-standard header."
(gnus-configure-windows 'edit-score)
(gnus-score-mode)
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf))
+ (setq-local gnus-prev-winconf winconf))
(gnus-message
4 "%s" (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
@@ -1163,14 +1180,19 @@ If FORMAT, also format the current score file."
(when format
(gnus-score-pretty-print))
(when (consp rule) ;; the rule exists
- (setq rule (mapconcat #'(lambda (obj)
- (regexp-quote (format "%S" obj)))
- rule
- sep))
+ (setq rule (if (symbolp (car rule))
+ (format "(%S)" (car rule))
+ (mapconcat (lambda (obj)
+ (regexp-quote (format "%S" obj)))
+ rule
+ sep)))
(goto-char (point-min))
- (re-search-forward rule nil t)
- ;; make it easy to use `kill-sexp':
- (goto-char (1- (match-beginning 0)))))))
+ (let ((move (if (string-match "(.*)" rule)
+ 0
+ -1)))
+ (re-search-forward rule nil t)
+ ;; make it easy to use `kill-sexp':
+ (goto-char (+ move (match-beginning 0))))))))
(defun gnus-score-load-file (file)
;; Load score file FILE. Returns a list a retrieved score-alists.
@@ -1220,6 +1242,7 @@ If FORMAT, also format the current score file."
(let ((mark (car (gnus-score-get 'mark alist)))
(expunge (car (gnus-score-get 'expunge alist)))
(mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
+ ;; (score-fn (car (gnus-score-get 'score-fn alist)))
(files (gnus-score-get 'files alist))
(exclude-files (gnus-score-get 'exclude-files alist))
(orphan (car (gnus-score-get 'orphan alist)))
@@ -1242,17 +1265,17 @@ If FORMAT, also format the current score file."
;; We do not respect eval and files atoms from global score
;; files.
(when (and files (not global))
- (setq lists (apply 'append lists
- (mapcar 'gnus-score-load-file
+ (setq lists (apply #'append lists
+ (mapcar #'gnus-score-load-file
(if adapt-file (cons adapt-file files)
files)))))
(when (and eval (not global))
- (eval eval))
+ (eval eval t))
;; We then expand any exclude-file directives.
(setq gnus-scores-exclude-files
(nconc
(apply
- 'nconc
+ #'nconc
(mapcar
(lambda (sfile)
(list
@@ -1370,9 +1393,12 @@ If FORMAT, also format the current score file."
(setq
err
(cond
- ((if (member (downcase type) '("lines" "chars"))
- (not (numberp (car s)))
- (not (stringp (car s))))
+ ((cond ((member (downcase type) '("lines" "chars"))
+ (not (numberp (car s))))
+ ((string= (downcase type) "date")
+ (not (or (numberp (car s))
+ (stringp (car s)))))
+ (t (not (stringp (car s)))))
(format "Invalid match %s in %s" (car s) file))
((and (cadr s) (not (integerp (cadr s))))
(format "Non-integer score %s in %s" (cadr s) file))
@@ -1535,10 +1561,10 @@ If FORMAT, also format the current score file."
(setq entry (pop entries)
header (nth 0 entry)
gnus-score-index (nth 1 (assoc header gnus-header-index)))
- (when (< 0 (apply 'max (mapcar
- (lambda (score)
- (length (gnus-score-get header score)))
- scores)))
+ (when (< 0 (apply #'max (mapcar
+ (lambda (score)
+ (length (gnus-score-get header score)))
+ scores)))
(when (if (and gnus-inhibit-slow-scoring
(or (eq gnus-inhibit-slow-scoring t)
(and (stringp gnus-inhibit-slow-scoring)
@@ -1552,10 +1578,14 @@ If FORMAT, also format the current score file."
(gnus-message
7 "Scoring on headers or body skipped.")
nil)
- ;; Call the scoring function for this type of "header".
- (setq new (funcall (nth 2 entry) scores header
- now expire trace)))
+ ;; Run score-fn
+ (if (eq header 'score-fn)
+ (setq new (gnus-score-func scores trace))
+ ;; Call the scoring function for this type of "header".
+ (setq new (funcall (nth 2 entry) scores header
+ now expire trace))))
(push new news))))
+
(when (gnus-buffer-live-p gnus-summary-buffer)
(let ((scored gnus-newsgroup-scored))
(with-current-buffer gnus-summary-buffer
@@ -1621,6 +1651,30 @@ score in `gnus-newsgroup-scored' by SCORE."
(not (string= id "")))
(gnus-score-lower-thread thread score)))))
+(defun gnus-score-func (scores &optional trace)
+ (dolist (alist scores)
+ (let ((articles gnus-scores-articles)
+ (entries (assoc 'score-fn alist)))
+ (dolist (score-fn (cdr entries))
+ (let ((score-fn (car score-fn))
+ article-alist score fn-score)
+ (dolist (art articles)
+ (setq article-alist
+ (cl-pairlis
+ '(number subject from date id
+ refs chars lines xref extra)
+ (car art))
+ score (cdr art))
+ (when (integerp (setq fn-score (funcall score-fn
+ article-alist score)))
+ (setcdr art (+ score fn-score)))
+ (setq score (cdr art))
+ (when (and trace
+ (integerp fn-score))
+ (push (cons (car-safe (rassq alist gnus-score-cache))
+ (list score-fn fn-score))
+ gnus-score-trace))))))))
+
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
entries alist)
@@ -1690,9 +1744,21 @@ score in `gnus-newsgroup-scored' by SCORE."
((eq type 'after)
(setq match-func 'string<
match (gnus-date-iso8601 (nth 0 kill))))
+ ((eq type '<)
+ (setq type 'after
+ match-func 'string<
+ match (gnus-time-iso8601
+ (time-subtract (current-time)
+ (* 86400 (nth 0 kill))))))
((eq type 'before)
(setq match-func 'gnus-string>
match (gnus-date-iso8601 (nth 0 kill))))
+ ((eq type '>)
+ (setq type 'before
+ match-func 'gnus-string>
+ match (gnus-time-iso8601
+ (time-subtract (current-time)
+ (* 86400 (nth 0 kill))))))
((eq type 'at)
(setq match-func 'string=
match (gnus-date-iso8601 (nth 0 kill))))
@@ -1759,45 +1825,44 @@ score in `gnus-newsgroup-scored' by SCORE."
handles))))
(defun gnus-score-body (scores header now expire &optional trace)
- (if gnus-agent-fetching
- nil
- (save-excursion
- (setq gnus-scores-articles
- (sort gnus-scores-articles
- (lambda (a1 a2)
- (< (mail-header-number (car a1))
- (mail-header-number (car a2))))))
- (set-buffer nntp-server-buffer)
- (save-restriction
- (let* ((buffer-read-only nil)
- (articles gnus-scores-articles)
- (all-scores scores)
- (request-func (cond ((string= "head" header)
- 'gnus-request-head)
- ((string= "body" header)
- 'gnus-request-body)
- (t 'gnus-request-article)))
- entries alist ofunc article last)
- (when articles
- (setq last (mail-header-number (caar (last articles))))
- ;; Not all backends support partial fetching. In that case,
- ;; we just fetch the entire article.
- ;; When scoring by body, we need to peek at the headers to detect
- ;; the content encoding
- (unless (or (gnus-check-backend-function
- (and (string-match "^gnus-" (symbol-name request-func))
- (intern (substring (symbol-name request-func)
- (match-end 0))))
- gnus-newsgroup-name)
- (string= "body" header))
- (setq ofunc request-func)
- (setq request-func 'gnus-request-article))
- (while articles
- (setq article (mail-header-number (caar articles)))
- (gnus-message 7 "Scoring article %s of %s..." article last)
- (widen)
- (let (handles)
- (when (funcall request-func article gnus-newsgroup-name)
+ (if gnus-agent-fetching
+ nil
+ (setq gnus-scores-articles
+ (sort gnus-scores-articles
+ (lambda (a1 a2)
+ (< (mail-header-number (car a1))
+ (mail-header-number (car a2))))))
+ (with-current-buffer nntp-server-buffer
+ (save-restriction
+ (let* ((buffer-read-only nil)
+ (articles gnus-scores-articles)
+ (all-scores scores)
+ (request-func (cond ((string= "head" header)
+ 'gnus-request-head)
+ ((string= "body" header)
+ 'gnus-request-body)
+ (t 'gnus-request-article)))
+ entries alist ofunc article last)
+ (when articles
+ (setq last (mail-header-number (caar (last articles))))
+ ;; Not all backends support partial fetching. In that case,
+ ;; we just fetch the entire article.
+ ;; When scoring by body, we need to peek at the headers to detect
+ ;; the content encoding
+ (unless (or (gnus-check-backend-function
+ (and (string-match "^gnus-" (symbol-name request-func))
+ (intern (substring (symbol-name request-func)
+ (match-end 0))))
+ gnus-newsgroup-name)
+ (string= "body" header))
+ (setq ofunc request-func)
+ (setq request-func 'gnus-request-article))
+ (while articles
+ (setq article (mail-header-number (caar articles)))
+ (gnus-message 7 "Scoring article %s of %s..." article last)
+ (widen)
+ (let (handles)
+ (when (funcall request-func article gnus-newsgroup-name)
(when (string= "body" header)
(setq handles (gnus-score-decode-text-parts)))
(goto-char (point-min))
@@ -1862,8 +1927,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq rest entries))))
(setq entries rest))))
(when handles (mm-destroy-parts handles))))
- (setq articles (cdr articles)))))))
- nil))
+ (setq articles (cdr articles)))))))
+ nil))
(defun gnus-score-thread (scores header now expire &optional trace)
(gnus-score-followup scores header now expire trace t))
@@ -1889,7 +1954,7 @@ score in `gnus-newsgroup-scored' by SCORE."
gnus-newsgroup-name gnus-adaptive-file-suffix))))
(setq gnus-scores-articles (sort gnus-scores-articles
- 'gnus-score-string<)
+ #'gnus-score-string<)
articles gnus-scores-articles)
(erase-buffer)
@@ -2018,7 +2083,7 @@ score in `gnus-newsgroup-scored' by SCORE."
;; We cannot string-sort the extra headers list. *sigh*
(if (= gnus-score-index 9)
gnus-scores-articles
- (sort gnus-scores-articles 'gnus-score-string<))
+ (sort gnus-scores-articles #'gnus-score-string<))
articles gnus-scores-articles)
(erase-buffer)
@@ -2438,7 +2503,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(defun gnus-score-find-trace ()
"Find all score rules that applies to the current article."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((old-scored gnus-newsgroup-scored))
(let ((gnus-newsgroup-headers
(list (gnus-summary-article-header)))
@@ -2491,11 +2556,11 @@ score in `gnus-newsgroup-scored' by SCORE."
(abbreviate-file-name file))))
(insert
(format "\nTotal score: %d"
- (apply '+ (mapcar
- (lambda (s)
- (or (caddr s)
- gnus-score-interactive-default-score))
- trace))))
+ (apply #'+ (mapcar
+ (lambda (s)
+ (or (caddr s)
+ gnus-score-interactive-default-score))
+ trace))))
(insert
"\n\nQuick help:
@@ -2553,7 +2618,7 @@ the score file and its full name, including the directory.")
(defun gnus-summary-rescore ()
"Redo the entire scoring process in the current summary."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-score-save)
(setq gnus-score-cache nil)
(setq gnus-newsgroup-scored nil)
@@ -2584,7 +2649,7 @@ the score file and its full name, including the directory.")
(defun gnus-summary-raise-same-subject-and-select (score)
"Raise articles which has the same subject with SCORE and select the next."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(let ((subject (gnus-summary-article-subject)))
(gnus-summary-raise-score score)
(while (gnus-summary-find-subject subject)
@@ -2593,7 +2658,7 @@ the score file and its full name, including the directory.")
(defun gnus-summary-raise-same-subject (score)
"Raise articles which has the same subject with SCORE."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(let ((subject (gnus-summary-article-subject)))
(gnus-summary-raise-score score)
(while (gnus-summary-find-subject subject)
@@ -2606,7 +2671,7 @@ the score file and its full name, including the directory.")
(defun gnus-summary-raise-thread (&optional score)
"Raise the score of the articles in the current thread with SCORE."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(setq score (gnus-score-delta-default score))
(let (e)
(save-excursion
@@ -2625,22 +2690,22 @@ the score file and its full name, including the directory.")
(defun gnus-summary-lower-same-subject-and-select (score)
"Raise articles which has the same subject with SCORE and select the next."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(gnus-summary-raise-same-subject-and-select (- score)))
(defun gnus-summary-lower-same-subject (score)
"Raise articles which has the same subject with SCORE."
- (interactive "p")
+ (interactive "p" gnus-article-mode gnus-summary-mode)
(gnus-summary-raise-same-subject (- score)))
(defun gnus-summary-lower-thread (&optional score)
"Lower score of articles in the current thread with SCORE."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(gnus-summary-raise-thread (- (gnus-score-delta-default score))))
;;; Finding score files.
-(defun gnus-score-score-files (group)
+(defun gnus-score-score-files (_group)
"Return a list of all possible score files."
;; Search and set any global score files.
(when gnus-global-score-files
@@ -2813,7 +2878,7 @@ This includes the score file for the group and all its parents."
(mapcar (lambda (group)
(gnus-score-file-name group gnus-adaptive-file-suffix))
(setq all (nreverse all)))
- (mapcar 'gnus-score-file-name all)))
+ (mapcar #'gnus-score-file-name all)))
(if (equal prefix "")
all
(mapcar
@@ -2853,7 +2918,7 @@ Destroys the current buffer."
(lambda (file)
(cons (inline (gnus-score-file-rank file)) file))
files)))
- (mapcar 'cdr (sort alist 'car-less-than-car)))))
+ (mapcar #'cdr (sort alist #'car-less-than-car)))))
(defun gnus-score-find-alist (group)
"Return list of score files for GROUP.
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
new file mode 100644
index 00000000000..39bde837b30
--- /dev/null
+++ b/lisp/gnus/gnus-search.el
@@ -0,0 +1,2165 @@
+;;; gnus-search.el --- Search facilities for Gnus -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines a generalized search language, and search engines
+;; that interface with various search programs. It is responsible for
+;; parsing the user's search input, sending that query to the search
+;; engines, and collecting results. Results are in the form of a
+;; vector of vectors, each vector representing a found article. The
+;; nnselect backend interprets that value to create a group containing
+;; the search results.
+
+;; This file was formerly known as nnir. Later, the backend parts of
+;; nnir became nnselect, and only the search functionality was left
+;; here.
+
+;; See the Gnus manual for details of the search language. Tests are
+;; in tests/gnus-search-test.el.
+
+;; The search parsing routines are responsible for accepting the
+;; user's search query as a string and parsing it into a sexp
+;; structure. The function `gnus-search-parse-query' is the entry
+;; point for that. Once the query is in sexp form, it is passed to
+;; the search engines themselves, which are responsible for
+;; transforming the query into a form that the external program can
+;; understand, and then filtering the search results into a format
+;; that nnselect can understand.
+
+;; The general flow is:
+
+;; 1. The user calls one of `gnus-group-make-search-group' or
+;; `gnus-group-make-permanent-search-group' (or a few other entry
+;; points). These functions prompt for a search query, and collect
+;; the groups to search, then create an nnselect group, setting an
+;; 'nnselect-specs group parameter where 'nnselect-function is
+;; `gnus-search-run-query', and 'nnselect-args is the search query and
+;; groups to search.
+
+;; 2. `gnus-search-run-query' is called with 'nnselect-args. It looks
+;; at the groups to search, categorizes them by server, and for each
+;; server finds the search engine to use. It calls each engine's
+;; `gnus-search-run-search' method with the query and groups passed as
+;; arguments, and the results are collected and handed off to the
+;; nnselect group.
+
+;; For information on writing new search engines, see the Gnus manual.
+
+;; TODO: Rewrite the query parser using syntax tables and
+;; `parse-partial-sexp'.
+
+;; TODO: Refactor IMAP search so we can move code that uses nnimap-*
+;; functions out into nnimap.el.
+
+;; TODO: Is there anything we can do about sorting results?
+
+;; TODO: Provide for returning a result count. This would probably
+;; need a completely separate top-level command, since we wouldn't be
+;; creating a group at all.
+
+;;; Code:
+
+(require 'gnus-group)
+(require 'gnus-sum)
+(require 'message)
+(require 'gnus-util)
+(require 'eieio)
+(eval-when-compile (require 'cl-lib))
+(autoload 'eieio-build-class-alist "eieio-opt")
+(autoload 'nnmaildir-base-name-to-article-number "nnmaildir")
+
+(defvar gnus-inhibit-demon)
+(defvar gnus-english-month-names)
+
+;;; Internal Variables:
+
+;; When Gnus servers are implemented as objects or structs, give them
+;; a `search-engine' slot and get rid of this variable.
+(defvar gnus-search-engine-instance-alist nil
+ "Mapping between servers and instantiated search engines.")
+
+(defvar gnus-search-history ()
+ "Internal history of Gnus searches.")
+
+(defun gnus-search-shutdown ()
+ (setq gnus-search-engine-instance-alist nil))
+
+(gnus-add-shutdown #'gnus-search-shutdown 'gnus)
+
+(define-error 'gnus-search-parse-error "Gnus search parsing error")
+
+(define-error 'gnus-search-config-error "Gnus search configuration error")
+
+;;; User Customizable Variables:
+
+(defgroup gnus-search nil
+ "Search groups in Gnus with assorted search engines."
+ :group 'gnus)
+
+(defcustom gnus-search-use-parsed-queries nil
+ "When t, use Gnus' generalized search language.
+The generalized search language is a search language that can be
+used across all search engines that Gnus supports. See the Gnus
+manual for details.
+
+If this option is set to nil, search queries will be passed
+directly to the search engines without being parsed or
+transformed."
+ :version "28.1"
+ :type 'boolean)
+
+(define-obsolete-variable-alias 'nnir-ignored-newsgroups
+ 'gnus-search-ignored-newsgroups "28.1")
+
+(defcustom gnus-search-ignored-newsgroups ""
+ "A regexp to match newsgroups in the active file that should
+ be skipped when searching."
+ :version "24.1"
+ :type 'regexp)
+
+(make-obsolete-variable
+ 'nnir-imap-default-search-key
+ "specify imap search keys, or use parsed queries." "28.1")
+
+;; Engine-specific configuration options.
+
+(defcustom gnus-search-swish++-config-file
+ (expand-file-name "~/Mail/swish++.conf")
+ "Location of Swish++ configuration file.
+This variable can also be set per-server."
+ :type 'file)
+
+(defcustom gnus-search-swish++-program "search"
+ "Name of swish++ search executable.
+This variable can also be set per-server."
+ :type 'string)
+
+(defcustom gnus-search-swish++-switches '()
+ "A list of strings, to be given as additional arguments to swish++.
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-swish++-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq gnus-search-swish++-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+ :type '(repeat string))
+
+(defcustom gnus-search-swish++-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "The prefix to remove from each file name returned by swish++
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable can also be set per-server."
+ :type 'regexp)
+
+(defcustom gnus-search-swish++-raw-queries-p nil
+ "If t, all Swish++ engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-config-file
+ (expand-file-name "~/Mail/swish-e.conf")
+ "Configuration file for swish-e.
+This variable can also be set per-server."
+ :type 'file
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-program "search"
+ "Name of swish-e search executable.
+This variable can also be set per-server."
+ :type 'string
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-switches '()
+ "A list of strings, to be given as additional arguments to swish-e.
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-swish-e-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq gnus-search-swish-e-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+ :type '(repeat string)
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "The prefix to remove from each file name returned by swish-e
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable can also be set per-server."
+ :type 'regexp
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-index-files '()
+ "A list of index files to use with this Swish-e instance.
+This variable can also be set per-server."
+ :type '(repeat file)
+ :version "28.1")
+
+(defcustom gnus-search-swish-e-raw-queries-p nil
+ "If t, all Swish-e engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "28.1")
+
+;; Namazu engine, see <URL:http://www.namazu.org/>
+
+(defcustom gnus-search-namazu-program "namazu"
+ "Name of Namazu search executable.
+This variable can also be set per-server."
+ :type 'string
+ :version "28.1")
+
+(defcustom gnus-search-namazu-index-directory (expand-file-name "~/Mail/namazu/")
+ "Index directory for Namazu.
+This variable can also be set per-server."
+ :type 'directory
+ :version "28.1")
+
+(defcustom gnus-search-namazu-switches '()
+ "A list of strings, to be given as additional arguments to namazu.
+The switches `-q', `-a', and `-s' are always used, very few other switches
+make any sense in this context.
+
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-namazu-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq gnus-search-namazu-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+ :type '(repeat string)
+ :version "28.1")
+
+(defcustom gnus-search-namazu-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "The prefix to remove from each file name returned by Namazu
+in order to get a group name (albeit with / instead of .).
+
+For example, suppose that Namazu returns file names such as
+\"/home/john/Mail/mail/misc/42\". For this example, use the following
+setting: (setq gnus-search-namazu-remove-prefix \"/home/john/Mail/\")
+Note the trailing slash. Removing this prefix gives \"mail/misc/42\".
+Gnus knows to remove the \"/42\" and to replace \"/\" with \".\" to
+arrive at the correct group name, \"mail.misc\".
+
+This variable can also be set per-server."
+ :type 'directory
+ :version "28.1")
+
+(defcustom gnus-search-namazu-raw-queries-p nil
+ "If t, all Namazu engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom gnus-search-notmuch-program "notmuch"
+ "Name of notmuch search executable.
+This variable can also be set per-server."
+ :type '(string)
+ :version "28.1")
+
+(defcustom gnus-search-notmuch-config-file
+ (expand-file-name "~/.notmuch-config")
+ "Configuration file for notmuch.
+This variable can also be set per-server."
+ :type 'file
+ :version "28.1")
+
+(defcustom gnus-search-notmuch-switches '()
+ "A list of strings, to be given as additional arguments to notmuch.
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-notmuch-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq gnus-search-notmuch-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+ :type '(repeat string)
+ :version "28.1")
+
+(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "The prefix to remove from each file name returned by notmuch
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable can also be set per-server."
+ :type 'regexp
+ :version "28.1")
+
+(defcustom gnus-search-notmuch-raw-queries-p nil
+ "If t, all Notmuch engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom gnus-search-imap-raw-queries-p nil
+ "If t, all IMAP engines will only accept raw search query
+ strings."
+ :version "28.1"
+ :type 'boolean)
+
+(defcustom gnus-search-mairix-program "mairix"
+ "Name of mairix search executable.
+This variable can also be set per-server."
+ :version "28.1"
+ :type 'string)
+
+(defcustom gnus-search-mairix-config-file
+ (expand-file-name "~/.mairixrc")
+ "Configuration file for mairix.
+This variable can also be set per-server."
+ :version "28.1"
+ :type 'file)
+
+(defcustom gnus-search-mairix-switches '()
+ "A list of strings, to be given as additional arguments to mairix.
+Note that this should be a list. I.e., do NOT use the following:
+ (setq gnus-search-mairix-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq gnu-search-mairix-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+ :version "28.1"
+ :type '(repeat string))
+
+(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "The prefix to remove from each file name returned by mairix
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable can also be set per-server."
+ :version "28.1"
+ :type 'regexp)
+
+(defcustom gnus-search-mairix-raw-queries-p nil
+ "If t, all Mairix engines will only accept raw search query
+ strings."
+ :version "28.1"
+ :type 'boolean)
+
+;; Options for search language parsing.
+
+(defcustom gnus-search-expandable-keys
+ '("from" "subject" "to" "cc" "bcc" "body" "recipient" "date"
+ "mark" "before" "after" "larger" "smaller" "attachment" "text"
+ "since" "thread" "sender" "address" "tag" "size" "grep" "limit"
+ "raw" "message-id" "id")
+ "A list of strings representing expandable search keys.
+\"Expandable\" simply means the key can be abbreviated while
+typing in search queries, ie \"subject\" could be entered as
+\"subj\" or even \"su\", though \"s\" is ambiguous between
+\"subject\" and \"since\".
+
+Ambiguous abbreviations will raise an error."
+ :version "28.1"
+ :type '(repeat string))
+
+(defcustom gnus-search-date-keys
+ '("date" "before" "after" "on" "senton" "sentbefore" "sentsince" "since")
+ "A list of keywords whose value should be parsed as a date.
+See the docstring of `gnus-search-parse-query' for information on
+date parsing."
+ :version "26.1"
+ :type '(repeat string))
+
+(defcustom gnus-search-contact-tables '()
+ "A list of completion tables used to search for messages from contacts.
+Each list element should be a table or collection suitable to be
+returned by `completion-at-point-functions'. That usually means
+a list of strings, a hash table, or an alist."
+ :version "28.1"
+ :type '(repeat sexp))
+
+;;; Search language
+
+;; This "language" was generalized from the original IMAP search query
+;; parsing routine.
+
+(defun gnus-search-parse-query (string)
+ "Turn STRING into an s-expression based query.
+The resulting query structure is passed to the various search
+backends, each of which adapts it as needed.
+
+The search \"language\" is essentially a series of key:value
+expressions. Key is most often a mail header, but there are
+other keys. Value is a string, quoted if it contains spaces.
+Key and value are separated by a colon, no space. Expressions
+are implicitly ANDed; the \"or\" keyword can be used to
+OR. \"not\" will negate the following expression, or keys can be
+prefixed with a \"-\". The \"near\" operator will work for
+engines that understand it; other engines will convert it to
+\"or\". Parenthetical groups work as expected.
+
+A key that matches the name of a mail header will search that
+header.
+
+Search keys can be expanded with TAB during entry, or left
+abbreviated so long as they remain unambiguous, ie \"f\" will
+search the \"from\" header. \"s\" will raise an error.
+
+Other keys:
+
+\"address\" will search all sender and recipient headers.
+
+\"recipient\" will search \"To\", \"Cc\", and \"Bcc\".
+
+\"before\" will search messages sent before the specified
+date (date specifications to come later). Date is exclusive.
+
+\"after\" (or its synonym \"since\") will search messages sent
+after the specified date. Date is inclusive.
+
+\"mark\" will search messages that have some sort of mark.
+Likely values include \"flag\", \"seen\", \"read\", \"replied\".
+It's also possible to use Gnus' internal marks, ie \"mark:R\"
+will be interpreted as mark:read.
+
+\"tag\" will search tags -- right now that's translated to
+\"keyword\" in IMAP, and left as \"tag\" for notmuch. At some
+point this should also be used to search marks in the Gnus
+registry.
+
+Other keys can be specified, provided that the search backends
+know how to interpret them.
+
+External contact-management packages can push completion tables
+onto the list variable `gnus-search-contact-tables', to provide
+auto-completion of contact names and addresses for keys like
+\"from\" and \"to\".
+
+Date values (any key in `gnus-search-date-keys') can be provided
+in any format that `parse-time-string' can parse (note that this
+can produce weird results). Dates with missing bits will be
+interpreted as the most recent occurrence thereof (i.e. \"march
+03\" is the most recent March 3rd). Lastly, relative
+specifications such as 1d (one day ago) are understood. This
+also accepts w, m, and y. m is assumed to be 30 days.
+
+This function will accept pretty much anything as input. Its
+only job is to parse the query into a sexp, and pass that on --
+it is the job of the search backends to make sense of the
+structured query. Malformed, unusable or invalid queries will
+typically be silently ignored."
+ (with-temp-buffer
+ ;; Set up the parsing environment.
+ (insert string)
+ (goto-char (point-min))
+ ;; Now, collect the output terms and return them.
+ (let (out)
+ (while (not (gnus-search-query-end-of-input))
+ (push (gnus-search-query-next-expr) out))
+ (reverse out))))
+
+(defun gnus-search-query-next-expr (&optional count halt)
+ "Return the next expression from the current buffer."
+ (let ((term (gnus-search-query-next-term count))
+ (next (gnus-search-query-peek-symbol)))
+ ;; Deal with top-level expressions. And, or, not, near... What
+ ;; else? Notmuch also provides xor and adj. It also provides a
+ ;; "nearness" parameter for near and adj.
+ (cond
+ ;; Handle 'expr or expr'
+ ((and (eq next 'or)
+ (null halt))
+ (list 'or term (gnus-search-query-next-expr 2)))
+ ;; Handle 'near operator.
+ ((eq next 'near)
+ (let ((near-next (gnus-search-query-next-expr 2)))
+ (if (and (stringp term)
+ (stringp near-next))
+ (list 'near term near-next)
+ (signal 'gnus-search-parse-error
+ (list "\"Near\" keyword must appear between two plain strings.")))))
+ ;; Anything else
+ (t term))))
+
+(defun gnus-search-query-next-term (&optional count)
+ "Return the next TERM from the current buffer."
+ (let ((term (gnus-search-query-next-symbol count)))
+ ;; What sort of term is this?
+ (cond
+ ;; negated term
+ ((eq term 'not) (list 'not (gnus-search-query-next-expr nil 'halt)))
+ ;; generic term
+ (t term))))
+
+(defun gnus-search-query-peek-symbol ()
+ "Return the next symbol from the current buffer, but don't consume it."
+ (save-excursion
+ (gnus-search-query-next-symbol)))
+
+(defun gnus-search-query-next-symbol (&optional count)
+ "Return the next symbol from the current buffer, or nil if we are
+at the end of the buffer. If supplied COUNT skips some symbols before
+returning the one at the supplied position."
+ (when (and (numberp count) (> count 1))
+ (gnus-search-query-next-symbol (1- count)))
+ (let ((case-fold-search t))
+ ;; end of input stream?
+ (unless (gnus-search-query-end-of-input)
+ ;; No, return the next symbol from the stream.
+ (cond
+ ;; Negated expression -- return it and advance one char.
+ ((looking-at "-") (forward-char 1) 'not)
+ ;; List expression -- we parse the content and return this as a list.
+ ((looking-at "(")
+ (gnus-search-parse-query (gnus-search-query-return-string ")" t)))
+ ;; Keyword input -- return a symbol version.
+ ((looking-at "\\band\\b") (forward-char 3) 'and)
+ ((looking-at "\\bor\\b") (forward-char 2) 'or)
+ ((looking-at "\\bnot\\b") (forward-char 3) 'not)
+ ((looking-at "\\bnear\\b") (forward-char 4) 'near)
+ ;; Plain string, no keyword
+ ((looking-at "[\"/]?\\b[^:]+\\([[:blank:]]\\|\\'\\)")
+ (gnus-search-query-return-string
+ (when (looking-at-p "[\"/]") t)))
+ ;; Assume a K:V expression.
+ (t (let ((key (gnus-search-query-expand-key
+ (buffer-substring
+ (point)
+ (progn
+ (re-search-forward ":" (point-at-eol) t)
+ (1- (point))))))
+ (value (gnus-search-query-return-string
+ (when (looking-at-p "[\"/]") t))))
+ (gnus-search-query-parse-kv key value)))))))
+
+(defun gnus-search-query-parse-kv (key value)
+ "Handle KEY and VALUE, parsing and expanding as necessary.
+This may result in (key value) being turned into a larger query
+structure.
+
+In the simplest case, they are simply consed together. String
+KEY is converted to a symbol."
+ (let () ;; return
+ (cond
+ ((member key gnus-search-date-keys)
+ (when (string= "after" key)
+ (setq key "since"))
+ (setq value (gnus-search-query-parse-date value)))
+ ((equal key "mark")
+ (setq value (gnus-search-query-parse-mark value)))
+ ((string= "message-id" key)
+ (setq key "id")))
+ (or nil ;; return
+ (cons (intern key) value))))
+
+(defun gnus-search-query-parse-date (value &optional rel-date)
+ "Interpret VALUE as a date specification.
+See the docstring of `gnus-search-parse-query' for details.
+
+The result is a list of (dd mm yyyy); individual elements can be
+nil.
+
+If VALUE is a relative time, interpret it as relative to
+REL-DATE, or (current-time) if REL-DATE is nil."
+ ;; Time parsing doesn't seem to work with slashes.
+ (let ((value (replace-regexp-in-string "/" "-" value))
+ (now (append '(0 0 0)
+ (seq-subseq (decode-time (or rel-date
+ (current-time)))
+ 3))))
+ ;; Check for relative time parsing.
+ (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value)
+ (seq-subseq
+ (decode-time
+ (time-subtract
+ (apply #'encode-time now)
+ (days-to-time
+ (* (string-to-number (match-string 1 value))
+ (cdr (assoc (match-string 2 value)
+ '(("d" . 1)
+ ("w" . 7)
+ ("m" . 30)
+ ("y" . 365))))))))
+ 3 6)
+ ;; Otherwise check the value of `parse-time-string'.
+
+ ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
+ (let ((d-time (parse-time-string value)))
+ ;; Did parsing produce anything at all?
+ (if (seq-some #'integerp (seq-subseq d-time 3 7))
+ (seq-subseq
+ ;; If DOW is given, handle that specially.
+ (if (and (seq-elt d-time 6) (null (seq-elt d-time 3)))
+ (decode-time
+ (time-subtract (apply #'encode-time now)
+ (days-to-time
+ (+ (if (> (seq-elt d-time 6)
+ (seq-elt now 6))
+ 7 0)
+ (- (seq-elt now 6) (seq-elt d-time 6))))))
+ d-time)
+ 3 6)
+ ;; `parse-time-string' failed to produce anything, just
+ ;; return the string.
+ value)))))
+
+(defun gnus-search-query-parse-mark (mark)
+ "Possibly transform MARK.
+If MARK is a single character, assume it is one of the
+gnus-*-mark marks, and return an appropriate string."
+ (if (= 1 (length mark))
+ (let ((m (aref mark 0)))
+ ;; Neither pcase nor cl-case will work here.
+ (cond
+ ((eql m gnus-ticked-mark) "flag")
+ ((eql m gnus-read-mark) "read")
+ ((eql m gnus-replied-mark) "replied")
+ ((eql m gnus-recent-mark) "recent")
+ (t mark)))
+ mark))
+
+(defun gnus-search-query-expand-key (key)
+ "Attempt to expand KEY to a full keyword.
+Use `gnus-search-expandable-keys' as a completion table; return
+KEY directly if it can't be completed. Raise an error if KEY is
+ambiguous, meaning that it is a prefix of multiple known
+keywords. This means that it's not possible to enter a custom
+keyword that happens to be a prefix of a known keyword."
+ (let ((comp (try-completion key gnus-search-expandable-keys)))
+ (if (or (eql comp 't) ; Already a key.
+ (null comp)) ; An unknown key.
+ key
+ (if (null (member comp gnus-search-expandable-keys))
+ ;; KEY is a prefix of multiple known keywords, and could not
+ ;; be completed to something unique.
+ (signal 'gnus-search-parse-error
+ (list (format "Ambiguous keyword: %s" key)))
+ ;; We completed to a unique known key.
+ comp))))
+
+(defun gnus-search-query-return-string (&optional delimited trim)
+ "Return a string from the current buffer.
+If DELIMITED is non-nil, assume the next character is a delimiter
+character, and return everything between point and the next
+occurrence of the delimiter, including the delimiters themselves.
+If TRIM is non-nil, do not return the delimiters. Otherwise,
+return one word."
+ ;; This function cannot handle nested delimiters, as it's not a
+ ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or
+ ;; (cc:bob or bcc:bob))".
+ (let ((start (point))
+ (delimiter (if (stringp delimited)
+ delimited
+ (when delimited
+ (char-to-string (char-after)))))
+ end)
+ (if delimiter
+ (progn
+ (when trim
+ ;; Skip past first delimiter if we're trimming.
+ (forward-char 1))
+ (while (not end)
+ (unless (search-forward delimiter nil t (unless trim 2))
+ (signal 'gnus-search-parse-error
+ (list (format "Unmatched delimited input with %s in query" delimiter))))
+ (let ((here (point)))
+ (unless (equal (buffer-substring (- here 2) (- here 1)) "\\")
+ (setq end (if trim (1- (point)) (point))
+ start (if trim (1+ start) start))))))
+ (setq end (progn (re-search-forward "\\([[:blank:]]+\\|$\\)" (point-max) t)
+ (match-beginning 0))))
+ (buffer-substring-no-properties start end)))
+
+(defun gnus-search-query-end-of-input ()
+ "Are we at the end of input?"
+ (skip-chars-forward "[:blank:]")
+ (looking-at "$"))
+
+;;; Search engines
+
+;; Search engines are implemented as classes. This is good for two
+;; things: encapsulating things like indexes and search prefixes, and
+;; transforming search queries.
+
+(defclass gnus-search-engine ()
+ ((raw-queries-p
+ :initarg :raw-queries-p
+ :initform nil
+ :type boolean
+ :custom boolean
+ :documentation
+ "When t, searches through this engine will never be parsed or
+ transformed, and must be entered \"raw\"."))
+ :abstract t
+ :documentation "Abstract base class for Gnus search engines.")
+
+(defclass gnus-search-grep ()
+ ((grep-program
+ :initarg :grep-program
+ :initform "grep"
+ :type string
+ :documentation "Grep executable to use for second-pass grep
+ searches.")
+ (grep-options
+ :initarg :grep-options
+ :initform nil
+ :type list
+ :documentation "Additional options, in the form of a list,
+ passed to the second-pass grep search, when present."))
+ :abstract t
+ :documentation "An abstract mixin class that can be added to
+ local-filesystem search engines, providing an additional grep:
+ search key. After the base engine returns a list of search
+ results (as local filenames), an external grep process is used
+ to further filter the results.")
+
+(cl-defgeneric gnus-search-grep-search (engine artlist criteria)
+ "Run a secondary grep search over a list of preliminary results.
+
+ARTLIST is a list of (filename score) pairs, produced by one of
+the other search engines. CRITERIA is a grep-specific search
+key. This method uses an external grep program to further filter
+the files in ARTLIST by that search key.")
+
+(cl-defmethod gnus-search-grep-search ((engine gnus-search-grep)
+ artlist criteria)
+ (with-slots (grep-program grep-options) engine
+ (if (executable-find grep-program)
+ ;; Don't catch errors -- allow them to propagate.
+ (let ((matched-files
+ (apply
+ #'process-lines
+ grep-program
+ `("-l" ,@grep-options
+ "-e" ,(shell-quote-argument criteria)
+ ,@(mapcar #'car artlist)))))
+ (seq-filter (lambda (a) (member (car a) matched-files))
+ artlist))
+ (nnheader-report 'search "invalid grep program: %s" grep-program))))
+
+(defclass gnus-search-process ()
+ ((proc-buffer
+ :initarg :proc-buffer
+ :type buffer
+ :documentation "A temporary buffer this engine uses for its
+ search process, and for munging its search results."))
+ :abstract t
+ :documentation
+ "A mixin class for engines that do their searching in a single
+ process launched for this purpose, which returns at the end of
+ the search. Subclass instances are safe to be run in
+ threads.")
+
+(cl-defmethod shared-initialize ((engine gnus-search-process)
+ slots)
+ (setq slots (plist-put slots :proc-buffer
+ (generate-new-buffer " *gnus-search-")))
+ (cl-call-next-method engine slots))
+
+(defclass gnus-search-imap (gnus-search-engine)
+ ((literal-plus
+ :initarg :literal-plus
+ :initform nil
+ :type boolean
+ :documentation
+ "Can this search engine handle literal+ searches? This slot
+ is set automatically by the imap server, and cannot be
+ set manually. Only the LITERAL+ capability is handled.")
+ (multisearch
+ :initarg :multisearch
+ :initform nil
+ :type boolean
+ :documentation
+ "Can this search engine handle the MULTISEARCH capability?
+ This slot is set automatically by the imap server, and cannot
+ be set manually. Currently unimplemented.")
+ (fuzzy
+ :initarg :fuzzy
+ :initform nil
+ :type boolean
+ :documentation
+ "Can this search engine handle the FUZZY search capability?
+ This slot is set automatically by the imap server, and cannot
+ be set manually. Currently only partially implemented.")
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-imap-raw-queries-p)))
+ :documentation
+ "The base IMAP search engine, using an IMAP server's search capabilities.
+This backend may be subclassed to handle particular IMAP servers'
+quirks.")
+
+(defclass gnus-search-find-grep (gnus-search-engine
+ gnus-search-process
+ gnus-search-grep)
+ nil)
+
+;;; The "indexed" search engine.
+
+;; These are engines that use an external program, with indexes kept
+;; on disk, to search messages usually kept in some local directory.
+;; They have several slots in common, for instance program name or
+;; configuration file. Many of the subclasses also allow
+;; distinguishing multiple databases or indexes. These slots can be
+;; set using a global default, or on a per-server basis.
+
+(defclass gnus-search-indexed (gnus-search-engine
+ gnus-search-process
+ gnus-search-grep)
+ ((program
+ :initarg :program
+ :type string
+ :documentation
+ "The executable used for indexing and searching.")
+ (config-file
+ :init-arg :config-file
+ :type string
+ :custom file
+ :documentation "Location of the config file, if any.")
+ (remove-prefix
+ :initarg :remove-prefix
+ :initform (concat (getenv "HOME") "/Mail/")
+ :type string
+ :documentation
+ "The path to the directory where the indexed mails are
+ kept. This path is removed from the search results.")
+ (switches
+ :initarg :switches
+ :type list
+ :documentation
+ "Additional switches passed to the search engine command-line
+ program."))
+ :abstract t
+ :allow-nil-initform t
+ :documentation "A base search engine class that assumes a local search index
+ accessed by a command line program.")
+
+(defclass gnus-search-swish-e (gnus-search-indexed)
+ ((index-files
+ :init-arg :index-files
+ :initform (symbol-value 'gnus-search-swish-e-index-files)
+ :type list)
+ (program
+ :initform (symbol-value 'gnus-search-swish-e-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-swish-e-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-swish-e-switches))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-swish-e-raw-queries-p))))
+
+(defclass gnus-search-swish++ (gnus-search-indexed)
+ ((program
+ :initform (symbol-value 'gnus-search-swish++-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-swish++-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-swish++-switches))
+ (config-file
+ :initform (symbol-value 'gnus-search-swish++-config-file))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-swish++-raw-queries-p))))
+
+(defclass gnus-search-mairix (gnus-search-indexed)
+ ((program
+ :initform (symbol-value 'gnus-search-mairix-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-mairix-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-mairix-switches))
+ (config-file
+ :initform (symbol-value 'gnus-search-mairix-config-file))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-mairix-raw-queries-p))))
+
+(defclass gnus-search-namazu (gnus-search-indexed)
+ ((index-directory
+ :initarg :index-directory
+ :initform (symbol-value 'gnus-search-namazu-index-directory)
+ :type string
+ :custom directory)
+ (program
+ :initform (symbol-value 'gnus-search-namazu-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-namazu-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-namazu-switches))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-namazu-raw-queries-p))))
+
+(defclass gnus-search-notmuch (gnus-search-indexed)
+ ((program
+ :initform (symbol-value 'gnus-search-notmuch-program))
+ (remove-prefix
+ :initform (symbol-value 'gnus-search-notmuch-remove-prefix))
+ (switches
+ :initform (symbol-value 'gnus-search-notmuch-switches))
+ (config-file
+ :initform (symbol-value 'gnus-search-notmuch-config-file))
+ (raw-queries-p
+ :initform (symbol-value 'gnus-search-notmuch-raw-queries-p))))
+
+(define-obsolete-variable-alias 'nnir-method-default-engines
+ 'gnus-search-default-engines "28.1")
+
+(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap))
+ "Alist of default search engines keyed by server method."
+ :version "26.1"
+ :type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool)
+ (const nneething) (const nndir) (const nnmbox)
+ (const nnml) (const nnmh) (const nndraft)
+ (const nnfolder) (const nnmaildir))
+ (choice
+ ,@(mapcar
+ (lambda (el) (list 'const (intern (car el))))
+ (eieio-build-class-alist 'gnus-search-engine t))))))
+
+;;; Transforming and running search queries.
+
+(cl-defgeneric gnus-search-run-search (engine server query groups)
+ "Run QUERY in GROUPS against SERVER, using search ENGINE.
+Should return results as a vector of vectors.")
+
+(cl-defgeneric gnus-search-transform (engine expression)
+ "Transform sexp EXPRESSION into a string search query usable by ENGINE.
+Responsible for handling and, or, and parenthetical expressions.")
+
+(cl-defgeneric gnus-search-transform-expression (engine expression)
+ "Transform a basic EXPRESSION into a string usable by ENGINE.")
+
+(cl-defgeneric gnus-search-make-query-string (engine query-spec)
+ "Extract the actual query string to use from QUERY-SPEC.")
+
+;; Methods that are likely to be the same for all engines.
+
+(cl-defmethod gnus-search-make-query-string ((engine gnus-search-engine)
+ query-spec)
+ (let ((parsed-query (alist-get 'parsed-query query-spec))
+ (raw-query (alist-get 'query query-spec)))
+ (if (and gnus-search-use-parsed-queries
+ (null (alist-get 'raw query-spec))
+ (null (slot-value engine 'raw-queries-p))
+ parsed-query)
+ (gnus-search-transform engine parsed-query)
+ (if (listp raw-query)
+ ;; Some callers are sending this in as (query "query"), not
+ ;; as a cons cell?
+ (car raw-query)
+ raw-query))))
+
+(defsubst gnus-search-single-p (query)
+ "Return t if QUERY is a search for a single message."
+ (let ((q (alist-get 'parsed-query query)))
+ (and (= (length q ) 1)
+ (consp (car-safe q))
+ (eq (caar q) 'id))))
+
+(cl-defmethod gnus-search-transform ((engine gnus-search-engine)
+ (query list))
+ (let (clauses)
+ (mapc
+ (lambda (item)
+ (when-let ((expr (gnus-search-transform-expression engine item)))
+ (push expr clauses)))
+ query)
+ (mapconcat #'identity (reverse clauses) " ")))
+
+;; Most search engines just pass through plain strings.
+(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine)
+ (expr string))
+ expr)
+
+;; Most search engines use implicit ANDs.
+(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine)
+ (_expr (eql and)))
+ nil)
+
+;; Most search engines use explicit infixed ORs.
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine)
+ (expr (head or)))
+ (let ((left (gnus-search-transform-expression engine (nth 1 expr)))
+ (right (gnus-search-transform-expression engine (nth 2 expr))))
+ ;; Unhandled keywords return a nil; don't create an "or" expression
+ ;; unless both sub-expressions are non-nil.
+ (if (and left right)
+ (format "%s or %s" left right)
+ (or left right))))
+
+;; Most search engines just use the string "not"
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine)
+ (expr (head not)))
+ (let ((next (gnus-search-transform-expression engine (cadr expr))))
+ (when next
+ (format "not %s" next))))
+
+;;; Search Engine Interfaces:
+
+(autoload 'nnimap-change-group "nnimap")
+(declare-function nnimap-buffer "nnimap" ())
+(declare-function nnimap-command "nnimap" (&rest args))
+
+(defvar gnus-search-imap-search-keys
+ '(body cc bcc from header keyword larger smaller subject text to uid x-gm-raw
+ answered before deleted draft flagged on since recent seen sentbefore
+ senton sentsince unanswered undeleted undraft unflagged unkeyword
+ unseen all old new or not)
+ "Known IMAP search keys.")
+
+;; imap interface
+(cl-defmethod gnus-search-run-search ((engine gnus-search-imap)
+ srv query groups)
+ (save-excursion
+ (let ((server (cadr (gnus-server-to-method srv)))
+ (gnus-inhibit-demon t)
+ ;; We're using the message id to look for a single message.
+ (single-search (gnus-search-single-p query))
+ (grouplist (or groups (gnus-search-get-active srv)))
+ q-string artlist group)
+ (message "Opening server %s" server)
+ (gnus-open-server srv)
+ ;; We should only be doing this once, in
+ ;; `nnimap-open-connection', but it's too frustrating to try to
+ ;; get to the server from the process buffer.
+ (with-current-buffer (nnimap-buffer)
+ (setf (slot-value engine 'literal-plus)
+ (when (nnimap-capability "LITERAL+") t))
+ ;; MULTISEARCH not yet implemented.
+ (setf (slot-value engine 'multisearch)
+ (when (nnimap-capability "MULTISEARCH") t))
+ ;; FUZZY only partially supported: the command is sent to the
+ ;; server (and presumably acted upon), but we don't yet
+ ;; request a RELEVANCY score as part of the response.
+ (setf (slot-value engine 'fuzzy)
+ (when (nnimap-capability "SEARCH=FUZZY") t)))
+
+ (setq q-string
+ (gnus-search-make-query-string engine query))
+
+ ;; A bit of backward-compatibility slash convenience: if the
+ ;; query string doesn't start with any known IMAP search
+ ;; keyword, assume it is a "TEXT" search.
+ (unless (or (eql ?\( (aref q-string 0))
+ (and (string-match "\\`[^[:blank:]]+" q-string)
+ (memql (intern-soft (downcase
+ (match-string 0 q-string)))
+ gnus-search-imap-search-keys)))
+ (setq q-string (concat "TEXT " q-string)))
+
+ ;; If it's a thread query, make sure that all message-id
+ ;; searches are also references searches.
+ (when (alist-get 'thread query)
+ (setq q-string
+ (replace-regexp-in-string
+ "HEADER Message-Id \\([^ )]+\\)"
+ "(OR HEADER Message-Id \\1 HEADER References \\1)"
+ q-string)))
+
+ (while (and (setq group (pop grouplist))
+ (or (null single-search) (null artlist)))
+ (when (nnimap-change-group
+ (gnus-group-short-name group) server)
+ (with-current-buffer (nnimap-buffer)
+ (message "Searching %s..." group)
+ (let ((result
+ (gnus-search-imap-search-command engine q-string)))
+ (when (car result)
+ (setq artlist
+ (vconcat
+ (mapcar
+ (lambda (artnum)
+ (let ((artn (string-to-number artnum)))
+ (when (> artn 0)
+ (vector group artn 100))))
+ (cdr (assoc "SEARCH" (cdr result))))
+ artlist))))
+ (message "Searching %s...done" group))))
+ (nreverse artlist))))
+
+(cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap)
+ (query string))
+ "Create the IMAP search command for QUERY.
+Currently takes into account support for the LITERAL+ capability.
+Other capabilities could be tested here."
+ (with-slots (literal-plus) engine
+ (when literal-plus
+ (setq query (split-string query "\n")))
+ (cond
+ ((consp query)
+ ;; We're not really streaming, just need to prevent
+ ;; `nnimap-send-command' from waiting for a response.
+ (let* ((nnimap-streaming t)
+ (call
+ (nnimap-send-command
+ "UID SEARCH CHARSET UTF-8 %s"
+ (pop query))))
+ (dolist (l query)
+ (process-send-string (get-buffer-process (current-buffer)) l)
+ (process-send-string (get-buffer-process (current-buffer))
+ (if (nnimap-newlinep nnimap-object)
+ "\n"
+ "\r\n")))
+ (nnimap-get-response call)))
+ (t (nnimap-command "UID SEARCH %s" query)))))
+
+(cl-defmethod gnus-search-transform ((_ gnus-search-imap)
+ (_query null))
+ "ALL")
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap)
+ (expr string))
+ (unless (string-match-p "\\`/.+/\\'" expr)
+ ;; Also need to check for fuzzy here. Or better, do some
+ ;; refactoring of this stuff.
+ (format "TEXT %s"
+ (gnus-search-imap-handle-string engine expr))))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap)
+ (expr (head or)))
+ (let ((left (gnus-search-transform-expression engine (nth 1 expr)))
+ (right (gnus-search-transform-expression engine (nth 2 expr))))
+ (if (and left right)
+ (format "(OR %s %s)"
+ left (format (if (eq 'or (car-safe (nth 2 expr)))
+ "(%s)" "%s")
+ right))
+ (or left right))))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap)
+ (expr (head near)))
+ "Imap searches interpret \"near\" as \"or\"."
+ (setcar expr 'or)
+ (gnus-search-transform-expression engine expr))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap)
+ (expr (head not)))
+ "Transform IMAP NOT.
+If the term to be negated is a flag, then use the appropriate UN*
+boolean instead."
+ (if (eql (caadr expr) 'mark)
+ (if (string= (cdadr expr) "new")
+ "OLD"
+ (format "UN%s" (gnus-search-imap-handle-flag (cdadr expr))))
+ (format "NOT %s"
+ (gnus-search-transform-expression engine (cadr expr)))))
+
+(cl-defmethod gnus-search-transform-expression ((_ gnus-search-imap)
+ (expr (head mark)))
+ (gnus-search-imap-handle-flag (cdr expr)))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap)
+ (expr list))
+ "Handle a search keyword for IMAP.
+All IMAP search keywords that take a value are supported
+directly. Keywords that are boolean are supported through other
+means (usually the \"mark\" keyword)."
+ (let ((fuzzy-supported (slot-value engine 'fuzzy))
+ (fuzzy ""))
+ (cl-case (car expr)
+ (date (setcar expr 'on))
+ (tag (setcar expr 'keyword))
+ (sender (setcar expr 'from))
+ (attachment (setcar expr 'body)))
+ ;; Allow sizes specified as KB or MB.
+ (let ((case-fold-search t)
+ unit)
+ (when (and (memq (car expr) '(larger smaller))
+ (string-match "\\(kb?\\|mb?\\)\\'" (cdr expr)))
+ (setq unit (match-string 1 (cdr expr)))
+ (setcdr expr
+ (number-to-string
+ (* (string-to-number
+ (string-replace unit "" (cdr expr)))
+ (if (string-prefix-p "k" unit)
+ 1024
+ 1048576))))))
+ (cond
+ ((consp (car expr))
+ (format "(%s)" (gnus-search-transform engine expr)))
+ ((eq (car expr) 'recipient)
+ (gnus-search-transform
+ engine (gnus-search-parse-query
+ (format
+ "to:%s or cc:%s or bcc:%s"
+ (cdr expr) (cdr expr) (cdr expr)))))
+ ((eq (car expr) 'address)
+ (gnus-search-transform
+ engine (gnus-search-parse-query
+ (format
+ "from:%s or to:%s or cc:%s or bcc:%s"
+ (cdr expr) (cdr expr) (cdr expr) (cdr expr)))))
+ ((memq (car expr) '(before since on sentbefore senton sentsince))
+ ;; Ignore dates given as strings.
+ (when (listp (cdr expr))
+ (format "%s %s"
+ (upcase (symbol-name (car expr)))
+ (gnus-search-imap-handle-date engine (cdr expr)))))
+ ((stringp (cdr expr))
+ ;; If the search term starts or ends with "*", remove the
+ ;; asterisk. If the engine supports FUZZY, then additionally make
+ ;; the search fuzzy.
+ (when (string-match "\\`\\*\\|\\*\\'" (cdr expr))
+ (setcdr expr (replace-regexp-in-string
+ "\\`\\*\\|\\*\\'" "" (cdr expr)))
+ (when fuzzy-supported
+ (setq fuzzy "FUZZY ")))
+ ;; If the search term is a regexp, drop the expression altogether.
+ (unless (string-match-p "\\`/.+/\\'" (cdr expr))
+ (cond
+ ((memq (car expr) gnus-search-imap-search-keys)
+ (format "%s%s %s"
+ fuzzy
+ (upcase (symbol-name (car expr)))
+ (gnus-search-imap-handle-string engine (cdr expr))))
+ ((eq (car expr) 'id)
+ (format "HEADER Message-ID \"%s\"" (cdr expr)))
+ ;; Treat what can't be handled as a HEADER search. Probably a bad
+ ;; idea.
+ (t (format "%sHEADER %s %s"
+ fuzzy
+ (car expr)
+ (gnus-search-imap-handle-string engine (cdr expr))))))))))
+
+(cl-defmethod gnus-search-imap-handle-date ((_engine gnus-search-imap)
+ (date list))
+ "Turn DATE into a date string recognizable by IMAP.
+While other search engines can interpret partially-qualified
+dates such as a plain \"January\", IMAP requires an absolute
+date.
+
+DATE is a list of (dd mm yyyy), any element of which could be
+nil (except that (dd nil yyyy) is not allowed). Massage those
+numbers into the most recent past occurrence of whichever date
+elements are present."
+ (pcase-let ((`(,nday ,nmonth ,nyear)
+ (seq-subseq (decode-time (current-time))
+ 3 6))
+ (`(,dday ,dmonth ,dyear) date))
+ (unless (and dday dmonth dyear)
+ (unless dday (setq dday 1))
+ (if dyear
+ ;; If we have a year, then leave everything else as is or set
+ ;; to 1.
+ (setq dmonth (or dmonth 1))
+ (if dmonth
+ (setq dyear
+ (if (or (> dmonth nmonth)
+ (and (= dmonth nmonth)
+ (> dday nday)))
+ ;; If our day/month combo is ahead of "now",
+ ;; move the year back.
+ (1- nyear)
+ nyear))
+ (setq dmonth 1))))
+ (format-time-string
+ "%e-%b-%Y"
+ (apply #'encode-time
+ (append '(0 0 0)
+ (list dday dmonth dyear))))))
+
+(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap)
+ (str string))
+ (with-slots (literal-plus) engine
+ (if (multibyte-string-p str)
+ ;; If LITERAL+ is available, use it and encode string as
+ ;; UTF-8.
+ (if literal-plus
+ (format "{%d+}\n%s"
+ (string-bytes str)
+ (encode-coding-string str 'utf-8))
+ ;; Otherwise, if the user hasn't already quoted the string,
+ ;; quote it for them.
+ (if (string-prefix-p "\"" str)
+ str
+ (format "\"%s\"" str)))
+ str)))
+
+(defun gnus-search-imap-handle-flag (flag)
+ "Adjust string FLAG to help IMAP recognize it.
+If it's one of the RFC3501 flags, make sure it's upcased.
+Otherwise, if FLAG starts with a \"$\", treat as a KEYWORD
+search. Otherwise, drop the flag."
+ (setq flag
+ (pcase flag
+ ("flag" "flagged")
+ ("read" "seen")
+ ("replied" "answered")
+ (_ flag)))
+ (cond
+ ((member flag '("seen" "answered" "deleted" "draft" "flagged" "recent"))
+ (upcase flag))
+ ((string-prefix-p "$" flag)
+ (format "KEYWORD %s" flag))
+ ;; TODO: Provide a user option to treat *all* marks as a KEYWORDs?
+ (t "")))
+
+;;; Methods for the indexed search engines.
+
+;; First, some common methods.
+
+(cl-defgeneric gnus-search-indexed-parse-output (engine server query &optional groups)
+ "Parse the results of ENGINE's QUERY against SERVER in GROUPS.
+Locally-indexed search engines return results as a list of
+filenames, sometimes with additional information. Returns a list
+of viable results, in the form of a list of [group article score]
+vectors.")
+
+(cl-defgeneric gnus-search-indexed-extract (engine)
+ "Extract a single article result from the current buffer.
+Returns a list of two values: a file name, and a relevancy score.
+Advances point to the beginning of the next result.")
+
+(cl-defmethod gnus-search-run-search ((engine gnus-search-indexed)
+ server query groups)
+ "Run QUERY against SERVER using ENGINE.
+This method is common to all indexed search engines.
+
+Returns a list of [group article score] vectors."
+
+ (save-excursion
+ (let* ((qstring (gnus-search-make-query-string engine query))
+ (program (slot-value engine 'program))
+ (buffer (slot-value engine 'proc-buffer))
+ (cp-list (gnus-search-indexed-search-command
+ engine qstring query groups))
+ proc exitstatus)
+ (set-buffer buffer)
+ (erase-buffer)
+
+ (if groups
+ (message "Doing %s query on %s..." program groups)
+ (message "Doing %s query..." program))
+ (setq proc (apply #'start-process (format "search-%s" server)
+ buffer program cp-list))
+ (while (process-live-p proc)
+ (accept-process-output proc))
+ (setq exitstatus (process-exit-status proc))
+ (if (zerop exitstatus)
+ ;; The search results have been put into the current buffer;
+ ;; `parse-output' finds them there and returns the article
+ ;; list.
+ (gnus-search-indexed-parse-output engine server query groups)
+ (nnheader-report 'search "%s error: %s" program exitstatus)
+ ;; Failure reason is in this buffer, show it if the user
+ ;; wants it.
+ (when (> gnus-verbose 6)
+ (display-buffer buffer))
+ nil))))
+
+(cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed)
+ server query &optional groups)
+ (let ((prefix (or (slot-value engine 'remove-prefix)
+ ""))
+ artlist article group)
+ (goto-char (point-min))
+ ;; Prep prefix, we want to at least be removing the root
+ ;; filesystem separator.
+ (when (stringp prefix)
+ (setq prefix (file-name-as-directory
+ (expand-file-name prefix "/"))))
+ (while (not (or (eobp)
+ (looking-at-p
+ "\\(?:[[:space:]\n]+\\)?Process .+ finished")))
+ (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine)))
+ (when (and f-name
+ (file-readable-p f-name)
+ (null (file-directory-p f-name)))
+ (setq group
+ (replace-regexp-in-string
+ "[/\\]" "."
+ (replace-regexp-in-string
+ "/?\\(cur\\|new\\|tmp\\)?/\\'" ""
+ (replace-regexp-in-string
+ "\\`\\." ""
+ (string-remove-prefix
+ prefix (file-name-directory f-name))
+ nil t)
+ nil t)
+ nil t))
+ (setq group (gnus-group-full-name group server))
+ (setq article (file-name-nondirectory f-name)
+ article
+ ;; TODO: Provide a cleaner way of producing final
+ ;; article numbers for the various backends.
+ (if (string-match-p "\\`[[:digit:]]+\\'" article)
+ (string-to-number article)
+ (nnmaildir-base-name-to-article-number
+ (substring article 0 (string-match ":" article))
+ group (string-remove-prefix "nnmaildir:" server))))
+ (when (and (numberp article)
+ (or (null groups)
+ (member group groups)))
+ (push (list f-name article group score)
+ artlist)))))
+ ;; Are we running an additional grep query?
+ (when-let ((grep-reg (alist-get 'grep query)))
+ (setq artlist (gnus-search-grep-search engine artlist grep-reg)))
+ ;; Munge into the list of vectors expected by nnselect.
+ (mapcar (pcase-lambda (`(,_ ,article ,group ,score))
+ (vector group article
+ (if (numberp score)
+ score
+ (string-to-number score))))
+ artlist)))
+
+(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed))
+ "Base implementation treats the whole line as a filename, and
+fudges a relevancy score of 100."
+ (prog1
+ (list (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position))
+ 100)
+ (forward-line 1)))
+
+;; Swish++
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++)
+ (expr (head near)))
+ (format "%s near %s"
+ (gnus-search-transform-expression engine (nth 1 expr))
+ (gnus-search-transform-expression engine (nth 2 expr))))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++)
+ (expr list))
+ (cond
+ ((listp (car expr))
+ (format "(%s)" (gnus-search-transform engine expr)))
+ ;; Untested and likely wrong.
+ ((and (stringp (cdr expr))
+ (string-prefix-p "(" (cdr expr)))
+ (format "%s = %s" (car expr) (gnus-search-transform
+ engine
+ (gnus-search-parse-query (cdr expr)))))
+ (t (format "%s = %s" (car expr) (cdr expr)))))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish++)
+ (qstring string)
+ _query &optional _groups)
+ (with-slots (config-file switches) engine
+ `("--config-file" ,config-file
+ ,@switches
+ ,qstring
+ )))
+
+(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish++))
+ (when (re-search-forward
+ "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t)
+ (list (match-string 2)
+ (match-string 1))))
+
+;; Swish-e
+
+;; I didn't do the query transformation for Swish-e, because the
+;; program seems no longer to exist.
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish-e)
+ (qstring string)
+ _query &optional _groups)
+ (with-slots (index-files switches) engine
+ `("-f" ,@index-files
+ ,@switches
+ "-w"
+ ,qstring
+ )))
+
+(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish-e))
+ (when (re-search-forward
+ "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t)
+ (list (match-string 3)
+ (match-string 1))))
+
+;; Namazu interface
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-namazu)
+ (expr list))
+ (cond
+ ((listp (car expr))
+ (format "(%s)" (gnus-search-transform engine expr)))
+ ((eql (car expr) 'body)
+ (cadr expr))
+ ;; I have no idea which fields namazu can handle. Just do these
+ ;; for now.
+ ((memq (car expr) '(subject from to))
+ (format "+%s:%s" (car expr) (cdr expr)))
+ ((eql (car expr) 'address)
+ (gnus-search-transform engine `((or (from . ,(cdr expr))
+ (to . ,(cdr expr))))))
+ ((eq (car expr) 'id)
+ (format "+message-id:%s" (cdr expr)))
+ (t (ignore-errors (cl-call-next-method)))))
+
+;; I can't tell if this is actually necessary.
+(cl-defmethod gnus-search-run-search :around ((_e gnus-search-namazu)
+ _server _query _groups)
+ (let ((process-environment (copy-sequence process-environment)))
+ (setenv "LC_MESSAGES" "C")
+ (cl-call-next-method)))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-namazu)
+ (qstring string)
+ query &optional _groups)
+ (let ((max (alist-get 'limit query)))
+ (with-slots (switches index-directory) engine
+ (append
+ (list "-q" ; don't be verbose
+ "-a" ; show all matches
+ "-s") ; use short format
+ (when max (list (format "--max=%d" max)))
+ switches
+ (list qstring index-directory)))))
+
+(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-namazu))
+ "Extract a single message result for Namazu.
+Namazu provides a little more information, for instance a score."
+
+ (when (re-search-forward
+ "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)"
+ nil t)
+ (forward-line 1)
+ (list (match-string 4)
+ (match-string 3))))
+
+;;; Notmuch interface
+
+(cl-defmethod gnus-search-transform ((_engine gnus-search-notmuch)
+ (_query null))
+ "*")
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch)
+ (expr (head near)))
+ (format "%s near %s"
+ (gnus-search-transform-expression engine (nth 1 expr))
+ (gnus-search-transform-expression engine (nth 2 expr))))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch)
+ (expr list))
+ ;; Swap keywords as necessary.
+ (cl-case (car expr)
+ (sender (setcar expr 'from))
+ ;; Notmuch's "to" is already equivalent to our "recipient".
+ (recipient (setcar expr 'to))
+ (mark (setcar expr 'tag)))
+ ;; Then actually format the results.
+ (cl-flet ((notmuch-date (date)
+ (if (stringp date)
+ date
+ (pcase date
+ (`(nil ,m nil)
+ (nth (1- m) gnus-english-month-names))
+ (`(nil nil ,y)
+ (number-to-string y))
+ (`(,d ,m nil)
+ (format "%02d-%02d" d m))
+ (`(nil ,m ,y)
+ (format "%02d-%d" m y))
+ (`(,d ,m ,y)
+ (format "%d/%d/%d" m d y))))))
+ (cond
+ ((consp (car expr))
+ (format "(%s)" (gnus-search-transform engine expr)))
+ ((eql (car expr) 'address)
+ (gnus-search-transform engine `((or (from . ,(cdr expr))
+ (to . ,(cdr expr))))))
+ ((eql (car expr) 'body)
+ (cdr expr))
+ ((memq (car expr) '(from to subject attachment mimetype tag id
+ thread folder path lastmod query property))
+ ;; Notmuch requires message-id with no angle brackets.
+ (when (eql (car expr) 'id)
+ (setcdr
+ expr (replace-regexp-in-string "\\`<\\|>\\'" "" (cdr expr))))
+ (format "%s:%s" (car expr)
+ (if (string-match "\\`\\*" (cdr expr))
+ ;; Notmuch can only handle trailing asterisk
+ ;; wildcards, so strip leading asterisks.
+ (replace-match "" nil nil (cdr expr))
+ (cdr expr))))
+ ((eq (car expr) 'date)
+ (format "date:%s" (notmuch-date (cdr expr))))
+ ((eq (car expr) 'before)
+ (format "date:..%s" (notmuch-date (cdr expr))))
+ ((eq (car expr) 'since)
+ (format "date:%s.." (notmuch-date (cdr expr))))
+ (t (ignore-errors (cl-call-next-method))))))
+
+(cl-defmethod gnus-search-run-search :around ((engine gnus-search-notmuch)
+ server query groups)
+ "Handle notmuch's thread-search routine."
+ ;; Notmuch allows for searching threads, but only using its own
+ ;; thread ids. That means a thread search is a \"double-bounce\":
+ ;; once to find the relevant thread ids, and again to find the
+ ;; actual messages. This method performs the first \"bounce\".
+ (if (alist-get 'thread query)
+ (with-slots (program proc-buffer) engine
+ (let* ((qstring
+ (gnus-search-make-query-string engine query))
+ (cp-list (gnus-search-indexed-search-command
+ engine qstring query groups))
+ thread-ids proc)
+ (set-buffer proc-buffer)
+ (erase-buffer)
+ (setq proc (apply #'start-process (format "search-%s" server)
+ proc-buffer program cp-list))
+ (while (process-live-p proc)
+ (accept-process-output proc))
+ (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t)
+ (push (match-string 1) thread-ids))
+ (cl-call-next-method
+ engine server
+ ;; Completely replace the query with our new thread-based one.
+ (mapconcat (lambda (thrd) (concat "thread:" thrd))
+ thread-ids " or ")
+ nil)))
+ (cl-call-next-method engine server query groups)))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-notmuch)
+ (qstring string)
+ query &optional _groups)
+ ;; Theoretically we could use the GROUPS parameter to pass a
+ ;; --folder switch to notmuch, but I'm not confident of getting the
+ ;; format right.
+ (let ((limit (alist-get 'limit query))
+ (thread (alist-get 'thread query)))
+ (with-slots (switches config-file) engine
+ `(,(format "--config=%s" config-file)
+ "search"
+ ,(if thread
+ "--output=threads"
+ "--output=files")
+ "--duplicate=1" ; I have found this necessary, I don't know why.
+ ,@switches
+ ,(if limit (format "--limit=%d" limit) "")
+ ,qstring
+ ))))
+
+;;; Mairix interface
+
+;; See the Gnus manual for why mairix searching is a bit weird.
+
+(cl-defmethod gnus-search-transform ((engine gnus-search-mairix)
+ (query list))
+ "Transform QUERY for a Mairix engine.
+Because Mairix doesn't accept parenthesized expressions, nor
+\"or\" statements between different keys, results may differ from
+other engines. We unpeel parenthesized expressions, and just
+cross our fingers for the rest of it."
+ (let (clauses)
+ (mapc
+ (lambda (item)
+ (when-let ((expr (if (consp (car-safe item))
+ (gnus-search-transform engine item)
+ (gnus-search-transform-expression engine item))))
+ (push expr clauses)))
+ query)
+ (mapconcat #'identity (reverse clauses) " ")))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix)
+ (expr (head not)))
+ "Transform Mairix \"not\".
+Mairix negation requires a \"~\" preceding string search terms,
+and \"-\" before marks."
+ (let ((next (gnus-search-transform-expression engine (cadr expr))))
+ (replace-regexp-in-string
+ ":"
+ (if (eql (caadr expr) 'mark)
+ ":-"
+ ":~")
+ next)))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix)
+ (expr (head or)))
+ "Handle Mairix \"or\" statement.
+Mairix only accepts \"or\" expressions on homogeneous keys. We
+cast \"or\" expressions on heterogeneous keys as \"and\", which
+isn't quite right, but it's the best we can do. For date keys,
+only keep one of the terms."
+ (let ((term1 (caadr expr))
+ (term2 (caaddr expr))
+ (val1 (gnus-search-transform-expression engine (nth 1 expr)))
+ (val2 (gnus-search-transform-expression engine (nth 2 expr))))
+ (cond
+ ((or (listp term1) (listp term2))
+ (concat val1 " " val2))
+ ((and (member (symbol-name term1) gnus-search-date-keys)
+ (member (symbol-name term2) gnus-search-date-keys))
+ (or val1 val2))
+ ((eql term1 term2)
+ (if (and val1 val2)
+ (format "%s/%s"
+ val1
+ (nth 1 (split-string val2 ":")))
+ (or val1 val2)))
+ (t (concat val1 " " val2)))))
+
+
+(cl-defmethod gnus-search-transform-expression ((_ gnus-search-mairix)
+ (expr (head mark)))
+ (gnus-search-mairix-handle-mark (cdr expr)))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix)
+ (expr list))
+ (let ((key (cl-case (car expr)
+ (sender "f")
+ (from "f")
+ (to "t")
+ (cc "c")
+ (subject "s")
+ (id "m")
+ (body "b")
+ (address "a")
+ (recipient "tc")
+ (text "bs")
+ (attachment "n")
+ (t nil))))
+ (cond
+ ((consp (car expr))
+ (gnus-search-transform engine expr))
+ ((member (symbol-name (car expr)) gnus-search-date-keys)
+ (gnus-search-mairix-handle-date expr))
+ ((memq (car expr) '(size smaller larger))
+ (gnus-search-mairix-handle-size expr))
+ ;; Drop regular expressions.
+ ((string-match-p "\\`/" (cdr expr))
+ nil)
+ ;; Turn parenthesized phrases into multiple word terms. Again,
+ ;; this isn't quite what the user is asking for, but better to
+ ;; return false positives.
+ ((and key (string-match-p "[[:blank:]]" (cdr expr)))
+ (mapconcat
+ (lambda (s) (format "%s:%s" key s))
+ (split-string (gnus-search-mairix-treat-string
+ (cdr expr)))
+ " "))
+ (key (format "%s:%s" key
+ (gnus-search-mairix-treat-string
+ (cdr expr))))
+ (t nil))))
+
+(defun gnus-search-mairix-treat-string (str)
+ "Treat string for wildcards.
+Mairix accepts trailing wildcards, but not leading. Also remove
+double quotes."
+ (replace-regexp-in-string
+ "\\`\\*\\|\"" ""
+ (replace-regexp-in-string "\\*\\'" "=" str)))
+
+(defun gnus-search-mairix-handle-size (expr)
+ "Format a mairix size search.
+Assume \"size\" key is equal to \"larger\"."
+ (format
+ (if (eql (car expr) 'smaller)
+ "z:-%s"
+ "z:%s-")
+ (cdr expr)))
+
+(defun gnus-search-mairix-handle-mark (expr)
+ "Format a mairix mark search."
+ (let ((mark
+ (pcase (cdr expr)
+ ("flag" "f")
+ ("read" "s")
+ ("seen" "s")
+ ("replied" "r")
+ (_ nil))))
+ (when mark
+ (format "F:%s" mark))))
+
+(defun gnus-search-mairix-handle-date (expr)
+ (let ((str
+ (pcase (cdr expr)
+ (`(nil ,m nil)
+ (substring
+ (nth (1- m) gnus-english-month-names)
+ 0 3))
+ (`(nil nil ,y)
+ (number-to-string y))
+ (`(,d ,m nil)
+ (format "%s%02d"
+ (substring
+ (nth (1- m) gnus-english-month-names)
+ 0 3)
+ d))
+ (`(nil ,m ,y)
+ (format "%d%s"
+ y (substring
+ (nth (1- m) gnus-english-month-names)
+ 0 3)))
+ (`(,d ,m ,y)
+ (format "%d%02d%02d" y m d)))))
+ (format
+ (pcase (car expr)
+ ('date "d:%s")
+ ('since "d:%s-")
+ ('after "d:%s-")
+ ('before "d:-%s"))
+ str)))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mairix)
+ (qstring string)
+ query &optional _groups)
+ (with-slots (switches config-file) engine
+ (append `("--rcfile" ,config-file "-r")
+ switches
+ (when (alist-get 'thread query) (list "-t"))
+ (list qstring))))
+
+;;; Find-grep interface
+
+(cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep)
+ (_ list))
+ ;; Drop everything that isn't a plain string.
+ nil)
+
+(cl-defmethod gnus-search-run-search ((engine gnus-search-find-grep)
+ server query
+ &optional groups)
+ "Run find and grep to obtain matching articles."
+ (let* ((method (gnus-server-to-method server))
+ (sym (intern
+ (concat (symbol-name (car method)) "-directory")))
+ (directory (cadr (assoc sym (cddr method))))
+ (regexp (alist-get 'grep query))
+ (grep-options (slot-value engine 'grep-options))
+ (grouplist (or groups (gnus-search-get-active server)))
+ (buffer (slot-value engine 'proc-buffer)))
+ (unless directory
+ (signal 'gnus-search-config-error
+ (list (format-message
+ "No directory found in definition of server %s"
+ server))))
+ (apply
+ #'vconcat
+ (mapcar (lambda (x)
+ (let ((group x)
+ artlist)
+ (message "Searching %s using find-grep..."
+ (or group server))
+ (save-window-excursion
+ (set-buffer 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
+ (replace-regexp-in-string
+ "\\." "/"
+ group nil t)))
+ group))))))
+ (unless group
+ (signal 'gnus-search-config-error
+ (list
+ "Cannot locate directory for group")))
+ (save-excursion
+ (apply
+ #'call-process "find" nil t
+ "find" group "-maxdepth" "1" "-type" "f"
+ "-name" "[0-9]*" "-exec"
+ (slot-value engine 'grep-program)
+ `("-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
+ (cl-subseq path 0 -1)
+ ".")))
+ (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))))
+
+;;; Util Code:
+
+(defun gnus-search-run-query (specs)
+ "Invoke appropriate search engine function."
+ ;; For now, run the searches synchronously. At some point
+ ;; multiple-server searches can each be run in their own thread,
+ ;; allowing concurrent searches of multiple backends. At present
+ ;; this causes problems when searching more than one server that
+ ;; uses `nntp-server-buffer', as their return values are written
+ ;; interleaved into that buffer. Anyway, that's the reason for the
+ ;; `mapc'.
+ (let* ((results [])
+ (prepared-query (gnus-search-prepare-query
+ (alist-get 'search-query-spec specs)))
+ (limit (alist-get 'limit prepared-query)))
+ (mapc
+ (pcase-lambda (`(,server . ,groups))
+ (condition-case err
+ (let ((search-engine (gnus-search-server-to-engine server)))
+ (setq results
+ (vconcat
+ (gnus-search-run-search
+ search-engine server prepared-query groups)
+ results)))
+ (gnus-search-config-error
+ (if (< 1 (length (alist-get 'search-group-spec specs)))
+ (apply #'nnheader-message 4
+ "Search engine for %s improperly configured: %s"
+ server (cdr err))
+ (signal 'gnus-search-config-error err)))))
+ (alist-get 'search-group-spec specs))
+ ;; Some search engines do their own limiting, but some don't, so
+ ;; do it again here. This is bad because, if the user is
+ ;; searching multiple groups, they would reasonably expect the
+ ;; limiting to apply to the search results *after sorting*. Doing
+ ;; it this way is liable to, for instance, eliminate all results
+ ;; from a later group entirely.
+ (if limit
+ (seq-subseq results 0 (min limit (length results)))
+ results)))
+
+(defun gnus-search-prepare-query (query-spec)
+ "Accept a search query in raw format, and prepare it.
+QUERY-SPEC is an alist produced by functions such as
+`gnus-group-make-search-group', and contains at least a 'query
+key, and possibly some meta keys. This function extracts any
+additional meta keys from the 'query string, and parses the
+remaining string, then adds all that to the top-level spec."
+ (let ((query (alist-get 'query query-spec))
+ val)
+ (when (stringp query)
+ ;; Look for these meta keys:
+ (while (string-match
+ "\\(thread\\|grep\\|limit\\|raw\\):\\([^ ]+\\)"
+ query)
+ (setq val (match-string 2 query))
+ (setf (alist-get (intern (match-string 1 query)) query-spec)
+ ;; This is stupid.
+ (cond
+ ((equal val "t"))
+ ((null (zerop (string-to-number val)))
+ (string-to-number val))
+ (t val)))
+ (setq query
+ (string-trim (replace-match "" t t query 0)))
+ (setf (alist-get 'query query-spec) query)))
+ (when (and gnus-search-use-parsed-queries
+ (null (alist-get 'raw query-spec)))
+ (setf (alist-get 'parsed-query query-spec)
+ (gnus-search-parse-query query)))
+ query-spec))
+
+;; This should be done once at Gnus startup time, when the servers are
+;; first opened, and the resulting engine instance attached to the
+;; server.
+(defun gnus-search-server-to-engine (srv)
+ (let* ((method (gnus-server-to-method srv))
+ (engine-config (assoc 'gnus-search-engine (cddr method)))
+ (server (or (cdr-safe
+ (assoc-string srv gnus-search-engine-instance-alist t))
+ (nth 1 engine-config)
+ (cdr-safe (assoc (car method) gnus-search-default-engines))
+ (when-let ((old (assoc 'nnir-search-engine
+ (cddr method))))
+ (nnheader-message
+ 8 "\"nnir-search-engine\" is no longer a valid parameter")
+ (nth 1 old))))
+ inst)
+ (setq server
+ (pcase server
+ ('notmuch 'gnus-search-notmuch)
+ ('namazu 'gnus-search-namazu)
+ ('find-grep 'gnus-search-find-grep)
+ ('imap 'gnus-search-imap)
+ (_ server))
+ inst
+ (cond
+ ((null server) nil)
+ ((eieio-object-p server)
+ server)
+ ((class-p server)
+ (make-instance server))
+ (t nil)))
+ (if inst
+ (unless (assoc-string srv gnus-search-engine-instance-alist t)
+ (when (cddr engine-config)
+ ;; We're not being completely backward-compatible here,
+ ;; because we're not checking for nnir-specific config
+ ;; options in the server definition.
+ (pcase-dolist (`(,key ,value) (cddr engine-config))
+ (condition-case nil
+ (setf (slot-value inst key) value)
+ ((invalid-slot-name invalid-slot-type)
+ (nnheader-report 'search
+ "Invalid search engine parameter: (%s %s)"
+ key value)))))
+ (push (cons srv inst) gnus-search-engine-instance-alist))
+ (signal 'gnus-search-config-error
+ (list (format-message
+ "No search engine configured for %s" srv))))
+ inst))
+
+(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
+
+(defun gnus-search-thread (header)
+ "Make an nnselect group based on the thread containing the article
+header. The current server will be searched. If the registry is
+installed, the server that the registry reports the current
+article came from is also searched."
+ (let* ((ids (cons (mail-header-id header)
+ (split-string
+ (or (mail-header-references header)
+ ""))))
+ (query
+ (list (cons 'query (mapconcat (lambda (i)
+ (format "id:%s" i))
+ ids " or "))
+ (cons 'thread t)))
+ (server
+ (list (list (gnus-method-to-server
+ (gnus-find-method-for-group gnus-newsgroup-name)))))
+ (registry-group (and
+ (bound-and-true-p gnus-registry-enabled)
+ (car (gnus-registry-get-id-key
+ (mail-header-id header) 'group))))
+ (registry-server
+ (and registry-group
+ (gnus-method-to-server
+ (gnus-find-method-for-group registry-group)))))
+ (when registry-server
+ (cl-pushnew (list registry-server) server :test #'equal))
+ (gnus-group-make-search-group nil (list
+ (cons 'search-query-spec query)
+ (cons 'search-group-spec server)))
+ (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
+
+(defun gnus-search-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)))
+ (goto-char (point-min))
+ (unless (or (null gnus-search-ignored-newsgroups)
+ (string= gnus-search-ignored-newsgroups ""))
+ (delete-matching-lines gnus-search-ignored-newsgroups))
+ (if (eq (car method) 'nntp)
+ (while (not (eobp))
+ (ignore-errors
+ (push (gnus-group-decoded-name
+ (gnus-group-full-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point)))
+ method))
+ groups))
+ (forward-line))
+ (while (not (eobp))
+ (ignore-errors
+ (push (gnus-group-decoded-name
+ (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))
+
+(defvar gnus-search-minibuffer-map
+ (let ((km (make-sparse-keymap)))
+ (set-keymap-parent km minibuffer-local-map)
+ (define-key km (kbd "TAB") #'completion-at-point)
+ km))
+
+(defun gnus-search--complete-key-data ()
+ "Potentially return completion data for a search key or value."
+ (let* ((key-start (save-excursion
+ (or (re-search-backward " " (minibuffer-prompt-end) t)
+ (goto-char (minibuffer-prompt-end)))
+ (skip-chars-forward " -")
+ (point)))
+ (after-colon (save-excursion
+ (when (re-search-backward ":" key-start t)
+ (1+ (point)))))
+ in-string)
+ (if after-colon
+ ;; We're in the value part of a key:value pair, which we
+ ;; only handle in a contact-completion context.
+ (when (and gnus-search-contact-tables
+ (save-excursion
+ (re-search-backward "\\<-?\\(\\w+\\):" key-start t)
+ (member (match-string 1)
+ '("from" "to" "cc"
+ "bcc" "recipient" "address"))))
+ (setq in-string (nth 3 (syntax-ppss)))
+ (list (if in-string (1+ after-colon) after-colon)
+ (point) (apply #'completion-table-merge
+ gnus-search-contact-tables)
+ :exit-function
+ (lambda (str status)
+ ;; If the value contains spaces, make sure it's
+ ;; quoted.
+ (when (and (memql status '(exact finished))
+ (or (string-match-p " " str)
+ in-string))
+ (unless (looking-at-p "\\s\"")
+ (insert "\""))
+ ;; Unless we already have an opening quote...
+ (unless in-string
+ (save-excursion
+ (goto-char after-colon)
+ (insert "\"")))))))
+ (list
+ key-start (point) gnus-search-expandable-keys
+ :exit-function (lambda (_s status)
+ (when (memql status '(exact finished))
+ (insert ":")))))))
+
+(defun gnus-search-make-spec (arg)
+ (list (cons 'query
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (add-hook 'completion-at-point-functions
+ #'gnus-search--complete-key-data
+ nil t))
+ (read-from-minibuffer
+ "Query: " nil gnus-search-minibuffer-map
+ nil 'gnus-search-history)))
+ (cons 'raw arg)))
+
+(provide 'gnus-search)
+;;; gnus-search.el ends here
diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el
index 680c90ecbfb..eeedf7ff35c 100644
--- a/lisp/gnus/gnus-sieve.el
+++ b/lisp/gnus/gnus-sieve.el
@@ -1,4 +1,4 @@
-;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
+;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -29,8 +29,6 @@
(require 'gnus)
(require 'gnus-sum)
-(require 'format-spec)
-(autoload 'sieve-mode "sieve-mode")
(eval-when-compile
(require 'sieve))
@@ -42,30 +40,25 @@
(defcustom gnus-sieve-file "~/.sieve"
"Path to your Sieve script."
- :type 'file
- :group 'gnus-sieve)
+ :type 'file)
(defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n"
"Line indicating the start of the autogenerated region in your Sieve script."
- :type 'string
- :group 'gnus-sieve)
+ :type 'string)
(defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n"
"Line indicating the end of the autogenerated region in your Sieve script."
- :type 'string
- :group 'gnus-sieve)
+ :type 'string)
(defcustom gnus-sieve-select-method nil
"Which select method we generate the Sieve script for.
For example: \"nnimap:mailbox\""
;; FIXME? gnus-select-method?
- :type '(choice (const nil) string)
- :group 'gnus-sieve)
+ :type '(choice (const nil) string))
(defcustom gnus-sieve-crosspost t
"Whether the generated Sieve script should do crossposting."
- :type 'boolean
- :group 'gnus-sieve)
+ :type 'boolean)
(defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s"
"Shell command to execute after updating your Sieve script. The following
@@ -73,8 +66,7 @@ formatting characters are recognized:
%f Script's file name (gnus-sieve-file)
%s Server name (from gnus-sieve-select-method)"
- :type 'string
- :group 'gnus-sieve)
+ :type 'string)
;;;###autoload
(defun gnus-sieve-update ()
@@ -88,10 +80,10 @@ See the documentation for these variables and functions for details."
(save-buffer)
(shell-command
(format-spec gnus-sieve-update-shell-command
- (format-spec-make ?f gnus-sieve-file
- ?s (or (cadr (gnus-server-get-method
- nil gnus-sieve-select-method))
- "")))))
+ `((?f . ,gnus-sieve-file)
+ (?s . ,(or (cadr (gnus-server-get-method
+ nil gnus-sieve-select-method))
+ ""))))))
;;;###autoload
(defun gnus-sieve-generate ()
@@ -121,7 +113,7 @@ Return nil if no rule could be guessed."
;;;###autoload
(defun gnus-sieve-article-add-rule ()
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-summary-select-article nil 'force)
(with-current-buffer gnus-original-article-buffer
(let ((rule (gnus-sieve-guess-rule-for-article))
@@ -142,7 +134,7 @@ For example:
\(gnus-sieve-string-list \\='(\"to\" \"cc\"))
=> \"[\\\"to\\\", \\\"cc\\\"]\"
"
- (concat "[\"" (mapconcat 'identity list "\", \"") "\"]"))
+ (concat "[\"" (mapconcat #'identity list "\", \"") "\"]"))
(defun gnus-sieve-test-list (list)
"Convert an elisp test list to a Sieve test list.
@@ -150,7 +142,7 @@ For example:
For example:
\(gnus-sieve-test-list \\='((address \"sender\" \"boss@company.com\") (size :over 4K)))
=> \"(address \\\"sender\\\" \\\"boss@company.com\\\", size :over 4K)\""
- (concat "(" (mapconcat 'gnus-sieve-test list ", ") ")"))
+ (concat "(" (mapconcat #'gnus-sieve-test list ", ") ")"))
;; FIXME: do proper quoting
(defun gnus-sieve-test-token (token)
@@ -191,7 +183,7 @@ For example:
(size :over 100K))))
=> \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"my@address.com\\\",
size :over 100K)\""
- (mapconcat 'gnus-sieve-test-token test " "))
+ (mapconcat #'gnus-sieve-test-token test " "))
(defun gnus-sieve-script (&optional method crosspost)
"Generate a Sieve script based on groups with select method METHOD
@@ -230,7 +222,7 @@ This is returned as a string."
"\tstop;\n")
"}")
script)))))
- (mapconcat 'identity script "\n")))
+ (mapconcat #'identity script "\n")))
(provide 'gnus-sieve)
diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el
index a5228551396..cb60108ea9c 100644
--- a/lisp/gnus/gnus-spec.el
+++ b/lisp/gnus/gnus-spec.el
@@ -1,4 +1,4 @@
-;;; gnus-spec.el --- format spec functions for Gnus
+;;; gnus-spec.el --- format spec functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -146,14 +146,14 @@ Return a list of updated types."
(while (setq type (pop types))
;; Jump to the proper buffer to find out the value of the
;; variable, if possible. (It may be buffer-local.)
- (save-excursion
+ (save-current-buffer
(let ((buffer (intern (format "gnus-%s-buffer" type))))
(when (and (boundp buffer)
(setq val (symbol-value buffer))
(gnus-buffer-live-p val))
- (set-buffer val))
- (setq new-format (symbol-value
- (intern (format "gnus-%s-line-format" type)))))
+ (set-buffer val)))
+ (setq new-format (symbol-value
+ (intern (format "gnus-%s-line-format" type))))
(setq entry (cdr (assq type gnus-format-specs)))
(if (and (car entry)
(equal (car entry) new-format))
@@ -170,7 +170,7 @@ Return a list of updated types."
new-format
(symbol-value
(intern (format "gnus-%s-line-format-alist" type)))
- (not (string-match "mode$" (symbol-name type))))))
+ (not (string-match "mode\\'" (symbol-name type))))))
;; Enter the new format spec into the list.
(if entry
(progn
@@ -526,13 +526,13 @@ or to characters when given a pad value."
(if (eq spec ?%)
;; "%%" just results in a "%".
(insert "%")
- (cond
- ;; Do tilde forms.
- ((eq spec ?@)
- (setq elem (list tilde-form ?s)))
- ;; Treat user defined format specifiers specially.
- (user-defined
- (setq elem
+ (setq elem
+ (cond
+ ;; Do tilde forms.
+ ((eq spec ?@)
+ (list tilde-form ?s))
+ ;; Treat user defined format specifiers specially.
+ (user-defined
(list
(list (intern (format
(if (stringp user-defined)
@@ -540,14 +540,14 @@ or to characters when given a pad value."
"gnus-user-format-function-%c")
user-defined))
'gnus-tmp-header)
- ?s)))
- ;; Find the specification from `spec-alist'.
- ((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
- ;; We used to use "%l" for displaying the grouplens score.
- ((eq spec ?l)
- (setq elem '("" ?s)))
- (t
- (setq elem '("*" ?s))))
+ ?s))
+ ;; Find the specification from `spec-alist'.
+ ((cdr (assq (or extended-spec spec) spec-alist)))
+ ;; We used to use "%l" for displaying the grouplens score.
+ ((eq spec ?l)
+ '("" ?s))
+ (t
+ '("*" ?s))))
(setq elem-type (cadr elem))
;; Insert the new format elements.
(when pad-width
@@ -628,8 +628,8 @@ or to characters when given a pad value."
If PROPS, insert the result."
(let ((form (gnus-parse-format format alist props)))
(if props
- (add-text-properties (point) (progn (eval form) (point)) props)
- (eval form))))
+ (add-text-properties (point) (progn (eval form t) (point)) props)
+ (eval form t))))
(defun gnus-set-format (type &optional insertable)
(set (intern (format "gnus-%s-line-format-spec" type))
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index 686dd974969..1c75abb6f4b 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -1,4 +1,4 @@
-;;; gnus-srvr.el --- virtual server support for Gnus
+;;; gnus-srvr.el --- virtual server support for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -34,7 +34,7 @@
(require 'gnus-range)
(require 'gnus-cloud)
-(autoload 'gnus-group-make-nnir-group "nnir")
+(autoload 'gnus-group-read-ephemeral-search-group "nnselect")
(defcustom gnus-server-exit-hook nil
"Hook run when exiting the server buffer."
@@ -176,7 +176,7 @@ If nil, a faster, but more primitive, buffer is used instead."
"g" gnus-server-regenerate-server
- "G" gnus-group-make-nnir-group
+ "G" gnus-group-read-ephemeral-search-group
"z" gnus-server-compact-server
@@ -262,8 +262,7 @@ The following commands are available:
(setq mode-line-process nil)
(buffer-disable-undo)
(setq truncate-lines t)
- (set (make-local-variable 'font-lock-defaults)
- '(gnus-server-font-lock-keywords t)))
+ (setq-local font-lock-defaults '(gnus-server-font-lock-keywords t)))
(defun gnus-server-insert-server-line (name method)
@@ -298,7 +297,7 @@ The following commands are available:
(point)
(prog1 (1+ (point))
;; Insert the text.
- (eval gnus-server-line-format-spec))
+ (eval gnus-server-line-format-spec t))
(list 'gnus-server (intern gnus-tmp-name)
'gnus-named-server (intern (gnus-method-to-server method t))))))
@@ -309,7 +308,7 @@ The following commands are available:
;; `gnus-server-buffer' selected as the current buffer, but not always (I
;; bumped into it when starting from a dedicated *Group* frame, and
;; gnus-configure-windows opened *Server* into its own dedicated frame).
- (with-current-buffer (get-buffer-create gnus-server-buffer)
+ (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
(gnus-server-mode)
(gnus-server-prepare)))
@@ -410,7 +409,7 @@ The following commands are available:
(defun gnus-server-kill-server (server)
"Kill the server on the current line."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(unless (gnus-server-goto-server server)
(if server (error "No such server: %s" server)
(error "No server on the current line")))
@@ -439,7 +438,7 @@ The following commands are available:
(defun gnus-server-yank-server ()
"Yank the previously killed server."
- (interactive)
+ (interactive nil gnus-server-mode)
(unless gnus-server-killed-servers
(error "No killed servers to be yanked"))
(let ((alist gnus-server-alist)
@@ -461,14 +460,14 @@ The following commands are available:
(defun gnus-server-exit ()
"Return to the group buffer."
- (interactive)
+ (interactive nil gnus-server-mode)
(gnus-run-hooks 'gnus-server-exit-hook)
(gnus-kill-buffer (current-buffer))
(gnus-configure-windows 'group t))
(defun gnus-server-list-servers ()
"List all available servers."
- (interactive)
+ (interactive nil gnus-server-mode)
(let ((cur (gnus-server-server-name)))
(gnus-server-prepare)
(if cur (gnus-server-goto-server cur)
@@ -490,7 +489,7 @@ The following commands are available:
(defun gnus-server-open-server (server)
"Force an open of SERVER."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(let ((method (gnus-server-to-method server)))
(unless method
(error "No such server: %s" server))
@@ -502,13 +501,13 @@ The following commands are available:
(defun gnus-server-open-all-servers ()
"Open all servers."
- (interactive)
+ (interactive nil gnus-server-mode)
(dolist (server gnus-inserted-opened-servers)
(gnus-server-open-server (car server))))
(defun gnus-server-close-server (server)
"Close SERVER."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(let ((method (gnus-server-to-method server)))
(unless method
(error "No such server: %s" server))
@@ -520,7 +519,7 @@ The following commands are available:
(defun gnus-server-offline-server (server)
"Set SERVER to offline."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(let ((method (gnus-server-to-method server)))
(unless method
(error "No such server: %s" server))
@@ -532,7 +531,7 @@ The following commands are available:
(defun gnus-server-close-all-servers ()
"Close all servers."
- (interactive)
+ (interactive nil gnus-server-mode)
(dolist (server gnus-inserted-opened-servers)
(gnus-server-close-server (car server)))
(dolist (server gnus-server-alist)
@@ -540,7 +539,7 @@ The following commands are available:
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(let ((method (gnus-server-to-method server)))
(unless method
(error "No such server: %s" server))
@@ -551,7 +550,7 @@ The following commands are available:
(defun gnus-server-remove-denials ()
"Make all denied servers into closed servers."
- (interactive)
+ (interactive nil gnus-server-mode)
(dolist (server gnus-opened-servers)
(when (eq (nth 1 server) 'denied)
(setcar (nthcdr 1 server) 'closed)))
@@ -559,11 +558,11 @@ The following commands are available:
(defun gnus-server-copy-server (from to)
"Copy a server definition to a new name."
- (interactive
- (list
- (or (gnus-server-server-name)
- (error "No server on the current line"))
- (read-string "Copy to: ")))
+ (interactive (list
+ (or (gnus-server-server-name)
+ (error "No server on the current line"))
+ (read-string "Copy to: "))
+ gnus-server-mode)
(unless from
(error "No server on current line"))
(unless (and to (not (string= to "")))
@@ -582,9 +581,10 @@ The following commands are available:
(defun gnus-server-add-server (how where)
(interactive
(list (intern (gnus-completing-read "Server method"
- (mapcar 'car gnus-valid-select-methods)
+ (mapcar #'car gnus-valid-select-methods)
t))
- (read-string "Server name: ")))
+ (read-string "Server name: "))
+ gnus-server-mode)
(when (assq where gnus-server-alist)
(error "Server with that name already defined"))
(push (list where how where) gnus-server-killed-servers)
@@ -593,7 +593,9 @@ The following commands are available:
(defun gnus-server-goto-server (server)
"Jump to a server line."
(interactive
- (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t)))
+ (list (gnus-completing-read "Goto server"
+ (mapcar #'car gnus-server-alist) t))
+ gnus-server-mode)
(let ((to (text-property-any (point-min) (point-max)
'gnus-server (intern server))))
(when to
@@ -602,7 +604,7 @@ The following commands are available:
(defun gnus-server-edit-server (server)
"Edit the server on the current line."
- (interactive (list (gnus-server-server-name)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(unless server
(error "No server on current line"))
(unless (assoc server gnus-server-alist)
@@ -612,27 +614,27 @@ The following commands are available:
(gnus-close-server info)
(gnus-edit-form
info "Editing the server."
- `(lambda (form)
- (gnus-server-set-info ,server form)
- (gnus-server-list-servers)
- (gnus-server-position-point))
+ (lambda (form)
+ (gnus-server-set-info server form)
+ (gnus-server-list-servers)
+ (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)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(unless server
(error "No server on current line"))
(let ((info (gnus-server-to-method server)))
(gnus-edit-form
info "Showing the server."
- (lambda (form)
+ (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)))
+ (interactive (list (gnus-server-server-name)) gnus-server-mode)
(let ((method (gnus-server-to-method server)))
(if (not (gnus-get-function method 'request-scan))
(error "Server %s can't scan" (car method))
@@ -714,7 +716,7 @@ claim them."
"\M-n" gnus-browse-next-group
"\M-p" gnus-browse-prev-group
"\r" gnus-browse-select-group
- "u" gnus-browse-unsubscribe-current-group
+ "u" gnus-browse-toggle-subscription-at-point
"l" gnus-browse-exit
"L" gnus-browse-exit
"q" gnus-browse-exit
@@ -733,7 +735,7 @@ claim them."
(easy-menu-define
gnus-browse-menu gnus-browse-mode-map ""
'("Browse"
- ["Subscribe" gnus-browse-unsubscribe-current-group t]
+ ["Toggle Subscribe" gnus-browse-toggle-subscription-at-point t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-select-group t]
["Describe" gnus-browse-describe-group t]
@@ -879,9 +881,9 @@ All normal editing commands are switched off.
\\<gnus-browse-mode-map>
The only things you can do in this buffer is
-1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
-The group will be inserted into the group buffer upon exit from this
-buffer.
+1) `\\[gnus-browse-toggle-subscription-at-point]' to subscribe or unsubscribe to
+a group. The group will be inserted into the group buffer upon exit from
+this buffer.
2) `\\[gnus-browse-read-group]' to read a group ephemerally.
@@ -897,7 +899,7 @@ buffer.
(defun gnus-browse-read-group (&optional no-article number)
"Enter the group at the current line.
If NUMBER, fetch this number of articles."
- (interactive "P")
+ (interactive "P" gnus-browse-mode)
(let* ((full-name (gnus-browse-group-name))
(group (if (gnus-native-method-p
(gnus-find-method-for-group full-name))
@@ -916,33 +918,38 @@ If NUMBER, fetch this number of articles."
(defun gnus-browse-select-group (&optional number)
"Select the current group.
If NUMBER, fetch this number of articles."
- (interactive "P")
+ (interactive "P" gnus-browse-mode)
(gnus-browse-read-group 'no number))
(defun gnus-browse-next-group (n)
"Go to the next group."
- (interactive "p")
+ (interactive "p" gnus-browse-mode)
(prog1
(forward-line n)
(gnus-group-position-point)))
(defun gnus-browse-prev-group (n)
"Go to the next group."
- (interactive "p")
+ (interactive "p" gnus-browse-mode)
(gnus-browse-next-group (- n)))
-(defun gnus-browse-unsubscribe-current-group (arg)
+(define-obsolete-function-alias 'gnus-browse-unsubscribe-current-group
+ 'gnus-browse-toggle-subscription-at-point "28.1")
+(define-obsolete-function-alias 'gnus-browse-unsubscribe-group
+ 'gnus-browse-toggle-subscription "28.1")
+
+(defun gnus-browse-toggle-subscription-at-point (arg)
"(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")
+ (interactive "p" gnus-browse-mode)
(when (eobp)
(error "No group at current line"))
(let ((ward (if (< arg 0) -1 1))
(arg (abs arg)))
(while (and (> arg 0)
(not (eobp))
- (gnus-browse-unsubscribe-group)
+ (gnus-browse-toggle-subscription)
(zerop (gnus-browse-next-group ward)))
(cl-decf arg))
(gnus-group-position-point)
@@ -961,7 +968,7 @@ how new groups will be entered into the group buffer."
(defun gnus-browse-describe-group (group)
"Describe the current group."
- (interactive (list (gnus-browse-group-name)))
+ (interactive (list (gnus-browse-group-name)) gnus-browse-mode)
(gnus-group-describe-group nil group))
(defun gnus-browse-delete-group (group force)
@@ -970,11 +977,11 @@ If FORCE (the prefix) is non-nil, all the articles in the group will
be deleted. This is \"deleted\" as in \"removed forever from the face
of the Earth\". There is no undo. The user will be prompted before
doing the deletion."
- (interactive (list (gnus-browse-group-name)
- current-prefix-arg))
+ (interactive (list (gnus-browse-group-name) current-prefix-arg)
+ gnus-browse-mode)
(gnus-group-delete-group group force))
-(defun gnus-browse-unsubscribe-group ()
+(defun gnus-browse-toggle-subscription ()
"Toggle subscription of the current group in the browse buffer."
(let ((sub nil)
(buffer-read-only nil)
@@ -1020,7 +1027,7 @@ doing the deletion."
(defun gnus-browse-exit ()
"Quit browsing and return to the group buffer."
- (interactive)
+ (interactive nil gnus-browse-mode)
(when (derived-mode-p 'gnus-browse-mode)
(gnus-kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
@@ -1032,7 +1039,7 @@ doing the deletion."
(defun gnus-browse-describe-briefly ()
"Give a one line description of the group mode commands."
- (interactive)
+ (interactive nil gnus-browse-mode)
(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")))
@@ -1089,7 +1096,7 @@ Requesting compaction of %s... (this may take a long time)"
(defun gnus-server-toggle-cloud-server ()
"Toggle whether the server under point is replicated in the Emacs Cloud."
- (interactive)
+ (interactive nil gnus-server-mode)
(let ((server (gnus-server-server-name)))
(unless server
(error "No server on the current line"))
@@ -1110,7 +1117,7 @@ Requesting compaction of %s... (this may take a long time)"
(defun gnus-server-set-cloud-method-server ()
"Set the server under point to host the Emacs Cloud."
- (interactive)
+ (interactive nil gnus-server-mode)
(let ((server (gnus-server-server-name)))
(unless server
(error "No server on the current line"))
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 19ff38966db..44e97d54846 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -31,6 +31,7 @@
(require 'gnus-range)
(require 'gnus-util)
(require 'gnus-cloud)
+(require 'gnus-dbus)
(autoload 'message-make-date "message")
(autoload 'gnus-agent-read-servers-validate "gnus-agent")
(autoload 'gnus-agent-save-local "gnus-agent")
@@ -258,7 +259,7 @@ not match this regexp will be removed before saving the list."
regexp))
(defcustom gnus-ignored-newsgroups
- (mapconcat 'identity
+ (mapconcat #'identity
'("^to\\." ; not "real" groups
"^[0-9. \t]+\\( \\|$\\)" ; all digits in name
"^[\"][\"#'()]" ; bogus characters
@@ -517,7 +518,7 @@ Can be used to turn version control on or off."
;; For subscribing new newsgroup
(defun gnus-subscribe-hierarchical-interactive (groups)
- (let ((groups (sort groups 'string<))
+ (let ((groups (sort groups #'string<))
prefixes prefix start ans group starts)
(while groups
(setq prefixes (list "^"))
@@ -636,7 +637,7 @@ the first newsgroup."
;; We subscribe the group by changing its level to `subscribed'.
(gnus-group-change-level
newsgroup gnus-level-default-subscribed
- gnus-level-killed (or next "dummy.group"))
+ gnus-level-killed next)
(gnus-request-update-group-status newsgroup 'subscribe)
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup)
@@ -662,7 +663,6 @@ the first newsgroup."
(defvar mail-sources)
(defvar nnmail-scan-directory-mail-source-once)
(defvar nnmail-split-history)
-(defvar nnmail-spool-file)
(defun gnus-close-all-servers ()
"Close all servers."
@@ -730,7 +730,7 @@ the first newsgroup."
;; Remove Gnus frames.
(gnus-kill-gnus-frames))
-(defun gnus-no-server-1 (&optional arg slave)
+(defun gnus-no-server-1 (&optional arg child)
"Read network news.
If ARG is a positive number, Gnus will use that as the startup
level. If ARG is nil, Gnus will be started at level 2
@@ -739,11 +739,10 @@ and not a positive number, Gnus will prompt the user for the name
of an NNTP server to use. As opposed to \\[gnus], this command
will not connect to the local server."
(let ((val (or arg (1- gnus-level-default-subscribed))))
- (gnus val t slave)
- (make-local-variable 'gnus-group-use-permanent-levels)
- (setq gnus-group-use-permanent-levels val)))
+ (gnus val t child)
+ (setq-local gnus-group-use-permanent-levels val)))
-(defun gnus-1 (&optional arg dont-connect slave)
+(defun gnus-1 (&optional arg dont-connect child)
"Read network news.
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
@@ -761,7 +760,7 @@ prompt the user for the name of an NNTP server to use."
(gnus-splash)
(gnus-run-hooks 'gnus-before-startup-hook)
(nnheader-init-server-buffer)
- (setq gnus-slave slave)
+ (setq gnus-child child)
(gnus-read-init-file)
;; Add "native" to gnus-predefined-server-alist just to have a
@@ -790,7 +789,7 @@ prompt the user for the name of an NNTP server to use."
(gnus-make-newsrc-file gnus-startup-file))
;; Read the dribble file.
- (when (or gnus-slave gnus-use-dribble-file)
+ (when (or gnus-child gnus-use-dribble-file)
(gnus-dribble-read-file))
;; Do the actual startup.
@@ -798,6 +797,8 @@ prompt the user for the name of an NNTP server to use."
(gnus-run-hooks 'gnus-setup-news-hook)
(when gnus-agent
(gnus-request-create-group "queue" '(nndraft "")))
+ (when gnus-dbus-close-on-sleep
+ (gnus-dbus-register-sleep-signal))
(gnus-start-draft-setup)
;; Generate the group buffer.
(gnus-group-list-groups level)
@@ -841,8 +842,7 @@ prompt the user for the name of an NNTP server to use."
If REGEXP is given, lines that match it will be deleted."
(when (and (not gnus-dribble-ignore)
(buffer-live-p gnus-dribble-buffer))
- (let ((obuf (current-buffer)))
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(when regexp
(goto-char (point-min))
(let (end)
@@ -857,8 +857,7 @@ If REGEXP is given, lines that match it will be deleted."
(insert (replace-regexp-in-string "\n" "\\\\n" string) "\n")
(bury-buffer gnus-dribble-buffer)
(with-current-buffer gnus-group-buffer
- (gnus-group-set-mode-line))
- (set-buffer obuf))))
+ (gnus-group-set-mode-line)))))
(defun gnus-dribble-touch ()
"Touch the dribble buffer."
@@ -872,13 +871,13 @@ If REGEXP is given, lines that match it will be deleted."
(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-local file-precious-flag t)
(setq buffer-save-without-query t)
(erase-buffer)
(setq buffer-file-name dribble-file)
;; The buffer may be shrunk a lot when deleting old entries.
;; It caused the auto-saving to stop.
- (set (make-local-variable 'auto-save-include-big-deletions) t)
+ (setq-local auto-save-include-big-deletions t)
(auto-save-mode t)
(buffer-disable-undo)
(bury-buffer (current-buffer))
@@ -914,9 +913,8 @@ If REGEXP is given, lines that match it will be deleted."
(defun gnus-dribble-eval-file ()
(when gnus-dribble-eval-file
(setq gnus-dribble-eval-file nil)
- (save-excursion
- (let ((gnus-dribble-ignore t))
- (set-buffer gnus-dribble-buffer)
+ (let ((gnus-dribble-ignore t))
+ (with-current-buffer gnus-dribble-buffer
(eval-buffer (current-buffer))))))
(defun gnus-dribble-delete-file ()
@@ -1008,11 +1006,11 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
;; Possibly eval the dribble file.
(and init
- (or gnus-use-dribble-file gnus-slave)
+ (or gnus-use-dribble-file gnus-child)
(gnus-dribble-eval-file))
- ;; Slave Gnusii should then clear the dribble buffer.
- (when (and init gnus-slave)
+ ;; Child Gnusii should then clear the dribble buffer.
+ (when (and init gnus-child)
(gnus-dribble-clear))
(gnus-update-format-specifications)
@@ -1030,7 +1028,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
;; Find new newsgroups and treat them.
(when (and init gnus-check-new-newsgroups (not level)
(gnus-check-server gnus-select-method)
- (not gnus-slave)
+ (not gnus-child)
gnus-plugged)
(gnus-find-new-newsgroups))
@@ -1040,8 +1038,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(gnus-server-opened gnus-select-method))
(gnus-check-bogus-newsgroups))
- ;; Read any slave files.
- (gnus-master-read-slave-newsrc)
+ ;; Read any child files.
+ (gnus-parent-read-child-newsrc)
;; Find the number of unread articles in each non-dead group.
(let ((gnus-read-active-file (and (not level) gnus-read-active-file)))
@@ -1071,7 +1069,7 @@ With 1 C-u, use the `ask-server' method to query the server for new
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")
+ (interactive "p" gnus-group-mode)
(let* ((gnus-subscribe-newsgroup-method
gnus-subscribe-newsgroup-method)
(check (cond
@@ -1174,7 +1172,7 @@ for new groups, and subscribe the new groups as zombies."
gnus-check-new-newsgroups)
gnus-secondary-select-methods))))
(groups 0)
- group new-newsgroups got-new method hashtb
+ new-newsgroups got-new method hashtb ;; group
gnus-override-subscribe-method)
(unless gnus-killed-hashtb
(gnus-make-hashtable-from-killed))
@@ -1185,10 +1183,9 @@ for new groups, and subscribe the new groups as zombies."
gnus-override-subscribe-method method)
(when (and (gnus-check-server method)
(gnus-request-newgroups date method))
- (save-excursion
- (setq got-new t
- hashtb (gnus-make-hashtable 100))
- (set-buffer nntp-server-buffer)
+ (setq got-new t
+ hashtb (gnus-make-hashtable 100))
+ (with-current-buffer nntp-server-buffer
;; Enter all the new groups into a hashtable.
(gnus-active-to-gnus-format method hashtb 'ignore))
;; Now all new groups from `method' are in `hashtb'.
@@ -1206,14 +1203,14 @@ for new groups, and subscribe the new groups as zombies."
(cond
((eq do-sub 'subscribe)
(cl-incf groups)
- (puthash g-name group gnus-killed-hashtb)
+ (puthash g-name nil gnus-killed-hashtb) ;; group
(gnus-call-subscribe-functions
gnus-subscribe-options-newsgroup-method g-name))
((eq do-sub 'ignore)
nil)
(t
(cl-incf groups)
- (puthash g-name group gnus-killed-hashtb)
+ (puthash g-name nil gnus-killed-hashtb) ;; group
(if gnus-subscribe-hierarchical-interactive
(push g-name new-newsgroups)
(gnus-call-subscribe-functions
@@ -1256,19 +1253,19 @@ INFO-LIST), otherwise it's a list in the format of the
`gnus-newsrc-hashtb' entries. LEVEL is the new level of the
group, OLDLEVEL is the old level and PREVIOUS is the group (a
string name) to insert this group before."
- (let (group info active num)
- ;; Glean what info we can from the arguments.
- (if (consp entry)
- (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry))))
- (setq group entry))
+ ;; Glean what info we can from the arguments.
+ (let ((group (if (consp entry)
+ (if fromkilled (nth 1 entry) (car (nth 1 entry)))
+ entry))
+ info active num)
(when (and (stringp entry)
oldlevel
(< oldlevel gnus-level-zombie))
(setq entry (gnus-group-entry entry)))
- (if (and (not oldlevel)
- (consp entry))
- (setq oldlevel (gnus-info-level (nth 1 entry)))
- (setq oldlevel (or oldlevel gnus-level-killed)))
+ (setq oldlevel (if (and (not oldlevel)
+ (consp entry))
+ (gnus-info-level (nth 1 entry))
+ (or oldlevel gnus-level-killed)))
;; This table is used for completion, so put a dummy entry there.
(unless (gethash group gnus-active-hashtb)
@@ -1280,7 +1277,8 @@ string name) to insert this group before."
(gnus-dribble-enter
(format "(gnus-group-change-level %S %S %S %S %S)"
group level oldlevel
- (cadr (member previous gnus-group-list))
+ (when previous
+ (cadr (member previous gnus-group-list)))
fromkilled)))
;; Then we remove the newgroup from any old structures, if needed.
@@ -1339,9 +1337,10 @@ string name) to insert this group before."
;; at the head of `gnus-newsrc-alist'.
(push info (cdr gnus-newsrc-alist))
(puthash group (list num info) gnus-newsrc-hashtb)
- (when (stringp previous)
+ (when (and previous (stringp previous))
(setq previous (gnus-group-entry previous)))
- (let ((idx (or (seq-position gnus-group-list (caadr previous))
+ (let ((idx (or (and previous
+ (seq-position gnus-group-list (caadr previous)))
(length gnus-group-list))))
(push group (nthcdr idx gnus-group-list)))
(gnus-dribble-enter
@@ -1405,7 +1404,7 @@ newsgroup."
(defun gnus-check-duplicate-killed-groups ()
"Remove duplicates from the list of killed groups."
- (interactive)
+ (interactive nil gnus-group-mode)
(let ((killed gnus-killed-list))
(while killed
(gnus-message 9 "%d" (length killed))
@@ -1799,7 +1798,7 @@ backend check whether the group actually exists."
;; by one.
(t
(dolist (info infos)
- (gnus-activate-group (gnus-info-group info) nil nil method t))))))
+ (gnus-activate-group (gnus-info-group info) t nil method t))))))
(defun gnus-make-hashtable-from-newsrc-alist ()
"Create a hash table from `gnus-newsrc-alist'.
@@ -2111,6 +2110,7 @@ The info element is shared with the same element of
((string= gnus-ignored-newsgroups "")
(delete-matching-lines "^to\\."))
(t
+ ;; relint suppression: Duplicated alternative branch
(delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups))))
(goto-char (point-min))
@@ -2245,9 +2245,8 @@ If FORCE is non-nil, the .newsrc file is read."
;; can find there for changing the data already read -
;; i. e., reading the .newsrc file will not trash the data
;; already read (except for read articles).
- (save-excursion
- (gnus-message 5 "Reading %s..." newsrc-file)
- (set-buffer (nnheader-find-file-noselect newsrc-file))
+ (gnus-message 5 "Reading %s..." newsrc-file)
+ (with-current-buffer (nnheader-find-file-noselect newsrc-file)
(buffer-disable-undo)
(gnus-newsrc-to-gnus-format)
(kill-buffer (current-buffer))
@@ -2337,7 +2336,7 @@ If FORCE is non-nil, the .newsrc file is read."
gnus-newsrc-file-version gnus-version)))))))
(defun gnus-convert-mark-converter-prompt (converter no-prompt)
- "Indicate whether CONVERTER requires gnus-convert-old-newsrc to
+ "Indicate whether CONVERTER requires `gnus-convert-old-newsrc' to
display the conversion prompt. NO-PROMPT may be nil (prompt),
t (no prompt), or any form that can be called as a function.
The form should return either t or nil."
@@ -2379,6 +2378,11 @@ If FORCE is non-nil, the .newsrc file is read."
(unless (gnus-yes-or-no-p (concat errmsg "; continue? "))
(error "%s" errmsg)))))))))
+;; IIUC these 3 vars were used in older .newsrc files.
+(defvar gnus-killed-assoc)
+(defvar gnus-marked-assoc)
+(defvar gnus-newsrc-assoc)
+
(defun gnus-read-newsrc-el-file (file)
(let ((ding-file (concat file "d")))
(when (file-exists-p ding-file)
@@ -2737,15 +2741,15 @@ values from `gnus-newsrc-hashtb', and write a new value of
(gnus-agent-save-local force))
(save-excursion
- (if (and (or gnus-use-dribble-file gnus-slave)
+ (if (and (or gnus-use-dribble-file gnus-child)
(not force)
(or (not (buffer-live-p 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)
- (if gnus-slave
- (gnus-slave-save-newsrc)
+ (if gnus-child
+ (gnus-child-save-newsrc)
;; Save .newsrc only if the select method is an NNTP method.
;; The .newsrc file is for interoperability with other
;; newsreaders, so saving non-NNTP groups there doesn't make
@@ -2759,8 +2763,7 @@ values from `gnus-newsrc-hashtb', and write a new value of
;; Save .newsrc.eld.
(set-buffer (gnus-get-buffer-create " *Gnus-newsrc*"))
- (make-local-variable 'version-control)
- (setq version-control gnus-backup-startup-file)
+ (setq-local version-control gnus-backup-startup-file)
(setq buffer-file-name
(concat gnus-current-startup-file ".eld"))
(setq default-directory (file-name-directory buffer-file-name))
@@ -2812,7 +2815,7 @@ values from `gnus-newsrc-hashtb', and write a new value of
(file-exists-p working-file)))
(unwind-protect
- (progn
+ (with-file-modes (file-modes startup-file)
(gnus-with-output-to-file working-file
(gnus-gnus-to-quick-newsrc-format)
(gnus-run-hooks 'gnus-save-quick-newsrc-hook))
@@ -2822,14 +2825,12 @@ values from `gnus-newsrc-hashtb', and write a new value of
;; file.
(let ((buffer-backed-up nil)
(buffer-file-name startup-file)
- (file-precious-flag t)
- (setmodes (file-modes startup-file)))
+ (file-precious-flag t))
;; 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)
(setq gnus-save-newsrc-file-last-timestamp
(file-attribute-modification-time
(file-attributes startup-file)))))
@@ -2971,8 +2972,7 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
(when ranges
(insert ",")))))
(insert "\n")))
- (make-local-variable 'version-control)
- (setq version-control 'never)
+ (setq-local version-control 'never)
;; It has been reported that sometime the modtime on the .newsrc
;; file seems to be off. We really do want to overwrite it, so
;; we clear the modtime here before saving. It's a bit odd,
@@ -2990,55 +2990,60 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
;;;
-;;; Slave functions.
+;;; Child functions.
;;;
-(defvar gnus-slave-mode nil)
+;; (defvar gnus-child-mode nil)
+
+(defun gnus-child-mode ()
+ "Minor mode for child Gnusae."
+ ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil).
+ ;; (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap))
+ (gnus-run-hooks 'gnus-child-mode-hook))
-(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))
+(define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1")
+(define-obsolete-variable-alias 'gnus-slave-mode-hook 'gnus-child-mode-hook
+ "28.1")
-(defun gnus-slave-save-newsrc ()
+(defun gnus-child-save-newsrc ()
(with-current-buffer gnus-dribble-buffer
- (let ((slave-name
- (make-temp-file (concat gnus-current-startup-file "-slave-")))
- (modes (ignore-errors
- (file-modes (concat gnus-current-startup-file ".eld")))))
- (let ((coding-system-for-write gnus-ding-file-coding-system))
- (gnus-write-buffer slave-name))
- (when modes
- (gnus-set-file-modes slave-name modes)))))
-
-(defun gnus-master-read-slave-newsrc ()
- (let ((slave-files
+ (with-file-modes (or (ignore-errors
+ (file-modes
+ (concat gnus-current-startup-file ".eld")))
+ (default-file-modes))
+ (let ((child-name
+ (make-temp-file (concat gnus-current-startup-file "-child-"))))
+ (let ((coding-system-for-write gnus-ding-file-coding-system))
+ (gnus-write-buffer child-name))))))
+
+(defun gnus-parent-read-child-newsrc ()
+ (let ((child-files
(directory-files
(file-name-directory gnus-current-startup-file)
t (concat
"^" (regexp-quote
- (concat
- (file-name-nondirectory gnus-current-startup-file)
- "-slave-")))
+ (file-name-nondirectory gnus-current-startup-file))
+ ;; When the obsolete variables like
+ ;; `gnus-slave-mode-hook' etc are removed, the "slave"
+ ;; bit of this regexp should also be removed.
+ "\\(-child-\\|-slave-\\)")
t))
file)
- (if (not slave-files)
- () ; There are no slave files to read.
- (gnus-message 7 "Reading slave newsrcs...")
- (with-current-buffer (gnus-get-buffer-create " *gnus slave*")
- (setq slave-files
+ (if (not child-files)
+ () ; There are no child files to read.
+ (gnus-message 7 "Reading child newsrcs...")
+ (with-current-buffer (gnus-get-buffer-create " *gnus child*")
+ (setq child-files
(sort (mapcar (lambda (file)
(list (file-attribute-modification-time
(file-attributes file))
file))
- slave-files)
+ child-files)
(lambda (f1 f2)
(time-less-p (car f1) (car f2)))))
- (while slave-files
+ (while child-files
(erase-buffer)
- (setq file (nth 1 (car slave-files)))
+ (setq file (nth 1 (car child-files)))
(nnheader-insert-file-contents file)
(when (condition-case ()
(progn
@@ -3047,12 +3052,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
(error
(gnus-error 3.2 "Possible error in %s" file)
nil))
- (unless gnus-slave ; Slaves shouldn't delete these files.
+ (unless gnus-child ; Children shouldn't delete these files.
(ignore-errors
(delete-file file))))
- (setq slave-files (cdr slave-files))))
+ (setq child-files (cdr child-files))))
(gnus-dribble-touch)
- (gnus-message 7 "Reading slave newsrcs...done"))))
+ (gnus-message 7 "Reading child newsrcs...done"))))
;;;
@@ -3095,50 +3100,49 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
(gnus-message 1 "Couldn't read newsgroups descriptions")
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))
- (when (or (search-forward "\n.\n" nil t)
- (goto-char (point-max)))
- (beginning-of-line)
- (narrow-to-region (point-min) (point)))
- ;; If these are groups from a foreign select method, we insert the
- ;; group prefix in front of the group names.
- (and method (not (inline
- (gnus-server-equal
- (gnus-server-get-method nil method)
- (gnus-server-get-method
- nil gnus-select-method))))
- (let ((prefix (gnus-group-prefixed-name "" method)))
- (goto-char (point-min))
- (while (and (not (eobp))
- (progn (insert prefix)
- (zerop (forward-line 1)))))))
- (goto-char (point-min))
- (while (not (eobp))
- (setq group
- (condition-case ()
- (read nntp-server-buffer)
- (error nil)))
- (skip-chars-forward " \t")
- (when group
- (setq group (if (numberp group)
- (number-to-string group)
- (symbol-name group)))
- (let* ((str (buffer-substring
- (point) (progn (end-of-line) (point))))
- (charset
- (or (gnus-group-name-charset method group)
- (gnus-parameter-charset group)
- gnus-default-charset)))
- ;; Fixme: Don't decode in unibyte mode.
- ;; Double fixme: We're not in unibyte mode, are we?
- (when (and str charset)
- (setq str (decode-coding-string str charset)))
- (puthash group str gnus-description-hashtb)))
- (forward-line 1))))
+ (with-current-buffer nntp-server-buffer
+ (save-excursion ;;FIXME: Not sure if it's needed!
+ (save-restriction
+ (goto-char (point-min))
+ (when (or (search-forward "\n.\n" nil t)
+ (goto-char (point-max)))
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point)))
+ ;; If these are groups from a foreign select method, we insert the
+ ;; group prefix in front of the group names.
+ (and method (not (inline
+ (gnus-server-equal
+ (gnus-server-get-method nil method)
+ (gnus-server-get-method
+ nil gnus-select-method))))
+ (let ((prefix (gnus-group-prefixed-name "" method)))
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (progn (insert prefix)
+ (zerop (forward-line 1)))))))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq group
+ (condition-case ()
+ (read nntp-server-buffer)
+ (error nil)))
+ (skip-chars-forward " \t")
+ (when group
+ (setq group (if (numberp group)
+ (number-to-string group)
+ (symbol-name group)))
+ (let* ((str (buffer-substring
+ (point) (progn (end-of-line) (point))))
+ (charset
+ (or (gnus-group-name-charset method group)
+ (gnus-parameter-charset group)
+ gnus-default-charset)))
+ ;; Fixme: Don't decode in unibyte mode.
+ ;; Double fixme: We're not in unibyte mode, are we?
+ (when (and str charset)
+ (setq str (decode-coding-string str charset)))
+ (puthash group str gnus-description-hashtb)))
+ (forward-line 1)))))
(gnus-message 5 "Reading descriptions file...done")
t))))
@@ -3155,7 +3159,7 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
"Declare back end NAME with ABILITIES as a Gnus back end."
(setq gnus-valid-select-methods
(nconc gnus-valid-select-methods
- (list (apply 'list name abilities))))
+ (list (apply #'list name abilities))))
(gnus-redefine-select-method-widget))
(defun gnus-set-default-directory ()
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index ec77f02dbcb..4bdc2023eb4 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -73,20 +73,13 @@
(eval-when-compile
(require 'subr-x))
-(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
+(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil
+ '(gnus-summary-mode))
(autoload 'gnus-cache-write-active "gnus-cache")
-(autoload 'gnus-mailing-list-insinuate "gnus-ml" nil t)
-(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" nil t)
(autoload 'gnus-pick-line-number "gnus-salt" nil t)
-(autoload 'mm-uu-dissect "mm-uu")
-(autoload 'gnus-article-outlook-deuglify-article "deuglify"
- "Deuglify broken Outlook (Express) articles and redisplay."
- t)
-(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)
+(autoload 'nnselect-article-rsv "nnselect" nil nil)
+(autoload 'nnselect-article-group "nnselect" nil nil)
+(autoload 'gnus-nnselect-group-p "nnselect" nil nil)
(defcustom gnus-kill-summary-on-exit t
"If non-nil, kill the summary buffer when you exit from it.
@@ -144,11 +137,14 @@ If t, fetch all the available old headers."
:type '(choice number
(sexp :menu-tag "other" t)))
-(defcustom gnus-refer-thread-use-nnir nil
- "Use nnir to search an entire server when referring threads.
+(define-obsolete-variable-alias 'gnus-refer-thread-use-nnir
+ 'gnus-refer-thread-use-search "28.1")
+
+(defcustom gnus-refer-thread-use-search nil
+ "Search an entire server when referring threads.
A nil value will only search for thread-related articles in the
current group."
- :version "24.1"
+ :version "28.1"
:group 'gnus-thread
:type 'boolean)
@@ -438,6 +434,16 @@ will go to the next group without confirmation."
(const slightly-quietly)
(sexp :menu-tag "on" t)))
+(defcustom gnus-paging-select-next t
+ "Control whether to select the next/prev article when paging.
+If non-nil, select the next article when reaching the end of the
+article (or the previous article when paging backwards).
+
+If nil, don't do anything at the end/start of the articles."
+ :version "28.1"
+ :group 'gnus-summary-maneuvering
+ :type 'boolean)
+
(defcustom gnus-auto-select-same nil
"If non-nil, select the next article with the same subject.
If there are no more articles with the same subject, go to
@@ -730,7 +736,8 @@ string with the suggested prefix."
:type '(repeat character))
(defcustom gnus-inhibit-user-auto-expire t
- "If non-nil, user marking commands will not mark an article as expirable, even if the group has auto-expire turned on."
+ "If non-nil, user marking commands will not mark an article as expirable.
+This is true even if the group has auto-expire turned on."
:version "21.1"
:group 'gnus-summary
:type 'boolean)
@@ -872,8 +879,9 @@ this reverses the sort order.
Ready-made functions include `gnus-article-sort-by-number',
`gnus-article-sort-by-author', `gnus-article-sort-by-subject',
-`gnus-article-sort-by-date', `gnus-article-sort-by-random'
-and `gnus-article-sort-by-score'.
+`gnus-article-sort-by-date', `gnus-article-sort-by-score',
+`gnus-article-sort-by-rsv', `gnus-article-sort-by-newsgroups',
+and `gnus-article-sort-by-random'.
When threading is turned on, the variable `gnus-thread-sort-functions'
controls how articles are sorted."
@@ -884,6 +892,8 @@ controls how articles are sorted."
(function-item gnus-article-sort-by-subject)
(function-item gnus-article-sort-by-date)
(function-item gnus-article-sort-by-score)
+ (function-item gnus-article-sort-by-rsv)
+ (function-item gnus-article-sort-by-newsgroups)
(function-item gnus-article-sort-by-random)
(function :tag "other"))
(boolean :tag "Reverse order"))))
@@ -908,8 +918,8 @@ Ready-made functions include `gnus-thread-sort-by-number',
`gnus-thread-sort-by-author', `gnus-thread-sort-by-recipient'
`gnus-thread-sort-by-subject', `gnus-thread-sort-by-date',
`gnus-thread-sort-by-score', `gnus-thread-sort-by-most-recent-number',
-`gnus-thread-sort-by-most-recent-date', `gnus-thread-sort-by-random',
-and `gnus-thread-sort-by-total-score' (see
+`gnus-thread-sort-by-most-recent-date', `gnus-thread-sort-by-newsgroups',
+`gnus-thread-sort-by-random', and `gnus-thread-sort-by-total-score' (see
`gnus-thread-score-function').
When threading is turned off, the variable
@@ -927,8 +937,10 @@ subthreads, customize `gnus-subthread-sort-functions'."
(function-item gnus-thread-sort-by-subject)
(function-item gnus-thread-sort-by-date)
(function-item gnus-thread-sort-by-score)
+ (function-item gnus-thread-sort-by-rsv)
(function-item gnus-thread-sort-by-most-recent-number)
(function-item gnus-thread-sort-by-most-recent-date)
+ (function-item gnus-thread-sort-by-newsgroups)
(function-item gnus-thread-sort-by-random)
(function-item gnus-thread-sort-by-total-score)
(function :tag "other"))
@@ -952,6 +964,7 @@ according to the value of `gnus-thread-sort-functions'."
(function-item gnus-thread-sort-by-score)
(function-item gnus-thread-sort-by-most-recent-number)
(function-item gnus-thread-sort-by-most-recent-date)
+ (function-item gnus-thread-sort-by-newsgroups)
(function-item gnus-thread-sort-by-random)
(function-item gnus-thread-sort-by-total-score)
(function :tag "other"))
@@ -1383,7 +1396,7 @@ the normal Gnus MIME machinery."
(defvar gnus-thread-indent-array nil)
(defvar gnus-thread-indent-array-level gnus-thread-indent-level)
(defvar gnus-sort-gathered-threads-function #'gnus-thread-sort-by-number
- "Function called to sort the articles within a thread after it has been gathered together.")
+ "Function to sort articles within a thread after it has been gathered together.")
(defvar gnus-summary-save-parts-type-history nil)
(defvar gnus-summary-save-parts-last-directory mm-default-directory)
@@ -1433,22 +1446,19 @@ 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 (nnir-article-rsv (mail-header-number gnus-tmp-header))
- 0)
- ?d)
- (?G (or (nnir-article-group (mail-header-number gnus-tmp-header))
- "")
- ?s)
+ (?Z (or (nnselect-article-rsv (mail-header-number gnus-tmp-header))
+ 0) ?d)
+ (?G (or (nnselect-article-group (mail-header-number gnus-tmp-header))
+ "") ?s)
(?g (or (gnus-group-short-name
- (nnir-article-group (mail-header-number gnus-tmp-header)))
- "")
- ?s)
+ (nnselect-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)
(?R gnus-tmp-replied ?c)
- (?\[ gnus-tmp-opening-bracket ?c)
- (?\] gnus-tmp-closing-bracket ?c)
+ (?\[ gnus-tmp-opening-bracket ?s)
+ (?\] gnus-tmp-closing-bracket ?s)
(?\> (make-string gnus-tmp-level ? ) ?s)
(?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s)
(?i gnus-tmp-score ?d)
@@ -1501,9 +1511,9 @@ the type of the variable (string, integer, character, etc).")
;; This is here rather than in gnus-art for compilation reasons.
(defvar gnus-article-mode-line-format-alist
- (nconc '((?w (gnus-article-wash-status) ?s)
- (?m (gnus-article-mime-part-status) ?s))
- gnus-summary-mode-line-format-alist))
+ (append '((?w (gnus-article-wash-status) ?s)
+ (?m (gnus-article-mime-part-status) ?s))
+ gnus-summary-mode-line-format-alist))
(defvar gnus-last-search-regexp nil
"Default regexp for article search command.")
@@ -1512,7 +1522,7 @@ the type of the variable (string, integer, character, etc).")
"Default shell command on article.")
(defvar gnus-newsgroup-agentized nil
- "Locally bound in each summary buffer to indicate whether the server has been agentized.")
+ "Locally bound in each summary buffer to indicate if server has been agentized.")
(defvar gnus-newsgroup-begin nil)
(defvar gnus-newsgroup-end nil)
(defvar gnus-newsgroup-last-rmail nil)
@@ -1542,7 +1552,7 @@ the type of the variable (string, integer, character, etc).")
(defvar gnus-newsgroup-expunged-tally nil)
(defvar gnus-newsgroup-marked nil
- "Sorted list of ticked articles in the current newsgroup (a subset of unread art).")
+ "Sorted list of ticked articles in current newsgroup (a subset of unread art).")
(defvar gnus-newsgroup-spam-marked nil
"List of ranges of articles that have been marked as spam.")
@@ -1619,6 +1629,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
(defvar gnus-newsgroup-sparse nil)
+(defvar gnus-newsgroup-selection nil)
+
(defvar gnus-current-article nil)
(defvar gnus-article-current nil)
(defvar gnus-current-headers nil)
@@ -1653,6 +1665,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
gnus-newsgroup-undownloaded
gnus-newsgroup-unsendable
+ gnus-newsgroup-selection
+
gnus-newsgroup-begin gnus-newsgroup-end
gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
gnus-newsgroup-last-folder gnus-newsgroup-last-file
@@ -1913,7 +1927,8 @@ increase the score of each group you read."
"," gnus-summary-best-unread-article
"[" gnus-summary-prev-unseen-article
"]" gnus-summary-next-unseen-article
- "\M-s" gnus-summary-search-article-forward
+ "\M-s\M-s" gnus-summary-search-article-forward
+ "\M-s\M-r" gnus-summary-search-article-backward
"\M-r" gnus-summary-search-article-backward
"\M-S" gnus-summary-repeat-search-article-forward
"\M-R" gnus-summary-repeat-search-article-backward
@@ -1965,6 +1980,8 @@ increase the score of each group you read."
"\C-c\C-s\C-i" gnus-summary-sort-by-score
"\C-c\C-s\C-o" gnus-summary-sort-by-original
"\C-c\C-s\C-r" gnus-summary-sort-by-random
+ "\C-c\C-s\C-u" gnus-summary-sort-by-newsgroups
+ "\C-c\C-s\C-x" gnus-summary-sort-by-extra
"=" gnus-summary-expand-window
"\C-x\C-s" gnus-summary-reselect-current-group
"\M-g" gnus-summary-rescan-group
@@ -1982,6 +1999,7 @@ increase the score of each group you read."
"\M-K" gnus-summary-edit-global-kill
;; "V" gnus-version
"\C-c\C-d" gnus-summary-describe-group
+ "\C-c\C-p" gnus-summary-make-group-from-search
"q" gnus-summary-exit
"Q" gnus-summary-exit-no-update
"\C-c\C-i" gnus-info-find-node
@@ -2505,6 +2523,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
(let ((gnus-summary-show-article-charset-alist
`((1 . ,cs))))
(gnus-summary-show-article 1))))
+ (function-put command 'completion-predicate #'ignore)
`[,(symbol-name cs) ,command t]))
(sort (coding-system-list) #'string<)))))
("Washing"
@@ -2761,7 +2780,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Hide marked" gnus-summary-limit-exclude-marks t]
["Show expunged" gnus-summary-limit-include-expunged t])
("Process Mark"
- ["Set mark" gnus-summary-mark-as-processable t]
+ ["Toggle/Set mark" gnus-summary-mark-as-processable t]
["Remove mark" gnus-summary-unmark-as-processable t]
["Remove all marks" gnus-summary-unmark-all-processable t]
["Invert marks" gnus-uu-invert-processable t]
@@ -2818,6 +2837,8 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Sort by lines" gnus-summary-sort-by-lines t]
["Sort by characters" gnus-summary-sort-by-chars t]
["Sort by marks" gnus-summary-sort-by-marks t]
+ ["Sort by newsgroup" gnus-summary-sort-by-newsgroups t]
+ ["Sort by extra" gnus-summary-sort-by-extra t]
["Randomize" gnus-summary-sort-by-random t]
["Original sort" gnus-summary-sort-by-original t])
("Help"
@@ -3019,7 +3040,7 @@ When FORCE, rebuild the tool bar."
;; Need to set `gnus-summary-tool-bar-map' because `gnus-article-mode'
;; uses its value.
(setq gnus-summary-tool-bar-map map))))
- (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))
+ (setq-local tool-bar-map gnus-summary-tool-bar-map))
(defun gnus-make-score-map (type)
"Make a summary score map of type TYPE."
@@ -3129,6 +3150,7 @@ buffer; read the Info manual for more information (`\\[gnus-info-find-node]').
The following commands are available:
\\{gnus-summary-mode-map}"
+ :interactive nil
(let ((gnus-summary-local-variables gnus-newsgroup-variables))
(gnus-summary-make-local-variables))
(gnus-summary-make-local-variables)
@@ -3155,8 +3177,8 @@ The following commands are available:
(make-local-variable 'gnus-original-article-buffer)
(add-hook 'pre-command-hook #'gnus-set-global-variables nil t)
(mm-enable-multibyte)
- (set (make-local-variable 'bookmark-make-record-function)
- #'gnus-summary-bookmark-make-record))
+ (setq-local bookmark-make-record-function
+ #'gnus-summary-bookmark-make-record))
(defun gnus-summary-make-local-variables ()
"Make all the local summary buffer variables."
@@ -3166,7 +3188,7 @@ The following commands are available:
;; Copy the global value of the variable.
(symbol-value (car local))
;; Use the value from the list.
- (eval (cdr local)))))
+ (eval (cdr local) t))))
(set (make-local-variable (car local)) global))
;; Simple nil-valued local variable.
(set (make-local-variable local) nil))))
@@ -3319,18 +3341,18 @@ article number."
,(or number
(inline-quote (gnus-summary-article-number)))))))
-(defmacro gnus-summary-thread-level (&optional number)
+(defsubst gnus-summary-thread-level (&optional number)
"Return the level of thread that starts with article NUMBER."
- `(if (and (eq gnus-summary-make-false-root 'dummy)
- (get-text-property (point) 'gnus-intangible))
- 0
- (gnus-data-level (gnus-data-find
- ,(or number '(gnus-summary-article-number))))))
+ (if (and (eq gnus-summary-make-false-root 'dummy)
+ (get-text-property (point) 'gnus-intangible))
+ 0
+ (gnus-data-level (gnus-data-find
+ (or number (gnus-summary-article-number))))))
-(defmacro gnus-summary-article-mark (&optional number)
+(defsubst gnus-summary-article-mark (&optional number)
"Return the mark of article NUMBER."
- `(gnus-data-mark (gnus-data-find
- ,(or number '(gnus-summary-article-number)))))
+ (gnus-data-mark (gnus-data-find
+ (or number (gnus-summary-article-number)))))
(defmacro gnus-summary-article-pos (&optional number)
"Return the position of the line of article NUMBER."
@@ -3459,7 +3481,7 @@ marks of articles."
;; Various summary mode internalish functions.
(defun gnus-mouse-pick-article (e)
- (interactive "e")
+ (interactive "e" gnus-summary-mode)
(mouse-set-point e)
(gnus-summary-next-page nil t))
@@ -3528,7 +3550,7 @@ Returns non-nil if the setup was successful."
(let ((gnus-summary-mode-group group))
(gnus-summary-mode))
(when (gnus-group-quit-config group)
- (set (make-local-variable 'gnus-single-article-buffer) nil))
+ (setq-local gnus-single-article-buffer nil))
(turn-on-gnus-mailing-list-mode)
;; These functions don't currently depend on GROUP, but might in
;; the future.
@@ -3638,6 +3660,7 @@ buffer that was in action when the last article was fetched."
;; so we don't call gnus-data-<field> accessors on nil.
(gnus-newsgroup-data gnus--dummy-data-list)
(gnus-newsgroup-downloadable '(0))
+ (gnus-visual nil)
case-fold-search ignores)
;; Here, all marks are bound to Z.
(gnus-summary-insert-line gnus--dummy-mail-header
@@ -3729,6 +3752,30 @@ buffer that was in action when the last article was fetched."
(inline
(gnus-summary-extract-address-component gnus-tmp-from))))))
+(defcustom gnus-sum-opening-bracket "["
+ "With %[ spec, used to identify normal (non-adopted) articles."
+ :version "28.1"
+ :type 'string
+ :group 'gnus-summary-format)
+
+(defcustom gnus-sum-closing-bracket "]"
+ "With %] spec, used to identify normal (non-adopted) articles."
+ :version "28.1"
+ :type 'string
+ :group 'gnus-summary-format)
+
+(defcustom gnus-sum-opening-bracket-adopted "<"
+ "With %[ spec, used to identify adopted articles."
+ :version "28.1"
+ :type 'string
+ :group 'gnus-summary-format)
+
+(defcustom gnus-sum-closing-bracket-adopted ">"
+ "With %] spec, used to identify adopted articles."
+ :version "28.1"
+ :type 'string
+ :group 'gnus-summary-format)
+
(defun gnus-summary-insert-line (header level current undownloaded
unread replied expirable subject-or-nil
&optional dummy score process)
@@ -3786,8 +3833,14 @@ buffer that was in action when the last article was fetched."
(1+ (match-beginning 0)) (1- (match-end 0))))
(t gnus-tmp-from)))
(gnus-tmp-subject (mail-header-subject gnus-tmp-header))
- (gnus-tmp-opening-bracket (if gnus-tmp-dummy ?\< ?\[))
- (gnus-tmp-closing-bracket (if gnus-tmp-dummy ?\> ?\]))
+ (gnus-tmp-opening-bracket
+ (if gnus-tmp-dummy
+ gnus-sum-opening-bracket-adopted
+ gnus-sum-opening-bracket))
+ (gnus-tmp-closing-bracket
+ (if gnus-tmp-dummy
+ gnus-sum-closing-bracket-adopted
+ gnus-sum-closing-bracket))
(inhibit-read-only t))
(when (string= gnus-tmp-name "")
(setq gnus-tmp-name gnus-tmp-from))
@@ -3799,7 +3852,7 @@ buffer that was in action when the last article was fetched."
(condition-case ()
(put-text-property
(point)
- (progn (eval gnus-summary-line-format-spec) (point))
+ (progn (eval gnus-summary-line-format-spec t) (point))
'gnus-number gnus-tmp-number)
(error (gnus-message 5 "Error updating the summary line")))
(when (gnus-visual-p 'summary-highlight 'highlight)
@@ -3920,14 +3973,14 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(my-format "%b %d '%y"))
(let* ((difference (time-subtract now messy-date))
(templist gnus-user-date-format-alist)
- (top (eval (caar templist))))
+ (top (eval (caar templist) t)))
(while (if (numberp top) (time-less-p top difference) (not top))
(progn
(setq templist (cdr templist))
- (setq top (eval (caar templist)))))
+ (setq top (eval (caar templist) t))))
(if (stringp (cdr (car templist)))
(setq my-format (cdr (car templist)))))
- (format-time-string (eval my-format) messy-date))
+ (format-time-string (eval my-format t) messy-date))
(error " ? ")))
(defun gnus-summary-set-local-parameters (group)
@@ -3946,8 +3999,8 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
;; buffer-local, whereas just parameters like `gcc-self',
;; `timestamp', etc. should not be bound as variables.
(if (boundp (car elem))
- (set (make-local-variable (car elem)) (eval (nth 1 elem)))
- (eval (nth 1 elem))))))))
+ (set (make-local-variable (car elem)) (eval (nth 1 elem) t))
+ (eval (nth 1 elem) t)))))))
(defun gnus-summary-read-group (group &optional show-all no-article
kill-buffer no-display backward
@@ -4051,8 +4104,6 @@ If SELECT-ARTICLES, only select those articles from GROUP."
;; The group was successfully selected.
(t
(gnus-set-global-variables)
- (when (boundp 'gnus-pick-line-number)
- (setq gnus-pick-line-number 0))
(when (boundp 'spam-install-hooks)
(spam-initialize))
;; Save the active value in effect when the group was entered.
@@ -4170,13 +4221,15 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(defun gnus-summary-prepare ()
"Generate the summary buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((inhibit-read-only t))
(erase-buffer)
(setq gnus-newsgroup-data nil
gnus-newsgroup-data-reverse nil)
(gnus-run-hooks 'gnus-summary-generate-hook)
;; Generate the buffer, either with threads or without.
+ (when (boundp 'gnus-pick-line-number)
+ (setq gnus-pick-line-number 0))
(when gnus-newsgroup-headers
(gnus-summary-prepare-threads
(if gnus-show-threads
@@ -4217,7 +4270,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(defun gnus-summary-simplify-subject-query ()
"Query where the respool algorithm would put this article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(message "%s" (gnus-general-simplify-subject (gnus-summary-article-subject))))
@@ -4531,48 +4584,14 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; This function has to be called with point after the article number
;; on the beginning of the line.
(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
- (let ((eol (point-at-eol))
- header references in-reply-to)
-
+ (let (header)
;; overview: [num subject from date id refs chars lines misc]
(unwind-protect
- (let (x)
- (narrow-to-region (point) eol)
- (unless (eobp)
- (forward-char))
-
- (setq header
- (make-full-mail-header
- number ; number
- (condition-case () ; subject
- (gnus-remove-odd-characters
- (funcall gnus-decode-encoded-word-function
- (setq x (nnheader-nov-field))))
- (error x))
- (condition-case () ; from
- (gnus-remove-odd-characters
- (funcall gnus-decode-encoded-address-function
- (setq x (nnheader-nov-field))))
- (error x))
- (nnheader-nov-field) ; date
- (nnheader-nov-read-message-id number) ; id
- (setq references (nnheader-nov-field)) ; refs
- (nnheader-nov-read-integer) ; chars
- (nnheader-nov-read-integer) ; lines
- (unless (eobp)
- (if (looking-at "Xref: ")
- (goto-char (match-end 0)))
- (nnheader-nov-field)) ; Xref
- (nnheader-nov-parse-extra)))) ; extra
-
+ (narrow-to-region (point) (point-at-eol))
+ (unless (eobp)
+ (forward-char))
+ (setq header (nnheader-parse-nov number))
(widen))
-
- (when (and (string= references "")
- (setq in-reply-to (mail-header-extra header))
- (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to))))
- (setf (mail-header-references header)
- (gnus-extract-message-id-from-in-reply-to in-reply-to)))
-
(when gnus-alter-header-function
(funcall gnus-alter-header-function header))
(gnus-dependencies-add-header header dependencies force-new)))
@@ -5064,17 +5083,17 @@ using some other form will lead to serious barfage."
(gnus-article-sort-by-author
(gnus-thread-header h1) (gnus-thread-header h2)))
+(defsubst gnus-article-sort-extract-extra (name header)
+ (let ((extract
+ (funcall gnus-extract-address-components
+ (or (cdr (assq name (mail-header-extra header)))
+ ""))))
+ (or (car extract) (cadr extract))))
+
(defsubst gnus-article-sort-by-recipient (h1 h2)
"Sort articles by recipient."
- (gnus-string<
- (let ((extract (funcall
- gnus-extract-address-components
- (or (cdr (assq 'To (mail-header-extra h1))) ""))))
- (or (car extract) (cadr extract)))
- (let ((extract (funcall
- gnus-extract-address-components
- (or (cdr (assq 'To (mail-header-extra h2))) ""))))
- (or (car extract) (cadr extract)))))
+ (let ((ex (lambda (h) (gnus-article-sort-extract-extra 'To h))))
+ (gnus-string< (funcall ex h1) (funcall ex h2))))
(defun gnus-thread-sort-by-recipient (h1 h2)
"Sort threads by root recipient."
@@ -5103,6 +5122,17 @@ using some other form will lead to serious barfage."
(gnus-article-sort-by-date
(gnus-thread-header h1) (gnus-thread-header h2)))
+(defsubst gnus-article-sort-by-rsv (h1 h2)
+ "Sort articles by rsv."
+ (when gnus-newsgroup-selection
+ (< (nnselect-article-rsv (mail-header-number h1))
+ (nnselect-article-rsv (mail-header-number h2)))))
+
+(defun gnus-thread-sort-by-rsv (h1 h2)
+ "Sort threads by root article rsv."
+ (gnus-article-sort-by-rsv
+ (gnus-thread-header h1) (gnus-thread-header h2)))
+
(defsubst gnus-article-sort-by-score (h1 h2)
"Sort articles by root article score.
Unscored articles will be counted as having a score of zero."
@@ -5158,6 +5188,16 @@ Unscored articles will be counted as having a score of zero."
"Sort threads such that the thread with the most recently dated article comes first."
(> (gnus-thread-latest-date h1) (gnus-thread-latest-date h2)))
+(defsubst gnus-article-sort-by-newsgroups (h1 h2)
+ "Sort articles by newsgroups."
+ (let ((ex (lambda (h) (gnus-article-sort-extract-extra 'Newsgroups h))))
+ (gnus-string< (funcall ex h1) (funcall ex h2))))
+
+(defun gnus-thread-sort-by-newsgroups (h1 h2)
+ "Sort threads by root newsgroups."
+ (gnus-article-sort-by-newsgroups
+ (gnus-thread-header h1) (gnus-thread-header 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
@@ -5352,7 +5392,8 @@ or a straight list of headers."
;; We remember that we probably want to output a dummy
;; root.
(setq gnus-tmp-dummy-line gnus-tmp-header)
- (setq gnus-tmp-prev-subject gnus-tmp-header))
+ (setq gnus-tmp-prev-subject
+ (gnus-simplify-subject-fully gnus-tmp-header)))
(t
;; We do not make a root for the gathered
;; sub-threads at all.
@@ -5442,10 +5483,10 @@ or a straight list of headers."
(if (and (eq gnus-summary-make-false-root 'adopt)
(= gnus-tmp-level 1)
(memq number gnus-tmp-gathered))
- (setq gnus-tmp-opening-bracket ?\<
- gnus-tmp-closing-bracket ?\>)
- (setq gnus-tmp-opening-bracket ?\[
- gnus-tmp-closing-bracket ?\]))
+ (setq gnus-tmp-opening-bracket gnus-sum-opening-bracket-adopted
+ gnus-tmp-closing-bracket gnus-sum-closing-bracket-adopted)
+ (setq gnus-tmp-opening-bracket gnus-sum-opening-bracket
+ gnus-tmp-closing-bracket gnus-sum-closing-bracket))
(if (>= gnus-tmp-level (length gnus-thread-indent-array))
(gnus-make-thread-indent-array
(max (* 2 (length gnus-thread-indent-array))
@@ -5528,7 +5569,7 @@ or a straight list of headers."
(setq gnus-tmp-thread thread)
(put-text-property
(point)
- (progn (eval gnus-summary-line-format-spec) (point))
+ (progn (eval gnus-summary-line-format-spec t) (point))
'gnus-number number)
(when gnus-visual-p
(forward-line -1)
@@ -5632,22 +5673,32 @@ or a straight list of headers."
"Fetch headers of ARTICLES."
(gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
(prog1
- (if (eq 'nov
- (setq gnus-headers-retrieved-by
- (gnus-retrieve-headers
- articles gnus-newsgroup-name
- (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 force-new dependencies gnus-newsgroup-name t)
- (gnus-get-newsgroup-headers dependencies force-new))
- (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
+ (pcase (setq gnus-headers-retrieved-by
+ (gnus-retrieve-headers
+ articles gnus-newsgroup-name
+ (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))))
+ ('nov
+ (gnus-get-newsgroup-headers-xover
+ articles force-new dependencies gnus-newsgroup-name t))
+ ('headers
+ (gnus-get-newsgroup-headers dependencies force-new))
+ ((pred listp)
+ (let ((dependencies
+ (or dependencies
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-dependencies))))
+ (delq nil (mapcar (lambda (header)
+ (gnus-dependencies-add-header
+ header dependencies force-new))
+ gnus-headers-retrieved-by)))))
+ (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@@ -5663,8 +5714,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
articles fetched-articles cached)
(unless (gnus-check-server
- (set (make-local-variable 'gnus-current-select-method)
- (gnus-find-method-for-group group)))
+ (setq-local gnus-current-select-method
+ (gnus-find-method-for-group group)))
(error "Couldn't open server"))
(or (and entry (not (eq (car entry) t))) ; Either it's active...
@@ -5937,19 +5988,22 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(initial (gnus-parameter-large-newsgroup-initial
gnus-newsgroup-name))
(default (if only-read-p
- (or initial gnus-large-newsgroup)
+ (if (eq initial 'all)
+ nil
+ (or initial gnus-large-newsgroup))
number))
(input
(read-string
(if only-read-p
- (format
- "How many articles from %s (available %d, default %d): "
- (gnus-group-real-name gnus-newsgroup-name)
- number default)
- (format
- "How many articles from %s (%d default): "
- (gnus-group-real-name gnus-newsgroup-name)
- default))
+ (format-prompt
+ "How many articles from %s (available %d)"
+ default
+ (gnus-group-real-name gnus-newsgroup-name)
+ number)
+ (format-prompt
+ "How many articles from %s"
+ default
+ (gnus-group-real-name gnus-newsgroup-name)))
nil
nil
(number-to-string default))))
@@ -6224,7 +6278,7 @@ If WHERE is `summary', the summary mode line format will be used."
""))
bufname-length max-len
gnus-tmp-header) ;; passed as argument to any user-format-funcs
- (setq mode-string (eval mformat))
+ (setq mode-string (eval mformat t))
(setq bufname-length (if (string-match "%b" mode-string)
(- (length
(buffer-name
@@ -6241,11 +6295,13 @@ If WHERE is `summary', the summary mode line format will be used."
;; We might have to chop a bit of the string off...
(when (> (length mode-string) max-len)
(setq mode-string
- (concat (truncate-string-to-width mode-string (- max-len 3))
- "...")))))
+ (truncate-string-to-width
+ mode-string (- max-len 3) nil nil t)))))
;; Update the mode line.
(setq mode-line-buffer-identification
- (gnus-mode-line-buffer-identification (list mode-string)))
+ (gnus-mode-line-buffer-identification
+ (list (propertize mode-string
+ 'face 'mode-line-buffer-id))))
(set-buffer-modified-p t))))
(defun gnus-create-xref-hashtb (from-newsgroup headers unreads)
@@ -6317,9 +6373,9 @@ The resulting hash table is returned, or nil if no Xrefs were found."
;; First peel off all invalid article numbers.
(when active
(let ((ids articles)
- id first)
+ id) ;; first
(while (setq id (pop ids))
- (when (and first (> id (cdr active)))
+ (when nil ;; (and first (> id (cdr active)))
;; We'll end up in this situation in one particular
;; obscure situation. If you re-scan a group and get
;; a new article that is cross-posted to a different
@@ -6401,12 +6457,11 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(gnus-group-update-group group t))))))
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
- (let ((cur nntp-server-buffer)
- (dependencies
+ (let ((dependencies
(or dependencies
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-dependencies)))
- headers id end ref number
+ headers
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(save-current-buffer (condition-case nil
@@ -6414,146 +6469,15 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(error))
gnus-newsgroup-ignored-charsets)))
(with-current-buffer nntp-server-buffer
- ;; Translate all TAB characters into SPACE characters.
- (subst-char-in-region (point-min) (point-max) ?\t ? t)
- (subst-char-in-region (point-min) (point-max) ?\r ? t)
- (ietf-drums-unfold-fws)
(gnus-run-hooks 'gnus-parse-headers-hook)
- (let ((case-fold-search t)
- in-reply-to header p lines chars)
+ (let ((nnmail-extra-headers gnus-extra-headers)
+ header)
(goto-char (point-min))
- ;; Search to the beginning of the next header. Error messages
- ;; do not begin with 2 or 3.
- (while (re-search-forward "^[23][0-9]+ " nil t)
- (setq id nil
- ref nil)
- ;; This implementation of this function, with nine
- ;; search-forwards instead of the one re-search-forward and
- ;; a case (which basically was the old function) is actually
- ;; about twice as fast, even though it looks messier. You
- ;; can't have everything, I guess. Speed and elegance
- ;; doesn't always go hand in hand.
- (setq
- header
- (make-full-mail-header
- ;; Number.
- (prog1
- (setq number (read cur))
- (end-of-line)
- (setq p (point))
- (narrow-to-region (point)
- (or (and (search-forward "\n.\n" nil t)
- (- (point) 2))
- (point))))
- ;; Subject.
- (progn
- (goto-char p)
- (if (search-forward "\nsubject:" nil t)
- (funcall gnus-decode-encoded-word-function
- (nnheader-header-value))
- "(none)"))
- ;; From.
- (progn
- (goto-char p)
- (if (search-forward "\nfrom:" nil t)
- (funcall gnus-decode-encoded-address-function
- (nnheader-header-value))
- "(nobody)"))
- ;; Date.
- (progn
- (goto-char p)
- (if (search-forward "\ndate:" nil t)
- (nnheader-header-value) ""))
- ;; Message-ID.
- (progn
- (goto-char p)
- (setq id (if (re-search-forward
- "^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
- ;; We do it this way to make sure the Message-ID
- ;; is (somewhat) syntactically valid.
- (buffer-substring (match-beginning 1)
- (match-end 1))
- ;; If there was no message-id, we just fake one
- ;; to make subsequent routines simpler.
- (nnheader-generate-fake-message-id number))))
- ;; References.
- (progn
- (goto-char p)
- (if (search-forward "\nreferences:" nil t)
- (progn
- (setq end (point))
- (prog1
- (nnheader-header-value)
- (setq ref
- (buffer-substring
- (progn
- (end-of-line)
- (search-backward ">" end t)
- (1+ (point)))
- (progn
- (search-backward "<" end t)
- (point))))))
- ;; Get the references from the in-reply-to header if there
- ;; were no references and the in-reply-to header looks
- ;; promising.
- (if (and (search-forward "\nin-reply-to:" nil t)
- (setq in-reply-to (nnheader-header-value))
- (string-match "<[^>]+>" in-reply-to))
- (let (ref2)
- (setq ref (substring in-reply-to (match-beginning 0)
- (match-end 0)))
- (while (string-match "<[^>]+>" in-reply-to (match-end 0))
- (setq ref2 (substring in-reply-to (match-beginning 0)
- (match-end 0)))
- (when (> (length ref2) (length ref))
- (setq ref ref2)))
- ref)
- (setq ref nil))))
- ;; Chars.
- (progn
- (goto-char p)
- (if (search-forward "\nchars: " nil t)
- (if (numberp (setq chars (ignore-errors (read cur))))
- chars -1)
- -1))
- ;; Lines.
- (progn
- (goto-char p)
- (if (search-forward "\nlines: " nil t)
- (if (numberp (setq lines (ignore-errors (read cur))))
- lines -1)
- -1))
- ;; Xref.
- (progn
- (goto-char p)
- (and (search-forward "\nxref:" nil t)
- (nnheader-header-value)))
- ;; Extra.
- (when gnus-extra-headers
- (let ((extra gnus-extra-headers)
- out)
- (while extra
- (goto-char p)
- (when (search-forward
- (concat "\n" (symbol-name (car extra)) ":") nil t)
- (push (cons (car extra) (nnheader-header-value))
- out))
- (pop extra))
- out))))
- (when (equal id ref)
- (setq ref nil))
-
- (when gnus-alter-header-function
- (funcall gnus-alter-header-function header)
- (setq id (mail-header-id header)
- ref (gnus-parent-id (mail-header-references header))))
-
+ (while (setq header (nnheader-parse-head))
(when (setq header
(gnus-dependencies-add-header
header dependencies force-new))
- (push header headers))
- (goto-char (point-max))
- (widen))
+ (push header headers)))
(nreverse headers)))))
;; Goes through the xover lines and returns a list of vectors
@@ -6760,19 +6684,19 @@ executed with point over the summary line of the articles."
(defun gnus-summary-save-process-mark ()
"Push the current set of process marked articles on the stack."
- (interactive)
+ (interactive nil gnus-summary-mode)
(push (copy-sequence gnus-newsgroup-processable)
gnus-newsgroup-process-stack))
(defun gnus-summary-kill-process-mark ()
"Push the current set of process marked articles on the stack and unmark."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-save-process-mark)
(gnus-summary-unmark-all-processable))
(defun gnus-summary-yank-process-mark ()
"Pop the last process mark state off the stack and restore it."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless gnus-newsgroup-process-stack
(error "Empty mark stack"))
(gnus-summary-process-mark-set (pop gnus-newsgroup-process-stack)))
@@ -6907,7 +6831,7 @@ articles with that subject. If BACKWARD, search backward instead."
(defun gnus-recenter (&optional n)
"Center point in window and redisplay frame.
Also do horizontal recentering."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when (and gnus-auto-center-summary
(not (eq gnus-auto-center-summary 'vertical)))
(gnus-horizontal-recenter))
@@ -6941,7 +6865,7 @@ If `gnus-auto-center-summary' is nil, or the article buffer isn't
displayed, no centering will be performed."
;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
- (interactive)
+ (interactive nil gnus-summary-mode)
;; The user has to want it.
(when gnus-auto-center-summary
(let* ((top (cond ((< (window-height) 4) 0)
@@ -7118,7 +7042,7 @@ displayed, no centering will be performed."
"Reconfigure windows to show the article buffer.
If `gnus-widen-article-window' is set, show only the article
buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(if (not (gnus-buffer-live-p gnus-article-buffer))
(error "There is no article buffer for this summary buffer")
(or (get-buffer-window gnus-article-buffer)
@@ -7141,7 +7065,7 @@ buffer."
(defun gnus-summary-universal-argument (arg)
"Perform any operation on all articles that are process/prefixed."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((articles (gnus-summary-work-articles arg))
func article)
(if (eq
@@ -7162,7 +7086,7 @@ buffer."
(gnus-summary-position-point))
(define-obsolete-function-alias
- 'gnus-summary-toggle-truncation #'toggle-truncate-lines "26.1")
+ 'gnus-summary-toggle-truncation #'toggle-truncate-lines "26.1")
(defun gnus-summary-find-for-reselect ()
"Return the number of an article to stay on across a reselect.
@@ -7184,7 +7108,7 @@ insertion from another group. If there's no such then return a dummy 0."
(defun gnus-summary-reselect-current-group (&optional all rescan)
"Exit and then reselect the current newsgroup.
The prefix argument ALL means to select all articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when (gnus-ephemeral-group-p gnus-newsgroup-name)
(error "Ephemeral groups can't be reselected"))
(let ((current-subject (gnus-summary-find-for-reselect))
@@ -7202,7 +7126,7 @@ 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")
+ (interactive "P" gnus-summary-mode)
(let ((config gnus-current-window-configuration))
(gnus-summary-reselect-current-group all t)
(gnus-configure-windows config)
@@ -7255,11 +7179,26 @@ The prefix argument ALL means to select all articles."
(setq info (copy-sequence (gnus-get-info group))
info (delq (gnus-info-params info) info))))))))))
+(defun gnus-summary-make-group-from-search ()
+ "Make a persistent group from the current ephemeral search group."
+ (interactive nil gnus-summary-mode)
+ (if (not (gnus-nnselect-group-p gnus-newsgroup-name))
+ (gnus-message 3 "%s is not a search group" gnus-newsgroup-name)
+ (let ((name (gnus-read-group "Group name: ")))
+ (with-current-buffer gnus-group-buffer
+ (gnus-group-make-group
+ name
+ (list 'nnselect "nnselect")
+ nil
+ (list (cons 'nnselect-specs
+ (gnus-group-get-parameter gnus-newsgroup-name
+ 'nnselect-specs t))))))))
+
(defun gnus-summary-save-newsrc (&optional force)
"Save the current number of read/marked articles in the dribble buffer.
The dribble buffer will then be saved.
If FORCE (the prefix), also save the .newsrc file(s)."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-update-info t)
(if force
(gnus-save-newsrc-file)
@@ -7271,7 +7210,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(defun gnus-summary-exit (&optional temporary leave-hidden)
"Exit reading current newsgroup, and then return to group selection mode.
`gnus-exit-group-hook' is called with no arguments if that value is non-nil."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-set-global-variables)
(when (gnus-buffer-live-p gnus-article-buffer)
(with-current-buffer gnus-article-buffer
@@ -7310,7 +7249,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(when gnus-use-cache
(gnus-cache-write-active))
;; Remove entries for this group.
- (nnmail-purge-split-history (gnus-group-real-name group))
+ (nnmail-purge-split-history group)
;; Make all changes in this group permanent.
(unless quit-config
(gnus-run-hooks 'gnus-exit-group-hook)
@@ -7331,6 +7270,8 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(gnus-group-next-unread-group 1))
(setq group-point (point))
(gnus-article-stop-animations)
+ (unless leave-hidden
+ (gnus-configure-windows 'group 'force))
(if temporary
nil ;Nothing to do.
(set-buffer buf)
@@ -7350,8 +7291,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(if quit-config
(gnus-handle-ephemeral-exit quit-config)
(goto-char group-point)
- (unless leave-hidden
- (gnus-configure-windows 'group 'force))
;; If gnus-group-buffer is already displayed, make sure we also move
;; the cursor in the window that displays it.
(let ((win (get-buffer-window (current-buffer) 0)))
@@ -7377,7 +7316,7 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update)
(defun gnus-summary-exit-no-update (&optional no-questions)
"Quit reading current newsgroup without updating read article info."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((group gnus-newsgroup-name)
(gnus-group-is-exiting-p t)
(gnus-group-is-exiting-without-update-p t)
@@ -7531,7 +7470,7 @@ The state which existed when entering the ephemeral is reset."
(defun gnus-summary-wake-up-the-dead (&rest _)
"Wake up the dead summary buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-dead-summary-mode -1)
(let ((name (buffer-name)))
(when (string-match "Dead " name)
@@ -7544,12 +7483,12 @@ The state which existed when entering the ephemeral is reset."
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-summary-describe-group (&optional force)
"Describe the current newsgroup."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-group-describe-group force gnus-newsgroup-name))
(defun gnus-summary-describe-briefly ()
"Describe summary mode commands briefly."
- (interactive)
+ (interactive nil gnus-summary-mode)
(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.
@@ -7559,7 +7498,7 @@ The state which existed when entering the ephemeral is reset."
If prefix argument NO-ARTICLE is non-nil, no article is selected
initially. If TARGET-GROUP, go to this group. If BACKWARD, go to
previous group instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
;; Stop pre-fetching.
(gnus-async-halt-prefetch)
(let ((current-group gnus-newsgroup-name)
@@ -7605,7 +7544,7 @@ previous group instead."
(defun gnus-summary-prev-group (&optional no-article)
"Exit current newsgroup and then select previous unread newsgroup.
If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-next-group no-article nil t))
;; Walking around summary lines.
@@ -7616,7 +7555,7 @@ 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 as well as unread.
Returns the article selected or nil if there are no matching articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(cond
;; Empty summary.
((null gnus-newsgroup-data)
@@ -7668,7 +7607,7 @@ If N is negative, go to the previous N'th subject line.
If UNREAD is non-nil, only unread articles are selected.
The difference between N and the actual number of steps taken is
returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(let ((backward (< n 0))
(n (abs n)))
(while (and (> n 0)
@@ -7687,18 +7626,18 @@ returned."
(defun gnus-summary-next-unread-subject (n)
"Go to next N'th unread summary line."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-next-subject n t))
(defun gnus-summary-prev-subject (n &optional unread)
"Go to previous N'th summary line.
If optional argument UNREAD is non-nil, only unread article is selected."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-next-subject (- n) unread))
(defun gnus-summary-prev-unread-subject (n)
"Go to previous N'th unread summary line."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-next-subject (- n) t))
(defun gnus-summary-goto-subjects (articles)
@@ -7712,7 +7651,7 @@ If optional argument UNREAD is non-nil, only unread article is selected."
(defun gnus-summary-goto-subject (article &optional force silent)
"Go to the subject line of ARTICLE.
If FORCE, also allow jumping to articles not currently shown."
- (interactive "nArticle number: ")
+ (interactive "nArticle number: " gnus-summary-mode)
(unless (numberp article)
(error "Article %s is not a number" article))
(let ((b (point))
@@ -7742,7 +7681,7 @@ If FORCE, also allow jumping to articles not currently shown."
(defun gnus-summary-expand-window (&optional arg)
"Make the summary buffer take up the entire Emacs frame.
Given a prefix, will force an `article' buffer configuration."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(if arg
(gnus-configure-windows 'article 'force)
(gnus-configure-windows 'summary 'force)))
@@ -7825,7 +7764,7 @@ be displayed."
(defun gnus-summary-force-verify-and-decrypt ()
"Display buttons for signed/encrypted parts and verify/decrypt them."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((mm-verify-option 'known)
(mm-decrypt-option 'known)
(gnus-article-emulate-mime t)
@@ -7839,7 +7778,7 @@ be displayed."
If UNREAD, only unread articles are selected.
If SUBJECT, only articles with SUBJECT are selected.
If BACKWARD, the previous article is selected instead of the next."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
;; Make sure we are in the summary buffer.
(unless (derived-mode-p 'gnus-summary-mode)
(set-buffer gnus-summary-buffer))
@@ -7937,7 +7876,7 @@ If BACKWARD, the previous article is selected instead of the next."
(switch-to-buffer gnus-group-buffer)
(when group
(gnus-group-jump-to-group group))
- (eval (cadr (assq key keystrokes)))
+ (eval (cadr (assq key keystrokes)) t)
(setq group (gnus-group-group-name))
(switch-to-buffer obuf))
(setq ended nil))
@@ -7951,7 +7890,7 @@ If BACKWARD, the previous article is selected instead of the next."
(defun gnus-summary-next-unread-article ()
"Select unread article after current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-next-article
(or (not (eq gnus-summary-goto-unread 'never))
(gnus-summary-last-article-p (gnus-summary-article-number)))
@@ -7961,12 +7900,12 @@ If BACKWARD, the previous article is selected instead of the next."
(defun gnus-summary-prev-article (&optional unread subject)
"Select the article before the current one.
If UNREAD is non-nil, only unread articles are selected."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-next-article unread subject t))
(defun gnus-summary-prev-unread-article ()
"Select unread article before current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-prev-article
(or (not (eq gnus-summary-goto-unread 'never))
(gnus-summary-first-article-p (gnus-summary-article-number)))
@@ -7987,7 +7926,7 @@ article.
If STOP is non-nil, just stop when reaching the end of the message.
Also see the variable `gnus-article-skip-boring'."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-set-global-variables)
(let ((article (gnus-summary-article-number))
(article-window (get-buffer-window gnus-article-buffer t))
@@ -8016,7 +7955,8 @@ Also see the variable `gnus-article-skip-boring'."
(gnus-message 3 "End of message"))
(circular
(gnus-summary-beginning-of-article))
- (lines
+ ((or lines
+ (not gnus-paging-select-next))
(gnus-message 3 "End of message"))
((null lines)
(if (and (eq gnus-summary-goto-unread 'never)
@@ -8031,7 +7971,7 @@ Also see the variable `gnus-article-skip-boring'."
Argument LINES specifies lines to be scrolled down.
If MOVE, move to the previous unread article if point is at
the beginning of the buffer."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((article (gnus-summary-article-number))
(article-window (get-buffer-window gnus-article-buffer t))
endp)
@@ -8047,7 +7987,8 @@ the beginning of the buffer."
(gnus-eval-in-buffer-window gnus-article-buffer
(setq endp (gnus-article-prev-page lines)))
(when (and move endp)
- (cond (lines
+ (cond ((or lines
+ (not gnus-paging-select-next))
(gnus-message 3 "Beginning of message"))
((null lines)
(if (and (eq gnus-summary-goto-unread 'never)
@@ -8060,14 +8001,14 @@ the beginning of the buffer."
"Show previous page of selected article.
Argument LINES specifies lines to be scrolled down.
If at the beginning of the article, go to the next article."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-prev-page lines t))
(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).
If no article is selected, then the current article will be selected first."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-configure-windows 'article)
(gnus-summary-show-thread)
(when (eq (gnus-summary-select-article nil nil 'pseudo) 'old)
@@ -8084,33 +8025,33 @@ If no article is selected, then the current article will be selected first."
"Scroll down (or up) one line current article.
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")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-scroll-up (- lines)))
(defun gnus-summary-next-same-subject ()
"Select next article which has the same subject as current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-next-article nil (gnus-summary-article-subject)))
(defun gnus-summary-prev-same-subject ()
"Select previous article which has the same subject as current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-prev-article nil (gnus-summary-article-subject)))
(defun gnus-summary-next-unread-same-subject ()
"Select next unread article which has the same subject as current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-next-article t (gnus-summary-article-subject)))
(defun gnus-summary-prev-unread-same-subject ()
"Select previous unread article which has the same subject as current one."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-prev-article t (gnus-summary-article-subject)))
(defun gnus-summary-first-unread-article ()
"Select the first unread article.
Return nil if there are no unread articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(when (gnus-summary-first-subject t)
(gnus-summary-show-thread)
@@ -8121,7 +8062,7 @@ Return nil if there are no unread articles."
(defun gnus-summary-first-unread-subject ()
"Place the point on the subject line of the first unread article.
Return nil if there are no unread articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(when (gnus-summary-first-subject t)
(gnus-summary-show-thread)
@@ -8130,7 +8071,7 @@ Return nil if there are no unread articles."
(defun gnus-summary-next-unseen-article (&optional backward)
"Select the next unseen article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((article (gnus-summary-article-number))
(articles (gnus-data-find-list article (gnus-data-list backward))))
(when (or (not gnus-summary-check-current)
@@ -8151,13 +8092,13 @@ Return nil if there are no unread articles."
(defun gnus-summary-prev-unseen-article ()
"Select the previous unseen article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-next-unseen-article t))
(defun gnus-summary-first-unseen-subject ()
"Place the point on the subject line of the first unseen article.
Return nil if there are no unseen articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(when (gnus-summary-first-subject nil nil t)
(gnus-summary-show-thread)
@@ -8166,9 +8107,9 @@ Return nil if there are no unseen articles."
(defun gnus-summary-first-unseen-or-unread-subject ()
"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
+If all articles have been seen, on the subject line of the first unread
article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(unless (when (gnus-summary-first-subject nil nil t)
(gnus-summary-show-thread)
@@ -8181,7 +8122,7 @@ article."
(defun gnus-summary-first-article ()
"Select the first article.
Return nil if there are no articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(when (gnus-summary-first-subject)
(gnus-summary-show-thread)
@@ -8193,7 +8134,7 @@ Return nil if there are no articles."
"Select the unread article with the highest score.
If given a prefix argument, select the next unread article that has a
score higher than the default score."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((article (if arg
(gnus-summary-better-unread-subject)
(gnus-summary-best-unread-subject))))
@@ -8203,7 +8144,7 @@ score higher than the default score."
(defun gnus-summary-best-unread-subject ()
"Select the unread subject with the highest score."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((best -1000000)
(data gnus-newsgroup-data)
article score)
@@ -8222,7 +8163,7 @@ score higher than the default score."
(defun gnus-summary-better-unread-subject ()
"Select the first unread subject that has a score over the default score."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((data gnus-newsgroup-data)
article)
(while (and (setq article (gnus-data-number (car data)))
@@ -8248,11 +8189,10 @@ 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
- (gnus-completing-read
- "Article number or Message-ID"
- (mapcar #'int-to-string gnus-newsgroup-limit))
- current-prefix-arg
- t))
+ (gnus-completing-read "Article number or Message-ID"
+ (mapcar #'int-to-string gnus-newsgroup-limit))
+ current-prefix-arg t)
+ gnus-summary-mode)
(prog1
(if (and (stringp article)
(string-match "@\\|%40" article))
@@ -8266,7 +8206,7 @@ is a number, it is the line the article is to be displayed on."
(defun gnus-summary-goto-last-article ()
"Go to the previously read article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(when gnus-last-article
(gnus-summary-goto-article gnus-last-article nil t))
@@ -8275,7 +8215,7 @@ is a number, it is the line the article is to be displayed on."
(defun gnus-summary-pop-article (number)
"Pop one article off the history and go to the previous.
NUMBER articles will be popped off."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(let (to)
(setq gnus-newsgroup-history
(cdr (setq to (nthcdr number gnus-newsgroup-history))))
@@ -8289,7 +8229,7 @@ NUMBER articles will be popped off."
(defun gnus-summary-limit-to-articles (n)
"Limit the summary buffer to the next N articles.
If not given a prefix, use the process marked articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(prog1
(let ((articles (gnus-summary-work-articles n)))
(setq gnus-newsgroup-processable nil)
@@ -8299,7 +8239,7 @@ If not given a prefix, use the process marked articles instead."
(defun gnus-summary-pop-limit (&optional total)
"Restore the previous limit.
If given a prefix, remove all limits."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when total
(setq gnus-newsgroup-limits
(list (mapcar #'mail-header-number gnus-newsgroup-headers))))
@@ -8313,10 +8253,11 @@ If given a prefix, remove all limits."
"Limit the summary buffer to articles that have subjects that match a regexp.
If NOT-MATCHING, excluding articles that have subjects that match a regexp."
(interactive
- (list (read-string (if current-prefix-arg
- "Exclude subject (regexp): "
- "Limit to subject (regexp): "))
- nil current-prefix-arg))
+ (list
+ (read-string
+ (if current-prefix-arg "Exclude subject (regexp): " "Limit to subject (regexp): "))
+ nil current-prefix-arg)
+ gnus-summary-mode)
(unless header
(setq header "subject"))
(when (not (equal "" subject))
@@ -8324,7 +8265,7 @@ If NOT-MATCHING, excluding articles that have subjects that match a regexp."
(let ((articles (gnus-summary-find-matching
(or header "subject") subject 'all nil nil
not-matching)))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" subject))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8333,18 +8274,25 @@ If NOT-MATCHING, excluding articles that have subjects that match a regexp."
"Limit the summary buffer to articles that have authors that match a regexp.
If NOT-MATCHING, excluding articles that have authors that match a regexp."
(interactive
- (list (let* ((header (gnus-summary-article-header))
- (default (and header (car (mail-header-parse-address
- (mail-header-from header))))))
- (read-string (concat (if current-prefix-arg
- "Exclude author (regexp"
- "Limit to author (regexp")
- (if default
- (concat ", default \"" default "\"): ")
- "): "))
- nil nil
- default))
- current-prefix-arg))
+ (list
+ (let*
+ ((header
+ (gnus-summary-article-header))
+ (default
+ (and header
+ (car
+ (mail-header-parse-address
+ (mail-header-from header))))))
+ (read-string
+ (concat
+ (if current-prefix-arg
+ "Exclude author (regexp" "Limit to author (regexp")
+ (if default
+ (concat ", default \"" default "\"): ")
+ "): "))
+ nil nil default))
+ current-prefix-arg)
+ gnus-summary-mode)
(gnus-summary-limit-to-subject from "from" not-matching))
(defun gnus-summary-limit-to-recipient (recipient &optional not-matching)
@@ -8356,9 +8304,12 @@ To and Cc headers are checked. You need to include them in
`nnmail-extra-headers'."
;; Unlike `rmail-summary-by-recipients', doesn't include From.
(interactive
- (list (read-string (format "%s recipient (regexp): "
- (if current-prefix-arg "Exclude" "Limit to")))
- current-prefix-arg))
+ (list
+ (read-string
+ (format "%s recipient (regexp): "
+ (if current-prefix-arg "Exclude" "Limit to")))
+ current-prefix-arg)
+ gnus-summary-mode)
(when (not (equal "" recipient))
(prog1 (let* ((to
(if (memq 'To nnmail-extra-headers)
@@ -8385,7 +8336,7 @@ To and Cc headers are checked. You need to include them in
(and (memq a to) a))
cc)
(nconc to cc))))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" recipient))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8398,9 +8349,12 @@ If NOT-MATCHING, exclude ADDRESS.
To, Cc and From headers are checked. You need to include `To' and `Cc'
in `nnmail-extra-headers'."
(interactive
- (list (read-string (format "%s address (regexp): "
- (if current-prefix-arg "Exclude" "Limit to")))
- current-prefix-arg))
+ (list
+ (read-string
+ (format "%s address (regexp): "
+ (if current-prefix-arg "Exclude" "Limit to")))
+ current-prefix-arg)
+ gnus-summary-mode)
(when (not (equal "" address))
(prog1 (let* ((to
(if (memq 'To nnmail-extra-headers)
@@ -8438,7 +8392,7 @@ in `nnmail-extra-headers'."
(nconc (if (eq to t) nil to)
(if (eq cc t) nil cc)
from))))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" address))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
@@ -8487,7 +8441,8 @@ articles that are younger than AGE days."
(setq days (* days -1))))
(message "Please enter a number.")
(sleep-for 1)))
- (list days younger)))
+ (list days younger))
+ gnus-summary-mode)
(prog1
(let ((data gnus-newsgroup-data)
(cutoff (days-to-time age))
@@ -8511,30 +8466,31 @@ articles that are younger than AGE days."
(let ((header
(intern
(gnus-completing-read
- (if current-prefix-arg
- "Exclude extra header"
- "Limit extra header")
+ (if current-prefix-arg "Exclude extra header" "Limit extra header")
(mapcar #'symbol-name gnus-extra-headers)
t nil nil
- (symbol-name (car gnus-extra-headers))))))
+ (symbol-name
+ (car gnus-extra-headers))))))
(list header
- (read-string (format "%s header %s (regexp): "
- (if current-prefix-arg "Exclude" "Limit to")
- header))
- current-prefix-arg)))
+ (read-string
+ (format "%s header %s (regexp): "
+ (if current-prefix-arg "Exclude" "Limit to")
+ header))
+ current-prefix-arg))
+ gnus-summary-mode)
(when (not (equal "" regexp))
(prog1
(let ((articles (gnus-summary-find-matching
(cons 'extra header) regexp 'all nil nil
not-matching)))
- (unless articles
+ (unless (or articles not-matching)
(error "Found no matches for \"%s\"" regexp))
(gnus-summary-limit articles))
(gnus-summary-position-point))))
(defun gnus-summary-limit-to-display-predicate ()
"Limit the summary buffer to the predicated in the `display' group parameter."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless gnus-newsgroup-display
(error "There is no `display' group parameter"))
(let (articles)
@@ -8547,7 +8503,7 @@ articles that are younger than AGE days."
(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."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(if all
(gnus-summary-limit-to-marks (char-to-string gnus-unread-mark))
(gnus-summary-limit-to-marks
@@ -8563,7 +8519,7 @@ If ALL is non-nil, limit strictly to unread articles."
(defun gnus-summary-limit-to-headers (match &optional reverse)
"Limit the summary buffer to articles that have headers that match MATCH.
If REVERSE (the prefix), limit to articles that don't match."
- (interactive "sMatch headers (regexp): \nP")
+ (interactive "sMatch headers (regexp): \nP" gnus-summary-mode)
(gnus-summary-limit-to-bodies match reverse t))
(declare-function article-goto-body "gnus-art" ())
@@ -8571,7 +8527,7 @@ If REVERSE (the prefix), limit to articles that don't match."
(defun gnus-summary-limit-to-bodies (match &optional reverse headersp)
"Limit the summary buffer to articles that have bodies that match MATCH.
If REVERSE (the prefix), limit to articles that don't match."
- (interactive "sMatch body (regexp): \nP")
+ (interactive "sMatch body (regexp): \nP" gnus-summary-mode)
(let ((articles nil)
(gnus-select-article-hook nil) ;Disable hook.
(gnus-article-prepare-hook nil)
@@ -8604,7 +8560,7 @@ If REVERSE (the prefix), limit to articles that don't match."
(defun gnus-summary-limit-to-singletons (&optional threadsp)
"Limit the summary buffer to articles that aren't part on any thread.
If THREADSP (the prefix), limit to articles that are in threads."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((articles nil)
thread-articles
threads)
@@ -8628,11 +8584,12 @@ If THREADSP (the prefix), limit to articles that are in threads."
(defun gnus-summary-limit-to-replied (&optional unreplied)
"Limit the summary buffer to replied articles.
If UNREPLIED (the prefix), limit to unreplied articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(if unreplied
(gnus-summary-limit
- (gnus-set-difference gnus-newsgroup-articles
- gnus-newsgroup-replied))
+ (seq-difference gnus-newsgroup-articles
+ gnus-newsgroup-replied
+ #'eq))
(gnus-summary-limit gnus-newsgroup-replied))
(gnus-summary-position-point))
@@ -8641,7 +8598,7 @@ If UNREPLIED (the prefix), limit to unreplied articles."
If REVERSE, limit the summary buffer to articles that are marked
with MARKS. MARKS can either be a string of marks or a list of marks.
Returns how many articles were removed."
- (interactive "sMarks: ")
+ (interactive "sMarks: " gnus-summary-mode)
(gnus-summary-limit-to-marks marks t))
(defun gnus-summary-limit-to-marks (marks &optional reverse)
@@ -8650,7 +8607,7 @@ If REVERSE (the prefix), limit the summary buffer to articles that are
not marked with MARKS. MARKS can either be a string of marks or a
list of marks.
Returns how many articles were removed."
- (interactive "sMarks: \nP")
+ (interactive "sMarks: \nP" gnus-summary-mode)
(prog1
(let ((data gnus-newsgroup-data)
(marks (if (listp marks) marks
@@ -8669,10 +8626,13 @@ Returns how many articles were removed."
With a prefix argument, limit to articles with score at or below
SCORE."
- (interactive (list (string-to-number
- (read-string
- (format "Limit to articles with score of at %s: "
- (if current-prefix-arg "most" "least"))))))
+ (interactive
+ (list
+ (string-to-number
+ (read-string
+ (format "Limit to articles with score of at %s: "
+ (if current-prefix-arg "most" "least")))))
+ gnus-summary-mode)
(let ((data gnus-newsgroup-data)
(compare (if (or below current-prefix-arg) #'<= #'>=))
articles)
@@ -8688,7 +8648,7 @@ SCORE."
(defun gnus-summary-limit-to-unseen ()
"Limit to unseen articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(gnus-summary-limit gnus-newsgroup-unseen)
(gnus-summary-position-point)))
@@ -8698,7 +8658,12 @@ SCORE."
When called interactively, ID is the Message-ID of the current
article. If thread-only is non-nil limit the summary buffer to
these articles."
- (interactive (list (mail-header-id (gnus-summary-article-header))))
+ (interactive
+ (list
+ (mail-header-id
+ (gnus-summary-article-header))
+ current-prefix-arg)
+ gnus-summary-mode)
(let ((articles (gnus-articles-in-thread
(gnus-id-to-thread (gnus-root-id id))))
;;we REALLY want the whole thread---this prevents cut-threads
@@ -8724,8 +8689,11 @@ these articles."
(defun gnus-summary-limit-include-matching-articles (header regexp)
"Display all the hidden articles that have HEADERs that match REGEXP."
- (interactive (list (read-string "Match on header: ")
- (read-string "Regexp: ")))
+ (interactive
+ (list
+ (read-string "Match on header: ")
+ (read-string "Regexp: "))
+ gnus-summary-mode)
(let ((articles (gnus-find-matching-articles header regexp)))
(prog1
(gnus-summary-limit (nconc articles gnus-newsgroup-limit))
@@ -8733,7 +8701,7 @@ these articles."
(defun gnus-summary-insert-dormant-articles ()
"Insert all the dormant articles for this group into the current buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((gnus-verbose (max 6 gnus-verbose)))
(if (not gnus-newsgroup-dormant)
(gnus-message 3 "No dormant articles for this group")
@@ -8741,7 +8709,7 @@ these articles."
(defun gnus-summary-insert-ticked-articles ()
"Insert ticked articles for this group into the current buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((gnus-verbose (max 6 gnus-verbose)))
(if (not gnus-newsgroup-marked)
(gnus-message 3 "No ticked articles for this group")
@@ -8751,7 +8719,7 @@ these articles."
"Display all the hidden articles that are marked as dormant.
Note that this command only works on a subset of the articles currently
fetched for this group."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless gnus-newsgroup-dormant
(error "There are no dormant articles in this group"))
(prog1
@@ -8774,14 +8742,14 @@ fetched for this group."
(defun gnus-summary-limit-exclude-dormant ()
"Hide all dormant articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(prog1
(gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse)
(gnus-summary-position-point)))
(defun gnus-summary-limit-exclude-childless-dormant ()
"Hide all dormant articles that have no children."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((data (gnus-data-list t))
articles d children)
;; Find all articles that are either not dormant or have
@@ -8806,7 +8774,7 @@ fetched for this group."
(defun gnus-summary-limit-mark-excluded-as-read (&optional all)
"Mark all unread excluded articles as read.
If ALL, mark even excluded ticked and dormants as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(setq gnus-newsgroup-limit (sort gnus-newsgroup-limit #'<))
(let ((articles (gnus-sorted-ndifference
(sort
@@ -9045,7 +9013,7 @@ fetch-old-headers verbiage, and so on."
"Refer parent article N times.
If N is negative, go to ancestor -N instead.
The difference between N and the number of articles fetched is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(let ((skip 1)
error header ref)
(when (not (natnump n))
@@ -9087,7 +9055,7 @@ The difference between N and the number of articles fetched is returned."
(defun gnus-summary-refer-references ()
"Fetch all articles mentioned in the References header.
Return the number of articles fetched."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((ref (mail-header-references (gnus-summary-article-header)))
(current (gnus-summary-article-number))
(n 0))
@@ -9121,25 +9089,24 @@ Return the number of articles fetched."
result))
(defun gnus-summary-refer-thread (&optional limit)
- "Fetch all articles in the current thread. For backends
-that know how to search for threads (currently only 'nnimap)
-a non-numeric prefix arg will use nnir to search the entire
-server; without a prefix arg only the current group is
-searched. If the variable `gnus-refer-thread-use-nnir' is
-non-nil the prefix arg has the reverse meaning. If no
-backend-specific `request-thread' function is available fetch
-LIMIT (the numerical prefix) old headers. If LIMIT is
-non-numeric or nil fetch the number specified by the
-`gnus-refer-thread-limit' variable."
- (interactive "P")
+ "Fetch all articles in the current thread.
+For backends that know how to search for threads (currently only
+`nnimap') a non-numeric prefix arg will search the entire server;
+without a prefix arg only the current group is searched. If the
+variable `gnus-refer-thread-use-search' is non-nil the prefix arg
+has the reverse meaning. If no backend-specific `request-thread'
+function is available fetch LIMIT (the numerical prefix) old
+headers. If LIMIT is non-numeric or nil fetch the number
+specified by the `gnus-refer-thread-limit' variable."
+ (interactive "P" gnus-summary-mode)
(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)
- (gnus-refer-thread-use-nnir
+ (gnus-refer-thread-use-search
(if (and (not (null limit)) (listp limit))
- (not gnus-refer-thread-use-nnir) gnus-refer-thread-use-nnir))
+ (not gnus-refer-thread-use-search) gnus-refer-thread-use-search))
(new-headers
(if (gnus-check-backend-function
'request-thread gnus-newsgroup-name)
@@ -9186,7 +9153,7 @@ non-numeric or nil fetch the number specified by the
(defun gnus-summary-open-group-with-article (message-id)
"Open a group containing the article with the given MESSAGE-ID."
- (interactive "sMessage-ID: ")
+ (interactive "sMessage-ID: " gnus-summary-mode)
(require 'nndoc)
(with-temp-buffer
;; Prepare a dummy article
@@ -9221,7 +9188,7 @@ non-numeric or nil fetch the number specified by the
(defun gnus-summary-refer-article (message-id)
"Fetch an article specified by MESSAGE-ID."
- (interactive "sMessage-ID: ")
+ (interactive "sMessage-ID: " gnus-summary-mode)
(when (and (stringp message-id)
(not (zerop (length message-id))))
(setq message-id (replace-regexp-in-string " " "" message-id))
@@ -9280,9 +9247,9 @@ non-numeric or nil fetch the number specified by the
(dolist (method gnus-refer-article-method)
(push (if (eq 'current method)
gnus-current-select-method
- (if (eq 'nnir (car method))
+ (if (eq 'nnselect (car method))
(list
- 'nnir
+ 'nnselect
(or (cadr method)
(gnus-method-to-server gnus-current-select-method)))
method))
@@ -9294,12 +9261,12 @@ non-numeric or nil fetch the number specified by the
(defun gnus-summary-edit-parameters ()
"Edit the group parameters of the current group."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-group-edit-group gnus-newsgroup-name 'params))
(defun gnus-summary-customize-parameters ()
"Customize the group parameters of the current group."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-group-customize gnus-newsgroup-name))
(defun gnus-summary-enter-digest-group (&optional force)
@@ -9309,7 +9276,7 @@ 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")
+ (interactive "P" gnus-summary-mode)
(let ((conf gnus-current-window-configuration))
(save-window-excursion
(save-excursion
@@ -9394,7 +9361,7 @@ To control what happens when you exit the group, see the
This will allow you to read digests and other similar
documents as newsgroups.
Obeys the standard process/prefix convention."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let* ((ogroup gnus-newsgroup-name)
(params (append (gnus-info-params (gnus-get-info ogroup))
(list (cons 'to-group ogroup))))
@@ -9443,7 +9410,7 @@ Obeys the standard process/prefix convention."
(defun gnus-summary-button-forward (arg)
"Move point to the next field or button in the article.
With optional ARG, move across that many fields."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-select-article)
(gnus-configure-windows 'article)
(let ((win (or (gnus-get-buffer-window gnus-article-buffer t)
@@ -9457,7 +9424,7 @@ With optional ARG, move across that many fields."
(defun gnus-summary-button-backward (arg)
"Move point to the previous field or button in the article.
With optional ARG, move across that many fields."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-select-article)
(gnus-configure-windows 'article)
(let ((win (or (gnus-get-buffer-window gnus-article-buffer t)
@@ -9493,16 +9460,6 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'."
(push primary urls))
(delete-dups urls)))
-;; cf. `ediff-truncate-string-left', to become `string-truncate-left'
-;; in Emacs 28
-(defun gnus--string-truncate-left (string length)
- "Truncate STRING to LENGTH, replacing initial surplus with \"...\"."
- (let ((strlen (length string)))
- (if (<= strlen length)
- string
- (setq length (max 0 (- length 3)))
- (concat "..." (substring string (max 0 (- strlen 1 length)))))))
-
(defun gnus-shorten-url (url max)
"Return an excerpt from URL not exceeding MAX characters."
(if (<= (length url) max)
@@ -9512,7 +9469,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'."
(rest (concat (url-filename parsed)
(when-let ((target (url-target parsed)))
(concat "#" target)))))
- (concat host (gnus--string-truncate-left rest (- max (length host)))))))
+ (concat host (string-truncate-left rest (- max (length host)))))))
(defun gnus-summary-browse-url (&optional external)
"Scan the current article body for links, and offer to browse them.
@@ -9524,7 +9481,7 @@ If only one link is found, browse that directly, otherwise use
completion to select a link. The first link marked in the
article text with `gnus-collect-urls-primary-text' is the
default."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let (urls target)
(gnus-summary-select-article)
(gnus-with-article-buffer
@@ -9536,10 +9493,10 @@ default."
(cond ((= (length urls) 1)
(car urls))
((> (length urls) 1)
- (completing-read (format "URL to browse (default %s): "
- (gnus-shorten-url (car urls) 40))
- urls nil t nil nil
- (car urls)))))
+ (completing-read
+ (format-prompt "URL to browse"
+ (gnus-shorten-url (car urls) 40))
+ urls nil t nil nil (car urls)))))
(if target
(if external
(funcall browse-url-secondary-browser-function target)
@@ -9549,7 +9506,7 @@ default."
(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."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-select-article)
(gnus-configure-windows 'article)
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9559,14 +9516,14 @@ If REGEXP-P (the prefix) is non-nil, do regexp isearch."
(defun gnus-summary-repeat-search-article-forward ()
"Repeat the previous search forwards."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless gnus-last-search-regexp
(error "No previous search"))
(gnus-summary-search-article-forward gnus-last-search-regexp))
(defun gnus-summary-repeat-search-article-backward ()
"Repeat the previous search backwards."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless gnus-last-search-regexp
(error "No previous search"))
(gnus-summary-search-article-forward gnus-last-search-regexp t))
@@ -9575,13 +9532,13 @@ If REGEXP-P (the prefix) is non-nil, do regexp isearch."
"Search for an article containing REGEXP forward.
If BACKWARD, search backward instead."
(interactive
- (list (read-string
- (format "Search article %s (regexp%s): "
- (if current-prefix-arg "backward" "forward")
- (if gnus-last-search-regexp
- (concat ", default " gnus-last-search-regexp)
- "")))
- current-prefix-arg))
+ (list
+ (read-string
+ (format-prompt "Search article %s (regexp)"
+ gnus-last-search-regexp
+ (if current-prefix-arg "backward" "forward")))
+ current-prefix-arg)
+ gnus-summary-mode)
(if (string-equal regexp "")
(setq regexp (or gnus-last-search-regexp ""))
(setq gnus-last-search-regexp regexp)
@@ -9596,11 +9553,11 @@ If BACKWARD, search backward instead."
(defun gnus-summary-search-article-backward (regexp)
"Search for an article containing REGEXP backward."
(interactive
- (list (read-string
- (format "Search article backward (regexp%s): "
- (if gnus-last-search-regexp
- (concat ", default " gnus-last-search-regexp)
- "")))))
+ (list
+ (read-string
+ (format-prompt "Search article backward (regexp)"
+ gnus-last-search-regexp)))
+ gnus-summary-mode)
(gnus-summary-search-article-forward regexp 'backward))
(defun gnus-summary-search-article (regexp &optional backward)
@@ -9735,18 +9692,20 @@ that not match REGEXP on HEADER."
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))
- (gnus-completing-read
- "Header name"
- (mapcar #'symbol-name
- (append
- '(Number Subject From Lines Date
- Message-ID Xref References Body)
- gnus-extra-headers))
- 'require-match))
- (read-string "Regexp: ")
- (read-key-sequence "Command: ")
- current-prefix-arg))
+ (list
+ (let ((completion-ignore-case t))
+ (gnus-completing-read
+ "Header name"
+ (mapcar #'symbol-name
+ (append
+ '(Number Subject From Lines Date Message-ID
+ Xref References Body)
+ gnus-extra-headers))
+ 'require-match))
+ (read-string "Regexp: ")
+ (read-key-sequence "Command: ")
+ current-prefix-arg)
+ gnus-summary-mode)
(when (equal header "Body")
(setq header ""))
;; Hidden thread subtrees must be searched as well.
@@ -9770,7 +9729,7 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
(defun gnus-summary-beginning-of-article ()
"Scroll the article back to the beginning."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(gnus-configure-windows 'article)
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9781,7 +9740,7 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
(defun gnus-summary-end-of-article ()
"Scroll to the end of the article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(gnus-configure-windows 'article)
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9814,7 +9773,9 @@ If the optional first argument FILENAME is nil, send the image to the
printer. If FILENAME is a string, save the PostScript image in a file with
that name. If FILENAME is a number, prompt the user for the name of the file
to save in."
- (interactive (list (ps-print-preprint current-prefix-arg)))
+ (interactive
+ (list (ps-print-preprint current-prefix-arg))
+ gnus-summary-mode)
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-select-article nil nil 'pseudo article)
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -9854,7 +9815,7 @@ to save in."
"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)
+ (interactive nil gnus-summary-mode)
(let ((gnus-keep-backlog nil)
(gnus-use-cache nil)
(gnus-agent nil)
@@ -9881,7 +9842,7 @@ 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")
+ (interactive "P" gnus-summary-mode)
(cond
((numberp arg)
(gnus-summary-show-article t)
@@ -9957,14 +9918,14 @@ C-u g', show the raw article."
(defun gnus-summary-show-raw-article ()
"Show the raw article without any article massaging functions being run."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-show-article t))
(defun gnus-summary-verbose-headers (&optional arg)
"Toggle permanent full header display.
If ARG is a positive number, turn header display on.
If ARG is a negative number, turn header display off."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(setq gnus-show-all-headers
(cond ((or (not (numberp arg))
(zerop arg))
@@ -9983,7 +9944,7 @@ If ARG is a negative number, turn header display off."
"Show the headers if they are hidden, or hide them if they are shown.
If ARG is a positive number, show the entire header.
If ARG is a negative number, hide the unwanted header lines."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((window (and (gnus-buffer-live-p gnus-article-buffer)
(get-buffer-window gnus-article-buffer t))))
(with-current-buffer gnus-article-buffer
@@ -10029,14 +9990,14 @@ If ARG is a negative number, hide the unwanted header lines."
(defun gnus-summary-show-all-headers ()
"Make all header lines visible."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-toggle-header 1))
(defun gnus-summary-caesar-message (&optional arg)
"Caesar rotate the current article by 13.
With a non-numerical prefix, also rotate headers. A numerical
prefix specifies how many places to rotate each letter forward."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -10059,7 +10020,7 @@ invalid IDNA string (`xn--bar' is invalid).
You must have GNU Libidn (URL `https://www.gnu.org/software/libidn/')
installed for this command to work."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -10073,7 +10034,7 @@ installed for this command to work."
(defun gnus-summary-morse-message (&optional _arg)
"Morse decode the current article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -10094,7 +10055,7 @@ installed for this command to work."
(defun gnus-summary-stop-page-breaking ()
"Stop page breaking in the current article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-select-article)
(gnus-eval-in-buffer-window gnus-article-buffer
(widen)
@@ -10124,7 +10085,7 @@ newsgroup that you want to move to have to support the `request-move'
and `request-accept' functions.
ACTION can be either `move' (the default), `crosspost' or `copy'."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(unless action
(setq action 'move))
;; Check whether the source group supports the required functions.
@@ -10430,13 +10391,13 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
"Copy the current article to some other group.
Arguments have the same meanings as in `gnus-summary-move-article'."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-move-article n to-newsgroup select-method 'copy))
(defun gnus-summary-crosspost-article (&optional n)
"Crosspost the current article to some other group.
Arguments have the same meanings as in `gnus-summary-move-article'."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-move-article n nil nil 'crosspost))
(defcustom gnus-summary-respool-default-method nil
@@ -10480,7 +10441,8 @@ latter case, they will be copied into the relevant groups."
(t
(let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms)))
(cdr (assoc (gnus-completing-read "Server name" ms-alist t)
- ms-alist))))))))
+ ms-alist)))))))
+ gnus-summary-mode)
(unless method
(error "No method given for respooling"))
(if (assoc (symbol-name
@@ -10491,7 +10453,7 @@ latter case, they will be copied into the relevant groups."
(defun gnus-summary-import-article (file &optional edit)
"Import an arbitrary file into a mail newsgroup."
- (interactive "fImport file: \nP")
+ (interactive "fImport file: \nP" gnus-summary-mode)
(let ((group gnus-newsgroup-name)
atts lines group-art)
(unless (gnus-check-backend-function 'request-accept-article group)
@@ -10535,7 +10497,7 @@ latter case, they will be copied into the relevant groups."
(defun gnus-summary-create-article ()
"Create an article in a mail newsgroup."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((group gnus-newsgroup-name)
(now (current-time))
group-art)
@@ -10559,7 +10521,7 @@ latter case, they will be copied into the relevant groups."
(defun gnus-summary-article-posted-p ()
"Say whether the current (mail) article is available from news as well.
This will be the case if the article has both been mailed and posted."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((id (mail-header-references (gnus-summary-article-header)))
(gnus-override-method (car (gnus-refer-article-methods))))
(if (gnus-request-head id "")
@@ -10571,7 +10533,7 @@ This will be the case if the article has both been mailed and posted."
(defun gnus-summary-expire-articles (&optional now)
"Expire all articles that are marked as expirable in the current group."
- (interactive)
+ (interactive nil gnus-summary-mode)
(when (and (not gnus-group-is-exiting-without-update-p)
(gnus-check-backend-function
'request-expire-articles gnus-newsgroup-name))
@@ -10640,7 +10602,7 @@ This will be the case if the article has both been mailed and posted."
"Expunge all expirable articles in the current group.
This means that *all* articles that are marked as expirable will be
deleted forever, right now."
- (interactive)
+ (interactive nil gnus-summary-mode)
(or gnus-expert-user
(gnus-yes-or-no-p
"Are you really, really sure you want to delete all expirable messages? ")
@@ -10660,7 +10622,7 @@ delete these instead.
If `gnus-novice-user' is non-nil you will be asked for
confirmation before the articles are deleted."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(unless (gnus-check-backend-function 'request-expire-articles
gnus-newsgroup-name)
(error "The current newsgroup does not support article deletion"))
@@ -10699,6 +10661,8 @@ confirmation before the articles are deleted."
(gnus-set-mode-line 'summary)
not-deleted))
+(defvar message-options-set-recipient)
+
(defun gnus-summary-edit-article (&optional arg)
"Edit the current article.
This will have permanent effect only in mail groups.
@@ -10708,7 +10672,7 @@ If ARG is 2, edit the raw articles even in read-only groups.
If ARG is 3, edit the articles with the current handles.
Otherwise, allow editing of articles even in read-only
groups."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let (force raw current-handles)
(cond
((null arg))
@@ -10754,40 +10718,41 @@ groups."
(mime-to-mml current-handles))
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl)
- (set (make-local-variable 'mml-buffer-list) mbl1))
+ (setq-local mml-buffer-list mbl1))
(add-hook 'kill-buffer-hook #'mml-destroy-buffers t t))))
- `(lambda (no-highlight)
- (let ((mail-parse-charset ',gnus-newsgroup-charset)
- (message-options message-options)
- (message-options-set-recipient)
- (mail-parse-ignored-charsets
- ',gnus-newsgroup-ignored-charsets)
- (rfc2047-header-encoding-alist
- ',(let ((charset (gnus-group-name-charset
- (gnus-find-method-for-group
- gnus-newsgroup-name)
- gnus-newsgroup-name)))
- (append (list (cons "Newsgroups" charset)
- (cons "Followup-To" charset)
- (cons "Xref" charset))
- rfc2047-header-encoding-alist))))
- ,(if (not raw) '(progn
- (mml-to-mime)
- (mml-destroy-buffers)
- (remove-hook 'kill-buffer-hook
- #'mml-destroy-buffers t)
- (kill-local-variable 'mml-buffer-list)))
- (gnus-summary-edit-article-done
- ,(or (mail-header-references gnus-current-headers) "")
- ,(gnus-group-read-only-p)
- ,gnus-summary-buffer no-highlight))))))))
+ (let ((charset gnus-newsgroup-charset)
+ (ign-cs gnus-newsgroup-ignored-charsets)
+ (hea (let ((charset (gnus-group-name-charset
+ (gnus-find-method-for-group
+ gnus-newsgroup-name)
+ gnus-newsgroup-name)))
+ (append (list (cons "Newsgroups" charset)
+ (cons "Followup-To" charset)
+ (cons "Xref" charset))
+ rfc2047-header-encoding-alist)))
+ (gch (or (mail-header-references gnus-current-headers) ""))
+ (ro (gnus-group-read-only-p))
+ (buf gnus-summary-buffer))
+ (lambda (no-highlight)
+ (let ((mail-parse-charset charset)
+ (message-options message-options)
+ (message-options-set-recipient)
+ (mail-parse-ignored-charsets ign-cs)
+ (rfc2047-header-encoding-alist hea))
+ (unless raw
+ (mml-to-mime)
+ (mml-destroy-buffers)
+ (remove-hook 'kill-buffer-hook
+ #'mml-destroy-buffers t)
+ (kill-local-variable 'mml-buffer-list))
+ (gnus-summary-edit-article-done gch ro buf no-highlight)))))))))
(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit)
(defun gnus-summary-edit-article-done (&optional references read-only buffer
no-highlight)
"Make edits to the current article permanent."
- (interactive)
+ (interactive nil gnus-summary-mode)
(save-excursion
;; The buffer restriction contains the entire article if it exists.
(when (article-goto-body)
@@ -10836,6 +10801,7 @@ groups."
;; We only have to update this line.
(save-excursion
(save-restriction
+ (nnheader-ms-strip-cr)
(message-narrow-to-head)
(let ((head (buffer-substring-no-properties
(point-min) (point-max)))
@@ -10874,7 +10840,8 @@ groups."
(list
(progn
(message "%s" (concat (this-command-keys) "- "))
- (read-char))))
+ (read-char)))
+ gnus-summary-mode)
(message "")
(gnus-summary-edit-article)
(execute-kbd-macro (concat (this-command-keys) key))
@@ -10887,7 +10854,7 @@ groups."
(defun gnus-summary-respool-query (&optional silent trace)
"Query where the respool algorithm would put this article."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let (gnus-mark-article-hook)
(gnus-summary-select-article)
(with-current-buffer gnus-original-article-buffer
@@ -10917,7 +10884,7 @@ groups."
(defun gnus-summary-respool-trace ()
"Trace where the respool algorithm would put this article.
Display a buffer showing all fancy splitting patterns which matched."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-respool-query nil t))
;; Summary marking commands.
@@ -10926,7 +10893,7 @@ Display a buffer showing all fancy splitting patterns which matched."
"Mark articles which has the same subject as read, and then select the next.
If UNMARK is positive, remove any kind of mark.
If UNMARK is negative, tick articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when unmark
(setq unmark (prefix-numeric-value unmark)))
(let ((count
@@ -10944,7 +10911,7 @@ If UNMARK is negative, tick articles."
"Mark articles which has the same subject as read.
If UNMARK is positive, remove any kind of mark.
If UNMARK is negative, tick articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when unmark
(setq unmark (prefix-numeric-value unmark)))
(let ((count
@@ -10994,7 +10961,7 @@ If optional argument UNMARK is negative, mark articles as unread instead."
If N is negative, mark backward instead. If UNMARK is non-nil, remove
the process mark instead. The difference between N and the actual
number of articles marked is returned."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(if (and (null n) (and transient-mark-mode mark-active))
(gnus-uu-mark-region (region-beginning) (region-end) unmark)
(setq n (prefix-numeric-value n))
@@ -11002,10 +10969,14 @@ number of articles marked is returned."
(n (abs n)))
(while (and
(> n 0)
- (if unmark
- (gnus-summary-remove-process-mark
- (gnus-summary-article-number))
- (gnus-summary-set-process-mark (gnus-summary-article-number)))
+ (let ((article (gnus-summary-article-number)))
+ (if unmark
+ (gnus-summary-remove-process-mark article)
+ (if gnus-process-mark-toggle
+ (if (memq article gnus-newsgroup-processable)
+ (gnus-summary-remove-process-mark article)
+ (gnus-summary-set-process-mark article))
+ (gnus-summary-set-process-mark article))))
(zerop (gnus-summary-next-subject (if backward -1 1) nil t)))
(setq n (1- n)))
(when (/= 0 n)
@@ -11018,12 +10989,12 @@ number of articles marked is returned."
"Remove the process mark from the next N articles.
If N is negative, unmark backward instead. The difference between N and
the actual number of articles unmarked is returned."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-mark-as-processable n t))
(defun gnus-summary-unmark-all-processable ()
"Remove the process mark from all articles."
- (interactive)
+ (interactive nil gnus-summary-mode)
(save-excursion
(while gnus-newsgroup-processable
(gnus-summary-remove-process-mark (car gnus-newsgroup-processable))))
@@ -11047,20 +11018,21 @@ the actual number of articles unmarked is returned."
"Mark N articles forward as expirable.
If N is negative, mark backward instead. The difference between N and
the actual number of articles marked is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-expirable-mark))
(defun gnus-summary-mark-as-spam (n)
"Mark N articles forward as spam.
If N is negative, mark backward instead. The difference between N and
the actual number of articles marked is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-spam-mark))
(defun gnus-summary-mark-article-as-replied (article)
"Mark ARTICLE as replied to and update the summary line.
ARTICLE can also be a list of articles."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number))
+ gnus-summary-mode)
(let ((articles (if (listp article) article (list article))))
(dolist (article articles)
(unless (numberp article)
@@ -11082,7 +11054,8 @@ ARTICLE can also be a list of articles."
(defun gnus-summary-set-bookmark (article)
"Set a bookmark in current article."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number))
+ gnus-summary-mode)
(when (or (not (get-buffer gnus-article-buffer))
(not gnus-current-article)
(not gnus-article-current)
@@ -11106,7 +11079,8 @@ ARTICLE can also be a list of articles."
(defun gnus-summary-remove-bookmark (article)
"Remove the bookmark from the current article."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number))
+ gnus-summary-mode)
;; Remove old bookmark, if one exists.
(if (not (assq article gnus-newsgroup-bookmarks))
(gnus-message 6 "No bookmark in current article.")
@@ -11118,7 +11092,7 @@ ARTICLE can also be a list of articles."
"Mark N articles forward as dormant.
If N is negative, mark backward instead. The difference between N and
the actual number of articles marked is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-dormant-mark))
(defun gnus-summary-set-process-mark (article)
@@ -11153,7 +11127,7 @@ If N is negative, mark backwards instead. Mark with MARK, ?r by default.
The difference between N and the actual number of articles marked is
returned.
If NO-EXPIRE, auto-expiry will be inhibited."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-show-thread)
(let ((backward (< n 0))
(gnus-summary-goto-unread
@@ -11417,20 +11391,20 @@ If NO-EXPIRE, auto-expiry will be inhibited."
"Tick N articles forwards.
If N is negative, tick backwards instead.
The difference between N and the number of articles ticked is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-ticked-mark))
(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")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward (- n) gnus-ticked-mark))
(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.
Optional 2nd argument CLEAR-MARK remove any kinds of mark."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-mark-article article (if clear-mark gnus-unread-mark
gnus-ticked-mark)))
@@ -11439,14 +11413,14 @@ Optional 2nd argument CLEAR-MARK remove any kinds of mark."
If N is negative, mark backwards instead.
The difference between N and the actual number of articles marked is
returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-del-mark gnus-inhibit-user-auto-expire))
(defun gnus-summary-mark-as-read-backward (n)
"Mark the N articles as read backwards.
The difference between N and the actual number of articles marked is
returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward
(- n) gnus-del-mark gnus-inhibit-user-auto-expire))
@@ -11460,13 +11434,13 @@ MARK specifies a string to be inserted at the beginning of the line."
"Clear marks from N articles forward.
If N is negative, clear backward instead.
The difference between N and the number of marks cleared is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward n gnus-unread-mark))
(defun gnus-summary-clear-mark-backward (n)
"Clear marks from N articles backward.
The difference between N and the number of marks cleared is returned."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-mark-forward (- n) gnus-unread-mark))
(defun gnus-summary-mark-unread-as-read ()
@@ -11499,7 +11473,7 @@ The difference between N and the number of marks cleared is returned."
"Mark all unread articles between point and mark as read.
If given a prefix, mark all articles between point and mark as read,
even ticked and dormant ones."
- (interactive "r\nP")
+ (interactive "r\nP" gnus-summary-mode)
(save-excursion
(let (article)
(goto-char point)
@@ -11516,7 +11490,7 @@ even ticked and dormant ones."
(defun gnus-summary-mark-below (score mark)
"Mark articles with score less than SCORE with MARK."
- (interactive "P\ncMark: ")
+ (interactive "P\ncMark: " gnus-summary-mode)
(setq score (if score
(prefix-numeric-value score)
(or gnus-summary-default-score 0)))
@@ -11530,22 +11504,22 @@ even ticked and dormant ones."
(defun gnus-summary-kill-below (&optional score)
"Mark articles with score below SCORE as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-mark-below score gnus-killed-mark))
(defun gnus-summary-clear-above (&optional score)
"Clear all marks from articles with score above SCORE."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-mark-above score gnus-unread-mark))
(defun gnus-summary-tick-above (&optional score)
"Tick all articles with score above SCORE."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-mark-above score gnus-ticked-mark))
(defun gnus-summary-mark-above (score mark)
"Mark articles with score over SCORE with MARK."
- (interactive "P\ncMark: ")
+ (interactive "P\ncMark: " gnus-summary-mode)
(setq score (if score
(prefix-numeric-value score)
(or gnus-summary-default-score 0)))
@@ -11561,7 +11535,7 @@ even ticked and dormant ones."
(defalias 'gnus-summary-show-all-expunged 'gnus-summary-limit-include-expunged)
(defun gnus-summary-limit-include-expunged (&optional no-error)
"Display all the hidden articles that were expunged for low scores."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((inhibit-read-only t))
(let ((scored gnus-newsgroup-scored)
headers h)
@@ -11598,7 +11572,7 @@ Note that this function will only catch up the unread article
in the current summary buffer limitation.
The number of articles marked as read is returned."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(prog1
(save-excursion
(when (or quietly
@@ -11647,7 +11621,7 @@ The number of articles marked as read is returned."
(defun gnus-summary-catchup-to-here (&optional all)
"Mark all unticked articles before the current one as read.
If ALL is non-nil, also mark ticked and dormant articles as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-excursion
(gnus-save-hidden-threads
(let ((beg (point)))
@@ -11659,12 +11633,12 @@ If ALL is non-nil, also mark ticked and dormant articles as read."
(defun gnus-summary-catchup-from-here (&optional all)
"Mark all unticked articles after (and including) the current one as read.
If ALL is non-nil, also mark ticked and dormant articles as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-excursion
(gnus-save-hidden-threads
(let ((beg (point)))
;; We check that there are unread articles.
- (when (or all (gnus-summary-find-next))
+ (when (or all (gnus-summary-last-article-p) (gnus-summary-find-next))
(gnus-summary-catchup all t beg nil t)))))
(gnus-summary-position-point))
@@ -11672,14 +11646,14 @@ If ALL is non-nil, also mark ticked and dormant articles as read."
"Mark all articles in this newsgroup as read.
This command is dangerous. Normally, you want \\[gnus-summary-catchup]
instead, which marks only unread articles as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-catchup t quietly))
(defun gnus-summary-catchup-and-exit (&optional all quietly)
"Mark all unread articles in this group as read, then exit.
If prefix argument ALL is non-nil, all articles are marked as read.
If QUIETLY is non-nil, no questions will be asked."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when (gnus-summary-catchup all quietly nil 'fast)
;; Select next newsgroup or exit.
(if (and (not (gnus-group-quit-config gnus-newsgroup-name))
@@ -11691,14 +11665,14 @@ If QUIETLY is non-nil, no questions will be asked."
"Mark all articles in this newsgroup as read, and then exit.
This command is dangerous. Normally, you want \\[gnus-summary-catchup-and-exit]
instead, which marks only unread articles as read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-catchup-and-exit t quietly))
(defun gnus-summary-catchup-and-goto-next-group (&optional all)
"Mark all articles in this group as read and select the next group.
If given a prefix, mark all articles, unread as well as ticked, as
read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-excursion
(gnus-summary-catchup all))
(gnus-summary-next-group))
@@ -11707,7 +11681,7 @@ read."
"Mark all articles in this group as read and select the previous group.
If given a prefix, mark all articles, unread as well as ticked, as
read."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-excursion
(gnus-summary-catchup all))
(gnus-summary-next-group nil nil t))
@@ -11783,7 +11757,7 @@ with that article."
(defun gnus-summary-rethread-current ()
"Rethread the thread the current article is part of."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((gnus-show-threads t)
(article (gnus-summary-article-number))
(id (mail-header-id (gnus-summary-article-header)))
@@ -11798,7 +11772,7 @@ with that article."
Note that the re-threading will only work if `gnus-thread-ignore-subject'
is non-nil or the Subject: of both articles are the same."
- (interactive)
+ (interactive nil gnus-summary-mode)
(unless (not (gnus-group-read-only-p))
(error "The current newsgroup does not support article editing"))
(unless (<= (length gnus-newsgroup-processable) 1)
@@ -11817,9 +11791,10 @@ is non-nil or the Subject: of both articles are the same."
"Make PARENT the parent of CHILDREN.
When called interactively, PARENT is the current article and CHILDREN
are the process-marked articles."
- (interactive
- (list (gnus-summary-article-number)
- (gnus-summary-work-articles nil)))
+ (interactive (list
+ (gnus-summary-article-number)
+ (gnus-summary-work-articles nil))
+ gnus-summary-mode)
(dolist (child children)
(save-window-excursion
(let ((gnus-article-buffer " *reparent*"))
@@ -11852,7 +11827,7 @@ are the process-marked articles."
(defun gnus-summary-toggle-threads (&optional arg)
"Toggle showing conversation threads.
If ARG is positive number, turn showing conversation threads on."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(let ((current (or (gnus-summary-article-number) gnus-newsgroup-end)))
(setq gnus-show-threads
(if (null arg) (not gnus-show-threads)
@@ -11864,7 +11839,7 @@ If ARG is positive number, turn showing conversation threads on."
(defun gnus-summary-show-all-threads ()
"Show all threads."
- (interactive)
+ (interactive nil gnus-summary-mode)
(remove-overlays (point-min) (point-max) 'invisible 'gnus-sum)
(gnus-summary-position-point))
@@ -11874,7 +11849,7 @@ If ARG is positive number, turn showing conversation threads on."
(defun gnus-summary-show-thread ()
"Show thread subtrees.
Returns nil if no thread was there to be shown."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((orig (point))
(end (point-at-eol))
(end (or (gnus-summary--inv end) (gnus-summary--inv (1- end))))
@@ -11915,7 +11890,7 @@ Returns nil if no thread was there to be shown."
"Hide all thread subtrees.
If PREDICATE is supplied, threads that satisfy this predicate
will not be hidden."
- (interactive)
+ (interactive nil gnus-summary-mode)
(save-excursion
(goto-char (point-min))
(let ((end nil)
@@ -11933,10 +11908,8 @@ will not be hidden."
(defun gnus-summary-hide-thread ()
"Hide thread subtrees.
-If PREDICATE is supplied, threads that satisfy this predicate
-will not be hidden.
Returns nil if no threads were there to be hidden."
- (interactive)
+ (interactive nil gnus-summary-mode)
(beginning-of-line)
(let ((start (point))
(starteol (line-end-position))
@@ -11955,9 +11928,9 @@ Returns nil if no threads were there to be hidden."
(overlay-put ol 'invisible 'gnus-sum)
(overlay-put ol 'evaporate t)))
(gnus-summary-goto-subject article)
+ ;; We moved backward past the start point (invisible thread?)
(when (> start (point))
- (message "Hiding the thread moved us backwards, aborting!")
- (goto-char (point-max))))
+ (goto-char starteol)))
(goto-char start)
nil))))
@@ -11988,7 +11961,7 @@ Returns the difference between N and the number of skips actually
done.
If SILENT, don't output messages."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(let ((backward (< n 0))
(n (abs n)))
(while (and (> n 0)
@@ -12004,7 +11977,7 @@ If SILENT, don't output messages."
"Go to the same level previous N'th thread.
Returns the difference between N and the number of skips actually
done."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-next-thread (- n)))
(defun gnus-summary-go-down-thread ()
@@ -12024,7 +11997,7 @@ done."
If N is negative, go up instead.
Returns the difference between N and how many steps down that were
taken."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(let ((up (< n 0))
(n (abs n)))
(while (and (> n 0)
@@ -12041,18 +12014,18 @@ taken."
If N is negative, go down instead.
Returns the difference between N and how many steps down that were
taken."
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-down-thread (- n)))
(defun gnus-summary-top-thread ()
"Go to the top of the thread."
- (interactive)
+ (interactive nil gnus-summary-mode)
(while (gnus-summary-go-up-thread))
(gnus-summary-article-number))
(defun gnus-summary-expire-thread ()
"Mark articles under current thread as expired."
- (interactive)
+ (interactive nil gnus-summary-mode)
(gnus-summary-kill-thread 0))
(defun gnus-summary-kill-thread (&optional unmark)
@@ -12060,7 +12033,7 @@ taken."
If the prefix argument is positive, remove any kinds of marks.
If the prefix argument is zero, mark thread as expired.
If the prefix argument is negative, tick articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(when unmark
(setq unmark (prefix-numeric-value unmark)))
(let ((articles (gnus-summary-articles-in-thread))
@@ -12095,82 +12068,88 @@ If the prefix argument is negative, tick articles instead."
(defun gnus-summary-sort-by-number (&optional reverse)
"Sort the summary buffer by article number.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'number reverse))
(defun gnus-summary-sort-by-most-recent-number (&optional reverse)
"Sort the summary buffer by most recent article number.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'most-recent-number reverse))
(defun gnus-summary-sort-by-random (&optional reverse)
"Randomize the order in the summary buffer.
Argument REVERSE means to randomize in reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'random reverse))
(defun gnus-summary-sort-by-author (&optional reverse)
"Sort the summary buffer by author name alphabetically.
If `case-fold-search' is non-nil, case of letters is ignored.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'author reverse))
(defun gnus-summary-sort-by-recipient (&optional reverse)
"Sort the summary buffer by recipient name alphabetically.
If `case-fold-search' is non-nil, case of letters is ignored.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'recipient reverse))
(defun gnus-summary-sort-by-subject (&optional reverse)
"Sort the summary buffer by subject alphabetically. `Re:'s are ignored.
If `case-fold-search' is non-nil, case of letters is ignored.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'subject reverse))
(defun gnus-summary-sort-by-date (&optional reverse)
"Sort the summary buffer by date.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'date reverse))
(defun gnus-summary-sort-by-most-recent-date (&optional reverse)
"Sort the summary buffer by most recent date.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'most-recent-date reverse))
(defun gnus-summary-sort-by-score (&optional reverse)
"Sort the summary buffer by score.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'score reverse))
(defun gnus-summary-sort-by-lines (&optional reverse)
"Sort the summary buffer by the number of lines.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'lines reverse))
(defun gnus-summary-sort-by-chars (&optional reverse)
"Sort the summary buffer by article length.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'chars reverse))
(defun gnus-summary-sort-by-marks (&optional reverse)
"Sort the summary buffer by article marks.
Argument REVERSE means reverse order."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(gnus-summary-sort 'marks reverse))
+(defun gnus-summary-sort-by-newsgroups (&optional reverse)
+ "Sort the summary buffer by newsgroups alphabetically.
+Argument REVERSE means reverse order."
+ (interactive "P" gnus-summary-mode)
+ (gnus-summary-sort 'newsgroups reverse))
+
(defun gnus-summary-sort-by-original (&optional _reverse)
"Sort the summary buffer using the default sorting method.
Argument REVERSE means reverse order."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((inhibit-read-only t)
(gnus-summary-prepare-hook nil))
;; We do the sorting by regenerating the threads.
@@ -12178,6 +12157,24 @@ Argument REVERSE means reverse order."
;; Hide subthreads if needed.
(gnus-summary-maybe-hide-threads)))
+(defun gnus-summary-sort-by-extra (&optional reverse)
+ "Sort the summary buffer using an extra header.
+Argument REVERSE means reverse order."
+ (interactive "P" gnus-summary-mode)
+ (let* ((extra-header
+ (gnus-completing-read "Sort by extra header"
+ (mapcar #'symbol-name gnus-extra-headers)
+ t nil nil
+ (symbol-name
+ (car gnus-extra-headers))))
+ (header (downcase extra-header)))
+ (if (and (fboundp (intern
+ (format "gnus-thread-sort-by-%s" header)))
+ (fboundp
+ (intern (format "gnus-article-sort-by-%s" header))))
+ (gnus-summary-sort header reverse)
+ (error "No sort function defined for header: %s" extra-header))))
+
(defun gnus-summary-sort (predicate reverse)
"Sort summary buffer by PREDICATE. REVERSE means reverse order."
(let* ((current (gnus-summary-article-number))
@@ -12219,7 +12216,7 @@ will not be marked as saved.
The `gnus-prompt-before-saving' variable says how prompting is
performed."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let* ((articles (gnus-summary-work-articles n))
(save-buffer (save-excursion
@@ -12288,10 +12285,10 @@ is neither omitted nor the symbol `r', force including all headers
regardless of the `:headers' property. If it is the symbol `r',
articles that are not decoded and include all headers will be piped
no matter what the properties `:decode' and `:headers' are."
- (interactive (gnus-interactive "P\ny"))
+ (interactive (gnus-interactive "P\ny") gnus-summary-mode)
(require 'gnus-art)
(let* ((articles (gnus-summary-work-articles n))
- (result-buffer "*Shell Command Output*")
+ (result-buffer shell-command-buffer-name)
(all-headers (not (memq sym '(nil r))))
(gnus-save-all-headers (or all-headers gnus-save-all-headers))
(raw (eq sym 'r))
@@ -12320,7 +12317,7 @@ no matter what the properties `:decode' and `:headers' are."
(buffer-string))))))
(put 'gnus-summary-save-in-pipe :headers headers))
(unless (zerop (length result))
- (if (with-current-buffer (get-buffer-create result-buffer)
+ (if (with-current-buffer (gnus-get-buffer-create result-buffer)
(erase-buffer)
(insert result)
(prog1
@@ -12340,7 +12337,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-in-mail))
(gnus-summary-save-article arg)))
@@ -12351,7 +12348,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-in-rmail))
(gnus-summary-save-article arg)))
@@ -12362,7 +12359,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-in-file))
(gnus-summary-save-article arg)))
@@ -12373,7 +12370,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-write-to-file))
(gnus-summary-save-article arg)))
@@ -12384,7 +12381,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-body-in-file))
(gnus-summary-save-article arg)))
@@ -12395,7 +12392,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-write-body-to-file))
(gnus-summary-save-article arg)))
@@ -12406,14 +12403,14 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-pipe-to-muttprint))
(gnus-summary-save-article arg t)))
(defun gnus-summary-pipe-message (program)
"Pipe the current article through PROGRAM."
- (interactive "sProgram: ")
+ (interactive "sProgram: " gnus-summary-mode)
(gnus-summary-select-article)
(let ((mail-header-separator ""))
(gnus-eval-in-buffer-window gnus-article-buffer
@@ -12449,7 +12446,7 @@ save those articles instead."
;; Form.
(save-restriction
(widen)
- (setq result (eval match)))))
+ (setq result (eval match t)))))
(setq split-name (cdr method))
(cond ((stringp result)
(push (expand-file-name
@@ -12508,7 +12505,7 @@ save those articles instead."
(gnus-activate-group to-newsgroup nil nil to-method)
(gnus-subscribe-group to-newsgroup))
(error "Couldn't create group %s" to-newsgroup)))
- (error "No such group: %s" to-newsgroup))
+ (user-error "No such group: %s" to-newsgroup))
to-newsgroup)))
(defvar gnus-summary-save-parts-counter)
@@ -12518,15 +12515,21 @@ save those articles instead."
"Save parts matching TYPE to DIR.
If REVERSE, save parts that do not match TYPE."
(interactive
- (list (read-string "Save parts of type: "
- (or (car gnus-summary-save-parts-type-history)
- gnus-summary-save-parts-default-mime)
- 'gnus-summary-save-parts-type-history)
+ (list (completing-read "Save parts of type: "
+ (progn
+ (gnus-summary-select-article nil t)
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ (delete-dups
+ (mapcar (lambda (h)
+ (mm-handle-media-type (cdr h)))
+ gnus-article-mime-handle-alist))))
+ nil nil nil 'gnus-summary-save-parts-type-history)
(setq gnus-summary-save-parts-last-directory
(read-directory-name "Save to directory: "
gnus-summary-save-parts-last-directory
nil t))
- current-prefix-arg))
+ current-prefix-arg)
+ gnus-summary-mode)
(gnus-summary-iterate n
(let ((gnus-display-mime-function nil)
gnus-article-prepare-hook
@@ -12665,12 +12668,12 @@ If REVERSE, save parts that do not match TYPE."
(defun gnus-summary-edit-global-kill (article)
"Edit the \"global\" kill file."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number)) gnus-summary-mode)
(gnus-group-edit-global-kill article))
(defun gnus-summary-edit-local-kill ()
"Edit a local kill file applied to the current newsgroup."
- (interactive)
+ (interactive nil gnus-summary-mode)
(setq gnus-current-headers (gnus-summary-article-header))
(gnus-group-edit-local-kill
(gnus-summary-article-number) gnus-newsgroup-name))
@@ -12782,7 +12785,7 @@ If REVERSE, save parts that do not match TYPE."
;; so we highlight the entire line instead.
(when (= (+ to 2) from)
(setq from beg)
- (setq to end))
+ (setq to (1+ end)))
(if gnus-newsgroup-selected-overlay
;; Move old overlay.
(move-overlay
@@ -12837,7 +12840,7 @@ If REVERSE, save parts that do not match TYPE."
(let ((face (funcall (gnus-summary-highlight-line-0))))
(unless (eq face (gnus-get-text-property-excluding-characters-with-faces beg 'face))
(gnus-put-text-property-excluding-characters-with-faces
- beg (point-at-eol) 'face
+ beg (1+ (point-at-eol)) 'face
(setq face (if (boundp face) (symbol-value face) face)))
(when gnus-summary-highlight-line-function
(funcall gnus-summary-highlight-line-function article face))))))
@@ -12958,8 +12961,7 @@ UNREAD is a sorted list."
(and gnus-newsgroup-name
(gnus-parameter-charset gnus-newsgroup-name))
gnus-default-charset))
- (set (make-local-variable 'gnus-newsgroup-ignored-charsets)
- ignored-charsets))))
+ (setq-local gnus-newsgroup-ignored-charsets ignored-charsets))))
;;;
;;; Mime Commands
@@ -12969,7 +12971,7 @@ UNREAD is a sorted list."
"Display the current article buffer fully MIME-buttonized.
If SHOW-ALL-PARTS (the prefix) is non-nil, all multipart/* parts are
treated as multipart/mixed."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-unbuttonized-mime-types nil)
(gnus-mime-display-multipart-as-mixed show-all-parts))
@@ -12977,7 +12979,7 @@ treated as multipart/mixed."
(defun gnus-summary-repair-multipart (article)
"Add a Content-Type header to a multipart article without one."
- (interactive (list (gnus-summary-article-number)))
+ (interactive (list (gnus-summary-article-number)) gnus-summary-mode)
(gnus-with-article article
(message-narrow-to-head)
(message-remove-header "Mime-Version")
@@ -12997,7 +12999,7 @@ treated as multipart/mixed."
(defun gnus-summary-toggle-display-buttonized ()
"Toggle the buttonizing of the article buffer."
- (interactive)
+ (interactive nil gnus-summary-mode)
(require 'gnus-art)
(if (setq gnus-inhibit-mime-unbuttonizing
(not gnus-inhibit-mime-unbuttonizing))
@@ -13035,7 +13037,7 @@ treated as multipart/mixed."
(nomove "" nil nil ,keystroke)))
(let ((func (gnus-summary-make-marking-command-1
mark (car lway) lway name)))
- (setq func (eval func))
+ (setq func (eval func t))
(define-key map (nth 4 lway) func)))))
(defun gnus-summary-make-marking-command-1 (mark way lway name)
@@ -13052,7 +13054,7 @@ If N is negative, move in reverse order.
The difference between N and the actual number of articles marked is
returned."
name (cadr lway))
- (interactive "p")
+ (interactive "p" gnus-summary-mode)
(gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway))))
(defun gnus-summary-generic-mark (n mark move unread)
@@ -13135,7 +13137,7 @@ returned."
"Insert all old articles in this group.
If ALL is non-nil, already read articles become readable.
If ALL is a number, fetch this number of articles."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(prog1
(let ((old (sort (mapcar #'gnus-data-number gnus-newsgroup-data) #'<))
older len)
@@ -13169,10 +13171,13 @@ If ALL is a number, fetch this number of articles."
(t
(when (and (numberp gnus-large-newsgroup)
(> len gnus-large-newsgroup))
- (let* ((cursor-in-echo-area nil)
- (initial (gnus-parameter-large-newsgroup-initial
- gnus-newsgroup-name))
- (input
+ (let ((cursor-in-echo-area nil)
+ (initial (gnus-parameter-large-newsgroup-initial
+ gnus-newsgroup-name))
+ input)
+ (when (eq initial 'all)
+ (setq initial len))
+ (setq input
(read-string
(format
"How many articles from %s (%s %d): "
@@ -13181,7 +13186,7 @@ If ALL is a number, fetch this number of articles."
len)
nil nil
(and initial
- (number-to-string initial)))))
+ (number-to-string initial))))
(unless (string-match "^[ \t]*$" input)
(setq all (string-to-number input))
(if (< all len)
@@ -13206,7 +13211,7 @@ If ALL is a number, fetch this number of articles."
(defun gnus-summary-insert-new-articles ()
"Insert all new articles in this group."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let ((old (sort (mapcar #'gnus-data-number gnus-newsgroup-data) #'<))
(old-high gnus-newsgroup-highest)
(nnmail-fetched-sources (list t))
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index deb4fc94adf..568fbbcafb1 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1,4 +1,4 @@
-;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
+;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -43,8 +43,7 @@
(defcustom gnus-topic-mode-hook nil
"Hook run in topic mode buffers."
- :type 'hook
- :group 'gnus-topic)
+ :type 'hook)
(defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
"Format of topic lines.
@@ -55,24 +54,22 @@ with some simple extensions.
%n Topic name.
%v Nothing if the topic is visible, \"...\" otherwise.
%g Number of groups in the topic.
+%G Number of groups in the topic and its subtopics.
%a Number of unread articles in the groups in the topic.
%A Number of unread articles in the groups in the topic and its subtopics.
General format specifiers can also be used.
See Info node `(gnus)Formatting Variables'."
:link '(custom-manual "(gnus)Formatting Variables")
- :type 'string
- :group 'gnus-topic)
+ :type 'string)
(defcustom gnus-topic-indent-level 2
"How much each subtopic should be indented."
- :type 'integer
- :group 'gnus-topic)
+ :type 'integer)
(defcustom gnus-topic-display-empty-topics t
"If non-nil, display the topic lines even of topics that have no unread articles."
- :type 'boolean
- :group 'gnus-topic)
+ :type 'boolean)
;; Internal variables.
@@ -91,6 +88,7 @@ See Info node `(gnus)Formatting Variables'."
(?v visible ?s)
(?i indentation ?s)
(?g number-of-groups ?d)
+ (?G total-number-of-groups ?d)
(?a (gnus-topic-articles-in-topic entries) ?d)
(?A total-number-of-articles ?d)
(?l level ?d)))
@@ -150,7 +148,8 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-topic-jump-to-topic (topic)
"Go to TOPIC."
(interactive
- (list (gnus-completing-read "Go to topic" (gnus-topic-list) t)))
+ (list (gnus-completing-read "Go to topic" (gnus-topic-list) t))
+ gnus-topic-mode)
(let ((inhibit-read-only t))
(dolist (topic (gnus-current-topics topic))
(unless (gnus-topic-goto-topic topic)
@@ -239,12 +238,12 @@ If RECURSIVE is t, return groups in its subtopics too."
(defun gnus-topic-goto-previous-topic (n)
"Go to the N'th previous topic."
- (interactive "p")
+ (interactive "p" gnus-topic-mode)
(gnus-topic-goto-next-topic (- n)))
(defun gnus-topic-goto-next-topic (n)
"Go to the N'th next topic."
- (interactive "p")
+ (interactive "p" gnus-topic-mode)
(let ((backward (< n 0))
(n (abs n))
(topic (gnus-current-topic)))
@@ -335,7 +334,7 @@ If RECURSIVE is t, return groups in its subtopics too."
(setq topology gnus-topic-topology
gnus-tmp-topics nil))
(push (caar topology) gnus-tmp-topics)
- (mapc 'gnus-topic-list (cdr topology))
+ (mapc #'gnus-topic-list (cdr topology))
gnus-tmp-topics)
;;; Topic parameter jazz
@@ -386,7 +385,7 @@ inheritance."
;; We probably have lots of nil elements here, so we remove them.
;; Probably faster than doing this "properly".
(delq nil (cons group-params-list
- (mapcar 'gnus-topic-parameters
+ (mapcar #'gnus-topic-parameters
(gnus-current-topics topic)))))
param out params)
;; Now we have all the parameters, so we go through them
@@ -445,7 +444,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(and (>= level gnus-level-zombie)
(<= lowest gnus-level-zombie)))
(gnus-group-prepare-flat-list-dead
- (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ (setq gnus-zombie-list (sort gnus-zombie-list #'string<))
gnus-level-zombie ?Z
regexp))
@@ -453,7 +452,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(and (>= level gnus-level-killed)
(<= lowest gnus-level-killed)))
(gnus-group-prepare-flat-list-dead
- (setq gnus-killed-list (sort gnus-killed-list 'string<))
+ (setq gnus-killed-list (sort gnus-killed-list #'string<))
gnus-level-killed ?K regexp)
(when not-in-list
(unless gnus-killed-hashtb
@@ -488,16 +487,18 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
If SILENT, don't insert anything. Return the number of unread
articles in the topic and its subtopics."
(let* ((type (pop topicl))
+ (entries-level (if gnus-group-listed-groups
+ gnus-level-killed
+ list-level))
+ (all (or predicate gnus-group-listed-groups
+ (cdr (assq 'visible
+ (gnus-topic-hierarchical-parameters
+ (car type))))))
+ (lowest (if gnus-group-listed-groups 0 lowest))
(entries (gnus-topic-find-groups
- (car type)
- (if gnus-group-listed-groups
- gnus-level-killed
- list-level)
- (or predicate gnus-group-listed-groups
- (cdr (assq 'visible
- (gnus-topic-hierarchical-parameters
- (car type)))))
- (if gnus-group-listed-groups 0 lowest)))
+ (car type) entries-level all lowest))
+ (all-groups (gnus-topic-find-groups
+ (car type) entries-level all lowest t))
(visiblep (and (eq (nth 1 type) 'visible) (not silent)))
(gnus-group-indentation
(make-string (* gnus-topic-indent-level level) ? ))
@@ -576,7 +577,7 @@ articles in the topic and its subtopics."
(gnus-topic-insert-topic-line
(car type) visiblep
(not (eq (nth 2 type) 'hidden))
- level all-entries unread))
+ level all-entries unread all-groups))
(gnus-topic-update-unreads (car type) unread)
(gnus-group--setup-tool-bar-update beg end)
(goto-char end)
@@ -630,11 +631,19 @@ articles in the topic and its subtopics."
(defvar gnus-tmp-header)
(defun gnus-topic-insert-topic-line (name visiblep shownp level entries
- &optional unread)
+ &optional unread all-groups)
+ (gnus--\,@
+ (let ((vars '(indentation visible name level number-of-groups
+ total-number-of-groups total-number-of-articles entries)))
+ `((with-suppressed-warnings ((lexical ,@vars))
+ ,@(mapcar (lambda (s) `(defvar ,s)) vars)))))
(let* ((visible (if visiblep "" "..."))
+ (level level)
+ (name name)
(indentation (make-string (* gnus-topic-indent-level level) ? ))
(total-number-of-articles unread)
(number-of-groups (length entries))
+ (total-number-of-groups (length all-groups))
(active-topic (eq gnus-topic-alist gnus-topic-active-alist))
gnus-tmp-header)
(gnus-topic-update-unreads name unread)
@@ -644,7 +653,7 @@ articles in the topic and its subtopics."
(add-text-properties
(point)
(prog1 (1+ (point))
- (eval gnus-topic-line-format-spec))
+ (eval gnus-topic-line-format-spec t))
(list 'gnus-topic name
'gnus-topic-level level
'gnus-topic-unread unread
@@ -658,7 +667,7 @@ articles in the topic and its subtopics."
(defun gnus-topic-update-topics-containing-group (group)
"Update all topics that have GROUP as a member."
- (when (and (eq major-mode 'gnus-group-mode)
+ (when (and (eq major-mode 'gnus-topic-mode)
gnus-topic-mode)
(save-excursion
(let ((alist gnus-topic-alist))
@@ -674,7 +683,7 @@ articles in the topic and its subtopics."
(defun gnus-topic-update-topic ()
"Update all parent topics to the current group."
- (when (and (eq major-mode 'gnus-group-mode)
+ (when (and (eq major-mode 'gnus-topic-mode)
gnus-topic-mode)
(let ((group (gnus-group-group-name))
(m (point-marker))
@@ -727,6 +736,9 @@ articles in the topic and its subtopics."
(entries (gnus-topic-find-groups
(car type) (car gnus-group-list-mode)
(cdr gnus-group-list-mode)))
+ (all-groups (gnus-topic-find-groups
+ (car type) (car gnus-group-list-mode)
+ (cdr gnus-group-list-mode) nil t))
entry)
(while children
(cl-incf unread (gnus-topic-unread (caar (pop children)))))
@@ -734,7 +746,7 @@ articles in the topic and its subtopics."
(when (numberp (car entry))
(cl-incf unread (car entry))))
(gnus-topic-insert-topic-line
- topic t t (car (gnus-topic-find-topology topic)) nil unread)))
+ topic t t (car (gnus-topic-find-topology topic)) nil unread all-groups)))
(defun gnus-topic-goto-missing-topic (topic)
(if (gnus-topic-goto-topic topic)
@@ -764,6 +776,9 @@ articles in the topic and its subtopics."
(entries (gnus-topic-find-groups
(car type) (car gnus-group-list-mode)
(cdr gnus-group-list-mode)))
+ (all-groups (gnus-topic-find-groups
+ (car type) (car gnus-group-list-mode)
+ (cdr gnus-group-list-mode) t))
(parent (gnus-topic-parent-topic topic-name))
(all-entries entries)
(unread 0)
@@ -782,7 +797,7 @@ articles in the topic and its subtopics."
(gnus-topic-insert-topic-line
(car type) (gnus-topic-visible-p)
(not (eq (nth 2 type) 'hidden))
- (gnus-group-topic-level) all-entries unread)
+ (gnus-group-topic-level) all-entries unread all-groups)
(gnus-delete-line)
(forward-line -1)
(setq new-unread (gnus-group-topic-unread)))
@@ -841,7 +856,7 @@ articles in the topic and its subtopics."
(pop topics)))
;; Go through all living groups and make sure that
;; they belong to some topic.
- (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
+ (let* ((tgroups (apply #'append (mapcar #'cdr gnus-topic-alist)))
(entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
(groups (cdr gnus-group-list)))
(dolist (group groups)
@@ -897,9 +912,7 @@ articles in the topic and its subtopics."
(let ((inhibit-read-only t))
(unless gnus-topic-inhibit-change-level
(gnus-group-goto-group (or (car (nth 1 previous)) group))
- (when (and gnus-topic-mode
- gnus-topic-alist
- (not gnus-topic-inhibit-change-level))
+ (when (and gnus-topic-mode gnus-topic-alist (gnus-current-topic))
;; Remove the group from the topics.
(if (and (< oldlevel gnus-level-zombie)
(>= level gnus-level-zombie))
@@ -1110,7 +1123,7 @@ articles in the topic and its subtopics."
["Delete" gnus-topic-delete t]
["Rename..." gnus-topic-rename t]
["Create..." gnus-topic-create-topic t]
- ["Mark" gnus-topic-mark-topic t]
+ ["Toggle/Set mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
["Sort" gnus-topic-sort-topics t]
["Previous topic" gnus-topic-goto-previous-topic t]
@@ -1121,7 +1134,9 @@ articles in the topic and its subtopics."
(define-minor-mode gnus-topic-mode
"Minor mode for topicsifying Gnus group buffers."
- :lighter " Topic" :keymap gnus-topic-mode-map
+ :lighter " Topic"
+ :keymap gnus-topic-mode-map
+ :interactive (gnus-group-mode)
(if (not (derived-mode-p 'gnus-group-mode))
(setq gnus-topic-mode nil)
;; Infest Gnus with topics.
@@ -1130,22 +1145,21 @@ articles in the topic and its subtopics."
(when (gnus-visual-p 'topic-menu 'menu)
(gnus-topic-make-menu-bar))
(gnus-set-format 'topic t)
- (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
- (set (make-local-variable 'gnus-group-prepare-function)
- 'gnus-group-prepare-topics)
- (set (make-local-variable 'gnus-group-get-parameter-function)
- 'gnus-group-topic-parameters)
- (set (make-local-variable 'gnus-group-goto-next-group-function)
- 'gnus-topic-goto-next-group)
- (set (make-local-variable 'gnus-group-indentation-function)
- 'gnus-topic-group-indentation)
- (set (make-local-variable 'gnus-group-update-group-function)
- 'gnus-topic-update-topics-containing-group)
- (set (make-local-variable 'gnus-group-sort-alist-function)
- 'gnus-group-sort-topic)
- (setq gnus-group-change-level-function 'gnus-topic-change-level)
- (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
- (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist
+ (add-hook 'gnus-group-catchup-group-hook #'gnus-topic-update-topic)
+ (setq-local gnus-group-prepare-function
+ #'gnus-group-prepare-topics)
+ (setq-local gnus-group-get-parameter-function
+ #'gnus-group-topic-parameters)
+ (setq-local gnus-group-goto-next-group-function
+ #'gnus-topic-goto-next-group)
+ (setq-local gnus-group-indentation-function
+ #'gnus-topic-group-indentation)
+ (setq-local gnus-group-update-group-function
+ #'gnus-topic-update-topics-containing-group)
+ (setq-local gnus-group-sort-alist-function #'gnus-group-sort-topic)
+ (setq gnus-group-change-level-function #'gnus-topic-change-level)
+ (setq gnus-goto-missing-group-function #'gnus-topic-goto-missing-group)
+ (add-hook 'gnus-check-bogus-groups-hook #'gnus-topic-clean-alist
nil 'local)
(setq gnus-topology-checked-p nil)
;; We check the topology.
@@ -1153,11 +1167,11 @@ articles in the topic and its subtopics."
(gnus-topic-check-topology)))
;; Remove topic infestation.
(unless gnus-topic-mode
- (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
+ (remove-hook 'gnus-summary-exit-hook #'gnus-topic-update-topic)
(setq gnus-group-change-level-function nil)
- (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
- (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
- (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
+ (remove-hook 'gnus-check-bogus-groups-hook #'gnus-topic-clean-alist)
+ (setq gnus-group-prepare-function #'gnus-group-prepare-flat)
+ (setq gnus-group-sort-alist-function #'gnus-group-sort-flat))
(when (called-interactively-p 'any)
(gnus-group-list-groups))))
@@ -1172,7 +1186,7 @@ articles in the group. If ALL is a negative number, fetch this
number of the earliest articles in the group.
If performed over a topic line, toggle folding the topic."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(when (and (eobp) (not (gnus-group-group-name)))
(forward-line -1))
(if (gnus-group-topic-p)
@@ -1184,13 +1198,13 @@ If performed over a topic line, toggle folding the topic."
(defun gnus-mouse-pick-topic (e)
"Select the group or topic under the mouse pointer."
- (interactive "e")
+ (interactive "e" gnus-topic-mode)
(mouse-set-point e)
(gnus-topic-read-group nil))
(defun gnus-topic-expire-articles (topic)
"Expire articles in this topic or group."
- (interactive (list (gnus-group-topic-name)))
+ (interactive (list (gnus-group-topic-name)) gnus-topic-mode)
(if (not topic)
(call-interactively 'gnus-group-expire-articles)
(save-excursion
@@ -1205,7 +1219,7 @@ If performed over a topic line, toggle folding the topic."
(defun gnus-topic-catchup-articles (topic)
"Catchup this topic or group.
Also see `gnus-group-catchup'."
- (interactive (list (gnus-group-topic-name)))
+ (interactive (list (gnus-group-topic-name)) gnus-topic-mode)
(if (not topic)
(call-interactively 'gnus-group-catchup-current)
(save-excursion
@@ -1216,7 +1230,7 @@ Also see `gnus-group-catchup'."
(inhibit-read-only t)
(gnus-group-marked groups))
(gnus-group-catchup-current)
- (mapcar 'gnus-topic-update-topics-containing-group groups)))))
+ (mapcar #'gnus-topic-update-topics-containing-group groups)))))
(defun gnus-topic-read-group (&optional all no-article group)
"Read news in this newsgroup.
@@ -1232,7 +1246,7 @@ be auto-selected upon group entry. If GROUP is non-nil, fetch
that group.
If performed over a topic line, toggle folding the topic."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(when (and (eobp) (not (gnus-group-group-name)))
(forward-line -1))
(if (gnus-group-topic-p)
@@ -1247,7 +1261,8 @@ When used interactively, PARENT will be the topic under point."
(interactive
(list
(read-string "New topic: ")
- (gnus-current-topic)))
+ (gnus-current-topic))
+ gnus-topic-mode)
;; Check whether this topic already exists.
(when (gnus-topic-find-topology topic)
(error "Topic already exists"))
@@ -1283,8 +1298,9 @@ 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" (mapcar 'car gnus-topic-alist) t
- nil 'gnus-topic-history)))
+ (gnus-completing-read "Move to topic" (mapcar #'car gnus-topic-alist) t
+ nil 'gnus-topic-history))
+ gnus-topic-mode)
(let ((use-marked (and (not n) (not (and transient-mark-mode mark-active))
gnus-group-marked t))
(groups (gnus-group-process-prefix n))
@@ -1309,7 +1325,7 @@ If COPYP, copy the groups instead."
(defun gnus-topic-remove-group (&optional n)
"Remove the current group from the topic."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(let ((use-marked (and (not n) (not (and transient-mark-mode mark-active))
gnus-group-marked t))
(groups (gnus-group-process-prefix n)))
@@ -1331,12 +1347,13 @@ If COPYP, copy the groups instead."
(interactive
(list current-prefix-arg
(gnus-completing-read
- "Copy to topic" (mapcar 'car gnus-topic-alist) t)))
+ "Copy to topic" (mapcar #'car gnus-topic-alist) t))
+ gnus-topic-mode)
(gnus-topic-move-group n topic t))
(defun gnus-topic-kill-group (&optional n discard)
"Kill the next N groups."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(if (gnus-group-topic-p)
(let ((topic (gnus-group-topic-name)))
(push (cons
@@ -1356,7 +1373,7 @@ If COPYP, copy the groups instead."
(defun gnus-topic-yank-group (&optional arg)
"Yank the last topic."
- (interactive "p")
+ (interactive "p" gnus-topic-mode)
(if gnus-topic-killed-topics
(let* ((previous
(or (gnus-group-topic-name)
@@ -1405,7 +1422,7 @@ If COPYP, copy the groups instead."
(defun gnus-topic-hide-topic (&optional permanent)
"Hide the current topic.
If PERMANENT, make it stay hidden in subsequent sessions as well."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(when (gnus-current-topic)
(gnus-topic-goto-topic (gnus-current-topic))
(if permanent
@@ -1418,46 +1435,54 @@ If PERMANENT, make it stay hidden in subsequent sessions as well."
(defun gnus-topic-show-topic (&optional permanent)
"Show the hidden topic.
If PERMANENT, make it stay shown in subsequent sessions as well."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(when (gnus-group-topic-p)
(if (not permanent)
(gnus-topic-remove-topic t nil)
(let ((topic
(gnus-topic-find-topology
(gnus-completing-read "Show topic"
- (mapcar 'car gnus-topic-alist) t))))
+ (mapcar #'car gnus-topic-alist) t))))
(setcar (cddr (cadr topic)) nil)
(setcar (cdr (cadr topic)) 'visible)
(gnus-group-list-groups)))))
-(defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
+(defun gnus-topic-mark-topic (topic &optional unmark non-recursive no-toggle)
"Mark all groups in the TOPIC with the process mark.
If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
- (interactive (list (gnus-group-topic-name)
- nil
- (and current-prefix-arg t)))
+ (interactive
+ (list (gnus-group-topic-name)
+ nil
+ (and current-prefix-arg t))
+ gnus-topic-mode)
(if (not topic)
(call-interactively 'gnus-group-mark-group)
(save-excursion
(let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
(not non-recursive))))
(while groups
- (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
- (gnus-info-group (nth 1 (pop groups)))))))))
+ (let ((group (gnus-info-group (nth 1 (pop groups)))))
+ (if (and gnus-process-mark-toggle (not no-toggle))
+ (if (memq group gnus-group-marked)
+ (gnus-group-remove-mark group )
+ (gnus-group-set-mark group))
+ (if unmark (gnus-group-remove-mark group)
+ (gnus-group-set-mark group)))))))))
(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(interactive (list (gnus-group-topic-name)
nil
- (and current-prefix-arg t)))
+ (and current-prefix-arg t))
+ gnus-topic-mode)
(if (not topic)
(call-interactively 'gnus-group-unmark-group)
- (gnus-topic-mark-topic topic t non-recursive)))
+ (gnus-topic-mark-topic topic t non-recursive t)))
(defun gnus-topic-get-new-news-this-topic (&optional n)
"Check for new news in the current topic."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(if (not (gnus-group-topic-p))
(gnus-group-get-new-news-this-group n)
(let* ((topic (gnus-group-topic-name))
@@ -1474,8 +1499,9 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(nreverse
(list
(setq topic (gnus-completing-read "Move to topic"
- (mapcar 'car gnus-topic-alist) t))
- (read-string (format "Move to %s (regexp): " topic))))))
+ (mapcar #'car gnus-topic-alist) t))
+ (read-string (format "Move to %s (regexp): " topic)))))
+ gnus-topic-mode)
(gnus-group-mark-regexp regexp)
(gnus-topic-move-group nil topic copyp))
@@ -1486,12 +1512,13 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(mapcar #'car gnus-topic-alist) t)))
(nreverse
(list topic
- (read-string (format "Copy to %s (regexp): " topic))))))
+ (read-string (format "Copy to %s (regexp): " topic)))))
+ gnus-topic-mode)
(gnus-topic-move-matching regexp topic t))
(defun gnus-topic-delete (topic)
"Delete a topic."
- (interactive (list (gnus-group-topic-name)))
+ (interactive (list (gnus-group-topic-name)) gnus-topic-mode)
(unless topic
(error "No topic to be deleted"))
(let ((entry (assoc topic gnus-topic-alist))
@@ -1512,7 +1539,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(interactive
(let ((topic (gnus-current-topic)))
(list topic
- (read-string (format "Rename %s to: " topic) topic))))
+ (read-string (format "Rename %s to: " topic) topic)))
+ gnus-topic-mode)
;; Check whether the new name exists.
(when (gnus-topic-find-topology new-name)
(error "Topic `%s' already exists" new-name))
@@ -1535,7 +1563,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(defun gnus-topic-indent (&optional unindent)
"Indent a topic -- make it a sub-topic of the previous topic.
If UNINDENT, remove an indentation."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(if unindent
(gnus-topic-unindent)
(let* ((topic (gnus-current-topic))
@@ -1555,7 +1583,7 @@ If UNINDENT, remove an indentation."
(defun gnus-topic-unindent ()
"Unindent a topic."
- (interactive)
+ (interactive nil gnus-topic-mode)
(let* ((topic (gnus-current-topic))
(parent (gnus-topic-parent-topic topic))
(grandparent (gnus-topic-parent-topic parent)))
@@ -1574,7 +1602,7 @@ If UNINDENT, remove an indentation."
(defun gnus-topic-list-active (&optional force)
"List all groups that Gnus knows about in a topicsified fashion.
If FORCE, always re-read the active file."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(when force
(gnus-get-killed-groups))
(gnus-topic-grok-active force)
@@ -1585,7 +1613,7 @@ If FORCE, always re-read the active file."
(defun gnus-topic-toggle-display-empty-topics ()
"Show/hide topics that have no unread articles."
- (interactive)
+ (interactive nil gnus-topic-mode)
(setq gnus-topic-display-empty-topics
(not gnus-topic-display-empty-topics))
(gnus-group-list-groups)
@@ -1598,7 +1626,7 @@ If FORCE, always re-read the active file."
(defun gnus-topic-edit-parameters (group)
"Edit the group parameters of GROUP.
If performed on a topic, edit the topic parameters instead."
- (interactive (list (gnus-group-group-name)))
+ (interactive (list (gnus-group-group-name)) gnus-topic-mode)
(if group
(gnus-group-edit-group-parameters group)
(if (not (gnus-group-topic-p))
@@ -1608,8 +1636,8 @@ If performed on a topic, edit the topic parameters instead."
(gnus-topic-parameters topic)
(format-message "Editing the topic parameters for `%s'."
(or group topic))
- `(lambda (form)
- (gnus-topic-set-parameters ,topic form)))))))
+ (lambda (form)
+ (gnus-topic-set-parameters topic form)))))))
(defun gnus-group-sort-topic (func reverse)
"Sort groups in the topics according to FUNC and REVERSE."
@@ -1642,7 +1670,8 @@ If performed on a topic, edit the topic parameters instead."
(defun gnus-topic-sort-groups (func &optional reverse)
"Sort the current topic according to FUNC.
If REVERSE, reverse the sorting order."
- (interactive (list gnus-group-sort-function current-prefix-arg))
+ (interactive (list gnus-group-sort-function current-prefix-arg)
+ gnus-topic-mode)
(let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
(gnus-topic-sort-topic
topic (gnus-make-sort-function func) reverse)
@@ -1651,51 +1680,50 @@ If REVERSE, reverse the sorting order."
(defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
"Sort the current topic alphabetically by group name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
(defun gnus-topic-sort-groups-by-unread (&optional reverse)
"Sort the current topic by number of unread articles.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
(defun gnus-topic-sort-groups-by-level (&optional reverse)
"Sort the current topic by group level.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
(defun gnus-topic-sort-groups-by-score (&optional reverse)
"Sort the current topic by group score.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
(defun gnus-topic-sort-groups-by-rank (&optional reverse)
"Sort the current topic by group rank.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
(defun gnus-topic-sort-groups-by-method (&optional reverse)
"Sort the current topic alphabetically by backend name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
(defun gnus-topic-sort-groups-by-server (&optional reverse)
"Sort the current topic alphabetically by server name.
If REVERSE, sort in reverse order."
- (interactive "P")
+ (interactive "P" gnus-topic-mode)
(gnus-topic-sort-groups 'gnus-group-sort-by-server reverse))
(defun gnus-topic-sort-topics-1 (top reverse)
(if (cdr top)
(let ((subtop
- (mapcar (gnus-byte-compile
- `(lambda (top)
- (gnus-topic-sort-topics-1 top ,reverse)))
+ (mapcar (lambda (top)
+ (gnus-topic-sort-topics-1 top reverse))
(sort (cdr top)
(lambda (t1 t2)
(string-lessp (caar t1) (caar t2)))))))
@@ -1707,9 +1735,10 @@ If REVERSE, sort in reverse order."
If REVERSE, reverse the sorting order."
(interactive
(list (gnus-completing-read "Sort topics in"
- (mapcar 'car gnus-topic-alist) t
+ (mapcar #'car gnus-topic-alist) t
(gnus-current-topic))
- current-prefix-arg))
+ current-prefix-arg)
+ gnus-topic-mode)
(let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
gnus-topic-topology)))
(gnus-topic-sort-topics-1 topic-topology reverse)
@@ -1722,7 +1751,8 @@ If REVERSE, reverse the sorting order."
(interactive
(list
(gnus-group-topic-name)
- (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t)))
+ (gnus-completing-read "Move to topic" (mapcar #'car gnus-topic-alist) t))
+ gnus-topic-mode)
(unless (and current to)
(error "Can't find topic"))
(let ((current-top (cdr (gnus-topic-find-topology current)))
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index 450879fcb20..64ed2bbad6b 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -1,4 +1,4 @@
-;;; gnus-undo.el --- minor mode for undoing in Gnus
+;;; gnus-undo.el --- minor mode for undoing in Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -52,8 +52,7 @@
(defcustom gnus-undo-limit 2000
"The number of undoable actions recorded."
- :type 'integer
- :group 'gnus-undo)
+ :type 'integer)
(defcustom gnus-undo-mode nil
;; FIXME: This is a buffer-local minor mode which requires running
@@ -61,13 +60,11 @@
;; 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)
+ :type 'boolean)
(defcustom gnus-undo-mode-hook nil
"Hook called in all `gnus-undo-mode' buffers."
- :type 'hook
- :group 'gnus-undo)
+ :type 'hook)
;;; Internal variables.
@@ -100,13 +97,13 @@
\\{gnus-undo-mode-map}"
:keymap gnus-undo-mode-map
- (set (make-local-variable 'gnus-undo-actions) nil)
- (set (make-local-variable 'gnus-undo-boundary) t)
+ (setq-local gnus-undo-actions nil)
+ (setq-local 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-hook 'post-command-hook 'gnus-undo-boundary nil t)))
+ (add-hook 'post-command-hook #'gnus-undo-boundary nil t)))
;;; Interface functions.
@@ -130,15 +127,10 @@
gnus-undo-boundary t))
(defun gnus-undo-register (form)
- "Register FORMS as something to be performed to undo a change.
-FORMS may use backtick quote syntax."
+ "Register FORMS as something to be performed to undo a change."
(when gnus-undo-mode
(gnus-undo-register-1
- `(lambda ()
- ,form))))
-
-(put 'gnus-undo-register 'lisp-indent-function 0)
-(put 'gnus-undo-register 'edebug-form-spec '(body))
+ `(lambda () ,form))))
(defun gnus-undo-register-1 (function)
"Register FUNCTION as something to be performed to undo a change."
@@ -161,23 +153,23 @@ FORMS may use backtick quote syntax."
;; We are not at a boundary...
(setq gnus-undo-boundary-inhibit t)))
-(defun gnus-undo (n)
+(defun gnus-undo (_n)
"Undo some previous changes in Gnus buffers.
-Repeat this command to undo more changes.
-A numeric argument serves as a repeat count."
+Repeat this command to undo more changes."
+ ;; FIXME: A numeric argument should serve as a repeat count.
(interactive "p")
(unless gnus-undo-mode
(error "Undoing is not enabled in this buffer"))
(message "%s" last-command)
- (when (or (not (eq last-command 'gnus-undo))
- (not gnus-undo-last))
+ (unless (and (eq last-command 'gnus-undo)
+ gnus-undo-last)
(setq gnus-undo-last gnus-undo-actions))
(let ((action (pop gnus-undo-last)))
(unless action
(error "Nothing further to undo"))
(setq gnus-undo-actions (delq action gnus-undo-actions))
(setq gnus-undo-boundary t)
- (mapc 'funcall action)))
+ (mapc #'funcall action)))
(provide 'gnus-undo)
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index e2b7ad6928c..be0284515dc 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1,4 +1,4 @@
-;;; gnus-util.el --- utility functions for Gnus
+;;; gnus-util.el --- utility functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -87,6 +87,7 @@ This is a compatibility function for different Emacsen."
(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
"Pop to BUFFER, evaluate FORMS, and then return to the original window."
+ (declare (indent 1) (debug t))
(let ((tempvar (make-symbol "GnusStartBufferWindow"))
(w (make-symbol "w"))
(buf (make-symbol "buf")))
@@ -103,9 +104,6 @@ This is a compatibility function for different Emacsen."
,@forms)
(select-window ,tempvar)))))
-(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
-(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
@@ -302,31 +300,28 @@ Symbols are also allowed; their print names are used instead."
(defmacro gnus-local-set-keys (&rest plist)
"Set the keys in PLIST in the current keymap."
+ (declare (indent 1))
`(gnus-define-keys-1 (current-local-map) ',plist))
(defmacro gnus-define-keys (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
- `(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
+ (declare (indent 1))
+ `(gnus-define-keys-1 ,(if (symbolp keymap) keymap `',keymap) (quote ,plist)))
(defmacro gnus-define-keys-safe (keymap &rest plist)
"Define all keys in PLIST in KEYMAP without overwriting previous definitions."
+ (declare (indent 1))
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
-(put 'gnus-define-keys 'lisp-indent-function 1)
-(put 'gnus-define-keys-safe 'lisp-indent-function 1)
-(put 'gnus-local-set-keys 'lisp-indent-function 1)
-
(defmacro gnus-define-keymap (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
+ (declare (indent 1))
`(gnus-define-keys-1 ,keymap (quote ,plist)))
-(put 'gnus-define-keymap 'lisp-indent-function 1)
-
(defun gnus-define-keys-1 (keymap plist &optional safe)
(when (null keymap)
(error "Can't set keys in a null keymap"))
- (cond ((symbolp keymap)
- (setq keymap (symbol-value keymap)))
+ (cond ((symbolp keymap) (error "First arg should be a keymap object"))
((keymapp keymap))
((listp keymap)
(set (car keymap) nil)
@@ -450,14 +445,12 @@ displayed in the echo area."
`(let (str time)
(cond ((eq gnus-add-timestamp-to-message 'log)
(setq str (let (message-log-max)
- (apply 'message ,format-string ,args)))
+ (apply #'message ,format-string ,args)))
(when (and message-log-max
(> message-log-max 0)
(/= (length str) 0))
(setq time (current-time))
- (with-current-buffer (if (fboundp 'messages-buffer)
- (messages-buffer)
- (get-buffer-create "*Messages*"))
+ (with-current-buffer (messages-buffer)
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert ,timestamp str "\n")
@@ -478,7 +471,7 @@ displayed in the echo area."
(message "%s" (concat ,timestamp str))
str))
(t
- (apply 'message ,format-string ,args)))))))
+ (apply #'message ,format-string ,args)))))))
(defvar gnus-action-message-log nil)
@@ -498,8 +491,8 @@ inside loops."
(if (<= level gnus-verbose)
(let ((message
(if gnus-add-timestamp-to-message
- (apply 'gnus-message-with-timestamp args)
- (apply 'message args))))
+ (apply #'gnus-message-with-timestamp args)
+ (apply #'message args))))
(when (and (consp gnus-action-message-log)
(<= level 3))
(push message gnus-action-message-log))
@@ -520,7 +513,7 @@ inside loops."
"Beep an error if LEVEL is equal to or less than `gnus-verbose'.
ARGS are passed to `message'."
(when (<= (floor level) gnus-verbose)
- (apply 'message args)
+ (apply #'message args)
(ding)
(let (duration)
(when (and (floatp level)
@@ -688,6 +681,8 @@ yield \"nnimap:yxa\"."
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
[menu-bar edit] 'undefined))
+(defvar print-string-length)
+
(defmacro gnus-bind-print-variables (&rest forms)
"Bind print-* variables and evaluate FORMS.
This macro is used with `prin1', `pp', etc. in order to ensure
@@ -768,7 +763,7 @@ nil. See also `gnus-bind-print-variables'."
If there's no subdirectory, delete DIRECTORY as well."
(when (file-directory-p directory)
(let ((files (directory-files
- directory t (rx (or (not ".") "..."))))
+ directory t directory-files-no-dot-files-regexp))
file dir)
(while files
(setq file (pop files))
@@ -787,7 +782,7 @@ If there's no subdirectory, delete DIRECTORY as well."
string)
(defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
- "The same as `put-text-property', but don't put this prop on any newlines in the region."
+ "Like `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(save-excursion
(save-restriction
@@ -798,7 +793,7 @@ If there's no subdirectory, delete DIRECTORY as well."
(put-text-property beg (point) prop val)))))
(defsubst gnus-put-overlay-excluding-newlines (beg end prop val)
- "The same as `put-text-property', but don't put this prop on any newlines in the region."
+ "Like `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(save-excursion
(save-restriction
@@ -858,64 +853,10 @@ the user are disabled, it is recommended that only the most minimal
operations are performed by FORMS. If you wish to assign many
complicated values atomically, compute the results into temporary
variables and then do only the assignment atomically."
+ (declare (indent 0) (debug t))
`(let ((inhibit-quit gnus-atomic-be-safe))
,@forms))
-(put 'gnus-atomic-progn 'lisp-indent-function 0)
-
-(defmacro gnus-atomic-progn-assign (protect &rest forms)
- "Evaluate FORMS, but ensure that the variables listed in PROTECT
-are not changed if anything in FORMS signals an error or otherwise
-non-locally exits. The variables listed in PROTECT are updated atomically.
-It is safe to use gnus-atomic-progn-assign with long computations.
-
-Note that if any of the symbols in PROTECT were unbound, they will be
-set to nil on a successful assignment. In case of an error or other
-non-local exit, it will still be unbound."
- (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
- (concat (symbol-name x)
- "-tmp"))
- x))
- protect))
- (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x)))
- temp-sym-map))
- (temp-sym-let (mapcar (lambda (x) (list (car x)
- `(and (boundp ',(cadr x))
- ,(cadr x))))
- temp-sym-map))
- (sym-temp-let sym-temp-map)
- (temp-sym-assign (apply 'append temp-sym-map))
- (sym-temp-assign (apply 'append sym-temp-map))
- (result (make-symbol "result-tmp")))
- `(let (,@temp-sym-let
- ,result)
- (let ,sym-temp-let
- (setq ,result (progn ,@forms))
- (setq ,@temp-sym-assign))
- (let ((inhibit-quit gnus-atomic-be-safe))
- (setq ,@sym-temp-assign))
- ,result)))
-
-(put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
-;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
-
-(defmacro gnus-atomic-setq (&rest pairs)
- "Similar to setq, except that the real symbols are only assigned when
-there are no errors. And when the real symbols are assigned, they are
-done so atomically. If other variables might be changed via side-effect,
-see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq
-with potentially long computations."
- (let ((tpairs pairs)
- syms)
- (while tpairs
- (push (car tpairs) syms)
- (setq tpairs (cddr tpairs)))
- `(gnus-atomic-progn-assign ,syms
- (setq ,@pairs))))
-
-;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
-
-
;;; Functions for saving to babyl/mail files.
(require 'rmail)
@@ -950,7 +891,7 @@ FILENAME exists and is Babyl format."
(setq rmail-default-rmail-file filename) ; 22
(setq rmail-default-file filename)) ; 23
(let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *Gnus-output*"))
+ (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))
;; Babyl rmail.el defines this, mbox does not.
(babyl (fboundp 'rmail-insert-rmail-file-header)))
(save-excursion
@@ -1015,6 +956,12 @@ FILENAME exists and is Babyl format."
(rmail-swap-buffers-maybe)
(rmail-maybe-set-message-counters))
(widen)
+ (unless babyl
+ (goto-char (point-max))
+ ;; Ensure we have a blank line before the next message.
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))
(narrow-to-region (point-max) (point-max)))
(insert-buffer-substring tmpbuf)
(when msg
@@ -1036,7 +983,7 @@ FILENAME exists and is Babyl format."
(require 'nnmail)
(setq filename (expand-file-name filename))
(let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (tmpbuf (gnus-get-buffer-create " *Gnus-output*")))
(save-excursion
;; Create the file, if it doesn't exist.
(when (and (not (get-file-buffer filename))
@@ -1108,19 +1055,24 @@ ARG is passed to the first function."
(defun gnus-run-hooks (&rest funcs)
"Does the same as `run-hooks', but saves the current buffer."
(save-current-buffer
- (apply 'run-hooks funcs)))
+ (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)))
+ (apply #'run-hook-with-args hook args)))
(defun gnus-run-mode-hooks (&rest funcs)
"Run `run-mode-hooks', saving the current buffer."
- (save-current-buffer (apply 'run-mode-hooks funcs)))
+ (save-current-buffer (apply #'run-mode-hooks funcs)))
;;; Various
+(defmacro gnus--\,@ (exp)
+ "Splice EXP's value (a list of Lisp forms) into the code."
+ (declare (debug t))
+ `(progn ,@(eval exp t)))
+
(defvar gnus-group-buffer) ; Compiler directive
(defun gnus-alive-p ()
"Say whether Gnus is running or not."
@@ -1179,7 +1131,7 @@ ARG is passed to the first function."
(maphash
(lambda (group active)
(when active
- (insert (format "%s %d %d y\n"
+ (insert (format "%S %d %d y\n"
(if full-names
group
(gnus-group-real-name group))
@@ -1193,6 +1145,7 @@ ARG is passed to the first function."
;; Fixme: Why not use `with-output-to-temp-buffer'?
(defmacro gnus-with-output-to-file (file &rest body)
+ (declare (indent 1) (debug t))
(let ((buffer (make-symbol "output-buffer"))
(size (make-symbol "output-buffer-size"))
(leng (make-symbol "output-buffer-length"))
@@ -1215,9 +1168,6 @@ ARG is passed to the first function."
(write-region (substring ,buffer 0 ,leng) nil ,file
,append 'no-msg))))))
-(put 'gnus-with-output-to-file 'lisp-indent-function 1)
-(put 'gnus-with-output-to-file 'edebug-form-spec '(form body))
-
(defun gnus-add-text-properties-when
(property value start end properties &optional object)
"Like `add-text-properties', only applied on where PROPERTY is VALUE."
@@ -1260,9 +1210,7 @@ ARG is passed to the first function."
(string-equal (downcase x) (downcase y)))))
(defcustom gnus-use-byte-compile t
- "If non-nil, byte-compile crucial run-time code.
-Setting it to nil has no effect after the first time `gnus-byte-compile'
-is run."
+ "If non-nil, byte-compile crucial run-time code."
:type 'boolean
:version "22.1"
:group 'gnus-various)
@@ -1270,13 +1218,8 @@ is run."
(defun gnus-byte-compile (form)
"Byte-compile FORM if `gnus-use-byte-compile' is non-nil."
(if gnus-use-byte-compile
- (progn
- (require 'bytecomp)
- (defalias 'gnus-byte-compile
- (lambda (form)
- (let ((byte-compile-warnings '(unresolved callargs redefine)))
- (byte-compile form))))
- (gnus-byte-compile form))
+ (let ((byte-compile-warnings '(unresolved callargs redefine)))
+ (byte-compile form))
form))
(defun gnus-remassoc (key alist)
@@ -1296,16 +1239,19 @@ sure of changing the value of `foo'."
(cons (cons key value) (gnus-remassoc key alist))
(gnus-remassoc key alist)))
+(defvar gnus-info-buffer)
+(declare-function gnus-configure-windows "gnus-win" (setting &optional force))
+
(defun gnus-create-info-command (node)
"Create a command that will go to info NODE."
- `(lambda ()
- (interactive)
- ,(concat "Enter the info system at node " node)
- (Info-goto-node ,node)
- (setq gnus-info-buffer (current-buffer))
- (gnus-configure-windows 'info)))
-
-(defun gnus-not-ignore (&rest args)
+ (lambda ()
+ (:documentation (format "Enter the info system at node %s." node))
+ (interactive)
+ (info node)
+ (setq gnus-info-buffer (current-buffer))
+ (gnus-configure-windows 'info)))
+
+(defun gnus-not-ignore (&rest _args)
t)
(defvar gnus-directory-sep-char-regexp "/"
@@ -1357,7 +1303,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
`(,spec elem))
((listp spec)
(if (memq (car spec) '(or and not))
- `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
+ `(,(car spec) ,@(mapcar #'gnus-make-predicate-1 (cdr spec)))
(error "Invalid predicate specifier: %s" spec)))))
(defun gnus-completing-read (prompt collection &optional require-match
@@ -1387,8 +1333,10 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
(declare-function iswitchb-read-buffer "iswitchb"
(prompt &optional default require-match
_predicate start matches-set))
+(declare-function iswitchb-minibuffer-setup "iswitchb")
(defvar iswitchb-temp-buflist)
(defvar iswitchb-mode)
+(defvar iswitchb-make-buflist-hook)
(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
initial-input history def)
@@ -1409,16 +1357,14 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
(unwind-protect
(progn
(or iswitchb-mode
- (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+ (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)))))
-
-(put 'gnus-parse-without-error 'lisp-indent-function 0)
-(put 'gnus-parse-without-error 'edebug-form-spec '(body))
+ (remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)))))
(defmacro gnus-parse-without-error (&rest body)
"Allow continuing onto the next line even if an error occurs."
+ (declare (indent 0) (debug t))
`(while (not (eobp))
(condition-case ()
(progn
@@ -1453,11 +1399,12 @@ CHOICE is a list of the choice char and help message at IDX."
prompt
(concat
(mapconcat (lambda (s) (char-to-string (car s)))
- choice ", ") ", ?"))
+ choice ", ")
+ ", ?"))
(setq tchar (read-char))
(when (not (assq tchar choice))
(setq tchar nil)
- (setq buf (get-buffer-create "*Gnus Help*"))
+ (setq buf (gnus-get-buffer-create "*Gnus Help*"))
(pop-to-buffer buf)
(fundamental-mode)
(buffer-disable-undo)
@@ -1509,7 +1456,7 @@ Return nil otherwise."
(defvar tool-bar-mode)
-(defun gnus-tool-bar-update (&rest ignore)
+(defun gnus-tool-bar-update (&rest _ignore)
"Update the tool bar."
(when (and (boundp 'tool-bar-mode)
tool-bar-mode)
@@ -1535,7 +1482,7 @@ sequence, this is like `mapcar'. With several, it is like the Common Lisp
(if seqs2_n
(let* ((seqs (cons seq1 seqs2_n))
(cnt 0)
- (heads (mapcar (lambda (seq)
+ (heads (mapcar (lambda (_seq)
(make-symbol (concat "head"
(int-to-string
(setq cnt (1+ cnt))))))
@@ -1569,7 +1516,7 @@ sequence, this is like `mapcar'. With several, it is like the Common Lisp
((memq 'type lst)
(symbol-name system-type))
(t nil)))
- codename)
+ ) ;; codename
(cond
((not (memq 'emacs lst))
nil)
@@ -1585,9 +1532,9 @@ sequence, this is like `mapcar'. With several, it is like the Common Lisp
empty directories from OLD-PATH."
(when (file-exists-p old-path)
(let* ((old-dir (file-name-directory old-path))
- (old-name (file-name-nondirectory old-path))
+ ;; (old-name (file-name-nondirectory old-path))
(new-dir (file-name-directory new-path))
- (new-name (file-name-nondirectory new-path))
+ ;; (new-name (file-name-nondirectory new-path))
temp)
(gnus-make-directory new-dir)
(rename-file old-path new-path t)
@@ -1601,17 +1548,17 @@ empty directories from OLD-PATH."
(file-truename
(concat old-dir "..")))))))))
-(defun gnus-set-file-modes (filename mode)
+(defun gnus-set-file-modes (filename mode &optional flag)
"Wrapper for set-file-modes."
(ignore-errors
- (set-file-modes filename mode)))
+ (set-file-modes filename mode flag)))
(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 (not (display-graphic-p))
- image
+ (when (display-images-p)
+ (declare-function image-size "image.c" (spec &optional pixels frame))
(let ((new-width (car size))
(new-height (cdr size)))
(when (> (cdr (image-size image t)) new-height)
@@ -1619,8 +1566,8 @@ Sizes are in pixels."
:max-height new-height)))
(when (> (car (image-size image t)) new-width)
(setq image (create-image (plist-get (cdr image) :data) nil t
- :max-width new-width)))
- image)))
+ :max-width new-width)))))
+ image)
(defun gnus-recursive-directory-files (dir)
"Return all regular files below DIR.
@@ -1654,6 +1601,7 @@ The first found will be returned if a file has hard or symbolic links."
"To each element of LIST apply PREDICATE.
Return nil if LIST is no list or is empty or some test returns nil;
otherwise, return t."
+ (declare (obsolete nil "28.1"))
(when (and list (listp list))
(let ((result (mapcar predicate list)))
(not (memq nil result)))))
@@ -1687,7 +1635,7 @@ lists of strings."
(setq props (plist-put props :foreground (face-foreground face)))
(setq props (plist-put props :background (face-background face))))
(ignore-errors
- (apply 'create-image file type data-p props))))
+ (apply #'create-image file type data-p props))))
(defun gnus-put-image (glyph &optional string category)
(let ((point (point)))
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index 46d6680c26b..ceb2ebcdcb1 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -1,4 +1,4 @@
-;;; gnus-uu.el --- extract (uu)encoded files in Gnus
+;;; gnus-uu.el --- extract (uu)encoded files in Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1987, 1993-1998, 2000-2021 Free Software
;; Foundation, Inc.
@@ -162,7 +162,7 @@ Note that this variable can be used in conjunction with the
(regexp :format "%v")))
(defcustom gnus-uu-ignore-files-by-type nil
- "A regular expression saying what files that shouldn't be viewed, based on MIME file type.
+ "Regexp matching files that shouldn't be viewed, based on MIME file type.
If, for instance, you want gnus-uu to ignore all audio files and all mpegs,
you could say something like
@@ -224,7 +224,7 @@ Default is \"/tmp/\"."
:type 'directory)
(defcustom gnus-uu-do-not-unpack-archives nil
- "Non-nil means that gnus-uu won't peek inside archives looking for files to display.
+ "If non-nil, gnus-uu won't peek inside archives looking for files to display.
Default is nil."
:group 'gnus-extract-archive
:type 'boolean)
@@ -265,19 +265,19 @@ it nil."
:type 'boolean)
(defcustom gnus-uu-unmark-articles-not-decoded nil
- "Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread.
+ "If non-nil, gnus-uu will mark unsuccessfully decoded articles as unread.
Default is nil."
:group 'gnus-extract
:type 'boolean)
(defcustom gnus-uu-correct-stripped-uucode nil
- "Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted.
+ "If non-nil, *try* to fix uuencoded files that have had trailing spaces deleted.
Default is nil."
:group 'gnus-extract
:type 'boolean)
(defcustom gnus-uu-save-in-digest nil
- "Non-nil means that gnus-uu, when asked to save without decoding, will save in digests.
+ "If non-nil, gnus-uu, when asked to save without decoding, will save in digests.
If this variable is nil, gnus-uu will just save everything in a
file without any embellishments. The digesting almost conforms to RFC1153 -
no easy way to specify any meaningful volume and issue numbers were found,
@@ -355,8 +355,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-uu-decode-uu (&optional n)
"Uudecodes the current article."
- (interactive "P")
- (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n))
+ (interactive "P" gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-uustrip-article n))
(defun gnus-uu-decode-uu-and-save (n dir)
"Decodes and saves the resulting file."
@@ -364,14 +364,15 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(file-name-as-directory
(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))
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-uustrip-article n dir nil nil t))
(defun gnus-uu-decode-unshar (&optional n)
"Unshars the current article."
- (interactive "P")
- (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan t))
+ (interactive "P" gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-unshar-article n nil nil 'scan t))
(defun gnus-uu-decode-unshar-and-save (n dir)
"Unshars and saves the current article."
@@ -379,9 +380,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(file-name-as-directory
(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))
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-unshar-article n dir nil 'scan t))
(defun gnus-uu-decode-save (n file)
"Saves the current article."
@@ -391,9 +393,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(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))))
+ "Save article in file: " gnus-uu-default-dir gnus-uu-default-dir)))
+ gnus-article-mode gnus-summary-mode)
(setq gnus-uu-saved-article-name file)
- (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t))
+ (gnus-uu-decode-with-method #'gnus-uu-save-article n nil t))
(defun gnus-uu-decode-binhex (n dir)
"Unbinhexes the current article."
@@ -401,12 +404,13 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(file-name-as-directory
(read-directory-name "Unbinhex and save in dir: "
- gnus-uu-default-dir
- gnus-uu-default-dir))))
+ gnus-uu-default-dir
+ gnus-uu-default-dir)))
+ gnus-article-mode gnus-summary-mode)
(gnus-uu-initialize)
(setq gnus-uu-binhex-article-name
(make-temp-file (expand-file-name "binhex" gnus-uu-work-dir)))
- (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir))
+ (gnus-uu-decode-with-method #'gnus-uu-binhex-article n dir))
(defun gnus-uu-decode-yenc (n dir)
"Decode the yEnc-encoded current article."
@@ -414,14 +418,15 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(file-name-as-directory
(read-directory-name "yEnc decode and save in dir: "
- gnus-uu-default-dir
- gnus-uu-default-dir))))
+ gnus-uu-default-dir
+ gnus-uu-default-dir)))
+ gnus-article-mode gnus-summary-mode)
(setq gnus-uu-yenc-article-name nil)
- (gnus-uu-decode-with-method 'gnus-uu-yenc-article n dir nil t))
+ (gnus-uu-decode-with-method #'gnus-uu-yenc-article n dir nil t))
(defun gnus-uu-decode-uu-view (&optional n)
"Uudecodes and views the current article."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-uu n)))
@@ -431,13 +436,14 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(read-file-name "Uudecode, view and save in dir: "
gnus-uu-default-dir
- gnus-uu-default-dir t)))
+ gnus-uu-default-dir t))
+ gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-uu-and-save n dir)))
(defun gnus-uu-decode-unshar-view (&optional n)
"Unshars and views the current article."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-unshar n)))
@@ -447,7 +453,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(read-file-name "Unshar, view and save in dir: "
gnus-uu-default-dir
- gnus-uu-default-dir t)))
+ gnus-uu-default-dir t))
+ gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-unshar-and-save n dir)))
@@ -459,7 +466,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(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))))
+ gnus-uu-default-dir gnus-uu-default-dir)))
+ gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-save n file)))
@@ -468,7 +476,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(read-file-name "Unbinhex, view and save in dir: "
- gnus-uu-default-dir gnus-uu-default-dir)))
+ gnus-uu-default-dir gnus-uu-default-dir))
+ gnus-article-mode gnus-summary-mode)
(gnus-uu-initialize)
(setq gnus-uu-binhex-article-name
(make-temp-file (expand-file-name "binhex" gnus-uu-work-dir)))
@@ -480,7 +489,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-uu-digest-mail-forward (&optional n post)
"Digests and forwards all articles in this series."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(gnus-uu-initialize)
(let ((gnus-uu-save-in-digest t)
(file (make-temp-file (nnheader-concat gnus-uu-work-dir "forward")))
@@ -546,7 +555,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-uu-digest-post-forward (&optional n)
"Digest and forward to a newsgroup."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(gnus-uu-digest-mail-forward n t))
;; Process marking.
@@ -569,14 +578,14 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-new-processable (unmarkp articles)
(if unmarkp
- (gnus-intersection gnus-newsgroup-processable articles)
- (gnus-set-difference articles gnus-newsgroup-processable)))
+ (nreverse (seq-intersection gnus-newsgroup-processable articles #'eq))
+ (seq-difference articles gnus-newsgroup-processable #'eq)))
(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
"Set the process mark on articles whose subjects match REGEXP.
When called interactively, prompt for REGEXP.
Optional UNMARK non-nil means unmark instead of mark."
- (interactive "sMark (regexp): \nP")
+ (interactive "sMark (regexp): \nP" gnus-article-mode gnus-summary-mode)
(save-excursion
(let* ((articles (gnus-uu-find-articles-matching regexp))
(new-marked (gnus-new-processable unmark articles)))
@@ -590,12 +599,12 @@ Optional UNMARK non-nil means unmark instead of mark."
(defun gnus-uu-unmark-by-regexp (regexp)
"Remove the process mark from articles whose subjects match REGEXP.
When called interactively, prompt for REGEXP."
- (interactive "sUnmark (regexp): ")
+ (interactive "sUnmark (regexp): " gnus-article-mode gnus-summary-mode)
(gnus-uu-mark-by-regexp regexp t))
(defun gnus-uu-mark-series (&optional silent)
"Mark the current series with the process mark."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let* ((articles (gnus-uu-find-articles-matching))
(l (length articles)))
(while articles
@@ -608,7 +617,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-mark-region (beg end &optional unmark)
"Set the process mark on all articles between point and mark."
- (interactive "r")
+ (interactive "r" gnus-article-mode gnus-summary-mode)
(save-excursion
(goto-char beg)
(while (< (point) end)
@@ -620,22 +629,22 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-unmark-region (beg end)
"Remove the process mark from all articles between point and mark."
- (interactive "r")
+ (interactive "r" gnus-article-mode gnus-summary-mode)
(gnus-uu-mark-region beg end t))
(defun gnus-uu-mark-buffer ()
"Set the process mark on all articles in the buffer."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-uu-mark-region (point-min) (point-max)))
(defun gnus-uu-unmark-buffer ()
"Remove the process mark on all articles in the buffer."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-uu-mark-region (point-min) (point-max) t))
(defun gnus-uu-mark-thread ()
"Marks all articles downwards in this thread."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(gnus-save-hidden-threads
(let ((level (gnus-summary-thread-level)))
(while (and (gnus-summary-set-process-mark (gnus-summary-article-number))
@@ -646,7 +655,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-unmark-thread ()
"Unmarks all articles downwards in this thread."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((level (gnus-summary-thread-level)))
(while (and (gnus-summary-remove-process-mark
(gnus-summary-article-number))
@@ -656,7 +665,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-invert-processable ()
"Invert the list of process-marked articles."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((data gnus-newsgroup-data)
number)
(save-excursion
@@ -669,7 +678,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-mark-over (&optional score)
"Mark all articles with a score over SCORE (the prefix)."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((score (or score gnus-summary-default-score 0))
(data gnus-newsgroup-data))
(save-excursion
@@ -684,7 +693,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-mark-sparse ()
"Mark all series that have some articles marked."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(let ((marked (nreverse gnus-newsgroup-processable))
subject articles total headers)
(unless marked
@@ -708,7 +717,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-mark-all ()
"Mark all articles in \"series\" order."
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(setq gnus-newsgroup-processable nil)
(save-excursion
(let ((data gnus-newsgroup-data)
@@ -728,33 +737,33 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-decode-postscript (&optional n)
"Gets PostScript of the current article."
- (interactive "P")
- (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n))
+ (interactive "P" gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-decode-postscript-article n))
(defun gnus-uu-decode-postscript-view (&optional n)
"Gets and views the current article."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-postscript n)))
(defun gnus-uu-decode-postscript-and-save (n dir)
"Extracts PostScript and saves the current article."
- (interactive
- (list current-prefix-arg
- (file-name-as-directory
- (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
+ (interactive (list current-prefix-arg
+ (file-name-as-directory
+ (read-directory-name "Save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ gnus-article-mode gnus-summary-mode)
+ (gnus-uu-decode-with-method #'gnus-uu-decode-postscript-article
n dir nil nil t))
(defun gnus-uu-decode-postscript-and-save-view (n dir)
"Decodes, views and saves the resulting file."
- (interactive
- (list current-prefix-arg
- (read-file-name "Where do you want to save the file(s)? "
- gnus-uu-default-dir
- gnus-uu-default-dir t)))
+ (interactive (list current-prefix-arg
+ (read-file-name "Where do you want to save the file(s)? "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t))
+ gnus-article-mode gnus-summary-mode)
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-postscript-and-save n dir)))
@@ -977,7 +986,7 @@ When called interactively, prompt for REGEXP."
(defvar gnus-uu-binhex-end-line
":$")
-(defun gnus-uu-binhex-article (buffer in-state)
+(defun gnus-uu-binhex-article (buffer _in-state)
(let (state start-char)
(with-current-buffer buffer
(widen)
@@ -1014,11 +1023,11 @@ When called interactively, prompt for REGEXP."
;; yEnc
-(defun gnus-uu-yenc-article (buffer in-state)
+(defun gnus-uu-yenc-article (_buffer _in-state)
(with-current-buffer gnus-original-article-buffer
(widen)
(let ((file-name (yenc-extract-filename))
- state start-char)
+ state) ;; start-char
(when (not file-name)
(setq state (list 'wrong-type)))
@@ -1046,7 +1055,7 @@ When called interactively, prompt for REGEXP."
;; PostScript
-(defun gnus-uu-decode-postscript-article (process-buffer in-state)
+(defun gnus-uu-decode-postscript-article (process-buffer _in-state)
(let ((state (list 'ok))
start-char end-char file-name)
(with-current-buffer process-buffer
@@ -1196,11 +1205,11 @@ When called interactively, prompt for REGEXP."
;; Expand numbers, sort, and return the list of article
;; numbers.
- (mapcar 'cdr
+ (mapcar #'cdr
(sort (gnus-uu-expand-numbers
list-of-subjects
(not do-not-translate))
- 'gnus-uu-string<))))))
+ #'gnus-uu-string<))))))
(defun gnus-uu-expand-numbers (string-list &optional translate)
;; Takes a list of strings and "expands" all numbers in all the
@@ -1278,13 +1287,15 @@ When called interactively, prompt for REGEXP."
(when dont-unmark-last-article
(setq gnus-uu-has-been-grabbed (list art))))))
+(defvar gnus-asynchronous)
+
;; This function takes a list of articles and a function to apply to
;; each article grabbed.
;;
;; This function returns a list of files decoded if the grabbing and
;; the process-function has been successful and nil otherwise.
(defun gnus-uu-grab-articles (articles process-function
- &optional sloppy limit no-errors)
+ &optional sloppy limit _no-errors)
(require 'gnus-async)
(let ((state 'first)
(gnus-asynchronous nil)
@@ -1452,10 +1463,10 @@ When called interactively, prompt for REGEXP."
(setq subject (substring subject (match-end 0)))))
(or part "")))
-(defun gnus-uu-uudecode-sentinel (process event)
+(defun gnus-uu-uudecode-sentinel (process _event)
(delete-process (get-process process)))
-(defun gnus-uu-uustrip-article (process-buffer in-state)
+(defun gnus-uu-uustrip-article (process-buffer _in-state)
;; Uudecodes a file asynchronously.
(with-current-buffer process-buffer
(let ((state (list 'wrong-type))
@@ -1576,7 +1587,7 @@ Gnus might fail to display all of it.")
;; This function is used by `gnus-uu-grab-articles' to treat
;; a shared article.
-(defun gnus-uu-unshar-article (process-buffer in-state)
+(defun gnus-uu-unshar-article (process-buffer _in-state)
(let ((state (list 'ok))
start-char)
(with-current-buffer process-buffer
@@ -1587,8 +1598,7 @@ Gnus might fail to display all of it.")
(save-excursion
(switch-to-buffer (current-buffer))
(delete-other-windows)
- (let ((buffer (get-buffer-create (generate-new-buffer-name
- "*Warning*"))))
+ (let ((buffer (generate-new-buffer "*Warning*")))
(unless
(unwind-protect
(with-current-buffer buffer
@@ -1674,7 +1684,7 @@ Gnus might fail to display all of it.")
did-unpack))
(defun gnus-uu-dir-files (dir)
- (let ((dirs (directory-files dir t (rx (or (not ".") "..."))))
+ (let ((dirs (directory-files dir t directory-files-no-dot-files-regexp))
files file)
(while dirs
(if (file-directory-p (setq file (car dirs)))
@@ -1781,8 +1791,8 @@ Gnus might fail to display all of it.")
gnus-uu-tmp-dir)))
(setq gnus-uu-work-dir
- (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))
- (gnus-set-file-modes gnus-uu-work-dir 448)
+ (with-file-modes #o700
+ (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)))
(setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))
(push (cons gnus-newsgroup-name gnus-uu-work-dir)
gnus-uu-tmp-alist))))
@@ -1831,8 +1841,8 @@ Gnus might fail to display all of it.")
;; Initializing
-(add-hook 'gnus-summary-prepare-exit-hook 'gnus-uu-clean-up)
-(add-hook 'gnus-summary-prepare-exit-hook 'gnus-uu-delete-work-dir)
+(add-hook 'gnus-summary-prepare-exit-hook #'gnus-uu-clean-up)
+(add-hook 'gnus-summary-prepare-exit-hook #'gnus-uu-delete-work-dir)
@@ -1858,7 +1868,7 @@ uuencode and adds MIME headers."
(function :tag "Other")))
(defcustom gnus-uu-post-include-before-composing nil
- "Non-nil means that gnus-uu will ask for a file to encode before you compose the article.
+ "If non-nil, gnus-uu asks for a file to encode before you compose the article.
If this variable is t, you can either include an encoded file with
\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article."
:group 'gnus-extract-post
@@ -1950,6 +1960,7 @@ The user will be asked for a file name."
(gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)
file-name))
(insert (format "Content-Transfer-Encoding: %s\n\n" encoding))
+ ;; FIXME: Shouldn't we set-buffer before saving the restriction? --Stef
(save-restriction
(set-buffer gnus-message-buffer)
(goto-char (point-min))
diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el
index 533b1e2a580..ec3601109e9 100644
--- a/lisp/gnus/gnus-vm.el
+++ b/lisp/gnus/gnus-vm.el
@@ -1,4 +1,4 @@
-;;; gnus-vm.el --- vm interface for Gnus
+;;; gnus-vm.el --- vm interface for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
@@ -72,7 +72,7 @@ If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(require 'gnus-art)
(let ((gnus-default-article-saver 'gnus-summary-save-in-vm))
(gnus-summary-save-article arg)))
@@ -80,7 +80,7 @@ save those articles instead."
(declare-function vm-save-message "ext:vm-save" (folder &optional count))
(defun gnus-summary-save-in-vm (&optional folder)
- (interactive)
+ (interactive nil gnus-article-mode gnus-summary-mode)
(require 'vm)
(setq folder
(gnus-read-save-file-name
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 8ca3e7230a3..8ac4e39fa52 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -1,4 +1,4 @@
-;;; gnus-win.el --- window configuration functions for Gnus
+;;; gnus-win.el --- window configuration functions for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -36,7 +36,6 @@
(defcustom gnus-use-full-window t
"If non-nil, use the entire Emacs screen."
- :group 'gnus-windows
:type 'boolean)
(defcustom gnus-use-atomic-windows nil
@@ -46,17 +45,14 @@
(defcustom gnus-window-min-width 2
"Minimum width of Gnus buffers."
- :group 'gnus-windows
:type 'integer)
(defcustom gnus-window-min-height 1
"Minimum height of Gnus buffers."
- :group 'gnus-windows
:type 'integer)
(defcustom gnus-always-force-window-configuration nil
"If non-nil, always force the Gnus window configurations."
- :group 'gnus-windows
:type 'boolean)
(defcustom gnus-use-frames-on-any-display nil
@@ -64,11 +60,10 @@
When nil, only frames on the same display as the selected frame will be
used to display Gnus windows."
:version "22.1"
- :group 'gnus-windows
:type 'boolean)
(defvar gnus-buffer-configuration
- '((group
+ `((group
(vertical 1.0
(group 1.0 point)))
(summary
@@ -142,10 +137,9 @@ used to display Gnus windows."
(pipe
(vertical 1.0
(summary 0.25 point)
- ("*Shell Command Output*" 1.0)))
+ (,shell-command-buffer-name 1.0)))
(bug
(vertical 1.0
- (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
("*Gnus Bug*" 1.0 point)))
(score-trace
(vertical 1.0
@@ -203,7 +197,6 @@ See the Gnus manual for an explanation of the syntax used.")
(defcustom gnus-configure-windows-hook nil
"A hook called when configuring windows."
:version "22.1"
- :group 'gnus-windows
:type 'hook)
;;; Internal variables.
@@ -253,7 +246,7 @@ See the Gnus manual for an explanation of the syntax used.")
;; return a new SPLIT.
(while (and (not (assq (car split) gnus-window-to-buffer))
(symbolp (car split)) (fboundp (car split)))
- (setq split (eval split)))
+ (setq split (eval split t)))
(let* ((type (car split))
(subs (cddr split))
(len (if (eq type 'horizontal) (window-width) (window-height)))
@@ -330,7 +323,7 @@ See the Gnus manual for an explanation of the syntax used.")
(setq sub (append (pop subs) nil))
(while (and (not (assq (car sub) gnus-window-to-buffer))
(symbolp (car sub)) (fboundp (car sub)))
- (setq sub (eval sub)))
+ (setq sub (eval sub t)))
(when sub
(push sub comp-subs)
(setq size (cadar comp-subs))
@@ -478,7 +471,7 @@ should have point."
;; return a new SPLIT.
(while (and (not (assq (car split) gnus-window-to-buffer))
(symbolp (car split)) (fboundp (car split)))
- (setq split (eval split)))
+ (setq split (eval split t)))
(setq type (elt split 0))
(cond
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 595c2a402b6..8b93accccad 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -292,6 +292,10 @@ is restarted, and sometimes reloaded."
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
+(defgroup gnus-dbus nil
+ "D-Bus integration for Gnus."
+ :group 'gnus)
+
(defconst gnus-version-number "5.13"
"Version number for this version of Gnus.")
@@ -305,34 +309,29 @@ be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
-(defvar gnus-mode-line-image-cache t)
-
-(eval-and-compile
- (if (fboundp 'find-image)
- (defun gnus-mode-line-buffer-identification (line)
- (let ((str (car-safe line))
- (load-path (append (mm-image-load-path) load-path)))
- (if (and (display-graphic-p)
- (stringp str)
- (string-match "^Gnus:" str))
- (progn (add-text-properties
- 0 5
- (list 'display
- (if (eq t gnus-mode-line-image-cache)
- (setq gnus-mode-line-image-cache
- (find-image
- '((:type xpm :file "gnus-pointer.xpm"
- :ascent center)
- (:type xbm :file "gnus-pointer.xbm"
- :ascent center))))
- gnus-mode-line-image-cache)
- 'help-echo (format
- "This is %s, %s."
- gnus-version (gnus-emacs-version)))
- str)
- (list str))
- line)))
- (defalias 'gnus-mode-line-buffer-identification 'identity)))
+(defun gnus-mode-line-buffer-identification (line)
+ (let ((str (car-safe line)))
+ (if (or (not (fboundp 'find-image))
+ (not (display-graphic-p))
+ (not (stringp str))
+ (not (string-match "^Gnus:" str)))
+ line
+ (let ((load-path (append (mm-image-load-path) load-path)))
+ ;; Add the Gnus logo.
+ (add-text-properties
+ 0 5
+ (list 'display
+ (find-image
+ '((:type xpm :file "gnus-pointer.xpm"
+ :ascent center)
+ (:type xbm :file "gnus-pointer.xbm"
+ :ascent center))
+ t)
+ 'help-echo (format
+ "This is %s, %s."
+ gnus-version (gnus-emacs-version)))
+ str)
+ (list str)))))
;; We define these group faces here to avoid the display
;; update forced when creating new faces.
@@ -526,25 +525,26 @@ be set in `.emacs' instead."
;; Summary mode faces.
-(defface gnus-summary-selected '((t (:underline t)))
+(defface gnus-summary-selected '((t (:underline t :extend t)))
"Face used for selected articles."
:group 'gnus-summary)
(defface gnus-summary-cancelled
'((((class color))
- (:foreground "yellow" :background "black")))
+ (:foreground "yellow" :background "black" :extend t))
+ (t (:extend t)))
"Face used for canceled articles."
:group 'gnus-summary)
(defface gnus-summary-normal-ticked
'((((class color)
(background dark))
- (:foreground "pink"))
+ (:foreground "pink" :extend t))
(((class color)
(background light))
- (:foreground "firebrick"))
+ (:foreground "firebrick" :extend t))
(t
- ()))
+ (:extend t)))
"Face used for normal interest ticked articles."
:group 'gnus-summary)
@@ -561,12 +561,12 @@ be set in `.emacs' instead."
(defface gnus-summary-normal-ancient
'((((class color)
(background dark))
- (:foreground "SkyBlue"))
+ (:foreground "SkyBlue" :extend t))
(((class color)
(background light))
- (:foreground "RoyalBlue"))
+ (:foreground "RoyalBlue" :extend t))
(t
- ()))
+ (:extend t)))
"Face used for normal interest ancient articles."
:group 'gnus-summary)
@@ -583,10 +583,10 @@ be set in `.emacs' instead."
(defface gnus-summary-normal-undownloaded
'((((class color)
(background light))
- (:foreground "cyan4" :bold nil))
+ (:foreground "cyan4" :bold nil :extend t))
(((class color) (background dark))
- (:foreground "LightGray" :bold nil))
- (t (:inverse-video t)))
+ (:foreground "LightGray" :bold nil :extend t))
+ (t (:inverse-video t :extend t)))
"Face used for normal interest uncached articles."
:group 'gnus-summary)
@@ -602,7 +602,7 @@ be set in `.emacs' instead."
(defface gnus-summary-normal-unread
'((t
- ()))
+ (:extend t)))
"Face used for normal interest unread articles."
:group 'gnus-summary)
@@ -619,12 +619,12 @@ be set in `.emacs' instead."
(defface gnus-summary-normal-read
'((((class color)
(background dark))
- (:foreground "PaleGreen"))
+ (:foreground "PaleGreen" :extend t))
(((class color)
(background light))
- (:foreground "DarkGreen"))
+ (:foreground "DarkGreen" :extend t))
(t
- ()))
+ (:extend t)))
"Face used for normal interest read articles."
:group 'gnus-summary)
@@ -660,7 +660,7 @@ be used directly.")
(defun gnus-add-buffer ()
"Add the current buffer to the list of Gnus buffers."
(gnus-prune-buffers)
- (push (current-buffer) gnus-buffers))
+ (cl-pushnew (current-buffer) gnus-buffers))
(defmacro gnus-kill-buffer (buffer)
"Kill BUFFER and remove from the list of Gnus buffers."
@@ -849,12 +849,6 @@ be used directly.")
(cons (car list) (list :type type :data data)))
list)))
-(let ((command (format "%s" this-command)))
- (when (string-match "gnus" command)
- (if (eq 'gnus-other-frame this-command)
- (gnus-get-buffer-create gnus-group-buffer)
- (gnus-splash))))
-
;;; Do the rest.
(require 'gnus-util)
@@ -1029,8 +1023,7 @@ Check the NNTPSERVER environment variable and the
;; `M-x customize-variable RET gnus-select-method RET' should work without
;; starting or even loading Gnus.
-;;;###autoload(when (fboundp 'custom-autoload)
-;;;###autoload (custom-autoload 'gnus-select-method "gnus"))
+;;;###autoload(custom-autoload 'gnus-select-method "gnus")
(defcustom gnus-select-method
(list 'nntp (or (gnus-getenv-nntpserver)
@@ -1146,7 +1139,7 @@ no need to set this variable."
:group 'gnus-message
:type '(choice (const :tag "default" nil)
string))
-(make-obsolete-variable 'gnus-local-domain nil "Emacs 24.1")
+(make-obsolete-variable 'gnus-local-domain nil "24.1")
;; Customization variables
@@ -1191,6 +1184,14 @@ newsgroups."
:group 'gnus-summary-marks
:type 'character)
+(defcustom gnus-process-mark-toggle t
+ "If nil the process mark command only sets the process mark."
+ :version "28.1"
+ :group 'gnus-summary
+ :group 'gnus-group-various
+ :group 'gnus-group-topic
+ :type 'boolean)
+
(defcustom gnus-large-newsgroup 200
"The number of articles which indicates a large newsgroup.
If the number of articles in a newsgroup is greater than this value,
@@ -1203,7 +1204,7 @@ Also see `gnus-large-ephemeral-newsgroup'."
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 file name 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
@@ -1553,7 +1554,7 @@ Use with caution.")
("\\(^\\|:\\)soc.culture.vietnamese\\>" vietnamese-viqr)
("\\(^\\|:\\)\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1))
:variable-document
- "Alist of regexps (to match group names) and default charsets to be used when reading."
+ "Alist of regexps (to match group names) and charsets to be used when reading."
:variable-group gnus-charset
:variable-type '(repeat (list (regexp :tag "Group")
(symbol :tag "Charset")))
@@ -1591,7 +1592,7 @@ posting an article."
"Alist of group regexps and its initial input of the number of articles."
:variable-group gnus-group-parameter
:parameter-type '(choice :tag "Initial Input for Large Newsgroup"
- (const :tag "All" nil)
+ (const :tag "All" 'all)
(integer))
:parameter-document "\
@@ -1610,7 +1611,7 @@ total number of articles in the group.")
:variable-default (mapcar
(lambda (g) (list g t))
'("delayed$" "drafts$" "queue$" "INBOX$"
- "^nnmairix:" "^nnir:" "archive"))
+ "^nnmairix:" "^nnselect:" "archive"))
:variable-document
"Groups in which the registry should be turned off."
:variable-group gnus-registry
@@ -1626,7 +1627,8 @@ total number of articles in the group.")
;; group parameters for spam processing added by Ted Zlatanov <tzz@lifelogs.com>
(defcustom gnus-install-group-spam-parameters t
"Disable the group parameters for spam detection.
-Enable if `G c' in XEmacs is giving you trouble, and make sure to submit a bug report."
+Enable if `G c' in XEmacs is giving you trouble, and make sure to
+submit a bug report."
:version "22.1"
:type 'boolean
:group 'gnus-start)
@@ -2226,8 +2228,8 @@ Disabling the agent may result in noticeable loss of performance."
:group 'gnus-start
:type '(choice (function-item gnus)
(function-item gnus-no-server)
- (function-item gnus-slave)
- (function-item gnus-slave-no-server)))
+ (function-item gnus-child)
+ (function-item gnus-child-no-server)))
(declare-function gnus-group-get-new-news "gnus-group")
@@ -2238,8 +2240,8 @@ Disabling the agent may result in noticeable loss of performance."
:type '(choice (function-item gnus)
(function-item gnus-group-get-new-news)
(function-item gnus-no-server)
- (function-item gnus-slave)
- (function-item gnus-slave-no-server)))
+ (function-item gnus-child)
+ (function-item gnus-child-no-server)))
(defcustom gnus-other-frame-parameters nil
"Frame parameters used by `gnus-other-frame' to create a Gnus frame."
@@ -2288,6 +2290,14 @@ a string, be sure to use a valid format, see RFC 2616."
(gnus-message 1 "Edit your init file to make this change permanent.")
(sit-for 2)))
+(defcustom gnus-agent-eagerly-store-articles t
+ "If non-nil, cache articles eagerly.
+
+When using the Gnus Agent and reading an agentized newsgroup,
+automatically cache the article in the agent cache."
+ :type 'boolean
+ :version "28.1")
+
;;; Internal variables
@@ -2309,7 +2319,7 @@ a string, be sure to use a valid format, see RFC 2616."
;; 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")
+(make-obsolete-variable 'gnus-carpal nil "24.1")
(defvar gnus-agent-fetching nil
"Whether Gnus agent is in fetching mode.")
@@ -2417,8 +2427,8 @@ such as a mark that says whether an article is stored in the cache
(defvar gnus-article-buffer "*Article*")
(defvar gnus-server-buffer "*Server*")
-(defvar gnus-slave nil
- "Whether this Gnus is a slave or not.")
+(defvar gnus-child nil
+ "Whether this Gnus is a child or not.")
(defvar gnus-batch-mode nil
"Whether this Gnus is running in batch mode or not.")
@@ -2512,7 +2522,7 @@ are always t.")
'(("info" :interactive t Info-goto-node)
("qp" quoted-printable-decode-region quoted-printable-decode-string)
("ps-print" ps-print-preprint)
- ("message" :interactive t
+ ("message" :interactive (message-mode)
message-send-and-exit message-yank-original)
("babel" babel-as-string)
("nnmail" nnmail-split-fancy nnmail-article-group)
@@ -2529,7 +2539,7 @@ are always t.")
("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-mh" :interactive (gnus-summary-mode) gnus-summary-save-in-folder)
("gnus-demon" gnus-demon-add-scanmail
gnus-demon-add-rescan gnus-demon-add-scan-timestamps
gnus-demon-add-disconnection gnus-demon-add-handler
@@ -2544,7 +2554,7 @@ are always t.")
("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-cite" :interactive (gnus-article-mode gnus-summary-mode)
gnus-article-highlight-citation gnus-article-hide-citation-maybe
gnus-article-hide-citation gnus-article-fill-cited-article
gnus-article-hide-citation-in-followups
@@ -2560,29 +2570,34 @@ are always t.")
gnus-cache-enter-remove-article gnus-cached-article-p
gnus-cache-open gnus-cache-close gnus-cache-update-article
gnus-cache-articles-in-group)
- ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
+ ("gnus-cache" :interactive (gnus-summary-mode)
+ gnus-summary-insert-cached-articles gnus-cache-enter-article
gnus-cache-remove-article gnus-summary-insert-cached-articles)
+ ("gnus-cache" :interactive t gnus-jog-cache)
("gnus-score" :interactive t
+ gnus-score-flush-cache gnus-score-close)
+ ("gnus-score" :interactive (gnus-summary-mode)
gnus-summary-increase-score gnus-summary-set-score
gnus-summary-raise-thread gnus-summary-raise-same-subject
gnus-summary-raise-score gnus-summary-raise-same-subject-and-select
gnus-summary-lower-thread gnus-summary-lower-same-subject
gnus-summary-lower-score gnus-summary-lower-same-subject-and-select
gnus-summary-current-score gnus-score-delta-default
- gnus-score-flush-cache gnus-score-close
gnus-possibly-score-headers gnus-score-followup-article
gnus-score-followup-thread)
("gnus-score"
(gnus-summary-score-map keymap) gnus-score-save gnus-score-headers
gnus-current-score-file-nondirectory gnus-score-adaptive
gnus-score-find-trace gnus-score-file-name)
- ("gnus-cus" :interactive t gnus-group-customize gnus-score-customize)
- ("gnus-topic" :interactive t gnus-topic-mode)
+ ("gnus-cus" :interactive (gnus-group-mode) gnus-group-customize)
+ ("gnus-cus" :interactive (gnus-summary-mode) gnus-score-customize)
+ ("gnus-topic" :interactive (gnus-group-mode) gnus-topic-mode)
("gnus-topic" gnus-topic-remove-group gnus-topic-set-parameters
gnus-subscribe-topics)
- ("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode)
+ ("gnus-salt" :interactive (gnus-summary-mode)
+ gnus-pick-mode gnus-binary-mode)
("gnus-uu" (gnus-uu-extract-map keymap) (gnus-uu-mark-map keymap))
- ("gnus-uu" :interactive t
+ ("gnus-uu" :interactive (gnus-article-mode gnus-summary-mode)
gnus-uu-digest-mail-forward gnus-uu-digest-post-forward
gnus-uu-mark-series gnus-uu-mark-region gnus-uu-mark-buffer
gnus-uu-mark-by-regexp gnus-uu-mark-all
@@ -2597,12 +2612,13 @@ are always t.")
("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread)
("gnus-msg" (gnus-summary-send-map keymap)
gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
- ("gnus-msg" :interactive t
- gnus-group-post-news gnus-group-mail gnus-group-news
+ ("gnus-msg" :interactive (gnus-group-mode)
+ gnus-group-post-news gnus-group-mail gnus-group-news)
+ ("gnus-msg" :interactive (gnus-summary-mode)
gnus-summary-post-news gnus-summary-news-other-window
gnus-summary-followup gnus-summary-followup-with-original
gnus-summary-cancel-article gnus-summary-supersede-article
- gnus-post-news gnus-summary-reply gnus-summary-reply-with-original
+ gnus-summary-reply gnus-summary-reply-with-original
gnus-summary-mail-forward gnus-summary-mail-other-window
gnus-summary-resend-message gnus-summary-resend-bounced-mail
gnus-summary-wide-reply gnus-summary-followup-to-mail
@@ -2610,7 +2626,9 @@ are always t.")
gnus-summary-wide-reply-with-original
gnus-summary-post-forward gnus-summary-wide-reply-with-original
gnus-summary-post-forward)
- ("gnus-picon" :interactive t gnus-treat-from-picon)
+ ("gnus-msg" gnus-post-news)
+ ("gnus-picon" :interactive (gnus-article-mode gnus-summary-mode)
+ gnus-treat-from-picon)
("smiley" :interactive t smiley-region)
("gnus-win" gnus-configure-windows gnus-add-configuration)
("gnus-sum" gnus-summary-insert-line gnus-summary-read-group
@@ -2633,7 +2651,7 @@ are always t.")
gnus-request-article-this-buffer gnus-article-mode
gnus-article-setup-buffer gnus-narrow-to-page
gnus-article-delete-invisible-text gnus-treat-article)
- ("gnus-art" :interactive t
+ ("gnus-art" :interactive (gnus-summary-mode gnus-article-mode)
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-remove-cr gnus-article-remove-trailing-blank-lines
@@ -2645,7 +2663,6 @@ are always t.")
gnus-article-hide-pem gnus-article-hide-signature
gnus-article-strip-leading-blank-lines gnus-article-date-local
gnus-article-date-original gnus-article-date-lapsed
- ;;gnus-article-show-all-headers
gnus-article-edit-mode gnus-article-edit-article
gnus-article-edit-done gnus-article-decode-encoded-words
gnus-start-date-timer gnus-stop-date-timer
@@ -2670,12 +2687,13 @@ are always t.")
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
+ ("gnus-vm" :interactive (gnus-summary-mode) gnus-summary-save-in-vm
gnus-summary-save-article-vm)
("compface" uncompface)
- ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-queue)
+ ("gnus-draft" :interactive (gnus-summary-mode) gnus-draft-mode)
+ ("gnus-draft" :interactive t gnus-group-send-queue)
("gnus-mlspl" gnus-group-split gnus-group-split-fancy)
- ("gnus-mlspl" :interactive t gnus-group-split-setup
+ ("gnus-mlspl" :interactive (gnus-group-mode) gnus-group-split-setup
gnus-group-split-update)
("gnus-delay" gnus-delay-initialize))))
@@ -2708,6 +2726,11 @@ with some simple extensions.
%k Pretty-printed version of the above (string)
For example, \"1.2k\" or \"0.4M\".
%L Number of lines in the article (integer)
+%Z RSV of the article; nil if not in an nnselect group (integer)
+%G Originating group name for the article; nil if not
+ in an nnselect group (string)
+%g Short from of the originating group name for the article;
+ nil if not in an nnselect group (string)
%I Indentation based on thread level (a string of
spaces)
%B A complex trn-style thread tree (string)
@@ -3156,14 +3179,16 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-kill-ephemeral-group (group)
"Remove ephemeral GROUP from relevant structures."
- (remhash group gnus-newsrc-hashtb))
+ (remhash group gnus-newsrc-hashtb)
+ (setq gnus-newsrc-alist
+ (delq (assoc group gnus-newsrc-alist)
+ gnus-newsrc-alist)))
(defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler."
(setq mode-line-modified "--")
(when (listp mode-line-format)
- (make-local-variable 'mode-line-format)
- (setq mode-line-format (copy-sequence mode-line-format))
+ (setq-local mode-line-format (copy-sequence mode-line-format))
(when (equal (nth 3 mode-line-format) " ")
(setcar (nthcdr 3 mode-line-format) " "))))
@@ -3204,9 +3229,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)))
- (when (and (not (member name-method gnus-server-method-cache))
- (not no-enter-cache)
- (not (assoc (car name-method) gnus-server-method-cache)))
+ (unless (or no-enter-cache
+ (member name-method gnus-server-method-cache)
+ (assoc (car name-method) gnus-server-method-cache))
(push name-method gnus-server-method-cache))
name)))
@@ -3265,8 +3290,7 @@ that that variable is buffer-local to the summary buffers."
(gnus-server-to-method method))
((equal method gnus-select-method)
gnus-select-method)
- ((and (stringp (car method))
- group)
+ ((and group (stringp (car method)))
(gnus-server-extend-method group method))
((and method
(not group)
@@ -3493,7 +3517,7 @@ You should probably use `gnus-find-method-for-group' instead."
(while (setq info (pop alist))
(when (gnus-server-equal (gnus-info-method info) server)
(push (gnus-info-group info) groups)))
- (sort groups 'string<)))
+ (sort groups #'string<)))
(defun gnus-group-foreign-p (group)
"Say whether a group is foreign or not."
@@ -3623,11 +3647,12 @@ If you call this function inside a loop, consider using the faster
(defun gnus-group-get-parameter (group &optional symbol allow-list)
"Return the group parameters for GROUP.
-If SYMBOL, return the value of that symbol in the group parameters.
-If ALLOW-LIST, also allow list as a result.
-Most functions should use `gnus-group-find-parameter', which
-also examines the topic parameters."
- (let ((params (gnus-info-params (gnus-get-info group))))
+If SYMBOL, return the value of that symbol in the group
+parameters. If ALLOW-LIST, also allow list as a result. Most
+functions should use `gnus-group-find-parameter', which also
+examines the topic parameters. GROUP can also be an info structure."
+ (let ((params (gnus-info-params (if (listp group) group
+ (gnus-get-info group)))))
(if symbol
(gnus-group-parameter-value params symbol allow-list)
params)))
@@ -3715,7 +3740,7 @@ just the host name."
depth (+ depth 1)))
depth))))
;; Separate foreign select method from group name and collapse.
- ;; If method contains a server, collapse to non-domain server name,
+ ;; If method contains a server, collapse to non-domain server name,
;; otherwise collapse to select method.
(let* ((colon (string-match ":" group))
(server (and colon (substring group 0 colon)))
@@ -4034,13 +4059,20 @@ Allow completion over sensible values."
;;; User-level commands.
;;;###autoload
+(defun gnus-child-no-server (&optional arg)
+ "Read network news as a child, without connecting to the local server."
+ (interactive "P")
+ (gnus-no-server arg t))
+
+;;;###autoload
(defun gnus-slave-no-server (&optional arg)
- "Read network news as a slave, without connecting to the local server."
+ "Read network news as a child, without connecting to the local server."
(interactive "P")
(gnus-no-server arg t))
+(make-obsolete 'gnus-slave-no-server 'gnus-child-no-server "28.1")
;;;###autoload
-(defun gnus-no-server (&optional arg slave)
+(defun gnus-no-server (&optional arg child)
"Read network news.
If ARG is a positive number, Gnus will use that as the startup level.
If ARG is nil, Gnus will be started at level 2. If ARG is non-nil
@@ -4049,13 +4081,20 @@ an NNTP server to use.
As opposed to `gnus', this command will not connect to the local
server."
(interactive "P")
- (gnus-no-server-1 arg slave))
+ (gnus-no-server-1 arg child))
+
+;;;###autoload
+(defun gnus-child (&optional arg)
+ "Read news as a child."
+ (interactive "P")
+ (gnus arg nil 'child))
;;;###autoload
(defun gnus-slave (&optional arg)
- "Read news as a slave."
+ "Read news as a child."
(interactive "P")
- (gnus arg nil 'slave))
+ (gnus arg nil 'child))
+(make-obsolete 'gnus-slave 'gnus-child "28.1")
(defun gnus-delete-gnus-frame ()
"Delete gnus frame unless it is the only one.
@@ -4116,7 +4155,7 @@ current display is used."
(add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame)))))
;;;###autoload
-(defun gnus (&optional arg dont-connect slave)
+(defun gnus (&optional arg dont-connect child)
"Read network news.
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
@@ -4126,11 +4165,12 @@ prompt the user for the name of an NNTP server to use."
;; 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")
+ (unless (or (byte-code-function-p (symbol-function 'gnus))
+ (subr-native-elisp-p (symbol-function 'gnus)))
+ (message "You should compile Gnus")
(sit-for 2))
(let ((gnus-action-message-log (list nil)))
- (gnus-1 arg dont-connect slave)
+ (gnus-1 arg dont-connect child)
(gnus-final-warning)))
(declare-function debbugs-gnu "ext:debbugs-gnu"
diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el
index bb5c76feaa1..6ff2a4e2851 100644
--- a/lisp/gnus/gssapi.el
+++ b/lisp/gnus/gssapi.el
@@ -1,4 +1,4 @@
-;;; gssapi.el --- GSSAPI/Kerberos 5 interface for Emacs
+;;; gssapi.el --- GSSAPI/Kerberos 5 interface for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
@@ -25,8 +25,6 @@
;;; Code:
-(require 'format-spec)
-
(defcustom gssapi-program (list
(concat "gsasl %s %p "
"--mechanism GSSAPI "
@@ -53,12 +51,9 @@ tried until a successful connection is made."
(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))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,user)))))
response)
(when process
(while (and (memq (process-status process) '(open run))
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
index b47e69ffa4b..4f800891b2b 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -1,4 +1,4 @@
-;;; gnus-agent.el --- Legacy unplugged support for Gnus
+;;; legacy-gnus-agent.el --- Legacy unplugged support for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -210,7 +210,7 @@ converted to the compressed format."
;; Therefore, hide the default prompt.
(gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t)
-(defun gnus-agent-unhook-expire-days (converting-to)
+(defun gnus-agent-unhook-expire-days (_converting-to)
"Remove every lambda from `gnus-group-prepare-hook' that mention the
symbol `gnus-agent-do-once' in their definition. This should NOT be
necessary as gnus-agent.el no longer adds them. However, it is
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index da2bcb6fe52..af0a1983766 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -1,4 +1,4 @@
-;;; mail-source.el --- functions for fetching mail
+;;; mail-source.el --- functions for fetching mail -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -24,7 +24,6 @@
;;; Code:
-(require 'format-spec)
(eval-when-compile
(require 'cl-lib)
(require 'imap))
@@ -57,7 +56,6 @@
"Where the mail backends will look for incoming mail.
This variable is a list of mail source specifiers.
See Info node `(gnus)Mail Source Specifiers'."
- :group 'mail-source
:version "24.4"
:link '(custom-manual "(gnus)Mail Source Specifiers")
:type `(choice
@@ -231,33 +229,27 @@ Leave mails for this many days" :value 14)))))
If nil, the user will be prompted when an error occurs. If non-nil,
the error will be ignored."
:version "22.1"
- :group 'mail-source
:type 'boolean)
(defcustom mail-source-primary-source nil
"Primary source for incoming mail.
If non-nil, this maildrop will be checked periodically for new mail."
- :group 'mail-source
:type 'sexp)
(defcustom mail-source-flash t
"If non-nil, flash periodically when mail is available."
- :group 'mail-source
:type 'boolean)
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
"File where mail will be stored while processing it."
- :group 'mail-source
:type 'file)
(defcustom mail-source-directory message-directory
"Directory where incoming mail source files (if any) will be stored."
- :group 'mail-source
:type 'directory)
(defcustom mail-source-default-file-modes 384
"Set the mode bits of all new mail files to this integer."
- :group 'mail-source
:type 'integer)
(defcustom mail-source-delete-incoming
@@ -271,7 +263,6 @@ Removing of old files happens in `mail-source-callback', i.e. no
old incoming files will be deleted unless you receive new mail.
You may also set this variable to nil and call
`mail-source-delete-old-incoming' interactively."
- :group 'mail-source
:version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
:type '(choice (const :tag "immediately" t)
(const :tag "never" nil)
@@ -282,28 +273,23 @@ You may also set this variable to nil and call
This variable only applies when `mail-source-delete-incoming' is a positive
number."
:version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
- :group 'mail-source
:type 'boolean)
(defcustom mail-source-incoming-file-prefix "Incoming"
"Prefix for file name for storing incoming mail."
- :group 'mail-source
:type 'string)
(defcustom mail-source-report-new-mail-interval 5
"Interval in minutes between checks for new mail."
- :group 'mail-source
:type 'number)
(defcustom mail-source-idle-time-delay 5
"Number of idle seconds to wait before checking for new mail."
- :group 'mail-source
:type 'number)
(defcustom mail-source-movemail-program "movemail"
"If non-nil, name of program for fetching new mail."
:version "26.2"
- :group 'mail-source
:type '(choice (const nil) string))
;;; Internal variables.
@@ -394,13 +380,10 @@ All keywords that can be used must be listed here."))
;; suitable for usage in a `let' form
(eval-and-compile
(defun mail-source-bind-1 (type)
- (let* ((defaults (cdr (assq type mail-source-keyword-map)))
- default bind)
- (while (setq default (pop defaults))
- (push (list (mail-source-strip-keyword (car default))
- nil)
- bind))
- bind)))
+ (mapcar (lambda (default)
+ (list (mail-source-strip-keyword (car default))
+ nil))
+ (cdr (assq type mail-source-keyword-map)))))
(defmacro mail-source-bind (type-source &rest body)
"Return a `let' form that binds all variables in source TYPE.
@@ -419,18 +402,20 @@ of the second `let' form.
The variables bound and their default values are described by
the `mail-source-keyword-map' variable."
- `(let* ,(mail-source-bind-1 (car type-source))
- (mail-source-set-1 ,(cadr type-source))
- ,@body))
-
-(put 'mail-source-bind 'lisp-indent-function 1)
-(put 'mail-source-bind 'edebug-form-spec '(sexp body))
+ (declare (indent 1) (debug (sexp body)))
+ ;; FIXME: Use lexical vars, i.e. don't initialize the vars inside
+ ;; `mail-source-set-1' via `set'.
+ (let ((bindings (mail-source-bind-1 (car type-source))))
+ `(with-suppressed-warnings ((lexical ,@(mapcar #'car bindings)))
+ (dlet ,bindings
+ (mail-source-set-1 ,(cadr type-source))
+ ,@body))))
(defun mail-source-set-1 (source)
(let* ((type (pop source))
(defaults (cdr (assq type mail-source-keyword-map)))
(search '(:max 1))
- found default value keyword auth-info user-auth pass-auth)
+ found default value keyword user-auth pass-auth) ;; auth-info
;; append to the search the useful info from the source and the defaults:
;; user, host, and port
@@ -464,21 +449,23 @@ the `mail-source-keyword-map' variable."
(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)))
+ (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)))
+ (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))
@@ -489,20 +476,16 @@ the `mail-source-keyword-map' variable."
(eval-and-compile
(defun mail-source-bind-common-1 ()
- (let* ((defaults mail-source-common-keyword-map)
- default bind)
- (while (setq default (pop defaults))
- (push (list (mail-source-strip-keyword (car default))
- nil)
- bind))
- bind)))
+ (mapcar (lambda (default)
+ (list (mail-source-strip-keyword (car default))
+ nil))
+ mail-source-common-keyword-map)))
(defun mail-source-set-common-1 (source)
(let* ((type (pop source))
- (defaults mail-source-common-keyword-map)
(defaults-1 (cdr (assq type mail-source-keyword-map)))
- default value keyword)
- (while (setq default (pop defaults))
+ value keyword)
+ (dolist (default mail-source-common-keyword-map)
(set (mail-source-strip-keyword (setq keyword (car default)))
(if (setq value (plist-get source keyword))
(mail-source-value value)
@@ -513,12 +496,14 @@ the `mail-source-keyword-map' variable."
(defmacro mail-source-bind-common (source &rest body)
"Return a `let' form that binds all common variables.
See `mail-source-bind'."
- `(let ,(mail-source-bind-common-1)
- (mail-source-set-common-1 source)
- ,@body))
-
-(put 'mail-source-bind-common 'lisp-indent-function 1)
-(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
+ (declare (indent 1) (debug (sexp body)))
+ ;; FIXME: AFAICT this is a Rube Goldberg'esque way to bind and initialize the
+ ;; `plugged` variable.
+ (let ((bindings (mail-source-bind-common-1)))
+ `(with-suppressed-warnings ((lexical ,@(mapcar #'car bindings)))
+ (dlet ,bindings
+ (mail-source-set-common-1 ,source)
+ ,@body))))
(defun mail-source-value (value)
"Return the value of VALUE."
@@ -528,7 +513,7 @@ See `mail-source-bind'."
value)
;; Function
((and (listp value) (symbolp (car value)) (fboundp (car value)))
- (eval value))
+ (eval value t))
;; Just return the value.
(t
value)))
@@ -689,13 +674,13 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
;; find "our" movemail in exec-directory.
;; Bug#31737
(apply
- 'call-process
+ #'call-process
(append
(list
mail-source-movemail-program
nil errors nil from to)))))
(when (file-exists-p to)
- (set-file-modes to mail-source-default-file-modes))
+ (set-file-modes to mail-source-default-file-modes 'nofollow))
(if (and (or (not (buffer-modified-p errors))
(zerop (buffer-size errors)))
(and (numberp result)
@@ -740,13 +725,16 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(when delay
(sleep-for delay)))
+(declare-function gnus-get-buffer-create "gnus" (name))
(defun mail-source-call-script (script)
- (let ((background nil)
- (stderr (get-buffer-create " *mail-source-stderr*"))
+ (require 'gnus)
+ (let (;; (background nil)
+ (stderr (gnus-get-buffer-create " *mail-source-stderr*"))
result)
(when (string-match "& *$" script)
(setq script (substring script 0 (match-beginning 0))
- background 0))
+ ;; background 0
+ ))
(setq result
(call-process shell-file-name nil stderr nil
shell-command-switch script))
@@ -767,14 +755,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
"Fetcher for single-file sources."
(mail-source-bind (file source)
(mail-source-run-script
- prescript (format-spec-make ?t mail-source-crash-box)
+ prescript `((?t . ,mail-source-crash-box))
prescript-delay)
(let ((mail-source-string (format "file:%s" path)))
(if (mail-source-movemail path mail-source-crash-box)
(prog1
(mail-source-callback callback path)
(mail-source-run-script
- postscript (format-spec-make ?t mail-source-crash-box))
+ postscript `((?t . ,mail-source-crash-box)))
(mail-source-delete-crash-box))
0))))
@@ -782,7 +770,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
"Fetcher for directory sources."
(mail-source-bind (directory source)
(mail-source-run-script
- prescript (format-spec-make ?t path) prescript-delay)
+ prescript `((?t . ,path)) prescript-delay)
(let ((found 0)
(mail-source-string (format "directory:%s" path)))
(dolist (file (directory-files
@@ -791,7 +779,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(funcall predicate file)
(mail-source-movemail file mail-source-crash-box))
(cl-incf found (mail-source-callback callback file))
- (mail-source-run-script postscript (format-spec-make ?t path))
+ (mail-source-run-script postscript `((?t . ,path)))
(mail-source-delete-crash-box)))
found)))
@@ -801,8 +789,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
;; fixme: deal with stream type in format specs
(mail-source-run-script
prescript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user)
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user))
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(mail-source-string (format "pop:%s@%s" user server))
@@ -823,21 +811,21 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(mail-source-fetch-with-program
(format-spec
program
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))))
(function
(funcall function mail-source-crash-box))
;; The default is to use pop3.el.
(t
(require 'pop3)
- (let ((pop3-password password)
- (pop3-maildrop user)
- (pop3-mailhost server)
- (pop3-port port)
- (pop3-authentication-scheme
- (if (eq authentication 'apop) 'apop 'pass))
- (pop3-stream-type stream)
- (pop3-leave-mail-on-server leave))
+ (dlet ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server)
+ (pop3-port port)
+ (pop3-authentication-scheme
+ (if (eq authentication 'apop) 'apop 'pass))
+ (pop3-stream-type stream)
+ (pop3-leave-mail-on-server leave))
(if (or debug-on-quit debug-on-error)
(save-excursion (pop3-movemail mail-source-crash-box))
(condition-case err
@@ -861,8 +849,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(setq mail-source-new-mail-available nil))
(mail-source-run-script
postscript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
(mail-source-delete-crash-box)))
;; We nix out the password in case the error
;; was because of a wrong password being given.
@@ -897,12 +885,12 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
;; The default is to use pop3.el.
(t
(require 'pop3)
- (let ((pop3-password password)
- (pop3-maildrop user)
- (pop3-mailhost server)
- (pop3-port port)
- (pop3-authentication-scheme
- (if (eq authentication 'apop) 'apop 'pass)))
+ (dlet ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server)
+ (pop3-port port)
+ (pop3-authentication-scheme
+ (if (eq authentication 'apop) 'apop 'pass)))
(if (or debug-on-quit debug-on-error)
(save-excursion (pop3-get-message-count))
(condition-case err
@@ -932,7 +920,7 @@ authentication. To do that, you need to set the
`message-send-mail-function' variable as `message-smtpmail-send-it'
and put the following line in your ~/.gnus.el file:
-\(add-hook \\='message-send-mail-hook \\='mail-source-touch-pop)
+\(add-hook \\='message-send-mail-hook #\\='mail-source-touch-pop)
See the Gnus manual for details."
(let ((sources (if mail-source-primary-source
@@ -976,6 +964,8 @@ See the Gnus manual for details."
;; (element 0 of the vector is nil if the timer is active).
(aset mail-source-report-new-mail-idle-timer 0 nil)))
+(declare-function display-time-event-handler "time" ())
+
(defun mail-source-report-new-mail (arg)
"Toggle whether to report when new mail is available.
This only works when `display-time' is enabled."
@@ -1004,11 +994,11 @@ This only works when `display-time' is enabled."
#'mail-source-start-idle-timer))
;; When you get new mail, clear "Mail" from the mode line.
(add-hook 'nnmail-post-get-new-mail-hook
- 'display-time-event-handler)
+ #'display-time-event-handler)
(message "Mail check enabled"))
(setq display-time-mail-function nil)
(remove-hook 'nnmail-post-get-new-mail-hook
- 'display-time-event-handler)
+ #'display-time-event-handler)
(message "Mail check disabled"))))
(defun mail-source-fetch-maildir (source callback)
@@ -1075,8 +1065,9 @@ This only works when `display-time' is enabled."
"Fetcher for imap sources."
(mail-source-bind (imap source)
(mail-source-run-script
- prescript (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user)
+ prescript
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user))
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(found 0)
@@ -1087,7 +1078,8 @@ This only works when `display-time' is enabled."
(if (and (imap-open server port stream authentication buf)
(imap-authenticate
user (or (cdr (assoc from mail-source-password-cache))
- password) buf))
+ password)
+ buf))
(let ((mailbox-list (if (listp mailbox) mailbox (list mailbox))))
(dolist (mailbox mailbox-list)
(when (imap-mailbox-select mailbox nil buf)
@@ -1141,8 +1133,8 @@ This only works when `display-time' is enabled."
(kill-buffer buf)
(mail-source-run-script
postscript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
found)))
(provide 'mail-source)
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 143af3c63ad..bcbf7476715 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -42,13 +42,12 @@
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(require 'format-spec)
(require 'dired)
(require 'mm-util)
(require 'rfc2047)
(require 'puny)
-(require 'rmc) ; read-multiple-choice
-(eval-when-compile (require 'subr-x)) ; when-let*
+(require 'rmc) ; read-multiple-choice
+(require 'subr-x)
(autoload 'mailclient-send-it "mailclient")
@@ -121,12 +120,13 @@
:group 'message-buffers
:type 'integer)
-(defcustom message-send-rename-function nil
+(defcustom message-send-rename-function #'message-default-send-rename-function
"Function called to rename the buffer after sending it."
:group 'message-buffers
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-fcc-handler-function 'message-output
+(defcustom message-fcc-handler-function #'message-output
"A function called to save outgoing articles.
This function will be called with the name of the file to store the
article in. The default function is `message-output' which saves in Unix
@@ -187,22 +187,26 @@ Otherwise, most addresses look like `angles', but they look like
(defcustom message-syntax-checks
(if message-insert-canlock '((sender . disabled)) nil)
- ;; Guess this one shouldn't be easy to customize...
"Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
Don't touch this variable unless you really know what you're doing.
-Checks include `approved', `bogus-recipient', `continuation-headers',
-`control-chars', `empty', `existing-newsgroups', `from', `illegible-text',
-`invisible-text', `long-header-lines', `long-lines', `message-id',
-`multiple-headers', `new-text', `newsgroups', `quoting-style',
-`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot',
-`shorten-followup-to', `signature', `size', `subject', `subject-cmsg'
-and `valid-newsgroups'."
- :group 'message-news
- :type '(repeat sexp)) ; Fixme: improve this
+See the Message manual for the meanings of the valid syntax check
+types."
+ :group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
+ :type '(alist
+ :key-type symbol
+ :value-type (const disabled)
+ :options (approved bogus-recipient continuation-headers
+ control-chars empty existing-newsgroups from illegible-text
+ invisible-text long-header-lines long-lines message-id
+ multiple-headers new-text newgroups quoting-style
+ repeated-newsgroups reply-to sender sendsys shoot
+ shorten-followup-to signature size subject subject-cmsg
+ valid-newsgroups)))
(defcustom message-required-headers '((optional . References)
From)
@@ -215,9 +219,9 @@ Also see `message-required-news-headers' and
:link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
-(defcustom message-draft-headers '(References From Date)
+(defcustom message-draft-headers '(References From)
"Headers to be generated when saving a draft message."
- :version "22.1"
+ :version "28.1"
:group 'message-news
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
@@ -304,6 +308,13 @@ any confusion."
:link '(custom-manual "(message)Message Headers")
:type 'regexp)
+(defcustom message-screenshot-command '("import" "png:-")
+ "Command to take a screenshot.
+The command should insert a PNG in the current buffer."
+ :group 'message-various
+ :type '(repeat string)
+ :version "28.1")
+
;;; Start of variables adopted from `message-utils.el'.
(defcustom message-subject-trailing-was-query t
@@ -322,7 +333,7 @@ used."
:group 'message-various)
(defcustom message-subject-trailing-was-ask-regexp
- "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)"
+ "[ \t]*\\([[(]+[Ww][Aa][Ss].*[])]+\\)"
"Regexp matching \"(was: <old subject>)\" in the subject line.
The function `message-strip-subject-trailing-was' uses this regexp if
@@ -337,7 +348,7 @@ It is okay to create some false positives here, as the user is asked."
:type 'regexp)
(defcustom message-subject-trailing-was-regexp
- "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
+ "[ \t]*\\((*[Ww][Aa][Ss]:.*)\\)"
"Regexp matching \"(was: <old subject>)\" in the subject line.
If `message-subject-trailing-was-query' is set to t, the subject is
@@ -376,7 +387,7 @@ Archives \(such as groups.google.com) respect this header."
:group 'message-various)
(defcustom message-archive-note
- "X-No-Archive: Yes - save http://groups.google.com/"
+ "X-No-Archive: Yes - save https://groups.google.com/"
"Note to insert why you wouldn't want this posting archived.
If nil, don't insert any text in the body."
:version "22.1"
@@ -388,9 +399,8 @@ If nil, don't insert any text in the body."
;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
;; new suggestions by R. Weikusat <rw at another.de>
-(defvar message-cross-post-old-target nil
+(defvar-local message-cross-post-old-target nil
"Old target for cross-posts or follow-ups.")
-(make-variable-buffer-local 'message-cross-post-old-target)
(defcustom message-cross-post-default t
"When non-nil `message-cross-post-followup-to' will perform a crosspost.
@@ -413,7 +423,7 @@ you can explicitly override this setting by calling
:type 'string
:group 'message-various)
-(defcustom message-cross-post-note-function 'message-cross-post-insert-note
+(defcustom message-cross-post-note-function #'message-cross-post-insert-note
"Function to use to insert note about Crosspost or Followup-To.
The function will be called with four arguments. The function should not only
insert a note, but also ensure old notes are deleted. See the documentation
@@ -440,8 +450,8 @@ whitespace)."
(defcustom message-elide-ellipsis "\n[...]\n\n"
"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
+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")
@@ -614,8 +624,8 @@ Done before generating the new subject of a forward."
(defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
"All headers that match this regexp will be deleted when forwarding a message.
-This variable is only consulted when forwarding \"normally\", not
-when forwarding as MIME or the like.
+Also see `message-forward-included-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
This may also be a list of regexps."
:version "21.1"
@@ -631,7 +641,14 @@ This may also be a list of regexps."
'("^From:" "^Subject:" "^Date:" "^To:" "^Cc:")
"If non-nil, delete non-matching headers when forwarding a message.
Only headers that match this regexp will be included. This
-variable should be a regexp or a list of regexps."
+variable should be a regexp or a list of regexps.
+
+Also see `message-forward-ignored-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
:version "27.1"
:group 'message-forwarding
:type '(repeat :value-to-internal (lambda (widget value)
@@ -641,6 +658,24 @@ variable should be a regexp or a list of regexps."
(widget-editable-list-match widget value)))
regexp))
+(defcustom message-forward-included-mime-headers
+ '("^Content-Type:" "^MIME-Version:")
+ "When forwarding as MIME, but not using MML, don't delete these headers.
+Also see `message-forward-ignored-headers' and
+`message-forward-ignored-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
+ :version "28.1"
+ :group 'message-forwarding
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp))
+
(defcustom message-ignored-cited-headers "."
"Delete these headers from the messages you yank."
:group 'message-insertion
@@ -726,7 +761,7 @@ See also `send-mail-function'."
:link '(custom-manual "(message)Mail Variables")
:group 'message-mail)
-(defcustom message-send-news-function 'message-send-news
+(defcustom message-send-news-function #'message-send-news
"Function to call to send the current buffer as news.
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'."
@@ -735,29 +770,32 @@ variable `mail-header-separator'."
:link '(custom-manual "(message)News Variables")
:type 'function)
-(defcustom message-reply-to-function nil
+(defcustom message-reply-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Reply")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-wide-reply-to-function nil
+(defcustom message-wide-reply-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Wide Reply")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-followup-to-function nil
+(defcustom message-followup-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Followup")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
(defcustom message-extra-wide-headers nil
"If non-nil, a list of additional address headers.
@@ -848,7 +886,8 @@ symbol `never', the posting is not allowed. If it is the symbol
;; differently (bug#36937).
nil
"Non-nil means don't add \"-f username\" to the sendmail command line.
-Doing so would be even more evil than leaving it out."
+See `feedmail-sendmail-f-doesnt-sell-me-out' for an explanation
+of what the \"-f\" parameter does."
:group 'message-sending
:link '(custom-manual "(message)Mail Variables")
:type 'boolean)
@@ -990,7 +1029,7 @@ the signature is inserted."
:version "22.1"
:group 'message-various)
-(defcustom message-citation-line-function 'message-insert-citation-line
+(defcustom message-citation-line-function #'message-insert-citation-line
"Function called to insert the \"Whomever writes:\" line.
Predefined functions include `message-insert-citation-line' and
@@ -1072,7 +1111,7 @@ Used by `message-yank-original' via `message-yank-cite'."
:link '(custom-manual "(message)Insertion Variables")
:type 'integer)
-(defcustom message-cite-function 'message-cite-original-without-signature
+(defcustom message-cite-function #'message-cite-original-without-signature
"Function for citing an original message.
Predefined functions include `message-cite-original' and
`message-cite-original-without-signature'.
@@ -1085,7 +1124,7 @@ Note that these functions use `mail-citation-hook' if that is non-nil."
:version "22.3" ;; Gnus 5.10.12 (changed default)
:group 'message-insertion)
-(defcustom message-indent-citation-function 'message-indent-citation
+(defcustom message-indent-citation-function #'message-indent-citation
"Function for modifying a citation just inserted in the mail buffer.
This can also be a list of functions. Each function can find the
citation between (point) and (mark t). And each function should leave
@@ -1099,7 +1138,8 @@ point and mark around the citation text as modified."
If nil, don't insert a signature.
If t, insert `message-signature-file'.
If a function or form, insert its result.
-See `mail-signature' for the recommended format of a signature."
+See `mail-signature' for the recommended format of a signature.
+Also see `message-signature-insert-empty-line'."
:version "23.2"
:type '(choice string
(const :tag "None" nil)
@@ -1147,7 +1187,7 @@ 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-position) \\='above))"
+ (eval (setq-local message-cite-reply-position \\='above))"
:version "24.1"
:type '(choice (const :tag "Reply inline" traditional)
(const :tag "Reply above" above)
@@ -1164,7 +1204,8 @@ 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)))"
+ ((posting-from-work-p) (eval (setq-local message-cite-style
+ message-cite-style-outlook)))"
:version "24.1"
:group 'message-insertion
:type '(choice (const :tag "Do not override variables" :value nil)
@@ -1191,7 +1232,8 @@ use in `gnus-posting-styles', such as:
(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'.")
+ "Message citation style used by Mozilla Thunderbird.
+Use with `message-cite-style'.")
(defconst message-cite-style-gmail
'((message-cite-function 'message-cite-original)
@@ -1616,6 +1658,11 @@ starting with `not' and followed by regexps."
"Face used for displaying MML."
:group 'message-faces)
+(defface message-signature-separator '((t :bold t))
+ "Face used for displaying the signature separator."
+ :group 'message-faces
+ :version "28.1")
+
(defun message-match-to-eoh (_limit)
(let ((start (point)))
(rfc822-goto-eoh)
@@ -1709,9 +1756,22 @@ number of levels specified in the faces `message-cited-text-*'."
(0 ',cited-text-face))
keywords))
(setq level (1+ level)))
- keywords))
+ keywords)
+ ;; Match signature. This `field' stuff ensures that hitting `RET'
+ ;; after the signature separator doesn't remove the trailing space.
+ (list
+ '(message--match-signature (0 '( face message-signature-separator
+ rear-nonsticky t
+ field signature)))))
"Additional expressions to highlight in Message mode.")
+(defun message--match-signature (limit)
+ (save-excursion
+ (and (re-search-forward message-signature-separator limit t)
+ ;; It's the last one in the buffer.
+ (not (save-excursion
+ (re-search-forward message-signature-separator nil t))))))
+
(defvar message-face-alist
'((bold . message-bold-region)
(underline . underline-region)
@@ -1969,9 +2029,8 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
(User-Agent))
"Alist used for formatting headers.")
-(defvar message-options nil
+(defvar-local message-options nil
"Some saved answers when sending message.")
-(make-variable-buffer-local 'message-options)
(defvar message-send-mail-real-function nil
"Internal send mail function.")
@@ -1986,6 +2045,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
(autoload 'gnus-delay-article "gnus-delay")
(autoload 'gnus-extract-address-components "gnus-util")
(autoload 'gnus-find-method-for-group "gnus")
+(autoload 'gnus-get-buffer-create "gnus")
(autoload 'gnus-group-name-charset "gnus-group")
(autoload 'gnus-group-name-decode "gnus-group")
(autoload 'gnus-groups-from-server "gnus")
@@ -2081,14 +2141,21 @@ is used by default."
(goto-char (point-min))
(looking-at message-unix-mail-delimiter))))
-(defun message-fetch-field (header &optional not-all)
- "The same as `mail-fetch-field', only remove all newlines.
+(defun message-fetch-field (header &optional first)
+ "Return the value of the header field named HEADER.
+Continuation lines are folded (i.e., newlines are removed).
Surrounding whitespace is also removed.
+By default, if there's more than one header field named HEADER,
+all the values are returned as one concatenated string, and
+values are comma-separated.
+
+If FIRST is non-nil, only the first value is returned.
+
The buffer is expected to be narrowed to just the header of the message;
see `message-narrow-to-headers-or-head'."
(let* ((inhibit-point-motion-hooks t)
- (value (mail-fetch-field header nil (not not-all))))
+ (value (mail-fetch-field header nil (not first))))
(when value
(while (string-match "\n[\t ]+" value)
(setq value (replace-match " " t t value)))
@@ -2096,12 +2163,12 @@ see `message-narrow-to-headers-or-head'."
;; we have initial or trailing white space; remove it.
(string-trim value))))
-(defun message-field-value (header &optional not-all)
+(defun message-field-value (header &optional first)
"The same as `message-fetch-field', only narrow to the headers first."
(save-excursion
(save-restriction
(message-narrow-to-headers-or-head)
- (message-fetch-field header not-all))))
+ (message-fetch-field header first))))
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
@@ -2152,10 +2219,11 @@ see `message-narrow-to-headers-or-head'."
(require 'gnus-sum) ; for gnus-list-identifiers
(let ((regexp (if (stringp gnus-list-identifiers)
gnus-list-identifiers
- (mapconcat 'identity gnus-list-identifiers " *\\|"))))
+ (mapconcat #'identity gnus-list-identifiers " *\\|"))))
(if (and (not (equal regexp ""))
(string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
- " *\\)\\)+\\(Re: +\\)?\\)") subject))
+ " *\\)\\)+\\(Re: +\\)?\\)")
+ subject))
(concat (substring subject 0 (match-beginning 1))
(or (match-string 3 subject)
(match-string 5 subject))
@@ -2292,7 +2360,8 @@ Leading \"Re: \" is not stripped by this function. Use the function
"Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
(interactive
(list
- (read-from-minibuffer "New subject: ")))
+ (read-from-minibuffer "New subject: "))
+ message-mode)
(cond ((and (not (or (null new-subject) ; new subject not empty
(zerop (string-width new-subject))
(string-match "^[ \t]*$" new-subject))))
@@ -2322,7 +2391,7 @@ Leading \"Re: \" is not stripped by this function. Use the function
"Mark some region in the current article with enclosing tags.
See `message-mark-insert-begin' and `message-mark-insert-end'.
If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
- (interactive "r\nP")
+ (interactive "r\nP" message-mode)
(save-excursion
;; add to the end of the region first, otherwise end would be invalid
(goto-char end)
@@ -2334,7 +2403,7 @@ If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
"Insert FILE at point, marking it with enclosing tags.
See `message-mark-insert-begin' and `message-mark-insert-end'.
If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
- (interactive "fFile to insert: \nP")
+ (interactive "fFile to insert: \nP" message-mode)
;; reverse insertion to get correct result.
(let ((p (point)))
(insert (if verbatim "#v-\n" message-mark-insert-end))
@@ -2348,7 +2417,7 @@ If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")."
The note can be customized using `message-archive-note'. When called with a
prefix argument, ask for a text to insert. If you don't want the note in the
body, set `message-archive-note' to nil."
- (interactive)
+ (interactive nil message-mode)
(if current-prefix-arg
(setq message-archive-note
(read-from-minibuffer "Reason for No-Archive: "
@@ -2374,7 +2443,8 @@ With prefix-argument just set Follow-Up, don't cross-post."
gnus-newsrc-alist)
nil nil '("poster" . 0)
(if (boundp 'gnus-group-history)
- 'gnus-group-history)))))
+ 'gnus-group-history))))
+ message-mode)
(message-remove-header "Follow[Uu]p-[Tt]o" t)
(message-goto-newsgroups)
(beginning-of-line)
@@ -2451,7 +2521,8 @@ With prefix-argument just set Follow-Up, don't cross-post."
gnus-newsrc-alist)
nil nil '("poster" . 0)
(if (boundp 'gnus-group-history)
- 'gnus-group-history)))))
+ 'gnus-group-history))))
+ message-mode)
(when (fboundp 'gnus-group-real-name)
(setq target-group (gnus-group-real-name target-group)))
(cond ((not (or (null target-group) ; new subject not empty
@@ -2486,7 +2557,7 @@ With prefix-argument just set Follow-Up, don't cross-post."
(defun message-reduce-to-to-cc ()
"Replace contents of To: header with contents of Cc: or Bcc: header."
- (interactive)
+ (interactive nil message-mode)
(let ((cc-content
(save-restriction (message-narrow-to-headers)
(message-fetch-field "cc")))
@@ -2651,8 +2722,8 @@ Point is left at the beginning of the narrowed-to region."
10000))))
(defun message-sort-headers ()
- "Sort the headers of the current message according to `message-header-format-alist'."
- (interactive)
+ "Sort headers of the current message according to `message-header-format-alist'."
+ (interactive nil message-mode)
(save-excursion
(save-restriction
(let ((max (1+ (length message-header-format-alist)))
@@ -2673,7 +2744,7 @@ Point is left at the beginning of the narrowed-to region."
(defun message-kill-address ()
"Kill the address under point."
- (interactive)
+ (interactive nil message-mode)
(let ((start (point)))
(message-skip-to-next-address)
(kill-region start (if (bolp) (1- (point)) (point)))))
@@ -2730,6 +2801,65 @@ systematically send encrypted emails when possible."
(when (message-all-epg-keys-available-p)
(mml-secure-message-sign-encrypt)))
+(defcustom message-openpgp-header nil
+ "Specification for the \"OpenPGP\" header of outgoing messages.
+
+The value must be a list of three elements, all strings:
+- Key ID, in hexadecimal form;
+- Key URL or ASCII armoured key; and
+- Protection preference, one of: \"unprotected\", \"sign\",
+ \"encrypt\" or \"signencrypt\".
+
+Each of the elements may be nil, in which case its part in the
+OpenPGP header will be left out. If all the values are nil,
+or `message-openpgp-header' is itself nil, the OpenPGP header
+will not be inserted."
+ :type '(choice
+ (const :tag "Don't add OpenPGP header" nil)
+ (list :tag "Use OpenPGP header"
+ (choice (string :tag "ID")
+ (const :tag "No ID" nil))
+ (choice (string :tag "Key")
+ (const :tag "No Key" nil))
+ (choice (other :tag "None" nil)
+ (const :tag "Unprotected" "unprotected")
+ (const :tag "Sign" "sign")
+ (const :tag "Encrypt" "encrypt")
+ (const :tag "Sign and Encrypt" "signencrypt"))))
+ :version "28.1")
+
+(defun message-add-openpgp-header ()
+ "Add OpenPGP header to point to public key.
+
+Header will be constructed as specified in `message-openpgp-header'.
+
+Consider adding this function to `message-header-setup-hook'"
+ ;; See https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header
+ (when (and message-openpgp-header
+ (or (nth 0 message-openpgp-header)
+ (nth 1 message-openpgp-header)
+ (nth 2 message-openpgp-header)))
+ (message-add-header
+ (with-temp-buffer
+ (insert "OpenPGP: ")
+ ;; add ID
+ (let (need-sep)
+ (when (nth 0 message-openpgp-header)
+ (insert "id=" (nth 0 message-openpgp-header))
+ (setq need-sep t))
+ ;; add URL
+ (when (nth 1 message-openpgp-header)
+ (when need-sep (insert "; "))
+ (insert "url=\"" (nth 1 message-openpgp-header) "\"")
+ (setq need-sep t))
+ ;; add preference
+ (when (nth 2 message-openpgp-header)
+ (when need-sep (insert "; "))
+ (insert "preference=" (nth 2 message-openpgp-header))))
+ ;; insert header
+ (buffer-string)))
+ (message-sort-headers)))
+
;;;
@@ -2743,78 +2873,79 @@ systematically send encrypted emails when possible."
(unless message-mode-map
(setq message-mode-map (make-keymap))
(set-keymap-parent message-mode-map text-mode-map)
- (define-key message-mode-map "\C-c?" 'describe-mode)
-
- (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
- (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
- (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
- (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
- (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
- (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
- (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
- (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
- (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
- (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
- (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
+ (define-key message-mode-map "\C-c?" #'describe-mode)
+
+ (define-key message-mode-map "\C-c\C-f\C-t" #'message-goto-to)
+ (define-key message-mode-map "\C-c\C-f\C-o" #'message-goto-from)
+ (define-key message-mode-map "\C-c\C-f\C-b" #'message-goto-bcc)
+ (define-key message-mode-map "\C-c\C-f\C-w" #'message-goto-fcc)
+ (define-key message-mode-map "\C-c\C-f\C-c" #'message-goto-cc)
+ (define-key message-mode-map "\C-c\C-f\C-s" #'message-goto-subject)
+ (define-key message-mode-map "\C-c\C-f\C-r" #'message-goto-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-n" #'message-goto-newsgroups)
+ (define-key message-mode-map "\C-c\C-f\C-d" #'message-goto-distribution)
+ (define-key message-mode-map "\C-c\C-f\C-f" #'message-goto-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-m" #'message-goto-mail-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-k" #'message-goto-keywords)
+ (define-key message-mode-map "\C-c\C-f\C-u" #'message-goto-summary)
(define-key message-mode-map "\C-c\C-f\C-i"
- 'message-insert-or-toggle-importance)
+ #'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\C-f\C-a"
- 'message-generate-unsubscribed-mail-followup-to)
+ #'message-generate-unsubscribed-mail-followup-to)
;; modify headers (and insert notes in body)
- (define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
+ (define-key message-mode-map "\C-c\C-fs" #'message-change-subject)
;;
- (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to)
+ (define-key message-mode-map "\C-c\C-fx" #'message-cross-post-followup-to)
;; prefix+message-cross-post-followup-to = same w/o cross-post
- (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
- (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
+ (define-key message-mode-map "\C-c\C-ft" #'message-reduce-to-to-cc)
+ (define-key message-mode-map "\C-c\C-fa" #'message-add-archive-header)
;; mark inserted text
- (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
- (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
+ (define-key message-mode-map "\C-c\M-m" #'message-mark-inserted-region)
+ (define-key message-mode-map "\C-c\M-f" #'message-mark-insert-file)
- (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
- (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
+ (define-key message-mode-map "\C-c\C-b" #'message-goto-body)
+ (define-key message-mode-map "\C-c\C-i" #'message-goto-signature)
- (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
- (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
- (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
- (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
- (define-key message-mode-map "\C-c\C-f\C-e" 'message-insert-expires)
+ (define-key message-mode-map "\C-c\C-t" #'message-insert-to)
+ (define-key message-mode-map "\C-c\C-fw" #'message-insert-wide-reply)
+ (define-key message-mode-map "\C-c\C-n" #'message-insert-newsgroups)
+ (define-key message-mode-map "\C-c\C-l" #'message-to-list-only)
+ (define-key message-mode-map "\C-c\C-f\C-e" #'message-insert-expires)
- (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\C-u" #'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\M-n"
- 'message-insert-disposition-notification-to)
-
- (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
- (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
- (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
- (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
- (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
- (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
- (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
- (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
-
- (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
- (define-key message-mode-map "\C-c\C-s" 'message-send)
- (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
- (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
- (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
-
- (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
- (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
- (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
- (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
- (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- (define-key message-mode-map [remap split-line] 'message-split-line)
-
- (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
-
- (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-n" 'message-display-abbrev))
+ #'message-insert-disposition-notification-to)
+
+ (define-key message-mode-map "\C-c\C-y" #'message-yank-original)
+ (define-key message-mode-map "\C-c\M-\C-y" #'message-yank-buffer)
+ (define-key message-mode-map "\C-c\C-q" #'message-fill-yanked-message)
+ (define-key message-mode-map "\C-c\C-w" #'message-insert-signature)
+ (define-key message-mode-map "\C-c\M-h" #'message-insert-headers)
+ (define-key message-mode-map "\C-c\C-r" #'message-caesar-buffer-body)
+ (define-key message-mode-map "\C-c\C-o" #'message-sort-headers)
+ (define-key message-mode-map "\C-c\M-r" #'message-rename-buffer)
+
+ (define-key message-mode-map "\C-c\C-c" #'message-send-and-exit)
+ (define-key message-mode-map "\C-c\C-s" #'message-send)
+ (define-key message-mode-map "\C-c\C-k" #'message-kill-buffer)
+ (define-key message-mode-map "\C-c\C-d" #'message-dont-send)
+ (define-key message-mode-map "\C-c\n" #'gnus-delay-article)
+
+ (define-key message-mode-map "\C-c\M-k" #'message-kill-address)
+ (define-key message-mode-map "\C-c\C-e" #'message-elide-region)
+ (define-key message-mode-map "\C-c\C-v" #'message-delete-not-region)
+ (define-key message-mode-map "\C-c\C-z" #'message-kill-to-signature)
+ (define-key message-mode-map "\M-\r" #'message-newline-and-reformat)
+ (define-key message-mode-map [remap split-line] #'message-split-line)
+
+ (define-key message-mode-map "\C-c\C-a" #'mml-attach-file)
+ (define-key message-mode-map "\C-c\C-p" #'message-insert-screenshot)
+
+ (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-n" #'message-display-abbrev))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
@@ -2839,6 +2970,8 @@ systematically send encrypted emails when possible."
:active (message-mark-active-p) :help "Mark region with enclosing tags"]
["Insert File Marked..." message-mark-insert-file
:help "Insert file at point marked with enclosing tags"]
+ ["Attach File..." mml-attach-file t]
+ ["Insert Screenshot" message-insert-screenshot t]
"----"
["Send Message" message-send-and-exit :help "Send this message"]
["Postpone Message" message-dont-send
@@ -2977,22 +3110,23 @@ See also `message-forbidden-properties'."
(defun message--syntax-propertize (beg end)
"Syntax-propertize certain message text specially."
- (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
- (smiley-regexp (regexp-opt message-smileys)))
- (goto-char beg)
- (while (search-forward-regexp citation-regexp
- end 'noerror)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
- (add-text-properties start (1+ start)
- `(syntax-table ,(string-to-syntax "<")))
- (add-text-properties end (min (1+ end) (point-max))
- `(syntax-table ,(string-to-syntax ">")))))
- (goto-char beg)
- (while (search-forward-regexp smiley-regexp
- end 'noerror)
- (add-text-properties (match-beginning 0) (match-end 0)
- `(syntax-table ,(string-to-syntax "."))))))
+ (with-syntax-table message-mode-syntax-table
+ (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
+ (smiley-regexp (regexp-opt message-smileys)))
+ (goto-char beg)
+ (while (search-forward-regexp citation-regexp
+ end 'noerror)
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (add-text-properties start (1+ start)
+ `(syntax-table ,(string-to-syntax "<")))
+ (add-text-properties end (min (1+ end) (point-max))
+ `(syntax-table ,(string-to-syntax ">")))))
+ (goto-char beg)
+ (while (search-forward-regexp smiley-regexp
+ end 'noerror)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ `(syntax-table ,(string-to-syntax ".")))))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
@@ -3000,46 +3134,43 @@ See also `message-forbidden-properties'."
Like `text-mode', but with these additional commands:
\\{message-mode-map}"
- (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)
- (set (make-local-variable 'message-draft-article) nil)
+ (setq-local message-reply-buffer nil)
+ (setq-local message-inserted-headers nil)
+ (setq-local message-send-actions nil)
+ (setq-local message-return-action nil)
+ (setq-local message-exit-actions nil)
+ (setq-local message-kill-actions nil)
+ (setq-local message-postpone-actions nil)
+ (setq-local message-draft-article nil)
(setq buffer-offer-save t)
- (set (make-local-variable 'facemenu-add-face-function)
+ (setq-local facemenu-add-face-function
(lambda (face end)
(let ((face-fun (cdr (assq face message-face-alist))))
(if face-fun
(funcall face-fun (point) end)
(error "Face %s not configured for %s mode" face mode-name)))
""))
- (set (make-local-variable 'facemenu-remove-face-function) t)
- (set (make-local-variable 'message-reply-headers) nil)
+ (setq-local facemenu-remove-face-function t)
+ (setq-local message-reply-headers nil)
(make-local-variable 'message-newsreader)
(make-local-variable 'message-mailer)
(make-local-variable 'message-post-method)
- (set (make-local-variable 'message-sent-message-via) nil)
- (set (make-local-variable 'message-checksum) nil)
- (set (make-local-variable 'message-mime-part) 0)
+ (setq-local message-sent-message-via nil)
+ (setq-local message-checksum nil)
+ (setq-local message-mime-part 0)
(message-setup-fill-variables)
(when message-fill-column
(setq fill-column message-fill-column)
(turn-on-auto-fill))
;; Allow using comment commands to add/remove quoting.
- ;; (set (make-local-variable 'comment-start) message-yank-prefix)
+ ;; (setq-local comment-start message-yank-prefix)
(when message-yank-prefix
- (set (make-local-variable 'comment-start) message-yank-prefix)
- (set (make-local-variable 'comment-start-skip)
- (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))
- (set (make-local-variable 'font-lock-defaults)
- '(message-font-lock-keywords t))
+ (setq-local comment-start message-yank-prefix)
+ (setq-local comment-start-skip
+ (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))
+ (setq-local font-lock-defaults '(message-font-lock-keywords t))
(if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) (message-make-tool-bar)))
- (easy-menu-add message-mode-menu message-mode-map)
- (easy-menu-add message-mode-field-menu message-mode-map)
+ (setq-local tool-bar-map (message-make-tool-bar)))
;; Mmmm... Forbidden properties...
(add-hook 'after-change-functions #'message-strip-forbidden-properties
nil 'local)
@@ -3058,47 +3189,42 @@ Like `text-mode', but with these additional commands:
;; Don't enable multibyte on an indirect buffer. Maybe enabling
;; multibyte is not necessary at all. -- zsh
(mm-enable-multibyte))
- (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
+ (setq-local indent-tabs-mode nil) ; No tabs for indentation.
(mml-mode)
;; Syntactic fontification. Helps `show-paren-mode',
;; `electric-pair-mode', and C-M-* navigation by syntactically
;; excluding citations and other artifacts.
;;
- (set (make-local-variable 'syntax-propertize-function) 'message--syntax-propertize)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (setq-local syntax-propertize-function #'message--syntax-propertize)
+ (setq-local parse-sexp-ignore-comments t)
(setq-local message-encoded-mail-cache nil))
(defun message-setup-fill-variables ()
"Setup message fill variables."
- (set (make-local-variable 'fill-paragraph-function)
- 'message-fill-paragraph)
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'paragraph-start)
- (make-local-variable 'adaptive-fill-regexp)
- (make-local-variable 'adaptive-fill-first-line-regexp)
+ (setq-local fill-paragraph-function #'message-fill-paragraph)
(let ((quote-prefix-regexp
;; User should change message-cite-prefix-regexp if
;; message-yank-prefix is set to an abnormal value.
(concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
- (setq paragraph-start
- (concat
- (regexp-quote mail-header-separator) "$\\|"
- "[ \t]*$\\|" ; blank lines
- "-- $\\|" ; signature delimiter
- "---+$\\|" ; delimiters for forwarded messages
- page-delimiter "$\\|" ; spoiler warnings
- ".*wrote:$\\|" ; attribution lines
- quote-prefix-regexp "$\\|" ; empty lines in quoted text
- ; mml tags
- "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
- (setq paragraph-separate paragraph-start)
- (setq adaptive-fill-regexp
- (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
- (setq adaptive-fill-first-line-regexp
- (concat quote-prefix-regexp "\\|"
- adaptive-fill-first-line-regexp)))
+ (setq-local paragraph-start
+ (concat
+ (regexp-quote mail-header-separator) "$\\|"
+ "[ \t]*$\\|" ; blank lines
+ "-- $\\|" ; signature delimiter
+ "---+$\\|" ; delimiters for forwarded messages
+ page-delimiter "$\\|" ; spoiler warnings
+ ".*wrote:$\\|" ; attribution lines
+ quote-prefix-regexp "$\\|" ; empty lines in quoted text
+ ; mml tags
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local adaptive-fill-regexp
+ (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
+ (setq-local adaptive-fill-first-line-regexp
+ (concat quote-prefix-regexp "\\|"
+ adaptive-fill-first-line-regexp)))
(setq-local auto-fill-inhibit-regexp nil)
- (setq-local normal-auto-fill-function 'message-do-auto-fill))
+ (setq-local normal-auto-fill-function #'message-do-auto-fill))
@@ -3110,87 +3236,87 @@ Like `text-mode', but with these additional commands:
(defun message-goto-to ()
"Move point to the To header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "To"))
(defun message-goto-from ()
"Move point to the From header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "From"))
(defun message-goto-subject ()
"Move point to the Subject header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Subject"))
(defun message-goto-cc ()
"Move point to the Cc header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Cc" "To"))
(defun message-goto-bcc ()
"Move point to the Bcc header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Bcc" "Cc" "To"))
(defun message-goto-fcc ()
"Move point to the Fcc header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Fcc" "To" "Newsgroups"))
(defun message-goto-reply-to ()
"Move point to the Reply-To header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Reply-To" "Subject"))
(defun message-goto-newsgroups ()
"Move point to the Newsgroups header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Newsgroups"))
(defun message-goto-distribution ()
"Move point to the Distribution header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Distribution"))
(defun message-goto-followup-to ()
"Move point to the Followup-To header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Followup-To" "Newsgroups"))
(defun message-goto-mail-followup-to ()
"Move point to the Mail-Followup-To header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Mail-Followup-To" "To"))
(defun message-goto-keywords ()
"Move point to the Keywords header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Keywords" "Subject"))
(defun message-goto-summary ()
"Move point to the Summary header."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(message-position-on-field "Summary" "Subject"))
-(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1")
+(define-obsolete-function-alias 'message-goto-body-1 #'message-goto-body "27.1")
(defun message-goto-body (&optional interactive)
"Move point to the beginning of the message body.
Returns point."
- (interactive "p")
+ (interactive "p" message-mode)
(when interactive
(when (looking-at "[ \t]*\n")
(expand-abbrev))
@@ -3217,7 +3343,7 @@ Returns point."
(defun message-goto-eoh (&optional interactive)
"Move point to the end of the headers."
- (interactive "p")
+ (interactive "p" message-mode)
(message-goto-body interactive)
(forward-line -1))
@@ -3225,7 +3351,7 @@ Returns point."
"Move point to the beginning of the message signature.
If there is no signature in the article, go to the end and
return nil."
- (interactive)
+ (interactive nil message-mode)
(push-mark)
(goto-char (point-min))
(if (re-search-forward message-signature-separator nil t)
@@ -3244,7 +3370,7 @@ in the current mail buffer, and appends the current `user-mail-address'.
If the optional argument INCLUDE-CC is non-nil, the addresses in the
Cc: header are also put into the MFT."
- (interactive "P")
+ (interactive "P" message-mode)
(let* (cc tos)
(save-restriction
(message-narrow-to-headers)
@@ -3262,7 +3388,7 @@ Cc: header are also put into the MFT."
"Insert a To header that points to the author of the article being replied to.
If the original author requested not to be sent mail, don't insert unless the
prefix FORCE is given."
- (interactive "P")
+ (interactive "P" message-mode)
(let* ((mct (message-fetch-reply-field "mail-copies-to"))
(dont (and mct (or (equal (downcase mct) "never")
(equal (downcase mct) "nobody"))))
@@ -3281,7 +3407,7 @@ prefix FORCE is given."
(defun message-insert-wide-reply ()
"Insert To and Cc headers as if you were doing a wide reply."
- (interactive)
+ (interactive nil message-mode)
(let ((headers (message-with-reply-buffer
(message-get-reply-headers t))))
(message-carefully-insert-headers headers)))
@@ -3326,7 +3452,7 @@ or in the synonym headers, defined by `message-header-synonyms'."
(defun message-widen-reply ()
"Widen the reply to include maximum recipients."
- (interactive)
+ (interactive nil message-mode)
(let ((follow-to
(and (buffer-live-p message-reply-buffer)
(with-current-buffer message-reply-buffer
@@ -3342,7 +3468,7 @@ or in the synonym headers, defined by `message-header-synonyms'."
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
- (interactive)
+ (interactive nil message-mode)
(let ((old-newsgroups (mail-fetch-field "newsgroups"))
(new-newsgroups (message-fetch-reply-field "newsgroups"))
(first t)
@@ -3377,13 +3503,13 @@ or in the synonym headers, defined by `message-header-synonyms'."
(defun message-widen-and-recenter ()
"Widen the buffer and go to the start."
- (interactive)
+ (interactive nil message-mode)
(widen)
(goto-char (point-min)))
(defun message-delete-not-region (beg end)
"Delete everything in the body of the current message outside of the region."
- (interactive "r")
+ (interactive "r" message-mode)
(let (citeprefix)
(save-excursion
(goto-char beg)
@@ -3410,7 +3536,7 @@ or in the synonym headers, defined by `message-header-synonyms'."
"Kill all text up to the signature.
If a numeric argument or prefix arg is given, leave that number
of lines before the signature intact."
- (interactive "P")
+ (interactive "P" message-mode)
(save-excursion
(save-restriction
(let ((point (point)))
@@ -3428,7 +3554,7 @@ of lines before the signature intact."
(defun message-newline-and-reformat (&optional arg not-break)
"Insert four newlines, and then reformat if inside quoted text.
Prefix arg means justify as well."
- (interactive (list (if current-prefix-arg 'full)))
+ (interactive (list (if current-prefix-arg 'full)) message-mode)
(unless (message-in-body-p)
(error "This command only works in the body of the message"))
(let (quoted point beg end leading-space bolp fill-paragraph-function)
@@ -3464,8 +3590,8 @@ Prefix arg means justify as well."
(equal quoted (match-string 0)))
(goto-char (match-end 0))
(looking-at "[ \t]*")
- (if (> (length leading-space) (length (match-string 0)))
- (setq leading-space (match-string 0)))
+ (when (< (length leading-space) (length (match-string 0)))
+ (setq leading-space (match-string 0)))
(forward-line 1))
(setq end (point))
(goto-char beg)
@@ -3519,7 +3645,7 @@ Prefix arg means justify as well."
"Message specific function to fill a paragraph.
This function is used as the value of `fill-paragraph-function' in
Message buffers and is not meant to be called directly."
- (interactive (list (if current-prefix-arg 'full)))
+ (interactive (list (if current-prefix-arg 'full)) message-mode)
(if (message-point-in-header-p)
(message-fill-field)
(message-newline-and-reformat arg t))
@@ -3542,8 +3668,15 @@ Message buffers and is not meant to be called directly."
(do-auto-fill))))
(defun message-insert-signature (&optional force)
- "Insert a signature. See documentation for variable `message-signature'."
- (interactive (list 0))
+ "Insert a signature at the end of the buffer.
+
+See the documentation for the `message-signature' variable for
+more information.
+
+If FORCE is 0 (or when called interactively), the global values
+of the signature variables will be consulted if the local ones
+are null."
+ (interactive (list 0) message-mode)
(let ((message-signature message-signature)
(message-signature-file message-signature-file))
;; If called interactively and there's no signature to insert,
@@ -3568,7 +3701,7 @@ Message buffers and is not meant to be called directly."
((functionp message-signature)
(funcall message-signature))
((listp message-signature)
- (eval message-signature))
+ (eval message-signature t))
(t message-signature)))
signature-file)
(setq signature
@@ -3602,7 +3735,7 @@ Message buffers and is not meant to be called directly."
(defun message-insert-importance-high ()
"Insert header to mark message as important."
- (interactive)
+ (interactive nil message-mode)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@@ -3612,7 +3745,7 @@ Message buffers and is not meant to be called directly."
(defun message-insert-importance-low ()
"Insert header to mark message as unimportant."
- (interactive)
+ (interactive nil message-mode)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@@ -3624,7 +3757,7 @@ Message buffers and is not meant to be called directly."
"Insert a \"Importance: high\" header, or cycle through the header values.
The three allowed values according to RFC 1327 are `high', `normal'
and `low'."
- (interactive)
+ (interactive nil message-mode)
(save-excursion
(let ((new "high")
cur)
@@ -3644,7 +3777,7 @@ and `low'."
(defun message-insert-disposition-notification-to ()
"Request a disposition notification (return receipt) to this message.
Note that this should not be used in newsgroups."
- (interactive)
+ (interactive nil message-mode)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@@ -3659,7 +3792,7 @@ Note that this should not be used in newsgroups."
"Elide the text in the region.
An ellipsis (from `message-elide-ellipsis') will be inserted where the
text was killed."
- (interactive "r")
+ (interactive "r" message-mode)
(let ((lines (count-lines b e))
(chars (- e b)))
(kill-region b e)
@@ -3676,7 +3809,8 @@ text was killed."
(min (point) (or (mark t) (point)))
(max (point) (or (mark t) (point)))
(when current-prefix-arg
- (prefix-numeric-value current-prefix-arg))))
+ (prefix-numeric-value current-prefix-arg)))
+ message-mode)
(setq n (if (numberp n) (mod n 26) 13)) ;canonize N
(unless (or (zerop n) ; no action needed for a rot of 0
@@ -3710,7 +3844,8 @@ With prefix arg, specifies the number of places to rotate each letter forward.
Mail and USENET news headers are not rotated unless WIDE is non-nil."
(interactive (if current-prefix-arg
(list (prefix-numeric-value current-prefix-arg))
- (list nil)))
+ (list nil))
+ message-mode)
(save-excursion
(save-restriction
(when (and (not wide) (message-goto-body))
@@ -3730,7 +3865,7 @@ Mail and USENET news headers are not rotated unless WIDE is non-nil."
"Rename the *message* buffer to \"*message* RECIPIENT\".
If the function is run with a prefix, it will ask for a new buffer
name, rather than giving an automatic name."
- (interactive "Pbuffer name: ")
+ (interactive "Pbuffer name: " message-mode)
(save-excursion
(save-restriction
(goto-char (point-min))
@@ -3753,7 +3888,7 @@ name, rather than giving an automatic name."
(defun message-fill-yanked-message (&optional justifyp)
"Fill the paragraphs of a message yanked into this one.
Numeric argument means justify as well."
- (interactive "P")
+ (interactive "P" message-mode)
(save-excursion
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t)
@@ -3818,7 +3953,7 @@ If REMOVE is non-nil, remove newlines, too.
To use this automatically, you may add this function to
`gnus-message-setup-hook'."
- (interactive "P")
+ (interactive "P" message-mode)
(let ((citexp (concat "^\\("
(concat message-yank-cited-prefix "\\|")
message-yank-prefix
@@ -3883,17 +4018,18 @@ 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")
+ (interactive "P" message-mode)
;; eval the let forms contained in message-cite-style
- (eval
- `(let ,(if (symbolp message-cite-style)
- (symbol-value message-cite-style)
- message-cite-style)
- (message--yank-original-internal ',arg))))
+ (let ((bindings (if (symbolp message-cite-style)
+ (symbol-value message-cite-style)
+ message-cite-style)))
+ (cl-progv (mapcar #'car bindings)
+ (mapcar (lambda (binding) (eval (cadr binding) t)) bindings)
+ (message--yank-original-internal arg))))
(defun message-yank-buffer (buffer)
"Insert BUFFER into the current buffer and quote it."
- (interactive "bYank buffer: ")
+ (interactive "bYank buffer: " message-mode)
(let ((message-reply-buffer (get-buffer buffer)))
(save-window-excursion
(message-yank-original))))
@@ -3958,7 +4094,7 @@ This function uses `mail-citation-hook' if that is non-nil."
;; Insert a blank line if it is peeled off.
(insert "\n"))))
(goto-char start)
- (mapc 'funcall functions)
+ (mapc #'funcall functions)
(when message-citation-line-function
(unless (bolp)
(insert "\n"))
@@ -3976,7 +4112,6 @@ This function uses `mail-citation-hook' if that is non-nil."
"Cite function in the standard Message manner."
(message-cite-original-1 nil))
-(autoload 'format-spec "format-spec")
(autoload 'gnus-date-get-time "gnus-util")
(defun message-insert-formatted-citation-line (&optional from date tz)
@@ -4001,20 +4136,18 @@ See `message-citation-line-format'."
(when (or message-reply-headers (and from date))
(unless from
(setq from (mail-header-from message-reply-headers)))
- (let* ((data (condition-case ()
- (funcall (if (boundp 'gnus-extract-address-components)
- gnus-extract-address-components
- 'mail-extract-address-components)
- from)
- (error nil)))
+ (let* ((data (ignore-errors
+ (funcall (or (bound-and-true-p
+ gnus-extract-address-components)
+ #'mail-extract-address-components)
+ from)))
(name (car data))
(fname name)
(lname name)
- (net (car (cdr data)))
- (name-or-net (or (car data)
- (car (cdr data)) from))
+ (net (cadr data))
+ (name-or-net (or name net from))
(time
- (when (string-match "%[^fnNFL]" message-citation-line-format)
+ (when (string-match-p "%[^FLNfn]" message-citation-line-format)
(cond ((numberp (car-safe date)) date) ;; backward compatibility
(date (gnus-date-get-time date))
(t
@@ -4023,68 +4156,53 @@ See `message-citation-line-format'."
(tz (or tz
(when (stringp date)
(nth 8 (parse-time-string date)))))
- (flist
- (let ((i ?A) lst)
- (when (stringp name)
- ;; Guess first name and last name:
- (let* ((names (delq
- nil
- (mapcar
- (lambda (x)
- (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'"
- x)
- x
- nil))
- (split-string name "[ \t]+"))))
- (count (length names)))
- (cond ((= count 1)
- (setq fname (car names)
- lname ""))
- ((or (= count 2) (= count 3))
- (setq fname (car names)
- lname (mapconcat 'identity (cdr names) " ")))
- ((> count 3)
- (setq fname (mapconcat 'identity
- (butlast names (- count 2))
- " ")
- lname (mapconcat 'identity
- (nthcdr 2 names)
- " "))))
- (when (string-match "\\(.*\\),\\'" fname)
- (let ((newlname (match-string 1 fname)))
- (setq fname lname lname newlname)))))
- ;; The following letters are not used in `format-time-string':
- (push ?E lst) (push "<E>" lst)
- (push ?F lst) (push (or fname name-or-net) lst)
- ;; We might want to use "" instead of "<X>" later.
- (push ?J lst) (push "<J>" lst)
- (push ?K lst) (push "<K>" lst)
- (push ?L lst) (push lname lst)
- (push ?N lst) (push name-or-net lst)
- (push ?O lst) (push "<O>" lst)
- (push ?P lst) (push "<P>" lst)
- (push ?Q lst) (push "<Q>" lst)
- (push ?f lst) (push from lst)
- (push ?i lst) (push "<i>" lst)
- (push ?n lst) (push net lst)
- (push ?o lst) (push "<o>" lst)
- (push ?q lst) (push "<q>" lst)
- (push ?t lst) (push "<t>" lst)
- (push ?v lst) (push "<v>" lst)
- ;; Delegate the rest to `format-time-string':
- (while (<= i ?z)
- (when (and (not (memq i lst))
- ;; Skip (Z,a)
- (or (<= i ?Z)
- (>= i ?a)))
- (push i lst)
- (push (condition-case nil
- (format-time-string (format "%%%c" i) time tz)
- (error (format ">%c<" i)))
- lst))
- (setq i (1+ i)))
- (reverse lst)))
- (spec (apply 'format-spec-make flist)))
+ spec)
+ (when (stringp name)
+ ;; Guess first name and last name:
+ (let* ((names (seq-filter
+ (lambda (s)
+ (string-match-p (rx bos (+ (in word ?. ?-)) eos) s))
+ (split-string name "[ \t]+")))
+ (count (length names)))
+ (cond ((= count 1)
+ (setq fname (car names)
+ lname ""))
+ ((or (= count 2) (= count 3))
+ (setq fname (car names)
+ lname (string-join (cdr names) " ")))
+ ((> count 3)
+ (setq fname (string-join (butlast names (- count 2))
+ " ")
+ lname (string-join (nthcdr 2 names) " "))))
+ (when (string-match "\\(.*\\),\\'" fname)
+ (let ((newlname (match-string 1 fname)))
+ (setq fname lname lname newlname)))))
+ ;; The following letters are not used in `format-time-string':
+ (push (cons ?E "<E>") spec)
+ (push (cons ?F (or fname name-or-net)) spec)
+ ;; We might want to use "" instead of "<X>" later.
+ (push (cons ?J "<J>") spec)
+ (push (cons ?K "<K>") spec)
+ (push (cons ?L lname) spec)
+ (push (cons ?N name-or-net) spec)
+ (push (cons ?O "<O>") spec)
+ (push (cons ?P "<P>") spec)
+ (push (cons ?Q "<Q>") spec)
+ (push (cons ?f from) spec)
+ (push (cons ?i "<i>") spec)
+ (push (cons ?n net) spec)
+ (push (cons ?o "<o>") spec)
+ (push (cons ?q "<q>") spec)
+ (push (cons ?t "<t>") spec)
+ (push (cons ?v "<v>") spec)
+ ;; Delegate the rest to `format-time-string':
+ (dolist (c (nconc (number-sequence ?A ?Z)
+ (number-sequence ?a ?z)))
+ (unless (assq c spec)
+ (push (cons c (condition-case nil
+ (format-time-string (format "%%%c" c) time tz)
+ (error (format ">%c<" c))))
+ spec)))
(insert (format-spec message-citation-line-format spec)))
(newline)))
@@ -4138,7 +4256,7 @@ This function strips off the signature from the original message."
"Send message like `message-send', then, if no errors, exit from mail buffer.
The usage of ARG is defined by the instance that called Message.
It should typically alter the sending method in some way or other."
- (interactive "P")
+ (interactive "P" message-mode)
(let ((buf (current-buffer))
(position (point-marker))
(actions message-exit-actions))
@@ -4158,7 +4276,7 @@ It should typically alter the sending method in some way or other."
(defun message-dont-send ()
"Don't send the message you have been editing.
Instead, just auto-save the buffer and then bury it."
- (interactive)
+ (interactive nil message-mode)
(set-buffer-modified-p t)
(save-buffer)
(let ((actions message-postpone-actions))
@@ -4167,7 +4285,7 @@ Instead, just auto-save the buffer and then bury it."
(defun message-kill-buffer ()
"Kill the current buffer."
- (interactive)
+ (interactive nil message-mode)
(when (or (not (buffer-modified-p))
(not message-kill-buffer-query)
(yes-or-no-p "Message modified; kill anyway? "))
@@ -4216,7 +4334,7 @@ Otherwise any failure is reported in a message back to the user from
the mailer.
The usage of ARG is defined by the instance that called Message.
It should typically alter the sending method in some way or other."
- (interactive "P")
+ (interactive "P" message-mode)
;; Make it possible to undo the coming changes.
(undo-boundary)
(let ((inhibit-read-only t))
@@ -4227,6 +4345,10 @@ It should typically alter the sending method in some way or other."
(when message-confirm-send
(or (y-or-n-p "Send message? ")
(keyboard-quit)))
+ (when (and (not (mml-secure-is-encrypted-p))
+ (mml-secure-is-encrypted-p 'anywhere)
+ (not (yes-or-no-p "This message has a <#secure tag, but is not going to be encrypted. Send anyway?")))
+ (error "Aborting sending"))
(message message-sending-message)
(let ((alist message-send-method-alist)
(success t)
@@ -4376,7 +4498,7 @@ conformance."
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
(let (char found choice nul-chars)
- (message-goto-body)
+ (goto-char (point-min))
(setq nul-chars (save-excursion
(search-forward "\000" nil t)))
(while (progn
@@ -4412,11 +4534,12 @@ conformance."
,(format
"Replace non-printable characters with \"%s\" and send"
message-replacement-char))
+ (?u "url-encode" "Use URL %hex encoding")
(?s "send" "Send as is without removing anything")
(?e "edit" "Continue editing")))))
(if (eq choice ?e)
(error "Non-printable characters"))
- (message-goto-body)
+ (goto-char (point-min))
(skip-chars-forward mm-7bit-chars)
(while (not (eobp))
(when (let ((char (char-after)))
@@ -4433,11 +4556,17 @@ conformance."
control-1))
(not (get-text-property
(point) 'untranslated-utf-8)))))
- (if (eq choice ?i)
- (message-kill-all-overlays)
+ (cond
+ ((eq choice ?i)
+ (message-kill-all-overlays))
+ ((eq choice ?u)
+ (let ((char (get-byte (point))))
+ (delete-char 1)
+ (insert (format "%%%x" char))))
+ (t
(delete-char 1)
(when (eq choice ?r)
- (insert message-replacement-char))))
+ (insert message-replacement-char)))))
(forward-char)
(skip-chars-forward mm-7bit-chars)))))
(message-check 'bogus-recipient
@@ -4460,7 +4589,7 @@ An address might be bogus if there's a matching entry in
(and message-bogus-addresses
(let ((re
(if (listp message-bogus-addresses)
- (mapconcat 'identity
+ (mapconcat #'identity
message-bogus-addresses
"\\|")
message-bogus-addresses)))
@@ -4473,7 +4602,7 @@ An address might be bogus if there's a matching entry in
"Warn before composing or sending a mail to an invalid address.
This function could be useful in `message-setup-hook'."
- (interactive)
+ (interactive nil message-mode)
(save-restriction
(message-narrow-to-headers)
(dolist (hdr '("To" "Cc" "Bcc"))
@@ -4507,7 +4636,8 @@ This function could be useful in `message-setup-hook'."
(custom-add-option 'message-setup-hook 'message-check-recipients)
(defun message-add-action (action &rest types)
- "Add ACTION to be performed when doing an exit of type TYPES."
+ "Add ACTION to be performed when doing an exit of type TYPES.
+Valid types are `send', `return', `exit', `kill' and `postpone'."
(while types
(add-to-list (intern (format "message-%s-actions" (pop types)))
action)))
@@ -4530,7 +4660,7 @@ This function could be useful in `message-setup-hook'."
(funcall action))
;; Something to be evalled.
(t
- (eval action))))))
+ (eval action t))))))
(defun message-send-mail-partially ()
"Send mail as message/partial."
@@ -4757,7 +4887,7 @@ If you always want Gnus to send messages in one piece, set
message-courtesy-message)))
;; If this was set, `sendmail-program' takes care of encoding.
(unless message-inhibit-body-encoding
- ;; Let's make sure we encoded all the body.
+ ;; Let's make sure we encoded everything in the buffer.
(cl-assert (save-excursion
(goto-char (point-min))
(not (re-search-forward "[^\000-\377]" nil t)))))
@@ -4782,15 +4912,17 @@ If you always want Gnus to send messages in one piece, set
Each line should be no more than 79 characters long."
(goto-char (point-min))
(while (not (eobp))
- (when (and (looking-at "[^:]+:")
- (> (- (line-end-position) (point)) 79))
- (mail-header-fold-field))
- (forward-line 1)))
+ (if (and (looking-at "[^:]+:")
+ (> (- (line-end-position) (point)) 79))
+ (goto-char (mail-header-fold-field))
+ (forward-line 1))))
(defvar sendmail-program)
(defvar smtpmail-smtp-server)
(defvar smtpmail-smtp-service)
(defvar smtpmail-smtp-user)
+(defvar smtpmail-stream-type)
+(defvar smtpmail-store-queue-variables)
(defun message-multi-smtp-send-mail ()
"Send the current buffer to `message-send-mail-function'.
@@ -4806,9 +4938,15 @@ that instead."
(message-send-mail-with-sendmail))
((equal (car method) "smtp")
(require 'smtpmail)
- (let* ((smtpmail-smtp-server (nth 1 method))
+ (let* ((smtpmail-store-queue-variables t)
+ (smtpmail-smtp-server (nth 1 method))
(service (nth 2 method))
(port (string-to-number service))
+ ;; If we're talking to the TLS SMTP port, then force a
+ ;; TLS connection.
+ (smtpmail-stream-type (if (= port 465)
+ 'tls
+ smtpmail-stream-type))
(smtpmail-smtp-service (if (> port 0) port service))
(smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user)))
(message-smtpmail-send-it)))
@@ -4840,7 +4978,7 @@ that instead."
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
- (when (eval message-mailer-swallows-blank-line)
+ (when (eval message-mailer-swallows-blank-line t)
(newline))
(when message-interactive
(with-current-buffer errbuf
@@ -4848,7 +4986,7 @@ that instead."
(let* ((default-directory "/")
(coding-system-for-write message-send-coding-system)
(cpr (apply
- 'call-process-region
+ #'call-process-region
(append
(list (point-min) (point-max) sendmail-program
nil errbuf nil "-oi")
@@ -4900,7 +5038,7 @@ to find out how to use this."
(pcase
(let ((coding-system-for-write message-send-coding-system))
(apply
- 'call-process-region (point-min) (point-max)
+ #'call-process-region (point-min) (point-max)
message-qmail-inject-program nil nil nil
;; qmail-inject's default behavior is to look for addresses on the
;; command line; if there're none, it scans the headers.
@@ -5219,7 +5357,7 @@ Otherwise, generate and save a value for `canlock-password' first."
;; Check "Shoot me".
(message-check 'shoot
(if (re-search-forward
- "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
+ "Message-ID.*.mail-host-address-is-not-set" nil t)
(y-or-n-p "You appear to have a misconfigured system. Really post? ")
t))
;; Check for Approved.
@@ -5292,7 +5430,7 @@ Otherwise, generate and save a value for `canlock-password' first."
"Really use %s possibly unknown group%s: %s? "
(if (= (length errors) 1) "this" "these")
(if (= (length errors) 1) "" "s")
- (mapconcat 'identity errors ", "))))
+ (mapconcat #'identity errors ", "))))
;; There were no errors.
((not errors)
t)
@@ -5591,7 +5729,7 @@ The result is a fixnum."
(mail-file-babyl-p filename))
;; gnus-output-to-mail does the wrong thing with live, mbox
;; Rmail buffers in Emacs 23.
- ;; http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255
+ ;; https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255
(let ((buff (find-buffer-visiting filename)))
(and buff (with-current-buffer buff
(eq major-mode 'rmail-mode)))))
@@ -5638,7 +5776,7 @@ If NOW, use that time instead."
(defun message-insert-expires (days)
"Insert the Expires header. Expiry in DAYS days."
- (interactive "NExpire article in how many days? ")
+ (interactive "NExpire article in how many days? " message-mode)
(save-excursion
(message-position-on-field "Expires" "X-Draft-From")
(insert (message-make-expires-date days))))
@@ -5930,8 +6068,7 @@ give as trustworthy answer as possible."
user-domain)
;; Default to this bogus thing.
(t
- (concat sysname
- ".i-did-not-set--mail-host-address--so-tickle-me")))))
+ (concat sysname ".mail-host-address-is-not-set")))))
(defun message-make-domain ()
"Return the domain name."
@@ -5941,7 +6078,7 @@ give as trustworthy answer as possible."
(defun message-to-list-only ()
"Send a message to the list only.
Remove all addresses but the list address from To and Cc headers."
- (interactive)
+ (interactive nil message-mode)
(let ((listaddr (message-make-mail-followup-to t)))
(when listaddr
(save-excursion
@@ -5959,7 +6096,7 @@ subscribed address (and not the additional To and Cc header contents)."
(cc (message-fetch-field "cc"))
(msg-recipients (concat to (and to cc ", ") cc))
(recipients
- (mapcar 'mail-strip-quoted-names
+ (mapcar #'mail-strip-quoted-names
(message-tokenize-header msg-recipients)))
(file-regexps
(if message-subscribed-address-file
@@ -5976,11 +6113,11 @@ subscribed address (and not the additional To and Cc header contents)."
(if re (setq re (concat re "\\|" item))
(setq re (concat "\\`\\(" item))))
(and re (list (concat re "\\)\\'"))))))))
- (mft-regexps (apply 'append message-subscribed-regexps
- (mapcar 'regexp-quote
+ (mft-regexps (apply #'append message-subscribed-regexps
+ (mapcar #'regexp-quote
message-subscribed-addresses)
file-regexps
- (mapcar 'funcall
+ (mapcar #'funcall
message-subscribed-address-functions))))
(save-match-data
(let ((list
@@ -6001,7 +6138,7 @@ subscribed address (and not the additional To and Cc header contents)."
(dolist (rhs
(delete-dups
(mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) ""))
- (mapcar 'downcase
+ (mapcar #'downcase
(mapcar
(lambda (elem)
(or (cadr elem)
@@ -6027,7 +6164,7 @@ subscribed address (and not the additional To and Cc header contents)."
(defun message-idna-to-ascii-rhs ()
"Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
See `message-idna-encode'."
- (interactive)
+ (interactive nil message-mode)
(when message-use-idna
(save-excursion
(save-restriction
@@ -6245,7 +6382,7 @@ Headers already prepared in the buffer are not modified."
(defun message-split-line ()
"Split current line, moving portion beyond point vertically down.
If the current line has `message-yank-prefix', insert it on the new line."
- (interactive "*")
+ (interactive "*" message-mode)
(split-line message-yank-prefix))
(defun message-insert-header (header value)
@@ -6443,7 +6580,7 @@ When called without a prefix argument, header value spanning
multiple lines is treated as a single line. Otherwise, even if
N is 1, when point is on a continuation header line, it will be
moved to the beginning "
- (interactive "p")
+ (interactive "^p" message-mode)
(cond
;; Go to beginning of header or beginning of line.
((and message-beginning-of-line (message-point-in-header-p))
@@ -6467,7 +6604,7 @@ moved to the beginning "
(if to
(concat " to "
(or (car (mail-extract-address-components to))
- to) "")
+ to))
"")
(if (and group (not (string= group ""))) (concat " on " group) "")
"*")))
@@ -6481,7 +6618,7 @@ moved to the beginning "
(if to
(concat " to "
(or (car (mail-extract-address-components to))
- to) "")
+ to))
"")
(if (and group (not (string= group ""))) (concat " on " group) "")
"*")))
@@ -6510,7 +6647,7 @@ moved to the beginning "
(cons (string-to-number (or (match-string 1 b) "1"))
b)))
(buffer-list)))
- 'car-less-than-car)))
+ #'car-less-than-car)))
new)))))
(defun message-pop-to-buffer (name &optional switch-function)
@@ -6551,9 +6688,8 @@ moved to the beginning "
(not (buffer-modified-p buffer)))
(kill-buffer buffer))))
;; Rename the buffer.
- (if message-send-rename-function
- (funcall message-send-rename-function)
- (message-default-send-rename-function))
+ (funcall (or message-send-rename-function
+ #'message-default-send-rename-function))
;; Push the current buffer onto the list.
(when message-max-buffers
(setq message-buffer-list
@@ -6652,8 +6788,9 @@ are not included."
(defun message-setup-1 (headers &optional yank-action actions return-action)
(dolist (action actions)
(condition-case nil
+ ;; FIXME: Use functions rather than expressions!
(add-to-list 'message-send-actions
- `(apply ',(car action) ',(cdr action)))))
+ `(apply #',(car action) ',(cdr action)))))
(setq message-return-action return-action)
(setq message-reply-buffer
(if (and (consp yank-action)
@@ -6768,7 +6905,7 @@ are not included."
(defun message-insert-headers ()
"Generate the headers for the article."
- (interactive)
+ (interactive nil message-mode)
(save-excursion
(save-restriction
(message-narrow-to-headers)
@@ -6792,7 +6929,7 @@ are not included."
;;;###autoload
(defun message-mail (&optional to subject other-headers continue
switch-function yank-action send-actions
- return-action &rest ignored)
+ return-action &rest _)
"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
@@ -6866,8 +7003,8 @@ The function is called with one parameter, a cons cell ..."
(message-fetch-field "original-to")))
cc (message-fetch-field "cc")
extra (when message-extra-wide-headers
- (mapconcat 'identity
- (mapcar 'message-fetch-field
+ (mapconcat #'identity
+ (mapcar #'message-fetch-field
message-extra-wide-headers)
", "))
mct (message-fetch-field "mail-copies-to")
@@ -6951,7 +7088,7 @@ want to get rid of this query permanently.")))
(setq recipients
(cond ((functionp message-dont-reply-to-names)
(mapconcat
- 'identity
+ #'identity
(delq nil
(mapcar (lambda (mail)
(unless (funcall message-dont-reply-to-names
@@ -6985,7 +7122,7 @@ want to get rid of this query permanently.")))
;; Remove hierarchical lists that are contained within each other,
;; if message-hierarchical-addresses is defined.
(when message-hierarchical-addresses
- (let ((plain-addrs (mapcar 'car recipients))
+ (let ((plain-addrs (mapcar #'car recipients))
subaddrs recip)
(while plain-addrs
(setq subaddrs (assoc (car plain-addrs)
@@ -7006,15 +7143,25 @@ want to get rid of this query permanently.")))
;; 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)))))
- (when (and recipients
- (or (not message-wide-reply-confirm-recipients)
- (y-or-n-p "Reply to all recipients? ")))
- (setq recipients (mapconcat
- (lambda (addr) (cdr addr)) recipients ", "))
- (if (string-match "^ +" recipients)
- (setq recipients (substring recipients (match-end 0))))
- (push (cons 'Cc recipients) follow-to)))
+ (when (or (< (length recipients) 2)
+ (not message-wide-reply-confirm-recipients)
+ (y-or-n-p "Reply to all recipients? "))
+ (if never-mct
+ ;; The author has requested never to get a (wide)
+ ;; response, so put everybody else into the To header.
+ ;; This avoids looking as if we're To-in somebody else in
+ ;; specific, and just Cc-in the rest.
+ (setq follow-to (list
+ (cons 'To
+ (mapconcat #'cdr recipients ", "))))
+ ;; Put the first recipient in the To header.
+ (setq follow-to (list (cons 'To (cdr (pop recipients)))))
+ ;; Put the rest of the recipients in Cc.
+ (when recipients
+ (setq recipients (mapconcat #'cdr recipients ", "))
+ (if (string-match "^ +" recipients)
+ (setq recipients (substring recipients (match-end 0))))
+ (push (cons 'Cc recipients) follow-to)))))
follow-to))
(defun message-prune-recipients (recipients)
@@ -7310,7 +7457,7 @@ If ARG, allow editing of the cancellation message."
;; Make control message.
(if arg
(message-news)
- (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
+ (setq buf (set-buffer (gnus-get-buffer-create " *message cancel*"))))
(erase-buffer)
(insert "Newsgroups: " newsgroups "\n"
"From: " from "\n"
@@ -7527,14 +7674,28 @@ Optional DIGEST will use digest to forward."
"-------------------- End of forwarded message --------------------\n")
(message-remove-ignored-headers b e)))
-(defun message-remove-ignored-headers (b e)
+(defun message-remove-ignored-headers (b e &optional preserve-mime)
(when (or message-forward-ignored-headers
message-forward-included-headers)
+ (let ((saved-headers nil))
(save-restriction
(narrow-to-region b e)
(goto-char b)
(narrow-to-region (point)
(or (search-forward "\n\n" nil t) (point)))
+ ;; When forwarding as MIME, preserve some MIME headers.
+ (when preserve-mime
+ (let ((headers (buffer-string)))
+ (with-temp-buffer
+ (insert headers)
+ (message-remove-header
+ (if (listp message-forward-included-mime-headers)
+ (mapconcat
+ #'identity (cons "^$" message-forward-included-mime-headers)
+ "\\|")
+ message-forward-included-mime-headers)
+ t nil t)
+ (setq saved-headers (string-lines (buffer-string) t)))))
(when message-forward-ignored-headers
(let ((ignored (if (stringp message-forward-ignored-headers)
(list message-forward-ignored-headers)
@@ -7547,7 +7708,12 @@ Optional DIGEST will use digest to forward."
(mapconcat #'identity (cons "^$" message-forward-included-headers)
"\\|")
message-forward-included-headers)
- t nil t)))))
+ t nil t))
+ ;; Insert the MIME headers, if any.
+ (goto-char (point-max))
+ (forward-line -1)
+ (dolist (header saved-headers)
+ (insert header "\n"))))))
(defun message-forward-make-body-mime (forward-buffer &optional beg end)
(let ((b (point)))
@@ -7559,12 +7725,13 @@ Optional DIGEST will use digest to forward."
(goto-char (point-min))
(when (looking-at "From ")
(replace-match "X-From-Line: "))
+ (message-remove-ignored-headers (point-min) (point-max) t)
(goto-char (point-max)))
(insert "<#/part>\n")
;; Consider there is no illegible text.
(add-text-properties
b (point)
- '(no-illegible-text t rear-nonsticky t start-open t))))
+ '(no-illegible-text t rear-nonsticky t))))
(defun message-forward-make-body-mml (forward-buffer)
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
@@ -7718,7 +7885,7 @@ is for the internal use."
(interactive)
(setq rmail-enable-mime-composing t)
(setq rmail-insert-mime-forwarded-message-function
- 'message-forward-rmail-make-body))
+ #'message-forward-rmail-make-body))
;;;###autoload
(defun message-resend (address)
@@ -7731,7 +7898,7 @@ is for the internal use."
gcc beg)
;; We first set up a normal mail buffer.
(unless (message-mail-user-agent)
- (set-buffer (get-buffer-create " *message resend*"))
+ (set-buffer (gnus-get-buffer-create " *message resend*"))
(let ((inhibit-read-only t))
(erase-buffer)))
(let ((message-this-is-mail t)
@@ -7983,7 +8150,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list."
(defcustom message-tool-bar-retro
'(;; Old Emacs 21 icon for consistency.
- (message-send-and-exit "gnus/mail-send")
+ (message-send-and-exit "mail/send")
(message-kill-buffer "close")
(message-dont-send "cancel")
(mml-attach-file "attach" mml-mode-map)
@@ -8075,7 +8242,7 @@ 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. If that variable is nil, indent with the
regular text mode tabbing command."
- (interactive)
+ (interactive nil message-mode)
(cond
((let ((completion-fail-discreetly t))
(completion-at-point))
@@ -8231,7 +8398,7 @@ The following arguments may contain lists of values."
(with-output-to-temp-buffer " *MESSAGE information message*"
(with-current-buffer " *MESSAGE information message*"
(fundamental-mode)
- (mapc 'princ text)
+ (mapc #'princ text)
(goto-char (point-min))))
(funcall ask question))
(funcall ask question)))
@@ -8452,7 +8619,7 @@ From headers in the original article."
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
- (interactive (list t))
+ (interactive (list t) message-mode)
(when (message--in-tocc-p)
(let* ((end (point))
(start (save-excursion
@@ -8510,7 +8677,7 @@ Meant for use on `completion-at-point-functions'."
;; FIXME: What is the most common term (circular letter, form letter, serial
;; letter, standard letter) for such kind of letter? See also
-;; <http://en.wikipedia.org/wiki/Form_letter>
+;; <https://en.wikipedia.org/wiki/Form_letter>
;; FIXME: Maybe extent message-mode's font-lock support to recognize
;; `message-form-letter-separator', i.e. highlight each message like a single
@@ -8539,7 +8706,7 @@ Unless FORCE, prompt before sending.
The messages are separated by `message-form-letter-separator'.
Header and body are separated by `mail-header-separator'."
- (interactive "P")
+ (interactive "P" message-mode)
(let ((sent 0) (skipped 0)
start end text
buff
@@ -8574,17 +8741,18 @@ Header and body are separated by `mail-header-separator'."
(defun message-replace-header (header new-value &optional after force)
"Remove HEADER and insert the NEW-VALUE.
-If AFTER, insert after this header. If FORCE, insert new field
-even if NEW-VALUE is empty."
+If AFTER, insert after this header. AFTER may be a list of
+headers. If FORCE, insert new field even if NEW-VALUE is empty."
;; Similar to `nnheader-replace-header' but for message buffers.
(save-excursion
(save-restriction
(message-narrow-to-headers)
(message-remove-header header))
(when (or force (> (length new-value) 0))
- (if after
- (message-position-on-field header after)
- (message-position-on-field header))
+ (apply #'message-position-on-field header
+ (if (listp after)
+ after
+ (list after)))
(insert new-value))))
(make-obsolete-variable
@@ -8607,7 +8775,7 @@ Used in `message-simplify-recipients'."
(make-obsolete 'message-simplify-recipients nil "27.1")
(defun message-simplify-recipients ()
- (interactive)
+ (interactive nil message-mode)
(dolist (hdr '("Cc" "To"))
(message-replace-header
hdr
@@ -8630,7 +8798,8 @@ Used in `message-simplify-recipients'."
(defun message-make-html-message-with-image-files (files)
"Make a message containing the current dired-marked image files."
- (interactive (list (dired-get-marked-files nil current-prefix-arg)))
+ (interactive (list (dired-get-marked-files nil current-prefix-arg))
+ dired-mode)
(message-mail)
(message-goto-body)
(insert "<#part type=text/html>\n\n")
@@ -8641,7 +8810,7 @@ Used in `message-simplify-recipients'."
(defun message-toggle-image-thumbnails ()
"For any included image files, insert a thumbnail of that image."
- (interactive)
+ (interactive nil message-mode)
(let ((displayed nil))
(save-excursion
(goto-char (point-min))
@@ -8670,8 +8839,113 @@ Used in `message-simplify-recipients'."
(* 0.5 (- (nth 3 edges) (nth 1 edges)))))
string)))))))
+(defun message-insert-screenshot (delay)
+ "Take a screenshot and insert in the current buffer.
+DELAY (the numeric prefix) says how many seconds to wait before
+starting the screenshotting process.
+
+The `message-screenshot-command' variable says what command is
+used to take the screenshot."
+ (interactive "p" message-mode)
+ (unless (executable-find (car message-screenshot-command))
+ (error "Can't find %s to take the screenshot"
+ (car message-screenshot-command)))
+ (cl-decf delay)
+ (unless (zerop delay)
+ (dotimes (i delay)
+ (message "Sleeping %d second%s..."
+ (- delay i)
+ (if (= (- delay i) 1)
+ ""
+ "s"))
+ (sleep-for 1)))
+ (message "Take screenshot")
+ (let ((image
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (apply #'call-process
+ (car message-screenshot-command) nil (current-buffer) nil
+ (cdr message-screenshot-command))
+ (buffer-string))))
+ (set-mark (point))
+ (insert-image
+ (create-image image 'png t
+ :max-width (truncate (* (frame-pixel-width) 0.8))
+ :max-height (truncate (* (frame-pixel-height) 0.8))
+ :scale 1)
+ (format "<#part type=\"image/png\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>"
+ ;; Get a base64 version of the image -- this avoids later
+ ;; complications if we're auto-saving the buffer and
+ ;; restoring from a file.
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert image)
+ (base64-encode-region (point-min) (point-max) t)
+ (buffer-string))))
+ (insert "\n\n")
+ (message "")))
+
+(declare-function gnus-url-unhex-string "gnus-util")
+
+(defun message-parse-mailto-url (url)
+ "Parse a mailto: url."
+ (setq url (replace-regexp-in-string "\n" " " url))
+ (when (string-match "mailto:/*\\(.*\\)" url)
+ (setq url (substring url (match-beginning 1) nil)))
+ (setq url (if (string-match "^\\?" url)
+ (substring url 1)
+ (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
+ (concat "to=" (match-string 1 url) "&"
+ (match-string 2 url))
+ (concat "to=" url))))
+ (let (retval pairs cur key val)
+ (setq pairs (split-string url "&"))
+ (while pairs
+ (setq cur (car pairs)
+ pairs (cdr pairs))
+ (if (not (string-match "=" cur))
+ nil ; Grace
+ (setq key (downcase (gnus-url-unhex-string
+ (substring cur 0 (match-beginning 0))))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
+ retval))
+
+;;;###autoload
+(defun message-mailto (&optional url)
+ "Command to parse command line mailto: links.
+This is meant to be used for MIME handlers: Setting the handler
+for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\"
+will then start up Emacs ready to compose mail. For emacsclient use
+ emacsclient -e '(message-mailto \"%u\")'"
+ (interactive)
+ ;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a>
+ (message-mail)
+ (message-mailto-1 (or url (pop command-line-args-left))))
+
+(defun message-mailto-1 (url)
+ (let ((args (message-parse-mailto-url url)))
+ (dolist (arg args)
+ (unless (equal (car arg) "body")
+ (message-position-on-field (capitalize (car arg)))
+ (insert (replace-regexp-in-string
+ "\r\n" "\n"
+ (mapconcat #'identity (reverse (cdr arg)) ", ") nil t))))
+ (when (assoc "body" args)
+ (message-goto-body)
+ (dolist (body (cdr (assoc "body" args)))
+ (insert body "\n")))
+ (if (assoc "subject" args)
+ (message-goto-body)
+ (message-goto-subject))))
+
(provide 'message)
+(make-obsolete-variable 'message-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'message-load-hook)
;; Local Variables:
diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el
index da420c9e638..fdc83e1de6e 100644
--- a/lisp/gnus/mm-archive.el
+++ b/lisp/gnus/mm-archive.el
@@ -1,4 +1,4 @@
-;;; mm-archive.el --- Functions for parsing archive files as MIME
+;;; mm-archive.el --- Functions for parsing archive files as MIME -*- lexical-binding: t; -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
@@ -24,6 +24,7 @@
(require 'mm-decode)
(autoload 'gnus-recursive-directory-files "gnus-util")
+(autoload 'gnus-get-buffer-create "gnus")
(autoload 'mailcap-extension-to-mime "mailcap")
(defvar mm-archive-decoders
@@ -41,8 +42,9 @@
dir)
(unless decoder
(error "No decoder found for %s" type))
- (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir))
- (set-file-modes dir #o700)
+ (with-file-modes #o700
+ (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory)
+ 'dir)))
(unwind-protect
(progn
(mm-with-unibyte-buffer
@@ -52,11 +54,11 @@
(write-region (point-min) (point-max) file nil 'silent)
(setq decoder (copy-sequence decoder))
(setcar (member "%f" decoder) file)
- (apply 'call-process (car decoder) nil nil nil
+ (apply #'call-process (car decoder) nil nil nil
(append (cdr decoder) (list dir)))
(delete-file file))
- (apply 'call-process-region (point-min) (point-max) (car decoder)
- nil (get-buffer-create "*tnef*")
+ (apply #'call-process-region (point-min) (point-max) (car decoder)
+ nil (gnus-get-buffer-create "*tnef*")
nil (append (cdr decoder) (list dir)))))
`("multipart/mixed"
,handle
@@ -98,12 +100,12 @@
(goto-char (point-max))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t)
- (end ,(point-marker)))
- (remove-images ,start end)
- (delete-region ,start end)))))))
+ (let ((end (point-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (remove-images start end)
+ (delete-region start end))))))))
(provide 'mm-archive)
-;; mm-archive.el ends here
+;;; mm-archive.el ends here
diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el
index f35ba3a0b91..d6b71f15e54 100644
--- a/lisp/gnus/mm-bodies.el
+++ b/lisp/gnus/mm-bodies.el
@@ -1,4 +1,4 @@
-;;; mm-bodies.el --- Functions for decoding MIME things
+;;; mm-bodies.el --- Functions for decoding MIME things -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index d50d05401da..02cd6af0c98 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -40,8 +40,8 @@
(defvar gnus-current-window-configuration)
-(add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
-(add-hook 'gnus-exit-gnus-hook 'mm-temp-files-delete)
+(add-hook 'gnus-exit-gnus-hook #'mm-destroy-postponed-undisplay-list)
+(add-hook 'gnus-exit-gnus-hook #'mm-temp-files-delete)
(defgroup mime-display ()
"Display of MIME in mail and news articles."
@@ -602,11 +602,10 @@ files left at the next time."
(push temp fails)))
(if fails
;; Schedule the deletion of the files left at the next time.
- (progn
- (write-region (concat (mapconcat 'identity (nreverse fails) "\n")
+ (with-file-modes #o600
+ (write-region (concat (mapconcat #'identity (nreverse fails) "\n")
"\n")
- nil cache-file nil 'silent)
- (set-file-modes cache-file #o600))
+ nil cache-file nil 'silent))
(when (file-exists-p cache-file)
(ignore-errors (delete-file cache-file))))
(setq mm-temp-files-to-be-deleted nil)))
@@ -911,8 +910,10 @@ external if displayed external."
;; The function is a string to be executed.
(mm-insert-part handle)
(mm-add-meta-html-tag handle)
- (let* ((dir (make-temp-file
- (expand-file-name "emm." mm-tmp-directory) 'dir))
+ ;; We create a private sub-directory where we store our files.
+ (let* ((dir (with-file-modes #o700
+ (make-temp-file
+ (expand-file-name "emm." mm-tmp-directory) 'dir)))
(filename (or
(mail-content-type-get
(mm-handle-disposition handle) 'filename)
@@ -924,8 +925,6 @@ external if displayed external."
(assoc "needsterminal" mime-info)))
(copiousoutput (assoc "copiousoutput" mime-info))
file buffer)
- ;; We create a private sub-directory where we store our files.
- (set-file-modes dir #o700)
(if filename
(setq file (expand-file-name
(gnus-map-function mm-file-name-rewrite-functions
@@ -941,14 +940,15 @@ external if displayed external."
;; `mailcap-mime-extensions'.
(setq suffix (car (rassoc (mm-handle-media-type handle)
mailcap-mime-extensions))))
- (setq file (make-temp-file (expand-file-name "mm." dir)
- nil suffix))))
+ (setq file (with-file-modes #o600
+ (make-temp-file (expand-file-name "mm." dir)
+ nil suffix)))))
(let ((coding-system-for-write mm-binary-coding-system))
(write-region (point-min) (point-max) file nil 'nomesg))
;; The file is deleted after the viewer exists. If the users edits
;; the file, changes will be lost. Set file to read-only to make it
;; clear.
- (set-file-modes file #o400)
+ (set-file-modes file #o400 'nofollow)
(message "Viewing with %s" method)
(cond
(needsterm
@@ -1081,7 +1081,8 @@ external if displayed external."
(string= total "\"%s\""))
(setq uses-stdin nil)
(push (shell-quote-argument
- (gnus-map-function mm-path-name-rewrite-functions file)) out))
+ (gnus-map-function mm-path-name-rewrite-functions file))
+ out))
((string= total "%t")
(push (shell-quote-argument (car type-list)) out))
(t
@@ -1092,7 +1093,7 @@ external if displayed external."
(push (shell-quote-argument
(gnus-map-function mm-path-name-rewrite-functions file))
out))
- (mapconcat 'identity (nreverse out) "")))
+ (mapconcat #'identity (nreverse out) "")))
(defun mm-remove-parts (handles)
"Remove the displayed MIME parts represented by HANDLES."
@@ -1255,6 +1256,7 @@ in HANDLE."
(defmacro mm-with-part (handle &rest forms)
"Run FORMS in the temp buffer containing the contents of HANDLE."
+ (declare (indent 1) (debug t))
;; The handle-buffer's content is a sequence of bytes, not a sequence of
;; chars, so the buffer should be unibyte. It may happen that the
;; handle-buffer is multibyte for some reason, in which case now is a good
@@ -1270,8 +1272,6 @@ in HANDLE."
(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))
(defun mm-get-part (handle &optional no-cache)
"Return the contents of HANDLE as a string.
@@ -1364,10 +1364,7 @@ PROMPT overrides the default one used to ask user for a file name."
(setq file
(read-file-name
(or prompt
- (format "Save MIME part to%s: "
- (if filename
- (format " (default %s)" filename)
- "")))
+ (format-prompt "Save MIME part to" filename))
(or directory mm-default-directory default-directory)
(expand-file-name
(or filename "")
@@ -1668,18 +1665,26 @@ If RECURSIVE, search recursively."
(let ((type (car ctl))
(subtype (cadr (split-string (car ctl) "/")))
(mm-security-handle ctl) ;; (car CTL) is the type.
+ (smime-type (cdr (assq 'smime-type (mm-handle-type parts))))
protocol func functest)
(cond
((or (equal type "application/x-pkcs7-mime")
(equal type "application/pkcs7-mime"))
(with-temp-buffer
(when (and (cond
+ ((equal smime-type "signed-data") t)
((eq mm-decrypt-option 'never) nil)
((eq mm-decrypt-option 'always) t)
((eq mm-decrypt-option 'known) t)
(t (y-or-n-p
(format "Decrypt (S/MIME) part? "))))
(mm-view-pkcs7 parts from))
+ (goto-char (point-min))
+ ;; The encrypted document is a MIME part, and may use either
+ ;; CRLF (Outlook and the like) or newlines for end-of-line
+ ;; markers. Translate from CRLF.
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
;; Normally there will be a Content-type header here, but
;; some mailers don't add that to the encrypted part, which
;; makes the subsequent re-dissection fail here.
@@ -1688,7 +1693,21 @@ If RECURSIVE, search recursively."
(unless (mail-fetch-field "content-type")
(goto-char (point-max))
(insert "Content-type: text/plain\n\n")))
- (setq parts (mm-dissect-buffer t)))))
+ (setq parts
+ (if (equal smime-type "signed-data")
+ (list (propertize
+ "multipart/signed"
+ 'protocol "application/pkcs7-signature"
+ 'gnus-info
+ (format
+ "%s:%s"
+ (get-text-property 0 'gnus-info
+ (car mm-security-handle))
+ (get-text-property 0 'gnus-details
+ (car mm-security-handle))))
+ (mm-dissect-buffer t)
+ parts)
+ (mm-dissect-buffer t))))))
((equal subtype "signed")
(unless (and (setq protocol
(mm-handle-multipart-ctl-parameter ctl 'protocol))
diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el
index 8bd3e0b3d2d..84a3b0a8d1c 100644
--- a/lisp/gnus/mm-encode.el
+++ b/lisp/gnus/mm-encode.el
@@ -1,4 +1,4 @@
-;;; mm-encode.el --- Functions for encoding MIME things
+;;; mm-encode.el --- Functions for encoding MIME things -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -98,9 +98,12 @@ This variable should never be set directly, but bound before a call to
boundary))
;;;###autoload
-(defun mm-default-file-encoding (file)
- "Return a default encoding for FILE."
- (if (not (string-match "\\.[^.]+$" file))
+(define-obsolete-function-alias 'mm-default-file-encoding
+ #'mm-default-file-type "future") ;Old bad name.
+;;;###autoload
+(defun mm-default-file-type (file)
+ "Return a default content type for FILE."
+ (if (not (string-match "\\.[^.]+\\'" file))
"application/octet-stream"
(mailcap-extension-to-mime (match-string 0 file))))
diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el
index 165c19139ce..0c628055acb 100644
--- a/lisp/gnus/mm-partial.el
+++ b/lisp/gnus/mm-partial.el
@@ -1,4 +1,4 @@
-;;; mm-partial.el --- showing message/partial
+;;; mm-partial.el --- showing message/partial -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -39,7 +39,8 @@
gnus-newsgroup-name)
(when (search-forward id nil t)
(let ((nhandles (mm-dissect-buffer
- nil gnus-article-loose-mime)) nid)
+ nil gnus-article-loose-mime))
+ nid)
(if (consp (car nhandles))
(mm-destroy-parts nhandles)
(setq nid (cdr (assq 'id
@@ -49,6 +50,8 @@
(push nhandles phandles))))))))
phandles))
+(defvar gnus-displaying-mime)
+
;;;###autoload
(defun mm-inline-partial (handle &optional no-display)
"Show the partial part of HANDLE.
@@ -59,7 +62,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
phandles
(b (point)) (n 1) total
phandle nn ntotal
- gnus-displaying-mime handles buffer)
+ gnus-displaying-mime handles) ;; buffer
(unless (mm-handle-cache handle)
(unless id
(error "Can not find message/partial id"))
@@ -69,14 +72,14 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
id
(with-current-buffer gnus-summary-buffer
(gnus-summary-article-number))))
- #'(lambda (a b)
- (let ((anumber (string-to-number
- (cdr (assq 'number
- (cdr (mm-handle-type a))))))
- (bnumber (string-to-number
- (cdr (assq 'number
- (cdr (mm-handle-type b)))))))
- (< anumber bnumber)))))
+ (lambda (a b)
+ (let ((anumber (string-to-number
+ (cdr (assq 'number
+ (cdr (mm-handle-type a))))))
+ (bnumber (string-to-number
+ (cdr (assq 'number
+ (cdr (mm-handle-type b)))))))
+ (< anumber bnumber)))))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles phandles))
(with-current-buffer (generate-new-buffer " *mm*")
@@ -90,7 +93,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(if ntotal
(if total
(unless (eq total ntotal)
- (error "The numbers of total are different"))
+ (error "The numbers of total are different"))
(setq total ntotal)))
(unless (< nn n)
(unless (eq nn n)
@@ -132,9 +135,11 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(mm-merge-handles gnus-article-mime-handles handles)))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let (buffer-read-only)
- (delete-region ,(point-min-marker) ,(point-max-marker))))))))))
+ (let ((beg (point-min-marker))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end))))))))))
(provide 'mm-partial)
diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el
index 412a4744125..3d58738d637 100644
--- a/lisp/gnus/mm-url.el
+++ b/lisp/gnus/mm-url.el
@@ -1,4 +1,4 @@
-;;; mm-url.el --- a wrapper of url functions/commands for Gnus
+;;; mm-url.el --- a wrapper of url functions/commands for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -44,8 +44,7 @@
(defcustom mm-url-use-external nil
"If non-nil, use external grab program `mm-url-program'."
:version "22.1"
- :type 'boolean
- :group 'mm-url)
+ :type 'boolean)
(defvar mm-url-predefined-programs
'((wget "wget" "--user-agent=mm-url" "-q" "-O" "-")
@@ -68,14 +67,12 @@ Likely values are `wget', `w3m', `lynx' and `curl'."
(symbol :tag "w3m" w3m)
(symbol :tag "lynx" lynx)
(symbol :tag "curl" curl)
- (string :tag "other"))
- :group 'mm-url)
+ (string :tag "other")))
(defcustom mm-url-arguments nil
"The arguments for `mm-url-program'."
:version "22.1"
- :type '(repeat string)
- :group 'mm-url)
+ :type '(repeat string))
;;; Internal variables
@@ -299,7 +296,7 @@ If `mm-url-use-external' is non-nil, use `mm-url-program'."
args (append (cdr item) (list url))))
(setq program mm-url-program
args (append mm-url-arguments (list url))))
- (unless (eq 0 (apply 'call-process program nil t nil args))
+ (unless (eq 0 (apply #'call-process program nil t nil args))
(error "Couldn't fetch %s" url))))
(defvar mm-url-timeout 30
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index 0d887a18ed7..92e04f9d2ee 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -70,7 +70,7 @@
(mm-coding-system-p 'cp932))
'((windows-31j . cp932)))
;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936
- ;; http://www.iana.org/assignments/charset-reg/GBK
+ ;; https://www.iana.org/assignments/charset-reg/GBK
;; Emacs 22.1 has cp936, but not gbk, so we alias it:
,@(when (and (not (mm-coding-system-p 'gbk))
(mm-coding-system-p 'cp936))
@@ -131,10 +131,6 @@ is not available."
(cond
((null charset)
charset)
- ;; Running in a non-MULE environment.
- ((or (null (mm-get-coding-system-list))
- (not (fboundp 'coding-system-get)))
- charset)
;; Check override list quite early. Should only used for decoding, not for
;; encoding!
((and allow-override
@@ -148,9 +144,9 @@ is not available."
;; on there being some coding system matching each `mime-charset'
;; property defined, as there should be.)
((and (mm-coding-system-p charset)
-;;; Doing this would potentially weed out incorrect charsets.
-;;; charset
-;;; (eq charset (coding-system-get charset 'mime-charset))
+ ;; Doing this would potentially weed out incorrect charsets.
+ ;; charset
+ ;; (eq charset (coding-system-get charset 'mime-charset))
)
charset)
;; Use coding system Emacs knows.
@@ -164,7 +160,7 @@ is not available."
form
(prog2
;; Avoid errors...
- (condition-case nil (eval form) (error nil))
+ (condition-case nil (eval form t) (error nil))
;; (message "Failed to eval `%s'" form))
(mm-coding-system-p cs)
(message "Added charset `%s' via `mm-charset-eval-alist'" cs))
@@ -295,77 +291,16 @@ superset of iso-8859-1."
(defvar mm-universal-coding-system mm-auto-save-coding-system
"The universal coding system.")
-;; Fixme: some of the cars here aren't valid MIME charsets. That
-;; should only matter with XEmacs, though.
(defvar mm-mime-mule-charset-alist
- '((us-ascii ascii)
- (iso-8859-1 latin-iso8859-1)
- (iso-8859-2 latin-iso8859-2)
- (iso-8859-3 latin-iso8859-3)
- (iso-8859-4 latin-iso8859-4)
- (iso-8859-5 cyrillic-iso8859-5)
- ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters.
- ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default
- ;; charset is koi8-r, not iso-8859-5.
- (koi8-r cyrillic-iso8859-5 gnus-koi8-r)
- (iso-8859-6 arabic-iso8859-6)
- (iso-8859-7 greek-iso8859-7)
- (iso-8859-8 hebrew-iso8859-8)
- (iso-8859-9 latin-iso8859-9)
- (iso-8859-14 latin-iso8859-14)
- (iso-8859-15 latin-iso8859-15)
- (viscii vietnamese-viscii-lower)
- (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978)
- (euc-kr korean-ksc5601)
- (gb2312 chinese-gb2312)
- (gbk chinese-gbk)
- (gb18030 gb18030-2-byte
- gb18030-4-byte-bmp gb18030-4-byte-smp
- gb18030-4-byte-ext-1 gb18030-4-byte-ext-2)
- (big5 chinese-big5-1 chinese-big5-2)
- (tibetan tibetan)
- (thai-tis620 thai-tis620)
- (windows-1251 cyrillic-iso8859-5)
- (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
- (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
- latin-jisx0201 japanese-jisx0208-1978
- chinese-gb2312 japanese-jisx0208
- korean-ksc5601 japanese-jisx0212)
- (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
- latin-jisx0201 japanese-jisx0208-1978
- chinese-gb2312 japanese-jisx0208
- korean-ksc5601 japanese-jisx0212
- chinese-cns11643-1 chinese-cns11643-2)
- (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
- cyrillic-iso8859-5 greek-iso8859-7
- latin-jisx0201 japanese-jisx0208-1978
- chinese-gb2312 japanese-jisx0208
- korean-ksc5601 japanese-jisx0212
- chinese-cns11643-1 chinese-cns11643-2
- chinese-cns11643-3 chinese-cns11643-4
- chinese-cns11643-5 chinese-cns11643-6
- chinese-cns11643-7)
- (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208
- japanese-jisx0213-1 japanese-jisx0213-2)
- (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208)
- (utf-8))
- "Alist of MIME-charset/MULE-charsets.")
-
-;; Correct by construction, but should be unnecessary for Emacs:
-(when (and (fboundp 'coding-system-list)
- (fboundp 'sort-coding-systems))
- (let ((css (sort-coding-systems (coding-system-list 'base-only)))
- cs mime mule alist)
- (while css
- (setq cs (pop css)
- mime (or (coding-system-get cs :mime-charset) ; Emacs 23 (unicode)
- (coding-system-get cs 'mime-charset)))
+ (let (mime mule alist)
+ (dolist (cs (sort-coding-systems (coding-system-list 'base-only)))
+ (setq mime (coding-system-get cs 'mime-charset))
(when (and mime
- (not (eq t (setq mule
- (coding-system-get cs 'safe-charsets))))
+ (not (eq t (setq mule (coding-system-get cs 'safe-charsets))))
(not (assq mime alist)))
(push (cons mime (delq 'ascii mule)) alist)))
- (setq mm-mime-mule-charset-alist (nreverse alist))))
+ (nreverse alist))
+ "Alist of MIME-charset/MULE-charsets.")
(defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2)
"A list of special charsets.
@@ -445,7 +380,7 @@ like \"&#128;\" to the euro sign, mainly in html messages."
"Return the MIME charset corresponding to the given Mule CHARSET."
(let ((css (sort (sort-coding-systems
(find-coding-systems-for-charsets (list charset)))
- 'mm-sort-coding-systems-predicate))
+ #'mm-sort-coding-systems-predicate))
cs mime)
(while (and (not mime)
css)
@@ -566,7 +501,7 @@ charset, and a longer list means no appropriate charset."
(let ((systems (find-coding-systems-region b e)))
(when mm-coding-system-priorities
(setq systems
- (sort systems 'mm-sort-coding-systems-predicate)))
+ (sort systems #'mm-sort-coding-systems-predicate)))
(setq systems (delq 'compound-text systems))
(unless (equal systems '(undecided))
(while systems
@@ -816,7 +751,7 @@ decompressed data. The buffer's multibyteness must be turned off."
(insert-buffer-substring cur)
(condition-case err
(progn
- (unless (memq (apply 'call-process-region
+ (unless (memq (apply #'call-process-region
(point-min) (point-max)
prog t (list t err-file) nil args)
jka-compr-acceptable-retval-list)
diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el
index b730b8e90d3..9d4c4bfead7 100644
--- a/lisp/gnus/mm-uu.el
+++ b/lisp/gnus/mm-uu.el
@@ -192,7 +192,7 @@ This can be either \"inline\" or \"attachment\".")
,(lambda () (mm-uu-verbatim-marks-extract 0 0))
nil)
(LaTeX
- "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]"
+ "^\\([\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]"
"^\\\\end{document}"
,#'mm-uu-latex-extract
nil
@@ -251,19 +251,23 @@ The value should be nil on displays where the face
(((type tty)
(class color)
(background dark))
- (:background "dark blue"))
+ (:background "dark blue"
+ :extend t))
(((class color)
(background dark))
(:foreground "light yellow"
- :background "dark green"))
+ :background "dark green"
+ :extend t))
(((type tty)
(class color)
(background light))
- (:foreground "dark blue"))
+ (:foreground "dark blue"
+ :extend t))
(((class color)
(background light))
(:foreground "dark green"
- :background "light yellow"))
+ :background "light yellow"
+ :extend t))
(t
()))
"Face for extracted buffers."
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index a06eedbaf7b..2ec75a0bc59 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -1,4 +1,4 @@
-;;; mm-view.el --- functions for viewing MIME objects
+;;; mm-view.el --- functions for viewing MIME objects -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -59,11 +59,16 @@
"The attributes of renderer types for text/html.")
(defcustom mm-fill-flowed t
- "If non-nil a format=flowed article will be displayed flowed."
+ "If non-nil, format=flowed articles will be displayed flowed."
:type 'boolean
:version "22.1"
:group 'mime-display)
+;; Not a defcustom, since it's usually overridden by the callers of
+;; the mm functions.
+(defvar mm-inline-font-lock t
+ "If non-nil, do font locking of inline media types that support it.")
+
(defcustom mm-inline-large-images-proportion 0.9
"Maximum proportion large images can occupy in the buffer.
This is only used if `mm-inline-large-images' is set to
@@ -99,11 +104,10 @@ This is only used if `mm-inline-large-images' is set to
(insert "\n")
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((b ,b)
- (inhibit-read-only t))
- (remove-images b b)
- (delete-region b (1+ b)))))))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (remove-images b b)
+ (delete-region b (1+ b)))))))
(defvar mm-w3m-setup nil
"Whether gnus-article-mode has been setup to use emacs-w3m.")
@@ -132,7 +136,7 @@ This is only used if `mm-inline-large-images' is set to
(equal "multipart" (mm-handle-media-supertype elem)))
(mm-w3m-cid-retrieve-1 url elem)))))
-(defun mm-w3m-cid-retrieve (url &rest args)
+(defun mm-w3m-cid-retrieve (url &rest _args)
"Insert a content pointed by URL if it has the cid: scheme."
(when (string-match "\\`cid:" url)
(or (catch 'found-handle
@@ -144,6 +148,9 @@ This is only used if `mm-inline-large-images' is set to
nil
(message "Failed to find \"Content-ID: %s\"" url)))))
+(defvar w3m-force-redisplay)
+(defvar w3m-safe-url-regexp)
+
(defun mm-inline-text-html-render-with-w3m (handle)
"Render a text/html part using emacs-w3m."
(mm-setup-w3m)
@@ -194,10 +201,11 @@ This is only used if `mm-inline-large-images' is set to
'keymap w3m-minor-mode-map)))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(point-min-marker)
- ,(point-max-marker)))))))))
+ (let ((beg (point-min-marker))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))))
(defcustom mm-w3m-standalone-supports-m17n-p 'undecided
"T means the w3m command supports the m17n feature."
@@ -269,13 +277,13 @@ This is only used if `mm-inline-large-images' is set to
(write-region (point-min) (point-max) file nil 'silent))
(delete-region (point-min) (point-max))
(unwind-protect
- (apply 'call-process cmd nil t nil (mapcar 'eval args))
+ (apply #'call-process cmd nil t nil (mapcar (lambda (e) (eval e t)) args))
(delete-file file))
(and post-func (funcall post-func))))
(defun mm-inline-wash-with-stdin (post-func cmd &rest args)
(let ((coding-system-for-write 'binary))
- (apply 'call-process-region (point-min) (point-max)
+ (apply #'call-process-region (point-min) (point-max)
cmd t t nil args))
(and post-func (funcall post-func)))
@@ -285,7 +293,7 @@ This is only used if `mm-inline-large-images' is set to
handle
(mm-with-unibyte-buffer
(insert source)
- (apply 'mm-inline-wash-with-file post-func cmd args)
+ (apply #'mm-inline-wash-with-file post-func cmd args)
(buffer-string)))))
(defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
@@ -294,7 +302,7 @@ This is only used if `mm-inline-large-images' is set to
handle
(mm-with-unibyte-buffer
(insert source)
- (apply 'mm-inline-wash-with-stdin post-func cmd args)
+ (apply #'mm-inline-wash-with-stdin post-func cmd args)
(buffer-string)))))
(defun mm-inline-render-with-function (handle func &rest args)
@@ -312,7 +320,7 @@ This is only used if `mm-inline-large-images' is set to
(defun mm-inline-text-html (handle)
(if (stringp (car handle))
- (mapcar 'mm-inline-text-html (cdr handle))
+ (mapcar #'mm-inline-text-html (cdr handle))
(let* ((func mm-text-html-renderer)
(entry (assq func mm-text-html-renderer-alist))
(inhibit-read-only t))
@@ -373,10 +381,11 @@ This is only used if `mm-inline-large-images' is set to
handle
(if (= (point-min) (point-max))
#'ignore
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(copy-marker (point-min) t)
- ,(point-max-marker)))))))))
+ (let ((beg (copy-marker (point-min) t))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))))
(defun mm-insert-inline (handle text)
"Insert TEXT inline from HANDLE."
@@ -386,12 +395,13 @@ This is only used if `mm-inline-large-images' is set to
(insert "\n"))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(copy-marker b t)
- ,(point-marker)))))))
+ (let ((beg (copy-marker b t))
+ (end (point-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))
-(defun mm-inline-audio (handle)
+(defun mm-inline-audio (_handle)
(message "Not implemented"))
(defun mm-view-message ()
@@ -408,12 +418,18 @@ This is only used if `mm-inline-large-images' is set to
(fundamental-mode)
(goto-char (point-min)))
+(defvar mm-inline-message-prepare-function nil
+ "Function called by `mm-inline-message' to do client specific setup.
+It is called with one parameter -- the charset.")
+
(defun mm-inline-message (handle)
+ "Insert HANDLE (a message/rfc822 part) into the current buffer.
+This function will call `mm-inline-message-prepare-function'
+after inserting the part."
(let ((b (point))
(bolp (bolp))
(charset (mail-content-type-get
- (mm-handle-type handle) 'charset))
- gnus-displaying-mime handles)
+ (mm-handle-type handle) 'charset)))
(when (and charset
(stringp charset))
(setq charset (intern (downcase charset)))
@@ -423,16 +439,8 @@ This is only used if `mm-inline-large-images' is set to
(save-restriction
(narrow-to-region b b)
(mm-insert-part handle)
- (let (gnus-article-mime-handles
- ;; disable prepare hook
- gnus-article-prepare-hook
- (gnus-newsgroup-charset
- (unless (eq charset 'gnus-decoded) ;; mm-uu might set it.
- (or charset gnus-newsgroup-charset))))
- (let ((gnus-original-article-buffer (mm-handle-buffer handle)))
- (run-hooks 'gnus-article-decode-hook))
- (gnus-article-prepare-display)
- (setq handles gnus-article-mime-handles))
+ (when mm-inline-message-prepare-function
+ (funcall mm-inline-message-prepare-function charset))
(goto-char (point-min))
(unless bolp
(insert "\n"))
@@ -440,14 +448,13 @@ This is only used if `mm-inline-large-images' is set to
(unless (bolp)
(insert "\n"))
(insert "----------\n\n")
- (when handles
- (setq gnus-article-mime-handles
- (mm-merge-handles gnus-article-mime-handles handles)))
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let ((inhibit-read-only t))
- (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
+ (let ((beg (point-min-marker))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))))
;; Shut up byte-compiler.
(defvar font-lock-mode-hook)
@@ -481,7 +488,7 @@ If MODE is not set, try to find mode automatically."
;; support modes, but now that we use font-lock-ensure, support modes
;; aren't a problem any more. So we could probably get rid of this
;; setting now, but it seems harmless and potentially still useful.
- (set (make-local-variable 'font-lock-mode-hook) nil)
+ (setq-local font-lock-mode-hook nil)
(setq buffer-file-name (mm-handle-filename handle))
(with-demoted-errors
(if mode
@@ -502,7 +509,8 @@ If MODE is not set, try to find mode automatically."
(delay-mode-hooks (set-auto-mode))
(setq mode major-mode)))
;; Do not fontify if the guess mode is fundamental.
- (unless (eq major-mode 'fundamental-mode)
+ (when (and (not (eq major-mode 'fundamental-mode))
+ mm-inline-font-lock)
(font-lock-ensure))))
(setq text (buffer-string))
(when (eq mode 'diff-mode)
@@ -540,7 +548,7 @@ If MODE is not set, try to find mode automatically."
(mm-display-inline-fontify handle 'shell-script-mode))
(defun mm-display-javascript-inline (handle)
- "Show JavsScript code from HANDLE inline."
+ "Show JavaScript code from HANDLE inline."
(mm-display-inline-fontify handle 'javascript-mode))
;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
@@ -591,8 +599,16 @@ If MODE is not set, try to find mode automatically."
(with-temp-buffer
(insert-buffer-substring (mm-handle-buffer handle))
(goto-char (point-min))
- (let ((part (base64-decode-string (buffer-string))))
- (epg-verify-string (epg-make-context 'CMS) part))))
+ (let ((part (base64-decode-string (buffer-string)))
+ (context (epg-make-context 'CMS)))
+ (prog1
+ (epg-verify-string context part)
+ (let ((result (car (epg-context-result-for context 'verify))))
+ (mm-sec-status
+ 'gnus-info (epg-signature-status result)
+ 'gnus-details
+ (format "%s:%s" (epg-signature-validity result)
+ (epg-signature-key-id result))))))))
(with-temp-buffer
(insert "MIME-Version: 1.0\n")
(mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el
index 476e5b12ba0..15157e6fbc8 100644
--- a/lisp/gnus/mml-sec.el
+++ b/lisp/gnus/mml-sec.el
@@ -1,4 +1,4 @@
-;;; mml-sec.el --- A package with security functions for MML documents
+;;; mml-sec.el --- A package with security functions for MML documents -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -140,7 +140,7 @@ by default identifies the used encryption keys, giving away the
Bcc'ed identities. Clearly, this contradicts the original goal of
*blind* copies.
For an academic paper explaining the problem, see URL
-`http://crypto.stanford.edu/portia/papers/bb-bcc.pdf'.
+`https://crypto.stanford.edu/portia/papers/bb-bcc.pdf'.
Use this variable to specify e-mail addresses whose owners do not
mind if they are identifiable as recipients. This may be useful if
you use Bcc headers to encrypt e-mails to yourself."
@@ -236,7 +236,7 @@ You can also customize or set `mml-signencrypt-style-alist' instead."
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n") nil t))
(goto-char (match-end 0))
- (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
+ (apply #'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
(cons method tags))))
(t (error "The message is corrupted. No mail header separator"))))))
@@ -250,7 +250,7 @@ You can also customize or set `mml-signencrypt-style-alist' instead."
"Add MML tags to sign this MML part.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part
(or method mml-secure-method mml-default-sign-method)
'sign))
@@ -259,53 +259,56 @@ Use METHOD if given. Else use `mml-secure-method' or
"Add MML tags to encrypt this MML part.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part
(or method mml-secure-method mml-default-sign-method)))
(defun mml-secure-sign-pgp ()
"Add MML tags to PGP sign this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "pgp" 'sign))
(defun mml-secure-sign-pgpauto ()
"Add MML tags to PGP-auto sign this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "pgpauto" 'sign))
(defun mml-secure-sign-pgpmime ()
"Add MML tags to PGP/MIME sign this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "pgpmime" 'sign))
(defun mml-secure-sign-smime ()
"Add MML tags to S/MIME sign this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "smime" 'sign))
(defun mml-secure-encrypt-pgp ()
"Add MML tags to PGP encrypt this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "pgp"))
(defun mml-secure-encrypt-pgpmime ()
"Add MML tags to PGP/MIME encrypt this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "pgpmime"))
(defun mml-secure-encrypt-smime ()
"Add MML tags to S/MIME encrypt this MML part."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-part "smime"))
-(defun mml-secure-is-encrypted-p ()
- "Check whether secure encrypt tag is present."
+(defun mml-secure-is-encrypted-p (&optional tag-present)
+ "Whether the current buffer contains a mail message that should be encrypted.
+If TAG-PRESENT, say whether the <#secure tag is present anywhere
+in the buffer."
(save-excursion
(goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"
- "<#secure[^>]+encrypt")
- nil t)))
+ (message-goto-body)
+ (if tag-present
+ (re-search-forward "<#secure[^>]+encrypt" nil t)
+ (skip-chars-forward "[ \t\n")
+ (looking-at "<#secure[^>]+encrypt"))))
(defun mml-secure-bcc-is-safe ()
"Check whether usage of Bcc is safe (or absent).
@@ -346,8 +349,8 @@ either an error is raised or not."
(concat "^" (regexp-quote mail-header-separator) "\n") nil t)
(goto-char (setq insert-loc (match-end 0)))
(unless (looking-at "<#secure")
- (apply 'mml-insert-tag
- 'secure 'method method 'mode mode tags)))
+ (apply #'mml-insert-tag
+ 'secure 'method method 'mode mode tags)))
(t (error
"The message is corrupted. No mail header separator"))))
(when (eql insert-loc (point))
@@ -355,7 +358,7 @@ either an error is raised or not."
(defun mml-unsecure-message ()
"Remove security related MML tags from message."
- (interactive)
+ (interactive nil mml-mode)
(save-excursion
(goto-char (point-max))
(when (re-search-backward "^<#secure.*>\n" nil t)
@@ -366,7 +369,7 @@ either an error is raised or not."
"Add MML tags to sign the entire message.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message
(or method mml-secure-method mml-default-sign-method)
'sign))
@@ -375,7 +378,7 @@ Use METHOD if given. Else use `mml-secure-method' or
"Add MML tag to sign and encrypt the entire message.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message
(or method mml-secure-method mml-default-sign-method)
'signencrypt))
@@ -384,53 +387,53 @@ Use METHOD if given. Else use `mml-secure-method' or
"Add MML tag to encrypt the entire message.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message
(or method mml-secure-method mml-default-sign-method)
'encrypt))
(defun mml-secure-message-sign-smime ()
"Add MML tag to encrypt/sign the entire message."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message "smime" 'sign))
(defun mml-secure-message-sign-pgp ()
"Add MML tag to encrypt/sign the entire message."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message "pgp" 'sign))
(defun mml-secure-message-sign-pgpmime ()
"Add MML tag to encrypt/sign the entire message."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message "pgpmime" 'sign))
(defun mml-secure-message-sign-pgpauto ()
"Add MML tag to encrypt/sign the entire message."
- (interactive)
+ (interactive nil mml-mode)
(mml-secure-message "pgpauto" 'sign))
(defun mml-secure-message-encrypt-smime (&optional dontsign)
"Add MML tag to encrypt and sign the entire message.
If called with a prefix argument, only encrypt (do NOT sign)."
- (interactive "P")
+ (interactive "P" mml-mode)
(mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
(defun mml-secure-message-encrypt-pgp (&optional dontsign)
"Add MML tag to encrypt and sign the entire message.
If called with a prefix argument, only encrypt (do NOT sign)."
- (interactive "P")
+ (interactive "P" mml-mode)
(mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
(defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
"Add MML tag to encrypt and sign the entire message.
If called with a prefix argument, only encrypt (do NOT sign)."
- (interactive "P")
+ (interactive "P" mml-mode)
(mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
(defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
"Add MML tag to encrypt and sign the entire message.
If called with a prefix argument, only encrypt (do NOT sign)."
- (interactive "P")
+ (interactive "P" mml-mode)
(mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el
@@ -558,7 +561,7 @@ Return keys."
(cl-assert keys)
(let* ((usage-prefs (mml-secure-cust-usage-lookup context usage))
(curr-fprs (cdr (assoc name (cdr usage-prefs))))
- (key-fprs (mapcar 'mml-secure-fingerprint keys))
+ (key-fprs (mapcar #'mml-secure-fingerprint keys))
(new-fprs (cl-union curr-fprs key-fprs :test 'equal)))
(if curr-fprs
(setcdr (assoc name (cdr usage-prefs)) new-fprs)
@@ -622,7 +625,7 @@ Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead."
mml-smime-passphrase-cache-expiry)
mml-secure-passphrase-cache-expiry))))
-(defun mml-secure-passphrase-callback (context key-id standard)
+(defun mml-secure-passphrase-callback (context key-id _standard)
"Ask for passphrase in CONTEXT for KEY-ID for STANDARD.
The passphrase is read and cached."
;; Based on mml2015-epg-passphrase-callback.
@@ -665,8 +668,9 @@ The passphrase is read and cached."
(epg-user-id-string uid))))
(equal (downcase (car (mail-header-parse-address
(epg-user-id-string uid))))
- (downcase (car (mail-header-parse-address
- recipient))))
+ (downcase (or (car (mail-header-parse-address
+ recipient))
+ recipient)))
(not (memq (epg-user-id-validity uid)
'(revoked expired))))
(throw 'break t))))))
@@ -794,7 +798,7 @@ When `mml-secure-fail-when-key-problem' is t, fail with an error in case of
outdated or multiple keys."
(let* ((nname (mml-secure-normalize-cust-name name))
(fprs (mml-secure-cust-fpr-lookup context usage nname))
- (usable-fprs (mapcar 'mml-secure-fingerprint keys)))
+ (usable-fprs (mapcar #'mml-secure-fingerprint keys)))
(if fprs
(if (gnus-subsetp fprs usable-fprs)
(mml-secure-filter-keys keys fprs)
@@ -905,7 +909,7 @@ If no one is selected, symmetric encryption will be performed. "
(error "No recipient specified")))
recipients))
-(defun mml-secure-epg-encrypt (protocol cont &optional sign)
+(defun mml-secure-epg-encrypt (protocol _cont &optional sign)
;; Based on code appearing inside mml2015-epg-encrypt.
(let* ((context (epg-make-context protocol))
(config (epg-find-configuration 'OpenPGP))
@@ -937,6 +941,48 @@ If no one is selected, symmetric encryption will be performed. "
(signal (car error) (cdr error))))
cipher))
+(defun mml-secure-sender-sign-query (protocol sender)
+ "Query whether to use SENDER to sign when using PROTOCOL.
+PROTOCOL will be `OpenPGP' or `CMS' (smime).
+This can also save the resulting value of
+`mml-secure-smime-sign-with-sender' or
+`mml-secure-openpgp-sign-with-sender' via Customize.
+Returns non-nil if the user has chosen to use SENDER."
+ (let ((buffer (get-buffer-create "*MML sender signing options*"))
+ (options '((?a "always" "Sign using this sender now and sign with message sender in future.")
+ (?s "session only" "Sign using this sender now, and sign with message sender for this session only.")
+ (?n "no" "Do not sign this message (and error out)")))
+ answer done val)
+ (save-window-excursion
+ (pop-to-buffer buffer)
+ (erase-buffer)
+ (insert (format "No %s signing key was found for this message.\nThe sender of this message is \"%s\".\nWould you like to attempt looking up a signing key based on it?"
+ (if (eq protocol 'OpenPGP)
+ "openpgp" "smime")
+ sender))
+ (while (not done)
+ (setq answer (read-multiple-choice "Sign this message using the sender?" options))
+ (cl-case (car answer)
+ (?a
+ (if (eq protocol 'OpenPGP)
+ (progn
+ (setq mml-secure-openpgp-sign-with-sender t)
+ (customize-save-variable
+ 'mml-secure-openpgp-sign-with-sender t))
+ (setq mml-secure-smime-sign-with-sender t)
+ (customize-save-variable 'mml-secure-smime-sign-with-sender t))
+ (setq done t
+ val t))
+ (?s
+ (if (eq protocol 'OpenPGP)
+ (setq mml-secure-openpgp-sign-with-sender t)
+ (setq mml-secure-smime-sign-with-sender t))
+ (setq done t
+ val t))
+ (?n
+ (setq done t)))))
+ val))
+
(defun mml-secure-epg-sign (protocol mode)
;; Based on code appearing inside mml2015-epg-sign.
(let* ((context (epg-make-context protocol))
@@ -944,6 +990,23 @@ If no one is selected, symmetric encryption will be performed. "
(signer-names (mml-secure-signer-names protocol sender))
(signers (mml-secure-signers context signer-names))
signature micalg)
+ (unless signers
+ (if (and (not noninteractive)
+ (mml-secure-sender-sign-query protocol sender))
+ (setq signer-names (mml-secure-signer-names protocol sender)
+ signers (mml-secure-signers context signer-names)))
+ (unless signers
+ (let ((maybe-msg
+ (if (or mml-secure-smime-sign-with-sender
+ mml-secure-openpgp-sign-with-sender)
+ "."
+ "; try setting `mml-secure-smime-sign-with-sender' or 'mml-secure-openpgp-sign-with-sender'.")))
+ ;; If `mml-secure-smime-sign-with-sender' or
+ ;; `mml-secure-openpgp-sign-with-sender' are already non-nil
+ ;; then there's no point advising the user to examine them.
+ ;; If there are any other variables worth examining, please
+ ;; improve this error message by having it mention them.
+ (error "Couldn't find any signer names%s" maybe-msg))))
(when (eq 'OpenPGP protocol)
(setf (epg-context-armor context) t)
(setf (epg-context-textmode context) t)
diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el
index 96bdeca69bf..5c133e680af 100644
--- a/lisp/gnus/mml-smime.el
+++ b/lisp/gnus/mml-smime.el
@@ -1,4 +1,4 @@
-;;; mml-smime.el --- S/MIME support for MML
+;;; mml-smime.el --- S/MIME support for MML -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -129,7 +129,7 @@ Whether the passphrase is cached at all is controlled by
(if func
(funcall func handle ctl))))
-(defun mml-smime-openssl-sign (cont)
+(defun mml-smime-openssl-sign (_cont)
(when (null smime-keys)
(customize-variable 'smime-keys)
(error "No S/MIME keys configured, use customize to add your key"))
@@ -154,14 +154,9 @@ Whether the passphrase is cached at all is controlled by
(write-region (point-min) (point-max) file))
(push file certfiles)
(push file tmpfiles)))
- (if (smime-encrypt-buffer certfiles)
- (progn
- (while (setq tmp (pop tmpfiles))
- (delete-file tmp))
- t)
- (while (setq tmp (pop tmpfiles))
- (delete-file tmp))
- nil))
+ (smime-encrypt-buffer certfiles)
+ (while (setq tmp (pop tmpfiles))
+ (delete-file tmp)))
(goto-char (point-max)))
(defvar gnus-extract-address-components)
@@ -184,7 +179,7 @@ Whether the passphrase is cached at all is controlled by
(and from (smime-get-key-by-email from)))
(smime-get-key-by-email
(gnus-completing-read "Sign this part with what signature"
- (mapcar 'car smime-keys) nil nil nil
+ (mapcar #'car smime-keys) nil nil nil
(and (listp (car-safe smime-keys))
(caar smime-keys))))))))
@@ -292,7 +287,7 @@ Whether the passphrase is cached at all is controlled by
(point-min) (point))
addresses)))
(delete-region (point-min) (point)))
- (setq addresses (mapcar 'downcase addresses))))
+ (setq addresses (mapcar #'downcase addresses))))
(if (not (member (downcase (or (mm-handle-multipart-from ctl) ""))
addresses))
(mm-sec-error 'gnus-info "Sender address forged")
@@ -304,7 +299,7 @@ Whether the passphrase is cached at all is controlled by
(concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
(if addresses
(concat "Addresses in certificate: "
- (mapconcat 'identity addresses ", "))
+ (mapconcat #'identity addresses ", "))
"No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
"\n" "\n"
"OpenSSL output:\n"
@@ -314,7 +309,7 @@ Whether the passphrase is cached at all is controlled by
(buffer-string) "\n")))))
handle)
-(defun mml-smime-openssl-verify-test (handle ctl)
+(defun mml-smime-openssl-verify-test (_handle _ctl)
smime-openssl-program)
(defvar epg-user-id-alist)
@@ -334,7 +329,6 @@ Whether the passphrase is cached at all is controlled by
(autoload 'epg-verify-string "epg")
(autoload 'epg-sign-string "epg")
(autoload 'epg-encrypt-string "epg")
- (autoload 'epg-passphrase-callback-function "epg")
(autoload 'epg-context-set-passphrase-callback "epg")
(autoload 'epg-sub-key-fingerprint "epg")
(autoload 'epg-configuration "epg-config")
@@ -375,8 +369,8 @@ Content-Disposition: attachment; filename=smime.p7s
(goto-char (point-max)))))
(defun mml-smime-epg-encrypt (cont)
- (let* ((inhibit-redisplay t)
- (boundary (mml-compute-boundary cont))
+ (let* ((inhibit-redisplay t) ;FIXME: Why?
+ ;; (boundary (mml-compute-boundary cont))
(cipher (mml-secure-epg-encrypt 'CMS cont)))
(delete-region (point-min) (point-max))
(goto-char (point-min))
@@ -394,7 +388,7 @@ Content-Disposition: attachment; filename=smime.p7m
(defun mml-smime-epg-verify (handle ctl)
(catch 'error
(let ((inhibit-redisplay t)
- context plain signature-file part signature)
+ context part signature) ;; plain signature-file
(when (or (null (setq part (mm-find-raw-part-by-type
ctl (or (mm-handle-multipart-ctl-parameter
ctl 'protocol)
@@ -413,19 +407,20 @@ Content-Disposition: attachment; filename=smime.p7m
(setq part (replace-regexp-in-string "\n" "\r\n" part)
context (epg-make-context 'CMS))
(condition-case error
- (setq plain (epg-verify-string context (mm-get-part signature) part))
+ ;; (setq plain
+ (epg-verify-string context (mm-get-part signature) part) ;;)
(error
(mm-sec-error 'gnus-info "Failed")
- (if (eq (car error) 'quit)
- (mm-sec-status 'gnus-details "Quit.")
- (mm-sec-status 'gnus-details (format "%S" error)))
+ (mm-sec-status 'gnus-details (if (eq (car error) 'quit)
+ "Quit."
+ (format "%S" error)))
(throw 'error handle)))
(mm-sec-status
'gnus-info
(epg-verify-result-to-string (epg-context-result-for context 'verify)))
handle)))
-(defun mml-smime-epg-verify-test (handle ctl)
+(defun mml-smime-epg-verify-test (_handle _ctl)
t)
(provide 'mml-smime)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 892cbed3c8b..5f35e73cd7c 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -1,4 +1,4 @@
-;;; mml.el --- A package for parsing and validating MML documents
+;;; mml.el --- A package for parsing and validating MML documents -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -206,8 +206,8 @@ part. This is for the internal use, you should never modify the value.")
(defun mml-destroy-buffers ()
(let (kill-buffer-hook)
- (mapc 'kill-buffer mml-buffer-list)
- (setq mml-buffer-list nil)))
+ (mapc #'kill-buffer (prog1 mml-buffer-list
+ (setq mml-buffer-list nil)))))
(defun mml-parse ()
"Parse the current buffer as an MML document."
@@ -241,34 +241,37 @@ part. This is for the internal use, you should never modify the value.")
(method (cdr (assq 'method taginfo)))
tags)
(save-excursion
- (if (re-search-forward
- "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
- (setq secure-mode "multipart")
- (setq secure-mode "part")))
+ (setq secure-mode
+ (if (re-search-forward
+ "<#/?\\(multipart\\|part\\|external\\|mml\\)."
+ nil t)
+ "multipart"
+ "part")))
(save-excursion
(goto-char location)
(re-search-forward "<#secure[^\n]*>\n"))
(delete-region (match-beginning 0) (match-end 0))
- (cond ((string= mode "sign")
- (setq tags (list "sign" method)))
- ((string= mode "encrypt")
- (setq tags (list "encrypt" method)))
- ((string= mode "signencrypt")
- (setq tags (list "sign" method "encrypt" method)))
- (t
- (error "Unknown secure mode %s" mode)))
- (eval `(mml-insert-tag ,secure-mode
- ,@tags
- ,(if keyfile "keyfile")
- ,keyfile
- ,@(apply #'append
- (mapcar (lambda (certfile)
- (list "certfile" certfile))
- certfiles))
- ,(if recipients "recipients")
- ,recipients
- ,(if sender "sender")
- ,sender))
+ (setq tags (cond ((string= mode "sign")
+ (list "sign" method))
+ ((string= mode "encrypt")
+ (list "encrypt" method))
+ ((string= mode "signencrypt")
+ (list "sign" method "encrypt" method))
+ (t
+ (error "Unknown secure mode %s" mode))))
+ (apply #'mml-insert-tag
+ secure-mode
+ `(,@tags
+ ,(if keyfile "keyfile")
+ ,keyfile
+ ,@(apply #'append
+ (mapcar (lambda (certfile)
+ (list "certfile" certfile))
+ certfiles))
+ ,(if recipients "recipients")
+ ,recipients
+ ,(if sender "sender")
+ ,sender))
;; restart the parse
(goto-char location)))
((looking-at "<#multipart")
@@ -295,6 +298,17 @@ part. This is for the internal use, you should never modify the value.")
(t
(mm-find-mime-charset-region point (point)
mm-hack-charsets))))
+ ;; We have a part that already has a transfer encoding. Undo
+ ;; that so that we don't double-encode later.
+ (when (and raw
+ (cdr (assq 'data-encoding tag)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert contents)
+ (mm-decode-content-transfer-encoding
+ (intern (cdr (assq 'data-encoding tag)))
+ (cdr (assq 'type tag)))
+ (setq contents (buffer-string))))
(when (and (not raw) (memq nil charsets))
(if (or (memq 'unknown-encoding mml-confirmation-set)
(message-options-get 'unknown-encoding)
@@ -313,8 +327,8 @@ Message contains characters with unknown encoding. Really send? ")
(eq 'mml (car tag))
(< (length charsets) 2))
(if (or (not no-markup-p)
+ ;; Don't create blank parts.
(string-match "[^ \t\r\n]" contents))
- ;; Don't create blank parts.
(push (nconc tag (list (cons 'contents contents)))
struct))
(let ((nstruct (mml-parse-singlepart-with-multiple-charsets
@@ -487,11 +501,8 @@ type detected."
(= (length cont) 1)
content-type)
(setcdr (assq 'type (cdr (car cont))) content-type))
- (when (and (consp (car cont))
- (= (length cont) 1)
- (fboundp 'libxml-parse-html-region)
- (equal (cdr (assq 'type (car cont))) "text/html"))
- (setq cont (mml-expand-html-into-multipart-related (car cont))))
+ (when (fboundp 'libxml-parse-html-region)
+ (setq cont (mapcar #'mml-expand-all-html-into-multipart-related cont)))
(prog1
(with-temp-buffer
(set-buffer-multibyte nil)
@@ -510,6 +521,18 @@ type detected."
(buffer-string))
(setq message-options options)))))
+(defun mml-expand-all-html-into-multipart-related (cont)
+ (cond ((and (eq (car cont) 'part)
+ (equal (cdr (assq 'type cont)) "text/html"))
+ (mml-expand-html-into-multipart-related cont))
+ ((eq (car cont) 'multipart)
+ (let ((cur (cdr cont)))
+ (while (consp cur)
+ (setcar cur (mml-expand-all-html-into-multipart-related (car cur)))
+ (setf cur (cdr cur))))
+ cont)
+ (t cont)))
+
(defun mml-expand-html-into-multipart-related (cont)
(let ((new-parts nil)
(cid 1))
@@ -527,7 +550,7 @@ type detected."
(end (point))
(parsed (url-generic-parse-url (cdr (assq 'src (cadr img))))))
(when (and (null (url-type parsed))
- (url-filename parsed)
+ (not (zerop (length (url-filename parsed))))
(file-exists-p (url-filename parsed)))
(goto-char start)
(when (search-forward (url-filename parsed) end t)
@@ -538,8 +561,7 @@ type detected."
new-parts))
(setq cid (1+ cid)))))))
;; We have local images that we want to include.
- (if (not new-parts)
- (list cont)
+ (when new-parts
(setcdr (assq 'contents cont) (buffer-string))
(setq cont
(nconc (list 'multipart (cons 'type "related"))
@@ -552,8 +574,8 @@ type detected."
(nth 1 new-part)
(nth 2 new-part))
(id . ,(concat "<" (nth 0 new-part)
- ">")))))))
- cont))))
+ ">"))))))))
+ cont)))
(autoload 'image-property "image")
@@ -598,7 +620,7 @@ type detected."
(filename (cdr (assq 'filename cont)))
(type (or (cdr (assq 'type cont))
(if filename
- (or (mm-default-file-encoding filename)
+ (or (mm-default-file-type filename)
"application/octet-stream")
"text/plain")))
(charset (cdr (assq 'charset cont)))
@@ -756,7 +778,7 @@ type detected."
(insert "Content-Type: "
(or (cdr (assq 'type cont))
(if name
- (or (mm-default-file-encoding name)
+ (or (mm-default-file-type name)
"application/octet-stream")
"text/plain"))
"\n")
@@ -843,7 +865,7 @@ type detected."
(cl-incf mml-multipart-number)))
(throw 'not-unique nil))))
((eq (car cont) 'multipart)
- (mapc 'mml-compute-boundary-1 (cddr cont))))
+ (mapc #'mml-compute-boundary-1 (cddr cont))))
t)
(defun mml-make-boundary (number)
@@ -1058,7 +1080,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
(goto-char (point-max))
(insert "<#/mml>\n"))
((stringp (car handle))
- (mapc 'mml-insert-mime (cdr handle))
+ (mapc #'mml-insert-mime (cdr handle))
(insert "<#/multipart>\n"))
(textp
(let ((charset (mail-content-type-get
@@ -1247,8 +1269,8 @@ See Info node `(emacs-mime)Composing'.
:lighter " MML" :keymap mml-mode-map
(when mml-mode
(when (boundp 'dnd-protocol-alist)
- (set (make-local-variable 'dnd-protocol-alist)
- (append mml-dnd-protocol-alist dnd-protocol-alist)))))
+ (setq-local dnd-protocol-alist
+ (append mml-dnd-protocol-alist dnd-protocol-alist)))))
;;;
;;; Helper functions for reading MIME stuff from the minibuffer and
@@ -1285,7 +1307,7 @@ If not set, `default-directory' will be used."
(require 'mailcap)
(mailcap-parse-mimetypes)
(let* ((default (or default
- (mm-default-file-encoding name)
+ (mm-default-file-type name)
;; Perhaps here we should check what the file
;; looks like, and offer text/plain if it looks
;; like text/plain.
@@ -1317,7 +1339,7 @@ If not set, `default-directory' will be used."
(defun mml-quote-region (beg end)
"Quote the MML tags in the region."
- (interactive "r")
+ (interactive "r" mml-mode)
(save-excursion
(save-restriction
;; Temporarily narrow the region to defend from changes
@@ -1341,7 +1363,7 @@ If not set, `default-directory' will be used."
(value (pop plist)))
(when value
;; Quote VALUE if it contains suspicious characters.
- (when (string-match "[\"'\\~/*;() \t\n[:multibyte:]]" value)
+ (when (string-match "[][\"'\\~/*;()<>= \t\n[:multibyte:]]" value)
(setq value (with-output-to-string
(let (print-escape-nonascii)
(prin1 value)))))
@@ -1407,7 +1429,7 @@ will be computed and used."
(interactive
(let* ((file (mml-minibuffer-read-file "Attach file: "))
(type (if current-prefix-arg
- (or (mm-default-file-encoding file)
+ (or (mm-default-file-type file)
"application/octet-stream")
(mml-minibuffer-read-type file)))
(description (if current-prefix-arg
@@ -1437,7 +1459,7 @@ will be computed and used."
(file-name-nondirectory file)))
(goto-char head))))
-(defun mml-dnd-attach-file (uri action)
+(defun mml-dnd-attach-file (uri _action)
"Attach a drag and drop file.
Ask for type, description or disposition according to
@@ -1568,6 +1590,16 @@ Should be adopted if code in `message-send-mail' is changed."
(declare-function message-generate-headers "message" (headers))
(declare-function message-sort-headers "message" ())
+(defvar gnus-newsgroup-name)
+(defvar gnus-displaying-mime)
+(defvar gnus-newsgroup-name)
+(defvar gnus-article-prepare-hook)
+(defvar gnus-newsgroup-charset)
+(defvar gnus-original-article-buffer)
+(defvar gnus-message-buffer)
+(defvar message-this-is-news)
+(defvar message-this-is-mail)
+
(defun mml-preview (&optional raw)
"Display current buffer with Gnus, in a new buffer.
If RAW, display a raw encoded MIME message.
@@ -1579,7 +1611,8 @@ or the `pop-to-buffer' function."
(interactive "P")
(setq mml-preview-buffer (generate-new-buffer
(concat (if raw "*Raw MIME preview of "
- "*MIME preview of ") (buffer-name))))
+ "*MIME preview of ")
+ (buffer-name))))
(require 'gnus-msg) ; for gnus-setup-posting-charset
(save-excursion
(let* ((buf (current-buffer))
@@ -1636,7 +1669,8 @@ or the `pop-to-buffer' function."
(use-local-map nil)
(add-hook 'kill-buffer-hook
(lambda ()
- (mm-destroy-parts gnus-article-mime-handles)) nil t)
+ (mm-destroy-parts gnus-article-mime-handles))
+ nil t)
(setq buffer-read-only t)
(local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
(local-set-key "=" (lambda () (interactive) (delete-other-windows)))
@@ -1685,7 +1719,7 @@ or the `pop-to-buffer' function."
cont)
(let ((alist mml-tweak-sexp-alist))
(while alist
- (if (eval (caar alist))
+ (if (eval (caar alist) t)
(funcall (cdar alist) cont))
(setq alist (cdr alist)))))
cont)
diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index 640491f9360..05f44a1cbd8 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -1,4 +1,4 @@
-;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
+;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -82,7 +82,7 @@ Whether the passphrase is cached at all is controlled by
(defvar mml1991-decrypt-function 'mailcrypt-decrypt)
(defvar mml1991-verify-function 'mailcrypt-verify)
-(defun mml1991-mailcrypt-sign (cont)
+(defun mml1991-mailcrypt-sign (_cont)
(let ((text (current-buffer))
headers signature
(result-buffer (get-buffer-create "*GPG Result*")))
@@ -118,7 +118,7 @@ Whether the passphrase is cached at all is controlled by
(declare-function mc-encrypt-generic "ext:mc-toplev"
(&optional recipients scheme start end from sign))
-(defun mml1991-mailcrypt-encrypt (cont &optional sign)
+(defun mml1991-mailcrypt-encrypt (_cont &optional sign)
(let ((text (current-buffer))
(mc-pgp-always-sign
(or mc-pgp-always-sign
@@ -171,8 +171,9 @@ Whether the passphrase is cached at all is controlled by
(defvar pgg-default-user-id)
(defvar pgg-errors-buffer)
(defvar pgg-output-buffer)
+(defvar pgg-text-mode)
-(defun mml1991-pgg-sign (cont)
+(defun mml1991-pgg-sign (_cont)
(let ((pgg-text-mode t)
(pgg-default-user-id (or (message-options-get 'mml-sender)
pgg-default-user-id))
@@ -209,7 +210,7 @@ Whether the passphrase is cached at all is controlled by
(buffer-string)))
t))
-(defun mml1991-pgg-encrypt (cont &optional sign)
+(defun mml1991-pgg-encrypt (_cont &optional sign)
(goto-char (point-min))
(when (re-search-forward "^$" nil t)
(let ((cte (save-restriction
@@ -242,7 +243,6 @@ Whether the passphrase is cached at all is controlled by
(defvar epg-user-id-alist)
(autoload 'epg-make-context "epg")
-(autoload 'epg-passphrase-callback-function "epg")
(autoload 'epa-select-keys "epa")
(autoload 'epg-list-keys "epg")
(autoload 'epg-context-set-armor "epg")
@@ -258,7 +258,7 @@ Whether the passphrase is cached at all is controlled by
(autoload 'epg-configuration "epg-config")
(autoload 'epg-expand-group "epg-config")
-(defun mml1991-epg-sign (cont)
+(defun mml1991-epg-sign (_cont)
(let ((inhibit-redisplay t)
headers cte)
;; Don't sign headers.
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el
index e7276b257de..1af7d10d055 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -1,4 +1,4 @@
-;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
+;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -185,7 +185,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(cadr err)
(format "%S" (cdr err))))
-(defun mml2015-mailcrypt-decrypt (handle ctl)
+(defun mml2015-mailcrypt-decrypt (handle _ctl)
(catch 'error
(let (child handles result)
(unless (setq child (mm-find-part-by-type
@@ -293,6 +293,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(substring alg (match-end 0))
alg))))
+(autoload 'gnus-get-buffer-create "gnus")
+
(defun mml2015-mailcrypt-verify (handle ctl)
(catch 'error
(let (part)
@@ -330,7 +332,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(replace-match "-----BEGIN PGP SIGNATURE-----" t t))
(if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
(replace-match "-----END PGP SIGNATURE-----" t t)))
- (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
+ (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*")))
(unless (condition-case err
(prog1
(funcall mml2015-verify-function)
@@ -359,7 +361,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
handle)))
(defun mml2015-mailcrypt-clear-verify ()
- (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
+ (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*")))
(if (condition-case err
(prog1
(funcall mml2015-verify-function)
@@ -477,6 +479,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(defvar pgg-default-user-id)
(defvar pgg-errors-buffer)
(defvar pgg-output-buffer)
+(defvar pgg-text-mode)
(autoload 'pgg-decrypt-region "pgg")
(autoload 'pgg-verify-region "pgg")
@@ -484,10 +487,10 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(autoload 'pgg-encrypt-region "pgg")
(autoload 'pgg-parse-armor "pgg-parse")
-(defun mml2015-pgg-decrypt (handle ctl)
+(defun mml2015-pgg-decrypt (handle _ctl)
(catch 'error
(let ((pgg-errors-buffer mml2015-result-buffer)
- child handles result decrypt-status)
+ child handles decrypt-status) ;; result
(unless (setq child (mm-find-part-by-type
(cdr handle)
"application/octet-stream" nil t))
@@ -710,7 +713,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(autoload 'epg-verify-string "epg")
(autoload 'epg-sign-string "epg")
(autoload 'epg-encrypt-string "epg")
-(autoload 'epg-passphrase-callback-function "epg")
(autoload 'epg-context-set-passphrase-callback "epg")
(autoload 'epg-key-sub-key-list "epg")
(autoload 'epg-sub-key-capability "epg")
@@ -725,6 +727,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(autoload 'epg-expand-group "epg-config")
(autoload 'epa-select-keys "epa")
+(autoload 'gnus-create-image "gnus-util")
+
(defun mml2015-epg-key-image (key-id)
"Return the image of a key, if any."
(with-temp-buffer
@@ -732,8 +736,9 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(let* ((coding-system-for-write 'binary)
(coding-system-for-read 'binary)
(data (shell-command-to-string
- (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1"
- (shell-quote-argument epg-gpg-program) key-id))))
+ (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >%s 2>&1"
+ (shell-quote-argument epg-gpg-program)
+ key-id null-device))))
(when (> (length data) 0)
(insert (substring data 16))
(condition-case nil
@@ -747,7 +752,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(let ((key-image (mml2015-epg-key-image key-id)))
(if (not key-image)
""
- (condition-case error
+ (condition-case nil
(let ((result " "))
(put-text-property
1 2 'display
@@ -766,10 +771,10 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(defun mml2015-epg-verify-result-to-string (verify-result)
(mapconcat #'mml2015-epg-signature-to-string verify-result "\n"))
-(defun mml2015-epg-decrypt (handle ctl)
+(defun mml2015-epg-decrypt (handle _ctl)
(catch 'error
(let ((inhibit-redisplay t)
- context plain child handles result decrypt-status)
+ context plain child handles) ;; decrypt-status result
(unless (setq child (mm-find-part-by-type
(cdr handle)
"application/octet-stream" nil t))
@@ -847,7 +852,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(defun mml2015-epg-verify (handle ctl)
(catch 'error
(let ((inhibit-redisplay t)
- context plain signature-file part signature)
+ context part signature) ;; plain signature-file
(when (or (null (setq part (mm-find-raw-part-by-type
ctl (or (mm-handle-multipart-ctl-parameter
ctl 'protocol)
@@ -862,12 +867,13 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
signature (mm-get-part signature)
context (epg-make-context))
(condition-case error
- (setq plain (epg-verify-string context signature part))
+ ;; (setq plain
+ (epg-verify-string context signature part) ;;)
(error
(mm-sec-error 'gnus-info "Failed")
- (if (eq (car error) 'quit)
- (mm-sec-status 'gnus-details "Quit.")
- (mm-sec-status 'gnus-details (mml2015-format-error error)))
+ (mm-sec-status 'gnus-details (if (eq (car error) 'quit)
+ "Quit."
+ (mml2015-format-error error)))
(throw 'error handle)))
(mm-sec-status 'gnus-info
(mml2015-epg-verify-result-to-string
@@ -949,7 +955,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
;;; General wrapper
(autoload 'gnus-buffer-live-p "gnus-util")
-(autoload 'gnus-get-buffer-create "gnus")
(defun mml2015-clean-buffer ()
(if (gnus-buffer-live-p mml2015-result-buffer)
@@ -975,7 +980,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
handle)))
;;;###autoload
-(defun mml2015-decrypt-test (handle ctl)
+(defun mml2015-decrypt-test (_handle _ctl)
mml2015-use)
;;;###autoload
@@ -987,7 +992,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
handle)))
;;;###autoload
-(defun mml2015-verify-test (handle ctl)
+(defun mml2015-verify-test (_handle _ctl)
mml2015-use)
;;;###autoload
diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el
index f2acea4fa64..76a7e21567a 100644
--- a/lisp/gnus/nnagent.el
+++ b/lisp/gnus/nnagent.el
@@ -1,4 +1,4 @@
-;;; nnagent.el --- offline backend for Gnus
+;;; nnagent.el --- offline backend for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -86,7 +86,7 @@
server dir)
t))))
-(deffoo nnagent-retrieve-groups (groups &optional server)
+(deffoo nnagent-retrieve-groups (_groups &optional _server)
(save-excursion
(cond
((file-exists-p (gnus-agent-lib-file "groups"))
@@ -106,13 +106,13 @@
(funcall (gnus-get-function gnus-command-method 'request-type)
(gnus-group-real-name group) article)))))
-(deffoo nnagent-request-newgroups (date server)
+(deffoo nnagent-request-newgroups (_date _server)
nil)
-(deffoo nnagent-request-update-info (group info &optional server)
+(deffoo nnagent-request-update-info (_group _info &optional _server)
nil)
-(deffoo nnagent-request-post (&optional server)
+(deffoo nnagent-request-post (&optional _server)
(gnus-agent-insert-meta-information 'news gnus-command-method)
(gnus-request-accept-article "nndraft:queue" nil t t))
@@ -138,13 +138,13 @@
group action server)))
nil)
-(deffoo nnagent-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnagent-retrieve-headers (articles &optional group _server fetch-old)
(let ((file (gnus-agent-article-name ".overview" group))
arts n first)
(save-excursion
(gnus-agent-load-alist group)
(setq arts (gnus-sorted-difference
- articles (mapcar 'car gnus-agent-article-alist)))
+ articles (mapcar #'car gnus-agent-article-alist)))
;; Assume that articles with smaller numbers than the first one
;; Agent knows are gone.
(setq first (caar gnus-agent-article-alist))
@@ -184,7 +184,7 @@
t)
'nov)))
-(deffoo nnagent-request-expire-articles (articles group &optional server force)
+(deffoo nnagent-request-expire-articles (articles _group &optional _server _force)
articles)
(deffoo nnagent-request-group (group &optional server dont-check info)
@@ -249,7 +249,7 @@
(nnoo-parent-function 'nnagent 'nnml-request-regenerate
(list (nnagent-server server))))
-(deffoo nnagent-retrieve-group-data-early (server infos)
+(deffoo nnagent-retrieve-group-data-early (_server _infos)
nil)
;; Use nnml functions for just about everything.
diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el
index adab42b2ae7..5f486f49703 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -1,4 +1,4 @@
-;;; nnbabyl.el --- rmail mbox access for Gnus
+;;; nnbabyl.el --- rmail mbox access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -70,7 +70,7 @@
(nnoo-define-basics nnbabyl)
-(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnbabyl-retrieve-headers (articles &optional group server _fetch-old)
(with-current-buffer nntp-server-buffer
(erase-buffer)
(let ((number (length articles))
@@ -185,7 +185,7 @@
(cons nnbabyl-current-group article)
(nnbabyl-article-group-number)))))))
-(deffoo nnbabyl-request-group (group &optional server dont-check info)
+(deffoo nnbabyl-request-group (group &optional server dont-check _info)
(let ((active (cadr (assoc group nnbabyl-group-alist))))
(save-excursion
(cond
@@ -224,10 +224,10 @@
(insert-buffer-substring in-buf)))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
-(deffoo nnbabyl-close-group (group &optional server)
+(deffoo nnbabyl-close-group (_group &optional _server)
t)
-(deffoo nnbabyl-request-create-group (group &optional server args)
+(deffoo nnbabyl-request-create-group (group &optional _server _args)
(nnmail-activate 'nnbabyl)
(unless (assoc group nnbabyl-group-alist)
(push (list group (cons 1 0))
@@ -235,18 +235,20 @@
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
t)
-(deffoo nnbabyl-request-list (&optional server)
+(deffoo nnbabyl-request-list (&optional _server)
(save-excursion
(nnmail-find-file nnbabyl-active-file)
(setq nnbabyl-group-alist (nnmail-get-active))
t))
-(deffoo nnbabyl-request-newgroups (date &optional server)
+(deffoo nnbabyl-request-newgroups (_date &optional server)
(nnbabyl-request-list server))
-(deffoo nnbabyl-request-list-newsgroups (&optional server)
+(deffoo nnbabyl-request-list-newsgroups (&optional _server)
(nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
+(defvar nnml-current-directory)
+
(deffoo nnbabyl-request-expire-articles
(articles newsgroup &optional server force)
(nnbabyl-possibly-change-newsgroup newsgroup server)
@@ -263,7 +265,8 @@
(nnmail-expired-article-p
newsgroup
(buffer-substring
- (point) (progn (end-of-line) (point))) force))
+ (point) (progn (end-of-line) (point)))
+ force))
(progn
(unless (eq nnmail-expiry-target 'delete)
(with-temp-buffer
@@ -292,8 +295,8 @@
(nconc rest articles))))
(deffoo nnbabyl-request-move-article
- (article group server accept-form &optional last move-is-internal)
- (let ((buf (get-buffer-create " *nnbabyl move*"))
+ (article group server accept-form &optional last _move-is-internal)
+ (let ((buf (gnus-get-buffer-create " *nnbabyl move*"))
result)
(and
(nnbabyl-request-article article group server)
@@ -304,7 +307,7 @@
"^X-Gnus-Newsgroup:"
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(delete-region (point-at-bol) (progn (forward-line 1) (point))))
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer (current-buffer))
result)
(save-excursion
@@ -320,7 +323,7 @@
(nnbabyl-possibly-change-newsgroup group server)
(nnmail-check-syntax)
(let ((buf (current-buffer))
- result beg)
+ result) ;; beg
(and
(nnmail-activate 'nnbabyl)
(save-excursion
@@ -328,7 +331,7 @@
(search-forward "\n\n" nil t)
(forward-line -1)
(save-excursion
- (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
+ (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) ;; beg
(delete-region (point) (progn (forward-line 1) (point)))))
(when nnmail-cache-accepted-message-ids
(nnmail-cache-insert (nnmail-fetch-field "message-id")
@@ -544,7 +547,7 @@
(setq buffer-file-name nnbabyl-mbox-file)
(insert "BABYL OPTIONS:\n\n\^_")
(nnmail-write-region
- (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))))
+ (point-min) (point-max) nnbabyl-mbox-file t 'nomesg nil 'excl))))
(defun nnbabyl-read-mbox ()
(nnmail-activate 'nnbabyl)
@@ -554,13 +557,12 @@
(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
- (let ((delim (concat "^" nnbabyl-mail-delimiter))
- (alist nnbabyl-group-alist)
- start end number)
- (set-buffer (setq nnbabyl-mbox-buffer
- (nnheader-find-file-noselect
- nnbabyl-mbox-file nil t)))
+ (let ((delim (concat "^" nnbabyl-mail-delimiter))
+ (alist nnbabyl-group-alist)
+ start end number)
+ (with-current-buffer (setq nnbabyl-mbox-buffer
+ (nnheader-find-file-noselect
+ nnbabyl-mbox-file nil t))
;; Save previous buffer mode.
(setq nnbabyl-previous-buffer-mode
(cons (cons (point-min) (point-max))
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 3c476b1079a..adf4427523f 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -1,4 +1,4 @@
-;;; nndiary.el --- A diary back end for Gnus
+;;; nndiary.el --- A diary back end for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -149,7 +149,6 @@ In order to make this clear, here are some examples:
- (360 . minute): for an appointment at 18:30 and 15 seconds, this would
pop up the appointment message at 12:30."
- :group 'nndiary
:type '(repeat (cons :format "%v\n"
(integer :format "%v")
(choice :format "%[%v(s)%] before...\n"
@@ -163,8 +162,7 @@ In order to make this clear, here are some examples:
(defcustom nndiary-week-starts-on-monday nil
"Whether a week starts on monday (otherwise, sunday)."
- :type 'boolean
- :group 'nndiary)
+ :type 'boolean)
(define-obsolete-variable-alias 'nndiary-request-create-group-hooks
@@ -172,7 +170,6 @@ In order to make this clear, here are some examples:
(defcustom nndiary-request-create-group-functions nil
"Hook run after `nndiary-request-create-group' is executed.
The hook functions will be called with the full group name as argument."
- :group 'nndiary
:type 'hook)
(define-obsolete-variable-alias 'nndiary-request-update-info-hooks
@@ -180,7 +177,6 @@ The hook functions will be called with the full group name as argument."
(defcustom nndiary-request-update-info-functions nil
"Hook run after `nndiary-request-update-info' is executed.
The hook functions will be called with the full group name as argument."
- :group 'nndiary
:type 'hook)
(define-obsolete-variable-alias 'nndiary-request-accept-article-hooks
@@ -189,12 +185,10 @@ The hook functions will be called with the full group name as argument."
"Hook run before accepting an article.
Executed near the beginning of `nndiary-request-accept-article'.
The hook functions will be called with the article in the current buffer."
- :group 'nndiary
:type 'hook)
(defcustom nndiary-check-directory-twice t
"If t, check directories twice to avoid NFS failures."
- :group 'nndiary
:type 'boolean)
@@ -475,7 +469,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 info)
+(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))
@@ -509,11 +503,11 @@ all. This may very well take some time.")
(nndiary-possibly-change-directory group server)
(nnmail-get-new-mail 'nndiary 'nndiary-save-nov nndiary-directory group)))
-(deffoo nndiary-close-group (group &optional server)
+(deffoo nndiary-close-group (_group &optional _server)
(setq nndiary-article-file-alist nil)
t)
-(deffoo nndiary-request-create-group (group &optional server args)
+(deffoo nndiary-request-create-group (group &optional server _args)
(nndiary-possibly-change-directory nil server)
(nnmail-activate 'nndiary)
(cond
@@ -532,8 +526,8 @@ all. This may very well take some time.")
(nndiary-possibly-change-directory group server)
(let ((articles (nnheader-directory-articles nndiary-current-directory)))
(when articles
- (setcar active (apply 'min articles))
- (setcdr active (apply 'max articles))))
+ (setcar active (apply #'min articles))
+ (setcdr active (apply #'max articles))))
(nnmail-save-active nndiary-group-alist nndiary-active-file)
(run-hook-with-args 'nndiary-request-create-group-functions
(gnus-group-prefixed-name group
@@ -541,7 +535,7 @@ all. This may very well take some time.")
t))
))
-(deffoo nndiary-request-list (&optional server)
+(deffoo nndiary-request-list (&optional _server)
(save-excursion
(let ((nnmail-file-coding-system nnmail-active-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
@@ -549,10 +543,10 @@ all. This may very well take some time.")
(setq nndiary-group-alist (nnmail-get-active))
t))
-(deffoo nndiary-request-newgroups (date &optional server)
+(deffoo nndiary-request-newgroups (_date &optional server)
(nndiary-request-list server))
-(deffoo nndiary-request-list-newsgroups (&optional server)
+(deffoo nndiary-request-list-newsgroups (&optional _server)
(save-excursion
(nnmail-find-file nndiary-newsgroups-file)))
@@ -564,7 +558,7 @@ all. This may very well take some time.")
(nnmail-activate 'nndiary)
;; Articles not listed in active-articles are already gone,
;; so don't try to expire them.
- (setq articles (gnus-intersection articles active-articles))
+ (setq articles (nreverse (seq-intersection articles active-articles #'eq)))
(while articles
(setq article (nndiary-article-to-file (setq number (pop articles))))
(if (and (nndiary-deletable-article-p group number)
@@ -589,15 +583,15 @@ all. This may very well take some time.")
(let ((active (nth 1 (assoc group nndiary-group-alist))))
(when active
(setcar active (or (and active-articles
- (apply 'min active-articles))
+ (apply #'min active-articles))
(1+ (cdr active)))))
(nnmail-save-active nndiary-group-alist nndiary-active-file))
(nndiary-save-nov)
(nconc rest articles)))
(deffoo nndiary-request-move-article
- (article group server accept-form &optional last move-is-internal)
- (let ((buf (get-buffer-create " *nndiary move*"))
+ (article group server accept-form &optional last _move-is-internal)
+ (let ((buf (gnus-get-buffer-create " *nndiary move*"))
result)
(nndiary-possibly-change-directory group server)
(nndiary-update-file-alist)
@@ -609,7 +603,7 @@ all. This may very well take some time.")
nndiary-article-file-alist)
(with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer (current-buffer))
result))
(progn
@@ -772,7 +766,7 @@ all. This may very well take some time.")
;;; Interface optional functions ============================================
-(deffoo nndiary-request-update-info (group info &optional server)
+(deffoo nndiary-request-update-info (group info &optional _server)
(nndiary-possibly-change-directory group)
(let ((timestamp (gnus-group-parameter-value (gnus-info-params info)
'timestamp t)))
@@ -831,7 +825,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)
- (with-current-buffer (get-buffer-create " *nndiary id*")
+ (with-current-buffer (gnus-get-buffer-create " *nndiary id*")
(let ((alist nndiary-group-alist)
number)
;; We want to look through all .overview files, but we want to
@@ -960,7 +954,7 @@ all. This may very well take some time.")
(setq nndiary-article-file-alist
(sort
(nnheader-article-to-file-alist nndiary-current-directory)
- 'car-less-than-car)))
+ #'car-less-than-car)))
(setq active
(if nndiary-article-file-alist
(cons (caar nndiary-article-file-alist)
@@ -992,20 +986,20 @@ all. This may very well take some time.")
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
- (let ((headers (nnheader-parse-naked-head)))
+ (let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers))))
(defun nndiary-open-nov (group)
(or (cdr (assoc group nndiary-nov-buffer-alist))
- (let ((buffer (get-buffer-create (format " *nndiary overview %s*"
- group))))
+ (let ((buffer (gnus-get-buffer-create
+ (format " *nndiary overview %s*" group))))
(with-current-buffer buffer
- (set (make-local-variable 'nndiary-nov-buffer-file-name)
- (expand-file-name
- nndiary-nov-file-name
- (nnmail-group-pathname group nndiary-directory)))
+ (setq-local nndiary-nov-buffer-file-name
+ (expand-file-name
+ nndiary-nov-file-name
+ (nnmail-group-pathname group nndiary-directory)))
(erase-buffer)
(when (file-exists-p nndiary-nov-buffer-file-name)
(nnheader-insert-file-contents nndiary-nov-buffer-file-name)))
@@ -1039,6 +1033,8 @@ all. This may very well take some time.")
;; Save the active file.
(nnmail-save-active nndiary-group-alist nndiary-active-file))
+(defvar nndiary-files) ; dynamically bound in nndiary-generate-nov-databases-1
+
(defun nndiary-generate-nov-databases-1 (dir &optional seen no-active)
"Regenerate the NOV database in DIR."
(interactive "DRegenerate NOV in: ")
@@ -1055,7 +1051,7 @@ all. This may very well take some time.")
(nndiary-generate-nov-databases-1 dir seen))))
;; Do this directory.
(let ((nndiary-files (sort (nnheader-article-to-file-alist dir)
- 'car-less-than-car)))
+ #'car-less-than-car)))
(if (not nndiary-files)
(let* ((group (nnheader-file-to-group
(directory-file-name dir) nndiary-directory))
@@ -1068,7 +1064,6 @@ all. This may very well take some time.")
(unless no-active
(nnmail-save-active nndiary-group-alist nndiary-active-file))))))
-(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
@@ -1086,7 +1081,7 @@ all. This may very well take some time.")
(defun nndiary-generate-nov-file (dir files)
(let* ((dir (file-name-as-directory dir))
(nov (concat dir nndiary-nov-file-name))
- (nov-buffer (get-buffer-create " *nov*"))
+ (nov-buffer (gnus-get-buffer-create " *nov*"))
chars file headers)
;; Init the nov buffer.
(with-current-buffer nov-buffer
@@ -1115,7 +1110,7 @@ all. This may very well take some time.")
(widen))
(setq files (cdr files)))
(with-current-buffer nov-buffer
- (nnmail-write-region 1 (point-max) nov nil 'nomesg)
+ (nnmail-write-region 1 (point-max) nov nil 'nomesg nil 'excl)
(kill-buffer (current-buffer))))))
(defun nndiary-nov-delete-article (group article)
@@ -1245,7 +1240,7 @@ all. This may very well take some time.")
(defun nndiary-unflatten (spec)
;; opposite of flatten: build ranges if possible
- (setq spec (sort spec '<))
+ (setq spec (sort spec #'<))
(let (min max res)
(while (setq min (pop spec))
(setq max min)
@@ -1300,7 +1295,7 @@ all. This may very well take some time.")
(apply #'encode-time 0 0 0 1 1 (nthcdr 5 date-elts))
(* (car reminder) 400861056))))
res))
- (sort res 'time-less-p)))
+ (sort res #'time-less-p)))
(defun nndiary-last-occurrence (sched)
;; Returns the last occurrence of schedule SCHED as an Emacs time struct, or
@@ -1318,8 +1313,8 @@ all. This may very well take some time.")
;; bored in finding a good algorithm for doing that ;-)
;; ### FIXME: remove identical entries.
(let ((dom-list (nth 2 sched))
- (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '>))
- (year-list (sort (nndiary-flatten (nth 4 sched) 1971) '>))
+ (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) #'>))
+ (year-list (sort (nndiary-flatten (nth 4 sched) 1971) #'>))
(dow-list (nth 5 sched)))
;; Special case: an asterisk in one of the days specifications means
;; that only the other should be taken into account. If both are
@@ -1370,7 +1365,7 @@ all. This may very well take some time.")
(setq day (+ 7 day))))
;; Finally, if we have some days, they are valid
(when days
- (sort days '>)
+ (sort days #'>)
(throw 'found
(encode-time 0 minute hour
(car days) month year time-zone)))
@@ -1396,12 +1391,12 @@ all. This may very well take some time.")
(this-day (decoded-time-day today))
(this-month (decoded-time-month today))
(this-year (decoded-time-year today))
- (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) '<))
- (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) '<))
+ (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) #'<))
+ (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) #'<))
(dom-list (nth 2 sched))
- (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '<))
+ (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) #'<))
(years (if (nth 4 sched)
- (sort (nndiary-flatten (nth 4 sched) 1971) '<)
+ (sort (nndiary-flatten (nth 4 sched) 1971) #'<)
t))
(dow-list (nth 5 sched))
(year (1- this-year))
@@ -1425,7 +1420,7 @@ all. This may very well take some time.")
(pop years)))
(if years
;; Because we might not be limited in years, we must guard against
- ;; infinite loops. Appart from cases like Feb 31, there are probably
+ ;; infinite loops. Apart from cases like Feb 31, there are probably
;; other ones, (no monday XXX 2nd etc). I don't know any algorithm to
;; decide this, so I assume that if we reach 10 years later, the
;; schedule is undecidable.
@@ -1474,7 +1469,7 @@ all. This may very well take some time.")
;; Aaaaaaall right. Now we have a valid list of DAYS for
;; this month and this year.
(when days
- (setq days (sort days '<))
+ (setq days (sort days #'<))
;; Remove past days for this year and this month.
(and (= year this-year)
(= month this-month)
diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el
index 46351d0004f..bfc22836583 100644
--- a/lisp/gnus/nndir.el
+++ b/lisp/gnus/nndir.el
@@ -1,4 +1,4 @@
-;;; nndir.el --- single directory newsgroup access for Gnus
+;;; nndir.el --- single directory newsgroup access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index 9d5e3900e8d..172433ef3b8 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -1,4 +1,4 @@
-;;; nndoc.el --- single file access for Gnus
+;;; nndoc.el --- single file access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -225,7 +225,7 @@ from the document.")
(nnoo-define-basics nndoc)
-(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
+(deffoo nndoc-retrieve-headers (articles &optional newsgroup server _fetch-old)
(when (nndoc-possibly-change-buffer newsgroup server)
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -256,11 +256,10 @@ from the document.")
(deffoo nndoc-request-article (article &optional newsgroup server buffer)
(nndoc-possibly-change-buffer newsgroup server)
- (save-excursion
- (let ((buffer (or buffer nntp-server-buffer))
- (entry (cdr (assq article nndoc-dissection-alist)))
- beg)
- (set-buffer buffer)
+ (let ((buffer (or buffer nntp-server-buffer))
+ (entry (cdr (assq article nndoc-dissection-alist)))
+ beg)
+ (with-current-buffer buffer
(erase-buffer)
(when entry
(cond
@@ -281,7 +280,7 @@ from the document.")
(funcall nndoc-article-transform-function article))
t))))))
-(deffoo nndoc-request-group (group &optional server dont-check info)
+(deffoo nndoc-request-group (group &optional server dont-check _info)
"Select news GROUP."
(let (number)
(cond
@@ -302,7 +301,7 @@ from the document.")
(nndoc-request-group group server))
t)
-(deffoo nndoc-request-type (group &optional article)
+(deffoo nndoc-request-type (_group &optional article)
(cond ((not article) 'unknown)
(nndoc-post-type nndoc-post-type)
(t 'unknown)))
@@ -318,19 +317,19 @@ from the document.")
(setq nndoc-dissection-alist nil)
t)
-(deffoo nndoc-request-list (&optional server)
+(deffoo nndoc-request-list (&optional _server)
t)
-(deffoo nndoc-request-newgroups (date &optional server)
+(deffoo nndoc-request-newgroups (_date &optional _server)
nil)
-(deffoo nndoc-request-list-newsgroups (&optional server)
+(deffoo nndoc-request-list-newsgroups (&optional _server)
nil)
;;; Internal functions.
-(defun nndoc-possibly-change-buffer (group source)
+(defun nndoc-possibly-change-buffer (group _source)
(let (buf)
(cond
;; The current buffer is this group's buffer.
@@ -347,13 +346,13 @@ from the document.")
(file-exists-p nndoc-address)
(not (file-directory-p nndoc-address))))
(push (cons group (setq nndoc-current-buffer
- (get-buffer-create
+ (gnus-get-buffer-create
(concat " *nndoc " group "*"))))
nndoc-group-alist)
(setq nndoc-dissection-alist nil)
(with-current-buffer nndoc-current-buffer
- (set-buffer-multibyte nil)
(erase-buffer)
+ (set-buffer-multibyte nil)
(condition-case error
(if (and (stringp nndoc-address)
(string-match nndoc-binary-file-names nndoc-address))
@@ -427,9 +426,9 @@ from the document.")
(setq result nil))))
(unless (or result results)
(error "Document is not of any recognized type"))
- (if result
- (car entry)
- (cadar (last (sort results 'car-less-than-car))))))
+ (car (if result
+ entry
+ (cdar (last (sort results #'car-less-than-car)))))))
;;;
;;; Built-in type predicates and functions
@@ -678,7 +677,7 @@ from the document.")
(search-forward "\ncommit " nil t)
(search-forward "\nAuthor: " nil t)))
-(defun nndoc-transform-git-article (article)
+(defun nndoc-transform-git-article (_article)
(goto-char (point-min))
(when (re-search-forward "^Author: " nil t)
(replace-match "From: " t t)))
@@ -702,7 +701,7 @@ from the document.")
(re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z\\.-]+/[0-9]+\\|arXiv:\\)" nil t))
t))
-(defun nndoc-transform-lanl-gov-announce (article)
+(defun nndoc-transform-lanl-gov-announce (_article)
(let ((case-fold-search nil))
(goto-char (point-max))
(when (re-search-backward "^\\\\\\\\ +( *\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
@@ -859,7 +858,7 @@ from the document.")
nil)
(goto-char point))))
-(deffoo nndoc-request-accept-article (group &optional server last)
+(deffoo nndoc-request-accept-article (_group &optional _server _last)
nil)
;;;
diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el
index ce88af19a07..394b6fcc4fc 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -1,4 +1,4 @@
-;;; nndraft.el --- draft article access for Gnus
+;;; nndraft.el --- draft article access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -79,7 +79,7 @@ are generated if and only if they are also in `message-draft-headers'."
server nndraft-directory)
t)))
-(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nndraft-retrieve-headers (articles &optional group server _fetch-old)
(nndraft-possibly-change-group group)
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -108,7 +108,7 @@ are generated if and only if they are also in `message-draft-headers'."
(nnheader-fold-continuation-lines)
'headers))))
-(deffoo nndraft-request-article (id &optional group server buffer)
+(deffoo nndraft-request-article (id &optional group _server buffer)
(nndraft-possibly-change-group group)
(when (numberp id)
;; We get the newest file of the auto-saved file and the
@@ -145,7 +145,7 @@ are generated if and only if they are also in `message-draft-headers'."
;;(message-remove-header "date")
t))
-(deffoo nndraft-request-update-info (group info &optional server)
+(deffoo nndraft-request-update-info (group info &optional _server)
(nndraft-possibly-change-group group)
(setf (gnus-info-read info)
(gnus-update-read-articles
@@ -204,13 +204,13 @@ are generated if and only if they are also in `message-draft-headers'."
(setq buffer-file-name (expand-file-name file)
buffer-auto-save-file-name (make-auto-save-file-name))
(clear-visited-file-modtime)
- (add-hook 'write-contents-functions 'nndraft-generate-headers nil t)
- (add-hook 'after-save-hook 'nndraft-update-unread-articles nil t)
+ (add-hook 'write-contents-functions #'nndraft-generate-headers nil t)
+ (add-hook 'after-save-hook #'nndraft-update-unread-articles nil t)
(message-add-action '(nndraft-update-unread-articles)
'exit 'postpone 'kill)
article))
-(deffoo nndraft-request-group (group &optional server dont-check info)
+(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))
@@ -229,16 +229,16 @@ are generated if and only if they are also in `message-draft-headers'."
(list group server dont-check)))
(deffoo nndraft-request-move-article (article group server accept-form
- &optional last move-is-internal)
+ &optional _last _move-is-internal)
(nndraft-possibly-change-group group)
- (let ((buf (get-buffer-create " *nndraft move*"))
+ (let ((buf (gnus-get-buffer-create " *nndraft move*"))
result)
(and
(nndraft-request-article article group server)
(with-current-buffer buf
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer (current-buffer))
result)
(null (nndraft-request-expire-articles (list article) group server 'force))
@@ -292,7 +292,7 @@ are generated if and only if they are also in `message-draft-headers'."
(nnoo-parent-function 'nndraft 'nnmh-request-replace-article
(list article group buffer))))
-(deffoo nndraft-request-create-group (group &optional server args)
+(deffoo nndraft-request-create-group (group &optional _server _args)
(nndraft-possibly-change-group group)
(if (file-exists-p nndraft-current-directory)
(if (file-directory-p nndraft-current-directory)
@@ -316,27 +316,25 @@ are generated if and only if they are also in `message-draft-headers'."
(nnheader-concat nndraft-directory group))))
(defun nndraft-article-filename (article &rest args)
- (apply 'concat
+ (apply #'concat
(file-name-as-directory nndraft-current-directory)
(int-to-string article)
args))
(defun nndraft-auto-save-file-name (file)
- (save-excursion
+ (with-current-buffer (gnus-get-buffer-create " *draft tmp*")
+ (setq buffer-file-name file)
(prog1
- (progn
- (set-buffer (get-buffer-create " *draft tmp*"))
- (setq buffer-file-name file)
- (make-auto-save-file-name))
+ (make-auto-save-file-name)
(kill-buffer (current-buffer)))))
(defun nndraft-articles ()
"Return the list of messages in the group."
(gnus-make-directory nndraft-current-directory)
(sort
- (mapcar 'string-to-number
+ (mapcar #'string-to-number
(directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t))
- '<))
+ #'<))
(nnoo-import nndraft
(nnmh
diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el
index 7dcebb13d96..d881d6ce055 100644
--- a/lisp/gnus/nneething.el
+++ b/lisp/gnus/nneething.el
@@ -1,4 +1,4 @@
-;;; nneething.el --- arbitrary file access for Gnus
+;;; nneething.el --- arbitrary file access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -77,7 +77,7 @@ included.")
(nnoo-define-basics nneething)
-(deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nneething-retrieve-headers (articles &optional group _server _fetch-old)
(nneething-possibly-change-directory group)
(with-current-buffer nntp-server-buffer
@@ -114,7 +114,7 @@ included.")
(nnheader-fold-continuation-lines)
'headers))))
-(deffoo nneething-request-article (id &optional group server buffer)
+(deffoo nneething-request-article (id &optional group _server buffer)
(nneething-possibly-change-directory group)
(let ((file (unless (stringp id)
(nneething-file-name id)))
@@ -143,7 +143,7 @@ included.")
(insert "\n"))
t))))
-(deffoo nneething-request-group (group &optional server dont-check info)
+(deffoo nneething-request-group (group &optional server dont-check _info)
(nneething-possibly-change-directory group server)
(unless dont-check
(nneething-create-mapping)
@@ -156,16 +156,16 @@ included.")
group)))
t)
-(deffoo nneething-request-list (&optional server dir)
+(deffoo nneething-request-list (&optional _server _dir)
(nnheader-report 'nneething "LIST is not implemented."))
-(deffoo nneething-request-newgroups (date &optional server)
+(deffoo nneething-request-newgroups (_date &optional _server)
(nnheader-report 'nneething "NEWSGROUPS is not implemented."))
-(deffoo nneething-request-type (group &optional article)
+(deffoo nneething-request-type (_group &optional _article)
'unknown)
-(deffoo nneething-close-group (group &optional server)
+(deffoo nneething-close-group (_group &optional _server)
(setq nneething-current-directory nil)
t)
@@ -381,7 +381,7 @@ included.")
(defun nneething-get-head (file)
"Either find the head in FILE or make a head for FILE."
- (with-current-buffer (get-buffer-create nneething-work-buffer)
+ (with-current-buffer (gnus-get-buffer-create nneething-work-buffer)
(setq case-fold-search nil)
(buffer-disable-undo)
(erase-buffer)
diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el
index c1ca5a13dfd..2de5b83a7b2 100644
--- a/lisp/gnus/nnfolder.el
+++ b/lisp/gnus/nnfolder.el
@@ -1,4 +1,4 @@
-;;; nnfolder.el --- mail folder access for Gnus
+;;; nnfolder.el --- mail folder access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -145,7 +145,7 @@ all. This may very well take some time.")
'nov
(setq articles (gnus-sorted-intersection
;; Is ARTICLES sorted?
- (sort articles '<)
+ (sort articles #'<)
(nnfolder-existing-articles)))
(while (setq article (pop articles))
(set-buffer nnfolder-current-buffer)
@@ -261,7 +261,7 @@ all. This may very well take some time.")
(point) (point-at-eol)))
-1))))))))
-(deffoo nnfolder-request-group (group &optional server dont-check info)
+(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))
@@ -314,7 +314,7 @@ all. This may very well take some time.")
;; over the buffer again unless we add new mail to it or modify it in some
;; way.
-(deffoo nnfolder-close-group (group &optional server force)
+(deffoo nnfolder-close-group (group &optional _server _force)
;; Make sure we _had_ the group open.
(when (or (assoc group nnfolder-buffer-alist)
(equal group nnfolder-current-group))
@@ -342,7 +342,7 @@ all. This may very well take some time.")
nnfolder-current-buffer nil)
t)
-(deffoo nnfolder-request-create-group (group &optional server args)
+(deffoo nnfolder-request-create-group (group &optional server _args)
(nnfolder-possibly-change-group nil server)
(nnmail-activate 'nnfolder)
(cond ((zerop (length group))
@@ -369,7 +369,7 @@ all. This may very well take some time.")
(setq nnfolder-group-alist (nnmail-get-active)))
t))
-(deffoo nnfolder-request-newgroups (date &optional server)
+(deffoo nnfolder-request-newgroups (_date &optional server)
(nnfolder-possibly-change-group nil server)
(nnfolder-request-list server))
@@ -383,9 +383,8 @@ all. This may very well take some time.")
;; current folder.
(defun nnfolder-existing-articles ()
- (save-excursion
- (when nnfolder-current-buffer
- (set-buffer nnfolder-current-buffer)
+ (when nnfolder-current-buffer
+ (with-current-buffer nnfolder-current-buffer
(goto-char (point-min))
(let ((marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
@@ -395,12 +394,13 @@ all. This may very well take some time.")
(let ((newnum (string-to-number (match-string 0))))
(if (nnmail-within-headers-p)
(push newnum numbers))))
- ;; The article numbers are increasing, so this result is sorted.
+ ;; The article numbers are increasing, so this result is sorted.
(nreverse numbers)))))
(autoload 'gnus-request-group "gnus-int")
(declare-function gnus-request-create-group "gnus-int"
(group &optional gnus-command-method args))
+(defvar nnfolder-current-directory)
(deffoo nnfolder-request-expire-articles (articles newsgroup
&optional server force)
@@ -463,9 +463,9 @@ all. This may very well take some time.")
(gnus-sorted-difference articles (nreverse deleted-articles)))))
(deffoo nnfolder-request-move-article (article group server accept-form
- &optional last move-is-internal)
+ &optional last _move-is-internal)
(save-excursion
- (let ((buf (get-buffer-create " *nnfolder move*"))
+ (let ((buf (gnus-get-buffer-create " *nnfolder move*"))
result)
(and
(nnfolder-request-article article group server)
@@ -478,7 +478,7 @@ all. This may very well take some time.")
(save-excursion (and (search-forward "\n\n" nil t) (point)))
t)
(gnus-delete-line))
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer buf)
result)
(save-excursion
@@ -499,7 +499,7 @@ all. This may very well take some time.")
(save-excursion
(nnfolder-possibly-change-group group server)
(nnmail-check-syntax)
- (let ((buf (current-buffer))
+ (let (;; (buf (current-buffer))
result art-group)
(goto-char (point-min))
(when (looking-at "X-From-Line: ")
@@ -706,7 +706,7 @@ deleted. Point is left where the deleted region was."
(if dont-check
(setq nnfolder-current-group group
nnfolder-current-buffer nil)
- (let (inf file)
+ (let (file) ;; inf
;; If we have to change groups, see if we don't already have
;; the folder in memory. If we do, verify the modtime and
;; destroy the folder if needed so we can rescan it.
@@ -718,7 +718,7 @@ deleted. Point is left where the deleted region was."
;; touched the file since last time.
(when (and nnfolder-current-buffer
(not (gnus-buffer-live-p nnfolder-current-buffer)))
- (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)
+ (setq nnfolder-buffer-alist (delq nil nnfolder-buffer-alist) ;; inf
nnfolder-current-buffer nil))
(setq nnfolder-current-group group)
@@ -735,7 +735,7 @@ deleted. Point is left where the deleted region was."
(or nnfolder-file-coding-system-for-write
nnfolder-file-coding-system-for-write)))
(nnmail-write-region (point-min) (point-min)
- file t 'nomesg)))
+ file t 'nomesg nil 'excl)))
(when (setq nnfolder-current-buffer (nnfolder-read-folder group))
(set-buffer nnfolder-current-buffer)
(push (list group nnfolder-current-buffer)
@@ -1083,7 +1083,7 @@ This command does not work if you use short group names."
(let ((coding-system-for-write
(or nnfolder-file-coding-system-for-write
nnfolder-file-coding-system)))
- (set (make-local-variable 'copyright-update) nil)
+ (setq-local copyright-update nil)
(save-buffer)))
(unless (or gnus-nov-is-evil nnfolder-nov-is-evil)
(nnfolder-save-nov))))
@@ -1096,10 +1096,10 @@ 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))))
+ (let ((buffer (gnus-get-buffer-create (format " *nnfolder overview %s*" group))))
(with-current-buffer buffer
- (set (make-local-variable 'nnfolder-nov-buffer-file-name)
- (nnfolder-group-nov-pathname group))
+ (setq-local nnfolder-nov-buffer-file-name
+ (nnfolder-group-nov-pathname group))
(erase-buffer)
(when (file-exists-p nnfolder-nov-buffer-file-name)
(nnheader-insert-file-contents nnfolder-nov-buffer-file-name)))
@@ -1160,7 +1160,7 @@ This command does not work if you use short group names."
(if (search-forward "\n\n" e t) (setq e (1- (point)))))
(with-temp-buffer
(insert-buffer-substring buf b e)
- (let ((headers (nnheader-parse-naked-head)))
+ (let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers)))))
diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el
index 15e4876642c..c10989aa1e9 100644
--- a/lisp/gnus/nngateway.el
+++ b/lisp/gnus/nngateway.el
@@ -1,4 +1,4 @@
-;;; nngateway.el --- posting news via mail gateways
+;;; nngateway.el --- posting news via mail gateways -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 1ff8ed40e42..708887cb9c7 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1,4 +1,4 @@
-;;; nnheader.el --- header access macros for Gnus and its backends
+;;; nnheader.el --- header access macros for Gnus and its backends -*- lexical-binding: t; -*-
;; Copyright (C) 1987-1990, 1993-1998, 2000-2021 Free Software
;; Foundation, Inc.
@@ -28,6 +28,10 @@
(eval-when-compile (require 'cl-lib))
+(defvar gnus-decode-encoded-word-function)
+(defvar gnus-decode-encoded-address-function)
+(defvar gnus-alter-header-function)
+
(defvar nnmail-extra-headers)
(defvar gnus-newsgroup-name)
(defvar jka-compr-compression-info-list)
@@ -39,6 +43,7 @@
(require 'mail-utils)
(require 'mm-util)
(require 'gnus-util)
+(autoload 'gnus-remove-odd-characters "gnus-sum")
(autoload 'gnus-range-add "gnus-range")
(autoload 'gnus-remove-from-range "gnus-range")
;; FIXME none of these are used explicitly in this file.
@@ -188,124 +193,166 @@ on your system, you could say something like:
(autoload 'ietf-drums-unfold-fws "ietf-drums")
-(defun nnheader-parse-naked-head (&optional number)
- ;; This function unfolds continuation lines in this buffer
- ;; destructively. When this side effect is unwanted, use
- ;; `nnheader-parse-head' instead of this function.
- (let ((case-fold-search t)
- (buffer-read-only nil)
+
+(defsubst nnheader-head-make-header (number)
+ "Return a full mail header with article NUMBER.
+Do this using data of type `head' in the current buffer."
+ (let ((p (point-min))
(cur (current-buffer))
- (p (point-min))
- in-reply-to lines ref)
- (nnheader-remove-cr-followed-by-lf)
- (ietf-drums-unfold-fws)
- (subst-char-in-region (point-min) (point-max) ?\t ? )
- (goto-char p)
- (insert "\n")
- (prog1
- ;; This implementation of this function, with nine
- ;; search-forwards instead of the one re-search-forward and a
- ;; case (which basically was the old function) is actually
- ;; about twice as fast, even though it looks messier. You
- ;; can't have everything, I guess. Speed and elegance don't
- ;; always go hand in hand.
- (vector
- ;; Number.
- (or number 0)
- ;; Subject.
- (progn
- (goto-char p)
- (if (search-forward "\nsubject:" nil t)
- (nnheader-header-value) "(none)"))
- ;; From.
- (progn
- (goto-char p)
- (if (search-forward "\nfrom:" nil t)
- (nnheader-header-value) "(nobody)"))
- ;; Date.
- (progn
- (goto-char p)
- (if (search-forward "\ndate:" nil t)
- (nnheader-header-value) ""))
- ;; Message-ID.
- (progn
- (goto-char p)
- (if (search-forward "\nmessage-id:" nil t)
- (buffer-substring
- (1- (or (search-forward "<" (point-at-eol) t)
- (point)))
- (or (search-forward ">" (point-at-eol) t) (point)))
- ;; If there was no message-id, we just fake one to make
- ;; subsequent routines simpler.
- (nnheader-generate-fake-message-id number)))
- ;; References.
- (progn
+ in-reply-to chars lines end ref)
+ ;; This implementation of this function, with nine
+ ;; search-forwards instead of the one re-search-forward and a
+ ;; case (which basically was the old function) is actually
+ ;; about twice as fast, even though it looks messier. You
+ ;; can't have everything, I guess. Speed and elegance don't
+ ;; always go hand in hand.
+ (make-full-mail-header
+ ;; Number.
+ number
+ ;; Subject.
+ (progn
+ (goto-char p)
+ (if (search-forward "\nsubject:" nil t)
+ (funcall gnus-decode-encoded-word-function
+ (nnheader-header-value))
+ "(none)"))
+ ;; From.
+ (progn
+ (goto-char p)
+ (if (search-forward "\nfrom:" nil t)
+ (funcall gnus-decode-encoded-address-function
+ (nnheader-header-value))
+ "(nobody)"))
+ ;; Date.
+ (progn
+ (goto-char p)
+ (if (search-forward "\ndate:" nil t)
+ (nnheader-header-value) ""))
+ ;; Message-ID.
+ (progn
+ (goto-char p)
+ (if (re-search-forward
+ "^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
+ ;; We do it this way to make sure the Message-ID
+ ;; is (somewhat) syntactically valid.
+ (buffer-substring (match-beginning 1)
+ (match-end 1))
+ ;; If there was no message-id, we just fake one to make
+ ;; subsequent routines simpler.
+ (nnheader-generate-fake-message-id number)))
+ ;; References.
+ (progn
+ (goto-char p)
+ (if (search-forward "\nreferences:" nil t)
+ (progn
+ (setq end (point))
+ (prog1
+ (nnheader-header-value)
+ (setq ref
+ (buffer-substring
+ (progn
+ (end-of-line)
+ (search-backward ">" end t)
+ (1+ (point)))
+ (progn
+ (search-backward "<" end t)
+ (point))))))
+ ;; Get the references from the in-reply-to header if there
+ ;; were no references and the in-reply-to header looks
+ ;; promising.
+ (if (and (search-forward "\nin-reply-to:" nil t)
+ (setq in-reply-to (nnheader-header-value))
+ (string-match "<[^>]+>" in-reply-to))
+ (let (ref2)
+ (setq ref (substring in-reply-to (match-beginning 0)
+ (match-end 0)))
+ (while (string-match "<[^>]+>" in-reply-to (match-end 0))
+ (setq ref2 (substring in-reply-to (match-beginning 0)
+ (match-end 0)))
+ (when (> (length ref2) (length ref))
+ (setq ref ref2)))
+ ref)
+ nil)))
+ ;; Chars.
+ (progn
+ (goto-char p)
+ (if (search-forward "\nchars: " nil t)
+ (if (numberp (setq chars (ignore-errors (read cur))))
+ chars -1)
+ -1))
+ ;; Lines.
+ (progn
+ (goto-char p)
+ (if (search-forward "\nlines: " nil t)
+ (if (numberp (setq lines (ignore-errors (read cur))))
+ lines -1)
+ -1))
+ ;; Xref.
+ (progn
+ (goto-char p)
+ (and (search-forward "\nxref:" nil t)
+ (nnheader-header-value)))
+ ;; Extra.
+ (when nnmail-extra-headers
+ (let ((extra nnmail-extra-headers)
+ out)
+ (while extra
(goto-char p)
- (if (search-forward "\nreferences:" nil t)
- (nnheader-header-value)
- ;; Get the references from the in-reply-to header if
- ;; there were no references and the in-reply-to header
- ;; looks promising.
- (if (and (search-forward "\nin-reply-to:" nil t)
- (setq in-reply-to (nnheader-header-value))
- (string-match "<[^\n>]+>" in-reply-to))
- (let (ref2)
- (setq ref (substring in-reply-to (match-beginning 0)
- (match-end 0)))
- (while (string-match "<[^\n>]+>"
- in-reply-to (match-end 0))
- (setq ref2 (substring in-reply-to (match-beginning 0)
- (match-end 0)))
- (when (> (length ref2) (length ref))
- (setq ref ref2)))
- ref)
- nil)))
- ;; Chars.
- 0
- ;; Lines.
- (progn
- (goto-char p)
- (if (search-forward "\nlines: " nil t)
- (if (numberp (setq lines (read cur)))
- lines 0)
- 0))
- ;; Xref.
- (progn
- (goto-char p)
- (and (search-forward "\nxref:" nil t)
- (nnheader-header-value)))
- ;; Extra.
- (when nnmail-extra-headers
- (let ((extra nnmail-extra-headers)
- out)
- (while extra
- (goto-char p)
- (when (search-forward
- (concat "\n" (symbol-name (car extra)) ":") nil t)
- (push (cons (car extra) (nnheader-header-value))
- out))
- (pop extra))
- out)))
- (goto-char p)
- (delete-char 1))))
-
-(defun nnheader-parse-head (&optional naked)
- (let ((cur (current-buffer)) num beg end)
- (when (if naked
- (setq num 0
- beg (point-min)
- end (point-max))
- ;; 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)
- (setq num (read cur)
- beg (point)
- end (if (search-forward "\n.\n" nil t)
- (goto-char (- (point) 2))
- (point)))))
- (with-temp-buffer
- (insert-buffer-substring cur beg end)
- (nnheader-parse-naked-head num)))))
+ (when (search-forward
+ (concat "\n" (symbol-name (car extra)) ":") nil t)
+ (push (cons (car extra) (nnheader-header-value))
+ out))
+ (pop extra))
+ out)))))
+
+(defun nnheader-parse-head (&optional naked temp)
+ "Parse data of type `header' in the current buffer and return a mail header.
+Modify the buffer contents in the process. The buffer is assumed
+to begin each header with an \"Article retrieved\" line with an
+article number; if NAKED is non-nil this line is assumed absent,
+and the buffer should contain a single header's worth of data.
+If TEMP is non-nil the data is first copied to a temporary buffer
+leaving the original buffer untouched."
+ (let ((cur (current-buffer))
+ (num 0)
+ (beg (point-min))
+ (end (point-max))
+ buf)
+ (when (or naked
+ ;; 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)
+ (setq num (read cur)
+ beg (point)
+ end (if (search-forward "\n.\n" nil t)
+ (goto-char (- (point) 2))
+ (point)))))
+ ;; When TEMP copy the data to a temporary buffer.
+ (if temp
+ (progn
+ (set-buffer (setq buf (generate-new-buffer " *nnheader-temp*")))
+ (insert-buffer-substring cur beg end))
+ ;; Otherwise just narrow to the data.
+ (narrow-to-region beg end))
+ (let ((case-fold-search t)
+ (buffer-read-only nil)
+ header)
+ (nnheader-remove-cr-followed-by-lf)
+ (ietf-drums-unfold-fws)
+ (subst-char-in-region (point-min) (point-max) ?\t ?\s t)
+ (subst-char-in-region (point-min) (point-max) ?\r ?\s t)
+ (goto-char (point-min))
+ (insert "\n")
+ (setq header (nnheader-head-make-header num))
+ (goto-char (point-min))
+ (delete-char 1)
+ (if temp
+ (kill-buffer buf)
+ (goto-char (point-max))
+ (widen))
+ (when gnus-alter-header-function
+ (funcall gnus-alter-header-function header))
+ header))))
(defmacro nnheader-nov-skip-field ()
'(search-forward "\t" eol 'move))
@@ -347,24 +394,43 @@ on your system, you could say something like:
'id)
(nnheader-generate-fake-message-id ,number))))
-(defun nnheader-parse-nov ()
+(defalias 'nnheader-nov-make-header 'nnheader-parse-nov)
+(autoload 'gnus-extract-message-id-from-in-reply-to "gnus-sum")
+
+(defun nnheader-parse-nov (&optional number)
(let ((eol (point-at-eol))
- (number (nnheader-nov-read-integer)))
- (vector
- number ; number
- (nnheader-nov-field) ; subject
- (nnheader-nov-field) ; from
- (nnheader-nov-field) ; date
- (nnheader-nov-read-message-id number) ; id
- (nnheader-nov-field) ; refs
- (nnheader-nov-read-integer) ; chars
- (nnheader-nov-read-integer) ; lines
- (if (eq (char-after) ?\n)
- nil
- (if (looking-at "Xref: ")
- (goto-char (match-end 0)))
- (nnheader-nov-field)) ; Xref
- (nnheader-nov-parse-extra)))) ; extra
+ references in-reply-to x header)
+ (setq header
+ (make-full-mail-header
+ (or number (nnheader-nov-read-integer)) ; number
+ (condition-case () ; subject
+ (gnus-remove-odd-characters
+ (funcall gnus-decode-encoded-word-function
+ (setq x (nnheader-nov-field))))
+ (error x))
+ (condition-case () ; from
+ (gnus-remove-odd-characters
+ (funcall gnus-decode-encoded-address-function
+ (setq x (nnheader-nov-field))))
+ (error x))
+ (nnheader-nov-field) ; date
+ (nnheader-nov-read-message-id number) ; id
+ (setq references (nnheader-nov-field)) ; refs
+ (nnheader-nov-read-integer) ; chars
+ (nnheader-nov-read-integer) ; lines
+ (unless (eobp)
+ (if (looking-at "Xref: ")
+ (goto-char (match-end 0)))
+ (nnheader-nov-field)) ; Xref
+ (nnheader-nov-parse-extra))) ; extra
+
+ (when (and (string= references "")
+ (setq in-reply-to (mail-header-extra header))
+ (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to))))
+ (setf (mail-header-references header)
+ (gnus-extract-message-id-from-in-reply-to in-reply-to)))
+ header))
+
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
@@ -399,21 +465,10 @@ on your system, you could say something like:
(delete-char 1))
(forward-line 1)))
-(defun nnheader-parse-overview-file (file)
- "Parse FILE and return a list of headers."
- (mm-with-unibyte-buffer
- (nnheader-insert-file-contents file)
- (goto-char (point-min))
- (let (headers)
- (while (not (eobp))
- (push (nnheader-parse-nov) headers)
- (forward-line 1))
- (nreverse headers))))
-
(defun nnheader-write-overview-file (file headers)
"Write HEADERS to FILE."
(with-temp-file file
- (mapcar 'nnheader-insert-nov headers)))
+ (mapcar #'nnheader-insert-nov headers)))
(defun nnheader-insert-header (header)
(insert
@@ -487,8 +542,8 @@ the line could be found."
(< num article)))
(forward-line 1)
(setq found (point))
- (or (eobp)
- (= (setq num (read cur)) article)))
+ (unless (eobp)
+ (setq num (read cur))))
(unless (eq num article)
(goto-char found)))
(beginning-of-line)
@@ -502,16 +557,18 @@ the line could be found."
"Coding system used in file backends of Gnus.")
(defvar nnheader-callback-function nil)
+(autoload 'gnus-get-buffer-create "gnus")
+
(defun nnheader-init-server-buffer ()
"Initialize the Gnus-backend communication buffer."
(unless (gnus-buffer-live-p nntp-server-buffer)
- (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
+ (setq nntp-server-buffer (gnus-get-buffer-create " *nntpd*")))
(with-current-buffer nntp-server-buffer
(erase-buffer)
(mm-enable-multibyte)
(kill-all-local-variables)
(setq case-fold-search t) ;Should ignore case.
- (set (make-local-variable 'nntp-process-response) nil)
+ (setq-local nntp-process-response nil)
t))
;;; Various functions the backends use.
@@ -630,7 +687,7 @@ the line could be found."
(defun nnheader-set-temp-buffer (name &optional noerase)
"Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
- (set-buffer (get-buffer-create name))
+ (set-buffer (gnus-get-buffer-create name))
(buffer-disable-undo)
(unless noerase
(erase-buffer))
@@ -666,15 +723,15 @@ an alarming frequency on NFS mounted file systems. If it is nil,
(defun nnheader-directory-files-safe (&rest args)
"Execute `directory-files' twice and returns the longer result."
- (let ((first (apply 'directory-files args))
- (second (apply 'directory-files args)))
+ (let ((first (apply #'directory-files args))
+ (second (apply #'directory-files args)))
(if (> (length first) (length second))
first
second)))
(defun nnheader-directory-articles (dir)
"Return a list of all article files in directory DIR."
- (mapcar 'nnheader-file-to-number
+ (mapcar #'nnheader-file-to-number
(if nnheader-directory-files-is-safe
(directory-files
dir nil nnheader-numerical-short-files t)
@@ -726,7 +783,7 @@ The first string in ARGS can be a format string."
(set (intern (format "%s-status-string" backend))
(if (< (length args) 2)
(car args)
- (apply 'format args)))
+ (apply #'format args)))
nil)
(defun nnheader-get-report-string (backend)
@@ -747,8 +804,8 @@ without formatting."
(with-current-buffer nntp-server-buffer
(erase-buffer)
(if (string-match "%" format)
- (insert (apply 'format format args))
- (apply 'insert format args))
+ (insert (apply #'format format args))
+ (apply #'insert format args))
t))
(defsubst nnheader-replace-chars-in-string (string from to)
@@ -784,12 +841,13 @@ without formatting."
(defun nnheader-message (level &rest args)
"Message if the Gnus backends are talkative."
- (if (or (not (numberp gnus-verbose-backends))
- (<= level gnus-verbose-backends))
- (if gnus-add-timestamp-to-message
- (apply 'gnus-message-with-timestamp args)
- (apply 'message args))
- (apply 'format args)))
+ (apply (cond
+ ((and (numberp gnus-verbose-backends)
+ (> level gnus-verbose-backends))
+ #'format)
+ (gnus-add-timestamp-to-message #'gnus-message-with-timestamp)
+ (t #'message))
+ args))
(defun nnheader-be-verbose (level)
"Return whether the backends should be verbose on LEVEL."
@@ -820,7 +878,7 @@ without formatting."
(defun nnheader-concat (dir &rest files)
"Concat DIR as directory to FILES."
- (apply 'concat (file-name-as-directory dir) files))
+ (apply #'concat (file-name-as-directory dir) files))
(defun nnheader-ms-strip-cr ()
"Strip ^M from the end of all lines."
@@ -858,7 +916,7 @@ first. Otherwise, find the newest one, though it may take a time."
(setq path (cdr path))))
(if (or first (not (cdr results)))
(car results)
- (car (sort results 'file-newer-than-file-p)))))
+ (car (sort results #'file-newer-than-file-p)))))
(defvar ange-ftp-path-format)
(defvar efs-path-regexp)
@@ -904,15 +962,15 @@ find-file-hook, etc.
"Open a file with some variables bound.
See `find-file-noselect' for the arguments."
(cl-letf* ((format-alist nil)
- (auto-mode-alist (mm-auto-mode-alist))
- ((default-value 'major-mode) 'fundamental-mode)
- (enable-local-variables nil)
- (after-insert-file-functions nil)
- (enable-local-eval nil)
- (coding-system-for-read nnheader-file-coding-system)
- (version-control 'never)
- (find-file-hook nil))
- (apply 'find-file-noselect args)))
+ (auto-mode-alist (mm-auto-mode-alist))
+ ((default-value 'major-mode) 'fundamental-mode)
+ (enable-local-variables nil)
+ (after-insert-file-functions nil)
+ (enable-local-eval nil)
+ (coding-system-for-read nnheader-file-coding-system)
+ (version-control 'never)
+ (find-file-hook nil))
+ (apply #'find-file-noselect args)))
(defun nnheader-directory-regular-files (dir)
"Return a list of all regular files in DIR."
@@ -926,7 +984,7 @@ See `find-file-noselect' for the arguments."
(defun nnheader-directory-files (&rest args)
"Same as `directory-files', but prune \".\" and \"..\"."
- (let ((files (apply 'directory-files args))
+ (let ((files (apply #'directory-files args))
out)
(while files
(unless (member (file-name-nondirectory (car files)) '("." ".."))
@@ -1008,8 +1066,10 @@ See `find-file-noselect' for the arguments."
(let ((now (current-time)))
(when (time-less-p 1 (time-subtract now nnheader-last-message-time))
(setq nnheader-last-message-time now)
- (apply 'nnheader-message args))))
+ (apply #'nnheader-message args))))
+(make-obsolete-variable 'nnheader-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'nnheader-load-hook)
(provide 'nnheader)
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 2411a5ed9ea..3e2a202a6cf 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1,4 +1,4 @@
-;;; nnimap.el --- IMAP interface for Gnus
+;;; nnimap.el --- IMAP interface for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -95,7 +95,7 @@ Uses the same syntax as `nnmail-split-methods'.")
"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")
+ "24.1")
(defvoo nnimap-authenticator nil
"How nnimap authenticate itself to the server.
@@ -136,6 +136,16 @@ will fetch all parts that have types that match that string. A
likely value would be \"text/\" to automatically fetch all
textual parts.")
+(defvoo nnimap-keepalive-intervals (cons (* 60 15)
+ (* 60 5))
+ "Configuration for the nnimap keepalive timer.
+The value is a cons of two integers (each representing a number
+of seconds): the first is how often to run the keepalive
+function, the second is the seconds of inactivity required to
+send the actual keepalive command.
+
+Set to nil to disable keepalive commands altogether.")
+
(defgroup nnimap nil
"IMAP for Gnus."
:group 'gnus)
@@ -143,16 +153,26 @@ textual parts.")
(defcustom nnimap-request-articles-find-limit nil
"Limit the number of articles to look for after moving an article."
:type '(choice (const nil) integer)
- :version "24.4"
- :group 'nnimap)
+ :version "24.4")
+
+(define-obsolete-variable-alias
+ 'nnimap-split-download-body-default 'nnimap-split-download-body
+ "28.1")
+
+(defcustom nnimap-split-download-body nil
+ "If non-nil, make message bodies available for consideration during splitting.
+This requires downloading the full message from the IMAP server
+during splitting, which may be slow."
+ :version "28.1"
+ :type 'boolean)
+
+(defvar nnimap--split-download-body nil
+ "Like `nnimap-split-download-body', but for internal use.")
(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)
@@ -365,10 +385,10 @@ textual parts.")
(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)
- :initial-resync 0))
+ (setq-local after-change-functions nil) ;FIXME: Why?
+ (setq-local nnimap-object
+ (make-nnimap :server (nnoo-current-server 'nnimap)
+ :initial-resync 0))
(push (list buffer (current-buffer)) nnimap-connection-alist)
(push (current-buffer) nnimap-process-buffers)
(current-buffer)))
@@ -395,20 +415,22 @@ textual parts.")
nil)))
(defun nnimap-keepalive ()
- (let ((now (current-time)))
+ (let ((now (current-time))
+ ;; Set this so we don't wait for a response.
+ (nnimap-streaming t))
(dolist (buffer nnimap-process-buffers)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(when (and nnimap-object
(nnimap-last-command-time nnimap-object)
(time-less-p
- ;; More than five minutes since the last command.
- (* 5 60)
+ (cdr nnimap-keepalive-intervals)
(time-subtract
now
(nnimap-last-command-time nnimap-object))))
- (ignore-errors ;E.g. "buffer foo has no process".
- (nnimap-send-command "NOOP"))))))))
+ (with-local-quit
+ (ignore-errors ;E.g. "buffer foo has no process".
+ (nnimap-send-command "NOOP")))))))))
(defun nnimap-open-connection (buffer)
;; Be backwards-compatible -- the earlier value of nnimap-stream was
@@ -430,6 +452,7 @@ textual parts.")
;; This is only needed for Windows XP or earlier
(defun nnimap-map-port (port)
+ (declare-function x-server-version "xfns.c" (&optional terminal))
(if (and (eq system-type 'windows-nt)
(<= (car (x-server-version)) 5)
(equal port "imaps"))
@@ -437,9 +460,12 @@ textual parts.")
port))
(defun nnimap-open-connection-1 (buffer)
- (unless nnimap-keepalive-timer
- (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
- #'nnimap-keepalive)))
+ (unless (or nnimap-keepalive-timer
+ (null nnimap-keepalive-intervals))
+ (setq nnimap-keepalive-timer (run-at-time
+ (car nnimap-keepalive-intervals)
+ (car nnimap-keepalive-intervals)
+ #'nnimap-keepalive)))
(with-current-buffer (nnimap-make-process-buffer buffer)
(let* ((coding-system-for-read 'binary)
(coding-system-for-write 'binary)
@@ -986,12 +1012,15 @@ textual parts.")
(when (and (car result) (not can-move))
(nnimap-delete-article article))
(cons internal-move-group
- (or (nnimap-find-uid-response "COPYUID" (caddr result))
+ (or (nnimap-find-uid-response
+ "COPYUID"
+ ;; Server gives different responses for MOVE and COPY.
+ (if can-move (caddr result) (cadr result)))
(nnimap-find-article-by-message-id
internal-move-group server message-id
nnimap-request-articles-find-limit)))))
;; Move the article to a different method.
- (when-let* ((result (eval accept-form)))
+ (when-let* ((result (eval accept-form t)))
(nnimap-change-group group server)
(nnimap-delete-article article)
result))))))
@@ -1048,7 +1077,9 @@ textual parts.")
"UID COPY %s %S")
(nnimap-article-ranges (gnus-compress-sequence articles))
(nnimap-group-to-imap (gnus-group-real-name nnmail-expiry-target)))
- (set (if can-move 'deleted-articles 'articles-to-delete) articles))))
+ (if can-move
+ (setq deleted-articles articles)
+ (setq articles-to-delete articles)))))
t)
(t
(dolist (article articles)
@@ -1152,7 +1183,7 @@ If LIMIT, first try to limit the search to the N last articles."
7 "Article marked for deletion, but not expunged.")
nil))))
-(deffoo nnimap-request-scan (&optional group server)
+(deffoo nnimap-request-scan (&optional _group server)
(when (and (nnimap-change-group nil server)
nnimap-inbox
nnimap-split-methods)
@@ -1600,13 +1631,15 @@ If LIMIT, first try to limit the search to the N last articles."
(setq start-article 1))
(let* ((unread
(gnus-compress-sequence
- (gnus-set-difference
- (gnus-set-difference
+ (seq-difference
+ (seq-difference
existing
(gnus-sorted-union
(cdr (assoc '%Seen flags))
- (cdr (assoc '%Deleted flags))))
- (cdr (assoc '%Flagged flags)))))
+ (cdr (assoc '%Deleted flags)))
+ #'eq)
+ (cdr (assoc '%Flagged flags))
+ #'eq)))
(read (gnus-range-difference
(cons start-article high) unread)))
(when (> start-article 1)
@@ -1670,8 +1703,7 @@ If LIMIT, first try to limit the search to the N last articles."
(when (and active
recent
(> (car (last recent)) (cdr active)))
- (push (list (cons (gnus-group-real-name group) 0))
- nnmail-split-history)))
+ (push (list (cons 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)
@@ -1684,7 +1716,7 @@ If LIMIT, first try to limit the search to the N last articles."
(gnus-add-to-range
(gnus-add-to-range
(gnus-range-add (gnus-info-read info)
- vanished)
+ vanished)
(cdr (assq '%Flagged flags)))
(cdr (assq '%Seen flags))))
(let ((marks (gnus-info-marks info)))
@@ -1770,11 +1802,6 @@ If LIMIT, first try to limit the search to the N last articles."
;; 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)
@@ -1801,8 +1828,9 @@ If LIMIT, first try to limit the search to the N last articles."
(setq uidvalidity
(and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
end t)
- ;; Store UIDVALIDITY as a string, as it's
- ;; too big for 32-bit Emacsen, usually.
+ ;; Store UIDVALIDITY as a string; before bignums,
+ ;; it was usually too big for 32-bit Emacsen,
+ ;; and we don't want to change the format now.
(match-string 1)))
(goto-char start)
(setq vanished
@@ -1849,15 +1877,15 @@ If LIMIT, first try to limit the search to the N last articles."
(setq nnimap-status-string "Read-only server")
nil)
-(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el
+(defvar gnus-refer-thread-use-search) ;; gnus-sum.el
(declare-function gnus-fetch-headers "gnus-sum"
(articles &optional limit force-new dependencies))
-(autoload 'nnir-search-thread "nnir")
+(autoload 'nnselect-search-thread "nnselect")
(deffoo nnimap-request-thread (header &optional group server)
- (if gnus-refer-thread-use-nnir
- (nnir-search-thread header)
+ (if gnus-refer-thread-use-search
+ (nnselect-search-thread header)
(when (nnimap-change-group group server)
(let* ((cmd (nnimap-make-thread-query header))
(result (with-current-buffer (nnimap-buffer)
@@ -1937,7 +1965,7 @@ Return the server's response to the SELECT or EXAMINE command."
(defun nnimap-log-buffer ()
(let ((name "*imap log*"))
(or (get-buffer name)
- (with-current-buffer (get-buffer-create name)
+ (with-current-buffer (gnus-get-buffer-create name)
(setq-local window-point-insertion-type t)
(current-buffer)))))
@@ -2102,7 +2130,8 @@ Return the server's response to the SELECT or EXAMINE command."
"BODY.PEEK"
"RFC822.PEEK"))
(cond
- (nnimap-split-download-body-default
+ ((or nnimap-split-download-body
+ nnimap--split-download-body)
"[]")
((nnimap-ver4-p)
"[HEADER]")
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index 6fa337d34f0..bcf01cfa9e7 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -1,4 +1,4 @@
-;;; nnmail.el --- mail support functions for the Gnus mail backends
+;;; nnmail.el --- mail support functions for the Gnus mail backends -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -115,7 +115,7 @@ If nil, the first match found will be used."
:type 'boolean)
(defcustom nnmail-split-fancy-with-parent-ignore-groups nil
- "Regexp that matches group names to be ignored when applying `nnmail-split-fancy-with-parent'.
+ "Regexp matching group names ignored by `nnmail-split-fancy-with-parent'.
This can also be a list of regexps."
:version "22.1"
:group 'nnmail-split
@@ -124,7 +124,8 @@ This can also be a list of regexps."
(repeat :value (".*") regexp)))
(defcustom nnmail-cache-ignore-groups nil
- "Regexp that matches group names to be ignored when inserting message ids into the cache (`nnmail-cache-insert').
+ "Regexp matching group ignored when inserting message ids into the cache.
+This is used by `nnmail-cache-insert'.
This can also be a list of regexps."
:version "22.1"
:group 'nnmail-split
@@ -239,11 +240,6 @@ If non-nil, also update the cache when copy or move articles."
:group 'nnmail
:type 'boolean)
-(make-obsolete-variable 'nnmail-spool-file 'mail-sources
- "Gnus 5.9 (Emacs 22.1)")
-;; revision 5.29 / p0-85 / Gnus 5.9
-;; Variable removed in No Gnus v0.7
-
(defcustom nnmail-resplit-incoming nil
"If non-nil, re-split incoming procmail sorted mail."
:group 'nnmail-procmail
@@ -597,7 +593,7 @@ These will be logged to the \"*nnmail split*\" buffer."
-(defun nnmail-request-post (&optional server)
+(defun nnmail-request-post (&optional _server)
(mail-send-and-exit nil))
(defvar nnmail-file-coding-system 'raw-text
@@ -663,7 +659,7 @@ nn*-request-list should have been called before calling this function."
(let ((buffer (current-buffer))
group-assoc group max min)
(while (not (eobp))
- (condition-case err
+ (condition-case nil
(progn
(narrow-to-region (point) (point-at-eol))
(setq group (read buffer)
@@ -711,7 +707,7 @@ If SOURCE is a directory spec, try to return the group name component."
(if (eq (car source) 'directory)
(let ((file (file-name-nondirectory file)))
(mail-source-bind (directory source)
- (if (string-match (concat (regexp-quote suffix) "$") file)
+ (if (string-match (concat (regexp-quote suffix) "\\'") file)
(substring file 0 (match-beginning 0))
nil)))
nil))
@@ -1047,7 +1043,7 @@ will be copied over from that buffer."
(list (list group ""))
nnmail-split-methods)))
;; Insert the incoming file.
- (with-current-buffer (get-buffer-create nnmail-article-buffer)
+ (with-current-buffer (gnus-get-buffer-create nnmail-article-buffer)
(erase-buffer)
(if (bufferp incoming)
(insert-buffer-substring incoming)
@@ -1280,7 +1276,7 @@ Return the number of characters in the body."
"Remove list identifiers from Subject headers."
(let ((regexp
(if (consp nnmail-list-identifiers)
- (mapconcat 'identity nnmail-list-identifiers " *\\|")
+ (mapconcat #'identity nnmail-list-identifiers " *\\|")
nnmail-list-identifiers)))
(when regexp
(goto-char (point-min))
@@ -1320,9 +1316,6 @@ Eudora has a broken References line, but an OK In-Reply-To."
(when (re-search-forward "^\\(In-Reply-To:[^\n]+\\)\n[ \t]+" nil t)
(replace-match "\\1" t))))
-(defalias 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references)
-(make-obsolete 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references "Emacs 23.1")
-
(custom-add-option 'nnmail-prepare-incoming-header-hook
'nnmail-ignore-broken-references)
@@ -1331,14 +1324,15 @@ Eudora has a broken References line, but an OK In-Reply-To."
(declare-function gnus-activate-group "gnus-start"
(group &optional scan dont-check method dont-sub-check))
-(defun nnmail-do-request-post (accept-func &optional server)
+(defun nnmail-do-request-post (accept-func &optional _server)
"Utility function to directly post a message to an nnmail-derived group.
Calls ACCEPT-FUNC (which should be `nnchoke-request-accept-article')
to actually put the message in the right group."
(let ((success t))
(dolist (mbx (message-unquote-tokens
(message-tokenize-header
- (message-fetch-field "Newsgroups") ", ")) success)
+ (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)
@@ -1395,7 +1389,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
;; Builtin : operation.
((eq (car split) ':)
(nnmail-log-split split)
- (nnmail-split-it (save-excursion (eval (cdr split)))))
+ (nnmail-split-it (save-excursion (eval (cdr split) t))))
;; Builtin ! operation.
((eq (car split) '!)
@@ -1432,11 +1426,11 @@ See the documentation for the variable `nnmail-split-fancy' for details."
;; we do not exclude foo.list just because
;; the header is: ``To: x-foo, foo''
(goto-char end)
- (if (and (re-search-backward (cadr split-rest)
- after-header-name t)
- (> (match-end 0) start-of-value))
- (setq split-rest nil)
- (setq split-rest (cddr split-rest))))
+ (setq split-rest
+ (unless (and (re-search-backward (cadr split-rest)
+ after-header-name t)
+ (> (match-end 0) start-of-value))
+ (cddr split-rest))))
(when split-rest
(goto-char end)
;; Someone might want to do a \N sub on this match, so
@@ -1527,7 +1521,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
expanded))))
(setq pos (1+ pos)))
(if did-expand
- (apply 'concat (nreverse expanded))
+ (apply #'concat (nreverse expanded))
newtext)))
;; Activate a backend only if it isn't already activated.
@@ -1574,7 +1568,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
() ; The buffer is open.
(with-current-buffer
(setq nnmail-cache-buffer
- (get-buffer-create " *nnmail message-id cache*"))
+ (gnus-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))
@@ -1622,7 +1616,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
(gnus-methods-equal-p gnus-command-method
(nnmail-cache-primary-mail-backend)))
(let ((regexp (if (consp nnmail-cache-ignore-groups)
- (mapconcat 'identity nnmail-cache-ignore-groups
+ (mapconcat #'identity nnmail-cache-ignore-groups
"\\|")
nnmail-cache-ignore-groups)))
(unless (and regexp (string-match regexp grp))
@@ -1749,7 +1743,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(nreverse (nnmail-article-group artnum-func))))))
;; Add the group-art list to the history list.
(if group-art
- (push group-art nnmail-split-history)
+ ;; We need to get the unique Gnus group name for this article
+ ;; -- there may be identically named groups from several
+ ;; backends.
+ (push (mapcar
+ (lambda (ga)
+ (cons (gnus-group-prefixed-name (car ga) gnus-command-method)
+ (cdr ga)))
+ group-art)
+ nnmail-split-history)
(delete-region (point-min) (point-max)))))
;;; Get new mail.
@@ -1757,7 +1759,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defvar nnmail-fetched-sources nil)
(defun nnmail-get-value (&rest args)
- (let ((sym (intern (apply 'format args))))
+ (let ((sym (intern (apply #'format args))))
(when (boundp sym)
(symbol-value sym))))
@@ -1802,10 +1804,10 @@ be called once per group or once for all groups."
(setq source (append source
(list
:predicate
- (gnus-byte-compile
- `(lambda (file)
+ (let ((str (concat group suffix)))
+ (lambda (file)
(string-equal
- ,(concat group suffix)
+ str
(file-name-nondirectory file)))))))))
(when nnmail-fetched-sources
(if (member source nnmail-fetched-sources)
@@ -1826,17 +1828,19 @@ be called once per group or once for all groups."
(condition-case cond
(mail-source-fetch
source
- (gnus-byte-compile
- `(lambda (file orig-file)
+ (let ((smsym (intern (format "%s-save-mail" method)))
+ (ansym (intern (format "%s-active-number" method)))
+ (src source))
+ (lambda (file orig-file)
(nnmail-split-incoming
- file ',(intern (format "%s-save-mail" method))
- ',spool-func
+ file smsym
+ spool-func
(or in-group
(if (equal file orig-file)
nil
(nnmail-get-split-group orig-file
- ',source)))
- ',(intern (format "%s-active-number" method))))))
+ src)))
+ ansym))))
((error quit)
(message "Mail source %s failed: %s" source cond)
0)))
@@ -1908,7 +1912,7 @@ If TIME is nil, then return the cutoff time for oldness instead."
(cdr group-art))
(gnus-group-mark-article-read target (cdr group-art))))))))
-(defun nnmail-fancy-expiry-target (group)
+(defun nnmail-fancy-expiry-target (_group)
"Return a target expiry group determined by `nnmail-fancy-expiry-targets'."
(let* (header
(case-fold-search nil)
@@ -1953,12 +1957,14 @@ If TIME is nil, then return the cutoff time for oldness instead."
(unless (re-search-forward "^Message-ID[ \t]*:" nil t)
(insert "Message-ID: " (nnmail-message-id) "\n")))))
-(defun nnmail-write-region (start end filename &optional append visit lockname)
+(defun nnmail-write-region (start end filename
+ &optional append visit lockname mustbenew)
"Do a `write-region', and then set the file modes."
(let ((coding-system-for-write nnmail-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
- (write-region start end filename append visit lockname)
- (set-file-modes filename nnmail-default-file-modes)))
+ (write-region start end filename append visit lockname mustbenew)
+ (set-file-modes filename nnmail-default-file-modes
+ (when (eq mustbenew 'excl) 'nofollow))))
;;;
;;; Status functions
@@ -2065,13 +2071,15 @@ Doesn't change point."
(when nnmail-split-tracing
(push split nnmail-split-trace))
(when nnmail-debug-splitting
- (with-current-buffer (get-buffer-create "*nnmail split*")
+ (with-current-buffer (gnus-get-buffer-create "*nnmail split*")
(goto-char (point-max))
(insert (format-time-string "%FT%T")
" "
(format "%S" split)
"\n"))))
+(make-obsolete-variable 'nnmail-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'nnmail-load-hook)
(provide 'nnmail)
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 5461c4c960e..4867455393a 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -1,4 +1,4 @@
-;;; nnmaildir.el --- maildir backend for Gnus
+;;; nnmaildir.el --- maildir backend for Gnus -*- lexical-binding:t -*-
;; This file is in the public domain.
@@ -21,7 +21,7 @@
;;; Commentary:
-;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>.
+;; Maildir format is documented at <URL:https://cr.yp.to/proto/maildir.html>.
;; nnmaildir also stores extra information in the .nnmaildir/ directory
;; within a maildir.
;;
@@ -48,16 +48,6 @@
;;; Code:
-;; eval this before editing
-[(progn
- (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0)
- (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0)
- (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0)
- (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0)
- (put 'nnmaildir--condcase 'lisp-indent-function 2)
- )
-]
-
(require 'nnheader)
(require 'gnus)
(require 'gnus-util)
@@ -111,7 +101,7 @@ SUFFIX should start with \":2,\"."
(new-flags
(concat (gnus-delete-duplicates
;; maildir flags must be sorted
- (sort (cons flag flags-as-list) '<)))))
+ (sort (cons flag flags-as-list) #'<)))))
(concat ":2," new-flags)))
(defun nnmaildir--remove-flag (flag suffix)
@@ -261,23 +251,23 @@ This variable is set by `nnmaildir-request-article'.")
(defun nnmaildir--param (pgname param)
(setq param (gnus-group-find-parameter pgname param 'allow-list))
(if (vectorp param) (setq param (aref param 0)))
- (eval param))
+ (eval param t))
(defmacro nnmaildir--with-nntp-buffer (&rest body)
- (declare (debug (body)))
+ (declare (indent 0) (debug t))
`(with-current-buffer nntp-server-buffer
,@body))
(defmacro nnmaildir--with-work-buffer (&rest body)
- (declare (debug (body)))
- `(with-current-buffer (get-buffer-create " *nnmaildir work*")
+ (declare (indent 0) (debug t))
+ `(with-current-buffer (gnus-get-buffer-create " *nnmaildir work*")
,@body))
(defmacro nnmaildir--with-nov-buffer (&rest body)
- (declare (debug (body)))
- `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
+ (declare (indent 0) (debug t))
+ `(with-current-buffer (gnus-get-buffer-create " *nnmaildir nov*")
,@body))
(defmacro nnmaildir--with-move-buffer (&rest body)
- (declare (debug (body)))
- `(with-current-buffer (get-buffer-create " *nnmaildir move*")
+ (declare (indent 0) (debug t))
+ `(with-current-buffer (gnus-get-buffer-create " *nnmaildir move*")
,@body))
(defsubst nnmaildir--subdir (dir subdir)
@@ -302,7 +292,7 @@ This variable is set by `nnmaildir-request-article'.")
(write-region "" nil file nil 'no-message))
(defun nnmaildir--delete-dir-files (dir ls)
(when (file-attributes dir)
- (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
+ (mapc #'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
(delete-directory dir)))
(defun nnmaildir--group-maxnum (server group)
@@ -358,7 +348,7 @@ This variable is set by `nnmaildir-request-article'.")
string)
(defmacro nnmaildir--condcase (errsym body &rest handler)
- (declare (debug (sexp form body)))
+ (declare (indent 2) (debug (sexp form body)))
`(condition-case ,errsym
(let ((system-messages-locale "C")) ,body)
(error . ,handler)))
@@ -492,9 +482,9 @@ This variable is set by `nnmaildir-request-article'.")
(setq nov-mid 0))
(goto-char (point-min))
(delete-char 1)
- (setq nov (nnheader-parse-naked-head)
+ (setq nov (nnheader-parse-head t)
field (or (mail-header-lines nov) 0)))
- (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
+ (unless (or (<= field 0) (nnmaildir--param pgname 'distrust-Lines:))
(setq nov-mid field))
(setq nov-mid (number-to-string nov-mid)
nov-mid (concat (number-to-string attr) "\t" nov-mid))
@@ -690,7 +680,7 @@ This variable is set by `nnmaildir-request-article'.")
"You must set \"directory\" in the select method")
(throw 'return nil))
(setq dir (cadr dir)
- dir (eval dir)
+ dir (eval dir t) ;FIXME: Why `eval'?
dir (expand-file-name dir)
dir (file-name-as-directory dir))
(unless (file-exists-p dir)
@@ -717,13 +707,13 @@ This variable is set by `nnmaildir-request-article'.")
(if x
(progn
(setq x (cadr x)
- x (eval x))
+ x (eval x t)) ;FIXME: Why `eval'?
(setf (nnmaildir--srv-target-prefix server) x))
(setq x (assq 'create-directory defs))
(if x
(progn
(setq x (cadr x)
- x (eval x)
+ x (eval x t) ;FIXME: Why `eval'?
x (file-name-as-directory x))
(setf (nnmaildir--srv-target-prefix server) x))
(setf (nnmaildir--srv-target-prefix server) "")))
@@ -865,8 +855,8 @@ This variable is set by `nnmaildir-request-article'.")
file))
files)
files (delq nil files)
- files (mapcar 'nnmaildir--parse-filename files)
- files (sort files 'nnmaildir--sort-files))
+ files (mapcar #'nnmaildir--parse-filename files)
+ files (sort files #'nnmaildir--sort-files))
(dolist (file files)
(setq file (if (consp file) file (aref file 3))
x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
@@ -1008,7 +998,7 @@ This variable is set by `nnmaildir-request-article'.")
always-marks (nnmaildir--param pgname 'always-marks)
never-marks (nnmaildir--param pgname 'never-marks)
existing (nnmaildir--grp-nlist group)
- existing (mapcar 'car existing)
+ existing (mapcar #'car existing)
existing (nreverse existing)
existing (gnus-compress-sequence existing 'always-list)
missing (list (cons 1 (nnmaildir--group-maxnum
@@ -1023,8 +1013,8 @@ This variable is set by `nnmaildir-request-article'.")
;; get mark names from mark dirs and from flag
;; mappings
(append
- (mapcar 'cdr nnmaildir-flag-mark-mapping)
- (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
+ (mapcar #'cdr nnmaildir-flag-mark-mapping)
+ (mapcar #'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
new-mmth (make-hash-table :size (length all-marks))
old-mmth (nnmaildir--grp-mmth group))
(dolist (mark all-marks)
@@ -1080,7 +1070,7 @@ This variable is set by `nnmaildir-request-article'.")
(let ((article (nnmaildir--flist-art flist prefix)))
(when article
(push (nnmaildir--art-num article) article-list))))))
- (setq ranges (gnus-add-to-range ranges (sort article-list '<)))))
+ (setq ranges (gnus-add-to-range ranges (sort article-list #'<)))))
(if (eq mark 'read) (setq read ranges)
(if ranges (setq marks (cons (cons mark ranges) marks)))))
(setf (gnus-info-read info) (gnus-range-add read missing))
@@ -1429,7 +1419,7 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--with-move-buffer
(erase-buffer)
(nnheader-insert-file-contents nnmaildir--file)
- (setq result (eval accept-form)))
+ (setq result (eval accept-form t)))
(unless (or (null result) (nnmaildir--param pgname 'read-only))
(nnmaildir--unlink nnmaildir--file)
(nnmaildir--expired-article group article))
@@ -1545,7 +1535,7 @@ This variable is set by `nnmaildir-request-article'.")
(defun nnmaildir-request-expire-articles (ranges &optional gname server force)
(let ((no-force (not force))
(group (nnmaildir--prepare server gname))
- pgname time boundary high low target dir nlist
+ pgname time boundary target dir nlist
didnt nnmaildir--file nnmaildir-article-file-name
deactivate-mark)
(catch 'return
@@ -1705,8 +1695,8 @@ This variable is set by `nnmaildir-request-article'.")
;; get mark names from mark dirs and from flag
;; mappings
(append
- (mapcar 'cdr nnmaildir-flag-mark-mapping)
- (mapcar 'intern all-marks))))
+ (mapcar #'cdr nnmaildir-flag-mark-mapping)
+ (mapcar #'intern all-marks))))
(dolist (action actions)
(setq ranges (car action)
todo-marks (caddr action))
@@ -1721,18 +1711,23 @@ This variable is set by `nnmaildir-request-article'.")
(defun nnmaildir-close-group (gname &optional server)
(let ((group (nnmaildir--prepare server gname))
- pgname ls dir msgdir files flist dirs)
+ pgname ls dir msgdir files dirs
+ (fset (make-hash-table :test #'equal)))
(if (null group)
(progn
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "No such group: " gname))
nil)
+ ;; Delete the now obsolete NOV files.
+ ;; FIXME: This can take a somewhat long time, so maybe it's better
+ ;; to do it asynchronously (i.e. in an idle timer).
(setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
dir (nnmaildir--srv-dir nnmaildir--cur-server)
dir (nnmaildir--srvgrp-dir dir gname)
msgdir (if (nnmaildir--param pgname 'read-only)
(nnmaildir--new dir) (nnmaildir--cur dir))
+ ;; The dir with the NOV files.
dir (nnmaildir--nndir dir)
dirs (cons (nnmaildir--nov-dir dir)
(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
@@ -1745,14 +1740,15 @@ This variable is set by `nnmaildir-request-article'.")
(save-match-data
(dolist (file files)
(string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
- (push (match-string 1 file) flist)))
+ (puthash (match-string 1 file) t fset)))
+ ;; Not sure why, but we specifically avoid deleting the `:' file.
+ (puthash ":" t fset)
(dolist (dir dirs)
(setq files (cdr dir)
dir (file-name-as-directory (car dir)))
(dolist (file files)
- (unless (or (member file flist) (string= file ":"))
- (setq file (concat dir file))
- (delete-file file))))
+ (unless (gethash file fset)
+ (delete-file (concat dir file)))))
t)))
(defun nnmaildir-close-server (&optional server _defs)
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index 43945cbec18..c6aaf460ece 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -1,4 +1,4 @@
-;;; nnmairix.el --- Mairix back end for Gnus, the Emacs newsreader
+;;; nnmairix.el --- Mairix back end for Gnus, the Emacs newsreader -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -193,8 +193,8 @@
(define-key gnus-summary-mode-map
(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)
+(add-hook 'gnus-group-mode-hook #'nnmairix-group-mode-hook)
+(add-hook 'gnus-summary-mode-hook #'nnmairix-summary-mode-hook)
;; ;;;###autoload
;; (defun nnmairix-initialize (&optional force)
@@ -202,8 +202,8 @@
;; (if (not (or (file-readable-p "~/.mairixrc")
;; force))
;; (message "No file `~/.mairixrc', skipping nnmairix setup")
-;; (add-hook 'gnus-group-mode-hook 'nnmairix-group-mode-hook)
-;; (add-hook 'gnus-summary-mode-hook 'nnmairix-summary-mode-hook)))
+;; (add-hook 'gnus-group-mode-hook #'nnmairix-group-mode-hook)
+;; (add-hook 'gnus-summary-mode-hook #'nnmairix-summary-mode-hook)))
;; Customizable stuff
@@ -219,20 +219,17 @@ server will be this prefix plus a random number. You can delete
unused nnmairix groups on the back end using
`nnmairix-purge-old-groups'."
:version "23.1"
- :type 'string
- :group 'nnmairix)
+ :type 'string)
(defcustom nnmairix-mairix-output-buffer "*mairix output*"
"Buffer used for mairix output."
:version "23.1"
- :type 'string
- :group 'nnmairix)
+ :type 'string)
(defcustom nnmairix-customize-query-buffer "*mairix query*"
"Name of the buffer for customizing Mairix queries."
:version "23.1"
- :type 'string
- :group 'nnmairix)
+ :type 'string)
(defcustom nnmairix-mairix-update-options '("-F" "-Q")
"Options when calling mairix for updating the database.
@@ -240,21 +237,18 @@ The default is \"-F\" and \"-Q\" for making updates faster. You
should call mairix without these options from time to
time (e.g. via cron job)."
:version "23.1"
- :type '(repeat string)
- :group 'nnmairix)
+ :type '(repeat string))
(defcustom nnmairix-mairix-search-options '("-Q")
"Options when calling mairix for searching.
The default is \"-Q\" for making searching faster."
:version "23.1"
- :type '(repeat string)
- :group 'nnmairix)
+ :type '(repeat string))
(defcustom nnmairix-mairix-synchronous-update nil
"Set this to t if you want Emacs to wait for mairix updating the database."
:version "23.1"
- :type 'boolean
- :group 'nnmairix)
+ :type 'boolean)
(defcustom nnmairix-rename-files-for-nnml t
"Rename nnml mail files so that they are consecutively numbered.
@@ -263,8 +257,7 @@ article numbers which will produce wrong article counts by
Gnus. This option controls whether nnmairix should rename the
files consecutively."
:version "23.1"
- :type 'boolean
- :group 'nnmairix)
+ :type 'boolean)
(defcustom nnmairix-widget-fields-list
'(("from" "f" "From") ("to" "t" "To") ("cc" "c" "Cc")
@@ -288,16 +281,14 @@ nil for disabling this)."
(const :tag "Subject" "subject")
(const :tag "Message ID" "Message-ID"))
(string :tag "Command")
- (string :tag "Description")))
- :group 'nnmairix)
+ (string :tag "Description"))))
(defcustom nnmairix-widget-select-window-function
(lambda () (select-window (get-largest-window)))
"Function for selecting the window for customizing the mairix query.
The default chooses the largest window in the current frame."
:version "23.1"
- :type 'function
- :group 'nnmairix)
+ :type 'function)
(defcustom nnmairix-propagate-marks-upon-close t
"Flag if marks should be propagated upon closing a group.
@@ -308,8 +299,7 @@ call `nnmairix-propagate-marks'."
:version "23.1"
:type '(choice (const :tag "always" t)
(const :tag "ask" ask)
- (const :tag "never" nil))
- :group 'nnmairix)
+ (const :tag "never" nil)))
(defcustom nnmairix-propagate-marks-to-nnmairix-groups nil
"Flag if marks from original articles should be seen in nnmairix groups.
@@ -319,8 +309,7 @@ e.g. an IMAP server (which stores the marks in the maildir file
name). You may safely set this to t for testing - the worst that
can happen are wrong marks in nnmairix groups."
:version "23.1"
- :type 'boolean
- :group 'nnmairix)
+ :type 'boolean)
(defcustom nnmairix-only-use-registry nil
"Use only the registry for determining original group(s).
@@ -330,16 +319,14 @@ propagating marks). If set to nil, it will also try to determine
the group from an additional mairix search which might be slow
when propagating lots of marks."
:version "23.1"
- :type 'boolean
- :group 'nnmairix)
+ :type 'boolean)
(defcustom nnmairix-allowfast-default nil
"Whether fast entering should be the default for nnmairix groups.
You may set this to t to make entering the group faster, but note that
this might lead to problems, especially when used with marks propagation."
:version "23.1"
- :type 'boolean
- :group 'nnmairix)
+ :type 'boolean)
;; ==== Other variables
@@ -417,7 +404,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 info)
+(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
@@ -430,7 +417,7 @@ Other back ends might or might not work.")
(backendmethod (gnus-server-to-method
(format "%s:%s" (symbol-name nnmairix-backend)
nnmairix-backend-server)))
- rval mfolder folderpath args)
+ rval mfolder folderpath) ;; args
(cond
((not folder)
;; No folder parameter -> error
@@ -510,12 +497,12 @@ Other back ends might or might not work.")
nil))))))
-(deffoo nnmairix-request-create-group (group &optional server args)
+(deffoo nnmairix-request-create-group (group &optional server _args)
(let ((qualgroup (if server (gnus-group-prefixed-name group (list 'nnmairix server))
group))
(exist t)
(count 0)
- groupname info)
+ groupname) ;; info
(when server (nnmairix-open-server server))
(gnus-group-add-parameter qualgroup '(query . nil))
(gnus-group-add-parameter qualgroup '(threads . nil))
@@ -574,7 +561,7 @@ Other back ends might or might not work.")
(deffoo nnmairix-request-list (&optional server)
(when server (nnmairix-open-server server))
(if (nnmairix-call-backend "request-list" nnmairix-backend-server)
- (let (cpoint cur qualgroup folder)
+ (let (cpoint cur qualgroup) ;; folder
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(setq cpoint (point))
@@ -603,7 +590,7 @@ Other back ends might or might not work.")
(nnmairix-open-server server))
(let* ((qualgroup (gnus-group-prefixed-name group (list 'nnmairix nnmairix-current-server)))
(propmarks (gnus-group-get-parameter qualgroup 'propmarks))
- (propto (gnus-group-get-parameter qualgroup 'propto t))
+ ;; (propto (gnus-group-get-parameter qualgroup 'propto t))
(corr (nnmairix-get-numcorr group server))
(folder (nnmairix-get-backend-folder group server)))
(save-excursion
@@ -611,7 +598,7 @@ Other back ends might or might not work.")
(let ((type (nth 1 cur))
(cmdmarks (nth 2 cur))
(range (gnus-uncompress-range (nth 0 cur)))
- mid ogroup number method temp)
+ mid ogroup temp) ;; number method
(when (and corr
(not (zerop (cadr corr))))
(setq range (mapcar (lambda (arg)
@@ -674,7 +661,7 @@ Other back ends might or might not work.")
(nnmairix-open-server server))
(let* ((qualgroup (gnus-group-prefixed-name group (list 'nnmairix nnmairix-current-server)))
(propmarks (gnus-group-get-parameter qualgroup 'propmarks))
- method)
+ ) ;; method
(when (and propmarks
nnmairix-marks-cache)
(when (or (eq nnmairix-propagate-marks-upon-close t)
@@ -689,9 +676,9 @@ Other back ends might or might not work.")
(autoload 'nnimap-request-update-info-internal "nnimap")
(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
+ ;; 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
(when server
(nnmairix-open-server server))
(let* ((qualgroup (gnus-group-prefixed-name
@@ -703,7 +690,7 @@ Other back ends might or might not work.")
(corr (nnmairix-get-numcorr group server))
(docorr (and corr (not (zerop (cadr corr)))))
(folderinfo `(,group 1 ((1 . 1))))
- readrange marks)
+ ) ;; readrange marks
(when (and propmarks
nnmairix-propagate-marks-to-nnmairix-groups)
;; these groups are not subscribed, so we have to ask the back end directly
@@ -714,8 +701,8 @@ Other back ends might or might not work.")
(setf (gnus-info-read info)
(if docorr
(nnmairix-map-range
- ;; FIXME: Use lexical-binding.
- `(lambda (x) (+ x ,(cadr corr)))
+ (let ((off (cadr corr)))
+ (lambda (x) (+ x off)))
(gnus-info-read folderinfo))
(gnus-info-read folderinfo)))
;; set other marks
@@ -725,8 +712,8 @@ Other back ends might or might not work.")
(cons
(car cur)
(nnmairix-map-range
- ;; FIXME: Use lexical-binding.
- `(lambda (x) (+ x ,(cadr corr)))
+ (let ((off (cadr corr)))
+ (lambda (x) (+ x off)))
(list (cadr cur)))))
(gnus-info-marks folderinfo))
(gnus-info-marks folderinfo))))
@@ -757,10 +744,9 @@ called interactively, user will be asked for parameters."
(when (not (listp query))
(setq query (list query)))
(when (and server group query)
- (save-excursion
- (let ((groupname (gnus-group-prefixed-name group server))
- info)
- (set-buffer gnus-group-buffer)
+ (let ((groupname (gnus-group-prefixed-name group server))
+ ) ;; info
+ (with-current-buffer gnus-group-buffer
(gnus-group-make-group group server)
(gnus-group-set-parameter groupname 'query query)
(gnus-group-set-parameter groupname 'threads threads)
@@ -783,7 +769,7 @@ called interactively, user will be asked for parameters."
(setq finished (not (y-or-n-p "Add another search query? "))
achar nil))
(nnmairix-search
- (mapconcat 'identity query " ")
+ (mapconcat #'identity query " ")
(car (nnmairix-get-server))
(y-or-n-p "Include whole threads? "))))
@@ -792,7 +778,7 @@ called interactively, user will be asked for parameters."
(interactive)
(let ((char-header nnmairix-interactive-query-parameters)
(server (nnmairix-backend-to-server gnus-current-select-method))
- query achar header finished group threads cq)
+ query achar header finished group threads) ;; cq
(when (or (not (gnus-buffer-live-p gnus-article-buffer))
(not (gnus-buffer-live-p gnus-summary-buffer)))
(error "No article or summary buffer"))
@@ -810,7 +796,8 @@ called interactively, user will be asked for parameters."
(setq achar nil)))
(set-buffer gnus-article-buffer)
(setq header nil)
- (when (setq cq (nth 1 (assoc achar char-header)))
+ (when ;; (setq cq
+ (nth 1 (assoc achar char-header)) ;;)
(setq header
(nnmairix-replace-illegal-chars
(gnus-fetch-field (nth 1 (assoc achar char-header))))))
@@ -824,7 +811,7 @@ called interactively, user will be asked for parameters."
(setq group (read-string "Group name: "))
(set-buffer gnus-summary-buffer)
(message "Creating group %s on server %s with query %s." group
- (gnus-method-to-server server) (mapconcat 'identity query " "))
+ (gnus-method-to-server server) (mapconcat #'identity query " "))
(nnmairix-create-search-group server group query threads)))
(defun nnmairix-create-server-and-default-group ()
@@ -841,7 +828,7 @@ All necessary information will be queried from the user."
(hidden (and (string-match "^nn\\(imap\\|maildir\\)$" backend)
(y-or-n-p
"Does the back end server work with maildir++ (i.e. hidden directories)? ")))
- create)
+ ) ;; create
(apply (intern (format "%s-%s" backend "open-server"))
(list servername))
@@ -866,7 +853,7 @@ All necessary information will be queried from the user."
(if (eq (car method) 'nnmairix)
(progn
(when (listp oldquery)
- (setq oldquery (mapconcat 'identity oldquery " ")))
+ (setq oldquery (mapconcat #'identity oldquery " ")))
(setq query (or query
(read-string "New query: " oldquery)))
(when (stringp query)
@@ -1023,7 +1010,7 @@ before deleting a group on the back end. SERVER specifies nnmairix server."
(if (nnmairix-open-server (nth 1 server))
(when (nnmairix-call-backend
"request-list" nnmairix-backend-server)
- (let (cur qualgroup folder)
+ (let (cur qualgroup) ;; folder
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (re-search-forward nnmairix-group-regexp (point-max) t)
@@ -1068,7 +1055,7 @@ with `nnmairix-mairix-update-options'."
(if (> (length commandsplit) 1)
(setq args (append args (cdr commandsplit) nnmairix-mairix-update-options))
(setq args (append args nnmairix-mairix-update-options)))
- (apply 'call-process args)
+ (apply #'call-process args)
(nnheader-message 7 "Updating mairix database for %s... done" cur))
(progn
(setq args (append (list cur (get-buffer nnmairix-mairix-output-buffer)
@@ -1076,7 +1063,7 @@ with `nnmairix-mairix-update-options'."
(if (> (length commandsplit) 1)
(setq args (append args (cdr commandsplit) nnmairix-mairix-update-options))
(setq args (append args nnmairix-mairix-update-options)))
- (set-process-sentinel (apply 'start-process args)
+ (set-process-sentinel (apply #'start-process args)
'nnmairix-sentinel-mairix-update-finished))))))
(defun nnmairix-group-delete-recreate-this-group ()
@@ -1186,7 +1173,7 @@ Marks propagation has to be enabled for this to work."
(error "Not in a nnmairix group"))
(save-excursion
(let ((mid (mail-header-message-id (gnus-summary-article-header)))
- groups cur)
+ groups) ;; cur
(when mid
(setq groups (nnmairix-determine-original-group-from-registry mid))
(unless (or groups
@@ -1249,7 +1236,7 @@ Marks propagation has to be enabled for this to work."
If THREADS is non-nil, enable full threads."
(let ((args (cons (car command) '(nil t nil))))
(with-current-buffer
- (get-buffer-create nnmairix-mairix-output-buffer)
+ (gnus-get-buffer-create nnmairix-mairix-output-buffer)
(erase-buffer)
(when (> (length command) 1)
(setq args (append args (cdr command))))
@@ -1260,19 +1247,19 @@ If THREADS is non-nil, enable full threads."
(setq args (append args '("-c"))))
(when threads
(setq args (append args '("-t"))))
- (apply 'call-process
+ (apply #'call-process
(append args (list "-o" folder) searchquery)))))
(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))))
(with-current-buffer
- (get-buffer-create nnmairix-mairix-output-buffer)
+ (gnus-get-buffer-create nnmairix-mairix-output-buffer)
(erase-buffer)
(when (> (length command) 1)
(setq args (append args (cdr command))))
(setq args (append args '("-r")))
- (apply 'call-process
+ (apply #'call-process
(append args query)))))
(defun nnmairix-get-server ()
@@ -1313,7 +1300,7 @@ If ALL is t, return also the unopened/failed ones."
"Return list of valid back end servers for nnmairix groups."
(let ((alist gnus-opened-servers)
(mairixservers (nnmairix-get-nnmairix-servers t))
- server mserver openedserver occ cur)
+ server mserver openedserver occ) ;; cur
;; Get list of all nnmairix backends (i.e. backends which are
;; already occupied)
(dolist (cur mairixservers)
@@ -1382,9 +1369,9 @@ This should correct problems of wrong article counts when using
nnmairix with nnml backends."
(let* ((files
(sort
- (mapcar 'string-to-number
+ (mapcar #'string-to-number
(directory-files path nil "[0-9]+" t))
- '<))
+ #'<))
(lastplusone (car files))
(path (file-name-as-directory path)))
(dolist (cur files)
@@ -1404,10 +1391,10 @@ TYPE is either `nov' or `headers'."
(nnheader-message 7 "nnmairix: Rewriting headers...")
(cond
((eq type 'nov)
- (let ((buf (get-buffer-create " *nnmairix buffer*"))
+ (let ((buf (gnus-get-buffer-create " *nnmairix buffer*"))
(corr (not (zerop numc)))
(name (buffer-name nntp-server-buffer))
- header cur xref)
+ cur xref) ;; header
(with-current-buffer buf
(erase-buffer)
(set-buffer nntp-server-buffer)
@@ -1548,9 +1535,8 @@ See %s for details" proc nnmairix-mairix-output-buffer)))
(defun nnmairix-create-message-line-for-search ()
"Create message line for interactive query in minibuffer."
(mapconcat
- (function
- (lambda (cur)
- (format "%c=%s" (car cur) (nth 3 cur))))
+ (lambda (cur)
+ (format "%c=%s" (car cur) (nth 3 cur)))
nnmairix-interactive-query-parameters ","))
(defun nnmairix-replace-illegal-chars (header)
@@ -1601,7 +1587,7 @@ search in raw mode."
(when (not (gnus-buffer-live-p gnus-article-buffer))
(error "No article buffer available"))
(let ((server (nth 1 gnus-current-select-method))
- mid rval group allgroups)
+ mid group allgroups) ;; rval
;; get message id
(with-current-buffer gnus-article-buffer
(gnus-summary-toggle-header 1)
@@ -1775,7 +1761,7 @@ If VERSION is a string: must be contained in mairix version output."
(let* ((commandsplit (split-string nnmairix-mairix-command))
(args (append (list (car commandsplit))
'(nil t nil) (cdr commandsplit) '("-V"))))
- (apply 'call-process args)
+ (apply #'call-process args)
(goto-char (point-min))
(re-search-forward "mairix.*")
(match-string 0))))
@@ -1811,13 +1797,12 @@ If VERSION is a string: must be contained in mairix version output."
(gnus-summary-toggle-header 1)
(set-buffer gnus-article-buffer)
(mapcar
- (function
- (lambda (field)
- (list (car (cddr field))
- (if (car field)
- (nnmairix-replace-illegal-chars
- (gnus-fetch-field (car field)))
- nil))))
+ (lambda (field)
+ (list (car (cddr field))
+ (if (car field)
+ (nnmairix-replace-illegal-chars
+ (gnus-fetch-field (car field)))
+ nil)))
nnmairix-widget-fields-list))))
@@ -1833,10 +1818,10 @@ MVALUES may contain values from current article."
(widget-create 'push-button
:notify
(if mvalues
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(nnmairix-widget-send-query nnmairix-widgets
t))
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(nnmairix-widget-send-query nnmairix-widgets
nil)))
"Send Query")
@@ -1844,16 +1829,16 @@ MVALUES may contain values from current article."
(widget-create 'push-button
:notify
(if mvalues
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(nnmairix-widget-create-group nnmairix-widgets
t))
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(nnmairix-widget-create-group nnmairix-widgets
nil)))
"Create permanent group")
(widget-insert " ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _ignore)
(kill-buffer nnmairix-customize-query-buffer))
"Cancel")
(use-local-map widget-keymap)
@@ -1911,25 +1896,24 @@ If WITHVALUES is t, query is based on current article."
(when (member 'flags nnmairix-widget-other)
(setq flag
(mapconcat
- (function
- (lambda (flag)
- (setq temp
- (widget-value (cadr (assoc (car flag) nnmairix-widgets))))
- (if (string= "yes" temp)
- (cadr flag)
- (if (string= "no" temp)
- (concat "-" (cadr flag))))))
+ (lambda (flag)
+ (setq temp
+ (widget-value (cadr (assoc (car flag) nnmairix-widgets))))
+ (if (string= "yes" temp)
+ (cadr flag)
+ (if (string= "no" temp)
+ (concat "-" (cadr flag)))))
'(("seen" "s") ("replied" "r") ("flagged" "f")) ""))
(when (not (zerop (length flag)))
(push (concat "F:" flag) query)))
;; return query string
- (mapconcat 'identity query " ")))
+ (mapconcat #'identity query " ")))
(defun nnmairix-widget-create-query (&optional values)
"Create widgets for creating mairix queries.
Fill in VALUES if based on an article."
- (let (allwidgets)
+ ;;(let (allwidgets)
(when (get-buffer nnmairix-customize-query-buffer)
(kill-buffer nnmairix-customize-query-buffer))
(switch-to-buffer nnmairix-customize-query-buffer)
@@ -1960,7 +1944,7 @@ Fill in VALUES if based on an article."
(when (member 'threads nnmairix-widget-other)
(widget-insert "\n")
(nnmairix-widget-add "Threads" 'checkbox nil))
- (widget-insert " Show full threads\n\n")))
+ (widget-insert " Show full threads\n\n")) ;; )
(defun nnmairix-widget-build-editable-fields (values)
"Build editable field widgets in `nnmairix-widget-fields-list'.
@@ -1968,32 +1952,31 @@ VALUES may contain values for editable fields from current article."
;; how can this be done less ugly?
(let ((ret))
(mapc
- (function
- (lambda (field)
- (setq field (car (cddr field)))
- (setq ret
- (nconc
- (list
- (list
- (concat "c" field)
- (widget-create 'checkbox
- :tag field
- :notify (lambda (widget &rest ignore)
- (nnmairix-widget-toggle-activate widget))
- nil)))
- (list
- (list
- (concat "e" field)
- (widget-create 'editable-field
- :size 60
- :format (concat " " field ":"
- (make-string (- 11 (length field)) ?\ )
- "%v")
- :value (or (cadr (assoc field values)) ""))))
- ret))
- (widget-insert "\n")
- ;; Deactivate editable field
- (widget-apply (cadr (nth 1 ret)) :deactivate)))
+ (lambda (field)
+ (setq field (car (cddr field)))
+ (setq ret
+ (nconc
+ (list
+ (list
+ (concat "c" field)
+ (widget-create 'checkbox
+ :tag field
+ :notify (lambda (widget &rest _ignore)
+ (nnmairix-widget-toggle-activate widget))
+ nil)))
+ (list
+ (list
+ (concat "e" field)
+ (widget-create 'editable-field
+ :size 60
+ :format (concat " " field ":"
+ (make-string (- 11 (length field)) ?\ )
+ "%v")
+ :value (or (cadr (assoc field values)) ""))))
+ ret))
+ (widget-insert "\n")
+ ;; Deactivate editable field
+ (widget-apply (cadr (nth 1 ret)) :deactivate))
nnmairix-widget-fields-list)
ret))
@@ -2001,7 +1984,7 @@ VALUES may contain values for editable fields from current article."
"Add a widget NAME with optional ARGS."
(push
(list name
- (apply 'widget-create args))
+ (apply #'widget-create args))
nnmairix-widgets))
(defun nnmairix-widget-toggle-activate (widget)
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index d1bb1da6113..66c22670b23 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -1,4 +1,4 @@
-;;; nnmbox.el --- mail mbox access for Gnus
+;;; nnmbox.el --- mail mbox access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -76,7 +76,7 @@
(nnoo-define-basics nnmbox)
-(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
+(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server _fetch-old)
(with-current-buffer nntp-server-buffer
(erase-buffer)
(let ((number (length sequence))
@@ -168,7 +168,7 @@
(cons nnmbox-current-group article)
(nnmbox-article-group-number nil))))))))
-(deffoo nnmbox-request-group (group &optional server dont-check info)
+(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
@@ -207,17 +207,16 @@
(file-name-directory nnmbox-mbox-file)
group
(lambda ()
- (save-excursion
- (let ((in-buf (current-buffer)))
- (set-buffer nnmbox-mbox-buffer)
+ (let ((in-buf (current-buffer)))
+ (with-current-buffer nnmbox-mbox-buffer
(goto-char (point-max))
(insert-buffer-substring in-buf)))
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file))))
-(deffoo nnmbox-close-group (group &optional server)
+(deffoo nnmbox-close-group (_group &optional _server)
t)
-(deffoo nnmbox-request-create-group (group &optional server args)
+(deffoo nnmbox-request-create-group (group &optional _server _args)
(nnmail-activate 'nnmbox)
(unless (assoc group nnmbox-group-alist)
(push (list group (cons 1 0))
@@ -225,7 +224,7 @@
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file))
t)
-(deffoo nnmbox-request-list (&optional server)
+(deffoo nnmbox-request-list (&optional _server)
(save-excursion
(let ((nnmail-file-coding-system
nnmbox-active-file-coding-system))
@@ -233,12 +232,14 @@
(setq nnmbox-group-alist (nnmail-get-active))
t))
-(deffoo nnmbox-request-newgroups (date &optional server)
+(deffoo nnmbox-request-newgroups (_date &optional server)
(nnmbox-request-list server))
-(deffoo nnmbox-request-list-newsgroups (&optional server)
+(deffoo nnmbox-request-list-newsgroups (&optional _server)
(nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
+(defvar nnml-current-directory)
+
(deffoo nnmbox-request-expire-articles
(articles newsgroup &optional server force)
(nnmbox-possibly-change-newsgroup newsgroup server)
@@ -279,8 +280,8 @@
(nconc rest articles))))
(deffoo nnmbox-request-move-article
- (article group server accept-form &optional last move-is-internal)
- (let ((buf (get-buffer-create " *nnmbox move*"))
+ (article group server accept-form &optional last _move-is-internal)
+ (let ((buf (gnus-get-buffer-create " *nnmbox move*"))
result)
(and
(nnmbox-request-article article group server)
@@ -292,7 +293,7 @@
"^X-Gnus-Newsgroup:"
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(gnus-delete-line))
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer buf)
result)
(save-excursion
@@ -613,7 +614,7 @@
(dir (file-name-directory nnmbox-mbox-file)))
(and dir (gnus-make-directory dir))
(nnmail-write-region (point-min) (point-min)
- nnmbox-mbox-file t 'nomesg))))
+ nnmbox-mbox-file t 'nomesg nil 'excl))))
(defun nnmbox-read-mbox ()
(nnmail-activate 'nnmbox)
@@ -622,16 +623,15 @@
(with-current-buffer nnmbox-mbox-buffer
(= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
()
- (save-excursion
- (let ((delim (concat "^" message-unix-mail-delimiter))
- (alist nnmbox-group-alist)
- (nnmbox-group-building-active-articles t)
- start end end-header number)
- (set-buffer (setq nnmbox-mbox-buffer
- (let ((nnheader-file-coding-system
- nnmbox-file-coding-system))
- (nnheader-find-file-noselect
- nnmbox-mbox-file t t))))
+ (let ((delim (concat "^" message-unix-mail-delimiter))
+ (alist nnmbox-group-alist)
+ (nnmbox-group-building-active-articles t)
+ start end end-header number)
+ (with-current-buffer (setq nnmbox-mbox-buffer
+ (let ((nnheader-file-coding-system
+ nnmbox-file-coding-system))
+ (nnheader-find-file-noselect
+ nnmbox-mbox-file t t)))
(mm-enable-multibyte)
(buffer-disable-undo)
(gnus-add-buffer)
diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el
index 4f81ed0b0c2..0923b8eff34 100644
--- a/lisp/gnus/nnmh.el
+++ b/lisp/gnus/nnmh.el
@@ -1,4 +1,4 @@
-;;; nnmh.el --- mhspool access for Gnus
+;;; nnmh.el --- mhspool access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -46,7 +46,7 @@
"Hook run narrowed to an article before saving.")
(defvoo nnmh-be-safe nil
- "If non-nil, nnmh will check all articles to make sure whether they are new or not.
+ "If non-nil, nnmh will check all articles to make sure if they are new or not.
Go through the .nnmh-articles file and compare with the actual
articles in this folder. The articles that are \"new\" will be marked
as unread by Gnus.")
@@ -72,7 +72,7 @@ as unread by Gnus.")
(nnoo-define-basics nnmh)
-(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
+(deffoo nnmh-retrieve-headers (articles &optional newsgroup server _fetch-old)
(with-current-buffer nntp-server-buffer
(erase-buffer)
(let* ((file nil)
@@ -147,7 +147,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 info)
+(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))
@@ -171,9 +171,9 @@ as unread by Gnus.")
(nnheader-re-read-dir pathname)
(setq dir
(sort
- (mapcar 'string-to-number
+ (mapcar #'string-to-number
(directory-files pathname nil "\\`[0-9]+\\'" t))
- '<))
+ #'<))
(cond
(dir
(setq nnmh-group-alist
@@ -188,9 +188,11 @@ as unread by Gnus.")
(nnheader-report 'nnmh "Empty group %s" group)
(nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
-(deffoo nnmh-request-scan (&optional group server)
+(deffoo nnmh-request-scan (&optional group _server)
(nnmail-get-new-mail 'nnmh nil nnmh-directory group))
+(defvar nnmh-toplev)
+
(deffoo nnmh-request-list (&optional server dir)
(nnheader-insert "")
(nnmh-possibly-change-directory nil server)
@@ -201,13 +203,12 @@ as unread by Gnus.")
(setq nnmh-group-alist (nnmail-get-active))
t)
-(defvar nnmh-toplev)
(defun nnmh-request-list-1 (dir)
(setq dir (expand-file-name dir))
;; Recurse down all directories.
(let ((files (nnheader-directory-files dir t nil t))
(max 0)
- min rdir num subdirectoriesp file)
+ min num subdirectoriesp file) ;; rdir
;; Recurse down directories.
(setq subdirectoriesp
;; link number always 1 on MS Windows :(
@@ -252,7 +253,7 @@ as unread by Gnus.")
(or min 1))))))
t)
-(deffoo nnmh-request-newgroups (date &optional server)
+(deffoo nnmh-request-newgroups (_date &optional server)
(nnmh-request-list server))
(deffoo nnmh-request-expire-articles (articles newsgroup
@@ -291,12 +292,12 @@ as unread by Gnus.")
(nnheader-message 5 "")
(nconc rest articles)))
-(deffoo nnmh-close-group (group &optional server)
+(deffoo nnmh-close-group (_group &optional _server)
t)
-(deffoo nnmh-request-move-article (article group server accept-form
- &optional last move-is-internal)
- (let ((buf (get-buffer-create " *nnmh move*"))
+(deffoo nnmh-request-move-article ( article group server accept-form
+ &optional _last _move-is-internal)
+ (let ((buf (gnus-get-buffer-create " *nnmh move*"))
result)
(and
(nnmh-deletable-article-p group article)
@@ -304,7 +305,7 @@ as unread by Gnus.")
(with-current-buffer buf
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer (current-buffer))
result)
(progn
@@ -350,7 +351,7 @@ as unread by Gnus.")
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)))
-(deffoo nnmh-request-create-group (group &optional server args)
+(deffoo nnmh-request-create-group (group &optional server _args)
(nnheader-init-server-buffer)
(unless (assoc group nnmh-group-alist)
(let (active)
@@ -358,12 +359,12 @@ as unread by Gnus.")
nnmh-group-alist)
(nnmh-possibly-create-directory group)
(nnmh-possibly-change-directory group server)
- (let ((articles (mapcar 'string-to-number
+ (let ((articles (mapcar #'string-to-number
(directory-files
nnmh-current-directory nil "\\`[0-9]+\\'"))))
(when articles
- (setcar active (apply 'min articles))
- (setcdr active (apply 'max articles))))))
+ (setcar active (apply #'min articles))
+ (setcdr active (apply #'max articles))))))
t)
(deffoo nnmh-request-delete-group (group &optional force server)
@@ -484,9 +485,9 @@ as unread by Gnus.")
(gnus-make-directory dir))
;; Find the highest number in the group.
(let ((files (sort
- (mapcar 'string-to-number
+ (mapcar #'string-to-number
(directory-files dir nil "\\`[0-9]+\\'"))
- '>)))
+ #'>)))
(when files
(setcdr active (car files)))))
(setcdr active (1+ (cdr active)))
@@ -502,15 +503,17 @@ as unread by Gnus.")
(setcdr active (1+ (cdr active))))
(cdr active)))
+(defvar nnmh-newsgroup-articles)
+
(defun nnmh-update-gnus-unreads (group)
;; Go through the .nnmh-articles file and compare with the actual
;; articles in this folder. The articles that are "new" will be
;; marked as unread by Gnus.
(let* ((dir nnmh-current-directory)
- (files (sort (mapcar 'string-to-number
+ (files (sort (mapcar #'string-to-number
(directory-files nnmh-current-directory
nil "\\`[0-9]+\\'" t))
- '<))
+ #'<))
(nnmh-file (concat dir ".nnmh-articles"))
new articles)
;; Load the .nnmh-articles file.
@@ -557,7 +560,7 @@ as unread by Gnus.")
(when new
(gnus-make-articles-unread
(gnus-group-prefixed-name group (list 'nnmh ""))
- (setq new (sort new '<))))
+ (setq new (sort new #'<))))
;; Sort the article list with highest numbers first.
(setq articles (sort articles (lambda (art1 art2)
(> (car art1) (car art2)))))
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index 0a8e847dcf7..18acc73aadd 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -1,4 +1,4 @@
-;;; nnml.el --- mail spool access for Gnus
+;;; nnml.el --- mail spool access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -111,7 +111,7 @@ non-nil.")
(nnoo-define-basics nnml)
-(defun nnml-group-pathname (group &optional file server)
+(defun nnml-group-pathname (group &optional file _server)
"Return an absolute file name of FILE for GROUP on SERVER."
(nnmail-group-pathname group nnml-directory file))
@@ -215,7 +215,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 info)
+(deffoo nnml-request-group (group &optional server dont-check _info)
(let ((file-name-coding-system nnmail-pathname-coding-system))
(cond
((not (nnml-possibly-change-directory group server))
@@ -252,11 +252,11 @@ non-nil.")
(t
(nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory nil))))
-(deffoo nnml-close-group (group &optional server)
+(deffoo nnml-close-group (_group &optional _server)
(setq nnml-article-file-alist nil)
t)
-(deffoo nnml-request-create-group (group &optional server args)
+(deffoo nnml-request-create-group (group &optional server _args)
(nnml-possibly-change-directory nil server)
(nnmail-activate 'nnml)
(cond
@@ -278,12 +278,12 @@ non-nil.")
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(articles (nnml-directory-articles nnml-current-directory)))
(when articles
- (setcar active (apply 'min articles))
- (setcdr active (apply 'max articles))))
+ (setcar active (apply #'min articles))
+ (setcdr active (apply #'max articles))))
(nnmail-save-active nnml-group-alist nnml-active-file)
t))))
-(deffoo nnml-request-list (&optional server)
+(deffoo nnml-request-list (&optional _server)
(save-excursion
(let ((nnmail-file-coding-system nnmail-active-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
@@ -291,10 +291,10 @@ non-nil.")
(setq nnml-group-alist (nnmail-get-active))
t))
-(deffoo nnml-request-newgroups (date &optional server)
+(deffoo nnml-request-newgroups (_date &optional server)
(nnml-request-list server))
-(deffoo nnml-request-list-newsgroups (&optional server)
+(deffoo nnml-request-list-newsgroups (&optional _server)
(save-excursion
(nnmail-find-file nnml-newsgroups-file)))
@@ -307,7 +307,7 @@ non-nil.")
article rest mod-time number target)
(nnmail-activate 'nnml)
- (setq active-articles (sort active-articles '<))
+ (setq active-articles (sort active-articles #'<))
;; Articles not listed in active-articles are already gone,
;; so don't try to expire them.
(setq articles (gnus-sorted-intersection articles active-articles))
@@ -353,15 +353,15 @@ non-nil.")
(let ((active (nth 1 (assoc-string group nnml-group-alist))))
(when active
(setcar active (or (and active-articles
- (apply 'min active-articles))
+ (apply #'min active-articles))
(1+ (cdr active)))))
(nnmail-save-active nnml-group-alist nnml-active-file))
(nnml-save-nov)
(nconc rest articles)))
(deffoo nnml-request-move-article
- (article group server accept-form &optional last move-is-internal)
- (let ((buf (get-buffer-create " *nnml move*"))
+ (article group server accept-form &optional last _move-is-internal)
+ (let ((buf (gnus-get-buffer-create " *nnml move*"))
(file-name-coding-system nnmail-pathname-coding-system)
result)
(nnml-possibly-change-directory group server)
@@ -374,7 +374,7 @@ non-nil.")
nnml-article-file-alist)
(with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
+ (setq result (eval accept-form t))
(kill-buffer (current-buffer))
result))
(progn
@@ -411,8 +411,8 @@ non-nil.")
(and
(nnmail-activate 'nnml)
(if (and (not (setq result (nnmail-article-group
- `(lambda (group)
- (nnml-active-number group ,server)))))
+ (lambda (group)
+ (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 t))))
@@ -572,7 +572,7 @@ non-nil.")
;; Find an article number in the current group given the Message-ID.
(defun nnml-find-group-number (id server)
- (with-current-buffer (get-buffer-create " *nnml id*")
+ (with-current-buffer (gnus-get-buffer-create " *nnml id*")
(let ((alist nnml-group-alist)
number)
;; We want to look through all .overview files, but we want to
@@ -705,7 +705,7 @@ article number. This function is called narrowed to an article."
(setq nnml-article-file-alist
(sort
(nnml-current-group-article-to-file-alist)
- 'car-less-than-car)))
+ #'car-less-than-car)))
(setq active
(if nnml-article-file-alist
(cons (caar nnml-article-file-alist)
@@ -766,21 +766,36 @@ article number. This function is called narrowed to an article."
(if (re-search-forward "\n\r?\n" nil t)
(1- (point))
(point-max))))
- (let ((headers (nnheader-parse-naked-head)))
+ (let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
+ ;; If there's non-ASCII raw characters in the data,
+ ;; RFC2047-encode them to avoid having arbitrary data in the
+ ;; .overview file.
+ (nnml--encode-headers headers)
headers))))
+(defun nnml--encode-headers (headers)
+ (let ((subject (mail-header-subject headers))
+ (rfc2047-encoding-type 'mime))
+ (unless (string-match "\\`[[:ascii:]]*\\'" subject)
+ (setf (mail-header-subject headers)
+ (mail-encode-encoded-word-string subject t))))
+ (let ((from (mail-header-from headers))
+ (rfc2047-encoding-type 'address-mime))
+ (unless (string-match "\\`[[:ascii:]]*\\'" from)
+ (setf (mail-header-from headers)
+ (rfc2047-encode-string from t)))))
+
(defun nnml-get-nov-buffer (group &optional incrementalp)
- (let ((buffer (get-buffer-create (format " *nnml %soverview %s*"
- (if incrementalp
- "incremental "
- "")
- group)))
+ (let ((buffer (gnus-get-buffer-create
+ (format " *nnml %soverview %s*"
+ (if incrementalp "incremental " "")
+ group)))
(file-name-coding-system nnmail-pathname-coding-system))
(with-current-buffer buffer
- (set (make-local-variable 'nnml-nov-buffer-file-name)
- (nnmail-group-pathname group nnml-directory nnml-nov-file-name))
+ (setq-local nnml-nov-buffer-file-name
+ (nnmail-group-pathname group nnml-directory nnml-nov-file-name))
(erase-buffer)
(when (and (not incrementalp)
(file-exists-p nnml-nov-buffer-file-name))
@@ -841,7 +856,7 @@ Unless no-active is non-nil, update the active file too."
(nnml-generate-nov-databases-directory dir seen)))
;; Do this directory.
(let ((nnml-files (sort (nnheader-article-to-file-alist dir)
- 'car-less-than-car)))
+ #'car-less-than-car)))
(if (not nnml-files)
(let* ((group (nnheader-file-to-group
(directory-file-name dir) nnml-directory))
@@ -873,8 +888,8 @@ Unless no-active is non-nil, update the active file too."
(defun nnml-generate-nov-file (dir files)
(let* ((dir (file-name-as-directory dir))
(nov (concat dir nnml-nov-file-name))
- (nov-buffer (get-buffer-create " *nov*"))
- chars file headers)
+ (nov-buffer (gnus-get-buffer-create " *nov*"))
+ chars headers) ;; file
(with-current-buffer nov-buffer
;; Init the nov buffer.
(buffer-disable-undo)
@@ -902,7 +917,7 @@ Unless no-active is non-nil, update the active file too."
(nnheader-insert-nov headers)))
(widen))))
(with-current-buffer nov-buffer
- (nnmail-write-region (point-min) (point-max) nov nil 'nomesg)
+ (nnmail-write-region (point-min) (point-max) nov nil 'nomesg nil 'excl)
(kill-buffer (current-buffer))))))
(defun nnml-nov-delete-article (group article)
@@ -995,7 +1010,7 @@ Use the nov database for the current group if available."
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(sort (nnml-current-group-article-to-file-alist)
- 'car-less-than-car)))
+ #'car-less-than-car)))
(if (not nnml-article-file-alist)
;; The group is empty: do nothing but return t
t
diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el
index 7d400791fa2..36a8bc4581b 100644
--- a/lisp/gnus/nnnil.el
+++ b/lisp/gnus/nnnil.el
@@ -1,4 +1,4 @@
-;;; nnnil.el --- empty backend for Gnus
+;;; nnnil.el --- empty backend for Gnus -*- lexical-binding: t; -*-
;; This file is in the public domain.
@@ -32,31 +32,31 @@
(defvar nnnil-status-string "")
-(defun nnnil-retrieve-headers (articles &optional group server fetch-old)
+(defun nnnil-retrieve-headers (_articles &optional _group _server _fetch-old)
(with-current-buffer nntp-server-buffer
(erase-buffer))
'nov)
-(defun nnnil-open-server (server &optional definitions)
+(defun nnnil-open-server (_server &optional _definitions)
t)
-(defun nnnil-close-server (&optional server)
+(defun nnnil-close-server (&optional _server)
t)
(defun nnnil-request-close ()
t)
-(defun nnnil-server-opened (&optional server)
+(defun nnnil-server-opened (&optional _server)
t)
-(defun nnnil-status-message (&optional server)
+(defun nnnil-status-message (&optional _server)
nnnil-status-string)
-(defun nnnil-request-article (article &optional group server to-buffer)
+(defun nnnil-request-article (_article &optional _group _server _to-buffer)
(setq nnnil-status-string "No such group")
nil)
-(defun nnnil-request-group (group &optional server fast info)
+(defun nnnil-request-group (_group &optional _server _fast _info)
(let (deactivate-mark)
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -64,15 +64,15 @@
(setq nnnil-status-string "No such group")
nil)
-(defun nnnil-close-group (group &optional server)
+(defun nnnil-close-group (_group &optional _server)
t)
-(defun nnnil-request-list (&optional server)
+(defun nnnil-request-list (&optional _server)
(with-current-buffer nntp-server-buffer
(erase-buffer))
t)
-(defun nnnil-request-post (&optional server)
+(defun nnnil-request-post (&optional _server)
(setq nnnil-status-string "Read-only server")
nil)
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index 9bb86d65aba..4e8490125f1 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -1,4 +1,4 @@
-;;; nnoo.el --- OO Gnus Backends
+;;; nnoo.el --- OO Gnus Backends -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -33,21 +33,26 @@
(defmacro defvoo (var init &optional doc &rest map)
"The same as `defvar', only takes list of variables to MAP to."
+ (declare (indent 2)
+ (doc-string 3)
+ (debug (var init &optional doc &rest map)))
`(prog1
,(if doc
`(defvar ,var ,init ,(concat doc "\n\nThis is a Gnus server variable. See Info node `(gnus)Select Methods'."))
`(defvar ,var ,init))
(nnoo-define ',var ',map)))
-(put 'defvoo 'lisp-indent-function 2)
-(put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map))
(defmacro deffoo (func args &rest forms)
"The same as `defun', only register FUNC."
+ (declare (indent 2)
+ (doc-string 3)
+ (debug (&define name lambda-list def-body)))
`(prog1
(defun ,func ,args ,@forms)
(nnoo-register-function ',func)))
-(put 'deffoo 'lisp-indent-function 2)
-(put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body))
+
+(defun noo--defalias (fun val)
+ (prog1 (defalias fun val) (nnoo-register-function fun)))
(defun nnoo-register-function (func)
(let ((funcs (nthcdr 3 (assoc (nnoo-backend func)
@@ -57,18 +62,18 @@
(setcar funcs (cons func (car funcs)))))
(defmacro nnoo-declare (backend &rest parents)
+ (declare (indent 1))
`(eval-and-compile
(if (assq ',backend nnoo-definition-alist)
(setcar (cdr (assq ',backend nnoo-definition-alist))
- (mapcar 'list ',parents))
+ (mapcar #'list ',parents))
(push (list ',backend
- (mapcar 'list ',parents)
+ (mapcar #'list ',parents)
nil nil)
nnoo-definition-alist))
(unless (assq ',backend nnoo-state-alist)
(push (list ',backend "*internal-non-initialized-backend*")
nnoo-state-alist))))
-(put 'nnoo-declare 'lisp-indent-function 1)
(defun nnoo-parents (backend)
(nth 1 (assoc backend nnoo-definition-alist)))
@@ -80,25 +85,19 @@
(nth 3 (assoc backend nnoo-definition-alist)))
(defmacro nnoo-import (backend &rest imports)
+ (declare (indent 1))
`(nnoo-import-1 ',backend ',imports))
-(put 'nnoo-import 'lisp-indent-function 1)
(defun nnoo-import-1 (backend imports)
(let ((call-function
- (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function))
- imp functions function)
- (while (setq imp (pop imports))
- (setq functions
- (or (cdr imp)
- (nnoo-functions (car imp))))
- (while functions
- (unless (fboundp
- (setq function
- (nnoo-symbol backend
- (nnoo-rest-symbol (car functions)))))
- (eval `(deffoo ,function (&rest args)
- (,call-function ',backend ',(car functions) args))))
- (pop functions)))))
+ (if (symbolp (car imports)) (pop imports) #'nnoo-parent-function)))
+ (dolist (imp imports)
+ (dolist (fun (or (cdr imp) (nnoo-functions (car imp))))
+ (let ((function (nnoo-symbol backend (nnoo-rest-symbol fun))))
+ (unless (fboundp function)
+ (noo--defalias function
+ (lambda (&rest args)
+ (funcall call-function backend fun args)))))))))
(defun nnoo-parent-function (backend function args)
(let ((pbackend (nnoo-backend function))
@@ -130,23 +129,22 @@
(setq vars (cdr vars)))))))
(defmacro nnoo-map-functions (backend &rest maps)
- `(nnoo-map-functions-1 ',backend ',maps))
-(put 'nnoo-map-functions 'lisp-indent-function 1)
-
-(defun nnoo-map-functions-1 (backend maps)
- (let (m margs i)
- (while (setq m (pop maps))
- (setq i 0
- margs nil)
- (while (< i (length (cdr m)))
- (if (numberp (nth i (cdr m)))
- (push `(nth ,i args) margs)
- (push (nth i (cdr m)) margs))
- (cl-incf i))
- (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
+ (declare (indent 1))
+ `(progn
+ ,@(mapcar
+ (lambda (m)
+ (let ((margs nil))
+ (dotimes (i (length (cdr m)))
+ (push (if (numberp (nth i (cdr m)))
+ `(nth ,i args)
+ (nth i (cdr m)))
+ margs))
+ `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
(&rest args)
+ (ignore args) ;; Not always used!
(nnoo-parent-function ',backend ',(car m)
- ,(cons 'list (nreverse margs))))))))
+ ,(cons 'list (nreverse margs))))))
+ maps)))
(defun nnoo-backend (symbol)
(string-match "^[^-]+-" (symbol-name symbol))
@@ -264,7 +262,7 @@
nnoo-state-alist))
t)
-(defun nnoo-status-message (backend server)
+(defun nnoo-status-message (backend _server)
(nnheader-get-report backend))
(defun nnoo-server-opened (backend server)
@@ -273,19 +271,27 @@
(defmacro nnoo-define-basics (backend)
"Define `close-server', `server-opened' and `status-message'."
- `(eval-and-compile
- (nnoo-define-basics-1 ',backend)))
-
-(defun nnoo-define-basics-1 (backend)
- (dolist (function '(server-opened status-message))
- (eval `(deffoo ,(nnoo-symbol backend function) (&optional server)
- (,(nnoo-symbol 'nnoo function) ',backend server))))
- (dolist (function '(close-server))
- (eval `(deffoo ,(nnoo-symbol backend function) (&optional server defs)
- (,(nnoo-symbol 'nnoo function) ',backend server))))
- (eval `(deffoo ,(nnoo-symbol backend 'open-server)
- (server &optional defs)
- (nnoo-change-server ',backend server defs))))
+ (let ((form
+ ;; We wrap the definitions in `when t' here so that a subsequent
+ ;; "real" definition of one those doesn't trigger a "defined multiple
+ ;; times" warning.
+ `(when t
+ ,@(mapcar (lambda (fun)
+ `(deffoo ,(nnoo-symbol backend fun) (&optional server)
+ (,(nnoo-symbol 'nnoo fun) ',backend server)))
+ '(server-opened status-message))
+ (deffoo ,(nnoo-symbol backend 'close-server) (&optional server _defs)
+ (,(nnoo-symbol 'nnoo 'close-server) ',backend server))
+ (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs)
+ (nnoo-change-server ',backend server defs)))))
+ ;; Wrapping with `when' has the downside that the compiler now doesn't
+ ;; "know" that these functions are defined, so to avoid "not known to be
+ ;; defined" warnings we eagerly define them during the compilation.
+ ;; This is fairly nasty since it will override previous "real" definitions
+ ;; (e.g. when compiling this in an Emacs instance that's running Gnus), but
+ ;; that's also what the previous code did, so it sucks but is not worse.
+ (eval form t)
+ form))
(defmacro nnoo-define-skeleton (backend)
"Define all required backend functions for BACKEND.
@@ -294,17 +300,15 @@ All functions will return nil and report an error."
(nnoo-define-skeleton-1 ',backend)))
(defun nnoo-define-skeleton-1 (backend)
- (let ((functions '(retrieve-headers
- request-close request-article
- request-group close-group
- request-list request-post request-list-newsgroups))
- function fun)
- (while (setq function (pop functions))
- (when (not (fboundp (setq fun (nnoo-symbol backend function))))
- (eval `(deffoo ,fun
- (&rest args)
- (nnheader-report ',backend ,(format "%s-%s not implemented"
- backend function))))))))
+ (dolist (op '(retrieve-headers
+ request-close request-article
+ request-group close-group
+ request-list request-post request-list-newsgroups))
+ (let ((fun (nnoo-symbol backend op)))
+ (unless (fboundp fun)
+ (let ((msg (format "%s-%s not implemented" backend op)))
+ (noo--defalias fun
+ (lambda (&rest _args) (nnheader-report backend msg))))))))
(defun nnoo-set (server &rest args)
(let ((parents (nnoo-parents (car server)))
diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el
index e78f93d829a..15e41e9d425 100644
--- a/lisp/gnus/nnregistry.el
+++ b/lisp/gnus/nnregistry.el
@@ -1,5 +1,4 @@
-;;; nnregistry.el --- access to articles via Gnus' message-id registry
-;;; -*- coding: utf-8 -*-
+;;; nnregistry.el --- access to articles via Gnus' message-id registry -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -36,21 +35,21 @@
(nnoo-declare nnregistry)
-(deffoo nnregistry-server-opened (server)
+(deffoo nnregistry-server-opened (_server)
gnus-registry-enabled)
-(deffoo nnregistry-close-server (server &optional defs)
+(deffoo nnregistry-close-server (_server &optional _defs)
t)
-(deffoo nnregistry-status-message (server)
+(deffoo nnregistry-status-message (_server)
nil)
-(deffoo nnregistry-open-server (server &optional defs)
+(deffoo nnregistry-open-server (_server &optional _defs)
gnus-registry-enabled)
(defvar nnregistry-within-nnregistry nil)
-(deffoo nnregistry-request-article (id &optional group server buffer)
+(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)))
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 8583333774c..a40fa88631f 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -1,4 +1,4 @@
-;;; nnrss.el --- interfacing with RSS
+;;; nnrss.el --- interfacing with RSS -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -100,7 +100,6 @@ Note that you have to regenerate all the nnrss groups if you change
the value. Moreover, you should be patient even if you are made to
read the same articles twice, that arises for the difference of the
versions of xml.el."
- :group 'nnrss
:type 'coding-system)
(defvar nnrss-compatible-encoding-alist
@@ -126,7 +125,7 @@ for decoding when the cdr that the data specify is not available.")
(setq group (decode-coding-string group 'utf-8))
group))
-(deffoo nnrss-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnrss-retrieve-headers (articles &optional group server _fetch-old)
(setq group (nnrss-decode-group-name group))
(nnrss-possibly-change-group group server)
(let (e)
@@ -174,7 +173,7 @@ for decoding when the cdr that the data specify is not available.")
"\n")))))
'nov)
-(deffoo nnrss-request-group (group &optional server dont-check info)
+(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)
@@ -189,7 +188,7 @@ for decoding when the cdr that the data specify is not available.")
t))
(nnheader-message 6 "nnrss: Requesting %s...done" group)))
-(deffoo nnrss-close-group (group &optional server)
+(deffoo nnrss-close-group (_group &optional _server)
t)
(deffoo nnrss-request-article (article &optional group server buffer)
@@ -201,7 +200,7 @@ for decoding when the cdr that the data specify is not available.")
(nnrss-possibly-change-group group server)
(let ((e (assq article nnrss-group-data))
(nntp-server-buffer (or buffer nntp-server-buffer))
- post err)
+ ) ;; err post
(when e
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -223,7 +222,7 @@ for decoding when the cdr that the data specify is not available.")
(cons '("Newsgroups" . utf-8)
rfc2047-header-encoding-alist)
rfc2047-header-encoding-alist))
- rfc2047-encode-encoded-words body fn)
+ rfc2047-encode-encoded-words body) ;; fn
(when (or text link enclosure comments)
(insert "\n")
(insert "<#multipart type=alternative>\n"
@@ -303,8 +302,7 @@ for decoding when the cdr that the data specify is not available.")
(when nnrss-content-function
(funcall nnrss-content-function e group article))))
(cond
- (err
- (nnheader-report 'nnrss err))
+ ;; (err (nnheader-report 'nnrss err))
((not e)
(nnheader-report 'nnrss "no such id: %d" article))
(t
@@ -312,7 +310,7 @@ for decoding when the cdr that the data specify is not available.")
;; we return the article number.
(cons nnrss-group (car e))))))
-(deffoo nnrss-open-server (server &optional defs connectionless)
+(deffoo nnrss-open-server (server &optional defs _connectionless)
(nnrss-read-server-data server)
(nnoo-change-server 'nnrss server defs)
t)
@@ -336,7 +334,7 @@ for decoding when the cdr that the data specify is not available.")
(nnrss-save-group-data group server))
not-expirable))
-(deffoo nnrss-request-delete-group (group &optional force server)
+(deffoo nnrss-request-delete-group (group &optional _force server)
(setq group (nnrss-decode-group-name group))
(nnrss-possibly-change-group group server)
(let (elem)
@@ -450,7 +448,7 @@ nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s"
(defun nnrss-normalize-date (date)
"Return a date string of DATE in the style of RFC 822 and its successors.
This function handles the ISO 8601 date format described in
-URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style
+URL `https://www.w3.org/TR/NOTE-datetime', and also the RFC 822 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
@@ -562,7 +560,7 @@ which RSS 2.0 allows."
;;; URL interface
-(defun nnrss-no-cache (url)
+(defun nnrss-no-cache (_url)
"")
(defun nnrss-insert (url)
@@ -614,7 +612,7 @@ which RSS 2.0 allows."
(defun nnrss-check-group (group server)
(let (file xml subject url extra changed author date feed-subject
- enclosure comments rss-ns rdf-ns content-ns dc-ns
+ enclosure comments rss-ns content-ns dc-ns ;; rdf-ns
hash-index)
(if (and nnrss-use-local
(file-exists-p (setq file (expand-file-name
@@ -638,7 +636,7 @@ which RSS 2.0 allows."
(setq changed t))
(setq xml (nnrss-fetch url)))
(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#")
+ ;; 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/")
content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
(dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
@@ -739,7 +737,7 @@ Read the file and attempt to subscribe to each Feed in the file."
"OPML subscription export.
Export subscriptions to a buffer in OPML Format."
(interactive)
- (with-current-buffer (get-buffer-create "*OPML Export*")
+ (with-current-buffer (gnus-get-buffer-create "*OPML Export*")
(set-buffer-file-coding-system 'utf-8)
(insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
"<!-- OPML generated by Emacs Gnus' nnrss.el -->\n"
@@ -798,7 +796,7 @@ It is useful when `(setq nnrss-use-local t)'."
(defun nnrss-node-just-text (node)
(if (and node (listp node))
- (mapconcat 'nnrss-node-just-text (cddr node) " ")
+ (mapconcat #'nnrss-node-just-text (cddr node) " ")
node))
(defun nnrss-find-el (tag data &optional found-list)
@@ -932,60 +930,7 @@ Use Mark Pilgrim's `ultra-liberal rss locator'."
(setq rss-link (nnrss-rss-title-description
rss-ns href-data (car hrefs))))
(setq hrefs (cdr hrefs)))))
- (if rss-link
- rss-link
- ;; 4. check syndic8
- (nnrss-find-rss-via-syndic8 url))))))))
-
-(declare-function xml-rpc-method-call "ext:xml-rpc"
- (server-url method &rest params))
-
-(defun nnrss-find-rss-via-syndic8 (url)
- "Query syndic8 for the rss feeds it has for URL."
- (if (not (locate-library "xml-rpc"))
- (progn
- (message "XML-RPC is not available... not checking Syndic8.")
- nil)
- (require 'xml-rpc)
- (let ((feedid (xml-rpc-method-call
- "http://www.syndic8.com/xmlrpc.php"
- 'syndic8.FindSites
- url)))
- (when feedid
- (let* ((feedinfo (xml-rpc-method-call
- "http://www.syndic8.com/xmlrpc.php"
- 'syndic8.GetFeedInfo
- feedid))
- (urllist
- (delq nil
- (mapcar
- (lambda (listinfo)
- (if (string-equal
- (cdr (assoc "status" listinfo))
- "Syndicated")
- (cons
- (cdr (assoc "sitename" listinfo))
- (list
- (cons 'title
- (cdr (assoc
- "sitename" listinfo)))
- (cons 'href
- (cdr (assoc
- "dataurl" listinfo)))))))
- feedinfo))))
- (if (not (> (length urllist) 1))
- (cdar urllist)
- (let ((completion-ignore-case t)
- (selection
- (mapcar (lambda (listinfo)
- (cons (cdr (assoc "sitename" listinfo))
- (string-to-number
- (cdr (assoc "feedid" listinfo)))))
- feedinfo)))
- (cdr (assoc
- (gnus-completing-read
- "Multiple feeds found. Select one"
- selection t) urllist)))))))))
+ rss-link))))))
(defun nnrss-rss-p (data)
"Test if DATA is an RSS feed.
@@ -1024,6 +969,11 @@ prefix), return the prefix."
(concat ns ":")
ns)))
+(defun nnrss-find-rss-via-syndic8 (_url)
+ "This function is obsolete and does nothing. Syndic8 shut down in 2013."
+ (declare (obsolete nil "28.1"))
+ nil)
+
(provide 'nnrss)
;;; nnrss.el ends here
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
new file mode 100644
index 00000000000..ecec705b326
--- /dev/null
+++ b/lisp/gnus/nnselect.el
@@ -0,0 +1,973 @@
+;;; nnselect.el --- a virtual group backend -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Andrew Cohen <cohen@andy.bu.edu>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a "virtual" backend that allows an arbitrary list of
+;; articles to be treated as a Gnus group. An nnselect group uses an
+;; `nnselect-spec' group parameter to specify this list of
+;; articles. `nnselect-spec' is an alist with two keys:
+;; `nnselect-function', whose value should be a function that returns
+;; the list of articles, and `nnselect-args'. The function will be
+;; applied to the arguments to generate the list of articles. The
+;; return value should be a vector, each element of which should in
+;; turn be a vector of three elements: a real prefixed group name, an
+;; article number in that group, and an integer score. The score is
+;; not used by nnselect but may be used by other code to help in
+;; sorting. Most functions will just choose a fixed number, such as
+;; 100, for this score.
+
+;; For example the search function `gnus-search-run-query' applied to
+;; arguments specifying a search query (see "gnus-search.el") can be
+;; used to return a list of articles from a search. Or the function
+;; can be the identity and the args a vector of articles.
+
+
+;;; Code:
+
+;;; Setup:
+
+(require 'gnus-art)
+(require 'gnus-search)
+
+(eval-when-compile (require 'cl-lib))
+
+;; Set up the backend
+
+(nnoo-declare nnselect)
+
+(nnoo-define-basics nnselect)
+
+(gnus-declare-backend "nnselect" 'post-mail 'virtual)
+
+;;; Internal Variables:
+
+(defvar gnus-inhibit-demon)
+(defvar gnus-message-group-art)
+
+;; For future use
+(defvoo nnselect-directory gnus-directory
+ "Directory for the nnselect backend.")
+
+(defvoo nnselect-active-file
+ (expand-file-name "nnselect-active" nnselect-directory)
+ "nnselect active file.")
+
+(defvoo nnselect-groups-file
+ (expand-file-name "nnselect-newsgroups" nnselect-directory)
+ "nnselect groups description file.")
+
+;;; Helper routines.
+(defun nnselect-compress-artlist (artlist)
+ "Compress ARTLIST."
+ (let (selection)
+ (pcase-dolist (`(,artgroup . ,arts)
+ (nnselect-categorize artlist #'nnselect-artitem-group))
+ (let (list)
+ (pcase-dolist (`(,rsv . ,articles)
+ (nnselect-categorize
+ arts #'nnselect-artitem-rsv #'nnselect-artitem-number))
+ (push (cons rsv (gnus-compress-sequence (sort articles #'<)))
+ list))
+ (push (cons artgroup list) selection)))
+ selection))
+
+(defun nnselect-uncompress-artlist (artlist)
+ "Uncompress ARTLIST."
+ (if (vectorp artlist)
+ artlist
+ (let (selection)
+ (pcase-dolist (`(,artgroup (,artrsv . ,artseq)) artlist)
+ (setq selection
+ (vconcat
+ (cl-map 'vector
+ (lambda (art)
+ (vector artgroup art artrsv))
+ (gnus-uncompress-sequence artseq)) selection)))
+ selection)))
+
+(make-obsolete 'nnselect-group-server 'gnus-group-server "28.1")
+
+;; Data type article list.
+
+(define-inline nnselect-artlist-length (artlist)
+ (inline-quote (length ,artlist)))
+
+(define-inline nnselect-artlist-article (artlist n)
+ "Return from ARTLIST the Nth artitem (counting starting at 1)."
+ (inline-quote (when (> ,n 0)
+ (elt ,artlist (1- ,n)))))
+
+(define-inline nnselect-artitem-group (artitem)
+ "Return the group from the ARTITEM."
+ (inline-quote (elt ,artitem 0)))
+
+(define-inline nnselect-artitem-number (artitem)
+ "Return the number from the ARTITEM."
+ (inline-quote (elt ,artitem 1)))
+
+(define-inline nnselect-artitem-rsv (artitem)
+ "Return the Retrieval Status Value (RSV, score) from the ARTITEM."
+ (inline-quote (elt ,artitem 2)))
+
+(define-inline nnselect-article-group (article)
+ "Return the group for ARTICLE."
+ (inline-quote
+ (nnselect-artitem-group (nnselect-artlist-article
+ gnus-newsgroup-selection ,article))))
+
+(define-inline nnselect-article-number (article)
+ "Return the number for ARTICLE."
+ (inline-quote (nnselect-artitem-number
+ (nnselect-artlist-article
+ gnus-newsgroup-selection ,article))))
+
+(define-inline nnselect-article-rsv (article)
+ "Return the rsv for ARTICLE."
+ (inline-quote (nnselect-artitem-rsv
+ (nnselect-artlist-article
+ gnus-newsgroup-selection ,article))))
+
+(define-inline nnselect-article-id (article)
+ "Return the pair `(nnselect id . real id)' of ARTICLE."
+ (inline-quote (cons ,article (nnselect-article-number ,article))))
+
+(define-inline nnselect-categorize (sequence keyfunc &optional valuefunc)
+ "Sorts a sequence into categories.
+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' (or `(valuefunc member)' if `valuefunc' is non-nil)."
+ (inline-letevals (sequence keyfunc valuefunc)
+ (inline-quote (let ((valuefunc (or ,valuefunc 'identity))
+ result)
+ (unless (null ,sequence)
+ (mapc
+ (lambda (member)
+ (let* ((key (funcall ,keyfunc member))
+ (value (funcall valuefunc member))
+ (kr (assoc key result)))
+ (if kr
+ (push value (cdr kr))
+ (push (list key value) result))))
+ (reverse ,sequence))
+ result)))))
+
+
+;; Unclear whether a macro or an inline function is best.
+;; (defmacro nnselect-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' (or `(valuefunc member)' if `valuefunc' is non-nil)."
+;; (let ((key (make-symbol "key"))
+;; (value (make-symbol "value"))
+;; (result (make-symbol "result"))
+;; (valuefunc (or valuefunc 'identity)))
+;; `(unless (null ,sequence)
+;; (let (,result)
+;; (mapc
+;; (lambda (member)
+;; (let* ((,key (,keyfunc member))
+;; (,value (,valuefunc member))
+;; (kr (assoc ,key ,result)))
+;; (if kr
+;; (push ,value (cdr kr))
+;; (push (list ,key ,value) ,result))))
+;; (reverse ,sequence))
+;; ,result))))
+
+(define-inline ids-by-group (articles)
+ (inline-quote
+ (nnselect-categorize ,articles #'nnselect-article-group
+ #'nnselect-article-id)))
+
+(define-inline numbers-by-group (articles &optional type)
+ (inline-quote
+ (cond
+ ((eq ,type 'range)
+ (nnselect-categorize (gnus-uncompress-range ,articles)
+ #'nnselect-article-group #'nnselect-article-number))
+ ((eq ,type 'tuple)
+ (nnselect-categorize ,articles
+ (lambda (elem)
+ (nnselect-article-group (car elem)))
+ (lambda (elem)
+ (cons (nnselect-article-number
+ (car elem))
+ (cdr elem)))))
+ (t
+ (nnselect-categorize ,articles
+ #'nnselect-article-group
+ #'nnselect-article-number)))))
+
+(defmacro nnselect-add-prefix (group)
+ "Ensures that the GROUP has an nnselect prefix."
+ `(gnus-group-prefixed-name
+ (gnus-group-short-name ,group) '(nnselect "nnselect")))
+
+(defmacro nnselect-get-artlist (group)
+ "Retrieve the list of articles for GROUP."
+ `(when (gnus-nnselect-group-p ,group)
+ (nnselect-uncompress-artlist
+ (gnus-group-get-parameter ,group 'nnselect-artlist t))))
+
+(defmacro nnselect-add-novitem (novitem)
+ "Add NOVITEM to the list of headers."
+ `(let* ((novitem ,novitem)
+ (artno (and novitem
+ (mail-header-number novitem)))
+ (art (car-safe (rassq artno artids))))
+ (when art
+ (setf (mail-header-number novitem) art)
+ (push novitem headers))))
+
+;;; User Customizable Variables:
+
+(defgroup nnselect nil
+ "Virtual groups in Gnus with arbitrary selection methods."
+ :group 'gnus)
+
+(define-obsolete-variable-alias 'nnir-retrieve-headers-override-function
+ 'nnselect-retrieve-headers-override-function "28.1")
+
+(defcustom nnselect-retrieve-headers-override-function nil
+ "A function that retrieves article headers for ARTICLES from GROUP.
+The retrieved headers should populate the `nntp-server-buffer'.
+Returns either the retrieved header format 'nov or 'headers.
+
+If this variable is nil, or if the provided function returns nil,
+ `gnus-retrieve-headers' will be called instead."
+ :version "28.1"
+ :type '(repeat function))
+
+;; Gnus backend interface functions.
+
+(deffoo nnselect-open-server (server &optional definitions)
+ ;; Just set the server variables appropriately.
+ (let ((backend (or (car (gnus-server-to-method server)) 'nnselect)))
+ (nnoo-change-server backend server definitions)))
+
+;; (deffoo nnselect-server-opened (&optional server)
+;; "Is SERVER the current virtual server?"
+;; (if (string-empty-p server)
+;; t
+;; (let ((backend (car (gnus-server-to-method server))))
+;; (nnoo-current-server-p (or backend 'nnselect) server))))
+
+(deffoo nnselect-server-opened (&optional _server)
+ t)
+
+
+(deffoo nnselect-request-group (group &optional _server _dont-check info)
+ (let* ((group (nnselect-add-prefix group))
+ (nnselect-artlist (nnselect-get-artlist group))
+ length)
+ ;; Check for cached select result or run the selection and cache
+ ;; the result.
+ (unless nnselect-artlist
+ (gnus-group-set-parameter
+ group 'nnselect-artlist
+ (nnselect-compress-artlist (setq nnselect-artlist
+ (nnselect-run
+ (gnus-group-get-parameter group 'nnselect-specs t)))))
+ (nnselect-request-update-info
+ group (or info (gnus-get-info group))))
+ (if (zerop (setq length (nnselect-artlist-length nnselect-artlist)))
+ (progn
+ (nnheader-report 'nnselect "Selection produced empty results.")
+ (when (gnus-ephemeral-group-p group)
+ (gnus-kill-ephemeral-group group)
+ (setq gnus-ephemeral-servers
+ (assq-delete-all 'nnselect gnus-ephemeral-servers)))
+ (nnheader-insert ""))
+ (with-current-buffer nntp-server-buffer
+ (nnheader-insert "211 %d %d %d %s\n"
+ length ; total #
+ 1 ; first #
+ length ; last #
+ group))) ; group name
+ nnselect-artlist))
+
+
+(deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old)
+ (let ((group (nnselect-add-prefix group)))
+ (with-current-buffer (gnus-summary-buffer-name group)
+ (setq gnus-newsgroup-selection (or gnus-newsgroup-selection
+ (nnselect-get-artlist group)))
+ (let ((gnus-inhibit-demon t)
+ (gartids (ids-by-group articles))
+ headers)
+ (with-current-buffer nntp-server-buffer
+ (pcase-dolist (`(,artgroup . ,artids) gartids)
+ (let ((artlist (sort (mapcar #'cdr artids) #'<))
+ (gnus-override-method (gnus-find-method-for-group artgroup))
+ (fetch-old
+ (or
+ (car-safe
+ (gnus-group-find-parameter artgroup
+ 'gnus-fetch-old-headers t))
+ fetch-old)))
+ (erase-buffer)
+ (pcase (setq gnus-headers-retrieved-by
+ (or
+ (and
+ nnselect-retrieve-headers-override-function
+ (funcall
+ nnselect-retrieve-headers-override-function
+ artlist artgroup))
+ (gnus-retrieve-headers
+ artlist artgroup fetch-old)))
+ ('nov
+ (goto-char (point-min))
+ (while (not (eobp))
+ (nnselect-add-novitem
+ (nnheader-parse-nov))
+ (forward-line 1)))
+ ('headers
+ (gnus-run-hooks 'gnus-parse-headers-hook)
+ (let ((nnmail-extra-headers gnus-extra-headers))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (nnselect-add-novitem
+ (nnheader-parse-head))
+ (forward-line 1))))
+ ((pred listp)
+ (dolist (novitem gnus-headers-retrieved-by)
+ (nnselect-add-novitem novitem)))
+ (_ (error "Unknown header type %s while requesting articles \
+ of group %s" gnus-headers-retrieved-by artgroup)))))
+ (setq headers
+ (sort
+ headers
+ (lambda (x y)
+ (< (mail-header-number x) (mail-header-number y))))))))))
+
+
+(deffoo nnselect-request-article (article &optional _group server to-buffer)
+ (let* ((gnus-override-method nil)
+ servers group-art artlist)
+ (if (numberp article)
+ (with-current-buffer gnus-summary-buffer
+ (unless (zerop (nnselect-artlist-length
+ gnus-newsgroup-selection))
+ (setq group-art (cons (nnselect-article-group article)
+ (nnselect-article-number article)))))
+ ;; message-id: either coming from a referral or a pseudo-article
+ ;; find the servers for a pseudo-article
+ (if (eq 'nnselect (car (gnus-server-to-method server)))
+ (with-current-buffer gnus-summary-buffer
+ (let ((thread (gnus-id-to-thread article)))
+ (when thread
+ (mapc
+ (lambda (x)
+ (when (and x (> x 0))
+ (cl-pushnew
+ (list
+ (gnus-method-to-server
+ (gnus-find-method-for-group
+ (nnselect-article-group x))))
+ servers :test 'equal)))
+ (gnus-articles-in-thread thread)))))
+ (setq servers (list (list server))))
+ (setq artlist
+ (gnus-search-run-query
+ (list
+ (cons 'search-query-spec
+ (list (cons 'query `((id . ,article)))
+ (cons 'criteria "") (cons 'shortcut t)))
+ (cons 'search-group-spec servers))))
+ (unless (zerop (nnselect-artlist-length artlist))
+ (setq
+ group-art
+ (cons
+ (nnselect-artitem-group (nnselect-artlist-article artlist 1))
+ (nnselect-artitem-number (nnselect-artlist-article artlist 1))))))
+ (when (numberp (cdr group-art))
+ (message "Requesting article %d from group %s"
+ (cdr group-art) (car group-art))
+ (if to-buffer
+ (with-current-buffer to-buffer
+ (let ((gnus-article-decode-hook nil))
+ (gnus-request-article-this-buffer
+ (cdr group-art) (car group-art))))
+ (gnus-request-article (cdr group-art) (car group-art)))
+ group-art)))
+
+
+(deffoo nnselect-request-move-article
+ (article _group _server accept-form &optional last _internal-move-group)
+ (let* ((artgroup (nnselect-article-group article))
+ (artnumber (nnselect-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 artgroup))
+ (move-is-internal (gnus-server-equal from-method to-method)))
+ (unless (gnus-check-backend-function
+ 'request-move-article artgroup)
+ (error "The group %s does not support article moving" artgroup))
+ (gnus-request-move-article
+ artnumber
+ artgroup
+ (nth 1 from-method)
+ accept-form
+ last
+ (and move-is-internal
+ to-newsgroup ; Not respooling
+ (gnus-group-real-name to-newsgroup)))))
+
+(deffoo nnselect-request-replace-article
+ (article _group buffer &optional no-encode)
+ (pcase-let ((`[,artgroup ,artnumber ,artrsv]
+ (with-current-buffer gnus-summary-buffer
+ (nnselect-artlist-article gnus-newsgroup-selection article))))
+ (unless (gnus-check-backend-function
+ 'request-replace-article artgroup)
+ (user-error "The group %s does not support article editing" artgroup))
+ (let ((newart
+ (gnus-request-replace-article artnumber artgroup buffer no-encode)))
+ (with-current-buffer gnus-summary-buffer
+ (cl-nsubstitute `[,artgroup ,newart ,artrsv]
+ `[,artgroup ,artnumber ,artrsv]
+ gnus-newsgroup-selection
+ :test #'equal :count 1)))))
+
+(deffoo nnselect-request-expire-articles
+ (articles _group &optional _server force)
+ (if force
+ (let (not-expired)
+ (pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles))
+ (let ((artlist (sort (mapcar #'cdr artids) #'<)))
+ (unless (gnus-check-backend-function 'request-expire-articles
+ artgroup)
+ (error "Group %s does not support article expiration" artgroup))
+ (unless (gnus-check-server (gnus-find-method-for-group artgroup))
+ (error "Couldn't open server for group %s" artgroup))
+ (push (mapcar (lambda (art)
+ (car (rassq art artids)))
+ (let ((nnimap-expunge 'immediately))
+ (gnus-request-expire-articles
+ artlist artgroup force)))
+ not-expired)))
+ (sort (delq nil not-expired) #'<))
+ articles))
+
+
+(deffoo nnselect-warp-to-article ()
+ (let* ((cur (if (> (gnus-summary-article-number) 0)
+ (gnus-summary-article-number)
+ (error "Can't warp to a pseudo-article")))
+ (artgroup (nnselect-article-group cur))
+ (artnumber (nnselect-article-number cur))
+ (_quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)))
+
+ ;; what should we do here? we could leave all the buffers around
+ ;; and assume that we have to exit from them one by one. or we can
+ ;; try to clean up directly
+
+ ;;first exit from the nnselect summary buffer.
+ ;;(gnus-summary-exit)
+ ;; and if the nnselect summary buffer in turn came from another
+ ;; summary buffer we have to clean that summary up too.
+ ;;(when (not (eq (cdr quit-config) 'group))
+ ;; (gnus-summary-exit))
+ (gnus-summary-read-group-1 artgroup t t nil
+ nil (list artnumber))))
+
+
+;; we pass this through to the real group in case it wants to adjust
+;; the mark. We also use this to mark an article expirable iff it is
+;; expirable in the real group.
+(deffoo nnselect-request-update-mark (_group article mark)
+ (let* ((artgroup (nnselect-article-group article))
+ (artnumber (nnselect-article-number article))
+ (gmark (gnus-request-update-mark artgroup artnumber mark)))
+ (when (and artnumber
+ (memq mark gnus-auto-expirable-marks)
+ (= mark gmark)
+ (gnus-group-auto-expirable-p artgroup))
+ (setq gmark gnus-expirable-mark))
+ gmark))
+
+
+(deffoo nnselect-request-set-mark (_group actions &optional _server)
+ (mapc
+ (lambda (request) (gnus-request-set-mark (car request) (cdr request)))
+ (nnselect-categorize
+ (cl-mapcan
+ (lambda (act)
+ (cl-destructuring-bind (range action marks) act
+ (mapcar
+ (lambda (artgroup)
+ (list (car artgroup)
+ (gnus-compress-sequence (sort (cdr artgroup) #'<))
+ action marks))
+ (numbers-by-group range 'range))))
+ actions)
+ #'car #'cdr)))
+
+(deffoo nnselect-request-update-info (group info &optional _server)
+ (let* ((group (nnselect-add-prefix group))
+ (gnus-newsgroup-selection
+ (or gnus-newsgroup-selection (nnselect-get-artlist group)))
+ newmarks)
+ (gnus-info-set-marks info nil)
+ (setf (gnus-info-read info) nil)
+ (pcase-dolist (`(,artgroup . ,nartids)
+ (ids-by-group
+ (number-sequence 1 (nnselect-artlist-length
+ gnus-newsgroup-selection))))
+ (let* ((gnus-newsgroup-active nil)
+ (artids (cl-sort nartids #'< :key 'car))
+ (group-info (gnus-get-info artgroup))
+ (marks (gnus-info-marks group-info))
+ (unread (gnus-uncompress-sequence
+ (gnus-range-difference (gnus-active artgroup)
+ (gnus-info-read group-info)))))
+ (setf (gnus-info-read info)
+ (gnus-add-to-range
+ (gnus-info-read info)
+ (delq nil (mapcar
+ (lambda (art)
+ (unless (memq (cdr art) unread) (car art)))
+ artids))))
+ (pcase-dolist (`(,type . ,mark-list) marks)
+ (let ((mark-type (gnus-article-mark-to-type type)) new)
+ (when
+ (setq new
+ (delq nil
+ (cond
+ ((eq mark-type 'tuple)
+ (mapcar
+ (lambda (id)
+ (let (mark)
+ (when
+ (setq mark (assq (cdr id) mark-list))
+ (cons (car id) (cdr mark)))))
+ artids))
+ (t
+ (setq mark-list
+ (gnus-uncompress-range mark-list))
+ (mapcar
+ (lambda (id)
+ (when (memq (cdr id) mark-list)
+ (car id))) artids)))))
+ (let ((previous (alist-get type newmarks)))
+ (if previous
+ (nconc previous new)
+ (push (cons type new) newmarks))))))))
+
+ ;; Clean up the marks: compress lists;
+ (pcase-dolist (`(,type . ,mark-list) newmarks)
+ (let ((mark-type (gnus-article-mark-to-type type)))
+ (unless (eq mark-type 'tuple)
+ (setf (alist-get type newmarks)
+ (gnus-compress-sequence mark-list)))))
+ ;; and ensure an unexist key.
+ (unless (assq 'unexist newmarks)
+ (push (cons 'unexist nil) newmarks))
+
+ (gnus-info-set-marks info newmarks)
+ (gnus-set-active group (cons 1 (nnselect-artlist-length
+ gnus-newsgroup-selection)))))
+
+
+(deffoo nnselect-request-thread (header &optional group server)
+ (with-current-buffer gnus-summary-buffer
+ (let ((group (nnselect-add-prefix group))
+ ;; find the best group for the originating article. if its a
+ ;; pseudo-article look for real articles in the same thread
+ ;; and see where they come from.
+ (artgroup (nnselect-article-group
+ (if (> (mail-header-number header) 0)
+ (mail-header-number header)
+ (if (> (gnus-summary-article-number) 0)
+ (gnus-summary-article-number)
+ (let ((thread
+ (gnus-id-to-thread (mail-header-id header))))
+ (when thread
+ (cl-some (lambda (x)
+ (when (and x (> x 0)) x))
+ (gnus-articles-in-thread thread)))))))))
+ ;; Check if search-based thread referral is permitted, and
+ ;; available.
+ (if (and gnus-refer-thread-use-search
+ (gnus-search-server-to-engine
+ (gnus-method-to-server
+ (gnus-find-method-for-group artgroup))))
+ ;; If so we perform the query, massage the result, and return
+ ;; the new headers back to the caller to incorporate into the
+ ;; current summary buffer.
+ (let* ((group-spec
+ (list (delq nil (list
+ (or server (gnus-group-server artgroup))
+ (unless gnus-refer-thread-use-search
+ artgroup)))))
+ (ids (cons (mail-header-id header)
+ (split-string
+ (or (mail-header-references header)
+ ""))))
+ (query-spec
+ (list (cons 'query (mapconcat (lambda (i)
+ (format "id:%s" i))
+ ids " or "))
+ (cons 'thread t)))
+ (last (nnselect-artlist-length gnus-newsgroup-selection))
+ (first (1+ last))
+ (new-nnselect-artlist
+ (gnus-search-run-query
+ (list (cons 'search-query-spec query-spec)
+ (cons 'search-group-spec group-spec))))
+ old-arts seq
+ headers)
+ (mapc
+ (lambda (article)
+ (if
+ (setq seq
+ (cl-position article
+ gnus-newsgroup-selection :test 'equal))
+ (push (1+ seq) old-arts)
+ (setq gnus-newsgroup-selection
+ (vconcat gnus-newsgroup-selection (vector article)))
+ (cl-incf last)))
+ new-nnselect-artlist)
+ (setq headers
+ (gnus-fetch-headers
+ (append (sort old-arts #'<)
+ (number-sequence first last))
+ nil t))
+ (gnus-group-set-parameter
+ group
+ 'nnselect-artlist
+ (nnselect-compress-artlist gnus-newsgroup-selection))
+ (when (>= last first)
+ (let (new-marks)
+ (pcase-dolist (`(,artgroup . ,artids)
+ (ids-by-group (number-sequence first last)))
+ (pcase-dolist (`(,type . ,marked)
+ (gnus-info-marks (gnus-get-info artgroup)))
+ (setq marked (gnus-uncompress-sequence marked))
+ (when (setq new-marks
+ (delq nil
+ (mapcar
+ (lambda (art)
+ (when (memq (cdr art) marked)
+ (car art)))
+ artids)))
+ (nconc
+ (symbol-value
+ (intern
+ (format "gnus-newsgroup-%s"
+ (car (rassq type gnus-article-mark-lists)))))
+ new-marks)))))
+ (setq gnus-newsgroup-active
+ (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))
+ (gnus-set-active
+ group
+ (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))
+ headers)
+ ;; If we can't or won't use search, just warp to the original
+ ;; group and punt back to gnus-summary-refer-thread.
+ (and (gnus-warp-to-article) (gnus-summary-refer-thread))))))
+
+
+(deffoo nnselect-close-group (group &optional _server)
+ (let ((group (nnselect-add-prefix group)))
+ (unless gnus-group-is-exiting-without-update-p
+ (nnselect-push-info group))
+ (setq gnus-newsgroup-selection nil)
+ (when (gnus-ephemeral-group-p group)
+ (gnus-kill-ephemeral-group group)
+ (setq gnus-ephemeral-servers
+ (assq-delete-all 'nnselect gnus-ephemeral-servers)))))
+
+
+(deffoo nnselect-request-create-group (group &optional _server args)
+ (message "Creating nnselect group %s" group)
+ (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect")))
+ (specs (assq 'nnselect-specs args))
+ (function-spec
+ (or (alist-get 'nnselect-function specs)
+ (intern (completing-read "Function: " obarray #'functionp))))
+ (args-spec
+ (or (alist-get 'nnselect-args specs)
+ (read-from-minibuffer "Args: " nil nil t nil "nil")))
+ (nnselect-specs (list (cons 'nnselect-function function-spec)
+ (cons 'nnselect-args args-spec))))
+ (gnus-group-set-parameter group 'nnselect-specs nnselect-specs)
+ (gnus-group-set-parameter
+ group 'nnselect-artlist
+ (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args)
+ (nnselect-run nnselect-specs))))
+ (nnselect-request-update-info group (gnus-get-info group)))
+ t)
+
+
+(deffoo nnselect-request-type (_group &optional article)
+ (if (and (numberp article) (> article 0))
+ (gnus-request-type
+ (nnselect-article-group article) (nnselect-article-number article))
+ 'unknown))
+
+(deffoo nnselect-request-post (&optional _server)
+ (if (not gnus-message-group-art)
+ (nnheader-report 'nnselect "Can't post to an nnselect group")
+ (gnus-request-post
+ (gnus-find-method-for-group
+ (nnselect-article-group (cdr gnus-message-group-art))))))
+
+
+(deffoo nnselect-request-rename-group (_group _new-name &optional _server)
+ t)
+
+
+(deffoo nnselect-request-scan (group _method)
+ (when (and group
+ (gnus-group-get-parameter (nnselect-add-prefix group)
+ 'nnselect-rescan t))
+ (nnselect-request-group-scan group)))
+
+
+(deffoo nnselect-request-group-scan (group &optional _server _info)
+ (let* ((group (nnselect-add-prefix group))
+ (artlist (nnselect-run
+ (gnus-group-get-parameter group 'nnselect-specs t))))
+ (gnus-set-active group (cons 1 (nnselect-artlist-length
+ artlist)))
+ (gnus-group-set-parameter
+ group 'nnselect-artlist
+ (nnselect-compress-artlist artlist))))
+
+;; Add any undefined required backend functions
+
+;; (nnoo-define-skeleton nnselect)
+
+;;; Util Code:
+
+(defun gnus-nnselect-group-p (group)
+ "Say whether GROUP is nnselect or not."
+ (or (and (gnus-group-prefixed-p group)
+ (eq 'nnselect (car (gnus-find-method-for-group group))))
+ (eq 'nnselect (car gnus-command-method))))
+
+
+(defun nnselect-run (specs)
+ "Apply nnselect-function to nnselect-args from SPECS.
+Return an article list."
+ (let ((func (alist-get 'nnselect-function specs))
+ (args (alist-get 'nnselect-args specs)))
+ (condition-case-unless-debug err
+ (funcall func args)
+ (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err)
+ []))))
+
+(defun nnselect-search-thread (header)
+ "Make an nnselect group containing the thread with article HEADER.
+The current server will be searched. If the registry is
+installed, the server that the registry reports the current
+article came from is also searched."
+ (let* ((ids (cons (mail-header-id header)
+ (split-string
+ (or (mail-header-references header)
+ ""))))
+ (query
+ (list (cons 'query (mapconcat (lambda (i)
+ (format "id:%s" i))
+ ids " or "))
+ (cons 'thread t)))
+ (server
+ (list (list (gnus-method-to-server
+ (gnus-find-method-for-group gnus-newsgroup-name)))))
+ (registry-group (and
+ (bound-and-true-p gnus-registry-enabled)
+ (car (gnus-registry-get-id-key
+ (mail-header-id header) 'group))))
+ (registry-server
+ (and registry-group
+ (gnus-method-to-server
+ (gnus-find-method-for-group registry-group)))))
+ (when registry-server (cl-pushnew (list registry-server) server
+ :test 'equal))
+ (gnus-group-read-ephemeral-group
+ (concat "nnselect-" (message-unique-id))
+ (list 'nnselect "nnselect")
+ nil
+ (cons (current-buffer) gnus-current-window-configuration)
+ ; nil
+ nil nil
+ (list
+ (cons 'nnselect-specs
+ (list
+ (cons 'nnselect-function 'gnus-search-run-query)
+ (cons 'nnselect-args
+ (list (cons 'search-query-spec query)
+ (cons 'search-group-spec server)))))
+ (cons 'nnselect-artlist nil)))
+ (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
+
+
+
+(defun nnselect-push-info (group)
+ "Copy mark-lists from GROUP to the originating groups."
+ (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads))
+ (select-reads (numbers-by-group
+ (gnus-info-read (gnus-get-info group)) 'range))
+ (select-unseen (numbers-by-group gnus-newsgroup-unseen))
+ (gnus-newsgroup-active nil) mark-list)
+ ;; collect the set of marked article lists categorized by
+ ;; originating groups
+ (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists)
+ (let (type-list)
+ (when (setq type-list
+ (symbol-value (intern (format "gnus-newsgroup-%s" mark))))
+ (push (cons
+ type
+ (numbers-by-group type-list (gnus-article-mark-to-type type)))
+ mark-list))))
+ ;; now work on each originating group one at a time
+ (pcase-dolist (`(,artgroup . ,artlist)
+ (numbers-by-group gnus-newsgroup-articles))
+ (let* ((group-info (gnus-get-info artgroup))
+ (old-unread (gnus-list-of-unread-articles artgroup))
+ newmarked delta-marks)
+ (when group-info
+ ;; iterate over mark lists for this group
+ (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists)
+ (let ((list (cdr (assoc artgroup (alist-get type mark-list))))
+ (mark-type (gnus-article-mark-to-type type)))
+
+ ;; When the backend can store marks we collect any
+ ;; changes. Unlike a normal group the mark lists only
+ ;; include marks for articles we retrieved.
+ (when (and (gnus-check-backend-function
+ 'request-set-mark artgroup)
+ (not (gnus-article-unpropagatable-p type)))
+ (let* ((old (gnus-list-range-intersection
+ artlist
+ (alist-get type (gnus-info-marks group-info))))
+ (del (gnus-remove-from-range (copy-tree old) list))
+ (add (gnus-remove-from-range (copy-tree list) old)))
+ (when add (push (list add 'add (list 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 artgroup) del))
+ (push (list del 'del (list type)) delta-marks))))
+
+ ;; Marked sets are of mark-type 'tuple, 'list, or
+ ;; 'range. We merge the lists with what is already in
+ ;; the original info to get full list of new marks. We
+ ;; do this by removing all the articles we retrieved
+ ;; from the full list, and then add back in the newly
+ ;; marked ones.
+ (cond
+ ((eq mark-type 'tuple)
+ ;; Get rid of the entries that have the default
+ ;; score.
+ (when (and list (eq type 'score) gnus-save-score)
+ (let* ((arts list)
+ (prev (cons nil list))
+ (all prev))
+ (while arts
+ (if (or (not (consp (car arts)))
+ (= (cdar arts) gnus-summary-default-score))
+ (setcdr prev (cdr arts))
+ (setq prev arts))
+ (setq arts (cdr arts)))
+ (setq list (cdr all))))
+ ;; now merge with the original list and sort just to
+ ;; make sure
+ (setq list
+ (sort (map-merge
+ 'list list
+ (alist-get type (gnus-info-marks group-info)))
+ (lambda (elt1 elt2)
+ (< (car elt1) (car elt2))))))
+ (t
+ (setq list
+ (gnus-compress-sequence
+ (gnus-sorted-union
+ (gnus-sorted-difference
+ (gnus-uncompress-sequence
+ (alist-get type (gnus-info-marks group-info)))
+ artlist)
+ (sort list #'<)) t)))
+
+ ;; When exiting the group, everything that's previously been
+ ;; unseen is now seen.
+ (when (eq type 'seen)
+ (setq list (gnus-range-add
+ list (cdr (assoc artgroup select-unseen))))))
+
+ (when (or list (eq type 'unexist))
+ (push (cons type list) newmarked)))) ;; end of mark-type loop
+
+ (when delta-marks
+ (unless (gnus-check-group artgroup)
+ (error "Can't open server for %s" artgroup))
+ (gnus-request-set-mark artgroup delta-marks))
+
+ (gnus-atomic-progn
+ (gnus-info-set-marks group-info newmarked)
+ ;; Cut off the end of the info if there's nothing else there.
+ (let ((i 5))
+ (while (and (> i 2)
+ (not (nth i group-info)))
+ (when (nthcdr (cl-decf i) group-info)
+ (setcdr (nthcdr i group-info) nil))))
+
+ ;; update read and unread
+ (gnus-update-read-articles
+ artgroup
+ (gnus-uncompress-range
+ (gnus-add-to-range
+ (gnus-remove-from-range
+ old-unread
+ (cdr (assoc artgroup select-reads)))
+ (sort (cdr (assoc artgroup select-unreads)) #'<))))
+ (gnus-get-unread-articles-in-group
+ group-info (gnus-active artgroup) t)
+ (gnus-group-update-group artgroup t t)))))))
+
+
+(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
+
+(defun gnus-summary-make-search-group (no-parse)
+ "Search a group from the summary buffer.
+Pass NO-PARSE on to the search engine."
+ (interactive "P")
+ (gnus-warp-to-article)
+ (let ((spec
+ (list
+ (cons 'search-group-spec
+ (list (list
+ (gnus-group-server gnus-newsgroup-name)
+ gnus-newsgroup-name))))))
+ (gnus-group-make-search-group no-parse spec)))
+
+
+(provide 'nnselect)
+
+;;; nnselect.el ends here
diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el
index b90fe3d9434..ce9ab3c53c1 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -1,4 +1,4 @@
-;;; nnspool.el --- spool access for GNU Emacs
+;;; nnspool.el --- spool access for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1988-1990, 1993-1998, 2000-2021 Free Software
;; Foundation, Inc.
@@ -126,7 +126,7 @@ there.")
(nnoo-define-basics nnspool)
-(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnspool-retrieve-headers (articles &optional group _server fetch-old)
"Retrieve the headers of ARTICLES."
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -203,7 +203,7 @@ there.")
server nnspool-spool-directory)
t)))
-(deffoo nnspool-request-article (id &optional group server buffer)
+(deffoo nnspool-request-article (id &optional group _server buffer)
"Select article by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((nntp-server-buffer (or buffer nntp-server-buffer))
@@ -222,7 +222,7 @@ there.")
(cons nnspool-current-group id)
ag))))
-(deffoo nnspool-request-body (id &optional group server)
+(deffoo nnspool-request-body (id &optional group _server)
"Select article body by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
@@ -233,7 +233,7 @@ there.")
(delete-region (point-min) (point)))
res))))
-(deffoo nnspool-request-head (id &optional group server)
+(deffoo nnspool-request-head (id &optional group _server)
"Select article head by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
@@ -245,7 +245,7 @@ there.")
(nnheader-fold-continuation-lines)))
res))
-(deffoo nnspool-request-group (group &optional server dont-check info)
+(deffoo nnspool-request-group (group &optional _server dont-check _info)
"Select news GROUP."
(let ((pathname (nnspool-article-pathname group))
dir)
@@ -261,7 +261,7 @@ there.")
;; Yes, completely empty spool directories *are* possible.
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
(when (setq dir (directory-files pathname nil "\\`[0-9]+\\'" t))
- (setq dir (sort (mapcar 'string-to-number dir) '<)))
+ (setq dir (sort (mapcar #'string-to-number dir) #'<)))
(if dir
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
@@ -269,26 +269,26 @@ there.")
(nnheader-report 'nnspool "Empty group %s" group)
(nnheader-insert "211 0 0 0 %s\n" group))))))
-(deffoo nnspool-request-type (group &optional article)
+(deffoo nnspool-request-type (_group &optional _article)
'news)
-(deffoo nnspool-close-group (group &optional server)
+(deffoo nnspool-close-group (_group &optional _server)
t)
-(deffoo nnspool-request-list (&optional server)
+(deffoo nnspool-request-list (&optional _server)
"List active newsgroups."
(save-excursion
(or (nnspool-find-file nnspool-active-file)
(nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
-(deffoo nnspool-request-list-newsgroups (&optional server)
+(deffoo nnspool-request-list-newsgroups (&optional _server)
"List newsgroups (defined in NNTP2)."
(save-excursion
(or (nnspool-find-file nnspool-newsgroups-file)
(nnheader-report 'nnspool (nnheader-file-error
nnspool-newsgroups-file)))))
-(deffoo nnspool-request-list-distributions (&optional server)
+(deffoo nnspool-request-list-distributions (&optional _server)
"List distributions (defined in NNTP2)."
(save-excursion
(or (nnspool-find-file nnspool-distributions-file)
@@ -296,7 +296,7 @@ there.")
nnspool-distributions-file)))))
;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
-(deffoo nnspool-request-newgroups (date &optional server)
+(deffoo nnspool-request-newgroups (date &optional _server)
"List groups created after DATE."
(if (nnspool-find-file nnspool-active-times-file)
(save-excursion
@@ -323,7 +323,7 @@ there.")
t)
nil))
-(deffoo nnspool-request-post (&optional server)
+(deffoo nnspool-request-post (&optional _server)
"Post a new news in current buffer."
(save-excursion
(let* ((process-connection-type nil) ; t bugs out on Solaris
@@ -331,7 +331,7 @@ there.")
(buf (current-buffer))
(proc
(condition-case err
- (apply 'start-process "*nnspool inews*" inews-buffer
+ (apply #'start-process "*nnspool inews*" inews-buffer
nnspool-inews-program nnspool-inews-switches)
(error
(nnheader-report 'nnspool "inews error: %S" err)))))
@@ -356,7 +356,7 @@ there.")
;;; Internal functions.
-(defun nnspool-inews-sentinel (proc status)
+(defun nnspool-inews-sentinel (proc _status)
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
(if (or (zerop (buffer-size))
@@ -409,7 +409,7 @@ there.")
(<= last (car arts)))
(pop arts))
;; The articles in `arts' are missing from the buffer.
- (mapc 'nnspool-insert-nov-head arts)
+ (mapc #'nnspool-insert-nov-head arts)
t))))))))))
(defun nnspool-insert-nov-head (article)
@@ -422,7 +422,7 @@ there.")
(nnspool-article-pathname nnspool-current-group article))
(nnheader-insert-article-line article)
(goto-char (point-min))
- (let ((headers (nnheader-parse-head)))
+ (let ((headers (nnheader-parse-head nil t)))
(set-buffer cur)
(goto-char (point-max))
(nnheader-insert-nov headers)))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index ff3b2ac8f55..1fd2ed06eba 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -233,7 +233,7 @@ server there that you can connect to. See also
(const :format "" "password")
(string :format "Password: %v")))))))
-(make-obsolete 'nntp-authinfo-file nil "Emacs 24.1")
+(make-obsolete 'nntp-authinfo-file nil "24.1")
@@ -309,7 +309,7 @@ backend doesn't catch this error.")
(defun nntp-record-command (string)
"Record the command STRING."
- (with-current-buffer (get-buffer-create "*nntp-log*")
+ (with-current-buffer (gnus-get-buffer-create "*nntp-log*")
(goto-char (point-max))
(insert (format-time-string "%Y%m%dT%H%M%S.%3N")
" " nntp-address " " string "\n")))
@@ -335,16 +335,16 @@ retried once before actually displaying the error report."
(apply #'error args)))
-(defmacro nntp-copy-to-buffer (buffer start end)
+(defsubst nntp-copy-to-buffer (buffer start end)
"Copy string from unibyte current buffer to multibyte buffer."
- `(let ((string (buffer-substring ,start ,end)))
- (with-current-buffer ,buffer
+ (let ((string (buffer-substring start end)))
+ (with-current-buffer buffer
(erase-buffer)
(insert string)
(goto-char (point-min))
nil)))
-(defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
+(defun nntp-wait-for (process wait-for buffer &optional decode discard)
"Wait for WAIT-FOR to arrive from PROCESS."
(with-current-buffer (process-buffer process)
@@ -436,7 +436,7 @@ retried once before actually displaying the error report."
(when process
(process-buffer process))))
-(defsubst nntp-retrieve-data (command address _port buffer
+(defun nntp-retrieve-data (command address _port buffer
&optional wait-for callback decode)
"Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
(let ((process (or (nntp-find-connection buffer)
@@ -469,7 +469,7 @@ retried once before actually displaying the error report."
nil)))
(nnheader-report 'nntp "Couldn't open connection to %s" address))))
-(defsubst nntp-send-command (wait-for &rest strings)
+(defun nntp-send-command (wait-for &rest strings)
"Send STRINGS to server and wait until WAIT-FOR returns."
(when (not (or nnheader-callback-function
nntp-inhibit-output))
@@ -600,7 +600,7 @@ retried once before actually displaying the error report."
nil)))
(defun nntp-with-open-group-function (group server connectionless bodyfun)
- "Protect against servers that don't like clients that keep idle connections opens.
+ "Protect against servers that don't like clients that keep idle connections open.
The problem being that these servers may either close a connection or
simply ignore any further requests on a connection. Closed
connections are not detected until `accept-process-output' has updated
@@ -651,7 +651,7 @@ command whose response triggered the error."
nntp-with-open-group-internal))
(defmacro nntp-with-open-group (group server &optional connectionless &rest forms)
- "Protect against servers that don't like clients that keep idle connections opens.
+ "Protect against servers that don't like clients that keep idle connections open.
The problem being that these servers may either close a connection or
simply ignore any further requests on a connection. Closed
connections are not detected until `accept-process-output' has updated
@@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(read-passwd (format "NNTP (%s@%s) password: "
user nntp-address)))))))
(if (not result)
- (signal 'nntp-authinfo-rejected "Password rejected")
+ (error "Password rejected")
result))))))
;;; Internal functions.
@@ -1247,8 +1247,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(and nntp-connection-timeout
(run-at-time
nntp-connection-timeout nil
- `(lambda ()
- (nntp-kill-buffer ,pbuffer)))))
+ (lambda ()
+ (nntp-kill-buffer pbuffer)))))
(process
(condition-case err
(let ((coding-system-for-read 'binary)
@@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the
"nntpd" pbuffer nntp-address nntp-port-number
:type (cadr (assoc nntp-open-connection-function map))
:end-of-command "^\\([2345]\\|[.]\\).*\n"
- :capability-command "HELP\r\n"
+ :capability-command
+ (lambda (greeting)
+ (if (and greeting
+ (string-match "Typhoon" greeting))
+ ;; Certain versions of the Typhoon server
+ ;; doesn't understand the CAPABILITIES
+ ;; command, but includes the capability
+ ;; data in the HELP command instead.
+ "HELP\r\n"
+ ;; Use the correct command for everything else.
+ "CAPABILITIES\r\n"))
:success "^3"
:starttls-function
(lambda (capabilities)
@@ -1320,7 +1330,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(dolist (entry nntp-server-action-alist)
(when (string-match (car entry) nntp-server-type)
(if (not (functionp (cadr entry)))
- (eval (cadr entry))
+ (eval (cadr entry) t)
(funcall (cadr entry)))))))
(defun nntp-async-wait (process wait-for buffer decode callback)
@@ -1741,7 +1751,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the
;; ==========================================================================
(defvoo nntp-open-telnet-envuser nil
- "If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
+ "If non-nil, telnet session supports the ENVIRON option.
+Don't prompt for login name. This applies to both client and server.")
(defvoo nntp-telnet-shell-prompt "bash\\|[$>] *\r?$"
"Regular expression to match the shell prompt on the remote machine.")
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 2bd4c2d657e..03a0ff296f2 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -1,4 +1,4 @@
-;;; nnvirtual.el --- virtual newsgroups access for Gnus
+;;; nnvirtual.el --- virtual newsgroups access for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
@@ -61,22 +61,27 @@ component group will show up when you enter the virtual group.")
(defvoo nnvirtual-current-group nil)
(defvoo nnvirtual-mapping-table nil
- "Table of rules on how to map between component group and article number to virtual article number.")
+ "Table of rules for mapping groups and articles to virtual article numbers.
+These rules determine how to map between component group and article number
+on the one hand, and virtual article number on the other hand.")
(defvoo nnvirtual-mapping-offsets nil
- "Table indexed by component group to an offset to be applied to article numbers in that group.")
+ "Table of mapping offsets to be applied to article numbers in a group.
+The table is indexed by component group number of the group.")
(defvoo nnvirtual-mapping-len 0
"Number of articles in this virtual group.")
(defvoo nnvirtual-mapping-reads nil
- "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.")
+ "Compressed sequence of read articles on the virtual group.
+It is computed from the unread status of individual component groups.")
(defvoo nnvirtual-mapping-marks nil
- "Compressed marks alist for the virtual group as computed from the marks of individual component groups.")
+ "Compressed marks alist for the virtual group.
+It is computed from the marks of individual component groups.")
(defvoo nnvirtual-info-installed nil
- "T if we have already installed the group info for this group, and shouldn't blast over it again.")
+ "t if the group info for this group is already installed.")
(defvoo nnvirtual-status-string "")
@@ -89,15 +94,15 @@ component group will show up when you enter the virtual group.")
(nnoo-define-basics nnvirtual)
-(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
- server fetch-old)
+(deffoo nnvirtual-retrieve-headers (articles &optional _newsgroup
+ server _fetch-old)
(when (nnvirtual-possibly-change-server server)
(with-current-buffer nntp-server-buffer
(erase-buffer)
(if (stringp (car articles))
'headers
(let ((vbuf (nnheader-set-temp-buffer
- (get-buffer-create " *virtual headers*")))
+ (gnus-get-buffer-create " *virtual headers*")))
(carticles (nnvirtual-partition-sequence articles))
(sysname (system-name))
cgroup carticle article result prefix)
@@ -181,7 +186,7 @@ component group will show up when you enter the virtual group.")
(defvoo nnvirtual-last-accessed-component-group nil)
-(deffoo nnvirtual-request-article (article &optional group server buffer)
+(deffoo nnvirtual-request-article (article &optional _group server buffer)
(when (nnvirtual-possibly-change-server server)
(if (stringp article)
;; This is a fetch by Message-ID.
@@ -245,7 +250,7 @@ component group will show up when you enter the virtual group.")
t)))
-(deffoo nnvirtual-request-group (group &optional server dont-check info)
+(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))
@@ -264,7 +269,7 @@ component group will show up when you enter the virtual group.")
nnvirtual-mapping-len nnvirtual-mapping-len group))))
-(deffoo nnvirtual-request-type (group &optional article)
+(deffoo nnvirtual-request-type (_group &optional article)
(if (not article)
'unknown
(if (numberp article)
@@ -274,7 +279,7 @@ component group will show up when you enter the virtual group.")
(gnus-request-type
nnvirtual-last-accessed-component-group nil))))
-(deffoo nnvirtual-request-update-mark (group article mark)
+(deffoo nnvirtual-request-update-mark (_group article mark)
(let* ((nart (nnvirtual-map-article article))
(cgroup (car nart)))
(when (and nart
@@ -286,22 +291,22 @@ component group will show up when you enter the virtual group.")
mark)
-(deffoo nnvirtual-close-group (group &optional server)
+(deffoo nnvirtual-close-group (_group &optional server)
(when (and (nnvirtual-possibly-change-server server)
(not (gnus-ephemeral-group-p (nnvirtual-current-group))))
(nnvirtual-update-read-and-marked t t))
t)
-(deffoo nnvirtual-request-newgroups (date &optional server)
+(deffoo nnvirtual-request-newgroups (_date &optional _server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
-(deffoo nnvirtual-request-list-newsgroups (&optional server)
+(deffoo nnvirtual-request-list-newsgroups (&optional _server)
(nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
-(deffoo nnvirtual-request-update-info (group info &optional server)
+(deffoo nnvirtual-request-update-info (_group info &optional server)
(when (and (nnvirtual-possibly-change-server server)
(not nnvirtual-info-installed))
;; Install the precomputed lists atomically, so the virtual group
@@ -316,7 +321,7 @@ component group will show up when you enter the virtual group.")
t))
-(deffoo nnvirtual-catchup-group (group &optional server all)
+(deffoo nnvirtual-catchup-group (_group &optional server all)
(when (and (nnvirtual-possibly-change-server server)
(not (gnus-ephemeral-group-p (nnvirtual-current-group))))
;; copy over existing marks first, in case they set anything
@@ -334,12 +339,12 @@ component group will show up when you enter the virtual group.")
(gnus-group-catchup-current nil all)))))
-(deffoo nnvirtual-find-group-art (group article)
+(deffoo nnvirtual-find-group-art (_group article)
"Return the real group and article for virtual GROUP and ARTICLE."
(nnvirtual-map-article article))
-(deffoo nnvirtual-request-post (&optional server)
+(deffoo nnvirtual-request-post (&optional _server)
(if (not gnus-message-group-art)
(nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
(let ((group (car (nnvirtual-find-group-art
@@ -348,8 +353,8 @@ component group will show up when you enter the virtual group.")
(gnus-request-post (gnus-find-method-for-group group)))))
-(deffoo nnvirtual-request-expire-articles (articles group
- &optional server force)
+(deffoo nnvirtual-request-expire-articles ( _articles _group
+ &optional server _force)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
@@ -357,12 +362,12 @@ component group will show up when you enter the virtual group.")
(dolist (group nnvirtual-component-groups)
(setq unexpired (nconc unexpired
(mapcar
- #'(lambda (article)
- (nnvirtual-reverse-map-article
- group article))
+ (lambda (article)
+ (nnvirtual-reverse-map-article
+ group article))
(gnus-uncompress-range
(gnus-group-expire-articles-1 group))))))
- (sort (delq nil unexpired) '<)))
+ (sort (delq nil unexpired) #'<)))
;;; Internal functions.
@@ -373,7 +378,7 @@ component group will show up when you enter the virtual group.")
(let* ((dependencies (make-hash-table :test #'equal))
(headers (gnus-get-newsgroup-headers dependencies)))
(erase-buffer)
- (mapc 'nnheader-insert-nov headers))))
+ (mapc #'nnheader-insert-nov headers))))
(defun nnvirtual-update-xref-header (group article prefix sysname)
@@ -497,7 +502,7 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components."
"Merge many sorted lists of numbers."
(if (null (cdr lists))
(car lists)
- (sort (apply 'nconc lists) '<)))
+ (sort (apply #'nconc lists) #'<)))
;; We map between virtual articles and real articles in a manner
@@ -643,7 +648,7 @@ numbers has no corresponding component article, then it is left out of
the result."
(when (numberp (cdr-safe articles))
(setq articles (list articles)))
- (let ((carticles (mapcar 'list nnvirtual-component-groups))
+ (let ((carticles (mapcar #'list nnvirtual-component-groups))
a i j article entry)
(while (setq a (pop articles))
(if (atom a)
@@ -662,7 +667,7 @@ the result."
(defun nnvirtual-create-mapping (dont-check)
- "Build the tables necessary to map between component (group, article) to virtual article.
+ "Build tables 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."
(let ((cnt 0)
@@ -745,7 +750,7 @@ based on the marks on the component groups."
;; Now that the mapping tables are generated, we can convert
;; and combine the separate component unreads and marks lists
;; into single lists of virtual article numbers.
- (setq unreads (apply 'nnvirtual-merge-sorted-lists
+ (setq unreads (apply #'nnvirtual-merge-sorted-lists
(mapcar (lambda (x)
(nnvirtual-reverse-map-sequence
(car x) (cdr x)))
@@ -755,7 +760,7 @@ based on the marks on the component groups."
(cons (cdr type)
(gnus-compress-sequence
(apply
- 'nnvirtual-merge-sorted-lists
+ #'nnvirtual-merge-sorted-lists
(mapcar (lambda (x)
(nnvirtual-reverse-map-sequence
(car x)
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index b8fb4a8373a..f08dc47e313 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -1,4 +1,4 @@
-;;; nnweb.el --- retrieving articles via web search engines
+;;; nnweb.el --- retrieving articles via web search engines -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -96,7 +96,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnoo-define-basics nnweb)
-(deffoo nnweb-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnweb-retrieve-headers (articles &optional group server _fetch-old)
(nnweb-possibly-change-server group server)
(with-current-buffer nntp-server-buffer
(erase-buffer)
@@ -117,7 +117,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnweb-write-active)
(nnweb-write-overview group)))
-(deffoo nnweb-request-group (group &optional server dont-check info)
+(deffoo nnweb-request-group (group &optional server dont-check _info)
(nnweb-possibly-change-server group server)
(unless (or nnweb-ephemeral-p
dont-check
@@ -154,17 +154,17 @@ Valid types include `google', `dejanews', and `gmane'.")
(and (stringp article)
(nnweb-definition 'id t)
(let ((fetch (nnweb-definition 'id))
- art active)
- (when (string-match "^<\\(.*\\)>$" article)
- (setq art (match-string 1 article)))
+ (art (when (string-match "^<\\(.*\\)>$" article)
+ (match-string 1 article)))
+ ) ;; active
(when (and fetch art)
(setq url (format fetch
(mm-url-form-encode-xwfu art)))
(mm-url-insert url)
(if (nnweb-definition 'reference t)
(setq article
- (funcall (nnweb-definition
- 'reference) article)))))))
+ (funcall (nnweb-definition 'reference)
+ article)))))))
(unless nnheader-callback-function
(funcall (nnweb-definition 'article)))
(nnheader-report 'nnweb "Fetched article %s" article)
@@ -184,19 +184,19 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnmail-generate-active (list (assoc server nnweb-group-alist)))
t))
-(deffoo nnweb-request-update-info (group info &optional server))
+(deffoo nnweb-request-update-info (_group _info &optional _server))
(deffoo nnweb-asynchronous-p ()
nil)
-(deffoo nnweb-request-create-group (group &optional server args)
+(deffoo nnweb-request-create-group (group &optional server _args)
(nnweb-possibly-change-server nil server)
(nnweb-request-delete-group group)
(push `(,group ,(cons 1 0)) nnweb-group-alist)
(nnweb-write-active)
t)
-(deffoo nnweb-request-delete-group (group &optional force server)
+(deffoo nnweb-request-delete-group (group &optional _force server)
(nnweb-possibly-change-server group server)
(gnus-alist-pull group nnweb-group-alist t)
(nnweb-write-active)
@@ -317,7 +317,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(let ((i 0)
(case-fold-search t)
(active (cadr (assoc nnweb-group nnweb-group-alist)))
- Subject Score Date Newsgroups From
+ Subject Date Newsgroups From
map url mid)
(unless active
(push (list nnweb-group (setq active (cons 1 0)))
@@ -411,7 +411,7 @@ Valid types include `google', `dejanews', and `gmane'.")
;; Return the articles in the right order.
(nnheader-message 7 "Searching google...done")
(setq nnweb-articles
- (sort nnweb-articles 'car-less-than-car))))))
+ (sort nnweb-articles #'car-less-than-car))))))
(defun nnweb-google-search (search)
(mm-url-insert
@@ -481,7 +481,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(forward-line 1)))
(nnheader-message 7 "Searching Gmane...done")
(setq nnweb-articles
- (sort (nconc nnweb-articles map) 'car-less-than-car)))))
+ (sort (nconc nnweb-articles map) #'car-less-than-car)))))
(defun nnweb-gmane-wash-article ()
(let ((case-fold-search t))
@@ -534,7 +534,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(nth 1 parse)
" "))
(insert ">\n")
- (mapc 'nnweb-insert-html (nth 2 parse))
+ (mapc #'nnweb-insert-html (nth 2 parse))
(insert "</" (symbol-name (car parse)) ">\n")))
(defun nnweb-parse-find (type parse &optional maxdepth)
diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el
index b8726c03c3e..51408618904 100644
--- a/lisp/gnus/score-mode.el
+++ b/lisp/gnus/score-mode.el
@@ -1,4 +1,4 @@
-;;; score-mode.el --- mode for editing Gnus score files
+;;; score-mode.el --- mode for editing Gnus score files -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -83,12 +83,12 @@ This mode is an extended emacs-lisp mode.
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
- (interactive)
+ (interactive nil gnus-score-mode)
(princ (time-to-days nil) (current-buffer)))
(defun gnus-score-pretty-print ()
"Format the current score file."
- (interactive)
+ (interactive nil gnus-score-mode)
(goto-char (point-min))
(let ((form (read (current-buffer))))
(erase-buffer)
@@ -98,7 +98,7 @@ This mode is an extended emacs-lisp mode.
(defun gnus-score-edit-exit ()
"Stop editing the score file."
- (interactive)
+ (interactive nil gnus-score-mode)
(unless (file-exists-p (file-name-directory (buffer-file-name)))
(make-directory (file-name-directory (buffer-file-name)) t))
(let ((coding-system-for-write score-mode-coding-system))
diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el
index 573acbc4cd6..32283af52bf 100644
--- a/lisp/gnus/smiley.el
+++ b/lisp/gnus/smiley.el
@@ -1,4 +1,4 @@
-;;; smiley.el --- displaying smiley faces
+;;; smiley.el --- displaying smiley faces -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -44,6 +44,7 @@
;; cry ;-(
;; dead X-)
;; grin :-D
+;; halo O:-)
;;; Code:
@@ -56,25 +57,22 @@
(defvar smiley-data-directory)
-(defcustom smiley-style
- (if (and (fboundp 'face-attribute)
- ;; In batch mode, attributes can be unspecified.
- (condition-case nil
- (>= (face-attribute 'default :height) 160)
- (error nil)))
- 'medium
- 'low-color)
+;; In batch mode, attributes can be unspecified.
+(defcustom smiley-style (if (ignore-errors
+ (>= (face-attribute 'default :height) 160))
+ 'medium
+ 'low-color)
"Smiley style."
:type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14
(const :tag "medium, ~10 colors" medium) ;; 16x16
- (const :tag "dull, grayscale" grayscale)) ;; 14x14
+ (const :tag "dull, grayscale" grayscale) ;; 14x14
+ (const :tag "emoji, full color" emoji))
:set (lambda (symbol value)
(set-default symbol value)
(setq smiley-data-directory (smiley-directory))
(smiley-update-cache))
- :initialize 'custom-initialize-default
- :version "23.1" ;; No Gnus
- :group 'smiley)
+ :initialize #'custom-initialize-default
+ :version "23.1") ;; No Gnus
;; For compatibility, honor the variable `smiley-data-directory' if the user
;; has set it.
@@ -95,9 +93,36 @@ is nil, use `smiley-style'."
:set (lambda (symbol value)
(set-default symbol value)
(smiley-update-cache))
- :initialize 'custom-initialize-default
- :type 'directory
- :group 'smiley)
+ :initialize #'custom-initialize-default
+ :type 'directory)
+
+(defcustom smiley-emoji-regexp-alist
+ '(("\\(;-)\\)\\W" 1 "😉")
+ ("[^;]\\(;)\\)\\W" 1 "😉")
+ ("\\(:-]\\)\\W" 1 "😬")
+ ("\\(8-)\\)\\W" 1 "🥴")
+ ("\\(:-|\\)\\W" 1 "ðŸ˜")
+ ("\\(:-[/\\]\\)\\W" 1 "😕")
+ ("\\(:-(\\)\\W" 1 "😠")
+ ("\\(X-)\\)\\W" 1 "😵") ; 💀
+ ("\\(:-{\\)\\W" 1 "😦")
+ ("\\(>:-)\\)\\W" 1 "😈")
+ ("\\(;-(\\)\\W" 1 "😢")
+ ("\\(:-D\\)\\W" 1 "😀")
+ ("\\(O:-)\\)\\W" 1 "😇")
+ ;; "smile" must be come after "evil"
+ ("\\(\\^?:-?)\\)\\W" 1 "🙂"))
+ "A list of regexps to map smilies to emoji.
+The elements are (REGEXP MATCH EMOJI), where MATCH is the submatch in
+regexp to replace with EMOJI."
+ :version "28.1"
+ :type '(repeat (list regexp
+ (integer :tag "Regexp match number")
+ (string :tag "Emoji")))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (smiley-update-cache))
+ :initialize #'custom-initialize-default)
;; The XEmacs version has a baroque, if not rococo, set of these.
(defcustom smiley-regexp-alist
@@ -126,8 +151,7 @@ regexp to replace with IMAGE. IMAGE is the name of an image file in
:set (lambda (symbol value)
(set-default symbol value)
(smiley-update-cache))
- :initialize 'custom-initialize-default
- :group 'smiley)
+ :initialize #'custom-initialize-default)
(defcustom gnus-smiley-file-types
(let ((types (list "pbm")))
@@ -138,30 +162,31 @@ regexp to replace with IMAGE. IMAGE is the name of an image file in
types)
"List of suffixes on smiley file names to try."
:version "24.1"
- :type '(repeat string)
- :group 'smiley)
+ :type '(repeat string))
(defvar smiley-cached-regexp-alist nil)
(defun smiley-update-cache ()
(setq smiley-cached-regexp-alist nil)
- (dolist (elt (if (symbolp smiley-regexp-alist)
- (symbol-value smiley-regexp-alist)
- smiley-regexp-alist))
- (let ((types gnus-smiley-file-types)
- file type)
- (while (and (not file)
- (setq type (pop types)))
- (unless (file-exists-p
- (setq file (expand-file-name (concat (nth 2 elt) "." type)
- smiley-data-directory)))
- (setq file nil)))
- (when type
- (let ((image (gnus-create-image file (intern type) nil
- :ascent 'center)))
- (when image
- (push (list (car elt) (cadr elt) image)
- smiley-cached-regexp-alist)))))))
+ (if (eq smiley-style 'emoji)
+ (setq smiley-cached-regexp-alist smiley-emoji-regexp-alist)
+ (dolist (elt (if (symbolp smiley-regexp-alist)
+ (symbol-value smiley-regexp-alist)
+ smiley-regexp-alist))
+ (let ((types gnus-smiley-file-types)
+ file type)
+ (while (and (not file)
+ (setq type (pop types)))
+ (unless (file-exists-p
+ (setq file (expand-file-name (concat (nth 2 elt) "." type)
+ smiley-data-directory)))
+ (setq file nil)))
+ (when type
+ (let ((image (gnus-create-image file (intern type) nil
+ :ascent 'center)))
+ (when image
+ (push (list (car elt) (cadr elt) image)
+ smiley-cached-regexp-alist))))))))
;; Not implemented:
;; (defvar smiley-mouse-map
@@ -193,8 +218,15 @@ A list of images is returned."
(when image
(push image images)
(gnus-add-wash-type 'smiley)
- (gnus-add-image 'smiley image)
- (gnus-put-image image string 'smiley))))
+ (if (symbolp image)
+ (progn
+ (gnus-add-image 'smiley image)
+ (gnus-put-image image string 'smiley))
+ ;; This is a string, but mark the property for
+ ;; deletion if the washing method is switched off.
+ (insert (propertize string
+ 'display image
+ 'gnus-image-category 'smiley))))))
images))))
;;;###autoload
@@ -210,7 +242,7 @@ interactively. If there's no argument, do it at the current buffer."
(defun smiley-toggle-buffer (&optional arg)
"Toggle displaying smiley faces in article buffer.
With arg, turn displaying on if and only if arg is positive."
- (interactive "P")
+ (interactive "P" gnus-article-mode gnus-summary-mode)
(gnus-with-article-buffer
(if (if (numberp arg)
(> arg 0)
diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el
index 2d84ff347ad..e9f703e90c6 100644
--- a/lisp/gnus/smime.el
+++ b/lisp/gnus/smime.el
@@ -42,7 +42,7 @@
;; reflect this.
;;
;; The home of this file is in Gnus, but also available from
-;; http://josefsson.org/smime.html.
+;; https://josefsson.org/smime.html.
;;; Quick introduction:
@@ -135,8 +135,7 @@ certificates to be sent with every message to each address."
:type '(repeat (list (string :tag "Mail address")
(file :tag "File name")
(repeat :tag "Additional certificate files"
- (file :tag "File name"))))
- :group 'smime)
+ (file :tag "File name")))))
(defcustom smime-CA-directory nil
"Directory containing certificates for CAs you trust.
@@ -148,16 +147,14 @@ $ ln -s ca.pem \\=`openssl x509 -noout -hash -in ca.pem\\=`.0
where `ca.pem' is the file containing a PEM encoded X.509 CA
certificate."
:type '(choice (const :tag "none" nil)
- directory)
- :group 'smime)
+ directory))
(defcustom smime-CA-file nil
"Files containing certificates for CAs you trust.
File should contain certificates in PEM format."
:version "22.1"
:type '(choice (const :tag "none" nil)
- file)
- :group 'smime)
+ file))
(defcustom smime-certificate-directory "~/Mail/certs/"
"Directory containing other people's certificates.
@@ -166,17 +163,16 @@ and the files themselves should be in PEM format."
;The S/MIME library provide simple functionality for fetching
;certificates into this directory, so there is no need to populate it
;manually.
- :type 'directory
- :group 'smime)
+ :type 'directory)
(defcustom smime-openssl-program
(and (condition-case ()
(eq 0 (call-process "openssl" nil nil nil "version"))
(error nil))
"openssl")
- "Name of OpenSSL binary."
- :type 'string
- :group 'smime)
+ "Name of OpenSSL binary or nil if none."
+ :type '(choice string
+ (const :tag "none" nil)))
;; OpenSSL option to select the encryption cipher
@@ -185,10 +181,12 @@ and the files themselves should be in PEM format."
:version "22.1"
:type '(choice (const :tag "Triple DES" "-des3")
(const :tag "DES" "-des")
+ (const :tag "AES 256 bits" "-aes256")
+ (const :tag "AES 192 bits" "-aes192")
+ (const :tag "AES 128 bits" "-aes128")
(const :tag "RC2 40 bits" "-rc2-40")
(const :tag "RC2 64 bits" "-rc2-64")
- (const :tag "RC2 128 bits" "-rc2-128"))
- :group 'smime)
+ (const :tag "RC2 128 bits" "-rc2-128")))
(defcustom smime-crl-check nil
"Check revocation status of signers certificate using CRLs.
@@ -208,24 +206,21 @@ certificate with .r0 as file name extension.
At least OpenSSL version 0.9.7 is required for this to work."
:type '(choice (const :tag "No check" nil)
(const :tag "Check certificate" "-crl_check")
- (const :tag "Check certificate chain" "-crl_check_all"))
- :group 'smime)
+ (const :tag "Check certificate chain" "-crl_check_all")))
(defcustom smime-dns-server nil
"DNS server to query certificates from.
If nil, use system defaults."
:version "22.1"
:type '(choice (const :tag "System defaults")
- string)
- :group 'smime)
+ string))
(defcustom smime-ldap-host-list nil
"A list of LDAP hosts with S/MIME user certificates.
If needed search base, binddn, passwd, etc. for the LDAP host
must be set in `ldap-host-parameters-alist'."
:type '(repeat (string :tag "Host name"))
- :version "23.1" ;; No Gnus
- :group 'smime)
+ :version "23.1") ;; No Gnus
(defvar smime-details-buffer "*OpenSSL output*")
@@ -278,7 +273,7 @@ key and certificate itself."
(setenv "GNUS_SMIME_PASSPHRASE" passphrase))
(prog1
(when (prog1
- (apply 'smime-call-openssl-region b e (list buffer tmpfile)
+ (apply #'smime-call-openssl-region b e (list buffer tmpfile)
"smime" "-sign" "-signer" (expand-file-name keyfile)
(append
(smime-make-certfiles certfiles)
@@ -310,9 +305,9 @@ is expected to contain of a PEM encoded certificate."
(tmpfile (make-temp-file "smime")))
(prog1
(when (prog1
- (apply 'smime-call-openssl-region b e (list buffer tmpfile)
+ (apply #'smime-call-openssl-region b e (list buffer tmpfile)
"smime" "-encrypt" smime-encrypt-cipher
- (mapcar 'expand-file-name certfiles))
+ (mapcar #'expand-file-name certfiles))
(with-current-buffer smime-details-buffer
(insert-file-contents tmpfile)
(delete-file tmpfile)))
@@ -380,7 +375,7 @@ Any details (stdout and stderr) are left in the buffer specified by
(with-temp-buffer
(let ((result-buffer (current-buffer)))
(with-current-buffer input-buffer
- (if (apply 'smime-call-openssl-region b e (list result-buffer
+ (if (apply #'smime-call-openssl-region b e (list result-buffer
smime-details-buffer)
"smime" "-verify" "-out" "-" CAs)
(with-current-buffer result-buffer
@@ -393,8 +388,8 @@ Returns non-nil on success.
Any details (stdout and stderr) are left in the buffer specified by
`smime-details-buffer'."
(smime-new-details-buffer)
- (if (apply 'smime-call-openssl-region b e (list smime-details-buffer t)
- "smime" "-verify" "-noverify" "-out" '("/dev/null"))
+ (if (apply #'smime-call-openssl-region b e (list smime-details-buffer t)
+ "smime" "-verify" "-noverify" "-out" `(,null-device))
t
(insert-buffer-substring smime-details-buffer)
nil))
@@ -412,7 +407,7 @@ in the buffer specified by `smime-details-buffer'."
(if passphrase
(setenv "GNUS_SMIME_PASSPHRASE" passphrase))
(if (prog1
- (apply 'smime-call-openssl-region b e
+ (apply #'smime-call-openssl-region b e
(list buffer tmpfile)
"smime" "-decrypt" "-recip" (expand-file-name keyfile)
(if passphrase
@@ -677,7 +672,7 @@ The following commands are available:
(defun smime-exit ()
"Quit the S/MIME buffer."
- (interactive)
+ (interactive nil smime-mode)
(kill-buffer (current-buffer)))
;; Other functions
diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el
index 8c148ce9d91..a4234f84001 100644
--- a/lisp/gnus/spam-report.el
+++ b/lisp/gnus/spam-report.el
@@ -1,4 +1,4 @@
-;;; spam-report.el --- Reporting spam
+;;; spam-report.el --- Reporting spam -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -43,8 +43,7 @@ If you are using spam.el, consider setting gnus-spam-process-newsgroups
or the gnus-group-spam-exit-processor-report-gmane group/topic parameter
instead."
:type '(radio (const nil)
- (regexp :value "^nntp\\+.*:gmane\\."))
- :group 'spam-report)
+ (regexp :value "^nntp\\+.*:gmane\\.")))
(defcustom spam-report-gmane-use-article-number t
"Whether the article number (faster!) or the header should be used.
@@ -52,8 +51,7 @@ instead."
You must set this to nil if you don't read Gmane groups directly
from news.gmane.org, e.g. when using local newsserver such as
leafnode."
- :type 'boolean
- :group 'spam-report)
+ :type 'boolean)
(defcustom spam-report-url-ping-function
'spam-report-url-ping-plain
@@ -66,23 +64,20 @@ The function must accept the arguments `host' and `report'."
spam-report-url-ping-mm-url)
(const :tag "Store request URLs in `spam-report-requests-file'"
spam-report-url-to-file)
- (function :tag "User defined function" nil))
- :group 'spam-report)
+ (function :tag "User defined function" nil)))
(defcustom spam-report-requests-file
(nnheader-concat gnus-directory "spam/" "spam-report-requests.url")
;; Is there a convention for the extension of such a file?
;; Should we use `spam-directory'?
"File where spam report request are stored."
- :type 'file
- :group 'spam-report)
+ :type 'file)
(defcustom spam-report-resend-to nil
"Email address that spam articles are resent to when reporting.
If not set, the user will be prompted to enter a value which will be
saved for future use."
- :type '(choice (const :tag "Prompt" nil) string)
- :group 'spam-report)
+ :type '(choice (const :tag "Prompt" nil) string))
(defvar spam-report-url-ping-temp-agent-function nil
"Internal variable for `spam-report-agentize' and `spam-report-deagentize'.
@@ -125,7 +120,8 @@ submitted at once. Internal variable.")
(defun spam-report-gmane-ham (&rest articles)
"Report ARTICLES as ham (unregister) through Gmane."
- (interactive (gnus-summary-work-articles current-prefix-arg))
+ (interactive (gnus-summary-work-articles current-prefix-arg)
+ gnus-summary-mode)
(let ((count 0))
(dolist (article articles)
(setq count (1+ count))
@@ -135,7 +131,8 @@ submitted at once. Internal variable.")
(defun spam-report-gmane-spam (&rest articles)
"Report ARTICLES as spam through Gmane."
- (interactive (gnus-summary-work-articles current-prefix-arg))
+ (interactive (gnus-summary-work-articles current-prefix-arg)
+ gnus-summary-mode)
(let ((count 0))
(dolist (article articles)
(setq count (1+ count))
@@ -232,8 +229,7 @@ the function specified by `spam-report-url-ping-function'."
This is initialized based on `user-mail-address'."
:type '(choice string
(const :tag "Don't expose address" nil))
- :version "23.1" ;; No Gnus
- :group 'spam-report)
+ :version "23.1") ;; No Gnus
(defvar spam-report-user-agent
(if spam-report-user-mail-address
@@ -345,8 +341,8 @@ Spam reports will be queued with \\[spam-report-url-to-file] when
the Agent is unplugged, and will be submitted in a batch when the
Agent is plugged."
(interactive)
- (add-hook 'gnus-agent-plugged-hook 'spam-report-plug-agent)
- (add-hook 'gnus-agent-unplugged-hook 'spam-report-unplug-agent))
+ (add-hook 'gnus-agent-plugged-hook #'spam-report-plug-agent)
+ (add-hook 'gnus-agent-unplugged-hook #'spam-report-unplug-agent))
;;;###autoload
(defun spam-report-deagentize ()
@@ -354,8 +350,8 @@ Agent is plugged."
Spam reports will be queued with the method used when
\\[spam-report-agentize] was run."
(interactive)
- (remove-hook 'gnus-agent-plugged-hook 'spam-report-plug-agent)
- (remove-hook 'gnus-agent-unplugged-hook 'spam-report-unplug-agent))
+ (remove-hook 'gnus-agent-plugged-hook #'spam-report-plug-agent)
+ (remove-hook 'gnus-agent-unplugged-hook #'spam-report-unplug-agent))
(defun spam-report-plug-agent ()
"Adjust spam report settings for plugged state.
@@ -382,4 +378,4 @@ Process queued spam reports."
(provide 'spam-report)
-;;; spam-report.el ends here.
+;;; spam-report.el ends here
diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el
index 8e73d133d89..ab9be0da890 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -1,10 +1,10 @@
-;;; spam-stat.el --- detecting spam based on statistics
+;;; spam-stat.el --- detecting spam based on statistics -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Keywords: network
-;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat
+;; URL: https://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat
;; This file is part of GNU Emacs.
@@ -135,42 +135,35 @@ whether a buffer contains spam or not."
(defcustom spam-stat-file "~/.spam-stat.el"
"File used to save and load the dictionary.
See `spam-stat-to-hash-table' for the format of the file."
- :type 'file
- :group 'spam-stat)
+ :type 'file)
(defcustom spam-stat-unknown-word-score 0.2
"The score to use for unknown words.
Also used for words that don't appear often enough."
- :type 'number
- :group 'spam-stat)
+ :type 'number)
(defcustom spam-stat-max-word-length 15
"Only words shorter than this will be considered."
- :type 'integer
- :group 'spam-stat)
+ :type 'integer)
(defcustom spam-stat-max-buffer-length 10240
"Only the beginning of buffers will be analyzed.
This variable says how many characters this will be."
- :type 'integer
- :group 'spam-stat)
+ :type 'integer)
(defcustom spam-stat-split-fancy-spam-group "mail.spam"
"Name of the group where spam should be stored.
If `spam-stat-split-fancy' is used in fancy splitting rules. Has
no effect when spam-stat is invoked through spam.el."
- :type 'string
- :group 'spam-stat)
+ :type 'string)
(defcustom spam-stat-split-fancy-spam-threshold 0.9
"Spam score threshold in spam-stat-split-fancy."
- :type 'number
- :group 'spam-stat)
+ :type 'number)
(defcustom spam-stat-washing-hook nil
"Hook applied to each message before analysis."
- :type 'hook
- :group 'spam-stat)
+ :type 'hook)
(defcustom spam-stat-score-buffer-user-functions nil
"List of additional scoring functions.
@@ -187,8 +180,7 @@ Also be careful when defining such functions. If they take a long
time, they will slow down your mail splitting. Thus, if the buffer is
large, don't forget to use smaller regions, by wrapping your work in,
say, `with-spam-stat-max-buffer-size'."
- :type '(repeat sexp)
- :group 'spam-stat)
+ :type '(repeat sexp))
(defcustom spam-stat-process-directory-age 90
"Max. age of files to be processed in directory, in days.
@@ -197,8 +189,7 @@ When using `spam-stat-process-spam-directory' or
been touched in this many days will be considered. Without
this filter, re-training spam-stat with several thousand messages
will start to take a very long time."
- :type 'number
- :group 'spam-stat)
+ :type 'number)
(defvar spam-stat-last-saved-at nil
"Time stamp of last change of spam-stat-file on this run")
@@ -260,9 +251,6 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good',
(defvar spam-stat-nbad 0
"The number of bad mails in the dictionary.")
-(defvar spam-stat-error-holder nil
- "A holder for condition-case errors while scoring buffers.")
-
(defsubst spam-stat-good (entry)
"Return the number of times this word belongs to good mails."
(aref entry 0))
@@ -486,8 +474,8 @@ The default score for unknown words is stored in
These are the words whose spam-stat differs the most from 0.5.
The list returned contains elements of the form \(WORD SCORE DIFF),
where DIFF is the difference between SCORE and 0.5."
- (let (result word score)
- (maphash (lambda (word ignore)
+ (let (result score) ;; word
+ (maphash (lambda (word _ignore)
(setq score (spam-stat-score-word word)
result (cons (list word score (abs (- score 0.5)))
result)))
@@ -501,14 +489,13 @@ where DIFF is the difference between SCORE and 0.5."
Add user supplied modifications if supplied."
(interactive) ; helps in debugging.
(setq spam-stat-score-data (spam-stat-buffer-words-with-scores))
- (let* ((probs (mapcar 'cadr spam-stat-score-data))
+ (let* ((probs (mapcar #'cadr spam-stat-score-data))
(prod (apply #'* probs))
(score0
- (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x))
+ (/ prod (+ prod (apply #'* (mapcar (lambda (x) (- 1 x))
probs)))))
(score1s
- (condition-case
- spam-stat-error-holder
+ (condition-case nil
(spam-stat-score-buffer-user score0)
(error nil)))
(ans
@@ -531,7 +518,7 @@ Add user supplied modifications if supplied."
Use this function on `nnmail-split-fancy'. If you are interested in
the raw data used for the last run of `spam-stat-score-buffer',
check the variable `spam-stat-score-data'."
- (condition-case spam-stat-error-holder
+ (condition-case err
(progn
(set-buffer spam-stat-buffer)
(goto-char (point-min))
@@ -541,7 +528,7 @@ check the variable `spam-stat-score-data'."
(push entry nnmail-split-trace))
spam-stat-score-data))
spam-stat-split-fancy-spam-group))
- (error (message "Error in spam-stat-split-fancy: %S" spam-stat-error-holder)
+ (error (message "Error in spam-stat-split-fancy: %S" err)
nil)))
;; Testing
@@ -588,7 +575,6 @@ check the variable `spam-stat-score-data'."
(defun spam-stat-count ()
"Return size of `spam-stat'."
- (interactive)
(hash-table-count spam-stat))
(defun spam-stat-test-directory (dir &optional verbose)
@@ -652,19 +638,19 @@ COUNT defaults to 5"
"Install the spam-stat function hooks."
(interactive)
(add-hook 'nnmail-prepare-incoming-message-hook
- 'spam-stat-store-current-buffer)
+ #'spam-stat-store-current-buffer)
(add-hook 'gnus-select-article-hook
- 'spam-stat-store-gnus-article-buffer))
+ #'spam-stat-store-gnus-article-buffer))
(defun spam-stat-unload-hook ()
"Uninstall the spam-stat function hooks."
(interactive)
(remove-hook 'nnmail-prepare-incoming-message-hook
- 'spam-stat-store-current-buffer)
+ #'spam-stat-store-current-buffer)
(remove-hook 'gnus-select-article-hook
- 'spam-stat-store-gnus-article-buffer))
+ #'spam-stat-store-gnus-article-buffer))
-(add-hook 'spam-stat-unload-hook 'spam-stat-unload-hook)
+(add-hook 'spam-stat-unload-hook #'spam-stat-unload-hook)
(provide 'spam-stat)
diff --git a/lisp/gnus/spam-wash.el b/lisp/gnus/spam-wash.el
index 1d00a39060d..bb2a1b97ada 100644
--- a/lisp/gnus/spam-wash.el
+++ b/lisp/gnus/spam-wash.el
@@ -1,4 +1,4 @@
-;;; spam-wash.el --- wash spam before analysis
+;;; spam-wash.el --- wash spam before analysis -*- lexical-binding: t; -*-
;; Copyright (C) 2004, 2007-2021 Free Software Foundation, Inc.
@@ -43,7 +43,7 @@
(handles (or (mm-dissect-buffer nil gnus-article-loose-mime)
(and gnus-article-emulate-mime
(mm-uu-dissect))))
- handle)
+ ) ;; handle
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
(setq gnus-article-mime-handle-alist nil))
@@ -57,7 +57,7 @@
(defun spam-treat-parts (handle)
(if (stringp (car handle))
- (mapcar 'spam-treat-parts (cdr handle))
+ (mapcar #'spam-treat-parts (cdr handle))
(if (bufferp (car handle))
(save-restriction
(narrow-to-region (point) (point))
@@ -65,7 +65,7 @@
(string-match "text" (car (mm-handle-type handle))))
(mm-insert-part handle))
(goto-char (point-max)))
- (mapcar 'spam-treat-parts handle))))
+ (mapcar #'spam-treat-parts handle))))
(provide 'spam-wash)
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index 6f4e259e3c7..3f978918b9a 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -1,4 +1,4 @@
-;;; spam.el --- Identifying spam
+;;; spam.el --- Identifying spam -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -44,12 +44,9 @@
;;; for the definitions of group content classification and spam processors
(require 'gnus)
-(eval-when-compile (require 'hashcash))
-
-;; for nnimap-split-download-body-default
-(eval-when-compile (require 'nnimap))
-
-(eval-when-compile (require 'cl-lib))
+(eval-when-compile
+ (require 'cl-lib)
+ (require 'hashcash))
;; autoload query-dig
(autoload 'query-dig "dig")
@@ -324,8 +321,8 @@ Default to t if one of the spam-use-* variables is set."
:type 'string
:group 'spam)
-;;; TODO: deprecate this variable, it's confusing since it's a list of strings,
-;;; not regular expressions
+;; 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"))
@@ -579,7 +576,7 @@ This must be a list. For example, `(\"-C\" \"configfile\")'."
(defcustom spam-spamassassin-positive-spam-flag-header "YES"
"The regex on `spam-spamassassin-spam-flag-header' for positive spam
identification."
- :type 'string
+ :type 'regexp
:group 'spam-spamassassin)
(defcustom spam-spamassassin-spam-status-header "X-Spam-Status"
@@ -708,21 +705,13 @@ finds ham or spam.")
"Clear the `spam-caches' entry for a check."
(remhash symbol spam-caches))
-(define-obsolete-function-alias 'spam-xor 'xor "27.1")
+(define-obsolete-function-alias 'spam-xor #'xor "27.1")
(defun spam-set-difference (list1 list2)
"Return a set difference of LIST1 and LIST2.
When either list is nil, the other is returned."
- (if (and list1 list2)
- ;; we have two non-nil lists
- (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))
- ;; if either of the lists was nil, return the other one
- (if list1 list1 list2)))
+ (declare (obsolete seq-difference "28.1"))
+ (seq-difference list1 list2 #'eq))
(defun spam-group-ham-mark-p (group mark &optional spam)
"Checks if MARK is considered a ham mark in GROUP."
@@ -730,7 +719,7 @@ When either list is nil, the other is returned."
(let* ((marks (spam-group-ham-marks group spam))
(marks (if (symbolp mark)
marks
- (mapcar 'symbol-value marks))))
+ (mapcar #'symbol-value marks))))
(memq mark marks))))
(defun spam-group-spam-mark-p (group mark)
@@ -1017,28 +1006,28 @@ 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)
(spam-install-mover-backend 'spam-use-move
@@ -1048,94 +1037,94 @@ backends)."
nil)
(spam-install-nocheck-backend 'spam-use-copy
- 'spam-copy-ham-routine
- 'spam-copy-spam-routine
+ #'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
+ #'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
+ #'spam-check-BBDB
+ #'spam-BBDB-register-routine
nil
- 'spam-BBDB-unregister-routine
+ #'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
+ #'spam-check-blacklist
nil
- 'spam-blacklist-register-routine
+ #'spam-blacklist-register-routine
nil
- 'spam-blacklist-unregister-routine)
+ #'spam-blacklist-unregister-routine)
(spam-install-backend 'spam-use-whitelist
- 'spam-check-whitelist
- 'spam-whitelist-register-routine
+ #'spam-check-whitelist
+ #'spam-whitelist-register-routine
nil
- 'spam-whitelist-unregister-routine
+ #'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
@@ -1228,10 +1217,20 @@ Will not return a nil score."
;;{{{ set up widening, processor checks
-;;; set up IMAP widening if it's necessary
+(defconst spam--widened (list ())
+ "Unique value identifying changes to `nnimap--split-download-body'.")
+
(defun spam-setup-widening ()
- (when (spam-widening-needed-p)
- (setq nnimap-split-download-body-default t)))
+ "Set up IMAP widening if it's necessary."
+ (and (boundp 'nnimap--split-download-body)
+ (not nnimap--split-download-body)
+ (spam-widening-needed-p)
+ (setq nnimap--split-download-body spam--widened)))
+
+(defun spam-teardown-widening ()
+ "Tear down IMAP widening."
+ (when (eq (bound-and-true-p nnimap--split-download-body) spam--widened)
+ (setq nnimap--split-download-body nil)))
(defun spam-widening-needed-p (&optional force-symbols)
(let (found)
@@ -1320,7 +1319,7 @@ In the case of mover backends, checks the setting of
(new-articles (spam-list-articles
gnus-newsgroup-articles
classification))
- (changed-articles (spam-set-difference new-articles old-articles)))
+ (changed-articles (seq-difference new-articles old-articles #'eq)))
;; now that we have the changed articles, we go through the processors
(dolist (backend (spam-backend-list))
(let (unregister-list)
@@ -1380,7 +1379,7 @@ In the case of mover backends, checks the setting of
(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)
+ deletep respool valid-move-destinations) ;; article mark
(when (member 'respool groups)
(setq respool t) ; boolean for later
@@ -1597,7 +1596,6 @@ parameters. A string as a parameter will set the
`spam-split-group' to that string.
See the Info node `(gnus)Fancy Mail Splitting' for more details."
- (interactive)
(setq spam-split-last-successful-check nil)
(unless spam-split-disabled
(let ((spam-split-group-choice spam-split-group))
@@ -1647,7 +1645,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-find-spam ()
"Detect spam in the current newsgroup using `spam-split'."
- (interactive)
+ (interactive nil gnus-summary-mode)
(let* ((group gnus-newsgroup-name)
(autodetect (gnus-parameter-spam-autodetect group))
@@ -1702,7 +1700,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(if (or (null first-method)
(equal first-method 'default))
(spam-split)
- (apply 'spam-split methods))))))
+ (apply #'spam-split methods))))))
(if (equal split-return 'spam)
(gnus-summary-mark-article article gnus-spam-mark))
@@ -1800,7 +1798,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(log-function (if unregister
'spam-log-undo-registration
'spam-log-processing-to-registry))
- article articles)
+ articles) ;; article
(when run-function
;; make list of articles, using specific-articles if given
@@ -1829,7 +1827,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;; return the number of articles processed
(length articles))))
-;;; log a ham- or spam-processor invocation to the registry
+;; log a ham- or spam-processor invocation to the registry
(defun spam-log-processing-to-registry (id type classification backend group)
(when spam-log-to-registry
(if (and (stringp id)
@@ -1848,7 +1846,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
"%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
+;; 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)
@@ -1861,8 +1859,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
"spam-log-registered-p"))
nil))))
-;;; check what a ham- or spam-processor registration says
-;;; returns nil if conflicting registrations are found
+;; 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)
@@ -1878,7 +1876,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
decision)))
-;;; check if a ham- or spam-processor registration needs to be undone
+;; check if a ham- or spam-processor registration needs to be undone
(defun spam-log-unregistration-needed-p (id type classification backend)
(when spam-log-to-registry
(if (and (stringp id)
@@ -1901,9 +1899,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
nil))))
-;;; undo a ham- or spam-processor registration (the group is not used)
+;; undo a ham- or spam-processor registration (the group is not used)
(defun spam-log-undo-registration (id type classification backend
- &optional group)
+ &optional _group)
(when (and spam-log-to-registry
(spam-log-unregistration-needed-p id type classification backend))
(if (and (stringp id)
@@ -1911,7 +1909,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(spam-classification-valid-p classification)
(spam-backend-valid-p backend))
(let ((cell-list (gnus-registry-get-id-key id type))
- new-cell-list found)
+ new-cell-list) ;; found
(dolist (cell cell-list)
(unless (and (eq classification (nth 0 cell))
(eq backend (nth 1 cell)))
@@ -1974,7 +1972,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun spam-reverse-ip-string (ip)
(when (stringp ip)
- (mapconcat 'identity
+ (mapconcat #'identity
(nreverse (split-string ip "\\."))
".")))
@@ -2027,94 +2025,83 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;;{{{ BBDB
-;;; original idea for spam-check-BBDB from Alexander Kotelnikov
-;;; <sacha@giotto.sj.ru>
+;; original idea for spam-check-BBDB from Alexander Kotelnikov
+;; <sacha@giotto.sj.ru>
;; all this is done inside a condition-case to trap errors
;; Autoloaded in message, which we require.
(declare-function gnus-extract-address-components "gnus-util" (from))
-(eval-and-compile
- (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-buffer 'ignore)
- (defalias 'bbdb-create-internal 'ignore)
- (defalias 'bbdb-records 'ignore)
- (defalias 'spam-BBDB-register-routine 'ignore)
- (defalias 'spam-enter-ham-BBDB 'ignore)
- (defalias 'spam-exists-in-BBDB-p 'ignore)
- (defalias 'bbdb-gethash 'ignore)
- nil)))
-
-(eval-and-compile
- (when (featurep 'bbdb-com)
- ;; when the BBDB changes, we want to clear out our cache
- (defun spam-clear-cache-BBDB (&rest immaterial)
- (spam-clear-cache 'spam-use-BBDB))
-
- (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB)
-
- (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
- (spam-exists-in-BBDB-p 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)))
-
- (defun spam-BBDB-unregister-routine (articles)
- (spam-BBDB-register-routine articles t))
-
- (defsubst spam-exists-in-BBDB-p (net)
- (when (and (stringp net) (not (zerop (length net))))
- (bbdb-records)
- (bbdb-gethash (downcase net))))
-
- (defun spam-check-BBDB ()
- "Mail from people in the BBDB is classified as ham or non-spam"
- (let ((net (message-fetch-field "from")))
- (when net
- (setq net (nth 1 (gnus-extract-address-components net)))
- (if (spam-exists-in-BBDB-p net)
- t
- (if spam-use-BBDB-exclusive
- spam-split-group
- nil)))))))
+(require 'bbdb nil 'noerror)
+(require 'bbdb-com nil 'noerror)
+
+(declare-function bbdb-records "bbdb" ())
+(declare-function bbdb-gethash "bbdb" (key &optional predicate))
+(declare-function bbdb-create-internal "bbdb-com" (&rest spec))
+
+;; when the BBDB changes, we want to clear out our cache
+(defun spam-clear-cache-BBDB (&rest _immaterial)
+ (spam-clear-cache 'spam-use-BBDB))
+
+(when (featurep 'bbdb-com)
+ (add-hook 'bbdb-change-hook #'spam-clear-cache-BBDB))
+
+(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
+ (spam-exists-in-BBDB-p 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)))
+
+(defun spam-BBDB-unregister-routine (articles)
+ (spam-BBDB-register-routine articles t))
+
+(defun spam-exists-in-BBDB-p (net)
+ (when (and (stringp net) (not (zerop (length net))))
+ (bbdb-records)
+ (bbdb-gethash (downcase net))))
+
+(defun spam-check-BBDB ()
+ "Mail from people in the BBDB is classified as ham or non-spam"
+ (let ((net (message-fetch-field "from")))
+ (when net
+ (setq net (nth 1 (gnus-extract-address-components net)))
+ (if (spam-exists-in-BBDB-p net)
+ t
+ (if spam-use-BBDB-exclusive
+ spam-split-group
+ nil)))))
;;}}}
;;{{{ ifile
-;;; check the ifile backend; return nil if the mail was NOT classified
-;;; as spam
+;; check the ifile backend; return nil if the mail was NOT classified
+;; as spam
(defun spam-get-ifile-database-parameter ()
@@ -2132,7 +2119,7 @@ See `spam-ifile-database'."
(let ((temp-buffer-name (buffer-name))
(db-param (spam-get-ifile-database-parameter)))
(with-current-buffer article-buffer-name
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max) spam-ifile-program
nil temp-buffer-name nil "-c"
(if db-param `(,db-param "-q") '("-q"))))
@@ -2154,13 +2141,13 @@ 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)
+ ) ;; parameters
(with-temp-buffer
(dolist (article articles)
(let ((article-string (spam-get-article-as-string article)))
(when (stringp article-string)
(insert article-string))))
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max) spam-ifile-program
nil nil nil
add-or-delete-option category
@@ -2188,7 +2175,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
"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)
+ ) ;; category return
(spam-stat-split-fancy)))
(defun spam-stat-register-spam-routine (articles &optional unregister)
@@ -2233,7 +2220,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
(let ((kill-whole-line t))
(kill-line)))
-;;; address can be a list, too
+;; address can be a list, too
(defun spam-enter-whitelist (address &optional remove)
"Enter ADDRESS (list or single) into the whitelist.
With a non-nil REMOVE, remove them."
@@ -2242,7 +2229,7 @@ With a non-nil REMOVE, remove them."
(setq spam-whitelist-cache nil)
(spam-clear-cache 'spam-use-whitelist))
-;;; address can be a list, too
+;; address can be a list, too
(defun spam-enter-blacklist (address &optional remove)
"Enter ADDRESS (list or single) into the blacklist.
With a non-nil REMOVE, remove them."
@@ -2303,8 +2290,8 @@ With a non-nil REMOVE, remove the ADDRESSES."
(cl-return)))
found)))
-;;; returns t if the sender is in the whitelist, nil or
-;;; spam-split-group otherwise
+;; returns t if the sender is in the whitelist, nil or
+;; spam-split-group otherwise
(defun spam-check-whitelist ()
;; FIXME! Should it detect when file timestamps change?
(unless spam-whitelist-cache
@@ -2339,7 +2326,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(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)
@@ -2349,7 +2336,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(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)
+ addresses unregister-list article-unregister-list) ;; from
(dolist (article articles)
(let ((from (spam-fetch-field-from-fast article))
(id (spam-fetch-field-message-id-fast article))
@@ -2399,11 +2386,11 @@ With a non-nil REMOVE, remove the ADDRESSES."
;;{{{ Spam-report glue (gmane and resend reporting)
(defun spam-report-gmane-register-routine (articles)
(when articles
- (apply 'spam-report-gmane-spam articles)))
+ (apply #'spam-report-gmane-spam articles)))
(defun spam-report-gmane-unregister-routine (articles)
(when articles
- (apply 'spam-report-gmane-ham articles)))
+ (apply #'spam-report-gmane-ham articles)))
(defun spam-report-resend-register-ham-routine (articles)
(spam-report-resend-register-routine articles t))
@@ -2438,7 +2425,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; return something sensible if the score can't be determined
(defun spam-bogofilter-score (&optional recheck)
"Get the Bogofilter spamicity score."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-window-excursion
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
@@ -2467,7 +2454,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
(with-current-buffer article-buffer-name
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-bogofilter-program
nil temp-buffer-name nil
@@ -2495,7 +2482,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(insert article-string)
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-bogofilter-program
nil nil nil switch
@@ -2525,7 +2512,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(let ((temp-buffer-name (buffer-name)))
(with-current-buffer article-buffer-name
(let ((status
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-spamoracle-binary
nil temp-buffer-name nil
@@ -2552,7 +2539,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
"-spam"
"-good"))
(status
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-spamoracle-binary
nil temp-buffer-name nil
@@ -2566,13 +2553,13 @@ With a non-nil REMOVE, remove the ADDRESSES."
(defun spam-spamoracle-learn-ham (articles &optional unregister)
(spam-spamoracle-learn articles nil unregister))
-(defun spam-spamoracle-unlearn-ham (articles &optional unregister)
+(defun spam-spamoracle-unlearn-ham (articles &optional _unregister)
(spam-spamoracle-learn-ham articles t))
(defun spam-spamoracle-learn-spam (articles &optional unregister)
(spam-spamoracle-learn articles t unregister))
-(defun spam-spamoracle-unlearn-spam (articles &optional unregister)
+(defun spam-spamoracle-unlearn-spam (articles &optional _unregister)
(spam-spamoracle-learn-spam articles t))
;;}}}
@@ -2600,7 +2587,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
(with-current-buffer article-buffer-name
- (apply 'call-process-region
+ (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)
@@ -2610,7 +2597,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; return something sensible if the score can't be determined
(defun spam-spamassassin-score (&optional recheck)
"Get the SpamAssassin score."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-window-excursion
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
@@ -2641,7 +2628,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(insert article-string)
(insert "\n"))))
;; call sa-learn on all messages at the same time
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-sa-learn-program
nil nil nil "--mbox"
@@ -2677,7 +2664,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; return something sensible if the score can't be determined
(defun spam-bsfilter-score (&optional recheck)
"Get the Bsfilter spamicity score."
- (interactive "P")
+ (interactive "P" gnus-summary-mode)
(save-window-excursion
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
@@ -2696,7 +2683,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
(with-current-buffer article-buffer-name
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-bsfilter-program
nil temp-buffer-name nil
@@ -2724,7 +2711,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(when (stringp article-string)
(with-temp-buffer
(insert article-string)
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-bsfilter-program
nil nil nil switch
@@ -2763,7 +2750,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; return something sensible if the score can't be determined
(defun spam-crm114-score ()
"Get the CRM114 Mailfilter pR."
- (interactive)
+ (interactive nil gnus-summary-mode)
(save-window-excursion
(gnus-summary-show-article t)
(set-buffer gnus-article-buffer)
@@ -2781,7 +2768,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
(with-current-buffer article-buffer-name
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-crm114-program
nil temp-buffer-name nil
@@ -2807,7 +2794,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(with-temp-buffer
(insert article-string)
- (apply 'call-process-region
+ (apply #'call-process-region
(point-min) (point-max)
spam-crm114-program
nil nil nil
@@ -2852,28 +2839,29 @@ installed through `spam-necessary-extra-headers'."
(push '((eq mark gnus-spam-mark) . spam)
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)
- (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
- (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
- (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
- (add-hook 'gnus-get-new-news-hook 'spam-setup-widening)
- (add-hook 'gnus-summary-prepared-hook 'spam-find-spam)
+ (add-hook 'gnus-save-newsrc-hook #'spam-maybe-spam-stat-save)
+ (add-hook 'gnus-get-top-new-news-hook #'spam-maybe-spam-stat-load)
+ (add-hook 'gnus-startup-hook #'spam-maybe-spam-stat-load)
+ (add-hook 'gnus-summary-prepare-exit-hook #'spam-summary-prepare-exit)
+ (add-hook 'gnus-summary-prepare-hook #'spam-summary-prepare)
+ (add-hook 'gnus-get-new-news-hook #'spam-setup-widening)
+ (add-hook 'gnus-summary-prepared-hook #'spam-find-spam)
;; Don't install things more than once.
(setq spam-install-hooks nil)))
(defun spam-unload-hook ()
"Uninstall the spam.el hooks."
(interactive)
- (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
- (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
- (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
- (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
- (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
- (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening)
- (remove-hook 'gnus-summary-prepare-hook 'spam-find-spam))
-
-(add-hook 'spam-unload-hook 'spam-unload-hook)
+ (spam-teardown-widening)
+ (remove-hook 'gnus-save-newsrc-hook #'spam-maybe-spam-stat-save)
+ (remove-hook 'gnus-get-top-new-news-hook #'spam-maybe-spam-stat-load)
+ (remove-hook 'gnus-startup-hook #'spam-maybe-spam-stat-load)
+ (remove-hook 'gnus-summary-prepare-exit-hook #'spam-summary-prepare-exit)
+ (remove-hook 'gnus-summary-prepare-hook #'spam-summary-prepare)
+ (remove-hook 'gnus-get-new-news-hook #'spam-setup-widening)
+ (remove-hook 'gnus-summary-prepare-hook #'spam-find-spam))
+
+(add-hook 'spam-unload-hook #'spam-unload-hook)
;;}}}
diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el
index 2fdd5d45b9e..233c50504bf 100644
--- a/lisp/help-at-pt.el
+++ b/lisp/help-at-pt.el
@@ -1,4 +1,4 @@
-;;; help-at-pt.el --- local help through the keyboard
+;;; help-at-pt.el --- local help through the keyboard -*- lexical-binding: t -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
@@ -42,9 +42,6 @@
;;
;; (global-set-key [C-tab] 'scan-buf-next-region)
;; (global-set-key [C-M-tab] 'scan-buf-previous-region)
-;;
-;; You do not have to do anything special to use the functionality
-;; provided by this file, because all important functions autoload.
;;; Code:
@@ -92,13 +89,16 @@ the `kbd-help' property at point. If `kbd-help' does not produce
a string, but the `help-echo' property does, then that string is
printed instead.
+The string is passed through `substitute-command-keys' before it
+is displayed.
+
A numeric argument ARG prevents display of a message in case
there is no help. While ARG can be used interactively, it is
mainly meant for use from Lisp."
(interactive "P")
(let ((help (help-at-pt-kbd-string)))
(if help
- (message "%s" help)
+ (message "%s" (substitute-command-keys help))
(if (not arg) (message "No local help at point")))))
(defvar help-at-pt-timer nil
@@ -162,6 +162,10 @@ included in this list. Suggested properties are `keymap',
`local-map', `button' and `kbd-help'. Any value other than t or
a non-empty list disables the feature.
+The text printed from the `help-echo' property is often only
+relevant when using the mouse. The presence of a `kbd-help'
+property guarantees that non mouse specific help is available.
+
This variable only takes effect after a call to
`help-at-pt-set-timer'. The help gets printed after Emacs has
been idle for `help-at-pt-timer-delay' seconds. You can call
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index ea92274add3..d7fb038f45a 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -40,8 +40,8 @@
(defvar help-fns-describe-function-functions nil
"List of functions to run in help buffer in `describe-function'.
Those functions will be run after the header line and argument
-list was inserted, and before the documentation will be inserted.
-The functions will receive the function name as argument.
+list was inserted, and before the documentation is inserted.
+The functions will be called with one argument: the function's symbol.
They can assume that a newline was output just before they were called,
and they should terminate any of their own output with a newline.
By convention they should indent their output by 2 spaces.")
@@ -126,45 +126,103 @@ with the current prefix. The files are chosen according to
:group 'help
:version "26.3")
+(defun help--symbol-class (s)
+ "Return symbol class characters for symbol S."
+ (when (stringp s)
+ (setq s (intern-soft s)))
+ (concat
+ (when (fboundp s)
+ (concat
+ (cond
+ ((commandp s) "c")
+ ((eq (car-safe (symbol-function s)) 'macro) "m")
+ (t "f"))
+ (and (let ((flist (indirect-function s)))
+ (advice--p (if (eq 'macro (car-safe flist)) (cdr flist) flist)))
+ "!")
+ (and (get s 'byte-obsolete-info) "-")))
+ (when (boundp s)
+ (concat
+ (if (custom-variable-p s) "u" "v")
+ (and (local-variable-if-set-p s) "'")
+ (and (ignore-errors (not (equal (symbol-value s) (default-value s)))) "*")
+ (and (get s 'byte-obsolete-variable) "-")))
+ (and (facep s) "a")
+ (and (fboundp 'cl-find-class) (cl-find-class s) "t")))
+
+(defun help--symbol-completion-table-affixation (completions)
+ (mapcar (lambda (c)
+ (let* ((s (intern c))
+ (doc (condition-case nil (documentation s) (error nil)))
+ (doc (and doc (substring doc 0 (string-match "\n" doc)))))
+ (list c (propertize
+ (format "%-4s" (help--symbol-class s))
+ 'face 'completions-annotations)
+ (if doc (propertize (format " -- %s" doc)
+ 'face 'completions-annotations)
+ ""))))
+ completions))
+
(defun help--symbol-completion-table (string pred action)
- (when help-enable-completion-autoload
- (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
- (help--load-prefixes prefixes)))
- (let ((prefix-completions
- (and help-enable-completion-autoload
- (mapcar #'intern (all-completions string definition-prefixes)))))
- (complete-with-action action obarray string
- (if pred (lambda (sym)
- (or (funcall pred sym)
- (memq sym prefix-completions)))))))
+ (if (and completions-detailed (eq action 'metadata))
+ '(metadata (affixation-function . help--symbol-completion-table-affixation))
+ (when help-enable-completion-autoload
+ (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
+ (help--load-prefixes prefixes)))
+ (let ((prefix-completions
+ (and help-enable-completion-autoload
+ (mapcar #'intern (all-completions string definition-prefixes)))))
+ (complete-with-action action obarray string
+ (if pred (lambda (sym)
+ (or (funcall pred sym)
+ (memq sym prefix-completions))))))))
(defvar describe-function-orig-buffer nil
"Buffer that was current when `describe-function' was invoked.
Functions on `help-fns-describe-function-functions' can use this
to get buffer-local values.")
+(defun help-fns--describe-function-or-command-prompt (&optional want-command)
+ "Prompt for a function from `describe-function' or `describe-command'.
+If optional argument WANT-COMMAND is non-nil, prompt for an
+interactive command."
+ (let* ((fn (if want-command
+ (caar command-history)
+ (function-called-at-point)))
+ (prompt (format-prompt (if want-command
+ "Describe command"
+ "Describe function")
+ fn))
+ (enable-recursive-minibuffers t)
+ (val (completing-read
+ prompt
+ #'help--symbol-completion-table
+ (lambda (f) (if want-command
+ (commandp f)
+ (or (fboundp f) (get f 'function-documentation))))
+ t nil nil
+ (and fn (symbol-name fn)))))
+ (unless (equal val "")
+ (setq fn (intern val)))
+ ;; These error messages are intended to be less technical for the
+ ;; `describe-command' case, as they are directed at users that are
+ ;; not necessarily ELisp programmers.
+ (unless (and fn (symbolp fn))
+ (user-error (if want-command
+ "You didn't specify a command's symbol"
+ "You didn't specify a function symbol")))
+ (unless (or (fboundp fn) (get fn 'function-documentation))
+ (user-error (if want-command
+ "Symbol is not a command: %s"
+ "Symbol's function definition is void: %s")
+ fn))
+ (list fn)))
+
;;;###autoload
(defun describe-function (function)
"Display the full documentation of FUNCTION (a symbol).
When called from lisp, FUNCTION may also be a function object."
- (interactive
- (let* ((fn (function-called-at-point))
- (enable-recursive-minibuffers t)
- (val (completing-read
- (if fn
- (format "Describe function (default %s): " fn)
- "Describe function: ")
- #'help--symbol-completion-table
- (lambda (f) (or (fboundp f) (get f 'function-documentation)))
- t nil nil
- (and fn (symbol-name fn)))))
- (unless (equal val "")
- (setq fn (intern val)))
- (unless (and fn (symbolp fn))
- (user-error "You didn't specify a function symbol"))
- (unless (or (fboundp fn) (get fn 'function-documentation))
- (user-error "Symbol's function definition is void: %s" fn))
- (list fn)))
+ (interactive (help-fns--describe-function-or-command-prompt))
;; We save describe-function-orig-buffer on the help xref stack, so
;; it is restored by the back/forward buttons. 'help-buffer'
@@ -194,9 +252,14 @@ When called from lisp, FUNCTION may also be a function object."
(describe-function-1 function)
(with-current-buffer standard-output
;; Return the text we displayed.
- (buffer-string))))
- ))
+ (buffer-string))))))
+;;;###autoload
+(defun describe-command (command)
+ "Display the full documentation of COMMAND (a symbol).
+When called from lisp, COMMAND may also be a function object."
+ (interactive (help-fns--describe-function-or-command-prompt 'is-command))
+ (describe-function command))
;; Could be this, if we make symbol-file do the work below.
;; (defun help-C-file-name (subr-or-var kind)
@@ -213,7 +276,9 @@ If we can't find the file name, nil is returned."
(let ((docbuf (get-buffer-create " *DOC*"))
(name (if (eq 'var kind)
(concat "V" (symbol-name subr-or-var))
- (concat "F" (subr-name (advice--cd*r subr-or-var))))))
+ (concat "F" (if (symbolp subr-or-var)
+ (symbol-name subr-or-var)
+ (subr-name (advice--cd*r subr-or-var)))))))
(with-current-buffer docbuf
(goto-char (point-min))
(if (eobp)
@@ -364,6 +429,7 @@ suitable file is found, return nil."
(help-C-file-name type 'subr)
'C-source))
((and (not file-name) (symbolp object)
+ (eq type 'defvar)
(integerp (get object 'variable-documentation)))
;; A variable defined in C. The form is from `describe-variable'.
(if (get-buffer " *DOC*")
@@ -436,13 +502,16 @@ suitable file is found, return nil."
;; If lots of ordinary text characters run this command,
;; don't mention them one by one.
(if (< (length non-modified-keys) 10)
- (princ (mapconcat #'key-description keys ", "))
+ (with-current-buffer standard-output
+ (insert (mapconcat #'help--key-description-fontified
+ keys ", ")))
(dolist (key non-modified-keys)
(setq keys (delq key keys)))
(if keys
- (progn
- (princ (mapconcat #'key-description keys ", "))
- (princ ", and many ordinary text characters"))
+ (with-current-buffer standard-output
+ (insert (mapconcat #'help--key-description-fontified
+ keys ", "))
+ (insert ", and many ordinary text characters"))
(princ "many ordinary text characters"))))
(when (or remapped keys non-modified-keys)
(princ ".")
@@ -503,7 +572,7 @@ suitable file is found, return nil."
(format "\nMacro: %s"
(help--docstring-quote
(format-kbd-macro real-def))))
- (t "[Missing arglist. Please make a bug report.]")))
+ (t "[Missing arglist.]")))
;; Insert "`X", not "(\` X)", when documenting `X.
(use1 (replace-regexp-in-string
"\\`(\\\\=\\\\\\\\=` \\([^\n ]*\\))\\'"
@@ -623,7 +692,7 @@ FILE is the file where FUNCTION was probably defined."
;; of the *packages* in which the function is defined.
(let* ((name (symbol-name symbol))
(re (concat "\\_<" (regexp-quote name) "\\_>"))
- (news (directory-files data-directory t "\\`NEWS\\.[1-9]"))
+ (news (directory-files data-directory t "\\`NEWS\\(\\'\\|\\.\\)"))
(place nil)
(first nil))
(with-temp-buffer
@@ -638,7 +707,7 @@ FILE is the file where FUNCTION was probably defined."
;; Almost all entries are of the form "* ... in Emacs NN.MM."
;; but there are also a few in the form "* Emacs NN.MM is a bug
;; fix release ...".
- (if (not (re-search-backward "^\\*.* Emacs \\([0-9.]+[0-9]\\)"
+ (if (not (re-search-backward "^\\* .* Emacs \\([0-9.]+[0-9]\\)"
nil t))
(message "Ref found in non-versioned section in %S"
(file-name-nondirectory f))
@@ -647,8 +716,7 @@ FILE is the file where FUNCTION was probably defined."
(setq place (list f pos))
(setq first version)))))))))
(when first
- (make-text-button first nil 'type 'help-news 'help-args place))
- first))
+ (make-text-button first nil 'type 'help-news 'help-args place))))
(add-hook 'help-fns-describe-function-functions
#'help-fns--mention-first-release)
@@ -661,6 +729,41 @@ FILE is the file where FUNCTION was probably defined."
(insert (format " Probably introduced at or before Emacs version %s.\n"
first))))))
+(declare-function shortdoc-display-group "shortdoc")
+(declare-function shortdoc-function-groups "shortdoc")
+
+(add-hook 'help-fns-describe-function-functions
+ #'help-fns--mention-shortdoc-groups)
+(defun help-fns--mention-shortdoc-groups (object)
+ (require 'shortdoc)
+ (when-let ((groups (and (symbolp object)
+ (shortdoc-function-groups object))))
+ (let ((start (point))
+ (times 0))
+ (with-current-buffer standard-output
+ (insert " Other relevant functions are documented in the ")
+ (mapc
+ (lambda (group)
+ (when (> times 0)
+ (insert (if (= times (1- (length groups)))
+ " and "
+ ", ")))
+ (setq times (1+ times))
+ (insert-text-button
+ (symbol-name group)
+ 'action (lambda (_)
+ (shortdoc-display-group group object))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show documentation group")))
+ groups)
+ (insert (if (= (length groups) 1)
+ " group.\n"
+ " groups.\n")))
+ (save-restriction
+ (narrow-to-region start (point))
+ (fill-region-as-paragraph (point-min) (point-max))
+ (goto-char (point-max))))))
+
(defun help-fns-short-filename (filename)
(let* ((abbrev (abbreviate-file-name filename))
(short abbrev))
@@ -738,6 +841,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
;; aliases before functions.
(aliased
(format-message "an alias for `%s'" real-def))
+ ((subr-native-elisp-p def)
+ (concat beg "native compiled Lisp function"))
((subrp def)
(concat beg (if (eq 'unevalled (cdr (subr-arity def)))
"special form"
@@ -775,7 +880,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
(t "")))
(if (and aliased (not (fboundp real-def)))
- (princ ",\nwhich is not defined. Please make a bug report.")
+ (princ ",\nwhich is not defined.")
(with-current-buffer standard-output
(save-excursion
(save-match-data
@@ -784,7 +889,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
nil t)
(help-xref-button 1 'help-function real-def)))))
- (when file-name
+ (if (not file-name)
+ (with-current-buffer standard-output
+ (setq help-mode--current-data (list :symbol function)))
;; We used to add .el to the file name,
;; but that's completely wrong when the user used load-file.
(princ (format-message " in `%s'"
@@ -793,6 +900,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
(help-fns-short-filename file-name))))
;; Make a hyperlink to the library.
(with-current-buffer standard-output
+ (setq help-mode--current-data (list :symbol function
+ :file file-name))
(save-excursion
(re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
nil t)
@@ -893,7 +1002,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound."
(output nil))
(if custom-version
(setq output
- (format "This %s was introduced, or its default value was changed, in\nversion %s of Emacs.\n"
+ (format " This %s was introduced, or its default value was changed, in\n version %s of Emacs.\n"
type custom-version))
(when cpv
(let* ((package (car-safe cpv))
@@ -904,7 +1013,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound."
(emacsv (cdr (assoc version pkg-versions))))
(if (and package version)
(setq output
- (format (concat "This %s was introduced, or its default value was changed, in\nversion %s of the %s package"
+ (format (concat " This %s was introduced, or its default value was changed, in\n version %s of the %s package"
(if emacsv
(format " that is part of Emacs %s" emacsv))
".\n")
@@ -924,18 +1033,15 @@ it is displayed along with the global value."
(orig-buffer (current-buffer))
val)
(setq val (completing-read
- (if (symbolp v)
- (format
- "Describe variable (default %s): " v)
- "Describe variable: ")
+ (format-prompt "Describe variable" (and (symbolp v) v))
#'help--symbol-completion-table
(lambda (vv)
- ;; In case the variable only exists in the buffer
- ;; the command we switch back to that buffer before
- ;; we examine the variable.
- (with-current-buffer orig-buffer
- (or (get vv 'variable-documentation)
- (and (boundp vv) (not (keywordp vv))))))
+ (or (get vv 'variable-documentation)
+ (and (not (keywordp vv))
+ ;; Since the variable may only exist in the
+ ;; original buffer, we have to look for it
+ ;; there.
+ (buffer-local-boundp vv orig-buffer))))
t nil nil
(if (symbolp v) (symbol-name v))))
(list (if (equal val "")
@@ -944,7 +1050,7 @@ it is displayed along with the global value."
(unless (buffer-live-p buffer) (setq buffer (current-buffer)))
(unless (frame-live-p frame) (setq frame (selected-frame)))
(if (not (symbolp variable))
- (message "You did not specify a variable")
+ (user-error "You didn't specify a variable")
(save-excursion
(let ((valvoid (not (with-current-buffer buffer (boundp variable))))
val val-start-pos locus)
@@ -965,12 +1071,18 @@ it is displayed along with the global value."
(princ (if file-name
(progn
(princ (format-message
- " is a variable defined in `%s'.\n"
+ " is a variable defined in `%s'.\n\n"
(if (eq file-name 'C-source)
"C source code"
- (file-name-nondirectory file-name))))
+ (help-fns-short-filename file-name))))
(with-current-buffer standard-output
- (save-excursion
+ (setq help-mode--current-data
+ (list :symbol variable
+ :type (if (eq file-name 'C-source)
+ 'variable
+ 'defvar)
+ :file file-name))
+ (save-excursion
(re-search-backward (substitute-command-keys
"`\\([^`']+\\)'")
nil t)
@@ -979,6 +1091,9 @@ it is displayed along with the global value."
(if valvoid
"It is void as a variable."
"Its "))
+ (with-current-buffer standard-output
+ (setq help-mode--current-data (list :symbol variable
+ :type 'variable)))
(if valvoid
" is void as a variable."
(substitute-command-keys "'s ")))))
@@ -1078,8 +1193,7 @@ it is displayed along with the global value."
(when (looking-at "value is") (replace-match ""))
(save-excursion
(insert "\n\nValue:")
- (set (make-local-variable 'help-button-cache)
- (point-marker)))
+ (setq-local help-button-cache (point-marker)))
(insert "value is shown ")
(insert-button "below"
'action help-button-cache
@@ -1102,7 +1216,6 @@ it is displayed along with the global value."
(with-current-buffer standard-output
(help-fns--ensure-empty-line))
- (princ "Documentation:\n")
(with-current-buffer standard-output
(insert (or doc "Not documented as a variable."))))
@@ -1125,8 +1238,8 @@ it is displayed along with the global value."
;; Note variable's version or package version.
(let ((output (describe-variable-custom-version-info variable)))
(when output
- (terpri)
- (terpri)
+ ;; (terpri)
+ ;; (terpri)
(princ output)))))
(add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local)
@@ -1350,9 +1463,12 @@ If FRAME is omitted or nil, use the selected frame."
(concat "\\(" customize-label "\\)") nil t)
(help-xref-button 1 'help-customize-face f)))
(setq file-name (find-lisp-object-file-name f 'defface))
- (when file-name
+ (if (not file-name)
+ (setq help-mode--current-data (list :symbol f))
+ (setq help-mode--current-data (list :symbol f
+ :file file-name))
(princ (substitute-command-keys "Defined in `"))
- (princ (file-name-nondirectory file-name))
+ (princ (help-fns-short-filename file-name))
(princ (substitute-command-keys "'"))
;; Make a hyperlink to the library.
(save-excursion
@@ -1424,10 +1540,8 @@ current buffer and the selected frame, respectively."
(v-or-f (if found v-or-f (function-called-at-point)))
(found (or found v-or-f))
(enable-recursive-minibuffers t)
- (val (completing-read (if found
- (format
- "Describe symbol (default %s): " v-or-f)
- "Describe symbol: ")
+ (val (completing-read (format-prompt "Describe symbol"
+ (and found v-or-f))
#'help--symbol-completion-table
(lambda (vv)
(cl-some (lambda (x) (funcall (nth 1 x) vv))
@@ -1435,7 +1549,7 @@ current buffer and the selected frame, respectively."
t nil nil
(if found (symbol-name v-or-f)))))
(list (if (equal val "")
- v-or-f (intern val)))))
+ (or v-or-f "") (intern val)))))
(if (not (symbolp symbol))
(user-error "You didn't specify a function or variable"))
(unless (buffer-live-p buffer) (setq buffer (current-buffer)))
@@ -1463,11 +1577,7 @@ current buffer and the selected frame, respectively."
(insert doc)
(delete-region (point)
(progn (skip-chars-backward " \t\n") (point)))
- (insert "\n\n"
- (eval-when-compile
- (propertize "\n" 'face
- '(:height 0.1 :inverse-video t :extend t)))
- "\n")
+ (insert "\n\n" (make-separator-line) "\n")
(when name
(insert (symbol-name symbol)
" is also a " name "." "\n\n"))))
@@ -1564,7 +1674,289 @@ BUFFER should be a buffer or a buffer name."
(insert "\nThe parent category table is:")
(describe-vector table 'help-describe-category-set))))))
+(defun help-fns-find-keymap-name (keymap)
+ "Find the name of the variable with value KEYMAP.
+Return nil if KEYMAP is not a valid keymap, or if there is no
+variable with value KEYMAP."
+ (when (keymapp keymap)
+ (let ((name (catch 'found-keymap
+ (mapatoms (lambda (symb)
+ (when (and (boundp symb)
+ (eq (symbol-value symb) keymap)
+ (not (eq symb 'keymap))
+ (throw 'found-keymap symb)))))
+ nil)))
+ ;; Follow aliasing.
+ (or (ignore-errors (indirect-variable name)) name))))
+
+(defun help-fns--most-relevant-active-keymap ()
+ "Return the name of the most relevant active keymap.
+The heuristic to determine which keymap is most likely to be
+relevant to a user follows this order:
+
+1. 'keymap' text property at point
+2. 'local-map' text property at point
+3. the `current-local-map'
+
+This is used to set the default value for the interactive prompt
+in `describe-keymap'. See also `Searching the Active Keymaps'."
+ (help-fns-find-keymap-name (or (get-char-property (point) 'keymap)
+ (if (get-text-property (point) 'local-map)
+ (get-char-property (point) 'local-map)
+ (current-local-map)))))
+
+(defvar keymap-name-history nil
+ "History for input to `describe-keymap'.")
+
+;;;###autoload
+(defun describe-keymap (keymap)
+ "Describe key bindings in KEYMAP.
+When called interactively, prompt for a variable that has a
+keymap value."
+ (interactive
+ (let* ((km (help-fns--most-relevant-active-keymap))
+ (val (completing-read
+ (format-prompt "Keymap" km)
+ obarray
+ (lambda (m) (and (boundp m) (keymapp (symbol-value m))))
+ t nil 'keymap-name-history
+ (symbol-name km))))
+ (unless (equal val "")
+ (setq km (intern val)))
+ (unless (and km (keymapp (symbol-value km)))
+ (user-error "Not a keymap: %s" km))
+ (list km)))
+ (let (used-gentemp)
+ (unless (and (symbolp keymap)
+ (boundp keymap)
+ (keymapp (symbol-value keymap)))
+ (when (not (keymapp keymap))
+ (if (symbolp keymap)
+ (error "Not a keymap variable: %S" keymap)
+ (error "Not a keymap")))
+ (let ((sym nil))
+ (unless sym
+ (setq sym (cl-gentemp "KEYMAP OBJECT (no variable) "))
+ (setq used-gentemp t)
+ (set sym keymap))
+ (setq keymap sym)))
+ ;; Follow aliasing.
+ (setq keymap (or (ignore-errors (indirect-variable keymap)) keymap))
+ (help-setup-xref (list #'describe-keymap keymap)
+ (called-interactively-p 'interactive))
+ (let* ((name (symbol-name keymap))
+ (doc (documentation-property keymap 'variable-documentation))
+ (file-name (find-lisp-object-file-name keymap 'defvar)))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (unless used-gentemp
+ (princ (format-message "%S is a keymap variable" keymap))
+ (if (not file-name)
+ (progn
+ (setq help-mode--current-data (list :symbol keymap))
+ (princ ".\n\n"))
+ (princ (format-message
+ " defined in `%s'.\n\n"
+ (if (eq file-name 'C-source)
+ "C source code"
+ (help-fns-short-filename file-name))))
+ (save-excursion
+ (re-search-backward (substitute-command-keys
+ "`\\([^`']+\\)'")
+ nil t)
+ (setq help-mode--current-data (list :symbol keymap
+ :file file-name))
+ (help-xref-button 1 'help-variable-def
+ keymap file-name))))
+ (when (and (not (equal "" doc)) doc)
+ (princ "Documentation:\n")
+ (princ (format-message "%s\n\n" doc)))
+ ;; Use `insert' instead of `princ', so control chars (e.g. \377)
+ ;; insert correctly.
+ (insert (substitute-command-keys (concat "\\{" name "}"))))))
+ ;; Cleanup.
+ (when used-gentemp
+ (makunbound keymap))))
+;;;###autoload
+(defun describe-mode (&optional buffer)
+ "Display documentation of current major mode and minor modes.
+A brief summary of the minor modes comes first, followed by the
+major mode description. This is followed by detailed
+descriptions of the minor modes, each on a separate page.
+
+For this to work correctly for a minor mode, the mode's indicator
+variable \(listed in `minor-mode-alist') must also be a function
+whose documentation describes the minor mode.
+
+If called from Lisp with a non-nil BUFFER argument, display
+documentation for the major and minor modes of that buffer."
+ (interactive "@")
+ (unless buffer (setq buffer (current-buffer)))
+ (help-setup-xref (list #'describe-mode buffer)
+ (called-interactively-p 'interactive))
+ ;; For the sake of help-do-xref and help-xref-go-back,
+ ;; don't switch buffers before calling `help-buffer'.
+ (with-help-window (help-buffer)
+ (with-current-buffer buffer
+ (let (minors)
+ ;; Older packages do not register in minor-mode-list but only in
+ ;; minor-mode-alist.
+ (dolist (x minor-mode-alist)
+ (setq x (car x))
+ (unless (memq x minor-mode-list)
+ (push x minor-mode-list)))
+ ;; Find enabled minor mode we will want to mention.
+ (dolist (mode minor-mode-list)
+ ;; Document a minor mode if it is listed in minor-mode-alist,
+ ;; non-nil, and has a function definition.
+ (let ((fmode (or (get mode :minor-mode-function) mode)))
+ (and (boundp mode) (symbol-value mode)
+ (fboundp fmode)
+ (let ((pretty-minor-mode
+ (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'"
+ (symbol-name fmode))
+ (capitalize
+ (substring (symbol-name fmode)
+ 0 (match-beginning 0)))
+ fmode)))
+ (push (list fmode pretty-minor-mode
+ (format-mode-line (assq mode minor-mode-alist)))
+ minors)))))
+ ;; Narrowing is not a minor mode, but its indicator is part of
+ ;; mode-line-modes.
+ (when (buffer-narrowed-p)
+ (push '(narrow-to-region "Narrow" " Narrow") minors))
+ (setq minors
+ (sort minors
+ (lambda (a b) (string-lessp (cadr a) (cadr b)))))
+ (when minors
+ (princ "Enabled minor modes:\n")
+ (make-local-variable 'help-button-cache)
+ (with-current-buffer standard-output
+ (dolist (mode minors)
+ (let ((mode-function (nth 0 mode))
+ (pretty-minor-mode (nth 1 mode))
+ (indicator (nth 2 mode)))
+ (save-excursion
+ (goto-char (point-max))
+ (princ "\n\f\n")
+ (push (point-marker) help-button-cache)
+ ;; Document the minor modes fully.
+ (insert-text-button
+ pretty-minor-mode 'type 'help-function
+ 'help-args (list mode-function)
+ 'button '(t))
+ (princ (format " minor mode (%s):\n"
+ (if (zerop (length indicator))
+ "no indicator"
+ (format "indicator%s"
+ indicator))))
+ (princ (help-split-fundoc (documentation mode-function)
+ nil 'doc)))
+ (insert-button pretty-minor-mode
+ 'action (car help-button-cache)
+ 'follow-link t
+ 'help-echo "mouse-2, RET: show full information")
+ (newline)))
+ (forward-line -1)
+ (fill-paragraph nil)
+ (forward-line 1))
+
+ (princ "\n(Information about these minor modes follows the major mode info.)\n\n"))
+ ;; Document the major mode.
+ (let ((mode mode-name))
+ (with-current-buffer standard-output
+ (let ((start (point)))
+ (insert (format-mode-line mode nil nil buffer))
+ (add-text-properties start (point) '(face bold)))))
+ (princ " mode")
+ (let* ((mode major-mode)
+ (file-name (find-lisp-object-file-name mode nil)))
+ (if (not file-name)
+ (setq help-mode--current-data (list :symbol mode))
+ (princ (format-message " defined in `%s'"
+ (help-fns-short-filename file-name)))
+ ;; Make a hyperlink to the library.
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
+ nil t)
+ (setq help-mode--current-data (list :symbol mode
+ :file file-name))
+ (help-xref-button 1 'help-function-def mode file-name)))))
+ (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc)))
+ (with-current-buffer standard-output
+ (insert ":\n")
+ (insert fundoc)
+ (insert (help-fns--list-local-commands)))))))
+ ;; For the sake of IELM and maybe others
+ nil)
+
+(defun help-fns--list-local-commands ()
+ (let ((functions nil))
+ (mapatoms
+ (lambda (sym)
+ (when (and (commandp sym)
+ ;; Ignore aliases.
+ (not (symbolp (symbol-function sym)))
+ ;; Ignore everything bound.
+ (not (where-is-internal sym nil t))
+ (apply #'derived-mode-p (command-modes sym)))
+ (push sym functions))))
+ (with-temp-buffer
+ (when functions
+ (setq functions (sort functions #'string<))
+ (insert "\n\nOther commands for this mode, not bound to any keys:\n\n")
+ (dolist (function functions)
+ (insert (format "`%s'\n" function))))
+ (buffer-string))))
+
+
+;; Widgets.
+
+(defvar describe-widget-functions
+ '(button-describe widget-describe)
+ "A list of functions for `describe-widget' to call.
+Each function should take one argument, a buffer position, and return
+non-nil if it described a widget at that position.")
+
+;;;###autoload
+(defun describe-widget (&optional pos)
+ "Display a buffer with information about a widget.
+You can use this command to describe buttons (e.g., the links in a *Help*
+buffer), editable fields of the customization buffers, etc.
+
+Interactively, click on a widget to describe it, or hit RET to describe the
+widget at point.
+
+When called from Lisp, POS may be a buffer position or a mouse position list.
+
+Calls each function of the list `describe-widget-functions' in turn, until
+one of them returns non-nil."
+ (interactive
+ (list
+ (let ((key
+ (read-key
+ "Click on a widget, or hit RET to describe the widget at point")))
+ (cond ((eq key ?\C-m) (point))
+ ((and (mouse-event-p key)
+ (eq (event-basic-type key) 'mouse-1)
+ (equal (event-modifiers key) '(click)))
+ (event-end key))
+ ((eq key ?\C-g) (signal 'quit nil))
+ (t (user-error "You didn't specify a widget"))))))
+ (let (buf)
+ ;; Allow describing a widget in a different window.
+ (when (posnp pos)
+ (setq buf (window-buffer (posn-window pos))
+ pos (posn-point pos)))
+ (with-current-buffer (or buf (current-buffer))
+ (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos)))
+ describe-widget-functions)
+ (message "No widget found at that position")))))
+
+
;;; Replacements for old lib-src/ programs. Don't seem especially useful.
;; Replaces lib-src/digest-doc.c.
diff --git a/lisp/help-macro.el b/lisp/help-macro.el
index 791b10a878f..1fa9d82afd8 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -1,4 +1,4 @@
-;;; help-macro.el --- makes command line help such as help-for-help
+;;; help-macro.el --- makes command line help such as help-for-help -*- lexical-binding: t -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -25,11 +25,12 @@
;;; Commentary:
-;; This file supplies the macro make-help-screen which constructs
-;; single character dispatching with browsable help such as that provided
-;; by help-for-help. This can be used to make many modes easier to use; for
-;; example, the GNU Emacs Empire Tool uses this for every "nested" mode map
-;; called from the main mode map.
+;; This file supplies the macro `make-help-screen' which constructs
+;; single character dispatching with browsable help such as that
+;; provided by `help-for-help'. This can be used to make many modes
+;; easier to use; for example, the (long-since defunct) GNU Emacs
+;; Empire Tool used this for every "nested" mode map called from the
+;; main mode map.
;; The name of this package was changed from help-screen.el to
;; help-macro.el in order to fit in a 14-character limit.
@@ -59,12 +60,6 @@
;;-> (define-key c-mp "\C-h" 'help-for-empire-redistribute-map)
;;-> (define-key c-mp help-character 'help-for-empire-redistribute-map)
-;;; Change Log:
-;;
-;; 22-Jan-1991 Lynn Slater x2048
-;; Last Modified: Mon Oct 1 11:43:52 1990 #3 (Lynn Slater)
-;; documented better
-
;;; Code:
(require 'backquote)
@@ -83,7 +78,8 @@ gives the window that lists the options."
:type 'boolean
:group 'help)
-(defmacro make-help-screen (fname help-line help-text helped-map)
+(defmacro make-help-screen (fname help-line help-text helped-map
+ &optional buffer-name)
"Construct help-menu function name FNAME.
When invoked, FNAME shows HELP-LINE and reads a command using HELPED-MAP.
If the command is the help character, FNAME displays HELP-TEXT
@@ -92,119 +88,128 @@ If HELP-TEXT contains the sequence `%THIS-KEY%', that is replaced
with the key sequence that invoked FNAME.
When FNAME finally does get a command, it executes that command
and then returns."
- (let ((doc-fn (intern (concat (symbol-name fname) "-doc"))))
- `(progn
- (defun ,doc-fn () ,help-text nil)
- (defun ,fname ()
- "Help command."
- (interactive)
- (let ((line-prompt
- (substitute-command-keys ,help-line)))
- (when three-step-help
- (message "%s" line-prompt))
- (let* ((help-screen (documentation (quote ,doc-fn)))
- ;; We bind overriding-local-map for very small
- ;; sections, *excluding* where we switch buffers
- ;; and where we execute the chosen help command.
- (local-map (make-sparse-keymap))
- (new-minor-mode-map-alist minor-mode-map-alist)
- (prev-frame (selected-frame))
- config new-frame key char)
- (when (string-match "%THIS-KEY%" help-screen)
- (setq help-screen
- (replace-match (key-description
- (substring (this-command-keys) 0 -1))
- t t help-screen)))
- (unwind-protect
- (let ((minor-mode-map-alist nil))
- (setcdr local-map ,helped-map)
- (define-key local-map [t] 'undefined)
- ;; Make the scroll bar keep working normally.
- (define-key local-map [vertical-scroll-bar]
- (lookup-key global-map [vertical-scroll-bar]))
- (if three-step-help
- (progn
- (setq key (let ((overriding-local-map local-map))
- (read-key-sequence nil)))
- ;; Make the HELP key translate to C-h.
- (if (lookup-key function-key-map key)
- (setq key (lookup-key function-key-map key)))
- (setq char (aref key 0)))
- (setq char ??))
- (when (or (eq char ??) (eq char help-char)
- (memq char help-event-list))
- (setq config (current-window-configuration))
- (pop-to-buffer " *Metahelp*" nil t)
- (and (fboundp 'make-frame)
- (not (eq (window-frame)
- prev-frame))
- (setq new-frame (window-frame)
- config nil))
- (setq buffer-read-only nil)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert help-screen))
- (let ((minor-mode-map-alist new-minor-mode-map-alist))
- (help-mode)
- (setq new-minor-mode-map-alist minor-mode-map-alist))
- (goto-char (point-min))
- (while (or (memq char (append help-event-list
- (cons help-char '(?? ?\C-v ?\s ?\177 delete backspace vertical-scroll-bar ?\M-v))))
- (eq (car-safe char) 'switch-frame)
- (equal key "\M-v"))
- (condition-case nil
- (cond
- ((eq (car-safe char) 'switch-frame)
- (handle-switch-frame char))
- ((memq char '(?\C-v ?\s))
- (scroll-up))
- ((or (memq char '(?\177 ?\M-v delete backspace))
- (equal key "\M-v"))
- (scroll-down)))
- (error nil))
- (let ((cursor-in-echo-area t)
- (overriding-local-map local-map))
- (setq key (read-key-sequence
- (format "Type one of the options listed%s: "
- (if (pos-visible-in-window-p
- (point-max))
- "" ", or SPACE or DEL to scroll")))
- char (aref key 0)))
-
- ;; If this is a scroll bar command, just run it.
- (when (eq char 'vertical-scroll-bar)
- (command-execute (lookup-key local-map key) nil key))))
- ;; We don't need the prompt any more.
- (message "")
- ;; Mouse clicks are not part of the help feature,
- ;; so reexecute them in the standard environment.
- (if (listp char)
- (setq unread-command-events
- (cons char unread-command-events)
- config nil)
- (let ((defn (lookup-key local-map key)))
- (if defn
- (progn
- (when config
- (set-window-configuration config)
- (setq config nil))
- ;; Temporarily rebind `minor-mode-map-alist'
- ;; to `new-minor-mode-map-alist' (Bug#10454).
- (let ((minor-mode-map-alist new-minor-mode-map-alist))
- ;; `defn' must make sure that its frame is
- ;; selected, so we won't iconify it below.
- (call-interactively defn))
- (when new-frame
- ;; Do not iconify the selected frame.
- (unless (eq new-frame (selected-frame))
- (iconify-frame new-frame))
- (setq new-frame nil)))
- (ding)))))
- (when config
- (set-window-configuration config))
- (when new-frame
- (iconify-frame new-frame))
- (setq minor-mode-map-alist new-minor-mode-map-alist))))))))
+ (declare (indent defun))
+ `(defun ,fname ()
+ "Help command."
+ (interactive)
+ (let ((line-prompt
+ (substitute-command-keys ,help-line)))
+ (when three-step-help
+ (message "%s" line-prompt))
+ (let* ((help-screen ,help-text)
+ ;; We bind overriding-local-map for very small
+ ;; sections, *excluding* where we switch buffers
+ ;; and where we execute the chosen help command.
+ (local-map (make-sparse-keymap))
+ (new-minor-mode-map-alist minor-mode-map-alist)
+ (prev-frame (selected-frame))
+ config new-frame key char)
+ (when (string-match "%THIS-KEY%" help-screen)
+ (setq help-screen
+ (replace-match (help--key-description-fontified
+ (substring (this-command-keys) 0 -1))
+ t t help-screen)))
+ (unwind-protect
+ (let ((minor-mode-map-alist nil))
+ (setcdr local-map ,helped-map)
+ (define-key local-map [t] 'undefined)
+ ;; Make the scroll bar keep working normally.
+ (define-key local-map [vertical-scroll-bar]
+ (lookup-key global-map [vertical-scroll-bar]))
+ (if three-step-help
+ (progn
+ (setq key (let ((overriding-local-map local-map))
+ (read-key-sequence nil)))
+ ;; Make the HELP key translate to C-h.
+ (if (lookup-key function-key-map key)
+ (setq key (lookup-key function-key-map key)))
+ (setq char (aref key 0)))
+ (setq char ??))
+ (when (or (eq char ??) (eq char help-char)
+ (memq char help-event-list))
+ (setq config (current-window-configuration))
+ (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t)
+ (and (fboundp 'make-frame)
+ (not (eq (window-frame)
+ prev-frame))
+ (setq new-frame (window-frame)
+ config nil))
+ (setq buffer-read-only nil)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (substitute-command-keys help-screen)))
+ (let ((minor-mode-map-alist new-minor-mode-map-alist))
+ (help-mode)
+ (setq new-minor-mode-map-alist minor-mode-map-alist))
+ (goto-char (point-min))
+ (while (or (memq char (append help-event-list
+ (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s
+ deletechar backspace vertical-scroll-bar
+ next prior up down))))
+ (eq (car-safe char) 'switch-frame)
+ (equal key "\M-v"))
+ (condition-case nil
+ (cond
+ ((eq (car-safe char) 'switch-frame)
+ (handle-switch-frame char))
+ ((memq char '(?\C-v ?\s next))
+ (scroll-up))
+ ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior))
+ (equal key "\M-v"))
+ (scroll-down))
+ ((memq char '(down))
+ (scroll-up 1))
+ ((memq char '(up))
+ (scroll-down 1)))
+ (error nil))
+ (let ((cursor-in-echo-area t)
+ (overriding-local-map local-map))
+ (setq key (read-key-sequence
+ (format "Type one of the options listed%s: "
+ (if (pos-visible-in-window-p
+ (point-max))
+ ""
+ (concat ", or "
+ (help--key-description-fontified (kbd "<PageDown>"))
+ " or "
+ (help--key-description-fontified (kbd "<PageUp>"))
+ " to scroll"))))
+ char (aref key 0)))
+
+ ;; If this is a scroll bar command, just run it.
+ (when (eq char 'vertical-scroll-bar)
+ (command-execute (lookup-key local-map key) nil key))))
+ ;; We don't need the prompt any more.
+ (message "")
+ ;; Mouse clicks are not part of the help feature,
+ ;; so reexecute them in the standard environment.
+ (if (listp char)
+ (setq unread-command-events
+ (cons char unread-command-events)
+ config nil)
+ (let ((defn (lookup-key local-map key)))
+ (if defn
+ (progn
+ (when config
+ (set-window-configuration config)
+ (setq config nil))
+ ;; Temporarily rebind `minor-mode-map-alist'
+ ;; to `new-minor-mode-map-alist' (Bug#10454).
+ (let ((minor-mode-map-alist new-minor-mode-map-alist))
+ ;; `defn' must make sure that its frame is
+ ;; selected, so we won't iconify it below.
+ (call-interactively defn))
+ (when new-frame
+ ;; Do not iconify the selected frame.
+ (unless (eq new-frame (selected-frame))
+ (iconify-frame new-frame))
+ (setq new-frame nil)))
+ (ding)))))
+ (when config
+ (set-window-configuration config))
+ (when new-frame
+ (iconify-frame new-frame))
+ (setq minor-mode-map-alist new-minor-mode-map-alist))))))
(provide 'help-macro)
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 1ac7587413a..8206115b15c 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -1,4 +1,4 @@
-;;; help-mode.el --- `help-mode' used by *Help* buffers
+;;; help-mode.el --- `help-mode' used by *Help* buffers -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1993-1994, 1998-2021 Free Software
;; Foundation, Inc.
@@ -29,15 +29,12 @@
;;; Code:
-(require 'button)
(require 'cl-lib)
-(eval-when-compile (require 'easymenu))
(defvar help-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (make-composed-keymap button-buffer-map
special-mode-map))
- (define-key map [mouse-2] 'help-follow-mouse)
(define-key map "l" 'help-go-back)
(define-key map "r" 'help-go-forward)
(define-key map "\C-c\C-b" 'help-go-back)
@@ -45,51 +42,71 @@
(define-key map [XF86Back] 'help-go-back)
(define-key map [XF86Forward] 'help-go-forward)
(define-key map "\C-c\C-c" 'help-follow-symbol)
- (define-key map "\r" 'help-follow)
+ (define-key map "s" 'help-view-source)
+ (define-key map "i" 'help-goto-info)
+ (define-key map "c" 'help-customize)
map)
- "Keymap for help mode.")
+ "Keymap for Help mode.")
(easy-menu-define help-mode-menu help-mode-map
- "Menu for Help Mode."
+ "Menu for Help mode."
'("Help-Mode"
["Show Help for Symbol" help-follow-symbol
:help "Show the docs for the symbol at point"]
["Previous Topic" help-go-back
- :help "Go back to previous topic in this help buffer"]
+ :help "Go back to previous topic in this help buffer"
+ :active help-xref-stack]
["Next Topic" help-go-forward
- :help "Go back to next topic in this help buffer"]
+ :help "Go back to next topic in this help buffer"
+ :active help-xref-forward-stack]
["Move to Previous Button" backward-button
:help "Move to the Previous Button in the help buffer"]
["Move to Next Button" forward-button
- :help "Move to the Next Button in the help buffer"]))
-
-(defvar help-xref-stack nil
+ :help "Move to the Next Button in the help buffer"]
+ ["View Source" help-view-source
+ :help "Go to the source file for the current help item"]
+ ["Goto Info" help-goto-info
+ :help "Go to the info node for the current help item"]
+ ["Customize" help-customize
+ :help "Customize variable or face"]))
+
+(defvar help-mode-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item "close" 'quit-window 'quit map
+ :help "Quit help"
+ :vert-only t)
+ (define-key-after map [separator-1] menu-bar-separator)
+ (tool-bar-local-item "search" 'isearch-forward 'search map
+ :help "Search" :vert-only t)
+ (tool-bar-local-item-from-menu 'help-go-back "left-arrow" map help-mode-map
+ :rtl "right-arrow" :vert-only t)
+ (tool-bar-local-item-from-menu 'help-go-forward "right-arrow" map help-mode-map
+ :rtl "left-arrow" :vert-only t)
+ map))
+
+(defvar-local help-xref-stack nil
"A stack of ways by which to return to help buffers after following xrefs.
-Used by `help-follow' and `help-xref-go-back'.
+Used by `help-follow-symbol' and `help-xref-go-back'.
An element looks like (POSITION FUNCTION ARGS...).
To use the element, do (apply FUNCTION ARGS) then goto the point.")
(put 'help-xref-stack 'permanent-local t)
-(make-variable-buffer-local 'help-xref-stack)
-(defvar help-xref-forward-stack nil
+(defvar-local help-xref-forward-stack nil
"A stack used to navigate help forwards after using the back button.
-Used by `help-follow' and `help-xref-go-forward'.
+Used by `help-follow-symbol' and `help-xref-go-forward'.
An element looks like (POSITION FUNCTION ARGS...).
To use the element, do (apply FUNCTION ARGS) then goto the point.")
(put 'help-xref-forward-stack 'permanent-local t)
-(make-variable-buffer-local 'help-xref-forward-stack)
-(defvar help-xref-stack-item nil
- "An item for `help-follow' in this buffer to push onto `help-xref-stack'.
+(defvar-local help-xref-stack-item nil
+ "An item for `help-follow-symbok' to push onto `help-xref-stack'.
The format is (FUNCTION ARGS...).")
(put 'help-xref-stack-item 'permanent-local t)
-(make-variable-buffer-local 'help-xref-stack-item)
-(defvar help-xref-stack-forward-item nil
+(defvar-local help-xref-stack-forward-item nil
"An item for `help-go-back' to push onto `help-xref-forward-stack'.
The format is (FUNCTION ARGS...).")
(put 'help-xref-stack-forward-item 'permanent-local t)
-(make-variable-buffer-local 'help-xref-stack-forward-item)
(setq-default help-xref-stack nil help-xref-stack-item nil)
(setq-default help-xref-forward-stack nil help-xref-forward-stack-item nil)
@@ -308,11 +325,12 @@ The format is (FUNCTION ARGS...).")
:supertype 'help-xref
'help-function
(lambda (file pos)
- (pop-to-buffer (find-file-noselect file))
+ (view-buffer-other-window (find-file-noselect file))
(goto-char pos))
'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement"))
(defvar bookmark-make-record-function)
+(defvar help-mode--current-data nil)
;;;###autoload
(define-derived-mode help-mode special-mode "Help"
@@ -320,20 +338,23 @@ The format is (FUNCTION ARGS...).")
Entry to this mode runs the normal hook `help-mode-hook'.
Commands:
\\{help-mode-map}"
- (set (make-local-variable 'revert-buffer-function)
- 'help-mode-revert-buffer)
- (set (make-local-variable 'bookmark-make-record-function)
- 'help-bookmark-make-record))
+ (setq-local revert-buffer-function
+ #'help-mode-revert-buffer)
+ (setq-local tool-bar-map
+ help-mode-tool-bar-map)
+ (setq-local help-mode--current-data nil)
+ (setq-local bookmark-make-record-function
+ #'help-bookmark-make-record))
;;;###autoload
(defun help-mode-setup ()
- "Enter Help Mode in the current buffer."
+ "Enter Help mode in the current buffer."
(help-mode)
(setq buffer-read-only nil))
;;;###autoload
(defun help-mode-finish ()
- "Finalize Help Mode setup in current buffer."
+ "Finalize Help mode setup in current buffer."
(when (derived-mode-p 'help-mode)
(setq buffer-read-only t)
(help-make-xrefs (current-buffer))))
@@ -358,8 +379,7 @@ Commands:
"\\(symbol\\|program\\|property\\)\\|" ; Don't link
"\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)"
"[ \t\n]+\\)?"
- ;; Note starting with word-syntax character:
- "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\|`\\)['’]"))
+ "['`‘]\\(\\(?:\\sw\\|\\s_\\)+\\|`\\)['’]"))
"Regexp matching doc string references to symbols.
The words preceding the quoted symbol can be used in doc strings to
@@ -444,7 +464,7 @@ Each element has the form (NAME TESTFUN DESCFUN) where:
"Parse and hyperlink documentation cross-references in the given BUFFER.
Find cross-reference information in a buffer and activate such cross
-references for selection with `help-follow'. Cross-references have
+references for selection with `help-follow-symbol'. Cross-references have
the canonical form `...' and the type of reference may be
disambiguated by the preceding word(s) used in
`help-xref-symbol-regexp'. Faces only get cross-referenced if
@@ -464,8 +484,7 @@ that."
(with-current-buffer (or buffer (current-buffer))
(save-excursion
(goto-char (point-min))
- ;; Skip the header-type info, though it might be useful to parse
- ;; it at some stage (e.g. "function in `library'").
+ ;; Skip the first bit, which has already been buttonized.
(forward-paragraph)
(let ((old-modified (buffer-modified-p)))
(let ((stab (syntax-table))
@@ -712,6 +731,34 @@ See `help-make-xrefs'."
(help-xref-go-forward (current-buffer))
(user-error "No next help buffer")))
+(defun help-view-source ()
+ "View the source of the current help item."
+ (interactive nil help-mode)
+ (unless (plist-get help-mode--current-data :file)
+ (error "Source file for the current help item is not defined"))
+ (help-function-def--button-function
+ (plist-get help-mode--current-data :symbol)
+ (plist-get help-mode--current-data :file)
+ (plist-get help-mode--current-data :type)))
+
+(defun help-goto-info ()
+ "View the *info* node of the current help item."
+ (interactive nil help-mode)
+ (unless help-mode--current-data
+ (error "No symbol to look up in the current buffer"))
+ (info-lookup-symbol (plist-get help-mode--current-data :symbol)
+ 'emacs-lisp-mode))
+
+(defun help-customize ()
+ "Customize variable or face whose doc string is shown in the current buffer."
+ (interactive nil help-mode)
+ (let ((sym (plist-get help-mode--current-data :symbol)))
+ (unless (or (boundp sym) (facep sym))
+ (user-error "No variable or face to customize"))
+ (cond
+ ((boundp sym) (customize-variable sym))
+ ((facep sym) (customize-face sym)))))
+
(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
@@ -719,11 +766,13 @@ a proper [back] button."
;; There is a reference at point. Follow it.
(let ((help-xref-following t))
(apply function (if (eq function 'info)
- (append args (list (generate-new-buffer-name "*info*"))) args))))
+ (append args (list (generate-new-buffer-name "*info*")))
+ args))))
;; The doc string is meant to explain what buttons do.
(defun help-follow-mouse ()
"Follow the cross-reference that you click on."
+ (declare (obsolete nil "28.1"))
(interactive)
(error "No cross-reference here"))
@@ -732,6 +781,7 @@ a proper [back] button."
"Follow cross-reference at point.
For the cross-reference format, see `help-make-xrefs'."
+ (declare (obsolete nil "28.1"))
(interactive)
(user-error "No cross-reference here"))
@@ -755,16 +805,15 @@ Show all docs for that symbol as either a variable, function or face."
(help-do-xref pos #'describe-symbol (list sym))
(user-error "No symbol here"))))
-(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-mode-revert-buffer (_ignore-auto _noconfirm)
+ (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.
@@ -784,8 +833,8 @@ help buffer by other means."
(&optional no-file no-context posn))
(defun help-bookmark-make-record ()
- "Create and return a help-mode bookmark record.
-Implements `bookmark-make-record-function' for help-mode buffers."
+ "Create and return a `help-mode' bookmark record.
+Implements `bookmark-make-record-function' for `help-mode' buffers."
(unless (car help-xref-stack-item)
(error "Cannot create bookmark - help command not known"))
`(,@(bookmark-make-record-default 'NO-FILE 'NO-CONTEXT)
@@ -798,7 +847,7 @@ Implements `bookmark-make-record-function' for help-mode buffers."
;;;###autoload
(defun help-bookmark-jump (bookmark)
- "Jump to help-mode bookmark BOOKMARK.
+ "Jump to `help-mode' bookmark BOOKMARK.
Handler function for record returned by `help-bookmark-make-record'.
BOOKMARK is a bookmark name or a bookmark record."
(let ((help-fn (bookmark-prop-get bookmark 'help-fn))
diff --git a/lisp/help.el b/lisp/help.el
index 88265680f90..ba27fc5810f 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -101,10 +101,12 @@
(define-key map "p" 'finder-by-keyword)
(define-key map "P" 'describe-package)
(define-key map "r" 'info-emacs-manual)
+ (define-key map "R" 'info-display-manual)
(define-key map "s" 'describe-syntax)
(define-key map "t" 'help-with-tutorial)
- (define-key map "w" 'where-is)
(define-key map "v" 'describe-variable)
+ (define-key map "w" 'where-is)
+ (define-key map "x" 'describe-command)
(define-key map "q" 'help-quit)
map)
"Keymap for characters following the Help key.")
@@ -131,7 +133,6 @@ This is a list
(WINDOW . quit-window) do quit-window, then select WINDOW.
(WINDOW BUF START POINT) display BUF at START, POINT, then select WINDOW.")
-(define-obsolete-function-alias 'print-help-return-message 'help-print-return-message "23.2")
(defun help-print-return-message (&optional function)
"Display or return message saying how to restore windows after help command.
This function assumes that `standard-output' is the help buffer.
@@ -187,64 +188,124 @@ Do not call this in the scope of `with-help-window'."
;; So keyboard macro definitions are documented correctly
(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
-(defalias 'help 'help-for-help-internal)
-;; find-function can find this.
-(defalias 'help-for-help 'help-for-help-internal)
-;; It can't find this, but nobody will look.
-(make-help-screen help-for-help-internal
+
+;;; Help for help. (a.k.a. `C-h C-h')
+
+(defvar help-for-help-buffer-name " *Metahelp*"
+ "Name of the `help-for-help' buffer.")
+
+(defface help-for-help-header '((t :height 1.26))
+ "Face used for headers in the `help-for-help' buffer."
+ :group 'help)
+
+(defun help--for-help-make-commands (commands)
+ "Create commands for `help-for-help' screen from COMMANDS."
+ (mapconcat
+ (lambda (cmd)
+ (if (listp cmd)
+ (let ((name (car cmd)) (desc (cadr cmd)))
+ (concat
+ " "
+ (if (string-match (rx string-start "C-" word string-end) name)
+ ;; `help--key-description-fontified' would convert "C-m" to
+ ;; "RET" so we can't use it here.
+ (propertize name 'face 'help-key-binding)
+ (concat "\\[" name "]"))
+ " " ; ensure we have some whitespace before the description
+ (propertize "\t" 'display '(space :align-to 8))
+ desc))
+ ""))
+ commands "\n"))
+
+(defun help--for-help-make-sections (sections)
+ "Create sections for `help-for-help' screen from SECTIONS."
+ (mapconcat
+ (lambda (section)
+ (let ((title (car section)) (commands (cdr section)))
+ (concat
+ "\n\n"
+ (propertize title 'face 'help-for-help-header)
+ "\n\n"
+ (help--for-help-make-commands commands))))
+ sections ""))
+
+(defalias 'help 'help-for-help)
+(make-help-screen help-for-help
(purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?")
- ;; Don't purecopy this one, because it's not evaluated (it's
- ;; directly used as a docstring in a function definition, so it'll
- ;; be moved to the DOC file anyway: no need for purecopying it).
- "You have typed %THIS-KEY%, the help character. Type a Help option:
-\(Use SPC or DEL to scroll through this text. Type \\<help-map>\\[help-quit] to exit the Help command.)
-
-a PATTERN Show commands whose name matches the PATTERN (a list of words
- or a regexp). See also the `apropos' command.
-b Display all key bindings.
-c KEYS Display the command name run by the given key sequence.
-C CODING Describe the given coding system, or RET for current ones.
-d PATTERN Show a list of functions, variables, and other items whose
- documentation matches the PATTERN (a list of words or a regexp).
-e Go to the *Messages* buffer which logs echo-area messages.
-f FUNCTION Display documentation for the given function.
-F COMMAND Show the Emacs manual's section that describes the command.
-g Display information about the GNU project.
-h Display the HELLO file which illustrates various scripts.
-i Start the Info documentation reader: read included manuals.
-I METHOD Describe a specific input method, or RET for current.
-k KEYS Display the full documentation for the key sequence.
-K KEYS Show the Emacs manual's section for the command bound to KEYS.
-l Show last 300 input keystrokes (lossage).
-L LANG-ENV Describe a specific language environment, or RET for current.
-m Display documentation of current minor modes and current major mode,
- including their special commands.
-n Display news of recent Emacs changes.
-o SYMBOL Display the given function or variable's documentation and value.
-p TOPIC Find packages matching a given topic keyword.
-P PACKAGE Describe the given Emacs Lisp package.
-r Display the Emacs manual in Info mode.
-s Display contents of current syntax table, plus explanations.
-S SYMBOL Show the section for the given symbol in the Info manual
- for the programming language used in this buffer.
-t Start the Emacs learn-by-doing tutorial.
-v VARIABLE Display the given variable's documentation and value.
-w COMMAND Display which keystrokes invoke the given command (where-is).
-. Display any available local help at point in the echo area.
-
-C-a Information about Emacs.
-C-c Emacs copying permission (GNU General Public License).
-C-d Instructions for debugging GNU Emacs.
-C-e External packages and information about Emacs.
-C-f Emacs FAQ.
-C-m How to order printed Emacs manuals.
-C-n News of recent Emacs changes.
-C-o Emacs ordering and distribution information.
-C-p Info about known Emacs problems.
-C-s Search forward \"help window\".
-C-t Emacs TODO list.
-C-w Information on absence of warranty for GNU Emacs."
- help-map)
+ (concat
+ "(Type "
+ (help--key-description-fontified (kbd "<PageDown>"))
+ " or "
+ (help--key-description-fontified (kbd "<PageUp>"))
+ " to scroll, "
+ (help--key-description-fontified "\C-s")
+ " to search, or \\<help-map>\\[help-quit] to exit.)"
+ (help--for-help-make-sections
+ `(("Commands, Keys and Functions"
+ ("describe-mode"
+ "Show help for current major and minor modes and their commands")
+ ("describe-bindings" "Show all key bindings")
+ ("describe-key" "Show help for key")
+ ("describe-key-briefly" "Show help for key briefly")
+ ("where-is" "Show which key runs a specific command")
+ ""
+ ("apropos-command"
+ "Search for commands (see also \\[apropos])")
+ ("apropos-documentation"
+ "Search documentation of functions, variables, and other items")
+ ("describe-command" "Show help for command")
+ ("describe-function" "Show help for function")
+ ("describe-variable" "Show help for variable")
+ ("describe-symbol" "Show help for function or variable"))
+ ("Manuals"
+ ("info-emacs-manual" "Show Emacs manual")
+ ("Info-goto-emacs-command-node"
+ "Show Emacs manual section for command")
+ ("Info-goto-emacs-key-command-node"
+ "Show Emacs manual section for a key sequence")
+ ("info" "Show all installed manuals")
+ ("info-display-manual" "Show a specific manual")
+ ("info-lookup-symbol" "Show description of symbol in pertinent manual"))
+ ("Other Help Commands"
+ ("view-external-packages"
+ "Extending Emacs with external packages")
+ ("finder-by-keyword"
+ "Search for Emacs packages (see also \\[list-packages])")
+ ("describe-package" "Describe a specific Emacs package")
+ ""
+ ("help-with-tutorial" "Start the Emacs tutorial")
+ ("view-echo-area-messages"
+ "Show recent messages (from echo area)")
+ ("view-lossage" ,(format "Show last %d input keystrokes (lossage)"
+ (lossage-size)))
+ ("display-local-help" "Show local help at point"))
+ ("Miscellaneous"
+ ("about-emacs" "About Emacs")
+ ("view-emacs-FAQ" "Emacs FAQ")
+ ("C-n" "News of recent changes")
+ ("view-emacs-problems" "Known problems")
+ ("view-emacs-debugging" "Debugging Emacs")
+ ""
+ ("describe-gnu-project" "About the GNU project")
+ ("describe-copying"
+ "Emacs copying permission (GNU General Public License)")
+ ("describe-distribution"
+ "Emacs ordering and distribution information")
+ ("C-m" "Order printed manuals")
+ ("view-emacs-todo" "Emacs TODO")
+ ("describe-no-warranty"
+ "Information on absence of warranty"))
+ ("Internationalization and Coding Systems"
+ ("describe-input-method" "Describe input method")
+ ("describe-coding-system" "Describe coding system")
+ ("describe-language-environment"
+ "Describe language environment")
+ ("describe-syntax" "Show current syntax table")
+ ("view-hello-file"
+ "Display the HELLO file illustrating various scripts"))))
+ "\n")
+ help-map
+ help-for-help-buffer-name)
@@ -365,7 +426,7 @@ With argument, display info only for the selected version."
(sort (delete-dups res) #'string>)))
(current (car all-versions)))
(setq version (completing-read
- (format "Read NEWS for the version (default %s): " current)
+ (format-prompt "Read NEWS for the version" current)
all-versions nil nil nil nil current))
(if (integerp (string-to-number version))
(setq version (string-to-number version))
@@ -459,6 +520,7 @@ the variable `message-log-max'."
"Display last few input keystrokes and the commands run.
For convenience this uses the same format as
`edit-last-kbd-macro'.
+See `lossage-size' to update the number of recorded keystrokes.
To record all your input, use `open-dribble-file'."
(interactive)
@@ -490,6 +552,21 @@ To record all your input, use `open-dribble-file'."
;; Key bindings
+(defun help--key-description-fontified (keys &optional prefix)
+ "Like `key-description' but add face for \"*Help*\" buffers."
+ ;; We add both the `font-lock-face' and `face' properties here, as this
+ ;; seems to be the only way to get this to work reliably in any
+ ;; buffer.
+ (propertize (key-description keys prefix)
+ 'font-lock-face 'help-key-binding
+ 'face 'help-key-binding))
+
+(defcustom describe-bindings-outline nil
+ "Non-nil enables outlines in the output buffer of `describe-bindings'."
+ :type 'boolean
+ :group 'help
+ :version "28.1")
+
(defun describe-bindings (&optional prefix buffer)
"Display a buffer showing a list of all defined keys, and their definitions.
The keys are displayed in order of precedence.
@@ -507,24 +584,26 @@ or a buffer name."
;; Be aware that `describe-buffer-bindings' puts its output into
;; the current buffer.
(with-current-buffer (help-buffer)
- (describe-buffer-bindings buffer prefix))))
-
-;; This function used to be in keymap.c.
-(defun describe-bindings-internal (&optional menus prefix)
- "Show a list of all defined keys, and their definitions.
-We put that list in a buffer, and display the buffer.
-
-The optional argument MENUS, if non-nil, says to mention menu bindings.
-\(Ordinarily these are omitted from the output.)
-The optional argument PREFIX, if non-nil, should be a key sequence;
-then we display only bindings that start with that prefix."
- (declare (obsolete describe-buffer-bindings "24.4"))
- (let ((buf (current-buffer)))
- (with-help-window (help-buffer)
- ;; Be aware that `describe-buffer-bindings' puts its output into
- ;; the current buffer.
- (with-current-buffer (help-buffer)
- (describe-buffer-bindings buf prefix menus)))))
+ (describe-buffer-bindings buffer prefix)
+
+ (when describe-bindings-outline
+ (setq-local outline-regexp ".*:$")
+ (setq-local outline-heading-end-regexp ":\n")
+ (setq-local outline-level (lambda () 1))
+ (setq-local outline-minor-mode-cycle t
+ outline-minor-mode-highlight t)
+ (outline-minor-mode 1)
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (insert (substitute-command-keys
+ (concat "\\<outline-mode-cycle-map>Type "
+ "\\[outline-cycle] or \\[outline-cycle-buffer] "
+ "on headings to cycle their visibility.\n\n")))
+ ;; Hide the longest body
+ (when (and (re-search-forward "Key translations" nil t)
+ (fboundp 'outline-cycle))
+ (outline-cycle))))))))
(defun where-is (definition &optional insert)
"Print message listing key sequences that invoke the command DEFINITION.
@@ -534,12 +613,9 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
(let ((fn (function-called-at-point))
(enable-recursive-minibuffers t)
val)
- (setq val (completing-read
- (if fn
- (format "Where is command (default %s): " fn)
- "Where is command: ")
- obarray 'commandp t nil nil
- (and fn (symbol-name fn))))
+ (setq val (completing-read (format-prompt "Where is command" fn)
+ obarray 'commandp t nil nil
+ (and fn (symbol-name fn))))
(list (unless (equal val "") (intern val))
current-prefix-arg)))
(unless definition (error "No command"))
@@ -560,7 +636,8 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
(let* ((remapped (command-remapping symbol))
(keys (where-is-internal
symbol overriding-local-map nil nil remapped))
- (keys (mapconcat 'key-description keys ", "))
+ (keys (mapconcat #'help--key-description-fontified
+ keys ", "))
string)
(setq string
(if insert
@@ -588,11 +665,11 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
nil)
(defun help-key-description (key untranslated)
- (let ((string (key-description key)))
+ (let ((string (help--key-description-fontified key)))
(if (or (not untranslated)
(and (eq (aref untranslated 0) ?\e) (not (eq (aref key 0) ?\e))))
string
- (let ((otherstring (key-description untranslated)))
+ (let ((otherstring (help--key-description-fontified untranslated)))
(if (equal string otherstring)
string
(format "%s (translated from %s)" string otherstring))))))
@@ -866,12 +943,7 @@ current buffer."
(when defn
(when (> (length info-list) 1)
(with-current-buffer standard-output
- (insert "\n\n"
- ;; FIXME: Can't use eval-when-compile because purified
- ;; strings lose their text properties :-(
- (propertize "\n" 'face
- '(:height 0.1 :inverse-video t :extend t))
- "\n")))
+ (insert "\n\n" (make-separator-line) "\n")))
(princ brief-desc)
(when locus
@@ -879,119 +951,11 @@ current buffer."
(princ ", which is ")
(describe-function-1 defn)))))))
-(defun describe-mode (&optional buffer)
- "Display documentation of current major mode and minor modes.
-A brief summary of the minor modes comes first, followed by the
-major mode description. This is followed by detailed
-descriptions of the minor modes, each on a separate page.
-
-For this to work correctly for a minor mode, the mode's indicator
-variable \(listed in `minor-mode-alist') must also be a function
-whose documentation describes the minor mode.
-
-If called from Lisp with a non-nil BUFFER argument, display
-documentation for the major and minor modes of that buffer."
- (interactive "@")
- (unless buffer (setq buffer (current-buffer)))
- (help-setup-xref (list #'describe-mode buffer)
- (called-interactively-p 'interactive))
- ;; For the sake of help-do-xref and help-xref-go-back,
- ;; don't switch buffers before calling `help-buffer'.
- (with-help-window (help-buffer)
- (with-current-buffer buffer
- (let (minor-modes)
- ;; Older packages do not register in minor-mode-list but only in
- ;; minor-mode-alist.
- (dolist (x minor-mode-alist)
- (setq x (car x))
- (unless (memq x minor-mode-list)
- (push x minor-mode-list)))
- ;; Find enabled minor mode we will want to mention.
- (dolist (mode minor-mode-list)
- ;; Document a minor mode if it is listed in minor-mode-alist,
- ;; non-nil, and has a function definition.
- (let ((fmode (or (get mode :minor-mode-function) mode)))
- (and (boundp mode) (symbol-value mode)
- (fboundp fmode)
- (let ((pretty-minor-mode
- (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'"
- (symbol-name fmode))
- (capitalize
- (substring (symbol-name fmode)
- 0 (match-beginning 0)))
- fmode)))
- (push (list fmode pretty-minor-mode
- (format-mode-line (assq mode minor-mode-alist)))
- minor-modes)))))
- ;; Narrowing is not a minor mode, but its indicator is part of
- ;; mode-line-modes.
- (when (buffer-narrowed-p)
- (push '(narrow-to-region "Narrow" " Narrow") minor-modes))
- (setq minor-modes
- (sort minor-modes
- (lambda (a b) (string-lessp (cadr a) (cadr b)))))
- (when minor-modes
- (princ "Enabled minor modes:\n")
- (make-local-variable 'help-button-cache)
- (with-current-buffer standard-output
- (dolist (mode minor-modes)
- (let ((mode-function (nth 0 mode))
- (pretty-minor-mode (nth 1 mode))
- (indicator (nth 2 mode)))
- (save-excursion
- (goto-char (point-max))
- (princ "\n\f\n")
- (push (point-marker) help-button-cache)
- ;; Document the minor modes fully.
- (insert-text-button
- pretty-minor-mode 'type 'help-function
- 'help-args (list mode-function)
- 'button '(t))
- (princ (format " minor mode (%s):\n"
- (if (zerop (length indicator))
- "no indicator"
- (format "indicator%s"
- indicator))))
- (princ (help-split-fundoc (documentation mode-function)
- nil 'doc)))
- (insert-button pretty-minor-mode
- 'action (car help-button-cache)
- 'follow-link t
- 'help-echo "mouse-2, RET: show full information")
- (newline)))
- (forward-line -1)
- (fill-paragraph nil)
- (forward-line 1))
-
- (princ "\n(Information about these minor modes follows the major mode info.)\n\n"))
- ;; Document the major mode.
- (let ((mode mode-name))
- (with-current-buffer standard-output
- (let ((start (point)))
- (insert (format-mode-line mode nil nil buffer))
- (add-text-properties start (point) '(face bold)))))
- (princ " mode")
- (let* ((mode major-mode)
- (file-name (find-lisp-object-file-name mode nil)))
- (when file-name
- (princ (format-message " defined in `%s'"
- (file-name-nondirectory file-name)))
- ;; Make a hyperlink to the library.
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
- nil t)
- (help-xref-button 1 'help-function-def mode file-name)))))
- (princ ":\n")
- (princ (help-split-fundoc (documentation major-mode) nil 'doc)))))
- ;; For the sake of IELM and maybe others
- nil)
-
(defun search-forward-help-for-help ()
"Search forward \"help window\"."
(interactive)
;; Move cursor to the "help window".
- (pop-to-buffer " *Metahelp*")
+ (pop-to-buffer help-for-help-buffer-name)
;; Do incremental search forward.
(isearch-forward nil t))
@@ -1082,6 +1046,488 @@ is currently activated with completion."
minor-modes nil)
(setq minor-modes (cdr minor-modes)))))
result))
+
+
+(defun substitute-command-keys (string)
+ "Substitute key descriptions for command names in STRING.
+Each substring of the form \\\\=[COMMAND] is replaced by either a
+keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND
+is not on any keys. Keybindings will use the face `help-key-binding'.
+
+Each substring of the form \\\\={MAPVAR} is replaced by a summary of
+the value of MAPVAR as a keymap. This summary is similar to the one
+produced by ‘describe-bindings’. The summary ends in two newlines
+(used by the helper function ‘help-make-xrefs’ to find the end of the
+summary).
+
+Each substring of the form \\\\=<MAPVAR> specifies the use of MAPVAR
+as the keymap for future \\\\=[COMMAND] substrings.
+
+Each grave accent \\=` is replaced by left quote, and each apostrophe \\='
+is replaced by right quote. Left and right quote characters are
+specified by ‘text-quoting-style’.
+
+\\\\== quotes the following character and is discarded; thus, \\\\==\\\\== puts \\\\==
+into the output, \\\\==\\[ puts \\[ into the output, and \\\\==\\=` puts \\=` into the
+output.
+
+Return the original STRING if no substitutions are made.
+Otherwise, return a new string."
+ (when (not (null string))
+ ;; KEYMAP is either nil (which means search all the active
+ ;; keymaps) or a specified local map (which means search just that
+ ;; and the global map). If non-nil, it might come from
+ ;; overriding-local-map, or from a \\<mapname> construct in STRING
+ ;; itself.
+ (let ((keymap overriding-local-map)
+ (inhibit-modification-hooks t)
+ (orig-buf (current-buffer)))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (let ((orig-point (point))
+ end-point active-maps
+ close generate-summary)
+ (cond
+ ;; 1. Handle all sequences starting with "\"
+ ((= (following-char) ?\\)
+ (ignore-errors
+ (forward-char 1))
+ (cond
+ ;; 1A. Ignore \= at end of string.
+ ((and (= (+ (point) 1) (point-max))
+ (= (following-char) ?=))
+ (forward-char 1))
+ ;; 1B. \= quotes the next character; thus, to put in \[
+ ;; without its special meaning, use \=\[.
+ ((= (following-char) ?=)
+ (goto-char orig-point)
+ (delete-char 2)
+ (ignore-errors
+ (forward-char 1)))
+ ;; 1C. \[foo] is replaced with the keybinding.
+ ((and (= (following-char) ?\[)
+ (save-excursion
+ (prog1 (search-forward "]" nil t)
+ (setq end-point (- (point) 2)))))
+ (goto-char orig-point)
+ (delete-char 2)
+ (let* ((fun (intern (buffer-substring (point) (1- end-point))))
+ (key (with-current-buffer orig-buf
+ (where-is-internal fun keymap t))))
+ ;; If this a command remap, we need to follow it.
+ (when (and (vectorp key)
+ (> (length key) 1)
+ (eq (aref key 0) 'remap)
+ (symbolp (aref key 1)))
+ (setq fun (aref key 1))
+ (setq key (with-current-buffer orig-buf
+ (where-is-internal fun keymap t))))
+ (if (not key)
+ ;; Function is not on any key.
+ (let ((op (point)))
+ (insert "M-x ")
+ (goto-char (+ end-point 3))
+ (add-text-properties op (point)
+ '( face help-key-binding
+ font-lock-face help-key-binding))
+ (delete-char 1))
+ ;; Function is on a key.
+ (delete-char (- end-point (point)))
+ (insert (help--key-description-fontified key)))))
+ ;; 1D. \{foo} is replaced with a summary of the keymap
+ ;; (symbol-value foo).
+ ;; \<foo> just sets the keymap used for \[cmd].
+ ((and (or (and (= (following-char) ?{)
+ (setq close "}")
+ (setq generate-summary t))
+ (and (= (following-char) ?<)
+ (setq close ">")))
+ (or (save-excursion
+ (prog1 (search-forward close nil t)
+ (setq end-point (- (point) 2))))))
+ (goto-char orig-point)
+ (delete-char 2)
+ (let* ((name (intern (buffer-substring (point) (1- end-point))))
+ this-keymap)
+ (delete-char (- end-point (point)))
+ ;; Get the value of the keymap in TEM, or nil if
+ ;; undefined. Do this in the user's current buffer
+ ;; in case it is a local variable.
+ (with-current-buffer orig-buf
+ ;; This is for computing the SHADOWS arg for
+ ;; describe-map-tree.
+ (setq active-maps (current-active-maps))
+ (when (boundp name)
+ (setq this-keymap (and (keymapp (symbol-value name))
+ (symbol-value name)))))
+ (cond
+ ((null this-keymap)
+ (insert "\nUses keymap "
+ (substitute-command-keys "`")
+ (symbol-name name)
+ (substitute-command-keys "'")
+ ", which is not currently defined.\n")
+ (unless generate-summary
+ (setq keymap nil)))
+ ((not generate-summary)
+ (setq keymap this-keymap))
+ (t
+ ;; Get the list of active keymaps that precede this one.
+ ;; If this one's not active, get nil.
+ (let ((earlier-maps (cdr (memq this-keymap (reverse active-maps)))))
+ (describe-map-tree this-keymap t (nreverse earlier-maps)
+ nil nil t nil nil t))))))))
+ ;; 2. Handle quotes.
+ ((and (eq (text-quoting-style) 'curve)
+ (or (and (= (following-char) ?\`)
+ (prog1 t (insert "‘")))
+ (and (= (following-char) ?')
+ (prog1 t (insert "’")))))
+ (delete-char 1))
+ ((and (eq (text-quoting-style) 'straight)
+ (= (following-char) ?\`))
+ (insert "'")
+ (delete-char 1))
+ ;; 3. Nothing to do -- next character.
+ (t (forward-char 1)))))
+ (buffer-string)))))
+
+(defvar help--keymaps-seen nil)
+(defun describe-map-tree (startmap partial shadow prefix title no-menu
+ transl always-title mention-shadow)
+ "Insert a description of the key bindings in STARTMAP.
+This is followed by the key bindings of all maps reachable
+through STARTMAP.
+
+If PARTIAL is non-nil, omit certain uninteresting commands
+\(such as `undefined').
+
+If SHADOW is non-nil, it is a list of maps; don't mention keys
+which would be shadowed by any of them.
+
+If PREFIX is non-nil, mention only keys that start with PREFIX.
+
+If TITLE is non-nil, is a string to insert at the beginning.
+TITLE should not end with a colon or a newline; we supply that.
+
+If NOMENU is non-nil, then omit menu-bar commands.
+
+If TRANSL is non-nil, the definitions are actually key
+translations so print strings and vectors differently.
+
+If ALWAYS_TITLE is non-nil, print the title even if there are no
+maps to look through.
+
+If MENTION_SHADOW is non-nil, then when something is shadowed by
+SHADOW, don't omit it; instead, mention it but say it is
+shadowed.
+
+Any inserted text ends in two newlines (used by
+`help-make-xrefs')."
+ (let* ((amaps (accessible-keymaps startmap prefix))
+ (orig-maps (if no-menu
+ (progn
+ ;; Delete from MAPS each element that is for
+ ;; the menu bar.
+ (let* ((tail amaps)
+ result)
+ (while tail
+ (let ((elem (car tail)))
+ (when (not (and (>= (length (car elem)) 1)
+ (eq (elt (car elem) 0) 'menu-bar)))
+ (setq result (append result (list elem)))))
+ (setq tail (cdr tail)))
+ result))
+ amaps))
+ (maps orig-maps)
+ (print-title (or maps always-title)))
+ ;; Print title.
+ (when print-title
+ (insert (concat (if title
+ (concat title
+ (if prefix
+ (concat " Starting With "
+ (help--key-description-fontified prefix)))
+ ":\n"))
+ "key binding\n"
+ "--- -------\n")))
+ ;; Describe key bindings.
+ (setq help--keymaps-seen nil)
+ (while (consp maps)
+ (let* ((elt (car maps))
+ (elt-prefix (car elt))
+ (sub-shadows (lookup-key shadow elt-prefix t)))
+ (when (if (natnump sub-shadows)
+ (prog1 t (setq sub-shadows nil))
+ ;; Describe this map iff elt_prefix is bound to a
+ ;; keymap, since otherwise it completely shadows this
+ ;; map.
+ (or (keymapp sub-shadows)
+ (null sub-shadows)
+ (and (consp sub-shadows)
+ (keymapp (car sub-shadows)))))
+ ;; Maps we have already listed in this loop shadow this map.
+ (let ((tail orig-maps))
+ (while (not (equal tail maps))
+ (when (equal (car (car tail)) elt-prefix)
+ (setq sub-shadows (cons (cdr (car tail)) sub-shadows)))
+ (setq tail (cdr tail))))
+ (describe-map (cdr elt) elt-prefix transl partial
+ sub-shadows no-menu mention-shadow)))
+ (setq maps (cdr maps)))
+ (when print-title
+ (insert "\n"))))
+
+(defun help--shadow-lookup (keymap key accept-default remap)
+ "Like `lookup-key', but with command remapping.
+Return nil if the key sequence is too long."
+ ;; Converted from shadow_lookup in keymap.c.
+ (let ((value (lookup-key keymap key accept-default)))
+ (cond ((and (fixnump value) (<= 0 value)))
+ ((and value remap (symbolp value))
+ (or (command-remapping value nil keymap)
+ value))
+ (t value))))
+
+(defvar help--previous-description-column 0)
+(defun help--describe-command (definition)
+ ;; Converted from describe_command in keymap.c.
+ ;; If column 16 is no good, go to col 32;
+ ;; but don't push beyond that--go to next line instead.
+ (let* ((column (current-column))
+ (description-column (cond ((> column 30)
+ (insert "\n")
+ 32)
+ ((or (> column 14)
+ (and (> column 10)
+ (= help--previous-description-column 32)))
+ 32)
+ (t 16))))
+ ;; Avoid using the `help-keymap' face.
+ (let ((op (point)))
+ (indent-to description-column 1)
+ (set-text-properties op (point) '( face nil
+ font-lock-face nil)))
+ (setq help--previous-description-column description-column)
+ (cond ((symbolp definition)
+ (insert (symbol-name definition) "\n"))
+ ((or (stringp definition) (vectorp definition))
+ (insert "Keyboard Macro\n"))
+ ((keymapp definition)
+ (insert "Prefix Command\n"))
+ (t (insert "??\n")))))
+
+(defun help--describe-translation (definition)
+ ;; Converted from describe_translation in keymap.c.
+ ;; Avoid using the `help-keymap' face.
+ (let ((op (point)))
+ (indent-to 16 1)
+ (set-text-properties op (point) '( face nil
+ font-lock-face nil)))
+ (cond ((symbolp definition)
+ (insert (symbol-name definition) "\n"))
+ ((or (stringp definition) (vectorp definition))
+ (insert (key-description definition nil) "\n"))
+ ((keymapp definition)
+ (insert "Prefix Command\n"))
+ (t (insert "??\n"))))
+
+(defun help--describe-map-compare (a b)
+ (let ((a (car a))
+ (b (car b)))
+ (cond ((and (fixnump a) (fixnump b)) (< a b))
+ ;; ((and (not (fixnump a)) (fixnump b)) nil) ; not needed
+ ((and (fixnump a) (not (fixnump b))) t)
+ ((and (symbolp a) (symbolp b))
+ ;; Sort the keystroke names in the "natural" way, with (for
+ ;; instance) "<f2>" coming between "<f1>" and "<f11>".
+ (string-version-lessp (symbol-name a) (symbol-name b)))
+ (t nil))))
+
+(defun describe-map (map prefix transl partial shadow nomenu mention-shadow)
+ "Describe the contents of keymap MAP.
+Assume that this keymap itself is reached by the sequence of
+prefix keys PREFIX (a string or vector).
+
+TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in
+`describe-map-tree'."
+ ;; Converted from describe_map in keymap.c.
+ (let* ((suppress (and partial 'suppress-keymap))
+ (map (keymap-canonicalize map))
+ (tail map)
+ (first t)
+ (describer (if transl
+ #'help--describe-translation
+ #'help--describe-command))
+ done vect)
+ (while (and (consp tail) (not done))
+ (cond ((or (vectorp (car tail)) (char-table-p (car tail)))
+ (help--describe-vector (car tail) prefix describer partial
+ shadow map mention-shadow))
+ ((consp (car tail))
+ (let ((event (caar tail))
+ definition this-shadowed)
+ ;; Ignore bindings whose "prefix" are not really
+ ;; valid events. (We get these in the frames and
+ ;; buffers menu.)
+ (and (or (symbolp event) (fixnump event))
+ (not (and nomenu (eq event 'menu-bar)))
+ ;; Don't show undefined commands or suppressed
+ ;; commands.
+ (setq definition (keymap--get-keyelt (cdr (car tail)) nil))
+ (or (not (symbolp definition))
+ (null (get definition suppress)))
+ ;; Don't show a command that isn't really
+ ;; visible because a local definition of the
+ ;; same key shadows it.
+ (or (not shadow)
+ (let ((tem (help--shadow-lookup shadow (vector event) t nil)))
+ (cond ((null tem) t)
+ ;; If both bindings are keymaps,
+ ;; this key is a prefix key, so
+ ;; don't say it is shadowed.
+ ((and (keymapp definition) (keymapp tem)) t)
+ ;; Avoid generating duplicate
+ ;; entries if the shadowed binding
+ ;; has the same definition.
+ ((and mention-shadow (not (eq tem definition)))
+ (setq this-shadowed t))
+ (t nil))))
+ (eq definition (lookup-key tail (vector event) t))
+ (push (list event definition this-shadowed) vect))))
+ ((eq (car tail) 'keymap)
+ ;; The same keymap might be in the structure twice, if
+ ;; we're using an inherited keymap. So skip anything
+ ;; we've already encountered.
+ (let ((tem (assq tail help--keymaps-seen)))
+ (if (and (consp tem)
+ (equal (car tem) prefix))
+ (setq done t)
+ (push (cons tail prefix) help--keymaps-seen)))))
+ (setq tail (cdr tail)))
+ ;; If we found some sparse map events, sort them.
+ (let ((vect (sort vect 'help--describe-map-compare)))
+ ;; Now output them in sorted order.
+ (while vect
+ (let* ((elem (car vect))
+ (start (car elem))
+ (definition (cadr elem))
+ (shadowed (caddr elem))
+ (end start))
+ (when first
+ (setq help--previous-description-column 0)
+ (insert "\n")
+ (setq first nil))
+ ;; Find consecutive chars that are identically defined.
+ (when (fixnump start)
+ (while (and (cdr vect)
+ (let ((this-event (caar vect))
+ (this-definition (cadar vect))
+ (this-shadowed (caddar vect))
+ (next-event (caar (cdr vect)))
+ (next-definition (cadar (cdr vect)))
+ (next-shadowed (caddar (cdr vect))))
+ (and (eq next-event (1+ this-event))
+ (equal next-definition this-definition)
+ (eq this-shadowed next-shadowed))))
+ (setq vect (cdr vect))
+ (setq end (caar vect))))
+ ;; Now START .. END is the range to describe next.
+ ;; Insert the string to describe the event START.
+ (insert (help--key-description-fontified (vector start) prefix))
+ (when (not (eq start end))
+ (insert " .. " (help--key-description-fontified (vector end) prefix)))
+ ;; Print a description of the definition of this character.
+ ;; Called function will take care of spacing out far enough
+ ;; for alignment purposes.
+ (if transl
+ (help--describe-translation definition)
+ (help--describe-command definition))
+ ;; Print a description of the definition of this character.
+ ;; elt_describer will take care of spacing out far enough for
+ ;; alignment purposes.
+ (when shadowed
+ (goto-char (max (1- (point)) (point-min)))
+ (insert "\n (this binding is currently shadowed)")
+ (goto-char (min (1+ (point)) (point-max)))))
+ ;; Next item in list.
+ (setq vect (cdr vect))))))
+
+;;;; This Lisp version is 100 times slower than its C equivalent:
+;;
+;; (defun help--describe-vector
+;; (vector prefix transl partial shadow entire-map mention-shadow)
+;; "Insert in the current buffer a description of the contents of VECTOR.
+;;
+;; PREFIX a prefix key which leads to the keymap that this vector is
+;; in.
+;;
+;; If PARTIAL, it means do not mention suppressed commands
+;; (that assumes the vector is in a keymap).
+;;
+;; SHADOW is a list of keymaps that shadow this map. If it is
+;; non-nil, look up the key in those maps and don't mention it if it
+;; is defined by any of them.
+;;
+;; ENTIRE-MAP is the vector in which this vector appears.
+;; If the definition in effect in the whole map does not match
+;; the one in this vector, we ignore this one."
+;; ;; Converted from describe_vector in keymap.c.
+;; (let* ((first t)
+;; (idx 0))
+;; (while (< idx (length vector))
+;; (let* ((val (aref vector idx))
+;; (definition (keymap--get-keyelt val nil))
+;; (start-idx idx)
+;; this-shadowed
+;; found-range)
+;; (when (and definition
+;; ;; Don't mention suppressed commands.
+;; (not (and partial
+;; (symbolp definition)
+;; (get definition 'suppress-keymap)))
+;; ;; If this binding is shadowed by some other map,
+;; ;; ignore it.
+;; (not (and shadow
+;; (help--shadow-lookup shadow (vector start-idx) t nil)
+;; (if mention-shadow
+;; (prog1 nil (setq this-shadowed t))
+;; t)))
+;; ;; Ignore this definition if it is shadowed by an earlier
+;; ;; one in the same keymap.
+;; (not (and entire-map
+;; (not (eq (lookup-key entire-map (vector start-idx) t)
+;; definition)))))
+;; (when first
+;; (insert "\n")
+;; (setq first nil))
+;; (when (and prefix (> (length prefix) 0))
+;; (insert (format "%s" prefix)))
+;; (insert (help--key-description-fontified (vector start-idx) prefix))
+;; ;; Find all consecutive characters or rows that have the
+;; ;; same definition.
+;; (while (equal (keymap--get-keyelt (aref vector (1+ idx)) nil)
+;; definition)
+;; (setq found-range t)
+;; (setq idx (1+ idx)))
+;; ;; If we have a range of more than one character,
+;; ;; print where the range reaches to.
+;; (when found-range
+;; (insert " .. ")
+;; (when (and prefix (> (length prefix) 0))
+;; (insert (format "%s" prefix)))
+;; (insert (help--key-description-fontified (vector idx) prefix)))
+;; (if transl
+;; (help--describe-translation definition)
+;; (help--describe-command definition))
+;; (when this-shadowed
+;; (goto-char (1- (point)))
+;; (insert " (binding currently shadowed)")
+;; (goto-char (1+ (point))))))
+;; (setq idx (1+ idx)))))
+
(declare-function x-display-pixel-height "xfns.c" (&optional terminal))
(declare-function x-display-pixel-width "xfns.c" (&optional terminal))
@@ -1431,6 +1877,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(error "Unrecognized usage format"))
(help--make-usage-docstring 'fn arglist)))))
+(declare-function subr-native-lambda-list "data.c")
+
(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
@@ -1446,6 +1894,10 @@ the same names as used in the original source code, when possible."
((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))
+ ((and (featurep 'native-compile)
+ (subrp def)
+ (listp (subr-native-lambda-list def)))
+ (subr-native-lambda-list def))
((or (and (byte-code-function-p def) (integerp (aref def 0)))
(subrp def) (module-function-p def))
(or (when preserve-names
@@ -1563,6 +2015,8 @@ the suggested string to use instead. See
(add-function :after command-error-function
#'help-command-error-confusable-suggestions)
+(define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1")
+
(provide 'help)
diff --git a/lisp/hexl.el b/lisp/hexl.el
index 31b16161510..8bfc1fb89e4 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -93,7 +93,15 @@ as that will override any bit grouping options set here."
"Face used in address area of Hexl mode buffer.")
(defface hexl-ascii-region
- '((t (:inherit header-line)))
+ ;; Copied from `header-line`. We used to inherit from it, but that
+ ;; looks awful when the headerline is given a variable-pitch font or
+ ;; (even worse) a 3D look.
+ '((((class color grayscale) (background light))
+ :background "grey90" :foreground "grey20"
+ :box nil)
+ (((class color grayscale) (background dark))
+ :background "grey20" :foreground "grey90"
+ :box nil))
"Face used in ASCII area of Hexl mode buffer.")
(defvar-local hexl-max-address 0
@@ -201,18 +209,20 @@ as that will override any bit grouping options set here."
(defvar hl-line-face)
;; Variables where the original values are stored to.
-(defvar hexl-mode--old-var-vals ())
-(make-variable-buffer-local 'hexl-mode--old-var-vals)
+(defvar-local hexl-mode--old-var-vals ())
-(defvar hexl-ascii-overlay nil
+(defvar-local hexl-ascii-overlay nil
"Overlay used to highlight ASCII element corresponding to current point.")
-(make-variable-buffer-local 'hexl-ascii-overlay)
(defvar hexl-font-lock-keywords
- '(("^\\([0-9a-f]+:\\).\\{40\\} \\(.+$\\)"
- ;; "^\\([0-9a-f]+:\\).+ \\(.+$\\)"
+ '(("^\\([0-9a-f]+:\\)\\( \\).\\{39\\}\\( \\)\\(.+$\\)"
+ ;; "^\\([0-9a-f]+:\\).+ \\(.+$\\)"v
(1 'hexl-address-region t t)
- (2 'hexl-ascii-region t t)))
+ ;; If `hexl-address-region' is using a variable-pitch font, the
+ ;; rest of the line isn't naturally aligned, so align them by hand.
+ (2 '(face nil display (space :align-to 10)))
+ (3 '(face nil display (space :align-to 51)))
+ (4 'hexl-ascii-region t t)))
"Font lock keywords used in `hexl-mode'.")
(defun hexl-rulerize (string bits)
@@ -293,22 +303,30 @@ also supported.
There are several ways to change text in hexl mode:
-ASCII characters (character between space (0x20) and tilde (0x7E)) are
-bound to self-insert so you can simply type the character and it will
-insert itself (actually overstrike) into the buffer.
+Self-inserting characters are bound to `hexl-self-insert' so you
+can simply type the character and it will insert itself (actually
+overstrike) into the buffer. However, inserting non-ASCII characters
+requires caution: the buffer's coding-system should correspond to
+the encoding on disk, and multibyte characters should be inserted
+with cursor on the first byte of a multibyte sequence whose length
+is identical to the length of the multibyte sequence to be inserted,
+otherwise this could produce invalid multibyte sequences. Non-ASCII
+characters in ISO-2022 encodings should preferably inserted byte by
+byte, to avoid problems caused by the designation sequences before
+the actual characters.
\\[hexl-quoted-insert] followed by another keystroke allows you to insert the key even if
it isn't bound to self-insert. An octal number can be supplied in place
of another key to insert the octal number's ASCII representation.
-\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is between 0 and 0xFF)
-into the buffer at the current point.
+\\[hexl-insert-hex-char] will insert a given hexadecimal value
+into the buffer at the current address.
-\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0 and 0377)
-into the buffer at the current point.
+\\[hexl-insert-octal-char] will insert a given octal value
+into the buffer at the current address.
-\\[hexl-insert-decimal-char] will insert a given decimal value (if it is between 0 and 255)
-into the buffer at the current point.
+\\[hexl-insert-decimal-char] will insert a given decimal value
+into the buffer at the current address..
\\[hexl-mode-exit] will exit `hexl-mode'.
@@ -322,26 +340,16 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(unless (eq major-mode 'hexl-mode)
(let ((modified (buffer-modified-p))
(inhibit-read-only t)
- (original-point (- (point) (point-min))))
- (and (eobp) (not (bobp))
- (setq original-point (1- original-point)))
+ (point-offset (bufferpos-to-filepos (point) 'exact)))
;; If `hexl-mode' is invoked with an argument the buffer is assumed to
;; be in hexl format.
(when (memq arg '(1 nil))
- ;; If the buffer's EOL type is -dos, we need to account for
- ;; extra CR characters added when hexlify-buffer writes the
- ;; buffer to a file.
- ;; FIXME: This doesn't take into account multibyte coding systems.
- (when (eq (coding-system-eol-type buffer-file-coding-system) 1)
- (setq original-point (+ (count-lines (point-min) (point))
- original-point))
- (or (bolp) (setq original-point (1- original-point))))
(hexlify-buffer)
(restore-buffer-modified-p modified))
(setq hexl-max-address
(+ (* (/ (1- (buffer-size)) (hexl-line-displen)) 16) 15))
(condition-case nil
- (hexl-goto-address original-point)
+ (hexl-goto-address point-offset)
(error nil)))
(let ((max-address hexl-max-address))
@@ -362,13 +370,14 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(setq-local font-lock-defaults '(hexl-font-lock-keywords t))
+ (setq-local font-lock-extra-managed-props '(display))
(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.
- (add-function :before-until (local 'eldoc-documentation-function)
- #'hexl-print-current-point-info)
+ (add-hook 'eldoc-documentation-functions
+ #'hexl-print-current-point-info nil t)
(eldoc-add-command-completions "hexl-")
(eldoc-remove-command "hexl-save-buffer"
"hexl-current-address")
@@ -429,7 +438,8 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(defun hexl-find-file (filename)
"Edit file FILENAME as a binary file in hex dump format.
Switch to a buffer visiting file FILENAME, creating one if none exists,
-and edit the file in `hexl-mode'."
+and edit the file in `hexl-mode'. The buffer's coding-system will be
+no-conversion, unlike if you visit it normally and then invoke `hexl-mode'."
(interactive
(list
(let ((completion-ignored-extensions nil))
@@ -455,6 +465,8 @@ and edit the file in `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)
+ (remove-hook 'eldoc-documentation-functions
+ #'hexl-print-current-point-info t)
(setq major-mode 'fundamental-mode)
(hexl-mode)))
@@ -465,17 +477,11 @@ With arg, don't unhexlify buffer."
(if (or (eq arg 1) (not arg))
(let ((modified (buffer-modified-p))
(inhibit-read-only t)
- (original-point (1+ (hexl-current-address))))
+ (point-offset (hexl-current-address)))
(dehexlify-buffer)
(remove-hook 'write-contents-functions #'hexl-save-buffer t)
(restore-buffer-modified-p modified)
- (goto-char original-point)
- ;; Maybe adjust point for the removed CR characters.
- (when (eq (coding-system-eol-type buffer-file-coding-system) 1)
- (setq original-point (- original-point
- (count-lines (point-min) (point))))
- (or (bobp) (setq original-point (1+ original-point))))
- (goto-char original-point)))
+ (goto-char (filepos-to-bufferpos point-offset 'exact))))
(remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t)
(major-mode-restore))
@@ -486,11 +492,11 @@ Ask the user for confirmation."
(if (y-or-n-p "Convert contents back to binary format? ")
(let ((modified (buffer-modified-p))
(inhibit-read-only t)
- (original-point (1+ (hexl-current-address))))
+ (point-offset (hexl-current-address)))
(dehexlify-buffer)
(remove-hook 'write-contents-functions #'hexl-save-buffer t)
(restore-buffer-modified-p modified)
- (goto-char original-point))))
+ (goto-char (filepos-to-bufferpos point-offset 'exact)))))
(defun hexl-current-address (&optional validate)
"Return current hexl-address."
@@ -513,7 +519,7 @@ Ask the user for confirmation."
(message "Current address is %d/0x%08x" hexl-address hexl-address))
hexl-address))
-(defun hexl-print-current-point-info ()
+(defun hexl-print-current-point-info (&rest _ignored)
"Return current hexl-address in string.
This function is intended to be used as eldoc callback."
(let ((addr (hexl-current-address)))
@@ -701,16 +707,16 @@ With prefix arg N, puts point N bytes of the way from the true beginning."
(defun hexl-end-of-line ()
"Goto end of line in Hexl mode."
(interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 15)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
+ (hexl-goto-address (min hexl-max-address (logior (hexl-current-address) 15))))
(defun hexl-scroll-down (arg)
"Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
(interactive "P")
(setq arg (if (null arg)
- (1- (window-height))
+ (- (window-height)
+ 1
+ (if ruler-mode 1 0)
+ next-screen-context-lines)
(prefix-numeric-value arg)))
(hexl-scroll-up (- arg)))
@@ -719,7 +725,10 @@ With prefix arg N, puts point N bytes of the way from the true beginning."
If there's no byte at the target address, move to the first or last line."
(interactive "P")
(setq arg (if (null arg)
- (1- (window-height))
+ (- (window-height)
+ 1
+ (if ruler-mode 1 0)
+ next-screen-context-lines)
(prefix-numeric-value arg)))
(let* ((movement (* arg 16))
(address (hexl-current-address))
@@ -749,7 +758,7 @@ If there's no byte at the target address, move to the first or last line."
"Go to end of 1KB boundary."
(interactive)
(hexl-goto-address
- (max hexl-max-address (logior (hexl-current-address) 1023))))
+ (min hexl-max-address (logior (hexl-current-address) 1023))))
(defun hexl-beginning-of-512b-page ()
"Go to beginning of 512 byte boundary."
@@ -760,7 +769,7 @@ If there's no byte at the target address, move to the first or last line."
"Go to end of 512 byte boundary."
(interactive)
(hexl-goto-address
- (max hexl-max-address (logior (hexl-current-address) 511))))
+ (min hexl-max-address (logior (hexl-current-address) 511))))
(defun hexl-quoted-insert (arg)
"Read next input character and insert it.
@@ -863,14 +872,27 @@ This discards the buffer's undo information."
"Insert a possibly multibyte character CH NUM times.
Non-ASCII characters are first encoded with `buffer-file-coding-system',
-and their encoded form is inserted byte by byte."
+and their encoded form is inserted byte by byte. Note that if the
+hexl buffer was produced by `hexl-find-file', its coding-system
+is no-conversion.
+
+Inserting non-ASCII characters requires caution: the buffer's
+coding-system should correspond to the encoding on disk, and
+multibyte characters should be inserted with cursor on the first
+byte of a multibyte sequence whose length is identical to the
+length of the multibyte sequence to be inserted, otherwise this
+could produce invalid multibyte sequences. Non-ASCII characters
+in ISO-2022 encodings should preferably inserted byte by byte, to
+avoid problems caused by the designation sequences before the
+actual characters."
(let ((charset (char-charset ch))
(coding (if (or (null buffer-file-coding-system)
;; coding-system-type equals t means undecided.
(eq (coding-system-type buffer-file-coding-system) t))
(default-value 'buffer-file-coding-system)
buffer-file-coding-system)))
- (cond ((and (> ch 0) (< ch 256))
+ (cond ((and (>= ch 0) (< ch 256)
+ (coding-system-get coding :ascii-compatible-p))
(hexl-insert-char ch num))
((eq charset 'unknown)
(error
@@ -887,7 +909,7 @@ and their encoded form is inserted byte by byte."
(when (null encoded)
(setq internal (encode-coding-string internal 'utf-8-emacs)
internal-hex
- (mapconcat (function (lambda (c) (format "%x" c)))
+ (mapconcat (lambda (c) (format "%x" c))
internal " "))
(if (yes-or-no-p
(format-message
@@ -900,7 +922,7 @@ and their encoded form is inserted byte by byte."
(substitute-command-keys "try \\[hexl-insert-hex-string]"))))
(while (> num 0)
(mapc
- (function (lambda (c) (hexl-insert-char c 1))) encoded)
+ (lambda (c) (hexl-insert-char c 1)) encoded)
(setq num (1- num))))))))
(defun hexl-self-insert-command (arg)
@@ -908,7 +930,19 @@ and their encoded form is inserted byte by byte."
Interactively, with a numeric argument, insert this character that many times.
Non-ASCII characters are first encoded with `buffer-file-coding-system',
-and their encoded form is inserted byte by byte."
+and their encoded form is inserted byte by byte. Note that if the
+hexl buffer was produced by `hexl-find-file', its coding-system
+is no-conversion.
+
+Inserting non-ASCII characters requires caution: the buffer's
+coding-system should correspond to the encoding on disk, and
+multibyte characters should be inserted with cursor on the first
+byte of a multibyte sequence whose length is identical to the
+length of the multibyte sequence to be inserted, otherwise this
+could produce invalid multibyte sequences. Non-ASCII characters
+in ISO-2022 encodings should preferably inserted byte by byte, to
+avoid problems caused by the designation sequences before the
+actual characters."
(interactive "p")
(hexl-insert-multibyte-char last-command-event arg))
@@ -935,7 +969,7 @@ CH must be a unibyte character whose value is between 0 and 255."
(goto-char ascii-position)
(delete-char 1)
(insert (hexl-printable-character ch))
- (or (eq address hexl-max-address)
+ (or (= address hexl-max-address)
(setq address (1+ address)))
(hexl-goto-address address)
(if at-ascii-position
@@ -948,7 +982,21 @@ CH must be a unibyte character whose value is between 0 and 255."
;; hex conversion
(defun hexl-insert-hex-char (arg)
- "Insert a character given by its hexadecimal code ARG times at point."
+ "Insert a character given by its hexadecimal code ARG times at point.
+
+Values above 0xFF are treated as multibyte characters, and first encoded
+using `buffer-file-coding-system'. Note that if the hexl buffer was
+produced by `hexl-find-file', its coding-system is no-conversion.
+
+Inserting non-ASCII characters requires caution: the buffer's
+coding-system should correspond to the encoding on disk, and
+multibyte characters should be inserted with cursor on the first
+byte of a multibyte sequence whose length is identical to the
+length of the multibyte sequence to be inserted, otherwise this
+could produce invalid multibyte sequences. Non-ASCII characters
+in ISO-2022 encodings should preferably inserted byte by byte, to
+avoid problems caused by the designation sequences before the
+actual characters."
(interactive "p")
(let ((num (hexl-hex-string-to-integer (read-string "Hex number: "))))
(if (< num 0)
@@ -981,7 +1029,21 @@ Embedded whitespace, dashes, and periods in the string are ignored."
(setq arg (- arg 1)))))
(defun hexl-insert-decimal-char (arg)
- "Insert a character given by its decimal code ARG times at point."
+ "Insert a character given by its decimal code ARG times at point.
+
+Values above 256 are treated as multibyte characters, and first encoded
+using `buffer-file-coding-system'. Note that if the hexl buffer was
+produced by `hexl-find-file', its coding-system is no-conversion.
+
+Inserting non-ASCII characters requires caution: the buffer's
+coding-system should correspond to the encoding on disk, and
+multibyte characters should be inserted with cursor on the first
+byte of a multibyte sequence whose length is identical to the
+length of the multibyte sequence to be inserted, otherwise this
+could produce invalid multibyte sequences. Non-ASCII characters
+in ISO-2022 encodings should preferably inserted byte by byte, to
+avoid problems caused by the designation sequences before the
+actual characters."
(interactive "p")
(let ((num (string-to-number (read-string "Decimal Number: "))))
(if (< num 0)
@@ -989,7 +1051,21 @@ Embedded whitespace, dashes, and periods in the string are ignored."
(hexl-insert-multibyte-char num arg))))
(defun hexl-insert-octal-char (arg)
- "Insert a character given by its octal code ARG times at point."
+ "Insert a character given by its octal code ARG times at point.
+
+Values above \377 are treated as multibyte characters, and first encoded
+using `buffer-file-coding-system'. Note that if the hexl buffer was
+produced by `hexl-find-file', its coding-system is no-conversion.
+
+Inserting non-ASCII characters requires caution: the buffer's
+coding-system should correspond to the encoding on disk, and
+multibyte characters should be inserted with cursor on the first
+byte of a multibyte sequence whose length is identical to the
+length of the multibyte sequence to be inserted, otherwise this
+could produce invalid multibyte sequences. Non-ASCII characters
+in ISO-2022 encodings should preferably inserted byte by byte, to
+avoid problems caused by the designation sequences before the
+actual characters."
(interactive "p")
(let ((num (hexl-octal-string-to-integer (read-string "Octal Number: "))))
(if (< num 0)
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
index 4bf32172de7..b7de65f5b78 100644
--- a/lisp/hfy-cmap.el
+++ b/lisp/hfy-cmap.el
@@ -1,4 +1,4 @@
-;;; hfy-cmap.el --- Fallback color name -> rgb mapping for `htmlfontify'
+;;; hfy-cmap.el --- Fallback color name -> rgb mapping for `htmlfontify' -*- lexical-binding:t -*-
;; Copyright (C) 2002-2003, 2009-2021 Free Software Foundation, Inc.
@@ -809,6 +809,22 @@
(defconst hfy-rgb-regex
"^\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\(.+\\)\\s-*$")
+(defun hfy-cmap--parse-buffer (buffer)
+ (with-current-buffer buffer
+ (let ((end-of-rgb 0)
+ result)
+ (goto-char (point-min))
+ (htmlfontify-unload-rgb-file)
+ (while (/= end-of-rgb 1)
+ (if (looking-at hfy-rgb-regex)
+ (push (list (match-string 4)
+ (string-to-number (match-string 1))
+ (string-to-number (match-string 2))
+ (string-to-number (match-string 3)))
+ result))
+ (setq end-of-rgb (forward-line)))
+ result)))
+
;;;###autoload
(defun htmlfontify-load-rgb-file (&optional file)
"Load an X11 style rgb.txt FILE.
@@ -818,25 +834,14 @@ Loads the variable `hfy-rgb-txt-color-map', which is used by
(interactive
(list
(read-file-name "rgb.txt (equivalent) file: " "" nil t (hfy-rgb-file))))
- (let ((rgb-buffer nil)
- (end-of-rgb 0)
- (rgb-txt nil))
- (if (and (setq rgb-txt (or file (hfy-rgb-file)))
- (file-readable-p rgb-txt))
- (with-current-buffer
- (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn))
- (goto-char (point-min))
- (htmlfontify-unload-rgb-file)
- (while (/= end-of-rgb 1)
- (if (looking-at hfy-rgb-regex)
- (setq hfy-rgb-txt-color-map
- (cons (list (match-string 4)
- (string-to-number (match-string 1))
- (string-to-number (match-string 2))
- (string-to-number (match-string 3)))
- hfy-rgb-txt-color-map)) )
- (setq end-of-rgb (forward-line)))
- (kill-buffer rgb-buffer)))))
+ (let ((rgb-buffer nil)
+ (rgb-txt (or file (hfy-rgb-file))))
+ (when (and rgb-txt
+ (file-readable-p rgb-txt))
+ (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn))
+ (when-let ((result (hfy-cmap--parse-buffer rgb-buffer)))
+ (setq hfy-rgb-txt-color-map result))
+ (kill-buffer rgb-buffer))))
(defun htmlfontify-unload-rgb-file ()
"Unload the current color name -> rgb translation map."
diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index c525016a076..37b88b318de 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -87,8 +87,6 @@
;;; Code:
-(require 'font-lock)
-
(defgroup hi-lock nil
"Interactively add and remove font-lock patterns for highlighting text."
:link '(custom-manual "(emacs)Highlight Interactively")
@@ -102,7 +100,7 @@ of functions `hi-lock-mode' and `hi-lock-find-patterns'."
:type 'integer
:group 'hi-lock)
-(defcustom hi-lock-highlight-range 200000
+(defcustom hi-lock-highlight-range 2000000
"Size of area highlighted by hi-lock when font-lock not active.
Font-lock is not active in buffers that do their own highlighting,
such as the buffer created by `list-colors-display'. In those buffers
@@ -113,7 +111,7 @@ highlighting will be applied throughout the buffer."
:group 'hi-lock)
(defcustom hi-lock-exclude-modes
- '(rmail-mode mime/viewer-mode gnus-article-mode)
+ '(rmail-mode mime/viewer-mode gnus-article-mode term-mode)
"List of major modes in which hi-lock will not run.
For security reasons since font lock patterns can specify function
calls."
@@ -233,17 +231,15 @@ by cycling through the faces in `hi-lock-face-defaults'."
"Patterns provided to hi-lock by user. Should not be changed.")
(put 'hi-lock-interactive-patterns 'permanent-local t)
-(define-obsolete-variable-alias 'hi-lock-face-history
- 'hi-lock-face-defaults "23.1")
+(defvar-local hi-lock-interactive-lighters nil
+ "Human-readable lighters for `hi-lock-interactive-patterns'.")
+(put 'hi-lock-interactive-lighters 'permanent-local t)
+
(defvar hi-lock-face-defaults
'("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine"
"hi-black-b" "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
"Default faces for hi-lock interactive functions.")
-(define-obsolete-variable-alias 'hi-lock-regexp-history
- 'regexp-history
- "23.1")
-
(defvar hi-lock-file-patterns-prefix "Hi-lock"
"String used to identify hi-lock patterns at the start of files.")
@@ -258,39 +254,25 @@ that older functionality. This variable avoids multiple reminders.")
Assumption is made if `hi-lock-mode' used in the *scratch* buffer while
a library is being loaded.")
-(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 [highlight-symbol-at-point]
- '(menu-item "Highlight Symbol at Point" highlight-symbol-at-point
- :help "Highlight symbol found near point without prompting."))
-
- (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.")
+(easy-menu-define hi-lock-menu nil
+ "Menu for hi-lock mode."
+ '("Hi Lock"
+ ["Highlight Regexp..." highlight-regexp
+ :help "Highlight text matching PATTERN (a regexp)."]
+ ["Highlight Phrase..." highlight-phrase
+ :help "Highlight text matching PATTERN (a regexp processed to match phrases)."]
+ ["Highlight Lines..." highlight-lines-matching-regexp
+ :help "Highlight lines containing match of PATTERN (a regexp)."]
+ ["Highlight Symbol at Point" highlight-symbol-at-point
+ :help "Highlight symbol found near point without prompting."]
+ ["Remove Highlighting..." unhighlight-regexp
+ :help "Remove previously entered highlighting pattern."
+ :enable hi-lock-interactive-patterns]
+ ["Patterns to Buffer" hi-lock-write-interactive-patterns
+ :help "Insert interactively added REGEXPs into buffer at point."
+ :enable hi-lock-interactive-patterns]
+ ["Patterns from Buffer" hi-lock-find-patterns
+ :help "Use patterns (if any) near top of buffer."]))
(defvar hi-lock-map
(let ((map (make-sparse-keymap "Hi Lock")))
@@ -385,13 +367,7 @@ Hi-lock: end is found. A mode is excluded if it's in the list
(warn "%s"
"Possible archaic use of (hi-lock-mode).
Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers,
-use (hi-lock-mode 1) for individual buffers. For compatibility with Emacs
-versions before 22 use the following in your init file:
-
- (if (functionp 'global-hi-lock-mode)
- (global-hi-lock-mode 1)
- (hi-lock-mode 1))
-")))
+use (hi-lock-mode 1) for individual buffers.")))
(if hi-lock-mode
;; Turned on.
(progn
@@ -406,7 +382,8 @@ versions before 22 use the following in your init file:
hi-lock-file-patterns)
(when hi-lock-interactive-patterns
(font-lock-remove-keywords nil hi-lock-interactive-patterns)
- (setq hi-lock-interactive-patterns nil))
+ (setq hi-lock-interactive-patterns nil
+ hi-lock-interactive-lighters nil))
(when hi-lock-file-patterns
(font-lock-remove-keywords nil hi-lock-file-patterns)
(setq hi-lock-file-patterns nil))
@@ -437,6 +414,9 @@ of text in those lines.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
Use the global history list for FACE.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type."
@@ -450,19 +430,29 @@ highlighting will not update as you type."
(hi-lock-set-pattern
;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
;; or a trailing $ in REGEXP will be interpreted correctly.
- (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face))
+ (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil nil
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)))
;;;###autoload
(defalias 'highlight-regexp 'hi-lock-face-buffer)
;;;###autoload
-(defun hi-lock-face-buffer (regexp &optional face subexp)
+(defun hi-lock-face-buffer (regexp &optional face subexp lighter)
"Set face of each match of REGEXP to FACE.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
Use the global history list for FACE. Limit face setting to the
corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
+LIGHTER is a human-readable string that can be used to select
+a regexp to unhighlight by its name instead of selecting a possibly
+complex regexp or closure.
+
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type. The Font Lock mode
@@ -472,12 +462,25 @@ the major mode specifies support for Font Lock."
(interactive
(list
(hi-lock-regexp-okay
- (read-regexp "Regexp to highlight" 'regexp-history-last))
+ (read-regexp "Regexp to highlight"
+ (if (use-region-p)
+ (prog1
+ (buffer-substring (region-beginning)
+ (region-end))
+ (deactivate-mark))
+ 'regexp-history-last)))
(hi-lock-read-face-name)
current-prefix-arg))
+ (when (stringp face)
+ (setq face (intern face)))
(or (facep face) (setq face 'hi-yellow))
(unless hi-lock-mode (hi-lock-mode 1))
- (hi-lock-set-pattern regexp face subexp))
+ (hi-lock-set-pattern
+ regexp face subexp lighter
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)
+ search-spaces-regexp))
;;;###autoload
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -487,9 +490,9 @@ the major mode specifies support for Font Lock."
Interactively, prompt for REGEXP using `read-regexp', then FACE.
Use the global history list for FACE.
-When called interactively, replace whitespace in user-provided
-regexp with arbitrary whitespace, and make initial lower-case
-letters case-insensitive, before highlighting with `hi-lock-set-pattern'.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'.
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
@@ -500,12 +503,16 @@ the major mode specifies support for Font Lock."
(interactive
(list
(hi-lock-regexp-okay
- (hi-lock-process-phrase
- (read-regexp "Phrase to highlight" 'regexp-history-last)))
+ (read-regexp "Phrase to highlight" 'regexp-history-last))
(hi-lock-read-face-name)))
(or (facep face) (setq face 'hi-yellow))
(unless hi-lock-mode (hi-lock-mode 1))
- (hi-lock-set-pattern regexp face))
+ (hi-lock-set-pattern
+ regexp face nil nil
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)
+ search-whitespace-regexp))
;;;###autoload
(defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point)
@@ -516,6 +523,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting,
unless you use a prefix argument.
Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
This uses Font lock mode if it is enabled; otherwise it uses overlays,
in which case the highlighting will not update as you type. The Font
Lock mode is considered \"enabled\" in a buffer if its `major-mode'
@@ -528,7 +538,11 @@ the major mode specifies support for Font Lock."
(face (hi-lock-read-face-name)))
(or (facep face) (setq face 'hi-yellow))
(unless hi-lock-mode (hi-lock-mode 1))
- (hi-lock-set-pattern regexp face)))
+ (hi-lock-set-pattern
+ regexp face nil nil
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search))))
(defun hi-lock-keyword->face (keyword)
(cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...).
@@ -542,13 +556,16 @@ the major mode specifies support for Font Lock."
(let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp)))
(when regexp (push regexp regexps)))
;; With font-locking on, check if the cursor is on a highlighted text.
- (let ((face-after (get-text-property (point) 'face))
- (face-before
- (unless (bobp) (get-text-property (1- (point)) 'face)))
- (faces (mapcar #'hi-lock-keyword->face
- hi-lock-interactive-patterns)))
- (unless (memq face-before faces) (setq face-before nil))
- (unless (memq face-after faces) (setq face-after nil))
+ (let* ((faces-after (get-text-property (point) 'face))
+ (faces-before
+ (unless (bobp) (get-text-property (1- (point)) 'face)))
+ ;; Use proper-list-p to handle faces like (foreground-color . "red3")
+ (faces-after (if (proper-list-p faces-after) faces-after (list faces-after)))
+ (faces-before (if (proper-list-p faces-before) faces-before (list faces-before)))
+ (faces (mapcar #'hi-lock-keyword->face
+ hi-lock-interactive-patterns))
+ (face-after (seq-some (lambda (face) (car (memq face faces))) faces-after))
+ (face-before (seq-some (lambda (face) (car (memq face faces))) faces-before)))
(when (and face-before face-after (not (eq face-before face-after)))
(setq face-before nil))
(when (or face-after face-before)
@@ -566,7 +583,8 @@ the major mode specifies support for Font Lock."
;; highlighted text at point. Use this later in
;; during completing-read.
(dolist (hi-lock-pattern hi-lock-interactive-patterns)
- (let ((regexp (car hi-lock-pattern)))
+ (let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters))
+ (car hi-lock-pattern))))
(if (string-match regexp hi-text)
(push regexp regexps)))))))
regexps))
@@ -598,12 +616,15 @@ then remove all hi-lock highlighting."
'keymap
(cons "Select Pattern to Unhighlight"
(mapcar (lambda (pattern)
- (list (car pattern)
- (format
- "%s (%s)" (car pattern)
- (hi-lock-keyword->face pattern))
- (cons nil nil)
- (car pattern)))
+ (let ((lighter
+ (or (car (rassq pattern hi-lock-interactive-lighters))
+ (car pattern))))
+ (list lighter
+ (format
+ "%s (%s)" lighter
+ (hi-lock-keyword->face pattern))
+ (cons nil nil)
+ lighter)))
hi-lock-interactive-patterns))))
;; If the user clicks outside the menu, meaning that they
;; change their mind, x-popup-menu returns nil, and
@@ -614,17 +635,25 @@ then remove all hi-lock highlighting."
(t
;; Un-highlighting triggered via keyboard action.
(unless hi-lock-interactive-patterns
- (error "No highlighting to remove"))
+ (user-error "No highlighting to remove"))
;; Infer the regexp to un-highlight based on cursor position.
(let* ((defaults (or (hi-lock--regexps-at-point)
- (mapcar #'car hi-lock-interactive-patterns))))
+ (mapcar (lambda (pattern)
+ (or (car (rassq pattern hi-lock-interactive-lighters))
+ (car pattern)))
+ hi-lock-interactive-patterns))))
(list
- (completing-read (if (null defaults)
- "Regexp to unhighlight: "
- (format "Regexp to unhighlight (default %s): "
- (car defaults)))
- hi-lock-interactive-patterns
+ (completing-read (format-prompt "Regexp to unhighlight" (car defaults))
+ (mapcar (lambda (pattern)
+ (cons (or (car (rassq pattern hi-lock-interactive-lighters))
+ (car pattern))
+ (cdr pattern)))
+ hi-lock-interactive-patterns)
nil t nil nil defaults))))))
+
+ (when (assoc regexp hi-lock-interactive-lighters)
+ (setq regexp (cadr (assoc regexp hi-lock-interactive-lighters))))
+
(dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
(list (assoc regexp hi-lock-interactive-patterns))))
(when keyword
@@ -641,7 +670,11 @@ then remove all hi-lock highlighting."
(setq hi-lock-interactive-patterns
(delq keyword hi-lock-interactive-patterns))
(remove-overlays
- nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
+ nil nil 'hi-lock-overlay-regexp
+ (or (car (rassq keyword hi-lock-interactive-lighters))
+ (hi-lock--hashcons (car keyword))))
+ (setq hi-lock-interactive-lighters
+ (rassq-delete-all keyword hi-lock-interactive-lighters))
(font-lock-flush))))
;;;###autoload
@@ -653,7 +686,7 @@ Interactively added patterns are those normally specified using
be found in variable `hi-lock-interactive-patterns'."
(interactive)
(if (null hi-lock-interactive-patterns)
- (error "There are no interactive patterns"))
+ (user-error "There are no interactive patterns"))
(let ((beg (point)))
(mapc
(lambda (pattern)
@@ -667,25 +700,6 @@ be found in variable `hi-lock-interactive-patterns'."
;; Implementation Functions
-(defun hi-lock-process-phrase (phrase)
- "Convert regexp PHRASE to a regexp that matches phrases.
-
-Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
-and initial lower-case letters made case insensitive."
- (let ((mod-phrase nil))
- ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161)
- (setq mod-phrase
- (replace-regexp-in-string
- "\\(^\\|\\s-\\)\\([a-z]\\)"
- (lambda (m) (format "%s[%s%s]"
- (match-string 1 m)
- (upcase (match-string 2 m))
- (match-string 2 m))) phrase))
- ;; FIXME fragile; better to use search-spaces-regexp?
- (setq mod-phrase
- (replace-regexp-in-string
- "\\s-+" "[ \t\n]+" mod-phrase nil t))))
-
(defun hi-lock-regexp-okay (regexp)
"Return REGEXP if it appears suitable for a font-lock pattern.
@@ -716,8 +730,7 @@ with completion and history."
(if (and hi-lock-auto-select-face (not current-prefix-arg))
(setq face (or (pop hi-lock--unused-faces) (car defaults)))
(setq face (completing-read
- (format "Highlight using face (default %s): "
- (car defaults))
+ (format-prompt "Highlight using face" (car defaults))
obarray 'facep t nil 'face-name-history defaults))
;; Update list of un-used faces.
(setq hi-lock--unused-faces (remove face hi-lock--unused-faces))
@@ -725,19 +738,27 @@ with completion and history."
(add-to-list 'hi-lock-face-defaults face t))
(intern face)))
-(defun hi-lock-set-pattern (regexp face &optional subexp)
+(defun hi-lock-set-pattern (regexp face &optional subexp lighter case-fold spaces-regexp)
"Highlight SUBEXP of REGEXP with face FACE.
If omitted or nil, SUBEXP defaults to zero, i.e. the entire
-REGEXP is highlighted."
+REGEXP is highlighted. LIGHTER is a human-readable string to
+display instead of a regexp. Non-nil CASE-FOLD ignores case.
+SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
;; Hashcons the regexp, so it can be passed to remove-overlays later.
(setq regexp (hi-lock--hashcons regexp))
(setq subexp (or subexp 0))
- (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend)))
+ (let ((pattern (list (lambda (limit)
+ (let ((case-fold-search case-fold)
+ (search-spaces-regexp spaces-regexp))
+ (re-search-forward regexp limit t)))
+ (list subexp (list 'quote face) 'prepend)))
(no-matches t))
;; Refuse to highlight a text that is already highlighted.
- (if (assoc regexp hi-lock-interactive-patterns)
+ (if (or (assoc regexp hi-lock-interactive-patterns)
+ (assoc (or lighter regexp) hi-lock-interactive-lighters))
(add-to-list 'hi-lock--unused-faces (face-name face))
(push pattern hi-lock-interactive-patterns)
+ (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters)
(if (and font-lock-mode (font-lock-specified-p major-mode))
(progn
(font-lock-add-keywords nil (list pattern) t)
@@ -749,7 +770,9 @@ REGEXP is highlighted."
(- range-min (max 0 (- range-max (point-max))))))
(search-end
(min (point-max)
- (+ range-max (max 0 (- (point-min) range-min))))))
+ (+ range-max (max 0 (- (point-min) range-min)))))
+ (case-fold-search case-fold)
+ (search-spaces-regexp spaces-regexp))
(save-excursion
(goto-char search-start)
(while (re-search-forward regexp search-end t)
@@ -757,13 +780,17 @@ REGEXP is highlighted."
(let ((overlay (make-overlay (match-beginning subexp)
(match-end subexp))))
(overlay-put overlay 'hi-lock-overlay t)
- (overlay-put overlay 'hi-lock-overlay-regexp regexp)
+ (overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp))
(overlay-put overlay 'face face))
(goto-char (match-end 0)))
(when no-matches
(add-to-list 'hi-lock--unused-faces (face-name face))
(setq hi-lock-interactive-patterns
- (cdr hi-lock-interactive-patterns)))))))))
+ (cdr hi-lock-interactive-patterns)
+ hi-lock-interactive-lighters
+ (cdr hi-lock-interactive-lighters))))
+ (when (or (> search-start (point-min)) (< search-end (point-max)))
+ (message "Hi-lock added only in range %d-%d" search-start search-end)))))))
(defun hi-lock-set-file-patterns (patterns)
"Replace file patterns list with PATTERNS and refontify."
diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el
index 4699f8abe8c..8919e982383 100644
--- a/lisp/hilit-chg.el
+++ b/lisp/hilit-chg.el
@@ -1,4 +1,4 @@
-;;; hilit-chg.el --- minor mode displaying buffer changes with special face
+;;; hilit-chg.el --- minor mode displaying buffer changes with special face -*- lexical-binding: t -*-
;; Copyright (C) 1998, 2000-2021 Free Software Foundation, Inc.
@@ -68,8 +68,7 @@
;; (defun my-highlight-changes-mode-hook ()
;; (if highlight-changes-mode
;; (add-hook 'write-file-functions 'highlight-changes-rotate-faces nil t)
-;; (remove-hook 'write-file-functions 'highlight-changes-rotate-faces t)
-;; ))
+;; (remove-hook 'write-file-functions 'highlight-changes-rotate-faces t)))
;; Automatically enabling Highlight Changes mode
@@ -114,16 +113,16 @@
;; Possible bindings:
-;; (global-set-key '[C-right] 'highlight-changes-next-change)
-;; (global-set-key '[C-left] 'highlight-changes-previous-change)
+;; (global-set-key '[C-right] #'highlight-changes-next-change)
+;; (global-set-key '[C-left] #'highlight-changes-previous-change)
;;
;; Other interactive functions (that could be bound if desired):
-;; highlight-changes-mode
-;; highlight-changes-toggle-visibility
-;; highlight-changes-remove-highlight
-;; highlight-compare-with-file
-;; highlight-compare-buffers
-;; highlight-changes-rotate-faces
+;; `highlight-changes-mode'
+;; `highlight-changes-toggle-visibility'
+;; `highlight-changes-remove-highlight'
+;; `highlight-compare-with-file'
+;; `highlight-compare-buffers'
+;; `highlight-changes-rotate-faces'
;;; Bugs:
@@ -179,7 +178,6 @@
:version "20.4"
:group 'faces)
-
;; Face information: How the changes appear.
;; Defaults for face: red foreground, no change to background,
@@ -192,22 +190,20 @@
'((((min-colors 88) (class color)) (:foreground "red1"))
(((class color)) (:foreground "red" ))
(t (:inverse-video t)))
- "Face used for highlighting changes."
- :group 'highlight-changes)
+ "Face used for highlighting changes.")
;; This looks pretty ugly, actually. Maybe the underline should be removed.
(defface highlight-changes-delete
'((((min-colors 88) (class color)) (:foreground "red1" :underline t))
(((class color)) (:foreground "red" :underline t))
(t (:inverse-video t)))
- "Face used for highlighting deletions."
- :group 'highlight-changes)
+ "Face used for highlighting deletions.")
;; A (not very good) default list of colors to rotate through.
(defcustom highlight-changes-colors
(if (eq (frame-parameter nil 'background-mode) 'light)
;; defaults for light background:
- '( "magenta" "blue" "darkgreen" "chocolate" "sienna4" "NavyBlue")
+ '("magenta" "blue" "darkgreen" "chocolate" "sienna4" "NavyBlue")
;; defaults for dark background:
'("yellow" "magenta" "blue" "maroon" "firebrick" "green4" "DarkOrchid"))
"Colors used by `highlight-changes-rotate-faces'.
@@ -218,50 +214,34 @@ This list is used if `highlight-changes-face-list' is nil, otherwise that
variable overrides this list. If you only care about foreground
colors then use this, if you want fancier faces then set
`highlight-changes-face-list'."
- :type '(repeat color)
- :group 'highlight-changes)
+ :type '(repeat color))
;; When you invoke highlight-changes-mode, should highlight-changes-visible-mode
;; be on or off?
-(define-obsolete-variable-alias 'highlight-changes-initial-state
- 'highlight-changes-visibility-initial-state "23.1")
-
(defcustom highlight-changes-visibility-initial-state t
"Controls whether changes are initially visible in Highlight Changes mode.
This controls the initial value of `highlight-changes-visible-mode'.
When a buffer is in Highlight Changes mode the function
`highlight-changes-visible-mode' is used to toggle the mode on or off."
- :type 'boolean
- :group 'highlight-changes)
-
-;; highlight-changes-global-initial-state has been removed
-
-
+ :type 'boolean)
;; These are the strings displayed in the mode-line for the minor mode:
-(define-obsolete-variable-alias 'highlight-changes-active-string
- 'highlight-changes-visible-string "23.1")
(defcustom highlight-changes-visible-string " +Chg"
"The string used when in Highlight Changes mode and changes are visible.
This should be set to nil if no indication is desired, or to
a string with a leading space."
:type '(choice string
- (const :tag "None" nil))
- :group 'highlight-changes)
-
-(define-obsolete-variable-alias 'highlight-changes-passive-string
- 'highlight-changes-invisible-string "23.1")
+ (const :tag "None" nil)))
(defcustom highlight-changes-invisible-string " -Chg"
"The string used when in Highlight Changes mode and changes are hidden.
This should be set to nil if no indication is desired, or to
a string with a leading space."
:type '(choice string
- (const :tag "None" nil))
- :group 'highlight-changes)
+ (const :tag "None" nil)))
(defcustom highlight-changes-global-modes t
"Determine whether a buffer is suitable for global Highlight Changes mode.
@@ -291,9 +271,7 @@ modes only."
(repeat :tag "Modes" :inline t (symbol :tag "mode")))
(function :menu-tag "determined by function"
:value buffer-file-name)
- (const :tag "none" nil)
- )
- :group 'highlight-changes)
+ (const :tag "none" nil)))
(defcustom highlight-changes-global-changes-existing-buffers nil
"If non-nil, toggling global Highlight Changes mode affects existing buffers.
@@ -302,15 +280,12 @@ created). However, if `highlight-changes-global-changes-existing-buffers'
is non-nil, then turning on `global-highlight-changes-mode' will turn on
Highlight Changes mode in suitable buffers, and turning the mode off will
remove it from existing buffers."
- :type 'boolean
- :group 'highlight-changes)
+ :type 'boolean)
;; These are for internal use.
(defvar hilit-chg-list nil)
-(defvar hilit-chg-string " ??")
-
-(make-variable-buffer-local 'hilit-chg-string)
+(defvar-local hilit-chg-string " ??")
@@ -334,9 +309,7 @@ through various faces.
\\[highlight-compare-with-file] - mark text as changed by comparing this
buffer with the contents of a file
\\[highlight-compare-buffers] highlights differences between two buffers."
- nil ;; init-value
- hilit-chg-string ;; lighter
- nil ;; keymap
+ :lighter hilit-chg-string
(if (or (display-color-p)
(and (fboundp 'x-display-grayscale-p) (x-display-grayscale-p)))
(progn
@@ -366,13 +339,8 @@ The default value can be customized with variable
`highlight-changes-visibility-initial-state'.
This command does not itself set Highlight Changes mode."
-
- t ;; init-value
- nil ;; lighter
- nil ;; keymap
-
- (hilit-chg-update)
- )
+ :init-value t
+ (hilit-chg-update))
(defun hilit-chg-cust-fix-changes-face-list (w _wc &optional event)
@@ -385,12 +353,10 @@ This command does not itself set Highlight Changes mode."
;; faces are saved but not to the actual list itself.
(let ((old-list (widget-value w)))
(if (member 'default old-list)
- (let
- ((p (reverse old-list))
+ (let ((p (reverse old-list))
(n (length old-list))
new-name old-name
- (new-list nil)
- )
+ (new-list nil))
(while p
(setq old-name (car p))
(setq new-name (intern (format "highlight-changes-%d" n)))
@@ -410,9 +376,7 @@ This command does not itself set Highlight Changes mode."
(if (equal new-list (widget-value w))
nil ;; (message "notify: no change!")
(widget-value-set w new-list)
- (widget-setup)
- )
- )
+ (widget-setup)))
;; (message "notify: no default here!")
))
(let ((parent (widget-get w :parent)))
@@ -431,10 +395,8 @@ Otherwise, this list will be constructed when needed from
:type '(choice
(repeat
:notify hilit-chg-cust-fix-changes-face-list
- face )
- (const :tag "Derive from highlight-changes-colors" nil)
- )
- :group 'highlight-changes)
+ face)
+ (const :tag "Derive from highlight-changes-colors" nil)))
(defun hilit-chg-map-changes (func &optional start-position end-position)
@@ -460,7 +422,7 @@ An overlay from BEG to END containing a change face is added
from the information in the text property of type `hilit-chg'.
This is the opposite of `hilit-chg-hide-changes'."
- (hilit-chg-map-changes 'hilit-chg-make-ov beg end))
+ (hilit-chg-map-changes #'hilit-chg-make-ov beg end))
(defun hilit-chg-make-ov (prop start end)
@@ -481,8 +443,7 @@ This is the opposite of `hilit-chg-hide-changes'."
(overlay-put ov 'evaporate t)
;; We set the change property so we can tell this is one
;; of our overlays (so we don't delete someone else's).
- (overlay-put ov 'hilit-chg t)
- )
+ (overlay-put ov 'hilit-chg t))
(error "hilit-chg-make-ov: no face for prop: %s" prop))))
(defun hilit-chg-hide-changes (&optional beg end)
@@ -531,9 +492,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))
+ (let ((end-incr 1)
+ (type 'hilit-chg)
+ (property 'hilit-chg))
(if undo-in-progress
(if (and highlight-changes-mode
highlight-changes-visible-mode)
@@ -554,7 +515,8 @@ This allows you to manually remove highlighting from uninteresting changes."
;; (setq beg-decr 0))))
;; (setq beg (max (- beg beg-decr) (point-min)))
(setq end (min (+ end end-incr) (point-max)))
- (setq type 'hilit-chg-delete))
+ (setq type 'hilit-chg-delete
+ property 'hilit-chg-delete))
;; Not a deletion.
;; Most of the time the following is not necessary, but
;; if the current text was marked as a deletion then
@@ -562,14 +524,15 @@ This allows you to manually remove highlighting from uninteresting changes."
;; text where she earlier deleted text, we have to remove the
;; deletion marking, and replace it explicitly with a `changed'
;; marking, otherwise its highlighting would disappear.
- (if (eq (get-text-property end 'hilit-chg) 'hilit-chg-delete)
- (save-restriction
- (widen)
- (put-text-property end (+ end 1) 'hilit-chg 'hilit-chg)
- (if highlight-changes-visible-mode
- (hilit-chg-fixup end (+ end 1))))))
+ (when (eq (get-text-property end 'hilit-chg-delete)
+ 'hilit-chg-delete)
+ (save-restriction
+ (widen)
+ (put-text-property end (+ end 1) 'hilit-chg-delete nil)
+ (if highlight-changes-visible-mode
+ (hilit-chg-fixup end (+ end 1))))))
(unless no-property-change
- (put-text-property beg end 'hilit-chg type))
+ (put-text-property beg end property type))
(if (or highlight-changes-visible-mode no-property-change)
(hilit-chg-make-ov type beg end)))))))
@@ -740,7 +703,7 @@ this, eval the following in the buffer to be saved:
;; remove our existing overlays
(hilit-chg-hide-changes)
;; for each change text property, increment it
- (hilit-chg-map-changes 'hilit-chg-bump-change)
+ (hilit-chg-map-changes #'hilit-chg-bump-change)
;; and display them
(hilit-chg-display-changes))
(unless modified
@@ -773,7 +736,7 @@ is non-nil."
(buf-b-read-only (with-current-buffer buf-b buffer-read-only))
temp-a temp-b)
(if (and file-a bufa-modified)
- (if (y-or-n-p (format "Save buffer %s? " buf-a))
+ (if (y-or-n-p (format "Save buffer %s? " buf-a))
(with-current-buffer buf-a
(save-buffer)
(setq bufa-modified (buffer-modified-p buf-a)))
@@ -782,7 +745,7 @@ is non-nil."
(setq temp-a (setq file-a (ediff-make-temp-file buf-a nil))))
(if (and file-b bufb-modified)
- (if (y-or-n-p (format "Save buffer %s? " buf-b))
+ (if (y-or-n-p (format "Save buffer %s? " buf-b))
(with-current-buffer buf-b
(save-buffer)
(setq bufb-modified (buffer-modified-p buf-b)))
@@ -823,12 +786,11 @@ is non-nil."
(if temp-a
(delete-file temp-a))
(if temp-b
- (delete-file temp-b)))
- ))
+ (delete-file temp-b)))))
;;;###autoload
(defun highlight-compare-buffers (buf-a buf-b)
-"Compare two buffers and highlight the differences.
+ "Compare two buffers and highlight the differences.
The default is the current buffer and the one in the next window.
@@ -849,8 +811,7 @@ changes are made, so \\[highlight-changes-next-change] and
(window-buffer (next-window)) t))))
(let ((file-a (buffer-file-name buf-a))
(file-b (buffer-file-name buf-b)))
- (highlight-markup-buffers buf-a file-a buf-b file-b)
- ))
+ (highlight-markup-buffers buf-a file-a buf-b file-b)))
;;;###autoload
(defun highlight-compare-with-file (file-b)
@@ -890,9 +851,11 @@ changes are made, so \\[highlight-changes-next-change] and
(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))
- ))
+ (kill-buffer buf-b))))
+(defvar hilit-x) ; placate the byte-compiler
+(defvar hilit-y)
+(defvar hilit-e)
(defun hilit-chg-get-diff-info (buf-a file-a buf-b file-b)
;; hilit-e,x,y are set by function hilit-chg-get-diff-list-hk.
@@ -900,8 +863,7 @@ changes are made, so \\[highlight-changes-next-change] and
(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))
- )
+ (list (cons 'ediff-job-name 'something)))
(ediff-with-current-buffer hilit-e (ediff-really-quit nil))
(list hilit-x hilit-y)))
@@ -909,9 +871,6 @@ changes are made, so \\[highlight-changes-next-change] and
(defun hilit-chg-get-diff-list-hk ()
;; 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 hilit-x nil hilit-y nil)
@@ -945,7 +904,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 hilit-y (append hilit-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.
@@ -957,10 +916,6 @@ changes are made, so \\[highlight-changes-next-change] and
(define-globalized-minor-mode global-highlight-changes-mode
highlight-changes-mode highlight-changes-mode-turn-on)
-(define-obsolete-function-alias
- 'global-highlight-changes
- 'global-highlight-changes-mode "23.1")
-
(defun highlight-changes-mode-turn-on ()
"See if Highlight Changes mode should be turned on for this buffer.
This is called when `global-highlight-changes-mode' is turned on."
@@ -979,8 +934,7 @@ This is called when `global-highlight-changes-mode' is turned on."
(and
(not (string-match "^[ *]" (buffer-name)))
(buffer-file-name))))
- (highlight-changes-mode 1))
- ))
+ (highlight-changes-mode 1))))
;;;; Desktop support.
@@ -1003,8 +957,7 @@ This is called when `global-highlight-changes-mode' is turned on."
;; (message "--- hilit-chg-debug-show ---")
;; (hilit-chg-map-changes (lambda (prop start end)
;; (message "%d-%d: %s" start end prop))
-;; beg end
-;; ))
+;; beg end))
;;
;; ================== end of debug ===============
diff --git a/lisp/hippie-exp.el b/lisp/hippie-exp.el
index 3abe0ca35f8..cbb69b206d4 100644
--- a/lisp/hippie-exp.el
+++ b/lisp/hippie-exp.el
@@ -1,10 +1,10 @@
-;;; hippie-exp.el --- expand text trying various ways to find its expansion
+;;; hippie-exp.el --- expand text trying various ways to find its expansion -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
;; Author: Anders Holst <aho@sans.kth.se>
;; Maintainer: emacs-devel@gnu.org
-;; Version: 1.6
+;; Old-Version: 1.6
;; Keywords: abbrev convenience
;; This file is part of GNU Emacs.
@@ -58,7 +58,7 @@
;; The variable `hippie-expand-dabbrev-as-symbol' controls whether
;; characters of syntax '_' is considered part of the words to expand
;; dynamically.
-;; See also the macro `make-hippie-expand-function' below.
+;; See also the function `make-hippie-expand-function' below.
;;
;; A short description of the current try-functions in this file:
;; `try-complete-file-name' : very convenient to have in any buffer,
@@ -215,50 +215,42 @@
"The list of expansion functions tried in order by `hippie-expand'.
To change the behavior of `hippie-expand', remove, change the order of,
or insert functions in this list."
- :type '(repeat function)
- :group 'hippie-expand)
+ :type '(repeat function))
(defcustom hippie-expand-verbose t
"Non-nil makes `hippie-expand' output which function it is trying."
- :type 'boolean
- :group 'hippie-expand)
+ :type 'boolean)
(defcustom hippie-expand-dabbrev-skip-space nil
"Non-nil means tolerate trailing spaces in the abbreviation to expand."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-dabbrev-as-symbol t
"Non-nil means expand as symbols, i.e. syntax `_' is considered a letter."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-no-restriction t
"Non-nil means that narrowed buffers are widened during search."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-max-buffers ()
"The maximum number of buffers (apart from the current) searched.
If nil, all buffers are searched."
:type '(choice (const :tag "All" nil)
- integer)
- :group 'hippie-expand)
+ integer))
(defcustom hippie-expand-ignore-buffers '("^ \\*.*\\*$" dired-mode)
"A list specifying which buffers not to search (if not current).
Can contain both regexps matching buffer names (as strings) and major modes
\(as atoms)."
- :type '(repeat (choice regexp (symbol :tag "Major Mode")))
- :group 'hippie-expand)
+ :type '(repeat (choice regexp (symbol :tag "Major Mode"))))
(defcustom hippie-expand-only-buffers ()
"A list specifying the only buffers to search (in addition to current).
Can contain both regexps matching buffer names (as strings) and major modes
\(as atoms). If non-nil, this variable overrides the variable
`hippie-expand-ignore-buffers'."
- :type '(repeat (choice regexp (symbol :tag "Major Mode")))
- :group 'hippie-expand)
+ :type '(repeat (choice regexp (symbol :tag "Major Mode"))))
;;;###autoload
(defun hippie-expand (arg)
@@ -407,18 +399,19 @@ undoes the expansion."
;; try-expand-line-all-buffers)))
;;
;;;###autoload
-(defmacro make-hippie-expand-function (try-list &optional verbose)
+(defun make-hippie-expand-function (try-list &optional verbose)
"Construct a function similar to `hippie-expand'.
Make it use the expansion functions in TRY-LIST. An optional second
argument VERBOSE non-nil makes the function verbose."
- `(function (lambda (arg)
- ,(concat
+ (lambda (arg)
+ (:documentation
+ (concat
"Try to expand text before point, using the following functions: \n"
- (mapconcat 'prin1-to-string (eval try-list) ", "))
+ (mapconcat #'prin1-to-string try-list ", ")))
(interactive "P")
- (let ((hippie-expand-try-functions-list ,try-list)
- (hippie-expand-verbose ,verbose))
- (hippie-expand arg)))))
+ (let ((hippie-expand-try-functions-list try-list)
+ (hippie-expand-verbose verbose))
+ (hippie-expand arg))))
;;; Here follows the try-functions and their requisites:
@@ -434,7 +427,8 @@ string). It returns t if a new completion is found, nil otherwise."
(he-init-string (he-file-name-beg) (point))
(let ((name-part (file-name-nondirectory he-search-string))
(dir-part (expand-file-name (or (file-name-directory
- he-search-string) ""))))
+ he-search-string)
+ ""))))
(if (not (he-string-member name-part he-tried-table))
(setq he-tried-table (cons name-part he-tried-table)))
(if (and (not (equal he-search-string ""))
@@ -442,7 +436,7 @@ string). It returns t if a new completion is found, nil otherwise."
(setq he-expand-list (sort (file-name-all-completions
name-part
dir-part)
- 'string-lessp))
+ #'string-lessp))
(setq he-expand-list ())))))
(while (and he-expand-list
@@ -534,11 +528,11 @@ string). It returns t if a new completion is found, nil otherwise."
(setq he-expand-list
(and (not (equal he-search-string ""))
(sort (all-completions he-search-string obarray
- (function (lambda (sym)
+ (lambda (sym)
(or (boundp sym)
(fboundp sym)
- (symbol-plist sym)))))
- 'string-lessp)))))
+ (symbol-plist sym))))
+ #'string-lessp)))))
(while (and he-expand-list
(he-string-member (car he-expand-list) he-tried-table))
(setq he-expand-list (cdr he-expand-list)))
@@ -563,10 +557,10 @@ otherwise."
(if (not (string= he-search-string ""))
(setq expansion
(try-completion he-search-string obarray
- (function (lambda (sym)
+ (lambda (sym)
(or (boundp sym)
(fboundp sym)
- (symbol-plist sym)))))))
+ (symbol-plist sym))))))
(if (or (eq expansion t)
(string= expansion he-search-string)
(he-string-member expansion he-tried-table))
@@ -821,10 +815,11 @@ string). It returns t if a new expansion is found, nil otherwise."
(he-init-string (he-dabbrev-beg) (point))
(setq he-expand-list
(and (not (equal he-search-string ""))
- (mapcar (function (lambda (sym)
- (if (and (boundp sym) (vectorp (eval sym)))
+ (mapcar (lambda (sym)
+ (if (and (boundp sym)
+ (abbrev-table-p (symbol-value sym)))
(abbrev-expansion (downcase he-search-string)
- (eval sym)))))
+ (symbol-value sym))))
(append '(local-abbrev-table
global-abbrev-table)
abbrev-table-name-list))))))
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index 73870f9579e..26cfcc3f9cc 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -45,11 +45,7 @@
;; An overlay is used. In the non-sticky cases, this overlay is
;; active only on the selected window. A hook is added to
;; `post-command-hook' to activate the overlay and move it to the line
-;; about point. To get the non-sticky behavior, `hl-line-unhighlight'
-;; is added to `pre-command-hook' as well. This function deactivates
-;; the overlay unconditionally in case the command changes the
-;; selected window. (It does so rather than keeping track of changes
-;; in the selected window).
+;; about point.
;; You could make variable `global-hl-line-mode' buffer-local and set
;; it to nil to avoid highlighting specific buffers, when the global
@@ -91,9 +87,9 @@ when `global-hl-line-sticky-flag' is non-nil.")
(set symbol value)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
- (when hl-line-overlay
+ (when (overlayp hl-line-overlay)
(overlay-put hl-line-overlay 'face hl-line-face))))
- (when global-hl-line-overlay
+ (when (overlayp global-hl-line-overlay)
(overlay-put global-hl-line-overlay 'face hl-line-face))))
(defcustom hl-line-sticky-flag t
@@ -129,6 +125,9 @@ This variable is expected to be made buffer-local by modes.")
(defvar hl-line-overlay-buffer nil
"Most recently visited buffer in which Hl-Line mode is enabled.")
+(defvar hl-line-overlay-priority -50
+ "Priority used on the overlay used by hl-line.")
+
;;;###autoload
(define-minor-mode hl-line-mode
"Toggle highlighting of the current line (Hl-Line mode).
@@ -141,9 +140,7 @@ non-selected window. Hl-Line mode uses the function
`hl-line-highlight' on `post-command-hook' in this case.
When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the
-line about point in the selected window only. In this case, it
-uses the function `hl-line-maybe-unhighlight' in
-addition to `hl-line-highlight' on `post-command-hook'."
+line about point in the selected window only."
:group 'hl-line
(if hl-line-mode
(progn
@@ -151,16 +148,14 @@ addition to `hl-line-highlight' on `post-command-hook'."
(add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t)
(hl-line-highlight)
(setq hl-line-overlay-buffer (current-buffer))
- (add-hook 'post-command-hook #'hl-line-highlight nil t)
- (add-hook 'post-command-hook #'hl-line-maybe-unhighlight nil t))
+ (add-hook 'post-command-hook #'hl-line-highlight nil t))
(remove-hook 'post-command-hook #'hl-line-highlight t)
(hl-line-unhighlight)
- (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t)
- (remove-hook 'post-command-hook #'hl-line-maybe-unhighlight t)))
+ (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t)))
(defun hl-line-make-overlay ()
(let ((ol (make-overlay (point) (point))))
- (overlay-put ol 'priority -50) ;(bug#16192)
+ (overlay-put ol 'priority hl-line-overlay-priority) ;(bug#16192)
(overlay-put ol 'face hl-line-face)
ol))
@@ -168,17 +163,19 @@ addition to `hl-line-highlight' on `post-command-hook'."
"Activate the Hl-Line overlay on the current line."
(if hl-line-mode ; Might be changed outside the mode function.
(progn
- (unless hl-line-overlay
+ (unless (overlayp hl-line-overlay)
(setq hl-line-overlay (hl-line-make-overlay))) ; To be moved.
(overlay-put hl-line-overlay
'window (unless hl-line-sticky-flag (selected-window)))
- (hl-line-move hl-line-overlay))
+ (hl-line-move hl-line-overlay)
+ (hl-line-maybe-unhighlight))
(hl-line-unhighlight)))
(defun hl-line-unhighlight ()
"Deactivate the Hl-Line overlay on the current line."
- (when hl-line-overlay
- (delete-overlay hl-line-overlay)))
+ (when (overlayp hl-line-overlay)
+ (delete-overlay hl-line-overlay)
+ (setq hl-line-overlay nil)))
(defun hl-line-maybe-unhighlight ()
"Maybe deactivate the Hl-Line overlay on the current line.
@@ -191,8 +188,7 @@ such overlays in all buffers except the current one."
(not (eq curbuf hlob))
(not (minibufferp)))
(with-current-buffer hlob
- (when (overlayp hl-line-overlay)
- (delete-overlay hl-line-overlay))))
+ (hl-line-unhighlight)))
(when (and (overlayp hl-line-overlay)
(eq (overlay-buffer hl-line-overlay) curbuf))
(setq hl-line-overlay-buffer curbuf))))
@@ -205,8 +201,8 @@ If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode
highlights the line about the current buffer's point in all live
windows.
-Global-Hl-Line mode uses the functions `global-hl-line-highlight'
-and `global-hl-line-maybe-unhighlight' on `post-command-hook'."
+Global-Hl-Line mode uses the function `global-hl-line-highlight'
+on `post-command-hook'."
:global t
:group 'hl-line
(if global-hl-line-mode
@@ -214,25 +210,24 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'."
;; In case `kill-all-local-variables' is called.
(add-hook 'change-major-mode-hook #'global-hl-line-unhighlight)
(global-hl-line-highlight-all)
- (add-hook 'post-command-hook #'global-hl-line-highlight)
- (add-hook 'post-command-hook #'global-hl-line-maybe-unhighlight))
+ (add-hook 'post-command-hook #'global-hl-line-highlight))
(global-hl-line-unhighlight-all)
(remove-hook 'post-command-hook #'global-hl-line-highlight)
- (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight)
- (remove-hook 'post-command-hook #'global-hl-line-maybe-unhighlight)))
+ (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight)))
(defun global-hl-line-highlight ()
"Highlight the current line in the current window."
(when global-hl-line-mode ; Might be changed outside the mode function.
(unless (window-minibuffer-p)
- (unless global-hl-line-overlay
+ (unless (overlayp global-hl-line-overlay)
(setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved.
(unless (member global-hl-line-overlay global-hl-line-overlays)
(push global-hl-line-overlay global-hl-line-overlays))
(overlay-put global-hl-line-overlay 'window
(unless global-hl-line-sticky-flag
(selected-window)))
- (hl-line-move global-hl-line-overlay))))
+ (hl-line-move global-hl-line-overlay)
+ (global-hl-line-maybe-unhighlight))))
(defun global-hl-line-highlight-all ()
"Highlight the current line in all live windows."
@@ -243,8 +238,9 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'."
(defun global-hl-line-unhighlight ()
"Deactivate the Global-Hl-Line overlay on the current line."
- (when global-hl-line-overlay
- (delete-overlay global-hl-line-overlay)))
+ (when (overlayp global-hl-line-overlay)
+ (delete-overlay global-hl-line-overlay)
+ (setq global-hl-line-overlay nil)))
(defun global-hl-line-maybe-unhighlight ()
"Maybe deactivate the Global-Hl-Line overlay on the current line.
@@ -256,9 +252,8 @@ all such overlays in all buffers except the current one."
(bufferp ovb)
(not (eq ovb (current-buffer)))
(not (minibufferp)))
- (with-current-buffer ovb
- (when (overlayp global-hl-line-overlay)
- (delete-overlay global-hl-line-overlay))))))
+ (with-current-buffer ovb
+ (global-hl-line-unhighlight)))))
global-hl-line-overlays))
(defun global-hl-line-unhighlight-all ()
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 8cd9a446198..b453061388f 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -11,9 +11,6 @@
;; Created: 2002-01-05
;; Description: htmlize a buffer/source tree with optional hyperlinks
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
-;; Compatibility: Emacs23, Emacs22
-;; Incompatibility: Emacs19, Emacs20, Emacs21
-;; Last Updated: Thu 2009-11-19 01:31:21 +0000
;; This file is part of GNU Emacs.
@@ -81,12 +78,6 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-(require 'faces)
-;; (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name')
-(require 'custom)
-;; (`defgroup' `defcustom')
-(require 'font-lock)
-;; (`font-lock-fontify-region')
(require 'cus-edit)
(require 'htmlfontify-loaddefs)
@@ -136,8 +127,8 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
\"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \")
(require \\='htmlfontify)
(hfy-load-tags-cache srcdir)
- (let ((hfy-page-header \\='rtfm-build-page-header)
- (hfy-page-footer \\='rtfm-build-page-footer)
+ (let ((hfy-page-header #\\='rtfm-build-page-header)
+ (hfy-page-footer #\\='rtfm-build-page-footer)
(rtfm-section section)
(hfy-index-file \"index\"))
(htmlfontify-run-etags srcdir)
@@ -151,7 +142,7 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
:link '(info-link "(htmlfontify) Customization")
:prefix "hfy-")
-(defcustom hfy-page-header 'hfy-default-header
+(defcustom hfy-page-header #'hfy-default-header
"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
@@ -159,7 +150,6 @@ the <style>...</style> text to embed in the document.
It should return a string that 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
;; own Custom preference on your users? --Stef
:tag "page-header"
@@ -170,66 +160,57 @@ See also `hfy-page-footer'."
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
+(defcustom hfy-page-footer #'hfy-default-footer
"As `hfy-page-header', but generates the output footer.
It takes only one argument, the filename."
- :group 'htmlfontify
:tag "page-footer"
:type '(function))
(defcustom hfy-extn ".html"
"File extension used for output files."
- :group 'htmlfontify
:tag "extension"
:type '(string))
(defcustom hfy-src-doc-link-style "text-decoration: underline;"
"String to add to the `<style> a' variant of an htmlfontify CSS class."
- :group 'htmlfontify
:tag "src-doc-link-style"
:type '(string))
(defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
"Regex to remove from the `<style> a' variant of an htmlfontify CSS class."
- :group 'htmlfontify
:tag "src-doc-link-unstyle"
- :type '(string))
+ :type '(regexp))
(defcustom hfy-link-extn nil
"File extension used for href links.
Useful where the htmlfontify output files are going to be processed
again, with a resulting change in file extension. If nil, then any
code using this should fall back to `hfy-extn'."
- :group 'htmlfontify
:tag "link-extension"
:type '(choice string (const nil)))
-(defcustom hfy-link-style-fun 'hfy-link-style-string
+(defcustom hfy-link-style-fun #'hfy-link-style-string
"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
normally be applied."
- :group 'htmlfontify
:tag "link-style-function"
:type '(function))
(defcustom hfy-index-file "hfy-index"
"Name (sans extension) of the tag definition index file produced during
fontification-and-hyperlinking."
- :group 'htmlfontify
:tag "index-file"
:type '(string))
(defcustom hfy-instance-file "hfy-instance"
"Name (sans extension) of the tag usage index file produced during
fontification-and-hyperlinking."
- :group 'htmlfontify
:tag "instance-file"
:type '(string))
@@ -237,25 +218,13 @@ fontification-and-hyperlinking."
"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."
- :group 'htmlfontify
:tag "html-quote-regex"
:type '(regexp))
-(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
- "23.2")
-(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
- "List of functions to call when starting `htmlfontify-buffer' to do any
-kludging necessary to get highlighting modes to behave as you want, even
-when not running under a window system."
- :group 'htmlfontify
- :tag "init-kludge-hooks"
- :type '(hook))
-
(define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3")
(defcustom hfy-post-html-hook nil
"List of functions to call after creating and filling the HTML buffer.
These functions will be called with the HTML buffer as the current buffer."
- :group 'htmlfontify
:tag "post-html-hooks"
:options '(set-auto-mode)
:type '(hook))
@@ -267,7 +236,6 @@ potentially non-current face information doesn't necessarily work for
`default').\n
Example: I customize this to:\n
\((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
- :group 'htmlfontify
:tag "default-face-definition"
:type '(alist))
@@ -281,7 +249,6 @@ in order, to:\n
1 - The tag
2 - The line
3 - The char (point) at which the tag occurs."
- :group 'htmlfontify
:tag "etag-regex"
:type '(regexp))
@@ -290,7 +257,6 @@ in order, to:\n
("&" "&amp;" )
(">" "&gt;" ))
"Alist of char -> entity mappings used to make the text HTML-safe."
- :group 'htmlfontify
:tag "html-quote-map"
:type '(alist :key-type (string)))
(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
@@ -332,7 +298,6 @@ done;")
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)))
@@ -340,13 +305,11 @@ done;")
"Location of etags binary (we begin by assuming it's in your path).\n
Note that if etags is not in your path, you will need to alter the shell
commands in `hfy-etags-cmd-alist'."
- :group 'htmlfontify
:tag "etags-bin"
:type '(file))
(defcustom hfy-shell-file-name "/bin/sh"
"Shell (Bourne or compatible) to invoke for complex shell operations."
- :group 'htmlfontify
:tag "shell-file-name"
:type '(file))
@@ -358,7 +321,6 @@ commands in `hfy-etags-cmd-alist'."
point-entered
point-left)
"Properties to omit when copying a fontified buffer for HTML transformation."
- :group 'htmlfontify
:tag "ignored-properties"
:type '(repeat symbol))
@@ -387,7 +349,6 @@ file for the whole source tree from there on down. The command should emit
the etags output on stdout.\n
Two canned commands are provided - they drive Emacs's etags and
exuberant-ctags' etags respectively."
- :group 'htmlfontify
:tag "etags-command"
:type (let ((clist (list '(string))))
(dolist (C hfy-etags-cmd-alist)
@@ -398,14 +359,12 @@ exuberant-ctags' etags respectively."
"Command to run with the name of a file, to see whether it is a text file
or not. The command should emit a string containing the word `text' if
the file is a text file, and a string not containing `text' otherwise."
- :group 'htmlfontify
:tag "istext-command"
:type '(string))
(defcustom hfy-find-cmd
"find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
"Find command used to harvest a list of files to attempt to fontify."
- :group 'htmlfontify
:tag "find-command"
:type '(string))
@@ -434,7 +393,6 @@ of these values in the specification key constitutes a match, eg:\n
((type tty) (class color))\n
and so on."
:type '(alist :key-type (symbol) :value-type (symbol))
- :group 'htmlfontify
:tag "display-class"
:options '((type (choice (const :tag "X11" x-toolkit)
(const :tag "Terminal" tty )
@@ -481,7 +439,6 @@ which can never slow you down, but may result in incomplete fontification."
(const :tag "div-wrapper" div-wrapper )
(const :tag "keep-overlays" keep-overlays )
(const :tag "body-text-only" body-text-only ))
- :group 'htmlfontify
:tag "optimizations")
(defvar hfy-tags-cache nil
@@ -566,22 +523,10 @@ therefore no longer care about) will be invalid at any time.\n
(defvar hfy-tmpfont-stack nil
"An alist of derived fonts resulting from overlays.")
-(defconst hfy-hex-regex "[[:xdigit:]]")
-
(defconst hfy-triplet-regex
- (concat
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"))
-
-(defun hfy-interq (set-a set-b)
- "Return the intersection (using `eq') of two lists SET-A and SET-B."
- (let ((sa set-a) (interq nil) (elt nil))
- (while sa
- (setq elt (car sa)
- sa (cdr sa))
- (if (memq elt set-b) (setq interq (cons elt interq))))
- interq))
+ (rx (group xdigit xdigit)
+ (group xdigit xdigit)
+ (group xdigit xdigit)))
(defun hfy-color-vals (color)
"Where COLOR is a color name or #XXXXXX style triplet, return a
@@ -593,19 +538,17 @@ If a window system is unavailable, calls `hfy-fallback-color-values'."
'(1 2 3))
;;(message ">> %s" color)
(if window-system
- (if (fboundp 'color-values)
- (color-values color)
- ;;(message "[%S]" window-system)
- (x-color-values color))
+ (color-values color)
;; blarg - tty colors are no good - go fetch some X colors:
(hfy-fallback-color-values color))))
-(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1")
+(define-obsolete-function-alias 'hfy-colour-vals #'hfy-color-vals "27.1")
(defvar hfy-cperl-mode-kludged-p nil)
(defun hfy-kludge-cperl-mode ()
"CPerl mode does its damnedest not to do some of its fontification when not
in a windowing system - try to trick it..."
+ (declare (obsolete nil "28.1"))
(if (not hfy-cperl-mode-kludged-p)
(progn (if (not window-system)
(let ((window-system 'htmlfontify))
@@ -728,7 +671,7 @@ STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
--> </script>
</head>
<body onload=\"stripe('index'); return true;\">\n"
- (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
+ (mapconcat #'hfy-html-quote (mapcar #'char-to-string file) "") style))
(defun hfy-default-footer (_file)
"Default value for `hfy-page-footer'.
@@ -766,24 +709,24 @@ may happen."
(let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white")))
(rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals color))))
(if rgb16
- ;;(apply 'format "rgb(%d, %d, %d)"
+ ;;(apply #'format "rgb(%d, %d, %d)"
;; Use #rrggbb instead, it is smaller
- (apply 'format "#%02x%02x%02x"
+ (apply #'format "#%02x%02x%02x"
(mapcar (lambda (X)
(* (/ (nth X rgb16)
- (nth X white)) 255))
+ (nth X white))
+ 255))
'(0 1 2))))))
(defun hfy-family (family) (list (cons "font-family" family)))
(defun hfy-bgcol (color) (list (cons "background" (hfy-triplet color))))
(defun hfy-color (color) (list (cons "color" (hfy-triplet color))))
-(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1")
+(define-obsolete-function-alias 'hfy-colour #'hfy-color "27.1")
(defun hfy-width (width) (list (cons "font-stretch" (symbol-name width))))
(defcustom hfy-font-zoom 1.05
"Font scaling from Emacs to HTML."
- :type 'float
- :group 'htmlfontify)
+ :type 'float)
(defun hfy-size (height)
"Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
@@ -932,7 +875,9 @@ See also `hfy-display-class' for details of valid values for CLASS."
(setq score 0) (ignore "t match"))
((not (cdr (assq key face-class))) ;Neither good nor bad.
nil (ignore "non match, non collision"))
- ((setq x (hfy-interq val (cdr (assq key face-class))))
+ ((setq x (nreverse
+ (seq-intersection val (cdr (assq key face-class))
+ #'eq)))
(setq score (+ score (length x)))
(ignore "intersection"))
(t ;; nope.
@@ -1028,19 +973,18 @@ merged by the user - `hfy-flatten-style' should do this."
(:italic (hfy-slant 'italic))))))
(setq that (hfy-face-to-style-i next))
;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
- (nconc this parent that))) )
+ (append this parent that))) )
-(defun hfy-size-to-int (spec)
+(defun hfy--size-to-int (spec)
"Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
Used while merging multiple font-size attributes."
- ;;(message "hfy-size-to-int");;DBUG
- (list
- (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
- (cond ((string= "%" (match-string 2 spec))
- (/ (string-to-number (match-string 1 spec)) 100.0))
- ((string= "pt" (match-string 2 spec))
- (* (string-to-number (match-string 1 spec)) 10)))
- (string-to-number spec))) )
+ ;;(message "hfy--size-to-int");;DBUG
+ (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
+ (cond ((string= "%" (match-string 2 spec))
+ (/ (string-to-number (match-string 1 spec)) 100.0))
+ ((string= "pt" (match-string 2 spec))
+ (* (string-to-number (match-string 1 spec)) 10)))
+ (string-to-number spec)) )
;; size is different, in that in order to get it right at all,
;; we have to trawl the inheritance path, accumulating modifiers,
@@ -1051,19 +995,18 @@ any multiple attributes appropriately. Currently only font-size is merged
down to a single occurrence - others may need special handling, but I
haven't encountered them yet. Returns a `hfy-style-assoc'."
;;(message "(hfy-flatten-style %S)" style) ;;DBUG
- (let ((n 0)
- (m (list 1))
+ (let ((m (list 1))
(x nil)
(r nil))
(dolist (css style)
(if (string= (car css) "font-size")
(progn
- (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
+ (when (not x) (push (hfy--size-to-int (cdr css)) m))
(when (string-match "pt" (cdr css)) (setq x t)))
- (setq r (nconc r (list css)))))
+ (push css r)))
;;(message "r: %S" r)
- (setq n (apply '* m))
- (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))
+ (let ((n (apply #'* m)))
+ (nconc (nreverse r) (hfy-size (if x (round n) (float n)))))))
(defun hfy-face-resolve-face (fn)
"For FN return a face specification.
@@ -1073,7 +1016,7 @@ then the specification is returned unchanged."
((facep fn)
(hfy-face-attr-for-class fn hfy-display-class))
;; FIXME: is this necessary? Faces can be symbols, but
- ;; not symbols refering to other symbols?
+ ;; not symbols referring to other symbols?
((and (symbolp fn)
(facep (symbol-value fn)))
(hfy-face-attr-for-class
@@ -1097,7 +1040,7 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
;; text-decoration is not inherited.
;; but it's not wrong and if this ever changes it will
;; be needed, so I think it's better to leave it in? -- v
- (nconc final-style '(("text-decoration" . "none"))))))
+ (push '("text-decoration" . "none") final-style))))
final-style))
;; strip redundant bits from a name. Technically, this could result in
@@ -1152,9 +1095,9 @@ See also `hfy-face-to-css'."
(push (car E) seen)
(format " %s: %s; " (car E) (cdr E)))))
css-list)))
- (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
+ (cons (hfy-css-name fn) (format "{%s}" (apply #'concat css-text)))) )
-(defvar hfy-face-to-css 'hfy-face-to-css-default
+(defvar hfy-face-to-css #'hfy-face-to-css-default
"Handler for mapping faces to styles.
The signature of the handler is of the form \(lambda (FN) ...).
FN is a font or `defface' specification (cf
@@ -1510,7 +1453,7 @@ Uses `hfy-link-style-fun' to do this."
;; Fix-me: Add handling of page breaks here + scan for ^L
;; where appropriate.
(format "body, pre %s\n" (cddr (assq 'default css)))
- (apply 'concat
+ (apply #'concat
(mapcar
(lambda (style)
(format
@@ -1611,7 +1554,7 @@ Insert \"</span>\". See `hfy-end-span-handler' for more
information."
(insert "</span>"))
-(defvar hfy-begin-span-handler 'hfy-begin-span
+(defvar hfy-begin-span-handler #'hfy-begin-span
"Handler to begin a span of text.
The signature of the handler is \(lambda (STYLE TEXT-BLOCK
TEXT-ID TEXT-BEGINS-BLOCK-P) ...). The handler must insert
@@ -1640,7 +1583,7 @@ behavior.
The default handler is `hfy-begin-span'.")
-(defvar hfy-end-span-handler 'hfy-end-span
+(defvar hfy-end-span-handler #'hfy-end-span
"Handler to end a span of text.
The signature of the handler is \(lambda () ...). The handler
must insert appropriate tags to end a span of text.
@@ -1821,33 +1764,7 @@ fontified. This is a simple convenience wrapper around
(htmlfontify-buffer)
(buffer-string))))
-(defun hfy-force-fontification ()
- "Try to force font-locking even when it is optimized away."
- (run-hooks 'hfy-init-kludge-hook)
- (eval-and-compile (require 'font-lock))
- (if (boundp 'font-lock-cache-position)
- (or font-lock-cache-position
- (setq font-lock-cache-position (make-marker))))
- (cond
- (noninteractive
- (message "hfy batch mode (%s:%S)"
- (or (buffer-file-name) (buffer-name)) major-mode)
- (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1
- (font-lock-ensure)
- (when font-lock-defaults
- ; Silence "interactive use only" warning on Emacs >= 25.1.
- (with-no-warnings (font-lock-fontify-buffer)))))
- ((and (fboundp #'jit-lock-fontify-now)
- (bound-and-true-p jit-lock-mode))
- (message "hfy jit-lock mode (%S %S)" window-system major-mode)
- (jit-lock-fontify-now))
- (t
- (message "hfy interactive mode (%S %S)" window-system major-mode)
- ;; If jit-lock is not in use, then the buffer is already fontified!
- ;; (when (and font-lock-defaults
- ;; font-lock-mode)
- ;; (font-lock-fontify-region (point-min) (point-max) nil))
- )))
+(define-obsolete-function-alias 'hfy-force-fontification #'font-lock-ensure "28.1")
;;;###autoload
(defun htmlfontify-buffer (&optional srcdir file)
@@ -1875,8 +1792,7 @@ hyperlinks as appropriate."
(setq file (match-string 1 file)))) )
(if (not (hfy-opt 'skip-refontification))
- (save-excursion ;; Keep region
- (hfy-force-fontification)))
+ (font-lock-ensure))
(if (called-interactively-p 'any) ;; display the buffer in interactive mode:
(switch-to-buffer (hfy-fontify-buffer srcdir file))
(hfy-fontify-buffer srcdir file)))
@@ -1923,9 +1839,7 @@ Hardly bombproof, but good enough in the context in which it is being used."
adding an extension of `hfy-extn'. Fontification is actually done by
`htmlfontify-buffer'. If the buffer is not fontified, just copy it."
;;(message "hfy-copy-and-fontify-file");;DBUG
- (let (;;(fast-lock-minimum-size hfy-fast-lock-save)
- ;;(font-lock-support-mode 'fast-lock-mode)
- ;;(window-system (or window-system 'htmlfontify))
+ (let (;;(window-system (or window-system 'htmlfontify))
(target nil)
(source nil)
(html nil))
@@ -1934,7 +1848,7 @@ adding an extension of `hfy-extn'. Fontification is actually done by
;; FIXME: Shouldn't this use expand-file-name? --Stef
(setq target (concat dstdir "/" file))
(hfy-make-directory (hfy-dirname target))
- (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification))
+ (if (not (hfy-opt 'skip-refontification)) (font-lock-ensure))
(if (or (hfy-fontified-p) (hfy-text-p srcdir file))
(progn (setq html (hfy-fontify-buffer srcdir file))
(set-buffer html)
@@ -2392,7 +2306,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
;; (custom-save-delete 'hfy-set-hooks)
;; (let ((standard-output (current-buffer)))
;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n")
-;; (mapatoms 'hfy-pp-hook)
+;; (mapatoms #'hfy-pp-hook)
;; (insert "\n)")
;; )
;; )
@@ -2419,7 +2333,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
;; FIXME: This saving&restoring of global customization
;; variables can interfere with other customization settings for
;; those vars (in .emacs or in Customize).
- (mapc 'hfy-save-initvar
+ (mapc #'hfy-save-initvar
'(auto-mode-alist interpreter-mode-alist))
(princ ")\n")
(indent-region start-pos (point) nil))
@@ -2431,6 +2345,13 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
(let ((file (hfy-initfile)))
(load file 'NOERROR nil nil) ))
+;; Obsolete.
+
+(defun hfy-interq (set-a set-b)
+ "Return the intersection (using `eq') of two lists SET-A and SET-B."
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection set-a set-b #'eq)))
+
(provide 'htmlfontify)
;;; htmlfontify.el ends here
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 5a3891634e6..1dc8acbe1f3 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -208,11 +208,9 @@ either clicking or hitting return "
'follow-link t
'help-echo "Click or RET: save new value in customize"
'action (lambda (_)
- (if (not (fboundp 'customize-save-variable))
- (message "Customize not available; value not saved")
- (customize-save-variable 'ibuffer-saved-filters
- ibuffer-saved-filters)
- (message "Saved updated ibuffer-saved-filters."))))
+ (customize-save-variable 'ibuffer-saved-filters
+ ibuffer-saved-filters)
+ (message "Saved updated ibuffer-saved-filters.")))
". See below for
an explanation and alternative ways to save the repaired value.
@@ -404,7 +402,7 @@ format. See `ibuffer-update-saved-filters-format' and
;;;###autoload
(define-minor-mode ibuffer-auto-mode
"Toggle use of Ibuffer's auto-update facility (Ibuffer Auto mode)."
- nil nil nil
+ :lighter nil
(unless (derived-mode-p 'ibuffer-mode)
(error "This buffer is not in Ibuffer mode"))
(cond (ibuffer-auto-mode
@@ -504,7 +502,7 @@ format. See `ibuffer-update-saved-filters-format' and
(ibuffer-forward-line 0))
(defun ibuffer--maybe-erase-shell-cmd-output ()
- (let ((buf (get-buffer "*Shell Command Output*")))
+ (let ((buf (get-buffer shell-command-buffer-name)))
(when (and (buffer-live-p buf)
(not shell-command-dont-erase-buffer)
(not (zerop (buffer-size buf))))
@@ -517,7 +515,7 @@ format. See `ibuffer-update-saved-filters-format' and
:opstring "Shell command executed on"
:before (ibuffer--maybe-erase-shell-cmd-output)
:modifier-p nil)
- (let ((out-buf (get-buffer-create "*Shell Command Output*")))
+ (let ((out-buf (get-buffer-create shell-command-buffer-name)))
(with-current-buffer out-buf (goto-char (point-max)))
(call-shell-region (point-min) (point-max)
command nil out-buf)))
@@ -542,7 +540,7 @@ format. See `ibuffer-update-saved-filters-format' and
:modifier-p nil)
(let ((file (and (not (buffer-modified-p))
buffer-file-name))
- (out-buf (get-buffer-create "*Shell Command Output*")))
+ (out-buf (get-buffer-create shell-command-buffer-name)))
(unless (and file (file-exists-p file))
(setq file
(make-temp-file
@@ -689,8 +687,8 @@ specifications with the same structure as
`ibuffer-filtering-qualifiers'."
(not
(memq nil ;; a filter will return nil if it failed
- (mapcar #'(lambda (filter)
- (ibuffer-included-in-filter-p buf filter))
+ (mapcar (lambda (filter)
+ (ibuffer-included-in-filter-p buf filter))
filters))))
(defun ibuffer-unary-operand (filter)
@@ -726,8 +724,8 @@ specification, with the same structure as an element of the list
;; (dolist (filter-spec (cdr filter) nil)
;; (when (ibuffer-included-in-filter-p buf filter-spec)
;; (throw 'has-match t))))
- (memq t (mapcar #'(lambda (x)
- (ibuffer-included-in-filter-p buf x))
+ (memq t (mapcar (lambda (x)
+ (ibuffer-included-in-filter-p buf x))
(cdr filter))))
('and
(catch 'no-match
@@ -1116,13 +1114,10 @@ filter into parts."
(defun ibuffer-maybe-save-stuff ()
(when ibuffer-save-with-custom
- (if (fboundp 'customize-save-variable)
- (progn
- (customize-save-variable 'ibuffer-saved-filters
- ibuffer-saved-filters)
- (customize-save-variable 'ibuffer-saved-filter-groups
- ibuffer-saved-filter-groups))
- (message "Not saved permanently: Customize not available"))))
+ (customize-save-variable 'ibuffer-saved-filters
+ ibuffer-saved-filters)
+ (customize-save-variable 'ibuffer-saved-filter-groups
+ ibuffer-saved-filter-groups)))
;;;###autoload
(defun ibuffer-save-filters (name filters)
@@ -1234,14 +1229,12 @@ Called interactively, accept a comma separated list of mode names."
(symbol-name (buffer-local-value
'major-mode buf)))))
(mapcar #'intern
- (completing-read-multiple
- (if default
- (format "Filter by major mode (default %s): " default)
- "Filter by major mode: ")
- obarray
- (lambda (e)
- (string-match "-mode\\'" (if (symbolp e) (symbol-name e) e)))
- t nil nil default)))
+ (completing-read-multiple
+ (format-prompt "Filter by major mode" default)
+ obarray
+ (lambda (e)
+ (string-match "-mode\\'" (if (symbolp e) (symbol-name e) e)))
+ t nil nil default)))
:accept-list t)
(eq qualifier (buffer-local-value 'major-mode buf)))
@@ -1259,11 +1252,9 @@ currently used by buffers."
(symbol-name (buffer-local-value
'major-mode buf)))))
(mapcar #'intern
- (completing-read-multiple
- (if default
- (format "Filter by major mode (default %s): " default)
- "Filter by major mode: ")
- (ibuffer-list-buffer-modes) nil t nil nil default)))
+ (completing-read-multiple
+ (format-prompt "Filter by major mode" default)
+ (ibuffer-list-buffer-modes) nil t nil nil default)))
:accept-list t)
(eq qualifier (buffer-local-value 'major-mode buf)))
@@ -1506,10 +1497,10 @@ Ordering is lexicographic."
(string-lessp
;; FIXME: For now just compare the file name and the process name
;; (if it exists). Is there a better way to do this?
- (or (buffer-file-name (car a))
+ (or (with-current-buffer (car a) (ibuffer-buffer-file-name))
(let ((pr-a (get-buffer-process (car a))))
(and (processp pr-a) (process-name pr-a))))
- (or (buffer-file-name (car b))
+ (or (with-current-buffer (car b) (ibuffer-buffer-file-name))
(let ((pr-b (get-buffer-process (car b))))
(and (processp pr-b) (process-name pr-b))))))
@@ -1598,8 +1589,8 @@ 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)
- 'kill))))
+ (lambda (_buf _mark)
+ 'kill))))
(message "Killed %s lines" count))))
;;;###autoload
@@ -1618,8 +1609,8 @@ a prefix argument reverses the meaning of that variable."
(when current-prefix-arg
(setq only-visible (not only-visible)))
(if only-visible
- (let ((table (mapcar #'(lambda (x)
- (buffer-name (car x)))
+ (let ((table (mapcar (lambda (x)
+ (buffer-name (car x)))
(ibuffer-current-state-list))))
(when (null table)
(error "No buffers!"))
@@ -1630,10 +1621,10 @@ 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)
- (when (string= (buffer-name buf) name)
- (setq buf-point (point))
- nil))
+ (ibuffer-map-lines (lambda (buf _marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
t nil)
(when (and
(null buf-point)
@@ -1644,10 +1635,10 @@ 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)
- (when (string= (buffer-name buf) name)
- (setq buf-point (point))
- nil))
+ (ibuffer-map-lines (lambda (buf _marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
t group)
(if buf-point
(throw 'found nil)
@@ -1784,11 +1775,11 @@ 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)
- (when (funcall func buf)
- (ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
- ibuffer-marked-char))
- t))
+ (lambda (buf _mark)
+ (when (funcall func buf)
+ (ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
+ ibuffer-marked-char))
+ t))
nil
group)))
(ibuffer-redisplay t)
@@ -1800,8 +1791,8 @@ You can then feed the file name(s) to other commands with \\[yank]."
"Mark all buffers whose name matches REGEXP."
(interactive "sMark by name (regexp): ")
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (string-match regexp (buffer-name buf)))))
+ (lambda (buf)
+ (string-match regexp (buffer-name buf)))))
(defun ibuffer-locked-buffer-p (&optional buf)
"Return non-nil if BUF is locked.
@@ -1825,25 +1816,19 @@ When BUF nil, default to the buffer at current line."
"Mark all buffers whose major mode matches REGEXP."
(interactive "sMark by major mode (regexp): ")
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (string-match regexp (format-mode-line mode-name nil nil buf))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (string-match regexp (format-mode-line mode-name nil nil buf))))))
;;;###autoload
(defun ibuffer-mark-by-file-name-regexp (regexp)
"Mark all buffers whose file name matches REGEXP."
- (interactive "sMark by file name (regexp): ")
+ (interactive (list (read-regexp "Mark by file name (regexp)")))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (let ((name (or (buffer-file-name buf)
- (with-current-buffer buf
- (and
- (boundp 'dired-directory)
- (stringp dired-directory)
- dired-directory)))))
- (when name
- ;; Match on the displayed file name (which is abbreviated).
- (string-match regexp (abbreviate-file-name name)))))))
+ (lambda (buf)
+ (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name))))
+ ;; Match on the displayed file name (which is abbreviated).
+ (string-match-p regexp (ibuffer--abbreviate-file-name name))))))
;;;###autoload
(defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers)
@@ -1855,21 +1840,21 @@ Otherwise buffers whose name matches an element of
(interactive (let ((reg (read-string "Mark by content (regexp): ")))
(list reg current-prefix-arg)))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (let ((mode (with-current-buffer buf major-mode))
- res)
- (cond ((and (not all-buffers)
- (or
- (memq mode ibuffer-never-search-content-mode)
- (cl-dolist (x ibuffer-never-search-content-name nil)
- (when-let ((found (string-match x (buffer-name buf))))
- (cl-return found)))))
- (setq res nil))
- (t
- (with-current-buffer buf
- (save-mark-and-excursion
- (goto-char (point-min))
- (setq res (re-search-forward regexp nil t)))))) res))))
+ (lambda (buf)
+ (let ((mode (with-current-buffer buf major-mode))
+ res)
+ (cond ((and (not all-buffers)
+ (or
+ (memq mode ibuffer-never-search-content-mode)
+ (cl-dolist (x ibuffer-never-search-content-name nil)
+ (when-let ((found (string-match x (buffer-name buf))))
+ (cl-return found)))))
+ (setq res nil))
+ (t
+ (with-current-buffer buf
+ (save-mark-and-excursion
+ (goto-char (point-min))
+ (setq res (re-search-forward regexp nil t)))))) res))))
;;;###autoload
(defun ibuffer-mark-by-mode (mode)
@@ -1881,97 +1866,95 @@ Otherwise buffers whose name matches an element of
'major-mode buf)))))
(list (intern
(completing-read
- (if default
- (format "Mark by major mode (default %s): " default)
- "Mark by major mode: ")
+ (format-prompt "Mark by major mode" default)
(ibuffer-list-buffer-modes) nil t nil nil default)))))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (eq (buffer-local-value 'major-mode buf) mode))))
+ (lambda (buf)
+ (eq (buffer-local-value 'major-mode buf) mode))))
;;;###autoload
(defun ibuffer-mark-modified-buffers ()
"Mark all modified buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (buffer-modified-p buf))))
+ (lambda (buf) (buffer-modified-p buf))))
;;;###autoload
(defun ibuffer-mark-unsaved-buffers ()
"Mark all modified buffers that have an associated file."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (and (buffer-local-value 'buffer-file-name buf)
- (buffer-modified-p buf)))))
+ (lambda (buf) (and (buffer-local-value 'buffer-file-name buf)
+ (buffer-modified-p buf)))))
;;;###autoload
(defun ibuffer-mark-dissociated-buffers ()
"Mark all buffers whose associated file does not exist."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (or
- (and buffer-file-name
- (not (file-exists-p buffer-file-name)))
- (and (eq major-mode 'dired-mode)
- (boundp 'dired-directory)
- (stringp dired-directory)
- (not (file-exists-p (file-name-directory dired-directory)))))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (or
+ (and buffer-file-name
+ (not (file-exists-p buffer-file-name)))
+ (and (eq major-mode 'dired-mode)
+ (boundp 'dired-directory)
+ (stringp dired-directory)
+ (not (file-exists-p (file-name-directory dired-directory)))))))))
;;;###autoload
(defun ibuffer-mark-help-buffers ()
"Mark buffers whose major mode is in variable `ibuffer-help-buffer-modes'."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (memq major-mode ibuffer-help-buffer-modes)))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (memq major-mode ibuffer-help-buffer-modes)))))
;;;###autoload
(defun ibuffer-mark-compressed-file-buffers ()
"Mark buffers whose associated file is compressed."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (and buffer-file-name
- (string-match ibuffer-compressed-file-name-regexp
- buffer-file-name))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (and buffer-file-name
+ (string-match ibuffer-compressed-file-name-regexp
+ buffer-file-name))))))
;;;###autoload
(defun ibuffer-mark-old-buffers ()
"Mark buffers which have not been viewed in `ibuffer-old-time' hours."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (when buffer-display-time
- (time-less-p
- (* 60 60 ibuffer-old-time)
- (time-since buffer-display-time)))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (when buffer-display-time
+ (time-less-p
+ (* 60 60 ibuffer-old-time)
+ (time-since buffer-display-time)))))))
;;;###autoload
(defun ibuffer-mark-special-buffers ()
"Mark all buffers whose name begins and ends with `*'."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (string-match "^\\*.+\\*$"
- (buffer-name buf)))))
+ (lambda (buf) (string-match "^\\*.+\\*$"
+ (buffer-name buf)))))
;;;###autoload
(defun ibuffer-mark-read-only-buffers ()
"Mark all read-only buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (buffer-local-value 'buffer-read-only buf))))
+ (lambda (buf) (buffer-local-value 'buffer-read-only buf))))
;;;###autoload
(defun ibuffer-mark-dired-buffers ()
"Mark all `dired' buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (eq (buffer-local-value 'major-mode buf) 'dired-mode))))
+ (lambda (buf) (eq (buffer-local-value 'major-mode buf) 'dired-mode))))
;;;###autoload
(defun ibuffer-do-occur (regexp &optional nlines)
@@ -1987,8 +1970,8 @@ defaults to one."
(let ((ibuffer-do-occur-bufs nil))
;; Accumulate a list of marked buffers
(ibuffer-map-marked-lines
- #'(lambda (buf _mark)
- (push buf ibuffer-do-occur-bufs)))
+ (lambda (buf _mark)
+ (push buf ibuffer-do-occur-bufs)))
(occur-1 regexp nlines ibuffer-do-occur-bufs)))
(provide 'ibuf-ext)
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index be09c6582ce..fcc4f9e751c 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -66,8 +66,8 @@ During evaluation of body, bind `it' to the value returned by TEST."
(ibuffer-redisplay-engine
;; Get rid of dead buffers
(delq nil
- (mapcar #'(lambda (e) (when (buffer-live-p (car e))
- e))
+ (mapcar (lambda (e) (when (buffer-live-p (car e))
+ e))
ibuffer-save-marks-tmp-mark-list)))
(ibuffer-redisplay t))))))
@@ -154,8 +154,8 @@ value if and only if `a' is \"less than\" `b'.
(ibuffer-redisplay t)
(setq ibuffer-last-sorting-mode ',name))
(push (list ',name ,description
- #'(lambda (a b)
- ,@body))
+ (lambda (a b)
+ ,@body))
ibuffer-sorting-functions-alist)
:autoload-end))
@@ -259,18 +259,18 @@ buffer object.
'ibuffer-map-deletion-lines)
(_
'ibuffer-map-marked-lines))
- #'(lambda (buf mark)
- ;; Silence warning for code that doesn't
- ;; use `mark'.
- (ignore mark)
- ,(if (eq modifier-p :maybe)
- `(let ((ibuffer-tmp-previous-buffer-modification
- (buffer-modified-p buf)))
- (prog1 ,inner-body
- (when (not (eq ibuffer-tmp-previous-buffer-modification
- (buffer-modified-p buf)))
- (setq ibuffer-did-modification t))))
- inner-body)))))
+ (lambda (buf mark)
+ ;; Silence warning for code that doesn't
+ ;; use `mark'.
+ (ignore mark)
+ ,(if (eq modifier-p :maybe)
+ `(let ((ibuffer-tmp-previous-buffer-modification
+ (buffer-modified-p buf)))
+ (prog1 ,inner-body
+ (when (not (eq ibuffer-tmp-previous-buffer-modification
+ (buffer-modified-p buf)))
+ (setq ibuffer-did-modification t))))
+ inner-body)))))
,finish)))
(if dangerous
`(when (ibuffer-confirm-operation-on ,active-opstring marked-names)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index ed0198aa436..9088f31053b 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -48,7 +48,6 @@
(require 'ibuf-macs)
(require 'dired))
-(require 'font-core)
(require 'seq)
(require 'ibuffer-loaddefs)
@@ -304,7 +303,7 @@ This variable takes precedence over filtering, and even
in completion lists of the `ibuffer-jump-to-buffer' command."
:type 'boolean)
-(defcustom ibuffer-use-header-line (boundp 'header-line-format)
+(defcustom ibuffer-use-header-line t
"If non-nil, display a header line containing current filters."
:type 'boolean)
@@ -339,6 +338,8 @@ directory, like `default-directory'."
(defcustom ibuffer-load-hook nil
"Hook run when Ibuffer is loaded."
:type 'hook)
+(make-obsolete-variable 'ibuffer-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom ibuffer-marked-face 'warning
"Face used for displaying marked buffers."
@@ -363,64 +364,6 @@ directory, like `default-directory'."
(regexp :tag "From")
(regexp :tag "To"))))
-(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 mnemonic 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))
-
- groups-map))
-
(defvar ibuffer--filter-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'ibuffer-filter-by-mode)
@@ -587,303 +530,233 @@ directory, like `default-directory'."
(define-key map (kbd "C-x 5 RET") 'ibuffer-visit-buffer-other-frame)
(define-key map (kbd "/") ibuffer--filter-map)
-
- (define-key map [menu-bar view]
- (cons "View" (make-sparse-keymap "View")))
-
- (define-key-after map [menu-bar view visit-buffer]
- '(menu-item "View this buffer" ibuffer-visit-buffer))
- (define-key-after map [menu-bar view visit-buffer-other-window]
- '(menu-item "View (other window)" ibuffer-visit-buffer-other-window))
- (define-key-after map [menu-bar view visit-buffer-other-frame]
- '(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"))
- (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'"))
-
- (define-key-after map [menu-bar view dashes]
- '("--"))
-
- (define-key-after map [menu-bar view sort]
- (cons "Sort" (make-sparse-keymap "Sort")))
-
- (define-key-after map [menu-bar view sort do-sort-by-major-mode]
- '(menu-item "Sort by major mode" ibuffer-do-sort-by-major-mode))
- (define-key-after map [menu-bar view sort do-sort-by-size]
- '(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"))
- (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"))
- (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"))
-
- (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)))
- (define-key-after map [menu-bar view filter filter-by-mode]
- '(menu-item "Add filter by any major mode..." ibuffer-filter-by-mode))
- (define-key-after map [menu-bar view filter filter-by-used-mode]
- '(menu-item "Add filter by a major mode in use..."
- ibuffer-filter-by-used-mode))
- (define-key-after map [menu-bar view filter filter-by-derived-mode]
- '(menu-item "Add filter by derived mode..."
- ibuffer-filter-by-derived-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-starred-name]
- '(menu-item "Add filter by starred buffer name..."
- ibuffer-filter-by-starred-name
- :help "List buffers whose names begin with a star"))
- (define-key-after map [menu-bar view filter filter-by-filename]
- '(menu-item "Add filter by full filename..." ibuffer-filter-by-filename
- :help
- (concat "For a buffer associated with file `/a/b/c.d', "
- "list buffer if a given pattern matches `/a/b/c.d'")))
- (define-key-after map [menu-bar view filter filter-by-basename]
- '(menu-item "Add filter by file basename..."
- ibuffer-filter-by-basename
- :help (concat "For a buffer associated with file `/a/b/c.d', "
- "list buffer if a given pattern matches `c.d'")))
- (define-key-after map [menu-bar view filter filter-by-file-extension]
- '(menu-item "Add filter by file name extension..."
- ibuffer-filter-by-file-extension
- :help (concat "For a buffer associated with file `/a/b/c.d', "
- "list buffer if a given pattern matches `d'")))
- (define-key-after map [menu-bar view filter filter-by-directory]
- '(menu-item "Add filter by filename's directory..."
- ibuffer-filter-by-directory
- :help
- (concat "For a buffer associated with file `/a/b/c.d', "
- "list buffer if a given pattern matches `/a/b'")))
- (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))
- (define-key-after map [menu-bar view filter filter-by-modified]
- '(menu-item "Add filter by modified buffer" ibuffer-filter-by-modified
- :help "List buffers that are marked as modified"))
- (define-key-after map [menu-bar view filter filter-by-visiting-file]
- '(menu-item "Add filter by buffer visiting a file"
- ibuffer-filter-by-visiting-file
- :help "List buffers that are visiting files"))
- (define-key-after map [menu-bar view filter 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))
- (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)))
- (define-key-after map [menu-bar view filter and-filter]
- '(menu-item "AND top two filters" ibuffer-and-filter
- :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
- (cdr ibuffer-filtering-qualifiers))
- :help
- "Create a new filter which is the logical AND of the top two filters"))
- (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"))
- (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)))
- (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"))
- (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))))
- (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 mnemonic 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"))
- (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"))
- (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)))
-
- (define-key-after map [menu-bar view filter-groups]
- (cons "Filter Groups" ibuffer-mode-groups-popup))
-
- (define-key-after map [menu-bar view dashes2]
- '("--"))
- (define-key-after map [menu-bar view auto-mode]
- '(menu-item "Auto Mode" ibuffer-auto-mode
- :button (:toggle . ibuffer-auto-mode)
- :help "Attempt to automatically update the Ibuffer buffer"))
-
- (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"))
- (define-key-after map [menu-bar mark change-marks]
- '(menu-item "Change marks" ibuffer-change-marks
- :help "Change OLD mark for marked buffers with NEW"))
- (define-key-after map [menu-bar mark mark-forward]
- '(menu-item "Mark" ibuffer-mark-forward
- :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"))
- (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"))
- (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"))
- (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"))
- (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"))
- (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 *"))
- (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"))
- (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"))
- (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"))
- (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"))
- (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"))
- (define-key-after map [menu-bar mark unmark-all]
- '(menu-item "Unmark All" ibuffer-unmark-all))
- (define-key-after map [menu-bar mark unmark-all-marks]
- '(menu-item "Unmark All buffers" ibuffer-unmark-all-marks))
-
- (define-key-after map [menu-bar mark dashes]
- '("--"))
-
- (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"))
- (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"))
- (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"))
- (define-key-after map [menu-bar mark ibuffer-mark-by-content-regexp]
- '(menu-item "Mark by content (regexp)..."
- ibuffer-mark-by-content-regexp
- :help "Mark buffers whose content matches a regexp"))
- (define-key-after map [menu-bar mark mark-by-locked]
- '(menu-item "Mark by locked buffers..." ibuffer-mark-by-locked
- :help "Mark all locked buffers"))
-
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]
- '(menu-item "View (separate frame)" ibuffer-do-view-other-frame))
- (define-key-after operate-map [do-save]
- '(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"))
- (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"))
- (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"))
- (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-toggle-read-only]
- '(menu-item "Toggle read-only flag" ibuffer-do-toggle-read-only))
- (define-key-after operate-map [do-toggle-lock]
- '(menu-item "Toggle lock flag" ibuffer-do-toggle-lock))
- (define-key-after operate-map [do-revert]
- '(menu-item "Revert" ibuffer-do-revert
- :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"))
- (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"))
- (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"))
- (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"))
- (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"))
- (define-key-after operate-map [do-eval]
- '(menu-item "Eval..." ibuffer-do-eval
- :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"))
- (define-key-after operate-map [diff-with-file]
- '(menu-item "Diff with file" ibuffer-diff-with-file
- :help "View the differences between this buffer and its file"))
-
- operate-map))
-
-(define-key ibuffer-mode-groups-popup [kill-filter-group]
- '(menu-item "Kill filter group"
- ibuffer-kill-line
- :enable (and (featurep 'ibuf-ext)
- ibuffer-filter-groups)))
-(define-key ibuffer-mode-groups-popup [yank-filter-group]
- '(menu-item "Yank last killed filter group"
- ibuffer-yank
- :enable (and (featurep 'ibuf-ext)
- ibuffer-filter-group-kill-ring)))
+(defun ibuffer-mode--groups-menu-definition (&optional is-popup)
+ "Build the `ibuffer' \"Filter\" menu. Internal."
+ `("Filter Groups"
+ ["Create filter group from current filters..."
+ ibuffer-filters-to-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)]
+ ["Move point to the next filter group"
+ ibuffer-forward-filter-group]
+ ["Move point to the previous filter group"
+ ibuffer-backward-filter-group]
+ ["Move point to a specific filter group..."
+ ibuffer-jump-to-filter-group]
+ ,@(if is-popup
+ '(["Kill filter group"
+ ibuffer-kill-line
+ :enable (and (featurep 'ibuf-ext)
+ ibuffer-filter-groups)]
+ ["Yank last killed filter group"
+ ibuffer-yank
+ :enable (and (featurep 'ibuf-ext)
+ ibuffer-filter-group-kill-ring)])
+ '(["Kill filter group named..."
+ ibuffer-kill-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)]
+ ["Yank last killed filter group before..."
+ ibuffer-yank-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-group-kill-ring)]))
+ ["Remove top filter group"
+ ibuffer-pop-filter-group
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)]
+ ["Remove all filter groups"
+ ibuffer-clear-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)]
+ ["Decompose filter group..."
+ ibuffer-pop-filter-group
+ :help "\"Unmake\" a filter group"
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)]
+ ["Save current filter groups permanently..."
+ ibuffer-save-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-filter-groups)
+ :help "Use a mnemonic name to store current filter groups"]
+ ["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"]
+ ["Delete permanently saved filter groups..."
+ ibuffer-delete-saved-filter-groups
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filter-groups)]
+ ["Set current filter groups to filter by mode"
+ ibuffer-set-filter-groups-by-mode]))
+
+(easy-menu-define ibuffer-mode-groups-popup nil
+ "Menu for `ibuffer'."
+ (ibuffer-mode--groups-menu-definition 'is-popup))
+
+(easy-menu-define ibuffer-mode-mark-menu ibuffer-mode-map
+ "Mark menu for `ibuffer'."
+ '("Mark"
+ ["Toggle marks" ibuffer-toggle-marks
+ :help "Unmark marked buffers, and mark unmarked buffers"]
+ ["Change marks" ibuffer-change-marks
+ :help "Change OLD mark for marked buffers with NEW"]
+ ["Mark" ibuffer-mark-forward
+ :help "Mark the buffer at point"]
+ ["Unmark" ibuffer-unmark-forward
+ :help "Unmark the buffer at point"]
+ ["Mark by mode..." ibuffer-mark-by-mode
+ :help "Mark all buffers in a particular major mode"]
+ ["Mark modified buffers" ibuffer-mark-modified-buffers
+ :help "Mark all buffers which have been modified"]
+ ["Mark unsaved buffers" ibuffer-mark-unsaved-buffers
+ :help "Mark all buffers which have a file and are modified"]
+ ["Mark read-only buffers" ibuffer-mark-read-only-buffers
+ :help "Mark all buffers which are read-only"]
+ ["Mark special buffers" ibuffer-mark-special-buffers
+ :help "Mark all buffers whose name begins with a *"]
+ ["Mark dired buffers" ibuffer-mark-dired-buffers
+ :help "Mark buffers in dired-mode"]
+ ["Mark dissociated buffers" ibuffer-mark-dissociated-buffers
+ :help "Mark buffers with a non-existent associated file"]
+ ["Mark help buffers" ibuffer-mark-help-buffers
+ :help "Mark buffers in help-mode"]
+ ["Mark compressed file buffers" ibuffer-mark-compressed-file-buffers
+ :help "Mark buffers which have a file that is compressed"]
+ ["Mark old buffers" ibuffer-mark-old-buffers
+ :help "Mark buffers which have not been viewed recently"]
+ ["Unmark All" ibuffer-unmark-all]
+ ["Unmark All buffers" ibuffer-unmark-all-marks]
+ "---"
+ ["Mark by buffer name (regexp)..." ibuffer-mark-by-name-regexp
+ :help "Mark buffers whose name matches a regexp"]
+ ["Mark by major mode (regexp)..." ibuffer-mark-by-mode-regexp
+ :help "Mark buffers whose major mode name matches a regexp"]
+ ["Mark by file name (regexp)..." ibuffer-mark-by-file-name-regexp
+ :help "Mark buffers whose file name matches a regexp"]
+ ["Mark by content (regexp)..." ibuffer-mark-by-content-regexp
+ :help "Mark buffers whose content matches a regexp"]
+ ["Mark by locked buffers..." ibuffer-mark-by-locked
+ :help "Mark all locked buffers"]))
+
+(easy-menu-define ibuffer-mode-view-menu ibuffer-mode-map
+ "View menu for `ibuffer'."
+ `("View"
+ ["View this buffer" ibuffer-visit-buffer]
+ ["View (other window)" ibuffer-visit-buffer-other-window]
+ ["View (other frame)" ibuffer-visit-buffer-other-frame]
+ ["Update" ibuffer-update
+ :help "Regenerate the list of buffers"]
+ ["Switch display format" ibuffer-switch-format
+ :help "Toggle between available values of `ibuffer-formats'"]
+ "---"
+ ("Sort"
+ ["Sort by major mode" ibuffer-do-sort-by-major-mode]
+ ["Sort by buffer size" ibuffer-do-sort-by-size]
+ ["Sort lexicographically" ibuffer-do-sort-by-alphabetic
+ :help "Sort by the alphabetic order of buffer name"]
+ ["Sort by view time" ibuffer-do-sort-by-recency
+ :help "Sort by the last time the buffer was displayed"]
+ "---"
+ ["Reverse sorting order" ibuffer-invert-sorting]
+ ["Switch sorting mode" ibuffer-toggle-sorting-mode
+ :help "Switch between the various sorting criteria"])
+ ("Filter"
+ ["Disable all filtering" ibuffer-filter-disable
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)]
+ ["Add filter by any major mode..." ibuffer-filter-by-mode]
+ ["Add filter by a major mode in use..." ibuffer-filter-by-used-mode]
+ ["Add filter by derived mode..." ibuffer-filter-by-derived-mode]
+ ["Add filter by buffer name..." ibuffer-filter-by-name]
+ ["Add filter by starred buffer name..." ibuffer-filter-by-starred-name
+ :help "List buffers whose names begin with a star"]
+ ["Add filter by full filename..." ibuffer-filter-by-filename
+ :help (concat "For a buffer associated with file `/a/b/c.d', "
+ "list buffer if a given pattern matches `/a/b/c.d'")]
+ ["Add filter by file basename..." ibuffer-filter-by-basename
+ :help (concat "For a buffer associated with file `/a/b/c.d', "
+ "list buffer if a given pattern matches `c.d'")]
+ ["Add filter by file name extension..." ibuffer-filter-by-file-extension
+ :help (concat "For a buffer associated with file `/a/b/c.d', "
+ "list buffer if a given pattern matches `d'")]
+ ["Add filter by filename's directory..." ibuffer-filter-by-directory
+ :help (concat "For a buffer associated with file `/a/b/c.d', "
+ "list buffer if a given pattern matches `/a/b'")]
+ ["Add filter by size less than..." ibuffer-filter-by-size-lt]
+ ["Add filter by size greater than..." ibuffer-filter-by-size-gt]
+ ["Add filter by modified buffer" ibuffer-filter-by-modified
+ :help "List buffers that are marked as modified"]
+ ["Add filter by buffer visiting a file" ibuffer-filter-by-visiting-file
+ :help "List buffers that are visiting files"]
+ ["Add filter by content (regexp)..." ibuffer-filter-by-content]
+ ["Add filter by Lisp predicate..." ibuffer-filter-by-predicate]
+ ["Remove top filter" ibuffer-pop-filter
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)]
+ ["AND top two filters" ibuffer-and-filter
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
+ (cdr ibuffer-filtering-qualifiers))
+ :help "Create a new filter which is the logical AND of the top two filters"]
+ ["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"]
+ ["Negate top filter" ibuffer-negate-filter
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)]
+ ["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"]
+ ["Swap top two filters" ibuffer-exchange-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
+ (cdr ibuffer-filtering-qualifiers))]
+ ["Save current filters permanently..." ibuffer-save-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)
+ :help "Use a mnemonic name to store current filter stack"]
+ ["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"]
+ ["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"]
+ ["Delete permanently saved filters..." ibuffer-delete-saved-filters
+ :enable (and (featurep 'ibuf-ext) ibuffer-saved-filters)])
+ ;; The "Filter Groups" menu:
+ ,(ibuffer-mode--groups-menu-definition)
+ "---"
+ ["Auto Mode" ibuffer-auto-mode
+ :style toggle
+ :selected ibuffer-auto-mode
+ :help "Attempt to automatically update the Ibuffer buffer"]))
+
+(define-obsolete-variable-alias 'ibuffer-mode-operate-map 'ibuffer-mode-operate-menu "28.1")
+(easy-menu-define ibuffer-mode-operate-menu ibuffer-mode-map
+ "Operate menu for `ibuffer'."
+ '("Operate"
+ ["View" ibuffer-do-view]
+ ["View (separate frame)" ibuffer-do-view-other-frame]
+ ["Save" ibuffer-do-save]
+ ["Replace (regexp)..." ibuffer-do-replace-regexp
+ :help "Replace text inside marked buffers"]
+ ["Query Replace..." ibuffer-do-query-replace
+ :help "Replace text in marked buffers, asking each time"]
+ ["Query Replace (regexp)..." ibuffer-do-query-replace-regexp
+ :help "Replace text in marked buffers by regexp, asking each time"]
+ ["Print" ibuffer-do-print]
+ ["Toggle modification flag" ibuffer-do-toggle-modified]
+ ["Toggle read-only flag" ibuffer-do-toggle-read-only]
+ ["Toggle lock flag" ibuffer-do-toggle-lock]
+ ["Revert" ibuffer-do-revert
+ :help "Revert marked buffers to their associated file"]
+ ["Rename Uniquely" ibuffer-do-rename-uniquely
+ :help "Rename marked buffers to a new, unique name"]
+ ["Kill" ibuffer-do-delete]
+ ["List lines matching..." ibuffer-do-occur
+ :help "View all lines in marked buffers matching a regexp"]
+ ["Pipe to shell command..." ibuffer-do-shell-command-pipe
+ :help "For each marked buffer, send its contents to a shell command"]
+ ["Pipe to shell command (replace)..." ibuffer-do-shell-command-pipe-replace
+ :help "For each marked buffer, replace its contents with output of shell command"]
+ ["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"]
+ ["Eval..." ibuffer-do-eval
+ :help "Evaluate a Lisp form in each marked buffer"]
+ ["Eval (viewing buffer)..." ibuffer-do-view-and-eval
+ :help "Evaluate a Lisp form in each marked buffer while viewing it"]
+ ["Diff with file" ibuffer-diff-with-file
+ :help "View the differences between this buffer and its file"]))
(defvar ibuffer-name-map
(let ((map (make-sparse-keymap)))
@@ -1024,7 +897,7 @@ width and the longest string in LIST."
(goto-char eventpt)
(ibuffer-set-mark ibuffer-marked-char))
(save-excursion
- (popup-menu ibuffer-mode-operate-map)))))
+ (popup-menu ibuffer-mode-operate-menu)))))
(setq buffer-read-only t)
(if (= eventpt (point))
(goto-char origpt)))))
@@ -1115,9 +988,7 @@ one window."
(let ((buf (ibuffer-current-buffer t)))
(bury-buffer (current-buffer))
(if noselect
- (let ((curwin (selected-window)))
- (pop-to-buffer buf)
- (select-window curwin))
+ (display-buffer buf)
(switch-to-buffer-other-window buf))))
(defun ibuffer-visit-buffer-other-window-noselect ()
@@ -1208,8 +1079,11 @@ a new window in the current frame, splitting vertically."
;; Make sure that redisplay is performed, otherwise there can be a
;; bad interaction with code in the window-scroll-functions hook
(redisplay t)
- (fit-window-to-buffer nil (when owin (/ (frame-height)
- (length (window-list (selected-frame)))))))
+ (when (buffer-local-value 'ibuffer-auto-mode (window-buffer))
+ (fit-window-to-buffer
+ nil (and owin
+ (/ (frame-height)
+ (length (window-list (selected-frame))))))))
(defun ibuffer-confirm-operation-on (operation names)
"Display a buffer asking whether to perform OPERATION on NAMES."
@@ -1307,6 +1181,11 @@ a new window in the current frame, splitting vertically."
(car dired-directory)))))
(and dirname (expand-file-name dirname))))))
+(defun ibuffer--abbreviate-file-name (filename)
+ "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'."
+ (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
+ (abbreviate-file-name filename)))
+
(define-ibuffer-op ibuffer-do-save ()
"Save marked buffers as with `save-buffer'."
(:complex t
@@ -1595,7 +1474,7 @@ If point is on a group name, this function operates on that group."
(defun ibuffer-compile-make-substring-form (strvar maxvar from-end-p)
(if from-end-p
;; FIXME: not sure if this case is correct (Bug#24972)
- `(truncate-string-to-width str strlen (- strlen ,maxvar) nil ?\s)
+ `(truncate-string-to-width str strlen (- strlen ,maxvar) ?\s)
`(truncate-string-to-width ,strvar ,maxvar nil ?\s)))
(defun ibuffer-compile-make-format-form (strvar widthform alignment)
@@ -1884,9 +1763,7 @@ If point is on a group name, this function operates on that group."
(cond ((zerop total) "No files")
((= 1 total) "1 file")
(t (format "%d files" total))))))
- (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
- (abbreviate-file-name
- (or (ibuffer-buffer-file-name) ""))))
+ (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) "")))
(define-ibuffer-column filename-and-process
(:name "Filename/Process"
@@ -2125,16 +2002,13 @@ the value of point at the beginning of the line for that buffer."
(and ibuffer-buf
(not (eq ibuffer-buf buf))))))
-;; This function is a special case; it's not defined by
-;; `define-ibuffer-sorter'.
-(defun ibuffer-do-sort-by-recency ()
- "Sort the buffers by last view time."
- (interactive)
- (setq ibuffer-sorting-mode 'recency)
- (when (eq ibuffer-last-sorting-mode 'recency)
- (setq ibuffer-sorting-reversep (not ibuffer-sorting-reversep)))
- (ibuffer-update nil t)
- (setq ibuffer-last-sorting-mode 'recency))
+(define-ibuffer-sorter recency
+ "Sort the buffers by how recently they've been used."
+ (:description "recency")
+ (time-less-p (with-current-buffer (car b)
+ (or buffer-display-time 0))
+ (with-current-buffer (car a)
+ (or buffer-display-time 0))))
(defun ibuffer-update-format ()
(when (null ibuffer-current-format)
@@ -2424,7 +2298,7 @@ buffers which are visiting a file."
(defun ibuffer (&optional other-window-p name qualifiers noselect
shrink filter-groups formats)
"Begin using Ibuffer to edit a list of buffers.
-Type `h' after entering ibuffer for more information.
+Type \\<ibuffer-mode-map>\\[describe-mode] after entering ibuffer for more information.
All arguments are optional.
OTHER-WINDOW-P says to use another window.
@@ -2463,7 +2337,7 @@ FORMATS is the value to use for `ibuffer-formats'.
(require 'ibuf-ext)
(setq ibuffer-filter-groups filter-groups))
(when formats
- (set (make-local-variable 'ibuffer-formats) formats))
+ (setq-local ibuffer-formats formats))
(ibuffer-update nil)
;; Skip the group name by default.
(ibuffer-forward-line 0 t)
@@ -2682,7 +2556,7 @@ You may rearrange filter groups by using the usual pair
`\\[ibuffer-kill-line]' and `\\[ibuffer-yank]'. Yanked groups
will be inserted before the group at point."
;; Include state info next to the mode name.
- (set (make-local-variable 'mode-line-process)
+ (setq-local mode-line-process
'(" by "
(ibuffer-sorting-mode (:eval (symbol-name ibuffer-sorting-mode))
"view time")
@@ -2706,35 +2580,33 @@ will be inserted before the group at point."
(setq buffer-read-only t)
(buffer-disable-undo)
(setq truncate-lines ibuffer-truncate-lines)
- ;; This makes things less ugly for Emacs 21 users with a non-nil
+ ;; This makes things less ugly for users with a non-nil
;; `show-trailing-whitespace'.
(setq show-trailing-whitespace nil)
;; disable `show-paren-mode' buffer-locally
(if (bound-and-true-p show-paren-mode)
- (set (make-local-variable 'show-paren-mode) nil))
- (set (make-local-variable 'revert-buffer-function)
- #'ibuffer-update)
- (set (make-local-variable 'ibuffer-sorting-mode)
- ibuffer-default-sorting-mode)
- (set (make-local-variable 'ibuffer-sorting-reversep)
- ibuffer-default-sorting-reversep)
- (set (make-local-variable 'ibuffer-shrink-to-minimum-size)
- ibuffer-default-shrink-to-minimum-size)
- (set (make-local-variable 'ibuffer-display-maybe-show-predicates)
- ibuffer-default-display-maybe-show-predicates)
- (set (make-local-variable 'ibuffer-filtering-qualifiers) nil)
- (set (make-local-variable 'ibuffer-filter-groups) nil)
- (set (make-local-variable 'ibuffer-filter-group-kill-ring) nil)
- (set (make-local-variable 'ibuffer-hidden-filter-groups) nil)
- (set (make-local-variable 'ibuffer-compiled-formats) nil)
- (set (make-local-variable 'ibuffer-cached-formats) nil)
- (set (make-local-variable 'ibuffer-cached-eliding-string) nil)
- (set (make-local-variable 'ibuffer-current-format) nil)
- (set (make-local-variable 'ibuffer-did-modification) nil)
- (set (make-local-variable 'ibuffer-tmp-hide-regexps) nil)
- (set (make-local-variable 'ibuffer-tmp-show-regexps) nil)
+ (setq-local show-paren-mode nil))
+ (setq-local revert-buffer-function #'ibuffer-update)
+ (setq-local ibuffer-sorting-mode
+ ibuffer-default-sorting-mode)
+ (setq-local ibuffer-sorting-reversep
+ ibuffer-default-sorting-reversep)
+ (setq-local ibuffer-shrink-to-minimum-size
+ ibuffer-default-shrink-to-minimum-size)
+ (setq-local ibuffer-display-maybe-show-predicates
+ ibuffer-default-display-maybe-show-predicates)
+ (setq-local ibuffer-filtering-qualifiers nil)
+ (setq-local ibuffer-filter-groups nil)
+ (setq-local ibuffer-filter-group-kill-ring nil)
+ (setq-local ibuffer-hidden-filter-groups nil)
+ (setq-local ibuffer-compiled-formats nil)
+ (setq-local ibuffer-cached-formats nil)
+ (setq-local ibuffer-cached-eliding-string nil)
+ (setq-local ibuffer-current-format nil)
+ (setq-local ibuffer-did-modification nil)
+ (setq-local ibuffer-tmp-hide-regexps nil)
+ (setq-local ibuffer-tmp-show-regexps nil)
(define-key ibuffer-mode-map [menu-bar edit] 'undefined)
- (define-key ibuffer-mode-map [menu-bar operate] (cons "Operate" ibuffer-mode-operate-map))
(ibuffer-update-format)
(when ibuffer-default-directory
(setq default-directory ibuffer-default-directory))
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index f80ada7a990..adea1505fd2 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -50,6 +50,8 @@
;;; Code:
(require 'rfn-eshadow) ; rfn-eshadow-overlay
+(require 'simple) ; max-mini-window-lines
+(require 'cl-lib)
(defgroup icomplete nil
"Show completions dynamically in minibuffer."
@@ -75,7 +77,13 @@ everything preceding the ~/ is discarded so the interactive
selection process starts again from the user's $HOME.")
(defcustom icomplete-show-matches-on-no-input nil
- "When non-nil, show completions when first prompting for input."
+ "When non-nil, show completions when first prompting for input.
+This means to show completions even when the current minibuffer contents
+is the same as was the initial input after minibuffer activation.
+This also means that if you traverse the list of completions with
+commands like `C-.' and just hit RET without typing any
+characters, the match under point will be chosen instead of the
+default."
:type 'boolean
:version "24.4")
@@ -89,10 +97,20 @@ Otherwise this should be a list of the completion tables (e.g.,
:type '(choice (const :tag "All" t)
(repeat function)))
+(defcustom icomplete-matches-format "%s/%s "
+ "Format of the current/total number of matches for the prompt prefix."
+ :version "28.1"
+ :type '(choice (const :tag "No prefix" nil)
+ (string :tag "Prefix format string")))
+
(defface icomplete-first-match '((t :weight bold))
"Face used by Icomplete for highlighting first match."
:version "24.4")
+(defface icomplete-selected-match '((t :inherit highlight))
+ "Face used by `icomplete-vertical-mode' for the selected candidate."
+ :version "24.4")
+
;;;_* User Customization variables
(defcustom icomplete-prospects-height 2
;; We used to compute how many lines 100 characters would take in
@@ -103,7 +121,7 @@ Otherwise this should be a list of the completion tables (e.g.,
:type 'integer
:version "26.1")
-(defcustom icomplete-compute-delay .3
+(defcustom icomplete-compute-delay .15
"Completions-computation stall, used only with large-number completions.
See `icomplete-delay-completions-threshold'."
:type 'number)
@@ -112,7 +130,7 @@ See `icomplete-delay-completions-threshold'."
"Pending-completions number over which to apply `icomplete-compute-delay'."
:type 'integer)
-(defcustom icomplete-max-delay-chars 3
+(defcustom icomplete-max-delay-chars 2
"Maximum number of initial chars to apply `icomplete-compute-delay'."
:type 'integer)
@@ -142,9 +160,9 @@ icompletion is occurring."
(defvar icomplete-overlay (make-overlay (point-min) (point-min) nil t t)
"Overlay used to display the list of completions.")
-(defun icomplete-pre-command-hook ()
- (let ((non-essential t))
- (icomplete-tidy)))
+(defvar icomplete--initial-input nil
+ "Initial input in the minibuffer when icomplete-mode was activated.
+Used to implement the option `icomplete-show-matches-on-no-input'.")
(defun icomplete-post-command-hook ()
(let ((non-essential t)) ;E.g. don't prompt for password!
@@ -153,12 +171,22 @@ icompletion is occurring."
(defvar icomplete-minibuffer-map
(let ((map (make-sparse-keymap)))
(define-key map [?\M-\t] 'icomplete-force-complete)
+ (define-key map [remap minibuffer-complete-and-exit] 'icomplete-ret)
(define-key map [?\C-j] 'icomplete-force-complete-and-exit)
(define-key map [?\C-.] 'icomplete-forward-completions)
(define-key map [?\C-,] 'icomplete-backward-completions)
map)
"Keymap used by `icomplete-mode' in the minibuffer.")
+(defun icomplete-ret ()
+ "Exit minibuffer for icomplete."
+ (interactive)
+ (if (and icomplete-show-matches-on-no-input
+ (car completion-all-sorted-completions)
+ (equal (icomplete--field-string) icomplete--initial-input))
+ (icomplete-force-complete-and-exit)
+ (minibuffer-complete-and-exit)))
+
(defun icomplete-force-complete-and-exit ()
"Complete the minibuffer with the longest possible match and exit.
Use the first of the matches if there are any displayed, and use
@@ -175,7 +203,7 @@ the default otherwise."
(if (or
;; there's some input, meaning the default in off the table by
;; definition; OR
- (> (icomplete--field-end) (icomplete--field-beg))
+ (not (equal (icomplete--field-string) icomplete--initial-input))
;; there's no input, but there's also no minibuffer default
;; (and the user really wants to see completions on no input,
;; meaning he expects a "force" to be at least attempted); OR
@@ -195,6 +223,29 @@ the default otherwise."
;; We're not at all interested in cycling here (bug#34077).
(minibuffer-force-complete nil nil 'dont-cycle))
+;; Apropos `icomplete-scroll', we implement "scrolling icomplete"
+;; within classic icomplete, which is "rotating", by contrast.
+;;
+;; The two variables supporing this are
+;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'.
+;; They come into play when:
+;;
+;; - The user invokes commands `icomplete-forward-completions' and
+;; `icomplete-backward-completions', thus "manually" scrolling to a
+;; given position;
+;;
+;; - The user re-filters a selection that had already been manually
+;; scrolled. The system attempts to keep the previous selection
+;; stable in the face of the new filtering. This is mostly done in
+;; `icomplete--render-vertical'.
+;;
+(defvar icomplete-scroll nil
+ "If non-nil, scroll candidates list instead of rotating it.")
+(defvar icomplete--scrolled-completions nil
+ "If non-nil, tail of completions list manually scrolled to.")
+(defvar icomplete--scrolled-past nil
+ "If non-nil, reverse tail of completions scrolled past.")
+
(defun icomplete-forward-completions ()
"Step forward completions by one entry.
Second entry becomes the first and can be selected with
@@ -203,10 +254,14 @@ Second entry becomes the first and can be selected with
(let* ((beg (icomplete--field-beg))
(end (icomplete--field-end))
(comps (completion-all-sorted-completions beg end))
- (last (last comps)))
- (when comps
- (setcdr last (cons (car comps) (cdr last)))
- (completion--cache-all-sorted-completions beg end (cdr comps)))))
+ (last (last comps)))
+ (when (consp (cdr comps))
+ (cond (icomplete-scroll
+ (push (pop comps) icomplete--scrolled-past)
+ (setq icomplete--scrolled-completions comps))
+ (t
+ (setcdr (last comps) (cons (pop comps) (cdr last)))))
+ (completion--cache-all-sorted-completions beg end comps))))
(defun icomplete-backward-completions ()
"Step backward completions by one entry.
@@ -216,15 +271,19 @@ Last entry becomes the first and can be selected with
(let* ((beg (icomplete--field-beg))
(end (icomplete--field-end))
(comps (completion-all-sorted-completions beg end))
- (last-but-one (last comps 2))
- (last (cdr last-but-one)))
- (when (consp last) ; At least two elements in comps
- (setcdr last-but-one (cdr last))
- (push (car last) comps)
- (completion--cache-all-sorted-completions beg end comps))))
+ last-but-one)
+ (cond ((and icomplete-scroll icomplete--scrolled-past)
+ (push (pop icomplete--scrolled-past) comps)
+ (setq icomplete--scrolled-completions comps))
+ ((and (not icomplete-scroll)
+ (consp (cdr (setq last-but-one (last comps 2)))))
+ ;; At least two elements in comps
+ (push (car (cdr last-but-one)) comps)
+ (setcdr last-but-one (cdr (cdr last-but-one)))))
+ (completion--cache-all-sorted-completions beg end comps)))
+
+;;;_* Helpers for `fido-mode' (or `ido-mode' emulation)
-;;; Helpers for `fido-mode' (or `ido-mode' emulation)
-;;;
(defun icomplete-fido-kill ()
"Kill line or current completion, like `ido-mode'.
If killing to the end of line make sense, call `kill-line',
@@ -278,7 +337,8 @@ require user confirmation."
(file-name-directory (icomplete--field-string))))
(current (car completion-all-sorted-completions))
(probe (and dir current
- (expand-file-name (directory-file-name current) dir))))
+ (expand-file-name (directory-file-name current)
+ (substitute-env-vars dir)))))
(cond ((and probe (file-directory-p probe) (not (string= current "./")))
(icomplete-force-complete))
(t
@@ -331,6 +391,7 @@ if that doesn't produce a completion match."
(setq-local icomplete-tidy-shadowed-file-names t
icomplete-show-matches-on-no-input t
icomplete-hide-common-prefix nil
+ icomplete-scroll (not (null icomplete-vertical-mode))
completion-styles '(flex)
completion-flex-nospace nil
completion-category-defaults nil
@@ -427,10 +488,11 @@ Conditions are:
"Run in minibuffer on activation to establish incremental completion.
Usually run by inclusion in `minibuffer-setup-hook'."
(when (and icomplete-mode (icomplete-simple-completing-p))
- (set (make-local-variable 'completion-show-inline-help) nil)
+ (setq-local icomplete--initial-input (icomplete--field-string))
+ (setq-local completion-show-inline-help nil)
+ (setq icomplete--scrolled-completions nil)
(use-local-map (make-composed-keymap icomplete-minibuffer-map
(current-local-map)))
- (add-hook 'pre-command-hook #'icomplete-pre-command-hook nil t)
(add-hook 'post-command-hook #'icomplete-post-command-hook nil t)
(run-hooks 'icomplete-minibuffer-setup-hook)))
@@ -444,73 +506,140 @@ Usually run by inclusion in `minibuffer-setup-hook'."
(setq icomplete--in-region-buffer nil)
(delete-overlay icomplete-overlay)
(kill-local-variable 'completion-show-inline-help)
- (remove-hook 'pre-command-hook 'icomplete-pre-command-hook t)
(remove-hook 'post-command-hook 'icomplete-post-command-hook t)
(message nil)))
(when (and completion-in-region-mode
icomplete-mode (icomplete-simple-completing-p))
(setq icomplete--in-region-buffer (current-buffer))
- (set (make-local-variable 'completion-show-inline-help) nil)
+ (setq-local completion-show-inline-help nil)
(let ((tem (assq 'completion-in-region-mode
minor-mode-overriding-map-alist)))
(unless (memq icomplete-minibuffer-map (cdr tem))
(setcdr tem (make-composed-keymap icomplete-minibuffer-map
(cdr tem)))))
- (add-hook 'pre-command-hook 'icomplete-pre-command-hook nil t)
(add-hook 'post-command-hook 'icomplete-post-command-hook nil t)))
(defun icomplete--sorted-completions ()
(or completion-all-sorted-completions
(cl-loop
+ initially (setq icomplete--scrolled-past nil) ; Invalidate scrolled state
with beg = (icomplete--field-beg)
with end = (icomplete--field-end)
with all = (completion-all-sorted-completions beg end)
+ ;; Icomplete mode re-sorts candidates, bubbling the default to
+ ;; top if it's found somewhere down the list. This loop's
+ ;; iteration variable, `fn' iterates through these "bubble up
+ ;; predicates" which may vary depending on specific
+ ;; `completing-read' invocations, described below:
for fn in (cond ((and minibuffer-default
(stringp minibuffer-default) ; bug#38992
- (= (icomplete--field-end) (icomplete--field-beg)))
- ;; When we have a non-nil string default and
- ;; no input whatsoever: we want to make sure
- ;; that default is bubbled to the top so that
- ;; `icomplete-force-complete-and-exit' will
- ;; select it (do that even if the match
- ;; doesn't match the completion perfectly.
- `(,(lambda (comp)
+ (equal (icomplete--field-string) icomplete--initial-input))
+ ;; Here, we have a non-nil string default and
+ ;; no input whatsoever. We want to make sure
+ ;; that the default is bubbled to the top so
+ ;; that `icomplete-force-complete-and-exit'
+ ;; will select it. We want to do that even if
+ ;; the match doesn't match the completion
+ ;; perfectly.
+ ;;
+ `(;; The first predicate ensures that:
+ ;;
+ ;; (completing-read "thing? " '("foo" "bar")
+ ;; nil nil nil nil "bar")
+ ;;
+ ;; Has "bar" at the top, so RET will select
+ ;; it, as desired.
+ ,(lambda (comp)
(equal minibuffer-default comp))
+ ;; Why do we need this second predicate?
+ ;; Because that'll make things like M-x man
+ ;; RET RET, when invoked with point on the
+ ;; "bar" word, behave correctly. There, the
+ ;; default doesn't quite match any
+ ;; candidate. So:
+ ;;
+ ;; (completing-read "Man entry? " '("foo(1)" "bar(1)")
+ ;; nil nil nil nil "bar")
+ ;;
+ ;; Will place "bar(1)" on top, and RET will
+ ;; select it -- again, as desired.
+ ;;
+ ;; FIXME: it's arguable that this second
+ ;; behaviour should be a property of the
+ ;; completion table and not the completion
+ ;; frontend such as we have done
+ ;; here. However, it seems generically
+ ;; useful for a very broad spectrum of
+ ;; cases.
,(lambda (comp)
(string-prefix-p minibuffer-default comp))))
((and fido-mode
(not minibuffer-default)
(eq (icomplete--category) 'file))
- ;; `fido-mode' has some extra file-sorting
- ;; semantics even if there isn't a default,
- ;; which is to bubble "./" to the top if it
- ;; exists. This makes M-x dired RET RET go to
- ;; the directory of current file, which is
- ;; what vanilla Emacs and `ido-mode' both do.
+ ;; When there isn't a default, `fido-mode'
+ ;; specifically also has some extra
+ ;; file-sorting semantics inherited from Ido.
+ ;; Those make the directory "./" bubble to the
+ ;; top (if it exists). This makes M-x dired
+ ;; RET RET go to the directory of current
+ ;; file, which is non-Icomplete vanilla Emacs
+ ;; and `ido-mode' both do.
`(,(lambda (comp)
(string= "./" comp)))))
- thereis (cl-loop
- for l on all
- while (consp (cdr l))
- for comp = (cadr l)
- when (funcall fn comp)
- do (setf (cdr l) (cddr l))
- and return
- (completion--cache-all-sorted-completions beg end (cons comp all)))
+ ;; After we have setup the predicates, look for a completion
+ ;; matching one of them and bubble up it, destructively on
+ ;; `completion-all-sorted-completions' (unless that completion
+ ;; happens to be already on top).
+ thereis (or
+ (and (funcall fn (car all)) all)
+ (cl-loop
+ for l on all
+ while (consp (cdr l))
+ for comp = (cadr l)
+ when (funcall fn comp)
+ do (setf (cdr l) (cddr l))
+ and return
+ (completion--cache-all-sorted-completions beg end (cons comp all))))
finally return all)))
+(defvar icomplete-vertical-mode-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-n") 'icomplete-forward-completions)
+ (define-key map (kbd "C-p") 'icomplete-backward-completions)
+ map)
+ "Keymap used by `icomplete-vertical-mode' in the minibuffer.")
+
+(defun icomplete--vertical-minibuffer-setup ()
+ "Setup the minibuffer for vertical display of completion candidates."
+ (use-local-map (make-composed-keymap icomplete-vertical-mode-minibuffer-map
+ (current-local-map)))
+ (setq-local icomplete-separator "\n"
+ icomplete-hide-common-prefix nil
+ ;; Ask `icomplete-completions' to return enough completions candidates.
+ icomplete-prospects-height 25
+ redisplay-adhoc-scroll-in-resize-mini-windows nil))
+
+;;;###autoload
+(define-minor-mode icomplete-vertical-mode
+ "Toggle vertical candidate display in `icomplete-mode' or `fido-mode'.
+
+As many completion candidates as possible are displayed, depending on
+the value of `max-mini-window-height', and the way the mini-window is
+resized depends on `resize-mini-windows'."
+ :global t
+ (remove-hook 'icomplete-minibuffer-setup-hook
+ #'icomplete--vertical-minibuffer-setup)
+ (when icomplete-vertical-mode
+ (add-hook 'icomplete-minibuffer-setup-hook
+ #'icomplete--vertical-minibuffer-setup)))
+
+(defalias 'fido-vertical-mode 'icomplete-vertical-mode)
+
;;;_* Completion
-;;;_ > icomplete-tidy ()
-(defun icomplete-tidy ()
- "Remove completions display (if any) prior to new user input.
-Should be run in on the minibuffer `pre-command-hook'.
-See `icomplete-mode' and `minibuffer-setup-hook'."
- (delete-overlay icomplete-overlay))
-
;;;_ > icomplete-exhibit ()
(defun icomplete-exhibit ()
"Insert Icomplete completions display.
@@ -523,7 +652,8 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
(goto-char (point-max))
; Insert the match-status information:
(when (and (or icomplete-show-matches-on-no-input
- (> (icomplete--field-end) (icomplete--field-beg)))
+ (not (equal (icomplete--field-string)
+ icomplete--initial-input)))
(or
;; Don't bother with delay after certain number of chars:
(> (- (point) (icomplete--field-beg))
@@ -546,7 +676,7 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
(or (>= (- (point) (overlay-end rfn-eshadow-overlay)) 2)
(eq ?/ (char-before (- (point) 2)))))
(delete-region (overlay-start rfn-eshadow-overlay)
- (overlay-end rfn-eshadow-overlay)) )
+ (overlay-end rfn-eshadow-overlay)))
(let* ((field-string (icomplete--field-string))
;; Not sure why, but such requests seem to come
;; every once in a while. It's not fully
@@ -564,13 +694,126 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
deactivate-mark)
;; Do nothing if while-no-input was aborted.
(when (stringp text)
- (move-overlay icomplete-overlay (point) (point) (current-buffer))
+ (move-overlay icomplete-overlay (point-min) (point) (current-buffer))
;; The current C cursor code doesn't know to use the overlay's
;; marker's stickiness to figure out whether to place the cursor
;; before or after the string, so let's spoon-feed it the pos.
(put-text-property 0 1 'cursor t text)
+ (overlay-put
+ icomplete-overlay 'before-string
+ (and icomplete-scroll
+ icomplete-matches-format
+ (let* ((past (length icomplete--scrolled-past))
+ (current (1+ past))
+ (total (+ past (safe-length
+ completion-all-sorted-completions))))
+ (format icomplete-matches-format current total))))
(overlay-put icomplete-overlay 'after-string text))))))))
+(defun icomplete--affixate (md prospects)
+ "Affixate PROSPECTS given completion metadata MD.
+Return a list of (COMP PREFIX SUFFIX)."
+ (let ((aff-fun (or (completion-metadata-get md 'affixation-function)
+ (plist-get completion-extra-properties :affixation-function)))
+ (ann-fun (or (completion-metadata-get md 'annotation-function)
+ (plist-get completion-extra-properties :annotation-function))))
+ (cond (aff-fun
+ (funcall aff-fun prospects))
+ (ann-fun
+ (mapcar
+ (lambda (comp)
+ (let ((suffix (or (funcall ann-fun comp) "")))
+ (list comp ""
+ ;; The default completion UI adds the
+ ;; `completions-annotations' face if no
+ ;; other faces are present.
+ (if (text-property-not-all 0 (length suffix) 'face nil suffix)
+ suffix
+ (propertize suffix 'face 'completions-annotations)))))
+ prospects))
+ (prospects))))
+
+(cl-defun icomplete--render-vertical (comps md &aux scroll-above scroll-below)
+ ;; Welcome to loopapalooza!
+ ;;
+ ;; First, be mindful of `icomplete-scroll' and manual scrolls. If
+ ;; `icomplete--scrolled-completions' and `icomplete--scrolled-past'
+ ;; are:
+ ;;
+ ;; - both nil, there is no manual scroll;
+ ;; - both non-nil, there is a healthy manual scroll the doesn't need
+ ;; to be readjusted (user just moved around the minibuffer, for
+ ;; example)l
+ ;; - non-nil and nil, respectively, a refiltering took place and we
+ ;; need attempt to readjust them to the new filtered `comps'.
+ (when (and icomplete-scroll
+ icomplete--scrolled-completions
+ (null icomplete--scrolled-past))
+ (cl-loop with preds
+ for (comp . rest) on comps
+ when (equal comp (car icomplete--scrolled-completions))
+ do
+ (setq icomplete--scrolled-past preds
+ comps (cons comp rest))
+ (completion--cache-all-sorted-completions
+ (icomplete--field-beg)
+ (icomplete--field-end)
+ comps)
+ and return nil
+ do (push comp preds)
+ finally (setq icomplete--scrolled-completions nil)))
+ ;; Then, in this pretty ugly loop, collect completions to display
+ ;; above and below the selected one, considering scrolling
+ ;; positions.
+ (cl-loop with preds = icomplete--scrolled-past
+ with succs = (cdr comps)
+ with max-lines = (1- (min
+ icomplete-prospects-height
+ (truncate (max-mini-window-lines) 1)))
+ with max-above = (- max-lines
+ 1
+ (cl-loop for (_ . r) on comps
+ repeat (truncate max-lines 2)
+ while (listp r)
+ count 1))
+ repeat max-lines
+ for neighbour = nil
+ if (and preds (> max-above 0)) do
+ (push (setq neighbour (pop preds)) scroll-above)
+ (cl-decf max-above)
+ else if (consp succs) collect
+ (setq neighbour (pop succs)) into scroll-below-aux
+ while neighbour
+ finally (setq scroll-below scroll-below-aux))
+ ;; Now figure out spacing and layout
+ ;;
+ (cl-loop
+ with selected = (substring (car comps))
+ initially (add-face-text-property 0 (length selected)
+ 'icomplete-selected-match 'append selected)
+ with torender = (nconc scroll-above (list selected) scroll-below)
+ with triplets = (icomplete--affixate md torender)
+ initially (when (eq triplets torender)
+ (cl-return-from icomplete--render-vertical
+ (concat
+ " \n"
+ (mapconcat #'identity torender icomplete-separator))))
+ for (comp prefix) in triplets
+ maximizing (length prefix) into max-prefix-len
+ maximizing (length comp) into max-comp-len
+ finally return
+ ;; Finally, render
+ ;;
+ (concat
+ " \n"
+ (cl-loop for (comp prefix suffix) in triplets
+ concat prefix
+ concat (make-string (- max-prefix-len (length prefix)) ? )
+ concat comp
+ concat (make-string (- max-comp-len (length comp)) ? )
+ concat suffix
+ concat icomplete-separator))))
+
;;;_ > icomplete-completions (name candidates predicate require-match)
(defun icomplete-completions (name candidates predicate require-match)
"Identify prospective candidates for minibuffer completion.
@@ -608,125 +851,131 @@ matches exist."
predicate))
(md (completion--field-metadata (icomplete--field-beg)))
(comps (icomplete--sorted-completions))
- (last (if (consp comps) (last comps)))
- (base-size (cdr last))
(open-bracket (if require-match "(" "["))
(close-bracket (if require-match ")" "]")))
;; `concat'/`mapconcat' is the slow part.
(if (not (consp comps))
(progn ;;(debug (format "Candidates=%S field=%S" candidates name))
(format " %sNo matches%s" open-bracket close-bracket))
- (if last (setcdr last nil))
- (let* ((most-try
- (if (and base-size (> base-size 0))
- (completion-try-completion
- name candidates predicate (length name) md)
- ;; If the `comps' are 0-based, the result should be
- ;; the same with `comps'.
- (completion-try-completion
- name comps nil (length name) md)))
- (most (if (consp most-try) (car most-try)
- (if most-try (car comps) "")))
- ;; Compare name and most, so we can determine if name is
- ;; a prefix of most, or something else.
- (compare (compare-strings name nil nil
- most nil nil completion-ignore-case))
- (ellipsis (if (char-displayable-p ?…) "…" "..."))
- (determ (unless (or (eq t compare) (eq t most-try)
- (= (setq compare (1- (abs compare)))
- (length most)))
- (concat open-bracket
- (cond
- ((= compare (length name))
- ;; Typical case: name is a prefix.
- (substring most compare))
- ;; Don't bother truncating if it doesn't gain
- ;; us at least 2 columns.
- ((< compare (+ 2 (string-width ellipsis))) most)
- (t (concat ellipsis (substring most compare))))
- close-bracket)))
- ;;"-prospects" - more than one candidate
- (prospects-len (+ (string-width
- (or determ (concat open-bracket close-bracket)))
- (string-width icomplete-separator)
- (+ 2 (string-width ellipsis)) ;; take {…} into account
- (string-width (buffer-string))))
- (prospects-max
- ;; Max total length to use, including the minibuffer content.
- (* (+ icomplete-prospects-height
- ;; If the minibuffer content already uses up more than
- ;; one line, increase the allowable space accordingly.
- (/ prospects-len (window-width)))
- (window-width)))
- ;; Find the common prefix among `comps'.
- ;; We can't use the optimization below because its assumptions
- ;; aren't always true, e.g. when completion-cycling (bug#10850):
- ;; (if (eq t (compare-strings (car comps) nil (length most)
- ;; most nil nil completion-ignore-case))
- ;; ;; Common case.
- ;; (length most)
- ;; Else, use try-completion.
- (prefix (when icomplete-hide-common-prefix
- (try-completion "" comps)))
- (prefix-len
- (and (stringp prefix)
- ;; Only hide the prefix if the corresponding info
- ;; is already displayed via `most'.
- (string-prefix-p prefix most t)
- (length prefix))) ;;)
- prospects comp limit)
- (if (or (eq most-try t) (not (consp (cdr comps))))
- (setq prospects nil)
- (when (member name comps)
- ;; NAME is complete but not unique. This scenario poses
- ;; following UI issues:
- ;;
- ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
- ;; is stripped empty. This would make the entry
- ;; inconspicuous.
- ;;
- ;; - Due to sorting of completions, NAME may not be the
- ;; first of the prospects and could be hidden deep in
- ;; the displayed string.
- ;;
- ;; - Because of `icomplete-prospects-height' , NAME may
- ;; not even be displayed to the user.
- ;;
- ;; To circumvent all the above problems, provide a visual
- ;; cue to the user via an "empty string" in the try
- ;; completion field.
- (setq determ (concat open-bracket "" close-bracket)))
- ;; Compute prospects for display.
- (while (and comps (not limit))
- (setq comp
- (if prefix-len (substring (car comps) prefix-len) (car comps))
- comps (cdr comps))
- (setq prospects-len
- (+ (string-width comp)
- (string-width icomplete-separator)
- prospects-len))
- (if (< prospects-len prospects-max)
- (push comp prospects)
- (setq limit t))))
- (setq prospects (nreverse prospects))
- ;; Decorate first of the prospects.
- (when prospects
- (let ((first (copy-sequence (pop prospects))))
- (put-text-property 0 (length first)
- 'face 'icomplete-first-match first)
- (push first prospects)))
- ;; Restore the base-size info, since completion-all-sorted-completions
- ;; is cached.
- (if last (setcdr last base-size))
- (if prospects
- (concat determ
- "{"
- (mapconcat 'identity prospects icomplete-separator)
- (and limit (concat icomplete-separator ellipsis))
- "}")
- (concat determ " [Matched]"))))))
-
-;;; Iswitchb compatibility
+ (if icomplete-vertical-mode
+ (icomplete--render-vertical comps md)
+ (let* ((last (if (consp comps) (last comps)))
+ ;; Save the "base size" encoded in `comps' then
+ ;; removing making `comps' a proper list.
+ (base-size (prog1 (cdr last)
+ (if last (setcdr last nil))))
+ (most-try
+ ;; icomplete-hide-common-prefix logic is used
+ ;; unconditionally when there is single match.
+ (when (or icomplete-hide-common-prefix (not (cdr comps)))
+ (if (and base-size (> base-size 0))
+ (completion-try-completion
+ name candidates predicate (length name) md)
+ ;; If the `comps' are 0-based, the result should be
+ ;; the same with `comps'.
+ (completion-try-completion
+ name comps nil (length name) md))))
+ (most (if (consp most-try) (car most-try)
+ (if most-try (car comps) "")))
+ ;; Compare name and most, so we can determine if name is
+ ;; a prefix of most, or something else.
+ (compare (compare-strings name nil nil
+ most nil nil completion-ignore-case))
+ (ellipsis (if (char-displayable-p ?…) "…" "..."))
+ (determ (unless (or (eq t compare) (eq t most-try)
+ (= (setq compare (1- (abs compare)))
+ (length most)))
+ (concat open-bracket
+ (cond
+ ((= compare (length name))
+ ;; Typical case: name is a prefix.
+ (substring most compare))
+ ;; Don't bother truncating if it doesn't gain
+ ;; us at least 2 columns.
+ ((< compare (+ 2 (string-width ellipsis))) most)
+ (t (concat ellipsis (substring most compare))))
+ close-bracket)))
+ ;;"-prospects" - more than one candidate
+ (prospects-len (+ (string-width
+ (or determ (concat open-bracket close-bracket)))
+ (string-width icomplete-separator)
+ (+ 2 (string-width ellipsis)) ;; take {…} into account
+ (string-width (buffer-string))))
+ (prospects-max
+ ;; Max total length to use, including the minibuffer content.
+ (* (+ icomplete-prospects-height
+ ;; If the minibuffer content already uses up more than
+ ;; one line, increase the allowable space accordingly.
+ (/ prospects-len (window-width)))
+ (window-width)))
+ ;; Find the common prefix among `comps'.
+ ;; We can't use the optimization below because its assumptions
+ ;; aren't always true, e.g. when completion-cycling (bug#10850):
+ ;; (if (eq t (compare-strings (car comps) nil (length most)
+ ;; most nil nil completion-ignore-case))
+ ;; ;; Common case.
+ ;; (length most)
+ ;; Else, use try-completion.
+ (prefix (when icomplete-hide-common-prefix
+ (try-completion "" comps)))
+ (prefix-len
+ (and (stringp prefix)
+ ;; Only hide the prefix if the corresponding info
+ ;; is already displayed via `most'.
+ (string-prefix-p prefix most t)
+ (length prefix))) ;;)
+ prospects comp limit)
+ (prog1
+ (if (or (eq most-try t) (and (not icomplete-scroll)
+ (not (consp (cdr comps)))))
+ (concat determ " [Matched]")
+ (when (member name comps)
+ ;; NAME is complete but not unique. This scenario poses
+ ;; following UI issues:
+ ;;
+ ;; - When `icomplete-hide-common-prefix' is non-nil, NAME
+ ;; is stripped empty. This would make the entry
+ ;; inconspicuous.
+ ;;
+ ;; - Due to sorting of completions, NAME may not be the
+ ;; first of the prospects and could be hidden deep in
+ ;; the displayed string.
+ ;;
+ ;; - Because of `icomplete-prospects-height' , NAME may
+ ;; not even be displayed to the user.
+ ;;
+ ;; To circumvent all the above problems, provide a visual
+ ;; cue to the user via an "empty string" in the try
+ ;; completion field.
+ (setq determ (concat open-bracket "" close-bracket)))
+ (while (and comps (not limit))
+ (setq comp
+ (if prefix-len (substring (car comps) prefix-len) (car comps))
+ comps (cdr comps))
+ (setq prospects-len
+ (+ (string-width comp)
+ (string-width icomplete-separator)
+ prospects-len))
+ (if (< prospects-len prospects-max)
+ (push comp prospects)
+ (setq limit t)))
+ (setq prospects (nreverse prospects))
+ ;; Decorate first of the prospects.
+ (when prospects
+ (let ((first (copy-sequence (pop prospects))))
+ (put-text-property 0 (length first)
+ 'face 'icomplete-first-match first)
+ (push first prospects)))
+ (concat determ
+ "{"
+ (mapconcat 'identity prospects icomplete-separator)
+ (concat (and limit (concat icomplete-separator ellipsis))
+ "}")))
+ ;; Restore the base-size info, since completion-all-sorted-completions
+ ;; is cached.
+ (if last (setcdr last base-size))))))))
+
+;;;_* Iswitchb compatibility
;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in
;; `obsolete' aren't obeyed (since that would encourage people to keep using
@@ -739,10 +988,9 @@ matches exist."
;;;###autoload (make-obsolete 'iswitchb-mode
;;;###autoload "use `icomplete-mode' or `ido-mode' instead." "24.4"))
-;;;_* Provide
(provide 'icomplete)
-;;_* Local emacs vars.
+;;;_* Local emacs vars.
;;Local variables:
;;allout-layout: (-2 :)
;;End:
diff --git a/lisp/ido.el b/lisp/ido.el
index a35d9f3211d..ea5ff32b8d7 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -243,7 +243,7 @@
;; current frame are put at the end of the list. A hook exists to
;; allow other functions to order the list. For example, if you add:
;;
-;; (add-hook 'ido-make-buffer-list-hook 'ido-summary-buffers-to-end)
+;; (add-hook 'ido-make-buffer-list-hook #'ido-summary-buffers-to-end)
;;
;; then all files matching "Summary" are moved to the end of the
;; list. (I find this handy for keeping the INBOX Summary and so on
@@ -355,8 +355,8 @@ 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)
- (ido-mode value))
- :initialize 'custom-initialize-default
+ (ido-mode (or value 0)))
+ :initialize #'custom-initialize-default
:require 'ido
:link '(emacs-commentary-link "ido.el")
:set-after '(ido-save-directory-list-file
@@ -366,13 +366,11 @@ use either \\[customize] or the function `ido-mode'."
:type '(choice (const :tag "Turn on only buffer" buffer)
(const :tag "Turn on only file" file)
(const :tag "Turn on both buffer and file" both)
- (const :tag "Switch off all" nil))
- :group 'ido)
+ (const :tag "Switch off all" nil)))
(defcustom ido-case-fold case-fold-search
"Non-nil if searching of buffer and file names should ignore case."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-ignore-buffers
'("\\` ")
@@ -380,8 +378,7 @@ use either \\[customize] or the function `ido-mode'."
For example, traditional behavior is not to list buffers whose names begin
with a space, for which the regexp is `\\\\=` '. See the source file for
example functions that filter buffer names."
- :type '(repeat (choice regexp function))
- :group 'ido)
+ :type '(repeat (choice regexp function)))
(defcustom ido-ignore-files
'("\\`CVS/" "\\`#" "\\`.#" "\\`\\.\\./" "\\`\\./")
@@ -389,19 +386,16 @@ example functions that filter buffer names."
For example, traditional behavior is not to list files whose names begin
with a #, for which the regexp is `\\\\=`#'. See the source file for
example functions that filter filenames."
- :type '(repeat (choice regexp function))
- :group 'ido)
+ :type '(repeat (choice regexp function)))
(defcustom ido-ignore-extensions t
"Non-nil means ignore files in `completion-ignored-extensions' list."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-show-dot-for-dired nil
"Non-nil means to always put . as the first item in file name lists.
This allows the current directory to be opened immediately with `dired'."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-file-extensions-order nil
"List of file extensions specifying preferred order of file selections.
@@ -409,21 +403,18 @@ Each element is either a string with `.' as the first char, an empty
string matching files without extension, or t which is the default order
for files with an unlisted file extension."
:type '(repeat (choice string
- (const :tag "Default order" t)))
- :group 'ido)
+ (const :tag "Default order" t))))
(defcustom ido-ignore-directories
'("\\`CVS/" "\\`\\.\\./" "\\`\\./")
"List of regexps or functions matching sub-directory names to ignore."
- :type '(repeat (choice regexp function))
- :group 'ido)
+ :type '(repeat (choice regexp function)))
(defcustom ido-ignore-directories-merge nil
"List of regexps or functions matching directory names to ignore during merge.
Directory names matched by one of the regexps in this list are not inserted
in merged file and directory lists."
- :type '(repeat (choice regexp function))
- :group 'ido)
+ :type '(repeat (choice regexp function)))
;; Examples for setting the value of ido-ignore-buffers
;;(defun ido-ignore-c-mode (name)
@@ -453,8 +444,7 @@ Possible values:
(const :tag "Display (no select) in other window" display)
(const :tag "Visit in other frame" other-frame)
(const :tag "Ask to visit in other frame" maybe-frame)
- (const :tag "Raise frame if already visited" raise-frame))
- :group 'ido)
+ (const :tag "Raise frame if already visited" raise-frame)))
(defcustom ido-default-buffer-method 'raise-frame
"How to switch to new buffer when using `ido-switch-buffer'.
@@ -464,38 +454,33 @@ See `ido-default-file-method' for details."
(const :tag "Display (no select) in other window" display)
(const :tag "Show in other frame" other-frame)
(const :tag "Ask to show in other frame" maybe-frame)
- (const :tag "Raise frame if already shown" raise-frame))
- :group 'ido)
+ (const :tag "Raise frame if already shown" raise-frame)))
(defcustom ido-enable-flex-matching nil
"Non-nil means that Ido will do flexible string matching.
Flexible matching means that if the entered string does not
match any item, any item containing the entered characters
in the given sequence will match."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-enable-regexp nil
"Non-nil means that Ido will do regexp matching.
Value can be toggled within Ido using `ido-toggle-regexp'."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-enable-prefix nil
"Non-nil means only match if the entered text is a prefix of file name.
This behavior is like the standard Emacs completion.
If nil, match if the entered text is an arbitrary substring.
Value can be toggled within Ido using `ido-toggle-prefix'."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-enable-dot-prefix nil
"Non-nil means to match leading dot as prefix.
I.e. hidden files and buffers will match only if you type a dot
as first char even if `ido-enable-prefix' is nil."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
;; See https://debbugs.gnu.org/2042 for more info.
(defcustom ido-buffer-disable-smart-matches t
@@ -506,30 +491,29 @@ By default, Ido arranges matches in the following order:
which can get in the way for buffer switching."
:version "24.3"
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-confirm-unique-completion nil
"Non-nil means that even a unique completion must be confirmed.
This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuffer]
even when there is only one unique completion."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
-(defcustom ido-cannot-complete-command 'ido-completion-help
+(defcustom ido-cannot-complete-command #'ido-completion-auto-help
"Command run when `ido-complete' can't complete any more.
The most useful values are `ido-completion-help', which pops up a
-window with completion alternatives, or `ido-next-match' or
-`ido-prev-match', which cycle the buffer list."
- :type 'function
- :group 'ido)
+window with completion alternatives; `ido-completion-auto-help',
+which does the same but respects the value of
+`completion-auto-help'; and `ido-next-match' or `ido-prev-match',
+which cycle the buffer list."
+ :version "28.1"
+ :type 'function)
(defcustom ido-record-commands t
"Non-nil means that Ido will record commands in command history.
Note that the non-Ido equivalent command is recorded."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-max-prospects 12
"Upper limit of the prospect list if non-zero.
@@ -537,8 +521,7 @@ Zero means no limit for the prospect list.
For a long list of prospects, building the full list for the
minibuffer can take a non-negligible amount of time; setting this
variable reduces that time."
- :type 'integer
- :group 'ido)
+ :type 'integer)
(defcustom ido-max-file-prompt-width 0.35
"Upper limit of the prompt string.
@@ -550,8 +533,7 @@ the frame width."
(integer :tag "Characters" :value 20)
(restricted-sexp :tag "Fraction of frame width"
:value 0.35
- :match-alternatives (ido-fractionp)))
- :group 'ido)
+ :match-alternatives (ido-fractionp))))
(defcustom ido-max-window-height nil
"Non-nil specifies a value to override `max-mini-window-height'."
@@ -561,28 +543,24 @@ the frame width."
(restricted-sexp
:tag "Fraction of window height"
:value 0.25
- :match-alternatives (ido-fractionp)))
- :group 'ido)
+ :match-alternatives (ido-fractionp))))
(defcustom ido-enable-last-directory-history t
"Non-nil means that Ido will remember latest selected directory names.
See `ido-last-directory-list' and `ido-save-directory-list-file'."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-max-work-directory-list 50
"Maximum number of working directories to record.
This is the list of directories where files have most recently been opened.
See `ido-work-directory-list' and `ido-save-directory-list-file'."
- :type 'integer
- :group 'ido)
+ :type 'integer)
(defcustom ido-work-directory-list-ignore-regexps nil
"List of regexps matching directories which should not be recorded.
Directory names matched by one of the regexps in this list are not inserted in
the `ido-work-directory-list' list."
- :type '(repeat regexp)
- :group 'ido)
+ :type '(repeat regexp))
(defcustom ido-use-filename-at-point nil
@@ -592,52 +570,44 @@ If found, use that as the starting point for filename selection."
:type '(choice
(const :tag "Disabled" nil)
(const :tag "Guess filename" guess)
- (other :tag "Use literal filename" t))
- :group 'ido)
+ (other :tag "Use literal filename" t)))
(defcustom ido-use-url-at-point nil
"Non-nil means that ido shall look for a URL at point.
If found, call `find-file-at-point' to visit it."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-enable-tramp-completion t
"Non-nil means that Ido shall perform tramp method and server name completion.
A tramp file name uses the following syntax: /method:user@host:filename."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-record-ftp-work-directories t
"Non-nil means record FTP file names in the work directory list."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-merge-ftp-work-directories nil
"If nil, merging ignores FTP file names in the work directory list."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-cache-ftp-work-directory-time 1.0
"Maximum time to cache contents of an FTP directory (in hours).
\\<ido-file-completion-map>
Use \\[ido-reread-directory] in prompt to refresh list.
If zero, FTP directories are not cached."
- :type 'number
- :group 'ido)
+ :type 'number)
(defcustom ido-slow-ftp-hosts nil
"List of slow FTP hosts where Ido prompting should not be used.
If an FTP host is on this list, Ido automatically switches to the non-Ido
equivalent function, e.g. `find-file' rather than `ido-find-file'."
- :type '(repeat string)
- :group 'ido)
+ :type '(repeat string))
(defcustom ido-slow-ftp-host-regexps nil
"List of regexps matching slow FTP hosts (see `ido-slow-ftp-hosts')."
- :type '(repeat regexp)
- :group 'ido)
+ :type '(repeat regexp))
(defvar ido-unc-hosts-cache t
"Cached value from the function `ido-unc-hosts'.")
@@ -652,66 +622,56 @@ hosts on first use of UNC path."
(function :tag "Your own function"))
:set #'(lambda (symbol value)
(set symbol value)
- (setq ido-unc-hosts-cache t))
- :group 'ido)
+ (setq ido-unc-hosts-cache t)))
(defcustom ido-downcase-unc-hosts t
"Non-nil if UNC host names should be downcased."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-ignore-unc-host-regexps nil
"List of regexps matching UNC hosts to ignore.
Case is ignored if `ido-downcase-unc-hosts' is set."
- :type '(repeat regexp)
- :group 'ido)
+ :type '(repeat regexp))
(defcustom ido-cache-unc-host-shares-time 8.0
"Maximum time to cache shares of an UNC host (in hours).
\\<ido-file-completion-map>
Use \\[ido-reread-directory] in prompt to refresh list.
If zero, UNC host shares are not cached."
- :type 'number
- :group 'ido)
+ :type 'number)
(defcustom ido-max-work-file-list 10
"Maximum number of names of recently opened files to record.
This is the list of the file names (sans directory) which have most recently
been opened. See `ido-work-file-list' and `ido-save-directory-list-file'."
- :type 'integer
- :group 'ido)
+ :type 'integer)
(defcustom ido-work-directory-match-only t
"Non-nil means to skip non-matching directories in the directory history.
When some text is already entered at the `ido-find-file' prompt, using
\\[ido-prev-work-directory] or \\[ido-next-work-directory] will skip directories
without any matching entries."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-auto-merge-work-directories-length 0
"Automatically switch to merged work directories during file name input.
The value is number of characters to type before switching to merged mode.
If zero, the switch happens when no matches are found in the current directory.
Automatic merging is disabled if the value is negative."
- :type 'integer
- :group 'ido)
+ :type 'integer)
(defcustom ido-auto-merge-delay-time 0.70
"Delay in seconds to wait for more input before doing auto merge."
- :type 'number
- :group 'ido)
+ :type 'number)
(defcustom ido-auto-merge-inhibit-characters-regexp "[][*?~]"
"Regexp matching characters which should inhibit automatic merging.
When a (partial) file name matches this regexp, merging is inhibited."
- :type 'regexp
- :group 'ido)
+ :type 'regexp)
(defcustom ido-merged-indicator "^"
"The string appended to first choice if it has multiple directory choices."
- :type 'string
- :group 'ido)
+ :type 'string)
(defcustom ido-max-dir-file-cache 100
"Maximum number of working directories to be cached.
@@ -723,8 +683,7 @@ modification times, so you may choose to disable caching on such
systems, or explicitly refresh the cache contents using the command
`ido-reread-directory' command (\\[ido-reread-directory]) in the minibuffer.
See also `ido-dir-file-cache' and `ido-save-directory-list-file'."
- :type 'integer
- :group 'ido)
+ :type 'integer)
(defcustom ido-max-directory-size nil
"Maximum size (in bytes) for directories to use Ido completion.
@@ -732,21 +691,18 @@ See also `ido-dir-file-cache' and `ido-save-directory-list-file'."
If you enter a directory with a size larger than this size, Ido will
not provide the normal completion. To show the completions, use \\[ido-toggle-ignore]."
:type '(choice (const :tag "No limit" nil)
- (integer :tag "Size in bytes" 30000))
- :group 'ido)
+ (integer :tag "Size in bytes" 30000)))
(defcustom ido-big-directories nil
"List of directory pattern strings that should be considered big.
Ido won't attempt to list the contents of directories matching
any of these regular expressions when completing file names."
:type '(repeat regexp)
- :group 'ido
:version "27.1")
(defcustom ido-rotate-file-list-default nil
"Non-nil means that Ido will always rotate file list to get default in front."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-enter-matching-directory 'only
"Additional methods to enter sub-directory of first/only matching item.
@@ -758,8 +714,7 @@ matching item, even without typing a slash."
:type '(choice (const :tag "Never" nil)
(const :tag "Slash enters first directory" first)
(const :tag "Slash enters first and only directory" only)
- (other :tag "Always enter unique directory" t))
- :group 'ido)
+ (other :tag "Always enter unique directory" t)))
(defcustom ido-create-new-buffer 'prompt
"Specify whether a new buffer is created if no buffer matches substring.
@@ -767,21 +722,18 @@ Choices are `always' to create new buffers unconditionally, `prompt' to
ask user whether to create buffer, or `never' to never create new buffer."
:type '(choice (const always)
(const prompt)
- (const never))
- :group 'ido)
+ (const never)))
(defcustom ido-setup-hook nil
"Hook run after the Ido variables and keymap have been setup.
The dynamic variable `ido-cur-item' contains the current type of item that
is read by Ido; possible values are file, dir, buffer, and list.
Additional keys can be defined in `ido-completion-map'."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defcustom ido-separator nil
"String used by Ido to separate the alternatives in the minibuffer."
- :type '(choice string (const nil))
- :group 'ido)
+ :type '(choice string (const nil)))
(make-obsolete-variable 'ido-separator
"set 3rd element of `ido-decorations' instead." nil)
@@ -802,8 +754,7 @@ can be completed using TAB,
11th element is displayed to confirm creating new file or buffer.
12th and 13th elements (if present) are used as brackets around the sole
remaining completion. If absent, elements 5 and 6 are used instead."
- :type '(repeat string)
- :group 'ido)
+ :type '(repeat string))
(defcustom ido-use-virtual-buffers nil
"If non-nil, refer to past (\"virtual\") buffers as well as existing ones.
@@ -827,71 +778,60 @@ enabled if this variable is configured to a non-nil value."
:version "24.1"
:type '(choice (const :tag "Always" t)
(const :tag "Automatic" auto)
- (const :tag "Never" nil))
- :group 'ido)
+ (const :tag "Never" nil)))
(defcustom ido-use-faces t
"Non-nil means use Ido faces to highlighting first match, only match and
subdirs in the alternatives."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defface ido-first-match '((t :weight bold))
- "Face used by Ido for highlighting first match."
- :group 'ido)
+ "Face used by Ido for highlighting first match.")
(defface ido-only-match '((((class color))
:foreground "ForestGreen")
(t :slant italic))
- "Face used by Ido for highlighting only match."
- :group 'ido)
+ "Face used by Ido for highlighting only match.")
(defface ido-subdir '((((min-colors 88) (class color))
:foreground "red1")
(((class color))
:foreground "red")
(t :underline t))
- "Face used by Ido for highlighting subdirs in the alternatives."
- :group 'ido)
+ "Face used by Ido for highlighting subdirs in the alternatives.")
(defface ido-virtual '((t :inherit font-lock-builtin-face))
"Face used by Ido for matching virtual buffer names."
- :version "24.1"
- :group 'ido)
+ :version "24.1")
(defface ido-indicator '((((min-colors 88) (class color))
:foreground "yellow1" :background "red1" :width condensed)
(((class color))
:foreground "yellow" :background "red" :width condensed)
(t :inverse-video t))
- "Face used by Ido for highlighting its indicators."
- :group 'ido)
+ "Face used by Ido for highlighting its indicators.")
(defface ido-incomplete-regexp
'((t :inherit font-lock-warning-face))
- "Ido face for indicating incomplete regexps."
- :group 'ido)
+ "Ido face for indicating incomplete regexps.")
(defcustom ido-make-file-list-hook nil
"List of functions to run when the list of matching files is created.
Each function on the list may modify the dynamically bound variable
`ido-temp-list' which contains the current list of matching files."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defcustom ido-make-dir-list-hook nil
"List of functions to run when the list of matching directories is created.
Each function on the list may modify the dynamically bound variable
`ido-temp-list' which contains the current list of matching directories."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defcustom ido-make-buffer-list-hook nil
"List of functions to run when the list of matching buffers is created.
Each function on the list may modify the dynamically bound variable
`ido-temp-list' which contains the current list of matching buffer names."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defcustom ido-rewrite-file-prompt-functions nil
"List of functions to run when the find-file prompt is created.
@@ -902,14 +842,13 @@ variables:
max-width - the max width of the resulting dirname; nil means no limit
prompt - the basic prompt (e.g. \"Find File: \")
literal - the string shown if doing \"literal\" find; set to nil to omit
- vc-off - the string shown if version control is inhibited; set to nil to omit
+ vc-off - the string shown if version control is inhibited; use nil to omit
prefix - either nil or a fixed prefix for the dirname
The following variables are available, but should not be changed:
`ido-current-directory' - the unabbreviated directory name
item - equals `file' or `dir' depending on the current mode."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defvar ido-rewrite-file-prompt-rules nil
"Alist of rewriting rules for directory names in Ido prompts.
@@ -924,14 +863,12 @@ also modify the dynamic variables described for the variable
(defcustom ido-completion-buffer "*Ido Completions*"
"Name of completion buffer used by Ido.
Set to nil to disable completion buffers popping up."
- :type 'string
- :group 'ido)
+ :type 'string)
(defcustom ido-completion-buffer-all-completions nil
"Non-nil means to show all completions in completion buffer.
Otherwise, only the current list of matches is shown."
- :type 'boolean
- :group 'ido)
+ :type 'boolean)
(defcustom ido-all-frames 'visible
"Argument to pass to `walk-windows' when Ido is finding buffers.
@@ -939,8 +876,7 @@ See documentation of `walk-windows' for useful values."
:type '(choice (const :tag "Selected frame only" nil)
(const :tag "All existing frames" t)
(const :tag "All visible frames" visible)
- (const :tag "All frames on this terminal" 0))
- :group 'ido)
+ (const :tag "All frames on this terminal" 0)))
(defcustom ido-minibuffer-setup-hook nil
"Ido-specific customization of minibuffer setup.
@@ -954,8 +890,7 @@ with other packages. For instance:
will constrain Emacs to a maximum minibuffer height of 3 lines when
Ido is running. Copied from `icomplete-minibuffer-setup-hook'."
- :type 'hook
- :group 'ido)
+ :type 'hook)
(defcustom ido-save-directory-list-file
(locate-user-emacs-file "ido.last" ".ido.last")
@@ -964,28 +899,24 @@ Variables stored are: `ido-last-directory-list', `ido-work-directory-list',
`ido-work-file-list', and `ido-dir-file-cache'.
Must be set before enabling Ido mode."
:version "24.4" ; added locate-user-emacs-file
- :type 'string
- :group 'ido)
+ :type 'string)
(defcustom ido-read-file-name-as-directory-commands '()
"List of commands which use `read-file-name' to read a directory name.
When `ido-everywhere' is non-nil, the commands in this list will read
the directory using `ido-read-directory-name'."
- :type '(repeat symbol)
- :group 'ido)
+ :type '(repeat symbol))
(defcustom ido-read-file-name-non-ido '()
"List of commands which shall not read file names the Ido way.
When `ido-everywhere' is non-nil, the commands in this list will read
the file name using normal `read-file-name' style."
- :type '(repeat symbol)
- :group 'ido)
+ :type '(repeat symbol))
(defcustom ido-before-fallback-functions '()
"List of functions to call before calling a fallback command.
The fallback command is passed as an argument to the functions."
- :type 'hook
- :group 'ido)
+ :type 'hook)
;;;; Keymaps
@@ -1071,10 +1002,10 @@ The fallback command is passed as an argument to the functions."
;;;; Persistent variables
-(defvar ido-file-history nil
+(defvar ido-file-history nil
"History of files selected using `ido-find-file'.")
-(defvar ido-buffer-history nil
+(defvar ido-buffer-history nil
"History of buffers selected using `ido-switch-buffer'.")
(defvar ido-last-directory-list nil
@@ -1106,10 +1037,9 @@ Should never be set permanently.")
(defvar ido-completion-map nil
"Currently active keymap for Ido commands.")
-(defvar ido-eoinput 1
+(defvar-local ido-eoinput 1
"Point where minibuffer input ends and completion info begins.
Copied from `icomplete-eoinput'.")
-(make-variable-buffer-local 'ido-eoinput)
(defvar ido-common-match-string nil
"Stores the string that is common to all matching files.")
@@ -1583,18 +1513,23 @@ Removes badly formatted data and ignored directories."
(ido-save-history))
(defun ido-common-initialization ()
- (add-hook 'minibuffer-setup-hook 'ido-minibuffer-setup)
- (add-hook 'choose-completion-string-functions 'ido-choose-completion-string))
+ (add-hook 'minibuffer-setup-hook #'ido-minibuffer-setup)
+ (add-hook 'choose-completion-string-functions #'ido-choose-completion-string))
(define-minor-mode ido-everywhere
"Toggle use of Ido for all buffer/file reading."
:global t
- :group 'ido
(remove-function read-file-name-function #'ido-read-file-name)
(remove-function read-buffer-function #'ido-read-buffer)
+ (when (boundp 'ffap-file-finder)
+ (remove-function ffap-file-finder #'ido-find-file)
+ (when ido-mode
+ (add-function :override ffap-file-finder #'ido-find-file)))
(when ido-everywhere
- (add-function :override read-file-name-function #'ido-read-file-name)
- (add-function :override read-buffer-function #'ido-read-buffer)))
+ (if (not ido-mode)
+ (ido-mode 'both)
+ (add-function :override read-file-name-function #'ido-read-file-name)
+ (add-function :override read-buffer-function #'ido-read-buffer))))
(defvar ido-minor-mode-map-entry nil)
@@ -1619,13 +1554,13 @@ This function also adds a hook to the minibuffer."
((> (prefix-numeric-value arg) 0) 'both)
(t nil)))
- (ido-everywhere (if ido-everywhere 1 -1))
+ (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1))
(when ido-mode
(ido-common-initialization)
(ido-load-history)
- (add-hook 'kill-emacs-hook 'ido-kill-emacs-hook)
+ (add-hook 'kill-emacs-hook #'ido-kill-emacs-hook)
(let ((map (make-sparse-keymap)))
(when (memq ido-mode '(file both))
@@ -1815,7 +1750,7 @@ is enabled then some keybindings are changed in the keymap."
ido-max-file-prompt-width))
(literal (and (boundp 'ido-find-literal) ido-find-literal "(literal) "))
(vc-off (and ido-saved-vc-hb (not vc-handled-backends) "[-VC] "))
- (prefix nil)
+ ;; (prefix nil)
(rule ido-rewrite-file-prompt-rules))
(let ((case-fold-search nil))
(while rule
@@ -1831,7 +1766,7 @@ is enabled then some keybindings are changed in the keymap."
; (if ido-process-ignore-lists "" "&")
(or literal "")
(or vc-off "")
- (or prefix "")
+ ;; (or prefix "")
(let ((l (length dirname)))
(if (and max-width (> max-width 0) (> l max-width))
(let* ((s (substring dirname (- max-width)))
@@ -2286,7 +2221,10 @@ If cursor is not at the end of the user input, move to end of input."
((and ido-enable-virtual-buffers
ido-virtual-buffers
(setq filename (assoc buf ido-virtual-buffers)))
- (ido-visit-buffer (find-file-noselect (cdr filename)) method t))
+ (if (eq method 'kill)
+ (setq recentf-list
+ (delete (cdr filename) recentf-list))
+ (ido-visit-buffer (find-file-noselect (cdr filename)) method t)))
((and (eq ido-create-new-buffer 'prompt)
(null require-match)
@@ -2432,7 +2370,16 @@ If cursor is not at the end of the user input, move to end of input."
(read-file-name-function nil))
(setq this-command (or ido-fallback fallback 'find-file))
(run-hook-with-args 'ido-before-fallback-functions this-command)
- (call-interactively this-command)))
+ (if (eq this-command 'write-file)
+ (write-file (read-file-name
+ "Write file: "
+ default-directory
+ (and buffer-file-name
+ (expand-file-name
+ (file-name-nondirectory buffer-file-name)
+ default-directory)))
+ t)
+ (call-interactively this-command))))
((eq ido-exit 'switch-to-buffer)
(ido-buffer-internal
@@ -2445,9 +2392,9 @@ If cursor is not at the end of the user input, move to end of input."
nil ido-text 'ido-enter-insert-file))
((eq ido-exit 'dired)
- (funcall (cond ((eq method 'other-window) 'dired-other-window)
- ((eq method 'other-frame) 'dired-other-frame)
- (t 'dired))
+ (funcall (cond ((eq method 'other-window) #'dired-other-window)
+ ((eq method 'other-frame) #'dired-other-frame)
+ (t #'dired))
(concat ido-current-directory (or ido-text ""))))
((eq ido-exit 'ffap)
@@ -3480,13 +3427,18 @@ instead removed from the current item list."
(defun ido-make-buffer-list-1 (&optional frame visible)
"Return list of non-ignored buffer names."
- (delq nil
- (mapcar
- (lambda (x)
- (let ((name (buffer-name x)))
- (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible)))
- name)))
- (buffer-list frame))))
+ (with-temp-buffer
+ ;; Each call to ido-ignore-item-p LET-binds case-fold-search.
+ ;; That is slow if there's no buffer-local binding available,
+ ;; roughly O(number of buffers). This hack avoids it.
+ (setq-local case-fold-search nil)
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (let ((name (buffer-name x)))
+ (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible)))
+ name)))
+ (buffer-list frame)))))
(defun ido-make-buffer-list (default)
"Return the current list of buffers.
@@ -3598,7 +3550,7 @@ it is put to the start of the list."
;; tramp-ftp-file-name-p is available only when tramp
;; has been loaded.
(fboundp 'tramp-ftp-file-name-p)
- (funcall 'tramp-ftp-file-name-p dir)
+ (tramp-ftp-file-name-p dir)
(string-match ":\\'" dir)
(file-name-all-completions "" (concat dir "./"))))))
(if (and compl
@@ -3698,7 +3650,8 @@ in this list."
(not (ido-local-file-exists-p x)))
(and (not (ido-final-slash x))
(let (file-name-handler-alist)
- (get-file-buffer x)))) x))
+ (get-file-buffer x))))
+ x))
ido-temp-list)))))
(ido-to-end ;; move . files to end
(delq nil (mapcar
@@ -3731,7 +3684,8 @@ If MERGED is non-nil, each subdir is cons'ed with DIR."
(delq nil
(mapcar
(lambda (name)
- (and (ido-final-slash name) (not (ido-ignore-item-p name ido-ignore-directories))
+ (and (ido-final-slash name)
+ (not (ido-ignore-item-p name ido-ignore-directories))
(if merged (cons name dir) name)))
(ido-file-name-all-completions dir)))))
@@ -3997,6 +3951,14 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
(when (bobp)
(next-completion 1)))))
+(defun ido-completion-auto-help ()
+ "Call `ido-completion-help' if `completion-auto-help' is non-nil."
+ (interactive)
+ ;; Note: `completion-auto-help' could also be `lazy', but this value
+ ;; is irrelevant to ido, which is fundamentally eager, so it is
+ ;; treated the same as t.
+ (when completion-auto-help
+ (ido-completion-help)))
(defun ido-completion-help ()
"Show possible completions in the `ido-completion-buffer'."
@@ -4016,7 +3978,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
(boundp 'ido-completion-buffer-full))
(set-window-start win (point-min))
(with-no-warnings
- (set (make-local-variable 'ido-completion-buffer-full) t))
+ (setq-local ido-completion-buffer-full t))
(setq full-list t
display-it t))
(scroll-other-window))
@@ -4041,7 +4003,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
(t
(copy-sequence (or ido-matches ido-cur-list))))
#'ido-file-lessp)))
- ;;(add-hook 'completion-setup-hook 'completion-setup-function)
+ ;;(add-hook 'completion-setup-hook #'completion-setup-function)
(display-completion-list completion-list))))))
;;; KILL CURRENT BUFFER
@@ -4128,6 +4090,7 @@ Record command in `command-history' if optional RECORD is non-nil."
(setq buffer (buffer-name buffer)))
(let (win newframe)
(cond
+ ;; "Killing" of virtual buffers is handled in `ido-buffer-internal'.
((eq method 'kill)
(if record
(ido-record-command 'kill-buffer buffer))
@@ -4707,7 +4670,9 @@ For details of keybindings, see `ido-find-file'."
(not (input-pending-p)))
(ido-trace "\n*start timer*")
(setq ido-auto-merge-timer
- (run-with-timer ido-auto-merge-delay-time nil 'ido-initiate-auto-merge (current-buffer))))))
+ (run-with-timer ido-auto-merge-delay-time nil
+ #'ido-initiate-auto-merge
+ (current-buffer))))))
(setq ido-rescan t)
@@ -4830,8 +4795,8 @@ Modified from `icomplete-completions'."
"Minibuffer setup hook for Ido."
;; Copied from `icomplete-minibuffer-setup-hook'.
(when (ido-active)
- (add-hook 'pre-command-hook 'ido-tidy nil t)
- (add-hook 'post-command-hook 'ido-exhibit nil t)
+ (add-hook 'pre-command-hook #'ido-tidy nil t)
+ (add-hook 'post-command-hook #'ido-exhibit nil t)
(run-hooks 'ido-minibuffer-setup-hook)
(when ido-initial-position
(goto-char (+ (minibuffer-prompt-end) ido-initial-position))
@@ -4857,8 +4822,7 @@ Modified from `icomplete-completions'."
(delete-region ido-eoinput (point-max))))
;; Reestablish the local variable 'cause minibuffer-setup is weird:
- (make-local-variable 'ido-eoinput)
- (setq ido-eoinput 1))))
+ (setq-local ido-eoinput 1))))
(defun ido-summary-buffers-to-end ()
;; Move the summaries to the end of the buffer list.
diff --git a/lisp/ielm.el b/lisp/ielm.el
index b7ce3ec525e..fd8dac74b74 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -44,8 +44,7 @@
(defcustom ielm-noisy t
"If non-nil, IELM will beep on error."
- :type 'boolean
- :group 'ielm)
+ :type 'boolean)
(defcustom ielm-prompt-read-only t
"If non-nil, the IELM prompt is read only.
@@ -74,7 +73,6 @@ buffers, including IELM buffers. If you sometimes use IELM on
text-only terminals or with `emacs -nw', you might wish to use
another binding for `comint-kill-whole-line'."
:type 'boolean
- :group 'ielm
:version "22.1")
(defcustom ielm-prompt "ELISP> "
@@ -90,8 +88,7 @@ does not update the prompt of an *ielm* buffer with a running process.
For IELM buffers that are not called `*ielm*', you can execute
\\[inferior-emacs-lisp-mode] in that IELM buffer to update the value,
for new prompts. This works even if the buffer has a running process."
- :type 'string
- :group 'ielm)
+ :type 'string)
(defvar ielm-prompt-internal "ELISP> "
"Stored value of `ielm-prompt' in the current IELM buffer.
@@ -103,8 +100,7 @@ customizes `ielm-prompt'.")
"Controls whether \\<ielm-map>\\[ielm-return] has intelligent behavior in IELM.
If non-nil, \\[ielm-return] evaluates input for complete sexps, or inserts a newline
and indents for incomplete sexps. If nil, always inserts newlines."
- :type 'boolean
- :group 'ielm)
+ :type 'boolean)
(defcustom ielm-dynamic-multiline-inputs t
"Force multiline inputs to start from column zero?
@@ -112,15 +108,13 @@ If non-nil, after entering the first line of an incomplete sexp, a newline
will be inserted after the prompt, moving the input to the next line.
This gives more frame width for large indented sexps, and allows functions
such as `edebug-defun' to work with such inputs."
- :type 'boolean
- :group 'ielm)
+ :type 'boolean)
(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
(defcustom ielm-mode-hook nil
"Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started."
:options '(eldoc-mode)
- :type 'hook
- :group 'ielm)
+ :type 'hook)
;; We define these symbols (that are only used buffer-locally in ielm
;; buffers) this way to avoid having them be defined in the global
@@ -366,9 +360,9 @@ nonempty, then flushes the buffer."
;; that same let. To avoid problems, neither of
;; these buffers should be alive during the
;; evaluation of form.
- (let* ((*1 *)
- (*2 **)
- (*3 ***)
+ (let* ((*1 (bound-and-true-p *))
+ (*2 (bound-and-true-p **))
+ (*3 (bound-and-true-p ***))
(active-process (ielm-process))
(old-standard-output standard-output)
new-standard-output
@@ -453,11 +447,12 @@ nonempty, then flushes the buffer."
(if error-type
(progn
(when ielm-noisy (ding))
- (setq output (concat output "*** " error-type " *** "))
- (setq output (concat output result)))
+ (setq output (concat output
+ "*** " error-type " *** "
+ result)))
;; There was no error, so shift the *** values
- (setq *** **)
- (setq ** *)
+ (setq *** (bound-and-true-p **))
+ (setq ** (bound-and-true-p *))
(setq * result))
(when (or (not for-effect) (not (equal output "")))
(setq output (concat output "\n"))))
@@ -534,37 +529,40 @@ Customized bindings may be defined in `ielm-map', which currently contains:
:syntax-table emacs-lisp-mode-syntax-table
(setq comint-prompt-regexp (concat "^" (regexp-quote ielm-prompt)))
- (set (make-local-variable 'paragraph-separate) "\\'")
- (set (make-local-variable 'paragraph-start) comint-prompt-regexp)
+ (setq-local paragraph-separate "\\'")
+ (setq-local paragraph-start comint-prompt-regexp)
(setq comint-input-sender 'ielm-input-sender)
(setq comint-process-echoes nil)
- (set (make-local-variable 'completion-at-point-functions)
- '(comint-replace-by-expanded-history
- ielm-complete-filename elisp-completion-at-point))
- (add-function :before-until (local 'eldoc-documentation-function)
- #'elisp-eldoc-documentation-function)
- (set (make-local-variable 'ielm-prompt-internal) ielm-prompt)
- (set (make-local-variable 'comint-prompt-read-only) ielm-prompt-read-only)
+ (dolist (f '(elisp-completion-at-point
+ ielm-complete-filename
+ comint-replace-by-expanded-history))
+ (add-hook 'completion-at-point-functions f nil t))
+ (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-var-docstring nil t)
+ (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-funcall nil t)
+ (setq-local ielm-prompt-internal ielm-prompt)
+ (setq-local comint-prompt-read-only ielm-prompt-read-only)
(setq comint-get-old-input 'ielm-get-old-input)
- (set (make-local-variable 'comint-completion-addsuffix) '("/" . ""))
+ (setq-local comint-completion-addsuffix '("/" . ""))
(setq mode-line-process '(":%s on " (:eval (buffer-name ielm-working-buffer))))
;; Useful for `hs-minor-mode'.
(setq-local comment-start ";")
(setq-local comment-use-syntax t)
(setq-local lexical-binding t)
- (set (make-local-variable 'indent-line-function) #'ielm-indent-line)
- (set (make-local-variable 'ielm-working-buffer) (current-buffer))
- (set (make-local-variable 'fill-paragraph-function) #'lisp-fill-paragraph)
+ (setq-local indent-line-function #'ielm-indent-line)
+ (setq-local ielm-working-buffer (current-buffer))
+ (setq-local fill-paragraph-function #'lisp-fill-paragraph)
;; Value holders
- (set (make-local-variable '*) nil)
- (set (make-local-variable '**) nil)
- (set (make-local-variable '***) nil)
- (set (make-local-variable 'ielm-match-data) nil)
+ (setq-local * nil)
+ (setq-local ** nil)
+ (setq-local *** nil)
+ (setq-local ielm-match-data nil)
;; font-lock support
- (set (make-local-variable 'font-lock-defaults)
+ (setq-local font-lock-defaults
'(ielm-font-lock-keywords nil nil ((?: . "w") (?- . "w") (?* . "w"))))
;; A dummy process to keep comint happy. It will never get any input
@@ -579,7 +577,7 @@ Customized bindings may be defined in `ielm-map', which currently contains:
;; Lisp output can include raw characters that confuse comint's
;; carriage control code.
- (set (make-local-variable 'comint-inhibit-carriage-motion) t)
+ (setq-local comint-inhibit-carriage-motion t)
;; Add a silly header
(insert ielm-header)
diff --git a/lisp/iimage.el b/lisp/iimage.el
index cc1461d7b0f..192530a8e6a 100644
--- a/lisp/iimage.el
+++ b/lisp/iimage.el
@@ -1,4 +1,4 @@
-;;; iimage.el --- Inline image minor mode.
+;;; iimage.el --- Inline image minor mode. -*- lexical-binding: t -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -51,8 +51,7 @@
(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)
+ :type '(choice (const nil) (repeat directory)))
(defvar iimage-mode-image-filename-regex
(concat "[-+./_0-9a-zA-Z]+\\."
@@ -74,14 +73,12 @@ Examples of image filename patterns to match:
\\=`file://foo.png\\='
\\[\\[foo.gif]]
<foo.png>
- foo.JPG
-"
- :type '(alist :key-type regexp :value-type integer)
- :group 'iimage)
+ foo.JPG"
+ :type '(alist :key-type regexp :value-type integer))
(defvar iimage-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-l" 'iimage-recenter)
+ (define-key map "\C-l" #'iimage-recenter)
map)
"Keymap used in `iimage-mode'.")
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 1c08ee6d226..2509ecf8f82 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -60,16 +60,16 @@
;; =============
;;
;; * The ImageMagick package. Currently, `convert' and `mogrify' are
-;; used. Find it here: http://www.imagemagick.org.
+;; used. Find it here: https://www.imagemagick.org.
;;
;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
;; needed.
;;
;; * For `image-dired-get-exif-data' and `image-dired-set-exif-data' to work,
;; the command line tool `exiftool' is needed. It can be found here:
-;; http://www.sno.phy.queensu.ca/~phil/exiftool/. These two functions
-;; are, among other things, used for writing comments to image files
-;; using `image-dired-thumbnail-set-image-description' and to create
+;; https://exiftool.org/. These two functions are, among other
+;; things, used for writing comments to image files using
+;; `image-dired-thumbnail-set-image-description' and to create
;; "unique" file names using `image-dired-get-exif-file-name' (used by
;; `image-dired-copy-with-exif-file-name').
;;
@@ -149,7 +149,6 @@
;;; Code:
(require 'dired)
-(require 'format-spec)
(require 'image-mode)
(require 'widget)
@@ -206,7 +205,7 @@ the index.html page that image-dired creates."
:group 'image-dired)
(defcustom image-dired-gallery-image-root-url
-"http://your.own.server/image-diredpics"
+"https://your.own.server/image-diredpics"
"URL where the full size images are to be found.
Note that this path has to be configured in your web server. Image-Dired
expects to find pictures in this directory."
@@ -214,7 +213,7 @@ expects to find pictures in this directory."
:group 'image-dired)
(defcustom image-dired-gallery-thumb-image-root-url
-"http://your.own.server/image-diredthumbs"
+"https://your.own.server/image-diredthumbs"
"URL where the thumbnail images are to be found.
Note that this path has to be configured in your web server. Image-Dired
expects to find pictures in this directory."
@@ -771,8 +770,8 @@ Increase at own risk.")
process)
(when (not (file-exists-p thumbnail-dir))
(message "Creating thumbnail directory")
- (make-directory thumbnail-dir t)
- (set-file-modes thumbnail-dir #o700))
+ (with-file-modes #o700
+ (make-directory thumbnail-dir t)))
;; Thumbnail file creation processes begin here and are marshaled
;; in a queue by `image-dired-create-thumb'.
@@ -2554,7 +2553,6 @@ easy-to-use form."
(let ((files (dired-get-marked-files)))
(pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
(kill-all-local-variables)
- (make-local-variable 'widget-example-repeat)
(let ((inhibit-read-only t))
(erase-buffer))
(remove-overlays)
diff --git a/lisp/image-file.el b/lisp/image-file.el
index c739714f33f..fbc9eaaf94e 100644
--- a/lisp/image-file.el
+++ b/lisp/image-file.el
@@ -1,4 +1,4 @@
-;;; image-file.el --- support for visiting image files
+;;; image-file.el --- support for visiting image files -*- lexical-binding:t -*-
;;
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;;
@@ -32,6 +32,7 @@
;;; Code:
(require 'image)
+(require 'image-converter)
;;;###autoload
@@ -80,13 +81,16 @@ the variable is set using \\[customize]."
(let ((exts-regexp
(and image-file-name-extensions
(concat "\\."
- (regexp-opt (nconc (mapcar #'upcase
- image-file-name-extensions)
- image-file-name-extensions)
- t)
+ (regexp-opt
+ (append (mapcar #'upcase image-file-name-extensions)
+ image-file-name-extensions
+ (mapcar #'upcase
+ image-converter-file-name-extensions)
+ image-converter-file-name-extensions)
+ t)
"\\'"))))
(mapconcat
- 'identity
+ #'identity
(delq nil (list exts-regexp
image-file-name-regexps
(car (rassq 'imagemagick image-type-file-name-regexps))))
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 24be008f3f7..69ef7015cce 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -40,6 +40,7 @@
(require 'image)
(require 'exif)
+(require 'dired)
(eval-when-compile (require 'cl-lib))
;;; Image mode window-info management.
@@ -94,6 +95,9 @@ Its value should be one of the following:
(defvar-local image-transform-rotation 0.0
"Rotation angle for the image in the current Image mode buffer.")
+(defvar-local image--transform-smoothing nil
+ "Whether to use transform smoothing.")
+
(defvar image-transform-right-angle-fudge 0.0001
"Snap distance to a multiple of a right angle.
There's no deep theory behind the default value, it should just
@@ -456,6 +460,7 @@ call."
(define-key map "sb" 'image-transform-fit-both)
(define-key map "ss" 'image-transform-set-scale)
(define-key map "sr" 'image-transform-set-rotation)
+ (define-key map "sm" 'image-transform-set-smoothing)
(define-key map "so" 'image-transform-original)
(define-key map "s0" 'image-transform-reset)
@@ -522,6 +527,8 @@ call."
:help "Rotate the image"]
["Set Rotation..." image-transform-set-rotation
:help "Set rotation angle of the image"]
+ ["Set Smoothing..." image-transform-set-smoothing
+ :help "Toggle smoothing"]
["Original Size" image-transform-original
:help "Reset image to actual size"]
["Reset to Default Size" image-transform-reset
@@ -611,24 +618,35 @@ Key bindings:
(setq major-mode 'image-mode)
(setq image-transform-resize image-auto-resize)
+ ;; Bail out early if we have no image data.
+ (if (zerop (buffer-size))
+ (funcall (if (called-interactively-p 'any) 'error 'message)
+ (if (file-exists-p buffer-file-name)
+ "Empty file"
+ "(New file)"))
+ (image-mode--display)))
+
+(defun image-mode--display ()
(if (not (image-get-display-property))
(progn
(when (condition-case err
- (progn
- (image-toggle-display-image)
- t)
- (unknown-image-type
- (image-mode-as-text)
- (funcall
- (if (called-interactively-p 'any) 'error 'message)
- "Unknown image type; consider switching `image-use-external-converter' on")
- nil)
- (error
- (image-mode-as-text)
- (funcall
- (if (called-interactively-p 'any) 'error 'message)
- "Cannot display image: %s" (cdr err))
- nil))
+ (progn
+ (image-toggle-display-image)
+ t)
+ (unknown-image-type
+ (image-mode-as-text)
+ (funcall
+ (if (called-interactively-p 'any) 'error 'message)
+ (if image-use-external-converter
+ "Unknown image type"
+ "Unknown image type; consider switching `image-use-external-converter' on"))
+ nil)
+ (error
+ (image-mode-as-text)
+ (funcall
+ (if (called-interactively-p 'any) 'error 'message)
+ "Cannot display image: %s" (cdr err))
+ nil))
;; If attempt to display the image fails.
(if (not (image-get-display-property))
(error "Invalid image"))
@@ -655,6 +673,9 @@ Key bindings:
(when image-auto-resize-on-window-resize
(add-hook 'window-state-change-functions #'image--window-state-change nil t))
+ (add-function :before-while (local 'isearch-filter-predicate)
+ #'image-mode-isearch-filter)
+
(run-mode-hooks 'image-mode-hook)
(let ((image (image-get-display-property))
(msg1 (substitute-command-keys
@@ -692,8 +713,7 @@ Key bindings:
Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display],
to switch back to `image-mode' and display an image file as the
actual image."
- nil (:eval (if image-type (format " Image[%s]" image-type) " Image"))
- image-minor-mode-map
+ :lighter (:eval (if image-type (format " Image[%s]" image-type) " Image"))
:group 'image
:version "22.1"
(if image-minor-mode
@@ -706,13 +726,14 @@ A non-mage major mode found from `auto-mode-alist' or fundamental mode
displays an image file as text."
;; image-mode-as-text = normal-mode + image-minor-mode
(let ((previous-image-type image-type)) ; preserve `image-type'
- (major-mode-restore '(image-mode image-mode-maybe image-mode-as-text))
+ (major-mode-restore '(image-mode image-mode-as-text))
;; Restore `image-type' after `kill-all-local-variables' in `normal-mode'.
(setq image-type previous-image-type)
;; Enable image minor mode with `C-c C-c'.
(image-minor-mode 1)
- ;; Show the image file as text.
- (image-toggle-display-text)))
+ (unless (image-get-display-property)
+ ;; Show the image file as text.
+ (image-toggle-display-text))))
(defun image-mode-as-hex ()
"Set a non-image mode as major mode in combination with image minor mode.
@@ -756,8 +777,6 @@ on these modes."
(if (image-get-display-property)
"text" "an image or hex") ".")))
-(define-obsolete-function-alias 'image-mode-maybe 'image-mode "23.2")
-
(defun image-toggle-display-text ()
"Show the image file as text.
Remove text properties that display the image."
@@ -772,6 +791,14 @@ Remove text properties that display the image."
(if (called-interactively-p 'any)
(message "Repeat this command to go back to displaying the image"))))
+(defun image-mode-isearch-filter (_beg _end)
+ "Show image as text when trying to search/replace in the image buffer."
+ (save-match-data
+ (when (and (derived-mode-p 'image-mode)
+ (image-get-display-property))
+ (image-mode-as-text)))
+ t)
+
(defvar archive-superior-buffer)
(defvar tar-superior-buffer)
(declare-function image-flush "image.c" (spec &optional frame))
@@ -816,13 +843,21 @@ was inserted."
(- (nth 2 edges) (nth 0 edges))))
(max-height (when edges
(- (nth 3 edges) (nth 1 edges))))
- (type (if (image--imagemagick-wanted-p filename)
- 'imagemagick
- (image-type file-or-data nil data-p)))
(inhibit-read-only t)
(buffer-undo-list t)
(modified (buffer-modified-p))
- props image)
+ props image type)
+
+ ;; If the data in the current buffer isn't from an existing file,
+ ;; but we have a file name (this happens when visiting images from
+ ;; a zip file, for instance), provide a type hint based on the
+ ;; suffix.
+ (when (and data-p filename)
+ (setq data-p (intern (format "image/%s"
+ (file-name-extension filename)))))
+ (setq type (if (image--imagemagick-wanted-p filename)
+ 'imagemagick
+ (image-type file-or-data nil data-p)))
;; Get the rotation data from the file, if any.
(when (zerop image-transform-rotation) ; don't reset modified value
@@ -841,10 +876,13 @@ was inserted."
;; :scale 1: If we do not set this, create-image will apply
;; default scaling based on font size.
(setq image (if (not edges)
- (create-image file-or-data type data-p :scale 1)
+ (create-image file-or-data type data-p :scale 1
+ :format (and filename data-p))
(create-image file-or-data type data-p :scale 1
:max-width max-width
- :max-height max-height)))
+ :max-height max-height
+ ;; Type hint.
+ :format (and filename data-p))))
;; Discard any stale image data before looking it up again.
(image-flush image)
@@ -923,6 +961,9 @@ Otherwise, display the image by calling `image-mode'."
(get-buffer-window-list (current-buffer) 'nomini 'visible))
(image-toggle-display-image)))
+(defvar image-auto-resize-timer nil
+ "Timer for `image-auto-resize-on-window-resize' option.")
+
(defun image--window-state-change (window)
;; Wait for a bit of idle-time before actually performing the change,
;; so as to batch together sequences of closely consecutive size changes.
@@ -931,8 +972,14 @@ Otherwise, display the image by calling `image-mode'."
;; consecutive calls happen without any redisplay between them,
;; the costly operation of image resizing should happen only once.
(when (numberp image-auto-resize-on-window-resize)
- (run-with-idle-timer image-auto-resize-on-window-resize nil
- #'image-fit-to-window window)))
+ (when image-auto-resize-timer
+ (cancel-timer image-auto-resize-timer))
+ (setq image-auto-resize-timer
+ (run-with-idle-timer image-auto-resize-on-window-resize nil
+ #'image-fit-to-window window))))
+
+(defvar image-fit-to-window-lock nil
+ "Lock for `image-fit-to-window' timer function.")
(defun image-fit-to-window (window)
"Adjust size of image to display it exactly in WINDOW boundaries."
@@ -946,10 +993,22 @@ Otherwise, display the image by calling `image-mode'."
(edges (window-inside-pixel-edges window))
(window-width (- (nth 2 edges) (nth 0 edges)))
(window-height (- (nth 3 edges) (nth 1 edges))))
+ ;; If the size has been changed manually (with `+'/`-'),
+ ;; then :max-width/:max-height is nil. In that case, do
+ ;; no automatic resizing.
(when (and image-width image-height
+ ;; Don't do resizing if we have a manual
+ ;; rotation (from the `r' command), either.
+ (not (plist-get (cdr spec) :rotation))
(or (not (= image-width window-width))
(not (= image-height window-height))))
- (image-toggle-display-image)))))))))
+ (unless image-fit-to-window-lock
+ (unwind-protect
+ (progn
+ (setq-local image-fit-to-window-lock t)
+ (ignore-error 'remote-file-error
+ (image-toggle-display-image)))
+ (setq image-fit-to-window-lock nil)))))))))))
;;; Animated images
@@ -1074,28 +1133,87 @@ replacing the current Image mode buffer."
(error "The buffer is not in Image mode"))
(unless buffer-file-name
(error "The current image is not associated with a file"))
- (let* ((file (file-name-nondirectory buffer-file-name))
- (images (image-mode--images-in-directory file))
- (idx 0))
- (catch 'image-visit-next-file
- (dolist (f images)
- (if (string= f file)
- (throw 'image-visit-next-file (1+ idx)))
- (setq idx (1+ idx))))
- (setq idx (mod (+ idx (or n 1)) (length images)))
- (let ((image (nth idx images))
- (dir (file-name-directory buffer-file-name)))
- (find-alternate-file image)
- ;; If we have dired buffer(s) open to where this image is, then
- ;; place point on it.
+ (let ((next (image-mode--next-file buffer-file-name n)))
+ (unless next
+ (user-error "No %s file in this directory"
+ (if (> n 0)
+ "next"
+ "prev")))
+ (if (stringp next)
+ (find-alternate-file next)
+ (funcall next))))
+
+(defun image-mode--directory-buffers (file)
+ "Return an alist of type/buffer for all \"parent\" buffers to image FILE.
+This is normally a list of Dired buffers, but can also be archive and
+tar mode buffers."
+ (let ((buffers nil)
+ (dir (file-name-directory file)))
+ (cond
+ ((and (boundp 'tar-superior-buffer)
+ tar-superior-buffer)
+ (when (buffer-live-p tar-superior-buffer)
+ (push (cons 'tar tar-superior-buffer) buffers)))
+ ((and (boundp 'archive-superior-buffer)
+ archive-superior-buffer)
+ (when (buffer-live-p archive-superior-buffer)
+ (push (cons 'archive archive-superior-buffer) buffers)))
+ (t
+ ;; Find a dired buffer.
(dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (when (and (derived-mode-p 'dired-mode)
+ (with-current-buffer buffer
+ (when (and (derived-mode-p 'dired-mode)
(equal (file-truename dir)
(file-truename default-directory)))
- (save-window-excursion
- (switch-to-buffer (current-buffer) t t)
- (dired-goto-file (expand-file-name image dir)))))))))
+ (push (cons 'dired (current-buffer)) buffers))))
+ ;; If we can't find any buffers to navigate in, we open a dired
+ ;; buffer.
+ (unless buffers
+ (push (cons 'dired (find-file-noselect dir)) buffers)
+ (message "Opened a dired buffer on %s" dir))))
+ buffers))
+
+(declare-function archive-next-file-displayer "arc-mode")
+(declare-function tar-next-file-displayer "tar-mode")
+
+(defun image-mode--next-file (file n)
+ "Go to the next image file in the parent buffer of FILE.
+This is typically a dired buffer, but may also be a tar/archive buffer.
+Return the next image file from that buffer.
+If N is negative, go to the previous file."
+ (let ((regexp (image-file-name-regexp))
+ (buffers (image-mode--directory-buffers file))
+ next)
+ (dolist (buffer buffers)
+ ;; We do this traversal for all the dired buffers open on this
+ ;; directory. There probably is just one, but we want to move
+ ;; point in all of them.
+ (save-window-excursion
+ (switch-to-buffer (cdr buffer) t t)
+ (cl-case (car buffer)
+ ('dired
+ (dired-goto-file file)
+ (let (found)
+ (while (and (not found)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (bobp))))
+ (dired-next-line n)
+ (let ((candidate (dired-get-filename nil t)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq found candidate))))
+ (if found
+ (setq next found)
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (dired-goto-file file))))
+ ('archive
+ (setq next (archive-next-file-displayer file regexp n)))
+ ('tar
+ (setq next (tar-next-file-displayer file regexp n))))))
+ next))
(defun image-previous-file (&optional n)
"Visit the preceding image in the same directory as the current file.
@@ -1362,7 +1480,10 @@ return value is suitable for appending to an image spec."
,@(when (cdr resized)
(list :height (cdr resized)))
,@(unless (= 0.0 image-transform-rotation)
- (list :rotation image-transform-rotation))))))
+ (list :rotation image-transform-rotation))
+ ,@(when image--transform-smoothing
+ (list :transform-smoothing
+ (string= image--transform-smoothing "smooth")))))))
(defun image-transform-set-scale (scale)
"Prompt for a number, and resize the current image by that amount."
@@ -1395,6 +1516,12 @@ ROTATION should be in degrees."
(setq image-transform-rotation (float (mod rotation 360)))
(image-toggle-display-image))
+(defun image-transform-set-smoothing (smoothing)
+ (interactive (list (completing-read "Smoothing: "
+ '("none" "smooth") nil t)))
+ (setq image--transform-smoothing smoothing)
+ (image-toggle-display-image))
+
(defun image-transform-original ()
"Display the current image with the original (actual) size and rotation."
(interactive)
@@ -1407,7 +1534,8 @@ ROTATION should be in degrees."
(interactive)
(setq image-transform-resize image-auto-resize
image-transform-rotation 0.0
- image-transform-scale 1)
+ image-transform-scale 1
+ image--transform-smoothing nil)
(image-toggle-display-image))
(provide 'image-mode)
diff --git a/lisp/image.el b/lisp/image.el
index 6220c96f2cd..494c26a8a33 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -141,6 +141,18 @@ based on the font pixel size."
(const :tag "Automatically compute" auto))
:version "26.1")
+(defcustom image-transform-smoothing #'image--default-smoothing
+ "Whether to do smoothing when applying transforms to images.
+Common transforms are rescaling and rotation.
+
+Valid values are nil (no smoothing), t (smoothing) or a predicate
+function that is called with the image specification and should return
+either nil or non-nil."
+ :type '(choice (const :tag "Do smoothing" t)
+ (const :tag "No smoothing" nil)
+ function)
+ :version "28.1")
+
(defcustom image-use-external-converter nil
"If non-nil, `create-image' will use external converters for exotic formats.
Emacs handles most of the common image formats (SVG, JPEG, PNG, GIF
@@ -264,9 +276,9 @@ compatibility with versions of Emacs that lack the variable
;; Used to be in image-type-header-regexps, but now not used anywhere
;; (since 2009-08-28).
(defun image-jpeg-p (data)
- (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
"Value is non-nil if DATA, a string, consists of JFIF image data.
We accept the tag Exif because that is the same format."
+ (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
(setq data (ignore-errors (string-to-unibyte data)))
(when (and data (string-match-p "\\`\xff\xd8" data))
(catch 'jfif
@@ -485,11 +497,40 @@ Image file names that are not absolute are searched for in the
type 'png
data-p t)))
(when (image-type-available-p type)
- (append (list 'image :type type (if data-p :data :file) file-or-data)
- (and (not (plist-get props :scale))
- (list :scale
- (image-compute-scaling-factor image-scaling-factor)))
- props)))
+ (let ((image
+ (append (list 'image :type type (if data-p :data :file)
+ file-or-data)
+ (and (not (plist-get props :scale))
+ ;; Add default scaling.
+ (list :scale
+ (image-compute-scaling-factor
+ image-scaling-factor)))
+ props)))
+ ;; Add default smoothing.
+ (unless (plist-member props :transform-smoothing)
+ (setq image (nconc image
+ (list :transform-smoothing
+ (pcase image-transform-smoothing
+ ('t t)
+ ('nil nil)
+ (func (funcall func image)))))))
+ image)))
+
+(defun image--default-smoothing (image)
+ "Say whether IMAGE should be smoothed when transformed."
+ (let* ((props (nthcdr 5 image))
+ (scaling (plist-get props :scale))
+ (rotation (plist-get props :rotation)))
+ (cond
+ ;; We always smooth when scaling down and small upwards scaling.
+ ((and scaling (< scaling 2))
+ t)
+ ;; Smooth when doing non-90-degree rotation
+ ((and rotation
+ (or (not (zerop (mod rotation 1)))
+ (not (zerop (% (truncate rotation) 90)))))
+ t)
+ (t nil))))
(defun image--set-property (image property value)
"Set PROPERTY in IMAGE to VALUE.
@@ -562,12 +603,16 @@ means display it in the right marginal area."
(defun insert-image (image &optional string area slice)
"Insert IMAGE into current buffer at point.
IMAGE is displayed by inserting STRING into the current buffer
-with a `display' property whose value is the image. STRING
-defaults to a single space if you omit it.
+with a `display' property whose value is the image.
+
+STRING defaults to a single space if you omit it, which means
+that the inserted image will behave as whitespace syntactically.
+
AREA is where to display the image. AREA nil or omitted means
display it in the text area, a value of `left-margin' means
display it in the left marginal area, a value of `right-margin'
means display it in the right marginal area.
+
SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
specifying the X and Y positions and WIDTH and HEIGHT of image area
@@ -679,8 +724,10 @@ BUFFER nil or omitted means use the current buffer."
(setq path (cdr path)))
(if found filename)))
+(defvar find-image--cache (make-hash-table :test #'equal))
+
;;;###autoload
-(defun find-image (specs)
+(defun find-image (specs &optional cache)
"Find an image, choosing one of a list of image specifications.
SPECS is a list of image specifications.
@@ -695,26 +742,33 @@ is supported, and FILE exists, is used to construct the image
specification to be returned. Return nil if no specification is
satisfied.
+If CACHE is non-nil, results are cached and returned on subsequent calls.
+
The image is looked for in `image-load-path'.
Image files should not be larger than specified by `max-image-size'."
- (let (image)
- (while (and specs (null image))
- (let* ((spec (car specs))
- (type (plist-get spec :type))
- (data (plist-get spec :data))
- (file (plist-get spec :file))
- found)
- (when (image-type-available-p type)
- (cond ((stringp file)
- (if (setq found (image-search-load-path file))
- (setq image
- (cons 'image (plist-put (copy-sequence spec)
- :file found)))))
- ((not (null data))
- (setq image (cons 'image spec)))))
- (setq specs (cdr specs))))
- image))
+ (or (and cache
+ (gethash specs find-image--cache))
+ (let ((orig-specs specs)
+ image)
+ (while (and specs (null image))
+ (let* ((spec (car specs))
+ (type (plist-get spec :type))
+ (data (plist-get spec :data))
+ (file (plist-get spec :file))
+ found)
+ (when (image-type-available-p type)
+ (cond ((stringp file)
+ (if (setq found (image-search-load-path file))
+ (setq image
+ (cons 'image (plist-put (copy-sequence spec)
+ :file found)))))
+ ((not (null data))
+ (setq image (cons 'image spec)))))
+ (setq specs (cdr specs))))
+ (when cache
+ (setf (gethash orig-specs find-image--cache) image))
+ image)))
;;;###autoload
@@ -784,6 +838,10 @@ number, play until that number of seconds has elapsed."
(if (setq timer (image-animate-timer image))
(cancel-timer timer))
(plist-put (cdr image) :animate-buffer (current-buffer))
+ (plist-put (cdr image) :animate-tardiness 0)
+ ;; Stash the data about the animation here so that we don't
+ ;; trigger image recomputation unnecessarily later.
+ (plist-put (cdr image) :animate-multi-frame-data animation)
(run-with-timer 0.2 nil #'image-animate-timeout
image (or index 0) (car animation)
0 limit (+ (float-time) 0.2)))))
@@ -814,9 +872,10 @@ Frames are indexed from 0. Optional argument NOCHECK non-nil means
do not check N is within the range of frames present in the image."
(unless nocheck
(if (< n 0) (setq n 0)
- (setq n (min n (1- (car (image-multi-frame-p image)))))))
+ (setq n (min n (1- (car (plist-get (cdr image)
+ :animate-multi-frame-data)))))))
(plist-put (cdr image) :index n)
- (force-window-update))
+ (force-window-update (plist-get (cdr image) :animate-buffer)))
(defun image-animate-get-speed (image)
"Return the speed factor for animating IMAGE."
@@ -848,20 +907,25 @@ The minimum delay between successive frames is `image-minimum-frame-delay'.
If the image has a non-nil :speed property, it acts as a multiplier
for the animation speed. A negative value means to animate in reverse."
+ ;; We keep track of "how late" image frames arrive. We decay the
+ ;; previous cumulative value by 10% and then add the current delay.
+ (plist-put (cdr image) :animate-tardiness
+ (+ (* (plist-get (cdr image) :animate-tardiness) 0.9)
+ (float-time (time-since target-time))))
(when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
- ;; Delayed more than two seconds more than expected.
- (or (time-less-p (time-since target-time) 2)
+ ;; Cumulatively delayed two seconds more than expected.
+ (or (< (plist-get (cdr image) :animate-tardiness) 2)
(progn
(message "Stopping animation; animation possibly too big")
nil)))
(image-show-frame image n t)
(let* ((speed (image-animate-get-speed image))
(time (current-time))
- (animation (image-multi-frame-p image))
(time-to-load-image (time-since time))
- (stated-delay-time (/ (or (cdr animation)
- image-default-frame-delay)
- (float (abs speed))))
+ (stated-delay-time
+ (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data))
+ image-default-frame-delay)
+ (float (abs speed))))
;; Subtract off the time we took to load the image from the
;; stated delay time.
(delay (max (float-time (time-subtract stated-delay-time
@@ -1074,6 +1138,7 @@ default is 20%."
image))
(defun image--get-imagemagick-and-warn (&optional position)
+ (declare-function image-transforms-p "image.c" (&optional frame))
(unless (or (fboundp 'imagemagick-types) (image-transforms-p))
(error "Cannot rescale images on this terminal"))
(let ((image (image--get-image position)))
@@ -1126,7 +1191,9 @@ rotations by only multiples of 90 degrees."
360)))))
(defun image-save ()
- "Save the image under point."
+ "Save the image under point.
+This writes the original image data to a file. Rotating or
+changing the displayed image size does not affect the saved image."
(interactive)
(let ((image (image--get-image)))
(with-temp-buffer
diff --git a/lisp/image/exif.el b/lisp/image/exif.el
index 14791be635d..c2cf2346408 100644
--- a/lisp/image/exif.el
+++ b/lisp/image/exif.el
@@ -118,8 +118,9 @@ If the data is invalid, an `exif-error' is signaled."
dest))
(when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg)))))
(exif--parse-exif-chunk app1))))
- (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg)))))
- (exif--parse-exif-chunk app1)))))
+ (save-excursion
+ (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg)))))
+ (exif--parse-exif-chunk app1))))))
(defun exif-orientation (exif)
"Return the orientation (in degrees) in EXIF.
@@ -165,7 +166,7 @@ If the orientation isn't present in the data, return nil."
;; Another magical number.
(unless (= (exif--read-number 2 le) #x002a)
(signal 'exif-error "Invalid TIFF header length"))
- (let ((offset (exif--read-number 2 le)))
+ (let ((offset (exif--read-number 4 le)))
;; Jump to where the IFD (directory) starts and parse it.
(when (> (1+ offset) (point-max))
(signal 'exif-error "Invalid IFD (directory) offset"))
diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el
index b596f68b65b..f6f056a2baf 100644
--- a/lisp/image/gravatar.el
+++ b/lisp/image/gravatar.el
@@ -26,6 +26,7 @@
(require 'url)
(require 'url-cache)
+(require 'dns)
(eval-when-compile
(require 'subr-x))
@@ -38,6 +39,7 @@
"Whether to cache retrieved gravatars."
:type 'boolean
:group 'gravatar)
+(make-obsolete-variable 'gravatar-automatic-caching nil "28.1")
(defcustom gravatar-cache-ttl 2592000
"Time to live in seconds for gravatar cache entries.
@@ -47,6 +49,7 @@ is retrieved anew. The default value is 30 days."
;; Restricted :type to number of seconds.
:version "27.1"
:group 'gravatar)
+(make-obsolete-variable 'gravatar-cache-ttl nil "28.1")
(defcustom gravatar-rating "g"
"Most explicit Gravatar rating level to allow.
@@ -118,9 +121,98 @@ a gravatar for a given email address."
:version "27.1"
:group 'gravatar)
-(defconst gravatar-base-url
- "https://www.gravatar.com/avatar"
- "Base URL for getting gravatars.")
+(defconst gravatar-service-alist
+ `((gravatar . ,(lambda (_addr callback)
+ (funcall callback "https://www.gravatar.com/avatar")))
+ (unicornify . ,(lambda (_addr callback)
+ (funcall callback "https://unicornify.pictures/avatar/")))
+ (libravatar . ,#'gravatar--service-libravatar))
+ "Alist of supported gravatar services.")
+
+(defcustom gravatar-service 'gravatar
+ "Symbol denoting gravatar-like service to use.
+Note that certain services might ignore other options, such as
+`gravatar-default-image' or certain values as with
+`gravatar-rating'.
+
+Note that `'libravatar' has security implications: It can be used
+to track whether you're reading a specific mail."
+ :type `(choice ,@(mapcar (lambda (s) `(const ,(car s)))
+ gravatar-service-alist))
+ :version "28.1"
+ :link '(url-link "https://www.libravatar.org/")
+ :link '(url-link "https://unicornify.pictures/")
+ :link '(url-link "https://gravatar.com/")
+ :group 'gravatar)
+
+(defun gravatar--service-libravatar (addr callback)
+ "Find domain that hosts avatars for email address ADDR."
+ ;; implements https://wiki.libravatar.org/api/
+ (save-match-data
+ (if (not (string-match ".+@\\(.+\\)" addr))
+ (funcall callback "https://seccdn.libravatar.org/avatar")
+ (let ((domain (match-string 1 addr))
+ (records '(("_avatars-sec" . "https")
+ ("_avatars" . "http")))
+ func)
+ (setq func
+ (lambda (result)
+ (cond
+ ((and
+ result ;there is a result
+ (let* ((answers (dns-get 'answers result))
+ (data (mapcar (lambda (record)
+ (dns-get 'data (cdr record)))
+ ;; We may get junk data back (or CNAME;
+ ;; ignore).
+ (and (eq (dns-get 'type answers) 'SRV)
+ answers)))
+ (priorities (mapcar (lambda (r)
+ (dns-get 'priority r))
+ data))
+ (max-priority (apply #'max 0 priorities))
+ (sum 0)
+ top)
+ ;; Attempt to find all records with the same maximal
+ ;; priority, and calculate the sum of their weights.
+ (dolist (ent data)
+ (when (= max-priority (dns-get 'priority ent))
+ (setq sum (+ sum (dns-get 'weight ent)))
+ (push ent top)))
+ ;; In case there is more than one maximal priority
+ ;; record, choose one at random, while taking the
+ ;; individual record weights into consideration.
+ (catch 'done
+ (dolist (ent top)
+ (when (and (or (= 0 sum)
+ (<= 0 (random sum)
+ (dns-get 'weight ent)))
+ ;; Ensure that port and domain data are
+ ;; valid. In case non of the results
+ ;; were valid, `catch' will evaluate to
+ ;; nil, and the next cond clause will be
+ ;; tested.
+ (<= 1 (dns-get 'port ent) 65535)
+ (string-match-p "\\`[-.0-9A-Za-z]+\\'"
+ (dns-get 'target ent)))
+ (funcall callback
+ (url-normalize-url
+ (format "%s://%s:%s/avatar"
+ (cdar records)
+ (dns-get 'target ent)
+ (dns-get 'port ent))))
+ (throw 'done t))
+ (setq sum (- sum (dns-get 'weight ent))))))))
+ ((setq records (cdr records))
+ ;; In case there are at least two methods.
+ (dns-query-asynchronous
+ (concat (caar records) "._tcp." domain)
+ func 'SRV))
+ (t ;fallback
+ (funcall callback "https://seccdn.libravatar.org/avatar")))))
+ (dns-query-asynchronous
+ (concat (caar records) "._tcp." domain)
+ func 'SRV t)))))
(defun gravatar-hash (mail-address)
"Return the Gravatar hash for MAIL-ADDRESS."
@@ -138,13 +230,18 @@ a gravatar for a given email address."
,@(and gravatar-size
`((s ,gravatar-size))))))
-(defun gravatar-build-url (mail-address)
- "Return the URL of a gravatar for MAIL-ADDRESS."
+(defun gravatar-build-url (mail-address callback)
+ "Find the URL of a gravatar for MAIL-ADDRESS and call CALLBACK with it."
;; https://gravatar.com/site/implement/images/
- (format "%s/%s?%s"
- gravatar-base-url
- (gravatar-hash mail-address)
- (gravatar--query-string)))
+ (let ((query-string (gravatar--query-string)))
+ (funcall (alist-get gravatar-service gravatar-service-alist)
+ mail-address
+ (lambda (url)
+ (funcall callback
+ (format "%s/%s?%s"
+ url
+ (gravatar-hash mail-address)
+ query-string))))))
(defun gravatar-get-data ()
"Return body of current URL buffer, or nil on failure."
@@ -154,28 +251,62 @@ a gravatar for a given email address."
(search-forward "\n\n" nil t)
(buffer-substring (point) (point-max)))))
+(defvar gravatar--cache (make-hash-table :test 'equal)
+ "Cache for gravatars.")
+
;;;###autoload
(defun gravatar-retrieve (mail-address callback &optional cbargs)
"Asynchronously retrieve a gravatar for MAIL-ADDRESS.
When finished, call CALLBACK as (apply CALLBACK GRAVATAR CBARGS),
where GRAVATAR is either an image descriptor, or the symbol
`error' if the retrieval failed."
- (let ((url (gravatar-build-url mail-address)))
- (if (url-cache-expired url gravatar-cache-ttl)
- (url-retrieve url #'gravatar-retrieved (list callback cbargs) t)
- (with-current-buffer (url-fetch-from-cache url)
- (gravatar-retrieved () callback cbargs)))))
+ (let ((cached (gethash mail-address gravatar--cache)))
+ (gravatar--prune-cache)
+ (if cached
+ (apply callback (cdr cached) cbargs)
+ ;; Nothing in the cache, fetch it.
+ (gravatar-build-url
+ mail-address
+ (lambda (url)
+ (url-retrieve
+ url
+ (lambda (status)
+ (let* ((data (and (not (plist-get status :error))
+ (gravatar-get-data)))
+ (image (and data (create-image data nil t))))
+ ;; Store the image in the cache.
+ (when image
+ (setf (gethash mail-address gravatar--cache)
+ (cons (time-convert (current-time) 'integer)
+ image)))
+ (prog1
+ (apply callback (if data image 'error) cbargs)
+ (kill-buffer))))
+ nil t))))))
+
+(defun gravatar--prune-cache ()
+ (let ((expired nil)
+ (time (- (time-convert (current-time) 'integer)
+ ;; Twelve hours.
+ (* 12 60 60))))
+ (maphash (lambda (key val)
+ (when (< (car val) time)
+ (push key expired)))
+ gravatar--cache)
+ (dolist (key expired)
+ (remhash key gravatar--cache))))
;;;###autoload
(defun gravatar-retrieve-synchronously (mail-address)
"Synchronously retrieve a gravatar for MAIL-ADDRESS.
Value is either an image descriptor, or the symbol `error' if the
retrieval failed."
- (let ((url (gravatar-build-url mail-address)))
- (with-current-buffer (if (url-cache-expired url gravatar-cache-ttl)
- (url-retrieve-synchronously url t)
- (url-fetch-from-cache url))
- (gravatar-retrieved () #'identity))))
+ (let ((url nil))
+ (gravatar-build-url mail-address (lambda (u) (setq url u)))
+ (while (not url)
+ (sleep-for 0.01))
+ (with-current-buffer (url-retrieve-synchronously url t)
+ (gravatar-retrieved nil #'identity))))
(defun gravatar-retrieved (status cb &optional cbargs)
"Handle Gravatar response data in current buffer.
@@ -184,10 +315,6 @@ an image descriptor, or the symbol `error' on failure.
This function is intended as a callback for `url-retrieve'."
(let ((data (unless (plist-get status :error)
(gravatar-get-data))))
- (and data ; Only cache on success.
- url-current-object ; Only cache if not already cached.
- gravatar-automatic-caching
- (url-store-in-cache))
(prog1 (apply cb (if data (create-image data nil t) 'error) cbargs)
(kill-buffer))))
diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el
index c1ba39ad7f8..e47f1f76e42 100644
--- a/lisp/image/image-converter.el
+++ b/lisp/image/image-converter.el
@@ -33,8 +33,15 @@
"Type of the external image converter to use.
The value should a symbol, either `imagemagick', `graphicsmagick',
or `ffmpeg'.
+
If nil, Emacs will try to find one of the supported converters
-installed on the system."
+installed on the system.
+
+The actual range of image formats that will be converted depends
+on what image formats the chosen converter reports being able to
+handle. `auto-mode-alist' is then used to further filter what
+formats that are to be supported: Only the suffixes that map to
+`image-mode' will be handled."
:group 'image
:type 'symbol
:version "27.1")
@@ -42,6 +49,9 @@ installed on the system."
(defvar image-converter-regexp nil
"A regexp that matches the file name suffixes that can be converted.")
+(defvar image-converter-file-name-extensions nil
+ "A list of file name suffixes that can be converted.")
+
(defvar image-converter--converters
'((graphicsmagick :command ("gm" "convert") :probe ("-list" "format"))
(ffmpeg :command "ffmpeg" :probe "-decoders")
@@ -58,9 +68,11 @@ is a string, it should be a MIME format string like
(unless image-converter
(image-converter--find-converter))
;; When image-converter was customized
- (if (and image-converter (not image-converter-regexp))
- (when-let ((formats (image-converter--probe image-converter)))
- (setq image-converter-regexp (concat "\\." (regexp-opt formats) "\\'"))))
+ (when (and image-converter (not image-converter-regexp))
+ (when-let ((formats (image-converter--probe image-converter)))
+ (setq image-converter-regexp
+ (concat "\\." (regexp-opt formats) "\\'"))
+ (setq image-converter-file-name-extensions formats)))
(and image-converter
(or (and (not data-p)
(string-match image-converter-regexp source))
@@ -181,11 +193,25 @@ data is returned as a string."
"Find an installed image converter."
(catch 'done
(dolist (elem image-converter--converters)
- (when-let ((formats (image-converter--probe (car elem))))
+ (when-let ((formats (image-converter--filter-formats
+ (image-converter--probe (car elem)))))
(setq image-converter (car elem)
- image-converter-regexp (concat "\\." (regexp-opt formats) "\\'"))
+ image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")
+ image-converter-file-name-extensions formats)
(throw 'done image-converter)))))
+(defun image-converter--filter-formats (suffixes)
+ "Filter SUFFIXES based on `auto-mode-alist'.
+Only suffixes that map to `image-mode' are returned."
+ (cl-loop with case-fold-search = (if (not auto-mode-case-fold)
+ nil
+ t)
+ for suffix in suffixes
+ when (eq (cdr (assoc (concat "foo." suffix) auto-mode-alist
+ #'string-match))
+ 'image-mode)
+ collect suffix))
+
(cl-defmethod image-converter--convert ((type (eql graphicsmagick)) source
image-format)
"Convert using GraphicsMagick."
diff --git a/lisp/imenu.el b/lisp/imenu.el
index 9e6878e68c1..2024bb1e066 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -36,14 +36,6 @@
;; A mode-specific function is called to generate the index. It is
;; then presented to the user, who can choose from this index.
-;;
-;; The package comes with a set of example functions for how to
-;; utilize this package.
-
-;; There are *examples* for index gathering functions/regular
-;; expressions for C/C++ and Lisp/Emacs Lisp but it is easy to
-;; customize for other modes. A function for jumping to the chosen
-;; index position is also supplied.
;;; History:
;; Thanks go to
@@ -81,25 +73,20 @@ Setting this to nil makes Imenu work a little faster but editing the
buffer will make the generated index positions wrong.
This might not yet be honored by all index-building functions."
- :type 'boolean
- :group 'imenu)
-
+ :type 'boolean)
(defcustom imenu-max-item-length 60
"If a number, truncate Imenu entries to that length."
:type '(choice integer
- (const :tag "Unlimited"))
- :group 'imenu)
+ (const :tag "Unlimited")))
(defcustom imenu-auto-rescan nil
"Non-nil means Imenu should always rescan the buffers."
- :type 'boolean
- :group 'imenu)
+ :type 'boolean)
(defcustom imenu-auto-rescan-maxout 600000
"Imenu auto-rescan is disabled in buffers larger than this size (in bytes)."
:type 'integer
- :group 'imenu
:version "26.2")
(defcustom imenu-use-popup-menu 'on-mouse
@@ -109,13 +96,11 @@ If t, always use a popup menu,
If `on-mouse' use a popup menu when `imenu' was invoked with the mouse."
:type '(choice (const :tag "On Mouse" on-mouse)
(const :tag "Never" nil)
- (other :tag "Always" t))
- :group 'imenu)
+ (other :tag "Always" t)))
(defcustom imenu-eager-completion-buffer t
"If non-nil, eagerly popup the completion buffer."
:type 'boolean
- :group 'imenu
:version "22.1")
(defcustom imenu-after-jump-hook nil
@@ -123,8 +108,7 @@ If `on-mouse' use a popup menu when `imenu' was invoked with the mouse."
Useful things to use here include `reposition-window', `recenter', and
\(lambda () (recenter 0)) to show at top of screen."
- :type 'hook
- :group 'imenu)
+ :type 'hook)
;;;###autoload
(defcustom imenu-sort-function nil
@@ -143,39 +127,23 @@ element should come before the second. The arguments are cons cells;
\(NAME . POSITION). Look at `imenu--sort-by-name' for an example."
:type '(choice (const :tag "No sorting" nil)
(const :tag "Sort by name" imenu--sort-by-name)
- (function :tag "Another function"))
- :group 'imenu)
+ (function :tag "Another function")))
(defcustom imenu-max-items 25
"Maximum number of elements in a mouse menu for Imenu."
- :type 'integer
- :group 'imenu)
-
-;; 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.
-;; If non-nil, user gets a message during the scanning of the buffer.
-;;
-;; Relevant only if the mode-specific function that creates the buffer
-;; index use `imenu-progress-message', and not useful if that is fast, in
-;; which case you might as well set this to nil."
-;; :type '(choice string
-;; (const :tag "None" nil))
-;; :group 'imenu)
+ :type 'integer)
(defcustom imenu-space-replacement "."
"The replacement string for spaces in index names.
Used when presenting the index in a completion buffer to make the
names work as tokens."
- :type '(choice string (const nil))
- :group 'imenu)
+ :type '(choice string (const nil)))
(defcustom imenu-level-separator ":"
"The separator between index names of different levels.
Used for making mouse-menu titles and for flattening nested indexes
with name concatenation."
- :type 'string
- :group 'imenu)
+ :type 'string)
(defcustom imenu-generic-skip-comments-and-strings t
"When non-nil, ignore text inside comments and strings.
@@ -183,11 +151,10 @@ Only affects `imenu-default-create-index-function' (and any
alternative implementation of `imenu-create-index-function' that
uses `imenu--generic-function')."
:type 'boolean
- :group 'imenu
:version "24.4")
;;;###autoload
-(defvar imenu-generic-expression nil
+(defvar-local imenu-generic-expression nil
"List of definition matchers for creating an Imenu index.
Each element of this list should have the form
@@ -223,13 +190,10 @@ characters which normally have \"symbol\" syntax are considered to have
\"word\" syntax during matching.")
;;;###autoload(put 'imenu-generic-expression 'risky-local-variable t)
-;;;###autoload
-(make-variable-buffer-local 'imenu-generic-expression)
-
;;;; Hooks
;;;###autoload
-(defvar imenu-create-index-function 'imenu-default-create-index-function
+(defvar-local imenu-create-index-function 'imenu-default-create-index-function
"The function to use for creating an index alist of the current buffer.
It should be a function that takes no arguments and returns
@@ -237,11 +201,9 @@ an index alist of the current buffer. The function is
called within a `save-excursion'.
See `imenu--index-alist' for the format of the buffer index alist.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-create-index-function)
;;;###autoload
-(defvar imenu-prev-index-position-function 'beginning-of-defun
+(defvar-local imenu-prev-index-position-function 'beginning-of-defun
"Function for finding the next index position.
If `imenu-create-index-function' is set to
@@ -251,21 +213,17 @@ file.
The function should leave point at the place to be connected to the
index and it should return nil when it doesn't find another index.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-prev-index-position-function)
;;;###autoload
-(defvar imenu-extract-index-name-function nil
+(defvar-local imenu-extract-index-name-function nil
"Function for extracting the index item name, given a position.
This function is called after `imenu-prev-index-position-function'
finds a position for an index item, with point at that position.
It should return the name for that index item.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-extract-index-name-function)
;;;###autoload
-(defvar imenu-name-lookup-function nil
+(defvar-local imenu-name-lookup-function nil
"Function to compare string with index item.
This function will be called with two strings, and should return
@@ -275,15 +233,11 @@ If nil, comparison is done with `string='.
Set this to some other function for more advanced comparisons,
such as \"begins with\" or \"name matches and number of
arguments match\".")
-;;;###autoload
-(make-variable-buffer-local 'imenu-name-lookup-function)
;;;###autoload
-(defvar imenu-default-goto-function 'imenu-default-goto-function
+(defvar-local imenu-default-goto-function 'imenu-default-goto-function
"The default function called when selecting an Imenu item.
The function in this variable is called when selecting a normal index-item.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-default-goto-function)
(defun imenu--subalist-p (item)
@@ -293,51 +247,14 @@ The function in this variable is called when selecting a normal index-item.")
(not (functionp (cadr item)))))
(defmacro imenu-progress-message (_prevpos &optional _relpos _reverse)
- "Macro to display a progress message.
-RELPOS is the relative position to display.
-If RELPOS is nil, then the relative position in the buffer
-is calculated.
-PREVPOS is the variable in which we store the last position displayed."
-
+ "This macro is obsolete and does nothing."
+ (declare (obsolete nil "28.1"))
;; Made obsolete/empty, as computers are now faster than the eye, and
;; it had problems updating the messages correctly, and could shadow
;; more important messages/prompts in the minibuffer. KFS 2004-10-27.
-
-;; `(and
-;; imenu-scanning-message
-;; (let ((pos ,(if relpos
-;; relpos
-;; `(imenu--relative-position ,reverse))))
-;; (if ,(if relpos t
-;; `(> pos (+ 5 ,prevpos)))
-;; (progn
-;; (message imenu-scanning-message pos)
-;; (setq ,prevpos pos)))))
)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Some examples of functions utilizing the framework of this
-;;;; package.
-;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; FIXME: This was the only imenu-example-* definition actually used,
-;; by cperl-mode.el. Now cperl-mode has its own copy, so these can
-;; all be removed.
-(defun imenu-example--name-and-position ()
- "Return the current/previous sexp and its (beginning) location.
-Don't move point."
- (declare (obsolete "use your own function instead." "23.2"))
- (save-excursion
- (forward-sexp -1)
- ;; [ydi] modified for imenu-use-markers
- (let ((beg (if imenu-use-markers (point-marker) (point)))
- (end (progn (forward-sexp) (point))))
- (cons (buffer-substring beg end)
- beg))))
-
;;;
;;; Lisp
;;;
@@ -546,8 +463,8 @@ Non-nil arguments are in recursive calls."
((imenu--subalist-p item)
(imenu--create-keymap (car item) (cdr item) cmd))
(t
- `(lambda () (interactive)
- ,(if cmd `(,cmd ',item) (list 'quote item)))))))
+ (lambda () (interactive)
+ (if cmd (funcall cmd item) item))))))
alist)))
(defun imenu--in-alist (str alist)
@@ -576,7 +493,8 @@ Non-nil arguments are in recursive calls."
(setq alist nil res elt))))
res))
-(defvar imenu-syntax-alist nil
+;;;###autoload
+(defvar-local imenu-syntax-alist nil
"Alist of syntax table modifiers to use while in `imenu--generic-function'.
The car of the assocs may be either a character or a string and the
@@ -586,8 +504,6 @@ a string, all the characters in the string get the specified syntax.
This is typically used to give word syntax to characters which
normally have symbol syntax to simplify `imenu-expression'
and speed-up matching.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-syntax-alist)
(defun imenu-default-create-index-function ()
"Default function to create an index alist of the current buffer.
@@ -629,14 +545,13 @@ The alternate method, which is the one most often used, is to call
;;; Generic index gathering function.
;;;
-(defvar imenu-case-fold-search t
+;;;###autoload
+(defvar-local imenu-case-fold-search t
"Defines whether `imenu--generic-function' should fold case when matching.
This variable should be set (only) by initialization code
for modes which use `imenu--generic-function'. If it is not set, but
`font-lock-defaults' is set, then font-lock's setting is used.")
-;;;###autoload
-(make-variable-buffer-local 'imenu-case-fold-search)
;; This function can be called with quitting disabled,
;; so it needs to be careful never to loop!
@@ -787,10 +702,13 @@ Return one of the entries in index-alist or nil."
index-alist))))
(when (stringp name)
(setq name (or (imenu-find-default name prepared-index-alist) name)))
- (cond (prompt)
- ((and name (imenu--in-alist name prepared-index-alist))
- (setq prompt (format "Index item (default %s): " name)))
- (t (setq prompt "Index item: ")))
+ (unless prompt
+ (setq prompt (format-prompt
+ "Index item"
+ (and name
+ (imenu--in-alist name prepared-index-alist)
+ ;; Default to `name' if it's in the alist.
+ name))))
(let ((minibuffer-setup-hook minibuffer-setup-hook))
;; Display the completion buffer.
(if (not imenu-eager-completion-buffer)
diff --git a/lisp/indent.el b/lisp/indent.el
index ed67e1c16f7..a33d9620098 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -39,8 +39,8 @@
(defvar indent-line-function 'indent-relative
"Function to indent the current line.
This function will be called with no arguments.
-If it is called somewhere where auto-indentation cannot be done
-\(e.g. inside a string), the function should simply return `noindent'.
+If it is called somewhere where it cannot auto-indent, the function
+should return `noindent' to signal that it didn't.
Setting this function is all you need to make TAB indent appropriately.
Don't rebind TAB unless you really need to.")
@@ -52,6 +52,8 @@ or in the line's indentation, otherwise it inserts a \"real\" TAB character.
If `complete', TAB first tries to indent the current line, and if the line
was already indented, then try to complete the thing at point.
+Also see `tab-first-completion'.
+
Some programming language modes have their own variable to control this,
e.g., `c-tab-always-indent', and do not respect this variable."
:group 'indent
@@ -60,22 +62,44 @@ e.g., `c-tab-always-indent', and do not respect this variable."
(const :tag "Indent if inside indentation, else TAB" nil)
(const :tag "Indent, or if already indented complete" complete)))
+(defcustom tab-first-completion nil
+ "Governs the behavior of TAB completion on the first press of the key.
+When nil, complete. When `eol', only complete if point is at the
+end of a line. When `word', complete unless the next character
+has word syntax (according to `syntax-after'). When
+`word-or-paren', complete unless the next character is part of a
+word or a parenthesis. When `word-or-paren-or-punct', complete
+unless the next character is part of a word, parenthesis, or
+punctuation. Typing TAB a second time always results in
+completion.
+
+This variable has no effect unless `tab-always-indent' is `complete'."
+ :group 'indent
+ :type '(choice
+ (const :tag "Always complete" nil)
+ (const :tag "Unless at the end of a line" 'eol)
+ (const :tag "Unless looking at a word" 'word)
+ (const :tag "Unless at a word or parenthesis" 'word-or-paren)
+ (const :tag "Unless at a word, parenthesis, or punctuation." 'word-or-paren-or-punct))
+ :version "27.1")
+
+(defvar indent-line-ignored-functions '(indent-relative
+ indent-relative-maybe
+ indent-relative-first-indent-point)
+ "Values that are ignored by `indent-according-to-mode'.")
(defun indent-according-to-mode ()
"Indent line in proper way for current major mode.
Normally, this is done by calling the function specified by the
variable `indent-line-function'. However, if the value of that
-variable is `indent-relative' or `indent-relative-first-indent-point',
+variable is present in the `indent-line-ignored-functions' variable,
handle it specially (since those functions are used for tabbing);
in that case, indent by aligning to the previous non-blank line."
(interactive)
(save-restriction
(widen)
(syntax-propertize (line-end-position))
- (if (memq indent-line-function
- '(indent-relative
- indent-relative-maybe
- indent-relative-first-indent-point))
+ (if (memq indent-line-function indent-line-ignored-functions)
;; These functions are used for tabbing, but can't be used for
;; indenting. Replace with something ad-hoc.
(let ((column (save-excursion
@@ -113,7 +137,7 @@ or performs symbol completion, depending on `tab-always-indent'.
The function called to actually indent the line or insert a tab
is given by the variable `indent-line-function'.
-If a prefix argument is given, after this function indents the
+If a prefix argument is given (ARG), after this function indents the
current line or inserts a tab, it also rigidly indents the entire
balanced expression which starts at the beginning of the current
line, to reflect the current line's indentation.
@@ -141,7 +165,8 @@ prefix argument is ignored."
(t
(let ((old-tick (buffer-chars-modified-tick))
(old-point (point))
- (old-indent (current-indentation)))
+ (old-indent (current-indentation))
+ (syn `(,(syntax-after (point)))))
;; Indent the line.
(or (not (eq (indent--funcall-widened indent-line-function) 'noindent))
@@ -154,7 +179,20 @@ prefix argument is ignored."
;; If the text was already indented right, try completion.
((and (eq tab-always-indent 'complete)
(eq old-point (point))
- (eq old-tick (buffer-chars-modified-tick)))
+ (eq old-tick (buffer-chars-modified-tick))
+ (or (null tab-first-completion)
+ (eq last-command this-command)
+ (and (equal tab-first-completion 'eol)
+ (eolp))
+ (and (member tab-first-completion
+ '(word word-or-paren word-or-paren-or-punct))
+ (not (member 2 syn)))
+ (and (member tab-first-completion
+ '(word-or-paren word-or-paren-or-punct))
+ (not (or (member 4 syn)
+ (member 5 syn))))
+ (and (equal tab-first-completion 'word-or-paren-or-punct)
+ (not (member 1 syn)))))
(completion-at-point))
;; If a prefix argument was given, rigidly indent the following
@@ -212,8 +250,9 @@ It is activated by calling `indent-rigidly' interactively.")
If called interactively with no prefix argument, activate a
transient mode in which the indentation can be adjusted interactively
by typing \\<indent-rigidly-map>\\[indent-rigidly-left], \\[indent-rigidly-right], \\[indent-rigidly-left-to-tab-stop], or \\[indent-rigidly-right-to-tab-stop].
-Typing any other key deactivates the transient mode, and this key is then
-acted upon as normally.
+Typing any other key exits this mode, and this key is then
+acted upon as normally. If `transient-mark-mode' is enabled,
+exiting also deactivates the mark.
If called from a program, or interactively with prefix ARG,
indent all lines starting in the region forward by ARG columns.
@@ -486,7 +525,7 @@ From the beginning of the line, moves past the left-margin indentation, the
fill-prefix, and any indentation used for centering or right-justifying the
line, but does not move past any whitespace that was explicitly inserted
\(such as a tab used to indent the first line of a paragraph)."
- (interactive "p")
+ (interactive "^p")
(beginning-of-line n)
(skip-chars-forward " \t")
;; Skip over fill-prefix.
diff --git a/lisp/info-look.el b/lisp/info-look.el
index 697c7475bcb..fd6f8f15082 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -75,7 +75,7 @@ List elements are cons cells of the form
If a file name matches REGEXP, then use help mode MODE instead of the
buffer's major mode."
- :group 'info-lookup :type '(repeat (cons (string :tag "Regexp")
+ :group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp")
(symbol :tag "Mode"))))
(defvar info-lookup-history nil
@@ -297,9 +297,7 @@ If optional argument QUERY is non-nil, query for the help mode."
(completion-ignore-case (info-lookup->ignore-case topic mode))
(enable-recursive-minibuffers t)
(value (completing-read
- (if default
- (format "Describe %s (default %s): " topic default)
- (format "Describe %s: " topic))
+ (format-prompt "Describe %s" default topic)
completions nil nil nil 'info-lookup-history default)))
(list (if (equal value "") default value) mode)))
@@ -557,7 +555,7 @@ Return nil if there is nothing appropriate in the buffer near point."
(info-lookup->regexp topic mode)))
(start (point)) end regexp subexp result)
(save-excursion
- (if (symbolp rule)
+ (if (functionp rule)
(setq result (funcall rule))
(if (consp rule)
(setq regexp (car rule)
@@ -610,6 +608,7 @@ Return nil if there is nothing appropriate in the buffer near point."
(defun info-lookup-guess-custom-symbol ()
"Get symbol at point in custom buffers."
+ (declare (obsolete nil "28.1"))
(condition-case nil
(save-excursion
(let ((case-fold-search t)
@@ -1065,7 +1064,9 @@ Return nil if there is nothing appropriate in the buffer near point."
:mode 'Custom-mode
:ignore-case t
:regexp "[^][()`'‘’,:\" \t\n]+"
- :parse-rule 'info-lookup-guess-custom-symbol
+ :parse-rule (lambda ()
+ (when-let ((symbol (get-text-property (point) 'custom-data)))
+ (symbol-name symbol)))
:other-modes '(emacs-lisp-mode))
(info-lookup-maybe-add-help
diff --git a/lisp/info-xref.el b/lisp/info-xref.el
index be1928d692b..538a017f3c0 100644
--- a/lisp/info-xref.el
+++ b/lisp/info-xref.el
@@ -95,7 +95,7 @@ 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))
+ (declare (debug (form def-body)) (indent 1))
`(let* ((info-xref-with-file--filename ,filename)
(info-xref-with-file--body (lambda () ,@body))
(info-xref-with-file--existing
diff --git a/lisp/info.el b/lisp/info.el
index 1e5a83426a0..b65728ba41b 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1,4 +1,4 @@
-;; info.el --- Info package for Emacs -*- lexical-binding:t -*-
+;;; info.el --- Info package for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1992-2021 Free Software Foundation, Inc.
@@ -67,7 +67,6 @@ Intermediate Info nodes are nodes visited by Info internally in the process of
searching the node to display. Intermediate nodes are not presented
to the user."
:type 'boolean
- :group 'info
:version "24.1")
(defvar Info-enable-active-nodes nil
@@ -79,8 +78,7 @@ The Lisp code is executed when the node is selected.")
'((((class color) (background light)) :foreground "brown" :weight bold :slant italic)
(((class color) (background dark)) :foreground "white" :weight bold :slant italic)
(t :weight bold :slant italic))
- "Face for Info node names."
- :group 'info)
+ "Face for Info node names.")
(defface info-title-1
'((((type tty pc) (class color) (background light))
@@ -88,26 +86,22 @@ The Lisp code is executed when the node is selected.")
(((type tty pc) (class color) (background dark))
:foreground "yellow" :weight bold)
(t :height 1.2 :inherit info-title-2))
- "Face for info titles at level 1."
- :group 'info)
+ "Face for info titles at level 1.")
(defface info-title-2
'((((type tty pc) (class color)) :foreground "lightblue" :weight bold)
(t :height 1.2 :inherit info-title-3))
- "Face for info titles at level 2."
- :group 'info)
+ "Face for info titles at level 2.")
(defface info-title-3
'((((type tty pc) (class color)) :weight bold)
(t :height 1.2 :inherit info-title-4))
- "Face for info titles at level 3."
- :group 'info)
+ "Face for info titles at level 3.")
(defface info-title-4
'((((type tty pc) (class color)) :weight bold)
(t :weight bold :inherit variable-pitch))
- "Face for info titles at level 4."
- :group 'info)
+ "Face for info titles at level 4.")
(defface info-menu-header
'((((type tty pc))
@@ -116,31 +110,26 @@ The Lisp code is executed when the node is selected.")
(t
:inherit variable-pitch
:weight bold))
- "Face for headers in Info menus."
- :group 'info)
+ "Face for headers in Info menus.")
(defface info-menu-star
'((((class color)) :foreground "red1")
(t :underline t))
- "Face for every third `*' in an Info menu."
- :group 'info)
+ "Face for every third `*' in an Info menu.")
(defface info-xref
'((t :inherit link))
- "Face for unvisited Info cross-references."
- :group 'info)
+ "Face for unvisited Info cross-references.")
(defface info-xref-visited
'((t :inherit (link-visited info-xref)))
"Face for visited Info cross-references."
- :version "22.1"
- :group 'info)
+ :version "22.1")
(defcustom Info-fontify-visited-nodes t
"Non-nil to fontify references to visited nodes in `info-xref-visited' face."
:version "22.1"
- :type 'boolean
- :group 'info)
+ :type 'boolean)
;; It's unfortunate that nil means no fontification, as opposed to no limit,
;; since that differs from font-lock-maximum-size.
@@ -150,43 +139,35 @@ Set to nil to disable node fontification; set to t for no limit."
:type '(choice (const :tag "No fontification" nil)
(const :tag "No size limit" t)
(integer :tag "Up to this many characters"))
- :version "25.1" ; 100k -> 400k
- :group 'info)
+ :version "25.1") ; 100k -> 400k
(defcustom Info-use-header-line t
"Non-nil means to put the beginning-of-node links in an Emacs header-line.
A header-line does not scroll with the rest of the buffer."
- :type 'boolean
- :group 'info)
+ :type 'boolean)
(defface info-header-xref
'((t :inherit info-xref))
- "Face for Info cross-references in a node header."
- :group 'info)
+ "Face for Info cross-references in a node header.")
(defface info-header-node
'((t :inherit info-node))
- "Face for Info nodes in a node header."
- :group 'info)
+ "Face for Info nodes in a node header.")
(defface info-index-match
'((t :inherit match))
"Face used to highlight matches in an index entry."
- :group 'info
:version "24.4")
;; This is a defcustom largely so that we can get the benefit
-;; of custom-initialize-delay. Perhaps it would work to make it a
-;; defvar and explicitly give it a standard-value property, and
-;; call custom-initialize-delay on it.
-;; The progn forces the autoloader to include the whole thing, not
-;; just an abbreviated version. The value is initialized at startup
-;; time, when command-line calls custom-reevaluate-setting on all
-;; the defcustoms in custom-delayed-init-variables. This is
-;; somewhat sub-optimal, as ideally this should be done when Info
-;; mode is first invoked.
+;; of `custom-initialize-delay'. Perhaps it would work to make it a
+;; `defvar' and explicitly give it a `standard-value' property, and
+;; call `custom-initialize-delay' on it.
+;; The value is initialized at startup time, when command-line calls
+;; `custom-reevaluate-setting' on all the defcustoms in
+;; `custom-delayed-init-variables'. This is somewhat sub-optimal, as ideally
+;; this should be done when Info mode is first invoked.
;;;###autoload
-(progn
(defcustom Info-default-directory-list
(let* ((config-dir
(file-name-as-directory
@@ -248,9 +229,8 @@ the environment variable INFOPATH is set.
Although this is a customizable variable, that is mainly for technical
reasons. Normally, you should either set INFOPATH or customize
`Info-additional-directory-list', rather than changing this variable."
- :initialize 'custom-initialize-delay
- :type '(repeat directory)
- :group 'info))
+ :initialize #'custom-initialize-delay
+ :type '(repeat directory))
(defvar Info-directory-list nil
"List of directories to search for Info documentation files.
@@ -285,8 +265,7 @@ a version of Emacs without installing it.")
(defcustom Info-additional-directory-list nil
"List of additional directories to search for Info documentation files.
These directories are searched after those in `Info-directory-list'."
- :type '(repeat directory)
- :group 'info)
+ :type '(repeat directory))
(defcustom Info-scroll-prefer-subnodes nil
"If non-nil, \\<Info-mode-map>\\[Info-scroll-up] in a menu visits subnodes.
@@ -300,8 +279,7 @@ Setting this option to nil results in behavior similar to the stand-alone
Info reader program, which visits the first subnode from the menu only
when you hit the end of the current node."
:version "22.1"
- :type 'boolean
- :group 'info)
+ :type 'boolean)
(defcustom Info-hide-note-references t
"If non-nil, hide the tag and section reference in *note and * menu items.
@@ -320,8 +298,7 @@ If this is non-nil, you may wish setting `Info-refill-paragraphs' non-nil."
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (derived-mode-p 'Info-mode)
- (revert-buffer t t)))))
- :group 'info)
+ (revert-buffer t t))))))
(defcustom Info-refill-paragraphs nil
"If non-nil, attempt to refill paragraphs with hidden references.
@@ -329,15 +306,13 @@ This refilling may accidentally remove explicit line breaks in the Info
file, so be prepared for a few surprises if you enable this feature.
This only has an effect if `Info-hide-note-references' is non-nil."
:version "22.1"
- :type 'boolean
- :group 'info)
+ :type 'boolean)
(defcustom Info-breadcrumbs-depth 4
"Depth of breadcrumbs to display.
0 means do not display breadcrumbs."
:version "23.1"
- :type 'integer
- :group 'info)
+ :type 'integer)
(defcustom Info-search-whitespace-regexp "\\s-+"
"If non-nil, regular expression to match a sequence of whitespace chars.
@@ -347,8 +322,7 @@ In the Customization buffer, that is `[' followed by a space,
a tab, a carriage return (control-M), a newline, and `]+'. Don't
add any capturing groups into this value; that can change the
numbering of existing capture groups in unexpected ways."
- :type 'regexp
- :group 'info)
+ :type 'regexp)
(defcustom Info-isearch-search t
"If non-nil, isearch in Info searches through multiple nodes.
@@ -363,8 +337,7 @@ node depending on search direction.
Setting this option to nil restores the default isearch behavior
with wrapping around the current Info node."
:version "22.1"
- :type 'boolean
- :group 'info)
+ :type 'boolean)
(defvar Info-isearch-initial-node nil)
(defvar Info-isearch-initial-history nil)
@@ -375,13 +348,11 @@ with wrapping around the current Info node."
(unless (and (boundp 'Info-fontify) (null Info-fontify))
'(turn-on-font-lock))
"Hook run when activating Info Mode."
- :type 'hook
- :group 'info)
+ :type 'hook)
(defcustom Info-selection-hook nil
"Hook run when an Info node is selected as the current node."
- :type 'hook
- :group 'info)
+ :type 'hook)
(defvar-local Info-current-file nil
"Info file that Info is now looking at, or nil.
@@ -420,6 +391,14 @@ where SUPPORTS-INDEX-COOKIES can be either t or nil.")
(defvar-local Info-index-alternatives nil
"List of possible matches for last `Info-index' command.")
+(defvar-local Info--current-index-alternative 0
+ "Current displayed index alternative.")
+
+(defcustom Info-warn-on-index-alternatives-wrap t
+ "Warn when wrapping to the beginning/end when displaying index alternatives."
+ :type 'boolean
+ :version "28.1")
+
(defvar Info-point-loc nil
"Point location within a selected node.
If string, the point is moved to the proper occurrence of the
@@ -639,14 +618,14 @@ Do the right thing if the file has been compressed or zipped."
(insert-file-contents-literally fullname visit)
(let ((inhibit-read-only t)
(coding-system-for-write 'no-conversion)
- (inhibit-nul-byte-detection t) ; Index nodes include null bytes
+ (inhibit-null-byte-detection t) ; Index nodes include null bytes
(default-directory (or (file-name-directory fullname)
default-directory)))
(or (consp decoder)
(setq decoder (list decoder)))
(apply #'call-process-region (point-min) (point-max)
(car decoder) t t nil (cdr decoder))))
- (let ((inhibit-nul-byte-detection t)) ; Index nodes include null bytes
+ (let ((inhibit-null-byte-detection t)) ; Index nodes include null bytes
(insert-file-contents fullname visit)))
;; Clear the caches of modified Info files.
@@ -945,7 +924,8 @@ find a node."
(when (and (not no-pop-to-dir)
(not Info-current-file))
(Info-directory))
- (user-error "Info file %s does not exist" filename)))
+ (user-error "Info file `%s' does not exist; consider installing it"
+ filename)))
filename))))
(defun Info-find-node (filename nodename &optional no-going-back strict-case)
@@ -957,6 +937,7 @@ This function first looks for a case-sensitive match for NODENAME;
if none is found it then tries a case-insensitive match (unless
STRICT-CASE is non-nil)."
(info-initialize)
+ (setq nodename (info--node-canonicalize-whitespace nodename))
(setq filename (Info-find-file filename))
;; Go into Info buffer.
(or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
@@ -1288,9 +1269,9 @@ is non-nil)."
(if Info-history
(let ((hist (car Info-history)))
(setq Info-history (cdr Info-history))
- (Info-find-node (nth 0 hist) (nth 1 hist) t)
+ (Info-find-node (nth 0 hist) (nth 1 hist) t t)
(goto-char (nth 2 hist)))
- (Info-find-node Info-current-file "Top" t)))))
+ (Info-find-node Info-current-file "Top" t t)))))
;; Cache the contents of the (virtual) dir file, once we have merged
;; it for the first time, so we can save time subsequently.
@@ -1375,7 +1356,7 @@ is non-nil)."
;; Index nodes include null bytes. DIR
;; files should not have indices, but who
;; knows...
- (let ((inhibit-nul-byte-detection t))
+ (let ((inhibit-null-byte-detection t))
(insert-file-contents file)
(setq Info-dir-file-name file)
(push (current-buffer) buffers)
@@ -1473,9 +1454,10 @@ is non-nil)."
(defvar Info-streamline-headings
'(("Emacs" . "Emacs")
- ("Programming" . "Programming")
+ ("Software development\\|Programming" . "Software development")
("Libraries" . "Libraries")
- ("World Wide Web\\|Net Utilities" . "Net Utilities"))
+ ("Network applications\\|World Wide Web\\|Net Utilities"
+ . "Network applications"))
"List of elements (RE . NAME) to merge headings matching RE to NAME.")
(defun Info-dir-remove-duplicates ()
@@ -1881,7 +1863,8 @@ See `completing-read' for a description of arguments and usage."
(lambda (string pred action)
(complete-with-action
action
- (Info-build-node-completions (Info-find-file file1 nil t))
+ (when-let ((file2 (Info-find-file file1 'noerror t)))
+ (Info-build-node-completions file2))
string pred))
nodename predicate code))))
;; Otherwise use Info-read-node-completion-table.
@@ -1907,10 +1890,17 @@ the Top node in FILENAME."
(or (cdr (assoc filename Info-file-completions))
(with-temp-buffer
(Info-mode)
- (Info-goto-node (format "(%s)Top" filename))
- (Info-build-node-completions-1)
- (push (cons filename Info-current-file-completions) Info-file-completions)
- Info-current-file-completions))
+ (condition-case nil
+ (Info-goto-node (format "(%s)Top" filename))
+ ;; `Info-goto-node' signals a `user-error' when there
+ ;; are no nodes in the file in question (for instance,
+ ;; if it's not actually an Info file).
+ (user-error nil)
+ (:success
+ (Info-build-node-completions-1)
+ (push (cons filename Info-current-file-completions)
+ Info-file-completions)
+ Info-current-file-completions))))
(or Info-current-file-completions
(Info-build-node-completions-1))))
@@ -1996,14 +1986,11 @@ the Top node in FILENAME."
"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
- (if Info-search-history
- (format "Regexp search%s (default %s): "
- (if case-fold-search "" " case-sensitively")
- (car Info-search-history))
- (format "Regexp search%s: "
- (if case-fold-search "" " case-sensitively")))
- nil 'Info-search-history)))
- (deactivate-mark)
+ (format-prompt
+ "Regexp search%s" (car Info-search-history)
+ (if case-fold-search "" " case-sensitively"))
+ nil 'Info-search-history))
+ Info-mode)
(when (equal regexp "")
(setq regexp (car Info-search-history)))
(when regexp
@@ -2096,6 +2083,7 @@ If DIRECTION is `backward', search in the reverse direction."
(< found opoint-max))
;; Search landed in the same node
(goto-char found)
+ (deactivate-mark)
(widen)
(goto-char found)
(save-match-data (Info-select-node)))
@@ -2110,13 +2098,13 @@ If DIRECTION is `backward', search in the reverse direction."
(defun Info-search-case-sensitively ()
"Search for a regexp case-sensitively."
- (interactive)
+ (interactive nil Info-mode)
(let ((case-fold-search nil))
(call-interactively 'Info-search)))
(defun Info-search-next ()
"Search for next regexp from a previous `Info-search' command."
- (interactive)
+ (interactive nil Info-mode)
(let ((case-fold-search Info-search-case-fold))
(if Info-search-history
(Info-search (car Info-search-history))
@@ -2125,13 +2113,11 @@ If DIRECTION is `backward', search in the reverse direction."
(defun Info-search-backward (regexp &optional bound noerror count)
"Search for REGEXP in the reverse direction."
(interactive (list (read-string
- (if Info-search-history
- (format "Regexp search%s backward (default %s): "
- (if case-fold-search "" " case-sensitively")
- (car Info-search-history))
- (format "Regexp search%s backward: "
- (if case-fold-search "" " case-sensitively")))
- nil 'Info-search-history)))
+ (format-prompt
+ "Regexp search%s backward" (car Info-search-history)
+ (if case-fold-search "" " case-sensitively"))
+ nil 'Info-search-history))
+ Info-mode)
(Info-search regexp bound noerror count 'backward))
(defun Info-isearch-search ()
@@ -2170,8 +2156,10 @@ If DIRECTION is `backward', search in the reverse direction."
(goto-char (if isearch-forward (point-min) (point-max)))))
(defun Info-isearch-push-state ()
- `(lambda (cmd)
- (Info-isearch-pop-state cmd ',Info-current-file ',Info-current-node)))
+ (let ((file Info-current-file)
+ (node Info-current-node))
+ (lambda (cmd)
+ (Info-isearch-pop-state cmd file node))))
(defun Info-isearch-pop-state (_cmd file node)
(or (and (equal Info-current-file file)
@@ -2268,7 +2256,7 @@ End of submatch 0, 1, and 3 are the same, so you can safely concat."
(defun Info-next ()
"Go to the \"next\" node, staying on the same hierarchical level.
This command doesn't descend into sub-nodes, like \\<Info-mode-map>\\[Info-forward-node] does."
- (interactive)
+ (interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
(or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
@@ -2277,7 +2265,7 @@ This command doesn't descend into sub-nodes, like \\<Info-mode-map>\\[Info-forwa
(defun Info-prev ()
"Go to the \"previous\" node, staying on the same hierarchical level.
This command doesn't go up to the parent node, like \\<Info-mode-map>\\[Info-backward-node] does."
- (interactive)
+ (interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
(or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
@@ -2286,7 +2274,7 @@ This command doesn't go up to the parent node, like \\<Info-mode-map>\\[Info-bac
(defun Info-up (&optional same-file)
"Go to the superior node of this node.
If SAME-FILE is non-nil, do not move to a different Info file."
- (interactive)
+ (interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
(or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
@@ -2309,11 +2297,15 @@ If SAME-FILE is non-nil, do not move to a different Info file."
nil t))
(progn (beginning-of-line) (if (looking-at "^\\* ") (forward-char 2)))
(goto-char p)
- (Info-restore-point Info-history)))))
+ (Info-restore-point Info-history))))
+ ;; If scroll-conservatively is non-zero and less than 101, display
+ ;; as much of the superior node above the target line as possible.
+ (when (< 0 scroll-conservatively 101)
+ (recenter)))
(defun Info-history-back ()
"Go back in the history to the last node visited."
- (interactive)
+ (interactive nil Info-mode)
(or Info-history
(user-error "This is the first Info node you looked at"))
(let ((history-forward
@@ -2333,7 +2325,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(defun Info-history-forward ()
"Go forward in the history of visited nodes."
- (interactive)
+ (interactive nil Info-mode)
(or Info-history-forward
(user-error "This is the last Info node you looked at"))
(let ((history-forward (cdr Info-history-forward))
@@ -2407,7 +2399,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(defun Info-history ()
"Go to a node with a menu of visited nodes."
- (interactive)
+ (interactive nil Info-mode)
(Info-find-node "*History*" "Top")
(Info-next-reference)
(Info-next-reference))
@@ -2444,7 +2436,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(defun Info-toc ()
"Go to a node with table of contents of the current Info file.
Table of contents is created from the tree structure of menus."
- (interactive)
+ (interactive nil Info-mode)
(Info-find-node Info-current-file "*TOC*")
(let ((prev-node (nth 1 (car Info-history))) p)
(goto-char (point-min))
@@ -2499,7 +2491,7 @@ Table of contents is created from the tree structure of menus."
(setq bound (or (and (equal nodename "Top")
(save-excursion
(re-search-forward
- "^[ \t-]*The Detailed Node Listing" nil t)))
+ "^[ \t—-]*The Detailed Node Listing" nil t)))
bound))
(while (< (point) bound)
(cond
@@ -2616,7 +2608,8 @@ new buffer."
(list (if (equal input "")
default input)
current-prefix-arg))
- (user-error "No cross-references in this node"))))
+ (user-error "No cross-references in this node")))
+ Info-mode)
(unless footnotename
(error "No reference was specified"))
@@ -2687,14 +2680,16 @@ Because of ambiguities, this should be concatenated with something like
;;; (setq Info-point-loc
;;; (buffer-substring (match-beginning 0) (1- (match-beginning 1))))
)
- (replace-regexp-in-string
- "[ \n]+" " "
+ (info--node-canonicalize-whitespace
(or (and (not (equal (match-string-no-properties 2) ""))
(match-string-no-properties 2))
;; If the node name is the menu entry name (using `entry::').
(buffer-substring-no-properties
(match-beginning 0) (1- (match-beginning 1)))))))
+(defun info--node-canonicalize-whitespace (string)
+ (replace-regexp-in-string "[ \t\n]+" " " string))
+
;; No one calls this.
;;(defun Info-menu-item-sequence (list)
;; (while list
@@ -2772,6 +2767,8 @@ Because of ambiguities, this should be concatenated with something like
;; Go back to the start node (for the next completion).
(unless (equal Info-current-node orignode)
(Info-goto-node orignode))
+ ;; Arrange list to be in order found in node.
+ (setq completions (nreverse completions))
;; Update the cache.
(setq Info-complete-cache
(list Info-current-file Info-current-node
@@ -2811,13 +2808,11 @@ new buffer."
(while (null item)
(setq item (let ((completion-ignore-case t)
(Info-complete-menu-buffer (current-buffer)))
- (completing-read (if default
- (format "Menu item (default %s): "
- default)
- "Menu item: ")
+ (completing-read (format-prompt "Menu item" default)
#'Info-complete-menu-item nil t nil nil
default))))
- (list item current-prefix-arg))))
+ (list item current-prefix-arg)))
+ Info-mode)
;; there is a problem here in that if several menu items have the same
;; name you can only go to the node of the first with this command.
(Info-goto-node (Info-extract-menu-item menu-item)
@@ -2861,19 +2856,19 @@ new buffer."
(defun Info-nth-menu-item ()
"Go to the node of the Nth menu item.
N is the digit argument used to invoke this command."
- (interactive)
+ (interactive nil Info-mode)
(Info-goto-node
(Info-extract-menu-counting
(- (aref (this-command-keys) (1- (length (this-command-keys)))) ?0))))
(defun Info-top-node ()
"Go to the Top node of this file."
- (interactive)
+ (interactive nil Info-mode)
(Info-goto-node "Top"))
(defun Info-final-node ()
"Go to the final node in this file."
- (interactive)
+ (interactive nil Info-mode)
(Info-goto-node "Top")
(let ((Info-history nil)
(case-fold-search t))
@@ -2897,7 +2892,7 @@ to the parent node.
When called from Lisp, NOT-DOWN non-nil means don't descend into sub-nodes,
NOT-UP non-nil means don't go to parent nodes, and NO-ERROR non-nil means
don't signal a user-error if there's no node to go to."
- (interactive)
+ (interactive nil Info-mode)
(goto-char (point-min))
(forward-line 1)
(let ((case-fold-search t))
@@ -2934,7 +2929,7 @@ don't signal a user-error if there's no node to go to."
"Go backward one node, considering all nodes as forming one sequence.
If the current node has a \"previous\" node, go to it, descending into its
last sub-node, if any; otherwise go \"up\" to the parent node."
- (interactive)
+ (interactive nil Info-mode)
(let ((prevnode (Info-extract-pointer "prev[ious]*" t))
(upnode (Info-extract-pointer "up" t))
(case-fold-search t))
@@ -2963,7 +2958,7 @@ last sub-node, if any; otherwise go \"up\" to the parent node."
(defun Info-next-menu-item ()
"Go to the node of the next menu item."
- (interactive)
+ (interactive nil Info-mode)
;; Bind this in case the user sets it to nil.
(let* ((case-fold-search t)
(node
@@ -2977,7 +2972,7 @@ last sub-node, if any; otherwise go \"up\" to the parent node."
(defun Info-last-menu-item ()
"Go to the node of the previous menu item."
- (interactive)
+ (interactive nil Info-mode)
(save-excursion
(forward-line 1)
;; Bind this in case the user sets it to nil.
@@ -2996,7 +2991,7 @@ last sub-node, if any; otherwise go \"up\" to the parent node."
(defun Info-next-preorder ()
"Go to the next subnode or the next node, or go up a level."
- (interactive)
+ (interactive nil Info-mode)
(cond ((Info-no-error (Info-next-menu-item)))
((Info-no-error (Info-next)))
((Info-no-error (Info-up t))
@@ -3015,7 +3010,7 @@ last sub-node, if any; otherwise go \"up\" to the parent node."
(defun Info-last-preorder ()
"Go to the last node, popping up a level if there is none."
- (interactive)
+ (interactive nil Info-mode)
(cond ((and Info-scroll-prefer-subnodes
(Info-no-error
(Info-last-menu-item)
@@ -3067,7 +3062,7 @@ the menu of a node, it moves to subnode indicated by the following menu
item. (That case won't normally result from this command, but can happen
in other ways.)"
- (interactive)
+ (interactive nil Info-mode)
(if (or (< (window-start) (point-min))
(> (window-start) (point-max)))
(set-window-start (selected-window) (point)))
@@ -3089,7 +3084,7 @@ in other ways.)"
(defun Info-mouse-scroll-up (e)
"Scroll one screenful forward in Info, using the mouse.
See `Info-scroll-up'."
- (interactive "e")
+ (interactive "e" Info-mode)
(save-selected-window
(if (eventp e)
(select-window (posn-window (event-start e))))
@@ -3101,7 +3096,7 @@ If point is within the menu of a node, and `Info-scroll-prefer-subnodes'
is non-nil, this goes to its last subnode. When you scroll past the
beginning of a node, that goes to the previous node or back up to the
parent node."
- (interactive)
+ (interactive nil Info-mode)
(if (or (< (window-start) (point-min))
(> (window-start) (point-max)))
(set-window-start (selected-window) (point)))
@@ -3121,7 +3116,7 @@ parent node."
(defun Info-mouse-scroll-down (e)
"Scroll one screenful backward in Info, using the mouse.
See `Info-scroll-down'."
- (interactive "e")
+ (interactive "e" Info-mode)
(save-selected-window
(if (eventp e)
(select-window (posn-window (event-start e))))
@@ -3130,9 +3125,11 @@ See `Info-scroll-down'."
(defun Info-next-reference-or-link (pat prop)
"Move point to the next pattern-based cross-reference or property-based link.
The next cross-reference is searched using the regexp PAT, and the next link
-is searched using the text property PROP. Move point to the closest found position
-of either a cross-reference found by `re-search-forward' or a link found by
-`next-single-char-property-change'. Return the new position of point, or nil."
+is searched using the text property PROP. Move point to the closest found
+position of either a cross-reference found by `re-search-forward' or a link
+found by `next-single-char-property-change'.
+
+Return the new position of point, or nil."
(let ((pxref (save-excursion (re-search-forward pat nil t)))
(plink (next-single-char-property-change (point) prop)))
(when (and (< plink (point-max)) (not (get-char-property plink prop)))
@@ -3145,10 +3142,12 @@ of either a cross-reference found by `re-search-forward' or a link found by
(defun Info-prev-reference-or-link (pat prop)
"Move point to the previous pattern-based cross-reference or property-based link.
-The previous cross-reference is searched using the regexp PAT, and the previous link
-is searched using the text property PROP. Move point to the closest found position
-of either a cross-reference found by `re-search-backward' or a link found by
-`previous-single-char-property-change'. Return the new position of point, or nil."
+The previous cross-reference is searched using the regexp PAT, and the previous
+link is searched using the text property PROP. Move point to the closest found
+position of either a cross-reference found by `re-search-backward' or a link
+found by `previous-single-char-property-change'.
+
+Return the new position of point, or nil."
(let ((pxref (save-excursion (re-search-backward pat nil t)))
(plink (previous-single-char-property-change (point) prop)))
(when (and (> plink (point-min)) (not (get-char-property plink prop)))
@@ -3163,7 +3162,7 @@ of either a cross-reference found by `re-search-backward' or a link found by
"Move cursor to the next cross-reference or menu item in the node.
If COUNT is non-nil (interactively with a prefix arg), jump over
COUNT cross-references."
- (interactive "i\np")
+ (interactive "i\np" Info-mode)
(unless count
(setq count 1))
(if (< count 0)
@@ -3191,7 +3190,7 @@ COUNT cross-references."
"Move cursor to the previous cross-reference or menu item in the node.
If COUNT is non-nil (interactively with a prefix arg), jump over
COUNT cross-references."
- (interactive "i\np")
+ (interactive "i\np" Info-mode)
(unless count
(setq count 1))
(if (< count 0)
@@ -3384,39 +3383,56 @@ Give an empty topic name to go to the Index node itself."
(setq exact (cons found exact)
matches (delq found matches)))
(setq Info-history-list ohist-list)
- (setq Info-index-alternatives (nconc exact (nreverse matches)))
+ (setq Info-index-alternatives (nconc exact (nreverse matches))
+ Info--current-index-alternative 0)
(Info-index-next 0)))))
(defun Info-index-next (num)
- "Go to the next matching index item from the last \\<Info-mode-map>\\[Info-index] command."
- (interactive "p")
- (or Info-index-alternatives
- (user-error "No previous `i' command"))
- (while (< num 0)
- (setq num (+ num (length Info-index-alternatives))))
- (while (> num 0)
- (setq Info-index-alternatives
- (nconc (cdr Info-index-alternatives)
- (list (car Info-index-alternatives)))
- num (1- num)))
- (Info-goto-node (nth 1 (car Info-index-alternatives)))
- (if (> (nth 3 (car Info-index-alternatives)) 0)
- ;; Forward 2 lines less because `Info-find-node-2' initially
- ;; puts point to the 2nd line.
- (forward-line (- (nth 3 (car Info-index-alternatives)) 2))
- (forward-line 3) ; don't search in headers
- (let ((name (car (car Info-index-alternatives))))
- (Info-find-index-name name)))
- (message "Found `%s' in %s. %s"
- (car (car Info-index-alternatives))
- (nth 2 (car Info-index-alternatives))
- (if (cdr Info-index-alternatives)
- (format-message
- "(%s total; use `%s' for next)"
- (length Info-index-alternatives)
- (key-description (where-is-internal
- 'Info-index-next overriding-local-map t)))
- "(Only match)")))
+ "Go to the next matching index item from the last \\<Info-mode-map>\\[Info-index] command.
+If given a numeric prefix, skip that many index items forward (or
+backward).
+
+Also see the `Info-warn-on-index-alternatives-wrap' user option."
+ (interactive "p" Info-mode)
+ (unless Info-index-alternatives
+ (user-error "No previous `i' command"))
+ (let ((index (+ Info--current-index-alternative num))
+ (total (length Info-index-alternatives))
+ (next-key (key-description (where-is-internal
+ 'Info-index-next overriding-local-map t))))
+ (if (and Info-warn-on-index-alternatives-wrap
+ (> total 1)
+ (cond
+ ((< index 0)
+ (setq Info--current-index-alternative (- total 2))
+ (message
+ "No previous matches, use `%s' to continue from end of list"
+ next-key)
+ t)
+ ((>= index total)
+ (setq Info--current-index-alternative -1)
+ (message
+ "No previous matches, use `%s' to continue from start of list"
+ next-key)
+ t)))
+ () ; Do nothing
+ (setq index (mod index total)
+ Info--current-index-alternative index)
+ (let ((entry (nth index Info-index-alternatives)))
+ (Info-goto-node (nth 1 entry))
+ (if (> (nth 3 entry) 0)
+ ;; Forward 2 lines less because `Info-find-node-2' initially
+ ;; puts point to the 2nd line.
+ (forward-line (- (nth 3 entry) 2))
+ (forward-line 3) ; don't search in headers
+ (Info-find-index-name (car entry)))
+ (message "Found `%s' in %s. %s"
+ (car entry)
+ (nth 2 entry)
+ (if (> total 1)
+ (format-message
+ "(%s total; use `%s' for next)" total next-key)
+ "(Only match)"))))))
(defun Info-find-index-name (name)
"Move point to the place within the current node where NAME is defined."
@@ -3511,7 +3527,8 @@ search results."
(with-current-buffer Info-complete-menu-buffer
(Info-goto-index)
(completing-read "Index topic: " #'Info-complete-menu-item))
- (kill-buffer Info-complete-menu-buffer)))))
+ (kill-buffer Info-complete-menu-buffer))))
+ Info-mode)
(if (equal topic "")
(Info-find-node Info-current-file "*Index*")
(unless (assoc (cons Info-current-file topic) Info-virtual-index-nodes)
@@ -3791,20 +3808,8 @@ Build a menu of the possible matches."
;; there is no "nxml.el" (it's nxml-mode.el).
;; But package.el makes the same assumption.
;; I think nxml is the only exception - maybe it should be just be renamed.
- (let ((str (ignore-errors (lm-commentary (find-library-name nodename)))))
- (if (null str)
- (insert "Can’t find package description.\n\n")
- (insert
- (with-temp-buffer
- (insert str)
- (goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-max))
- (delete-blank-lines)
- (goto-char (point-min))
- (while (re-search-forward "^;+ ?" nil t)
- (replace-match "" nil nil))
- (buffer-string))))))))
+ (insert (or (ignore-errors (lm-commentary (find-library-name nodename)))
+ (insert "Can’t find package description.\n\n"))))))
;;;###autoload
(defun info-finder (&optional keywords)
@@ -3829,7 +3834,7 @@ with a list of packages that contain all specified keywords."
(defun Info-undefined ()
"Make command be undefined in Info."
- (interactive)
+ (interactive nil Info-mode)
(ding))
(defun Info-help ()
@@ -3906,7 +3911,7 @@ ERRORSTRING optional fourth argument, controls action on no match:
"\\<Info-mode-map>Follow a node reference near point.
Like \\[Info-menu], \\[Info-follow-reference], \\[Info-next], \\[Info-prev] or \\[Info-up] command, depending on where you click.
At end of the node's text, moves to the next node, or up if none."
- (interactive "e")
+ (interactive "e" Info-mode)
(mouse-set-point click)
(and (not (Info-follow-nearest-node))
(save-excursion (forward-line 1) (eobp))
@@ -3920,7 +3925,7 @@ if point is in a menu item description, follow that menu item.
If FORK is non-nil (interactively with a prefix arg), show the node in
a new Info buffer.
If FORK is a string, it is the name to use for the new buffer."
- (interactive "P")
+ (interactive "P" Info-mode)
(or (Info-try-follow-nearest-node fork)
(when (save-excursion
(search-backward "\n* menu:" nil t))
@@ -3990,7 +3995,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(defun Info-mouse-follow-link (click)
"Follow a link where you click."
- (interactive "@e")
+ (interactive "@e" Info-mode)
(let* ((position (event-start click))
(posn-string (and position (posn-string position)))
(link-args (if posn-string
@@ -4066,6 +4071,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(define-key map "^" 'Info-up)
(define-key map "," 'Info-index-next)
(define-key map "\177" 'Info-scroll-down)
+ (define-key map [remap goto-line] 'goto-line-relative)
(define-key map [mouse-2] 'Info-mouse-follow-nearest-node)
(define-key map [follow-link] 'mouse-face)
(define-key map [XF86Back] 'Info-history-back)
@@ -4102,22 +4108,28 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
:help "Go to top node of file"]
["Final Node" Info-final-node
:help "Go to final node in this file"]
+ "---"
("Menu Item" ["You should never see this" report-emacs-bug t])
("Reference" ["You should never see this" report-emacs-bug t])
["Search..." Info-search
:help "Search for regular expression in this Info file"]
["Search Next" Info-search-next
:help "Search for another occurrence of regular expression"]
- ["Go to Node..." Info-goto-node
+ "---"
+ ("History"
+ ["Back in history" Info-history-back :active Info-history
+ :help "Go back in history to the last node you were at"]
+ ["Forward in history" Info-history-forward :active Info-history-forward
+ :help "Go forward in history"]
+ ["Show History" Info-history :active Info-history-list
+ :help "Go to menu of visited nodes"])
+ ("Go to"
+ ["Go to Node..." Info-goto-node
:help "Go to a named node"]
- ["Back in history" Info-history-back :active Info-history
- :help "Go back in history to the last node you were at"]
- ["Forward in history" Info-history-forward :active Info-history-forward
- :help "Go forward in history"]
- ["History" Info-history :active Info-history-list
- :help "Go to menu of visited nodes"]
- ["Table of Contents" Info-toc
- :help "Go to table of contents"]
+ ["Table of Contents" Info-toc
+ :help "Go to table of contents"]
+ ["Go to Directory" Info-directory
+ :help "Go to the Info directory node."])
("Index"
["Lookup a String..." Info-index
:help "Look for a string in the index items"]
@@ -4131,6 +4143,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
:help "Copy the name of the current node into the kill ring"]
["Clone Info buffer" clone-buffer
:help "Create a twin copy of the current Info buffer."]
+ "---"
["Exit" quit-window :help "Stop reading Info"]))
@@ -4186,12 +4199,12 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(defun Info-history-back-menu (e)
"Pop up the menu with a list of previously visited Info nodes."
- (interactive "e")
+ (interactive "e" Info-mode)
(Info-history-menu e "Back in history" Info-history 'Info-history-back))
(defun Info-history-forward-menu (e)
"Pop up the menu with a list of Info nodes visited with ‘Info-history-back’."
- (interactive "e")
+ (interactive "e" Info-mode)
(Info-history-menu e "Forward in history" Info-history-forward 'Info-history-forward))
(defvar Info-menu-last-node nil)
@@ -4265,7 +4278,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
"Put the name of the current Info node into the kill ring.
The name of the Info file is prepended to the node name in parentheses.
With a zero prefix arg, put the name inside a function call to `info'."
- (interactive "P")
+ (interactive "P" Info-mode)
(unless Info-current-node
(user-error "No current Info node"))
(let ((node (if (stringp Info-current-file)
@@ -4381,6 +4394,7 @@ Moving within a node:
already visible, try to go to the previous menu entry, or up
if there is none.
\\[beginning-of-buffer] Go to beginning of node.
+\\[end-of-buffer] Go to end of node.
Advanced commands:
\\[Info-search] Search through this Info file for specified regexp,
@@ -4818,11 +4832,11 @@ first line or header line, and for breadcrumb links.")
;; an end of sentence
(skip-syntax-backward " ("))
(setq other-tag
- (cond ((save-match-data (looking-back "\\<see"
- (- (point) 3)))
+ (cond ((save-match-data (looking-back "\\(^\\| \\)see"
+ (- (point) 4)))
"")
- ((save-match-data (looking-back "\\<in"
- (- (point) 2)))
+ ((save-match-data (looking-back "\\(^\\| \\)in"
+ (- (point) 3)))
"")
((memq (char-before) '(nil ?\. ?! ??))
"See ")
@@ -5146,9 +5160,8 @@ first line or header line, and for breadcrumb links.")
"Additional menu-items to add to speedbar frame.")
;; Make sure our special speedbar major mode is loaded
-(if (featurep 'speedbar)
- (Info-install-speedbar-variables)
- (add-hook 'speedbar-load-hook 'Info-install-speedbar-variables))
+(with-eval-after-load 'speedbar
+ (Info-install-speedbar-variables))
;;; Info hierarchy display method
;;;###autoload
diff --git a/lisp/informat.el b/lisp/informat.el
index 3b949fca4be..bac09752b70 100644
--- a/lisp/informat.el
+++ b/lisp/informat.el
@@ -1,4 +1,4 @@
-;;; informat.el --- info support functions package for Emacs
+;;; informat.el --- info support functions package for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986, 2001-2021 Free Software Foundation, Inc.
@@ -140,7 +140,7 @@
(or (bolp)
(newline))
(insert "\^_\f\nTag table:\n")
- (if (eq major-mode 'info-mode)
+ (if (derived-mode-p 'info-mode)
(move-marker Info-tag-table-marker (point)))
(setq tag-list (nreverse tag-list))
(while tag-list
@@ -337,7 +337,7 @@ Check that every node pointer points to an existing node."
(point))))
(Info-extract-menu-node-name))))
(goto-char (point-min))
- (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
+ (while (re-search-forward "\\*note\\>[^:\t]*:" nil t)
(goto-char (+ (match-beginning 0) 5))
(skip-chars-forward " \n")
(Info-validate-node-name
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index 02fb0914778..0eb009fa526 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -43,12 +43,6 @@
;;; Code:
-;; Unused.
-;;; (defgroup ccl nil
-;;; "CCL (Code Conversion Language) compiler."
-;;; :prefix "ccl-"
-;;; :group 'i18n)
-
(defconst ccl-command-table
[if branch loop break repeat write-repeat write-read-repeat
read read-if read-branch write call end
@@ -196,7 +190,9 @@
"Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
increment it. If IC is specified, embed DATA at IC."
(if ic
- (aset ccl-program-vector ic (ccl-fixnum data))
+ (aset ccl-program-vector ic (if (numberp data)
+ (ccl-fixnum data)
+ data))
(let ((len (length ccl-program-vector)))
(if (>= ccl-current-ic len)
(let ((new (make-vector (* len 2) nil)))
@@ -204,7 +200,9 @@ increment it. If IC is specified, embed DATA at IC."
(setq len (1- len))
(aset new len (aref ccl-program-vector len)))
(setq ccl-program-vector new))))
- (aset ccl-program-vector ccl-current-ic (ccl-fixnum data))
+ (aset ccl-program-vector ccl-current-ic (if (numberp data)
+ (ccl-fixnum data)
+ data))
(setq ccl-current-ic (1+ ccl-current-ic))))
(defun ccl-embed-symbol (symbol prop)
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index 0d2304bf98e..97bf31acfc3 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1,4 +1,4 @@
-;;; characters.el --- set syntax and category for multibyte characters
+;;; characters.el --- set syntax and category for multibyte characters -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -60,7 +60,7 @@ Vietnamese")
;; For each group (row) of 2-byte character sets.
(define-category ?A "2-byte alnum
-Alpha-numeric characters of 2-byte character sets")
+Alphanumeric characters of 2-byte character sets")
(define-category ?C "2-byte han
Chinese (Han) characters of 2-byte character sets")
(define-category ?G "2-byte Greek
@@ -226,6 +226,7 @@ with L, LRE, or LRO Unicode bidi character type.")
;; JISX0208
+;; Note: Some of these have their syntax updated later below.
(map-charset-chars #'modify-syntax-entry 'japanese-jisx0208 "_" #x2121 #x227E)
(map-charset-chars #'modify-syntax-entry 'japanese-jisx0208 "_" #x2821 #x287E)
(let ((chars '(?ー ?ã‚› ?゜ ?ヽ ?ヾ ?ã‚ ?ゞ ?〃 ?ä» ?々 ?〆 ?〇)))
@@ -264,7 +265,7 @@ with L, LRE, or LRO Unicode bidi character type.")
(map-charset-chars #'modify-syntax-entry 'korean-ksc5601 "_" #x2121 #x227E)
(map-charset-chars #'modify-syntax-entry 'korean-ksc5601 "_" #x2621 #x277E)
(map-charset-chars #'modify-syntax-entry 'korean-ksc5601 "_" #x2830 #x287E)
-(map-charset-chars #'modify-syntax-entry 'korean-ksc5601 "_" #x2930 #x297E)
+(map-charset-chars #'modify-syntax-entry 'korean-ksc5601 "_" #x2930 #x2975)
(map-charset-chars #'modify-category-entry 'korean-ksc5601 ?A #x2330 #x2339)
(map-charset-chars #'modify-category-entry 'korean-ksc5601 ?A #x2341 #x235A)
(map-charset-chars #'modify-category-entry 'korean-ksc5601 ?A #x2361 #x237A)
@@ -317,6 +318,7 @@ with L, LRE, or LRO Unicode bidi character type.")
(modify-syntax-entry #x5be ".") ; MAQAF
(modify-syntax-entry #x5c0 ".") ; PASEQ
(modify-syntax-entry #x5c3 ".") ; SOF PASUQ
+(modify-syntax-entry #x5c6 ".") ; NUN HAFUKHA
(modify-syntax-entry #x5f3 ".") ; GERESH
(modify-syntax-entry #x5f4 ".") ; GERSHAYIM
@@ -482,9 +484,9 @@ with L, LRE, or LRO Unicode bidi character type.")
(progn
(modify-syntax-entry chars syntax)
(modify-category-entry chars category))
- (mapc #'(lambda (x)
- (modify-syntax-entry x syntax)
- (modify-category-entry x category))
+ (mapc (lambda (x)
+ (modify-syntax-entry x syntax)
+ (modify-category-entry x category))
chars)))))
;; Bidi categories
@@ -521,9 +523,9 @@ with L, LRE, or LRO Unicode bidi character type.")
;; syntax: ¢£¤¥¨ª¯²³´¶¸¹º.) There should be a well-defined way of
;; relating Unicode categories to Emacs syntax codes.
- ;; NBSP isn't semantically interchangeable with other whitespace chars,
- ;; so it's more like punctuation.
- (set-case-syntax ?  "." tbl)
+ ;; FIXME: We should probably just use the Unicode properties to set
+ ;; up the syntax table.
+
(set-case-syntax ?¡ "." tbl)
(set-case-syntax ?¦ "_" tbl)
(set-case-syntax ?§ "." tbl)
@@ -558,7 +560,7 @@ with L, LRE, or LRO Unicode bidi character type.")
(setq c (1+ c)))
;; Latin Extended Additional
- (modify-category-entry '(#x1e00 . #x1ef9) ?l)
+ (modify-category-entry '(#x1E00 . #x1EF9) ?l)
;; Latin Extended-C
(setq c #x2C60)
@@ -579,13 +581,13 @@ with L, LRE, or LRO Unicode bidi character type.")
(setq c (1+ c)))
;; Greek
- (modify-category-entry '(#x0370 . #x03ff) ?g)
+ (modify-category-entry '(#x0370 . #x03FF) ?g)
;; Armenian
(setq c #x531)
;; Greek Extended
- (modify-category-entry '(#x1f00 . #x1fff) ?g)
+ (modify-category-entry '(#x1F00 . #x1FFF) ?g)
;; cyrillic
(modify-category-entry '(#x0400 . #x04FF) ?y)
@@ -597,48 +599,57 @@ with L, LRE, or LRO Unicode bidi character type.")
;; Cyrillic Extended-C
(modify-category-entry '(#x1C80 . #x1C8F) ?y)
- ;; general punctuation
+ ;; space characters (see section 6.2 in the Unicode Standard)
+ (set-case-syntax ?  " " tbl)
(setq c #x2000)
(while (<= c #x200b)
(set-case-syntax c " " tbl)
(setq c (1+ c)))
+ (let ((chars '(#x202F #x205F #x3000)))
+ (while chars
+ (set-case-syntax (car chars) " " tbl)
+ (setq chars (cdr chars))))
+ ;; general punctuation
(while (<= c #x200F)
(set-case-syntax c "." tbl)
(setq c (1+ c)))
- ;; Fixme: These aren't all right:
(setq c #x2010)
- (while (<= c #x2016)
- (set-case-syntax c "_" tbl)
+ ;; Fixme: What to do with characters that have Pi and Pf
+ ;; Unicode properties?
+ (while (<= c #x2017)
+ (set-case-syntax c "." tbl)
(setq c (1+ c)))
;; Punctuation syntax for quotation marks (like `)
- (while (<= c #x201f)
+ (while (<= c #x201F)
(set-case-syntax c "." tbl)
(setq c (1+ c)))
- ;; Fixme: These aren't all right:
(while (<= c #x2027)
- (set-case-syntax c "_" tbl)
+ (set-case-syntax c "." tbl)
(setq c (1+ c)))
- (while (<= c #x206F)
+ (setq c #x2030)
+ (while (<= c #x205E)
(set-case-syntax c "." tbl)
(setq c (1+ c)))
+ (let ((chars '(?‹ ?› ?â„ ?â’)))
+ (while chars
+ (modify-syntax-entry (car chars) "_")
+ (setq chars (cdr chars))))
- ;; Fixme: The following blocks might be better as symbol rather than
- ;; punctuation.
;; Arrows
(setq c #x2190)
(while (<= c #x21FF)
- (set-case-syntax c "." tbl)
+ (set-case-syntax c "_" tbl)
(setq c (1+ c)))
;; Mathematical Operators
(while (<= c #x22FF)
- (set-case-syntax c "." tbl)
+ (set-case-syntax c "_" tbl)
(setq c (1+ c)))
;; Miscellaneous Technical
(while (<= c #x23FF)
- (set-case-syntax c "." tbl)
+ (set-case-syntax c "_" tbl)
(setq c (1+ c)))
;; Control Pictures
- (while (<= c #x243F)
+ (while (<= c #x244F)
(set-case-syntax c "_" tbl)
(setq c (1+ c)))
@@ -652,13 +663,13 @@ with L, LRE, or LRO Unicode bidi character type.")
;; Supplemental Mathematical Operators
(setq c #x2A00)
(while (<= c #x2AFF)
- (set-case-syntax c "." tbl)
+ (set-case-syntax c "_" tbl)
(setq c (1+ c)))
;; Miscellaneous Symbols and Arrows
(setq c #x2B00)
(while (<= c #x2BFF)
- (set-case-syntax c "." tbl)
+ (set-case-syntax c "_" tbl)
(setq c (1+ c)))
;; Coptic
@@ -674,19 +685,47 @@ with L, LRE, or LRO Unicode bidi character type.")
(set-case-syntax c "." tbl)
(setq c (1+ c)))
+ ;; Ideographic punctuation
+ (setq c #x3001)
+ (while (<= c #x3003)
+ (set-case-syntax c "." tbl)
+ (setq c (1+ c)))
+ (set-case-syntax #x30FB "." tbl)
+
;; Symbols for Legacy Computing
(setq c #x1FB00)
+ (while (<= c #x1FBCA)
+ (set-case-syntax c "_" tbl)
+ (setq c (1+ c)))
+ ;; FIXME: Should these be digits?
(while (<= c #x1FBFF)
(set-case-syntax c "." tbl)
(setq c (1+ c)))
;; Fullwidth Latin
- (setq c #xff21)
- (while (<= c #xff3a)
+ (setq c #xFF01)
+ (while (<= c #xFF0F)
+ (set-case-syntax c "." tbl)
+ (setq c (1+ c)))
+ (set-case-syntax #xFF04 "_" tbl)
+ (set-case-syntax #xFF0B "_" tbl)
+ (set-case-syntax #xFF1A "." tbl)
+ (set-case-syntax #xFF1B "." tbl)
+ (set-case-syntax #xFF1F "." tbl)
+ (set-case-syntax #xFF20 "." tbl)
+ (setq c #xFF21)
+ (while (<= c #xFF3A)
(modify-category-entry c ?l)
(modify-category-entry (+ c #x20) ?l)
(setq c (1+ c)))
+ ;; Halfwidth Latin
+ (setq c #xFF64)
+ (while (<= c #xFF65)
+ (set-case-syntax c "." tbl)
+ (setq c (1+ c)))
+ (set-case-syntax #xFF61 "." tbl)
+
;; Combining diacritics
(modify-category-entry '(#x300 . #x362) ?^)
;; Combining marks
@@ -759,7 +798,14 @@ with L, LRE, or LRO Unicode bidi character type.")
(funcall map-unicode-property 'uppercase
(lambda (lc uc) (aset up lc uc) (aset up uc uc)))
(funcall map-unicode-property 'lowercase
- (lambda (uc lc) (aset down uc lc) (aset down lc lc))))))
+ (lambda (uc lc) (aset down uc lc) (aset down lc lc)))
+
+ ;; Override the Unicode uppercase property for ß, since we are
+ ;; using our case tables for determining the case of a
+ ;; character (see uppercasep and lowercasep in buffer.h).
+ ;; The special-uppercase property of ß ensures that it is
+ ;; still upcased to SS per the usual convention.
+ (aset up ?ß ?ẞ))))
;; Clear out the extra slots so that they will be recomputed from the main
;; (downcase) table and upcase table. Since we’re side-stepping the usual
@@ -1344,8 +1390,8 @@ with L, LRE, or LRO Unicode bidi character type.")
(dolist (charset-info (nthcdr 2 slot))
(let ((charset (car charset-info)))
(dolist (code-range (cdr charset-info))
- (map-charset-chars #'(lambda (range _arg)
- (set-char-table-range table range 2))
+ (map-charset-chars (lambda (range _arg)
+ (set-char-table-range table range 2))
charset nil
(car code-range) (cdr code-range)))))
(optimize-char-table table)
@@ -1371,8 +1417,8 @@ Setup char-width-table appropriate for non-CJK language environment."
(require 'charscript))
(map-charset-chars
- #'(lambda (range _ignore)
- (set-char-table-range char-script-table range 'tibetan))
+ (lambda (range _ignore)
+ (set-char-table-range char-script-table range 'tibetan))
'tibetan)
@@ -1380,14 +1426,14 @@ Setup char-width-table appropriate for non-CJK language environment."
(when (setq unicode-category-table
(unicode-property-table-internal 'general-category))
- (map-char-table #'(lambda (key val)
- (if val
- (cond ((or (and (/= (aref (symbol-name val) 0) ?M)
- (/= (aref (symbol-name val) 0) ?C))
- (eq val 'Zs))
- (modify-category-entry key ?.))
- ((eq val 'Mn)
- (modify-category-entry key ?^)))))
+ (map-char-table (lambda (key val)
+ (if val
+ (cond ((or (and (/= (aref (symbol-name val) 0) ?M)
+ (/= (aref (symbol-name val) 0) ?C))
+ (eq val 'Zs))
+ (modify-category-entry key ?.))
+ ((eq val 'Mn)
+ (modify-category-entry key ?^)))))
unicode-category-table))
(optimize-char-table (standard-category-table))
@@ -1478,21 +1524,21 @@ option `glyphless-char-display'."
((eq target 'format-control)
(when unicode-category-table
(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))))))
+ (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))
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 8e4fdeaaf71..3deaff96774 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -1,4 +1,4 @@
-;;; fontset.el --- commands for handling fontset
+;;; fontset.el --- commands for handling fontset -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -191,6 +191,7 @@
(kanbun #x319D)
(han #x5B57)
(yi #xA288)
+ (javanese #xA980)
(cham #xAA00)
(tai-viet #xAA80)
(hangul #xAC00)
@@ -496,37 +497,37 @@
(:registry "iso10646-1"))))
(cjk-table (make-char-table nil))
(script-coverage
- #'(lambda (script)
- (let ((coverage))
- (map-char-table
- #'(lambda (range val)
- (when (eq val script)
- (if (consp range)
- (setq range (cons (car range) (cdr range))))
- (push range coverage)))
- char-script-table)
- coverage)))
+ (lambda (script)
+ (let ((coverage))
+ (map-char-table
+ (lambda (range val)
+ (when (eq val script)
+ (if (consp range)
+ (setq range (cons (car range) (cdr range))))
+ (push range coverage)))
+ char-script-table)
+ coverage)))
(data (list (vconcat (mapcar 'car cjk))))
(i 0))
(dolist (elt cjk)
(let ((mask (ash 1 i)))
(map-charset-chars
- #'(lambda (range _arg)
- (let ((from (car range)) (to (cdr range)))
- (if (< to #x110000)
- (while (<= from to)
- (or (memq (aref char-script-table from)
- '(kana hangul han cjk-misc))
- (aset cjk-table from
- (logior (or (aref cjk-table from) 0) mask)))
- (setq from (1+ from))))))
+ (lambda (range _arg)
+ (let ((from (car range)) (to (cdr range)))
+ (if (< to #x110000)
+ (while (<= from to)
+ (or (memq (aref char-script-table from)
+ '(kana hangul han cjk-misc))
+ (aset cjk-table from
+ (logior (or (aref cjk-table from) 0) mask)))
+ (setq from (1+ from))))))
(nth 1 elt) nil (nth 2 elt) (nth 3 elt)))
(setq i (1+ i)))
(map-char-table
- #'(lambda (range val)
- (if (consp range)
- (setq range (cons (car range) (cdr range))))
- (push (cons range val) data))
+ (lambda (range val)
+ (if (consp range)
+ (setq range (cons (car range) (cdr range))))
+ (push (cons range val) data))
cjk-table)
(dolist (script scripts)
(dolist (range (funcall script-coverage (car script)))
@@ -718,11 +719,13 @@
georgian
cherokee
canadian-aboriginal
+ cham
ogham
runic
symbol
braille
yi
+ javanese
tai-viet
aegean-number
ancient-greek-number
@@ -1224,7 +1227,7 @@ Done when `mouse-set-font' is called."
(string-match "fontset-auto[0-9]+$" fontset)
(push (list (fontset-plain-name fontset) fontset) l)))
(cons "Fontset"
- (sort l #'(lambda (x y) (string< (car x) (car y)))))))
+ (sort l (lambda (x y) (string< (car x) (car y)))))))
(declare-function query-fontset "fontset.c" (pattern &optional regexpp))
diff --git a/lisp/international/isearch-x.el b/lisp/international/isearch-x.el
index c401511ec00..b890bde48d1 100644
--- a/lisp/international/isearch-x.el
+++ b/lisp/international/isearch-x.el
@@ -1,4 +1,4 @@
-;;; isearch-x.el --- extended isearch handling commands
+;;; isearch-x.el --- extended isearch handling commands -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -35,9 +35,8 @@
(interactive)
(let ((overriding-terminal-local-map nil))
(toggle-input-method t))
- (setq isearch-input-method-function input-method-function
- isearch-input-method-local-p t)
- (setq input-method-function nil)
+ (setq isearch-input-method-function input-method-function)
+ (setq-local input-method-function nil)
(isearch-update))
;;;###autoload
@@ -46,9 +45,17 @@
(interactive)
(let ((overriding-terminal-local-map nil))
(toggle-input-method))
- (setq isearch-input-method-function input-method-function
- isearch-input-method-local-p t)
- (setq input-method-function nil)
+ (setq isearch-input-method-function input-method-function)
+ (setq-local input-method-function nil)
+ (isearch-update))
+
+;;;###autoload
+(defun isearch-transient-input-method ()
+ "Activate transient input method in interactive search."
+ (interactive)
+ (let ((overriding-terminal-local-map nil))
+ (activate-transient-input-method))
+ (setq-local input-method-function nil)
(isearch-update))
(defvar isearch-minibuffer-local-map
@@ -60,7 +67,7 @@
;; Exit from recursive edit safely. Set in `after-change-functions'
;; by isearch-with-keyboard-coding.
-(defun isearch-exit-recursive-edit (start end length)
+(defun isearch-exit-recursive-edit (_start _end _length)
(interactive)
(throw 'exit nil))
@@ -95,6 +102,7 @@
;;;###autoload
(defun isearch-process-search-multibyte-characters (last-char &optional count)
+ (defvar junk-hist)
(if (eq this-command 'isearch-printing-char)
(let ((overriding-terminal-local-map nil)
(prompt (isearch-message-prefix))
@@ -117,6 +125,7 @@
(cons last-char unread-command-events))
;; Inherit current-input-method in a minibuffer.
str (read-string prompt isearch-message 'junk-hist nil t))
+ (deactivate-transient-input-method)
(if (or (not str) (< (length str) (length isearch-message)))
;; All inputs were deleted while the input method
;; was working.
diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el
index fa55a2cf572..f8cb61c08f9 100644
--- a/lisp/international/iso-ascii.el
+++ b/lisp/international/iso-ascii.el
@@ -1,4 +1,4 @@
-;;; iso-ascii.el --- set up char tables for ISO 8859/1 on ASCII terminals
+;;; iso-ascii.el --- set up char tables for ISO 8859/1 on ASCII terminals -*- lexical-binding: t -*-
;; Copyright (C) 1987, 1995, 1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -41,8 +41,7 @@
(defcustom iso-ascii-convenient nil
"Non-nil means `iso-ascii' should aim for convenience, not precision."
- :type 'boolean
- :group 'iso-ascii)
+ :type 'boolean)
(defvar iso-ascii-display-table (make-display-table)
"Display table used for ISO-ASCII mode.")
diff --git a/lisp/international/iso-cvt.el b/lisp/international/iso-cvt.el
index 3f3843e23dd..ead7c8aa619 100644
--- a/lisp/international/iso-cvt.el
+++ b/lisp/international/iso-cvt.el
@@ -1,4 +1,4 @@
-;;; iso-cvt.el --- translate ISO 8859-1 from/to various encodings -*- coding: utf-8 -*-
+;;; iso-cvt.el --- translate ISO 8859-1 from/to various encodings -*- lexical-binding: t; -*-
;; This file was formerly called gm-lingo.el.
;; Copyright (C) 1993-1998, 2000-2021 Free Software Foundation, Inc.
@@ -79,7 +79,7 @@
(point-max))))
;;;###autoload
-(defun iso-spanish (from to &optional buffer)
+(defun iso-spanish (from to &optional _buffer)
"Translate net conventions for Spanish to ISO 8859-1.
Translate the region between FROM and TO using the table
`iso-spanish-trans-tab'.
@@ -121,7 +121,7 @@ and may translate too little.")
"Currently active translation table for German.")
;;;###autoload
-(defun iso-german (from to &optional buffer)
+(defun iso-german (from to &optional _buffer)
"Translate net conventions for German to ISO 8859-1.
Translate the region FROM and TO using the table
`iso-german-trans-tab'.
@@ -194,7 +194,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
"Translation table for translating ISO 8859-1 characters to TeX sequences.")
;;;###autoload
-(defun iso-iso2tex (from to &optional buffer)
+(defun iso-iso2tex (from to &optional _buffer)
"Translate ISO 8859-1 characters to TeX sequences.
Translate the region between FROM and TO using the table
`iso-iso2tex-trans-tab'.
@@ -387,7 +387,7 @@ This table is not exhaustive (and due to TeX's power can never be).
It only contains commonly used sequences.")
;;;###autoload
-(defun iso-tex2iso (from to &optional buffer)
+(defun iso-tex2iso (from to &optional _buffer)
"Translate TeX sequences to ISO 8859-1 characters.
Translate the region between FROM and TO using the table
`iso-tex2iso-trans-tab'.
@@ -646,7 +646,7 @@ It only contains commonly used sequences.")
"Translation table for translating ISO 8859-1 characters to German TeX.")
;;;###autoload
-(defun iso-gtex2iso (from to &optional buffer)
+(defun iso-gtex2iso (from to &optional _buffer)
"Translate German TeX sequences to ISO 8859-1 characters.
Translate the region between FROM and TO using the table
`iso-gtex2iso-trans-tab'.
@@ -655,7 +655,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
(iso-translate-conventions from to iso-gtex2iso-trans-tab))
;;;###autoload
-(defun iso-iso2gtex (from to &optional buffer)
+(defun iso-iso2gtex (from to &optional _buffer)
"Translate ISO 8859-1 characters to German TeX sequences.
Translate the region between FROM and TO using the table
`iso-iso2gtex-trans-tab'.
@@ -674,7 +674,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
"Translation table for translating ISO 8859-1 characters to Duden sequences.")
;;;###autoload
-(defun iso-iso2duden (from to &optional buffer)
+(defun iso-iso2duden (from to &optional _buffer)
"Translate ISO 8859-1 characters to Duden sequences.
Translate the region between FROM and TO using the table
`iso-iso2duden-trans-tab'.
@@ -812,7 +812,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
("&yuml;" "ÿ")))
;;;###autoload
-(defun iso-iso2sgml (from to &optional buffer)
+(defun iso-iso2sgml (from to &optional _buffer)
"Translate ISO 8859-1 characters in the region to SGML entities.
Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\".
Optional arg BUFFER is ignored (for use in `format-alist')."
@@ -820,7 +820,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
(iso-translate-conventions from to iso-iso2sgml-trans-tab))
;;;###autoload
-(defun iso-sgml2iso (from to &optional buffer)
+(defun iso-sgml2iso (from to &optional _buffer)
"Translate SGML entities in the region to ISO 8859-1 characters.
Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\".
Optional arg BUFFER is ignored (for use in `format-alist')."
@@ -828,13 +828,13 @@ Optional arg BUFFER is ignored (for use in `format-alist')."
(iso-translate-conventions from to iso-sgml2iso-trans-tab))
;;;###autoload
-(defun iso-cvt-read-only (&rest ignore)
+(defun iso-cvt-read-only (&rest _ignore)
"Warn that format is read-only."
(interactive)
(error "This format is read-only; specify another format for writing"))
;;;###autoload
-(defun iso-cvt-write-only (&rest ignore)
+(defun iso-cvt-write-only (&rest _ignore)
"Warn that format is write-only."
(interactive)
(error "This format is write-only"))
diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el
index 9f696c26856..2c7da2b7cdf 100644
--- a/lisp/international/iso-transl.el
+++ b/lisp/international/iso-transl.el
@@ -1,4 +1,4 @@
-;;; iso-transl.el --- keyboard input for ISO 10646 chars -*- coding: utf-8 -*-
+;;; iso-transl.el --- keyboard input for ISO 10646 chars -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1987, 1993-1999, 2001-2021 Free Software Foundation,
;; Inc.
@@ -30,22 +30,12 @@
;; A-umlaut as `C-x 8 " A' or `Alt-" A' (if you have an Alt key) or
;; `umlaut A' (if you have an umlaut/diaeresis key).
-;; C-x 8 is set up to autoload this package,
-;; but Alt keys and dead accent keys are only defined
-;; once you have loaded the package. It is nontrivial
-;; to make all of the Alt keys autoload, and it is not clear
-;; that the dead accent keys SHOULD autoload this package.
-
;; This package supports all characters defined by ISO 8859-1, along
;; with a few other ISO 10646 characters commonly used in English and
;; basic math.
;;; Code:
-;;; Provide some binding for startup:
-;;;###autoload (define-key key-translation-map "\C-x8" 'iso-transl-ctl-x-8-map)
-;;;###autoload (autoload 'iso-transl-ctl-x-8-map "iso-transl" "Keymap for C-x 8 prefix." t 'keymap)
-
(defvar iso-transl-dead-key-alist
'((?\' . mute-acute)
(?\` . mute-grave)
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index a5082f630c7..793508cae4a 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -1,4 +1,4 @@
-;;; ja-dic-cnv.el --- convert a Japanese dictionary (SKK-JISYO.L) to Emacs Lisp
+;;; ja-dic-cnv.el --- convert a Japanese dictionary (SKK-JISYO.L) to Emacs Lisp -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -48,7 +48,7 @@
(defvar ja-dic-filename "ja-dic.el")
(defun skkdic-convert-okuri-ari (skkbuf buf)
- (byte-compile-info-message "Processing OKURI-ARI entries")
+ (byte-compile-info "Processing OKURI-ARI entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting okuri-ari entries.\n"
@@ -96,8 +96,8 @@
("ã‚‚ã" "ç›®")
("ゆã" "行")))
-(defun skkdic-convert-postfix (skkbuf buf)
- (byte-compile-info-message "Processing POSTFIX entries")
+(defun skkdic-convert-postfix (_skkbuf buf)
+ (byte-compile-info "Processing POSTFIX entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting postfix entries.\n"
@@ -150,8 +150,8 @@
(defconst skkdic-prefix-list '(skkdic-prefix-list))
-(defun skkdic-convert-prefix (skkbuf buf)
- (byte-compile-info-message "Processing PREFIX entries")
+(defun skkdic-convert-prefix (_skkbuf buf)
+ (byte-compile-info "Processing PREFIX entries" t)
(goto-char (point-min))
(with-current-buffer buf
(insert ";; Setting prefix entries.\n"
@@ -209,7 +209,7 @@
(substring str from idx)
skkdic-word-list)))
(if (or (and (consp kana2-list)
- (let ((kana-len (length kana))
+ (let (;; (kana-len (length kana))
kana2)
(catch 'skkdic-tag
(while kana2-list
@@ -273,7 +273,7 @@
(defun skkdic-collect-okuri-nasi ()
(save-excursion
(let ((progress (make-progress-reporter
- (byte-compile-info-message "Collecting OKURI-NASI entries")
+ (byte-compile-info "Collecting OKURI-NASI entries" t)
(point) (point-max)
nil 10)))
(while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$"
@@ -301,7 +301,7 @@
"(skkdic-set-okuri-nasi\n")
(let ((l (nreverse skkdic-okuri-nasi-entries))
(progress (make-progress-reporter
- (byte-compile-info-message "Processing OKURI-NASI entries")
+ (byte-compile-info "Processing OKURI-NASI entries" t)
0 skkdic-okuri-nasi-entries-count
nil 10))
(count 0))
@@ -327,12 +327,12 @@
The format of the dictionary file should be the same as SKK dictionaries.
Saves the output as `ja-dic-filename', in directory DIRNAME (if specified)."
(interactive "FSKK dictionary file: ")
- (let* ((coding-system-for-read 'euc-japan)
- (skkbuf (get-buffer-create " *skkdic-unannotated*"))
+ (let* ((skkbuf (get-buffer-create " *skkdic-unannotated*"))
(buf (get-buffer-create "*skkdic-work*")))
;; Set skkbuf to an unannotated copy of the dictionary.
(with-current-buffer skkbuf
- (insert-file-contents (expand-file-name filename))
+ (let ((coding-system-for-read 'euc-japan))
+ (insert-file-contents (expand-file-name filename)))
(re-search-forward "^[^;]")
(while (re-search-forward ";[^\n/]*/" nil t)
(replace-match "/")))
@@ -340,7 +340,8 @@ Saves the output as `ja-dic-filename', in directory DIRNAME (if specified)."
(with-current-buffer buf
(erase-buffer)
(buffer-disable-undo)
- (insert ";;; ja-dic.el --- dictionary for Japanese input method\n"
+ (insert ";;; ja-dic.el --- dictionary for Japanese input method"
+ " -*- lexical-binding:t -*-\n"
";;\tGenerated by the command `skkdic-convert'\n"
";;\tOriginal SKK dictionary file: "
(file-relative-name (expand-file-name filename) dirname)
@@ -529,8 +530,7 @@ To get complete usage, invoke:
',(let ((l entries)
(map '(skdic-okuri-nasi))
(progress (make-progress-reporter
- (byte-compile-info-message
- "Extracting OKURI-NASI entries")
+ (byte-compile-info "Extracting OKURI-NASI entries")
0 (length entries)))
(count 0)
entry)
diff --git a/lisp/international/ja-dic-utl.el b/lisp/international/ja-dic-utl.el
index 498fb23f707..cc636986f99 100644
--- a/lisp/international/ja-dic-utl.el
+++ b/lisp/international/ja-dic-utl.el
@@ -1,4 +1,4 @@
-;;; ja-dic-utl.el --- utilities for handling Japanese dictionary (SKK-JISYO.L)
+;;; ja-dic-utl.el --- utilities for handling Japanese dictionary (SKK-JISYO.L) -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el
index 63147678519..05179a98ac2 100644
--- a/lisp/international/kinsoku.el
+++ b/lisp/international/kinsoku.el
@@ -1,4 +1,4 @@
-;;; kinsoku.el --- `Kinsoku' processing funcs
+;;; kinsoku.el --- `Kinsoku' processing funcs -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -182,4 +182,6 @@ the context of text formatting."
(aref (char-category-set (preceding-char)) ?<))
(kinsoku-shorter linebeg))))
+(provide 'kinsoku)
+
;;; kinsoku.el ends here
diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el
index 290f4fa0cf1..87f73897bf6 100644
--- a/lisp/international/kkc.el
+++ b/lisp/international/kkc.el
@@ -1,4 +1,4 @@
-;;; kkc.el --- Kana Kanji converter
+;;; kkc.el --- Kana Kanji converter -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/international/latexenc.el b/lisp/international/latexenc.el
index e2ee3fb37e3..ff7cddcb26e 100644
--- a/lisp/international/latexenc.el
+++ b/lisp/international/latexenc.el
@@ -1,4 +1,4 @@
-;;; latexenc.el --- guess correct coding system in LaTeX files -*-coding: utf-8 -*-
+;;; latexenc.el --- guess correct coding system in LaTeX files -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -109,6 +109,8 @@ Return nil if no matching input encoding can be found."
(defvar latexenc-dont-use-tex-guess-main-file-flag nil
"Non-nil means don't use tex-guessmain-file to find the coding system.")
+(defvar tex-start-of-header)
+
;;;###autoload
(defun latexenc-find-file-coding-system (arg-list)
"Determine the coding system of a LaTeX file if it uses \"inputenc.sty\".
diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el
index bda2c51ab9d..b3d6a635b1c 100644
--- a/lisp/international/latin1-disp.el
+++ b/lisp/international/latin1-disp.el
@@ -1,4 +1,4 @@
-;;; latin1-disp.el --- display tables for other ISO 8859 on Latin-1 terminals -*-coding: utf-8;-*-
+;;; latin1-disp.el --- display tables for other ISO 8859 on Latin-1 terminals -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -86,8 +86,8 @@ use either \\[customize] or the function `latin1-display'."
:group 'latin1-display
:type 'boolean
:require 'latin1-disp
- :initialize 'custom-initialize-default
- :set (lambda (symbol value)
+ :initialize #'custom-initialize-default
+ :set (lambda (_symbol value)
(if value
(apply #'latin1-display latin1-display-sets)
(latin1-display))))
@@ -186,8 +186,8 @@ character set."
'arabic-iso8859-6
(car (remq 'ascii (get-language-info language
'charset))))))
- (map-charset-chars #'(lambda (range arg)
- (standard-display-default (car range) (cdr range)))
+ (map-charset-chars (lambda (range _arg)
+ (standard-display-default (car range) (cdr range)))
charset))
(sit-for 0))
@@ -201,11 +201,10 @@ character set: `latin-2', `hebrew' etc."
(char (and info (decode-char (car (remq 'ascii info)) ?\ ))))
(and char (char-displayable-p char))))
-(defun latin1-display-setup (set &optional force)
+(defun latin1-display-setup (set &optional _force)
"Set up Latin-1 display for characters in the given SET.
SET must be a member of `latin1-display-sets'. Normally, check
-whether a font for SET is available and don't set the display if it
-is. If FORCE is non-nil, set up the display regardless."
+whether a font for SET is available and don't set the display if it is."
(cond
((eq set 'latin-2)
(latin1-display-identities set)
@@ -735,7 +734,7 @@ is. If FORCE is non-nil, set up the display regardless."
(sit-for 0))
;;;###autoload
-(defcustom latin1-display-ucs-per-lynx nil
+(defcustom latin1-display-ucs-per-lynx nil ;FIXME: Isn't this a minor mode?
"Set up Latin-1/ASCII display for Unicode characters.
This uses the transliterations of the Lynx browser. The display isn't
changed if the display can render Unicode characters.
@@ -745,8 +744,8 @@ use either \\[customize] or the function `latin1-display'."
:group 'latin1-display
:type 'boolean
:require 'latin1-disp
- :initialize 'custom-initialize-default
- :set (lambda (symbol value)
+ :initialize #'custom-initialize-default
+ :set (lambda (_symbol value)
(if value
(latin1-display-ucs-per-lynx 1)
(latin1-display-ucs-per-lynx -1))))
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 8c64a7bf441..55accf5beee 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -55,6 +55,7 @@
;; Keep "C-x C-m ..." for mule specific commands.
(define-key ctl-x-map "\C-m" mule-keymap)
+(define-key ctl-x-map "\\" 'activate-transient-input-method)
(defvar describe-language-environment-map
(let ((map (make-sparse-keymap "Describe Language Environment")))
@@ -139,8 +140,8 @@
`(menu-item "Set Coding Systems" ,set-coding-system-map))
(bindings--define-key map [separator-input-method] menu-bar-separator)
- (bindings--define-key map [describe-input-method]
- '(menu-item "Describe Input Method" describe-input-method))
+ (bindings--define-key map [activate-transient-input-method]
+ '(menu-item "Transient Input Method" activate-transient-input-method))
(bindings--define-key map [set-input-method]
'(menu-item "Select Input Method..." set-input-method))
(bindings--define-key map [toggle-input-method]
@@ -283,53 +284,57 @@ wrong, use this command again to toggle back to the right mode."
(interactive)
(view-file (expand-file-name "HELLO" data-directory)))
+(defvar mule-cmds--prefixed-command-next-coding-system nil)
+(defvar mule-cmds--prefixed-command-last-coding-system nil)
+
+(defun mule-cmds--prefixed-command-pch ()
+ (if (not mule-cmds--prefixed-command-next-coding-system)
+ (progn
+ (remove-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch)
+ (remove-hook 'prefix-command-echo-keystrokes-functions
+ #'mule-cmds--prefixed-command-echo)
+ (remove-hook 'prefix-command-preserve-state-hook
+ #'mule-cmds--prefixed-command-preserve))
+ (setq this-command
+ (let ((cmd this-command)
+ (coding-system mule-cmds--prefixed-command-next-coding-system))
+ (lambda ()
+ (interactive)
+ (setq this-command cmd)
+ (let ((coding-system-for-read coding-system)
+ (coding-system-for-write coding-system)
+ (coding-system-require-warning t))
+ (call-interactively cmd)))))
+ (setq mule-cmds--prefixed-command-last-coding-system
+ mule-cmds--prefixed-command-next-coding-system)
+ (setq mule-cmds--prefixed-command-next-coding-system nil)))
+
+(defun mule-cmds--prefixed-command-echo ()
+ (when mule-cmds--prefixed-command-next-coding-system
+ (format "With coding-system %S"
+ mule-cmds--prefixed-command-next-coding-system)))
+
+(defun mule-cmds--prefixed-command-preserve ()
+ (setq mule-cmds--prefixed-command-next-coding-system
+ mule-cmds--prefixed-command-last-coding-system))
+
(defun universal-coding-system-argument (coding-system)
- "Execute an I/O command using the specified coding system."
+ "Execute an I/O command using the specified CODING-SYSTEM."
(interactive
(let ((default (and buffer-file-coding-system
(not (eq (coding-system-type buffer-file-coding-system)
'undecided))
buffer-file-coding-system)))
(list (read-coding-system
- (if default
- (format "Coding system for following command (default %s): " default)
- "Coding system for following command: ")
+ (format-prompt "Coding system for following command" default)
default))))
- ;; FIXME: This "read-key-sequence + call-interactively" loop is trying to
- ;; reproduce the normal command loop, but this "can't" be done faithfully so
- ;; it necessarily suffers from breakage in corner cases (e.g. it fails to run
- ;; pre/post-command-hook, doesn't properly set this-command/last-command, it
- ;; doesn't handle keyboard macros, ...).
- (let* ((keyseq (read-key-sequence
- (format "Command to execute with %s:" coding-system)))
- (cmd (key-binding keyseq)))
- ;; read-key-sequence ignores quit, so make an explicit check.
- (if (equal last-input-event (nth 3 (current-input-mode)))
- (keyboard-quit))
- (when (memq cmd '(universal-argument digit-argument))
- (call-interactively cmd)
-
- ;; Process keys bound in `universal-argument-map'.
- (while (progn
- (setq keyseq (read-key-sequence nil t)
- cmd (key-binding keyseq t))
- (memq cmd '(negative-argument digit-argument
- universal-argument-more)))
- (setq current-prefix-arg prefix-arg prefix-arg nil)
- ;; Have to bind `last-command-event' here so that
- ;; `digit-argument', for instance, can compute the
- ;; `prefix-arg'.
- (setq last-command-event (aref keyseq 0))
- (call-interactively cmd)))
-
- (let ((coding-system-for-read coding-system)
- (coding-system-for-write coding-system)
- (coding-system-require-warning t))
- (setq current-prefix-arg prefix-arg prefix-arg nil)
- ;; Have to bind `last-command-event' e.g. for `self-insert-command'.
- (setq last-command-event (aref keyseq 0))
- (message "")
- (call-interactively cmd))))
+ (prefix-command-preserve-state)
+ (setq mule-cmds--prefixed-command-next-coding-system coding-system)
+ (add-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch)
+ (add-hook 'prefix-command-echo-keystrokes-functions
+ #'mule-cmds--prefixed-command-echo)
+ (add-hook 'prefix-command-preserve-state-hook
+ #'mule-cmds--prefixed-command-preserve))
(defun set-default-coding-systems (coding-system)
"Set default value of various coding systems to CODING-SYSTEM.
@@ -436,58 +441,57 @@ non-nil, it is used to sort CODINGS instead."
(most-preferred (car from-priority))
(lang-preferred (get-language-info current-language-environment
'coding-system))
- (func (function
- (lambda (x)
- (let ((base (coding-system-base x)))
- ;; We calculate the priority number 0..255 by
- ;; using the 8 bits PMMLCEII as this:
- ;; P: 1 if most preferred.
- ;; MM: greater than 0 if mime-charset.
- ;; L: 1 if one of the current lang. env.'s codings.
- ;; C: 1 if one of codings listed in the category list.
- ;; E: 1 if not XXX-with-esc
- ;; II: if iso-2022 based, 0..3, else 1.
- (logior
- (ash (if (eq base most-preferred) 1 0) 7)
- (ash
- (let ((mime (coding-system-get base :mime-charset)))
- ;; Prefer coding systems corresponding to a
- ;; MIME charset.
- (if mime
- ;; Lower utf-16 priority so that we
- ;; normally prefer utf-8 to it, and put
- ;; x-ctext below that.
- (cond ((string-match-p "utf-16"
- (symbol-name mime))
- 2)
- ((string-match-p "^x-" (symbol-name mime))
- 1)
- (t 3))
- 0))
- 5)
- (ash (if (memq base lang-preferred) 1 0) 4)
- (ash (if (memq base from-priority) 1 0) 3)
- (ash (if (string-match-p "-with-esc\\'"
- (symbol-name base))
- 0 1) 2)
- (if (eq (coding-system-type base) 'iso-2022)
- (let ((category (coding-system-category base)))
- ;; For ISO based coding systems, prefer
- ;; one that doesn't use designation nor
- ;; locking/single shifting.
- (cond
- ((or (eq category 'coding-category-iso-8-1)
- (eq category 'coding-category-iso-8-2))
- 2)
- ((or (eq category 'coding-category-iso-7-tight)
- (eq category 'coding-category-iso-7))
- 1)
- (t
- 0)))
- 1)
- ))))))
- (sort codings (function (lambda (x y)
- (> (funcall func x) (funcall func y))))))))
+ (func (lambda (x)
+ (let ((base (coding-system-base x)))
+ ;; We calculate the priority number 0..255 by
+ ;; using the 8 bits PMMLCEII as this:
+ ;; P: 1 if most preferred.
+ ;; MM: greater than 0 if mime-charset.
+ ;; L: 1 if one of the current lang. env.'s codings.
+ ;; C: 1 if one of codings listed in the category list.
+ ;; E: 1 if not XXX-with-esc
+ ;; II: if iso-2022 based, 0..3, else 1.
+ (logior
+ (ash (if (eq base most-preferred) 1 0) 7)
+ (ash
+ (let ((mime (coding-system-get base :mime-charset)))
+ ;; Prefer coding systems corresponding to a
+ ;; MIME charset.
+ (if mime
+ ;; Lower utf-16 priority so that we
+ ;; normally prefer utf-8 to it, and put
+ ;; x-ctext below that.
+ (cond ((string-match-p "utf-16"
+ (symbol-name mime))
+ 2)
+ ((string-match-p "^x-" (symbol-name mime))
+ 1)
+ (t 3))
+ 0))
+ 5)
+ (ash (if (memq base lang-preferred) 1 0) 4)
+ (ash (if (memq base from-priority) 1 0) 3)
+ (ash (if (string-match-p "-with-esc\\'"
+ (symbol-name base))
+ 0 1) 2)
+ (if (eq (coding-system-type base) 'iso-2022)
+ (let ((category (coding-system-category base)))
+ ;; For ISO based coding systems, prefer
+ ;; one that doesn't use designation nor
+ ;; locking/single shifting.
+ (cond
+ ((or (eq category 'coding-category-iso-8-1)
+ (eq category 'coding-category-iso-8-2))
+ 2)
+ ((or (eq category 'coding-category-iso-7-tight)
+ (eq category 'coding-category-iso-7))
+ 1)
+ (t
+ 0)))
+ 1)
+ )))))
+ (sort codings (lambda (x y)
+ (> (funcall func x) (funcall func y)))))))
(defun find-coding-systems-region (from to)
"Return a list of proper coding systems to encode a text between FROM and TO.
@@ -607,9 +611,8 @@ When called from a program, the value is the position of the unencodable
character found, or nil if all characters are encodable."
(interactive
(list (let ((default (or buffer-file-coding-system 'us-ascii)))
- (read-coding-system
- (format "Coding-system (default %s): " default)
- default))))
+ (read-coding-system (format-prompt "Coding-system" default)
+ default))))
(let ((pos (unencodable-char-position (point) (point-max) coding-system)))
(if pos
(goto-char (1+ pos))
@@ -676,18 +679,18 @@ DEFAULT is the coding system to use by default in the query."
;; ((CODING (POS . CHAR) (POS . CHAR) ...) ...)
(if unsafe
(setq unsafe
- (mapcar #'(lambda (coding)
- (cons coding
- (if (stringp from)
- (mapcar #'(lambda (pos)
- (cons pos (aref from pos)))
- (unencodable-char-position
- 0 (length from) coding
- 11 from))
- (mapcar #'(lambda (pos)
- (cons pos (char-after pos)))
- (unencodable-char-position
- from to coding 11)))))
+ (mapcar (lambda (coding)
+ (cons coding
+ (if (stringp from)
+ (mapcar (lambda (pos)
+ (cons pos (aref from pos)))
+ (unencodable-char-position
+ 0 (length from) coding
+ 11 from))
+ (mapcar (lambda (pos)
+ (cons pos (char-after pos)))
+ (unencodable-char-position
+ from to coding 11)))))
unsafe)))
(setq codings (sanitize-coding-system-list codings))
@@ -700,8 +703,8 @@ DEFAULT is the coding system to use by default in the query."
;; buffer is displayed.
(when (and unsafe (not (stringp from)))
(pop-to-buffer bufname)
- (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x)))
- unsafe))))
+ (goto-char (apply #'min (mapcar (lambda (x) (or (car (cadr x)) (point-max)))
+ unsafe))))
;; Then ask users to select one from CODINGS while showing
;; the reason why none of the defaults are not used.
(with-output-to-temp-buffer "*Warning*"
@@ -741,19 +744,19 @@ e.g., for sending an email message.\n ")
(insert (format " %s cannot encode these:" (car coding)))
(let ((i 0)
(func1
- #'(lambda (bufname pos)
- (when (buffer-live-p (get-buffer bufname))
- (pop-to-buffer bufname)
- (goto-char pos))))
+ (lambda (bufname pos)
+ (when (buffer-live-p (get-buffer bufname))
+ (pop-to-buffer bufname)
+ (goto-char pos))))
(func2
- #'(lambda (bufname pos coding)
- (when (buffer-live-p (get-buffer bufname))
- (pop-to-buffer bufname)
- (if (< (point) pos)
- (goto-char pos)
- (forward-char 1)
- (search-unencodable-char coding)
- (forward-char -1))))))
+ (lambda (bufname pos coding)
+ (when (buffer-live-p (get-buffer bufname))
+ (pop-to-buffer bufname)
+ (if (< (point) pos)
+ (goto-char pos)
+ (forward-char 1)
+ (search-unencodable-char coding)
+ (forward-char -1))))))
(dolist (elt (cdr coding))
(insert " ")
(if (stringp from)
@@ -798,9 +801,8 @@ or specify any other coding system (and risk losing\n\
;; Read a coding system.
(setq coding-system
- (read-coding-system
- (format "Select coding system (default %s): " default)
- default))
+ (read-coding-system (format-prompt "Select coding system" default)
+ default))
(setq last-coding-system-specified coding-system))
(kill-buffer "*Warning*")
@@ -885,7 +887,7 @@ It is highly recommended to fix it before writing to a file."
;; Change elements of the list to (coding . base-coding).
(setq default-coding-system
- (mapcar (function (lambda (x) (cons x (coding-system-base x))))
+ (mapcar (lambda (x) (cons x (coding-system-base x)))
default-coding-system))
(if (and auto-cs (not no-other-defaults))
@@ -1079,7 +1081,7 @@ it asks the user to select a proper coding system."
(if (fboundp select-safe-coding-system-function)
(funcall select-safe-coding-system-function
(point-min) (point-max) coding
- (function (lambda (x) (coding-system-get x :mime-charset))))
+ (lambda (x) (coding-system-get x :mime-charset)))
coding)))
;;; Language support stuff.
@@ -1258,7 +1260,7 @@ This returns a language environment name as a string."
(name (completing-read prompt
language-info-alist
(and key
- (function (lambda (elm) (and (listp elm) (assq key elm)))))
+ (lambda (elm) (and (listp elm) (assq key elm))))
t nil nil default)))
(if (and (> (length name) 0)
(or (not key)
@@ -1277,7 +1279,7 @@ in the format of Lisp expression for registering each input method.
Emacs loads this file at startup time.")
(defconst leim-list-header (format-message
-";;; %s -- list of LEIM (Library of Emacs Input Method) -*-coding: utf-8;-*-
+";;; %s --- list of LEIM (Library of Emacs Input Method) -*- lexical-binding:t -*-
;;
;; This file is automatically generated.
;;
@@ -1313,15 +1315,13 @@ Each function is called with one arg, LEIM directory name.")
(dolist (function update-leim-list-functions)
(apply function dirs)))
-(defvar current-input-method nil
+(defvar-local current-input-method nil
"The current input method for multilingual text.
If nil, that means no input method is activated now.")
-(make-variable-buffer-local 'current-input-method)
(put 'current-input-method 'permanent-local t)
-(defvar current-input-method-title nil
+(defvar-local current-input-method-title nil
"Title string of the current input method shown in mode line.")
-(make-variable-buffer-local 'current-input-method-title)
(put 'current-input-method-title 'permanent-local t)
(define-widget 'mule-input-method-string 'string
@@ -1342,33 +1342,51 @@ This is the input method activated automatically by the command
mule-input-method-string)
:set-after '(current-language-environment))
+(defcustom default-transient-input-method nil
+ "Default transient input method.
+This is the input method activated by the command
+`activate-transient-input-method' (\\[activate-transient-input-method])."
+ :link '(custom-manual "(emacs)Input Methods")
+ :group 'mule
+ :type '(choice (const nil)
+ mule-input-method-string)
+ :set-after '(current-language-environment)
+ :version "28.1")
+
+(defvar-local current-transient-input-method nil
+ "Current input method temporarily enabled by `activate-transient-input-method'.
+If nil, that means no transient input method is active now.")
+(put 'current-transient-input-method 'permanent-local t)
+
+(defvar-local previous-transient-input-method nil
+ "The input method that was active before enabling the transient input method.
+If nil, that means no previous input method was active.")
+(put 'previous-transient-input-method 'permanent-local t)
+
(put 'input-method-function 'permanent-local t)
-(defvar input-method-history nil
+(defvar-local input-method-history nil
"History list of input methods read from the minibuffer.
Maximum length of the history list is determined by the value
of `history-length', which see.")
-(make-variable-buffer-local 'input-method-history)
(put 'input-method-history 'permanent-local t)
(define-obsolete-variable-alias
'inactivate-current-input-method-function
'deactivate-current-input-method-function "24.3")
-(defvar deactivate-current-input-method-function nil
+(defvar-local deactivate-current-input-method-function nil
"Function to call for deactivating the current input method.
Every input method should set this to an appropriate value when activated.
This function is called with no argument.
This function should never change the value of `current-input-method'.
It is set to nil by the function `deactivate-input-method'.")
-(make-variable-buffer-local 'deactivate-current-input-method-function)
(put 'deactivate-current-input-method-function 'permanent-local t)
-(defvar describe-current-input-method-function nil
+(defvar-local describe-current-input-method-function nil
"Function to call for describing the current input method.
This function is called with no argument.")
-(make-variable-buffer-local 'describe-current-input-method-function)
(put 'describe-current-input-method-function 'permanent-local t)
(defvar input-method-alist nil
@@ -1402,13 +1420,13 @@ The commands `describe-input-method' and `list-input-methods' need
these duplicated values to show some information about input methods
without loading the relevant Quail packages.
\n(fn INPUT-METHOD LANG-ENV ACTIVATE-FUNC TITLE DESCRIPTION &rest ARGS)"
- (if (symbolp lang-env)
- (setq lang-env (symbol-name lang-env))
- (setq lang-env (purecopy lang-env)))
- (if (symbolp input-method)
- (setq input-method (symbol-name input-method))
- (setq input-method (purecopy input-method)))
- (setq args (mapcar 'purecopy args))
+ (setq lang-env (if (symbolp lang-env)
+ (symbol-name lang-env)
+ (purecopy lang-env)))
+ (setq input-method (if (symbolp input-method)
+ (symbol-name input-method)
+ (purecopy input-method)))
+ (setq args (mapcar #'purecopy args))
(let ((info (cons lang-env args))
(slot (assoc input-method input-method-alist)))
(if slot
@@ -1476,7 +1494,8 @@ If INPUT-METHOD is nil, deactivate any current input method."
(defun deactivate-input-method ()
"Turn off the current input method."
(when current-input-method
- (add-to-history 'input-method-history current-input-method)
+ (unless current-transient-input-method
+ (add-to-history 'input-method-history current-input-method))
(unwind-protect
(progn
(setq input-method-function nil
@@ -1505,7 +1524,7 @@ To deactivate it programmatically, use `deactivate-input-method'."
(interactive
(let* ((default (or (car input-method-history) default-input-method)))
(list (read-input-method-name
- (if default "Select input method (default %s): " "Select input method: ")
+ (format-prompt "Select input method" default)
default t)
t)))
(activate-input-method input-method)
@@ -1538,7 +1557,9 @@ which marks the variable `default-input-method' as set for Custom buffers."
(if toggle-input-method-active
(error "Recursive use of `toggle-input-method'"))
(if (and current-input-method (not arg))
- (deactivate-input-method)
+ (if current-transient-input-method
+ (deactivate-transient-input-method)
+ (deactivate-input-method))
(let ((toggle-input-method-active t)
(default (or (car input-method-history) default-input-method)))
(if (and arg default (equal current-input-method default)
@@ -1548,7 +1569,7 @@ which marks the variable `default-input-method' as set for Custom buffers."
(if (or arg (not default))
(progn
(read-input-method-name
- (if default "Input method (default %s): " "Input method: " )
+ (format-prompt "Input method" default)
default t))
default))
(unless default-input-method
@@ -1557,13 +1578,49 @@ which marks the variable `default-input-method' as set for Custom buffers."
(when interactive
(customize-mark-as-set 'default-input-method)))))))
+(defun activate-transient-input-method (&optional arg interactive)
+ "Select and enable a transient input method for the current buffer.
+If `default-transient-input-method' was not yet defined, prompt for it."
+ (interactive "P\np")
+ (when (or arg (not default-transient-input-method))
+ (let* ((default (or (car input-method-history) default-input-method))
+ (input-method
+ (read-input-method-name
+ (format-prompt "Transient input method" default)
+ default t)))
+ (setq default-transient-input-method input-method)
+ (when interactive
+ (customize-mark-as-set 'default-transient-input-method))))
+ (let* ((clearfun (make-symbol "clear-transient-input-method"))
+ (exitfun
+ (lambda ()
+ (deactivate-transient-input-method)
+ (remove-hook 'input-method-after-insert-chunk-hook clearfun))))
+ (fset clearfun (lambda () (funcall exitfun)))
+ (add-hook 'input-method-after-insert-chunk-hook clearfun)
+ (setq previous-transient-input-method current-input-method)
+ (when previous-transient-input-method
+ (deactivate-input-method))
+ (activate-input-method default-transient-input-method)
+ (setq current-transient-input-method default-transient-input-method)
+ exitfun))
+
+(defun deactivate-transient-input-method ()
+ "Disable currently active transient input method for the current buffer."
+ (when current-transient-input-method
+ (deactivate-input-method)
+ (when previous-transient-input-method
+ (activate-input-method previous-transient-input-method)
+ (setq previous-transient-input-method nil))
+ (setq current-transient-input-method nil)))
+
(autoload 'help-buffer "help-mode")
(defun describe-input-method (input-method)
"Describe input method INPUT-METHOD."
(interactive
(list (read-input-method-name
- "Describe input method (default current choice): ")))
+ (format-prompt "Describe input method" current-input-method))))
(if (and input-method (symbolp input-method))
(setq input-method (symbol-name input-method)))
(help-setup-xref (list #'describe-input-method
@@ -1797,13 +1854,11 @@ The default status is as follows:
'raw-text)
(set-default-coding-systems nil)
- (setq default-sendmail-coding-system 'iso-latin-1)
- ;; On Darwin systems, this should be utf-8-unix, but when this file is loaded
- ;; that is not yet defined, so we set it in set-locale-environment instead.
- ;; [Actually, it seems to work fine to use utf-8-unix here, and not just
- ;; on Darwin. The previous comment seems to be outdated?
- ;; See patch at https://debbugs.gnu.org/15803 ]
- (setq default-file-name-coding-system 'iso-latin-1-unix)
+ (setq default-sendmail-coding-system 'utf-8)
+ (setq default-file-name-coding-system (if (memq system-type
+ '(window-nt ms-dos))
+ 'iso-latin-1-unix
+ 'utf-8-unix))
;; Preserve eol-type from existing default-process-coding-systems.
;; On non-unix-like systems in particular, these may have been set
;; carefully by the user, or by the startup code, to deal with the
@@ -1819,8 +1874,10 @@ The default status is as follows:
(input-coding
(condition-case nil
(coding-system-change-text-conversion
- (cdr default-process-coding-system) 'iso-latin-1)
- (coding-system-error 'iso-latin-1))))
+ (cdr default-process-coding-system)
+ (if (memq system-type '(window-nt ms-dos)) 'iso-latin-1 'utf-8))
+ (coding-system-error
+ (if (memq system-type '(window-nt ms-dos)) 'iso-latin-1 'utf-8)))))
(setq default-process-coding-system
(cons output-coding input-coding)))
@@ -1872,7 +1929,7 @@ runs the hook `exit-language-environment-hook'. After setting up
the new language environment, it runs `set-language-environment-hook'."
(interactive (list (read-language-name
nil
- "Set language environment (default English): ")))
+ (format-prompt "Set language environment" "English"))))
(if language-name
(if (symbolp language-name)
(setq language-name (symbol-name language-name)))
@@ -2064,12 +2121,6 @@ See `set-language-info-alist' for use in programs."
"Do various unibyte-mode setups for language environment LANGUAGE-NAME."
(set-display-table-and-terminal-coding-system language-name))
-(defun princ-list (&rest args)
- "Print all arguments with `princ', then print \"\\n\"."
- (declare (obsolete "use mapc and princ instead." "23.3"))
- (mapc #'princ args)
- (princ "\n"))
-
(put 'describe-specified-language-support 'apropos-inhibit t)
;; Print language-specific information such as input methods,
@@ -2093,7 +2144,7 @@ See `set-language-info-alist' for use in programs."
(interactive
(list (read-language-name
'documentation
- "Describe language environment (default current choice): ")))
+ (format-prompt "Describe language environment" current-language-environment))))
(if (null language-name)
(setq language-name current-language-environment))
(if (or (null language-name)
@@ -2194,7 +2245,7 @@ See `set-language-info-alist' for use in programs."
;; LANGUAGE is a language code taken from ISO 639:1988 (E/F)
;; with additions from ISO 639/RA Newsletter No.1/1989;
;; see Internet RFC 2165 (1997-06) and
- ;; http://www.evertype.com/standards/iso639/iso639-en.html
+ ;; https://www.evertype.com/standards/iso639/iso639-en.html
;; TERRITORY is a country code taken from ISO 3166
;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html.
;; CODESET and MODIFIER are implementation-dependent.
@@ -2906,24 +2957,28 @@ STR should be a unibyte string."
(mapconcat
(if (and coding-system (eq (coding-system-type coding-system) 'iso-2022))
;; Try to get a pretty description for ISO 2022 escape sequences.
- (function (lambda (x) (or (cdr (assq x iso-2022-control-alist))
- (format "#x%02X" x))))
- (function (lambda (x) (format "#x%02X" x))))
+ (lambda (x) (or (cdr (assq x iso-2022-control-alist))
+ (format "#x%02X" x)))
+ (lambda (x) (format "#x%02X" x)))
str " "))
(defun encode-coding-char (char coding-system &optional charset)
- "Encode CHAR by CODING-SYSTEM and return the resulting string.
+ "Encode CHAR by CODING-SYSTEM and return the resulting string of bytes.
If CODING-SYSTEM can't safely encode CHAR, return nil.
The 3rd optional argument CHARSET, if non-nil, is a charset preferred
on encoding."
(let* ((str1 (string char))
(str2 (string char char))
(found (find-coding-systems-string str1))
- enc1 enc2 i1 i2)
- (if (eq (car-safe found) 'undecided) ;Aka (not (multibyte-string-p str1))
- ;; `char' is ASCII.
+ (bom-p (coding-system-get coding-system :bom))
+ enc1 enc2 i0 i1 i2)
+ ;; If CHAR is ASCII and CODING-SYSTEM doesn't prepend a BOM, just
+ ;; encode CHAR.
+ (if (and (eq (car-safe found) 'undecided)
+ (null bom-p))
(encode-coding-string str1 coding-system)
- (when (memq (coding-system-base coding-system) found)
+ (when (or (eq (car-safe found) 'undecided)
+ (memq (coding-system-base coding-system) found))
;; We must find the encoded string of CHAR. But, just encoding
;; CHAR will put extra control sequences (usually to designate
;; ASCII charset) at the tail if type of CODING is ISO 2022.
@@ -2944,7 +2999,19 @@ on encoding."
;; Now (substring enc1 i1) and (substring enc2 i2) are the same,
;; and they are the extra control sequences at the tail to
;; exclude.
- (substring enc2 0 i2)))))
+
+ ;; We also need to exclude the leading 2 or 3 bytes if they
+ ;; come from a BOM.
+ (setq i0
+ (if bom-p
+ (cond
+ ((eq (coding-system-type coding-system) 'utf-8)
+ 3)
+ ((eq (coding-system-type coding-system) 'utf-16)
+ 2)
+ (t 0))
+ 0))
+ (substring enc2 i0 i2)))))
;; Backwards compatibility. These might be better with :init-value t,
;; but that breaks loadup.
@@ -2962,11 +3029,6 @@ on encoding."
;; Doc said "obsolete" in 23.1, this statement only added in 24.1.
(make-obsolete 'unify-8859-on-decoding-mode "don't use it." "23.1")
-(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
"Hash table of cached CHAR-NAME keys to CHAR-CODE values.")
@@ -3001,7 +3063,7 @@ on encoding."
(#x1D000 . #x1FFFF)
;; (#x20000 . #xDFFFF) CJK Ideograph Extension A, B, etc, unused
(#xE0000 . #xE01FF)))
- (gc-cons-threshold 10000000)
+ (gc-cons-threshold (max gc-cons-threshold 10000000))
(names (make-hash-table :size 42943 :test #'equal)))
(dolist (range ranges)
(let ((c (car range))
@@ -3015,6 +3077,15 @@ on encoding."
;; higher code, so it gets pushed later!
(if new-name (puthash new-name c names))
(if old-name (puthash old-name c names))
+ ;; Unicode uses the spelling "lamda" in character
+ ;; names, instead of "lambda", due to "preferences
+ ;; expressed by the Greek National Body" (Bug#30513).
+ ;; Some characters have an old-name with the "lambda"
+ ;; spelling, but others don't. Add the traditional
+ ;; spelling for more convenient completion.
+ (when (and (not old-name) new-name
+ (string-match "\\<LAMDA\\>" new-name))
+ (puthash (replace-match "LAMBDA" t t new-name) c names))
(setq c (1+ c))))))
;; Special case for "BELL" which is apparently the only char which
;; doesn't have a new name and whose old-name is shadowed by a newer
@@ -3022,13 +3093,23 @@ on encoding."
(puthash "BELL (BEL)" ?\a names)
(setq ucs-names names))))
-(defun mule--ucs-names-annotation (name)
- ;; FIXME: It would be much better to add this annotation before rather than
- ;; after the char name, so the annotations are aligned.
- ;; FIXME: The default behavior of displaying annotations in italics
- ;; doesn't work well here.
- (let ((char (gethash name ucs-names)))
- (when char (format " (%c)" char))))
+(defun mule--ucs-names-sort-by-code (names)
+ (let ((codes-and-names
+ (mapcar (lambda (name) (cons (gethash name ucs-names) name)) names)))
+ (mapcar #'cdr (sort codes-and-names #'car-less-than-car))))
+
+(defun mule--ucs-names-affixation (names)
+ (mapcar (lambda (name)
+ (let ((char (gethash name ucs-names)))
+ (list name (concat (if char (list char) " ") "\t") "")))
+ names))
+
+(defun mule--ucs-names-group (name transform)
+ (if transform
+ name
+ (let* ((char (gethash name ucs-names))
+ (script (and char (aref char-script-table char))))
+ (if script (symbol-name script) "ungrouped"))))
(defun char-from-name (string &optional ignore-case)
"Return a character as a number from its Unicode name STRING.
@@ -3051,6 +3132,15 @@ Return nil if STRING does not name a character."
ignore-case))
code)))))))
+(defcustom read-char-by-name-sort nil
+ "How to sort characters for `read-char-by-name' completion.
+Defines the sorting order either by character names or their codepoints."
+ :type '(choice
+ (const :tag "Sort by character names" nil)
+ (const :tag "Sort by character codepoints" code))
+ :group 'mule
+ :version "28.1")
+
(defun read-char-by-name (prompt)
"Read a character by its Unicode name or hex number string.
Display PROMPT and read a string that represents a character by its
@@ -3064,6 +3154,10 @@ preceded by an asterisk `*' and use completion, it will show all
the characters whose names include that substring, not necessarily
at the beginning of the name.
+The options `read-char-by-name-sort', `completions-group', and
+`completions-group-sort' define the sorting order of completion characters,
+whether to group them, and how to sort groups.
+
Accept a name like \"CIRCULATION FUNCTION\", a hexadecimal
number like \"2A10\", or a number in hash notation (e.g.,
\"#x2a10\" for hex, \"10r10768\" for decimal, or \"#o25020\" for
@@ -3071,13 +3165,21 @@ octal). Treat otherwise-ambiguous strings like \"BED\" (U+1F6CF)
as names, not numbers."
(let* ((enable-recursive-minibuffers t)
(completion-ignore-case t)
+ (completion-tab-width 4)
(input
(completing-read
prompt
(lambda (string pred action)
(if (eq action 'metadata)
- '(metadata
- (annotation-function . mule--ucs-names-annotation)
+ `(metadata
+ (display-sort-function
+ . ,(when (eq read-char-by-name-sort 'code)
+ #'mule--ucs-names-sort-by-code))
+ (affixation-function
+ . ,#'mule--ucs-names-affixation)
+ (group-function
+ . ,(when completions-group
+ #'mule--ucs-names-group))
(category . unicode-name))
(complete-with-action action (ucs-names) string pred)))))
(char
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index c787c9b1ddf..2d36dab6320 100644
--- a/lisp/international/mule-conf.el
+++ b/lisp/international/mule-conf.el
@@ -1,4 +1,4 @@
-;;; mule-conf.el --- configure multilingual environment
+;;; mule-conf.el --- configure multilingual environment -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
@@ -39,9 +39,9 @@
;; Society of Japan/Information Technology Standards Commission of
;; Japan (IPSJ/ITSCJ) at https://www.itscj.ipsj.or.jp/itscj_english/.
;; Standards docs equivalent to iso-2022 and iso-8859 are at
-;; http://www.ecma.ch/.
+;; https://www.ecma.ch/.
-;; FWIW, http://www.microsoft.com/globaldev/ lists the following for
+;; FWIW, https://www.microsoft.com/globaldev/ lists the following for
;; MS Windows, which are presumably the only charsets we really need
;; to worry about on such systems:
;; `OEM codepages': 437, 720, 737, 775, 850, 852, 855, 857, 858, 862, 866
@@ -358,7 +358,7 @@
:code-offset #x130000
:unify-map "BIG5")
;; Fixme: AKA cp950 according to
-;; <URL:http://www.microsoft.com/globaldev/reference/WinCP.asp>. Is
+;; <URL:https://www.microsoft.com/globaldev/reference/WinCP.asp>. Is
;; that correct?
(define-charset 'chinese-big5-1
@@ -708,7 +708,7 @@
;; Original name for cp1125, says Serhii Hlodin <hlodin@lutsk.bank.gov.ua>
(define-charset-alias 'cp866u 'cp1125)
-;; Fixme: C.f. iconv, http://czyborra.com/charsets/codepages.html
+;; Fixme: C.f. iconv, https://czyborra.com/charsets/codepages.html
;; shows this as not ASCII compatible, with various graphics in
;; 0x01-0x1F.
(define-charset 'cp437
@@ -1075,6 +1075,90 @@
(define-charset-alias 'ebcdic-int 'ibm038)
(define-charset-alias 'cp038 'ibm038)
+(define-charset 'ibm256
+ "Netherlands version of EBCDIC"
+ :short-name "IBM256"
+ :code-space [0 255]
+ :mime-charset 'ibm256
+ :map "IBM256")
+
+(define-charset 'ibm273
+ "Austrian / German version of EBCDIC"
+ :short-name "IBM273"
+ :code-space [0 255]
+ :mime-charset 'ibm273
+ :map "IBM273")
+
+(define-charset 'ibm274
+ "Belgian version of EBCDIC"
+ :short-name "IBM274"
+ :code-space [0 255]
+ :mime-charset 'ibm274
+ :map "IBM274")
+
+(define-charset 'ibm275
+ "Brazilian version of EBCDIC"
+ :short-name "IBM275"
+ :code-space [0 255]
+ :mime-charset 'ibm275
+ :map "IBM275")
+
+(define-charset 'ibm277
+ "Danish / Norwegian version of EBCDIC"
+ :short-name "IBM277"
+ :code-space [0 255]
+ :mime-charset 'ibm277
+ :map "IBM277")
+
+(define-charset 'ibm278
+ "Finnish / Swedish version of EBCDIC"
+ :short-name "IBM278"
+ :code-space [0 255]
+ :mime-charset 'ibm278
+ :map "IBM278")
+
+(define-charset 'ibm280
+ "Italian version of EBCDIC"
+ :short-name "IBM280"
+ :code-space [0 255]
+ :mime-charset 'ibm270
+ :map "IBM280")
+
+(define-charset 'ibm281
+ "Japanese-E version of EBCDIC"
+ :short-name "IBM281"
+ :code-space [0 255]
+ :mime-charset 'ibm281
+ :map "IBM281")
+
+(define-charset 'ibm284
+ "Spanish version of EBCDIC"
+ :short-name "IBM284"
+ :code-space [0 255]
+ :mime-charset 'ibm284
+ :map "IBM284")
+
+(define-charset 'ibm285
+ "UK english version of EBCDIC"
+ :short-name "IBM285"
+ :code-space [0 255]
+ :mime-charset 'ibm285
+ :map "IBM285")
+
+(define-charset 'ibm290
+ "Japanese katakana version of EBCDIC"
+ :short-name "IBM290"
+ :code-space [0 255]
+ :mime-charset 'ibm290
+ :map "IBM290")
+
+(define-charset 'ibm297
+ "French version of EBCDIC"
+ :short-name "IBM297"
+ :code-space [0 255]
+ :mime-charset 'ibm297
+ :map "IBM297")
+
(define-charset 'ibm1047
;; Says groff:
"IBM1047, `EBCDIC Latin 1/Open Systems' used by OS/390 Unix."
@@ -1251,7 +1335,9 @@ by UTF-8."
:coding-type 'undecided
:mnemonic ?-
:charset-list '(emacs)
- :prefer-utf-8 t)
+ :prefer-utf-8 t
+ :inhibit-null-byte-detection 0
+ :inhibit-iso-escape-detection 0)
(define-coding-system 'raw-text
"Raw text, which means text contains random 8-bit codes.
@@ -1508,6 +1594,7 @@ for decoding and encoding files, process I/O, etc."
:mime-charset 'us-ascii)
(define-coding-system-alias 'iso-safe 'us-ascii)
+(define-coding-system-alias 'ascii 'us-ascii)
(define-coding-system 'utf-7
"UTF-7 encoding of Unicode (RFC 2152)."
@@ -1517,6 +1604,10 @@ for decoding and encoding files, process I/O, etc."
:charset-list '(unicode)
:pre-write-conversion 'utf-7-pre-write-conversion
:post-read-conversion 'utf-7-post-read-conversion)
+;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p,
+;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII
+;; compatible, so we override that here (bug#40407).
+(coding-system-put 'utf-7 :ascii-compatible-p nil)
(define-coding-system 'utf-7-imap
"UTF-7 encoding of Unicode, IMAP version (RFC 2060)"
@@ -1525,6 +1616,8 @@ for decoding and encoding files, process I/O, etc."
:charset-list '(unicode)
:pre-write-conversion 'utf-7-imap-pre-write-conversion
:post-read-conversion 'utf-7-imap-post-read-conversion)
+;; See comment for utf-7 above.
+(coding-system-put 'utf-7-imap :ascii-compatible-p nil)
;; Use us-ascii for terminal output if some other coding system is not
;; specified explicitly.
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index 1a21453e2c1..2d3cd25b4a4 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -1,4 +1,4 @@
-;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
+;;; mule-diag.el --- show diagnosis of multilingual environment (Mule) -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -45,8 +45,8 @@
(define-button-type 'sort-listed-character-sets
'help-echo (purecopy "mouse-2, RET: sort on this column")
'face 'bold
- 'action #'(lambda (button)
- (sort-listed-character-sets (button-get button 'sort-key))))
+ 'action (lambda (button)
+ (sort-listed-character-sets (button-get button 'sort-key))))
(define-button-type 'list-charset-chars
:supertype 'help-xref
@@ -86,8 +86,7 @@ but still shows the full information."
(indent-to 48)
(insert "| +--CHARS\n")
(let ((columns '(("CHARSET-NAME" . name) "\t\t\t\t\t"
- ("D CH FINAL-BYTE" . iso-spec)))
- pos)
+ ("D CH FINAL-BYTE" . iso-spec))))
(while columns
(if (stringp (car columns))
(insert (car columns))
@@ -117,8 +116,8 @@ but still shows the full information."
SORT-KEY should be `name' or `iso-spec' (default `name')."
(or sort-key
(setq sort-key 'name))
- (let ((tail charset-list)
- charset-info-list supplementary-list charset sort-func)
+ (let (;; (tail charset-list)
+ charset-info-list supplementary-list sort-func)
(dolist (charset charset-list)
;; Generate a list that contains all information to display.
(let ((elt (list charset
@@ -136,13 +135,12 @@ SORT-KEY should be `name' or `iso-spec' (default `name')."
((eq sort-key 'iso-spec)
;; Sort by DIMENSION CHARS FINAL-CHAR
- (function
- (lambda (x y)
- (or (< (nth 1 x) (nth 1 y))
- (and (= (nth 1 x) (nth 1 y))
- (or (< (nth 2 x) (nth 2 y))
- (and (= (nth 2 x) (nth 2 y))
- (< (nth 3 x) (nth 3 y)))))))))
+ (lambda (x y)
+ (or (< (nth 1 x) (nth 1 y))
+ (and (= (nth 1 x) (nth 1 y))
+ (or (< (nth 2 x) (nth 2 y))
+ (and (= (nth 2 x) (nth 2 y))
+ (< (nth 3 x) (nth 3 y))))))))
(t
(error "Invalid charset sort key: %s" sort-key))))
@@ -200,10 +198,6 @@ Character sets for defining other charsets, or for backward compatibility
;;; (charset-iso-graphic-plane charset)
(charset-description charset)))))
-(defvar non-iso-charset-alist nil
- "Obsolete.")
-(make-obsolete-variable 'non-iso-charset-alist "no longer relevant." "23.1")
-
;; A variable to hold charset input history.
(defvar charset-history nil)
@@ -278,9 +272,9 @@ meanings of these arguments."
(setq tab-width 4)
(set-buffer-multibyte t)
(let ((dim (charset-dimension charset))
- (chars (charset-chars charset))
- ;; (plane (charset-iso-graphic-plane charset))
- (plane 1)
+ ;; (chars (charset-chars charset))
+ ;; (plane (charset-iso-graphic-plane charset))
+ ;; (plane 1)
(range (plist-get (charset-plist charset) :code-space))
min max min2 max2)
(if (> dim 2)
@@ -420,7 +414,8 @@ or provided just for backward compatibility." nil)))
(print-coding-system-briefly coding-system 'doc-string)
(let ((type (coding-system-type coding-system))
;; Fixme: use this
- (extra-spec (coding-system-plist coding-system)))
+ ;; (extra-spec (coding-system-plist coding-system))
+ )
(princ "Type: ")
(princ type)
(cond ((eq type 'undecided)
@@ -840,6 +835,8 @@ The IGNORED argument is ignored."
(list (completing-read
"Font name (default current choice for ASCII chars): "
(and window-system
+ ;; Implied by `window-system'.
+ (fboundp 'x-list-fonts)
(fboundp 'fontset-list)
;; The final element in `fontset-list' is a default
;; (generic) one, so don't include that.
@@ -863,6 +860,8 @@ The IGNORED argument is ignored."
(with-output-to-temp-buffer "*Help*"
(describe-font-internal font-info)))))
+(defvar mule--print-opened)
+
(defun print-fontset-element (val)
;; VAL has this format:
;; ((REQUESTED-FONT-NAME OPENED-FONT-NAME ...) ...)
@@ -920,7 +919,7 @@ The IGNORED argument is ignored."
(or adstyle "*") registry)))))
;; Insert opened font names (if any).
- (if (and (boundp 'print-opened) (symbol-value 'print-opened))
+ (if (bound-and-true-p mule--print-opened)
(dolist (opened (cdr elt))
(insert "\n\t[" opened "]")))))))
@@ -948,8 +947,9 @@ the current buffer."
" and [" (propertize "OPENED" 'face 'underline) "])")
(let* ((info (fontset-info fontset))
(default-info (char-table-extra-slot info 0))
+ (mule--print-opened print-opened)
start1 end1 start2 end2)
- (describe-vector info 'print-fontset-element)
+ (describe-vector info #'print-fontset-element)
(when (char-table-range info nil)
;; The default of FONTSET is described.
(setq start1 (re-search-backward "^default"))
@@ -961,7 +961,7 @@ the current buffer."
(when default-info
(insert "\n ---<fallback to the default fontset>---")
(put-text-property (line-beginning-position) (point) 'face 'highlight)
- (describe-vector default-info 'print-fontset-element)
+ (describe-vector default-info #'print-fontset-element)
(when (char-table-range default-info nil)
;; The default of the default fontset is described.
(setq end2 (re-search-backward "^default"))
@@ -1172,12 +1172,12 @@ The default is 20. If LIMIT is negative, do not limit the listing."
(if (or (vectorp elt) (listp elt))
(let ((i 0))
(catch 'tag
- (mapc #'(lambda (x)
- (setq i (1+ i))
- (when (= i limit)
- (insert " ...\n")
- (throw 'tag nil))
- (insert (format " %s\n" x)))
+ (mapc (lambda (x)
+ (setq i (1+ i))
+ (when (= i limit)
+ (insert " ...\n")
+ (throw 'tag nil))
+ (insert (format " %s\n" x)))
elt)))
(insert (format " %s\n" elt)))))))
diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index e5759d9724d..55449599fe9 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -44,9 +44,22 @@
(setq i (1+ i)))))
string)
-(defvar truncate-string-ellipsis "..." ;"…"
+(defvar truncate-string-ellipsis nil
"String to use to indicate truncation.
-Serves as default value of ELLIPSIS argument to `truncate-string-to-width'.")
+Serves as default value of ELLIPSIS argument to `truncate-string-to-width'
+returned by the function `truncate-string-ellipsis'.")
+
+(defun truncate-string-ellipsis ()
+ "Return the string used to indicate truncation.
+Use the value of the variable `truncate-string-ellipsis' when it's non-nil.
+Otherwise, return the Unicode character U+2026 \"HORIZONTAL ELLIPSIS\"
+when it's displayable on the selected frame, or `...'. This function
+needs to be called on every use of `truncate-string-to-width' to
+decide whether the selected frame can display that Unicode character."
+ (cond
+ (truncate-string-ellipsis)
+ ((char-displayable-p ?…) "…")
+ ("...")))
;;;###autoload
(defun truncate-string-to-width (str end-column
@@ -73,7 +86,7 @@ If ELLIPSIS is non-nil, it should be a string which will replace the
end of STR (including any padding) if it extends beyond END-COLUMN,
unless the display width of STR is equal to or less than the display
width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
-defaults to `truncate-string-ellipsis'.
+defaults to `truncate-string-ellipsis', or to three dots when it's nil.
If ELLIPSIS-TEXT-PROPERTY is non-nil, a too-long string will not
be truncated, but instead the elided parts will be covered by a
@@ -81,7 +94,7 @@ be truncated, but instead the elided parts will be covered by a
(or start-column
(setq start-column 0))
(when (and ellipsis (not (stringp ellipsis)))
- (setq ellipsis truncate-string-ellipsis))
+ (setq ellipsis (truncate-string-ellipsis)))
(let ((str-len (length str))
(str-width (string-width str))
(ellipsis-width (if ellipsis (string-width ellipsis) 0))
@@ -265,23 +278,13 @@ Optional 5th argument NIL-FOR-TOO-LONG non-nil means return nil
CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'.
This affects the implicit sorting of lists of coding systems returned by
operations such as `find-coding-systems-region'."
+ (declare (indent 1) (debug t))
(let ((current (make-symbol "current")))
`(let ((,current (coding-system-priority-list)))
(apply #'set-coding-system-priority ,coding-systems)
(unwind-protect
(progn ,@body)
(apply #'set-coding-system-priority ,current)))))
-;;;###autoload(put 'with-coding-priority 'lisp-indent-function 1)
-(put 'with-coding-priority 'edebug-form-spec t)
-
-;;;###autoload
-(defmacro detect-coding-with-priority (from to priority-list)
- "Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
-PRIORITY-LIST is an alist of coding categories vs the corresponding
-coding systems ordered by priority."
- (declare (obsolete with-coding-priority "23.1"))
- `(with-coding-priority (mapcar #'cdr ,priority-list)
- (detect-coding-region ,from ,to)))
;;;###autoload
(defun detect-coding-with-language-environment (from to lang-env)
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index fe26e8303fb..9cd38afd8be 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -1,4 +1,4 @@
-;;; mule.el --- basic commands for multilingual environment
+;;; mule.el --- basic commands for multilingual environment -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -30,12 +30,13 @@
;;; Code:
-;; FIXME? Are these still relevant? Nothing uses them AFAICS.
(defconst mule-version "6.0 (HANACHIRUSATO)" "\
Version number and name of this version of MULE (multilingual environment).")
+(make-obsolete-variable 'mule-version 'emacs-version "28.1")
(defconst mule-version-date "2003.9.1" "\
Distribution date of this version of MULE (multilingual environment).")
+(make-obsolete-variable 'mule-version-date nil "28.1")
;;; CHARSET
@@ -306,12 +307,9 @@ Return t if file exists."
(and (null noerror)
(signal 'file-error (list "Cannot open load file" file)))
;; Read file with code conversion, and then eval.
- (let* ((buffer
- ;; We can't use `generate-new-buffer' because files.el
- ;; is not yet loaded.
- (get-buffer-create (generate-new-buffer-name " *load*")))
- (load-in-progress t)
- (source (save-match-data (string-match "\\.el\\'" fullname))))
+ (let ((buffer (generate-new-buffer " *load*"))
+ (load-in-progress t)
+ (source (string-suffix-p ".el" fullname)))
(unless nomessage
(if source
(message "Loading %s (source)..." file)
@@ -319,8 +317,9 @@ Return t if file exists."
(when purify-flag
(push (purecopy file) preloaded-file-list))
(unwind-protect
- (let ((load-file-name fullname)
- (set-auto-coding-for-load t)
+ (let ((load-true-file-name fullname)
+ (load-file-name fullname)
+ (set-auto-coding-for-load t)
(inhibit-file-name-operation nil))
(with-current-buffer buffer
;; So that we don't get completely screwed if the
@@ -407,16 +406,6 @@ PLIST (property list) may contain any type of information a user
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
-(defun charset-id (_charset)
- "Always return 0. This is provided for backward compatibility."
- (declare (obsolete nil "23.1"))
- 0)
-
-(defmacro charset-bytes (_charset)
- "Always return 0. This is provided for backward compatibility."
- (declare (obsolete nil "23.1"))
- 0)
-
(defun get-charset-property (charset propname)
"Return the value of CHARSET's PROPNAME property.
This is the last value stored with
@@ -462,19 +451,8 @@ Return -1 if charset isn't an ISO 2022 one."
"Return long name of CHARSET."
(plist-get (charset-plist charset) :long-name))
-(defun charset-list ()
- "Return list of all charsets ever defined."
- (declare (obsolete charset-list "23.1"))
- charset-list)
-
;;; CHARACTER
-(define-obsolete-function-alias 'char-valid-p 'characterp "23.1")
-
-(defun generic-char-p (_char)
- "Always return nil. This is provided for backward compatibility."
- (declare (obsolete nil "23.1"))
- nil)
(defun make-char-internal (charset-id &optional code1 code2)
(let ((charset (aref emacs-mule-charset-table charset-id)))
@@ -513,27 +491,27 @@ per-character basis, this may not be accurate."
(cond
((listp cs-list)
(catch 'tag
- (mapc #'(lambda (charset)
- (if (encode-char char charset)
- (throw 'tag charset)))
+ (mapc (lambda (charset)
+ (if (encode-char char charset)
+ (throw 'tag charset)))
cs-list)
nil))
((eq cs-list 'iso-2022)
(catch 'tag2
- (mapc #'(lambda (charset)
- (if (and (plist-get (charset-plist charset)
- :iso-final-char)
- (encode-char char charset))
- (throw 'tag2 charset)))
+ (mapc (lambda (charset)
+ (if (and (plist-get (charset-plist charset)
+ :iso-final-char)
+ (encode-char char charset))
+ (throw 'tag2 charset)))
charset-list)
nil))
((eq cs-list 'emacs-mule)
(catch 'tag3
- (mapc #'(lambda (charset)
- (if (and (plist-get (charset-plist charset)
- :emacs-mule-id)
- (encode-char char charset))
- (throw 'tag3 charset)))
+ (mapc (lambda (charset)
+ (if (and (plist-get (charset-plist charset)
+ :emacs-mule-id)
+ (encode-char char charset))
+ (throw 'tag3 charset)))
charset-list)
nil)))))))))))
@@ -768,11 +746,12 @@ decoded by the coding system itself and before any functions in
`after-insert-functions' are called. This function is passed one
argument: the number of characters in the text to convert, with
point at the start of the text. The function should leave point
-unchanged, and should return the new character count. Note that
-this function should avoid reading from files or receiving text
-from subprocesses -- anything that could invoke decoding; if it
-must do so, it should bind `coding-system-for-read' to a value
-other than the current coding-system, to avoid infinite recursion.
+and the match data unchanged, and should return the new character
+count. Note that this function should avoid reading from files
+or receiving text from subprocesses -- anything that could invoke
+decoding; if it must do so, it should bind
+`coding-system-for-read' to a value other than the current
+coding-system, to avoid infinite recursion.
`:pre-write-conversion'
@@ -780,13 +759,13 @@ VALUE must be a function to call after all functions in
`write-region-annotate-functions' and `buffer-file-format' are
called, and before the text is encoded by the coding system
itself. This function should convert the whole text in the
-current buffer. For backward compatibility, this function is
-passed two arguments which can be ignored. Note that this
-function should avoid writing to files or sending text to
-subprocesses -- anything that could invoke encoding; if it
-must do so, it should bind `coding-system-for-write' to a
-value other than the current coding-system, to avoid infinite
-recursion.
+current buffer, and leave the match data unchanged. For backward
+compatibility, this function is passed two arguments which can be
+ignored. Note that this function should avoid writing to files
+or sending text to subprocesses -- anything that could invoke
+encoding; if it must do so, it should bind
+`coding-system-for-write' to a value other than the current
+coding-system, to avoid infinite recursion.
`:default-char'
@@ -874,10 +853,10 @@ VALUE is a CCL program name defined by `define-ccl-program'. The
CCL program reads a character sequence and writes a byte sequence
as an encoding result.
-`:inhibit-nul-byte-detection'
+`:inhibit-null-byte-detection'
VALUE non-nil means Emacs should ignore null bytes on code detection.
-See the variable `inhibit-nul-byte-detection'. This attribute
+See the variable `inhibit-null-byte-detection'. This attribute
is meaningful only when `:coding-type' is `undecided'.
If VALUE is t, Emacs will ignore null bytes unconditionally while
detecting encoding. If VALUE is non-nil and not t, Emacs will
@@ -929,7 +908,7 @@ non-ASCII files. This attribute is meaningful only when
:ccl-encoder
:valids))
((eq coding-type 'undecided)
- '(:inhibit-nul-byte-detection
+ '(:inhibit-null-byte-detection
:inhibit-iso-escape-detection
:prefer-utf-8))))))
@@ -1090,14 +1069,11 @@ formats (e.g. iso-latin-1-unix, koi8-r-dos)."
(setq codings (cons alias codings))))))
codings))
-(defconst char-coding-system-table nil
- "It exists just for backward compatibility, and the value is always nil.")
-(make-obsolete-variable 'char-coding-system-table nil "23.1")
-
(defun transform-make-coding-system-args (name type &optional doc-string props)
"For internal use only.
Transform XEmacs style args for `make-coding-system' to Emacs style.
Value is a list of transformed arguments."
+ (declare (obsolete nil "28.1"))
(let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?")))
(eol-type (plist-get props 'eol-type))
properties tmp)
@@ -1175,106 +1151,6 @@ Value is a list of transformed arguments."
(error "unsupported XEmacs style make-coding-style arguments: %S"
`(,name ,type ,doc-string ,props))))))
-(defun make-coding-system (coding-system type mnemonic doc-string
- &optional
- flags
- properties
- eol-type)
- "Define a new coding system CODING-SYSTEM (symbol).
-This function is provided for backward compatibility."
- (declare (obsolete define-coding-system "23.1"))
- ;; For compatibility with XEmacs, we check the type of TYPE. If it
- ;; is a symbol, perhaps, this function is called with XEmacs-style
- ;; arguments. Here, try to transform that kind of arguments to
- ;; Emacs style.
- (if (symbolp type)
- (let ((args (transform-make-coding-system-args coding-system type
- mnemonic doc-string)))
- (setq coding-system (car args)
- type (nth 1 args)
- mnemonic (nth 2 args)
- doc-string (nth 3 args)
- flags (nth 4 args)
- properties (nth 5 args)
- eol-type (nth 6 args))))
-
- (setq type
- (cond ((eq type 0) 'emacs-mule)
- ((eq type 1) 'shift-jis)
- ((eq type 2) 'iso2022)
- ((eq type 3) 'big5)
- ((eq type 4) 'ccl)
- ((eq type 5) 'raw-text)
- (t
- (error "Invalid coding system type: %s" type))))
-
- (setq properties
- (let ((plist nil) key)
- (dolist (elt properties)
- (setq key (car elt))
- (cond ((eq key 'post-read-conversion)
- (setq key :post-read-conversion))
- ((eq key 'pre-write-conversion)
- (setq key :pre-write-conversion))
- ((eq key 'translation-table-for-decode)
- (setq key :decode-translation-table))
- ((eq key 'translation-table-for-encode)
- (setq key :encode-translation-table))
- ((eq key 'safe-charsets)
- (setq key :charset-list))
- ((eq key 'mime-charset)
- (setq key :mime-charset))
- ((eq key 'valid-codes)
- (setq key :valids)))
- (setq plist (plist-put plist key (cdr elt))))
- plist))
- (setq properties (plist-put properties :mnemonic mnemonic))
- (plist-put properties :coding-type type)
- (cond ((eq eol-type 0) (setq eol-type 'unix))
- ((eq eol-type 1) (setq eol-type 'dos))
- ((eq eol-type 2) (setq eol-type 'mac))
- ((vectorp eol-type) (setq eol-type nil)))
- (plist-put properties :eol-type eol-type)
-
- (cond
- ((eq type 'iso2022)
- (plist-put properties :flags
- (list (and (or (consp (nth 0 flags))
- (consp (nth 1 flags))
- (consp (nth 2 flags))
- (consp (nth 3 flags))) 'designation)
- (or (nth 4 flags) 'long-form)
- (and (nth 5 flags) 'ascii-at-eol)
- (and (nth 6 flags) 'ascii-at-cntl)
- (and (nth 7 flags) '7-bit)
- (and (nth 8 flags) 'locking-shift)
- (and (nth 9 flags) 'single-shift)
- (and (nth 10 flags) 'use-roman)
- (and (nth 11 flags) 'use-oldjis)
- (or (nth 12 flags) 'direction)
- (and (nth 13 flags) 'init-at-bol)
- (and (nth 14 flags) 'designate-at-bol)
- (and (nth 15 flags) 'safe)
- (and (nth 16 flags) 'latin-extra)))
- (plist-put properties :designation
- (let ((vec (make-vector 4 nil)))
- (dotimes (i 4)
- (let ((spec (nth i flags)))
- (if (eq spec t)
- (aset vec i '(94 96))
- (if (consp spec)
- (progn
- (if (memq t spec)
- (setq spec (append (delq t spec) '(94 96))))
- (aset vec i spec))))))
- vec)))
-
- ((eq type 'ccl)
- (plist-put properties :ccl-decoder (car flags))
- (plist-put properties :ccl-encoder (cdr flags))))
-
- (apply 'define-coding-system coding-system doc-string properties))
-
(defun merge-coding-systems (first second)
"Fill in any unspecified aspects of coding system FIRST from SECOND.
Return the resulting coding system."
@@ -1316,12 +1192,11 @@ FORM is a form to evaluate to define the coding-system."
;; `last-coding-system-used'. (It used to set it unconditionally, but
;; that seems unnecessary; see Bug#4533.)
-(defvar buffer-file-coding-system-explicit nil
+(defvar-local buffer-file-coding-system-explicit nil
"The file coding system explicitly specified for the current buffer.
The value is a cons of coding systems for reading (decoding) and
writing (encoding).
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 ()
@@ -1376,7 +1251,7 @@ Internal use only.")
(concat "\\(?:" completion-pcm--delim-wild-regex
"\\|\\([[:alpha:]]\\)[[:digit:]]\\)"))
(cs (completing-read
- (format "Coding system for saving file (default %s): " default)
+ (format-prompt "Coding system for saving file" default)
combined-table
nil t nil 'coding-system-history
(if default (symbol-name default)))))
@@ -1479,8 +1354,7 @@ graphical terminals."
default-terminal-coding-system)
default-terminal-coding-system)))
(read-coding-system
- (format "Coding system for terminal display (default %s): "
- default)
+ (format-prompt "Coding system for terminal display" default)
default))))
(if (and (not coding-system)
(not (terminal-coding-system)))
@@ -1513,8 +1387,7 @@ graphical terminals."
(default (if (eq (coding-system-type coding) 'raw-text)
default-keyboard-coding-system)))
(read-coding-system
- (format "Coding system for keyboard input (default %s): "
- default)
+ (format-prompt "Coding system for keyboard input" default)
default))))
(let ((coding-type (coding-system-type coding-system))
(saved-meta-mode
@@ -1609,10 +1482,8 @@ the text is encoded or decoded by CODING-SYSTEM."
This setting is effective for the next communication only."
(interactive
(list (read-coding-system
- (if last-next-selection-coding-system
- (format "Coding system for the next selection (default %S): "
- last-next-selection-coding-system)
- "Coding system for the next selection: ")
+ (format-prompt "Coding system for the next selection"
+ last-next-selection-coding-system)
last-next-selection-coding-system)))
(if coding-system
(setq last-next-selection-coding-system coding-system)
@@ -1621,15 +1492,6 @@ This setting is effective for the next communication only."
(setq next-selection-coding-system coding-system))
-(defun set-coding-priority (arg)
- "Set priority of coding categories according to ARG.
-ARG is a list of coding categories ordered by priority.
-
-This function is provided for backward compatibility."
- (declare (obsolete set-coding-system-priority "23.1"))
- (apply 'set-coding-system-priority
- (mapcar #'(lambda (x) (symbol-value x)) arg)))
-
;;; X selections
(defvar ctext-non-standard-encodings-alist
@@ -1852,8 +1714,8 @@ in-place."
;; self-extracting exe archives.
(mapcar (lambda (arg) (cons (purecopy (car arg)) (cdr arg)))
'(("\\.\\(\
-arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|7z\\|\
-ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|7Z\\)\\'"
+arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|7z\\|squashfs\\|\
+ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|7Z\\|SQUASHFS\\)\\'"
. no-conversion-multibyte)
("\\.\\(exe\\|EXE\\)\\'" . no-conversion)
("\\.\\(sx[dmicw]\\|odt\\|tar\\|t[bg]z\\)\\'" . no-conversion)
@@ -2308,8 +2170,7 @@ Part of the job of this function is setting `buffer-undo-list' appropriately."
(read-coding-system "Text was really in: ")
(let ((coding (or buffer-file-coding-system last-coding-system-used)))
(read-coding-system
- (concat "But was interpreted as"
- (if coding (format " (default %S): " coding) ": "))
+ (format-prompt "But was interpreted as" coding)
coding))))
(or (and new-coding coding)
(error "Coding system not specified"))
diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el
index a78c1290f66..e049832d58b 100644
--- a/lisp/international/ogonek.el
+++ b/lisp/international/ogonek.el
@@ -1,4 +1,4 @@
-;;; ogonek.el --- change the encoding of Polish diacritics
+;;; ogonek.el --- change the encoding of Polish diacritics -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
@@ -300,9 +300,8 @@ The functions come in the following groups.
Store the name in the parameter-variable DEFAULT-NAME-VAR.
PROMPT is a string to be shown when the user is asked for a name."
(let ((encoding
- (completing-read
- (format "%s (default %s): " prompt (symbol-value default-name-var))
- ogonek-name-encoding-alist nil t)))
+ (completing-read (format-prompt prompt (symbol-value default-name-var))
+ ogonek-name-encoding-alist nil t)))
;; change the default name to the one just read, and
;; return the new default as the name you read
(set default-name-var
@@ -314,8 +313,7 @@ The result is stored in the variable DEFAULT-PREFIX-VAR.
PROMPT is a string to be shown when the user is asked for a new prefix."
(let ((prefix-string
(read-string
- (format "%s (default %s): " prompt
- (char-to-string (eval default-prefix-var))))))
+ (format-prompt prompt (char-to-string (eval default-prefix-var))))))
(if (> (length prefix-string) 1)
(error "! Only one character expected")
;; set the default prefix character to the one just read
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index eef53a03c7b..5d1311530a5 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -1,4 +1,4 @@
-;;; quail.el --- provides simple input method for multilingual text
+;;; quail.el --- provides simple input method for multilingual text -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -61,15 +61,14 @@
;; Buffer local variables
-(defvar quail-current-package nil
+(defvar-local quail-current-package nil
"The current Quail package, which depends on the current input method.
See the documentation of `quail-package-alist' for the format.")
-(make-variable-buffer-local 'quail-current-package)
(put 'quail-current-package 'permanent-local t)
;; Quail uses the following variables to assist users.
;; A string containing available key sequences or translation list.
-(defvar quail-guidance-str nil)
+(defvar-local quail-guidance-str nil)
;; A buffer to show completion list of the current key sequence.
(defvar quail-completion-buf nil)
;; We may display the guidance string in a buffer on a one-line frame.
@@ -78,41 +77,34 @@ See the documentation of `quail-package-alist' for the format.")
;; Each buffer in which Quail is activated should use different
;; guidance string.
-(make-variable-buffer-local 'quail-guidance-str)
(put 'quail-guidance-str 'permanent-local t)
-(defvar quail-overlay nil
+(defvar-local quail-overlay nil
"Overlay which covers the current translation region of Quail.")
-(make-variable-buffer-local 'quail-overlay)
-(defvar quail-conv-overlay nil
+(defvar-local quail-conv-overlay nil
"Overlay which covers the text to be converted in Quail mode.")
-(make-variable-buffer-local 'quail-conv-overlay)
-(defvar quail-current-key nil
+(defvar-local quail-current-key nil
"Current key for translation in Quail mode.")
-(make-variable-buffer-local 'quail-current-key)
-(defvar quail-current-str nil
+(defvar-local quail-current-str nil
"Currently selected translation of the current key.")
-(make-variable-buffer-local 'quail-current-str)
-(defvar quail-current-translations nil
+(defvar-local quail-current-translations nil
"Cons of indices and vector of possible translations of the current key.
Indices is a list of (CURRENT START END BLOCK BLOCKS), where
CURRENT is an index of the current translation,
START and END are indices of the start and end of the current block,
BLOCK is the current block index,
BLOCKS is a number of blocks of translation.")
-(make-variable-buffer-local 'quail-current-translations)
-(defvar quail-current-data nil
+(defvar-local quail-current-data nil
"Any Lisp object holding information of current translation status.
When a key sequence is mapped to TRANS and TRANS is a cons
of actual translation and some Lisp object to be referred
for translating the longer key sequence, this variable is set
to that Lisp object.")
-(make-variable-buffer-local 'quail-current-data)
;; Quail package handlers.
@@ -736,9 +728,9 @@ Available types are listed in the variable `quail-keyboard-layout-alist'."
:type (cons 'choice (mapcar (lambda (elt)
(list 'const (car elt)))
quail-keyboard-layout-alist))
- :set #'(lambda (symbol value)
- (quail-update-keyboard-layout value)
- (set symbol value)))
+ :set (lambda (symbol value)
+ (quail-update-keyboard-layout value)
+ (set symbol value)))
;;;###autoload
(defun quail-set-keyboard-layout (kbd-type)
@@ -787,7 +779,7 @@ you type is correctly handled."
(defun quail-keyseq-translate (keyseq)
(apply 'string
- (mapcar (function (lambda (x) (quail-keyboard-translate x)))
+ (mapcar (lambda (x) (quail-keyboard-translate x))
keyseq)))
(defun quail-insert-kbd-layout (kbd-layout)
@@ -1046,7 +1038,7 @@ the following annotation types are supported.
(quail-install-decode-map ',decode-map))))))
;;;###autoload
-(defun quail-install-map (map &optional name)
+(defun quail-install-map (map &optional _name)
"Install the Quail map MAP in the current Quail package.
Optional 2nd arg NAME, if non-nil, is a name of Quail package for
@@ -1060,7 +1052,7 @@ The installed map can be referred by the function `quail-map'."
(setcar (cdr (cdr quail-current-package)) map))
;;;###autoload
-(defun quail-install-decode-map (decode-map &optional name)
+(defun quail-install-decode-map (decode-map &optional _name)
"Install the Quail decode map DECODE-MAP in the current Quail package.
Optional 2nd arg NAME, if non-nil, is a name of Quail package for
@@ -1083,7 +1075,7 @@ The installed decode map can be referred by the function `quail-decode-map'."
KEY is a string meaning a sequence of keystrokes to be translated.
TRANSLATION is a character, a string, a vector, a Quail map,
a function, or a cons.
-It it is a character, it is the sole translation of KEY.
+If it is a character, it is the sole translation of KEY.
If it is a string, each character is a candidate for the translation.
If it is a vector, each element (string or character) is a candidate
for the translation.
@@ -1376,6 +1368,30 @@ If STR has `advice' text property, append the following special event:
(delete-region (overlay-start quail-overlay)
(overlay-end quail-overlay))))
+;; Quail puts keys back in `unread-command-events' to be re-read
+;; again, but these keys have already been recorded in recent-keys and
+;; in the keyboard macro, if one is being defined, which means that
+;; recording them again creates duplicates. This function is a
+;; wrapper around adding input events to `unread-command-events', but
+;; it makes sure these events will not be recorded a second time.
+(defun quail-add-unread-command-events (key &optional reset)
+ "Add KEY to `unread-command-events', but avoid recording it a second time.
+If KEY is a character, it is prepended to `unread-command-events' as
+a cons cell of the form (no-record . KEY).
+If KEY is a vector of events, the events in the vector are prepended
+to `unread-command-events', after converting each event to a cons cell
+of the form (no-record . EVENT).
+If RESET is non-nil, the events in `unread-command-events' are first
+discarded, i.e. in this case KEY will end up being the only key
+in `unread-command-events'."
+ (if reset (setq unread-command-events nil))
+ (setq unread-command-events
+ (if (characterp key)
+ (cons (cons 'no-record key) unread-command-events)
+ (append (mapcan (lambda (e) (list (cons 'no-record e)))
+ (append key nil))
+ unread-command-events))))
+
(defun quail-start-translation (key)
"Start translation of the typed character KEY by the current Quail package.
Return the input string."
@@ -1390,16 +1406,14 @@ Return the input string."
(let* ((echo-keystrokes 0)
(help-char nil)
(overriding-terminal-local-map (quail-translation-keymap))
- (generated-events nil) ;FIXME: What is this?
+ ;; (generated-events nil) ;FIXME: What is this?
(input-method-function nil)
(modified-p (buffer-modified-p))
- last-command-event last-command this-command inhibit-record)
+ last-command-event last-command this-command)
(setq quail-current-key ""
quail-current-str ""
quail-translating t)
- (if key
- (setq unread-command-events (cons key unread-command-events)
- inhibit-record t))
+ (if key (quail-add-unread-command-events key))
(while quail-translating
(set-buffer-modified-p modified-p)
(quail-show-guidance)
@@ -1408,13 +1422,8 @@ Return the input string."
(or input-method-previous-message "")
quail-current-str
quail-guidance-str)))
- ;; We inhibit record_char only for the first key,
- ;; because it was already recorded before read_char
- ;; called quail-input-method.
- (inhibit--record-char inhibit-record)
(keyseq (read-key-sequence prompt nil nil t))
(cmd (lookup-key (quail-translation-keymap) keyseq)))
- (setq inhibit-record nil)
(if (if key
(and (commandp cmd) (not (eq cmd 'quail-other-command)))
(eq cmd 'quail-self-insert-command))
@@ -1428,9 +1437,7 @@ Return the input string."
(quail-error (message "%s" (cdr err)) (beep))))
;; KEYSEQ is not defined in the translation keymap.
;; Let's return the event(s) to the caller.
- (setq unread-command-events
- (append (this-single-command-raw-keys)
- unread-command-events))
+ (quail-add-unread-command-events (this-single-command-raw-keys))
(setq quail-translating nil))))
(quail-delete-region)
quail-current-str)
@@ -1455,18 +1462,16 @@ Return the input string."
(let* ((echo-keystrokes 0)
(help-char nil)
(overriding-terminal-local-map (quail-conversion-keymap))
- (generated-events nil) ;FIXME: What is this?
+ ;; (generated-events nil) ;FIXME: What is this?
(input-method-function nil)
(modified-p (buffer-modified-p))
- last-command-event last-command this-command inhibit-record)
+ last-command-event last-command this-command)
(setq quail-current-key ""
quail-current-str ""
quail-translating t
quail-converting t
quail-conversion-str "")
- (if key
- (setq unread-command-events (cons key unread-command-events)
- inhibit-record t))
+ (if key (quail-add-unread-command-events key))
(while quail-converting
(set-buffer-modified-p modified-p)
(or quail-translating
@@ -1482,13 +1487,8 @@ Return the input string."
quail-conversion-str
quail-current-str
quail-guidance-str)))
- ;; We inhibit record_char only for the first key,
- ;; because it was already recorded before read_char
- ;; called quail-input-method.
- (inhibit--record-char inhibit-record)
(keyseq (read-key-sequence prompt nil nil t))
(cmd (lookup-key (quail-conversion-keymap) keyseq)))
- (setq inhibit-record nil)
(if (if key (commandp cmd) (eq cmd 'quail-self-insert-command))
(progn
(setq last-command-event (aref keyseq (1- (length keyseq)))
@@ -1511,9 +1511,7 @@ Return the input string."
(setq quail-converting nil)))))
;; KEYSEQ is not defined in the conversion keymap.
;; Let's return the event(s) to the caller.
- (setq unread-command-events
- (append (this-single-command-raw-keys)
- unread-command-events))
+ (quail-add-unread-command-events (this-single-command-raw-keys))
(setq quail-converting nil))))
(setq quail-translating nil)
(if (overlay-start quail-conv-overlay)
@@ -1559,9 +1557,8 @@ with more keys."
(or input-method-exit-on-first-char
(while (> len control-flag)
(setq len (1- len))
- (setq unread-command-events
- (cons (aref quail-current-key len)
- unread-command-events))))))
+ (quail-add-unread-command-events
+ (aref quail-current-key len))))))
((null control-flag)
(unless quail-current-str
(setq quail-current-str
@@ -1579,12 +1576,12 @@ with more keys."
(let (char)
(if (stringp quail-current-str)
(catch 'tag
- (mapc #'(lambda (ch)
- (when (/= (unibyte-char-to-multibyte
- (multibyte-char-to-unibyte ch))
- ch)
- (setq char ch)
- (throw 'tag nil)))
+ (mapc (lambda (ch)
+ (when (/= (unibyte-char-to-multibyte
+ (multibyte-char-to-unibyte ch))
+ ch)
+ (setq char ch)
+ (throw 'tag nil)))
quail-current-str))
(if (/= (unibyte-char-to-multibyte
(multibyte-char-to-unibyte quail-current-str))
@@ -1807,8 +1804,7 @@ sequence counting from the head."
(setcar indices (1+ (car indices)))
(quail-update-current-translations)
(quail-update-translation nil)))
- (setq unread-command-events
- (cons last-command-event unread-command-events))
+ (quail-add-unread-command-events last-command-event)
(quail-terminate-translation)))
(defun quail-prev-translation ()
@@ -1822,8 +1818,7 @@ sequence counting from the head."
(setcar indices (1- (car indices)))
(quail-update-current-translations)
(quail-update-translation nil)))
- (setq unread-command-events
- (cons last-command-event unread-command-events))
+ (quail-add-unread-command-events last-command-event)
(quail-terminate-translation)))
(defun quail-next-translation-block ()
@@ -1838,8 +1833,7 @@ sequence counting from the head."
(setcar indices (+ (nth 2 indices) offset))
(quail-update-current-translations)
(quail-update-translation nil)))
- (setq unread-command-events
- (cons last-command-event unread-command-events))
+ (quail-add-unread-command-events last-command-event)
(quail-terminate-translation)))
(defun quail-prev-translation-block ()
@@ -1858,8 +1852,7 @@ sequence counting from the head."
(setcar indices (+ (nth 1 indices) offset))
(quail-update-current-translations)))
(quail-update-translation nil)))
- (setq unread-command-events
- (cons last-command-event unread-command-events))
+ (quail-add-unread-command-events last-command-event)
(quail-terminate-translation)))
(defun quail-abort-translation ()
@@ -2014,8 +2007,8 @@ Remaining args are for FUNC."
(sit-for 1000000)
(delete-region point-max (point-max))
(when quit-flag
- (setq quit-flag nil
- unread-command-events '(7)))))
+ (setq quit-flag nil)
+ (quail-add-unread-command-events 7 t))))
(defun quail-show-guidance ()
"Display a guidance for Quail input method in some window.
@@ -2027,10 +2020,15 @@ minibuffer and the selected frame has no other windows)."
(bury-buffer quail-completion-buf)
;; Then, show the guidance.
- (when (and (quail-require-guidance-buf)
- (not input-method-use-echo-area)
- (null unread-command-events)
- (null unread-post-input-method-events))
+ (when (and
+ ;; Don't try to display guidance on an expired minibuffer. This
+ ;; would go into an infinite wait rather than executing the user's
+ ;; command. Bug #45792.
+ (not (eq major-mode 'minibuffer-inactive-mode))
+ (quail-require-guidance-buf)
+ (not input-method-use-echo-area)
+ (null unread-command-events)
+ (null unread-post-input-method-events))
(if (minibufferp)
(if (eq (minibuffer-window) (frame-root-window))
;; Use another frame. It is sure that we are using some
@@ -2146,7 +2144,7 @@ minibuffer and the selected frame has no other windows)."
(setq str
(format "%s[%s]"
str
- (concat (sort (mapcar (function (lambda (x) (car x)))
+ (concat (sort (mapcar (lambda (x) (car x))
(cdr map))
'<)))))
;; Show list of translations.
@@ -2350,13 +2348,13 @@ Optional 6th arg IGNORES is a list of translations to ignore."
((consp translation)
(setq translation (cdr translation))
(let ((multibyte nil))
- (mapc (function (lambda (x)
- ;; Accept only non-ASCII chars not
- ;; listed in IGNORES.
- (if (and (if (integerp x) (> x 127)
- (string-match-p "[^[:ascii:]]" x))
- (not (member x ignores)))
- (setq multibyte t))))
+ (mapc (lambda (x)
+ ;; Accept only non-ASCII chars not
+ ;; listed in IGNORES.
+ (if (and (if (integerp x) (> x 127)
+ (string-match-p "[^[:ascii:]]" x))
+ (not (member x ignores)))
+ (setq multibyte t)))
translation)
(when multibyte
(setcdr decode-map
@@ -2381,11 +2379,11 @@ These are stored in DECODE-MAP using the concise format. DECODE-MAP
should be made by `quail-build-decode-map' (which see)."
(setq decode-map
(sort (cdr decode-map)
- (function (lambda (x y)
- (setq x (car x) y (car y))
- (or (> (length x) (length y))
- (and (= (length x) (length y))
- (not (string< x y))))))))
+ (lambda (x y)
+ (setq x (car x) y (car y))
+ (or (> (length x) (length y))
+ (and (= (length x) (length y))
+ (not (string< x y)))))))
(let ((window-width (window-width (get-buffer-window
(current-buffer) 'visible)))
(single-trans-width 4)
@@ -2452,7 +2450,7 @@ should be made by `quail-build-decode-map' (which see)."
(insert-char ?- single-trans-width)
(forward-line 1)
;; Insert the key-tran pairs.
- (dotimes (row rows)
+ (dotimes (_ rows)
(let ((elt (pop single-list)))
(when elt
(move-to-column col)
@@ -2478,14 +2476,13 @@ should be made by `quail-build-decode-map' (which see)."
'face 'font-lock-comment-face))
(quail-indent-to max-key-width)
(if (vectorp (cdr elt))
- (mapc (function
- (lambda (x)
- (let ((width (if (integerp x) (char-width x)
- (string-width x))))
- (when (> (+ (current-column) 1 width) window-width)
- (insert "\n")
- (quail-indent-to max-key-width))
- (insert " " x))))
+ (mapc (lambda (x)
+ (let ((width (if (integerp x) (char-width x)
+ (string-width x))))
+ (when (> (+ (current-column) 1 width) window-width)
+ (insert "\n")
+ (quail-indent-to max-key-width))
+ (insert " " x)))
(cdr elt))
(insert " " (cdr elt)))
(insert ?\n))
@@ -2626,12 +2623,14 @@ KEY BINDINGS FOR CONVERSION
(run-hooks 'temp-buffer-show-hook)))))
(defun quail-help-insert-keymap-description (keymap &optional header)
+ (defvar the-keymap)
(let ((pos1 (point))
+ (the-keymap keymap)
pos2)
(if header
(insert header))
(save-excursion
- (insert (substitute-command-keys "\\{keymap}")))
+ (insert (substitute-command-keys "\\{the-keymap}")))
;; Skip headers "key bindings", etc.
(forward-line 3)
(setq pos2 (point))
@@ -2829,19 +2828,19 @@ If CHAR is an ASCII character and can be input by typing itself, return t."
(key-list nil))
(if (consp decode-map)
(let ((str (string char)))
- (mapc #'(lambda (elt)
- (if (string= str (car elt))
- (setq key-list (cons (cdr elt) key-list))))
+ (mapc (lambda (elt)
+ (if (string= str (car elt))
+ (setq key-list (cons (cdr elt) key-list))))
(cdr decode-map)))
(let ((key-head (aref decode-map char)))
(if (stringp key-head)
(setq key-list (quail-find-key1
(quail-lookup-key key-head nil t)
key-head char nil))
- (mapc #'(lambda (elt)
- (setq key-list
- (quail-find-key1
- (quail-lookup-key elt nil t) elt char key-list)))
+ (mapc (lambda (elt)
+ (setq key-list
+ (quail-find-key1
+ (quail-lookup-key elt nil t) elt char key-list)))
key-head))))
(or key-list
(and (< char 128)
@@ -3012,7 +3011,7 @@ of each directory."
;; At first, clean up the file.
(with-current-buffer list-buf
- (goto-char 1)
+ (goto-char (point-min))
;; Insert the correct header.
(if (looking-at (regexp-quote leim-list-header))
@@ -3068,28 +3067,31 @@ of each directory."
;; Don't get fooled by commented-out code.
(while (re-search-forward "^[ \t]*(quail-define-package" nil t)
(goto-char (match-beginning 0))
- (condition-case nil
- (let ((form (read (current-buffer))))
- (with-current-buffer list-buf
- (insert
- (format "(register-input-method
+ (let (form)
+ (condition-case err
+ (progn
+ (setq form (read (current-buffer)))
+ (with-current-buffer list-buf
+ (insert
+ (format "(register-input-method
%S %S '%s
%S %S
%S)\n"
- (nth 1 form) ; PACKAGE-NAME
- (nth 2 form) ; LANGUAGE
- 'quail-use-package ; ACTIVATE-FUNC
- (nth 3 form) ; PACKAGE-TITLE
- (progn ; PACKAGE-DESCRIPTION (one line)
- (string-match ".*" (nth 5 form))
- (match-string 0 (nth 5 form)))
- (file-relative-name ; PACKAGE-FILENAME
- (file-name-sans-extension (car pkg-list))
- (car dirnames))))))
- (error
- ;; Ignore the remaining contents of this file.
- (goto-char (point-max))
- (message "Some part of \"%s\" is broken" (car pkg-list))))))
+ (nth 1 form) ; PACKAGE-NAME
+ (nth 2 form) ; LANGUAGE
+ 'quail-use-package ; ACTIVATE-FUNC
+ (nth 3 form) ; PACKAGE-TITLE
+ (progn ; PACKAGE-DESCRIPTION (one line)
+ (string-match ".*" (nth 5 form))
+ (match-string 0 (nth 5 form)))
+ (file-relative-name ; PACKAGE-FILENAME
+ (file-name-sans-extension (car pkg-list))
+ (car dirnames))))))
+ (error
+ ;; Ignore the remaining contents of this file.
+ (goto-char (point-max))
+ (message "Some part of \"%s\" is broken: %s in %s"
+ (car pkg-list) err form))))))
(setq pkg-list (cdr pkg-list)))
(setq quail-dirs (cdr quail-dirs) dirnames (cdr dirnames))))
diff --git a/lisp/international/rfc1843.el b/lisp/international/rfc1843.el
index a5ed2aadf85..bd83a7a289b 100644
--- a/lisp/international/rfc1843.el
+++ b/lisp/international/rfc1843.el
@@ -60,7 +60,7 @@ e-mail transmission, news posting, etc."
(defcustom rfc1843-newsgroups-regexp "chinese\\|hz"
"Regexp of newsgroups in which might be HZ encoded."
- :type 'string
+ :type 'regexp
:group 'mime)
(defun rfc1843-decode-region (from to)
diff --git a/lisp/international/robin.el b/lisp/international/robin.el
index 94d2bf18088..e4a11801c38 100644
--- a/lisp/international/robin.el
+++ b/lisp/international/robin.el
@@ -1,4 +1,4 @@
-;;; robin.el --- yet another input method (smaller than quail)
+;;; robin.el --- yet another input method (smaller than quail) -*- lexical-binding: t; -*-
;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -371,14 +371,12 @@ Internal use only."
;;; Interactive use
-(defvar robin-mode nil
+(defvar-local robin-mode nil
"If non-nil, `robin-input-method' is active.")
-(make-variable-buffer-local 'robin-mode)
-(defvar robin-current-package-name nil
+(defvar-local robin-current-package-name nil
"String representing the name of the current robin package.
A nil value means no package is selected.")
-(make-variable-buffer-local 'robin-current-package-name)
;;;###autoload
(defun robin-use-package (name)
@@ -424,8 +422,7 @@ While this input method is active, the variable
(add-hook 'minibuffer-exit-hook 'robin-exit-from-minibuffer))
(run-hooks 'input-method-activate-hook
'robin-activate-hook)
- (set (make-local-variable 'input-method-function)
- 'robin-input-method)))
+ (setq-local input-method-function 'robin-input-method)))
(define-obsolete-variable-alias
'robin-inactivate-hook
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index b8b31d45b95..ccb4c8390bb 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -269,6 +269,8 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:é™°å¹³, 6:陽平, 3:上è², 4:去è²,
(tit-moveleft ",<")
(tit-keyprompt nil))
+ (princ (format ";;; %s -*- lexical-binding:t -*-\n"
+ (file-name-nondirectory filename)))
(princ ";; Quail package `")
(princ package)
(princ "\n")
@@ -375,7 +377,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:é™°å¹³, 6:陽平, 3:上è², 4:去è²,
;; Arg DOCSTRING
(let ((doc (concat tit-prompt "\n"))
(comments (if tit-comments
- (mapconcat 'identity (nreverse tit-comments) "\n")))
+ (mapconcat #'identity (nreverse tit-comments) "\n")))
(doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info))))
(if comments
(setq doc (concat doc "\n" comments "\n")))
@@ -737,12 +739,10 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; method is for inputting CNS characters.
(defun tsang-quick-converter (dicbuf tsang-p big5-p)
- (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡")
- (if big5-p "簡易" "簡易")))
+ (let ((fulltitle (if tsang-p "倉頡" "簡易"))
dic)
(goto-char (point-max))
- (if big5-p
- (insert (format "\"中文輸入ã€%s】BIG5
+ (insert (format "\"中文輸入ã€%s】%s
漢語%s輸入éµç›¤
@@ -753,19 +753,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
[Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一]
\\\\<quail-translation-docstring>\"\n"
- fulltitle fulltitle))
- (insert (format "\"中文輸入ã€%s】CNS
-
- 漢語%s輸入éµç›¤
-
- [Q 手] [W ç”°] [E æ°´] [R å£] [T 廿] [Y åœ] [U å±±] [I 戈] [O 人] [P 心]
-
- [A æ—¥] [S å°¸] [D 木] [F ç«] [G 土] [H 竹] [J å] [L 中]
-
- [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一]
-
-\\\\<quail-translation-docstring>\"\n"
- fulltitle fulltitle)))
+ fulltitle (if big5-p "BIG5" "CNS") fulltitle))
(insert " '((\".\" . quail-next-translation-block)
(\",\" . quail-prev-translation-block))
nil nil)\n\n")
@@ -793,9 +781,9 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
(if val (setq trans (concat val trans)))
(puthash key trans table)
(forward-line 1)))
- (maphash #'(lambda (key val) (setq dic (cons (cons key val) dic)))
+ (maphash (lambda (key val) (setq dic (cons (cons key val) dic)))
table)))
- (setq dic (sort dic (function (lambda (x y) (string< (car x ) (car y))))))
+ (setq dic (sort dic (lambda (x y) (string< (car x ) (car y)))))
(dolist (elt dic)
(insert (format "(%S\t%S)\n" (car elt) (cdr elt))))
(let ((punctuation '((";" ";﹔,ã€ï¹ï¹‘" ";﹔,ã€ï¹ï¹‘")
@@ -943,20 +931,20 @@ method `chinese-tonepy' with which you must specify tones by digits
(if val (setq trans (vconcat val trans)))
(puthash key trans table)
(forward-line 1))
- (maphash #'(lambda (key trans)
- (let ((len (length trans))
- i)
- (if (and (= len 1) (= (length (aref trans 0)) 1))
- (setq trans (aref trans 0))
- (setq i 0)
- (while (and (< i len)
- (= (length (aref trans i)) 1))
- (setq i (1+ i)))
- (if (= i len)
- (setq trans (mapconcat 'identity trans "")))))
- (setq dic (cons (cons key trans) dic)))
+ (maphash (lambda (key trans)
+ (let ((len (length trans))
+ i)
+ (if (and (= len 1) (= (length (aref trans 0)) 1))
+ (setq trans (aref trans 0))
+ (setq i 0)
+ (while (and (< i len)
+ (= (length (aref trans i)) 1))
+ (setq i (1+ i)))
+ (if (= i len)
+ (setq trans (mapconcat #'identity trans "")))))
+ (setq dic (cons (cons key trans) dic)))
table)))
- (setq dic (sort dic (function (lambda (x y) (string< (car x) (car y))))))
+ (setq dic (sort dic (lambda (x y) (string< (car x) (car y)))))
(goto-char (point-max))
(insert (format "%S\n" "汉字输入∷ã€è‡ªç„¶ã€‘∷
@@ -1147,6 +1135,8 @@ the generated Quail package is saved."
;; Explicitly set eol format to `unix'.
(setq coding-system-for-write 'utf-8-unix)
(with-temp-file (expand-file-name quailfile dirname)
+ (insert (format ";;; %s -*- lexical-binding:t -*-\n"
+ (file-name-nondirectory quailfile)))
(insert (format-message ";; Quail package `%s'\n" name))
(insert (format-message
";; Generated by the command `miscdic-convert'\n"))
@@ -1212,8 +1202,10 @@ The library is named pinyin.el, and contains the constant
(dst-file (cadr command-line-args-left))
(coding-system-for-write 'utf-8-unix))
(with-temp-file dst-file
- (insert ";; This file is automatically generated from pinyin.map,\
- by the\n;; function pinyin-convert.\n\n")
+ (insert ";;; " (file-name-nondirectory dst-file)
+ " -*- lexical-binding:t -*-
+;; This file is automatically generated from pinyin.map, by the
+;; function pinyin-convert.\n\n")
(insert "(defconst pinyin-character-map\n'(")
(let ((pos (point)))
(insert-file-contents src-file)
diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el
index a4d1a238a4d..0f8dedfc09b 100644
--- a/lisp/international/ucs-normalize.el
+++ b/lisp/international/ucs-normalize.el
@@ -1,4 +1,4 @@
-;;; ucs-normalize.el --- Unicode normalization NFC/NFD/NFKD/NFKC
+;;; ucs-normalize.el --- Unicode normalization NFC/NFD/NFKD/NFKC -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -25,8 +25,8 @@
;; This program has passed the NormalizationTest-5.2.0.txt.
;;
;; References:
-;; http://www.unicode.org/reports/tr15/
-;; http://www.unicode.org/review/pr-29.html
+;; https://www.unicode.org/reports/tr15/
+;; https://www.unicode.org/review/pr-29.html
;;
;; HFS-Normalization:
;; Reference:
@@ -98,7 +98,7 @@
;;
;; D. Sorting and Composition of Smaller Blocks (`ucs-normalize-block-compose-chars')
;;
-;; The block will be split to multiple samller blocks by starter
+;; The block will be split to multiple smaller blocks by starter
;; characters. Each block is sorted, and composed if necessary.
;;
;; E. Composition of Entire Block (`ucs-normalize-compose-chars')
@@ -131,7 +131,7 @@
#x1D1BF #x1D1C0)
"Composition Exclusion List.
This list is taken from
- http://www.unicode.org/Public/UNIDATA/5.2/CompositionExclusions.txt")
+ https://www.unicode.org/Public/UNIDATA/5.2/CompositionExclusions.txt")
;; Unicode ranges that decompositions & combining characters are defined.
(defvar check-range nil)
@@ -185,7 +185,7 @@
;; always returns nil, something the code here doesn't like.
(define-char-code-property 'decomposition "uni-decomposition.el")
(define-char-code-property 'canonical-combining-class "uni-combining.el")
- (let ((char 0) ccc decomposition)
+ (let (ccc decomposition)
(mapc
(lambda (start-end)
(cl-do ((char (car start-end) (+ char 1))) ((> char (cdr start-end)))
@@ -441,7 +441,7 @@ decomposition."
(concat (quick-check-list-to-regexp quick-check-list) "\\|[가-힣]"))
(defun quick-check-composition-list-to-regexp (quick-check-list)
- (concat (quick-check-list-to-regexp quick-check-list) "\\|[ᅡ-ᅵᆨ-ᇂ]"))
+ (quick-check-list-to-regexp quick-check-list))
)
@@ -612,14 +612,16 @@ COMPOSITION-PREDICATE will be used to compose region."
(defun ucs-normalize-hfs-nfd-post-read-conversion (len)
(save-excursion
(save-restriction
- (narrow-to-region (point) (+ (point) len))
- (ucs-normalize-HFS-NFC-region (point-min) (point-max))
- (- (point-max) (point-min)))))
+ (save-match-data
+ (narrow-to-region (point) (+ (point) len))
+ (ucs-normalize-HFS-NFC-region (point-min) (point-max))
+ (- (point-max) (point-min))))))
;; Pre-write conversion for `utf-8-hfs'.
;; _from and _to are legacy arguments (see `define-coding-system').
(defun ucs-normalize-hfs-nfd-pre-write-conversion (_from _to)
- (ucs-normalize-HFS-NFD-region (point-min) (point-max)))
+ (save-match-data
+ (ucs-normalize-HFS-NFD-region (point-min) (point-max))))
;;; coding-system definition
(define-coding-system 'utf-8-hfs
diff --git a/lisp/international/utf-7.el b/lisp/international/utf-7.el
index e941abb463e..dece184ffef 100644
--- a/lisp/international/utf-7.el
+++ b/lisp/international/utf-7.el
@@ -1,4 +1,4 @@
-;;; utf-7.el --- utf-7 coding system
+;;; utf-7.el --- utf-7 coding system -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/lisp/isearch.el b/lisp/isearch.el
index f99461ac456..922ab0f6ad4 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -26,7 +26,7 @@
;; Instructions
-;; For programmed use of isearch-mode, e.g. calling (isearch-forward),
+;; For programmed use of isearch-mode, e.g. calling `isearch-forward',
;; isearch-mode behaves modally and does not return until the search
;; is completed. It uses a recursive-edit to behave this way.
@@ -46,7 +46,7 @@
;; exits and searches in the last search direction.
;; Exiting immediately from isearch uses isearch-edit-string instead
-;; of nonincremental-search, if search-nonincremental-instead is non-nil.
+;; of nonincremental-search, if `search-nonincremental-instead' is non-nil.
;; The name of this option should probably be changed if we decide to
;; keep the behavior. No point in forcing nonincremental search until
;; the last possible moment.
@@ -54,7 +54,6 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-(declare-function tmm-menubar-keymap "tmm.el")
;; Some additional options and constants.
@@ -173,6 +172,29 @@ This allows you to resume earlier Isearch sessions through the
command history."
:type 'boolean)
+(defcustom isearch-wrap-pause t
+ "Define the behavior of wrapping when there are no more matches.
+When `t' (by default), signal an error when no more matches are found.
+Then after repeating the search, wrap with `isearch-wrap-function'.
+When `no', wrap immediately after reaching the last match.
+When `no-ding', wrap immediately without flashing the screen.
+When `nil', never wrap, just stop at the last match."
+ :type '(choice (const :tag "Pause before wrapping" t)
+ (const :tag "No pause before wrapping" no)
+ (const :tag "No pause and no flashing" no-ding)
+ (const :tag "Disable wrapping" nil))
+ :version "28.1")
+
+(defcustom isearch-repeat-on-direction-change nil
+ "Whether a direction change should move to another match.
+When `nil', the default, a direction change moves point to the other
+end of the current search match.
+When `t', a direction change moves to another search match, if there
+is one."
+ :type '(choice (const :tag "Remain on the same match" nil)
+ (const :tag "Move to another match" t))
+ :version "28.1")
+
(defvar isearch-mode-hook nil
"Function(s) to call after starting up an incremental search.")
@@ -211,6 +233,7 @@ called with the positions of the start and the end of the text
matched by Isearch and replace commands. If this function
returns nil, Isearch and replace commands will continue searching
without stopping at resp. replacing this match.
+This function is expected to be careful not to clobber the match data.
If you use `add-function' to modify this variable, you can use the
`isearch-message-prefix' advice property to specify the prefix string
@@ -269,6 +292,17 @@ are `word-search-regexp' \(`\\[isearch-toggle-word]'), `isearch-symbol-regexp'
"Non-nil means incremental search highlights the current match."
:type 'boolean)
+(defcustom search-highlight-submatches t
+ "Whether to highlight regexp subexpressions of the current regexp match.
+The faces used to do the highlights are named `isearch-group-1',
+`isearch-group-2', etc. (By default, only these 2 are defined.)
+When there are more matches than faces, then faces are reused from the
+beginning, in a cyclical manner, so the `isearch-group-1' face is
+isreused for the third match. If you want to use more distinctive colors,
+you can define more of these faces using the same numbering scheme."
+ :type 'boolean
+ :version "28.1")
+
(defface isearch
'((((class color) (min-colors 88) (background light))
;; The background must not be too dark, for that means
@@ -343,10 +377,20 @@ If this is nil, extra highlighting can be \"manually\" removed with
:group 'lazy-highlight)
(defcustom lazy-highlight-initial-delay 0.25
- "Seconds to wait before beginning to lazily highlight all matches."
+ "Seconds to wait before beginning to lazily highlight all matches.
+This setting only has effect when the search string is less than
+`lazy-highlight-no-delay-length' characters long."
:type 'number
:group 'lazy-highlight)
+(defcustom lazy-highlight-no-delay-length 3
+ "For search strings at least this long, lazy highlight starts immediately.
+For shorter search strings, `lazy-highlight-initial-delay'
+applies."
+ :type 'integer
+ :group 'lazy-highlight
+ :version "28.1")
+
(defcustom lazy-highlight-interval 0 ; 0.0625
"Seconds between lazily highlighting successive matches."
:type 'number
@@ -361,7 +405,7 @@ A value of nil means highlight all matches shown on the screen."
(integer :tag "Some"))
:group 'lazy-highlight)
-(defcustom lazy-highlight-buffer-max-at-a-time 20
+(defcustom lazy-highlight-buffer-max-at-a-time 200 ; 20 (bug#48581)
"Maximum matches to highlight at a time (for `lazy-highlight-buffer').
Larger values may reduce Isearch's responsiveness to user input;
smaller values make matches highlight slowly.
@@ -369,7 +413,7 @@ A value of nil means highlight all matches in the buffer."
:type '(choice (const :tag "All" nil)
(integer :tag "Some"))
:group 'lazy-highlight
- :version "27.1")
+ :version "28.1")
(defcustom lazy-highlight-buffer nil
"Controls the lazy-highlighting of the full buffer.
@@ -440,11 +484,11 @@ and doesn't remove full-buffer highlighting after a search."
(make-help-screen isearch-help-for-help-internal
(purecopy "Type a help option: [bkm] or ?")
"You have typed %THIS-KEY%, the help character. Type a Help option:
-\(Type \\<help-map>\\[help-quit] to exit the Help command.)
+\(Type \\<isearch-help-map>\\[help-quit] to exit the Help command.)
-b Display all Isearch key bindings.
-k KEYS Display full documentation of Isearch key sequence.
-m Display documentation of Isearch mode.
+\\[isearch-describe-bindings] Display all Isearch key bindings.
+\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence.
+\\[isearch-describe-mode] Display documentation of Isearch mode.
You can't type here other help keys available in the global help map,
but outside of this help window when you type them in Isearch mode,
@@ -495,7 +539,7 @@ This is like `describe-bindings', but displays only Isearch keys."
(require 'tmm)
(run-hooks 'menu-bar-update-hook)
(let ((command nil))
- (let ((menu-bar (tmm-menubar-keymap)))
+ (let ((menu-bar (menu-bar-keymap)))
(with-isearch-suspended
(setq command (let ((isearch-mode t)) ; Show bindings from
; `isearch-mode-map' in
@@ -504,158 +548,9 @@ This is like `describe-bindings', but displays only Isearch keys."
(call-interactively command)))
(defvar isearch-menu-bar-commands
- '(isearch-tmm-menubar menu-bar-open mouse-minor-mode-menu)
+ '(isearch-tmm-menubar tmm-menubar menu-bar-open mouse-minor-mode-menu)
"List of commands that can open a menu during Isearch.")
-(defvar isearch-menu-bar-yank-map
- (let ((map (make-sparse-keymap)))
- (define-key map [isearch-yank-pop]
- '(menu-item "Previous kill" isearch-yank-pop
- :help "Replace previous yanked kill on search string"))
- (define-key map [isearch-yank-kill]
- '(menu-item "Current kill" isearch-yank-kill
- :help "Append current kill to search string"))
- (define-key map [isearch-yank-until-char]
- '(menu-item "Until char..." isearch-yank-until-char
- :help "Yank from point to specified character into search string"))
- (define-key map [isearch-yank-line]
- '(menu-item "Rest of line" isearch-yank-line
- :help "Yank the rest of the current line on search string"))
- (define-key map [isearch-yank-symbol-or-char]
- '(menu-item "Symbol/char"
- isearch-yank-symbol-or-char
- :help "Yank next symbol or char on search string"))
- (define-key map [isearch-yank-word-or-char]
- '(menu-item "Word/char"
- isearch-yank-word-or-char
- :help "Yank next word or char on search string"))
- (define-key map [isearch-yank-char]
- '(menu-item "Char" isearch-yank-char
- :help "Yank char at point on search string"))
- map))
-
-(defvar isearch-menu-bar-map
- (let ((map (make-sparse-keymap "Isearch")))
- (define-key map [isearch-complete]
- '(menu-item "Complete current search string" isearch-complete
- :help "Complete current search string over search history"))
- (define-key map [isearch-complete-separator]
- '(menu-item "--"))
- (define-key map [isearch-query-replace-regexp]
- '(menu-item "Replace search string as regexp" isearch-query-replace-regexp
- :help "Replace matches for current search string as regexp"))
- (define-key map [isearch-query-replace]
- '(menu-item "Replace search string" isearch-query-replace
- :help "Replace matches for current search string"))
- (define-key map [isearch-occur]
- '(menu-item "Show all matches for search string" isearch-occur
- :help "Show all matches for current search string"))
- (define-key map [isearch-highlight-regexp]
- '(menu-item "Highlight all matches for search string"
- isearch-highlight-regexp
- :help "Highlight all matches for current search string"))
- (define-key map [isearch-search-replace-separator]
- '(menu-item "--"))
- (define-key map [isearch-toggle-specified-input-method]
- '(menu-item "Turn on specific input method"
- isearch-toggle-specified-input-method
- :help "Turn on specific input method for search"))
- (define-key map [isearch-toggle-input-method]
- '(menu-item "Toggle input method" isearch-toggle-input-method
- :help "Toggle input method for search"))
- (define-key map [isearch-input-method-separator]
- '(menu-item "--"))
- (define-key map [isearch-char-by-name]
- '(menu-item "Search for char by name" isearch-char-by-name
- :help "Search for character by name"))
- (define-key map [isearch-quote-char]
- '(menu-item "Search for literal char" isearch-quote-char
- :help "Search for literal char"))
- (define-key map [isearch-special-char-separator]
- '(menu-item "--"))
- (define-key map [isearch-toggle-word]
- '(menu-item "Word matching" isearch-toggle-word
- :help "Word matching"
- :button (:toggle
- . (eq isearch-regexp-function 'word-search-regexp))))
- (define-key map [isearch-toggle-symbol]
- '(menu-item "Symbol matching" isearch-toggle-symbol
- :help "Symbol matching"
- :button (:toggle
- . (eq isearch-regexp-function
- 'isearch-symbol-regexp))))
- (define-key map [isearch-toggle-regexp]
- '(menu-item "Regexp matching" isearch-toggle-regexp
- :help "Regexp matching"
- :button (:toggle . isearch-regexp)))
- (define-key map [isearch-toggle-invisible]
- '(menu-item "Invisible text matching" isearch-toggle-invisible
- :help "Invisible text matching"
- :button (:toggle . isearch-invisible)))
- (define-key map [isearch-toggle-char-fold]
- '(menu-item "Character folding matching" isearch-toggle-char-fold
- :help "Character folding matching"
- :button (:toggle
- . (eq isearch-regexp-function
- 'char-fold-to-regexp))))
- (define-key map [isearch-toggle-case-fold]
- '(menu-item "Case folding matching" isearch-toggle-case-fold
- :help "Case folding matching"
- :button (:toggle . isearch-case-fold-search)))
- (define-key map [isearch-toggle-lax-whitespace]
- '(menu-item "Lax whitespace matching" isearch-toggle-lax-whitespace
- :help "Lax whitespace matching"
- :button (:toggle . isearch-lax-whitespace)))
- (define-key map [isearch-toggle-separator]
- '(menu-item "--"))
- (define-key map [isearch-yank-menu]
- `(menu-item "Yank on search string" ,isearch-menu-bar-yank-map))
- (define-key map [isearch-edit-string]
- '(menu-item "Edit current search string" isearch-edit-string
- :help "Edit current search string"))
- (define-key map [isearch-ring-retreat]
- '(menu-item "Edit previous search string" isearch-ring-retreat
- :help "Edit previous search string in Isearch history"))
- (define-key map [isearch-ring-advance]
- '(menu-item "Edit next search string" isearch-ring-advance
- :help "Edit next search string in Isearch history"))
- (define-key map [isearch-del-char]
- '(menu-item "Delete last char from search string" isearch-del-char
- :help "Delete last character from search string"))
- (define-key map [isearch-delete-char]
- '(menu-item "Undo last input item" isearch-delete-char
- :help "Undo the effect of the last Isearch command"))
- (define-key map [isearch-end-of-buffer]
- '(menu-item "Go to last match" isearch-end-of-buffer
- :help "Go to last occurrence of current search string"))
- (define-key map [isearch-beginning-of-buffer]
- '(menu-item "Go to first match" isearch-beginning-of-buffer
- :help "Go to first occurrence of current search string"))
- (define-key map [isearch-repeat-backward]
- '(menu-item "Repeat search backward" isearch-repeat-backward
- :help "Repeat current search backward"))
- (define-key map [isearch-repeat-forward]
- '(menu-item "Repeat search forward" isearch-repeat-forward
- :help "Repeat current search forward"))
- (define-key map [isearch-nonincremental]
- '(menu-item "Nonincremental search" isearch-exit
- :help "Start nonincremental search"
- :visible (string-equal isearch-string "")))
- (define-key map [isearch-exit]
- '(menu-item "Finish search" isearch-exit
- :help "Finish search leaving point where it is"
- :visible (not (string-equal isearch-string ""))))
- (define-key map [isearch-abort]
- '(menu-item "Remove characters not found" isearch-abort
- :help "Quit current search"
- :visible (not isearch-success)))
- (define-key map [isearch-cancel]
- `(menu-item "Cancel search" isearch-cancel
- :help "Cancel current search and return to starting point"
- :filter ,(lambda (binding)
- (if isearch-success 'isearch-abort binding))))
- map))
-
;; Note: Before adding more key bindings to this map, please keep in
;; mind that any unbound key exits Isearch and runs the command bound
;; to it in the local or global map. So in effect every key unbound
@@ -725,7 +620,7 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map "\M-n" 'isearch-ring-advance)
(define-key map "\M-p" 'isearch-ring-retreat)
- (define-key map "\M-y" 'isearch-yank-pop)
+ (define-key map "\M-y" 'isearch-yank-pop-only)
(define-key map "\M-\t" 'isearch-complete)
@@ -742,6 +637,7 @@ This is like `describe-bindings', but displays only Isearch keys."
;; For searching multilingual text.
(define-key map "\C-\\" 'isearch-toggle-input-method)
(define-key map "\C-^" 'isearch-toggle-specified-input-method)
+ (define-key map "\C-x\\" 'isearch-transient-input-method)
;; People expect to be able to paste with the mouse.
(define-key map [mouse-2] #'isearch-mouse-2)
@@ -770,14 +666,116 @@ This is like `describe-bindings', but displays only Isearch keys."
;; The key translations defined in the C-x 8 prefix should add
;; characters to the search string. See iso-transl.el.
(define-key map "\C-x8\r" 'isearch-char-by-name)
-
- (define-key map [menu-bar search-menu]
- (list 'menu-item "Isearch" isearch-menu-bar-map))
- (define-key map [remap tmm-menubar] 'isearch-tmm-menubar)
-
map)
"Keymap for `isearch-mode'.")
+(easy-menu-define isearch-menu-bar-map isearch-mode-map
+ "Menu for `isearch-mode'."
+ '("Isearch"
+ ["Cancel search" isearch-cancel
+ :help "Cancel current search and return to starting point"
+ :filter (lambda (binding)
+ (if isearch-success 'isearch-abort binding))]
+ ["Remove characters not found" isearch-abort
+ :help "Quit current search"
+ :visible (not isearch-success)]
+ ["Finish search" isearch-exit
+ :help "Finish search leaving point where it is"
+ :visible (not (string-equal isearch-string ""))]
+ ["Nonincremental search" isearch-exit
+ :help "Start nonincremental search"
+ :visible (string-equal isearch-string "")]
+ ["Repeat search forward" isearch-repeat-forward
+ :help "Repeat current search forward"]
+ ["Repeat search backward" isearch-repeat-backward
+ :help "Repeat current search backward"]
+ ["Go to first match" isearch-beginning-of-buffer
+ :help "Go to first occurrence of current search string"]
+ ["Go to last match" isearch-end-of-buffer
+ :help "Go to last occurrence of current search string"]
+ ["Undo last input item" isearch-delete-char
+ :help "Undo the effect of the last Isearch command"]
+ ["Delete last char from search string" isearch-del-char
+ :help "Delete last character from search string"]
+ ["Edit next search string" isearch-ring-advance
+ :help "Edit next search string in Isearch history"]
+ ["Edit previous search string" isearch-ring-retreat
+ :help "Edit previous search string in Isearch history"]
+ ["Edit current search string" isearch-edit-string
+ :help "Edit current search string"]
+ ("Yank on search string"
+ ["Char" isearch-yank-char
+ :help "Yank char at point on search string"]
+ ["Word/char"
+ isearch-yank-word-or-char
+ :help "Yank next word or char on search string"]
+ ["Symbol/char"
+ isearch-yank-symbol-or-char
+ :help "Yank next symbol or char on search string"]
+ ["Rest of line" isearch-yank-line
+ :help "Yank the rest of the current line on search string"]
+ ["Until char..." isearch-yank-until-char
+ :help "Yank from point to specified character into search string"]
+ ["Current kill" isearch-yank-kill
+ :help "Append current kill to search string"]
+ ["Previous kill" isearch-yank-pop-only
+ :help "Replace previous yanked kill on search string"])
+ "---"
+ ["Lax whitespace matching" isearch-toggle-lax-whitespace
+ :help "Lax whitespace matching"
+ :style toggle
+ :selected isearch-lax-whitespace]
+ ["Case folding matching" isearch-toggle-case-fold
+ :help "Case folding matching"
+ :style toggle
+ :selected isearch-case-fold-search]
+ ["Character folding matching" isearch-toggle-char-fold
+ :help "Character folding matching"
+ :style toggle
+ :selected (eq isearch-regexp-function
+ 'char-fold-to-regexp)]
+ ["Invisible text matching" isearch-toggle-invisible
+ :help "Invisible text matching"
+ :style toggle
+ :selected isearch-invisible]
+ ["Regexp matching" isearch-toggle-regexp
+ :help "Regexp matching"
+ :style toggle
+ :selected isearch-regexp]
+ ["Symbol matching" isearch-toggle-symbol
+ :help "Symbol matching"
+ :style toggle
+ :selected (eq isearch-regexp-function
+ 'isearch-symbol-regexp)]
+ ["Word matching" isearch-toggle-word
+ :help "Word matching"
+ :style toggle
+ :selected (eq isearch-regexp-function 'word-search-regexp)]
+ "---"
+ ["Search for literal char" isearch-quote-char
+ :help "Search for literal char"]
+ ["Search for char by name" isearch-char-by-name
+ :help "Search for character by name"]
+ "---"
+ ["Toggle input method" isearch-toggle-input-method
+ :help "Toggle input method for search"]
+ ["Turn on specific input method" isearch-toggle-specified-input-method
+ :help "Turn on specific input method for search"]
+ ["Turn on transient input method" isearch-transient-input-method
+ :help "Turn on transient input method for search"]
+ "---"
+ ["Highlight all matches for search string" isearch-highlight-regexp
+ :help "Highlight all matches for current search string"]
+ ["Show all matches for search string" isearch-occur
+ :help "Show all matches for current search string"]
+ ["Replace search string" isearch-query-replace
+ :help "Replace matches for current search string"]
+ ["Replace search string as regexp" isearch-query-replace-regexp
+ :help "Replace matches for current search string as regexp"]
+ "---"
+ ["Complete current search string" isearch-complete
+ :help "Complete current search string over search history"]))
+
(defvar isearch-tool-bar-old-map nil
"Variable holding the old local value of `tool-bar-map', if any.")
@@ -885,7 +883,7 @@ variable by the command `isearch-toggle-lax-whitespace'.")
"Stack of search status elements.
Each element is an `isearch--state' struct where the slots are
[STRING MESSAGE POINT SUCCESS FORWARD OTHER-END WORD/REGEXP-FUNCTION
- ERROR WRAPPED BARRIER CASE-FOLD-SEARCH POP-FUN]")
+ ERROR WRAPPED BARRIER CASE-FOLD-SEARCH POP-FUN MATCH-DATA]")
(defvar isearch-string "") ; The current search string.
(defvar isearch-message "") ; text-char-description version of isearch-string
@@ -901,6 +899,7 @@ Each element is an `isearch--state' struct where the slots are
"Recorded minimum/maximal point for the current search.")
(defvar isearch-just-started nil)
(defvar isearch-start-hscroll 0) ; hscroll when starting the search.
+(defvar isearch-match-data nil) ; match-data of regexp-based search
;; case-fold-search while searching.
;; either nil, t, or 'yes. 'yes means the same as t except that mixed
@@ -954,10 +953,6 @@ Each element is an `isearch--state' struct where the slots are
;; The value of input-method-function when isearch is invoked.
(defvar isearch-input-method-function nil)
-;; A flag to tell if input-method-function is locally bound when
-;; isearch is invoked.
-(defvar isearch-input-method-local-p nil)
-
(defvar isearch--saved-overriding-local-map nil)
;; Minor-mode-alist changes - kind of redundant with the
@@ -978,12 +973,13 @@ Each element is an `isearch--state' struct where the slots are
(defvar-local isearch-mode nil) ;; Name of the minor mode, if non-nil.
(define-key global-map "\C-s" 'isearch-forward)
-(define-key esc-map "\C-s" 'isearch-forward-regexp)
+(define-key esc-map "\C-s" 'isearch-forward-regexp)
(define-key global-map "\C-r" 'isearch-backward)
-(define-key esc-map "\C-r" 'isearch-backward-regexp)
-(define-key search-map "w" 'isearch-forward-word)
-(define-key search-map "_" 'isearch-forward-symbol)
-(define-key search-map "." 'isearch-forward-symbol-at-point)
+(define-key esc-map "\C-r" 'isearch-backward-regexp)
+(define-key search-map "w" 'isearch-forward-word)
+(define-key search-map "_" 'isearch-forward-symbol)
+(define-key search-map "." 'isearch-forward-symbol-at-point)
+(define-key search-map "\M-." 'isearch-forward-thing-at-point)
;; Entry points to isearch-mode.
@@ -1012,7 +1008,7 @@ Type \\[isearch-yank-until-char] to yank from point until the next instance of a
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
+Type \\[isearch-yank-pop-only] 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.
Type \\[isearch-char-by-name] to add a character to search by Unicode name,\
@@ -1072,6 +1068,8 @@ To use a different input method for searching, type \
\\[isearch-toggle-specified-input-method],
and specify an input method you want to use.
+To activate a transient input method, type \\[isearch-transient-input-method].
+
The above keys, bound in `isearch-mode-map', are often controlled by
options; do \\[apropos] on search-.* to find them.
Other control and meta characters terminate the search
@@ -1161,6 +1159,42 @@ positive, or search for ARGth symbol backward if ARG is negative."
(isearch-push-state)
(isearch-update)))))
+(defcustom isearch-forward-thing-at-point '(region url symbol sexp)
+ "A list of symbols to try to get the \"thing\" at point.
+Each element of the list should be one of the symbols supported by
+`bounds-of-thing-at-point'. This variable is used by the command
+`isearch-forward-thing-at-point' to yank the initial \"thing\"
+as text to the search string."
+ :type '(repeat (symbol :tag "Thing symbol"))
+ :version "28.1")
+
+(defun isearch-forward-thing-at-point ()
+ "Do incremental search forward for the \"thing\" found near point.
+Like ordinary incremental search except that the \"thing\" found at point
+is added to the search string initially. The \"thing\" is defined by
+`bounds-of-thing-at-point'. You can customize the variable
+`isearch-forward-thing-at-point' to define a list of symbols to try
+to find a \"thing\" at point. For example, when the list contains
+the symbol `region' and the region is active, then text from the
+active region is added to the search string."
+ (interactive)
+ (isearch-forward nil 1)
+ (let ((bounds (seq-some (lambda (thing)
+ (bounds-of-thing-at-point thing))
+ isearch-forward-thing-at-point)))
+ (cond
+ (bounds
+ (when (use-region-p)
+ (deactivate-mark))
+ (when (< (car bounds) (point))
+ (goto-char (car bounds)))
+ (isearch-yank-string
+ (buffer-substring-no-properties (car bounds) (cdr bounds))))
+ (t
+ (setq isearch-error "No thing at point")
+ (isearch-push-state)
+ (isearch-update)))))
+
;; isearch-mode only sets up incremental search for the minor mode.
;; All the work is done by the isearch-mode commands.
@@ -1219,12 +1253,12 @@ used to set the value of `isearch-regexp-function'."
isearch-small-window nil
isearch-just-started t
isearch-start-hscroll (window-hscroll)
+ isearch-match-data nil
isearch-opoint (point)
search-ring-yank-pointer nil
isearch-opened-overlays nil
isearch-input-method-function input-method-function
- isearch-input-method-local-p (local-variable-p 'input-method-function)
regexp-search-ring-yank-pointer nil
isearch-pre-scroll-point nil
@@ -1245,9 +1279,7 @@ used to set the value of `isearch-regexp-function'."
;; We must bypass input method while reading key. When a user type
;; printable character, appropriate input method is turned on in
;; minibuffer to read multibyte characters.
- (or isearch-input-method-local-p
- (make-local-variable 'input-method-function))
- (setq input-method-function nil)
+ (setq-local input-method-function nil)
(looking-at "")
(setq isearch-window-configuration
@@ -1343,12 +1375,13 @@ The last thing is to trigger a new round of lazy highlighting."
;; the X coordinate it returns is 1 pixel beyond
;; the last visible one.
(>= (car visible-p)
- (* (window-max-chars-per-line) (frame-char-width))))
+ (* (window-max-chars-per-line) (frame-char-width)))
+ (< (car visible-p) 0))
(set-window-hscroll (selected-window) current-scroll))))
(if isearch-other-end
(if (< isearch-other-end (point)) ; isearch-forward?
- (isearch-highlight isearch-other-end (point))
- (isearch-highlight (point) isearch-other-end))
+ (isearch-highlight isearch-other-end (point) isearch-match-data)
+ (isearch-highlight (point) isearch-other-end isearch-match-data))
(isearch-dehighlight))))
(setq ;; quit-flag nil not for isearch-mode
isearch-adjusted nil
@@ -1404,8 +1437,8 @@ NOPUSH is t and EDIT is t."
(set-window-group-start (selected-window) found-start t))))
(setq isearch-mode nil)
- (if isearch-input-method-local-p
- (setq input-method-function isearch-input-method-function)
+ (if isearch-input-method-function
+ (setq-local input-method-function isearch-input-method-function)
(kill-local-variable 'input-method-function))
(if isearch-tool-bar-old-map
@@ -1478,7 +1511,7 @@ REGEXP if non-nil says use the regexp search ring."
(apply 'propertize string properties))
(defun isearch-update-from-string-properties (string)
- "Update isearch properties from the isearch string"
+ "Update isearch properties from the isearch STRING."
(when (plist-member (text-properties-at 0 string) 'isearch-case-fold-search)
(setq isearch-case-fold-search
(get-text-property 0 'isearch-case-fold-search string)))
@@ -1506,7 +1539,8 @@ REGEXP if non-nil says use the regexp search ring."
(barrier isearch-barrier)
(case-fold-search isearch-case-fold-search)
(pop-fun (if isearch-push-state-function
- (funcall isearch-push-state-function))))))
+ (funcall isearch-push-state-function)))
+ (match-data isearch-match-data))))
(string nil :read-only t)
(message nil :read-only t)
(point nil :read-only t)
@@ -1518,7 +1552,8 @@ REGEXP if non-nil says use the regexp search ring."
(wrapped nil :read-only t)
(barrier nil :read-only t)
(case-fold-search nil :read-only t)
- (pop-fun nil :read-only t))
+ (pop-fun nil :read-only t)
+ (match-data nil :read-only t))
(defun isearch--set-state (cmd)
(setq isearch-string (isearch--state-string cmd)
@@ -1530,7 +1565,8 @@ REGEXP if non-nil says use the regexp search ring."
isearch-error (isearch--state-error cmd)
isearch-wrapped (isearch--state-wrapped cmd)
isearch-barrier (isearch--state-barrier cmd)
- isearch-case-fold-search (isearch--state-case-fold-search cmd))
+ isearch-case-fold-search (isearch--state-case-fold-search cmd)
+ isearch-match-data (isearch--state-match-data cmd))
(if (functionp (isearch--state-pop-fun cmd))
(funcall (isearch--state-pop-fun cmd) cmd))
(goto-char (isearch--state-point cmd)))
@@ -1593,7 +1629,8 @@ If this is set inside code wrapped by the macro
"Exit Isearch mode, run BODY, and reinvoke the pending search.
You can update the global isearch variables by setting new values to
`isearch-new-string', `isearch-new-message', `isearch-new-forward',
-`isearch-new-regexp-function', `isearch-new-case-fold', `isearch-new-nonincremental'."
+`isearch-new-regexp-function', `isearch-new-case-fold',
+`isearch-new-nonincremental'."
;; This code is very hairy for several reasons, explained in the code.
;; Mainly, isearch-mode must be terminated while editing and then restarted.
;; If there were a way to catch any change of buffer from the minibuffer,
@@ -1622,6 +1659,7 @@ You can update the global isearch variables by setting new values to
(isearch-adjusted isearch-adjusted)
(isearch-yank-flag isearch-yank-flag)
(isearch-error isearch-error)
+ (isearch-match-data isearch-match-data)
(multi-isearch-file-list-new multi-isearch-file-list)
(multi-isearch-buffer-list-new multi-isearch-buffer-list)
@@ -1851,14 +1889,15 @@ Use `isearch-exit' to quit without signaling."
;; After taking the last element, adjust ring to previous one.
(isearch-ring-adjust1 nil))
;; If already have what to search for, repeat it.
- (or isearch-success
- (progn
- ;; Set isearch-wrapped before calling isearch-wrap-function
- (setq isearch-wrapped t)
- (if isearch-wrap-function
- (funcall isearch-wrap-function)
- (goto-char (if isearch-forward (point-min) (point-max)))))))
+ (unless (or isearch-success (null isearch-wrap-pause))
+ ;; Set isearch-wrapped before calling isearch-wrap-function
+ (setq isearch-wrapped t)
+ (if isearch-wrap-function
+ (funcall isearch-wrap-function)
+ (goto-char (if isearch-forward (point-min) (point-max))))))
;; C-s in reverse or C-r in forward, change direction.
+ (if (and isearch-other-end isearch-repeat-on-direction-change)
+ (goto-char isearch-other-end))
(setq isearch-forward (not isearch-forward)
isearch-success t))
@@ -1868,7 +1907,8 @@ Use `isearch-exit' to quit without signaling."
(setq isearch-success t)
;; For the case when count > 1, don't keep intermediate states
;; added to isearch-cmds by isearch-push-state in this loop.
- (let ((isearch-cmds isearch-cmds))
+ (let ((isearch-cmds isearch-cmds)
+ (was-success isearch-success))
(while (<= 0 (setq count (1- (or count 1))))
(if (and isearch-success
(equal (point) isearch-other-end)
@@ -1883,13 +1923,26 @@ Use `isearch-exit' to quit without signaling."
(forward-char (if isearch-forward 1 -1))
(isearch-search))
(isearch-search))
- (when (> count 0)
- ;; Update isearch-cmds, so if isearch-search fails later,
- ;; it can restore old successful state from isearch-cmds.
- (isearch-push-state))
- ;; Stop looping on failure.
- (when (or (not isearch-success) isearch-error)
- (setq count 0)))))
+ (when (> count 0)
+ ;; Update isearch-cmds, so if isearch-search fails later,
+ ;; it can restore old successful state from isearch-cmds.
+ (isearch-push-state))
+ (cond
+ ;; Wrap immediately and repeat the search again
+ ((memq isearch-wrap-pause '(no no-ding))
+ (if isearch-success
+ (setq was-success isearch-success)
+ ;; If failed this time after succeeding last time
+ (when was-success
+ (setq was-success nil)
+ (setq count (1+ count)) ;; Increment to force repeat
+ (setq isearch-wrapped t)
+ (if isearch-wrap-function
+ (funcall isearch-wrap-function)
+ (goto-char (if isearch-forward (point-min) (point-max)))))))
+ ;; Stop looping on failure
+ (t (when (or (not isearch-success) isearch-error)
+ (setq count 0)))))))
(isearch-push-state)
(isearch-update))
@@ -1908,10 +1961,12 @@ of the buffer, type \\[isearch-beginning-of-buffer] with a numeric argument."
(cond ((< count 0)
(isearch-repeat-backward (abs count))
;; Reverse the direction back
- (isearch-repeat 'forward))
+ (let ((isearch-repeat-on-direction-change nil))
+ (isearch-repeat 'forward)))
(t
;; Take into account one iteration to reverse direction
- (when (not isearch-forward) (setq count (1+ count)))
+ (unless isearch-repeat-on-direction-change
+ (when (not isearch-forward) (setq count (1+ count))))
(isearch-repeat 'forward count))))
(isearch-repeat 'forward)))
@@ -1929,10 +1984,12 @@ of the buffer, type \\[isearch-end-of-buffer] with a numeric argument."
(cond ((< count 0)
(isearch-repeat-forward (abs count))
;; Reverse the direction back
- (isearch-repeat 'backward))
+ (let ((isearch-repeat-on-direction-change nil))
+ (isearch-repeat 'backward)))
(t
;; Take into account one iteration to reverse direction
- (when isearch-forward (setq count (1+ count)))
+ (unless isearch-repeat-on-direction-change
+ (when isearch-forward (setq count (1+ count))))
(isearch-repeat 'backward count))))
(isearch-repeat 'backward)))
@@ -2016,15 +2073,16 @@ Turning on character-folding turns off regexp mode.")
(defvar isearch-message-properties minibuffer-prompt-properties
"Text properties that are added to the isearch prompt.")
-(defun isearch--momentary-message (string)
- "Print STRING at the end of the isearch prompt for 1 second."
+(defun isearch--momentary-message (string &optional seconds)
+ "Print STRING at the end of the isearch prompt for 1 second.
+The optional argument SECONDS overrides the number of seconds."
(let ((message-log-max nil))
(message "%s%s%s"
(isearch-message-prefix nil isearch-nonincremental)
isearch-message
(apply #'propertize (format " [%s]" string)
isearch-message-properties)))
- (sit-for 1))
+ (sit-for (or seconds 1)))
(isearch-define-mode-toggle lax-whitespace " " nil
"In ordinary search, toggles the value of the variable
@@ -2341,7 +2399,7 @@ characters in that string."
(with-isearch-suspended
(setq regexp-collect
(read-regexp
- (format "Regexp to collect (default %s): " default)
+ (format-prompt "Regexp to collect" default)
default 'occur-collect-regexp-history)))
regexp-collect))
;; Otherwise normal occur takes numerical prefix argument.
@@ -2386,22 +2444,17 @@ respectively)."
(funcall isearch-regexp-function isearch-string))
(isearch-regexp-function (word-search-regexp isearch-string))
(isearch-regexp isearch-string)
- ((if (and (eq isearch-case-fold-search t)
- search-upper-case)
- (isearch-no-upper-case-p
- isearch-string isearch-regexp)
- isearch-case-fold-search)
- ;; Turn isearch-string into a case-insensitive
- ;; regexp.
- (mapconcat
- (lambda (c)
- (let ((s (string c)))
- (if (string-match "[[:alpha:]]" s)
- (format "[%s%s]" (upcase s) (downcase s))
- (regexp-quote s))))
- isearch-string ""))
(t (regexp-quote isearch-string)))))
- (funcall hi-lock-func regexp (hi-lock-read-face-name)))
+ (let ((case-fold-search isearch-case-fold-search)
+ ;; Set `search-upper-case' to nil to not call
+ ;; `isearch-no-upper-case-p' in `hi-lock'.
+ (search-upper-case nil)
+ (search-spaces-regexp
+ (if (if isearch-regexp
+ isearch-regexp-lax-whitespace
+ isearch-lax-whitespace)
+ search-whitespace-regexp)))
+ (funcall hi-lock-func regexp (hi-lock-read-face-name) isearch-string)))
(and isearch-recursive-edit (exit-recursive-edit)))
(defun isearch-highlight-regexp ()
@@ -2409,14 +2462,18 @@ respectively)."
The arguments passed to `highlight-regexp' are the regexp from
the last search and the face from `hi-lock-read-face-name'."
(interactive)
- (isearch--highlight-regexp-or-lines 'highlight-regexp))
+ (isearch--highlight-regexp-or-lines
+ #'(lambda (regexp face lighter)
+ (highlight-regexp regexp face nil lighter))))
(defun isearch-highlight-lines-matching-regexp ()
"Exit Isearch mode and call `highlight-lines-matching-regexp'.
The arguments passed to `highlight-lines-matching-regexp' are the
regexp from the last search and the face from `hi-lock-read-face-name'."
(interactive)
- (isearch--highlight-regexp-or-lines 'highlight-lines-matching-regexp))
+ (isearch--highlight-regexp-or-lines
+ #'(lambda (regexp face _lighter)
+ (highlight-lines-matching-regexp regexp face))))
(defun isearch-delete-char ()
@@ -2478,18 +2535,55 @@ If search string is empty, just beep."
(unless isearch-mode (isearch-mode t))
(isearch-yank-string (current-kill 0)))
+(defun isearch-yank-from-kill-ring ()
+ "Read a string from the `kill-ring' and append it to the search string."
+ (interactive)
+ (with-isearch-suspended
+ (let ((string (read-from-kill-ring "Yank from kill-ring: ")))
+ (if (and isearch-case-fold-search
+ (eq 'not-yanks search-upper-case))
+ (setq string (downcase string)))
+ (if isearch-regexp (setq string (regexp-quote string)))
+ (setq isearch-yank-flag t)
+ (setq isearch-new-string (concat isearch-string string)
+ isearch-new-message (concat isearch-message
+ (mapconcat 'isearch-text-char-description
+ string ""))))))
+
(defun isearch-yank-pop ()
- "Replace just-yanked search string with previously killed string."
+ "Replace just-yanked search string with previously killed string.
+Unlike `isearch-yank-pop-only', when this command is called not immediately
+after a `isearch-yank-kill' or a `isearch-yank-pop', it activates the
+minibuffer to read a string from the `kill-ring' as `yank-pop' does."
(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)
+ (if (not (memq last-command '(isearch-yank-kill
+ isearch-yank-pop isearch-yank-pop-only)))
+ (isearch-yank-from-kill-ring)
(isearch-pop-state)
(isearch-yank-string (current-kill 1))))
+(defun isearch-yank-pop-only (&optional arg)
+ "Replace just-yanked search string with previously killed string.
+Unlike `isearch-yank-pop', when this command is called not immediately
+after a `isearch-yank-kill' or a `isearch-yank-pop-only', it only pops
+the last killed string instead of activating the minibuffer to read
+a string from the `kill-ring' as `yank-pop' does. The prefix arg \\[universal-argument]
+always reads a string from the `kill-ring' using the minibuffer."
+ (interactive "P")
+ (cond
+ ((equal arg '(4))
+ (isearch-yank-from-kill-ring))
+ ((not (memq last-command '(isearch-yank-kill
+ isearch-yank-pop isearch-yank-pop-only)))
+ ;; 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, `M-y' could be changed from `isearch-yank-pop-only'
+ ;; to `isearch-yank-pop' that uses the kill-ring-browser.
+ (isearch-yank-kill))
+ (t
+ (isearch-pop-state)
+ (isearch-yank-string (current-kill 1)))))
+
(defun isearch-yank-x-selection ()
"Pull current X selection into search string."
(interactive)
@@ -2506,7 +2600,9 @@ Otherwise invoke whatever the calling mouse-2 command sequence
is bound to outside of Isearch."
(interactive "e")
(let ((w (posn-window (event-start click)))
- (binding (let ((overriding-terminal-local-map nil))
+ (binding (let ((overriding-terminal-local-map nil)
+ ;; Key search depends on mode (bug#47755)
+ (isearch-mode nil))
(key-binding (this-command-keys-vector) t))))
(if (and (window-minibuffer-p w)
(not (minibuffer-window-active-p w))) ; in echo area
@@ -2523,6 +2619,8 @@ is bound to outside of Isearch."
(let ((pasted-text (nth 1 event)))
(isearch-yank-string pasted-text))))
+(defvar isearch--yank-prev-point nil)
+
(defun isearch-yank-internal (jumpform)
"Pull the text from point to the point reached by JUMPFORM.
JUMPFORM is a lambda expression that takes no arguments and returns
@@ -2533,7 +2631,14 @@ or it might return the position of the end of the line."
(save-excursion
(and (not isearch-forward) isearch-other-end
(goto-char isearch-other-end))
- (buffer-substring-no-properties (point) (funcall jumpform)))))
+ (and (not isearch-success) isearch--yank-prev-point
+ (goto-char isearch--yank-prev-point))
+ (buffer-substring-no-properties
+ (point)
+ (prog1
+ (setq isearch--yank-prev-point (funcall jumpform))
+ (when isearch-success
+ (setq isearch--yank-prev-point nil)))))))
(defun isearch-yank-char-in-minibuffer (&optional arg)
"Pull next character from buffer into end of search string in minibuffer."
@@ -2623,7 +2728,7 @@ With argument, add COUNT copies of the character."
string ""))))))))
(defun isearch-search-and-update ()
- ;; Do the search and update the display.
+ "Do the search and update the display."
(when (or isearch-success
;; Unsuccessful regexp search may become successful by
;; addition of characters which make isearch-string valid
@@ -2940,7 +3045,7 @@ See more for options in `search-exit-option'."
((and (eq (car-safe main-event) 'down-mouse-1)
(window-minibuffer-p (posn-window (event-start main-event))))
;; Swallow the up-event.
- (read-event)
+ (read--potential-mouse-event)
(setq this-command 'isearch-edit-string))
;; Don't terminate the search for motion commands.
((and isearch-yank-on-move
@@ -3155,7 +3260,7 @@ If there is no completion possible, say so and continue searching."
;; Message string
(defun isearch-message (&optional c-q-hack ellipsis)
- ;; Generate and print the message string.
+ "Generate and print the message string."
;; N.B.: This function should always be called with point at the
;; search point, because in certain (rare) circumstances, undesired
@@ -3242,6 +3347,8 @@ the word mode."
(< (point) isearch-opoint)))
"over")
(if isearch-wrapped "wrapped ")
+ (if (and (not isearch-success) (buffer-narrowed-p) widen-automatically)
+ "narrowed " "")
(if (and (not isearch-success) (not isearch-case-fold-search))
"case-sensitive ")
(let ((prefix ""))
@@ -3282,7 +3389,7 @@ the word mode."
(defun isearch-lazy-count-format (&optional suffix-p)
"Format the current match number and the total number of matches.
-When SUFFIX-P is non-nil, the returned string is indended for
+When SUFFIX-P is non-nil, the returned string is intended for
isearch-message-suffix prompt. Otherwise, for isearch-message-prefix."
(let ((format-string (if suffix-p
lazy-count-suffix-format
@@ -3293,7 +3400,7 @@ isearch-message-suffix prompt. Otherwise, for isearch-message-prefix."
(not isearch-error)
(not isearch-suspended))
(format format-string
- (if isearch-forward
+ (if isearch-lazy-highlight-forward
isearch-lazy-count-current
(if (eq isearch-lazy-count-current 0)
0
@@ -3400,14 +3507,13 @@ Optional third argument, if t, means if fail just return nil (no error).
(when pos1
;; When using multiple buffers isearch, switch to the new buffer here,
;; because `save-excursion' above doesn't allow doing it inside funcall.
- (if (and multi-isearch-next-buffer-current-function
- (buffer-live-p multi-isearch-current-buffer))
- (switch-to-buffer multi-isearch-current-buffer))
+ (when multi-isearch-next-buffer-current-function
+ (multi-isearch-switch-buffer))
(goto-char pos1)
pos1)))
(defun isearch-search ()
- ;; Do the search with the current search string.
+ "Do the search with the current search string."
(if (and (eq isearch-case-fold-search t) search-upper-case)
(setq isearch-case-fold-search
(isearch-no-upper-case-p isearch-string isearch-regexp)))
@@ -3424,15 +3530,19 @@ Optional third argument, if t, means if fail just return nil (no error).
;; Clear RETRY unless the search predicate says
;; to skip this search hit.
(if (or (not isearch-success)
- (bobp) (eobp)
- (= (match-beginning 0) (match-end 0))
(funcall isearch-filter-predicate
(match-beginning 0) (match-end 0)))
- (setq retry nil)))
+ (setq retry nil)
+ ;; Advance point on empty matches before retrying
+ (when (= (match-beginning 0) (match-end 0))
+ (if (if isearch-forward (eobp) (bobp))
+ (setq retry nil isearch-success nil)
+ (forward-char (if isearch-forward 1 -1))))))
(setq isearch-just-started nil)
- (if isearch-success
- (setq isearch-other-end
- (if isearch-forward (match-beginning 0) (match-end 0)))))
+ (when isearch-success
+ (setq isearch-other-end
+ (if isearch-forward (match-beginning 0) (match-end 0)))
+ (setq isearch-match-data (match-data t))))
(quit (isearch-unread ?\C-g)
(setq isearch-success nil))
@@ -3448,7 +3558,10 @@ Optional third argument, if t, means if fail just return nil (no error).
(string-match "\\`Regular expression too big" isearch-error))
(cond
(isearch-regexp-function
- (setq isearch-error "Too many words"))
+ (setq isearch-error nil)
+ (setq isearch-regexp-function nil)
+ (isearch-search-and-update)
+ (isearch--momentary-message "Too many words; switched to literal mode" 2))
((and isearch-lax-whitespace search-whitespace-regexp)
(setq isearch-error "Too many spaces for whitespace matching"))))))
@@ -3460,10 +3573,10 @@ Optional third argument, if t, means if fail just return nil (no error).
;; stack overflow in regexp search.
(setq isearch-error (format "%s" lossage))))
- (if isearch-success
- nil
+ (unless isearch-success
;; Ding if failed this time after succeeding last time.
(and (isearch--state-success (car isearch-cmds))
+ (not (eq isearch-wrap-pause 'no-ding))
(ding))
(if (functionp (isearch--state-pop-fun (car isearch-cmds)))
(funcall (isearch--state-pop-fun (car isearch-cmds))
@@ -3656,8 +3769,29 @@ since they have special meaning in a regexp."
;; Highlighting
(defvar isearch-overlay nil)
+(defvar isearch-submatches-overlays nil)
-(defun isearch-highlight (beg end)
+(defface isearch-group-1
+ '((((class color) (min-colors 88) (background light))
+ (:background "#f000f0" :foreground "lightskyblue1"))
+ (((class color) (min-colors 88) (background dark))
+ (:background "palevioletred1" :foreground "brown4"))
+ (t (:inherit isearch)))
+ "Face for highlighting Isearch the odd group matches."
+ :group 'isearch
+ :version "28.1")
+
+(defface isearch-group-2
+ '((((class color) (min-colors 88) (background light))
+ (:background "#a000a0" :foreground "lightskyblue1"))
+ (((class color) (min-colors 88) (background dark))
+ (:background "palevioletred3" :foreground "brown4"))
+ (t (:inherit isearch)))
+ "Face for highlighting Isearch the even group matches."
+ :group 'isearch
+ :version "28.1")
+
+(defun isearch-highlight (beg end &optional match-data)
(if search-highlight
(if isearch-overlay
;; Overlay already exists, just move it.
@@ -3666,11 +3800,37 @@ 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-face))))
+ (overlay-put isearch-overlay 'face isearch-face)))
+
+ (when (and search-highlight-submatches isearch-regexp)
+ (mapc 'delete-overlay isearch-submatches-overlays)
+ (setq isearch-submatches-overlays nil)
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr match-data))
+ (group 0)
+ b e ov face)
+ (while submatch-data
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov isearch-submatches-overlays))))))
(defun isearch-dehighlight ()
(when isearch-overlay
- (delete-overlay isearch-overlay)))
+ (delete-overlay isearch-overlay))
+ (when search-highlight-submatches
+ (mapc 'delete-overlay isearch-submatches-overlays)
+ (setq isearch-submatches-overlays nil)))
+
;; isearch-lazy-highlight feature
;; by Bob Glickstein <http://www.zanshin.com/~bobg/>
@@ -3802,7 +3962,8 @@ by other Emacs features."
(clrhash isearch-lazy-count-hash)
(setq isearch-lazy-count-current nil
isearch-lazy-count-total nil)
- (isearch-message)))
+ ;; Delay updating the message if possible, to avoid flicker
+ (when (string-equal isearch-string "") (isearch-message))))
(setq isearch-lazy-highlight-window-start-changed nil)
(setq isearch-lazy-highlight-window-end-changed nil)
(setq isearch-lazy-highlight-error isearch-error)
@@ -3847,7 +4008,11 @@ by other Emacs features."
(point-min))))
(unless (equal isearch-string "")
(setq isearch-lazy-highlight-timer
- (run-with-idle-timer lazy-highlight-initial-delay nil
+ (run-with-idle-timer (if (>= (length isearch-string)
+ lazy-highlight-no-delay-length)
+ 0
+ lazy-highlight-initial-delay)
+ nil
'isearch-lazy-highlight-start))))
;; Update the current match number only in isearch-mode and
;; unless isearch-mode is used specially with isearch-message-function
@@ -3871,9 +4036,10 @@ Attempt to do the search exactly the way the pending Isearch would."
(isearch-regexp-lax-whitespace
isearch-lazy-highlight-regexp-lax-whitespace)
(isearch-forward isearch-lazy-highlight-forward)
- ;; Match invisible text only when counting matches
- ;; and user can visit invisible matches
- (search-invisible (and isearch-lazy-count search-invisible t))
+ ;; Don't match invisible text unless it can be opened
+ ;; or when counting matches and user can visit hidden matches
+ (search-invisible (or (eq search-invisible 'open)
+ (and isearch-lazy-count search-invisible)))
(retry t)
(success nil))
;; Use a loop like in `isearch-search'.
@@ -3882,7 +4048,6 @@ 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)))
@@ -3996,13 +4161,13 @@ Attempt to do the search exactly the way the pending Isearch would."
"Update highlighting of other matches in the full buffer."
(let ((max lazy-highlight-buffer-max-at-a-time)
(looping t)
- nomore window-start window-end
- (opoint (point)))
+ nomore opoint window-start window-end)
(with-local-quit
(save-selected-window
(if (and (window-live-p isearch-lazy-highlight-window)
(not (memq (selected-window) isearch-lazy-highlight-window-group)))
(select-window isearch-lazy-highlight-window))
+ (setq opoint (point))
(setq window-start (window-group-start))
(setq window-end (window-group-end))
(save-excursion
diff --git a/lisp/isearchb.el b/lisp/isearchb.el
index 3713879e3b6..eaf7983cbd8 100644
--- a/lisp/isearchb.el
+++ b/lisp/isearchb.el
@@ -1,4 +1,4 @@
-;;; isearchb --- a marriage between iswitchb and isearch
+;;; isearchb.el --- a marriage between iswitchb and isearch -*- lexical-binding: t -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -7,7 +7,6 @@
;; Created: 16 Apr 2004
;; Version: 1.5
;; Keywords: lisp
-;; X-URL: http://www.newartisans.com/johnw/emacs.html
;; This file is part of GNU Emacs.
@@ -89,13 +88,11 @@
"Number of idle seconds before isearchb turns itself off.
If nil, don't use a timeout."
:type '(choice (integer :tag "Seconds")
- (const :tag "Disable" nil))
- :group 'isearchb)
+ (const :tag "Disable" nil)))
(defcustom isearchb-show-completions t
"If non-nil, show possible completions in the minibuffer."
- :type 'boolean
- :group 'isearchb)
+ :type 'boolean)
(defvar isearchb-start-buffer nil)
(defvar isearchb-last-buffer nil)
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index 12031132eda..a1287926eb9 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -48,8 +48,7 @@ Preserves the `buffer-modified-p' state of the current buffer."
"Jit-lock fontifies chunks of at most this many characters at a time.
This variable controls both display-time and stealth fontification."
- :type 'integer
- :group 'jit-lock)
+ :type 'integer)
(defcustom jit-lock-stealth-time nil
@@ -59,8 +58,7 @@ If nil, stealth fontification is never performed.
The value of this variable is used when JIT Lock mode is turned on."
:type '(choice (const :tag "never" nil)
- (number :tag "seconds" :value 16))
- :group 'jit-lock)
+ (number :tag "seconds" :value 16)))
(defcustom jit-lock-stealth-nice 0.5
@@ -72,8 +70,7 @@ To reduce machine load during stealth fontification, at the cost of stealth
taking longer to fontify, you could increase the value of this variable.
See also `jit-lock-stealth-load'."
:type '(choice (const :tag "never" nil)
- (number :tag "seconds"))
- :group 'jit-lock)
+ (number :tag "seconds")))
(defcustom jit-lock-stealth-load
@@ -89,14 +86,12 @@ See also `jit-lock-stealth-nice'."
:type (if (condition-case nil (load-average) (error))
'(choice (const :tag "never" nil)
(integer :tag "load"))
- '(const :format "%t: unsupported\n" nil))
- :group 'jit-lock)
+ '(const :format "%t: unsupported\n" nil)))
(defcustom jit-lock-stealth-verbose nil
"If non-nil, means stealth fontification should show status messages."
- :type 'boolean
- :group 'jit-lock)
+ :type 'boolean)
(defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually)
@@ -110,7 +105,7 @@ This means those subsequent lines are refontified to reflect their new
syntactic context, after `jit-lock-context-time' seconds.
If any other value, e.g., `syntax-driven', it means refontification of
subsequent lines to reflect their new syntactic context may or may not
-occur after `jit-lock-context-time', depending on the the font-lock
+occur after `jit-lock-context-time', depending on the font-lock
definitions of the buffer. Specifically, if `font-lock-keywords-only'
is nil in a buffer, which generally means the syntactic fontification
is done using the buffer mode's syntax table, the syntactic
@@ -121,13 +116,11 @@ and sets the buffer-local value of `jit-lock-contextually' to t).
The value of this variable is used when JIT Lock mode is turned on."
:type '(choice (const :tag "never" nil)
(const :tag "always" t)
- (other :tag "syntax-driven" syntax-driven))
- :group 'jit-lock)
+ (other :tag "syntax-driven" syntax-driven)))
(defcustom jit-lock-context-time 0.5
"Idle time after which text is contextually refontified, if applicable."
- :type '(number :tag "seconds")
- :group 'jit-lock)
+ :type '(number :tag "seconds"))
(defcustom jit-lock-antiblink-grace 2
"Delay after which to refontify unterminated strings and comments.
@@ -140,14 +133,12 @@ and comments, the delay helps avoid unpleasant \"blinking\", between
string/comment and non-string/non-comment fontification."
:type '(choice (const :tag "never" nil)
(number :tag "seconds"))
- :group 'jit-lock
:version "27.1")
(defcustom jit-lock-defer-time nil ;; 0.25
"Idle time after which deferred fontification should take place.
If nil, fontification is not deferred.
If 0, then fontification is only deferred while there is input pending."
- :group 'jit-lock
:type '(choice (const :tag "never" nil)
(number :tag "seconds")))
@@ -156,9 +147,10 @@ If 0, then fontification is only deferred while there is input pending."
(defvar-local jit-lock-mode nil
"Non-nil means Just-in-time Lock mode is active.")
-(defvar-local jit-lock-functions nil
- "Functions to do the actual fontification.
-They are called with two arguments: the START and END of the region to fontify.")
+(defvar jit-lock-functions nil
+ "Special hook run to do the actual fontification.
+The functions are called with two arguments:
+the START and END of the region to fontify.")
(defvar-local jit-lock-context-unfontify-pos nil
"Consider text after this position as contextually unfontified.
@@ -268,7 +260,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'."
;; Setup our hooks.
(add-hook 'after-change-functions 'jit-lock-after-change nil t)
- (add-hook 'fontification-functions 'jit-lock-function))
+ (add-hook 'fontification-functions 'jit-lock-function nil t))
;; Turn Just-in-time Lock mode off.
(t
@@ -300,7 +292,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'."
When this minor mode is enabled, jit-lock runs as little code as possible
during redisplay and moves the rest to a timer, where things
like `debug-on-error' and Edebug can be used."
- :global t :group 'jit-lock
+ :global t
(when jit-lock-defer-timer
(cancel-timer jit-lock-defer-timer)
(setq jit-lock-defer-timer nil))
@@ -350,7 +342,8 @@ If non-nil, CONTEXTUAL means that a contextual fontification would be useful."
"Unregister FUN as a fontification function.
Only applies to the current buffer."
(remove-hook 'jit-lock-functions fun t)
- (unless jit-lock-functions (jit-lock-mode nil)))
+ (when (member jit-lock-functions '(nil '(t)))
+ (jit-lock-mode nil)))
(defun jit-lock-refontify (&optional beg end)
"Force refontification of the region BEG..END (default whole buffer)."
@@ -444,8 +437,8 @@ Defaults to the whole buffer. END can be out of bounds."
(quit (put-text-property start next 'fontified nil)
(signal (car err) (cdr err))))))
- ;; In case we fontified more than requested, take advantage of the
- ;; good news.
+ ;; In case we fontified more than requested, take
+ ;; advantage of the good news.
(when (or (< tight-beg start) (> tight-end next))
(put-text-property tight-beg tight-end 'fontified t))
diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el
index 3c7d2a057d5..6933a7c1d06 100644
--- a/lisp/jka-cmpr-hook.el
+++ b/lisp/jka-cmpr-hook.el
@@ -1,4 +1,4 @@
-;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el
+;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 1997, 1999-2000, 2002-2021 Free Software
;; Foundation, Inc.
@@ -93,6 +93,7 @@ Otherwise, it is nil.")
"\\)" file-name-version-regexp "?\\'"))))
;; Functions for accessing the return value of jka-compr-get-compression-info
+;; FIXME: Use cl-defstruct!
(defun jka-compr-info-regexp (info) (aref info 0))
(defun jka-compr-info-compress-message (info) (aref info 1))
(defun jka-compr-info-compress-program (info) (aref info 2))
@@ -103,6 +104,9 @@ Otherwise, it is nil.")
(defun jka-compr-info-can-append (info) (aref info 7))
(defun jka-compr-info-strip-extension (info) (aref info 8))
(defun jka-compr-info-file-magic-bytes (info) (aref info 9))
+(defun jka-compr-info-uncompress-function (info)
+ (and (> (length info) 10)
+ (aref info 10)))
(defun jka-compr-get-compression-info (filename)
@@ -196,13 +200,15 @@ options through Custom does this automatically."
;;[regexp
;; compr-message compr-prog compr-args
;; uncomp-message uncomp-prog uncomp-args
- ;; can-append strip-extension-flag file-magic-bytes]
+ ;; can-append strip-extension-flag file-magic-bytes
+ ;; uncompress-function]
(mapcar 'purecopy
'(["\\.Z\\'"
"compressing" "compress" ("-c")
;; gzip is more common than uncompress. It can only read, not write.
"uncompressing" "gzip" ("-c" "-q" "-d")
- nil t "\037\235"]
+ nil t "\037\235"
+ zlib-decompress-region]
;; 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".
@@ -217,11 +223,13 @@ options through Custom does this automatically."
["\\.\\(?:tgz\\|svgz\\|sifz\\)\\'"
"compressing" "gzip" ("-c" "-q")
"uncompressing" "gzip" ("-c" "-q" "-d")
- t nil "\037\213"]
+ t nil "\037\213"
+ zlib-decompress-region]
["\\.g?z\\'"
"compressing" "gzip" ("-c" "-q")
"uncompressing" "gzip" ("-c" "-q" "-d")
- t t "\037\213"]
+ t t "\037\213"
+ zlib-decompress-region]
["\\.lz\\'"
"Lzip compressing" "lzip" ("-c" "-q")
"Lzip uncompressing" "lzip" ("-c" "-q" "-d")
@@ -258,7 +266,7 @@ options through Custom does this automatically."
Each element, which describes a compression technique, is a vector of
the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
-APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
+APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS UNCOMPRESS-FUNCTION], where:
regexp is a regexp that matches filenames that are
compressed with this format
@@ -274,7 +282,7 @@ APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
uncompress-msg is the message to issue to the user when doing this
type of uncompression (nil means no message)
- uncompress-program is a program that performs this compression
+ uncompress-program is a program that performs this uncompression
uncompress-args is a list of args to pass to the uncompress program
@@ -287,6 +295,9 @@ APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
file-magic-chars is a string of characters that you would find
at the beginning of a file compressed in this way.
+ uncompress-function is a function that performs uncompression, if
+ uncompress-program is not found.
+
If you set this outside Custom while Auto Compression mode is
already enabled \(as it is by default), you have to call
`jka-compr-update' after setting it to properly update other
@@ -308,9 +319,12 @@ variables. Setting this through Custom does that automatically."
(repeat :tag "Uncompress Arguments" string)
(boolean :tag "Append")
(boolean :tag "Strip Extension")
- (string :tag "Magic Bytes")))
+ (string :tag "Magic Bytes")
+ (choice :tag "Uncompress Function"
+ (symbol)
+ (const :tag "None" nil))))
:set 'jka-compr-set
- :version "24.1" ; removed version extension piece
+ :version "28.1" ; add uncompress-function
:group 'jka-compr)
(defcustom jka-compr-mode-alist-additions
diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el
index f9bec722f14..658ea44a348 100644
--- a/lisp/jka-compr.el
+++ b/lisp/jka-compr.el
@@ -1,7 +1,6 @@
-;;; jka-compr.el --- reading/writing/loading compressed files
+;;; jka-compr.el --- reading/writing/loading compressed files -*- lexical-binding: t; -*-
-;; Copyright (C) 1993-1995, 1997, 1999-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1993-2021 Free Software Foundation, Inc.
;; Author: Jay K. Adams <jka@ece.cmu.edu>
;; Maintainer: emacs-devel@gnu.org
@@ -101,11 +100,10 @@ NOTE: Not used in MS-DOS and Windows systems."
(defvar jka-compr-use-shell
(not (memq system-type '(ms-dos windows-nt))))
-(defvar jka-compr-really-do-compress nil
+(defvar-local jka-compr-really-do-compress nil
"Non-nil in a buffer whose visited file was uncompressed on visiting it.
This means compress the data on writing the file, even if the
data appears to be compressed already.")
-(make-variable-buffer-local 'jka-compr-really-do-compress)
(put 'jka-compr-really-do-compress 'permanent-local t)
@@ -121,7 +119,7 @@ data appears to be compressed already.")
(widen) (erase-buffer)
(insert (format "Error while executing \"%s %s < %s\"\n\n"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
infile))
(and errfile
@@ -171,7 +169,7 @@ to keep: LEN chars starting BEG chars from the beginning."
(format
"%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
err-file
jka-compr-dd-program
jka-compr-dd-blocksize
@@ -219,7 +217,7 @@ to keep: LEN chars starting BEG chars from the beginning."
"-c"
(format "%s %s 2> %s %s"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
err-file
(if (stringp output)
(concat "> " output)
@@ -228,7 +226,7 @@ to keep: LEN chars starting BEG chars from the beginning."
(jka-compr-error prog args infile message err-file))
(delete-file err-file)))
(or (eq 0
- (apply 'call-process
+ (apply #'call-process
prog infile (if (stringp output) temp output)
nil args))
(jka-compr-error prog args infile message))
@@ -388,6 +386,7 @@ There should be no more than seven characters after the final `/'."
(let ((uncompress-message (jka-compr-info-uncompress-message info))
(uncompress-program (jka-compr-info-uncompress-program info))
+ (uncompress-function (jka-compr-info-uncompress-function info))
(uncompress-args (jka-compr-info-uncompress-args info))
(base-name (file-name-nondirectory filename))
(notfound nil)
@@ -411,58 +410,76 @@ There should be no more than seven characters after the final `/'."
jka-compr-verbose
(message "%s %s..." uncompress-message base-name))
- (condition-case error-code
-
- (let ((coding-system-for-read 'no-conversion))
- (if replace
- (goto-char (point-min)))
- (setq start (point))
- (if (or beg end)
- (jka-compr-partial-uncompress uncompress-program
- (concat uncompress-message
- " " base-name)
- uncompress-args
- local-file
- (or beg 0)
- (if (and beg end)
- (- end beg)
- end))
- ;; 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)))
- (jka-compr-call-process uncompress-program
- (concat uncompress-message
- " " base-name)
- local-file
- t
- nil
- uncompress-args)))
- (setq size (- (point) start))
- (if replace
- (delete-region (point) (point-max)))
- (goto-char start))
- (error
- ;; If the file we wanted to uncompress does not exist,
- ;; handle that according to VISIT as `insert-file-contents'
- ;; would, maybe signaling the same error it normally would.
- (if (and (eq (car error-code) 'file-missing)
- (eq (nth 3 error-code) local-file))
- (if visit
- (setq notfound error-code)
- (signal 'file-missing
- (cons "Opening input file"
- (nthcdr 2 error-code))))
- ;; If the uncompression program can't be found,
- ;; signal that as a non-file error
- ;; so that find-file-noselect-1 won't handle it.
- (if (and (memq 'file-error (get (car error-code)
- 'error-conditions))
- (equal (cadr error-code) "Searching for program"))
- (error "Uncompression program `%s' not found"
- (nth 3 error-code)))
- (signal (car error-code) (cdr error-code))))))
+ (if (and (not (executable-find uncompress-program))
+ uncompress-function
+ (fboundp uncompress-function))
+ ;; If we don't have the uncompression program, then use the
+ ;; internal uncompression function (if we have one).
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally file)
+ (funcall uncompress-function (point-min) (point-max))
+ (when end
+ (delete-region end (point-max)))
+ (when beg
+ (delete-region (point-min) beg))
+ (setq size (buffer-size))
+ (insert-into-buffer buf))
+ (goto-char (point-min)))
+ ;; Use the external uncompression program.
+ (condition-case error-code
+
+ (let ((coding-system-for-read 'no-conversion))
+ (if replace
+ (goto-char (point-min)))
+ (setq start (point))
+ (if (or beg end)
+ (jka-compr-partial-uncompress
+ uncompress-program
+ (concat uncompress-message " " base-name)
+ uncompress-args
+ local-file
+ (or beg 0)
+ (if (and beg end)
+ (- end beg)
+ end))
+ ;; 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)))
+ (jka-compr-call-process uncompress-program
+ (concat uncompress-message
+ " " base-name)
+ local-file
+ t
+ nil
+ uncompress-args)))
+ (setq size (- (point) start))
+ (if replace
+ (delete-region (point) (point-max)))
+ (goto-char start))
+ (error
+ ;; If the file we wanted to uncompress does not exist,
+ ;; handle that according to VISIT as `insert-file-contents'
+ ;; would, maybe signaling the same error it normally would.
+ (if (and (eq (car error-code) 'file-missing)
+ (eq (nth 3 error-code) local-file))
+ (if visit
+ (setq notfound error-code)
+ (signal 'file-missing
+ (cons "Opening input file"
+ (nthcdr 2 error-code))))
+ ;; If the uncompression program can't be found,
+ ;; signal that as a non-file error
+ ;; so that find-file-noselect-1 won't handle it.
+ (if (and (memq 'file-error (get (car error-code)
+ 'error-conditions))
+ (equal (cadr error-code) "Searching for program"))
+ (error "Uncompression program `%s' not found"
+ (nth 3 error-code)))
+ (signal (car error-code) (cdr error-code)))))))
(and
local-copy
@@ -623,12 +640,12 @@ There should be no more than seven characters after the final `/'."
(substring file 0 (string-match (jka-compr-info-regexp info) file)))
file)))
-(put 'write-region 'jka-compr 'jka-compr-write-region)
-(put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
-(put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
-(put 'load 'jka-compr 'jka-compr-load)
+(put 'write-region 'jka-compr #'jka-compr-write-region)
+(put 'insert-file-contents 'jka-compr #'jka-compr-insert-file-contents)
+(put 'file-local-copy 'jka-compr #'jka-compr-file-local-copy)
+(put 'load 'jka-compr #'jka-compr-load)
(put 'byte-compiler-base-file-name 'jka-compr
- 'jka-compr-byte-compiler-base-file-name)
+ #'jka-compr-byte-compiler-base-file-name)
;;;###autoload
(defvar jka-compr-inhibit nil
@@ -650,7 +667,7 @@ It is not recommended to set this variable permanently to anything but nil.")
;; to prevent the primitive from calling our handler again.
(defun jka-compr-run-real-handler (operation args)
(let ((inhibit-file-name-handlers
- (cons 'jka-compr-handler
+ (cons #'jka-compr-handler
(and (eq inhibit-file-name-operation operation)
inhibit-file-name-handlers)))
(inhibit-file-name-operation operation))
@@ -664,18 +681,18 @@ and `inhibit-local-variables-suffixes' that were added
by `jka-compr-install'."
;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
(mapc
- (function (lambda (x)
- (and (jka-compr-info-strip-extension x)
- (setq inhibit-local-variables-suffixes
- (delete (jka-compr-info-regexp x)
- inhibit-local-variables-suffixes)))))
+ (lambda (x)
+ (and (jka-compr-info-strip-extension x)
+ (setq inhibit-local-variables-suffixes
+ (delete (jka-compr-info-regexp x)
+ inhibit-local-variables-suffixes))))
jka-compr-compression-info-list--internal)
(let* ((fnha (cons nil file-name-handler-alist))
(last fnha))
(while (cdr last)
- (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
+ (if (eq (cdr (car (cdr last))) #'jka-compr-handler)
(setcdr last (cdr (cdr last)))
(setq last (cdr last))))
diff --git a/lisp/json.el b/lisp/json.el
index ce9db0ccfe3..0e61e1ad90c 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
;; Author: Theresa O'Connor <ted@oconnor.cx>
-;; Version: 1.4
+;; Version: 1.5
;; Keywords: convenience
;; This file is part of GNU Emacs.
@@ -26,20 +26,31 @@
;; This is a library for parsing and generating JSON (JavaScript Object
;; Notation).
-;; Learn all about JSON here: <URL:http://json.org/>.
+;; Learn all about JSON here: <URL:https://json.org/>.
;; The user-serviceable entry points for the parser are the functions
-;; `json-read' and `json-read-from-string'. The encoder has a single
+;; `json-read' and `json-read-from-string'. The encoder has a single
;; entry point, `json-encode'.
;; Since there are several natural representations of key-value pair
-;; mappings in elisp (alist, plist, hash-table), `json-read' allows you
+;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you
;; to specify which you'd prefer (see `json-object-type' and
;; `json-array-type').
;; Similarly, since `false' and `null' are distinct in JSON, you can
;; distinguish them by binding `json-false' and `json-null' as desired.
+;;; Organization:
+
+;; Historically json.el used the prefix `json-read-' for decoding and
+;; the prefix `json-encode-' for encoding. Many of these definitions
+;; are used by external packages since few were marked as internal.
+;; Optimizing the encoder to manipulate a buffer rather than strings
+;; while minimizing code duplication therefore necessitated a new
+;; namespace `json--print-'. This rendered many encoding functions
+;; obsolete and unused, but those considered externally useful are
+;; kept for backward compatibility and as a public API.
+
;;; History:
;; 2006-03-11 - Initial version.
@@ -57,7 +68,7 @@
(require 'map)
(require 'subr-x)
-;; Parameters
+;;;; Parameters
(defvar json-object-type 'alist
"Type to convert JSON objects to.
@@ -102,19 +113,30 @@ this around your call to `json-read' instead of `setq'ing it.")
"Value to use as an element separator when encoding.")
(defvar json-encoding-default-indentation " "
- "The default indentation level for encoding.
+ "String used for a single indentation level during encoding.
+This value is repeated for each further nested element.
+Used only when `json-encoding-pretty-print' is non-nil.")
+
+(defvar json--print-indentation-prefix "\n"
+ "String used to start indentation during encoding.
Used only when `json-encoding-pretty-print' is non-nil.")
-(defvar json--encoding-current-indentation "\n"
- "Internally used to keep track of the current indentation level of encoding.
+(defvar json--print-indentation-depth 0
+ "Current indentation level during encoding.
+Dictates repetitions of `json-encoding-default-indentation'.
Used only when `json-encoding-pretty-print' is non-nil.")
+(defvar json--print-keyval-separator ":"
+ "String used to separate key-value pairs during encoding.")
+
(defvar json-encoding-pretty-print nil
"If non-nil, then the output of `json-encode' will be pretty-printed.")
(defvar json-encoding-lisp-style-closings nil
- "If non-nil, ] and } closings will be formatted lisp-style,
-without indentation.")
+ "If non-nil, delimiters ] and } will be formatted Lisp-style.
+This means they will be placed on the same line as the last
+element of the respective array or object, without indentation.
+Used only when `json-encoding-pretty-print' is non-nil.")
(defvar json-encoding-object-sort-predicate nil
"Sorting predicate for JSON object keys during encoding.
@@ -124,88 +146,101 @@ instance, setting this to `string<' will have JSON object keys
ordered alphabetically.")
(defvar json-pre-element-read-function nil
- "Function called (if non-nil) by `json-read-array' and
-`json-read-object' right before reading a JSON array or object,
-respectively. The function is called with one argument, which is
-the current JSON key.")
+ "If non-nil, a function to call before reading a JSON array or object.
+It is called by `json-read-array' and `json-read-object',
+respectively, with one argument, which is the current JSON key.")
(defvar json-post-element-read-function nil
- "Function called (if non-nil) by `json-read-array' and
-`json-read-object' right after reading a JSON array or object,
-respectively.")
+ "If non-nil, a function to call after reading a JSON array or object.
+It is called by `json-read-array' and `json-read-object',
+respectively, with no arguments.")
-;;; Utilities
+;;;; Utilities
-(defun json-join (strings separator)
- "Join STRINGS with SEPARATOR."
- (mapconcat 'identity strings separator))
+(define-obsolete-function-alias 'json-join #'string-join "28.1")
(defun json-alist-p (list)
- "Non-null if and only if LIST is an alist with simple keys."
- (while (consp list)
- (setq list (if (and (consp (car list))
- (atom (caar list)))
- (cdr list)
- 'not-alist)))
+ "Non-nil if and only if LIST is an alist with simple keys."
+ (declare (pure t) (side-effect-free error-free))
+ (while (and (consp (car-safe list))
+ (atom (caar list))
+ (setq list (cdr list))))
(null list))
(defun json-plist-p (list)
- "Non-null if and only if LIST is a plist with keyword keys."
- (while (consp list)
- (setq list (if (and (keywordp (car list))
- (consp (cdr list)))
- (cddr list)
- 'not-plist)))
+ "Non-nil if and only if LIST is a plist with keyword keys."
+ (declare (pure t) (side-effect-free error-free))
+ (while (and (keywordp (car-safe list))
+ (consp (cdr list))
+ (setq list (cddr list))))
(null list))
-(defun json--plist-reverse (plist)
- "Return a copy of PLIST in reverse order.
-Unlike `reverse', this keeps the property-value pairs intact."
- (let (res)
- (while plist
- (let ((prop (pop plist))
- (val (pop plist)))
- (push val res)
- (push prop res)))
- res))
-
-(defun json--plist-to-alist (plist)
- "Return an alist of the property-value pairs in PLIST."
- (let (res)
- (while plist
- (let ((prop (pop plist))
- (val (pop plist)))
- (push (cons prop val) res)))
- (nreverse res)))
-
-(defmacro json--with-indentation (body)
- `(let ((json--encoding-current-indentation
- (if json-encoding-pretty-print
- (concat json--encoding-current-indentation
- json-encoding-default-indentation)
- "")))
- ,body))
+(defun json--plist-nreverse (plist)
+ "Return PLIST in reverse order.
+Unlike `nreverse', this keeps the ordering of each property
+relative to its value intact. Like `nreverse', this function may
+destructively modify PLIST to produce the result."
+ (let (prev (next (cddr plist)))
+ (while next
+ (setcdr (cdr plist) prev)
+ (setq prev plist plist next next (cddr next))
+ (setcdr (cdr plist) prev)))
+ plist)
+
+;; Encoder utilities
+
+(defmacro json--with-output-to-string (&rest body)
+ "Eval BODY in a temporary buffer bound to `standard-output'.
+Return the resulting buffer contents as a string."
+ (declare (indent 0) (debug t))
+ `(with-output-to-string
+ (with-current-buffer standard-output
+ ;; This affords decent performance gains.
+ (setq-local inhibit-modification-hooks t)
+ ,@body)))
+
+(defmacro json--with-indentation (&rest body)
+ "Eval BODY with the JSON encoding nesting incremented by one step.
+This macro sets up appropriate variable bindings for
+`json--print-indentation' to produce the correct indentation when
+`json-encoding-pretty-print' is non-nil."
+ (declare (debug t) (indent 0))
+ `(let ((json--print-indentation-prefix
+ (if json-encoding-pretty-print json--print-indentation-prefix ""))
+ (json--print-keyval-separator (if json-encoding-pretty-print ": " ":"))
+ (json--print-indentation-depth (1+ json--print-indentation-depth)))
+ ,@body))
+
+(defun json--print-indentation ()
+ "Insert the current indentation for JSON encoding at point.
+Has no effect if `json-encoding-pretty-print' is nil."
+ (when json-encoding-pretty-print
+ (insert json--print-indentation-prefix)
+ (dotimes (_ json--print-indentation-depth)
+ (insert json-encoding-default-indentation))))
;; Reader utilities
(define-inline json-advance (&optional n)
- "Advance N characters forward."
+ "Advance N characters forward, or 1 character if N is nil.
+On reaching the end of the accessible region of the buffer, stop
+and signal an error."
(inline-quote (forward-char ,n)))
(define-inline json-peek ()
- "Return the character at point."
+ "Return the character at point.
+At the end of the accessible region of the buffer, return 0."
(inline-quote (following-char)))
(define-inline json-pop ()
- "Advance past the character at point, returning it."
+ "Advance past the character at point, returning it.
+Signal `json-end-of-file' if called at the end of the buffer."
(inline-quote
- (let ((char (json-peek)))
- (if (zerop char)
- (signal 'json-end-of-file nil)
- (json-advance)
- char))))
+ (prog1 (or (char-after)
+ (signal 'json-end-of-file ()))
+ (json-advance))))
(define-inline json-skip-whitespace ()
"Skip past the whitespace at point."
@@ -213,9 +248,7 @@ Unlike `reverse', this keeps the property-value pairs intact."
;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
;; or https://tools.ietf.org/html/rfc7159#section-2 for the
;; definition of whitespace in JSON.
- (inline-quote (skip-chars-forward "\t\r\n ")))
-
-
+ (inline-quote (skip-chars-forward "\t\n\r ")))
;; Error conditions
@@ -227,16 +260,17 @@ Unlike `reverse', this keeps the property-value pairs intact."
(define-error 'json-string-format "Bad string format" 'json-error)
(define-error 'json-key-format "Bad JSON object key" 'json-error)
(define-error 'json-object-format "Bad JSON object" 'json-error)
+(define-error 'json-array-format "Bad JSON array" 'json-error)
(define-error 'json-end-of-file "End of file while parsing JSON"
'(end-of-file json-error))
-;;; Paths
+;;;; Paths
(defvar json--path '()
- "Used internally by `json-path-to-position' to keep track of
-the path during recursive calls to `json-read'.")
+ "Keeps track of the path during recursive calls to `json-read'.
+Used internally by `json-path-to-position'.")
(defun json--record-path (key)
"Record the KEY to the current JSON path.
@@ -247,7 +281,7 @@ Used internally by `json-path-to-position'."
"Check if the last parsed JSON structure passed POSITION.
Used internally by `json-path-to-position'."
(let ((start (caar json--path)))
- (when (< start position (+ (point) 1))
+ (when (< start position (1+ (point)))
(throw :json-path (list :path (nreverse (mapcar #'cdr json--path))
:match-start start
:match-end (point)))))
@@ -265,13 +299,13 @@ properties:
:path -- A list of strings and numbers forming the path to
the JSON element at the given position. Strings
denote object names, while numbers denote array
- indexes.
+ indices.
:match-start -- Position where the matched JSON element begins.
:match-end -- Position where the matched JSON element ends.
-This can for instance be useful to determine the path to a JSON
+This can, for instance, be useful to determine the path to a JSON
element in a deeply nested structure."
(save-excursion
(unless string
@@ -279,7 +313,7 @@ element in a deeply nested structure."
(let* ((json--path '())
(json-pre-element-read-function #'json--record-path)
(json-post-element-read-function
- (apply-partially #'json--check-position position))
+ (lambda () (json--check-position position)))
(path (catch :json-path
(if string
(json-read-from-string string)
@@ -287,79 +321,75 @@ element in a deeply nested structure."
(when (plist-get path :path)
path))))
-;;; Keywords
+
+
+;;;; Keywords
-(defvar json-keywords '("true" "false" "null")
+(defconst json-keywords '("true" "false" "null")
"List of JSON keywords.")
+(make-obsolete-variable 'json-keywords "it is no longer used." "28.1")
;; Keyword parsing
+;; Characters that can follow a JSON value.
+(rx-define json--post-value (| (in "\t\n\r ,]}") eos))
+
(defun json-read-keyword (keyword)
- "Read a JSON keyword at point.
-KEYWORD is the keyword expected."
- (unless (member keyword json-keywords)
- (signal 'json-unknown-keyword (list keyword)))
- (mapc (lambda (char)
- (when (/= char (json-peek))
- (signal 'json-unknown-keyword
- (list (save-excursion
- (backward-word-strictly 1)
- (thing-at-point 'word)))))
- (json-advance))
- keyword)
- (json-skip-whitespace)
- (unless (looking-at "\\([],}]\\|$\\)")
- (signal 'json-unknown-keyword
- (list (save-excursion
- (backward-word-strictly 1)
- (thing-at-point 'word)))))
- (cond ((string-equal keyword "true") t)
- ((string-equal keyword "false") json-false)
- ((string-equal keyword "null") json-null)))
+ "Read the expected JSON KEYWORD at point."
+ (prog1 (cond ((equal keyword "true") t)
+ ((equal keyword "false") json-false)
+ ((equal keyword "null") json-null)
+ (t (signal 'json-unknown-keyword (list keyword))))
+ (or (looking-at-p keyword)
+ (signal 'json-unknown-keyword (list (thing-at-point 'word))))
+ (json-advance (length keyword))
+ (or (looking-at-p (rx json--post-value))
+ (signal 'json-unknown-keyword (list (thing-at-point 'word))))
+ (json-skip-whitespace)))
;; Keyword encoding
(defun json-encode-keyword (keyword)
"Encode KEYWORD as a JSON value."
+ (declare (side-effect-free t))
(cond ((eq keyword t) "true")
((eq keyword json-false) "false")
((eq keyword json-null) "null")))
-;;; Numbers
+(defun json--print-keyword (keyword)
+ "Insert KEYWORD as a JSON value at point.
+Return nil if KEYWORD is not recognized as a JSON keyword."
+ (prog1 (setq keyword (json-encode-keyword keyword))
+ (and keyword (insert keyword))))
-;; Number parsing
+;;;; Numbers
-(defun json-read-number (&optional sign)
- "Read the JSON number following point.
-The optional SIGN argument is for internal use.
+;; Number parsing
-N.B.: Only numbers which can fit in Emacs Lisp's native number
-representation will be parsed correctly."
- ;; If SIGN is non-nil, the number is explicitly signed.
- (let ((number-regexp
- "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
- (cond ((and (null sign) (= (json-peek) ?-))
- (json-advance)
- (- (json-read-number t)))
- ((and (null sign) (= (json-peek) ?+))
- (json-advance)
- (json-read-number t))
- ((and (looking-at number-regexp)
- (or (match-beginning 1)
- (match-beginning 2)))
- (goto-char (match-end 0))
- (string-to-number (match-string 0)))
- (t (signal 'json-number-format (list (point)))))))
+(rx-define json--number
+ (: (? ?-) ; Sign.
+ (| (: (in "1-9") (* digit)) ?0) ; Integer.
+ (? ?. (+ digit)) ; Fraction.
+ (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent.
+
+(defun json-read-number (&optional _sign)
+ "Read the JSON number following point."
+ (declare (advertised-calling-convention () "28.1"))
+ (or (looking-at (rx json--number))
+ (signal 'json-number-format (list (point))))
+ (goto-char (match-end 0))
+ (prog1 (string-to-number (match-string 0))
+ (or (looking-at-p (rx json--post-value))
+ (signal 'json-number-format (list (point))))
+ (json-skip-whitespace)))
;; Number encoding
-(defun json-encode-number (number)
- "Return a JSON representation of NUMBER."
- (format "%s" number))
+(define-obsolete-function-alias 'json-encode-number #'json-encode "28.1")
-;;; Strings
+;;;; Strings
-(defvar json-special-chars
+(defconst json-special-chars
'((?\" . ?\")
(?\\ . ?\\)
(?b . ?\b)
@@ -367,7 +397,7 @@ representation will be parsed correctly."
(?n . ?\n)
(?r . ?\r)
(?t . ?\t))
- "Characters which are escaped in JSON, with their elisp counterparts.")
+ "Characters which are escaped in JSON, with their Elisp counterparts.")
;; String parsing
@@ -377,48 +407,47 @@ representation will be parsed correctly."
(defun json-read-escaped-char ()
"Read the JSON string escaped character at point."
- ;; Skip over the '\'
+ ;; Skip over the '\'.
(json-advance)
- (let* ((char (json-pop))
- (special (assq char json-special-chars)))
+ (let ((char (json-pop)))
(cond
- (special (cdr special))
- ((not (eq char ?u)) char)
+ ((cdr (assq char json-special-chars)))
+ ((/= char ?u) char)
;; Special-case UTF-16 surrogate pairs,
;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that
;; this clause overlaps with the next one and therefore has to
;; come first.
((looking-at
- (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit)))
- "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit)))))
+ (rx (group (any "Dd") (any "89ABab") (= 2 xdigit))
+ "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit))))
(json-advance 10)
(json--decode-utf-16-surrogates
(string-to-number (match-string 1) 16)
(string-to-number (match-string 2) 16)))
((looking-at (rx (= 4 xdigit)))
- (let ((hex (match-string 0)))
- (json-advance 4)
- (string-to-number hex 16)))
+ (json-advance 4)
+ (string-to-number (match-string 0) 16))
(t
(signal 'json-string-escape (list (point)))))))
(defun json-read-string ()
"Read the JSON string at point."
- (unless (= (json-peek) ?\")
- (signal 'json-string-format (list "doesn't start with `\"'!")))
- ;; Skip over the '"'
+ ;; Skip over the '"'.
(json-advance)
(let ((characters '())
(char (json-peek)))
- (while (not (= char ?\"))
+ (while (/= char ?\")
(when (< char 32)
- (signal 'json-string-format (list (prin1-char char))))
+ (if (zerop char)
+ (signal 'json-end-of-file ())
+ (signal 'json-string-format (list char))))
(push (if (= char ?\\)
(json-read-escaped-char)
- (json-pop))
+ (json-advance)
+ char)
characters)
(setq char (json-peek)))
- ;; Skip over the '"'
+ ;; Skip over the '"'.
(json-advance)
(if characters
(concat (nreverse characters))
@@ -426,48 +455,58 @@ representation will be parsed correctly."
;; String encoding
+(defun json--print-string (string &optional from)
+ "Insert a JSON representation of STRING at point.
+FROM is the index of STRING to start from and defaults to 0."
+ (insert ?\")
+ (goto-char (prog1 (point) (princ string)))
+ (and from (delete-char from))
+ ;; Escape only quotation mark, backslash, and the control
+ ;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
+ (while (re-search-forward (rx (in ?\" ?\\ cntrl)) nil 'move)
+ (let ((char (preceding-char)))
+ (delete-char -1)
+ (insert ?\\ (or
+ ;; Special JSON character (\n, \r, etc.).
+ (car (rassq char json-special-chars))
+ ;; Fallback: UCS code point in \uNNNN form.
+ (format "u%04x" char)))))
+ (insert ?\")
+ string)
+
(defun json-encode-string (string)
"Return a JSON representation of STRING."
- ;; Reimplement the meat of `replace-regexp-in-string', for
- ;; performance (bug#20154).
- (let ((l (length string))
- (start 0)
- res mb)
- ;; Only escape quotation mark, backslash and the control
- ;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
- (while (setq mb (string-match "[\"\\[:cntrl:]]" string start))
- (let* ((c (aref string mb))
- (special (rassq c json-special-chars)))
- (push (substring string start mb) res)
- (push (if special
- ;; Special JSON character (\n, \r, etc.).
- (string ?\\ (car special))
- ;; Fallback: UCS code point in \uNNNN form.
- (format "\\u%04x" c))
- res)
- (setq start (1+ mb))))
- (push (substring string start l) res)
- (push "\"" res)
- (apply #'concat "\"" (nreverse res))))
+ (json--with-output-to-string (json--print-string string)))
+
+(defun json--print-stringlike (object)
+ "Insert OBJECT encoded as a JSON string at point.
+Return nil if OBJECT cannot be encoded as a JSON string."
+ (cond ((stringp object) (json--print-string object))
+ ((keywordp object) (json--print-string (symbol-name object) 1))
+ ((symbolp object) (json--print-string (symbol-name object)))))
+
+(defun json--print-key (object)
+ "Insert a JSON key representation of OBJECT at point.
+Signal `json-key-format' if it cannot be encoded as a string."
+ (or (json--print-stringlike object)
+ (signal 'json-key-format (list object))))
(defun json-encode-key (object)
"Return a JSON representation of OBJECT.
If the resulting JSON object isn't a valid JSON object key,
this signals `json-key-format'."
- (let ((encoded (json-encode object)))
- (unless (stringp (json-read-from-string encoded))
- (signal 'json-key-format (list object)))
- encoded))
+ (declare (obsolete json-encode "28.1"))
+ (json--with-output-to-string (json--print-key object)))
+
+;;;; Objects
-;;; JSON Objects
+;; JSON object parsing
(defun json-new-object ()
- "Create a new Elisp object corresponding to a JSON object.
+ "Create a new Elisp object corresponding to an empty JSON object.
Please see the documentation of `json-object-type'."
- (cond ((eq json-object-type 'hash-table)
- (make-hash-table :test 'equal))
- (t
- ())))
+ (and (eq json-object-type 'hash-table)
+ (make-hash-table :test #'equal)))
(defun json-add-to-object (object key value)
"Add a new KEY -> VALUE association to OBJECT.
@@ -475,10 +514,10 @@ Returns the updated object, which you should save, e.g.:
(setq obj (json-add-to-object obj \"foo\" \"bar\"))
Please see the documentation of `json-object-type' and `json-key-type'."
(let ((json-key-type
- (or json-key-type
- (cdr (assq json-object-type '((hash-table . string)
- (alist . symbol)
- (plist . keyword)))))))
+ (cond (json-key-type)
+ ((eq json-object-type 'hash-table) 'string)
+ ((eq json-object-type 'alist) 'symbol)
+ ((eq json-object-type 'plist) 'keyword))))
(setq key
(cond ((eq json-key-type 'string)
key)
@@ -494,17 +533,15 @@ Please see the documentation of `json-object-type' and `json-key-type'."
((eq json-object-type 'plist)
(cons key (cons value object))))))
-;; JSON object parsing
-
(defun json-read-object ()
"Read the JSON object at point."
- ;; Skip over the "{"
+ ;; Skip over the '{'.
(json-advance)
(json-skip-whitespace)
- ;; read key/value pairs until "}"
+ ;; Read key/value pairs until '}'.
(let ((elements (json-new-object))
key value)
- (while (not (= (json-peek) ?}))
+ (while (/= (json-peek) ?\})
(json-skip-whitespace)
(setq key (json-read-string))
(json-skip-whitespace)
@@ -519,120 +556,108 @@ Please see the documentation of `json-object-type' and `json-key-type'."
(funcall json-post-element-read-function))
(setq elements (json-add-to-object elements key value))
(json-skip-whitespace)
- (when (/= (json-peek) ?})
+ (when (/= (json-peek) ?\})
(if (= (json-peek) ?,)
(json-advance)
(signal 'json-object-format (list "," (json-peek))))))
- ;; Skip over the "}"
+ ;; Skip over the '}'.
(json-advance)
(pcase json-object-type
('alist (nreverse elements))
- ('plist (json--plist-reverse elements))
+ ('plist (json--plist-nreverse elements))
(_ elements))))
+;; JSON object encoding
+
+(defun json--print-pair (key val)
+ "Insert JSON representation of KEY-VAL pair at point.
+This always inserts a trailing `json-encoding-separator'."
+ (json--print-indentation)
+ (json--print-key key)
+ (insert json--print-keyval-separator)
+ (json--print val)
+ (insert json-encoding-separator))
+
+(defun json--print-map (map)
+ "Insert JSON object representation of MAP at point.
+This works for any MAP satisfying `mapp'."
+ (insert ?\{)
+ (unless (map-empty-p map)
+ (json--with-indentation
+ (map-do #'json--print-pair map)
+ (delete-char (- (length json-encoding-separator))))
+ (or json-encoding-lisp-style-closings
+ (json--print-indentation)))
+ (insert ?\}))
+
+(defun json--print-unordered-map (map)
+ "Like `json--print-map', but optionally sort MAP first.
+If `json-encoding-object-sort-predicate' is non-nil, this first
+transforms an unsortable MAP into a sortable alist."
+ (if (and json-encoding-object-sort-predicate
+ (not (map-empty-p map)))
+ (json--print-alist (map-pairs map) t)
+ (json--print-map map)))
+
;; Hash table encoding
-(defun json-encode-hash-table (hash-table)
- "Return a JSON representation of HASH-TABLE."
- (if json-encoding-object-sort-predicate
- (json-encode-alist (map-into hash-table 'list))
- (format "{%s%s}"
- (json-join
- (let (r)
- (json--with-indentation
- (maphash
- (lambda (k v)
- (push (format
- (if json-encoding-pretty-print
- "%s%s: %s"
- "%s%s:%s")
- json--encoding-current-indentation
- (json-encode-key k)
- (json-encode v))
- r))
- hash-table))
- r)
- json-encoding-separator)
- (if (or (not json-encoding-pretty-print)
- json-encoding-lisp-style-closings)
- ""
- json--encoding-current-indentation))))
+(define-obsolete-function-alias 'json-encode-hash-table #'json-encode "28.1")
;; List encoding (including alists and plists)
+(defun json--print-alist (alist &optional destructive)
+ "Insert a JSON representation of ALIST at point.
+Sort ALIST first if `json-encoding-object-sort-predicate' is
+non-nil. Sorting can optionally be DESTRUCTIVE for speed."
+ (json--print-map (if (and json-encoding-object-sort-predicate alist)
+ (sort (if destructive alist (copy-sequence alist))
+ (lambda (a b)
+ (funcall json-encoding-object-sort-predicate
+ (car a) (car b))))
+ alist)))
+
+;; The following two are unused but useful to keep around due to the
+;; inherent ambiguity of lists.
+
(defun json-encode-alist (alist)
"Return a JSON representation of ALIST."
- (when json-encoding-object-sort-predicate
- (setq alist
- (sort alist (lambda (a b)
- (funcall json-encoding-object-sort-predicate
- (car a) (car b))))))
- (format "{%s%s}"
- (json-join
- (json--with-indentation
- (mapcar (lambda (cons)
- (format (if json-encoding-pretty-print
- "%s%s: %s"
- "%s%s:%s")
- json--encoding-current-indentation
- (json-encode-key (car cons))
- (json-encode (cdr cons))))
- alist))
- json-encoding-separator)
- (if (or (not json-encoding-pretty-print)
- json-encoding-lisp-style-closings)
- ""
- json--encoding-current-indentation)))
+ (json--with-output-to-string (json--print-alist alist)))
(defun json-encode-plist (plist)
"Return a JSON representation of PLIST."
- (if json-encoding-object-sort-predicate
- (json-encode-alist (json--plist-to-alist plist))
- (let (result)
- (json--with-indentation
- (while plist
- (push (concat
- json--encoding-current-indentation
- (json-encode-key (car plist))
- (if json-encoding-pretty-print
- ": "
- ":")
- (json-encode (cadr plist)))
- result)
- (setq plist (cddr plist))))
- (concat "{"
- (json-join (nreverse result) json-encoding-separator)
- (if (and json-encoding-pretty-print
- (not json-encoding-lisp-style-closings))
- json--encoding-current-indentation
- "")
- "}"))))
+ (json--with-output-to-string (json--print-unordered-map plist)))
+
+(defun json--print-list (list)
+ "Like `json-encode-list', but insert the JSON at point."
+ (cond ((json-alist-p list) (json--print-alist list))
+ ((json-plist-p list) (json--print-unordered-map list))
+ ((listp list) (json--print-array list))
+ ((signal 'json-error (list list)))))
(defun json-encode-list (list)
"Return a JSON representation of LIST.
-Tries to DWIM: simple lists become JSON arrays, while alists and plists
-become JSON objects."
- (cond ((json-alist-p list) (json-encode-alist list))
- ((json-plist-p list) (json-encode-plist list))
- ((listp list) (json-encode-array list))
- (t
- (signal 'json-error (list list)))))
+Tries to DWIM: alists and plists become JSON objects, while
+simple lists become JSON arrays."
+ (declare (obsolete json-encode "28.1"))
+ (json--with-output-to-string (json--print-list list)))
-;;; Arrays
+;;;; Arrays
;; Array parsing
(defun json-read-array ()
"Read the JSON array at point."
- ;; Skip over the "["
+ ;; Skip over the '['.
(json-advance)
(json-skip-whitespace)
- ;; read values until "]"
- (let (elements)
- (while (not (= (json-peek) ?\]))
+ ;; Read values until ']'.
+ (let (elements
+ (len 0))
+ (while (/= (json-peek) ?\])
(json-skip-whitespace)
(when json-pre-element-read-function
- (funcall json-pre-element-read-function (length elements)))
+ (funcall json-pre-element-read-function len)
+ (setq len (1+ len)))
(push (json-read) elements)
(when json-post-element-read-function
(funcall json-post-element-read-function))
@@ -640,8 +665,8 @@ become JSON objects."
(when (/= (json-peek) ?\])
(if (= (json-peek) ?,)
(json-advance)
- (signal 'json-error (list 'bleah)))))
- ;; Skip over the "]"
+ (signal 'json-array-format (list "," (json-peek))))))
+ ;; Skip over the ']'.
(json-advance)
(pcase json-array-type
('vector (nreverse (vconcat elements)))
@@ -649,45 +674,51 @@ become JSON objects."
;; Array encoding
+(defun json--print-array (array)
+ "Like `json-encode-array', but insert the JSON at point."
+ (insert ?\[)
+ (unless (length= array 0)
+ (json--with-indentation
+ (json--print-indentation)
+ (let ((first t))
+ (mapc (lambda (elt)
+ (if first
+ (setq first nil)
+ (insert json-encoding-separator)
+ (json--print-indentation))
+ (json--print elt))
+ array)))
+ (or json-encoding-lisp-style-closings
+ (json--print-indentation)))
+ (insert ?\]))
+
(defun json-encode-array (array)
- "Return a JSON representation of ARRAY."
- (if (and json-encoding-pretty-print
- (> (length array) 0))
- (concat
- (json--with-indentation
- (concat (format "[%s" json--encoding-current-indentation)
- (json-join (mapcar 'json-encode array)
- (format "%s%s"
- json-encoding-separator
- json--encoding-current-indentation))))
- (format "%s]"
- (if json-encoding-lisp-style-closings
- ""
- json--encoding-current-indentation)))
- (concat "["
- (mapconcat 'json-encode array json-encoding-separator)
- "]")))
+ "Return a JSON representation of ARRAY.
+ARRAY can also be a list."
+ (json--with-output-to-string (json--print-array array)))
-;;; JSON reader.
+;;;; Reader
(defmacro json-readtable-dispatch (char)
- "Dispatch reader function for CHAR."
- (declare (debug (symbolp)))
- (let ((table
- '((?t json-read-keyword "true")
- (?f json-read-keyword "false")
- (?n json-read-keyword "null")
- (?{ json-read-object)
- (?\[ json-read-array)
- (?\" json-read-string)))
- res)
- (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
- (push (list c 'json-read-number) table))
- (pcase-dolist (`(,c . ,rest) table)
- (push `((eq ,char ,c) (,@rest)) res))
- `(cond ,@res (t (signal 'json-readtable-error (list ,char))))))
+ "Dispatch reader function for CHAR at point.
+If CHAR is nil, signal `json-end-of-file'."
+ (declare (debug t))
+ (macroexp-let2 nil char char
+ `(cond ,@(map-apply
+ (lambda (key expr)
+ `((eq ,char ,key) ,expr))
+ `((?\" ,#'json-read-string)
+ (?\[ ,#'json-read-array)
+ (?\{ ,#'json-read-object)
+ (?n ,#'json-read-keyword "null")
+ (?f ,#'json-read-keyword "false")
+ (?t ,#'json-read-keyword "true")
+ ,@(mapcar (lambda (c) (list c #'json-read-number))
+ '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
+ (,char (signal 'json-readtable-error (list ,char)))
+ (t (signal 'json-end-of-file ())))))
(defun json-read ()
"Parse and return the JSON object following point.
@@ -705,10 +736,7 @@ you will get the following structure returned:
((c . :json-false))])
(b . \"foo\"))"
(json-skip-whitespace)
- (let ((char (json-peek)))
- (if (zerop char)
- (signal 'json-end-of-file nil)
- (json-readtable-dispatch char))))
+ (json-readtable-dispatch (char-after)))
;; Syntactic sugar for the reader
@@ -723,12 +751,21 @@ you will get the following structure returned:
"Read the first JSON object contained in FILE and return it."
(with-temp-buffer
(insert-file-contents file)
- (goto-char (point-min))
(json-read)))
-;;; JSON encoder
+;;;; Encoder
+
+(defun json--print (object)
+ "Like `json-encode', but insert or print the JSON at point."
+ (cond ((json--print-keyword object))
+ ((listp object) (json--print-list object))
+ ((json--print-stringlike object))
+ ((numberp object) (prin1 object))
+ ((arrayp object) (json--print-array object))
+ ((hash-table-p object) (json--print-unordered-map object))
+ ((signal 'json-error (list object)))))
(defun json-encode (object)
"Return a JSON representation of OBJECT as a string.
@@ -736,20 +773,9 @@ you will get the following structure returned:
OBJECT should have a structure like one returned by `json-read'.
If an error is detected during encoding, an error based on
`json-error' is signaled."
- (cond ((memq object (list t json-null json-false))
- (json-encode-keyword object))
- ((stringp object) (json-encode-string object))
- ((keywordp object) (json-encode-string
- (substring (symbol-name object) 1)))
- ((listp object) (json-encode-list object))
- ((symbolp object) (json-encode-string
- (symbol-name object)))
- ((numberp object) (json-encode-number object))
- ((arrayp object) (json-encode-array object))
- ((hash-table-p object) (json-encode-hash-table object))
- (t (signal 'json-error (list object)))))
-
-;; Pretty printing & minimizing
+ (json--with-output-to-string (json--print object)))
+
+;;;; Pretty printing & minimizing
(defun json-pretty-print-buffer (&optional minimize)
"Pretty-print current buffer.
@@ -760,7 +786,7 @@ With prefix argument MINIMIZE, minimize it instead."
(defvar json-pretty-print-max-secs 2.0
"Maximum time for `json-pretty-print's comparison.
The function `json-pretty-print' uses `replace-region-contents'
-(which see) passing the value of this variable as argument
+\(which see) passing the value of this variable as argument
MAX-SECS.")
(defun json-pretty-print (begin end &optional minimize)
@@ -768,10 +794,12 @@ MAX-SECS.")
With prefix argument MINIMIZE, minimize it instead."
(interactive "r\nP")
(let ((json-encoding-pretty-print (null minimize))
- ;; Distinguish an empty objects from 'null'
+ ;; Distinguish an empty object from 'null'.
(json-null :json-null)
- ;; Ensure that ordering is maintained
+ ;; Ensure that ordering is maintained.
(json-object-type 'alist)
+ ;; Ensure that keys survive roundtrip (bug#24252, bug#42545).
+ (json-key-type 'string)
(orig-buf (current-buffer))
error)
;; Strategy: Repeatedly `json-read' from the original buffer and
@@ -799,9 +827,7 @@ With prefix argument MINIMIZE, minimize it instead."
;; them.
(let ((space (buffer-substring
(point)
- (+ (point)
- (skip-chars-forward
- " \t\n" (point-max)))))
+ (+ (point) (skip-chars-forward " \t\n"))))
(json (json-read)))
(setq pos (point)) ; End of last good json-read.
(set-buffer tmp-buf)
@@ -831,14 +857,14 @@ With prefix argument MINIMIZE, minimize it instead."
"Pretty-print current buffer with object keys ordered.
With prefix argument MINIMIZE, minimize it instead."
(interactive "P")
- (let ((json-encoding-object-sort-predicate 'string<))
+ (let ((json-encoding-object-sort-predicate #'string<))
(json-pretty-print-buffer minimize)))
(defun json-pretty-print-ordered (begin end &optional minimize)
"Pretty-print the region with object keys ordered.
With prefix argument MINIMIZE, minimize it instead."
(interactive "r\nP")
- (let ((json-encoding-object-sort-predicate 'string<))
+ (let ((json-encoding-object-sort-predicate #'string<))
(json-pretty-print begin end minimize)))
(provide 'json)
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index e1d3cb261e0..f1fb6c1ddaf 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -4,29 +4,31 @@
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: processes, languages, extensions
+;; Version: 1.0.14
;; Package-Requires: ((emacs "25.2"))
-;; Version: 1.0.9
-;; This is an Elpa :core package. Don't use functionality that is not
-;; compatible with Emacs 25.2.
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library implements the JSONRPC 2.0 specification as described
-;; in http://www.jsonrpc.org/. As the name suggests, JSONRPC is a
+;; in https://www.jsonrpc.org/. As the name suggests, JSONRPC is a
;; generic Remote Procedure Call protocol designed around JSON
;; objects. To learn how to write JSONRPC programs with this library,
;; see Info node `(elisp)JSONRPC'."
@@ -37,7 +39,6 @@
;;; Code:
(require 'cl-lib)
-(require 'json)
(require 'eieio)
(eval-when-compile (require 'subr-x))
(require 'warnings)
@@ -139,18 +140,15 @@ immediately."
(defun jsonrpc-events-buffer (connection)
"Get or create JSONRPC events buffer for CONNECTION."
- (let* ((probe (jsonrpc--events-buffer connection))
- (buffer (or (and (buffer-live-p probe)
- probe)
- (let ((buffer (get-buffer-create
- (format "*%s events*"
- (jsonrpc-name connection)))))
- (with-current-buffer buffer
- (buffer-disable-undo)
- (read-only-mode t)
- (setf (jsonrpc--events-buffer connection) buffer))
- buffer))))
- buffer))
+ (let ((probe (jsonrpc--events-buffer connection)))
+ (if (buffer-live-p probe)
+ probe
+ (with-current-buffer
+ (get-buffer-create (format "*%s events*" (jsonrpc-name connection)))
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (setf (jsonrpc--events-buffer connection)
+ (current-buffer))))))
(defun jsonrpc-forget-pending-continuations (connection)
"Stop waiting for responses from the current JSONRPC CONNECTION."
@@ -272,10 +270,10 @@ it only exits locally (returning the JSONRPC result object) if
the request is successful, otherwise it exits non-locally with an
error of type `jsonrpc-error'.
-DEFERRED is passed to `jsonrpc-async-request', which see.
+DEFERRED and TIMEOUT as in `jsonrpc-async-request', which see.
If CANCEL-ON-INPUT is non-nil and the user inputs something while
-the functino is waiting, then it exits immediately, returning
+the function is waiting, then it exits immediately, returning
CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are
ignored."
(let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
@@ -285,7 +283,8 @@ ignored."
(catch tag
(setq
id-and-timer
- (jsonrpc--async-request-1
+ (apply
+ #'jsonrpc--async-request-1
connection method params
:success-fn (lambda (result)
(unless cancelled
@@ -301,11 +300,12 @@ ignored."
(lambda ()
(unless cancelled
(throw tag '(error (jsonrpc-error-message . "Timed out")))))
- :deferred deferred
- :timeout timeout))
+ `(,@(when deferred `(:deferred ,deferred))
+ ,@(when timeout `(:timeout ,timeout)))))
(cond (cancel-on-input
- (while (sit-for 30))
- (setq cancelled t)
+ (unwind-protect
+ (let ((inhibit-quit t)) (while (sit-for 30)))
+ (setq cancelled t))
`(cancelled ,cancel-on-input-retval))
(t (while t (accept-process-output nil 30)))))
;; In normal operation, cancellation is handled by the
@@ -330,11 +330,14 @@ ignored."
:method method
:params params))
-(defconst jrpc-default-request-timeout 10
+(define-obsolete-variable-alias 'jrpc-default-request-timeout
+ 'jsonrpc-default-request-timeout "28.1")
+
+(defconst jsonrpc-default-request-timeout 10
"Time in seconds before timing out a JSONRPC request.")
-;;; Specfic to `jsonrpc-process-connection'
+;;; Specific to `jsonrpc-process-connection'
;;;
(defclass jsonrpc-process-connection (jsonrpc-connection)
@@ -364,21 +367,55 @@ connection object, called when the process dies .")
(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
(cl-call-next-method)
- (let* ((proc (plist-get slots :process))
- (proc (if (functionp proc) (funcall proc) proc))
- (buffer (get-buffer-create (format "*%s output*" (process-name proc))))
- (stderr (get-buffer-create (format "*%s stderr*" (process-name proc)))))
+ (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots
+ ;; FIXME: notice the undocumented bad coupling in the stderr
+ ;; buffer name, it must be named exactly like this we expect when
+ ;; calling `make-process'. If there were a `set-process-stderr'
+ ;; like there is `set-process-buffer' we wouldn't need this and
+ ;; could use a pipe with a process filter instead of
+ ;; `after-change-functions'. Alternatively, we need a new initarg
+ ;; (but maybe not a slot).
+ (let ((calling-buffer (current-buffer)))
+ (with-current-buffer (get-buffer-create (format "*%s stderr*" name))
+ (let ((inhibit-read-only t)
+ (hidden-name (concat " " (buffer-name))))
+ (erase-buffer)
+ (buffer-disable-undo)
+ (add-hook
+ 'after-change-functions
+ (lambda (beg _end _pre-change-len)
+ (cl-loop initially (goto-char beg)
+ do (forward-line)
+ when (bolp)
+ for line = (buffer-substring
+ (line-beginning-position 0)
+ (line-end-position 0))
+ do (with-current-buffer (jsonrpc-events-buffer conn)
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert (format "[stderr] %s\n" line))))
+ until (eobp)))
+ nil t)
+ ;; If we are correctly coupled to the client, the process
+ ;; now created should pick up the current stderr buffer,
+ ;; which we immediately rename
+ (setq proc (if (functionp proc)
+ (with-current-buffer calling-buffer (funcall proc))
+ proc))
+ (ignore-errors (kill-buffer hidden-name))
+ (rename-buffer hidden-name)
+ (process-put proc 'jsonrpc-stderr (current-buffer))
+ (setq buffer-read-only t))))
(setf (jsonrpc--process conn) proc)
- (set-process-buffer proc buffer)
- (process-put proc 'jsonrpc-stderr stderr)
+ (set-process-buffer proc (get-buffer-create (format " *%s output*" name)))
(set-process-filter proc #'jsonrpc--process-filter)
(set-process-sentinel proc #'jsonrpc--process-sentinel)
(with-current-buffer (process-buffer proc)
(buffer-disable-undo)
(set-marker (process-mark proc) (point-min))
- (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc))
- (with-current-buffer stderr
- (buffer-disable-undo))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (setq buffer-read-only t))
(process-put proc 'jsonrpc-connection conn)))
(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
@@ -442,26 +479,35 @@ With optional CLEANUP, kill any associated buffers."
;;;
(define-error 'jsonrpc-error "jsonrpc-error")
-(defun jsonrpc--json-read ()
- "Read JSON object in buffer, move point to end of buffer."
- ;; TODO: I guess we can make these macros if/when jsonrpc.el
- ;; goes into Emacs core.
- (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
- :object-type 'plist
- :null-object nil
- :false-object :json-false))
- (t (let ((json-object-type 'plist))
- (json-read)))))
-
-(defun jsonrpc--json-encode (object)
- "Encode OBJECT into a JSON string."
- (cond ((fboundp 'json-serialize) (json-serialize
- object
- :false-object :json-false
- :null-object nil))
- (t (let ((json-false :json-false)
- (json-null nil))
- (json-encode object)))))
+(defalias 'jsonrpc--json-read
+ (if (fboundp 'json-parse-buffer)
+ (lambda ()
+ (json-parse-buffer :object-type 'plist
+ :null-object nil
+ :false-object :json-false))
+ (require 'json)
+ (defvar json-object-type)
+ (declare-function json-read "json" ())
+ (lambda ()
+ (let ((json-object-type 'plist))
+ (json-read))))
+ "Read JSON object in buffer, move point to end of buffer.")
+
+(defalias 'jsonrpc--json-encode
+ (if (fboundp 'json-serialize)
+ (lambda (object)
+ (json-serialize object
+ :false-object :json-false
+ :null-object nil))
+ (require 'json)
+ (defvar json-false)
+ (defvar json-null)
+ (declare-function json-encode "json" (object))
+ (lambda (object)
+ (let ((json-false :json-false)
+ (json-null nil))
+ (json-encode object))))
+ "Encode OBJECT into a JSON string.")
(cl-defun jsonrpc--reply
(connection id &key (result nil result-supplied-p) (error nil error-supplied-p))
@@ -577,7 +623,7 @@ With optional CLEANUP, kill any associated buffers."
params
&rest args
&key success-fn error-fn timeout-fn
- (timeout jrpc-default-request-timeout)
+ (timeout jsonrpc-default-request-timeout)
(deferred nil))
"Does actual work for `jsonrpc-async-request'.
@@ -682,7 +728,7 @@ originated."
(format "-%s" subtype)))))
(goto-char (point-max))
(prog1
- (let ((msg (format "%s%s%s %s:\n%s\n"
+ (let ((msg (format "[%s]%s%s %s:\n%s"
type
(if id (format " (id:%s)" id) "")
(if error " ERROR" "")
diff --git a/lisp/kermit.el b/lisp/kermit.el
index cf6bf31d806..fdab7e5a505 100644
--- a/lisp/kermit.el
+++ b/lisp/kermit.el
@@ -1,4 +1,4 @@
-;;; kermit.el --- additions to shell mode for use with kermit
+;;; kermit.el --- additions to shell mode for use with kermit -*- lexical-binding: t -*-
;; Copyright (C) 1988, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 786b050f8b4..8821e35c2d1 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -167,52 +167,53 @@ macro to be executed before appending to it."
(defvar kmacro-keymap
(let ((map (make-sparse-keymap)))
;; Start, end, execute macros
- (define-key map "s" 'kmacro-start-macro)
- (define-key map "\C-s" 'kmacro-start-macro)
- (define-key map "\C-k" 'kmacro-end-or-call-macro-repeat)
- (define-key map "r" 'apply-macro-to-region-lines)
- (define-key map "q" 'kbd-macro-query) ;; Like C-x q
+ (define-key map "s" #'kmacro-start-macro)
+ (define-key map "\C-s" #'kmacro-start-macro)
+ (define-key map "\C-k" #'kmacro-end-or-call-macro-repeat)
+ (define-key map "r" #'apply-macro-to-region-lines)
+ (define-key map "q" #'kbd-macro-query) ;; Like C-x q
+ (define-key map "Q" #'kdb-macro-redisplay)
;; macro ring
- (define-key map "\C-n" 'kmacro-cycle-ring-next)
- (define-key map "\C-p" 'kmacro-cycle-ring-previous)
- (define-key map "\C-v" 'kmacro-view-macro-repeat)
- (define-key map "\C-d" 'kmacro-delete-ring-head)
- (define-key map "\C-t" 'kmacro-swap-ring)
- (define-key map "\C-l" 'kmacro-call-ring-2nd-repeat)
+ (define-key map "\C-n" #'kmacro-cycle-ring-next)
+ (define-key map "\C-p" #'kmacro-cycle-ring-previous)
+ (define-key map "\C-v" #'kmacro-view-macro-repeat)
+ (define-key map "\C-d" #'kmacro-delete-ring-head)
+ (define-key map "\C-t" #'kmacro-swap-ring)
+ (define-key map "\C-l" #'kmacro-call-ring-2nd-repeat)
;; macro counter
- (define-key map "\C-f" 'kmacro-set-format)
- (define-key map "\C-c" 'kmacro-set-counter)
- (define-key map "\C-i" 'kmacro-insert-counter)
- (define-key map "\C-a" 'kmacro-add-counter)
+ (define-key map "\C-f" #'kmacro-set-format)
+ (define-key map "\C-c" #'kmacro-set-counter)
+ (define-key map "\C-i" #'kmacro-insert-counter)
+ (define-key map "\C-a" #'kmacro-add-counter)
;; macro editing
- (define-key map "\C-e" 'kmacro-edit-macro-repeat)
- (define-key map "\r" 'kmacro-edit-macro)
- (define-key map "e" 'edit-kbd-macro)
- (define-key map "l" 'kmacro-edit-lossage)
- (define-key map " " 'kmacro-step-edit-macro)
+ (define-key map "\C-e" #'kmacro-edit-macro-repeat)
+ (define-key map "\r" #'kmacro-edit-macro)
+ (define-key map "e" #'edit-kbd-macro)
+ (define-key map "l" #'kmacro-edit-lossage)
+ (define-key map " " #'kmacro-step-edit-macro)
;; naming and binding
- (define-key map "b" 'kmacro-bind-to-key)
- (define-key map "n" 'kmacro-name-last-macro)
- (define-key map "x" 'kmacro-to-register)
+ (define-key map "b" #'kmacro-bind-to-key)
+ (define-key map "n" #'kmacro-name-last-macro)
+ (define-key map "x" #'kmacro-to-register)
map)
"Keymap for keyboard macro commands.")
(defalias 'kmacro-keymap kmacro-keymap)
;;; Provide some binding for startup:
-;;;###autoload (global-set-key "\C-x(" 'kmacro-start-macro)
-;;;###autoload (global-set-key "\C-x)" 'kmacro-end-macro)
-;;;###autoload (global-set-key "\C-xe" 'kmacro-end-and-call-macro)
-;;;###autoload (global-set-key [f3] 'kmacro-start-macro-or-insert-counter)
-;;;###autoload (global-set-key [f4] 'kmacro-end-or-call-macro)
-;;;###autoload (global-set-key "\C-x\C-k" 'kmacro-keymap)
+;;;###autoload (global-set-key "\C-x(" #'kmacro-start-macro)
+;;;###autoload (global-set-key "\C-x)" #'kmacro-end-macro)
+;;;###autoload (global-set-key "\C-xe" #'kmacro-end-and-call-macro)
+;;;###autoload (global-set-key [f3] #'kmacro-start-macro-or-insert-counter)
+;;;###autoload (global-set-key [f4] #'kmacro-end-or-call-macro)
+;;;###autoload (global-set-key "\C-x\C-k" #'kmacro-keymap)
;;;###autoload (autoload 'kmacro-keymap "kmacro" "Keymap for keyboard macro commands." t 'keymap)
(if kmacro-call-mouse-event
- (global-set-key (vector kmacro-call-mouse-event) 'kmacro-end-call-mouse))
+ (global-set-key (vector kmacro-call-mouse-event) #'kmacro-end-call-mouse))
;;; Called from keyboard-quit
@@ -289,7 +290,8 @@ the last increment."
(defun kmacro-set-counter (arg)
"Set the value of `kmacro-counter' to ARG, or prompt for value if no argument.
-With \\[universal-argument] prefix, reset counter to its value prior to this iteration of the macro."
+With \\[universal-argument] prefix, reset counter to its value prior to this iteration of the
+macro."
(interactive "NMacro counter value: ")
(if (not (or defining-kbd-macro executing-kbd-macro))
(kmacro-display-counter (setq kmacro-initial-counter-value arg))
@@ -480,7 +482,7 @@ without repeating the prefix."
(defun kmacro-view-ring-2nd ()
- "Display the current head of the keyboard macro ring."
+ "Display the second macro in the keyboard macro ring."
(interactive)
(unless (kmacro-ring-empty-p)
(kmacro-display (car (car kmacro-ring)) nil "2nd macro")))
@@ -666,11 +668,13 @@ use \\[kmacro-name-last-macro]."
(set-transient-map
(let ((map (make-sparse-keymap)))
(define-key map (vector repeat-key)
- `(lambda () (interactive)
- (kmacro-call-macro ,(and kmacro-call-repeat-with-arg arg)
- 'repeating nil ,(if end-macro
- last-kbd-macro
- (or macro last-kbd-macro)))))
+ (let ((ra (and kmacro-call-repeat-with-arg arg))
+ (m (if end-macro
+ last-kbd-macro
+ (or macro last-kbd-macro))))
+ (lambda ()
+ (interactive)
+ (kmacro-call-macro ra 'repeating nil m))))
map)))))
@@ -780,23 +784,36 @@ If kbd macro currently being defined end it before activating it."
;;;###autoload
(defun kmacro-lambda-form (mac &optional counter format)
"Create lambda form for macro bound to symbol or key."
- (if counter
- (setq mac (list mac counter format)))
- `(lambda (&optional arg)
- "Keyboard macro."
- (interactive "p")
- (kmacro-exec-ring-item ',mac arg)))
+ ;; Apparently, there are two different ways this is called:
+ ;; either `counter' and `format' are both provided and `mac' is a vector,
+ ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT).
+ ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit',
+ ;; while the second is used from within this file.
+ (let ((mac (if counter (list mac counter format) mac)))
+ ;; FIXME: This should be a "funcallable struct"!
+ (lambda (&optional arg)
+ "Keyboard macro."
+ ;; We put an "unused prompt" as a special marker so
+ ;; `kmacro-extract-lambda' can see it's "one of us".
+ (interactive "pkmacro")
+ (if (eq arg 'kmacro--extract-lambda)
+ (cons 'kmacro--extract-lambda mac)
+ (kmacro-exec-ring-item mac arg)))))
(defun kmacro-extract-lambda (mac)
"Extract kmacro from a kmacro lambda form."
- (and (eq (car-safe mac) 'lambda)
- (setq mac (assoc 'kmacro-exec-ring-item mac))
- (setq mac (car-safe (cdr-safe (car-safe (cdr-safe mac)))))
- (listp mac)
- (= (length mac) 3)
- (arrayp (car mac))
- mac))
-
+ (let ((mac (cond
+ ((eq (car-safe mac) 'lambda)
+ (let ((e (assoc 'kmacro-exec-ring-item mac)))
+ (car-safe (cdr-safe (car-safe (cdr-safe e))))))
+ ((and (functionp mac)
+ (equal (interactive-form mac) '(interactive "pkmacro")))
+ (let ((r (funcall mac 'kmacro--extract-lambda)))
+ (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r)))))))
+ (and (consp mac)
+ (= (length mac) 3)
+ (arrayp (car mac))
+ mac)))
(defalias 'kmacro-p #'kmacro-extract-lambda
"Return non-nil if MAC is a kmacro keyboard macro.")
@@ -924,7 +941,7 @@ The ARG parameter is unused."
nil
(if kmacro-view-last-item
(concat (cond ((= kmacro-view-item-no 2) "2nd")
- ((= kmacro-view-item-no 3) "3nd")
+ ((= kmacro-view-item-no 3) "3rd")
(t (format "%dth" kmacro-view-item-no)))
" previous macro")
"Last macro")))
@@ -963,7 +980,7 @@ without repeating the prefix."
"Edit most recent 300 keystrokes as a keyboard macro."
(interactive)
(kmacro-push-ring)
- (edit-kbd-macro "\C-hl"))
+ (edit-kbd-macro (car (where-is-internal 'view-lossage))))
;;; Single-step editing of keyboard macros
@@ -1272,7 +1289,8 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(defun kmacro-step-edit-macro ()
"Step edit and execute last keyboard macro.
-To customize possible responses, change the \"bindings\" in `kmacro-step-edit-map'."
+To customize possible responses, change the \"bindings\" in
+`kmacro-step-edit-map'."
(interactive)
(let ((kmacro-step-edit-active t)
(kmacro-step-edit-new-macro "")
@@ -1296,6 +1314,16 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma
(kmacro-push-ring)
(setq last-kbd-macro kmacro-step-edit-new-macro))))
+(defun kdb-macro-redisplay ()
+ "Force redisplay during kbd macro execution."
+ (interactive)
+ (or executing-kbd-macro
+ defining-kbd-macro
+ (user-error "Not defining or executing kbd macro"))
+ (when executing-kbd-macro
+ (let ((executing-kbd-macro nil))
+ (redisplay))))
+
(provide 'kmacro)
;;; kmacro.el ends here
diff --git a/lisp/language/burmese.el b/lisp/language/burmese.el
index 7f2a99a41a2..ade3566717b 100644
--- a/lisp/language/burmese.el
+++ b/lisp/language/burmese.el
@@ -1,4 +1,4 @@
-;;; burmese.el --- support for Burmese -*- coding: utf-8 -*-
+;;; burmese.el --- support for Burmese -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -23,7 +23,6 @@
;;; Commentary:
-;; Aung San Suu Kyi says to call her country "Burma".
;; The murderous generals say to call it "Myanmar".
;; We will call it "Burma". -- rms, Chief GNUisance.
@@ -52,7 +51,9 @@
regexp t t))))
regexp))
-(let ((elt (list (vector burmese-composable-pattern 0 'font-shape-gstring)
- (vector "." 0 'font-shape-gstring))))
+(let ((elt (list (vector burmese-composable-pattern 0 #'font-shape-gstring)
+ (vector "." 0 #'font-shape-gstring))))
(set-char-table-range composition-function-table '(#x1000 . #x107F) elt)
(set-char-table-range composition-function-table '(#xAA60 . #xAA7B) elt))
+
+;;; burmese.el ends here
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index be1a6b4f4c1..cbb35565af2 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -1,4 +1,4 @@
-;;; cham.el --- support for Cham -*- coding: utf-8 -*-
+;;; cham.el --- support for Cham -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2008, 2009, 2010, 2011, 2012
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -29,11 +29,19 @@
(set-char-table-range composition-function-table
'(#xAA00 . #xAA5F)
- (list (vector "[\xAA00-\xAA5F]+" 0 'font-shape-gstring)))
+ (list (vector "[\xAA00-\xAA5F]+" 0 #'font-shape-gstring)))
(set-language-info-alist
"Cham" '((charset unicode)
(coding-system utf-8)
- (coding-priority utf-8)))
+ (coding-priority utf-8)
+ (input-method . "cham")
+ (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦê¨ê¨°")
+ (documentation . "\
+The Cham script is a Brahmic script used to write Cham,
+an Austronesian language spoken by some 245,000 Chams
+in Vietnam and Cambodia.")))
(provide 'cham)
+
+;;; cham.el ends here
diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el
index 4bc2eaa2cdd..105e7a735fd 100644
--- a/lisp/language/china-util.el
+++ b/lisp/language/china-util.el
@@ -1,4 +1,4 @@
-;;; china-util.el --- utilities for Chinese -*- coding: utf-8 -*-
+;;; china-util.el --- utilities for Chinese -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el
index cd826e0ae1b..5cb8344c094 100644
--- a/lisp/language/chinese.el
+++ b/lisp/language/chinese.el
@@ -1,4 +1,4 @@
-;;; chinese.el --- support for Chinese -*- coding: utf-8; -*-
+;;; chinese.el --- support for Chinese -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -103,6 +103,11 @@
(define-coding-system-alias 'hz-gb-2312 'chinese-hz)
(define-coding-system-alias 'hz 'chinese-hz)
+;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p,
+;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII
+;; compatible, so we override that here (bug#40407).
+(coding-system-put 'chinese-hz :ascii-compatible-p nil)
+
(set-language-info-alist
"Chinese-GB" '((charset chinese-gb2312 chinese-sisheng)
(iso639-language . zh)
diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el
index 22a4aa78689..04e681d743d 100644
--- a/lisp/language/cyril-util.el
+++ b/lisp/language/cyril-util.el
@@ -1,4 +1,4 @@
-;;; cyril-util.el --- utilities for Cyrillic scripts
+;;; cyril-util.el --- utilities for Cyrillic scripts -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
@@ -47,7 +47,7 @@
;;;###autoload
(defun standard-display-cyrillic-translit (&optional cyrillic-language)
- "Display a cyrillic buffer using a transliteration.
+ "Display a Cyrillic buffer using a transliteration.
For readability, the table is slightly
different from the one used for the input method `cyrillic-translit'.
diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el
index fa36d36b53b..b64a237cf73 100644
--- a/lisp/language/cyrillic.el
+++ b/lisp/language/cyrillic.el
@@ -1,4 +1,4 @@
-;;; cyrillic.el --- support for Cyrillic -*- coding: utf-8; -*-
+;;; cyrillic.el --- support for Cyrillic -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -33,7 +33,7 @@
;; are converted to Unicode internally. See
;; <URL:http://www.ecma.ch/ecma1/STAND/ECMA-113.HTM>. For more info
;; on Cyrillic charsets, see
-;; <URL:http://czyborra.com/charsets/cyrillic.html>. The KOI and
+;; <URL:https://czyborra.com/charsets/cyrillic.html>. The KOI and
;; Alternativnyj coding systems should live in code-pages.el, but
;; they've always been preloaded and the coding system autoload
;; mechanism didn't get accepted, so they have to stay here and
@@ -169,13 +169,6 @@ Support for Russian using koi8-r and the russian-computer input method.")
:charset-list '(ibm866)
:mime-charset 'cp866)
-(define-coding-system 'koi8-u
- "KOI8-U 8-bit encoding for Cyrillic (MIME: KOI8-U)"
- :coding-type 'charset
- :mnemonic ?U
- :charset-list '(koi8-u)
- :mime-charset 'koi8-u)
-
(define-coding-system 'koi8-t
"KOI8-T 8-bit encoding for Cyrillic"
:coding-type 'charset
diff --git a/lisp/language/czech.el b/lisp/language/czech.el
index a9cddc2c1f3..e449a7e9279 100644
--- a/lisp/language/czech.el
+++ b/lisp/language/czech.el
@@ -1,4 +1,4 @@
-;;; czech.el --- support for Czech -*- coding: utf-8 -*-
+;;; czech.el --- support for Czech -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/language/english.el b/lisp/language/english.el
index dfbec85792f..41d56be7d46 100644
--- a/lisp/language/english.el
+++ b/lisp/language/english.el
@@ -1,4 +1,4 @@
-;;; english.el --- support for English
+;;; english.el --- support for English -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el
index effbc305fce..dc385b07d3e 100644
--- a/lisp/language/ethio-util.el
+++ b/lisp/language/ethio-util.el
@@ -1,4 +1,4 @@
-;;; ethio-util.el --- utilities for Ethiopic -*- coding: utf-8-emacs; -*-
+;;; ethio-util.el --- utilities for Ethiopic -*- coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -98,44 +98,74 @@
;; users' preference
;;
-(defvar ethio-primary-language 'tigrigna
+(defgroup ethiopic nil
+ "Options for writing Ethiopic."
+ :version "28.1"
+ :group 'languages)
+
+(defcustom ethio-primary-language 'tigrigna
"Symbol that defines the primary language in SERA --> FIDEL conversion.
-The value should be one of: `tigrigna', `amharic' or `english'.")
+The value should be one of: `tigrigna', `amharic' or `english'."
+ :version "28.1"
+ :type '(choice (const :tag "Tigrigna" tigrigna)
+ (const :tag "Amharic" amharic)
+ (const :tag "English" english)))
-(defvar ethio-secondary-language 'english
+(defcustom ethio-secondary-language 'english
"Symbol that defines the secondary language in SERA --> FIDEL conversion.
-The value should be one of: `tigrigna', `amharic' or `english'.")
+The value should be one of: `tigrigna', `amharic' or `english'."
+ :version "28.1"
+ :type '(choice (const :tag "Tigrigna" tigrigna)
+ (const :tag "Amharic" amharic)
+ (const :tag "English" english)))
-(defvar ethio-use-colon-for-colon nil
+(defcustom ethio-use-colon-for-colon nil
"Non-nil means associate ASCII colon with Ethiopic colon.
If nil, associate ASCII colon with Ethiopic word separator, i.e., two
vertically stacked dots. All SERA <--> FIDEL converters refer this
-variable.")
+variable."
+ :version "28.1"
+ :type 'boolean)
-(defvar ethio-use-three-dot-question nil
- "Non-nil means associate ASCII question mark with Ethiopic old style question mark (three vertically stacked dots).
+(defcustom ethio-use-three-dot-question nil
+ "If non-nil, associate ASCII question mark with Ethiopic question mark.
+The Ethiopic old style question mark is three vertically stacked dots.
If nil, associate ASCII question mark with Ethiopic stylized question
-mark. All SERA <--> FIDEL converters refer this variable.")
-
-(defvar ethio-quote-vowel-always nil
- "Non-nil means always put an apostrophe before an isolated vowel (except at word initial) in FIDEL --> SERA conversion.
+mark. All SERA <--> FIDEL converters refer this variable."
+ :version "28.1"
+ :type 'boolean)
+
+(defcustom ethio-quote-vowel-always nil
+ "Non-nil means always put an apostrophe before an isolated vowel.
+This happens in FIDEL --> SERA conversions. Isolated vowels at
+word beginning do not get an apostrophe put before them.
If nil, put an apostrophe only between a 6th-form consonant and an
-isolated vowel.")
+isolated vowel."
+ :version "28.1"
+ :type 'boolean)
-(defvar ethio-W-sixth-always nil
- "Non-nil means convert the Wu-form of a 12-form consonant to \"W'\" instead of \"Wu\" in FIDEL --> SERA conversion.")
+(defcustom ethio-W-sixth-always nil
+ "Non-nil means convert the Wu-form of a 12-form consonant to \"W'\".
+This is instead of \"Wu\" in FIDEL --> SERA conversion."
+ :version "28.1"
+ :type 'boolean)
-(defvar ethio-numeric-reduction 0
+(defcustom ethio-numeric-reduction 0
"Degree of reduction in converting Ethiopic digits into Arabic digits.
Should be 0, 1 or 2.
For example, ({10}{9}{100}{80}{7}) is converted into:
\\=`10\\=`9\\=`100\\=`80\\=`7 if `ethio-numeric-reduction' is 0,
\\=`109100807 if `ethio-numeric-reduction' is 1,
- \\=`10900807 if `ethio-numeric-reduction' is 2.")
+ \\=`10900807 if `ethio-numeric-reduction' is 2."
+ :version "28.1"
+ :type 'integer)
-(defvar ethio-java-save-lowercase nil
+(defcustom ethio-java-save-lowercase nil
"Non-nil means save Ethiopic characters in lowercase hex numbers to Java files.
-If nil, use uppercases.")
+If nil, use uppercases."
+ :version "28.1"
+ :type 'boolean)
+
(defun ethio-prefer-amharic-p ()
(or (eq ethio-primary-language 'amharic)
@@ -828,11 +858,12 @@ The 2nd and 3rd arguments BEGIN and END specify the region."
(set-buffer-modified-p nil)))
;;;###autoload
-(defun ethio-tex-to-fidel-buffer nil
+(defun ethio-tex-to-fidel-buffer ()
"Convert fidel-tex commands in the current buffer into fidel chars."
(interactive)
- (let ((buffer-read-only nil)
- (p) (ch))
+ (let ((inhibit-read-only t)
+ ;; (p) (ch)
+ )
;; TeX macros to Ethiopic characters
(robin-convert-region (point-min) (point-max) "ethiopic-tex")
@@ -967,8 +998,7 @@ Otherwise, [0-9A-F]."
;; Ethiopic word separator vs. ASCII space
;;
-(defvar ethio-prefer-ascii-space t)
-(make-variable-buffer-local 'ethio-prefer-ascii-space)
+(defvar-local ethio-prefer-ascii-space t)
(defun ethio-toggle-space nil
"Toggle ASCII space and Ethiopic separator for keyboard input."
@@ -1014,7 +1044,7 @@ With ARG, insert that many delimiters."
;;
;;;###autoload
-(defun ethio-composition-function (pos to font-object string _direction)
+(defun ethio-composition-function (pos _to _font-object string _direction)
(setq pos (1- pos))
(let ((pattern "\\ce\\(áŸ\\|ö ‡Š\\)"))
(if string
diff --git a/lisp/language/ethiopic.el b/lisp/language/ethiopic.el
index 1e409e3dcf8..209dcd51c90 100644
--- a/lisp/language/ethiopic.el
+++ b/lisp/language/ethiopic.el
@@ -1,4 +1,4 @@
-;;; ethiopic.el --- support for Ethiopic -*- coding: utf-8-emacs; -*-
+;;; ethiopic.el --- support for Ethiopic -*- coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -79,8 +79,8 @@
)))
;; For automatic composition
-(aset composition-function-table ?ö ‡Š 'ethio-composition-function)
-(aset composition-function-table ?០'ethio-composition-function)
+(aset composition-function-table ?ö ‡Š #'ethio-composition-function)
+(aset composition-function-table ?០#'ethio-composition-function)
(provide 'ethiopic)
diff --git a/lisp/language/european.el b/lisp/language/european.el
index debcc2c76a8..bcd62a14c4c 100644
--- a/lisp/language/european.el
+++ b/lisp/language/european.el
@@ -1,4 +1,4 @@
-;;; european.el --- support for European languages -*- coding: utf-8; -*-
+;;; european.el --- support for European languages -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -324,6 +324,87 @@ Latin-9 is sometimes nicknamed `Latin-0'."))
:mime-charset 'windows-1257)
(define-coding-system-alias 'cp1257 'windows-1257)
+(define-coding-system 'ibm256
+ "Netherlands version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm256)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-int1 'ibm256)
+(define-coding-system-alias 'cp256 'ibm256)
+
+(define-coding-system 'ibm273
+ "Austrian / German version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm273)
+ :mnemonic ?*)
+(define-coding-system-alias 'cp273 'ibm273)
+
+(define-coding-system 'ibm274
+ "Belgian version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm274)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-be 'ibm274)
+(define-coding-system-alias 'cp274 'ibm274)
+
+(define-coding-system 'ibm275
+ "Brazilian version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm275)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-br 'ibm275)
+(define-coding-system-alias 'cp275 'ibm275)
+
+(define-coding-system 'ibm277
+ "Danish / Norwegian version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm277)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-dk 'ibm277)
+(define-coding-system-alias 'ebcdic-cp-no 'ibm277)
+(define-coding-system-alias 'cp277 'ibm277)
+
+(define-coding-system 'ibm278
+ "Finnish / Swedish version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm278)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-fi 'ibm278)
+(define-coding-system-alias 'ebcdic-cp-se 'ibm278)
+(define-coding-system-alias 'cp278 'ibm278)
+
+(define-coding-system 'ibm280
+ "Italian version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm280)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-it 'ibm280)
+(define-coding-system-alias 'cp280 'ibm280)
+
+(define-coding-system 'ibm284
+ "Spanish version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm284)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-es 'ibm284)
+(define-coding-system-alias 'cp284 'ibm284)
+
+(define-coding-system 'ibm285
+ "UK english version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm285)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-gb 'ibm285)
+(define-coding-system-alias 'cp285 'ibm285)
+
+(define-coding-system 'ibm297
+ "French version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm297)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-cp-fr 'ibm297)
+(define-coding-system-alias 'cp297 'ibm297)
+
(define-coding-system 'cp775
"DOS codepage 775 (PC Baltic, MS-DOS Baltic Rim)"
:coding-type 'charset
diff --git a/lisp/language/georgian.el b/lisp/language/georgian.el
index 0a17238e07a..321ef43f5f2 100644
--- a/lisp/language/georgian.el
+++ b/lisp/language/georgian.el
@@ -1,4 +1,4 @@
-;;; georgian.el --- language support for Georgian
+;;; georgian.el --- language support for Georgian -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/language/greek.el b/lisp/language/greek.el
index 735785046be..403a87d2535 100644
--- a/lisp/language/greek.el
+++ b/lisp/language/greek.el
@@ -1,4 +1,4 @@
-;;; greek.el --- support for Greek
+;;; greek.el --- support for Greek -*- lexical-binding: t -*-
;; Copyright (C) 2002, 2013-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el
index a2928112e54..9e9213536cb 100644
--- a/lisp/language/hanja-util.el
+++ b/lisp/language/hanja-util.el
@@ -1,4 +1,4 @@
-;;; hanja-util.el --- Korean Hanja util module -*- coding: utf-8 -*-
+;;; hanja-util.el --- Korean Hanja util module -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -22,7 +22,7 @@
;;; Commentary:
-;; This file defines korean hanja table and symbol table.
+;; This file defines the Korean Hanja table and symbol table.
;;; Code:
@@ -31,7 +31,7 @@
(defvar hanja-table nil
"A char table for Hanja characters.
-It maps a hangul character to a list of the corresponding Hanja characters.
+It maps a Hangul character to a list of the corresponding Hanja characters.
Each element of the list has the form CHAR or (CHAR . STRING)
where CHAR is a Hanja character and STRING is the meaning of that
character. This variable is initialized by `hanja-init-load'.")
diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el
index 2035fa3112b..c55d23f72d6 100644
--- a/lisp/language/hebrew.el
+++ b/lisp/language/hebrew.el
@@ -1,4 +1,4 @@
-;;; hebrew.el --- support for Hebrew -*- coding: utf-8 -*-
+;;; hebrew.el --- support for Hebrew -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -240,14 +240,14 @@ Bidirectional editing is supported.")))
(let* ((base "[\u05D0-\u05F2\uFB1D\uFB1F-\uFB28\uFB2A-\uFB4F]")
(combining
- "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+")
+ "[\u034F\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+")
(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)
+ (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
diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el
index 427953a6068..8d4b2a826e6 100644
--- a/lisp/language/ind-util.el
+++ b/lisp/language/ind-util.el
@@ -1,4 +1,4 @@
-;;; ind-util.el --- Transliteration and Misc. Tools for Indian Languages -*- coding: utf-8-emacs; -*-
+;;; ind-util.el --- Transliteration and Misc. Tools for Indian Languages -*- coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -40,7 +40,7 @@
(defun indian-regexp-of-hashtbl-keys (hashtbl)
"Return the regular expression of hash table keys."
(let (keys)
- (maphash (lambda (key val) (push key keys)) hashtbl)
+ (maphash (lambda (key _val) (push key keys)) hashtbl)
(regexp-opt keys)))
(defvar indian-dev-base-table
@@ -232,8 +232,8 @@
'(
(;; VOWELS
(?à´… nil) (?à´† ?à´¾) (?à´‡ ?à´¿) (?à´ˆ ?ീ) (?à´‰ ?àµ) (?à´Š ?ൂ)
- (?ഋ ?ൃ) (?ഌ nil) nil (?ഠ?േ) (?എ ?െ) (?ഠ?ൈ)
- nil (?ഓ ?ോ) (?ഒ ?ൊ) (?ഔ ?ൌ) nil nil)
+ (?ഋ ?ൃ) (?ഌ ?ൢ) (?ൡ ?ൣ) (?ഠ?േ) (?എ ?െ) (?ഠ?ൈ)
+ nil (?à´’ ?ൊ) (?à´“ ?ോ) (?à´” ?ൗ) (?ൠ?àµ) (?ൠ ?ൄ))
(;; CONSONANTS
?à´• ?à´– ?à´— ?à´˜ ?à´™ ;; GUTTRULS
?ച ?ഛ ?ജ ?ഠ?ഞ ;; PALATALS
@@ -243,13 +243,16 @@
?à´¯ ?à´° ?à´± ?à´² ?à´³ ?à´´ ?à´µ ;; SEMIVOWELS
?à´¶ ?à´· ?à´¸ ?à´¹ ;; SIBILANTS
nil nil nil nil nil nil nil nil ;; NUKTAS
- "à´œàµà´ž" "à´•àµà´·")
+ "à´œàµà´ž" "à´•àµà´·"
+ "à´±àµà´±" "à´¨àµà´±" "à´¤àµà´¤" "à´¤àµà´¥" "à´žàµà´ž" "à´™àµà´™" "à´¨àµà´¨"
+ "à´žàµà´š" "à´¨àµà´•" "à´™àµà´•" "à´šàµà´š" "à´šàµà´›" "à´•àµà´•"
+ "à´¬àµà´¬" "à´•àµà´•" "à´—àµà´—" "à´œàµà´œ" "à´®àµà´®" "à´ªàµà´ª" "à´µàµà´µ" "à´•àµà´¸" "à´¶àµà´¶")
(;; Misc Symbols
nil ?ം ?ഃ nil ?ൠnil nil)
(;; Digits
?൦ ?൧ ?൨ ?൩ ?൪ ?൫ ?൬ ?൭ ?൮ ?൯)
- (;; Inscript-extra (4) (#, $, ^, *, ])
- "àµà´°" "à´°àµ" "à´¤àµà´°" "à´¶àµà´°" nil)))
+ (;; Chillus
+ "à´£àµ" ?ൺ "à´¨àµ" ?ൻ "à´°àµ" ?ർ "à´²àµ" ?ൽ "à´³àµ" ?ൾ)))
(defvar indian-tml-base-table
'(
@@ -323,6 +326,29 @@
(;; misc -- 7
".N" (".n" "M") "H" ".a" ".h" ("AUM" "OM") "..")))
+(defvar indian-mlm-mozhi-table
+ '(;; for encode/decode
+ (;; vowels -- 18
+ "a" ("aa" "A") "i" ("ii" "I") "u" ("uu" "U")
+ "R" "Ll" "Lll" ("E" "ae") "e" "ai"
+ nil "o" "O" "au" "~" "RR")
+ (;; consonants -- 40
+ ("k" "c") "kh" "g" "gh" "ng"
+ "ch" ("Ch" "chh") "j" "jh" "nj"
+ "T" "Th" "D" "Dh" "N"
+ "th" "thh" "d" "dh" "n" nil
+ "p" ("ph" "f") "b" "bh" "m"
+ "y" "r" "rr" "l" "L" "zh" ("v" "w")
+ ("S" "z") "sh" "s" "h"
+ nil nil nil nil nil nil nil nil
+ nil "X"
+ ;; some of these are extra to Mozhi
+ ("t" "tt") "nt" "tth" "tthh" "nnj" "nng" "nn"
+ "nch" "nc" "nk" "cch" "cchh" "cc"
+ "B" ("C" "K" "q") "G" "J" "M" "P" "V" "x" "Z")
+ (;; misc -- 7
+ nil nil "H")))
+
(defvar indian-kyoto-harvard-table
'(;; for encode/decode
(;; vowel
@@ -524,6 +550,10 @@
(indian-make-hash indian-mlm-base-table
indian-itrans-v5-table))
+(defvar indian-mlm-mozhi-hash
+ (indian-make-hash indian-mlm-base-table
+ indian-mlm-mozhi-table))
+
(defvar indian-tml-itrans-v5-hash
(indian-make-hash indian-tml-base-table
indian-itrans-v5-table-for-tamil))
@@ -535,7 +565,7 @@
(let ((regexp ,(indian-regexp-of-hashtbl-keys
(if encode-p (car (eval hashtable))
(cdr (eval hashtable))))))
- (narrow-to-region from to)
+ (narrow-to-region ,from ,to)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(let ((matchstr (gethash (match-string 0)
@@ -583,7 +613,7 @@
;; The followings provide conversion between IS 13194 (ISCII) and UCS.
-(let
+(dlet
;;Unicode vs IS13194 ;; only Devanagari is supported now.
((ucs-devanagari-to-is13194-alist
'((?\x0900 . "[U+0900]")
@@ -790,11 +820,11 @@ Returns new end position."
(save-restriction
(narrow-to-region from to)
(goto-char (point-min))
- (let* ((current-repertory is13194-default-repertory))
+ ;; (let* ((current-repertory is13194-default-repertory))
(while (re-search-forward indian-ucs-to-is13194-regexp nil t)
(replace-match
(get-char-code-property (string-to-char (match-string 0))
- 'iscii))))
+ 'iscii)));; )
(point-max))))
(defun indian-iscii-to-ucs-region (from to)
@@ -1216,7 +1246,7 @@ Returns new end position."
(interactive "r")
(save-excursion
(save-restriction
- (let ((pos from)
+ (let (;; (pos from)
(alist (char-table-extra-slot indian-2-column-to-ucs-chartable 0)))
(narrow-to-region from to)
(decompose-region from to)
diff --git a/lisp/language/indian.el b/lisp/language/indian.el
index 83212e821cf..6f9d2703849 100644
--- a/lisp/language/indian.el
+++ b/lisp/language/indian.el
@@ -1,4 +1,4 @@
-;;; indian.el --- Indian languages support -*- coding: utf-8; -*-
+;;; indian.el --- Indian languages support -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
@@ -25,7 +25,7 @@
;;; Commentary:
;; This file contains definitions of Indian language environments, and
-;; setups for displaying the scrtipts used there.
+;; setups for displaying the scripts used there.
;;; Code:
@@ -381,7 +381,7 @@ South Indian language Malayalam is supported in this language environment."))
(if slot
(set-char-table-range
composition-function-table key
- (list (vector (cdr slot) 0 'font-shape-gstring))))))
+ (list (vector (cdr slot) 0 #'font-shape-gstring))))))
char-script-table))
(provide 'indian)
diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el
index 9dce17c4967..f3e3590645b 100644
--- a/lisp/language/japan-util.el
+++ b/lisp/language/japan-util.el
@@ -1,4 +1,4 @@
-;;; japan-util.el --- utilities for Japanese
+;;; japan-util.el --- utilities for Japanese -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -96,9 +96,9 @@ HANKAKU-KATAKANA belongs to `japanese-jisx0201-kana'.")
(put-char-code-property jisx0201 'jisx0208 katakana)))))
(defconst japanese-symbol-table
- '((?\  ?\ ) (?, ?, ?、) (?. ?. ?。) (?〠?, ?、) (?。 ?. ?。) (?・ nil ?・)
+ '((?\  ?\ ) (?, ?,) (?. ?.) (?〠nil ?、) (?。 nil ?。) (?・ nil ?・)
(?: ?:) (?ï¼› ?\;) (?? ??) (?ï¼ ?!) (?ã‚› nil ?゙) (?゜ nil ?゚)
- (?´ ?') (?` ?`) (?^ ?^) (?_ ?_) (?ー ?- ?ー) (?— ?-) (?†?-)
+ (?´ ?') (?` ?`) (?^ ?^) (?_ ?_) (?ー nil ?ー) (?— ?-) (?†?-)
(?ï¼ ?/) (?ï¼¼ ?\\) (?〜 ?~) (?| ?|) (?‘ ?`) (?’ ?') (?“ ?\") (?†?\")
(?\( ?\() (?\) ?\)) (?\ï¼» ?\[) (?\ï¼½ ?\]) (?\ï½› ?{) (?\ï½ ?})
(?〈 ?<) (?〉 ?>) (?\「 nil ?\「) (?\〠nil ?\」)
@@ -236,7 +236,7 @@ of which charset is `japanese-jisx0201-kana'."
(composition
(and (not hankaku)
(get-char-code-property kana 'kana-composition)))
- next slot)
+ slot) ;; next
(if (and composition (setq slot (assq (following-char) composition)))
(japanese-replace-region (match-beginning 0) (1+ (point))
(cdr slot))
@@ -258,7 +258,7 @@ of which charset is `japanese-jisx0201-kana'."
(while (re-search-forward "\\cK\\|\\ck" nil t)
(let* ((kata (preceding-char))
(composition (get-char-code-property kata 'kana-composition))
- next slot)
+ slot) ;; next
(if (and composition (setq slot (assq (following-char) composition)))
(japanese-replace-region (match-beginning 0) (1+ (point))
(get-char-code-property
@@ -305,7 +305,7 @@ Optional argument KATAKANA-ONLY non-nil means to convert only KATAKANA char."
(re-search-forward "\\ca\\|\\ck" nil t)))
(let* ((hankaku (preceding-char))
(composition (get-char-code-property hankaku 'kana-composition))
- next slot)
+ slot) ;; next
(if (and composition (setq slot (assq (following-char) composition)))
(japanese-replace-region (match-beginning 0) (1+ (point))
(cdr slot))
diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el
index 42ad037ccfd..bd8ef6ec857 100644
--- a/lisp/language/japanese.el
+++ b/lisp/language/japanese.el
@@ -1,4 +1,4 @@
-;;; japanese.el --- support for Japanese
+;;; japanese.el --- support for Japanese -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -82,9 +82,7 @@
(#x00A6 . #xFFE4) ; BROKEN LINE FULLWIDTH BROKEN LINE
)))
(define-translation-table 'japanese-ucs-jis-to-cp932-map map)
- (mapc #'(lambda (x) (let ((tmp (car x)))
- (setcar x (cdr x)) (setcdr x tmp)))
- map)
+ (setq map (mapcar (lambda (x) (cons (cdr x) (car x))) map))
(define-translation-table 'japanese-ucs-cp932-to-jis-map map))
;; U+2014 (EM DASH) vs U+2015 (HORIZONTAL BAR)
@@ -190,6 +188,22 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>."
(define-coding-system-alias 'shift_jis-2004 'japanese-shift-jis-2004)
+(define-coding-system 'ibm281
+ "Japanese-E version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm281)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-jp-e 'ibm281)
+(define-coding-system-alias 'cp281 'ibm281)
+
+(define-coding-system 'ibm290
+ "Japanese katakana version of EBCDIC"
+ :coding-type 'charset
+ :charset-list '(ibm290)
+ :mnemonic ?*)
+(define-coding-system-alias 'ebcdic-jp-kana 'ibm290)
+(define-coding-system-alias 'cp290 'ibm290)
+
(set-language-info-alist
"Japanese" '((setup-function . setup-japanese-environment-internal)
(exit-function . use-default-char-width-table)
@@ -241,8 +255,10 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>."
(#x2b65 . [#x02E9 #x02E5])
(#x2b66 . [#x02E5 #x02E9])))
table)
- (dolist (elt map)
- (setcar elt (decode-char 'japanese-jisx0213-1 (car elt))))
+ (setq map
+ (mapcar (lambda (x) (cons (decode-char 'japanese-jisx0213-1 (car x))
+ (cdr x)))
+ map))
(setq table (make-translation-table-from-alist map))
(define-translation-table 'jisx0213-to-unicode table)
(define-translation-table 'unicode-to-jisx0213
diff --git a/lisp/language/khmer.el b/lisp/language/khmer.el
index 4a070321961..471af401656 100644
--- a/lisp/language/khmer.el
+++ b/lisp/language/khmer.el
@@ -1,4 +1,4 @@
-;;; khmer.el --- support for Khmer -*- coding: utf-8 -*-
+;;; khmer.el --- support for Khmer -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -31,8 +31,8 @@
(documentation . t)))
(let ((val (list (vector "[\x1780-\x17FF\x19E0-\x19FF\x200C\x200D]+"
- 0 'font-shape-gstring))))
+ 0 #'font-shape-gstring))))
(set-char-table-range composition-function-table '(#x1780 . #x17FF) val)
(set-char-table-range composition-function-table '(#x19E0 . #x19FF) val))
-;; khmer.el ends here
+;;; khmer.el ends here
diff --git a/lisp/language/korea-util.el b/lisp/language/korea-util.el
index 24e6627d82b..b999eff662f 100644
--- a/lisp/language/korea-util.el
+++ b/lisp/language/korea-util.el
@@ -1,4 +1,4 @@
-;;; korea-util.el --- utilities for Korean
+;;; korea-util.el --- utilities for Korean -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@@ -32,21 +32,25 @@
(purecopy (if (string-match "3" (or (getenv "HANGUL_KEYBOARD_TYPE") ""))
"3"
""))
- "The kind of Korean keyboard for Korean input method.
-\"\" for 2, \"3\" for 3.")
+ "The kind of Korean keyboard for Korean (Hangul) input method.
+\"\" for 2, \"3\" for 3, and \"3f\" for 3f.")
;; functions useful for Korean text input
(defun toggle-korean-input-method ()
- "Turn on or off a Korean text input method for the current buffer."
+ "Turn on or off a Korean text input method for the current buffer.
+The keyboard layout variation used is determined by
+`default-korean-keyboard'."
(interactive)
(if current-input-method
(deactivate-input-method)
(activate-input-method
(concat "korean-hangul" default-korean-keyboard))))
-(defun quail-hangul-switch-symbol-ksc (&rest ignore)
- "Swith to/from Korean symbol package."
+(defun quail-hangul-switch-symbol-ksc (&rest _ignore)
+ "Switch to/from Korean symbol package.
+The keyboard layout variation used is determined by
+`default-korean-keyboard'."
(interactive "i")
(and current-input-method
(if (string-equal current-input-method "korean-symbol")
@@ -54,8 +58,10 @@
default-korean-keyboard))
(activate-input-method "korean-symbol"))))
-(defun quail-hangul-switch-hanja (&rest ignore)
- "Swith to/from Korean hanja package."
+(defun quail-hangul-switch-hanja (&rest _ignore)
+ "Switch to/from Korean hanja package.
+The keyboard layout variation used is determined by
+`default-korean-keyboard'."
(interactive "i")
(and current-input-method
(if (string-match "korean-hanja" current-input-method)
@@ -70,27 +76,24 @@
(interactive)
(let ((overriding-terminal-local-map nil))
(toggle-korean-input-method))
- (setq isearch-input-method-function input-method-function
- isearch-input-method-local-p t)
- (setq input-method-function nil)
+ (setq isearch-input-method-function input-method-function)
+ (setq-local input-method-function nil)
(isearch-update))
(defun isearch-hangul-switch-symbol-ksc ()
(interactive)
(let ((overriding-terminal-local-map nil))
(quail-hangul-switch-symbol-ksc))
- (setq isearch-input-method-function input-method-function
- isearch-input-method-local-p t)
- (setq input-method-function nil)
+ (setq isearch-input-method-function input-method-function)
+ (setq-local input-method-function nil)
(isearch-update))
(defun isearch-hangul-switch-hanja ()
(interactive)
(let ((overriding-terminal-local-map nil))
(quail-hangul-switch-hanja))
- (setq isearch-input-method-function input-method-function
- isearch-input-method-local-p t)
- (setq input-method-function nil)
+ (setq isearch-input-method-function input-method-function)
+ (setq-local input-method-function nil)
(isearch-update))
;; Information for setting and exiting Korean environment.
diff --git a/lisp/language/korean.el b/lisp/language/korean.el
index 1ab9f76f3e4..bdf8240de96 100644
--- a/lisp/language/korean.el
+++ b/lisp/language/korean.el
@@ -1,4 +1,4 @@
-;;; korean.el --- support for Korean -*- coding: utf-8 -*-
+;;; korean.el --- support for Korean -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -85,6 +85,18 @@ and the following key bindings are available within Korean input methods:
F9, Hangul_Hanja: hangul-to-hanja-conversion")
))
+;; For auto-composing conjoining jamo.
+(let* ((choseong "[\u1100-\u115F\uA960-\uA97C]")
+ (jungseong "[\u1160-\u11A7\uD7B0-\uD7C6]")
+ (jongseong "[\u11A8-\u11FF\uD7CB-\uD7FB]?")
+ (pattern (concat choseong jungseong jongseong)))
+ (set-char-table-range composition-function-table
+ '(#x1100 . #x115F)
+ (list (vector pattern 0 #'font-shape-gstring)))
+ (set-char-table-range composition-function-table
+ '(#xA960 . #xA97C)
+ (list (vector pattern 0 #'font-shape-gstring))))
+
(provide 'korean)
;;; korean.el ends here
diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el
index 0815874367a..c8c3fe4f7e6 100644
--- a/lisp/language/lao-util.el
+++ b/lisp/language/lao-util.el
@@ -1,4 +1,4 @@
-;;; lao-util.el --- utilities for Lao -*- coding: utf-8; -*-
+;;; lao-util.el --- utilities for Lao -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@@ -183,7 +183,9 @@
;; Semi-vowel-sign-lo and lower vowels are put under the letter.
(defconst lao-transcription-consonant-alist
- (sort '(;; single consonants
+ (sort
+ (copy-sequence
+ '(;; single consonants
("k" . "àº")
("kh" . "ຂ")
("qh" . "ຄ")
@@ -223,14 +225,16 @@
("hy" . ["ຫàº"])
("hn" . ["ຫນ"])
("hm" . ["ຫມ"])
- )
- (function (lambda (x y) (> (length (car x)) (length (car y)))))))
+ ))
+ (lambda (x y) (> (length (car x)) (length (car y))))))
(defconst lao-transcription-semi-vowel-alist
'(("r" . "ຼ")))
(defconst lao-transcription-vowel-alist
- (sort '(("a" . "ະ")
+ (sort
+ (copy-sequence
+ '(("a" . "ະ")
("ar" . "າ")
("i" . "ິ")
("ii" . "ີ")
@@ -257,8 +261,8 @@
("ai" . "ໄ")
("ei" . "ໃ")
("ao" . ["ເົາ"])
- ("aM" . "ຳ"))
- (function (lambda (x y) (> (length (car x)) (length (car y)))))))
+ ("aM" . "ຳ")))
+ (lambda (x y) (> (length (car x)) (length (car y))))))
;; Maa-sakod is put at the tail.
(defconst lao-transcription-maa-sakod-alist
@@ -494,10 +498,10 @@ syllable. In that case, FROM and TO are indexes to STR."
(compose-gstring-for-graphic gstring direction)
(or (font-shape-gstring gstring direction)
(let ((glyph-len (lgstring-glyph-len gstring))
- (i 0)
- glyph)
+ (i 0)) ;; glyph
(while (and (< i glyph-len)
- (setq glyph (lgstring-glyph gstring i)))
+ ;; (setq glyph
+ (lgstring-glyph gstring i)) ;;)
(setq i (1+ i)))
(compose-glyph-string-relative gstring 0 i 0.1)))))
diff --git a/lisp/language/lao.el b/lisp/language/lao.el
index 44fe8d230db..c699d57c15a 100644
--- a/lisp/language/lao.el
+++ b/lisp/language/lao.el
@@ -1,4 +1,4 @@
-;;; lao.el --- support for Lao -*- coding: utf-8 -*-
+;;; lao.el --- support for Lao -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@@ -66,7 +66,7 @@
(t (string c))))
(cdr l) ""))
;; Element of composition-function-table.
- (elt (list (vector regexp 1 'lao-composition-function)
+ (elt (list (vector regexp 1 #'lao-composition-function)
fallback-rule))
ch)
(dotimes (i len)
diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el
index e25e63b4c5c..a2ca678b2be 100644
--- a/lisp/language/misc-lang.el
+++ b/lisp/language/misc-lang.el
@@ -1,4 +1,4 @@
-;;; misc-lang.el --- support for miscellaneous languages (characters)
+;;; misc-lang.el --- support for miscellaneous languages (characters) -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
@@ -136,10 +136,63 @@ thin (i.e. 1-dot width) space."
(set-char-table-range
composition-function-table
'(#x600 . #x74F)
- (list (vector "[\u0600-\u074F\u200C\u200D]+" 0
- 'arabic-shape-gstring)
- (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" 1
- 'arabic-shape-gstring)))
+ (list (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+"
+ 1 #'arabic-shape-gstring)
+ (vector "[\u0600-\u074F\u200C\u200D]+"
+ 0 #'arabic-shape-gstring)))
+
+;; The Egyptian Hieroglyph Format Controls were introduced in Unicode
+;; Standard v12.0. Apparently, they are not yet well supported in
+;; existing fonts, as of late 2020. But there's no reason for us not
+;; to be ready for when they will be!
+;; The below is needed to support the arrangement of the Egyptian
+;; Hieroglyphs in "quadrats", as directed by the format controls,
+;; which specify how the hieroglyphs should be joined horizontally and
+;; vertically.
+(defun egyptian-shape-grouping (gstring direction)
+ (if (= (lgstring-char gstring 0) #x13437)
+ (let ((nchars (lgstring-char-len gstring))
+ (i 1)
+ (nesting 1)
+ ch)
+ ;; Find where this group ends.
+ (while (and (< i nchars) (> nesting 0))
+ (setq ch (lgstring-char gstring i))
+ (cond
+ ((= ch #x13437)
+ (setq nesting (1+ nesting)))
+ ((= ch #x13438)
+ (setq nesting (1- nesting))))
+ (setq i (1+ i)))
+ (when (zerop nesting)
+ ;; Make a new gstring from the characters that constitute a
+ ;; complete nested group.
+ (let ((new-header (make-vector (1+ i) nil))
+ (new-gstring (make-vector (+ i 2) nil)))
+ (aset new-header 0 (lgstring-font gstring))
+ (dotimes (j i)
+ (aset new-header (1+ j) (lgstring-char gstring j))
+ (lgstring-set-glyph new-gstring j (lgstring-glyph gstring j)))
+ (lgstring-set-header new-gstring new-header)
+ (font-shape-gstring new-gstring direction))))))
+
+(let ((hieroglyph "[\U00013000-\U0001342F]"))
+ ;; HORIZONTAL/VERTICAL JOINER and INSERT AT.../OVERLAY controls
+ (set-char-table-range
+ composition-function-table
+ '(#x13430 . #x13436)
+ (list (vector (concat hieroglyph "[\U00013430-\U00013436]" hieroglyph)
+ ;; We use font-shape-gstring so that, if the font
+ ;; doesn't support these controls, the glyphs are
+ ;; displayed individually, and not as a single
+ ;; grapheme cluster.
+ 1 #'font-shape-gstring)))
+ ;; Grouping controls
+ (set-char-table-range
+ composition-function-table
+ #x13437
+ (list (vector "\U00013437[\U00013000-\U0001343F]+"
+ 0 #'egyptian-shape-grouping))))
(provide 'misc-lang)
diff --git a/lisp/language/romanian.el b/lisp/language/romanian.el
index 2b189dbcd05..2112df7b150 100644
--- a/lisp/language/romanian.el
+++ b/lisp/language/romanian.el
@@ -1,4 +1,4 @@
-;;; romanian.el --- support for Romanian -*- coding: utf-8 -*-
+;;; romanian.el --- support for Romanian -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/language/sinhala.el b/lisp/language/sinhala.el
index efd8aacc5ac..89392ad6c50 100644
--- a/lisp/language/sinhala.el
+++ b/lisp/language/sinhala.el
@@ -1,4 +1,4 @@
-;;; sinhala.el --- support for Sinhala -*- coding: utf-8 -*-
+;;; sinhala.el --- support for Sinhala -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -43,6 +43,6 @@
"[\u0D85-\u0D96][\u0D82-\u0D83]?\\|"
;; any other singleton characters
"[\u0D80-\u0DFF]")
- 0 'font-shape-gstring)))
+ 0 #'font-shape-gstring)))
-;; sinhala.el ends here
+;;; sinhala.el ends here
diff --git a/lisp/language/slovak.el b/lisp/language/slovak.el
index 99da8624176..2a738467d20 100644
--- a/lisp/language/slovak.el
+++ b/lisp/language/slovak.el
@@ -1,4 +1,4 @@
-;;; slovak.el --- support for Slovak -*- coding: utf-8 -*-
+;;; slovak.el --- support for Slovak -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/language/tai-viet.el b/lisp/language/tai-viet.el
index 95a0a0608b4..366c39202d3 100644
--- a/lisp/language/tai-viet.el
+++ b/lisp/language/tai-viet.el
@@ -1,4 +1,4 @@
-;;; tai-viet.el --- support for Tai Viet -*- coding: utf-8 -*-
+;;; tai-viet.el --- support for Tai Viet -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007, 2008, 2009, 2010, 2011
@@ -30,7 +30,7 @@
(set-char-table-range composition-function-table
'(#xAA80 . #xAADF)
- 'tai-viet-composition-function)
+ #'tai-viet-composition-function)
(set-language-info-alist
"TaiViet" '((charset unicode)
@@ -56,3 +56,5 @@ The language name is spelled as \"êªêª«êª±êª£ ꪼꪕ\", and the script name is
spelled as \"ꪎꪳ ꪼꪕ\".")))
(provide 'tai-viet)
+
+;;; tai-viet.el ends here
diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el
index f9c57e8ca83..e11a05445c7 100644
--- a/lisp/language/thai-util.el
+++ b/lisp/language/thai-util.el
@@ -1,4 +1,4 @@
-;;; thai-util.el --- utilities for Thai -*- coding: utf-8; -*-
+;;; thai-util.el --- utilities for Thai -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -232,10 +232,10 @@ positions (integers or markers) specifying the region."
(let ((glyph-len (lgstring-glyph-len gstring))
(last-char (lgstring-char gstring
(1- (lgstring-char-len gstring))))
- (i 0)
- glyph)
+ (i 0)) ;; glyph
(while (and (< i glyph-len)
- (setq glyph (lgstring-glyph gstring i)))
+ ;; (setq glyph
+ (lgstring-glyph gstring i)) ;; )
(setq i (1+ i)))
(if (= last-char ?ำ)
(setq i (1- i)))
diff --git a/lisp/language/thai-word.el b/lisp/language/thai-word.el
index 94c6ab98979..5d0389c28df 100644
--- a/lisp/language/thai-word.el
+++ b/lisp/language/thai-word.el
@@ -1,4 +1,4 @@
-;;; thai-word.el -- find Thai word boundaries
+;;; thai-word.el --- find Thai word boundaries -*- lexical-binding: t; -*-
;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -10973,8 +10973,7 @@ If COUNT is negative, move point backward (- COUNT) words."
;; special instead of using forward-word.
(let ((start (point))
(limit (match-end 0))
- boundaries
- tail)
+ boundaries) ;; tail
;; If thai-forward-word has been called within a Thai
;; region, we must go back until the Thai region starts
;; to do the contextual analysis for finding word
@@ -11075,4 +11074,4 @@ With argument, do this that many times."
;; coding: utf-8
;; End:
-;; end of thai-word.el
+;;; thai-word.el ends here
diff --git a/lisp/language/thai.el b/lisp/language/thai.el
index 44a9a319330..be15db49db9 100644
--- a/lisp/language/thai.el
+++ b/lisp/language/thai.el
@@ -1,4 +1,4 @@
-;;; thai.el --- support for Thai -*- coding: utf-8 -*-
+;;; thai.el --- support for Thai -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el
index 69db76670d8..ddf4a0c0fb1 100644
--- a/lisp/language/tibet-util.el
+++ b/lisp/language/tibet-util.el
@@ -1,4 +1,4 @@
-;;; tibet-util.el --- utilities for Tibetan -*- coding: utf-8-emacs; -*-
+;;; tibet-util.el --- utilities for Tibetan -*- coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -43,13 +43,17 @@
("་" . "་")
("༔" . "༔")
;; Yes these are dirty. But ...
- ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎]))
+ ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎")
+ 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎]))
("༄༅༅" . ,(compose-string
- "à¿à¿‚à¿‚à¿‚" 0 4
+ (copy-sequence "à¿à¿‚à¿‚à¿‚") 0 4
[?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚]))
- ("༄༅" . ,(compose-string "à¿à¿‚à¿‚" 0 3 [?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚]))
- ("༆" . ,(compose-string "à¿à¿‚༙" 0 3 [?à¿ (Br . Bl) ?à¿‚ (br . tr) ?༙]))
- ("༄" . ,(compose-string "à¿à¿‚" 0 2 [?à¿ (Br . Bl) ?à¿‚]))))
+ ("༄༅" . ,(compose-string (copy-sequence "à¿à¿‚à¿‚")
+ 0 3 [?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚]))
+ ("༆" . ,(compose-string (copy-sequence "à¿à¿‚༙")
+ 0 3 [?࿠(Br . Bl) ?࿂ (br . tr) ?༙]))
+ ("༄" . ,(compose-string (copy-sequence "à¿à¿‚")
+ 0 2 [?à¿ (Br . Bl) ?à¿‚]))))
;;;###autoload
(defun tibetan-char-p (ch)
@@ -122,42 +126,42 @@ The returned string has no composition information."
(setq t-str-list (cons (substring str idx) t-str-list)))
(apply 'concat (nreverse t-str-list))))
-;;;
+;;
;;; Functions for composing/decomposing Tibetan sequence.
-;;;
-;;; A Tibetan syllable is typically structured as follows:
-;;;
-;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]]
-;;;
-;;; where C's are all vertically stacked, V appears below or above
-;;; consonant cluster and M is always put above the C[C+]V combination.
-;;; (Sanskrit visarga, though it is a vowel modifier, is considered
-;;; to be a punctuation.)
-;;;
-;;; Here are examples of the words "bsgrubs" and "hfauM"
-;;;
-;;; བསྒྲུབས ཧཱུཾ
-;;;
-;;; M
-;;; b s b s h
-;;; g fa
-;;; r u
-;;; u
-;;;
-;;; Consonants `'' (འ), `w' (à½), `y' (ཡ), `r' (ར) take special
-;;; forms when they are used as subjoined consonant. Consonant `r'
-;;; takes another special form when used as superjoined in such a case
-;;; as "rka", while it does not change its form when conjoined with
-;;; subjoined `'', `w' or `y' as in "rwa", "rya".
-
-;; Append a proper composition rule and glyph to COMPONENTS to compose
-;; CHAR with a composition that has COMPONENTS.
+;;
+;; A Tibetan syllable is typically structured as follows:
+;;
+;; [Prefix] C [C+] V [M] [Suffix [Post suffix]]
+;;
+;; where C's are all vertically stacked, V appears below or above
+;; consonant cluster and M is always put above the C[C+]V combination.
+;; (Sanskrit visarga, though it is a vowel modifier, is considered
+;; to be a punctuation.)
+;;
+;; Here are examples of the words "bsgrubs" and "hfauM"
+;;
+;; བསྒྲུབས ཧཱུཾ
+;;
+;; M
+;; b s b s h
+;; g fa
+;; r u
+;; u
+;;
+;; Consonants `'' (འ), `w' (à½), `y' (ཡ), `r' (ར) take special
+;; forms when they are used as subjoined consonant. Consonant `r'
+;; takes another special form when used as superjoined in such a case
+;; as "rka", while it does not change its form when conjoined with
+;; subjoined `'', `w' or `y' as in "rwa", "rya".
+
+; Append a proper composition rule and glyph to COMPONENTS to compose
+; CHAR with a composition that has COMPONENTS.
(defun tibetan-add-components (components char)
(let ((last (last components))
(stack-upper '(tc . bc))
(stack-under '(bc . tc))
- rule comp-vowel tmp)
+ rule comp-vowel)
;; Special treatment for 'a chung.
;; If 'a follows a consonant, turn it into the subjoined form.
;; * Disabled by Tomabechi 2000/06/09 *
@@ -242,7 +246,7 @@ The returned string has no composition information."
(defun tibetan-compose-region (beg end)
"Compose Tibetan text the region BEG and END."
(interactive "r")
- (let (str result chars)
+ ;; (let (str result chars)
(save-excursion
(save-restriction
(narrow-to-region beg end)
@@ -268,10 +272,10 @@ The returned string has no composition information."
(while (< (point) to)
(tibetan-add-components components (following-char))
(forward-char 1))
- (compose-region from to components)))))))
+ (compose-region from to components)))))) ;; )
(defvar tibetan-decompose-precomposition-alist
- (mapcar (function (lambda (x) (cons (string-to-char (cdr x)) (car x))))
+ (mapcar (lambda (x) (cons (string-to-char (cdr x)) (car x)))
tibetan-precomposition-rule-alist))
;;;###autoload
diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el
index 0d31780b480..48c7638948c 100644
--- a/lisp/language/tibetan.el
+++ b/lisp/language/tibetan.el
@@ -1,4 +1,4 @@
-;;; tibetan.el --- support for Tibetan language -*- coding: utf-8-emacs; -*-
+;;; tibetan.el --- support for Tibetan language -*- coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -326,7 +326,9 @@
(defconst tibetan-subjoined-transcription-alist
- (sort '(("+k" . "à¾")
+ (sort
+ (copy-sequence
+ '(("+k" . "à¾")
("+kh" . "ྑ")
("+g" . "ྒ")
("+gh" . "ྒྷ")
@@ -371,8 +373,8 @@
("+W" . "ྺ") ;; fixed form subscribed WA
("+Y" . "ྻ") ;; fixed form subscribed YA
("+R" . "ྼ") ;; fixed form subscribed RA
- )
- (lambda (x y) (> (length (car x)) (length (car y))))))
+ ))
+ (lambda (x y) (> (length (car x)) (length (car y))))))
;;;
;;; alist for Tibetan base consonant <-> subjoined consonant conversion.
@@ -603,7 +605,7 @@ This also matches some punctuation characters which need conversion.")
;; For automatic composition.
(set-char-table-range
composition-function-table '(#xF00 . #xFD1)
- (list (vector tibetan-composable-pattern 0 'font-shape-gstring)))
+ (list (vector tibetan-composable-pattern 0 #'font-shape-gstring)))
(provide 'tibetan)
diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el
index 7ce8ee1e500..207d76f47c1 100644
--- a/lisp/language/tv-util.el
+++ b/lisp/language/tv-util.el
@@ -1,4 +1,4 @@
-;;; tv-util.el --- support for Tai Viet -*- coding: utf-8 -*-
+;;; tv-util.el --- support for Tai Viet -*- lexical-binding: t; -*-
;; Copyright (C) 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -128,7 +128,7 @@
;;;###autoload
-(defun tai-viet-composition-function (from to font-object string _direction)
+(defun tai-viet-composition-function (from _to _font-object string _direction)
(if string
(if (string-match tai-viet-re string from)
(tai-viet-compose-string from (match-end 0) string))
@@ -136,5 +136,6 @@
(if (looking-at tai-viet-re)
(tai-viet-compose-region from (match-end 0)))))
-;;
(provide 'tai-viet-util)
+
+;;; tv-util.el ends here
diff --git a/lisp/language/utf-8-lang.el b/lisp/language/utf-8-lang.el
index 2b85f1b2073..f23b3889cc4 100644
--- a/lisp/language/utf-8-lang.el
+++ b/lisp/language/utf-8-lang.el
@@ -1,4 +1,4 @@
-;;; utf-8-lang.el --- generic UTF-8 language environment
+;;; utf-8-lang.el --- generic UTF-8 language environment -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/language/viet-util.el b/lisp/language/viet-util.el
index 177b04bc473..bfaf0f3b94a 100644
--- a/lisp/language/viet-util.el
+++ b/lisp/language/viet-util.el
@@ -1,4 +1,4 @@
-;;; viet-util.el --- utilities for Vietnamese -*- coding: utf-8; -*-
+;;; viet-util.el --- utilities for Vietnamese -*- lexical-binding: t; -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el
index 7ab3b4f2431..7980041e2b3 100644
--- a/lisp/language/vietnamese.el
+++ b/lisp/language/vietnamese.el
@@ -1,4 +1,4 @@
-;;; vietnamese.el --- support for Vietnamese -*- coding: utf-8; -*-
+;;; vietnamese.el --- support for Vietnamese -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 5948b6a67e4..e6ac5d54fc7 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -1,4 +1,4 @@
-;;; loaddefs.el --- automatically extracted autoloads
+;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*-
;;
;;; Code:
@@ -55,14 +55,14 @@ should return a grid vector array that is the new solution.
\(fn BREEDER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "5x5" '("5x5-")))
+(register-definition-prefixes "5x5" '("5x5-"))
;;;***
;;;### (autoloads nil "add-log" "vc/add-log.el" (0 0 0 0))
;;; Generated autoloads from vc/add-log.el
-(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
+(put 'change-log-default-name 'safe-local-variable #'string-or-null-p)
(defvar add-log-current-defun-function nil "\
If non-nil, function to guess name of surrounding function.
@@ -192,7 +192,7 @@ old-style time formats for entries are supported.
\(fn OTHER-LOG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "add-log" '("add-log-" "change-log-")))
+(register-definition-prefixes "add-log" '("add-log-" "change-log-"))
;;;***
@@ -329,7 +329,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
(function-put 'defadvice 'lisp-indent-function '2)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "advice" '("ad-")))
+(register-definition-prefixes "advice" '("ad-"))
;;;***
@@ -432,7 +432,7 @@ A replacement function for `newline-and-indent', aligning as it goes.
The alignment is done by calling `align' on the region that was
indented." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "align" '("align-")))
+(register-definition-prefixes "align" '("align-"))
;;;***
@@ -477,31 +477,31 @@ 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-use-hanging-indents 'safe-local-variable #'booleanp)
(put 'allout-reindent-bodies 'safe-local-variable (lambda (x) (memq x '(nil t text force))))
-(put 'allout-show-bodies 'safe-local-variable (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-show-bodies 'safe-local-variable #'booleanp)
-(put 'allout-header-prefix 'safe-local-variable 'stringp)
+(put 'allout-header-prefix 'safe-local-variable #'stringp)
-(put 'allout-primary-bullet 'safe-local-variable 'stringp)
+(put 'allout-primary-bullet 'safe-local-variable #'stringp)
-(put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-plain-bullets-string 'safe-local-variable #'stringp)
-(put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-distinctive-bullets-string 'safe-local-variable #'stringp)
(put 'allout-use-mode-specific-leader 'safe-local-variable (lambda (x) (or (memq x '(t nil allout-mode-leaders comment-start)) (stringp x))))
-(put 'allout-old-style-prefixes 'safe-local-variable (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-old-style-prefixes 'safe-local-variable #'booleanp)
-(put 'allout-stylish-prefixes 'safe-local-variable (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil)))))
+(put 'allout-stylish-prefixes 'safe-local-variable #'booleanp)
-(put 'allout-numbered-bullet 'safe-local-variable (if (fboundp 'string-or-null-p) 'string-or-null-p (lambda (x) (or (stringp x) (null x)))))
+(put 'allout-numbered-bullet 'safe-local-variable #'string-or-null-p)
-(put 'allout-file-xref-bullet 'safe-local-variable (if (fboundp 'string-or-null-p) 'string-or-null-p (lambda (x) (or (stringp x) (null x)))))
+(put 'allout-file-xref-bullet 'safe-local-variable #'string-or-null-p)
-(put 'allout-presentation-padding 'safe-local-variable 'integerp)
+(put 'allout-presentation-padding 'safe-local-variable #'integerp)
(put 'allout-layout 'safe-local-variable (lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
@@ -511,10 +511,19 @@ Return t if `allout-mode' is active in current buffer." nil t)
(autoload 'allout-mode "allout" "\
Toggle Allout outline mode.
-If called interactively, enable Allout mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Allout
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `allout-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\<allout-mode-map-value>
Allout outline mode is a minor mode that provides extensive
@@ -778,7 +787,7 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be.
\(fn &optional ARG)" t nil)
-(defalias 'outlinify-sticky 'outlineify-sticky)
+(defalias 'outlinify-sticky #'outlineify-sticky)
(autoload 'outlineify-sticky "allout" "\
Activate outline mode and establish file var so it is started subsequently.
@@ -788,7 +797,7 @@ for details on preparing Emacs for automatic allout activation.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "allout" '("allout-")))
+(register-definition-prefixes "allout" '("allout-"))
;;;***
@@ -821,15 +830,24 @@ 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)))))
+(put 'allout-widgets-mode-inhibit 'safe-local-variable #'booleanp)
(autoload 'allout-widgets-mode "allout-widgets" "\
Toggle Allout Widgets mode.
-If called interactively, enable Allout-Widgets mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Allout-Widgets mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `allout-widgets-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Allout Widgets mode is an extension of Allout mode that provides
graphical decoration of outline structure. It is meant to
@@ -851,7 +869,7 @@ outline hot-spot navigation (see `allout-mode').
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "allout-widgets" '("allout-")))
+(register-definition-prefixes "allout-widgets" '("allout-"))
;;;***
@@ -874,7 +892,7 @@ directory, so that Emacs will know its current contents.
\(fn OPERATION &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ange-ftp" '("ange-ftp-" "ftp-error" "internal-ange-ftp-mode")))
+(register-definition-prefixes "ange-ftp" '("ange-ftp-" "ftp-error" "internal-ange-ftp-mode"))
;;;***
@@ -908,7 +926,7 @@ the buffer *Birthday-Present-for-Name*.
\(fn &optional NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "animate" '("animat")))
+(register-definition-prefixes "animate" '("animat"))
;;;***
@@ -934,7 +952,12 @@ This is a good function to put in `comint-output-filter-functions'.
\(fn IGNORED)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ansi-color" '("ansi-color-")))
+(autoload 'ansi-color-compilation-filter "ansi-color" "\
+Maybe translate SGR control sequences into text properties.
+This function depends on the `ansi-color-for-compilation-mode'
+variable, and is meant to be used in `compilation-filter-hook'." nil nil)
+
+(register-definition-prefixes "ansi-color" '("ansi-color-"))
;;;***
@@ -969,7 +992,7 @@ Major mode for editing ANTLR grammar files.
Use ANTLR's convention for TABs according to `antlr-tab-offset-alist'.
Used in `antlr-mode'. Also a useful function in `java-mode-hook'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "antlr-mode" '("antlr-")))
+(register-definition-prefixes "antlr-mode" '("antlr-"))
;;;***
@@ -992,7 +1015,7 @@ ARG is positive, otherwise off.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "appt" '("appt-")))
+(register-definition-prefixes "appt" '("appt-"))
;;;***
@@ -1038,7 +1061,20 @@ will be buffer-local when set.
\(fn PATTERN &optional BUFFER)" t nil)
-(defalias 'command-apropos 'apropos-command)
+(autoload 'apropos-function "apropos" "\
+Show functions that match 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.
+
+This is the same as running `apropos-command' with a \\[universal-argument] prefix,
+or a non-nil `apropos-do-all' argument.
+
+\(fn PATTERN)" t nil)
+
+(defalias 'command-apropos #'apropos-command)
(autoload 'apropos-command "apropos" "\
Show commands (interactively callable functions) that match PATTERN.
@@ -1076,7 +1112,7 @@ search for matches for any two (or more) of those words.
With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil,
consider all symbols (if they match PATTERN).
-Returns list of symbols and documentation found.
+Return list of symbols and documentation found.
\(fn PATTERN &optional DO-ALL)" t nil)
@@ -1126,7 +1162,7 @@ Returns list of symbols and documentation found.
\(fn PATTERN &optional DO-ALL)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "apropos" '("apropos-")))
+(register-definition-prefixes "apropos" '("apropos-"))
;;;***
@@ -1136,11 +1172,11 @@ Returns list of symbols and documentation found.
(autoload 'archive-mode "arc-mode" "\
Major mode for viewing an archive file in a dired-like way.
You can move around using the usual cursor motion commands.
-Letters no longer insert themselves.
-Type `e' to pull a file out of the archive and into its own buffer;
+Letters no longer insert themselves.\\<archive-mode-map>
+Type \\[archive-extract] to pull a file out of the archive and into its own buffer;
or click mouse-2 on the file's line in the archive mode buffer.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[archive-extract] command) and
save it, the contents of that buffer will be saved back into the
archive.
@@ -1148,7 +1184,7 @@ archive.
\(fn &optional FORCE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "arc-mode" '("arc")))
+(register-definition-prefixes "arc-mode" '("arc"))
;;;***
@@ -1175,16 +1211,18 @@ in array mode may have different values assigned to the variables.
The variables are:
Variables you assign:
- array-max-row: The number of rows in the array.
- array-max-column: The number of columns in the array.
- array-columns-per-line: The number of columns in the array per line of buffer.
- array-field-width: The width of each field, in characters.
- array-rows-numbered: A logical variable describing whether to ignore
- row numbers in the buffer.
+ `array-max-row': The number of rows in the array.
+ `array-max-column': The number of columns in the array.
+ `array-columns-per-line': The number of columns in the array
+ per line of buffer.
+ `array-field-width': The width of each field, in characters.
+ `array-rows-numbered': A logical variable describing whether to ignore
+ row numbers in the buffer.
Variables which are calculated:
- array-line-length: The number of characters in a buffer line.
- array-lines-per-row: The number of buffer lines used to display each row.
+ `array-line-length': The number of characters in a buffer line.
+ `array-lines-per-row': The number of buffer lines used to
+ display each row.
The following commands are available (an asterisk indicates it may
take a numeric prefix argument):
@@ -1194,17 +1232,17 @@ take a numeric prefix argument):
* \\[array-next-row] Move down one row.
* \\[array-previous-row] Move up one row.
- * \\[array-copy-forward] Copy the current field into the column to the right.
- * \\[array-copy-backward] Copy the current field into the column to the left.
- * \\[array-copy-down] Copy the current field into the row below.
- * \\[array-copy-up] Copy the current field into the row above.
+ * \\[array-copy-forward] Copy current field into the column to the right.
+ * \\[array-copy-backward] Copy current field into the column to the left.
+ * \\[array-copy-down] Copy current field into the row below.
+ * \\[array-copy-up] Copy current field into the row above.
- * \\[array-copy-column-forward] Copy the current column into the column to the right.
- * \\[array-copy-column-backward] Copy the current column into the column to the left.
+ * \\[array-copy-column-forward] Copy current column into the column to the right.
+ * \\[array-copy-column-backward] Copy current column into the column to the left.
* \\[array-copy-row-down] Copy the current row into the row below.
* \\[array-copy-row-up] Copy the current row into the row above.
- \\[array-fill-rectangle] Copy the field at mark into every cell with row and column
+ \\[array-fill-rectangle] Copy field at mark into every cell with row and column
between that of point and mark.
\\[array-what-position] Display the current array row and column.
@@ -1215,27 +1253,35 @@ take a numeric prefix argument):
\\[array-expand-rows] Expand the array (remove row numbers and
newlines inside rows)
- \\[array-display-local-variables] Display the current values of local variables.
+ \\[array-display-local-variables] Display current values of local variables.
Entering array mode calls the function `array-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward")))
+(register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward"))
;;;***
;;;### (autoloads nil "artist" "textmodes/artist.el" (0 0 0 0))
;;; Generated autoloads from textmodes/artist.el
-(push (purecopy '(artist 1 2 6)) package--builtin-versions)
(autoload 'artist-mode "artist" "\
Toggle Artist mode.
-If called interactively, enable Artist mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Artist
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `artist-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Artist lets you draw lines, squares, rectangles and poly-lines,
ellipses and circles with your mouse and/or keyboard.
@@ -1434,7 +1480,7 @@ Keymap summary
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "artist" '("artist-")))
+(register-definition-prefixes "artist" '("artist-"))
;;;***
@@ -1463,7 +1509,7 @@ Special commands:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "asm-mode" '("asm-")))
+(register-definition-prefixes "asm-mode" '("asm-"))
;;;***
@@ -1480,14 +1526,15 @@ let-binding.")
(autoload 'authinfo-mode "auth-source" "\
Mode for editing .authinfo/.netrc files.
-This is just like `fundamental-mode', but hides passwords. The
-passwords are revealed when point moved into the password.
+This is just like `fundamental-mode', but has basic syntax
+highlighting and hides passwords. Passwords are revealed when
+point is moved into the passwords (see `authinfo-hide-elements').
\\{authinfo-mode-map}
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "auth-source" '("auth")))
+(register-definition-prefixes "auth-source" '("auth"))
;;;***
@@ -1506,7 +1553,7 @@ ENTRY is the name of a password-store entry.
The key used to retrieve the password is the symbol `secret'.
The convention used as the format for a password-store file is
-the following (see http://www.passwordstore.org/#organization):
+the following (see URL `https://www.passwordstore.org/#organization'):
secret
key1: value1
@@ -1514,7 +1561,7 @@ key2: value2
\(fn KEY ENTRY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "auth-source-pass" '("auth-source-pass-")))
+(register-definition-prefixes "auth-source-pass" '("auth-source-pass-"))
;;;***
@@ -1564,10 +1611,19 @@ or call the function `autoarg-kp-mode'.")
(autoload 'autoarg-kp-mode "autoarg" "\
Toggle Autoarg-KP mode, a global minor mode.
-If called interactively, enable Autoarg-Kp mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Autoarg-Kp
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'autoarg-kp-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\<autoarg-kp-mode-map>
This is similar to `autoarg-mode' but rebinds the keypad keys
@@ -1577,7 +1633,7 @@ This is similar to `autoarg-mode' but rebinds the keypad keys
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoarg" '("autoarg-")))
+(register-definition-prefixes "autoarg" '("autoarg-"))
;;;***
@@ -1589,7 +1645,7 @@ Major mode for editing Autoconf configure.ac files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoconf" '("autoconf-")))
+(register-definition-prefixes "autoconf" '("autoconf-"))
;;;***
@@ -1620,17 +1676,26 @@ or call the function `auto-insert-mode'.")
(autoload 'auto-insert-mode "autoinsert" "\
Toggle Auto-insert mode, a global minor mode.
-If called interactively, enable Auto-Insert mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Auto-Insert mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'auto-insert-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Auto-insert mode is enabled, when new files are created you can
insert a template for the file depending on the mode of the buffer.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoinsert" '("auto-insert")))
+(register-definition-prefixes "autoinsert" '("auto-insert"))
;;;***
@@ -1668,21 +1733,36 @@ The function does NOT recursively descend into subdirectories of the
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.
+autoload definitions. 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.
\(fn &rest DIRS)" t nil)
+(make-obsolete 'update-directory-autoloads 'make-directory-autoloads '"28.1")
+
+(autoload 'make-directory-autoloads "autoload" "\
+Update autoload definitions for Lisp files in the directories DIRS.
+DIR can be either a single directory or a list of
+directories. (The latter usage is discouraged.)
+
+The autoloads will be written to OUTPUT-FILE. If any Lisp file
+binds `generated-autoload-file' as a file-local variable, write
+its autoloads into the specified file instead.
+
+The function does NOT recursively descend into subdirectories of the
+directory or directories specified.
+
+\(fn DIR OUTPUT-FILE)" t nil)
+
(autoload 'batch-update-autoloads "autoload" "\
Update loaddefs.el autoloads in batch mode.
Calls `update-directory-autoloads' on the command line arguments.
Definitions are written to `generated-autoload-file' (which
should be non-nil)." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autoload" '("autoload-" "generate" "make-autoload" "no-update-autoloads")))
+(register-definition-prefixes "autoload" '("autoload-" "batch-update-autoloads--summary" "generate" "make-autoload" "no-update-autoloads"))
;;;***
@@ -1692,10 +1772,19 @@ should be non-nil)." nil nil)
(autoload 'auto-revert-mode "autorevert" "\
Toggle reverting buffer when the file changes (Auto-Revert Mode).
-If called interactively, enable Auto-Revert mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Auto-Revert mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `auto-revert-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Auto-Revert Mode is a minor mode that affects only the current
buffer. When enabled, it reverts the buffer when the file on
@@ -1704,6 +1793,10 @@ disk changes.
When a buffer is reverted, a message is generated. This can be
suppressed by setting `auto-revert-verbose' to nil.
+Reverting can sometimes fail to preserve all the markers in the buffer.
+To avoid that, set `revert-buffer-insert-file-contents-function' to
+the slower function `revert-buffer-insert-file-contents-delicately'.
+
Use `global-auto-revert-mode' to automatically revert all buffers.
Use `auto-revert-tail-mode' if you know that the file will only grow
without being changed in the part that is already in the buffer.
@@ -1719,10 +1812,19 @@ This function is designed to be added to hooks, for example:
(autoload 'auto-revert-tail-mode "autorevert" "\
Toggle reverting tail of buffer when the file grows.
-If called interactively, enable Auto-Revert-Tail mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Auto-Revert-Tail mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `auto-revert-tail-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Auto-Revert Tail Mode is enabled, the tail of the file is
constantly followed, as with the shell command `tail -f'. This
@@ -1760,10 +1862,19 @@ or call the function `global-auto-revert-mode'.")
(autoload 'global-auto-revert-mode "autorevert" "\
Toggle Global Auto-Revert Mode.
-If called interactively, enable Global Auto-Revert mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+Auto-Revert mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-auto-revert-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Global Auto-Revert Mode is a global minor mode that reverts any
buffer associated with a file when the file changes on disk. Use
@@ -1784,7 +1895,7 @@ specifies in the mode line.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "autorevert" '("auto-revert-" "global-auto-revert-")))
+(register-definition-prefixes "autorevert" '("auto-revert-" "global-auto-revert-"))
;;;***
@@ -1792,7 +1903,7 @@ specifies in the mode line.
;;;;;; 0))
;;; Generated autoloads from emacs-lisp/avl-tree.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "avl-tree" '("avl-tree-")))
+(register-definition-prefixes "avl-tree" '("avl-tree-"))
;;;***
@@ -1803,7 +1914,7 @@ specifies in the mode line.
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'.")
+use either \\[customize] or \\[mouse-avoidance-mode].")
(custom-autoload 'mouse-avoidance-mode "avoid" nil)
@@ -1832,7 +1943,7 @@ definition of \"random distance\".)
\(fn &optional MODE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "avoid" '("mouse-avoidance-")))
+(register-definition-prefixes "avoid" '("mouse-avoidance-"))
;;;***
@@ -1845,7 +1956,7 @@ definition of \"random distance\".)
Print a trace of Lisp function calls currently active.
Output stream used is value of `standard-output'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "backtrace" '("backtrace-")))
+(register-definition-prefixes "backtrace" '("backtrace-"))
;;;***
@@ -1865,7 +1976,7 @@ Run script using `bat-run' and `bat-run-args'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bat-mode" '("bat-")))
+(register-definition-prefixes "bat-mode" '("bat-"))
;;;***
@@ -1891,10 +2002,19 @@ or call the function `display-battery-mode'.")
(autoload 'display-battery-mode "battery" "\
Toggle battery status display in mode line (Display Battery mode).
-If called interactively, enable Display-Battery mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Display-Battery mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'display-battery-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
The text displayed in the mode line is controlled by
`battery-mode-line-format' and `battery-status-function'.
@@ -1903,7 +2023,7 @@ seconds.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "battery" '("battery-")))
+(register-definition-prefixes "battery" '("battery-"))
;;;***
@@ -1911,6 +2031,20 @@ seconds.
;;;;;; 0 0))
;;; Generated autoloads from emacs-lisp/benchmark.el
+(autoload 'benchmark-call "benchmark" "\
+Measure the run time of calling FUNC a number REPETITIONS of times.
+The result is a list (TIME GC GCTIME)
+where TIME is the total time it took, in seconds.
+GCTIME is the amount of time that was spent in the GC
+and GC is the number of times the GC was called.
+
+REPETITIONS can also be a floating point number, in which case it
+specifies a minimum number of seconds that the benchmark execution
+should take. In that case the return value is prepended with the
+number of repetitions actually used.
+
+\(fn FUNC &optional REPETITIONS)" nil nil)
+
(autoload 'benchmark-run "benchmark" "\
Time execution of FORMS.
If REPETITIONS is supplied as a number, run FORMS that many times,
@@ -1940,6 +2074,8 @@ Interactively, REPETITIONS is taken from the prefix arg, and
the command prompts for the form to benchmark.
For non-interactive use see also `benchmark-run' and
`benchmark-run-compiled'.
+FORM can also be a function in which case we measure the time it takes
+to call it without any argument.
\(fn REPETITIONS FORM)" t nil)
@@ -1951,14 +2087,14 @@ The return value is the value of the final form in BODY.
(function-put 'benchmark-progn 'lisp-indent-function '0)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "benchmark" '("benchmark-elapse")))
+(register-definition-prefixes "benchmark" '("benchmark-"))
;;;***
;;;### (autoloads nil "bib-mode" "textmodes/bib-mode.el" (0 0 0 0))
;;; Generated autoloads from textmodes/bib-mode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bib-mode" '("addbib" "bib-" "mark-bib" "return-key-bib" "unread-bib")))
+(register-definition-prefixes "bib-mode" '("addbib" "bib-" "mark-bib" "return-key-bib" "unread-bib"))
;;;***
@@ -2051,7 +2187,7 @@ A prefix arg negates the value of `bibtex-search-entry-globally'.
\(fn KEY &optional GLOBAL START DISPLAY)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bibtex" '("bibtex-")))
+(register-definition-prefixes "bibtex" '("bibtex-"))
;;;***
@@ -2064,14 +2200,14 @@ Major mode for editing BibTeX style files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bibtex-style" '("bibtex-style-")))
+(register-definition-prefixes "bibtex-style" '("bibtex-style-"))
;;;***
;;;### (autoloads nil "bindat" "emacs-lisp/bindat.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/bindat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bindat" '("bindat-")))
+(register-definition-prefixes "bindat" '("bindat-"))
;;;***
@@ -2097,7 +2233,7 @@ Binhex decode region between START and END.
\(fn START END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "binhex" '("binhex-")))
+(register-definition-prefixes "binhex" '("binhex-"))
;;;***
@@ -2218,7 +2354,7 @@ a reflection.
\(fn NUM)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "blackbox" '("bb-" "blackbox-")))
+(register-definition-prefixes "blackbox" '("bb-" "blackbox-"))
;;;***
@@ -2229,7 +2365,7 @@ a reflection.
(define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite)
(define-key ctl-x-r-map "l" 'bookmark-bmenu-list)
-(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\
+(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) (define-key map "D" 'bookmark-delete-all) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) map) "\
Keymap containing bindings to bookmark functions.
It is not bound to any key by default: to bind it
so that you have a bookmark prefix, just use `global-set-key' and bind a
@@ -2382,6 +2518,13 @@ probably because we were called from there.
\(fn BOOKMARK-NAME &optional BATCH)" t nil)
+(autoload 'bookmark-delete-all "bookmark" "\
+Permanently delete all bookmarks.
+If optional argument NO-CONFIRM is non-nil, don't ask for
+confirmation.
+
+\(fn &optional NO-CONFIRM)" t nil)
+
(autoload 'bookmark-write "bookmark" "\
Write bookmarks to a file (reading the file name with the minibuffer)." t nil)
@@ -2423,6 +2566,10 @@ unique numeric suffixes \"<2>\", \"<3>\", etc.
\(fn FILE &optional OVERWRITE NO-MSG DEFAULT)" t nil)
+(autoload 'bookmark-bmenu-get-buffer "bookmark" "\
+Return the Bookmark List, building it if it doesn't exists.
+Don't affect the buffer ring order." nil nil)
+
(autoload 'bookmark-bmenu-list "bookmark" "\
Display a list of existing bookmarks.
The list is displayed in a buffer named `*Bookmark List*'.
@@ -2434,13 +2581,13 @@ deletion, or > if it is flagged for displaying." t nil)
(defalias 'edit-bookmarks 'bookmark-bmenu-list)
(autoload 'bookmark-bmenu-search "bookmark" "\
-Incremental search of bookmarks, hiding the non-matches as we go." t nil)
+Incremental search of bookmarks, hiding the non-matches as we go." '(bookmark-bmenu-mode) nil)
-(defvar menu-bar-bookmark-map (let ((map (make-sparse-keymap "Bookmark functions"))) (bindings--define-key map [load] '(menu-item "Load a Bookmark File..." bookmark-load :help "Load bookmarks from a bookmark file)")) (bindings--define-key map [write] '(menu-item "Save Bookmarks As..." bookmark-write :help "Write bookmarks to a file (reading the file name with the minibuffer)")) (bindings--define-key map [save] '(menu-item "Save Bookmarks" bookmark-save :help "Save currently defined bookmarks")) (bindings--define-key map [edit] '(menu-item "Edit Bookmark List" bookmark-bmenu-list :help "Display a list of existing bookmarks")) (bindings--define-key map [delete] '(menu-item "Delete Bookmark..." bookmark-delete :help "Delete a bookmark from the bookmark list")) (bindings--define-key map [rename] '(menu-item "Rename Bookmark..." bookmark-rename :help "Change the name of a bookmark")) (bindings--define-key map [locate] '(menu-item "Insert Location..." bookmark-locate :help "Insert the name of the file associated with a bookmark")) (bindings--define-key map [insert] '(menu-item "Insert Contents..." bookmark-insert :help "Insert the text of the file pointed to by a bookmark")) (bindings--define-key map [set] '(menu-item "Set Bookmark..." bookmark-set :help "Set a bookmark named inside a file.")) (bindings--define-key map [jump] '(menu-item "Jump to Bookmark..." bookmark-jump :help "Jump to a bookmark (a point in some file)")) map))
+(defvar menu-bar-bookmark-map (let ((map (make-sparse-keymap "Bookmark functions"))) (bindings--define-key map [load] '(menu-item "Load a Bookmark File..." bookmark-load :help "Load bookmarks from a bookmark file)")) (bindings--define-key map [write] '(menu-item "Save Bookmarks As..." bookmark-write :help "Write bookmarks to a file (reading the file name with the minibuffer)")) (bindings--define-key map [save] '(menu-item "Save Bookmarks" bookmark-save :help "Save currently defined bookmarks")) (bindings--define-key map [edit] '(menu-item "Edit Bookmark List" bookmark-bmenu-list :help "Display a list of existing bookmarks")) (bindings--define-key map [delete] '(menu-item "Delete Bookmark..." bookmark-delete :help "Delete a bookmark from the bookmark list")) (bindings--define-key map [delete-all] '(menu-item "Delete all Bookmarks..." bookmark-delete-all :help "Delete all bookmarks from the bookmark list")) (bindings--define-key map [rename] '(menu-item "Rename Bookmark..." bookmark-rename :help "Change the name of a bookmark")) (bindings--define-key map [locate] '(menu-item "Insert Location..." bookmark-locate :help "Insert the name of the file associated with a bookmark")) (bindings--define-key map [insert] '(menu-item "Insert Contents..." bookmark-insert :help "Insert the text of the file pointed to by a bookmark")) (bindings--define-key map [set] '(menu-item "Set Bookmark..." bookmark-set :help "Set a bookmark named inside a file.")) (bindings--define-key map [jump] '(menu-item "Jump to Bookmark..." bookmark-jump :help "Jump to a bookmark (a point in some file)")) map))
(defalias 'menu-bar-bookmark-map menu-bar-bookmark-map)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bookmark" '("bookmark-" "with-buffer-modified-unmodified")))
+(register-definition-prefixes "bookmark" '("bookmark-" "with-buffer-modified-unmodified"))
;;;***
@@ -2452,18 +2599,36 @@ 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.
-If the value is not a function it should be a list of pairs
-\(REGEXP . FUNCTION). In this case the function called will be the one
-associated with the first REGEXP which matches the current URL. The
-function is passed the URL and any other args of `browse-url'. The last
-regexp should probably be \".\" to specify a default browser.
-
-Also see `browse-url-secondary-browser-function'.")
+Also see `browse-url-secondary-browser-function' and
+`browse-url-handlers'.")
(custom-autoload 'browse-url-browser-function "browse-url" t)
+(defvar browse-url-default-handlers '(("\\`mailto:" . browse-url--mailto) ("\\`man:" . browse-url--man) (browse-url--non-html-file-url-p . browse-url-emacs)) "\
+Like `browse-url-handlers' but populated by Emacs and packages.
+
+Emacs and external packages capable of browsing certain URLs
+should place their entries in this alist rather than
+`browse-url-handlers' which is reserved for the user.")
+
+(autoload 'browse-url-select-handler "browse-url" "\
+Return a handler of suitable for browsing URL.
+This searches `browse-url-handlers', and
+`browse-url-default-handlers' for a matching handler. Return nil
+if no handler is found.
+
+If KIND is given, the search is restricted to handlers whose
+function symbol has the symbol-property `browse-url-browser-kind'
+set to KIND.
+
+Currently, it also consults `browse-url-browser-function' first
+if it is set to an alist, although this usage is deprecated since
+Emacs 28.1 and will be removed in a future release.
+
+\(fn URL &optional KIND)" nil nil)
+
(autoload 'browse-url-of-file "browse-url" "\
-Ask a WWW browser to display FILE.
+Use a web browser to display FILE.
Display the current buffer's file if FILE is nil or if called
interactively. Turn the filename into a URL with function
`browse-url-file-url'. Pass the URL to a browser using the
@@ -2472,7 +2637,9 @@ interactively. Turn the filename into a URL with function
\(fn &optional FILE)" t nil)
(autoload 'browse-url-of-buffer "browse-url" "\
-Ask a WWW browser to display BUFFER.
+Use a web browser to display BUFFER.
+See `browse-url' for details.
+
Display the current buffer if BUFFER is nil. Display only the
currently visible part of BUFFER (from a temporary file) if buffer is
narrowed.
@@ -2483,40 +2650,57 @@ narrowed.
In Dired, ask a WWW browser to display the file named on this line." t nil)
(autoload 'browse-url-of-region "browse-url" "\
-Ask a WWW browser to display the current region.
+Use a web browser to display the current region.
+See `browse-url' for details.
\(fn MIN MAX)" t nil)
(autoload 'browse-url "browse-url" "\
-Ask a WWW browser to load URL.
-Prompt for a URL, defaulting to the URL at or before point.
-Invokes a suitable browser function which does the actual job.
-The variable `browse-url-browser-function' says which browser function to
-use. If the URL is a mailto: URL, consult `browse-url-mailto-function'
-first, if that exists.
-
-The additional ARGS are passed to the browser function. See the doc
-strings of the actual functions, starting with `browse-url-browser-function',
-for information about the significance of ARGS (most of the functions
-ignore it).
-If ARGS are omitted, the default is to pass `browse-url-new-window-flag'
-as ARGS.
+Open URL using a configurable method.
+This will typically (by default) open URL with an external web
+browser, but a wide variety of different methods can be used,
+depending on the URL type.
+
+The variables `browse-url-browser-function',
+`browse-url-handlers', and `browse-url-default-handlers'
+determine which browser function to use.
+
+This command prompts for a URL, defaulting to the URL at or
+before point.
+
+The additional ARGS are passed to the browser function. See the
+doc strings of the actual functions, starting with
+`browse-url-browser-function', for information about the
+significance of ARGS (most of the functions ignore it).
+
+If ARGS are omitted, the default is to pass
+`browse-url-new-window-flag' as ARGS.
\(fn URL &rest ARGS)" t nil)
(autoload 'browse-url-at-point "browse-url" "\
-Ask a WWW browser to load the URL at or before point.
-Variable `browse-url-browser-function' says which browser to use.
+Open URL at point using a configurable method.
+See `browse-url' for details.
Optional prefix argument ARG non-nil inverts the value of the option
`browse-url-new-window-flag'.
\(fn &optional ARG)" t nil)
+(autoload 'browse-url-with-browser-kind "browse-url" "\
+Browse URL with a browser of the given browser KIND.
+KIND is either `internal' or `external'.
+
+When called interactively, the default browser kind is the
+opposite of the browser kind of `browse-url-browser-function'.
+
+\(fn KIND URL &optional ARG)" t nil)
+
(autoload 'browse-url-at-mouse "browse-url" "\
-Ask a WWW browser to load a URL clicked with the mouse.
-The URL is the one around or before the position of the mouse click
-but point is not changed. Variable `browse-url-browser-function'
-says which browser to use.
+Use a web browser to load a URL clicked with the mouse.
+See `browse-url' for details.
+
+The URL is the one around or before the position of the mouse
+click but point is not changed.
\(fn EVENT)" t nil)
@@ -2639,46 +2823,6 @@ used instead of `browse-url-new-window-flag'.
(make-obsolete 'browse-url-gnome-moz 'nil '"25.1")
-(autoload 'browse-url-mosaic "browse-url" "\
-Ask the XMosaic WWW browser to load URL.
-
-Default to the URL around or before point. The strings in variable
-`browse-url-mosaic-arguments' are also passed to Mosaic and the
-program is invoked according to the variable
-`browse-url-mosaic-program'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new Mosaic window, 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'.
-
-\(fn URL &optional NEW-WINDOW)" t nil)
-
-(make-obsolete 'browse-url-mosaic 'nil '"25.1")
-
-(autoload 'browse-url-cci "browse-url" "\
-Ask the XMosaic WWW browser to load URL.
-Default to the URL around or before point.
-
-This function only works for XMosaic version 2.5 or later. You must
-select `CCI' from XMosaic's File menu, set the CCI Port Address to the
-value of variable `browse-url-CCI-port', and enable `Accept requests'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new browser window, 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'.
-
-\(fn URL &optional NEW-WINDOW)" t nil)
-
-(make-obsolete 'browse-url-cci 'nil '"25.1")
-
(autoload 'browse-url-conkeror "browse-url" "\
Ask the Conkeror WWW browser to load URL.
Default to the URL around or before point. Also pass the strings
@@ -2699,6 +2843,8 @@ NEW-WINDOW instead of `browse-url-new-window-flag'.
\(fn URL &optional NEW-WINDOW)" t nil)
+(make-obsolete 'browse-url-conkeror 'nil '"28.1")
+
(autoload 'browse-url-w3 "browse-url" "\
Ask the w3 WWW browser to load URL.
Default to the URL around or before point.
@@ -2792,7 +2938,14 @@ from `browse-url-elinks-wrapper'.
\(fn URL &optional NEW-WINDOW)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "browse-url" '("browse-url-")))
+(autoload 'browse-url-button-open-url "browse-url" "\
+Open URL using `browse-url'.
+If `current-prefix-arg' is non-nil, use
+`browse-url-secondary-browser-function' instead.
+
+\(fn URL)" nil nil)
+
+(register-definition-prefixes "browse-url" '("browse-url-"))
;;;***
@@ -2829,7 +2982,7 @@ name of buffer configuration.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bs" '("bs-")))
+(register-definition-prefixes "bs" '("bs-"))
;;;***
@@ -2850,7 +3003,7 @@ columns on its right towards the left.
\\[bubbles-set-game-difficult] sets the difficulty to difficult.
\\[bubbles-set-game-hard] sets the difficulty to hard." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bubbles" '("bubbles-")))
+(register-definition-prefixes "bubbles" '("bubbles-"))
;;;***
@@ -2865,24 +3018,42 @@ columns on its right towards the left.
(autoload 'bug-reference-mode "bug-reference" "\
Toggle hyperlinking bug references in the buffer (Bug Reference mode).
-If called interactively, enable Bug-Reference mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Bug-Reference mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `bug-reference-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
(autoload 'bug-reference-prog-mode "bug-reference" "\
Like `bug-reference-mode', but only buttonize in comments and strings.
-If called interactively, enable Bug-Reference-Prog mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Bug-Reference-Prog mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `bug-reference-prog-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bug-reference" '("bug-reference-")))
+(register-definition-prefixes "bug-reference" '("bug-reference-"))
;;;***
@@ -2890,7 +3061,7 @@ ARG is `toggle'; disable the mode otherwise.
;;;;;; 0))
;;; Generated autoloads from emacs-lisp/byte-opt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "byte-opt" '("byte-" "disassemble-offset")))
+(register-definition-prefixes "byte-opt" '("byte-" "disassemble-offset"))
;;;***
@@ -2943,18 +3114,25 @@ before scanning it.
If the third argument FORCE is non-nil, recompile every `.el' file
that already has a `.elc' file.
-\(fn DIRECTORY &optional ARG FORCE)" t nil)
+This command will normally not follow symlinks when compiling
+files. If FOLLOW-SYMLINKS is non-nil, symlinked `.el' files will
+also be compiled.
+
+\(fn DIRECTORY &optional ARG FORCE FOLLOW-SYMLINKS)" t nil)
(put 'no-byte-compile 'safe-local-variable 'booleanp)
(autoload 'byte-compile-file "bytecomp" "\
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.
+See also `emacs-lisp-byte-compile-and-load'.
+
\(fn FILENAME &optional LOAD)" t nil)
+(set-advertised-calling-convention 'byte-compile-file '(filename) '"28.1")
+
(autoload 'compile-defun "bytecomp" "\
Compile and evaluate the current top-level form.
Print the result in the echo area.
@@ -3019,7 +3197,7 @@ and corresponding effects.
\(fn &optional ARG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte-" "displaying-byte-compile-warnings" "emacs-lisp-" "no-byte-compile")))
+(register-definition-prefixes "bytecomp" '("batch-byte-compile-file" "byte" "displaying-byte-compile-warnings" "emacs-lisp-" "no-byte-compile"))
;;;***
@@ -3027,7 +3205,7 @@ and corresponding effects.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-bahai.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-bahai" '("calendar-bahai-" "diary-bahai-" "holiday-bahai")))
+(register-definition-prefixes "cal-bahai" '("calendar-bahai-" "diary-bahai-" "holiday-bahai"))
;;;***
@@ -3037,7 +3215,7 @@ and corresponding effects.
(put 'calendar-chinese-time-zone 'risky-local-variable t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-china" '("calendar-chinese-" "diary-chinese-" "holiday-chinese")))
+(register-definition-prefixes "cal-china" '("calendar-chinese-" "diary-chinese-" "holiday-chinese"))
;;;***
@@ -3045,7 +3223,7 @@ and corresponding effects.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-coptic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-coptic" '("calendar-" "diary-")))
+(register-definition-prefixes "cal-coptic" '("calendar-" "diary-"))
;;;***
@@ -3058,7 +3236,7 @@ and corresponding effects.
(put 'calendar-current-time-zone-cache 'risky-local-variable t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-dst" '("calendar-" "dst-")))
+(register-definition-prefixes "cal-dst" '("calendar-" "dst-"))
;;;***
@@ -3066,7 +3244,7 @@ and corresponding effects.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-french.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-french" '("calendar-french-" "diary-french-date")))
+(register-definition-prefixes "cal-french" '("calendar-french-" "diary-french-date"))
;;;***
@@ -3081,14 +3259,14 @@ from the cursor position.
\(fn DEATH-DATE START-YEAR END-YEAR)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-hebrew" '("calendar-hebrew-" "diary-hebrew-" "holiday-hebrew")))
+(register-definition-prefixes "cal-hebrew" '("calendar-hebrew-" "diary-hebrew-" "holiday-hebrew"))
;;;***
;;;### (autoloads nil "cal-html" "calendar/cal-html.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-html.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-html" '("cal-html-")))
+(register-definition-prefixes "cal-html" '("cal-html-"))
;;;***
@@ -3096,14 +3274,14 @@ from the cursor position.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-islam.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-islam" '("calendar-islamic-" "diary-islamic-" "holiday-islamic")))
+(register-definition-prefixes "cal-islam" '("calendar-islamic-" "diary-islamic-" "holiday-islamic"))
;;;***
;;;### (autoloads nil "cal-iso" "calendar/cal-iso.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-iso.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-iso" '("calendar-iso-" "diary-iso-date")))
+(register-definition-prefixes "cal-iso" '("calendar-iso-" "diary-iso-date"))
;;;***
@@ -3111,7 +3289,7 @@ from the cursor position.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-julian.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-julian" '("calendar-" "diary-" "holiday-julian")))
+(register-definition-prefixes "cal-julian" '("calendar-" "diary-" "holiday-julian"))
;;;***
@@ -3119,21 +3297,21 @@ from the cursor position.
;;;;;; 0))
;;; Generated autoloads from calendar/cal-mayan.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-mayan" '("calendar-mayan-" "diary-mayan-date")))
+(register-definition-prefixes "cal-mayan" '("calendar-mayan-" "diary-mayan-date"))
;;;***
;;;### (autoloads nil "cal-menu" "calendar/cal-menu.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-menu.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-menu" '("cal")))
+(register-definition-prefixes "cal-menu" '("cal"))
;;;***
;;;### (autoloads nil "cal-move" "calendar/cal-move.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-move.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-move" '("calendar-")))
+(register-definition-prefixes "cal-move" '("calendar-"))
;;;***
@@ -3141,21 +3319,21 @@ from the cursor position.
;;;;;; 0 0))
;;; Generated autoloads from calendar/cal-persia.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-persia" '("calendar-persian-" "diary-persian-date")))
+(register-definition-prefixes "cal-persia" '("calendar-persian-" "diary-persian-date"))
;;;***
;;;### (autoloads nil "cal-tex" "calendar/cal-tex.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-tex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-tex" '("cal-tex-")))
+(register-definition-prefixes "cal-tex" '("cal-tex-"))
;;;***
;;;### (autoloads nil "cal-x" "calendar/cal-x.el" (0 0 0 0))
;;; Generated autoloads from calendar/cal-x.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cal-x" '("calendar-" "diary-frame")))
+(register-definition-prefixes "cal-x" '("calendar-" "diary-frame"))
;;;***
@@ -3243,248 +3421,224 @@ See Info node `(calc)Defining Functions'.
(function-put 'defmath 'doc-string-elt '3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "calc-aent" "calc/calc-aent.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from calc/calc-aent.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-aent" '("calc" "math-")))
+(register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-"))
;;;***
;;;### (autoloads nil "calc-alg" "calc/calc-alg.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-alg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-alg" '("calc" "math-")))
+(register-definition-prefixes "calc-alg" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-arith" "calc/calc-arith.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-arith.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-arith" '("calc" "math-")))
+(register-definition-prefixes "calc-arith" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-bin" "calc/calc-bin.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-bin.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-bin" '("calc" "math-")))
+(register-definition-prefixes "calc-bin" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-comb" "calc/calc-comb.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-comb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-comb" '("calc" "math-")))
+(register-definition-prefixes "calc-comb" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-cplx" "calc/calc-cplx.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-cplx.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-cplx" '("calc" "math-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "calc-embed" "calc/calc-embed.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from calc/calc-embed.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-embed" '("calc-")))
+(register-definition-prefixes "calc-cplx" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-ext" "calc/calc-ext.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-ext.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-ext" '("calc" "math-" "var-")))
+(register-definition-prefixes "calc-ext" '("calc" "math-" "var-"))
;;;***
;;;### (autoloads nil "calc-fin" "calc/calc-fin.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-fin.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-fin" '("calc" "math-c")))
+(register-definition-prefixes "calc-fin" '("calc" "math-c"))
;;;***
;;;### (autoloads nil "calc-forms" "calc/calc-forms.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-forms.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-forms" '("calc" "math-" "var-TimeZone")))
+(register-definition-prefixes "calc-forms" '("calc" "math-" "var-TimeZone"))
;;;***
;;;### (autoloads nil "calc-frac" "calc/calc-frac.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-frac.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-frac" '("calc" "math-")))
+(register-definition-prefixes "calc-frac" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-funcs" "calc/calc-funcs.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-funcs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-funcs" '("calc" "math-")))
+(register-definition-prefixes "calc-funcs" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-graph" "calc/calc-graph.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-graph.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-graph" '("calc-")))
+(register-definition-prefixes "calc-graph" '("calc-"))
;;;***
;;;### (autoloads nil "calc-help" "calc/calc-help.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-help.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-help" '("calc-")))
+(register-definition-prefixes "calc-help" '("calc-"))
;;;***
;;;### (autoloads nil "calc-incom" "calc/calc-incom.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-incom.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-incom" '("calc-")))
+(register-definition-prefixes "calc-incom" '("calc-"))
;;;***
;;;### (autoloads nil "calc-keypd" "calc/calc-keypd.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-keypd.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-keypd" '("calc-")))
+(register-definition-prefixes "calc-keypd" '("calc-"))
;;;***
;;;### (autoloads nil "calc-lang" "calc/calc-lang.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-lang.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-lang" '("calc-" "math-")))
+(register-definition-prefixes "calc-lang" '("calc-" "math-"))
;;;***
;;;### (autoloads nil "calc-macs" "calc/calc-macs.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-macs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-macs" '("Math-" "calc-" "math-")))
+(register-definition-prefixes "calc-macs" '("Math-" "calc-" "math-"))
;;;***
;;;### (autoloads nil "calc-map" "calc/calc-map.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-map.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-map" '("calc" "math-")))
+(register-definition-prefixes "calc-map" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-math" "calc/calc-math.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-math.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-math" '("calc" "math-")))
+(register-definition-prefixes "calc-math" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-menu" "calc/calc-menu.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-menu.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-menu" '("calc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "calc-misc" "calc/calc-misc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from calc/calc-misc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-misc" '("math-iipow")))
+(register-definition-prefixes "calc-menu" '("calc-"))
;;;***
;;;### (autoloads nil "calc-mode" "calc/calc-mode.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-mode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-mode" '("calc-" "math-get-modes-vec")))
+(register-definition-prefixes "calc-mode" '("calc-" "math-get-modes-vec"))
;;;***
;;;### (autoloads nil "calc-mtx" "calc/calc-mtx.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-mtx.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-mtx" '("calc" "math-")))
+(register-definition-prefixes "calc-mtx" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-nlfit" "calc/calc-nlfit.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-nlfit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-nlfit" '("calc-fit-" "math-nlfit-")))
+(register-definition-prefixes "calc-nlfit" '("calc-fit-" "math-nlfit-"))
;;;***
;;;### (autoloads nil "calc-poly" "calc/calc-poly.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-poly.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-poly" '("calcFunc-" "math-")))
+(register-definition-prefixes "calc-poly" '("calcFunc-" "math-"))
;;;***
;;;### (autoloads nil "calc-prog" "calc/calc-prog.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-prog.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-prog" '("calc" "math-" "var-q")))
+(register-definition-prefixes "calc-prog" '("calc" "math-" "var-q"))
;;;***
;;;### (autoloads nil "calc-rewr" "calc/calc-rewr.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-rewr.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rewr" '("calc" "math-")))
+(register-definition-prefixes "calc-rewr" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-rules" "calc/calc-rules.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-rules.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-rules" '("calc-")))
+(register-definition-prefixes "calc-rules" '("calc-"))
;;;***
;;;### (autoloads nil "calc-sel" "calc/calc-sel.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-sel.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-sel" '("calc-")))
+(register-definition-prefixes "calc-sel" '("calc-"))
;;;***
;;;### (autoloads nil "calc-stat" "calc/calc-stat.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-stat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stat" '("calc" "math-")))
+(register-definition-prefixes "calc-stat" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-store" "calc/calc-store.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-store.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-store" '("calc")))
+(register-definition-prefixes "calc-store" '("calc"))
;;;***
;;;### (autoloads nil "calc-stuff" "calc/calc-stuff.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-stuff.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-stuff" '("calc" "math-")))
+(register-definition-prefixes "calc-stuff" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-trail" "calc/calc-trail.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-trail.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-trail" '("calc-trail-")))
+(register-definition-prefixes "calc-trail" '("calc-trail-"))
;;;***
@@ -3496,57 +3650,49 @@ See Info node `(calc)Defining Functions'.
\(fn N)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-undo" '("calc-")))
+(register-definition-prefixes "calc-undo" '("calc-"))
;;;***
;;;### (autoloads nil "calc-units" "calc/calc-units.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-units.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-units" '("calc" "math-")))
+(register-definition-prefixes "calc-units" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calc-vec" "calc/calc-vec.el" (0 0 0 0))
;;; Generated autoloads from calc/calc-vec.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-vec" '("calc" "math-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "calc-yank" "calc/calc-yank.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from calc/calc-yank.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calc-yank" '("calc-" "math-number-regexp")))
+(register-definition-prefixes "calc-vec" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calcalg2" "calc/calcalg2.el" (0 0 0 0))
;;; Generated autoloads from calc/calcalg2.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg2" '("calc" "math-" "var-IntegLimit")))
+(register-definition-prefixes "calcalg2" '("calc" "math-" "var-IntegLimit"))
;;;***
;;;### (autoloads nil "calcalg3" "calc/calcalg3.el" (0 0 0 0))
;;; Generated autoloads from calc/calcalg3.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcalg3" '("calc" "math-")))
+(register-definition-prefixes "calcalg3" '("calc" "math-"))
;;;***
;;;### (autoloads nil "calccomp" "calc/calccomp.el" (0 0 0 0))
;;; Generated autoloads from calc/calccomp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calccomp" '("calcFunc-c" "math-")))
+(register-definition-prefixes "calccomp" '("calcFunc-c" "math-"))
;;;***
;;;### (autoloads nil "calcsel2" "calc/calcsel2.el" (0 0 0 0))
;;; Generated autoloads from calc/calcsel2.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calcsel2" '("calc-")))
+(register-definition-prefixes "calcsel2" '("calc-"))
;;;***
@@ -3557,7 +3703,7 @@ See Info node `(calc)Defining Functions'.
Run the Emacs calculator.
See the documentation for `calculator-mode' for more information." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calculator" '("calculator-")))
+(register-definition-prefixes "calculator" '("calculator-"))
;;;***
@@ -3601,7 +3747,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "calendar" '("calendar-" "diary-" "holiday-buffer" "lunar-phases-buffer" "solar-sunrises-buffer")))
+(register-definition-prefixes "calendar" '("calendar-" "diary-" "holiday-buffer" "lunar-phases-buffer" "solar-sunrises-buffer"))
;;;***
@@ -3620,21 +3766,21 @@ it fails.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "canlock" '("canlock-")))
+(register-definition-prefixes "canlock" '("canlock-"))
;;;***
;;;### (autoloads nil "cc-align" "progmodes/cc-align.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-align.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-align" '("c-")))
+(register-definition-prefixes "cc-align" '("c-"))
;;;***
;;;### (autoloads nil "cc-awk" "progmodes/cc-awk.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-awk.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-awk" '("awk-" "c-awk-")))
+(register-definition-prefixes "cc-awk" '("awk-" "c-awk-"))
;;;***
@@ -3642,21 +3788,21 @@ it fails.
;;;;;; 0 0 0))
;;; Generated autoloads from progmodes/cc-bytecomp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-bytecomp" '("cc-")))
+(register-definition-prefixes "cc-bytecomp" '("cc-"))
;;;***
;;;### (autoloads nil "cc-cmds" "progmodes/cc-cmds.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-cmds.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-cmds" '("c-")))
+(register-definition-prefixes "cc-cmds" '("c-"))
;;;***
;;;### (autoloads nil "cc-defs" "progmodes/cc-defs.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-defs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-defs" '("c-" "cc-bytecomp-compiling-or-loading")))
+(register-definition-prefixes "cc-defs" '("c-" "cc-bytecomp-compiling-or-loading"))
;;;***
@@ -3667,14 +3813,14 @@ it fails.
(autoload 'c-guess-basic-syntax "cc-engine" "\
Return the syntactic context of the current line." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-engine" '("c-")))
+(register-definition-prefixes "cc-engine" '("c-"))
;;;***
;;;### (autoloads nil "cc-fonts" "progmodes/cc-fonts.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-fonts.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords")))
+(register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "doxygen-font-lock-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))
;;;***
@@ -3774,21 +3920,21 @@ the absolute file name of the file if STYLE-NAME is nil.
\(fn &optional STYLE-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-guess" '("c-guess-")))
+(register-definition-prefixes "cc-guess" '("c-guess-"))
;;;***
;;;### (autoloads nil "cc-langs" "progmodes/cc-langs.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-langs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-langs" '("c-")))
+(register-definition-prefixes "cc-langs" '("c-"))
;;;***
;;;### (autoloads nil "cc-menus" "progmodes/cc-menus.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-menus.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-menus" '("cc-imenu-")))
+(register-definition-prefixes "cc-menus" '("cc-imenu-"))
;;;***
@@ -3843,7 +3989,7 @@ should be used.
This function attempts to use file contents to determine whether
the code is C or C++ and based on that chooses whether to enable
-`c-mode' or `c++-mode'." nil nil)
+`c-mode' or `c++-mode'." t nil)
(autoload 'c++-mode "cc-mode" "\
Major mode for editing C++ code.
@@ -3962,7 +4108,7 @@ Key bindings:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-mode" '("awk-mode-map" "c++-mode-" "c-" "idl-mode-" "java-mode-" "objc-mode-" "pike-mode-")))
+(register-definition-prefixes "cc-mode" '("awk-mode-map" "c++-mode-" "c-" "idl-mode-" "java-mode-" "objc-mode-" "pike-mode-"))
;;;***
@@ -3990,7 +4136,7 @@ in this way.
If DONT-OVERRIDE is t, style variables that already have values (i.e., whose
values are not the symbol `set-from-style') will not be overridden. CC Mode
calls c-set-style internally in this way whilst initializing a buffer; if
-cc-set-style is called like this from anywhere else, it will usually behave as
+c-set-style is called like this from anywhere else, it will usually behave as
a null operation.
\(fn STYLENAME &optional DONT-OVERRIDE)" t nil)
@@ -4016,7 +4162,7 @@ and exists only for compatibility reasons.
\(fn SYMBOL OFFSET &optional IGNORED)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-styles" '("c-" "cc-choose-style-for-mode")))
+(register-definition-prefixes "cc-styles" '("c-" "cc-choose-style-for-mode"))
;;;***
@@ -4026,7 +4172,7 @@ and exists only for compatibility reasons.
(put 'c-backslash-column 'safe-local-variable 'integerp)
(put 'c-file-style 'safe-local-variable 'string-or-null-p)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-vars" '("awk-mode-hook" "c++-" "c-" "defcustom-c-stylevar" "idl-" "java-" "objc-" "pike-")))
+(register-definition-prefixes "cc-vars" '("awk-mode-hook" "c++-" "c-" "defcustom-c-stylevar" "idl-" "java-" "objc-" "pike-"))
;;;***
@@ -4321,7 +4467,7 @@ See the documentation of `define-ccl-program' for the detail of CCL program.
\(fn CCL-PROG &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ccl" '("ccl-")))
+(register-definition-prefixes "ccl" '("ccl-"))
;;;***
@@ -4337,19 +4483,14 @@ Returns a form where all lambdas don't have any free variables.
\(fn FORM)" nil nil)
-(autoload 'cconv-warnings-only "cconv" "\
-Add the warnings that closure conversion would encounter.
-
-\(fn FORM)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cconv" '("cconv-")))
+(register-definition-prefixes "cconv" '("cconv-"))
;;;***
;;;### (autoloads nil "cdl" "cdl.el" (0 0 0 0))
;;; Generated autoloads from cdl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cdl" '("cdl-")))
+(register-definition-prefixes "cdl" '("cdl-"))
;;;***
@@ -4357,7 +4498,7 @@ Add the warnings that closure conversion would encounter.
;;; Generated autoloads from cedet/cedet.el
(push (purecopy '(cedet 2 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cedet" '("cedet-")))
+(register-definition-prefixes "cedet" '("cedet-"))
;;;***
@@ -4365,7 +4506,7 @@ Add the warnings that closure conversion would encounter.
;;;;;; 0 0))
;;; Generated autoloads from cedet/cedet-cscope.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cedet-cscope" '("cedet-cscope-")))
+(register-definition-prefixes "cedet-cscope" '("cedet-cscope-"))
;;;***
@@ -4373,7 +4514,7 @@ Add the warnings that closure conversion would encounter.
;;;;;; 0))
;;; Generated autoloads from cedet/cedet-files.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cedet-files" '("cedet-")))
+(register-definition-prefixes "cedet-files" '("cedet-"))
;;;***
@@ -4381,7 +4522,7 @@ Add the warnings that closure conversion would encounter.
;;;;;; 0 0))
;;; Generated autoloads from cedet/cedet-global.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cedet-global" '("cedet-g")))
+(register-definition-prefixes "cedet-global" '("cedet-g"))
;;;***
@@ -4389,7 +4530,7 @@ Add the warnings that closure conversion would encounter.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/cedet-idutils.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cedet-idutils" '("cedet-idutils-")))
+(register-definition-prefixes "cedet-idutils" '("cedet-idutils-"))
;;;***
@@ -4418,7 +4559,7 @@ to the action header.
(autoload 'cfengine-auto-mode "cfengine" "\
Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cfengine" '("cfengine")))
+(register-definition-prefixes "cfengine" '("cfengine"))
;;;***
@@ -4445,15 +4586,14 @@ from which to start.
\(fn STRING &optional LAX FROM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "char-fold" '("char-fold-")))
+(register-definition-prefixes "char-fold" '("char-fold-"))
;;;***
;;;### (autoloads nil "chart" "emacs-lisp/chart.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/chart.el
-(push (purecopy '(chart 0 2)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chart" '("chart")))
+(register-definition-prefixes "chart" '("chart"))
;;;***
@@ -4473,14 +4613,13 @@ Returns non-nil if any false statements are found.
\(fn ROOT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "check-declare" '("check-declare-")))
+(register-definition-prefixes "check-declare" '("check-declare-"))
;;;***
;;;### (autoloads nil "checkdoc" "emacs-lisp/checkdoc.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from emacs-lisp/checkdoc.el
-(push (purecopy '(checkdoc 0 6 2)) package--builtin-versions)
(put 'checkdoc-force-docstrings-flag 'safe-local-variable #'booleanp)
(put 'checkdoc-force-history-flag 'safe-local-variable #'booleanp)
(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable #'booleanp)
@@ -4645,10 +4784,19 @@ Prefix argument is the same as for `checkdoc-defun'." t nil)
(autoload 'checkdoc-minor-mode "checkdoc" "\
Toggle automatic docstring checking (Checkdoc minor mode).
-If called interactively, enable Checkdoc minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Checkdoc
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `checkdoc-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
In Checkdoc minor mode, the usual bindings for `eval-defun' which is
bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
@@ -4661,7 +4809,7 @@ checking of documentation strings.
(autoload 'checkdoc-package-keywords "checkdoc" "\
Find package keywords that aren't in `finder-known-keywords'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "checkdoc" '("checkdoc-")))
+(register-definition-prefixes "checkdoc" '("checkdoc-"))
;;;***
@@ -4697,7 +4845,7 @@ Encode the text in the current buffer to HZ." t nil)
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "china-util" '("decode-hz-line-continuation" "hz-" "hz/zw-start-gb" "iso2022-" "zw-start-gb")))
+(register-definition-prefixes "china-util" '("decode-hz-line-continuation" "hz-" "hz/zw-start-gb" "iso2022-" "zw-start-gb"))
;;;***
@@ -4722,7 +4870,7 @@ element to judge if that element should be excluded from the list.
The buffer is left in Command History mode." t nil)
(autoload 'command-history "chistory" "\
-Examine commands from `command-history' in a buffer.
+Examine commands from variable `command-history' in a buffer.
The number of commands listed is controlled by `list-command-history-max'.
The command history is filtered by `list-command-history-filter' if non-nil.
Use \\<command-history-map>\\[command-history-repeat] to repeat the command on the current line.
@@ -4734,15 +4882,45 @@ and digits provide prefix arguments. Tab does not indent.
This command always recompiles the Command History listing
and runs the normal hook `command-history-hook'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "default-command-history-filter" "list-command-history-")))
+(register-definition-prefixes "chistory" '("command-history-" "default-command-history-filter" "list-command-history-"))
;;;***
-;;;### (autoloads "actual autoloads are elsewhere" "cl-extra" "emacs-lisp/cl-extra.el"
+;;;### (autoloads nil "cl-font-lock" "progmodes/cl-font-lock.el"
;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/cl-extra.el
+;;; Generated autoloads from progmodes/cl-font-lock.el
+
+(defvar cl-font-lock-built-in-mode nil "\
+Non-nil if Cl-Font-Lock-Built-In mode is enabled.
+See the `cl-font-lock-built-in-mode' command
+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 `cl-font-lock-built-in-mode'.")
+
+(custom-autoload 'cl-font-lock-built-in-mode "cl-font-lock" nil)
+
+(autoload 'cl-font-lock-built-in-mode "cl-font-lock" "\
+Highlight built-in functions, variables, and types in `lisp-mode'.
+
+This is a minor mode. If called interactively, toggle the
+`Cl-Font-Lock-Built-In mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'cl-font-lock-built-in-mode)'.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-extra" '("cl-")))
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
+(register-definition-prefixes "cl-font-lock" '("cl-font-lock-"))
;;;***
@@ -4777,15 +4955,29 @@ DEFAULT-BODY, if present, is used as the body of a default method.
(autoload 'cl-defmethod "cl-generic" "\
Define a new method for generic function NAME.
-I.e. it defines the implementation of NAME to use for invocations where the
-values of the dispatch arguments match the specified TYPEs.
+This defines an implementation of NAME to use for invocations
+of specific types of arguments.
+
+ARGS is a list of dispatch arguments (see `cl-defun'), but where
+each variable element is either just a single variable name VAR,
+or a list on the form (VAR TYPE).
+
+For instance:
+
+ (cl-defmethod foo (bar (format-string string) &optional zot)
+ (format format-string bar))
+
The dispatch arguments have to be among the mandatory arguments, and
all methods of NAME have to use the same set of arguments for dispatch.
Each dispatch argument and TYPE are specified in ARGS where the corresponding
formal argument appears as (VAR TYPE) rather than just VAR.
-The optional second argument QUALIFIER is a specifier that
-modifies how the method is combined with other methods, including:
+The optional EXTRA element, on the form `:extra STRING', allows
+you to add more methods for the same specializers and qualifiers.
+These are distinguished by STRING.
+
+The optional argument QUALIFIER is a specifier that modifies how
+the method is combined with other methods, including:
:before - Method will be called before the primary
:after - Method will be called after the primary
:around - Method will be called around everything else
@@ -4802,9 +4994,9 @@ method to be applicable.
The set of acceptable TYPEs (also called \"specializers\") is defined
\(and can be extended) by the various methods of `cl-generic-generalizers'.
-\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" nil t)
+\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" nil t)
-(function-put 'cl-defmethod 'doc-string-elt '3)
+(function-put 'cl-defmethod 'doc-string-elt 'cl--defmethod-doc-pos)
(function-put 'cl-defmethod 'lisp-indent-function 'defun)
@@ -4818,7 +5010,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
\(fn GENERIC QUALIFIERS SPECIALIZERS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-generic" '("cl-")))
+(register-definition-prefixes "cl-generic" '("cl-"))
;;;***
@@ -4904,7 +5096,7 @@ instead.
\(fn INDENT-POINT STATE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-indent" '("common-lisp-" "lisp-")))
+(register-definition-prefixes "cl-indent" '("common-lisp-" "lisp-"))
;;;***
@@ -4947,22 +5139,23 @@ This can be needed when using code byte-compiled using the old
macro-expansion of `cl-defstruct' that used vectors objects instead
of record objects.
-If called interactively, enable Cl-Old-Struct-Compat mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Cl-Old-Struct-Compat mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
-\(fn &optional ARG)" t nil)
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-lib" '("cl-")))
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'cl-old-struct-compat-mode)'.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "cl-macs" "emacs-lisp/cl-macs.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/cl-macs.el
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-macs" '("cl-")))
+(register-definition-prefixes "cl-lib" '("cl-"))
;;;***
@@ -5018,15 +5211,7 @@ limit.
\(fn PRINT-FUNCTION VALUE LIMIT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "cl-seq" "emacs-lisp/cl-seq.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/cl-seq.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-seq" '("cl--")))
+(register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code"))
;;;***
@@ -5048,7 +5233,7 @@ For use inside Lisp programs, see also `c-macro-expansion'.
\(fn START END SUBST)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmacexp" '("c-macro-")))
+(register-definition-prefixes "cmacexp" '("c-macro-"))
;;;***
@@ -5070,7 +5255,7 @@ is run).
\(fn CMD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "inferior-scheme-" "scheme-" "switch-to-scheme")))
+(register-definition-prefixes "cmuscheme" '("cmuscheme-load-hook" "inferior-scheme-" "scheme-" "switch-to-scheme"))
;;;***
@@ -5091,7 +5276,7 @@ If FRAME cannot display COLOR, return nil.
\(fn COLOR &optional FRAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "color" '("color-")))
+(register-definition-prefixes "color" '("color-"))
;;;***
@@ -5199,7 +5384,97 @@ REGEXP-GROUP is the regular expression group in REGEXP to use.
\(fn PROCESS COMMAND REGEXP REGEXP-GROUP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "comint" '("comint-")))
+(register-definition-prefixes "comint" '("comint-"))
+
+;;;***
+
+;;;### (autoloads nil "comp" "emacs-lisp/comp.el" (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/comp.el
+(put 'no-native-compile 'safe-local-variable 'booleanp)
+
+(autoload 'comp-subr-trampoline-install "comp" "\
+Make SUBR-NAME effectively advice-able when called from native code.
+
+\(fn SUBR-NAME)" nil nil)
+
+(autoload 'comp-c-func-name "comp" "\
+Given NAME, return a name suitable for the native code.
+Add PREFIX in front of it. If FIRST is not nil, pick the first
+available name ignoring compilation context and potential name
+clashes.
+
+\(fn NAME PREFIX &optional FIRST)" nil nil)
+
+(autoload 'comp-clean-up-stale-eln "comp" "\
+Given FILE remove all its *.eln files in `native-comp-eln-load-path'
+sharing the original source filename (including FILE).
+
+\(fn FILE)" nil nil)
+
+(autoload 'comp-lookup-eln "comp" "\
+Given a Lisp source FILENAME return the corresponding .eln file if found.
+Search happens in `native-comp-eln-load-path'.
+
+\(fn FILENAME)" nil nil)
+
+(autoload 'native-compile "comp" "\
+Compile FUNCTION-OR-FILE into native code.
+This is the synchronous entry-point for the Emacs Lisp native
+compiler.
+FUNCTION-OR-FILE is a function symbol, a form, or the filename of
+an Emacs Lisp source file.
+If OUTPUT is non-nil, use it as the filename for the compiled
+object.
+If FUNCTION-OR-FILE is a filename, return the filename of the
+compiled object. If FUNCTION-OR-FILE is a function symbol or a
+form, return the compiled function.
+
+\(fn FUNCTION-OR-FILE &optional OUTPUT)" nil nil)
+
+(autoload 'batch-native-compile "comp" "\
+Perform native compilation on remaining command-line arguments.
+Use this from the command line, with ‘-batch’;
+it won’t work in an interactive Emacs.
+Native compilation equivalent to `batch-byte-compile'." nil nil)
+
+(autoload 'batch-byte+native-compile "comp" "\
+Like `batch-native-compile', but used for bootstrap.
+Generate .elc files in addition to the .eln files.
+Force the produced .eln to be outputted in the eln system
+directory (the last entry in `native-comp-eln-load-path') unless
+`native-compile-target-directory' is non-nil. If the environment
+variable 'NATIVE_DISABLED' is set, only byte compile." nil nil)
+
+(autoload 'native-compile-async "comp" "\
+Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+\(fn FILES &optional RECURSIVELY LOAD SELECTOR)" nil nil)
+
+(register-definition-prefixes "comp" '("comp-" "make-comp-edge" "native-" "no-native-compile"))
+
+;;;***
+
+;;;### (autoloads nil "comp-cstr" "emacs-lisp/comp-cstr.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from emacs-lisp/comp-cstr.el
+
+(register-definition-prefixes "comp-cstr" '("comp-" "with-comp-cstr-accessors"))
;;;***
@@ -5237,14 +5512,14 @@ on third call it again advances points to the next difference and so on.
\(fn IGNORE-WHITESPACE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compare-w" '("compare-")))
+(register-definition-prefixes "compare-w" '("compare-"))
;;;***
;;;### (autoloads nil "compface" "image/compface.el" (0 0 0 0))
;;; Generated autoloads from image/compface.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compface" '("uncompface")))
+(register-definition-prefixes "compface" '("uncompface"))
;;;***
@@ -5309,7 +5584,7 @@ You might also use mode hooks to specify it in certain modes, like this:
(lambda ()
(unless (or (file-exists-p \"makefile\")
(file-exists-p \"Makefile\"))
- (set (make-local-variable \\='compile-command)
+ (setq-local compile-command
(concat \"make -k \"
(if buffer-file-name
(shell-quote-argument
@@ -5396,10 +5671,20 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see).
(autoload 'compilation-shell-minor-mode "compile" "\
Toggle Compilation Shell minor mode.
-If called interactively, enable Compilation-Shell minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Compilation-Shell minor mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `compilation-shell-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Compilation Shell minor mode is enabled, all the
error-parsing commands of the Compilation major mode are
@@ -5411,10 +5696,19 @@ See `compilation-mode'.
(autoload 'compilation-minor-mode "compile" "\
Toggle Compilation minor mode.
-If called interactively, enable Compilation minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Compilation minor mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `compilation-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Compilation minor mode is enabled, all the error-parsing
commands of Compilation major mode are available. See
@@ -5428,7 +5722,7 @@ This is the value of `next-error-function' in Compilation buffers.
\(fn N &optional RESET)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile")))
+(register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile"))
;;;***
@@ -5448,14 +5742,23 @@ or call the function `dynamic-completion-mode'.")
(autoload 'dynamic-completion-mode "completion" "\
Toggle dynamic word-completion on or off.
-If called interactively, enable Dynamic-Completion mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Dynamic-Completion mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'dynamic-completion-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "initialize-completions" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-")))
+(register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "initialize-completions" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-"))
;;;***
@@ -5492,7 +5795,9 @@ doesn't have enough contents to decide, this is identical to
See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode',
`conf-ppd-mode' and `conf-xdefaults-mode'.
-\\{conf-mode-map}" t nil)
+\\{conf-mode-map}
+
+\(fn)" t nil)
(autoload 'conf-unix-mode "conf-mode" "\
Conf Mode starter for Unix style Conf files.
@@ -5628,7 +5933,7 @@ For details see `conf-mode'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "conf-mode" '("conf-")))
+(register-definition-prefixes "conf-mode" '("conf-"))
;;;***
@@ -5658,7 +5963,7 @@ and subsequent calls on the same file won't go to disk.
\(fn PHRASE-FILE &optional STARTMSG ENDMSG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cookie1" '("cookie")))
+(register-definition-prefixes "cookie1" '("cookie"))
;;;***
@@ -5697,7 +6002,7 @@ If FIX is non-nil, run `copyright-fix-years' instead.
\(fn DIRECTORY MATCH &optional FIX)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "copyright" '("copyright-")))
+(register-definition-prefixes "copyright" '("copyright-"))
;;;***
@@ -5817,8 +6122,7 @@ span the needed amount of lines.
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
`cperl-pod-face', `cperl-pod-head-face' control processing of POD and
-here-docs sections. With capable Emaxen results of scan are used
-for indentation too, otherwise they are used for highlighting only.
+here-docs sections. Results of scan are used for indentation too.
Variables controlling indentation style:
`cperl-tab-always-indent'
@@ -5855,12 +6159,12 @@ Variables controlling indentation style:
`cperl-min-label-indent'
Minimal indentation for line that is a label.
-Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith
- `cperl-indent-level' 5 4 2 4
- `cperl-brace-offset' 0 0 0 0
- `cperl-continued-brace-offset' -5 -4 0 0
- `cperl-label-offset' -5 -4 -2 -4
- `cperl-continued-statement-offset' 5 4 2 4
+Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith
+ `cperl-indent-level' 5 4 2 4 4
+ `cperl-brace-offset' 0 0 0 0 0
+ `cperl-continued-brace-offset' -5 -4 0 0 0
+ `cperl-label-offset' -5 -4 -2 -2 -4
+ `cperl-continued-statement-offset' 5 4 2 4 4
CPerl knows several indentation styles, and may bulk set the
corresponding variables. Use \\[cperl-set-style] to do this. Use
@@ -5896,7 +6200,7 @@ Run `perldoc' on WORD.
(autoload 'cperl-perldoc-at-point "cperl-mode" "\
Run a `perldoc' on the word around point." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cperl-mode" '("cperl-" "pod2man-program")))
+(register-definition-prefixes "cperl-mode" '("cperl-" "pod2man-program"))
;;;***
@@ -5914,7 +6218,7 @@ A prefix arg suppresses display of that buffer.
(autoload 'cpp-parse-edit "cpp" "\
Edit display information for cpp conditionals." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cpp" '("cpp-")))
+(register-definition-prefixes "cpp" '("cpp-"))
;;;***
@@ -5942,7 +6246,7 @@ with empty strings removed.
\(fn PROMPT TABLE &optional PREDICATE REQUIRE-MATCH INITIAL-INPUT HIST DEF INHERIT-INPUT-METHOD)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "crm" '("crm-")))
+(register-definition-prefixes "crm" '("crm-"))
;;;***
@@ -5987,7 +6291,7 @@ on what is seen near point.
\(fn SYMBOL)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "css-mode" '("css-" "scss-")))
+(register-definition-prefixes "css-mode" '("css-" "scss-"))
;;;***
@@ -6007,10 +6311,19 @@ or call the function `cua-mode'.")
(autoload 'cua-mode "cua-base" "\
Toggle Common User Access style editing (CUA mode).
-If called interactively, enable Cua mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Cua mode'
+mode. If the prefix argument is positive, enable the mode, and if it
+is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'cua-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
CUA mode is a global minor mode. When enabled, typed text
replaces the active selection, and you can use C-z, C-x, C-c, and
@@ -6037,14 +6350,14 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cua-base" '("cua-")))
+(register-definition-prefixes "cua-base" '("cua-"))
;;;***
;;;### (autoloads nil "cua-gmrk" "emulation/cua-gmrk.el" (0 0 0 0))
;;; Generated autoloads from emulation/cua-gmrk.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cua-gmrk" '("cua-")))
+(register-definition-prefixes "cua-gmrk" '("cua-"))
;;;***
@@ -6055,14 +6368,23 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings.
Toggle the region as rectangular.
Activates the region if needed. Only lasts until the region is deactivated.
-If called interactively, enable Cua-Rectangle-Mark mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Cua-Rectangle-Mark mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `cua-rectangle-mark-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cua-rect" '("cua-")))
+(register-definition-prefixes "cua-rect" '("cua-"))
;;;***
@@ -6078,10 +6400,19 @@ By convention, this is a list of symbols where each symbol stands for the
(autoload 'cursor-intangible-mode "cursor-sensor" "\
Keep cursor outside of any `cursor-intangible' text property.
-If called interactively, enable Cursor-Intangible mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Cursor-Intangible mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `cursor-intangible-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -6093,21 +6424,30 @@ where WINDOW is the affected window, OLDPOS is the last known position of
the cursor and DIR can be `entered' or `left' depending on whether the cursor
is entering the area covered by the text-property property or leaving it.
-If called interactively, enable Cursor-Sensor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Cursor-Sensor mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `cursor-sensor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cursor-sensor" '("cursor-sensor-")))
+(register-definition-prefixes "cursor-sensor" '("cursor-sensor-"))
;;;***
;;;### (autoloads nil "cus-dep" "cus-dep.el" (0 0 0 0))
;;; Generated autoloads from cus-dep.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cus-dep" '("custom-" "generated-custom-dependencies-file")))
+(register-definition-prefixes "cus-dep" '("custom-" "generated-custom-dependencies-file"))
;;;***
@@ -6258,9 +6598,9 @@ PACKAGE value appearing in the :package-version keyword. Since
the user might see the value in an error message, a good choice is
the official name of the package, such as MH-E or Gnus.")
-(defalias 'customize-changed 'customize-changed-options)
+(define-obsolete-function-alias 'customize-changed-options #'customize-changed "28.1")
-(autoload 'customize-changed-options "cus-edit" "\
+(autoload 'customize-changed "cus-edit" "\
Customize all settings whose meanings have changed in Emacs itself.
This includes new user options and faces, and new customization
groups, as well as older options and faces whose meanings or
@@ -6416,7 +6756,7 @@ The format is suitable for use with `easy-menu-define'.
\(fn SYMBOL &optional NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cus-edit" '("Custom-" "custom" "widget-")))
+(register-definition-prefixes "cus-edit" '("Custom-" "cus" "widget-"))
;;;***
@@ -6451,7 +6791,7 @@ omitted, a buffer named *Custom Themes* is used.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cus-theme" '("custom-" "describe-theme-1")))
+(register-definition-prefixes "cus-theme" '("custom-" "describe-theme-1"))
;;;***
@@ -6463,21 +6803,29 @@ Mode used for cvs status output.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cvs-status" '("cvs-")))
+(register-definition-prefixes "cvs-status" '("cvs-"))
;;;***
;;;### (autoloads nil "cwarn" "progmodes/cwarn.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cwarn.el
-(push (purecopy '(cwarn 1 3 1)) package--builtin-versions)
(autoload 'cwarn-mode "cwarn" "\
Minor mode that highlights suspicious C and C++ constructions.
-If called interactively, enable Cwarn mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Cwarn
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `cwarn-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Suspicious constructs are highlighted using `font-lock-warning-face'.
@@ -6504,16 +6852,17 @@ or call the function `global-cwarn-mode'.")
(autoload 'global-cwarn-mode "cwarn" "\
Toggle Cwarn mode in all buffers.
With prefix ARG, enable Global Cwarn mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
Cwarn mode is enabled in all buffers where
`turn-on-cwarn-mode-if-enabled' would do it.
+
See `cwarn-mode' for more information on Cwarn mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cwarn" '("cwarn-" "turn-on-cwarn-mode-if-enabled")))
+(register-definition-prefixes "cwarn" '("cwarn-" "turn-on-cwarn-mode-if-enabled"))
;;;***
@@ -6532,7 +6881,7 @@ Return ALTERNATIVNYJ external character code of CHAR if appropriate.
\(fn CHAR)" nil nil)
(autoload 'standard-display-cyrillic-translit "cyril-util" "\
-Display a cyrillic buffer using a transliteration.
+Display a Cyrillic buffer using a transliteration.
For readability, the table is slightly
different from the one used for the input method `cyrillic-translit'.
@@ -6544,7 +6893,7 @@ If the argument is nil, we return the display table to its standard state.
\(fn &optional CYRILLIC-LANGUAGE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cyril-util" '("cyrillic-language-alist")))
+(register-definition-prefixes "cyril-util" '("cyrillic-language-alist"))
;;;***
@@ -6595,7 +6944,7 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion].
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dabbrev" '("dabbrev-")))
+(register-definition-prefixes "dabbrev" '("dabbrev-"))
;;;***
@@ -6607,7 +6956,7 @@ Create a new data-debug buffer with NAME.
\(fn NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-" "dd-propertize")))
+(register-definition-prefixes "data-debug" '("data-debug-"))
;;;***
@@ -6617,12 +6966,21 @@ Create a new data-debug buffer with NAME.
(autoload 'dbus-handle-event "dbus" "\
Handle events from the D-Bus.
EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being
-part of the event, is called with arguments ARGS.
+part of the event, is called with arguments ARGS (without type information).
If the HANDLER returns a `dbus-error', it is propagated as return message.
\(fn EVENT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dbus" '("dbus-")))
+(function-put 'dbus-handle-event 'completion-predicate #'ignore)
+
+(autoload 'dbus-monitor "dbus" "\
+Invoke `dbus-register-monitor' interactively, and switch to the buffer.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address. The value nil defaults to `:session'.
+
+\(fn &optional BUS)" t nil)
+
+(register-definition-prefixes "dbus" '("dbus-"))
;;;***
@@ -6715,8 +7073,7 @@ Variables controlling indentation style and extra features:
dcl-imenu-label-call
Change the text that is used as sub-listing labels in imenu.
-Loading this package calls the value of the variable
-`dcl-mode-load-hook' with no args, if that value is non-nil.
+To run code after DCL mode has loaded, use `with-eval-after-load'.
Turning on DCL mode calls the value of the variable `dcl-mode-hook'
with no args, if that value is non-nil.
@@ -6750,7 +7107,7 @@ There is some minimal font-lock support (see vars
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dcl-mode" '("dcl-")))
+(register-definition-prefixes "dcl-mode" '("dcl-"))
;;;***
@@ -6830,7 +7187,7 @@ To specify a nil argument interactively, exit with an empty minibuffer.
(defalias 'cancel-debug-watch #'cancel-debug-on-variable-change)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "debug" '("debug" "inhibit-debug-on-entry")))
+(register-definition-prefixes "debug" '("debug" "inhibit-debug-on-entry"))
;;;***
@@ -6854,15 +7211,16 @@ The most useful commands are:
\\[decipher-frequency-count] Display the frequency of each ciphertext letter
\\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it)
\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint)
-\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil)
+\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)
+
+\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "decipher" '("decipher-")))
+(register-definition-prefixes "decipher" '("decipher-"))
;;;***
;;;### (autoloads nil "delim-col" "delim-col.el" (0 0 0 0))
;;; Generated autoloads from delim-col.el
-(push (purecopy '(delim-col 2 1)) package--builtin-versions)
(autoload 'delimit-columns-customize "delim-col" "\
Customize the `columns' group." t nil)
@@ -6901,7 +7259,7 @@ START and END delimit the corners of the text rectangle.
\(fn START END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "delim-col" '("delimit-columns-")))
+(register-definition-prefixes "delim-col" '("delimit-columns-"))
;;;***
@@ -6923,10 +7281,19 @@ or call the function `delete-selection-mode'.")
(autoload 'delete-selection-mode "delsel" "\
Toggle Delete Selection mode.
-If called interactively, enable Delete-Selection mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Delete-Selection mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'delete-selection-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Delete Selection mode is enabled, typed text replaces the selection
if the selection is active. Otherwise, typed text is just inserted at
@@ -6937,7 +7304,14 @@ information on adapting behavior of commands in Delete Selection mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "delsel" '("del" "minibuffer-keyboard-quit")))
+(autoload 'delete-active-region "delsel" "\
+Delete the active region.
+If KILLP is non-nil, or if called interactively with a prefix argument,
+the active region is killed instead of deleted.
+
+\(fn &optional KILLP)" t nil)
+
+(register-definition-prefixes "delsel" '("del" "minibuffer-keyboard-quit"))
;;;***
@@ -6973,6 +7347,9 @@ KEYWORD-ARGS:
:after-hook FORM
A single lisp form which is evaluated after the mode
hooks have been run. It should not be quoted.
+ :interactive BOOLEAN
+ Whether the derived mode should be `interactive' or not.
+ The default is t.
BODY: forms to execute just before running the
hooks for the new mode. Do not use `interactive' here.
@@ -7012,7 +7389,7 @@ the first time the mode is used.
\(fn MODE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "derived" '("derived-mode-")))
+(register-definition-prefixes "derived" '("derived-mode-"))
;;;***
@@ -7067,10 +7444,12 @@ Otherwise return a description formatted by
of `eldoc-echo-area-use-multiline-p' variable and width of
minibuffer window for width limit.
-This function is meant to be used as a value of
-`eldoc-documentation-function' variable." nil nil)
+This function can be used as a value of
+`eldoc-documentation-functions' variable.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "descr-text" '("describe-")))
+\(fn CALLBACK &rest _)" nil nil)
+
+(register-definition-prefixes "descr-text" '("describe-"))
;;;***
@@ -7090,10 +7469,19 @@ or call the function `desktop-save-mode'.")
(autoload 'desktop-save-mode "desktop" "\
Toggle desktop saving (Desktop Save mode).
-If called interactively, enable Desktop-Save mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Desktop-Save mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'desktop-save-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Desktop Save mode is enabled, the state of Emacs is saved from
one session to another. In particular, Emacs will save the desktop when
@@ -7296,7 +7684,7 @@ Save the desktop in directory `desktop-dirname'." t nil)
(autoload 'desktop-revert "desktop" "\
Revert to the last loaded desktop." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "desktop" '("desktop-")))
+(register-definition-prefixes "desktop" '("desktop-"))
;;;***
@@ -7310,13 +7698,13 @@ You can control what lines will be unwrapped by frobbing
indicating the minimum and maximum length of an unwrapped citation line. If
NODISPLAY is non-nil, don't redisplay the article buffer.
-\(fn &optional NODISPLAY)" t nil)
+\(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-article-outlook-repair-attribution "deuglify" "\
Repair a broken attribution line.
If NODISPLAY is non-nil, don't redisplay the article buffer.
-\(fn &optional NODISPLAY)" t nil)
+\(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-outlook-deuglify-article "deuglify" "\
Full deuglify of broken Outlook (Express) articles.
@@ -7324,19 +7712,19 @@ Treat \"smartquotes\", unwrap lines, repair attribution and
rearrange citation. If NODISPLAY is non-nil, don't redisplay the
article buffer.
-\(fn &optional NODISPLAY)" t nil)
+\(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-article-outlook-deuglify-article "deuglify" "\
-Deuglify broken Outlook (Express) articles and redisplay." t nil)
+Deuglify broken Outlook (Express) articles and redisplay." '(gnus-article-mode gnus-summary-mode) nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "deuglify" '("gnus-")))
+(register-definition-prefixes "deuglify" '("gnus-"))
;;;***
;;;### (autoloads nil "dframe" "dframe.el" (0 0 0 0))
;;; Generated autoloads from dframe.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dframe" '("dframe-")))
+(register-definition-prefixes "dframe" '("dframe-"))
;;;***
@@ -7381,7 +7769,90 @@ Major mode for editing the diary file.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diary-lib" '("calendar-mark-" "diary-")))
+(register-definition-prefixes "diary-lib" '("calendar-mark-" "diary-"))
+
+;;;***
+
+;;;### (autoloads nil "dictionary" "net/dictionary.el" (0 0 0 0))
+;;; Generated autoloads from net/dictionary.el
+
+(autoload 'dictionary-mode "dictionary" "\
+Mode for searching a dictionary.
+This is a mode for searching a dictionary server implementing the
+protocol defined in RFC 2229.
+
+This is a quick reference to this mode describing the default key bindings:
+\\<dictionary-mode-map>
+* \\[dictionary-close] close the dictionary buffer
+* \\[dictionary-help] display this help information
+* \\[dictionary-search] ask for a new word to search
+* \\[dictionary-lookup-definition] search the word at point
+* \\[forward-button] or TAB place point to the next link
+* \\[backward-button] or S-TAB place point to the prev link
+
+* \\[dictionary-match-words] ask for a pattern and list all matching words.
+* \\[dictionary-select-dictionary] select the default dictionary
+* \\[dictionary-select-strategy] select the default search strategy
+
+* RET or <mouse-2> visit that link" nil nil)
+
+(autoload 'dictionary "dictionary" "\
+Create a new dictionary buffer and install `dictionary-mode'." t nil)
+
+(autoload 'dictionary-search "dictionary" "\
+Search the WORD in DICTIONARY if given or in all if nil.
+It presents the selection or word at point as default input and
+allows editing it.
+
+\(fn WORD &optional DICTIONARY)" t nil)
+
+(autoload 'dictionary-lookup-definition "dictionary" "\
+Unconditionally lookup the word at point." t nil)
+
+(autoload 'dictionary-match-words "dictionary" "\
+Search PATTERN in current default dictionary using default strategy.
+
+\(fn &optional PATTERN &rest IGNORED)" t nil)
+
+(autoload 'dictionary-mouse-popup-matching-words "dictionary" "\
+Display entries matching the word at the cursor retrieved using EVENT.
+
+\(fn EVENT)" t nil)
+
+(autoload 'dictionary-popup-matching-words "dictionary" "\
+Display entries matching WORD or the current word if not given.
+
+\(fn &optional WORD)" t nil)
+
+(autoload 'dictionary-tooltip-mode "dictionary" "\
+Display tooltips for the current word.
+
+This function can be used to enable or disable the tooltip mode
+for the current buffer (based on ARG). If global-tooltip-mode is
+active it will overwrite that mode for the current buffer.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'global-dictionary-tooltip-mode "dictionary" "\
+Enable/disable dictionary-tooltip-mode for all buffers.
+
+Internally it provides a default for the dictionary-tooltip-mode.
+It can be overwritten for each buffer using dictionary-tooltip-mode.
+
+Note: (global-dictionary-tooltip-mode 0) will not disable the mode
+any buffer where (dictionary-tooltip-mode 1) has been called.
+
+\(fn &optional ARG)" t nil)
+
+(register-definition-prefixes "dictionary" '("dictionary-" "global-dictionary-tooltip-mode"))
+
+;;;***
+
+;;;### (autoloads nil "dictionary-connection" "net/dictionary-connection.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from net/dictionary-connection.el
+
+(register-definition-prefixes "dictionary-connection" '("dictionary-connection-"))
;;;***
@@ -7456,7 +7927,7 @@ OLD and NEW may each be a buffer or a buffer name.
\(fn OLD NEW &optional SWITCHES NO-ASYNC)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diff" '("diff-")))
+(register-definition-prefixes "diff" '("diff-"))
;;;***
@@ -7483,16 +7954,25 @@ a diff with \\[diff-reverse-direction].
(autoload 'diff-minor-mode "diff-mode" "\
Toggle Diff minor mode.
-If called interactively, enable Diff minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Diff minor
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `diff-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\{diff-minor-mode-map}
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "diff-mode" '("diff-")))
+(register-definition-prefixes "diff-mode" '("diff-"))
;;;***
@@ -7500,12 +7980,14 @@ enable the mode if ARG is omitted or nil, and toggle it if ARG is
;;; Generated autoloads from net/dig.el
(autoload 'dig "dig" "\
-Query addresses of a DOMAIN using dig, by calling `dig-invoke'.
-Optional arguments are passed to `dig-invoke'.
+Query addresses of a DOMAIN using dig.
+See `dig-invoke' for an explanation for the parameters.
+When called interactively, DOMAIN is prompted for. If given a prefix,
+also prompt for the QUERY-TYPE parameter.
\(fn DOMAIN &optional QUERY-TYPE QUERY-CLASS QUERY-OPTION DIG-OPTION SERVER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dig" '("dig-" "query-dig")))
+(register-definition-prefixes "dig" '("dig-" "query-dig"))
;;;***
@@ -7517,10 +7999,15 @@ Switches passed to `ls' for Dired. MUST contain the `l' option.
May contain all other options that don't contradict `-l';
may contain even `F', `b', `i' and `s'. See also the variable
`dired-ls-F-marks-symlinks' concerning the `F' switch.
+
+If you have files with names with embedded newline characters, adding
+`b' to the switches will allow Dired to handle those files better.
+
Options that include embedded whitespace must be quoted
like this: \"--option=value with spaces\"; you can use
`combine-and-quote-strings' to produce the correct quoting of
each option.
+
On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
some of the `ls' switches are not supported; see the doc string of
`insert-directory' in `ls-lisp.el' for more details.")
@@ -7618,24 +8105,13 @@ directories again, type \\[dired-do-redisplay] to relist the file at point or th
subdirectory, or type \\[dired-build-subdir-alist] to parse the buffer
again for the directory tree.
-Customization variables (rename this buffer and type \\[describe-variable] on each line
-for more info):
+See the `dired' customization group for a list of user options.
- `dired-listing-switches'
- `dired-trivial-filenames'
- `dired-marker-char'
- `dired-del-marker'
- `dired-keep-marker-rename'
- `dired-keep-marker-copy'
- `dired-keep-marker-hardlink'
- `dired-keep-marker-symlink'
-
-Hooks (use \\[describe-variable] to see their documentation):
+This mode runs the following hooks:
`dired-before-readin-hook'
`dired-after-readin-hook'
`dired-mode-hook'
- `dired-load-hook'
Keybindings:
\\{dired-mode-map}
@@ -7643,23 +8119,24 @@ Keybindings:
\(fn &optional DIRNAME SWITCHES)" nil nil)
(put 'dired-find-alternate-file 'disabled t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dired" '("dired-")))
+(autoload 'dired-jump "dired" "\
+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.
+When OTHER-WINDOW is non-nil, jump to Dired buffer in other window.
+When FILE-NAME is non-nil, jump to its line in Dired.
+Interactively with prefix argument, read FILE-NAME.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "dired-aux" "dired-aux.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from dired-aux.el
+\(fn &optional OTHER-WINDOW FILE-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dired-aux" '("dired-" "minibuffer-default-add-dired-shell-commands")))
+(autoload 'dired-jump-other-window "dired" "\
+Like \\[dired-jump] (`dired-jump') but in other window.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "dired-x" "dired-x.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from dired-x.el
+\(fn &optional FILE-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dired-x" '("dired-" "virtual-dired")))
+(register-definition-prefixes "dired" '("dired-"))
;;;***
@@ -7669,10 +8146,19 @@ Keybindings:
(autoload 'dirtrack-mode "dirtrack" "\
Toggle directory tracking in shell buffers (Dirtrack mode).
-If called interactively, enable Dirtrack mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Dirtrack
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `dirtrack-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
This method requires that your shell prompt contain the current
working directory at all times, and that you set the variable
@@ -7693,7 +8179,7 @@ from `default-directory'.
\(fn INPUT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dirtrack" '("dirtrack-")))
+(register-definition-prefixes "dirtrack" '("dirtrack-"))
;;;***
@@ -7709,7 +8195,7 @@ redefine OBJECT if it is a symbol.
\(fn OBJECT &optional BUFFER INDENT INTERACTIVE-P)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "disass" '("disassemble-")))
+(register-definition-prefixes "disass" '("disassemble-"))
;;;***
@@ -7828,7 +8314,7 @@ in `.emacs'.
\(fn ARG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "disp-table" '("display-table-print-array")))
+(register-definition-prefixes "disp-table" '("display-table-print-array"))
;;;***
@@ -7840,10 +8326,20 @@ in `.emacs'.
Toggle display of fill-column indicator.
This uses `display-fill-column-indicator' internally.
-If called interactively, enable Display-Fill-Column-Indicator mode if
-ARG is positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and toggle
-it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Display-Fill-Column-Indicator mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `display-fill-column-indicator-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
To change the position of the column displayed by default
customize `display-fill-column-indicator-column'. You can change the
@@ -7868,17 +8364,38 @@ or call the function `global-display-fill-column-indicator-mode'.")
(autoload 'global-display-fill-column-indicator-mode "display-fill-column-indicator" "\
Toggle Display-Fill-Column-Indicator mode in all buffers.
-With prefix ARG, enable Global Display-Fill-Column-Indicator mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+With prefix ARG, enable Global Display-Fill-Column-Indicator mode if
+ARG is positive; otherwise, disable it. If called from Lisp, enable
+the mode if ARG is omitted or nil.
Display-Fill-Column-Indicator mode is enabled in all buffers where
`display-fill-column-indicator--turn-on' would do it.
-See `display-fill-column-indicator-mode' for more information on Display-Fill-Column-Indicator mode.
+
+See `display-fill-column-indicator-mode' for more information on
+Display-Fill-Column-Indicator mode.
+
+`global-display-fill-column-indicator-modes' is used to control
+which modes this minor mode is used in.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "display-fill-column-indicator" '("display-fill-column-indicator--turn-on")))
+(defvar global-display-fill-column-indicator-modes '((not special-mode) t) "\
+Which major modes `display-fill-column-indicator-mode' is switched on in.
+This variable can be either t (all major modes), nil (no major modes),
+or a list of modes and (not modes) to switch use this minor mode or
+not. For instance
+
+ (c-mode (not message-mode mail-mode) text-mode)
+
+means \"use this mode in all modes derived from `c-mode', don't use in
+modes derived from `message-mode' or `mail-mode', but do use in other
+modes derived from `text-mode'\". An element with value t means \"use\"
+and nil means \"don't use\". There's an implicit nil at the end of the
+list.")
+
+(custom-autoload 'global-display-fill-column-indicator-modes "display-fill-column-indicator" t)
+
+(register-definition-prefixes "display-fill-column-indicator" '("display-fill-column-indicator--turn-on"))
;;;***
@@ -7890,10 +8407,19 @@ See `display-fill-column-indicator-mode' for more information on Display-Fill-Co
Toggle display of line numbers in the buffer.
This uses `display-line-numbers' internally.
-If called interactively, enable Display-Line-Numbers mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Display-Line-Numbers mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `display-line-numbers-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
To change the type of line numbers displayed by default,
customize `display-line-numbers-type'. To change the type while
@@ -7915,17 +8441,19 @@ or call the function `global-display-line-numbers-mode'.")
(autoload 'global-display-line-numbers-mode "display-line-numbers" "\
Toggle Display-Line-Numbers mode in all buffers.
-With prefix ARG, enable Global Display-Line-Numbers mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+With prefix ARG, enable Global Display-Line-Numbers mode if ARG is
+positive; otherwise, disable it. If called from Lisp, enable the mode
+if ARG is omitted or nil.
Display-Line-Numbers mode is enabled in all buffers where
`display-line-numbers--turn-on' would do it.
-See `display-line-numbers-mode' for more information on Display-Line-Numbers mode.
+
+See `display-line-numbers-mode' for more information on
+Display-Line-Numbers mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "display-line-numbers" '("display-line-numbers-")))
+(register-definition-prefixes "display-line-numbers" '("display-line-numbers-"))
;;;***
@@ -7963,14 +8491,21 @@ if some action was made, or nil if the URL is ignored.")
(custom-autoload 'dnd-protocol-alist "dnd" t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dnd" '("dnd-")))
+(register-definition-prefixes "dnd" '("dnd-"))
;;;***
;;;### (autoloads nil "dns" "net/dns.el" (0 0 0 0))
;;; Generated autoloads from net/dns.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dns" '("dns-")))
+(autoload 'dns-query "dns" "\
+Query a DNS server for NAME of TYPE.
+If FULL, return the entire record returned.
+If REVERSE, look up an IP address.
+
+\(fn NAME &optional TYPE FULL REVERSE)" nil nil)
+
+(register-definition-prefixes "dns" '("dns-"))
;;;***
@@ -7993,7 +8528,7 @@ Turning on DNS mode runs `dns-mode-hook'.
(autoload 'dns-mode-soa-increment-serial "dns-mode" "\
Locate SOA record and increment the serial field." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dns-mode" '("dns-mode-")))
+(register-definition-prefixes "dns-mode" '("dns-mode-"))
;;;***
@@ -8025,10 +8560,19 @@ to the next best mode." nil nil)
(autoload 'doc-view-minor-mode "doc-view" "\
Toggle displaying buffer via Doc View (Doc View minor mode).
-If called interactively, enable Doc-View minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Doc-View
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `doc-view-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
See the command `doc-view-mode' for more information on this mode.
@@ -8039,7 +8583,7 @@ See the command `doc-view-mode' for more information on this mode.
\(fn BMK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "doc-view" '("doc-view-")))
+(register-definition-prefixes "doc-view" '("doc-view-"))
;;;***
@@ -8049,35 +8593,35 @@ See the command `doc-view-mode' for more information on this mode.
(autoload 'doctor "doctor" "\
Switch to *doctor* buffer and start giving psychotherapy." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "doctor" '("doc" "make-doctor-variables")))
+(register-definition-prefixes "doctor" '("doc" "make-doctor-variables"))
;;;***
;;;### (autoloads nil "dom" "dom.el" (0 0 0 0))
;;; Generated autoloads from dom.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dom" '("dom-")))
+(register-definition-prefixes "dom" '("dom-"))
;;;***
;;;### (autoloads nil "dos-fns" "dos-fns.el" (0 0 0 0))
;;; Generated autoloads from dos-fns.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-fns" '("dos")))
+(register-definition-prefixes "dos-fns" '("dos"))
;;;***
;;;### (autoloads nil "dos-vars" "dos-vars.el" (0 0 0 0))
;;; Generated autoloads from dos-vars.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-vars" '("dos-codepage-setup-hook" "msdos-shells")))
+(register-definition-prefixes "dos-vars" '("dos-codepage-setup-hook" "msdos-shells"))
;;;***
;;;### (autoloads nil "dos-w32" "dos-w32.el" (0 0 0 0))
;;; Generated autoloads from dos-w32.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dos-w32" '("file-name-buffer-file-type-alist" "find-" "w32-")))
+(register-definition-prefixes "dos-w32" '("file-name-buffer-file-type-alist" "find-" "w32-"))
;;;***
@@ -8087,28 +8631,36 @@ Switch to *doctor* buffer and start giving psychotherapy." t nil)
(autoload 'double-mode "double" "\
Toggle special insertion on double keypresses (Double mode).
-If called interactively, enable Double mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Double
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `double-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Double mode is enabled, some keys will insert different
strings when pressed twice. See `double-map' for details.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "double" '("double-")))
+(register-definition-prefixes "double" '("double-"))
;;;***
;;;### (autoloads nil "dunnet" "play/dunnet.el" (0 0 0 0))
;;; Generated autoloads from play/dunnet.el
-(push (purecopy '(dunnet 2 2)) package--builtin-versions)
(autoload 'dunnet "dunnet" "\
Switch to *dungeon* buffer and start game." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dunnet" '("dun" "obj-special")))
+(register-definition-prefixes "dunnet" '("dun" "obj-special"))
;;;***
@@ -8116,7 +8668,7 @@ Switch to *dungeon* buffer and start game." t nil)
;;;;;; 0 0))
;;; Generated autoloads from dynamic-setting.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "dynamic-setting" '("dynamic-setting-handle-config-changed-event" "font-setting-change-default-font")))
+(register-definition-prefixes "dynamic-setting" '("dynamic-setting-handle-config-changed-event" "font-setting-change-default-font"))
;;;***
@@ -8124,7 +8676,7 @@ Switch to *dungeon* buffer and start game." t nil)
;;;;;; 0 0 0))
;;; Generated autoloads from emacs-lisp/easy-mmode.el
-(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
+(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
(autoload 'define-minor-mode "easy-mmode" "\
Define a new minor mode MODE.
@@ -8147,42 +8699,35 @@ documenting what its argument does. If the word \"ARG\" does not
appear in DOC, a paragraph is added to DOC explaining
usage of the mode argument.
-Optional INIT-VALUE is the initial value of the mode's variable.
- Note that the minor mode function won't be called by setting
- this option, so the value *reflects* the minor mode's natural
- initial state, rather than *setting* it.
- In the vast majority of cases it should be nil.
-Optional LIGHTER is displayed in the mode line when the mode is on.
-Optional KEYMAP is the default keymap bound to the mode keymap.
- If non-nil, it should be a variable name (whose value is a keymap),
- or an expression that returns either a keymap or a list of
- (KEY . BINDING) pairs where KEY and BINDING are suitable for
- `define-key'. If you supply a KEYMAP argument that is not a
- symbol, this macro defines the variable MODE-map and gives it
- the value that KEYMAP specifies.
-
BODY contains code to execute each time the mode is enabled or disabled.
It is executed after toggling the mode, and before running MODE-hook.
Before the actual body code, you can write keyword arguments, i.e.
alternating keywords and values. If you provide BODY, then you must
- provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide
- at least one keyword argument, or both; otherwise, BODY would be
- misinterpreted as the first omitted argument. The following special
- keywords are supported (other keywords are passed to `defcustom' if
- the minor mode is global):
-
-:group GROUP Custom group name to use in all generated `defcustom' forms.
- Defaults to MODE without the possible trailing \"-mode\".
- Don't use this default group name unless you have written a
- `defgroup' to define that group properly.
+ provide at least one keyword argument (e.g. `:lighter nil`).
+ The following special keywords are supported (other keywords are passed
+ to `defcustom' if the minor mode is global):
+
:global GLOBAL If non-nil specifies that the minor mode is not meant to be
buffer-local, so don't make the variable MODE buffer-local.
By default, the mode is buffer-local.
-:init-value VAL Same as the INIT-VALUE argument.
+:init-value VAL the initial value of the mode's variable.
+ Note that the minor mode function won't be called by setting
+ this option, so the value *reflects* the minor mode's natural
+ initial state, rather than *setting* it.
+ In the vast majority of cases it should be nil.
Not used if you also specify :variable.
-:lighter SPEC Same as the LIGHTER argument.
-:keymap MAP Same as the KEYMAP argument.
-:require SYM Same as in `defcustom'.
+:lighter SPEC Text displayed in the mode line when the mode is on.
+:keymap MAP Keymap bound to the mode keymap. Defaults to `MODE-map'.
+ If non-nil, it should be a variable name (whose value is
+ a keymap), or an expression that returns either a keymap or
+ a list of (KEY . BINDING) pairs where KEY and BINDING are
+ suitable for `define-key'. If you supply a KEYMAP argument
+ that is not a symbol, this macro defines the variable MODE-map
+ and gives it the value that KEYMAP specifies.
+:interactive VAL Whether this mode should be a command or not. The default
+ is to make it one; use nil to avoid that. If VAL is a list,
+ it's interpreted as a list of major modes this minor mode
+ is useful in.
:variable PLACE The location to use instead of the variable MODE to store
the state of the mode. This can be simply a different
named variable, or a generalized variable.
@@ -8192,7 +8737,6 @@ BODY contains code to execute each time the mode is enabled or disabled.
sets it. If you specify a :variable, this function does
not define a MODE variable (nor any of the terms used
in :variable).
-
:after-hook A single lisp form which is evaluated after the mode hooks
have been run. It should not be quoted.
@@ -8201,29 +8745,36 @@ For example, you could write
:lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version \"27.5\"
...BODY CODE...)
-\(fn MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)" nil t)
+For backward compatibility with the Emacs<21 calling convention,
+the keywords can also be preceded by the obsolete triplet
+INIT-VALUE LIGHTER KEYMAP.
+
+\(fn MODE DOC [KEYWORD VAL ... &rest BODY])" nil t)
(function-put 'define-minor-mode 'doc-string-elt '2)
-(defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode)
+(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode)
-(defalias 'define-global-minor-mode 'define-globalized-minor-mode)
+(defalias 'define-global-minor-mode #'define-globalized-minor-mode)
(autoload 'define-globalized-minor-mode "easy-mmode" "\
Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
TURN-ON is a function that will be called with no args in every buffer
- and that should try to turn MODE on if applicable for that buffer.
-Each of KEY VALUE is a pair of CL-style keyword arguments. As
- the minor mode defined by this function is always global, any
- :global keyword is ignored. Other keywords have the same
- meaning as in `define-minor-mode', which see. In particular,
- :group specifies the custom group. The most useful keywords
- are those that are passed on to the `defcustom'. It normally
- makes no sense to pass the :lighter or :keymap keywords to
- `define-globalized-minor-mode', since these are usually passed
- to the buffer-local version of the minor mode.
+and that should try to turn MODE on if applicable for that buffer.
+
+Each of KEY VALUE is a pair of CL-style keyword arguments. :predicate
+specifies which major modes the globalized minor mode should be switched on
+in. As the minor mode defined by this function is always global, any
+:global keyword is ignored. Other keywords have the same meaning as in
+`define-minor-mode', which see. In particular, :group specifies the custom
+group. The most useful keywords are those that are passed on to the
+`defcustom'. It normally makes no sense to pass the :lighter or :keymap
+keywords to `define-globalized-minor-mode', since these are usually passed
+to the buffer-local version of the minor mode.
+
BODY contains code to execute each time the mode is enabled or disabled.
- It is executed after toggling the mode, and before running GLOBAL-MODE-hook.
+It is executed after toggling the mode, and before running
+GLOBAL-MODE-hook.
If MODE's set-up depends on the major mode in effect when it was
enabled, then disabling and reenabling MODE should make MODE work
@@ -8275,208 +8826,56 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX).
(function-put 'easy-mmode-defsyntax 'lisp-indent-function '1)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easy-mmode" '("easy-mmode-")))
-
-;;;***
-
-;;;### (autoloads nil "easymenu" "emacs-lisp/easymenu.el" (0 0 0
-;;;;;; 0))
-;;; Generated autoloads from emacs-lisp/easymenu.el
-
-(autoload 'easy-menu-define "easymenu" "\
-Define a pop-up menu and/or menu bar menu specified by MENU.
-If SYMBOL is non-nil, define SYMBOL as a function to pop up the
-submenu defined by MENU, with DOC as its doc string.
-
-MAPS, if non-nil, should be a keymap or a list of keymaps; add
-the submenu defined by MENU to the keymap or each of the keymaps,
-as a top-level menu bar item.
-
-The first element of MENU must be a string. It is the menu bar
-item name. It may be followed by the following keyword argument
-pairs:
-
- :filter FUNCTION
- FUNCTION must be a function which, if called with one
- argument---the list of the other menu items---returns the
- items to actually display.
-
- :visible INCLUDE
- INCLUDE is an expression. The menu is visible if the
- expression evaluates to a non-nil value. `:included' is an
- alias for `:visible'.
-
- :active ENABLE
- ENABLE is an expression. The menu is enabled for selection
- if the expression evaluates to a non-nil value. `:enable' is
- an alias for `:active'.
-
- :label FORM
- FORM is an expression that is dynamically evaluated and whose
- value serves as the menu's label (the default is the first
- element of MENU).
-
- :help HELP
- HELP is a string, the help to display for the menu.
- In a GUI this is a \"tooltip\" on the menu button. (Though
- in Lucid :help is not shown for the top-level menu bar, only
- for sub-menus.)
-
-The rest of the elements in MENU are menu items.
-A menu item can be a vector of three elements:
-
- [NAME CALLBACK ENABLE]
-
-NAME is a string--the menu item name.
-
-CALLBACK is a command to run when the item is chosen, or an
-expression to evaluate when the item is chosen.
-
-ENABLE is an expression; the item is enabled for selection if the
-expression evaluates to a non-nil value.
-
-Alternatively, a menu item may have the form:
-
- [ NAME CALLBACK [ KEYWORD ARG ]... ]
-
-where NAME and CALLBACK have the same meanings as above, and each
-optional KEYWORD and ARG pair should be one of the following:
-
- :keys KEYS
- KEYS is a string; a keyboard equivalent to the menu item.
- This is normally not needed because keyboard equivalents are
- usually computed automatically. KEYS is expanded with
- `substitute-command-keys' before it is used.
-
- :key-sequence KEYS
- KEYS is a hint for speeding up Emacs's first display of the
- menu. It should be nil if you know that the menu item has no
- keyboard equivalent; otherwise it should be a string or
- vector specifying a keyboard equivalent for the menu item.
-
- :active ENABLE
- 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
- INCLUDE is an expression; this item is only visible if this
- expression has a non-nil value. `:included' is an alias for
- `:visible'.
-
- :label FORM
- FORM is an expression that is dynamically evaluated and whose
- value serves as the menu item's label (the default is NAME).
-
- :suffix FORM
- FORM is an expression that is dynamically evaluated and whose
- value is concatenated with the menu entry's label.
-
- :style STYLE
- STYLE is a symbol describing the type of menu item; it should
- be `toggle' (a checkbox), or `radio' (a radio button), or any
- other value (meaning an ordinary menu item).
-
- :selected SELECTED
- SELECTED is an expression; the checkbox or radio button is
- selected whenever the expression's value is non-nil.
-
- :help HELP
- HELP is a string, the help to display for the menu item.
-
-Alternatively, a menu item can be a string. Then that string
-appears in the menu as unselectable text. A string consisting
-solely of dashes is displayed as a menu separator.
-
-Alternatively, a menu item can be a list with the same format as
-MENU. This is a submenu.
-
-\(fn SYMBOL MAPS DOC MENU)" nil t)
-
-(function-put 'easy-menu-define 'lisp-indent-function 'defun)
-
-(autoload 'easy-menu-do-define "easymenu" "\
-
-
-\(fn SYMBOL MAPS DOC MENU)" nil nil)
-
-(autoload 'easy-menu-create-menu "easymenu" "\
-Create a menu called MENU-NAME with items described in MENU-ITEMS.
-MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items
-possibly preceded by keyword pairs as described in `easy-menu-define'.
-
-\(fn MENU-NAME MENU-ITEMS)" nil nil)
-
-(autoload 'easy-menu-change "easymenu" "\
-Change menu found at PATH as item NAME to contain ITEMS.
-PATH is a list of strings for locating the menu that
-should contain a submenu named NAME.
-ITEMS is a list of menu items, as in `easy-menu-define'.
-These items entirely replace the previous items in that submenu.
-
-If MAP is specified, it should normally be a keymap; nil stands for the local
-menu-bar keymap. It can also be a symbol, which has earlier been used as the
-first argument in a call to `easy-menu-define', or the value of such a symbol.
-
-If the menu located by PATH has no submenu named NAME, add one.
-If the optional argument BEFORE is present, add it just before
-the submenu named BEFORE, otherwise add it at the end of the menu.
-
-To implement dynamic menus, either call this from
-`menu-bar-update-hook' or use a menu filter.
-
-\(fn PATH NAME ITEMS &optional BEFORE MAP)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easymenu" '("add-submenu" "easy-menu-")))
+(register-definition-prefixes "easy-mmode" '("easy-mmode-"))
;;;***
;;;### (autoloads nil "ebnf-abn" "progmodes/ebnf-abn.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-abn.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-abn" '("ebnf-abn-")))
+(register-definition-prefixes "ebnf-abn" '("ebnf-abn-"))
;;;***
;;;### (autoloads nil "ebnf-bnf" "progmodes/ebnf-bnf.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-bnf.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-bnf" '("ebnf-")))
+(register-definition-prefixes "ebnf-bnf" '("ebnf-"))
;;;***
;;;### (autoloads nil "ebnf-dtd" "progmodes/ebnf-dtd.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-dtd.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-dtd" '("ebnf-dtd-")))
+(register-definition-prefixes "ebnf-dtd" '("ebnf-dtd-"))
;;;***
;;;### (autoloads nil "ebnf-ebx" "progmodes/ebnf-ebx.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-ebx.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-ebx" '("ebnf-ebx-")))
+(register-definition-prefixes "ebnf-ebx" '("ebnf-ebx-"))
;;;***
;;;### (autoloads nil "ebnf-iso" "progmodes/ebnf-iso.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-iso.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-iso" '("ebnf-")))
+(register-definition-prefixes "ebnf-iso" '("ebnf-"))
;;;***
;;;### (autoloads nil "ebnf-otz" "progmodes/ebnf-otz.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-otz.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-otz" '("ebnf-")))
+(register-definition-prefixes "ebnf-otz" '("ebnf-"))
;;;***
;;;### (autoloads nil "ebnf-yac" "progmodes/ebnf-yac.el" (0 0 0 0))
;;; Generated autoloads from progmodes/ebnf-yac.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf-yac" '("ebnf-yac-")))
+(register-definition-prefixes "ebnf-yac" '("ebnf-yac-"))
;;;***
@@ -8731,7 +9130,7 @@ See also `ebnf-push-style'.
See `ebnf-style-database' documentation." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebnf2ps" '("ebnf-")))
+(register-definition-prefixes "ebnf2ps" '("ebnf-"))
;;;***
@@ -8853,7 +9252,7 @@ Otherwise, FILE-NAME specifies the file to save the tree in.
(autoload 'ebrowse-statistics "ebrowse" "\
Display statistics for a class tree." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebrowse" '("ebrowse-" "electric-buffer-menu-mode-hook")))
+(register-definition-prefixes "ebrowse" '("ebrowse-" "electric-buffer-menu-mode-hook"))
;;;***
@@ -8888,7 +9287,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ebuff-menu" '("Electric-buffer-menu-" "electric-buffer-")))
+(register-definition-prefixes "ebuff-menu" '("Electric-buffer-menu-" "electric-buffer-"))
;;;***
@@ -8901,7 +9300,7 @@ With prefix arg NOCONFIRM, execute current line as-is without editing.
\(fn &optional NOCONFIRM)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "echistory" '("Electric-history-" "electric-")))
+(register-definition-prefixes "echistory" '("Electric-history-" "electric-"))
;;;***
@@ -8911,7 +9310,7 @@ With prefix arg NOCONFIRM, execute current line as-is without editing.
(autoload 'ecomplete-setup "ecomplete" "\
Read the .ecompleterc file." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ecomplete" '("ecomplete-")))
+(register-definition-prefixes "ecomplete" '("ecomplete-"))
;;;***
@@ -8932,24 +9331,33 @@ or call the function `global-ede-mode'.")
(autoload 'global-ede-mode "ede" "\
Toggle global EDE (Emacs Development Environment) mode.
-If called interactively, enable Global Ede mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global Ede
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-ede-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
This global minor mode enables `ede-minor-mode' in all buffers in
an EDE controlled project.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede")))
+(register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede"))
;;;***
;;;### (autoloads nil "ede/auto" "cedet/ede/auto.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/auto.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/auto" '("ede-")))
+(register-definition-prefixes "ede/auto" '("ede-"))
;;;***
@@ -8957,102 +9365,14 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/autoconf-edit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/autoconf-edit" '("autoconf-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/base" "cedet/ede/base.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/base.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/base" '("ede-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/config" "cedet/ede/config.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/config.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/config" '("ede-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/cpp-root"
-;;;;;; "cedet/ede/cpp-root.el" (0 0 0 0))
-;;; Generated autoloads from cedet/ede/cpp-root.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/cpp-root" '("ede-c")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/custom" "cedet/ede/custom.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/custom.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/custom" '("ede-" "eieio-ede-old-variables")))
+(register-definition-prefixes "ede/autoconf-edit" '("autoconf-"))
;;;***
;;;### (autoloads nil "ede/detect" "cedet/ede/detect.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/detect.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/detect" '("ede-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/dired" "cedet/ede/dired.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/dired.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/dired" '("ede-dired-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/emacs" "cedet/ede/emacs.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/emacs.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/emacs" '("ede-emacs-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/files" "cedet/ede/files.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/files.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/files" '("ede-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/generic"
-;;;;;; "cedet/ede/generic.el" (0 0 0 0))
-;;; Generated autoloads from cedet/ede/generic.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/generic" '("ede-generic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/linux" "cedet/ede/linux.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/linux.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/linux" '("ede-linux-" "project-linux-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/locate" "cedet/ede/locate.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/locate.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/locate" '("ede-locate-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/make" "cedet/ede/make.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/make.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/make" '("ede-make-")))
+(register-definition-prefixes "ede/detect" '("ede-"))
;;;***
@@ -9060,28 +9380,28 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/makefile-edit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/makefile-edit" '("makefile-")))
+(register-definition-prefixes "ede/makefile-edit" '("makefile-"))
;;;***
;;;### (autoloads nil "ede/pconf" "cedet/ede/pconf.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/pconf.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/pconf" '("ede-pconf-create-file-query")))
+(register-definition-prefixes "ede/pconf" '("ede-pconf-create-file-query"))
;;;***
;;;### (autoloads nil "ede/pmake" "cedet/ede/pmake.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/pmake.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/pmake" '("ede-pmake-")))
+(register-definition-prefixes "ede/pmake" '("ede-pmake-"))
;;;***
;;;### (autoloads nil "ede/proj" "cedet/ede/proj.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/proj.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj" '("ede-proj-")))
+(register-definition-prefixes "ede/proj" '("ede-proj-"))
;;;***
@@ -9089,7 +9409,7 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/proj-archive.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-archive" '("ede-")))
+(register-definition-prefixes "ede/proj-archive" '("ede-"))
;;;***
@@ -9097,7 +9417,7 @@ an EDE controlled project.
;;;;;; 0 0))
;;; Generated autoloads from cedet/ede/proj-aux.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-aux" '("ede-")))
+(register-definition-prefixes "ede/proj-aux" '("ede-"))
;;;***
@@ -9105,7 +9425,7 @@ an EDE controlled project.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/ede/proj-comp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-comp" '("ede-" "proj-comp-insert-variable-once")))
+(register-definition-prefixes "ede/proj-comp" '("ede-" "proj-comp-insert-variable-once"))
;;;***
@@ -9113,7 +9433,7 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/proj-elisp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-elisp" '("ede-")))
+(register-definition-prefixes "ede/proj-elisp" '("ede-"))
;;;***
@@ -9121,7 +9441,7 @@ an EDE controlled project.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/ede/proj-info.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-info" '("ede-")))
+(register-definition-prefixes "ede/proj-info" '("ede-"))
;;;***
@@ -9129,7 +9449,7 @@ an EDE controlled project.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/ede/proj-misc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-misc" '("ede-")))
+(register-definition-prefixes "ede/proj-misc" '("ede-"))
;;;***
@@ -9137,7 +9457,7 @@ an EDE controlled project.
;;;;;; 0 0))
;;; Generated autoloads from cedet/ede/proj-obj.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-obj" '("ede-")))
+(register-definition-prefixes "ede/proj-obj" '("ede-"))
;;;***
@@ -9145,7 +9465,7 @@ an EDE controlled project.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/ede/proj-prog.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-prog" '("ede-proj-target-makefile-program")))
+(register-definition-prefixes "ede/proj-prog" '("ede-proj-target-makefile-program"))
;;;***
@@ -9153,7 +9473,7 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/proj-scheme.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-scheme" '("ede-proj-target-scheme")))
+(register-definition-prefixes "ede/proj-scheme" '("ede-proj-target-scheme"))
;;;***
@@ -9161,7 +9481,7 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/proj-shared.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/proj-shared" '("ede-")))
+(register-definition-prefixes "ede/proj-shared" '("ede-"))
;;;***
@@ -9169,37 +9489,21 @@ an EDE controlled project.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/ede/project-am.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/project-am" '("project-am-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/shell" "cedet/ede/shell.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/shell.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/shell" '("ede-shell-run-command")))
+(register-definition-prefixes "ede/project-am" '("project-am-"))
;;;***
;;;### (autoloads nil "ede/simple" "cedet/ede/simple.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/simple.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/simple" '("ede-simple-")))
+(register-definition-prefixes "ede/simple" '("ede-simple-"))
;;;***
;;;### (autoloads nil "ede/source" "cedet/ede/source.el" (0 0 0 0))
;;; Generated autoloads from cedet/ede/source.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/source" '("ede-source")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/speedbar"
-;;;;;; "cedet/ede/speedbar.el" (0 0 0 0))
-;;; Generated autoloads from cedet/ede/speedbar.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/speedbar" '("ede-")))
+(register-definition-prefixes "ede/source" '("ede-source"))
;;;***
@@ -9207,15 +9511,7 @@ an EDE controlled project.
;;;;;; 0))
;;; Generated autoloads from cedet/ede/srecode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/srecode" '("ede-srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ede/util" "cedet/ede/util.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/ede/util.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/util" '("ede-make-buffer-writable")))
+(register-definition-prefixes "ede/srecode" '("ede-srecode-"))
;;;***
@@ -9275,7 +9571,7 @@ Toggle edebugging of all definitions." t nil)
(autoload 'edebug-all-forms "edebug" "\
Toggle edebugging of all forms." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edebug" '("cancel-edebug-on-entry" "edebug" "get-edebug-spec" "global-edebug-")))
+(register-definition-prefixes "edebug" '("arglist" "backquote-form" "def-declarations" "edebug" "function-form" "interactive" "lambda-" "name" "nested-backquote-form"))
;;;***
@@ -9297,9 +9593,9 @@ arguments after setting up the Ediff buffers.
\(fn FILE-A FILE-B FILE-C &optional STARTUP-HOOKS)" t nil)
-(defalias 'ediff3 'ediff-files3)
+(defalias 'ediff3 #'ediff-files3)
-(defalias 'ediff 'ediff-files)
+(defalias 'ediff #'ediff-files)
(autoload 'ediff-current-file "ediff" "\
Start ediff between current buffer and its file on disk.
@@ -9325,7 +9621,7 @@ symbol describing the Ediff job type; it defaults to
\(fn BUFFER-A BUFFER-B &optional STARTUP-HOOKS JOB-NAME)" t nil)
-(defalias 'ebuffers 'ediff-buffers)
+(defalias 'ebuffers #'ediff-buffers)
(autoload 'ediff-buffers3 "ediff" "\
Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C.
@@ -9339,7 +9635,7 @@ symbol describing the Ediff job type; it defaults to
\(fn BUFFER-A BUFFER-B BUFFER-C &optional STARTUP-HOOKS JOB-NAME)" t nil)
-(defalias 'ebuffers3 'ediff-buffers3)
+(defalias 'ebuffers3 #'ediff-buffers3)
(autoload 'ediff-directories "ediff" "\
Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have
@@ -9348,7 +9644,7 @@ expression; only file names that match the regexp are considered.
\(fn DIR1 DIR2 REGEXP)" t nil)
-(defalias 'edirs 'ediff-directories)
+(defalias 'edirs #'ediff-directories)
(autoload 'ediff-directory-revisions "ediff" "\
Run Ediff on a directory, DIR1, comparing its files with their revisions.
@@ -9357,7 +9653,7 @@ names. Only the files that are under revision control are taken into account.
\(fn DIR1 REGEXP)" t nil)
-(defalias 'edir-revisions 'ediff-directory-revisions)
+(defalias 'edir-revisions #'ediff-directory-revisions)
(autoload 'ediff-directories3 "ediff" "\
Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that
@@ -9366,7 +9662,7 @@ regular expression; only file names that match the regexp are considered.
\(fn DIR1 DIR2 DIR3 REGEXP)" t nil)
-(defalias 'edirs3 'ediff-directories3)
+(defalias 'edirs3 #'ediff-directories3)
(autoload 'ediff-merge-directories "ediff" "\
Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have
@@ -9376,7 +9672,7 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files.
\(fn DIR1 DIR2 REGEXP &optional MERGE-AUTOSTORE-DIR)" t nil)
-(defalias 'edirs-merge 'ediff-merge-directories)
+(defalias 'edirs-merge #'ediff-merge-directories)
(autoload 'ediff-merge-directories-with-ancestor "ediff" "\
Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors.
@@ -9396,7 +9692,7 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files.
\(fn DIR1 REGEXP &optional MERGE-AUTOSTORE-DIR)" t nil)
-(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions)
+(defalias 'edir-merge-revisions #'ediff-merge-directory-revisions)
(autoload 'ediff-merge-directory-revisions-with-ancestor "ediff" "\
Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors.
@@ -9598,14 +9894,14 @@ Call `ediff-merge-directories' with the next three command line arguments." nil
(autoload 'ediff-merge-directories-with-ancestor-command "ediff" "\
Call `ediff-merge-directories-with-ancestor' with the next four command line arguments." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff" '("ediff-")))
+(register-definition-prefixes "ediff" '("ediff-"))
;;;***
;;;### (autoloads nil "ediff-diff" "vc/ediff-diff.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-diff.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-diff" '("ediff-")))
+(register-definition-prefixes "ediff-diff" '("ediff-"))
;;;***
@@ -9614,21 +9910,21 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg
(autoload 'ediff-customize "ediff-help" nil t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-help" '("ediff-")))
+(register-definition-prefixes "ediff-help" '("ediff-"))
;;;***
;;;### (autoloads nil "ediff-init" "vc/ediff-init.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-init.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-init" '("ediff-" "stipple-pixmap")))
+(register-definition-prefixes "ediff-init" '("ediff-" "stipple-pixmap"))
;;;***
;;;### (autoloads nil "ediff-merg" "vc/ediff-merg.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-merg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-merg" '("ediff-")))
+(register-definition-prefixes "ediff-merg" '("ediff-"))
;;;***
@@ -9638,16 +9934,16 @@ Call `ediff-merge-directories-with-ancestor' with the next four command line arg
(autoload 'ediff-show-registry "ediff-mult" "\
Display Ediff's registry." t nil)
-(defalias 'eregistry 'ediff-show-registry)
+(defalias 'eregistry #'ediff-show-registry)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-mult" '("ediff-")))
+(register-definition-prefixes "ediff-mult" '("ediff-"))
;;;***
;;;### (autoloads nil "ediff-ptch" "vc/ediff-ptch.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-ptch.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-ptch" '("ediff-")))
+(register-definition-prefixes "ediff-ptch" '("ediff-"))
;;;***
@@ -9664,27 +9960,26 @@ Enable or disable Ediff toolbar.
Works only in versions of Emacs that support toolbars.
To change the default, set the variable `ediff-use-toolbar-p', which see." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-util" '("ediff-")))
+(register-definition-prefixes "ediff-util" '("ediff-"))
;;;***
;;;### (autoloads nil "ediff-vers" "vc/ediff-vers.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-vers.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-vers" '("ediff-" "rcs-ediff-view-revision")))
+(register-definition-prefixes "ediff-vers" '("ediff-" "rcs-ediff-view-revision"))
;;;***
;;;### (autoloads nil "ediff-wind" "vc/ediff-wind.el" (0 0 0 0))
;;; Generated autoloads from vc/ediff-wind.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ediff-wind" '("ediff-")))
+(register-definition-prefixes "ediff-wind" '("ediff-"))
;;;***
;;;### (autoloads nil "edmacro" "edmacro.el" (0 0 0 0))
;;; Generated autoloads from edmacro.el
-(push (purecopy '(edmacro 2 1)) package--builtin-versions)
(autoload 'edit-kbd-macro "edmacro" "\
Edit a keyboard macro.
@@ -9730,7 +10025,7 @@ or nil, use a compact 80-column format.
\(fn &optional MACRO VERBOSE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edmacro" '("edmacro-")))
+(register-definition-prefixes "edmacro" '("edmacro-"))
;;;***
@@ -9747,7 +10042,7 @@ Argument BOTTOM is the bottom margin in number of lines or percent of window.
(autoload 'edt-emulation-on "edt" "\
Turn on EDT Emulation." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt" '("edt-")))
+(register-definition-prefixes "edt" '("edt-"))
;;;***
@@ -9755,7 +10050,7 @@ Turn on EDT Emulation." t nil)
;;;;;; 0))
;;; Generated autoloads from emulation/edt-lk201.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt-lk201" '("*EDT-keys*")))
+(register-definition-prefixes "edt-lk201" '("*EDT-keys*"))
;;;***
@@ -9763,14 +10058,14 @@ Turn on EDT Emulation." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/edt-mapper.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt-mapper" '("edt-")))
+(register-definition-prefixes "edt-mapper" '("edt-"))
;;;***
;;;### (autoloads nil "edt-pc" "emulation/edt-pc.el" (0 0 0 0))
;;; Generated autoloads from emulation/edt-pc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt-pc" '("*EDT-keys*")))
+(register-definition-prefixes "edt-pc" '("*EDT-keys*"))
;;;***
@@ -9778,7 +10073,7 @@ Turn on EDT Emulation." t nil)
;;;;;; 0))
;;; Generated autoloads from emulation/edt-vt100.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "edt-vt100" '("edt-set-term-width-")))
+(register-definition-prefixes "edt-vt100" '("edt-set-term-width-"))
;;;***
@@ -9816,7 +10111,7 @@ BUFFER is put back into its original major mode.
\(fn FUN &optional NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ehelp" '("ehelp-" "electric-")))
+(register-definition-prefixes "ehelp" '("ehelp-" "electric-"))
;;;***
@@ -9824,7 +10119,7 @@ BUFFER is put back into its original major mode.
;;; Generated autoloads from emacs-lisp/eieio.el
(push (purecopy '(eieio 1 4)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio" '("child-of-class-p" "defclass" "eieio-" "find-class" "obj" "oref" "oset" "same-class-p" "set-slot-value" "slot-" "with-slots")))
+(register-definition-prefixes "eieio" '("child-of-class-p" "defclass" "eieio-" "find-class" "obj" "oref" "oset" "same-class-p" "set-slot-value" "slot-" "with-slots"))
;;;***
@@ -9832,15 +10127,7 @@ BUFFER is put back into its original major mode.
;;;;;; 0 0 0))
;;; Generated autoloads from emacs-lisp/eieio-base.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-base" '("eieio-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "eieio-compat"
-;;;;;; "emacs-lisp/eieio-compat.el" (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/eieio-compat.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-compat" '("eieio--generic-static-symbol-specializers" "generic-p" "next-method-p" "no-")))
+(register-definition-prefixes "eieio-base" '("eieio-"))
;;;***
@@ -9859,15 +10146,7 @@ It creates an autoload function for CNAME's constructor.
\(fn CNAME SUPERCLASSES FILENAME DOC)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "eieio-custom"
-;;;;;; "emacs-lisp/eieio-custom.el" (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/eieio-custom.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-custom" '("eieio-")))
+(register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot"))
;;;***
@@ -9875,23 +10154,21 @@ It creates an autoload function for CNAME's constructor.
;;;;;; (0 0 0 0))
;;; Generated autoloads from emacs-lisp/eieio-datadebug.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-datadebug" '("data-debug-insert-object-")))
+(register-definition-prefixes "eieio-datadebug" '("data-debug-insert-object-"))
;;;***
-;;;### (autoloads "actual autoloads are elsewhere" "eieio-opt" "emacs-lisp/eieio-opt.el"
+;;;### (autoloads nil "eieio-speedbar" "emacs-lisp/eieio-speedbar.el"
;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/eieio-opt.el
+;;; Generated autoloads from emacs-lisp/eieio-speedbar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-opt" '("eieio-")))
+(register-definition-prefixes "eieio-speedbar" '("eieio-speedbar"))
;;;***
-;;;### (autoloads nil "eieio-speedbar" "emacs-lisp/eieio-speedbar.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/eieio-speedbar.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eieio-speedbar" '("eieio-speedbar")))
+;;;### (autoloads nil "eldoc" "emacs-lisp/eldoc.el" (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/eldoc.el
+(push (purecopy '(eldoc 1 11 0)) package--builtin-versions)
;;;***
@@ -9911,10 +10188,19 @@ or call the function `electric-pair-mode'.")
(autoload 'electric-pair-mode "elec-pair" "\
Toggle automatic parens pairing (Electric Pair mode).
-If called interactively, enable Electric-Pair mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Electric-Pair mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'electric-pair-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Electric Pair mode is a global minor mode. When enabled, typing
an open parenthesis automatically inserts the corresponding
@@ -9929,14 +10215,23 @@ To toggle the mode in a single buffer, use `electric-pair-local-mode'.
(autoload 'electric-pair-local-mode "elec-pair" "\
Toggle `electric-pair-mode' only in this buffer.
-If called interactively, enable Electric-Pair-Local mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Electric-Pair-Local mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(buffer-local-value 'electric-pair-mode (current-buffer))'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elec-pair" '("electric-pair-")))
+(register-definition-prefixes "elec-pair" '("electric-pair-"))
;;;***
@@ -9953,7 +10248,7 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elide-head" '("elide-head-")))
+(register-definition-prefixes "elide-head" '("elide-head-"))
;;;***
@@ -9986,7 +10281,7 @@ optional prefix argument REINIT is non-nil.
\(fn &optional REINIT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elint" '("elint-")))
+(register-definition-prefixes "elint" '("elint-"))
;;;***
@@ -10021,143 +10316,7 @@ If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions is reset after results are
displayed." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "elp" '("elp-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-alias" "eshell/em-alias.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-alias.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-alias" '("eshell" "pcomplete/eshell-mode/alias")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-banner" "eshell/em-banner.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-banner.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-banner" '("eshell-banner-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-basic" "eshell/em-basic.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-basic.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-basic" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-cmpl" "eshell/em-cmpl.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-cmpl.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-cmpl" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-dirs" "eshell/em-dirs.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-dirs.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-dirs" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-glob" "eshell/em-glob.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-glob.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-glob" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-hist" "eshell/em-hist.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-hist.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-hist" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-ls" "eshell/em-ls.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-ls.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-ls" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-pred" "eshell/em-pred.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-pred.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-pred" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-prompt" "eshell/em-prompt.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-prompt.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-prompt" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-rebind" "eshell/em-rebind.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-rebind.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-rebind" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-script" "eshell/em-script.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-script.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-script" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-smart" "eshell/em-smart.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-smart.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-smart" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-term" "eshell/em-term.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-term.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-term" '("eshell-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-tramp" "eshell/em-tramp.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-tramp.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-tramp" '("eshell")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-unix" "eshell/em-unix.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-unix.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-unix" '("eshell" "nil-blank-string" "pcomplete/")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "em-xtra" "eshell/em-xtra.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from eshell/em-xtra.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "em-xtra" '("eshell/" "pcomplete/bcc")))
+(register-definition-prefixes "elp" '("elp-"))
;;;***
@@ -10187,7 +10346,7 @@ some major modes from being locked under some circumstances.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacs-lock" '("emacs-lock-" "toggle-emacs-lock")))
+(register-definition-prefixes "emacs-lock" '("emacs-lock-" "toggle-emacs-lock"))
;;;***
@@ -10198,11 +10357,23 @@ some major modes from being locked under some circumstances.
Report a bug in GNU Emacs.
Prompts for bug subject. Leaves you in a mail buffer.
+Already submitted bugs can be found in the Emacs bug tracker:
+
+ https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1
+
\(fn TOPIC &optional UNUSED)" t nil)
(set-advertised-calling-convention 'report-emacs-bug '(topic) '"24.5")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emacsbug" '("report-emacs-bug-")))
+(autoload 'submit-emacs-patch "emacsbug" "\
+Send an Emacs patch to the Emacs maintainers.
+Interactively, you will be prompted for SUBJECT and a patch FILE
+name (which will be attached to the mail). You will end up in a
+Message buffer where you can explain more about the patch.
+
+\(fn SUBJECT FILE)" t nil)
+
+(register-definition-prefixes "emacsbug" '("emacs-bug--system-description" "report-emacs-bug-"))
;;;***
@@ -10258,7 +10429,7 @@ Emerge two RCS revisions of a file, with another revision as ancestor.
\(fn A-DIR B-DIR ANCESTOR-DIR OUTPUT-DIR)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "emerge" '("emerge-")))
+(register-definition-prefixes "emerge" '("emerge-"))
;;;***
@@ -10270,10 +10441,19 @@ Minor mode for editing text/enriched files.
These are files with embedded formatting information in the MIME standard
text/enriched format.
-If called interactively, enable Enriched mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Enriched
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `enriched-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Turning the mode on or off runs `enriched-mode-hook'.
@@ -10296,7 +10476,7 @@ Commands:
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "enriched" '("enriched-")))
+(register-definition-prefixes "enriched" '("enriched-"))
;;;***
@@ -10486,7 +10666,7 @@ Insert selected KEYS after the point.
\(fn KEYS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epa" '("epa-")))
+(register-definition-prefixes "epa" '("epa-"))
;;;***
@@ -10519,7 +10699,27 @@ Encrypt marked files." t nil)
(autoload 'epa-file-disable "epa-file" nil t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epa-file" '("epa-")))
+(register-definition-prefixes "epa-file" '("epa-"))
+
+;;;***
+
+;;;### (autoloads nil "epa-ks" "epa-ks.el" (0 0 0 0))
+;;; Generated autoloads from epa-ks.el
+
+(autoload 'epa-search-keys "epa-ks" "\
+Ask a keyserver for all keys matching QUERY.
+
+The keyserver to be used is specified by `epa-keyserver'.
+
+If EXACT is non-nil (interactively, prefix argument), require
+exact matches.
+
+Note that the request may fail if the query is not specific
+enough, since keyservers have strict timeout settings.
+
+\(fn QUERY EXACT)" t nil)
+
+(register-definition-prefixes "epa-ks" '("epa-k"))
;;;***
@@ -10529,10 +10729,19 @@ Encrypt marked files." t nil)
(autoload 'epa-mail-mode "epa-mail" "\
A minor-mode for composing encrypted/clearsigned mails.
-If called interactively, enable epa-mail mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `epa-mail
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `epa-mail-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -10593,14 +10802,23 @@ or call the function `epa-global-mail-mode'.")
(autoload 'epa-global-mail-mode "epa-mail" "\
Minor mode to hook EasyPG into Mail mode.
-If called interactively, enable Epa-Global-Mail mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Epa-Global-Mail mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'epa-global-mail-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epa-mail" '("epa-mail-")))
+(register-definition-prefixes "epa-mail" '("epa-mail-"))
;;;***
@@ -10613,7 +10831,7 @@ Return a context object.
\(fn &optional PROTOCOL ARMOR TEXTMODE INCLUDE-CERTS CIPHER-ALGORITHM DIGEST-ALGORITHM COMPRESS-ALGORITHM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epg" '("epg-")))
+(register-definition-prefixes "epg" '("epg-"))
;;;***
@@ -10653,7 +10871,7 @@ Look at CONFIG and try to expand GROUP.
\(fn CONFIG GROUP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "epg-config" '("epg-")))
+(register-definition-prefixes "epg-config" '("epg-"))
;;;***
@@ -10668,197 +10886,103 @@ Prompt the user for values of nick, server, port, and password." nil nil)
ERC is a powerful, modular, and extensible IRC client.
This function is the main entry point for ERC.
-It permits you to select connection parameters, and then starts ERC.
+It allows selecting connection parameters, and then starts ERC.
Non-interactively, it takes the keyword arguments
(server (erc-compute-server))
(port (erc-compute-port))
(nick (erc-compute-nick))
password
- (full-name (erc-compute-full-name)))
+ (full-name (erc-compute-full-name))
That is, if called with
(erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-then the server and full-name will be set to those values, whereas
-`erc-compute-port', `erc-compute-nick' and `erc-compute-full-name' will
-be invoked for the values of the other parameters.
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of the other parameters.
\(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name)))" t nil)
-(defalias 'erc-select 'erc)
+(defalias 'erc-select #'erc)
(autoload 'erc-tls "erc" "\
-Interactively select TLS connection parameters and run ERC.
-Arguments are the same as for `erc'.
-
-\(fn &rest R)" t nil)
-
-(autoload 'erc-handle-irc-url "erc" "\
-Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD.
-If ERC is already connected to HOST:PORT, simply /join CHANNEL.
-Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
-
-\(fn HOST PORT CHANNEL USER PASSWORD)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc" '("define-erc-module" "erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-autoaway"
-;;;;;; "erc/erc-autoaway.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-autoaway.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-autoaway" '("erc-auto")))
-
-;;;***
-
-;;;### (autoloads nil "erc-backend" "erc/erc-backend.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-backend.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-backend" '("erc-")))
+ERC is a powerful, modular, and extensible IRC client.
+This function is the main entry point for ERC over TLS.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-button" "erc/erc-button.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-button.el
+It allows selecting connection parameters, and then starts ERC
+over TLS.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-button" '("erc-")))
+Non-interactively, it takes the keyword arguments
+ (server (erc-compute-server))
+ (port (erc-compute-port))
+ (nick (erc-compute-nick))
+ password
+ (full-name (erc-compute-full-name))
+ client-certificate
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-capab" "erc/erc-capab.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-capab.el
+That is, if called with
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-capab" '("erc-capab-identify-")))
+ (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-compat" "erc/erc-compat.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-compat.el
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of their respective parameters.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-compat" '("erc-")))
+CLIENT-CERTIFICATE, if non-nil, should either be a list where the
+first element is the certificate key file name, and the second
+element is the certificate file name itself, or t, which means
+that `auth-source' will be queried for the key and the
+certificate. Authenticating using a TLS client certificate is
+also refered to as \"CertFP\" (Certificate Fingerprint)
+authentication by various IRC networks.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-dcc" "erc/erc-dcc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-dcc.el
+Example usage:
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-dcc" '("erc-" "pcomplete/erc-mode/")))
+ (erc-tls :server \"irc.libera.chat\" :port 6697
+ :client-certificate
+ '(\"/home/bandali/my-cert.key\"
+ \"/home/bandali/my-cert.crt\"))
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-desktop-notifications"
-;;;;;; "erc/erc-desktop-notifications.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-desktop-notifications.el
+\(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-desktop-notifications" '("erc-notifications-")))
+(autoload 'erc-handle-irc-url "erc" "\
+Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD.
+If ERC is already connected to HOST:PORT, simply /join CHANNEL.
+Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-ezbounce"
-;;;;;; "erc/erc-ezbounce.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-ezbounce.el
+\(fn HOST PORT CHANNEL USER PASSWORD)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ezbounce" '("erc-ezb-")))
+(register-definition-prefixes "erc" '("define-erc-module" "erc-"))
;;;***
-;;;### (autoloads "actual autoloads are elsewhere" "erc-fill" "erc/erc-fill.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-fill.el
+;;;### (autoloads nil "erc-backend" "erc/erc-backend.el" (0 0 0 0))
+;;; Generated autoloads from erc/erc-backend.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-fill" '("erc-")))
+(register-definition-prefixes "erc-backend" '("erc-"))
;;;***
;;;### (autoloads nil "erc-goodies" "erc/erc-goodies.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-goodies.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-goodies" '("erc-")))
+(register-definition-prefixes "erc-goodies" '("erc-"))
;;;***
;;;### (autoloads nil "erc-ibuffer" "erc/erc-ibuffer.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-ibuffer.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ibuffer" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-identd" "erc/erc-identd.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-identd.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-identd" '("erc-identd-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-imenu" "erc/erc-imenu.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-imenu.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-imenu" '("erc-unfill-notice")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-join" "erc/erc-join.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-join.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-join" '("erc-")))
+(register-definition-prefixes "erc-ibuffer" '("erc-"))
;;;***
;;;### (autoloads nil "erc-lang" "erc/erc-lang.el" (0 0 0 0))
;;; Generated autoloads from erc/erc-lang.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-638-languages" "language")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-list" "erc/erc-list.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-list.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-list" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-log" "erc/erc-log.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-log.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-log" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-match" "erc/erc-match.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-match.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-match" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-menu" "erc/erc-menu.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-menu.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-menu" '("erc-menu-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-netsplit"
-;;;;;; "erc/erc-netsplit.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-netsplit.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-netsplit" '("erc-")))
+(register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-638-languages" "language"))
;;;***
@@ -10874,111 +10998,7 @@ server name and search for a match in `erc-networks-alist'." nil nil)
(autoload 'erc-server-select "erc-networks" "\
Interactively select a server to connect to using `erc-server-alist'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-networks" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-notify" "erc/erc-notify.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-notify.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-notify" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-page" "erc/erc-page.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-page.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-page" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-pcomplete"
-;;;;;; "erc/erc-pcomplete.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-pcomplete.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("erc-pcomplet" "pcomplete")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-replace"
-;;;;;; "erc/erc-replace.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-replace.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-replace" '("erc-replace-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-ring" "erc/erc-ring.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-ring.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ring" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-services"
-;;;;;; "erc/erc-services.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-services.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-services" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-sound" "erc/erc-sound.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-sound.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-sound" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-speedbar"
-;;;;;; "erc/erc-speedbar.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-speedbar.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-speedbar" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-spelling"
-;;;;;; "erc/erc-spelling.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-spelling.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-spelling" '("erc-spelling-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-stamp" "erc/erc-stamp.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-stamp.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-stamp" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-track" "erc/erc-track.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-track.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-track" '("erc-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-truncate"
-;;;;;; "erc/erc-truncate.el" (0 0 0 0))
-;;; Generated autoloads from erc/erc-truncate.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-truncate" '("erc-max-buffer-size")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "erc-xdcc" "erc/erc-xdcc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from erc/erc-xdcc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-xdcc" '("erc-")))
+(register-definition-prefixes "erc-networks" '("erc-"))
;;;***
@@ -11010,10 +11030,6 @@ it has to be wrapped in `(eval (quote ...))'.
(function-put 'ert-deftest 'lisp-indent-function '2)
-(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.
@@ -11046,54 +11062,52 @@ and how to display message.
\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil)
-(defalias 'ert 'ert-run-tests-interactively)
+(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)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ert" '("ert-")))
+(register-definition-prefixes "ert" '("ert-"))
;;;***
;;;### (autoloads nil "ert-x" "emacs-lisp/ert-x.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/ert-x.el
-(put 'ert-with-test-buffer 'lisp-indent-function 1)
-
(autoload 'ert-kill-all-test-buffers "ert-x" "\
Kill all test buffers that are still live." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ert-x" '("ert-")))
+(register-definition-prefixes "ert-x" '("ert-"))
;;;***
;;;### (autoloads nil "esh-arg" "eshell/esh-arg.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-arg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-arg" '("eshell-")))
+(register-definition-prefixes "esh-arg" '("eshell-"))
;;;***
;;;### (autoloads nil "esh-cmd" "eshell/esh-cmd.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-cmd.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-cmd" '("eshell" "pcomplete/eshell-mode/eshell-debug")))
+(register-definition-prefixes "esh-cmd" '("eshell" "pcomplete/eshell-mode/eshell-debug"))
;;;***
;;;### (autoloads nil "esh-ext" "eshell/esh-ext.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-ext.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-ext" '("eshell")))
+(register-definition-prefixes "esh-ext" '("eshell"))
;;;***
;;;### (autoloads nil "esh-io" "eshell/esh-io.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-io.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-io" '("eshell-")))
+(register-definition-prefixes "esh-io" '("eshell-"))
;;;***
@@ -11105,7 +11119,12 @@ Emacs shell interactive mode.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-mode" '("eshell")))
+(autoload 'eshell-bookmark-jump "esh-mode" "\
+Default bookmark handler for Eshell buffers.
+
+\(fn BOOKMARK)" nil nil)
+
+(register-definition-prefixes "esh-mode" '("eshell"))
;;;***
@@ -11113,35 +11132,35 @@ Emacs shell interactive mode.
;;;;;; 0))
;;; Generated autoloads from eshell/esh-module.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-module" '("eshell-")))
+(register-definition-prefixes "esh-module" '("eshell-"))
;;;***
;;;### (autoloads nil "esh-opt" "eshell/esh-opt.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-opt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-opt" '("eshell-")))
+(register-definition-prefixes "esh-opt" '("eshell-"))
;;;***
;;;### (autoloads nil "esh-proc" "eshell/esh-proc.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-proc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-proc" '("eshell")))
+(register-definition-prefixes "esh-proc" '("eshell"))
;;;***
;;;### (autoloads nil "esh-util" "eshell/esh-util.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-util" '("eshell-")))
+(register-definition-prefixes "esh-util" '("eshell-"))
;;;***
;;;### (autoloads nil "esh-var" "eshell/esh-var.el" (0 0 0 0))
;;; Generated autoloads from eshell/esh-var.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "esh-var" '("eshell" "pcomplete/eshell-mode/")))
+(register-definition-prefixes "esh-var" '("eshell" "pcomplete/eshell-mode/"))
;;;***
@@ -11183,9 +11202,7 @@ corresponding to a successful execution.
\(fn COMMAND &optional STATUS-VAR)" nil nil)
-(define-obsolete-function-alias 'eshell-report-bug 'report-emacs-bug "23.1")
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eshell" '("eshell-")))
+(register-definition-prefixes "eshell" '("eshell-"))
;;;***
@@ -11208,6 +11225,8 @@ Any other value means use the setting of `case-fold-search'.")
(custom-autoload 'tags-case-fold-search "etags" t)
+(put 'tags-case-fold-search 'safe-local-variable 'symbolp)
+
(defvar tags-table-list nil "\
List of file names of tags tables to search.
An element that is a directory means the file \"TAGS\" in that directory.
@@ -11439,10 +11458,10 @@ argument is passed to `next-file', which see).
(autoload 'tags-search "etags" "\
Search through all files listed in tags table for match for REGEXP.
Stops when a match is found.
-To continue searching for next match, use command \\[tags-loop-continue].
+To continue searching for next match, use the command \\[fileloop-continue].
-If FILES if non-nil should be a list or an iterator returning the files to search.
-The search will be restricted to these files.
+If FILES if non-nil should be a list or an iterator returning the
+files to search. The search will be restricted to these files.
Also see the documentation of the `tags-file-name' variable.
@@ -11452,8 +11471,8 @@ Also see the documentation of the `tags-file-name' variable.
Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
-with the command \\[tags-loop-continue].
-For non-interactive use, superceded by `fileloop-initialize-replace'.
+with the command \\[fileloop-continue].
+For non-interactive use, superseded by `fileloop-initialize-replace'.
\(fn FROM TO &optional DELIMITED FILES)" t nil)
@@ -11489,7 +11508,7 @@ for \\[find-tag] (which see)." t nil)
(autoload 'etags--xref-backend "etags" nil nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function" "xref-")))
+(register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function" "xref-"))
;;;***
@@ -11643,7 +11662,7 @@ With ARG, insert that many delimiters.
\(fn POS TO FONT-OBJECT STRING DIRECTION)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ethio-util" '("ethio-" "exit-ethiopic-environment")))
+(register-definition-prefixes "ethio-util" '("ethio-" "exit-ethiopic-environment"))
;;;***
@@ -11710,7 +11729,7 @@ This does nothing except loading eudc by autoload side-effect." t nil)
(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc" '("eudc-")))
+(register-definition-prefixes "eudc" '("eudc-"))
;;;***
@@ -11747,7 +11766,7 @@ Display a button for the JPEG DATA.
\(fn DATA)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-bob" '("eudc-")))
+(register-definition-prefixes "eudc-bob" '("eudc-bob-"))
;;;***
@@ -11761,7 +11780,7 @@ This function can only be called from a directory query result buffer." t nil)
(autoload 'eudc-try-bbdb-insert "eudc-export" "\
Call `eudc-insert-record-at-point-into-bbdb' if on a record." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-export" '("eudc-")))
+(register-definition-prefixes "eudc-export" '("eudc-"))
;;;***
@@ -11772,35 +11791,43 @@ Call `eudc-insert-record-at-point-into-bbdb' if on a record." t nil)
(autoload 'eudc-edit-hotlist "eudc-hotlist" "\
Edit the hotlist of directory servers in a specialized buffer." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-hotlist" '("eudc-hotlist-")))
+(register-definition-prefixes "eudc-hotlist" '("eudc-hotlist-"))
;;;***
;;;### (autoloads nil "eudc-vars" "net/eudc-vars.el" (0 0 0 0))
;;; Generated autoloads from net/eudc-vars.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc-vars" '("eudc-")))
+(register-definition-prefixes "eudc-vars" '("eudc-"))
;;;***
;;;### (autoloads nil "eudcb-bbdb" "net/eudcb-bbdb.el" (0 0 0 0))
;;; Generated autoloads from net/eudcb-bbdb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudcb-bbdb" '("eudc-bbdb-")))
+(register-definition-prefixes "eudcb-bbdb" '("eudc-bbdb-"))
;;;***
;;;### (autoloads nil "eudcb-ldap" "net/eudcb-ldap.el" (0 0 0 0))
;;; Generated autoloads from net/eudcb-ldap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudcb-ldap" '("eudc-")))
+(register-definition-prefixes "eudcb-ldap" '("eudc-"))
;;;***
;;;### (autoloads nil "eudcb-mab" "net/eudcb-mab.el" (0 0 0 0))
;;; Generated autoloads from net/eudcb-mab.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudcb-mab" '("eudc-")))
+(register-definition-prefixes "eudcb-mab" '("eudc-"))
+
+;;;***
+
+;;;### (autoloads nil "eudcb-macos-contacts" "net/eudcb-macos-contacts.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from net/eudcb-macos-contacts.el
+
+(register-definition-prefixes "eudcb-macos-contacts" '("eudc-macos-contacts-"))
;;;***
@@ -11828,7 +11855,7 @@ fourth arg NOSEP non-nil inhibits this.
\(fn PRETTY-PRINTER &optional HEADER FOOTER NOSEP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ewoc" '("ewoc-")))
+(register-definition-prefixes "ewoc" '("ewoc-"))
;;;***
@@ -11843,6 +11870,20 @@ duplicate entries (if any) removed.")
(custom-autoload 'eww-suggest-uris "eww" t)
+(autoload 'eww-browse "eww" "\
+Function to be run to parse command line URLs.
+This is meant to be used for MIME handlers or command line use.
+
+Setting the handler for \"text/x-uri;\" to
+\"emacs -f eww-browse %u\" will then start up Emacs and call eww
+to browse the url.
+
+This can also be used on the command line directly:
+
+ emacs -f eww-browse https://gnu.org
+
+will start Emacs and browse the GNU web site." t nil)
+
(autoload 'eww "eww" "\
Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
@@ -11851,7 +11892,11 @@ word(s) will be searched for via `eww-search-prefix'.
If called with a prefix ARG, use a new buffer instead of reusing
the default EWW buffer.
-\(fn URL &optional ARG)" t nil)
+If BUFFER, the data to be rendered is in that buffer. In that
+case, this function doesn't actually fetch URL. BUFFER will be
+killed after rendering.
+
+\(fn URL &optional ARG BUFFER)" t nil)
(defalias 'browse-web 'eww)
(autoload 'eww-open-file "eww" "\
@@ -11891,7 +11936,7 @@ instead of `browse-url-new-window-flag'.
(autoload 'eww-list-bookmarks "eww" "\
Display the bookmarks." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eww" '("eww-")))
+(register-definition-prefixes "eww" '("erc--download-directory" "eww-"))
;;;***
@@ -11927,14 +11972,14 @@ Make file executable according to umask if not already executable.
If file already has any execute bits set at all, do not change existing
file modes." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "executable" '("executable-")))
+(register-definition-prefixes "executable" '("executable-"))
;;;***
;;;### (autoloads nil "exif" "image/exif.el" (0 0 0 0))
;;; Generated autoloads from image/exif.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "exif" '("exif-")))
+(register-definition-prefixes "exif" '("exif-"))
;;;***
@@ -11979,14 +12024,14 @@ This is used only in conjunction with `expand-add-abbrevs'." t nil)
(define-key abbrev-map "p" 'expand-jump-to-previous-slot)
(define-key abbrev-map "n" 'expand-jump-to-next-slot)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "expand" '("expand-")))
+(register-definition-prefixes "expand" '("expand-"))
;;;***
;;;### (autoloads nil "ezimage" "ezimage.el" (0 0 0 0))
;;; Generated autoloads from ezimage.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ezimage" '("defezimage" "ezimage-")))
+(register-definition-prefixes "ezimage" '("defezimage" "ezimage-"))
;;;***
@@ -12055,7 +12100,7 @@ with no args, if that value is non-nil.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "f90" '("f90-")))
+(register-definition-prefixes "f90" '("f90-"))
;;;***
@@ -12173,10 +12218,19 @@ a top-level keymap, `text-scale-increase' or
(autoload 'buffer-face-mode "face-remap" "\
Minor mode for a buffer-specific default face.
-If called interactively, enable Buffer-Face mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Buffer-Face mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `buffer-face-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When enabled, the face specified by the variable
`buffer-face-mode-face' is used to display the buffer text.
@@ -12220,7 +12274,34 @@ Besides the choice of face, it is the same as `buffer-face-mode'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "face-remap" '("buffer-face-mode-" "face-" "internal-lisp-face-attributes" "text-scale-m")))
+(register-definition-prefixes "face-remap" '("buffer-face-mode-" "face-" "internal-lisp-face-attributes" "text-scale-"))
+
+;;;***
+
+;;;### (autoloads nil "facemenu" "facemenu.el" (0 0 0 0))
+;;; Generated autoloads from facemenu.el
+ (autoload 'facemenu-menu "facemenu" nil nil 'keymap)
+
+(define-key global-map [C-down-mouse-2] 'facemenu-menu)
+
+(autoload 'list-colors-display "facemenu" "\
+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. Customize
+`list-colors-sort' to change the order in which colors are shown.
+Type `g' or \\[revert-buffer] after customizing `list-colors-sort'
+to redisplay colors in the new order.
+
+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.
+
+\(fn &optional LIST BUFFER-NAME CALLBACK)" t nil)
+
+(register-definition-prefixes "facemenu" '("facemenu-" "list-colors-"))
;;;***
@@ -12259,7 +12340,7 @@ FUNCTION must return an explanation when the test fails and
\(fn FUNCTION)" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "faceup" '("faceup-")))
+(register-definition-prefixes "faceup" '("faceup-"))
;;;***
@@ -12306,20 +12387,25 @@ internally by feedmail):
after-run (the queue has just been run, possibly sending messages)
WHAT-EVENT is used as a key into the table `feedmail-queue-reminder-alist'. If
-the associated value is a function, it is called without arguments and is expected
-to perform the reminder activity. You can supply your own reminder functions
-by redefining `feedmail-queue-reminder-alist'. If you don't want any reminders,
-you can set `feedmail-queue-reminder-alist' to nil.
+the associated value is a function, it is called without arguments and is
+expected to perform the reminder activity. You can supply your own reminder
+functions by redefining `feedmail-queue-reminder-alist'. If you don't want any
+reminders, you can set `feedmail-queue-reminder-alist' to nil.
\(fn &optional WHAT-EVENT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "feedmail" '("feedmail-")))
+(register-definition-prefixes "feedmail" '("feedmail-"))
;;;***
;;;### (autoloads nil "ffap" "ffap.el" (0 0 0 0))
;;; Generated autoloads from ffap.el
+(defvar ffap-file-finder 'find-file "\
+The command called by `find-file-at-point' to find a file.")
+
+(custom-autoload 'ffap-file-finder "ffap" t)
+
(autoload 'ffap-next "ffap" "\
Search buffer for next file or URL, and run ffap.
Optional argument BACK says to search backwards.
@@ -12375,7 +12461,7 @@ This hook is intended to be put in `file-name-at-point-functions'." nil nil)
(autoload 'ffap-bindings "ffap" "\
Evaluate the forms in variable `ffap-bindings'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ffap" '("dired-at-point-" "ffap-" "find-file-literally-at-point")))
+(register-definition-prefixes "ffap" '("dired-at-point-" "ffap-" "find-file-literally-at-point"))
;;;***
@@ -12434,7 +12520,7 @@ the name is considered already unique; only the second substitution
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filecache" '("file-cache-")))
+(register-definition-prefixes "filecache" '("file-cache-"))
;;;***
@@ -12461,20 +12547,20 @@ operating on the next file and nil otherwise.
(autoload 'fileloop-initialize-replace "fileloop" "\
Initialize a new round of query&replace on several files.
- FROM is a regexp and TO is the replacement to use.
- FILES describes the files, as in `fileloop-initialize'.
- CASE-FOLD can be t, nil, or `default':
- if it is nil, matching of FROM is case-sensitive.
- if it is t, matching of FROM is case-insensitive, except
- when `search-upper-case' is non-nil and FROM includes
- upper-case letters.
- if it is `default', the function uses the value of
- `case-fold-search' instead.
- DELIMITED if non-nil means replace only word-delimited matches.
+FROM is a regexp and TO is the replacement to use.
+FILES describes the files, as in `fileloop-initialize'.
+CASE-FOLD can be t, nil, or `default':
+ if it is nil, matching of FROM is case-sensitive.
+ if it is t, matching of FROM is case-insensitive, except
+ when `search-upper-case' is non-nil and FROM includes
+ upper-case letters.
+ if it is `default', the function uses the value of
+ `case-fold-search' instead.
+DELIMITED if non-nil means replace only word-delimited matches.
\(fn FROM TO FILES CASE-FOLD &optional DELIMITED)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fileloop" '("fileloop-")))
+(register-definition-prefixes "fileloop" '("fileloop-"))
;;;***
@@ -12488,7 +12574,9 @@ Otherwise, signal a `file-notify-error'.
\(fn OBJECT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filenotify" '("file-notify-")))
+(function-put 'file-notify-handle-event 'completion-predicate #'ignore)
+
+(register-definition-prefixes "filenotify" '("file-notify-"))
;;;***
@@ -12594,7 +12682,13 @@ Execute BODY, and unwind connection-local variables.
\(fn &rest BODY)" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "hack-connection-local-variables" "modify-" "read-file-local-variable")))
+(autoload 'path-separator "files-x" "\
+The connection-local value of `path-separator'." nil nil)
+
+(autoload 'null-device "files-x" "\
+The connection-local value of `null-device'." nil nil)
+
+(register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "hack-connection-local-variables" "modify-" "read-file-local-variable"))
;;;***
@@ -12605,7 +12699,7 @@ Execute BODY, and unwind connection-local variables.
Filesets initialization.
Set up hooks, load the cache file -- if existing -- and build the menu." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filesets" '("filesets-")))
+(register-definition-prefixes "filesets" '("filesets-"))
;;;***
@@ -12627,7 +12721,7 @@ result is a string that should be ready for the command line.
\(fn &rest SUBFINDS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-cmd" '("find-")))
+(register-definition-prefixes "find-cmd" '("find-"))
;;;***
@@ -12643,6 +12737,9 @@ The command run (after changing into DIR) is essentially
except that the car of the variable `find-ls-option' specifies what to
use in place of \"-ls\" as the final argument.
+Collect output in the \"*Find*\" buffer. To kill the job before
+it finishes, type \\[kill-find].
+
\(fn DIR ARGS)" t nil)
(autoload 'find-name-dired "find-dired" "\
@@ -12669,14 +12766,14 @@ specifies what to use in place of \"-ls\" as the final argument.
\(fn DIR REGEXP)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-dired" '("find-" "kill-find" "lookfor-dired")))
+(register-definition-prefixes "find-dired" '("find-" "kill-find" "lookfor-dired"))
;;;***
;;;### (autoloads nil "find-file" "find-file.el" (0 0 0 0))
;;; 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)))) "\
+(defvar ff-special-constructs `((,(purecopy "^#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") \, (lambda nil (match-string 2)))) "\
List of special constructs recognized by `ff-treat-as-special'.
Each element, tried in order, has the form (REGEXP . EXTRACT).
If REGEXP matches the current line (from the beginning of the line),
@@ -12694,7 +12791,7 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in another window.
\(fn &optional IN-OTHER-WINDOW)" t nil)
-(defalias 'ff-find-related-file 'ff-find-other-file)
+(defalias 'ff-find-related-file #'ff-find-other-file)
(autoload 'ff-find-other-file "find-file" "\
Find the header or source file corresponding to this file.
@@ -12703,6 +12800,10 @@ Being on a `#include' line pulls in that file.
If optional IN-OTHER-WINDOW is non-nil, find the file in the other window.
If optional IGNORE-INCLUDE is non-nil, ignore being on `#include' lines.
+If optional EVENT is non-nil (default `last-nonmenu-event', move
+point to the end position of that event before calling the
+various ff-* hooks.
+
Variables of interest include:
- `ff-case-fold-search'
@@ -12749,19 +12850,18 @@ Variables of interest include:
- `ff-file-created-hook'
List of functions to be called if the other file has been created.
-\(fn &optional IN-OTHER-WINDOW IGNORE-INCLUDE)" t nil)
+\(fn &optional IN-OTHER-WINDOW IGNORE-INCLUDE EVENT)" t nil)
-(autoload 'ff-mouse-find-other-file "find-file" "\
-Visit the file you click on.
+(define-obsolete-function-alias 'ff-mouse-find-other-file #'ff-find-other-file "28.1")
-\(fn EVENT)" t nil)
+(define-obsolete-function-alias 'ff-mouse-find-other-file-other-window #'ff-find-other-file-other-window "28.1")
-(autoload 'ff-mouse-find-other-file-other-window "find-file" "\
-Visit the file you click on in another window.
+(autoload 'ff-find-other-file-other-window "find-file" "\
+Visit the file you point at in another window.
\(fn EVENT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-file" '("cc-" "ff-" "modula2-other-file-alist")))
+(register-definition-prefixes "find-file" '("cc-" "ff-" "modula2-other-file-alist"))
;;;***
@@ -12776,6 +12876,13 @@ Interactively, prompt for LIBRARY using the one at or near point.
\(fn LIBRARY)" t nil)
+(autoload 'read-library-name "find-func" "\
+Read and return a library name, defaulting to the one near point.
+
+A library name is the filename of an Emacs Lisp library located
+in a directory under `load-path' (or `find-function-source-path',
+if non-nil)." nil nil)
+
(autoload 'find-library-other-window "find-func" "\
Find the Emacs Lisp source of LIBRARY in another window.
@@ -12943,7 +13050,7 @@ Find directly the variable at point in the other window." t nil)
(autoload 'find-function-setup-keys "find-func" "\
Define some key bindings for the find-function family of functions." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-" "read-library-name")))
+(register-definition-prefixes "find-func" '("find-"))
;;;***
@@ -12965,13 +13072,12 @@ Change the filter on a `find-lisp-find-dired' buffer to REGEXP.
\(fn REGEXP)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-lisp" '("find-lisp-")))
+(register-definition-prefixes "find-lisp" '("find-lisp-"))
;;;***
;;;### (autoloads nil "finder" "finder.el" (0 0 0 0))
;;; Generated autoloads from finder.el
-(push (purecopy '(finder 1 0)) package--builtin-versions)
(autoload 'finder-list-keywords "finder" "\
Display descriptions of the keywords in the Finder buffer." t nil)
@@ -12985,7 +13091,7 @@ FILE should be in a form suitable for passing to `locate-library'.
(autoload 'finder-by-keyword "finder" "\
Find packages matching a given keyword." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "finder" '("finder-" "generated-finder-keywords-file")))
+(register-definition-prefixes "finder" '("finder-" "generated-finder-keywords-file"))
;;;***
@@ -13008,7 +13114,7 @@ to get the effect of a C-q.
\(fn &rest LOSING-TERMINAL-TYPES)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flow-ctrl" '("flow-control-c-")))
+(register-definition-prefixes "flow-ctrl" '("flow-control-c-"))
;;;***
@@ -13029,18 +13135,18 @@ lines.
\(fn &optional BUFFER DELETE-SPACE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flow-fill" '("fill-flowed-")))
+(register-definition-prefixes "flow-fill" '("fill-flowed-"))
;;;***
;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0))
;;; Generated autoloads from progmodes/flymake.el
-(push (purecopy '(flymake 1 0 8)) package--builtin-versions)
+(push (purecopy '(flymake 1 1 1)) package--builtin-versions)
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
LEVEL is passed to `display-warning', which is used to display
-the warning. If this form is included in a byte-compiled file,
+the warning. If this form is included in a file,
the generated warning contains an indication of the file that
generated it.
@@ -13072,17 +13178,26 @@ diagnostics at BEG.
(autoload 'flymake-diag-region "flymake" "\
Compute BUFFER's region (BEG . END) corresponding to LINE and COL.
If COL is nil, return a region just for LINE. Return nil if the
-region is invalid.
+region is invalid. This function saves match data.
\(fn BUFFER LINE &optional COL)" nil nil)
(autoload 'flymake-mode "flymake" "\
Toggle Flymake mode on or off.
-If called interactively, enable Flymake mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Flymake
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `flymake-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Flymake is an Emacs minor mode for on-the-fly syntax checking.
Flymake collects diagnostic information from multiple sources,
@@ -13122,7 +13237,7 @@ Turn Flymake mode on." nil nil)
(autoload 'flymake-mode-off "flymake" "\
Turn Flymake mode off." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake" '("flymake-")))
+(register-definition-prefixes "flymake" '("flymake-"))
;;;***
@@ -13138,7 +13253,7 @@ REPORT-FN is Flymake's callback.
\(fn REPORT-FN &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-cc" '("flymake-cc-")))
+(register-definition-prefixes "flymake-cc" '("flymake-cc-"))
;;;***
@@ -13147,7 +13262,7 @@ REPORT-FN is Flymake's callback.
;;; Generated autoloads from progmodes/flymake-proc.el
(push (purecopy '(flymake-proc 1 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flymake-proc" '("flymake-proc-")))
+(register-definition-prefixes "flymake-proc" '("flymake-proc-"))
;;;***
@@ -13161,10 +13276,19 @@ Turn on `flyspell-mode' for comments and strings." t nil)
(autoload 'flyspell-mode "flyspell" "\
Toggle on-the-fly spell checking (Flyspell mode).
-If called interactively, enable Flyspell mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Flyspell
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `flyspell-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Flyspell mode is a buffer-local minor mode. When enabled, it
spawns a single Ispell process and checks each word. The default
@@ -13186,7 +13310,7 @@ invoking `ispell-change-dictionary'.
Consider using the `ispell-parser' to check your text. For instance
consider adding:
-\(add-hook \\='tex-mode-hook (function (lambda () (setq ispell-parser \\='tex))))
+\(add-hook \\='tex-mode-hook (lambda () (setq ispell-parser \\='tex)))
in your init file.
\\[flyspell-region] checks all words inside a region.
@@ -13214,7 +13338,7 @@ of a misspelled word removed when you've corrected it.
(autoload 'flyspell-buffer "flyspell" "\
Flyspell whole buffer." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "flyspell" '("flyspell-" "mail-mode-flyspell-verify" "make-flyspell-overlay" "sgml-mode-flyspell-verify" "tex")))
+(register-definition-prefixes "flyspell" '("flyspell-" "mail-mode-flyspell-verify" "make-flyspell-overlay" "sgml-mode-flyspell-verify" "tex"))
;;;***
@@ -13222,7 +13346,7 @@ Flyspell whole buffer." t nil)
;;; Generated autoloads from foldout.el
(push (purecopy '(foldout 1 10)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "foldout" '("foldout-")))
+(register-definition-prefixes "foldout" '("foldout-"))
;;;***
@@ -13238,10 +13362,19 @@ Turn off Follow mode. Please see the function `follow-mode'." nil nil)
(autoload 'follow-mode "follow" "\
Toggle Follow mode.
-If called interactively, enable Follow mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Follow
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `follow-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Follow mode is a minor mode that combines windows into one tall
virtual window. This is accomplished by two main techniques:
@@ -13344,7 +13477,7 @@ selected if the original window is the first one in the frame.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "follow" '("follow-")))
+(register-definition-prefixes "follow" '("follow-"))
;;;***
@@ -13352,21 +13485,29 @@ selected if the original window is the first one in the frame.
;;;;;; 0))
;;; Generated autoloads from international/fontset.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fontset" '("charset-script-alist" "create-" "fontset-" "generate-fontset-menu" "set" "standard-fontset-spec" "x-" "xlfd-")))
+(register-definition-prefixes "fontset" '("charset-script-alist" "create-" "fontset-" "generate-fontset-menu" "set" "standard-fontset-spec" "x-" "xlfd-"))
;;;***
;;;### (autoloads nil "footnote" "mail/footnote.el" (0 0 0 0))
;;; Generated autoloads from mail/footnote.el
-(push (purecopy '(footnote 0 19)) package--builtin-versions)
(autoload 'footnote-mode "footnote" "\
Toggle Footnote mode.
-If called interactively, enable Footnote mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Footnote
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `footnote-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Footnote mode is a buffer-local minor mode. If enabled, it
provides footnote support for `message-mode'. To get started,
@@ -13375,14 +13516,64 @@ play around with the following keys:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-")))
+(register-definition-prefixes "footnote" '("footnote-"))
;;;***
;;;### (autoloads nil "format-spec" "format-spec.el" (0 0 0 0))
;;; Generated autoloads from format-spec.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "format-spec" '("format-spec")))
+(autoload 'format-spec "format-spec" "\
+Return a string based on FORMAT and SPECIFICATION.
+FORMAT is a string containing `format'-like specs like \"su - %u %k\".
+SPECIFICATION is an alist mapping format specification characters
+to their substitutions.
+
+For instance:
+
+ (format-spec \"su - %u %l\"
+ \\=`((?u . ,(user-login-name))
+ (?l . \"ls\")))
+
+Each %-spec may contain optional flag, width, and precision
+modifiers, as follows:
+
+ %<flags><width><precision>character
+
+The following flags are allowed:
+
+* 0: Pad to the width, if given, with zeros instead of spaces.
+* -: Pad to the width, if given, on the right instead of the left.
+* <: Truncate to the width and precision, if given, on the left.
+* >: Truncate to the width and precision, if given, on the right.
+* ^: Convert to upper case.
+* _: Convert to lower case.
+
+The width and truncation modifiers behave like the corresponding
+ones in `format' when applied to %s.
+
+For example, \"%<010b\" means \"substitute into the output the
+value associated with ?b in SPECIFICATION, either padding it with
+leading zeros or truncating leading characters until it's ten
+characters wide\".
+
+Any text properties of FORMAT are copied to the result, with any
+text properties of a %-spec itself copied to its substitution.
+
+IGNORE-MISSING indicates how to handle %-spec characters not
+present in SPECIFICATION. If it is nil or omitted, emit an
+error; if it is the symbol `ignore', leave those %-specs verbatim
+in the result, including their text properties, if any; if it is
+the symbol `delete', remove those %-specs from the result;
+otherwise do the same as for the symbol `ignore', but also leave
+any occurrences of \"%%\" in FORMAT verbatim in the result.
+
+If SPLIT, instead of returning a single string, a list of strings
+is returned, where each format spec is its own element.
+
+\(fn FORMAT SPECIFICATION &optional IGNORE-MISSING SPLIT)" nil nil)
+
+(register-definition-prefixes "format-spec" '("format-spec-"))
;;;***
@@ -13420,7 +13611,7 @@ Visit a file in Forms mode in other window.
\(fn FN)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "forms" '("forms-")))
+(register-definition-prefixes "forms" '("forms-"))
;;;***
@@ -13499,7 +13690,7 @@ with no args, if that value is non-nil.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fortran" '("fortran-")))
+(register-definition-prefixes "fortran" '("fortran-"))
;;;***
@@ -13556,7 +13747,7 @@ and choose the directory as the fortune-file.
\(fn &optional FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fortune" '("fortune-")))
+(register-definition-prefixes "fortune" '("fortune-"))
;;;***
@@ -13567,7 +13758,7 @@ and choose the directory as the fortune-file.
Minimum set of parameters to filter for live (on-session) framesets.
DO NOT MODIFY. See `frameset-filter-alist' for a full description.")
-(defvar frameset-persistent-filter-alist (nconc '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\
+(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\
Parameters to filter for persistent framesets.
DO NOT MODIFY. See `frameset-filter-alist' for a full description.")
@@ -13732,7 +13923,7 @@ Interactively, reads the register using `register-read-with-preview'.
\(fn REGISTER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "frameset" '("frameset-")))
+(register-definition-prefixes "frameset" '("frameset-"))
;;;***
@@ -13741,22 +13932,21 @@ Interactively, reads the register using `register-read-with-preview'.
(unless (fboundp 'define-fringe-bitmap) (defun define-fringe-bitmap (_bitmap _bits &optional _height _width _align) "Define fringe bitmap BITMAP from BITS of size HEIGHT x WIDTH.\nBITMAP is a symbol identifying the new fringe bitmap.\nBITS is either a string or a vector of integers.\nHEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS.\nWIDTH must be an integer between 1 and 16, or nil which defaults to 8.\nOptional fifth arg ALIGN may be one of ‘top’, ‘center’, or ‘bottom’,\nindicating the positioning of the bitmap relative to the rows where it\nis used; the default is to center the bitmap. Fifth arg may also be a\nlist (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap\nshould be repeated.\nIf BITMAP already exists, the existing definition is replaced."))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fringe" '("fringe-" "set-fringe-")))
+(register-definition-prefixes "fringe" '("fringe-" "set-fringe-"))
;;;***
;;;### (autoloads nil "gamegrid" "play/gamegrid.el" (0 0 0 0))
;;; Generated autoloads from play/gamegrid.el
-(push (purecopy '(gamegrid 1 2)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gamegrid" '("gamegrid-")))
+(register-definition-prefixes "gamegrid" '("gamegrid-"))
;;;***
;;;### (autoloads nil "gametree" "play/gametree.el" (0 0 0 0))
;;; Generated autoloads from play/gametree.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gametree" '("gametree-")))
+(register-definition-prefixes "gametree" '("gametree-"))
;;;***
@@ -13778,10 +13968,19 @@ 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).
-If called interactively, enable Gdb-Enable-Debug mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Gdb-Enable-Debug mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'gdb-enable-debug)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -13845,7 +14044,7 @@ detailed description of this mode.
\(fn COMMAND-LINE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gdb-mi" '("breakpoint" "def-gdb-" "gdb" "gud-" "hollow-right-triangle" "nil")))
+(register-definition-prefixes "gdb-mi" '("breakpoint" "def-gdb-" "gdb" "gud-" "hollow-right-triangle" "nil"))
;;;***
@@ -13853,7 +14052,7 @@ detailed description of this mode.
;;;;;; 0 0))
;;; Generated autoloads from emacs-lisp/generator.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generator" '("cps-" "iter-")))
+(register-definition-prefixes "generator" '("cps-" "iter-"))
;;;***
@@ -13868,6 +14067,10 @@ instead (which see).")
(autoload 'define-generic-mode "generic" "\
Create a new generic mode MODE.
+A \"generic\" mode is a simple major mode with basic support for
+comment syntax and Font Lock mode, but otherwise does not have
+any special keystrokes or functionality available.
+
MODE is the name of the command for the generic mode; don't quote it.
The optional DOCSTRING is the documentation for the mode command. If
you do not supply it, `define-generic-mode' uses a default
@@ -13935,14 +14138,14 @@ regular expression that can be used as an element of
(make-obsolete 'generic-make-keywords-list 'regexp-opt '"24.4")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic" '("generic-")))
+(register-definition-prefixes "generic" '("generic-"))
;;;***
;;;### (autoloads nil "generic-x" "generic-x.el" (0 0 0 0))
;;; Generated autoloads from generic-x.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "generic-x" '("default-generic-mode" "generic-")))
+(register-definition-prefixes "generic-x" '("default-generic-mode" "generic-"))
;;;***
@@ -13952,17 +14155,26 @@ regular expression that can be used as an element of
(autoload 'glasses-mode "glasses" "\
Minor mode for making identifiers likeThis readable.
-If called interactively, enable Glasses mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Glasses
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `glasses-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When this mode is active, it tries to add virtual
separators (like underscores) at places they belong to.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "glasses" '("glasses-")))
+(register-definition-prefixes "glasses" '("glasses-"))
;;;***
@@ -14018,18 +14230,22 @@ DEFAULT-MAP specifies the default key map for ICON-LIST.
\(fn ICON-LIST ZAP-LIST DEFAULT-MAP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gmm-utils" '("defun-gmm" "gmm-")))
+(register-definition-prefixes "gmm-utils" '("defun-gmm" "gmm-"))
;;;***
;;;### (autoloads nil "gnus" "gnus/gnus.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus.el
(push (purecopy '(gnus 5 13)) package--builtin-versions)
-(when (fboundp 'custom-autoload)
- (custom-autoload 'gnus-select-method "gnus"))
+(custom-autoload 'gnus-select-method "gnus")
+
+(autoload 'gnus-child-no-server "gnus" "\
+Read network news as a child, without connecting to the local server.
+
+\(fn &optional ARG)" t nil)
(autoload 'gnus-slave-no-server "gnus" "\
-Read network news as a slave, without connecting to the local server.
+Read network news as a child, without connecting to the local server.
\(fn &optional ARG)" t nil)
@@ -14042,10 +14258,15 @@ an NNTP server to use.
As opposed to `gnus', this command will not connect to the local
server.
-\(fn &optional ARG SLAVE)" t nil)
+\(fn &optional ARG CHILD)" t nil)
+
+(autoload 'gnus-child "gnus" "\
+Read news as a child.
+
+\(fn &optional ARG)" t nil)
(autoload 'gnus-slave "gnus" "\
-Read news as a slave.
+Read news as a child.
\(fn &optional ARG)" t nil)
@@ -14068,9 +14289,9 @@ 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.
-\(fn &optional ARG DONT-CONNECT SLAVE)" t nil)
+\(fn &optional ARG DONT-CONNECT CHILD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus" '("gnus-")))
+(register-definition-prefixes "gnus" '("gnus-"))
;;;***
@@ -14083,8 +14304,13 @@ Start Gnus unplugged." t nil)
(autoload 'gnus-plugged "gnus-agent" "\
Start Gnus plugged." t nil)
+(autoload 'gnus-child-unplugged "gnus-agent" "\
+Read news as a child unplugged.
+
+\(fn &optional ARG)" t nil)
+
(autoload 'gnus-slave-unplugged "gnus-agent" "\
-Read news as a slave unplugged.
+Read news as a child unplugged.
\(fn &optional ARG)" t nil)
@@ -14148,7 +14374,7 @@ CLEAN is obsolete and ignored.
\(fn &optional CLEAN REREAD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-agent" '("gnus-")))
+(register-definition-prefixes "gnus-agent" '("gnus-"))
;;;***
@@ -14158,21 +14384,21 @@ CLEAN is obsolete and ignored.
(autoload 'gnus-article-prepare-display "gnus-art" "\
Make the current buffer look like a nice article." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-art" '("article-" "gnus-")))
+(register-definition-prefixes "gnus-art" '("article-" "gnus-"))
;;;***
;;;### (autoloads nil "gnus-async" "gnus/gnus-async.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-async.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-async" '("gnus-")))
+(register-definition-prefixes "gnus-async" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-bcklg" "gnus/gnus-bcklg.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-bcklg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-bcklg" '("gnus-backlog-")))
+(register-definition-prefixes "gnus-bcklg" '("gnus-backlog-"))
;;;***
@@ -14181,7 +14407,7 @@ Make the current buffer look like a nice article." nil nil)
;;; Generated autoloads from gnus/gnus-bookmark.el
(autoload 'gnus-bookmark-set "gnus-bookmark" "\
-Set a bookmark for this article." t nil)
+Set a bookmark for this article." '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-bookmark-jump "gnus-bookmark" "\
Jump to a Gnus bookmark (BMK-NAME).
@@ -14194,7 +14420,7 @@ The list is displayed in a buffer named `*Gnus Bookmark List*'.
The leftmost column displays a D if the bookmark is flagged for
deletion, or > if it is flagged for displaying." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-bookmark" '("gnus-bookmark-")))
+(register-definition-prefixes "gnus-bookmark" '("gnus-bookmark-"))
;;;***
@@ -14235,28 +14461,35 @@ supported.
\(fn GROUP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cache" '("gnus-")))
+(register-definition-prefixes "gnus-cache" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-cite" "gnus/gnus-cite.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-cite.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cite" '("gnus-" "turn-o")))
+(register-definition-prefixes "gnus-cite" '("gnus-" "turn-o"))
;;;***
;;;### (autoloads nil "gnus-cloud" "gnus/gnus-cloud.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-cloud.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cloud" '("gnus-cloud-")))
+(register-definition-prefixes "gnus-cloud" '("gnus-cloud-"))
;;;***
;;;### (autoloads nil "gnus-cus" "gnus/gnus-cus.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-cus.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-cus" '("category-fields" "gnus-")))
+(register-definition-prefixes "gnus-cus" '("category-fields" "gnus-"))
+
+;;;***
+
+;;;### (autoloads nil "gnus-dbus" "gnus/gnus-dbus.el" (0 0 0 0))
+;;; Generated autoloads from gnus/gnus-dbus.el
+
+(register-definition-prefixes "gnus-dbus" '("gnus-dbus-"))
;;;***
@@ -14276,7 +14509,11 @@ DELAY is a string, giving the length of the time. Possible values are:
* hh:mm for a specific time. Use 24h format. If it is later than this
time, then the deadline is tomorrow, else today.
-\(fn DELAY)" t nil)
+The value of `message-draft-headers' determines which headers are
+generated when the article is delayed. Remaining headers are
+generated when the article is sent.
+
+\(fn DELAY)" '(message-mode) nil)
(autoload 'gnus-delay-send-queue "gnus-delay" "\
Send all the delayed messages that are due now." t nil)
@@ -14291,14 +14528,14 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil.
\(fn &optional NO-KEYMAP NO-CHECK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-delay" '("gnus-delay-")))
+(register-definition-prefixes "gnus-delay" '("gnus-delay-"))
;;;***
;;;### (autoloads nil "gnus-demon" "gnus/gnus-demon.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-demon.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-demon" '("gnus-")))
+(register-definition-prefixes "gnus-demon" '("gnus-"))
;;;***
@@ -14315,7 +14552,7 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil.
\(fn HEADER)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-diary" '("gnus-")))
+(register-definition-prefixes "gnus-diary" '("gnus-"))
;;;***
@@ -14325,7 +14562,7 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil.
(autoload 'turn-on-gnus-dired-mode "gnus-dired" "\
Convenience method to turn on gnus-dired-mode." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-dired" '("gnus-dired-")))
+(register-definition-prefixes "gnus-dired" '("gnus-dired-"))
;;;***
@@ -14335,21 +14572,21 @@ Convenience method to turn on gnus-dired-mode." t nil)
(autoload 'gnus-draft-reminder "gnus-draft" "\
Reminder user if there are unsent drafts." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-draft" '("gnus-")))
+(register-definition-prefixes "gnus-draft" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-dup" "gnus/gnus-dup.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-dup.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-dup" '("gnus-")))
+(register-definition-prefixes "gnus-dup" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-eform" "gnus/gnus-eform.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-eform.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-eform" '("gnus-edit-form")))
+(register-definition-prefixes "gnus-eform" '("gnus-edit-form"))
;;;***
@@ -14408,7 +14645,7 @@ Files matching `gnus-face-omit-files' are not considered." t nil)
(autoload 'gnus-insert-random-face-header "gnus-fun" "\
Insert a random Face header from `gnus-face-directory'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-fun" '("gnus-")))
+(register-definition-prefixes "gnus-fun" '("gnus-"))
;;;***
@@ -14420,15 +14657,15 @@ Insert a random Face header from `gnus-face-directory'." nil nil)
Display gravatar in the From header.
If gravatar is already displayed, remove it.
-\(fn &optional FORCE)" t nil)
+\(fn &optional FORCE)" '(gnus-article-mode gnus-summary-mode) 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)
+\(fn &optional FORCE)" '(gnus-article-mode gnus-summary-mode) nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-gravatar" '("gnus-gravatar-")))
+(register-definition-prefixes "gnus-gravatar" '("gnus-gravatar-"))
;;;***
@@ -14454,7 +14691,7 @@ The arguments have the same meaning as those of
\(fn IDS &optional WINDOW-CONF)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-group" '("gnus-")))
+(register-definition-prefixes "gnus-group" '("gnus-"))
;;;***
@@ -14471,7 +14708,7 @@ The arguments have the same meaning as those of
\(fn SUMMARY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-html" '("gnus-")))
+(register-definition-prefixes "gnus-html" '("gnus-"))
;;;***
@@ -14484,14 +14721,14 @@ The arguments have the same meaning as those of
\(fn HANDLE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-icalendar" '("gnus-icalendar")))
+(register-definition-prefixes "gnus-icalendar" '("gnus-icalendar"))
;;;***
;;;### (autoloads nil "gnus-int" "gnus/gnus-int.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-int.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-int" '("gnus-")))
+(register-definition-prefixes "gnus-int" '("gnus-"))
;;;***
@@ -14504,21 +14741,21 @@ The arguments have the same meaning as those of
Run batched scoring.
Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-kill" '("gnus-")))
+(register-definition-prefixes "gnus-kill" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-logic" "gnus/gnus-logic.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-logic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-logic" '("gnus-")))
+(register-definition-prefixes "gnus-logic" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-mh" "gnus/gnus-mh.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-mh.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-mh" '("gnus-")))
+(register-definition-prefixes "gnus-mh" '("gnus-"))
;;;***
@@ -14536,16 +14773,25 @@ If FORCE is non-nil, replace the old ones.
(autoload 'gnus-mailing-list-mode "gnus-ml" "\
Minor mode for providing mailing-list commands.
-If called interactively, enable Gnus-Mailing-List mode if ARG is
-positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and
-toggle it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Gnus-Mailing-List mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `gnus-mailing-list-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\{gnus-mailing-list-mode-map}
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-ml" '("gnus-mailing-list-")))
+(register-definition-prefixes "gnus-ml" '("gnus-mailing-list-"))
;;;***
@@ -14644,7 +14890,7 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
\(fn &optional GROUPS NO-CROSSPOST CATCH-ALL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-mlspl" '("gnus-group-split-")))
+(register-definition-prefixes "gnus-mlspl" '("gnus-group-split-"))
;;;***
@@ -14672,7 +14918,7 @@ Like `message-reply'.
(define-mail-user-agent 'gnus-user-agent 'gnus-msg-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-msg" '("gnus-")))
+(register-definition-prefixes "gnus-msg" '("gnus-"))
;;;***
@@ -14689,7 +14935,7 @@ notification using `notifications-notify' for it.
This is typically a function to add in
`gnus-after-getting-new-news-hook'" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-notifications" '("gnus-notifications-")))
+(register-definition-prefixes "gnus-notifications" '("gnus-notifications-"))
;;;***
@@ -14698,17 +14944,17 @@ This is typically a function to add in
(autoload 'gnus-treat-from-picon "gnus-picon" "\
Display picons in the From header.
-If picons are already displayed, remove them." t nil)
+If picons are already displayed, remove them." '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-treat-mail-picon "gnus-picon" "\
Display picons in the Cc and To headers.
-If picons are already displayed, remove them." t nil)
+If picons are already displayed, remove them." '(gnus-article-mode gnus-summary-mode) nil)
(autoload 'gnus-treat-newsgroups-picon "gnus-picon" "\
Display picons in the Newsgroups and Followup-To headers.
-If picons are already displayed, remove them." t nil)
+If picons are already displayed, remove them." '(gnus-article-mode gnus-summary-mode) nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-picon" '("gnus-picon-")))
+(register-definition-prefixes "gnus-picon" '("gnus-picon-"))
;;;***
@@ -14740,6 +14986,8 @@ Both lists have to be sorted over <.
\(fn LIST1 LIST2)" nil nil)
+(make-obsolete 'gnus-intersection 'seq-intersection '"28.1")
+
(autoload 'gnus-sorted-intersection "gnus-range" "\
Return intersection of LIST1 and LIST2.
LIST1 and LIST2 have to be sorted over <.
@@ -14777,7 +15025,7 @@ Add NUM into sorted LIST by side effect.
\(fn LIST NUM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-range" '("gnus-")))
+(register-definition-prefixes "gnus-range" '("gnus-"))
;;;***
@@ -14788,7 +15036,7 @@ Add NUM into sorted LIST by side effect.
(autoload 'gnus-registry-initialize "gnus-registry" "\
Initialize the Gnus registry." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-registry" '("gnus-")))
+(register-definition-prefixes "gnus-registry" '("gnus-"))
;;;***
@@ -14796,21 +15044,29 @@ Initialize the Gnus registry." t nil)
;;;;;; 0 0))
;;; Generated autoloads from gnus/gnus-rfc1843.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-rfc1843" '("rfc1843-")))
+(register-definition-prefixes "gnus-rfc1843" '("rfc1843-"))
;;;***
;;;### (autoloads nil "gnus-salt" "gnus/gnus-salt.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-salt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-salt" '("gnus-")))
+(register-definition-prefixes "gnus-salt" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-score" "gnus/gnus-score.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-score.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-score" '("gnus-")))
+(register-definition-prefixes "gnus-score" '("gnus-"))
+
+;;;***
+
+;;;### (autoloads nil "gnus-search" "gnus/gnus-search.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from gnus/gnus-search.el
+
+(register-definition-prefixes "gnus-search" '("gnus-search-"))
;;;***
@@ -14830,9 +15086,9 @@ between gnus-sieve-region-start and gnus-sieve-region-end with
\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost).
See the documentation for these variables and functions for details." t nil)
-(autoload 'gnus-sieve-article-add-rule "gnus-sieve" nil t nil)
+(autoload 'gnus-sieve-article-add-rule "gnus-sieve" nil '(gnus-article-mode gnus-summary-mode) nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-sieve" '("gnus-sieve-")))
+(register-definition-prefixes "gnus-sieve" '("gnus-sieve-"))
;;;***
@@ -14844,14 +15100,14 @@ Update the format specification near point.
\(fn VAR)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-spec" '("gnus-")))
+(register-definition-prefixes "gnus-spec" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-srvr" "gnus/gnus-srvr.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-srvr.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-srvr" '("gnus-")))
+(register-definition-prefixes "gnus-srvr" '("gnus-"))
;;;***
@@ -14863,7 +15119,7 @@ Declare back end NAME with ABILITIES as a Gnus back end.
\(fn NAME &rest ABILITIES)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-start" '("gnus-")))
+(register-definition-prefixes "gnus-start" '("gnus-"))
;;;***
@@ -14876,42 +15132,42 @@ BOOKMARK is a bookmark name or a bookmark record.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-sum" '("gnus-")))
+(register-definition-prefixes "gnus-sum" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-topic" "gnus/gnus-topic.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-topic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-topic" '("gnus-")))
+(register-definition-prefixes "gnus-topic" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-undo" "gnus/gnus-undo.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-undo.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-undo" '("gnus-")))
+(register-definition-prefixes "gnus-undo" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-util" "gnus/gnus-util.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-util" '("gnus-")))
+(register-definition-prefixes "gnus-util" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-uu" "gnus/gnus-uu.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-uu.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-uu" '("gnus-")))
+(register-definition-prefixes "gnus-uu" '("gnus-"))
;;;***
;;;### (autoloads nil "gnus-vm" "gnus/gnus-vm.el" (0 0 0 0))
;;; Generated autoloads from gnus/gnus-vm.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-vm" '("gnus-")))
+(register-definition-prefixes "gnus-vm" '("gnus-"))
;;;***
@@ -14923,14 +15179,14 @@ Add the window configuration CONF to `gnus-buffer-configuration'.
\(fn CONF)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-win" '("gnus-")))
+(register-definition-prefixes "gnus-win" '("gnus-"))
;;;***
;;;### (autoloads nil "gnutls" "net/gnutls.el" (0 0 0 0))
;;; Generated autoloads from net/gnutls.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnutls" '("gnutls-" "open-gnutls-stream")))
+(register-definition-prefixes "gnutls" '("gnutls-" "open-gnutls-stream"))
;;;***
@@ -14958,7 +15214,7 @@ Use \\[describe-mode] for more info.
\(fn &optional N M)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gomoku" '("gomoku-")))
+(register-definition-prefixes "gomoku" '("gomoku-"))
;;;***
@@ -14987,24 +15243,67 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
(autoload 'goto-address-mode "goto-addr" "\
Minor mode to buttonize URLs and e-mail addresses in the current buffer.
-If called interactively, enable Goto-Address mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Goto-Address mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `goto-address-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
+(put 'global-goto-address-mode 'globalized-minor-mode t)
+
+(defvar global-goto-address-mode nil "\
+Non-nil if Global Goto-Address mode is enabled.
+See the `global-goto-address-mode' command
+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 `global-goto-address-mode'.")
+
+(custom-autoload 'global-goto-address-mode "goto-addr" nil)
+
+(autoload 'global-goto-address-mode "goto-addr" "\
+Toggle Goto-Address mode in all buffers.
+With prefix ARG, enable Global Goto-Address mode if ARG is positive;
+otherwise, disable it. If called from Lisp, enable the mode if ARG
+is omitted or nil.
+
+Goto-Address mode is enabled in all buffers where
+`goto-addr-mode--turn-on' would do it.
+
+See `goto-address-mode' for more information on Goto-Address mode.
\(fn &optional ARG)" t nil)
(autoload 'goto-address-prog-mode "goto-addr" "\
Like `goto-address-mode', but only for comments and strings.
-If called interactively, enable Goto-Address-Prog mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Goto-Address-Prog mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `goto-address-prog-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "goto-addr" '("goto-address-")))
+(register-definition-prefixes "goto-addr" '("goto-addr"))
;;;***
@@ -15026,7 +15325,7 @@ retrieval failed.
\(fn MAIL-ADDRESS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gravatar" '("gravatar-")))
+(register-definition-prefixes "gravatar" '("gravatar-"))
;;;***
@@ -15054,7 +15353,12 @@ by `grep-compute-defaults'; to change the default value, use
The default find command for \\[grep-find].
In interactive usage, the actual value of this variable is set up
by `grep-compute-defaults'; to change the default value, use
-\\[customize] or call the function `grep-apply-setting'.")
+\\[customize] or call the function `grep-apply-setting'.
+
+This variable can either be a string, or a cons of the
+form (COMMAND . POSITION). In the latter case, COMMAND will be
+used as the default command, and point will be placed at POSITION
+for easier editing.")
(custom-autoload 'grep-find-command "grep" nil)
@@ -15063,7 +15367,7 @@ List of hook functions run by `grep-process-setup' (see `run-hooks').")
(custom-autoload 'grep-setup-hook "grep" t)
-(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^\0\n]+\\)\\(?3:\0\\)\\(?2:[0-9]+\\):" "\\|" "\\(?1:" "\\(?:[a-zA-Z]:\\)?" "[^\n:]+?[^\n/:]\\):[\11 ]*\\(?2:[1-9][0-9]*\\)[\11 ]*:" "\\)") 1 2 (,(lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face))) (when mbeg (- mbeg beg))))) \, (lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face)) (mend (and mbeg (next-single-property-change mbeg 'font-lock-face nil end)))) (when mend (- mend beg)))))) nil nil (3 '(face nil display ":"))) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "\
+(defconst grep-regexp-alist `((,(concat "^\\(?:" "\\(?1:[^\0\n]+\\)\\(?3:\0\\)\\(?2:[0-9]+\\):" "\\|" "\\(?1:" "\\(?:[a-zA-Z]:\\)?" "[^\n:]+?[^\n/:]\\):[\11 ]*\\(?2:[1-9][0-9]*\\)[\11 ]*:" "\\)") 1 2 (,(lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face))) (when mbeg (- mbeg beg))))) \, (lambda nil (when grep-highlight-matches (let* ((beg (match-end 0)) (end (save-excursion (goto-char beg) (line-end-position))) (mbeg (text-property-any beg end 'font-lock-face grep-match-face)) (mend (and mbeg (next-single-property-change mbeg 'font-lock-face nil end)))) (when mend (- mend beg 1)))))) nil nil (3 '(face nil display ":"))) ("^Binary file \\(.+\\) matches" 1 nil nil 0 1)) "\
Regexp used to match grep hits.
See `compilation-error-regexp-alist' for format details.")
@@ -15214,14 +15518,14 @@ command before it's run.
(defalias 'rzgrep 'zrgrep)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-")))
+(register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-"))
;;;***
;;;### (autoloads nil "gssapi" "gnus/gssapi.el" (0 0 0 0))
;;; Generated autoloads from gnus/gssapi.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gssapi" '("gssapi-program" "open-gssapi-stream")))
+(register-definition-prefixes "gssapi" '("gssapi-program" "open-gssapi-stream"))
;;;***
@@ -15273,7 +15577,7 @@ and source-file directory for your debugger.
\(fn COMMAND-LINE)" t nil)
(autoload 'pdb "gud" "\
-Run COMMAND-LINE in the `*gud-FILE*' buffer.
+Run COMMAND-LINE in the `*gud-FILE*' buffer to debug Python programs.
COMMAND-LINE should include the pdb executable
name (`gud-pdb-command-name') and the file to be debugged.
@@ -15326,14 +15630,23 @@ or call the function `gud-tooltip-mode'.")
(autoload 'gud-tooltip-mode "gud" "\
Toggle the display of GUD tooltips.
-If called interactively, enable Gud-Tooltip mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Gud-Tooltip mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'gud-tooltip-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gud" '("gdb-" "gud-")))
+(register-definition-prefixes "gud" '("gdb-" "gud-"))
;;;***
@@ -15382,9 +15695,15 @@ arguments as NAME. DO is a function as defined in `gv-get'.
\(fn SYMBOL NAME ARGS HANDLER &optional FIX)" nil nil)
-(or (assq 'gv-expander defun-declarations-alist) (let ((x `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)))) (push x macro-declarations-alist) (push x defun-declarations-alist)))
+(defsubst gv--expander-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-expander args))
+
+(defsubst gv--setter-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-setter args))
+
+(or (assq 'gv-expander defun-declarations-alist) (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist)))
-(or (assq 'gv-setter defun-declarations-alist) (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) defun-declarations-alist))
+(or (assq 'gv-setter defun-declarations-alist) (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist))
+
+(let ((spec (get 'compiler-macro 'edebug-declaration-spec))) (put 'gv-expander 'edebug-declaration-spec spec) (put 'gv-setter 'edebug-declaration-spec spec))
(autoload 'gv-define-setter "gv" "\
Define a setter method for generalized variable NAME.
@@ -15426,7 +15745,7 @@ The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)" nil t)
-(put 'gv-place 'edebug-form-spec 'edebug-match-form)
+(def-edebug-elem-spec 'gv-place '(form))
(autoload 'gv-ref "gv" "\
Return a reference to PLACE.
@@ -15437,7 +15756,7 @@ binding mode.
\(fn PLACE)" nil t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gv" '("gv-")))
+(register-definition-prefixes "gv" '("gv-"))
;;;***
@@ -15454,7 +15773,7 @@ Variables: `handwrite-linespace' (default 12)
`handwrite-numlines' (default 60)
`handwrite-pagenumbering' (default nil)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "handwrite" '("handwrite-" "menu-bar-handwrite-map")))
+(register-definition-prefixes "handwrite" '("handwrite-" "menu-bar-handwrite-map"))
;;;***
@@ -15462,7 +15781,7 @@ Variables: `handwrite-linespace' (default 12)
;;;;;; 0 0))
;;; Generated autoloads from language/hanja-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hanja-util" '("han")))
+(register-definition-prefixes "hanja-util" '("han"))
;;;***
@@ -15487,7 +15806,7 @@ This is, necessarily (as of Emacs 20.3), a crock. When the
current-time interface is made s2G-compliant, hanoi.el will need
to be updated." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hanoi" '("hanoi-")))
+(register-definition-prefixes "hanoi" '("hanoi-"))
;;;***
@@ -15531,7 +15850,7 @@ Prefix arg sets default accept amount temporarily.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hashcash" '("hashcash-")))
+(register-definition-prefixes "hashcash" '("hashcash-"))
;;;***
@@ -15561,6 +15880,9 @@ the `kbd-help' property at point. If `kbd-help' does not produce
a string, but the `help-echo' property does, then that string is
printed instead.
+The string is passed through `substitute-command-keys' before it
+is displayed.
+
A numeric argument ARG prevents display of a message in case
there is no help. While ARG can be used interactively, it is
mainly meant for use from Lisp.
@@ -15587,6 +15909,10 @@ included in this list. Suggested properties are `keymap',
`local-map', `button' and `kbd-help'. Any value other than t or
a non-empty list disables the feature.
+The text printed from the `help-echo' property is often only
+relevant when using the mouse. The presence of a `kbd-help'
+property guarantees that non mouse specific help is available.
+
This variable only takes effect after a call to
`help-at-pt-set-timer'. The help gets printed after Emacs has
been idle for `help-at-pt-timer-delay' seconds. You can call
@@ -15654,7 +15980,7 @@ different regions. With numeric argument ARG, behaves like
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-at-pt" '("help-at-pt-" "scan-buf-move-hook")))
+(register-definition-prefixes "help-at-pt" '("help-at-pt-" "scan-buf-move-hook"))
;;;***
@@ -15667,6 +15993,12 @@ When called from lisp, FUNCTION may also be a function object.
\(fn FUNCTION)" t nil)
+(autoload 'describe-command "help-fns" "\
+Display the full documentation of COMMAND (a symbol).
+When called from lisp, COMMAND may also be a function object.
+
+\(fn COMMAND)" t nil)
+
(autoload 'help-C-file-name "help-fns" "\
Return the name of the C file where SUBR-OR-VAR is defined.
KIND should be `var' for a variable or `subr' for a subroutine.
@@ -15746,6 +16078,43 @@ BUFFER should be a buffer or a buffer name.
\(fn &optional BUFFER)" t nil)
+(autoload 'describe-keymap "help-fns" "\
+Describe key bindings in KEYMAP.
+When called interactively, prompt for a variable that has a
+keymap value.
+
+\(fn KEYMAP)" t nil)
+
+(autoload 'describe-mode "help-fns" "\
+Display documentation of current major mode and minor modes.
+A brief summary of the minor modes comes first, followed by the
+major mode description. This is followed by detailed
+descriptions of the minor modes, each on a separate page.
+
+For this to work correctly for a minor mode, the mode's indicator
+variable (listed in `minor-mode-alist') must also be a function
+whose documentation describes the minor mode.
+
+If called from Lisp with a non-nil BUFFER argument, display
+documentation for the major and minor modes of that buffer.
+
+\(fn &optional BUFFER)" t nil)
+
+(autoload 'describe-widget "help-fns" "\
+Display a buffer with information about a widget.
+You can use this command to describe buttons (e.g., the links in a *Help*
+buffer), editable fields of the customization buffers, etc.
+
+Interactively, click on a widget to describe it, or hit RET to describe the
+widget at point.
+
+When called from Lisp, POS may be a buffer position or a mouse position list.
+
+Calls each function of the list `describe-widget-functions' in turn, until
+one of them returns non-nil.
+
+\(fn &optional POS)" t nil)
+
(autoload 'doc-file-to-man "help-fns" "\
Produce an nroff buffer containing the doc-strings from the DOC file.
@@ -15756,7 +16125,7 @@ Produce a texinfo buffer with sorted doc-strings from the DOC file.
\(fn FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-fns" '("describe-" "help-")))
+(register-definition-prefixes "help-fns" '("describe-" "help-" "keymap-name-history"))
;;;***
@@ -15772,7 +16141,7 @@ gives the window that lists the options.")
(custom-autoload 'three-step-help "help-macro" t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-macro" '("make-help-screen")))
+(register-definition-prefixes "help-macro" '("make-help-screen"))
;;;***
@@ -15788,10 +16157,10 @@ Commands:
\(fn)" t nil)
(autoload 'help-mode-setup "help-mode" "\
-Enter Help Mode in the current buffer." nil nil)
+Enter Help mode in the current buffer." nil nil)
(autoload 'help-mode-finish "help-mode" "\
-Finalize Help Mode setup in current buffer." nil nil)
+Finalize Help mode setup in current buffer." nil nil)
(autoload 'help-setup-xref "help-mode" "\
Invoked from commands using the \"*Help*\" buffer to install some xref info.
@@ -15819,7 +16188,7 @@ it does not already exist." nil nil)
Parse and hyperlink documentation cross-references in the given BUFFER.
Find cross-reference information in a buffer and activate such cross
-references for selection with `help-follow'. Cross-references have
+references for selection with `help-follow-symbol'. Cross-references have
the canonical form `...' and the type of reference may be
disambiguated by the preceding word(s) used in
`help-xref-symbol-regexp'. Faces only get cross-referenced if
@@ -15863,13 +16232,13 @@ Add xrefs for symbols in `pp's output between FROM and TO.
(define-obsolete-function-alias 'help-xref-interned 'describe-symbol "25.1")
(autoload 'help-bookmark-jump "help-mode" "\
-Jump to help-mode bookmark BOOKMARK.
+Jump to `help-mode' bookmark BOOKMARK.
Handler function for record returned by `help-bookmark-make-record'.
BOOKMARK is a bookmark name or a bookmark record.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "help-mode" '("describe-symbol-backends" "help-")))
+(register-definition-prefixes "help-mode" '("describe-symbol-backends" "help-"))
;;;***
@@ -15882,14 +16251,14 @@ Describe local key bindings of current mode." t nil)
(autoload 'Helper-help "helper" "\
Provide help for current mode." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "helper" '("Helper-")))
+(register-definition-prefixes "helper" '("Helper-"))
;;;***
;;;### (autoloads nil "hex-util" "hex-util.el" (0 0 0 0))
;;; Generated autoloads from hex-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hex-util" '("decode-hex-string" "encode-hex-string")))
+(register-definition-prefixes "hex-util" '("decode-hex-string" "encode-hex-string"))
;;;***
@@ -15944,22 +16313,30 @@ also supported.
There are several ways to change text in hexl mode:
-ASCII characters (character between space (0x20) and tilde (0x7E)) are
-bound to self-insert so you can simply type the character and it will
-insert itself (actually overstrike) into the buffer.
+Self-inserting characters are bound to `hexl-self-insert' so you
+can simply type the character and it will insert itself (actually
+overstrike) into the buffer. However, inserting non-ASCII characters
+requires caution: the buffer's coding-system should correspond to
+the encoding on disk, and multibyte characters should be inserted
+with cursor on the first byte of a multibyte sequence whose length
+is identical to the length of the multibyte sequence to be inserted,
+otherwise this could produce invalid multibyte sequences. Non-ASCII
+characters in ISO-2022 encodings should preferably inserted byte by
+byte, to avoid problems caused by the designation sequences before
+the actual characters.
\\[hexl-quoted-insert] followed by another keystroke allows you to insert the key even if
it isn't bound to self-insert. An octal number can be supplied in place
of another key to insert the octal number's ASCII representation.
-\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is between 0 and 0xFF)
-into the buffer at the current point.
+\\[hexl-insert-hex-char] will insert a given hexadecimal value
+into the buffer at the current address.
-\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0 and 0377)
-into the buffer at the current point.
+\\[hexl-insert-octal-char] will insert a given octal value
+into the buffer at the current address.
-\\[hexl-insert-decimal-char] will insert a given decimal value (if it is between 0 and 255)
-into the buffer at the current point.
+\\[hexl-insert-decimal-char] will insert a given decimal value
+into the buffer at the current address..
\\[hexl-mode-exit] will exit `hexl-mode'.
@@ -15975,7 +16352,8 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(autoload 'hexl-find-file "hexl" "\
Edit file FILENAME as a binary file in hex dump format.
Switch to a buffer visiting file FILENAME, creating one if none exists,
-and edit the file in `hexl-mode'.
+and edit the file in `hexl-mode'. The buffer's coding-system will be
+no-conversion, unlike if you visit it normally and then invoke `hexl-mode'.
\(fn FILENAME)" t nil)
@@ -15983,15 +16361,7 @@ and edit the file in `hexl-mode'.
Convert a binary buffer to hexl format.
This discards the buffer's undo information." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hexl" '("dehexlify-buffer" "hexl-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "hfy-cmap" "hfy-cmap.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from hfy-cmap.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hfy-cmap" '("hfy-" "htmlfontify-unload-rgb-file")))
+(register-definition-prefixes "hexl" '("dehexlify-buffer" "hexl-"))
;;;***
@@ -16001,10 +16371,19 @@ This discards the buffer's undo information." t nil)
(autoload 'hi-lock-mode "hi-lock" "\
Toggle selective highlighting of patterns (Hi Lock mode).
-If called interactively, enable Hi-Lock mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Hi-Lock
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `hi-lock-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Hi Lock mode is automatically enabled when you invoke any of the
highlighting commands listed below, such as \\[highlight-regexp].
@@ -16083,11 +16462,12 @@ or call the function `global-hi-lock-mode'.")
(autoload 'global-hi-lock-mode "hi-lock" "\
Toggle Hi-Lock mode in all buffers.
With prefix ARG, enable Global Hi-Lock mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
Hi-Lock mode is enabled in all buffers where
`turn-on-hi-lock-if-enabled' would do it.
+
See `hi-lock-mode' for more information on Hi-Lock mode.
\(fn &optional ARG)" t nil)
@@ -16103,6 +16483,9 @@ of text in those lines.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
Use the global history list for FACE.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type.
@@ -16118,6 +16501,13 @@ Use the global history list for FACE. Limit face setting to the
corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
+LIGHTER is a human-readable string that can be used to select
+a regexp to unhighlight by its name instead of selecting a possibly
+complex regexp or closure.
+
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type. The Font Lock mode
@@ -16125,7 +16515,7 @@ is considered \"enabled\" in a buffer if its `major-mode'
causes `font-lock-specified-p' to return non-nil, which means
the major mode specifies support for Font Lock.
-\(fn REGEXP &optional FACE SUBEXP)" t nil)
+\(fn REGEXP &optional FACE SUBEXP LIGHTER)" t nil)
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -16134,9 +16524,9 @@ Set face of each match of phrase REGEXP to FACE.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
Use the global history list for FACE.
-When called interactively, replace whitespace in user-provided
-regexp with arbitrary whitespace, and make initial lower-case
-letters case-insensitive, before highlighting with `hi-lock-set-pattern'.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'.
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
@@ -16155,6 +16545,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting,
unless you use a prefix argument.
Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point.
+If REGEXP contains upper case characters (excluding those preceded by `\\')
+and `search-upper-case' is non-nil, the matching is case-sensitive.
+
This uses Font lock mode if it is enabled; otherwise it uses overlays,
in which case the highlighting will not update as you type. The Font
Lock mode is considered \"enabled\" in a buffer if its `major-mode'
@@ -16182,7 +16575,7 @@ be found in variable `hi-lock-interactive-patterns'." t nil)
(autoload 'hi-lock-find-patterns "hi-lock" "\
Add patterns from the current buffer to the list of hi-lock patterns." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hi-lock" '("hi-lock-" "turn-on-hi-lock-if-enabled")))
+(register-definition-prefixes "hi-lock" '("hi-lock-" "turn-on-hi-lock-if-enabled"))
;;;***
@@ -16192,10 +16585,19 @@ Add patterns from the current buffer to the list of hi-lock patterns." t nil)
(autoload 'hide-ifdef-mode "hideif" "\
Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode).
-If called interactively, enable Hide-Ifdef mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Hide-Ifdef
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `hide-ifdef-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Hide-Ifdef mode is a buffer-local minor mode for use with C and
C-like major modes. When enabled, code within #ifdef constructs
@@ -16233,14 +16635,14 @@ Several variables affect how the hiding is done:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")))
+(register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef"))
;;;***
;;;### (autoloads nil "hideshow" "progmodes/hideshow.el" (0 0 0 0))
;;; 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))) "\
+(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) (mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil))) "\
Alist for initializing the hideshow variables for different modes.
Each element has the form
(MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC).
@@ -16271,10 +16673,19 @@ whitespace. Case does not matter.")
(autoload 'hs-minor-mode "hideshow" "\
Minor mode to selectively hide/show code and comment blocks.
-If called interactively, enable Hs minor mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `hs minor
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `hs-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When hideshow minor mode is on, the menu bar is augmented with hideshow
commands and the hideshow commands are enabled.
@@ -16297,7 +16708,15 @@ Key bindings:
(autoload 'turn-off-hideshow "hideshow" "\
Unconditionally turn off `hs-minor-mode'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hideshow" '("hs-")))
+(register-definition-prefixes "hideshow" '("hs-"))
+
+;;;***
+
+;;;### (autoloads nil "hierarchy" "emacs-lisp/hierarchy.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from emacs-lisp/hierarchy.el
+
+(register-definition-prefixes "hierarchy" '("hierarchy-"))
;;;***
@@ -16307,10 +16726,19 @@ Unconditionally turn off `hs-minor-mode'." nil nil)
(autoload 'highlight-changes-mode "hilit-chg" "\
Toggle highlighting changes in this buffer (Highlight Changes mode).
-If called interactively, enable Highlight-Changes mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Highlight-Changes mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `highlight-changes-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Highlight Changes is enabled, changes are marked with a text
property. Normally they are displayed in a distinctive face, but
@@ -16332,10 +16760,20 @@ buffer with the contents of a file
(autoload 'highlight-changes-visible-mode "hilit-chg" "\
Toggle visibility of highlighting due to Highlight Changes mode.
-If called interactively, enable Highlight-Changes-Visible mode if ARG
-is positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and toggle
-it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Highlight-Changes-Visible mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `highlight-changes-visible-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Highlight Changes Visible mode only has an effect when Highlight
Changes mode is on. When enabled, the changed text is displayed
@@ -16421,23 +16859,24 @@ or call the function `global-highlight-changes-mode'.")
(autoload 'global-highlight-changes-mode "hilit-chg" "\
Toggle Highlight-Changes mode in all buffers.
-With prefix ARG, enable Global Highlight-Changes mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
+With prefix ARG, enable Global Highlight-Changes mode if ARG is
+positive; otherwise, disable it. If called from Lisp, enable the mode if
ARG is omitted or nil.
Highlight-Changes mode is enabled in all buffers where
`highlight-changes-mode-turn-on' would do it.
-See `highlight-changes-mode' for more information on Highlight-Changes mode.
+
+See `highlight-changes-mode' for more information on
+Highlight-Changes mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hilit-chg" '("global-highlight-changes" "highlight-" "hilit-chg-")))
+(register-definition-prefixes "hilit-chg" '("highlight-" "hilit-chg-"))
;;;***
;;;### (autoloads nil "hippie-exp" "hippie-exp.el" (0 0 0 0))
;;; Generated autoloads from hippie-exp.el
-(push (purecopy '(hippie-exp 1 6)) package--builtin-versions)
(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) "\
The list of expansion functions tried in order by `hippie-expand'.
@@ -16463,9 +16902,9 @@ Construct a function similar to `hippie-expand'.
Make it use the expansion functions in TRY-LIST. An optional second
argument VERBOSE non-nil makes the function verbose.
-\(fn TRY-LIST &optional VERBOSE)" nil t)
+\(fn TRY-LIST &optional VERBOSE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hippie-exp" '("he-" "hippie-expand-" "try-")))
+(register-definition-prefixes "hippie-exp" '("he-" "hippie-expand-" "try-"))
;;;***
@@ -16475,10 +16914,19 @@ argument VERBOSE non-nil makes the function verbose.
(autoload 'hl-line-mode "hl-line" "\
Toggle highlighting of the current line (Hl-Line mode).
-If called interactively, enable Hl-Line mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Hl-Line
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `hl-line-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Hl-Line mode is a buffer-local minor mode. If
`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the
@@ -16488,9 +16936,7 @@ non-selected window. Hl-Line mode uses the function
`hl-line-highlight' on `post-command-hook' in this case.
When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the
-line about point in the selected window only. In this case, it
-uses the function `hl-line-maybe-unhighlight' in
-addition to `hl-line-highlight' on `post-command-hook'.
+line about point in the selected window only.
\(fn &optional ARG)" t nil)
@@ -16507,35 +16953,44 @@ or call the function `global-hl-line-mode'.")
(autoload 'global-hl-line-mode "hl-line" "\
Toggle line highlighting in all buffers (Global Hl-Line mode).
-If called interactively, enable Global Hl-Line mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+Hl-Line mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-hl-line-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode
highlights the line about the current buffer's point in all live
windows.
-Global-Hl-Line mode uses the functions `global-hl-line-highlight'
-and `global-hl-line-maybe-unhighlight' on `post-command-hook'.
+Global-Hl-Line mode uses the function `global-hl-line-highlight'
+on `post-command-hook'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-")))
+(register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-"))
;;;***
;;;### (autoloads nil "hmac-def" "net/hmac-def.el" (0 0 0 0))
;;; Generated autoloads from net/hmac-def.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hmac-def" '("define-hmac-function")))
+(register-definition-prefixes "hmac-def" '("define-hmac-function"))
;;;***
;;;### (autoloads nil "hmac-md5" "net/hmac-md5.el" (0 0 0 0))
;;; Generated autoloads from net/hmac-md5.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hmac-md5" '("hmac-md5" "md5-binary")))
+(register-definition-prefixes "hmac-md5" '("hmac-md5" "md5-binary"))
;;;***
@@ -16647,7 +17102,7 @@ The optional LABEL is used to label the buffer created.
(defalias 'holiday-list 'list-holidays)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "holidays" '("calendar-" "holiday-")))
+(register-definition-prefixes "holidays" '("calendar-" "holiday-"))
;;;***
@@ -16683,15 +17138,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'.
\(fn SRCDIR DSTDIR &optional F-EXT L-EXT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "htmlfontify" '("hfy-" "htmlfontify-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ibuf-ext" "ibuf-ext.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from ibuf-ext.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("alphabetic" "basename" "content" "derived-mode" "directory" "eval" "file" "ibuffer-" "major-mode" "mod" "name" "predicate" "print" "process" "query-replace" "rename-uniquely" "replace-regexp" "revert" "shell-command-" "size" "starred-name" "used-mode" "view-and-eval" "visiting-file")))
+(register-definition-prefixes "htmlfontify" '("hfy-" "htmlfontify-"))
;;;***
@@ -16805,7 +17252,7 @@ bound to the current value of the filter.
(function-put 'define-ibuffer-filter 'doc-string-elt '2)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-macs" '("ibuffer-")))
+(register-definition-prefixes "ibuf-macs" '("ibuffer-"))
;;;***
@@ -16828,7 +17275,7 @@ buffers which are visiting a file.
(autoload 'ibuffer "ibuffer" "\
Begin using Ibuffer to edit a list of buffers.
-Type `h' after entering ibuffer for more information.
+Type \\<ibuffer-mode-map>\\[describe-mode] after entering ibuffer for more information.
All arguments are optional.
OTHER-WINDOW-P says to use another window.
@@ -16852,14 +17299,13 @@ If optional arg OTHER-WINDOW is non-nil, then use another window.
\(fn &optional OTHER-WINDOW)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuffer" '("filename" "ibuffer-" "locked" "mark" "mod" "name" "process" "read-only" "size")))
+(register-definition-prefixes "ibuffer" '("filename" "ibuffer-" "locked" "mark" "mod" "name" "process" "read-only" "recency" "size"))
;;;***
;;;### (autoloads nil "icalendar" "calendar/icalendar.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from calendar/icalendar.el
-(push (purecopy '(icalendar 0 19)) package--builtin-versions)
(autoload 'icalendar-export-file "icalendar" "\
Export diary file to iCalendar format.
@@ -16908,7 +17354,7 @@ buffer `*icalendar-errors*'.
\(fn &optional DIARY-FILENAME DO-NOT-ASK NON-MARKING)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icalendar" '("icalendar-")))
+(register-definition-prefixes "icalendar" '("icalendar-"))
;;;***
@@ -16928,10 +17374,19 @@ or call the function `fido-mode'.")
(autoload 'fido-mode "icomplete" "\
An enhanced `icomplete-mode' that emulates `ido-mode'.
-If called interactively, enable Fido mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Fido mode'
+mode. If the prefix argument is positive, enable the mode, and if it
+is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'fido-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
This global minor mode makes minibuffer completion behave
more like `ido-mode' than regular `icomplete-mode'.
@@ -16951,10 +17406,19 @@ or call the function `icomplete-mode'.")
(autoload 'icomplete-mode "icomplete" "\
Toggle incremental minibuffer completion (Icomplete mode).
-If called interactively, enable Icomplete mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Icomplete
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'icomplete-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When this global minor mode is enabled, typing in the minibuffer
continuously displays a list of possible completions that match
@@ -16970,12 +17434,45 @@ completions:
\\{icomplete-minibuffer-map}
\(fn &optional ARG)" t nil)
+
+(defvar icomplete-vertical-mode nil "\
+Non-nil if Icomplete-Vertical mode is enabled.
+See the `icomplete-vertical-mode' command
+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 `icomplete-vertical-mode'.")
+
+(custom-autoload 'icomplete-vertical-mode "icomplete" nil)
+
+(autoload 'icomplete-vertical-mode "icomplete" "\
+Toggle vertical candidate display in `icomplete-mode' or `fido-mode'.
+
+This is a minor mode. If called interactively, toggle the
+`Icomplete-Vertical mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'icomplete-vertical-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+As many completion candidates as possible are displayed, depending on
+the value of `max-mini-window-height', and the way the mini-window is
+resized depends on `resize-mini-windows'.
+
+\(fn &optional ARG)" t nil)
(when (locate-library "obsolete/iswitchb")
(autoload 'iswitchb-mode "iswitchb" "Toggle Iswitchb mode." t)
(make-obsolete 'iswitchb-mode
"use `icomplete-mode' or `ido-mode' instead." "24.4"))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icomplete" '("icomplete-")))
+(register-definition-prefixes "icomplete" '("fido-vertical-mode" "icomplete-"))
;;;***
@@ -17017,7 +17514,7 @@ with no args, if that value is non-nil.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "icon" '("beginning-of-icon-defun" "calculate-icon-indent" "electric-icon-brace" "end-of-icon-defun" "icon-" "indent-icon-exp" "mark-icon-function")))
+(register-definition-prefixes "icon" '("beginning-of-icon-defun" "calculate-icon-indent" "electric-icon-brace" "end-of-icon-defun" "icon-" "indent-icon-exp" "mark-icon-function"))
;;;***
@@ -17025,7 +17522,7 @@ with no args, if that value is non-nil.
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/idlw-complete-structtag.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-complete-structtag" '("idlwave-")))
+(register-definition-prefixes "idlw-complete-structtag" '("idlwave-"))
;;;***
@@ -17033,7 +17530,7 @@ with no args, if that value is non-nil.
;;;;;; 0))
;;; Generated autoloads from progmodes/idlw-help.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-help" '("idlwave-")))
+(register-definition-prefixes "idlw-help" '("idlwave-"))
;;;***
@@ -17061,7 +17558,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-shell" '("idlwave-")))
+(register-definition-prefixes "idlw-shell" '("idlwave-"))
;;;***
@@ -17069,7 +17566,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/idlw-toolbar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlw-toolbar" '("idlwave-toolbar-")))
+(register-definition-prefixes "idlw-toolbar" '("idlwave-toolbar-"))
;;;***
@@ -17103,7 +17600,7 @@ The main features of this mode are
Use \\[idlwave-fill-paragraph] to refill a paragraph inside a
comment. The indentation of the second line of the paragraph
relative to the first will be retained. Use
- \\[idlwave-auto-fill-mode] to toggle auto-fill mode for these
+ \\[auto-fill-mode] to toggle auto-fill mode for these
comments. When the variable `idlwave-fill-comment-line-only' is
nil, code can also be auto-filled and auto-indented.
@@ -17178,7 +17675,6 @@ The main features of this mode are
8. Hooks
-----
- Loading idlwave.el runs `idlwave-load-hook'.
Turning on `idlwave-mode' runs `idlwave-mode-hook'.
9. Documentation and Customization
@@ -17187,7 +17683,7 @@ The main features of this mode are
\\[idlwave-info] to display (complain to your sysadmin if that does
not work). For Postscript, PDF, and HTML versions of the
documentation, check IDLWAVE's homepage at URL
- `http://github.com/jdtsmith/idlwave'.
+ `https://github.com/jdtsmith/idlwave'.
IDLWAVE has customize support - see the group `idlwave'.
10.Keybindings
@@ -17200,7 +17696,7 @@ The main features of this mode are
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "idlwave" '("idlwave-")))
+(register-definition-prefixes "idlwave" '("idlwave-"))
;;;***
@@ -17460,7 +17956,7 @@ DEF, if non-nil, is the default value.
\(fn PROMPT CHOICES &optional PREDICATE REQUIRE-MATCH INITIAL-INPUT HIST DEF INHERIT-INPUT-METHOD)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ido" '("ido-")))
+(register-definition-prefixes "ido" '("ido-"))
;;;***
@@ -17475,14 +17971,14 @@ See `inferior-emacs-lisp-mode' for details.
\(fn &optional BUF-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ielm" '("ielm-" "inferior-emacs-lisp-mode")))
+(register-definition-prefixes "ielm" '("ielm-" "inferior-emacs-lisp-mode"))
;;;***
;;;### (autoloads nil "ietf-drums" "mail/ietf-drums.el" (0 0 0 0))
;;; Generated autoloads from mail/ietf-drums.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ietf-drums" '("ietf-drums-")))
+(register-definition-prefixes "ietf-drums" '("ietf-drums-"))
;;;***
@@ -17494,16 +17990,25 @@ See `inferior-emacs-lisp-mode' for details.
(autoload 'iimage-mode "iimage" "\
Toggle Iimage mode on or off.
-If called interactively, enable Iimage mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Iimage
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `iimage-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\{iimage-mode-map}
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iimage" '("iimage-" "turn-off-iimage-mode")))
+(register-definition-prefixes "iimage" '("iimage-" "turn-off-iimage-mode"))
;;;***
@@ -17612,12 +18117,16 @@ means display it in the right marginal area.
(autoload 'insert-image "image" "\
Insert IMAGE into current buffer at point.
IMAGE is displayed by inserting STRING into the current buffer
-with a `display' property whose value is the image. STRING
-defaults to a single space if you omit it.
+with a `display' property whose value is the image.
+
+STRING defaults to a single space if you omit it, which means
+that the inserted image will behave as whitespace syntactically.
+
AREA is where to display the image. AREA nil or omitted means
display it in the text area, a value of `left-margin' means
display it in the left marginal area, a value of `right-margin'
means display it in the right marginal area.
+
SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
specifying the X and Y positions and WIDTH and HEIGHT of image area
@@ -17661,11 +18170,13 @@ is supported, and FILE exists, is used to construct the image
specification to be returned. Return nil if no specification is
satisfied.
+If CACHE is non-nil, results are cached and returned on subsequent calls.
+
The image is looked for in `image-load-path'.
Image files should not be larger than specified by `max-image-size'.
-\(fn SPECS)" nil nil)
+\(fn SPECS &optional CACHE)" nil nil)
(autoload 'defimage "image" "\
Define SYMBOL as an image, and return SYMBOL.
@@ -17703,7 +18214,7 @@ recognizes these files as having image type `imagemagick'.
If Emacs is compiled without ImageMagick support, this does nothing." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image" '("image" "unknown-image-type")))
+(register-definition-prefixes "image" '("find-image--cache" "image" "unknown-image-type"))
;;;***
@@ -17711,7 +18222,7 @@ If Emacs is compiled without ImageMagick support, this does nothing." nil nil)
;;;;;; (0 0 0 0))
;;; Generated autoloads from image/image-converter.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-converter" '("image-convert")))
+(register-definition-prefixes "image-converter" '("image-convert"))
;;;***
@@ -17802,10 +18313,19 @@ Setup easy-to-use keybindings for the commands to be used in dired mode.
Note that n, p and <down> and <up> will be hijacked and bound to
`image-dired-dired-x-line'.
-If called interactively, enable Image-Dired minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Image-Dired minor mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `image-dired-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -17843,7 +18363,7 @@ Edit comment and tags of current or marked image files.
Edit comment and tags for all marked image files in an
easy-to-use form." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-dired" '("image-dired-")))
+(register-definition-prefixes "image-dired" '("image-dired-"))
;;;***
@@ -17898,10 +18418,19 @@ or call the function `auto-image-file-mode'.")
(autoload 'auto-image-file-mode "image-file" "\
Toggle visiting of image files as images (Auto Image File mode).
-If called interactively, enable Auto-Image-File mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Auto-Image-File mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'auto-image-file-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
An image file is one whose name has an extension in
`image-file-name-extensions', or matches a regexp in
@@ -17909,7 +18438,7 @@ An image file is one whose name has an extension in
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-file" '("image-file-")))
+(register-definition-prefixes "image-file" '("image-file-"))
;;;***
@@ -17927,10 +18456,19 @@ Key bindings:
(autoload 'image-minor-mode "image-mode" "\
Toggle Image minor mode in this buffer.
-If called interactively, enable Image minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Image
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `image-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display],
to switch back to `image-mode' and display an image file as the
@@ -17948,14 +18486,14 @@ displays an image file as text." nil nil)
\(fn BMK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "image-mode" '("image-")))
+(register-definition-prefixes "image-mode" '("image-"))
;;;***
;;;### (autoloads nil "imap" "net/imap.el" (0 0 0 0))
;;; Generated autoloads from net/imap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "imap" '("imap-")))
+(register-definition-prefixes "imap" '("imap-"))
;;;***
@@ -17979,7 +18517,7 @@ element should come before the second. The arguments are cons cells;
(custom-autoload 'imenu-sort-function "imenu" t)
-(defvar imenu-generic-expression nil "\
+(defvar-local imenu-generic-expression nil "\
List of definition matchers for creating an Imenu index.
Each element of this list should have the form
@@ -18015,9 +18553,7 @@ characters which normally have \"symbol\" syntax are considered to have
\"word\" syntax during matching.")
(put 'imenu-generic-expression 'risky-local-variable t)
-(make-variable-buffer-local 'imenu-generic-expression)
-
-(defvar imenu-create-index-function 'imenu-default-create-index-function "\
+(defvar-local imenu-create-index-function 'imenu-default-create-index-function "\
The function to use for creating an index alist of the current buffer.
It should be a function that takes no arguments and returns
@@ -18026,9 +18562,7 @@ called within a `save-excursion'.
See `imenu--index-alist' for the format of the buffer index alist.")
-(make-variable-buffer-local 'imenu-create-index-function)
-
-(defvar imenu-prev-index-position-function 'beginning-of-defun "\
+(defvar-local imenu-prev-index-position-function 'beginning-of-defun "\
Function for finding the next index position.
If `imenu-create-index-function' is set to
@@ -18039,18 +18573,14 @@ file.
The function should leave point at the place to be connected to the
index and it should return nil when it doesn't find another index.")
-(make-variable-buffer-local 'imenu-prev-index-position-function)
-
-(defvar imenu-extract-index-name-function nil "\
+(defvar-local imenu-extract-index-name-function nil "\
Function for extracting the index item name, given a position.
This function is called after `imenu-prev-index-position-function'
finds a position for an index item, with point at that position.
It should return the name for that index item.")
-(make-variable-buffer-local 'imenu-extract-index-name-function)
-
-(defvar imenu-name-lookup-function nil "\
+(defvar-local imenu-name-lookup-function nil "\
Function to compare string with index item.
This function will be called with two strings, and should return
@@ -18061,18 +18591,28 @@ Set this to some other function for more advanced comparisons,
such as \"begins with\" or \"name matches and number of
arguments match\".")
-(make-variable-buffer-local 'imenu-name-lookup-function)
-
-(defvar imenu-default-goto-function 'imenu-default-goto-function "\
+(defvar-local imenu-default-goto-function 'imenu-default-goto-function "\
The default function called when selecting an Imenu item.
The function in this variable is called when selecting a normal index-item.")
-
-(make-variable-buffer-local 'imenu-default-goto-function)
(put 'imenu--index-alist 'risky-local-variable t)
-(make-variable-buffer-local 'imenu-syntax-alist)
+(defvar-local imenu-syntax-alist nil "\
+Alist of syntax table modifiers to use while in `imenu--generic-function'.
+
+The car of the assocs may be either a character or a string and the
+cdr is a syntax description appropriate for `modify-syntax-entry'. For
+a string, all the characters in the string get the specified syntax.
+
+This is typically used to give word syntax to characters which
+normally have symbol syntax to simplify `imenu-expression'
+and speed-up matching.")
+
+(defvar-local imenu-case-fold-search t "\
+Defines whether `imenu--generic-function' should fold case when matching.
-(make-variable-buffer-local 'imenu-case-fold-search)
+This variable should be set (only) by initialization code
+for modes which use `imenu--generic-function'. If it is not set, but
+`font-lock-defaults' is set, then font-lock's setting is used.")
(autoload 'imenu-add-to-menubar "imenu" "\
Add an `imenu' entry to the menu bar for the current buffer.
@@ -18093,7 +18633,7 @@ for more information.
\(fn INDEX-ITEM)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "imenu" '("imenu-")))
+(register-definition-prefixes "imenu" '("imenu-"))
;;;***
@@ -18125,7 +18665,7 @@ Convert old Emacs Devanagari characters to UCS.
\(fn FROM TO)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ind-util" '("indian-" "is13194-")))
+(register-definition-prefixes "ind-util" '("indian-" "is13194-"))
;;;***
@@ -18136,16 +18676,21 @@ Convert old Emacs Devanagari characters to UCS.
Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'.
If there is a process already running in `*inferior-lisp*', just switch
to that buffer.
+
With argument, allows you to edit the command line (default is value
of `inferior-lisp-program'). Runs the hooks from
`inferior-lisp-mode-hook' (after the `comint-mode-hook' is run).
+
+If any parts of the command name contains spaces, they should be
+quoted using shell quote syntax.
+
\(Type \\[describe-mode] in the process buffer for a list of commands.)
\(fn CMD)" t nil)
(defalias 'run-lisp 'inferior-lisp)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "inf-lisp" '("inferior-lisp-" "lisp-" "switch-to-lisp")))
+(register-definition-prefixes "inf-lisp" '("inferior-lisp-" "lisp-" "switch-to-lisp"))
;;;***
@@ -18169,7 +18714,9 @@ the environment variable INFOPATH is set.
Although this is a customizable variable, that is mainly for technical
reasons. Normally, you should either set INFOPATH or customize
-`Info-additional-directory-list', rather than changing this variable." :initialize 'custom-initialize-delay :type '(repeat directory) :group 'info)
+`Info-additional-directory-list', rather than changing this variable." :initialize #'custom-initialize-delay :type '(repeat directory))
+
+(custom-autoload 'Info-default-directory-list "info" t)
(autoload 'info-other-window "info" "\
Like `info' but show the Info buffer in another window.
@@ -18288,6 +18835,7 @@ Moving within a node:
already visible, try to go to the previous menu entry, or up
if there is none.
\\[beginning-of-buffer] Go to beginning of node.
+\\[end-of-buffer] Go to end of node.
Advanced commands:
\\[Info-search] Search through this Info file for specified regexp,
@@ -18349,7 +18897,7 @@ completion alternatives to currently visited manuals.
\(fn MANUAL)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info" '("Info-" "info-")))
+(register-definition-prefixes "info" '("Info-" "info-"))
;;;***
@@ -18396,7 +18944,7 @@ Perform completion on file preceding point.
\(fn &optional MODE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info-look" '("info-")))
+(register-definition-prefixes "info-look" '("info-"))
;;;***
@@ -18477,7 +19025,7 @@ the sources handy.
\(fn FILENAME-LIST)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "info-xref" '("info-xref-")))
+(register-definition-prefixes "info-xref" '("info-xref-"))
;;;***
@@ -18518,7 +19066,7 @@ Must be used only with -batch, and kills Emacs on completion.
Each file will be processed even if an error occurred previously.
For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\"" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "informat" '("Info-validate-")))
+(register-definition-prefixes "informat" '("Info-validate-"))
;;;***
@@ -18537,21 +19085,7 @@ See Info node `(elisp)Defining Functions' for more details.
(function-put 'define-inline 'doc-string-elt '3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "inline" '("inline-")))
-
-;;;***
-
-;;;### (autoloads nil "inversion" "cedet/inversion.el" (0 0 0 0))
-;;; Generated autoloads from cedet/inversion.el
-(push (purecopy '(inversion 1 3)) package--builtin-versions)
-
-(autoload 'inversion-require-emacs "inversion" "\
-Declare that you need either EMACS-VER, XEMACS-VER or SXEMACS-ver.
-Only checks one based on which kind of Emacs is being run.
-
-\(fn EMACS-VER XEMACS-VER SXEMACS-VER)" nil nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "inversion" '("inversion-")))
+(register-definition-prefixes "inline" '("inline-"))
;;;***
@@ -18565,12 +19099,15 @@ Select an input method and turn it on in interactive search." t nil)
(autoload 'isearch-toggle-input-method "isearch-x" "\
Toggle input method in interactive search." t nil)
+(autoload 'isearch-transient-input-method "isearch-x" "\
+Activate transient input method in interactive search." t nil)
+
(autoload 'isearch-process-search-multibyte-characters "isearch-x" "\
\(fn LAST-CHAR &optional COUNT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "isearch-x" '("isearch-")))
+(register-definition-prefixes "isearch-x" '("isearch-"))
;;;***
@@ -18584,7 +19121,7 @@ Executing this command again will terminate the search; or, if
the search has not yet begun, will toggle to the last buffer
accessed via isearchb." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "isearchb" '("isearchb")))
+(register-definition-prefixes "isearchb" '("isearchb"))
;;;***
@@ -18592,7 +19129,7 @@ accessed via isearchb." t nil)
;;;;;; 0 0 0))
;;; Generated autoloads from international/iso-ascii.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-ascii" '("iso-ascii-")))
+(register-definition-prefixes "iso-ascii" '("iso-ascii-"))
;;;***
@@ -18683,24 +19220,14 @@ Warn that format is write-only.
(autoload 'iso-cvt-define-menu "iso-cvt" "\
Add submenus to the File menu, to convert to and from various formats." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-cvt" '("iso-")))
-
-;;;***
-
-;;;### (autoloads nil "iso-transl" "international/iso-transl.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from international/iso-transl.el
- (define-key key-translation-map "\C-x8" 'iso-transl-ctl-x-8-map)
- (autoload 'iso-transl-ctl-x-8-map "iso-transl" "Keymap for C-x 8 prefix." t 'keymap)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-transl" '("iso-transl-")))
+(register-definition-prefixes "iso-cvt" '("iso-"))
;;;***
;;;### (autoloads nil "iso8601" "calendar/iso8601.el" (0 0 0 0))
;;; Generated autoloads from calendar/iso8601.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso8601" '("iso8601-")))
+(register-definition-prefixes "iso8601" '("iso8601-"))
;;;***
@@ -18833,7 +19360,16 @@ amount for last line processed.
\(fn REG-START REG-END &optional RECHECKP SHIFT)" t nil)
(autoload 'ispell-comments-and-strings "ispell" "\
-Check comments and strings in the current buffer for spelling errors." t nil)
+Check comments and strings in the current buffer for spelling errors.
+If called interactively with an active region, check only comments and
+strings in the region.
+When called from Lisp, START and END buffer positions can be provided
+to limit the check.
+
+\(fn &optional START END)" t nil)
+
+(autoload 'ispell-comment-or-string-at-point "ispell" "\
+Check the comment or string containing point for spelling errors." t nil)
(autoload 'ispell-buffer "ispell" "\
Check the current buffer for spelling errors interactively." t nil)
@@ -18872,10 +19408,19 @@ available on the net." t nil)
(autoload 'ispell-minor-mode "ispell" "\
Toggle last-word spell checking (Ispell minor mode).
-If called interactively, enable ISpell minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `ISpell
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `ispell-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Ispell minor mode is a buffer-local minor mode. When enabled,
typing SPC or RET warns you if the previous word is incorrectly
@@ -18908,9 +19453,9 @@ in your init file:
You can bind this to the key C-c i in GNUS or mail by adding to
`news-reply-mode-hook' or `mail-mode-hook' the following lambda expression:
- (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message)))" t nil)
+ (lambda () (local-set-key \"\\C-ci\" \\='ispell-message))" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ispell" '("check-ispell-version" "ispell-")))
+(register-definition-prefixes "ispell" '("check-ispell-version" "ispell-"))
;;;***
@@ -18918,7 +19463,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;;;; (0 0 0 0))
;;; Generated autoloads from international/ja-dic-cnv.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-cnv" '("batch-skkdic-convert" "ja-dic-filename" "skkdic-")))
+(register-definition-prefixes "ja-dic-cnv" '("batch-skkdic-convert" "ja-dic-filename" "skkdic-"))
;;;***
@@ -18926,7 +19471,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;;;; (0 0 0 0))
;;; Generated autoloads from international/ja-dic-utl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ja-dic-utl" '("skkdic-")))
+(register-definition-prefixes "ja-dic-utl" '("skkdic-"))
;;;***
@@ -19003,7 +19548,7 @@ If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
\(fn PROMPT &optional INITIAL-INPUT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "japan-util" '("japanese-")))
+(register-definition-prefixes "japan-util" '("japanese-"))
;;;***
@@ -19026,7 +19571,7 @@ This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
and `inhibit-local-variables-suffixes' that were added
by `jka-compr-install'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jka-compr" '("compression-error" "jka-compr-")))
+(register-definition-prefixes "jka-compr" '("compression-error" "jka-compr-"))
;;;***
@@ -19057,30 +19602,30 @@ one of the aforementioned options instead of using this mode.
(dolist (name (list "node" "nodejs" "gjs" "rhino")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'js-mode)))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "js" '("js-" "with-js")))
+(register-definition-prefixes "js" '("js-" "with-js"))
;;;***
;;;### (autoloads nil "json" "json.el" (0 0 0 0))
;;; Generated autoloads from json.el
-(push (purecopy '(json 1 4)) package--builtin-versions)
+(push (purecopy '(json 1 5)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "json" '("json-")))
+(register-definition-prefixes "json" '("json-"))
;;;***
;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0))
;;; Generated autoloads from jsonrpc.el
-(push (purecopy '(jsonrpc 1 0 9)) package--builtin-versions)
+(push (purecopy '(jsonrpc 1 0 14)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-")))
+(register-definition-prefixes "jsonrpc" '("jsonrpc-"))
;;;***
;;;### (autoloads nil "kermit" "kermit.el" (0 0 0 0))
;;; Generated autoloads from kermit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "kermit" '("kermit-")))
+(register-definition-prefixes "kermit" '("kermit-"))
;;;***
@@ -19159,7 +19704,7 @@ the context of text formatting.
\(fn LINEBEG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "kinsoku" '("kinsoku-")))
+(register-definition-prefixes "kinsoku" '("kinsoku-"))
;;;***
@@ -19183,18 +19728,18 @@ and the return value is the length of the conversion.
\(fn FROM TO)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "kkc" '("kkc-")))
+(register-definition-prefixes "kkc" '("kkc-"))
;;;***
;;;### (autoloads nil "kmacro" "kmacro.el" (0 0 0 0))
;;; Generated autoloads from kmacro.el
- (global-set-key "\C-x(" 'kmacro-start-macro)
- (global-set-key "\C-x)" 'kmacro-end-macro)
- (global-set-key "\C-xe" 'kmacro-end-and-call-macro)
- (global-set-key [f3] 'kmacro-start-macro-or-insert-counter)
- (global-set-key [f4] 'kmacro-end-or-call-macro)
- (global-set-key "\C-x\C-k" 'kmacro-keymap)
+ (global-set-key "\C-x(" #'kmacro-start-macro)
+ (global-set-key "\C-x)" #'kmacro-end-macro)
+ (global-set-key "\C-xe" #'kmacro-end-and-call-macro)
+ (global-set-key [f3] #'kmacro-start-macro-or-insert-counter)
+ (global-set-key [f4] #'kmacro-end-or-call-macro)
+ (global-set-key "\C-x\C-k" #'kmacro-keymap)
(autoload 'kmacro-keymap "kmacro" "Keymap for keyboard macro commands." t 'keymap)
(autoload 'kmacro-exec-ring-item "kmacro" "\
@@ -19307,7 +19852,7 @@ Create lambda form for macro bound to symbol or key.
\(fn MAC &optional COUNTER FORMAT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "kmacro" '("kmacro-")))
+(register-definition-prefixes "kmacro" '("kdb-macro-redisplay" "kmacro-"))
;;;***
@@ -19316,12 +19861,12 @@ Create lambda form for macro bound to symbol or key.
;;; Generated autoloads from language/korea-util.el
(defvar default-korean-keyboard (purecopy (if (string-match "3" (or (getenv "HANGUL_KEYBOARD_TYPE") "")) "3" "")) "\
-The kind of Korean keyboard for Korean input method.
-\"\" for 2, \"3\" for 3.")
+The kind of Korean keyboard for Korean (Hangul) input method.
+\"\" for 2, \"3\" for 3, and \"3f\" for 3f.")
(autoload 'setup-korean-environment-internal "korea-util" nil nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "korea-util" '("exit-korean-environment" "isearch-" "korean-key-bindings" "quail-hangul-switch-" "toggle-korean-input-method")))
+(register-definition-prefixes "korea-util" '("exit-korean-environment" "isearch-" "korean-key-bindings" "quail-hangul-switch-" "toggle-korean-input-method"))
;;;***
@@ -19360,7 +19905,7 @@ Transcribe Romanized Lao string STR to Lao character string.
\(fn FROM TO)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lao-util" '("lao-")))
+(register-definition-prefixes "lao-util" '("lao-"))
;;;***
@@ -19394,7 +19939,7 @@ coding system names is determined from `latex-inputenc-coding-alist'.
\(fn ARG-LIST)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "latexenc" '("latexenc-dont-use-")))
+(register-definition-prefixes "latexenc" '("latexenc-dont-use-"))
;;;***
@@ -19438,7 +19983,7 @@ use either \\[customize] or the function `latin1-display'.")
(custom-autoload 'latin1-display-ucs-per-lynx "latin1-disp" nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "latin1-disp" '("latin1-display-")))
+(register-definition-prefixes "latin1-disp" '("latin1-display-"))
;;;***
@@ -19451,14 +19996,14 @@ A major mode to edit GNU ld script files
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ld-script" '("ld-script-")))
+(register-definition-prefixes "ld-script" '("ld-script-"))
;;;***
;;;### (autoloads nil "ldap" "net/ldap.el" (0 0 0 0))
;;; Generated autoloads from net/ldap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ldap" '("ldap-")))
+(register-definition-prefixes "ldap" '("ldap-"))
;;;***
@@ -19466,7 +20011,7 @@ A major mode to edit GNU ld script files
;;;;;; (0 0 0 0))
;;; Generated autoloads from gnus/legacy-gnus-agent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "legacy-gnus-agent" '("gnus-agent-")))
+(register-definition-prefixes "legacy-gnus-agent" '("gnus-agent-"))
;;;***
@@ -19474,13 +20019,13 @@ A major mode to edit GNU ld script files
;;;;;; (0 0 0 0))
;;; Generated autoloads from textmodes/less-css-mode.el
-(put 'less-css-compile-at-save 'safe-local-variable 'booleanp)
+(put 'less-css-compile-at-save 'safe-local-variable #'booleanp)
(put 'less-css-lessc-options 'safe-local-variable t)
-(put 'less-css-output-directory 'safe-local-variable 'stringp)
+(put 'less-css-output-directory 'safe-local-variable #'stringp)
-(put 'less-css-input-file-name 'safe-local-variable 'stringp)
+(put 'less-css-input-file-name 'safe-local-variable #'stringp)
(add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode))
(autoload 'less-css-mode "less-css-mode" "\
@@ -19490,7 +20035,7 @@ Special commands:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "less-css-mode" '("less-css-")))
+(register-definition-prefixes "less-css-mode" '("less-css-"))
;;;***
@@ -19532,7 +20077,7 @@ displayed in the example above.
(function-put 'let-alist 'lisp-indent-function '1)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "let-alist" '("let-alist--")))
+(register-definition-prefixes "let-alist" '("let-alist--"))
;;;***
@@ -19541,27 +20086,39 @@ displayed in the example above.
(autoload 'life "life" "\
Run Conway's Life simulation.
-The starting pattern is randomly selected. Prefix arg (optional first
-arg non-nil from a program) is the number of seconds to sleep between
-generations (this defaults to 1).
+The starting pattern is randomly selected from `life-patterns'.
+
+Prefix arg is the number of tenths of a second to sleep between
+generations (the default is `life-step-time').
-\(fn &optional SLEEPTIME)" t nil)
+When called from Lisp, optional argument STEP-TIME is the time to
+sleep in seconds.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "life" '("life-")))
+\(fn &optional STEP-TIME)" t nil)
+
+(register-definition-prefixes "life" '("life-"))
;;;***
;;;### (autoloads nil "linum" "linum.el" (0 0 0 0))
;;; Generated autoloads from linum.el
-(push (purecopy '(linum 0 9 24)) package--builtin-versions)
(autoload 'linum-mode "linum" "\
Toggle display of line numbers in the left margin (Linum mode).
-If called interactively, enable Linum mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Linum
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `linum-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Linum mode is a buffer-local minor mode.
@@ -19582,16 +20139,16 @@ or call the function `global-linum-mode'.")
(autoload 'global-linum-mode "linum" "\
Toggle Linum mode in all buffers.
With prefix ARG, enable Global Linum mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
+
+Linum mode is enabled in all buffers where `linum-on' would do it.
-Linum mode is enabled in all buffers where
-`linum-on' would do it.
See `linum-mode' for more information on Linum mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "linum" '("linum-")))
+(register-definition-prefixes "linum" '("linum-"))
;;;***
@@ -19599,7 +20156,7 @@ See `linum-mode' for more information on Linum mode.
;;;;;; 0))
;;; Generated autoloads from emacs-lisp/lisp-mnt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lisp-mnt" '("lm-")))
+(register-definition-prefixes "lisp-mnt" '("lm-"))
;;;***
@@ -19612,11 +20169,10 @@ If the feature is required by any other loaded code, and prefix arg FORCE
is nil, raise an error.
Standard unloading activities include restoring old autoloads for
-functions defined by the library, undoing any additions that the
-library has made to hook variables or to `auto-mode-alist', undoing
-ELP profiling of functions in that library, unproviding any features
-provided by the library, and canceling timers held in variables
-defined by the library.
+functions defined by the library, removing such functions from
+hooks and `auto-mode-alist', undoing their ELP profiling,
+unproviding any features provided by the library, and canceling
+timers held in variables defined by the library.
If a function `FEATURE-unload-function' is defined, this function
calls it with no arguments, before doing anything else. That function
@@ -19632,7 +20188,7 @@ something strange, such as redefining an Emacs function.
\(fn FEATURE &optional FORCE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-" "read-feature" "unload-")))
+(register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-" "read-feature" "unload-"))
;;;***
@@ -19686,7 +20242,7 @@ except that FILTER is not optional.
\(fn SEARCH-STRING FILTER &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "locate" '("locate-")))
+(register-definition-prefixes "locate" '("locate-"))
;;;***
@@ -19719,7 +20275,7 @@ done. Otherwise, this function will use the current buffer.
\(fn CALLBACK &optional SETUP PARAMS BUFFER MODE &rest IGNORE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "log-edit" '("log-edit-" "vc-log-")))
+(register-definition-prefixes "log-edit" '("log-edit-"))
;;;***
@@ -19731,7 +20287,7 @@ Major mode for browsing CVS log output.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "log-view" '("log-view-")))
+(register-definition-prefixes "log-view" '("log-view-"))
;;;***
@@ -19824,7 +20380,7 @@ for further customization of the printer command.
\(fn START END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lpr" '("lpr-" "print")))
+(register-definition-prefixes "lpr" '("lpr-" "print"))
;;;***
@@ -19837,7 +20393,7 @@ Otherwise they are treated as Emacs regexps (for backward compatibility).")
(custom-autoload 'ls-lisp-support-shell-wildcards "ls-lisp" t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ls-lisp" '("ls-lisp-")))
+(register-definition-prefixes "ls-lisp" '("ls-lisp-"))
;;;***
@@ -19851,7 +20407,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-")))
+(register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "eclipse-check" "lunar-"))
;;;***
@@ -19863,7 +20419,7 @@ A major mode to edit m4 macro files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "m4-mode" '("m4-")))
+(register-definition-prefixes "m4-mode" '("m4-"))
;;;***
@@ -19948,7 +20504,7 @@ and then select the region of un-tablified names and use
\(fn TOP BOTTOM &optional MACRO)" t nil)
(define-key ctl-x-map "q" 'kbd-macro-query)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "macros" '("macros--insert-vector-macro")))
+(register-definition-prefixes "macros" '("macros--insert-vector-macro"))
;;;***
@@ -19987,7 +20543,7 @@ Convert mail domain DOMAIN to the country it corresponds to.
\(fn DOMAIN)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-extr" '("mail-extr-")))
+(register-definition-prefixes "mail-extr" '("mail-extr-"))
;;;***
@@ -20011,21 +20567,21 @@ message.
This function normally would be called when the message is sent." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-hist" '("mail-hist-")))
+(register-definition-prefixes "mail-hist" '("mail-hist-"))
;;;***
;;;### (autoloads nil "mail-parse" "mail/mail-parse.el" (0 0 0 0))
;;; Generated autoloads from mail/mail-parse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-parse" '("mail-")))
+(register-definition-prefixes "mail-parse" '("mail-"))
;;;***
;;;### (autoloads nil "mail-prsvr" "mail/mail-prsvr.el" (0 0 0 0))
;;; Generated autoloads from mail/mail-prsvr.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-prsvr" '("mail-parse-")))
+(register-definition-prefixes "mail-prsvr" '("mail-parse-"))
;;;***
@@ -20033,7 +20589,7 @@ This function normally would be called when the message is sent." nil nil)
;;;;;; 0))
;;; Generated autoloads from gnus/mail-source.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-source" '("mail-source")))
+(register-definition-prefixes "mail-source" '("mail-source"))
;;;***
@@ -20111,7 +20667,7 @@ matches may be returned from the message body.
\(fn FIELD-NAME &optional LAST ALL LIST DELETE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-utils" '("mail-")))
+(register-definition-prefixes "mail-utils" '("mail-"))
;;;***
@@ -20131,10 +20687,19 @@ or call the function `mail-abbrevs-mode'.")
(autoload 'mail-abbrevs-mode "mailabbrev" "\
Toggle abbrev expansion of mail aliases (Mail Abbrevs mode).
-If called interactively, enable Mail-Abbrevs mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Mail-Abbrevs mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'mail-abbrevs-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Mail Abbrevs mode is a global minor mode. When enabled,
abbrev-like expansion is performed when editing certain mail
@@ -20163,7 +20728,7 @@ double-quotes.
\(fn NAME DEFINITION &optional FROM-MAILRC-FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailabbrev" '("mail-" "merge-mail-abbrevs" "rebuild-mail-abbrevs")))
+(register-definition-prefixes "mailabbrev" '("mail-" "merge-mail-abbrevs" "rebuild-mail-abbrevs"))
;;;***
@@ -20216,14 +20781,14 @@ current header, calls `mail-complete-function' and passes prefix ARG if any.
(make-obsolete 'mail-complete 'mail-completion-at-point-function '"24.1")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailalias" '("build-mail-aliases" "mail-")))
+(register-definition-prefixes "mailalias" '("build-mail-aliases" "mail-"))
;;;***
;;;### (autoloads nil "mailcap" "net/mailcap.el" (0 0 0 0))
;;; Generated autoloads from net/mailcap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailcap" '("mailcap-")))
+(register-definition-prefixes "mailcap" '("mailcap-"))
;;;***
@@ -20235,21 +20800,65 @@ Pass current buffer on to the system's mail client.
Suitable value for `send-mail-function'.
The mail client is taken to be the handler of mailto URLs." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailclient" '("mailclient-")))
+(register-definition-prefixes "mailclient" '("mailclient-"))
;;;***
;;;### (autoloads nil "mailheader" "mail/mailheader.el" (0 0 0 0))
;;; Generated autoloads from mail/mailheader.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mailheader" '("mail-header")))
+(register-definition-prefixes "mailheader" '("mail-header"))
;;;***
;;;### (autoloads nil "mairix" "net/mairix.el" (0 0 0 0))
;;; Generated autoloads from net/mairix.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mairix" '("mairix-")))
+(autoload 'mairix-search "mairix" "\
+Call Mairix with SEARCH.
+If THREADS is non-nil, also display whole threads of found
+messages. Results will be put into the default search file.
+
+\(fn SEARCH THREADS)" t nil)
+
+(autoload 'mairix-use-saved-search "mairix" "\
+Use a saved search for querying Mairix." t nil)
+
+(autoload 'mairix-edit-saved-searches-customize "mairix" "\
+Edit the list of saved searches in a customization buffer." t nil)
+
+(autoload 'mairix-search-from-this-article "mairix" "\
+Search messages from sender of the current article.
+This is effectively a shortcut for calling `mairix-search' with
+f:current_from. If prefix THREADS is non-nil, include whole
+threads.
+
+\(fn THREADS)" t nil)
+
+(autoload 'mairix-search-thread-this-article "mairix" "\
+Search thread for the current article.
+This is effectively a shortcut for calling `mairix-search'
+with m:msgid of the current article and enabled threads." t nil)
+
+(autoload 'mairix-widget-search-based-on-article "mairix" "\
+Create mairix query based on current article using widgets." t nil)
+
+(autoload 'mairix-edit-saved-searches "mairix" "\
+Edit current mairix searches." t nil)
+
+(autoload 'mairix-widget-search "mairix" "\
+Create mairix query interactively using graphical widgets.
+MVALUES may contain values from current article.
+
+\(fn &optional MVALUES)" t nil)
+
+(autoload 'mairix-update-database "mairix" "\
+Call mairix for updating the database for SERVERS.
+Mairix will be called asynchronously unless
+`mairix-synchronous-update' is t. Mairix will be called with
+`mairix-update-options'." t nil)
+
+(register-definition-prefixes "mairix" '("mairix-"))
;;;***
@@ -20369,14 +20978,7 @@ An adapted `makefile-mode' that knows about imake.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "make-mode" '("makefile-")))
-
-;;;***
-
-;;;### (autoloads nil "makeinfo" "textmodes/makeinfo.el" (0 0 0 0))
-;;; Generated autoloads from textmodes/makeinfo.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "makeinfo" '("makeinfo-")))
+(register-definition-prefixes "make-mode" '("makefile-"))
;;;***
@@ -20387,7 +20989,7 @@ An adapted `makefile-mode' that knows about imake.
Make a summary of current key bindings in the buffer *Summary*.
Previous contents of that buffer are killed first." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "makesum" '("double-column")))
+(register-definition-prefixes "makesum" '("double-column"))
;;;***
@@ -20442,36 +21044,44 @@ to auto-complete your input based on the installed manual pages.
(autoload 'man-follow "man" "\
Get a Un*x manual page of the item under point and put it in a buffer.
-\(fn MAN-ARGS)" t nil)
+\(fn MAN-ARGS)" '(man-common) nil)
(autoload 'Man-bookmark-jump "man" "\
Default bookmark handler for Man buffers.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "man" '("Man-" "man")))
+(register-definition-prefixes "man" '("Man-" "man"))
;;;***
;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/map.el
-(push (purecopy '(map 2 0)) package--builtin-versions)
+(push (purecopy '(map 3 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map-")))
+(register-definition-prefixes "map" '("map-"))
;;;***
;;;### (autoloads nil "master" "master.el" (0 0 0 0))
;;; Generated autoloads from master.el
-(push (purecopy '(master 1 0 2)) package--builtin-versions)
(autoload 'master-mode "master" "\
Toggle Master mode.
-If called interactively, enable Master mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Master
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `master-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Master mode is enabled, you can scroll the slave buffer
using the following commands:
@@ -20484,7 +21094,7 @@ yourself the value of `master-of' by calling `master-show-slave'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "master" '("master-")))
+(register-definition-prefixes "master" '("master-"))
;;;***
@@ -20504,10 +21114,20 @@ or call the function `minibuffer-depth-indicate-mode'.")
(autoload 'minibuffer-depth-indicate-mode "mb-depth" "\
Toggle Minibuffer Depth Indication mode.
-If called interactively, enable Minibuffer-Depth-Indicate mode if ARG
-is positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and toggle
-it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Minibuffer-Depth-Indicate mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'minibuffer-depth-indicate-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Minibuffer Depth Indication mode is a global minor mode. When
enabled, any recursive use of the minibuffer will show the
@@ -20516,15 +21136,29 @@ recursion depth in the minibuffer prompt. This is only useful if
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mb-depth" '("minibuffer-depth-")))
+(register-definition-prefixes "mb-depth" '("minibuffer-depth-"))
;;;***
;;;### (autoloads nil "md4" "md4.el" (0 0 0 0))
;;; Generated autoloads from md4.el
-(push (purecopy '(md4 1 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "md4" '("md4")))
+(register-definition-prefixes "md4" '("md4"))
+
+;;;***
+
+;;;### (autoloads nil "memory-report" "emacs-lisp/memory-report.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/memory-report.el
+
+(autoload 'memory-report "memory-report" "\
+Generate a report of how Emacs is using memory.
+
+This report is approximate, and will commonly over-count memory
+usage by variables, because shared data structures will usually
+by counted more than once." t nil)
+
+(register-definition-prefixes "memory-report" '("memory-report-"))
;;;***
@@ -20547,7 +21181,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 RETURN-ACTION &rest IGNORED)" t nil)
+\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest _)" t nil)
(autoload 'message-news "message" "\
Start editing a news article to be sent.
@@ -20650,7 +21284,16 @@ which specify the range to operate on.
\(fn START END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "message" '("message-" "nil")))
+(autoload 'message-mailto "message" "\
+Command to parse command line mailto: links.
+This is meant to be used for MIME handlers: Setting the handler
+for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\"
+will then start up Emacs ready to compose mail. For emacsclient use
+ emacsclient -e '(message-mailto \"%u\")'
+
+\(fn &optional URL)" t nil)
+
+(register-definition-prefixes "message" '("message-"))
;;;***
@@ -20669,71 +21312,28 @@ Major mode for editing MetaPost sources.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "meta-mode" '("font-lock-match-meta-declaration-item-and-skip-to-next" "meta")))
-
-;;;***
-
-;;;### (autoloads nil "metamail" "mail/metamail.el" (0 0 0 0))
-;;; Generated autoloads from mail/metamail.el
-
-(autoload 'metamail-interpret-header "metamail" "\
-Interpret a header part of a MIME message in current buffer.
-Its body part is not interpreted at all." t nil)
-
-(autoload 'metamail-interpret-body "metamail" "\
-Interpret a body part of a MIME message in current buffer.
-Optional argument VIEWMODE specifies the value of the
-EMACS_VIEW_MODE environment variable (defaulted to 1).
-Optional argument NODISPLAY non-nil means buffer is not
-redisplayed as output is inserted.
-Its header part is not interpreted at all.
-
-\(fn &optional VIEWMODE NODISPLAY)" t nil)
-
-(autoload 'metamail-buffer "metamail" "\
-Process current buffer through `metamail'.
-Optional argument VIEWMODE specifies the value of the
-EMACS_VIEW_MODE environment variable (defaulted to 1).
-Optional argument BUFFER specifies a buffer to be filled (nil
-means current).
-Optional argument NODISPLAY non-nil means buffer is not
-redisplayed as output is inserted.
-
-\(fn &optional VIEWMODE BUFFER NODISPLAY)" t nil)
-
-(autoload 'metamail-region "metamail" "\
-Process current region through `metamail'.
-Optional argument VIEWMODE specifies the value of the
-EMACS_VIEW_MODE environment variable (defaulted to 1).
-Optional argument BUFFER specifies a buffer to be filled (nil
-means current).
-Optional argument NODISPLAY non-nil means buffer is not
-redisplayed as output is inserted.
-
-\(fn BEG END &optional VIEWMODE BUFFER NODISPLAY)" t nil)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "metamail" '("metamail-")))
+(register-definition-prefixes "meta-mode" '("font-lock-match-meta-declaration-item-and-skip-to-next" "meta"))
;;;***
;;;### (autoloads nil "mh-acros" "mh-e/mh-acros.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-acros.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating")))
+(register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating"))
;;;***
;;;### (autoloads nil "mh-alias" "mh-e/mh-alias.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-alias.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-alias" '("mh-")))
+(register-definition-prefixes "mh-alias" '("mh-"))
;;;***
;;;### (autoloads nil "mh-buffers" "mh-e/mh-buffers.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-buffers.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-buffers" '("mh-")))
+(register-definition-prefixes "mh-buffers" '("mh-"))
;;;***
@@ -20818,14 +21418,14 @@ this command to kill the draft buffer and delete the draft
message. Use the command \\[kill-buffer] if you don't want to
delete the draft message." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-comp" '("mh-")))
+(register-definition-prefixes "mh-comp" '("mh-"))
;;;***
;;;### (autoloads nil "mh-compat" "mh-e/mh-compat.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-compat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-compat" '("mh-")))
+(register-definition-prefixes "mh-compat" '("mh-"))
;;;***
@@ -20842,7 +21442,7 @@ delete the draft message." t nil)
(autoload 'mh-version "mh-e" "\
Display version information about MH-E and the MH mail handling system." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-e" '("defcustom-mh" "defface-mh" "defgroup-mh" "mh-")))
+(register-definition-prefixes "mh-e" '("defcustom-mh" "defface-mh" "defgroup-mh" "mh-"))
;;;***
@@ -20925,14 +21525,14 @@ perform the operation on all messages in that region.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-folder" '("mh-")))
+(register-definition-prefixes "mh-folder" '("mh-"))
;;;***
;;;### (autoloads nil "mh-funcs" "mh-e/mh-funcs.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-funcs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-funcs" '("mh-")))
+(register-definition-prefixes "mh-funcs" '("mh-"))
;;;***
@@ -20940,91 +21540,91 @@ perform the operation on all messages in that region.
;;;;;; 0))
;;; Generated autoloads from mh-e/mh-identity.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-identity" '("mh-")))
+(register-definition-prefixes "mh-identity" '("mh-"))
;;;***
;;;### (autoloads nil "mh-inc" "mh-e/mh-inc.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-inc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-inc" '("mh-inc-spool-")))
+(register-definition-prefixes "mh-inc" '("mh-inc-spool-"))
;;;***
;;;### (autoloads nil "mh-junk" "mh-e/mh-junk.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-junk.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-junk" '("mh-")))
+(register-definition-prefixes "mh-junk" '("mh-"))
;;;***
;;;### (autoloads nil "mh-letter" "mh-e/mh-letter.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-letter.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-letter" '("mh-")))
+(register-definition-prefixes "mh-letter" '("mh-"))
;;;***
;;;### (autoloads nil "mh-limit" "mh-e/mh-limit.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-limit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-limit" '("mh-")))
+(register-definition-prefixes "mh-limit" '("mh-"))
;;;***
;;;### (autoloads nil "mh-mime" "mh-e/mh-mime.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-mime.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-mime" '("mh-")))
+(register-definition-prefixes "mh-mime" '("mh-"))
;;;***
;;;### (autoloads nil "mh-print" "mh-e/mh-print.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-print.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-print" '("mh-p")))
+(register-definition-prefixes "mh-print" '("mh-p"))
;;;***
;;;### (autoloads nil "mh-scan" "mh-e/mh-scan.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-scan.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-scan" '("mh-")))
+(register-definition-prefixes "mh-scan" '("mh-"))
;;;***
;;;### (autoloads nil "mh-search" "mh-e/mh-search.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-search.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-search" '("mh-")))
+(register-definition-prefixes "mh-search" '("mh-"))
;;;***
;;;### (autoloads nil "mh-seq" "mh-e/mh-seq.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-seq.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-seq" '("mh-")))
+(register-definition-prefixes "mh-seq" '("mh-"))
;;;***
;;;### (autoloads nil "mh-show" "mh-e/mh-show.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-show.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-show" '("mh-")))
+(register-definition-prefixes "mh-show" '("mh-"))
;;;***
;;;### (autoloads nil "mh-speed" "mh-e/mh-speed.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-speed.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-speed" '("mh-")))
+(register-definition-prefixes "mh-speed" '("mh-"))
;;;***
;;;### (autoloads nil "mh-thread" "mh-e/mh-thread.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-thread.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-thread" '("mh-")))
+(register-definition-prefixes "mh-thread" '("mh-"))
;;;***
@@ -21032,21 +21632,21 @@ perform the operation on all messages in that region.
;;;;;; 0))
;;; Generated autoloads from mh-e/mh-tool-bar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-tool-bar" '("mh-tool-bar-")))
+(register-definition-prefixes "mh-tool-bar" '("mh-tool-bar-"))
;;;***
;;;### (autoloads nil "mh-utils" "mh-e/mh-utils.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-utils.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-utils" '("mh-")))
+(register-definition-prefixes "mh-utils" '("mh-"))
;;;***
;;;### (autoloads nil "mh-xface" "mh-e/mh-xface.el" (0 0 0 0))
;;; Generated autoloads from mh-e/mh-xface.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mh-xface" '("mh-")))
+(register-definition-prefixes "mh-xface" '("mh-"))
;;;***
@@ -21063,7 +21663,7 @@ the rules from `css-mode'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mhtml-mode" '("mhtml-")))
+(register-definition-prefixes "mhtml-mode" '("mhtml-"))
;;;***
@@ -21083,10 +21683,19 @@ or call the function `midnight-mode'.")
(autoload 'midnight-mode "midnight" "\
Non-nil means run `midnight-hook' at midnight.
-If called interactively, enable Midnight mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Midnight
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'midnight-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -21109,7 +21718,7 @@ to its second argument TM.
\(fn SYMB TM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "midnight" '("clean-buffer-list-" "midnight-")))
+(register-definition-prefixes "midnight" '("clean-buffer-list-" "midnight-"))
;;;***
@@ -21129,10 +21738,20 @@ or call the function `minibuffer-electric-default-mode'.")
(autoload 'minibuffer-electric-default-mode "minibuf-eldef" "\
Toggle Minibuffer Electric Default mode.
-If called interactively, enable Minibuffer-Electric-Default mode if
-ARG is positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and toggle
-it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Minibuffer-Electric-Default mode' mode. If the prefix argument is
+positive, enable the mode, and if it is zero or negative, disable the
+mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'minibuffer-electric-default-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Minibuffer Electric Default mode is a global minor mode. When
enabled, minibuffer prompts that show a default value only show
@@ -21143,7 +21762,7 @@ is modified to remove the default indication.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "minibuf-eldef" '("minibuf")))
+(register-definition-prefixes "minibuf-eldef" '("minibuf"))
;;;***
@@ -21197,7 +21816,7 @@ upper atmosphere. These cause momentary pockets of higher-pressure
air to form, which act as lenses that deflect incoming cosmic rays,
focusing them to strike the drive platter and flip the desired bit.
You can type `M-x butterfly C-M-c' to run it. This is a permuted
-variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'." t nil)
+variation of `C-x M-c M-butterfly' from url `https://xkcd.com/378/'." t nil)
(autoload 'list-dynamic-libraries "misc" "\
Display a list of all dynamic libraries known to Emacs.
@@ -21210,7 +21829,7 @@ The return value is always nil.
\(fn &optional LOADED-ONLY-P BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misc" '("list-dynamic-libraries--")))
+(register-definition-prefixes "misc" '("list-dynamic-libraries--"))
;;;***
@@ -21260,6 +21879,9 @@ Sequence of files visited by multiple file buffers Isearch.")
Set up isearch to search multiple buffers.
Intended to be added to `isearch-mode-hook'." nil nil)
+(autoload 'multi-isearch-switch-buffer "misearch" "\
+Switch to the next buffer in multi-buffer search." nil nil)
+
(autoload 'multi-isearch-buffers "misearch" "\
Start multi-buffer Isearch on a list of BUFFERS.
This list can contain live buffers or their names.
@@ -21298,54 +21920,56 @@ whose file names match the specified wildcard.
\(fn FILES)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "misearch" '("misearch-unload-function" "multi-isearch-")))
+(register-definition-prefixes "misearch" '("misearch-unload-function" "multi-isearch-"))
;;;***
;;;### (autoloads nil "mixal-mode" "progmodes/mixal-mode.el" (0 0
;;;;;; 0 0))
;;; Generated autoloads from progmodes/mixal-mode.el
-(push (purecopy '(mixal-mode 0 1)) package--builtin-versions)
+(push (purecopy '(mixal-mode 0 4)) package--builtin-versions)
(autoload 'mixal-mode "mixal-mode" "\
Major mode for the mixal asm language.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mixal-mode" '("mixal-")))
+(register-definition-prefixes "mixal-mode" '("mixal-"))
;;;***
;;;### (autoloads nil "mm-archive" "gnus/mm-archive.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-archive.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-archive" '("mm-")))
+(register-definition-prefixes "mm-archive" '("mm-"))
;;;***
;;;### (autoloads nil "mm-bodies" "gnus/mm-bodies.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-bodies.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-bodies" '("mm-")))
+(register-definition-prefixes "mm-bodies" '("mm-"))
;;;***
;;;### (autoloads nil "mm-decode" "gnus/mm-decode.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-decode.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-decode" '("mm-")))
+(register-definition-prefixes "mm-decode" '("mm-"))
;;;***
;;;### (autoloads nil "mm-encode" "gnus/mm-encode.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-encode.el
-(autoload 'mm-default-file-encoding "mm-encode" "\
-Return a default encoding for FILE.
+(define-obsolete-function-alias 'mm-default-file-encoding #'mm-default-file-type "future")
+
+(autoload 'mm-default-file-type "mm-encode" "\
+Return a default content type for FILE.
\(fn FILE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-encode" '("mm-")))
+(register-definition-prefixes "mm-encode" '("mm-"))
;;;***
@@ -21365,7 +21989,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing.
\(fn HANDLE &optional NO-DISPLAY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-extern" '("mm-extern-")))
+(register-definition-prefixes "mm-extern" '("mm-extern-"))
;;;***
@@ -21380,7 +22004,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing.
\(fn HANDLE &optional NO-DISPLAY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-partial" '("mm-partial-find-parts")))
+(register-definition-prefixes "mm-partial" '("mm-partial-find-parts"))
;;;***
@@ -21398,14 +22022,14 @@ Insert file contents of URL using `mm-url-program'.
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-url" '("mm-url-")))
+(register-definition-prefixes "mm-url" '("mm-url-"))
;;;***
;;;### (autoloads nil "mm-util" "gnus/mm-util.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-util" '("mm-")))
+(register-definition-prefixes "mm-util" '("mm-"))
;;;***
@@ -21426,14 +22050,14 @@ Assume text has been decoded if DECODED is non-nil.
\(fn HANDLE &optional DECODED)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-uu" '("mm-")))
+(register-definition-prefixes "mm-uu" '("mm-"))
;;;***
;;;### (autoloads nil "mm-view" "gnus/mm-view.el" (0 0 0 0))
;;; Generated autoloads from gnus/mm-view.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mm-view" '("mm-")))
+(register-definition-prefixes "mm-view" '("mm-"))
;;;***
@@ -21462,21 +22086,21 @@ will be computed and used.
\(fn FILE &optional TYPE DESCRIPTION DISPOSITION)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml" '("mime-to-mml" "mml-")))
+(register-definition-prefixes "mml" '("mime-to-mml" "mml-"))
;;;***
;;;### (autoloads nil "mml-sec" "gnus/mml-sec.el" (0 0 0 0))
;;; Generated autoloads from gnus/mml-sec.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml-sec" '("mml-")))
+(register-definition-prefixes "mml-sec" '("mml-"))
;;;***
;;;### (autoloads nil "mml-smime" "gnus/mml-smime.el" (0 0 0 0))
;;; Generated autoloads from gnus/mml-smime.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml-smime" '("mml-smime-")))
+(register-definition-prefixes "mml-smime" '("mml-smime-"))
;;;***
@@ -21493,7 +22117,7 @@ will be computed and used.
\(fn CONT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml1991" '("mml1991-")))
+(register-definition-prefixes "mml1991" '("mml1991-"))
;;;***
@@ -21532,7 +22156,7 @@ will be computed and used.
(autoload 'mml2015-self-encrypt "mml2015" nil nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mml2015" '("mml2015-")))
+(register-definition-prefixes "mml2015" '("mml2015-"))
;;;***
@@ -21541,7 +22165,7 @@ will be computed and used.
(put 'define-overloadable-function 'doc-string-elt 3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mode-local" '("def" "describe-mode-local-bindings" "fetch-overload" "get-mode-local-parent" "make-obsolete-overload" "mode-local-" "setq-mode-local" "with-mode-local" "xref-mode-local-")))
+(register-definition-prefixes "mode-local" '("def" "describe-mode-local-bindings" "fetch-overload" "get-mode-local-parent" "make-obsolete-overload" "mode-local-" "setq-mode-local" "with-mode-local" "xref-mode-local-"))
;;;***
@@ -21576,7 +22200,7 @@ followed by the first character of the construct.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "modula2" '("m2-" "m3-font-lock-keywords")))
+(register-definition-prefixes "modula2" '("m2-" "m3-font-lock-keywords"))
;;;***
@@ -21603,14 +22227,14 @@ Convert NATO phonetic alphabet in region to ordinary ASCII text.
\(fn BEG END)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "morse" '("morse-code" "nato-alphabet")))
+(register-definition-prefixes "morse" '("morse-code" "nato-alphabet"))
;;;***
;;;### (autoloads nil "mouse-copy" "mouse-copy.el" (0 0 0 0))
;;; Generated autoloads from mouse-copy.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mouse-copy" '("mouse-")))
+(register-definition-prefixes "mouse-copy" '("mouse-"))
;;;***
@@ -21659,7 +22283,7 @@ To test this function, evaluate:
\(fn START-EVENT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mouse-drag" '("mouse-")))
+(register-definition-prefixes "mouse-drag" '("mouse-"))
;;;***
@@ -21669,7 +22293,7 @@ To test this function, evaluate:
(autoload 'mpc "mpc" "\
Main entry point for MPC." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpc" '("mpc-" "tag-browser-tagtypes")))
+(register-definition-prefixes "mpc" '("mpc-" "tag-browser-tagtypes"))
;;;***
@@ -21679,7 +22303,7 @@ Main entry point for MPC." t nil)
(autoload 'mpuz "mpuz" "\
Multiplication puzzle with GNU Emacs." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mpuz" '("mpuz-")))
+(register-definition-prefixes "mpuz" '("mpuz-"))
;;;***
@@ -21699,24 +22323,39 @@ or call the function `msb-mode'.")
(autoload 'msb-mode "msb" "\
Toggle Msb mode.
-If called interactively, enable Msb mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Msb mode'
+mode. If the prefix argument is positive, enable the mode, and if it
+is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'msb-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "msb" '("mouse-select-buffer" "msb")))
+(register-definition-prefixes "msb" '("mouse-select-buffer" "msb"))
;;;***
;;;### (autoloads nil "mspools" "mail/mspools.el" (0 0 0 0))
;;; Generated autoloads from mail/mspools.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mspools" '("mspools-")))
+(autoload 'mspools-show "mspools" "\
+Show the list of non-empty spool files in the *spools* buffer.
+Buffer is not displayed if SHOW is non-nil.
+
+\(fn &optional NOSHOW)" t nil)
+
+(register-definition-prefixes "mspools" '("mspools-"))
;;;***
@@ -21840,7 +22479,7 @@ The default is 20. If LIMIT is negative, do not limit the listing.
\(fn &optional LIMIT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-diag" '("charset-history" "describe-font-internal" "insert-section" "list-" "non-iso-charset-alist" "print-" "sort-listed-character-sets")))
+(register-definition-prefixes "mule-diag" '("charset-history" "describe-font-internal" "insert-section" "list-" "print-" "sort-listed-character-sets"))
;;;***
@@ -21875,7 +22514,7 @@ If ELLIPSIS is non-nil, it should be a string which will replace the
end of STR (including any padding) if it extends beyond END-COLUMN,
unless the display width of STR is equal to or less than the display
width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
-defaults to `truncate-string-ellipsis'.
+defaults to `truncate-string-ellipsis', or to three dots when it's nil.
If ELLIPSIS-TEXT-PROPERTY is non-nil, a too-long string will not
be truncated, but instead the elided parts will be covered by a
@@ -21945,16 +22584,8 @@ This affects the implicit sorting of lists of coding systems returned by
operations such as `find-coding-systems-region'.
\(fn CODING-SYSTEMS &rest BODY)" nil t)
-(put 'with-coding-priority 'lisp-indent-function 1)
-
-(autoload 'detect-coding-with-priority "mule-util" "\
-Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
-PRIORITY-LIST is an alist of coding categories vs the corresponding
-coding systems ordered by priority.
-
-\(fn FROM TO PRIORITY-LIST)" nil t)
-(make-obsolete 'detect-coding-with-priority 'with-coding-priority '"23.1")
+(function-put 'with-coding-priority 'lisp-indent-function '1)
(autoload 'detect-coding-with-language-environment "mule-util" "\
Detect a coding system for the text between FROM and TO with LANG-ENV.
@@ -21991,14 +22622,43 @@ QUALITY can be:
\(fn POSITION &optional QUALITY CODING-SYSTEM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mule-util" '("filepos-to-bufferpos--dos" "truncate-string-ellipsis")))
+(register-definition-prefixes "mule-util" '("filepos-to-bufferpos--dos" "truncate-string-ellipsis"))
;;;***
;;;### (autoloads nil "mwheel" "mwheel.el" (0 0 0 0))
;;; Generated autoloads from mwheel.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-")))
+(defcustom mouse-wheel-mode t "\
+Non-nil if Mouse-Wheel mode is enabled.
+See the `mouse-wheel-mode' command
+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 `mouse-wheel-mode'." :set #'custom-set-minor-mode :initialize 'custom-initialize-delay :type 'boolean :group 'mouse)
+
+(custom-autoload 'mouse-wheel-mode "mwheel" nil)
+
+(autoload 'mouse-wheel-mode "mwheel" "\
+Toggle mouse wheel support (Mouse Wheel mode).
+
+This is a minor mode. If called interactively, toggle the
+`Mouse-Wheel mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'mouse-wheel-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
+(register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-"))
;;;***
@@ -22128,7 +22788,7 @@ Open a network connection to HOST on PORT.
\(fn HOST PORT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "ipconfig" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-")))
+(register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "ipconfig" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-"))
;;;***
@@ -22142,7 +22802,7 @@ listed in the PORTS list.
\(fn MACHINE &rest PORTS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "netrc" '("netrc-")))
+(register-definition-prefixes "netrc" '("netrc-"))
;;;***
@@ -22186,6 +22846,10 @@ values:
`ssl' -- Equivalent to `tls'.
`shell' -- A shell connection.
+:coding is a symbol or a cons used to specify the coding systems
+used to decode and encode the data which the process reads and
+writes. See `make-network-process' for details.
+
: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
@@ -22208,7 +22872,10 @@ values:
:capability-command specifies a command used to query the HOST
for its capabilities. For instance, for IMAP this should be
- \"1 CAPABILITY\\r\\n\".
+ \"1 CAPABILITY\\r\\n\". This can either be a string (which will
+ then be sent verbatim to the server), or a function (called with
+ a single parameter; the \"greeting\" from the server when connecting),
+ and should return a string to send to the server.
:starttls-function specifies a function for handling STARTTLS.
This function should take one parameter, the response to the
@@ -22239,8 +22906,8 @@ a greeting from the server.
:nowait, if non-nil, says the connection should be made
asynchronously, if possible.
-:shell-command is a format-spec string that can be used if :type
-is `shell'. It has two specs, %s for host and %p for port
+:shell-command is a `format-spec' string that can be used if
+:type is `shell'. It has two specs, %s for host and %p for port
number. Example: \"ssh gateway nc %s %p\".
:tls-parameters is a list that should be supplied if you're
@@ -22251,9 +22918,9 @@ gnutls-boot (as returned by `gnutls-boot-parameters').
\(fn NAME BUFFER HOST SERVICE &rest PARAMETERS)" nil nil)
-(defalias 'open-protocol-stream 'open-network-stream)
+(define-obsolete-function-alias 'open-protocol-stream #'open-network-stream "26.1")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "network-stream" '("network-stream-")))
+(register-definition-prefixes "network-stream" '("network-stream-"))
;;;***
@@ -22275,7 +22942,7 @@ Run `newsticker-start-hook' if newsticker was not running already.
\(fn &optional DO-NOT-COMPLAIN-IF-RUNNING)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-backend" '("newsticker-")))
+(register-definition-prefixes "newst-backend" '("newsticker-"))
;;;***
@@ -22286,7 +22953,7 @@ Run `newsticker-start-hook' if newsticker was not running already.
(autoload 'newsticker-plainview "newst-plainview" "\
Start newsticker plainview." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-plainview" '("newsticker-")))
+(register-definition-prefixes "newst-plainview" '("newsticker-"))
;;;***
@@ -22297,7 +22964,7 @@ Start newsticker plainview." t nil)
(autoload 'newsticker-show-news "newst-reader" "\
Start reading news. You may want to bind this to a key." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-reader" '("newsticker-")))
+(register-definition-prefixes "newst-reader" '("newsticker-"))
;;;***
@@ -22316,7 +22983,7 @@ Start newsticker's ticker (but not the news retrieval).
Start display timer for the actual ticker if wanted and not
running already." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-ticker" '("newsticker-")))
+(register-definition-prefixes "newst-ticker" '("newsticker-"))
;;;***
@@ -22327,28 +22994,28 @@ running already." t nil)
(autoload 'newsticker-treeview "newst-treeview" "\
Start newsticker treeview." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newst-treeview" '("newsticker-")))
+(register-definition-prefixes "newst-treeview" '("newsticker-"))
;;;***
;;;### (autoloads nil "newsticker" "net/newsticker.el" (0 0 0 0))
;;; Generated autoloads from net/newsticker.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "newsticker" '("newsticker-version")))
+(register-definition-prefixes "newsticker" '("newsticker-version"))
;;;***
;;;### (autoloads nil "nnagent" "gnus/nnagent.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnagent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnagent" '("nnagent-")))
+(register-definition-prefixes "nnagent" '("nnagent-"))
;;;***
;;;### (autoloads nil "nnbabyl" "gnus/nnbabyl.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnbabyl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnbabyl" '("nnbabyl-")))
+(register-definition-prefixes "nnbabyl" '("nnbabyl-"))
;;;***
@@ -22360,14 +23027,14 @@ Generate NOV databases in all nndiary directories.
\(fn &optional SERVER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nndiary" '("nndiary-")))
+(register-definition-prefixes "nndiary" '("nndiary-"))
;;;***
;;;### (autoloads nil "nndir" "gnus/nndir.el" (0 0 0 0))
;;; Generated autoloads from gnus/nndir.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nndir" '("nndir-")))
+(register-definition-prefixes "nndir" '("nndir-"))
;;;***
@@ -22383,21 +23050,21 @@ symbol in the alist.
\(fn DEFINITION &optional POSITION)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nndoc" '("nndoc-")))
+(register-definition-prefixes "nndoc" '("nndoc-"))
;;;***
;;;### (autoloads nil "nndraft" "gnus/nndraft.el" (0 0 0 0))
;;; Generated autoloads from gnus/nndraft.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nndraft" '("nndraft-")))
+(register-definition-prefixes "nndraft" '("nndraft-"))
;;;***
;;;### (autoloads nil "nneething" "gnus/nneething.el" (0 0 0 0))
;;; Generated autoloads from gnus/nneething.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nneething" '("nneething-")))
+(register-definition-prefixes "nneething" '("nneething-"))
;;;***
@@ -22408,70 +23075,63 @@ symbol in the alist.
Look for mbox folders in the nnfolder directory and make them into groups.
This command does not work if you use short group names." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnfolder" '("nnfolder-")))
+(register-definition-prefixes "nnfolder" '("nnfolder-"))
;;;***
;;;### (autoloads nil "nngateway" "gnus/nngateway.el" (0 0 0 0))
;;; Generated autoloads from gnus/nngateway.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nngateway" '("nngateway-")))
+(register-definition-prefixes "nngateway" '("nngateway-"))
;;;***
;;;### (autoloads nil "nnheader" "gnus/nnheader.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnheader.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnheader" '("gnus-" "mail-header-" "make-mail-header" "nnheader-" "nntp-")))
+(register-definition-prefixes "nnheader" '("gnus-" "mail-header-" "make-mail-header" "nnheader-" "nntp-"))
;;;***
;;;### (autoloads nil "nnimap" "gnus/nnimap.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnimap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnimap" '("nnimap-")))
-
-;;;***
-
-;;;### (autoloads nil "nnir" "gnus/nnir.el" (0 0 0 0))
-;;; Generated autoloads from gnus/nnir.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnir" '("gnus-" "nnir-")))
+(register-definition-prefixes "nnimap" '("nnimap-"))
;;;***
;;;### (autoloads nil "nnmail" "gnus/nnmail.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnmail.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnmail" '("nnmail-")))
+(register-definition-prefixes "nnmail" '("nnmail-"))
;;;***
;;;### (autoloads nil "nnmaildir" "gnus/nnmaildir.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnmaildir.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnmaildir" '("nnmaildir-")))
+(register-definition-prefixes "nnmaildir" '("nnmaildir-"))
;;;***
;;;### (autoloads nil "nnmairix" "gnus/nnmairix.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnmairix.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnmairix" '("nnmairix-")))
+(register-definition-prefixes "nnmairix" '("nnmairix-"))
;;;***
;;;### (autoloads nil "nnmbox" "gnus/nnmbox.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnmbox.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnmbox" '("nnmbox-")))
+(register-definition-prefixes "nnmbox" '("nnmbox-"))
;;;***
;;;### (autoloads nil "nnmh" "gnus/nnmh.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnmh.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnmh" '("nnmh-")))
+(register-definition-prefixes "nnmh" '("nnmh-"))
;;;***
@@ -22483,70 +23143,77 @@ Generate NOV databases in all nnml directories.
\(fn &optional SERVER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnml" '("nnml-")))
+(register-definition-prefixes "nnml" '("nnml-"))
;;;***
;;;### (autoloads nil "nnnil" "gnus/nnnil.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnnil.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnnil" '("nnnil-")))
+(register-definition-prefixes "nnnil" '("nnnil-"))
;;;***
;;;### (autoloads nil "nnoo" "gnus/nnoo.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnoo.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnoo" '("deffoo" "defvoo" "nnoo-")))
+(register-definition-prefixes "nnoo" '("deffoo" "defvoo" "nnoo-" "noo--defalias"))
;;;***
;;;### (autoloads nil "nnregistry" "gnus/nnregistry.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnregistry.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnregistry" '("nnregistry-")))
+(register-definition-prefixes "nnregistry" '("nnregistry-"))
;;;***
;;;### (autoloads nil "nnrss" "gnus/nnrss.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnrss.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnrss" '("nnrss-")))
+(register-definition-prefixes "nnrss" '("nnrss-"))
+
+;;;***
+
+;;;### (autoloads nil "nnselect" "gnus/nnselect.el" (0 0 0 0))
+;;; Generated autoloads from gnus/nnselect.el
+
+(register-definition-prefixes "nnselect" '("gnus-" "ids-by-group" "nnselect-" "numbers-by-group"))
;;;***
;;;### (autoloads nil "nnspool" "gnus/nnspool.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnspool.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnspool" '("news-inews-program" "nnspool-")))
+(register-definition-prefixes "nnspool" '("news-inews-program" "nnspool-"))
;;;***
;;;### (autoloads nil "nntp" "gnus/nntp.el" (0 0 0 0))
;;; Generated autoloads from gnus/nntp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nntp" '("nntp-")))
+(register-definition-prefixes "nntp" '("nntp-"))
;;;***
;;;### (autoloads nil "nnvirtual" "gnus/nnvirtual.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnvirtual.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnvirtual" '("nnvirtual-")))
+(register-definition-prefixes "nnvirtual" '("nnvirtual-"))
;;;***
;;;### (autoloads nil "nnweb" "gnus/nnweb.el" (0 0 0 0))
;;; Generated autoloads from gnus/nnweb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nnweb" '("nnweb-")))
+(register-definition-prefixes "nnweb" '("nnweb-"))
;;;***
;;;### (autoloads nil "notifications" "notifications.el" (0 0 0 0))
;;; Generated autoloads from notifications.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "notifications" '("notifications-")))
+(register-definition-prefixes "notifications" '("notifications-"))
;;;***
@@ -22578,7 +23245,7 @@ future sessions.
\(fn COMMAND)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "novice" '("en/disable-command")))
+(register-definition-prefixes "novice" '("en/disable-command"))
;;;***
@@ -22595,14 +23262,14 @@ closing requests for requests that are used in matched pairs.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nroff-mode" '("nroff-")))
+(register-definition-prefixes "nroff-mode" '("nroff-"))
;;;***
;;;### (autoloads nil "nsm" "net/nsm.el" (0 0 0 0))
;;; Generated autoloads from net/nsm.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nsm" '("network-security-" "nsm-")))
+(register-definition-prefixes "nsm" '("network-security-" "nsm-"))
;;;***
@@ -22610,21 +23277,21 @@ closing requests for requests that are used in matched pairs.
;;; Generated autoloads from net/ntlm.el
(push (purecopy '(ntlm 2 1 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ntlm" '("ntlm-")))
+(register-definition-prefixes "ntlm" '("ntlm-"))
;;;***
;;;### (autoloads nil "nxml-enc" "nxml/nxml-enc.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-enc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-enc" '("nxml-")))
+(register-definition-prefixes "nxml-enc" '("nxml-"))
;;;***
;;;### (autoloads nil "nxml-maint" "nxml/nxml-maint.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-maint.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-maint" '("nxml-insert-target-repertoire-glyph-set")))
+(register-definition-prefixes "nxml-maint" '("nxml-insert-target-repertoire-glyph-set"))
;;;***
@@ -22685,70 +23352,70 @@ Many aspects this mode can be customized using
\(fn)" t nil)
(defalias 'xml-mode 'nxml-mode)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-mode" '("nxml-")))
+(register-definition-prefixes "nxml-mode" '("nxml-"))
;;;***
;;;### (autoloads nil "nxml-ns" "nxml/nxml-ns.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-ns.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-ns" '("nxml-ns-")))
+(register-definition-prefixes "nxml-ns" '("nxml-ns-"))
;;;***
;;;### (autoloads nil "nxml-outln" "nxml/nxml-outln.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-outln.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-outln" '("nxml-")))
+(register-definition-prefixes "nxml-outln" '("nxml-"))
;;;***
;;;### (autoloads nil "nxml-parse" "nxml/nxml-parse.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-parse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-parse" '("nxml-")))
+(register-definition-prefixes "nxml-parse" '("nxml-"))
;;;***
;;;### (autoloads nil "nxml-rap" "nxml/nxml-rap.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-rap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-rap" '("nxml-")))
+(register-definition-prefixes "nxml-rap" '("nxml-"))
;;;***
;;;### (autoloads nil "nxml-util" "nxml/nxml-util.el" (0 0 0 0))
;;; Generated autoloads from nxml/nxml-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nxml-util" '("nxml-")))
+(register-definition-prefixes "nxml-util" '("nxml-"))
;;;***
;;;### (autoloads nil "ob-C" "org/ob-C.el" (0 0 0 0))
;;; Generated autoloads from org/ob-C.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-C" '("org-babel-")))
+(register-definition-prefixes "ob-C" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-J" "org/ob-J.el" (0 0 0 0))
;;; Generated autoloads from org/ob-J.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-J" '("obj-" "org-babel-")))
+(register-definition-prefixes "ob-J" '("obj-" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-R" "org/ob-R.el" (0 0 0 0))
;;; Generated autoloads from org/ob-R.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-R" '("ob-R-" "org-babel-")))
+(register-definition-prefixes "ob-R" '("ob-R-" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-abc" "org/ob-abc.el" (0 0 0 0))
;;; Generated autoloads from org/ob-abc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-abc" '("org-babel-")))
+(register-definition-prefixes "ob-abc" '("org-babel-"))
;;;***
@@ -22756,78 +23423,70 @@ Many aspects this mode can be customized using
;;;;;; 0))
;;; Generated autoloads from org/ob-asymptote.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-asymptote" '("org-babel-")))
+(register-definition-prefixes "ob-asymptote" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-awk" "org/ob-awk.el" (0 0 0 0))
;;; Generated autoloads from org/ob-awk.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-awk" '("org-babel-")))
+(register-definition-prefixes "ob-awk" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-calc" "org/ob-calc.el" (0 0 0 0))
;;; Generated autoloads from org/ob-calc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-calc" '("org-babel-")))
+(register-definition-prefixes "ob-calc" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-clojure" "org/ob-clojure.el" (0 0 0 0))
;;; Generated autoloads from org/ob-clojure.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-clojure" '("ob-clojure-" "org-babel-")))
+(register-definition-prefixes "ob-clojure" '("ob-clojure-" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-comint" "org/ob-comint.el" (0 0 0 0))
;;; Generated autoloads from org/ob-comint.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-comint" '("org-babel-comint-")))
+(register-definition-prefixes "ob-comint" '("org-babel-comint-"))
;;;***
;;;### (autoloads nil "ob-coq" "org/ob-coq.el" (0 0 0 0))
;;; Generated autoloads from org/ob-coq.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-coq" '("coq-program-name" "org-babel-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ob-core" "org/ob-core.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ob-core.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-core" '("org-")))
+(register-definition-prefixes "ob-coq" '("coq-program-name" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-css" "org/ob-css.el" (0 0 0 0))
;;; Generated autoloads from org/ob-css.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-css" '("org-babel-")))
+(register-definition-prefixes "ob-css" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ditaa" "org/ob-ditaa.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ditaa.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ditaa" '("org-")))
+(register-definition-prefixes "ob-ditaa" '("org-"))
;;;***
;;;### (autoloads nil "ob-dot" "org/ob-dot.el" (0 0 0 0))
;;; Generated autoloads from org/ob-dot.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-dot" '("org-babel-")))
+(register-definition-prefixes "ob-dot" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ebnf" "org/ob-ebnf.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ebnf.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ebnf" '("org-babel-")))
+(register-definition-prefixes "ob-ebnf" '("org-babel-"))
;;;***
@@ -22835,197 +23494,189 @@ Many aspects this mode can be customized using
;;;;;; 0 0))
;;; Generated autoloads from org/ob-emacs-lisp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-emacs-lisp" '("org-babel-")))
+(register-definition-prefixes "ob-emacs-lisp" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-eshell" "org/ob-eshell.el" (0 0 0 0))
;;; Generated autoloads from org/ob-eshell.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-eshell" '("ob-eshell-session-live-p" "org-babel-")))
+(register-definition-prefixes "ob-eshell" '("ob-eshell-session-live-p" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-eval" "org/ob-eval.el" (0 0 0 0))
;;; Generated autoloads from org/ob-eval.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-eval" '("org-babel-")))
+(register-definition-prefixes "ob-eval" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-exp" "org/ob-exp.el" (0 0 0 0))
;;; Generated autoloads from org/ob-exp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-exp" '("org-")))
+(register-definition-prefixes "ob-exp" '("org-"))
;;;***
;;;### (autoloads nil "ob-forth" "org/ob-forth.el" (0 0 0 0))
;;; Generated autoloads from org/ob-forth.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-forth" '("org-babel-")))
+(register-definition-prefixes "ob-forth" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-fortran" "org/ob-fortran.el" (0 0 0 0))
;;; Generated autoloads from org/ob-fortran.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-fortran" '("org-babel-")))
+(register-definition-prefixes "ob-fortran" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-gnuplot" "org/ob-gnuplot.el" (0 0 0 0))
;;; Generated autoloads from org/ob-gnuplot.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-gnuplot" '("*org-babel-gnuplot-" "org-babel-")))
+(register-definition-prefixes "ob-gnuplot" '("*org-babel-gnuplot-" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-groovy" "org/ob-groovy.el" (0 0 0 0))
;;; Generated autoloads from org/ob-groovy.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-groovy" '("org-babel-")))
+(register-definition-prefixes "ob-groovy" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-haskell" "org/ob-haskell.el" (0 0 0 0))
;;; Generated autoloads from org/ob-haskell.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-haskell" '("org-babel-")))
+(register-definition-prefixes "ob-haskell" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-hledger" "org/ob-hledger.el" (0 0 0 0))
;;; Generated autoloads from org/ob-hledger.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-hledger" '("org-babel-")))
+(register-definition-prefixes "ob-hledger" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-io" "org/ob-io.el" (0 0 0 0))
;;; Generated autoloads from org/ob-io.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-io" '("org-babel-")))
+(register-definition-prefixes "ob-io" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-java" "org/ob-java.el" (0 0 0 0))
;;; Generated autoloads from org/ob-java.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-java" '("org-babel-")))
+(register-definition-prefixes "ob-java" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-js" "org/ob-js.el" (0 0 0 0))
;;; Generated autoloads from org/ob-js.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-js" '("org-babel-")))
+(register-definition-prefixes "ob-js" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-latex" "org/ob-latex.el" (0 0 0 0))
;;; Generated autoloads from org/ob-latex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-latex" '("org-babel-")))
+(register-definition-prefixes "ob-latex" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ledger" "org/ob-ledger.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ledger.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ledger" '("org-babel-")))
+(register-definition-prefixes "ob-ledger" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-lilypond" "org/ob-lilypond.el" (0 0 0 0))
;;; Generated autoloads from org/ob-lilypond.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lilypond" '("lilypond-mode" "org-babel-")))
+(register-definition-prefixes "ob-lilypond" '("lilypond-mode" "org-babel-"))
;;;***
;;;### (autoloads nil "ob-lisp" "org/ob-lisp.el" (0 0 0 0))
;;; Generated autoloads from org/ob-lisp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lisp" '("org-babel-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ob-lob" "org/ob-lob.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ob-lob.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lob" '("org-babel-")))
+(register-definition-prefixes "ob-lisp" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-lua" "org/ob-lua.el" (0 0 0 0))
;;; Generated autoloads from org/ob-lua.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-lua" '("org-babel-")))
+(register-definition-prefixes "ob-lua" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-makefile" "org/ob-makefile.el" (0 0 0 0))
;;; Generated autoloads from org/ob-makefile.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-makefile" '("org-babel-")))
+(register-definition-prefixes "ob-makefile" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-maxima" "org/ob-maxima.el" (0 0 0 0))
;;; Generated autoloads from org/ob-maxima.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-maxima" '("org-babel-")))
+(register-definition-prefixes "ob-maxima" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-mscgen" "org/ob-mscgen.el" (0 0 0 0))
;;; Generated autoloads from org/ob-mscgen.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-mscgen" '("org-babel-")))
+(register-definition-prefixes "ob-mscgen" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ocaml" "org/ob-ocaml.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ocaml.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ocaml" '("org-babel-")))
+(register-definition-prefixes "ob-ocaml" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-octave" "org/ob-octave.el" (0 0 0 0))
;;; Generated autoloads from org/ob-octave.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-octave" '("org-babel-")))
+(register-definition-prefixes "ob-octave" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-org" "org/ob-org.el" (0 0 0 0))
;;; Generated autoloads from org/ob-org.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-org" '("org-babel-")))
+(register-definition-prefixes "ob-org" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-perl" "org/ob-perl.el" (0 0 0 0))
;;; Generated autoloads from org/ob-perl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-perl" '("org-babel-")))
+(register-definition-prefixes "ob-perl" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-picolisp" "org/ob-picolisp.el" (0 0 0 0))
;;; Generated autoloads from org/ob-picolisp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-picolisp" '("org-babel-")))
+(register-definition-prefixes "ob-picolisp" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-plantuml" "org/ob-plantuml.el" (0 0 0 0))
;;; Generated autoloads from org/ob-plantuml.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-plantuml" '("org-")))
+(register-definition-prefixes "ob-plantuml" '("org-"))
;;;***
@@ -23033,113 +23684,105 @@ Many aspects this mode can be customized using
;;;;;; 0 0))
;;; Generated autoloads from org/ob-processing.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-processing" '("org-babel-")))
+(register-definition-prefixes "ob-processing" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-python" "org/ob-python.el" (0 0 0 0))
;;; Generated autoloads from org/ob-python.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-python" '("org-babel-")))
+(register-definition-prefixes "ob-python" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ref" "org/ob-ref.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ref.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ref" '("org-babel-")))
+(register-definition-prefixes "ob-ref" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-ruby" "org/ob-ruby.el" (0 0 0 0))
;;; Generated autoloads from org/ob-ruby.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-ruby" '("org-babel-")))
+(register-definition-prefixes "ob-ruby" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-sass" "org/ob-sass.el" (0 0 0 0))
;;; Generated autoloads from org/ob-sass.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-sass" '("org-babel-")))
+(register-definition-prefixes "ob-sass" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-scheme" "org/ob-scheme.el" (0 0 0 0))
;;; Generated autoloads from org/ob-scheme.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-scheme" '("org-babel-")))
+(register-definition-prefixes "ob-scheme" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-screen" "org/ob-screen.el" (0 0 0 0))
;;; Generated autoloads from org/ob-screen.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-screen" '("org-babel-")))
+(register-definition-prefixes "ob-screen" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-sed" "org/ob-sed.el" (0 0 0 0))
;;; Generated autoloads from org/ob-sed.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-sed" '("org-babel-")))
+(register-definition-prefixes "ob-sed" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-shell" "org/ob-shell.el" (0 0 0 0))
;;; Generated autoloads from org/ob-shell.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-shell" '("org-babel-")))
+(register-definition-prefixes "ob-shell" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-shen" "org/ob-shen.el" (0 0 0 0))
;;; Generated autoloads from org/ob-shen.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-shen" '("org-babel-")))
+(register-definition-prefixes "ob-shen" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-sql" "org/ob-sql.el" (0 0 0 0))
;;; Generated autoloads from org/ob-sql.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-sql" '("org-babel-")))
+(register-definition-prefixes "ob-sql" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-sqlite" "org/ob-sqlite.el" (0 0 0 0))
;;; Generated autoloads from org/ob-sqlite.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-sqlite" '("org-babel-")))
+(register-definition-prefixes "ob-sqlite" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-stan" "org/ob-stan.el" (0 0 0 0))
;;; Generated autoloads from org/ob-stan.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-stan" '("org-babel-")))
+(register-definition-prefixes "ob-stan" '("org-babel-"))
;;;***
;;;### (autoloads nil "ob-table" "org/ob-table.el" (0 0 0 0))
;;; Generated autoloads from org/ob-table.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-table" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ob-tangle" "org/ob-tangle.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ob-tangle.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-tangle" '("org-babel-")))
+(register-definition-prefixes "ob-table" '("org-"))
;;;***
;;;### (autoloads nil "ob-vala" "org/ob-vala.el" (0 0 0 0))
;;; Generated autoloads from org/ob-vala.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ob-vala" '("org-babel-")))
+(register-definition-prefixes "ob-vala" '("org-babel-"))
;;;***
@@ -23182,101 +23825,77 @@ startup file, `~/.emacs-octave'.
(defalias 'run-octave 'inferior-octave)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "octave" '("inferior-octave-" "octave-")))
+(register-definition-prefixes "octave" '("inferior-octave-" "octave-"))
;;;***
;;;### (autoloads nil "ogonek" "international/ogonek.el" (0 0 0 0))
;;; Generated autoloads from international/ogonek.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ogonek" '("ogonek-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ol" "org/ol.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ol.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ol-bbdb" "org/ol-bbdb.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ol-bbdb.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-bbdb" '("org-bbdb-")))
+(register-definition-prefixes "ogonek" '("ogonek-"))
;;;***
;;;### (autoloads nil "ol-bibtex" "org/ol-bibtex.el" (0 0 0 0))
;;; Generated autoloads from org/ol-bibtex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-bibtex" '("org-")))
+(register-definition-prefixes "ol-bibtex" '("org-"))
;;;***
;;;### (autoloads nil "ol-docview" "org/ol-docview.el" (0 0 0 0))
;;; Generated autoloads from org/ol-docview.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-docview" '("org-docview-")))
+(register-definition-prefixes "ol-docview" '("org-docview-"))
;;;***
;;;### (autoloads nil "ol-eshell" "org/ol-eshell.el" (0 0 0 0))
;;; Generated autoloads from org/ol-eshell.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-eshell" '("org-eshell-")))
+(register-definition-prefixes "ol-eshell" '("org-eshell-"))
;;;***
;;;### (autoloads nil "ol-eww" "org/ol-eww.el" (0 0 0 0))
;;; Generated autoloads from org/ol-eww.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-eww" '("org-eww-")))
+(register-definition-prefixes "ol-eww" '("org-eww-"))
;;;***
;;;### (autoloads nil "ol-gnus" "org/ol-gnus.el" (0 0 0 0))
;;; Generated autoloads from org/ol-gnus.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-gnus" '("org-gnus-")))
+(register-definition-prefixes "ol-gnus" '("org-gnus-"))
;;;***
;;;### (autoloads nil "ol-info" "org/ol-info.el" (0 0 0 0))
;;; Generated autoloads from org/ol-info.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-info" '("org-info-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ol-irc" "org/ol-irc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ol-irc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-irc" '("org-irc-")))
+(register-definition-prefixes "ol-info" '("org-info-"))
;;;***
;;;### (autoloads nil "ol-mhe" "org/ol-mhe.el" (0 0 0 0))
;;; Generated autoloads from org/ol-mhe.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-mhe" '("org-mhe-")))
+(register-definition-prefixes "ol-mhe" '("org-mhe-"))
;;;***
;;;### (autoloads nil "ol-rmail" "org/ol-rmail.el" (0 0 0 0))
;;; Generated autoloads from org/ol-rmail.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-rmail" '("org-rmail-")))
+(register-definition-prefixes "ol-rmail" '("org-rmail-"))
;;;***
;;;### (autoloads nil "ol-w3m" "org/ol-w3m.el" (0 0 0 0))
;;; Generated autoloads from org/ol-w3m.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ol-w3m" '("org-w3m-")))
+(register-definition-prefixes "ol-w3m" '("org-w3m-"))
;;;***
@@ -23313,7 +23932,7 @@ Coloring:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "opascal" '("opascal-")))
+(register-definition-prefixes "opascal" '("opascal-"))
;;;***
@@ -23513,7 +24132,7 @@ With prefix arg UNCOMPILED, load the uncompiled versions.
(autoload 'org-customize "org" "\
Call the customize function with org as argument." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org" '("org-" "turn-on-org-cdlatex")))
+(register-definition-prefixes "org" '("org-" "turn-on-org-cdlatex"))
;;;***
@@ -23789,23 +24408,7 @@ to override `appt-message-warning-time'.
\(fn &optional REFRESH FILTER &rest ARGS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-agenda" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-archive"
-;;;;;; "org/org-archive.el" (0 0 0 0))
-;;; Generated autoloads from org/org-archive.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-archive" '("org-a")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-attach" "org/org-attach.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-attach.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-attach" '("org-attach-")))
+(register-definition-prefixes "org-agenda" '("org-"))
;;;***
@@ -23813,7 +24416,7 @@ to override `appt-message-warning-time'.
;;;;;; 0 0 0))
;;; Generated autoloads from org/org-attach-git.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-attach-git" '("org-attach-git-")))
+(register-definition-prefixes "org-attach-git" '("org-attach-git-"))
;;;***
@@ -23859,31 +24462,7 @@ of the day at point (if any) or the current HH:MM time.
(autoload 'org-capture-import-remember-templates "org-capture" "\
Set `org-capture-templates' to be similar to `org-remember-templates'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-capture" '("org-capture-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-clock" "org/org-clock.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-clock.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-clock" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-colview"
-;;;;;; "org/org-colview.el" (0 0 0 0))
-;;; Generated autoloads from org/org-colview.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-colview" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-compat" "org/org-compat.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-compat.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-compat" '("org-")))
+(register-definition-prefixes "org-capture" '("org-capture-"))
;;;***
@@ -23905,38 +24484,14 @@ Decrypt all entries in the current buffer." t nil)
(autoload 'org-crypt-use-before-save-magic "org-crypt" "\
Add a hook to automatically encrypt entries before a file is saved to disk." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-crypt" '("org-")))
+(register-definition-prefixes "org-crypt" '("org-"))
;;;***
;;;### (autoloads nil "org-ctags" "org/org-ctags.el" (0 0 0 0))
;;; Generated autoloads from org/org-ctags.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-ctags" '("org-ctags-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-datetree"
-;;;;;; "org/org-datetree.el" (0 0 0 0))
-;;; Generated autoloads from org/org-datetree.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-datetree" '("org-datetree-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-duration"
-;;;;;; "org/org-duration.el" (0 0 0 0))
-;;; Generated autoloads from org/org-duration.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-duration" '("org-duration-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-element"
-;;;;;; "org/org-element.el" (0 0 0 0))
-;;; Generated autoloads from org/org-element.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-element" '("org-element-")))
+(register-definition-prefixes "org-ctags" '("org-ctags-"))
;;;***
@@ -23944,61 +24499,21 @@ Add a hook to automatically encrypt entries before a file is saved to disk." nil
;;;;;; 0))
;;; Generated autoloads from org/org-entities.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-entities" '("org-entit")))
+(register-definition-prefixes "org-entities" '("org-entit"))
;;;***
;;;### (autoloads nil "org-faces" "org/org-faces.el" (0 0 0 0))
;;; Generated autoloads from org/org-faces.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-faces" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-feed" "org/org-feed.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-feed.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-feed" '("org-feed-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-footnote"
-;;;;;; "org/org-footnote.el" (0 0 0 0))
-;;; Generated autoloads from org/org-footnote.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-footnote" '("org-footnote-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-goto" "org/org-goto.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-goto.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-goto" '("org-goto-")))
+(register-definition-prefixes "org-faces" '("org-"))
;;;***
;;;### (autoloads nil "org-habit" "org/org-habit.el" (0 0 0 0))
;;; Generated autoloads from org/org-habit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-habit" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-id" "org/org-id.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-id.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-id" '("org-id-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-indent" "org/org-indent.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-indent.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-indent" '("org-indent-")))
+(register-definition-prefixes "org-habit" '("org-"))
;;;***
@@ -24006,69 +24521,21 @@ Add a hook to automatically encrypt entries before a file is saved to disk." nil
;;;;;; 0 0 0))
;;; Generated autoloads from org/org-inlinetask.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-inlinetask" '("org-inlinetask-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-keys" "org/org-keys.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-keys.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-keys" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-lint" "org/org-lint.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-lint.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-lint" '("org-lint-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-list" "org/org-list.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-list.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-list" '("org-")))
+(register-definition-prefixes "org-inlinetask" '("org-inlinetask-"))
;;;***
;;;### (autoloads nil "org-macro" "org/org-macro.el" (0 0 0 0))
;;; Generated autoloads from org/org-macro.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-macro" '("org-macro-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-macs" "org/org-macs.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-macs.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-macs" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-mobile" "org/org-mobile.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-mobile.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-mobile" '("org-mobile-")))
+(register-definition-prefixes "org-macro" '("org-macro-"))
;;;***
;;;### (autoloads nil "org-mouse" "org/org-mouse.el" (0 0 0 0))
;;; Generated autoloads from org/org-mouse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-mouse" '("org-mouse-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-num" "org/org-num.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-num.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-num" '("org-num-")))
+(register-definition-prefixes "org-mouse" '("org-mouse-"))
;;;***
@@ -24076,15 +24543,7 @@ Add a hook to automatically encrypt entries before a file is saved to disk." nil
;;;;;; 0 0))
;;; Generated autoloads from org/org-pcomplete.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-pcomplete" '("org-" "pcomplete/org-mode/")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-plot" "org/org-plot.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-plot.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-plot" '("org-plot")))
+(register-definition-prefixes "org-pcomplete" '("org-" "pcomplete/org-mode/"))
;;;***
@@ -24092,45 +24551,21 @@ Add a hook to automatically encrypt entries before a file is saved to disk." nil
;;;;;; 0))
;;; Generated autoloads from org/org-protocol.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-protocol" '("org-protocol-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-refile" "org/org-refile.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-refile.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-refile" '("org-")))
+(register-definition-prefixes "org-protocol" '("org-protocol-"))
;;;***
;;;### (autoloads nil "org-src" "org/org-src.el" (0 0 0 0))
;;; Generated autoloads from org/org-src.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-src" '("org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-table" "org/org-table.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-table.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-table" '("org")))
+(register-definition-prefixes "org-src" '("org-"))
;;;***
;;;### (autoloads nil "org-tempo" "org/org-tempo.el" (0 0 0 0))
;;; Generated autoloads from org/org-tempo.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-tempo" '("org-tempo-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "org-timer" "org/org-timer.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/org-timer.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "org-timer" '("org-timer-")))
+(register-definition-prefixes "org-tempo" '("org-tempo-"))
;;;***
@@ -24151,6 +24586,7 @@ Inserted by installing Org or when a release is made." nil nil)
;;; Generated autoloads from outline.el
(put 'outline-regexp 'safe-local-variable 'stringp)
(put 'outline-heading-end-regexp 'safe-local-variable 'stringp)
+(put 'outline-level 'risky-local-variable t)
(autoload 'outline-mode "outline" "\
Set major mode for editing outlines with selective display.
@@ -24176,116 +24612,38 @@ Turning on outline mode calls the value of `text-mode-hook' and then of
`outline-mode-hook', if they are non-nil.
\(fn)" t nil)
+(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp)
+(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp)
(autoload 'outline-minor-mode "outline" "\
Toggle Outline minor mode.
-If called interactively, enable Outline minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
-
-See the command `outline-mode' for more information on this mode.
-
-\(fn &optional ARG)" t nil)
-(put 'outline-level 'risky-local-variable t)
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "outline" '("outline-")))
+This is a minor mode. If called interactively, toggle the `Outline
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox" "org/ox.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox.el
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox" '("org-export-")))
+To check whether the minor mode is enabled in the current buffer,
+evaluate `outline-minor-mode'.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-ascii" "org/ox-ascii.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-ascii.el
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-ascii" '("org-ascii-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-beamer" "org/ox-beamer.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-beamer.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-beamer" '("org-beamer-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-html" "org/ox-html.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-html.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-html" '("org-html-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-icalendar"
-;;;;;; "org/ox-icalendar.el" (0 0 0 0))
-;;; Generated autoloads from org/ox-icalendar.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-icalendar" '("org-icalendar-")))
+See the command `outline-mode' for more information on this mode.
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-latex" "org/ox-latex.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-latex.el
+\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-latex" '("org-latex-")))
+(register-definition-prefixes "outline" '("outline-"))
;;;***
;;;### (autoloads nil "ox-man" "org/ox-man.el" (0 0 0 0))
;;; Generated autoloads from org/ox-man.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-man" '("org-man-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-md" "org/ox-md.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-md.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-md" '("org-md-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-odt" "org/ox-odt.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-odt.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-odt" '("org-odt-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-org" "org/ox-org.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-org.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-org" '("org-org-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-publish" "org/ox-publish.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-publish.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-publish" '("org-publish-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ox-texinfo" "org/ox-texinfo.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from org/ox-texinfo.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ox-texinfo" '("org-texinfo-")))
+(register-definition-prefixes "ox-man" '("org-man-"))
;;;***
@@ -24304,10 +24662,27 @@ with \"-q\").
Even if the value is nil, you can type \\[package-initialize] to
make installed packages available at any time, or you can
-call (package-initialize) in your init-file.")
+call (package-activate-all) in your init-file.")
(custom-autoload 'package-enable-at-startup "package" 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 :initialize #'custom-initialize-delay :risky t :version "24.1")
+
+(custom-autoload 'package-user-dir "package" t)
+
+(defcustom package-directory-list (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) :initialize #'custom-initialize-delay :risky t :version "24.1")
+
+(custom-autoload 'package-directory-list "package" t)
+
(defvar package--activated nil "\
Non-nil if `package-activate-all' has been run.")
@@ -24329,9 +24704,9 @@ that code in the early init-file.
\(fn &optional NO-ACTIVATE)" t nil)
-(autoload 'package-activate-all "package" "\
+(defun package-activate-all nil "\
Activate all installed packages.
-The variable `package-load-list' controls which packages to load." nil nil)
+The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (if qs (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage)) (require 'package) (package--activate-all))))
(autoload 'package-import-keyring "package" "\
Import keys from FILE.
@@ -24387,7 +24762,11 @@ directory.
(autoload 'package-install-selected-packages "package" "\
Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them." t nil)
+If some packages are not installed, propose to install them.
+If optional argument NOCONFIRM is non-nil, don't ask for
+confirmation to install packages.
+
+\(fn &optional NOCONFIRM)" t nil)
(autoload 'package-reinstall "package" "\
Reinstall package PKG.
@@ -24428,7 +24807,12 @@ The return value is a string (or nil in case we can't find it)." nil nil)
(function-put 'package-get-version 'pure 't)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")))
+(defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "\
+Location of the file used to speed up activation of packages at startup." :type 'file :initialize #'custom-initialize-delay :version "27.1")
+
+(custom-autoload 'package-quickstart-file "package" t)
+
+(register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-"))
;;;***
@@ -24451,14 +24835,14 @@ archive).
\(fn FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package-x" '("package-")))
+(register-definition-prefixes "package-x" '("package-"))
;;;***
;;;### (autoloads nil "page-ext" "textmodes/page-ext.el" (0 0 0 0))
;;; Generated autoloads from textmodes/page-ext.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "page-ext" '("pages-")))
+(register-definition-prefixes "page-ext" '("pages-"))
;;;***
@@ -24478,10 +24862,19 @@ or call the function `show-paren-mode'.")
(autoload 'show-paren-mode "paren" "\
Toggle visualization of matching parens (Show Paren mode).
-If called interactively, enable Show-Paren mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Show-Paren
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'show-paren-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Show Paren mode is a global minor mode. When enabled, any
matching parenthesis is highlighted in `show-paren-style' after
@@ -24489,7 +24882,7 @@ matching parenthesis is highlighted in `show-paren-style' after
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "paren" '("show-paren-")))
+(register-definition-prefixes "paren" '("show-paren-"))
;;;***
@@ -24500,8 +24893,9 @@ matching parenthesis is highlighted in `show-paren-style' after
(autoload 'parse-time-string "parse-time" "\
Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ).
-STRING should be something resembling an RFC 822 (or later) date-time, e.g.,
-\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is
+STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\",
+or something resembling an RFC 822 (or later) date-time, e.g.,
+\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is
somewhat liberal in what format it accepts, and will attempt to
return a \"likely\" value even for somewhat malformed strings.
The values returned are identical to those of `decode-time', but
@@ -24510,7 +24904,7 @@ unknown DST value is returned as -1.
\(fn STRING)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "parse-time" '("parse-")))
+(register-definition-prefixes "parse-time" '("parse-"))
;;;***
@@ -24561,7 +24955,7 @@ See also the user variables `pascal-type-keywords', `pascal-start-keywords' and
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pascal" '("electric-pascal-" "pascal-")))
+(register-definition-prefixes "pascal" '("electric-pascal-" "pascal-"))
;;;***
@@ -24585,7 +24979,7 @@ Check if KEY is in the cache.
\(fn KEY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "password-cache" '("password-")))
+(register-definition-prefixes "password-cache" '("password-"))
;;;***
@@ -24612,9 +25006,9 @@ PATTERN matches. PATTERN can take one of the forms:
If a SYMBOL is used twice in the same pattern
the second occurrence becomes an `eq'uality test.
(pred FUN) matches if FUN called on EXPVAL returns non-nil.
+ (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
(app FUN PAT) matches if FUN called on EXPVAL matches PAT.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
- (let PAT EXPR) matches if EXPR matches PAT.
(and PAT...) matches if all the patterns match.
(or PAT...) matches if any of the patterns matches.
@@ -24624,7 +25018,7 @@ FUN in `pred' and `app' can take one of the forms:
(F ARG1 .. ARGn)
call F with ARG1..ARGn and EXPVAL as n+1'th argument
-FUN, BOOLEXP, EXPR, and subsequent PAT can refer to variables
+FUN, BOOLEXP, and subsequent PAT can refer to variables
bound earlier in the pattern by a SYMBOL pattern.
Additional patterns can be defined using `pcase-defmacro'.
@@ -24719,7 +25113,7 @@ for the result of evaluating EXP (first arg to `pcase').
(function-put 'pcase-defmacro 'doc-string-elt '3)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcase" '("pcase-")))
+(register-definition-prefixes "pcase" '("pcase-"))
;;;***
@@ -24729,7 +25123,7 @@ for the result of evaluating EXP (first arg to `pcase').
(autoload 'pcomplete/cvs "pcmpl-cvs" "\
Completion rules for the `cvs' command." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-cvs" '("pcmpl-cvs-")))
+(register-definition-prefixes "pcmpl-cvs" '("pcmpl-cvs-"))
;;;***
@@ -24753,7 +25147,7 @@ Completion for the GNU find utility." nil nil)
(defalias 'pcomplete/gdb 'pcomplete/xargs)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-gnu" '("pcmpl-gnu-")))
+(register-definition-prefixes "pcmpl-gnu" '("pcmpl-gnu-"))
;;;***
@@ -24769,7 +25163,7 @@ Completion for GNU/Linux `umount'." nil nil)
(autoload 'pcomplete/mount "pcmpl-linux" "\
Completion for GNU/Linux `mount'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-linux" '("pcmpl-linux-" "pcomplete-pare-list")))
+(register-definition-prefixes "pcmpl-linux" '("pcmpl-linux-" "pcomplete-pare-list"))
;;;***
@@ -24779,7 +25173,7 @@ Completion for GNU/Linux `mount'." nil nil)
(autoload 'pcomplete/rpm "pcmpl-rpm" "\
Completion for the `rpm' command." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-rpm" '("pcmpl-rpm-")))
+(register-definition-prefixes "pcmpl-rpm" '("pcmpl-rpm-"))
;;;***
@@ -24818,7 +25212,12 @@ Completion rules for the `ssh' command." nil nil)
Completion rules for the `scp' command.
Includes files as well as host names followed by a colon." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-unix" '("pcmpl-")))
+(autoload 'pcomplete/telnet "pcmpl-unix" nil nil nil)
+
+(autoload 'pcomplete/rsh "pcmpl-unix" "\
+Complete `rsh', which, after the user and hostname, is like xargs." nil nil)
+
+(register-definition-prefixes "pcmpl-unix" '("pcmpl-" "pcomplete/"))
;;;***
@@ -24838,7 +25237,12 @@ long options." nil nil)
(autoload 'pcomplete/ag "pcmpl-x" "\
Completion for the `ag' command." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcmpl-x" '("pcmpl-x-")))
+(autoload 'pcomplete/bcc32 "pcmpl-x" "\
+Completion function for Borland's C++ compiler." nil nil)
+
+(defalias 'pcomplete/bcc 'pcomplete/bcc32)
+
+(register-definition-prefixes "pcmpl-x" '("pcmpl-x-"))
;;;***
@@ -24887,7 +25291,7 @@ this is `comint-dynamic-complete-functions'.
(autoload 'pcomplete-shell-setup "pcomplete" "\
Setup `shell-mode' to use pcomplete." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcomplete" '("pcomplete-")))
+(register-definition-prefixes "pcomplete" '("pcomplete-"))
;;;***
@@ -24964,7 +25368,7 @@ Anything else means to do it only if the prefix arg is equal to this value.")
Run `cvs-examine' if DIR is a CVS administrative directory.
The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp dir) (setq dir (directory-file-name dir)) (when (and (string= "CVS" (file-name-nondirectory dir)) (file-readable-p (expand-file-name "Entries" dir)) cvs-dired-use-hook (if (eq cvs-dired-use-hook 'always) (not current-prefix-arg) (equal current-prefix-arg cvs-dired-use-hook))) (save-excursion (funcall cvs-dired-action (file-name-directory dir) t t)))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs" '("cvs-" "defun-cvs-mode")))
+(register-definition-prefixes "pcvs" '("cvs-" "defun-cvs-mode"))
;;;***
@@ -24974,28 +25378,28 @@ The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp d
(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)) "\
Global menu used by PCL-CVS.")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs-defs" '("cvs-")))
+(register-definition-prefixes "pcvs-defs" '("cvs-"))
;;;***
;;;### (autoloads nil "pcvs-info" "vc/pcvs-info.el" (0 0 0 0))
;;; Generated autoloads from vc/pcvs-info.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs-info" '("cvs-")))
+(register-definition-prefixes "pcvs-info" '("cvs-"))
;;;***
;;;### (autoloads nil "pcvs-parse" "vc/pcvs-parse.el" (0 0 0 0))
;;; Generated autoloads from vc/pcvs-parse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs-parse" '("cvs-")))
+(register-definition-prefixes "pcvs-parse" '("cvs-"))
;;;***
;;;### (autoloads nil "pcvs-util" "vc/pcvs-util.el" (0 0 0 0))
;;; Generated autoloads from vc/pcvs-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pcvs-util" '("cvs-")))
+(register-definition-prefixes "pcvs-util" '("cvs-"))
;;;***
@@ -25067,7 +25471,7 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "perl-mode" '("indent-perl-exp" "mark-perl-function" "perl-")))
+(register-definition-prefixes "perl-mode" '("indent-perl-exp" "mark-perl-function" "perl-"))
;;;***
@@ -25147,14 +25551,14 @@ they are not by default assigned to keys." t nil)
(defalias 'edit-picture 'picture-mode)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "picture" '("picture-")))
+(register-definition-prefixes "picture" '("picture-"))
;;;***
;;;### (autoloads nil "pinyin" "language/pinyin.el" (0 0 0 0))
;;; Generated autoloads from language/pinyin.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pinyin" '("pinyin-character-map")))
+(register-definition-prefixes "pinyin" '("pinyin-character-map"))
;;;***
@@ -25174,14 +25578,23 @@ or call the function `pixel-scroll-mode'.")
(autoload 'pixel-scroll-mode "pixel-scroll" "\
A minor mode to scroll text pixel-by-pixel.
-If called interactively, enable Pixel-Scroll mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Pixel-Scroll mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'pixel-scroll-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pixel-scroll" '("pixel-")))
+(register-definition-prefixes "pixel-scroll" '("pixel-"))
;;;***
@@ -25198,7 +25611,7 @@ Major mode for editing PLSTORE files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "plstore" '("plstore-")))
+(register-definition-prefixes "plstore" '("plstore-"))
;;;***
@@ -25211,7 +25624,7 @@ Called through `file-coding-system-alist', before the file is visited for real.
\(fn ARG-LIST)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "po" '("po-")))
+(register-definition-prefixes "po" '("po-"))
;;;***
@@ -25227,7 +25640,7 @@ pong-mode keybindings:\\<pong-mode-map>
\\{pong-mode-map}" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pong" '("pong-")))
+(register-definition-prefixes "pong" '("pong-"))
;;;***
@@ -25240,7 +25653,7 @@ Use streaming commands.
\(fn FILE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pop3" '("pop3-")))
+(register-definition-prefixes "pop3" '("pop3-"))
;;;***
@@ -25290,7 +25703,7 @@ Ignores leading comment characters.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pp" '("pp-")))
+(register-definition-prefixes "pp" '("pp-"))
;;;***
@@ -25830,7 +26243,7 @@ are both set to t.
\(fn &optional SELECT-PRINTER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "printing" '("lpr-setup" "pr-")))
+(register-definition-prefixes "printing" '("lpr-setup" "pr-"))
;;;***
@@ -25850,7 +26263,7 @@ Proced buffers.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "proced" '("proced-")))
+(register-definition-prefixes "proced" '("proced-"))
;;;***
@@ -25884,21 +26297,63 @@ Open profile FILENAME.
\(fn FILENAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "profiler" '("profiler-")))
+(register-definition-prefixes "profiler" '("profiler-"))
;;;***
;;;### (autoloads nil "project" "progmodes/project.el" (0 0 0 0))
;;; Generated autoloads from progmodes/project.el
+(push (purecopy '(project 0 6 0)) package--builtin-versions)
(autoload 'project-current "project" "\
-Return the project instance in DIR or `default-directory'.
-When no project found in DIR, and MAYBE-PROMPT is non-nil, ask
-the user for a different directory to look in. If that directory
-is not a part of a detectable project either, return a
-`transient' project instance rooted in it.
+Return the project instance in DIRECTORY, defaulting to `default-directory'.
+
+When no project is found in that directory, the result depends on
+the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
+else ask the user for a directory in which to look for the
+project, and if no project is found there, return a \"transient\"
+project instance.
+
+The \"transient\" project instance is a special kind of value
+which denotes a project rooted in that directory and includes all
+the files under the directory except for those that should be
+ignored (per `project-ignores').
+
+See the doc string of `project-find-functions' for the general form
+of the project instance object.
+
+\(fn &optional MAYBE-PROMPT DIRECTORY)" nil nil)
-\(fn &optional MAYBE-PROMPT DIR)" nil nil)
+(defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "!" 'project-shell-command) (define-key map "&" 'project-async-shell-command) (define-key map "f" 'project-find-file) (define-key map "F" 'project-or-external-find-file) (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-dired) (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "G" 'project-or-external-find-regexp) (define-key map "r" 'project-query-replace-regexp) (define-key map "x" 'project-execute-extended-command) map) "\
+Keymap for project commands.")
+ (define-key ctl-x-map "p" project-prefix-map)
+
+(autoload 'project-other-window-command "project" "\
+Run project command, displaying resultant buffer in another window.
+
+The following commands are available:
+
+\\{project-prefix-map}
+\\{project-other-window-map}" t nil)
+ (define-key ctl-x-4-map "p" #'project-other-window-command)
+
+(autoload 'project-other-frame-command "project" "\
+Run project command, displaying resultant buffer in another frame.
+
+The following commands are available:
+
+\\{project-prefix-map}
+\\{project-other-frame-map}" t nil)
+ (define-key ctl-x-5-map "p" #'project-other-frame-command)
+
+(autoload 'project-other-tab-command "project" "\
+Run project command, displaying resultant buffer in a new tab.
+
+The following commands are available:
+
+\\{project-prefix-map}" t nil)
+
+(when (bound-and-true-p tab-prefix-map) (define-key tab-prefix-map "p" #'project-other-tab-command))
(autoload 'project-find-regexp "project" "\
Find all matches for REGEXP in the current project's roots.
@@ -25919,14 +26374,46 @@ pattern to search for.
\(fn REGEXP)" t nil)
(autoload 'project-find-file "project" "\
-Visit a file (with completion) in the current project's roots.
-The completion default is the filename at point, if one is
-recognized." t nil)
+Visit a file (with completion) in the current project.
+
+The completion default is the filename at point, determined by
+`thing-at-point' (whether such file exists or not)." t nil)
(autoload 'project-or-external-find-file "project" "\
-Visit a file (with completion) in the current project's roots or external roots.
-The completion default is the filename at point, if one is
-recognized." t nil)
+Visit a file (with completion) in the current project or external roots.
+
+The completion default is the filename at point, determined by
+`thing-at-point' (whether such file exists or not)." t nil)
+
+(autoload 'project-dired "project" "\
+Start Dired in the current project's root." t nil)
+
+(autoload 'project-vc-dir "project" "\
+Run VC-Dir in the current project's root." t nil)
+
+(autoload 'project-shell "project" "\
+Start an inferior shell in the current project's root directory.
+If a buffer already exists for running a shell in the project's root,
+switch to it. Otherwise, create a new shell buffer.
+With \\[universal-argument] prefix arg, create a new inferior shell buffer even
+if one already exists." t nil)
+
+(autoload 'project-eshell "project" "\
+Start Eshell in the current project's root directory.
+If a buffer already exists for running Eshell in the project's root,
+switch to it. Otherwise, create a new Eshell buffer.
+With \\[universal-argument] prefix arg, create a new Eshell buffer even
+if one already exists." t nil)
+
+(autoload 'project-async-shell-command "project" "\
+Run `async-shell-command' in the current project's root directory." t nil)
+
+(function-put 'project-async-shell-command 'interactive-only 'async-shell-command)
+
+(autoload 'project-shell-command "project" "\
+Run `shell-command' in the current project's root directory." t nil)
+
+(function-put 'project-shell-command 'interactive-only 'shell-command)
(autoload 'project-search "project" "\
Search for REGEXP in all the files of the project.
@@ -25944,7 +26431,89 @@ loop using the command \\[fileloop-continue].
\(fn FROM TO)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-")))
+(autoload 'project-compile "project" "\
+Run `compile' in the project root." t nil)
+
+(function-put 'project-compile 'interactive-only 'compile)
+
+(autoload 'project-switch-to-buffer "project" "\
+Display buffer BUFFER-OR-NAME in the selected window.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical.
+
+\(fn BUFFER-OR-NAME)" t nil)
+
+(autoload 'project-display-buffer "project" "\
+Display BUFFER-OR-NAME in some window, without selecting it.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical.
+
+This function uses `display-buffer' as a subroutine, which see
+for how it is determined where the buffer will be displayed.
+
+\(fn BUFFER-OR-NAME)" t nil)
+
+(autoload 'project-display-buffer-other-frame "project" "\
+Display BUFFER-OR-NAME preferably in another frame.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical.
+
+This function uses `display-buffer-other-frame' as a subroutine,
+which see for how it is determined where the buffer will be
+displayed.
+
+\(fn BUFFER-OR-NAME)" t nil)
+
+(autoload 'project-kill-buffers "project" "\
+Kill the buffers belonging to the current project.
+Two buffers belong to the same project if their project
+instances, as reported by `project-current' in each buffer, are
+identical. Only the buffers that match a condition in
+`project-kill-buffer-conditions' will be killed. If NO-CONFIRM
+is non-nil, the command will not ask the user for confirmation.
+NO-CONFIRM is always nil when the command is invoked
+interactively.
+
+\(fn &optional NO-CONFIRM)" t nil)
+
+(autoload 'project-remember-project "project" "\
+Add project PR to the front of the project list.
+Save the result in `project-list-file' if the list of projects has changed.
+
+\(fn PR)" nil nil)
+
+(autoload 'project-remove-known-project "project" "\
+Remove directory PROJECT-ROOT from the project list.
+PROJECT-ROOT is the root directory of a known project listed in
+the project list.
+
+\(fn PROJECT-ROOT)" t nil)
+
+(autoload 'project-known-project-roots "project" "\
+Return the list of root directories of all known projects." nil nil)
+
+(autoload 'project-execute-extended-command "project" "\
+Execute an extended command in project root." t nil)
+
+(function-put 'project-execute-extended-command 'interactive-only 'command-execute)
+
+(autoload 'project-switch-project "project" "\
+\"Switch\" to another project by running an Emacs command.
+The available commands are presented as a dispatch menu
+made from `project-switch-commands'.
+
+When called in a program, it will use the project corresponding
+to directory DIR.
+
+\(fn DIR)" t nil)
+
+(register-definition-prefixes "project" '("project-"))
;;;***
@@ -25979,7 +26548,7 @@ With prefix argument ARG, restart the Prolog process if running before.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "prolog" '("mercury-mode-map" "prolog-")))
+(register-definition-prefixes "prolog" '("mercury-mode-map" "prolog-"))
;;;***
@@ -25992,14 +26561,14 @@ The default value is (\"/usr/local/share/emacs/fonts/bdf\").")
(custom-autoload 'bdf-directory-list "ps-bdf" t)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-bdf" '("bdf-")))
+(register-definition-prefixes "ps-bdf" '("bdf-"))
;;;***
;;;### (autoloads nil "ps-def" "ps-def.el" (0 0 0 0))
;;; Generated autoloads from ps-def.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-def" '("ps-")))
+(register-definition-prefixes "ps-def" '("ps-"))
;;;***
@@ -26047,15 +26616,7 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-mode" '("ps-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "ps-mule" "ps-mule.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from ps-mule.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-mule" '("ps-mule-")))
+(register-definition-prefixes "ps-mode" '("ps-"))
;;;***
@@ -26244,14 +26805,14 @@ If EXTENSION is any other symbol, it is ignored.
\(fn FACE-EXTENSION &optional MERGE-P ALIST-SYM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-print" '("ps-")))
+(register-definition-prefixes "ps-print" '("ps-"))
;;;***
;;;### (autoloads nil "ps-samp" "ps-samp.el" (0 0 0 0))
;;; Generated autoloads from ps-samp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ps-samp" '("ps-")))
+(register-definition-prefixes "ps-samp" '("ps-"))
;;;***
@@ -26271,20 +26832,20 @@ Optional argument FACE specifies the face to do the highlighting.
\(fn START END &optional FACE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "pulse" '("pulse-")))
+(register-definition-prefixes "pulse" '("pulse-"))
;;;***
;;;### (autoloads nil "puny" "net/puny.el" (0 0 0 0))
;;; Generated autoloads from net/puny.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "puny" '("puny-")))
+(register-definition-prefixes "puny" '("puny-"))
;;;***
;;;### (autoloads nil "python" "progmodes/python.el" (0 0 0 0))
;;; Generated autoloads from progmodes/python.el
-(push (purecopy '(python 0 26 1)) package--builtin-versions)
+(push (purecopy '(python 0 27 1)) package--builtin-versions)
(add-to-list 'auto-mode-alist (cons (purecopy "\\.py[iw]?\\'") 'python-mode))
@@ -26317,7 +26878,7 @@ Major mode for editing Python files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal")))
+(register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal"))
;;;***
@@ -26338,7 +26899,7 @@ them into characters should be done separately.
\(fn FROM TO &optional CODING-SYSTEM)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "qp" '("quoted-printable-")))
+(register-definition-prefixes "qp" '("quoted-printable-"))
;;;***
@@ -26518,7 +27079,7 @@ Add one translation rule, KEY to TRANSLATION, in the current Quail package.
KEY is a string meaning a sequence of keystrokes to be translated.
TRANSLATION is a character, a string, a vector, a Quail map,
a function, or a cons.
-It it is a character, it is the sole translation of KEY.
+If it is a character, it is the sole translation of KEY.
If it is a string, each character is a candidate for the translation.
If it is a vector, each element (string or character) is a candidate
for the translation.
@@ -26568,7 +27129,7 @@ of each directory.
\(fn DIRNAME &rest DIRNAMES)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail" '("quail-")))
+(register-definition-prefixes "quail" '("quail-"))
;;;***
@@ -26576,7 +27137,7 @@ of each directory.
;;;;;; 0 0 0))
;;; Generated autoloads from leim/quail/ethiopic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/ethiopic" '("ethio-select-a-translation")))
+(register-definition-prefixes "quail/ethiopic" '("ethio-select-a-translation"))
;;;***
@@ -26591,7 +27152,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
\(fn INPUT-METHOD FUNC HELP-TEXT &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/hangul" '("alphabetp" "hangul" "notzerop")))
+(register-definition-prefixes "quail/hangul" '("alphabetp" "hangul" "notzerop"))
;;;***
@@ -26599,14 +27160,14 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
;;;;;; 0 0))
;;; Generated autoloads from leim/quail/indian.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/indian" '("inscript-" "quail-")))
+(register-definition-prefixes "quail/indian" '("indian-mlm-mozhi-u" "inscript-" "quail-"))
;;;***
;;;### (autoloads nil "quail/ipa" "leim/quail/ipa.el" (0 0 0 0))
;;; Generated autoloads from leim/quail/ipa.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/ipa" '("ipa-x-sampa-")))
+(register-definition-prefixes "quail/ipa" '("ipa-x-sampa-"))
;;;***
@@ -26614,21 +27175,21 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
;;;;;; 0 0 0))
;;; Generated autoloads from leim/quail/japanese.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/japanese" '("quail-japanese-")))
+(register-definition-prefixes "quail/japanese" '("quail-japanese-"))
;;;***
;;;### (autoloads nil "quail/lao" "leim/quail/lao.el" (0 0 0 0))
;;; Generated autoloads from leim/quail/lao.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/lao" '("lao-" "quail-lao-update-translation")))
+(register-definition-prefixes "quail/lao" '("lao-" "quail-lao-update-translation"))
;;;***
;;;### (autoloads nil "quail/lrt" "leim/quail/lrt.el" (0 0 0 0))
;;; Generated autoloads from leim/quail/lrt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/lrt" '("quail-lrt-update-translation")))
+(register-definition-prefixes "quail/lrt" '("quail-lrt-update-translation"))
;;;***
@@ -26636,14 +27197,14 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
;;;;;; 0 0 0))
;;; Generated autoloads from leim/quail/sisheng.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/sisheng" '("quail-make-sisheng-rules" "sisheng-")))
+(register-definition-prefixes "quail/sisheng" '("quail-make-sisheng-rules" "sisheng-"))
;;;***
;;;### (autoloads nil "quail/thai" "leim/quail/thai.el" (0 0 0 0))
;;; Generated autoloads from leim/quail/thai.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/thai" '("thai-generate-quail-map")))
+(register-definition-prefixes "quail/thai" '("thai-generate-quail-map"))
;;;***
@@ -26651,7 +27212,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'.
;;;;;; 0 0 0))
;;; Generated autoloads from leim/quail/tibetan.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/tibetan" '("quail-tib" "tibetan-")))
+(register-definition-prefixes "quail/tibetan" '("quail-tib" "tibetan-"))
;;;***
@@ -26668,14 +27229,14 @@ While this input method is active, the variable
\(fn &optional ARG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/uni-input" '("ucs-input-")))
+(register-definition-prefixes "quail/uni-input" '("ucs-input-"))
;;;***
;;;### (autoloads nil "quail/viqr" "leim/quail/viqr.el" (0 0 0 0))
;;; Generated autoloads from leim/quail/viqr.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/viqr" '("viet-quail-define-rules")))
+(register-definition-prefixes "quail/viqr" '("viet-quail-define-rules"))
;;;***
@@ -26744,7 +27305,7 @@ The key bindings for `quickurl-list-mode' are:
(autoload 'quickurl-list "quickurl" "\
Display `quickurl-list' as a formatted list using `quickurl-list-mode'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quickurl" '("quickurl-")))
+(register-definition-prefixes "quickurl" '("quickurl-"))
;;;***
@@ -26752,7 +27313,7 @@ Display `quickurl-list' as a formatted list using `quickurl-list-mode'." t nil)
;;;;;; 0 0 0))
;;; Generated autoloads from emacs-lisp/radix-tree.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "radix-tree" '("radix-tree-")))
+(register-definition-prefixes "radix-tree" '("radix-tree-"))
;;;***
@@ -26771,7 +27332,11 @@ If ARG is non-nil, instead prompt for connection parameters.
(defalias 'irc 'rcirc)
(autoload 'rcirc-connect "rcirc" "\
-
+Connect to SERVER.
+The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD,
+ENCRYPTION, SERVER-ALIAS are interpreted as in
+`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels
+that are joined after authentication.
\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS)" nil nil)
@@ -26788,14 +27353,23 @@ or call the function `rcirc-track-minor-mode'.")
(autoload 'rcirc-track-minor-mode "rcirc" "\
Global minor mode for tracking activity in rcirc buffers.
-If called interactively, enable Rcirc-Track minor mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Rcirc-Track minor mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'rcirc-track-minor-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rcirc" '("defun-rcirc-command" "rcirc-" "set-rcirc-" "with-rcirc-")))
+(register-definition-prefixes "rcirc" '("rcirc-" "with-rcirc-"))
;;;***
@@ -26812,9 +27386,14 @@ the regexp builder. It displays a buffer named \"*RE-Builder*\"
in another window, initially containing an empty regexp.
As you edit the regexp in the \"*RE-Builder*\" buffer, the
-matching parts of the target buffer will be highlighted." t nil)
+matching parts of the target buffer will be highlighted.
+
+Case-sensitivity can be toggled with \\[reb-toggle-case]. The
+regexp builder supports three different forms of input which can
+be set with \\[reb-change-syntax]. More options and details are
+provided in the Commentary section of this library." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "re-builder" '("re-builder-unload-function" "reb-")))
+(register-definition-prefixes "re-builder" '("re-builder-unload-function" "reb-"))
;;;***
@@ -26834,18 +27413,34 @@ or call the function `recentf-mode'.")
(autoload 'recentf-mode "recentf" "\
Toggle \"Open Recent\" menu (Recentf mode).
-If called interactively, enable Recentf mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Recentf
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'recentf-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Recentf mode is enabled, a \"Open Recent\" submenu is
displayed in the \"File\" menu, containing a list of files that
were operated on recently, in the most-recently-used order.
+By default, only operations like opening a file, writing a buffer
+to a file, and killing a buffer is counted as \"operating\" on
+the file. If instead you want to prioritize files that appear in
+buffers you switch to a lot, you can say something like the following:
+
+ (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)
+
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "recentf" '("recentf-")))
+(register-definition-prefixes "recentf" '("recentf-"))
;;;***
@@ -26986,30 +27581,39 @@ with a prefix argument, prompt for START-AT and FORMAT.
(autoload 'rectangle-mark-mode "rect" "\
Toggle the region as rectangular.
-If called interactively, enable Rectangle-Mark mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Rectangle-Mark mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `rectangle-mark-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Activates the region if needed. Only lasts until the region is deactivated.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")))
+(register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-"))
;;;***
;;;### (autoloads nil "refbib" "textmodes/refbib.el" (0 0 0 0))
;;; Generated autoloads from textmodes/refbib.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "refbib" '("r2b-")))
+(register-definition-prefixes "refbib" '("r2b-"))
;;;***
;;;### (autoloads nil "refer" "textmodes/refer.el" (0 0 0 0))
;;; Generated autoloads from textmodes/refer.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "refer" '("refer-")))
+(register-definition-prefixes "refer" '("refer-"))
;;;***
@@ -27019,10 +27623,19 @@ Activates the region if needed. Only lasts until the region is deactivated.
(autoload 'refill-mode "refill" "\
Toggle automatic refilling (Refill mode).
-If called interactively, enable Refill mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Refill
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `refill-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Refill mode is a buffer-local minor mode. When enabled, the
current paragraph is refilled as you edit. Self-inserting
@@ -27033,7 +27646,7 @@ For true \"word wrap\" behavior, use `visual-line-mode' instead.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "refill" '("refill-")))
+(register-definition-prefixes "refill" '("refill-"))
;;;***
@@ -27050,10 +27663,19 @@ Turn on RefTeX mode." nil nil)
(autoload 'reftex-mode "reftex" "\
Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX.
-If called interactively, enable Reftex mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Reftex
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `reftex-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\<reftex-mode-map>A Table of Contents of the entire (multifile) document with browsing
capabilities is available with `\\[reftex-toc]'.
@@ -27089,79 +27711,7 @@ on the menu bar.
Reset the symbols containing information from buffer scanning.
This enforces rescanning the buffer on next use." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-auc" "textmodes/reftex-auc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-auc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-auc" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-cite"
-;;;;;; "textmodes/reftex-cite.el" (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-cite.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-cite" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-dcr" "textmodes/reftex-dcr.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-dcr.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-dcr" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-global"
-;;;;;; "textmodes/reftex-global.el" (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-global.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-global" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-index"
-;;;;;; "textmodes/reftex-index.el" (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-index.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-index" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-parse"
-;;;;;; "textmodes/reftex-parse.el" (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-parse.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-parse" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-ref" "textmodes/reftex-ref.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-ref.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-ref" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-sel" "textmodes/reftex-sel.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-sel.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-sel" '("reftex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "reftex-toc" "textmodes/reftex-toc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from textmodes/reftex-toc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-toc" '("reftex-")))
+(register-definition-prefixes "reftex" '("reftex-"))
;;;***
@@ -27173,7 +27723,7 @@ This enforces rescanning the buffer on next use." nil nil)
(put 'reftex-level-indent 'safe-local-variable 'integerp)
(put 'reftex-guess-label-type 'safe-local-variable (lambda (x) (memq x '(nil t))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reftex-vars" '("reftex-")))
+(register-definition-prefixes "reftex-vars" '("reftex-"))
;;;***
@@ -27237,33 +27787,31 @@ This means the number of non-shy regexp grouping constructs
\(fn REGEXP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "regexp-opt" '("regexp-opt-")))
+(register-definition-prefixes "regexp-opt" '("regexp-opt-"))
;;;***
;;;### (autoloads nil "regi" "emacs-lisp/regi.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/regi.el
-(push (purecopy '(regi 1 8)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "regi" '("regi-")))
+(register-definition-prefixes "regi" '("regi-"))
;;;***
;;;### (autoloads nil "registry" "registry.el" (0 0 0 0))
;;; Generated autoloads from registry.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "registry" '("registry-")))
+(register-definition-prefixes "registry" '("registry-"))
;;;***
;;;### (autoloads nil "remember" "textmodes/remember.el" (0 0 0 0))
;;; Generated autoloads from textmodes/remember.el
-(push (purecopy '(remember 2 0)) package--builtin-versions)
(autoload 'remember "remember" "\
Remember an arbitrary piece of data.
-INITIAL is the text to initially place in the *Remember* buffer,
-or nil to bring up a blank *Remember* buffer.
+INITIAL is the text to initially place in the `remember-buffer',
+or nil to bring up a blank `remember-buffer'.
With a prefix or a visible region, use the region as INITIAL.
@@ -27279,7 +27827,7 @@ Remember the contents of the current clipboard.
Most useful for remembering things from other applications." t nil)
(autoload 'remember-diary-extract-entries "remember" "\
-Extract diary entries from the region." nil nil)
+Extract diary entries from the region based on `remember-diary-regexp'." nil nil)
(autoload 'remember-notes "remember" "\
Return the notes buffer, creating it if needed, and maybe switch to it.
@@ -27304,13 +27852,12 @@ to turn the *scratch* buffer into your notes buffer.
\(fn &optional SWITCH-TO)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "remember" '("remember-")))
+(register-definition-prefixes "remember" '("remember-"))
;;;***
;;;### (autoloads nil "repeat" "repeat.el" (0 0 0 0))
;;; Generated autoloads from repeat.el
-(push (purecopy '(repeat 0 51)) package--builtin-versions)
(autoload 'repeat "repeat" "\
Repeat most recently executed command.
@@ -27329,7 +27876,43 @@ recently executed command not bound to an input event\".
\(fn REPEAT-ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "repeat" '("repeat-")))
+(defvar repeat-map nil "\
+The value of the repeating map for the next command.
+A command called from the map can set it again to the same map when
+the map can't be set on the command symbol property `repeat-map'.")
+
+(defvar repeat-mode nil "\
+Non-nil if Repeat mode is enabled.
+See the `repeat-mode' command
+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 `repeat-mode'.")
+
+(custom-autoload 'repeat-mode "repeat" nil)
+
+(autoload 'repeat-mode "repeat" "\
+Toggle Repeat mode.
+When Repeat mode is enabled, and the command symbol has the property named
+`repeat-map', this map is activated temporarily for the next command.
+
+This is a minor mode. If called interactively, toggle the `Repeat
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'repeat-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
+(register-definition-prefixes "repeat" '("describe-repeat-maps" "repeat-"))
;;;***
@@ -27362,7 +27945,7 @@ mail-sending package is used for editing and sending the message.
\(fn ADDRESS PKGNAME VARLIST &optional PRE-HOOKS POST-HOOKS SALUTATION)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reporter" '("reporter-")))
+(register-definition-prefixes "reporter" '("reporter-"))
;;;***
@@ -27387,10 +27970,12 @@ visible (if only part could otherwise be made so), to make the defun line
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).
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage.
-\(fn &optional ARG)" t nil)
+\(fn &optional ARG INTERACTIVE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reposition" '("repos-count-screen-lines")))
+(register-definition-prefixes "reposition" '("repos-count-screen-lines"))
;;;***
@@ -27400,14 +27985,25 @@ first comment line visible (if point is in a comment).
(autoload 'reveal-mode "reveal" "\
Toggle uncloaking of invisible text near point (Reveal mode).
-If called interactively, enable Reveal mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Reveal
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `reveal-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Reveal mode is a buffer-local minor mode. When enabled, it
reveals invisible text around point.
+Also see the `reveal-auto-hide' variable.
+
\(fn &optional ARG)" t nil)
(defvar global-reveal-mode nil "\
@@ -27424,14 +28020,23 @@ or call the function `global-reveal-mode'.")
Toggle Reveal mode in all buffers (Global Reveal mode).
Reveal mode renders invisible text around point visible again.
-If called interactively, enable Global Reveal mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+Reveal mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-reveal-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "reveal" '("reveal-")))
+(register-definition-prefixes "reveal" '("reveal-"))
;;;***
@@ -27439,49 +28044,49 @@ enable the mode if ARG is omitted or nil, and toggle it if ARG is
;;;;;; 0))
;;; Generated autoloads from international/rfc1843.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc1843" '("rfc1843-")))
+(register-definition-prefixes "rfc1843" '("rfc1843-"))
;;;***
;;;### (autoloads nil "rfc2045" "mail/rfc2045.el" (0 0 0 0))
;;; Generated autoloads from mail/rfc2045.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc2045" '("rfc2045-encode-string")))
+(register-definition-prefixes "rfc2045" '("rfc2045-encode-string"))
;;;***
;;;### (autoloads nil "rfc2047" "mail/rfc2047.el" (0 0 0 0))
;;; Generated autoloads from mail/rfc2047.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc2047" '("rfc2047-")))
+(register-definition-prefixes "rfc2047" '("rfc2047-"))
;;;***
;;;### (autoloads nil "rfc2104" "net/rfc2104.el" (0 0 0 0))
;;; Generated autoloads from net/rfc2104.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc2104" '("rfc2104-")))
+(register-definition-prefixes "rfc2104" '("rfc2104-"))
;;;***
;;;### (autoloads nil "rfc2231" "mail/rfc2231.el" (0 0 0 0))
;;; Generated autoloads from mail/rfc2231.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc2231" '("rfc2231-")))
+(register-definition-prefixes "rfc2231" '("rfc2231-"))
;;;***
;;;### (autoloads nil "rfc2368" "mail/rfc2368.el" (0 0 0 0))
;;; Generated autoloads from mail/rfc2368.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc2368" '("rfc2368-")))
+(register-definition-prefixes "rfc2368" '("rfc2368-"))
;;;***
;;;### (autoloads nil "rfc822" "mail/rfc822.el" (0 0 0 0))
;;; Generated autoloads from mail/rfc822.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rfc822" '("rfc822-")))
+(register-definition-prefixes "rfc822" '("rfc822-"))
;;;***
@@ -27498,7 +28103,7 @@ Make a ring that can contain SIZE elements.
\(fn SIZE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ring" '("ring-")))
+(register-definition-prefixes "ring" '("ring-"))
;;;***
@@ -27544,7 +28149,7 @@ variable.
\(fn INPUT-ARGS &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rlogin" '("rlogin-")))
+(register-definition-prefixes "rlogin" '("rlogin-"))
;;;***
@@ -27556,14 +28161,11 @@ Name of user's primary mail file.")
(custom-autoload 'rmail-file-name "rmail" t)
-(put 'rmail-spool-directory 'standard-value '((cond ((file-exists-p "/var/mail") "/var/mail/") ((file-exists-p "/var/spool/mail") "/var/spool/mail/") ((memq system-type '(hpux usg-unix-v)) "/usr/mail/") (t "/usr/spool/mail/"))))
-
-(defvar rmail-spool-directory (purecopy (cond ((file-exists-p "/var/mail") "/var/mail/") ((file-exists-p "/var/spool/mail") "/var/spool/mail/") ((memq system-type '(hpux usg-unix-v)) "/usr/mail/") (t "/usr/spool/mail/"))) "\
+(defcustom rmail-spool-directory (purecopy (cond ((file-exists-p "/var/mail") "/var/mail/") ((file-exists-p "/var/spool/mail") "/var/spool/mail/") ((memq system-type '(hpux usg-unix-v)) "/usr/mail/") (t "/usr/spool/mail/"))) "\
Name of directory used by system mailer for delivering new mail.
-Its name should end with a slash.")
+Its name should end with a slash." :initialize #'custom-initialize-delay :type 'directory :group 'rmail)
(custom-autoload 'rmail-spool-directory "rmail" t)
-(custom-initialize-delay 'rmail-spool-directory nil)
(autoload 'rmail-movemail-variant-p "rmail" "\
Return t if the current movemail variant is any of VARIANTS.
@@ -27703,6 +28305,7 @@ Instead, these commands are available:
\\[rmail-undelete-previous-message] Undelete message. Tries current message, then earlier messages
till a deleted message is found.
\\[rmail-edit-current-message] Edit the current message. \\[rmail-cease-edit] to return to Rmail.
+\\[rmail-epa-decrypt] Decrypt the current message.
\\[rmail-expunge] Expunge deleted messages.
\\[rmail-expunge-and-save] Expunge and save the file.
\\[rmail-quit] Quit Rmail: expunge, save, then switch to another buffer.
@@ -27741,7 +28344,7 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server.
\(fn PASSWORD)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail" '("mail-" "rmail-")))
+(register-definition-prefixes "rmail" '("mail-" "rmail-"))
;;;***
@@ -27749,31 +28352,7 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server.
;;;;;; (0 0 0 0))
;;; Generated autoloads from mail/rmail-spam-filter.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmail-spam-filter" '("rmail-" "rsf-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "rmailedit" "mail/rmailedit.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/rmailedit.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailedit" '("rmail-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "rmailkwd" "mail/rmailkwd.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/rmailkwd.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailkwd" '("rmail-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "rmailmm" "mail/rmailmm.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/rmailmm.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailmm" '("rmail-")))
+(register-definition-prefixes "rmail-spam-filter" '("rmail-" "rsf-"))
;;;***
@@ -27845,23 +28424,7 @@ than appending to it. Deletes the message after writing if
\(fn FILE-NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailout" '("rmail-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "rmailsort" "mail/rmailsort.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/rmailsort.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailsort" '("rmail-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "rmailsum" "mail/rmailsum.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/rmailsum.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rmailsum" '("rmail-")))
+(register-definition-prefixes "rmailout" '("rmail-"))
;;;***
@@ -27869,28 +28432,37 @@ than appending to it. Deletes the message after writing if
;;; Generated autoloads from emacs-lisp/rmc.el
(autoload 'read-multiple-choice "rmc" "\
-Ask user a multiple choice question.
-PROMPT should be a string that will be displayed as the prompt.
-
-CHOICES is a list of (KEY NAME [DESCRIPTION]). KEY is a
-character to be entered. NAME is a short name for the entry to
-be displayed while prompting (if there's room, it might be
-shortened). DESCRIPTION is an optional longer explanation that
-will be displayed in a help buffer if the user requests more
-help.
+Ask user to select an entry from CHOICES, promting with PROMPT.
+This function allows to ask the user a multiple-choice question.
+
+CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
+KEY is a character the user should type to select the entry.
+NAME is a short name for the entry to be displayed while prompting
+\(if there's no room, it might be shortened).
+DESCRIPTION is an optional longer description of the entry; it will
+be displayed in a help buffer if the user requests more help. This
+help description has a fixed format in columns. For greater
+flexibility, instead of passing a DESCRIPTION, the caller can pass
+the optional argument HELP-STRING. This argument is a string that
+should contain a more detailed description of all of the possible
+choices. `read-multiple-choice' will display that description in a
+help buffer if the user requests that.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
-that variable for more information. In this case, the useful
-bindings are `recenter', `scroll-up', and `scroll-down'. If the
-user enters `recenter', `scroll-up', or `scroll-down' responses,
-perform the requested window recentering or scrolling and ask
-again.
-
-When `use-dialog-box' is t (the default), this function can pop
-up a dialog window to collect the user input. That functionality
-requires `display-popup-menus-p' to return t. Otherwise, a
-text dialog will be used.
+that variable for more information. The relevant bindings for the
+purposes of this function are `recenter', `scroll-up', `scroll-down',
+and `edit'.
+If the user types the `recenter', `scroll-up', or `scroll-down'
+responses, the function performs the requested window recentering or
+scrolling, and then asks the question again. If the user enters `edit',
+the function starts a recursive edit. When the user exit the recursive
+edit, the multiple-choice prompt gains focus again.
+
+When `use-dialog-box' is t (the default), and the command using this
+function was invoked via the mouse, this function pops up a GUI dialog
+to collect the user input, but only if Emacs is capable of using GUI
+dialogs. Otherwise, the function will always use text-mode dialogs.
The return value is the matching entry from the CHOICES list.
@@ -27901,7 +28473,7 @@ Usage example:
(?s \"session only\")
(?n \"no\")))
-\(fn PROMPT CHOICES)" nil nil)
+\(fn PROMPT CHOICES &optional HELP-STRING)" nil nil)
;;;***
@@ -27914,35 +28486,35 @@ Return a pattern.
\(fn FILENAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-cmpct" '("rng-")))
+(register-definition-prefixes "rng-cmpct" '("rng-"))
;;;***
;;;### (autoloads nil "rng-dt" "nxml/rng-dt.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-dt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-dt" '("rng-dt-")))
+(register-definition-prefixes "rng-dt" '("rng-dt-"))
;;;***
;;;### (autoloads nil "rng-loc" "nxml/rng-loc.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-loc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-loc" '("rng-")))
+(register-definition-prefixes "rng-loc" '("rng-"))
;;;***
;;;### (autoloads nil "rng-maint" "nxml/rng-maint.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-maint.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-maint" '("rng-")))
+(register-definition-prefixes "rng-maint" '("rng-"))
;;;***
;;;### (autoloads nil "rng-match" "nxml/rng-match.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-match.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-match" '("rng-")))
+(register-definition-prefixes "rng-match" '("rng-"))
;;;***
@@ -27954,35 +28526,35 @@ Initialize `nxml-mode' to take advantage of `rng-validate-mode'.
This is typically called from `nxml-mode-hook'.
Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-nxml" '("rng-")))
+(register-definition-prefixes "rng-nxml" '("rng-"))
;;;***
;;;### (autoloads nil "rng-parse" "nxml/rng-parse.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-parse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-parse" '("rng-parse-")))
+(register-definition-prefixes "rng-parse" '("rng-parse-"))
;;;***
;;;### (autoloads nil "rng-pttrn" "nxml/rng-pttrn.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-pttrn.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-pttrn" '("rng-")))
+(register-definition-prefixes "rng-pttrn" '("rng-"))
;;;***
;;;### (autoloads nil "rng-uri" "nxml/rng-uri.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-uri.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-uri" '("rng-")))
+(register-definition-prefixes "rng-uri" '("rng-"))
;;;***
;;;### (autoloads nil "rng-util" "nxml/rng-util.el" (0 0 0 0))
;;; Generated autoloads from nxml/rng-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-util" '("rng-")))
+(register-definition-prefixes "rng-util" '("rng-"))
;;;***
@@ -27992,10 +28564,19 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil)
(autoload 'rng-validate-mode "rng-valid" "\
Minor mode performing continual validation against a RELAX NG schema.
-If called interactively, enable Rng-Validate mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Rng-Validate mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `rng-validate-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Checks whether the buffer is a well-formed XML 1.0 document,
conforming to the XML Namespaces Recommendation and valid against a
@@ -28019,7 +28600,7 @@ to use for finding the schema.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-valid" '("rng-")))
+(register-definition-prefixes "rng-valid" '("rng-"))
;;;***
@@ -28048,7 +28629,7 @@ must be equal.
\(fn NAME PARAMS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rng-xsd" '("rng-xsd-" "xsd-duration-reference-dates")))
+(register-definition-prefixes "rng-xsd" '("rng-xsd-" "xsd-duration-reference-dates"))
;;;***
@@ -28082,7 +28663,7 @@ Start using robin package NAME, which is a string.
\(fn NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "robin" '("robin-")))
+(register-definition-prefixes "robin" '("robin-"))
;;;***
@@ -28120,7 +28701,7 @@ See also `toggle-rot13-mode'." t nil)
(autoload 'toggle-rot13-mode "rot13" "\
Toggle the use of ROT13 encoding for the current window." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rot13" '("rot13-")))
+(register-definition-prefixes "rot13" '("rot13-"))
;;;***
@@ -28143,10 +28724,19 @@ highlighting.
(autoload 'rst-minor-mode "rst" "\
Toggle ReST minor mode.
-If called interactively, enable Rst minor mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Rst minor
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `rst-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When ReST minor mode is enabled, the ReST mode keybindings
are installed on top of the major mode bindings. Use this
@@ -28154,14 +28744,14 @@ for modes derived from Text mode, like Mail mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rst" '("rst-")))
+(register-definition-prefixes "rst" '("rst-"))
;;;***
;;;### (autoloads nil "rtree" "rtree.el" (0 0 0 0))
;;; Generated autoloads from rtree.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rtree" '("rtree-")))
+(register-definition-prefixes "rtree" '("rtree-"))
;;;***
@@ -28175,33 +28765,41 @@ Major mode for editing Ruby code.
\(fn)" t nil)
-(add-to-list 'auto-mode-alist (cons (purecopy (concat "\\(?:\\.\\(?:" "rbw?\\|ru\\|rake\\|thor" "\\|jbuilder\\|rabl\\|gemspec\\|podspec" "\\)" "\\|/" "\\(?:Gem\\|Rake\\|Cap\\|Thor" "\\|Puppet\\|Berks" "\\|Vagrant\\|Guard\\|Pod\\)file" "\\)\\'")) 'ruby-mode))
+(add-to-list 'auto-mode-alist (cons (purecopy (concat "\\(?:\\.\\(?:" "rbw?\\|ru\\|rake\\|thor" "\\|jbuilder\\|rabl\\|gemspec\\|podspec" "\\)" "\\|/" "\\(?:Gem\\|Rake\\|Cap\\|Thor" "\\|Puppet\\|Berks\\|Brew" "\\|Vagrant\\|Guard\\|Pod\\)file" "\\)\\'")) 'ruby-mode))
(dolist (name (list "ruby" "rbx" "jruby" "ruby1.9" "ruby1.8")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'ruby-mode)))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ruby-mode" '("ruby-")))
+(register-definition-prefixes "ruby-mode" '("ruby-"))
;;;***
;;;### (autoloads nil "ruler-mode" "ruler-mode.el" (0 0 0 0))
;;; Generated autoloads from ruler-mode.el
-(push (purecopy '(ruler-mode 1 6)) package--builtin-versions)
-(defvar ruler-mode nil "\
+(defvar-local ruler-mode nil "\
Non-nil if Ruler mode is enabled.
Use the command `ruler-mode' to change this variable.")
(autoload 'ruler-mode "ruler-mode" "\
Toggle display of ruler in header line (Ruler mode).
-If called interactively, enable Ruler mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Ruler
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `ruler-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ruler-mode" '("ruler-")))
+(register-definition-prefixes "ruler-mode" '("ruler-"))
;;;***
@@ -28265,7 +28863,7 @@ unmatchable Never match anything at all.
CHARCLASS Match a character from a character class. One of:
alpha, alphabetic, letter Alphabetic characters (defined by Unicode).
alnum, alphanumeric Alphabetic or decimal digit chars (Unicode).
- digit numeric, num 0-9.
+ digit, numeric, num 0-9.
xdigit, hex-digit, hex 0-9, A-F, a-f.
cntrl, control ASCII codes 0-31.
blank Horizontal whitespace (Unicode).
@@ -28393,38 +28991,43 @@ For more details, see Info node `(elisp) Extending Rx'.
\(fn NAME [(ARGS...)] RX)" nil t)
-(function-put 'rx-define 'lisp-indent-function '1)
+(function-put 'rx-define 'lisp-indent-function 'defun)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rx" '("rx-")))
+(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form.\nREGEXPS are interpreted as in `rx'. The pattern matches any\nstring that is a match for REGEXPS, as if by `string-match'.\n\nIn addition to the usual `rx' syntax, REGEXPS can contain the\nfollowing constructs:\n\n (let REF RX...) binds the symbol REF to a submatch that matches\n the regular expressions RX. REF is bound in\n CODE to the string of the submatch or nil, but\n can also be used in `backref'.\n (backref REF) matches whatever the submatch REF matched.\n REF can be a number, as usual, or a name\n introduced by a previous (let REF ...)\n construct." (let* ((rx--pcase-vars nil) (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) `(and (pred stringp) ,(pcase (length rx--pcase-vars) (0 `(pred (string-match ,regexp))) (1 `(app (lambda (s) (if (string-match ,regexp s) (match-string 1 s) 0)) (and ,(car rx--pcase-vars) (pred (not numberp))))) (nvars `(app (lambda (s) (and (string-match ,regexp s) ,(rx--reduce-right (lambda (a b) `(cons ,a ,b)) (mapcar (lambda (i) `(match-string ,i s)) (number-sequence 1 nvars))))) ,(list '\` (rx--reduce-right #'cons (mapcar (lambda (name) (list '\, name)) (reverse rx--pcase-vars)))))))))))
+
+(define-symbol-prop 'rx--pcase-macroexpander 'edebug-form-spec 'nil)
+
+(define-symbol-prop 'rx 'pcase-macroexpander #'rx--pcase-macroexpander)
+
+(register-definition-prefixes "rx" '("rx-"))
;;;***
;;;### (autoloads nil "sasl" "net/sasl.el" (0 0 0 0))
;;; Generated autoloads from net/sasl.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl" '("sasl-")))
+(register-definition-prefixes "sasl" '("sasl-"))
;;;***
;;;### (autoloads nil "sasl-cram" "net/sasl-cram.el" (0 0 0 0))
;;; Generated autoloads from net/sasl-cram.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-cram" '("sasl-cram-md5-")))
+(register-definition-prefixes "sasl-cram" '("sasl-cram-md5-"))
;;;***
;;;### (autoloads nil "sasl-digest" "net/sasl-digest.el" (0 0 0 0))
;;; Generated autoloads from net/sasl-digest.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-digest" '("sasl-digest-md5-")))
+(register-definition-prefixes "sasl-digest" '("sasl-digest-md5-"))
;;;***
;;;### (autoloads nil "sasl-ntlm" "net/sasl-ntlm.el" (0 0 0 0))
;;; Generated autoloads from net/sasl-ntlm.el
-(push (purecopy '(sasl 1 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-ntlm" '("sasl-ntlm-")))
+(register-definition-prefixes "sasl-ntlm" '("sasl-ntlm-"))
;;;***
@@ -28432,13 +29035,20 @@ For more details, see Info node `(elisp) Extending Rx'.
;;;;;; 0 0 0))
;;; Generated autoloads from net/sasl-scram-rfc.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-scram-rfc" '("sasl-scram-")))
+(register-definition-prefixes "sasl-scram-rfc" '("sasl-scram-"))
+
+;;;***
+
+;;;### (autoloads nil "sasl-scram-sha256" "net/sasl-scram-sha256.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from net/sasl-scram-sha256.el
+
+(register-definition-prefixes "sasl-scram-sha256" '("sasl-scram-sha"))
;;;***
;;;### (autoloads nil "savehist" "savehist.el" (0 0 0 0))
;;; Generated autoloads from savehist.el
-(push (purecopy '(savehist 24)) package--builtin-versions)
(defvar savehist-mode nil "\
Non-nil if Savehist mode is enabled.
@@ -28453,10 +29063,19 @@ or call the function `savehist-mode'.")
(autoload 'savehist-mode "savehist" "\
Toggle saving of minibuffer history (Savehist mode).
-If called interactively, enable Savehist mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Savehist
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'savehist-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Savehist mode is enabled, minibuffer history is saved
to `savehist-file' periodically and when exiting Emacs. When
@@ -28486,7 +29105,7 @@ histories, which is probably undesirable.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "savehist" '("savehist-")))
+(register-definition-prefixes "savehist" '("savehist-"))
;;;***
@@ -28508,10 +29127,19 @@ Non-nil means automatically save place in each file.
This means when you visit a file, point goes to the last place
where it was when you previously visited the same file.
-If called interactively, enable Save-Place mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Save-Place
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'save-place-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -28521,10 +29149,19 @@ If this mode is enabled, point is recorded when you kill the buffer
or exit Emacs. Visiting this file again will go to that position,
even in a later Emacs session.
-If called interactively, enable Save-Place-Local mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Save-Place-Local mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `save-place-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
To save places automatically in all files, put this in your init
file:
@@ -28533,14 +29170,7 @@ file:
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "saveplace" '("load-save-place-alist-from-file" "save-place")))
-
-;;;***
-
-;;;### (autoloads nil "sb-image" "sb-image.el" (0 0 0 0))
-;;; Generated autoloads from sb-image.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("defimage-speedbar" "speedbar-")))
+(register-definition-prefixes "saveplace" '("load-save-place-alist-from-file" "save-place"))
;;;***
@@ -28581,7 +29211,7 @@ that variable's value is a string.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scheme" '("dsssl-" "scheme-")))
+(register-definition-prefixes "scheme" '("dsssl-" "scheme-"))
;;;***
@@ -28596,7 +29226,7 @@ This mode is an extended emacs-lisp mode.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "score-mode" '("gnus-score-" "score-mode-")))
+(register-definition-prefixes "score-mode" '("gnus-score-" "score-mode-"))
;;;***
@@ -28616,24 +29246,33 @@ or call the function `scroll-all-mode'.")
(autoload 'scroll-all-mode "scroll-all" "\
Toggle shared scrolling in same-frame windows (Scroll-All mode).
-If called interactively, enable Scroll-All mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Scroll-All
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'scroll-all-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-all" '("scroll-all-")))
+(register-definition-prefixes "scroll-all" '("scroll-all-"))
;;;***
;;;### (autoloads nil "scroll-bar" "scroll-bar.el" (0 0 0 0))
;;; Generated autoloads from scroll-bar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-bar" '("get-scroll-bar-mode" "horizontal-scroll-bar" "previous-scroll-bar-mode" "scroll-bar-" "set-scroll-bar-mode" "toggle-")))
+(register-definition-prefixes "scroll-bar" '("get-scroll-bar-mode" "horizontal-scroll-bar" "previous-scroll-bar-mode" "scroll-bar-" "set-scroll-bar-mode" "toggle-"))
;;;***
@@ -28643,10 +29282,19 @@ one window apply to all visible windows in the same frame.
(autoload 'scroll-lock-mode "scroll-lock" "\
Buffer-local minor mode for pager-like scrolling.
-If called interactively, enable Scroll-Lock mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Scroll-Lock mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `scroll-lock-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When enabled, keys that normally move point by line or paragraph
will scroll the buffer by the respective amount of lines instead
@@ -28658,7 +29306,7 @@ MS-Windows systems if `w32-scroll-lock-modifier' is non-nil.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "scroll-lock" '("scroll-lock-")))
+(register-definition-prefixes "scroll-lock" '("scroll-lock-"))
;;;***
@@ -28667,7 +29315,7 @@ MS-Windows systems if `w32-scroll-lock-modifier' is non-nil.
(when (featurep 'dbusbind)
(autoload 'secrets-show-secrets "secrets" nil t))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "secrets" '("secrets-")))
+(register-definition-prefixes "secrets" '("secrets-"))
;;;***
@@ -28688,7 +29336,6 @@ The possible elements of this list include the following:
`global-semantic-stickyfunc-mode' - Show current fun in header line.
`global-semantic-mru-bookmark-mode' - Provide `switch-to-buffer'-like
keybinding for tag names.
- `global-cedet-m3-minor-mode' - A mouse 3 context menu.
`global-semantic-idle-local-symbol-highlight-mode' - Highlight references
of the symbol under point.
The following modes are more targeted at people who want to see
@@ -28714,10 +29361,19 @@ or call the function `semantic-mode'.")
(autoload 'semantic-mode "semantic" "\
Toggle parser features (Semantic mode).
-If called interactively, enable Semantic mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Semantic
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'semantic-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
In Semantic mode, Emacs parses the buffers you visit for their
semantic content. This information is used by a variety of
@@ -28729,23 +29385,7 @@ Semantic mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic" '("bovinate" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/analyze"
-;;;;;; "cedet/semantic/analyze.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/analyze.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/analyze" '("semantic-a")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/analyze/complete"
-;;;;;; "cedet/semantic/analyze/complete.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/analyze/complete.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/analyze/complete" '("semantic-analyze-")))
+(register-definition-prefixes "semantic" '("bovinate" "semantic-"))
;;;***
@@ -28753,7 +29393,7 @@ Semantic mode.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/analyze/debug.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/analyze/debug" '("semantic-analyze")))
+(register-definition-prefixes "semantic/analyze/debug" '("semantic-analyze"))
;;;***
@@ -28761,31 +29401,7 @@ Semantic mode.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/analyze/fcn.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/analyze/fcn" '("semantic-analyze-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/analyze/refs"
-;;;;;; "cedet/semantic/analyze/refs.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/analyze/refs.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/analyze/refs" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine"
-;;;;;; "cedet/semantic/bovine.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine/c"
-;;;;;; "cedet/semantic/bovine/c.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine/c.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/c" '("c-mode" "semantic")))
+(register-definition-prefixes "semantic/analyze/fcn" '("semantic-analyze-"))
;;;***
@@ -28793,23 +29409,7 @@ Semantic mode.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/bovine/debug.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/debug" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine/el"
-;;;;;; "cedet/semantic/bovine/el.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine/el.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/el" '("emacs-lisp-mode" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine/gcc"
-;;;;;; "cedet/semantic/bovine/gcc.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine/gcc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/gcc" '("semantic-")))
+(register-definition-prefixes "semantic/bovine/debug" '("semantic-"))
;;;***
@@ -28822,23 +29422,7 @@ Major mode for editing Bovine grammars.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/grammar" '("bovine-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine/make"
-;;;;;; "cedet/semantic/bovine/make.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine/make.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/make" '("makefile-mode" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/bovine/scm"
-;;;;;; "cedet/semantic/bovine/scm.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/bovine/scm.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/bovine/scm" '("semantic-")))
+(register-definition-prefixes "semantic/bovine/grammar" '("bovine-"))
;;;***
@@ -28846,31 +29430,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/chart.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/chart" '("semantic-chart-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/complete"
-;;;;;; "cedet/semantic/complete.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/complete.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/complete" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/ctxt"
-;;;;;; "cedet/semantic/ctxt.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/ctxt.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/ctxt" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db"
-;;;;;; "cedet/semantic/db.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db" '("semanticdb-")))
+(register-definition-prefixes "semantic/chart" '("semantic-chart-"))
;;;***
@@ -28878,7 +29438,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-debug.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-debug" '("semanticdb-")))
+(register-definition-prefixes "semantic/db-debug" '("semanticdb-"))
;;;***
@@ -28886,7 +29446,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-ebrowse.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ebrowse" '("c++-mode" "semanticdb-")))
+(register-definition-prefixes "semantic/db-ebrowse" '("c++-mode" "semanticdb-"))
;;;***
@@ -28894,31 +29454,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-el.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-el" '("emacs-lisp-mode" "semanticdb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db-file"
-;;;;;; "cedet/semantic/db-file.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db-file.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-file" '("semanticdb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db-find"
-;;;;;; "cedet/semantic/db-find.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db-find.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-find" '("semanticdb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db-global"
-;;;;;; "cedet/semantic/db-global.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db-global.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-global" '("semanticdb-")))
+(register-definition-prefixes "semantic/db-el" '("emacs-lisp-mode" "semanticdb-"))
;;;***
@@ -28926,15 +29462,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-javascript.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-javascript" '("javascript-mode" "semanticdb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db-mode"
-;;;;;; "cedet/semantic/db-mode.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db-mode.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-mode" '("semanticdb-")))
+(register-definition-prefixes "semantic/db-javascript" '("javascript-mode" "semanticdb-"))
;;;***
@@ -28942,23 +29470,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/db-ref.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-ref" '("semanticdb-ref-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/db-typecache"
-;;;;;; "cedet/semantic/db-typecache.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/db-typecache.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/db-typecache" '("semanticdb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/debug"
-;;;;;; "cedet/semantic/debug.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/debug.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/debug" '("semantic-debug-")))
+(register-definition-prefixes "semantic/db-ref" '("semanticdb-ref-"))
;;;***
@@ -28966,39 +29478,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/decorate.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/decorate/include"
-;;;;;; "cedet/semantic/decorate/include.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/decorate/include.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/include" '("semantic-decoration-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/decorate/mode"
-;;;;;; "cedet/semantic/decorate/mode.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/decorate/mode.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/decorate/mode" '("define-semantic-decoration-style" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/dep"
-;;;;;; "cedet/semantic/dep.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/dep.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/dep" '("defcustom-mode-local-semantic-dependency-system-include-path" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/doc"
-;;;;;; "cedet/semantic/doc.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/doc.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/doc" '("semantic-doc")))
+(register-definition-prefixes "semantic/decorate" '("semantic-"))
;;;***
@@ -29006,31 +29486,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/ede-grammar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/ede-grammar" '("semantic-ede-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/edit"
-;;;;;; "cedet/semantic/edit.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/edit.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/edit" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/find"
-;;;;;; "cedet/semantic/find.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/find.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/find" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/format"
-;;;;;; "cedet/semantic/format.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/format.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/format" '("semantic-")))
+(register-definition-prefixes "semantic/ede-grammar" '("semantic-ede-"))
;;;***
@@ -29038,7 +29494,7 @@ Major mode for editing Bovine grammars.
;;;;;; 0))
;;; Generated autoloads from cedet/semantic/fw.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/fw" '("semantic")))
+(register-definition-prefixes "semantic/fw" '("semantic"))
;;;***
@@ -29046,55 +29502,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/grammar.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/grammar" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads nil "semantic/grammar-wy" "cedet/semantic/grammar-wy.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/grammar-wy.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/grammar-wy" '("semantic-grammar-wy--")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/html"
-;;;;;; "cedet/semantic/html.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/html.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/html" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/ia"
-;;;;;; "cedet/semantic/ia.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/ia.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/ia" '("semantic-ia-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/ia-sb"
-;;;;;; "cedet/semantic/ia-sb.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/ia-sb.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/ia-sb" '("semantic-ia-s")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/idle"
-;;;;;; "cedet/semantic/idle.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/idle.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/idle" '("define-semantic-idle-service" "global-semantic-idle-summary-mode" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/imenu"
-;;;;;; "cedet/semantic/imenu.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/imenu.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/imenu" '("semantic-")))
+(register-definition-prefixes "semantic/grammar" '("semantic-"))
;;;***
@@ -29102,31 +29510,7 @@ Major mode for editing Bovine grammars.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/semantic/java.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/java" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/lex"
-;;;;;; "cedet/semantic/lex.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/lex.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex" '("define-lex" "semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/lex-spp"
-;;;;;; "cedet/semantic/lex-spp.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/lex-spp.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/lex-spp" '("define-lex-spp-" "semantic-lex-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/mru-bookmark"
-;;;;;; "cedet/semantic/mru-bookmark.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/mru-bookmark.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/mru-bookmark" '("global-semantic-mru-bookmark-mode" "semantic-")))
+(register-definition-prefixes "semantic/java" '("semantic-"))
;;;***
@@ -29134,47 +29518,7 @@ Major mode for editing Bovine grammars.
;;;;;; 0))
;;; Generated autoloads from cedet/semantic/sb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/sb" '("semantic-sb-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/scope"
-;;;;;; "cedet/semantic/scope.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/scope.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/scope" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/senator"
-;;;;;; "cedet/semantic/senator.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/senator.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/senator" '("semantic-up-reference" "senator-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/sort"
-;;;;;; "cedet/semantic/sort.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/sort.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/sort" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref"
-;;;;;; "cedet/semantic/symref.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref" '("semantic-symref-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref/cscope"
-;;;;;; "cedet/semantic/symref/cscope.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref/cscope.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/cscope" '("semantic-symref-cscope--line-re")))
+(register-definition-prefixes "semantic/sb" '("semantic-sb-"))
;;;***
@@ -29182,79 +29526,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/symref/filter.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/filter" '("semantic-symref-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref/global"
-;;;;;; "cedet/semantic/symref/global.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref/global.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/global" '("semantic-symref-global--line-re")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref/grep"
-;;;;;; "cedet/semantic/symref/grep.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref/grep.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/grep" '("semantic-symref-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref/idutils"
-;;;;;; "cedet/semantic/symref/idutils.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref/idutils.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/idutils" '("semantic-symref-idutils--line-re")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/symref/list"
-;;;;;; "cedet/semantic/symref/list.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/symref/list.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/symref/list" '("semantic-symref-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/tag"
-;;;;;; "cedet/semantic/tag.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/tag.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/tag" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/tag-file"
-;;;;;; "cedet/semantic/tag-file.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/tag-file.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/tag-file" '("semantic-prototype-file")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/tag-ls"
-;;;;;; "cedet/semantic/tag-ls.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/tag-ls.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/tag-ls" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/tag-write"
-;;;;;; "cedet/semantic/tag-write.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/tag-write.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/tag-write" '("semantic-tag-write-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/texi"
-;;;;;; "cedet/semantic/texi.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/texi.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/texi" '("semantic-")))
+(register-definition-prefixes "semantic/symref/filter" '("semantic-symref-"))
;;;***
@@ -29262,15 +29534,7 @@ Major mode for editing Bovine grammars.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/semantic/util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/util" '("semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/util-modes"
-;;;;;; "cedet/semantic/util-modes.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/util-modes.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/util-modes" '("semantic-")))
+(register-definition-prefixes "semantic/util" '("semantic-"))
;;;***
@@ -29278,7 +29542,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent" '("define-wisent-lexer" "wisent-")))
+(register-definition-prefixes "semantic/wisent" '("define-wisent-lexer" "wisent-"))
;;;***
@@ -29286,7 +29550,7 @@ Major mode for editing Bovine grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent/comp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/comp" '("wisent-")))
+(register-definition-prefixes "semantic/wisent/comp" '("wisent-"))
;;;***
@@ -29299,31 +29563,7 @@ Major mode for editing Wisent grammars.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/grammar" '("wisent-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/wisent/java-tags"
-;;;;;; "cedet/semantic/wisent/java-tags.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/wisent/java-tags.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/java-tags" '("semantic-" "wisent-java-parse-error")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/wisent/javascript"
-;;;;;; "cedet/semantic/wisent/javascript.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/wisent/javascript.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/javascript" '("semantic-" "wisent-javascript-jv-expand-tag")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "semantic/wisent/python"
-;;;;;; "cedet/semantic/wisent/python.el" (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/wisent/python.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/python" '("semantic-" "wisent-python-")))
+(register-definition-prefixes "semantic/wisent/grammar" '("wisent-"))
;;;***
@@ -29331,7 +29571,7 @@ Major mode for editing Wisent grammars.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/semantic/wisent/wisent.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "semantic/wisent/wisent" '("$action" "$nterm" "$region" "wisent-")))
+(register-definition-prefixes "semantic/wisent/wisent" '("$action" "$nterm" "$region" "wisent-"))
;;;***
@@ -29551,7 +29791,7 @@ and `default-sendmail-coding-system',
but lower priority than the local value of `buffer-file-coding-system'.
See also the function `select-message-coding-system'.")
-(defvar default-sendmail-coding-system 'iso-latin-1 "\
+(defvar default-sendmail-coding-system 'utf-8 "\
Default coding system for encoding the outgoing mail.
This variable is used only when `sendmail-coding-system' is nil.
@@ -29621,13 +29861,24 @@ Like `mail' command, but display mail buffer in another frame.
\(fn &optional NOERASE TO SUBJECT IN-REPLY-TO CC REPLYBUFFER SENDACTIONS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sendmail" '("mail-" "sendmail-")))
+(register-definition-prefixes "sendmail" '("mail-" "sendmail-"))
;;;***
;;;### (autoloads nil "seq" "emacs-lisp/seq.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/seq.el
-(push (purecopy '(seq 2 21)) package--builtin-versions)
+(push (purecopy '(seq 2 22)) package--builtin-versions)
+
+(autoload 'seq-subseq "seq" "\
+Return the sequence of elements of SEQUENCE from START to END.
+END is exclusive.
+
+If END is omitted, it defaults to the length of the sequence. If
+START or END is negative, it counts from the end. Signal an
+error if START or END are outside of the sequence (i.e too large
+if positive or too small if negative).
+
+\(fn SEQUENCE START &optional END)" nil nil)
(autoload 'seq-take "seq" "\
Take the first N elements of SEQUENCE and return the result.
@@ -29645,15 +29896,8 @@ sorted. FUNCTION must be a function of one argument.
\(fn FUNCTION PRED SEQUENCE)" nil nil)
-(autoload 'seq-concatenate "seq" "\
-Concatenate SEQUENCES into a single sequence of type TYPE.
-TYPE must be one of following symbols: vector, string or list.
-
-
-\(fn TYPE SEQUENCE...)" nil nil)
-
(autoload 'seq-filter "seq" "\
-Return a list of all the elements for which (PRED element) is non-nil in SEQUENCE.
+Return a list of all elements for which (PRED element) is non-nil in SEQUENCE.
\(fn PRED SEQUENCE)" nil nil)
@@ -29676,6 +29920,11 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called.
\(fn FUNCTION SEQUENCE INITIAL-VALUE)" nil nil)
+(autoload 'seq-every-p "seq" "\
+Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE.
+
+\(fn PRED SEQUENCE)" nil nil)
+
(autoload 'seq-some "seq" "\
Return non-nil if PRED is satisfied for at least one element of SEQUENCE.
If so, return the first non-nil value returned by PRED.
@@ -29698,7 +29947,38 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil.
\(fn SEQUENCE ELT &optional TESTFN)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "seq" '("seq-")))
+(autoload 'seq-uniq "seq" "\
+Return a list of the elements of SEQUENCE with duplicates removed.
+TESTFN is used to compare elements, or `equal' if TESTFN is nil.
+
+\(fn SEQUENCE &optional TESTFN)" nil nil)
+
+(autoload 'seq-intersection "seq" "\
+Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
+Equality is defined by TESTFN if non-nil or by `equal' if nil.
+
+\(fn SEQUENCE1 SEQUENCE2 &optional TESTFN)" nil nil)
+
+(autoload 'seq-difference "seq" "\
+Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
+Equality is defined by TESTFN if non-nil or by `equal' if nil.
+
+\(fn SEQUENCE1 SEQUENCE2 &optional TESTFN)" nil nil)
+
+(autoload 'seq-group-by "seq" "\
+Apply FUNCTION to each element of SEQUENCE.
+Separate the elements of SEQUENCE into an alist using the results as
+keys. Keys are compared using `equal'.
+
+\(fn FUNCTION SEQUENCE)" nil nil)
+
+(autoload 'seq-max "seq" "\
+Return the largest element of SEQUENCE.
+SEQUENCE must be a sequence of numbers or markers.
+
+\(fn SEQUENCE)" nil nil)
+
+(register-definition-prefixes "seq" '("seq-"))
;;;***
@@ -29753,10 +30033,19 @@ or call the function `server-mode'.")
(autoload 'server-mode "server" "\
Toggle Server mode.
-If called interactively, enable Server mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Server
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'server-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Server mode runs a process that accepts commands from the
`emacsclient' program. See Info node `Emacs server' and
@@ -29773,7 +30062,7 @@ only these files will be asked to be saved.
\(fn ARG)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "server" '("server-")))
+(register-definition-prefixes "server" '("server-"))
;;;***
@@ -29786,7 +30075,7 @@ Major mode for Simple Emacs Spreadsheet.
When you invoke SES in a new buffer, it is divided into cells
that you can enter data into. You can navigate the cells with
the arrow keys and add more cells with the tab key. The contents
-of these cells can be numbers, text, or Lisp expressions. (To
+of these cells can be numbers, text, or Lisp expressions. (To
enter text, enclose it in double quotes.)
In an expression, you can use cell coordinates to refer to the
@@ -29817,7 +30106,7 @@ These are active only in the minibuffer, when entering or editing a
formula:
\\{ses-mode-edit-map}" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ses" '("ses")))
+(register-definition-prefixes "ses" '("ses"))
;;;***
@@ -29866,13 +30155,13 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6>
<p>Paragraphs only need an opening tag. Line breaks and multiple spaces are
ignored unless the text is <pre>preformatted.</pre> Text can be marked as
-<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or
-Edit/Text Properties/Face commands.
+<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o
+or Edit/Text Properties/Face commands.
Pages can have <a name=\"SOMENAME\">named points</a> and can link other points
to them with <a href=\"#SOMENAME\">see also somename</a>. In the same way <a
href=\"URL\">see also URL</a> where URL is a filename relative to current
-directory, or absolute as in `http://www.cs.indiana.edu/elisp/w3/docs.html'.
+directory, or absolute as in `https://www.cs.indiana.edu/elisp/w3/docs.html'.
Images in many formats can be inlined with <img src=\"URL\">.
@@ -29885,14 +30174,13 @@ To work around that, do:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sgml-mode" '("html-" "sgml-")))
+(register-definition-prefixes "sgml-mode" '("html-" "sgml-"))
;;;***
;;;### (autoloads nil "sh-script" "progmodes/sh-script.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from progmodes/sh-script.el
-(push (purecopy '(sh-script 2 0 6)) package--builtin-versions)
(put 'sh-shell 'safe-local-variable 'symbolp)
(autoload 'sh-mode "sh-script" "\
@@ -29924,11 +30212,9 @@ following commands are available, based on the current shell's syntax:
\\[sh-while] while loop
For sh and rc shells indentation commands are:
-\\[sh-show-indent] Show the variable controlling this line's indentation.
-\\[sh-set-indent] Set then variable controlling this line's indentation.
-\\[sh-learn-line-indent] Change the indentation variable so this line
-would indent to the way it currently is.
-\\[sh-learn-buffer-indent] Set the indentation variables so the
+\\[smie-config-show-indent] Show the rules controlling this line's indentation.
+\\[smie-config-set-indent] Change the rules controlling this line's indentation.
+\\[smie-config-guess] Try to tweak the indentation rules so the
buffer indents as it currently is indented.
@@ -29953,7 +30239,7 @@ with your script for an edit-interpret-debug cycle.
(defalias 'shell-script-mode 'sh-mode)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sh-script" '("sh-")))
+(register-definition-prefixes "sh-script" '("sh-"))
;;;***
@@ -30004,7 +30290,7 @@ function, `load-path-shadows-find'.
\(fn &optional STRINGP)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shadow" '("load-path-shadows-")))
+(register-definition-prefixes "shadow" '("load-path-shadows-"))
;;;***
@@ -30038,7 +30324,7 @@ function). Each site can be either a hostname or the name of a cluster (see
(autoload 'shadow-initialize "shadowfile" "\
Set up file shadowing." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shadowfile" '("shadow")))
+(register-definition-prefixes "shadowfile" '("shadow"))
;;;***
@@ -30054,6 +30340,13 @@ arguments.")
(custom-autoload 'shell-dumb-shell-regexp "shell" t)
+(autoload 'split-string-shell-command "shell" "\
+Split STRING (a shell command) into a list of strings.
+General shell syntax, like single and double quoting, as well as
+backslash quoting, is respected.
+
+\(fn STRING)" nil nil)
+
(autoload 'shell "shell" "\
Run an inferior shell, with I/O through BUFFER (which defaults to `*shell*').
Interactively, a prefix arg means to prompt for BUFFER.
@@ -30090,7 +30383,21 @@ Make the shell buffer the current buffer, and return it.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shell" '("dirs" "explicit-" "shell-")))
+(register-definition-prefixes "shell" '("dirs" "explicit-" "shell-"))
+
+;;;***
+
+;;;### (autoloads nil "shortdoc" "emacs-lisp/shortdoc.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from emacs-lisp/shortdoc.el
+
+(autoload 'shortdoc-display-group "shortdoc" "\
+Pop to a buffer with short documentation summary for functions in GROUP.
+If FUNCTION is non-nil, place point on the entry for FUNCTION (if any).
+
+\(fn GROUP &optional FUNCTION)" t nil)
+
+(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "vector"))
;;;***
@@ -30109,14 +30416,14 @@ DOM should be a parse tree as generated by
\(fn DOM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shr" '("shr-" "svg--wrap-svg")))
+(register-definition-prefixes "shr" '("shr-"))
;;;***
;;;### (autoloads nil "shr-color" "net/shr-color.el" (0 0 0 0))
;;; Generated autoloads from net/shr-color.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "shr-color" '("shr-color-")))
+(register-definition-prefixes "shr-color" '("shr-color-"))
;;;***
@@ -30143,7 +30450,7 @@ DOM should be a parse tree as generated by
\(fn &optional NAME)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sieve" '("sieve-")))
+(register-definition-prefixes "sieve" '("sieve-"))
;;;***
@@ -30151,7 +30458,7 @@ DOM should be a parse tree as generated by
;;;;;; 0))
;;; Generated autoloads from net/sieve-manage.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sieve-manage" '("sieve-")))
+(register-definition-prefixes "sieve-manage" '("sieve-"))
;;;***
@@ -30160,15 +30467,11 @@ DOM should be a parse tree as generated by
(autoload 'sieve-mode "sieve-mode" "\
Major mode for editing Sieve code.
-This is much like C mode except for the syntax of comments. Its keymap
-inherits from C mode's and it has the same variables for customizing
-indentation. It has its own abbrev table and its own syntax table.
-
Turning on Sieve mode runs `sieve-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sieve-mode" '("sieve-")))
+(register-definition-prefixes "sieve-mode" '("sieve-"))
;;;***
@@ -30179,9 +30482,6 @@ Turning on Sieve mode runs `sieve-mode-hook'.
Major mode for editing SIMULA code.
\\{simula-mode-map}
Variables controlling indentation style:
- `simula-tab-always-indent'
- Non-nil means TAB in SIMULA mode should always reindent the current line,
- regardless of where in the line point is when the TAB command is used.
`simula-indent-level'
Indentation of SIMULA statements with respect to containing block.
`simula-substatement-offset'
@@ -30218,7 +30518,7 @@ with no arguments, if that value is non-nil.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "simula" '("simula-")))
+(register-definition-prefixes "simula" '("simula-"))
;;;***
@@ -30340,7 +30640,7 @@ twice for the others.
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "skeleton" '("skeleton-")))
+(register-definition-prefixes "skeleton" '("skeleton-"))
;;;***
@@ -30374,10 +30674,19 @@ buffer names.
(autoload 'smerge-mode "smerge-mode" "\
Minor mode to simplify editing output from the diff3 program.
-If called interactively, enable Smerge mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `SMerge
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `smerge-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\{smerge-mode-map}
@@ -30385,16 +30694,18 @@ enable the mode if ARG is omitted or nil, and toggle it if ARG is
(autoload 'smerge-start-session "smerge-mode" "\
Turn on `smerge-mode' and move point to first conflict marker.
-If no conflict maker is found, turn off `smerge-mode'." t nil)
+If no conflict maker is found, turn off `smerge-mode'.
+
+\(fn &optional INTERACTIVELY)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smerge-mode" '("smerge-")))
+(register-definition-prefixes "smerge-mode" '("smerge-"))
;;;***
;;;### (autoloads nil "smie" "emacs-lisp/smie.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/smie.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smie" '("smie-")))
+(register-definition-prefixes "smie" '("smie-"))
;;;***
@@ -30413,14 +30724,14 @@ interactively. If there's no argument, do it at the current buffer.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smiley" '("gnus-smiley-file-types" "smiley-")))
+(register-definition-prefixes "smiley" '("gnus-smiley-file-types" "smiley-"))
;;;***
;;;### (autoloads nil "smime" "gnus/smime.el" (0 0 0 0))
;;; Generated autoloads from gnus/smime.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smime" '("smime")))
+(register-definition-prefixes "smime" '("smime"))
;;;***
@@ -30432,7 +30743,7 @@ interactively. If there's no argument, do it at the current buffer.
(autoload 'smtpmail-send-queued-mail "smtpmail" "\
Send mail that was queued as a result of setting `smtpmail-queue-mail'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smtpmail" '("smtpmail-")))
+(register-definition-prefixes "smtpmail" '("smtpmail-"))
;;;***
@@ -30455,7 +30766,7 @@ Snake mode keybindings:
\\[snake-move-up] Makes the snake move up
\\[snake-move-down] Makes the snake move down" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snake" '("snake-")))
+(register-definition-prefixes "snake" '("snake-"))
;;;***
@@ -30482,7 +30793,7 @@ Delete converts tabs to spaces as it moves back.
Turning on snmp-mode runs the hooks in `snmp-common-mode-hook',
then `snmpv2-mode-hook'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snmp-mode" '("snmp")))
+(register-definition-prefixes "snmp-mode" '("snmp"))
;;;***
@@ -30499,10 +30810,19 @@ Open the so-long `customize' group." t nil)
(autoload 'so-long-minor-mode "so-long" "\
This is the minor mode equivalent of `so-long-mode'.
-If called interactively, enable So-Long minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `So-Long
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `so-long-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Any active minor modes listed in `so-long-minor-modes' are disabled for the
current buffer, and buffer-local values are assigned to variables in accordance
@@ -30575,10 +30895,19 @@ or call the function `global-so-long-mode'.")
(autoload 'global-so-long-mode "so-long" "\
Toggle automated performance mitigations for files with long lines.
-If called interactively, enable Global So-Long mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+So-Long mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-so-long-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Many Emacs modes struggle with buffers which contain excessively long lines,
and may consequently cause unacceptable performance issues.
@@ -30596,15 +30925,15 @@ Use \\[so-long-customize] to configure the behaviour.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "so-long" '("so-long-" "turn-o")))
+(register-definition-prefixes "so-long" '("so-long-" "turn-o"))
;;;***
;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0))
;;; Generated autoloads from net/soap-client.el
-(push (purecopy '(soap-client 3 1 5)) package--builtin-versions)
+(push (purecopy '(soap-client 3 2 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-client" '("soap-")))
+(register-definition-prefixes "soap-client" '("soap-"))
;;;***
@@ -30612,14 +30941,14 @@ Use \\[so-long-customize] to configure the behaviour.
;;;;;; 0))
;;; Generated autoloads from net/soap-inspect.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-inspect" '("soap-")))
+(register-definition-prefixes "soap-inspect" '("soap-"))
;;;***
;;;### (autoloads nil "socks" "net/socks.el" (0 0 0 0))
;;; Generated autoloads from net/socks.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "socks" '("socks-")))
+(register-definition-prefixes "socks" '("socks-"))
;;;***
@@ -30636,7 +30965,7 @@ This function is suitable for execution in an init file.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solar" '("calendar-" "diary-sunrise-sunset" "solar-")))
+(register-definition-prefixes "solar" '("calendar-" "diary-sunrise-sunset" "solar-"))
;;;***
@@ -30713,7 +31042,7 @@ Pick your favorite shortcuts:
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "solitaire" '("solitaire-")))
+(register-definition-prefixes "solitaire" '("solitaire-"))
;;;***
@@ -30895,14 +31224,14 @@ is non-nil, it also prints a message describing the number of deletions.
\(fn BEG END &optional REVERSE ADJACENT KEEP-BLANKS INTERACTIVE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sort" '("sort-")))
+(register-definition-prefixes "sort" '("sort-"))
;;;***
;;;### (autoloads nil "soundex" "soundex.el" (0 0 0 0))
;;; Generated autoloads from soundex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soundex" '("soundex")))
+(register-definition-prefixes "soundex" '("soundex"))
;;;***
@@ -30918,7 +31247,7 @@ installed through `spam-necessary-extra-headers'.
\(fn &rest SYMBOLS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam" '("spam-")))
+(register-definition-prefixes "spam" '("spam-"))
;;;***
@@ -30959,21 +31288,21 @@ Remove spam-report support from the Agent.
Spam reports will be queued with the method used when
\\[spam-report-agentize] was run." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam-report" '("spam-report-")))
+(register-definition-prefixes "spam-report" '("spam-report-"))
;;;***
;;;### (autoloads nil "spam-stat" "gnus/spam-stat.el" (0 0 0 0))
;;; Generated autoloads from gnus/spam-stat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam-stat" '("spam-stat" "with-spam-stat-max-buffer-size")))
+(register-definition-prefixes "spam-stat" '("spam-stat" "with-spam-stat-max-buffer-size"))
;;;***
;;;### (autoloads nil "spam-wash" "gnus/spam-wash.el" (0 0 0 0))
;;; Generated autoloads from gnus/spam-wash.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spam-wash" '("spam-")))
+(register-definition-prefixes "spam-wash" '("spam-"))
;;;***
@@ -30997,7 +31326,7 @@ Change frame focus to or from the speedbar frame.
If the selected frame is not speedbar, then speedbar frame is
selected. If the speedbar frame is active, then select the attached frame." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "speedbar" '("speedbar-")))
+(register-definition-prefixes "speedbar" '("speedbar-"))
;;;***
@@ -31010,7 +31339,7 @@ Adds that special touch of class to your outgoing mail." t nil)
(autoload 'snarf-spooks "spook" "\
Return a vector containing the lines from `spook-phrases-file'." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "spook" '("spook-phrase")))
+(register-definition-prefixes "spook" '("spook-phrase"))
;;;***
@@ -31065,7 +31394,7 @@ must tell Emacs. Here's how to do that in your init file:
\(add-hook \\='sql-mode-hook
(lambda ()
- (modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))
+ (modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))
\(fn)" t nil)
@@ -31510,7 +31839,7 @@ Run vsql as an inferior process.
\(fn &optional BUFFER)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sql" '("sql-")))
+(register-definition-prefixes "sql" '("sql-"))
;;;***
@@ -31518,7 +31847,7 @@ Run vsql as an inferior process.
;;; Generated autoloads from cedet/srecode.el
(push (purecopy '(srecode 1 2)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode" '("srecode-version")))
+(register-definition-prefixes "srecode" '("srecode-version"))
;;;***
@@ -31526,23 +31855,7 @@ Run vsql as an inferior process.
;;;;;; 0 0))
;;; Generated autoloads from cedet/srecode/args.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/args" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/compile"
-;;;;;; "cedet/srecode/compile.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/compile.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/compile" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/cpp"
-;;;;;; "cedet/srecode/cpp.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/cpp.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/cpp" '("srecode-")))
+(register-definition-prefixes "srecode/args" '("srecode-"))
;;;***
@@ -31550,7 +31863,7 @@ Run vsql as an inferior process.
;;;;;; 0 0))
;;; Generated autoloads from cedet/srecode/ctxt.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/ctxt" '("srecode-")))
+(register-definition-prefixes "srecode/ctxt" '("srecode-"))
;;;***
@@ -31558,31 +31871,7 @@ Run vsql as an inferior process.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/srecode/dictionary.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/dictionary" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/document"
-;;;;;; "cedet/srecode/document.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/document.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/document" '("srecode-document-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/el" "cedet/srecode/el.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/el.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/el" '("srecode-semantic-apply-tag-to-dict")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/expandproto"
-;;;;;; "cedet/srecode/expandproto.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/expandproto.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/expandproto" '("srecode-")))
+(register-definition-prefixes "srecode/dictionary" '("srecode-"))
;;;***
@@ -31590,7 +31879,7 @@ Run vsql as an inferior process.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/srecode/extract.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/extract" '("srecode-extract")))
+(register-definition-prefixes "srecode/extract" '("srecode-extract"))
;;;***
@@ -31598,7 +31887,7 @@ Run vsql as an inferior process.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/srecode/fields.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/fields" '("srecode-")))
+(register-definition-prefixes "srecode/fields" '("srecode-"))
;;;***
@@ -31606,7 +31895,7 @@ Run vsql as an inferior process.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/srecode/filters.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/filters" '("srecode-comment-prefix")))
+(register-definition-prefixes "srecode/filters" '("srecode-comment-prefix"))
;;;***
@@ -31614,39 +31903,7 @@ Run vsql as an inferior process.
;;;;;; 0 0))
;;; Generated autoloads from cedet/srecode/find.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/find" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/getset"
-;;;;;; "cedet/srecode/getset.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/getset.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/getset" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/insert"
-;;;;;; "cedet/srecode/insert.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/insert.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/insert" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/map"
-;;;;;; "cedet/srecode/map.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/map.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/map" '("srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/mode"
-;;;;;; "cedet/srecode/mode.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/mode.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/mode" '("srecode-")))
+(register-definition-prefixes "srecode/find" '("srecode-"))
;;;***
@@ -31654,15 +31911,7 @@ Run vsql as an inferior process.
;;;;;; (0 0 0 0))
;;; Generated autoloads from cedet/srecode/semantic.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/semantic" '("srecode-semantic-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/srt"
-;;;;;; "cedet/srecode/srt.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/srt.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/srt" '("srecode-read-")))
+(register-definition-prefixes "srecode/semantic" '("srecode-semantic-"))
;;;***
@@ -31675,9 +31924,9 @@ Major-mode for writing SRecode macros.
\(fn)" t nil)
-(defalias 'srt-mode 'srecode-template-mode)
+(defalias 'srt-mode #'srecode-template-mode)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/srt-mode" '("semantic-" "srecode-")))
+(register-definition-prefixes "srecode/srt-mode" '("semantic-" "srecode-"))
;;;***
@@ -31685,23 +31934,7 @@ Major-mode for writing SRecode macros.
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/srecode/table.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/table" '("object-sort-list" "srecode-")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/template"
-;;;;;; "cedet/srecode/template.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/template.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/template" '("semantic-tag-components")))
-
-;;;***
-
-;;;### (autoloads "actual autoloads are elsewhere" "srecode/texi"
-;;;;;; "cedet/srecode/texi.el" (0 0 0 0))
-;;; Generated autoloads from cedet/srecode/texi.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "srecode/texi" '("semantic-insert-foreign-tag" "srecode-texi-")))
+(register-definition-prefixes "srecode/table" '("object-sort-list" "srecode-"))
;;;***
@@ -31783,10 +32016,19 @@ or call the function `strokes-mode'.")
(autoload 'strokes-mode "strokes" "\
Toggle Strokes mode, a global minor mode.
-If called interactively, enable Strokes mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Strokes
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'strokes-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\<strokes-mode-map>
Strokes are pictographic mouse gestures which invoke commands.
@@ -31813,7 +32055,7 @@ Optional FORCE non-nil will ignore the buffer's read-only status.
(autoload 'strokes-compose-complex-stroke "strokes" "\
Read a complex stroke and insert its glyph into the current buffer." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "strokes" '("strokes-")))
+(register-definition-prefixes "strokes" '("strokes-"))
;;;***
@@ -31838,6 +32080,27 @@ Studlify-case the current buffer." t nil)
;;;### (autoloads nil "subr-x" "emacs-lisp/subr-x.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/subr-x.el
+(autoload 'if-let "subr-x" "\
+Bind variables according to SPEC and evaluate THEN or ELSE.
+Evaluate each binding in turn, as in `let*', stopping if a
+binding value is nil. If all are non-nil return the value of
+THEN, otherwise the last form in ELSE.
+
+Each element of SPEC is a list (SYMBOL VALUEFORM) that binds
+SYMBOL to the value of VALUEFORM. An element can additionally be
+of the form (VALUEFORM), which is evaluated and checked for nil;
+i.e. SYMBOL can be omitted if only the test result is of
+interest. It can also be of the form SYMBOL, then the binding of
+SYMBOL is checked for nil.
+
+As a special case, interprets a SPEC of the form (SYMBOL SOMETHING)
+like ((SYMBOL SOMETHING)). This exists for backward compatibility
+with an old syntax that accepted only one binding.
+
+\(fn SPEC THEN &rest ELSE)" nil t)
+
+(function-put 'if-let 'lisp-indent-function '2)
+
(autoload 'when-let "subr-x" "\
Bind variables according to SPEC and conditionally evaluate BODY.
Evaluate each binding in turn, stopping if a binding value is nil.
@@ -31849,7 +32112,18 @@ The variable list SPEC is the same as in `if-let'.
(function-put 'when-let 'lisp-indent-function '1)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let" "internal--" "replace-region-contents" "string-" "thread-" "when-let*")))
+(autoload 'string-truncate-left "subr-x" "\
+Truncate STRING to LENGTH, replacing initial surplus with \"...\".
+
+\(fn STRING LENGTH)" nil nil)
+
+(autoload 'string-lines "subr-x" "\
+Split STRING into a list of lines.
+If OMIT-NULLS, empty lines will be removed from the results.
+
+\(fn STRING &optional OMIT-NULLS)" nil nil)
+
+(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*"))
;;;***
@@ -31861,10 +32135,19 @@ The variable list SPEC is the same as in `if-let'.
(autoload 'subword-mode "subword" "\
Toggle subword movement and editing (Subword mode).
-If called interactively, enable Subword mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Subword
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `subword-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Subword mode is a buffer-local minor mode. Enabling it changes
the definition of a word so that word-based commands stop inside
@@ -31901,11 +32184,12 @@ or call the function `global-subword-mode'.")
(autoload 'global-subword-mode "subword" "\
Toggle Subword mode in all buffers.
With prefix ARG, enable Global Subword mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
+
+Subword mode is enabled in all buffers where `(lambda nil
+\(subword-mode 1))' would do it.
-Subword mode is enabled in all buffers where
-`(lambda nil (subword-mode 1))' would do it.
See `subword-mode' for more information on Subword mode.
\(fn &optional ARG)" t nil)
@@ -31913,10 +32197,19 @@ See `subword-mode' for more information on Subword mode.
(autoload 'superword-mode "subword" "\
Toggle superword movement and editing (Superword mode).
-If called interactively, enable Superword mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Superword
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `superword-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Superword mode is a buffer-local minor mode. Enabling it changes
the definition of words such that symbols characters are treated
@@ -31942,16 +32235,17 @@ or call the function `global-superword-mode'.")
(autoload 'global-superword-mode "subword" "\
Toggle Superword mode in all buffers.
With prefix ARG, enable Global Superword mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
+
+Superword mode is enabled in all buffers where `(lambda nil
+\(superword-mode 1))' would do it.
-Superword mode is enabled in all buffers where
-`(lambda nil (superword-mode 1))' would do it.
See `superword-mode' for more information on Superword mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subword" '("subword-" "superword-mode-map")))
+(register-definition-prefixes "subword" '("subword-" "superword-mode-map"))
;;;***
@@ -31983,23 +32277,21 @@ The region need not be active (and typically isn't when this
function is called). Also, the hook `sc-pre-hook' is run before,
and `sc-post-hook' is run after the guts of this function." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "supercite" '("sc-")))
+(register-definition-prefixes "supercite" '("sc-"))
;;;***
;;;### (autoloads nil "svg" "svg.el" (0 0 0 0))
;;; Generated autoloads from svg.el
-(push (purecopy '(svg 1 0)) package--builtin-versions)
+(push (purecopy '(svg 1 1)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "svg" '("svg-")))
+(register-definition-prefixes "svg" '("svg-"))
;;;***
;;;### (autoloads nil "t-mouse" "t-mouse.el" (0 0 0 0))
;;; Generated autoloads from t-mouse.el
-(define-obsolete-function-alias 't-mouse-mode 'gpm-mouse-mode "23.1")
-
(defvar gpm-mouse-mode t "\
Non-nil if Gpm-Mouse mode is enabled.
See the `gpm-mouse-mode' command
@@ -32013,10 +32305,19 @@ or call the function `gpm-mouse-mode'.")
(autoload 'gpm-mouse-mode "t-mouse" "\
Toggle mouse support in GNU/Linux consoles (GPM Mouse mode).
-If called interactively, enable Gpm-Mouse mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Gpm-Mouse
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'gpm-mouse-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
This allows the use of the mouse when operating on a GNU/Linux console,
in the same way as you can use the mouse under X11.
@@ -32028,7 +32329,7 @@ GPM. This is due to limitations in GPM and the Linux kernel.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "t-mouse" '("gpm-mouse-")))
+(register-definition-prefixes "t-mouse" '("gpm-mouse-"))
;;;***
@@ -32038,16 +32339,23 @@ GPM. This is due to limitations in GPM and the Linux kernel.
(autoload 'tab-line-mode "tab-line" "\
Toggle display of window tab line in the buffer.
-If called interactively, enable Tab-Line mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Tab-Line
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
-\(fn &optional ARG)" t nil)
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
-(defvar tab-line-exclude nil)
+To check whether the minor mode is enabled in the current buffer,
+evaluate `tab-line-mode'.
-(make-variable-buffer-local 'tab-line-exclude)
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
+(defvar-local tab-line-exclude nil)
(put 'global-tab-line-mode 'globalized-minor-mode t)
@@ -32064,16 +32372,17 @@ or call the function `global-tab-line-mode'.")
(autoload 'global-tab-line-mode "tab-line" "\
Toggle Tab-Line mode in all buffers.
With prefix ARG, enable Global Tab-Line mode if ARG is positive;
-otherwise, disable it. If called from Lisp, enable the mode if
-ARG is omitted or nil.
+otherwise, disable it. If called from Lisp, enable the mode if ARG is
+omitted or nil.
Tab-Line mode is enabled in all buffers where
`tab-line-mode--turn-on' would do it.
+
See `tab-line-mode' for more information on Tab-Line mode.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tab-line" '("tab-line-")))
+(register-definition-prefixes "tab-line" '("tab-line-"))
;;;***
@@ -32104,7 +32413,7 @@ The variable `tab-width' controls the spacing of tab stops.
\(fn START END &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tabify" '("tabify-regexp")))
+(register-definition-prefixes "tabify" '("tabify-regexp"))
;;;***
@@ -32198,7 +32507,7 @@ Move the point under the table as shown below.
+--------------+------+--------------------------------+
-!-
-Type M-x table-insert-row instead of \\[table-insert-row-column]. \\[table-insert-row-column] does not work
+Type \\[table-insert-row] instead of \\[table-insert-row-column]. \\[table-insert-row-column] does not work
when the point is outside of the table. This insertion at
outside of the table effectively appends a row at the end.
@@ -32398,7 +32707,8 @@ Creates a cell above and a cell below the current point location." t nil)
(autoload 'table-split-cell-horizontally "table" "\
Split current cell horizontally.
-Creates a cell on the left and a cell on the right of the current point location." t nil)
+Creates a cell on the left and a cell on the right of the current
+point location." t nil)
(autoload 'table-split-cell "table" "\
Split current cell in ORIENTATION.
@@ -32446,10 +32756,19 @@ location is indicated by `table-word-continuation-char'. This
variable's value can be toggled by \\[table-fixed-width-mode] at
run-time.
-If called interactively, enable Table-Fixed-Width mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Table-Fixed-Width mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `table-fixed-width-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -32485,14 +32804,14 @@ buffer, and leaves the previous contents of the buffer untouched.
References used for this implementation:
HTML:
- URL `http://www.w3.org'
+ URL `https://www.w3.org'
LaTeX:
- URL `http://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
+ URL `https://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
CALS (DocBook DTD):
- URL `http://www.oasis-open.org/html/a502.htm'
- URL `http://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
+ URL `https://www.oasis-open.org/html/a502.htm'
+ URL `https://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
\(fn LANGUAGE &optional DEST-BUFFER CAPTION)" t nil)
@@ -32668,7 +32987,7 @@ Remove the frame from a table and deactivate the table. This command
converts a table into plain text without frames. It is a companion to
`table-capture' which does the opposite process." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("*table--" "table-")))
+(register-definition-prefixes "table" '("*table--" "table-"))
;;;***
@@ -32690,7 +33009,7 @@ Connect to display DISPLAY for the Emacs talk group.
(autoload 'talk "talk" "\
Connect to the Emacs talk group from the current X display or tty frame." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "talk" '("talk-")))
+(register-definition-prefixes "talk" '("talk-"))
;;;***
@@ -32700,12 +33019,12 @@ Connect to the Emacs talk group from the current X display or tty frame." t nil)
(autoload 'tar-mode "tar-mode" "\
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.
-Type `e' to pull a file out of the tar file and into its own buffer;
+Letters no longer insert themselves.\\<tar-mode-map>
+Type \\[tar-extract] to pull a file out of the tar file and into its own buffer;
or click mouse-2 on the file's line in the Tar mode buffer.
-Type `c' to copy an entry from the tar file into another file on disk.
+Type \\[tar-copy] to copy an entry from the tar file into another file on disk.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[tar-extract] command) and
save it with \\[save-buffer], the contents of that buffer will be
saved back into the tar-file buffer; in this way you can edit a file
inside of a tar archive without extracting it and re-archiving it.
@@ -32715,7 +33034,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tar-mode" '("tar-")))
+(register-definition-prefixes "tar-mode" '("tar-"))
;;;***
@@ -32765,7 +33084,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'.
\(fn COMMAND &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcl" '("add-log-tcl-defun" "calculate-tcl-indent" "indent-tcl-exp" "inferior-tcl-" "run-tcl" "switch-to-tcl" "tcl-")))
+(register-definition-prefixes "tcl" '("inferior-tcl-" "run-tcl" "switch-to-tcl" "tcl-"))
;;;***
@@ -32773,15 +33092,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'.
;;;;;; 0 0 0))
;;; Generated autoloads from emacs-lisp/tcover-ses.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcover-ses" '("ses-exercise")))
-
-;;;***
-
-;;;### (autoloads nil "tcover-unsafep" "emacs-lisp/tcover-unsafep.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from emacs-lisp/tcover-unsafep.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tcover-unsafep" '("testcover-unsafep")))
+(register-definition-prefixes "tcover-ses" '("ses-exercise"))
;;;***
@@ -32808,14 +33119,14 @@ Normally input is edited in Emacs and sent a line at a time.
\(fn HOST)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "telnet" '("send-process-next-char" "telnet-")))
+(register-definition-prefixes "telnet" '("send-process-next-char" "telnet-"))
;;;***
;;;### (autoloads nil "tempo" "tempo.el" (0 0 0 0))
;;; Generated autoloads from tempo.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tempo" '("tempo-")))
+(register-definition-prefixes "tempo" '("tempo-"))
;;;***
@@ -32868,7 +33179,7 @@ use in that buffer.
\(fn PORT SPEED &optional LINE-MODE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("ansi-term-color-vector" "explicit-shell-file-name" "serial-" "term-")))
+(register-definition-prefixes "term" '("ansi-term-color-vector" "serial-" "term-"))
;;;***
@@ -32885,13 +33196,12 @@ If BYTE-COMPILE is non-nil, byte compile each function after instrumenting.
(autoload 'testcover-this-defun "testcover" "\
Start coverage on function under point." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "testcover" '("testcover-")))
+(register-definition-prefixes "testcover" '("testcover-"))
;;;***
;;;### (autoloads nil "tetris" "play/tetris.el" (0 0 0 0))
;;; Generated autoloads from play/tetris.el
-(push (purecopy '(tetris 2 1)) package--builtin-versions)
(autoload 'tetris "tetris" "\
Play the Tetris game.
@@ -32900,19 +33210,17 @@ rotate the shape to fit in with those at the bottom of the screen so
as to form complete rows.
tetris-mode keybindings:
- \\<tetris-mode-map>
-\\[tetris-start-game] Starts a new game of Tetris
-\\[tetris-end-game] Terminates the current game
-\\[tetris-pause-game] Pauses (or resumes) the current game
-\\[tetris-move-left] Moves the shape one square to the left
-\\[tetris-move-right] Moves the shape one square to the right
-\\[tetris-rotate-prev] Rotates the shape clockwise
-\\[tetris-rotate-next] Rotates the shape anticlockwise
-\\[tetris-move-bottom] Drops the shape to the bottom of the playing area
-
-" t nil)
+\\<tetris-mode-map>
+\\[tetris-start-game] Start a new game of Tetris
+\\[tetris-end-game] Terminate the current game
+\\[tetris-pause-game] Pause (or resume) the current game
+\\[tetris-move-left] Move the shape one square to the left
+\\[tetris-move-right] Move the shape one square to the right
+\\[tetris-rotate-prev] Rotate the shape clockwise
+\\[tetris-rotate-next] Rotate the shape anticlockwise
+\\[tetris-move-bottom] Drop the shape to the bottom of the playing area" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tetris" '("tetris-")))
+(register-definition-prefixes "tetris" '("tetris-"))
;;;***
@@ -33041,7 +33349,7 @@ 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 "\
+(defvar tex-default-mode #'latex-mode "\
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.
@@ -33061,17 +33369,20 @@ String inserted by typing \\[tex-insert-quote] to close a quotation.")
(autoload 'tex-mode "tex-mode" "\
Major mode for editing files of input for TeX, LaTeX, or SliTeX.
+This is the shared parent mode of several submodes.
Tries to determine (by looking at the beginning of the file) whether
this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode',
-`latex-mode', or `slitex-mode', respectively. If it cannot be determined,
+`latex-mode', or `slitex-mode', accordingly. If it cannot be determined,
such as if there are no commands in the file, the value of `tex-default-mode'
-says which mode to use." t nil)
+says which mode to use.
+
+\(fn)" t nil)
-(defalias 'TeX-mode 'tex-mode)
+(defalias 'TeX-mode #'tex-mode)
-(defalias 'plain-TeX-mode 'plain-tex-mode)
+(defalias 'plain-TeX-mode #'plain-tex-mode)
-(defalias 'LaTeX-mode 'latex-mode)
+(defalias 'LaTeX-mode #'latex-mode)
(autoload 'plain-tex-mode "tex-mode" "\
Major mode for editing files of input for plain TeX.
@@ -33210,7 +33521,7 @@ Major mode to edit DocTeX files.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tex-mode" '("doctex-font-lock-" "latex-" "plain-tex-mode-map" "tex-")))
+(register-definition-prefixes "tex-mode" '("doctex-font-lock-" "latex-" "plain-tex-mode-map" "tex-"))
;;;***
@@ -33251,7 +33562,7 @@ if large. You can use `Info-split' to do this manually.
\(fn &optional NOSPLIT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "texinfmt" '("batch-texinfo-format" "texinf")))
+(register-definition-prefixes "texinfmt" '("batch-texinfo-format" "texinf"))
;;;***
@@ -33337,15 +33648,7 @@ value of `texinfo-mode-hook'.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "texinfo" '("texinfo-")))
-
-;;;***
-
-;;;### (autoloads nil "texnfo-upd" "textmodes/texnfo-upd.el" (0 0
-;;;;;; 0 0))
-;;; Generated autoloads from textmodes/texnfo-upd.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "texnfo-upd" '("texinfo-")))
+(register-definition-prefixes "texinfo" '("texinfo-"))
;;;***
@@ -33353,7 +33656,7 @@ value of `texinfo-mode-hook'.
;;;;;; (0 0 0 0))
;;; Generated autoloads from emacs-lisp/text-property-search.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "text-property-search" '("text-property-")))
+(register-definition-prefixes "text-property-search" '("text-property-"))
;;;***
@@ -33381,7 +33684,7 @@ Compose Thai characters in the current buffer." t nil)
\(fn GSTRING DIRECTION)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thai-util" '("exit-thai-language-environment-internal" "setup-thai-language-environment-internal" "thai-")))
+(register-definition-prefixes "thai-util" '("exit-thai-language-environment-internal" "setup-thai-language-environment-internal" "thai-"))
;;;***
@@ -33389,7 +33692,7 @@ Compose Thai characters in the current buffer." t nil)
;;;;;; 0))
;;; Generated autoloads from language/thai-word.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thai-word" '("thai-")))
+(register-definition-prefixes "thai-word" '("thai-"))
;;;***
@@ -33453,7 +33756,7 @@ treated as white space.
\(fn &optional IGNORE-COMMENT-OR-STRING)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("beginning-of-thing" "define-thing-chars" "end-of-thing" "filename" "form-at-point" "in-string-p" "sentence-at-point" "thing-at-point-" "word-at-point")))
+(register-definition-prefixes "thingatpt" '("beginning-of-thing" "define-thing-chars" "end-of-thing" "filename" "form-at-point" "in-string-p" "sentence-at-point" "thing-at-point-" "word-at-point"))
;;;***
@@ -33471,7 +33774,7 @@ An EVENT has the format
Display a list of threads." t nil)
(put 'list-threads 'disabled "Beware: manually canceling threads can ruin your Emacs session.")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thread" '("thread-list-")))
+(register-definition-prefixes "thread" '("thread-list-"))
;;;***
@@ -33501,7 +33804,7 @@ In dired, make a thumbs buffer with all files in current directory." t nil)
(autoload 'thumbs-dired-setroot "thumbs" "\
In dired, call the setroot program on the image at point." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thumbs" '("thumbs-")))
+(register-definition-prefixes "thumbs" '("thumbs-"))
;;;***
@@ -33509,7 +33812,7 @@ In dired, call the setroot program on the image at point." t nil)
;;; Generated autoloads from emacs-lisp/thunk.el
(push (purecopy '(thunk 1 0)) package--builtin-versions)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thunk" '("thunk-")))
+(register-definition-prefixes "thunk" '("thunk-"))
;;;***
@@ -33581,7 +33884,7 @@ See also docstring of the function tibetan-compose-region." t nil)
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tibet-util" '("tibetan-")))
+(register-definition-prefixes "tibet-util" '("tibetan-"))
;;;***
@@ -33636,10 +33939,19 @@ This function is meant to be used as a `post-self-insert-hook'." t nil)
(autoload 'tildify-mode "tildify" "\
Adds electric behavior to space character.
-If called interactively, enable Tildify mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Tildify
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `tildify-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When space is inserted into a buffer in a position where hard space is required
instead (determined by `tildify-space-pattern' and `tildify-space-predicates'),
@@ -33652,7 +33964,7 @@ variable will be set to the representation.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tildify" '("tildify-")))
+(register-definition-prefixes "tildify" '("tildify-"))
;;;***
@@ -33685,10 +33997,19 @@ or call the function `display-time-mode'.")
(autoload 'display-time-mode "time" "\
Toggle display of time, load level, and mail flag in mode lines.
-If called interactively, enable Display-Time mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Display-Time mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'display-time-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When Display Time mode is enabled, it updates every minute (you
can control the number of seconds between updates by customizing
@@ -33698,22 +34019,30 @@ runs the normal hook `display-time-hook' after each update.
\(fn &optional ARG)" t nil)
-(autoload 'display-time-world "time" "\
-Enable updating display of times in various time zones.
-`display-time-world-list' specifies the zones.
-To turn off the world time display, go to that window and type `q'." t nil)
+(define-obsolete-function-alias 'display-time-world #'world-clock "28.1")
+
+(autoload 'world-clock "time" "\
+Display a world clock buffer with times in various time zones.
+The variable `world-clock-list' specifies which time zones to use.
+To turn off the world time display, go to the window and type `\\[quit-window]'." t nil)
(autoload 'emacs-uptime "time" "\
Return a string giving the uptime of this instance of Emacs.
FORMAT is a string to format the result, using `format-seconds'.
For example, the Unix uptime command format is \"%D, %z%2h:%.2m\".
+If the optional argument HERE is non-nil, insert string at
+point.
-\(fn &optional FORMAT)" t nil)
+\(fn &optional FORMAT HERE)" t nil)
(autoload 'emacs-init-time "time" "\
-Return a string giving the duration of the Emacs initialization." t nil)
+Return a string giving the duration of the Emacs initialization.
+FORMAT is a string to format the result, using `format'. If nil,
+the default format \"%f seconds\" is used.
+
+\(fn &optional FORMAT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time" '("display-time-" "legacy-style-world-list" "time--display-world-list" "zoneinfo-style-world-list")))
+(register-definition-prefixes "time" '("display-time-" "legacy-style-world-list" "time--display-world-list" "world-clock-" "zoneinfo-style-world-list"))
;;;***
@@ -33799,6 +34128,10 @@ Lower-case specifiers return only the unit.
optional leading \".\" for zero-padding. For example, \"%.3Y\" will
return something of the form \"001 year\".
+The \"%s\" spec takes an additional optional parameter,
+introduced by the \",\" character, to say how many decimals to
+use. \"%,1s\" means \"use one decimal\".
+
The \"%z\" specifier does not print anything. When it is used, specifiers
must be given in order of decreasing size. To the left of \"%z\", nothing
is output until the first non-zero unit is encountered.
@@ -33810,7 +34143,7 @@ Convert the time interval in seconds to a short string.
\(fn DELAY)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("date-" "decoded-time-" "encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value")))
+(register-definition-prefixes "time-date" '("date-" "decoded-time-" "encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value"))
;;;***
@@ -33842,7 +34175,7 @@ look like one of the following:
Time-stamp: <>
Time-stamp: \" \"
The time stamp is written between the brackets or quotes:
- Time-stamp: <2001-02-18 10:20:51 gildea>
+ Time-stamp: <2020-08-07 17:10:21 gildea>
The time stamp is updated only if the variable
`time-stamp-active' is non-nil.
@@ -33854,18 +34187,17 @@ The variables `time-stamp-pattern', `time-stamp-line-limit',
(autoload 'time-stamp-toggle-active "time-stamp" "\
Toggle `time-stamp-active', setting whether \\[time-stamp] updates a buffer.
-With ARG, turn time stamping on if and only if arg is positive.
+With ARG, turn time stamping on if and only if ARG is positive.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-stamp" '("time-stamp-")))
+(register-definition-prefixes "time-stamp" '("time-stamp-"))
;;;***
;;;### (autoloads nil "timeclock" "calendar/timeclock.el" (0 0 0
;;;;;; 0))
;;; Generated autoloads from calendar/timeclock.el
-(push (purecopy '(timeclock 2 6 1)) package--builtin-versions)
(defvar timeclock-mode-line-display nil "\
Non-nil if Timeclock-Mode-Line-Display mode is enabled.
@@ -33967,7 +34299,7 @@ relative only to the time worked today, and not to past time.
\(fn &optional SHOW-SECONDS TODAY-ONLY)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "timeclock" '("timeclock-")))
+(register-definition-prefixes "timeclock" '("timeclock-"))
;;;***
@@ -33981,14 +34313,14 @@ List all timers in a buffer.
\(fn &optional IGNORE-AUTO NONCONFIRM)" t nil)
(put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "timer-list" '("timer-list-")))
+(register-definition-prefixes "timer-list" '("timer-list-"))
;;;***
;;;### (autoloads nil "timezone" "timezone.el" (0 0 0 0))
;;; Generated autoloads from timezone.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "timezone" '("timezone-")))
+(register-definition-prefixes "timezone" '("timezone-"))
;;;***
@@ -34013,14 +34345,13 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\".
\(fn &optional FORCE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter")))
+(register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter"))
;;;***
;;;### (autoloads nil "tmm" "tmm.el" (0 0 0 0))
;;; Generated autoloads from tmm.el
(define-key global-map "\M-`" 'tmm-menubar)
- (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
(autoload 'tmm-menubar "tmm" "\
Text-mode emulation of looking and choosing from a menubar.
@@ -34059,7 +34390,7 @@ instead of executing it.
\(fn MENU &optional IN-POPUP DEFAULT-ITEM NO-EXECUTE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tmm" '("tmm-")))
+(register-definition-prefixes "tmm" '("tmm-"))
;;;***
@@ -34127,7 +34458,7 @@ Mode for displaying and reprioritizing top priority Todo.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "todo-mode" '("todo-")))
+(register-definition-prefixes "todo-mode" '("todo-"))
;;;***
@@ -34199,14 +34530,14 @@ holds a keymap.
\(fn COMMAND ICON IN-MAP &optional FROM-MAP &rest PROPS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tool-bar" '("tool-bar-")))
+(register-definition-prefixes "tool-bar" '("tool-bar-"))
;;;***
;;;### (autoloads nil "tooltip" "tooltip.el" (0 0 0 0))
;;; Generated autoloads from tooltip.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tooltip" '("tooltip-")))
+(register-definition-prefixes "tooltip" '("tooltip-"))
;;;***
@@ -34221,7 +34552,7 @@ to a tcp server on another machine.
\(fn PROCESS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tq" '("tq-")))
+(register-definition-prefixes "tq" '("tq-"))
;;;***
@@ -34270,13 +34601,14 @@ the output buffer or changing the window configuration.
(defalias 'trace-function 'trace-function-foreground)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trace" '("inhibit-trace" "trace-" "untrace-")))
+(register-definition-prefixes "trace" '("inhibit-trace" "trace-" "untrace-"))
;;;***
;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0))
;;; Generated autoloads from net/tramp.el
-(push (purecopy '(tramp 2 4 5 27 2)) package--builtin-versions)
+ (when (featurep 'tramp-compat)
+ (load "tramp-compat" 'noerror 'nomessage))
(defvar tramp-mode t "\
Whether Tramp is enabled.
@@ -34306,29 +34638,26 @@ match file names at root of the underlying local file system,
like \"/sys\" or \"/C:\".")
(defun tramp-autoload-file-name-handler (operation &rest args) "\
-Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args))
+Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory temporary-file-directory)) (when (bound-and-true-p tramp-archive-autoload) (load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror 'nomessage))) (apply operation args))
(defun tramp-register-autoload-file-name-handlers nil "\
-Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put 'tramp-autoload-file-name-handler 'safe-magic t))
+Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))
(tramp-register-autoload-file-name-handlers)
(defun tramp-unload-file-name-handlers nil "\
Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))
-(defvar tramp-completion-mode nil "\
-If non-nil, external packages signal that they are in file name completion.")
-
(defun tramp-unload-tramp nil "\
Discard Tramp from loading remote files." (interactive) (ignore-errors (unload-feature 'tramp 'force)))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp" '("tramp-" "with-")))
+(register-definition-prefixes "tramp" '("tramp-" "with-"))
;;;***
;;;### (autoloads nil "tramp-adb" "net/tramp-adb.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-adb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-adb" '("tramp-")))
+(register-definition-prefixes "tramp-adb" '("tramp-"))
;;;***
@@ -34350,30 +34679,31 @@ It must be supported by libarchive(3).")
(defmacro tramp-archive-autoload-file-name-regexp nil "\
Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'"))
-(defalias 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler)
+(defun tramp-archive-autoload-file-name-handler (operation &rest args) "\
+Load Tramp archive file name handler, and perform OPERATION." (when tramp-archive-enabled (let ((default-directory temporary-file-directory) (tramp-archive-autoload t)) tramp-archive-autoload (apply #'tramp-autoload-file-name-handler operation args))))
(defun tramp-register-archive-file-name-handler nil "\
-Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))
+Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))
(add-hook 'after-init-hook #'tramp-register-archive-file-name-handler)
(add-hook 'tramp-archive-unload-hook (lambda nil (remove-hook 'after-init-hook #'tramp-register-archive-file-name-handler)))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-archive" '("tramp-" "with-parsed-tramp-archive-file-name")))
+(register-definition-prefixes "tramp-archive" '("tramp-" "with-parsed-tramp-archive-file-name"))
;;;***
;;;### (autoloads nil "tramp-cache" "net/tramp-cache.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-cache.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-cache" '("tramp-")))
+(register-definition-prefixes "tramp-cache" '("tramp-"))
;;;***
;;;### (autoloads nil "tramp-cmds" "net/tramp-cmds.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-cmds.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-cmds" '("tramp-")))
+(register-definition-prefixes "tramp-cmds" '("tramp-"))
;;;***
@@ -34381,21 +34711,35 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;;;; 0))
;;; Generated autoloads from net/tramp-compat.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-compat" '("tramp-")))
+(register-definition-prefixes "tramp-compat" '("tramp-"))
+
+;;;***
+
+;;;### (autoloads nil "tramp-crypt" "net/tramp-crypt.el" (0 0 0 0))
+;;; Generated autoloads from net/tramp-crypt.el
+
+(register-definition-prefixes "tramp-crypt" '("tramp-crypt-"))
;;;***
;;;### (autoloads nil "tramp-ftp" "net/tramp-ftp.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-ftp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-ftp" '("tramp-")))
+(register-definition-prefixes "tramp-ftp" '("tramp-"))
+
+;;;***
+
+;;;### (autoloads nil "tramp-fuse" "net/tramp-fuse.el" (0 0 0 0))
+;;; Generated autoloads from net/tramp-fuse.el
+
+(register-definition-prefixes "tramp-fuse" '("tramp-fuse-"))
;;;***
;;;### (autoloads nil "tramp-gvfs" "net/tramp-gvfs.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-gvfs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-")))
+(register-definition-prefixes "tramp-gvfs" '("tramp-" "with-tramp-dbus-"))
;;;***
@@ -34403,7 +34747,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;;;; (0 0 0 0))
;;; Generated autoloads from net/tramp-integration.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-integration" '("tramp-")))
+(register-definition-prefixes "tramp-integration" '("tramp-"))
;;;***
@@ -34411,21 +34755,28 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;;;; 0))
;;; Generated autoloads from net/tramp-rclone.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-rclone" '("tramp-rclone-")))
+(register-definition-prefixes "tramp-rclone" '("tramp-rclone-"))
;;;***
;;;### (autoloads nil "tramp-sh" "net/tramp-sh.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-sh.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-sh" '("tramp-")))
+(register-definition-prefixes "tramp-sh" '("tramp-"))
;;;***
;;;### (autoloads nil "tramp-smb" "net/tramp-smb.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-smb.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-smb" '("tramp-smb-")))
+(register-definition-prefixes "tramp-smb" '("tramp-smb-"))
+
+;;;***
+
+;;;### (autoloads nil "tramp-sshfs" "net/tramp-sshfs.el" (0 0 0 0))
+;;; Generated autoloads from net/tramp-sshfs.el
+
+(register-definition-prefixes "tramp-sshfs" '("tramp-sshfs-"))
;;;***
@@ -34433,28 +34784,90 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive
;;;;;; 0 0 0))
;;; Generated autoloads from net/tramp-sudoedit.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-sudoedit" '("tramp-sudoedit-")))
+(register-definition-prefixes "tramp-sudoedit" '("tramp-sudoedit-"))
;;;***
;;;### (autoloads nil "tramp-uu" "net/tramp-uu.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-uu.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-uu" '("tramp-uu")))
+(register-definition-prefixes "tramp-uu" '("tramp-uu"))
;;;***
;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0))
;;; Generated autoloads from net/trampver.el
+(push (purecopy '(tramp 2 5 2 -1)) package--builtin-versions)
+
+(register-definition-prefixes "trampver" '("tramp-"))
+
+;;;***
+
+;;;### (autoloads nil "transient" "transient.el" (0 0 0 0))
+;;; Generated autoloads from transient.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-")))
+(autoload 'transient-insert-suffix "transient" "\
+Insert a SUFFIX into PREFIX before LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'.
+
+\(fn PREFIX LOC SUFFIX)" nil nil)
+
+(function-put 'transient-insert-suffix 'lisp-indent-function 'defun)
+
+(autoload 'transient-append-suffix "transient" "\
+Insert a SUFFIX into PREFIX after LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'.
+
+\(fn PREFIX LOC SUFFIX)" nil nil)
+
+(function-put 'transient-append-suffix 'lisp-indent-function 'defun)
+
+(autoload 'transient-replace-suffix "transient" "\
+Replace the suffix at LOC in PREFIX with SUFFIX.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'.
+
+\(fn PREFIX LOC SUFFIX)" nil nil)
+
+(function-put 'transient-replace-suffix 'lisp-indent-function 'defun)
+
+(autoload 'transient-remove-suffix "transient" "\
+Remove the suffix or group at LOC in PREFIX.
+PREFIX is a prefix command, a symbol.
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'.
+
+\(fn PREFIX LOC)" nil nil)
+
+(function-put 'transient-remove-suffix 'lisp-indent-function 'defun)
+
+(register-definition-prefixes "transient" '("transient-"))
;;;***
;;;### (autoloads nil "tree-widget" "tree-widget.el" (0 0 0 0))
;;; Generated autoloads from tree-widget.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tree-widget" '("tree-widget-")))
+(register-definition-prefixes "tree-widget" '("tree-widget-"))
;;;***
@@ -34480,7 +34893,7 @@ resumed later.
\(fn &optional ARG DONT-ASK-FOR-REVERT)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tutorial" '("get-lang-string" "lang-strings" "tutorial--")))
+(register-definition-prefixes "tutorial" '("get-lang-string" "lang-strings" "tutorial--"))
;;;***
@@ -34492,7 +34905,7 @@ resumed later.
\(fn FROM TO FONT-OBJECT STRING DIRECTION)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tv-util" '("tai-viet-")))
+(register-definition-prefixes "tv-util" '("tai-viet-"))
;;;***
@@ -34500,8 +34913,8 @@ resumed later.
;;;;;; 0 0))
;;; Generated autoloads from textmodes/two-column.el
(autoload '2C-command "two-column" () t 'keymap)
- (global-set-key "\C-x6" '2C-command)
- (global-set-key [f2] '2C-command)
+ (global-set-key "\C-x6" #'2C-command)
+ (global-set-key [f2] #'2C-command)
(autoload '2C-two-columns "two-column" "\
Split current window vertically for two-column editing.
@@ -34514,11 +34927,13 @@ first and the associated buffer to its right.
\(fn &optional BUFFER)" t nil)
(autoload '2C-associate-buffer "two-column" "\
-Associate another buffer with this one in two-column minor mode.
+Associate another BUFFER with this one in two-column minor mode.
Can also be used to associate a just previously visited file, by
accepting the proposed default buffer.
-\(See \\[describe-mode] .)" t nil)
+\(See \\[describe-mode] .)
+
+\(fn BUFFER)" t nil)
(autoload '2C-split "two-column" "\
Split a two-column text at point, into two buffers in two-column minor mode.
@@ -34540,7 +34955,7 @@ First column's text sSs Second column's text
\(fn ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "two-column" '("2C-")))
+(register-definition-prefixes "two-column" '("2C-"))
;;;***
@@ -34561,10 +34976,19 @@ or call the function `type-break-mode'.")
Enable or disable typing-break mode.
This is a minor mode, but it is global to all buffers by default.
-If called interactively, enable Type-Break mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Type-Break
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'type-break-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When this mode is enabled, the user is encouraged to take typing breaks at
appropriate intervals; either after a specified amount of time or when the
@@ -34673,7 +35097,7 @@ FRAC should be the inverse of the fractional value; for example, a value of
\(fn WPM &optional WORDLEN FRAC)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "type-break" '("timep" "type-break-")))
+(register-definition-prefixes "type-break" '("timep" "type-break-"))
;;;***
@@ -34688,7 +35112,7 @@ You might need to set `uce-mail-reader' before using this.
\(fn &optional IGNORED)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "uce" '("uce-")))
+(register-definition-prefixes "uce" '("uce-"))
;;;***
@@ -34756,7 +35180,7 @@ Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus.
\(fn STR)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs")))
+(register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs"))
;;;***
@@ -34781,14 +35205,6 @@ which specify the range to operate on.
;;;***
-;;;### (autoloads "actual autoloads are elsewhere" "undigest" "mail/undigest.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from mail/undigest.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "undigest" '("rmail-")))
-
-;;;***
-
;;;### (autoloads nil "unrmail" "mail/unrmail.el" (0 0 0 0))
;;; Generated autoloads from mail/unrmail.el
@@ -34805,7 +35221,7 @@ The variable `unrmail-mbox-format' controls which mbox format to use.
\(fn FILE TO-FILE)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unrmail" '("unrmail-mbox-format")))
+(register-definition-prefixes "unrmail" '("unrmail-mbox-format"))
;;;***
@@ -34815,11 +35231,11 @@ The variable `unrmail-mbox-format' controls which mbox format to use.
(autoload 'unsafep "unsafep" "\
Return nil if evaluating FORM couldn't possibly do any harm.
Otherwise result is a reason why FORM is unsafe.
-UNSAFEP-VARS is a list of symbols with local bindings.
+VARS is a list of symbols with local bindings like `unsafep-vars'.
-\(fn FORM &optional UNSAFEP-VARS)" nil nil)
+\(fn FORM &optional VARS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "unsafep" '("safe-functions" "unsafep-")))
+(register-definition-prefixes "unsafep" '("safe-functions" "unsafep-"))
;;;***
@@ -34875,14 +35291,14 @@ how long to wait for a response before giving up.
\(fn URL &optional SILENT INHIBIT-COOKIES TIMEOUT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url" '("url-")))
+(register-definition-prefixes "url" '("url-"))
;;;***
;;;### (autoloads nil "url-about" "url/url-about.el" (0 0 0 0))
;;; Generated autoloads from url/url-about.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-about" '("url-")))
+(register-definition-prefixes "url-about" '("url-"))
;;;***
@@ -34925,7 +35341,7 @@ RATING a rating between 1 and 10 of the strength of the authentication.
\(fn TYPE &optional FUNCTION RATING)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-auth" '("url-")))
+(register-definition-prefixes "url-auth" '("url-"))
;;;***
@@ -34948,7 +35364,7 @@ Extract FNAM from the local disk cache.
\(fn FNAM)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-cache" '("url-")))
+(register-definition-prefixes "url-cache" '("url-"))
;;;***
@@ -34960,14 +35376,14 @@ Extract FNAM from the local disk cache.
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-cid" '("url-cid-gnus")))
+(register-definition-prefixes "url-cid" '("url-cid-gnus"))
;;;***
;;;### (autoloads nil "url-cookie" "url/url-cookie.el" (0 0 0 0))
;;; Generated autoloads from url/url-cookie.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-cookie" '("url-cookie")))
+(register-definition-prefixes "url-cookie" '("url-cookie"))
;;;***
@@ -35003,28 +35419,28 @@ added to this list, so most requests can just pass in nil.
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-dav" '("url-")))
+(register-definition-prefixes "url-dav" '("url-dav-"))
;;;***
;;;### (autoloads nil "url-dired" "url/url-dired.el" (0 0 0 0))
;;; Generated autoloads from url/url-dired.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-dired" '("url-")))
+(register-definition-prefixes "url-dired" '("url-"))
;;;***
;;;### (autoloads nil "url-domsuf" "url/url-domsuf.el" (0 0 0 0))
;;; Generated autoloads from url/url-domsuf.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-domsuf" '("url-domsuf-")))
+(register-definition-prefixes "url-domsuf" '("url-domsuf-"))
;;;***
;;;### (autoloads nil "url-expand" "url/url-expand.el" (0 0 0 0))
;;; Generated autoloads from url/url-expand.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-expand" '("url-")))
+(register-definition-prefixes "url-expand" '("url-"))
;;;***
@@ -35036,21 +35452,21 @@ Handle file: and ftp: URLs.
\(fn URL CALLBACK CBARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-file" '("url-file-")))
+(register-definition-prefixes "url-file" '("url-file-"))
;;;***
;;;### (autoloads nil "url-ftp" "url/url-ftp.el" (0 0 0 0))
;;; Generated autoloads from url/url-ftp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-ftp" '("url-ftp")))
+(register-definition-prefixes "url-ftp" '("url-ftp"))
;;;***
;;;### (autoloads nil "url-future" "url/url-future.el" (0 0 0 0))
;;; Generated autoloads from url/url-future.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-future" '("url-future-")))
+(register-definition-prefixes "url-future" '("url-future-"))
;;;***
@@ -35073,7 +35489,7 @@ overriding the value of `url-gateway-method'.
\(fn NAME BUFFER HOST SERVICE &optional GATEWAY-METHOD)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-gw" '("url-")))
+(register-definition-prefixes "url-gw" '("url-"))
;;;***
@@ -35094,10 +35510,19 @@ or call the function `url-handler-mode'.")
(autoload 'url-handler-mode "url-handlers" "\
Toggle using `url' library for URL filenames (URL Handler mode).
-If called interactively, enable Url-Handler mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Url-Handler mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'url-handler-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
@@ -35136,14 +35561,14 @@ if it had been inserted from a file named URL.
\(fn URL &optional VISIT BEG END REPLACE)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-handlers" '("url-")))
+(register-definition-prefixes "url-handlers" '("url-"))
;;;***
;;;### (autoloads nil "url-history" "url/url-history.el" (0 0 0 0))
;;; Generated autoloads from url/url-history.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-history" '("url-")))
+(register-definition-prefixes "url-history" '("url-"))
;;;***
@@ -35157,14 +35582,14 @@ if it had been inserted from a file named URL.
(autoload 'url-https-file-readable-p "url-http")
(autoload 'url-https-file-attributes "url-http")
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-http" '("url-h")))
+(register-definition-prefixes "url-http" '("url-h"))
;;;***
;;;### (autoloads nil "url-imap" "url/url-imap.el" (0 0 0 0))
;;; Generated autoloads from url/url-imap.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-imap" '("url-imap")))
+(register-definition-prefixes "url-imap" '("url-imap"))
;;;***
@@ -35176,7 +35601,7 @@ if it had been inserted from a file named URL.
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-irc" '("url-irc-")))
+(register-definition-prefixes "url-irc" '("url-irc-"))
;;;***
@@ -35191,7 +35616,7 @@ URL can be a URL string, or a URL record of the type returned by
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-ldap" '("url-ldap-")))
+(register-definition-prefixes "url-ldap" '("url-ldap-"))
;;;***
@@ -35208,14 +35633,14 @@ Handle the mailto: URL syntax.
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-mailto" '("url-mail-goto-field")))
+(register-definition-prefixes "url-mailto" '("url-mail-goto-field"))
;;;***
;;;### (autoloads nil "url-methods" "url/url-methods.el" (0 0 0 0))
;;; Generated autoloads from url/url-methods.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-methods" '("url-scheme-")))
+(register-definition-prefixes "url-methods" '("url-scheme-"))
;;;***
@@ -35248,7 +35673,7 @@ Fetch a data URL (RFC 2397).
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-misc" '("url-do-terminal-emulator")))
+(register-definition-prefixes "url-misc" '("url-do-terminal-emulator"))
;;;***
@@ -35265,14 +35690,14 @@ Fetch a data URL (RFC 2397).
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-news" '("url-news-")))
+(register-definition-prefixes "url-news" '("url-news-"))
;;;***
;;;### (autoloads nil "url-nfs" "url/url-nfs.el" (0 0 0 0))
;;; Generated autoloads from url/url-nfs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-nfs" '("url-nfs")))
+(register-definition-prefixes "url-nfs" '("url-nfs"))
;;;***
@@ -35325,7 +35750,7 @@ parses to
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-parse" '("url-")))
+(register-definition-prefixes "url-parse" '("url-"))
;;;***
@@ -35335,14 +35760,14 @@ parses to
(autoload 'url-setup-privacy-info "url-privacy" "\
Setup variables that expose info about you and your system." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-privacy" '("url-device-type")))
+(register-definition-prefixes "url-privacy" '("url-device-type"))
;;;***
;;;### (autoloads nil "url-proxy" "url/url-proxy.el" (0 0 0 0))
;;; Generated autoloads from url/url-proxy.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-proxy" '("url-")))
+(register-definition-prefixes "url-proxy" '("url-"))
;;;***
@@ -35358,7 +35783,7 @@ The variable `url-queue-timeout' sets a timeout.
\(fn URL CALLBACK &optional CBARGS SILENT INHIBIT-COOKIES)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-queue" '("url-queue")))
+(register-definition-prefixes "url-queue" '("url-queue"))
;;;***
@@ -35378,7 +35803,7 @@ would have been passed to OPERATION.
\(fn OPERATION &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-tramp" '("url-tramp-convert-")))
+(register-definition-prefixes "url-tramp" '("url-tramp-convert-"))
;;;***
@@ -35496,11 +35921,14 @@ instead of just \"key\" as in the example above.
\(fn QUERY &optional SEMICOLONS KEEP-EMPTY)" nil nil)
(autoload 'url-unhex-string "url-util" "\
-Remove %XX embedded spaces, etc in a URL.
+Decode %XX sequences in a percent-encoded URL.
If optional second argument ALLOW-NEWLINES is non-nil, then allow the
decoding of carriage returns and line feeds in the string, which is normally
forbidden in URL encoding.
+The resulting string in general requires decoding using an
+appropriate coding-system; see `decode-coding-string'.
+
\(fn STR &optional ALLOW-NEWLINES)" nil nil)
(autoload 'url-hexify-string "url-util" "\
@@ -35558,14 +35986,14 @@ is \"www.fsf.co.uk\".
\(fn URL)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-util" '("url-")))
+(register-definition-prefixes "url-util" '("url-"))
;;;***
;;;### (autoloads nil "url-vars" "url/url-vars.el" (0 0 0 0))
;;; Generated autoloads from url/url-vars.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-vars" '("url-")))
+(register-definition-prefixes "url-vars" '("url-"))
;;;***
@@ -35602,7 +36030,12 @@ The buffer in question is current when this function is called.
\(fn FILENAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged")))
+(autoload 'userlock--handle-unlock-error "userlock" "\
+Report an ERROR that occurred while unlocking a file.
+
+\(fn ERROR)" nil nil)
+
+(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--"))
;;;***
@@ -35629,7 +36062,7 @@ The buffer in question is current when this function is called.
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "utf-7" '("utf-7-")))
+(register-definition-prefixes "utf-7" '("utf-7-"))
;;;***
@@ -35641,7 +36074,7 @@ Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil.
\(fn STRING &optional FOR-IMAP)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "utf7" '("utf7-")))
+(register-definition-prefixes "utf7" '("utf7-"))
;;;***
@@ -35667,7 +36100,7 @@ If FILE-NAME is non-nil, save the result to FILE-NAME.
\(fn START END &optional FILE-NAME)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "uudecode" '("uudecode-")))
+(register-definition-prefixes "uudecode" '("uudecode-"))
;;;***
@@ -35704,7 +36137,10 @@ Note that if FILE is a symbolic link, it will not be resolved --
the responsible backend system for the symbolic link itself will
be reported.
-\(fn FILE)" nil nil)
+If NO-ERROR is nil, signal an error that no VC backend is
+responsible for the given file.
+
+\(fn FILE &optional NO-ERROR)" nil nil)
(autoload 'vc-next-action "vc" "\
Do the next logical version control operation on the current fileset.
@@ -35746,6 +36182,22 @@ first backend that could register the file is used.
\(fn &optional VC-FILESET COMMENT)" t nil)
+(autoload 'vc-ignore "vc" "\
+Ignore FILE under the VCS of DIRECTORY.
+
+Normally, FILE is a wildcard specification that matches the files
+to be ignored. When REMOVE is non-nil, remove FILE from the list
+of ignored files.
+
+DIRECTORY defaults to `default-directory' and is used to
+determine the responsible VC backend.
+
+When called interactively, prompt for a FILE to ignore, unless a
+prefix argument is given, in which case prompt for a file FILE to
+remove from the list of ignored files.
+
+\(fn FILE &optional DIRECTORY REMOVE)" t nil)
+
(autoload 'vc-version-diff "vc" "\
Report diffs between revisions REV1 and REV2 in the repository history.
This compares two revisions of the current fileset.
@@ -35900,7 +36352,7 @@ with its diffs (if the underlying VCS supports that).
\(fn &optional LIMIT REVISION)" t nil)
(autoload 'vc-print-branch-log "vc" "\
-Show the change log for BRANCH in a window.
+Show the change log for BRANCH root in a window.
\(fn BRANCH)" t nil)
@@ -35948,8 +36400,6 @@ Revert working copies of the selected fileset to their repository contents.
This asks for confirmation if the buffer contents are not identical
to the working revision (except for keyword expansion)." t nil)
-(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
-
(autoload 'vc-pull "vc" "\
Update the current fileset or branch.
You must be visiting a version controlled file, or in a `vc-dir' buffer.
@@ -36038,7 +36488,7 @@ Return the branch part of a revision number REV.
\(fn REV)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc" '("vc-" "with-vc-properties")))
+(register-definition-prefixes "vc" '("vc-" "with-vc-properties"))
;;;***
@@ -36079,7 +36529,7 @@ should be applied to the background or to the foreground.
\(fn FILE REV &optional DISPLAY-MODE BUF MOVE-POINT-TO VC-BK)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-annotate" '("vc-")))
+(register-definition-prefixes "vc-annotate" '("vc-"))
;;;***
@@ -36097,7 +36547,7 @@ Name of the format file in a .bzr directory.")
(load "vc-bzr" nil t)
(vc-bzr-registered file))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-bzr" '("vc-bzr-")))
+(register-definition-prefixes "vc-bzr" '("vc-bzr-"))
;;;***
@@ -36110,20 +36560,25 @@ Name of the format file in a .bzr directory.")
(load "vc-cvs" nil t)
(vc-cvs-registered f)))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-cvs" '("vc-cvs-")))
+(register-definition-prefixes "vc-cvs" '("vc-cvs-"))
;;;***
;;;### (autoloads nil "vc-dav" "vc/vc-dav.el" (0 0 0 0))
;;; Generated autoloads from vc/vc-dav.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-dav" '("vc-dav-")))
+(register-definition-prefixes "vc-dav" '("vc-dav-"))
;;;***
;;;### (autoloads nil "vc-dir" "vc/vc-dir.el" (0 0 0 0))
;;; Generated autoloads from vc/vc-dir.el
+(autoload 'vc-dir-root "vc-dir" "\
+Run `vc-dir' in the repository root directory without prompt.
+If the default directory of the current buffer is
+not under version control, prompt for a directory." t nil)
+
(autoload 'vc-dir "vc-dir" "\
Show the VC status for \"interesting\" files in and below DIR.
This allows you to mark files and perform VC operations on them.
@@ -36143,7 +36598,14 @@ These are the commands available for use in the file status buffer:
\(fn DIR &optional BACKEND)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-dir" '("vc-")))
+(autoload 'vc-dir-bookmark-jump "vc-dir" "\
+Provides the bookmark-jump behavior for a `vc-dir' buffer.
+This implements the `handler' function interface for the record
+type returned by `vc-dir-bookmark-make-record'.
+
+\(fn BMK)" nil nil)
+
+(register-definition-prefixes "vc-dir" '("vc-"))
;;;***
@@ -36169,14 +36631,14 @@ case, and the process object in the asynchronous case.
\(fn BUFFER OKSTATUS COMMAND FILE-OR-LIST &rest FLAGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-dispatcher" '("vc-")))
+(register-definition-prefixes "vc-dispatcher" '("vc-"))
;;;***
;;;### (autoloads nil "vc-filewise" "vc/vc-filewise.el" (0 0 0 0))
;;; Generated autoloads from vc/vc-filewise.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-filewise" '("vc-")))
+(register-definition-prefixes "vc-filewise" '("vc-"))
;;;***
@@ -36189,7 +36651,7 @@ case, and the process object in the asynchronous case.
(load "vc-git" nil t)
(vc-git-registered file))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-git" '("vc-git-")))
+(register-definition-prefixes "vc-git" '("vc-git-"))
;;;***
@@ -36202,7 +36664,7 @@ case, and the process object in the asynchronous case.
(load "vc-hg" nil t)
(vc-hg-registered file))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-hg" '("vc-hg-")))
+(register-definition-prefixes "vc-hg" '("vc-hg-"))
;;;***
@@ -36220,7 +36682,7 @@ Name of the monotone directory's format file.")
(load "vc-mtn" nil t)
(vc-mtn-registered file))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-mtn" '("vc-mtn-")))
+(register-definition-prefixes "vc-mtn" '("vc-mtn-"))
;;;***
@@ -36235,7 +36697,7 @@ For a description of possible values, see `vc-check-master-templates'.")
(defun vc-rcs-registered (f) (vc-default-registered 'RCS f))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-rcs" '("vc-r")))
+(register-definition-prefixes "vc-rcs" '("vc-r"))
;;;***
@@ -36255,7 +36717,7 @@ Return the name of a master file in the SCCS project directory.
Does not check whether the file exists but returns nil if it does not
find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) (when project-dir (if (file-name-absolute-p project-dir) (setq dirs '("SCCS" "")) (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) (setq project-dir (expand-file-name (concat "~" project-dir)))) (while (and (not dir) dirs) (setq dir (expand-file-name (car dirs) project-dir)) (unless (file-directory-p dir) (setq dir nil) (setq dirs (cdr dirs)))) (and dir (expand-file-name (concat "s." basename) dir)))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-sccs" '("vc-sccs-")))
+(register-definition-prefixes "vc-sccs" '("vc-sccs-"))
;;;***
@@ -36270,7 +36732,7 @@ For a description of possible values, see `vc-check-master-templates'.")
(defun vc-src-registered (f) (vc-default-registered 'src f))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-src" '("vc-src-")))
+(register-definition-prefixes "vc-src" '("vc-src-"))
;;;***
@@ -36285,14 +36747,14 @@ For a description of possible values, see `vc-check-master-templates'.")
(load "vc-svn" nil t)
(vc-svn-registered f))))
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-svn" '("vc-svn-")))
+(register-definition-prefixes "vc-svn" '("vc-svn-"))
;;;***
;;;### (autoloads nil "vcursor" "vcursor.el" (0 0 0 0))
;;; Generated autoloads from vcursor.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vcursor" '("vcursor-")))
+(register-definition-prefixes "vcursor" '("vcursor-"))
;;;***
@@ -36340,7 +36802,7 @@ Add a description of the problem and include a reproducible test case.
Feel free to send questions and enhancement requests to <reto@gnu.org>.
Official distribution is at
-URL `http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html'
+URL `https://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html'
The Vera Mode Maintainer
@@ -36353,14 +36815,14 @@ Key bindings:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vera-mode" '("vera-")))
+(register-definition-prefixes "vera-mode" '("vera-"))
;;;***
;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/verilog-mode.el
-(push (purecopy '(verilog-mode 2019 12 17 268053413)) package--builtin-versions)
+(push (purecopy '(verilog-mode 2021 4 12 188864585)) package--builtin-versions)
(autoload 'verilog-mode "verilog-mode" "\
Major mode for editing Verilog code.
@@ -36496,7 +36958,7 @@ Key bindings specific to `verilog-mode-map' are:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "verilog-mode" '("electric-verilog-" "verilog-" "vl-")))
+(register-definition-prefixes "verilog-mode" '("electric-verilog-" "verilog-" "vl-"))
;;;***
@@ -37053,7 +37515,7 @@ Key bindings:
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vhdl-mode" '("vhdl-")))
+(register-definition-prefixes "vhdl-mode" '("vhdl-"))
;;;***
@@ -37096,7 +37558,7 @@ Convert Vietnamese characters of the current buffer to `VIQR' mnemonics." t nil)
\(fn FROM TO)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viet-util" '("viet-viqr-alist" "viqr-regexp")))
+(register-definition-prefixes "viet-util" '("viet-viqr-alist" "viqr-regexp"))
;;;***
@@ -37109,15 +37571,13 @@ If nil, make an icon of the frame. If non-nil, delete the frame.")
(custom-autoload 'view-remove-frame-by-deleting "view" t)
-(defvar view-mode nil "\
+(defvar-local view-mode nil "\
Non-nil if View mode is enabled.
Don't change this variable directly, you must change it by one of the
functions that enable or disable view mode.")
-(make-variable-buffer-local 'view-mode)
-
(autoload 'kill-buffer-if-not-modified "view" "\
-Like `kill-buffer', but does nothing if the buffer is modified.
+Like `kill-buffer', but does nothing if buffer BUF is modified.
\(fn BUF)" nil nil)
@@ -37183,7 +37643,7 @@ 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.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -37205,7 +37665,7 @@ Optional argument EXIT-ACTION is either nil or a function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -37227,7 +37687,7 @@ Optional argument EXIT-ACTION is either nil or a function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -37236,10 +37696,19 @@ own View-like bindings.
(autoload 'view-mode "view" "\
Toggle View mode, a minor mode for viewing text but not editing it.
-If called interactively, enable View mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `View mode'
+mode. If the prefix argument is positive, enable the mode, and if it
+is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `view-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
When View mode is enabled, commands that do not change the buffer
contents are available as usual. Kill commands save text but
@@ -37354,7 +37823,7 @@ This function runs the normal hook `view-mode-hook'.
(autoload 'View-exit-and-edit "view" "\
Exit View mode and make the current buffer editable." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("View-" "view-")))
+(register-definition-prefixes "view" '("View-" "view-"))
;;;***
@@ -37369,7 +37838,7 @@ If Viper is enabled, turn it off. Otherwise, turn it on." t nil)
(autoload 'viper-mode "viper" "\
Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper" '("set-viper-state-in-major-mode" "this-major-mode-requires-vi-state" "viper-")))
+(register-definition-prefixes "viper" '("set-viper-state-in-major-mode" "this-major-mode-requires-vi-state" "viper-"))
;;;***
@@ -37377,14 +37846,14 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0))
;;; Generated autoloads from emulation/viper-cmd.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-cmd" '("viper-")))
+(register-definition-prefixes "viper-cmd" '("viper-"))
;;;***
;;;### (autoloads nil "viper-ex" "emulation/viper-ex.el" (0 0 0 0))
;;; Generated autoloads from emulation/viper-ex.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-ex" '("ex-" "viper-")))
+(register-definition-prefixes "viper-ex" '("ex-" "viper-"))
;;;***
@@ -37392,7 +37861,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-init.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-init" '("viper-")))
+(register-definition-prefixes "viper-init" '("viper-"))
;;;***
@@ -37400,7 +37869,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-keym.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-keym" '("ex-read-filename-map" "viper-")))
+(register-definition-prefixes "viper-keym" '("ex-read-filename-map" "viper-"))
;;;***
@@ -37408,7 +37877,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-macs.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-macs" '("ex-" "viper-")))
+(register-definition-prefixes "viper-macs" '("ex-" "viper-"))
;;;***
@@ -37416,7 +37885,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-mous.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-mous" '("viper-")))
+(register-definition-prefixes "viper-mous" '("viper-"))
;;;***
@@ -37424,35 +37893,35 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil)
;;;;;; 0 0))
;;; Generated autoloads from emulation/viper-util.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "viper-util" '("viper")))
+(register-definition-prefixes "viper-util" '("viper"))
;;;***
;;;### (autoloads nil "vt-control" "vt-control.el" (0 0 0 0))
;;; Generated autoloads from vt-control.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vt-control" '("vt-")))
+(register-definition-prefixes "vt-control" '("vt-"))
;;;***
;;;### (autoloads nil "vt100-led" "vt100-led.el" (0 0 0 0))
;;; Generated autoloads from vt100-led.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vt100-led" '("led-")))
+(register-definition-prefixes "vt100-led" '("led-"))
;;;***
;;;### (autoloads nil "w32-fns" "w32-fns.el" (0 0 0 0))
;;; Generated autoloads from w32-fns.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "w32-fns" '("w32-")))
+(register-definition-prefixes "w32-fns" '("w32-"))
;;;***
;;;### (autoloads nil "w32-vars" "w32-vars.el" (0 0 0 0))
;;; Generated autoloads from w32-vars.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "w32-vars" '("w32-")))
+(register-definition-prefixes "w32-vars" '("w32-"))
;;;***
@@ -37514,6 +37983,11 @@ See also `warning-series', `warning-prefix-function',
`warning-fill-prefix', and `warning-fill-column' for additional
programming features.
+This will also display buttons allowing the user to permanently
+disable automatic display of the warning or disable the warning
+entirely by setting `warning-suppress-types' or
+`warning-suppress-log-types' on their behalf.
+
\(fn TYPE MESSAGE &optional LEVEL BUFFER-NAME)" nil nil)
(autoload 'lwarn "warnings" "\
@@ -37546,13 +38020,12 @@ this is equivalent to `display-warning', using
\(fn MESSAGE &rest ARGS)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "warnings" '("display-warning-minimum-level" "log-warning-minimum-level" "warning-")))
+(register-definition-prefixes "warnings" '("warning-"))
;;;***
;;;### (autoloads nil "wdired" "wdired.el" (0 0 0 0))
;;; Generated autoloads from wdired.el
-(push (purecopy '(wdired 2 0)) package--builtin-versions)
(autoload 'wdired-change-to-wdired-mode "wdired" "\
Put a Dired buffer in Writable Dired (WDired) mode.
@@ -37564,7 +38037,7 @@ directories to reflect your edits.
See `wdired-mode'." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wdired" '("wdired-")))
+(register-definition-prefixes "wdired" '("wdired-"))
;;;***
@@ -37580,7 +38053,7 @@ hotlist.
Please submit bug reports and other feedback to the author, Neil W. Van Dyke
<nwv@acm.org>." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "webjump" '("webjump-")))
+(register-definition-prefixes "webjump" '("webjump-"))
;;;***
@@ -37605,10 +38078,19 @@ or call the function `which-function-mode'.")
(autoload 'which-function-mode "which-func" "\
Toggle mode line display of current function (Which Function mode).
-If called interactively, enable Which-Function mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Which-Function mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'which-function-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Which Function mode is a global minor mode. When enabled, the
current function name is continuously displayed in the mode line,
@@ -37616,7 +38098,7 @@ in certain major modes.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "which-func" '("which-func")))
+(register-definition-prefixes "which-func" '("which-func"))
;;;***
@@ -37627,10 +38109,19 @@ in certain major modes.
(autoload 'whitespace-mode "whitespace" "\
Toggle whitespace visualization (Whitespace mode).
-If called interactively, enable Whitespace mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Whitespace
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `whitespace-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'.
@@ -37640,10 +38131,19 @@ See also `whitespace-style', `whitespace-newline' and
(autoload 'whitespace-newline-mode "whitespace" "\
Toggle newline visualization (Whitespace Newline mode).
-If called interactively, enable Whitespace-Newline mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Whitespace-Newline mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `whitespace-newline-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Use `whitespace-newline-mode' only for NEWLINE visualization
exclusively. For other visualizations, including NEWLINE
@@ -37667,10 +38167,19 @@ or call the function `global-whitespace-mode'.")
(autoload 'global-whitespace-mode "whitespace" "\
Toggle whitespace visualization globally (Global Whitespace mode).
-If called interactively, enable Global Whitespace mode if ARG is
-positive, and disable it if ARG is zero or negative. If called from
-Lisp, also enable the mode if ARG is omitted or nil, and toggle it if
-ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+Whitespace mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-whitespace-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
See also `whitespace-style', `whitespace-newline' and
`whitespace-display-mappings'.
@@ -37690,10 +38199,19 @@ or call the function `global-whitespace-newline-mode'.")
(autoload 'global-whitespace-newline-mode "whitespace" "\
Toggle global newline visualization (Global Whitespace Newline mode).
-If called interactively, enable Global Whitespace-Newline mode if ARG
-is positive, and disable it if ARG is zero or negative. If called
-from Lisp, also enable the mode if ARG is omitted or nil, and toggle
-it if ARG is `toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Global
+Whitespace-Newline mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'global-whitespace-newline-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Use `global-whitespace-newline-mode' only for NEWLINE
visualization exclusively. For other visualizations, including
@@ -37989,7 +38507,7 @@ cleaning up these problems.
\(fn START END &optional FORCE REPORT-IF-BOGUS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "whitespace" '("whitespace-")))
+(register-definition-prefixes "whitespace" '("whitespace-"))
;;;***
@@ -38014,14 +38532,23 @@ Show widget browser for WIDGET in other window.
(autoload 'widget-minor-mode "wid-browse" "\
Minor mode for traversing widgets.
-If called interactively, enable Widget minor mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Widget
+minor mode' mode. If the prefix argument is positive, enable the
+mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `widget-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wid-browse" '("widget-")))
+(register-definition-prefixes "wid-browse" '("widget-"))
;;;***
@@ -38063,7 +38590,7 @@ Note that such modes will need to require wid-edit.")
(autoload 'widget-setup "wid-edit" "\
Setup current buffer so editing string widgets works." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "wid-edit" '("widget-")))
+(register-definition-prefixes "wid-edit" '("widget-"))
;;;***
@@ -38118,31 +38645,37 @@ unless `windmove-create-window' is non-nil and a new window is created.
Set up keybindings for `windmove'.
Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift'.
\(fn &optional MODIFIERS)" t nil)
(autoload 'windmove-display-left "windmove" "\
Display the next buffer in window to the left of the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'.
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'.
\(fn &optional ARG)" t nil)
(autoload 'windmove-display-up "windmove" "\
Display the next buffer in window above the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'.
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'.
\(fn &optional ARG)" t nil)
(autoload 'windmove-display-right "windmove" "\
Display the next buffer in window to the right of the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'.
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'.
\(fn &optional ARG)" t nil)
(autoload 'windmove-display-down "windmove" "\
Display the next buffer in window below the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'.
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'.
\(fn &optional ARG)" t nil)
@@ -38151,6 +38684,11 @@ Display the next buffer in the same window.
\(fn &optional ARG)" t nil)
+(autoload 'windmove-display-new-frame "windmove" "\
+Display the next buffer in a new frame.
+
+\(fn &optional ARG)" t nil)
+
(autoload 'windmove-display-new-tab "windmove" "\
Display the next buffer in a new tab.
@@ -38161,6 +38699,8 @@ Set up keybindings for directional buffer display.
Keys are bound to commands that display the next buffer in the specified
direction. Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift-meta'.
\(fn &optional MODIFIERS)" t nil)
@@ -38198,7 +38738,10 @@ Set up keybindings for directional window deletion.
Keys are bound to commands that delete windows in the specified
direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down},
where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
-a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'.
+a single modifier.
+If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings
+are directly bound to the arrow keys.
+Default value of PREFIX is `C-x' and MODIFIERS is `shift'.
\(fn &optional PREFIX MODIFIERS)" t nil)
@@ -38219,11 +38762,14 @@ Set up keybindings for directional window swap states.
Keys are bound to commands that swap the states of the selected window
with the window in the specified direction. Keybindings are of the form
MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers
-or a single modifier. Default value of MODIFIERS is `shift-super'.
+or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to the
+arrow keys.
+Default value of MODIFIERS is `shift-super'.
\(fn &optional MODIFIERS)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "windmove" '("windmove-")))
+(register-definition-prefixes "windmove" '("windmove-"))
;;;***
@@ -38243,10 +38789,19 @@ or call the function `winner-mode'.")
(autoload 'winner-mode "winner" "\
Toggle Winner mode on or off.
-If called interactively, enable Winner mode if ARG is positive, and
-disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the `Winner
+mode' mode. If the prefix argument is positive, enable the mode, and
+if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'winner-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Winner mode is a global minor mode that records the changes in
the window configuration (i.e. how the frames are partitioned
@@ -38257,13 +38812,12 @@ you can press `C-c <right>' (calling `winner-redo').
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "winner" '("winner-")))
+(register-definition-prefixes "winner" '("winner-"))
;;;***
;;;### (autoloads nil "woman" "woman.el" (0 0 0 0))
;;; Generated autoloads from woman.el
-(push (purecopy '(woman 0 551)) package--builtin-versions)
(defvar woman-locale nil "\
String specifying a manual page locale, or nil.
@@ -38306,21 +38860,21 @@ Default bookmark handler for Woman buffers.
\(fn BOOKMARK)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "woman" '("WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp" "woman")))
+(register-definition-prefixes "woman" '("WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp" "woman"))
;;;***
;;;### (autoloads nil "x-dnd" "x-dnd.el" (0 0 0 0))
;;; Generated autoloads from x-dnd.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "x-dnd" '("x-dnd-")))
+(register-definition-prefixes "x-dnd" '("x-dnd-"))
;;;***
;;;### (autoloads nil "xdg" "xdg.el" (0 0 0 0))
;;; Generated autoloads from xdg.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xdg" '("xdg-")))
+(register-definition-prefixes "xdg" '("xdg-"))
;;;***
@@ -38384,7 +38938,7 @@ All text between the <!-- ... --> markers will be removed.
\(fn BEG END)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xml" '("xml-")))
+(register-definition-prefixes "xml" '("xml-"))
;;;***
@@ -38404,12 +38958,13 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
\(fn &optional LIMIT)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xmltok" '("xmltok-")))
+(register-definition-prefixes "xmltok" '("xmltok-"))
;;;***
;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xref.el
+(push (purecopy '(xref 1 1 0)) package--builtin-versions)
(autoload 'xref-find-backend "xref" nil nil nil)
@@ -38495,21 +39050,21 @@ FILES must be a list of absolute file names.
\(fn REGEXP FILES)" nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xref" '("xref-")))
+(register-definition-prefixes "xref" '("xref-"))
;;;***
;;;### (autoloads nil "xscheme" "progmodes/xscheme.el" (0 0 0 0))
;;; Generated autoloads from progmodes/xscheme.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xscheme" '("default-xscheme-runlight" "exit-scheme-interaction-mode" "global-set-scheme-interaction-buffer" "local-" "reset-scheme" "run-scheme" "scheme-" "start-scheme" "verify-xscheme-buffer" "xscheme-")))
+(register-definition-prefixes "xscheme" '("default-xscheme-runlight" "exit-scheme-interaction-mode" "global-set-scheme-interaction-buffer" "local-" "reset-scheme" "run-scheme" "scheme-" "start-scheme" "verify-xscheme-buffer" "xscheme-"))
;;;***
;;;### (autoloads nil "xsd-regexp" "nxml/xsd-regexp.el" (0 0 0 0))
;;; Generated autoloads from nxml/xsd-regexp.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xsd-regexp" '("xsdre-")))
+(register-definition-prefixes "xsd-regexp" '("xsdre-"))
;;;***
@@ -38529,10 +39084,19 @@ or call the function `xterm-mouse-mode'.")
(autoload 'xterm-mouse-mode "xt-mouse" "\
Toggle XTerm mouse mode.
-If called interactively, enable Xterm-Mouse mode if ARG is positive,
-and disable it if ARG is zero or negative. If called from Lisp, also
-enable the mode if ARG is omitted or nil, and toggle it if ARG is
-`toggle'; disable the mode otherwise.
+This is a minor mode. If called interactively, toggle the
+`Xterm-Mouse mode' mode. If the prefix argument is positive, enable
+the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `(default-value 'xterm-mouse-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
Turn it on to use Emacs mouse commands, and off to use xterm mouse commands.
This works in terminal emulators compatible with xterm. It only
@@ -38543,7 +39107,7 @@ down the SHIFT key while pressing the mouse button.
\(fn &optional ARG)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-")))
+(register-definition-prefixes "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-"))
;;;***
@@ -38557,7 +39121,7 @@ Interactively, URL defaults to the string looking like a url around point.
\(fn URL &optional NEW-SESSION)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "xwidget" '("xwidget-")))
+(register-definition-prefixes "xwidget" '("xwidget-"))
;;;***
@@ -38572,14 +39136,14 @@ Yenc decode region between START and END using an internal decoder.
(autoload 'yenc-extract-filename "yenc" "\
Extract file name from an yenc header." nil nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "yenc" '("yenc-")))
+(register-definition-prefixes "yenc" '("yenc-"))
;;;***
;;;### (autoloads nil "zeroconf" "net/zeroconf.el" (0 0 0 0))
;;; Generated autoloads from net/zeroconf.el
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "zeroconf" '("zeroconf-")))
+(register-definition-prefixes "zeroconf" '("zeroconf-"))
;;;***
@@ -38589,7 +39153,7 @@ Extract file name from an yenc header." nil nil)
(autoload 'zone "zone" "\
Zone out, completely." t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "zone" '("zone-")))
+(register-definition-prefixes "zone" '("zone-"))
;;;***
@@ -38613,7 +39177,8 @@ Zone out, completely." t nil)
;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el" "cedet/semantic/debug.el"
;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el"
;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/edit.el"
-;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/html.el"
+;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el"
+;;;;;; "cedet/semantic/grm-wy-boot.el" "cedet/semantic/html.el"
;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el" "cedet/semantic/idle.el"
;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el" "cedet/semantic/lex.el"
;;;;;; "cedet/semantic/mru-bookmark.el" "cedet/semantic/scope.el"
@@ -38634,83 +39199,85 @@ Zone out, completely." t nil)
;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el"
;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el"
;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el"
-;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/eieio-compat.el" "emacs-lisp/eieio-custom.el"
-;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eldoc.el" "emacs-lisp/float-sup.el"
+;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-compat.el"
+;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el"
;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el"
;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el"
;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el"
-;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el"
-;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el"
-;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el"
-;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el"
-;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el"
-;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el"
-;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el"
-;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el"
-;;;;;; "erc/erc-track.el" "erc/erc-truncate.el" "erc/erc-xdcc.el"
-;;;;;; "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-tramp.el"
-;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "facemenu.el" "faces.el"
-;;;;;; "files.el" "font-core.el" "font-lock.el" "format.el" "frame.el"
-;;;;;; "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" "international/characters.el"
-;;;;;; "international/charscript.el" "international/cp51932.el"
-;;;;;; "international/eucjp-ms.el" "international/mule-cmds.el"
-;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el"
-;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el"
-;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el"
-;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el"
-;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el"
-;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el"
-;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el"
-;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el"
-;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el"
-;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el"
-;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el"
-;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el"
-;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el"
-;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el"
-;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el"
-;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el"
-;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/croatian.el"
-;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el"
-;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el"
-;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el"
-;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el"
-;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el"
-;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el"
-;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el"
-;;;;;; "leim/quail/rfc1345.el" "leim/quail/sami.el" "leim/quail/sgml-input.el"
-;;;;;; "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el"
-;;;;;; "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" "leim/quail/vntelex.el"
-;;;;;; "leim/quail/vnvni.el" "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el"
-;;;;;; "mail/rmailedit.el" "mail/rmailkwd.el" "mail/rmailmm.el"
-;;;;;; "mail/rmailmsc.el" "mail/rmailsort.el" "mail/rmailsum.el"
-;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "mh-e/mh-loaddefs.el"
-;;;;;; "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" "newcomment.el"
-;;;;;; "obarray.el" "org/ob-core.el" "org/ob-lob.el" "org/ob-matlab.el"
-;;;;;; "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" "org/ol-irc.el"
-;;;;;; "org/ol.el" "org/org-archive.el" "org/org-attach.el" "org/org-clock.el"
-;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-datetree.el"
-;;;;;; "org/org-duration.el" "org/org-element.el" "org/org-feed.el"
-;;;;;; "org/org-footnote.el" "org/org-goto.el" "org/org-id.el" "org/org-indent.el"
-;;;;;; "org/org-install.el" "org/org-keys.el" "org/org-lint.el"
-;;;;;; "org/org-list.el" "org/org-macs.el" "org/org-mobile.el" "org/org-num.el"
-;;;;;; "org/org-plot.el" "org/org-refile.el" "org/org-table.el"
-;;;;;; "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" "org/ox-html.el"
-;;;;;; "org/ox-icalendar.el" "org/ox-latex.el" "org/ox-md.el" "org/ox-odt.el"
-;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el"
-;;;;;; "progmodes/elisp-mode.el" "progmodes/prog-mode.el" "ps-mule.el"
-;;;;;; "register.el" "replace.el" "rfn-eshadow.el" "select.el" "simple.el"
-;;;;;; "startup.el" "subdirs.el" "subr.el" "tab-bar.el" "textmodes/fill.el"
+;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el"
+;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el"
+;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el"
+;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el"
+;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el"
+;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el"
+;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el"
+;;;;;; "erc/erc-stamp.el" "erc/erc-status-sidebar.el" "erc/erc-track.el"
+;;;;;; "erc/erc-truncate.el" "erc/erc-xdcc.el" "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-tramp.el" "eshell/em-unix.el"
+;;;;;; "eshell/em-xtra.el" "faces.el" "files.el" "font-core.el"
+;;;;;; "font-lock.el" "format.el" "frame.el" "help.el" "hfy-cmap.el"
+;;;;;; "ibuf-ext.el" "indent.el" "international/characters.el" "international/charscript.el"
+;;;;;; "international/cp51932.el" "international/eucjp-ms.el" "international/iso-transl.el"
+;;;;;; "international/mule-cmds.el" "international/mule-conf.el"
+;;;;;; "international/mule.el" "isearch.el" "jit-lock.el" "jka-cmpr-hook.el"
+;;;;;; "language/burmese.el" "language/cham.el" "language/chinese.el"
+;;;;;; "language/cyrillic.el" "language/czech.el" "language/english.el"
+;;;;;; "language/ethiopic.el" "language/european.el" "language/georgian.el"
+;;;;;; "language/greek.el" "language/hebrew.el" "language/indian.el"
+;;;;;; "language/japanese.el" "language/khmer.el" "language/korean.el"
+;;;;;; "language/lao.el" "language/misc-lang.el" "language/romanian.el"
+;;;;;; "language/sinhala.el" "language/slovak.el" "language/tai-viet.el"
+;;;;;; "language/thai.el" "language/tibetan.el" "language/utf-8-lang.el"
+;;;;;; "language/vietnamese.el" "ldefs-boot.el" "leim/ja-dic/ja-dic.el"
+;;;;;; "leim/leim-list.el" "leim/quail/4Corner.el" "leim/quail/ARRAY30.el"
+;;;;;; "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el"
+;;;;;; "leim/quail/ECDICT.el" "leim/quail/ETZY.el" "leim/quail/PY-b5.el"
+;;;;;; "leim/quail/PY.el" "leim/quail/Punct-b5.el" "leim/quail/Punct.el"
+;;;;;; "leim/quail/QJ-b5.el" "leim/quail/QJ.el" "leim/quail/SW.el"
+;;;;;; "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el"
+;;;;;; "leim/quail/arabic.el" "leim/quail/cham.el" "leim/quail/compose.el"
+;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el"
+;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el"
+;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el"
+;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el"
+;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el"
+;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el"
+;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el"
+;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el"
+;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el"
+;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el"
+;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el"
+;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el"
+;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el"
+;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el"
+;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el"
+;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-lob.el"
+;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el"
+;;;;;; "org/ol-irc.el" "org/ol.el" "org/org-archive.el" "org/org-attach.el"
+;;;;;; "org/org-clock.el" "org/org-colview.el" "org/org-compat.el"
+;;;;;; "org/org-datetree.el" "org/org-duration.el" "org/org-element.el"
+;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-goto.el"
+;;;;;; "org/org-id.el" "org/org-indent.el" "org/org-install.el"
+;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el"
+;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el"
+;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el"
+;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el"
+;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el"
+;;;;;; "org/ox-texinfo.el" "org/ox.el" "progmodes/elisp-mode.el"
+;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el"
+;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el"
+;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el"
;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el"
;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el"
;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el"
-;;;;;; "textmodes/reftex-sel.el" "textmodes/reftex-toc.el" "textmodes/text-mode.el"
-;;;;;; "uniquify.el" "vc/ediff-hook.el" "vc/vc-hooks.el" "version.el"
-;;;;;; "widget.el" "window.el") (0 0 0 0))
+;;;;;; "textmodes/reftex-sel.el" "textmodes/reftex-toc.el" "textmodes/texnfo-upd.el"
+;;;;;; "textmodes/text-mode.el" "uniquify.el" "vc/ediff-hook.el"
+;;;;;; "vc/vc-hooks.el" "version.el" "widget.el" "window.el") (0
+;;;;;; 0 0 0))
;;;***
diff --git a/lisp/leim/quail/arabic.el b/lisp/leim/quail/arabic.el
index 6b00c1e0526..e5bd62b9096 100644
--- a/lisp/leim/quail/arabic.el
+++ b/lisp/leim/quail/arabic.el
@@ -1,4 +1,4 @@
-;;; arabic.el --- Quail package for inputting Arabic -*- coding: utf-8;-*-
+;;; arabic.el --- Quail package for inputting Arabic -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el
new file mode 100644
index 00000000000..d12ae6cddf0
--- /dev/null
+++ b/lisp/leim/quail/cham.el
@@ -0,0 +1,116 @@
+;;; cham.el --- Quail package for inputting Cham characters -*- coding: utf-8; lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Eli Zaretskii <eliz@gnu.org>
+;; Keywords: i18n
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines the following Cham keyboards:
+;;
+;; - QWERTY-based Cham.
+
+;;; Code:
+
+(require 'quail)
+
+(quail-define-package
+ "cham" "Cham" "ꨌꩌ" t
+ "A QWERTY-based Cham input method."
+ nil t nil nil t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("a" ?ꨀ)
+ ("A" ?ꨄ)
+ ("i" ?ê¨)
+ ("u" ?ꨂ)
+ ("e" ?ꨃ)
+ ("o" ?ꨅ)
+ ("k" ?ꨆ)
+ ("K" ?ꨇ)
+ ("g" ?ꨈ)
+ ("G" ?ꨉ)
+ ("q" ?ꨊ)
+ ("Q" ?ꨋ)
+ ("c" ?ꨌ)
+ ("C" ?ê¨)
+ ("j" ?ꨎ)
+ ("J" ?ê¨)
+ ("z" ?ê¨)
+ ("Z" ?ꨑ)
+ ("zz" ?ꨒ)
+ ("t" ?ꨓ)
+ ("T" ?ꨔ)
+ ("d" ?ꨕ)
+ ("D" ?ꨖ)
+ ("n" ?ꨗ)
+ ("N" ?ꨘ)
+ ("p" ?ꨚ)
+ ("P" ?ꨛ)
+ ("f" ?ꨜ)
+ ("b" ?ê¨)
+ ("B" ?ꨞ)
+ ("m" ?ꨟ)
+ ("M" ?ꨠ)
+ ("mm" ?ꨡ)
+ ("y" ?ꨢ)
+ ("r" ?ꨣ)
+ ("l" ?ꨤ)
+ ("w" ?ꨥ)
+ ("v" ?ꨥ)
+ ("x" ?ꨦ)
+ ("s" ?ꨧ)
+ ("h" ?ꨨ)
+ ("kk" ?ê©€)
+ ("ww" ?ê©)
+ ("vv" ?ê©)
+ ("qq" ?ê©‚)
+ ("cc" ?ê©„)
+ ("tt" ?ê©…)
+ ("nn" ?ꩆ)
+ ("pp" ?ꩇ)
+ ("yy" ?ꩈ)
+ ("rr" ?ꩉ)
+ ("ll" ?ꩊ)
+ ("gg" ?ꩊ)
+ ("xx" ?ê©‹)
+ ("." ?ꩌ)
+ ("H" ?ê©)
+ ("0" ?ê©)
+ ("1" ?ê©‘)
+ ("2" ?ê©’)
+ ("3" ?ê©“)
+ ("4" ?ê©”)
+ ("5" ?ê©•)
+ ("6" ?ê©–)
+ ("7" ?ê©—)
+ ("8" ?꩘)
+ ("9" ?ê©™)
+ ("!" ?ꨩ)
+ ("#" ?ꨪ)
+ ("$" ?ꨫ)
+ ("^" ?ꨬ)
+ ("&" ?ꨮ)
+ ("`" ?꩜)
+ ("=" ?ꨱ)
+ ("-" ?ꩃ)
+ ("~" ?꩟)
+ )
+
+;;; cham.el ends here
diff --git a/lisp/leim/quail/compose.el b/lisp/leim/quail/compose.el
new file mode 100644
index 00000000000..264a9b479b3
--- /dev/null
+++ b/lisp/leim/quail/compose.el
@@ -0,0 +1,2952 @@
+;;; compose.el --- Quail package for Multi_key character composition -*-coding: utf-8; lexical-binding: t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Juri Linkov <juri@linkov.net>
+;; Keywords: multilingual, input method, i18n
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This input method supports the same key sequences as defined by the
+;; standard X Multi_key: https://en.wikipedia.org/wiki/Compose_key
+
+;; You can enable this input method transiently with `C-u C-x \ compose RET'.
+;; Then typing `C-x \' will enable this input method temporarily, and
+;; after typing a key sequence it will be disabled. So typing
+;; e.g. `C-x \ E =' will insert the Euro sign character, and disable
+;; this input method automatically afterwards.
+
+;;; Code:
+
+(require 'quail)
+
+(quail-define-package
+ "compose" "UTF-8" "+" t
+ "Compose-like input method with the same key sequences as X Multi_key.
+Examples:
+ E = -> € 1 2 -> ½ ^ 3 -> ³"
+ '(("\t" . quail-completion))
+ t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("''" ?´)
+ ("-^" ?¯)
+ ("^-" ?¯)
+ ("__" ?¯)
+ ("_^" ?¯)
+ (" (" ?˘)
+ ("( " ?˘)
+ ("\"\"" ?¨)
+ (" <" ?ˇ)
+ ("< " ?ˇ)
+ ("-- " ?­)
+ ("++" ?#)
+ ("' " ?\')
+ (" '" ?\')
+ ("AT" ?@)
+ ("((" ?\[)
+ ("//" ["\\\\"])
+ ("/<" ["\\\\"])
+ ("</" ["\\\\"])
+ ("))" ?\])
+ ("^ " ?^)
+ (" ^" ?^)
+ ("> " ?^)
+ (" >" ?^)
+ ("` " ?`)
+ (" `" ?`)
+ (", " ?¸)
+ (" ," ?¸)
+ (",," ?¸)
+ ("(-" ?\{)
+ ("-(" ?\{)
+ ("/^" ?|)
+ ("^/" ?|)
+ ("VL" ?|)
+ ("LV" ?|)
+ ("vl" ?|)
+ ("lv" ?|)
+ (")-" ?\})
+ ("-)" ?\})
+ ("~ " ?~)
+ (" ~" ?~)
+ ("- " ?~)
+ (" -" ?~)
+ (" " ? )
+ (" ." ? )
+ ("oc" ?©)
+ ("oC" ?©)
+ ("Oc" ?©)
+ ("OC" ?©)
+ ("Co" ?©)
+ ("CO" ?©)
+ ("or" ?®)
+ ("oR" ?®)
+ ("Or" ?®)
+ ("OR" ?®)
+ ("Ro" ?®)
+ ("RO" ?®)
+ (".>" ?›)
+ (".<" ?‹)
+ (".." ?…)
+ (".-" ?·)
+ (".^" ?·)
+ ("^." ?·)
+ (".=" ?•)
+ ("!^" ?¦)
+ ("!!" ?¡)
+ ("p!" ?¶)
+ ("P!" ?¶)
+ ("+-" ?±)
+ ("-+" ?±)
+ ("??" ?¿)
+ ("ss" ?ß)
+ ("SS" ?ẞ)
+ ("oe" ?Å“)
+ ("OE" ?Å’)
+ ("ae" ?æ)
+ ("AE" ?Æ)
+ ("ff" ?ff)
+ ("fi" ?ï¬)
+ ("fl" ?fl)
+ ("Fi" ?ffi)
+ ("Fl" ?ffl)
+ ("IJ" ?IJ)
+ ("Ij" ?IJ)
+ ("ij" ?ij)
+ ("oo" ?°)
+ ("*0" ?°)
+ ("0*" ?°)
+ ("<<" ?«)
+ (">>" ?»)
+ ("<'" ?‘)
+ ("'<" ?‘)
+ (">'" ?’)
+ ("'>" ?’)
+ (",'" ?‚)
+ ("'," ?‚)
+ ("<\"" ?“)
+ ("\"<" ?“)
+ (">\"" ?â€)
+ ("\">" ?â€)
+ (",\"" ?„)
+ ("\"," ?„)
+ ("%o" ?‰)
+ ("CE" ?â‚ )
+ ("C/" ?â‚¡)
+ ("/C" ?â‚¡)
+ ("Cr" ?â‚¢)
+ ("Fr" ?â‚£)
+ ("L=" ?₤)
+ ("=L" ?₤)
+ ("m/" ?â‚¥)
+ ("/m" ?â‚¥)
+ ("N=" ?₦)
+ ("=N" ?₦)
+ ("Pt" ?â‚§)
+ ("Rs" ?₨)
+ ("W=" ?â‚©)
+ ("=W" ?â‚©)
+ ("d=" ?â‚«)
+ ("=d" ?â‚«)
+ ("C=" ?€)
+ ("=C" ?€)
+ ("c=" ?€)
+ ("=c" ?€)
+ ("E=" ?€)
+ ("=E" ?€)
+ ("e=" ?€)
+ ("=e" ?€)
+ ("С=" ?€)
+ ("=С" ?€)
+ ("Е=" ?€)
+ ("=Е" ?€)
+ ("P=" ?₽)
+ ("p=" ?₽)
+ ("=P" ?₽)
+ ("=p" ?₽)
+ ("З=" ?₽)
+ ("з=" ?₽)
+ ("=З" ?₽)
+ ("=з" ?₽)
+ ("R=" ?₹)
+ ("=R" ?₹)
+ ("r=" ?₹)
+ ("=r" ?₹)
+ ("C|" ?¢)
+ ("|C" ?¢)
+ ("c|" ?¢)
+ ("|c" ?¢)
+ ("c/" ?¢)
+ ("/c" ?¢)
+ ("L-" ?£)
+ ("-L" ?£)
+ ("l-" ?£)
+ ("-l" ?£)
+ ("Y=" ?Â¥)
+ ("=Y" ?Â¥)
+ ("y=" ?Â¥)
+ ("=y" ?Â¥)
+ ("Y-" ?Â¥)
+ ("-Y" ?Â¥)
+ ("y-" ?Â¥)
+ ("-y" ?Â¥)
+ ("fs" ?Å¿)
+ ("fS" ?Å¿)
+ ("--." ?–)
+ ("---" ?—)
+ ("#q" ?♩)
+ ("#e" ?♪)
+ ("#E" ?♫)
+ ("#S" ?♬)
+ ("#b" ?â™­)
+ ("#f" ?â™®)
+ ("##" ?♯)
+ ("so" ?§)
+ ("os" ?§)
+ ("SO" ?§)
+ ("OS" ?§)
+ ("s!" ?§)
+ ("S!" ?§)
+ ("па" ?§)
+ ("ox" ?¤)
+ ("xo" ?¤)
+ ("oX" ?¤)
+ ("Xo" ?¤)
+ ("OX" ?¤)
+ ("XO" ?¤)
+ ("Ox" ?¤)
+ ("xO" ?¤)
+ ("PP" ?¶)
+ ("No" ?â„–)
+ ("NO" ?â„–)
+ ("Ðо" ?â„–)
+ ("ÐО" ?â„–)
+ ("?!" ?⸘)
+ ("!?" ?‽)
+ ("CCCP" ?☭)
+ ("OA" ?â’¶)
+ ("<3" ?♥)
+ (":)" ?☺)
+ (":(" ?☹)
+ ("\\o/" ?🙌)
+ ("poo" ?💩)
+ ("FU" ?🖕)
+ ("LLAP" ?🖖)
+ ("ᄀᄀ" ?á„)
+ ("ᄃᄃ" ?ᄄ)
+ ("ᄇᄇ" ?ᄈ)
+ ("ᄉᄉ" ?ᄊ)
+ ("ᄌᄌ" ?á„)
+ ("á„‚á„€" ?á„“)
+ ("á„‚á„‚" ?á„”)
+ ("ᄂᄃ" ?ᄕ)
+ ("ᄂᄇ" ?ᄖ)
+ ("ᄃᄀ" ?ᄗ)
+ ("ᄅᄂ" ?ᄘ)
+ ("á„…á„…" ?á„™)
+ ("ᄅᄒ" ?ᄚ)
+ ("á„…á„‹" ?á„›)
+ ("ᄆᄇ" ?ᄜ)
+ ("ᄆᄋ" ?á„)
+ ("ᄇᄀ" ?ᄞ)
+ ("ᄇᄂ" ?ᄟ)
+ ("ᄇᄃ" ?ᄠ)
+ ("ᄇᄉ" ?ᄡ)
+ ("ᄇᄌ" ?ᄧ)
+ ("ᄇᄎ" ?ᄨ)
+ ("ᄇá„" ?á„©)
+ ("ᄇᄑ" ?ᄪ)
+ ("ᄇᄋ" ?ᄫ)
+ ("ᄉᄀ" ?ᄭ)
+ ("ᄉᄂ" ?ᄮ)
+ ("ᄉᄃ" ?ᄯ)
+ ("ᄉᄅ" ?ᄰ)
+ ("ᄉᄆ" ?ᄱ)
+ ("ᄉᄇ" ?ᄲ)
+ ("ᄉᄋ" ?ᄵ)
+ ("ᄉᄌ" ?ᄶ)
+ ("ᄉᄎ" ?ᄷ)
+ ("ᄉá„" ?ᄸ)
+ ("ᄉá„" ?ᄹ)
+ ("ᄉᄑ" ?ᄺ)
+ ("ᄉᄒ" ?ᄻ)
+ ("ᄼᄼ" ?ᄽ)
+ ("ᄾᄾ" ?ᄿ)
+ ("á„‹á„€" ?á…)
+ ("ᄋᄃ" ?ᅂ)
+ ("ᄋᄆ" ?ᅃ)
+ ("ᄋᄇ" ?ᅄ)
+ ("ᄋᄉ" ?ᅅ)
+ ("á„‹á…€" ?á…†)
+ ("á„‹á„‹" ?á…‡)
+ ("ᄋᄌ" ?ᅈ)
+ ("ᄋᄎ" ?ᅉ)
+ ("á„‹á„" ?á…Š)
+ ("á„‹á„‘" ?á…‹)
+ ("ᄌᄋ" ?á…)
+ ("á…Žá…Ž" ?á…)
+ ("á…á…" ?á…‘)
+ ("ᄎá„" ?á…’)
+ ("ᄎᄒ" ?ᅓ)
+ ("ᄑᄇ" ?ᅖ)
+ ("á„‘á„‹" ?á…—)
+ ("á„’á„’" ?á…˜)
+ ("á…¡á…µ" ?á…¢)
+ ("ᅣᅵ" ?ᅤ)
+ ("ᅥᅵ" ?ᅦ)
+ ("á…§á…µ" ?á…¨)
+ ("á…©á…¡" ?á…ª)
+ ("á…©á…µ" ?á…¬)
+ ("ᅮᅥ" ?ᅯ)
+ ("ᅮᅵ" ?ᅱ)
+ ("ᅳᅵ" ?ᅴ)
+ ("á…¡á…©" ?á…¶)
+ ("á…¡á…®" ?á…·)
+ ("ᅣᅩ" ?ᅸ)
+ ("ᅣᅭ" ?ᅹ)
+ ("ᅥᅩ" ?ᅺ)
+ ("ᅥᅮ" ?ᅻ)
+ ("ᅥᅳ" ?ᅼ)
+ ("á…§á…©" ?á…½)
+ ("á…§á…®" ?á…¾)
+ ("á…©á…¥" ?á…¿)
+ ("ᅩᅦ" ?ᆀ)
+ ("á…©á…¨" ?á†)
+ ("ᅩᅩ" ?ᆂ)
+ ("ᅩᅮ" ?ᆃ)
+ ("ᅭᅣ" ?ᆄ)
+ ("ᅭᅤ" ?ᆅ)
+ ("ᅭᅧ" ?ᆆ)
+ ("ᅭᅩ" ?ᆇ)
+ ("ᅭᅵ" ?ᆈ)
+ ("ᅮᅡ" ?ᆉ)
+ ("ᅮᅢ" ?ᆊ)
+ ("ᅮᅨ" ?ᆌ)
+ ("ᅮᅮ" ?á†)
+ ("ᅲᅡ" ?ᆎ)
+ ("ᅲᅥ" ?á†)
+ ("ᅲᅦ" ?á†)
+ ("ᅲᅧ" ?ᆑ)
+ ("ᅲᅨ" ?ᆒ)
+ ("ᅲᅮ" ?ᆓ)
+ ("ᅲᅵ" ?ᆔ)
+ ("ᅳᅮ" ?ᆕ)
+ ("ᅳᅳ" ?ᆖ)
+ ("ᅴᅮ" ?ᆗ)
+ ("ᅵᅡ" ?ᆘ)
+ ("ᅵᅣ" ?ᆙ)
+ ("ᅵᅩ" ?ᆚ)
+ ("ᅵᅮ" ?ᆛ)
+ ("ᅵᅳ" ?ᆜ)
+ ("ᅵᆞ" ?á†)
+ ("ᆞᅥ" ?ᆟ)
+ ("ᆞᅮ" ?ᆠ)
+ ("ᆞᅵ" ?ᆡ)
+ ("ᆞᆞ" ?ᆢ)
+ ("ᆨᆨ" ?ᆩ)
+ ("ᆨᆺ" ?ᆪ)
+ ("ᆫᆽ" ?ᆬ)
+ ("ᆫᇂ" ?ᆭ)
+ ("ᆯᆨ" ?ᆰ)
+ ("ᆯᆷ" ?ᆱ)
+ ("ᆯᆸ" ?ᆲ)
+ ("ᆯᆺ" ?ᆳ)
+ ("ᆯᇀ" ?ᆴ)
+ ("ᆯá‡" ?ᆵ)
+ ("ᆯᇂ" ?ᆶ)
+ ("ᆸᆺ" ?ᆹ)
+ ("ᆺᆺ" ?ᆻ)
+ ("ᆨᆯ" ?ᇃ)
+ ("ᆫᆨ" ?ᇅ)
+ ("ᆫᆮ" ?ᇆ)
+ ("ᆫᆺ" ?ᇇ)
+ ("ᆫᇫ" ?ᇈ)
+ ("ᆫᇀ" ?ᇉ)
+ ("ᆮᆨ" ?ᇊ)
+ ("ᆮᆯ" ?ᇋ)
+ ("ᆯᆫ" ?á‡)
+ ("ᆯᆮ" ?ᇎ)
+ ("ᆯᆯ" ?á‡)
+ ("ᆯᇫ" ?ᇗ)
+ ("ᆯᆿ" ?ᇘ)
+ ("ᆯᇹ" ?ᇙ)
+ ("ᆷᆨ" ?ᇚ)
+ ("ᆷᆯ" ?ᇛ)
+ ("ᆷᆸ" ?ᇜ)
+ ("ᆷᆺ" ?á‡)
+ ("ᆷᇫ" ?ᇟ)
+ ("ᆷᆾ" ?ᇠ)
+ ("ᆷᇂ" ?ᇡ)
+ ("ᆷᆼ" ?ᇢ)
+ ("ᆸᆯ" ?ᇣ)
+ ("ᆸá‡" ?ᇤ)
+ ("ᆸᇂ" ?ᇥ)
+ ("ᆸᆼ" ?ᇦ)
+ ("ᆺᆨ" ?ᇧ)
+ ("ᆺᆮ" ?ᇨ)
+ ("ᆺᆯ" ?ᇩ)
+ ("ᆺᆸ" ?ᇪ)
+ ("ᆼᆨ" ?ᇬ)
+ ("ᆼᆼ" ?ᇮ)
+ ("ᆼᆿ" ?ᇯ)
+ ("ᇰᆺ" ?ᇱ)
+ ("ᇰᇫ" ?ᇲ)
+ ("á‡á†¸" ?ᇳ)
+ ("á‡á†¼" ?ᇴ)
+ ("ᇂᆫ" ?ᇵ)
+ ("ᇂᆯ" ?ᇶ)
+ ("ᇂᆷ" ?ᇷ)
+ ("ᇂᆸ" ?ᇸ)
+ ("á„¡á„€" ?á„¢)
+ ("ᄡᄃ" ?ᄣ)
+ ("ᄡᄇ" ?ᄤ)
+ ("ᄡᄉ" ?ᄥ)
+ ("ᄡᄌ" ?ᄦ)
+ ("ᄈᄋ" ?ᄬ)
+ ("ᄲᄀ" ?ᄳ)
+ ("ᄊᄉ" ?ᄴ)
+ ("ᅪᅵ" ?ᅫ)
+ ("ᅯᅵ" ?ᅰ)
+ ("ᅯᅳ" ?ᆋ)
+ ("ᆪᆨ" ?ᇄ)
+ ("ᆰᆺ" ?ᇌ)
+ ("ᇎᇂ" ?á‡)
+ ("ᆱᆨ" ?ᇑ)
+ ("ᆱᆺ" ?ᇒ)
+ ("ᆲᆺ" ?ᇓ)
+ ("ᆲᇂ" ?ᇔ)
+ ("ᆲᆼ" ?ᇕ)
+ ("ᆳᆺ" ?ᇖ)
+ ("á‡á†º" ?ᇞ)
+ ("ᇬᆨ" ?ᇭ)
+ ("ᄇᄭ" ?ᄢ)
+ ("ᄇᄯ" ?ᄣ)
+ ("ᄇᄲ" ?ᄤ)
+ ("ᄇᄊ" ?ᄥ)
+ ("ᄇᄶ" ?ᄦ)
+ ("ᄇᄫ" ?ᄬ)
+ ("ᄉᄞ" ?ᄳ)
+ ("ᄉᄊ" ?ᄴ)
+ ("á…©á…¢" ?á…«)
+ ("ᅮᅦ" ?ᅰ)
+ ("ᅮᅼ" ?ᆋ)
+ ("ᆨᇧ" ?ᇄ)
+ ("ᆯᆪ" ?ᇌ)
+ ("ᆯᇚ" ?ᇑ)
+ ("ᆯá‡" ?ᇒ)
+ ("ᆯᆹ" ?ᇓ)
+ ("ᆯᇥ" ?ᇔ)
+ ("ᆯᇦ" ?ᇕ)
+ ("ᆯᆻ" ?ᇖ)
+ ("ᆷᆻ" ?ᇞ)
+ ("ᆼᆩ" ?ᇭ)
+ (",-" ?¬)
+ ("-," ?¬)
+ ("^_a" ?ª)
+ ("^_a" ?ª)
+ ("^2" ?²)
+ ("2^" ?²)
+ ("^3" ?³)
+ ("3^" ?³)
+ ("mu" ?µ)
+ ("/u" ?µ)
+ ("u/" ?µ)
+ ("^1" ?¹)
+ ("1^" ?¹)
+ ("^_o" ?º)
+ ("^_o" ?º)
+ ("14" ?¼)
+ ("12" ?½)
+ ("34" ?¾)
+ ("`A" ?À)
+ ("A`" ?À)
+ ("´A" ?Ã)
+ ("A´" ?Ã)
+ ("'A" ?Ã)
+ ("A'" ?Ã)
+ ("^A" ?Â)
+ ("A^" ?Â)
+ (">A" ?Â)
+ ("A>" ?Â)
+ ("~A" ?Ã)
+ ("A~" ?Ã)
+ ("\"A" ?Ä)
+ ("A\"" ?Ä)
+ ("¨A" ?Ä)
+ ("A¨" ?Ä)
+ ("oA" ?Ã…)
+ ("*A" ?Ã…)
+ ("A*" ?Ã…)
+ ("AA" ?Ã…)
+ (",C" ?Ç)
+ ("C," ?Ç)
+ ("¸C" ?Ç)
+ ("`E" ?È)
+ ("E`" ?È)
+ ("´E" ?É)
+ ("E´" ?É)
+ ("'E" ?É)
+ ("E'" ?É)
+ ("^E" ?Ê)
+ ("E^" ?Ê)
+ (">E" ?Ê)
+ ("E>" ?Ê)
+ ("\"E" ?Ë)
+ ("E\"" ?Ë)
+ ("¨E" ?Ë)
+ ("E¨" ?Ë)
+ ("`I" ?Ì)
+ ("I`" ?Ì)
+ ("´I" ?Ã)
+ ("I´" ?Ã)
+ ("'I" ?Ã)
+ ("I'" ?Ã)
+ ("^I" ?ÃŽ)
+ ("I^" ?ÃŽ)
+ (">I" ?ÃŽ)
+ ("I>" ?ÃŽ)
+ ("\"I" ?Ã)
+ ("I\"" ?Ã)
+ ("¨I" ?Ã)
+ ("I¨" ?Ã)
+ ("'J" ["JÌ"])
+ ("J'" ["JÌ"])
+ ("´J" ["JÌ"])
+ ("J´" ["JÌ"])
+ ("DH" ?Ã)
+ ("~N" ?Ñ)
+ ("N~" ?Ñ)
+ ("`O" ?Ã’)
+ ("O`" ?Ã’)
+ ("´O" ?Ó)
+ ("O´" ?Ó)
+ ("'O" ?Ó)
+ ("O'" ?Ó)
+ ("^O" ?Ô)
+ ("O^" ?Ô)
+ (">O" ?Ô)
+ ("O>" ?Ô)
+ ("~O" ?Õ)
+ ("O~" ?Õ)
+ ("\"O" ?Ö)
+ ("O\"" ?Ö)
+ ("¨O" ?Ö)
+ ("O¨" ?Ö)
+ ("xx" ?×)
+ ("/O" ?Ø)
+ ("O/" ?Ø)
+ ("`U" ?Ù)
+ ("U`" ?Ù)
+ ("´U" ?Ú)
+ ("U´" ?Ú)
+ ("'U" ?Ú)
+ ("U'" ?Ú)
+ ("^U" ?Û)
+ ("U^" ?Û)
+ (">U" ?Û)
+ ("U>" ?Û)
+ ("\"U" ?Ü)
+ ("U\"" ?Ü)
+ ("¨U" ?Ü)
+ ("U¨" ?Ü)
+ ("´Y" ?Ã)
+ ("Y´" ?Ã)
+ ("'Y" ?Ã)
+ ("Y'" ?Ã)
+ ("TH" ?Þ)
+ ("`a" ?à)
+ ("a`" ?à)
+ ("´a" ?á)
+ ("a´" ?á)
+ ("'a" ?á)
+ ("a'" ?á)
+ ("^a" ?â)
+ ("a^" ?â)
+ (">a" ?â)
+ ("a>" ?â)
+ ("~a" ?ã)
+ ("a~" ?ã)
+ ("\"a" ?ä)
+ ("a\"" ?ä)
+ ("¨a" ?ä)
+ ("a¨" ?ä)
+ ("oa" ?Ã¥)
+ ("*a" ?Ã¥)
+ ("a*" ?Ã¥)
+ ("aa" ?Ã¥)
+ (",c" ?ç)
+ ("c," ?ç)
+ ("¸c" ?ç)
+ ("`e" ?è)
+ ("e`" ?è)
+ ("´e" ?é)
+ ("e´" ?é)
+ ("'e" ?é)
+ ("e'" ?é)
+ ("^e" ?ê)
+ ("e^" ?ê)
+ (">e" ?ê)
+ ("e>" ?ê)
+ ("\"e" ?ë)
+ ("e\"" ?ë)
+ ("¨e" ?ë)
+ ("e¨" ?ë)
+ ("`i" ?ì)
+ ("i`" ?ì)
+ ("´i" ?í)
+ ("i´" ?í)
+ ("'i" ?í)
+ ("i'" ?í)
+ ("^i" ?î)
+ ("i^" ?î)
+ (">i" ?î)
+ ("i>" ?î)
+ ("\"i" ?ï)
+ ("i\"" ?ï)
+ ("¨i" ?ï)
+ ("i¨" ?ï)
+ ("'j" ["jÌ"])
+ ("j'" ["jÌ"])
+ ("´j" ["jÌ"])
+ ("j´" ["jÌ"])
+ ("dh" ?ð)
+ ("~n" ?ñ)
+ ("n~" ?ñ)
+ ("`o" ?ò)
+ ("o`" ?ò)
+ ("´o" ?ó)
+ ("o´" ?ó)
+ ("'o" ?ó)
+ ("o'" ?ó)
+ ("^o" ?ô)
+ ("o^" ?ô)
+ (">o" ?ô)
+ ("o>" ?ô)
+ ("~o" ?õ)
+ ("o~" ?õ)
+ ("o¨" ?ö)
+ ("¨o" ?ö)
+ ("\"o" ?ö)
+ ("o\"" ?ö)
+ (":-" ?÷)
+ ("-:" ?÷)
+ ("/o" ?ø)
+ ("o/" ?ø)
+ ("`u" ?ù)
+ ("u`" ?ù)
+ ("´u" ?ú)
+ ("u´" ?ú)
+ ("'u" ?ú)
+ ("u'" ?ú)
+ ("^u" ?û)
+ ("u^" ?û)
+ (">u" ?û)
+ ("u>" ?û)
+ ("\"u" ?ü)
+ ("u\"" ?ü)
+ ("¨u" ?ü)
+ ("u¨" ?ü)
+ ("´y" ?ý)
+ ("y´" ?ý)
+ ("'y" ?ý)
+ ("y'" ?ý)
+ ("th" ?þ)
+ ("\"y" ?ÿ)
+ ("y\"" ?ÿ)
+ ("¨y" ?ÿ)
+ ("y¨" ?ÿ)
+ ("¯A" ?Ā)
+ ("_A" ?Ä€)
+ ("A_" ?Ä€)
+ ("-A" ?Ä€)
+ ("A-" ?Ä€)
+ ("¯a" ?Ä)
+ ("_a" ?Ä)
+ ("a_" ?Ä)
+ ("-a" ?Ä)
+ ("a-" ?Ä)
+ ("UA" ?Ä‚)
+ ("uA" ?Ä‚)
+ ("bA" ?Ä‚)
+ ("A(" ?Ä‚)
+ ("Ua" ?ă)
+ ("ua" ?ă)
+ ("ba" ?ă)
+ ("a(" ?ă)
+ (";A" ?Ä„)
+ ("A;" ?Ä„)
+ (",A" ?Ä„)
+ ("A," ?Ä„)
+ (";a" ?Ä…)
+ ("a;" ?Ä…)
+ (",a" ?Ä…)
+ ("a," ?Ä…)
+ ("´C" ?Ć)
+ ("'C" ?Ć)
+ ("C'" ?Ć)
+ ("´c" ?ć)
+ ("'c" ?ć)
+ ("c'" ?ć)
+ ("^C" ?Ĉ)
+ ("^c" ?ĉ)
+ (".C" ?ÄŠ)
+ ("C." ?ÄŠ)
+ (".c" ?Ä‹)
+ ("c." ?Ä‹)
+ ("cC" ?Č)
+ ("<C" ?Č)
+ ("C<" ?Č)
+ ("cc" ?Ä)
+ ("<c" ?Ä)
+ ("c<" ?Ä)
+ ("cD" ?ÄŽ)
+ ("<D" ?ÄŽ)
+ ("D<" ?ÄŽ)
+ ("cd" ?Ä)
+ ("<d" ?Ä)
+ ("d<" ?Ä)
+ ("-D" ?Ä)
+ ("D-" ?Ä)
+ ("/D" ?Ä)
+ ("-d" ?Ä‘)
+ ("d-" ?Ä‘)
+ ("/d" ?Ä‘)
+ ("¯E" ?Ē)
+ ("_E" ?Ä’)
+ ("E_" ?Ä’)
+ ("-E" ?Ä’)
+ ("E-" ?Ä’)
+ ("¯e" ?ē)
+ ("_e" ?Ä“)
+ ("e_" ?Ä“)
+ ("-e" ?Ä“)
+ ("e-" ?Ä“)
+ ("UE" ?Ä”)
+ ("bE" ?Ä”)
+ ("Ue" ?Ä•)
+ ("be" ?Ä•)
+ (".E" ?Ä–)
+ ("E." ?Ä–)
+ (".e" ?Ä—)
+ ("e." ?Ä—)
+ (";E" ?Ę)
+ ("E;" ?Ę)
+ (",E" ?Ę)
+ ("E," ?Ę)
+ (";e" ?Ä™)
+ ("e;" ?Ä™)
+ (",e" ?Ä™)
+ ("e," ?Ä™)
+ ("cE" ?Äš)
+ ("<E" ?Äš)
+ ("E<" ?Äš)
+ ("ce" ?Ä›)
+ ("<e" ?Ä›)
+ ("e<" ?Ä›)
+ ("^G" ?Ĝ)
+ ("^g" ?Ä)
+ ("UG" ?Äž)
+ ("GU" ?Äž)
+ ("bG" ?Äž)
+ ("˘G" ?Ğ)
+ ("G˘" ?Ğ)
+ ("G(" ?Äž)
+ ("Ug" ?ÄŸ)
+ ("gU" ?ÄŸ)
+ ("bg" ?ÄŸ)
+ ("˘g" ?ğ)
+ ("g˘" ?ğ)
+ ("g(" ?ÄŸ)
+ (".G" ?Ä )
+ ("G." ?Ä )
+ (".g" ?Ä¡)
+ ("g." ?Ä¡)
+ (",G" ?Ä¢)
+ ("G," ?Ä¢)
+ ("¸G" ?Ģ)
+ (",g" ?Ä£)
+ ("g," ?Ä£)
+ ("¸g" ?ģ)
+ ("^H" ?Ĥ)
+ ("^h" ?Ä¥)
+ ("/H" ?Ħ)
+ ("/h" ?ħ)
+ ("~I" ?Ĩ)
+ ("I~" ?Ĩ)
+ ("~i" ?Ä©)
+ ("i~" ?Ä©)
+ ("¯I" ?Ī)
+ ("_I" ?Ī)
+ ("I_" ?Ī)
+ ("-I" ?Ī)
+ ("I-" ?Ī)
+ ("¯i" ?ī)
+ ("_i" ?Ä«)
+ ("i_" ?Ä«)
+ ("-i" ?Ä«)
+ ("i-" ?Ä«)
+ ("UI" ?Ĭ)
+ ("bI" ?Ĭ)
+ ("Ui" ?Ä­)
+ ("bi" ?Ä­)
+ (";I" ?Ä®)
+ ("I;" ?Ä®)
+ (",I" ?Ä®)
+ ("I," ?Ä®)
+ (";i" ?į)
+ ("i;" ?į)
+ (",i" ?į)
+ ("i," ?į)
+ (".I" ?İ)
+ ("I." ?İ)
+ ("i." ?ı)
+ (".i" ?ı)
+ ("^J" ?Ä´)
+ ("^j" ?ĵ)
+ (",K" ?Ķ)
+ ("K," ?Ķ)
+ ("¸K" ?Ķ)
+ (",k" ?Ä·)
+ ("k," ?Ä·)
+ ("¸k" ?ķ)
+ ("kk" ?ĸ)
+ ("´L" ?Ĺ)
+ ("'L" ?Ĺ)
+ ("L'" ?Ĺ)
+ ("´l" ?ĺ)
+ ("'l" ?ĺ)
+ ("l'" ?ĺ)
+ (",L" ?Ä»)
+ ("L," ?Ä»)
+ ("¸L" ?Ļ)
+ (",l" ?ļ)
+ ("l," ?ļ)
+ ("¸l" ?ļ)
+ ("cL" ?Ľ)
+ ("<L" ?Ľ)
+ ("L<" ?Ľ)
+ ("cl" ?ľ)
+ ("<l" ?ľ)
+ ("l<" ?ľ)
+ ("/L" ?Å)
+ ("L/" ?Å)
+ ("/l" ?Å‚)
+ ("l/" ?Å‚)
+ ("´N" ?Ń)
+ ("'N" ?Ń)
+ ("N'" ?Ń)
+ ("´n" ?ń)
+ ("'n" ?Å„)
+ ("n'" ?Å„)
+ (",N" ?Å…)
+ ("N," ?Å…)
+ ("¸N" ?Ņ)
+ (",n" ?ņ)
+ ("n," ?ņ)
+ ("¸n" ?ņ)
+ ("cN" ?Ň)
+ ("<N" ?Ň)
+ ("N<" ?Ň)
+ ("cn" ?ň)
+ ("<n" ?ň)
+ ("n<" ?ň)
+ ("NG" ?ÅŠ)
+ ("ng" ?Å‹)
+ ("¯O" ?Ō)
+ ("_O" ?Ō)
+ ("O_" ?Ō)
+ ("-O" ?Ō)
+ ("O-" ?Ō)
+ ("¯o" ?Å)
+ ("_o" ?Å)
+ ("o_" ?Å)
+ ("-o" ?Å)
+ ("o-" ?Å)
+ ("UO" ?ÅŽ)
+ ("bO" ?ÅŽ)
+ ("Uo" ?Å)
+ ("bo" ?Å)
+ ("=O" ?Å)
+ ("=o" ?Å‘)
+ ("´R" ?Ŕ)
+ ("'R" ?Å”)
+ ("R'" ?Å”)
+ ("´r" ?ŕ)
+ ("'r" ?Å•)
+ ("r'" ?Å•)
+ (",R" ?Å–)
+ ("R," ?Å–)
+ ("¸R" ?Ŗ)
+ (",r" ?Å—)
+ ("r," ?Å—)
+ ("¸r" ?ŗ)
+ ("cR" ?Ř)
+ ("<R" ?Ř)
+ ("R<" ?Ř)
+ ("cr" ?Å™)
+ ("<r" ?Å™)
+ ("r<" ?Å™)
+ ("´S" ?Ś)
+ ("'S" ?Åš)
+ ("S'" ?Åš)
+ ("´s" ?ś)
+ ("'s" ?Å›)
+ ("s'" ?Å›)
+ ("^S" ?Ŝ)
+ ("^s" ?Å)
+ (",S" ?Åž)
+ ("S," ?Åž)
+ ("¸S" ?Ş)
+ (",s" ?ÅŸ)
+ ("s," ?ÅŸ)
+ ("¸s" ?ş)
+ ("s¸" ?ş)
+ ("cS" ?Å )
+ ("<S" ?Å )
+ ("S<" ?Å )
+ ("cs" ?Å¡)
+ ("<s" ?Å¡)
+ ("s<" ?Å¡)
+ (",T" ?Å¢)
+ ("T," ?Å¢)
+ ("¸T" ?Ţ)
+ (",t" ?Å£)
+ ("t," ?Å£)
+ ("¸t" ?ţ)
+ ("cT" ?Ť)
+ ("<T" ?Ť)
+ ("T<" ?Ť)
+ ("ct" ?Å¥)
+ ("<t" ?Å¥)
+ ("t<" ?Å¥)
+ ("/T" ?Ŧ)
+ ("T/" ?Ŧ)
+ ("T-" ?Ŧ)
+ ("/t" ?ŧ)
+ ("t/" ?ŧ)
+ ("t-" ?ŧ)
+ ("~U" ?Ũ)
+ ("U~" ?Ũ)
+ ("~u" ?Å©)
+ ("u~" ?Å©)
+ ("¯U" ?Ū)
+ ("_U" ?Ū)
+ ("U_" ?Ū)
+ ("-U" ?Ū)
+ ("U-" ?Ū)
+ ("¯u" ?ū)
+ ("_u" ?Å«)
+ ("u_" ?Å«)
+ ("-u" ?Å«)
+ ("u-" ?Å«)
+ ("UU" ?Ŭ)
+ ("uU" ?Ŭ)
+ ("bU" ?Ŭ)
+ ("Uu" ?Å­)
+ ("uu" ?Å­)
+ ("bu" ?Å­)
+ ("oU" ?Å®)
+ ("*U" ?Å®)
+ ("U*" ?Å®)
+ ("ou" ?ů)
+ ("*u" ?ů)
+ ("u*" ?ů)
+ ("=U" ?Ű)
+ ("=u" ?ű)
+ (";U" ?Ų)
+ ("U;" ?Ų)
+ (",U" ?Ų)
+ ("U," ?Ų)
+ (";u" ?ų)
+ ("u;" ?ų)
+ (",u" ?ų)
+ ("u," ?ų)
+ ("^W" ?Å´)
+ ("W^" ?Å´)
+ ("^w" ?ŵ)
+ ("w^" ?ŵ)
+ ("^Y" ?Ŷ)
+ ("Y^" ?Ŷ)
+ ("^y" ?Å·)
+ ("y^" ?Å·)
+ ("\"Y" ?Ÿ)
+ ("Y\"" ?Ÿ)
+ ("¨Y" ?Ÿ)
+ ("Y¨" ?Ÿ)
+ ("´Z" ?Ź)
+ ("'Z" ?Ź)
+ ("Z'" ?Ź)
+ ("´z" ?ź)
+ ("'z" ?ź)
+ ("z'" ?ź)
+ (".Z" ?Å»)
+ ("Z." ?Å»)
+ (".z" ?ż)
+ ("z." ?ż)
+ ("cZ" ?Ž)
+ ("vZ" ?Ž)
+ ("<Z" ?Ž)
+ ("Z<" ?Ž)
+ ("cz" ?ž)
+ ("vz" ?ž)
+ ("<z" ?ž)
+ ("z<" ?ž)
+ ("/b" ?Æ€)
+ ("/I" ?Æ—)
+ ("+O" ?Æ )
+ ("+o" ?Æ¡)
+ ("+U" ?Ư)
+ ("+u" ?ư)
+ ("/Z" ?Ƶ)
+ ("/z" ?ƶ)
+ ("cA" ?Ç)
+ ("ca" ?ÇŽ)
+ ("cI" ?Ç)
+ ("ci" ?Ç)
+ ("cO" ?Ç‘)
+ ("co" ?Ç’)
+ ("cU" ?Ç“)
+ ("cu" ?Ç”)
+ ("¯Ü" ?Ǖ)
+ ("_Ü" ?Ǖ)
+ ("¯\"U" ?Ǖ)
+ ("_\"U" ?Ç•)
+ ("¯ü" ?ǖ)
+ ("_ü" ?ǖ)
+ ("¯\"u" ?ǖ)
+ ("_\"u" ?Ç–)
+ ("´Ü" ?Ǘ)
+ ("'Ü" ?Ǘ)
+ ("´\"U" ?Ǘ)
+ ("'\"U" ?Ç—)
+ ("´ü" ?ǘ)
+ ("'ü" ?ǘ)
+ ("´\"u" ?ǘ)
+ ("'\"u" ?ǘ)
+ ("cÜ" ?Ǚ)
+ ("c\"U" ?Ç™)
+ ("cü" ?ǚ)
+ ("c\"u" ?Çš)
+ ("`Ü" ?Ǜ)
+ ("`\"U" ?Ç›)
+ ("`ü" ?ǜ)
+ ("`\"u" ?ǜ)
+ ("¯Ä" ?Ǟ)
+ ("_Ä" ?Ǟ)
+ ("¯\"A" ?Ǟ)
+ ("_\"A" ?Çž)
+ ("¯ä" ?ǟ)
+ ("_ä" ?ǟ)
+ ("¯\"a" ?ǟ)
+ ("_\"a" ?ÇŸ)
+ ("¯Ȧ" ?Ǡ)
+ ("_Ȧ" ?Ǡ)
+ ("¯.A" ?Ǡ)
+ ("_.A" ?Ç )
+ ("¯ȧ" ?ǡ)
+ ("_ȧ" ?ǡ)
+ ("¯.a" ?ǡ)
+ ("_.a" ?Ç¡)
+ ("¯Æ" ?Ǣ)
+ ("_Æ" ?Ǣ)
+ ("¯æ" ?ǣ)
+ ("_æ" ?ǣ)
+ ("/G" ?Ǥ)
+ ("/g" ?Ç¥)
+ ("cG" ?Ǧ)
+ ("cg" ?ǧ)
+ ("cK" ?Ǩ)
+ ("ck" ?Ç©)
+ (";O" ?Ǫ)
+ ("O;" ?Ǫ)
+ (",O" ?Ǫ)
+ ("O," ?Ǫ)
+ (";o" ?Ç«)
+ ("o;" ?Ç«)
+ (",o" ?Ç«)
+ ("o," ?Ç«)
+ ("¯Ǫ" ?Ǭ)
+ ("_Ǫ" ?Ǭ)
+ ("¯;O" ?Ǭ)
+ ("_;O" ?Ǭ)
+ ("¯ǫ" ?ǭ)
+ ("_Ç«" ?Ç­)
+ ("¯;o" ?ǭ)
+ ("_;o" ?Ç­)
+ ("cÆ·" ?Ç®)
+ ("cʒ" ?ǯ)
+ ("cj" ?ǰ)
+ ("´G" ?Ǵ)
+ ("'G" ?Ç´)
+ ("´g" ?ǵ)
+ ("'g" ?ǵ)
+ ("`N" ?Ǹ)
+ ("`n" ?ǹ)
+ ("´Å" ?Ǻ)
+ ("'Å" ?Ǻ)
+ ("*'A" ?Ǻ)
+ ("´å" ?ǻ)
+ ("'Ã¥" ?Ç»)
+ ("*'a" ?Ç»)
+ ("´Æ" ?Ǽ)
+ ("'Æ" ?Ǽ)
+ ("´æ" ?ǽ)
+ ("'æ" ?ǽ)
+ ("´Ø" ?Ǿ)
+ ("'Ø" ?Ǿ)
+ ("´/O" ?Ǿ)
+ ("'/O" ?Ǿ)
+ ("´ø" ?ǿ)
+ ("'ø" ?ǿ)
+ ("´/o" ?ǿ)
+ ("'/o" ?Ç¿)
+ ("cH" ?Èž)
+ ("ch" ?ÈŸ)
+ (".A" ?Ȧ)
+ (".a" ?ȧ)
+ ("¸E" ?Ȩ)
+ ("¸e" ?ȩ)
+ ("¯Ö" ?Ȫ)
+ ("_Ö" ?Ȫ)
+ ("¯\"O" ?Ȫ)
+ ("_\"O" ?Ȫ)
+ ("¯ö" ?ȫ)
+ ("_ö" ?ȫ)
+ ("¯\"o" ?ȫ)
+ ("_\"o" ?È«)
+ ("¯Õ" ?Ȭ)
+ ("_Õ" ?Ȭ)
+ ("¯~O" ?Ȭ)
+ ("_~O" ?Ȭ)
+ ("¯õ" ?ȭ)
+ ("_õ" ?ȭ)
+ ("¯~o" ?ȭ)
+ ("_~o" ?È­)
+ (".O" ?È®)
+ (".o" ?ȯ)
+ ("¯Ȯ" ?Ȱ)
+ ("_Ȯ" ?Ȱ)
+ ("¯.O" ?Ȱ)
+ ("_.O" ?Ȱ)
+ ("¯ȯ" ?ȱ)
+ ("_ȯ" ?ȱ)
+ ("¯.o" ?ȱ)
+ ("_.o" ?ȱ)
+ ("¯Y" ?Ȳ)
+ ("_Y" ?Ȳ)
+ ("¯y" ?ȳ)
+ ("_y" ?ȳ)
+ ("ee" ?É™)
+ ("/i" ?ɨ)
+ ("/Ê”" ?Ê¡)
+ ("^_h" ?ʰ)
+ ("^_h" ?ʰ)
+ ("^_ɦ" ?ʱ)
+ ("^_ɦ" ?ʱ)
+ ("^_j" ?ʲ)
+ ("^_j" ?ʲ)
+ ("^_r" ?ʳ)
+ ("^_r" ?ʳ)
+ ("^_ɹ" ?ʴ)
+ ("^_ɹ" ?ʴ)
+ ("^_ɻ" ?ʵ)
+ ("^_ɻ" ?ʵ)
+ ("^_Ê" ?ʶ)
+ ("^_Ê" ?ʶ)
+ ("^_w" ?Ê·)
+ ("^_w" ?Ê·)
+ ("^_y" ?ʸ)
+ ("^_y" ?ʸ)
+ ("^_É£" ?Ë )
+ ("^_É£" ?Ë )
+ ("^_l" ?Ë¡)
+ ("^_l" ?Ë¡)
+ ("^_s" ?Ë¢)
+ ("^_s" ?Ë¢)
+ ("^_x" ?Ë£)
+ ("^_x" ?Ë£)
+ ("^_ʕ" ?ˤ)
+ ("^_ʕ" ?ˤ)
+ ("\"´" ?̈́)
+ ("\"'" ?Í„)
+ ("¨´" ?΅)
+ ("¨'" ?΅)
+ ("'\" " ?Î…)
+ ("´Α" ?Ά)
+ ("'Α" ?Ά)
+ ("Α'" ?Ά)
+ ("´Ε" ?Έ)
+ ("'Ε" ?Έ)
+ ("Ε'" ?Έ)
+ ("´Η" ?Ή)
+ ("'Η" ?Ή)
+ ("Η'" ?Ή)
+ ("´Ι" ?Ί)
+ ("'Ι" ?Ί)
+ ("Ι'" ?Ί)
+ ("´Ο" ?Ό)
+ ("'Ο" ?Ό)
+ ("Ο'" ?Ό)
+ ("´Υ" ?Ύ)
+ ("'Î¥" ?ÎŽ)
+ ("Î¥'" ?ÎŽ)
+ ("´Ω" ?Î)
+ ("'Ω" ?Î)
+ ("Ω'" ?Î)
+ ("´ϊ" ?Î)
+ ("'ÏŠ" ?Î)
+ ("´\"ι" ?Î)
+ ("'\"ι" ?Î)
+ ("\"Ι" ?Ϊ)
+ ("Ι\"" ?Ϊ)
+ ("\"Υ" ?Ϋ)
+ ("Υ\"" ?Ϋ)
+ ("´α" ?ά)
+ ("'α" ?ά)
+ ("α'" ?ά)
+ ("´ε" ?έ)
+ ("'ε" ?έ)
+ ("ε'" ?έ)
+ ("´η" ?ή)
+ ("'η" ?ή)
+ ("η'" ?ή)
+ ("´ι" ?ί)
+ ("'ι" ?ί)
+ ("´ϋ" ?ΰ)
+ ("'ϋ" ?ΰ)
+ ("´\"υ" ?ΰ)
+ ("'\"υ" ?ΰ)
+ ("\"ι" ?ϊ)
+ ("ι\"" ?ϊ)
+ ("\"Ï…" ?Ï‹)
+ ("Ï…\"" ?Ï‹)
+ ("´ο" ?ό)
+ ("'ο" ?ό)
+ ("ο'" ?ό)
+ ("´υ" ?Ï)
+ ("'Ï…" ?Ï)
+ ("Ï…'" ?Ï)
+ ("´ω" ?ώ)
+ ("'ω" ?ώ)
+ ("ω'" ?ώ)
+ ("\"Ï’" ?Ï”)
+ ("`Е" ?Ѐ)
+ ("\"Е" ?Ð)
+ ("´Г" ?Ѓ)
+ ("'Г" ?Ѓ)
+ ("\"І" ?Ї)
+ ("´К" ?Ќ)
+ ("'К" ?Ќ)
+ ("`И" ?Ð)
+ ("UУ" ?Ў)
+ ("bУ" ?Ў)
+ ("UИ" ?Й)
+ ("bИ" ?Й)
+ ("Uи" ?й)
+ ("bи" ?й)
+ ("`е" ?Ñ)
+ ("\"е" ?ё)
+ ("´г" ?ѓ)
+ ("'г" ?ѓ)
+ ("\"Ñ–" ?Ñ—)
+ ("´к" ?ќ)
+ ("'к" ?ќ)
+ ("`и" ?Ñ)
+ ("Uу" ?ў)
+ ("bу" ?ў)
+ ("/Г" ?Ғ)
+ ("/г" ?ғ)
+ ("/К" ?Ҟ)
+ ("/к" ?ҟ)
+ ("/Ò®" ?Ò°)
+ ("/Ò¯" ?Ò±)
+ ("UЖ" ?Ó)
+ ("bЖ" ?Ó)
+ ("Uж" ?ӂ)
+ ("bж" ?ӂ)
+ ("UÐ" ?Ó)
+ ("bÐ" ?Ó)
+ ("Uа" ?ӑ)
+ ("bа" ?ӑ)
+ ("\"Ð" ?Ó’)
+ ("\"а" ?ӓ)
+ ("UЕ" ?Ӗ)
+ ("bЕ" ?Ӗ)
+ ("Uе" ?ӗ)
+ ("bе" ?ӗ)
+ ("\"Ó˜" ?Óš)
+ ("\"Ó™" ?Ó›)
+ ("\"Ж" ?Ӝ)
+ ("\"ж" ?Ó)
+ ("\"З" ?Ӟ)
+ ("\"з" ?ӟ)
+ ("¯И" ?Ӣ)
+ ("_И" ?Ӣ)
+ ("¯и" ?ӣ)
+ ("_и" ?ӣ)
+ ("\"И" ?Ӥ)
+ ("\"и" ?ӥ)
+ ("\"О" ?Ӧ)
+ ("\"о" ?ӧ)
+ ("\"Ó¨" ?Óª)
+ ("\"Ó©" ?Ó«)
+ ("\"Э" ?Ӭ)
+ ("\"Ñ" ?Ó­)
+ ("¯У" ?Ӯ)
+ ("_У" ?Ӯ)
+ ("¯у" ?ӯ)
+ ("_у" ?ӯ)
+ ("\"У" ?Ӱ)
+ ("\"у" ?ӱ)
+ ("=У" ?Ӳ)
+ ("=у" ?ӳ)
+ ("\"Ч" ?Ӵ)
+ ("\"ч" ?ӵ)
+ ("\"Ы" ?Ӹ)
+ ("\"Ñ‹" ?Ó¹)
+ ("ٓا" ?آ)
+ ("ٔا" ?أ)
+ ("ٔو" ?ؤ)
+ ("ٕا" ?إ)
+ ("ٔي" ?ئ)
+ ("Ù”Û•" ?Û€)
+ ("Ù”Û" ?Û‚)
+ ("Ù”Û’" ?Û“)
+ ("़न" ?ऩ)
+ ("़र" ?ऱ)
+ ("़ळ" ?ऴ)
+ ("़क" ?क़)
+ ("़ख" ?ख़)
+ ("़ग" ?ग़)
+ ("़ज" ?ज़)
+ ("़ड" ?ड़)
+ ("़ढ" ?à¥)
+ ("़फ" ?फ़)
+ ("़य" ?य़)
+ ("ো" ?ো)
+ ("ৌ" ?ৌ)
+ ("়ড" ?ড়)
+ ("়ঢ" ?à§)
+ ("়য" ?য়)
+ ("਼ਲ" ?ਲ਼)
+ ("਼ਸ" ?ਸ਼)
+ ("਼ਖ" ?ਖ਼)
+ ("਼ਗ" ?ਗ਼)
+ ("਼ਜ" ?ਜ਼)
+ ("਼ਫ" ?ਫ਼)
+ ("ୈ" ?ୈ)
+ ("ୋ" ?ୋ)
+ ("ୌ" ?ୌ)
+ ("଼ଡ" ?ଡ଼)
+ ("଼ଢ" ?à­)
+ ("ௗஒ" ?ஔ)
+ ("ொ" ?ொ)
+ ("ோ" ?ோ)
+ ("ௌ" ?ௌ)
+ ("ై" ?ై)
+ ("ೀ" ?ೀ)
+ ("ೇ" ?ೇ)
+ ("ೈ" ?ೈ)
+ ("ೊ" ?ೊ)
+ ("ೋ" ?ೋ)
+ ("ൊ" ?ൊ)
+ ("ോ" ?ോ)
+ ("ൌ" ?ൌ)
+ ("ේ" ?ේ)
+ ("à·™à·" ?à·œ)
+ ("ෝ" ?à·)
+ ("ෞ" ?ෞ)
+ ("ྷག" ?གྷ)
+ ("ྷཌ" ?à½)
+ ("ྷད" ?དྷ)
+ ("ྷབ" ?བྷ)
+ ("ྷཛ" ?ཛྷ)
+ ("ྵཀ" ?ཀྵ)
+ ("ཱི" ?ཱི)
+ ("ཱུ" ?ཱུ)
+ ("ྲྀ" ?ྲྀ)
+ ("ླྀ" ?ླྀ)
+ ("ཱྀ" ?à¾)
+ ("ྒྷ" ?ྒྷ)
+ ("ྜྷ" ?à¾)
+ ("ྡྷ" ?ྡྷ)
+ ("ྦྷ" ?ྦྷ)
+ ("ྫྷ" ?ྫྷ)
+ ("à¾à¾µ" ?ྐྵ)
+ ("ီဥ" ?ဦ)
+ (".B" ?Ḃ)
+ ("B." ?Ḃ)
+ (".b" ?ḃ)
+ ("b." ?ḃ)
+ ("!B" ?Ḅ)
+ ("!b" ?ḅ)
+ ("´Ç" ?Ḉ)
+ ("'Ç" ?Ḉ)
+ ("´,C" ?Ḉ)
+ ("´¸C" ?Ḉ)
+ ("'¸C" ?Ḉ)
+ ("´ç" ?ḉ)
+ ("'ç" ?ḉ)
+ ("´,c" ?ḉ)
+ ("´¸c" ?ḉ)
+ ("'¸c" ?ḉ)
+ (".D" ?Ḋ)
+ ("D." ?Ḋ)
+ (".d" ?ḋ)
+ ("d." ?ḋ)
+ ("!D" ?Ḍ)
+ ("!d" ?á¸)
+ (",D" ?á¸)
+ ("D," ?á¸)
+ ("¸D" ?á¸)
+ (",d" ?ḑ)
+ ("d," ?ḑ)
+ ("¸d" ?ḑ)
+ ("`Ē" ?Ḕ)
+ ("`¯E" ?Ḕ)
+ ("`_E" ?Ḕ)
+ ("`ē" ?ḕ)
+ ("`¯e" ?ḕ)
+ ("`_e" ?ḕ)
+ ("´Ē" ?Ḗ)
+ ("'Ē" ?Ḗ)
+ ("´¯E" ?Ḗ)
+ ("´_E" ?Ḗ)
+ ("'¯E" ?Ḗ)
+ ("'_E" ?Ḗ)
+ ("´ē" ?ḗ)
+ ("'ē" ?ḗ)
+ ("´¯e" ?ḗ)
+ ("´_e" ?ḗ)
+ ("'¯e" ?ḗ)
+ ("'_e" ?ḗ)
+ ("UȨ" ?Ḝ)
+ ("bȨ" ?Ḝ)
+ ("U ,E" ?Ḝ)
+ ("U¸E" ?Ḝ)
+ ("b,E" ?Ḝ)
+ ("b¸E" ?Ḝ)
+ ("UÈ©" ?á¸)
+ ("bÈ©" ?á¸)
+ ("U ,e" ?á¸)
+ ("U¸e" ?á¸)
+ ("b,e" ?á¸)
+ ("b¸e" ?á¸)
+ (".F" ?Ḟ)
+ ("F." ?Ḟ)
+ (".f" ?ḟ)
+ ("f." ?ḟ)
+ ("¯G" ?Ḡ)
+ ("_G" ?Ḡ)
+ ("¯g" ?ḡ)
+ ("_g" ?ḡ)
+ (".H" ?Ḣ)
+ (".h" ?ḣ)
+ ("!H" ?Ḥ)
+ ("!h" ?ḥ)
+ ("\"H" ?Ḧ)
+ ("\"h" ?ḧ)
+ (",H" ?Ḩ)
+ ("H," ?Ḩ)
+ ("¸H" ?Ḩ)
+ (",h" ?ḩ)
+ ("h," ?ḩ)
+ ("¸h" ?ḩ)
+ ("´Ã" ?Ḯ)
+ ("'Ã" ?Ḯ)
+ ("´\"I" ?Ḯ)
+ ("'\"I" ?Ḯ)
+ ("´ï" ?ḯ)
+ ("'ï" ?ḯ)
+ ("´\"i" ?ḯ)
+ ("'\"i" ?ḯ)
+ ("´K" ?Ḱ)
+ ("'K" ?Ḱ)
+ ("´k" ?ḱ)
+ ("'k" ?ḱ)
+ ("!K" ?Ḳ)
+ ("!k" ?ḳ)
+ ("!L" ?Ḷ)
+ ("!l" ?ḷ)
+ ("¯Ḷ" ?Ḹ)
+ ("_Ḷ" ?Ḹ)
+ ("¯!L" ?Ḹ)
+ ("_!L" ?Ḹ)
+ ("¯ḷ" ?ḹ)
+ ("_ḷ" ?ḹ)
+ ("¯!l" ?ḹ)
+ ("_!l" ?ḹ)
+ ("´M" ?Ḿ)
+ ("'M" ?Ḿ)
+ ("´m" ?ḿ)
+ ("'m" ?ḿ)
+ (".M" ?á¹€)
+ ("M." ?á¹€)
+ (".m" ?á¹)
+ ("m." ?á¹)
+ ("!M" ?Ṃ)
+ ("!m" ?ṃ)
+ (".N" ?Ṅ)
+ (".n" ?á¹…)
+ ("!N" ?Ṇ)
+ ("!n" ?ṇ)
+ ("´Õ" ?Ṍ)
+ ("'Õ" ?Ṍ)
+ ("´~O" ?Ṍ)
+ ("'~O" ?Ṍ)
+ ("´õ" ?á¹)
+ ("'õ" ?á¹)
+ ("´~o" ?á¹)
+ ("'~o" ?á¹)
+ ("\"Õ" ?Ṏ)
+ ("\"~O" ?Ṏ)
+ ("\"õ" ?á¹)
+ ("\"~o" ?á¹)
+ ("`ÅŒ" ?á¹)
+ ("`¯O" ?á¹)
+ ("`_O" ?á¹)
+ ("`Å" ?ṑ)
+ ("`¯o" ?ṑ)
+ ("`_o" ?ṑ)
+ ("´Ō" ?Ṓ)
+ ("'Ō" ?Ṓ)
+ ("´¯O" ?Ṓ)
+ ("´_O" ?Ṓ)
+ ("'¯O" ?Ṓ)
+ ("'_O" ?á¹’)
+ ("´Å" ?ṓ)
+ ("'Å" ?ṓ)
+ ("´¯o" ?ṓ)
+ ("´_o" ?ṓ)
+ ("'¯o" ?ṓ)
+ ("'_o" ?ṓ)
+ ("´P" ?Ṕ)
+ ("'P" ?á¹”)
+ ("´p" ?ṕ)
+ ("'p" ?ṕ)
+ (".P" ?á¹–)
+ ("P." ?á¹–)
+ (".p" ?á¹—)
+ ("p." ?á¹—)
+ (".R" ?Ṙ)
+ (".r" ?á¹™)
+ ("!R" ?Ṛ)
+ ("!r" ?á¹›)
+ ("¯Ṛ" ?Ṝ)
+ ("_Ṛ" ?Ṝ)
+ ("¯!R" ?Ṝ)
+ ("_!R" ?Ṝ)
+ ("¯ṛ" ?á¹)
+ ("_á¹›" ?á¹)
+ ("¯!r" ?á¹)
+ ("_!r" ?á¹)
+ (".S" ?á¹ )
+ ("S." ?á¹ )
+ (".s" ?ṡ)
+ ("s." ?ṡ)
+ ("!S" ?á¹¢)
+ ("!s" ?á¹£)
+ (".Ś" ?Ṥ)
+ (".´S" ?Ṥ)
+ (".'S" ?Ṥ)
+ (".Å›" ?á¹¥)
+ (".´s" ?ṥ)
+ (".'s" ?á¹¥)
+ (".Š" ?Ṧ)
+ (".Å¡" ?á¹§)
+ (".Ṣ" ?Ṩ)
+ (".!S" ?Ṩ)
+ (".ṣ" ?ṩ)
+ (".!s" ?ṩ)
+ (".T" ?Ṫ)
+ ("T." ?Ṫ)
+ (".t" ?ṫ)
+ ("t." ?ṫ)
+ ("!T" ?Ṭ)
+ ("!t" ?á¹­)
+ ("´Ũ" ?Ṹ)
+ ("'Ũ" ?Ṹ)
+ ("´~U" ?Ṹ)
+ ("'~U" ?Ṹ)
+ ("´ũ" ?ṹ)
+ ("'Å©" ?á¹¹)
+ ("´~u" ?ṹ)
+ ("'~u" ?á¹¹)
+ ("\"Ū" ?Ṻ)
+ ("\"¯U" ?Ṻ)
+ ("\"_U" ?Ṻ)
+ ("\"Å«" ?á¹»)
+ ("\"¯u" ?ṻ)
+ ("\"_u" ?á¹»)
+ ("~V" ?á¹¼)
+ ("~v" ?á¹½)
+ ("!V" ?á¹¾)
+ ("!v" ?ṿ)
+ ("`W" ?Ẁ)
+ ("`w" ?áº)
+ ("´W" ?Ẃ)
+ ("'W" ?Ẃ)
+ ("´w" ?ẃ)
+ ("'w" ?ẃ)
+ ("\"W" ?Ẅ)
+ ("\"w" ?ẅ)
+ (".W" ?Ẇ)
+ (".w" ?ẇ)
+ ("!W" ?Ẉ)
+ ("!w" ?ẉ)
+ (".X" ?Ẋ)
+ (".x" ?ẋ)
+ ("\"X" ?Ẍ)
+ ("\"x" ?áº)
+ (".Y" ?Ẏ)
+ (".y" ?áº)
+ ("^Z" ?áº)
+ ("^z" ?ẑ)
+ ("!Z" ?Ẓ)
+ ("!z" ?ẓ)
+ ("\"t" ?ẗ)
+ ("ow" ?ẘ)
+ ("oy" ?ẙ)
+ (".ſ" ?ẛ)
+ ("!A" ?Ạ)
+ ("!a" ?ạ)
+ ("?A" ?Ả)
+ ("?a" ?ả)
+ ("´Â" ?Ấ)
+ ("'Â" ?Ấ)
+ ("´^A" ?Ấ)
+ ("'^A" ?Ấ)
+ ("´â" ?ấ)
+ ("'â" ?ấ)
+ ("´^a" ?ấ)
+ ("'^a" ?ấ)
+ ("`Â" ?Ầ)
+ ("`^A" ?Ầ)
+ ("`â" ?ầ)
+ ("`^a" ?ầ)
+ ("?Â" ?Ẩ)
+ ("?^A" ?Ẩ)
+ ("?â" ?ẩ)
+ ("?^a" ?ẩ)
+ ("~Â" ?Ẫ)
+ ("~^A" ?Ẫ)
+ ("~â" ?ẫ)
+ ("~^a" ?ẫ)
+ ("^Ạ" ?Ậ)
+ ("^!A" ?Ậ)
+ ("^ạ" ?ậ)
+ ("^!a" ?ậ)
+ ("´Ă" ?Ắ)
+ ("'Ă" ?Ắ)
+ ("´bA" ?Ắ)
+ ("'bA" ?Ắ)
+ ("´ă" ?ắ)
+ ("'ă" ?ắ)
+ ("´ba" ?ắ)
+ ("'ba" ?ắ)
+ ("`Ă" ?Ằ)
+ ("`bA" ?Ằ)
+ ("`ă" ?ằ)
+ ("`ba" ?ằ)
+ ("?Ă" ?Ẳ)
+ ("?bA" ?Ẳ)
+ ("?ă" ?ẳ)
+ ("?ba" ?ẳ)
+ ("~Ă" ?Ẵ)
+ ("~bA" ?Ẵ)
+ ("~ă" ?ẵ)
+ ("~ba" ?ẵ)
+ ("UẠ" ?Ặ)
+ ("bẠ" ?Ặ)
+ ("U!A" ?Ặ)
+ ("b!A" ?Ặ)
+ ("Uạ" ?ặ)
+ ("bạ" ?ặ)
+ ("U!a" ?ặ)
+ ("b!a" ?ặ)
+ ("!E" ?Ẹ)
+ ("!e" ?ẹ)
+ ("?E" ?Ẻ)
+ ("?e" ?ẻ)
+ ("~E" ?Ẽ)
+ ("~e" ?ẽ)
+ ("´Ê" ?Ế)
+ ("'Ê" ?Ế)
+ ("´^E" ?Ế)
+ ("'^E" ?Ế)
+ ("´ê" ?ế)
+ ("'ê" ?ế)
+ ("´^e" ?ế)
+ ("'^e" ?ế)
+ ("`Ê" ?Ề)
+ ("`^E" ?Ề)
+ ("`ê" ?á»)
+ ("`^e" ?á»)
+ ("?Ê" ?Ể)
+ ("?^E" ?Ể)
+ ("?ê" ?ể)
+ ("?^e" ?ể)
+ ("~Ê" ?Ễ)
+ ("~^E" ?Ễ)
+ ("~ê" ?ễ)
+ ("~^e" ?á»…)
+ ("^Ẹ" ?Ệ)
+ ("^!E" ?Ệ)
+ ("^ẹ" ?ệ)
+ ("^!e" ?ệ)
+ ("?I" ?Ỉ)
+ ("?i" ?ỉ)
+ ("!I" ?Ị)
+ ("!i" ?ị)
+ ("!O" ?Ọ)
+ ("!o" ?á»)
+ ("?O" ?Ỏ)
+ ("?o" ?á»)
+ ("´Ô" ?á»)
+ ("'Ô" ?á»)
+ ("´^O" ?á»)
+ ("'^O" ?á»)
+ ("´ô" ?ố)
+ ("'ô" ?ố)
+ ("´^o" ?ố)
+ ("'^o" ?ố)
+ ("`Ô" ?Ồ)
+ ("`^O" ?á»’)
+ ("`ô" ?ồ)
+ ("`^o" ?ồ)
+ ("?Ô" ?Ổ)
+ ("?^O" ?á»”)
+ ("?ô" ?ổ)
+ ("?^o" ?ổ)
+ ("~Ô" ?Ỗ)
+ ("~^O" ?á»–)
+ ("~ô" ?ỗ)
+ ("~^o" ?á»—)
+ ("^Ọ" ?Ộ)
+ ("^!O" ?Ộ)
+ ("^á»" ?á»™)
+ ("^!o" ?á»™)
+ ("´Ơ" ?Ớ)
+ ("'Ơ" ?Ớ)
+ ("´+O" ?Ớ)
+ ("'+O" ?Ớ)
+ ("´ơ" ?ớ)
+ ("'Æ¡" ?á»›)
+ ("´+o" ?ớ)
+ ("'+o" ?á»›)
+ ("`Ơ" ?Ờ)
+ ("`+O" ?Ờ)
+ ("`Æ¡" ?á»)
+ ("`+o" ?á»)
+ ("?Ơ" ?Ở)
+ ("?+O" ?Ở)
+ ("?ơ" ?ở)
+ ("?+o" ?ở)
+ ("~Æ " ?á» )
+ ("~+O" ?á» )
+ ("~ơ" ?ỡ)
+ ("~+o" ?ỡ)
+ ("!Ơ" ?Ợ)
+ ("!+O" ?Ợ)
+ ("!ơ" ?ợ)
+ ("!+o" ?ợ)
+ ("!U" ?Ụ)
+ ("!u" ?ụ)
+ ("?U" ?Ủ)
+ ("?u" ?á»§)
+ ("´Ư" ?Ứ)
+ ("'Ư" ?Ứ)
+ ("´+U" ?Ứ)
+ ("'+U" ?Ứ)
+ ("´ư" ?ứ)
+ ("'ư" ?ứ)
+ ("´+u" ?ứ)
+ ("'+u" ?ứ)
+ ("`Ư" ?Ừ)
+ ("`+U" ?Ừ)
+ ("`ư" ?ừ)
+ ("`+u" ?ừ)
+ ("?Ư" ?Ử)
+ ("?+U" ?Ử)
+ ("?ư" ?ử)
+ ("?+u" ?á»­)
+ ("~Ư" ?Ữ)
+ ("~+U" ?á»®)
+ ("~ư" ?ữ)
+ ("~+u" ?ữ)
+ ("!Ư" ?Ự)
+ ("!+U" ?á»°)
+ ("!ư" ?ự)
+ ("!+u" ?á»±)
+ ("`Y" ?Ỳ)
+ ("`y" ?ỳ)
+ ("!Y" ?á»´)
+ ("!y" ?ỵ)
+ ("?Y" ?á»¶)
+ ("?y" ?á»·)
+ ("~Y" ?Ỹ)
+ ("~y" ?ỹ)
+ (")α" ?ἀ)
+ ("(α" ?á¼)
+ ("`ἀ" ?ἂ)
+ ("`)α" ?ἂ)
+ ("`á¼" ?ἃ)
+ ("`(α" ?ἃ)
+ ("´ἀ" ?ἄ)
+ ("'ἀ" ?ἄ)
+ ("´)α" ?ἄ)
+ ("')α" ?ἄ)
+ ("´á¼" ?á¼…)
+ ("'á¼" ?á¼…)
+ ("´(α" ?ἅ)
+ ("'(α" ?ἅ)
+ ("~ἀ" ?ἆ)
+ ("~)α" ?ἆ)
+ ("~á¼" ?ἇ)
+ ("~(α" ?ἇ)
+ (")Α" ?Ἀ)
+ ("(Α" ?Ἁ)
+ ("`Ἀ" ?Ἂ)
+ ("`)Α" ?Ἂ)
+ ("`Ἁ" ?Ἃ)
+ ("`(Α" ?Ἃ)
+ ("´Ἀ" ?Ἄ)
+ ("'Ἀ" ?Ἄ)
+ ("´)Α" ?Ἄ)
+ ("')Α" ?Ἄ)
+ ("´Ἁ" ?á¼)
+ ("'Ἁ" ?á¼)
+ ("´(Α" ?á¼)
+ ("'(Α" ?á¼)
+ ("~Ἀ" ?Ἆ)
+ ("~)Α" ?Ἆ)
+ ("~Ἁ" ?á¼)
+ ("~(Α" ?á¼)
+ (")ε" ?á¼)
+ ("(ε" ?ἑ)
+ ("`á¼" ?á¼’)
+ ("`)ε" ?ἒ)
+ ("`ἑ" ?ἓ)
+ ("`(ε" ?ἓ)
+ ("´á¼" ?á¼”)
+ ("'á¼" ?á¼”)
+ ("´)ε" ?ἔ)
+ ("')ε" ?ἔ)
+ ("´ἑ" ?ἕ)
+ ("'ἑ" ?ἕ)
+ ("´(ε" ?ἕ)
+ ("'(ε" ?ἕ)
+ (")Ε" ?Ἐ)
+ ("(Ε" ?Ἑ)
+ ("`Ἐ" ?Ἒ)
+ ("`)Ε" ?Ἒ)
+ ("`á¼™" ?á¼›)
+ ("`(Ε" ?Ἓ)
+ ("´Ἐ" ?Ἔ)
+ ("'Ἐ" ?Ἔ)
+ ("´)Ε" ?Ἔ)
+ ("')Ε" ?Ἔ)
+ ("´Ἑ" ?á¼)
+ ("'á¼™" ?á¼)
+ ("´(Ε" ?á¼)
+ ("'(Ε" ?á¼)
+ (")η" ?ἠ)
+ ("(η" ?ἡ)
+ ("`á¼ " ?á¼¢)
+ ("`)η" ?ἢ)
+ ("`ἡ" ?ἣ)
+ ("`(η" ?ἣ)
+ ("´ἠ" ?ἤ)
+ ("'ἠ" ?ἤ)
+ ("´)η" ?ἤ)
+ ("')η" ?ἤ)
+ ("´ἡ" ?ἥ)
+ ("'ἡ" ?ἥ)
+ ("´(η" ?ἥ)
+ ("'(η" ?ἥ)
+ ("~ἠ" ?ἦ)
+ ("~)η" ?ἦ)
+ ("~ἡ" ?ἧ)
+ ("~(η" ?ἧ)
+ (")Η" ?Ἠ)
+ ("(Η" ?Ἡ)
+ ("`Ἠ" ?Ἢ)
+ ("`)Η" ?Ἢ)
+ ("`Ἡ" ?Ἣ)
+ ("`(Η" ?Ἣ)
+ ("´Ἠ" ?Ἤ)
+ ("'Ἠ" ?Ἤ)
+ ("´)Η" ?Ἤ)
+ ("')Η" ?Ἤ)
+ ("´Ἡ" ?Ἥ)
+ ("'Ἡ" ?Ἥ)
+ ("´(Η" ?Ἥ)
+ ("'(Η" ?Ἥ)
+ ("~Ἠ" ?Ἦ)
+ ("~)Η" ?Ἦ)
+ ("~Ἡ" ?Ἧ)
+ ("~(Η" ?Ἧ)
+ (")ι" ?ἰ)
+ ("(ι" ?ἱ)
+ ("`á¼°" ?á¼²)
+ ("`)ι" ?ἲ)
+ ("`á¼±" ?á¼³)
+ ("`(ι" ?ἳ)
+ ("´ἰ" ?ἴ)
+ ("'á¼°" ?á¼´)
+ ("´)ι" ?ἴ)
+ ("')ι" ?ἴ)
+ ("´ἱ" ?ἵ)
+ ("'á¼±" ?á¼µ)
+ ("´(ι" ?ἵ)
+ ("'(ι" ?ἵ)
+ ("~á¼°" ?á¼¶)
+ ("~)ι" ?ἶ)
+ ("~á¼±" ?á¼·)
+ ("~(ι" ?ἷ)
+ (")Ι" ?Ἰ)
+ ("(Ι" ?Ἱ)
+ ("`Ἰ" ?Ἲ)
+ ("`)Ι" ?Ἲ)
+ ("`á¼¹" ?á¼»)
+ ("`(Ι" ?Ἳ)
+ ("´Ἰ" ?Ἴ)
+ ("'Ἰ" ?Ἴ)
+ ("´)Ι" ?Ἴ)
+ ("')Ι" ?Ἴ)
+ ("´Ἱ" ?Ἵ)
+ ("'á¼¹" ?á¼½)
+ ("´(Ι" ?Ἵ)
+ ("'(Ι" ?Ἵ)
+ ("~Ἰ" ?Ἶ)
+ ("~)Ι" ?Ἶ)
+ ("~Ἱ" ?Ἷ)
+ ("~(Ι" ?Ἷ)
+ (")ο" ?ὀ)
+ ("(ο" ?á½)
+ ("`ὀ" ?ὂ)
+ ("`)ο" ?ὂ)
+ ("`á½" ?ὃ)
+ ("`(ο" ?ὃ)
+ ("´ὀ" ?ὄ)
+ ("'ὀ" ?ὄ)
+ ("´)ο" ?ὄ)
+ ("')ο" ?ὄ)
+ ("´á½" ?á½…)
+ ("'á½" ?á½…)
+ ("´(ο" ?ὅ)
+ ("'(ο" ?ὅ)
+ (")Ο" ?Ὀ)
+ ("(Ο" ?Ὁ)
+ ("`Ὀ" ?Ὂ)
+ ("`)Ο" ?Ὂ)
+ ("`Ὁ" ?Ὃ)
+ ("`(Ο" ?Ὃ)
+ ("´Ὀ" ?Ὄ)
+ ("'Ὀ" ?Ὄ)
+ ("´)Ο" ?Ὄ)
+ ("')Ο" ?Ὄ)
+ ("´Ὁ" ?á½)
+ ("'Ὁ" ?á½)
+ ("´(Ο" ?á½)
+ ("'(Ο" ?á½)
+ (")Ï…" ?á½)
+ ("(υ" ?ὑ)
+ ("`á½" ?á½’)
+ ("`)Ï…" ?á½’)
+ ("`ὑ" ?ὓ)
+ ("`(υ" ?ὓ)
+ ("´á½" ?á½”)
+ ("'á½" ?á½”)
+ ("´)υ" ?ὔ)
+ ("')Ï…" ?á½”)
+ ("´ὑ" ?ὕ)
+ ("'ὑ" ?ὕ)
+ ("´(υ" ?ὕ)
+ ("'(υ" ?ὕ)
+ ("~á½" ?á½–)
+ ("~)Ï…" ?á½–)
+ ("~ὑ" ?ὗ)
+ ("~(Ï…" ?á½—)
+ ("(Î¥" ?á½™)
+ ("`á½™" ?á½›)
+ ("`(Î¥" ?á½›)
+ ("´Ὑ" ?á½)
+ ("'á½™" ?á½)
+ ("´(Î¥" ?á½)
+ ("'(Î¥" ?á½)
+ ("~Ὑ" ?Ὗ)
+ ("~(Υ" ?Ὗ)
+ (")ω" ?ὠ)
+ ("(ω" ?ὡ)
+ ("`á½ " ?á½¢)
+ ("`)ω" ?ὢ)
+ ("`ὡ" ?ὣ)
+ ("`(ω" ?ὣ)
+ ("´ὠ" ?ὤ)
+ ("'ὠ" ?ὤ)
+ ("´)ω" ?ὤ)
+ ("')ω" ?ὤ)
+ ("´ὡ" ?ὥ)
+ ("'ὡ" ?ὥ)
+ ("´(ω" ?ὥ)
+ ("'(ω" ?ὥ)
+ ("~ὠ" ?ὦ)
+ ("~)ω" ?ὦ)
+ ("~ὡ" ?ὧ)
+ ("~(ω" ?ὧ)
+ (")Ω" ?Ὠ)
+ ("(Ω" ?Ὡ)
+ ("`Ὠ" ?Ὢ)
+ ("`)Ω" ?Ὢ)
+ ("`Ὡ" ?Ὣ)
+ ("`(Ω" ?Ὣ)
+ ("´Ὠ" ?Ὤ)
+ ("'Ὠ" ?Ὤ)
+ ("´)Ω" ?Ὤ)
+ ("')Ω" ?Ὤ)
+ ("´Ὡ" ?Ὥ)
+ ("'Ὡ" ?Ὥ)
+ ("´(Ω" ?Ὥ)
+ ("'(Ω" ?Ὥ)
+ ("~Ὠ" ?Ὦ)
+ ("~)Ω" ?Ὦ)
+ ("~Ὡ" ?Ὧ)
+ ("~(Ω" ?Ὧ)
+ ("`α" ?ὰ)
+ ("`ε" ?ὲ)
+ ("`η" ?ὴ)
+ ("`ι" ?ὶ)
+ ("`ο" ?ὸ)
+ ("`υ" ?ὺ)
+ ("`ω" ?ὼ)
+ ("ιἀ" ?ᾀ)
+ ("ι)α" ?ᾀ)
+ ("ιá¼" ?á¾)
+ ("ι(α" ?á¾)
+ ("ιἂ" ?ᾂ)
+ ("ι`ἀ" ?ᾂ)
+ ("ι`)α" ?ᾂ)
+ ("ιἃ" ?ᾃ)
+ ("ι`á¼" ?ᾃ)
+ ("ι`(α" ?ᾃ)
+ ("ιἄ" ?ᾄ)
+ ("ι´ἀ" ?ᾄ)
+ ("ι'ἀ" ?ᾄ)
+ ("ι´)α" ?ᾄ)
+ ("ι')α" ?ᾄ)
+ ("ιἅ" ?ᾅ)
+ ("ι´á¼" ?á¾…)
+ ("ι'á¼" ?á¾…)
+ ("ι´(α" ?ᾅ)
+ ("ι'(α" ?ᾅ)
+ ("ιἆ" ?ᾆ)
+ ("ι~ἀ" ?ᾆ)
+ ("ι~)α" ?ᾆ)
+ ("ιἇ" ?ᾇ)
+ ("ι~á¼" ?ᾇ)
+ ("ι~(α" ?ᾇ)
+ ("ιἈ" ?ᾈ)
+ ("ι)Α" ?ᾈ)
+ ("ιἉ" ?ᾉ)
+ ("ι(Α" ?ᾉ)
+ ("ιἊ" ?ᾊ)
+ ("ι`Ἀ" ?ᾊ)
+ ("ι`)Α" ?ᾊ)
+ ("ιἋ" ?ᾋ)
+ ("ι`Ἁ" ?ᾋ)
+ ("ι`(Α" ?ᾋ)
+ ("ιἌ" ?ᾌ)
+ ("ι´Ἀ" ?ᾌ)
+ ("ι'Ἀ" ?ᾌ)
+ ("ι´)Α" ?ᾌ)
+ ("ι')Α" ?ᾌ)
+ ("ιá¼" ?á¾)
+ ("ι´Ἁ" ?á¾)
+ ("ι'Ἁ" ?á¾)
+ ("ι´(Α" ?á¾)
+ ("ι'(Α" ?á¾)
+ ("ιἎ" ?ᾎ)
+ ("ι~Ἀ" ?ᾎ)
+ ("ι~)Α" ?ᾎ)
+ ("ιá¼" ?á¾)
+ ("ι~Ἁ" ?á¾)
+ ("ι~(Α" ?á¾)
+ ("ιἠ" ?á¾)
+ ("ι)η" ?á¾)
+ ("ιἡ" ?ᾑ)
+ ("ι(η" ?ᾑ)
+ ("ιἢ" ?ᾒ)
+ ("ι`ἠ" ?ᾒ)
+ ("ι`)η" ?ᾒ)
+ ("ιἣ" ?ᾓ)
+ ("ι`ἡ" ?ᾓ)
+ ("ι`(η" ?ᾓ)
+ ("ιἤ" ?ᾔ)
+ ("ι´ἠ" ?ᾔ)
+ ("ι'ἠ" ?ᾔ)
+ ("ι´)η" ?ᾔ)
+ ("ι')η" ?ᾔ)
+ ("ιἥ" ?ᾕ)
+ ("ι´ἡ" ?ᾕ)
+ ("ι'ἡ" ?ᾕ)
+ ("ι´(η" ?ᾕ)
+ ("ι'(η" ?ᾕ)
+ ("ιἦ" ?ᾖ)
+ ("ι~ἠ" ?ᾖ)
+ ("ι~)η" ?ᾖ)
+ ("ιἧ" ?ᾗ)
+ ("ι~ἡ" ?ᾗ)
+ ("ι~(η" ?ᾗ)
+ ("ιἨ" ?ᾘ)
+ ("ι)Η" ?ᾘ)
+ ("ιἩ" ?ᾙ)
+ ("ι(Η" ?ᾙ)
+ ("ιἪ" ?ᾚ)
+ ("ι`Ἠ" ?ᾚ)
+ ("ι`)Η" ?ᾚ)
+ ("ιἫ" ?ᾛ)
+ ("ι`Ἡ" ?ᾛ)
+ ("ι`(Η" ?ᾛ)
+ ("ιἬ" ?ᾜ)
+ ("ι´Ἠ" ?ᾜ)
+ ("ι'Ἠ" ?ᾜ)
+ ("ι´)Η" ?ᾜ)
+ ("ι')Η" ?ᾜ)
+ ("ιἭ" ?á¾)
+ ("ι´Ἡ" ?á¾)
+ ("ι'Ἡ" ?á¾)
+ ("ι´(Η" ?á¾)
+ ("ι'(Η" ?á¾)
+ ("ιἮ" ?ᾞ)
+ ("ι~Ἠ" ?ᾞ)
+ ("ι~)Η" ?ᾞ)
+ ("ιἯ" ?ᾟ)
+ ("ι~Ἡ" ?ᾟ)
+ ("ι~(Η" ?ᾟ)
+ ("ιὠ" ?ᾠ)
+ ("ι)ω" ?ᾠ)
+ ("ιὡ" ?ᾡ)
+ ("ι(ω" ?ᾡ)
+ ("ιὢ" ?ᾢ)
+ ("ι`ὠ" ?ᾢ)
+ ("ι`)ω" ?ᾢ)
+ ("ιὣ" ?ᾣ)
+ ("ι`ὡ" ?ᾣ)
+ ("ι`(ω" ?ᾣ)
+ ("ιὤ" ?ᾤ)
+ ("ι´ὠ" ?ᾤ)
+ ("ι'ὠ" ?ᾤ)
+ ("ι´)ω" ?ᾤ)
+ ("ι')ω" ?ᾤ)
+ ("ιὥ" ?ᾥ)
+ ("ι´ὡ" ?ᾥ)
+ ("ι'ὡ" ?ᾥ)
+ ("ι´(ω" ?ᾥ)
+ ("ι'(ω" ?ᾥ)
+ ("ιὦ" ?ᾦ)
+ ("ι~ὠ" ?ᾦ)
+ ("ι~)ω" ?ᾦ)
+ ("ιὧ" ?ᾧ)
+ ("ι~ὡ" ?ᾧ)
+ ("ι~(ω" ?ᾧ)
+ ("ιὨ" ?ᾨ)
+ ("ι)Ω" ?ᾨ)
+ ("ιὩ" ?ᾩ)
+ ("ι(Ω" ?ᾩ)
+ ("ιὪ" ?ᾪ)
+ ("ι`Ὠ" ?ᾪ)
+ ("ι`)Ω" ?ᾪ)
+ ("ιὫ" ?ᾫ)
+ ("ι`Ὡ" ?ᾫ)
+ ("ι`(Ω" ?ᾫ)
+ ("ιὬ" ?ᾬ)
+ ("ι´Ὠ" ?ᾬ)
+ ("ι'Ὠ" ?ᾬ)
+ ("ι´)Ω" ?ᾬ)
+ ("ι')Ω" ?ᾬ)
+ ("ιὭ" ?ᾭ)
+ ("ι´Ὡ" ?ᾭ)
+ ("ι'Ὡ" ?ᾭ)
+ ("ι´(Ω" ?ᾭ)
+ ("ι'(Ω" ?ᾭ)
+ ("ιὮ" ?ᾮ)
+ ("ι~Ὠ" ?ᾮ)
+ ("ι~)Ω" ?ᾮ)
+ ("ιὯ" ?ᾯ)
+ ("ι~Ὡ" ?ᾯ)
+ ("ι~(Ω" ?ᾯ)
+ ("Uα" ?ᾰ)
+ ("bα" ?ᾰ)
+ ("¯α" ?ᾱ)
+ ("_α" ?ᾱ)
+ ("ιὰ" ?ᾲ)
+ ("ι`α" ?ᾲ)
+ ("ια" ?ᾳ)
+ ("ιά" ?ᾴ)
+ ("ι´α" ?ᾴ)
+ ("ι'α" ?ᾴ)
+ ("~α" ?ᾶ)
+ ("ιᾶ" ?ᾷ)
+ ("ι~α" ?ᾷ)
+ ("UΑ" ?Ᾰ)
+ ("bΑ" ?Ᾰ)
+ ("¯Α" ?Ᾱ)
+ ("_Α" ?Ᾱ)
+ ("`Α" ?Ὰ)
+ ("ιΑ" ?ᾼ)
+ ("¨~" ?á¿)
+ ("ιὴ" ?ῂ)
+ ("ι`η" ?ῂ)
+ ("ιη" ?ῃ)
+ ("ιή" ?ῄ)
+ ("ι´η" ?ῄ)
+ ("ι'η" ?ῄ)
+ ("~η" ?ῆ)
+ ("ιῆ" ?ῇ)
+ ("ι~η" ?ῇ)
+ ("`Ε" ?Ὲ)
+ ("`Η" ?Ὴ)
+ ("ιΗ" ?ῌ)
+ ("᾿`" ?á¿)
+ ("᾿´" ?῎)
+ ("᾿'" ?῎)
+ ("᾿~" ?á¿)
+ ("Uι" ?á¿)
+ ("bι" ?á¿)
+ ("¯ι" ?ῑ)
+ ("_ι" ?ῑ)
+ ("`ÏŠ" ?á¿’)
+ ("`\"ι" ?ῒ)
+ ("~ι" ?ῖ)
+ ("~ÏŠ" ?á¿—)
+ ("~\"ι" ?ῗ)
+ ("UΙ" ?Ῐ)
+ ("bΙ" ?Ῐ)
+ ("¯Ι" ?Ῑ)
+ ("_Ι" ?Ῑ)
+ ("`Ι" ?Ὶ)
+ ("῾`" ?á¿)
+ ("῾´" ?῞)
+ ("῾'" ?῞)
+ ("῾~" ?῟)
+ ("UÏ…" ?á¿ )
+ ("bÏ…" ?á¿ )
+ ("¯υ" ?ῡ)
+ ("_Ï…" ?á¿¡)
+ ("`Ï‹" ?á¿¢)
+ ("`\"Ï…" ?á¿¢)
+ (")Ï" ?ῤ)
+ ("(Ï" ?á¿¥)
+ ("~υ" ?ῦ)
+ ("~Ï‹" ?á¿§)
+ ("~\"Ï…" ?á¿§)
+ ("UΥ" ?Ῠ)
+ ("bΥ" ?Ῠ)
+ ("¯Υ" ?Ῡ)
+ ("_Î¥" ?á¿©)
+ ("`Υ" ?Ὺ)
+ ("(Ρ" ?Ῥ)
+ ("¨`" ?῭)
+ ("ιὼ" ?ῲ)
+ ("ι`ω" ?ῲ)
+ ("ιω" ?ῳ)
+ ("ιώ" ?ῴ)
+ ("ι´ω" ?ῴ)
+ ("ι'ω" ?ῴ)
+ ("~ω" ?ῶ)
+ ("ιῶ" ?ῷ)
+ ("ι~ω" ?ῷ)
+ ("`Ο" ?Ὸ)
+ ("`Ω" ?Ὼ)
+ ("ιΩ" ?ῼ)
+ ("^0" ?â°)
+ ("^_i" ?â±)
+ ("^_i" ?â±)
+ ("^4" ?â´)
+ ("^5" ?âµ)
+ ("^6" ?â¶)
+ ("^7" ?â·)
+ ("^8" ?â¸)
+ ("^9" ?â¹)
+ ("^+" ?âº)
+ ("^−" ?â»)
+ ("^=" ?â¼)
+ ("^(" ?â½)
+ ("^)" ?â¾)
+ ("^_n" ?â¿)
+ ("^_n" ?â¿)
+ ("_0" ?â‚€)
+ ("_0" ?â‚€)
+ ("_1" ?â‚)
+ ("_1" ?â‚)
+ ("_2" ?â‚‚)
+ ("_2" ?â‚‚)
+ ("_3" ?₃)
+ ("_3" ?₃)
+ ("_4" ?â‚„)
+ ("_4" ?â‚„)
+ ("_5" ?â‚…)
+ ("_5" ?â‚…)
+ ("_6" ?₆)
+ ("_6" ?₆)
+ ("_7" ?₇)
+ ("_7" ?₇)
+ ("_8" ?₈)
+ ("_8" ?₈)
+ ("_9" ?₉)
+ ("_9" ?₉)
+ ("_+" ?₊)
+ ("_+" ?₊)
+ ("_−" ?₋)
+ ("_−" ?₋)
+ ("_=" ?₌)
+ ("_=" ?₌)
+ ("_(" ?â‚)
+ ("_(" ?â‚)
+ ("_)" ?₎)
+ ("_)" ?₎)
+ ("SM" ?â„ )
+ ("sM" ?â„ )
+ ("Sm" ?â„ )
+ ("sm" ?â„ )
+ ("TM" ?â„¢)
+ ("tM" ?â„¢)
+ ("Tm" ?â„¢)
+ ("tm" ?â„¢)
+ ("17" ?â…)
+ ("19" ?â…‘)
+ ("110" ?â…’)
+ ("13" ?â…“)
+ ("23" ?â…”)
+ ("15" ?â…•)
+ ("25" ?â…–)
+ ("35" ?â…—)
+ ("45" ?â…˜)
+ ("16" ?â…™)
+ ("56" ?â…š)
+ ("18" ?â…›)
+ ("38" ?⅜)
+ ("58" ?â…)
+ ("78" ?â…ž)
+ ("03" ?↉)
+ ("/â†" ?↚)
+ ("/→" ?↛)
+ ("/↔" ?↮)
+ ("<-" ?â†)
+ ("->" ?→)
+ ("=>" ?⇒)
+ ("∄" ?∄)
+ ("{}" ?∅)
+ ("∉" ?∉)
+ ("∌" ?∌)
+ ("∤" ?∤)
+ ("∦" ?∦)
+ ("≁" ?â‰)
+ ("≄" ?≄)
+ ("≁" ?≇)
+ ("≉" ?≉)
+ ("/=" ?≠)
+ ("=/" ?≠)
+ ("≠" ?≠)
+ ("≢" ?≢)
+ ("<=" ?≤)
+ (">=" ?≥)
+ ("â‰Ì¸" ?≭)
+ ("≮" ?≮)
+ ("≮" ?≮)
+ ("≯" ?≯)
+ ("≯" ?≯)
+ ("≰" ?≰)
+ ("≱" ?≱)
+ ("≴" ?≴)
+ ("≵" ?≵)
+ ("≸" ?≸)
+ ("≹" ?≹)
+ ("⊀" ?⊀)
+ ("⊁" ?âŠ)
+ ("⊄" ?⊄)
+ ("⊄" ?⊄)
+ ("⊅" ?⊅)
+ ("⊅" ?⊅)
+ ("⊈" ?⊈)
+ ("⊉" ?⊉)
+ ("⊬" ?⊬)
+ ("⊭" ?⊭)
+ ("⊮" ?⊮)
+ ("⊯" ?⊯)
+ ("⋠" ?⋠)
+ ("⋡" ?⋡)
+ ("⋢" ?⋢)
+ ("⋣" ?⋣)
+ ("⋪" ?⋪)
+ ("⋫" ?⋫)
+ ("⋬" ?⋬)
+ ("⋭" ?⋭)
+ ("di" ?⌀)
+ ("(1)" ?â‘ )
+ ("(2)" ?â‘¡)
+ ("(3)" ?â‘¢)
+ ("(4)" ?â‘£)
+ ("(5)" ?⑤)
+ ("(6)" ?â‘¥)
+ ("(7)" ?⑦)
+ ("(8)" ?â‘§)
+ ("(9)" ?⑨)
+ ("(10)" ?â‘©)
+ ("(11)" ?⑪)
+ ("(12)" ?â‘«)
+ ("(13)" ?⑬)
+ ("(14)" ?â‘­)
+ ("(15)" ?â‘®)
+ ("(16)" ?⑯)
+ ("(17)" ?â‘°)
+ ("(18)" ?⑱)
+ ("(19)" ?⑲)
+ ("(20)" ?⑳)
+ ("(A)" ?â’¶)
+ ("(B)" ?â’·)
+ ("(C)" ?â’¸)
+ ("(D)" ?â’¹)
+ ("(E)" ?â’º)
+ ("(F)" ?â’»)
+ ("(G)" ?â’¼)
+ ("(H)" ?â’½)
+ ("(I)" ?â’¾)
+ ("(J)" ?â’¿)
+ ("(K)" ?â“€)
+ ("(L)" ?â“)
+ ("(M)" ?â“‚)
+ ("(N)" ?Ⓝ)
+ ("(O)" ?â“„)
+ ("(P)" ?â“…)
+ ("(Q)" ?Ⓠ)
+ ("(R)" ?Ⓡ)
+ ("(S)" ?Ⓢ)
+ ("(T)" ?Ⓣ)
+ ("(U)" ?Ⓤ)
+ ("(V)" ?â“‹)
+ ("(W)" ?Ⓦ)
+ ("(X)" ?â“)
+ ("(Y)" ?Ⓨ)
+ ("(Z)" ?â“)
+ ("(a)" ?â“)
+ ("(b)" ?â“‘)
+ ("(c)" ?â“’)
+ ("(d)" ?â““)
+ ("(e)" ?â“”)
+ ("(f)" ?â“•)
+ ("(g)" ?â“–)
+ ("(h)" ?â“—)
+ ("(i)" ?ⓘ)
+ ("(j)" ?â“™)
+ ("(k)" ?ⓚ)
+ ("(l)" ?â“›)
+ ("(m)" ?ⓜ)
+ ("(n)" ?â“)
+ ("(o)" ?ⓞ)
+ ("(p)" ?ⓟ)
+ ("(q)" ?â“ )
+ ("(r)" ?â“¡)
+ ("(s)" ?â“¢)
+ ("(t)" ?â“£)
+ ("(u)" ?ⓤ)
+ ("(v)" ?â“¥)
+ ("(w)" ?ⓦ)
+ ("(x)" ?â“§)
+ ("(y)" ?ⓨ)
+ ("(z)" ?â“©)
+ ("(0)" ?⓪)
+ ("â«Ì¸" ?⫝̸)
+ ("^一" ?㆒)
+ ("^二" ?㆓)
+ ("^三" ?㆔)
+ ("^四" ?㆕)
+ ("^上" ?㆖)
+ ("^中" ?㆗)
+ ("^下" ?㆘)
+ ("^甲" ?㆙)
+ ("^乙" ?㆚)
+ ("^丙" ?㆛)
+ ("^ä¸" ?㆜)
+ ("^天" ?ã†)
+ ("^地" ?㆞)
+ ("^人" ?㆟)
+ ("(21)" ?㉑)
+ ("(22)" ?㉒)
+ ("(23)" ?㉓)
+ ("(24)" ?㉔)
+ ("(25)" ?㉕)
+ ("(26)" ?㉖)
+ ("(27)" ?㉗)
+ ("(28)" ?㉘)
+ ("(29)" ?㉙)
+ ("(30)" ?㉚)
+ ("(31)" ?㉛)
+ ("(32)" ?㉜)
+ ("(33)" ?ã‰)
+ ("(34)" ?㉞)
+ ("(35)" ?㉟)
+ ("(ᄀ)" ?㉠)
+ ("(ᄂ)" ?㉡)
+ ("(ᄃ)" ?㉢)
+ ("(ᄅ)" ?㉣)
+ ("(ᄆ)" ?㉤)
+ ("(ᄇ)" ?㉥)
+ ("(ᄉ)" ?㉦)
+ ("(ᄋ)" ?㉧)
+ ("(ᄌ)" ?㉨)
+ ("(ᄎ)" ?㉩)
+ ("(á„)" ?㉪)
+ ("(á„)" ?㉫)
+ ("(ᄑ)" ?㉬)
+ ("(ᄒ)" ?㉭)
+ ("(가)" ?㉮)
+ ("(나)" ?㉯)
+ ("(다)" ?㉰)
+ ("(라)" ?㉱)
+ ("(마)" ?㉲)
+ ("(바)" ?㉳)
+ ("(사)" ?㉴)
+ ("(아)" ?㉵)
+ ("(자)" ?㉶)
+ ("(차)" ?㉷)
+ ("(á„á…¡)" ?㉸)
+ ("(á„á…¡)" ?㉹)
+ ("(파)" ?㉺)
+ ("(하)" ?㉻)
+ ("(一)" ?㊀)
+ ("(二)" ?ãŠ)
+ ("(三)" ?㊂)
+ ("(四)" ?㊃)
+ ("(五)" ?㊄)
+ ("(六)" ?㊅)
+ ("(七)" ?㊆)
+ ("(八)" ?㊇)
+ ("(ä¹)" ?㊈)
+ ("(å)" ?㊉)
+ ("(月)" ?㊊)
+ ("(ç«)" ?㊋)
+ ("(水)" ?㊌)
+ ("(木)" ?ãŠ)
+ ("(金)" ?㊎)
+ ("(土)" ?ãŠ)
+ ("(æ—¥)" ?ãŠ)
+ ("(株)" ?㊑)
+ ("(有)" ?㊒)
+ ("(社)" ?㊓)
+ ("(å)" ?㊔)
+ ("(特)" ?㊕)
+ ("(財)" ?㊖)
+ ("(ç¥)" ?㊗)
+ ("(労)" ?㊘)
+ ("(秘)" ?㊙)
+ ("(男)" ?㊚)
+ ("(女)" ?㊛)
+ ("(é©)" ?㊜)
+ ("(優)" ?ãŠ)
+ ("(å°)" ?㊞)
+ ("(注)" ?㊟)
+ ("(項)" ?㊠)
+ ("(休)" ?㊡)
+ ("(写)" ?㊢)
+ ("(正)" ?㊣)
+ ("(上)" ?㊤)
+ ("(中)" ?㊥)
+ ("(下)" ?㊦)
+ ("(左)" ?㊧)
+ ("(å³)" ?㊨)
+ ("(医)" ?㊩)
+ ("(宗)" ?㊪)
+ ("(学)" ?㊫)
+ ("(監)" ?㊬)
+ ("(ä¼)" ?㊭)
+ ("(資)" ?㊮)
+ ("(å”)" ?㊯)
+ ("(夜)" ?㊰)
+ ("(36)" ?㊱)
+ ("(37)" ?㊲)
+ ("(38)" ?㊳)
+ ("(39)" ?㊴)
+ ("(40)" ?㊵)
+ ("(41)" ?㊶)
+ ("(42)" ?㊷)
+ ("(43)" ?㊸)
+ ("(44)" ?㊹)
+ ("(45)" ?㊺)
+ ("(46)" ?㊻)
+ ("(47)" ?㊼)
+ ("(48)" ?㊽)
+ ("(49)" ?㊾)
+ ("(50)" ?㊿)
+ ("(ã‚¢)" ?ã‹)
+ ("(イ)" ?㋑)
+ ("(ウ)" ?㋒)
+ ("(エ)" ?㋓)
+ ("(オ)" ?㋔)
+ ("(ã‚«)" ?ã‹•)
+ ("(ã‚­)" ?ã‹–)
+ ("(ク)" ?㋗)
+ ("(ケ)" ?㋘)
+ ("(コ)" ?㋙)
+ ("(サ)" ?㋚)
+ ("(ã‚·)" ?ã‹›)
+ ("(ス)" ?㋜)
+ ("(ã‚»)" ?ã‹)
+ ("(ソ)" ?㋞)
+ ("(タ)" ?㋟)
+ ("(ãƒ)" ?ã‹ )
+ ("(ツ)" ?㋡)
+ ("(テ)" ?㋢)
+ ("(ト)" ?㋣)
+ ("(ナ)" ?㋤)
+ ("(ニ)" ?㋥)
+ ("(ヌ)" ?㋦)
+ ("(ãƒ)" ?ã‹§)
+ ("(ノ)" ?㋨)
+ ("(ãƒ)" ?ã‹©)
+ ("(ヒ)" ?㋪)
+ ("(フ)" ?㋫)
+ ("(ヘ)" ?㋬)
+ ("(ホ)" ?㋭)
+ ("(マ)" ?㋮)
+ ("(ミ)" ?㋯)
+ ("(ム)" ?㋰)
+ ("(メ)" ?㋱)
+ ("(モ)" ?㋲)
+ ("(ヤ)" ?㋳)
+ ("(ユ)" ?㋴)
+ ("(ヨ)" ?㋵)
+ ("(ラ)" ?㋶)
+ ("(リ)" ?㋷)
+ ("(ル)" ?㋸)
+ ("(レ)" ?㋹)
+ ("(ロ)" ?㋺)
+ ("(ワ)" ?㋻)
+ ("(ヰ)" ?㋼)
+ ("(ヱ)" ?㋽)
+ ("(ヲ)" ?㋾)
+ ("Ö´×™" ?ï¬)
+ ("ַײ" ?ײַ)
+ ("×ש" ?שׁ)
+ ("ׂש" ?שׂ)
+ ("×ï­‰" ?שּׁ)
+ ("×ּש" ?שּׁ)
+ ("ׂשּ" ?שּׂ)
+ ("ּׂש" ?שּׂ)
+ ("Ö·×" ?אַ)
+ ("Ö¸×" ?אָ)
+ ("Ö¼×" ?אּ)
+ ("ּב" ?בּ)
+ ("ּג" ?גּ)
+ ("ּד" ?דּ)
+ ("ּה" ?הּ)
+ ("ּו" ?וּ)
+ ("ּז" ?זּ)
+ ("ּט" ?טּ)
+ ("ּי" ?יּ)
+ ("ּך" ?ךּ)
+ ("ּכ" ?כּ)
+ ("ּל" ?לּ)
+ ("ּמ" ?מּ)
+ ("Ö¼× " ?ï­€)
+ ("ּס" ?ï­)
+ ("Ö¼×£" ?ï­ƒ)
+ ("ּפ" ?פּ)
+ ("ּצ" ?צּ)
+ ("Ö¼×§" ?ï­‡)
+ ("ּר" ?רּ)
+ ("ּש" ?שּ)
+ ("ּת" ?תּ)
+ ("ֹו" ?וֹ)
+ ("ֿב" ?בֿ)
+ ("Ö¿×›" ?ï­)
+ ("ֿפ" ?פֿ)
+ ("ð…—ð…¥" ?ð…ž)
+ ("ð…˜ð…¥" ?ð…Ÿ)
+ ("ð…Ÿð…®" ?ð… )
+ ("ð…Ÿð…¯" ?ð…¡)
+ ("ð…Ÿð…°" ?ð…¢)
+ ("ð…Ÿð…±" ?ð…£)
+ ("ð…Ÿð…²" ?ð…¤)
+ ("ð†¹ð…¥" ?ð†»)
+ ("ð†ºð…¥" ?ð†¼)
+ ("ð†»ð…®" ?ð†½)
+ ("ð†¼ð…®" ?ð†¾)
+ ("ð†»ð…¯" ?ð†¿)
+ ("ð†¼ð…¯" ?ð‡€)
+ (";S" ?Ș)
+ ("S;" ?Ș)
+ (";s" ?È™)
+ ("s;" ?È™)
+ (";T" ?Èš)
+ ("T;" ?Èš)
+ (";t" ?È›)
+ ("t;" ?È›)
+ ("``а" ["аÌ"])
+ ("`а" ["а̀"])
+ ("´а" ["аÌ"])
+ ("'а" ["аÌ"])
+ ("¯а" ["а̄"])
+ ("_а" ["а̄"])
+ ("^а" ["а̂"])
+ ("``Ð" ["ÐÌ"])
+ ("`Ð" ["ÐÌ€"])
+ ("´Ð" ["ÐÌ"])
+ ("'Ð" ["ÐÌ"])
+ ("¯Ð" ["ÐÌ„"])
+ ("_Ð" ["ÐÌ„"])
+ ("^Ð" ["ÐÌ‚"])
+ ("``е" ["еÌ"])
+ ("´е" ["еÌ"])
+ ("'е" ["еÌ"])
+ ("¯е" ["е̄"])
+ ("_е" ["е̄"])
+ ("^е" ["е̂"])
+ ("``Е" ["ЕÌ"])
+ ("´Е" ["ЕÌ"])
+ ("'Е" ["ЕÌ"])
+ ("¯Е" ["Е̄"])
+ ("_Е" ["Е̄"])
+ ("^Е" ["Е̂"])
+ ("``и" ["иÌ"])
+ ("´и" ["иÌ"])
+ ("'и" ["иÌ"])
+ ("^и" ["и̂"])
+ ("``И" ["ИÌ"])
+ ("´И" ["ИÌ"])
+ ("'И" ["ИÌ"])
+ ("^И" ["И̂"])
+ ("``о" ["оÌ"])
+ ("`о" ["о̀"])
+ ("´о" ["оÌ"])
+ ("'о" ["оÌ"])
+ ("¯о" ["о̄"])
+ ("_о" ["о̄"])
+ ("^о" ["о̂"])
+ ("``О" ["ОÌ"])
+ ("`О" ["О̀"])
+ ("´О" ["ОÌ"])
+ ("'О" ["ОÌ"])
+ ("¯О" ["О̄"])
+ ("_О" ["О̄"])
+ ("^О" ["О̂"])
+ ("``у" ["уÌ"])
+ ("`у" ["у̀"])
+ ("´у" ["уÌ"])
+ ("'у" ["уÌ"])
+ ("^у" ["у̂"])
+ ("``У" ["УÌ"])
+ ("`У" ["У̀"])
+ ("´У" ["УÌ"])
+ ("'У" ["УÌ"])
+ ("^У" ["У̂"])
+ ("``Ñ€" ["Ñ€Ì"])
+ ("`р" ["р̀"])
+ ("´р" ["Ñ€Ì"])
+ ("'Ñ€" ["Ñ€Ì"])
+ ("¯р" ["р̄"])
+ ("_р" ["р̄"])
+ ("^р" ["р̂"])
+ ("``Р" ["РÌ"])
+ ("`Р" ["Р̀"])
+ ("´Р" ["РÌ"])
+ ("'Р" ["РÌ"])
+ ("¯Р" ["Р̄"])
+ ("_Р" ["Р̄"])
+ ("^Р" ["Р̂"])
+ ("v/" ?√)
+ ("/v" ?√)
+ ("88" ?∞)
+ ("=_" ?≡)
+ ("_≠" ?≢)
+ ("≠_" ?≢)
+ ("<_" ?≤)
+ ("_<" ?≤)
+ (">_" ?≥)
+ ("_>" ?≥)
+ ("_⊂" ?⊆)
+ ("⊂_" ?⊆)
+ ("_⊃" ?⊇)
+ ("⊃_" ?⊇)
+ ("○-" ?⊖)
+ ("-○" ?⊖)
+ ("○." ?⊙)
+ (".○" ?⊙)
+ ("<>" ?â‹„)
+ ("><" ?â‹„)
+ ("∧∨" ?⋄)
+ ("∨∧" ?⋄)
+ (":." ?∴)
+ (".:" ?∵)
+ ("⊥⊤" ?⌶)
+ ("⊤⊥" ?⌶)
+ ("[]" ?⌷)
+ ("][" ?⌷)
+ ("⎕=" ?⌸)
+ ("=⎕" ?⌸)
+ ("⎕÷" ?⌹)
+ ("÷⎕" ?⌹)
+ ("⎕⋄" ?⌺)
+ ("⋄⎕" ?⌺)
+ ("⎕∘" ?⌻)
+ ("∘⎕" ?⌻)
+ ("⎕○" ?⌼)
+ ("○⎕" ?⌼)
+ ("○|" ?⌽)
+ ("|○" ?⌽)
+ ("○∘" ?⌾)
+ ("∘○" ?⌾)
+ ("/-" ?⌿)
+ ("-/" ?⌿)
+ ("\\-" ?â€)
+ ("-\\" ?â€)
+ ("/⎕" ?â)
+ ("⎕/" ?â)
+ ("\\⎕" ?â‚)
+ ("⎕\\" ?â‚)
+ ("<⎕" ?âƒ)
+ ("⎕<" ?âƒ)
+ (">⎕" ?â„)
+ ("⎕>" ?â„)
+ ("â†|" ?â…)
+ ("|â†" ?â…)
+ ("→|" ?â†)
+ ("|→" ?â†)
+ ("â†âŽ•" ?â‡)
+ ("⎕â†" ?â‡)
+ ("→⎕" ?âˆ)
+ ("⎕→" ?âˆ)
+ ("â—‹\\" ?â‰)
+ ("\\â—‹" ?â‰)
+ ("_⊥" ?âŠ)
+ ("⊥_" ?âŠ)
+ ("∆|" ?â‹)
+ ("|∆" ?â‹)
+ ("∨⎕" ?âŒ)
+ ("⎕∨" ?âŒ)
+ ("∆⎕" ?â)
+ ("⎕∆" ?â)
+ ("∘⊥" ?âŽ)
+ ("⊥∘" ?âŽ)
+ ("↑-" ?â)
+ ("-↑" ?â)
+ ("↑⎕" ?â)
+ ("⎕↑" ?â)
+ ("¯⊤" ?â‘)
+ ("⊤¯" ?â‘)
+ ("∇|" ?â’)
+ ("|∇" ?â’)
+ ("∧⎕" ?â“)
+ ("⎕∧" ?â“)
+ ("∇⎕" ?â”)
+ ("⎕∇" ?â”)
+ ("∘⊤" ?â•)
+ ("⊤∘" ?â•)
+ ("↓-" ?â–)
+ ("-↓" ?â–)
+ ("↓⎕" ?â—)
+ ("⎕↓" ?â—)
+ ("_'" ?â˜)
+ ("∆_" ?â™)
+ ("_∆" ?â™)
+ ("â‹„_" ?âš)
+ ("_â‹„" ?âš)
+ ("∘_" ?â›)
+ ("_∘" ?â›)
+ ("â—‹_" ?âœ)
+ ("_â—‹" ?âœ)
+ ("∘∩" ?â)
+ ("∩∘" ?â)
+ ("⎕'" ?âž)
+ ("'⎕" ?âž)
+ ("â—‹*" ?âŸ)
+ ("*â—‹" ?âŸ)
+ (":⎕" ?â )
+ ("⎕:" ?â )
+ ("¨⊤" ?â¡)
+ ("⊤¨" ?â¡)
+ ("¨∇" ?â¢)
+ ("∇¨" ?â¢)
+ ("*¨" ?â£)
+ ("¨*" ?â£)
+ ("∘¨" ?â¤)
+ ("¨∘" ?â¤)
+ ("○¨" ?â¥)
+ ("¨○" ?â¥)
+ ("∪|" ?â¦)
+ ("|∪" ?â¦)
+ ("⊂|" ?â§)
+ ("|⊂" ?â§)
+ ("~¨" ?â¨)
+ ("¨>" ?â©)
+ (">¨" ?â©)
+ ("∇~" ?â«)
+ ("~∇" ?â«)
+ ("0~" ?â¬)
+ ("~0" ?â¬)
+ ("|~" ?â­)
+ ("~|" ?â­)
+ (";_" ?â®)
+ ("≠⎕" ?â¯)
+ ("⎕≠" ?â¯)
+ ("?⎕" ?â°)
+ ("⎕?" ?â°)
+ ("∨~" ?â±)
+ ("~∨" ?â±)
+ ("∧~" ?â²)
+ ("~∧" ?â²)
+ ("âº_" ?â¶)
+ ("_âº" ?â¶)
+ ("∊_" ?â·)
+ ("_∊" ?â·)
+ ("â³_" ?â¸)
+ ("_â³" ?â¸)
+ ("âµ_" ?â¹)
+ ("_âµ" ?â¹)
+ )
+
+;; Quail package `iso-transl' is based on `C-x 8' key sequences.
+;; This input method supports the same key sequences as defined
+;; by the `C-x 8' keymap in iso-transl.el.
+
+(quail-define-package
+ "iso-transl" "UTF-8" "X8" t
+ "Use the same key sequences as in `C-x 8' keymap defined in iso-transl.el.
+Examples:
+ * E -> € 1 / 2 -> ½ ^ 3 -> ³"
+ '(("\t" . quail-completion))
+ t nil nil nil nil nil nil nil nil t)
+
+(eval-when-compile
+ (require 'iso-transl)
+ (defmacro iso-transl--define-rules ()
+ `(quail-define-rules
+ ,@(mapcar (lambda (rule)
+ (let ((from (car rule))
+ (to (cdr rule)))
+ (list from (if (stringp to)
+ (vector to)
+ to))))
+ iso-transl-char-map))))
+
+(iso-transl--define-rules)
+
+(provide 'compose)
+;;; compose.el ends here
diff --git a/lisp/leim/quail/croatian.el b/lisp/leim/quail/croatian.el
index ae6b97577ff..7402b81a8cc 100644
--- a/lisp/leim/quail/croatian.el
+++ b/lisp/leim/quail/croatian.el
@@ -1,4 +1,4 @@
-;;; croatian.el -- Quail package for inputting Croatian -*-coding: utf-8;-*-
+;;; croatian.el --- Quail package for inputting Croatian -*-coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/cyril-jis.el b/lisp/leim/quail/cyril-jis.el
index e796273ca85..689f738f5ee 100644
--- a/lisp/leim/quail/cyril-jis.el
+++ b/lisp/leim/quail/cyril-jis.el
@@ -1,4 +1,4 @@
-;;; cyril-jis.el --- Quail package for inputting JISX0208 Cyrillic letters
+;;; cyril-jis.el --- Quail package for inputting JISX0208 Cyrillic letters -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/cyrillic.el b/lisp/leim/quail/cyrillic.el
index 0d4a3efc304..3654aca192c 100644
--- a/lisp/leim/quail/cyrillic.el
+++ b/lisp/leim/quail/cyrillic.el
@@ -1,4 +1,4 @@
-;;; cyrillic.el --- Quail package for inputting Cyrillic characters
+;;; cyrillic.el --- Quail package for inputting Cyrillic characters -*- lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/czech.el b/lisp/leim/quail/czech.el
index 63497c1196a..78b50117225 100644
--- a/lisp/leim/quail/czech.el
+++ b/lisp/leim/quail/czech.el
@@ -1,4 +1,4 @@
-;;; czech.el --- Quail package for inputting Czech -*-coding: utf-8;-*-
+;;; czech.el --- Quail package for inputting Czech -*-coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/ethiopic.el b/lisp/leim/quail/ethiopic.el
index 8d19a233709..c8753effe0a 100644
--- a/lisp/leim/quail/ethiopic.el
+++ b/lisp/leim/quail/ethiopic.el
@@ -1,4 +1,4 @@
-;;; ethiopic.el --- Quail package for inputting Ethiopic characters -*-coding: utf-8-emacs;-*-
+;;; ethiopic.el --- Quail package for inputting Ethiopic characters -*-coding: utf-8-emacs; lexical-binding:t -*-
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/georgian.el b/lisp/leim/quail/georgian.el
index c71f2ceae24..2389d8138ae 100644
--- a/lisp/leim/quail/georgian.el
+++ b/lisp/leim/quail/georgian.el
@@ -1,4 +1,4 @@
-;;; georgian.el --- Quail package for inputting Georgian characters -*-coding: utf-8;-*-
+;;; georgian.el --- Quail package for inputting Georgian characters -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/greek.el b/lisp/leim/quail/greek.el
index 19b0ad3da7e..89ebd447471 100644
--- a/lisp/leim/quail/greek.el
+++ b/lisp/leim/quail/greek.el
@@ -1,4 +1,4 @@
-;;; greek.el --- Quail package for inputting Greek -*-coding: utf-8-*-
+;;; greek.el --- Quail package for inputting Greek -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el
index 22ca27e4f00..c03e86b33c0 100644
--- a/lisp/leim/quail/hangul.el
+++ b/lisp/leim/quail/hangul.el
@@ -1,4 +1,4 @@
-;;; hangul.el --- Korean Hangul input method
+;;; hangul.el --- Korean Hangul input method -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -88,9 +88,9 @@
(defvar hangul-im-keymap
(let ((map (make-sparse-keymap)))
- (define-key map "\d" 'hangul-delete-backward-char)
- (define-key map [f9] 'hangul-to-hanja-conversion)
- (define-key map [Hangul_Hanja] 'hangul-to-hanja-conversion)
+ (define-key map "\d" #'hangul-delete-backward-char)
+ (define-key map [f9] #'hangul-to-hanja-conversion)
+ (define-key map [Hangul_Hanja] #'hangul-to-hanja-conversion)
map)
"Keymap for Hangul method. It is used by all Hangul input methods.")
@@ -337,7 +337,7 @@ Other parts are the same as a `hangul3-input-method-cho'."
char)))))
(aset hangul-queue 5 char)))
(hangul-insert-character hangul-queue)
- (if (zerop (apply '+ (append hangul-queue nil)))
+ (if (zerop (apply #'+ (append hangul-queue nil)))
(hangul-insert-character (setq hangul-queue (vector 0 0 0 0 char 0)))
(hangul-insert-character hangul-queue
(setq hangul-queue (vector 0 0 0 0 char 0))))))
@@ -349,7 +349,7 @@ Other parts are the same as a `hangul3-input-method-cho'."
(while (and (> i 0) (zerop (aref hangul-queue i)))
(setq i (1- i)))
(aset hangul-queue i 0))
- (if (notzerop (apply '+ (append hangul-queue nil)))
+ (if (notzerop (apply #'+ (append hangul-queue nil)))
(hangul-insert-character hangul-queue)
(delete-char -1)))
@@ -511,21 +511,20 @@ When a Korean input method is off, convert the following hangul character."
;; Text shown by describe-input-method. Set to a proper text by
;; hangul-input-method-activate.
-(defvar hangul-input-method-help-text nil)
-(make-variable-buffer-local 'hangul-input-method-help-text)
+(defvar-local hangul-input-method-help-text nil)
;;;###autoload
-(defun hangul-input-method-activate (input-method func help-text &rest args)
+(defun hangul-input-method-activate (_input-method func help-text &rest _args)
"Activate Hangul input method INPUT-METHOD.
FUNC is a function to handle input key.
HELP-TEXT is a text set in `hangul-input-method-help-text'."
- (setq deactivate-current-input-method-function 'hangul-input-method-deactivate
- describe-current-input-method-function 'hangul-input-method-help
+ (setq deactivate-current-input-method-function #'hangul-input-method-deactivate
+ describe-current-input-method-function #'hangul-input-method-help
hangul-input-method-help-text help-text)
(quail-delete-overlays)
(if (eq (selected-window) (minibuffer-window))
- (add-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer))
- (set (make-local-variable 'input-method-function) func))
+ (add-hook 'minibuffer-exit-hook #'quail-exit-from-minibuffer))
+ (setq-local input-method-function func))
(defun hangul-input-method-deactivate ()
"Deactivate the current Hangul input method."
@@ -539,7 +538,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'."
(define-obsolete-function-alias
'hangul-input-method-inactivate
- 'hangul-input-method-deactivate "24.3")
+ #'hangul-input-method-deactivate "24.3")
(defun hangul-input-method-help ()
"Describe the current Hangul input method."
diff --git a/lisp/leim/quail/hanja-jis.el b/lisp/leim/quail/hanja-jis.el
index 6f753259456..c4eb4b57be8 100644
--- a/lisp/leim/quail/hanja-jis.el
+++ b/lisp/leim/quail/hanja-jis.el
@@ -1,4 +1,4 @@
-;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208)
+;;; hanja-jis.el --- Quail package for inputting Korean Hanja (JISX0208) -*- lexical-binding: t -*-
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/hanja.el b/lisp/leim/quail/hanja.el
index aef30e8843a..7095bcf38ae 100644
--- a/lisp/leim/quail/hanja.el
+++ b/lisp/leim/quail/hanja.el
@@ -1,4 +1,4 @@
-;;; hanja.el --- Quail-package for Korean Hanja (KSC5601) -*-coding: utf-8;-*-
+;;; hanja.el --- Quail-package for Korean Hanja (KSC5601) -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/hanja3.el b/lisp/leim/quail/hanja3.el
index b5f9bfe808b..080ba0e0fde 100644
--- a/lisp/leim/quail/hanja3.el
+++ b/lisp/leim/quail/hanja3.el
@@ -1,4 +1,4 @@
-;;; hanja3.el --- Quail-package for Korean Hanja (KSC5601) -*-coding: utf-8;-*-
+;;; hanja3.el --- Quail-package for Korean Hanja (KSC5601) -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/hebrew.el b/lisp/leim/quail/hebrew.el
index 772da70b5ce..28b2eb34367 100644
--- a/lisp/leim/quail/hebrew.el
+++ b/lisp/leim/quail/hebrew.el
@@ -1,4 +1,4 @@
-;; hebrew.el --- Quail package for inputting Hebrew characters -*-coding: utf-8;-*-
+;;; hebrew.el --- Quail package for inputting Hebrew characters -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;; 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/indian.el b/lisp/leim/quail/indian.el
index 3fdefbf60ff..251b18c9887 100644
--- a/lisp/leim/quail/indian.el
+++ b/lisp/leim/quail/indian.el
@@ -1,4 +1,4 @@
-;;; indian.el --- Quail packages for inputting Indian
+;;; indian.el --- Quail packages for inputting Indian -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -39,7 +39,10 @@
(defun quail-define-indian-trans-package (hashtbls pkgname
lang title doc)
- (funcall 'quail-define-package pkgname lang title t doc
+ ;; This is a funcall to avoid `quail-update-leim-list-file'
+ ;; determining that this is a quail definition (it searches for
+ ;; "(quail-define-package").
+ (funcall #'quail-define-package pkgname lang title t doc
nil nil nil nil nil nil t nil)
(maphash
(lambda (key val)
@@ -117,6 +120,7 @@
indian-knd-itrans-v5-hash "kannada-itrans" "Kannada" "KndIT"
"Kannada transliteration by ITRANS method.")
+;; ITRANS not applicable to Malayalam & could be removed eventually
(if nil
(quail-define-package "malayalam-itrans" "Malayalam" "MlmIT" t "Malayalam ITRANS"))
(quail-define-indian-trans-package
@@ -199,7 +203,7 @@
(setq clm 6)
(dolist (v vowels)
- (apply 'insert (propertize "\t" 'display (list 'space :align-to clm))
+ (apply #'insert (propertize "\t" 'display (list 'space :align-to clm))
(if (nth 1 c) (list (nth 1 c) (nth 2 v)) (list "")))
(setq clm (+ clm 6))))
(insert "\n")
@@ -308,7 +312,10 @@ Full key sequences are listed below:")
(defun quail-define-inscript-package (char-tables key-tables pkgname lang
title docstring)
- (funcall 'quail-define-package pkgname lang title nil docstring
+ ;; This is a funcall to avoid `quail-update-leim-list-file'
+ ;; determining that this is a quail definition (it searches for
+ ;; "(quail-define-package").
+ (funcall #'quail-define-package pkgname lang title nil docstring
nil nil nil t nil nil nil nil)
(let (char-table key-table char key)
(while (and char-tables key-tables)
@@ -358,24 +365,23 @@ Full key sequences are listed below:")
'(
(;; VOWELS (18)
(?D nil) (?E ?e) (?F ?f) (?R ?r) (?G ?g) (?T ?t)
- (?+ ?=) ("F]" "f]") (?! ?@) (?S ?s) (?Z ?z) (?W ?w)
- (?| ?\\) (?~ ?`) (?A ?a) (?Q ?q) ("+]" "=]") ("R]" "r]"))
+ (?= ?+) nil nil (?S ?s) (?Z ?z) (?W ?w)
+ nil (?~ ?`) (?A ?a) (?Q ?q))
(;; CONSONANTS (42)
?k ?K ?i ?I ?U ;; GRUTTALS
?\; ?: ?p ?P ?} ;; PALATALS
?' ?\" ?\[ ?{ ?C ;; CEREBRALS
- ?l ?L ?o ?O ?v ?V ;; DENTALS
+ ?l ?L ?o ?O ?v nil ;; DENTALS
?h ?H ?y ?Y ?c ;; LABIALS
- ?/ ?j ?J ?n ?N "N]" ?b ;; SEMIVOWELS
+ ?/ ?j ?J ?n ?N ?B ?b ;; SEMIVOWELS
?M ?< ?m ?u ;; SIBILANTS
- "k]" "K]" "i]" "p]" "[]" "{]" "H]" "/]" ;; NUKTAS
- ?% ?&)
+ nil nil nil nil nil nil nil nil nil) ;; NUKTAS
(;; Misc Symbols (7)
- ?X ?x ?_ ">]" ?d "X]" ?>)
+ nil ?x ?_ nil ?d)
(;; Digits
?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)
- (;; Inscripts
- ?# ?$ ?^ ?* ?\])))
+ (;; Chillus
+ "Cd" "Cd]" "vd" "vd]" "jd" "jd]" "nd" "nd]" "Nd" "Nd]")))
(defvar inscript-tml-keytable
'(
@@ -463,6 +469,9 @@ Full key sequences are listed below:")
"malayalam-inscript" "Malayalam" "MlmIS"
"Malayalam keyboard Inscript.")
+(quail-defrule "\\" ?‌)
+(quail-defrule "X" ?​)
+
(if nil
(quail-define-package "tamil-inscript" "Tamil" "TmlIS" t "Tamil keyboard Inscript"))
(quail-define-inscript-package
@@ -571,4 +580,72 @@ Full key sequences are listed below:")
("?" ?\?)
("/" ?à§))
+(defun indian-mlm-mozhi-update-translation (control-flag)
+ (let ((len (length quail-current-key)) chillu
+ (vowels '(?a ?e ?i ?o ?u ?A ?E ?I ?O ?U ?R)))
+ (cond ((numberp control-flag)
+ (progn (if (= control-flag 0)
+ (setq quail-current-str quail-current-key)
+ (cond (input-method-exit-on-first-char)
+ ((and (memq (aref quail-current-key
+ (1- control-flag))
+ vowels)
+ (setq chillu (cl-position
+ (aref quail-current-key
+ control-flag)
+ '(?m ?N ?n ?r ?l ?L))))
+ ;; conditions for putting chillu
+ (and (or (and (= control-flag (1- len))
+ (not (setq control-flag nil)))
+ (and (= control-flag (- len 2))
+ (let ((temp (aref quail-current-key
+ (1- len))))
+ ;; is it last char of word?
+ (not
+ (or (and (>= temp ?a) (<= temp ?z))
+ (and (>= temp ?A) (<= temp ?Z))
+ (eq temp ?~))))
+ (setq control-flag (1+ control-flag))))
+ (setq quail-current-str ;; put chillu
+ (concat (if (not (stringp
+ quail-current-str))
+ (string quail-current-str)
+ quail-current-str)
+ (string
+ (nth chillu '(?ം ?ൺ ?ൻ ?ർ ?ൽ ?ൾ)))))))))
+ (and (not input-method-exit-on-first-char) control-flag
+ (while (> len control-flag)
+ (setq len (1- len))
+ (setq unread-command-events
+ (cons (aref quail-current-key len)
+ unread-command-events))))
+ ))
+ ((null control-flag)
+ (unless quail-current-str
+ (setq quail-current-str quail-current-key)
+ ))
+ ((equal control-flag t)
+ (if (memq (aref quail-current-key (1- len)) ;; If vowel ending,
+ vowels) ;; may have to put
+ (setq control-flag nil))))) ;; chillu. So don't
+ control-flag) ;; end translation
+
+(quail-define-package "malayalam-mozhi" "Malayalam" "MlmMI" t
+ "Malayalam transliteration by Mozhi method."
+ nil nil t nil nil nil t nil
+ #'indian-mlm-mozhi-update-translation)
+
+(maphash
+ (lambda (key val)
+ (quail-defrule key (if (= (length val) 1)
+ (string-to-char val)
+ (vector val))))
+ (cdr indian-mlm-mozhi-hash))
+
+(defun indian-mlm-mozhi-underscore (_key _len) (throw 'quail-tag nil))
+
+(quail-defrule "_" #'indian-mlm-mozhi-underscore)
+(quail-defrule "|" ?‌)
+(quail-defrule "||" ?​)
+
;;; indian.el ends here
diff --git a/lisp/leim/quail/ipa-praat.el b/lisp/leim/quail/ipa-praat.el
index 4d862f1688a..1a95395fd74 100644
--- a/lisp/leim/quail/ipa-praat.el
+++ b/lisp/leim/quail/ipa-praat.el
@@ -1,4 +1,4 @@
-;;; ipa-praat.el --- Inputting IPA characters with the conventions of Praat
+;;; ipa-praat.el --- Inputting IPA characters with the conventions of Praat -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
@@ -35,7 +35,7 @@
"ipa-praat" "IPA" "IPAP" t
"International Phonetic Alphabet input method.
This follows the input method of the phonetic analysis program
-Praat (http://www.fon.hum.uva.nl/praat/).
+Praat (https://www.fon.hum.uva.nl/praat/).
* Vowels
diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el
index 9b4d0e028ad..c25687574ed 100644
--- a/lisp/leim/quail/ipa.el
+++ b/lisp/leim/quail/ipa.el
@@ -1,4 +1,4 @@
-;;; ipa.el --- Quail package for inputting IPA characters -*-coding: utf-8;-*-
+;;; ipa.el --- Quail package for inputting IPA characters -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -276,7 +276,7 @@ string."
(cl-assert (vectorp quail-keymap) t)
(setq quail-keymap (append quail-keymap nil))))
(list
- (apply 'vector
+ (apply #'vector
(mapcar
#'(lambda (entry)
(cl-assert (char-or-string-p entry) t)
@@ -336,12 +336,12 @@ exchange in environments where Unicode is not available. This input method
uses this transliteration to allow you to produce the IPA in your editor
with a keyboard that's limited to ASCII.
-See http://www.phon.ucl.ac.uk/home/sampa/ipasam-x.pdf for a full definition
+See https://www.phon.ucl.ac.uk/home/sampa/ipasam-x.pdf for a full definition
of the mapping.")
(quail-define-rules
- ;; Table taken from http://en.wikipedia.org/wiki/X-SAMPA, checked with
- ;; http://www.phon.ucl.ac.uk/home/sampa/ipasam-x.pdf
+ ;; Table taken from https://en.wikipedia.org/wiki/X-SAMPA, checked with
+ ;; https://www.phon.ucl.ac.uk/home/sampa/ipasam-x.pdf
("d`" "É–") ;; Voiced retroflex plosive U+0256
("g" "É¡") ;; Voiced velar plosive U+0261
@@ -502,9 +502,9 @@ of the mapping.")
;; diacritic. To avoid this, handle the input specially with the function
;; ipa-x-sampa-underscore-implosive.
-(dolist (implosive-x-sampa (mapcar 'car ipa-x-sampa-implosive-submap))
+(dolist (implosive-x-sampa (mapcar #'car ipa-x-sampa-implosive-submap))
(setq implosive-x-sampa (car (split-string implosive-x-sampa "_")))
(quail-defrule (format "%s_" implosive-x-sampa)
- 'ipa-x-sampa-underscore-implosive))
+ #'ipa-x-sampa-underscore-implosive))
;;; ipa.el ends here
diff --git a/lisp/leim/quail/japanese.el b/lisp/leim/quail/japanese.el
index d7249d286fb..6a2bcdc9ed7 100644
--- a/lisp/leim/quail/japanese.el
+++ b/lisp/leim/quail/japanese.el
@@ -1,4 +1,4 @@
-;;; japanese.el --- Quail package for inputting Japanese
+;;; japanese.el --- Quail package for inputting Japanese -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -113,8 +113,7 @@
(?h . "japanese")
(?q . ("japanese-ascii"))))
-(defvar quail-japanese-package-saved nil)
-(make-variable-buffer-local 'quail-japanese-package-saved)
+(defvar-local quail-japanese-package-saved nil)
(put 'quail-japanese-package-saved 'permanent-local t)
(defun quail-japanese-switch-package (key idx)
@@ -413,7 +412,7 @@ C-h kkc-help
List these key bindings.
"
nil t t nil nil nil nil nil
- 'quail-japanese-update-translation
+ #'quail-japanese-update-translation
'(("K" . quail-japanese-toggle-kana)
(" " . quail-japanese-kanji-kkc)
("\C-m" . quail-no-conversion)
@@ -492,7 +491,7 @@ qh: shift to the input method `japanese',
qq: toggle between this input method and the input method `japanese-ascii'.
"
nil t t nil nil nil nil nil
- 'quail-japanese-hankaku-update-translation)
+ #'quail-japanese-hankaku-update-translation)
(dolist (elt quail-japanese-transliteration-rules)
(quail-defrule (car elt)
@@ -518,7 +517,7 @@ qq: toggle between this input method and the input method `japanese-ascii'.
nil
"Japanese hiragana input method by Roman transliteration."
nil t t nil nil nil nil nil
- 'quail-japanese-update-translation)
+ #'quail-japanese-update-translation)
;; Use the same map as that of `japanese'.
(setcar (cdr (cdr quail-current-package))
@@ -539,7 +538,7 @@ qq: toggle between this input method and the input method `japanese-ascii'.
nil
"Japanese katakana input method by Roman transliteration."
nil t t nil nil nil nil nil
- 'quail-japanese-katakana-update-translation)
+ #'quail-japanese-katakana-update-translation)
(dolist (elt quail-japanese-transliteration-rules)
(quail-defrule (car elt)
diff --git a/lisp/leim/quail/lao.el b/lisp/leim/quail/lao.el
index af3b5892629..a932460a20a 100644
--- a/lisp/leim/quail/lao.el
+++ b/lisp/leim/quail/lao.el
@@ -1,4 +1,4 @@
-;;; lao.el --- Quail package for inputting Lao characters -*-coding: utf-8;-*-
+;;; lao.el --- Quail package for inputting Lao characters -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
@@ -195,7 +195,7 @@ you need to re-load it to properly re-initialize related alists.")
(quail-define-package
"lao" "Lao" "ລ" t
"Lao input method simulating Lao keyboard layout based on Thai TIS620"
- nil t t t t nil nil nil 'quail-lao-update-translation nil t)
+ nil t t t t nil nil nil #'quail-lao-update-translation nil t)
(quail-install-map
(quail-map-from-table
diff --git a/lisp/leim/quail/latin-alt.el b/lisp/leim/quail/latin-alt.el
index 4391ea5d50c..0db952b67c4 100644
--- a/lisp/leim/quail/latin-alt.el
+++ b/lisp/leim/quail/latin-alt.el
@@ -1,4 +1,4 @@
-;;; latin-alt.el --- Quail package for inputting various European characters -*-coding: utf-8;-*-
+;;; latin-alt.el --- Quail package for inputting various European characters -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el
index dffd8e633bc..2146304f156 100644
--- a/lisp/leim/quail/latin-ltx.el
+++ b/lisp/leim/quail/latin-ltx.el
@@ -1,4 +1,4 @@
-;;; latin-ltx.el --- Quail package for TeX-style input -*-coding: utf-8;-*-
+;;; latin-ltx.el --- Quail package for TeX-style input -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
@@ -8,7 +8,7 @@
;; Author: TAKAHASHI Naoto <ntakahas@m17n.org>
;; Dave Love <fx@gnu.org>
-;; Keywords: multilingual, input, Greek, i18n
+;; Keywords: multilingual, input method, i18n
;; This file is part of GNU Emacs.
@@ -242,12 +242,14 @@ system, including many technical ones. Examples:
((lambda (name char)
;; "GREEK SMALL LETTER PHI" (which is \phi) and "GREEK PHI SYMBOL"
;; (which is \varphi) are reversed in `ucs-names', so we define
- ;; them manually.
- (unless (string-match-p "\\<PHI\\>" name)
+ ;; them manually. Also ignore "GREEK SMALL LETTER EPSILON" and
+ ;; add the correct value for \epsilon manually.
+ (unless (string-match-p "\\<\\(?:PHI\\|GREEK SMALL LETTER EPSILON\\)\\>" name)
(concat "\\" (funcall (if (match-end 1) #' capitalize #'downcase)
(match-string 2 name)))))
"\\`GREEK \\(?:SMALL\\|CAPITA\\(L\\)\\) LETTER \\([^- ]+\\)\\'")
+ ("\\epsilon" ?ϵ)
("\\phi" ?Ï•)
("\\Box" ?â–¡)
("\\Bumpeq" ?≎)
@@ -277,13 +279,17 @@ system, including many technical ones. Examples:
("\\Vdash" ?⊩)
("\\Vert" ?‖)
("\\Vvdash" ?⊪)
+ ("\\above" ?â”´)
("\\aleph" ?ℵ)
("\\amalg" ?âˆ)
("\\angle" ?∠)
+ ("\\aoint" ?∳)
("\\approx" ?≈)
("\\approxeq" ?≊)
+ ("\\asmash" ?⬆)
("\\ast" ?∗)
("\\asymp" ?â‰)
+ ("\\atop" ?¦)
("\\backcong" ?≌)
("\\backepsilon" ?âˆ)
("\\backprime" ?‵)
@@ -292,11 +298,18 @@ system, including many technical ones. Examples:
("\\backslash" ?\\)
("\\barwedge" ?⊼)
("\\because" ?∵)
+ ("\\begin" ?\〖)
+ ("\\below" ?┬)
("\\beth" ?â„¶)
("\\between" ?≬)
("\\bigcap" ?â‹‚)
("\\bigcirc" ?â—¯)
("\\bigcup" ?⋃)
+ ("\\bigodot" ?⨀)
+ ("\\bigoplus" ?â¨)
+ ("\\bigotimes" ?⨂)
+ ("\\bigsqcup" ?⨆)
+ ("\\biguplus" ?⨄)
("\\bigstar" ?★)
("\\bigtriangledown" ?â–½)
("\\bigtriangleup" ?â–³)
@@ -313,6 +326,7 @@ system, including many technical ones. Examples:
("\\boxminus" ?⊟)
("\\boxplus" ?⊞)
("\\boxtimes" ?⊠)
+ ("\\bra" ?\⟨)
("\\bullet" ?•)
("\\bumpeq" ?â‰)
("\\cap" ?∩)
@@ -329,7 +343,9 @@ system, including many technical ones. Examples:
("\\circledast" ?⊛)
("\\circledcirc" ?⊚)
("\\circleddash" ?âŠ)
+ ("\\close" ?┤)
("\\clubsuit" ?♣)
+ ("\\coint" ?∲)
("\\coloneq" ?≔)
("\\complement" ?âˆ)
("\\cong" ?≅)
@@ -347,8 +363,12 @@ system, including many technical ones. Examples:
("\\dagger" ?†)
("\\daleth" ?ℸ)
("\\dashv" ?⊣)
+ ("\\Dd" ?â……)
+ ("\\dd" ?â…†)
("\\ddag" ?‡)
("\\ddagger" ?‡)
+ ("\\ddddot" ?⃜)
+ ("\\dddot" ?⃛)
("\\ddots" ?⋱)
("\\diamond" ?â‹„)
("\\diamondsuit" ?♢)
@@ -361,8 +381,12 @@ system, including many technical ones. Examples:
("\\downdownarrows" ?⇊)
("\\downleftharpoon" ?⇃)
("\\downrightharpoon" ?⇂)
+ ("\\dsmash" ?⬇)
+ ("\\ee" ?â…‡)
("\\ell" ?â„“)
("\\emptyset" ?∅)
+ ("\\end" ?\〗)
+ ("\\eqarray" ?â–ˆ)
("\\eqcirc" ?≖)
("\\eqcolon" ?≕)
("\\eqslantgtr" ?â‹)
@@ -412,16 +436,25 @@ system, including many technical ones. Examples:
("\\heartsuit" ?♥)
("\\hookleftarrow" ?↩)
("\\hookrightarrow" ?↪)
+ ("\\hphantom" ?⬄)
+ ("\\hsmash" ?⬌)
("\\iff" ?⇔)
+ ("\\ii" ?â…ˆ)
+ ("\\iiiint" ?⨌)
+ ("\\iiint" ?∭)
+ ("\\iint" ?∬)
("\\imath" ?ı)
("\\in" ?∈)
("\\infty" ?∞)
("\\int" ?∫)
("\\intercal" ?⊺)
+ ("\\jj" ?â…‰)
+ ("\\jmath" ?È·)
("\\langle" ?⟨) ;; Was ?〈, see bug#12948.
("\\lbrace" ?{)
("\\lbrack" ?\[)
("\\lceil" ?⌈)
+ ("\\ldiv" ?∕)
("\\ldots" ?…)
("\\le" ?≤)
("\\leadsto" ?â†)
@@ -527,16 +560,25 @@ system, including many technical ones. Examples:
("\\nvdash" ?⊬)
("\\nwarrow" ?↖)
("\\odot" ?⊙)
+ ("\\oiiint" ?∰)
+ ("\\oiint" ?∯)
("\\oint" ?∮)
("\\ominus" ?⊖)
("\\oplus" ?⊕)
("\\oslash" ?⊘)
("\\otimes" ?⊗)
+ ("\\overbrace" ?âž)
+ ("\\overparen" ?âœ)
("\\par" ?
)
("\\parallel" ?∥)
("\\partial" ?∂)
("\\perp" ?⊥)
+ ("\\phantom" ?⟡)
("\\pitchfork" ?â‹”)
+ ("\\pppprime" ?â—)
+ ("\\ppprime" ?‴)
+ ("\\pprime" ?″)
+ ("\\prcue" ?≼)
("\\prec" ?≺)
("\\precapprox" ?≾)
("\\preceq" ?≼)
@@ -546,12 +588,16 @@ system, including many technical ones. Examples:
("\\prime" ?′)
("\\prod" ?âˆ)
("\\propto" ?âˆ)
+ ("\\qdrt" ?∜)
("\\qed" ?∎)
("\\quad" ?â€)
("\\rangle" ?\⟩) ;; Was ?〉, see bug#12948.
+ ("\\ratio" ?∶)
("\\rbrace" ?})
("\\rbrack" ?\])
("\\rceil" ?⌉)
+ ("\\rddots" ?â‹°)
+ ("\\rect" ?â–­)
("\\rfloor" ?⌋)
("\\rightarrow" ?→)
("\\rightarrowtail" ?↣)
@@ -563,6 +609,8 @@ system, including many technical ones. Examples:
("\\rightrightarrows" ?⇉)
("\\rightthreetimes" ?⋌)
("\\risingdotseq" ?≓)
+ ("\\rrect" ?â–¢)
+ ("\\sdiv" ?â„)
("\\rtimes" ?⋊)
("\\sbs" ?﹨)
("\\searrow" ?↘)
@@ -575,6 +623,7 @@ system, including many technical ones. Examples:
("\\smallamalg" ?âˆ)
("\\smallsetminus" ?∖)
("\\smallsmile" ?⌣)
+ ("\\smash" ?â¬)
("\\smile" ?⌣)
("\\spadesuit" ?â™ )
("\\sphericalangle" ?∢)
@@ -625,12 +674,16 @@ system, including many technical ones. Examples:
("\\ulcorner" ?⌜)
("\\uparrow" ?↑)
("\\updownarrow" ?↕)
+ ("\\underbar" ?â–)
+ ("\\underbrace" ?âŸ)
+ ("\\underparen" ?â)
("\\upleftharpoon" ?↿)
("\\uplus" ?⊎)
("\\uprightharpoon" ?↾)
("\\upuparrows" ?⇈)
("\\urcorner" ?âŒ)
("\\u{i}" ?Ä­)
+ ("\\vbar" ?│)
("\\vDash" ?⊨)
((lambda (name char)
@@ -641,6 +694,7 @@ system, including many technical ones. Examples:
(concat "\\var" (downcase (match-string 1 name)))))
"\\`GREEK \\([^- ]+\\) SYMBOL\\'")
+ ("\\varepsilon" ?ε)
("\\varphi" ?φ)
("\\varprime" ?′)
("\\varpropto" ?âˆ)
@@ -652,6 +706,7 @@ system, including many technical ones. Examples:
("\\vee" ?∨)
("\\veebar" ?⊻)
("\\vert" ?|)
+ ("\\vphantom" ?⇳)
("\\wedge" ?∧)
("\\wp" ?℘)
("\\wr" ?≀)
@@ -727,7 +782,9 @@ system, including many technical ones. Examples:
("\\ldq" ?\“)
("\\rdq" ?\â€)
("\\defs" ?≙) ; per fuzz/zed
- ;; ("\\sqrt[3]" ?∛)
+ ("\\sqrt" ?√)
+ ("\\sqrt[3]" ?∛)
+ ("\\sqrt[4]" ?∜)
("\\llbracket" ?\〚) ; stmaryrd
("\\rrbracket" ?\〛)
;; ("\\lbag" ?\〚) ; fuzz
diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el
index 95226e0cefa..8329fff82ed 100644
--- a/lisp/leim/quail/latin-post.el
+++ b/lisp/leim/quail/latin-post.el
@@ -1,4 +1,4 @@
-;;; latin-post.el --- Quail packages for inputting various European characters -*-coding: utf-8;-*-
+;;; latin-post.el --- Quail packages for inputting various European characters -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -744,7 +744,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
;;; correctly on most displays.
;;; This reference is an authoritative guide to Hawaiian orthography:
-;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
+;;; https://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi
;;; Comments to bobnewell@bobnewell.net
@@ -937,7 +937,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
(quail-define-package
"danish-postfix" "Latin-1" "DA<" t
- "Danish input method (rule: AE -> Æ, OE -> Ø, AA -> Å, E\\=' -> É)
+ "Danish input method (rule: AE -> Æ, OE -> Ø, AA -> Å, E\\=' -> É, E= -> €)
Doubling the postfix separates the letter and postfix: e.g. aee -> ae
"
@@ -951,6 +951,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("AA" ?Ã…)
("aa" ?Ã¥)
("E'" ?É)
+ ("E=" ?€)
("e'" ?é)
("AEE" ["AE"])
@@ -960,6 +961,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("AAA" ["AA"])
("aaa" ["aa"])
("E''" ["E'"])
+ ("E==" ["E="])
("e''" ["e'"])
)
@@ -1034,6 +1036,7 @@ AE -> Ä
AEE -> AE
OE -> Ö
OEE -> OE
+E= -> €
"
nil t nil nil nil nil nil nil nil nil t)
@@ -1042,11 +1045,13 @@ OEE -> OE
("ae" ?ä)
("OE" ?Ö)
("oe" ?ö)
+ ("E=" ?€)
("AEE" ["AE"])
("aee" ["ae"])
("OEE" ["OE"])
("oee" ["oe"])
+ ("E==" ["E="])
)
(quail-define-package
@@ -1061,6 +1066,8 @@ Par exemple: a\\=` -> à e\\=' -> é.
En doublant la frappe des diacritiques, ils s'isoleront de la lettre.
Par exemple: e\\='\\=' -> e\\='
+€ est produit par E=.
+
Å’ est produit par O/."
nil t nil nil nil nil nil nil nil nil t)
@@ -1073,6 +1080,7 @@ Par exemple: e\\='\\=' -> e\\='
("E'" ?É)
("E^" ?Ê)
("E\"" ?Ë)
+ ("E=" ?€)
("e`" ?è)
("e'" ?é)
("e^" ?ê)
@@ -1104,6 +1112,7 @@ Par exemple: e\\='\\=' -> e\\='
("E''" ["E'"])
("E^^" ["E^"])
("E\"\"" ["E\""])
+ ("E==" ["E="])
("e``" ["e`"])
("e''" ["e'"])
("e^^" ["e^"])
@@ -1140,6 +1149,7 @@ ue -> ü (not after a/e/q)
uee -> ue
sz -> ß
szz -> sz
+E= -> €
"
nil t nil nil nil nil nil nil nil nil t)
@@ -1152,6 +1162,7 @@ szz -> sz
("ue" ?ü)
("sz" ?ß)
("SZ" ?ẞ)
+ ("E=" ?€)
("AEE" ["AE"])
("aee" ["ae"])
@@ -1168,6 +1179,7 @@ szz -> sz
("Aue" ["Aue"])
("que" ["que"])
("Que" ["Que"])
+ ("E==" ["E="])
)
(quail-define-package
@@ -1184,6 +1196,7 @@ AE -> Æ
OE -> Ö
D/ -> Ã (eth)
T/ -> Þ (thorn)
+E= -> €
Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
" nil t nil nil nil nil nil nil nil nil t)
@@ -1238,7 +1251,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\='
a\\=` -> à A\\=` -> À e\\=' -> é << -> «
e\\=` -> è E\\=` -> È E\\=' -> É >> -> »
-i\\=` -> ì I\\=` -> Ì o_ -> º
+i\\=` -> ì I\\=` -> Ì E= -> € o_ -> º
o\\=` -> ò O\\=` -> Ò a_ -> ª
u\\=` -> ù U\\=` -> Ù
@@ -1252,6 +1265,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\=`\\=` -> a\\=`
("a`" ?à)
("E`" ?È)
("E'" ?É)
+ ("E=" ?€)
("e`" ?è)
("e'" ?é)
("I`" ?Ì)
@@ -1269,6 +1283,7 @@ Doubling the postfix separates the letter and postfix: e.g. a\\=`\\=` -> a\\=`
("a``" ["a`"])
("E``" ["E`"])
("E''" ["E'"])
+ ("E==" ["E="])
("e``" ["e`"])
("e''" ["e'"])
("I``" ["I`"])
@@ -1283,9 +1298,68 @@ Doubling the postfix separates the letter and postfix: e.g. a\\=`\\=` -> a\\=`
("a__" ["a_"])
)
+;; Input modes of various orthographies for the Lakota language.
+;; I'd like to acknowledge the elders and ancestors who fought
+;; to keep the language and culture alive.
+;; Grant Shangreaux <grant@churls.world> 2021-05-23
+
+(quail-define-package
+ "lakota-white-hat-postfix" "Lakota" "Lak " t
+ "Lakota White Hat orthography input method with postfix modifiers.
+The `f' key produces the nasal Å‹ while unused letters `r' and `v' add
+the combining dot above and macron diacritics respectively. This allows
+production of all the consonants:
+
+cv -> c̄ hr -> ḣ pv -> p̄ tv -> t̄
+cr -> ċ kv -> k̄ pr -> ṗ tr -> ṫ
+gr -> ġ kr -> k̇ sr -> ṡ zr -> ż
+
+The glottal stop is produced by repeating the ' character. This orthography
+does not use stress diacritics on vowels. Mit̄ak̄uyep̄i p̄ilamayayap̄ilo."
+nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ("f" ?Å‹)
+ ("''" ?’)
+ ;; using hex representation as these characters combine with the ? syntax
+ ("r" #x307) ; COMBINING DOT ABOVE
+ ("v" #x304)) ; COMBINING MACRON
+
+
+
+(quail-define-package
+ "lakota-slo-postfix" "Lakota" "SLO " t
+ "Suggested Lakota Orthography input method with postfix modifier.
+To add stress to a vowel, simply type the single quote ' after the vowel.
+The glottal stop is produced by repeating the ' character. All other
+characters are bound to a single key. Mitákuyepi philámayayapi ló."
+nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ;; accented vowels
+ ("a'" ?á) ("A'" ?Ã)
+ ("e'" ?é) ("E'" ?É)
+ ("i'" ?í) ("I'" ?Ã)
+ ("o'" ?ó) ("O'" ?Ó)
+ ("u'" ?ú) ("U'" ?Ú)
+
+ ;; consonants with caron
+ ("c" ?Ä) ("C" ?ÄŒ)
+ ("j" ?ÈŸ) ("J" ?Èž)
+ ("q" ?ǧ) ("Q" ?Ǧ)
+ ("x" ?ž) ("X" ?Ž)
+ ("r" ?Å¡) ("R" ?Å )
+
+ ;; velar nasal n
+ ("f" ?Å‹)
+
+ ;; glottal stop
+ ("''" ?’))
+
(quail-define-package
"norwegian-postfix" "Latin-1" "NO<" t
- "Norwegian (Norsk) input method (rule: AE->Æ OE->Ø AA->Å E\\='->É)
+ "Norwegian (Norsk) input method (rule: AE->Æ OE->Ø AA->Å E\\='->É
+ E= -> €)
Doubling the postfix separates the letter and postfix: e.g. aee -> ae
"
@@ -1299,6 +1373,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("AA" ?Ã…)
("aa" ?Ã¥)
("E'" ?É)
+ ("E=" ?€)
("e'" ?é)
("AEE" ["AE"])
@@ -1308,6 +1383,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("AAA" ["AA"])
("aaa" ["aa"])
("E''" ["E'"])
+ ("E==" ["E="])
("e''" ["e'"])
)
@@ -1322,6 +1398,7 @@ aa -> å
a\" -> ä
o\" -> ö
e\\=' -> é
+E= -> €
Doubling the postfix separates the letter and postfix:
aee -> ae o\"\" -> o\" etc.
@@ -1339,6 +1416,7 @@ aee -> ae o\"\" -> o\" etc.
("O\"" ?Ö)
("o\"" ?ö)
("E'" ?É)
+ ("E=" ?€)
("e'" ?é)
("AEE" ["AE"])
@@ -1352,6 +1430,7 @@ aee -> ae o\"\" -> o\" etc.
("O\"\"" ["O\""])
("o\"\"" ["o\""])
("E''" ["E'"])
+ ("E==" ["E="])
("e''" ["e'"])
)
@@ -1361,6 +1440,7 @@ aee -> ae o\"\" -> o\" etc.
A\\=' -> Ã
E\\=' -> É
+E= -> €
I\\=' -> Ã
O\\=' -> Ó
U\\=' -> Ú
@@ -1376,6 +1456,7 @@ a\\='\\=' -> a\\=' n~~ -> n~, etc.
("A'" ?Ã)
("a'" ?á)
("E'" ?É)
+ ("E=" ?€)
("e'" ?é)
("I'" ?Ã)
("i'" ?í)
@@ -1393,6 +1474,7 @@ a\\='\\=' -> a\\=' n~~ -> n~, etc.
("A''" ["A'"])
("a''" ["a'"])
("E''" ["E'"])
+ ("E==" ["E="])
("e''" ["e'"])
("I''" ["I'"])
("i''" ["i'"])
@@ -1410,7 +1492,8 @@ a\\='\\=' -> a\\=' n~~ -> n~, etc.
(quail-define-package
"swedish-postfix" "Latin-1" "SV<" t
- "Swedish (Svenska) input method (rule: AA -> Å AE -> Ä OE -> Ö E\\=' -> É)
+ "Swedish (Svenska) input method
+(rule: AA -> Å AE -> Ä OE -> Ö E\\=' -> É E= -> €)
Doubling the postfix separates the letter and postfix: e.g. aee -> ae
" nil t nil nil nil nil nil nil nil nil t)
@@ -1423,6 +1506,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("OE" ?Ö)
("oe" ?ö)
("E'" ?É)
+ ("E=" ?€)
("e'" ?é)
("AAA" ["AA"])
@@ -1432,6 +1516,7 @@ Doubling the postfix separates the letter and postfix: e.g. aee -> ae
("OEE" ["OE"])
("oee" ["oe"])
("E''" ["E'"])
+ ("E==" ["E="])
("e''" ["e'"])
)
diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el
index 6d906443054..3b9c942a8c1 100644
--- a/lisp/leim/quail/latin-pre.el
+++ b/lisp/leim/quail/latin-pre.el
@@ -1,4 +1,4 @@
-;;; latin-pre.el --- Quail packages for inputting various European characters -*-coding: utf-8;-*-
+;;; latin-pre.el --- Quail packages for inputting various European characters -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1294,7 +1294,7 @@ of characters from a single Latin-N charset.
;;; correctly on most displays.
;;; This reference is an authoritative guide to Hawaiian orthography:
-;;; http://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
+;;; https://www2.hawaii.edu/~strauch/tips/HawaiianOrthography.html
;;; Initial coding 2018-09-08 Bob Newell, Honolulu, Hawaiʻi
;;; Comments to bobnewell@bobnewell.net
@@ -1337,4 +1337,33 @@ Doubling the prefix separates the letter and prefix. --a -> -a
("``" ["`"])
)
+(quail-define-package
+ "lakota-slo-prefix" "Lakota" "SLO " t
+ "Suggested Lakota Orthography input method with prefix modifier.
+To add stress to a vowel, simply type the single quote ' before the vowel.
+The glottal stop is produced by repeating the ' character. All other
+characters are bound to a single key. Mitákuyepi philámayayapi ló."
+nil t nil nil nil nil nil nil nil nil t)
+
+(quail-define-rules
+ ;; accented vowels
+ ("'a" ?á) ("'A" ?Ã)
+ ("'e" ?é) ("'E" ?É)
+ ("'i" ?í) ("'I" ?Ã)
+ ("'o" ?ó) ("'O" ?Ó)
+ ("'u" ?ú) ("'U" ?Ú)
+
+ ;; consonants with caron
+ ("c" ?Ä) ("C" ?ÄŒ)
+ ("j" ?ÈŸ) ("J" ?Èž)
+ ("q" ?ǧ) ("Q" ?Ǧ)
+ ("x" ?ž) ("X" ?Ž)
+ ("r" ?Å¡) ("R" ?Å )
+
+ ;; velar nasal n
+ ("f" ?Å‹)
+
+ ;; glottal stop
+ ("''" ?’))
+
;;; latin-pre.el ends here
diff --git a/lisp/leim/quail/lrt.el b/lisp/leim/quail/lrt.el
index e05bc1e6cb7..68eaeb58ec6 100644
--- a/lisp/leim/quail/lrt.el
+++ b/lisp/leim/quail/lrt.el
@@ -1,4 +1,4 @@
-;;; lrt.el --- Quail package for inputting Lao characters by LRT method -*-coding: utf-8;-*-
+;;; lrt.el --- Quail package for inputting Lao characters by LRT method -*- lexical-binding: t; -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -60,7 +60,7 @@
`\\' (backslash) + `$' => ຯ LAO ELLIPSIS
"
nil 'forget-last-selection 'deterministic 'kbd-translate 'show-layout
- nil nil nil 'quail-lrt-update-translation nil t)
+ nil nil nil #'quail-lrt-update-translation nil t)
;; LRT (Lao Roman Transcription) input method accepts the following
;; key sequence:
diff --git a/lisp/leim/quail/persian.el b/lisp/leim/quail/persian.el
index f3aad8c7c56..cb1f6e3c78b 100644
--- a/lisp/leim/quail/persian.el
+++ b/lisp/leim/quail/persian.el
@@ -1,4 +1,4 @@
-;;; persian.el --- Quail package for inputting Persian/Farsi keyboard -*- coding: utf-8;-*-
+;;; persian.el --- Quail package for inputting Persian/Farsi keyboard -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/programmer-dvorak.el b/lisp/leim/quail/programmer-dvorak.el
index a3796296c89..9e1e23c04bb 100644
--- a/lisp/leim/quail/programmer-dvorak.el
+++ b/lisp/leim/quail/programmer-dvorak.el
@@ -1,4 +1,4 @@
-;;; programmer-dvorak.el --- Quail package for the programmer Dvorak layout
+;;; programmer-dvorak.el --- Quail package for the programmer Dvorak layout -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
@@ -24,7 +24,7 @@
;;; Commentary:
;;; This file provides an input method for the programmers Dvorak keyboard
-;;; layout by Roland Kaufman (<http://www.kaufmann.no/roland/dvorak/>).
+;;; layout by Roland Kaufman (<https://www.kaufmann.no/roland/dvorak/>).
;;; Code:
diff --git a/lisp/leim/quail/py-punct.el b/lisp/leim/quail/py-punct.el
index 161c12da3fd..2a61795a135 100644
--- a/lisp/leim/quail/py-punct.el
+++ b/lisp/leim/quail/py-punct.el
@@ -1,4 +1,4 @@
-;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols)
+;;; py-punct.el --- Quail packages for Chinese (pinyin + extra symbols) -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/pypunct-b5.el b/lisp/leim/quail/pypunct-b5.el
index 9f4e73c9f05..f9330bd24f9 100644
--- a/lisp/leim/quail/pypunct-b5.el
+++ b/lisp/leim/quail/pypunct-b5.el
@@ -1,4 +1,4 @@
-;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols)
+;;; pypunct-b5.el --- Quail packages for Chinese (pinyin + extra symbols) -*- lexical-binding: t -*-
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/rfc1345.el b/lisp/leim/quail/rfc1345.el
index eb24d8cb888..a07208294f7 100644
--- a/lisp/leim/quail/rfc1345.el
+++ b/lisp/leim/quail/rfc1345.el
@@ -1,4 +1,4 @@
-;;; rfc1345.el --- Quail method for RFC 1345 mnemonics -*- coding: utf-8 -*-
+;;; rfc1345.el --- Quail method for RFC 1345 mnemonics -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/sami.el b/lisp/leim/quail/sami.el
index 576c3b08971..6c9b2d99cc0 100644
--- a/lisp/leim/quail/sami.el
+++ b/lisp/leim/quail/sami.el
@@ -1,4 +1,4 @@
-;;; sami.el --- Quail package for inputting Sámi -*-coding: utf-8;-*-
+;;; sami.el --- Quail package for inputting Sámi -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/sgml-input.el b/lisp/leim/quail/sgml-input.el
index a323f924e60..68add78e29d 100644
--- a/lisp/leim/quail/sgml-input.el
+++ b/lisp/leim/quail/sgml-input.el
@@ -1,4 +1,4 @@
-;;; sgml-input.el --- Quail method for Unicode entered as SGML entities -*- coding: utf-8 -*-
+;;; sgml-input.el --- Quail method for Unicode entered as SGML entities -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/sisheng.el b/lisp/leim/quail/sisheng.el
index 8e7a500276a..aa35bb0574f 100644
--- a/lisp/leim/quail/sisheng.el
+++ b/lisp/leim/quail/sisheng.el
@@ -1,4 +1,4 @@
-;;; sisheng.el --- sisheng input method for Chinese pinyin transliteration
+;;; sisheng.el --- sisheng input method for Chinese pinyin transliteration -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/slovak.el b/lisp/leim/quail/slovak.el
index c88362eb49d..53780cfd4a5 100644
--- a/lisp/leim/quail/slovak.el
+++ b/lisp/leim/quail/slovak.el
@@ -1,4 +1,4 @@
-;;; slovak.el --- Quail package for inputting Slovak -*-coding: utf-8;-*-
+;;; slovak.el --- Quail package for inputting Slovak -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/symbol-ksc.el b/lisp/leim/quail/symbol-ksc.el
index 10dab16acac..0583d64c2b6 100644
--- a/lisp/leim/quail/symbol-ksc.el
+++ b/lisp/leim/quail/symbol-ksc.el
@@ -1,4 +1,4 @@
-;;; symbol-ksc.el --- Quail-package for Korean Symbol (KSC5601) -*-coding: utf-8;-*-
+;;; symbol-ksc.el --- Quail-package for Korean Symbol (KSC5601) -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
diff --git a/lisp/leim/quail/tamil-dvorak.el b/lisp/leim/quail/tamil-dvorak.el
index f115c51926c..b2d48afa0a7 100644
--- a/lisp/leim/quail/tamil-dvorak.el
+++ b/lisp/leim/quail/tamil-dvorak.el
@@ -1,4 +1,4 @@
-;;; tamil-dvorak.el --- Quail package for Tamil input with Dvorak keyboard
+;;; tamil-dvorak.el --- Quail package for Tamil input with Dvorak keyboard -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/thai.el b/lisp/leim/quail/thai.el
index 7cf11daf9d0..07ba657f9b8 100644
--- a/lisp/leim/quail/thai.el
+++ b/lisp/leim/quail/thai.el
@@ -1,4 +1,4 @@
-;;; thai.el --- Quail package for inputting Thai characters -*-coding: utf-8;-*-
+;;; thai.el --- Quail package for inputting Thai characters -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/tibetan.el b/lisp/leim/quail/tibetan.el
index a54763d56f6..33cc6f5965f 100644
--- a/lisp/leim/quail/tibetan.el
+++ b/lisp/leim/quail/tibetan.el
@@ -1,4 +1,4 @@
-;;; tibetan.el --- Quail package for inputting Tibetan characters -*-coding: utf-8-emacs;-*-
+;;; tibetan.el --- Quail package for inputting Tibetan characters -*-coding: utf-8-emacs; lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -158,7 +158,7 @@
Tsheg is assigned to SPC. Space is assigned to period `.'.
"
nil nil nil nil nil nil nil nil
- 'quail-tibetan-update-translation)
+ #'quail-tibetan-update-translation)
;; Here we build up a Quail map for a Tibetan sequence the whole of
;; which can be one composition.
@@ -371,7 +371,7 @@
(setq trans-list (cons trans trans-list)
i last)
(setq trans-list nil i len))))
- (apply 'concat (nreverse trans-list))))
+ (apply #'concat (nreverse trans-list))))
(defvar quail-tibkey-characters nil)
@@ -440,7 +440,7 @@
I hope I'll complete in a future revision.
"
nil nil nil nil nil nil nil nil
- 'quail-tibkey-update-translation)
+ #'quail-tibkey-update-translation)
(quail-install-map
(quail-map-from-table
diff --git a/lisp/leim/quail/uni-input.el b/lisp/leim/quail/uni-input.el
index de31f4b8b05..bfe4ce6f120 100644
--- a/lisp/leim/quail/uni-input.el
+++ b/lisp/leim/quail/uni-input.el
@@ -1,4 +1,4 @@
-;;; uni-input.el --- Hex Unicode input method
+;;; uni-input.el --- Hex Unicode input method -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
@@ -57,11 +57,12 @@
(echo-keystrokes 0)
(help-char nil)
(events (list key))
- (str " "))
+ ;; (str " ")
+ )
(unwind-protect
(catch 'non-digit
(progn
- (dotimes (i 4)
+ (dotimes (_ 4)
(let ((seq (read-key-sequence nil))
key)
(if (and (stringp seq)
@@ -76,7 +77,7 @@
(throw 'non-digit (append (reverse events)
(listify-key-sequence seq))))))
(quail-delete-region)
- (let ((n (string-to-number (apply 'string
+ (let ((n (string-to-number (apply #'string
(cdr (nreverse events)))
16)))
(if (characterp n)
@@ -100,13 +101,12 @@ While this input method is active, the variable
(quail-delete-overlays)
(setq describe-current-input-method-function nil))
(kill-local-variable 'input-method-function))
- (setq deactivate-current-input-method-function 'ucs-input-deactivate)
- (setq describe-current-input-method-function 'ucs-input-help)
+ (setq deactivate-current-input-method-function #'ucs-input-deactivate)
+ (setq describe-current-input-method-function #'ucs-input-help)
(quail-delete-overlays)
(if (eq (selected-window) (minibuffer-window))
- (add-hook 'minibuffer-exit-hook 'quail-exit-from-minibuffer))
- (set (make-local-variable 'input-method-function)
- 'ucs-input-method)))
+ (add-hook 'minibuffer-exit-hook #'quail-exit-from-minibuffer))
+ (setq-local input-method-function #'ucs-input-method)))
(defun ucs-input-deactivate ()
"Deactivate UCS input method."
@@ -115,7 +115,7 @@ While this input method is active, the variable
(define-obsolete-function-alias
'ucs-input-inactivate
- 'ucs-input-deactivate "24.3")
+ #'ucs-input-deactivate "24.3")
(defun ucs-input-help ()
(interactive)
diff --git a/lisp/leim/quail/viqr.el b/lisp/leim/quail/viqr.el
index b7591b15e05..d127ff247cf 100644
--- a/lisp/leim/quail/viqr.el
+++ b/lisp/leim/quail/viqr.el
@@ -1,4 +1,4 @@
-;;; viqr.el --- Quail packages for inputting Vietnamese with VIQR system -*-coding: utf-8;-*-
+;;; viqr.el --- Quail packages for inputting Vietnamese with VIQR system -*-coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/vntelex.el b/lisp/leim/quail/vntelex.el
index c6033faa36b..22d23d47474 100644
--- a/lisp/leim/quail/vntelex.el
+++ b/lisp/leim/quail/vntelex.el
@@ -1,4 +1,4 @@
-;;; vntelex.el --- Quail package for Vietnamese by Telex method
+;;; vntelex.el --- Quail package for Vietnamese by Telex method -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/vnvni.el b/lisp/leim/quail/vnvni.el
index f6e876f48c3..faccc0afc53 100644
--- a/lisp/leim/quail/vnvni.el
+++ b/lisp/leim/quail/vnvni.el
@@ -1,4 +1,4 @@
-;;; vnvni.el --- Quail package for Vietnamese by VNI method
+;;; vnvni.el --- Quail package for Vietnamese by VNI method -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/welsh.el b/lisp/leim/quail/welsh.el
index 03e6b842b2e..f521d1464e9 100644
--- a/lisp/leim/quail/welsh.el
+++ b/lisp/leim/quail/welsh.el
@@ -1,4 +1,4 @@
-;;; welsh.el --- Quail package for inputting Welsh characters -*-coding: utf-8;-*-
+;;; welsh.el --- Quail package for inputting Welsh characters -*- coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/linum.el b/lisp/linum.el
index 704ca5b8ced..b0281d366cd 100644
--- a/lisp/linum.el
+++ b/lisp/linum.el
@@ -5,7 +5,7 @@
;; Author: Markus Triska <markus.triska@gmx.at>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: convenience
-;; Version: 0.9x
+;; Old-Version: 0.9x
;; This file is part of GNU Emacs.
@@ -31,15 +31,11 @@
;;; Code:
-(defconst linum-version "0.9x")
-
-(defvar linum-overlays nil "Overlays used in this buffer.")
-(defvar linum-available nil "Overlays available for reuse.")
+(defvar-local linum-overlays nil "Overlays used in this buffer.")
+(defvar-local linum-available nil "Overlays available for reuse.")
(defvar linum-before-numbering-hook nil
"Functions run in each buffer before line numbering starts.")
-(mapc #'make-variable-buffer-local '(linum-overlays linum-available))
-
(defgroup linum nil
"Show line numbers in the left margin."
:group 'convenience)
@@ -245,6 +241,9 @@ Linum mode is a buffer-local minor mode."
;; continue standard unloading
nil)
+(defconst linum-version "0.9x")
+(make-obsolete-variable 'linum-version 'emacs-version "28.1")
+
(provide 'linum)
;;; linum.el ends here
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index 5fbc6ce0d8c..0b12bdad058 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -1,4 +1,4 @@
-;;; loadhist.el --- lisp functions for working with feature groups
+;;; loadhist.el --- lisp functions for working with feature groups -*- lexical-binding: t -*-
;; Copyright (C) 1995, 1998, 2000-2021 Free Software Foundation, Inc.
@@ -82,12 +82,6 @@ A library name is equivalent to the file name that `load-library' would load."
(when (eq (car-safe x) 'require)
(push (cdr x) requires)))))
-(defsubst file-set-intersect (p q)
- "Return the set intersection of two lists."
- (let (ret)
- (dolist (x p ret)
- (when (memq x q) (push x ret)))))
-
(defun file-dependents (file)
"Return the list of loaded libraries that depend on FILE.
This can include FILE itself.
@@ -97,7 +91,7 @@ A library name is equivalent to the file name that `load-library' would load."
(dependents nil))
(dolist (x load-history dependents)
(when (and (stringp (car x))
- (file-set-intersect provides (file-requires (car x))))
+ (seq-intersection provides (file-requires (car x)) #'eq))
(push (car x) dependents)))))
(defun read-feature (prompt &optional loaded-p)
@@ -234,11 +228,10 @@ If the feature is required by any other loaded code, and prefix arg FORCE
is nil, raise an error.
Standard unloading activities include restoring old autoloads for
-functions defined by the library, undoing any additions that the
-library has made to hook variables or to `auto-mode-alist', undoing
-ELP profiling of functions in that library, unproviding any features
-provided by the library, and canceling timers held in variables
-defined by the library.
+functions defined by the library, removing such functions from
+hooks and `auto-mode-alist', undoing their ELP profiling,
+unproviding any features provided by the library, and canceling
+timers held in variables defined by the library.
If a function `FEATURE-unload-function' is defined, this function
calls it with no arguments, before doing anything else. That function
@@ -287,22 +280,32 @@ something strange, such as redefining an Emacs function."
;; functions which the package might just have installed, and
;; there might be other important state, but this tactic
;; normally works.
- (mapatoms
- (lambda (x)
- (when (and (boundp x)
- (or (and (consp (symbol-value x)) ; Random hooks.
- (string-match "-hooks?\\'" (symbol-name x)))
- (memq x unload-feature-special-hooks))) ; Known abnormal hooks etc.
- (dolist (y unload-function-defs-list)
- (when (and (eq (car-safe y) 'defun)
- (not (get (cdr y) 'autoload)))
- (remove-hook x (cdr y)))))))
- ;; Remove any feature-symbols from auto-mode-alist as well.
- (dolist (y unload-function-defs-list)
- (when (and (eq (car-safe y) 'defun)
- (not (get (cdr y) 'autoload)))
- (setq auto-mode-alist
- (rassq-delete-all (cdr y) auto-mode-alist)))))
+ (let ((removables (cl-loop for def in unload-function-defs-list
+ when (and (eq (car-safe def) 'defun)
+ (not (get (cdr def) 'autoload)))
+ collect (cdr def))))
+ (mapatoms
+ (lambda (x)
+ (when (and (boundp x)
+ (or (and (consp (symbol-value x)) ; Random hooks.
+ (string-match "-hooks?\\'" (symbol-name x)))
+ ;; Known abnormal hooks etc.
+ (memq x unload-feature-special-hooks)))
+ (dolist (func removables)
+ (remove-hook x func)))))
+ (save-current-buffer
+ (dolist (buffer (buffer-list))
+ (pcase-dolist (`(,sym . ,val) (buffer-local-variables buffer))
+ (when (or (and (consp val)
+ (string-match "-hooks?\\'" (symbol-name sym)))
+ (memq sym unload-feature-special-hooks))
+ (set-buffer buffer)
+ (dolist (func removables)
+ (remove-hook sym func t))))))
+ ;; Remove any feature-symbols from auto-mode-alist as well.
+ (dolist (func removables)
+ (setq auto-mode-alist
+ (rassq-delete-all func auto-mode-alist)))))
;; Change major mode in all buffers using one defined in the feature being unloaded.
(unload--set-major-mode)
@@ -313,6 +316,13 @@ something strange, such as redefining an Emacs function."
;; Don't return load-history, it is not useful.
nil)
+;; Obsolete.
+
+(defsubst file-set-intersect (p q)
+ "Return the set intersection of two lists."
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection p q #'eq)))
+
(provide 'loadhist)
;;; loadhist.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 121abda83a0..158c02eceaa 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -1,4 +1,4 @@
-;;; loadup.el --- load up standardly loaded Lisp files for Emacs
+;;; loadup.el --- load up standardly loaded Lisp files for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1992, 1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -57,7 +57,7 @@
;; bidi.c needs for its job.
(setq redisplay--inhibit-bidi t)
-(message "dump mode: %s" dump-mode)
+(message "Dump mode: %s" dump-mode)
;; Add subdirectories to the load-path for files that might get
;; autoloaded when bootstrapping or running Emacs normally.
@@ -112,7 +112,7 @@
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
- (setq purify-flag (make-hash-table :test 'equal :size 80000)))
+ (setq purify-flag (make-hash-table :test #'equal :size 80000)))
(message "Using load-path %s" load-path)
@@ -134,7 +134,7 @@
;; Do it after subr, since both after-load-functions and add-hook are
;; implemented in subr.el.
-(add-hook 'after-load-functions (lambda (f) (garbage-collect)))
+(add-hook 'after-load-functions (lambda (_) (garbage-collect)))
(load "version")
@@ -151,13 +151,14 @@
;; variable its advertised default value (it starts as nil, see
;; xdisp.c).
(setq resize-mini-windows 'grow-only)
-(setq load-source-file-function 'load-with-code-conversion)
+(setq load-source-file-function #'load-with-code-conversion)
(load "files")
;; Load-time macro-expansion can only take effect after setting
;; load-source-file-function because of where it is called in lread.c.
(load "emacs-lisp/macroexp")
-(if (byte-code-function-p (symbol-function 'macroexpand-all))
+(if (or (byte-code-function-p (symbol-function 'macroexpand-all))
+ (subr-native-elisp-p (symbol-function 'macroexpand-all)))
nil
;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply
;; fail until pcase is explicitly loaded. This also means that we have to
@@ -170,7 +171,6 @@
(load "cus-face")
(load "faces") ; after here, `defface' may be used.
-(load "button")
;; We don't want to store loaddefs.el in the repository because it is
;; a generated file; but it is required in order to compile the lisp files.
@@ -187,12 +187,13 @@
;; In case loaddefs hasn't been generated yet.
(file-error (load "ldefs-boot.el")))
-(let ((new (make-hash-table :test 'equal)))
+(let ((new (make-hash-table :test #'equal)))
;; Now that loaddefs has populated definition-prefixes, purify its contents.
(maphash (lambda (k v) (puthash (purecopy k) (purecopy v) new))
definition-prefixes)
(setq definition-prefixes new))
+(load "button") ;After loaddefs, because of define-minor-mode!
(load "emacs-lisp/nadvice")
(load "emacs-lisp/cl-preloaded")
(load "obarray") ;abbrev.el is implemented in terms of obarrays.
@@ -253,9 +254,6 @@
(load "startup")
(load "term/tty-colors")
(load "font-core")
-;; facemenu must be loaded before font-lock, because `facemenu-keymap'
-;; needs to be defined when font-lock is loaded.
-(load "facemenu")
(load "emacs-lisp/syntax")
(load "font-lock")
(load "jit-lock")
@@ -265,6 +263,7 @@
(load "scroll-bar"))
(load "select")
(load "emacs-lisp/timer")
+(load "emacs-lisp/easymenu")
(load "isearch")
(load "rfn-eshadow")
@@ -351,6 +350,7 @@
(load "cus-start") ;Late to reduce customize-rogue (needs loaddefs.el anyway)
(if (not (eq system-type 'ms-dos))
(load "tooltip"))
+(load "international/iso-transl") ; Binds Alt-[ and friends.
;; This file doesn't exist when building a development version of Emacs
;; from the repository. It is generated just after temacs is built.
@@ -400,7 +400,7 @@ lost after dumping")))
emacs-repository-branch (ignore-errors (emacs-repository-get-branch)))
;; A constant, so we shouldn't change it with `setq'.
(defconst emacs-build-number
- (if versions (1+ (apply 'max versions)) 1))))
+ (if versions (1+ (apply #'max versions)) 1))))
(message "Finding pointers to doc strings...")
@@ -430,11 +430,11 @@ lost after dumping")))
;; 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 load-history (mapcar #'purecopy load-history))
(set-buffer-modified-p nil)
-(remove-hook 'after-load-functions (lambda (f) (garbage-collect)))
+(remove-hook 'after-load-functions (lambda (_) (garbage-collect)))
(if (boundp 'load--prefer-newer)
(progn
@@ -449,6 +449,43 @@ lost after dumping")))
;; At this point, we're ready to resume undo recording for scratch.
(buffer-enable-undo "*scratch*")
+(when (featurep 'native-compile)
+ ;; Fix the compilation unit filename to have it working when
+ ;; installed or if the source directory got moved. This is set to be
+ ;; a pair in the form of:
+ ;; (rel-filename-from-install-bin . rel-filename-from-local-bin).
+ (let ((h (make-hash-table :test #'eq))
+ (bin-dest-dir (cadr (member "--bin-dest" command-line-args)))
+ (eln-dest-dir (cadr (member "--eln-dest" command-line-args))))
+ (when (and bin-dest-dir eln-dest-dir)
+ (setq eln-dest-dir
+ (concat eln-dest-dir "native-lisp/" comp-native-version-dir "/"))
+ (mapatoms (lambda (s)
+ (let ((f (symbol-function s)))
+ (when (subr-native-elisp-p f)
+ (puthash (subr-native-comp-unit f) nil h)))))
+ (maphash (lambda (cu _)
+ (let* ((file (native-comp-unit-file cu))
+ (preloaded (equal (substring (file-name-directory file)
+ -10 -1)
+ "preloaded"))
+ (eln-dest-dir-eff (if preloaded
+ (expand-file-name "preloaded"
+ eln-dest-dir)
+ eln-dest-dir)))
+ (native-comp-unit-set-file
+ cu
+ (cons
+ ;; Relative filename from the installed binary.
+ (file-relative-name (expand-file-name
+ (file-name-nondirectory
+ file)
+ eln-dest-dir-eff)
+ bin-dest-dir)
+ ;; Relative filename from the built uninstalled binary.
+ (file-relative-name file invocation-directory)))))
+ h))))
+
(when (hash-table-p purify-flag)
(let ((strings 0)
(vectors 0)
@@ -476,12 +513,19 @@ lost after dumping")))
;; Make sure we will attempt bidi reordering henceforth.
(setq redisplay--inhibit-bidi nil)
+
+
(if dump-mode
(let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp")
((equal dump-mode "dump") "emacs")
((equal dump-mode "bootstrap") "emacs")
((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
(t (error "unrecognized dump mode %s" dump-mode)))))
+ (when (and (featurep 'native-compile)
+ (equal dump-mode "pdump"))
+ ;; Don't enable this before bootstrap is completed, as the
+ ;; compiler infrastructure may not be usable yet.
+ (setq comp-enable-subr-trampolines t))
(message "Dumping under the name %s" output)
(condition-case ()
(delete-file output)
@@ -538,8 +582,9 @@ lost after dumping")))
;; Don't keep `load-file-name' set during the top-level session!
;; Otherwise, it breaks a lot of code which does things like
;; (or load-file-name byte-compile-current-file).
+(setq load-true-file-name nil)
(setq load-file-name nil)
-(eval top-level)
+(eval top-level t)
;; Local Variables:
diff --git a/lisp/locate.el b/lisp/locate.el
index 6073234ce1b..c4dbe2af02b 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -267,9 +267,7 @@ that is, with a prefix arg, you get the default behavior."
(let* ((default (locate-word-at-point))
(input
(read-from-minibuffer
- (if (> (length default) 0)
- (format "Locate (default %s): " default)
- (format "Locate: "))
+ (format-prompt "Locate" default)
nil nil nil 'locate-history-list default t)))
(and (equal input "") default
(setq input default))
@@ -321,9 +319,9 @@ then `locate-post-command-hook'."
(erase-buffer)
(setq locate-current-filter filter)
- (set (make-local-variable 'locate-local-search) search-string)
- (set (make-local-variable 'locate-local-filter) filter)
- (set (make-local-variable 'locate-local-prompt) run-locate-command)
+ (setq-local locate-local-search search-string)
+ (setq-local locate-local-filter filter)
+ (setq-local locate-local-prompt run-locate-command)
(if run-locate-command
(shell-command search-string locate-buffer-name)
@@ -469,8 +467,8 @@ do not work in subdirectories.
buffer-read-only t)
(add-to-invisibility-spec '(dired . t))
(dired-alist-add-1 default-directory (point-min-marker))
- (set (make-local-variable 'dired-directory) "/")
- (set (make-local-variable 'dired-subdir-switches) locate-ls-subdir-switches)
+ (setq-local dired-directory "/")
+ (setq-local dired-subdir-switches locate-ls-subdir-switches)
(setq dired-switches-alist nil)
;; This should support both Unix and Windoze style names
(setq-local directory-listing-before-filename-regexp
@@ -670,11 +668,11 @@ the database on the command line."
(or (file-exists-p database)
(error "Database file %s does not exist" database))
(let ((locate-make-command-line
- (function (lambda (string)
- (cons locate-command
- (list (concat "--database="
- (expand-file-name database))
- string))))))
+ (lambda (string)
+ (cons locate-command
+ (list (concat "--database="
+ (expand-file-name database))
+ string)))))
(locate search-string)))
(defun locate-do-redisplay (&optional arg test-for-subdir)
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 012d2518929..29a0fd8d728 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -1,4 +1,4 @@
-;;; lpr.el --- print Emacs buffer on line printer
+;;; lpr.el --- print Emacs buffer on line printer -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -39,12 +39,10 @@
(memq system-type '(usg-unix-v hpux))
"Non-nil if running on a system type that uses the \"lp\" command.")
-
(defgroup lpr nil
"Print Emacs buffer on line printer."
:group 'text)
-
;;;###autoload
(defcustom printer-name
(and (eq system-type 'ms-dos) "PRN")
@@ -65,8 +63,7 @@ file. If you want to discard the printed output, set this to \"NUL\"."
:tag "Printer Name"
(const :tag "Default" nil)
;; could use string but then we lose completion for files.
- (file :tag "Name"))
- :group 'lpr)
+ (file :tag "Name")))
;;;###autoload
(defcustom lpr-switches nil
@@ -74,16 +71,14 @@ file. If you want to discard the printed output, set this to \"NUL\"."
It is recommended to set `printer-name' instead of including an explicit
switch on this list.
See `lpr-command'."
- :type '(repeat (string :tag "Argument"))
- :group 'lpr)
+ :type '(repeat (string :tag "Argument")))
(defcustom lpr-add-switches (memq system-type '(berkeley-unix gnu/linux))
"Non-nil means construct `-T' and `-J' options for the printer program.
These are made assuming that the program is `lpr';
if you are using some other incompatible printer program,
this variable should be nil."
- :type 'boolean
- :group 'lpr)
+ :type 'boolean)
(defcustom lpr-printer-switch
(if lpr-lp-system
@@ -94,8 +89,7 @@ This switch is used in conjunction with `printer-name'."
:type '(choice :menu-tag "Printer Name Switch"
:tag "Printer Name Switch"
(const :tag "None" nil)
- (string :tag "Printer Switch"))
- :group 'lpr)
+ (string :tag "Printer Switch")))
;;;###autoload
(defcustom lpr-command
@@ -116,8 +110,7 @@ Windows NT and Novell Netware respectively) are handled specially, using
`printer-name' as the destination for output; any other program is
treated like `lpr' except that an explicit filename is given as the last
argument."
- :type 'string
- :group 'lpr)
+ :type 'string)
;; Default is nil, because that enables us to use pr -f
;; which is more reliable than pr with no args, which is what lpr -p does.
@@ -127,22 +120,21 @@ If nil, we run `lpr-page-header-program' to make page headings
and print the result."
:type '(choice (const nil)
(string :tag "Single argument")
- (repeat :tag "Multiple arguments" (string :tag "Argument")))
- :group 'lpr)
+ (repeat :tag "Multiple arguments" (string :tag "Argument"))))
(defcustom print-region-function
(if (memq system-type '(ms-dos windows-nt))
- #'w32-direct-print-region-function
+ (progn
+ (declare-function w32-direct-print-region-function "w32-fns")
+ #'w32-direct-print-region-function)
#'call-process-region)
"Function to call to print the region on a printer.
See definition of `print-region-1' for calling conventions."
- :type 'function
- :group 'lpr)
+ :type 'function)
(defcustom lpr-page-header-program "pr"
"Name of program for adding page headers to a file."
- :type 'string
- :group 'lpr)
+ :type 'string)
;; Berkeley systems support -F, and GNU pr supports both -f and -F,
;; So it looks like -F is a better default.
@@ -151,8 +143,7 @@ See definition of `print-region-1' for calling conventions."
If `%s' appears in any of the strings, it is substituted by the page title.
Note that for correct quoting, `%s' should normally be a separate element.
The variable `lpr-page-header-program' specifies the program to use."
- :type '(repeat string)
- :group 'lpr)
+ :type '(repeat string))
;;;###autoload
(defun lpr-buffer ()
@@ -248,7 +239,7 @@ for further customization of the printer command."
nil
;; Run a separate program to get page headers.
(let ((new-coords (print-region-new-buffer start end)))
- (apply 'call-process-region (car new-coords) (cdr new-coords)
+ (apply #'call-process-region (car new-coords) (cdr new-coords)
lpr-page-header-program t t nil
(mapcar (lambda (e) (format e name))
lpr-page-header-switches)))
@@ -270,7 +261,7 @@ for further customization of the printer command."
(let ((retval
(let ((tempbuf (current-buffer)))
(with-current-buffer buf
- (apply (or print-region-function 'call-process-region)
+ (apply (or print-region-function #'call-process-region)
start end lpr-command
nil tempbuf nil
(nconc (and name lpr-add-switches
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index b60475626f8..9041b9ac0f9 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -28,7 +28,7 @@
;; OVERVIEW ==========================================================
;; This file advises the function `insert-directory' to implement it
-;; directly from Emacs lisp, without running ls in a subprocess.
+;; directly from Emacs Lisp, without running ls in a subprocess.
;; This is useful if you don't have ls installed (ie, on MS Windows).
;; This function can use regexps instead of shell wildcards. If you
@@ -276,7 +276,9 @@ supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
is non-nil; otherwise, it interprets wildcards as regular expressions
to match file names. It does not support all `ls' switches -- those
that work are: A a B C c F G g h i n R r S s t U u v X. The l switch
-is assumed to be always present and cannot be turned off."
+is assumed to be always present and cannot be turned off.
+Long variants of the above switches, as documented for GNU `ls',
+are also supported; unsupported long options are silently ignored."
(if ls-lisp-use-insert-directory-program
(funcall orig-fun
file switches wildcard full-directory-p)
@@ -284,13 +286,21 @@ is assumed to be always present and cannot be turned off."
(let ((handler (find-file-name-handler (expand-file-name file)
'insert-directory))
(orig-file file)
- wildcard-regexp)
+ wildcard-regexp
+ (ls-lisp-dirs-first
+ (or ls-lisp-dirs-first
+ (string-match "--group-directories-first" switches))))
(if handler
(funcall handler 'insert-directory file switches
wildcard full-directory-p)
- ;; Remove --dired switch
- (if (string-match "--dired " switches)
- (setq switches (replace-match "" nil nil switches)))
+ (when (string-match "--group-directories-first" switches)
+ ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in
+ ;; reverse order:
+ (setq ls-lisp-dirs-first t)
+ (setq switches (replace-match "" nil nil switches)))
+ ;; Remove unrecognized long options, and convert the
+ ;; recognized ones to their short variants.
+ (setq switches (ls-lisp--sanitize-switches switches))
;; Convert SWITCHES to a list of characters.
(setq switches (delete ?\ (delete ?- (append switches nil))))
;; Sometimes we get ".../foo*/" as FILE. While the shell and
@@ -435,9 +445,9 @@ not contain `d', so that a full listing is expected."
;; text. But if the listing is empty, as e.g. in empty
;; directories with -a removed from switches, point will be
;; before the inserted text, and dired-insert-directory will
- ;; not indent the listing correctly. Going to the end of the
- ;; buffer fixes that.
- (unless files (goto-char (point-max)))
+ ;; not indent the listing correctly. Getting past the
+ ;; inserted text solves this.
+ (unless (cdr total-line) (forward-line 2))
(if (memq ?R switches)
;; List the contents of all directories recursively.
;; cadr of each element of `file-alist' is t for
@@ -836,6 +846,9 @@ Return nil if no time switch found."
((memq ?t switches) 5) ; last modtime
((memq ?u switches) 4))) ; last access
+(defvar ls-lisp--time-locale nil
+ "Locale to be used for formatting file times.")
+
(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,
@@ -851,11 +864,13 @@ All ls time options, namely c, t and u, are handled."
(condition-case nil
;; Use traditional time format in the C or POSIX locale,
;; ISO-style time format otherwise, so columns line up.
- (let ((locale system-time-locale))
+ (let ((locale (or system-time-locale ls-lisp--time-locale)))
(if (not locale)
(let ((vars '("LC_ALL" "LC_TIME" "LANG")))
(while (and vars (not (setq locale (getenv (car vars)))))
- (setq vars (cdr vars)))))
+ (setq vars (cdr vars)))
+ ;; Cache the locale for next calls.
+ (setq ls-lisp--time-locale (or locale "C"))))
(if (member locale '("C" "POSIX"))
(setq locale nil))
(format-time-string
@@ -885,6 +900,60 @@ All ls time options, namely c, t and u, are handled."
;; Continue standard unloading.
nil)
+(defun ls-lisp--sanitize-switches (switches)
+ "Convert long options of GNU 'ls' to their short form.
+Conversion is done only for flags supported by ls-lisp.
+Long options not supported by ls-lisp are removed.
+Supported options are: A a B C c F G g h i n R r S s t U u v X.
+The l switch is assumed to be always present and cannot be turned off."
+ (let ((lsflags '(("-a" . "--all")
+ ("-A" . "--almost-all")
+ ("-B" . "--ignore-backups")
+ ("-C" . "--color")
+ ("-F" . "--classify")
+ ("-G" . "--no-group")
+ ("-h" . "--human-readable")
+ ("-H" . "--dereference-command-line")
+ ("-i" . "--inode")
+ ("-n" . "--numeric-uid-gid")
+ ("-r" . "--reverse")
+ ("-R" . "--recursive")
+ ("-s" . "--size")
+ ("-S" . "--sort.*[ \\\t]")
+ ("" . "--group-directories-first")
+ ("" . "--author")
+ ("" . "--escape")
+ ("" . "--directory")
+ ("" . "--dired")
+ ("" . "--file-type")
+ ("" . "--format")
+ ("" . "--full-time")
+ ("" . "--si")
+ ("" . "--dereference-command-line-symlink-to-dir")
+ ("" . "--hide")
+ ("" . "--hyperlink")
+ ("" . "--ignore")
+ ("" . "--kibibytes")
+ ("" . "--dereference")
+ ("" . "--literal")
+ ("" . "--hide-control-chars")
+ ("" . "--show-control-chars")
+ ("" . "--quote-name")
+ ("" . "--context")
+ ("" . "--help")
+ ;; ("" . "--indicator-style.*[ \\\t]")
+ ;; ("" . "--quoting-style.*[ \t\\]")
+ ;; ("" . "--time.*[ \\\t]")
+ ;; ("" . "--time-style.*[ \\\t]")
+ ;; ("" . "--tabsize.*[ \\\t]")
+ ;; ("" . "--width.*[ \\\t]")
+ ("" . "--.*=.*[ \\\t\n]?") ;; catch all with '=' sign in
+ ("" . "--version"))))
+ (dolist (f lsflags)
+ (if (string-match (cdr f) switches)
+ (setq switches (replace-match (car f) nil nil switches))))
+ (string-trim switches)))
+
(provide 'ls-lisp)
;;; ls-lisp.el ends here
diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el
index d1b99a96e25..af327442c28 100644
--- a/lisp/mail/binhex.el
+++ b/lisp/mail/binhex.el
@@ -29,12 +29,6 @@
;;; Code:
-(eval-and-compile
- (defalias 'binhex-char-int
- (if (fboundp 'char-int)
- 'char-int
- 'identity)))
-
(defgroup binhex nil
"Decoding of BinHex (binary-to-hexadecimal) data."
:group 'mail
@@ -44,19 +38,16 @@
"Non-nil value should be a string that names a binhex decoder.
The program should expect to read binhex data on its standard
input and write the converted data to its standard output."
- :type 'string
- :group 'binhex)
+ :type 'string)
(defcustom binhex-decoder-switches '("-d")
"List of command line flags passed to the command `binhex-decoder-program'."
- :group 'binhex
:type '(repeat string))
(defcustom binhex-use-external
(executable-find binhex-decoder-program)
"Use external binhex program."
:version "22.1"
- :group 'binhex
:type 'boolean)
(defconst binhex-alphabet-decoding-alist
@@ -83,12 +74,10 @@ input and write the converted data to its standard output."
"^[^:]...............................................................$")
(defconst binhex-end-line ":$") ; unused
-(defvar binhex-temporary-file-directory
- (cond ((fboundp 'temp-directory) (temp-directory))
- ((boundp 'temporary-file-directory) temporary-file-directory)
- ("/tmp/")))
+(make-obsolete-variable 'binhex-temporary-file-directory
+ 'temporary-file-directory "28.1")
-(defun binhex-insert-char (char &optional count ignored buffer)
+(defun binhex-insert-char (char &optional count _ignored buffer)
"Insert COUNT copies of CHARACTER into BUFFER."
(if (or (null buffer) (eq buffer (current-buffer)))
(insert-char char count)
@@ -152,14 +141,14 @@ input and write the converted data to its standard output."
(defun binhex-string-big-endian (string)
(let ((ret 0) (i 0) (len (length string)))
(while (< i len)
- (setq ret (+ (ash ret 8) (binhex-char-int (aref string i)))
+ (setq ret (+ (ash ret 8) (aref string i))
i (1+ i)))
ret))
(defun binhex-string-little-endian (string)
(let ((ret 0) (i 0) (shift 0) (len (length string)))
(while (< i len)
- (setq ret (+ ret (ash (binhex-char-int (aref string i)) shift))
+ (setq ret (+ ret (ash (aref string i) shift))
i (1+ i)
shift (+ shift 8)))
ret))
@@ -169,11 +158,11 @@ input and write the converted data to its standard output."
(let ((pos (point-min)) len)
(vector
(prog1
- (setq len (binhex-char-int (char-after pos)))
+ (setq len (char-after pos))
(setq pos (1+ pos)))
(buffer-substring pos (setq pos (+ pos len)))
(prog1
- (setq len (binhex-char-int (char-after pos)))
+ (setq len (char-after pos))
(setq pos (1+ pos)))
(buffer-substring pos (setq pos (+ pos 4)))
(buffer-substring pos (setq pos (+ pos 4)))
@@ -281,11 +270,12 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(defun binhex-decode-region-external (start end)
"Binhex decode region between START and END using external decoder."
(interactive "r")
- (let ((cbuf (current-buffer)) firstline work-buffer
+ (let ((cbuf (current-buffer))
+ work-buffer ;; firstline
(file-name (expand-file-name
(concat (binhex-decode-region-internal start end t)
".data")
- binhex-temporary-file-directory)))
+ temporary-file-directory)))
(save-excursion
(goto-char start)
(when (re-search-forward binhex-begin-line nil t)
@@ -295,9 +285,9 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(set-buffer (setq work-buffer
(generate-new-buffer " *binhex-work*")))
(buffer-disable-undo work-buffer)
- (insert-buffer-substring cbuf firstline end)
- (cd binhex-temporary-file-directory)
- (apply 'call-process-region
+ (insert-buffer-substring cbuf nil end) ;; firstline
+ (cd temporary-file-directory)
+ (apply #'call-process-region
(point-min)
(point-max)
binhex-decoder-program
@@ -325,6 +315,8 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(binhex-decode-region-external start end)
(binhex-decode-region-internal start end)))
+(define-obsolete-function-alias 'binhex-char-int #'identity "28.1")
+
(provide 'binhex)
;;; binhex.el ends here
diff --git a/lisp/mail/blessmail.el b/lisp/mail/blessmail.el
index 505ce5d4767..f380f0df290 100644
--- a/lisp/mail/blessmail.el
+++ b/lisp/mail/blessmail.el
@@ -1,4 +1,4 @@
-;;; blessmail.el --- decide whether movemail needs special privileges -*- no-byte-compile: t -*-
+;;; blessmail.el --- decide whether movemail needs special privileges -*- no-byte-compile: t; lexical-binding: t; -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 684c465da5b..14c93f2fc8e 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -1,4 +1,4 @@
-;;; emacsbug.el --- command to report Emacs bugs to appropriate mailing list
+;;; emacsbug.el --- command to report Emacs bugs to appropriate mailing list -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1994, 1997-1998, 2000-2021 Free Software
;; Foundation, Inc.
@@ -45,12 +45,10 @@
(defcustom report-emacs-bug-no-confirmation nil
"If non-nil, suppress the confirmations asked for the sake of novice users."
- :group 'emacsbug
:type 'boolean)
(defcustom report-emacs-bug-no-explanations nil
"If non-nil, suppress the explanations given for the sake of novice users."
- :group 'emacsbug
:type 'boolean)
;; User options end here.
@@ -58,13 +56,11 @@
(defvar report-emacs-bug-orig-text nil
"The automatically-created initial text of the bug report.")
-(defvar report-emacs-bug-send-command nil
+(defvar-local report-emacs-bug-send-command nil
"Name of the command to send the bug report, as a string.")
-(make-variable-buffer-local 'report-emacs-bug-send-command)
-(defvar report-emacs-bug-send-hook nil
+(defvar-local report-emacs-bug-send-hook nil
"Hook run before sending the bug report.")
-(make-variable-buffer-local 'report-emacs-bug-send-hook)
(declare-function x-server-vendor "xfns.c" (&optional terminal))
(declare-function x-server-version "xfns.c" (&optional terminal))
@@ -206,9 +202,13 @@ This requires either the macOS \"open\" command, or the freedesktop
(defvar message-sendmail-envelope-from)
;;;###autoload
-(defun report-emacs-bug (topic &optional unused)
+(defun report-emacs-bug (topic &optional _unused)
"Report a bug in GNU Emacs.
-Prompts for bug subject. Leaves you in a mail buffer."
+Prompts for bug subject. Leaves you in a mail buffer.
+
+Already submitted bugs can be found in the Emacs bug tracker:
+
+ https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1"
(declare (advertised-calling-convention (topic) "24.5"))
(interactive "sBug Subject: ")
;; The syntax `version;' is preferred to `[version]' because the
@@ -217,10 +217,10 @@ Prompts for bug subject. Leaves you in a mail buffer."
(let ((from-buffer (current-buffer))
(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 (messages-buffer)
- (point-max-marker)))
+ user-point) ;; message-end-point
+ ;; (setq message-end-point
+ ;; (with-current-buffer (messages-buffer)
+ ;; (point-max-marker)))
(condition-case nil
;; For the novice user make sure there's always enough space for
;; the mail and the warnings buffer on this frame (Bug#10873).
@@ -237,12 +237,12 @@ Prompts for bug subject. Leaves you in a mail buffer."
;; 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)
+ (setq-local message-strip-special-text-properties nil)
;; Make sure we default to the From: address as envelope when sending
;; through sendmail. FIXME: Why?
(when (and (not (message--sendmail-envelope-from))
(message-bogus-recipient-p (message-make-address)))
- (set (make-local-variable 'message-sendmail-envelope-from) 'header)))
+ (setq-local message-sendmail-envelope-from 'header)))
(rfc822-goto-eoh)
(forward-line 1)
;; Move the mail signature to the proper place.
@@ -261,7 +261,7 @@ Prompts for bug subject. Leaves you in a mail buffer."
"Bug-GNU-Emacs"
'face 'link
'help-echo (concat "mouse-2, RET: Follow this link")
- 'action (lambda (button)
+ 'action (lambda (_button)
(browse-url "https://lists.gnu.org/r/bug-gnu-emacs/"))
'follow-link t)
(insert " mailing list\nand the GNU bug tracker at ")
@@ -269,8 +269,8 @@ Prompts for bug subject. Leaves you in a mail buffer."
"debbugs.gnu.org"
'face 'link
'help-echo (concat "mouse-2, RET: Follow this link")
- 'action (lambda (button)
- (browse-url "https://debbugs.gnu.org/"))
+ 'action (lambda (_button)
+ (browse-url "https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1"))
'follow-link t)
(insert ". Please check that
@@ -301,42 +301,7 @@ usually do not have translators for other languages.\n\n")))
(let ((txt (delete-and-extract-region (1+ user-point) (point))))
(insert (propertize "\n" 'display txt)))
- (insert "\nIn " (emacs-version))
- (if emacs-build-system
- (insert " built on " emacs-build-system))
- (insert "\n")
-
- (if (stringp emacs-repository-version)
- (insert "Repository revision: " emacs-repository-version "\n"))
- (if (stringp emacs-repository-branch)
- (insert "Repository branch: " emacs-repository-branch "\n"))
- (if (fboundp 'x-server-vendor)
- (condition-case nil
- ;; This is used not only for X11 but also W32 and others.
- (insert "Windowing system distributor '" (x-server-vendor)
- "', version "
- (mapconcat 'number-to-string (x-server-version) ".") "\n")
- (error t)))
- (let ((os (ignore-errors (report-emacs-bug--os-description))))
- (if (stringp os)
- (insert "System Description: " os "\n\n")))
- (let ((message-buf (get-buffer "*Messages*")))
- (if message-buf
- (let (beg-pos
- (end-pos message-end-point))
- (with-current-buffer message-buf
- (goto-char end-pos)
- (forward-line -10)
- (setq beg-pos (point)))
- (terpri (current-buffer) t)
- (insert "Recent messages:\n")
- (insert-buffer-substring message-buf beg-pos end-pos))))
- (insert "\n")
- (when (and system-configuration-options
- (not (equal system-configuration-options "")))
- (insert "Configured using:\n 'configure "
- system-configuration-options "'\n\n")
- (fill-region (line-beginning-position -1) (point)))
+ (emacs-bug--system-description)
(insert "Configured features:\n" system-configuration-features "\n\n")
(fill-region (line-beginning-position -1) (point))
(insert "Important settings:\n")
@@ -344,7 +309,7 @@ usually do not have translators for other languages.\n\n")))
(lambda (var)
(let ((val (getenv var)))
(if val (insert (format " value of $%s: %s\n" var val)))))
- '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSPATH"
+ '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSNATIVELOADPATH" "EMACSPATH"
"LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES"
"LC_MONETARY" "LC_NUMERIC" "LC_TIME" "LANG" "XMODIFIERS"))
(insert (format " locale-coding-system: %s\n" locale-coding-system))
@@ -380,10 +345,10 @@ usually do not have translators for other languages.\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" 'info-emacs-bug)
+ (define-key (current-local-map) "\C-c\C-i" #'info-emacs-bug)
(if can-insert-mail
(define-key (current-local-map) "\C-c\M-i"
- 'report-emacs-bug-insert-to-mailer))
+ #'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
@@ -409,80 +374,155 @@ usually do not have translators for other languages.\n\n")))
(shrink-window-if-larger-than-buffer (get-buffer-window "*Bug Help*")))
;; Make it less likely people will send empty messages.
(if report-emacs-bug-send-hook
- (add-hook report-emacs-bug-send-hook 'report-emacs-bug-hook nil t))
+ (add-hook report-emacs-bug-send-hook #'report-emacs-bug-hook nil t))
(goto-char (point-max))
(skip-chars-backward " \t\n")
- (make-local-variable 'report-emacs-bug-orig-text)
- (setq report-emacs-bug-orig-text
- (buffer-substring-no-properties (point-min) (point)))
+ (setq-local report-emacs-bug-orig-text
+ (buffer-substring-no-properties (point-min) (point)))
(goto-char user-point)))
-(define-obsolete-function-alias 'report-emacs-bug-info 'info-emacs-bug "24.3")
+(defun emacs-bug--system-description ()
+ (insert "\nIn " (emacs-version))
+ (if emacs-build-system
+ (insert " built on " emacs-build-system))
+ (insert "\n")
+
+ (if (stringp emacs-repository-version)
+ (insert "Repository revision: " emacs-repository-version "\n"))
+ (if (stringp emacs-repository-branch)
+ (insert "Repository branch: " emacs-repository-branch "\n"))
+ (if (fboundp 'x-server-vendor)
+ (condition-case nil
+ ;; This is used not only for X11 but also W32 and others.
+ (insert "Windowing system distributor '" (x-server-vendor)
+ "', version "
+ (mapconcat #'number-to-string (x-server-version) ".") "\n")
+ (error t)))
+ (let ((os (ignore-errors (report-emacs-bug--os-description))))
+ (if (stringp os)
+ (insert "System Description: " os "\n\n")))
+ (when (and system-configuration-options
+ (not (equal system-configuration-options "")))
+ (insert "Configured using:\n 'configure "
+ system-configuration-options "'\n\n")
+ (fill-region (line-beginning-position -1) (point))))
+
+(define-obsolete-function-alias 'report-emacs-bug-info #'info-emacs-bug "24.3")
(defun report-emacs-bug-hook ()
"Do some checking before sending a bug report."
- (save-excursion
- (goto-char (point-max))
- (skip-chars-backward " \t\n")
- (and (= (- (point) (point-min))
- (length report-emacs-bug-orig-text))
- (string-equal (buffer-substring-no-properties (point-min) (point))
- report-emacs-bug-orig-text)
- (error "No text entered in bug report"))
- ;; Warning for novice users.
- (when (and (string-match "bug-gnu-emacs@gnu\\.org" (mail-fetch-field "to"))
- (not report-emacs-bug-no-confirmation)
- (not (yes-or-no-p
- "Send this bug report to the Emacs maintainers? ")))
- (with-output-to-temp-buffer "*Bug Help*"
- (princ (substitute-command-keys
- (format "\
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (and (= (- (point) (point-min))
+ (length report-emacs-bug-orig-text))
+ (string-equal (buffer-substring-no-properties (point-min) (point))
+ report-emacs-bug-orig-text)
+ (error "No text entered in bug report"))
+ ;; Warning for novice users.
+ (when (and (string-match "bug-gnu-emacs@gnu\\.org" (mail-fetch-field "to"))
+ (not report-emacs-bug-no-confirmation)
+ (not (yes-or-no-p
+ "Send this bug report to the Emacs maintainers? ")))
+ (with-output-to-temp-buffer "*Bug Help*"
+ (princ (substitute-command-keys
+ (format "\
You invoked the command M-x report-emacs-bug,
but you decided not to mail the bug report to the Emacs maintainers.
If you want to mail it to someone else instead,
please insert the proper e-mail address after \"To: \",
and send the mail again%s."
- (if report-emacs-bug-send-command
- (format " using \\[%s]"
- report-emacs-bug-send-command)
- "")))))
- (error "M-x report-emacs-bug was canceled, please read *Bug Help* buffer"))
- ;; Query the user for the SMTP method, so that we can skip
- ;; questions about From header validity if the user is going to
- ;; use mailclient, anyway.
- (when (or (and (derived-mode-p 'message-mode)
- (eq message-send-mail-function 'sendmail-query-once))
- (and (not (derived-mode-p 'message-mode))
- (eq send-mail-function 'sendmail-query-once)))
- (sendmail-query-user-about-smtp)
- (when (derived-mode-p 'message-mode)
- (setq message-send-mail-function (message-default-send-mail-function))))
- (or report-emacs-bug-no-confirmation
- ;; mailclient.el does not need a valid From
- (if (derived-mode-p 'message-mode)
- (eq message-send-mail-function 'message-send-mail-with-mailclient)
- (eq send-mail-function 'mailclient-send-it))
- ;; Not narrowing to the headers, but that's OK.
- (let ((from (mail-fetch-field "From")))
- (and (or (not from)
- (message-bogus-recipient-p from)
- ;; This is the default user-mail-address. On today's
- ;; systems, it seems more likely to be wrong than right,
- ;; since most people don't run their own mail server.
- (string-match (format "\\<%s@%s\\>"
- (regexp-quote (user-login-name))
- (regexp-quote (system-name)))
- from))
- (not (yes-or-no-p
- (format-message "Is `%s' really your email address? "
- from)))
- (error "Please edit the From address and try again"))))
- ;; Bury the help buffer (if it's shown).
- (when-let ((help (get-buffer "*Bug Help*")))
- (when (get-buffer-window help)
- (quit-window nil (get-buffer-window help))))))
+ (if report-emacs-bug-send-command
+ (format " using \\[%s]"
+ report-emacs-bug-send-command)
+ "")))))
+ (error "M-x report-emacs-bug was canceled, please read *Bug Help* buffer"))
+ ;; Query the user for the SMTP method, so that we can skip
+ ;; questions about From header validity if the user is going to
+ ;; use mailclient, anyway.
+ (when (or (and (derived-mode-p 'message-mode)
+ (eq (message-default-send-mail-function) 'sendmail-query-once))
+ (and (not (derived-mode-p 'message-mode))
+ (eq send-mail-function 'sendmail-query-once)))
+ (setq send-mail-function (sendmail-query-user-about-smtp))
+ (when (derived-mode-p 'message-mode)
+ (setq message-send-mail-function (message-default-send-mail-function))
+ (add-hook 'message-sent-hook
+ (lambda ()
+ (when (y-or-n-p "Save this mail sending choice?")
+ (customize-save-variable 'send-mail-function
+ send-mail-function)))
+ nil t)))
+ (or report-emacs-bug-no-confirmation
+ ;; mailclient.el does not need a valid From
+ (eq send-mail-function 'mailclient-send-it)
+ ;; Not narrowing to the headers, but that's OK.
+ (let ((from (mail-fetch-field "From")))
+ (when (and (or (not from)
+ (message-bogus-recipient-p from)
+ ;; This is the default user-mail-address. On
+ ;; today's systems, it seems more likely to
+ ;; be wrong than right, since most people
+ ;; don't run their own mail server.
+ (string-match (format "\\<%s@%s\\>"
+ (regexp-quote (user-login-name))
+ (regexp-quote (system-name)))
+ from))
+ (not (yes-or-no-p
+ (format-message "Is `%s' really your email address? "
+ from))))
+ (goto-char (point-min))
+ (re-search-forward "^From: " nil t)
+ (error "Please edit the From address and try again"))))
+ ;; Bury the help buffer (if it's shown).
+ (when-let ((help (get-buffer "*Bug Help*")))
+ (when (get-buffer-window help)
+ (quit-window nil (get-buffer-window help)))))
+;;;###autoload
+(defun submit-emacs-patch (subject file)
+ "Send an Emacs patch to the Emacs maintainers.
+Interactively, you will be prompted for SUBJECT and a patch FILE
+name (which will be attached to the mail). You will end up in a
+Message buffer where you can explain more about the patch."
+ (interactive "sThis patch is about: \nfPatch file name: ")
+ (switch-to-buffer "*Patch Help*")
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert "Thank you for considering submitting a patch to the Emacs project.\n\n"
+ "Please describe what the patch fixes (or, if it's a new feature, what it\n"
+ "implements) in the mail buffer below. When done, use the `C-c C-c' command\n"
+ "to send the patch as an email to the Emacs issue tracker.\n\n"
+ "If this is the first time you've submitted an Emacs patch, please\n"
+ "read the ")
+ (insert-text-button
+ "CONTRIBUTE"
+ 'action (lambda (_)
+ (view-buffer
+ (find-file-noselect
+ (expand-file-name "CONTRIBUTE" installation-directory)))))
+ (insert " file first.\n")
+ (goto-char (point-min))
+ (view-mode 1)
+ (button-mode 1))
+ (message-mail-other-window report-emacs-bug-address subject)
+ (insert "\n\n\n")
+ (emacs-bug--system-description)
+ (mml-attach-file file "text/patch" nil "attachment")
+ (message-goto-body)
+ (message "Write a description of the patch and use `C-c C-c' to send it")
+ (add-hook 'message-send-hook
+ (lambda ()
+ (message-goto-body)
+ (insert "Tags: patch\n\n"))
+ nil t)
+ (message-add-action
+ (lambda ()
+ ;; Bury the help buffer (if it's shown).
+ (when-let ((help (get-buffer "*Patch Help*")))
+ (when (get-buffer-window help)
+ (quit-window nil (get-buffer-window help)))))
+ 'send))
(provide 'emacsbug)
diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el
index b9920023d82..cec573642ec 100644
--- a/lisp/mail/feedmail.el
+++ b/lisp/mail/feedmail.el
@@ -163,7 +163,7 @@
;; (autoload 'feedmail-buffer-to-smtpmail "feedmail" nil t)
;; (setq feedmail-buffer-eating-function 'feedmail-buffer-to-smtpmail)
;;
-;; Alternatively, the FLIM <http://www.m17n.org/FLIM/> project
+;; Alternatively, the FLIM <https://www.m17n.org/FLIM/> project
;; provides a library called smtp.el. If you want to use that, the above lines
;; would be:
;;
@@ -622,22 +622,25 @@ to arrange for the message to get a From: line."
(defcustom feedmail-sendmail-f-doesnt-sell-me-out nil
- "Says whether the sendmail program issues a warning header if called with \"-f\".
+ "Whether sendmail should issue a warning header if called with \"-f\".
The sendmail program has a useful feature to let you set the envelope FROM
address via a command line option, \"-f\". Unfortunately, it also has a widely
disliked default behavior of selling you out if you do that by inserting
an unattractive warning in the headers. It looks something like this:
- X-Authentication-Warning: u1.example.com: niceguy set sender to niceguy@example.com using -f
-
-It is possible to configure sendmail to not do this, but such a reconfiguration
-is not an option for many users. As this is the default behavior of most
-sendmail installations, one can mostly only wish it were otherwise. If feedmail
-believes the sendmail program will sell you out this way, it won't use the \"-f\"
-option when calling sendmail. If it doesn't think sendmail will sell you out,
-it will use the \"-f\" \(since it is a handy feature). You control what
-feedmail thinks with this variable. The default is nil, meaning that feedmail
-will believe that sendmail will sell you out."
+ X-Authentication-Warning: u1.example.com: niceguy set
+ sender to niceguy@example.com using -f
+
+It is possible to configure sendmail to not do this, but such a
+reconfiguration is not an option for many users. As this is the
+default behavior of most sendmail installations, one can mostly
+only wish it were otherwise. If feedmail believes the sendmail
+program will sell you out this way, it won't use the \"-f\"
+option when calling sendmail. If it doesn't think sendmail will
+sell you out, it will use the \"-f\" \(since it is a handy
+feature). You control what feedmail thinks with this variable.
+The default is nil, meaning that feedmail will believe that
+sendmail will sell you out."
:version "24.1"
:group 'feedmail-headers
:type 'boolean
@@ -807,7 +810,8 @@ fiddle-plex.
feedmail will use this list of fiddle-plexes to manipulate user-specified
message header fields. It does this after it has completed all normal
-message header field manipulation and before calling `feedmail-last-chance-hook'.
+message header field manipulation and before calling
+`feedmail-last-chance-hook'.
For an explanation of fiddle-plexes, see the documentation for the
variable `feedmail-fiddle-plex-blurb'. In contrast to some other fiddle-plex
@@ -889,13 +893,14 @@ called and will consult `feedmail-spray-this-address' to find the
stripped envelope email address (no comments or angle brackets). The
function should return an embellished form of the address.
-The recipe for sending form letters is: (1) create a message with all
-addressees on Bcc: headers; (2) tell feedmail to remove Bcc: headers
-before sending the message; (3) create a function which will embellish
-stripped addresses, if desired; (4) define `feedmail-spray-address-fiddle-plex-list'
-appropriately; (5) send the message with `feedmail-enable-spray' set
-non-nil; (6) stand back and watch co-workers wonder at how efficient
-you are at accomplishing inherently inefficient things."
+The recipe for sending form letters is: (1) create a message with
+all addressees on Bcc: headers; (2) tell feedmail to remove Bcc:
+headers before sending the message; (3) create a function which
+will embellish stripped addresses, if desired; (4) define
+`feedmail-spray-address-fiddle-plex-list' appropriately; (5) send
+the message with `feedmail-enable-spray' set non-nil; (6) stand
+back and watch co-workers wonder at how efficient you are at
+accomplishing inherently inefficient things."
:group 'feedmail-spray
:type 'sexp ; too complex to be described accurately
)
@@ -1203,7 +1208,7 @@ no longer matches to transformed string. Used by function
feedmail-tidy-up-slug and indirectly by feedmail-queue-subject-slug-maker."
:version "24.1"
:group 'feedmail-queue
- :type 'string
+ :type 'regexp
)
@@ -1336,19 +1341,22 @@ variable, but may depend on its value as described here.")
(defun feedmail-mail-send-hook-splitter ()
"Facilitate dividing `mail-send-hook' things into queued and immediate cases.
-If you have `mail-send-hook' functions that should only be called for sending/
-queueing messages or only be called for the sending of queued messages, this is
-for you. Add this function to `mail-send-hook' with something like this:
+If you have `mail-send-hook' functions that should only be called
+for sending/ queueing messages or only be called for the sending
+of queued messages, this is for you. Add this function to
+`mail-send-hook' with something like this:
(add-hook \\='mail-send-hook \\='feedmail-mail-send-hook-splitter)
-Then add the functions you want called to either `feedmail-mail-send-hook-queued'
-or `feedmail-mail-send-hook', as appropriate. The distinction is that
-`feedmail-mail-send-hook' will be called when you send mail from a composition
-buffer (typically by typing C-c C-c), whether the message is sent immediately
-or placed in the queue or drafts directory. `feedmail-mail-send-hook-queued' is
-called when messages are being sent from the queue directory, typically via a
-call to `feedmail-run-the-queue'."
+Then add the functions you want called to either
+`feedmail-mail-send-hook-queued' or `feedmail-mail-send-hook', as
+appropriate. The distinction is that `feedmail-mail-send-hook'
+will be called when you send mail from a composition
+buffer (typically by typing C-c C-c), whether the message is sent
+immediately or placed in the queue or drafts directory.
+`feedmail-mail-send-hook-queued' is called when messages are
+being sent from the queue directory, typically via a call to
+`feedmail-run-the-queue'."
(feedmail-say-debug ">in-> feedmail-mail-send-hook-splitter %s" feedmail-queue-runner-is-active)
(if feedmail-queue-runner-is-active
(run-hooks 'feedmail-mail-send-hook-queued)
@@ -1373,7 +1381,7 @@ It shows the simple addresses and gets a confirmation. Use as:
(save-window-excursion
(display-buffer (set-buffer (get-buffer-create " F-C-A-H-E")))
(erase-buffer)
- (insert (mapconcat 'identity feedmail-address-list " "))
+ (insert (mapconcat #'identity feedmail-address-list " "))
(if (not (y-or-n-p "How do you like them apples? "))
(error "FQM: Sending...gave up in last chance hook"))))
@@ -1584,10 +1592,10 @@ Feeds the buffer to it."
(feedmail-say-debug ">in-> feedmail-buffer-to-binmail %s" addr-listoid)
(set-buffer prepped)
(apply
- 'call-process-region
+ #'call-process-region
(append (list (point-min) (point-max) "/bin/sh" nil errors-to nil "-c"
(format feedmail-binmail-template
- (mapconcat 'identity addr-listoid " "))))))
+ (mapconcat #'identity addr-listoid " "))))))
(defvar sendmail-program)
@@ -1601,7 +1609,7 @@ local gurus."
(require 'sendmail)
(feedmail-say-debug ">in-> feedmail-buffer-to-sendmail %s" addr-listoid)
(set-buffer prepped)
- (apply 'call-process-region
+ (apply #'call-process-region
(append (list (point-min) (point-max) sendmail-program
nil errors-to nil "-oi" "-t")
;; provide envelope "from" to sendmail; results will vary
@@ -1630,7 +1638,7 @@ local gurus."
(let ((result (smtpmail-via-smtp addr-listoid prepped)))
(when result
(set-buffer errors-to)
- (insert "Send via smtpmail failed: %s" result)
+ (insert "Send via smtpmail failed: " result)
(let ((case-fold-search t)
;; don't be overconfident about the name of the trace buffer
(tracer (concat "trace.*smtp.*" (regexp-quote smtpmail-smtp-server))))
@@ -1911,7 +1919,7 @@ see the variable feedmail-prompt-before-queue-user-alist.
(and (stringp feedmail-prompt-before-queue-help-supplement)
(princ feedmail-prompt-before-queue-help-supplement))
(with-current-buffer standard-output
- (if (fboundp 'help-mode) (help-mode)))))
+ (help-mode))))
(defun feedmail-message-action-scroll-up ()
@@ -1972,13 +1980,9 @@ backup file names and the like)."
(list-of-possible-fqms))
(if (and (> q-cnt 0) feedmail-queue-runner-confirm-global)
(setq do-the-run
- (if (fboundp 'y-or-n-p-with-timeout)
- (y-or-n-p-with-timeout (format "FQM: Draft: %dm+%d, Queue: %dm+%d; run the queue? "
- d-cnt d-oth q-cnt q-oth)
- 5 nil)
- (y-or-n-p (format "FQM: Draft: %dm+%d, Queue: %dm+%d; run the queue? "
- d-cnt d-oth q-cnt q-oth))
- )))
+ (y-or-n-p-with-timeout (format "FQM: Draft: %dm+%d, Queue: %dm+%d; run the queue? "
+ d-cnt d-oth q-cnt q-oth)
+ 5 nil)))
(if (not do-the-run)
(setq messages-skipped q-cnt)
(save-window-excursion
@@ -1997,15 +2001,10 @@ backup file names and the like)."
(if (and already-buffer (buffer-modified-p already-buffer))
(save-window-excursion
(display-buffer (set-buffer already-buffer))
- (if (fboundp 'y-or-n-p-with-timeout)
- ;; make a guess that the user just forgot to save
- (if (y-or-n-p-with-timeout (format "FQM: Visiting %s; save before send? " blobby) 10 t)
- (save-buffer))
- (if (y-or-n-p (format "FQM: Visiting %s; save before send? " blobby))
- (save-buffer))
- )))
-
- (set-buffer blobby-buffer)
+ ;; make a guess that the user just forgot to save
+ (if (y-or-n-p-with-timeout (format "FQM: Visiting %s; save before send? " blobby) 10 t)
+ (save-buffer))))
+ (set-buffer blobby-buffer)
(setq buffer-offer-save nil)
(buffer-disable-undo blobby-buffer)
(insert-file-contents-literally maybe-file)
@@ -2043,7 +2042,7 @@ backup file names and the like)."
(message "FQM: Trapped `%s', message left in queue." (car signal-stuff))
(sit-for 3)
(message "FQM: Trap details: \"%s\""
- (mapconcat 'identity (cdr signal-stuff) "\" \""))
+ (mapconcat #'identity (cdr signal-stuff) "\" \""))
(sit-for 3)))
(kill-buffer blobby-buffer)
(feedmail-say-chatter
@@ -2076,10 +2075,10 @@ internally by feedmail):
after-run (the queue has just been run, possibly sending messages)
WHAT-EVENT is used as a key into the table `feedmail-queue-reminder-alist'. If
-the associated value is a function, it is called without arguments and is expected
-to perform the reminder activity. You can supply your own reminder functions
-by redefining `feedmail-queue-reminder-alist'. If you don't want any reminders,
-you can set `feedmail-queue-reminder-alist' to nil."
+the associated value is a function, it is called without arguments and is
+expected to perform the reminder activity. You can supply your own reminder
+functions by redefining `feedmail-queue-reminder-alist'. If you don't want any
+reminders, you can set `feedmail-queue-reminder-alist' to nil."
(interactive "p")
(feedmail-say-debug ">in-> feedmail-queue-reminder %s" what-event)
(let ((key (if (and what-event (symbolp what-event)) what-event 'on-demand)) entry reminder)
@@ -2158,17 +2157,8 @@ you can set `feedmail-queue-reminder-alist' to nil."
(setq answer (cons '^ helper))
(if (or (eq user-sez ?\C-m) (eq user-sez ?\C-j) (eq user-sez ?y))
(setq user-sez d-char))
- ;; these char-to-int things are because of some
- ;; incomprehensible difference between the two in
- ;; byte-compiled stuff between Emacs and XEmacs
- ;; (well, I'm sure someone could comprehend it,
- ;; but I say 'uncle')
- (setq answer (or (assoc user-sez user-alist)
- (and (fboundp 'char-to-int)
- (assoc (char-to-int user-sez) user-alist))
- (assoc user-sez standard-alist)
- (and (fboundp 'char-to-int)
- (assoc (char-to-int user-sez) standard-alist))))
+ (setq answer (or (assoc user-sez user-alist)
+ (assoc user-sez standard-alist)))
(if (or (null answer) (null (cdr answer)))
(progn
(beep)
@@ -2414,7 +2404,7 @@ mapped to mostly alphanumerics for safety."
;; mail-aliases nil = mail-abbrevs.el
(feedmail-say-debug "expanding mail aliases")
(if (or feedmail-force-expand-mail-aliases
- (and (fboundp 'expand-mail-aliases) mail-aliases))
+ mail-aliases)
(expand-mail-aliases (point-min) eoh-marker))
;; Make it pretty.
@@ -2983,7 +2973,8 @@ probably not appropriate for you."
(defun feedmail-fiddle-list-of-fiddle-plexes (list-of-fiddle-plexes)
- "Fiddling based on a list of fiddle-plexes. Values t, nil, and string are pointless."
+ "Fiddling based on a list of fiddle-plexes.
+Values t, nil, and string are pointless."
(feedmail-say-debug ">in-> feedmail-fiddle-list-of-fiddle-plexes")
;; default is to fall off the end of the list and do nothing
(let ((lofp list-of-fiddle-plexes) fp)
@@ -3130,8 +3121,7 @@ been weeded out."
;; won't delete the newly created frame upon exit!
(save-window-excursion
(switch-to-buffer buffer)
- (if (and (fboundp 'y-or-n-p-with-timeout)
- (numberp feedmail-confirm-outgoing-timeout))
+ (if (numberp feedmail-confirm-outgoing-timeout)
(y-or-n-p-with-timeout
"FQM: Send this email? "
(abs feedmail-confirm-outgoing-timeout)
diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el
index 4ee0ee98fb2..5319ab994ce 100644
--- a/lisp/mail/flow-fill.el
+++ b/lisp/mail/flow-fill.el
@@ -81,7 +81,7 @@ RFC 2646 suggests 66 characters for readability."
(while (setq end (text-property-any start (point-max) 'hard 't))
(save-restriction
(narrow-to-region start end)
- (let ((fill-column (eval fill-flowed-encode-column)))
+ (let ((fill-column (eval fill-flowed-encode-column t)))
(fill-flowed-fill-buffer))
(goto-char (point-min))
(while (re-search-forward "\n" nil t)
@@ -119,7 +119,7 @@ If BUFFER is nil, default to the current buffer.
If DELETE-SPACE, delete RFC2646 spaces padding at the end of
lines."
(with-current-buffer (or buffer (current-buffer))
- (let ((fill-column (eval fill-flowed-display-column)))
+ (let ((fill-column (eval fill-flowed-display-column t)))
(goto-char (point-min))
(while (not (eobp))
(cond
@@ -131,31 +131,38 @@ lines."
(goto-char (match-end 0))
(unless (looking-at " ")
(insert " "))
- (end-of-line)
- (when (and (not (eobp))
- (save-excursion
- (forward-line 1)
- (looking-at (format "\\(%s ?\\)[^>]" prefix))))
- ;; Delete the newline and the quote at the start of the
- ;; next line.
- (delete-region (point) (match-end 1))
- (ignore-errors
+ (while (and (eq (char-before (line-end-position)) ?\s)
+ (not (eobp))
+ (save-excursion
+ (forward-line 1)
+ (looking-at (format "\\(%s ?\\)[^>]" prefix))))
+ (end-of-line)
+ (when (and (not (eobp))
+ (save-excursion
+ (forward-line 1)
+ (looking-at (format "\\(%s ?\\)[^>]" prefix))))
+ ;; Delete the newline and the quote at the start of the
+ ;; next line.
+ (delete-region (point) (match-end 1))))
+ (ignore-errors
(let ((fill-prefix (concat prefix " "))
adaptive-fill-mode)
(fill-region (line-beginning-position)
(line-end-position)
- 'left 'nosqueeze))))))
- (t
+ 'left 'nosqueeze)))))
+ (t
;; Delete the newline.
(when (eq (following-char) ?\s)
(delete-char 1))
;; Hack: Don't do the flowing on the signature line.
(when (and (not (looking-at "-- $"))
(eq (char-before (line-end-position)) ?\s))
- (end-of-line)
- (when delete-space
- (delete-char -1))
- (delete-char 1)
+ (while (and (not (eobp))
+ (eq (char-before (line-end-position)) ?\s))
+ (end-of-line)
+ (when delete-space
+ (delete-char -1))
+ (delete-char 1))
(ignore-errors
(let ((fill-prefix ""))
(fill-region (line-beginning-position)
@@ -167,8 +174,8 @@ lines."
(defvar fill-flowed-encode-tests)
(defun fill-flowed-test ()
- (interactive "")
(declare (obsolete nil "27.1"))
+ (interactive "")
(user-error (concat "This function is obsolete. Please see "
"test/lisp/mail/flow-fill-tests.el "
"in the Emacs source tree")))
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index 45a790b3ee6..995ae5f9160 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -5,7 +5,7 @@
;; Author: Steven L Baur <steve@xemacs.org> (1997-2011)
;; Boruch Baum <boruch_baum@gmx.com> (2017-)
;; Keywords: mail, news
-;; Version: 0.19
+;; Old-Version: 0.19
;; This file is part of GNU Emacs.
@@ -910,7 +910,31 @@ play around with the following keys:
(unless (assoc bullet-regexp filladapt-token-table)
(setq filladapt-token-table
(append filladapt-token-table
- (list (list bullet-regexp 'bullet)))))))))
+ (list (list bullet-regexp 'bullet)))))))
+ (footnote--regenerate-alist)))
+
+(defun footnote--regenerate-alist ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward footnote-section-tag-regexp nil t)
+ (setq footnote--markers-alist
+ (cl-loop
+ with start-of-footnotes = (match-beginning 0)
+ with regexp = (footnote--current-regexp)
+ for (note text) in
+ (cl-loop for pos = (re-search-forward regexp nil t)
+ while pos
+ collect (list (match-string 1)
+ (copy-marker (match-beginning 0) t)))
+ do (goto-char (point-min))
+ collect (cl-list*
+ (string-to-number note)
+ text
+ (cl-loop
+ for pos = (re-search-forward regexp start-of-footnotes t)
+ while pos
+ when (equal note (match-string 1))
+ collect (copy-marker (match-beginning 0) t))))))))
(provide 'footnote)
diff --git a/lisp/mail/hashcash.el b/lisp/mail/hashcash.el
index e84a755e164..b4889eec46f 100644
--- a/lisp/mail/hashcash.el
+++ b/lisp/mail/hashcash.el
@@ -116,15 +116,6 @@ For example, you may want to set this to (\"-Z2\") to reduce header length."
(require 'mail-utils)
-(eval-and-compile
- (if (fboundp 'point-at-bol)
- (defalias 'hashcash-point-at-bol 'point-at-bol)
- (defalias 'hashcash-point-at-bol 'line-beginning-position))
-
- (if (fboundp 'point-at-eol)
- (defalias 'hashcash-point-at-eol 'point-at-eol)
- (defalias 'hashcash-point-at-eol 'line-end-position)))
-
(defun hashcash-strip-quoted-names (addr)
(setq addr (mail-strip-quoted-names addr))
(if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr))
@@ -141,8 +132,8 @@ For example, you may want to set this to (\"-Z2\") to reduce header length."
(let ((token ""))
(cl-loop
(setq token
- (concat token (buffer-substring (point) (hashcash-point-at-eol))))
- (goto-char (hashcash-point-at-eol))
+ (concat token (buffer-substring (point) (line-end-position))))
+ (goto-char (line-end-position))
(forward-char 1)
(unless (looking-at "[ \t]") (cl-return token))
(while (looking-at "[ \t]") (forward-char 1))))))
@@ -374,6 +365,9 @@ Prefix arg sets default accept amount temporarily."
(message "Payment valid"))
ok))))
+(define-obsolete-function-alias 'hashcash-point-at-bol #'line-beginning-position "28.1")
+(define-obsolete-function-alias 'hashcash-point-at-eol #'line-end-position "28.1")
+
(provide 'hashcash)
;;; hashcash.el ends here
diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el
index 795e37dced6..2d683574743 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -232,13 +232,13 @@ If DECODE, the DISPLAY-NAME will have RFC2047 decoding performed
;; If we found no display-name, then we look for comments.
(if display-name
(setq display-string
- (mapconcat 'identity (reverse display-name) " "))
+ (mapconcat #'identity (reverse display-name) " "))
(setq display-string (ietf-drums-get-comment string)))
(if (not mailbox)
(when (and display-string
(string-match "@" display-string))
(cons
- (mapconcat 'identity (nreverse display-name) "")
+ (mapconcat #'identity (nreverse display-name) "")
(ietf-drums-get-comment string)))
(cons mailbox (if decode
(rfc2047-decode-string display-string)
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 11918aa84f7..88fb0866856 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1,4 +1,4 @@
-;;; mail-extr.el --- extract full name and address from email header
+;;; mail-extr.el --- extract full name and address from email header -*- lexical-binding: t; -*-
;; Copyright (C) 1991-1994, 1997, 2001-2021 Free Software Foundation,
;; Inc.
@@ -222,23 +222,20 @@
"Whether to try to guess middle initial from mail address.
If true, then when we see an address like \"John Smith <jqs@host.com>\"
we will assume that \"John Q. Smith\" is the fellow's name."
- :type 'boolean
- :group 'mail-extr)
+ :type 'boolean)
(defcustom mail-extr-ignore-single-names nil
"Whether to ignore a name that is just a single word.
If true, then when we see an address like \"Idiot <dumb@stupid.com>\"
we will act as though we couldn't find a full name in the address."
:type 'boolean
- :version "22.1"
- :group 'mail-extr)
+ :version "22.1")
(defcustom mail-extr-ignore-realname-equals-mailbox-name t
"Whether to ignore a name that is equal to the mailbox name.
If true, then when the address is like \"Single <single@address.com>\"
we will act as though we couldn't find a full name in the address."
- :type 'boolean
- :group 'mail-extr)
+ :type 'boolean)
;; Matches a leading title that is not part of the name (does not
;; contribute to uniquely identifying the person).
@@ -248,19 +245,16 @@ we will act as though we couldn't find a full name in the address."
"Matches prefixes to the full name that identify a person's position.
These are stripped from the full name because they do not contribute to
uniquely identifying the person."
- :type 'regexp
- :group 'mail-extr)
+ :type 'regexp)
(defcustom mail-extr-@-binds-tighter-than-! nil
"Whether the local mail transport agent looks at ! before @."
- :type 'boolean
- :group 'mail-extr)
+ :type 'boolean)
(defcustom mail-extr-mangle-uucp nil
"Whether to throw away information in UUCP addresses
by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"."
- :type 'boolean
- :group 'mail-extr)
+ :type 'boolean)
;;----------------------------------------------------------------------
;; what orderings are meaningful?????
@@ -760,7 +754,6 @@ non-display use, you should probably use
end-of-address
<-pos >-pos @-pos colon-pos comma-pos !-pos %-pos \;-pos
group-:-pos group-\;-pos route-addr-:-pos
- record-pos-symbol
first-real-pos last-real-pos
phrase-beg phrase-end
;; Dynamically set in mail-extr-voodoo.
@@ -852,13 +845,16 @@ non-display use, you should probably use
)
;; record the position of various interesting chars, determine
;; validity later.
- ((setq record-pos-symbol
- (cdr (assq char
- '((?< . <-pos) (?> . >-pos) (?@ . @-pos)
- (?: . colon-pos) (?, . comma-pos) (?! . !-pos)
- (?% . %-pos) (?\; . \;-pos)))))
- (set record-pos-symbol
- (cons (point) (symbol-value record-pos-symbol)))
+ ((memq char '(?< ?> ?@ ?: ?, ?! ?% ?\;))
+ (push (point) (pcase-exhaustive char
+ (?< <-pos)
+ (?> >-pos)
+ (?@ @-pos)
+ (?: colon-pos)
+ (?, comma-pos)
+ (?! !-pos)
+ (?% %-pos)
+ (?\; \;-pos)))
(forward-char 1))
((eq char ?.)
(forward-char 1))
@@ -1065,7 +1061,7 @@ non-display use, you should probably use
(mail-extr-demarkerize route-addr-:-pos)
(setq route-addr-:-pos nil
>-pos (mail-extr-demarkerize >-pos)
- %-pos (mapcar 'mail-extr-demarkerize %-pos)))
+ %-pos (mapcar #'mail-extr-demarkerize %-pos)))
;; de-listify @-pos
(setq @-pos (car @-pos))
@@ -1122,7 +1118,7 @@ non-display use, you should probably use
(setq insert-point (point-max)))
(%-pos
(setq insert-point (car (last %-pos))
- saved-%-pos (mapcar 'mail-extr-markerize %-pos)
+ saved-%-pos (mapcar #'mail-extr-markerize %-pos)
%-pos nil
@-pos (mail-extr-markerize @-pos)))
(@-pos
@@ -1162,7 +1158,7 @@ non-display use, you should probably use
"uucp"))
(setq !-pos (cdr !-pos))))
(and saved-%-pos
- (setq %-pos (append (mapcar 'mail-extr-demarkerize
+ (setq %-pos (append (mapcar #'mail-extr-demarkerize
saved-%-pos)
%-pos)))
(setq @-pos (mail-extr-demarkerize @-pos))
@@ -1461,8 +1457,7 @@ If it is neither nil nor a string, modifying of names will never take
place. It affects how `mail-extract-address-components' works."
:type '(choice (regexp :size 0)
(const :tag "Always enabled" nil)
- (const :tag "Always disabled" t))
- :group 'mail-extr)
+ (const :tag "Always disabled" t)))
(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
(unless (and mail-extr-disable-voodoo
@@ -1851,11 +1846,16 @@ place. It affects how `mail-extract-address-components' works."
;; Updated by the RIPE Network Coordination Centre.
;;
;; Source: ISO 3166 Maintenance Agency
-;; http://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1-semic.txt
-;; http://www.iana.org/domain-names.htm
-;; http://www.iana.org/cctld/cctld-whois.htm
+;; https://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1-semic.txt
+;; https://www.iana.org/domain-names.htm
+;; https://www.iana.org/cctld/cctld-whois.htm
;; Latest change: 2007/11/15
+;; FIXME: There are over 1500 top level domains, the vast majority of
+;; which are not in the below list. Should they be?
+;; https://data.iana.org/TLD/tlds-alpha-by-domain.txt
+;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
+
(defconst mail-extr-all-top-level-domains
(let ((ob (make-vector 739 0)))
(mapc
@@ -2145,6 +2145,80 @@ place. It affects how `mail-extract-address-components' works."
("uucp" t "Unix to Unix CoPy")
;; Infrastructure Domains:
("arpa" t "Advanced Research Projects Agency (U.S. DoD)")
+ ;; Geographic Domains:
+ ("abudhabi" "Abu Dhabi")
+ ("africa" "Africa")
+ ("alsace" "Alsace, France")
+ ("amsterdam" "Amsterdam, The Netherlands")
+ ("arab" "League of Arab States")
+ ("asia" "Asia-Pacific region")
+ ("bar" "Bar, Montenegro")
+ ("barcelona" "Barcelona, Spain")
+ ("bayern" "Bavaria, Germany")
+ ("bcn" "Barcelona, Spain")
+ ("berlin" "Berlin, Germany")
+ ("boston" "Boston, Massachusetts")
+ ("brussels" "Brussels, Belgium")
+ ("budapest" "Budapest, Hungary")
+ ("bzh" "Brittany, France")
+ ("capetown" "Cape Town, South Africa")
+ ("cat" "Catalonia, Spain")
+ ("cologne" "Cologne, Germany")
+ ("corsica" "Corsica, France")
+ ("cymru" "Wales, United Kingdom")
+ ("doha" "Doha")
+ ("dubai" "Dubai")
+ ("durban" "Durban, South Africa")
+ ("eus" "Basque, Spain and France")
+ ("frl" "Friesland, Netherlands")
+ ("gal" "Galicia, Spain")
+ ("gent" "Ghent, Belgium")
+ ("hamburg" "Hamburg, Germany")
+ ("helsinki" "Helsinki, Finland")
+ ("irish" "Ireland")
+ ("ist" "İstanbul, Turkey")
+ ("istanbul" "İstanbul, Turkey")
+ ("joburg" "Johannesburg, South Africa")
+ ("kiwi" "New Zealanders")
+ ("koeln" "Cologne, Germany")
+ ("krd" "Kurdistan")
+ ("kyoto" "Kyoto, Japan")
+ ("lat" "Latin America")
+ ("london" "London, United Kingdom")
+ ("madrid" "Madrid, Spain")
+ ("melbourne" "Melbourne, Australia")
+ ("miami" "Miami, Florida")
+ ("nagoya" "Nagoya, Japan")
+ ("nrw" "North Rhine-Westphalia, Germany")
+ ("nyc" "New York City, New York")
+ ("okinawa" "Okinawa, Japan")
+ ("osaka" "Osaka, Japan")
+ ("paris" "Paris, France")
+ ("quebec" "Québec, Canada")
+ ("rio" "Rio de Janeiro, Brazil")
+ ("ruhr" "Ruhr, Germany")
+ ("ryukyu" "Ryukyu Islands, Japan")
+ ("saarland" "Saarland, Germany")
+ ("scot" "Scotland, United Kingdom")
+ ("stockholm" "Stockholm, Sweden")
+ ("swiss" "Switzerland")
+ ("sydney" "Sydney, Australia")
+ ("taipei" "Taipei, Taiwan")
+ ("tatar" "Tatars")
+ ("tirol" "Tyrol, Austria")
+ ("tokyo" "Tokyo, Japan")
+ ("vegas" "Las Vegas, Nevada")
+ ("wales" "Wales, United Kingdom")
+ ("wien" "Vienna, Austria")
+ ("yokohama" "Yokohama, Japan")
+ ("zuerich" "Zurich, Switzerland")
+ ;; Internationalized Geographic Domains:
+ ("xn--1qqw23a" "Foshan, China")
+ ("xn--xhq521b" "Guangdong, China")
+ ("xn--80adxhks" "Moscow, Russia")
+ ("xn--p1acf" "Russia")
+ ("xn--mgbca7dzdo" "Abu Dhabi")
+ ("xn--ngbrx" "Arab")
))
ob))
@@ -2162,13 +2236,13 @@ place. It affects how `mail-extract-address-components' works."
;(let ((all nil))
-; (mapatoms #'(lambda (x)
+; (mapatoms (lambda (x)
; (if (and (boundp x)
; (string-match "^mail-extr-" (symbol-name x)))
; (setq all (cons x all)))))
; (setq all (sort all #'string-lessp))
; (cons 'setq
-; (apply 'nconc (mapcar #'(lambda (x)
+; (apply 'nconc (mapcar (lambda (x)
; (list x (symbol-value x)))
; all))))
diff --git a/lisp/mail/mail-hist.el b/lisp/mail/mail-hist.el
index 37c8ad68860..239b386ff84 100644
--- a/lisp/mail/mail-hist.el
+++ b/lisp/mail/mail-hist.el
@@ -1,4 +1,4 @@
-;;; mail-hist.el --- headers and message body history for outgoing mail
+;;; mail-hist.el --- headers and message body history for outgoing mail -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
@@ -69,8 +69,8 @@
;;;###autoload
(defun mail-hist-enable ()
- (add-hook 'mail-mode-hook 'mail-hist-define-keys)
- (add-hook 'mail-send-hook 'mail-hist-put-headers-into-history))
+ (add-hook 'mail-mode-hook #'mail-hist-define-keys)
+ (add-hook 'mail-send-hook #'mail-hist-put-headers-into-history))
(defvar mail-hist-header-ring-alist nil
"Alist of form (header-name . history-ring).
@@ -80,14 +80,12 @@ previous/next input.")
(defcustom mail-hist-history-size (or kill-ring-max 1729)
"The maximum number of elements in a mail field's history.
Oldest elements are dumped first."
- :type 'integer
- :group 'mail-hist)
+ :type 'integer)
;;;###autoload
(defcustom mail-hist-keep-history t
"Non-nil means keep a history for headers and text of outgoing mail."
- :type 'boolean
- :group 'mail-hist)
+ :type 'boolean)
;; For handling repeated history requests
(defvar mail-hist-access-count 0)
@@ -184,8 +182,7 @@ HEADER is a string without the colon."
(defcustom mail-hist-text-size-limit nil
"Don't store any header or body with more than this many characters.
If the value is nil, that means no limit on text size."
- :type '(choice (const nil) integer)
- :group 'mail-hist)
+ :type '(choice (const nil) integer))
(defun mail-hist-text-too-long-p (text)
"Return non-nil if TEXT's length exceeds `mail-hist-text-size-limit'."
diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el
index 8cae2af8af1..e72ed828494 100644
--- a/lisp/mail/mail-parse.el
+++ b/lisp/mail/mail-parse.el
@@ -1,4 +1,4 @@
-;;; mail-parse.el --- Interface functions for parsing mail
+;;; mail-parse.el --- Interface functions for parsing mail -*- lexical-binding: t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/mail-prsvr.el b/lisp/mail/mail-prsvr.el
index 806d52e80f1..a9b5a4422d4 100644
--- a/lisp/mail/mail-prsvr.el
+++ b/lisp/mail/mail-prsvr.el
@@ -1,4 +1,4 @@
-;;; mail-prsvr.el --- Interface variables for parsing mail
+;;; mail-prsvr.el --- Interface variables for parsing mail -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el
index ad2dee59c7c..bb1f8f13bac 100644
--- a/lisp/mail/mail-utils.el
+++ b/lisp/mail/mail-utils.el
@@ -1,4 +1,4 @@
-;;; mail-utils.el --- utility functions used both by rmail and rnews
+;;; mail-utils.el --- utility functions used both by rmail and rnews -*- lexical-binding: t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -46,6 +46,7 @@ also the To field, unless this would leave an empty To field."
:type '(choice regexp (const :tag "Your Name" nil))
:group 'mail)
+(defvar epa-inhibit)
;; Returns t if file FILE is an Rmail file.
;;;###autoload
(defun mail-file-babyl-p (file)
@@ -58,6 +59,7 @@ also the To field, unless this would leave an empty To field."
(defun mail-string-delete (string start end)
"Return a string containing all of STRING except the part
from START (inclusive) to END (exclusive)."
+ ;; FIXME: This is not used anywhere. Make obsolete?
(if (null end) (substring string 0 start)
(concat (substring string 0 start)
(substring string end nil))))
@@ -132,7 +134,7 @@ we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=."
(aref string (1+ (match-beginning 1))))))
strings)))
(setq i (match-end 0)))
- (apply 'concat (nreverse (cons (substring string i) strings))))))
+ (apply #'concat (nreverse (cons (substring string i) strings))))))
;; FIXME Gnus for some reason has `quoted-printable-decode-region' in qp.el.
;;;###autoload
@@ -192,7 +194,7 @@ Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
Return a modified address list."
(when address
(if mail-use-rfc822
- (mapconcat 'identity (rfc822-addresses address) ", ")
+ (mapconcat #'identity (rfc822-addresses address) ", ")
(let (pos)
;; Strip comments.
@@ -280,7 +282,7 @@ comma-separated list, and return the pruned list."
destinations))
;; Legacy name
-(define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
+(define-obsolete-function-alias 'rmail-dont-reply-to #'mail-dont-reply-to "24.1")
;;;###autoload
diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el
index 8e63bf04bf1..5cb4a7469a9 100644
--- a/lisp/mail/mailabbrev.el
+++ b/lisp/mail/mailabbrev.el
@@ -1,4 +1,4 @@
-;;; mailabbrev.el --- abbrev-expansion of mail aliases
+;;; mailabbrev.el --- abbrev-expansion of mail aliases -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1987, 1992-1993, 1996-1997, 2000-2021 Free
;; Software Foundation, Inc.
@@ -140,15 +140,13 @@ abbrev-like expansion is performed when editing certain mail
headers (those specified by `mail-abbrev-mode-regexp'), based on
the entries in your `mail-personal-alias-file'."
:global t
- :group 'mail-abbrev
:version "20.3"
(if mail-abbrevs-mode (mail-abbrevs-enable) (mail-abbrevs-disable)))
(defcustom mail-abbrevs-only nil
"Non-nil means only mail abbrevs should expand automatically.
Other abbrevs expand only when you explicitly use `expand-abbrev'."
- :type 'boolean
- :group 'mail-abbrev)
+ :type 'boolean)
;; originally defined in sendmail.el - used to be an alist, now is a table.
(defvar mail-abbrevs nil
@@ -186,11 +184,11 @@ no aliases, which is represented by this being a table with no entries.)")
(abbrev-mode 1))
(defun mail-abbrevs-enable ()
- (add-hook 'mail-mode-hook 'mail-abbrevs-setup))
+ (add-hook 'mail-mode-hook #'mail-abbrevs-setup))
(defun mail-abbrevs-disable ()
"Turn off use of the `mailabbrev' package."
- (remove-hook 'mail-mode-hook 'mail-abbrevs-setup)
+ (remove-hook 'mail-mode-hook #'mail-abbrevs-setup)
(abbrev-mode (if (default-value 'abbrev-mode) 1 -1)))
;;;###autoload
@@ -258,8 +256,7 @@ By default this is the file specified by `mail-personal-alias-file'."
"String inserted between addresses in multi-address mail aliases.
This has to contain a comma, so \", \" is a reasonable value. You might
also want something like \",\\n \" to get each address on its own line."
- :type 'string
- :group 'mail-abbrev)
+ :type 'string)
;; define-mail-abbrev sets this flag, which causes mail-resolve-all-aliases
;; to be called before expanding abbrevs if it's necessary.
@@ -367,7 +364,7 @@ double-quotes."
(defun mail-resolve-all-aliases-1 (sym &optional so-far)
(if (memq sym so-far)
(error "mail alias loop detected: %s"
- (mapconcat 'symbol-name (cons sym so-far) " <- ")))
+ (mapconcat #'symbol-name (cons sym so-far) " <- ")))
(let ((definition (and (boundp sym) (symbol-value sym))))
(if definition
(let ((result '())
@@ -377,11 +374,11 @@ double-quotes."
(setq result (cons (substring definition start end) result)
start (and end (match-end 0)))))
(setq definition
- (mapconcat (function (lambda (x)
+ (mapconcat (lambda (x)
(or (mail-resolve-all-aliases-1
- (intern-soft (downcase x) mail-abbrevs)
- (cons sym so-far))
- x)))
+ (intern-soft (downcase x) mail-abbrevs)
+ (cons sym so-far))
+ x))
(nreverse result)
mail-alias-separator-string))
(set sym definition))))
@@ -420,8 +417,7 @@ of the current line; if it matches, abbrev mode will be turned on, otherwise
it will be turned off. (You don't need to worry about continuation lines.)
This should be set to match those mail fields in which you want abbreviations
turned on."
- :type 'regexp
- :group 'mail-abbrev)
+ :type 'regexp)
(defvar mail-abbrev-syntax-table nil
"The syntax-table used for abbrev-expansion purposes.
@@ -433,15 +429,15 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
(make-local-variable 'mail-abbrev-syntax-table)
(unless mail-abbrev-syntax-table
(let ((tab (copy-syntax-table (syntax-table)))
- (_ (aref (standard-syntax-table) ?_))
+ (syntax-_ (aref (standard-syntax-table) ?_))
(w (aref (standard-syntax-table) ?w)))
(map-char-table
- (function (lambda (key value)
- (if (null value)
- ;; Fetch the inherited value
- (setq value (aref tab key)))
- (if (equal value _)
- (set-char-table-range tab key w))))
+ (lambda (key value)
+ (if (null value)
+ ;; Fetch the inherited value
+ (setq value (aref tab key)))
+ (if (equal value syntax-_)
+ (set-char-table-range tab key w)))
tab)
(modify-syntax-entry ?@ "w" tab)
(modify-syntax-entry ?% "w" tab)
@@ -534,8 +530,7 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
(default-directory (expand-file-name "~/"))
(def mail-personal-alias-file))
(read-file-name
- (format "Read additional aliases from file (default %s): "
- def)
+ (format-prompt "Read additional aliases from file" def)
default-directory
(expand-file-name def default-directory)
t))))
@@ -548,7 +543,7 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
(default-directory (expand-file-name "~/"))
(def mail-personal-alias-file))
(read-file-name
- (format "Read mail aliases from file (default %s): " def)
+ (format-prompt "Read mail aliases from file" def)
default-directory
(expand-file-name def default-directory)
t))))
@@ -601,12 +596,12 @@ In other respects, this behaves like `end-of-buffer', which see."
(eval-after-load "sendmail"
'(progn
- (define-key mail-mode-map "\C-c\C-a" 'mail-abbrev-insert-alias)
+ (define-key mail-mode-map "\C-c\C-a" #'mail-abbrev-insert-alias)
(define-key mail-mode-map "\e\t" ; like completion-at-point
- 'mail-abbrev-complete-alias)))
+ #'mail-abbrev-complete-alias))) ;; FIXME: Use `completion-at-point'.
-;;(define-key mail-mode-map "\C-n" 'mail-abbrev-next-line)
-;;(define-key mail-mode-map "\M->" 'mail-abbrev-end-of-buffer)
+;;(define-key mail-mode-map "\C-n" #'mail-abbrev-next-line)
+;;(define-key mail-mode-map "\M->" #'mail-abbrev-end-of-buffer)
(provide 'mailabbrev)
diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el
index 42a3679fd64..5a5488b2ec1 100644
--- a/lisp/mail/mailalias.el
+++ b/lisp/mail/mailalias.el
@@ -255,9 +255,9 @@ removed from alias expansions."
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)))
+ (read-file-name
+ (format-prompt "Read mail alias file" 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.
@@ -517,7 +517,7 @@ PREFIX is the string we want to complete."
(setq mail-names
(sort (append (if (consp mail-aliases)
(mapcar
- (function (lambda (a) (list (car a))))
+ (lambda (a) (list (car a)))
mail-aliases))
(if (consp mail-local-names)
mail-local-names)
diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el
index 355aa207b95..5c153ce1c1f 100644
--- a/lisp/mail/mailclient.el
+++ b/lisp/mail/mailclient.el
@@ -1,4 +1,4 @@
-;;; mailclient.el --- mail sending via system's mail client.
+;;; mailclient.el --- mail sending via system's mail client. -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -134,7 +134,7 @@ The mail client is taken to be the handler of mailto URLs."
character-coding
;; Use the external browser function to send the
;; message.
- (browse-url-mailto-function nil))
+ (browse-url-default-handlers nil))
;; initialize limiter
(setq mailclient-delim-static "?")
;; construct and call up mailto URL
diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el
index cbc01e4a442..0443279be84 100644
--- a/lisp/mail/mailheader.el
+++ b/lisp/mail/mailheader.el
@@ -1,4 +1,4 @@
-;;; mailheader.el --- mail header parsing, merging, formatting
+;;; mailheader.el --- mail header parsing, merging, formatting -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -99,23 +99,23 @@ value."
headers)
;; Advertised part of the interface; see mail-header, mail-header-set.
-(with-suppressed-warnings ((lexical headers))
- (defvar headers))
-(defsubst mail-header (header &optional header-alist)
+(defun 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
value is a list, its first element is the original value of the header,
-with any subsequent elements being the result of parsing the value.
-If HEADER-ALIST is nil, the dynamically bound variable `headers' is used."
+with any subsequent elements being the result of parsing the value."
(declare (gv-setter (lambda (value)
`(mail-header-set ,header ,value ,header-alist))))
+ (with-suppressed-warnings ((lexical headers)) (defvar headers))
(cdr (assq header (or header-alist headers))))
(defun mail-header-set (header value &optional header-alist)
"Set the value associated with header HEADER to VALUE in HEADER-ALIST.
HEADER-ALIST defaults to the dynamically bound variable `headers' if nil.
See `mail-header' for the semantics of VALUE."
+ (declare (obsolete alist-get "28.1"))
+ (with-suppressed-warnings ((lexical headers)) (defvar headers))
(let* ((alist (or header-alist headers))
(entry (assq header alist)))
(if entry
@@ -131,10 +131,13 @@ should be a string or a list of string. The first element may be nil to
denote that the formatting functions must use the remaining elements, or
skip the header altogether if there are no other elements.
The macro `mail-header' can be used to access headers in HEADERS."
- (mapcar
- (lambda (rule)
- (cons (car rule) (eval (cdr rule))))
- merge-rules))
+ (declare (obsolete alist-get "28.1"))
+ (with-suppressed-warnings ((lexical headers)) (defvar headers))
+ (let ((headers headers))
+ (mapcar
+ (lambda (rule)
+ (cons (car rule) (eval (cdr rule) t)))
+ merge-rules)))
(defvar mail-header-format-function
(lambda (header value)
@@ -167,7 +170,7 @@ A key of nil has as its value a list of defaulted headers to ignore."
(mapcar #'car format-rules))))
(dolist (rule format-rules)
(let* ((header (car rule))
- (value (mail-header header)))
+ (value (alist-get header headers)))
(if (stringp header)
(setq header (intern header)))
(cond ((null header) 'ignore)
@@ -176,13 +179,11 @@ A key of nil has as its value a list of defaulted headers to ignore."
(unless (memq (car defaulted) ignore)
(let* ((header (car defaulted))
(value (cdr defaulted)))
- (if (cdr rule)
- (funcall (cdr rule) header value)
- (funcall mail-header-format-function header value))))))
+ (funcall (or (cdr rule) mail-header-format-function)
+ header value)))))
(value
- (if (cdr rule)
- (funcall (cdr rule) header value)
- (funcall mail-header-format-function header value))))))
+ (funcall (or (cdr rule) mail-header-format-function)
+ header value)))))
(insert "\n")))
(provide 'mailheader)
diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el
index 37a75fadf96..6d834140582 100644
--- a/lisp/mail/mspools.el
+++ b/lisp/mail/mspools.el
@@ -1,4 +1,4 @@
-;;; mspools.el --- show mail spools waiting to be read
+;;; mspools.el --- show mail spools waiting to be read -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -125,18 +125,15 @@
(defcustom mspools-update nil
"Non-nil means update *spools* buffer after visiting any folder."
- :type 'boolean
- :group 'mspools)
+ :type 'boolean)
(defcustom mspools-suffix "spool"
"Extension used for spool files (not including full stop)."
- :type 'string
- :group 'mspools)
+ :type 'string)
(defcustom mspools-using-vm (fboundp 'vm)
"Non-nil if VM is used as mail reader, otherwise RMAIL is used."
- :type 'boolean
- :group 'mspools)
+ :type 'boolean)
(defcustom mspools-folder-directory
(if (boundp 'vm-folder-directory)
@@ -144,8 +141,7 @@
"~/MAIL/")
"Directory where mail folders are kept. Ensure it has a trailing /.
Defaults to `vm-folder-directory' if bound else to ~/MAIL/."
- :type 'directory
- :group 'mspools)
+ :type 'directory)
(defcustom mspools-vm-system-mail (or (getenv "MAIL")
(concat rmail-spool-directory
@@ -156,8 +152,7 @@ without it. By default this will be set to the environment variable
$MAIL. Otherwise it will use `rmail-spool-directory' to guess where
your primary spool is. If this fails, set it to something like
/usr/spool/mail/login-name."
- :type 'file
- :group 'mspools)
+ :type 'file)
;;; Internal Variables
@@ -172,14 +167,11 @@ your primary spool is. If this fails, set it to something like
(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)
+ (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 "n" #'next-line)
+ (define-key map "p" #'previous-line)
map)
"Keymap for the *spools* buffer.")
@@ -221,14 +213,15 @@ your primary spool is. If this fails, set it to something like
(concat mspools-folder-directory s "." mspools-suffix)
(concat mspools-folder-directory s ".crash")))
;; So I create a vm-spool-files entry for each of those mail drops
- (mapcar 'file-name-sans-extension
+ (mapcar #'file-name-sans-extension
(directory-files mspools-folder-directory nil
(format "\\`[^.]+\\.%s" mspools-suffix)))
))
))
;;; MSPOOLS-SHOW -- the main function
-(defun mspools-show ( &optional noshow)
+;;;###autoload
+(defun mspools-show (&optional noshow)
"Show the list of non-empty spool files in the *spools* buffer.
Buffer is not displayed if SHOW is non-nil."
(interactive)
@@ -237,7 +230,7 @@ Buffer is not displayed if SHOW is non-nil."
(progn
(set-buffer mspools-buffer)
(setq buffer-read-only nil)
- (delete-region (point-min) (point-max)))
+ (erase-buffer))
;; else buffer doesn't exist so create it
(get-buffer-create mspools-buffer))
@@ -260,8 +253,8 @@ Buffer is not displayed if SHOW is non-nil."
(defun mspools-visit-spool ()
"Visit the folder on the current line of the *spools* buffer."
(interactive)
- (let ( spool-name folder-name)
- (setq spool-name (mspools-get-spool-name))
+ (let ((spool-name (mspools-get-spool-name))
+ folder-name)
(if (null spool-name)
(message "No spool on current line")
@@ -270,19 +263,20 @@ Buffer is not displayed if SHOW is non-nil."
;; put in a little "*" to indicate spool file has been read.
(if (not mspools-update)
(save-excursion
- (setq buffer-read-only nil)
(beginning-of-line)
- (insert "*")
- (delete-char 1)
- (setq buffer-read-only t)
- ))
+ (let ((inhibit-read-only t))
+ (insert "*")
+ (delete-char 1))))
(message "folder %s spool %s" folder-name spool-name)
- (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
- (forward-line 1))
+ (forward-line (if (eq (count-lines (point-min) (point-at-eol))
+ mspools-files-len)
+ ;; FIXME: Why use `mspools-files-len' instead
+ ;; of looking if we're on the last line and
+ ;; jumping to the first one if so?
+ (- 1 mspools-files-len) ;back to top of list
+ ;; else just on to next line
+ 1))
;; Choose whether to use VM or RMAIL for reading folder.
(if mspools-using-vm
@@ -296,8 +290,8 @@ Buffer is not displayed if SHOW is non-nil."
(if mspools-update
;; generate new list of spools.
- (save-excursion
- (mspools-show-again 'noshow))))))
+ (save-excursion ;;FIXME: Why?
+ (mspools-revert-buffer))))))
(defun mspools-get-folder-from-spool (name)
"Return folder name corresponding to the spool file NAME."
@@ -319,27 +313,31 @@ 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) (point-at-eol)))))
+ ;; FIXME: Why not extract the name directly from the current line's text?
(car (nth line-num mspools-files))))
;;; Spools mode functions
-(defun mspools-revert-buffer (ignore noconfirm)
- "Re-run mspools-show to revert the *spools* buffer."
+(defun mspools-revert-buffer (&optional _ignore _noconfirm)
+ "Re-run `mspools-show' to revert the *spools* buffer."
(mspools-show 'noshow))
(defun mspools-show-again (&optional noshow)
- "Update the *spools* buffer. This is useful if mspools-update is
-nil."
+ "Update the *spools* buffer.
+This is useful if `mspools-update' is nil."
+ (declare (obsolete revert-buffer "28.1"))
(interactive)
(mspools-show noshow))
(defun mspools-help ()
"Show help for `mspools-mode'."
+ (declare (obsolete describe-mode "28.1"))
(interactive)
(describe-function 'mspools-mode))
(defun mspools-quit ()
"Quit the *spools* buffer."
+ (declare (obsolete quit-window "28.1"))
(interactive)
(kill-buffer mspools-buffer))
@@ -353,32 +351,26 @@ nil."
(defun mspools-get-spool-files ()
"Find the list of spool files and display them in *spools* buffer."
- (let (folders head spool len beg end any)
- (if (null mspools-folder-directory)
- (error "Set `mspools-folder-directory' to where the spool files are"))
- (setq folders (directory-files mspools-folder-directory nil
+ (if (null mspools-folder-directory)
+ (error "Set `mspools-folder-directory' to where the spool files are"))
+ (let* ((folders (directory-files mspools-folder-directory nil
(format "\\`[^.]+\\.%s\\'" mspools-suffix)))
- (setq folders (mapcar 'mspools-size-folder folders))
- (setq folders (delq nil folders))
+ (folders (delq nil (mapcar #'mspools-size-folder folders)))
+ ;; beg end
+ )
(setq mspools-files folders)
(setq mspools-files-len (length mspools-files))
- (set-buffer mspools-buffer)
- (while folders
- (setq any t)
- (setq head (car folders))
- (setq spool (car head))
- (setq len (cdr head))
- (setq folders (cdr folders))
- (setq beg (point))
- (insert (format " %10d %s" len spool))
- (setq end (point))
- (insert "\n")
- ;;(put-text-property beg end 'mouse-face 'highlight)
- )
- (if any
- (delete-char -1)) ;delete last RET
- (goto-char (point-min))
- ))
+ (with-current-buffer mspools-buffer
+ (pcase-dolist (`(,spool . ,len) folders)
+ ;; (setq beg (point))
+ (insert (format " %10d %s" len spool))
+ ;; (setq end (point))
+ (insert "\n")
+ ;;(put-text-property beg end 'mouse-face 'highlight)
+ )
+ (if (not (bolp))
+ (delete-char -1)) ;delete last RET
+ (goto-char (point-min)))))
(defun mspools-size-folder (spool)
"Return (SPOOL . SIZE ), if SIZE of spool file is non-zero."
diff --git a/lisp/mail/qp.el b/lisp/mail/qp.el
index 9b93dddd3b8..02a371a8448 100644
--- a/lisp/mail/qp.el
+++ b/lisp/mail/qp.el
@@ -1,4 +1,4 @@
-;;; qp.el --- Quoted-Printable functions
+;;; qp.el --- Quoted-Printable functions -*- lexical-binding:t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -125,7 +125,7 @@ encode lines starting with \"From\"."
(not (eobp)))
(insert
(prog1
- (format "=%02X" (char-after))
+ (format "=%02X" (get-byte))
(delete-char 1))))
;; Encode white space at the end of lines.
(goto-char (point-min))
@@ -134,7 +134,7 @@ encode lines starting with \"From\"."
(while (not (eolp))
(insert
(prog1
- (format "=%02X" (char-after))
+ (format "=%02X" (get-byte))
(delete-char 1)))))
(let ((ultra
(and (boundp 'mm-use-ultra-safe-encoding)
diff --git a/lisp/mail/reporter.el b/lisp/mail/reporter.el
index aecb33f052e..4b70582a261 100644
--- a/lisp/mail/reporter.el
+++ b/lisp/mail/reporter.el
@@ -1,4 +1,4 @@
-;;; reporter.el --- customizable bug reporting of lisp programs
+;;; reporter.el --- customizable bug reporting of lisp programs -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1998, 2001-2021 Free Software Foundation, Inc.
@@ -51,7 +51,6 @@
;;(defun mypkg-submit-bug-report ()
;; "Submit via mail a bug report on mypkg"
;; (interactive)
-;; (require 'reporter)
;; (reporter-submit-bug-report
;; mypkg-maintainer-address
;; (concat "mypkg.el " mypkg-version)
@@ -101,9 +100,8 @@ This is necessary to properly support the printing of buffer-local
variables. Current buffer will always be the mail buffer being
composed.")
-(defvar reporter-initial-text nil
+(defvar-local reporter-initial-text nil
"The automatically created initial text of a bug report.")
-(make-variable-buffer-local 'reporter-initial-text)
@@ -159,7 +157,7 @@ composed.")
t)
(error indent-enclosing-p))))
-(defun reporter-lisp-indent (indent-point state)
+(defun reporter-lisp-indent (_indent-point state)
"A better lisp indentation style for bug reporting."
(save-excursion
(goto-char (1+ (nth 1 state)))
@@ -194,7 +192,7 @@ MAILBUF is the mail buffer being composed."
(<= maxwidth (current-column)))
(save-excursion
(let ((compact-p (not (memq varsym reporter-dont-compact-list)))
- (lisp-indent-function 'reporter-lisp-indent))
+ (lisp-indent-function #'reporter-lisp-indent))
(goto-char here)
(reporter-beautify-list maxwidth compact-p))))
(insert "\n"))
@@ -207,6 +205,11 @@ MAILBUF is the mail buffer being composed."
(error
(error ""))))
+(defun reporter--run-functions (funs)
+ (if (functionp funs)
+ (funcall funs)
+ (mapc #'funcall funs)))
+
(defun reporter-dump-state (pkgname varlist pre-hooks post-hooks)
"Dump the state of the mode specific variables.
PKGNAME contains the name of the mode as it will appear in the bug
@@ -231,44 +234,39 @@ properly.
PRE-HOOKS is run after the Emacs version and PKGNAME are inserted, but
before the VARLIST is dumped. POST-HOOKS is run after the VARLIST is
dumped."
- (let ((buffer (current-buffer)))
- (set-buffer buffer)
- (insert "Emacs : " (emacs-version) "\n")
- (and pkgname
- (insert "Package: " pkgname "\n"))
- (run-hooks 'pre-hooks)
- (if (not varlist)
- nil
- (insert "\ncurrent state:\n==============\n")
- ;; create an emacs-lisp-mode buffer to contain the output, which
- ;; we'll later insert into the mail buffer
- (condition-case fault
- (let ((mailbuf (current-buffer))
- (elbuf (get-buffer-create " *tmp-reporter-buffer*")))
- (with-current-buffer elbuf
- (emacs-lisp-mode)
- (erase-buffer)
- (insert "(setq\n")
- (lisp-indent-line)
- (mapc
- (function
- (lambda (varsym-or-cons-cell)
- (let ((varsym (or (car-safe varsym-or-cons-cell)
- varsym-or-cons-cell))
- (printer (or (cdr-safe varsym-or-cons-cell)
- 'reporter-dump-variable)))
- (funcall printer varsym mailbuf)
- )))
- varlist)
- (lisp-indent-line)
- (insert ")\n"))
- (insert-buffer-substring elbuf))
- (error
- (insert "State could not be dumped due to the following error:\n\n"
- (format "%s" fault)
- "\n\nYou should still send this bug report."))))
- (run-hooks 'post-hooks)
- ))
+ (insert "Emacs : " (emacs-version) "\n")
+ (and pkgname
+ (insert "Package: " pkgname "\n"))
+ (reporter--run-functions pre-hooks)
+ (if (not varlist)
+ nil
+ (insert "\ncurrent state:\n==============\n")
+ ;; create an emacs-lisp-mode buffer to contain the output, which
+ ;; we'll later insert into the mail buffer
+ (condition-case fault
+ (let ((mailbuf (current-buffer))
+ (elbuf (get-buffer-create " *tmp-reporter-buffer*")))
+ (with-current-buffer elbuf
+ (emacs-lisp-mode)
+ (erase-buffer)
+ (insert "(setq\n")
+ (lisp-indent-line)
+ (mapc
+ (lambda (varsym-or-cons-cell)
+ (let ((varsym (or (car-safe varsym-or-cons-cell)
+ varsym-or-cons-cell))
+ (printer (or (cdr-safe varsym-or-cons-cell)
+ 'reporter-dump-variable)))
+ (funcall printer varsym mailbuf)))
+ varlist)
+ (lisp-indent-line)
+ (insert ")\n"))
+ (insert-buffer-substring elbuf))
+ (error
+ (insert "State could not be dumped due to the following error:\n\n"
+ (format "%s" fault)
+ "\n\nYou should still send this bug report."))))
+ (reporter--run-functions post-hooks))
(defun reporter-compose-outgoing ()
@@ -368,7 +366,7 @@ mail-sending package is used for editing and sending the message."
(skip-chars-backward " \t\n")
(setq reporter-initial-text (buffer-substring after-sep-pos (point))))
(if (setq hookvar (get agent 'hookvar))
- (add-hook hookvar 'reporter-bug-hook nil t))
+ (add-hook hookvar #'reporter-bug-hook nil t))
;; compose the minibuf message and display this.
(let* ((sendkey-whereis (where-is-internal
diff --git a/lisp/mail/rfc2045.el b/lisp/mail/rfc2045.el
index 415cd86eaa0..c0672f18a98 100644
--- a/lisp/mail/rfc2045.el
+++ b/lisp/mail/rfc2045.el
@@ -1,4 +1,4 @@
-;;; rfc2045.el --- Functions for decoding rfc2045 headers
+;;; rfc2045.el --- Functions for decoding rfc2045 headers -*- lexical-binding:t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el
index 1369c5bbbf5..5b08713949f 100644
--- a/lisp/mail/rfc2047.el
+++ b/lisp/mail/rfc2047.el
@@ -716,11 +716,13 @@ Point moves to the end of the region."
(goto-char e)))))
(defun rfc2047-fold-field ()
- "Fold the current header field."
+ "Fold the current header field.
+Return the new end point."
(save-excursion
(save-restriction
(rfc2047-narrow-to-field)
- (rfc2047-fold-region (point-min) (point-max)))))
+ (rfc2047-fold-region (point-min) (point-max))
+ (point-max))))
(defun rfc2047-fold-region (b e)
"Fold long lines in region B to E."
diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el
index da42d664da6..6fb4502b23b 100644
--- a/lisp/mail/rfc2231.el
+++ b/lisp/mail/rfc2231.el
@@ -215,23 +215,25 @@ These look like:
\"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
\"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
\"This is ***fun***\"."
- (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
- (let ((coding-system (mm-charset-to-coding-system
- (match-string 1 string) nil t))
- ;;(language (match-string 2 string))
- (value (match-string 3 string)))
- (mm-with-unibyte-buffer
- (insert value)
- (goto-char (point-min))
- (while (re-search-forward "%\\([[:xdigit:]][[:xdigit:]]\\)" nil t)
- (insert
- (prog1
- (string-to-number (match-string 1) 16)
- (delete-region (match-beginning 0) (match-end 0)))))
- ;; Decode using the charset, if any.
- (if (memq coding-system '(nil ascii))
- (buffer-string)
- (decode-coding-string (buffer-string) coding-system)))))
+ (if (not (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)\\'"
+ string))
+ (error "Unrecognized RFC2231 format: %S" string)
+ (let ((value (match-string 3 string))
+ ;;(language (match-string 2 string))
+ (coding-system (mm-charset-to-coding-system
+ (match-string 1 string) nil t)))
+ (mm-with-unibyte-buffer
+ (insert value)
+ (goto-char (point-min))
+ (while (re-search-forward "%\\([[:xdigit:]][[:xdigit:]]\\)" nil t)
+ (insert
+ (prog1
+ (string-to-number (match-string 1) 16)
+ (delete-region (match-beginning 0) (match-end 0)))))
+ ;; Decode using the charset, if any.
+ (if (memq coding-system '(nil ascii))
+ (buffer-string)
+ (decode-coding-string (buffer-string) coding-system))))))
(defun rfc2231-encode-string (param value)
"Return a PARAM=VALUE string encoded according to RFC2231.
diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el
index 3b98b2f6c5b..553f3cc3a54 100644
--- a/lisp/mail/rfc2368.el
+++ b/lisp/mail/rfc2368.el
@@ -1,4 +1,4 @@
-;;; rfc2368.el --- support for rfc2368
+;;; rfc2368.el --- support for rfc2368 -*- lexical-binding:t -*-
;; Copyright (C) 1998, 2000-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/rfc822.el b/lisp/mail/rfc822.el
index 95f78bcc316..2e97226662f 100644
--- a/lisp/mail/rfc822.el
+++ b/lisp/mail/rfc822.el
@@ -1,4 +1,4 @@
-;;; rfc822.el --- hairy RFC 822 (or later) parser for mail, news, etc.
+;;; rfc822.el --- hairy RFC 822 (or later) parser for mail, news, etc. -*- lexical-binding: t; -*-
;; Copyright (C) 1986-1987, 1990, 2001-2021 Free Software Foundation,
;; Inc.
@@ -226,11 +226,11 @@
((and (not (eobp)) (= (following-char) ?\@))
;; <@foo.bar,@baz:quux@abcd.efg>
(rfc822-snarf-frob-list "<...> address" ?\, ?\:
- (function (lambda ()
- (if (rfc822-looking-at ?\@)
- (rfc822-snarf-domain)
- (rfc822-bad-address
- "Gubbish in route-addr")))))
+ (lambda ()
+ (if (rfc822-looking-at ?\@)
+ (rfc822-snarf-domain)
+ (rfc822-bad-address
+ "Gubbish in route-addr"))))
(rfc822-snarf-words)
(or (rfc822-looking-at ?@)
(rfc822-bad-address "Malformed <..@..> address"))
@@ -279,8 +279,7 @@
(let ((buf (generate-new-buffer " rfc822")))
(unwind-protect
(with-current-buffer buf
- (make-local-variable 'case-fold-search)
- (setq case-fold-search nil) ;For speed(?)
+ (setq-local case-fold-search nil) ;For speed(?)
(insert header-text)
;; unfold continuation lines
(goto-char (point-min))
diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el
index f75538ab533..fbac9e0cc0c 100644
--- a/lisp/mail/rmail-spam-filter.el
+++ b/lisp/mail/rmail-spam-filter.el
@@ -1,4 +1,4 @@
-;;; rmail-spam-filter.el --- spam filter for Rmail, the Emacs mail reader
+;;; rmail-spam-filter.el --- spam filter for Rmail, the Emacs mail reader -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Keywords: email, spam, filter, rmail
@@ -82,50 +82,42 @@
(defcustom rmail-use-spam-filter nil
"Non-nil to activate the Rmail spam filter.
Set `rsf-definitions-alist' to define what you consider spam emails."
- :type 'boolean
- :group 'rmail-spam-filter)
+ :type 'boolean)
(defcustom rsf-file "~/XRMAIL-SPAM"
"Name of Rmail file for optionally saving some of the spam.
You can either just delete spam, or save it in this file for
later review. Which action to take for each spam definition is
specified by the \"action\" element of the definition."
- :type 'string
- :group 'rmail-spam-filter)
+ :type 'string)
(defcustom rsf-no-blind-cc nil
"Non-nil means mail with no explicit To: or Cc: is spam."
- :type 'boolean
- :group 'rmail-spam-filter)
+ :type 'boolean)
(defcustom rsf-ignore-case nil
"Non-nil means to ignore case in `rsf-definitions-alist'."
- :type 'boolean
- :group 'rmail-spam-filter)
+ :type 'boolean)
(defcustom rsf-beep nil
"Non-nil means to beep if spam is found."
- :type 'boolean
- :group 'rmail-spam-filter)
+ :type 'boolean)
(defcustom rsf-sleep-after-message 2.0
"Seconds to wait after displaying a message that spam was found."
- :type 'number
- :group 'rmail-spam-filter)
+ :type 'number)
(defcustom rsf-min-region-to-spam-list 7
"Minimum size of region that you can add to the spam list.
The aim is to avoid adding too short a region, which could result
in false positive identification of a valid message as spam."
- :type 'integer
- :group 'rmail-spam-filter)
+ :type 'integer)
(defcustom rsf-autosave-newly-added-definitions nil
"Non-nil to auto-save new spam entries.
Any time you add an entry via the \"Spam\" menu, immediately saves
the custom file."
- :type 'boolean
- :group 'rmail-spam-filter)
+ :type 'boolean)
(defcustom rsf-white-list nil
"List of regexps to identify valid senders.
@@ -133,8 +125,7 @@ If any element matches the \"From\" header, the message is
flagged as a valid, non-spam message. E.g., if your domain is
\"emacs.com\" then including \"emacs\\\\.com\" in this list would
flag all mail (purporting to be) from your colleagues as valid."
- :type '(repeat string)
- :group 'rmail-spam-filter)
+ :type '(repeat regexp))
(defcustom rsf-definitions-alist nil
"A list of rules (definitions) matching spam messages.
@@ -157,29 +148,28 @@ A rule matches only if all the specified elements match."
(list :format "%v"
(cons :format "%v" :value (from . "")
(const :format "" from)
- (string :tag "From" ""))
+ (regexp :tag "From" ""))
(cons :format "%v" :value (to . "")
(const :format "" to)
- (string :tag "To" ""))
+ (regexp :tag "To" ""))
(cons :format "%v" :value (subject . "")
(const :format "" subject)
- (string :tag "Subject" ""))
+ (regexp :tag "Subject" ""))
(cons :format "%v" :value (content-type . "")
(const :format "" content-type)
- (string :tag "Content-Type" ""))
+ (regexp :tag "Content-Type" ""))
(cons :format "%v" :value (contents . "")
(const :format "" contents)
- (string :tag "Contents" ""))
+ (regexp :tag "Contents" ""))
(cons :format "%v" :value (x-spam-status . "")
(const :format "" x-spam-status)
- (string :tag "X-Spam-Status" ""))
+ (regexp :tag "X-Spam-Status" ""))
(cons :format "%v" :value (action . output-and-delete)
(const :format "" action)
(choice :tag "Action selection"
(const :tag "Output and delete" output-and-delete)
(const :tag "Delete" delete-spam)
- ))))
- :group 'rmail-spam-filter)
+ )))))
;; FIXME nothing uses this, and it could just be let-bound.
(defvar rsf-scanning-messages-now nil
@@ -214,6 +204,18 @@ the cdr is set to t. Else, the car is set to nil."
;; rule means this cannot be spam.
(setcar result nil)))))
+;; Don't spuriously advance to the next unseen message while
+;; prompting, because that causes it to then be missed while actually
+;; reading mail afterwards! Call this instead of
+;; rmail-first-unseen-message.
+(defun rsf--rmail-last-seen-message ()
+ (max 1
+ ;; 'rmail-first-unseen-message' can return nil in a completely
+ ;; empty buffer.
+ (1- (or (rmail-first-unseen-message) 1))))
+
+(defvar bbdb/mail_auto_create_p)
+
(defun rmail-spam-filter (msg)
"Return nil if message number MSG is spam based on `rsf-definitions-alist'.
If spam, optionally output message to a file `rsf-file' and delete
@@ -327,8 +329,7 @@ it from rmail file. Called for each new message retrieved by
(if (and (car maybe-spam) (cdr maybe-spam))
;; Temporarily set rmail-current-message in order to output
;; and delete the spam msg if needed:
- (let ((rmail-current-message msg) ; FIXME does this do anything?
- (action (cdr (assq 'action
+ (let ((action (cdr (assq 'action
(nth num-element rsf-definitions-alist))))
(newfile (not (file-exists-p rsf-file))))
;; Check action item in rsf-definitions-alist and do it.
@@ -337,7 +338,7 @@ it from rmail file. Called for each new message retrieved by
;; Else the prompt to write a new file leaves the raw
;; mbox buffer visible.
(and newfile
- (rmail-show-message (rmail-first-unseen-message) t))
+ (rmail-show-message (rsf--rmail-last-seen-message) t))
(rmail-output rsf-file)
;; Swap back, else rmail-get-new-mail-1 gets confused.
(when newfile
@@ -377,7 +378,7 @@ This is called at the end of `rmail-get-new-mail-1' if there is new mail."
(sleep-for rsf-sleep-after-message))
(when (> nspam 0)
;; Otherwise sleep or expunge prompt leaves raw mbox buffer showing.
- (rmail-show-message (or (rmail-first-unseen-message) 1) t)
+ (rmail-show-message (or (rsf--rmail-last-seen-message) 1) t)
(unwind-protect
(progn
(if rsf-beep (ding t))
@@ -513,12 +514,12 @@ to the spam list (remember to save it)" region-to-spam-list))))))
["Customize spam definitions" rsf-customize-spam-definitions]
["Browse spam customizations" rsf-customize-group]
))
- (define-key map "\C-cSt" 'rsf-add-subject-to-spam-list)
- (define-key map "\C-cSr" 'rsf-add-sender-to-spam-list)
- (define-key map "\C-cSn" 'rsf-add-region-to-spam-list)
- (define-key map "\C-cSa" 'rsf-custom-save-all)
- (define-key map "\C-cSd" 'rsf-customize-spam-definitions)
- (define-key map "\C-cSg" 'rsf-customize-group))
+ (define-key map "\C-cSt" #'rsf-add-subject-to-spam-list)
+ (define-key map "\C-cSr" #'rsf-add-sender-to-spam-list)
+ (define-key map "\C-cSn" #'rsf-add-region-to-spam-list)
+ (define-key map "\C-cSa" #'rsf-custom-save-all)
+ (define-key map "\C-cSd" #'rsf-customize-spam-definitions)
+ (define-key map "\C-cSg" #'rsf-customize-group))
(defun rsf-add-content-type-field ()
"Maintain backward compatibility for `rmail-spam-filter'.
@@ -554,4 +555,4 @@ checks to see if the old format is used, and updates it if necessary."
(provide 'rmail-spam-filter)
-;;; rmail-spam-filter ends here
+;;; rmail-spam-filter.el ends here
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 86154f2a61f..e479a8e9b4a 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -39,6 +39,7 @@
(require 'mail-utils)
(require 'rfc2047)
+(require 'auth-source)
(require 'rmail-loaddefs)
@@ -160,13 +161,6 @@ its character representation and its display representation.")
:version "21.1")
;;;###autoload
-(put 'rmail-spool-directory 'standard-value
- '((cond ((file-exists-p "/var/mail") "/var/mail/")
- ((file-exists-p "/var/spool/mail") "/var/spool/mail/")
- ((memq system-type '(hpux usg-unix-v)) "/usr/mail/")
- (t "/usr/spool/mail/"))))
-
-;;;###autoload
(defcustom rmail-spool-directory
(purecopy
(cond ((file-exists-p "/var/mail")
@@ -180,12 +174,10 @@ its character representation and its display representation.")
(t "/usr/spool/mail/")))
"Name of directory used by system mailer for delivering new mail.
Its name should end with a slash."
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:type 'directory
:group 'rmail)
-;;;###autoload(custom-initialize-delay 'rmail-spool-directory nil)
-
(defcustom rmail-movemail-program nil
"If non-nil, the file name of the `movemail' program."
:group 'rmail-retrieve
@@ -417,20 +409,6 @@ The variable `rmail-highlighted-headers' specifies which headers."
:group 'rmail-headers
:version "22.1")
-;; This was removed in Emacs 23.1 with no notification, an unnecessary
-;; incompatible change.
-(defcustom rmail-highlight-face 'rmail-highlight
- "Face used by Rmail for highlighting headers."
- ;; Note that nil doesn't actually mean use the default face, it
- ;; means use either bold or highlight. It's not worth fixing this
- ;; now that this is obsolete.
- :type '(choice (const :tag "Default" nil)
- face)
- :group 'rmail-headers)
-(make-obsolete-variable 'rmail-highlight-face
- "customize the face `rmail-highlight' instead."
- "23.2")
-
(defface rmail-header-name
'((t (:inherit font-lock-function-name-face)))
"Face to use for highlighting the header names.
@@ -521,25 +499,6 @@ still the current message in the Rmail buffer.")
(defvar rmail-mmdf-delim2 "^\001\001\001\001\n"
"Regexp marking the end of an mmdf message.")
-;; FIXME Post-mbox, this is now unused.
-;; In Emacs-22, this was called:
-;; i) the very first time a message was shown.
-;; ii) when toggling the headers to the normal state, every time.
-;; It's not clear what it should do now, since there is nothing that
-;; records when a message is shown for the first time (unseen is not
-;; necessarily the same thing).
-;; See https://lists.gnu.org/r/emacs-devel/2009-03/msg00013.html
-(defcustom rmail-message-filter nil
- "If non-nil, a filter function for new messages in RMAIL.
-Called with region narrowed to the message, including headers,
-before obeying `rmail-ignored-headers'."
- :group 'rmail-headers
- :type '(choice (const nil) function))
-
-(make-obsolete-variable 'rmail-message-filter
- "it is not used (try `rmail-show-message-hook')."
- "23.1")
-
(defcustom rmail-automatic-folder-directives nil
"List of directives specifying how to automatically file messages.
Whenever Rmail shows a message in the folder that `rmail-file-name'
@@ -578,11 +537,21 @@ Examples:
(defvar rmail-reply-prefix "Re: "
"String to prepend to Subject line when replying to a message.")
+;; Note: this is matched with case-fold-search bound to t.
+(defcustom rmail-re-abbrevs
+ "\\(RE\\|رد\\|回å¤\\|回覆\\|SV\\|Antw\\|VS\\|REF\\|AW\\|ΑΠ\\|ΣΧΕΤ\\|השב\\|Vá\\|R\\|RIF\\|BLS\\|RES\\|Odp\\|YNT\\|ATB\\)"
+ "Regexp with localized 'Re:' abbreviations in various languages."
+ :version "28.1"
+ :type 'regexp)
+
;; Some mailers use "Re(2):" or "Re^2:" or "Re: Re:" or "Re[2]:".
;; This pattern should catch all the common variants.
;; rms: I deleted the change to delete tags in square brackets
;; because they mess up RT tags.
-(defvar rmail-reply-regexp "\\`\\(Re\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?\u00a0*: *\\)*"
+(defvar rmail-reply-regexp
+ (concat "\\`\\("
+ rmail-re-abbrevs
+ "\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?\u00a0*[::] *\\)*")
"Regexp to delete from Subject line before inserting `rmail-reply-prefix'.")
(defcustom rmail-display-summary nil
@@ -651,14 +620,12 @@ Element N specifies the summary line for message N+1.")
;; Rmail buffer swapping variables.
-(defvar rmail-buffer-swapped nil
+(defvar-local rmail-buffer-swapped nil
"If non-nil, `rmail-buffer' is swapped with `rmail-view-buffer'.")
-(make-variable-buffer-local 'rmail-buffer-swapped)
(put 'rmail-buffer-swapped 'permanent-local t)
-(defvar rmail-view-buffer nil
+(defvar-local rmail-view-buffer nil
"Buffer which holds RMAIL message for MIME displaying.")
-(make-variable-buffer-local 'rmail-view-buffer)
(put 'rmail-view-buffer 'permanent-local t)
;; `Sticky' default variables.
@@ -1102,6 +1069,7 @@ The buffer is expected to be narrowed to just the header of the message."
(define-key map [?\S-\ ] 'scroll-down-command)
(define-key map "\177" 'scroll-down-command)
(define-key map "?" 'describe-mode)
+ (define-key map "\C-c\C-d" 'rmail-epa-decrypt)
(define-key map "\C-c\C-s\C-d" 'rmail-sort-by-date)
(define-key map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
(define-key map "\C-c\C-s\C-a" 'rmail-sort-by-author)
@@ -1294,6 +1262,7 @@ Instead, these commands are available:
\\[rmail-undelete-previous-message] Undelete message. Tries current message, then earlier messages
till a deleted message is found.
\\[rmail-edit-current-message] Edit the current message. \\[rmail-cease-edit] to return to Rmail.
+\\[rmail-epa-decrypt] Decrypt the current message.
\\[rmail-expunge] Expunge deleted messages.
\\[rmail-expunge-and-save] Expunge and save the file.
\\[rmail-quit] Quit Rmail: expunge, save, then switch to another buffer.
@@ -1453,27 +1422,23 @@ If so restore the actual mbox message collection."
(defun rmail-perm-variables ()
(make-local-variable 'rmail-last-regexp)
(make-local-variable 'rmail-deleted-vector)
- (make-local-variable 'rmail-buffer)
- (make-local-variable 'rmail-was-converted)
- (setq rmail-was-converted nil)
- (make-local-variable 'rmail-seriously-modified)
- (setq rmail-seriously-modified nil)
- (setq rmail-buffer (current-buffer))
+ (setq-local rmail-was-converted nil)
+ (setq-local rmail-seriously-modified nil)
+ (setq-local rmail-buffer (current-buffer))
(set-buffer-multibyte nil)
(with-current-buffer (setq rmail-view-buffer (rmail-generate-viewer-buffer))
(setq buffer-undo-list t)
;; Note that this does not erase the buffer. Should it?
;; It depends on how this is called. If somehow called with the
;; rmail buffers swapped, it would erase the message collection.
- (set (make-local-variable 'rmail-overlay-list) nil)
+ (setq-local rmail-overlay-list nil)
(set-buffer-multibyte t)
;; Force C-x C-s write Unix EOLs.
(set-buffer-file-coding-system 'undecided-unix))
(make-local-variable 'rmail-summary-buffer)
(make-local-variable 'rmail-summary-vector)
(make-local-variable 'rmail-current-message)
- (make-local-variable 'rmail-total-messages)
- (setq rmail-total-messages 0)
+ (setq-local rmail-total-messages 0)
(make-local-variable 'rmail-message-vector)
(make-local-variable 'rmail-msgref-vector)
(make-local-variable 'rmail-inbox-list)
@@ -1488,40 +1453,30 @@ If so restore the actual mbox message collection."
;; FIXME expand-file-name?
(concat rmail-spool-directory
(user-login-name)))))))
- (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
+ (setq-local tool-bar-map rmail-tool-bar-map))
;; Set up the non-permanent locals associated with Rmail mode.
(defun rmail-variables ()
;; Turn off undo. We turn it back on in rmail-edit.
(setq buffer-undo-list t)
;; Don't let a local variables list in a message cause confusion.
- (make-local-variable 'local-enable-local-variables)
- (setq local-enable-local-variables nil)
+ (setq-local local-enable-local-variables nil)
;; Don't turn off auto-saving based on the size of the buffer
;; because that code does not understand buffer-swapping.
- (make-local-variable 'auto-save-include-big-deletions)
- (setq auto-save-include-big-deletions t)
- (make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function 'rmail-revert)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(rmail-font-lock-keywords
- t t nil nil
- (font-lock-maximum-size . nil)
- (font-lock-dont-widen . t)
- (font-lock-inhibit-thing-lock . (lazy-lock-mode fast-lock-mode))))
- (make-local-variable 'require-final-newline)
- (setq require-final-newline nil)
- (make-local-variable 'version-control)
- (setq version-control 'never)
- (make-local-variable 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'rmail-mode-kill-summary)
- (make-local-variable 'file-precious-flag)
- (setq file-precious-flag t)
- (make-local-variable 'desktop-save-buffer)
- (setq desktop-save-buffer t)
- (make-local-variable 'save-buffer-coding-system)
- (setq save-buffer-coding-system 'no-conversion)
+ (setq-local auto-save-include-big-deletions t)
+ (setq-local revert-buffer-function 'rmail-revert)
+ (setq-local font-lock-defaults
+ '(rmail-font-lock-keywords
+ t t nil nil
+ (font-lock-maximum-size . nil)
+ (font-lock-dont-widen . t)
+ (font-lock-inhibit-thing-lock . (lazy-lock-mode fast-lock-mode))))
+ (setq-local require-final-newline nil)
+ (setq-local version-control 'never)
+ (add-hook 'kill-buffer-hook #'rmail-mode-kill-summary nil t)
+ (setq-local file-precious-flag t)
+ (setq-local desktop-save-buffer t)
+ (setq-local save-buffer-coding-system 'no-conversion)
(setq next-error-move-function 'rmail-next-error-move))
;; Handle M-x revert-buffer done in an rmail-mode buffer.
@@ -1766,7 +1721,7 @@ not be a new one). It returns non-nil if it got any new messages."
(buffer-read-only nil)
;; Don't make undo records while getting mail.
(buffer-undo-list t)
- delete-files files file-last-names)
+ files file-last-names) ;; delete-files
;; Pull files off all-files onto files as long as there is
;; no name conflict. A conflict happens when two inbox
;; file names have the same last component.
@@ -1788,7 +1743,7 @@ not be a new one). It returns non-nil if it got any new messages."
(while (not (looking-back "\n\n" (- (point) 2)))
(insert "\n")))
(setq found (or
- (rmail-get-new-mail-1 file-name files delete-files)
+ (rmail-get-new-mail-1 file-name files nil) ;; delete-files
found))))
;; Move to the first new message unless we have other unseen
;; messages before it.
@@ -1907,7 +1862,8 @@ interactively."
(when rmail-remote-password-required
(setq got-password (not (rmail-have-password)))
(setq supplied-password (rmail-get-remote-password
- (string-match "^imaps?" proto))))
+ (string-match "^imaps?" proto)
+ user host)))
;; FIXME
;; The password is embedded. Strip it out since movemail
;; does not really like it, in spite of the movemail spec.
@@ -1927,14 +1883,12 @@ interactively."
((string-match "^po:\\([^:]+\\)\\(:\\(.*\\)\\)?" file)
(let (got-password supplied-password
- ;; (proto "pop")
- ;; (user (match-string 1 file))
- ;; (host (match-string 3 file))
- )
+ (user (match-string 1 file))
+ (host (match-string 3 file)))
(when rmail-remote-password-required
(setq got-password (not (rmail-have-password)))
- (setq supplied-password (rmail-get-remote-password nil)))
+ (setq supplied-password (rmail-get-remote-password nil user host)))
(list file "pop" supplied-password got-password)))
@@ -2767,6 +2721,12 @@ See also `unrmail-mbox-format'."
:version "24.4"
:group 'rmail-files)
+(defcustom rmail-show-message-set-modified nil
+ "If non-nil, displaying an unseen message marks the Rmail buffer as modified."
+ :type 'boolean
+ :group 'rmail
+ :version "28.1")
+
(defun rmail-show-message-1 (&optional msg)
"Show message MSG (default: current message) using `rmail-view-buffer'.
Return text to display in the minibuffer if MSG is out of
@@ -2794,6 +2754,8 @@ The current mail message becomes the message displayed."
;; Mark the message as seen, but preserve buffer modified flag.
(let ((modiff (buffer-modified-p)))
(rmail-set-attribute rmail-unseen-attr-index nil)
+ (and rmail-show-message-set-modified
+ (setq modiff t))
(unless modiff
(restore-buffer-modified-p modiff)))
;; bracket the message in the mail
@@ -2811,7 +2773,7 @@ The current mail message becomes the message displayed."
;; rmail-header-style based on the binding in effect when
;; this function is called; `rmail-toggle-header' can
;; inspect this value to determine how to toggle.
- (set (make-local-variable 'rmail-header-style) header-style)
+ (setq-local rmail-header-style header-style)
;; In case viewing the previous message sets the paragraph
;; direction non-nil, we reset it here to allow independent
;; dynamic determination of paragraph direction in every
@@ -2822,7 +2784,7 @@ The current mail message becomes the message displayed."
(re-search-forward "mime-version: 1.0" nil t))
(let ((rmail-buffer mbox-buf)
(rmail-view-buffer view-buf))
- (set (make-local-variable 'rmail-mime-decoded) t)
+ (setq-local rmail-mime-decoded t)
(funcall rmail-show-mime-function))
(setq body-start (search-forward "\n\n" nil t))
(narrow-to-region beg (point))
@@ -2900,9 +2862,9 @@ The current mail message becomes the message displayed."
(rmail-display-labels)
(rmail-swap-buffers)
(setq rmail-buffer-swapped t)
- (run-hooks 'rmail-show-message-hook)
(when showing-message
- (setq blurb (format "Showing message %d...done" msg)))))
+ (setq blurb (format "Showing message %d...done" msg)))
+ (run-hooks 'rmail-show-message-hook)))
blurb))
(defun rmail-copy-headers (beg _end &optional ignored-headers)
@@ -3021,7 +2983,7 @@ using the coding system CODING."
(defun rmail-highlight-headers ()
"Highlight the headers specified by `rmail-highlighted-headers'.
-Uses the face specified by `rmail-highlight-face'."
+Uses the face `rmail-highlight'."
(if rmail-highlighted-headers
(save-excursion
(search-forward "\n\n" nil 'move)
@@ -3029,11 +2991,7 @@ Uses the face specified by `rmail-highlight-face'."
(narrow-to-region (point-min) (point))
(let ((case-fold-search t)
(inhibit-read-only t)
- ;; When rmail-highlight-face is removed, just
- ;; use 'rmail-highlight here.
- (face (or rmail-highlight-face
- (if (face-differs-from-default-p 'bold)
- 'bold 'highlight)))
+ (face 'rmail-highlight)
;; List of overlays to reuse.
(overlays rmail-overlay-list))
(goto-char (point-min))
@@ -3398,8 +3356,12 @@ whitespace, replacing whitespace runs with a single space and
removing prefixes such as Re:, Fwd: and so on and mailing list
tags such as [tag]."
(let ((subject (or (rmail-get-header "Subject" msgnum) ""))
- (regexp
- "\\`[ \t\n]*\\(\\(\\w\\{1,3\\}\u00a0*:\\|\\[[^]]+]\\)[ \t\n]+\\)*"))
+ (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,4\\}\u00a0*[::]\\|\\[[^]]+]\\)[ \t\n]+\\)*"))
+ ;; Corporate mailing systems sometimes add `[External] :'; if that happened,
+ ;; delete everything up thru there. Empirically, that deletion makes
+ ;; the Subject match the other messages in the thread.
+ (if (string-match "\\[external][ \t\n]*:" subject)
+ (setq subject (substring subject (match-end 0))))
(setq subject (rfc2047-decode-string subject))
(setq subject (replace-regexp-in-string regexp "" subject))
(replace-regexp-in-string "[ \t\n]+" " " subject)))
@@ -3714,9 +3676,9 @@ If BUFFER is not swapped, yank out of its message viewer buffer."
(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)))))
+ (mapcar (lambda (elt)
+ (cons (car elt) (if (stringp (cdr elt))
+ (rfc2047-decode-string (cdr elt)))))
other-headers))
(if (stringp to) (setq to (rfc2047-decode-string to)))
(if (stringp in-reply-to)
@@ -3805,32 +3767,61 @@ use \\[mail-yank-original] to yank the original message into it."
(rmail-apply-in-message
rmail-current-message
(lambda ()
- (search-forward "\n\n" nil 'move)
- (narrow-to-region (point-min) (point))
- (setq from (mail-fetch-field "from")
- reply-to (or (mail-fetch-field "mail-reply-to" nil t)
- (mail-fetch-field "reply-to" nil t)
- from)
- subject (mail-fetch-field "subject")
- date (mail-fetch-field "date")
- message-id (mail-fetch-field "message-id")
- references (mail-fetch-field "references" nil nil t)
- ;; Bug#512. It's inappropriate to reply to these addresses.
- ;;resent-reply-to (mail-fetch-field "resent-reply-to" nil t)
- ;;resent-cc (and (not just-sender)
- ;; (mail-fetch-field "resent-cc" nil t))
- ;;resent-to (or (mail-fetch-field "resent-to" nil t) "")
- ;;resent-subject (mail-fetch-field "resent-subject")
- ;;resent-date (mail-fetch-field "resent-date")
- ;;resent-message-id (mail-fetch-field "resent-message-id")
- )
- (unless just-sender
- (if (mail-fetch-field "mail-followup-to" nil t)
- ;; If this header field is present, use it instead of the
- ;; To and Cc fields.
- (setq to (mail-fetch-field "mail-followup-to" nil t))
- (setq cc (or (mail-fetch-field "cc" nil t) "")
- to (or (mail-fetch-field "to" nil t) ""))))))
+ (let ((end (point-max))
+ subheader)
+ ;; Find the message's real header.
+ (search-forward "\n\n" nil 'move)
+ (narrow-to-region (point-min) (point))
+
+ (goto-char (point-min))
+
+ ;; If this is an encrypted message, search for other header fields
+ ;; inside the encrypted part, and use them instead of the real header.
+
+ ;; First, find a From: field after a plausible section start.
+ (when (and (search-forward "\nContent-Type: multipart/encrypted;\n" nil t)
+ (save-restriction
+ (narrow-to-region (point-min) end)
+ (and (search-forward "\nFrom: " nil t)
+ (setq subheader (point)))))
+ ;; We found one, so widen up to end of message and go there.
+ (narrow-to-region (point-min) end)
+ (goto-char subheader)
+
+ ;; Find the start of the inner header.
+ (search-backward "\n--")
+ (forward-line 2)
+
+ ;; Find the end of it.
+ (let ((subheader-start (point)))
+ (goto-char subheader)
+ (search-forward "\n\n" nil 'move)
+ (narrow-to-region subheader-start (point))))
+
+ (setq from (mail-fetch-field "from")
+ reply-to (or (mail-fetch-field "mail-reply-to" nil t)
+ (mail-fetch-field "reply-to" nil t)
+ from)
+ subject (mail-fetch-field "subject")
+ date (mail-fetch-field "date")
+ message-id (mail-fetch-field "message-id")
+ references (mail-fetch-field "references" nil nil t)
+ ;; Bug#512. It's inappropriate to reply to these addresses.
+ ;;resent-reply-to (mail-fetch-field "resent-reply-to" nil t)
+ ;;resent-cc (and (not just-sender)
+ ;; (mail-fetch-field "resent-cc" nil t))
+ ;;resent-to (or (mail-fetch-field "resent-to" nil t) "")
+ ;;resent-subject (mail-fetch-field "resent-subject")
+ ;;resent-date (mail-fetch-field "resent-date")
+ ;;resent-message-id (mail-fetch-field "resent-message-id")
+ )
+ (unless just-sender
+ (if (mail-fetch-field "mail-followup-to" nil t)
+ ;; If this header field is present, use it instead of the
+ ;; To and Cc fields.
+ (setq to (mail-fetch-field "mail-followup-to" nil t))
+ (setq cc (or (mail-fetch-field "cc" nil t) "")
+ to (or (mail-fetch-field "to" nil t) "")))))))
;; Merge the resent-to and resent-cc into the to and cc.
;; Bug#512. It's inappropriate to reply to these addresses.
;;(if (and resent-to (not (equal resent-to "")))
@@ -4175,22 +4166,12 @@ The variable `rmail-retry-ignored-headers' is a regular expression
specifying headers which should not be copied into the new message."
(interactive)
(require 'mail-utils)
- ;; FIXME This does not handle rmail-mime-feature != 'rmailmm.
- ;; There is no API defined for rmail-mime-feature to provide
- ;; rmail-mime-message-p, rmail-mime-toggle-raw equivalents.
- ;; But does anyone actually use rmail-mime-feature != 'rmailmm?
- (if (and rmail-enable-mime
- (eq rmail-mime-feature 'rmailmm)
- (featurep rmail-mime-feature))
- (with-current-buffer rmail-buffer
- (if (rmail-mime-message-p)
- (let ((rmail-mime-mbox-buffer rmail-view-buffer)
- (rmail-mime-view-buffer rmail-buffer))
- (rmail-mime-toggle-raw 'raw)))))
-
- (let ((rmail-this-buffer (current-buffer))
+ (let (bounce-buffer ;; Buffer we found it in
+ bounce-start ;; Position of start of failed message in that buffer
+ bounce-end ;; Position of end of failed message in that buffer
+ bounce-indent ;; Number of columns we need to de-indent it.
(msgnum rmail-current-message)
- bounce-start bounce-end bounce-indent resending
+ resending
(content-type (rmail-get-header "Content-Type")))
(save-excursion
(goto-char (point-min))
@@ -4199,19 +4180,27 @@ specifying headers which should not be copied into the new message."
(string-match
";[\n\t ]*boundary=\"?\\([-0-9a-z'()+_,./:=? ]+\\)\"?"
content-type))
- ;; Handle a MIME multipart bounce message.
+ ;; Handle a MIME multipart bounce message
+ ;; by scanning the raw buffer.
(let ((codestring
(concat "\n--"
(substring content-type (match-beginning 1)
- (match-end 1)))))
- (unless (re-search-forward mail-mime-unsent-header nil t)
- (error "Cannot find beginning of header in failed message"))
- (unless (search-forward "\n\n" nil t)
- (error "Cannot find start of Mime data in failed message"))
- (setq bounce-start (point))
- (if (search-forward codestring nil t)
- (setq bounce-end (match-beginning 0))
- (setq bounce-end (point-max))))
+ (match-end 1))))
+ (beg (rmail-msgbeg msgnum))
+ (end (rmail-msgend msgnum)))
+ (with-current-buffer rmail-view-buffer
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (unless (re-search-forward mail-mime-unsent-header nil t)
+ (error "Cannot find beginning of header in failed message"))
+ (unless (search-forward "\n\n" nil t)
+ (error "Cannot find start of Mime data in failed message"))
+ (setq bounce-start (point))
+ (setq bounce-buffer (current-buffer))
+ (if (search-forward codestring nil t)
+ (setq bounce-end (match-beginning 0))
+ (setq bounce-end (point-max))))))
;; Non-MIME bounce.
(or (re-search-forward mail-unsent-separator nil t)
(error "Cannot parse this as a failure message"))
@@ -4226,6 +4215,7 @@ specifying headers which should not be copied into the new message."
(setq bounce-indent (- (current-column)))
(goto-char (point-max))
(re-search-backward "^End of returned message$" nil t)
+ (setq bounce-buffer (current-buffer))
(setq bounce-end (point)))
;; One message contained a few random lines before
;; the old message header. The first line of the
@@ -4242,8 +4232,10 @@ specifying headers which should not be copied into the new message."
(setq bounce-start (point))
(goto-char (point-max))
(search-backward (concat "\n\n" boundary) bounce-start t)
+ (setq bounce-buffer (current-buffer))
(setq bounce-end (point)))
(setq bounce-start (point)
+ bounce-buffer (current-buffer)
bounce-end (point-max)))
(unless (search-forward "\n\n" nil t)
(error "Cannot find end of header in failed message"))))))
@@ -4252,9 +4244,9 @@ specifying headers which should not be copied into the new message."
;; Turn off the usual actions for initializing the message body
;; because we want to get only the text from the failure message.
(let (mail-signature mail-setup-hook)
- (if (rmail-start-mail nil nil nil nil nil rmail-this-buffer
+ (if (rmail-start-mail nil nil nil nil nil rmail-buffer
(list (list 'rmail-mark-message
- rmail-this-buffer
+ rmail-buffer
(aref rmail-msgref-vector msgnum)
rmail-retried-attr-index)))
;; Insert original text as initial text of new draft message.
@@ -4263,7 +4255,7 @@ specifying headers which should not be copied into the new message."
(let ((inhibit-read-only t)
eoh)
(erase-buffer)
- (insert-buffer-substring rmail-this-buffer
+ (insert-buffer-substring bounce-buffer
bounce-start bounce-end)
(goto-char (point-min))
(if bounce-indent
@@ -4394,9 +4386,8 @@ browsing, and moving of messages."
(text face mouse function &optional token prevline))
;; Make sure our special speedbar major mode is loaded
-(if (featurep 'speedbar)
- (rmail-install-speedbar-variables)
- (add-hook 'speedbar-load-hook 'rmail-install-speedbar-variables))
+(with-eval-after-load 'speedbar
+ (rmail-install-speedbar-variables))
(defun rmail-speedbar-buttons (buffer)
"Create buttons for BUFFER containing rmail messages.
@@ -4490,15 +4481,30 @@ TEXT and INDENT are not used."
(setq rmail-remote-password nil)
(setq rmail-encoded-remote-password nil)))
-(defun rmail-get-remote-password (imap)
- "Get the password for retrieving mail from a POP or IMAP server. If none
-has been set, then prompt the user for one."
+(defun rmail-get-remote-password (imap user host)
+ "Get the password for retrieving mail from a POP or IMAP server.
+If none has been set, the password is found via auth-source. If
+you use ~/.authinfo as your auth-source backend, then put
+something like the following in that file:
+
+machine mymachine login myloginname password mypassword
+
+If auth-source search yields no result, prompt the user for the
+password."
(when (not rmail-encoded-remote-password)
(if (not rmail-remote-password)
- (setq rmail-remote-password
- (read-passwd (if imap
- "IMAP password: "
- "POP password: "))))
+ (setq rmail-remote-password
+ (let ((found (nth 0 (auth-source-search
+ :max 1 :user user :host host
+ :require '(:secret)))))
+ (if found
+ (let ((secret (plist-get found :secret)))
+ (if (functionp secret)
+ (funcall secret)
+ secret))
+ (read-passwd (if imap
+ "IMAP password: "
+ "POP password: "))))))
(rmail-set-remote-password rmail-remote-password)
(setq rmail-remote-password nil))
(rmail-encode-string rmail-encoded-remote-password (emacs-pid)))
@@ -4613,8 +4619,9 @@ Argument MIME is non-nil if this is a mime message."
;; change it in one of the calls to `epa-decrypt-region'.
(save-excursion
- (let (decrypts (mime (rmail-mime-message-p))
- mime-disabled)
+ (let (decrypts
+ (mime (and (eq major-mode 'rmail-mode) (rmail-mime-message-p)))
+ mime-disabled)
(goto-char (point-min))
;; Turn off mime processing.
@@ -4637,11 +4644,10 @@ Argument MIME is non-nil if this is a mime message."
"> ")
(push (rmail-epa-decrypt-1 mime) decrypts))))
- (when (and decrypts (eq major-mode 'rmail-mode))
- (rmail-add-label "decrypt"))
-
(when (and decrypts (rmail-buffers-swapped-p))
(when (y-or-n-p "Replace the original message? ")
+ (when (eq major-mode 'rmail-mode)
+ (rmail-add-label "decrypt"))
(setq decrypts (nreverse decrypts))
(let ((beg (rmail-msgbeg rmail-current-message))
(end (rmail-msgend rmail-current-message)))
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index f8179916c03..fd24bdceccc 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -1,4 +1,4 @@
-;;; rmailedit.el --- "RMAIL edit mode" Edit the current message
+;;; rmailedit.el --- "RMAIL edit mode" Edit the current message -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1994, 2001-2021 Free Software Foundation, Inc.
@@ -38,8 +38,8 @@
(let ((map (make-sparse-keymap)))
;; Make a keymap that inherits text-mode-map.
(set-keymap-parent map text-mode-map)
- (define-key map "\C-c\C-c" 'rmail-cease-edit)
- (define-key map "\C-c\C-]" 'rmail-abort-edit)
+ (define-key map "\C-c\C-c" #'rmail-cease-edit)
+ (define-key map "\C-c\C-]" #'rmail-abort-edit)
map))
(declare-function rmail-summary-disable "rmailsum" ())
@@ -63,16 +63,13 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(use-local-map rmail-edit-map)
(setq major-mode 'rmail-edit-mode)
(setq mode-name "RMAIL Edit")
- (if (boundp 'mode-line-modified)
- (setq mode-line-modified (default-value 'mode-line-modified))
- (setq mode-line-format (default-value 'mode-line-format)))
+ (setq mode-line-modified (default-value 'mode-line-modified))
;; Don't turn off auto-saving based on the size of the buffer
;; because that code does not understand buffer-swapping.
- (make-local-variable 'auto-save-include-big-deletions)
- (setq auto-save-include-big-deletions t)
+ (setq-local auto-save-include-big-deletions t)
;; If someone uses C-x C-s, don't clobber the rmail file (bug#2625).
(add-hook 'write-region-annotate-functions
- 'rmail-write-region-annotate nil t)
+ #'rmail-write-region-annotate nil t)
(run-mode-hooks 'rmail-edit-mode-hook)))
;; Rmail Edit mode is suitable only for specially formatted data.
@@ -100,10 +97,9 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(if (zerop rmail-total-messages)
(error "No messages in this buffer"))
(rmail-modify-format)
- (make-local-variable 'rmail-old-pruned)
- (setq rmail-old-pruned (rmail-msg-is-pruned))
+ (setq-local rmail-old-pruned (rmail-msg-is-pruned))
(rmail-edit-mode)
- (set (make-local-variable 'rmail-old-mime-state)
+ (setq-local rmail-old-mime-state
(and rmail-enable-mime
;; If you use something else, you are on your own.
(eq rmail-mime-feature 'rmailmm)
@@ -127,13 +123,11 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(goto-char (point-min))
;; t = decoded; raw = raw.
(aref (aref (rmail-mime-entity-display entity) 0) 0)))))
- (make-local-variable 'rmail-old-text)
- (setq rmail-old-text
- (save-restriction
- (widen)
- (buffer-substring (point-min) (point-max))))
- (make-local-variable 'rmail-old-headers)
- (setq rmail-old-headers (rmail-edit-headers-alist t))
+ (setq-local rmail-old-text
+ (save-restriction
+ (widen)
+ (buffer-substring (point-min) (point-max))))
+ (setq-local rmail-old-headers (rmail-edit-headers-alist t))
(setq buffer-read-only nil)
(setq buffer-undo-list nil)
;; Whether the buffer is initially marked as modified or not
@@ -151,8 +145,9 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(declare-function rmail-summary-enable "rmailsum" ())
(declare-function rmail-summary-update-line "rmailsum" (n))
-(defun rmail-cease-edit ()
- "Finish editing message; switch back to Rmail proper."
+(defun rmail-cease-edit (&optional abort)
+ "Finish editing message; switch back to Rmail proper.
+If ABORT, this is the result of aborting an edit."
(interactive)
(if (rmail-summary-exists)
(with-current-buffer rmail-summary-buffer
@@ -211,7 +206,7 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(kill-all-local-variables)
(rmail-mode-1)
(if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
+ (setq-local tool-bar-map rmail-tool-bar-map))
(setq buffer-undo-list t)
(rmail-variables))
;; If text has really changed, mark message as edited.
@@ -277,6 +272,8 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
;; No match for rmail-mime-charset-pattern, but there was some
;; other Content-Type. We should not insert another. (Bug#4624)
(content-type)
+ ;; Don't insert anything if aborting.
+ (abort)
((null old-coding)
;; If there was no charset= spec, insert one.
(backward-char 1)
@@ -358,7 +355,7 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
(widen)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
- (rmail-cease-edit)
+ (rmail-cease-edit t)
(rmail-highlight-headers))
(defun rmail-edit-headers-alist (&optional widen markers)
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index 657b3629bd1..acbb5880b5c 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -1,4 +1,4 @@
-;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs
+;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1988, 1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -73,7 +73,7 @@ according to the choice made, and returns a symbol."
(or (eq major-mode 'rmail-summary-mode)
(rmail-summary-exists)
(and (setq old (rmail-get-keywords))
- (mapc 'rmail-make-label (split-string old ", "))))
+ (mapc #'rmail-make-label (split-string old ", "))))
(completing-read (concat prompt
(if rmail-last-label
(concat " (default "
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index ab5b49aab92..99bff66657b 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -1,4 +1,4 @@
-;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
+;;; rmailmm.el --- MIME decoding and display stuff for RMAIL -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -78,6 +78,7 @@
(require 'rmail)
(require 'mail-parse)
(require 'message)
+(require 'cl-lib)
;;; User options.
@@ -101,8 +102,7 @@ all others are handled by `rmail-mime-bulk-handler'.
Note also that this alist is ignored when the variable
`rmail-enable-mime' is non-nil."
:type '(alist :key-type regexp :value-type (repeat function))
- :version "23.1"
- :group 'rmail-mime)
+ :version "23.1")
(defcustom rmail-mime-attachment-dirs-alist
`(("text/.*" "~/Documents")
@@ -114,8 +114,7 @@ The first item is a regular expression matching a content-type.
The remaining elements are directories, in order of decreasing preference.
The first directory that exists is used."
:type '(alist :key-type regexp :value-type (repeat directory))
- :version "23.1"
- :group 'rmail-mime)
+ :version "23.1")
(defcustom rmail-mime-show-images 'button
"What to do with image attachments that Emacs is capable of displaying.
@@ -128,12 +127,11 @@ automatically display the image in the buffer."
(const :tag "No special treatment" nil)
(number :tag "Show if smaller than certain size")
(other :tag "Always show" show))
- :version "23.2"
- :group 'rmail-mime)
+ :version "23.2")
(defcustom rmail-mime-render-html-function
- (cond ((fboundp 'libxml-parse-html-region) 'rmail-mime-render-html-shr)
- ((executable-find "lynx") 'rmail-mime-render-html-lynx)
+ (cond ((fboundp 'libxml-parse-html-region) #'rmail-mime-render-html-shr)
+ ((executable-find "lynx") #'rmail-mime-render-html-lynx)
(t nil))
"Function to convert HTML to text.
Called with buffer containing HTML extracted from message in a
@@ -177,9 +175,12 @@ operations such as HTML decoding")
;;; MIME-entity object
-(defun rmail-mime-entity (type disposition transfer-encoding
- display header tagline body children handler
- &optional truncated)
+(cl-defstruct (rmail-mime-entity
+ (:copier nil) (:constructor nil)
+ (:constructor rmail-mime-entity
+ ( type disposition transfer-encoding
+ display header tagline body children handler
+ &optional truncated)
"Return a newly created MIME-entity object from arguments.
A MIME-entity is a vector of 10 elements:
@@ -210,12 +211,7 @@ Content-Transfer-Encoding, and is a lower-case string.
DISPLAY is a vector [CURRENT NEW], where CURRENT indicates how
the header, tag line, and body of the entity are displayed now,
and NEW indicates how their display should be updated.
-Both elements are vectors [HEADER-DISPLAY TAGLINE-DISPLAY BODY-DISPLAY],
-where each constituent element is a symbol for the corresponding
-item with these values:
- nil: not displayed
- t: displayed by the decoded presentation form
- raw: displayed by the raw MIME data (for the header and body only)
+Both elements are `rmail-mime-display' objects.
HEADER and BODY are vectors [BEG END DISPLAY-FLAG], where BEG and
END are markers that specify the region of the header or body lines
@@ -236,24 +232,13 @@ has just one child. Any other entity has no child.
HANDLER is a function to insert the entity according to DISPLAY.
It is called with one argument ENTITY.
-TRUNCATED is non-nil if the text of this entity was truncated."
-
- (vector type disposition transfer-encoding
- display header tagline body children handler truncated))
-
-;; Accessors for a MIME-entity object.
-(defsubst rmail-mime-entity-type (entity) (aref entity 0))
-(defsubst rmail-mime-entity-disposition (entity) (aref entity 1))
-(defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2))
-(defsubst rmail-mime-entity-display (entity) (aref entity 3))
-(defsubst rmail-mime-entity-header (entity) (aref entity 4))
-(defsubst rmail-mime-entity-tagline (entity) (aref entity 5))
-(defsubst rmail-mime-entity-body (entity) (aref entity 6))
-(defsubst rmail-mime-entity-children (entity) (aref entity 7))
-(defsubst rmail-mime-entity-handler (entity) (aref entity 8))
-(defsubst rmail-mime-entity-truncated (entity) (aref entity 9))
+TRUNCATED is non-nil if the text of this entity was truncated."))
+ type disposition transfer-encoding
+ display header tagline body children handler truncated)
+
(defsubst rmail-mime-entity-set-truncated (entity truncated)
- (aset entity 9 truncated))
+ (declare (obsolete (setf rmail-mime-entity-truncated) "28.1"))
+ (setf (rmail-mime-entity-truncated entity) truncated))
;;; Buttons
@@ -303,9 +288,16 @@ TRUNCATED is non-nil if the text of this entity was truncated."
;; Display options returned by rmail-mime-entity-display.
;; Value is on of nil, t, raw.
-(defsubst rmail-mime-display-header (disp) (aref disp 0))
-(defsubst rmail-mime-display-tagline (disp) (aref disp 1))
-(defsubst rmail-mime-display-body (disp) (aref disp 2))
+(cl-defstruct (rmail-mime-display
+ (:copier rmail-mime--copy-display) (:constructor nil)
+ (:constructor rmail-mime--make-display (header tagline body)
+ "Make an object describing how to display.
+Each field's value is a symbol for the corresponding
+item with these values:
+ nil: not displayed
+ t: displayed by the decoded presentation form
+ raw: displayed by the raw MIME data (for the header and body only)."))
+ header tagline body)
(defun rmail-mime-entity-segment (pos &optional entity)
"Return a vector describing the displayed region of a MIME-entity at POS.
@@ -371,27 +363,30 @@ The value is a vector [INDEX HEADER TAGLINE BODY END], where
(defun rmail-mime-shown-mode (entity)
"Make MIME-entity ENTITY display in the default way."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
- (aset new 0 (aref (rmail-mime-entity-header entity) 2))
- (aset new 1 (aref (rmail-mime-entity-tagline entity) 2))
- (aset new 2 (aref (rmail-mime-entity-body entity) 2)))
+ (setf (rmail-mime-display-header new)
+ (aref (rmail-mime-entity-header entity) 2))
+ (setf (rmail-mime-display-tagline new)
+ (aref (rmail-mime-entity-tagline entity) 2))
+ (setf (rmail-mime-display-body new)
+ (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 display in hidden mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
- (aset new 0 nil)
- (aset new 1 t)
- (aset new 2 nil))
+ (setf (rmail-mime-display-header new) nil)
+ (setf (rmail-mime-display-tagline new) t)
+ (setf (rmail-mime-display-body new) nil))
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-hidden-mode child)))
(defun rmail-mime-raw-mode (entity)
"Make MIME-entity ENTITY display in raw mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
- (aset new 0 'raw)
- (aset new 1 nil)
- (aset new 2 'raw))
+ (setf (rmail-mime-display-header new) 'raw)
+ (setf (rmail-mime-display-tagline new) nil)
+ (setf (rmail-mime-display-body new) 'raw))
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-raw-mode child)))
@@ -404,8 +399,8 @@ Use `raw' for raw mode, and any other non-nil value for decoded mode."
(current (aref (rmail-mime-entity-display entity) 0))
(segment (rmail-mime-entity-segment pos entity)))
(if (or (eq state 'raw)
- (and (not state)
- (not (eq (rmail-mime-display-header current) 'raw))))
+ (not (or state
+ (eq (rmail-mime-display-header current) 'raw))))
;; Enter the raw mode.
(rmail-mime-raw-mode entity)
;; Enter the shown mode.
@@ -439,7 +434,7 @@ Use `raw' for raw mode, and any other non-nil value for decoded mode."
;; header.
(if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min)))
(let ((new (aref (rmail-mime-entity-display entity) 1)))
- (aset new 0 t))))
+ (setf (rmail-mime-display-header new) t))))
;; Query as a warning before showing if truncated.
(if (and (not (stringp entity))
(rmail-mime-entity-truncated entity))
@@ -448,7 +443,8 @@ Use `raw' for raw mode, and any other non-nil value for decoded mode."
;; Enter the shown mode.
(rmail-mime-shown-mode entity)
;; Force this body shown.
- (aset (aref (rmail-mime-entity-display entity) 1) 2 t))
+ (let ((new (aref (rmail-mime-entity-display entity) 1)))
+ (setf (rmail-mime-display-body new) t)))
(let ((inhibit-read-only t)
(modified (buffer-modified-p))
(rmail-mime-mbox-buffer rmail-view-buffer)
@@ -458,9 +454,9 @@ Use `raw' for raw mode, and any other non-nil value for decoded mode."
(rmail-mime-insert entity)
(restore-buffer-modified-p modified))))))
-(define-key rmail-mode-map "\t" 'forward-button)
-(define-key rmail-mode-map [backtab] 'backward-button)
-(define-key rmail-mode-map "\r" 'rmail-mime-toggle-hidden)
+(define-key rmail-mode-map "\t" #'forward-button)
+(define-key rmail-mode-map [backtab] #'backward-button)
+(define-key rmail-mode-map "\r" #'rmail-mime-toggle-hidden)
;;; Handlers
@@ -483,7 +479,7 @@ to the tag line."
(when item
(if (stringp item)
(insert item)
- (apply 'insert-button item))))
+ (apply #'insert-button item))))
;; Follow the tagline by an empty line to make it a separate
;; paragraph, so that the paragraph direction of the following text
;; is determined based on that text.
@@ -495,8 +491,10 @@ to the tag line."
(modified (buffer-modified-p))
;; If we are going to show the body, the new button label is
;; "Hide". Otherwise, it's "Show".
- (label (if (aref (aref (rmail-mime-entity-display entity) 1) 2) "Hide"
- "Show"))
+ (label
+ (if (rmail-mime-display-body
+ (aref (rmail-mime-entity-display entity) 1))
+ "Hide" "Show"))
(button (next-button (point))))
;; Go to the second character of the button "Show" or "Hide".
(goto-char (1+ (button-start button)))
@@ -556,9 +554,10 @@ HEADER is a header component of a MIME-entity object (see
(rmail-mime-insert-text
(rmail-mime-entity content-type content-disposition
content-transfer-encoding
- (vector (vector nil nil nil) (vector nil nil t))
+ (vector (rmail-mime--make-display nil nil nil)
+ (rmail-mime--make-display nil nil t))
(vector nil nil nil) (vector "" (cons nil nil) t)
- (vector nil nil nil) nil 'rmail-mime-insert-text))
+ (vector nil nil nil) nil #'rmail-mime-insert-text))
t)
(defun rmail-mime-insert-decoded-text (entity)
@@ -592,7 +591,7 @@ HEADER is a header component of a MIME-entity object (see
(let ((current (aref (rmail-mime-entity-display entity) 0))
(new (aref (rmail-mime-entity-display entity) 1))
(header (rmail-mime-entity-header entity))
- (tagline (rmail-mime-entity-tagline entity))
+ ;; (tagline (rmail-mime-entity-tagline entity))
(body (rmail-mime-entity-body entity))
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
@@ -634,7 +633,7 @@ HEADER is a header component of a MIME-entity object (see
(defun rmail-mime-insert-image (entity)
"Decode and insert the image body of MIME-entity ENTITY."
- (let* ((content-type (car (rmail-mime-entity-type entity)))
+ (let* (;; (content-type (car (rmail-mime-entity-type entity)))
(bulk-data (aref (rmail-mime-entity-tagline entity) 1))
(body (rmail-mime-entity-body entity))
data)
@@ -709,6 +708,9 @@ HEADER is a header component of a MIME-entity object (see
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url discard-comments))
+(defvar shr-inhibit-images)
+(defvar shr-width)
+
(defun rmail-mime-render-html-shr (source-buffer)
(let ((dom (with-current-buffer source-buffer
(libxml-parse-html-region (point-min) (point-max))))
@@ -759,7 +761,8 @@ For images that Emacs is capable of displaying, the behavior
depends upon the value of `rmail-mime-show-images'."
(rmail-mime-insert-bulk
(rmail-mime-entity content-type content-disposition content-transfer-encoding
- (vector (vector nil nil nil) (vector nil t nil))
+ (vector (rmail-mime--make-display nil nil nil)
+ (rmail-mime--make-display nil t nil))
(vector nil nil nil) (vector "" (cons nil nil) t)
(vector nil nil nil) nil 'rmail-mime-insert-bulk)))
@@ -781,9 +784,11 @@ directly."
(let ((encoding (rmail-mime-entity-transfer-encoding entity)))
(setq size (- (aref body 1) (aref body 0)))
(cond ((string= encoding "base64")
- (setq size (/ (* size 3) 4)))
+ ;; https://en.wikipedia.org/wiki/Base64#MIME
+ (setq size (* size 0.73)))
((string= encoding "quoted-printable")
- (setq size (/ (* size 7) 3)))))))
+ ;; Assume most of the text is ASCII...
+ (setq size (/ (* size 5) 7)))))))
(cond
((string-match "text/html" content-type)
@@ -1024,9 +1029,10 @@ The other arguments are the same as `rmail-mime-multipart-handler'."
nil (format "%s/%d" parse-tag index)
content-type content-disposition)))
;; Display a tagline.
- (aset (aref (rmail-mime-entity-display child) 1) 1
+ (setf (rmail-mime-display-tagline
+ (aref (rmail-mime-entity-display child) 1))
(aset (rmail-mime-entity-tagline child) 2 t))
- (rmail-mime-entity-set-truncated child truncated)
+ (setf (rmail-mime-entity-truncated child) truncated)
(push child entities)))
(delete-region end next)
@@ -1072,8 +1078,8 @@ The other arguments are the same as `rmail-mime-multipart-handler'."
(let ((current (aref (rmail-mime-entity-display entity) 0))
(new (aref (rmail-mime-entity-display entity) 1))
(header (rmail-mime-entity-header entity))
- (tagline (rmail-mime-entity-tagline entity))
- (body (rmail-mime-entity-body entity))
+ ;; (tagline (rmail-mime-entity-tagline entity))
+ ;; (body (rmail-mime-entity-body entity))
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
;; header
@@ -1169,13 +1175,11 @@ The parsed header value:
content-transfer-encoding))
(save-restriction
(widen)
- (let ((entity (get-text-property (1- (point)) 'rmail-mime-entity))
- current new)
+ (let ((entity (get-text-property (1- (point)) 'rmail-mime-entity)))
(when entity
- (setq current (aref (rmail-mime-entity-display entity) 0)
- new (aref (rmail-mime-entity-display entity) 1))
- (dotimes (i 3)
- (aset current i (aref new i)))))))
+ (let ((new (aref (rmail-mime-entity-display entity) 1)))
+ (setf (aref (rmail-mime-entity-display entity) 0)
+ (rmail-mime--copy-display new)))))))
(defun rmail-mime-show (&optional show-headers)
"Handle the current buffer as a MIME message.
@@ -1240,13 +1244,15 @@ modified."
(header (vector (point-min-marker) hdr-end nil))
(tagline (vector parse-tag (cons nil nil) t))
(body (vector hdr-end (point-max-marker) is-inline))
- (new (vector (aref header 2) (aref tagline 2) (aref body 2)))
+ (new (rmail-mime--make-display
+ (aref header 2) (aref tagline 2) (aref body 2)))
children handler entity)
(cond ((string-match "multipart/.*" (car content-type))
(save-restriction
(narrow-to-region (1- end) (point-max))
(if (zerop (length parse-tag)) ; top level of message
- (aset new 1 (aset tagline 2 nil))) ; don't show tagline
+ (setf (rmail-mime-display-tagline new)
+ (aset tagline 2 nil))) ; don't show tagline
(setq children (rmail-mime-process-multipart
content-type
content-disposition
@@ -1260,37 +1266,38 @@ modified."
'("text/plain") '("inline")))
(msg-new (aref (rmail-mime-entity-display msg) 1)))
;; Show header of the child.
- (aset msg-new 0 t)
+ (setf (rmail-mime-display-header msg-new) t)
(aset (rmail-mime-entity-header msg) 2 t)
;; Hide tagline of the child.
- (aset msg-new 1 nil)
+ (setf (rmail-mime-display-tagline msg-new) nil)
(aset (rmail-mime-entity-tagline msg) 2 nil)
(setq children (list msg)
handler 'rmail-mime-insert-multipart))))
((and is-inline (string-match "text/html" (car content-type)))
;; Display tagline, so part can be detached
- (aset new 1 (aset tagline 2 t))
- (aset new 2 (aset body 2 t)) ; display body also.
+ (setf (rmail-mime-display-tagline new) (aset tagline 2 t))
+ (setf (rmail-mime-display-body new) (aset body 2 t)) ; display body also.
(setq handler 'rmail-mime-insert-bulk))
;; Inline non-HTML text
((and is-inline (string-match "text/" (car content-type)))
;; Don't need a tagline.
- (aset new 1 (aset tagline 2 nil))
+ (setf (rmail-mime-display-tagline new) (aset tagline 2 nil))
(setq handler 'rmail-mime-insert-text))
(t
;; Force hidden mode.
- (aset new 1 (aset tagline 2 t))
- (aset new 2 (aset body 2 nil))
+ (setf (rmail-mime-display-tagline new) (aset tagline 2 t))
+ (setf (rmail-mime-display-body new) (aset body 2 nil))
(setq handler 'rmail-mime-insert-bulk)))
- (setq entity (rmail-mime-entity content-type
- content-disposition
- content-transfer-encoding
- (vector (vector nil nil nil) new)
- header tagline body children handler))
+ (setq entity (rmail-mime-entity
+ content-type
+ content-disposition
+ content-transfer-encoding
+ (vector (rmail-mime--make-display nil nil nil) new)
+ header tagline body children handler))
(if (and (eq handler 'rmail-mime-insert-bulk)
(rmail-mime-set-bulk-data entity))
;; Show the body.
- (aset new 2 (aset body 2 t)))
+ (setf (rmail-mime-display-body new) (aset body 2 t)))
entity)
;; Hide headers and handle the part.
@@ -1324,7 +1331,8 @@ If an error occurs, return an error message string."
'("text/plain") '("inline")))
(new (aref (rmail-mime-entity-display entity) 1)))
;; Show header.
- (aset new 0 (aset (rmail-mime-entity-header entity) 2 t))
+ (setf (rmail-mime-display-header new)
+ (aset (rmail-mime-entity-header entity) 2 t))
entity)))
(error (format "%s" err)))))
@@ -1339,7 +1347,7 @@ available."
;; Not a raw-mode. Each handler should handle it.
(funcall (rmail-mime-entity-handler entity) entity)
(let ((header (rmail-mime-entity-header entity))
- (tagline (rmail-mime-entity-tagline entity))
+ ;; (tagline (rmail-mime-entity-tagline entity))
(body (rmail-mime-entity-body entity))
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
@@ -1370,15 +1378,15 @@ available."
(aref body 0) (aref body 1))
(or (bolp) (insert "\n")))
(put-text-property beg (point) 'rmail-mime-entity entity)))))
- (dotimes (i 3)
- (aset current i (aref new i)))))
+ (setf (aref (rmail-mime-entity-display entity) 0)
+ (rmail-mime--copy-display new))))
(define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
"Major mode used in `rmail-mime' buffers."
(setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil)))
;;;###autoload
-(defun rmail-mime (&optional arg state)
+(defun rmail-mime (&optional _arg state)
"Toggle the display of a MIME message.
The actual behavior depends on the value of `rmail-enable-mime'.
@@ -1396,7 +1404,7 @@ are handled according to `rmail-mime-media-type-handlers-alist'.
By default, this displays text and multipart messages, and offers to
download attachments as specified by `rmail-mime-attachment-dirs-alist'.
The arguments ARG and STATE have no effect in this case."
- (interactive (list current-prefix-arg nil))
+ (interactive)
(if rmail-enable-mime
(with-current-buffer rmail-buffer
(if (or (rmail-mime-message-p)
@@ -1442,7 +1450,7 @@ The arguments ARG and STATE have no effect in this case."
(rmail-mime-view-buffer rmail-view-buffer)
(rmail-mime-coding-system nil))
;; If ENTITY is not a vector, it is a string describing an error.
- (if (vectorp entity)
+ (if (rmail-mime-entity-p entity)
(with-current-buffer rmail-mime-view-buffer
(erase-buffer)
;; This condition-case is for catching an error in the
@@ -1530,7 +1538,7 @@ This is the usual value of `rmail-insert-mime-forwarded-message-function'."
(rmail-mime-view-buffer rmail-view-buffer)
(header-end (save-excursion
(re-search-forward "^$" nil 'move) (point)))
- (body-end (point-max))
+ ;; (body-end (point-max))
(entity (rmail-mime-parse)))
(or
;; At first, just search the headers.
diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el
index ef5f3c31bbc..673b2c5a7e5 100644
--- a/lisp/mail/rmailmsc.el
+++ b/lisp/mail/rmailmsc.el
@@ -1,4 +1,4 @@
-;;; rmailmsc.el --- miscellaneous support functions for the RMAIL mail reader
+;;; rmailmsc.el --- miscellaneous support functions for the RMAIL mail reader -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -45,7 +45,7 @@ This applies only to the current session."
(nreverse (mail-parse-comma-list)))))
(when (or (not rmail-inbox-list)
(y-or-n-p (concat "Replace "
- (mapconcat 'identity
+ (mapconcat #'identity
rmail-inbox-list
", ")
"? ")))
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index 9305a48b8d8..eb8590f1f73 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -1,4 +1,4 @@
-;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
+;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1987, 1993-1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -81,14 +81,14 @@ This uses `rmail-output-file-alist'."
(widen)
(narrow-to-region beg end)
(let ((tail rmail-output-file-alist)
- answer err)
+ answer) ;; err
;; Suggest a file based on a pattern match.
(while (and tail (not answer))
(goto-char (point-min))
(if (re-search-forward (caar tail) nil t)
(setq answer
(condition-case err
- (eval (cdar tail))
+ (eval (cdar tail) t)
(error
(display-warning
'rmail-output
@@ -197,7 +197,8 @@ display message number MSG."
(defun rmail-convert-to-babyl-format ()
"Convert the mbox message in the current buffer to Babyl format."
- (let ((count 0) (start (point-min))
+ (let (;; (count 0)
+ (start (point-min))
(case-fold-search nil)
(buffer-undo-list t))
(goto-char (point-min))
@@ -357,7 +358,7 @@ unless NOMSG is a symbol (neither nil nor t).
AS-SEEN is non-nil if we are copying the message \"as seen\"."
(let ((case-fold-search t)
encrypted-file-name
- from date)
+ ) ;; from date
(goto-char (point-min))
;; Preserve the Mail-From and MIME-Version fields
;; even if they have been pruned.
diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
index 2c42e6c8598..1669c8cd7bb 100644
--- a/lisp/mail/rmailsort.el
+++ b/lisp/mail/rmailsort.el
@@ -1,4 +1,4 @@
-;;; rmailsort.el --- Rmail: sort messages
+;;; rmailsort.el --- Rmail: sort messages -*- lexical-binding: t; -*-
;; Copyright (C) 1990, 1993-1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -142,7 +142,7 @@ If prefix argument REVERSE is non-nil, sorts in reverse order."
"\\(,\\|\\'\\)")
labelvec))
(setq labels (substring labels (match-end 0))))
- (setq labelvec (apply 'vector (nreverse labelvec))
+ (setq labelvec (apply #'vector (nreverse labelvec))
nmax (length labelvec))
(rmail-sort-messages reverse
;; If no labels match, returns nmax; if they
@@ -205,7 +205,7 @@ Numeric keys are sorted numerically, all others as strings."
(inhibit-read-only t)
(current-message nil)
(msgnum 1)
- (msginfo nil)
+ ;; (msginfo nil)
(undo (not (eq buffer-undo-list t))))
;; There's little hope that we can easily undo after that.
(buffer-disable-undo (current-buffer))
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index f7b3ba0bd76..ac933b9706d 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of summaries."
:group 'rmail-summary)
(defvar rmail-summary-font-lock-keywords
- '(("^.....D.*" . font-lock-string-face) ; Deleted.
- ("^.....-.*" . font-lock-type-face) ; Unread.
+ '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted.
+ ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread.
;; Neither of the below will be highlighted if either of the above are:
- ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date.
+ ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date.
("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels.
"Additional expressions to highlight in Rmail Summary mode.")
@@ -121,6 +121,7 @@ Setting this option to nil might speed up the generation of summaries."
(define-key map [?\S-\ ] 'rmail-summary-scroll-msg-down)
(define-key map "\177" 'rmail-summary-scroll-msg-down)
(define-key map "?" 'describe-mode)
+ (define-key map "\C-c\C-d" 'rmail-summary-epa-decrypt)
(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)
@@ -532,8 +533,7 @@ message."
;; Set up the rest of its state and local variables.
(setq buffer-read-only t)
(rmail-summary-mode)
- (make-local-variable 'minor-mode-alist)
- (setq minor-mode-alist (list (list t (concat ": " description))))
+ (setq-local minor-mode-alist (list (list t (concat ": " description))))
(setq rmail-buffer rbuf
rmail-summary-redo redo
rmail-total-messages total)))
@@ -755,7 +755,12 @@ the message being processed."
(forward-char -1)
(skip-chars-backward " \t")
(point))))))
- len mch lo)
+ len mch lo newline)
+ ;; If there are multiple lines in FROM,
+ ;; discard up to the last newline in it.
+ (while (and (stringp from)
+ (setq newline (string-match "\n" from)))
+ (setq from (substring from (1+ newline))))
(if (or (null from)
(string-match
(or rmail-user-mail-address-regexp
@@ -930,14 +935,15 @@ a negative argument means to delete and move backward."
(unless (numberp count) (setq count 1))
(let (del-msg
(backward (< count 0)))
- (while (and (/= count 0)
- ;; Don't waste time if we are at the beginning
- ;; and trying to go backward.
- (not (and backward (bobp))))
+ (while (/= count 0)
+ ;; Don't waste time counting down without doing anything if we
+ ;; are at the beginning and trying to go backward.
+ (if (and backward (bobp))
+ (setq count -1))
(rmail-summary-goto-msg)
(with-current-buffer rmail-buffer
- (rmail-delete-message)
- (setq del-msg rmail-current-message))
+ (setq del-msg rmail-current-message)
+ (rmail-delete-message))
(rmail-summary-mark-deleted del-msg)
(while (and (not (if backward (bobp) (eobp)))
(save-excursion (beginning-of-line)
@@ -974,8 +980,9 @@ a negative argument means to delete and move forward."
(delete-char 1)
(insert "D"))
;; Discard cached new summary line.
- (with-current-buffer rmail-buffer
- (aset rmail-summary-vector (1- n) nil))))
+ (when n
+ (with-current-buffer rmail-buffer
+ (aset rmail-summary-vector (1- n) nil)))))
(beginning-of-line))
(defun rmail-summary-update-line (n)
@@ -1094,13 +1101,10 @@ Commands for sorting the summary:
(set-syntax-table text-mode-syntax-table)
(make-local-variable 'rmail-buffer)
(make-local-variable 'rmail-total-messages)
- (make-local-variable 'rmail-current-message)
- (setq rmail-current-message nil)
- (make-local-variable 'rmail-summary-redo)
- (setq rmail-summary-redo nil)
+ (setq-local rmail-current-message nil)
+ (setq-local rmail-summary-redo nil)
(make-local-variable 'revert-buffer-function)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(rmail-summary-font-lock-keywords t))
+ (setq-local font-lock-defaults '(rmail-summary-font-lock-keywords t))
(rmail-summary-enable))
;; Summary features need to be disabled during edit mode.
@@ -1293,8 +1297,7 @@ Returns non-nil if message N was found."
;; Make sure we have an overlay to use.
(or rmail-summary-overlay
(progn
- (make-local-variable 'rmail-summary-overlay)
- (setq rmail-summary-overlay (make-overlay (point) (point)))
+ (setq-local rmail-summary-overlay (make-overlay (point) (point)))
(overlay-put rmail-summary-overlay 'rmail-summary t)))
;; If this message is in the summary, use the overlay to highlight it.
;; Otherwise, don't highlight anything.
@@ -1492,6 +1495,12 @@ argument says to read a file name and use that file as the inbox."
(rmail-edit-current-message)
(use-local-map rmail-summary-edit-map))
+(defun rmail-summary-epa-decrypt ()
+ "Decrypt this message."
+ (interactive)
+ (rmail-pop-to-buffer rmail-buffer)
+ (rmail-epa-decrypt))
+
(defun rmail-summary-cease-edit ()
"Finish editing message, then go back to Rmail summary buffer."
(interactive)
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 15f7f224028..fee11c06aa7 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -30,6 +30,7 @@
(require 'mail-utils)
(require 'rfc2047)
(autoload 'message-make-date "message")
+(autoload 'message-narrow-to-headers "message")
(defgroup sendmail nil
"Mail sending commands for Emacs."
@@ -537,7 +538,7 @@ This also saves the value of `send-mail-function' via Customize."
(display-buffer (current-buffer))
(let ((completion-ignore-case t))
(completing-read
- (format "Send mail via (default %s): " (caar options))
+ (format-prompt "Send mail via" (caar options))
options nil 'require-match nil nil (car options))))))
;; Return the choice.
(cdr (assoc-string choice options t))))
@@ -699,29 +700,25 @@ Turning on Mail mode runs the normal hooks `text-mode-hook' and
(make-local-variable 'mail-reply-action)
(make-local-variable 'mail-send-actions)
(make-local-variable 'mail-return-action)
- (make-local-variable 'mail-encode-mml)
- (setq mail-encode-mml nil)
+ (setq-local mail-encode-mml nil)
(setq buffer-offer-save t)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(mail-font-lock-keywords t t))
+ (setq-local font-lock-defaults '(mail-font-lock-keywords t t))
(make-local-variable 'paragraph-separate)
(setq-local normal-auto-fill-function #'mail-mode-auto-fill)
(setq-local fill-paragraph-function #'mail-mode-fill-paragraph)
;; Allow using comment commands to add/remove quoting (this only does
;; anything if mail-yank-prefix is set to a non-nil value).
- (set (make-local-variable 'comment-start) mail-yank-prefix)
+ (setq-local comment-start mail-yank-prefix)
(if mail-yank-prefix
- (set (make-local-variable 'comment-start-skip)
- (concat "^" (regexp-quote mail-yank-prefix) "[ \t]*")))
- (make-local-variable 'adaptive-fill-regexp)
+ (setq-local comment-start-skip
+ (concat "^" (regexp-quote mail-yank-prefix) "[ \t]*")))
;; Also update the paragraph-separate entry if you change this.
- (setq adaptive-fill-regexp
- (concat "[ \t]*[-[:alnum:]]+>+[ \t]*\\|"
- adaptive-fill-regexp))
- (make-local-variable 'adaptive-fill-first-line-regexp)
- (setq adaptive-fill-first-line-regexp
- (concat "[ \t]*[-[:alnum:]]*>+[ \t]*\\|"
- adaptive-fill-first-line-regexp))
+ (setq-local adaptive-fill-regexp
+ (concat "[ \t]*[-[:alnum:]]+>+[ \t]*\\|"
+ adaptive-fill-regexp))
+ (setq-local 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
@@ -729,14 +726,21 @@ Turning on Mail mode runs the normal hooks `text-mode-hook' and
;; Lines containing just >= 3 dashes, perhaps after whitespace,
;; are also sometimes used and should be separators.
(setq paragraph-separate
- (concat (regexp-quote mail-header-separator)
+ (if (zerop (length mail-header-separator))
+ (concat
;; This is based on adaptive-fill-regexp (presumably
;; the idea is to allow navigation etc of cited paragraphs).
- "$\\|\t*[-–!|#%;>*·•‣âƒâ—¦ ]+$"
+ "\t*[-–!|#%;>*·•‣âƒâ—¦ ]+$"
"\\|[ \t]*[-[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
"--\\( \\|-+\\)$\\|"
- page-delimiter)))
-
+ page-delimiter)
+ (concat (regexp-quote mail-header-separator)
+ ;; This is based on adaptive-fill-regexp (presumably
+ ;; the idea is to allow navigation etc of cited paragraphs).
+ "$\\|\t*[-–!|#%;>*·•‣âƒâ—¦ ]+$"
+ "\\|[ \t]*[-[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
+ "--\\( \\|-+\\)$\\|"
+ page-delimiter))))
(defun mail-header-end ()
"Return the buffer location of the end of headers, as a number."
@@ -766,10 +770,11 @@ Concretely: replace the first blank line in the header with the separator."
"Remove header separator to put the message in correct form for sendmail.
Leave point at the start of the delimiter line."
(goto-char (point-min))
- (when (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n")
- nil t)
- (replace-match "\n"))
+ (unless (zerop (length mail-header-separator))
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n")
+ nil t)
+ (replace-match "\n")))
(rfc822-goto-eoh))
(defun mail-mode-auto-fill ()
@@ -891,8 +896,9 @@ the user from the mailer."
(concat "\\(?:[[:space:];,]\\|\\`\\)"
(regexp-opt mail-mailing-lists t)
"\\(?:[[:space:];,]\\|\\'\\)"))))
- (mail-combine-fields "To")
- (mail-combine-fields "Cc")
+ (unless noninteractive
+ (mail-combine-fields "To")
+ (mail-combine-fields "Cc"))
;; If there are mailing lists defined
(when ml
(save-excursion
@@ -934,7 +940,9 @@ the user from the mailer."
(error "Message contains non-ASCII characters"))))
;; Complain about any invalid line.
(goto-char (point-min))
- (re-search-forward (regexp-quote mail-header-separator) (point-max) t)
+ ;; Search for mail-header-eeparator as whole line.
+ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")
+ (point-max) t)
(let ((header-end (or (match-beginning 0) (point-max))))
(goto-char (point-min))
(while (< (point) header-end)
@@ -965,7 +973,10 @@ the user from the mailer."
(defun mail-envelope-from ()
"Return the envelope mail address to use when sending mail.
-This function uses `mail-envelope-from'."
+This function uses the `mail-envelope-from' variable.
+
+The buffer should be narrowed to the headers of the mail message
+before this function is called."
(if (eq mail-envelope-from 'header)
(nth 1 (mail-extract-address-components
(mail-fetch-field "From")))
@@ -983,7 +994,7 @@ but lower priority than the local value of `buffer-file-coding-system'.
See also the function `select-message-coding-system'.")
;;;###autoload
-(defvar default-sendmail-coding-system 'iso-latin-1
+(defvar default-sendmail-coding-system 'utf-8
"Default coding system for encoding the outgoing mail.
This variable is used only when `sendmail-coding-system' is nil.
@@ -1181,7 +1192,12 @@ external program defined by `sendmail-program'."
;; local binding in the mail buffer will take effect.
(envelope-from
(and mail-specify-envelope-from
- (or (mail-envelope-from) user-mail-address))))
+ (or (save-restriction
+ ;; Only look at the headers when fetching the
+ ;; envelope address.
+ (message-narrow-to-headers)
+ (mail-envelope-from))
+ user-mail-address))))
(unwind-protect
(with-current-buffer tembuf
(erase-buffer)
@@ -1804,14 +1820,14 @@ If the current line has `mail-yank-prefix', insert it on the new line."
(declare-function mml-attach-file "mml"
(file &optional type description disposition))
-(declare-function mm-default-file-encoding "mm-encode" (file))
(defun mail-add-attachment (file)
"Add FILE as a MIME attachment to the end of the mail message being composed."
(interactive "fAttach file: ")
(mml-attach-file file
- (or (mm-default-file-encoding file)
- "application/octet-stream") nil)
+ (or (mm-default-file-type file)
+ "application/octet-stream")
+ nil)
(setq mail-encode-mml t))
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index e6b6197e858..133a2e1828e 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -50,9 +50,10 @@
;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
;; Authentication by the AUTH mechanism.
-;; See http://www.ietf.org/rfc/rfc2554.txt
+;; See https://www.ietf.org/rfc/rfc2554.txt
;;; Code:
+;;; Dependencies
(require 'sendmail)
(require 'auth-source)
@@ -61,12 +62,12 @@
(autoload 'message-make-message-id "message")
(autoload 'rfc2104-hash "rfc2104")
-;;;
+;;; Options
+
(defgroup smtpmail nil
"SMTP protocol for sending mail."
:group 'mail)
-
(defcustom smtpmail-default-smtp-server nil
"Specify default SMTP server.
This only has effect if you specify it before loading the smtpmail library."
@@ -134,8 +135,9 @@ Used for the value of `sendmail-coding-system' when
(defcustom smtpmail-queue-mail nil
"Non-nil means mail is queued; otherwise it is sent immediately.
-If queued, it is stored in the directory `smtpmail-queue-dir'
-and sent with `smtpmail-send-queued-mail'."
+If queued, it is stored in the directory `smtpmail-queue-dir' and
+sent with `smtpmail-send-queued-mail'. Also see
+`smtpmail-store-queue-variables'."
:type 'boolean)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
@@ -172,11 +174,21 @@ mean \"try again\"."
:type 'integer
:version "27.1")
-;; End of customizable variables.
+(defcustom smtpmail-store-queue-variables nil
+ "If non-nil, store SMTP variables when queueing mail.
+These will then be used when sending the queue."
+ :type 'boolean
+ :version "28.1")
+;;; Variables
(defvar smtpmail-address-buffer)
-(defvar smtpmail-recipient-address-list)
+(defvar smtpmail-recipient-address-list nil)
+(defvar smtpmail--stored-queue-variables
+ '(smtpmail-smtp-server
+ smtpmail-stream-type
+ smtpmail-smtp-service
+ smtpmail-smtp-user))
(defvar smtpmail-queue-counter 0)
@@ -186,12 +198,14 @@ mean \"try again\"."
(defvar smtpmail-auth-supported '(cram-md5 plain login)
"List of supported SMTP AUTH mechanisms.
The list is in preference order.
-Every element should have a matching `cl-defmethod' for
+Every element should have a matching `cl-defmethod'
for `smtpmail-try-auth-method'.")
(defvar smtpmail-mail-address nil
"Value to use for envelope-from address for mail from ambient buffer.")
+;;; Functions
+
;;;###autoload
(defun smtpmail-send-it ()
(let ((errbuf (if mail-interactive
@@ -205,11 +219,15 @@ for `smtpmail-try-auth-method'.")
;; Examine this variable now, so that
;; local binding in the mail buffer will take effect.
(smtpmail-mail-address
- (or (and mail-specify-envelope-from (mail-envelope-from))
- (let ((from (mail-fetch-field "from")))
- (and from
- (cadr (mail-extract-address-components from))))
- (smtpmail-user-mail-address)))
+ (save-restriction
+ ;; Only look at the headers when fetching the
+ ;; envelope address.
+ (message-narrow-to-headers)
+ (or (and mail-specify-envelope-from (mail-envelope-from))
+ (let ((from (mail-fetch-field "from")))
+ (and from
+ (cadr (mail-extract-address-components from))))
+ (smtpmail-user-mail-address))))
(smtpmail-code-conv-from
(if enable-multibyte-characters
(let ((sendmail-coding-system smtpmail-code-conv-from))
@@ -324,7 +342,7 @@ for `smtpmail-try-auth-method'.")
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
- (if (eval mail-mailer-swallows-blank-line)
+ (if (eval mail-mailer-swallows-blank-line t)
(newline))
;; Find and handle any Fcc fields.
(goto-char (point-min))
@@ -381,11 +399,17 @@ for `smtpmail-try-auth-method'.")
nil t)
(insert-buffer-substring tembuf)
(write-file file-data)
- (write-region
- (concat "(setq smtpmail-recipient-address-list '"
- (prin1-to-string smtpmail-recipient-address-list)
- ")\n")
- nil file-elisp nil 'silent)
+ (let ((coding-system-for-write 'utf-8))
+ (with-temp-buffer
+ (insert "(setq ")
+ (dolist (var (cons 'smtpmail-recipient-address-list
+ ;; Perhaps store the server etc.
+ (and smtpmail-store-queue-variables
+ smtpmail--stored-queue-variables)))
+ (insert (format " %s %S\n" var (symbol-value var))))
+ (insert ")\n")
+ (write-region (point-min) (point-max) file-elisp
+ nil 'silent)))
(write-region (concat file-data "\n") nil
(expand-file-name smtpmail-queue-index-file
smtpmail-queue-dir)
@@ -405,26 +429,30 @@ for `smtpmail-try-auth-method'.")
(let (file-data file-elisp
(qfile (expand-file-name smtpmail-queue-index-file
smtpmail-queue-dir))
+ (stored (cons 'smtpmail-recipient-address-list
+ smtpmail--stored-queue-variables))
+ smtpmail-recipient-address-list
+ (smtpmail-smtp-server smtpmail-smtp-server)
+ (smtpmail-stream-type smtpmail-stream-type)
+ (smtpmail-smtp-service smtpmail-smtp-service)
+ (smtpmail-smtp-user smtpmail-smtp-user)
result)
(insert-file-contents qfile)
(goto-char (point-min))
(while (not (eobp))
(setq file-data (buffer-substring (point) (line-end-position)))
(setq file-elisp (concat file-data ".el"))
- ;; FIXME: Avoid `load' which can execute arbitrary code and is hence
- ;; a source of security holes. Better read the file and extract the
- ;; data "by hand".
- ;;(load file-elisp)
- (with-temp-buffer
- (insert-file-contents file-elisp)
- (goto-char (point-min))
- (pcase (read (current-buffer))
- (`(setq smtpmail-recipient-address-list ',v)
- (skip-chars-forward " \n\t")
- (unless (eobp) (message "Ignoring trailing text in %S"
- file-elisp))
- (setq smtpmail-recipient-address-list v))
- (sexp (error "Unexpected code in %S: %S" file-elisp sexp))))
+ (let ((coding-system-for-read 'utf-8))
+ (with-temp-buffer
+ (insert-file-contents file-elisp)
+ (let ((form (read (current-buffer))))
+ (when (or (not (consp form))
+ (not (eq (car form) 'setq))
+ (not (consp (cdr form))))
+ (error "Unexpected code in %S: %S" file-elisp form))
+ (cl-loop for (var val) on (cdr form) by #'cddr
+ when (memq var stored)
+ do (set var val)))))
;; Insert the message literally: it is already encoded as per
;; the MIME headers, and code conversions might guess the
;; encoding wrongly.
@@ -432,15 +460,20 @@ for `smtpmail-try-auth-method'.")
(let ((coding-system-for-read 'no-conversion))
(insert-file-contents file-data))
(let ((smtpmail-mail-address
- (or (and mail-specify-envelope-from (mail-envelope-from))
+ (or (and mail-specify-envelope-from
+ (save-restriction
+ ;; Only look at the headers when fetching the
+ ;; envelope address.
+ (message-narrow-to-headers)
+ (mail-envelope-from)))
user-mail-address)))
- (if (not (null smtpmail-recipient-address-list))
- (when (setq result (smtpmail-via-smtp
- smtpmail-recipient-address-list
- (current-buffer)))
- (error "Sending failed: %s"
- (smtpmail--sanitize-error-message result)))
- (error "Sending failed; no recipients"))))
+ (if (not smtpmail-recipient-address-list)
+ (error "Sending failed; no recipients")
+ (when (setq result (smtpmail-via-smtp
+ smtpmail-recipient-address-list
+ (current-buffer)))
+ (error "Sending failed: %s"
+ (smtpmail--sanitize-error-message result))))))
(delete-file file-data)
(delete-file file-elisp)
(delete-region (point-at-bol) (point-at-bol 2)))
@@ -487,13 +520,6 @@ for `smtpmail-try-auth-method'.")
recipient
(concat recipient "@" smtpmail-sendto-domain)))
-(defun smtpmail-intersection (list1 list2)
- (let ((result nil))
- (dolist (el2 list2)
- (when (memq el2 list1)
- (push el2 result)))
- (nreverse result)))
-
(defun smtpmail-command-or-throw (process string &optional code)
(let (ret)
(smtpmail-send-command process string)
@@ -510,8 +536,10 @@ for `smtpmail-try-auth-method'.")
(if port
(format "%s" port)
"smtp"))
- (let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
- (mech (car (smtpmail-intersection mechs smtpmail-auth-supported)))
+ (let* ((mechs (seq-intersection
+ smtpmail-auth-supported
+ (cdr-safe (assoc 'auth supported-extensions))
+ #'eq))
(auth-source-creation-prompts
'((user . "SMTP user name for %h: ")
(secret . "SMTP password for %u@%h: ")))
@@ -524,6 +552,7 @@ for `smtpmail-try-auth-method'.")
:require (and ask-for-password
'(:user :secret))
:create ask-for-password)))
+ (mech (or (plist-get auth-info :smtp-auth) (car mechs)))
(user (plist-get auth-info :user))
(password (plist-get auth-info :secret))
(save-function (and ask-for-password
@@ -623,7 +652,7 @@ USER and PASSWORD should be non-nil."
(= code (car response)))))
(defun smtpmail-response-text (response)
- (mapconcat 'identity (cdr response) "\n"))
+ (mapconcat #'identity (cdr response) "\n"))
(defun smtpmail-query-smtp-server ()
"Query for an SMTP server and try to contact it.
@@ -679,13 +708,17 @@ Returns an error if the server cannot be contacted."
;; `smtpmail-mail-address' should be set to the appropriate
;; buffer-local value by the caller, but in case not:
(envelope-from
- (or smtpmail-mail-address
- (and mail-specify-envelope-from
- (mail-envelope-from))
- (let ((from (mail-fetch-field "from")))
- (and from
- (cadr (mail-extract-address-components from))))
- (smtpmail-user-mail-address)))
+ (save-restriction
+ ;; Only look at the headers when fetching the
+ ;; envelope address.
+ (message-narrow-to-headers)
+ (or smtpmail-mail-address
+ (and mail-specify-envelope-from
+ (mail-envelope-from))
+ (let ((from (mail-fetch-field "from")))
+ (and from
+ (cadr (mail-extract-address-components from))))
+ (smtpmail-user-mail-address))))
process-buffer
result
auth-mechanisms
@@ -737,7 +770,7 @@ Returns an error if the server cannot be contacted."
"Unable to contact server")))
;; set the send-filter
- (set-process-filter process 'smtpmail-process-filter)
+ (set-process-filter process #'smtpmail-process-filter)
(let* ((greeting (plist-get (cdr result) :greeting))
(code (smtpmail-response-code greeting)))
@@ -1083,6 +1116,12 @@ many continuation lines."
(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
(replace-match ""))))))
+;; Obsolete.
+
+(defun smtpmail-intersection (list1 list2)
+ (declare (obsolete seq-intersection "28.1"))
+ (seq-intersection list2 list1 #'eq))
+
(provide 'smtpmail)
;;; smtpmail.el ends here
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index c2064e352d3..d545b0c3f15 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -1,4 +1,4 @@
-;;; supercite.el --- minor mode for citing mail and news replies
+;;; supercite.el --- minor mode for citing mail and news replies -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -509,9 +509,9 @@ string."
;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;; end user configuration variables
-(defvar sc-mail-info nil
+(defvar-local sc-mail-info nil
"Alist of mail header information gleaned from reply buffer.")
-(defvar sc-attributions nil
+(defvar-local sc-attributions nil
"Alist of attributions for use when citing.")
(defvar sc-tmp-nested-regexp nil
@@ -521,80 +521,77 @@ string."
(defvar sc-tmp-dumb-regexp nil
"Temp regexp describing non-nested citation cited with a nesting citer.")
-(make-variable-buffer-local 'sc-mail-info)
-(make-variable-buffer-local 'sc-attributions)
-
;; ======================================================================
;; supercite keymaps
(defvar sc-T-keymap
(let ((map (make-sparse-keymap)))
- (define-key map "a" 'sc-S-preferred-attribution-list)
- (define-key map "b" 'sc-T-mail-nuke-blank-lines)
- (define-key map "c" 'sc-T-confirm-always)
- (define-key map "d" 'sc-T-downcase)
- (define-key map "e" 'sc-T-electric-references)
- (define-key map "f" 'sc-T-auto-fill-region)
- (define-key map "h" 'sc-T-describe)
- (define-key map "l" 'sc-S-cite-region-limit)
- (define-key map "n" 'sc-S-mail-nuke-mail-headers)
- (define-key map "N" 'sc-S-mail-header-nuke-list)
- (define-key map "o" 'sc-T-electric-circular)
- (define-key map "p" 'sc-S-preferred-header-style)
- (define-key map "s" 'sc-T-nested-citation)
- (define-key map "u" 'sc-T-use-only-preferences)
- (define-key map "w" 'sc-T-fixup-whitespace)
- (define-key map "?" 'sc-T-describe)
+ (define-key map "a" #'sc-S-preferred-attribution-list)
+ (define-key map "b" #'sc-T-mail-nuke-blank-lines)
+ (define-key map "c" #'sc-T-confirm-always)
+ (define-key map "d" #'sc-T-downcase)
+ (define-key map "e" #'sc-T-electric-references)
+ (define-key map "f" #'sc-T-auto-fill-region)
+ (define-key map "h" #'sc-T-describe)
+ (define-key map "l" #'sc-S-cite-region-limit)
+ (define-key map "n" #'sc-S-mail-nuke-mail-headers)
+ (define-key map "N" #'sc-S-mail-header-nuke-list)
+ (define-key map "o" #'sc-T-electric-circular)
+ (define-key map "p" #'sc-S-preferred-header-style)
+ (define-key map "s" #'sc-T-nested-citation)
+ (define-key map "u" #'sc-T-use-only-preferences)
+ (define-key map "w" #'sc-T-fixup-whitespace)
+ (define-key map "?" #'sc-T-describe)
map)
"Keymap for sub-keymap of setting and toggling functions.")
(defvar sc-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "c" 'sc-cite-region)
- (define-key map "f" 'sc-mail-field-query)
- (define-key map "g" 'sc-mail-process-headers)
- (define-key map "h" 'sc-describe)
- (define-key map "i" 'sc-insert-citation)
- (define-key map "o" 'sc-open-line)
- (define-key map "r" 'sc-recite-region)
- (define-key map "\C-p" 'sc-raw-mode-toggle)
- (define-key map "u" 'sc-uncite-region)
- (define-key map "w" 'sc-insert-reference)
- (define-key map "\C-t" sc-T-keymap)
- (define-key map "?" 'sc-describe)
+ (define-key map "c" #'sc-cite-region)
+ (define-key map "f" #'sc-mail-field-query)
+ (define-key map "g" #'sc-mail-process-headers)
+ (define-key map "h" #'sc-describe)
+ (define-key map "i" #'sc-insert-citation)
+ (define-key map "o" #'sc-open-line)
+ (define-key map "r" #'sc-recite-region)
+ (define-key map "\C-p" #'sc-raw-mode-toggle)
+ (define-key map "u" #'sc-uncite-region)
+ (define-key map "w" #'sc-insert-reference)
+ (define-key map "\C-t" sc-T-keymap)
+ (define-key map "?" #'sc-describe)
map)
"Keymap for Supercite quasi-mode.")
(defvar sc-electric-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "p" 'sc-eref-prev)
- (define-key map "n" 'sc-eref-next)
- (define-key map "s" 'sc-eref-setn)
- (define-key map "j" 'sc-eref-jump)
- (define-key map "x" 'sc-eref-abort)
- (define-key map "q" 'sc-eref-abort)
- (define-key map "\r" 'sc-eref-exit)
- (define-key map "\n" 'sc-eref-exit)
- (define-key map "g" 'sc-eref-goto)
- (define-key map "?" 'describe-mode)
- (define-key map "\C-h" 'describe-mode)
- (define-key map [f1] 'describe-mode)
- (define-key map [help] 'describe-mode)
+ (define-key map "p" #'sc-eref-prev)
+ (define-key map "n" #'sc-eref-next)
+ (define-key map "s" #'sc-eref-setn)
+ (define-key map "j" #'sc-eref-jump)
+ (define-key map "x" #'sc-eref-abort)
+ (define-key map "q" #'sc-eref-abort)
+ (define-key map "\r" #'sc-eref-exit)
+ (define-key map "\n" #'sc-eref-exit)
+ (define-key map "g" #'sc-eref-goto)
+ (define-key map "?" #'describe-mode)
+ (define-key map "\C-h" #'describe-mode)
+ (define-key map [f1] #'describe-mode)
+ (define-key map [help] #'describe-mode)
map)
"Keymap for `sc-electric-mode' electric references mode.")
(defvar sc-minibuffer-local-completion-map
(let ((map (copy-keymap minibuffer-local-completion-map)))
- (define-key map "\C-t" 'sc-toggle-fn)
- (define-key map " " 'self-insert-command)
+ (define-key map "\C-t" #'sc-toggle-fn)
+ (define-key map " " #'self-insert-command)
map)
"Keymap for minibuffer confirmation of attribution strings.")
(defvar sc-minibuffer-local-map
(let ((map (copy-keymap minibuffer-local-map)))
- (define-key map "\C-t" 'sc-toggle-fn)
+ (define-key map "\C-t" #'sc-toggle-fn)
map)
"Keymap for minibuffer confirmation of attribution strings.")
@@ -618,10 +615,7 @@ the list should be unique."
(lambda (elt) (char-to-string (cdr elt))) alist "/")
") "))
(p prompt)
- (event
- (if (fboundp 'allocate-event)
- (allocate-event)
- nil)))
+ event)
(while (stringp p)
(if (let ((cursor-in-echo-area t)
(inhibit-quit t))
@@ -630,8 +624,6 @@ the list should be unique."
(prog1 quit-flag (setq quit-flag nil)))
(progn
(message "%s%s" p (single-key-description event))
- (if (fboundp 'deallocate-event)
- (deallocate-event event))
(setq quit-flag nil)
(signal 'quit '())))
(let ((char event)
@@ -650,8 +642,6 @@ the list should be unique."
(discard-input)
(if (eq p prompt)
(setq p (concat "Try again. " prompt)))))))
- (if (fboundp 'deallocate-event)
- (deallocate-event event))
p))
(defun sc-scan-info-alist (alist)
@@ -1028,17 +1018,16 @@ supplied, is used instead of the line point is on in the current buffer."
(setq position (1+ position))
(let ((keep-p t))
(mapc
- (function
- (lambda (filter)
- (let ((regexp (car filter))
- (pos (cdr filter)))
- (if (and (string-match regexp name)
- (or (and (numberp pos)
- (= pos position))
- (and (eq pos 'last)
- (= position (1- elements)))
- (eq pos 'any)))
- (setq keep-p nil)))))
+ (lambda (filter)
+ (let ((regexp (car filter))
+ (pos (cdr filter)))
+ (if (and (string-match regexp name)
+ (or (and (numberp pos)
+ (= pos position))
+ (and (eq pos 'last)
+ (= position (1- elements)))
+ (eq pos 'any)))
+ (setq keep-p nil))))
sc-name-filter-alist)
(if keep-p
(setq keepers (cons position keepers)))))
@@ -1120,6 +1109,8 @@ Only used during confirmation."
(setq sc-attrib-or-cite (not sc-attrib-or-cite))
(throw 'sc-reconfirm t))
+(defvar completer-disable) ;; From some `completer.el' package.
+
(defun sc-select-attribution ()
"Select an attribution from `sc-attributions'.
@@ -1137,6 +1128,8 @@ selection but before querying is performed. During
auto-selected citation string and the variable `attribution' is bound
to the auto-selected attribution string."
(run-hooks 'sc-attribs-preselect-hook)
+ (with-suppressed-warnings ((lexical citation attribution))
+ (defvar citation) (defvar attribution))
(let ((query-p sc-confirm-always-p)
attribution citation
(attriblist sc-preferred-attribution-list))
@@ -1161,7 +1154,7 @@ to the auto-selected attribution string."
(setq attribution attrib
attriblist nil))
((listp attrib)
- (setq attribution (eval attrib))
+ (setq attribution (eval attrib t))
(if (stringp attribution)
(setq attriblist nil)
(setq attribution nil
@@ -1604,7 +1597,7 @@ error occurs."
(let ((ref (nth sc-eref-style sc-rewrite-header-list)))
(condition-case err
(progn
- (eval ref)
+ (eval ref t)
(let ((lines (count-lines (point-min) (point-max))))
(or nomsg (message "Ref header %d [%d line%s]: %s"
sc-eref-style lines
@@ -1778,8 +1771,7 @@ querying you by typing `C-h'. Note that the format is changed
slightly from that used by `set-variable' -- the current value is
printed just after the variable's name instead of at the bottom of the
help window."
- (let* ((minibuffer-help-form '(funcall myhelp))
- (myhelp
+ (let* ((myhelp
(lambda ()
(with-output-to-temp-buffer "*Help*"
(prin1 var)
@@ -1795,7 +1787,8 @@ help window."
1))
(with-current-buffer standard-output
(help-mode))
- nil))))
+ nil)))
+ (minibuffer-help-form `(funcall #',myhelp)))
(set var (eval-minibuffer (format "Set %s to value: " var)))))
(defmacro sc-toggle-symbol (rootname)
diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el
index a573c8a2673..9ebffef2e59 100644
--- a/lisp/mail/uce.el
+++ b/lisp/mail/uce.el
@@ -1,4 +1,4 @@
-;;; uce.el --- facilitate reply to unsolicited commercial email
+;;; uce.el --- facilitate reply to unsolicited commercial email -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1998, 2000-2021 Free Software Foundation, Inc.
@@ -127,14 +127,12 @@
"A symbol indicating which mail reader you are using.
Choose from: `gnus', `rmail'."
:type '(choice (const gnus) (const rmail))
- :version "20.3"
- :group 'uce)
+ :version "20.3")
(defcustom uce-setup-hook nil
"Hook to run after UCE rant message is composed.
This hook is run after `mail-setup-hook', which is run as well."
- :type 'hook
- :group 'uce)
+ :type 'hook)
(defcustom uce-message-text
"Recently, I have received an Unsolicited Commercial E-mail from you.
@@ -180,36 +178,31 @@ on beginning of some line from the spamming list. So, when you set it
up, it might be a good idea to actually use this feature.
Value nil means insert no text by default, lets you type it in."
- :type '(choice (const nil) string)
- :group 'uce)
+ :type '(choice (const nil) string))
(defcustom uce-uce-separator
"----- original unsolicited commercial email follows -----"
"Line that will begin quoting of the UCE.
Value nil means use no separator."
- :type '(choice (const nil) string)
- :group 'uce)
+ :type '(choice (const nil) string))
(defcustom uce-signature mail-signature
"Text to put as your signature after the note to UCE sender.
Value nil means none, t means insert `~/.signature' file (if it happens
to exist), if this variable is a string this string will be inserted
as your signature."
- :type '(choice (const nil) (const t) string)
- :group 'uce)
+ :type '(choice (const nil) (const t) string))
(defcustom uce-default-headers
"Errors-To: nobody@localhost\nPrecedence: bulk\n"
"Additional headers to use when responding to a UCE with \\[uce-reply-to-uce].
These are mostly meant for headers that prevent delivery errors reporting."
- :type '(choice (const nil) string)
- :group 'uce)
+ :type '(choice (const nil) string))
(defcustom uce-subject-line
"Spam alert: unsolicited commercial e-mail"
"Subject of the message that will be sent in response to a UCE."
- :type 'string
- :group 'uce)
+ :type 'string)
;; End of user options.
@@ -221,7 +214,7 @@ These are mostly meant for headers that prevent delivery errors reporting."
(declare-function rmail-toggle-header "rmail" (&optional arg))
;;;###autoload
-(defun uce-reply-to-uce (&optional ignored)
+(defun uce-reply-to-uce (&optional _ignored)
"Compose a reply to unsolicited commercial email (UCE).
Sets up a reply buffer addressed to: the sender, his postmaster,
his abuse@ address, and the postmaster of the mail relay used.
@@ -367,7 +360,7 @@ You might need to set `uce-mail-reader' before using this."
;; functions in mail-mode, etc.
(run-hooks 'mail-setup-hook 'uce-setup-hook))))
-(defun uce-insert-ranting (&optional ignored)
+(defun uce-insert-ranting (&optional _ignored)
"Insert text of the usual reply to UCE into current buffer."
(interactive "P")
(insert uce-message-text))
diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el
index 34de416c959..5b1abd54c6f 100644
--- a/lisp/mail/unrmail.el
+++ b/lisp/mail/unrmail.el
@@ -1,4 +1,4 @@
-;;; unrmail.el --- convert Rmail Babyl files to mbox files
+;;; unrmail.el --- convert Rmail Babyl files to mbox files -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
@@ -235,7 +235,7 @@ The variable `unrmail-mbox-format' controls which mbox format to use."
;; Insert the `From ' line.
(insert mail-from)
;; Record the keywords and attributes in our special way.
- (insert "X-RMAIL-ATTRIBUTES: " (apply 'string attrs) "\n")
+ (insert "X-RMAIL-ATTRIBUTES: " (apply #'string attrs) "\n")
(when keywords
(insert "X-RMAIL-KEYWORDS: " keywords "\n"))
;; Convert From to >From, etc.
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index 94f8dc18a6c..026356efe97 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -1,4 +1,4 @@
-;;; uudecode.el -- elisp native uudecode -*- lexical-binding:t -*-
+;;; uudecode.el --- elisp native uudecode -*- lexical-binding:t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -24,11 +24,6 @@
;;; Code:
-(defalias 'uudecode-char-int
- (if (fboundp 'char-int)
- 'char-int
- 'identity))
-
(defgroup uudecode nil
"Decoding of uuencoded data."
:group 'mail
@@ -61,10 +56,8 @@ input and write the converted data to its standard output."
(setq str (concat str "[^a-z]")))
(concat str ".?$")))
-(defvar uudecode-temporary-file-directory
- (cond ((fboundp 'temp-directory) (temp-directory))
- ((boundp 'temporary-file-directory) temporary-file-directory)
- ("/tmp")))
+(make-obsolete-variable 'uudecode-temporary-file-directory
+ 'temporary-file-directory "28.1")
;;;###autoload
(defun uudecode-decode-region-external (start end &optional file-name)
@@ -86,13 +79,7 @@ used is specified by `uudecode-decoder-program'."
(match-string 1)))))
(setq tempfile (if file-name
(expand-file-name file-name)
- (if (fboundp 'make-temp-file)
- (let ((temporary-file-directory
- uudecode-temporary-file-directory))
- (make-temp-file "uu"))
- (expand-file-name
- (make-temp-name "uu")
- uudecode-temporary-file-directory))))
+ (make-temp-file "uu")))
(let ((cdir default-directory)
(default-process-coding-system nil))
(unwind-protect
@@ -148,7 +135,7 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
((> (skip-chars-forward uudecode-alphabet end) 0)
(setq lim (point))
(setq remain
- (logand (- (uudecode-char-int (char-after inputpos)) 32)
+ (logand (- (char-after inputpos) 32)
63))
(setq inputpos (1+ inputpos))
(if (= remain 0) (setq done t))
@@ -156,7 +143,7 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
(setq bits (+ bits
(logand
(-
- (uudecode-char-int (char-after inputpos)) 32)
+ (char-after inputpos) 32)
63)))
(if (/= counter 0) (setq remain (1- remain)))
(setq counter (1+ counter)
@@ -207,6 +194,8 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
(uudecode-decode-region-external start end file-name)
(uudecode-decode-region-internal start end file-name)))
+(define-obsolete-function-alias 'uudecode-char-int #'identity "28.1")
+
(provide 'uudecode)
;;; uudecode.el ends here
diff --git a/lisp/man.el b/lisp/man.el
index e0e85a845c6..9b941a2b3d2 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -90,7 +90,6 @@
(require 'ansi-color)
(require 'cl-lib)
-(require 'button)
(defgroup man nil
"Browse UNIX manual pages."
@@ -98,8 +97,6 @@
:group 'external
:group 'help)
-(defvar Man-notify)
-
(defcustom Man-filter-list nil
"Manpage cleaning filter command phrases.
This variable contains a list of the following form:
@@ -150,8 +147,7 @@ the manpage buffer."
(ansi-color-make-color-map))
"The value used here for `ansi-color-map'.")
-;; Use the value of the obsolete user option Man-notify, if set.
-(defcustom Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly)
+(defcustom Man-notify-method 'friendly
"Selects the behavior when manpage is ready.
This variable may have one of the following values, where (sf) means
that the frames are switched, so the manpage is displayed in the frame
@@ -253,7 +249,7 @@ the associated section number."
"Regexp that matches the text that precedes the command's name.
Used in `bookmark-set' to get the default bookmark name."
:version "24.1"
- :type 'string :group 'bookmark)
+ :type 'regexp :group 'bookmark)
(defcustom manual-program "man"
"Program used by `man' to produce man pages."
@@ -400,22 +396,15 @@ Otherwise, the value is whatever the function
;; other variables and keymap initializations
-(defvar Man-original-frame)
-(make-variable-buffer-local 'Man-original-frame)
-(defvar Man-arguments)
-(make-variable-buffer-local 'Man-arguments)
+(defvar-local Man-original-frame nil)
+(defvar-local Man-arguments nil)
(put 'Man-arguments 'permanent-local t)
-(defvar Man--sections nil)
-(make-variable-buffer-local 'Man--sections)
-(defvar Man--refpages nil)
-(make-variable-buffer-local 'Man--refpages)
-(defvar Man-page-list nil)
-(make-variable-buffer-local 'Man-page-list)
-(defvar Man-current-page 0)
-(make-variable-buffer-local 'Man-current-page)
-(defvar Man-page-mode-string "1 of 1")
-(make-variable-buffer-local 'Man-page-mode-string)
+(defvar-local Man--sections nil)
+(defvar-local Man--refpages nil)
+(defvar-local Man-page-list nil)
+(defvar-local Man-current-page 0)
+(defvar-local Man-page-mode-string "1 of 1")
(defconst Man-sysv-sed-script "\
/\b/ { s/_\b//g
@@ -836,7 +825,8 @@ POS defaults to `point'."
;; ======================================================================
;; Top level command and background process sentinel
-;; For compatibility with older versions.
+;; This alias was originally for compatibility with older versions.
+;; Some users got used to having it, so we will not remove it.
;;;###autoload
(defalias 'manual-entry 'man)
@@ -926,15 +916,18 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
;; run differently in Man-getpage-in-background, an error
;; here may not necessarily mean that we'll also get an
;; error later.
- (ignore-errors
- (call-process manual-program nil '(t nil) nil
- "-k" (concat (when (or Man-man-k-use-anchor
- (string-equal prefix ""))
- "^")
- prefix))))
- (setq table (Man-parse-man-k)))
+ (when (eq 0
+ (ignore-errors
+ (call-process
+ manual-program nil '(t nil) nil
+ "-k" (concat (when (or Man-man-k-use-anchor
+ (string-equal prefix ""))
+ "^")
+ prefix))))
+ (setq table (Man-parse-man-k)))))
;; Cache the table for later reuse.
- (setq Man-completion-cache (cons prefix table)))
+ (when table
+ (setq Man-completion-cache (cons prefix table))))
;; The table may contain false positives since the match is made
;; by "man -k" not just on the manpage's name.
(if section
@@ -1013,10 +1006,9 @@ to auto-complete your input based on the installed manual pages."
(completion-ignore-case t)
Man-completion-cache ;Don't cache across calls.
(input (completing-read
- (format "Manual entry%s"
- (if (string= default-entry "")
- ": "
- (format " (default %s): " default-entry)))
+ (format-prompt "Manual entry"
+ (and (not (equal default-entry ""))
+ default-entry))
'Man-completion-table
nil nil nil 'Man-topic-history default-entry)))
(if (string= input "")
@@ -1032,7 +1024,7 @@ to auto-complete your input based on the installed manual pages."
;;;###autoload
(defun man-follow (man-args)
"Get a Un*x manual page of the item under point and put it in a buffer."
- (interactive (list (Man-default-man-entry)))
+ (interactive (list (Man-default-man-entry)) man-common)
(if (or (not man-args)
(string= man-args ""))
(error "No item under point")
@@ -1106,7 +1098,6 @@ Return the buffer in which the manpage will appear."
(buffer (get-buffer bufname)))
(if buffer
(Man-notify-when-ready buffer)
- (require 'env)
(message "Invoking %s %s in the background" manual-program man-args)
(setq buffer (generate-new-buffer bufname))
(with-current-buffer buffer
@@ -1152,7 +1143,7 @@ Return the buffer in which the manpage will appear."
(defun Man-update-manpage ()
"Reformat current manpage by calling the man command again synchronously."
- (interactive)
+ (interactive nil man-common)
(when (eq Man-arguments nil)
;;this shouldn't happen unless it is not in a Man buffer."
(error "Man-arguments not initialized"))
@@ -1248,7 +1239,7 @@ See the variable `Man-notify-method' for the different notification behaviors."
(defun Man-fontify-manpage ()
"Convert overstriking and underlining to the correct fonts.
Same for the ANSI bold and normal escape sequences."
- (interactive)
+ (interactive nil man-common)
(goto-char (point-min))
;; Fontify ANSI escapes.
(let ((ansi-color-apply-face-function #'ansi-color-apply-text-property-face)
@@ -1364,7 +1355,7 @@ default type, `Man-xref-man-page' is used for the buttons."
Normally skip any jobs that should have been done by the sed script,
but when called interactively, do those jobs even if the sed
script would have done them."
- (interactive "p")
+ (interactive "p" man-common)
(if (or interactive (not Man-sed-script))
(progn
(goto-char (point-min))
@@ -1396,7 +1387,7 @@ synchronously, PROCESS is the name of the buffer where the manpage
command is run. Second argument STRING is the entire string of output."
(save-excursion
(let ((Man-buffer (process-buffer process)))
- (if (null (buffer-name Man-buffer)) ;; deleted buffer
+ (if (not (buffer-live-p Man-buffer)) ;; deleted buffer
(set-process-buffer process nil)
(with-current-buffer Man-buffer
@@ -1430,7 +1421,7 @@ manpage command."
(delete-buff nil)
message)
- (if (null (buffer-name Man-buffer)) ;; deleted buffer
+ (if (not (buffer-live-p Man-buffer)) ;; deleted buffer
(or (stringp process)
(set-process-buffer process nil))
@@ -1508,8 +1499,13 @@ manpage command."
(when delete-buff
(if (window-live-p (get-buffer-window Man-buffer t))
- (quit-restore-window
- (get-buffer-window Man-buffer t) 'kill)
+ (progn
+ (quit-restore-window
+ (get-buffer-window Man-buffer t) 'kill)
+ ;; Ensure that we end up in the correct window.
+ (let ((old-window (old-selected-window)))
+ (when (window-live-p old-window)
+ (select-window old-window))))
(kill-buffer Man-buffer)))
(when message
@@ -1533,7 +1529,14 @@ manpage command."
(defvar bookmark-make-record-function)
-(define-derived-mode Man-mode special-mode "Man"
+(define-derived-mode man-common special-mode "Man Shared"
+ "Parent mode for `Man-mode' like modes.
+This mode is here to be inherited by modes that need to use
+commands from `Man-mode'. Used by `woman'.
+(In itself, this mode currently does nothing.)"
+ :interactive nil)
+
+(define-derived-mode Man-mode man-common "Man"
"A mode for browsing Un*x manual pages.
The following man commands are available in the buffer. Try
@@ -1579,10 +1582,10 @@ The following key bindings are currently in effect in the buffer:
(auto-fill-mode -1)
(setq imenu-generic-expression (list (list nil Man-heading-regexp 0)))
(imenu-add-to-menubar man-imenu-title)
- (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)
+ (setq-local outline-regexp Man-heading-regexp)
+ (setq-local outline-level (lambda () 1))
+ (setq-local bookmark-make-record-function
+ #'Man-bookmark-make-record)
(add-hook 'window-state-change-functions #'Man--window-state-change nil t))
(defun Man-build-section-list ()
@@ -1729,7 +1732,7 @@ The following key bindings are currently in effect in the buffer:
(defun Man-next-section (n)
"Move point to Nth next section (default 1)."
- (interactive "p")
+ (interactive "p" man-common)
(let ((case-fold-search nil)
(start (point)))
(if (looking-at Man-heading-regexp)
@@ -1745,7 +1748,7 @@ The following key bindings are currently in effect in the buffer:
(defun Man-previous-section (n)
"Move point to Nth previous section (default 1)."
- (interactive "p")
+ (interactive "p" man-common)
(let ((case-fold-search nil))
(if (looking-at Man-heading-regexp)
(forward-line -1))
@@ -1762,8 +1765,7 @@ Returns t if section is found, nil otherwise."
(if (re-search-forward (concat "^" section) (point-max) t)
(progn (beginning-of-line) t)
(goto-char curpos)
- nil)
- ))
+ nil)))
(defvar Man--last-section nil)
@@ -1777,7 +1779,8 @@ Returns t if section is found, nil otherwise."
(prompt (concat "Go to section (default " default "): "))
(chosen (completing-read prompt Man--sections
nil nil nil nil default)))
- (list chosen)))
+ (list chosen))
+ man-common)
(setq Man--last-section section)
(unless (Man-find-section section)
(error "Section %s not found" section)))
@@ -1786,7 +1789,7 @@ Returns t if section is found, nil otherwise."
(defun Man-goto-see-also-section ()
"Move point to the \"SEE ALSO\" section.
Actually the section moved to is described by `Man-see-also-regexp'."
- (interactive)
+ (interactive nil man-common)
(if (not (Man-find-section Man-see-also-regexp))
(error "%s" (concat "No " Man-see-also-regexp
" section found in the current manpage"))))
@@ -1840,7 +1843,8 @@ Specify which REFERENCE to use; default is based on word at point."
(prompt (concat "Refer to (default " default "): "))
(chosen (completing-read prompt Man--refpages
nil nil nil nil defaults)))
- chosen))))
+ chosen)))
+ man-common)
(if (not Man--refpages)
(error "Can't find any references in the current manpage")
(setq Man--last-refpage reference)
@@ -1849,7 +1853,7 @@ Specify which REFERENCE to use; default is based on word at point."
(defun Man-kill ()
"Kill the buffer containing the manpage."
- (interactive)
+ (interactive nil man-common)
(quit-window t))
(defun Man-goto-page (page &optional noerror)
@@ -1860,7 +1864,8 @@ Specify which REFERENCE to use; default is based on word at point."
(if (= (length Man-page-list) 1)
(error "You're looking at the only manpage in the buffer")
(list (read-minibuffer (format "Go to manpage [1-%d]: "
- (length Man-page-list)))))))
+ (length Man-page-list))))))
+ man-common)
(if (and (not Man-page-list) (not noerror))
(error "Not a man page buffer"))
(when Man-page-list
@@ -1882,7 +1887,7 @@ Specify which REFERENCE to use; default is based on word at point."
(defun Man-next-manpage ()
"Find the next manpage entry in the buffer."
- (interactive)
+ (interactive nil man-common)
(if (= (length Man-page-list) 1)
(error "This is the only manpage in the buffer"))
(if (< Man-current-page (length Man-page-list))
@@ -1893,7 +1898,7 @@ Specify which REFERENCE to use; default is based on word at point."
(defun Man-previous-manpage ()
"Find the previous manpage entry in the buffer."
- (interactive)
+ (interactive nil man-common)
(if (= (length Man-page-list) 1)
(error "This is the only manpage in the buffer"))
(if (> Man-current-page 1)
diff --git a/lisp/master.el b/lisp/master.el
index 18b5c2166f5..3dcee50c5e0 100644
--- a/lisp/master.el
+++ b/lisp/master.el
@@ -1,9 +1,9 @@
-;;; master.el --- make a buffer the master over another buffer
+;;; master.el --- make a buffer the master over another buffer -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
-;; Version: 1.0.2
+;; Old-Version: 1.0.2
;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -23,7 +23,7 @@
;;; Commentary:
-;; master-mode is a minor mode which enables you to scroll another
+;; `master-mode' is a minor mode which enables you to scroll another
;; buffer (the slave) without leaving your current buffer (the master).
;; It can be used by sql.el, for example: The SQL buffer is the master
@@ -36,28 +36,19 @@
;; SQL buffer.
;;
;; (add-hook 'sql-mode-hook
-;; (function (lambda ()
-;; (master-mode t)
-;; (master-set-slave sql-buffer))))
+;; (lambda ()
+;; (master-mode t)
+;; (master-set-slave sql-buffer)))
;; (add-hook 'sql-set-sqli-hook
-;; (function (lambda ()
-;; (master-set-slave sql-buffer))))
+;; (lambda ()
+;; (master-set-slave sql-buffer)))
;;; Thanks to all the people who helped me out:
;;
;; Rob Riepel <networking.stanford.edu>
-;;; History:
-;;
-
;;; Code:
-;; Unused.
-;;; (defgroup master nil
-;;; "Support for master/slave relationships between buffers."
-;;; :version "22.1"
-;;; :group 'convenience)
-
;; Variables that don't need initialization.
(defvar master-of nil
@@ -93,11 +84,10 @@ yourself the value of `master-of' by calling `master-show-slave'."
;; Initialize Master mode by setting a slave buffer.
(defun master-set-slave (buffer)
- "Makes BUFFER the slave of the current buffer.
+ "Make BUFFER the slave of the current buffer.
Use \\[master-mode] to toggle control of the slave buffer."
(interactive "bSlave: ")
- (make-local-variable 'master-of)
- (setq master-of buffer)
+ (setq-local master-of buffer)
(run-hooks 'master-set-slave-hook))
(defun master-show-slave ()
diff --git a/lisp/mb-depth.el b/lisp/mb-depth.el
index 06da0739d6b..88003afb409 100644
--- a/lisp/mb-depth.el
+++ b/lisp/mb-depth.el
@@ -30,10 +30,22 @@
;;; Code:
-(defvar minibuffer-depth-indicator-function nil
- "If non-nil, function to set up the minibuffer depth indicator.
-It is called with one argument, the minibuffer depth,
-and must return a string.")
+(defcustom minibuffer-depth-indicator-function nil
+ "If non-nil, a function to produce the minibuffer depth indicator.
+The function will be called with one argument, the minibuffer depth,
+and must return a string to display as indication of the minibuffer
+depth.
+If nil, display the depth as a number inside brackets, [NN], with
+the `minibuffer-depth-indicator' face."
+ :version "28.1"
+ :type '(choice (const :tag "Default indicator display, [NN]" nil)
+ (function))
+ :group 'minibuffer)
+
+(defface minibuffer-depth-indicator '((t :inherit highlight))
+ "Face to use for minibuffer depth indicator."
+ :group 'minibuffer
+ :version "28.1")
;; An overlay covering the prompt. This is a buffer-local variable in
;; each affected minibuffer.
@@ -52,7 +64,10 @@ The prompt should already have been inserted."
(overlay-put minibuffer-depth-overlay 'before-string
(if minibuffer-depth-indicator-function
(funcall minibuffer-depth-indicator-function depth)
- (propertize (format "[%d]" depth) 'face 'highlight)))
+ (concat (propertize (format "[%d]" depth)
+ 'face
+ 'minibuffer-depth-indicator)
+ " ")))
(overlay-put minibuffer-depth-overlay 'evaporate t))))
;;;###autoload
diff --git a/lisp/md4.el b/lisp/md4.el
index 9aaec57f27f..771d9f9f0d4 100644
--- a/lisp/md4.el
+++ b/lisp/md4.el
@@ -4,7 +4,7 @@
;; Author: Taro Kawagishi <tarok@transpulse.org>
;; Keywords: MD4
-;; Version: 1.00
+;; Old-Version: 1.00
;; Created: February 2001
;; This file is part of GNU Emacs.
@@ -22,6 +22,16 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+;;; Commentary:
+
+;; The MD4 Message-Digest Algorithm.
+;;
+;; The security of the MD4 hashing algorithm is very poor to
+;; non-existent. It was declared obsolete by RFC 6150 in 2011:
+;; https://tools.ietf.org/html/rfc6150
+;;
+;; You probably want to use `secure-hash' instead.
+
;;; Code:
;;;
@@ -33,7 +43,12 @@
(defun md4 (in n)
"Return the MD4 hash for a string IN of length N bytes.
The returned hash is 16 bytes long. N is required to handle
-strings containing the character 0."
+strings containing the character 0.
+
+The security of the MD4 hashing algorithm is very poor to
+non-existent. It was declared obsolete by RFC 6150 in 2011.
+
+You probably want to use `secure-hash' instead."
(let (m
(b (cons 0 (* n 8)))
(i 0)
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 9cb47a22629..8def1575b24 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -1,4 +1,4 @@
-;;; menu-bar.el --- define a default menu bar
+;;; menu-bar.el --- define a default menu bar -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2000-2021 Free Software Foundation, Inc.
@@ -79,9 +79,6 @@
:help "Print current buffer with page headings"))
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")
(defvar menu-bar-file-menu
(let ((menu (make-sparse-keymap "File")))
@@ -229,7 +226,8 @@
(filename (car (find-file-read-args "Find file: " mustmatch))))
(if mustmatch
(find-file-existing filename)
- (find-file filename))))
+ (with-suppressed-warnings ((interactive-only find-file))
+ (find-file filename)))))
;; The "Edit->Search" submenu
(defvar menu-bar-last-search-type nil
@@ -458,9 +456,6 @@
(defvar menu-bar-edit-menu
(let ((menu (make-sparse-keymap "Edit")))
- (bindings--define-key menu [props]
- '(menu-item "Text Properties" facemenu-menu))
-
;; ns-win.el said: Add spell for platform consistency.
(if (featurep 'ns)
(bindings--define-key menu [spell]
@@ -494,7 +489,7 @@
'(menu-item "Select All" mark-whole-buffer
:help "Mark the whole buffer for a subsequent cut/copy"))
(bindings--define-key menu [clear]
- '(menu-item "Clear" delete-region
+ '(menu-item "Clear" delete-active-region
:enable (and mark-active
(not buffer-read-only))
:help
@@ -540,6 +535,12 @@
(if (featurep 'ns)
(bindings--define-key menu [separator-undo] menu-bar-separator))
+ (bindings--define-key menu [undo-redo]
+ '(menu-item "Redo" undo-redo
+ :enable (and (not buffer-read-only)
+ (undo--last-change-was-undo-p buffer-undo-list))
+ :help "Redo last undone edits"))
+
(bindings--define-key menu [undo]
'(menu-item "Undo" undo
:enable (and (not buffer-read-only)
@@ -547,7 +548,7 @@
(if (eq last-command 'undo)
(listp pending-undo-list)
(consp buffer-undo-list)))
- :help "Undo last operation"))
+ :help "Undo last edits"))
menu))
@@ -569,7 +570,9 @@
(defun clipboard-yank ()
"Insert the clipboard contents, or the last stretch of killed text."
(interactive "*")
- (let ((select-enable-clipboard t))
+ (let ((select-enable-clipboard t)
+ ;; Ensure that we defeat the DWIM login in `gui-selection-value'.
+ (gui--last-selected-text-clipboard nil))
(yank)))
(defun clipboard-kill-ring-save (beg end &optional region)
@@ -597,7 +600,7 @@ Do the same for the keys of the same name."
(define-key global-map [f20] 'clipboard-kill-region)
(define-key global-map [f16] 'clipboard-kill-ring-save)
(define-key global-map [f18] 'clipboard-yank)
- ;; X11R6 versions:
+ ;; X11 versions:
(define-key global-map [cut] 'clipboard-kill-region)
(define-key global-map [copy] 'clipboard-kill-ring-save)
(define-key global-map [paste] 'clipboard-yank))
@@ -629,9 +632,9 @@ Do the same for the keys of the same name."
:help "Customize value of specific option"))
(bindings--define-key menu [separator-2]
menu-bar-separator)
- (bindings--define-key menu [customize-changed-options]
- '(menu-item "New Options..." customize-changed-options
- :help "Options added or changed in recent Emacs versions"))
+ (bindings--define-key menu [customize-changed]
+ '(menu-item "New Options..." customize-changed
+ :help "Options and faces added or changed in recent Emacs versions"))
(bindings--define-key menu [customize-saved]
'(menu-item "Saved Options" customize-saved
:help "Customize previously saved options"))
@@ -661,31 +664,63 @@ PROPS are additional properties."
:button (:toggle . (and (default-boundp ',fname)
(default-value ',fname)))))
-(defmacro menu-bar-make-toggle (name variable doc message help &rest body)
+(defmacro menu-bar-make-toggle (command variable item-name message help
+ &rest body)
+ "Define a menu-bar toggle command.
+See `menu-bar-make-toggle-command', for which this is a
+compatibility wrapper. BODY is passed in as SETTING-SEXP in that macro."
+ (declare (obsolete menu-bar-make-toggle-command "28.1"))
+ `(menu-bar-make-toggle-command ,command ,variable ,item-name ,message ,help
+ ,(and body
+ `(progn
+ ,@body))))
+
+(defmacro menu-bar-make-toggle-command (command variable item-name message
+ help
+ &optional setting-sexp
+ &rest keywords)
+ "Define a menu-bar toggle command.
+COMMAND (a symbol) is the toggle command to define.
+
+VARIABLE (a symbol) is the variable to set.
+
+ITEM-NAME (a string) is the menu-item name.
+
+MESSAGE is a format string for the toggle message, with %s for the new
+status.
+
+HELP (a string) is the `:help' tooltip text and the doc string first
+line (minus final period) for the command.
+
+SETTING-SEXP is a Lisp sexp that sets VARIABLE, or it is nil meaning
+set it according to its `defcustom' or using `set-default'.
+
+KEYWORDS is a plist for `menu-item' for keywords other than `:help'."
`(progn
- (defun ,name (&optional interactively)
+ (defun ,command (&optional interactively)
,(concat "Toggle whether to " (downcase (substring help 0 1))
- (substring help 1) ".
+ (substring help 1) ".
In an interactive call, record this option as a candidate for saving
by \"Save Options\" in Custom buffers.")
(interactive "p")
- (if ,(if body `(progn . ,body)
- `(progn
+ (if ,(if setting-sexp
+ `,setting-sexp
+ `(progn
(custom-load-symbol ',variable)
(let ((set (or (get ',variable 'custom-set) 'set-default))
(get (or (get ',variable 'custom-get) 'default-value)))
(funcall set ',variable (not (funcall get ',variable))))))
- (message ,message "enabled globally")
- (message ,message "disabled globally"))
- ;; The function `customize-mark-as-set' must only be called when
- ;; a variable is set interactively, as the purpose is to mark it as
- ;; a candidate for "Save Options", and we do not want to save options
- ;; the user have already set explicitly in his init file.
- (if interactively (customize-mark-as-set ',variable)))
- '(menu-item ,doc ,name
- :help ,help
- :button (:toggle . (and (default-boundp ',variable)
- (default-value ',variable))))))
+ (message ,message "enabled globally")
+ (message ,message "disabled globally"))
+ ;; `customize-mark-as-set' must only be called when a variable is set
+ ;; interactively, because the purpose is to mark the variable as a
+ ;; candidate for `Save Options', and we do not want to save options that
+ ;; the user has already set explicitly in the init file.
+ (when interactively (customize-mark-as-set ',variable)))
+ '(menu-item ,item-name ,command :help ,help
+ :button (:toggle . (and (default-boundp ',variable)
+ (default-value ',variable)))
+ ,@keywords)))
;; Function for setting/saving default font.
@@ -957,10 +992,11 @@ The selected font will be the default on both the existing and future frames."
:help "Indicate buffer boundaries in fringe"))
(bindings--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"))
+ (menu-bar-make-toggle-command
+ toggle-indicate-empty-lines indicate-empty-lines
+ "Empty Line Indicators"
+ "Indicating of empty lines %s"
+ "Indicate trailing empty lines in fringe, globally"))
(bindings--define-key menu [customize]
'(menu-item "Customize Fringe" menu-bar-showhide-fringe-menu-customize
@@ -1405,7 +1441,7 @@ mail status in mode line"))
(bindings--define-key menu [custom-separator]
menu-bar-separator)
(bindings--define-key menu [case-fold-search]
- (menu-bar-make-toggle
+ (menu-bar-make-toggle-command
toggle-case-fold-search case-fold-search
"Ignore Case"
"Case-Insensitive Search %s"
@@ -1436,7 +1472,7 @@ mail status in mode line"))
(if (featurep 'system-font-setting)
(bindings--define-key menu [menu-system-font]
- (menu-bar-make-toggle
+ (menu-bar-make-toggle-command
toggle-use-system-font font-use-system-font
"Use System Font"
"Use system font: %s"
@@ -1462,13 +1498,15 @@ mail status in mode line"))
menu-bar-separator)
(bindings--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"))
+ (menu-bar-make-toggle-command
+ 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"))
(bindings--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"))
+ (menu-bar-make-toggle-command
+ toggle-debug-on-error debug-on-error
+ "Enter Debugger on Error" "Debug on Error %s"
+ "Enter Lisp debugger when an error is signaled"))
(bindings--define-key menu [debugger-separator]
menu-bar-separator)
@@ -1480,20 +1518,34 @@ mail status in mode line"))
(bindings--define-key menu [cursor-separator]
menu-bar-separator)
+ (bindings--define-key menu [save-desktop]
+ (menu-bar-make-toggle-command
+ toggle-save-desktop-globally desktop-save-mode
+ "Save State between Sessions"
+ "Saving desktop state %s"
+ "Visit desktop of previous session when restarting Emacs"
+ (progn
+ (require 'desktop)
+ ;; Do it by name, to avoid a free-variable
+ ;; warning during byte compilation.
+ (set-default
+ 'desktop-save-mode (not (symbol-value 'desktop-save-mode))))))
+
(bindings--define-key menu [save-place]
- (menu-bar-make-toggle
+ (menu-bar-make-toggle-command
toggle-save-place-globally save-place-mode
"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-mode (not (symbol-value 'save-place-mode)))))
+ (progn
+ (require 'saveplace)
+ ;; Do it by name, to avoid a free-variable
+ ;; warning during byte compilation.
+ (set-default
+ 'save-place-mode (not (symbol-value 'save-place-mode))))))
(bindings--define-key menu [uniquify]
- (menu-bar-make-toggle
+ (menu-bar-make-toggle-command
toggle-uniquify-buffer-names uniquify-buffer-name-style
"Use Directory Names in Buffer Names"
"Directory name in buffer names (uniquify) %s"
@@ -1507,7 +1559,7 @@ mail status in mode line"))
(bindings--define-key menu [cua-mode]
(menu-bar-make-mm-toggle
cua-mode
- "Use CUA Keys (Cut/Paste with C-x/C-c/C-v)"
+ "Cut/Paste with C-x/C-c/C-v (CUA Mode)"
"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))))
@@ -1515,8 +1567,8 @@ mail status in mode line"))
(bindings--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"
+ "CUA Mode (without C-x/C-c/C-v)"
+ "Enable CUA Mode without rebinding C-x/C-c/C-v keys"
(:visible (and (boundp 'cua-enable-cua-keys)
(not cua-enable-cua-keys)))))
@@ -1807,6 +1859,10 @@ mail status in mode line"))
(bindings--define-key menu [list-keybindings]
'(menu-item "List Key Bindings" describe-bindings
:help "Display all current key bindings (keyboard shortcuts)"))
+ (bindings--define-key menu [list-recent-keystrokes]
+ '(menu-item "Show Recent Inputs" view-lossage
+ :help "Display last few input events and the commands \
+they ran"))
(bindings--define-key menu [describe-current-display-table]
'(menu-item "Describe Display Table" describe-current-display-table
:help "Describe the current display table"))
@@ -1822,6 +1878,12 @@ mail status in mode line"))
(bindings--define-key menu [describe-function]
'(menu-item "Describe Function..." describe-function
:help "Display documentation of function/command"))
+ (bindings--define-key menu [describe-command]
+ '(menu-item "Describe Command..." describe-command
+ :help "Display documentation of command"))
+ (bindings--define-key menu [shortdoc-display-group]
+ '(menu-item "Function Group Overview..." shortdoc-display-group
+ :help "Display a function overview for a specific topic"))
(bindings--define-key menu [describe-key-1]
'(menu-item "Describe Key or Mouse Operation..." describe-key
;; Users typically don't identify keys and menu items...
@@ -2026,6 +2088,8 @@ key, a click, or a menu-item"))
(bindings--define-key global-map [menu-bar help-menu]
(cons (purecopy "Help") menu-bar-help-menu))
+(define-key global-map [menu-bar mouse-1] 'menu-bar-open-mouse)
+
(defun menu-bar-menu-frame-live-and-visible-p ()
"Return non-nil if the menu frame is alive and visible.
The menu frame is the frame for which we are updating the menu."
@@ -2175,11 +2239,11 @@ Buffers menu is regenerated."
:type 'boolean
:group 'menu)
-(defvar list-buffers-directory nil
+(defvar-local list-buffers-directory nil
"String to display in buffer listings for buffers not visiting a file.")
-(make-variable-buffer-local 'list-buffers-directory)
(defun menu-bar-select-buffer ()
+ (declare (obsolete nil "28.1"))
(interactive)
(switch-to-buffer last-command-event))
@@ -2227,9 +2291,10 @@ It must accept a buffer as its only required argument.")
(setq i (1- i))
(aset buffers-vec i
(cons (car pair)
- `(lambda ()
- (interactive)
- (funcall menu-bar-select-buffer-function ,(cdr pair))))))
+ (let ((buf (cdr pair)))
+ (lambda ()
+ (interactive)
+ (funcall menu-bar-select-buffer-function buf))))))
buffers-vec))
(defun menu-bar-update-buffers (&optional force)
@@ -2284,8 +2349,8 @@ It must accept a buffer as its only required argument.")
(aset frames-vec i
(cons
(frame-parameter frame 'name)
- `(lambda ()
- (interactive) (menu-bar-select-frame ,frame))))
+ (lambda ()
+ (interactive) (menu-bar-select-frame frame))))
(setq i (1+ i)))
;; Put it after the normal buffers
(setq buffers-menu
@@ -2601,6 +2666,92 @@ If FRAME is nil or not given, use the selected frame."
(global-set-key [f10] 'menu-bar-open)
+(defun menu-bar-open-mouse (event)
+ "Open the menu bar for the menu item clicked on by the mouse.
+EVENT should be a mouse down or click event.
+
+Also see `menu-bar-open', which this calls.
+This command is to be used when you click the mouse in the menubar."
+ (interactive "e")
+ ;; This only should be bound to clicks on the menu-bar, outside of
+ ;; any window.
+ (let ((window (posn-window (event-start event))))
+ (when window
+ (error "Event is inside window %s" window)))
+
+ (let* ((x-position (car (posn-x-y (event-start event))))
+ (menu-bar-item-cons (menu-bar-item-at-x x-position)))
+ (menu-bar-open nil
+ (if menu-bar-item-cons
+ (cdr menu-bar-item-cons)
+ 0))))
+
+(defun menu-bar-keymap ()
+ "Return the current menu-bar keymap.
+
+The ordering of the return value respects `menu-bar-final-items'."
+ (let ((menu-bar '())
+ (menu-end '()))
+ (map-keymap
+ (lambda (key binding)
+ (let ((pos (seq-position menu-bar-final-items key))
+ (menu-item (cons key binding)))
+ (if pos
+ ;; If KEY is the name of an item that we want to put
+ ;; last, store it separately with explicit ordering for
+ ;; sorting.
+ (push (cons pos menu-item) menu-end)
+ (push menu-item menu-bar))))
+ (lookup-key (menu-bar-current-active-maps) [menu-bar]))
+ `(keymap ,@(nreverse menu-bar)
+ ,@(mapcar #'cdr (sort menu-end
+ (lambda (a b)
+ (< (car a) (car b))))))))
+
+(defun menu-bar-current-active-maps ()
+ "Return the current active maps in the order the menu bar displays them.
+This value does not take into account `menu-bar-final-items' as that applies
+per-item."
+ ;; current-active-maps returns maps in the order local then
+ ;; global. The menu bar displays items in the opposite order.
+ (cons 'keymap (nreverse (current-active-maps))))
+
+(defun menu-bar-item-at-x (x-position)
+ "Return a cons of the form (KEY . X) for a menu item.
+The returned X is the left X coordinate for that menu item.
+
+X-POSITION is the X coordinate being queried. If nothing is clicked on,
+returns nil."
+ (let ((column 0)
+ (menu-bar (menu-bar-keymap))
+ prev-key
+ prev-column
+ found)
+ (catch 'done
+ (map-keymap
+ (lambda (key binding)
+ (when (> column x-position)
+ (setq found t)
+ (throw 'done nil))
+ (setq prev-key key)
+ (pcase binding
+ ((or `(,(and (pred stringp) name) . ,_) ;Simple menu item.
+ `(menu-item ,name ,_cmd ;Extended menu item.
+ . ,(and props
+ (guard (let ((visible
+ (plist-get props :visible)))
+ (or (null visible)
+ (eval visible)))))))
+ (setq prev-column column
+ column (+ column (length name) 1)))))
+ menu-bar)
+ ;; Check the last menu item.
+ (when (> column x-position)
+ (setq found t)))
+ (if found
+ (cons prev-key prev-column)
+ nil)))
+
(defun buffer-menu-open ()
"Start key navigation of the buffer menu.
This is the keyboard interface to \\[mouse-buffer-menu]."
@@ -2620,6 +2771,16 @@ This is the keyboard interface to \\[mouse-buffer-menu]."
(menu-bar-buffer-vector item)))))
km))
+(defun menu-bar-define-mouse-key (map key def)
+ "Like `define-key', but adds all possible prefixes for the mouse."
+ (define-key map (vector key) def)
+ (mapc (lambda (prefix) (define-key map (vector prefix key) def))
+ ;; This list only needs to contain special window areas that
+ ;; are rendered in TTYs. No need for *-scroll-bar, *-fringe,
+ ;; or *-divider.
+ '(tab-line header-line menu-bar tab-bar mode-line vertical-line
+ left-margin right-margin)))
+
(defvar tty-menu-navigation-map
(let ((map (make-sparse-keymap)))
;; The next line is disabled because it breaks interpretation of
@@ -2654,39 +2815,33 @@ This is the keyboard interface to \\[mouse-buffer-menu]."
(define-key map [?\C-j] 'tty-menu-select)
(define-key map [return] 'tty-menu-select)
(define-key map [linefeed] 'tty-menu-select)
- (define-key map [mouse-1] 'tty-menu-select)
- (define-key map [drag-mouse-1] 'tty-menu-select)
- (define-key map [mouse-2] 'tty-menu-select)
- (define-key map [drag-mouse-2] 'tty-menu-select)
- (define-key map [mouse-3] 'tty-menu-select)
- (define-key map [drag-mouse-3] 'tty-menu-select)
- (define-key map [wheel-down] 'tty-menu-next-item)
- (define-key map [wheel-up] 'tty-menu-prev-item)
- (define-key map [wheel-left] 'tty-menu-prev-menu)
- (define-key map [wheel-right] 'tty-menu-next-menu)
- ;; The following 4 bindings are for those whose text-mode mouse
+ (menu-bar-define-mouse-key map 'mouse-1 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'drag-mouse-1 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'mouse-2 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'drag-mouse-2 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'mouse-3 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'drag-mouse-3 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'wheel-down 'tty-menu-next-item)
+ (menu-bar-define-mouse-key map 'wheel-up 'tty-menu-prev-item)
+ (menu-bar-define-mouse-key map 'wheel-left 'tty-menu-prev-menu)
+ (menu-bar-define-mouse-key map 'wheel-right 'tty-menu-next-menu)
+ ;; The following 6 bindings are for those whose text-mode mouse
;; lack the wheel.
- (define-key map [S-mouse-1] 'tty-menu-next-item)
- (define-key map [S-drag-mouse-1] 'tty-menu-next-item)
- (define-key map [S-mouse-2] 'tty-menu-prev-item)
- (define-key map [S-drag-mouse-2] 'tty-menu-prev-item)
- (define-key map [S-mouse-3] 'tty-menu-prev-item)
- (define-key map [S-drag-mouse-3] 'tty-menu-prev-item)
- (define-key map [header-line mouse-1] 'tty-menu-select)
- (define-key map [header-line drag-mouse-1] 'tty-menu-select)
+ (menu-bar-define-mouse-key map 'S-mouse-1 'tty-menu-next-item)
+ (menu-bar-define-mouse-key map 'S-drag-mouse-1 'tty-menu-next-item)
+ (menu-bar-define-mouse-key map 'S-mouse-2 'tty-menu-prev-item)
+ (menu-bar-define-mouse-key map 'S-drag-mouse-2 'tty-menu-prev-item)
+ (menu-bar-define-mouse-key map 'S-mouse-3 'tty-menu-prev-item)
+ (menu-bar-define-mouse-key map 'S-drag-mouse-3 'tty-menu-prev-item)
;; The down-mouse events must be bound to tty-menu-ignore, so that
;; only releasing the mouse button pops up the menu.
- (define-key map [mode-line down-mouse-1] 'tty-menu-ignore)
- (define-key map [mode-line down-mouse-2] 'tty-menu-ignore)
- (define-key map [mode-line down-mouse-3] 'tty-menu-ignore)
- (define-key map [mode-line C-down-mouse-1] 'tty-menu-ignore)
- (define-key map [mode-line C-down-mouse-2] 'tty-menu-ignore)
- (define-key map [mode-line C-down-mouse-3] 'tty-menu-ignore)
- (define-key map [down-mouse-1] 'tty-menu-ignore)
- (define-key map [C-down-mouse-1] 'tty-menu-ignore)
- (define-key map [C-down-mouse-2] 'tty-menu-ignore)
- (define-key map [C-down-mouse-3] 'tty-menu-ignore)
- (define-key map [mouse-movement] 'tty-menu-mouse-movement)
+ (menu-bar-define-mouse-key map 'down-mouse-1 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'down-mouse-2 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'down-mouse-3 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'C-down-mouse-1 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'C-down-mouse-2 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'C-down-mouse-3 'tty-menu-ignore)
+ (menu-bar-define-mouse-key map 'mouse-movement 'tty-menu-mouse-movement)
map)
"Keymap used while processing TTY menus.")
diff --git a/lisp/mh-e/ChangeLog.1 b/lisp/mh-e/ChangeLog.1
index 86b6eb8040d..b0fdd02e3b3 100644
--- a/lisp/mh-e/ChangeLog.1
+++ b/lisp/mh-e/ChangeLog.1
@@ -324,7 +324,7 @@
* mh-customize.el (mh-show-pgg-good-face)
(mh-show-pgg-unknown-face, mh-show-pgg-bad-face): Faces added to
- highlight buttons introduced for encrpted or signed MIME parts.
+ highlight buttons introduced for encrypted or signed MIME parts.
2005-03-19 Bill Wohler <wohler@newt.com>
@@ -428,7 +428,7 @@
2004-11-28 Jeffrey C Honig <jch@honig.net>
* mh-comp.el (mh-complete-word): Kill the *Completions* buffer in
- any cases where we belive we are done with it. Not perfect, but
+ any cases where we believe we are done with it. Not perfect, but
better than just leaving it around.
2004-11-08 Satyaki Das <satyaki@theforce.stanford.edu>
@@ -818,7 +818,7 @@
* Makefile:
(mh-e-autoloads.el): Add target to make `mh-e-autoloads.el', a
- file containg usual entry commands into MH-E to be used for users
+ file containing usual entry commands into MH-E to be used for users
installing MH-E separately from Emacs.
(XEMACS_LOADDEFS_FILE): New. Used to generate mh-loaddefs.el
in XEmacs.
@@ -1201,7 +1201,7 @@
2003-11-01 Peter S Galbraith <psg@debian.org>
- * Makefile: Add target to make `mh-startup.el', a file containg
+ * Makefile: Add target to make `mh-startup.el', a file containing
usual entry commands into MH-E to be used for users installing
MH-E separately from Emacs.
@@ -1914,7 +1914,7 @@
2003-08-18 Peter S Galbraith <psg@debian.org>
* mh-comp.el (mh-letter-mode): Call `mh-find-path unconditionally,
- like elsewehere in MH-E.
+ like elsewhere in MH-E.
* mh-utils.el (mh-find-path): Run setup code only if
`mh-find-path-run' is nil such that this is only done once.
@@ -2588,7 +2588,7 @@
2003-07-24 Satyaki Das <satyakid@stanford.edu>
* mh-e.el (mh-folder-message-menu, mh-folder-folder-menu): Use the
- predicate mh-outstanding-commands-p instead of its exapansion.
+ predicate mh-outstanding-commands-p instead of its expansion.
Also use the same label in both menus.
(mh-outstanding-commands-p): Generalized so that it will work in
mh-show-mode buffers as well.
@@ -3915,7 +3915,7 @@
2003-04-22 Satyaki Das <satyaki@theforce.stanford.edu>
* mh-utils.el (mh-normalize-folder-name): Make the completion
- code work properly with XEmacs. This change is neeeded since
+ code work properly with XEmacs. This change is needed since
split-string behaves differently in XEmacs than it does in GNU
Emacs.
(mh-exec-cmd-error): Add a comment, so that we change it later on.
@@ -7391,7 +7391,7 @@
numbers.
(mh-cmd-note): Mention mh-set-cmd-note in docstring. Also suggest
that it is updated dynamically only if mh-scan-format-file is t.
- (mh-set-cmd-note): Grammer fix in docstring.
+ (mh-set-cmd-note): Grammar fix in docstring.
(mh-cmd-note): Noted that the first column is column number 0.
* mh-e.el (mh-scan-format-file): Added information about
@@ -7696,7 +7696,7 @@
* mh-identity.el: New file. Multiple Identify support for MH-E.
Used to easily set different fields such as From and Organization,
- as well as diffrent signature files. This file won't be included
+ as well as different signature files. This file won't be included
with V7.0.
2002-11-02 Bill Wohler <wohler@newt.com>
@@ -9458,10 +9458,10 @@
2002-07-15 Mark D. Baushke <mdb@gnu.org>
- * mh-utils.el (mm-decode): Use load for the Non-fatal depencency
+ * mh-utils.el (mm-decode): Use load for the Non-fatal dependency
on the mm-decode library.
* mh-mime.el (mm-decode, mm-uu, mm-view): Use load for the
- Non-fatal depencencies on the mm-decode, mm-uu and mm-view
+ Non-fatal dependencies on the mm-decode, mm-uu and mm-view
libraries.
2002-07-15 Satyaki Das <satyaki@theforce.stanford.edu>
@@ -11196,7 +11196,7 @@
instead of "0 msgs". Do not try to print a range when there are
no messages.
* mh-e.el (mh-regenerate-headers): Bug fix. Catch and remove the
- "scan: band message list" message.
+ "scan: bad message list" message.
2001-11-13 Jeffrey C Honig <jch@honig.net>
@@ -11356,7 +11356,7 @@
4 was silly for my case.
* mh-e.el (mh-update-sequences): Check for nil value of
mh-current-folder, which happens if mh-summary-height < 4
- although I haven't tracked doen why that happens.
+ although I haven't tracked down why that happens.
2001-10-22 Peter S Galbraith <psg@debian.org>
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index af6f2f1ab02..8fdcf3c62b4 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -1,4 +1,4 @@
-;;; mh-acros.el --- macros used in MH-E
+;;; mh-acros.el --- macros used in MH-E -*- lexical-binding: t; -*-
;; Copyright (C) 2004, 2006-2021 Free Software Foundation, Inc.
@@ -36,8 +36,6 @@
;; because it's pointless to compile a file full of macros. But we
;; kept the name.
-;;; Change Log:
-
;;; Code:
(require 'cl-lib)
@@ -49,20 +47,19 @@
;;;###mh-autoload
(defmacro mh-do-in-gnu-emacs (&rest body)
"Execute BODY if in GNU Emacs."
- (declare (debug t))
+ (declare (debug t) (indent defun))
(unless (featurep 'xemacs) `(progn ,@body)))
-(put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
;;;###mh-autoload
(defmacro mh-do-in-xemacs (&rest body)
"Execute BODY if in XEmacs."
- (declare (debug t))
+ (declare (debug t) (indent defun))
(when (featurep 'xemacs) `(progn ,@body)))
-(put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
;;;###mh-autoload
(defmacro mh-funcall-if-exists (function &rest args)
"Call FUNCTION with ARGS as parameters if it exists."
+ (declare (debug (symbolp body)))
;; FIXME: Not clear when this should be used. If the function happens
;; not to exist at compile-time (e.g. because the corresponding package
;; wasn't loaded), then it won't ever be used :-(
@@ -75,25 +72,24 @@
"Create function NAME.
If FUNCTION exists, then NAME becomes an alias for FUNCTION.
Otherwise, create function NAME with ARG-LIST and BODY."
+ (declare (indent defun) (doc-string 4)
+ (debug (&define name symbolp sexp def-body)))
`(defalias ',name
(if (fboundp ',function)
',function
(lambda ,arg-list ,@body))))
-(put 'defun-mh 'lisp-indent-function 'defun)
-(put 'defun-mh 'doc-string-elt 4)
;;;###mh-autoload
(defmacro defmacro-mh (name macro arg-list &rest body)
"Create macro NAME.
If MACRO exists, then NAME becomes an alias for MACRO.
Otherwise, create macro NAME with ARG-LIST and BODY."
+ (declare (indent defun) (doc-string 4)
+ (debug (&define name symbolp sexp def-body)))
(let ((defined-p (fboundp macro)))
(if defined-p
`(defalias ',name ',macro)
`(defmacro ,name ,arg-list ,@body))))
-(put 'defmacro-mh 'lisp-indent-function 'defun)
-(put 'defmacro-mh 'doc-string-elt 4)
-
;;; Miscellaneous
@@ -127,7 +123,7 @@ Execute BODY, which can modify the folder buffer without having to
worry about file locking or the read-only flag, and return its result.
If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag
is unchanged, otherwise it is cleared."
- (declare (debug t))
+ (declare (debug t) (indent defun))
(setq save-modification-flag (car save-modification-flag)) ; CL style
`(prog1
(let ((mh-folder-updating-mod-flag (buffer-modified-p))
@@ -139,14 +135,13 @@ is unchanged, otherwise it is cleared."
(mh-set-folder-modified-p mh-folder-updating-mod-flag)))
,@(if (not save-modification-flag)
'((mh-set-folder-modified-p nil)))))
-(put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
;;;###mh-autoload
(defmacro mh-in-show-buffer (show-buffer &rest body)
"Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
Display buffer SHOW-BUFFER in other window and execute BODY in it.
Stronger than `save-excursion', weaker than `save-window-excursion'."
- (declare (debug t))
+ (declare (debug t) (indent defun))
(setq show-buffer (car show-buffer)) ; CL style
`(let ((mh-in-show-buffer-saved-window (selected-window)))
(switch-to-buffer-other-window ,show-buffer)
@@ -155,7 +150,6 @@ Stronger than `save-excursion', weaker than `save-window-excursion'."
(progn
,@body)
(select-window mh-in-show-buffer-saved-window))))
-(put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
;;;###mh-autoload
(defmacro mh-do-at-event-location (event &rest body)
@@ -163,7 +157,7 @@ Stronger than `save-excursion', weaker than `save-window-excursion'."
After BODY has been executed return to original window.
The modification flag of the buffer in the event window is
preserved."
- (declare (debug t))
+ (declare (debug t) (indent defun))
(let ((event-window (make-symbol "event-window"))
(event-position (make-symbol "event-position"))
(original-window (make-symbol "original-window"))
@@ -190,7 +184,6 @@ preserved."
(goto-char ,original-position)
(set-marker ,original-position nil)
(select-window ,original-window))))))
-(put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
@@ -209,7 +202,7 @@ VAR is bound to the message on the current line as we loop
starting from BEGIN till END. In each step BODY is executed.
If VAR is nil then the loop is executed without any binding."
- (declare (debug (symbolp body)))
+ (declare (debug (symbolp body)) (indent defun))
(unless (symbolp var)
(error "Can not bind the non-symbol %s" var))
(let ((binding-needed-flag var))
@@ -221,7 +214,6 @@ If VAR is nil then the loop is executed without any binding."
(let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
,@body))
(forward-line 1)))))
-(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
;;;###mh-autoload
(defmacro mh-iterate-on-range (var range &rest body)
@@ -235,7 +227,7 @@ a string. In each iteration, BODY is executed.
The parameter RANGE is usually created with
`mh-interactive-range' in order to provide a uniform interface to
MH-E functions."
- (declare (debug (symbolp body)))
+ (declare (debug (symbolp body)) (indent defun))
(unless (symbolp var)
(error "Can not bind the non-symbol %s" var))
(let ((binding-needed-flag var)
@@ -263,7 +255,6 @@ MH-E functions."
(when (gethash v ,seq-hash-table)
(let ,(if binding-needed-flag `((,var v)) ())
,@body))))))))
-(put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
(defmacro mh-dlet* (binders &rest body)
"Like `let*' but always dynamically scoped."
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index c3eedb94ba5..415e9848258 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -1,4 +1,4 @@
-;;; mh-alias.el --- MH-E mail alias completion and expansion
+;;; mh-alias.el --- MH-E mail alias completion and expansion -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1997, 2001-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -42,8 +40,8 @@
"Time aliases were last loaded.")
(defvar mh-alias-read-address-map
(let ((map (copy-keymap minibuffer-local-completion-map)))
- (define-key map "," 'mh-alias-minibuffer-confirm-address)
- (define-key map " " 'self-insert-command)
+ (define-key map "," #'mh-alias-minibuffer-confirm-address)
+ (define-key map " " #'self-insert-command)
map))
(defcustom mh-alias-system-aliases
@@ -73,12 +71,11 @@ If ARG is non-nil, set timestamp with the current time."
(setq mh-alias-tstamp (list (nth 0 time) (nth 1 time))))
(let ((stamp))
(car (memq t (mapcar
- (function
- (lambda (file)
- (when (and file (file-exists-p file))
- (setq stamp (file-attribute-modification-time
- (file-attributes file)))
- (time-less-p mh-alias-tstamp stamp))))
+ (lambda (file)
+ (when (and file (file-exists-p file))
+ (setq stamp (file-attribute-modification-time
+ (file-attributes file)))
+ (time-less-p mh-alias-tstamp stamp)))
(mh-alias-filenames t)))))))
(defun mh-alias-filenames (arg)
@@ -93,11 +90,10 @@ appended."
(filelist (and filename (split-string filename "[ \t]+")))
(userlist
(mapcar
- (function
- (lambda (file)
- (if (and mh-user-path file
- (file-exists-p (expand-file-name file mh-user-path)))
- (expand-file-name file mh-user-path))))
+ (lambda (file)
+ (if (and mh-user-path file
+ (file-exists-p (expand-file-name file mh-user-path)))
+ (expand-file-name file mh-user-path)))
filelist)))
(if arg
(if (stringp mh-alias-system-aliases)
@@ -272,9 +268,9 @@ Blind aliases or users from /etc/passwd are not expanded."
(t (split-string
(completing-read prompt mh-alias-alist nil nil) ",")))))
(if (not mh-alias-expand-aliases-flag)
- (mapconcat 'identity the-answer ", ")
+ (mapconcat #'identity the-answer ", ")
;; Loop over all elements, checking if in passwd alias or blind first
- (mapconcat 'mh-alias-expand the-answer ",\n ")))))
+ (mapconcat #'mh-alias-expand the-answer ",\n ")))))
;;;###mh-autoload
(defun mh-alias-minibuffer-confirm-address ()
@@ -429,10 +425,10 @@ contains it."
(if (or (not alias)
(string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
(completing-read "Alias file: "
- (mapcar 'list mh-alias-insert-file) nil t)
+ (mapcar #'list mh-alias-insert-file) nil t)
(or (mh-alias-which-file-has-alias alias mh-alias-insert-file)
(completing-read "Alias file: "
- (mapcar 'list mh-alias-insert-file) nil t)))))
+ (mapcar #'list mh-alias-insert-file) nil t)))))
((and mh-alias-insert-file (stringp mh-alias-insert-file))
mh-alias-insert-file)
(t
@@ -451,11 +447,10 @@ set `mh-alias-insert-file' or the \"Aliasfile:\" profile component"))
(car autolist))
((or (not alias)
(string-equal alias (mh-alias-ali alias))) ;alias doesn't exist
- (completing-read "Alias file: " (mapcar 'list autolist) nil t))
+ (completing-read "Alias file: " autolist nil t))
(t
(or (mh-alias-which-file-has-alias alias autolist)
- (completing-read "Alias file: "
- (mapcar 'list autolist) nil t))))))))
+ (completing-read "Alias file: " autolist nil t))))))))
;;;###mh-autoload
(defun mh-alias-address-to-alias (address)
@@ -466,12 +461,11 @@ set `mh-alias-insert-file' or the \"Aliasfile:\" profile component"))
;; Double-check that we have an individual alias. This means that the
;; alias doesn't expand into a list (of which this address is part).
(car (delq nil (mapcar
- (function
- (lambda (alias)
- (let ((recurse (mh-alias-ali alias nil)))
- (if (string-match ".*,.*" recurse)
- nil
- alias))))
+ (lambda (alias)
+ (let ((recurse (mh-alias-ali alias nil)))
+ (if (string-match ".*,.*" recurse)
+ nil
+ alias)))
(split-string aliases ", +")))))))
;;;###mh-autoload
diff --git a/lisp/mh-e/mh-buffers.el b/lisp/mh-e/mh-buffers.el
index 55f74b6585d..ef21fdb2f95 100644
--- a/lisp/mh-e/mh-buffers.el
+++ b/lisp/mh-e/mh-buffers.el
@@ -1,4 +1,4 @@
-;;; mh-buffers.el --- MH-E buffer constants and utilities
+;;; mh-buffers.el --- MH-E buffer constants and utilities -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
;; The names of ephemeral buffers have a " *mh-" prefix (so that they
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index 4333d27e0fb..b64bbfb6f3b 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -1,4 +1,4 @@
-;;; mh-comp.el --- MH-E functions for composing and sending messages
+;;; mh-comp.el --- MH-E functions for composing and sending messages -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -29,8 +29,6 @@
;; that are used to send the mail. Other that those, functions that
;; are needed in mh-letter.el should be found there.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -305,6 +303,7 @@ message and scan line."
(let ((draft-buffer (current-buffer))
(file-name buffer-file-name)
(config mh-previous-window-config)
+ ;; FIXME this is subtly different to select-message-coding-system.
(coding-system-for-write
(if (fboundp 'select-message-coding-system)
(select-message-coding-system) ; Emacs has this since at least 21.1
@@ -318,7 +317,7 @@ message and scan line."
(or (and (boundp 'sendmail-coding-system) sendmail-coding-system)
(and (default-boundp 'buffer-file-coding-system)
(default-value 'buffer-file-coding-system))
- 'iso-latin-1)))))
+ 'utf-8)))))
;; Older versions of spost do not support -msgid and -mime.
(unless mh-send-uses-spost-flag
;; Adding a Message-ID field looks good, makes it easier to search for
@@ -434,43 +433,42 @@ See also `mh-send'."
(mh-insert-header-separator)
;; Merge in components
(mh-mapc
- (function
- (lambda (header-field)
- (let ((field (car header-field))
- (value (cdr header-field))
- (case-fold-search t))
- (cond
- ;; Address field
- ((string-match field "^To$\\|^Cc$\\|^From$")
- (cond
- ((not (mh-goto-header-field (concat field ":")))
- ;; Header field does not exist, add it
- (mh-goto-header-end 0)
- (insert field ": " value "\n"))
- ((string-equal value "")
- ;; Header field already exists and no value
- )
- (t
- ;; Header field exists and we have a value
- (let (address mailbox (alias (mh-alias-expand value)))
- (and alias
- (setq address (ietf-drums-parse-address alias))
- (setq mailbox (car address)))
- ;; XXX - Need to parse all addresses out of field
- (if (and
- (not (mh-regexp-in-field-p
- (concat "\\b" (regexp-quote value) "\\b") field))
- mailbox
- (not (mh-regexp-in-field-p
- (concat "\\b" (regexp-quote mailbox) "\\b") field)))
- (insert " " value ","))
- ))))
- ((string-match field "^Fcc$")
- ;; Folder reference
- (mh-modify-header-field field value))
- ;; Text field, that's an easy case
- (t
- (mh-modify-header-field field value))))))
+ (lambda (header-field)
+ (let ((field (car header-field))
+ (value (cdr header-field))
+ (case-fold-search t))
+ (cond
+ ;; Address field
+ ((string-match field "^To$\\|^Cc$\\|^From$")
+ (cond
+ ((not (mh-goto-header-field (concat field ":")))
+ ;; Header field does not exist, add it
+ (mh-goto-header-end 0)
+ (insert field ": " value "\n"))
+ ((string-equal value "")
+ ;; Header field already exists and no value
+ )
+ (t
+ ;; Header field exists and we have a value
+ (let (address mailbox (alias (mh-alias-expand value)))
+ (and alias
+ (setq address (ietf-drums-parse-address alias))
+ (setq mailbox (car address)))
+ ;; XXX - Need to parse all addresses out of field
+ (if (and
+ (not (mh-regexp-in-field-p
+ (concat "\\b" (regexp-quote value) "\\b") field))
+ mailbox
+ (not (mh-regexp-in-field-p
+ (concat "\\b" (regexp-quote mailbox) "\\b") field)))
+ (insert " " value ","))
+ ))))
+ ((string-match field "^Fcc$")
+ ;; Folder reference
+ (mh-modify-header-field field value))
+ ;; Text field, that's an easy case
+ (t
+ (mh-modify-header-field field value)))))
(mh-components-to-list components-file))
(delete-file components-file)
(goto-char (point-min))
@@ -699,33 +697,34 @@ message and scan line."
;; trumping anything in the distcomps file.
(let ((components-file (mh-bare-components mh-dist-formfile)))
(mh-mapc
- (function
- (lambda (header-field)
- (let ((field (car header-field))
- (value (cdr header-field))
- (case-fold-search t))
- (cond
- ((string-match field "^Resent-Fcc$")
- (setq comp-fcc value))
- ((string-match field "^Resent-From$")
- (or from
- (setq from value)))
- ((string-match field "^Resent-To$")
- (setq comp-to value))
- ((string-match field "^Resent-Cc$")
- (setq comp-cc value))
- ((string-match field "^Resent-Bcc$")
- (setq comp-bcc value))
- ((string-match field "^Resent-.*$")
- (mh-insert-fields field value))))))
+ (lambda (header-field)
+ (let ((field (car header-field))
+ (value (cdr header-field))
+ (case-fold-search t))
+ (cond
+ ((string-match field "^Resent-Fcc$")
+ (setq comp-fcc value))
+ ((string-match field "^Resent-From$")
+ (or from
+ (setq from value)))
+ ((string-match field "^Resent-To$")
+ (setq comp-to value))
+ ((string-match field "^Resent-Cc$")
+ (setq comp-cc value))
+ ((string-match field "^Resent-Bcc$")
+ (setq comp-bcc value))
+ ((string-match field "^Resent-.*$")
+ (mh-insert-fields field value)))))
(mh-components-to-list components-file))
(delete-file components-file))
- (mh-insert-fields "Resent-To:" (mapconcat 'identity (list to comp-to) ", ")
- "Resent-Cc:" (mapconcat 'identity (list cc comp-cc) ", ")
- "Resent-Fcc:" (mapconcat 'identity (list fcc
- comp-fcc) ", ")
- "Resent-Bcc:" (mapconcat 'identity (list bcc
- comp-bcc) ", ")
+ (mh-insert-fields "Resent-To:" (mapconcat #'identity (list to comp-to)
+ ", ")
+ "Resent-Cc:" (mapconcat #'identity (list cc comp-cc)
+ ", ")
+ "Resent-Fcc:" (mapconcat #'identity (list fcc comp-fcc)
+ ", ")
+ "Resent-Bcc:" (mapconcat #'identity (list bcc comp-bcc)
+ ", ")
"Resent-From:" from)
(save-buffer)
(message "Redistributing...")
@@ -1097,7 +1096,7 @@ letter."
(setq mode-line-buffer-identification (list " {%b}"))
(mh-logo-display)
(mh-make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t)
+ (add-hook 'kill-buffer-hook #'mh-tidy-draft-buffer nil t)
(run-hook-with-args 'mh-compose-letter-function to subject cc))
(defun mh-insert-x-mailer ()
@@ -1166,7 +1165,7 @@ This should be the last function called when composing the draft."
MSG can be a message number, a list of message numbers, or a sequence.
The hook `mh-annotate-msg-hook' is run after annotating; see its
documentation for variables it can use."
- (apply 'mh-exec-cmd "anno" folder
+ (apply #'mh-exec-cmd "anno" folder
(if (listp msg) (append msg args) (cons msg args)))
(save-excursion
(cond ((get-buffer folder) ; Buffer may be deleted
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index 07bf03b30ee..ade80e8b95e 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -1,4 +1,4 @@
-;;; mh-compat.el --- make MH-E compatible with various versions of Emacs
+;;; mh-compat.el --- make MH-E compatible with various versions of Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -23,8 +23,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
;; This is a good place to gather code that is used for compatibility
@@ -42,7 +40,7 @@
(eval-when-compile (require 'mh-acros))
(mh-do-in-gnu-emacs
- (defalias 'mh-require 'require))
+ (defalias 'mh-require #'require))
(mh-do-in-xemacs
(defun mh-require (feature &optional filename noerror)
@@ -83,6 +81,7 @@ This is an analogue of a dynamically scoped `let' that operates on
the function cell of FUNCs rather than their value cell.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (sexp sexp &rest form)) &rest form)))
(if (fboundp 'cl-letf)
`(cl-letf ,(mapcar (lambda (binding)
`((symbol-function ',(car binding))
@@ -90,9 +89,6 @@ the function cell of FUNCs rather than their value cell.
bindings)
,@body)
`(flet ,bindings ,@body)))
-(put 'mh-flet 'lisp-indent-function 1)
-(put 'mh-flet 'edebug-form-spec
- '((&rest (sexp sexp &rest form)) &rest form))
(defun mh-display-color-cells (&optional display)
"Return the number of color cells supported by DISPLAY.
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index 6ac23789507..949787a2501 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -1,4 +1,4 @@
-;;; mh-e.el --- GNU Emacs interface to the MH mail system
+;;; mh-e.el --- GNU Emacs interface to the MH mail system -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1988, 1990, 1992-1995, 1997, 1999-2021 Free
;; Software Foundation, Inc.
@@ -229,7 +229,7 @@ User's mail folder directory.")
(defvar mh-arrow-marker nil
"Marker for arrow display in fringe.")
-(defvar mh-blacklist nil
+(defvar mh-blocklist nil
"List of messages to use to train the junk filter.
This variable can be used by
`mh-before-commands-processed-hook'.")
@@ -295,7 +295,7 @@ Elements have the form (SEQUENCE . MESSAGES).")
"Stack of operations that change the folder view.
These operations include narrowing or threading.")
-(defvar mh-whitelist nil
+(defvar mh-allowlist nil
"List of messages to use to train the junk filter.
This variable can be used by
`mh-before-commands-processed-hook'.")
@@ -522,7 +522,7 @@ parsed by MH-E."
(let* ((initial-size (mh-truncate-log-buffer))
(start (point))
(args (mh-list-to-string args)))
- (apply 'call-process (expand-file-name command mh-progs) nil t nil args)
+ (apply #'call-process (expand-file-name command mh-progs) nil t nil args)
(when (> (buffer-size) initial-size)
(save-excursion
(goto-char start)
@@ -560,7 +560,7 @@ ARGS are passed to COMMAND as command line arguments."
(with-current-buffer (get-buffer-create mh-log-buffer)
(mh-truncate-log-buffer))
(let* ((process-connection-type nil)
- (process (apply 'start-process
+ (process (apply #'start-process
command nil
(expand-file-name command mh-progs)
(mh-list-to-string args))))
@@ -602,7 +602,7 @@ RAISE-ERROR is non-nil, in which case an error is signaled if
(set-buffer (get-buffer-create mh-temp-buffer))
(erase-buffer)
(let ((value
- (apply 'call-process
+ (apply #'call-process
(expand-file-name command mh-progs) nil t nil
args)))
(goto-char (point-min))
@@ -616,7 +616,7 @@ Put the output into buffer after point.
Set mark after inserted text.
Output is expected to be shown to user, not parsed by MH-E."
(push-mark (point) t)
- (apply 'call-process
+ (apply #'call-process
(expand-file-name command mh-progs) nil t display
(mh-list-to-string args))
@@ -650,7 +650,7 @@ preserves whether the mark is active or not."
"Execute MH library command COMMAND with ARGS.
Put the output into buffer after point.
Set mark after inserted text."
- (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args))
+ (apply #'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args))
(defun mh-handle-process-error (command status)
"Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS."
@@ -695,9 +695,8 @@ See documentation for `defgroup' for a description of the arguments
SYMBOL, MEMBERS, DOC and ARGS.
This macro is used by Emacs versions that lack the :package-version
keyword, introduced in Emacs 22."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(defgroup ,symbol ,members ,doc ,@(mh-strip-package-version args)))
-(put 'defgroup-mh 'lisp-indent-function 'defun)
(defmacro defcustom-mh (symbol value doc &rest args)
"Declare SYMBOL as a customizable variable that defaults to VALUE.
@@ -705,9 +704,8 @@ See documentation for `defcustom' for a description of the arguments
SYMBOL, VALUE, DOC and ARGS.
This macro is used by Emacs versions that lack the :package-version
keyword, introduced in Emacs 22."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(defcustom ,symbol ,value ,doc ,@(mh-strip-package-version args)))
-(put 'defcustom-mh 'lisp-indent-function 'defun)
(defmacro defface-mh (face spec doc &rest args)
"Declare FACE as a customizable face that defaults to SPEC.
@@ -715,9 +713,8 @@ See documentation for `defface' for a description of the arguments
FACE, SPEC, DOC and ARGS.
This macro is used by Emacs versions that lack the :package-version
keyword, introduced in Emacs 22."
- (declare (doc-string 3))
+ (declare (doc-string 3) (indent defun))
`(defface ,face ,spec ,doc ,@(mh-strip-package-version args)))
-(put 'defface-mh 'lisp-indent-function 'defun)
@@ -741,8 +738,11 @@ is described by the variable `mh-variants'."
;; Make a unique list of directories, keeping the given order.
;; We don't want the same MH variant to be listed multiple times.
(cl-loop for dir in (append mh-path mh-sys-path exec-path) do
- (setq dir (file-chase-links (directory-file-name dir)))
- (cl-pushnew dir list-unique :test #'equal))
+ ;; skip relative dirs, typically "."
+ (if (file-name-absolute-p dir)
+ (progn
+ (setq dir (file-chase-links (directory-file-name dir)))
+ (cl-pushnew dir list-unique :test #'equal))))
(cl-loop for dir in (nreverse list-unique) do
(when (and dir (file-accessible-directory-p dir))
(let ((variant (mh-variant-info dir)))
@@ -977,7 +977,7 @@ necessary and can actually cause problems."
:set (lambda (symbol value)
(set-default symbol value) ;Done in mh-variant-set-variant!
(mh-variant-set value))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:group 'mh-e
:package-version '(MH-E . "8.0"))
@@ -1550,8 +1550,8 @@ as the result is undefined."
,(append
'(radio)
(mapcar
- (function (lambda (arg) `(const ,arg)))
- (mapcar 'car mh-identity-list))))
+ (lambda (arg) `(const ,arg))
+ (mapcar #'car mh-identity-list))))
(cons :tag "Fcc Field"
(const "fcc")
(string :tag "Value"))
@@ -1577,8 +1577,8 @@ See `mh-identity-list'."
:type (append
'(radio)
(cons '(const :tag "None" nil)
- (mapcar (function (lambda (arg) `(const ,arg)))
- (mapcar 'car mh-identity-list))))
+ (mapcar (lambda (arg) `(const ,arg))
+ (mapcar #'car mh-identity-list))))
:group 'mh-identity
:package-version '(MH-E . "7.1"))
@@ -1687,13 +1687,13 @@ fashion."
;; Available spam filter interfaces
(defvar mh-junk-function-alist
- '((spamassassin mh-spamassassin-blacklist mh-spamassassin-whitelist)
- (bogofilter mh-bogofilter-blacklist mh-bogofilter-whitelist)
- (spamprobe mh-spamprobe-blacklist mh-spamprobe-whitelist))
+ '((spamassassin mh-spamassassin-blocklist mh-spamassassin-allowlist)
+ (bogofilter mh-bogofilter-blocklist mh-bogofilter-allowlist)
+ (spamprobe mh-spamprobe-blocklist mh-spamprobe-allowlist))
"Available choices of spam programs to use.
This is an alist. For each element there are functions that
-blacklist a message as spam and whitelist a message incorrectly
+blocklist a message as spam and allowlist a message incorrectly
classified as spam.")
(defun mh-junk-choose (symbol value)
@@ -1718,8 +1718,8 @@ be slow when junking large numbers of messages. If you have
enough memory or don't junk that many messages at the same time,
you might try turning on this option.
-Note that this option is used as the \"display\" argument in the
-call to `call-process'. Therefore, turning on this option means
+Note that this option is used as the \"destination\" argument in
+the call to `call-process'. Therefore, turning on this option means
setting its value to \"0\". You can also set its value to t to
direct the programs' output to the \"*MH-E Log*\" buffer; this
may be useful for debugging."
@@ -1747,7 +1747,7 @@ bogofilter, then you can set this option to \"Bogofilter\"."
(const :tag "SpamAssassin" spamassassin)
(const :tag "Bogofilter" bogofilter)
(const :tag "SpamProbe" spamprobe))
- :set 'mh-junk-choose
+ :set #'mh-junk-choose
:group 'mh-junk
:package-version '(MH-E . "7.3"))
@@ -1910,11 +1910,11 @@ white image, can be generated using the \"compface\" command (see URL
`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z'). The
\"Online X-Face Converter\" is a useful resource for quick conversion
of images into \"X-Face:\" header fields (see URL
-`http://www.dairiki.org/xface/').
+`https://www.dairiki.org/xface/').
Use the \"make-face\" script to convert a JPEG image to the higher
resolution, color, \"Face:\" header field (see URL
-`http://quimby.gnus.org/circus/face/make-face').
+`https://quimby.gnus.org/circus/face/make-face').
The URL of any image can be used for the \"X-Image-URL:\" field and no
processing of the image is required.
@@ -2008,7 +2008,7 @@ call `mh-set-cmd-note' with the width specified by your format file
you would use \"(mh-set-cmd-note 4)\"."
:type 'boolean
:group 'mh-scan-line-formats
- :set 'mh-adaptive-cmd-note-flag-check
+ :set #'mh-adaptive-cmd-note-flag-check
:package-version '(MH-E . "7.0"))
(defun mh-scan-format-file-check (symbol value)
@@ -2047,7 +2047,7 @@ Emacs start with 0)."
(const :tag "Use Default scan Format" nil)
(file :tag "Specify a scan Format File"))
:group 'mh-scan-line-formats
- :set 'mh-scan-format-file-check
+ :set #'mh-scan-format-file-check
:package-version '(MH-E . "6.0"))
(defun mh-adaptive-cmd-note-flag-check (symbol value)
@@ -2236,11 +2236,11 @@ commands."
:group 'mh-sequences
:package-version '(MH-E . "7.0"))
-(defcustom-mh mh-whitelist-preserves-sequences-flag t
- "Non-nil means that sequences are preserved when messages are whitelisted.
+(defcustom-mh mh-allowlist-preserves-sequences-flag t
+ "Non-nil means that sequences are preserved when messages are allowlisted.
If a message is in any sequence (except \"Previous-Sequence:\"
-and \"cur\") when it is whitelisted, then it will still be in
+and \"cur\") when it is allowlisted, then it will still be in
those sequences in the destination folder. If this behavior is
not desired, then turn off this option."
:type 'boolean
@@ -2420,11 +2420,11 @@ of citations entirely, choose \"None\"."
;; These entries have been intentionally excluded by the developers.
;; "Comments:" ; RFC 822 (or later) - show this one
-;; "Fax:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
-;; "Mail-System-Version:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
-;; "Mailer:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+;; "Fax:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+;; "Mail-System-Version:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+;; "Mailer:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
;; "Organization:" ;
-;; "Phone:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+;; "Phone:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
;; "Reply-By:" ; RFC 2156
;; "Reply-To:" ; RFC 822 (or later)
;; "Sender:" ;
@@ -2437,13 +2437,13 @@ of citations entirely, choose \"None\"."
;; Mention source, if known.
(defvar mh-invisible-header-fields-internal
'(
- "Abuse-Reports-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Abuse-Reports-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Accept-Language:"
"AcceptLanguage:"
"Accreditor:" ; Habeas
"Also-Control:" ; H. Spencer: News Article Format and Transmission, June 1994
"Alternate-recipient:" ; RFC 2156
- "Approved-By:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Approved-By:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Approved:" ; RFC 1036
"Article-Names:" ; H. Spencer: News Article Format and Transmission, June 1994
"Article-Updates:" ; H. Spencer: News Article Format and Transmission, June 1994
@@ -2454,7 +2454,7 @@ of citations entirely, choose \"None\"."
"Bounces-To:"
"Bounces_to:"
"Bytes:"
- "Cancel-Key:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Cancel-Key:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Cancel-Lock:" ; NNTP posts
"Comment:" ; Shows up with DomainKeys
"Content-" ; RFC 2045, 1123, 1766, 1864, 2045, 2110, 2156, 2183, 2912
@@ -2469,20 +2469,20 @@ of citations entirely, choose \"None\"."
"Disposition-Notification-Options:" ; RFC 2298
"Disposition-Notification-To:" ; RFC 2298
"Distribution:" ; RFC 1036
- "DKIM-" ; http://antispam.yahoo.com/domainkeys
+ "DKIM-" ; https://en.wikipedia.org/wiki/DomainKeys_Identified_Mail
"DL-Expansion-History:" ; RFC 2156
- "DomainKey-" ; http://antispam.yahoo.com/domainkeys
+ "DomainKey-" ; https://en.wikipedia.org/wiki/DomainKeys_Identified_Mail
"DomainKey-Signature:"
"Encoding:" ; RFC 1505
"Envelope-to:"
- "Errors-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Errors-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Expires:" ; RFC 1036
"Expiry-Date:" ; RFC 2156
"Face:" ; Gnus Face header
"Followup-To:" ; RFC 1036
- "For-Approval:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "For-Comment:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "For-Handling:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "For-Approval:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "For-Comment:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "For-Handling:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Forwarded:" ; MH
"From " ; sendmail
"Generate-Delivery-Report:" ; RFC 2156
@@ -2493,12 +2493,12 @@ of citations entirely, choose \"None\"."
"Language:" ; RFC 2156
"Lines:" ; RFC 1036
"List-" ; RFC 2369, 2919
- "Mail-Copies-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "Mail-Followup-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Mail-Copies-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Mail-Followup-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Mail-from:" ; MH
- "Mail-Reply-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Mail-Reply-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Mailing-List:" ; Egroups/yahoogroups mailing list manager
- "Message-Content:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Message-Content:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Message-ID:" ; RFC 822 (or later)
"Message-Type:" ; RFC 2156
"Mime-Version" ; RFC 2045
@@ -2516,50 +2516,50 @@ of citations entirely, choose \"None\"."
"Original-Recipient:" ; RFC 2298
"Original-To:" ; mail to news
"Original-X-" ; mail to news
- "Origination-Client:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "Originator:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Origination-Client:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Originator:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"P1-Content-Type:" ; X400
"P1-Message-Id:" ; X400
"P1-Recipient:" ; X400
"Path:" ; RFC 1036
"Pics-Label:" ; W3C
- "Posted-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "Precedence:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Posted-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Precedence:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Prev-Resent" ; MH
"Prevent-NonDelivery-Report:" ; RFC 2156
"Priority:" ; RFC 2156
- "Read-Receipt-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Read-Receipt-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Received-SPF:" ; Gmail
"Received:" ; RFC 822 (or later)
"References:" ; RFC 822 (or later)
- "Registered-Mail-Reply-Requested-By:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Registered-Mail-Reply-Requested-By:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Remailed-" ; MH
- "Replaces:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Replaces:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Replied:" ; MH
"Resent-" ; RFC 822 (or later)
"Return-Path:" ; RFC 822 (or later)
- "Return-Receipt-Requested:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "Return-Receipt-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Return-Receipt-Requested:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Return-Receipt-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Seal-Send-Time:"
"See-Also:" ; H. Spencer: News Article Format and Transmission, June 1994
"Sensitivity:" ; RFC 2156, 2421
- "Speech-Act:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Speech-Act:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Status:" ; sendmail
"Supersedes:" ; H. Spencer: News Article Format and Transmission, June 1994
- "Telefax:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Telefax:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Thread-"
"Thread-Index:"
"Thread-Topic:"
- "Translated-By:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "Translation-Of:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Translated-By:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "Translation-Of:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"Ua-Content-Id:" ; X400
"Via:" ; MH
"X-Abuse-and-DMCA-"
"X-Abuse-Info:"
"X-Accept-Language:" ; Netscape/Mozilla
"X-Ack:"
- "X-ACL-Warn:" ; http://www.exim.org
- "X-Admin:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-ACL-Warn:" ; https://www.exim.org
+ "X-Admin:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Administrivia-To:"
"X-AMAZON" ; Amazon.com
"X-AnalysisOut:" ; Exchange
@@ -2582,8 +2582,8 @@ of citations entirely, choose \"None\"."
"X-BFI:"
"X-Bigfish:"
"X-Bogosity:" ; bogofilter
- "X-BPS1:" ; http://www.boggletools.com
- "X-BPS2:" ; http://www.boggletools.com
+ "X-BPS1:" ; http://www.boggletools.com [dead link?]
+ "X-BPS2:" ; http://www.boggletools.com [dead link?]
"X-Brightmail-Tracker:" ; Brightmail
"X-BrightmailFiltered:" ; Brightmail
"X-Bugzilla-" ; Bugzilla
@@ -2594,17 +2594,17 @@ of citations entirely, choose \"None\"."
"X-CanIt-Geo:" ; IEEE spam filter
"X-Cloudmark-SP-" ; Cloudmark (www.cloudmark.com)
"X-Comment:" ; AT&T Mailennium
- "X-Complaints-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Complaints-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Completed:"
- "X-Confirm-Reading-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Confirm-Reading-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Content-Filtered-By:"
"X-ContentStamp:" ; NetZero
- "X-Country-Chain:" ; http://www.declude.com/x-note.htm
+ "X-Country-Chain:" ; http://www.declude.com/x-note.htm [dead link?]
"X-Cr-Hashedpuzzle:"
"X-Cr-Puzzleid:"
"X-Cron-Env:"
"X-DCC-" ; SpamAssassin
- "X-Declude-" ; http://www.declude.com/x-note.htm
+ "X-Declude-" ; http://www.declude.com/x-note.htm [dead link?]
"X-Dedicated:"
"X-Delivered"
"X-Destination-ID:"
@@ -2619,40 +2619,40 @@ of citations entirely, choose \"None\"."
"X-EID:"
"X-ELNK-Trace:" ; Earthlink mailer
"X-EM-" ; Some ecommerce software
- "X-Email-Type-Id:" ; Paypal http://www.paypal.com
+ "X-Email-Type-Id:" ; Paypal https://www.paypal.com
"X-Enigmail-Version:"
"X-Envelope-Date:" ; GNU mailutils
- "X-Envelope-From:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Envelope-From:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Envelope-Sender:"
- "X-Envelope-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Envelope-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-EviteMessageId:" ; evite.com
"X-Evolution:" ; Evolution mail client
"X-ExtLoop"
- "X-Face:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Face:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Facebook" ; Facebook
"X-FB-SS:"
"X-fmx-"
"X-Folder:" ; Spam
"X-Forwarded-" ; Google+
"X-From-Line"
- "X-FuHaFi:" ; http://www.gmx.net/
+ "X-FuHaFi:" ; https://www.gmx.net/
"X-Generated-By:" ; launchpad.net
"X-Gmail-" ; Gmail
"X-Gnus-Mail-Source:" ; gnus
"X-Google-" ; Google mail
"X-Google-Sender-Auth:"
"X-Greylist:" ; milter-greylist-1.2.1
- "X-Habeas-" ; http://www.returnpath.net
+ "X-Habeas-" ; https://www.returnpath.net
"X-Hashcash:" ; hashcash
"X-Headers-End:" ; SpamCop
"X-HPL-"
"X-HR-"
"X-HTTP-UserAgent:"
"X-Hz" ; Hertz
- "X-Identity:" ; http://www.declude.com/x-note.htm
+ "X-Identity:" ; http://www.declude.com/x-note.htm [dead link?]
"X-IEEE-UCE-" ; IEEE spam filter
"X-Image-URL:"
- "X-IMAP:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-IMAP:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Info:" ; NTMail
"X-IronPort-" ; IronPort AV
"X-ISI-4-30-3-MailScanner:"
@@ -2662,15 +2662,15 @@ of citations entirely, choose \"None\"."
"X-Juno-" ; Juno
"X-Key:"
"X-Launchpad-" ; plaunchpad.net
- "X-List-Host:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-List-Host:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-List-Subscribe:" ; Unknown mailing list managers
"X-List-Unsubscribe:" ; Unknown mailing list managers
"X-Listprocessor-" ; ListProc(tm) by CREN
- "X-Listserver:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "X-Loop:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Listserver:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Loop:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Lrde-Mailscanner:"
"X-Lumos-SenderID:" ; Roving ConstantContact
- "X-mail_abuse_inquiries:" ; http://www.salesforce.com
+ "X-mail_abuse_inquiries:" ; https://www.salesforce.com
"X-Mail-from:" ; fastmail.fm
"X-MAIL-INFO:" ; NetZero
"X-Mailer_"
@@ -2683,28 +2683,28 @@ of citations entirely, choose \"None\"."
"X-Mailutils-Message-Id" ; GNU Mailutils
"X-Majordomo:" ; Majordomo mailing list manager
"X-Match:"
- "X-MaxCode-Template:" ; Paypal http://www.paypal.com
+ "X-MaxCode-Template:" ; Paypal https://www.paypal.com
"X-MB-Message-" ; AOL WebMail
"X-MDaemon-Deliver-To:"
"X-MDRemoteIP:"
- "X-ME-Bayesian:" ; http://www.newmediadevelopment.net/page.cfm/parent/Client-Area/content/Managing-spam/
+ "X-ME-Bayesian:" ; https://www.newmediadevelopment.net/page.cfm/parent/Client-Area/content/Managing-spam/
"X-Message-Id"
"X-Message-Type:"
"X-MessageWall-Score:" ; Unknown mailing list manager, AUC TeX
"X-MHE-Checksum:" ; Checksum added during index search
"X-MIME-Autoconverted:" ; sendmail
- "X-MIMEOLE:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/sendmail
+ "X-MIMEOLE:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/sendmail
"X-MIMETrack:"
"X-Mms-" ; T-Mobile pictures
"X-Mozilla-Status:" ; Netscape/Mozilla
"X-MS-" ; MS Outlook
"X-Msmail-" ; MS Outlook
- "X-MSMail-Priority" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-MSMail-Priority" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-MXL-Hash:"
"X-NAI-Spam-" ; Network Associates Inc. SpamKiller
"X-News:" ; News
- "X-Newsreader:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "X-No-Archive:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Newsreader:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-No-Archive:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Notes-Item:" ; Lotus Notes Domino structured header
"X-Notification-" ; Google+
"X-Notifications:" ; Google+
@@ -2713,7 +2713,7 @@ of citations entirely, choose \"None\"."
"X-ORBL:"
"X-Orcl-Content-Type:"
"X-Organization:"
- "X-Original-Arrival-Type:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Original-Arrival-Type:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Original-Complaints-To:"
"X-Original-Date:" ; SourceForge mailing list manager
"X-Original-To:"
@@ -2733,10 +2733,10 @@ of citations entirely, choose \"None\"."
"X-Provags-ID:"
"X-PSTN-"
"X-Qotd-" ; User added
- "X-RCPT-TO:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-RCPT-TO:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Received-Date:"
"X-Received:"
- "X-Report-Abuse-To:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Report-Abuse-To:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Request-"
"X-Resolved-to:" ; fastmail.fm
"X-Return-Path-Hint:" ; Roving ConstantContact
@@ -2753,12 +2753,12 @@ of citations entirely, choose \"None\"."
"X-SBRule:" ; Spam
"X-Scanned-By:"
"X-Sender-ID:" ; Google+
- "X-Sender:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-Sender:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Sendergroup:" ; Cisco Email Security (formerly IronPort; http://www.ironport.com)
"X-Server-Date:"
"X-Server-Uuid:"
"X-Service-Code:"
- "X-SFDC-" ; http://www.salesforce.com
+ "X-SFDC-" ; https://www.salesforce.com
"X-Sieve:" ; Sieve filtering
"X-SMFBL:"
"X-SMHeaderMap:"
@@ -2773,14 +2773,14 @@ of citations entirely, choose \"None\"."
"X-Submissions-To:"
"X-Sun-Charset:"
"X-Telecom-Digest"
- "X-TM-IMSS-Message-ID:" ; http://www.trendmicro.com
+ "X-TM-IMSS-Message-ID:" ; https://www.trendmicro.com
"X-Trace:"
"X-UID"
- "X-UIDL:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-UIDL:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-Unity"
"X-UNTD-" ; NetZero
- "X-URI:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "X-URL:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-URI:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-URL:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
"X-USANET-" ; usa.net
"X-Usenet-Provider"
"X-UserInfo1:"
@@ -2792,11 +2792,11 @@ of citations entirely, choose \"None\"."
"X-VSMLoop:" ; NTMail
"X-WebTV-Signature:"
"X-Wss-Id:" ; Worldtalk gateways
- "X-X-Sender:" ; http://people.dsv.su.se/~jpalme/ietf/mail-headers/
- "X-XPT-XSL-Name:" ; Paypal http://www.paypal.com
+ "X-X-Sender:" ; https://people.dsv.su.se/~jpalme/ietf/mail-headers/
+ "X-XPT-XSL-Name:" ; Paypal https://www.paypal.com
"X-xsi-"
- "X-XWALL-" ; http://www.dataenter.co.at/doc/xwall_undocumented_config.htm
- "X-Y-GMX-Trusted:" ; http://www.gmx.net/
+ "X-XWALL-" ; https://www.dataenter.co.at/doc/xwall_undocumented_config.htm
+ "X-Y-GMX-Trusted:" ; https://www.gmx.net/
"X-Yahoo"
"X-Yahoo-Newman-"
"X-YMail-"
@@ -3036,20 +3036,20 @@ supports it.
The first header field used, if present, is the Gnus-specific
\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and
XEmacs. For more information, see URL
-`http://quimby.gnus.org/circus/face/'. Next is the traditional
+`https://quimby.gnus.org/circus/face/'. Next is the traditional
\"X-Face:\" header field. The display of this field requires the
\"uncompface\" program (see URL
`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent
versions of XEmacs have internal support for \"X-Face:\" images. If
your version of XEmacs does not, then you'll need both \"uncompface\"
-and the x-face package (see URL `http://www.jpl.org/ftp/pub/elisp/').
+and the x-face package (see URL `https://www.jpl.org/ftp/pub/elisp/').
Finally, MH-E will display images referenced by the \"X-Image-URL:\"
header field if neither the \"Face:\" nor the \"X-Face:\" fields are
present. The display of the images requires \"wget\" (see URL
`https://www.gnu.org/software/wget/wget.html'), \"fetch\", or \"curl\"
to fetch the image and the \"convert\" program from the ImageMagick
-suite (see URL `http://www.imagemagick.org/'). Of the three header
+suite (see URL `https://www.imagemagick.org/'). Of the three header
fields this is the most efficient in terms of network usage since the
image doesn't need to be transmitted with every single mail.
@@ -3182,7 +3182,7 @@ folder, which is also available in `mh-current-folder'."
:package-version '(MH-E . "8.0"))
(defcustom-mh mh-annotate-msg-hook nil
- "Hook run whenever a message is sent and after the scan lines and message are annotated.
+ "Hook run when a message is sent and after annotating the scan lines and message.
Hook functions can access the current folder name with
`mh-current-folder' and obtain the message numbers of the
annotated messages with `mh-annotate-list'."
@@ -3195,7 +3195,7 @@ annotated messages with `mh-annotate-list'."
"Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding refile and delete requests.
Variables that are useful in this hook include `mh-delete-list',
-`mh-refile-list', `mh-blacklist', and `mh-whitelist' which can be
+`mh-refile-list', `mh-blocklist', and `mh-allowlist' which can be
used to see which changes will be made to the current folder,
`mh-current-folder'."
:type 'hook
@@ -3227,8 +3227,8 @@ before sending, add the `ispell-message' function."
:group 'mh-letter
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-blacklist-msg-hook nil
- "Hook run by \\<mh-letter-mode-map>\\[mh-junk-blacklist] after marking each message for blacklisting."
+(defcustom-mh mh-blocklist-msg-hook nil
+ "Hook run by \\<mh-letter-mode-map>\\[mh-junk-blocklist] after marking each message for blocklisting."
:type 'hook
:group 'mh-hooks
:group 'mh-show
@@ -3400,8 +3400,8 @@ sequence."
:group 'mh-sequences
:package-version '(MH-E . "6.0"))
-(defcustom-mh mh-whitelist-msg-hook nil
- "Hook run by \\<mh-letter-mode-map>\\[mh-junk-whitelist] after marking each message for whitelisting."
+(defcustom-mh mh-allowlist-msg-hook nil
+ "Hook run by \\<mh-letter-mode-map>\\[mh-junk-allowlist] after marking each message for allowlisting."
:type 'hook
:group 'mh-hooks
:group 'mh-show
@@ -3412,6 +3412,7 @@ sequence."
;;; Faces (:group 'mh-faces + group where faces described)
(if (boundp 'facemenu-unlisted-faces)
+ ;; This variable was removed in Emacs 22.1.
(add-to-list 'facemenu-unlisted-faces "^mh-"))
;; To add a new face:
@@ -3626,9 +3627,9 @@ specified colors."
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-blacklisted
+(defface-mh mh-folder-blocklisted
(mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number))))
- "Blacklisted message face."
+ "Blocklisted message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.4"))
@@ -3722,9 +3723,9 @@ format `mh-scan-format-nmh' and the regular expression
:group 'mh-folder
:package-version '(MH-E . "8.0"))
-(defface-mh mh-folder-whitelisted
+(defface-mh mh-folder-allowlisted
(mh-face-data 'mh-folder-refiled '((t (:inherit mh-folder-refiled))))
- "Whitelisted message face."
+ "Allowlisted message face."
:group 'mh-faces
:group 'mh-folder
:package-version '(MH-E . "8.4"))
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index dbea4762892..35277ae46a1 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -1,4 +1,4 @@
-;;; mh-folder.el --- MH-Folder mode
+;;; mh-folder.el --- MH-Folder mode -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc.
@@ -25,8 +25,6 @@
;; Mode for browsing folders
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -209,10 +207,10 @@ annotation.")
;; Use defalias to make sure the documented primary key bindings
;; appear in menu lists.
-(defalias 'mh-alt-show 'mh-show)
-(defalias 'mh-alt-refile-msg 'mh-refile-msg)
-(defalias 'mh-alt-send 'mh-send)
-(defalias 'mh-alt-visit-folder 'mh-visit-folder)
+(defalias 'mh-alt-show #'mh-show)
+(defalias 'mh-alt-refile-msg #'mh-refile-msg)
+(defalias 'mh-alt-send #'mh-send)
+(defalias 'mh-alt-visit-folder #'mh-visit-folder)
;; Save the "b" binding for a future `back'. Maybe?
(gnus-define-keys mh-folder-mode-map
@@ -280,7 +278,8 @@ annotation.")
(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map)
"?" mh-prefix-help
- "b" mh-junk-blacklist
+ "a" mh-junk-allowlist
+ "b" mh-junk-blocklist
"w" mh-junk-whitelist)
(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map)
@@ -388,7 +387,7 @@ annotation.")
(?K "[v]iew, [i]nline, with [e]xternal viewer; \n"
"[o]utput/save MIME part; save [a]ll parts; \n"
"[t]oggle buttons; [TAB] next; [SHIFT-TAB] previous")
- (?J "[b]lacklist, [w]hitelist message"))
+ (?J "[b]locklist, [a]llowlist message"))
"Key binding cheat sheet.
See `mh-set-help'.")
@@ -407,12 +406,12 @@ See `mh-set-help'.")
;; Marked for deletion
(list (concat mh-scan-deleted-msg-regexp ".*")
'(0 'mh-folder-deleted))
- ;; Marked for blacklisting
- (list (concat mh-scan-blacklisted-msg-regexp ".*")
- '(0 'mh-folder-blacklisted))
- ;; Marked for whitelisting
- (list (concat mh-scan-whitelisted-msg-regexp ".*")
- '(0 'mh-folder-whitelisted))
+ ;; Marked for blocklisting
+ (list (concat mh-scan-blocklisted-msg-regexp ".*")
+ '(0 'mh-folder-blocklisted))
+ ;; Marked for allowlisting
+ (list (concat mh-scan-allowlisted-msg-regexp ".*")
+ '(0 'mh-folder-allowlisted))
;; After subject
(list mh-scan-body-regexp
'(1 'mh-folder-body nil t))
@@ -618,8 +617,8 @@ perform the operation on all messages in that region.
'mh-showing-mode nil ; Show message also?
'mh-refile-list nil ; List of folder names in mh-seq-list
'mh-delete-list nil ; List of msgs nums to delete
- 'mh-blacklist nil ; List of messages to process as spam
- 'mh-whitelist nil ; List of messages to process as ham
+ 'mh-blocklist nil ; List of messages to process as spam
+ 'mh-allowlist nil ; List of messages to process as ham
'mh-seq-list nil ; Alist of (seq . msgs) nums
'mh-seen-list nil ; List of displayed messages
'mh-next-direction 'forward ; Direction to move to next message
@@ -650,15 +649,16 @@ perform the operation on all messages in that region.
(auto-save-mode -1)
(setq buffer-offer-save t)
(mh-make-local-hook (mh-write-file-functions))
- (add-hook (mh-write-file-functions) 'mh-execute-commands nil t)
+ (add-hook (mh-write-file-functions) #'mh-execute-commands nil t)
(make-local-variable 'revert-buffer-function)
(make-local-variable 'hl-line-mode) ; avoid pollution
(mh-funcall-if-exists hl-line-mode 1)
- (setq revert-buffer-function 'mh-undo-folder)
+ (setq revert-buffer-function #'mh-undo-folder)
(add-to-list 'minor-mode-alist '(mh-showing-mode " Show"))
- (easy-menu-add mh-folder-sequence-menu)
- (easy-menu-add mh-folder-message-menu)
- (easy-menu-add mh-folder-folder-menu)
+ (mh-do-in-xemacs
+ (easy-menu-add mh-folder-sequence-menu)
+ (easy-menu-add mh-folder-message-menu)
+ (easy-menu-add mh-folder-folder-menu))
(mh-inc-spool-make)
(mh-set-help mh-folder-mode-help-messages)
(if (and (featurep 'xemacs)
@@ -715,8 +715,8 @@ RANGE is read in interactive use."
(defun mh-execute-commands ()
"Perform outstanding operations\\<mh-folder-mode-map>.
-If you've marked messages to be refiled, deleted, blacklisted, or
-whitelisted and you want to go ahead and perform these operations
+If you've marked messages to be refiled, deleted, blocklisted, or
+allowlisted and you want to go ahead and perform these operations
on these messages, use this command. Many MH-E commands that may
affect the numbering of the messages (such as
\\[mh-rescan-folder] or \\[mh-pack-folder]) will ask if you want
@@ -1116,7 +1116,7 @@ called interactively."
(message "Destination folder: %s" (cdr mh-last-destination)))
(t
(mh-iterate-on-range msg range
- (apply 'mh-write-msg-to-file msg (cdr mh-last-destination)))
+ (apply #'mh-write-msg-to-file msg (cdr mh-last-destination)))
(mh-next-msg interactive-flag))))
;;;###mh-autoload
@@ -1189,16 +1189,16 @@ RANGE is read in interactive use."
(beginning-of-line)
(while (not (or (looking-at mh-scan-refiled-msg-regexp)
(looking-at mh-scan-deleted-msg-regexp)
- (looking-at mh-scan-blacklisted-msg-regexp)
- (looking-at mh-scan-whitelisted-msg-regexp)
+ (looking-at mh-scan-blocklisted-msg-regexp)
+ (looking-at mh-scan-allowlisted-msg-regexp)
(and (eq mh-next-direction 'forward) (bobp))
(and (eq mh-next-direction 'backward)
(save-excursion (forward-line) (eobp)))))
(forward-line (if (eq mh-next-direction 'forward) -1 1)))
(if (or (looking-at mh-scan-refiled-msg-regexp)
(looking-at mh-scan-deleted-msg-regexp)
- (looking-at mh-scan-blacklisted-msg-regexp)
- (looking-at mh-scan-whitelisted-msg-regexp))
+ (looking-at mh-scan-blocklisted-msg-regexp)
+ (looking-at mh-scan-allowlisted-msg-regexp))
(progn
(mh-undo-msg (mh-get-msg-num t))
(mh-maybe-show))
@@ -1530,7 +1530,7 @@ is updated."
(save-excursion
(when (eq major-mode 'mh-show-mode)
(set-buffer mh-show-folder-buffer))
- (or mh-delete-list mh-refile-list mh-blacklist mh-whitelist)))
+ (or mh-delete-list mh-refile-list mh-blocklist mh-allowlist)))
;;;###mh-autoload
(defun mh-set-folder-modified-p (flag)
@@ -1556,12 +1556,12 @@ after the commands are processed."
(folders-changed (list mh-current-folder))
(seq-map (and
(or (and mh-refile-list mh-refile-preserves-sequences-flag)
- (and mh-whitelist
- mh-whitelist-preserves-sequences-flag))
+ (and mh-allowlist
+ mh-allowlist-preserves-sequences-flag))
(mh-create-sequence-map mh-seq-list)))
(dest-map (and mh-refile-list mh-refile-preserves-sequences-flag
(make-hash-table)))
- (white-map (and mh-whitelist mh-whitelist-preserves-sequences-flag
+ (allow-map (and mh-allowlist mh-allowlist-preserves-sequences-flag
(make-hash-table))))
;; Remove invalid scan lines if we are in an index folder and then remove
;; the real messages
@@ -1605,53 +1605,53 @@ after the commands are processed."
;; Now delete messages
(cond (mh-delete-list
(setq redraw-needed-flag t)
- (apply 'mh-exec-cmd "rmm" folder
+ (apply #'mh-exec-cmd "rmm" folder
(mh-coalesce-msg-list mh-delete-list))
(mh-delete-scan-msgs mh-delete-list)
(setq mh-delete-list nil)))
- ;; Blacklist messages.
- (when mh-blacklist
- (let ((msg-list (mh-coalesce-msg-list mh-blacklist))
- (dest (mh-junk-blacklist-disposition)))
- (mh-junk-process-blacklist mh-blacklist)
+ ;; Blocklist messages.
+ (when mh-blocklist
+ (let ((msg-list (mh-coalesce-msg-list mh-blocklist))
+ (dest (mh-junk-blocklist-disposition)))
+ (mh-junk-process-blocklist mh-blocklist)
;; TODO I wonder why mh-exec-cmd is used instead of the following:
;; (mh-refile-a-msg nil (intern dest))
;; (mh-delete-a-msg nil)))
(if (null dest)
- (apply 'mh-exec-cmd "rmm" folder msg-list)
- (apply 'mh-exec-cmd "refile" "-src" folder dest msg-list)
+ (apply #'mh-exec-cmd "rmm" folder msg-list)
+ (apply #'mh-exec-cmd "refile" "-src" folder dest msg-list)
(push dest folders-changed))
(setq redraw-needed-flag t)
- (mh-delete-scan-msgs mh-blacklist)
- (setq mh-blacklist nil)))
+ (mh-delete-scan-msgs mh-blocklist)
+ (setq mh-blocklist nil)))
- ;; Whitelist messages.
- (when mh-whitelist
- (let ((msg-list (mh-coalesce-msg-list mh-whitelist))
+ ;; Allowlist messages.
+ (when mh-allowlist
+ (let ((msg-list (mh-coalesce-msg-list mh-allowlist))
(last (car (mh-translate-range mh-inbox "last"))))
- (mh-junk-process-whitelist mh-whitelist)
+ (mh-junk-process-allowlist mh-allowlist)
(apply #'mh-exec-cmd "refile" "-src" folder mh-inbox msg-list)
(push mh-inbox folders-changed)
(setq redraw-needed-flag t)
- (mh-delete-scan-msgs mh-whitelist)
- (when mh-whitelist-preserves-sequences-flag
- (clrhash white-map)
+ (mh-delete-scan-msgs mh-allowlist)
+ (when mh-allowlist-preserves-sequences-flag
+ (clrhash allow-map)
(cl-loop for i from (1+ (or last 0))
- for msg in (sort (copy-sequence mh-whitelist) #'<)
+ for msg in (sort (copy-sequence mh-allowlist) #'<)
do (cl-loop for seq-name in (gethash msg seq-map)
- do (push i (gethash seq-name white-map))))
+ do (push i (gethash seq-name allow-map))))
(maphash
#'(lambda (seq msgs)
;; Can't be run in background, since the current
;; folder is changed by mark this could lead to a
- ;; race condition with the next refile/whitelist.
+ ;; race condition with the next refile/allowlist.
(apply #'mh-exec-cmd "mark"
"-sequence" (symbol-name seq) mh-inbox
"-add" (mapcar #'(lambda(x) (format "%s" x))
(mh-coalesce-msg-list msgs))))
- white-map))
- (setq mh-whitelist nil)))
+ allow-map))
+ (setq mh-allowlist nil)))
;; Don't need to remove sequences since delete and refile do so.
;; Mark cur message
@@ -1702,7 +1702,7 @@ after the commands are processed."
(mh-recenter nil)))
;;;###mh-autoload
-(defun mh-make-folder-mode-line (&optional ignored)
+(defun mh-make-folder-mode-line (&optional _ignored)
"Set the fields of the mode line for a folder buffer.
The optional argument is now obsolete and IGNORED. It used to be
used to pass in what is now stored in the buffer-local variable
@@ -1962,10 +1962,10 @@ once when he kept statistics on his mail usage."
(setq message (mh-get-msg-num t)))
(if (looking-at mh-scan-refiled-msg-regexp)
(error "Message %d is refiled; undo refile before deleting" message))
- (if (looking-at mh-scan-blacklisted-msg-regexp)
- (error "Message %d is blacklisted; undo before deleting" message))
- (if (looking-at mh-scan-whitelisted-msg-regexp)
- (error "Message %d is whitelisted; undo before deleting" message))
+ (if (looking-at mh-scan-blocklisted-msg-regexp)
+ (error "Message %d is blocklisted; undo before deleting" message))
+ (if (looking-at mh-scan-allowlisted-msg-regexp)
+ (error "Message %d is allowlisted; undo before deleting" message))
(if (looking-at mh-scan-deleted-msg-regexp)
nil
(mh-set-folder-modified-p t)
@@ -1987,10 +1987,10 @@ be refiled."
(setq message (mh-get-msg-num t)))
(cond ((looking-at mh-scan-deleted-msg-regexp)
(error "Message %d is deleted; undo delete before moving" message))
- ((looking-at mh-scan-blacklisted-msg-regexp)
- (error "Message %d is blacklisted; undo before moving" message))
- ((looking-at mh-scan-whitelisted-msg-regexp)
- (error "Message %d is whitelisted; undo before moving" message))
+ ((looking-at mh-scan-blocklisted-msg-regexp)
+ (error "Message %d is blocklisted; undo before moving" message))
+ ((looking-at mh-scan-allowlisted-msg-regexp)
+ (error "Message %d is allowlisted; undo before moving" message))
((looking-at mh-scan-refiled-msg-regexp)
(if (y-or-n-p
(format "Message %d already refiled; copy to %s as well? "
@@ -2009,7 +2009,7 @@ be refiled."
(run-hooks 'mh-refile-msg-hook)))))
(defun mh-undo-msg (msg)
- "Undo the deletion, refile, black- or whitelisting of one MSG.
+ "Undo the deletion, refile, block- or allowlisting of one MSG.
If MSG is nil then act on the message at point"
(save-excursion
(if (numberp msg)
@@ -2018,10 +2018,10 @@ If MSG is nil then act on the message at point"
(setq msg (mh-get-msg-num t)))
(cond ((memq msg mh-delete-list)
(setq mh-delete-list (delq msg mh-delete-list)))
- ((memq msg mh-blacklist)
- (setq mh-blacklist (delq msg mh-blacklist)))
- ((memq msg mh-whitelist)
- (setq mh-whitelist (delq msg mh-whitelist)))
+ ((memq msg mh-blocklist)
+ (setq mh-blocklist (delq msg mh-blocklist)))
+ ((memq msg mh-allowlist)
+ (setq mh-allowlist (delq msg mh-allowlist)))
(t
(dolist (folder-msg-list mh-refile-list)
(setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list))))
diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el
index 309bcb4b49f..4a5e670c1ef 100644
--- a/lisp/mh-e/mh-funcs.el
+++ b/lisp/mh-e/mh-funcs.el
@@ -1,4 +1,4 @@
-;;; mh-funcs.el --- MH-E functions not everyone will use right away
+;;; mh-funcs.el --- MH-E functions not everyone will use right away -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
@@ -30,8 +30,6 @@
;; small support routines are needed, place them with the function;
;; otherwise, create a separate section for them.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -348,7 +346,7 @@ See `mh-store-msg' for a description of DIRECTORY."
(error "Error occurred during execution of %s" command)))))
;;;###mh-autoload
-(defun mh-undo-folder (&rest ignored)
+(defun mh-undo-folder (&rest _ignored)
"Undo all refiles and deletes in the current folder.
Arguments are IGNORED (for `revert-buffer')."
(interactive)
@@ -356,8 +354,8 @@ Arguments are IGNORED (for `revert-buffer')."
(yes-or-no-p "Undo all commands in folder? "))
(setq mh-delete-list nil
mh-refile-list nil
- mh-blacklist nil
- mh-whitelist nil
+ mh-blocklist nil
+ mh-allowlist nil
mh-seq-list nil
mh-next-direction 'forward)
(with-mh-folder-updating (nil)
diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el
index 6a9851662ab..cc60f7b6640 100644
--- a/lisp/mh-e/mh-gnus.el
+++ b/lisp/mh-e/mh-gnus.el
@@ -1,4 +1,4 @@
-;;; mh-gnus.el --- make MH-E compatible with various versions of Gnus
+;;; mh-gnus.el --- make MH-E compatible with various versions of Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2004, 2006-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -129,7 +127,7 @@
(unless default
(setq default (mml-content-disposition type filename)))
(let ((disposition (completing-read
- (format "Disposition (default %s): " default)
+ (format-prompt "Disposition" default)
'(("attachment") ("inline") (""))
nil t nil nil default)))
(if (not (equal disposition ""))
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index bd6f7b2f1df..ceede0d07cb 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -1,4 +1,4 @@
-;;; mh-identity.el --- multiple identify support for MH-E
+;;; mh-identity.el --- multiple identify support for MH-E -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -33,8 +33,6 @@
;; in MH-Letter mode. The command `mh-insert-identity' can be used
;; to manually insert an identity.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -50,7 +48,7 @@ This is normally set as part of an Identity in
(defvar mh-identity-menu nil
"The Identity menu.")
-(defalias 'mh-identity-make-menu-no-autoload 'mh-identity-make-menu)
+(defalias 'mh-identity-make-menu-no-autoload #'mh-identity-make-menu)
;;;###mh-autoload
(defun mh-identity-make-menu ()
@@ -71,11 +69,10 @@ See `mh-identity-add-menu'."
(mh-insert-auto-fields) mh-auto-fields-list]
"--")
- (mapcar (function
- (lambda (arg)
- `[,arg (mh-insert-identity ,arg) :style radio
- :selected (equal mh-identity-local ,arg)]))
- (mapcar 'car mh-identity-list))
+ (mapcar (lambda (arg)
+ `[,arg (mh-insert-identity ,arg) :style radio
+ :selected (equal mh-identity-local ,arg)])
+ (mapcar #'car mh-identity-list))
'(["None"
(mh-insert-identity "None") :style radio
:selected (not mh-identity-local)]
@@ -92,7 +89,7 @@ See `mh-identity-add-menu'."
"Add the current Identity menu.
See `mh-identity-make-menu'."
(if mh-identity-menu
- (easy-menu-add mh-identity-menu)))
+ (mh-do-in-xemacs (easy-menu-add mh-identity-menu))))
(defvar mh-identity-local nil
"Buffer-local variable that holds the identity currently in use.")
@@ -143,7 +140,7 @@ See `mh-identity-list'."
(completing-read
"Identity: "
(cons '("None")
- (mapcar 'list (mapcar 'car mh-identity-list)))
+ (mapcar #'list (mapcar #'car mh-identity-list)))
nil t default nil default))
(if (eq identity "None")
nil
@@ -172,8 +169,8 @@ See `mh-identity-list'."
"Identity: "
(if mh-identity-local
(cons '("None")
- (mapcar 'list (mapcar 'car mh-identity-list)))
- (mapcar 'list (mapcar 'car mh-identity-list)))
+ (mapcar #'list (mapcar #'car mh-identity-list)))
+ (mapcar #'list (mapcar #'car mh-identity-list)))
nil t)
nil))
diff --git a/lisp/mh-e/mh-inc.el b/lisp/mh-e/mh-inc.el
index 32f731799b9..83cfe4f99f1 100644
--- a/lisp/mh-e/mh-inc.el
+++ b/lisp/mh-e/mh-inc.el
@@ -1,4 +1,4 @@
-;;; mh-inc.el --- MH-E "inc" and separate mail spool handling
+;;; mh-inc.el --- MH-E "inc" and separate mail spool handling -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2004, 2006-2021 Free Software Foundation, Inc.
@@ -28,8 +28,6 @@
;; inc can also be used to incorporate mail from multiple spool files
;; into separate folders. See "C-h v mh-inc-spool-list".
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -58,19 +56,15 @@
(mh-inc-spool-generator folder spool)
(mh-inc-spool-def-key key folder))))))
-(defalias 'mh-inc-spool-make-no-autoload 'mh-inc-spool-make)
+(defalias 'mh-inc-spool-make-no-autoload #'mh-inc-spool-make)
(defun mh-inc-spool-generator (folder spool)
"Create a command to inc into FOLDER from SPOOL file."
- (let ((folder1 (make-symbol "folder"))
- (spool1 (make-symbol "spool")))
- (set folder1 folder)
- (set spool1 spool)
- (setf (symbol-function (intern (concat "mh-inc-spool-" folder)))
- `(lambda ()
- ,(format "Inc spool file %s into folder %s." spool folder)
- (interactive)
- (mh-inc-folder ,spool1 (concat "+" ,folder1))))))
+ (defalias (symbol-function (intern (concat "mh-inc-spool-" folder)))
+ (lambda ()
+ (:documentation (format "Inc spool file %s into folder %s." spool folder))
+ (interactive)
+ (mh-inc-folder spool (concat "+" folder)))))
(defun mh-inc-spool-def-key (key folder)
"Define a KEY in `mh-inc-spool-map' to inc FOLDER and collect help string."
diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el
index b49c6322492..6c3674811b0 100644
--- a/lisp/mh-e/mh-junk.el
+++ b/lisp/mh-e/mh-junk.el
@@ -1,4 +1,4 @@
-;;; mh-junk.el --- MH-E interface to anti-spam measures
+;;; mh-junk.el --- MH-E interface to anti-spam measures -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
@@ -26,16 +26,14 @@
;; Spam handling in MH-E.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
(require 'mh-scan)
;;;###mh-autoload
-(defun mh-junk-blacklist (range)
- "Blacklist RANGE as spam.
+(defun mh-junk-blocklist (range)
+ "Blocklist RANGE as spam.
This command trains the spam program in use (see the option
`mh-junk-program') with the content of RANGE and then handles the
@@ -47,44 +45,44 @@ read in interactive use.
For more information about using your particular spam fighting
program, see:
- - `mh-spamassassin-blacklist'
- - `mh-bogofilter-blacklist'
- - `mh-spamprobe-blacklist'"
- (interactive (list (mh-interactive-range "Blacklist")))
- (mh-iterate-on-range () range (mh-blacklist-a-msg nil))
- (if (looking-at mh-scan-blacklisted-msg-regexp)
+ - `mh-spamassassin-blocklist'
+ - `mh-bogofilter-blocklist'
+ - `mh-spamprobe-blocklist'"
+ (interactive (list (mh-interactive-range "Blocklist")))
+ (mh-iterate-on-range () range (mh-junk-blocklist-a-msg nil))
+ (if (looking-at mh-scan-blocklisted-msg-regexp)
(mh-next-msg)))
-(defun mh-blacklist-a-msg (message)
- "Blacklist MESSAGE.
-If MESSAGE is nil then the message at point is blacklisted.
-The hook `mh-blacklist-msg-hook' is called after you mark a message
-for blacklisting."
+(defun mh-junk-blocklist-a-msg (message)
+ "Blocklist MESSAGE.
+If MESSAGE is nil then the message at point is blocklisted.
+The hook `mh-blocklist-msg-hook' is called after you mark a message
+for blocklisting."
(save-excursion
(if (numberp message)
(mh-goto-msg message nil t)
(beginning-of-line)
(setq message (mh-get-msg-num t)))
(cond ((looking-at mh-scan-refiled-msg-regexp)
- (error "Message %d is refiled; undo refile before blacklisting"
+ (error "Message %d is refiled; undo refile before blocklisting"
message))
((looking-at mh-scan-deleted-msg-regexp)
- (error "Message %d is deleted; undo delete before blacklisting"
+ (error "Message %d is deleted; undo delete before blocklisting"
message))
- ((looking-at mh-scan-whitelisted-msg-regexp)
- (error "Message %d is whitelisted; undo before blacklisting"
+ ((looking-at mh-scan-allowlisted-msg-regexp)
+ (error "Message %d is allowlisted; undo before blocklisting"
message))
- ((looking-at mh-scan-blacklisted-msg-regexp) nil)
+ ((looking-at mh-scan-blocklisted-msg-regexp) nil)
(t
(mh-set-folder-modified-p t)
- (setq mh-blacklist (cons message mh-blacklist))
+ (setq mh-blocklist (cons message mh-blocklist))
(if (not (memq message mh-seen-list))
(setq mh-seen-list (cons message mh-seen-list)))
- (mh-notate nil mh-note-blacklisted mh-cmd-note)
- (run-hooks 'mh-blacklist-msg-hook)))))
+ (mh-notate nil mh-note-blocklisted mh-cmd-note)
+ (run-hooks 'mh-blocklist-msg-hook)))))
;;;###mh-autoload
-(defun mh-junk-blacklist-disposition ()
+(defun mh-junk-blocklist-disposition ()
"Determines the fate of the selected spam."
(cond ((null mh-junk-disposition) nil)
((equal mh-junk-disposition "") "+")
@@ -96,73 +94,76 @@ for blacklisting."
(t (concat "+" mh-junk-disposition))))
;;;###mh-autoload
-(defun mh-junk-process-blacklist (range)
- "Blacklist RANGE as spam.
+(defun mh-junk-process-blocklist (range)
+ "Blocklist RANGE as spam.
This command trains the spam program in use (see the option
`mh-junk-program') with the content of RANGE and then handles the
message(s) as specified by the option `mh-junk-disposition'."
- (let ((blacklist-func (nth 1 (assoc mh-junk-choice mh-junk-function-alist))))
- (unless blacklist-func
+ (let ((blocklist-func (nth 1 (assoc mh-junk-choice mh-junk-function-alist))))
+ (unless blocklist-func
(error "Customize `mh-junk-program' appropriately"))
(mh-iterate-on-range msg range
- (message "Blacklisting message %d..." msg)
- (funcall (symbol-function blacklist-func) msg)
- (message "Blacklisting message %d...done" msg))))
+ (funcall (symbol-function blocklist-func) msg))))
;;;###mh-autoload
(defun mh-junk-whitelist (range)
- "Whitelist RANGE as ham.
+ "Old name for `mh-junk-allowlist'; use \\[mh-junk-allowlist] instead."
+ (declare (obsolete mh-junk-allowlist "28.1"))
+ (interactive (list (mh-interactive-range "Allowlist")))
+ (mh-junk-allowlist range))
-This command reclassifies the RANGE as ham if it were incorrectly
+;;;###mh-autoload
+(defun mh-junk-allowlist (range)
+ "Allowlist RANGE as ham.
+
+This command reclassifies the RANGE as ham if it has been incorrectly
classified as spam (see the option `mh-junk-program'). It then
refiles the message into the \"+inbox\" folder.
Check the documentation of `mh-interactive-range' to see how
RANGE is read in interactive use."
- (interactive (list (mh-interactive-range "Whitelist")))
- (mh-iterate-on-range () range (mh-junk-whitelist-a-msg nil))
- (if (looking-at mh-scan-whitelisted-msg-regexp)
+ (interactive (list (mh-interactive-range "Allowlist")))
+ (mh-iterate-on-range () range (mh-junk-allowlist-a-msg nil))
+ (if (looking-at mh-scan-allowlisted-msg-regexp)
(mh-next-msg)))
-(defun mh-junk-whitelist-a-msg (message)
- "Whitelist MESSAGE.
-If MESSAGE is nil then the message at point is whitelisted. The
-hook `mh-whitelist-msg-hook' is called after you mark a message
-for whitelisting."
+(defun mh-junk-allowlist-a-msg (message)
+ "Allowlist MESSAGE.
+If MESSAGE is nil then the message at point is allowlisted. The
+hook `mh-allowlist-msg-hook' is called after you mark a message
+for allowlisting."
(save-excursion
(if (numberp message)
(mh-goto-msg message nil t)
(beginning-of-line)
(setq message (mh-get-msg-num t)))
(cond ((looking-at mh-scan-refiled-msg-regexp)
- (error "Message %d is refiled; undo refile before whitelisting"
+ (error "Message %d is refiled; undo refile before allowlisting"
message))
((looking-at mh-scan-deleted-msg-regexp)
- (error "Message %d is deleted; undo delete before whitelisting"
+ (error "Message %d is deleted; undo delete before allowlisting"
message))
- ((looking-at mh-scan-blacklisted-msg-regexp)
- (error "Message %d is blacklisted; undo before whitelisting"
+ ((looking-at mh-scan-blocklisted-msg-regexp)
+ (error "Message %d is blocklisted; undo before allowlisting"
message))
- ((looking-at mh-scan-whitelisted-msg-regexp) nil)
+ ((looking-at mh-scan-allowlisted-msg-regexp) nil)
(t
(mh-set-folder-modified-p t)
- (setq mh-whitelist (cons message mh-whitelist))
- (mh-notate nil mh-note-whitelisted mh-cmd-note)
- (run-hooks 'mh-whitelist-msg-hook)))))
+ (setq mh-allowlist (cons message mh-allowlist))
+ (mh-notate nil mh-note-allowlisted mh-cmd-note)
+ (run-hooks 'mh-allowlist-msg-hook)))))
;;;###mh-autoload
-(defun mh-junk-process-whitelist (range)
- "Whitelist RANGE as ham.
+(defun mh-junk-process-allowlist (range)
+ "Allowlist RANGE as ham.
This command reclassifies the RANGE as ham if it were incorrectly
classified as spam (see the option `mh-junk-program')."
- (let ((whitelist-func (nth 2 (assoc mh-junk-choice mh-junk-function-alist))))
- (unless whitelist-func
+ (let ((allowlist-func (nth 2 (assoc mh-junk-choice mh-junk-function-alist))))
+ (unless allowlist-func
(error "Customize `mh-junk-program' appropriately"))
(mh-iterate-on-range msg range
- (message "Whitelisting message %d..." msg)
- (funcall (symbol-function whitelist-func) msg)
- (message "Whitelisting message %d...done" msg))))
+ (funcall (symbol-function allowlist-func) msg))))
@@ -172,12 +173,12 @@ classified as spam (see the option `mh-junk-program')."
(defvar mh-sa-learn-executable (executable-find "sa-learn"))
;;;###mh-autoload
-(defun mh-spamassassin-blacklist (msg)
- "Blacklist MSG with SpamAssassin.
+(defun mh-spamassassin-blocklist (msg)
+ "Blocklist MSG with SpamAssassin.
SpamAssassin is one of the more popular spam filtering programs.
Get it from your local distribution or from the SpamAssassin web
-site at URL `http://spamassassin.org/'.
+site at URL `https://spamassassin.apache.org/'.
To use SpamAssassin, add the following recipes to
\".procmailrc\":
@@ -198,7 +199,7 @@ To use SpamAssassin, add the following recipes to
* ^X-Spam-Status: Yes
spam/.
-If you don't use \"spamc\", use \"spamassassin -P -a\".
+If you don't use \"spamc\", use \"spamassassin\".
Note that one of the recipes above throws away messages with a
score greater than or equal to 10. Here's how you can determine a
@@ -221,22 +222,22 @@ rules-based filters is a plethora of false positives so it is
worthwhile to check.
If SpamAssassin classifies a message incorrectly, or is unsure,
-you can use the MH-E commands \\[mh-junk-blacklist] and
-\\[mh-junk-whitelist].
+you can use the MH-E commands \\[mh-junk-blocklist] and
+\\[mh-junk-allowlist].
-The command \\[mh-junk-blacklist] adds a \"blacklist_from\" entry
+The command \\[mh-junk-blocklist] adds a \"blacklist_from\" entry
to \"~/spamassassin/user_prefs\", deletes the message, and sends
the message to the Razor, so that others might not see this spam.
If the \"sa-learn\" command is available, the message is also
recategorized as spam.
-The command \\[mh-junk-whitelist] adds a \"whitelist_from\" rule
+The command \\[mh-junk-allowlist] adds a \"whitelist_from\" rule
to the \"~/.spamassassin/user_prefs\" file. If the \"sa-learn\"
command is available, the message is also recategorized as ham.
Over time, you'll observe that the same host or domain occurs
repeatedly in the \"blacklist_from\" entries, so you might think
-that you could avoid future spam by blacklisting all mail from a
+that you could avoid future spam by blocklisting all mail from a
particular domain. The utility function
`mh-spamassassin-identify-spammers' helps you do precisely that.
This function displays a frequency count of the hosts and domains
@@ -245,35 +246,26 @@ in the \"blacklist_from\" entries from the last blank line in
information can be used so that you can replace multiple
\"blacklist_from\" entries with a single wildcard entry such as:
- blacklist_from *@*amazingoffersdirect2u.com
-
-In versions of SpamAssassin (2.50 and on) that support a Bayesian
-classifier, \\[mh-junk-blacklist] uses the program \"sa-learn\"
-to recategorize the message as spam. Neither MH-E, nor
-SpamAssassin, rebuilds the database after adding words, so you
-will need to run \"sa-learn --rebuild\" periodically. This can be
-done by adding the following to your crontab:
-
- 0 * * * * sa-learn --rebuild > /dev/null 2>&1"
+ blacklist_from *@*amazingoffersdirect2u.com"
(unless mh-spamassassin-executable
(error "Unable to find the spamassassin executable"))
(let ((current-folder mh-current-folder)
(msg-file (mh-msg-filename msg mh-current-folder))
(sender))
- (message "Reporting message %d..." msg)
+ (message "Reporting message %d as spam with spamassassin..." msg)
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-spamassassin-executable msg-file mh-junk-background nil
- ;;"--report" "--remove-from-whitelist"
- "-r" "-R") ; spamassassin V2.20
+ ;; -R removes from allowlist
+ "--report" "-R")
(when mh-sa-learn-executable
- (message "Recategorizing message %d as spam..." msg)
+ (message "Recategorizing message %d as spam with sa-learn..." msg)
(mh-truncate-log-buffer)
(call-process mh-sa-learn-executable msg-file mh-junk-background nil
- "--single" "--spam" "--local" "--no-rebuild")))
- (message "Blacklisting sender of message %d..." msg)
+ "--spam" "--local" "--no-sync")))
+ (message "Blocklisting sender of message %d..." msg)
(with-current-buffer (get-buffer-create mh-temp-buffer)
(erase-buffer)
(call-process (expand-file-name mh-scan-prog mh-progs)
@@ -285,18 +277,18 @@ done by adding the following to your crontab:
(progn
(setq sender (match-string 0))
(mh-spamassassin-add-rule "blacklist_from" sender)
- (message "Blacklisting sender of message %d...done" msg))
- (message "Blacklisting sender of message %d...not done (from my address)" msg)))))
+ (message "Blocklisting sender of message %d...done" msg))
+ (message "Blocklisting sender of message %d...not done (from my address)" msg)))))
;;;###mh-autoload
-(defun mh-spamassassin-whitelist (msg)
- "Whitelist MSG with SpamAssassin.
+(defun mh-spamassassin-allowlist (msg)
+ "Allowlist MSG with SpamAssassin.
-The \\[mh-junk-whitelist] command adds a \"whitelist_from\" rule to
+The \\[mh-junk-allowlist] command adds a \"whitelist_from\" rule to
the \"~/.spamassassin/user_prefs\" file. If the \"sa-learn\" command
is available, the message is also recategorized as ham.
-See `mh-spamassassin-blacklist' for more information."
+See `mh-spamassassin-blocklist' for more information."
(unless mh-spamassassin-executable
(error "Unable to find the spamassassin executable"))
(let ((msg-file (mh-msg-filename msg mh-current-folder))
@@ -306,27 +298,28 @@ See `mh-spamassassin-blacklist' for more information."
(erase-buffer)
(message "Removing spamassassin markup from message %d..." msg)
(call-process mh-spamassassin-executable msg-file t nil
- ;; "--remove-markup"
- "-d") ; spamassassin V2.20
+ "--remove-markup")
(if show-buffer
(kill-buffer show-buffer))
(write-file msg-file)
(when mh-sa-learn-executable
- (message "Recategorizing message %d as ham..." msg)
+ (message "Recategorizing message %d as ham with sa-learn..." msg)
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-sa-learn-executable msg-file mh-junk-background nil
- "--single" "--ham" "--local" "--no-rebuild")))
- (message "Whitelisting sender of message %d..." msg)
+ "--ham" "--local" "--no-sync")))
+ (message "Allowlisting sender of message %d..." msg)
(setq from
(car (mh-funcall-if-exists
ietf-drums-parse-address (mh-get-header-field "From:"))))
(kill-buffer nil)
- (unless (or (null from) (equal from ""))
- (mh-spamassassin-add-rule "whitelist_from" from))
- (message "Whitelisting sender of message %d...done" msg))))
+ (if (or (null from) (equal from ""))
+ (message "Allowlisting sender of message %d...%s"
+ msg "not done (cannot identify sender)")
+ (mh-spamassassin-add-rule "whitelist_from" from)
+ (message "Allowlisting sender of message %d...done" msg)))))
(defun mh-spamassassin-add-rule (rule body)
"Add a new rule to \"~/.spamassassin/user_prefs\".
@@ -396,8 +389,8 @@ information can be used so that you can replace multiple
(defvar mh-bogofilter-executable (executable-find "bogofilter"))
;;;###mh-autoload
-(defun mh-bogofilter-blacklist (msg)
- "Blacklist MSG with bogofilter.
+(defun mh-bogofilter-blocklist (msg)
+ "Blocklist MSG with bogofilter.
Bogofilter is a Bayesian spam filtering program. Get it from your
local distribution or from the bogofilter web site at URL
@@ -434,7 +427,7 @@ To use bogofilter, add the following recipes to \".procmailrc\":
spam/unsure/.
If bogofilter classifies a message incorrectly, or is unsure, you can
-use the MH-E commands \\[mh-junk-blacklist] and \\[mh-junk-whitelist]
+use the MH-E commands \\[mh-junk-blocklist] and \\[mh-junk-allowlist]
to update bogofilter's training.
The \"Bogofilter FAQ\" suggests that you run the following
@@ -447,28 +440,32 @@ occasionally to shrink the database:
The \"Bogofilter tuning HOWTO\" describes how you can fine-tune Bogofilter."
(unless mh-bogofilter-executable
(error "Unable to find the bogofilter executable"))
+ (message "Blocklisting message %d with bogofilter..." msg)
(let ((msg-file (mh-msg-filename msg mh-current-folder)))
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-bogofilter-executable msg-file mh-junk-background
- nil "-s"))))
+ nil "-s")
+ (message "Blocklisting message %d with bogofilter...done" msg))))
;;;###mh-autoload
-(defun mh-bogofilter-whitelist (msg)
- "Whitelist MSG with bogofilter.
+(defun mh-bogofilter-allowlist (msg)
+ "Allowlist MSG with bogofilter.
-See `mh-bogofilter-blacklist' for more information."
+See `mh-bogofilter-blocklist' for more information."
(unless mh-bogofilter-executable
(error "Unable to find the bogofilter executable"))
+ (message "Allowlisting message %d with bogofilter..." msg)
(let ((msg-file (mh-msg-filename msg mh-current-folder)))
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-bogofilter-executable msg-file mh-junk-background
- nil "-n"))))
+ nil "-n")
+ (message "Allowlisting message %d with bogofilter...done" msg))))
@@ -477,8 +474,8 @@ See `mh-bogofilter-blacklist' for more information."
(defvar mh-spamprobe-executable (executable-find "spamprobe"))
;;;###mh-autoload
-(defun mh-spamprobe-blacklist (msg)
- "Blacklist MSG with SpamProbe.
+(defun mh-spamprobe-blocklist (msg)
+ "Blocklist MSG with SpamProbe.
SpamProbe is a Bayesian spam filtering program. Get it from your
local distribution or from the SpamProbe web site at URL
@@ -501,32 +498,36 @@ To use SpamProbe, add the following recipes to \".procmailrc\":
spam/.
If SpamProbe classifies a message incorrectly, you can use the
-MH-E commands \\[mh-junk-blacklist] and \\[mh-junk-whitelist] to
+MH-E commands \\[mh-junk-blocklist] and \\[mh-junk-allowlist] to
update SpamProbe's training."
(unless mh-spamprobe-executable
(error "Unable to find the spamprobe executable"))
+ (message "Blocklisting message %d with spamprobe..." msg)
(let ((msg-file (mh-msg-filename msg mh-current-folder)))
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-spamprobe-executable msg-file mh-junk-background
- nil "spam"))))
+ nil "spam")
+ (message "Blocklisting message %d with spamprobe...done" msg))))
;;;###mh-autoload
-(defun mh-spamprobe-whitelist (msg)
- "Whitelist MSG with SpamProbe.
+(defun mh-spamprobe-allowlist (msg)
+ "Allowlist MSG with SpamProbe.
-See `mh-spamprobe-blacklist' for more information."
+See `mh-spamprobe-blocklist' for more information."
(unless mh-spamprobe-executable
(error "Unable to find the spamprobe executable"))
+ (message "Allowlisting message %d with spamprobe..." msg)
(let ((msg-file (mh-msg-filename msg mh-current-folder)))
(mh-truncate-log-buffer)
;; Put call-process output in log buffer if we are saving it
;; (this happens if mh-junk-background is t).
(with-current-buffer mh-log-buffer
(call-process mh-spamprobe-executable msg-file mh-junk-background
- nil "good"))))
+ nil "good")
+ (message "Allowlisting message %d with spamprobe...done" msg))))
(provide 'mh-junk)
diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index 359d4603183..ae5b80d5807 100644
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -1,4 +1,4 @@
-;;; mh-letter.el --- MH-Letter mode
+;;; mh-letter.el --- MH-Letter mode -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -31,8 +31,6 @@
;; mh-utils.el. That will help prevent the loading of this file until
;; a message is actually composed.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -330,19 +328,19 @@ order).
(t
;; ...or the header only
(setq font-lock-defaults '((mh-show-font-lock-keywords) t))))
- (easy-menu-add mh-letter-menu)
+ (mh-do-in-xemacs (easy-menu-add mh-letter-menu))
;; Maybe we want to use the existing Mail menu from mail-mode in
;; 9.0; in the mean time, let's remove it since the redundancy will
;; only produce confusion.
- (define-key mh-letter-mode-map [menu-bar mail] 'undefined)
+ (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)
+ #'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)
- (setq auto-fill-function 'mh-auto-fill-for-letter)))
+ (setq auto-fill-function #'mh-auto-fill-for-letter)))
@@ -390,10 +388,7 @@ This command leaves the mark before the letter and point after it."
(or mh-sent-from-msg (nth 0 (mh-translate-range folder "cur")))
(nth 0 (mh-translate-range folder "cur"))))
(message
- (read-string (concat "Message number"
- (or (and default
- (format " (default %d): " default))
- ": "))
+ (read-string (format-prompt "Message number" default)
nil nil
(if (numberp default)
(int-to-string default)
@@ -851,7 +846,7 @@ body."
(forward-line)))))
;;;###mh-autoload
-(defun mh-position-on-field (field &optional ignored)
+(defun mh-position-on-field (field &optional _ignored)
"Move to the end of the FIELD in the header.
Move to end of entire header if FIELD not found.
Returns non-nil if FIELD was found.
diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el
index 1edcfe372a9..39cf7c5d271 100644
--- a/lisp/mh-e/mh-limit.el
+++ b/lisp/mh-e/mh-limit.el
@@ -1,4 +1,4 @@
-;;; mh-limit.el --- MH-E display limits
+;;; mh-limit.el --- MH-E display limits -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2003, 2006-2021 Free Software Foundation, Inc.
@@ -25,8 +25,6 @@
;; "Poor man's threading" by psg.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -148,7 +146,7 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
"Put all following messages with same subject in sequence 'subject.
If arg ALL is t, move to beginning of folder buffer to collect all
messages.
-If arg ALL is nil, collect only messages fron current one on forward.
+If arg ALL is nil, collect only messages from current one on forward.
Return number of messages put in the sequence:
@@ -198,7 +196,7 @@ It would be desirable to avoid hard-coding this.")
This function only works with an unthreaded folder. If arg ALL is
t, move to beginning of folder buffer to collect all messages. If
-arg ALL is nil, collect only messages fron current one on
+arg ALL is nil, collect only messages from current one on
forward.
Return number of messages put in the sequence:
@@ -237,7 +235,7 @@ Return number of messages put in the sequence:
(setq list (cons (mh-get-msg-num t) list)))
(if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
;; sort the result into a sequence
- (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
+ (let ((sorted-list (sort (copy-sequence list) #'mh-lessp)))
(while sorted-list
(mh-add-msgs-to-seq (car sorted-list) 'subject nil)
(setq sorted-list (cdr sorted-list)))
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index 7bdf743fc42..ef702525b7b 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -1,4 +1,4 @@
-;;; mh-mime.el --- MH-E MIME support
+;;; mh-mime.el --- MH-E MIME support -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
@@ -36,8 +36,6 @@
;; MIME option to mh-forward command to move to content-description
;; insertion point.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -190,9 +188,9 @@ Set from last use.")
;; XEmacs doesn't care.
(set-keymap-parent map mh-show-mode-map))
(mh-do-in-gnu-emacs
- (define-key map [mouse-2] 'mh-push-button))
+ (define-key map [mouse-2] #'mh-push-button))
(mh-do-in-xemacs
- (define-key map '(button2) 'mh-push-button))
+ (define-key map '(button2) #'mh-push-button))
(dolist (c mh-mime-button-commands)
(define-key map (cadr c) (car c)))
map))
@@ -214,11 +212,11 @@ Set from last use.")
(let ((map (make-sparse-keymap)))
(unless (>= (string-to-number emacs-version) 21)
(set-keymap-parent map mh-show-mode-map))
- (define-key map "\r" 'mh-press-button)
+ (define-key map "\r" #'mh-press-button)
(mh-do-in-gnu-emacs
- (define-key map [mouse-2] 'mh-push-button))
+ (define-key map [mouse-2] #'mh-push-button))
(mh-do-in-xemacs
- (define-key map '(button2) 'mh-push-button))
+ (define-key map '(button2) #'mh-push-button))
map))
@@ -259,9 +257,7 @@ usually reads the file \"/etc/mailcap\"."
(methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x))))
(mailcap-mime-info type 'all)))
(def (caar methods))
- (prompt (format "Viewer%s: " (if def
- (format " (default %s)" def)
- "")))
+ (prompt (format-prompt "Viewer" def))
(method (completing-read prompt methods nil nil nil nil def))
(folder mh-show-folder-buffer)
(buffer-read-only nil))
@@ -395,9 +391,9 @@ do the work."
((and (or prompt
(equal t mh-mime-save-parts-default-directory))
mh-mime-save-parts-directory)
- (read-directory-name (format
- "Store in directory (default %s): "
- mh-mime-save-parts-directory)
+ (read-directory-name (format-prompt
+ "Store in directory"
+ mh-mime-save-parts-directory)
"" mh-mime-save-parts-directory t ""))
((stringp mh-mime-save-parts-default-directory)
mh-mime-save-parts-default-directory)
@@ -413,7 +409,7 @@ do the work."
(cd directory)
(setq mh-mime-save-parts-directory directory)
(let ((initial-size (mh-truncate-log-buffer)))
- (apply 'call-process
+ (apply #'call-process
(expand-file-name command mh-progs) nil t nil
(mh-list-to-string (list folder msg "-auto"
(if (not (mh-variant-p 'nmh))
@@ -452,7 +448,7 @@ decoding the same message multiple times."
(let ((b (point))
(clean-message-header mh-clean-message-header-flag)
(invisible-headers mh-invisible-header-fields-compiled)
- (visible-headers nil))
+ ) ;; (visible-headers nil)
(save-excursion
(save-restriction
(narrow-to-region b b)
@@ -474,7 +470,7 @@ decoding the same message multiple times."
(cond (clean-message-header
(mh-clean-msg-header (point-min)
invisible-headers
- visible-headers)
+ nil) ;; visible-headers
(goto-char (point-min)))
(t
(mh-start-of-uncleaned-message)))
@@ -489,15 +485,11 @@ decoding the same message multiple times."
(mh-display-emphasis)
(mm-handle-set-undisplayer
handle
- `(lambda ()
- (let (buffer-read-only)
- (if (fboundp 'remove-specifier)
- ;; This is only valid on XEmacs.
- (mapcar (lambda (prop)
- (remove-specifier
- (face-property 'default prop) (current-buffer)))
- '(background background-pixmap foreground)))
- (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
+ (let ((beg (point-min-marker))
+ (end (point-max-marker)))
+ (lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region beg end)))))))))
;;;###mh-autoload
(defun mh-decode-message-header ()
@@ -783,7 +775,7 @@ This is only useful if a Content-Disposition header is not present."
(funcall media-test handle) ; Since mm-inline-large-images is T,
; this only tells us if the image is
; something that emacs can display
- (let* ((image (mm-get-image handle)))
+ (let ((image (mm-get-image handle)))
(or (mh-do-in-xemacs
(and (mh-funcall-if-exists glyphp image)
(< (glyph-width image)
@@ -792,7 +784,7 @@ This is only useful if a Content-Disposition header is not present."
(or mh-max-inline-image-height
(window-pixel-height)))))
(mh-do-in-gnu-emacs
- (let ((size (mh-funcall-if-exists image-size image)))
+ (let ((size (and (fboundp 'image-size) (image-size image))))
(and size
(< (cdr size) (or mh-max-inline-image-height
(1- (window-height))))
@@ -1225,7 +1217,7 @@ The option `mh-compose-insertion' controls what type of tags are inserted."
t)
t t)))
(list description folder range)))
- (let ((messages (mapconcat 'identity (mh-list-to-string range) " ")))
+ (let ((messages (mapconcat #'identity (mh-list-to-string range) " ")))
(dolist (message (mh-translate-range folder messages))
(if (equal mh-compose-insertion 'mml)
(mh-mml-forward-message description folder (format "%s" message))
@@ -1258,11 +1250,7 @@ See also \\[mh-mh-to-mime]."
(interactive (list
(mml-minibuffer-read-description)
(mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
- (read-string (concat "Messages"
- (if (numberp mh-sent-from-msg)
- (format " (default %d): "
- mh-sent-from-msg)
- ": ")))))
+ (read-string (format-prompt "Messages" mh-sent-from-msg))))
(beginning-of-line)
(insert "#forw [")
(and description
@@ -1596,7 +1584,7 @@ the possible security methods (see `mh-mml-method-default')."
(if current-prefix-arg
(let ((def (or (car mh-mml-cryptographic-method-history)
mh-mml-method-default)))
- (completing-read (format "Method (default %s): " def)
+ (completing-read (format-prompt "Method" def)
'(("pgp") ("pgpmime") ("smime"))
nil t nil 'mh-mml-cryptographic-method-history def))
mh-mml-method-default))
@@ -1725,14 +1713,14 @@ a type (see `mailcap-mime-types').
Optional argument DEFAULT is returned if a type isn't entered."
(mailcap-parse-mimetypes)
(let* ((default (or default
- (mm-default-file-encoding filename)
+ (mm-default-file-type filename)
"application/octet-stream"))
(probed-type (mh-file-mime-type filename))
(type (or (and (not (equal probed-type "application/octet-stream"))
probed-type)
(completing-read
- (format "Content type (default %s): " default)
- (mapcar 'list (mailcap-mime-types))))))
+ (format-prompt "Content type" default)
+ (mapcar #'list (mailcap-mime-types))))))
(if (not (equal type ""))
type
default)))
diff --git a/lisp/mh-e/mh-print.el b/lisp/mh-e/mh-print.el
index 513a1bc953d..2074ff6f8f3 100644
--- a/lisp/mh-e/mh-print.el
+++ b/lisp/mh-e/mh-print.el
@@ -1,4 +1,4 @@
-;;; mh-print.el --- MH-E printing support
+;;; mh-print.el --- MH-E printing support -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -207,8 +205,9 @@ Consider using \\[mh-ps-print-msg] instead."
;; Print scan listing if we have more than one message.
(if (> (length msgs) 1)
(let* ((msgs-string
- (mapconcat 'identity (mh-list-to-string
- (mh-coalesce-msg-list msgs)) " "))
+ (mapconcat #'identity (mh-list-to-string
+ (mh-coalesce-msg-list msgs))
+ " "))
(lpr-command
(format mh-lpr-command-format
(cond ((listp range)
diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el
index cec331389b0..10235209dce 100644
--- a/lisp/mh-e/mh-scan.el
+++ b/lisp/mh-e/mh-scan.el
@@ -1,4 +1,4 @@
-;;; mh-scan.el --- MH-E scan line constants and utilities
+;;; mh-scan.el --- MH-E scan line constants and utilities -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -27,8 +27,6 @@
;; This file contains constants and a few functions for interpreting
;; scan lines.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -115,8 +113,8 @@ expression which matches the body text as in the default of
not correct, the body fragment will not be highlighted with the
face `mh-folder-body'.")
-(defvar mh-scan-blacklisted-msg-regexp "^\\( *[0-9]+\\)B"
- "This regular expression matches blacklisted (spam) messages.
+(defvar mh-scan-blocklisted-msg-regexp "^\\( *[0-9]+\\)B"
+ "This regular expression matches blocklisted (spam) messages.
It must match from the beginning of the line. Note that the
default setting of `mh-folder-font-lock-keywords' expects this
@@ -127,9 +125,9 @@ matches the message number as in the default of
This expression includes the leading space within parenthesis
since it looks better to highlight it as well. The highlighting
-is done with the face `mh-folder-blacklisted'. This regular
+is done with the face `mh-folder-blocklisted'. This regular
expression should be correct as it is needed by non-fontification
-functions. See also `mh-note-blacklisted'.")
+functions. See also `mh-note-blocklisted'.")
(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*"
"This regular expression matches the current message.
@@ -297,21 +295,21 @@ non-fontification functions.")
This is used to eliminate error messages that are occasionally
produced by \"inc\".")
-(defvar mh-scan-whitelisted-msg-regexp "^\\( *[0-9]+\\)W"
- "This regular expression matches whitelisted (non-spam) messages.
+(defvar mh-scan-allowlisted-msg-regexp "^\\( *[0-9]+\\)A"
+ "This regular expression matches allowlisted (non-spam) messages.
It must match from the beginning of the line. Note that the
default setting of `mh-folder-font-lock-keywords' expects this
expression to contain at least one parenthesized expression which
matches the message number as in the default of
- \"^\\\\( *[0-9]+\\\\)W\".
+ \"^\\\\( *[0-9]+\\\\)A\".
This expression includes the leading space within parenthesis
since it looks better to highlight it as well. The highlighting
-is done with the face `mh-folder-whitelisted'. This regular
+is done with the face `mh-folder-allowlisted'. This regular
expression should be correct as it is needed by non-fontification
-functions. See also `mh-note-whitelisted'.")
+functions. See also `mh-note-allowlisted'.")
@@ -335,8 +333,8 @@ This column will have one of the values: \" \", \"^\", \"D\", \"B\", \"W\", \"+\
\" \" is the default value,
\"^\" is the `mh-note-refiled' character,
\"D\" is the `mh-note-deleted' character,
- \"B\" is the `mh-note-blacklisted' character,
- \"W\" is the `mh-note-whitelisted' character, and
+ \"B\" is the `mh-note-blocklisted' character,
+ \"A\" is the `mh-note-allowlisted' character, and
\"+\" is the `mh-note-cur' character.")
(defvar mh-scan-destination-width 1
@@ -401,9 +399,9 @@ This column will only ever have spaces in it.")
;; Alphabetical.
-(defvar mh-note-blacklisted ?B
- "Messages that have been blacklisted are marked by this character.
-See also `mh-scan-blacklisted-msg-regexp'.")
+(defvar mh-note-blocklisted ?B
+ "Messages that have been blocklisted are marked by this character.
+See also `mh-scan-blocklisted-msg-regexp'.")
(defvar mh-note-cur ?+
"The current message (in MH, not in MH-E) is marked by this character.
@@ -438,9 +436,9 @@ See also `mh-scan-refiled-msg-regexp'.")
Messages in the \"search\" sequence are marked by this character as
well.")
-(defvar mh-note-whitelisted ?W
- "Messages that have been whitelisted are marked by this character.
-See also `mh-scan-whitelisted-msg-regexp'.")
+(defvar mh-note-allowlisted ?A
+ "Messages that have been allowlisted are marked by this character.
+See also `mh-scan-allowlisted-msg-regexp'.")
@@ -497,7 +495,7 @@ with `mh-scan-msg-format-string'."
(width 0))
(with-current-buffer tmp-buffer
(erase-buffer)
- (apply 'call-process
+ (apply #'call-process
(expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
(list folder "last" "-format" "%(msg)"))
(goto-char (point-min))
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index 957a81b6055..e03c9dc83f7 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -1,4 +1,4 @@
-;;; mh-search --- MH-Search mode
+;;; mh-search.el --- MH-Search mode -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
@@ -39,8 +39,6 @@
;; documentation will direct you to the specific instructions for
;; your particular searcher.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -274,23 +272,23 @@ folder containing the index search results."
t)))
;; Copy the search results over.
- (maphash #'(lambda (folder msgs)
- (let ((cur (car (mh-translate-range folder "cur")))
- (msgs (sort (cl-loop
- for msg being the hash-keys of msgs
- collect msg)
- #'<)))
- (mh-exec-cmd "refile" msgs "-src" folder
- "-link" index-folder)
- ;; Restore cur to old value, that refile changed
- (when cur
- (mh-exec-cmd-quiet nil "mark" folder "-add" "-zero"
- "-sequence"
- "cur" (format "%s" cur)))
- (cl-loop for msg in msgs
- do (cl-incf result-count)
- (setf (gethash result-count origin-map)
- (cons folder msg)))))
+ (maphash (lambda (folder msgs)
+ (let ((cur (car (mh-translate-range folder "cur")))
+ (msgs (sort (cl-loop
+ for msg being the hash-keys of msgs
+ collect msg)
+ #'<)))
+ (mh-exec-cmd "refile" msgs "-src" folder
+ "-link" index-folder)
+ ;; Restore cur to old value, that refile changed
+ (when cur
+ (mh-exec-cmd-quiet nil "mark" folder "-add" "-zero"
+ "-sequence"
+ "cur" (format "%s" cur)))
+ (cl-loop for msg in msgs
+ do (cl-incf result-count)
+ (setf (gethash result-count origin-map)
+ (cons folder msg)))))
folder-results-map)
;; Vist the results folder.
@@ -332,7 +330,7 @@ configuration and is used when the search folder is dismissed."
(interactive (list (mh-prompt-for-folder "Search" mh-current-folder nil nil t)
(current-window-configuration)))
;; FIXME: `pick-folder' is unused!
- (let ((pick-folder (if (equal folder "+") mh-current-folder folder)))
+ (let () ;; (pick-folder (if (equal folder "+") mh-current-folder folder))
(switch-to-buffer-other-window "search-pattern")
(if (or (zerop (buffer-size))
(not (y-or-n-p "Reuse pattern? ")))
@@ -356,7 +354,7 @@ configuration and is used when the search folder is dismissed."
"---------\n")
(mh-search-mode)
(goto-char (point-min))
- (dotimes (i 5)
+ (dotimes (_ 5)
(add-text-properties (point) (1+ (point)) '(front-sticky t))
(add-text-properties (- (mh-line-end-position) 2)
(1- (mh-line-end-position))
@@ -453,7 +451,7 @@ search all folders."
(defvar mh-flists-search-folders)
-(defun mh-flists-execute (&rest ignored)
+(defun mh-flists-execute (&rest _ignored)
"Execute flists.
Search for messages belonging to `mh-flists-sequence' in the
folders specified by `mh-flists-search-folders'. If
@@ -618,7 +616,7 @@ The hook `mh-search-mode-hook' is called upon entry to this mode.
\\{mh-search-mode-map}"
- (easy-menu-add mh-pick-menu)
+ (mh-do-in-xemacs (easy-menu-add mh-pick-menu))
(mh-set-help mh-search-mode-help-messages))
@@ -880,7 +878,7 @@ used to search."
folder-path
(format "%s/" folder-path)))))
-(defalias 'mh-swish++-next-result 'mh-swish-next-result)
+(defalias 'mh-swish++-next-result #'mh-swish-next-result)
(defun mh-swish++-regexp-builder (regexp-list)
"Generate query for swish++.
@@ -1136,10 +1134,10 @@ REGEXP-LIST is an alist of fields and values."
((atom (cadr expr)) `(or (and ,expr)))
((eq (caadr expr) 'not) (mh-mairix-convert-to-sop* (cadadr expr)))
((eq (caadr expr) 'and) (mh-mairix-convert-to-sop*
- `(or ,@(mapcar #'(lambda (x) `(not ,x))
+ `(or ,@(mapcar (lambda (x) `(not ,x))
(cdadr expr)))))
((eq (caadr expr) 'or) (mh-mairix-convert-to-sop*
- `(and ,@(mapcar #'(lambda (x) `(not ,x))
+ `(and ,@(mapcar (lambda (x) `(not ,x))
(cdadr expr)))))
(t (error "Unreachable: %s" expr))))
@@ -1450,7 +1448,7 @@ being the list of messages originally from that folder."
(defun mh-index-execute-commands ()
"Perform the outstanding operations on the actual messages.
The copies in the searched folder are then deleted, refiled,
-blacklisted and whitelisted to get the desired result. Before
+blocklisted and allowlisted to get the desired result. Before
processing the messages we make sure that the message is
identical to the one that the user has marked in the index
buffer."
@@ -1467,12 +1465,12 @@ buffer."
(with-current-buffer folder
(let ((old-refile-list mh-refile-list)
(old-delete-list mh-delete-list)
- (old-blacklist mh-blacklist)
- (old-whitelist mh-whitelist))
+ (old-blocklist mh-blocklist)
+ (old-allowlist mh-allowlist))
(setq mh-refile-list nil
mh-delete-list msgs
- mh-blacklist nil
- mh-whitelist nil)
+ mh-blocklist nil
+ mh-allowlist nil)
(unwind-protect (mh-execute-commands)
(setq mh-refile-list
(mapcar (lambda (x)
@@ -1484,11 +1482,11 @@ buffer."
mh-delete-list
(cl-loop for x in old-delete-list
unless (memq x msgs) collect x)
- mh-blacklist
- (cl-loop for x in old-blacklist
+ mh-blocklist
+ (cl-loop for x in old-blocklist
unless (memq x msgs) collect x)
- mh-whitelist
- (cl-loop for x in old-whitelist
+ mh-allowlist
+ (cl-loop for x in old-allowlist
unless (memq x msgs) collect x))
(mh-set-folder-modified-p (mh-outstanding-commands-p))
(when (mh-outstanding-commands-p)
@@ -1496,8 +1494,8 @@ buffer."
(mh-index-matching-source-msgs (append (cl-loop for x in mh-refile-list
append (cdr x))
mh-delete-list
- mh-blacklist
- mh-whitelist)
+ mh-blocklist
+ mh-allowlist)
t))
folders)))
@@ -1620,7 +1618,7 @@ garbled."
(cl-loop for seq in seq-list
do (apply #'mh-exec-cmd "mark" mh-current-folder
"-sequence" (symbol-name (car seq)) "-add"
- (mapcar #'(lambda (x) (format "%s" x)) (cdr seq))))))
+ (mapcar (lambda (x) (format "%s" x)) (cdr seq))))))
;;;###mh-autoload
(defun mh-create-sequence-map (seq-list)
@@ -1853,7 +1851,7 @@ PROC is used to convert the value to actual data."
(1+ last-slash) (1- last-space)))
(buffer-substring-no-properties (1+ last-space) end))))))
-(defalias 'mh-md5-parser 'mh-openssl-parser)
+(defalias 'mh-md5-parser #'mh-openssl-parser)
;;;###mh-autoload
(defun mh-index-update-maps (folder &optional origin-map)
@@ -1945,4 +1943,4 @@ folder buffer."
;; sentence-end-double-space: nil
;; End:
-;;; mh-search ends here
+;;; mh-search.el ends here
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el
index 6515f975592..9cdf39f7f1e 100644
--- a/lisp/mh-e/mh-seq.el
+++ b/lisp/mh-e/mh-seq.el
@@ -1,4 +1,4 @@
-;;; mh-seq.el --- MH-E sequences support
+;;; mh-seq.el --- MH-E sequences support -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
@@ -26,8 +26,6 @@
;; Sequences are stored in the alist `mh-seq-list' in the form:
;; ((seq-name msgs ...) (seq-name msgs ...) ...)
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -156,7 +154,7 @@ The list appears in a buffer named \"*MH-E Sequences*\"."
(let ((name (mh-seq-name (car seq-list)))
(sorted-seq-msgs
(mh-coalesce-msg-list
- (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<)))
+ (sort (copy-sequence (mh-seq-msgs (car seq-list))) #'<)))
name-spec)
(insert (setq name-spec (format (format "%%%ss:" max-len) name)))
(while sorted-seq-msgs
@@ -191,7 +189,7 @@ MESSAGE appears."
(cond (dest-folder (format " (to be refiled to %s)" dest-folder))
(deleted-flag (format " (to be deleted)"))
(t ""))
- (mapconcat 'concat
+ (mapconcat #'concat
(mh-list-to-string (mh-seq-containing-msg message t))
" "))))
@@ -390,10 +388,7 @@ Prompt with PROMPT, raise an error if the sequence is empty and
the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
sequence. A reply of `%' defaults to the first sequence
containing the current message."
- (let* ((input (completing-read (format "%s sequence%s: " prompt
- (if default
- (format " (default %s)" default)
- ""))
+ (let* ((input (completing-read (format-prompt "%s sequence" default prompt)
(mh-seq-names mh-seq-list)
nil nil nil 'mh-sequence-history))
(seq (cond ((equal input "%")
@@ -494,13 +489,13 @@ folder buffer are not updated."
;; Add to a SEQUENCE each message the list of MSGS.
(if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
(if msgs
- (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
+ (apply #'mh-exec-cmd "mark" mh-current-folder "-add"
"-sequence" (symbol-name seq)
(mh-coalesce-msg-list msgs)))))
(defun mh-canonicalize-sequence (msgs)
"Sort MSGS in decreasing order and remove duplicates."
- (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
+ (let* ((sorted-msgs (sort (copy-sequence msgs) #'>))
(head sorted-msgs))
(while (cdr head)
(if (= (car head) (cadr head))
@@ -565,7 +560,7 @@ OP is one of `widen' and `unthread'."
(defvar mh-range-seq-names)
(defvar mh-range-history ())
(defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
-(define-key mh-range-completion-map " " 'self-insert-command)
+(define-key mh-range-completion-map " " #'self-insert-command)
;;;###mh-autoload
(defun mh-interactive-range (range-prompt &optional default)
@@ -646,13 +641,10 @@ should be replaced with:
((stringp default) default)
((symbolp default) (symbol-name default))))
(prompt (cond ((and guess large default)
- (format "%s (folder has %s messages, default %s)"
- prompt (car counts) default))
- ((and guess large)
- (format "%s (folder has %s messages)"
- prompt (car counts)))
+ (format-prompt "%s (folder has %s messages)"
+ default prompt (car counts)))
(default
- (format "%s (default %s)" prompt default))))
+ (format-prompt prompt default))))
(minibuffer-local-completion-map mh-range-completion-map)
(seq-list (if (eq folder mh-current-folder)
mh-seq-list
@@ -662,7 +654,7 @@ should be replaced with:
(mh-seq-names seq-list)))
(input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
((and (not ask-flag) (not large)) "all")
- (t (completing-read (format "%s: " prompt)
+ (t (completing-read prompt
'mh-range-completion-function nil nil
nil 'mh-range-history default))))
msg-list)
@@ -794,9 +786,9 @@ If SAVE-REFILES is non-nil, then keep the sequences
that note messages to be refiled."
(let ((seqs ()))
(cond (save-refiles
- (mh-mapc (function (lambda (seq) ; Save the refiling sequences
- (if (mh-folder-name-p (mh-seq-name seq))
- (setq seqs (cons seq seqs)))))
+ (mh-mapc (lambda (seq) ; Save the refiling sequences
+ (if (mh-folder-name-p (mh-seq-name seq))
+ (setq seqs (cons seq seqs))))
mh-seq-list)))
(save-excursion
(if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list"))
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index 389dafd0e3c..803f07e02b2 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -1,4 +1,4 @@
-;;; mh-show.el --- MH-Show mode
+;;; mh-show.el --- MH-Show mode -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -26,8 +26,6 @@
;; Mode for showing messages.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -136,7 +134,7 @@ displayed."
(show-window (get-buffer-window mh-show-buffer))
(display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag))
(if (not (eq (next-window (minibuffer-window)) (selected-window)))
- (delete-other-windows)) ; force ourself to the top window
+ (delete-other-windows)) ; force ourselves to the top window
(mh-in-show-buffer (mh-show-buffer)
(setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag)
(if (and show-window
@@ -187,7 +185,7 @@ Sets the current buffer to the show buffer."
(set-buffer folder)
;; When Gnus uses external displayers it has to keep handles longer. So
;; we will delete these handles when mh-quit is called on the folder. It
- ;; would be nicer if there are weak pointers in emacs lisp, then we could
+ ;; would be nicer if there are weak pointers in Emacs Lisp, then we could
;; get the garbage collector to do this for us.
(unless (mh-buffer-data)
(setf (mh-buffer-data) (mh-make-buffer-data)))
@@ -195,7 +193,7 @@ Sets the current buffer to the show buffer."
(let ((formfile mh-mhl-format-file)
(clean-message-header mh-clean-message-header-flag)
(invisible-headers mh-invisible-header-fields-compiled)
- (visible-headers nil)
+ ;; (visible-headers nil)
(msg-filename (mh-msg-filename msg-num folder-name))
(show-buffer mh-show-buffer)
(mm-inline-media-tests mh-mm-inline-media-tests))
@@ -219,8 +217,7 @@ Sets the current buffer to the show buffer."
(erase-buffer)
;; Changing contents, so this hook needs to be reinitialized.
;; pgp.el uses this.
- (if (boundp 'write-contents-hooks) ;Emacs 19
- (kill-local-variable 'write-contents-hooks))
+ (kill-local-variable 'write-contents-functions)
(font-lock-mode -1)
(mh-show-mode)
(if formfile
@@ -242,7 +239,7 @@ Sets the current buffer to the show buffer."
(cond (clean-message-header
(mh-clean-msg-header (point-min)
invisible-headers
- visible-headers)
+ nil) ;; visible-headers
(goto-char (point-min)))
(t
(mh-start-of-uncleaned-message)))
@@ -466,8 +463,10 @@ still visible.\n")
(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t)
(mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick)
(mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick)
-(mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist)
-(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)
+(mh-defun-show-buffer mh-show-junk-allowlist mh-junk-allowlist)
+(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-allowlist)
+(make-obsolete 'mh-show-junk-whitelist 'mh-show-junk-allowlist "28.1")
+(mh-defun-show-buffer mh-show-junk-blocklist mh-junk-blocklist)
(mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)
(mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)
(mh-defun-show-buffer mh-show-index-sequenced-messages
@@ -636,7 +635,8 @@ still visible.\n")
(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map)
"?" mh-prefix-help
- "b" mh-show-junk-blacklist
+ "a" mh-show-junk-allowlist
+ "b" mh-show-junk-blocklist
"w" mh-show-junk-whitelist)
(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map)
@@ -863,10 +863,11 @@ See also `mh-folder-mode'.
(turn-on-font-lock))
(when mh-decode-mime-flag
(mh-make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t))
- (easy-menu-add mh-show-sequence-menu)
- (easy-menu-add mh-show-message-menu)
- (easy-menu-add mh-show-folder-menu)
+ (add-hook 'kill-buffer-hook #'mh-mime-cleanup nil t))
+ (mh-do-in-xemacs
+ (easy-menu-add mh-show-sequence-menu)
+ (easy-menu-add mh-show-message-menu)
+ (easy-menu-add mh-show-folder-menu))
(make-local-variable 'mh-show-folder-buffer)
(buffer-disable-undo)
(use-local-map mh-show-mode-map))
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index 7d42b0bb5df..3af840c3a31 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -1,4 +1,4 @@
-;;; mh-speed.el --- MH-E speedbar support
+;;; mh-speed.el --- MH-E speedbar support -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -26,8 +26,6 @@
;; Future versions should only use flists.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -100,9 +98,9 @@
;; Alphabetical.
-(defalias 'mh-speed-contract-folder 'mh-speed-toggle)
+(defalias 'mh-speed-contract-folder #'mh-speed-toggle)
-(defalias 'mh-speed-expand-folder 'mh-speed-toggle)
+(defalias 'mh-speed-expand-folder #'mh-speed-toggle)
(defun mh-speed-refresh ()
"Regenerates the list of folders in the speedbar.
@@ -125,11 +123,10 @@ With non-nil FORCE, the update is always carried out."
;; Otherwise on to your regular programming
(t t)))
-(defun mh-speed-toggle (&rest ignored)
+(defun mh-speed-toggle (&rest _ignored)
"Toggle the display of child folders in the speedbar.
The optional arguments from speedbar are IGNORED."
(interactive)
- (declare (ignore args))
(beginning-of-line)
(let ((parent (get-text-property (point) 'mh-folder))
(kids-p (get-text-property (point) 'mh-children-p))
@@ -164,11 +161,10 @@ The optional arguments from speedbar are IGNORED."
(mh-line-beginning-position) (1+ (line-beginning-position))
'(mh-expanded t)))))))
-(defun mh-speed-view (&rest ignored)
+(defun mh-speed-view (&rest _ignored)
"Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder].
The optional arguments from speedbar are IGNORED."
(interactive)
- (declare (ignore args))
(let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder))
(range (and (stringp folder)
(mh-read-range "Scan" folder t nil nil
@@ -204,9 +200,9 @@ created."
(mh-speed-flists nil))))
;;;###mh-autoload
-(defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons)
+(defalias 'mh-show-speedbar-buttons #'mh-folder-speedbar-buttons)
;;;###mh-autoload
-(defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons)
+(defalias 'mh-letter-speedbar-buttons #'mh-folder-speedbar-buttons)
(defmacro mh-speed-select-attached-frame ()
"Compatibility macro to handle speedbar versions 0.11a and 0.14beta4."
@@ -307,7 +303,7 @@ The function will expand out parent folders of FOLDER if needed."
(mh-speed-toggle))
(goto-char (gethash prefix mh-speed-folder-map))))
(while suffix-list
- ;; We always need atleast one toggle. We need two if the directory list
+ ;; We always need at least one toggle. We need two if the directory list
;; is stale since a folder was added.
(when (equal prefix (get-text-property (mh-line-beginning-position)
'mh-folder))
@@ -433,7 +429,7 @@ flists is run only for that one folder."
(setq mh-speed-flists-folder nil)
(mh-process-kill-without-query mh-speed-flists-process)
(set-process-filter mh-speed-flists-process
- 'mh-speed-parse-flists-output)))))))
+ #'mh-speed-parse-flists-output)))))))
;; Copied from mh-make-folder-list-filter...
;; XXX Refactor to use mh-make-folder-list-filer?
diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el
index 2ddf79fb8c0..89b0dbd9798 100644
--- a/lisp/mh-e/mh-thread.el
+++ b/lisp/mh-e/mh-thread.el
@@ -1,4 +1,4 @@
-;;; mh-thread.el --- MH-E threading support
+;;; mh-thread.el --- MH-E threading support -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2004, 2006-2021 Free Software Foundation, Inc.
@@ -26,10 +26,10 @@
;; The threading portion of this files tries to implement the
;; algorithm described at:
-;; http://www.jwz.org/doc/threading.html
+;; https://www.jwz.org/doc/threading.html
;; It also begins to implement the threading section of the IMAP -
;; SORT and THREAD Extensions RFC at:
-;; http://tools.ietf.org/html/rfc5256
+;; https://tools.ietf.org/html/rfc5256
;; The implementation lacks the reference and subject canonicalization
;; of the RFC.
@@ -69,8 +69,6 @@
;; (5) Better canonicalizing for message identifier and subject
;; strings.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -233,7 +231,7 @@ sibling."
(push index msg-list)))
(forward-line))
(mh-scan-folder mh-current-folder
- (mapcar #'(lambda (x) (format "%s" x))
+ (mapcar (lambda (x) (format "%s" x))
(mh-coalesce-msg-list msg-list))
t))
(when mh-index-data
@@ -591,7 +589,7 @@ Only information about messages in MSG-LIST are added to the tree."
#'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
"-width" "10000" "-format"
"%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n"
- folder (mapcar #'(lambda (x) (format "%s" x)) msg-list)))
+ folder (mapcar (lambda (x) (format "%s" x)) msg-list)))
(goto-char (point-min))
(let ((roots ())
(case-fold-search t))
@@ -635,9 +633,9 @@ Only information about messages in MSG-LIST are added to the tree."
(mh-thread-remove-parent-link id)
(mh-thread-add-link (car ancestors) id)))
(mh-thread-add-link (car ancestors) (cadr ancestors)))))))
- (maphash #'(lambda (_k v)
- (when (null (mh-container-parent v))
- (push v roots)))
+ (maphash (lambda (_k v)
+ (when (null (mh-container-parent v))
+ (push v roots)))
mh-thread-id-table)
(setq roots (mh-thread-prune-containers roots))
(prog1 (setq roots (mh-thread-group-by-subject roots))
@@ -720,25 +718,25 @@ For now it will take the last string inside angles."
mh-thread-history)
(mh-thread-remove-parent-link node)))))
(let ((results ()))
- (maphash #'(lambda (_k v)
- (when (and (null (mh-container-parent v))
- (gethash (mh-message-id (mh-container-message v))
- mh-thread-id-index-map))
- (push v results)))
+ (maphash (lambda (_k v)
+ (when (and (null (mh-container-parent v))
+ (gethash (mh-message-id (mh-container-message v))
+ mh-thread-id-index-map))
+ (push v results)))
mh-thread-id-table)
(mh-thread-sort-containers results))))
(defun mh-thread-sort-containers (containers)
"Sort a list of message CONTAINERS to be in ascending order wrt index."
(sort containers
- #'(lambda (x y)
- (when (and (mh-container-message x) (mh-container-message y))
- (let* ((id-x (mh-message-id (mh-container-message x)))
- (id-y (mh-message-id (mh-container-message y)))
- (index-x (gethash id-x mh-thread-id-index-map))
- (index-y (gethash id-y mh-thread-id-index-map)))
- (and (integerp index-x) (integerp index-y)
- (< index-x index-y)))))))
+ (lambda (x y)
+ (when (and (mh-container-message x) (mh-container-message y))
+ (let* ((id-x (mh-message-id (mh-container-message x)))
+ (id-y (mh-message-id (mh-container-message y)))
+ (index-x (gethash id-x mh-thread-id-index-map))
+ (index-y (gethash id-y mh-thread-id-index-map)))
+ (and (integerp index-x) (integerp index-y)
+ (< index-x index-y)))))))
(defvar mh-thread-last-ancestor)
diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el
index 7dbddbc891b..94aa8dd4a92 100644
--- a/lisp/mh-e/mh-tool-bar.el
+++ b/lisp/mh-e/mh-tool-bar.el
@@ -1,4 +1,4 @@
-;;; mh-tool-bar.el --- MH-E tool bar support
+;;; mh-tool-bar.el --- MH-E tool bar support -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -356,7 +354,7 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
'(list ,@(mapcar (lambda (x) `(quote ,x)) folder-defaults))
"List of buttons to include in MH-Folder tool bar."
:group 'mh-tool-bar
- :set 'mh-tool-bar-folder-buttons-set
+ :set #'mh-tool-bar-folder-buttons-set
:type '(set ,@(cl-loop for x in folder-buttons
for y in folder-docs
collect `(const :tag ,y ,x)))
@@ -367,7 +365,7 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
'(list ,@(mapcar (lambda (x) `(quote ,x)) letter-defaults))
"List of buttons to include in MH-Letter tool bar."
:group 'mh-tool-bar
- :set 'mh-tool-bar-letter-buttons-set
+ :set #'mh-tool-bar-letter-buttons-set
:type '(set ,@(cl-loop for x in letter-buttons
for y in letter-docs
collect `(const :tag ,y ,x)))
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el
index 1ebb9dbab28..8e900dc0113 100644
--- a/lisp/mh-e/mh-utils.el
+++ b/lisp/mh-e/mh-utils.el
@@ -1,4 +1,4 @@
-;;; mh-utils.el --- MH-E general utilities
+;;; mh-utils.el --- MH-E general utilities -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 1997, 2000-2021 Free Software Foundation,
;; Inc.
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -268,11 +266,10 @@ and displayed in a help buffer."
(interactive)
(let* ((help (or help-messages
(cdr (assoc nil (assoc major-mode mh-help-messages)))))
- (text (substitute-command-keys (mapconcat 'identity help ""))))
+ (text (substitute-command-keys (mapconcat #'identity help ""))))
(with-electric-help
- (function
- (lambda ()
- (insert text)))
+ (lambda ()
+ (insert text))
mh-help-buffer)))
;;;###mh-autoload
@@ -299,7 +296,7 @@ and displayed in a help buffer."
This is the inverse of `mh-read-msg-list', which expands ranges.
Message lists passed to MH programs should be processed by this
function to avoid exceeding system command line argument limits."
- (let ((msgs (sort (copy-sequence messages) 'mh-greaterp))
+ (let ((msgs (sort (copy-sequence messages) #'mh-greaterp))
(range-high nil)
(prev -1)
(ranges nil))
@@ -545,8 +542,8 @@ nested folders within them."
(mh-sub-folders-actual folder)))
(t match))))
(if add-trailing-slash-flag
- (mapcar #'(lambda (x)
- (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
+ (mapcar (lambda (x)
+ (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
sub-folders)
sub-folders)))
@@ -670,7 +667,7 @@ three arguments so we bind this variable to t or nil.
This variable should never be set.")
(defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
-(define-key mh-folder-completion-map " " 'minibuffer-complete) ;Why???
+(define-key mh-folder-completion-map " " #'minibuffer-complete) ;Why???
(defvar mh-speed-flists-inhibit-flag nil)
@@ -731,8 +728,7 @@ See Info node `(elisp) Programmed Completion' for details."
(t (file-directory-p path))))))))
;; Shush compiler.
-(mh-do-in-xemacs
- (defvar completion-root-regexp))
+(defvar completion-root-regexp) ;; Apparently used in XEmacs
(defun mh-folder-completing-read (prompt default allow-root-folder-flag)
"Read folder name with PROMPT and default result DEFAULT.
@@ -759,10 +755,9 @@ function will accept the folder +, which means all folders when
used in searching."
(if (null default)
(setq default ""))
- (let* ((default-string (cond (default-string (format " (default %s)" default-string))
- ((equal "" default) "")
- (t (format " (default %s)" default))))
- (prompt (format "%s folder%s: " prompt default-string))
+ (let* ((default-string (or default-string
+ (if (equal default "") nil default)))
+ (prompt (format-prompt "%s folder" default-string prompt))
(mh-current-folder-name mh-current-folder)
read-name folder-name)
(while (and (setq read-name (mh-folder-completing-read
@@ -926,10 +921,10 @@ Handle RFC 822 (or later) continuation lines."
(defvar mh-hidden-header-keymap
(let ((map (make-sparse-keymap)))
(mh-do-in-gnu-emacs
- (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button))
+ (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button))
(mh-do-in-xemacs
(define-key map '(button2)
- 'mh-letter-toggle-header-field-display-button))
+ #'mh-letter-toggle-header-field-display-button))
map))
;;;###mh-autoload
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el
index f96302f9097..d4d5c5c3784 100644
--- a/lisp/mh-e/mh-xface.el
+++ b/lisp/mh-e/mh-xface.el
@@ -1,4 +1,4 @@
-;;; mh-xface.el --- MH-E X-Face and Face header field display
+;;; mh-xface.el --- MH-E X-Face and Face header field display -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc.
@@ -23,8 +23,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -365,7 +363,7 @@ Replace the ?/ character with a ?! character and append .png.
Also replaces special characters with `mh-url-hexify-string'
since not all characters, such as :, are valid within Windows
filenames. In addition, replaces * with %2a. See URL
-`http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
+`https://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
(format "%s/%s.png" mh-x-image-cache-directory
(mh-replace-regexp-in-string
"\\*" "%2a"
@@ -425,8 +423,7 @@ After the image is fetched, it is stored in CACHE-FILE. It will
be displayed in a buffer and position specified by MARKER. The
actual display is carried out by the SENTINEL function."
(if mh-wget-executable
- (let ((buffer (get-buffer-create (generate-new-buffer-name
- mh-temp-fetch-buffer)))
+ (let ((buffer (generate-new-buffer mh-temp-fetch-buffer))
(filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
(expand-file-name (make-temp-name "~/mhe-fetch")))))
(with-current-buffer buffer
diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el
index db16612505e..30273fab1b8 100644
--- a/lisp/minibuf-eldef.el
+++ b/lisp/minibuf-eldef.el
@@ -36,10 +36,24 @@
(defvar minibuffer-eldef-shorten-default)
(defun minibuffer-default--in-prompt-regexps ()
- `(("\\( (default\\(?: is\\)? \\(.*\\))\\):? \\'"
- 1 ,(if minibuffer-eldef-shorten-default " [\\2]"))
- ("([^(]+?\\(, default\\(?: is\\)? \\(.*\\)\\)):? \\'" 1)
- ("\\( \\[.*\\]\\):? *\\'" 1)))
+ (cons
+ (list
+ (concat
+ "\\("
+ (if (string-match "%s" minibuffer-default-prompt-format)
+ (concat
+ (regexp-quote (substring minibuffer-default-prompt-format
+ 0 (match-beginning 0)))
+ "\\(.*?\\)"
+ (regexp-quote (substring minibuffer-default-prompt-format
+ (match-end 0))))
+ (regexp-quote minibuffer-default-prompt-format))
+ "\\): ")
+ 1 (and minibuffer-eldef-shorten-default " [\\2]"))
+ `(("\\( (default\\(?: is\\)? \\(.*\\))\\):? \\'"
+ 1 ,(if minibuffer-eldef-shorten-default " [\\2]"))
+ ("([^(]+?\\(, default\\(?: is\\)? \\(.*\\)\\)):? \\'" 1)
+ ("\\( \\[.*\\]\\):? *\\'" 1))))
(defcustom minibuffer-eldef-shorten-default nil
"If non-nil, shorten \"(default ...)\" to \"[...]\" in minibuffer prompts."
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 0443cf4b031..3751ba80e0a 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -83,7 +83,6 @@
;; - add support for ** to pcm.
;; - Add vc-file-name-completion-table to read-file-name-internal.
-;; - A feature like completing-help.el.
;;; Code:
@@ -121,6 +120,19 @@ This metadata is an alist. Currently understood keys are:
- `annotation-function': function to add annotations in *Completions*.
Takes one argument (STRING), which is a possible completion and
returns a string to append to STRING.
+- `affixation-function': function to prepend/append a prefix/suffix to
+ entries. Takes one argument (COMPLETIONS) and should return a list
+ of annotated completions. The elements of the list must be
+ three-element lists: completion, its prefix and suffix. This
+ function takes priority over `annotation-function' when both are
+ provided, so only this function is used.
+- `group-function': function for grouping the completion candidates.
+ Takes two arguments: a completion candidate (COMPLETION) and a
+ boolean flag (TRANSFORM). If TRANSFORM is nil, the function
+ returns the group title of the group to which the candidate
+ belongs. The returned title may be nil. Otherwise the function
+ returns the transformed candidate. The transformation can remove a
+ redundant prefix, which is displayed in the group title.
- `display-sort-function': function to sort entries in *Completions*.
Takes one argument (COMPLETIONS) and should return a new list
of completions. Can operate destructively.
@@ -266,7 +278,7 @@ the form (concat S2 S)."
(let* ((str (if (string-prefix-p s1 string completion-ignore-case)
(concat s2 (substring string (length s1)))))
(res (if str (complete-with-action action table str pred))))
- (when res
+ (when (or res (eq (car-safe action) 'boundaries))
(cond
((eq (car-safe action) 'boundaries)
(let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
@@ -483,8 +495,17 @@ for use at QPOS."
(qsuffix (cdr action))
(ufull (if (zerop (length qsuffix)) ustring
(funcall unquote (concat string qsuffix))))
- (_ (cl-assert (string-prefix-p ustring ufull)))
- (usuffix (substring ufull (length ustring)))
+ ;; If (not (string-prefix-p ustring ufull)) we have a problem:
+ ;; unquoting the qfull gives something "unrelated" to ustring.
+ ;; E.g. "~/" and "/" where "~//" gets unquoted to just "/" (see
+ ;; bug#47678).
+ ;; In that case we can't even tell if we're right before the
+ ;; "/" or right after it (aka if this "/" is from qstring or
+ ;; from qsuffix), thus which usuffix to use is very unclear.
+ (usuffix (if (string-prefix-p ustring ufull)
+ (substring ufull (length ustring))
+ ;; FIXME: Maybe "" is preferable/safer?
+ qsuffix))
(boundaries (completion-boundaries ustring table pred usuffix))
(qlboundary (car (funcall requote (car boundaries) string)))
(qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
@@ -685,13 +706,6 @@ for use at QPOS."
completions)
qboundary))))
-;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
-;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
-(define-obsolete-function-alias
- 'complete-in-turn #'completion-table-in-turn "23.1")
-(define-obsolete-function-alias
- 'dynamic-completion-table #'completion-table-dynamic "23.1")
-
;;; Minibuffer completion
(defgroup minibuffer nil
@@ -708,7 +722,7 @@ The text is displayed for `minibuffer-message-timeout' seconds,
or until the next input event arrives, whichever comes first.
Enclose MESSAGE in [...] if this is not yet the case.
If ARGS are provided, then pass MESSAGE through `format-message'."
- (if (not (minibufferp (current-buffer)))
+ (if (not (minibufferp (current-buffer) t))
(progn
(if args
(apply #'message message args)
@@ -727,14 +741,16 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
;; Don't overwrite the face properties the caller has set
(text-properties-at 0 message))
(setq message (apply #'propertize message minibuffer-message-properties)))
- (let ((ol (make-overlay (point-max) (point-max) nil t t))
- ;; A quit during sit-for normally only interrupts the sit-for,
- ;; but since minibuffer-message is used at the end of a command,
- ;; at a time when the command has virtually finished already, a C-g
- ;; should really cause an abort-recursive-edit instead (i.e. as if
- ;; the C-g had been typed at top-level). Binding inhibit-quit here
- ;; is an attempt to get that behavior.
- (inhibit-quit t))
+ ;; Put overlay either on `minibuffer-message' property, or at EOB.
+ (let* ((ovpos (minibuffer--message-overlay-pos))
+ (ol (make-overlay ovpos ovpos nil t t))
+ ;; A quit during sit-for normally only interrupts the sit-for,
+ ;; but since minibuffer-message is used at the end of a command,
+ ;; at a time when the command has virtually finished already, a C-g
+ ;; should really cause an abort-recursive-edit instead (i.e. as if
+ ;; the C-g had been typed at top-level). Binding inhibit-quit here
+ ;; is an attempt to get that behavior.
+ (inhibit-quit t))
(unwind-protect
(progn
(unless (zerop (length message))
@@ -743,6 +759,12 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
;; before or after the string, so let's spoon-feed it the pos.
(put-text-property 0 1 'cursor t message))
(overlay-put ol 'after-string message)
+ ;; Make sure the overlay with the message is displayed before
+ ;; any other overlays in that position, in case they have
+ ;; resize-mini-windows set to nil and the other overlay strings
+ ;; are too long for the mini-window width. This makes sure the
+ ;; temporary message will always be visible.
+ (overlay-put ol 'priority 1100)
(sit-for (or minibuffer-message-timeout 1000000)))
(delete-overlay ol)))))
@@ -764,8 +786,10 @@ and `clear-minibuffer-message' called automatically via
(defvar minibuffer-message-overlay nil)
(defun minibuffer--message-overlay-pos ()
- "Return position where `set-minibuffer-message' shall put message overlay."
- ;; Starting from point, look for non-nil 'minibuffer-message'
+ "Return position where minibuffer message functions shall put message overlay.
+The minibuffer message functions include `minibuffer-message' and
+`set-minibuffer-message'."
+ ;; Starting from point, look for non-nil `minibuffer-message'
;; property, and return its position. If none found, return the EOB
;; position.
(let* ((pt (point))
@@ -810,7 +834,7 @@ via `set-message-function'."
;; The current C cursor code doesn't know to use the overlay's
;; marker's stickiness to figure out whether to place the cursor
;; before or after the string, so let's spoon-feed it the pos.
- (put-text-property 0 1 'cursor 1 message))
+ (put-text-property 0 1 'cursor t message))
(overlay-put minibuffer-message-overlay 'after-string message)
;; Make sure the overlay with the message is displayed before
;; any other overlays in that position, in case they have
@@ -858,6 +882,12 @@ 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)))
+(defun minibuffer--completion-prompt-end ()
+ (let ((end (minibuffer-prompt-end)))
+ (if (< (point) end)
+ (user-error "Can't complete in prompt")
+ end)))
+
(defvar completion-show-inline-help t
"If non-nil, print helpful inline messages during completion.")
@@ -959,6 +989,7 @@ styles for specific categories, such as files, buffers, etc."
;; A new style that combines substring and pcm might be better,
;; e.g. one that does not anchor to bos.
(project-file (styles . (substring)))
+ (xref-location (styles . (substring)))
(info-menu (styles . (basic substring))))
"Default settings for specific completion categories.
Each entry has the shape (CATEGORY . ALIST) where ALIST is
@@ -1078,10 +1109,16 @@ in the last `cdr'."
(defun completion--replace (beg end newtext)
"Replace the buffer text between BEG and END with NEWTEXT.
Moves point to the end of the new text."
- ;; The properties on `newtext' include things like
- ;; completions-first-difference, which we don't want to include
- ;; upon insertion.
- (set-text-properties 0 (length newtext) nil newtext)
+ ;; The properties on `newtext' include things like the
+ ;; `completions-first-difference' face, which we don't want to
+ ;; include upon insertion.
+ (if minibuffer-allow-text-properties
+ ;; If we're preserving properties, then just remove the faces
+ ;; and other properties added by the completion machinery.
+ (remove-text-properties 0 (length newtext) '(face completion-score)
+ newtext)
+ ;; Remove all text properties.
+ (set-text-properties 0 (length newtext) nil newtext))
;; Maybe this should be in subr.el.
;; You'd think this is trivial to do, but details matter if you want
;; to keep markers "at the right place" and be robust in the face of
@@ -1124,6 +1161,44 @@ completion candidates than this number."
:version "24.1"
:type completion--cycling-threshold-type)
+(defcustom completions-group nil
+ "Enable grouping of completion candidates in the *Completions* buffer.
+See also `completions-group-format' and `completions-group-sort'."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom completions-group-sort nil
+ "Sort groups in the *Completions* buffer.
+
+The value can either be nil to disable sorting, `alphabetical' for
+alphabetical sorting or a custom sorting function. The sorting
+function takes and returns an alist of groups, where each element is a
+pair of a group title string and a list of group candidate strings."
+ :type '(choice (const :tag "No sorting" nil)
+ (const :tag "Alphabetical sorting" alphabetical)
+ function)
+ :version "28.1")
+
+(defcustom completions-group-format
+ (concat
+ (propertize " " 'face 'completions-group-separator)
+ (propertize " %s " 'face 'completions-group-title)
+ (propertize " " 'face 'completions-group-separator
+ 'display '(space :align-to right)))
+ "Format string used for the group title."
+ :type 'string
+ :version "28.1")
+
+(defface completions-group-title
+ '((t :inherit shadow :slant italic))
+ "Face used for the title text of the candidate group headlines."
+ :version "28.1")
+
+(defface completions-group-separator
+ '((t :inherit shadow :strike-through t))
+ "Face used for the separator lines between the candidate groups."
+ :version "28.1")
+
(defun completion--cycle-threshold (metadata)
(let* ((cat (completion-metadata-get metadata 'category))
(over (completion--category-override cat 'cycle)))
@@ -1132,6 +1207,7 @@ completion candidates than this number."
(defvar-local completion-all-sorted-completions nil)
(defvar-local completion--all-sorted-completions-location nil)
(defvar completion-cycling nil) ;Function that takes down the cycling map.
+(defvar completion-tab-width nil)
(defvar completion-fail-discreetly nil
"If non-nil, stay quiet when there is no match.")
@@ -1279,10 +1355,9 @@ If no characters can be completed, display a list of possible completions.
If you repeat this command after it displayed such a list,
scroll the window of possible completions."
(interactive)
- (when (<= (minibuffer-prompt-end) (point))
- (completion-in-region (minibuffer-prompt-end) (point-max)
- minibuffer-completion-table
- minibuffer-completion-predicate)))
+ (completion-in-region (minibuffer--completion-prompt-end) (point-max)
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
(defun completion--in-region-1 (beg end)
;; If the previous command was not this,
@@ -1340,6 +1415,68 @@ scroll the window of possible completions."
(if (eq (car bounds) base) md-at-point
(completion-metadata (substring string 0 base) table pred))))
+(defun minibuffer--sort-by-key (elems keyfun)
+ "Return ELEMS sorted by increasing value of their KEYFUN.
+KEYFUN takes an element of ELEMS and should return a numerical value."
+ (mapcar #'cdr
+ (sort (mapcar (lambda (x) (cons (funcall keyfun x) x)) elems)
+ #'car-less-than-car)))
+
+(defun minibuffer--sort-by-position (hist elems)
+ "Sort ELEMS by their position in HIST."
+ (let ((hash (make-hash-table :test #'equal :size (length hist)))
+ (index 0))
+ ;; Record positions in hash
+ (dolist (c hist)
+ (unless (gethash c hash)
+ (puthash c index hash))
+ (cl-incf index))
+ (minibuffer--sort-by-key
+ elems (lambda (x) (gethash x hash most-positive-fixnum)))))
+
+(defun minibuffer--sort-by-length-alpha (elems)
+ "Sort ELEMS first by length, then alphabetically."
+ (sort elems (lambda (c1 c2)
+ (or (< (length c1) (length c2))
+ (and (= (length c1) (length c2))
+ (string< c1 c2))))))
+
+(defun minibuffer--sort-preprocess-history (base)
+ "Preprocess history.
+Remove completion BASE prefix string from history elements."
+ (let* ((def (if (stringp minibuffer-default)
+ minibuffer-default
+ (car-safe minibuffer-default)))
+ (hist (and (not (eq minibuffer-history-variable t))
+ (symbol-value minibuffer-history-variable)))
+ (base-size (length base)))
+ ;; Default comes first.
+ (setq hist (if def (cons def hist) hist))
+ ;; Drop base string from the history elements.
+ (if (= base-size 0)
+ hist
+ (delq nil (mapcar
+ (lambda (c)
+ (when (string-prefix-p base c)
+ (substring c base-size)))
+ hist)))))
+
+(defun minibuffer--group-by (group-fun sort-fun elems)
+ "Group ELEMS by GROUP-FUN and sort groups by SORT-FUN."
+ (let ((groups))
+ (dolist (cand elems)
+ (let* ((key (funcall group-fun cand nil))
+ (group (assoc key groups)))
+ (if group
+ (setcdr group (cons cand (cdr group)))
+ (push (list key cand) groups))))
+ (setq groups (nreverse groups)
+ groups (mapc (lambda (x)
+ (setcdr x (nreverse (cdr x))))
+ groups)
+ groups (funcall sort-fun groups))
+ (mapcan #'cdr groups)))
+
(defun completion-all-sorted-completions (&optional start end)
(or completion-all-sorted-completions
(let* ((start (or start (minibuffer-prompt-end)))
@@ -1369,23 +1506,18 @@ scroll the window of possible completions."
(setq all (delete-dups all))
(setq last (last all))
- (cond
- (sort-fun
- (setq all (funcall sort-fun all)))
- (t
- ;; Prefer shorter completions, by default.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
- (if (minibufferp)
- ;; Prefer recently used completions and put the default, if
- ;; it exists, on top.
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all
- (sort all
- (lambda (c1 c2)
- (cond ((equal c1 minibuffer-default) t)
- ((equal c2 minibuffer-default) nil)
- (t (> (length (member c1 hist))
- (length (member c2 hist))))))))))))
+ (if sort-fun
+ (setq all (funcall sort-fun all))
+ ;; Sort first by length and alphabetically.
+ (setq all (minibuffer--sort-by-length-alpha all))
+ ;; Sort by history position, put the default, if it
+ ;; exists, on top.
+ (when (minibufferp)
+ (setq all (minibuffer--sort-by-position
+ (minibuffer--sort-preprocess-history
+ (substring string 0 base-size))
+ all))))
+
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
@@ -1403,12 +1535,12 @@ scroll the window of possible completions."
(unless completion-cycling
(minibuffer-force-complete nil nil 'dont-cycle))
(completion--complete-and-exit
- (minibuffer-prompt-end) (point-max) #'exit-minibuffer
+ (minibuffer--completion-prompt-end) (point-max) #'exit-minibuffer
;; If the previous completion completed to an element which fails
;; test-completion, then we shouldn't exit, but that should be rare.
(lambda ()
(if minibuffer--require-match
- (minibuffer-message "Incomplete")
+ (completion--message "Incomplete")
;; If a match is not required, exit after all.
(exit-minibuffer)))))
@@ -1421,7 +1553,7 @@ DONT-CYCLE tells the function not to setup cycling."
;; FIXME: Need to deal with the extra-size issue here as well.
;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
- (let* ((start (copy-marker (or start (minibuffer-prompt-end))))
+ (let* ((start (copy-marker (or start (minibuffer--completion-prompt-end))))
(end (or end (point-max)))
;; (md (completion--field-metadata start))
(all (completion-all-sorted-completions start end))
@@ -1492,7 +1624,7 @@ If `minibuffer-completion-confirm' is `confirm-after-completion',
`minibuffer-confirm-exit-commands', and accept the input
otherwise."
(interactive)
- (completion-complete-and-exit (minibuffer-prompt-end) (point-max)
+ (completion-complete-and-exit (minibuffer--completion-prompt-end) (point-max)
#'exit-minibuffer))
(defun completion-complete-and-exit (beg end exit-function)
@@ -1658,40 +1790,45 @@ is added, provided that matches some possible completion.
Return nil if there is no valid completion, else t."
(interactive)
(completion-in-region--single-word
- (minibuffer-prompt-end) (point-max)
- minibuffer-completion-table minibuffer-completion-predicate))
-
-(defun completion-in-region--single-word (beg end collection
- &optional predicate)
- (let ((minibuffer-completion-table collection)
- (minibuffer-completion-predicate predicate))
- (pcase (completion--do-completion beg end
- #'completion--try-word-completion)
+ (minibuffer--completion-prompt-end) (point-max)))
+
+(defun completion-in-region--single-word (beg end)
+ (pcase (completion--do-completion beg end #'completion--try-word-completion)
(#b000 nil)
- (_ t))))
+ (_ t)))
-(defface completions-annotations '((t :inherit italic))
+(defface completions-annotations '((t :inherit (italic shadow)))
"Face to use for annotations in the *Completions* buffer.")
(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', display completions sorted
-horizontally in alphabetical order, rather than down the screen."
- :type '(choice (const horizontal) (const vertical))
+If the value is `horizontal', display completions sorted in columns
+horizontally in alphabetical order, rather than down the screen.
+If the value is `one-column', display completions down the screen
+in one column."
+ :type '(choice (const horizontal) (const vertical) (const one-column))
:version "23.2")
-(defun completion--insert-strings (strings)
+(defcustom completions-detailed nil
+ "When non-nil, display completions with details added as prefix/suffix.
+Some commands might provide a detailed view with more information prepended
+or appended to completions."
+ :type 'boolean
+ :version "28.1")
+
+(defun completion--insert-strings (strings &optional group-fun)
"Insert a list of STRINGS into the current buffer.
-Uses columns to keep the listing readable but compact.
-It also eliminates runs of equal strings."
+The candidate strings are inserted into the buffer depending on the
+completions format as specified by the variable `completions-format'.
+Runs of equal candidate strings are eliminated. GROUP-FUN is a
+`group-function' used for grouping the completion candidates."
(when (consp strings)
(let* ((length (apply #'max
(mapcar (lambda (s)
(if (consp s)
- (+ (string-width (car s))
- (string-width (cadr s)))
+ (apply #'+ (mapcar #'string-width s))
(string-width s)))
strings)))
(window (get-buffer-window (current-buffer) 0))
@@ -1702,82 +1839,158 @@ It also eliminates runs of equal strings."
;; Don't allocate more columns than we can fill.
;; Windows can't show less than 3 lines anyway.
(max 1 (/ (length strings) 2))))
- (colwidth (/ wwidth columns))
- (column 0)
- (rows (/ (length strings) columns))
- (row 0)
- (first t)
- (laststring nil))
- ;; The insertion should be "sensible" no matter what choices were made
- ;; for the parameters above.
- (dolist (str strings)
- (unless (equal laststring str) ; Remove (consecutive) duplicates.
- (setq laststring str)
+ (colwidth (/ wwidth columns)))
+ (unless (or tab-stop-list (null completion-tab-width)
+ (zerop (mod colwidth completion-tab-width)))
+ ;; Align to tab positions for the case
+ ;; when the caller uses tabs inside prefix.
+ (setq colwidth (- colwidth (mod colwidth completion-tab-width))))
+ (funcall (intern (format "completion--insert-%s" completions-format))
+ strings group-fun length wwidth colwidth columns))))
+
+(defun completion--insert-horizontal (strings group-fun
+ length wwidth
+ colwidth _columns)
+ (let ((column 0)
+ (first t)
+ (last-title nil)
+ (last-string nil))
+ (dolist (str strings)
+ (unless (equal last-string str) ; Remove (consecutive) duplicates.
+ (setq last-string str)
+ (when group-fun
+ (let ((title (funcall group-fun (if (consp str) (car str) str) nil)))
+ (unless (equal title last-title)
+ (setq last-title title)
+ (when title
+ (insert (if first "" "\n") (format completions-group-format title) "\n")
+ (setq column 0
+ first t)))))
+ (unless first
;; FIXME: `string-width' doesn't pay attention to
;; `display' properties.
- (let ((length (if (consp str)
- (+ (string-width (car str))
- (string-width (cadr str)))
- (string-width str))))
- (cond
- ((eq completions-format 'vertical)
- ;; Vertical format
- (when (> row rows)
- (forward-line (- -1 rows))
- (setq row 0 column (+ column colwidth)))
- (when (> column 0)
- (end-of-line)
- (while (> (current-column) column)
- (if (eobp)
- (insert "\n")
- (forward-line 1)
- (end-of-line)))
- (insert " \t")
- (set-text-properties (1- (point)) (point)
- `(display (space :align-to ,column)))))
- (t
- ;; Horizontal format
- (unless first
- (if (< wwidth (+ (max colwidth length) column))
- ;; No space for `str' at point, move to next line.
- (progn (insert "\n") (setq column 0))
- (insert " \t")
- ;; Leave the space unpropertized so that in the case we're
- ;; already past the goal column, there is still
- ;; a space displayed.
- (set-text-properties (1- (point)) (point)
- ;; We can't just set tab-width, because
- ;; completion-setup-function will kill
- ;; all local variables :-(
- `(display (space :align-to ,column)))
- nil))))
- (setq first nil)
- (if (not (consp str))
- (put-text-property (point) (progn (insert str) (point))
- 'mouse-face 'highlight)
- (put-text-property (point) (progn (insert (car str)) (point))
- 'mouse-face 'highlight)
- (let ((beg (point))
- (end (progn (insert (cadr str)) (point))))
- (put-text-property beg end 'mouse-face nil)
- (font-lock-prepend-text-property beg end 'face
- 'completions-annotations)))
- (cond
- ((eq completions-format 'vertical)
- ;; Vertical format
- (if (> column 0)
- (forward-line)
- (insert "\n"))
- (setq row (1+ row)))
- (t
- ;; Horizontal format
- ;; Next column to align to.
- (setq column (+ column
- ;; Round up to a whole number of columns.
- (* colwidth (ceiling length colwidth))))))))))))
-
-(defvar completion-common-substring nil)
-(make-obsolete-variable 'completion-common-substring nil "23.1")
+ (if (< wwidth (+ column (max colwidth
+ (if (consp str)
+ (apply #'+ (mapcar #'string-width str))
+ (string-width str)))))
+ ;; No space for `str' at point, move to next line.
+ (progn (insert "\n") (setq column 0))
+ (insert " \t")
+ ;; Leave the space unpropertized so that in the case we're
+ ;; already past the goal column, there is still
+ ;; a space displayed.
+ (set-text-properties (1- (point)) (point)
+ ;; We can set tab-width using
+ ;; completion-tab-width, but
+ ;; the caller can prefer using
+ ;; \t to align prefixes.
+ `(display (space :align-to ,column)))
+ nil))
+ (setq first nil)
+ (completion--insert str group-fun)
+ ;; Next column to align to.
+ (setq column (+ column
+ ;; Round up to a whole number of columns.
+ (* colwidth (ceiling length colwidth))))))))
+
+(defun completion--insert-vertical (strings group-fun
+ _length _wwidth
+ colwidth columns)
+ (while strings
+ (let ((group nil)
+ (column 0)
+ (row 0)
+ (rows)
+ (last-string nil))
+ (if group-fun
+ (let* ((str (car strings))
+ (title (funcall group-fun (if (consp str) (car str) str) nil)))
+ (while (and strings
+ (equal title (funcall group-fun
+ (if (consp (car strings))
+ (car (car strings))
+ (car strings))
+ nil)))
+ (push (car strings) group)
+ (pop strings))
+ (setq group (nreverse group)))
+ (setq group strings
+ strings nil))
+ (setq rows (/ (length group) columns))
+ (when group-fun
+ (let* ((str (car group))
+ (title (funcall group-fun (if (consp str) (car str) str) nil)))
+ (when title
+ (goto-char (point-max))
+ (insert (format completions-group-format title) "\n"))))
+ (dolist (str group)
+ (unless (equal last-string str) ; Remove (consecutive) duplicates.
+ (setq last-string str)
+ (when (> row rows)
+ (forward-line (- -1 rows))
+ (setq row 0 column (+ column colwidth)))
+ (when (> column 0)
+ (end-of-line)
+ (while (> (current-column) column)
+ (if (eobp)
+ (insert "\n")
+ (forward-line 1)
+ (end-of-line)))
+ (insert " \t")
+ (set-text-properties (1- (point)) (point)
+ `(display (space :align-to ,column))))
+ (completion--insert str group-fun)
+ (if (> column 0)
+ (forward-line)
+ (insert "\n"))
+ (setq row (1+ row)))))))
+
+(defun completion--insert-one-column (strings group-fun &rest _)
+ (let ((last-title nil) (last-string nil))
+ (dolist (str strings)
+ (unless (equal last-string str) ; Remove (consecutive) duplicates.
+ (setq last-string str)
+ (when group-fun
+ (let ((title (funcall group-fun (if (consp str) (car str) str) nil)))
+ (unless (equal title last-title)
+ (setq last-title title)
+ (when title
+ (insert (format completions-group-format title) "\n")))))
+ (completion--insert str group-fun)
+ (insert "\n")))))
+
+(defun completion--insert (str group-fun)
+ (if (not (consp str))
+ (add-text-properties
+ (point)
+ (progn
+ (insert
+ (if group-fun
+ (funcall group-fun str 'transform)
+ str))
+ (point))
+ `(mouse-face highlight completion--string ,str))
+ ;; If `str' is a list that has 2 elements,
+ ;; then the second element is a suffix annotation.
+ ;; If `str' has 3 elements, then the second element
+ ;; is a prefix, and the third element is a suffix.
+ (let* ((prefix (when (nth 2 str) (nth 1 str)))
+ (suffix (or (nth 2 str) (nth 1 str))))
+ (when prefix
+ (let ((beg (point))
+ (end (progn (insert prefix) (point))))
+ (put-text-property beg end 'mouse-face nil)))
+ (completion--insert (car str) group-fun)
+ (let ((beg (point))
+ (end (progn (insert suffix) (point))))
+ (put-text-property beg end 'mouse-face nil)
+ ;; Put the predefined face only when suffix
+ ;; is added via annotation-function without prefix,
+ ;; and when the caller doesn't use own face.
+ (unless (or prefix (text-property-not-all
+ 0 (length suffix) 'face nil suffix))
+ (font-lock-prepend-text-property
+ beg end 'face 'completions-annotations))))))
(defvar completion-setup-hook nil
"Normal hook run at the end of setting up a completion list buffer.
@@ -1837,7 +2050,7 @@ and with BASE-SIZE appended as the last element."
completions)
base-size))))
-(defun display-completion-list (completions &optional common-substring)
+(defun display-completion-list (completions &optional common-substring group-fun)
"Display the list of completions, COMPLETIONS, using `standard-output'.
Each element may be just a symbol or string
or may be a list of two strings to be printed as if concatenated.
@@ -1847,7 +2060,9 @@ alternative, the second serves as annotation.
The actual completion alternatives, as inserted, are given `mouse-face'
properties of `highlight'.
At the end, this runs the normal hook `completion-setup-hook'.
-It can find the completion buffer in `standard-output'."
+It can find the completion buffer in `standard-output'.
+GROUP-FUN is a `group-function' used for grouping the completion
+candidates."
(declare (advertised-calling-convention (completions) "24.4"))
(if common-substring
(setq completions (completion-hilit-commonality
@@ -1860,7 +2075,7 @@ It can find the completion buffer in `standard-output'."
(let ((standard-output (current-buffer))
(completion-setup-hook nil))
(with-suppressed-warnings ((callargs display-completion-list))
- (display-completion-list completions common-substring)))
+ (display-completion-list completions common-substring group-fun)))
(princ (buffer-string)))
(with-current-buffer standard-output
@@ -1868,13 +2083,9 @@ It can find the completion buffer in `standard-output'."
(if (null completions)
(insert "There are no possible completions of what you have typed.")
(insert "Possible completions are:\n")
- (completion--insert-strings completions))))
+ (completion--insert-strings completions group-fun))))
- ;; The hilit used to be applied via completion-setup-hook, so there
- ;; may still be some code that uses completion-common-substring.
- (with-no-warnings
- (let ((completion-common-substring common-substring))
- (run-hooks 'completion-setup-hook)))
+ (run-hooks 'completion-setup-hook)
nil)
(defvar completion-extra-properties nil
@@ -1888,6 +2099,14 @@ These include:
completion). The function can access the completion data via
`minibuffer-completion-table' and related variables.
+`:affixation-function': Function to prepend/append a prefix/suffix to
+ completions. The function must accept one argument, a list of
+ completions, and return a list of annotated completions. The
+ elements of the list must be three-element lists: completion, its
+ prefix and suffix. This function takes priority over
+ `:annotation-function' when both are provided, so only this
+ function is used.
+
`:exit-function': Function to run after completion is performed.
The function must accept two arguments, STRING and STATUS.
@@ -1940,7 +2159,7 @@ variables.")
"Display a list of possible completions of the current minibuffer contents."
(interactive)
(message "Making completion list...")
- (let* ((start (or start (minibuffer-prompt-end)))
+ (let* ((start (or start (minibuffer--completion-prompt-end)))
(end (or end (point-max)))
(string (buffer-substring start end))
(md (completion--field-metadata start))
@@ -1959,7 +2178,7 @@ variables.")
;; the sole completion, then hide (previous&stale) completions.
(minibuffer-hide-completions)
(ding)
- (minibuffer-message
+ (completion--message
(if completions "Sole completion" "No completions")))
(let* ((last (last completions))
@@ -1970,16 +2189,22 @@ variables.")
base-size md
minibuffer-completion-table
minibuffer-completion-predicate))
- (afun (or (completion-metadata-get all-md 'annotation-function)
- (plist-get completion-extra-properties
- :annotation-function)
- completion-annotate-function))
+ (ann-fun (or (completion-metadata-get all-md 'annotation-function)
+ (plist-get completion-extra-properties
+ :annotation-function)
+ completion-annotate-function))
+ (aff-fun (or (completion-metadata-get all-md 'affixation-function)
+ (plist-get completion-extra-properties
+ :affixation-function)))
+ (sort-fun (completion-metadata-get all-md 'display-sort-function))
+ (group-fun (completion-metadata-get all-md 'group-function))
+ (mainbuf (current-buffer))
;; If the *Completions* buffer is shown in a new
;; window, mark it as softly-dedicated, so bury-buffer in
;; minibuffer-hide-completions will know whether to
;; delete the window or not.
(display-buffer-mark-dedicated 'soft))
- (with-displayed-buffer-window
+ (with-current-buffer-window
"*Completions*"
;; This is a copy of `display-buffer-fallback-action'
;; where `display-buffer-use-some-window' is replaced
@@ -1993,66 +2218,90 @@ variables.")
,(if (eq (selected-window) (minibuffer-window))
'display-buffer-at-bottom
'display-buffer-below-selected))
- ,(if temp-buffer-resize-mode
- '(window-height . resize-temp-buffer-window)
- '(window-height . fit-window-to-buffer))
- ,(when temp-buffer-resize-mode
- '(preserve-size . (nil . t))))
- nil
- ;; Remove the base-size tail because `sort' requires a properly
- ;; nil-terminated list.
- (when last (setcdr last nil))
- (setq completions
- ;; FIXME: This function is for the output of all-completions,
- ;; not completion-all-completions. Often it's the same, but
- ;; not always.
- (let ((sort-fun (completion-metadata-get
- all-md 'display-sort-function)))
- (if sort-fun
- (funcall sort-fun completions)
- (sort completions 'string-lessp))))
- (when afun
- (setq completions
- (mapcar (lambda (s)
- (let ((ann (funcall afun s)))
- (if ann (list s ann) s)))
- completions)))
-
- (with-current-buffer standard-output
- (set (make-local-variable 'completion-base-position)
- (list (+ start base-size)
- ;; FIXME: We should pay attention to completion
- ;; boundaries here, but currently
- ;; completion-all-completions does not give us the
- ;; necessary information.
- end))
- (set (make-local-variable 'completion-list-insert-choice-function)
- (let ((ctable minibuffer-completion-table)
- (cpred minibuffer-completion-predicate)
- (cprops completion-extra-properties))
- (lambda (start end choice)
- (unless (or (zerop (length prefix))
- (equal prefix
- (buffer-substring-no-properties
- (max (point-min)
- (- start (length prefix)))
- start)))
- (message "*Completions* out of date"))
- ;; FIXME: Use `md' to do quoting&terminator here.
- (completion--replace start end choice)
- (let* ((minibuffer-completion-table ctable)
- (minibuffer-completion-predicate cpred)
- (completion-extra-properties cprops)
- (result (concat prefix choice))
- (bounds (completion-boundaries
- result ctable cpred "")))
- ;; If the completion introduces a new field, then
- ;; completion is not finished.
- (completion--done result
- (if (eq (car bounds) (length result))
- 'exact 'finished)))))))
-
- (display-completion-list completions))))
+ ,(if temp-buffer-resize-mode
+ '(window-height . resize-temp-buffer-window)
+ '(window-height . fit-window-to-buffer))
+ ,(when temp-buffer-resize-mode
+ '(preserve-size . (nil . t)))
+ (body-function
+ . ,#'(lambda (_window)
+ (with-current-buffer mainbuf
+ ;; Remove the base-size tail because `sort' requires a properly
+ ;; nil-terminated list.
+ (when last (setcdr last nil))
+
+ ;; Sort first using the `display-sort-function'.
+ ;; FIXME: This function is for the output of
+ ;; all-completions, not
+ ;; completion-all-completions. Often it's the
+ ;; same, but not always.
+ (setq completions (if sort-fun
+ (funcall sort-fun completions)
+ (sort completions 'string-lessp)))
+
+ ;; After sorting, group the candidates using the
+ ;; `group-function'.
+ (when group-fun
+ (setq completions
+ (minibuffer--group-by
+ group-fun
+ (pcase completions-group-sort
+ ('nil #'identity)
+ ('alphabetical
+ (lambda (groups)
+ (sort groups
+ (lambda (x y)
+ (string< (car x) (car y))))))
+ (_ completions-group-sort))
+ completions)))
+
+ (cond
+ (aff-fun
+ (setq completions
+ (funcall aff-fun completions)))
+ (ann-fun
+ (setq completions
+ (mapcar (lambda (s)
+ (let ((ann (funcall ann-fun s)))
+ (if ann (list s ann) s)))
+ completions))))
+
+ (with-current-buffer standard-output
+ (setq-local completion-base-position
+ (list (+ start base-size)
+ ;; FIXME: We should pay attention to completion
+ ;; boundaries here, but currently
+ ;; completion-all-completions does not give us the
+ ;; necessary information.
+ end))
+ (setq-local completion-list-insert-choice-function
+ (let ((ctable minibuffer-completion-table)
+ (cpred minibuffer-completion-predicate)
+ (cprops completion-extra-properties))
+ (lambda (start end choice)
+ (unless (or (zerop (length prefix))
+ (equal prefix
+ (buffer-substring-no-properties
+ (max (point-min)
+ (- start (length prefix)))
+ start)))
+ (message "*Completions* out of date"))
+ ;; FIXME: Use `md' to do quoting&terminator here.
+ (completion--replace start end choice)
+ (let* ((minibuffer-completion-table ctable)
+ (minibuffer-completion-predicate cpred)
+ (completion-extra-properties cprops)
+ (result (concat prefix choice))
+ (bounds (completion-boundaries
+ result ctable cpred "")))
+ ;; If the completion introduces a new field, then
+ ;; completion is not finished.
+ (completion--done result
+ (if (eq (car bounds) (length result))
+ 'exact 'finished)))))))
+
+ (display-completion-list completions nil group-fun)))))
+ nil)))
nil))
(defun minibuffer-hide-completions ()
@@ -2065,6 +2314,11 @@ variables.")
(defun exit-minibuffer ()
"Terminate this minibuffer argument."
(interactive)
+ (when (minibufferp)
+ (when (not (minibuffer-innermost-command-loop-p))
+ (error "%s" "Not in most nested command loop"))
+ (when (not (innermost-minibuffer-p))
+ (error "%s" "Not in most nested minibuffer")))
;; If the command that uses this has made modifications in the minibuffer,
;; we don't want them to cause deactivation of the mark in the original
;; buffer.
@@ -2074,6 +2328,15 @@ variables.")
(setq deactivate-mark nil)
(throw 'exit nil))
+(defun minibuffer-quit-recursive-edit ()
+ "Quit the command that requested this recursive edit without error.
+Like `abort-recursive-edit' without aborting keyboard macro
+execution."
+ ;; See Info node `(elisp)Recursive Editing' for an explanation of
+ ;; throwing a function to `exit'.
+ (throw 'exit (lambda ()
+ (signal 'minibuffer-quit nil))))
+
(defun self-insert-and-exit ()
"Terminate minibuffer input."
(interactive)
@@ -2340,11 +2603,13 @@ The completion method is determined by `completion-at-point-functions'."
;;; Key bindings.
(let ((map minibuffer-local-map))
- (define-key map "\C-g" 'abort-recursive-edit)
+ (define-key map "\C-g" 'abort-minibuffers)
(define-key map "\M-<" 'minibuffer-beginning-of-buffer)
- (define-key map "\r" 'exit-minibuffer)
- (define-key map "\n" 'exit-minibuffer))
+ ;; Put RET last so that it is shown in doc strings in preference to
+ ;; C-j, when using the \\[exit-minibuffer] notation.
+ (define-key map "\n" 'exit-minibuffer)
+ (define-key map "\r" 'exit-minibuffer))
(defvar minibuffer-local-completion-map
(let ((map (make-sparse-keymap)))
@@ -2357,6 +2622,7 @@ The completion method is determined by `completion-at-point-functions'."
(define-key map "?" 'minibuffer-completion-help)
(define-key map [prior] 'switch-to-completions)
(define-key map "\M-v" 'switch-to-completions)
+ (define-key map "\M-g\M-c" 'switch-to-completions)
map)
"Local keymap for minibuffer input with completion.")
@@ -2376,15 +2642,36 @@ The completion method is determined by `completion-at-point-functions'."
Gets combined either with `minibuffer-local-completion-map' or
with `minibuffer-local-must-match-map'.")
-(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
- 'minibuffer-local-filename-must-match-map "23.1")
(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
-(let ((map minibuffer-local-ns-map))
- (define-key map " " 'exit-minibuffer)
- (define-key map "\t" 'exit-minibuffer)
- (define-key map "?" 'self-insert-and-exit))
+(defvar minibuffer-local-ns-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map " " #'exit-minibuffer)
+ (define-key map "\t" #'exit-minibuffer)
+ (define-key map "?" #'self-insert-and-exit)
+ map)
+ "Local keymap for the minibuffer when spaces are not allowed.")
+
+(defun read-no-blanks-input (prompt &optional initial inherit-input-method)
+ "Read a string from the terminal, not allowing blanks.
+Prompt with PROMPT. Whitespace terminates the input. If INITIAL is
+non-nil, it should be a string, which is used as initial input, with
+point positioned at the end, so that SPACE will accept the input.
+\(Actually, INITIAL can also be a cons of a string and an integer.
+Such values are treated as in `read-from-minibuffer', but are normally
+not useful in this function.)
+
+Third arg INHERIT-INPUT-METHOD, if non-nil, means the minibuffer inherits
+the current input method and the setting of`enable-multibyte-characters'.
+
+If `inhibit-interaction' is non-nil, this function will signal an
+`inhibited-interaction' error."
+ (read-from-minibuffer prompt initial minibuffer-local-ns-map
+ nil minibuffer-history nil inherit-input-method))
+
+;;; Major modes for the minibuffer
(defvar minibuffer-inactive-mode-map
(let ((map (make-keymap)))
@@ -2411,6 +2698,18 @@ not active.")
"Major mode to use in the minibuffer when it is not active.
This is only used when the minibuffer area has no active minibuffer.")
+(defvaralias 'minibuffer-mode-map 'minibuffer-local-map)
+
+(define-derived-mode minibuffer-mode nil "Minibuffer"
+ "Major mode used for active minibuffers.
+
+For customizing this mode, it is better to use
+`minibuffer-setup-hook' and `minibuffer-exit-hook' rather than
+the mode hook of this mode."
+ :syntax-table nil
+ :abbrev-table nil
+ :interactive nil)
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
@@ -2551,11 +2850,6 @@ same as `substitute-in-file-name'."
all))))))
(file-error nil))) ;PCM often calls with invalid directories.
-(defvar read-file-name-predicate nil
- "Current predicate used by `read-file-name-internal'.")
-(make-obsolete-variable 'read-file-name-predicate
- "use the regular PRED argument" "23.2")
-
(defun completion--sifn-requote (upos qstr)
;; We're looking for `qpos' such that:
;; (equal (substring (substitute-in-file-name qstr) 0 upos)
@@ -2793,7 +3087,7 @@ See `read-file-name' for the meaning of the arguments."
(minibuffer-maybe-quote-filename dir)))
(initial (cons (minibuffer-maybe-quote-filename initial) 0)))))
- (let ((completion-ignore-case read-file-name-completion-ignore-case)
+ (let ((ignore-case read-file-name-completion-ignore-case)
(minibuffer-completing-file-name t)
(pred (or predicate 'file-exists-p))
(add-to-history nil))
@@ -2821,10 +3115,11 @@ See `read-file-name' for the meaning of the arguments."
minibuffer-default))
(setq minibuffer-default
(cdr-safe minibuffer-default)))
+ (setq-local completion-ignore-case ignore-case)
;; 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)
+ (setq-local minibuffer-default-add-function
(lambda ()
(with-current-buffer
(window-buffer (minibuffer-selected-window))
@@ -2876,6 +3171,7 @@ See `read-file-name' for the meaning of the arguments."
(unless val (error "No file name specified"))
(if (and default-filename
+ (not (file-remote-p dir))
(string-equal val (if (consp insdef) (car insdef) insdef)))
(setq val default-filename))
(setq val (substitute-in-file-name val))
@@ -3113,13 +3409,14 @@ or a symbol, see `completion-pcm--merge-completions'."
(let ((n '()))
(while p
(pcase p
- (`(,(or 'any 'any-delim) point . ,rest) (setq p `(point . ,rest)))
- ;; This is not just a performance improvement: it also turns
- ;; a terminating `point' into an implicit `any', which
- ;; affects the final position of point (because `point' gets
- ;; turned into a non-greedy ".*?" regexp whereas we need
- ;; it the be greedy when it's at the end, see bug#38458).
- (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
+ (`(,(or 'any 'any-delim) ,(or 'any 'point) . ,_)
+ (setq p (cdr p)))
+ ;; This is not just a performance improvement: it turns a
+ ;; terminating `point' into an implicit `any', which affects
+ ;; the final position of point (because `point' gets turned
+ ;; into a non-greedy ".*?" regexp whereas we need it to be
+ ;; greedy when it's at the end, see bug#38458).
+ (`(point) (setq p nil)) ;Implicit terminating `any'.
(_ (push (pop p) n))))
(nreverse n)))
@@ -3198,10 +3495,18 @@ than the latter (which has two \"holes\" and three
one-letter-long matches).")
(defun completion-pcm--hilit-commonality (pattern completions)
+ "Show where and how well PATTERN matches COMPLETIONS.
+PATTERN, a list of symbols and strings as seen
+`completion-pcm--merge-completions', is assumed to match every
+string in COMPLETIONS. Return a deep copy of COMPLETIONS where
+each string is propertized with `completion-score', a number
+between 0 and 1, and with faces `completions-common-part',
+`completions-first-difference' in the relevant segments."
(when completions
(let* ((re (completion-pcm--pattern->regex pattern 'group))
(point-idx (completion-pcm--pattern-point-idx pattern))
- (case-fold-search completion-ignore-case))
+ (case-fold-search completion-ignore-case)
+ last-md)
(mapcar
(lambda (str)
;; Don't modify the string itself.
@@ -3209,12 +3514,12 @@ one-letter-long matches).")
(unless (string-match re str)
(error "Internal error: %s does not match %s" re str))
(let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
- (md (match-data))
- (start (pop md))
- (end (pop md))
- (len (length str))
- ;; To understand how this works, consider these bad
- ;; ascii(tm) diagrams showing how the pattern "foo"
+ (match-end (match-end 0))
+ (md (cddr (setq last-md (match-data t last-md))))
+ (from 0)
+ (end (length str))
+ ;; To understand how this works, consider these simple
+ ;; ascii diagrams showing how the pattern "foo"
;; flex-matches "fabrobazo", "fbarbazoo" and
;; "barfoobaz":
@@ -3250,9 +3555,12 @@ one-letter-long matches).")
(score-numerator 0)
(score-denominator 0)
(last-b 0)
- (update-score
+ (update-score-and-face
(lambda (a b)
- "Update score variables given match range (A B)."
+ "Update score and face given match range (A B)."
+ (add-face-text-property a b
+ 'completions-common-part
+ nil str)
(setq
score-numerator (+ score-numerator (- b a)))
(unless (or (= a last-b)
@@ -3266,19 +3574,15 @@ one-letter-long matches).")
flex-score-match-tightness)))))
(setq
last-b b))))
- (funcall update-score start start)
(while md
- (funcall update-score start (car md))
- (add-face-text-property
- start (pop md)
- 'completions-common-part
- nil str)
- (setq start (pop md)))
- (funcall update-score len len)
- (add-face-text-property
- start end
- 'completions-common-part
- nil str)
+ (funcall update-score-and-face from (pop md))
+ (setq from (pop md)))
+ ;; If `pattern' doesn't have an explicit trailing any, the
+ ;; regex `re' won't produce match data representing the
+ ;; region after the match. We need to account to account
+ ;; for that extra bit of match (bug#42149).
+ (unless (= from match-end)
+ (funcall update-score-and-face from match-end))
(if (> (length str) pos)
(add-face-text-property
pos (1+ pos)
@@ -3287,7 +3591,7 @@ one-letter-long matches).")
(unless (zerop (length str))
(put-text-property
0 1 'completion-score
- (/ score-numerator (* len (1+ score-denominator)) 1.0) str)))
+ (/ score-numerator (* end (1+ score-denominator)) 1.0) str)))
str)
completions))))
@@ -3759,13 +4063,7 @@ See `completing-read' for the meaning of the arguments."
;; `read-from-minibuffer' uses 1-based index.
(1+ (cdr initial-input)))))
- (let* ((minibuffer-completion-table collection)
- (minibuffer-completion-predicate predicate)
- ;; FIXME: Remove/rename this var, see the next one.
- (minibuffer-completion-confirm (unless (eq require-match t)
- require-match))
- (minibuffer--require-match require-match)
- (base-keymap (if require-match
+ (let* ((base-keymap (if require-match
minibuffer-local-must-match-map
minibuffer-local-completion-map))
(keymap (if (memq minibuffer-completing-file-name '(nil lambda))
@@ -3778,8 +4076,17 @@ See `completing-read' for the meaning of the arguments."
;; in minibuffer-local-filename-completion-map can
;; override bindings in base-keymap.
base-keymap)))
- (result (read-from-minibuffer prompt initial-input keymap
- nil hist def inherit-input-method)))
+ (result
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local minibuffer-completion-table collection)
+ (setq-local minibuffer-completion-predicate predicate)
+ ;; FIXME: Remove/rename this var, see the next one.
+ (setq-local minibuffer-completion-confirm
+ (unless (eq require-match t) require-match))
+ (setq-local minibuffer--require-match require-match))
+ (read-from-minibuffer prompt initial-input keymap
+ nil hist def inherit-input-method))))
(when (and (equal result "") def)
(setq result (if (consp def) (car def) def)))
result))
@@ -3862,6 +4169,44 @@ the minibuffer was activated, and execute the forms."
(with-minibuffer-selected-window
(scroll-other-window-down arg)))
+(defcustom minibuffer-default-prompt-format " (default %s)"
+ "Format string used to output \"default\" values.
+When prompting for input, there will often be a default value,
+leading to prompts like \"Number of articles (default 50): \".
+The \"default\" part of that prompt is controlled by this
+variable, and can be set to, for instance, \" [%s]\" if you want
+a shorter displayed prompt, or \"\", if you don't want to display
+the default at all.
+
+This variable is used by the `format-prompt' function."
+ :version "28.1"
+ :type 'string)
+
+(defun format-prompt (prompt default &rest format-args)
+ "Format PROMPT with DEFAULT according to `minibuffer-default-prompt-format'.
+If FORMAT-ARGS is nil, PROMPT is used as a plain string. If
+FORMAT-ARGS is non-nil, PROMPT is used as a format control
+string, and FORMAT-ARGS are the arguments to be substituted into
+it. See `format' for details.
+
+If DEFAULT is a list, the first element is used as the default.
+If not, the element is used as is.
+
+If DEFAULT is nil or an empty string, no \"default value\" string
+is included in the return value."
+ (concat
+ (if (null format-args)
+ prompt
+ (apply #'format prompt format-args))
+ (and default
+ (or (not (stringp default))
+ (length> default 0))
+ (format minibuffer-default-prompt-format
+ (if (consp default)
+ (car default)
+ default)))
+ ": "))
+
(provide 'minibuffer)
;;; minibuffer.el ends here
diff --git a/lisp/misc.el b/lisp/misc.el
index cc2bbe99458..39ec9497d7f 100644
--- a/lisp/misc.el
+++ b/lisp/misc.el
@@ -1,4 +1,4 @@
-;;; misc.el --- some nonstandard editing and utility commands for Emacs
+;;; misc.el --- some nonstandard editing and utility commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1989, 2001-2021 Free Software Foundation, Inc.
@@ -41,7 +41,7 @@ The characters copied are inserted in the buffer before point."
(save-excursion
(beginning-of-line)
(backward-char 1)
- (skip-chars-backward "\ \t\n")
+ (skip-chars-backward " \t\n")
(move-to-column cc)
;; Default is enough to copy the whole rest of the line.
(setq n (if arg (prefix-numeric-value arg) (point-max)))
@@ -69,7 +69,9 @@ The characters copied are inserted in the buffer before point."
Case is ignored if `case-fold-search' is non-nil in the current buffer.
Goes backward if ARG is negative; error if CHAR not found.
Ignores CHAR at point."
- (interactive "p\ncZap up to char: ")
+ (interactive (list (prefix-numeric-value current-prefix-arg)
+ (read-char-from-minibuffer "Zap up to char: "
+ nil 'read-char-history)))
(let ((direction (if (>= arg 0) 1 -1)))
(kill-region (point)
(progn
@@ -125,7 +127,7 @@ upper atmosphere. These cause momentary pockets of higher-pressure
air to form, which act as lenses that deflect incoming cosmic rays,
focusing them to strike the drive platter and flip the desired bit.
You can type `M-x butterfly C-M-c' to run it. This is a permuted
-variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'."
+variation of `C-x M-c M-butterfly' from url `https://xkcd.com/378/'."
(interactive)
(if (yes-or-no-p "Do you really want to unleash the powers of the butterfly? ")
(progn
@@ -137,7 +139,7 @@ variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'."
(sit-for (* 5 (/ (abs (random)) (float most-positive-fixnum))))
(message "Successfully flipped one bit!"))
(message "Well, then go to xkcd.com!")
- (browse-url "http://xkcd.com/378/")))
+ (browse-url "https://xkcd.com/378/")))
;; A command to list dynamically loaded libraries. This useful in
;; environments where dynamic-library-alist is used, i.e., Windows
@@ -162,7 +164,7 @@ Internal use only."
"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))
+ (let ((max-id-len 7) (max-name-len 11))
(dolist (lib dynamic-library-alist)
(let ((id-len (length (symbol-name (car lib))))
(name-len (apply 'max (mapcar 'length (cdr lib)))))
@@ -181,7 +183,9 @@ Internal use only."
(push (list id (vector (symbol-name id)
(list-dynamic-libraries--loaded from)
(mapconcat 'identity (cdr lib) ", ")))
- tabulated-list-entries)))))
+ tabulated-list-entries))))
+ (when (not dynamic-library-alist)
+ (message "No dynamic libraries found")))
;;;###autoload
(defun list-dynamic-libraries (&optional loaded-only-p buffer)
diff --git a/lisp/misearch.el b/lisp/misearch.el
index 3fd4e1f1e16..7f3e981bb0e 100644
--- a/lisp/misearch.el
+++ b/lisp/misearch.el
@@ -1,4 +1,4 @@
-;;; misearch.el --- isearch extensions for multi-buffer search
+;;; misearch.el --- isearch extensions for multi-buffer search -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -28,6 +28,8 @@
;;; Code:
+(require 'cl-lib)
+
;;; Search multiple buffers
;;;###autoload (add-hook 'isearch-mode-hook 'multi-isearch-setup)
@@ -40,8 +42,7 @@
(defcustom multi-isearch-search t
"Non-nil enables searching multiple related buffers, in certain modes."
:type 'boolean
- :version "23.1"
- :group 'multi-isearch)
+ :version "23.1")
(defcustom multi-isearch-pause t
"A choice defining where to pause the search.
@@ -53,8 +54,7 @@ If t, pause in all buffers that contain the search string."
(const :tag "Don't pause" nil)
(const :tag "Only in initial buffer" initial)
(const :tag "All buffers" t))
- :version "23.1"
- :group 'multi-isearch)
+ :version "23.1")
;;;###autoload
(defvar multi-isearch-next-buffer-function nil
@@ -119,10 +119,10 @@ Intended to be added to `isearch-mode-hook'."
(default-value 'isearch-wrap-function)
multi-isearch-orig-push-state
(default-value 'isearch-push-state-function))
- (setq-default isearch-search-fun-function 'multi-isearch-search-fun
- isearch-wrap-function 'multi-isearch-wrap
- isearch-push-state-function 'multi-isearch-push-state)
- (add-hook 'isearch-mode-end-hook 'multi-isearch-end)))
+ (setq-default isearch-search-fun-function #'multi-isearch-search-fun
+ isearch-wrap-function #'multi-isearch-wrap
+ isearch-push-state-function #'multi-isearch-push-state)
+ (add-hook 'isearch-mode-end-hook #'multi-isearch-end)))
(defun multi-isearch-end ()
"Clean up the multi-buffer search after terminating isearch."
@@ -133,7 +133,7 @@ Intended to be added to `isearch-mode-hook'."
(setq-default isearch-search-fun-function multi-isearch-orig-search-fun
isearch-wrap-function multi-isearch-orig-wrap
isearch-push-state-function multi-isearch-orig-push-state)
- (remove-hook 'isearch-mode-end-hook 'multi-isearch-end))
+ (remove-hook 'isearch-mode-end-hook #'multi-isearch-end))
(defun multi-isearch-search-fun ()
"Return the proper search function, for isearch in multiple buffers."
@@ -190,10 +190,10 @@ the initial buffer."
(if (or (null multi-isearch-pause)
(and multi-isearch-pause multi-isearch-current-buffer))
(progn
- (switch-to-buffer
- (setq multi-isearch-current-buffer
- (funcall multi-isearch-next-buffer-current-function
- (current-buffer) t)))
+ (setq multi-isearch-current-buffer
+ (funcall multi-isearch-next-buffer-current-function
+ (current-buffer) t))
+ (multi-isearch-switch-buffer)
(goto-char (if isearch-forward (point-min) (point-max))))
(setq multi-isearch-current-buffer (current-buffer))
(setq isearch-wrapped nil)))
@@ -202,14 +202,25 @@ the initial buffer."
"Save a function restoring the state of multiple buffers search.
Save the current buffer to the additional state parameter in the
search status stack."
- `(lambda (cmd)
- (multi-isearch-pop-state cmd ,(current-buffer))))
+ (let ((buf (current-buffer)))
+ (lambda (cmd)
+ (multi-isearch-pop-state cmd buf))))
(defun multi-isearch-pop-state (_cmd buffer)
- "Restore the multiple buffers search state.
+ "Restore the multiple buffers search state in BUFFER.
Switch to the buffer restored from the search status stack."
- (unless (equal buffer (current-buffer))
- (switch-to-buffer (setq multi-isearch-current-buffer buffer))))
+ (unless (eq buffer (current-buffer))
+ (setq multi-isearch-current-buffer buffer)
+ (multi-isearch-switch-buffer)))
+
+;;;###autoload
+(defun multi-isearch-switch-buffer ()
+ "Switch to the next buffer in multi-buffer search."
+ (when (and (buffer-live-p multi-isearch-current-buffer)
+ (not (eq multi-isearch-current-buffer (current-buffer))))
+ (setq isearch-mode nil)
+ (switch-to-buffer multi-isearch-current-buffer)
+ (setq isearch-mode " M-Isearch")))
;;; Global multi-buffer search invocations
@@ -236,13 +247,9 @@ set in `multi-isearch-buffers' or `multi-isearch-buffers-regexp'."
(buf nil)
(ido-ignore-item-temp-list bufs))
(while (not (string-equal
- (setq buf (read-buffer
- (if (eq read-buffer-function #'ido-read-buffer)
- "Next buffer to search (C-j to end): "
- "Next buffer to search (RET to end): ")
- nil t))
+ (setq buf (read-buffer (multi-occur--prompt) nil t))
""))
- (add-to-list 'bufs buf)
+ (cl-pushnew buf bufs :test #'equal)
(setq ido-ignore-item-temp-list bufs))
(nreverse bufs)))
@@ -326,7 +333,7 @@ Every next/previous file in the defined sequence is visited by
default-directory
default-directory))
default-directory))
- (add-to-list 'files file))
+ (cl-pushnew file files :test #'equal))
(nreverse files)))
;; A regexp is not the same thing as a file glob - does this matter?
@@ -385,7 +392,7 @@ whose file names match the specified wildcard."
(defun multi-isearch-unload-function ()
"Remove autoloaded variables from `unload-function-defs-list'.
Also prevent the feature from being reloaded via `isearch-mode-hook'."
- (remove-hook 'isearch-mode-hook 'multi-isearch-setup)
+ (remove-hook 'isearch-mode-hook #'multi-isearch-setup)
(let ((defs (list (car unload-function-defs-list)))
(auto '(multi-isearch-next-buffer-function
multi-isearch-next-buffer-current-function
@@ -399,7 +406,7 @@ Also prevent the feature from being reloaded via `isearch-mode-hook'."
;; .
nil))
-(defalias 'misearch-unload-function 'multi-isearch-unload-function)
+(defalias 'misearch-unload-function #'multi-isearch-unload-function)
(provide 'multi-isearch)
diff --git a/lisp/mouse-copy.el b/lisp/mouse-copy.el
index e48722ef944..14fbb51b27e 100644
--- a/lisp/mouse-copy.el
+++ b/lisp/mouse-copy.el
@@ -1,4 +1,4 @@
-;;; mouse-copy.el --- one-click text copy and move
+;;; mouse-copy.el --- one-click text copy and move -*- lexical-binding: t -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -55,9 +55,6 @@
;; <twurgler@goodyear.com> is similar to mouse-drag-throw, but
;; doesn't pass clicks through.
;;
-;; These functions have been tested in emacs version 19.30,
-;; and this package has run in the past on 19.25-19.29.
-;;
;; Originally mouse-copy was part of a larger package.
;; As of 11 July 96 the scrolling functions were split out
;; in preparation for incorporation into (the future) emacs-19.32.
@@ -216,8 +213,7 @@ by johnh@ficus.cs.ucla.edu."
(if (mouse-drag-secondary start-event)
(progn
(mouse-kill-preserving-secondary)
- (insert (gui-get-selection 'SECONDARY))))
-)
+ (insert (gui-get-selection 'SECONDARY)))))
(provide 'mouse-copy)
diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el
index f6612600bdd..b424b6edfe8 100644
--- a/lisp/mouse-drag.el
+++ b/lisp/mouse-drag.el
@@ -1,4 +1,4 @@
-;;; mouse-drag.el --- use mouse-2 to do a new style of scrolling
+;;; mouse-drag.el --- use mouse-2 to do a new style of scrolling -*- lexical-binding: t -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
@@ -70,9 +70,6 @@
;; <twurgler@goodyear.com> is similar to mouse-drag-throw, but
;; doesn't pass clicks through.
;;
-;; These functions have been tested in emacs version 19.30,
-;; and this package has run in the past on 19.25-19.29.
-;;
;; Originally mouse-drag was part of a larger package.
;; As of 11 July 96 the scrolling functions were split out
;; in preparation for incorporation into (the future) emacs-19.32.
@@ -225,7 +222,7 @@ To test this function, evaluate:
;; Don't change the mouse pointer shape while we drag.
(setq track-mouse 'dragging)
(while (progn
- (setq event (read-event)
+ (setq event (read--potential-mouse-event)
end (event-end event)
row (cdr (posn-col-row end))
col (car (posn-col-row end)))
@@ -286,7 +283,7 @@ To test this function, evaluate:
window-last-col (- (window-width) 2))
(track-mouse
(while (progn
- (setq event (read-event)
+ (setq event (read--potential-mouse-event)
end (event-end event)
row (cdr (posn-col-row end))
col (car (posn-col-row end)))
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 72ad77c6344..89e5d7c48a3 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -49,7 +49,10 @@
"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."
+addition to mouse drags.
+
+This variable applies only to mouse adjustments in Emacs, not
+selecting and adjusting regions in other windows."
:type 'boolean
:version "24.1")
@@ -116,7 +119,9 @@ Expects to be bound to `(double-)mouse-1' in `key-translation-map'."
(time-since (cdr mouse--last-down))
(/ (abs mouse-1-click-follows-link) 1000.0))))))
(eq (car mouse--last-down)
- (event-convert-list (list 'down (car-safe last-input-event))))
+ (event-convert-list
+ `(down ,@(event-modifiers last-input-event)
+ ,(event-basic-type last-input-event))))
(let* ((action (mouse-on-link-p (event-start last-input-event))))
(when (and action
(or mouse-1-click-in-non-selected-windows
@@ -271,34 +276,6 @@ not it is actually displayed."
local-menu
minor-mode-menus)))
-(defun mouse-major-mode-menu (event &optional prefix)
- "Pop up a mode-specific menu of mouse commands.
-Default to the Edit menu if the major mode doesn't define a menu."
- (declare (obsolete mouse-menu-major-mode-map "23.1"))
- (interactive "@e\nP")
- (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
- (popup-menu (mouse-menu-major-mode-map) event prefix))
-
-(defun mouse-popup-menubar (event prefix)
- "Pop up a menu equivalent to the menu bar for keyboard EVENT with PREFIX.
-The contents are the items that would be in the menu bar whether or
-not it is actually displayed."
- (declare (obsolete mouse-menu-bar-map "23.1"))
- (interactive "@e \nP")
- (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
- (popup-menu (mouse-menu-bar-map) (unless (integerp event) event) prefix))
-
-(defun mouse-popup-menubar-stuff (event prefix)
- "Popup a menu like either `mouse-major-mode-menu' or `mouse-popup-menubar'.
-Use the former if the menu bar is showing, otherwise the latter."
- (declare (obsolete nil "23.1"))
- (interactive "@e\nP")
- (run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
- (popup-menu
- (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0))
- (mouse-menu-bar-map)
- (mouse-menu-major-mode-map))
- event prefix))
;; Commands that operate on windows.
@@ -438,7 +415,7 @@ must be one of the symbols `header', `mode', or `vertical'."
(when (window-live-p (setq posn-window (posn-window start)))
;; Add left edge of `posn-window' to `position'.
(setq position (+ (window-pixel-left posn-window) position))
- (unless (nth 1 start)
+ (unless (posn-area start)
;; Add width of objects on the left of the text area to
;; `position'.
(when (eq (window-current-scroll-bars posn-window) 'left)
@@ -517,9 +494,11 @@ must be one of the symbols `header', `mode', or `vertical'."
(define-key map [header-line] map)
(define-key map [vertical-line] map)
;; ... and some maybe even with a right- or bottom-divider
- ;; prefix.
+ ;; or left- or right-margin prefix ...
(define-key map [right-divider] map)
(define-key map [bottom-divider] map)
+ (define-key map [left-margin] map)
+ (define-key map [right-margin] map)
map)
t (lambda () (setq track-mouse old-track-mouse)))))))
@@ -552,7 +531,7 @@ frame instead."
(not (eq (window-frame minibuffer-window) frame))))
;; Drag frame when the window is on the bottom of its frame and
;; there is no minibuffer window below.
- (mouse-drag-frame start-event 'move)))))
+ (mouse-drag-frame-move start-event)))))
(defun mouse-drag-header-line (start-event)
"Change the height of a window by dragging on its header line.
@@ -569,7 +548,19 @@ the frame instead."
(mouse-drag-line start-event 'header)
(let ((frame (window-frame window)))
(when (frame-parameter frame 'drag-with-header-line)
- (mouse-drag-frame start-event 'move))))))
+ (mouse-drag-frame-move start-event))))))
+
+(defun mouse-drag-tab-line (start-event)
+ "Drag frame with tab line in its topmost window.
+START-EVENT is the starting mouse event of the drag action."
+ (interactive "e")
+ (let* ((start (event-start start-event))
+ (window (posn-window start)))
+ (when (and (window-live-p window)
+ (window-at-side-p window 'top))
+ (let ((frame (window-frame window)))
+ (when (frame-parameter frame 'drag-with-tab-line)
+ (mouse-drag-frame-move start-event))))))
(defun mouse-drag-vertical-line (start-event)
"Change the width of a window by dragging on a vertical line.
@@ -577,46 +568,138 @@ START-EVENT is the starting mouse event of the drag action."
(interactive "e")
(mouse-drag-line start-event 'vertical))
-(defun mouse-resize-frame (frame x-diff y-diff &optional x-move y-move)
- "Helper function for `mouse-drag-frame'."
- (let* ((frame-x-y (frame-position frame))
- (frame-x (car frame-x-y))
- (frame-y (cdr frame-x-y))
- alist)
- (if (> x-diff 0)
- (when x-move
- (setq x-diff (min x-diff frame-x))
- (setq x-move (- frame-x x-diff)))
- (let* ((min-width (frame-windows-min-size frame t nil t))
- (min-diff (max 0 (- (frame-inner-width frame) min-width))))
- (setq x-diff (max x-diff (- min-diff)))
- (when x-move
- (setq x-move (+ frame-x (- x-diff))))))
-
- (if (> y-diff 0)
- (when y-move
- (setq y-diff (min y-diff frame-y))
- (setq y-move (- frame-y y-diff)))
- (let* ((min-height (frame-windows-min-size frame nil nil t))
- (min-diff (max 0 (- (frame-inner-height frame) min-height))))
- (setq y-diff (max y-diff (- min-diff)))
- (when y-move
- (setq y-move (+ frame-y (- y-diff))))))
-
- (unless (zerop x-diff)
- (when x-move
- (push `(left . ,x-move) alist))
- (push `(width . (text-pixels . ,(+ (frame-text-width frame) x-diff)))
- alist))
- (unless (zerop y-diff)
- (when y-move
- (push `(top . ,y-move) alist))
- (push `(height . (text-pixels . ,(+ (frame-text-height frame) y-diff)))
- alist))
- (when alist
- (modify-frame-parameters frame alist))))
-
-(defun mouse-drag-frame (start-event part)
+(defun mouse-drag-frame-resize (start-event part)
+ "Drag a frame or one of its edges with the mouse.
+START-EVENT is the starting mouse event of the drag action. Its
+position window denotes the frame that will be dragged.
+
+PART specifies the part that has been dragged and must be one of
+the symbols `left', `top', `right', `bottom', `top-left',
+`top-right', `bottom-left', `bottom-right' to drag an internal
+border or edge. If PART equals `move', this means to move the
+frame with the mouse."
+ ;; Give temporary modes such as isearch a chance to turn off.
+ (run-hooks 'mouse-leave-buffer-hook)
+ (let* ((echo-keystrokes 0)
+ (start (event-start start-event))
+ (window (posn-window start))
+ ;; FRAME is the frame to drag.
+ (frame (if (window-live-p window)
+ (window-frame window)
+ window))
+ ;; Initial "first" frame position and size. While dragging we
+ ;; base all calculations against that size and position.
+ (first-pos (frame-position frame))
+ (first-left (car first-pos))
+ (first-top (cdr first-pos))
+ (first-width (frame-text-width frame))
+ (first-height (frame-text-height frame))
+ ;; Don't let FRAME become less large than the size needed to
+ ;; fit all of its windows.
+ (min-text-width
+ (+ (frame-windows-min-size frame t nil t)
+ (- (frame-inner-width frame) first-width)))
+ (min-text-height
+ (+ (frame-windows-min-size frame nil nil t)
+ (- (frame-inner-height frame) first-height)))
+ ;; PARENT is the parent frame of FRAME or, if FRAME is a
+ ;; top-level frame, FRAME's workarea.
+ (parent (frame-parent frame))
+ (parent-edges
+ (if parent
+ (frame-edges parent)
+ (let* ((attributes
+ (car (display-monitor-attributes-list)))
+ (workarea (assq 'workarea attributes)))
+ (and workarea
+ `(,(nth 1 workarea) ,(nth 2 workarea)
+ ,(+ (nth 1 workarea) (nth 3 workarea))
+ ,(+ (nth 2 workarea) (nth 4 workarea)))))))
+ (parent-left (and parent-edges (nth 0 parent-edges)))
+ (parent-top (and parent-edges (nth 1 parent-edges)))
+ (parent-right (and parent-edges (nth 2 parent-edges)))
+ (parent-bottom (and parent-edges (nth 3 parent-edges)))
+ ;; Drag types. drag-left/drag-right and drag-top/drag-bottom
+ ;; are mutually exclusive.
+ (drag-left (memq part '(bottom-left left top-left)))
+ (drag-top (memq part '(top-left top top-right)))
+ (drag-right (memq part '(top-right right bottom-right)))
+ (drag-bottom (memq part '(bottom-right bottom bottom-left)))
+ ;; Initial "first" mouse position. While dragging we base all
+ ;; calculations against that position.
+ (first-x-y (mouse-absolute-pixel-position))
+ (first-x (car first-x-y))
+ (first-y (cdr first-x-y))
+ (exitfun nil)
+ (move
+ (lambda (event)
+ (interactive "e")
+ (when (consp event)
+ (let* ((last-x-y (mouse-absolute-pixel-position))
+ (last-x (car last-x-y))
+ (last-y (cdr last-x-y))
+ (left (- last-x first-x))
+ (top (- last-y first-y))
+ alist)
+ ;; We never want to warp the mouse position here. When
+ ;; moving the mouse leftward or upward, then with a wide
+ ;; border the calculated left or top position of the
+ ;; frame could drop to a value less than zero depending
+ ;; on where precisely the mouse within the border. We
+ ;; guard against this by never allowing the frame to
+ ;; move to a position less than zero here. No such
+ ;; precautions are used for the right and bottom borders
+ ;; so with a large internal border parts of that border
+ ;; may disappear.
+ (when (and drag-left (>= last-x parent-left)
+ (>= (- first-width left) min-text-width))
+ (push `(left . ,(max (+ first-left left) 0)) alist)
+ (push `(width . (text-pixels . ,(- first-width left)))
+ alist))
+ (when (and drag-top (>= last-y parent-top)
+ (>= (- first-height top) min-text-height))
+ (push `(top . ,(max 0 (+ first-top top))) alist)
+ (push `(height . (text-pixels . ,(- first-height top)))
+ alist))
+ (when (and drag-right (<= last-x parent-right)
+ (>= (+ first-width left) min-text-width))
+ (push `(width . (text-pixels . ,(+ first-width left)))
+ alist))
+ (when (and drag-bottom (<= last-y parent-bottom)
+ (>= (+ first-height top) min-text-height))
+ (push `(height . (text-pixels . ,(+ first-height top)))
+ alist))
+ (modify-frame-parameters frame alist)))))
+ (old-track-mouse track-mouse))
+ ;; Start tracking. The special value 'dragging' signals the
+ ;; display engine to freeze the mouse pointer shape for as long
+ ;; as we drag.
+ (setq track-mouse 'dragging)
+ ;; Loop reading events and sampling the position of the mouse.
+ (setq exitfun
+ (set-transient-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [switch-frame] #'ignore)
+ (define-key map [select-window] #'ignore)
+ (define-key map [scroll-bar-movement] #'ignore)
+ (define-key map [mouse-movement] move)
+ ;; Swallow drag-mouse-1 events to avoid selecting some other window.
+ (define-key map [drag-mouse-1]
+ (lambda () (interactive) (funcall exitfun)))
+ ;; Some of the events will of course end up looked up
+ ;; with a mode-line, header-line or vertical-line prefix ...
+ (define-key map [mode-line] map)
+ (define-key map [header-line] map)
+ (define-key map [tab-line] map)
+ (define-key map [vertical-line] map)
+ ;; ... and some maybe even with a right- or bottom-divider
+ ;; prefix.
+ (define-key map [right-divider] map)
+ (define-key map [bottom-divider] map)
+ map)
+ t (lambda () (setq track-mouse old-track-mouse))))))
+
+(defun mouse-drag-frame-move (start-event)
"Drag a frame or one of its edges with the mouse.
START-EVENT is the starting mouse event of the drag action. Its
position window denotes the frame that will be dragged.
@@ -635,9 +718,14 @@ frame with the mouse."
(frame (if (window-live-p window)
(window-frame window)
window))
- (width (frame-native-width frame))
- (height (frame-native-height frame))
- ;; PARENT is the parent frame of FRAME or, if FRAME is a
+ (native-width (frame-native-width frame))
+ (native-height (frame-native-height frame))
+ ;; Initial "first" frame position and size. While dragging we
+ ;; base all calculations against that size and position.
+ (first-pos (frame-position frame))
+ (first-left (car first-pos))
+ (first-top (cdr first-pos))
+ ;; PARENT is the parent frame of FRAME or, if FRAME is a
;; top-level frame, FRAME's workarea.
(parent (frame-parent frame))
(parent-edges
@@ -654,19 +742,16 @@ frame with the mouse."
(parent-top (and parent-edges (nth 1 parent-edges)))
(parent-right (and parent-edges (nth 2 parent-edges)))
(parent-bottom (and parent-edges (nth 3 parent-edges)))
- ;; `pos-x' and `pos-y' record the x- and y-coordinates of the
- ;; last sampled mouse position. Note that we sample absolute
- ;; mouse positions to avoid that moving the mouse from one
- ;; frame into another gets into our way. `last-x' and `last-y'
- ;; records the x- and y-coordinates of the previously sampled
- ;; position. The differences between `last-x' and `pos-x' as
- ;; well as `last-y' and `pos-y' determine the amount the mouse
- ;; has been dragged between the last two samples.
- pos-x-y pos-x pos-y
- (last-x-y (mouse-absolute-pixel-position))
- (last-x (car last-x-y))
- (last-y (cdr last-x-y))
- ;; `snap-x' and `snap-y' record the x- and y-coordinates of the
+ ;; Initial "first" mouse position. While dragging we base all
+ ;; calculations against that position.
+ (first-x-y (mouse-absolute-pixel-position))
+ (first-x (car first-x-y))
+ (first-y (cdr first-x-y))
+ ;; `snap-width' (maybe also a yet to be provided `snap-height')
+ ;; could become floats to handle proportionality wrt PARENT.
+ ;; We don't do any checks on this parameter so far.
+ (snap-width (frame-parameter frame 'snap-width))
+ ;; `snap-x' and `snap-y' record the x- and y-coordinates of the
;; mouse position when FRAME snapped. As soon as the
;; difference between `pos-x' and `snap-x' (or `pos-y' and
;; `snap-y') exceeds the value of FRAME's `snap-width'
@@ -678,176 +763,141 @@ frame with the mouse."
(lambda (event)
(interactive "e")
(when (consp event)
- (setq pos-x-y (mouse-absolute-pixel-position))
- (setq pos-x (car pos-x-y))
- (setq pos-y (cdr pos-x-y))
- (cond
- ((eq part 'left)
- (mouse-resize-frame frame (- last-x pos-x) 0 t))
- ((eq part 'top)
- (mouse-resize-frame frame 0 (- last-y pos-y) nil t))
- ((eq part 'right)
- (mouse-resize-frame frame (- pos-x last-x) 0))
- ((eq part 'bottom)
- (mouse-resize-frame frame 0 (- pos-y last-y)))
- ((eq part 'top-left)
- (mouse-resize-frame
- frame (- last-x pos-x) (- last-y pos-y) t t))
- ((eq part 'top-right)
- (mouse-resize-frame
- frame (- pos-x last-x) (- last-y pos-y) nil t))
- ((eq part 'bottom-left)
- (mouse-resize-frame
- frame (- last-x pos-x) (- pos-y last-y) t))
- ((eq part 'bottom-right)
- (mouse-resize-frame
- frame (- pos-x last-x) (- pos-y last-y)))
- ((eq part 'move)
- (let* ((old-position (frame-position frame))
- (old-left (car old-position))
- (old-top (cdr old-position))
- (left (+ old-left (- pos-x last-x)))
- (top (+ old-top (- pos-y last-y)))
- right bottom
- ;; `snap-width' (maybe also a yet to be provided
- ;; `snap-height') could become floats to handle
- ;; proportionality wrt PARENT. We don't do any
- ;; checks on this parameter so far.
- (snap-width (frame-parameter frame 'snap-width)))
- ;; Docking and constraining.
- (when (and (numberp snap-width) parent-edges)
+ (let* ((last-x-y (mouse-absolute-pixel-position))
+ (last-x (car last-x-y))
+ (last-y (cdr last-x-y))
+ (left (- last-x first-x))
+ (top (- last-y first-y))
+ right bottom)
+ (setq left (+ first-left left))
+ (setq top (+ first-top top))
+ ;; Docking and constraining.
+ (when (and (numberp snap-width) parent-edges)
+ (cond
+ ;; Docking at the left parent edge.
+ ((< last-x first-x)
(cond
- ;; Docking at the left parent edge.
- ((< pos-x last-x)
- (cond
- ((and (> left parent-left)
- (<= (- left parent-left) snap-width))
- ;; Snap when the mouse moved leftward and
- ;; FRAME's left edge would end up within
- ;; `snap-width' pixels from PARENT's left edge.
- (setq snap-x pos-x)
- (setq left parent-left))
- ((and (<= left parent-left)
- (<= (- parent-left left) snap-width)
- snap-x (<= (- snap-x pos-x) snap-width))
- ;; Stay snapped when the mouse moved leftward
- ;; but not more than `snap-width' pixels from
- ;; the time FRAME snapped.
- (setq left parent-left))
- (t
- ;; Unsnap when the mouse moved more than
- ;; `snap-width' pixels leftward from the time
- ;; FRAME snapped.
- (setq snap-x nil))))
- ((> pos-x last-x)
- (setq right (+ left width))
- (cond
- ((and (< right parent-right)
- (<= (- parent-right right) snap-width))
- ;; Snap when the mouse moved rightward and
- ;; FRAME's right edge would end up within
- ;; `snap-width' pixels from PARENT's right edge.
- (setq snap-x pos-x)
- (setq left (- parent-right width)))
- ((and (>= right parent-right)
- (<= (- right parent-right) snap-width)
- snap-x (<= (- pos-x snap-x) snap-width))
- ;; Stay snapped when the mouse moved rightward
- ;; but not more more than `snap-width' pixels
- ;; from the time FRAME snapped.
- (setq left (- parent-right width)))
- (t
- ;; Unsnap when the mouse moved rightward more
- ;; than `snap-width' pixels from the time FRAME
- ;; snapped.
- (setq snap-x nil)))))
-
+ ((and (> left parent-left)
+ (<= (- left parent-left) snap-width))
+ ;; Snap when the mouse moved leftward and FRAME's
+ ;; left edge would end up within `snap-width'
+ ;; pixels from PARENT's left edge.
+ (setq snap-x last-x)
+ (setq left parent-left))
+ ((and (<= left parent-left)
+ (<= (- parent-left left) snap-width)
+ snap-x (<= (- snap-x last-x) snap-width))
+ ;; Stay snapped when the mouse moved leftward but
+ ;; not more than `snap-width' pixels from the time
+ ;; FRAME snapped.
+ (setq left parent-left))
+ (t
+ ;; Unsnap when the mouse moved more than
+ ;; `snap-width' pixels leftward from the time
+ ;; FRAME snapped.
+ (setq snap-x nil))))
+ ((> last-x first-x)
+ (setq right (+ left native-width))
(cond
- ((< pos-y last-y)
- (cond
- ((and (> top parent-top)
- (<= (- top parent-top) snap-width))
- ;; Snap when the mouse moved upward and FRAME's
- ;; top edge would end up within `snap-width'
- ;; pixels from PARENT's top edge.
- (setq snap-y pos-y)
- (setq top parent-top))
- ((and (<= top parent-top)
- (<= (- parent-top top) snap-width)
- snap-y (<= (- snap-y pos-y) snap-width))
- ;; Stay snapped when the mouse moved upward but
- ;; not more more than `snap-width' pixels from
- ;; the time FRAME snapped.
- (setq top parent-top))
- (t
- ;; Unsnap when the mouse moved upward more than
- ;; `snap-width' pixels from the time FRAME
- ;; snapped.
- (setq snap-y nil))))
- ((> pos-y last-y)
- (setq bottom (+ top height))
- (cond
- ((and (< bottom parent-bottom)
- (<= (- parent-bottom bottom) snap-width))
- ;; Snap when the mouse moved downward and
- ;; FRAME's bottom edge would end up within
- ;; `snap-width' pixels from PARENT's bottom
- ;; edge.
- (setq snap-y pos-y)
- (setq top (- parent-bottom height)))
- ((and (>= bottom parent-bottom)
- (<= (- bottom parent-bottom) snap-width)
- snap-y (<= (- pos-y snap-y) snap-width))
- ;; Stay snapped when the mouse moved downward
- ;; but not more more than `snap-width' pixels
- ;; from the time FRAME snapped.
- (setq top (- parent-bottom height)))
- (t
- ;; Unsnap when the mouse moved downward more
- ;; than `snap-width' pixels from the time FRAME
- ;; snapped.
- (setq snap-y nil))))))
-
- ;; If requested, constrain FRAME's draggable areas to
- ;; PARENT's edges. The `top-visible' parameter should
- ;; be set when FRAME has a draggable header-line. If
- ;; set to a number, it ascertains that the top of
- ;; FRAME is always constrained to the top of PARENT
- ;; and that at least as many pixels of FRAME as
- ;; specified by that number are visible on each of the
- ;; three remaining sides of PARENT.
- ;;
- ;; The `bottom-visible' parameter should be set when
- ;; FRAME has a draggable mode-line. If set to a
- ;; number, it ascertains that the bottom of FRAME is
- ;; always constrained to the bottom of PARENT and that
- ;; at least as many pixels of FRAME as specified by
- ;; that number are visible on each of the three
- ;; remaining sides of PARENT.
- (let ((par (frame-parameter frame 'top-visible))
- bottom-visible)
- (unless par
- (setq par (frame-parameter frame 'bottom-visible))
- (setq bottom-visible t))
- (when (and (numberp par) parent-edges)
- (setq left
- (max (min (- parent-right par) left)
- (+ (- parent-left width) par)))
- (setq top
- (if bottom-visible
- (min (max top (- parent-top (- height par)))
- (- parent-bottom height))
- (min (max top parent-top)
- (- parent-bottom par))))))
-
- ;; Use `modify-frame-parameters' since `left' and
- ;; `top' may want to move FRAME out of its PARENT.
- (modify-frame-parameters
- frame
- `((left . (+ ,left)) (top . (+ ,top)))))))
- (setq last-x pos-x)
- (setq last-y pos-y))))
- (old-track-mouse track-mouse))
+ ((and (< right parent-right)
+ (<= (- parent-right right) snap-width))
+ ;; Snap when the mouse moved rightward and FRAME's
+ ;; right edge would end up within `snap-width'
+ ;; pixels from PARENT's right edge.
+ (setq snap-x last-x)
+ (setq left (- parent-right native-width)))
+ ((and (>= right parent-right)
+ (<= (- right parent-right) snap-width)
+ snap-x (<= (- last-x snap-x) snap-width))
+ ;; Stay snapped when the mouse moved rightward but
+ ;; not more more than `snap-width' pixels from the
+ ;; time FRAME snapped.
+ (setq left (- parent-right native-width)))
+ (t
+ ;; Unsnap when the mouse moved rightward more than
+ ;; `snap-width' pixels from the time FRAME
+ ;; snapped.
+ (setq snap-x nil)))))
+ (cond
+ ((< last-y first-y)
+ (cond
+ ((and (> top parent-top)
+ (<= (- top parent-top) snap-width))
+ ;; Snap when the mouse moved upward and FRAME's
+ ;; top edge would end up within `snap-width'
+ ;; pixels from PARENT's top edge.
+ (setq snap-y last-y)
+ (setq top parent-top))
+ ((and (<= top parent-top)
+ (<= (- parent-top top) snap-width)
+ snap-y (<= (- snap-y last-y) snap-width))
+ ;; Stay snapped when the mouse moved upward but
+ ;; not more more than `snap-width' pixels from the
+ ;; time FRAME snapped.
+ (setq top parent-top))
+ (t
+ ;; Unsnap when the mouse moved upward more than
+ ;; `snap-width' pixels from the time FRAME
+ ;; snapped.
+ (setq snap-y nil))))
+ ((> last-y first-y)
+ (setq bottom (+ top native-height))
+ (cond
+ ((and (< bottom parent-bottom)
+ (<= (- parent-bottom bottom) snap-width))
+ ;; Snap when the mouse moved downward and FRAME's
+ ;; bottom edge would end up within `snap-width'
+ ;; pixels from PARENT's bottom edge.
+ (setq snap-y last-y)
+ (setq top (- parent-bottom native-height)))
+ ((and (>= bottom parent-bottom)
+ (<= (- bottom parent-bottom) snap-width)
+ snap-y (<= (- last-y snap-y) snap-width))
+ ;; Stay snapped when the mouse moved downward but
+ ;; not more more than `snap-width' pixels from the
+ ;; time FRAME snapped.
+ (setq top (- parent-bottom native-height)))
+ (t
+ ;; Unsnap when the mouse moved downward more than
+ ;; `snap-width' pixels from the time FRAME
+ ;; snapped.
+ (setq snap-y nil))))))
+
+ ;; If requested, constrain FRAME's draggable areas to
+ ;; PARENT's edges. The `top-visible' parameter should
+ ;; be set when FRAME has a draggable header-line. If
+ ;; set to a number, it ascertains that the top of FRAME
+ ;; is always constrained to the top of PARENT and that
+ ;; at least as many pixels of FRAME as specified by that
+ ;; number are visible on each of the three remaining
+ ;; sides of PARENT.
+ ;;
+ ;; The `bottom-visible' parameter should be set when
+ ;; FRAME has a draggable mode-line. If set to a number,
+ ;; it ascertains that the bottom of FRAME is always
+ ;; constrained to the bottom of PARENT and that at least
+ ;; as many pixels of FRAME as specified by that number
+ ;; are visible on each of the three remaining sides of
+ ;; PARENT.
+ (let ((par (frame-parameter frame 'top-visible))
+ bottom-visible)
+ (unless par
+ (setq par (frame-parameter frame 'bottom-visible))
+ (setq bottom-visible t))
+ (when (and (numberp par) parent-edges)
+ (setq left
+ (max (min (- parent-right par) left)
+ (+ (- parent-left native-width) par)))
+ (setq top
+ (if bottom-visible
+ (min (max top (- parent-top (- native-height par)))
+ (- parent-bottom native-height))
+ (min (max top parent-top)
+ (- parent-bottom par))))))
+ ;; Use `modify-frame-parameters' since `left' and `top'
+ ;; may want to move FRAME out of its PARENT.
+ (modify-frame-parameters frame `((left . (+ ,left)) (top . (+ ,top))))))))
+ (old-track-mouse track-mouse))
;; Start tracking. The special value 'dragging' signals the
;; display engine to freeze the mouse pointer shape for as long
;; as we drag.
@@ -867,6 +917,7 @@ frame with the mouse."
;; with a mode-line, header-line or vertical-line prefix ...
(define-key map [mode-line] map)
(define-key map [header-line] map)
+ (define-key map [tab-line] map)
(define-key map [vertical-line] map)
;; ... and some maybe even with a right- or bottom-divider
;; prefix.
@@ -879,49 +930,49 @@ frame with the mouse."
"Drag left edge of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'left))
+ (mouse-drag-frame-resize start-event 'left))
(defun mouse-drag-top-left-corner (start-event)
"Drag top left corner of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'top-left))
+ (mouse-drag-frame-resize start-event 'top-left))
(defun mouse-drag-top-edge (start-event)
"Drag top edge of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'top))
+ (mouse-drag-frame-resize start-event 'top))
(defun mouse-drag-top-right-corner (start-event)
"Drag top right corner of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'top-right))
+ (mouse-drag-frame-resize start-event 'top-right))
(defun mouse-drag-right-edge (start-event)
"Drag right edge of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'right))
+ (mouse-drag-frame-resize start-event 'right))
(defun mouse-drag-bottom-right-corner (start-event)
"Drag bottom right corner of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'bottom-right))
+ (mouse-drag-frame-resize start-event 'bottom-right))
(defun mouse-drag-bottom-edge (start-event)
"Drag bottom edge of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'bottom))
+ (mouse-drag-frame-resize start-event 'bottom))
(defun mouse-drag-bottom-left-corner (start-event)
"Drag bottom left corner of a frame with the mouse.
START-EVENT is the starting mouse event of the drag action."
(interactive "e")
- (mouse-drag-frame start-event 'bottom-left))
+ (mouse-drag-frame-resize start-event 'bottom-left))
(defcustom mouse-select-region-move-to-beginning nil
"Effect of selecting a region extending backward from double click.
@@ -1157,7 +1208,7 @@ overlay property, the value of that property determines what to do.
for the `follow-link' event, the binding of that event determines
what to do.
-The resulting value determine whether POS is inside a link:
+The resulting value determines whether POS is inside a link:
- If the value is `mouse-face', POS is inside a link if there
is a non-nil `mouse-face' property at POS. Return t in this case.
@@ -1759,7 +1810,7 @@ The function returns a non-nil value if it creates a secondary selection."
(let (event end end-point)
(track-mouse
(while (progn
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (mouse-movement-p event)
(memq (car-safe event) '(switch-frame select-window))))
@@ -2173,8 +2224,8 @@ and selects that window."
;; Sort the list to put the most popular major modes first.
(setq split-by-major-mode
(sort split-by-major-mode
- (function (lambda (elt1 elt2)
- (> (length elt1) (length elt2))))))
+ (lambda (elt1 elt2)
+ (> (length elt1) (length elt2)))))
;; Make a separate submenu for each major mode
;; that has more than one buffer,
;; unless all the remaining buffers are less than 1/10 of them.
@@ -2215,8 +2266,8 @@ and selects that window."
head)
(setq buffers
(sort buffers
- (function (lambda (elt1 elt2)
- (string< (buffer-name elt1) (buffer-name elt2))))))
+ (lambda (elt1 elt2)
+ (string< (buffer-name elt1) (buffer-name elt2)))))
(setq tail buffers)
(while tail
(or (eq ?\s (aref (buffer-name (car tail)) 0))
@@ -2270,9 +2321,6 @@ and selects that window."
;; Few buffers--put them all in one pane.
(list (cons title alist))))
-(define-obsolete-function-alias
- 'mouse-choose-completion 'choose-completion "23.2")
-
;; Font selection.
(defun font-menu-add-default ()
@@ -2498,7 +2546,7 @@ region, text is copied instead of being cut."
(lambda (modifier)
`(const :tag ,(format "Enable, but copy with the %s modifier"
modifier)
- modifier))
+ ,modifier))
'(alt super hyper shift control meta))
(other :tag "Enable dragging the region" t))
:version "26.1")
@@ -2517,9 +2565,12 @@ as it does when dropping text in the source buffer."
If this option is nil, `mouse-drag-and-drop-region' does not show
tooltips. If this is t, it shows the entire text dragged in a
tooltip. If this is an integer (as with the default value of
-256), it will show that many characters of the dragged text in
-a tooltip."
- :type 'integer
+256), it will show up to that many characters of the dragged text
+in a tooltip."
+ :type '(choice
+ (const :tag "Do not show tooltips" nil)
+ (const :tag "Show all text" t)
+ (integer :tag "Max number of characters to show" 256))
:version "26.1")
(defcustom mouse-drag-and-drop-region-show-cursor t
@@ -2553,6 +2604,7 @@ is copied instead of being cut."
(let* ((mouse-button (event-basic-type last-input-event))
(mouse-drag-and-drop-region-show-tooltip
(when (and mouse-drag-and-drop-region-show-tooltip
+ (> mouse-drag-and-drop-region-show-tooltip 0)
(display-multi-frame-p)
(require 'tooltip))
mouse-drag-and-drop-region-show-tooltip))
@@ -2588,7 +2640,7 @@ is copied instead of being cut."
;; this for all windows on all visible frames. In addition we save
;; also the cursor type for the window's buffer so we can restore it
;; in case we modified it.
- ;; https://lists.gnu.org/archive/html/emacs-devel/2017-12/msg00090.html
+ ;; https://lists.gnu.org/r/emacs-devel/2017-12/msg00090.html
(walk-window-tree
(lambda (window)
(setq states
@@ -2829,8 +2881,8 @@ is copied instead of being cut."
(set-marker (nth 2 state) nil))
(with-current-buffer (window-buffer window)
(setq cursor-type (nth 3 state)))))))
-
+
;;; Bindings for mouse commands.
(global-set-key [down-mouse-1] 'mouse-drag-region)
@@ -2870,6 +2922,7 @@ is copied instead of being cut."
;; versions.
(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line)
(global-set-key [header-line mouse-1] 'mouse-select-window)
+(global-set-key [tab-line down-mouse-1] 'mouse-drag-tab-line)
(global-set-key [tab-line mouse-1] 'mouse-select-window)
;; (global-set-key [mode-line drag-mouse-1] 'mouse-select-window)
(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line)
diff --git a/lisp/mpc.el b/lisp/mpc.el
index e2b751ce2a4..ab572aa539a 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -125,16 +125,13 @@
(unless (member elem seen) (push elem res)))))
(nreverse res)))
-(defun mpc-intersection (l1 l2 &optional selectfun)
+(defun mpc-intersection (l1 l2 selectfun)
"Return L1 after removing all elements not found in L2.
-If SELECTFUN is non-nil, elements aren't compared directly, but instead
+Elements aren't compared directly, but instead
they are passed through SELECTFUN before comparison."
- (let ((res ()))
- (if selectfun (setq l2 (mapcar selectfun l2)))
- (dolist (elem l1)
- (when (member (if selectfun (funcall selectfun elem) elem) l2)
- (push elem res)))
- (nreverse res)))
+ (seq-intersection l1 l2 (lambda (x y)
+ (equal (funcall selectfun x)
+ (funcall selectfun y)))))
(defun mpc-event-set-point (event)
(condition-case nil (posn-set-point (event-end event))
@@ -185,7 +182,7 @@ numerically rather than lexicographically."
(abs res))
res))))))))
-(define-obsolete-function-alias 'mpc-string-prefix-p 'string-prefix-p "24.3")
+(define-obsolete-function-alias 'mpc-string-prefix-p #'string-prefix-p "24.3")
;; This can speed up mpc--song-search significantly. The table may grow
;; very large, tho. It's only bounded by the fact that it gets flushed
@@ -293,11 +290,11 @@ defaults to 6600 and HOST defaults to localhost."
(let ((plist (process-plist mpc-proc)))
(while plist (process-put proc (pop plist) (pop plist)))))
(mpc-proc-buffer proc 'mpd-commands (current-buffer))
- (process-put proc 'callback 'ignore)
+ (process-put proc 'callback #'ignore)
(process-put proc 'ready nil)
(clrhash mpc--find-memoize)
- (set-process-filter proc 'mpc--proc-filter)
- (set-process-sentinel proc 'ignore)
+ (set-process-filter proc #'mpc--proc-filter)
+ (set-process-sentinel proc #'ignore)
(set-process-query-on-exit-flag proc nil)
;; This may be called within a process filter ;-(
(with-local-quit (mpc-proc-sync proc))
@@ -378,7 +375,7 @@ which will be concatenated with proper quoting before passing them to MPD."
(mpc--debug "Send \"%s\"" cmd)
(process-send-string
proc (concat (if (stringp cmd) cmd
- (mapconcat 'mpc--proc-quote-string cmd " "))
+ (mapconcat #'mpc--proc-quote-string cmd " "))
"\n")))
(if callback
;; (let ((buf (current-buffer)))
@@ -390,7 +387,7 @@ which will be concatenated with proper quoting before passing them to MPD."
;; (set-buffer buf)))))
)
;; If `callback' is nil, we're executing synchronously.
- (process-put proc 'callback 'ignore)
+ (process-put proc 'callback #'ignore)
;; This returns the process's buffer.
(mpc-proc-sync proc)))))
@@ -400,7 +397,7 @@ which will be concatenated with proper quoting before passing them to MPD."
(concat "command_list_begin\n"
(mapconcat (lambda (cmd)
(if (stringp cmd) cmd
- (mapconcat 'mpc--proc-quote-string cmd " ")))
+ (mapconcat #'mpc--proc-quote-string cmd " ")))
cmds
"\n")
"\ncommand_list_end"))
@@ -490,9 +487,9 @@ to call FUN for any change whatsoever.")
(defvar mpc--status-timer nil)
(defun mpc--status-timer-start ()
- (add-hook 'pre-command-hook 'mpc--status-timer-stop)
+ (add-hook 'pre-command-hook #'mpc--status-timer-stop)
(unless mpc--status-timer
- (setq mpc--status-timer (run-with-timer 1 1 'mpc--status-timer-run))))
+ (setq mpc--status-timer (run-with-timer 1 1 #'mpc--status-timer-run))))
(defun mpc--status-timer-stop ()
(when mpc--status-timer
(cancel-timer mpc--status-timer)
@@ -512,7 +509,7 @@ to call FUN for any change whatsoever.")
;; Turn it off even if we'll start it again, in case it changes the delay.
(cancel-timer mpc--status-idle-timer))
(setq mpc--status-idle-timer
- (run-with-idle-timer 1 t 'mpc--status-idle-timer-run))
+ (run-with-idle-timer 1 t #'mpc--status-idle-timer-run))
;; Typically, the idle timer is started from the mpc--status-callback,
;; which is run asynchronously while we're already idle (we typically
;; just started idling), so the timer itself will only be run the next
@@ -527,7 +524,7 @@ to call FUN for any change whatsoever.")
(unless really
;; We don't completely stop the timer, so that if some other MPD
;; client starts playback, we may get a chance to notice it.
- (run-with-idle-timer 10 t 'mpc--status-idle-timer-run))))
+ (run-with-idle-timer 10 t #'mpc--status-idle-timer-run))))
(defun mpc--status-idle-timer-run ()
(mpc--status-timer-start)
(mpc--status-timer-run))
@@ -598,7 +595,7 @@ Any call to `mpc-status-refresh' may cause it to be restarted."
;; (dotimes (i (string-to-number pos)) (mpc--queue-pop))
;; (mpc-proc-cmd (mpc-proc-cmd-list
;; (make-list (string-to-number pos) "delete 0"))
-;; 'ignore)
+;; #'ignore)
;; (if (not (equal (cdr (assq 'file mpc-status))
;; (mpc--queue-head)))
;; (message "MPC's queue is out of sync"))))))
@@ -685,7 +682,7 @@ The songs are returned as alists."
(let ((plsongs (mpc-cmd-find 'Playlist pl)))
(if (not (mpc-cmd-special-tag-p other-tag))
(when (member (cons other-tag value)
- (apply 'append plsongs))
+ (apply #'append plsongs))
(push pl pls))
;; Problem N°2: we compute the intersection whereas all
;; we care about is whether it's empty. So we could
@@ -696,15 +693,15 @@ The songs are returned as alists."
;; good enough because this is only used with "search", which
;; doesn't pay attention to playlists and URLs anyway.
(let* ((osongs (mpc-cmd-find other-tag value))
- (ofiles (mpc-assq-all 'file (apply 'append osongs)))
- (plfiles (mpc-assq-all 'file (apply 'append plsongs))))
- (when (mpc-intersection plfiles ofiles)
+ (ofiles (mpc-assq-all 'file (apply #'append osongs)))
+ (plfiles (mpc-assq-all 'file (apply #'append plsongs))))
+ (when (seq-intersection plfiles ofiles)
(push pl pls)))))))
pls))
((eq tag 'Directory)
(if (null other-tag)
- (apply 'nconc
+ (apply #'nconc
(mpc-assq-all 'directory
(mpc-proc-buf-to-alist
(mpc-proc-cmd "lsinfo")))
@@ -727,7 +724,7 @@ The songs are returned as alists."
;; If there's an other-tag, then just extract the dir info from the
;; list of other-tag's songs.
(let* ((other-songs (mpc-cmd-find other-tag value))
- (files (mpc-assq-all 'file (apply 'append other-songs)))
+ (files (mpc-assq-all 'file (apply #'append other-songs)))
(dirs '()))
(dolist (file files)
(let ((dir (file-name-directory file)))
@@ -761,7 +758,7 @@ The songs are returned as alists."
((null other-tag)
(condition-case nil
- (mapcar 'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
+ (mapcar #'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
(mpc-proc-error
;; If `tag' is not one of the expected tags, MPD burps about not
;; having the relevant table.
@@ -772,7 +769,7 @@ The songs are returned as alists."
(condition-case nil
(if (mpc-cmd-special-tag-p other-tag)
(signal 'mpc-proc-error "Not implemented")
- (mapcar 'cdr
+ (mapcar #'cdr
(mpc-proc-cmd-to-alist
(list "list" (symbol-name tag)
(symbol-name other-tag) value))))
@@ -783,7 +780,7 @@ The songs are returned as alists."
(mpc-assq-all tag
;; Don't use `nconc' now that mpc-cmd-find may
;; return a memoized result.
- (apply 'append other-songs))))))))
+ (apply #'append other-songs))))))))
(defun mpc-cmd-stop (&optional callback)
(mpc-proc-cmd "stop" callback))
@@ -819,8 +816,8 @@ The songs are returned as alists."
(defun mpc-cmd-status ()
(mpc-proc-cmd-to-alist "status"))
-(defun mpc-cmd-play ()
- (mpc-proc-cmd "play")
+(defun mpc-cmd-play (&optional sn)
+ (mpc-proc-cmd (if sn (list "play" sn) "play"))
(mpc-status-refresh))
(defun mpc-cmd-seekcur (time)
@@ -849,7 +846,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; Sort them from last to first, so the renumbering
;; caused by the earlier deletions don't affect
;; later ones.
- (sort song-poss '>))))
+ (sort (copy-sequence song-poss) #'>))))
(if (stringp playlist)
(puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
@@ -873,7 +870,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; Sort them from last to first, so the renumbering
;; caused by the earlier deletions affect
;; later ones a bit less.
- (sort song-poss '>))))
+ (sort (copy-sequence song-poss) #'>))))
(if (stringp playlist)
(puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
@@ -884,7 +881,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(unless callback (mpc-proc-sync))))
(defun mpc-cmd-tagtypes ()
- (mapcar 'cdr (mpc-proc-cmd-to-alist "tagtypes")))
+ (mapcar #'cdr (mpc-proc-cmd-to-alist "tagtypes")))
;; This was never integrated into MPD.
;; (defun mpc-cmd-download (file)
@@ -1000,7 +997,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(cond
((>= col 0) (insert str))
(t (insert (substring str (min (length str) (- col))))))))
- (pred nil))
+ (pred #'always))
(while (string-match "%\\(?:%\\|\\(-\\)?\\([0-9]+\\)?{\\([[:alpha:]][[:alnum:]]*\\)\\(?:-\\([^}]+\\)\\)?}\\)" format-spec pos)
(let ((pre-text (substring format-spec pos (match-beginning 0))))
(funcall insert pre-text)
@@ -1019,7 +1016,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(pcase tag
((or 'Time 'Duration)
(let ((time (cdr (or (assq 'time info) (assq 'Time info)))))
- (setq pred (list nil)) ;Just assume it's never eq.
+ (setq pred #'ignore) ;Just assume it's never eq.
(when time
(mpc-secs-to-time (if (and (eq tag 'Duration)
(string-match ":" time))
@@ -1028,7 +1025,15 @@ If PLAYLIST is t or nil or missing, use the main playlist."
('Cover
(let ((dir (file-name-directory (cdr (assq 'file info)))))
;; (debug)
- (push `(equal ',dir (file-name-directory (cdr (assq 'file info)))) pred)
+ (setq pred
+ ;; We want the closure to capture the current
+ ;; value of `pred' and not a reference to the
+ ;; variable itself.
+ (let ((oldpred pred))
+ (lambda (info)
+ (and (funcall oldpred info)
+ (equal dir (file-name-directory
+ (cdr (assq 'file info))))))))
(if-let* ((covers '(".folder.png" "cover.jpg" "folder.jpg"))
(cover (cl-loop for file in (directory-files (mpc-file-local-copy dir))
if (member (downcase file) covers)
@@ -1045,7 +1050,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(setq size nil)
(propertize dir 'display image))
;; Make sure we return something on which we can
- ;; place the `mpc-pred' property, as
+ ;; place the `mpc--uptodate-p' property, as
;; a negative-cache. We could also use
;; a default cover.
(progn (setq size nil) " "))))
@@ -1054,7 +1059,14 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; than the URL in `file'. Pretend it's in `Title'.
(when (and (null val) (eq tag 'Title))
(setq val (cdr (assq 'file info))))
- (push `(equal ',val (cdr (assq ',tag info))) pred)
+ (setq pred
+ ;; We want the closure to capture the current
+ ;; value of `pred' and not a reference to the
+ ;; variable itself.
+ (let ((oldpred pred))
+ (lambda (info)
+ (and (funcall oldpred info)
+ (equal val (cdr (assq tag info)))))))
(cond
((not (and (eq tag 'Date) (stringp val))) val)
;; For "date", only keep the year!
@@ -1082,11 +1094,11 @@ If PLAYLIST is t or nil or missing, use the main playlist."
'follow-link t
'keymap `(keymap
(mouse-2
- . (lambda ()
- (interactive)
- (mpc-constraints-push 'noerror)
- (mpc-constraints-restore
- ',(list (list tag text)))))))))
+ . ,(lambda ()
+ (interactive)
+ (mpc-constraints-push 'noerror)
+ (mpc-constraints-restore
+ ',(list (list tag text)))))))))
(funcall insert
(concat (when size
(propertize " " 'display
@@ -1099,35 +1111,34 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(if (null size) (setq col (+ col textwidth postwidth))
(insert space)
(setq col (+ col size))))))
- (put-text-property start (point) 'mpc-pred
- `(lambda (info) (and ,@(nreverse pred))))))
+ (put-text-property start (point) 'mpc--uptodate-p pred)))
;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mpc-mode-map
(let ((map (make-sparse-keymap)))
- ;; (define-key map "\e" 'mpc-stop)
- (define-key map "q" 'mpc-quit)
- (define-key map "\r" 'mpc-select)
- (define-key map [(shift return)] 'mpc-select-toggle)
- (define-key map [mouse-2] 'mpc-select)
- (define-key map [S-mouse-2] 'mpc-select-extend)
- (define-key map [C-mouse-2] 'mpc-select-toggle)
- (define-key map [drag-mouse-2] 'mpc-drag-n-drop)
+ ;; (define-key map "\e" #'mpc-stop)
+ (define-key map "q" #'mpc-quit)
+ (define-key map "\r" #'mpc-select)
+ (define-key map [(shift return)] #'mpc-select-toggle)
+ (define-key map [mouse-2] #'mpc-select)
+ (define-key map [S-mouse-2] #'mpc-select-extend)
+ (define-key map [C-mouse-2] #'mpc-select-toggle)
+ (define-key map [drag-mouse-2] #'mpc-drag-n-drop)
;; We use `always' because a binding to t is like a binding to nil.
(define-key map [follow-link] :always)
;; But follow-link doesn't apply blindly to header-line and
;; mode-line clicks.
- (define-key map [header-line follow-link] 'ignore)
- (define-key map [mode-line follow-link] 'ignore)
+ (define-key map [header-line follow-link] #'ignore)
+ (define-key map [mode-line follow-link] #'ignore)
;; Doesn't work because the first click changes the buffer, so the second
;; is applied elsewhere :-(
- ;; (define-key map [(double mouse-2)] 'mpc-play-at-point)
- (define-key map "p" 'mpc-pause)
- (define-key map "s" 'mpc-toggle-play)
- (define-key map ">" 'mpc-next)
- (define-key map "<" 'mpc-prev)
- (define-key map "g" 'mpc-seek-current)
+ ;; (define-key map [(double mouse-2)] #'mpc-play-at-point)
+ (define-key map "p" #'mpc-pause)
+ (define-key map "s" #'mpc-toggle-play)
+ (define-key map ">" #'mpc-next)
+ (define-key map "<" #'mpc-prev)
+ (define-key map "g" #'mpc-seek-current)
map))
(easy-menu-define mpc-mode-menu mpc-mode-map
@@ -1219,7 +1230,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(when (assq 'file mpc-status)
(let ((inhibit-read-only t))
(dolist (spec mpc-status-buffer-format)
- (let ((pred (get-text-property (point) 'mpc-pred)))
+ (let ((pred (get-text-property (point) 'mpc--uptodate-p)))
(if (and pred (funcall pred mpc-status))
(forward-line)
(delete-region (point) (line-beginning-position 2))
@@ -1279,7 +1290,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; Restore the selection. I.e. move the overlays back to their
;; corresponding location. Actually which overlay is used for what
;; doesn't matter.
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(dolist (elem selection)
;; After an update, some elements may have disappeared.
@@ -1304,7 +1315,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(interactive (list last-nonmenu-event))
(mpc-event-set-point event)
(if (and (bolp) (eobp)) (forward-line -1))
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(if (mpc-tagbrowser-all-p)
nil
@@ -1664,12 +1675,12 @@ Return non-nil if a selection was deactivated."
;; (unless (equal constraints mpc-constraints)
;; (setq-local mpc-constraints constraints)
(dolist (cst constraints)
- (let ((vals (apply 'mpc-union
+ (let ((vals (apply #'mpc-union
(mapcar (lambda (val)
(mpc-cmd-list mpc-tag (car cst) val))
(cdr cst)))))
(setq active
- (if (listp active) (mpc-intersection active vals) vals))))
+ (if (listp active) (seq-intersection active vals) vals))))
(when (listp active)
;; Remove the selections if they are all in conflict with
@@ -1683,7 +1694,7 @@ Return non-nil if a selection was deactivated."
(setq mpc--changed-selection t))
(unless nodeactivate
(setq selection nil)
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(mpc-tagbrowser-all-select))))
@@ -1728,7 +1739,7 @@ Return non-nil if a selection was deactivated."
(defvar mpc-tagbrowser-dir-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map mpc-tagbrowser-mode-map)
- (define-key map [?\M-\C-m] 'mpc-tagbrowser-dir-toggle)
+ (define-key map [?\M-\C-m] #'mpc-tagbrowser-dir-toggle)
map))
;; (defvar mpc-tagbrowser-dir-keywords
@@ -1840,12 +1851,12 @@ A value of t means the main playlist.")
(let ((map (make-sparse-keymap)))
;; Bind the up-events rather than the down-event, so the
;; `message' isn't canceled by the subsequent up-event binding.
- (define-key map [down-mouse-1] 'ignore)
- (define-key map [mouse-1] 'mpc-volume-mouse-set)
- (define-key map [header-line mouse-1] 'mpc-volume-mouse-set)
- (define-key map [header-line down-mouse-1] 'ignore)
- (define-key map [mode-line mouse-1] 'mpc-volume-mouse-set)
- (define-key map [mode-line down-mouse-1] 'ignore)
+ (define-key map [down-mouse-1] #'ignore)
+ (define-key map [mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [header-line mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [header-line down-mouse-1] #'ignore)
+ (define-key map [mode-line mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [mode-line down-mouse-1] #'ignore)
map))
(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
@@ -1878,7 +1889,7 @@ A value of t means the main playlist.")
(progn
(message "MPD volume already at %s%%" newvol)
(ding))
- (mpc-proc-cmd (list "setvol" newvol) 'mpc-status-refresh)
+ (mpc-proc-cmd (list "setvol" newvol) #'mpc-status-refresh)
(message "Set MPD volume to %s%%" newvol))))
(defun mpc-volume-widget (vol &optional size)
@@ -1915,7 +1926,7 @@ A value of t means the main playlist.")
(defvar mpc-songs-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [remap mpc-select] 'mpc-songs-jump-to)
+ (define-key map [remap mpc-select] #'mpc-songs-jump-to)
map))
(defvar mpc-songpointer-set-visible nil)
@@ -1963,7 +1974,7 @@ This is used so that they can be compared with `eq', which is needed for
(setq mpc-songs-playlist (cadr cst)))
;; We don't do anything really special here for playlists,
;; because it's unclear what's a correct "union" of playlists.
- (let ((vals (apply 'mpc-union
+ (let ((vals (apply #'mpc-union
(mapcar (lambda (val)
(mpc-cmd-find (car cst) val))
(cdr cst)))))
@@ -2089,7 +2100,7 @@ This is used so that they can be compared with `eq', which is needed for
((null (with-current-buffer plbuf (re-search-forward re nil t)))
;; song-file only appears once in the playlist: no ambiguity,
;; we're good to go!
- (mpc-proc-cmd (list "play" sn)))
+ (mpc-cmd-play sn))
(t
;; The song appears multiple times in the playlist. If the current
;; buffer holds not only the destination song but also the current
@@ -2337,7 +2348,7 @@ This is used so that they can be compared with `eq', which is needed for
"Quit Music Player Daemon."
(interactive)
(let* ((proc mpc-proc)
- (bufs (mapcar 'cdr (if proc (process-get proc 'buffers))))
+ (bufs (mapcar #'cdr (if proc (process-get proc 'buffers))))
(wins (mapcar (lambda (buf) (get-buffer-window buf 0)) bufs))
(song-buf (mpc-songs-buf))
frames)
@@ -2358,7 +2369,7 @@ This is used so that they can be compared with `eq', which is needed for
(unless (memq (window-buffer win) bufs) (setq delete nil)))
(if delete (ignore-errors (delete-frame frame))))))
;; Then kill the buffers.
- (mapc 'kill-buffer bufs)
+ (mapc #'kill-buffer bufs)
(mpc-status-stop)
(if proc (delete-process proc))))
@@ -2391,6 +2402,7 @@ This is used so that they can be compared with `eq', which is needed for
(interactive)
(mpc-cmd-stop)
(mpc-cmd-clear)
+ (mpc-songs-refresh)
(mpc-status-refresh))
(defun mpc-pause ()
@@ -2520,7 +2532,7 @@ If stopped, start playback."
(setq mpc-last-seek-time
(cons currenttime (setq time (+ time step))))
(mpc-proc-cmd (list "seekid" songid time)
- 'mpc-status-refresh))))
+ #'mpc-status-refresh))))
(let ((status (mpc-cmd-status)))
(let* ((songid (cdr (assq 'songid status)))
(time (if songid (string-to-number
@@ -2530,7 +2542,7 @@ If stopped, start playback."
(lambda ()
(mpc-proc-cmd (list "seekid" songid
(setq time (+ time step)))
- 'mpc-status-refresh)))))
+ #'mpc-status-refresh)))))
(while (mouse-movement-p
(event-basic-type (setq event (read-event)))))
(cancel-timer timer)))))))
@@ -2585,7 +2597,7 @@ If stopped, start playback."
((and (>= songtime songduration) mpc--faster-toggle-forward)
;; Skip to the beginning of the next song.
(if (not (equal (cdr (assq 'state mpc-status)) "play"))
- (mpc-proc-cmd "next" 'mpc-status-refresh)
+ (mpc-proc-cmd "next" #'mpc-status-refresh)
;; If we're playing, this is done automatically, so we
;; don't need to do anything, or rather we *shouldn't*
;; do anything otherwise there's a race condition where
@@ -2617,7 +2629,7 @@ If stopped, start playback."
(condition-case nil
(mpc-proc-cmd
(list "seekid" songid songtime)
- 'mpc-status-refresh)
+ #'mpc-status-refresh)
(mpc-proc-error (mpc-status-refresh)))))))))))
(setq mpc--faster-toggle-forward (> step 0))
(funcall fun) ;Initialize values.
@@ -2701,7 +2713,7 @@ If stopped, start playback."
(error "Not a playlist")
(buffer-substring (line-beginning-position)
(line-end-position)))))
- (mpc-cmd-add (mapcar 'car songs) playlist)
+ (mpc-cmd-add (mapcar #'car songs) playlist)
(message "Added %d songs to %s" (length songs) playlist)
(if (member playlist
(cdr (assq 'Playlist (mpc-constraints-get-current))))
@@ -2713,7 +2725,7 @@ If stopped, start playback."
((eq start-buf end-buf)
;; Moving songs within the shown playlist.
(let ((dest-pos (get-text-property (point) 'mpc-file-pos)))
- (mpc-cmd-move (mapcar 'cdr songs) dest-pos mpc-songs-playlist)
+ (mpc-cmd-move (mapcar #'cdr songs) dest-pos mpc-songs-playlist)
(message "Moved %d songs" (length songs))))
(t
;; Adding songs to the shown playlist.
@@ -2724,10 +2736,10 @@ If stopped, start playback."
;; MPD's protocol does not let us add songs at a particular
;; position in a playlist, so we first have to add them to the
;; end, and then move them to their final destination.
- (mpc-cmd-add (mapcar 'car songs) mpc-songs-playlist)
+ (mpc-cmd-add (mapcar #'car songs) mpc-songs-playlist)
(mpc-cmd-move (let ((poss '()))
(dotimes (i (length songs))
- (push (+ i (length pl)) poss))
+ (push (+ i (length pl)) poss))
(nreverse poss))
dest-pos mpc-songs-playlist)
(message "Added %d songs" (length songs)))))
@@ -2750,7 +2762,9 @@ If stopped, start playback."
(if current-prefix-arg
;; FIXME: We should provide some completion here, especially for the
;; case where the user specifies a local socket/file name.
- (setq mpc-host (read-string "MPD host and port: " nil nil mpc-host)))
+ (setq mpc-host (read-string
+ (format-prompt "MPD host and port" mpc-host)
+ nil nil mpc-host)))
nil))
(let* ((song-buf (mpc-songs-buf))
(song-win (get-buffer-window song-buf 0)))
diff --git a/lisp/msb.el b/lisp/msb.el
index 6b21fedd854..1f05e9db589 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1,4 +1,4 @@
-;;; msb.el --- customizable buffer-selection with multiple menus
+;;; msb.el --- customizable buffer-selection with multiple menus -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 1997-2021 Free Software Foundation, Inc.
@@ -252,14 +252,12 @@ error every time you do \\[msb]."
:type `(choice (const :tag "long" :value ,msb--very-many-menus)
(const :tag "short" :value ,msb--few-menus)
(sexp :tag "user"))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-modes-key 4000
"The sort key for files sorted by mode."
:type 'integer
- :set 'msb-custom-set
- :group 'msb
+ :set #'msb-custom-set
:version "20.3")
(defcustom msb-separator-diff 100
@@ -267,8 +265,7 @@ error every time you do \\[msb]."
The separators will appear between all menus that have a sorting key
that differs by this value or more."
:type '(choice integer (const nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-files-by-directory-sort-key 0
"The sort key for files sorted by directory.")
@@ -278,8 +275,7 @@ that differs by this value or more."
If this variable is set to 15 for instance, then the submenu will be
split up in minor parts, 15 items each. A value of nil means no limit."
:type '(choice integer (const nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-max-file-menu-items 10
"The maximum number of items from different directories.
@@ -293,27 +289,23 @@ them together.
If the value is not a number, then the value 10 is used."
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-most-recently-used-sort-key -1010
"Where should the menu with the most recently used buffers be placed?"
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-display-most-recently-used 15
"How many buffers should be in the most-recently-used menu.
No buffers at all if less than 1 or nil (or any non-number)."
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-most-recently-used-title "Most recently used (%d)"
"The title for the most-recently-used menu."
:type 'string
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-horizontal-shift-function (lambda () 0)
"Function that specifies how many pixels to shift the top menu leftwards.")
@@ -323,8 +315,7 @@ No buffers at all if less than 1 or nil (or any non-number)."
Non-nil means that the buffer menu should include buffers that have
names that starts with a space character."
:type 'boolean
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-item-handling-function 'msb-item-handler
"The appearance of a buffer menu.
@@ -354,15 +345,13 @@ Set this to nil or t if you don't want any sorting (faster)."
:type '(choice (const msb-sort-by-name)
(const :tag "Newest first" t)
(const :tag "Oldest first" nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-files-by-directory nil
"Non-nil means that files should be sorted by directory.
This is instead of the groups in `msb-menu-cond'."
:type 'boolean
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(define-obsolete-variable-alias 'msb-after-load-hooks
'msb-after-load-hook "24.1")
@@ -370,8 +359,9 @@ This is instead of the groups in `msb-menu-cond'."
(defcustom msb-after-load-hook nil
"Hook run after the msb package has been loaded."
:type 'hook
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
+(make-obsolete-variable 'msb-after-load-hook
+ "use `with-eval-after-load' instead." "28.1")
;;;
;;; Internal variables
@@ -456,10 +446,10 @@ An item look like (NAME . BUFFER)."
;;;
;;; msb
-;;;
-;;; This function can be used instead of (mouse-buffer-menu EVENT)
-;;; function in "mouse.el".
-;;;
+;;
+;; This function can be used instead of (mouse-buffer-menu EVENT)
+;; function in "mouse.el".
+;;
(defun msb (event)
"Pop up several menus of buffers for selection with the mouse.
This command switches buffers in the window that you clicked on, and
@@ -705,7 +695,7 @@ See `msb-menu-cond' for a description of its elements."
(cl-loop for fi
across function-info-vector
if (and (setq result
- (eval (aref fi 1))) ;Test CONDITION
+ (eval (aref fi 1) t)) ;Test CONDITION
(not (and (eq result 'no-multi)
multi-flag))
(progn (when (eq result 'multi)
@@ -725,12 +715,11 @@ All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER)
to the buffer-list variable in FUNCTION-INFO."
(let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
;; Here comes the hairy side-effect!
- (set list-symbol
- (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
- buffer
- max-buffer-name-length)
- buffer)
- (eval list-symbol)))))
+ (push (cons (funcall (aref function-info 4) ;ITEM-HANDLER
+ buffer
+ max-buffer-name-length)
+ buffer)
+ (symbol-value list-symbol))))
(defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
"Select the appropriate menu for BUFFER."
@@ -752,7 +741,7 @@ to the buffer-list variable in FUNCTION-INFO."
(defun msb--create-sort-item (function-info)
"Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
- (let ((buffer-list (eval (aref function-info 0))))
+ (let ((buffer-list (symbol-value (aref function-info 0))))
(when buffer-list
(let ((sorter (aref function-info 5)) ;SORTER
(sort-key (aref function-info 2))) ;MENU-SORT-KEY
@@ -923,7 +912,7 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
for value = (msb--create-sort-item elt)
if value collect value))))
(setq menu
- (mapcar 'cdr ;Remove the SORT-KEY
+ (mapcar #'cdr ;Remove the SORT-KEY
;; Sort the menus - not the items.
(msb--add-separators
(sort
@@ -1063,9 +1052,12 @@ variable `msb-menu-cond'."
(msb--split-menus-2 list 0 nil)
list))
+(defun msb--select-buffer ()
+ (interactive)
+ (switch-to-buffer last-command-event))
+
(defun msb--make-keymap-menu (raw-menu)
- (let ((end 'menu-bar-select-buffer)
- (mcount 0))
+ (let ((mcount 0))
(mapcar
(lambda (sub-menu)
(cond
@@ -1074,7 +1066,7 @@ variable `msb-menu-cond'."
(t
(let ((buffers (mapcar (lambda (item)
(cons (buffer-name (cdr item))
- (cons (car item) end)))
+ (cons (car item) 'msb--select-buffer)))
(cdr sub-menu))))
(nconc (list (cl-incf mcount) (car sub-menu)
'keymap (car sub-menu))
@@ -1111,8 +1103,8 @@ variable `msb-menu-cond'."
(nconc
(list (frame-parameter frame 'name)
(frame-parameter frame 'name))
- `(lambda ()
- (interactive) (menu-bar-select-frame ,frame))))
+ (lambda ()
+ (interactive) (menu-bar-select-frame frame))))
frames)))))
(setcdr global-buffers-menu-map
(if (and buffers-menu frames-menu)
@@ -1126,7 +1118,7 @@ variable `msb-menu-cond'."
;; C-down-mouse-1).
(defvar msb-mode-map
(let ((map (make-sparse-keymap "Msb")))
- (define-key map [remap mouse-buffer-menu] 'msb)
+ (define-key map [remap mouse-buffer-menu] #'msb)
map))
;;;###autoload
@@ -1135,14 +1127,14 @@ variable `msb-menu-cond'."
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'."
- :global t :group 'msb
+ :global t
(if msb-mode
(progn
- (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
- (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+ (add-hook 'menu-bar-update-hook #'msb-menu-bar-update-buffers)
+ (remove-hook 'menu-bar-update-hook #'menu-bar-update-buffers)
(msb-menu-bar-update-buffers t))
- (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
- (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+ (remove-hook 'menu-bar-update-hook #'msb-menu-bar-update-buffers)
+ (add-hook 'menu-bar-update-hook #'menu-bar-update-buffers)
(menu-bar-update-buffers t)))
(defun msb-unload-function ()
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index f8a10ef2869..def77587747 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -1,4 +1,4 @@
-;;; mwheel.el --- Wheel mouse support
+;;; mwheel.el --- Mouse wheel support -*- lexical-binding:t -*-
;; Copyright (C) 1998, 2000-2021 Free Software Foundation, Inc.
;; Keywords: mouse
@@ -25,8 +25,8 @@
;; Under X11/X.Org, the wheel events are sent as button4/button5
;; events.
-;; It is already enabled by default on most graphical displays. You
-;; can toggle it with M-x mouse-wheel-mode.
+;; Mouse wheel support is already enabled by default on most graphical
+;; displays. You can toggle it using `M-x mouse-wheel-mode'.
;;; Code:
@@ -37,10 +37,11 @@
;; 'mwheel-down', but I cannot find a way to do this very easily (or
;; portably), so for now I just live with it.
-(require 'custom)
(require 'timer)
(defvar mouse-wheel-mode)
+(defvar mouse-wheel--installed-bindings-alist nil
+ "Alist of all installed mouse wheel key bindings.")
;; Setter function for mouse-button user-options. Switch Mouse Wheel
;; mode off and on again so that the old button is unbound and
@@ -48,8 +49,10 @@
(defun mouse-wheel-change-button (var button)
(set-default var button)
- ;; Sync the bindings.
- (when (bound-and-true-p mouse-wheel-mode) (mouse-wheel-mode 1)))
+ ;; Sync the bindings if they're already setup.
+ (when (and mouse-wheel--installed-bindings-alist
+ (bound-and-true-p mouse-wheel-mode))
+ (mouse-wheel-mode 1)))
(defcustom mouse-wheel-down-event
(if (or (featurep 'w32-win) (featurep 'ns-win))
@@ -85,7 +88,7 @@ set to the event sent when clicking on the mouse wheel button."
:type 'number)
(defcustom mouse-wheel-scroll-amount
- '(5 ((shift) . 1) ((meta) . nil) ((control) . text-scale))
+ '(1 ((shift) . hscroll) ((meta) . nil) ((control) . text-scale))
"Amount to scroll windows by when spinning the mouse wheel.
This is an alist mapping the modifier key to the amount to scroll when
the wheel is moved with the modifier key depressed.
@@ -97,6 +100,9 @@ screen. It can also be a floating point number, specifying the fraction of
a full screen to scroll. A near full screen is `next-screen-context-lines'
less than a full screen.
+If AMOUNT is the symbol 'hscroll', this means that with MODIFIER,
+the mouse wheel will scroll horizontally instead of vertically.
+
If AMOUNT is the symbol text-scale, this means that with
MODIFIER, the mouse wheel will change the face height instead of
scrolling."
@@ -123,12 +129,16 @@ scrolling."
(const :tag "Scroll full screen" :value nil)
(integer :tag "Scroll specific # of lines")
(float :tag "Scroll fraction of window")
+ (const :tag "Scroll horizontally" :value hscroll)
(const :tag "Change face size" :value text-scale)))))
:set 'mouse-wheel-change-button
- :version "27.1")
+ :version "28.1")
(defcustom mouse-wheel-progressive-speed t
- "If non-nil, the faster the user moves the wheel, the faster the scrolling.
+ "If nil, scrolling speed is proportional to the wheel speed.
+If non-nil, moving the wheel faster will make scrolling
+progressively faster.
+
Note that this has no effect when `mouse-wheel-scroll-amount' specifies
a \"near full screen\" scroll or when the mouse wheel sends key instead
of button events."
@@ -142,6 +152,16 @@ face height."
:group 'mouse
:type 'boolean)
+(defcustom mouse-wheel-scroll-amount-horizontal 1
+ "Amount to scroll windows horizontally.
+Its value can be changed dynamically by using a numeric prefix argument
+before starting horizontal scrolling.
+It has effect when `mouse-wheel-scroll-amount' binds the value `hscroll'
+to one of modifiers (`Shift' by default)."
+ :group 'mouse
+ :type 'number
+ :version "28.1")
+
;;; For tilt-scroll
;;;
(defcustom mouse-wheel-tilt-scroll nil
@@ -162,23 +182,18 @@ Also see `mouse-wheel-tilt-scroll'."
:type 'boolean
:version "26.1")
-(eval-and-compile
- (if (fboundp 'event-button)
- (fset 'mwheel-event-button 'event-button)
- (defun mwheel-event-button (event)
- (let ((x (event-basic-type event)))
- ;; Map mouse-wheel events to appropriate buttons
- (if (eq 'mouse-wheel x)
- (let ((amount (car (cdr (cdr (cdr event))))))
- (if (< amount 0)
- mouse-wheel-up-event
- mouse-wheel-down-event))
- x))))
-
- (if (fboundp 'event-window)
- (fset 'mwheel-event-window 'event-window)
- (defun mwheel-event-window (event)
- (posn-window (event-start event)))))
+(defun mwheel-event-button (event)
+ (let ((x (event-basic-type event)))
+ ;; Map mouse-wheel events to appropriate buttons
+ (if (eq 'mouse-wheel x)
+ (let ((amount (car (cdr (cdr (cdr event))))))
+ (if (< amount 0)
+ mouse-wheel-up-event
+ mouse-wheel-down-event))
+ x)))
+
+(defun mwheel-event-window (event)
+ (posn-window (event-start event)))
(defvar mwheel-inhibit-click-event-timer nil
"Timer running while mouse wheel click event is inhibited.")
@@ -208,13 +223,13 @@ Also see `mouse-wheel-tilt-scroll'."
(defvar mouse-wheel-left-event
(if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-left
- (intern "mouse-6"))
+ 'mouse-6)
"Event used for scrolling left.")
(defvar mouse-wheel-right-event
(if (or (featurep 'w32-win) (featurep 'ns-win))
'wheel-right
- (intern "mouse-7"))
+ 'mouse-7)
"Event used for scrolling right.")
(defun mouse-wheel--get-scroll-window (event)
@@ -244,11 +259,17 @@ active window."
frame nil t)))))
(mwheel-event-window event)))
-(defun mwheel-scroll (event)
+(defun mwheel-scroll (event &optional arg)
"Scroll up or down according to the EVENT.
This should be bound only to mouse buttons 4, 5, 6, and 7 on
-non-Windows systems."
- (interactive (list last-input-event))
+non-Windows systems.
+
+Optional argument ARG (interactively, prefix numeric argument) controls
+the step of horizontal scrolling.
+
+The variable `mouse-wheel-scroll-amount-horizontal' records the last
+value of ARG, and the command uses it in subsequent scrolls."
+ (interactive (list last-input-event current-prefix-arg))
(let* ((selected-window (selected-window))
(scroll-window (mouse-wheel--get-scroll-window event))
(old-point
@@ -275,7 +296,14 @@ non-Windows systems."
(condition-case nil
(unwind-protect
(let ((button (mwheel-event-button event)))
- (cond ((eq button mouse-wheel-down-event)
+ (cond ((and (eq amt 'hscroll) (eq button mouse-wheel-down-event))
+ (when (and (natnump arg) (> arg 0))
+ (setq mouse-wheel-scroll-amount-horizontal arg))
+ (funcall (if mouse-wheel-flip-direction
+ mwheel-scroll-left-function
+ mwheel-scroll-right-function)
+ mouse-wheel-scroll-amount-horizontal))
+ ((eq button mouse-wheel-down-event)
(condition-case nil (funcall mwheel-scroll-down-function amt)
;; Make sure we do indeed scroll to the beginning of
;; the buffer.
@@ -290,7 +318,14 @@ non-Windows systems."
;; for a reason that escapes me. This problem seems
;; to only affect scroll-down. --Stef
(set-window-start (selected-window) (point-min))))))
- ((eq button mouse-wheel-up-event)
+ ((and (eq amt 'hscroll) (eq button mouse-wheel-up-event))
+ (when (and (natnump arg) (> arg 0))
+ (setq mouse-wheel-scroll-amount-horizontal arg))
+ (funcall (if mouse-wheel-flip-direction
+ mwheel-scroll-right-function
+ mwheel-scroll-left-function)
+ mouse-wheel-scroll-amount-horizontal))
+ ((eq button mouse-wheel-up-event)
(condition-case nil (funcall mwheel-scroll-up-function amt)
;; Make sure we do indeed scroll to the end of the buffer.
(end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
@@ -349,51 +384,68 @@ non-Windows systems."
(text-scale-decrease 1)))
(select-window selected-window))))
-(defvar mwheel-installed-bindings nil)
-(defvar mwheel-installed-text-scale-bindings nil)
+(defun mouse-wheel--add-binding (key fun)
+ "Bind mouse wheel button KEY to function FUN.
+Save it for later removal by `mouse-wheel--remove-bindings'."
+ (global-set-key key fun)
+ (push (cons key fun) mouse-wheel--installed-bindings-alist))
-(defun mouse-wheel--remove-bindings (bindings funs)
- "Remove key BINDINGS if they're bound to any function in FUNS.
-BINDINGS is a list of key bindings, FUNS is a list of functions.
+(defun mouse-wheel--remove-bindings ()
+ "Remove all mouse wheel key bindings.
This is a helper function for `mouse-wheel-mode'."
- (dolist (key bindings)
- (when (memq (lookup-key (current-global-map) key) funs)
- (global-unset-key key))))
-
+ (dolist (binding mouse-wheel--installed-bindings-alist)
+ (let ((key (car binding))
+ (fun (cdr binding)))
+ (when (eq (lookup-key (current-global-map) key) fun)
+ (global-unset-key key))))
+ (setq mouse-wheel--installed-bindings-alist nil))
+
+(defun mouse-wheel--create-scroll-keys (binding event)
+ "Return list of key vectors for BINDING and EVENT.
+BINDING is an element in `mouse-wheel-scroll-amount'. EVENT is
+an event used for scrolling, such as `mouse-wheel-down-event'."
+ (let ((prefixes (list 'left-margin 'right-margin
+ 'left-fringe 'right-fringe
+ 'vertical-scroll-bar 'horizontal-scroll-bar
+ 'mode-line 'header-line)))
+ (if (consp binding)
+ ;; With modifiers, bind only the buffer area (no prefix).
+ (list `[(,@(car binding) ,event)])
+ ;; No modifier: bind also some non-buffer areas of the screen.
+ (cons (vector event)
+ (mapcar (lambda (prefix) (vector prefix event)) prefixes)))))
+
+;;;###autoload
(define-minor-mode mouse-wheel-mode
"Toggle mouse wheel support (Mouse Wheel mode)."
:init-value t
- ;; We'd like to use custom-initialize-set here so the setup is done
- ;; before dumping, but at the point where the defcustom is evaluated,
- ;; the corresponding function isn't defined yet, so
- ;; custom-initialize-set signals an error.
- :initialize 'custom-initialize-delay
:global t
:group 'mouse
;; Remove previous bindings, if any.
- (mouse-wheel--remove-bindings mwheel-installed-bindings
- '(mwheel-scroll))
- (mouse-wheel--remove-bindings mwheel-installed-text-scale-bindings
- '(mouse-wheel-text-scale))
- (setq mwheel-installed-bindings nil)
- (setq mwheel-installed-text-scale-bindings nil)
+ (mouse-wheel--remove-bindings)
;; Setup bindings as needed.
(when mouse-wheel-mode
- (dolist (binding mouse-wheel-scroll-amount)
- (cond
- ;; Bindings for changing font size.
- ((and (consp binding) (eq (cdr binding) 'text-scale))
- (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
- (let ((key `[,(list (caar binding) event)]))
- (global-set-key key 'mouse-wheel-text-scale)
- (push key mwheel-installed-text-scale-bindings))))
- ;; Bindings for scrolling.
- (t
- (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
- mouse-wheel-right-event mouse-wheel-left-event))
- (let ((key `[(,@(if (consp binding) (car binding)) ,event)]))
- (global-set-key key 'mwheel-scroll)
- (push key mwheel-installed-bindings))))))))
+ (mouse-wheel--setup-bindings)))
+
+(defun mouse-wheel--setup-bindings ()
+ (dolist (binding mouse-wheel-scroll-amount)
+ (cond
+ ;; Bindings for changing font size.
+ ((and (consp binding) (eq (cdr binding) 'text-scale))
+ (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
+ (mouse-wheel--add-binding `[,(list (caar binding) event)]
+ 'mouse-wheel-text-scale)))
+ ;; Bindings for scrolling.
+ (t
+ (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
+ mouse-wheel-left-event mouse-wheel-right-event))
+ (dolist (key (mouse-wheel--create-scroll-keys binding event))
+ (mouse-wheel--add-binding key 'mwheel-scroll)))))))
+
+(when mouse-wheel-mode
+ (mouse-wheel--setup-bindings))
+
+;;; Obsolete.
;;; Compatibility entry point
;; preloaded ;;;###autoload
@@ -402,6 +454,12 @@ This is a helper function for `mouse-wheel-mode'."
(declare (obsolete mouse-wheel-mode "27.1"))
(mouse-wheel-mode (if uninstall -1 1)))
+(defvar mwheel-installed-bindings nil)
+(make-obsolete-variable 'mwheel-installed-bindings nil "28.1")
+
+(defvar mwheel-installed-text-scale-bindings nil)
+(make-obsolete-variable 'mwheel-installed-text-scale-bindings nil "28.1")
+
(provide 'mwheel)
;;; mwheel.el ends here
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 49208c966ed..3f3a3df8e55 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -838,7 +838,7 @@ If nil, prompt the user for a password."
"If non-nil, regexp matching hosts on which `dir' command lists directory."
:group 'ange-ftp
:type '(choice (const :tag "Default" nil)
- string))
+ regexp))
(defcustom ange-ftp-binary-file-name-regexp ""
"If a file matches this regexp then it is transferred in binary mode."
@@ -949,7 +949,11 @@ Some AT&T folks claim to use something called `pftp' here."
:type 'string)
(defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v")
- "A list of arguments passed to the FTP program when started."
+ ;; Clients that use the BSD editline instead of the GNU readline
+ ;; library may need to disable command line editing. (Bug#48494)
+ "A list of arguments passed to the FTP program when started.
+Some FTP clients may also require the \"-e\" argument, which disables
+command line editing."
:group 'ange-ftp
:type '(repeat string))
@@ -1080,7 +1084,7 @@ All HOST values should be in lower case.")
(defvar ange-ftp-trample-marker)
;; New error symbols.
-(define-error 'ftp-error nil 'file-error) ;"FTP error"
+(define-error 'ftp-error nil '(remote-file-error file-error)) ;"FTP error"
;;; ------------------------------------------------------------
;;; Enhanced message support.
@@ -1556,7 +1560,7 @@ good, skip, fatal, or unknown."
;; This looks like an error, but we have to keep reading the output
;; to see if it was fixed or not. E.g. it may indicate that IPv6
;; failed, but maybe a subsequent IPv4 fallback succeeded.
- (set (make-local-variable 'ange-ftp-pending-error-line) line)
+ (setq-local ange-ftp-pending-error-line line)
t)
((string-match ange-ftp-fatal-msgs line)
(delete-process proc)
@@ -1970,30 +1974,24 @@ on the gateway machine to do the FTP instead."
"Major mode for interacting with the FTP process.
\\{comint-mode-map}"
- (make-local-variable 'ange-ftp-process-string)
- (setq ange-ftp-process-string "")
+ (setq-local ange-ftp-process-string "")
(make-local-variable 'ange-ftp-process-busy)
(make-local-variable 'ange-ftp-process-result)
(make-local-variable 'ange-ftp-process-msg)
(make-local-variable 'ange-ftp-process-multi-skip)
- (make-local-variable 'ange-ftp-process-result-line)
(make-local-variable 'ange-ftp-process-continue)
- (make-local-variable 'ange-ftp-hash-mark-count)
(make-local-variable 'ange-ftp-binary-hash-mark-size)
(make-local-variable 'ange-ftp-ascii-hash-mark-size)
(make-local-variable 'ange-ftp-hash-mark-unit)
- (make-local-variable 'ange-ftp-xfer-size)
(make-local-variable 'ange-ftp-last-percent)
- (setq ange-ftp-hash-mark-count 0)
- (setq ange-ftp-xfer-size 0)
- (setq ange-ftp-process-result-line "")
+ (setq-local ange-ftp-hash-mark-count 0)
+ (setq-local ange-ftp-xfer-size 0)
+ (setq-local ange-ftp-process-result-line "")
(setq comint-prompt-regexp "^ftp> ")
- (make-local-variable 'comint-password-prompt-regexp)
;; This is a regexp that can't match anything.
;; ange-ftp has its own ways of handling passwords.
- (setq comint-password-prompt-regexp regexp-unmatchable)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start comint-prompt-regexp))
+ (setq-local comint-password-prompt-regexp regexp-unmatchable)
+ (setq-local paragraph-start comint-prompt-regexp))
(defcustom ange-ftp-raw-login nil
"Use raw FTP commands for login, if account password is not nil.
@@ -2553,7 +2551,7 @@ can parse the output from a DIR listing for a host of type TYPE.")
FILE is the full name of the remote file, LSARGS is any args to pass to the
`ls' command, and PARSE specifies that the output should be parsed and stored
away in the internal cache."
- (when (string-match "^--dired\\s-+" lsargs)
+ (while (string-match "^--dired\\s-+" lsargs)
(setq lsargs (replace-match "" nil t lsargs)))
;; If parse is t, we assume that file is a directory. i.e. we only parse
;; full directory listings.
@@ -3427,8 +3425,7 @@ system TYPE.")
(and (file-directory-p name)
(file-readable-p name)))
-(defun ange-ftp-directory-files (directory &optional full match
- &rest v19-args)
+(defun ange-ftp-directory-files (directory &optional full match nosort count)
(setq directory (expand-file-name directory))
(if (ange-ftp-ftp-name directory)
(progn
@@ -3443,19 +3440,21 @@ system TYPE.")
(if (or (not match) (string-match-p match f))
(setq files
(cons (if full (concat directory f) f) files))))
+ (when (natnump count)
+ (setq files (last files count)))
(nreverse files)))
- (apply 'ange-ftp-real-directory-files directory full match v19-args)))
+ (apply 'ange-ftp-real-directory-files directory full match nosort count)))
(defun ange-ftp-directory-files-and-attributes
- (directory &optional full match nosort id-format)
+ (directory &optional full match nosort id-format count)
(setq directory (expand-file-name directory))
(if (ange-ftp-ftp-name directory)
(mapcar
(lambda (file)
(cons file (file-attributes (expand-file-name file directory))))
- (ange-ftp-directory-files directory full match nosort))
+ (ange-ftp-directory-files directory full match nosort count))
(ange-ftp-real-directory-files-and-attributes
- directory full match nosort id-format)))
+ directory full match nosort id-format count)))
(defun ange-ftp-file-attributes (file &optional id-format)
(setq file (expand-file-name file))
@@ -3535,20 +3534,22 @@ system TYPE.")
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
- (let* ((host (nth 0 parsed))
- (user (nth 1 parsed))
- (name (ange-ftp-quote-string (nth 2 parsed)))
- (abbr (ange-ftp-abbreviate-filename file))
- (result (ange-ftp-send-cmd host user
- (list 'delete name)
- (format "Deleting %s" abbr))))
- (or (car result)
- (signal 'ftp-error
- (list
- "Removing old name"
- (format "FTP Error: \"%s\"" (cdr result))
- file)))
- (ange-ftp-delete-file-entry file))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash file)
+ (let* ((host (nth 0 parsed))
+ (user (nth 1 parsed))
+ (name (ange-ftp-quote-string (nth 2 parsed)))
+ (abbr (ange-ftp-abbreviate-filename file))
+ (result (ange-ftp-send-cmd host user
+ (list 'delete name)
+ (format "Deleting %s" abbr))))
+ (or (car result)
+ (signal 'ftp-error
+ (list
+ "Removing old name"
+ (format "FTP Error: \"%s\"" (cdr result))
+ file)))
+ (ange-ftp-delete-file-entry file)))
(ange-ftp-real-delete-file file trash))))
(defun ange-ftp-file-modtime (file)
@@ -3659,7 +3660,7 @@ so return the size on the remote host exactly. See RFC 3659."
;; (set-process-sentinel proc 'ange-ftp-copy-file-locally-sentinel)
;; (set-process-query-on-exit-flag proc nil)
;; (with-current-buffer (process-buffer proc)
-;; (set (make-local-variable 'copy-cont) cont))))
+;; (setq-local copy-cont cont))))
;;
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
;; (with-current-buffer (process-buffer proc)
@@ -3719,7 +3720,7 @@ so return the size on the remote host exactly. See RFC 3659."
(binary (or (ange-ftp-binary-file filename)
(ange-ftp-binary-file newname)))
temp1
- temp2)
+ ) ;; temp2
;; check to see if we can overwrite
(if (or (not ok-if-already-exists)
@@ -3753,7 +3754,7 @@ so return the size on the remote host exactly. See RFC 3659."
filename newname binary msg
f-parsed f-host f-user f-name f-abbr
t-parsed t-host t-user t-name t-abbr
- temp1 temp2 cont nowait)
+ temp1 nil cont nowait) ;; temp2
nowait))
;; filename wasn't remote. newname must be remote. call the
@@ -4162,46 +4163,55 @@ directory, so that Emacs will know its current contents."
(defun ange-ftp-delete-directory (dir &optional recursive trash)
(if (file-directory-p dir)
- (let ((parsed (ange-ftp-ftp-name dir)))
- (if recursive
- (mapc
- (lambda (file)
- (if (file-directory-p file)
- (ange-ftp-delete-directory file recursive trash)
- (delete-file file trash)))
- ;; We do not want to delete "." and "..".
- (directory-files dir 'full (rx (or (not ".") "...")))))
- (if parsed
- (let* ((host (nth 0 parsed))
- (user (nth 1 parsed))
- ;; Some ftp's on unix machines (at least on Suns)
- ;; insist that rmdir take a filename, and not a
- ;; directory-name name as an arg. Argh!! This is a bug.
- ;; Non-unix machines will probably always insist
- ;; that rmdir takes a directory-name as an arg
- ;; (as the ftp man page says it should).
- (name (ange-ftp-quote-string
- (if (eq (ange-ftp-host-type host) 'unix)
- (ange-ftp-real-directory-file-name
- (nth 2 parsed))
- (ange-ftp-real-file-name-as-directory
- (nth 2 parsed)))))
- (abbr (ange-ftp-abbreviate-filename dir))
- (result
- (progn
- ;; CWD must not in this directory.
- (ange-ftp-cd host user "/" 'noerror)
- (ange-ftp-send-cmd host user
- (list 'rmdir name)
- (format "Removing directory %s"
- abbr)))))
- (or (car result)
- (ange-ftp-error host user
- (format "Could not remove directory %s: %s"
- dir
- (cdr result))))
- (ange-ftp-delete-file-entry dir t))
- (ange-ftp-real-delete-directory dir recursive trash)))
+ ;; Trashing directories does not work yet, because
+ ;; `rename-file', called in `move-file-to-trash', does not
+ ;; handle directories.
+ (if nil ; (and delete-by-moving-to-trash trash)
+ ;; Move non-empty dir to trash only if recursive deletion was
+ ;; requested.
+ (if (not (or recursive (directory-empty-p dir)))
+ (signal 'ftp-error
+ (list "Directory is not empty, not moving to trash"))
+ (move-file-to-trash dir))
+ (let ((parsed (ange-ftp-ftp-name dir)))
+ (if recursive
+ (mapc
+ (lambda (file)
+ (if (file-directory-p file)
+ (ange-ftp-delete-directory file recursive)
+ (delete-file file)))
+ (directory-files dir 'full directory-files-no-dot-files-regexp)))
+ (if parsed
+ (let* ((host (nth 0 parsed))
+ (user (nth 1 parsed))
+ ;; Some ftp's on unix machines (at least on Suns)
+ ;; insist that rmdir take a filename, and not a
+ ;; directory-name name as an arg. Argh!! This is a bug.
+ ;; Non-unix machines will probably always insist
+ ;; that rmdir takes a directory-name as an arg
+ ;; (as the ftp man page says it should).
+ (name (ange-ftp-quote-string
+ (if (eq (ange-ftp-host-type host) 'unix)
+ (ange-ftp-real-directory-file-name
+ (nth 2 parsed))
+ (ange-ftp-real-file-name-as-directory
+ (nth 2 parsed)))))
+ (abbr (ange-ftp-abbreviate-filename dir))
+ (result
+ (progn
+ ;; CWD must not in this directory.
+ (ange-ftp-cd host user "/" 'noerror)
+ (ange-ftp-send-cmd host user
+ (list 'rmdir name)
+ (format "Removing directory %s"
+ abbr)))))
+ (or (car result)
+ (ange-ftp-error host user
+ (format "Could not remove directory %s: %s"
+ dir
+ (cdr result))))
+ (ange-ftp-delete-file-entry dir t))
+ (ange-ftp-real-delete-directory dir recursive trash))))
(error "Not a directory: %s" dir)))
;; Make a local copy of FILE and return its name.
@@ -4739,7 +4749,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired.
0)
-(defun ange-ftp-set-file-modes (filename mode)
+(defun ange-ftp-set-file-modes (filename mode &optional flag)
+ flag ;; FIXME: Support 'nofollow'.
(ange-ftp-call-chmod (list (format "%o" mode) filename)))
(defun ange-ftp-make-symbolic-link (&rest _arguments)
@@ -6104,8 +6115,7 @@ Other orders of $ and _ seem to all work just fine.")
(1- (match-end 2)))))
(filename (if (match-beginning 3)
(substring name (match-beginning 3)))))
- (if (and (boundp 'filename)
- (stringp filename)
+ (if (and (stringp filename)
(string-match "[#@].+" filename))
(setq filename (concat ange-ftp-bs2000-special-prefix
(substring filename 1))))
@@ -6252,10 +6262,6 @@ be recognized automatically (they are all valid BS2000 hosts too)."
;; ange-ftp-bs2000-file-name-as-directory
;; ange-ftp-bs2000-make-compressed-filename
;; ange-ftp-bs2000-file-name-sans-versions
-
-;;;; ------------------------------------------------------------
-;;;; Finally provide package.
-;;;; ------------------------------------------------------------
(provide 'ange-ftp)
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 6168201b8e0..6d64100be17 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1,4 +1,4 @@
-;;; browse-url.el --- pass a URL to a WWW browser
+;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*-
;; Copyright (C) 1995-2021 Free Software Foundation, Inc.
@@ -39,7 +39,6 @@
;; browse-url-chrome Chrome 47.0.2526.111
;; browse-url-chromium Chromium 3.0
;; browse-url-epiphany Epiphany Don't know
-;; browse-url-conkeror Conkeror Don't know
;; browse-url-w3 w3 0
;; browse-url-text-* Any text browser 0
;; browse-url-generic arbitrary
@@ -48,6 +47,7 @@
;; browse-url-xdg-open freedesktop.org xdg-open
;; browse-url-kde KDE konqueror (kfm)
;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT)
+;; eww-browse-url Emacs Web Wowser
;; Browsers can cache Web pages so it may be necessary to tell them to
;; reload the current page if it has changed (e.g., if you have edited
@@ -114,13 +114,29 @@
;; To always save modified buffers before displaying the file in a browser:
;; (setq browse-url-save-file t)
-;; To invoke different browsers for different URLs:
-;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail)
-;; ("." . browse-url-firefox)))
+;; To invoke different browsers/tools for different URLs, customize
+;; `browse-url-handlers'. In earlier versions of Emacs, the same
+;; could be done by setting `browse-url-browser-function' to an alist
+;; but this usage is deprecated now.
+
+;; All browser functions provided by here have a
+;; `browse-url-browser-kind' symbol property set to either `internal'
+;; or `external' which determines if they browse the given URL inside
+;; Emacs or spawn an external application with it. Some parts of
+;; Emacs make use of that, e.g., when an URL is dragged into Emacs, it
+;; is not sensible to invoke an external browser with it, so here only
+;; internal browsers are considered. Therefore, it is advised to put
+;; that property also on custom browser functions.
+;; (function-put 'my-browse-url-in-emacs 'browse-url-browser-kind
+;; 'internal)
+;; (function-put 'my-browse-url-externally 'browse-url-browser-kind
+;; 'external)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code:
+(require 'url)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variables
@@ -140,7 +156,6 @@
(function-item :tag "Google Chrome" :value browse-url-chrome)
(function-item :tag "Chromium" :value browse-url-chromium)
(function-item :tag "Epiphany" :value browse-url-epiphany)
- (function-item :tag "Conkeror" :value browse-url-conkeror)
(function-item :tag "Text browser in an xterm window"
:value browse-url-text-xterm)
(function-item :tag "Text browser in an Emacs window"
@@ -157,7 +172,9 @@
:value browse-url-default-browser)
(function :tag "Your own function")
(alist :tag "Regexp/function association list"
- :key-type regexp :value-type function)))
+ :key-type regexp :value-type function
+ :format "%{%t%}\n%d%v\n"
+ :doc "Deprecated. Use `browse-url-handlers' instead.")))
;;;###autoload
(defcustom browse-url-browser-function 'browse-url-default-browser
@@ -165,13 +182,8 @@
This is used by the `browse-url-at-point', `browse-url-at-mouse', and
`browse-url-of-file' commands.
-If the value is not a function it should be a list of pairs
-\(REGEXP . FUNCTION). In this case the function called will be the one
-associated with the first REGEXP which matches the current URL. The
-function is passed the URL and any other args of `browse-url'. The last
-regexp should probably be \".\" to specify a default browser.
-
-Also see `browse-url-secondary-browser-function'."
+Also see `browse-url-secondary-browser-function' and
+`browse-url-handlers'."
:type browse-url--browser-defcustom-type
:version "24.1")
@@ -216,7 +228,7 @@ be used instead."
"\\(?:"
;; Match paired parentheses, e.g. in Wikipedia URLs:
;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com
- "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)"
+ "[" chars punct "]+" "(" "[" chars punct "]+" ")"
"\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?"
"\\|"
"[" chars punct "]+" "[" chars "]"
@@ -385,6 +397,8 @@ If non-nil, then open the URL in a new buffer rather than a new window if
:version "25.1"
:type 'boolean)
+(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1")
+
(defcustom browse-url-galeon-new-window-is-tab nil
"Whether to open up new windows in a tab or a new window.
If non-nil, then open the URL in a new tab rather than a new window if
@@ -414,35 +428,20 @@ Passing an interactive argument to \\[browse-url], or specific browser
commands reverses the effect of this variable."
:type 'boolean)
-(defcustom browse-url-mosaic-program "xmosaic"
- "The name by which to invoke Mosaic (or mMosaic)."
- :type 'string
- :version "20.3")
-
-(make-obsolete-variable 'browse-url-mosaic-program nil "25.1")
-
-(defcustom browse-url-mosaic-arguments nil
- "A list of strings to pass to Mosaic as arguments."
- :type '(repeat (string :tag "Argument")))
-
-(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1")
-
-(defcustom browse-url-mosaic-pidfile "~/.mosaicpid"
- "The name of the pidfile created by Mosaic."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1")
-
(defcustom browse-url-conkeror-program "conkeror"
"The name by which to invoke Conkeror."
:type 'string
:version "25.1")
+(make-obsolete-variable 'browse-url-conkeror-program nil "28.1")
+
(defcustom browse-url-conkeror-arguments nil
"A list of strings to pass to Conkeror as arguments."
:version "25.1"
:type '(repeat (string :tag "Argument")))
+(make-obsolete-variable 'browse-url-conkeror-arguments nil "28.1")
+
(defcustom browse-url-filename-alist
`(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/")
;; The above loses the username to avoid the browser prompting for
@@ -483,24 +482,7 @@ Used by the `browse-url-of-file' command."
"Hook run after `browse-url-of-file' has asked a browser to load a file."
:type 'hook)
-(defcustom browse-url-CCI-port 3003
- "Port to access XMosaic via CCI.
-This can be any number between 1024 and 65535 but must correspond to
-the value set in the browser."
- :type 'integer)
-
-(make-obsolete-variable 'browse-url-CCI-port nil "25.1")
-
-(defcustom browse-url-CCI-host "localhost"
- "Host to access XMosaic via CCI.
-This should be the host name of the machine running XMosaic with CCI
-enabled. The port number should be set in `browse-url-CCI-port'."
- :type 'string)
-
-(make-obsolete-variable 'browse-url-CCI-host nil "25.1")
-
-(defvar browse-url-temp-file-name nil)
-(make-variable-buffer-local 'browse-url-temp-file-name)
+(defvar-local browse-url-temp-file-name nil)
(defcustom browse-url-xterm-program "xterm"
"The name of the terminal emulator used by `browse-url-text-xterm'.
@@ -595,6 +577,116 @@ down (this *won't* always work)."
"Wrapper command prepended to the Elinks command-line."
:type '(repeat (string :tag "Wrapper")))
+(defun browse-url--browser-kind (function url)
+ "Return the browser kind of a browser FUNCTION for URL.
+The browser kind is either `internal' (the browser runs inside
+Emacs), `external' (the browser is spawned in an external
+process), or nil (we don't know)."
+ (let ((kind (if (symbolp function)
+ (get function 'browse-url-browser-kind))))
+ (if (functionp kind)
+ (funcall kind url)
+ kind)))
+
+(defun browse-url--mailto (url &rest args)
+ "Call `browse-url-mailto-function' with URL and ARGS."
+ (funcall browse-url-mailto-function url args))
+
+(defun browse-url--browser-kind-mailto (url)
+ (browse-url--browser-kind browse-url-mailto-function url))
+(function-put 'browse-url--mailto 'browse-url-browser-kind
+ #'browse-url--browser-kind-mailto)
+
+(defun browse-url--man (url &rest args)
+ "Call `browse-url-man-function' with URL and ARGS."
+ (funcall browse-url-man-function url args))
+
+(defun browse-url--browser-kind-man (url)
+ (browse-url--browser-kind browse-url-man-function url))
+(function-put 'browse-url--man 'browse-url-browser-kind
+ #'browse-url--browser-kind-man)
+
+(defun browse-url--browser (url &rest args)
+ "Call `browse-url-browser-function' with URL and ARGS."
+ (funcall browse-url-browser-function url args))
+
+(defun browse-url--browser-kind-browser (url)
+ (browse-url--browser-kind browse-url-browser-function url))
+(function-put 'browse-url--browser 'browse-url-browser-kind
+ #'browse-url--browser-kind-browser)
+
+(defun browse-url--non-html-file-url-p (url)
+ "Return non-nil if URL is a file:// URL of a non-HTML file."
+ (and (string-match-p "\\`file://" url)
+ (not (string-match-p "\\`file://.*\\.html?\\b" url))))
+
+;;;###autoload
+(defvar browse-url-default-handlers
+ '(("\\`mailto:" . browse-url--mailto)
+ ("\\`man:" . browse-url--man)
+ (browse-url--non-html-file-url-p . browse-url-emacs))
+ "Like `browse-url-handlers' but populated by Emacs and packages.
+
+Emacs and external packages capable of browsing certain URLs
+should place their entries in this alist rather than
+`browse-url-handlers' which is reserved for the user.")
+
+(defcustom browse-url-handlers nil
+ "An alist with elements of the form (REGEXP-OR-PREDICATE . HANDLER).
+Each REGEXP-OR-PREDICATE is matched against the URL to be opened
+in turn and the first match's HANDLER is invoked with the URL.
+
+A HANDLER must be a function with the same arguments as
+`browse-url'.
+
+If no REGEXP-OR-PREDICATE matches, the same procedure is
+performed with the value of `browse-url-default-handlers'. If
+there is also no match, the URL is opened using the value of
+`browse-url-browser-function'."
+ :type '(alist :key-type (choice
+ (regexp :tag "Regexp")
+ (function :tag "Predicate"))
+ :value-type (function :tag "Handler"))
+ :version "28.1")
+
+;;;###autoload
+(defun browse-url-select-handler (url &optional kind)
+ "Return a handler of suitable for browsing URL.
+This searches `browse-url-handlers', and
+`browse-url-default-handlers' for a matching handler. Return nil
+if no handler is found.
+
+If KIND is given, the search is restricted to handlers whose
+function symbol has the symbol-property `browse-url-browser-kind'
+set to KIND.
+
+Currently, it also consults `browse-url-browser-function' first
+if it is set to an alist, although this usage is deprecated since
+Emacs 28.1 and will be removed in a future release."
+ (catch 'custom-url-handler
+ (dolist (rxpred-handler
+ (append
+ ;; The alist choice of browse-url-browser-function
+ ;; is deprecated since 28.1, so the (unless ...)
+ ;; can be removed at some point in time.
+ (when (and (consp browse-url-browser-function)
+ (not (functionp browse-url-browser-function)))
+ (lwarn 'browse-url :warning
+ "Having `browse-url-browser-function' set to an
+alist is deprecated. Use `browse-url-handlers' instead.")
+ browse-url-browser-function)
+ browse-url-handlers
+ browse-url-default-handlers))
+ (let ((rx-or-pred (car rxpred-handler))
+ (handler (cdr rxpred-handler)))
+ (when (and (or (null kind)
+ (eq kind (browse-url--browser-kind
+ handler url)))
+ (if (functionp rx-or-pred)
+ (funcall rx-or-pred url)
+ (string-match-p rx-or-pred url)))
+ (throw 'custom-url-handler handler))))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; URL encoding
@@ -667,7 +759,7 @@ for use in `interactive'."
;;;###autoload
(defun browse-url-of-file (&optional file)
- "Ask a WWW browser to display FILE.
+ "Use a web browser to display FILE.
Display the current buffer's file if FILE is nil or if called
interactively. Turn the filename into a URL with function
`browse-url-file-url'. Pass the URL to a browser using the
@@ -682,6 +774,8 @@ interactively. Turn the filename into a URL with function
(cond ((not (buffer-modified-p)))
(browse-url-save-file (save-buffer))
(t (message "%s modified since last save" file))))))
+ (when (file-remote-p file)
+ (setq file (file-local-copy file)))
(browse-url (browse-url-file-url file))
(run-hooks 'browse-url-of-file-hook))
@@ -702,7 +796,9 @@ Use variable `browse-url-filename-alist' to map filenames to URLs."
;;;###autoload
(defun browse-url-of-buffer (&optional buffer)
- "Ask a WWW browser to display BUFFER.
+ "Use a web browser to display BUFFER.
+See `browse-url' for details.
+
Display the current buffer if BUFFER is nil. Display only the
currently visible part of BUFFER (from a temporary file) if buffer is
narrowed."
@@ -729,13 +825,13 @@ narrowed."
(browse-url-of-file file-name))))
(defun browse-url-delete-temp-file (&optional temp-file-name)
- ;; Delete browse-url-temp-file-name from the file system
- ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead
+ "Delete `browse-url-temp-file-name' from the file system.
+If optional arg TEMP-FILE-NAME is non-nil, delete it instead."
(let ((file-name (or temp-file-name browse-url-temp-file-name)))
(if (and file-name (file-exists-p file-name))
(delete-file file-name))))
-(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file)
+(add-hook 'kill-buffer-hook #'browse-url-delete-temp-file)
(declare-function dired-get-filename "dired"
(&optional localp no-error-if-not-filep))
@@ -751,7 +847,8 @@ narrowed."
;;;###autoload
(defun browse-url-of-region (min max)
- "Ask a WWW browser to display the current region."
+ "Use a web browser to display the current region.
+See `browse-url' for details."
(interactive "r")
(save-excursion
(save-restriction
@@ -765,19 +862,25 @@ narrowed."
;;;###autoload
(defun browse-url (url &rest args)
- "Ask a WWW browser to load URL.
-Prompt for a URL, defaulting to the URL at or before point.
-Invokes a suitable browser function which does the actual job.
-The variable `browse-url-browser-function' says which browser function to
-use. If the URL is a mailto: URL, consult `browse-url-mailto-function'
-first, if that exists.
-
-The additional ARGS are passed to the browser function. See the doc
-strings of the actual functions, starting with `browse-url-browser-function',
-for information about the significance of ARGS (most of the functions
-ignore it).
-If ARGS are omitted, the default is to pass `browse-url-new-window-flag'
-as ARGS."
+ "Open URL using a configurable method.
+This will typically (by default) open URL with an external web
+browser, but a wide variety of different methods can be used,
+depending on the URL type.
+
+The variables `browse-url-browser-function',
+`browse-url-handlers', and `browse-url-default-handlers'
+determine which browser function to use.
+
+This command prompts for a URL, defaulting to the URL at or
+before point.
+
+The additional ARGS are passed to the browser function. See the
+doc strings of the actual functions, starting with
+`browse-url-browser-function', for information about the
+significance of ARGS (most of the functions ignore it).
+
+If ARGS are omitted, the default is to pass
+`browse-url-new-window-flag' as ARGS."
(interactive (browse-url-interactive-arg "URL: "))
(unless (called-interactively-p 'interactive)
(setq args (or args (list browse-url-new-window-flag))))
@@ -786,12 +889,9 @@ as ARGS."
(not (string-match "\\`[a-z]+:" url)))
(setq url (expand-file-name url)))
(let ((process-environment (copy-sequence process-environment))
- (function (or (and (string-match "\\`mailto:" url)
- browse-url-mailto-function)
- (and (string-match "\\`man:" url)
- browse-url-man-function)
- browse-url-browser-function))
- ;; Ensure that `default-directory' exists and is readable (b#6077).
+ (function (or (browse-url-select-handler url)
+ browse-url-browser-function))
+ ;; Ensure that `default-directory' exists and is readable (bug#6077).
(default-directory (or (unhandled-file-name-directory default-directory)
(expand-file-name "~/"))))
;; When connected to various displays, be careful to use the display of
@@ -799,25 +899,14 @@ as ARGS."
;; which may not even exist any more.
(if (stringp (frame-parameter nil 'display))
(setenv "DISPLAY" (frame-parameter nil 'display)))
- (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 function)
- (when (string-match (car bf) url)
- (apply (cdr bf) url args)
- (throw 'done t)))
- (error "No browse-url-browser-function matching URL %s"
- url))
- ;; Unbound symbols go down this leg, since void-function from
- ;; apply is clearer than wrong-type-argument from dolist.
- (apply function url args))))
+ (if (functionp function)
+ (apply function url args)
+ (error "No suitable browser for URL %s" url))))
;;;###autoload
(defun browse-url-at-point (&optional arg)
- "Ask a WWW browser to load the URL at or before point.
-Variable `browse-url-browser-function' says which browser to use.
+ "Open URL at point using a configurable method.
+See `browse-url' for details.
Optional prefix argument ARG non-nil inverts the value of the option
`browse-url-new-window-flag'."
(interactive "P")
@@ -829,11 +918,40 @@ Optional prefix argument ARG non-nil inverts the value of the option
(error "No URL found"))))
;;;###autoload
+(defun browse-url-with-browser-kind (kind url &optional arg)
+ "Browse URL with a browser of the given browser KIND.
+KIND is either `internal' or `external'.
+
+When called interactively, the default browser kind is the
+opposite of the browser kind of `browse-url-browser-function'."
+ (interactive
+ (let* ((url-arg (browse-url-interactive-arg "URL: "))
+ ;; Default to the inverse kind of the default browser.
+ (default (if (eq (browse-url--browser-kind
+ browse-url-browser-function (car url-arg))
+ 'internal)
+ 'external
+ 'internal))
+ (k (intern (completing-read
+ (format-prompt "Browser kind" default)
+ '(internal external)
+ nil t nil nil
+ default))))
+ (cons k url-arg)))
+ (let ((function (browse-url-select-handler url kind)))
+ (unless function
+ (setq function (if (eq kind 'external)
+ #'browse-url-default-browser
+ #'eww)))
+ (funcall function url arg)))
+
+;;;###autoload
(defun browse-url-at-mouse (event)
- "Ask a WWW browser to load a URL clicked with the mouse.
-The URL is the one around or before the position of the mouse click
-but point is not changed. Variable `browse-url-browser-function'
-says which browser to use."
+ "Use a web browser to load a URL clicked with the mouse.
+See `browse-url' for details.
+
+The URL is the one around or before the position of the mouse
+click but point is not changed."
(interactive "e")
(save-excursion
(mouse-set-point event)
@@ -875,12 +993,18 @@ The optional NEW-WINDOW argument is not used."
(url-unhex-string url)
url)))))
+(function-put 'browse-url-default-windows-browser 'browse-url-browser-kind
+ 'external)
+
(defun browse-url-default-macosx-browser (url &optional _new-window)
"Invoke the macOS system's default Web browser.
The optional NEW-WINDOW argument is not used."
(interactive (browse-url-interactive-arg "URL: "))
(start-process (concat "open " url) nil "open" url))
+(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind
+ 'external)
+
;; --- Netscape ---
(defun browse-url-process-environment ()
@@ -928,8 +1052,6 @@ instead of `browse-url-new-window-flag'."
;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon)
((executable-find browse-url-kde-program) 'browse-url-kde)
;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape)
-;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic)
- ((executable-find browse-url-conkeror-program) 'browse-url-conkeror)
((executable-find browse-url-chrome-program) 'browse-url-chrome)
((executable-find browse-url-xterm-program) 'browse-url-text-xterm)
((locate-library "w3") 'browse-url-w3)
@@ -937,6 +1059,10 @@ instead of `browse-url-new-window-flag'."
(lambda (&rest _ignore) (error "No usable browser found"))))
url args))
+(function-put 'browse-url-default-browser 'browse-url-browser-kind
+ ;; Well, most probably external if we ignore w3.
+ 'external)
+
(defun browse-url-can-use-xdg-open ()
"Return non-nil if the \"xdg-open\" program can be used.
xdg-open is a desktop utility that calls your preferred web browser."
@@ -949,13 +1075,15 @@ xdg-open is a desktop utility that calls your preferred web browser."
(executable-find "xdg-open")))
;;;###autoload
-(defun browse-url-xdg-open (url &optional ignored)
+(defun browse-url-xdg-open (url &optional _ignored)
"Pass the specified URL to the \"xdg-open\" command.
xdg-open is a desktop utility that calls your preferred web browser.
The optional argument IGNORED is not used."
(interactive (browse-url-interactive-arg "URL: "))
(call-process "xdg-open" nil 0 nil url))
+(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external)
+
;;;###autoload
(defun browse-url-netscape (url &optional new-window)
"Ask the Netscape WWW browser to load URL.
@@ -978,7 +1106,7 @@ used instead of `browse-url-new-window-flag'."
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment))
(process
- (apply 'start-process
+ (apply #'start-process
(concat "netscape " url) nil
browse-url-netscape-program
(append
@@ -996,8 +1124,10 @@ used instead of `browse-url-new-window-flag'."
",new-window"))
")"))))))))
(set-process-sentinel process
- `(lambda (process change)
- (browse-url-netscape-sentinel process ,url)))))
+ (lambda (process _change)
+ (browse-url-netscape-sentinel process url)))))
+
+(function-put 'browse-url-netscape 'browse-url-browser-kind 'external)
(defun browse-url-netscape-sentinel (process url)
"Handle a change to the process communicating with Netscape."
@@ -1006,7 +1136,7 @@ used instead of `browse-url-new-window-flag'."
(let* ((process-environment (browse-url-process-environment)))
;; Netscape not running - start it
(message "Starting %s..." browse-url-netscape-program)
- (apply 'start-process (concat "netscape" url) nil
+ (apply #'start-process (concat "netscape" url) nil
browse-url-netscape-program
(append browse-url-netscape-startup-arguments (list url))))))
@@ -1025,7 +1155,7 @@ How depends on `browse-url-netscape-version'."
"Send a remote control command to Netscape."
(declare (obsolete nil "25.1"))
(let* ((process-environment (browse-url-process-environment)))
- (apply 'start-process "netscape" nil
+ (apply #'start-process "netscape" nil
browse-url-netscape-program
(append browse-url-netscape-arguments
(list "-remote" command)))))
@@ -1051,7 +1181,7 @@ used instead of `browse-url-new-window-flag'."
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment))
(process
- (apply 'start-process
+ (apply #'start-process
(concat "mozilla " url) nil
browse-url-mozilla-program
(append
@@ -1066,8 +1196,10 @@ used instead of `browse-url-new-window-flag'."
",new-window"))
")"))))))
(set-process-sentinel process
- `(lambda (process change)
- (browse-url-mozilla-sentinel process ,url)))))
+ (lambda (process _change)
+ (browse-url-mozilla-sentinel process url)))))
+
+(function-put 'browse-url-mozilla 'browse-url-browser-kind 'external)
(defun browse-url-mozilla-sentinel (process url)
"Handle a change to the process communicating with Mozilla."
@@ -1075,7 +1207,7 @@ used instead of `browse-url-new-window-flag'."
(let* ((process-environment (browse-url-process-environment)))
;; Mozilla is not running - start it
(message "Starting %s..." browse-url-mozilla-program)
- (apply 'start-process (concat "mozilla " url) nil
+ (apply #'start-process (concat "mozilla " url) nil
browse-url-mozilla-program
(append browse-url-mozilla-startup-arguments (list url))))))
@@ -1098,7 +1230,7 @@ instead of `browse-url-new-window-flag'."
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment)))
- (apply 'start-process
+ (apply #'start-process
(concat "firefox " url) nil
browse-url-firefox-program
(append
@@ -1109,6 +1241,8 @@ instead of `browse-url-new-window-flag'."
'("-new-window")))
(list url)))))
+(function-put 'browse-url-firefox 'browse-url-browser-kind 'external)
+
;;;###autoload
(defun browse-url-chromium (url &optional _new-window)
"Ask the Chromium WWW browser to load URL.
@@ -1119,13 +1253,15 @@ The optional argument NEW-WINDOW is not used."
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment)))
- (apply 'start-process
+ (apply #'start-process
(concat "chromium " url) nil
browse-url-chromium-program
(append
browse-url-chromium-arguments
(list url)))))
+(function-put 'browse-url-chromium 'browse-url-browser-kind 'external)
+
(defun browse-url-chrome (url &optional _new-window)
"Ask the Google Chrome WWW browser to load URL.
Default to the URL around or before point. The strings in
@@ -1135,13 +1271,15 @@ The optional argument NEW-WINDOW is not used."
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment)))
- (apply 'start-process
+ (apply #'start-process
(concat "google-chrome " url) nil
browse-url-chrome-program
(append
browse-url-chrome-arguments
(list url)))))
+(function-put 'browse-url-chrome 'browse-url-browser-kind 'external)
+
;;;###autoload
(defun browse-url-galeon (url &optional new-window)
"Ask the Galeon WWW browser to load URL.
@@ -1163,7 +1301,7 @@ used instead of `browse-url-new-window-flag'."
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment))
- (process (apply 'start-process
+ (process (apply #'start-process
(concat "galeon " url)
nil
browse-url-galeon-program
@@ -1176,8 +1314,10 @@ used instead of `browse-url-new-window-flag'."
'("--existing"))
(list url)))))
(set-process-sentinel process
- `(lambda (process change)
- (browse-url-galeon-sentinel process ,url)))))
+ (lambda (process _change)
+ (browse-url-galeon-sentinel process url)))))
+
+(function-put 'browse-url-galeon 'browse-url-browser-kind 'external)
(defun browse-url-galeon-sentinel (process url)
"Handle a change to the process communicating with Galeon."
@@ -1186,7 +1326,7 @@ used instead of `browse-url-new-window-flag'."
(let* ((process-environment (browse-url-process-environment)))
;; Galeon is not running - start it
(message "Starting %s..." browse-url-galeon-program)
- (apply 'start-process (concat "galeon " url) nil
+ (apply #'start-process (concat "galeon " url) nil
browse-url-galeon-program
(append browse-url-galeon-startup-arguments (list url))))))
@@ -1209,7 +1349,7 @@ used instead of `browse-url-new-window-flag'."
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment))
- (process (apply 'start-process
+ (process (apply #'start-process
(concat "epiphany " url)
nil
browse-url-epiphany-program
@@ -1222,8 +1362,10 @@ used instead of `browse-url-new-window-flag'."
'("--existing"))
(list url)))))
(set-process-sentinel process
- `(lambda (process change)
- (browse-url-epiphany-sentinel process ,url)))))
+ (lambda (process _change)
+ (browse-url-epiphany-sentinel process url)))))
+
+(function-put 'browse-url-epiphany 'browse-url-browser-kind 'external)
(defun browse-url-epiphany-sentinel (process url)
"Handle a change to the process communicating with Epiphany."
@@ -1231,7 +1373,7 @@ used instead of `browse-url-new-window-flag'."
(let* ((process-environment (browse-url-process-environment)))
;; Epiphany is not running - start it
(message "Starting %s..." browse-url-epiphany-program)
- (apply 'start-process (concat "epiphany " url) nil
+ (apply #'start-process (concat "epiphany " url) nil
browse-url-epiphany-program
(append browse-url-epiphany-startup-arguments (list url))))))
@@ -1244,10 +1386,18 @@ Optional argument SAME-WINDOW non-nil means show the URL in the
currently selected window instead."
(interactive (browse-url-interactive-arg "URL: "))
(require 'url-handlers)
- (let ((file-name-handler-alist
- (cons (cons url-handler-regexp 'url-file-handler)
- file-name-handler-alist)))
- (if same-window (find-file url) (find-file-other-window url))))
+ (let ((parsed (url-generic-parse-url url))
+ (func (if same-window 'find-file 'find-file-other-window)))
+ (if (and (equal (url-type parsed) "file")
+ (file-directory-p (url-filename parsed)))
+ ;; It's a directory; just open it.
+ (funcall func (url-filename parsed))
+ (let ((file-name-handler-alist
+ (cons (cons url-handler-regexp 'url-file-handler)
+ file-name-handler-alist)))
+ (funcall func url)))))
+
+(function-put 'browse-url-emacs 'browse-url-browser-kind 'internal)
;;;###autoload
(defun browse-url-gnome-moz (url &optional new-window)
@@ -1264,7 +1414,7 @@ When called non-interactively, optional second argument NEW-WINDOW is
used instead of `browse-url-new-window-flag'."
(declare (obsolete nil "25.1"))
(interactive (browse-url-interactive-arg "URL: "))
- (apply 'start-process (concat "gnome-moz-remote " url)
+ (apply #'start-process (concat "gnome-moz-remote " url)
nil
browse-url-gnome-moz-program
(append
@@ -1273,88 +1423,7 @@ used instead of `browse-url-new-window-flag'."
'("--newwin"))
(list "--raise" url))))
-;; --- Mosaic ---
-
-;;;###autoload
-(defun browse-url-mosaic (url &optional new-window)
- "Ask the XMosaic WWW browser to load URL.
-
-Default to the URL around or before point. The strings in variable
-`browse-url-mosaic-arguments' are also passed to Mosaic and the
-program is invoked according to the variable
-`browse-url-mosaic-program'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new Mosaic window, 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'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "Mosaic URL: "))
- (let ((pidfile (expand-file-name browse-url-mosaic-pidfile))
- pid)
- (if (file-readable-p pidfile)
- (with-temp-buffer
- (insert-file-contents pidfile)
- (setq pid (read (current-buffer)))))
- (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running
- (progn
- (with-temp-buffer
- (insert (if (browse-url-maybe-new-window new-window)
- "newwin\n"
- "goto\n")
- url "\n")
- (with-file-modes ?\700
- (if (file-exists-p
- (setq pidfile (format "/tmp/Mosaic.%d" pid)))
- (delete-file pidfile))
- ;; https://debbugs.gnu.org/17428. Use O_EXCL.
- (write-region nil nil pidfile nil 'silent nil 'excl)))
- ;; Send signal SIGUSR to Mosaic
- (message "Signaling Mosaic...")
- (signal-process pid 'SIGUSR1)
- ;; Or you could try:
- ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid))
- (message "Signaling Mosaic...done"))
- ;; Mosaic not running - start it
- (message "Starting %s..." browse-url-mosaic-program)
- (apply 'start-process "xmosaic" nil browse-url-mosaic-program
- (append browse-url-mosaic-arguments (list url)))
- (message "Starting %s...done" browse-url-mosaic-program))))
-
-;; --- Mosaic using CCI ---
-
-;;;###autoload
-(defun browse-url-cci (url &optional new-window)
- "Ask the XMosaic WWW browser to load URL.
-Default to the URL around or before point.
-
-This function only works for XMosaic version 2.5 or later. You must
-select `CCI' from XMosaic's File menu, set the CCI Port Address to the
-value of variable `browse-url-CCI-port', and enable `Accept requests'.
-
-When called interactively, if variable `browse-url-new-window-flag' is
-non-nil, load the document in a new browser window, 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'."
- (declare (obsolete nil "25.1"))
- (interactive (browse-url-interactive-arg "Mosaic URL: "))
- (open-network-stream "browse-url" " *browse-url*"
- browse-url-CCI-host browse-url-CCI-port)
- ;; Todo: start browser if fails
- (process-send-string "browse-url"
- (concat "get url (" url ") output "
- (if (browse-url-maybe-new-window new-window)
- "new"
- "current")
- "\r\n"))
- (process-send-string "browse-url" "disconnect\r\n")
- (delete-process "browse-url"))
+(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external)
;; --- Conkeror ---
;;;###autoload
@@ -1375,10 +1444,11 @@ new window, load it in a new buffer in an existing window instead.
When called non-interactively, use optional second argument
NEW-WINDOW instead of `browse-url-new-window-flag'."
+ (declare (obsolete nil "28.1"))
(interactive (browse-url-interactive-arg "URL: "))
(setq url (browse-url-encode-url url))
(let* ((process-environment (browse-url-process-environment)))
- (apply 'start-process (format "conkeror %s" url)
+ (apply #'start-process (format "conkeror %s" url)
nil
browse-url-conkeror-program
(append
@@ -1392,6 +1462,9 @@ NEW-WINDOW instead of `browse-url-new-window-flag'."
"window")
"buffer")
url))))))
+
+(function-put 'browse-url-conkeror 'browse-url-browser-kind 'external)
+
;; --- W3 ---
;; External.
@@ -1415,6 +1488,8 @@ used instead of `browse-url-new-window-flag'."
(w3-fetch-other-window url)
(w3-fetch url)))
+(function-put 'browse-url-w3 'browse-url-browser-kind 'internal)
+
;;;###autoload
(defun browse-url-w3-gnudoit (url &optional _new-window)
;; new-window ignored
@@ -1423,12 +1498,14 @@ The `browse-url-gnudoit-program' program is used with options given by
`browse-url-gnudoit-args'. Default to the URL around or before point."
(declare (obsolete nil "25.1"))
(interactive (browse-url-interactive-arg "W3 URL: "))
- (apply 'start-process (concat "gnudoit:" url) nil
+ (apply #'start-process (concat "gnudoit:" url) nil
browse-url-gnudoit-program
(append browse-url-gnudoit-args
(list (concat "(w3-fetch \"" url "\")")
"(raise-frame)"))))
+(function-put 'browse-url-w3-gnudoit 'browse-url-browser-kind 'internal)
+
;; --- Lynx in an xterm ---
;;;###autoload
@@ -1446,6 +1523,8 @@ The optional argument NEW-WINDOW is not used."
,@browse-url-xterm-args "-e" ,browse-url-text-browser
,url)))
+(function-put 'browse-url-text-xterm 'browse-url-browser-kind 'external)
+
;; --- Lynx in an Emacs "term" window ---
(declare-function term-char-mode "term" ())
@@ -1520,6 +1599,8 @@ used instead of `browse-url-new-window-flag'."
url
"\r")))))
+(function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal)
+
;; --- mailto ---
(autoload 'rfc2368-parse-mailto-url "rfc2368")
@@ -1567,6 +1648,8 @@ used instead of `browse-url-new-window-flag'."
(unless (bolp)
(insert "\n"))))))))
+(function-put 'browse-url-mail 'browse-url-browser-kind 'internal)
+
;; --- man ---
(defvar manual-program)
@@ -1578,7 +1661,9 @@ used instead of `browse-url-new-window-flag'."
(setq url (replace-regexp-in-string "\\`man:" "" url))
(cond
((executable-find manual-program) (man url))
- (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url)))))
+ (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url)))))
+
+(function-put 'browse-url-man 'browse-url-browser-kind 'internal)
;; --- Random browser ---
@@ -1593,10 +1678,12 @@ don't offer a form of remote control."
(interactive (browse-url-interactive-arg "URL: "))
(if (not browse-url-generic-program)
(error "No browser defined (`browse-url-generic-program')"))
- (apply 'call-process browse-url-generic-program nil
+ (apply #'call-process browse-url-generic-program nil
0 nil
(append browse-url-generic-args (list url))))
+(function-put 'browse-url-generic 'browse-url-browser-kind 'external)
+
;;;###autoload
(defun browse-url-kde (url &optional _new-window)
"Ask the KDE WWW browser to load URL.
@@ -1607,6 +1694,8 @@ The optional argument NEW-WINDOW is not used."
(apply #'start-process (concat "KDE " url) nil browse-url-kde-program
(append browse-url-kde-args (list url))))
+(function-put 'browse-url-kde 'browse-url-browser-kind 'external)
+
(defun browse-url-elinks-new-window (url)
"Ask the Elinks WWW browser to load URL in a new window."
(let ((process-environment (browse-url-process-environment)))
@@ -1616,6 +1705,9 @@ The optional argument NEW-WINDOW is not used."
browse-url-elinks-wrapper
(list "elinks" url)))))
+(function-put 'browse-url-elinks-new-window 'browse-url-browser-kind
+ 'external)
+
;;;###autoload
(defun browse-url-elinks (url &optional new-window)
"Ask the Elinks WWW browser to load URL.
@@ -1634,8 +1726,10 @@ from `browse-url-elinks-wrapper'."
(elinks-ping-process (start-process "elinks-ping" nil
"elinks" "-remote" "ping()")))
(set-process-sentinel elinks-ping-process
- `(lambda (process change)
- (browse-url-elinks-sentinel process ,url))))))
+ (lambda (process _change)
+ (browse-url-elinks-sentinel process url))))))
+
+(function-put 'browse-url-elinks 'browse-url-browser-kind 'external)
(defun browse-url-elinks-sentinel (process url)
"Determines if Elinks is running or a new one has to be started."
@@ -1659,9 +1753,9 @@ from `browse-url-elinks-wrapper'."
(defvar browse-url-button-map
(let ((map (make-sparse-keymap)))
- (define-key map "\r" 'browse-url-button-open)
- (define-key map [mouse-2] 'browse-url-button-open)
- (define-key map "w" 'browse-url-button-copy)
+ (define-key map "\r" #'browse-url-button-open)
+ (define-key map [mouse-2] #'browse-url-button-open)
+ (define-key map "w" #'browse-url-button-copy)
map)
"The keymap used for browse-url buttons.")
@@ -1699,6 +1793,7 @@ external browser instead of the default one."
(funcall browse-url-secondary-browser-function url)
(browse-url url))))
+;;;###autoload
(defun browse-url-button-open-url (url)
"Open URL using `browse-url'.
If `current-prefix-arg' is non-nil, use
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index a0984c5378e..4116d293e1b 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -51,11 +51,16 @@
(unless (boundp 'dbus-debug)
(defvar dbus-debug nil))
-;; Pacify byte compiler.
-(eval-when-compile (require 'cl-lib))
-
+(require 'cl-lib)
+(require 'seq)
+(require 'subr-x)
(require 'xml)
+;;; D-Bus constants.
+
+(defconst dbus-compound-types '(:array :variant :struct :dict-entry)
+ "D-Bus compound types, represented as list.")
+
(defconst dbus-service-dbus "org.freedesktop.DBus"
"The bus name used to talk to the bus itself.")
@@ -65,7 +70,8 @@
(defconst dbus-path-local (concat dbus-path-dbus "/Local")
"The object path used in local/in-process-generated messages.")
-;; Default D-Bus interfaces.
+
+;;; Default D-Bus interfaces.
(defconst dbus-interface-dbus "org.freedesktop.DBus"
"The interface exported by the service `dbus-service-dbus'.")
@@ -139,6 +145,17 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
+(defconst dbus-interface-monitoring (concat dbus-interface-dbus ".Monitoring")
+ "The monitoring interface.
+See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-become-monitor'.")
+
+;; <interface name="org.freedesktop.DBus.Monitoring">
+;; <method name="BecomeMonitor">
+;; <arg name="rule" type="as" direction="in"/>
+;; <arg name="flags" type="u" direction="in"/> ;; Not used, must be 0.
+;; </method>
+;; </interface>
+
(defconst dbus-interface-local (concat dbus-interface-dbus ".Local")
"An interface whose methods can only be invoked by the local implementation.")
@@ -148,7 +165,60 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
-;; Emacs defaults.
+(defconst dbus-annotation-deprecated (concat dbus-interface-dbus ".Deprecated")
+ "An annotation indicating a deprecated interface, method, signal, or property.")
+
+
+;;; Default D-Bus errors.
+
+(defgroup dbus nil
+ "Elisp bindings for D-Bus."
+ :group 'comm
+ :link '(custom-manual "(dbus)Top")
+ :version "28.1")
+
+(defconst dbus-error-dbus "org.freedesktop.DBus.Error"
+ "The namespace for default error names.
+See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
+
+(defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied")
+ "Security restrictions don't allow doing what you're trying to do.")
+
+(defconst dbus-error-disconnected (concat dbus-error-dbus ".Disconnected")
+ "The connection is disconnected and you're trying to use it.")
+
+(defconst dbus-error-failed (concat dbus-error-dbus ".Failed")
+ "A generic error; \"something went wrong\" - see the error message for more.")
+
+(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs")
+ "Invalid arguments passed to a method call.")
+
+(defconst dbus-error-no-reply (concat dbus-error-dbus ".NoReply")
+ "No reply to a message expecting one, usually means a timeout occurred.")
+
+(defconst dbus-error-property-read-only
+ (concat dbus-error-dbus ".PropertyReadOnly")
+ "Property you tried to set is read-only.")
+
+(defconst dbus-error-service-unknown (concat dbus-error-dbus ".ServiceUnknown")
+ "The bus doesn't know how to launch a service to supply the bus name you wanted.")
+
+(defconst dbus-error-unknown-interface
+ (concat dbus-error-dbus ".UnknownInterface")
+ "Interface you invoked a method on isn't known by the object.")
+
+(defconst dbus-error-unknown-method (concat dbus-error-dbus ".UnknownMethod")
+ "Method name you invoked isn't known by the object you invoked it on.")
+
+(defconst dbus-error-unknown-object (concat dbus-error-dbus ".UnknownObject")
+ "Object you invoked a method on isn't known.")
+
+(defconst dbus-error-unknown-property (concat dbus-error-dbus ".UnknownProperty")
+ "Property you tried to access isn't known by the object.")
+
+
+;;; Emacs defaults.
+
(defconst dbus-service-emacs "org.gnu.Emacs"
"The well known service name of Emacs.")
@@ -160,7 +230,8 @@ shall be subdirectories of this path.")
(defconst dbus-interface-emacs "org.gnu.Emacs"
"The interface namespace used by Emacs.")
-;; D-Bus constants.
+
+;;; Basic D-Bus message functions.
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
@@ -169,22 +240,16 @@ Otherwise, return result of last form in BODY, or all other errors."
`(condition-case err
(progn ,@body)
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
-(define-obsolete-variable-alias 'dbus-event-error-hooks
- 'dbus-event-error-functions "24.3")
(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors)
"Functions to be called when a D-Bus error happens in the event handler.
Every function must accept two arguments, the event and the error variable
caught in `condition-case' by `dbus-error'.")
-
-;;; Basic D-Bus message functions.
-
-(defvar dbus-return-values-table (make-hash-table :test 'equal)
+(defvar dbus-return-values-table (make-hash-table :test #'equal)
"Hash table for temporarily storing arguments of reply messages.
A key in this hash table is a list (:serial BUS SERIAL), like in
-`dbus-registered-objects-table'. BUS is either a Lisp symbol,
+`dbus-registered-objects-table'. BUS is either a Lisp keyword,
`:system' or `:session', or a string denoting the bus address.
SERIAL is the serial number of the reply message.
@@ -218,8 +283,8 @@ The result will be made available in `dbus-return-values-table'."
(defun dbus-call-method (bus service path interface method &rest args)
"Call METHOD on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
SERVICE is the D-Bus service name to be used. PATH is the D-Bus
object path SERVICE is registered at. INTERFACE is an interface
@@ -240,8 +305,8 @@ converted into D-Bus types via the following rules:
string => DBUS_TYPE_STRING
list => DBUS_TYPE_ARRAY
-All arguments can be preceded by a type symbol. For details about
-type symbols, see Info node `(dbus)Type Conversion'.
+All arguments can be preceded by a type keyword. For details
+about type keywords, see Info node `(dbus)Type Conversion'.
`dbus-call-method' returns the resulting values of METHOD as a list of
Lisp objects. The type conversion happens the other direction as for
@@ -286,7 +351,8 @@ object is returned instead of a list containing this single Lisp object.
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -301,8 +367,8 @@ object is returned instead of a list containing this single Lisp object.
(check-interval 0.001)
(key
(apply
- 'dbus-message-internal dbus-message-type-method-call
- bus service path interface method 'dbus-call-method-handler args))
+ #'dbus-message-internal dbus-message-type-method-call
+ bus service path interface method #'dbus-call-method-handler args))
(result (cons :pending nil)))
;; Wait until `dbus-call-method-handler' has put the result into
@@ -319,35 +385,32 @@ object is returned instead of a list containing this single Lisp object.
(puthash key result dbus-return-values-table)
(unwind-protect
- (progn
- (with-timeout ((if timeout (/ timeout 1000.0) 25)
- (signal 'dbus-error (list "call timed out")))
- (while (eq (car result) :pending)
- (let ((event (let ((inhibit-redisplay t) unread-command-events)
- (read-event nil nil check-interval))))
- (when event
- (if (ignore-errors (dbus-check-event event))
- (setf result (gethash key dbus-return-values-table))
- (setf unread-command-events
- (nconc unread-command-events
- (cons event nil)))))
- (when (< check-interval 1)
- (setf check-interval (* check-interval 1.05))))))
- (when (eq (car result) :error)
- (signal (cadr result) (cddr result)))
- (cdr result))
+ (progn
+ (with-timeout
+ ((if timeout (/ timeout 1000.0) 25)
+ (signal 'dbus-error `(,dbus-error-no-reply "Call timed out")))
+ (while (eq (car result) :pending)
+ (let ((event (let ((inhibit-redisplay t) unread-command-events)
+ (read-event nil nil check-interval))))
+ (when event
+ (if (ignore-errors (dbus-check-event event))
+ (setf result (gethash key dbus-return-values-table))
+ (setf unread-command-events
+ (nconc unread-command-events
+ (cons event nil)))))
+ (when (< check-interval 1)
+ (setf check-interval (* check-interval 1.05))))))
+ (when (eq (car result) :error)
+ (signal (cadr result) (cddr result)))
+ (cdr result))
(remhash key dbus-return-values-table))))
-;; `dbus-call-method' works non-blocking now.
-(defalias 'dbus-call-method-non-blocking 'dbus-call-method)
-(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3")
-
(defun dbus-call-method-asynchronously
(bus service path interface method handler &rest args)
"Call METHOD on the D-Bus BUS asynchronously.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
SERVICE is the D-Bus service name to be used. PATH is the D-Bus
object path SERVICE is registered at. INTERFACE is an interface
@@ -372,8 +435,8 @@ converted into D-Bus types via the following rules:
string => DBUS_TYPE_STRING
list => DBUS_TYPE_ARRAY
-All arguments can be preceded by a type symbol. For details about
-type symbols, see Info node `(dbus)Type Conversion'.
+All arguments can be preceded by a type keyword. For details
+about type keywords, see Info node `(dbus)Type Conversion'.
If HANDLER is a Lisp function, the function returns a key into the
hash table `dbus-registered-objects-table'. The corresponding entry
@@ -384,7 +447,7 @@ Example:
\(dbus-call-method-asynchronously
:system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
- \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message
+ \"org.freedesktop.Hal.Device\" \"GetPropertyString\" #\\='message
\"system.kernel.machine\")
-| i686
@@ -393,7 +456,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -406,15 +470,15 @@ Example:
(or (null handler) (functionp handler)
(signal 'wrong-type-argument (list 'functionp handler)))
- (apply 'dbus-message-internal dbus-message-type-method-call
+ (apply #'dbus-message-internal dbus-message-type-method-call
bus service path interface method handler args))
(defun dbus-send-signal (bus service path interface signal &rest args)
"Send signal SIGNAL on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address. The signal is sent from the D-Bus object
-Emacs is registered at BUS.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address. The signal is sent from the
+D-Bus object Emacs is registered at BUS.
SERVICE is the D-Bus name SIGNAL is sent to. It can be either a known
name or a unique name. If SERVICE is nil, the signal is sent as
@@ -432,8 +496,8 @@ converted into D-Bus types via the following rules:
string => DBUS_TYPE_STRING
list => DBUS_TYPE_ARRAY
-All arguments can be preceded by a type symbol. For details about
-type symbols, see Info node `(dbus)Type Conversion'.
+All arguments can be preceded by a type keyword. For details
+about type keywords, see Info node `(dbus)Type Conversion'.
Example:
@@ -443,7 +507,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (null service) (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -454,7 +519,7 @@ Example:
(or (stringp signal)
(signal 'wrong-type-argument (list 'stringp signal)))
- (apply 'dbus-message-internal dbus-message-type-signal
+ (apply #'dbus-message-internal dbus-message-type-signal
bus service path interface signal args))
(defun dbus-method-return-internal (bus service serial &rest args)
@@ -463,31 +528,50 @@ This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
(or (natnump serial)
(signal 'wrong-type-argument (list 'natnump serial)))
- (apply 'dbus-message-internal dbus-message-type-method-return
+ (apply #'dbus-message-internal dbus-message-type-method-return
bus service serial args))
-(defun dbus-method-error-internal (bus service serial &rest args)
+(defun dbus-method-error-internal (bus service serial error-name &rest args)
"Return error message for message SERIAL on the D-Bus BUS.
+ERROR-NAME must belong to the \"org.freedesktop.DBus.Error\" namespace.
This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
(or (natnump serial)
(signal 'wrong-type-argument (list 'natnump serial)))
- (apply 'dbus-message-internal dbus-message-type-error
- bus service serial args))
+ (apply #'dbus-message-internal dbus-message-type-error
+ bus service serial error-name args))
+
+(defun dbus-check-arguments (bus service &rest args)
+ "Check arguments ARGS by side effect.
+BUS, SERVICE and ARGS have the same format as in `dbus-call-method'.
+Any wrong argument triggers a D-Bus error. Otherwise, return t.
+This is an internal function, it shall not be used outside dbus.el."
+
+ (or (featurep 'dbusbind)
+ (signal 'dbus-error (list "Emacs not compiled with dbus support")))
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
+ (signal 'wrong-type-argument (list 'keywordp bus)))
+ (or (stringp service)
+ (signal 'wrong-type-argument (list 'stringp service)))
+
+ (apply #'dbus-message-internal dbus-message-type-invalid bus service args))
;;; Hash table of registered functions.
@@ -506,8 +590,9 @@ hash table."
(defun dbus-setenv (bus variable value)
"Set the value of the BUS environment variable named VARIABLE to VALUE.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address. Both VARIABLE and VALUE should be strings.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address. Both VARIABLE and VALUE should
+be strings.
Normally, services inherit the environment of the BUS daemon. This
function adds to or modifies that environment when activating services.
@@ -521,8 +606,8 @@ Some bus instances, such as `:system', may disable setting the environment."
(defun dbus-register-service (bus service &rest flags)
"Register known name SERVICE on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
SERVICE is the D-Bus service name that should be registered. It must
be a known name.
@@ -553,12 +638,13 @@ placed in the queue.
;; Add Peer handler.
(dbus-register-method
- bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register)
+ bus service nil dbus-interface-peer "Ping"
+ #'dbus-peer-handler 'dont-register)
;; Add ObjectManager handler.
(dbus-register-method
bus service nil dbus-interface-objectmanager "GetManagedObjects"
- 'dbus-managed-objects-handler 'dont-register)
+ #'dbus-managed-objects-handler 'dont-register)
(let ((arg 0)
reply)
@@ -582,8 +668,9 @@ placed in the queue.
(defun dbus-unregister-service (bus service)
"Unregister all objects related to SERVICE from D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address. SERVICE must be a known service name.
+BUS is either a Lisp keyword, `: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:
@@ -597,7 +684,7 @@ queue of this service."
(maphash
(lambda (key value)
- (unless (equal :serial (car key))
+ (unless (eq :serial (car key))
(dolist (elt value)
(ignore-errors
(when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
@@ -618,8 +705,8 @@ queue of this service."
(bus service path interface signal handler &rest args)
"Register for a signal on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
SERVICE is the D-Bus service name used by the sending D-Bus object.
It can be either a known name or the unique name of the D-Bus object
@@ -662,7 +749,7 @@ Example:
\(dbus-register-signal
:system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
- \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler)
+ \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" #\\='my-signal-handler)
=> ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\")
(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler))
@@ -681,7 +768,7 @@ Example:
(if (and (stringp service)
(not (zerop (length service)))
(not (string-equal service dbus-service-dbus))
- (not (string-match "^:" service)))
+ (/= (string-to-char service) ?:))
(setq uname (dbus-get-name-owner bus service))
(setq uname service))
@@ -710,7 +797,7 @@ Example:
;; `:arg0' .. `:arg63', `:path0' .. `:path63'.
((and (keywordp key)
(string-match
- "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$"
+ "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'"
(symbol-name key)))
(setq counter (match-string 2 (symbol-name key))
args (cdr args)
@@ -726,9 +813,7 @@ Example:
"path" "")
value))
;; `:arg-namespace', `:path-namespace'.
- ((and (keywordp key)
- (string-match
- "^:\\(arg\\|path\\)-namespace$" (symbol-name key)))
+ ((memq key '(:arg-namespace :path-namespace))
(setq args (cdr args)
value (car args))
(unless (stringp value)
@@ -736,8 +821,7 @@ Example:
(list "Wrong argument" key value)))
(format
",%s='%s'"
- (if (string-equal (match-string 1 (symbol-name key)) "path")
- "path_namespace" "arg0namespace")
+ (if (eq key :path-namespace) "path_namespace" "arg0namespace")
value))
;; `:eavesdrop'.
((eq key :eavesdrop)
@@ -751,11 +835,11 @@ Example:
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"AddMatch" rule)
(dbus-error
- (if (not (string-match "eavesdrop" rule))
+ (if (not (string-match-p "eavesdrop" rule))
(signal (car err) (cdr err))
;; The D-Bus spec says we shall fall back to a rule without eavesdrop.
(when dbus-debug (message "Removing eavesdrop from rule %s" rule))
- (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule))
+ (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t))
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"AddMatch" rule))))
@@ -776,8 +860,8 @@ Example:
(bus service path interface method handler &optional dont-register-service)
"Register METHOD on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
SERVICE is the D-Bus service name of the D-Bus object METHOD is
registered for. It must be a known name (see discussion of
@@ -788,10 +872,18 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
interface offered by SERVICE. It must provide METHOD.
HANDLER is a Lisp function to be called when a method call is
-received. It must accept the input arguments of METHOD. The return
-value of HANDLER is used for composing the returning D-Bus message.
-If HANDLER returns a reply message with an empty argument list,
-HANDLER must return the symbol `:ignore'.
+received. It must accept the input arguments of METHOD. The
+return value of HANDLER is used for composing the returning D-Bus
+message. If HANDLER returns a reply message with an empty
+argument list, HANDLER must return the keyword `:ignore' in order
+to distinguish it from nil (the boolean false).
+
+If HANDLER detects an error, it shall return the list `(:error
+ERROR-NAME ERROR-MESSAGE)'. ERROR-NAME is a namespaced string
+which characterizes the error type, and ERROR-MESSAGE is a free
+text string. Alternatively, any Emacs signal `dbus-error' in
+HANDLER raises a D-Bus error message with the error name
+\"org.freedesktop.DBus.Error.Failed\".
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
@@ -820,8 +912,9 @@ discovering the still incomplete interface."
(defun dbus-unregister-object (object)
"Unregister OBJECT from D-Bus.
OBJECT must be the result of a preceding `dbus-register-method',
-`dbus-register-property' or `dbus-register-signal' call. It
-returns t if OBJECT has been unregistered, nil otherwise.
+`dbus-register-signal', `dbus-register-property' or
+`dbus-register-monitor' call. The function returns t if OBJECT
+has been unregistered, nil otherwise.
When OBJECT identifies the last method or property, which is
registered for the respective service, Emacs releases its
@@ -859,7 +952,10 @@ association to the service from D-Bus."
(when (eq type :signal)
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
- "RemoveMatch" (nth 4 elt)))))
+ "RemoveMatch" (nth 4 elt)))
+ ;; Delete monitor connection by reestablishing private bus.
+ (when (eq type :monitor)
+ (dbus-init-bus bus 'private))))
;; Check, whether there is still a registered function or property
;; for the given service. If not, unregister the service from the
@@ -869,16 +965,19 @@ association to the service from D-Bus."
(progn
(maphash
(lambda (k v)
- (dolist (e v)
- (ignore-errors
- (and
- ;; Bus.
- (equal bus (cadr k))
- ;; Service.
- (string-equal service (cadr e))
- ;; Non-empty object path.
- (nth 2 e)
- (throw :found t)))))
+ (when (consp v)
+ (dolist (e v)
+ (ignore-errors
+ (and
+ ;; Type.
+ (eq type (car k))
+ ;; Bus.
+ (equal bus (cadr k))
+ ;; Service.
+ (string-equal service (cadr e))
+ ;; Non-empty object path.
+ (nth 2 e)
+ (throw :found t))))))
dbus-registered-objects-table)
nil))))
(dbus-unregister-service bus service))
@@ -893,9 +992,7 @@ association to the service from D-Bus."
STRING shall be UTF-8 coded."
(if (zerop (length string))
'(:array :signature "y")
- (let (result)
- (dolist (elt (string-to-list string) (append '(:array) result))
- (setq result (append result (list :byte elt)))))))
+ (cons :array (mapcan (lambda (c) (list :byte c)) string))))
(defun dbus-byte-array-to-string (byte-array &optional multibyte)
"Transform BYTE-ARRAY into UTF-8 coded string.
@@ -903,12 +1000,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte
array as produced by `dbus-string-to-byte-array'. The resulting
string is unibyte encoded, unless MULTIBYTE is non-nil."
(apply
- (if multibyte 'string 'unibyte-string)
- (if (equal byte-array '(:array :signature "y"))
- nil
- (let (result)
- (dolist (elt byte-array result)
- (when (characterp elt) (setq result (append result `(,elt)))))))))
+ (if multibyte #'string #'unibyte-string)
+ (unless (equal byte-array '(:array :signature "y"))
+ (seq-filter #'characterp byte-array))))
(defun dbus-escape-as-identifier (string)
"Escape an arbitrary STRING so it follows the rules for a C identifier.
@@ -930,9 +1024,9 @@ telepathy-glib's `tp_escape_as_identifier'."
(if (zerop (length string))
"_"
(replace-regexp-in-string
- "^[0-9]\\|[^A-Za-z0-9]"
+ "\\`[0-9]\\|[^A-Za-z0-9]"
(lambda (x) (format "_%2x" (aref x 0)))
- string)))
+ string nil t)))
(defun dbus-unescape-from-identifier (string)
"Retrieve the original string from the encoded STRING as unibyte string.
@@ -942,7 +1036,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'."
(replace-regexp-in-string
"_.."
(lambda (x) (byte-to-string (string-to-number (substring x 1) 16)))
- string)))
+ string nil t)))
;;; D-Bus events.
@@ -951,26 +1045,37 @@ STRING must have been encoded with `dbus-escape-as-identifier'."
"Check whether EVENT is a well formed D-Bus event.
EVENT is a list which starts with symbol `dbus-event':
- (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
+ (dbus-event BUS TYPE SERIAL SERVICE DESTINATION PATH
+ INTERFACE MEMBER HANDLER &rest ARGS)
BUS identifies the D-Bus the message is coming from. It is
-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'.
+either a Lisp keyword, `:system', `:session', `:systemp-private'
+or `:session-private', 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 when TYPE is
+equal `dbus-message-type-method-return' or `dbus-message-type-error'.
+
+SERVICE and PATH are the unique name and the object path of the
+D-Bus object emitting the message. DESTINATION is the D-Bus name
+the message is dedicated to, or nil in case the message is a
+broadcast signal.
+
+INTERFACE and MEMBER denote the message which has been sent.
+When TYPE is `dbus-message-type-error', MEMBER is the error name.
+
+HANDLER is the function which has been registered for this
+message. ARGS are the typed arguments as returned from the
+message. They are passed to HANDLER without type information,
+when it is called during event handling in `dbus-handle-event'.
This function signals a `dbus-error' if the event is not well
formed."
(when dbus-debug (message "DBus-Event %s" event))
(unless (and (listp event)
(eq (car event) 'dbus-event)
- ;; Bus symbol.
- (or (symbolp (nth 1 event))
+ ;; Bus keyword.
+ (or (keywordp (nth 1 event))
(stringp (nth 1 event)))
;; Type.
(and (natnump (nth 2 event))
@@ -982,54 +1087,104 @@ formed."
(= dbus-message-type-error (nth 2 event))
(or (stringp (nth 4 event))
(null (nth 4 event))))
- ;; Object path.
+ ;; Destination.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
- (stringp (nth 5 event)))
- ;; Interface.
+ (or (stringp (nth 5 event))
+ (null (nth 5 event))))
+ ;; Object path.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 6 event)))
- ;; Member.
+ ;; Interface.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 7 event)))
+ ;; Member.
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (stringp (nth 8 event)))
;; Handler.
- (functionp (nth 8 event)))
+ (functionp (nth 9 event))
+ ;; Arguments.
+ (listp (nthcdr 10 event)))
(signal 'dbus-error (list "Not a valid D-Bus event" event))))
+(defun dbus-delete-types (&rest args)
+ "Delete type information from arguments retrieved via `dbus-handle-event'.
+Basic type arguments (TYPE VALUE) will be transformed into VALUE, and
+compound type arguments (TYPE VALUE) will be transformed into (VALUE)."
+ (car
+ (mapcar
+ (lambda (elt)
+ (cond
+ ((atom elt) elt)
+ ((memq (car elt) dbus-compound-types)
+ (mapcar #'dbus-delete-types (cdr elt)))
+ (t (cadr elt))))
+ args)))
+
+(defun dbus-flatten-types (arg)
+ "Flatten type information from argument retrieved via `dbus-handle-event'.
+Basic type arguments (TYPE VALUE) will be transformed into TYPE VALUE, and
+compound type arguments (TYPE VALUE) will be kept as is."
+ (let (result)
+ (dolist (elt arg)
+ (cond
+ ((atom elt) (push elt result))
+ ((and (not (memq (car elt) dbus-compound-types)))
+ (push (car elt) result)
+ (push (cadr elt) result))
+ (t
+ (push (cons (car elt) (dbus-flatten-types (cdr elt))) result))))
+ (nreverse result)))
+
;;;###autoload
(defun dbus-handle-event (event)
"Handle events from the D-Bus.
EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being
-part of the event, is called with arguments ARGS.
+part of the event, is called with arguments ARGS (without type information).
If the HANDLER returns a `dbus-error', it is propagated as return message."
+ (declare (completion ignore))
(interactive "e")
(condition-case err
- (let (result)
+ (let (monitor args result)
;; We ignore not well-formed events.
(dbus-check-event event)
- ;; Error messages must be propagated.
- (when (= dbus-message-type-error (nth 2 event))
- (signal 'dbus-error (nthcdr 9 event)))
- ;; Apply the handler.
- (setq result (apply (nth 8 event) (nthcdr 9 event)))
- ;; Return a message when it is a message call.
- (when (= dbus-message-type-method-call (nth 2 event))
- (dbus-ignore-errors
- (if (eq result :ignore)
- (dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event))
- (apply 'dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event)
- (if (consp result) result (list result)))))))
+ ;; Remove type information.
+ (setq args (mapcar #'dbus-delete-types (nthcdr 10 event)))
+ (setq monitor
+ (gethash
+ (list :monitor (nth 1 event)) dbus-registered-objects-table))
+ (if monitor
+ ;; A monitor event shall not trigger other operations, and
+ ;; it shall not trigger D-Bus errors.
+ (setq result (dbus-ignore-errors (apply (nth 9 event) args)))
+ ;; Error messages must be propagated. The error name is in
+ ;; the member slot.
+ (when (= dbus-message-type-error (nth 2 event))
+ (signal 'dbus-error (cons (nth 8 event) args)))
+ ;; Apply the handler.
+ (setq result (apply (nth 9 event) args))
+ ;; Return an (error) message when it is a message call.
+ (when (= dbus-message-type-method-call (nth 2 event))
+ (dbus-ignore-errors
+ (if (eq (car-safe result) :error)
+ (apply #'dbus-method-error-internal
+ (nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
+ (if (eq result :ignore)
+ (dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event))
+ (apply #'dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event)
+ (if (consp result) result (list result)))))))))
;; Error handling.
(dbus-error
;; Return an error message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(dbus-method-error-internal
- (nth 1 event) (nth 4 event) (nth 3 event) (cadr err))))
+ (nth 1 event) (nth 4 event) (nth 3 event) dbus-error-failed
+ (error-message-string err))))
;; Propagate D-Bus error messages.
(run-hook-with-args 'dbus-event-error-functions event err)
(when dbus-debug
@@ -1037,8 +1192,8 @@ 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 a Lisp symbol, `:system' or `:session', or a
-string denoting the bus address. EVENT is a D-Bus event, see
+The result is either a Lisp keyword, `:system' or `:session', or
+a string denoting the bus address. EVENT is a D-Bus event, see
`dbus-check-event'. This function signals a `dbus-error' if the
event is not well formed."
(dbus-check-event event)
@@ -1069,13 +1224,21 @@ formed."
(dbus-check-event event)
(nth 4 event))
+(defun dbus-event-destination-name (event)
+ "Return the name of the D-Bus object the event is dedicated to.
+The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
+This function signals a `dbus-error' if the event is not well
+formed."
+ (dbus-check-event event)
+ (nth 5 event))
+
(defun dbus-event-path-name (event)
"Return the object path of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
- (nth 5 event))
+ (nth 6 event))
(defun dbus-event-interface-name (event)
"Return the interface name of the D-Bus object the event is coming from.
@@ -1083,15 +1246,32 @@ The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
- (nth 6 event))
+ (nth 7 event))
(defun dbus-event-member-name (event)
"Return the member name the event is coming from.
-It is either a signal name or a method name. The result is a
-string. EVENT is a D-Bus event, see `dbus-check-event'. This
-function signals a `dbus-error' if the event is not well formed."
+It is either a signal name, a method name or an error name. The
+result is a string. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
(dbus-check-event event)
- (nth 7 event))
+ (nth 8 event))
+
+(defun dbus-event-handler (event)
+ "Return the handler the event is applied with.
+The result is a function. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
+ (dbus-check-event event)
+ (nth 9 event))
+
+(defun dbus-event-arguments (event)
+ "Return the arguments the event is carrying on.
+The result is a list of arguments. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
+ (dbus-check-event event)
+ (nthcdr 10 event))
;;; D-Bus registered names.
@@ -1101,10 +1281,11 @@ function signals a `dbus-error' if the event is not well formed."
BUS defaults to `:system' when nil or omitted. 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
- (or bus :system) dbus-service-dbus
- dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ (or bus :system) dbus-service-dbus
+ dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))))
(defun dbus-list-names (bus)
"Return the service names registered at D-Bus BUS.
@@ -1112,34 +1293,36 @@ The result is a list of strings, which is nil when there are no
registered service names at all. Well known names are strings
like \"org.freedesktop.DBus\". Names starting with \":\" are
unique names for services."
- (dbus-ignore-errors
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))))
(defun dbus-list-known-names (bus)
"Retrieve all services which correspond to a known name in BUS.
A service has a known name if it doesn't start with \":\"."
- (let (result)
- (dolist (name (dbus-list-names bus) (nreverse result))
- (unless (string-equal ":" (substring name 0 1))
- (push name result)))))
+ (seq-remove (lambda (name)
+ (= (string-to-char name) ?:))
+ (dbus-list-names bus)))
(defun dbus-list-queued-owners (bus service)
"Return the unique names registered at D-Bus BUS and queued for SERVICE.
The result is a list of strings, or nil when there are no queued
name owner service names at all."
- (dbus-ignore-errors
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus
- dbus-interface-dbus "ListQueuedOwners" service)))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus
+ dbus-interface-dbus "ListQueuedOwners" service))))
(defun dbus-get-name-owner (bus service)
"Return the name owner of SERVICE registered at D-Bus BUS.
The result is either a string, or nil if there is no name owner."
- (dbus-ignore-errors
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus
- dbus-interface-dbus "GetNameOwner" service)))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus
+ dbus-interface-dbus "GetNameOwner" service))))
(defun dbus-ping (bus service &optional timeout)
"Check whether SERVICE is registered for D-Bus BUS.
@@ -1167,7 +1350,8 @@ check whether SERVICE is already running, you can instead write
"Default handler for the \"org.freedesktop.DBus.Peer\" interface.
It will be registered for all objects created by `dbus-register-service'."
(let* ((last-input-event last-input-event)
- (method (dbus-event-member-name last-input-event)))
+ (method (dbus-event-member-name last-input-event))
+ (path (dbus-event-path-name last-input-event)))
(cond
;; "Ping" does not return an output parameter.
((string-equal method "Ping")
@@ -1177,37 +1361,62 @@ It will be registered for all objects created by `dbus-register-service'."
(signal
'dbus-error
(list
- (format "%s.GetMachineId not implemented" dbus-interface-peer)))))))
+ (format "%s.GetMachineId not implemented" dbus-interface-peer))))
+ (t `(:error ,dbus-error-unknown-method
+ ,(format-message
+ "No such method \"%s.%s\" at path \"%s\""
+ dbus-interface-peer method path))))))
;;; D-Bus introspection.
+(defsubst dbus--introspect-names (object tag)
+ "Return the names of the children of OBJECT with TAG."
+ (mapcar (lambda (elt)
+ (dbus-introspect-get-attribute elt "name"))
+ (xml-get-children object tag)))
+
+(defsubst dbus--introspect-name (object tag name)
+ "Return the first child of OBJECT with TAG, whose name is NAME."
+ (seq-find (lambda (elt)
+ (string-equal (dbus-introspect-get-attribute elt "name") name))
+ (xml-get-children object tag)))
+
(defun dbus-introspect (bus service path)
"Return all interfaces and sub-nodes of SERVICE,
registered at object path PATH at bus BUS.
-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."
+BUS is either a Lisp keyword, `: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-ignore-errors
- (dbus-call-method
- bus service path dbus-interface-introspectable "Introspect"
- :timeout 1000)))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus service path dbus-interface-introspectable "Introspect"
+ :timeout 1000))))
+
+(defalias 'dbus--parse-xml-buffer
+ (if (libxml-available-p)
+ (lambda ()
+ (xml-remove-comments (point-min) (point-max))
+ (libxml-parse-xml-region (point-min) (point-max)))
+ (lambda ()
+ (car (xml-parse-region (point-min) (point-max)))))
+ "Compatibility shim for `libxml-parse-xml-region'.")
(defun dbus-introspect-xml (bus service path)
"Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
The data are a parsed list. The root object is a \"node\",
representing the object path PATH. The root object can contain
\"interface\" and further \"node\" objects."
- ;; We don't want to raise errors.
- (xml-node-name
- (ignore-errors
- (with-temp-buffer
- (insert (dbus-introspect bus service path))
- (xml-parse-region (point-min) (point-max))))))
+ (with-temp-buffer
+ ;; We don't want to raise errors.
+ (ignore-errors
+ (insert (dbus-introspect bus service path))
+ (dbus--parse-xml-buffer))))
(defun dbus-introspect-get-attribute (object attribute)
"Return the ATTRIBUTE value of D-Bus introspection OBJECT.
@@ -1219,21 +1428,15 @@ the D-Bus specification."
"Return all node names of SERVICE in D-Bus BUS at object path PATH.
It returns a list of strings. The node names stand for further
object paths of the D-Bus service."
- (let ((object (dbus-introspect-xml bus service path))
- result)
- (dolist (elt (xml-get-children object 'node) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names (dbus-introspect-xml bus service path) 'node))
(defun dbus-introspect-get-all-nodes (bus service path)
"Return all node names of SERVICE in D-Bus BUS at object path PATH.
It returns a list of strings, which are further object paths of SERVICE."
- (let ((result (list path)))
- (dolist (elt
- (dbus-introspect-get-node-names bus service path)
- result)
- (setq elt (expand-file-name elt path))
- (setq result
- (append result (dbus-introspect-get-all-nodes bus service elt))))))
+ (cons path (mapcan (lambda (elt)
+ (setq elt (expand-file-name elt path))
+ (dbus-introspect-get-all-nodes bus service elt))
+ (dbus-introspect-get-node-names bus service path))))
(defun dbus-introspect-get-interface-names (bus service path)
"Return all interface names of SERVICE in D-Bus BUS at object path PATH.
@@ -1244,10 +1447,7 @@ always present. Another default interface is
\"org.freedesktop.DBus.Properties\". If present, \"interface\"
objects can also have \"property\" objects as children, beside
\"method\" and \"signal\" objects."
- (let ((object (dbus-introspect-xml bus service path))
- result)
- (dolist (elt (xml-get-children object 'interface) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface))
(defun dbus-introspect-get-interface (bus service path interface)
"Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH.
@@ -1256,22 +1456,14 @@ and a member of the list returned by
`dbus-introspect-get-interface-names'. The resulting
\"interface\" object can contain \"method\", \"signal\",
\"property\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-xml bus service path) 'interface)))
- (while (and elt
- (not (string-equal
- interface
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name (dbus-introspect-xml bus service path)
+ 'interface interface))
(defun dbus-introspect-get-method-names (bus service path interface)
"Return a list of strings of all method names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'method) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'method))
(defun dbus-introspect-get-method (bus service path interface method)
"Return method METHOD of interface INTERFACE as an XML object.
@@ -1279,22 +1471,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH.
METHOD must be a string and a member of the list returned by
`dbus-introspect-get-method-names'. The resulting \"method\"
object can contain \"arg\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'method)))
- (while (and elt
- (not (string-equal
- method (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'method method))
(defun dbus-introspect-get-signal-names (bus service path interface)
"Return a list of strings of all signal names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'signal) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'signal))
(defun dbus-introspect-get-signal (bus service path interface signal)
"Return signal SIGNAL of interface INTERFACE as an XML object.
@@ -1302,22 +1487,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH.
SIGNAL must be a string, element of the list returned by
`dbus-introspect-get-signal-names'. The resulting \"signal\"
object can contain \"arg\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'signal)))
- (while (and elt
- (not (string-equal
- signal (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'signal signal))
(defun dbus-introspect-get-property-names (bus service path interface)
"Return a list of strings of all property names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'property) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'property))
(defun dbus-introspect-get-property (bus service path interface property)
"Return PROPERTY of INTERFACE as an XML object.
@@ -1325,15 +1503,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH.
PROPERTY must be a string and a member of the list returned by
`dbus-introspect-get-property-names'. The resulting PROPERTY
object can contain \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'property)))
- (while (and elt
- (not (string-equal
- property
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'property property))
(defun dbus-introspect-get-annotation-names
(bus service path interface &optional name)
@@ -1341,15 +1513,13 @@ object can contain \"annotation\" children."
If NAME is nil, the annotations are children of INTERFACE,
otherwise NAME must be a \"method\", \"signal\", or \"property\"
object, where the annotations belong to."
- (let ((object
- (if name
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name)
- (dbus-introspect-get-property bus service path interface name))
- (dbus-introspect-get-interface bus service path interface)))
- result)
- (dolist (elt (xml-get-children object 'annotation) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (if name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)
+ (dbus-introspect-get-property bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface))
+ 'annotation))
(defun dbus-introspect-get-annotation
(bus service path interface name annotation)
@@ -1357,22 +1527,13 @@ object, where the annotations belong to."
If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise
NAME must be the name of a \"method\", \"signal\", or
\"property\" object, where the ANNOTATION belongs to."
- (let ((elt (xml-get-children
- (if name
- (or (dbus-introspect-get-method
- bus service path interface name)
- (dbus-introspect-get-signal
- bus service path interface name)
- (dbus-introspect-get-property
- bus service path interface name))
- (dbus-introspect-get-interface bus service path interface))
- 'annotation)))
- (while (and elt
- (not (string-equal
- annotation
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (if name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)
+ (dbus-introspect-get-property bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface))
+ 'annotation annotation))
(defun dbus-introspect-get-argument-names (bus service path interface name)
"Return a list of all argument names as a list of strings.
@@ -1380,61 +1541,55 @@ NAME must be a \"method\" or \"signal\" object.
Argument names are optional, the function can return nil
therefore, even if the method or signal has arguments."
- (let ((object
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name)))
- result)
- (dolist (elt (xml-get-children object 'arg) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name))
+ 'arg))
(defun dbus-introspect-get-argument (bus service path interface name arg)
"Return argument ARG as XML object.
NAME must be a \"method\" or \"signal\" object. ARG must be a
string and a member of the list returned by
`dbus-introspect-get-argument-names'."
- (let ((elt (xml-get-children
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name))
- 'arg)))
- (while (and elt
- (not (string-equal
- arg (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name))
+ 'arg arg))
(defun dbus-introspect-get-signature
(bus service path interface name &optional direction)
- "Return signature of a `method' or `signal' represented by NAME as a string.
+ "Return signature of a `method', `property' or `signal' represented by NAME.
If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
If DIRECTION is nil, \"in\" is assumed.
-If NAME is a `signal', and DIRECTION is non-nil, DIRECTION must
-be \"out\"."
+If NAME is a `signal' or a `property', DIRECTION is ignored."
;; For methods, we use "in" as default direction.
(let ((object (or (dbus-introspect-get-method
bus service path interface name)
(dbus-introspect-get-signal
+ bus service path interface name)
+ (dbus-introspect-get-property
bus service path interface name))))
- (when (and (string-equal
- "method" (dbus-introspect-get-attribute object "name"))
- (not (stringp direction)))
+ (when (and (eq 'method (car object)) (not (stringp direction)))
(setq direction "in"))
;; In signals, no direction is given.
- (when (string-equal "signal" (dbus-introspect-get-attribute object "name"))
+ (when (eq 'signal (car object))
(setq direction nil))
;; Collect the signatures.
- (mapconcat
- (lambda (x)
- (let ((arg (dbus-introspect-get-argument
- bus service path interface name x)))
- (if (or (not (stringp direction))
- (string-equal
- direction
- (dbus-introspect-get-attribute arg "direction")))
- (dbus-introspect-get-attribute arg "type")
- "")))
- (dbus-introspect-get-argument-names bus service path interface name)
- "")))
+ (if (eq 'property (car object))
+ (dbus-introspect-get-attribute object "type")
+ (mapconcat
+ (lambda (x)
+ (let ((arg (dbus-introspect-get-argument
+ bus service path interface name x)))
+ (if (or (not (stringp direction))
+ (string-equal
+ direction
+ (dbus-introspect-get-attribute arg "direction")))
+ (dbus-introspect-get-attribute arg "type")
+ "")))
+ (dbus-introspect-get-argument-names bus service path interface name)
+ ""))))
;;; D-Bus properties.
@@ -1442,52 +1597,58 @@ be \"out\"."
(defun dbus-get-property (bus service path interface property)
"Return the value of PROPERTY of INTERFACE.
It will be checked at BUS, SERVICE, PATH. The result can be any
-valid D-Bus value, or nil if there is no PROPERTY."
- (dbus-ignore-errors
- ;; "Get" returns a variant, so we must use the `car'.
- (car
- (dbus-call-method
- bus service path dbus-interface-properties
- "Get" :timeout 500 interface property))))
-
-(defun dbus-set-property (bus service path interface property value)
- "Set value of PROPERTY of INTERFACE to VALUE.
-It will be checked at BUS, SERVICE, PATH. When the value is
-successfully set return VALUE. Otherwise, return nil."
- (dbus-ignore-errors
- ;; "Set" requires a variant.
+valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read."
+ ;; "Get" returns a variant, so we must use the `car'.
+ (car
(dbus-call-method
bus service path dbus-interface-properties
- "Set" :timeout 500 interface property (list :variant value))
- ;; Return VALUE.
- (dbus-get-property bus service path interface property)))
+ "Get" :timeout 500 interface property)))
+
+(defun dbus-set-property (bus service path interface property &rest args)
+ "Set value of PROPERTY of INTERFACE to VALUE.
+It will be checked at BUS, SERVICE, PATH. VALUE can be preceded
+by a TYPE keyword. When the value is successfully set, and the
+property's access type is not `:write', return VALUE. Otherwise,
+return nil.
+
+\(dbus-set-property BUS SERVICE PATH INTERFACE PROPERTY [TYPE] VALUE)"
+ ;; "Set" requires a variant.
+ (dbus-call-method
+ bus service path dbus-interface-properties
+ "Set" :timeout 500 interface property (cons :variant args))
+ ;; Return VALUE.
+ (condition-case err
+ (dbus-get-property bus service path interface property)
+ (dbus-error
+ (if (string-equal dbus-error-access-denied (cadr err))
+ (car args)
+ (signal (car err) (cdr err))))))
(defun dbus-get-all-properties (bus service path interface)
"Return all properties of INTERFACE at BUS, SERVICE, PATH.
The result is a list of entries. Every entry is a cons of the
name of the property, and its value. If there are no properties,
nil is returned."
- (dbus-ignore-errors
- ;; "GetAll" returns "a{sv}".
- (let (result)
- (dolist (dict
- (dbus-call-method
- bus service path dbus-interface-properties
- "GetAll" :timeout 500 interface)
- (nreverse result))
- (push (cons (car dict) (cl-caadr dict)) result)))))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ ;; "GetAll" returns "a{sv}".
+ (mapcar (lambda (dict)
+ (cons (car dict) (caadr dict)))
+ (dbus-call-method bus service path dbus-interface-properties
+ "GetAll" :timeout 500 interface)))))
(defun dbus-get-this-registered-property (bus _service path interface property)
"Return PROPERTY entry of `dbus-registered-objects-table'.
Filter out not matching PATH."
;; Remove entries not belonging to this case.
- (seq-remove
+ (seq-filter
(lambda (item)
- (not (string-equal path (nth 2 item))))
+ (string-equal path (nth 2 item)))
(gethash (list :property bus interface property)
dbus-registered-objects-table)))
-(defun dbus-get-other-registered-property (bus _service path interface property)
+(defun dbus-get-other-registered-properties
+ (bus _service path interface property)
"Return PROPERTY entry of `dbus-registered-objects-table'.
Filter out matching PATH."
;; Remove matching entries.
@@ -1498,12 +1659,11 @@ Filter out matching PATH."
dbus-registered-objects-table)))
(defun dbus-register-property
- (bus service path interface property access value
- &optional emits-signal dont-register-service)
+ (bus service path interface property access &rest args)
"Register PROPERTY on the D-Bus BUS.
-BUS is either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address.
+BUS is either a Lisp keyword, `: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 (see discussion of DONT-REGISTER-SERVICE below).
@@ -1513,14 +1673,16 @@ 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).
+the keyword `:read', `:write' or `:readwrite'.
+
+VALUE is the initial value of the property, it can be of any
+valid type (see `dbus-call-method' for details). VALUE can be
+preceded by a TYPE keyword.
If PROPERTY already exists on PATH, it will be overwritten. For
properties with access type `:read' this is the only way to
-change their values. Properties with access type `:readwrite'
-can be changed by `dbus-set-property'.
+change their values. Properties with access type `:write' or
+`:readwrite' 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
@@ -1533,116 +1695,167 @@ 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 'wrong-type-argument (list "Access type invalid" access)))
-
- ;; Add handlers for the three property-related methods.
- (dbus-register-method
- 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 'dont-register)
- (dbus-register-method
- bus service path dbus-interface-properties "Set"
- 'dbus-property-handler 'dont-register)
-
- ;; Register SERVICE.
- (unless (or dont-register-service (member service (dbus-list-names bus)))
- (dbus-register-service bus service))
-
- ;; Send the PropertiesChanged signal.
- (when emits-signal
- (dbus-send-signal
- bus service path dbus-interface-properties "PropertiesChanged"
- `((:dict-entry ,property (: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 :property bus interface property))
- (val
- (cons
- (list
- nil service path
- (cons
- (if emits-signal (list access :emits-signal) (list access))
- value))
- (dbus-get-other-registered-property
- bus service path interface property))))
- (puthash key val dbus-registered-objects-table)
-
- ;; Return the object.
- (list key (list service path))))
+clients from discovering the still incomplete interface.
+
+\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \
+[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)"
+ (let (;; Read basic type keyword.
+ (type (when (keywordp (car args)) (pop args)))
+ (value (pop args))
+ (emits-signal (pop args))
+ (dont-register-service (pop args)))
+ (unless (member access '(:read :write :readwrite))
+ (signal 'wrong-type-argument (list "Access type invalid" access)))
+ (unless (or type (consp value))
+ (setq type
+ (cond
+ ((memq value '(t nil)) :boolean)
+ ((natnump value) :uint32)
+ ((fixnump value) :int32)
+ ((floatp value) :double)
+ ((stringp value) :string)
+ (t
+ (signal 'wrong-type-argument (list "Value type invalid" value))))))
+ (unless (consp value)
+ (setq value (list type value)))
+ (setq value (if (member (car value) dbus-compound-types)
+ (list :variant value) (cons :variant value)))
+ (dbus-check-arguments bus service value)
+
+ ;; Add handlers for the three property-related methods.
+ (dbus-register-method
+ 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 'dont-register)
+ (dbus-register-method
+ bus service path dbus-interface-properties "Set"
+ #'dbus-property-handler 'dont-register)
+
+ ;; Register SERVICE.
+ (unless (or dont-register-service (member service (dbus-list-names bus)))
+ (dbus-register-service bus service))
+
+ ;; Send the PropertiesChanged signal.
+ (when emits-signal
+ (dbus-send-signal
+ bus service path dbus-interface-properties "PropertiesChanged"
+ interface
+ ;; changed_properties.
+ (if (eq access :write)
+ '(:array: :signature "{sv}")
+ `(:array (:dict-entry ,property ,value)))
+ ;; invalidated_properties.
+ (if (eq access :write)
+ `(:array ,property)
+ '(:array))))
+
+ ;; Create a hash table entry. We use nil for the unique name,
+ ;; because the property might be accessed from anybody.
+ (let ((key (list :property bus interface property))
+ (val
+ (cons
+ (list nil service path (list access emits-signal value))
+ (dbus-get-other-registered-properties
+ bus service path interface property))))
+ (puthash key val dbus-registered-objects-table)
+
+ ;; Return the object.
+ (list key (list service path)))))
(defun dbus-property-handler (&rest args)
"Default handler for the \"org.freedesktop.DBus.Properties\" interface.
It will be registered for all objects created by `dbus-register-property'."
- (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))
- (property (cadr args)))
+ (let* ((last-input-event last-input-event)
+ (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))
+ (property (cadr args)))
(cond
;; "Get" returns a variant.
((string-equal method "Get")
- (let ((entry (dbus-get-this-registered-property
- bus service path interface property)))
- (when (string-equal path (nth 2 (car entry)))
- `((:variant ,(cdar (last (car entry))))))))
-
- ;; "Set" expects a variant.
+ (let* ((entry (dbus-get-this-registered-property
+ bus service path interface property))
+ (object (car (last (car entry)))))
+ (cond
+ ((not (consp object))
+ `(:error ,dbus-error-unknown-property
+ ,(format-message
+ "No such property \"%s\" at path \"%s\"" property path)))
+ ((eq :write (car object))
+ `(:error ,dbus-error-access-denied
+ ,(format-message
+ "Property \"%s\" at path \"%s\" is not readable" property path)))
+ ;; Return the result. Since variant is a list, we must embed
+ ;; it into another list.
+ (t (list (nth 2 object))))))
+
+ ;; "Set" needs the third typed argument from `last-input-event'.
((string-equal method "Set")
- (let* ((value (caar (cddr args)))
+ (let* ((value (dbus-flatten-types (nth 12 last-input-event)))
(entry (dbus-get-this-registered-property
bus service path interface property))
- ;; 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 (member :readwrite (car object))
- (signal 'dbus-error
- (list "Property not writable at path" property path)))
- (puthash (list :property bus interface property)
- (cons (append (butlast (car entry))
- (list (cons (car object) value)))
- (dbus-get-other-registered-property
- bus service path interface property))
- dbus-registered-objects-table)
- ;; Send the "PropertiesChanged" signal.
- (when (member :emits-signal (car object))
- (dbus-send-signal
- bus service path dbus-interface-properties "PropertiesChanged"
- `((:dict-entry ,property (:variant ,value)))
- '(:array)))
- ;; Return empty reply.
- :ignore))
+ (cond
+ ((not (consp object))
+ `(:error ,dbus-error-unknown-property
+ ,(format-message
+ "No such property \"%s\" at path \"%s\"" property path)))
+ ((eq :read (car object))
+ `(:error ,dbus-error-property-read-only
+ ,(format-message
+ "Property \"%s\" at path \"%s\" is not writable" property path)))
+ (t (puthash (list :property bus interface property)
+ (cons (append
+ (butlast (car entry))
+ ;; Reuse ACCESS and EMITS-SIGNAL.
+ (list (append (butlast object) (list value))))
+ (dbus-get-other-registered-properties
+ bus service path interface property))
+ dbus-registered-objects-table)
+ ;; Send the "PropertiesChanged" signal.
+ (when (nth 1 object)
+ (dbus-send-signal
+ bus service path dbus-interface-properties "PropertiesChanged"
+ interface
+ ;; changed_properties.
+ (if (eq :write (car object))
+ '(:array: :signature "{sv}")
+ `(:array (:dict-entry ,property ,value)))
+ ;; invalidated_properties.
+ (if (eq :write (car object))
+ `(:array ,property)
+ '(:array))))
+ ;; Return empty reply.
+ :ignore))))
;; "GetAll" returns "a{sv}".
((string-equal method "GetAll")
(let (result)
(maphash
(lambda (key val)
- (dolist (item val)
- (when (and (equal (butlast key) (list :property bus interface))
- (string-equal path (nth 2 item))
- (not (functionp (car (last item)))))
- (push
- (list :dict-entry
- (car (last key))
- (list :variant (cdar (last item))))
- result))))
+ (when (consp val)
+ (dolist (item val)
+ (let ((object (car (last item))))
+ (when (and (equal (butlast key) (list :property bus interface))
+ (string-equal path (nth 2 item))
+ (consp object)
+ (not (eq :write (car object))))
+ (push
+ (list :dict-entry (car (last key)) (nth 2 object))
+ result))))))
dbus-registered-objects-table)
- ;; Return the result, or an empty array.
- (list :array (or result '(:signature "{sv}"))))))))
+ ;; Return the result, or an empty array. An array must be
+ ;; embedded in a list.
+ (list (cons :array (or result '(:signature "{sv}"))))))
+
+ (t `(:error ,dbus-error-unknown-method
+ ,(format-message
+ "No such method \"%s.%s\" at path \"%s\""
+ dbus-interface-properties method path))))))
;;; D-Bus object manager.
@@ -1682,10 +1895,11 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow."
(let ((result
;; Direct call. Fails, if the target does not support the
;; object manager interface.
- (dbus-ignore-errors
- (dbus-call-method
- bus service path dbus-interface-objectmanager
- "GetManagedObjects" :timeout 1000))))
+ (let (dbus-debug)
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus service path dbus-interface-objectmanager
+ "GetManagedObjects" :timeout 1000)))))
(if result
;; Massage the returned structure.
@@ -1698,7 +1912,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow."
(if (cadr entry2)
;; "sv".
(dolist (entry3 (cadr entry2))
- (setcdr entry3 (cl-caadr entry3)))
+ (setcdr entry3 (caadr entry3)))
(setcdr entry2 nil)))))
;; Fallback: collect the information. Slooow!
@@ -1729,35 +1943,38 @@ It will be registered for all objects created by `dbus-register-service'."
;; Check for object path wildcard interfaces.
(maphash
(lambda (key val)
- (when (and (equal (butlast key 2) (list :method bus))
- (null (nth 2 (car-safe val))))
- (push (nth 2 key) interfaces)))
+ (when (equal (butlast key 2) (list :property bus))
+ (dolist (item val)
+ (unless (nth 2 item) ; Path.
+ (push (nth 2 key) interfaces)))))
dbus-registered-objects-table)
;; Check all registered object paths.
(maphash
(lambda (key val)
- (let ((object (or (nth 2 (car-safe val)) "")))
- (when (and (equal (butlast key 2) (list :method bus))
- (string-prefix-p path object))
- (dolist (interface (cons (nth 2 key) interfaces))
- (unless (assoc object result)
- (push (list object) result))
- (unless (assoc interface (cdr (assoc object result)))
- (setcdr
- (assoc object result)
- (append
- (list (cons
- interface
- ;; We simulate "org.freedesktop.DBus.Properties.GetAll"
- ;; by using an appropriate D-Bus event.
- (let ((last-input-event
- (append
- (butlast last-input-event 4)
- (list object dbus-interface-properties
- "GetAll" 'dbus-property-handler))))
- (dbus-property-handler interface))))
- (cdr (assoc object result)))))))))
+ (when (equal (butlast key 2) (list :property bus))
+ (dolist (item val)
+ (let ((object (or (nth 2 item) ""))) ; Path.
+ (when (string-prefix-p path object)
+ (dolist (interface (cons (nth 2 key) (delete-dups interfaces)))
+ (unless (assoc object result)
+ (push (list object) result))
+ (unless (assoc interface (cdr (assoc object result)))
+ (setcdr
+ (assoc object result)
+ (append
+ (list (cons
+ interface
+ ;; We simulate
+ ;; "org.freedesktop.DBus.Properties.GetAll"
+ ;; by using an appropriate D-Bus event.
+ (let ((last-input-event
+ (append
+ (butlast last-input-event 4)
+ (list object dbus-interface-properties
+ "GetAll" #'dbus-property-handler))))
+ (dbus-property-handler interface))))
+ (cdr (assoc object result)))))))))))
dbus-registered-objects-table)
;; Return the result, or an empty array.
@@ -1772,13 +1989,214 @@ It will be registered for all objects created by `dbus-register-service'."
result)
'(:signature "{oa{sa{sv}}}"))))))
+(cl-defun dbus-register-monitor
+ (bus &optional handler &key type sender destination path interface member)
+ "Register HANDLER for monitor events on the D-Bus BUS.
+
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address.
+
+HANDLER is the function to be called when a monitor event
+arrives. It is called with the `args' slot of the monitor event,
+which are stripped off the type keywords. If HANDLER is nil, the
+default handler `dbus-monitor-handler' is applied.
+
+The other arguments are keyword-value pairs. `:type TYPE'
+defines the message type to be monitored. If given, it must be
+equal one of the strings \"method_call\", \"method_return\",
+\"error\" or \"signal\".
+
+`:sender SENDER' and `:destination DESTINATION' are D-Bus names.
+They can be unique names, or well-known service names.
+
+`:path PATH' is the D-Bus object to be monitored. `:interface
+INTERFACE' is the name of an interface, and `:member MEMBER' is
+either a method name, a signal name, or an error name."
+ (let ((bus-private (if (eq bus :system) :system-private
+ (if (eq bus :session) :session-private bus)))
+ rule key key1 value)
+ (unless handler (setq handler #'dbus-monitor-handler))
+ ;; Compose rule.
+ (setq rule
+ (string-join
+ (delq nil (mapcar
+ (lambda (item)
+ (when (cdr item)
+ (format "%s='%s'" (car item) (cdr item))))
+ `(("type" . ,type) ("sender" . ,sender)
+ ("destination" . ,destination) ("path" . ,path)
+ ("interface" . ,interface) ("member" . ,member))))
+ ",")
+ rule (or rule ""))
+
+ (when (fboundp 'dbus-get-unique-name)
+ (unless (ignore-errors (dbus-get-unique-name bus-private))
+ (dbus-init-bus bus 'private)))
+ (dbus-call-method
+ bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring
+ "BecomeMonitor" `(:array :string ,rule) :uint32 0)
+
+ (when dbus-debug (message "Matching rule \"%s\" created" rule))
+
+ ;; Create a hash table entry.
+ (setq key (list :monitor bus-private)
+ key1 (list nil nil nil handler rule)
+ value (gethash key dbus-registered-objects-table))
+ (unless (member key1 value)
+ (puthash key (cons key1 value) dbus-registered-objects-table))
+
+ (when dbus-debug (message "%s" dbus-registered-objects-table))
+
+ ;; Return the object.
+ (list key (list nil nil handler))))
+
+(defconst dbus-monitor-method-call
+ (propertize "method-call" 'face 'font-lock-function-name-face)
+ "Text to be inserted for D-Bus method-call in monitor.")
+
+(defconst dbus-monitor-method-return
+ (propertize "method-return" 'face 'font-lock-function-name-face)
+ "Text to be inserted for D-Bus method-return in monitor.")
+
+(defconst dbus-monitor-error (propertize "error" 'face 'font-lock-warning-face)
+ "Text to be inserted for D-Bus error in monitor.")
+
+(defconst dbus-monitor-signal
+ (propertize "signal" 'face 'font-lock-type-face)
+ "Text to be inserted for D-Bus signal in monitor.")
+
+(defun dbus-monitor-goto-serial ()
+ "Goto D-Bus message with the same serial number."
+ (interactive)
+ (when (mouse-event-p last-input-event) (mouse-set-point last-input-event))
+ (when-let ((point (get-text-property (point) 'dbus-serial)))
+ (goto-char point)))
+
+(defun dbus-monitor-handler (&rest _args)
+ "Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\" interface.
+It will be applied for all objects created by `dbus-register-monitor'
+which don't declare an own handler. The printed timestamps do
+not reflect the time the D-Bus message has passed the D-Bus
+daemon, it is rather the timestamp the corresponding D-Bus event
+has been handled by this function."
+ (with-current-buffer (get-buffer-create "*D-Bus Monitor*")
+ (special-mode)
+ (buffer-disable-undo)
+ ;; Move forward and backward between messages.
+ (local-set-key [?n] #'forward-paragraph)
+ (local-set-key [?p] #'backward-paragraph)
+ ;; Follow serial links.
+ (local-set-key (kbd "RET") #'dbus-monitor-goto-serial)
+ (local-set-key [mouse-2] #'dbus-monitor-goto-serial)
+ (let* ((inhibit-read-only t)
+ (text-quoting-style 'grave)
+ (point (point))
+ (eobp (eobp))
+ (event last-input-event)
+ (type (dbus-event-message-type event))
+ (sender (dbus-event-service-name event))
+ (destination (dbus-event-destination-name event))
+ (serial (dbus-event-serial-number event))
+ (path (dbus-event-path-name event))
+ (interface (dbus-event-interface-name event))
+ (member (dbus-event-member-name event))
+ (arguments (dbus-event-arguments event))
+ (time (time-to-seconds (current-time))))
+ (save-excursion
+ ;; Check for matching method-call.
+ (goto-char (point-max))
+ (when (and (or (= type dbus-message-type-method-return)
+ (= type dbus-message-type-error))
+ (re-search-backward
+ (format
+ (concat
+ "^method-call time=\\(\\S-+\\) "
+ ".*sender=%s .*serial=\\(%d\\) ")
+ destination serial)
+ nil 'noerror))
+ (setq serial
+ (propertize
+ (match-string 2) 'dbus-serial (match-beginning 0)
+ 'help-echo "RET, mouse-1, mouse-2: goto method-call"
+ 'face 'link 'follow-link 'mouse-face 'mouse-face 'highlight)
+ time (format "%f (%f)" time (- time (read (match-string 1)))))
+ (set-text-properties
+ (match-beginning 2) (match-end 2)
+ `(dbus-serial ,(point-max)
+ help-echo
+ ,(format
+ "RET, mouse-1, mouse-2: goto %s"
+ (if (= type dbus-message-type-error) "error" "method-return"))
+ face link follow-link mouse-face mouse-face highlight)))
+ ;; Insert D-Bus message.
+ (goto-char (point-max))
+ (insert
+ (format
+ (concat
+ "%s time=%s sender=%s -> destination=%s serial=%s "
+ "path=%s interface=%s member=%s\n")
+ (cond
+ ((= type dbus-message-type-method-call) dbus-monitor-method-call)
+ ((= type dbus-message-type-method-return) dbus-monitor-method-return)
+ ((= type dbus-message-type-error) dbus-monitor-error)
+ ((= type dbus-message-type-signal) dbus-monitor-signal))
+ time sender destination serial path interface member))
+ (dolist (arg arguments)
+ (pp (dbus-flatten-types arg) (current-buffer)))
+ (insert "\n")
+ ;; Show byte arrays as string.
+ (goto-char point)
+ (while (re-search-forward
+ "(:array\\( :byte [[:digit:]]+\\)+)" nil 'noerror)
+ (put-text-property
+ (match-beginning 0) (match-end 0)
+ 'help-echo (dbus-byte-array-to-string (read (match-string 0)))))
+ ;; Show fixed numbers.
+ (goto-char point)
+ (while (re-search-forward
+ (concat
+ (regexp-opt
+ '(":int16" ":uint16" ":int32" ":uint32" ":int64" ":uint64"))
+ " \\([-+[:digit:]]+\\)")
+ nil 'noerror)
+ (put-text-property
+ (match-beginning 1) (match-end 1)
+ 'help-echo
+ (format
+ "#o%o, #x%X" (read (match-string 1)) (read (match-string 1)))))
+ ;; Show floating numbers.
+ (goto-char point)
+ (while (re-search-forward ":double \\([-+.[:digit:]]+\\)" nil 'noerror)
+ (put-text-property
+ (match-beginning 1) (match-end 1)
+ 'help-echo (format "%e" (read (match-string 1))))))
+ (when eobp
+ (goto-char (point-max))))))
+
+;;;###autoload
+(defun dbus-monitor (&optional bus)
+ "Invoke `dbus-register-monitor' interactively, and switch to the buffer.
+BUS is either a Lisp keyword, `:system' or `:session', or a
+string denoting the bus address. The value nil defaults to `:session'."
+ (interactive
+ (list
+ (let ((input
+ (completing-read
+ (format-prompt "Enter bus symbol or name" :session)
+ '(:system :session) nil nil nil nil :session)))
+ (if (and (stringp input)
+ (string-match-p "^\\(:session\\|:system\\)$" input))
+ (intern input) input))))
+ (dbus-register-monitor (or bus :session))
+ (switch-to-buffer (get-buffer-create "*D-Bus Monitor*")))
+
(defun dbus-handle-bus-disconnect ()
"React to a bus disconnection.
BUS is the bus that disconnected. This routine unregisters all
handlers on the given bus and causes all synchronous calls
pending at the time of disconnect to fail."
(let ((bus (dbus-event-bus-name last-input-event))
- (keys-to-remove))
+ keys-to-remove)
(maphash
(lambda (key value)
(when (and (eq (nth 0 key) :serial)
@@ -1788,13 +2206,14 @@ pending at the time of disconnect to fail."
(list 'dbus-event
bus
dbus-message-type-error
- (nth 2 key)
- nil
- nil
- nil
- nil
- value)
- (list 'dbus-error "Bus disconnected" bus))
+ (nth 2 key) ; serial
+ nil ; service
+ nil ; destination
+ nil ; path
+ nil ; interface
+ nil ; member
+ value) ; handler
+ (list 'dbus-error dbus-error-disconnected "Bus disconnected" bus))
(push key keys-to-remove)))
dbus-registered-objects-table)
(dolist (key keys-to-remove)
@@ -1803,10 +2222,11 @@ pending at the time of disconnect to fail."
(defun dbus-init-bus (bus &optional private)
"Establish the connection to D-Bus BUS.
-BUS can be either the symbol `:system' or the symbol `:session', or it
-can be a string denoting the address of the corresponding bus. For
-the system and session buses, this function is called when loading
-`dbus.el', there is no need to call it again.
+BUS can be either the keyword `:system' or the keyword
+`:session', or it can be a string denoting the address of the
+corresponding bus. For the system and session buses, this
+function is called when loading `dbus.el', there is no need to
+call it again.
The function returns the number of connections this Emacs session
has established to the BUS under the same unique name (see
@@ -1816,13 +2236,13 @@ example, if Emacs is linked with the GTK+ toolkit, and it runs in
a GTK+-aware environment like GNOME, another connection might
already be established.
-When PRIVATE is non-nil, a new connection is established instead of
-reusing an existing one. It results in a new unique name at the bus.
-This can be used, if it is necessary to distinguish from another
-connection used in the same Emacs process, like the one established by
-GTK+. It should be used with care for at least the `:system' and
-`:session' buses, because other Emacs Lisp packages might already use
-this connection to those buses."
+When PRIVATE is non-nil, a new connection is established instead
+of reusing an existing one. It results in a new unique name at
+the bus. This can be used, if it is necessary to distinguish
+from another connection used in the same Emacs process, like the
+one established by GTK+. If BUS is the keyword `:system' or the
+keyword `:session', the new connection is identified by the
+keywords `:system-private' or `:session-private', respectively."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(prog1
@@ -1847,5 +2267,9 @@ this connection to those buses."
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
+;;
+;; * Cache introspection data.
+;;
+;; * Run handlers in own threads.
;;; dbus.el ends here
diff --git a/lisp/net/dictionary-connection.el b/lisp/net/dictionary-connection.el
new file mode 100644
index 00000000000..b874c488a82
--- /dev/null
+++ b/lisp/net/dictionary-connection.el
@@ -0,0 +1,156 @@
+;;; dictionary-connection.el --- TCP-based client connection for dictionary -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Torsten Hilbrich <torsten.hilbrich@gmx.net>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; dictionary-connection allows handling TCP-based connections in
+;; client mode where text-based information is exchanged. There is
+;; special support for handling CR LF (and the usual CR LF . CR LF
+;; terminator).
+
+;;; Code:
+
+(defsubst dictionary-connection-p (connection)
+ "Return non-nil if CONNECTION is a connection object."
+ (get connection 'connection))
+
+(defsubst dictionary-connection-read-point (connection)
+ "Return the read point of the CONNECTION object."
+ (get connection 'dictionary-connection-read-point))
+
+(defsubst dictionary-connection-process (connection)
+ "Return the process of the CONNECTION object."
+ (get connection 'dictionary-connection-process))
+
+(defsubst dictionary-connection-buffer (connection)
+ "Return the buffer of the CONNECTION object."
+ (get connection 'dictionary-connection-buffer))
+
+(defsubst dictionary-connection-set-read-point (connection point)
+ "Set the read-point for CONNECTION to POINT."
+ (put connection 'dictionary-connection-read-point point))
+
+(defsubst dictionary-connection-set-process (connection process)
+ "Set the process for CONNECTION to PROCESS."
+ (put connection 'dictionary-connection-process process))
+
+(defsubst dictionary-connection-set-buffer (connection buffer)
+ "Set the buffer for CONNECTION to BUFFER."
+ (put connection 'dictionary-connection-buffer buffer))
+
+(defun dictionary-connection-create-data (buffer process point)
+ "Create a new connection data based on BUFFER, PROCESS, and POINT."
+ (let ((connection (make-symbol "connection")))
+ (put connection 'connection t)
+ (dictionary-connection-set-read-point connection point)
+ (dictionary-connection-set-process connection process)
+ (dictionary-connection-set-buffer connection buffer)
+ connection))
+
+(defun dictionary-connection-open (server port)
+ "Open a connection to SERVER at PORT.
+Return a data structure identifying the connection."
+
+ (let ((process-buffer (generate-new-buffer (format " connection to %s:%s"
+ server
+ port)))
+ (process))
+ (with-current-buffer process-buffer
+ (setq process (open-network-stream "connection" process-buffer
+ server port))
+ (dictionary-connection-create-data process-buffer process (point-min)))))
+
+(defun dictionary-connection-status (connection)
+ "Return the status of the CONNECTION.
+Possible return values are the symbols:
+ nil: argument is not a connection object
+ 'none: argument is not connected
+ 'up: connection is open and buffer is existing
+ 'down: connection is closed
+ 'alone: connection is not associated with a buffer"
+ (when (dictionary-connection-p connection)
+ (let ((process (dictionary-connection-process connection))
+ (buffer (dictionary-connection-buffer connection)))
+ (if (not process)
+ 'none
+ (if (not (buffer-live-p buffer))
+ 'alone
+ (if (not (eq (process-status process) 'open))
+ 'down
+ 'up))))))
+
+(defun dictionary-connection-close (connection)
+ "Force closing of the CONNECTION."
+ (when (dictionary-connection-p connection)
+ (let ((buffer (dictionary-connection-buffer connection))
+ (process (dictionary-connection-process connection)))
+ (if process
+ (delete-process process))
+ (if buffer
+ (kill-buffer buffer))
+
+ (dictionary-connection-set-process connection nil)
+ (dictionary-connection-set-buffer connection nil))))
+
+(defun dictionary-connection-send (connection data)
+ "Send DATA to the process stored in CONNECTION."
+ (unless (eq (dictionary-connection-status connection) 'up)
+ (error "Connection is not up"))
+ (with-current-buffer (dictionary-connection-buffer connection)
+ (goto-char (point-max))
+ (dictionary-connection-set-read-point connection (point))
+ (process-send-string (dictionary-connection-process connection) data)))
+
+(defun dictionary-connection-send-crlf (connection data)
+ "Send DATA together with CRLF to the process found in CONNECTION."
+ (dictionary-connection-send connection (concat data "\r\n")))
+
+(defun dictionary-connection-read (connection delimiter)
+ "Read data from CONNECTION until DELIMITER is found inside the buffer."
+ (unless (eq (dictionary-connection-status connection) 'up)
+ (error "Connection is not up"))
+ (let ((case-fold-search nil)
+ match-end)
+ (with-current-buffer (dictionary-connection-buffer connection)
+ (goto-char (dictionary-connection-read-point connection))
+ ;; Wait until there is enough data
+ (while (not (search-forward-regexp delimiter nil t))
+ (accept-process-output (dictionary-connection-process connection) 3)
+ (goto-char (dictionary-connection-read-point connection)))
+ (setq match-end (point))
+ ;; Return the result
+ (let ((result (buffer-substring (dictionary-connection-read-point connection)
+ match-end)))
+ (dictionary-connection-set-read-point connection match-end)
+ result))))
+
+(defun dictionary-connection-read-crlf (connection)
+ "Read from CONNECTION until a line is completed with CRLF."
+ (dictionary-connection-read connection "\015?\012"))
+
+(defun dictionary-connection-read-to-point (connection)
+ "Read from CONNECTION until an end of entry is encountered.
+End of entry is a decimal point found on a line by itself."
+ (dictionary-connection-read connection "\015?\012[.]\015?\012"))
+
+(provide 'dictionary-connection)
+;;; dictionary-connection.el ends here
diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el
new file mode 100644
index 00000000000..f33cbaf1126
--- /dev/null
+++ b/lisp/net/dictionary.el
@@ -0,0 +1,1372 @@
+;;; dictionary.el --- Client for rfc2229 dictionary servers -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Torsten Hilbrich <torsten.hilbrich@gmx.net>
+;; Keywords: interface, dictionary
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; dictionary allows you to interact with dictionary servers.
+;; Use M-x customize-group dictionary to modify user settings.
+;;
+;; Main functions for interaction are:
+;; dictionary - opens a new dictionary buffer
+;; dictionary-search - search for the definition of a word
+;;
+;; You can find more information in the README file of the GitHub
+;; repository https://github.com/myrkr/dictionary-el
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'custom)
+(require 'dictionary-connection)
+(require 'button)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stuff for customizing.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar dictionary-current-server)
+(defun dictionary-set-server-var (name value)
+ "Customize helper for setting variable NAME to VALUE.
+The helper is used by customize to check for an active connection
+when setting a variable. The user has then the choice to close
+the existing connection."
+ (if (and (boundp 'dictionary-connection)
+ dictionary-connection
+ (eq (dictionary-connection-status dictionary-connection) 'up)
+ (y-or-n-p
+ (concat "Close existing connection to " dictionary-current-server "? ")))
+ (dictionary-connection-close dictionary-connection))
+ (set-default name value))
+
+(defgroup dictionary nil
+ "Client for accessing the dictd server based dictionaries"
+ :group 'hypermedia)
+
+(defgroup dictionary-proxy nil
+ "Proxy configuration options for the dictionary client"
+ :group 'dictionary)
+
+(defcustom dictionary-server
+ nil
+ "This server is contacted for searching the dictionary.
+
+You can specify here:
+
+- Automatic: First try localhost, then dict.org after confirmation
+- localhost: Only use localhost
+- dict.org: Only use dict.org
+- User-defined: You can specify your own server here"
+ :group 'dictionary
+ :set #'dictionary-set-server-var
+ :type '(choice (const :tag "Automatic" nil)
+ (const :tag "localhost" "localhost")
+ (const :tag "dict.org" "dict.org")
+ (string :tag "User-defined"))
+ :version "28.1")
+
+(defcustom dictionary-port
+ 2628
+ "The port of the dictionary server.
+This port is propably always 2628 so there should be no need to modify it."
+ :group 'dictionary
+ :set #'dictionary-set-server-var
+ :type 'number
+ :version "28.1")
+
+(defcustom dictionary-identification
+ "dictionary.el emacs lisp dictionary client"
+ "This is the identification string that will be sent to the server."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-dictionary
+ "*"
+ "The dictionary which is used for searching definitions and matching.
+* and ! have a special meaning, * search all dictionaries, ! search until
+one dictionary yields matches."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-strategy
+ "."
+ "The default strategy for listing matching words."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-popup-strategy
+ "exact"
+ "The default strategy for listing matching words within a popup window.
+
+The following algorithm (defined by the dictd server) are supported
+by the choice value:
+
+- Exact match
+
+ The found word exactly matches the searched word.
+
+- Similar sounding
+
+ The found word sounds similar to the searched word. For this match type
+ the soundex algorithm defined by Donald E. Knuth is used. It will only
+ works with english words and the algorithm is not very reliable (i.e.,
+ the soundex algorithm is quite simple).
+
+- Levenshtein distance one
+
+ The Levenshtein distance is defined as the number of insertions, deletions,
+ or replacements needed to get the searched word. This algorithm searches
+ for word where spelling mistakes are allowed. Levenshtein distance one
+ means there is either a deleted character, an inserted character, or a
+ modified one.
+
+- User choice
+
+ Here you can enter any matching algorithm supported by your
+ dictionary server."
+ :group 'dictionary
+ :type '(choice (const :tag "Exact match" "exact")
+ (const :tag "Similar sounding" "soundex")
+ (const :tag "Levenshtein distance one" "lev")
+ (string :tag "User choice"))
+ :version "28.1")
+
+(defcustom dictionary-create-buttons
+ t
+ "Create some clickable buttons on top of the window if non-nil."
+ :group 'dictionary
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-link-dictionary
+ "*"
+ "The dictionary which is used in links.
+* means to create links that search all dictionaries,
+nil means to create links that search only in the same dictionary
+where the current word was found."
+ :group 'dictionary
+ :type '(choice (const :tag "Link to all dictionaries" "*")
+ (const :tag "Link only to the same dictionary" nil)
+ (string :tag "User choice"))
+ :version "28.1")
+
+(defcustom dictionary-mode-hook
+ nil
+ "Hook run in dictionary mode buffers."
+ :group 'dictionary
+ :type 'hook
+ :version "28.1")
+
+(defcustom dictionary-post-buffer-hook
+ nil
+ "Hook run at the end of every update of the dictionary buffer."
+ :group 'dictionary
+ :type 'hook
+ :version "28.1")
+
+(defcustom dictionary-use-http-proxy
+ nil
+ "Connects via a HTTP proxy using the CONNECT command when not nil."
+ :group 'dictionary-proxy
+ :set #'dictionary-set-server-var
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-proxy-server
+ "proxy"
+ "The name of the HTTP proxy to use when `dictionary-use-http-proxy' is set."
+ :group 'dictionary-proxy
+ :set #'dictionary-set-server-var
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-proxy-port
+ 3128
+ "The port of the proxy server, used only when `dictionary-use-http-proxy' is set."
+ :group 'dictionary-proxy
+ :set #'dictionary-set-server-var
+ :type 'number
+ :version "28.1")
+
+(defcustom dictionary-use-single-buffer
+ nil
+ "Should the dictionary command reuse previous dictionary buffers?"
+ :group 'dictionary
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-description-open-delimiter
+ ""
+ "The delimiter to display in front of the dictionaries description."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-description-close-delimiter
+ ""
+ "The delimiter to display after of the dictionaries description."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+;; Define only when coding-system-list is available
+(defcustom dictionary-coding-systems-for-dictionaries
+ '( ("mueller" . koi8-r))
+ "Mapping of dictionaries to coding systems.
+Each entry in this list defines the coding system to be used for that
+dictionary. The default coding system for all other dictionaries
+is utf-8"
+ :group 'dictionary
+ :type `(repeat (cons :tag "Association"
+ (string :tag "Dictionary name")
+ (choice :tag "Coding system"
+ :value 'utf-8
+ ,@(mapcar (lambda (x) (list 'const x))
+ (coding-system-list))
+ )))
+ :version "28.1")
+
+(defface dictionary-word-definition-face
+'((((supports (:family "DejaVu Serif")))
+ (:family "DejaVu Serif"))
+ (((type x))
+ (:font "Sans Serif"))
+ (t
+ (:font "default")))
+"The face that is used for displaying the definition of the word."
+:group 'dictionary
+:version "28.1")
+
+(defface dictionary-word-entry-face
+ '((((type x))
+ (:italic t))
+ (((type tty) (class color))
+ (:foreground "green"))
+ (t
+ (:inverse t)))
+ "The face that is used for displaying the initial word entry line."
+ :group 'dictionary
+ :version "28.1")
+
+(defface dictionary-button-face
+ '((t
+ (:bold t)))
+ "The face that is used for displaying buttons."
+ :group 'dictionary
+ :version "28.1")
+
+(defface dictionary-reference-face
+ '((((type x)
+ (class color)
+ (background dark))
+ (:foreground "yellow"))
+ (((type tty)
+ (class color)
+ (background dark))
+ (:foreground "cyan"))
+ (((class color)
+ (background light))
+ (:foreground "blue"))
+ (t
+ (:underline t)))
+
+ "The face that is used for displaying a reference word."
+ :group 'dictionary
+ :version "28.1")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Buffer local variables for storing the current state
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar dictionary-window-configuration
+ nil
+ "The window configuration to be restored upon closing the buffer.")
+
+(defvar dictionary-selected-window
+ nil
+ "The currently selected window.")
+
+(defvar dictionary-position-stack
+ nil
+ "The history buffer for point and window position.")
+
+(defvar dictionary-data-stack
+ nil
+ "The history buffer for functions and arguments.")
+
+(defvar dictionary-positions
+ nil
+ "The current positions.")
+
+(defvar dictionary-current-data
+ nil
+ "The item that will be placed on stack next time.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Global variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar dictionary-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (set-keymap-parent map button-buffer-map)
+
+ (define-key map "q" #'dictionary-close)
+ (define-key map "h" #'dictionary-help)
+ (define-key map "s" #'dictionary-search)
+ (define-key map "d" #'dictionary-lookup-definition)
+ (define-key map "D" #'dictionary-select-dictionary)
+ (define-key map "M" #'dictionary-select-strategy)
+ (define-key map "m" #'dictionary-match-words)
+ (define-key map "l" #'dictionary-previous)
+ (define-key map "n" #'forward-button)
+ (define-key map "p" #'backward-button)
+ (define-key map " " #'scroll-up-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map (read-kbd-macro "M-SPC") #'scroll-down-command)
+ map)
+ "Keymap for the dictionary mode.")
+
+(defvar dictionary-connection
+ nil
+ "The current network connection.")
+
+(defvar dictionary-instances
+ 0
+ "The number of open dictionary buffers.")
+
+(defvar dictionary-marker
+ nil
+ "Stores the point position while buffer display.")
+
+(defvar dictionary-color-support
+ (condition-case nil
+ (x-display-color-p)
+ (error nil))
+ "Determines if the Emacs has support to display color.")
+
+(defvar dictionary-word-history
+ '()
+ "History list of searched word.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Basic function providing startup actions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun dictionary-mode ()
+ ;; FIXME: Use define-derived-mode.
+ "Mode for searching a dictionary.
+This is a mode for searching a dictionary server implementing the
+protocol defined in RFC 2229.
+
+This is a quick reference to this mode describing the default key bindings:
+\\<dictionary-mode-map>
+* \\[dictionary-close] close the dictionary buffer
+* \\[dictionary-help] display this help information
+* \\[dictionary-search] ask for a new word to search
+* \\[dictionary-lookup-definition] search the word at point
+* \\[forward-button] or TAB place point to the next link
+* \\[backward-button] or S-TAB place point to the prev link
+
+* \\[dictionary-match-words] ask for a pattern and list all matching words.
+* \\[dictionary-select-dictionary] select the default dictionary
+* \\[dictionary-select-strategy] select the default search strategy
+
+* RET or <mouse-2> visit that link"
+
+ (unless (eq major-mode 'dictionary-mode)
+ (cl-incf dictionary-instances))
+
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (use-local-map dictionary-mode-map)
+ (setq major-mode 'dictionary-mode)
+ (setq mode-name "Dictionary")
+
+ (setq-local dictionary-data-stack nil)
+ (setq-local dictionary-position-stack nil)
+
+ (make-local-variable 'dictionary-current-data)
+ (make-local-variable 'dictionary-positions)
+
+ (make-local-variable 'dictionary-default-dictionary)
+ (make-local-variable 'dictionary-default-strategy)
+
+ (add-hook 'kill-buffer-hook #'dictionary-close t t)
+ (run-hooks 'dictionary-mode-hook))
+
+;;;###autoload
+(defun dictionary ()
+ "Create a new dictionary buffer and install `dictionary-mode'."
+ (interactive)
+ (let ((buffer (or (and dictionary-use-single-buffer
+ (get-buffer "*Dictionary*"))
+ (generate-new-buffer "*Dictionary*")))
+ (window-configuration (current-window-configuration))
+ (selected-window (frame-selected-window)))
+
+ (switch-to-buffer-other-window buffer)
+ (dictionary-mode)
+
+ (setq-local dictionary-window-configuration window-configuration)
+ (setq-local dictionary-selected-window selected-window)
+ (dictionary-check-connection)
+ (dictionary-new-buffer)
+ (dictionary-store-positions)
+ (dictionary-store-state 'dictionary-new-buffer nil)))
+
+(defun dictionary-new-buffer ()
+ "Create a new and clean buffer."
+
+ (dictionary-pre-buffer)
+ (dictionary-post-buffer))
+
+(defsubst dictionary-reply-code (reply)
+ "Return the reply code stored in REPLY."
+ (get reply 'reply-code))
+
+(defsubst dictionary-reply (reply)
+ "Return the string reply stored in REPLY."
+ (get reply 'reply))
+
+(defsubst dictionary-reply-list (reply)
+ "Return the reply list stored in REPLY."
+ (get reply 'reply-list))
+
+(defun dictionary-open-server (server)
+ "Opens a new connection to SERVER.
+The connection takes the proxy setting in customization group
+`dictionary-proxy' into account."
+ (let ((wanted 'raw-text)
+ (coding-system nil))
+ (if (member wanted (coding-system-list))
+ (setq coding-system wanted))
+ (let ((coding-system-for-read coding-system)
+ (coding-system-for-write coding-system))
+ (setq dictionary-current-server server)
+ (message "Opening connection to %s:%s" server
+ dictionary-port)
+ (dictionary-connection-close dictionary-connection)
+ (setq dictionary-connection
+ (if dictionary-use-http-proxy
+ (dictionary-connection-open dictionary-proxy-server
+ dictionary-proxy-port)
+ (dictionary-connection-open server dictionary-port)))
+ (set-process-query-on-exit-flag
+ (dictionary-connection-process dictionary-connection)
+ nil)
+
+ (when dictionary-use-http-proxy
+ (message "Proxy CONNECT to %s:%d"
+ dictionary-proxy-server
+ dictionary-proxy-port)
+ (dictionary-send-command (format "CONNECT %s:%d HTTP/1.1"
+ server
+ dictionary-port))
+ ;; just a \r\n combination
+ (dictionary-send-command "")
+
+ ;; read first line of reply
+ (let* ((reply (dictionary-read-reply))
+ (reply-list (dictionary-split-string reply)))
+ ;; first item is protocol, second item is code
+ (unless (= (string-to-number (cadr reply-list)) 200)
+ (error "Bad reply from proxy server %s" reply))
+
+ ;; skip the following header lines until empty found
+ (while (not (equal reply ""))
+ (setq reply (dictionary-read-reply)))))
+
+ (dictionary-check-initial-reply)
+ (dictionary-send-command (concat "client " dictionary-identification))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (unless (dictionary-check-reply reply 250)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))))))
+
+(defun dictionary-check-connection ()
+ "Check if there is already a connection open."
+ (if (not (and dictionary-connection
+ (eq (dictionary-connection-status dictionary-connection) 'up)))
+ (if dictionary-server
+ (dictionary-open-server dictionary-server)
+ (let ((server "localhost"))
+ (condition-case nil
+ (dictionary-open-server server)
+ (error
+ (if (y-or-n-p
+ (format "Failed to open server %s, continue with dict.org? "
+ server))
+ (dictionary-open-server "dict.org")
+ (error "Failed automatic server selection, please customize dictionary-server"))))))))
+
+(defun dictionary-mode-p ()
+ "Return non-nil if current buffer has `dictionary-mode'."
+ (eq major-mode 'dictionary-mode))
+
+(defun dictionary-ensure-buffer ()
+ "If current buffer is not a dictionary buffer, create a new one."
+ (unless (dictionary-mode-p)
+ (dictionary)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dealing with closing the buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-close (&rest _ignored)
+ "Close the current dictionary buffer and its connection."
+ (interactive)
+ (if (eq major-mode 'dictionary-mode)
+ (progn
+ (setq major-mode nil)
+ (if (<= (cl-decf dictionary-instances) 0)
+ (dictionary-connection-close dictionary-connection))
+ (let ((configuration dictionary-window-configuration)
+ (selected-window dictionary-selected-window))
+ (kill-buffer (current-buffer))
+ (set-window-configuration configuration)
+ (select-window selected-window)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpful functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-send-command (string)
+ "Send the command STRING to the network connection."
+ (dictionary-check-connection)
+ ;;;; #####
+ (dictionary-connection-send-crlf dictionary-connection string))
+
+(defun dictionary-read-reply ()
+ "Read the reply line from the server."
+ (let ((answer (dictionary-connection-read-crlf dictionary-connection)))
+ (if (string-match "\r?\n" answer)
+ (substring answer 0 (match-beginning 0))
+ answer)))
+
+(defun dictionary-split-string (string)
+ "Split STRING consisting of space-separated words into elements.
+This function knows about the special meaning of quotes (\")"
+ (let ((list))
+ (while (and string (> (length string) 0))
+ (let ((search "\\(\\s-+\\)")
+ (start 0))
+ (if (= (aref string 0) ?\")
+ (setq search "\\(\"\\)\\s-*"
+ start 1))
+ (if (string-match search string start)
+ (progn
+ (setq list (cons (substring string start (- (match-end 1) 1)) list)
+ string (substring string (match-end 0))))
+ (setq list (cons string list)
+ string nil))))
+ (nreverse list)))
+
+(defun dictionary-read-reply-and-split ()
+ "Read the reply, split it into words and return it."
+ (let ((answer (make-symbol "reply-data"))
+ (reply (dictionary-read-reply)))
+ (let ((reply-list (dictionary-split-string reply)))
+ (put answer 'reply reply)
+ (put answer 'reply-list reply-list)
+ (put answer 'reply-code (string-to-number (car reply-list)))
+ answer)))
+
+(defun dictionary-read-answer ()
+ "Read the complete answer.
+The answer is delimited by a decimal point (.) on a line by itself."
+ (let ((answer (dictionary-connection-read-to-point dictionary-connection))
+ (start 0))
+ (while (string-match "\r\n" answer start)
+ (setq answer (replace-match "\n" t t answer))
+ (setq start (1- (match-end 0))))
+ (setq start 0)
+ (if (string-match "\n\\.\n.*" answer start)
+ (setq answer (replace-match "" t t answer)))
+ answer))
+
+(defun dictionary-check-reply (reply code)
+ "Extract the reply code from REPLY and check against CODE."
+ (let ((number (dictionary-reply-code reply)))
+ (and (numberp number)
+ (= number code))))
+
+(defun dictionary-coding-system (dictionary)
+ "Select coding system to use for DICTIONARY."
+ (let ((coding-system
+ (or (cdr (assoc dictionary
+ dictionary-coding-systems-for-dictionaries))
+ 'utf-8)))
+ (if (member coding-system (coding-system-list))
+ coding-system
+ nil)))
+
+(defun dictionary-decode-charset (text dictionary)
+ "Convert TEXT from the charset configured for DICTIONARY."
+ (let ((coding-system (dictionary-coding-system dictionary)))
+ (if coding-system
+ (decode-coding-string text coding-system)
+ text)))
+
+(defun dictionary-encode-charset (text dictionary)
+ "Convert TEXT to the charset defined for DICTIONARY."
+ (let ((coding-system (dictionary-coding-system dictionary)))
+ (if coding-system
+ (encode-coding-string text coding-system)
+ text)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Communication functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-check-initial-reply ()
+ "Read the first reply from server and check it."
+ (let ((reply (dictionary-read-reply-and-split)))
+ (unless (dictionary-check-reply reply 220)
+ (dictionary-connection-close dictionary-connection)
+ (error "Server returned: %s" (dictionary-reply reply)))))
+
+;; Store the current state
+(defun dictionary-store-state (function data)
+ "Store the current state of operation for later restore.
+The current state consist of a tuple of FUNCTION and DATA.
+This is basically an implementation of a history to return to a
+previous state."
+ (if dictionary-current-data
+ (progn
+ (push dictionary-current-data dictionary-data-stack)
+ (unless dictionary-positions
+ (error "dictionary-store-state called before dictionary-store-positions"))
+ (push dictionary-positions dictionary-position-stack)))
+ (setq dictionary-current-data
+ (cons function data)))
+
+(defun dictionary-store-positions ()
+ "Store the current positions for later restore."
+
+ (setq dictionary-positions (cons (point) (window-start))))
+
+;; Restore the previous state
+(defun dictionary-restore-state (&rest _ignored)
+ "Restore the state just before the last operation."
+ (let ((position (pop dictionary-position-stack))
+ (data (pop dictionary-data-stack)))
+ (unless position
+ (error "Already at begin of history"))
+ (apply (car data) (cdr data))
+ (set-window-start (selected-window) (cdr position))
+ (goto-char (car position))
+ (setq dictionary-current-data data)))
+
+;; The normal search
+
+(defun dictionary-new-search (args &optional all)
+ "Save the current state and start a new search based on ARGS.
+The parameter ARGS is a cons cell where car is the word to search
+and cdr is the dictionary where to search the word in."
+ (interactive)
+ (dictionary-store-positions)
+ (let ((word (car args))
+ (dictionary (cdr args)))
+
+ (if all
+ (setq dictionary dictionary-default-dictionary))
+ (dictionary-ensure-buffer)
+ (dictionary-new-search-internal word dictionary 'dictionary-display-search-result)
+ (dictionary-store-state 'dictionary-new-search-internal
+ (list word dictionary 'dictionary-display-search-result))))
+
+(defun dictionary-new-search-internal (word dictionary function)
+ "Start a new search for WORD in DICTIONARY after preparing the buffer.
+FUNCTION is the callback which is called for each search result."
+ (dictionary-pre-buffer)
+ (dictionary-do-search word dictionary function))
+
+(defun dictionary-do-search (word dictionary function &optional nomatching)
+ "Search for WORD in DICTIONARY and call FUNCTION for each result.
+Optional argument NOMATCHING controls whether to suppress the display
+of matching words."
+
+ (message "Searching for %s in %s" word dictionary)
+ (dictionary-send-command (concat "define "
+ (dictionary-encode-charset dictionary "")
+ " \""
+ (dictionary-encode-charset word dictionary)
+ "\""))
+
+ (message nil)
+ (let ((reply (dictionary-read-reply-and-split)))
+ (if (dictionary-check-reply reply 552)
+ (progn
+ (unless nomatching
+ (insert "Word not found")
+ (dictionary-do-matching
+ word
+ dictionary
+ "."
+ (lambda (reply)
+ (insert ", maybe you are looking for one of these words\n\n")
+ (dictionary-display-only-match-result reply)))
+ (dictionary-post-buffer)))
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" is unknown, please select an existing one"
+ dictionary)
+ (unless (dictionary-check-reply reply 150)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (funcall function reply)))))
+
+(define-button-type 'dictionary-link
+ 'face 'dictionary-reference-face
+ 'action (lambda (button)
+ (let ((func (button-get button 'callback))
+ (data (button-get button 'data))
+ (list-data (button-get button 'list-data)))
+ (if list-data
+ (apply func list-data)
+ (funcall func data)))))
+
+(define-button-type 'dictionary-button
+ :supertype 'dictionary-link
+ 'face 'dictionary-button-face)
+
+(defun dictionary-pre-buffer ()
+ "These commands are executed at the begin of a new buffer."
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (if dictionary-create-buttons
+ (progn
+ (insert-button "[Back]" :type 'dictionary-button
+ 'callback 'dictionary-restore-state
+ 'help-echo (purecopy "Mouse-2 to go backwards in history"))
+ (insert " ")
+ (insert-button "[Search definition]" :type 'dictionary-button
+ 'callback 'dictionary-search
+ 'help-echo (purecopy "Mouse-2 to look up a new word"))
+ (insert " ")
+
+ (insert-button "[Matching words]" :type 'dictionary-button
+ 'callback 'dictionary-match-words
+ 'help-echo (purecopy "Mouse-2 to find matches for a pattern"))
+ (insert " ")
+
+ (insert-button "[Quit]" :type 'dictionary-button
+ 'callback 'dictionary-close
+ 'help-echo (purecopy "Mouse-2 to close this window"))
+
+ (insert "\n ")
+
+ (insert-button "[Select dictionary]" :type 'dictionary-button
+ 'callback 'dictionary-select-dictionary
+ 'help-echo (purecopy "Mouse-2 to select dictionary for future searches"))
+ (insert " ")
+ (insert-button "[Select match strategy]" :type 'dictionary-button
+ 'callback 'dictionary-select-strategy
+ 'help-echo (purecopy "Mouse-2 to select matching algorithm"))
+ (insert "\n\n")))
+ (setq dictionary-marker (point-marker)))
+
+(defun dictionary-post-buffer ()
+ "These commands are executed at the end of a new buffer."
+ (goto-char dictionary-marker)
+
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (run-hooks 'dictionary-post-buffer-hook))
+
+(defun dictionary-display-search-result (reply)
+ "Start displaying the result in REPLY."
+
+ (let ((number (nth 1 (dictionary-reply-list reply))))
+ (insert number (if (equal number "1")
+ " definition"
+ " definitions")
+ " found\n\n")
+ (setq reply (dictionary-read-reply-and-split))
+ (while (dictionary-check-reply reply 151)
+ (let* ((reply-list (dictionary-reply-list reply))
+ (dictionary (nth 2 reply-list))
+ (description (nth 3 reply-list))
+ (word (nth 1 reply-list)))
+ (dictionary-display-word-entry dictionary description)
+ (setq reply (dictionary-read-answer))
+ (dictionary-display-word-definition reply word dictionary)
+ (setq reply (dictionary-read-reply-and-split))))
+ (dictionary-post-buffer)))
+
+(defun dictionary-display-word-entry (dictionary description)
+ "Insert an explanation for DESCRIPTION from DICTIONARY.
+The DICTIONARY is only used for decoding the bytes to display the DESCRIPTION."
+ (let ((start (point)))
+ (insert "From "
+ dictionary-description-open-delimiter
+ (dictionary-decode-charset description dictionary)
+ dictionary-description-close-delimiter
+ " [" (dictionary-decode-charset dictionary dictionary) "]:")
+ (put-text-property start (point) 'face 'dictionary-word-entry-face)
+ (insert "\n\n")))
+
+(defun dictionary-display-word-definition (reply word dictionary)
+ "Insert the definition in REPLY for the current WORD from DICTIONARY.
+It will replace links which are found in the REPLY and replace
+them with buttons to perform a new search."
+ (let ((start (point)))
+ (insert (dictionary-decode-charset reply dictionary))
+ (insert "\n\n")
+ (put-text-property start (point) 'face 'dictionary-word-definition-face)
+ (let ((regexp "\\({+\\)\\([^ '\"][^}]*\\)\\(}+\\)"))
+ (goto-char start)
+ (while (< (point) (point-max))
+ (if (search-forward-regexp regexp nil t)
+ (let ((match-start (match-beginning 2))
+ (match-end (match-end 2)))
+ (if dictionary-color-support
+ ;; Compensate for the replacement
+ (let ((brace-match-length (- (match-end 1)
+ (match-beginning 1))))
+ (setq match-start (- (match-beginning 2)
+ brace-match-length))
+ (setq match-end (- (match-end 2)
+ brace-match-length))
+ (replace-match "\\2")))
+ (dictionary-mark-reference match-start match-end
+ 'dictionary-new-search
+ word dictionary))
+ (goto-char (point-max)))))))
+
+(defun dictionary-mark-reference (start end call displayed-word dictionary)
+ "Format the area from START to END as link calling CALL.
+The word is taken from the buffer, the DICTIONARY is given as argument."
+ (let ((word (buffer-substring-no-properties start end)))
+ (while (string-match "\n\\s-*" word)
+ (setq word (replace-match " " t t word)))
+ (while (string-match "[*\"]" word)
+ (setq word (replace-match "" t t word)))
+ (when dictionary-link-dictionary
+ (setq dictionary dictionary-link-dictionary))
+
+ (unless (equal word displayed-word)
+ (make-button start end :type 'dictionary-link
+ 'callback call
+ 'data (cons word dictionary)
+ 'help-echo (concat "Press Mouse-2 to lookup \""
+ word "\" in \"" dictionary "\"")))))
+
+(defun dictionary-select-dictionary (&rest _ignored)
+ "Save the current state and start a dictionary selection."
+ (interactive)
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-select-dictionary)
+ (dictionary-store-state 'dictionary-do-select-dictionary nil))
+
+(defun dictionary-do-select-dictionary (&rest _ignored)
+ "The workhorse for doing the dictionary selection."
+
+ (message "Looking up databases and descriptions")
+ (dictionary-send-command "show db")
+
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 554)
+ (error "No dictionary present")
+ (unless (dictionary-check-reply reply 110)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))
+ (dictionary-display-dictionaries))))
+
+(defun dictionary-simple-split-string (string &optional pattern)
+ "Return a list of substrings of STRING which are separated by PATTERN.
+If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
+ (or pattern
+ (setq pattern "[ \f\t\n\r\v]+"))
+ ;; The FSF version of this function takes care not to cons in case
+ ;; of infloop. Maybe we should synch?
+ (let (parts (start 0))
+ (while (string-match pattern string start)
+ (setq parts (cons (substring string start (match-beginning 0)) parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts))))
+
+(defun dictionary-display-dictionaries ()
+ "Handle the display of all dictionaries existing on the server."
+ (dictionary-pre-buffer)
+ (insert "Please select your default dictionary:\n\n")
+ (dictionary-display-dictionary-line "* \"All dictionaries\"")
+ (dictionary-display-dictionary-line "! \"The first matching dictionary\"")
+ (let* ((reply (dictionary-read-answer))
+ (list (dictionary-simple-split-string reply "\n+")))
+ (mapc #'dictionary-display-dictionary-line list))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-dictionary-line (string)
+ "Display a single dictionary and its description read from STRING."
+ (let* ((list (dictionary-split-string string))
+ (dictionary (car list))
+ (description (cadr list))
+ (translated (dictionary-decode-charset description dictionary)))
+ (if dictionary
+ (if (equal dictionary "--exit--")
+ (insert "(end of default search list)\n")
+ (insert-button (concat dictionary ": " translated) :type 'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'data (cons dictionary description)
+ 'help-echo (purecopy "Mouse-2 to select this dictionary"))
+ (unless (dictionary-special-dictionary dictionary)
+ (insert " ")
+ (insert-button "(Details)" :type 'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'list-data (list (cons dictionary description) t)
+ 'help-echo (purecopy "Mouse-2 to get more information")))
+ (insert "\n")))))
+
+(defun dictionary-set-dictionary (param &optional more)
+ "Select the dictionary which is the car of PARAM as new default."
+
+ (if more
+ (dictionary-display-more-info param)
+ (let ((dictionary (car param)))
+ (setq dictionary-default-dictionary dictionary)
+ (dictionary-restore-state)
+ (message "Dictionary %s has been selected" dictionary))))
+
+(defun dictionary-special-dictionary (name)
+ "Check whether the special * or ! dictionary are seen in NAME."
+ (or (equal name "*")
+ (equal name "!")))
+
+(defun dictionary-display-more-info (param)
+ "Display the available information on the dictionary found in PARAM."
+
+ (let ((dictionary (car param))
+ (description (cdr param)))
+ (unless (dictionary-special-dictionary dictionary)
+ (dictionary-store-positions)
+ (message "Requesting more information on %s" dictionary)
+ (dictionary-send-command
+ (concat "show info " (dictionary-encode-charset dictionary "")))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" does not exist" dictionary)
+ (unless (dictionary-check-reply reply 112)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (dictionary-pre-buffer)
+ (insert "Information on dictionary: ")
+ (insert-button description :type 'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'data (cons dictionary description)
+ 'help-echo (purecopy "Mouse-2 to select this dictionary"))
+ (insert "\n\n")
+ (setq reply (dictionary-read-answer))
+ (insert reply)
+ (dictionary-post-buffer)))
+
+ (dictionary-store-state 'dictionary-display-more-info dictionary))))
+
+(defun dictionary-select-strategy (&rest _ignored)
+ "Save the current state and start a strategy selection."
+ (interactive)
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-select-strategy)
+ (dictionary-store-state 'dictionary-do-select-strategy nil))
+
+(defun dictionary-do-select-strategy ()
+ "The workhorse for doing the strategy selection."
+
+ (message "Request existing matching algorithm")
+ (dictionary-send-command "show strat")
+
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 555)
+ (error "No strategies available")
+ (unless (dictionary-check-reply reply 111)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))
+ (dictionary-display-strategies))))
+
+(defun dictionary-display-strategies ()
+ "Handle the display of all strategies existing on the server."
+ (dictionary-pre-buffer)
+ (insert "Please select your default search strategy:\n\n")
+ (dictionary-display-strategy-line ". \"The servers default\"")
+ (let* ((reply (dictionary-read-answer))
+ (list (dictionary-simple-split-string reply "\n+")))
+ (mapc #'dictionary-display-strategy-line list))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-strategy-line (string)
+ "Display a single strategy found in STRING."
+ (let* ((list (dictionary-split-string string))
+ (strategy (car list))
+ (description (cadr list)))
+ (if strategy
+ (progn
+ (insert-button description :type 'dictionary-link
+ 'callback 'dictionary-set-strategy
+ 'data strategy
+ 'help-echo (purecopy "Mouse-2 to select this matching algorithm"))
+ (insert "\n")))))
+
+(defun dictionary-set-strategy (strategy &rest _ignored)
+ "Select this STRATEGY as new default."
+ (setq dictionary-default-strategy strategy)
+ (dictionary-restore-state)
+ (message "Strategy %s has been selected" strategy))
+
+(defun dictionary-new-matching (word)
+ "Run a new matching search on WORD."
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-matching word dictionary-default-dictionary
+ dictionary-default-strategy
+ 'dictionary-display-match-result)
+ (dictionary-store-state 'dictionary-do-matching
+ (list word dictionary-default-dictionary
+ dictionary-default-strategy
+ 'dictionary-display-match-result)))
+
+(defun dictionary-do-matching (word dictionary strategy function)
+ "Find matches for WORD with STRATEGY in DICTIONARY and display them with FUNCTION."
+
+ (message "Lookup matching words for %s in %s using %s"
+ word dictionary strategy)
+ (dictionary-send-command
+ (concat "match " (dictionary-encode-charset dictionary "") " "
+ (dictionary-encode-charset strategy "") " \""
+ (dictionary-encode-charset word "") "\""))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" is invalid" dictionary))
+ (if (dictionary-check-reply reply 551)
+ (error "Strategy \"%s\" is invalid" strategy))
+ (if (dictionary-check-reply reply 552)
+ (error (concat
+ "No match for \"%s\" with strategy \"%s\" in "
+ "dictionary \"%s\".")
+ word strategy dictionary))
+ (unless (dictionary-check-reply reply 152)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (funcall function reply)))
+
+(defun dictionary-display-only-match-result (reply)
+ "Display the results from the current matches in REPLY without the headers."
+ (let ((number (nth 1 (dictionary-reply-list reply)))
+ (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (insert number " matching word" (if (equal number "1") "" "s")
+ " found\n\n")
+ (let ((result nil))
+ (mapc (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (cadr list))
+ (hash (assoc dictionary result)))
+ (if dictionary
+ (if hash
+ (setcdr hash (cons word (cdr hash)))
+ (setq result (cons
+ (cons dictionary (list word))
+ result))))))
+ list)
+ (dictionary-display-match-lines (reverse result)))))
+
+(defun dictionary-display-match-result (reply)
+ "Display the results in REPLY from a match operation."
+ (dictionary-pre-buffer)
+
+ (let ((number (nth 1 (dictionary-reply-list reply)))
+ (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (insert number " matching word" (if (equal number "1") "" "s")
+ " found\n\n")
+ (let ((result nil))
+ (mapc (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (cadr list))
+ (hash (assoc dictionary result)))
+ (if dictionary
+ (if hash
+ (setcdr hash (cons word (cdr hash)))
+ (setq result (cons
+ (cons dictionary (list word))
+ result))))))
+ list)
+ (dictionary-display-match-lines (reverse result))))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-match-lines (list)
+ "Display a line for each match found in LIST."
+ (mapc (lambda (item)
+ (let ((dictionary (car item))
+ (word-list (cdr item)))
+ (insert "Matches from " dictionary ":\n")
+ (mapc (lambda (word)
+ (setq word (dictionary-decode-charset word dictionary))
+ (insert " ")
+ (insert-button word :type 'dictionary-link
+ 'callback 'dictionary-new-search
+ 'data (cons word dictionary)
+ 'help-echo (purecopy "Mouse-2 to lookup word"))
+ (insert "\n")) (reverse word-list))
+ (insert "\n")))
+ list))
+
+;; Returns a sensible default for dictionary-search:
+;; - if region is active returns its contents
+;; - otherwise return the word near the point
+(defun dictionary-search-default ()
+ (cond
+ ((use-region-p)
+ (buffer-substring-no-properties (region-beginning) (region-end)))
+ ((car (get-char-property (point) 'data)))
+ (t (current-word t))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User callable commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun dictionary-search (word &optional dictionary)
+ "Search the WORD in DICTIONARY if given or in all if nil.
+It presents the selection or word at point as default input and
+allows editing it."
+ (interactive
+ (list (let ((default (dictionary-search-default)))
+ (read-string (if default
+ (format "Search word (%s): " default)
+ "Search word: ")
+ nil 'dictionary-word-history default))
+ (if current-prefix-arg
+ (read-string (if dictionary-default-dictionary
+ (format "Dictionary (%s): " dictionary-default-dictionary)
+ "Dictionary: ")
+ nil nil dictionary-default-dictionary)
+ dictionary-default-dictionary)))
+
+ ;; if called by pressing the button
+ (unless word
+ (setq word (read-string "Search word: " nil 'dictionary-word-history)))
+ ;; just in case non-interactively called
+ (unless dictionary
+ (setq dictionary dictionary-default-dictionary))
+ (dictionary-new-search (cons word dictionary)))
+
+;;;###autoload
+(defun dictionary-lookup-definition ()
+ "Unconditionally lookup the word at point."
+ (interactive)
+ (dictionary-new-search (cons (current-word) dictionary-default-dictionary)))
+
+(defun dictionary-previous ()
+ "Go to the previous location in the current buffer."
+ (interactive)
+ (unless (dictionary-mode-p)
+ (error "Current buffer is no dictionary buffer"))
+ (dictionary-restore-state))
+
+(defun dictionary-help ()
+ "Display a little help."
+ (interactive)
+ (describe-function 'dictionary-mode))
+
+;;;###autoload
+(defun dictionary-match-words (&optional pattern &rest _ignored)
+ "Search PATTERN in current default dictionary using default strategy."
+ (interactive)
+ ;; can't use interactive because of mouse events
+ (or pattern
+ (setq pattern (read-string "Search pattern: "
+ nil 'dictionary-word-history)))
+ (dictionary-new-matching pattern))
+
+;;;###autoload
+(defun dictionary-mouse-popup-matching-words (event)
+ "Display entries matching the word at the cursor retrieved using EVENT."
+ (interactive "e")
+ (let ((word (save-window-excursion
+ (save-excursion
+ (mouse-set-point event)
+ (current-word)))))
+ (selected-window)
+ (dictionary-popup-matching-words word)))
+
+;;;###autoload
+(defun dictionary-popup-matching-words (&optional word)
+ "Display entries matching WORD or the current word if not given."
+ (interactive)
+ (dictionary-do-matching (or word (current-word) (error "Nothing to search for"))
+ dictionary-default-dictionary
+ dictionary-default-popup-strategy
+ 'dictionary-process-popup-replies))
+
+(defun dictionary-process-popup-replies (&ignore)
+ (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+
+ (let ((result (mapcar (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (dictionary-decode-charset
+ (cadr list) dictionary)))
+ (message word)
+ (if (equal word "")
+ [ "-" nil nil]
+ (vector (concat "[" dictionary "] " word)
+ `(dictionary-new-search
+ '(,word . ,dictionary))
+ t ))))
+
+ list)))
+ (easy-menu-define dictionary-mode-map-menu dictionary-mode-map
+ "Menu used for displaying dictionary popup"
+ (cons "Matching words"
+ `(,@result)))
+ (popup-menu dictionary-mode-map-menu))))
+
+;;; Tooltip support
+
+;; Add a mode indicator named "Dict"
+(defvar dictionary-tooltip-mode
+ nil
+ "Indicates whether the dictionary tooltip mode is active.")
+(nconc minor-mode-alist '((dictionary-tooltip-mode " Dict")))
+
+(defcustom dictionary-tooltip-dictionary
+ nil
+ "This dictionary to lookup words for tooltips."
+ :group 'dictionary
+ :type '(choice (const :tag "None" nil) string)
+ :version "28.1")
+
+(defun dictionary-definition (word &optional dictionary)
+ (interactive)
+ (unwind-protect
+ (let ((dictionary (or dictionary dictionary-default-dictionary)))
+ (dictionary-do-search word dictionary 'dictionary-read-definition t))
+ nil))
+
+(defun dictionary-read-definition (&ignore)
+ (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (mapconcat #'identity (cdr list) "\n")))
+
+;;; Tooltip support for GNU Emacs
+(defvar global-dictionary-tooltip-mode
+ nil)
+
+(defun dictionary-word-at-mouse-event (event)
+ (with-current-buffer (tooltip-event-buffer event)
+ (let ((point (posn-point (event-end event))))
+ (if (use-region-p)
+ (when (and (<= (region-beginning) point) (<= point (region-end)))
+ (buffer-substring (region-beginning) (region-end)))
+ (save-excursion
+ (goto-char point)
+ (current-word))))))
+
+(defvar dictionary-tooltip-mouse-event nil
+ "Event that triggered the tooltip mode.")
+
+(defun dictionary-display-tooltip (&ignore)
+ "Search the current word in the `dictionary-tooltip-dictionary'."
+ (interactive "e")
+ (if (and dictionary-tooltip-mode dictionary-tooltip-dictionary)
+ (let ((word (dictionary-word-at-mouse-event dictionary-tooltip-mouse-event)))
+ (if word
+ (let ((definition
+ (dictionary-definition word dictionary-tooltip-dictionary)))
+ (if definition
+ (tooltip-show (dictionary-decode-charset definition
+ dictionary-tooltip-dictionary)))))
+ t)
+ nil))
+
+(defun dictionary-tooltip-track-mouse (event)
+ "Called whenever a dictionary tooltip display is about to be triggered."
+ (interactive "e")
+ (tooltip-hide)
+ (when dictionary-tooltip-mode
+ (setq dictionary-tooltip-mouse-event (copy-sequence event))
+ (tooltip-start-delayed-tip)))
+
+(defun dictionary-switch-tooltip-mode (on)
+ "Turn off or on support for the dictionary tooltip mode.
+
+It is normally internally called with 1 to enable support for the
+tooltip mode. The hook function will check the value of the
+variable dictionary-tooltip-mode to decide if some action must be
+taken. When disabling the tooltip mode the value of this variable
+will be set to nil."
+ (interactive)
+ (tooltip-mode on)
+ (if on
+ (add-hook 'tooltip-functions #'dictionary-display-tooltip)
+ (remove-hook 'tooltip-functions #'dictionary-display-tooltip)))
+
+;;;###autoload
+(defun dictionary-tooltip-mode (&optional arg)
+ "Display tooltips for the current word.
+
+This function can be used to enable or disable the tooltip mode
+for the current buffer (based on ARG). If global-tooltip-mode is
+active it will overwrite that mode for the current buffer."
+ (interactive "P")
+ (require 'tooltip)
+ (let ((on (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not dictionary-tooltip-mode))))
+ (setq-local dictionary-tooltip-mode on)
+ (setq-local track-mouse on)
+ (make-local-variable 'dictionary-tooltip-mouse-event)
+ (dictionary-switch-tooltip-mode 1)
+ (if on
+ (local-set-key [mouse-movement] 'dictionary-tooltip-track-mouse)
+ (local-set-key [mouse-movement] 'ignore))
+ on))
+
+;;;###autoload
+(defun global-dictionary-tooltip-mode (&optional arg)
+ "Enable/disable dictionary-tooltip-mode for all buffers.
+
+Internally it provides a default for the dictionary-tooltip-mode.
+It can be overwritten for each buffer using dictionary-tooltip-mode.
+
+Note: (global-dictionary-tooltip-mode 0) will not disable the mode
+any buffer where (dictionary-tooltip-mode 1) has been called."
+ (interactive "P")
+ (require 'tooltip)
+ (let ((on (if arg (> (prefix-numeric-value arg) 0)
+ (not global-dictionary-tooltip-mode))))
+ (setq global-dictionary-tooltip-mode on)
+ (setq-default dictionary-tooltip-mode on)
+ (make-local-variable 'dictionary-tooltip-mouse-event)
+ (setq-default track-mouse on)
+ (dictionary-switch-tooltip-mode 1)
+ (global-set-key [mouse-movement]
+ (if on #'dictionary-tooltip-track-mouse #'ignore))
+ on))
+
+(provide 'dictionary)
+;;; dictionary.el ends here
diff --git a/lisp/net/dig.el b/lisp/net/dig.el
index e137044b17f..4f0b0df2b73 100644
--- a/lisp/net/dig.el
+++ b/lisp/net/dig.el
@@ -1,4 +1,4 @@
-;;; dig.el --- Domain Name System dig interface
+;;; dig.el --- Domain Name System dig interface -*- lexical-binding:t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -42,15 +42,13 @@
(defcustom dig-program "dig"
"Name of dig (domain information groper) binary."
- :type 'file
- :group 'dig)
+ :type 'file)
(defcustom dig-dns-server nil
"DNS server to query.
If nil, use system defaults."
:type '(choice (const :tag "System defaults")
- string)
- :group 'dig)
+ string))
(defcustom dig-font-lock-keywords
'(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face)
@@ -58,8 +56,7 @@ If nil, use system defaults."
("^; <<>>.*" 0 font-lock-type-face)
("^;.*" 0 font-lock-function-name-face))
"Default expressions to highlight in dig mode."
- :type 'sexp
- :group 'dig)
+ :type 'sexp)
(defun dig-invoke (domain &optional
query-type query-class query-option
@@ -82,7 +79,7 @@ and is a commonly available debugging tool."
(push domain cmdline)
(if server (push (concat "@" server) cmdline)
(if dig-dns-server (push (concat "@" dig-dns-server) cmdline)))
- (apply 'call-process dig-program nil buf nil cmdline)
+ (apply #'call-process dig-program nil buf nil cmdline)
buf))
(defun dig-extract-rr (domain &optional type class)
@@ -123,17 +120,15 @@ Buffer should contain output generated by `dig-invoke'."
(defvar dig-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "g" nil)
- (define-key map "q" 'dig-exit)
+ (define-key map "q" #'dig-exit)
map))
(define-derived-mode dig-mode special-mode "Dig"
"Major mode for displaying dig output."
(buffer-disable-undo)
(setq-local font-lock-defaults '(dig-font-lock-keywords t))
- (when (featurep 'font-lock)
- ;; FIXME: what is this for?? --Stef
- (font-lock-set-defaults))
- )
+ ;; FIXME: what is this for?? --Stef M
+ (font-lock-set-defaults))
(defun dig-exit ()
"Quit dig output buffer."
@@ -143,9 +138,14 @@ Buffer should contain output generated by `dig-invoke'."
;;;###autoload
(defun dig (domain &optional
query-type query-class query-option dig-option server)
- "Query addresses of a DOMAIN using dig, by calling `dig-invoke'.
-Optional arguments are passed to `dig-invoke'."
- (interactive "sHost: ")
+ "Query addresses of a DOMAIN using dig.
+See `dig-invoke' for an explanation for the parameters.
+When called interactively, DOMAIN is prompted for. If given a prefix,
+also prompt for the QUERY-TYPE parameter."
+ (interactive
+ (list (read-string "Host: ")
+ (and current-prefix-arg
+ (read-string "Query type: "))))
(pop-to-buffer-same-window
(dig-invoke domain query-type query-class query-option dig-option server))
(goto-char (point-min))
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index 8b75ecca810..1086bab9466 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -1,4 +1,4 @@
-;;; dns.el --- Domain Name Service lookups
+;;; dns.el --- Domain Name Service lookups -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -24,6 +24,8 @@
;;; Code:
+(require 'cl-lib)
+
(defvar dns-timeout 5
"How many seconds to wait when doing DNS queries.")
@@ -73,7 +75,7 @@ updated. Set this variable to t to disable the check.")
(defun dns-write-bytes (value &optional length)
(let (bytes)
- (dotimes (i (or length 1))
+ (dotimes (_ (or length 1))
(push (% value 256) bytes)
(setq value (/ value 256)))
(dolist (byte bytes)
@@ -81,7 +83,7 @@ updated. Set this variable to t to disable the check.")
(defun dns-read-bytes (length)
(let ((value 0))
- (dotimes (i length)
+ (dotimes (_ length)
(setq value (logior (* value 256) (following-char)))
(forward-char 1))
value))
@@ -133,12 +135,12 @@ updated. Set this variable to t to disable the check.")
(if (stringp ended)
(if (null name)
ended
- (concat (mapconcat 'identity (nreverse name) ".") "." ended))
- (mapconcat 'identity (nreverse name) "."))))
+ (concat (mapconcat #'identity (nreverse name) ".") "." ended))
+ (mapconcat #'identity (nreverse name) "."))))
(defun dns-write (spec &optional tcp-p)
"Write a DNS packet according to SPEC.
-If TCP-P, the first two bytes of the package with be the length field."
+If TCP-P, the first two bytes of the packet will be the length field."
(with-temp-buffer
(set-buffer-multibyte nil)
(dns-write-bytes (dns-get 'id spec) 2)
@@ -189,13 +191,15 @@ If TCP-P, the first two bytes of the package with be the length field."
(dns-write-bytes (buffer-size) 2))
(buffer-string)))
-(defun dns-read (packet)
+(defun dns-read (packet &optional tcp-p)
(with-temp-buffer
(set-buffer-multibyte nil)
(let ((spec nil)
queries answers authorities additionals)
(insert packet)
- (goto-char (point-min))
+ ;; When using TCP we have a 2 byte length field to ignore.
+ (goto-char (+ (point-min)
+ (if tcp-p 2 0)))
(push (list 'id (dns-read-bytes 2)) spec)
(let ((byte (dns-read-bytes 1)))
(push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t))
@@ -227,7 +231,7 @@ If TCP-P, the first two bytes of the package with be the length field."
(setq authorities (dns-read-bytes 2))
(setq additionals (dns-read-bytes 2))
(let ((qs nil))
- (dotimes (i queries)
+ (dotimes (_ queries)
(push (list (dns-read-name)
(list 'type (dns-inverse-get (dns-read-bytes 2)
dns-query-types))
@@ -235,33 +239,36 @@ If TCP-P, the first two bytes of the package with be the length field."
dns-classes)))
qs))
(push (list 'queries qs) spec))
- (dolist (slot '(answers authorities additionals))
- (let ((qs nil)
- type)
- (dotimes (i (symbol-value slot))
- (push (list (dns-read-name)
- (list 'type
- (setq type (dns-inverse-get (dns-read-bytes 2)
- dns-query-types)))
- (list 'class (dns-inverse-get (dns-read-bytes 2)
- dns-classes))
- (list 'ttl (dns-read-bytes 4))
- (let ((length (dns-read-bytes 2)))
- (list 'data
- (dns-read-type
- (buffer-substring
- (point)
- (progn (forward-char length) (point)))
- type))))
- qs))
- (push (list slot qs) spec)))
+ (cl-loop for (slot length) in `((answers ,answers)
+ (authorities ,authorities)
+ (additionals ,additionals))
+ do (let ((qs nil)
+ type)
+ (dotimes (_ length)
+ (push (list (dns-read-name)
+ (list 'type
+ (setq type (dns-inverse-get
+ (dns-read-bytes 2)
+ dns-query-types)))
+ (list 'class (dns-inverse-get
+ (dns-read-bytes 2)
+ dns-classes))
+ (list 'ttl (dns-read-bytes 4))
+ (let ((length (dns-read-bytes 2)))
+ (list 'data
+ (dns-read-type
+ (buffer-substring
+ (point)
+ (progn (forward-char length)
+ (point)))
+ type))))
+ qs))
+ (push (list slot qs) spec)))
(nreverse spec))))
(defun dns-read-int32 ()
- ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we
- ;; use floats, it works.
- (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
- (dns-read-bytes 3))))
+ (declare (obsolete nil "28.1"))
+ (number-to-string (dns-read-bytes 4)))
(defun dns-read-type (string type)
(let ((buffer (current-buffer))
@@ -274,23 +281,23 @@ If TCP-P, the first two bytes of the package with be the length field."
(cond
((eq type 'A)
(let ((bytes nil))
- (dotimes (i 4)
+ (dotimes (_ 4)
(push (dns-read-bytes 1) bytes))
- (mapconcat 'number-to-string (nreverse bytes) ".")))
+ (mapconcat #'number-to-string (nreverse bytes) ".")))
((eq type 'AAAA)
(let (hextets)
- (dotimes (i 8)
+ (dotimes (_ 8)
(push (dns-read-bytes 2) hextets))
(mapconcat (lambda (n) (format "%x" n))
(nreverse hextets) ":")))
((eq type 'SOA)
(list (list 'mname (dns-read-name buffer))
(list 'rname (dns-read-name buffer))
- (list 'serial (dns-read-int32))
- (list 'refresh (dns-read-int32))
- (list 'retry (dns-read-int32))
- (list 'expire (dns-read-int32))
- (list 'minimum (dns-read-int32))))
+ (list 'serial (dns-read-bytes 4))
+ (list 'refresh (dns-read-bytes 4))
+ (list 'retry (dns-read-bytes 4))
+ (list 'expire (dns-read-bytes 4))
+ (list 'minimum (dns-read-bytes 4))))
((eq type 'SRV)
(list (list 'priority (dns-read-bytes 2))
(list 'weight (dns-read-bytes 2))
@@ -309,16 +316,14 @@ If TCP-P, the first two bytes of the package with be the length field."
"Return false if we need to recheck the list of DNS servers."
(and dns-servers
(or (eq dns-servers-valid-for-interfaces t)
- ;; `network-interface-list' was introduced in Emacs 22.1.
- (not (fboundp 'network-interface-list))
(equal dns-servers-valid-for-interfaces
(network-interface-list)))))
(defun dns-set-servers ()
"Set `dns-servers' to a list of DNS servers or nil if none are found.
Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
+ (setq dns-servers nil)
(or (when (file-exists-p "/etc/resolv.conf")
- (setq dns-servers nil)
(with-temp-buffer
(insert-file-contents "/etc/resolv.conf")
(goto-char (point-min))
@@ -327,13 +332,12 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
(setq dns-servers (nreverse dns-servers))))
(when (executable-find "nslookup")
(with-temp-buffer
- (call-process "nslookup" nil t nil "localhost")
+ (call-process "nslookup" nil t nil "-retry=0" "-timeout=2" "localhost")
(goto-char (point-min))
- (re-search-forward
- "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
- (setq dns-servers (list (match-string 1))))))
- (when (fboundp 'network-interface-list)
- (setq dns-servers-valid-for-interfaces (network-interface-list))))
+ (when (re-search-forward
+ "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t)
+ (setq dns-servers (list (match-string 1)))))))
+ (setq dns-servers-valid-for-interfaces (network-interface-list)))
(defun dns-read-txt (string)
(if (> (length string) 1)
@@ -355,23 +359,6 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
result))
;;; Interface functions.
-(defmacro dns-make-network-process (server)
- `(let ((server ,server)
- (coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (if (fboundp 'make-network-process)
- (make-network-process
- :name "dns"
- :coding 'binary
- :buffer (current-buffer)
- :host server
- :service "domain"
- :type 'datagram)
- ;; Older versions of Emacs doesn't have
- ;; `make-network-process', so we fall back on opening a TCP
- ;; connection to the DNS server.
- (open-network-stream "dns" (current-buffer) server "domain"))))
-
(defvar dns-cache (make-vector 4096 0))
(defun dns-query-cached (name &optional type fullp reversep)
@@ -384,64 +371,144 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
(set (intern key dns-cache) result)
result))))
-;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
-;; yet, so no alias are provided. --rsteib
-
-(defun dns-query (name &optional type fullp reversep)
+(defun dns-query-asynchronous (name callback &optional type full reverse)
"Query a DNS server for NAME of TYPE.
-If FULLP, return the entire record returned.
-If REVERSEP, look up an IP address."
+CALLBACK will be called with a single parameter: The result.
+
+If there's no result, or `dns-timeout' has passed, CALLBACK will
+be called with nil as the parameter.
+
+If FULL, return the entire record.
+If REVERSE, look up an IP address."
(setq type (or type 'A))
(unless (dns-servers-up-to-date-p)
(dns-set-servers))
- (when reversep
+ (when reverse
(setq name (concat
- (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
+ (mapconcat #'identity (nreverse (split-string name "\\.")) ".")
".in-addr.arpa")
type 'PTR))
(if (not dns-servers)
- (message "No DNS server configuration found")
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (let ((process (condition-case ()
- (dns-make-network-process (car dns-servers))
- (error
- (message
- "dns: Got an error while trying to talk to %s"
- (car dns-servers))
- nil)))
- (step 100)
- (times (* dns-timeout 1000))
- (id (random 65000)))
- (when process
- (process-send-string
- process
- (dns-write `((id ,id)
- (opcode query)
- (queries ((,name (type ,type))))
- (recursion-desired-p t))))
- (while (and (zerop (buffer-size))
- (> times 0))
- (let ((step-sec (/ step 1000.0)))
- (sit-for step-sec)
- (accept-process-output process step-sec))
- (setq times (- times step)))
- (condition-case nil
- (delete-process process)
- (error nil))
- (when (and (>= (buffer-size) 2)
- ;; We had a time-out.
- (> times 0))
- (let ((result (dns-read (buffer-string))))
- (if fullp
- result
- (let ((answer (car (dns-get 'answers result))))
- (when (eq type (dns-get 'type answer))
- (if (eq type 'TXT)
- (dns-get-txt-answer (dns-get 'answers result))
- (dns-get 'data answer))))))))))))
+ (progn
+ (message "No DNS server configuration found")
+ nil)
+ (dns--lookup name callback type full)))
+
+(defun dns--lookup (name callback type full)
+ (with-current-buffer (generate-new-buffer " *dns*")
+ (set-buffer-multibyte nil)
+ (let* ((tcp nil)
+ (process
+ (condition-case ()
+ (let ((server (car dns-servers))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (if (featurep 'make-network-process '(:type datagram))
+ (make-network-process
+ :name "dns"
+ :coding 'binary
+ :buffer (current-buffer)
+ :host server
+ :service "domain"
+ :type 'datagram)
+ ;; On MS-Windows datagram sockets are not
+ ;; supported, so we fall back on opening a TCP
+ ;; connection to the DNS server.
+ (progn
+ (setq tcp t)
+ (open-network-stream "dns" (current-buffer)
+ server "domain"))))
+ (error
+ (message
+ "dns: Got an error while trying to talk to %s"
+ (car dns-servers))
+ nil)))
+ (triggered nil)
+ (buffer (current-buffer))
+ timer)
+ (if (not process)
+ (progn
+ (kill-buffer buffer)
+ (funcall callback nil))
+ ;; Call the callback if we don't get any response at all.
+ (setq timer (run-at-time dns-timeout nil
+ (lambda ()
+ (unless triggered
+ (setq triggered t)
+ (delete-process process)
+ (kill-buffer buffer)
+ (funcall callback nil)))))
+ (process-send-string
+ process
+ (dns-write `((id ,(random 65000))
+ (opcode query)
+ (queries ((,name (type ,type))))
+ (recursion-desired-p t))
+ tcp))
+ (set-process-filter
+ process
+ (lambda (process string)
+ (with-current-buffer (process-buffer process)
+ (goto-char (point-max))
+ (insert string)
+ (goto-char (point-min))
+ ;; If this is DNS, then we always get the full data in
+ ;; one packet. If it's TCP, we may only get part of the
+ ;; data, but the first two bytes says how long the data
+ ;; is supposed to be.
+ (when (or (not tcp)
+ (>= (buffer-size) (dns-read-bytes 2)))
+ (setq triggered t)
+ (cancel-timer timer)
+ (dns--filter process callback type full tcp)))))
+ ;; In case we the process is deleted for some reason, then do
+ ;; a failure callback.
+ (set-process-sentinel
+ process
+ (lambda (_ state)
+ (when (and (eq state 'deleted)
+ ;; Ensure we don't trigger this callback twice.
+ (not triggered))
+ (setq triggered t)
+ (cancel-timer timer)
+ (kill-buffer buffer)
+ (funcall callback nil))))))))
+
+(defun dns--filter (process callback type full tcp)
+ (let ((message (buffer-string)))
+ (when (process-live-p process)
+ (delete-process process))
+ (kill-buffer (current-buffer))
+ (when (>= (length message) 2)
+ (let ((result (dns-read message tcp)))
+ (funcall callback
+ (if full
+ result
+ (let ((answer (car (dns-get 'answers result))))
+ (when (eq type (dns-get 'type answer))
+ (if (eq type 'TXT)
+ (dns-get-txt-answer (dns-get 'answers result))
+ (dns-get 'data answer))))))))))
+
+;;;###autoload
+(defun dns-query (name &optional type full reverse)
+ "Query a DNS server for NAME of TYPE.
+If FULL, return the entire record returned.
+If REVERSE, look up an IP address."
+ (let* ((result nil)
+ (query-started
+ (dns-query-asynchronous
+ name
+ (lambda (response)
+ (setq result (list response)))
+ type full reverse)))
+ (if query-started
+ ;; Loop until we get the callback.
+ (while (not result)
+ (sleep-for 0.01)))
+ (car result)))
(provide 'dns)
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el
index c22d4782b88..1d7af7f5b5f 100644
--- a/lisp/net/eudc-bob.el
+++ b/lisp/net/eudc-bob.el
@@ -1,4 +1,4 @@
-;;; eudc-bob.el --- Binary Objects Support for EUDC
+;;; eudc-bob.el --- Binary Objects Support for EUDC -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -39,19 +39,41 @@
(require 'eudc)
-(defvar eudc-bob-generic-keymap nil
+(defvar eudc-bob-generic-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "s" #'eudc-bob-save-object)
+ (define-key map "!" #'eudc-bob-pipe-object-to-external-program)
+ (define-key map [down-mouse-3] #'eudc-bob-popup-menu)
+ map)
"Keymap for multimedia objects.")
-(defvar eudc-bob-image-keymap nil
+(defvar eudc-bob-image-keymap
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map eudc-bob-generic-keymap)
+ (define-key map "t" #'eudc-bob-toggle-inline-display)
+ map)
"Keymap for inline images.")
-(defvar eudc-bob-sound-keymap nil
+(defvar eudc-bob-sound-keymap
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map eudc-bob-generic-keymap)
+ (define-key map (kbd "RET") #'eudc-bob-play-sound-at-point)
+ (define-key map [down-mouse-2] #'eudc-bob-play-sound-at-mouse)
+ map)
"Keymap for inline sounds.")
-(defvar eudc-bob-url-keymap nil
+(defvar eudc-bob-url-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") #'browse-url-at-point)
+ (define-key map [down-mouse-2] #'browse-url-at-mouse)
+ map)
"Keymap for inline urls.")
-(defvar eudc-bob-mail-keymap nil
+(defvar eudc-bob-mail-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") #'goto-address-at-point)
+ (define-key map [down-mouse-2] #'goto-address-at-point)
+ map)
"Keymap for inline e-mail addresses.")
(defvar eudc-bob-generic-menu
@@ -71,16 +93,9 @@
`("EUDC Sound Menu"
["---" nil nil]
["Play sound" eudc-bob-play-sound-at-point
- (fboundp 'play-sound)]
+ (fboundp 'play-sound-internal)]
,@(cdr (cdr eudc-bob-generic-menu))))
-(defun eudc-jump-to-event (event)
- "Jump to the window and point where EVENT occurred."
- (if (fboundp 'event-closest-point)
- (goto-char (event-closest-point event))
- (set-buffer (window-buffer (posn-window (event-start event))))
- (goto-char (posn-point (event-start event)))))
-
(defun eudc-bob-get-overlay-prop (prop)
"Get property PROP from one of the overlays around."
(let ((overlays (append (overlays-at (1- (point)))
@@ -138,9 +153,7 @@ display a button."
'end-glyph (if inline glyph)
'duplicable t
'invisible inline
- 'start-open t
- 'end-open t
- 'object-data data))))
+ 'object-data data))))
((fboundp 'create-image)
(let* ((image (create-image data nil t))
(props (list 'object-data data 'eudc-image image)))
@@ -177,9 +190,7 @@ display a button."
eudc-bob-sound-keymap
eudc-bob-sound-menu
(list 'duplicable t
- 'start-open t
- 'end-open t
- 'object-data data)))
+ 'object-data data)))
(defun eudc-bob-display-generic-binary (data)
"Display a button for unidentified binary DATA."
@@ -187,9 +198,7 @@ display a button."
eudc-bob-generic-keymap
eudc-bob-generic-menu
(list 'duplicable t
- 'start-open t
- 'end-open t
- 'object-data data)))
+ 'object-data data)))
(defun eudc-bob-play-sound-at-point ()
"Play the sound data contained in the button at point."
@@ -197,7 +206,7 @@ display a button."
(let (sound)
(if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
(error "No sound data available here")
- (unless (fboundp 'play-sound)
+ (unless (fboundp 'play-sound-internal)
(error "Playing sounds not supported on this system"))
(play-sound (list 'sound :data sound)))))
@@ -205,44 +214,30 @@ display a button."
"Play the sound data contained in the button where EVENT occurred."
(interactive "e")
(save-excursion
- (eudc-jump-to-event event)
+ (mouse-set-point event)
(eudc-bob-play-sound-at-point)))
-(defun eudc-bob-save-object ()
+(defun eudc-bob-save-object (filename)
"Save the object data of the button at point."
- (interactive)
+ (interactive "fWrite file: ")
(let ((data (eudc-bob-get-overlay-prop 'object-data))
- (buffer (generate-new-buffer "*eudc-tmp*")))
- (save-excursion
- (if (fboundp 'set-buffer-file-coding-system)
- (set-buffer-file-coding-system 'binary))
- (set-buffer buffer)
- (set-buffer-multibyte nil)
- (insert data)
- (save-buffer))
- (kill-buffer buffer)))
+ (coding-system-for-write 'binary)) ;Inhibit EOL conversion.
+ (write-region data nil filename)))
-(defun eudc-bob-pipe-object-to-external-program ()
+(defun eudc-bob-pipe-object-to-external-program (program)
"Pipe the object data of the button at point to an external program."
- (interactive)
+ (interactive (list (completing-read "Viewer: " eudc-external-viewers)))
(let ((data (eudc-bob-get-overlay-prop 'object-data))
- (buffer (generate-new-buffer "*eudc-tmp*"))
- program
- viewer)
- (condition-case nil
- (save-excursion
- (if (fboundp 'set-buffer-file-coding-system)
- (set-buffer-file-coding-system 'binary))
- (set-buffer buffer)
- (insert data)
- (setq program (completing-read "Viewer: " eudc-external-viewers))
- (if (setq viewer (assoc program eudc-external-viewers))
- (call-process-region (point-min) (point-max)
- (car (cdr viewer))
- (cdr (cdr viewer)))
- (call-process-region (point-min) (point-max) program)))
- (error
- (kill-buffer buffer)))))
+ (viewer (assoc program eudc-external-viewers)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert data)
+ (let ((coding-system-for-write 'binary)) ;Inhibit EOL conversion
+ (if viewer
+ (call-process-region (point-min) (point-max)
+ (car (cdr viewer))
+ (cdr (cdr viewer)))
+ (call-process-region (point-min) (point-max) program))))))
(defun eudc-bob-menu ()
"Retrieve the menu attached to a binary object."
@@ -252,47 +247,8 @@ display a button."
"Pop-up a menu of EUDC multimedia commands."
(interactive "@e")
(run-hooks 'activate-menubar-hook)
- (eudc-jump-to-event event)
- (let ((result (x-popup-menu t (eudc-bob-menu)))
- command)
- (if result
- (progn
- (setq command (lookup-key (eudc-bob-menu)
- (apply 'vector result)))
- (command-execute command)))))
-
-(setq eudc-bob-generic-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map "s" 'eudc-bob-save-object)
- (define-key map "!" 'eudc-bob-pipe-object-to-external-program)
- (define-key map [down-mouse-3] 'eudc-bob-popup-menu)
- map))
-
-(setq eudc-bob-image-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map "t" 'eudc-bob-toggle-inline-display)
- map))
-
-(setq eudc-bob-sound-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map [return] 'eudc-bob-play-sound-at-point)
- (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse)
- map))
-
-(setq eudc-bob-url-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map [return] 'browse-url-at-point)
- (define-key map [down-mouse-2] 'browse-url-at-mouse)
- map))
-
-(setq eudc-bob-mail-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map [return] 'goto-address-at-point)
- (define-key map [down-mouse-2] 'goto-address-at-point)
- map))
-
-(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
-(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
+ (mouse-set-point event)
+ (popup-menu (eudc-bob-menu) event))
;; If the first arguments can be nil here, then these 3 can be
;; defconsts once more.
diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el
index 9306ec0c9bf..66db7814ad8 100644
--- a/lisp/net/eudc-export.el
+++ b/lisp/net/eudc-export.el
@@ -1,4 +1,4 @@
-;;; eudc-export.el --- functions to export EUDC query results
+;;; eudc-export.el --- functions to export EUDC query results -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -35,6 +35,7 @@
;; NOERROR is so we can compile it.
(require 'bbdb nil t)
(require 'bbdb-com nil t)
+(require 'cl-lib)
(defun eudc-create-bbdb-record (record &optional silent)
"Create a BBDB record using the RECORD alist.
@@ -42,24 +43,22 @@ RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
symbol and VALUE is the corresponding value for the record.
If SILENT is non-nil then the created BBDB record is not displayed."
(require 'bbdb)
+ (declare-function bbdb-create-internal "bbdb-com" (&rest spec))
+ (declare-function bbdb-display-records "bbdb"
+ (records &optional layout append))
;; This function runs in a special context where lisp symbols corresponding
;; to field names in record are bound to the corresponding values
- (eval
- `(let* (,@(mapcar (lambda (c)
- (list (car c) (if (listp (cdr c))
- (list 'quote (cdr c))
- (cdr c))))
- record)
- bbdb-name
- bbdb-company
- bbdb-net
- bbdb-address
- bbdb-phones
- bbdb-notes
- spec
- bbdb-record
- value
- (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
+ (cl-progv (mapcar #'car record) (mapcar #'cdr record)
+ (let* (bbdb-name
+ bbdb-company
+ bbdb-net
+ bbdb-address
+ bbdb-phones
+ bbdb-notes
+ spec
+ bbdb-record
+ value
+ (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
;; BBDB standard fields
(setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
@@ -68,37 +67,37 @@ If SILENT is non-nil then the created BBDB record is not displayed."
bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
(setq spec (cdr (assq 'address conversion-alist)))
(setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
- spec
- (list spec))
- record t)))
+ spec
+ (list spec))
+ record t)))
(setq spec (cdr (assq 'phone conversion-alist)))
(setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
- spec
- (list spec))
- record t)))
+ spec
+ (list spec))
+ record t)))
;; BBDB custom fields
(setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
- (mapcar (function
- (lambda (mapping)
- (if (and (not (memq (car mapping)
- '(name company net address phone notes)))
- (setq value (eudc-parse-spec (cdr mapping) record nil)))
- (cons (car mapping) value))))
+ (mapcar (lambda (mapping)
+ (if (and (not (memq (car mapping)
+ '(name company net address phone notes)))
+ (setq value (eudc-parse-spec (cdr mapping) record nil)))
+ (cons (car mapping) value)))
conversion-alist)))
(setq bbdb-notes (delq nil bbdb-notes))
- (setq bbdb-record (bbdb-create-internal
- bbdb-name
- ,@(when (eudc--using-bbdb-3-or-newer-p)
- '(nil
- nil))
- bbdb-company
- bbdb-net
- ,@(if (eudc--using-bbdb-3-or-newer-p)
- '(bbdb-phones
- bbdb-address)
- '(bbdb-address
- bbdb-phones))
- bbdb-notes))
+ (setq bbdb-record
+ (apply #'bbdb-create-internal
+ `(,bbdb-name
+ ,@(when (eudc--using-bbdb-3-or-newer-p)
+ '(nil
+ nil))
+ ,bbdb-company
+ ,bbdb-net
+ ,@(if (eudc--using-bbdb-3-or-newer-p)
+ (list bbdb-phones
+ bbdb-address)
+ (list bbdb-address
+ bbdb-phones))
+ ,bbdb-notes)))
(or silent
(bbdb-display-records (list bbdb-record))))))
@@ -112,7 +111,7 @@ If RECURSE is non-nil then SPEC may be a list of atomic specs."
(symbolp (car spec))
(fboundp (car spec))))
(condition-case nil
- (eval spec)
+ (eval spec t)
(void-variable nil)))
((and recurse
(listp spec))
@@ -195,9 +194,9 @@ LOCATION is used as the phone location for BBDB."
(signal (car err) (cdr err)))))
(if (= 3 (length phone-list))
(setq phone-list (append phone-list '(nil))))
- (apply 'vector location phone-list)))
+ (apply #'vector location phone-list)))
((listp phone)
- (vector location (mapconcat 'identity phone ", ")))
+ (vector location (mapconcat #'identity phone ", ")))
(t
(error "Invalid phone specification"))))
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el
index e4b7e8ae71b..a737a99ce95 100644
--- a/lisp/net/eudc-hotlist.el
+++ b/lisp/net/eudc-hotlist.el
@@ -1,4 +1,4 @@
-;;; eudc-hotlist.el --- hotlist management for EUDC
+;;; eudc-hotlist.el --- hotlist management for EUDC -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -37,12 +37,12 @@
(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-current-buffer)
+ (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-current-buffer)
map))
(define-derived-mode eudc-hotlist-mode fundamental-mode "EUDC-Servers"
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 26495c19020..b80801717f1 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -1,4 +1,4 @@
-;;; eudc-vars.el --- Emacs Unified Directory Client
+;;; eudc-vars.el --- Emacs Unified Directory Client -*- lexical-binding: t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -27,8 +27,6 @@
;;; Code:
-(require 'custom)
-
;;{{{ EUDC Main Custom Group
(defgroup eudc nil
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 3169022186e..6459c52afee 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -49,10 +49,6 @@
(require 'cl-lib)
-(eval-and-compile
- (if (not (fboundp 'make-overlay))
- (require 'overlay)))
-
(unless (fboundp 'custom-menu-create)
(autoload 'custom-menu-create "cus-edit"))
@@ -69,12 +65,12 @@
(defvar eudc-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map widget-keymap)
- (define-key map "q" 'kill-current-buffer)
- (define-key map "x" 'kill-current-buffer)
- (define-key map "f" 'eudc-query-form)
- (define-key map "b" 'eudc-try-bbdb-insert)
- (define-key map "n" 'eudc-move-to-next-record)
- (define-key map "p" 'eudc-move-to-previous-record)
+ (define-key map "q" #'kill-current-buffer)
+ (define-key map "x" #'kill-current-buffer)
+ (define-key map "f" #'eudc-query-form)
+ (define-key map "b" #'eudc-try-bbdb-insert)
+ (define-key map "n" #'eudc-move-to-next-record)
+ (define-key map "p" #'eudc-move-to-previous-record)
map))
(defvar mode-popup-menu)
@@ -411,13 +407,12 @@ if any, is called to print the value in cdr of FIELD."
(val (cdr field)))
(if match
(progn
- (eval (list (cdr match) val))
+ (funcall (cdr match) val)
(insert "\n"))
(mapc
- (function
- (lambda (val-elem)
- (indent-to col)
- (insert val-elem "\n")))
+ (lambda (val-elem)
+ (indent-to col)
+ (insert val-elem "\n"))
(cond
((listp val) val)
((stringp val) (split-string val "\n"))
@@ -464,37 +459,33 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
;; Replace field names with user names, compute max width
(setq precords
(mapcar
- (function
- (lambda (record)
- (mapcar
- (function
- (lambda (field)
- (setq attribute-name
- (if raw-attr-names
- (symbol-name (car field))
- (eudc-format-attribute-name-for-display (car field))))
- (if (> (length attribute-name) width)
- (setq width (length attribute-name)))
- (cons attribute-name (cdr field))))
- record)))
+ (lambda (record)
+ (mapcar
+ (lambda (field)
+ (setq attribute-name
+ (if raw-attr-names
+ (symbol-name (car field))
+ (eudc-format-attribute-name-for-display (car field))))
+ (if (> (length attribute-name) width)
+ (setq width (length attribute-name)))
+ (cons attribute-name (cdr field)))
+ record))
records))
;; Display the records
(setq first-record (point))
(mapc
- (function
- (lambda (record)
- (setq beg (point))
- ;; Map over the record fields to print the attribute/value pairs
- (mapc (function
- (lambda (field)
- (eudc-print-record-field field width)))
- record)
- ;; Store the record internal format in some convenient place
- (overlay-put (make-overlay beg (point))
- 'eudc-record
- (car records))
- (setq records (cdr records))
- (insert "\n")))
+ (lambda (record)
+ (setq beg (point))
+ ;; Map over the record fields to print the attribute/value pairs
+ (mapc (lambda (field)
+ (eudc-print-record-field field width))
+ record)
+ ;; Store the record internal format in some convenient place
+ (overlay-put (make-overlay beg (point))
+ 'eudc-record
+ (car records))
+ (setq records (cdr records))
+ (insert "\n"))
precords))
(insert "\n")
(widget-create 'push-button
@@ -518,12 +509,11 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(if (not (and (boundp 'eudc-form-widget-list)
eudc-form-widget-list))
(error "Not in a directory query form buffer")
- (mapc (function
- (lambda (wid-field)
- (setq value (widget-value (cdr wid-field)))
- (if (not (string= value ""))
- (setq query-alist (cons (cons (car wid-field) value)
- query-alist)))))
+ (mapc (lambda (wid-field)
+ (setq value (widget-value (cdr wid-field)))
+ (if (not (string= value ""))
+ (setq query-alist (cons (cons (car wid-field) value)
+ query-alist))))
eudc-form-widget-list)
(kill-buffer (current-buffer))
(eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
@@ -543,49 +533,47 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(if (null (cdar rec))
(list record) ; No duplicate attrs in this record
- (mapc (function
- (lambda (field)
- (if (listp (cdr field))
- (setq duplicates (cons field duplicates))
- (setq unique (cons field unique)))))
+ (mapc (lambda (field)
+ (if (listp (cdr field))
+ (setq duplicates (cons field duplicates))
+ (setq unique (cons field unique))))
record)
(setq result (list unique))
;; Map over the record fields that have multiple values
(mapc
- (function
- (lambda (field)
- (let ((method (if (consp eudc-duplicate-attribute-handling-method)
- (cdr
- (assq
- (or
- (car
- (rassq
- (car field)
- (symbol-value
- eudc-protocol-attributes-translation-alist)))
- (car field))
- eudc-duplicate-attribute-handling-method))
- eudc-duplicate-attribute-handling-method)))
- (cond
- ((or (null method) (eq 'list method))
- (setq result
- (eudc-add-field-to-records field result)))
- ((eq 'first method)
- (setq result
- (eudc-add-field-to-records (cons (car field)
- (cadr field))
- result)))
- ((eq 'concat method)
- (setq result
- (eudc-add-field-to-records (cons (car field)
- (mapconcat
- #'identity
- (cdr field)
- "\n"))
- result)))
- ((eq 'duplicate method)
- (setq result
- (eudc-distribute-field-on-records field result)))))))
+ (lambda (field)
+ (let ((method (if (consp eudc-duplicate-attribute-handling-method)
+ (cdr
+ (assq
+ (or
+ (car
+ (rassq
+ (car field)
+ (symbol-value
+ eudc-protocol-attributes-translation-alist)))
+ (car field))
+ eudc-duplicate-attribute-handling-method))
+ eudc-duplicate-attribute-handling-method)))
+ (cond
+ ((or (null method) (eq 'list method))
+ (setq result
+ (eudc-add-field-to-records field result)))
+ ((eq 'first method)
+ (setq result
+ (eudc-add-field-to-records (cons (car field)
+ (cadr field))
+ result)))
+ ((eq 'concat method)
+ (setq result
+ (eudc-add-field-to-records (cons (car field)
+ (mapconcat
+ #'identity
+ (cdr field)
+ "\n"))
+ result)))
+ ((eq 'duplicate method)
+ (setq result
+ (eudc-distribute-field-on-records field result))))))
duplicates)
result)))
@@ -593,19 +581,17 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'."
"Eliminate records that do not contain all ATTRS from RECORDS."
(delq nil
(mapcar
- (function
- (lambda (rec)
- (if (cl-every (lambda (attr)
- (consp (assq attr rec)))
- attrs)
- rec)))
+ (lambda (rec)
+ (if (cl-every (lambda (attr)
+ (consp (assq attr rec)))
+ attrs)
+ rec))
records)))
(defun eudc-add-field-to-records (field records)
"Add FIELD to each individual record in RECORDS and return the resulting list."
- (mapcar (function
- (lambda (r)
- (cons field r)))
+ (mapcar (lambda (r)
+ (cons field r))
records))
(defun eudc-distribute-field-on-records (field records)
@@ -886,10 +872,9 @@ see `eudc-inline-expansion-servers'."
(let ((response-string
(apply #'format
(car eudc-inline-expansion-format)
- (mapcar (function
- (lambda (field)
- (or (cdr (assq field r))
- "")))
+ (mapcar (lambda (field)
+ (or (cdr (assq field r))
+ ""))
(eudc-translate-attribute-list
(cdr eudc-inline-expansion-format))))))
(if (> (length response-string) 0)
@@ -929,16 +914,14 @@ queries the server for the existing fields and displays a corresponding form."
;; Build the list of prompts
(setq prompts (if eudc-use-raw-directory-names
(mapcar #'symbol-name (eudc-translate-attribute-list fields))
- (mapcar (function
- (lambda (field)
- (or (cdr (assq field eudc-user-attribute-names-alist))
- (capitalize (symbol-name field)))))
+ (mapcar (lambda (field)
+ (or (cdr (assq field eudc-user-attribute-names-alist))
+ (capitalize (symbol-name field))))
fields)))
;; Loop over prompt strings to find the longest one
- (mapc (function
- (lambda (prompt)
- (if (> (length prompt) width)
- (setq width (length prompt)))))
+ (mapc (lambda (prompt)
+ (if (> (length prompt) width)
+ (setq width (length prompt))))
prompts)
;; Insert the first widget out of the mapcar to leave the cursor
;; in the first field
@@ -949,14 +932,13 @@ queries the server for the existing fields and displays a corresponding form."
eudc-form-widget-list))
(setq fields (cdr fields))
(setq prompts (cdr prompts))
- (mapc (function
- (lambda (field)
- (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
- (setq widget (widget-create 'editable-field
- :size 15))
- (setq eudc-form-widget-list (cons (cons field widget)
- eudc-form-widget-list))
- (setq prompts (cdr prompts))))
+ (mapc (lambda (field)
+ (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
+ (setq widget (widget-create 'editable-field
+ :size 15))
+ (setq eudc-form-widget-list (cons (cons field widget)
+ eudc-form-widget-list))
+ (setq prompts (cdr prompts)))
fields)
(widget-insert "\n\n")
(widget-create 'push-button
@@ -1070,8 +1052,6 @@ queries the server for the existing fields and displays a corresponding form."
;;{{{ Menus and keymaps
-(require 'easymenu)
-
(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
(defconst eudc-tail-menu
@@ -1118,27 +1098,26 @@ queries the server for the existing fields and displays a corresponding form."
(append
'("Server")
(mapcar
- (function
- (lambda (servspec)
- (let* ((server (car servspec))
- (protocol (cdr servspec))
- (proto-name (symbol-name protocol)))
- (setq command (intern (concat "eudc-set-server-"
- server
- "-"
- proto-name)))
- (if (not (fboundp command))
- (fset command
- `(lambda ()
- (interactive)
- (eudc-set-server ,server (quote ,protocol))
- (message "Selected directory server is now %s (%s)"
- ,server
- ,proto-name))))
- (vector (format "%s (%s)" server proto-name)
- command
- :style 'radio
- :selected `(equal eudc-server ,server)))))
+ (lambda (servspec)
+ (let* ((server (car servspec))
+ (protocol (cdr servspec))
+ (proto-name (symbol-name protocol)))
+ (setq command (intern (concat "eudc-set-server-"
+ server
+ "-"
+ proto-name)))
+ (if (not (fboundp command))
+ (fset command
+ (lambda ()
+ (interactive)
+ (eudc-set-server server protocol)
+ (message "Selected directory server is now %s (%s)"
+ server
+ proto-name))))
+ (vector (format "%s (%s)" server proto-name)
+ command
+ :style 'radio
+ :selected `(equal eudc-server ,server))))
eudc-server-hotlist)
eudc-server-menu))
eudc-tail-menu)))
@@ -1150,7 +1129,9 @@ queries the server for the existing fields and displays a corresponding form."
(cons "Directory Servers"
(easy-menu-create-menu "Directory Servers" (cdr (eudc-menu))))))
-;;; Load time initializations :
+;;}}}
+
+;;{{{ Load time initializations
;; Load the options file
(if (and (not noninteractive)
diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el
index d7da1c8d1f8..e241a1c2fac 100644
--- a/lisp/net/eudcb-bbdb.el
+++ b/lisp/net/eudcb-bbdb.el
@@ -1,4 +1,4 @@
-;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
+;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -34,6 +34,7 @@
;; Make it loadable on systems without bbdb.
(require 'bbdb nil t)
(require 'bbdb-com nil t)
+(require 'seq)
;;{{{ Internal cooking
@@ -87,33 +88,30 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
"Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
(require 'bbdb)
(catch 'unmatch
- (progn
- (dolist (condition eudc-bbdb-current-query)
- (let ((attr (car condition))
- (val (cdr condition))
- (case-fold-search t)
- bbdb-val)
- (or (and (memq attr '(firstname lastname aka company phones
- addresses net))
- (progn
- (setq bbdb-val
- (eval (list (intern (concat "bbdb-record-"
- (symbol-name
- (eudc-bbdb-field
- attr))))
- 'record)))
- (if (listp bbdb-val)
- (if eudc-bbdb-enable-substring-matches
- (eval `(or ,@(mapcar (lambda (subval)
- (string-match val subval))
- bbdb-val)))
- (member (downcase val)
- (mapcar 'downcase bbdb-val)))
+ (dolist (condition eudc-bbdb-current-query)
+ (let ((attr (car condition))
+ (val (cdr condition))
+ (case-fold-search t))
+ (or (and (memq attr '(firstname lastname aka company phones
+ addresses net))
+ (let ((bbdb-val
+ (funcall (intern (concat "bbdb-record-"
+ (symbol-name
+ (eudc-bbdb-field
+ attr))))
+ record)))
+ (if (listp bbdb-val)
(if eudc-bbdb-enable-substring-matches
- (string-match val bbdb-val)
- (string-equal (downcase val) (downcase bbdb-val))))))
- (throw 'unmatch nil))))
- record)))
+ (seq-some (lambda (subval)
+ (string-match val subval))
+ bbdb-val)
+ (member (downcase val)
+ (mapcar #'downcase bbdb-val)))
+ (if eudc-bbdb-enable-substring-matches
+ (string-match val bbdb-val)
+ (string-equal (downcase val) (downcase bbdb-val))))))
+ (throw 'unmatch nil))))
+ record))
;; External.
(declare-function bbdb-phone-location "ext:bbdb" t) ; via bbdb-defstruct
@@ -137,18 +135,17 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
(defun eudc-bbdb-extract-phones (record)
(require 'bbdb)
- (mapcar (function
- (lambda (phone)
- (if eudc-bbdb-use-locations-as-attribute-names
- (cons (intern (if (eudc--using-bbdb-3-or-newer-p)
- (bbdb-phone-label phone)
- (bbdb-phone-location phone)))
- (bbdb-phone-string phone))
- (cons 'phones (format "%s: %s"
- (if (eudc--using-bbdb-3-or-newer-p)
- (bbdb-phone-label phone)
- (bbdb-phone-location phone))
- (bbdb-phone-string phone))))))
+ (mapcar (lambda (phone)
+ (if eudc-bbdb-use-locations-as-attribute-names
+ (cons (intern (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-phone-label phone)
+ (bbdb-phone-location phone)))
+ (bbdb-phone-string phone))
+ (cons 'phones (format "%s: %s"
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-phone-label phone)
+ (bbdb-phone-location phone))
+ (bbdb-phone-string phone)))))
(if (eudc--using-bbdb-3-or-newer-p)
(bbdb-record-phone record)
(bbdb-record-phones record))))
@@ -183,40 +180,34 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'."
(require 'bbdb)
(let ((attrs (or eudc-bbdb-current-return-attributes
'(firstname lastname aka company phones addresses net notes)))
- attr
- eudc-rec
- val)
- (while (prog1
- (setq attr (car attrs))
- (setq attrs (cdr attrs)))
- (cond
- ((eq attr 'phones)
- (setq val (eudc-bbdb-extract-phones record)))
- ((eq attr 'addresses)
- (setq val (eudc-bbdb-extract-addresses record)))
- ((eq attr 'notes)
- (if (eudc--using-bbdb-3-or-newer-p)
- (setq val (bbdb-record-xfield record 'notes))
- (setq val (bbdb-record-notes record))))
- ((memq attr '(firstname lastname aka company net))
- (setq val (eval
- (list (intern
- (concat "bbdb-record-"
- (symbol-name (eudc-bbdb-field attr))))
- 'record))))
- (t
- (error "Unknown BBDB attribute")))
- (cond
- ((or (not val) (equal val ""))) ; do nothing
- ((memq attr '(phones addresses))
- (setq eudc-rec (append val eudc-rec)))
- ((and (listp val)
- (= 1 (length val)))
- (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
- ((> (length val) 0)
- (setq eudc-rec (cons (cons attr val) eudc-rec)))
- (t
- (error "Unexpected attribute value"))))
+ eudc-rec)
+ (dolist (attr attrs)
+ (let ((val
+ (pcase attr
+ ('phones (eudc-bbdb-extract-phones record))
+ ('addresses (eudc-bbdb-extract-addresses record))
+ ('notes
+ (if (eudc--using-bbdb-3-or-newer-p)
+ (bbdb-record-xfield record 'notes)
+ (bbdb-record-notes record)))
+ ((or 'firstname 'lastname 'aka 'company 'net)
+ (funcall (intern
+ (concat "bbdb-record-"
+ (symbol-name (eudc-bbdb-field attr))))
+ record))
+ (_
+ (error "Unknown BBDB attribute")))))
+ (cond
+ ((or (not val) (equal val ""))) ; do nothing
+ ((memq attr '(phones addresses))
+ (setq eudc-rec (append val eudc-rec)))
+ ((and (listp val)
+ (= 1 (length val)))
+ (push (cons attr (car val)) eudc-rec))
+ ((> (length val) 0)
+ (push (cons attr val) eudc-rec))
+ (t
+ (error "Unexpected attribute value")))))
(nreverse eudc-rec)))
@@ -241,23 +232,20 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(while (and records (> (length query-attrs) 0))
(setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
(if (car query-attrs)
- (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
+ ;; BEWARE: `bbdb-search' is a macro!
+ (setq records (eval `(bbdb-search records ,@bbdb-attrs) t)))
(setq query-attrs (cdr query-attrs)))
- (mapc (function
- (lambda (record)
- (setq filtered (eudc-filter-duplicate-attributes record))
- ;; If there were duplicate attributes reverse the order of the
- ;; record so the unique attributes appear first
- (if (> (length filtered) 1)
- (setq filtered (mapcar (function
- (lambda (rec)
- (reverse rec)))
- filtered)))
- (setq result (append result filtered))))
+ (mapc (lambda (record)
+ (setq filtered (eudc-filter-duplicate-attributes record))
+ ;; If there were duplicate attributes reverse the order of the
+ ;; record so the unique attributes appear first
+ (if (> (length filtered) 1)
+ (setq filtered (mapcar #'reverse filtered)))
+ (setq result (append result filtered)))
(delq nil
- (mapcar 'eudc-bbdb-format-record-as-result
+ (mapcar #'eudc-bbdb-format-record-as-result
(delq nil
- (mapcar 'eudc-bbdb-filter-non-matching-record
+ (mapcar #'eudc-bbdb-filter-non-matching-record
records)))))
result))
diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el
index d4c8f93ddf1..0aff276475e 100644
--- a/lisp/net/eudcb-ldap.el
+++ b/lisp/net/eudcb-ldap.el
@@ -1,4 +1,4 @@
-;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
+;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -38,10 +38,10 @@
;;{{{ Internal cooking
-(eval-and-compile
+(defalias 'eudc-ldap-get-host-parameter
(if (fboundp 'ldap-get-host-parameter)
- (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter)
- (defun eudc-ldap-get-host-parameter (host parameter)
+ #'ldap-get-host-parameter
+ (lambda (host parameter)
"Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
(plist-get (cdr (assoc host ldap-host-parameters-alist))
parameter))))
@@ -76,16 +76,15 @@
"Do some cleanup in a RECORD to make it suitable for EUDC."
(declare (obsolete eudc-ldap-cleanup-record-filtering-addresses "25.1"))
(mapcar
- (function
- (lambda (field)
- (cons (intern (downcase (car field)))
- (if (cdr (cdr field))
- (cdr field)
- (car (cdr field))))))
+ (lambda (field)
+ (cons (intern (downcase (car field)))
+ (if (cdr (cdr field))
+ (cdr field)
+ (car (cdr field)))))
record))
(defun eudc-filter-$ (string)
- (mapconcat 'identity (split-string string "\\$") "\n"))
+ (mapconcat #'identity (split-string string "\\$") "\n"))
(defun eudc-ldap-cleanup-record-filtering-addresses (record)
"Clean up RECORD to make it suitable for EUDC.
@@ -105,7 +104,7 @@ multiple addresses."
(value (cdr field)))
(when (and clean-up-addresses
(memq name '(postaladdress registeredaddress)))
- (setq value (mapcar 'eudc-filter-$ value)))
+ (setq value (mapcar #'eudc-filter-$ value)))
(if (eq name 'mail)
(setq mail-addresses (append mail-addresses value))
(push (cons name (if (cdr value)
@@ -127,9 +126,9 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
eudc-server
(if (listp return-attrs)
- (mapcar 'symbol-name return-attrs))))
+ (mapcar #'symbol-name return-attrs))))
final-result)
- (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
+ (setq result (mapcar #'eudc-ldap-cleanup-record-filtering-addresses result))
(if (and eudc-strict-return-matches
return-attrs
@@ -138,10 +137,10 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
;; Apply eudc-duplicate-attribute-handling-method
(if (not (eq 'list eudc-duplicate-attribute-handling-method))
(mapc
- (function (lambda (record)
- (setq final-result
- (append (eudc-filter-duplicate-attributes record)
- final-result))))
+ (lambda (record)
+ (setq final-result
+ (append (eudc-filter-duplicate-attributes record)
+ final-result)))
result))
final-result))
@@ -155,7 +154,7 @@ attribute names are returned. Default to `person'."
(let ((ldap-host-parameters-alist
(list (cons eudc-server
'(scope subtree sizelimit 1)))))
- (mapcar 'eudc-ldap-cleanup-record-filtering-addresses
+ (mapcar #'eudc-ldap-cleanup-record-filtering-addresses
(ldap-search
(eudc-ldap-format-query-as-rfc1558
(list (cons "objectclass"
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index eb7032ac4c8..732881f75a0 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -1,4 +1,4 @@
-;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend
+;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el
new file mode 100644
index 00000000000..18c8958c160
--- /dev/null
+++ b/lisp/net/eudcb-macos-contacts.el
@@ -0,0 +1,123 @@
+;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Alexander Adolf
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This library provides an interface to the macOS Contacts app as
+;; an EUDC data source. It uses AppleScript to interface with the
+;; Contacts app on localhost, so no 3rd party tools are needed.
+
+;;; Usage:
+;; (require 'eudcb-macos-contacts)
+;; (eudc-macos-contacts-set-server "localhost")
+
+;;; Code:
+
+(require 'eudc)
+(require 'executable)
+
+;;{{{ Internal cooking
+
+(defvar eudc-macos-contacts-conversion-alist nil)
+
+;; hook ourselves into the EUDC framework
+(eudc-protocol-set 'eudc-query-function
+ 'eudc-macos-contacts-query-internal
+ 'macos-contacts)
+(eudc-protocol-set 'eudc-list-attributes-function
+ nil
+ 'macos-contacts)
+(eudc-protocol-set 'eudc-macos-contacts-conversion-alist
+ nil
+ 'macos-contacts)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes
+ nil
+ 'macos-contacts)
+
+(defun eudc-macos-contacts-search-helper (str)
+ "Helper function to query the Contacts app via AppleScript.
+Searches for all persons with a case-insensitive substring match
+of STR in any of their name fields (first, middle, or last)."
+ (if (executable-find "osascript")
+ (call-process "osascript" nil t nil
+ "-e"
+ (format "
+set results to {}
+tell application \"Address Book\"
+ set pList to every person whose (name contains \"%s\")
+ repeat with pers in pList
+ repeat with emailAddr in emails of pers
+ set results to results & {name of pers & \":\" & value ¬
+ of emailAddr & \"\n\"}
+ end repeat
+ end repeat
+ get results as text
+end tell" str))
+ (message (concat "[eudc] Error in macOS Contacts backend: "
+ "`osascript' executable not found. "
+ "Is this is a macOS 10.0 or later system?"))))
+
+(defun eudc-macos-contacts-query-internal (query &optional _return-attrs)
+ "Query macOS Contacts with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
+macOS Contacts attribute names.
+RETURN-ATTRS is a list of attributes to return, defaulting to
+`eudc-default-return-attributes'."
+ (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*"))
+ result)
+ (with-current-buffer macos-contacts-buffer
+ (erase-buffer)
+ (dolist (term query)
+ (eudc-macos-contacts-search-helper (cdr term)))
+ (delete-duplicate-lines (point-min) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (equal (line-beginning-position) (line-end-position)))
+ (let* ((args (split-string (buffer-substring
+ (point) (line-end-position))
+ ":"))
+ (name (nth 0 args))
+ (email (nth 1 args)))
+ (setq result (cons `((name . ,name)
+ (email . ,email))
+ result))))
+ (forward-line))
+ result)))
+
+;;}}}
+
+;;{{{ High-level interfaces (interactive functions)
+
+(defun eudc-macos-contacts-set-server (dummy)
+ "Set the EUDC server to macOS Contacts app.
+The server in DUMMY is not actually used, since this backend
+always and implicitly connects to an instance of the Contacts app
+running on the local host."
+ (interactive)
+ (eudc-set-server dummy 'macos-contacts)
+ (message "[eudc] macOS Contacts app server selected"))
+
+;;}}}
+
+(eudc-register-protocol 'macos-contacts)
+
+(provide 'eudcb-macos-contacts)
+
+;;; eudcb-macos-contacts.el ends here
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 26090700cef..eec3ec7ba8b 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -25,14 +25,15 @@
;;; Code:
(require 'cl-lib)
-(require 'format-spec)
+(require 'mm-url)
+(require 'puny)
(require 'shr)
+(require 'text-property-search)
+(require 'thingatpt)
(require 'url)
(require 'url-queue)
-(require 'thingatpt)
-(require 'mm-url)
-(require 'puny)
-(eval-when-compile (require 'subr-x)) ;; for string-trim
+(require 'xdg)
+(eval-when-compile (require 'subr-x))
(defgroup eww nil
"Emacs Web Wowser"
@@ -55,11 +56,31 @@
:group 'eww
:type 'string)
-(defcustom eww-download-directory "~/Downloads/"
- "Directory where files will downloaded."
- :version "24.4"
+(defcustom eww-use-browse-url "\\`mailto:"
+ "eww will use `browse-url' when following links that match this regexp.
+The action to be taken can be further customized via
+`browse-url-handlers'."
+ :version "28.1"
+ :type 'regexp)
+
+(defun erc--download-directory ()
+ "Return the name of the download directory.
+If ~/Downloads/ exists, that will be used, and if not, the
+DOWNLOAD XDG user directory will be returned. If that's
+undefined, ~/Downloads/ is returned anyway."
+ (or (and (file-exists-p "~/Downloads/")
+ "~/Downloads/")
+ (when-let ((dir (xdg-user-dir "DOWNLOAD")))
+ (file-name-as-directory dir))
+ "~/Downloads/"))
+
+(defcustom eww-download-directory 'erc--download-directory
+ "Directory where files will downloaded.
+This should either be a directory name or a function (called with
+no parameters) that returns a directory name."
+ :version "28.1"
:group 'eww
- :type 'directory)
+ :type '(choice directory function))
;;;###autoload
(defcustom eww-suggest-uris
@@ -120,6 +141,15 @@ The string will be passed through `substitute-command-keys'."
:type '(choice (const :tag "Unlimited" nil)
integer))
+(defcustom eww-retrieve-command nil
+ "Command to retrieve an URL via an external program.
+If nil, `url-retrieve' is used to download the data. If non-nil,
+this should be a list where the first item is the program, and
+the rest are the arguments."
+ :version "28.1"
+ :type '(choice (const :tag "Use `url-retrieve'" nil)
+ (repeat string)))
+
(defcustom eww-use-external-browser-for-content-type
"\\`\\(video/\\|audio/\\|application/ogg\\)"
"Always use external browser for specified content-type."
@@ -263,19 +293,40 @@ This list can be customized via `eww-suggest-uris'."
(nreverse uris)))
;;;###autoload
-(defun eww (url &optional arg)
+(defun eww-browse ()
+ "Function to be run to parse command line URLs.
+This is meant to be used for MIME handlers or command line use.
+
+Setting the handler for \"text/x-uri;\" to
+\"emacs -f eww-browse %u\" will then start up Emacs and call eww
+to browse the url.
+
+This can also be used on the command line directly:
+
+ emacs -f eww-browse https://gnu.org
+
+will start Emacs and browse the GNU web site."
+ (interactive)
+ (eww (pop command-line-args-left)))
+
+
+;;;###autoload
+(defun eww (url &optional arg buffer)
"Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'.
If called with a prefix ARG, use a new buffer instead of reusing
-the default EWW buffer."
+the default EWW buffer.
+
+If BUFFER, the data to be rendered is in that buffer. In that
+case, this function doesn't actually fetch URL. BUFFER will be
+killed after rendering."
(interactive
- (let* ((uris (eww-suggested-uris))
- (prompt (concat "Enter URL or keywords"
- (if uris (format " (default %s)" (car uris)) "")
- ": ")))
- (list (read-string prompt nil 'eww-prompt-history uris)
+ (let ((uris (eww-suggested-uris)))
+ (list (read-string (format-prompt "Enter URL or keywords"
+ (and uris (car uris)))
+ nil 'eww-prompt-history uris)
(prefix-numeric-value current-prefix-arg))))
(setq url (eww--dwim-expand-url url))
(pop-to-buffer-same-window
@@ -307,8 +358,39 @@ the default EWW buffer."
(insert (format "Loading %s..." url))
(goto-char (point-min)))
(let ((url-mime-accept-string eww-accept-content-types))
- (url-retrieve url 'eww-render
- (list url nil (current-buffer)))))
+ (if buffer
+ (let ((eww-buffer (current-buffer)))
+ (with-current-buffer buffer
+ (eww-render nil url nil eww-buffer)))
+ (eww-retrieve url #'eww-render
+ (list url nil (current-buffer))))))
+
+(defun eww-retrieve (url callback cbargs)
+ (if (null eww-retrieve-command)
+ (url-retrieve url #'eww-render
+ (list url nil (current-buffer)))
+ (let ((buffer (generate-new-buffer " *eww retrieve*"))
+ (error-buffer (generate-new-buffer " *eww error*")))
+ (with-current-buffer buffer
+ (set-buffer-multibyte nil)
+ (make-process
+ :name "*eww fetch*"
+ :buffer (current-buffer)
+ :stderr error-buffer
+ :command (append eww-retrieve-command (list url))
+ :sentinel (lambda (process _)
+ (unless (process-live-p process)
+ (when (buffer-live-p error-buffer)
+ (when (get-buffer-process error-buffer)
+ (delete-process (get-buffer-process error-buffer) ))
+ (kill-buffer error-buffer))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (insert "Content-type: text/html; charset=utf-8\n\n")
+ (apply #'funcall callback nil cbargs))))))))))
+
+(function-put 'eww 'browse-url-browser-kind 'internal)
(defun eww--dwim-expand-url (url)
(setq url (string-trim url))
@@ -359,7 +441,19 @@ the default EWW buffer."
(eww (concat "file://"
(and (memq system-type '(windows-nt ms-dos))
"/")
- (expand-file-name file))))
+ (expand-file-name file))
+ nil
+ ;; The file name may be a non-local Tramp file. The URL
+ ;; library doesn't understand these file names, so use the
+ ;; normal Emacs machinery to load the file.
+ (with-current-buffer (generate-new-buffer " *eww file*")
+ (set-buffer-multibyte nil)
+ (insert "Content-type: " (or (mailcap-extension-to-mime
+ (url-file-extension file))
+ "application/octet-stream")
+ "\n\n")
+ (insert-file-contents file)
+ (current-buffer))))
;;;###autoload
(defun eww-search-words ()
@@ -373,8 +467,8 @@ for the search engine used."
(let ((region-string (buffer-substring (region-beginning) (region-end))))
(if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string))
(eww region-string)
- (call-interactively 'eww)))
- (call-interactively 'eww)))
+ (call-interactively #'eww)))
+ (call-interactively #'eww)))
(defun eww-open-in-new-buffer ()
"Fetch link at point in a new EWW buffer."
@@ -541,10 +635,10 @@ Currently this means either text/html or application/xhtml+xml."
(goto-char point))
(shr-target-id
(goto-char (point-min))
- (let ((point (next-single-property-change
- (point-min) 'shr-target-id)))
- (when point
- (goto-char point))))
+ (let ((match (text-property-search-forward
+ 'shr-target-id shr-target-id t)))
+ (when match
+ (goto-char (prop-match-beginning match)))))
(t
(goto-char (point-min))
;; Don't leave point inside forms, because the normal eww
@@ -608,31 +702,88 @@ Currently this means either text/html or application/xhtml+xml."
(eww-handle-link dom)
(let ((start (point)))
(shr-tag-a dom)
- (put-text-property start (point)
- 'keymap
- (if (mm-images-in-region-p start (point))
- eww-image-link-keymap
- eww-link-keymap))))
+ (if (dom-attr dom 'href)
+ (put-text-property start (point)
+ 'keymap
+ (if (mm-images-in-region-p start (point))
+ eww-image-link-keymap
+ eww-link-keymap)))))
+
+(defun eww--limit-string-pixelwise (string pixels)
+ (if (not pixels)
+ string
+ (with-temp-buffer
+ (insert string)
+ (if (< (eww--pixel-column) pixels)
+ string
+ ;; Iterate to find appropriate length.
+ (while (and (> (eww--pixel-column) pixels)
+ (not (bobp)))
+ (forward-char -1))
+ ;; Return at least one character.
+ (buffer-substring (point-min) (max (point)
+ (1+ (point-min))))))))
+
+(defun eww--pixel-column ()
+ (if (not (get-buffer-window (current-buffer)))
+ (save-window-excursion
+ ;; Avoid errors if the selected window is a dedicated one,
+ ;; and they just want to insert a document into it.
+ (set-window-dedicated-p nil nil)
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size nil (line-beginning-position) (point))))
+ (car (window-text-pixel-size nil (line-beginning-position) (point)))))
(defun eww-update-header-line-format ()
(setq header-line-format
(and eww-header-line-format
- (let ((title (plist-get eww-data :title))
- (peer (plist-get eww-data :peer)))
- (when (zerop (length title))
- (setq title "[untitled]"))
- ;; This connection has is https.
+ (let ((peer (plist-get eww-data :peer))
+ (url (plist-get eww-data :url))
+ (title (propertize
+ (if (zerop (length (plist-get eww-data :title)))
+ "[untitled]"
+ (plist-get eww-data :title))
+ 'face 'variable-pitch)))
+ ;; This connection is https.
(when peer
- (setq title
- (propertize title 'face
- (if (plist-get peer :warnings)
- 'eww-invalid-certificate
- 'eww-valid-certificate))))
+ (add-face-text-property 0 (length title)
+ (if (plist-get peer :warnings)
+ 'eww-invalid-certificate
+ 'eww-valid-certificate)
+ t title))
+ ;; Limit the length of the title so that the host name
+ ;; of the URL is always visible.
+ (when url
+ (setq url (propertize url 'face 'variable-pitch))
+ (let* ((parsed (url-generic-parse-url url))
+ (host-length (shr-string-pixel-width
+ (propertize
+ (format "%s://%s" (url-type parsed)
+ (url-host parsed))
+ 'face 'variable-pitch)))
+ (width (window-width nil t)))
+ (cond
+ ;; The host bit is wider than the window, so nix
+ ;; the title.
+ ((> (+ host-length (shr-string-pixel-width "xxxxx")) width)
+ (setq title ""))
+ ;; Trim the title.
+ ((> (+ (shr-string-pixel-width (concat title "xx"))
+ host-length)
+ width)
+ (setq title
+ (concat
+ (eww--limit-string-pixelwise
+ title (- width host-length
+ (shr-string-pixel-width
+ (propertize "...: " 'face
+ 'variable-pitch))))
+ (propertize "..." 'face 'variable-pitch)))))))
(replace-regexp-in-string
"%" "%%"
(format-spec
eww-header-line-format
- `((?u . ,(or (plist-get eww-data :url) ""))
+ `((?u . ,(or url ""))
(?t . ,title))))))))
(defun eww-tag-title (dom)
@@ -667,14 +818,19 @@ Currently this means either text/html or application/xhtml+xml."
(declare-function mailcap-view-mime "mailcap" (type))
(defun eww-display-pdf ()
- (let ((data (buffer-substring (point) (point-max))))
- (pop-to-buffer-same-window (get-buffer-create "*eww pdf*"))
- (let ((coding-system-for-write 'raw-text)
- (inhibit-read-only t))
- (erase-buffer)
- (insert data)
- (mailcap-view-mime "application/pdf")))
- (goto-char (point-min)))
+ (let ((buf (current-buffer))
+ (pos (point)))
+ (with-current-buffer (get-buffer-create "*eww pdf*")
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (set-buffer-multibyte nil)
+ (insert-buffer-substring buf pos)
+ (mailcap-view-mime "application/pdf"))
+ (if (zerop (buffer-size))
+ ;; Buffer contents passed to shell command via temporary file.
+ (kill-buffer)
+ (goto-char (point-min))
+ (pop-to-buffer-same-window (current-buffer))))))
(defun eww-setup-buffer ()
(when (or (plist-get eww-data :url)
@@ -699,7 +855,7 @@ Currently this means either text/html or application/xhtml+xml."
(defun eww-view-source ()
"View the HTML source code of the current page."
- (interactive)
+ (interactive nil eww-mode)
(let ((buf (get-buffer-create "*eww-source*"))
(source (plist-get eww-data :source)))
(with-current-buffer buf
@@ -725,7 +881,7 @@ Currently this means either text/html or application/xhtml+xml."
(defun eww-toggle-paragraph-direction ()
"Cycle the paragraph direction between left-to-right, right-to-left and auto."
- (interactive)
+ (interactive nil eww-mode)
(setq bidi-paragraph-direction
(cond ((eq bidi-paragraph-direction 'left-to-right)
nil)
@@ -743,7 +899,7 @@ Currently this means either text/html or application/xhtml+xml."
This command uses heuristics to find the parts of the web page that
contains the main textual portion, leaving out navigation menus and
the like."
- (interactive)
+ (interactive nil eww-mode)
(let* ((old-data eww-data)
(dom (with-temp-buffer
(insert (plist-get old-data :source))
@@ -831,6 +987,7 @@ the like."
(define-key map "F" 'eww-toggle-fonts)
(define-key map "D" 'eww-toggle-paragraph-direction)
(define-key map [(meta C)] 'eww-toggle-colors)
+ (define-key map [(meta I)] 'eww-toggle-images)
(define-key map "b" 'eww-add-bookmark)
(define-key map "B" 'eww-list-bookmarks)
@@ -859,6 +1016,7 @@ the like."
["List cookies" url-cookie-list t]
["Toggle fonts" eww-toggle-fonts t]
["Toggle colors" eww-toggle-colors t]
+ ["Toggle images" eww-toggle-images t]
["Character Encoding" eww-set-character-encoding]
["Toggle Paragraph Direction" eww-toggle-paragraph-direction]))
map))
@@ -882,6 +1040,7 @@ the like."
;;;###autoload
(define-derived-mode eww-mode special-mode "eww"
"Mode for browsing the web."
+ :interactive nil
(setq-local eww-data (list :title ""))
(setq-local browse-url-browser-function #'eww-browse-url)
(add-hook 'after-change-functions #'eww-process-text-input nil t)
@@ -894,9 +1053,16 @@ the like."
;; multi-page isearch support
(setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer)
(setq truncate-lines t)
+ (setq-local thing-at-point-provider-alist
+ (append thing-at-point-provider-alist
+ '((url . eww--url-at-point))))
(buffer-disable-undo)
(setq buffer-read-only t))
+(defun eww--url-at-point ()
+ "`thing-at-point' provider function."
+ (get-text-property (point) 'shr-url))
+
;;;###autoload
(defun eww-browse-url (url &optional new-window)
"Ask the EWW browser to load URL.
@@ -927,7 +1093,7 @@ instead of `browse-url-new-window-flag'."
(defun eww-back-url ()
"Go to the previously displayed page."
- (interactive)
+ (interactive nil eww-mode)
(when (>= eww-history-position (length eww-history))
(user-error "No previous page"))
(eww-save-history)
@@ -936,7 +1102,7 @@ instead of `browse-url-new-window-flag'."
(defun eww-forward-url ()
"Go to the next displayed page."
- (interactive)
+ (interactive nil eww-mode)
(when (zerop eww-history-position)
(user-error "No next page"))
(eww-save-history)
@@ -960,7 +1126,7 @@ instead of `browse-url-new-window-flag'."
"Go to the page marked `next'.
A page is marked `next' if rel=\"next\" appears in a <link>
or <a> tag."
- (interactive)
+ (interactive nil eww-mode)
(if (plist-get eww-data :next)
(eww-browse-url (shr-expand-url (plist-get eww-data :next)
(plist-get eww-data :url)))
@@ -970,7 +1136,7 @@ or <a> tag."
"Go to the page marked `previous'.
A page is marked `previous' if rel=\"previous\" appears in a <link>
or <a> tag."
- (interactive)
+ (interactive nil eww-mode)
(if (plist-get eww-data :previous)
(eww-browse-url (shr-expand-url (plist-get eww-data :previous)
(plist-get eww-data :url)))
@@ -980,7 +1146,7 @@ or <a> tag."
"Go to the page marked `up'.
A page is marked `up' if rel=\"up\" appears in a <link>
or <a> tag."
- (interactive)
+ (interactive nil eww-mode)
(if (plist-get eww-data :up)
(eww-browse-url (shr-expand-url (plist-get eww-data :up)
(plist-get eww-data :url)))
@@ -990,7 +1156,7 @@ or <a> tag."
"Go to the page marked `top'.
A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\"
appears in a <link> or <a> tag."
- (interactive)
+ (interactive nil eww-mode)
(let ((best-url (or (plist-get eww-data :start)
(plist-get eww-data :contents)
(plist-get eww-data :home))))
@@ -1003,7 +1169,7 @@ appears in a <link> or <a> tag."
If LOCAL is non-nil (interactively, the command was invoked with
a prefix argument), don't reload the page from the network, but
just re-display the HTML already fetched."
- (interactive "P")
+ (interactive "P" eww-mode)
(let ((url (plist-get eww-data :url)))
(if local
(if (null (plist-get eww-data :dom))
@@ -1011,7 +1177,7 @@ just re-display the HTML already fetched."
(eww-display-html 'utf-8 url (plist-get eww-data :dom)
(point) (current-buffer)))
(let ((url-mime-accept-string eww-accept-content-types))
- (url-retrieve url 'eww-render
+ (eww-retrieve url #'eww-render
(list url (point) (current-buffer) encode))))))
;; Form support.
@@ -1046,6 +1212,7 @@ just re-display the HTML already fetched."
(define-key map [(control e)] 'eww-end-of-text)
(define-key map [?\t] 'shr-next-link)
(define-key map [?\M-\t] 'shr-previous-link)
+ (define-key map [backtab] 'shr-previous-link)
map))
(defvar eww-textarea-map
@@ -1055,22 +1222,25 @@ just re-display the HTML already fetched."
(define-key map [(control c) (control c)] 'eww-submit)
(define-key map [?\t] 'shr-next-link)
(define-key map [?\M-\t] 'shr-previous-link)
+ (define-key map [backtab] 'shr-previous-link)
map))
(defvar eww-select-map
(let ((map (make-sparse-keymap)))
(define-key map "\r" 'eww-change-select)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'eww-change-select)
(define-key map [(control c) (control c)] 'eww-submit)
map))
(defun eww-beginning-of-text ()
"Move to the start of the input field."
- (interactive)
+ (interactive nil eww-mode)
(goto-char (eww-beginning-of-field)))
(defun eww-end-of-text ()
"Move to the end of the text in the input field."
- (interactive)
+ (interactive nil eww-mode)
(goto-char (eww-end-of-field))
(let ((start (eww-beginning-of-field)))
(while (and (equal (following-char) ? )
@@ -1111,11 +1281,13 @@ just re-display the HTML already fetched."
(defun eww-form-submit (dom)
(let ((start (point))
(value (dom-attr dom 'value)))
- (setq value
- (if (zerop (length value))
- "Submit"
- value))
- (insert value)
+ (if (null value)
+ (shr-generic dom)
+ (insert value))
+ ;; If the contents of the <button>...</button> turns out to be
+ ;; empty, or the value was blank, default to this:
+ (when (= (point) start)
+ (insert "Submit"))
(add-face-text-property start (point) 'eww-form-submit)
(put-text-property start (point) 'eww-form
(list :eww-form eww-form
@@ -1160,7 +1332,7 @@ just re-display the HTML already fetched."
(defun eww-select-file ()
"Change the value of the upload file menu under point."
- (interactive)
+ (interactive nil eww-mode)
(let* ((input (get-text-property (point) 'eww-form)))
(let ((filename
(let ((insert-default-directory t))
@@ -1256,7 +1428,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(defun eww-tag-textarea (dom)
(let ((start (point))
- (value (or (dom-attr dom 'value) ""))
+ (value (or (dom-text dom) ""))
(lines (string-to-number (or (dom-attr dom 'rows) "10")))
(width (string-to-number (or (dom-attr dom 'cols) "10")))
end)
@@ -1325,16 +1497,15 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(options nil)
(start (point))
(max 0))
- (dolist (elem (dom-non-text-children dom))
- (when (eq (dom-tag elem) 'option)
- (when (dom-attr elem 'selected)
- (nconc menu (list :value (dom-attr elem 'value))))
- (let ((display (dom-text elem)))
- (setq max (max max (length display)))
- (push (list 'item
- :value (dom-attr elem 'value)
- :display display)
- options))))
+ (dolist (elem (dom-by-tag dom 'option))
+ (when (dom-attr elem 'selected)
+ (nconc menu (list :value (dom-attr elem 'value))))
+ (let ((display (dom-text elem)))
+ (setq max (max max (length display)))
+ (push (list 'item
+ :value (dom-attr elem 'value)
+ :display display)
+ options)))
(when options
(setq options (nreverse options))
;; If we have no selected values, default to the first value.
@@ -1361,25 +1532,32 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(setq display (plist-get (cdr elem) :display))))
display))
-(defun eww-change-select ()
+(defun eww--form-items (form)
+ (cl-loop for elem in form
+ when (and (consp elem)
+ (eq (car elem) 'item))
+ collect (cdr elem)))
+
+(defun eww-change-select (event)
"Change the value of the select drop-down menu under point."
- (interactive)
- (let* ((input (get-text-property (point) 'eww-form))
- (completion-ignore-case t)
- (options
- (delq nil
- (mapcar (lambda (elem)
- (and (consp elem)
- (eq (car elem) 'item)
- (cons (plist-get (cdr elem) :display)
- (plist-get (cdr elem) :value))))
- input)))
- (display
- (completing-read "Change value: " options nil 'require-match))
- (inhibit-read-only t))
- (plist-put input :value (cdr (assoc-string display options t)))
- (goto-char
- (eww-update-field display))))
+ (interactive
+ (list last-nonmenu-event)
+ eww-mode)
+ (mouse-set-point event)
+ (let ((input (get-text-property (point) 'eww-form)))
+ (popup-menu
+ (cons
+ "Change Value"
+ (mapcar
+ (lambda (elem)
+ (vector (plist-get elem :display)
+ (lambda ()
+ (interactive)
+ (plist-put input :value (plist-get elem :value))
+ (goto-char (eww-update-field (plist-get elem :display))))
+ t))
+ (eww--form-items input)))
+ event)))
(defun eww-update-field (string &optional offset)
(unless offset
@@ -1399,7 +1577,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(defun eww-toggle-checkbox ()
"Toggle the value of the checkbox under point."
- (interactive)
+ (interactive nil eww-mode)
(let* ((input (get-text-property (point) 'eww-form))
(type (plist-get input :type)))
(if (equal type "checkbox")
@@ -1419,9 +1597,9 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(goto-char (car elem))
(if (not (eq (cdr elem) input))
(progn
- (plist-put input :checked nil)
+ (plist-put (cdr elem) :checked nil)
(eww-update-field eww-form-checkbox-symbol))
- (plist-put input :checked t)
+ (plist-put (cdr elem) :checked t)
(eww-update-field eww-form-checkbox-selected-symbol)))))
(forward-char 1)))))
@@ -1469,7 +1647,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(defun eww-submit ()
"Submit the current form."
- (interactive)
+ (interactive nil eww-mode)
(let* ((this-input (get-text-property (point) 'eww-form))
(form (plist-get this-input :eww-form))
values next-submit)
@@ -1483,7 +1661,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(cond
((member (plist-get input :type) '("checkbox" "radio"))
(when (plist-get input :checked)
- (push (cons name (plist-get input :value))
+ (push (cons name (or (plist-get input :value) "on"))
values)))
((equal (plist-get input :type) "file")
(when-let ((file (plist-get input :filename)))
@@ -1556,7 +1734,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
"Browse the current URL with an external browser.
The browser to used is specified by the
`browse-url-secondary-browser-function' variable."
- (interactive)
+ (interactive nil eww-mode)
(funcall browse-url-secondary-browser-function
(or url (plist-get eww-data :url))))
@@ -1566,14 +1744,18 @@ If EXTERNAL is single prefix, browse the URL using
`browse-url-secondary-browser-function'.
If EXTERNAL is double prefix, browse in new buffer."
- (interactive (list current-prefix-arg last-nonmenu-event))
+ (interactive
+ (list current-prefix-arg last-nonmenu-event)
+ eww-mode)
(mouse-set-point mouse-event)
(let ((url (get-text-property (point) 'shr-url)))
(cond
((not url)
(message "No link under point"))
- ((string-match "^mailto:" url)
- (browse-url-mail url))
+ ((string-match-p eww-use-browse-url url)
+ ;; This respects the user options `browse-url-handlers'
+ ;; and `browse-url-mailto-function'.
+ (browse-url url))
((and (consp external) (<= (car external) 4))
(funcall browse-url-secondary-browser-function url)
(shr--blink-link))
@@ -1598,28 +1780,31 @@ Differences in #targets are ignored."
(defun eww-copy-page-url ()
"Copy the URL of the current page into the kill ring."
- (interactive)
+ (interactive nil eww-mode)
(message "%s" (plist-get eww-data :url))
(kill-new (plist-get eww-data :url)))
(defun eww-download ()
"Download URL to `eww-download-directory'.
Use link at point if there is one, else the current page's URL."
- (interactive)
- (access-file eww-download-directory "Download failed")
- (let ((url (or (get-text-property (point) 'shr-url)
- (eww-current-url))))
- (if (not url)
- (message "No URL under point")
- (url-retrieve url 'eww-download-callback (list url)))))
-
-(defun eww-download-callback (status url)
+ (interactive nil eww-mode)
+ (let ((dir (if (stringp eww-download-directory)
+ eww-download-directory
+ (funcall eww-download-directory))))
+ (access-file dir "Download failed")
+ (let ((url (or (get-text-property (point) 'shr-url)
+ (eww-current-url))))
+ (if (not url)
+ (message "No URL under point")
+ (url-retrieve url #'eww-download-callback (list url dir))))))
+
+(defun eww-download-callback (status url dir)
(unless (plist-get status :error)
(let* ((obj (url-generic-parse-url url))
(path (directory-file-name (car (url-path-and-query obj))))
(file (eww-make-unique-file-name
(eww-decode-url-file-name (file-name-nondirectory path))
- eww-download-directory)))
+ dir)))
(goto-char (point-min))
(re-search-forward "\r?\n\r?\n")
(let ((coding-system-for-write 'no-conversion))
@@ -1670,14 +1855,14 @@ Use link at point if there is one, else the current page's URL."
(defun eww-set-character-encoding (charset)
"Set character encoding to CHARSET.
If CHARSET is nil then use UTF-8."
- (interactive "zUse character set (default utf-8): ")
+ (interactive "zUse character set (default utf-8): " eww-mode)
(if (null charset)
(eww-reload nil 'utf-8)
(eww-reload nil charset)))
(defun eww-switch-to-buffer ()
"Prompt for an EWW buffer to display in the selected window."
- (interactive)
+ (interactive nil eww-mode)
(let ((completion-extra-properties
'(:annotation-function (lambda (buf)
(with-current-buffer buf
@@ -1695,7 +1880,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-toggle-fonts ()
"Toggle whether to use monospaced or font-enabled layouts."
- (interactive)
+ (interactive nil eww-mode)
(setq shr-use-fonts (not shr-use-fonts))
(eww-reload)
(message "Proportional fonts are now %s"
@@ -1703,20 +1888,28 @@ If CHARSET is nil then use UTF-8."
(defun eww-toggle-colors ()
"Toggle whether to use HTML-specified colors or not."
- (interactive)
+ (interactive nil eww-mode)
(message "Colors are now %s"
(if (setq shr-use-colors (not shr-use-colors))
"on"
"off"))
(eww-reload))
+(defun eww-toggle-images ()
+ "Toggle whether or not to display images."
+ (interactive nil eww-mode)
+ (setq shr-inhibit-images (not shr-inhibit-images))
+ (eww-reload)
+ (message "Images are now %s"
+ (if shr-inhibit-images "off" "on")))
+
;;; Bookmarks code
(defvar eww-bookmarks nil)
(defun eww-add-bookmark ()
"Bookmark the current page."
- (interactive)
+ (interactive nil eww-mode)
(eww-read-bookmarks)
(dolist (bookmark eww-bookmarks)
(when (equal (plist-get eww-data :url) (plist-get bookmark :url))
@@ -1735,28 +1928,30 @@ If CHARSET is nil then use UTF-8."
(defun eww-write-bookmarks ()
(with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)
- (insert ";; Auto-generated file; don't edit\n")
+ (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n")
(pp eww-bookmarks (current-buffer))))
-(defun eww-read-bookmarks ()
+(defun eww-read-bookmarks (&optional error-out)
+ "Read bookmarks from `eww-bookmarks'.
+If ERROR-OUT, signal user-error if there are no bookmarks."
(let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)))
(setq eww-bookmarks
(unless (zerop (or (file-attribute-size (file-attributes file)) 0))
(with-temp-buffer
(insert-file-contents file)
- (read (current-buffer)))))))
+ (read (current-buffer)))))
+ (when (and error-out (not eww-bookmarks))
+ (user-error "No bookmarks are defined"))))
;;;###autoload
(defun eww-list-bookmarks ()
"Display the bookmarks."
(interactive)
+ (eww-read-bookmarks t)
(pop-to-buffer "*eww bookmarks*")
(eww-bookmark-prepare))
(defun eww-bookmark-prepare ()
- (eww-read-bookmarks)
- (unless eww-bookmarks
- (user-error "No bookmarks are defined"))
(set-buffer (get-buffer-create "*eww bookmarks*"))
(eww-bookmark-mode)
(let* ((width (/ (window-width) 2))
@@ -1778,7 +1973,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-bookmark-kill ()
"Kill the current bookmark."
- (interactive)
+ (interactive nil eww-bookmark-mode)
(let* ((start (line-beginning-position))
(bookmark (get-text-property start 'eww-bookmark))
(inhibit-read-only t))
@@ -1792,7 +1987,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-bookmark-yank ()
"Yank a previously killed bookmark to the current line."
- (interactive)
+ (interactive nil eww-bookmark-mode)
(unless eww-bookmark-kill-ring
(user-error "No previously killed bookmark"))
(beginning-of-line)
@@ -1810,7 +2005,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-bookmark-browse ()
"Browse the bookmark under point in eww."
- (interactive)
+ (interactive nil eww-bookmark-mode)
(let ((bookmark (get-text-property (line-beginning-position) 'eww-bookmark)))
(unless bookmark
(user-error "No bookmark on the current line"))
@@ -1819,11 +2014,12 @@ If CHARSET is nil then use UTF-8."
(defun eww-next-bookmark ()
"Go to the next bookmark in the list."
- (interactive)
+ (interactive nil eww-bookmark-mode)
(let ((first nil)
bookmark)
(unless (get-buffer "*eww bookmarks*")
(setq first t)
+ (eww-read-bookmarks t)
(eww-bookmark-prepare))
(with-current-buffer (get-buffer "*eww bookmarks*")
(when (and (not first)
@@ -1837,11 +2033,12 @@ If CHARSET is nil then use UTF-8."
(defun eww-previous-bookmark ()
"Go to the previous bookmark in the list."
- (interactive)
+ (interactive nil eww-bookmark-mode)
(let ((first nil)
bookmark)
(unless (get-buffer "*eww bookmarks*")
(setq first t)
+ (eww-read-bookmarks t)
(eww-bookmark-prepare))
(with-current-buffer (get-buffer "*eww bookmarks*")
(if first
@@ -1879,6 +2076,7 @@ If CHARSET is nil then use UTF-8."
"Mode for listing bookmarks.
\\{eww-bookmark-mode-map}"
+ :interactive nil
(buffer-disable-undo)
(setq truncate-lines t))
@@ -1927,7 +2125,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-history-browse ()
"Browse the history under point in eww."
- (interactive)
+ (interactive nil eww-history-mode)
(let ((history (get-text-property (line-beginning-position) 'eww-history)))
(unless history
(error "No history on the current line"))
@@ -1955,6 +2153,7 @@ If CHARSET is nil then use UTF-8."
"Mode for listing eww-histories.
\\{eww-history-mode-map}"
+ :interactive nil
(buffer-disable-undo)
(setq truncate-lines t))
@@ -2009,7 +2208,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-buffer-select ()
"Switch to eww buffer."
- (interactive)
+ (interactive nil eww-buffers-mode)
(let ((buffer (get-text-property (line-beginning-position)
'eww-buffer)))
(unless buffer
@@ -2029,7 +2228,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-buffer-show-next ()
"Move to next eww buffer in the list and display it."
- (interactive)
+ (interactive nil eww-buffers-mode)
(forward-line)
(when (eobp)
(goto-char (point-min)))
@@ -2037,7 +2236,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-buffer-show-previous ()
"Move to previous eww buffer in the list and display it."
- (interactive)
+ (interactive nil eww-buffers-mode)
(beginning-of-line)
(when (bobp)
(goto-char (point-max)))
@@ -2046,7 +2245,7 @@ If CHARSET is nil then use UTF-8."
(defun eww-buffer-kill ()
"Kill buffer from eww list."
- (interactive)
+ (interactive nil eww-buffers-mode)
(let* ((start (line-beginning-position))
(buffer (get-text-property start 'eww-buffer))
(inhibit-read-only t))
@@ -2080,6 +2279,7 @@ If CHARSET is nil then use UTF-8."
"Mode for listing buffers.
\\{eww-buffers-mode-map}"
+ :interactive nil
(buffer-disable-undo)
(setq truncate-lines t))
@@ -2124,12 +2324,12 @@ entries (if any) will be removed from the list.
Only the properties listed in `eww-desktop-data-save' are included.
Generally, the list should not include the (usually overly large)
:dom, :source and :text properties."
- (let ((history (mapcar 'eww-desktop-data-1
- (cons eww-data eww-history))))
- (list :history (if eww-desktop-remove-duplicates
- (cl-remove-duplicates
- history :test 'eww-desktop-history-duplicate)
- history))))
+ (let ((history (mapcar #'eww-desktop-data-1
+ (cons eww-data eww-history))))
+ (list :history (if eww-desktop-remove-duplicates
+ (cl-remove-duplicates
+ history :test #'eww-desktop-history-duplicate)
+ history))))
(defun eww-restore-desktop (file-name buffer-name misc-data)
"Restore an eww buffer from its desktop file record.
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index bc377ff33af..43dd9dc15cd 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -1,10 +1,10 @@
-;;; gnutls.el --- Support SSL/TLS connections through GnuTLS
+;;; gnutls.el --- Support SSL/TLS connections through GnuTLS -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 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/)
+;; Originally-By: Simon Josefsson (See https://josefsson.org/emacs-security/)
;; Thanks-To: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -59,7 +59,6 @@ general, Emacs network security is handled by the Network
Security Manager (NSM), and the default value of nil delegates
the job of checking the connection security to the NSM.
See Info node `(emacs) Network Security'."
- :group 'gnutls
:type '(choice (const nil)
string))
@@ -91,7 +90,6 @@ checks are performed at the gnutls level. Instead the checks are
performed via `open-network-stream' at a higher level by the
Network Security Manager. See Info node `(emacs) Network
Security'."
- :group 'gnutls
:version "24.4"
:type '(choice
(const t)
@@ -118,7 +116,6 @@ Security'."
If a file path contains glob wildcards, they will be expanded.
The files may be in PEM or DER format, as per the GnuTLS documentation.
The files may not exist, in which case they will be ignored."
- :group 'gnutls
:type '(choice (function :tag "Function to produce list of bundle filenames")
(repeat (file :tag "Bundle filename"))))
@@ -139,7 +136,6 @@ network security is handled at a higher level via
node `(emacs) Network Security'."
:type '(choice (const :tag "Use default value" nil)
(integer :tag "Number of bits" 2048))
- :group 'gnutls
:version "27.1")
(defcustom gnutls-crlfiles
@@ -150,7 +146,6 @@ node `(emacs) Network Security'."
If a file path contains glob wildcards, they will be expanded.
The files may be in PEM or DER format, as per the GnuTLS documentation.
The files may not exist, in which case they will be ignored."
- :group 'gnutls
:type '(choice (function :tag "Function to produce list of CRL filenames")
(repeat (file :tag "CRL filename")))
:version "27.1")
@@ -170,8 +165,9 @@ Third arg HOST is the name of the host to connect to, or its IP address.
Fourth arg SERVICE is the name of the service desired, or an integer
specifying a port number to connect to.
Fifth arg PARAMETERS is an optional list of keyword/value pairs.
-Only :client-certificate and :nowait keywords are recognized, and
-have the same meaning as for `open-network-stream'.
+Only :client-certificate, :nowait, and :coding keywords are
+recognized, and have the same meaning as for
+`open-network-stream'.
For historical reasons PARAMETERS can also be a symbol, which is
interpreted the same as passing a list containing :nowait and the
value of that symbol.
@@ -209,7 +205,8 @@ trust and key files, and priority string."
(gnutls-boot-parameters
:type 'gnutls-x509pki
:keylist keylist
- :hostname (puny-encode-domain host)))))))
+ :hostname (puny-encode-domain host))))
+ :coding (plist-get parameters :coding))))
(if nowait
process
(gnutls-negotiate :process process
@@ -339,15 +336,18 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
- (cadr (cl-find-if #'(lambda (x)
- (string-match (car x) hostname))
+ (cadr (cl-find-if (lambda (x)
+ (string-match (car x) hostname))
gnutls-verify-error)))
;; else it's nil
(t nil))))
(min-prime-bits (or min-prime-bits gnutls-min-prime-bits)))
- (when verify-hostname-error
- (push :hostname verify-error))
+ ;; Only add :hostname if `verify-error' is not t, since t
+ ;; means "include :hostname" Bug#38602.
+ (and verify-hostname-error
+ (not (eq verify-error t))
+ (push :hostname verify-error))
`(:priority ,priority-string
:hostname ,hostname
diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el
index 38b91ae3cc9..8992ef736a6 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -1,4 +1,4 @@
-;;; goto-addr.el --- click to browse URL or to send to e-mail address
+;;; goto-addr.el --- click to browse URL or to send to e-mail address -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2000-2021 Free Software Foundation, Inc.
@@ -73,19 +73,16 @@
(defcustom goto-address-fontify-p t
"Non-nil means URLs and e-mail addresses in buffer are fontified.
But only if `goto-address-highlight-p' is also non-nil."
- :type 'boolean
- :group 'goto-address)
+ :type 'boolean)
(defcustom goto-address-highlight-p t
"Non-nil means URLs and e-mail addresses in buffer are highlighted."
- :type 'boolean
- :group 'goto-address)
+ :type 'boolean)
(defcustom goto-address-fontify-maximum-size 30000
"Maximum size of file in which to fontify and/or highlight URLs.
A value of t means there is no limit--fontify regardless of the size."
- :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t))
- :group 'goto-address)
+ :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t)))
(defvar goto-address-mail-regexp
;; Actually pretty much any char could appear in the username part. -stef
@@ -122,30 +119,26 @@ will have no effect.")
(defvar goto-address-highlight-keymap
(let ((m (make-sparse-keymap)))
- (define-key m (kbd "<mouse-2>") 'goto-address-at-point)
- (define-key m (kbd "C-c RET") 'goto-address-at-point)
+ (define-key m (kbd "<mouse-2>") #'goto-address-at-point)
+ (define-key m (kbd "C-c RET") #'goto-address-at-point)
m)
"Keymap to hold goto-addr's mouse key defs under highlighted URLs.")
(defcustom goto-address-url-face 'link
"Face to use for URLs."
- :type 'face
- :group 'goto-address)
+ :type 'face)
(defcustom goto-address-url-mouse-face 'highlight
"Face to use for URLs when the mouse is on them."
- :type 'face
- :group 'goto-address)
+ :type 'face)
(defcustom goto-address-mail-face 'italic
"Face to use for e-mail addresses."
- :type 'face
- :group 'goto-address)
+ :type 'face)
(defcustom goto-address-mail-mouse-face 'secondary-selection
"Face to use for e-mail addresses when the mouse is on them."
- :type 'face
- :group 'goto-address)
+ :type 'face)
(defun goto-address-unfontify (start end)
"Remove `goto-address' fontification from the given region."
@@ -270,9 +263,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
;;;###autoload
(define-minor-mode goto-address-mode
"Minor mode to buttonize URLs and e-mail addresses in the current buffer."
- nil
- ""
- nil
+ :lighter ""
(if goto-address-mode
(jit-lock-register #'goto-address-fontify-region)
(jit-lock-unregister #'goto-address-fontify-region)
@@ -280,12 +271,19 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
(widen)
(goto-address-unfontify (point-min) (point-max)))))
+(defun goto-addr-mode--turn-on ()
+ (when (not goto-address-mode)
+ (goto-address-mode 1)))
+
+;;;###autoload
+(define-globalized-minor-mode global-goto-address-mode
+ goto-address-mode goto-addr-mode--turn-on
+ :version "28.1")
+
;;;###autoload
(define-minor-mode goto-address-prog-mode
"Like `goto-address-mode', but only for comments and strings."
- nil
- ""
- nil
+ :lighter ""
(if goto-address-prog-mode
(jit-lock-register #'goto-address-fontify-region)
(jit-lock-unregister #'goto-address-fontify-region)
diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el
index 0946048dd84..5ea8839699d 100644
--- a/lisp/net/hmac-def.el
+++ b/lisp/net/hmac-def.el
@@ -1,4 +1,4 @@
-;;; hmac-def.el --- A macro for defining HMAC functions.
+;;; hmac-def.el --- A macro for defining HMAC functions. -*- lexical-binding: t -*-
;; Copyright (C) 1999, 2001, 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el
index 683b97660e0..85a8c51de23 100644
--- a/lisp/net/hmac-md5.el
+++ b/lisp/net/hmac-md5.el
@@ -1,4 +1,4 @@
-;;; hmac-md5.el --- Compute HMAC-MD5.
+;;; hmac-md5.el --- Compute HMAC-MD5. -*- lexical-binding:t -*-
;; Copyright (C) 1999, 2001, 2007-2021 Free Software Foundation, Inc.
@@ -22,42 +22,8 @@
;;; Commentary:
-;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
-;;
-;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
-;; => "9294727a3638bb1c13f48ef8158bfc9d"
-;;
-;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
-;; => "750c783e6ab0b503eaa86e310a5db738"
-;;
-;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
-;; => "56be34521d144c88dbb8c733f0e8b3f6"
-;;
-;; (encode-hex-string
-;; (hmac-md5
-;; (make-string 50 ?\xcd)
-;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
-;; => "697eaf0aca3a3aea3a75164746ffaa79"
-;;
-;; (encode-hex-string
-;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
-;; => "56461ef2342edc00f9bab995690efd4c"
-;;
-;; (encode-hex-string
-;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
-;; => "56461ef2342edc00f9bab995"
-;;
-;; (encode-hex-string
-;; (hmac-md5
-;; "Test Using Larger Than Block-Size Key - Hash Key First"
-;; (make-string 80 ?\xaa)))
-;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd"
-;;
-;; (encode-hex-string
-;; (hmac-md5
-;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
-;; (make-string 80 ?\xaa)))
-;; => "6f630fad67cda0ee1fb1f562db3aa53e"
+;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1",
+;; moved to lisp/test/net/hmac-md5-tests.el
;;; Code:
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index 5eedb7da3f8..6ca76f1f994 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -134,9 +134,9 @@
;;
;;; Code:
+;;; Dependencies
(eval-when-compile (require 'cl-lib))
-(require 'format-spec)
(require 'utf7)
(require 'rfc2104)
;; Hmm... digest-md5 is not part of Emacs.
@@ -146,7 +146,7 @@
(declare-function digest-md5-digest-uri "ext:digest-md5")
(declare-function digest-md5-challenge "ext:digest-md5")
-;; User variables.
+;;; User variables
(defgroup imap nil
"Low-level IMAP issues."
@@ -160,7 +160,6 @@
%l with the value of `imap-default-user'. The program should accept
IMAP commands on stdin and return responses to stdout. Each entry in
the list is tried until a successful connection is made."
- :group 'imap
:type '(repeat string))
(defcustom imap-gssapi-program (list
@@ -173,7 +172,6 @@ the list is tried until a successful connection is made."
%l with the value of `imap-default-user'. The program should accept
IMAP commands on stdin and return responses to stdout. Each entry in
the list is tried until a successful connection is made."
- :group 'imap
:type '(repeat string))
(defcustom imap-shell-program '("ssh %s imapd"
@@ -186,11 +184,10 @@ number on server, %g with `imap-shell-host', and %l with
`imap-default-user'. The program should read IMAP commands from stdin
and write IMAP response to stdout. Each entry in the list is tried
until a successful connection is made."
- :group 'imap
:type '(repeat string))
(defcustom imap-process-connection-type nil
- "Value for `process-connection-type' to use for Kerberos4, GSSAPI, shell, 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
@@ -198,7 +195,6 @@ system has no ptys or if all ptys are busy: then a pipe is used
in any case. The value takes effect when an IMAP server is
opened; changing it after that has no effect."
:version "22.1"
- :group 'imap
:type 'boolean)
(defcustom imap-use-utf7 t
@@ -206,7 +202,6 @@ opened; changing it after that has no effect."
Since the UTF7 decoding currently only decodes into ISO-8859-1
characters, you may disable this decoding if you need to access UTF7
encoded mailboxes which doesn't translate into ISO-8859-1."
- :group 'imap
:type 'boolean)
(defcustom imap-log nil
@@ -217,7 +212,6 @@ It is not written to disk, however. Do not enable this
variable unless you are comfortable with that.
See also `imap-debug'."
- :group 'imap
:type 'boolean)
(defcustom imap-debug nil
@@ -232,17 +226,14 @@ variable unless you are comfortable with that.
This variable only takes effect when loading the `imap' library.
See also `imap-log'."
- :group 'imap
:type 'boolean)
(defcustom imap-shell-host "gateway"
"Hostname of rlogin proxy."
- :group 'imap
:type 'string)
(defcustom imap-default-user (user-login-name)
"Default username to use."
- :group 'imap
:type 'string)
(defcustom imap-read-timeout (if (memq system-type '(windows-nt cygwin))
@@ -250,15 +241,13 @@ See also `imap-log'."
0.1)
"How long to wait between checking for the end of output.
Shorter values mean quicker response, but is more CPU intensive."
- :type 'number
- :group 'imap)
+ :type 'number)
(defcustom imap-store-password nil
"If non-nil, store session password without prompting."
- :group 'imap
:type 'boolean)
-;; Various variables.
+;;; Various variables
(defvar imap-fetch-data-hook nil
"Hooks called after receiving each FETCH response.")
@@ -317,7 +306,9 @@ the value of this variable will be bound to a certain value to which
an application program that uses this module specifies on a per-server
basis.")
-;; Internal constants. Change these and die.
+;;; Internal constants
+
+;; Change these and die.
(defconst imap-default-port 143)
(defconst imap-default-ssl-port 993)
@@ -349,7 +340,7 @@ basis.")
(defconst imap-log-buffer "*imap-log*")
(defconst imap-debug-buffer "*imap-debug*")
-;; Internal variables.
+;;; Internal variables
(defvar imap-stream nil)
(defvar imap-auth nil)
@@ -438,7 +429,7 @@ This variable is set to t automatically per server if the
canonical form fails.")
-;; Utility functions:
+;;; Utility functions
(defun imap-remassoc (key alist)
"Delete by side effect any elements of ALIST whose car is `equal' to KEY.
@@ -490,7 +481,8 @@ sure of changing the value of `foo'."
(nth 3 (car imap-failed-tags))))
-;; Server functions; stream stuff:
+;;; Server functions
+;;;; Stream functions
(defun imap-log (string-or-buffer)
(when imap-log
@@ -517,12 +509,9 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(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 imap-default-user))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user)))))
response)
(when process
(with-current-buffer buffer
@@ -583,12 +572,9 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(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 imap-default-user))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user)))))
response)
(when process
(with-current-buffer buffer
@@ -701,13 +687,10 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(process (start-process
name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?g imap-shell-host
- ?p (number-to-string port)
- ?l imap-default-user)))))
+ (format-spec cmd `((?s . ,server)
+ (?g . ,imap-shell-host)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user))))))
(when process
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
@@ -743,9 +726,9 @@ sure of changing the value of `foo'."
:end-of-command "\r\n"
:success "^1 OK "
:starttls-function
- #'(lambda (capabilities)
- (when (string-match-p "STARTTLS" capabilities)
- "1 STARTTLS\r\n"))))
+ (lambda (capabilities)
+ (when (string-match-p "STARTTLS" capabilities)
+ "1 STARTTLS\r\n"))))
done)
(when process
(imap-log buffer)
@@ -757,7 +740,7 @@ sure of changing the value of `foo'."
(message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
done))
-;; Server functions; authenticator stuff:
+;;;; Authenticator functions
(defun imap-interactive-login (buffer loginfunc)
"Login to server in BUFFER.
@@ -881,7 +864,7 @@ t if it successfully authenticates, nil otherwise."
(concat "LOGIN anonymous \"" (concat (user-login-name) "@"
(system-name)) "\"")))))
-;;; Compiler directives.
+;;; Compiler directives
(defvar imap-sasl-client)
(defvar imap-sasl-step)
@@ -979,7 +962,7 @@ t if it successfully authenticates, nil otherwise."
(imap-send-command-1 "")
(imap-ok-p (imap-wait-for-tag tag)))))))
-;; Server functions:
+;;; Server functions
(defun imap-open-1 (buffer)
(with-current-buffer buffer
@@ -993,8 +976,8 @@ t if it successfully authenticates, nil otherwise."
"imap" buffer imap-server imap-port)
((error quit) nil)))
(when imap-process
- (set-process-filter imap-process 'imap-arrival-filter)
- (set-process-sentinel imap-process 'imap-sentinel)
+ (set-process-filter imap-process #'imap-arrival-filter)
+ (set-process-sentinel imap-process #'imap-sentinel)
(while (and (eq imap-state 'initial)
(memq (process-status imap-process) '(open run)))
(message "Waiting for response from %s..." imap-server)
@@ -1018,7 +1001,7 @@ necessary. If nil, the buffer name is generated."
(with-current-buffer (get-buffer-create buffer)
(if (imap-opened buffer)
(imap-close buffer))
- (mapc 'make-local-variable imap-local-variables)
+ (mapc #'make-local-variable imap-local-variables)
(set-buffer-multibyte nil)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
@@ -1039,9 +1022,8 @@ necessary. If nil, the buffer name is generated."
(when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
;; Stream changed?
(if (not (eq imap-default-stream stream))
- (with-current-buffer (get-buffer-create
- (generate-new-buffer-name " *temp*"))
- (mapc 'make-local-variable imap-local-variables)
+ (with-current-buffer (generate-new-buffer " *temp*")
+ (mapc #'make-local-variable imap-local-variables)
(set-buffer-multibyte nil)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
@@ -1085,7 +1067,6 @@ necessary. If nil, the buffer name is generated."
"If non-nil, check if IMAP is open.
See the function `imap-ping-server'."
:version "23.1" ;; No Gnus
- :group 'imap
:type 'boolean)
(defun imap-opened (&optional buffer)
@@ -1238,7 +1219,7 @@ If BUFFER is nil, the current buffer is assumed."
(imap-send-command-wait "LOGOUT" buffer)))
-;; Mailbox functions:
+;;; Mailbox functions
(defun imap-mailbox-put (propname value &optional mailbox buffer)
(with-current-buffer (or buffer (current-buffer))
@@ -1353,16 +1334,16 @@ If BUFFER is nil the current buffer is assumed."
(when imap-current-mailbox
(if asynch
(imap-add-callback (imap-send-command "CLOSE")
- `(lambda (tag status)
- (message "IMAP mailbox `%s' closed... %s"
- imap-current-mailbox status)
- (when (eq ,imap-current-mailbox
- imap-current-mailbox)
- ;; Don't wipe out data if another mailbox
- ;; was selected...
- (setq imap-current-mailbox nil
- imap-message-data nil
- imap-state 'auth))))
+ (let ((cmb imap-current-mailbox))
+ (lambda (_tag status)
+ (message "IMAP mailbox `%s' closed... %s"
+ imap-current-mailbox status)
+ (when (eq cmb imap-current-mailbox)
+ ;; Don't wipe out data if another mailbox
+ ;; was selected...
+ (setq imap-current-mailbox nil
+ imap-message-data nil
+ imap-state 'auth)))))
(when (imap-ok-p (imap-send-command-wait "CLOSE"))
(setq imap-current-mailbox nil
imap-message-data nil
@@ -1530,7 +1511,7 @@ or `unseen'. The IMAP command tag is returned."
identifier))))))
-;; Message functions:
+;;; Message functions
(defun imap-current-message (&optional buffer)
(with-current-buffer (or buffer (current-buffer))
@@ -1732,8 +1713,7 @@ See `imap-enable-exchange-bug-workaround'."
(string-match "The specified message set is invalid"
(cadr data)))
(with-current-buffer (or buffer (current-buffer))
- (set (make-local-variable 'imap-enable-exchange-bug-workaround)
- t)
+ (setq-local imap-enable-exchange-bug-workaround t)
(imap-fetch (cdr uids) props receive nouidfetch))
(signal (car data) (cdr data))))))
@@ -1748,8 +1728,8 @@ See `imap-enable-exchange-bug-workaround'."
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
- (apply 'max (imap-message-map
- (lambda (uid _prop) uid) 'UID))))
+ (apply #'max (imap-message-map
+ (lambda (uid _prop) uid) 'UID))))
(if old-mailbox
(imap-mailbox-select old-mailbox (eq state 'examine))
(imap-mailbox-unselect)))))))
@@ -1794,7 +1774,7 @@ first element. The rest of list contains the saved articles' UIDs."
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
- (apply 'max (imap-message-map
+ (apply #'max (imap-message-map
(lambda (uid _prop) uid) 'UID))))
(if old-mailbox
(imap-mailbox-select old-mailbox (eq state 'examine))
@@ -1828,7 +1808,7 @@ on failure."
(numberp (nth 9 body)))
(nth 9 body))
(t 0))
- (apply '+ (mapcar 'imap-body-lines body)))
+ (apply #'+ (mapcar #'imap-body-lines body)))
0))
(defun imap-envelope-from (from)
@@ -1842,7 +1822,7 @@ on failure."
(if (aref from 0) ">"))))
-;; Internal functions.
+;;; Internal functions
(defun imap-add-callback (tag func)
(setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
@@ -1979,7 +1959,7 @@ Return nil if no complete line has arrived."
(delete-region (point-min) (point-max)))))))))
-;; Imap parser.
+;;; Imap parser
(defsubst imap-forward ()
(or (eobp) (forward-char)))
@@ -2432,7 +2412,7 @@ Return nil if no complete line has arrived."
(buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
(if (eq (char-before) ? )
(prog1
- (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
+ (mapconcat #'identity (cons section (imap-parse-header-list)) " ")
(search-forward "]" nil t))
section)))
@@ -2860,6 +2840,8 @@ Return nil if no complete line has arrived."
(imap-forward)
(nreverse body)))))
+;;; Debug
+
(when imap-debug ; (untrace-all)
(require 'trace)
(buffer-disable-undo (get-buffer-create imap-debug-buffer))
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 1a99f8f2a4f..7997bf3c90b 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -1,4 +1,4 @@
-;;; ldap.el --- client interface to LDAP for Emacs
+;;; ldap.el --- client interface to LDAP for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -29,11 +29,10 @@
;; `ldapsearch' to actually perform the searches. That program can be
;; found in all LDAP developer kits such as:
;; - UM-LDAP 3.3 (http://www.umich.edu/~dirsvcs/ldap/)
-;; - OpenLDAP (http://www.openldap.org/)
+;; - OpenLDAP (https://www.openldap.org/)
;;; Code:
-(require 'custom)
(require 'password-cache)
(autoload 'auth-source-search "auth-source")
@@ -419,12 +418,12 @@ RFC2798 Section 9.1.1")
(encode-coding-string str ldap-coding-system))
(defun ldap-decode-address (str)
- (mapconcat 'ldap-decode-string
+ (mapconcat #'ldap-decode-string
(split-string str "\\$")
"\n"))
(defun ldap-encode-address (str)
- (mapconcat 'ldap-encode-string
+ (mapconcat #'ldap-encode-string
(split-string str "\n")
"$"))
@@ -602,7 +601,7 @@ an alist of attribute/value pairs."
(sizelimit (plist-get search-plist 'sizelimit))
(withdn (plist-get search-plist 'withdn))
(numres 0)
- arglist dn name value record result proc)
+ arglist dn name value record result)
(if (or (null filter)
(equal "" filter))
(error "No search filter"))
@@ -672,7 +671,7 @@ an alist of attribute/value pairs."
" bind distinguished name (binddn)"))
(error "Failed ldapsearch invocation: %s \"%s\""
ldap-ldapsearch-prog
- (mapconcat 'identity proc-args "\" \""))))))
+ (mapconcat #'identity proc-args "\" \""))))))
(apply #'call-process ldap-ldapsearch-prog
;; Ignore stderr, which can corrupt results
nil (list buf nil) nil
@@ -727,7 +726,7 @@ an alist of attribute/value pairs."
(setq record nil)
(skip-chars-forward " \t\n")
(message "Parsing results... %d" numres)
- (1+ numres))
+ (setq numres (1+ numres)))
(message "Parsing results... done")
(nreverse result)))))
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index 3bda83c1cae..aeeb9bd8d3b 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -29,6 +29,7 @@
;;; Code:
+(require 'cl-lib)
(autoload 'mail-header-parse-content-type "mail-parse")
(defgroup mailcap nil
@@ -174,11 +175,11 @@ is consulted."
(type . "application/zip")
("copiousoutput"))
("pdf"
- (viewer . pdf-view-mode)
+ (viewer . doc-view-mode)
(type . "application/pdf")
(test . window-system))
("pdf"
- (viewer . doc-view-mode)
+ (viewer . pdf-view-mode)
(type . "application/pdf")
(test . window-system))
("pdf"
@@ -268,11 +269,6 @@ is consulted."
(viewer . "display %s")
(type . "image/*")
(test . (eq window-system 'x))
- ("needsx11"))
- (".*"
- (viewer . "ee %s")
- (type . "image/*")
- (test . (eq window-system 'x))
("needsx11")))
("text"
("plain"
@@ -334,9 +330,16 @@ Content-Type header as argument to return a boolean value for the
validity. Otherwise, if it is a non-function Lisp symbol or list
whose car is a symbol, it is `eval'uated to yield the validity. If it
is a string or list of strings, it represents a shell command to run
-to return a true or false shell value for the validity.")
+to return a true or false shell value for the validity.
+
+The last matching entry in this structure takes precedence over
+preceding entries.")
(put 'mailcap-mime-data 'risky-local-variable t)
+(defvar mailcap--computed-mime-data nil
+ "Computed version of the mailcap data incorporating all sources.
+Same format as `mailcap-mime-data'.")
+
(defcustom mailcap-download-directory nil
"Directory to which `mailcap-save-binary-file' downloads files by default.
nil means your home directory."
@@ -383,8 +386,7 @@ Gnus might fail to display all of it.")
(when
(save-window-excursion
(delete-other-windows)
- (let ((buffer (get-buffer-create (generate-new-buffer-name
- "*Warning*"))))
+ (let ((buffer (generate-new-buffer "*Warning*")))
(unwind-protect
(with-current-buffer buffer
(insert (substitute-command-keys
@@ -422,7 +424,13 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
(when (or (not mailcap-parsed-p)
force)
;; Clear out all old data.
- (setq mailcap-mime-data nil)
+ (setq mailcap--computed-mime-data nil)
+ ;; Add the Emacs-distributed defaults (which will be used as
+ ;; fallbacks). Do it this way instead of just copying the list,
+ ;; since entries are destructively modified.
+ (cl-loop for (major . minors) in mailcap-mime-data
+ do (cl-loop for (minor . entry) in minors
+ do (mailcap-add-mailcap-entry major minor entry)))
(cond
(path nil)
((getenv "MAILCAPS")
@@ -709,10 +717,13 @@ to supply to the test."
(push (list otest result) mailcap-viewer-test-cache)
result))))
-(defun mailcap-add-mailcap-entry (major minor info)
- (let ((old-major (assoc major mailcap-mime-data)))
+(defun mailcap-add-mailcap-entry (major minor info &optional storage)
+ (let* ((storage (or storage 'mailcap--computed-mime-data))
+ (old-major (assoc major (symbol-value storage))))
(if (null old-major) ; New major area
- (push (cons major (list (cons minor info))) mailcap-mime-data)
+ (set storage
+ (cons (cons major (list (cons minor info)))
+ (symbol-value storage)))
(let ((cur-minor (assoc minor old-major)))
(cond
((or (null cur-minor) ; New minor area, or
@@ -736,11 +747,15 @@ If TEST is not given, it defaults to t."
(when (or (not (car tl))
(not (cadr tl)))
(error "%s is not a valid MIME type" type))
- (mailcap-add-mailcap-entry
- (car tl) (cadr tl)
- `((viewer . ,viewer)
- (test . ,(if test test t))
- (type . ,type)))))
+ (let ((entry
+ `((viewer . ,viewer)
+ (test . ,(if test test t))
+ (type . ,type))))
+ ;; Store it.
+ (mailcap-add-mailcap-entry (car tl) (cadr tl) entry
+ 'mailcap-user-mime-data)
+ ;; Make it available for usage.
+ (mailcap-add-mailcap-entry (car tl) (cadr tl) entry))))
;;;
;;; The main whabbo
@@ -791,13 +806,13 @@ If NO-DECODE is non-nil, don't decode STRING."
;; NO-DECODE avoids calling `mail-header-parse-content-type' from
;; `mail-parse.el'
(let (
- major ; Major encoding (text, etc)
- minor ; Minor encoding (html, etc)
- info ; Other info
- major-info ; (assoc major mailcap-mime-data)
- viewers ; Possible viewers
- passed ; Viewers that passed the test
- viewer ; The one and only viewer
+ major ; Major encoding (text, etc)
+ minor ; Minor encoding (html, etc)
+ info ; Other info
+ major-info ; (assoc major mailcap--computed-mime-data)
+ viewers ; Possible viewers
+ passed ; Viewers that passed the test
+ viewer ; The one and only viewer
ctl)
(save-excursion
(setq ctl
@@ -809,12 +824,12 @@ If NO-DECODE is non-nil, don't decode STRING."
(if viewer
(setq passed (list viewer))
;; None found, so heuristically select some applicable viewer
- ;; from `mailcap-mime-data'.
+ ;; from `mailcap--computed-mime-data'.
(mailcap-parse-mailcaps nil t)
(setq major (split-string (car ctl) "/"))
(setq minor (cadr major)
major (car major))
- (when (setq major-info (cdr (assoc major mailcap-mime-data)))
+ (when (setq major-info (cdr (assoc major mailcap--computed-mime-data)))
(when (setq viewers (mailcap-possible-viewers major-info minor))
(setq info (mapcar (lambda (a)
(cons (symbol-name (car a)) (cdr a)))
@@ -827,11 +842,11 @@ If NO-DECODE is non-nil, don't decode STRING."
;; ~/.mailcap file, then we filter out the system entries
;; and see whether we have anything left.
(when mailcap-prefer-mailcap-viewers
- (when-let ((user-entry
- (seq-find (lambda (elem)
- (eq (cdr (assq 'source elem)) 'user))
- passed)))
- (setq passed (list user-entry))))
+ (when-let ((user-entries
+ (seq-filter (lambda (elem)
+ (eq (cdr (assq 'source elem)) 'user))
+ passed)))
+ (setq passed user-entries)))
(setq viewer (car passed))))
(when (and (stringp (cdr (assq 'viewer viewer)))
passed)
@@ -847,7 +862,7 @@ If NO-DECODE is non-nil, don't decode STRING."
((eq request 'all)
passed)
(t
- ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
+ ;; MUST make a copy *sigh*, else we modify mailcap--computed-mime-data
(setq viewer (copy-sequence viewer))
(let ((view (assq 'viewer viewer))
(test (assq 'test viewer)))
@@ -1057,7 +1072,7 @@ For instance, \"foo.png\" will result in \"image/png\"."
(nconc
(mapcar 'cdr mailcap-mime-extensions)
(let (res type)
- (dolist (data mailcap-mime-data)
+ (dolist (data mailcap--computed-mime-data)
(dolist (info (cdr data))
(setq type (cdr (assq 'type (cdr info))))
(unless (string-match-p "\\*" type)
@@ -1115,18 +1130,72 @@ For instance, \"foo.png\" will result in \"image/png\"."
res)))
(nreverse res)))))
+(defun mailcap--async-shell (command file)
+ "Asynchronously call MIME viewer shell COMMAND.
+Replace %s in COMMAND with FILE, as per `mailcap-mime-data'.
+Delete FILE once COMMAND exits."
+ (let ((buf (get-buffer-create " *mailcap shell*")))
+ (async-shell-command (format command file) buf)
+ (add-function :after (process-sentinel (get-buffer-process buf))
+ (lambda (proc _msg)
+ (when (memq (process-status proc) '(exit signal))
+ (delete-file file))))))
+
(defun mailcap-view-mime (type)
"View the data in the current buffer that has MIME type TYPE.
-`mailcap-mime-data' determines the method to use."
+The variable `mailcap--computed-mime-data' determines the method
+to use. If the method is a shell command string, erase the
+current buffer after passing its contents to the shell command."
(let ((method (mailcap-mime-info type)))
(if (stringp method)
- (shell-command-on-region (point-min) (point-max)
- ;; Use stdin as the "%s".
- (format method "-")
- (current-buffer)
- t)
+ (let* ((ext (concat "." (cadr (split-string type "/"))))
+ (file (make-temp-file "emacs-mailcap" nil ext))
+ (coding-system-for-write 'binary))
+ (write-region nil nil file nil 'silent)
+ (delete-region (point-min) (point-max))
+ (mailcap--async-shell method file))
(funcall method))))
+(defun mailcap-view-file (file)
+ "View FILE according to rules given by the mailcap system.
+This normally involves executing some external program to display
+the file.
+
+See \"~/.mailcap\", `mailcap-mime-data' and related files and variables."
+ (interactive "fOpen file with mailcap: ")
+ (setq file (expand-file-name file))
+ (mailcap-parse-mailcaps)
+ (let ((command (mailcap-mime-info
+ (mailcap-extension-to-mime (file-name-extension file)))))
+ (unless command
+ (error "No viewer for %s" (file-name-extension file)))
+ ;; Remove quotes around the file name - we'll use shell-quote-argument.
+ (while (string-match "['\"]%s['\"]" command)
+ (setq command (replace-match "%s" t t command)))
+ (setq command (replace-regexp-in-string
+ "%s"
+ (shell-quote-argument (convert-standard-filename file))
+ command
+ nil t))
+ ;; Handlers such as "gio open" and kde-open5 start viewer in background
+ ;; and exit immediately. Avoid `start-process' since it assumes
+ ;; :connection-type `pty' and kills children processes with SIGHUP
+ ;; when temporary terminal session is finished (Bug#44824).
+ ;; An alternative is `process-connection-type' let-bound to nil for
+ ;; `start-process-shell-command' call (with no chance to report failure).
+ (make-process
+ :name "mailcap-view-file"
+ :connection-type 'pipe
+ :buffer nil ; "*Messages*" may be suitable for debugging
+ :sentinel (lambda (proc event)
+ (when (and (memq (process-status proc) '(exit signal))
+ (/= (process-exit-status proc) 0))
+ (message
+ "Command %s: %s."
+ (mapconcat #'identity (process-command proc) " ")
+ (substring event 0 -1))))
+ :command (list shell-file-name shell-command-switch command))))
+
(provide 'mailcap)
;;; mailcap.el ends here
diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el
index 18f41023578..e1d35c2a85a 100644
--- a/lisp/net/mairix.el
+++ b/lisp/net/mairix.el
@@ -1,4 +1,4 @@
-;;; mairix.el --- Mairix interface for Emacs
+;;; mairix.el --- Mairix interface for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -83,55 +83,46 @@
(defcustom mairix-file-path "~/"
"Path where output files produced by Mairix should be stored."
- :type 'directory
- :group 'mairix)
+ :type 'directory)
(defcustom mairix-search-file "mairixsearch.mbox"
"Name of the default file for storing the searches.
Note that this will be prefixed by `mairix-file-path'."
- :type 'string
- :group 'mairix)
+ :type 'string)
(defcustom mairix-command "mairix"
"Command for calling mairix.
You can add further options here if you want to, but better use
`mairix-update-options' instead."
- :type 'string
- :group 'mairix)
+ :type 'string)
(defcustom mairix-output-buffer "*mairix output*"
"Name of the buffer for the output of the mairix binary."
- :type 'string
- :group 'mairix)
+ :type 'string)
(defcustom mairix-customize-query-buffer "*mairix query*"
"Name of the buffer for customizing a search query."
- :type 'string
- :group 'mairix)
+ :type 'string)
(defcustom mairix-saved-searches-buffer "*mairix searches*"
"Name of the buffer for displaying saved searches."
- :type 'string
- :group 'mairix)
+ :type 'string)
(defcustom mairix-update-options '("-F" "-Q")
"Options when calling mairix for updating the database.
The default is \"-F\" and \"-Q\" for making updates faster. You
should call mairix without these options from time to
time (e.g. via cron job)."
- :type '(repeat string)
- :group 'mairix)
+ :type '(repeat string))
(defcustom mairix-search-options '("-Q")
"Options when calling mairix for searching.
The default is \"-Q\" for making searching faster."
- :type '(repeat string)
- :group 'mairix)
+ :type '(repeat string))
(defcustom mairix-synchronous-update nil
"Defines if Emacs should wait for the mairix database update."
- :type 'boolean
- :group 'mairix)
+ :type 'boolean)
(defcustom mairix-saved-searches nil
"Saved mairix searches.
@@ -144,8 +135,7 @@ threads (nil or t). Note that the file will be prefixed by
(choice :tag "File"
(const :tag "default")
file)
- (boolean :tag "Threads")))
- :group 'mairix)
+ (boolean :tag "Threads"))))
(defcustom mairix-mail-program 'rmail
"Mail program used to display search results.
@@ -153,8 +143,7 @@ Currently RMail, Gnus (mbox), and VM are supported. If you use Gnus
with maildir, use nnmairix.el instead."
:type '(choice (const :tag "RMail" rmail)
(const :tag "Gnus mbox" gnus)
- (const :tag "VM" vm))
- :group 'mairix)
+ (const :tag "VM" vm)))
(defcustom mairix-display-functions
'((rmail mairix-rmail-display)
@@ -166,8 +155,7 @@ This is an alist where each entry consists of a symbol from
displaying the search results. The function will be called with
the mailbox file produced by mairix as the single argument."
:type '(repeat (list (symbol :tag "Mail program")
- (function)))
- :group 'mairix)
+ (function))))
(defcustom mairix-get-mail-header-functions
'((rmail mairix-rmail-fetch-field)
@@ -184,15 +172,13 @@ won't work."
:type '(repeat (list (symbol :tag "Mail program")
(choice :tag "Header function"
(const :tag "none")
- function)))
- :group 'mairix)
+ function))))
(defcustom mairix-widget-select-window-function
(lambda () (select-window (get-largest-window)))
"Function for selecting the window for customizing the mairix query.
The default chooses the largest window in the current frame."
- :type 'function
- :group 'mairix)
+ :type 'function)
;; Other variables
@@ -342,6 +328,7 @@ Currently there are `threads' and `flags'.")
;;;; Main interactive functions
+;;;###autoload
(defun mairix-search (search threads)
"Call Mairix with SEARCH.
If THREADS is non-nil, also display whole threads of found
@@ -356,6 +343,7 @@ messages. Results will be put into the default search file."
threads)
(mairix-show-folder mairix-search-file)))
+;;;###autoload
(defun mairix-use-saved-search ()
"Use a saved search for querying Mairix."
(interactive)
@@ -388,6 +376,7 @@ Overwrite existing entry? ")
(setcdr (assoc name mairix-saved-searches) mairix-last-search))))
(mairix-select-save))
+;;;###autoload
(defun mairix-edit-saved-searches-customize ()
"Edit the list of saved searches in a customization buffer."
(interactive)
@@ -400,6 +389,8 @@ in your .emacs by pressing `Save for Future Sessions'.\n"
(make-string 65 ?=) "\n")))
(autoload 'mail-strip-quoted-names "mail-utils")
+
+;;;###autoload
(defun mairix-search-from-this-article (threads)
"Search messages from sender of the current article.
This is effectively a shortcut for calling `mairix-search' with
@@ -416,6 +407,7 @@ threads."
threads)
(error "No function for obtaining mail header specified"))))
+;;;###autoload
(defun mairix-search-thread-this-article ()
"Search thread for the current article.
This is effectively a shortcut for calling `mairix-search'
@@ -437,12 +429,14 @@ with m:msgid of the current article and enabled threads."
(mairix-search
(format "m:%s" mid) t)))
+;;;###autoload
(defun mairix-widget-search-based-on-article ()
"Create mairix query based on current article using widgets."
(interactive)
(mairix-widget-search
(mairix-widget-get-values)))
+;;;###autoload
(defun mairix-edit-saved-searches ()
"Edit current mairix searches."
(interactive)
@@ -455,6 +449,7 @@ with m:msgid of the current article and enabled threads."
(defvar mairix-widgets)
+;;;###autoload
(defun mairix-widget-search (&optional mvalues)
"Create mairix query interactively using graphical widgets.
MVALUES may contain values from current article."
@@ -466,24 +461,25 @@ MVALUES may contain values from current article."
;; generate Buttons
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _)
(mairix-widget-send-query mairix-widgets))
"Send Query")
(widget-insert " ")
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _)
(mairix-widget-save-search mairix-widgets))
"Save search")
(widget-insert " ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _)
(kill-buffer mairix-customize-query-buffer))
"Cancel")
(use-local-map widget-keymap)
(widget-setup)
(goto-char (point-min)))
+;;;###autoload
(defun mairix-update-database ()
"Call mairix for updating the database for SERVERS.
Mairix will be called asynchronously unless
@@ -502,7 +498,7 @@ Mairix will be called asynchronously unless
(cdr commandsplit)
mairix-update-options))
(setq args (append args mairix-update-options)))
- (apply 'call-process args))
+ (apply #'call-process args))
(progn
(message "Updating mairix database...")
(setq args (append (list "mairixupdate" (get-buffer-create mairix-output-buffer)
@@ -511,8 +507,8 @@ Mairix will be called asynchronously unless
(setq args (append args (cdr commandsplit) mairix-update-options))
(setq args (append args mairix-update-options)))
(set-process-sentinel
- (apply 'start-process args)
- 'mairix-sentinel-mairix-update-finished)))))
+ (apply #'start-process args)
+ #'mairix-sentinel-mairix-update-finished)))))
;;;; Helper functions
@@ -535,8 +531,11 @@ The mail program is given by `mairix-mail-program'."
If FILE is nil, use default. If THREADS is non-nil, also return
whole threads. Function returns t if messages were found."
(let* ((commandsplit (split-string mairix-command))
- (args (cons (car commandsplit)
- `(nil ,(get-buffer-create mairix-output-buffer) nil)))
+ (args (cons
+ (car commandsplit)
+ (append
+ `(nil ,(get-buffer-create mairix-output-buffer) nil)
+ mairix-search-options)))
rval)
(with-current-buffer mairix-output-buffer
(erase-buffer))
@@ -557,7 +556,7 @@ whole threads. Function returns t if messages were found."
mairix-file-path))
file))
(setq rval
- (apply 'call-process
+ (apply #'call-process
(append args (list "-o" file) query)))
(if (zerop rval)
(with-current-buffer mairix-output-buffer
@@ -582,7 +581,7 @@ whole threads. Function returns t if messages were found."
(setq header (replace-match "," t t header)))
header))
-(defun mairix-sentinel-mairix-update-finished (proc status)
+(defun mairix-sentinel-mairix-update-finished (_proc status)
"Sentinel for mairix update process PROC with STATUS."
(if (equal status "finished\n")
(message "Updating mairix database... done")
@@ -631,97 +630,94 @@ See %s for details" mairix-output-buffer)))
(when (member 'flags mairix-widget-other)
(setq flag
(mapconcat
- (function
- (lambda (flag)
- (setq temp
- (widget-value (cadr (assoc (car flag) mairix-widgets))))
- (if (string= "yes" temp)
- (cadr flag)
- (if (string= "no" temp)
- (concat "-" (cadr flag))))))
+ (lambda (flag)
+ (setq temp
+ (widget-value (cadr (assoc (car flag) mairix-widgets))))
+ (if (string= "yes" temp)
+ (cadr flag)
+ (if (string= "no" temp)
+ (concat "-" (cadr flag)))))
'(("seen" "s") ("replied" "r") ("flagged" "f")) ""))
(when (not (zerop (length flag)))
(push (concat "F:" flag) query)))
;; return query string
- (mapconcat 'identity query " ")))
+ (mapconcat #'identity query " ")))
(defun mairix-widget-create-query (&optional values)
"Create widgets for creating mairix queries.
Fill in VALUES if based on an article."
- (let (allwidgets)
- (when (get-buffer mairix-customize-query-buffer)
- (kill-buffer mairix-customize-query-buffer))
- (switch-to-buffer mairix-customize-query-buffer)
- (kill-all-local-variables)
- (erase-buffer)
- (widget-insert
- "Specify your query for Mairix using check boxes for activating fields.\n\n")
- (widget-insert
- (concat "Use ~word to match messages "
- (propertize "not" 'face 'italic)
- " containing the word)\n"
- " substring= to match words containing the substring\n"
- " substring=N to match words containing the substring, allowing\n"
- " up to N errors(missing/extra/different letters)\n"
- " ^substring= to match the substring at the beginning of a word.\n"))
- (widget-insert
- (format-message
- "Whitespace will be converted to `,' (i.e. AND). Use `/' for OR.\n\n"))
- (setq mairix-widgets (mairix-widget-build-editable-fields values))
- (when (member 'flags mairix-widget-other)
- (widget-insert "\nFlags:\n Seen: ")
- (mairix-widget-add "seen"
- 'menu-choice
- :value "ignore"
- '(item "yes") '(item "no") '(item "ignore"))
- (widget-insert " Replied: ")
- (mairix-widget-add "replied"
- 'menu-choice
- :value "ignore"
- '(item "yes") '(item "no") '(item "ignore"))
- (widget-insert " Ticked: ")
- (mairix-widget-add "flagged"
- 'menu-choice
- :value "ignore"
- '(item "yes") '(item "no") '(item "ignore")))
- (when (member 'threads mairix-widget-other)
- (widget-insert "\n")
- (mairix-widget-add "Threads" 'checkbox nil))
- (widget-insert " Show full threads\n\n")))
+ (when (get-buffer mairix-customize-query-buffer)
+ (kill-buffer mairix-customize-query-buffer))
+ (switch-to-buffer mairix-customize-query-buffer)
+ (kill-all-local-variables)
+ (erase-buffer)
+ (widget-insert
+ "Specify your query for Mairix using check boxes for activating fields.\n\n")
+ (widget-insert
+ (concat "Use ~word to match messages "
+ (propertize "not" 'face 'italic)
+ " containing the word)\n"
+ " substring= to match words containing the substring\n"
+ " substring=N to match words containing the substring, allowing\n"
+ " up to N errors(missing/extra/different letters)\n"
+ " ^substring= to match the substring at the beginning of a word.\n"))
+ (widget-insert
+ (format-message
+ "Whitespace will be converted to `,' (i.e. AND). Use `/' for OR.\n\n"))
+ (setq mairix-widgets (mairix-widget-build-editable-fields values))
+ (when (member 'flags mairix-widget-other)
+ (widget-insert "\nFlags:\n Seen: ")
+ (mairix-widget-add "seen"
+ 'menu-choice
+ :value "ignore"
+ '(item "yes") '(item "no") '(item "ignore"))
+ (widget-insert " Replied: ")
+ (mairix-widget-add "replied"
+ 'menu-choice
+ :value "ignore"
+ '(item "yes") '(item "no") '(item "ignore"))
+ (widget-insert " Ticked: ")
+ (mairix-widget-add "flagged"
+ 'menu-choice
+ :value "ignore"
+ '(item "yes") '(item "no") '(item "ignore")))
+ (when (member 'threads mairix-widget-other)
+ (widget-insert "\n")
+ (mairix-widget-add "Threads" 'checkbox nil))
+ (widget-insert " Show full threads\n\n"))
(defun mairix-widget-build-editable-fields (values)
"Build editable field widgets in `nnmairix-widget-fields-list'.
VALUES may contain values for editable fields from current article."
(let ((ret))
(mapc
- (function
- (lambda (field)
- (setq field (car (cddr field)))
- (setq
- ret
- (nconc
- (list
- (list
- (concat "c" field)
- (widget-create 'checkbox
- :tag field
- :notify (lambda (widget &rest ignore)
- (mairix-widget-toggle-activate widget))
- nil)))
- (list
- (list
- (concat "e" field)
- (widget-create 'editable-field
- :size 60
- :format (concat " " field ":"
- (make-string
- (- 11 (length field)) ?\ )
- "%v")
- :value (or (cadr (assoc field values)) ""))))
- ret))
- (widget-insert "\n")
- ;; Deactivate editable field
- (widget-apply (cadr (nth 1 ret)) :deactivate)))
+ (lambda (field)
+ (setq field (car (cddr field)))
+ (setq
+ ret
+ (nconc
+ (list
+ (list
+ (concat "c" field)
+ (widget-create 'checkbox
+ :tag field
+ :notify (lambda (widget &rest _ignore)
+ (mairix-widget-toggle-activate widget))
+ nil)))
+ (list
+ (list
+ (concat "e" field)
+ (widget-create 'editable-field
+ :size 60
+ :format (concat " " field ":"
+ (make-string
+ (- 11 (length field)) ?\ )
+ "%v")
+ :value (or (cadr (assoc field values)) ""))))
+ ret))
+ (widget-insert "\n")
+ ;; Deactivate editable field
+ (widget-apply (cadr (nth 1 ret)) :deactivate))
mairix-widget-fields-list)
ret))
@@ -729,7 +725,7 @@ VALUES may contain values for editable fields from current article."
"Add a widget NAME with optional ARGS."
(push
(list name
- (apply 'widget-create args))
+ (apply #'widget-create args))
mairix-widgets))
(defun mairix-widget-toggle-activate (widget)
@@ -936,13 +932,12 @@ Use cursor keys or C-n,C-p to select next/previous search.\n\n")
(save-excursion
(save-restriction
(mapcar
- (function
- (lambda (field)
- (list (car (cddr field))
- (if (car field)
- (mairix-replace-invalid-chars
- (funcall get-mail-header (car field)))
- nil))))
+ (lambda (field)
+ (list (car (cddr field))
+ (if (car field)
+ (mairix-replace-invalid-chars
+ (funcall get-mail-header (car field)))
+ nil)))
mairix-widget-fields-list)))
(error "No function for obtaining mail header specified"))))
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index e0befac28c2..90cca7d415c 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -1,4 +1,4 @@
-;;; net-utils.el --- network functions
+;;; net-utils.el --- network functions -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -67,17 +67,14 @@
"tracert"
"traceroute")
"Program to trace network hops to a destination."
- :group 'net-utils
:type 'string)
(defcustom traceroute-program-options nil
"Options for the traceroute program."
- :group 'net-utils
:type '(repeat string))
(defcustom ping-program "ping"
"Program to send network test packets to a host."
- :group 'net-utils
:type 'string)
;; On GNU/Linux and Irix, the system's ping program seems to send packets
@@ -87,7 +84,6 @@
(list "-c" "4"))
"Options for the ping program.
These options can be used to limit how many ICMP packets are emitted."
- :group 'net-utils
:type '(repeat string))
(defcustom ifconfig-program
@@ -98,7 +94,6 @@ These options can be used to limit how many ICMP packets are emitted."
(t "ip"))
"Program to print network configuration information."
:version "25.1" ; add ip
- :group 'net-utils
:type 'string)
(defcustom ifconfig-program-options
@@ -108,7 +103,6 @@ These options can be used to limit how many ICMP packets are emitted."
"Options for the ifconfig program."
:version "25.1"
:set-after '(ifconfig-program)
- :group 'net-utils
:type '(repeat string))
(defcustom iwconfig-program
@@ -116,7 +110,6 @@ These options can be used to limit how many ICMP packets are emitted."
((net-utils--executable-find-sbin "iw") "iw")
(t "iw"))
"Program to print wireless network configuration information."
- :group 'net-utils
:type 'string
:version "26.1")
@@ -124,7 +117,6 @@ These options can be used to limit how many ICMP packets are emitted."
(cond ((string-match-p "iw\\'" iwconfig-program) (list "dev"))
(t nil))
"Options for the iwconfig program."
- :group 'net-utils
:type '(repeat string)
:version "26.1")
@@ -133,25 +125,21 @@ These options can be used to limit how many ICMP packets are emitted."
((net-utils--executable-find-sbin "ss"))
(t "ss"))
"Program to print network statistics."
- :group 'net-utils
:type 'string
:version "26.1")
(defcustom netstat-program-options
(list "-a")
"Options for the netstat program."
- :group 'net-utils
:type '(repeat string))
(defcustom arp-program (or (net-utils--executable-find-sbin "arp") "arp")
"Program to print IP to address translation tables."
- :group 'net-utils
:type 'string)
(defcustom arp-program-options
(list "-a")
"Options for the arp program."
- :group 'net-utils
:type '(repeat string))
(defcustom route-program
@@ -162,7 +150,6 @@ These options can be used to limit how many ICMP packets are emitted."
((net-utils--executable-find-sbin "ip"))
(t "ip"))
"Program to print routing tables."
- :group 'net-utils
:type 'string
:version "26.1")
@@ -171,18 +158,15 @@ These options can be used to limit how many ICMP packets are emitted."
((string-match-p "netstat\\'" route-program) (list "-r"))
(t (list "route")))
"Options for the route program."
- :group 'net-utils
:type '(repeat string)
:version "26.1")
(defcustom nslookup-program "nslookup"
"Program to interactively query DNS information."
- :group 'net-utils
:type 'string)
(defcustom nslookup-program-options nil
"Options for the nslookup program."
- :group 'net-utils
:type '(repeat string))
(defcustom nslookup-prompt-regexp "^> "
@@ -190,28 +174,23 @@ These options can be used to limit how many ICMP packets are emitted."
This variable is only used if the variable
`comint-use-prompt-regexp' is non-nil."
- :group 'net-utils
:type 'regexp)
(defcustom dig-program "dig"
"Program to query DNS information."
- :group 'net-utils
:type 'string)
(defcustom dig-program-options nil
"Options for the dig program."
- :group 'net-utils
:type '(repeat string)
:version "26.1")
(defcustom ftp-program "ftp"
"Program to run to do FTP transfers."
- :group 'net-utils
:type 'string)
(defcustom ftp-program-options nil
"Options for the ftp program."
- :group 'net-utils
:type '(repeat string))
(defcustom ftp-prompt-regexp "^ftp>"
@@ -219,17 +198,14 @@ This variable is only used if the variable
This variable is only used if the variable
`comint-use-prompt-regexp' is non-nil."
- :group 'net-utils
:type 'regexp)
(defcustom smbclient-program "smbclient"
"Smbclient program."
- :group 'net-utils
:type 'string)
(defcustom smbclient-program-options nil
"Options for the smbclient program."
- :group 'net-utils
:type '(repeat string))
(defcustom smbclient-prompt-regexp "^smb: >"
@@ -237,17 +213,14 @@ This variable is only used if the variable
This variable is only used if the variable
`comint-use-prompt-regexp' is non-nil."
- :group 'net-utils
:type 'regexp)
(defcustom dns-lookup-program "host"
"Program to interactively query DNS information."
- :group 'net-utils
:type 'string)
(defcustom dns-lookup-program-options nil
"Options for the dns-lookup program."
- :group 'net-utils
:type '(repeat string))
;; Internal variables
@@ -265,7 +238,7 @@ This variable is only used if the variable
1 'font-lock-keyword-face)
;; Dotted quads
(list
- (mapconcat 'identity
+ (mapconcat #'identity
(make-list 4 "[0-9]+")
"\\.")
0 'font-lock-variable-name-face)
@@ -273,7 +246,7 @@ This variable is only used if the variable
(list
(let ((host-expression "[-A-Za-z0-9]+"))
(concat
- (mapconcat 'identity
+ (mapconcat #'identity
(make-list 2 host-expression)
"\\.")
"\\(\\." host-expression "\\)*"))
@@ -288,7 +261,7 @@ This variable is only used if the variable
(list
;; Dotted quads
(list
- (mapconcat 'identity (make-list 4 "[0-9]+") "\\.")
+ (mapconcat #'identity (make-list 4 "[0-9]+") "\\.")
0 'font-lock-variable-name-face)
;; Simple rfc4291 addresses
(list (concat
@@ -300,15 +273,15 @@ This variable is only used if the variable
(list
(let ((host-expression "[-A-Za-z0-9]+"))
(concat
- (mapconcat 'identity (make-list 2 host-expression) "\\.")
+ (mapconcat #'identity (make-list 2 host-expression) "\\.")
"\\(\\." host-expression "\\)*"))
0 'font-lock-variable-name-face))
"Expressions to font-lock for general network utilities.")
(define-derived-mode net-utils-mode special-mode "NetworkUtil"
"Major mode for interacting with an external network utility."
- (set (make-local-variable 'font-lock-defaults)
- '((net-utils-font-lock-keywords)))
+ (setq-local font-lock-defaults
+ '((net-utils-font-lock-keywords)))
(setq-local revert-buffer-function #'net-utils--revert-function))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -371,8 +344,8 @@ This variable is only used if the variable
(erase-buffer)
(insert header "\n")
(set-process-filter
- (apply 'start-process name buf program args)
- 'net-utils-remove-ctrl-m-filter)
+ (apply #'start-process name buf program args)
+ #'net-utils-remove-ctrl-m-filter)
(display-buffer buf)
buf))
@@ -390,27 +363,27 @@ This variable is only used if the variable
(when proc
(set-process-filter proc nil)
(delete-process proc)))
- (let ((inhibit-read-only t)
- (coding-system-for-read
- ;; MS-Windows versions of network utilities output text
- ;; encoded in the console (a.k.a. "OEM") codepage, which is
- ;; different from the default system (a.k.a. "ANSI")
- ;; codepage.
- (if (eq system-type 'windows-nt)
- (intern (format "cp%d" (w32-get-console-output-codepage)))
- coding-system-for-read)))
+ (let ((inhibit-read-only t))
(erase-buffer))
(net-utils-mode)
(setq-local net-utils--revert-cmd
`(net-utils-run-simple ,(current-buffer)
,program-name ,args nodisplay))
- (set-process-filter
- (apply 'start-process program-name
- (current-buffer) program-name args)
- 'net-utils-remove-ctrl-m-filter)
+ (let ((coding-system-for-read
+ ;; MS-Windows versions of network utilities output text
+ ;; encoded in the console (a.k.a. "OEM") codepage, which is
+ ;; different from the default system (a.k.a. "ANSI")
+ ;; codepage.
+ (if (eq system-type 'windows-nt)
+ (intern (format "cp%d" (w32-get-console-output-codepage)))
+ coding-system-for-read)))
+ (set-process-filter
+ (apply #'start-process program-name
+ (current-buffer) program-name args)
+ #'net-utils-remove-ctrl-m-filter))
(unless nodisplay (display-buffer (current-buffer)))))
-(defun net-utils--revert-function (&optional ignore-auto noconfirm)
+(defun net-utils--revert-function (&optional _ignore-auto _noconfirm)
(message "Reverting `%s'..." (buffer-name))
(apply (car net-utils--revert-cmd) (cdr net-utils--revert-cmd))
(let ((proc (get-buffer-process (current-buffer))))
@@ -430,7 +403,7 @@ This variable is only used if the variable
ifconfig-program
ifconfig-program-options))
-(defalias 'ipconfig 'ifconfig)
+(defalias 'ipconfig #'ifconfig)
;;;###autoload
(defun iwconfig ()
@@ -532,7 +505,7 @@ in Lisp code."
(net-utils-run-program
"Nslookup"
(concat "** "
- (mapconcat 'identity
+ (mapconcat #'identity
(list "Nslookup" host nslookup-program)
" ** "))
nslookup-program
@@ -618,15 +591,14 @@ This command uses `nslookup-program' to look up DNS records."
(defvar nslookup-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\t" 'completion-at-point)
+ (define-key map "\t" #'completion-at-point)
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."
- (set
- (make-local-variable 'font-lock-defaults)
- '((nslookup-font-lock-keywords)))
+ (setq-local font-lock-defaults
+ '((nslookup-font-lock-keywords)))
(setq comint-prompt-regexp nslookup-prompt-regexp)
(setq comint-input-autoexpand t))
@@ -647,9 +619,9 @@ This command uses `dns-lookup-program' for looking up the DNS information."
(net-utils-run-program
(concat "DNS Lookup [" host "]")
(concat "** "
- (mapconcat 'identity
- (list "DNS Lookup" host dns-lookup-program)
- " ** "))
+ (mapconcat #'identity
+ (list "DNS Lookup" host dns-lookup-program)
+ " ** "))
dns-lookup-program
options)))
@@ -670,13 +642,14 @@ This command uses `dig-program' for looking up the DNS information."
(net-utils-run-program
"Dig"
(concat "** "
- (mapconcat 'identity
+ (mapconcat #'identity
(list "Dig" host dig-program)
" ** "))
dig-program
options)))
(autoload 'comint-exec "comint")
+(declare-function comint-watch-for-password-prompt "comint" (string))
;; This is a lot less than ange-ftp, but much simpler.
;;;###autoload
@@ -698,7 +671,7 @@ This command uses `dig-program' for looking up the DNS information."
(defvar ftp-mode-map
(let ((map (make-sparse-keymap)))
;; Occasionally useful
- (define-key map "\t" 'completion-at-point)
+ (define-key map "\t" #'completion-at-point)
map))
(define-derived-mode ftp-mode comint-mode "FTP"
@@ -711,9 +684,9 @@ This command uses `dig-program' for looking up the DNS information."
;; password prompts will probably immediately follow the initial
;; connection), but it's better than getting prompted twice for the
;; same password.
- (unless (memq 'comint-watch-for-password-prompt
+ (unless (memq #'comint-watch-for-password-prompt
(default-value 'comint-output-filter-functions))
- (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt
+ (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt
nil t)))
(defun smbclient (host service)
@@ -760,9 +733,9 @@ This command uses `smbclient-program' to connect to HOST."
;; password prompts will probably immediately follow the initial
;; connection), but it's better than getting prompted twice for the
;; same password.
- (unless (memq 'comint-watch-for-password-prompt
+ (unless (memq #'comint-watch-for-password-prompt
(default-value 'comint-output-filter-functions))
- (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt
+ (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt
nil t)))
@@ -771,7 +744,7 @@ This command uses `smbclient-program' to connect to HOST."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Full list is available at:
-;; http://www.iana.org/assignments/port-numbers
+;; https://www.iana.org/assignments/port-numbers
(defvar network-connection-service-alist
(list
(cons 'echo 7)
@@ -811,7 +784,7 @@ This list is not complete.")
(error "Could not open connection to %s" host))
(erase-buffer)
(set-marker (process-mark tcp-connection) (point-min))
- (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter)
+ (set-process-filter tcp-connection #'net-utils-remove-ctrl-m-filter)
(and initial-string
(process-send-string tcp-connection
(concat initial-string "\r\n")))
@@ -826,7 +799,6 @@ This list is not complete.")
If a host name passed to `finger' matches one of these regular
expressions, it is assumed to be a host that doesn't accept
queries of the form USER@HOST, and wants a query containing USER only."
- :group 'net-utils
:type '(repeat regexp)
:version "21.1")
@@ -853,7 +825,7 @@ and `network-connection-service-alist', which see."
(let* ((user-and-host (concat user "@" host))
(process-name (concat "Finger [" user-and-host "]"))
(regexps finger-X.500-host-regexps)
- found)
+ ) ;; found
(and regexps
(while (not (string-match (car regexps) host))
(setq regexps (cdr regexps)))
@@ -867,7 +839,6 @@ and `network-connection-service-alist', which see."
(defcustom whois-server-name "rs.internic.net"
"Default host name for the whois service."
- :group 'net-utils
:type 'string)
(defcustom whois-server-list
@@ -881,15 +852,19 @@ and `network-connection-service-alist', which see."
("whois.nic.gov")
("whois.ripe.net"))
"A list of whois servers that can be queried."
- :group 'net-utils
:type '(repeat (list string)))
;; FIXME: modern whois clients include a much better tld <-> whois server
;; list, Emacs should probably avoid specifying the server as the client
;; will DTRT anyway... -rfr
+;; I'm not sure about the above FIXME. It seems to me that we should
+;; just check the Root Zone Database maintained at:
+;; https://www.iana.org/domains/root/db
+;; For example: whois -h whois.iana.org .se | grep whois
(defcustom whois-server-tld
- '(("rs.internic.net" . "com")
- ("whois.publicinterestregistry.net" . "org")
+ '(("whois.verisign-grs.com" . "com")
+ ("whois.verisign-grs.com" . "net")
+ ("whois.pir.org" . "org")
("whois.ripe.net" . "be")
("whois.ripe.net" . "de")
("whois.ripe.net" . "dk")
@@ -897,21 +872,22 @@ and `network-connection-service-alist', which see."
("whois.ripe.net" . "fi")
("whois.ripe.net" . "fr")
("whois.ripe.net" . "uk")
+ ("whois.iis.se" . "se")
+ ("whois.iis.nu" . "nu")
("whois.apnic.net" . "au")
("whois.apnic.net" . "ch")
("whois.apnic.net" . "hk")
("whois.apnic.net" . "jp")
+ ("whois.eu" . "eu")
("whois.nic.gov" . "gov")
("whois.nic.mil" . "mil"))
"Alist to map top level domains to whois servers."
- :group 'net-utils
:type '(repeat (cons string string)))
(defcustom whois-guess-server t
"If non-nil then whois will try to deduce the appropriate whois
server from the query. If the query doesn't look like a domain or hostname
then the server named by `whois-server-name' is used."
- :group 'net-utils
:type 'boolean)
(defun whois-get-tld (host)
@@ -952,7 +928,6 @@ The port is deduced from `network-connection-service-alist'."
(defcustom whois-reverse-lookup-server "whois.arin.net"
"Server which provides inverse DNS mapping."
- :group 'net-utils
:type 'string)
;;;###autoload
@@ -971,10 +946,8 @@ The port is deduced from `network-connection-service-alist'."
"Major mode for interacting with the network-connection program.")
(defun network-connection-mode-setup (host service)
- (make-local-variable 'network-connection-host)
- (setq network-connection-host host)
- (make-local-variable 'network-connection-service)
- (setq network-connection-service service))
+ (setq-local network-connection-host host)
+ (setq-local network-connection-service service))
;;;###autoload
(defun network-connection-to-service (host service)
@@ -985,9 +958,8 @@ This command uses `network-connection-service-alist', which see."
(read-from-minibuffer "Host: " (net-utils-machine-at-point))
(completing-read "Service: "
(mapcar
- (function
- (lambda (elt)
- (list (symbol-name (car elt)))))
+ (lambda (elt)
+ (list (symbol-name (car elt))))
network-connection-service-alist))))
(network-connection
host
diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el
index 908876de531..9473c821a1a 100644
--- a/lisp/net/netrc.el
+++ b/lisp/net/netrc.el
@@ -1,4 +1,5 @@
-;;; netrc.el --- .netrc parsing functionality
+;;; netrc.el --- .netrc parsing functionality -*- lexical-binding: t -*-
+
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -40,8 +41,7 @@
(defcustom netrc-file "~/.authinfo"
"File where user credentials are stored."
:version "24.1"
- :type 'file
- :group 'netrc)
+ :type 'file)
(defvar netrc-services-file "/etc/services"
"The name of the services file.")
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 6efdca10e09..1983688cef2 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -113,6 +113,10 @@ values:
`ssl' -- Equivalent to `tls'.
`shell' -- A shell connection.
+:coding is a symbol or a cons used to specify the coding systems
+used to decode and encode the data which the process reads and
+writes. See `make-network-process' for details.
+
: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
@@ -135,7 +139,10 @@ values:
:capability-command specifies a command used to query the HOST
for its capabilities. For instance, for IMAP this should be
- \"1 CAPABILITY\\r\\n\".
+ \"1 CAPABILITY\\r\\n\". This can either be a string (which will
+ then be sent verbatim to the server), or a function (called with
+ a single parameter; the \"greeting\" from the server when connecting),
+ and should return a string to send to the server.
:starttls-function specifies a function for handling STARTTLS.
This function should take one parameter, the response to the
@@ -166,8 +173,8 @@ a greeting from the server.
:nowait, if non-nil, says the connection should be made
asynchronously, if possible.
-:shell-command is a format-spec string that can be used if :type
-is `shell'. It has two specs, %s for host and %p for port
+:shell-command is a `format-spec' string that can be used if
+:type is `shell'. It has two specs, %s for host and %p for port
number. Example: \"ssh gateway nc %s %p\".
:tls-parameters is a list that should be supplied if you're
@@ -189,7 +196,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
:host (puny-encode-domain host) :service service
:nowait (plist-get parameters :nowait)
:tls-parameters
- (plist-get parameters :tls-parameters))
+ (plist-get parameters :tls-parameters)
+ :coding (plist-get parameters :coding))
(let ((work-buffer (or buffer
(generate-new-buffer " *stream buffer*")))
(fun (cond ((and (eq type 'plain)
@@ -240,8 +248,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(list key cert)))))))
;;;###autoload
-(defalias 'open-protocol-stream 'open-network-stream)
-(define-obsolete-function-alias 'open-protocol-stream 'open-network-stream
+(define-obsolete-function-alias 'open-protocol-stream #'open-network-stream
"26.1")
(defun network-stream-open-plain (name buffer host service parameters)
@@ -249,7 +256,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(stream (make-network-process :name name :buffer buffer
:host (puny-encode-domain host)
:service service
- :nowait (plist-get parameters :nowait))))
+ :nowait (plist-get parameters :nowait)
+ :coding (plist-get parameters :coding))))
(when (plist-get parameters :warn-unless-encrypted)
(setq stream (nsm-verify-connection stream host service nil t)))
(list stream
@@ -270,11 +278,15 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
(stream (make-network-process :name name :buffer buffer
:host (puny-encode-domain host)
- :service service))
+ :service service
+ :coding (plist-get parameters :coding)))
(greeting (and (not (plist-get parameters :nogreeting))
(network-stream-get-response stream start eoc)))
- (capabilities (network-stream-command stream capability-command
- eo-capa))
+ (capabilities
+ (network-stream-command
+ stream
+ (network-stream--capability-command capability-command greeting)
+ eo-capa))
(resulting-type 'plain)
starttls-available starttls-command error)
@@ -322,7 +334,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
;; Requery capabilities for protocols that require it; i.e.,
;; EHLO for SMTP.
(when (plist-get parameters :always-query-capabilities)
- (network-stream-command stream capability-command eo-capa)))
+ (network-stream-command
+ stream
+ (network-stream--capability-command capability-command greeting)
+ eo-capa)))
(when (let ((response
(network-stream-command stream starttls-command eoc)))
(and response (string-match success-string response)))
@@ -350,14 +365,18 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(setq stream
(make-network-process :name name :buffer buffer
:host (puny-encode-domain host)
- :service service))
+ :service service
+ :coding (plist-get parameters :coding)))
(network-stream-get-response stream start eoc)))
(unless (process-live-p stream)
(error "Unable to negotiate a TLS connection with %s/%s"
host service))
;; Re-get the capabilities, which may have now changed.
(setq capabilities
- (network-stream-command stream capability-command eo-capa))))
+ (network-stream-command
+ stream
+ (network-stream--capability-command capability-command greeting)
+ eo-capa))))
;; If TLS is mandatory, close the connection if it's unencrypted.
(when (and require-tls
@@ -420,7 +439,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
parameters)
(require 'tls)
(open-tls-stream name buffer host service)))
- (eoc (plist-get parameters :end-of-command)))
+ (eoc (plist-get parameters :end-of-command))
+ greeting)
(if (plist-get parameters :nowait)
(list stream nil nil 'tls)
;; Check certificate validity etc.
@@ -432,42 +452,58 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
;; openssl/gnutls-cli.
(when (and (not (gnutls-available-p))
eoc)
- (network-stream-get-response stream start eoc)
+ (setq greeting (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))
+ (let ((capability-command
+ (plist-get parameters :capability-command))
(eo-capa (or (plist-get parameters :end-of-capability)
eoc)))
(list stream
(network-stream-get-response stream start eoc)
- (network-stream-command stream capability-command eo-capa)
+ (network-stream-command
+ stream
+ (network-stream--capability-command
+ capability-command greeting)
+ eo-capa)
'tls)))))))
-(declare-function format-spec "format-spec" (format spec))
-(declare-function format-spec-make "format-spec" (&rest pairs))
-
(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)))
+ (coding (plist-get parameters :coding))
(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))))))
+ `((?s . ,host)
+ (?p . ,service))))))
+ greeting)
+ (when coding (if (consp coding)
+ (set-process-coding-system stream
+ (car coding)
+ (cdr coding))
+ (set-process-coding-system stream
+ coding
+ coding)))
(list stream
- (network-stream-get-response stream start eoc)
- (network-stream-command stream capability-command
- (or (plist-get parameters :end-of-capability)
- eoc))
+ (setq greeting (network-stream-get-response stream start eoc))
+ (network-stream-command
+ stream
+ (network-stream--capability-command capability-command greeting)
+ (or (plist-get parameters :end-of-capability)
+ eoc))
'plain)))
+(defun network-stream--capability-command (command greeting)
+ (if (functionp command)
+ (funcall command greeting)
+ command))
+
(provide 'network-stream)
;;; network-stream.el ends here
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 714edbe2088..e623dab26df 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -34,16 +34,15 @@
;; ======================================================================
;;; Code:
-(require 'derived)
(require 'xml)
(require 'url-parse)
(require 'iso8601)
;; Silence warnings
+(defvar newsticker-groups)
(defvar w3-mode-map)
(defvar w3m-minor-mode-map)
-
(defvar newsticker--retrieval-timer-list nil
"List of timers for news retrieval.
This is an alist, each element consisting of (feed-name . timer).")
@@ -67,43 +66,34 @@ considered to be running if the newsticker timer list is not empty."
;; Hard-coding URLs like this is a recipe for propagating obsolete info.
(defconst newsticker--raw-url-list-defaults
- '(
- ;; 2017/12: no response.
-;;; ("CNET News.com"
-;;; "http://export.cnet.com/export/feeds/news/rss/1,11176,,00.xml")
- ("Debian Security Advisories"
- "http://www.debian.org/security/dsa.en.rdf")
+ '(("Debian Security Advisories"
+ "https://www.debian.org/security/dsa.en.rdf")
("Debian Security Advisories - Long format"
- "http://www.debian.org/security/dsa-long.en.rdf")
+ "https://www.debian.org/security/dsa-long.en.rdf")
("Emacs Wiki"
- "https://www.emacswiki.org/emacs?action=rss"
- nil
- 3600)
+ "https://www.emacswiki.org/emacs?action=rss"
+ nil
+ 3600)
("LWN (Linux Weekly News)"
- "https://lwn.net/headlines/rss")
- ;; Not updated since 2010.
-;;; ("NY Times: Technology"
-;;; "http://www.nytimes.com/services/xml/rss/userland/Technology.xml")
-;;; ("NY Times"
-;;; "http://www.nytimes.com/services/xml/rss/userland/HomePage.xml")
+ "https://lwn.net/headlines/rss")
("Quote of the day"
- "http://feeds.feedburner.com/quotationspage/qotd"
- "07:00"
- 86400)
+ "https://feeds.feedburner.com/quotationspage/qotd"
+ "07:00"
+ 86400)
("The Register"
- "https://www.theregister.co.uk/headlines.rss")
+ "https://www.theregister.co.uk/headlines.rss")
("slashdot"
- "http://rss.slashdot.org/Slashdot/slashdot"
- nil
- 3600) ;/. will ban you if under 3600 seconds!
+ "http://rss.slashdot.org/Slashdot/slashdot"
+ nil
+ 3600) ;/. will ban you if under 3600 seconds!
("Wired News"
- "https://www.wired.com/feed/rss")
+ "https://www.wired.com/feed/rss")
("Heise News (german)"
- "http://www.heise.de/newsticker/heise.rdf")
+ "http://www.heise.de/newsticker/heise.rdf")
("Tagesschau (german)"
- "http://www.tagesschau.de/newsticker.rdf"
- nil
- 1800))
+ "http://www.tagesschau.de/newsticker.rdf"
+ nil
+ 1800))
"Default URL list in raw form.
This list is fed into defcustom via `newsticker--splicer'.")
@@ -162,10 +152,10 @@ value effective."
:group 'newsticker)
(defcustom newsticker-url-list-defaults
- '(("Emacs Wiki"
- "https://www.emacswiki.org/emacs?action=rss"
- nil
- 3600))
+ '(("Emacs Wiki"
+ "https://www.emacswiki.org/emacs?action=rss"
+ nil
+ 3600))
"A customizable list of news feeds to select from.
These were mostly extracted from the Radio Community Server
<http://rcs.userland.com/>.
@@ -173,7 +163,7 @@ These were mostly extracted from the Radio Community Server
You may add other entries in `newsticker-url-list'."
:type `(set ,@(mapcar #'newsticker--splicer
newsticker--raw-url-list-defaults))
- :set 'newsticker--set-customvar-retrieval
+ :set #'newsticker--set-customvar-retrieval
:group 'newsticker-retrieval)
(defcustom newsticker-url-list nil
@@ -227,7 +217,7 @@ which apply for this feed only, overriding the value of
(choice :tag "Wget Arguments"
(const :tag "Default arguments" nil)
(repeat :tag "Special arguments" string))))
- :set 'newsticker--set-customvar-retrieval
+ :set #'newsticker--set-customvar-retrieval
:group 'newsticker-retrieval)
(defcustom newsticker-retrieval-method
@@ -270,7 +260,7 @@ make it less than 1800 seconds (30 minutes)!"
(const :tag "Daily" 86400)
(const :tag "Weekly" 604800)
(integer :tag "Interval"))
- :set 'newsticker--set-customvar-retrieval
+ :set #'newsticker--set-customvar-retrieval
:group 'newsticker-retrieval)
(defcustom newsticker-desc-comp-max
@@ -363,7 +353,7 @@ description are marked as immortal."
(const :tag "Title" title)
(const :tag "Description" description)
(const :tag "All" all))
- (string :tag "Regexp")))))
+ (regexp :tag "Regexp")))))
:group 'newsticker-headline-processing)
;; ======================================================================
@@ -559,7 +549,7 @@ name/timer pair to `newsticker--retrieval-timer-list'."
(if (<= interval 0)
(setq interval nil))
(setq timer (run-at-time start-time interval
- 'newsticker-get-news feed-name))
+ #'newsticker-get-news feed-name))
(if interval
(add-to-list 'newsticker--retrieval-timer-list
(cons feed-name timer))))))
@@ -654,6 +644,15 @@ If URL is nil it is searched at point."
(add-to-list 'newsticker-url-list (list name url nil nil nil) t)
(customize-variable 'newsticker-url-list))
+(defun newsticker-customize-feed (feed-name)
+ "Open customization buffer for `newsticker-url-list' and jump to FEED-NAME."
+ (interactive
+ (list (completing-read "Name of feed or group to edit: "
+ (mapcar #'car newsticker-url-list))))
+ (customize-variable 'newsticker-url-list)
+ (when (search-forward (concat "Label: " feed-name) nil t)
+ (forward-line -1)))
+
(defun newsticker-customize ()
"Open the newsticker customization group."
(interactive)
@@ -680,8 +679,8 @@ See `newsticker-get-news'."
(condition-case error-data
(url-retrieve url 'newsticker--get-news-by-url-callback
(list feed-name))
- (error (message "Error retrieving news from %s: %s" feed-name
- error-data))))
+ (error (message "Error retrieving news from %s: %s" feed-name
+ error-data))))
(force-mode-line-update))
(defun newsticker--get-news-by-url-callback (status feed-name)
@@ -728,10 +727,10 @@ See `newsticker-get-news'."
(error "Another wget-process is running for %s" feed-name))
;; start wget
(let* ((args (append wget-arguments (list url)))
- (proc (apply 'start-process feed-name buffername
+ (proc (apply #'start-process feed-name buffername
newsticker-wget-name args)))
(set-process-coding-system proc 'no-conversion 'no-conversion)
- (set-process-sentinel proc 'newsticker--sentinel)
+ (set-process-sentinel proc #'newsticker--sentinel)
(process-put proc 'nt-feed-name feed-name)
(setq newsticker--process-ids (cons (process-id proc)
newsticker--process-ids))
@@ -825,7 +824,7 @@ Argument BUFFER is the buffer of the retrieval process."
(setq coding-system (intern (downcase (match-string 1))))
(setq coding-system
(condition-case nil
- (check-coding-system coding-system)
+ (check-coding-system coding-system)
(coding-system-error
(message
"newsticker.el: ignoring coding system %s for %s"
@@ -898,7 +897,7 @@ Argument BUFFER is the buffer of the retrieval process."
;; Atom 1.0 feed.
;; (and (eq 'feed (xml-node-name topnode))
- ;; (string= "http://www.w3.org/2005/Atom"
+ ;; (string= "https://www.w3.org/2005/Atom"
;; (xml-get-attribute topnode 'xmlns)))
(setq image-url (newsticker--get-logo-url-atom-1.0 topnode))
(setq icon-url (newsticker--get-icon-url-atom-1.0 topnode))
@@ -936,8 +935,8 @@ Argument BUFFER is the buffer of the retrieval process."
;; setup scrollable text
(when (= 0 (length newsticker--process-ids))
(when (fboundp 'newsticker--ticker-text-setup) ;silence
- ;compiler
- ;warnings
+ ;compiler
+ ;warnings
(newsticker--ticker-text-setup)))
(setq newsticker--latest-update-time (current-time))
(when something-was-added
@@ -945,8 +944,8 @@ Argument BUFFER is the buffer of the retrieval process."
(newsticker--cache-save-feed
(newsticker--cache-get-feed name-symbol))
(when (fboundp 'newsticker--buffer-set-uptodate) ;silence
- ;compiler
- ;warnings
+ ;compiler
+ ;warnings
(newsticker--buffer-set-uptodate nil)))
;; kill the process buffer if wanted
(unless newsticker-debug
@@ -1013,7 +1012,7 @@ Argument BUFFER is the buffer of the retrieval process."
;; And another one (20050702)! If description is HTML
;; encoded and starts with a `<', wrap the whole
;; description in a CDATA expression. This happened for
- ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote
+ ;; https://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote
(goto-char (point-min))
(while (re-search-forward
"<description>\\(<img.*?\\)</description>" nil t)
@@ -1107,8 +1106,8 @@ same as in `newsticker--parse-atom-1.0'."
;; time-fn
(lambda (node)
(newsticker--decode-rfc822-date
- (car (xml-node-children
- (car (xml-get-children node 'modified))))))
+ (car (xml-node-children
+ (car (xml-get-children node 'modified))))))
;; guid-fn
(lambda (node)
(newsticker--guid-to-string
@@ -1132,9 +1131,9 @@ Restore an xml-string from a an xml NODE that was returned by xml-parse..."
(children (cddr node)))
(concat "<" qname
(when att-list " ")
- (mapconcat 'newsticker--unxml-attribute att-list " ")
+ (mapconcat #'newsticker--unxml-attribute att-list " ")
">"
- (mapconcat 'newsticker--unxml children "") "</" qname ">")))
+ (mapconcat #'newsticker--unxml children "") "</" qname ">")))
(defun newsticker--unxml-attribute (attribute)
"Actually restore xml-string of an ATTRIBUTE of an xml node."
@@ -1177,7 +1176,7 @@ URL `http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html'"
;; unxml the content or the summary node. Atom
;; allows for integrating (x)html into the atom
;; structure but we need the raw html string.
- ;; e.g. http://www.heise.de/open/news/news-atom.xml
+ ;; e.g. https://www.heise.de/open/news/news-atom.xml
;; http://feeds.feedburner.com/ru_nix_blogs
(or (newsticker--unxml
(car (xml-node-children
@@ -1557,6 +1556,7 @@ argument, which is one of the items in ITEMLIST."
;; ======================================================================
(defun newsticker--insert-bytes (bytes)
+ "Decode BYTES and insert in current buffer."
(insert (decode-coding-string bytes 'binary)))
(defun newsticker--remove-whitespace (string)
@@ -1580,7 +1580,7 @@ Remove the pre-formatted from `newsticker--cache'."
"Forget all cached pre-formatted data.
Remove the pre-formatted from `newsticker--cache'."
(mapc (lambda (feed)
- (mapc 'newsticker--do-forget-preformatted
+ (mapc #'newsticker--do-forget-preformatted
(cdr feed)))
newsticker--cache)
(when (fboundp 'newsticker--buffer-set-uptodate)
@@ -1593,10 +1593,10 @@ This function calls `message' with arguments STRING and ARGS, if
(and newsticker-debug
;;(not (active-minibuffer-window))
;;(not (current-message))
- (apply 'message string args)))
+ (apply #'message string args)))
(defun newsticker--decode-iso8601-date (string)
- "Return ISO8601-STRING in format like `encode-time'.
+ "Return ISO8601-encoded STRING in format like `encode-time'.
Converts from ISO-8601 to Emacs representation. If no time zone
is present, this function defaults to universal time."
(if string
@@ -1678,8 +1678,9 @@ Sat, 07 Sep 2002 00:00:01 GMT
(message "Cannot decode \"%s\": %s %s" rfc822-string
(car error-data) (cdr error-data))
nil))))
- nil))
+ nil))
+;; FIXME: Can this be replaced by seq-intersection?
(defun newsticker--lists-intersect-p (list1 list2)
"Return t if LIST1 and LIST2 share elements."
(let ((result nil))
@@ -1737,27 +1738,27 @@ Save image as FILENAME in DIRECTORY, download it from URL."
(let* ((proc-name (concat feed-name "-" filename))
(buffername (concat " *newsticker-wget-image-" proc-name "*"))
(item (or (assoc feed-name newsticker-url-list)
- (assoc feed-name newsticker-url-list-defaults)
- (error
- "Cannot get image for %s: Check newsticker-url-list"
- feed-name)))
+ (assoc feed-name newsticker-url-list-defaults)
+ (error
+ "Cannot get image for %s: Check newsticker-url-list"
+ feed-name)))
(wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
newsticker-wget-arguments)))
- (with-current-buffer (get-buffer-create buffername)
- (erase-buffer)
- ;; throw an error if there is an old wget-process around
- (if (get-process feed-name)
- (error "Another wget-process is running for image %s"
- feed-name))
- ;; start wget
- (let* ((args (append wget-arguments (list url)))
- (proc (apply 'start-process proc-name buffername
- newsticker-wget-name args)))
- (set-process-coding-system proc 'no-conversion 'no-conversion)
- (set-process-sentinel proc 'newsticker--image-sentinel)
- (process-put proc 'nt-directory directory)
- (process-put proc 'nt-feed-name feed-name)
- (process-put proc 'nt-filename filename)))))
+ (with-current-buffer (get-buffer-create buffername)
+ (erase-buffer)
+ ;; throw an error if there is an old wget-process around
+ (if (get-process feed-name)
+ (error "Another wget-process is running for image %s"
+ feed-name))
+ ;; start wget
+ (let* ((args (append wget-arguments (list url)))
+ (proc (apply #'start-process proc-name buffername
+ newsticker-wget-name args)))
+ (set-process-coding-system proc 'no-conversion 'no-conversion)
+ (set-process-sentinel proc #'newsticker--image-sentinel)
+ (process-put proc 'nt-directory directory)
+ (process-put proc 'nt-feed-name feed-name)
+ (process-put proc 'nt-filename filename)))))
(defun newsticker--image-sentinel (process _event)
"Sentinel for image-retrieving PROCESS caused by EVENT."
@@ -1782,18 +1783,18 @@ Save image as FILENAME in DIRECTORY, download it from URL."
"Save contents of BUFFER in DIRECTORY as FILE-NAME.
Finally kill buffer."
(with-current-buffer buffer
- (let ((image-name (concat directory file-name)))
- (set-buffer-file-coding-system 'no-conversion)
- ;; make sure the cache dir exists
- (unless (file-directory-p directory)
- (make-directory directory))
- ;; write and close buffer
- (let ((require-final-newline nil)
- (backup-inhibited t)
- (coding-system-for-write 'no-conversion))
- (write-region nil nil image-name nil 'quiet))
- (set-buffer-modified-p nil)
- (kill-buffer buffer))))
+ (let ((image-name (concat directory file-name)))
+ (set-buffer-file-coding-system 'no-conversion)
+ ;; make sure the cache dir exists
+ (unless (file-directory-p directory)
+ (make-directory directory))
+ ;; write and close buffer
+ (let ((require-final-newline nil)
+ (backup-inhibited t)
+ (coding-system-for-write 'no-conversion))
+ (write-region nil nil image-name nil 'quiet))
+ (set-buffer-modified-p nil)
+ (kill-buffer buffer))))
(defun newsticker--image-remove (directory file-name)
"In DIRECTORY remove FILE-NAME."
@@ -1808,8 +1809,8 @@ Save image as FILENAME in DIRECTORY, download it from URL."
(condition-case error-data
(url-retrieve url 'newsticker--image-download-by-url-callback
(list feed-name directory filename))
- (error (message "Error retrieving image from %s: %s" feed-name
- error-data))))
+ (error (message "Error retrieving image from %s: %s" feed-name
+ error-data))))
(force-mode-line-update))
(defun newsticker--image-download-by-url-callback (status feed-name directory filename)
@@ -2146,11 +2147,11 @@ FEED is a symbol!"
(concat newsticker-dir "/feeds"))
(defun newsticker--cache-save ()
- "Save cache data for all feeds."
- (unless (file-directory-p newsticker-dir)
- (make-directory newsticker-dir t))
- (mapc 'newsticker--cache-save-feed newsticker--cache)
- nil)
+ "Save cache data for all feeds."
+ (unless (file-directory-p newsticker-dir)
+ (make-directory newsticker-dir t))
+ (mapc #'newsticker--cache-save-feed newsticker--cache)
+ nil)
(defun newsticker--cache-save-feed (feed)
"Save cache data for FEED."
@@ -2216,14 +2217,14 @@ If AGES is nil, the total number of items is returned."
(if (memq (newsticker--age (car items)) ages)
(setq num (1+ num)))
(if (memq (newsticker--age (car items)) '(new old immortal obsolete))
- (setq num (1+ num))))
+ (setq num (1+ num))))
(setq items (cdr items)))
num))
(defun newsticker--stat-num-items-total (&optional age)
"Return total number of items in all feeds which have the given AGE.
If AGE is nil, the total number of items is returned."
- (apply '+
+ (apply #'+
(mapcar (lambda (feed)
(if age
(newsticker--stat-num-items (intern (car feed)) age)
@@ -2236,39 +2237,66 @@ If AGE is nil, the total number of items is returned."
(defun newsticker-opml-export ()
"OPML subscription export.
Export subscriptions to a buffer in OPML Format."
- ;; FIXME: use newsticker-groups
(interactive)
(with-current-buffer (get-buffer-create "*OPML Export*")
+ (erase-buffer)
(set-buffer-file-coding-system 'utf-8)
(insert (concat
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
"<!-- OPML generated by Emacs newsticker.el -->\n"
"<opml version=\"1.0\">\n"
" <head>\n"
- " <title>mySubscriptions</title>\n"
+ " <title>Emacs newsticker subscriptions</title>\n"
" <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
"</dateCreated>\n"
" <ownerEmail>" user-mail-address "</ownerEmail>\n"
" <ownerName>" (user-full-name) "</ownerName>\n"
" </head>\n"
" <body>\n"))
- (dolist (sub (append newsticker-url-list newsticker-url-list-defaults))
- (insert " <outline text=\"")
- (insert (newsticker--title sub))
- (insert "\" xmlUrl=\"")
- (insert (xml-escape-string (let ((url (cadr sub)))
- (if (stringp url) url (prin1-to-string url)))))
- (insert "\"/>\n"))
- (insert " </body>\n</opml>\n"))
+ (let ((feeds (append newsticker-url-list newsticker-url-list-defaults))
+ ;; insert the feed groups and all feeds that are contained
+ (saved-feed-names (newsticker--opml-insert-elt newsticker-groups 2)))
+ ;; to be safe: insert all feeds that are not contained in any group
+ (dolist (f feeds)
+ (unless (seq-find (lambda (sfn) (string= (car f) sfn)) saved-feed-names)
+ (newsticker--opml-insert-feed (car f) 4)))
+ (insert " </body>\n</opml>\n")))
(pop-to-buffer "*OPML Export*")
(when (fboundp 'sgml-mode)
(sgml-mode)))
+(defun newsticker--opml-insert-elt (elt depth)
+ "Insert an OPML ELT with indentation level DEPTH."
+ (if (listp elt)
+ (newsticker--opml-insert-group elt (+ 2 depth))
+ (newsticker--opml-insert-feed elt (+ 2 depth))))
+
+(defun newsticker--opml-insert-group (group depth)
+ "Insert an OPML GROUP with indentation level DEPTH."
+ (let (saved-feeds)
+ (insert (make-string depth ? ) "<outline type=\"folder\" text=\"" (car group) "\">\n")
+ (setq saved-feeds (mapcar (lambda (e)
+ (newsticker--opml-insert-elt e depth))
+ (cdr group)))
+ (insert (make-string depth ? ) "</outline>\n")
+ (flatten-tree saved-feeds)))
+
+(defun newsticker--opml-insert-feed (feed-name depth)
+ "Insert an OPML FEED-NAME with indentation level DEPTH."
+ (let* ((feed-definition (seq-find (lambda (f)
+ (string= feed-name (car f)))
+ (append newsticker-url-list newsticker-url-list-defaults)))
+ (url (nth 1 feed-definition))
+ (url-string (if (functionp url) (prin1-to-string url)
+ (xml-escape-string url))))
+ (insert (make-string depth ? ) "<outline text=\"" feed-name
+ "\" xmlUrl=\"" url-string
+ "\"/>\n"))
+ feed-name)
+
(defun newsticker--opml-import-outlines (outlines)
- "Recursively import OUTLINES from OPML data.
-Note that nested outlines are currently flattened -- i.e. grouping is
-removed."
- (mapc (lambda (outline)
+ "Recursively import OUTLINES from OPML data."
+ (mapcar (lambda (outline)
(let ((name (xml-get-attribute outline 'text))
(url (xml-get-attribute outline 'xmlUrl))
(children (xml-get-children outline 'outline)))
@@ -2276,18 +2304,27 @@ removed."
(add-to-list 'newsticker-url-list
(list name url nil nil nil) t))
(if children
- (newsticker--opml-import-outlines children))))
- outlines))
+ (append (list name)
+ (newsticker--opml-import-outlines children))
+ name)))
+ outlines))
(defun newsticker-opml-import (filename)
- "Import OPML data from FILENAME."
+ "Import OPML data from FILENAME.
+Feeds are added to `newsticker-url-list' and `newsticker-groups'
+preserving the outline structure."
(interactive "fOPML file: ")
(set-buffer (find-file-noselect filename))
(goto-char (point-min))
(let* ((node-list (xml-parse-region (point-min) (point-max)))
+ (title (car (xml-node-children
+ (car (xml-get-children
+ (car (xml-get-children (car node-list) 'head))
+ 'title)))))
(body (car (xml-get-children (car node-list) 'body)))
- (outlines (xml-get-children body 'outline)))
- (newsticker--opml-import-outlines outlines))
+ (outlines (xml-get-children body 'outline))
+ (imported-groups-data (newsticker--opml-import-outlines outlines)))
+ (add-to-list 'newsticker-groups (cons title imported-groups-data) t))
(customize-variable 'newsticker-url-list))
;; ======================================================================
@@ -2359,7 +2396,7 @@ the item."
(make-directory temp-dir t))
(cd temp-dir)
(message "Getting image %s" url)
- (apply 'start-process "wget-image"
+ (apply #'start-process "wget-image"
" *newsticker-wget-download-images*"
newsticker-wget-name
(list url))
@@ -2381,7 +2418,7 @@ This function is suited for adding it to `newsticker-new-item-functions'."
(make-directory temp-dir t))
(cd temp-dir)
(message "Getting enclosure %s" url)
- (apply 'start-process "wget-enclosure"
+ (apply #'start-process "wget-enclosure"
" *newsticker-wget-download-enclosures*"
newsticker-wget-name
(list url))
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 242716984f6..420cf82e4d8 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -1,10 +1,10 @@
-;;; newst-plainview.el --- Single buffer frontend for newsticker.
+;;; newst-plainview.el --- Single buffer frontend for newsticker. -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-plainview.el
-;; URL: http://www.nongnu.org/newsticker
+;; URL: https://www.nongnu.org/newsticker
;; Package: newsticker
;; ======================================================================
@@ -34,7 +34,6 @@
(require 'newst-ticker)
(require 'newst-reader)
-(require 'derived)
(require 'xml)
;; Silence warnings
@@ -91,7 +90,7 @@ The following sort methods are available:
(const :tag "Keep original order" sort-by-original-order)
(const :tag "Sort by time" sort-by-time)
(const :tag "Sort by title" sort-by-title))
- :set 'newsticker--set-customvar-sorting
+ :set #'newsticker--set-customvar-sorting
:group 'newsticker-plainview)
(defcustom newsticker-heading-format
@@ -108,7 +107,7 @@ The following printf-like specifiers can be used:
%s The statistical data of the feed. See `newsticker-statistics-format'.
%t The title of the feed, i.e. its name."
:type 'string
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-plainview)
(defcustom newsticker-item-format
@@ -123,7 +122,7 @@ The following printf-like specifiers can be used:
the title of the feed is used.
%t The title of the item."
:type 'string
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-plainview)
(defcustom newsticker-desc-format
@@ -134,7 +133,7 @@ The following printf-like specifiers can be used:
%d The date the item was (first) retrieved. See
`newsticker-date-format'."
:type 'string
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-plainview)
(defcustom newsticker-statistics-format
@@ -147,7 +146,7 @@ The following printf-like specifiers can be used:
%o The number of old items in the feed.
%O The number of obsolete items in the feed."
:type 'string
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-plainview)
@@ -196,7 +195,7 @@ If set to t old items will be completely folded and only new
items will show up in the *newsticker* buffer. Otherwise old as
well as new items will be visible."
:type 'boolean
- :set 'newsticker--set-customvar-buffer
+ :set #'newsticker--set-customvar-buffer
:group 'newsticker-plainview)
(defcustom newsticker-show-descriptions-of-new-items
@@ -205,14 +204,14 @@ well as new items will be visible."
If set to t old items will be folded and new items will be
unfolded. Otherwise old as well as new items will be folded."
:type 'boolean
- :set 'newsticker--set-customvar-buffer
+ :set #'newsticker--set-customvar-buffer
:group 'newsticker-plainview)
(defcustom newsticker-show-all-news-elements
nil
"Show all news elements."
:type 'boolean
- ;;:set 'newsticker--set-customvar
+ ;;:set #'newsticker--set-customvar
:group 'newsticker-plainview)
;; ======================================================================
@@ -274,6 +273,7 @@ images."
(defvar newsticker--plainview-tool-bar-map
(when (boundp 'tool-bar-map)
+ (defvar tool-bar-map)
(let ((tool-bar-map (make-sparse-keymap)))
(tool-bar-add-item "newsticker/prev-feed"
'newsticker-previous-feed
@@ -387,51 +387,45 @@ images."
(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 [?\S-\ ] 'scroll-down-command)
- (define-key map " " 'scroll-up-command)
- (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)
+ (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 [?\S-\ ] #'scroll-down-command)
+ (define-key map " " #'scroll-up-command)
+ (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)
@@ -445,17 +439,17 @@ images."
"NewsTicker"
"Viewing news feeds in Emacs."
(if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map)
- newsticker--plainview-tool-bar-map))
- (set (make-local-variable 'imenu-sort-function) nil)
- (set (make-local-variable 'scroll-conservatively) 999)
+ (setq-local tool-bar-map
+ newsticker--plainview-tool-bar-map))
+ (setq-local imenu-sort-function nil)
+ (setq-local scroll-conservatively 999)
(setq imenu-create-index-function 'newsticker--imenu-create-index)
(setq imenu-default-goto-function 'newsticker--imenu-goto)
(setq buffer-read-only t)
(auto-fill-mode -1) ;; turn auto-fill off!
(font-lock-mode -1) ;; turn off font-lock!!
- (set (make-local-variable 'font-lock-defaults) nil)
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ (setq-local font-lock-defaults nil)
+ (setq-local line-move-ignore-invisible t)
(setq mode-line-format
(list "-"
'mode-line-mule-info
@@ -480,11 +474,11 @@ images."
;; maps for the clickable portions
(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)
+ (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.")
@@ -533,7 +527,7 @@ Unless FORCE is t this is done only if necessary, i.e. when the
(set-buffer-file-coding-system 'utf-8)
(if newsticker-use-full-width
- (set (make-local-variable 'fill-column) (1- (window-width))))
+ (setq-local fill-column (1- (window-width))))
(newsticker--buffer-insert-all-items)
;; FIXME: needed for methods buffer in ecb
@@ -981,7 +975,7 @@ not get changed."
(let* (pos1 pos2
(inhibit-read-only t)
inv-prop org-inv-prop
- is-invisible)
+ ) ;; is-invisible
(newsticker--buffer-beginning-of-item)
(newsticker--buffer-goto '(desc))
(setq pos1 (max (point-min) (1- (point))))
@@ -1010,7 +1004,7 @@ not get changed."
(let* (pos1 pos2
(inhibit-read-only t)
inv-prop org-inv-prop
- is-invisible)
+ ) ;; is-invisible
(newsticker--buffer-beginning-of-item)
(newsticker--buffer-goto '(desc))
(setq pos1 (max (point-min) (1- (point))))
@@ -1148,7 +1142,7 @@ If VALUE is nil, auto-narrowing is turned off, otherwise it is turned on."
(setq index-alist (list feed-list)))
index-alist)))
-(defun newsticker--imenu-goto (name pos &rest args)
+(defun newsticker--imenu-goto (_name pos &rest _args)
"Go to item NAME at position POS and show item.
ARGS are ignored."
(goto-char pos)
@@ -1237,6 +1231,9 @@ item-retrieval time is added as well."
;; insert the description
(newsticker--buffer-do-insert-text item 'desc feed-name-symbol))
+(defvar w3m-fill-column)
+(defvar w3-maximum-line-length)
+
(defun newsticker--buffer-do-insert-text (item type feed-name-symbol)
"Actually insert contents of news item, format it, render it and all that.
ITEM is a news item, TYPE tells which part of the item shall be inserted,
diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el
index b188bd4589e..40e304402ad 100644
--- a/lisp/net/newst-reader.el
+++ b/lisp/net/newst-reader.el
@@ -1,4 +1,4 @@
-;;; newst-reader.el --- Generic RSS reader functions.
+;;; newst-reader.el --- Generic RSS reader functions. -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
@@ -94,7 +94,7 @@ done."
(const :tag "Right" right)
(const :tag "Center" center)
(const :tag "Full" full))
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-reader)
(defcustom newsticker-use-full-width
@@ -103,7 +103,7 @@ done."
If non-nil newsticker sets `fill-column' so that the whole
window is used when filling. See also `newsticker-justification'."
:type 'boolean
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-reader)
(defcustom newsticker-html-renderer
@@ -122,7 +122,7 @@ htmlr if this option is set."
(const :tag "w3" w3-region)
(const :tag "w3m" w3m-region)
(const :tag "htmlr" newsticker-htmlr-render))
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-reader)
(defcustom newsticker-date-format
@@ -130,7 +130,7 @@ htmlr if this option is set."
"Format for the date part in item and feed lines.
See `format-time-string' for a list of valid specifiers."
:type 'string
- :set 'newsticker--set-customvar-formatting
+ :set #'newsticker--set-customvar-formatting
:group 'newsticker-reader)
(defgroup newsticker-faces nil
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 275c91a36ea..8cfafb5bfe4 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -1,4 +1,4 @@
-;; newst-ticker.el --- mode line ticker for newsticker.
+;;; newst-ticker.el --- mode line ticker for newsticker. -*- lexical-binding: t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
@@ -83,7 +83,7 @@ smooth display (see `newsticker-scroll-smoothly') a value of 0.3 seems
reasonable. For non-smooth display a value of 10 is a good starting
point."
:type 'number
- :set 'newsticker--set-customvar-ticker
+ :set #'newsticker--set-customvar-ticker
:group 'newsticker-ticker)
(defcustom newsticker-scroll-smoothly
@@ -104,7 +104,7 @@ at all. If you change `newsticker-scroll-smoothly' you should also change
If t the echo area will not show immortal items. See also
`newsticker-hide-old-items-in-echo-area'."
:type 'boolean
- :set 'newsticker--set-customvar-ticker
+ :set #'newsticker--set-customvar-ticker
:group 'newsticker-ticker)
(defcustom newsticker-hide-old-items-in-echo-area
@@ -113,7 +113,7 @@ If t the echo area will not show immortal items. See also
If t the echo area will show only new items, i.e. only items which have
been added between the last two retrievals."
:type 'boolean
- :set 'newsticker--set-customvar-ticker
+ :set #'newsticker--set-customvar-ticker
:group 'newsticker-ticker)
(defcustom newsticker-hide-obsolete-items-in-echo-area
@@ -122,7 +122,7 @@ been added between the last two retrievals."
If t the echo area will not show obsolete items. See also
`newsticker-hide-old-items-in-echo-area'."
:type 'boolean
- :set 'newsticker--set-customvar-ticker
+ :set #'newsticker--set-customvar-ticker
:group 'newsticker-ticker)
(defun newsticker--display-tick ()
@@ -205,7 +205,7 @@ running already."
(setq newsticker--ticker-timer
(run-at-time newsticker-ticker-interval
newsticker-ticker-interval
- 'newsticker--display-tick))))
+ #'newsticker--display-tick))))
(defun newsticker-stop-ticker ()
"Stop newsticker's ticker (but not the news retrieval)."
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index a67e1069ef0..d524e6dd173 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -31,10 +31,6 @@
;; See newsticker.el
;; ======================================================================
-;;; History:
-;;
-
-;; ======================================================================
;;; Code:
(require 'cl-lib)
(require 'newst-reader)
@@ -52,72 +48,73 @@
(defface newsticker-treeview-face
'((((class color) (background dark)) :foreground "white")
(((class color) (background light)) :foreground "black"))
- "Face for newsticker tree."
- :group 'newsticker-treeview)
+ "Face for newsticker tree.")
(defface newsticker-treeview-new-face
'((t :inherit newsticker-treeview-face :weight bold))
- "Face for newsticker tree."
- :group 'newsticker-treeview)
+ "Face for newsticker tree.")
(defface newsticker-treeview-old-face
'((t :inherit newsticker-treeview-face))
- "Face for newsticker tree."
- :group 'newsticker-treeview)
+ "Face for newsticker tree.")
(defface newsticker-treeview-immortal-face
'((default :inherit newsticker-treeview-face :slant italic)
(((class color) (background dark)) :foreground "orange")
(((class color) (background light)) :foreground "blue"))
- "Face for newsticker tree."
- :group 'newsticker-treeview)
+ "Face for newsticker tree.")
(defface newsticker-treeview-obsolete-face
'((t :inherit newsticker-treeview-face :strike-through t))
- "Face for newsticker tree."
- :group 'newsticker-treeview)
+ "Face for newsticker tree.")
(defface newsticker-treeview-selection-face
'((((class color) (background dark)) :background "#4444aa")
(((class color) (background light)) :background "#bbbbff"))
- "Face for newsticker selection."
- :group 'newsticker-treeview)
+ "Face for newsticker selection.")
(defcustom newsticker-treeview-date-format
"%d.%m.%y, %H:%M"
"Format for the date column in the treeview list buffer.
See `format-time-string' for a list of valid specifiers."
:version "25.1"
- :type 'string
- :group 'newsticker-treeview)
+ :type 'string)
(defcustom newsticker-treeview-own-frame
nil
"Decides whether newsticker treeview creates and uses its own frame."
- :type 'boolean
- :group 'newsticker-treeview)
+ :type 'boolean)
(defcustom newsticker-treeview-treewindow-width
30
"Width of tree window in treeview layout.
See also `newsticker-treeview-listwindow-height'."
- :type 'integer
- :group 'newsticker-treeview)
+ :type 'integer)
(defcustom newsticker-treeview-listwindow-height
10
"Height of list window in treeview layout.
See also `newsticker-treeview-treewindow-width'."
- :type 'integer
- :group 'newsticker-treeview)
+ :type 'integer)
(defcustom newsticker-treeview-automatically-mark-displayed-items-as-old
t
"Decides whether to automatically mark displayed items as old.
If t an item is marked as old as soon as it is displayed. This
applies to newsticker only."
- :type 'boolean
- :group 'newsticker-treeview)
+ :type 'boolean)
+
+(defcustom newsticker-treeview-use-feed-name-from-url-list-in-treeview
+ t
+ "Use the feed names from 'newsticker-url-list' for display in treeview."
+ :version "28.1"
+ :type 'boolean)
+
+(defcustom newsticker-treeview-use-feed-name-from-url-list-in-itemview
+ t
+ "Use feed names from 'newsticker-url-list' in itemview."
+ :version "28.1"
+ :type 'boolean)
(defvar newsticker-groups
'("Feeds")
@@ -131,14 +128,6 @@ groupcontent := feedname | groupdefinition)
Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\")
\"feed3\")")
-(defcustom newsticker-groups-filename
- nil
- "Name of the newsticker groups settings file."
- :version "25.1" ; changed default value to nil
- :type '(choice (const nil) string)
- :group 'newsticker-treeview)
-(make-obsolete-variable 'newsticker-groups-filename 'newsticker-dir "23.1")
-
;; ======================================================================
;;; internal variables
;; ======================================================================
@@ -160,14 +149,16 @@ Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\")
(defvar newsticker--treeview-feed-tree nil)
(defvar newsticker--treeview-vfeed-tree nil)
+(declare-function newsticker-handle-url "newst-plainview" ())
+
;; maps for the clickable portions
(defvar newsticker--treeview-url-keymap
(let ((map (make-sparse-keymap 'newsticker--treeview-url-keymap)))
- (define-key map [mouse-1] 'newsticker-treeview-mouse-browse-url)
- (define-key map [mouse-2] 'newsticker-treeview-mouse-browse-url)
- (define-key map "\n" 'newsticker-treeview-browse-url)
- (define-key map "\C-m" 'newsticker-treeview-browse-url)
- (define-key map [(control return)] 'newsticker-handle-url)
+ (define-key map [mouse-1] #'newsticker-treeview-mouse-browse-url)
+ (define-key map [mouse-2] #'newsticker-treeview-mouse-browse-url)
+ (define-key map "\n" #'newsticker-treeview-browse-url)
+ (define-key map "\C-m" #'newsticker-treeview-browse-url)
+ (define-key map [(control return)] #'newsticker-handle-url)
map)
"Key map for click-able headings in the newsticker treeview buffers.")
@@ -336,9 +327,9 @@ If string SHOW-FEED is non-nil it is shown in the item string."
(replace-match " "))
(let ((map (make-sparse-keymap)))
(dolist (key'([mouse-1] [mouse-3]))
- (define-key map key 'newsticker-treeview-tree-click))
- (define-key map "\n" 'newsticker-treeview-show-item)
- (define-key map "\C-m" 'newsticker-treeview-show-item)
+ (define-key map key #'newsticker-treeview-tree-click))
+ (define-key map "\n" #'newsticker-treeview-show-item)
+ (define-key map "\C-m" #'newsticker-treeview-show-item)
(add-text-properties pos1 (point-max)
(list :nt-item item
:nt-feed feed
@@ -620,9 +611,9 @@ If CLEAR-BUFFER is non-nil the list buffer is completely erased."
(defvar newsticker-treeview-list-sort-button-map
(let ((map (make-sparse-keymap)))
(define-key map [header-line mouse-1]
- 'newsticker--treeview-list-sort-by-column)
+ #'newsticker--treeview-list-sort-by-column)
(define-key map [header-line mouse-2]
- 'newsticker--treeview-list-sort-by-column)
+ #'newsticker--treeview-list-sort-by-column)
map)
"Local keymap for newsticker treeview list window sort buttons.")
@@ -727,9 +718,8 @@ for the button."
(window-width (newsticker--treeview-item-window))
fill-column))))
(if newsticker-use-full-width
- (set (make-local-variable 'fill-column) wwidth))
- (set (make-local-variable 'fill-column) (min fill-column
- wwidth)))
+ (setq-local fill-column wwidth))
+ (setq-local fill-column (min fill-column wwidth)))
(let ((desc (newsticker--desc item)))
(insert "\n" (or desc "[No Description]")))
(set-marker marker1 (1+ (point-min)))
@@ -747,11 +737,14 @@ for the button."
(img (newsticker--image-read feed-name-symbol nil 40)))
(if (and (display-images-p) img)
(newsticker--insert-image img (car item))
- (insert (newsticker--real-feed-name feed-name-symbol))))
+ (insert (if newsticker-treeview-use-feed-name-from-url-list-in-itemview
+ (symbol-name feed-name-symbol)
+ (newsticker--real-feed-name feed-name-symbol)))))
(add-text-properties (point-min) (point)
(list 'face 'newsticker-feed-face
'mouse-face 'highlight
- 'help-echo "Visit in web browser."
+ 'help-echo (concat (newsticker--real-feed-name feed-name-symbol)
+ "\nClick to visit in web browser.")
:nt-link (newsticker--link item)
'keymap newsticker--treeview-url-keymap))
(setq pos (point))
@@ -942,31 +935,31 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored."
(newsticker-treeview-mode)))
(defun newsticker--treeview-propertize-tag (tag &optional num-new nt-id feed
- vfeed)
+ vfeed tooltip)
"Return propertized copy of string TAG.
Optional argument NUM-NEW is used for choosing face, other
-arguments NT-ID, FEED, and VFEED are added as properties."
+arguments NT-ID, FEED, VFEED and TOOLTIP are added as properties."
;;(message "newsticker--treeview-propertize-tag `%s' %s" feed nt-id)
(let ((face 'newsticker-treeview-face)
(map (make-sparse-keymap)))
(if (and num-new (> num-new 0))
(setq face 'newsticker-treeview-new-face))
(dolist (key '([mouse-1] [mouse-3]))
- (define-key map key 'newsticker-treeview-tree-click))
- (define-key map "\n" 'newsticker-treeview-tree-do-click)
- (define-key map "\C-m" 'newsticker-treeview-tree-do-click)
+ (define-key map key #'newsticker-treeview-tree-click))
+ (define-key map "\n" #'newsticker-treeview-tree-do-click)
+ (define-key map "\C-m" #'newsticker-treeview-tree-do-click)
(propertize tag 'face face 'keymap map
:nt-id nt-id
:nt-feed feed
:nt-vfeed vfeed
- 'help-echo tag
+ 'help-echo tooltip
'mouse-face 'highlight)))
(defun newsticker--treeview-tree-get-tag (feed-name vfeed-name
&optional nt-id)
"Return a tag string for either FEED-NAME or, if it is nil, for VFEED-NAME.
Optional argument NT-ID is added to the tag's properties."
- (let (tag (num-new 0))
+ (let (tag tooltip (num-new 0))
(cond (vfeed-name
(cond ((string= vfeed-name "new")
(setq num-new (newsticker--stat-num-items-total 'new))
@@ -979,18 +972,29 @@ Optional argument NT-ID is added to the tag's properties."
(setq tag (format "Obsolete items (%d)" num-new)))
((string= vfeed-name "all")
(setq num-new (newsticker--stat-num-items-total))
- (setq tag (format "All items (%d)" num-new)))))
+ (setq tag (format "All items (%d)" num-new))))
+ (setq tooltip tag))
(feed-name
(setq num-new (newsticker--stat-num-items-for-group
(intern feed-name) 'new 'immortal))
(setq tag
(format "%s (%d)"
- (newsticker--real-feed-name (intern feed-name))
- num-new))))
+ (if newsticker-treeview-use-feed-name-from-url-list-in-itemview
+ feed-name
+ (newsticker--real-feed-name (intern feed-name)))
+ num-new))
+ (setq tooltip
+ (if (newsticker--group-get-group feed-name)
+ tag
+ (format "%s (%d)\n%s"
+ feed-name
+ num-new
+ (newsticker--real-feed-name (intern feed-name)))))))
(if tag
(newsticker--treeview-propertize-tag tag num-new
nt-id
- feed-name vfeed-name))))
+ feed-name vfeed-name
+ tooltip))))
(defun newsticker--stat-num-items-for-group (feed-name-symbol &rest ages)
"Count number of items in feed FEED-NAME-SYMBOL that have an age matching AGES."
@@ -1094,6 +1098,7 @@ Arguments are ignored."
;; ======================================================================
(defvar newsticker-treeview-tool-bar-map
(when (boundp 'tool-bar-map)
+ (defvar tool-bar-map)
(let ((tool-bar-map (make-sparse-keymap)))
(tool-bar-add-item "newsticker/prev-feed"
'newsticker-treeview-prev-feed
@@ -1265,29 +1270,9 @@ Note: does not update the layout."
(defun newsticker--treeview-load ()
"Load treeview settings."
(let* ((coding-system-for-read 'utf-8)
- (filename
- (or (and newsticker-groups-filename
- (not (string=
- (expand-file-name newsticker-groups-filename)
- (expand-file-name (concat newsticker-dir "/groups"))))
- (file-exists-p newsticker-groups-filename)
- (y-or-n-p
- (format-message
- (concat "Obsolete variable `newsticker-groups-filename' "
- "points to existing file \"%s\".\n"
- "Read it? ")
- newsticker-groups-filename))
- newsticker-groups-filename)
- (concat newsticker-dir "/groups")))
+ (filename (concat newsticker-dir "/groups"))
(buf (and (file-exists-p filename)
(find-file-noselect filename))))
- (and newsticker-groups-filename
- (file-exists-p newsticker-groups-filename)
- (y-or-n-p (format-message
- (concat "Delete the file \"%s\",\nto which the obsolete "
- "variable `newsticker-groups-filename' points ? ")
- newsticker-groups-filename))
- (delete-file newsticker-groups-filename))
(when buf
(set-buffer buf)
(goto-char (point-min))
@@ -1463,6 +1448,15 @@ Move to next item unless DONT-PROCEED is non-nil."
newsticker--treeview-current-vfeed)
(newsticker--treeview-get-selected-item)))
+(defun newsticker-treeview-customize-current-feed ()
+ "Open customization buffer for `newsticker-url-list' and move to current feed."
+ (interactive)
+ (let ((cur-feed (or newsticker--treeview-current-feed
+ newsticker--treeview-current-vfeed)))
+ (if (newsticker--group-get-group cur-feed)
+ (message "Cannot customize groups. Please select a feed.")
+ (newsticker-customize-feed cur-feed))))
+
(defun newsticker--treeview-set-current-node (node)
"Make NODE the current node."
(with-current-buffer (newsticker--treeview-tree-buffer)
@@ -1655,7 +1649,7 @@ Return t if a new feed was activated, nil otherwise."
(interactive
(list (let ((completion-ignore-case t))
(completing-read
- "Jump to feed: "
+ "Jump to feed/group: "
(append '("new" "obsolete" "immortal" "all")
(mapcar #'car (append newsticker-url-list
newsticker-url-list-defaults)))
@@ -1881,28 +1875,34 @@ of the shift. If MOVE-GROUP is nil the currently selected feed
`newsticker--treeview-current-feed' is shifted, if it is t then
the current feed's parent group is shifted.."
(let* ((cur-feed newsticker--treeview-current-feed)
- (thing (if move-group
- (newsticker--group-find-parent-group cur-feed)
+ (thing (if (and move-group
+ (not (newsticker--group-get-group cur-feed)))
+ (car (newsticker--group-find-parent-group cur-feed))
cur-feed))
(parent-group (newsticker--group-find-parent-group
- (if move-group (car thing) thing))))
+ ;;(if move-group (car thing) thing)
+ thing)))
(unless parent-group
(error "Group not found!"))
(let* ((siblings (cdr parent-group))
- (pos (cl-position thing siblings :test 'equal))
+ (pos (cl-position thing siblings :test
+ (lambda (o1 o2)
+ (equal (if (listp o1) (car o1) o1)
+ (if (listp o2) (car o2) o2)))))
(tpos (+ pos delta ))
(new-pos (max 0 (min (length siblings) tpos)))
(beg (cl-subseq siblings 0 (min pos new-pos)))
(end (cl-subseq siblings (+ 1 (max pos new-pos))))
(p (elt siblings new-pos)))
(when (not (= pos new-pos))
- (setcdr parent-group
- (cl-concatenate 'list
- beg
- (if (> delta 0)
- (list p thing)
- (list thing p))
- end))
+ (let ((th (or (newsticker--group-get-group thing) thing)))
+ (setcdr parent-group
+ (cl-concatenate 'list
+ beg
+ (if (> delta 0)
+ (list p th)
+ (list th p))
+ end)))
(newsticker--treeview-tree-update)
(newsticker-treeview-update)
(newsticker-treeview-jump cur-feed)))))
@@ -2015,36 +2015,37 @@ Return t if groups have changed, nil otherwise."
(defvar newsticker-treeview-mode-map
(let ((map (make-sparse-keymap 'newsticker-treeview-mode-map)))
- (define-key map " " 'newsticker-treeview-next-page)
- (define-key map "a" 'newsticker-add-url)
- (define-key map "b" 'newsticker-treeview-browse-url-item)
- (define-key map "F" 'newsticker-treeview-prev-feed)
- (define-key map "f" 'newsticker-treeview-next-feed)
- (define-key map "g" 'newsticker-treeview-get-news)
- (define-key map "G" 'newsticker-get-all-news)
- (define-key map "i" 'newsticker-treeview-toggle-item-immortal)
- (define-key map "j" 'newsticker-treeview-jump)
- (define-key map "n" 'newsticker-treeview-next-item)
- (define-key map "N" 'newsticker-treeview-next-new-or-immortal-item)
- (define-key map "O" 'newsticker-treeview-mark-list-items-old)
- (define-key map "o" 'newsticker-treeview-mark-item-old)
- (define-key map "p" 'newsticker-treeview-prev-item)
- (define-key map "P" 'newsticker-treeview-prev-new-or-immortal-item)
- (define-key map "q" 'newsticker-treeview-quit)
- (define-key map "S" 'newsticker-treeview-save-item)
- (define-key map "s" 'newsticker-treeview-save)
- (define-key map "u" 'newsticker-treeview-update)
- (define-key map "v" 'newsticker-treeview-browse-url)
- ;;(define-key map "\n" 'newsticker-treeview-scroll-item)
- ;;(define-key map "\C-m" 'newsticker-treeview-scroll-item)
- (define-key map "\M-m" 'newsticker-group-move-feed)
- (define-key map "\M-a" 'newsticker-group-add-group)
- (define-key map "\M-d" 'newsticker-group-delete-group)
- (define-key map "\M-r" 'newsticker-group-rename-group)
- (define-key map [M-down] 'newsticker-group-shift-feed-down)
- (define-key map [M-up] 'newsticker-group-shift-feed-up)
- (define-key map [M-S-down] 'newsticker-group-shift-group-down)
- (define-key map [M-S-up] 'newsticker-group-shift-group-up)
+ (define-key map " " #'newsticker-treeview-next-page)
+ (define-key map "a" #'newsticker-add-url)
+ (define-key map "b" #'newsticker-treeview-browse-url-item)
+ (define-key map "c" #'newsticker-treeview-customize-current-feed)
+ (define-key map "F" #'newsticker-treeview-prev-feed)
+ (define-key map "f" #'newsticker-treeview-next-feed)
+ (define-key map "g" #'newsticker-treeview-get-news)
+ (define-key map "G" #'newsticker-get-all-news)
+ (define-key map "i" #'newsticker-treeview-toggle-item-immortal)
+ (define-key map "j" #'newsticker-treeview-jump)
+ (define-key map "n" #'newsticker-treeview-next-item)
+ (define-key map "N" #'newsticker-treeview-next-new-or-immortal-item)
+ (define-key map "O" #'newsticker-treeview-mark-list-items-old)
+ (define-key map "o" #'newsticker-treeview-mark-item-old)
+ (define-key map "p" #'newsticker-treeview-prev-item)
+ (define-key map "P" #'newsticker-treeview-prev-new-or-immortal-item)
+ (define-key map "q" #'newsticker-treeview-quit)
+ (define-key map "S" #'newsticker-treeview-save-item)
+ (define-key map "s" #'newsticker-treeview-save)
+ (define-key map "u" #'newsticker-treeview-update)
+ (define-key map "v" #'newsticker-treeview-browse-url)
+ ;;(define-key map "\n" #'newsticker-treeview-scroll-item)
+ ;;(define-key map "\C-m" #'newsticker-treeview-scroll-item)
+ (define-key map "\M-m" #'newsticker-group-move-feed)
+ (define-key map "\M-a" #'newsticker-group-add-group)
+ (define-key map "\M-d" #'newsticker-group-delete-group)
+ (define-key map "\M-r" #'newsticker-group-rename-group)
+ (define-key map [M-down] #'newsticker-group-shift-feed-down)
+ (define-key map [M-up] #'newsticker-group-shift-feed-up)
+ (define-key map [M-S-down] #'newsticker-group-shift-group-down)
+ (define-key map [M-S-up] #'newsticker-group-shift-group-up)
map)
"Mode map for newsticker treeview.")
@@ -2052,8 +2053,8 @@ Return t if groups have changed, nil otherwise."
"Major mode for Newsticker Treeview.
\\{newsticker-treeview-mode-map}"
(if (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map)
- newsticker-treeview-tool-bar-map))
+ (setq-local tool-bar-map
+ newsticker-treeview-tool-bar-map))
(setq buffer-read-only t
truncate-lines t))
diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el
index 5a540a21d30..34e94acd12c 100644
--- a/lisp/net/newsticker.el
+++ b/lisp/net/newsticker.el
@@ -54,7 +54,7 @@
;; as well as the following Atom formats:
;; * Atom 0.3
;; * Atom 1.0
-;; (see http://www.ietf.org/internet-drafts/draft-ietf-atompub-format-11.txt)
+;; (see https://www.ietf.org/internet-drafts/draft-ietf-atompub-format-11.txt)
;; That makes Newsticker.el an "Atom aggregator, "RSS reader", "RSS
;; aggregator", and "Feed Reader".
@@ -78,14 +78,6 @@
;; Installation
;; ------------
-;; If you are using Newsticker as part of GNU Emacs there is no need to
-;; perform any installation steps in order to use Newsticker. Otherwise
-;; place Newsticker in a directory where Emacs can find it. Add the
-;; following line to your init file:
-;; (add-to-list 'load-path "/path/to/newsticker/")
-;; (autoload 'newsticker-start "newsticker" "Emacs Newsticker" t)
-;; (autoload 'newsticker-show-news "newsticker" "Emacs Newsticker" t)
-
;; If you are using `imenu', which allows for navigating with the help of a
;; menu, you should add the following to your Emacs startup file
;; (`~/.emacs').
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index f80e8a99516..1d9ee6db86c 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -239,7 +239,7 @@ otherwise."
(mapc
(lambda (info)
(let ((local-ip (nth 1 info))
- (mask (nth 2 info)))
+ (mask (nth 3 info)))
(when
(nsm-network-same-subnet (substring local-ip 0 -1)
(substring mask 0 -1)
@@ -311,9 +311,9 @@ See also: `network-security-protocol-checks' and `nsm-noninteractive'"
(map-values results)
"\n")
"\n")
- "\n* ")))))
- (delete-process process)
- (setq process nil)))
+ "\n* "))))))
+ (delete-process process)
+ (setq process nil))
(run-hook-with-args 'nsm-tls-post-check-functions
host port status settings results)))
process)
@@ -371,7 +371,7 @@ Reference:
Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure
Use of Transport Layer Security (TLS) and Datagram Transport Layer
Security (DTLS)\", \"(4.1. General Guidelines)\"
-`https://tools.ietf.org/html/rfc7525\#section-4.1'"
+`https://tools.ietf.org/html/rfc7525#section-4.1'"
(let ((kx (plist-get status :key-exchange)))
(and (string-match "^\\bRSA\\b" kx)
(format-message
@@ -468,7 +468,7 @@ Reference:
GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous
authentication\",
-`https://www.gnutls.org/manual/gnutls.html\#Anonymous-authentication'"
+`https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'"
(let ((kx (plist-get status :key-exchange)))
(and (string-match "\\bANON\\b" kx)
(format-message
@@ -603,7 +603,7 @@ References:
full SHA-1\", `https://shattered.io/static/shattered.pdf'
[2]: Chromium Security Education TLS/SSL. \"Deprecated and Removed
Features (SHA-1 Certificate Signatures)\",
-`https://www.chromium.org/Home/chromium-security/education/tls\#TOC-SHA-1-Certificate-Signatures'
+`https://www.chromium.org/Home/chromium-security/education/tls#TOC-SHA-1-Certificate-Signatures'
[3]: Jones J.C (2017). \"The end of SHA-1 on the Public Web\",
`https://blog.mozilla.org/security/2017/02/23/the-end-of-sha-1-on-the-public-web/'
[4]: Apple Support (2017). \"Move to SHA-256 signed certificates to
@@ -640,7 +640,7 @@ References:
[1]: Sotirov A, Stevens M et al (2008). \"MD5 considered harmful today
- Creating a rogue CA certificate\",
-`http://www.win.tue.nl/hashclash/rogue-ca/'
+`https://www.win.tue.nl/hashclash/rogue-ca/'
[2]: Turner S, Chen L (2011). \"Updated Security Considerations for
the MD5 Message-Digest and the HMAC-MD5 Algorithms\",
`https://tools.ietf.org/html/rfc6151'"
@@ -964,6 +964,7 @@ protocol."
(defun nsm-write-settings ()
(with-temp-file nsm-settings-file
+ (insert ";;;; -*- mode: lisp-data -*-\n")
(insert "(\n")
(dolist (setting nsm-permanent-host-settings)
(insert " ")
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index c1e9dbb2bc1..0450c80c2ec 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -69,7 +69,6 @@
(require 'md4)
(require 'hmac-md5)
-(require 'calc)
(defgroup ntlm nil
"NTLM (NT LanManager) authentication."
@@ -133,32 +132,93 @@ is not given."
domain ;buffer field
))))
-(defun ntlm-compute-timestamp ()
- "Compute an NTLMv2 timestamp.
+;; Poor man's bignums: natural numbers represented as lists of bytes
+;; in little-endian order.
+;; When this code no longer needs to run on Emacs 26 or older, all this
+;; silliness should be simplified to use ordinary Lisp integers.
+
+(eval-and-compile ; for compile-time simplification
+ (defun ntlm--bignat-of-int (x)
+ "Convert the natural number X into a bignat."
+ (declare (pure t))
+ (and (not (zerop x))
+ (cons (logand x #xff) (ntlm--bignat-of-int (ash x -8)))))
+
+ (defun ntlm--bignat-add (a b &optional carry)
+ "Add the bignats A and B and the natural number CARRY."
+ (declare (pure t))
+ (and (or a b (and carry (not (zerop carry))))
+ (let ((s (+ (if a (car a) 0)
+ (if b (car b) 0)
+ (or carry 0))))
+ (cons (logand s #xff)
+ (ntlm--bignat-add (cdr a) (cdr b) (ash s -8))))))
+
+ (defun ntlm--bignat-shift-left (x n)
+ "Multiply the bignat X by 2^{8N}."
+ (declare (pure t))
+ (if (zerop n) x (ntlm--bignat-shift-left (cons 0 x) (1- n))))
+
+ (defun ntlm--bignat-mul-byte (a b)
+ "Multiply the bignat A with the byte B."
+ (declare (pure t))
+ (let ((p (mapcar (lambda (x) (* x b)) a)))
+ (ntlm--bignat-add
+ (mapcar (lambda (x) (logand x #xff)) p)
+ (cons 0 (mapcar (lambda (x) (ash x -8)) p)))))
+
+ (defun ntlm--bignat-mul (a b)
+ "Multiply the bignats A and B."
+ (declare (pure t))
+ (and a b (ntlm--bignat-add (ntlm--bignat-mul-byte a (car b))
+ (cons 0 (ntlm--bignat-mul a (cdr b))))))
+
+ (defun ntlm--bignat-of-string (s)
+ "Convert the string S (in decimal) to a bignat."
+ (declare (pure t))
+ (ntlm--bignat-of-digits (reverse (string-to-list s))))
+
+ (defun ntlm--bignat-of-digits (digits)
+ "Convert the little-endian list DIGITS of decimal digits to a bignat."
+ (declare (pure t))
+ (and digits
+ (ntlm--bignat-add
+ nil
+ (ntlm--bignat-mul-byte (ntlm--bignat-of-digits (cdr digits)) 10)
+ (- (car digits) ?0))))
+
+ (defun ntlm--bignat-to-int64 (x)
+ "Convert the bignat X to a 64-bit little-endian number as a string."
+ (declare (pure t))
+ (apply #'unibyte-string (mapcar (lambda (n) (or (nth n x) 0))
+ (number-sequence 0 7))))
+ )
+
+(defun ntlm--time-to-timestamp (time)
+ "Convert TIME to an NTLMv2 timestamp.
Return a unibyte string representing the number of tenths of a
microsecond since January 1, 1601 as a 64-bit little-endian
-signed integer."
- ;; FIXME: This can likely be significantly simplified using the new
- ;; bignums support!
- (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)")
- (us-to-tenths-of-us "mul($3,10)")
- (ps-to-tenths-of-us "idiv($4,100000)")
- (tenths-of-us-since-jan-1-1601
- (apply #'calc-eval (concat "add(add(add("
- s-to-tenths-of-us ","
- us-to-tenths-of-us "),"
- ps-to-tenths-of-us "),"
- ;; tenths of microseconds between
- ;; 1601-01-01 and 1970-01-01
- "116444736000000000)")
- 'rawnum (time-convert nil 'list)))
- result-bytes)
- (dotimes (_byte 8)
- (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601)
- result-bytes)
- (setq tenths-of-us-since-jan-1-1601
- (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601)))
- (apply #'unibyte-string (nreverse result-bytes))))
+signed integer. TIME must be on the form (HIGH LOW USEC PSEC)."
+ (let* ((s-hi (ntlm--bignat-of-int (nth 0 time)))
+ (s-lo (ntlm--bignat-of-int (nth 1 time)))
+ (s (ntlm--bignat-add (ntlm--bignat-shift-left s-hi 2) s-lo))
+ (us*10 (ntlm--bignat-of-int (* (nth 2 time) 10)))
+ (ps/1e5 (ntlm--bignat-of-int (/ (nth 3 time) 100000)))
+ ;; tenths of microseconds between 1601-01-01 and 1970-01-01
+ (to-unix-epoch (ntlm--bignat-of-string "116444736000000000"))
+ (tenths-of-us-since-jan-1-1601
+ (ntlm--bignat-add
+ (ntlm--bignat-add
+ (ntlm--bignat-add
+ (ntlm--bignat-mul s (ntlm--bignat-of-int 10000000))
+ us*10)
+ ps/1e5)
+ to-unix-epoch)))
+ (ntlm--bignat-to-int64 tenths-of-us-since-jan-1-1601)))
+
+(defun ntlm-compute-timestamp ()
+ "Current time as an NTLMv2 timestamp, as a unibyte string."
+ (ntlm--time-to-timestamp (time-convert nil 'list)))
(defun ntlm-generate-nonce ()
"Generate a random nonce, not to be used more than once.
diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el
index aa34fe7f1a3..cb49f75c81d 100644
--- a/lisp/net/pop3.el
+++ b/lisp/net/pop3.el
@@ -463,7 +463,7 @@ Return non-nil if it is necessary to update the local UIDL file."
(when (cdr elt)
(insert "(\"" (pop elt) "\"\n ")
(while elt
- (insert (format "\"%s\" %s\n " (pop elt) (pop elt))))
+ (insert (format "%S %s\n " (pop elt) (pop elt))))
(delete-char -4)
(insert ")\n ")))
(delete-char -3)
@@ -725,9 +725,9 @@ Otherwise, return the size of the message-id MSG."
(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)))))
+ (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)
diff --git a/lisp/net/puny.el b/lisp/net/puny.el
index fc17730f5a4..42a7e796798 100644
--- a/lisp/net/puny.el
+++ b/lisp/net/puny.el
@@ -1,4 +1,4 @@
-;;; puny.el --- translate non-ASCII domain names to ASCII
+;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
;;; Commentary:
;; Written by looking at
-;; http://stackoverflow.com/questions/183485/can-anyone-recommend-a-good-free-javascript-for-punycode-to-unicode-conversion
+;; https://stackoverflow.com/questions/183485/can-anyone-recommend-a-good-free-javascript-for-punycode-to-unicode-conversion
;;; Code:
@@ -35,9 +35,9 @@
For instance, \"fśf.org\" => \"xn--ff-2sa.org\"."
;; The vast majority of domain names are not IDNA domain names, so
;; add a check first to avoid doing unnecessary work.
- (if (string-match "\\'[[:ascii:]]+\\'" domain)
+ (if (string-match "\\`[[:ascii:]]+\\'" domain)
domain
- (mapconcat 'puny-encode-string (split-string domain "[.]") ".")))
+ (mapconcat #'puny-encode-string (split-string domain "[.]") ".")))
(defun puny-encode-string (string)
"Encode STRING according to the IDNA/punycode algorithm.
@@ -57,7 +57,7 @@ For instance, \"bücher\" => \"xn--bcher-kva\"."
(defun puny-decode-domain (domain)
"Decode DOMAIN according to the IDNA/punycode algorithm.
For instance, \"xn--ff-2sa.org\" => \"fśf.org\"."
- (mapconcat 'puny-decode-string (split-string domain "[.]") "."))
+ (mapconcat #'puny-decode-string (split-string domain "[.]") "."))
(defun puny-decode-string (string)
"Decode an IDNA/punycode-encoded string.
@@ -75,7 +75,7 @@ For instance \"xn--bcher-kva\" => \"bücher\"."
(defconst puny-damp 700)
(defconst puny-tmin 1)
(defconst puny-tmax 26)
-(defconst puny-skew 28)
+(defconst puny-skew 38)
;; 0-25 a-z
;; 26-36 0-9
@@ -196,12 +196,12 @@ For instance \"xn--bcher-kva\" => \"bücher\"."
(cl-incf i)))
(buffer-string)))
-;; http://www.unicode.org/reports/tr39/#Restriction_Level_Detection
-;; http://www.unicode.org/reports/tr31/#Table_Candidate_Characters_for_Inclusion_in_Identifiers
+;; https://www.unicode.org/reports/tr39/#Restriction_Level_Detection
+;; https://www.unicode.org/reports/tr31/#Table_Candidate_Characters_for_Inclusion_in_Identifiers
(defun puny-highly-restrictive-string-p (string)
"Say whether STRING is \"highly restrictive\" in the Unicode IDNA sense.
-See http://www.unicode.org/reports/tr39/#Restriction_Level_Detection
+See https://www.unicode.org/reports/tr39/#Restriction_Level_Detection
for details. The main idea is that if you're mixing
scripts (like latin and cyrillic), you may confuse the user by
using homographs."
diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el
index ab1f43f552b..2574c8cb63e 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -1,4 +1,4 @@
-;;; quickurl.el --- insert a URL based on text at point in buffer
+;;; quickurl.el --- insert a URL based on text at point in buffer -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -97,23 +97,19 @@
(locate-user-emacs-file "quickurls" ".quickurls")
"File that contains the URL list."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'quickurl)
+ :type 'file)
(defcustom quickurl-format-function #'quickurl-format-url
"Function to format the URL before insertion into the current buffer."
- :type 'function
- :group 'quickurl)
+ :type 'function)
(defcustom quickurl-sort-function #'quickurl-sort-urls
"Function to sort the URL list."
- :type 'function
- :group 'quickurl)
+ :type 'function)
(defcustom quickurl-grab-lookup-function #'current-word
"Function to grab the thing to lookup."
- :type 'function
- :group 'quickurl)
+ :type 'function)
(defun quickurl--assoc-function (key alist)
"Default function for `quickurl-assoc-function'."
@@ -122,31 +118,26 @@
(defcustom quickurl-assoc-function #'quickurl--assoc-function
"Function to use for alist lookup into `quickurl-urls'."
:version "26.1" ; was the obsolete assoc-ignore-case
- :type 'function
- :group 'quickurl)
+ :type 'function)
(defcustom quickurl-completion-ignore-case t
"Should `quickurl-ask' ignore case when doing the input lookup?"
- :type 'boolean
- :group 'quickurl)
+ :type 'boolean)
(defcustom quickurl-prefix ";; -*- lisp -*-\n\n"
"Text to write to `quickurl-url-file' before writing the URL list."
- :type 'string
- :group 'quickurl)
+ :type 'string)
(defcustom quickurl-postfix ""
"Text to write to `quickurl-url-file' after writing the URL list.
See the constant `quickurl-reread-hook-postfix' for some example text that
could be used here."
- :type 'string
- :group 'quickurl)
+ :type 'string)
(defcustom quickurl-list-mode-hook nil
"Hooks for `quickurl-list-mode'."
- :type 'hook
- :group 'quickurl)
+ :type 'hook)
;; Constants.
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index d4472572d6b..f11f36e8096 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -25,7 +25,7 @@
;;; Commentary:
;; Internet Relay Chat (IRC) is a form of instant communication over
-;; the Internet. It is mainly designed for group (many-to-many)
+;; the Internet. It is mainly designed for group (many-to-many)
;; communication in discussion forums called channels, but also allows
;; one-to-one communication.
@@ -44,7 +44,10 @@
(require 'cl-lib)
(require 'ring)
(require 'time-date)
+(require 'auth-source)
+(require 'parse-time)
(eval-when-compile (require 'subr-x))
+(eval-when-compile (require 'rx))
(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version))
@@ -56,10 +59,10 @@
:group 'applications)
(defcustom rcirc-server-alist
- '(("irc.libera.chat" :channels ("#rcirc")
- ;; Don't use the TLS port by default, in case gnutls is not available.
- ;; :port 6697 :encryption tls
- ))
+ (if (gnutls-available-p)
+ '(("irc.libera.chat" :channels ("#rcirc")
+ :port 6697 :encryption tls))
+ '(("irc.libera.chat" :channels ("#rcirc"))))
"An alist of IRC connections to establish when running `rcirc'.
Each element looks like (SERVER-NAME PARAMETERS).
@@ -108,8 +111,9 @@ for connections using SSL/TLS.
`:server-alias'
-VALUE must be a string that will be used instead of the server name for
-display purposes. If absent, the real server name will be displayed instead."
+VALUE must be a string that will be used instead of the server
+name for display purposes. If absent, the real server name will
+be displayed instead."
:type '(alist :key-type string
:value-type (plist :options
((:nick string)
@@ -120,7 +124,8 @@ display purposes. If absent, the real server name will be displayed instead."
(:channels (repeat string))
(:encryption (choice (const tls)
(const plain)))
- (:server-alias string)))))
+ (:server-alias string))))
+ :version "28.1")
(defcustom rcirc-default-port 6667
"The default port to connect to."
@@ -178,27 +183,37 @@ If nil, no maximum is applied."
:type '(choice (const :tag "No maximum" nil)
(integer :tag "Number of characters")))
-(defvar rcirc-ignore-buffer-activity-flag nil
- "If non-nil, ignore activity in this buffer.")
-(make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag)
+(defvar-local rcirc-ignore-buffer-activity-flag nil
+ "Non-nil means ignore activity in this buffer.")
-(defvar rcirc-low-priority-flag nil
- "If non-nil, activity in this buffer is considered low priority.")
-(make-variable-buffer-local 'rcirc-low-priority-flag)
+(defvar-local rcirc-low-priority-flag nil
+ "Non-nil means activity in this buffer is considered low priority.")
(defcustom rcirc-omit-responses
'("JOIN" "PART" "QUIT" "NICK")
"Responses which will be hidden when `rcirc-omit-mode' is enabled."
:type '(repeat string))
-(defvar rcirc-prompt-start-marker nil)
+(defcustom rcirc-omit-after-reconnect
+ '("JOIN" "TOPIC" "NAMES")
+ "Types of messages to hide right after reconnecting."
+ :type '(repeat string)
+ :version "28.1")
+
+(defvar-local rcirc-reconncting nil
+ "Non-nil means we have just reconnected.
+This is used to hide the message types enumerated in
+`rcirc-supress-after-reconnect'.")
+
+(defvar-local rcirc-prompt-start-marker nil
+ "Marker indicating the beginning of the message prompt.")
(define-minor-mode rcirc-omit-mode
"Toggle the hiding of \"uninteresting\" lines.
Uninteresting lines are those whose responses are listed in
`rcirc-omit-responses'."
- nil " Omit" nil
+ :lighter " Omit"
(if rcirc-omit-mode
(progn
(add-to-invisibility-spec '(rcirc-omit . nil))
@@ -230,8 +245,7 @@ number. If zero or nil, no truncating is done."
(integer :tag "Number of lines")))
(defcustom rcirc-scroll-show-maximum-output t
- "If non-nil, scroll buffer to keep the point at the bottom of
-the window."
+ "Non-nil means scroll to keep the point at the bottom of the window."
:type 'boolean)
(defcustom rcirc-authinfo nil
@@ -247,14 +261,16 @@ The ARGUMENTS for each METHOD symbol are:
`chanserv': NICK CHANNEL PASSWORD
`bitlbee': NICK PASSWORD
`quakenet': ACCOUNT PASSWORD
+ `sasl': NICK PASSWORD
Examples:
((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\")
(\"Libera.Chat\" chanserv \"bob\" \"#bobland\" \"passwd99\")
(\"bitlbee\" bitlbee \"robert\" \"sekrit\")
(\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\")
- (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))"
- :type '(alist :key-type (string :tag "Server")
+ (\"quakenet.org\" quakenet \"bobby\" \"sekrit\")
+ (\"oftc\" sasl \"bob\" \"hunter2\"))"
+ :type '(alist :key-type (regexp :tag "Server")
:value-type (choice (list :tag "NickServ"
(const nickserv)
(string :tag "Nick")
@@ -271,6 +287,10 @@ Examples:
(list :tag "QuakeNet"
(const quakenet)
(string :tag "Account")
+ (string :tag "Password"))
+ (list :tag "SASL"
+ (const sasl)
+ (string :tag "Nick")
(string :tag "Password")))))
(defcustom rcirc-auto-authenticate-flag t
@@ -292,10 +312,11 @@ The following replacements are made:
%s is the server.
%t is the buffer target, a channel or a user.
-Setting this alone will not affect the prompt;
-use either M-x customize or also call `rcirc-update-prompt'."
+Setting this alone will not affect the prompt; use either
+\\[execute-extended-command] customize or also call
+`rcirc-update-prompt'."
:type 'string
- :set 'rcirc-set-changed
+ :set #'rcirc-set-changed
:initialize 'custom-initialize-default)
(defcustom rcirc-keywords nil
@@ -331,7 +352,8 @@ Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT."
:type 'hook)
(defvar rcirc-authenticated-hook nil
- "Hook run after successfully authenticated.")
+ "Hook run after successfully authenticated.
+Functions in this hook are called with a single argument PROCESS.")
(defcustom rcirc-always-use-server-buffer-flag nil
"Non-nil means messages without a channel target will go to the server buffer."
@@ -359,9 +381,9 @@ If VAL is a coding system, it is used for both decoding and encoding
messages.
If VAL is a cons of coding systems, the car part is used for decoding,
and the cdr part is used for encoding."
- :type '(alist :key-type (choice (string :tag "Channel Regexp")
- (cons (string :tag "Channel Regexp")
- (string :tag "Server Regexp")))
+ :type '(alist :key-type (choice (regexp :tag "Channel Regexp")
+ (cons (regexp :tag "Channel Regexp")
+ (regexp :tag "Server Regexp")))
:value-type (choice coding-system
(cons (coding-system :tag "Decode")
(coding-system :tag "Encode")))))
@@ -386,13 +408,21 @@ will be killed."
:version "24.3"
:type 'boolean)
-(defvar rcirc-nick nil)
+(defcustom rcirc-nick-filter #'identity
+ "Function applied to nicknames before displaying."
+ :version "28.1"
+ :type 'function)
+
+(defvar-local rcirc-nick nil
+ "The nickname used for the current connection.")
-(defvar rcirc-prompt-end-marker nil)
+(defvar-local rcirc-prompt-end-marker nil
+ "Marker indicating the end of the message prompt.")
-(defvar rcirc-nick-table nil)
+(defvar-local rcirc-nick-table nil
+ "Hash table mapping nicks to channels.")
-(defvar rcirc-recent-quit-alist nil
+(defvar-local rcirc-recent-quit-alist nil
"Alist of nicks that have recently quit or parted the channel.")
(defvar rcirc-nick-syntax-table
@@ -403,8 +433,8 @@ will be killed."
table)
"Syntax table which includes all nick characters as word constituents.")
-;; each process has an alist of (target . buffer) pairs
-(defvar rcirc-buffer-alist nil)
+(defvar-local rcirc-buffer-alist nil
+ "Alist of (TARGET . BUFFER) pairs.")
(defvar rcirc-activity nil
"List of buffers with unviewed activity.")
@@ -413,13 +443,16 @@ will be killed."
"String displayed in mode line representing `rcirc-activity'.")
(put 'rcirc-activity-string 'risky-local-variable t)
-(defvar rcirc-server-buffer nil
+(defvar-local rcirc-server-buffer nil
"The server buffer associated with this channel buffer.")
-(defvar rcirc-target nil
+(defvar-local rcirc-server-parameters nil
+ "List of parameters received from the server.")
+
+(defvar-local rcirc-target nil
"The channel or user associated with this buffer.")
-(defvar rcirc-urls nil
+(defvar-local rcirc-urls nil
"List of URLs seen in the current buffer and their start positions.")
(put 'rcirc-urls 'permanent-local t)
@@ -427,7 +460,8 @@ will be killed."
"Kill connection after this many seconds if there is no activity.")
-(defvar rcirc-startup-channels nil)
+(defvar-local rcirc-startup-channels nil
+ "List of channel names to join after authenticating.")
(defvar rcirc-server-name-history nil
"History variable for \\[rcirc] call.")
@@ -497,6 +531,12 @@ If ARG is non-nil, instead prompt for connection parameters."
(encryption (plist-get (cdr c) :encryption))
(server-alias (plist-get (cdr c) :server-alias))
contact)
+ (when-let (((not password))
+ (auth (auth-source-search :host server
+ :user user-name
+ :port port))
+ (fn (plist-get (car auth) :secret)))
+ (setq password (funcall fn)))
(when server
(let (connected)
(dolist (p (rcirc-process-list))
@@ -528,23 +568,78 @@ If ARG is non-nil, instead prompt for connection parameters."
(defalias 'irc 'rcirc)
-(defvar rcirc-process-output nil)
-(defvar rcirc-topic nil)
-(defvar rcirc-keepalive-timer nil)
-(defvar rcirc-last-server-message-time nil)
-(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-connection-info nil)
-(defvar rcirc-process nil)
+(defvar-local rcirc-process-output nil
+ "Partial message response.")
+(defvar-local rcirc-topic nil
+ "Topic of the current channel.")
+(defvar rcirc-keepalive-timer nil
+ "Timer for sending KEEPALIVE message.")
+(defvar-local rcirc-last-server-message-time nil
+ "Timestamp for the last server response.")
+(defvar-local rcirc-server nil
+ "Server provided by server.")
+(defvar-local rcirc-server-name nil
+ "Server name given by 001 response.")
+(defvar-local rcirc-timeout-timer nil
+ "Timer for determining a network timeout.")
+(defvar-local rcirc-user-authenticated nil
+ "Flag indicating if the user is authenticated.")
+(defvar-local rcirc-user-disconnect nil
+ "Flag indicating if the connection was broken.")
+(defvar-local rcirc-connecting nil
+ "Flag indicating if the connection is being established.")
+(defvar-local rcirc-connection-info nil
+ "Information about the current connection.
+If defined, it is a list of this form (SERVER PORT NICK USER-NAME
+FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS).
+See `rcirc-connect' for more details on these variables.")
+(defvar-local rcirc-process nil
+ "Network process for the current connection.")
+
+;;; IRCv3 capability negotiation (https://ircv3.net/specs/extensions/capability-negotiation)
+(defvar rcirc-implemented-capabilities
+ '("message-tags" ;https://ircv3.net/specs/extensions/message-tags
+ "server-time" ;https://ircv3.net/specs/extensions/server-time
+ "batch" ;https://ircv3.net/specs/extensions/batch
+ "message-ids" ;https://ircv3.net/specs/extensions/message-ids
+ "invite-notify" ;https://ircv3.net/specs/extensions/invite-notify
+ "sasl" ;https://ircv3.net/specs/extensions/sasl-3.1
+ )
+ "A list of capabilities that rcirc supports.")
+(defvar-local rcirc-requested-capabilities nil
+ "A list of capabilities that client has requested.")
+(defvar-local rcirc-acked-capabilities nil
+ "A list of capabilities that the server supports.")
+(defvar-local rcirc-finished-sasl t
+ "Check whether SASL authentication has completed")
+
+(defun rcirc-get-server-method (server)
+ "Return authentication method for SERVER."
+ (catch 'method
+ (dolist (i rcirc-authinfo)
+ (let ((server-i (car i))
+ (method (cadr i)))
+ (when (string-match server-i server)
+ (throw 'method method))))))
+
+(defun rcirc-get-server-password (server)
+ "Return password for SERVER."
+ (catch 'pass
+ (dolist (i rcirc-authinfo)
+ (let ((server-i (car i))
+ (args (cdddr i)))
+ (when (string-match server-i server)
+ (throw 'pass (car args)))))))
;;;###autoload
(defun rcirc-connect (server &optional port nick user-name
full-name startup-channels password encryption
server-alias)
+ "Connect to SERVER.
+The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD,
+ENCRYPTION, SERVER-ALIAS are interpreted as in
+`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels
+that are joined after authentication."
(save-excursion
(message "Connecting to %s..." (or server-alias server))
(let* ((inhibit-eol-conversion)
@@ -557,6 +652,7 @@ 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)
+ (use-sasl (eq (rcirc-get-server-method server) 'sasl))
(process (open-network-stream
(or server-alias server) nil server port-number
:type (or encryption 'plain))))
@@ -564,37 +660,42 @@ If ARG is non-nil, instead prompt for connection parameters."
(set-process-coding-system process 'raw-text 'raw-text)
(switch-to-buffer (rcirc-generate-new-buffer-name process nil))
(set-process-buffer process (current-buffer))
- (rcirc-mode process nil)
+ (unless (eq major-mode 'rcirc-mode)
+ (rcirc-mode process nil))
(set-process-sentinel process 'rcirc-sentinel)
(set-process-filter process 'rcirc-filter)
- (setq-local rcirc-connection-info
- (list server port nick user-name full-name startup-channels
- password encryption server-alias))
- (setq-local rcirc-process process)
- (setq-local rcirc-server server)
- (setq-local rcirc-server-name
- (or server-alias server)) ; Update when we get 001 response.
- (setq-local rcirc-buffer-alist nil)
- (setq-local rcirc-nick-table (make-hash-table :test 'equal))
- (setq-local rcirc-nick nick)
- (setq-local rcirc-process-output nil)
- (setq-local rcirc-startup-channels startup-channels)
- (setq-local rcirc-last-server-message-time (current-time))
-
- (setq-local rcirc-timeout-timer nil)
- (setq-local rcirc-user-disconnect nil)
- (setq-local rcirc-user-authenticated nil)
- (setq-local rcirc-connecting t)
+ (setq rcirc-connection-info
+ (list server port nick user-name full-name startup-channels
+ password encryption server-alias))
+ (setq rcirc-process process)
+ (setq rcirc-server server)
+ (setq rcirc-server-name (or server-alias server)) ; Update when we get 001 response.
+ (setq rcirc-nick-table (make-hash-table :test 'equal))
+ (setq rcirc-nick nick)
+ (setq rcirc-startup-channels startup-channels)
+ (setq rcirc-last-server-message-time (current-time))
+
+ (setq rcirc-connecting t)
(add-hook 'auto-save-hook 'rcirc-log-write)
+ (when use-sasl
+ (rcirc-send-string process "CAP REQ sasl"))
+ (when use-sasl
+ (setq-local rcirc-finished-sasl nil))
;; identify
+ (dolist (cap rcirc-implemented-capabilities)
+ (rcirc-send-string process "CAP" "REQ" : cap)
+ (push cap rcirc-requested-capabilities))
(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
- " 0 * :" full-name))
+ (rcirc-send-string process "PASS" password))
+ (rcirc-send-string process "NICK" nick)
+ (rcirc-send-string process "USER" user-name "0" "*" : full-name)
+ ;; Setup sasl, and initiate authentication.
+ (when (and rcirc-auto-authenticate-flag
+ use-sasl)
+ (rcirc-send-string process "AUTHENTICATE" "PLAIN"))
;; setup ping timer if necessary
(unless rcirc-keepalive-timer
@@ -602,31 +703,33 @@ If ARG is non-nil, instead prompt for connection parameters."
(run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive)))
(message "Connecting to %s...done" (or server-alias server))
+ (setq mode-line-process nil)
;; return process object
process)))
(defmacro with-rcirc-process-buffer (process &rest body)
+ "Evaluate BODY in the buffer of PROCESS."
(declare (indent 1) (debug t))
`(with-current-buffer (process-buffer ,process)
,@body))
(defmacro with-rcirc-server-buffer (&rest body)
+ "Evaluate BODY in the server buffer of the current channel."
(declare (indent 0) (debug t))
- `(with-current-buffer rcirc-server-buffer
- ,@body))
+ `(if (buffer-live-p rcirc-server-buffer)
+ (with-current-buffer rcirc-server-buffer
+ ,@body)
+ (user-error "Server buffer was killed")))
(define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1")
(defun rcirc-prompt-for-encryption (server-plist)
"Prompt the user for the encryption method to use.
SERVER-PLIST is the property list for the server."
- (let ((choices '("plain" "tls"))
- (default (or (plist-get server-plist :encryption)
- "plain")))
- (intern
- (completing-read (format "Encryption (default %s): " default)
- choices nil t nil nil default))))
+ (if (or (eq (plist-get server-plist :encryption) 'plain)
+ (yes-or-no-p "Encrypt connection?"))
+ 'tls 'plain))
(defun rcirc-keepalive ()
"Send keep alive pings to active rcirc processes.
@@ -647,14 +750,18 @@ last ping."
(setq rcirc-keepalive-timer nil)))
(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message)
+ "Uptime header in PROCESS buffer.
+MESSAGE should contain a timestamp, indicating when the KEEPALIVE
+message was generated."
(with-rcirc-process-buffer process
(setq header-line-format
(format "%f" (float-time
(time-since (string-to-number message)))))))
-(defvar rcirc-debug-buffer "*rcirc debug*")
+(defvar rcirc-debug-buffer "*rcirc debug*"
+ "Buffer name for debugging messages.")
(defvar rcirc-debug-flag nil
- "If non-nil, write information to `rcirc-debug-buffer'.")
+ "Non-nil means write information to `rcirc-debug-buffer'.")
(defun rcirc-debug (process text)
"Add an entry to the debug log including PROCESS and TEXT.
Debug text is appended to `rcirc-debug-buffer' if `rcirc-debug-flag'
@@ -688,7 +795,7 @@ When 0, do not auto-reconnect."
:version "25.1"
:type 'integer)
-(defvar rcirc-last-connect-time nil
+(defvar-local rcirc-last-connect-time nil
"The last time the buffer was connected.")
(defun rcirc-sentinel (process sentinel)
@@ -716,6 +823,8 @@ When 0, do not auto-reconnect."
(run-hook-with-args 'rcirc-sentinel-functions process sentinel))))
(defun rcirc-disconnect-buffer (&optional buffer)
+ "Disconnect BUFFER.
+If BUFFER is nil, default to the current buffer."
(with-current-buffer (or buffer (current-buffer))
;; set rcirc-target to nil for each channel so cleanup
;; doesn't happen when we reconnect
@@ -753,19 +862,19 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(rcirc-process-server-response process line))))))
(defun rcirc-reschedule-timeout (process)
+ "Update timeout indicator for PROCESS."
(with-rcirc-process-buffer process
(when (not rcirc-connecting)
(with-rcirc-process-buffer process
(when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer))
(setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil
- 'rcirc-delete-process
+ 'delete-process
process))))))
-(defun rcirc-delete-process (process)
- (delete-process process))
-
-(defvar rcirc-trap-errors-flag t)
+(defvar rcirc-trap-errors-flag t
+ "Non-nil means Lisp errors are degraded to error messages.")
(defun rcirc-process-server-response (process text)
+ "Parse TEXT as received from PROCESS."
(if rcirc-trap-errors-flag
(condition-case err
(rcirc-process-server-response-1 process text)
@@ -774,17 +883,91 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(format "\"%s\" %s" text err) t)))
(rcirc-process-server-response-1 process text)))
+(defconst rcirc-process-regexp
+ (rx-let ((message-tag ; message tags as specified in
+ ; https://ircv3.net/specs/extensions/message-tags
+ (: (? "+")
+ (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/")
+ (+ (any alnum "-"))
+ (? "="
+ (* (not (any 0 ?\n ?\r ?\; ?\s)))))))
+ (rx line-start
+ (optional "@" (group message-tag (* ";" message-tag)) (+ space))
+ ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1.
+ ;; We're a bit more accepting than the RFC: We allow any non-space
+ ;; characters in the command name, multiple spaces between
+ ;; arguments, and allow the last argument to omit the leading ":",
+ ;; even if there are less than 15 arguments.
+ (optional
+ (group ":" (group (one-or-more (not (any " ")))) " "))
+ (group (one-or-more (not (any " "))))))
+ "Regular expression used for parsing server response.")
+
+(defconst rcirc-tag-regexp
+ (rx bos
+ (group
+ (? "+")
+ (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/")
+ (+ (any alnum "-")))
+ (? "=" (group (* (not (any 0 ?\n ?\r ?\; ?\s)))))
+ eos)
+ "Regular expression used for destructing a tag.")
+
+(defvar rcirc-message-tags nil
+ "Alist of parsed message tags.")
+
+(defvar rcirc-supported-batch-types
+ '()
+ "List of recognized batch types.
+Each element has the form (TYPE HANDLE), where TYPE is a string
+and HANDLE is either the symbol `immediate' or `deferred'.
+Messages in an immediate batch are handled just like regular
+messages, while deferred messages are stored in
+`rcirc-batch-messages'.")
+
+(defvar-local rcirc-batch-attributes nil
+ "Alist mapping batch IDs to parameters.")
+
+(defvar-local rcirc-batched-messages nil
+ "Alist mapping batch IDs to deferred messages.
+Note that the messages are stored in reverse order.")
+
+(defsubst rcirc-get-tag (key &optional default)
+ "Return tag value for KEY or DEFAULT."
+ (alist-get key rcirc-message-tags default nil #'string=))
+
(defun rcirc-process-server-response-1 (process text)
- ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. We're a
- ;; bit more accepting than the RFC: We allow any non-space
- ;; characters in the command name, multiple spaces between
- ;; arguments, and allow the last argument to omit the leading ":",
- ;; even if there are less than 15 arguments.
- (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\)" text)
- (let* ((user (match-string 2 text))
+ "Parse TEXT as received from PROCESS."
+ (if (string-match rcirc-process-regexp text)
+ (let* ((rcirc-message-tags
+ (append
+ (and-let* ((tag-data (match-string 1 text)))
+ (save-match-data
+ (mapcar
+ (lambda (tag)
+ (unless (string-match rcirc-tag-regexp tag)
+ ;; This should not happen, unless there is
+ ;; a mismatch between this regular
+ ;; expression and `rcirc-process-regexp'.
+ (error "Malformed tag %S" tag))
+ (cons (match-string 1 tag)
+ (replace-regexp-in-string
+ (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n))
+ (lambda (rep)
+ (concat (substring rep 0 -2)
+ (cl-case (aref rep (1- (length rep)))
+ (?: ";")
+ (?s " ")
+ (?\\ "\\\\")
+ (?r "\r")
+ (?n "\n"))))
+ (match-string 2 tag))))
+ (split-string tag-data ";"))))
+ rcirc-message-tags))
+ (user (match-string 3 text))
(sender (rcirc-user-nick user))
- (cmd (match-string 3 text))
- (cmd-end (match-end 3))
+ (cmd (match-string 4 text))
+ (cmd-end (match-end 4))
(args nil)
(handler (intern-soft (concat "rcirc-handler-" cmd))))
(cl-loop with i = cmd-end
@@ -797,9 +980,18 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(push (substring text (match-end 0)) args)
(cl-assert (= i (length text))))
(cl-callf nreverse args)))
- (if (not (fboundp handler))
- (rcirc-handler-generic process cmd sender args text)
- (funcall handler process sender args text))
+ (cond ((and-let* ((batch-id (rcirc-get-tag "batch"))
+ (type (cadr (assoc batch-id rcirc-batch-attributes)))
+ (attr (assoc type rcirc-supported-batch-types))
+ ((eq (cadr attr) 'deferred)))
+ ;; handle deferred batch messages later
+ (push (list cmd process sender args text rcirc-message-tags)
+ (alist-get batch-id rcirc-batched-messages
+ nil nil #'string=))
+ t))
+ ((not (fboundp handler))
+ (rcirc-handler-generic process cmd sender args text))
+ ((funcall handler process sender args text)))
(run-hook-with-args 'rcirc-receive-message-functions
process cmd sender args text))
(message "UNHANDLED: %s" text)))
@@ -808,17 +1000,34 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
"Responses that don't trigger activity in the mode-line indicator.")
(defun rcirc-handler-generic (process response sender args _text)
- "Generic server response handler."
+ "Generic server response handler.
+This handler is called, when no more specific handler could be
+found. PROCESS, SENDER and RESPONSE are passed on to
+`rcirc-print'. ARGS are concatenated into a single string and
+used as the message body."
(rcirc-print process sender response nil
(mapconcat 'identity (cdr args) " ")
(not (member response rcirc-responses-no-activity))))
(defun rcirc--connection-open-p (process)
+ "Check if PROCESS is open or running."
(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)
+(defun rcirc-send-string (process &rest parts)
+ "Send PROCESS a PARTS plus a newline.
+PARTS may contain a `:' symbol, to designate that the next string
+is the message, that should be prefixed by a colon. If the last
+element in PARTS is a list, append it to PARTS."
+ (let ((last (car (last parts))))
+ (when (listp last)
+ (setf parts (append (butlast parts) last))))
+ (when-let (message (memq : parts))
+ (cl-check-type (cadr message) string)
+ (setf (cadr message) (concat ":" (cadr message))
+ parts (remq : parts)))
+ (let ((string (concat (encode-coding-string
+ (mapconcat #'identity parts " ")
+ rcirc-encode-coding-system)
"\n")))
(unless (rcirc--connection-open-p process)
(error "Network connection to %s is not open"
@@ -827,13 +1036,17 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(process-send-string process string)))
(defun rcirc-send-privmsg (process target string)
+ "Send TARGET the message in STRING via PROCESS."
(cl-check-type target string)
- (rcirc-send-string process (format "PRIVMSG %s :%s" target string)))
+ (rcirc-send-string process "PRIVMSG" target : string))
+
+(defun rcirc-ctcp-wrap (&rest args)
+ "Join ARGS into a string wrapped by ASCII 1 charterers."
+ (concat "\C-a" (string-join (delq nil args) " ") "\C-a"))
(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))))
+ "Send TARGET a REQUEST via PROCESS."
+ (rcirc-send-privmsg process target (rcirc-ctcp-wrap request args)))
(defun rcirc-buffer-process (&optional buffer)
"Return the process associated with channel BUFFER.
@@ -859,7 +1072,7 @@ With no argument or nil as argument, use the current buffer."
"Return the nick associated with BUFFER.
With no argument or nil as argument, use the current buffer."
(with-current-buffer (or buffer (current-buffer))
- (with-current-buffer rcirc-server-buffer
+ (with-rcirc-server-buffer
(or rcirc-nick rcirc-default-nick))))
(defvar rcirc-max-message-length 420
@@ -892,17 +1105,22 @@ If SILENT is non-nil, do not print the message in any irc buffer."
(let ((response (if noticep "NOTICE" "PRIVMSG")))
(rcirc-get-buffer-create process target)
(dolist (msg (rcirc-split-message message))
- (rcirc-send-string process (concat response " " target " :" msg))
+ (rcirc-send-string process response target : msg)
(unless silent
(rcirc-print process (rcirc-nick process) response target msg)))))
-(defvar rcirc-input-ring nil)
-(defvar rcirc-input-ring-index 0)
+(defvar-local rcirc-input-ring nil
+ "Ring object for input.")
+
+(defvar-local rcirc-input-ring-index 0
+ "Current position in the input ring.")
(defun rcirc-prev-input-string (arg)
+ "Move ARG elements ahead in the input ring."
(ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg)))
(defun rcirc-insert-prev-input ()
+ "Insert previous element in input ring."
(interactive)
(when (<= rcirc-prompt-end-marker (point))
(delete-region rcirc-prompt-end-marker (point-max))
@@ -910,6 +1128,7 @@ If SILENT is non-nil, do not print the message in any irc buffer."
(setq rcirc-input-ring-index (1+ rcirc-input-ring-index))))
(defun rcirc-insert-next-input ()
+ "Insert next element in input ring."
(interactive)
(when (<= rcirc-prompt-end-marker (point))
(delete-region rcirc-prompt-end-marker (point-max))
@@ -943,63 +1162,62 @@ The list is updated automatically by `defun-rcirc-command'.")
(if (re-search-backward "[[:space:]@]" 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-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-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."
+ (table (cond
+ ;; No completion before the prompt
+ ((< beg rcirc-prompt-end-marker) nil)
+ ;; Only complete nicks mid-message
+ ((> beg rcirc-prompt-end-marker)
+ (mapcar rcirc-nick-filter
+ (rcirc-channel-nicks
+ (rcirc-buffer-process)
+ rcirc-target)))
+ ;; Complete commands at the beginning of the
+ ;; message, when the first character is a dash
+ ((eq (char-after beg) ?/)
+ (mapcar
+ (lambda (cmd) (concat cmd " "))
+ (nconc (sort (copy-sequence rcirc-client-commands)
+ 'string-lessp)
+ (sort (copy-sequence rcirc-server-commands)
+ 'string-lessp))))
+ ;; Complete usernames right after the prompt by
+ ;; appending a colon after the name
+ ((mapcar
+ (lambda (str) (concat (funcall rcirc-nick-filter str) ": "))
+ (rcirc-channel-nicks (rcirc-buffer-process)
+ rcirc-target))))))
+ (list beg (point)
+ (lambda (str pred action)
+ (if (eq action 'metadata)
+ '(metadata (cycle-sort-function . identity))
+ (complete-with-action action table str pred)))))))
+
+(defun rcirc-set-decode-coding-system (coding-system)
+ "Set the decode CODING-SYSTEM used in this channel."
(interactive "zCoding system for incoming messages: ")
(setq-local rcirc-decode-coding-system coding-system))
-(defun set-rcirc-encode-coding-system (coding-system)
- "Set the encode coding system used in this channel."
+(define-obsolete-function-alias
+ 'rcirc-set-decode-coding-system
+ 'set-rcirc-decode-coding-system
+ "28.1")
+
+(defun rcirc-set-encode-coding-system (coding-system)
+ "Set the encode CODING-SYSTEM used in this channel."
(interactive "zCoding system for outgoing messages: ")
(setq-local rcirc-encode-coding-system coding-system))
+(define-obsolete-function-alias
+ 'rcirc-set-encode-coding-system
+ 'set-rcirc-encode-coding-system
+ "28.1")
+
(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 "TAB") 'completion-at-point)
(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)
@@ -1022,34 +1240,35 @@ IRC command completion is performed only if `/' is the first input char."
map)
"Keymap for rcirc mode.")
-(defvar rcirc-short-buffer-name nil
+(defvar-local rcirc-short-buffer-name nil
"Generated abbreviation to use to indicate buffer activity.")
(defvar rcirc-mode-hook nil
"Hook run when setting up rcirc buffer.")
-(defvar rcirc-last-post-time nil)
+(defvar-local rcirc-last-post-time nil
+ "Timestamp indicating last user action.")
(defvar rcirc-log-alist nil
"Alist of lines to log to disk when `rcirc-log-flag' is non-nil.
Each element looks like (FILENAME . TEXT).")
-(defvar rcirc-current-line 0
+(defvar-local rcirc-current-line 0
"The current number of responses printed in this channel.
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}"
+ ;; FIXME: Use define-derived-mode.
(kill-all-local-variables)
(use-local-map rcirc-mode-map)
(setq mode-name "rcirc")
(setq major-mode 'rcirc-mode)
(setq mode-line-process nil)
- (setq-local rcirc-input-ring
+ (setq rcirc-input-ring
;; If rcirc-input-ring is already a ring with desired
;; size do not re-initialize.
(if (and (ring-p rcirc-input-ring)
@@ -1057,18 +1276,14 @@ This number is independent of the number of lines in the buffer.")
rcirc-input-ring-size))
rcirc-input-ring
(make-ring rcirc-input-ring-size)))
- (setq-local rcirc-server-buffer (process-buffer process))
- (setq-local rcirc-target target)
- (setq-local rcirc-topic nil)
- (setq-local rcirc-last-post-time (current-time))
+ (setq rcirc-server-buffer (process-buffer process))
+ (setq rcirc-target target)
+ (setq rcirc-last-post-time (current-time))
(setq-local fill-paragraph-function 'rcirc-fill-paragraph)
- (setq-local rcirc-recent-quit-alist nil)
- (setq-local rcirc-current-line 0)
- (setq-local rcirc-last-connect-time (current-time))
+ (setq rcirc-current-line 0)
+ (setq rcirc-last-connect-time (current-time))
(use-hard-newlines t)
- (setq-local rcirc-short-buffer-name nil)
- (setq-local rcirc-urls nil)
;; setup for omitting responses
(setq buffer-invisibility-spec '())
@@ -1089,8 +1304,8 @@ This number is independent of the number of lines in the buffer.")
(if (consp (cdr i)) (cddr i) (cdr i))))))
;; setup the prompt and markers
- (setq-local rcirc-prompt-start-marker (point-max-marker))
- (setq-local rcirc-prompt-end-marker (point-max-marker))
+ (setq rcirc-prompt-start-marker (point-max-marker))
+ (setq rcirc-prompt-end-marker (point-max-marker))
(rcirc-update-prompt)
(goto-char rcirc-prompt-end-marker)
@@ -1111,6 +1326,7 @@ This number is independent of the number of lines in the buffer.")
(add-hook 'completion-at-point-functions
'rcirc-completion-at-point nil 'local)
+ (setq-local completion-cycle-threshold t)
(run-mode-hooks 'rcirc-mode-hook))
@@ -1149,7 +1365,7 @@ If ALL is non-nil, update prompts in all IRC buffers."
'front-sticky t 'rear-nonsticky t))))))))
(defun rcirc-set-changed (option value)
- "Set OPTION to VALUE and do updates after a customization change."
+ "Set OPTION to VALUE and update after a customization change."
(set-default option value)
(cond ((eq option 'rcirc-prompt)
(rcirc-update-prompt 'all))
@@ -1163,9 +1379,10 @@ 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"
+(defcustom rcirc-log-directory (locate-user-emacs-file "rcirc-log")
"Directory to keep IRC logfiles."
- :type 'directory)
+ :type 'directory
+ :version "28.1")
(defcustom rcirc-log-flag nil
"Non-nil means log IRC activity to disk.
@@ -1191,10 +1408,11 @@ with it."
(kill-buffer (cdr channel))))))
(defun rcirc-change-major-mode-hook ()
- "Part the channel when changing the major-mode."
+ "Part the channel when changing the major mode."
(rcirc-clean-up-buffer "Changed major mode"))
(defun rcirc-clean-up-buffer (reason)
+ "Clean up current buffer and part with REASON."
(let ((buffer (current-buffer)))
(rcirc-clear-activity buffer)
(when (and (rcirc-buffer-process)
@@ -1205,7 +1423,7 @@ with it."
(rcirc-update-short-buffer-names)
(if (rcirc-channel-p rcirc-target)
(rcirc-send-string (rcirc-buffer-process)
- (concat "PART " rcirc-target " :" reason))
+ "PART" rcirc-target : reason)
(when rcirc-target
(rcirc-remove-nick-channel (rcirc-buffer-process)
(rcirc-buffer-nick)
@@ -1245,9 +1463,11 @@ Create the buffer if it doesn't exist."
(let ((new-buffer (get-buffer-create
(rcirc-generate-new-buffer-name process target))))
(with-current-buffer new-buffer
- (rcirc-mode process target)
+ (unless (eq major-mode 'rcirc-mode)
+ (rcirc-mode process target)))
+ (setq mode-line-process nil)
(rcirc-put-nick-channel process (rcirc-nick process) target
- rcirc-current-line))
+ rcirc-current-line)
new-buffer)))))
(defun rcirc-send-input ()
@@ -1283,6 +1503,8 @@ Create the buffer if it doesn't exist."
(setq rcirc-input-ring-index 0))))))
(defun rcirc-fill-paragraph (&optional justify)
+ "Implementation for `fill-paragraph-function'.
+The argument JUSTIFY is passed on to `fill-region'."
(interactive "P")
(when (> (point) rcirc-prompt-end-marker)
(save-restriction
@@ -1291,13 +1513,15 @@ Create the buffer if it doesn't exist."
(fill-region (point-min) (point-max) justify)))))
(defun rcirc-process-input-line (line)
- (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line)
+ "Process LINE as a message or a command."
+ (if (string-match "^/\\([^/ ][^ ]*\\) ?\\(.*\\)$" line)
(rcirc-process-command (match-string 1 line)
(match-string 2 line)
line)
(rcirc-process-message line)))
(defun rcirc-process-message (line)
+ "Process LINE as a message to be sent."
(if (not rcirc-target)
(message "Not joined (no target)")
(delete-region rcirc-prompt-end-marker (point))
@@ -1305,29 +1529,31 @@ Create the buffer if it doesn't exist."
(setq rcirc-last-post-time (current-time))))
(defun rcirc-process-command (command args line)
- (if (eq (aref command 0) ?/)
- ;; "//text" will send "/text" as a message
- (rcirc-process-message (substring line 1))
- (let ((fun (intern-soft (concat "rcirc-cmd-" command)))
- (process (rcirc-buffer-process)))
- (newline)
- (with-current-buffer (current-buffer)
- (delete-region rcirc-prompt-end-marker (point))
- (if (string= command "me")
- (rcirc-print process (rcirc-buffer-nick)
- "ACTION" rcirc-target args)
+ "Process COMMAND with arguments ARGS.
+LINE is the raw input, from which COMMAND and ARGS was
+extracted."
+ (let ((fun (intern-soft (concat "rcirc-cmd-" command)))
+ (process (rcirc-buffer-process)))
+ (newline)
+ (with-current-buffer (current-buffer)
+ (delete-region rcirc-prompt-end-marker (point))
+ (if (string= command "me")
(rcirc-print process (rcirc-buffer-nick)
- "COMMAND" rcirc-target line))
- (set-marker rcirc-prompt-end-marker (point))
- (if (fboundp fun)
- (funcall fun args process rcirc-target)
- (rcirc-send-string process
- (concat command " :" args)))))))
-
-(defvar rcirc-parent-buffer nil)
-(make-variable-buffer-local 'rcirc-parent-buffer)
+ "ACTION" rcirc-target args)
+ (rcirc-print process (rcirc-buffer-nick)
+ "COMMAND" rcirc-target line))
+ (set-marker rcirc-prompt-end-marker (point))
+ (if (fboundp fun)
+ (funcall fun args process rcirc-target)
+ (rcirc-send-string process command : args)))))
+
+(defvar-local rcirc-parent-buffer nil
+ "Message buffer that requested a multiline buffer.")
(put 'rcirc-parent-buffer 'permanent-local t)
-(defvar rcirc-window-configuration nil)
+
+(defvar rcirc-window-configuration nil
+ "Window configuration before creating multiline buffer.")
+
(defun rcirc-edit-multiline ()
"Move current edit to a dedicated buffer."
(interactive)
@@ -1357,9 +1583,7 @@ Create the buffer if it doesn't exist."
(define-minor-mode rcirc-multiline-minor-mode
"Minor mode for editing multiple lines in rcirc."
- :init-value nil
:lighter " rcirc-mline"
- :keymap rcirc-multiline-minor-mode-map
:global nil
(setq fill-column rcirc-max-message-length))
@@ -1425,9 +1649,10 @@ the of the following escape sequences replaced by the described values:
:value-type string))
(defun rcirc-format-response-string (process sender response target text)
- "Return a nicely-formatted response string, incorporating TEXT
-\(and perhaps other arguments). The specific formatting used
-is found by looking up RESPONSE in `rcirc-response-formats'."
+ "Return a formatted response string from SENDER, incorporating TEXT.
+The specific formatting used is found by looking up RESPONSE in
+`rcirc-response-formats'. PROCESS is the process object used for
+communication."
(with-temp-buffer
(insert (or (cdr (assoc response rcirc-response-formats))
(cdr (assq t rcirc-response-formats))))
@@ -1436,7 +1661,7 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(sender (if (or (not sender)
(string= (rcirc-server-name process) sender))
""
- sender))
+ (funcall rcirc-nick-filter sender)))
face)
(while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t)
(rcirc-add-face start (match-beginning 0) face)
@@ -1481,7 +1706,8 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(buffer-substring (point-min) (point-max))))
(defun rcirc-target-buffer (process sender response target _text)
- "Return a buffer to print the server response."
+ "Return a buffer to print the server response from SENDER.
+PROCESS is the process object for the current connection."
(cl-assert (not (bufferp target)))
(with-rcirc-process-buffer process
(cond ((not target)
@@ -1497,13 +1723,12 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
((or (rcirc-get-buffer process target)
(rcirc-any-buffer process))))))
-(defvar rcirc-activity-types nil)
-(make-variable-buffer-local 'rcirc-activity-types)
-(defvar rcirc-last-sender nil)
-(make-variable-buffer-local 'rcirc-last-sender)
+(defvar-local rcirc-last-sender nil)
+(defvar-local rcirc-activity-types nil
+ "List of symbols designating kinds of activities in a buffer.")
(defcustom rcirc-omit-threshold 100
- "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted."
+ "Lines since last activity from a nick before `rcirc-omit-responses' are omitted."
:type 'integer)
(defcustom rcirc-log-process-buffers nil
@@ -1513,14 +1738,16 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(defun rcirc-last-quit-line (process nick target)
"Return the line number where NICK left TARGET.
-Returns nil if the information is not recorded."
+Returns nil if the information is not recorded.
+PROCESS is the process object for the current connection."
(let ((chanbuf (rcirc-get-buffer process target)))
(when chanbuf
(cdr (assoc-string nick (with-current-buffer chanbuf
rcirc-recent-quit-alist))))))
(defun rcirc-last-line (process nick target)
- "Return the line from the last activity from NICK in TARGET."
+ "Return the line from the last activity from NICK in TARGET.
+PROCESS is the process object for the current connection."
(let ((line (or (cdr (assoc-string target
(gethash nick (with-rcirc-server-buffer
rcirc-nick-table)) t))
@@ -1531,7 +1758,8 @@ Returns nil if the information is not recorded."
nil)))
(defun rcirc-elapsed-lines (process nick target)
- "Return the number of lines since activity from NICK in TARGET."
+ "Return the number of lines since activity from NICK in TARGET.
+PROCESS is the process object for the current connection."
(let ((last-activity-line (rcirc-last-line process nick target)))
(when (and last-activity-line
(> last-activity-line 0))
@@ -1539,11 +1767,12 @@ Returns nil if the information is not recorded."
(defvar rcirc-markup-text-functions
'(rcirc-markup-attributes
+ rcirc-color-attributes
+ rcirc-remove-markup-codes
rcirc-markup-my-nick
rcirc-markup-urls
rcirc-markup-keywords
rcirc-markup-bright-nicks)
-
"List of functions used to manipulate text before it is printed.
Each function takes two arguments, SENDER, and RESPONSE. The
@@ -1553,7 +1782,8 @@ at the beginning of the `rcirc-text' propertized text.")
(defun rcirc-print (process sender response target text &optional activity)
"Print TEXT in the buffer associated with TARGET.
Format based on SENDER and RESPONSE. If ACTIVITY is non-nil,
-record activity."
+record activity. PROCESS is the process object for the current
+connection."
(or text (setq text ""))
(unless (and (or (member sender rcirc-ignore-list)
(member (with-syntax-table rcirc-nick-syntax-table
@@ -1563,11 +1793,13 @@ record activity."
;; do not ignore if we sent the message
(not (string= sender (rcirc-nick process))))
(let* ((buffer (rcirc-target-buffer process sender response target text))
+ (time (if-let ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time)
+ (current-time)))
(inhibit-read-only t))
(with-current-buffer buffer
(let ((moving (= (point) rcirc-prompt-end-marker))
- (old-point (point-marker))
- (fill-start (marker-position rcirc-prompt-start-marker)))
+ (old-point (point-marker)))
(setq text (decode-coding-string text rcirc-decode-coding-system))
(unless (string= sender (rcirc-nick process))
@@ -1581,25 +1813,32 @@ record activity."
;; temporarily set the marker insertion-type because
;; insert-before-markers results in hidden text in new buffers
(goto-char rcirc-prompt-start-marker)
+ (catch 'exit
+ (while (not (bobp))
+ (goto-char (or (previous-single-property-change (point) 'hard)
+ (point-min)))
+ (when (let ((then (get-text-property (point) 'rcirc-time)))
+ (and then (not (time-less-p time then))))
+ (next-single-property-change (point) 'hard)
+ (forward-char 1)
+ (throw 'exit nil))))
(set-marker-insertion-type rcirc-prompt-start-marker t)
(set-marker-insertion-type rcirc-prompt-end-marker t)
- (let ((start (point)))
- (insert (rcirc-format-response-string process sender response nil
- text)
- (propertize "\n" 'hard t))
-
- ;; squeeze spaces out of text before rcirc-text
- (fill-region fill-start
- (1- (or (next-single-property-change fill-start
- 'rcirc-text)
- rcirc-prompt-end-marker)))
-
- ;; run markup functions
- (save-excursion
- (save-restriction
- (narrow-to-region start rcirc-prompt-start-marker)
- (goto-char (or (next-single-property-change start 'rcirc-text)
+ ;; run markup functions
+ (cl-assert (bolp))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert (propertize (rcirc-format-response-string process sender response
+ nil text)
+ 'rcirc-msgid (rcirc-get-tag "msgid"))
+ (propertize "\n" 'hard t))
+
+ ;; squeeze spaces out of text before rcirc-text
+ (fill-region (point-min) (point-max))
+
+ (goto-char (or (next-single-property-change (point-min) 'rcirc-text)
(point)))
(when (rcirc-buffer-process)
(save-excursion (rcirc-markup-timestamp sender response))
@@ -1610,14 +1849,21 @@ record activity."
(when rcirc-read-only-flag
(add-text-properties (point-min) (point-max)
- '(read-only t front-sticky t))))
- ;; make text omittable
+ '(read-only t front-sticky t)))
+
+ (add-text-properties (point-min) (point-max)
+ (list 'rcirc-time time))
+
+ ;; make text omittable
(let ((last-activity-lines (rcirc-elapsed-lines process sender target)))
(if (and (not (string= (rcirc-nick process) sender))
- (member response rcirc-omit-responses)
+ (or (member response rcirc-omit-responses)
+ (if (member response rcirc-omit-after-reconnect)
+ rcirc-reconncting
+ (setq rcirc-reconncting nil)))
(or (not last-activity-lines)
(< rcirc-omit-threshold last-activity-lines)))
- (put-text-property (1- start) (1- rcirc-prompt-start-marker)
+ (put-text-property (point-min) (point-max)
'invisible 'rcirc-omit)
;; otherwise increment the line count
(setq rcirc-current-line (1+ rcirc-current-line))))))
@@ -1639,11 +1885,11 @@ record activity."
(window-buffer w))
(>= (window-point w)
rcirc-prompt-end-marker))
- (set-window-point w (point-max))))
+ (set-window-point w (point-max))))
nil t)
;; restore the point
- (goto-char (if moving rcirc-prompt-end-marker old-point))
+ (goto-char (if moving rcirc-prompt-end-marker old-point)))
;; keep window on bottom line if it was already there
(when rcirc-scroll-show-maximum-output
@@ -1660,28 +1906,29 @@ record activity."
;; flush undo (can we do something smarter here?)
(buffer-disable-undo)
- (buffer-enable-undo))
-
- ;; record mode line activity
- (when (and activity
- (not rcirc-ignore-buffer-activity-flag)
- (not (and rcirc-dim-nicks sender
- (string-match (regexp-opt rcirc-dim-nicks) sender)
- (rcirc-channel-p target))))
- (rcirc-record-activity (current-buffer)
- (when (not (rcirc-channel-p rcirc-target))
- 'nick)))
-
- (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-functions
- process sender response target text)))))
+ (buffer-enable-undo)
+
+ ;; record mode line activity
+ (when (and activity
+ (not rcirc-ignore-buffer-activity-flag)
+ (not (and rcirc-dim-nicks sender
+ (string-match (regexp-opt rcirc-dim-nicks) sender)
+ (rcirc-channel-p target))))
+ (rcirc-record-activity (current-buffer)
+ (when (not (rcirc-channel-p rcirc-target))
+ 'nick)))
+
+ (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-functions
+ process sender response target text)))))
(defun rcirc-generate-log-filename (process target)
+ "Return filename for log file based on PROCESS and TARGET."
(if target
(rcirc-generate-new-buffer-name process target)
(process-name process)))
@@ -1703,11 +1950,15 @@ guarantee valid filenames for the current OS."
:type 'function)
(defun rcirc-log (process sender response target text)
- "Record line in `rcirc-log', to be later written to disk."
- (let ((filename (funcall rcirc-log-filename-function process target)))
+ "Record TEXT from SENDER to TARGET to be logged.
+The message is logged in `rcirc-log', and is later written to
+disk. PROCESS is the process object for the current connection."
+ (let ((filename (funcall rcirc-log-filename-function process target))
+ (time (and-let* ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time))))
(unless (null filename)
(let ((cell (assoc-string filename rcirc-log-alist))
- (line (concat (format-time-string rcirc-time-format)
+ (line (concat (format-time-string rcirc-time-format time)
(substring-no-properties
(rcirc-format-response-string process sender
response target text))
@@ -1742,14 +1993,17 @@ log-files with absolute names (see `rcirc-log-filename-function')."
rcirc-log-directory)))
(defun rcirc-join-channels (process channels)
- "Join CHANNELS."
+ "Join CHANNELS.
+PROCESS is the process object for the current connection."
(save-window-excursion
(dolist (channel channels)
(with-rcirc-process-buffer process
(rcirc-cmd-join channel process)))))
;;; nick management
-(defvar rcirc-nick-prefix-chars "~&@%+")
+(defvar rcirc-nick-prefix-chars '(?~ ?& ?@ ?% ?+)
+ "List of junk characters to strip from nick prefixes.")
+
(defun rcirc-user-nick (user)
"Return the nick from USER. Remove any non-nick junk."
(save-match-data
@@ -1759,7 +2013,8 @@ log-files with absolute names (see `rcirc-log-filename-function')."
user)))
(defun rcirc-nick-channels (process nick)
- "Return list of channels for NICK."
+ "Return list of channels for NICK.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(mapcar (lambda (x) (car x))
(gethash nick rcirc-nick-table))))
@@ -1769,7 +2024,7 @@ log-files with absolute names (see `rcirc-log-filename-function')."
Update the associated linestamp if LINE is non-nil.
If the record doesn't exist, and LINE is nil, set the linestamp
-to zero."
+to zero. PROCESS is the process object for the current connection."
(let ((nick (rcirc-user-nick nick)))
(with-rcirc-process-buffer process
(let* ((chans (gethash nick rcirc-nick-table))
@@ -1781,12 +2036,14 @@ to zero."
rcirc-nick-table))))))
(defun rcirc-nick-remove (process nick)
- "Remove NICK from table."
+ "Remove NICK from table.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(remhash nick rcirc-nick-table)))
(defun rcirc-remove-nick-channel (process nick channel)
- "Remove the CHANNEL from list associated with NICK."
+ "Remove the CHANNEL from list associated with NICK.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(let* ((chans (gethash nick rcirc-nick-table))
(newchans
@@ -1800,7 +2057,8 @@ to zero."
(remhash nick rcirc-nick-table)))))
(defun rcirc-channel-nicks (process target)
- "Return the list of nicks associated with TARGET sorted by last activity."
+ "Return the list of nicks associated with TARGET sorted by last activity.
+PROCESS is the process object for the current connection."
(when target
(if (rcirc-channel-p target)
(with-rcirc-process-buffer process
@@ -1819,8 +2077,9 @@ to zero."
(list target))))
(defun rcirc-ignore-update-automatic (nick)
- "Remove NICK from `rcirc-ignore-list'
-if NICK is also on `rcirc-ignore-list-automatic'."
+ "Check if NICK is in `rcirc-ignore-list-automatic'.
+If so, remove from `rcirc-ignore-list'. PROCESS is the process
+object for the current connection."
(when (member nick rcirc-ignore-list-automatic)
(setq rcirc-ignore-list-automatic
(delete nick rcirc-ignore-list-automatic)
@@ -1828,7 +2087,7 @@ if NICK is also on `rcirc-ignore-list-automatic'."
(delete nick rcirc-ignore-list))))
(defun rcirc-nickname< (s1 s2)
- "Return t if IRC nickname S1 is less than S2, and nil otherwise.
+ "Return non-nil 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."
@@ -1850,7 +2109,7 @@ 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)))
+ (mapconcat rcirc-nick-filter sorted sep)))
;;; activity tracking
(defvar rcirc-track-minor-mode-map
@@ -1863,9 +2122,6 @@ This function does not alter the INPUT string."
;;;###autoload
(define-minor-mode rcirc-track-minor-mode
"Global minor mode for tracking activity in rcirc buffers."
- :init-value nil
- :lighter ""
- :keymap rcirc-track-minor-mode-map
:global t
(or global-mode-string (setq global-mode-string '("")))
;; toggle the mode-line channel indicator
@@ -1881,12 +2137,8 @@ This function does not alter the INPUT string."
(remove-hook 'window-configuration-change-hook
'rcirc-window-configuration-change)))
-(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist)
- (setq minor-mode-alist
- (cons '(rcirc-ignore-buffer-activity-flag " Ignore") minor-mode-alist)))
-(or (assq 'rcirc-low-priority-flag minor-mode-alist)
- (setq minor-mode-alist
- (cons '(rcirc-low-priority-flag " LowPri") minor-mode-alist)))
+(add-to-list 'minor-mode-alist '(rcirc-ignore-buffer-activity-flag " Ignore"))
+(add-to-list 'minor-mode-alist '(rcirc-low-priority-flag " LowPri"))
(defun rcirc-toggle-ignore-buffer-activity ()
"Toggle the value of `rcirc-ignore-buffer-activity-flag'."
@@ -1911,9 +2163,7 @@ This function does not alter the INPUT string."
(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))
+ (switch-to-buffer (with-rcirc-server-buffer (current-buffer))))
(defun rcirc-jump-to-first-unread-line ()
"Move the point to the first unread line in this buffer."
@@ -1949,7 +2199,8 @@ With prefix ARG, go to the next low priority buffer with activity."
(concat
" Type C-u " (key-description (this-command-keys))
" for low priority activity.")
- "")))))
+ ""))))
+ (rcirc-update-activity-string))
(define-obsolete-variable-alias 'rcirc-activity-hooks
'rcirc-activity-functions "24.3")
@@ -2005,7 +2256,6 @@ activity. Only run if the buffer is not visible and
(defvar rcirc-update-activity-string-hook nil
"Hook run whenever the activity string is updated.")
-;; TODO: add mouse properties
(defun rcirc-update-activity-string ()
"Update mode-line string."
(let* ((pair (rcirc-split-activity rcirc-activity))
@@ -2024,19 +2274,26 @@ activity. Only run if the buffer is not visible and
((not (null (rcirc-process-list)))
"[]")
(t "[]")))
- (run-hooks 'rcirc-update-activity-string-hook)))
+ (run-hooks 'rcirc-update-activity-string-hook)
+ (force-mode-line-update t)))
(defun rcirc-activity-string (buffers)
+ "Generate activity string for all BUFFERS."
(mapconcat (lambda (b)
(let ((s (substring-no-properties (rcirc-short-buffer-name b))))
(with-current-buffer b
(dolist (type rcirc-activity-types)
- (rcirc-add-face 0 (length s)
- (cl-case type
+ (rcirc-facify s (cl-case type
(nick 'rcirc-track-nick)
- (keyword 'rcirc-track-keyword))
- s)))
- s))
+ (keyword 'rcirc-track-keyword)))))
+ (let ((map (make-mode-line-mouse-map
+ 'mouse-1
+ (lambda ()
+ (interactive)
+ (pop-to-buffer b)))))
+ (propertize s
+ 'mouse-face 'mode-line-highlight
+ 'local-map map))))
buffers ","))
(defun rcirc-short-buffer-name (buffer)
@@ -2045,7 +2302,7 @@ activity. Only run if the buffer is not visible and
(or rcirc-short-buffer-name (buffer-name))))
(defun rcirc-visible-buffers ()
- "Return a list of the visible buffers that are in rcirc-mode."
+ "Return a list of the visible buffers that are in `rcirc-mode'."
(let (acc)
(walk-windows (lambda (w)
(with-current-buffer (window-buffer w)
@@ -2053,13 +2310,16 @@ activity. Only run if the buffer is not visible and
(push (current-buffer) acc)))))
acc))
-(defvar rcirc-visible-buffers nil)
+(defvar rcirc-visible-buffers nil
+ "List of visible IRC buffers.")
+
(defun rcirc-window-configuration-change ()
+ "Clear activity and overlay arrows, unless minibuffer is active."
(unless (minibuffer-window-active-p (minibuffer-window))
(rcirc-window-configuration-change-1)))
(defun rcirc-window-configuration-change-1 ()
- ;; clear activity and overlay arrows
+ "Clear activity and overlay arrows."
(let* ((old-activity rcirc-activity)
(hidden-buffers rcirc-visible-buffers))
@@ -2085,6 +2345,7 @@ activity. Only run if the buffer is not visible and
;;; buffer name abbreviation
(defun rcirc-update-short-buffer-names ()
+ "Update variable `rcirc-short-buffer-name' for IRC buffers."
(let ((bufalist
(apply 'append (mapcar (lambda (process)
(with-rcirc-process-buffer process
@@ -2096,10 +2357,15 @@ activity. Only run if the buffer is not visible and
(setq rcirc-short-buffer-name (car i)))))))
(defun rcirc-abbreviate (pairs)
+ "Generate alist of abbreviated buffer names to buffers.
+PAIRS is the concatenated value of all `rcirc-buffer-alist'
+values, from each process."
(apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs))))
-(defun rcirc-rebuild-tree (tree &optional acc)
- (let ((ch (char-to-string (car tree))))
+(defun rcirc-rebuild-tree (tree)
+ "Merge prefix TREE into alist of unique prefixes to buffers."
+ (let ((ch (char-to-string (car tree)))
+ acc)
(dolist (x (cdr tree))
(if (listp x)
(setq acc (append acc
@@ -2111,6 +2377,12 @@ activity. Only run if the buffer is not visible and
acc))
(defun rcirc-make-trees (pairs)
+ "Generate tree prefix tree of buffer names.
+PAIRS is a list of (TARGET . BUFFER) entries. The resulting tree
+is a list of (CHAR . CHILDREN) cons-cells, where CHAR is the
+leading character and CHILDREN is either BUFFER when a unique
+prefix could be found or another tree if it shares the same
+prefix with another element in PAIRS."
(let (alist)
(mapc (lambda (pair)
(if (consp pair)
@@ -2143,50 +2415,85 @@ activity. Only run if the buffer is not visible and
;; the current buffer/channel/user, and ARGS, which is a string
;; containing the text following the /cmd.
-(defmacro defun-rcirc-command (command argument docstring interactive-form
- &rest body)
- "Define a command."
- `(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)))
- (ignore target) ; mark `target' variable as ignorable
- ,@body))))
-
-(defun-rcirc-command msg (message)
- "Send private MESSAGE to TARGET."
- (interactive "i")
- (if (null message)
- (progn
- (setq target (completing-read "Message nick: "
+(defmacro rcirc-define-command (command arguments &rest body)
+ "Define a new client COMMAND in BODY that takes ARGUMENTS.
+ARGUMENTS may designate optional arguments using a single
+`&optional' symbol. Just like `defun', a string at the beginning
+of BODY is interpreted as the documentation string. Following
+that, an interactive form can specified."
+ (declare (debug (symbolp (&rest symbolp) def-body))
+ (indent defun))
+ (cl-check-type command symbol)
+ (cl-check-type arguments list)
+ (let* ((fn-name (intern (concat "rcirc-cmd-" (symbol-name command))))
+ (total (length (remq '&optional arguments)))
+ (required (- (length arguments) (length (memq '&optional arguments))))
+ (optional (- total required))
+ (regexp (with-temp-buffer
+ (insert "\\`")
+ (when arguments
+ (dotimes (_ (1- (length arguments)))
+ (insert "\\(?:\\(.+?\\)[[:space:]]+"))
+ (dotimes (i (1- (length arguments)))
+ (if (< i optional)
+ (insert "\\)?")
+ (insert "\\)"))))
+ (insert "\\(.*?\\)")
+ (insert "[[:space:]]*\\'")
+ (buffer-string)))
+ (argument (gensym))
+ documentation
+ interactive-spec)
+ (when (stringp (car body))
+ (setq documentation (pop body)))
+ (when (eq (car-safe (car-safe body)) 'interactive)
+ (setq interactive-spec (cdr (pop body))))
+ `(progn
+ (defun ,fn-name (,argument &optional process target)
+ ,(concat documentation
+ "\n\nNote: If PROCESS or TARGET are nil, the values given"
+ "\nby `rcirc-buffer-process' and `rcirc-target' will be used.")
+ (interactive (list ,@interactive-spec))
+ (unless (if (listp ,argument)
+ (<= ,required (length ,argument) ,total)
+ (string-match ,regexp ,argument))
+ (user-error "Malformed input (%s): %S" ',command ',argument))
+ (let ((process (or process (rcirc-buffer-process)))
+ (target (or target rcirc-target)))
+ (ignore target process)
+ (let (,@(cl-loop
+ for i from 0 for arg in (delq '&optional arguments)
+ collect `(,arg (if (listp ,argument)
+ (nth ,i ,argument)
+ (match-string ,(1+ i) ,argument)))))
+ ,@body)))
+ (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))))))
+
+(define-obsolete-function-alias
+ 'defun-rcirc-command
+ 'rcirc-define-command
+ "28.1")
+
+(rcirc-define-command msg (chan-or-nick message)
+ "Send MESSAGE to CHAN-OR-NICK."
+ (interactive (list (completing-read "Message nick: "
(with-rcirc-server-buffer
- rcirc-nick-table)))
- (when (> (length target) 0)
- (setq message (read-string (format "Message %s: " target)))
- (when (> (length message) 0)
- (rcirc-send-message process target message))))
- (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message))
- (message "Not enough args, or something.")
- (setq target (match-string 1 message)
- message (match-string 2 message))
- (rcirc-send-message process target message))))
-
-(defun-rcirc-command query (nick)
+ rcirc-nick-table))
+ (read-string "Message: ")))
+ (rcirc-send-message process chan-or-nick message))
+
+(rcirc-define-command query (nick)
"Open a private chat buffer to NICK."
(interactive (list (completing-read "Query nick: "
- (with-rcirc-server-buffer rcirc-nick-table))))
+ (with-rcirc-server-buffer
+ rcirc-nick-table))))
(let ((existing-buffer (rcirc-get-buffer process nick)))
(switch-to-buffer (or existing-buffer
(rcirc-get-buffer-create process nick)))
(when (not existing-buffer)
(rcirc-cmd-whois nick))))
-(defun-rcirc-command join (channels)
+(rcirc-define-command join (channels)
"Join CHANNELS.
CHANNELS is a comma- or space-separated string of channel names."
(interactive "sJoin channels: ")
@@ -2195,46 +2502,35 @@ CHANNELS is a comma- or space-separated string of channel names."
(rcirc-get-buffer-create process ch))
split-channels))
(channels (mapconcat 'identity split-channels ",")))
- (rcirc-send-string process (concat "JOIN " channels))
+ (rcirc-send-string process "JOIN" channels)
(when (not (eq (selected-window) (minibuffer-window)))
(dolist (b buffers) ;; order the new channel buffers in the buffer list
(switch-to-buffer b)))))
-(defun-rcirc-command invite (nick-channel)
+(rcirc-define-command invite (nick channel)
"Invite NICK to CHANNEL."
(interactive (list
- (concat
- (completing-read "Invite nick: "
- (with-rcirc-server-buffer rcirc-nick-table))
- " "
- (read-string "Channel: "))))
- (rcirc-send-string process (concat "INVITE " nick-channel)))
-
-(defun-rcirc-command part (channel)
+ (completing-read "Invite nick: "
+ (with-rcirc-server-buffer rcirc-nick-table))
+ (read-string "Channel: ")))
+ (rcirc-send-string process "INVITE" nick channel))
+
+(rcirc-define-command part (&optional channel reason)
"Part CHANNEL.
CHANNEL should be a string of the form \"#CHANNEL-NAME REASON\".
If omitted, CHANNEL-NAME defaults to TARGET, and REASON defaults
to `rcirc-default-part-reason'."
- (interactive "sPart channel: ")
- (let ((channel (if (> (length channel) 0) channel target))
- (msg rcirc-default-part-reason))
- (when (string-match "\\`\\([&#+!]\\S-+\\)?\\s-*\\(.+\\)?\\'" channel)
- (when (match-beginning 2)
- (setq msg (match-string 2 channel)))
- (setq channel (if (match-beginning 1)
- (match-string 1 channel)
- target)))
- (rcirc-send-string process (concat "PART " channel " :" msg))))
-
-(defun-rcirc-command quit (reason)
+ (interactive "sPart channel: \nsReason: ")
+ (rcirc-send-string process "PART" (or channel target)
+ : (or reason rcirc-default-part-reason)))
+
+(rcirc-define-command quit (&optional reason)
"Send a quit message to server with REASON."
(interactive "sQuit reason: ")
- (rcirc-send-string process (concat "QUIT :"
- (if (not (zerop (length reason)))
- reason
- rcirc-default-quit-reason))))
+ (rcirc-send-string process "QUIT"
+ : (or reason rcirc-default-quit-reason)))
-(defun-rcirc-command reconnect (_)
+(rcirc-define-command reconnect ()
"Reconnect to current server."
(interactive "i")
(with-rcirc-server-buffer
@@ -2245,79 +2541,73 @@ to `rcirc-default-part-reason'."
(setf (nth 5 conn-info)
(cl-remove-if-not #'rcirc-channel-p
(mapcar #'car rcirc-buffer-alist)))
+ (dolist (buf (nth 5 conn-info))
+ (with-current-buffer (cdr (assoc buf rcirc-buffer-alist))
+ (setq rcirc-reconncting t)))
(apply #'rcirc-connect conn-info))))))
-(defun-rcirc-command nick (nick)
+(rcirc-define-command nick (nick)
"Change nick to NICK."
- (interactive "i")
- (when (null nick)
- (setq nick (read-string "New nick: " (rcirc-nick process))))
- (rcirc-send-string process (concat "NICK " nick)))
+ (interactive (list (read-string "New nick: ")))
+ (rcirc-send-string process "NICK" nick))
-(defun-rcirc-command names (channel)
+(rcirc-define-command names (&optional channel)
"Display list of names in CHANNEL or in current channel if CHANNEL is nil.
If called interactively, prompt for a channel when prefix arg is supplied."
- (interactive "P")
- (if (called-interactively-p 'interactive)
- (if channel
- (setq channel (read-string "List names in channel: " target))))
- (let ((channel (if (> (length channel) 0)
- channel
- target)))
- (rcirc-send-string process (concat "NAMES " channel))))
-
-(defun-rcirc-command topic (topic)
+ (interactive (list (and current-prefix-arg
+ (read-string "List names in channel: "))))
+ (rcirc-send-string process "NAMES" (or channel target)))
+
+(rcirc-define-command topic (topic)
"List TOPIC for the TARGET channel.
With a prefix arg, prompt for new topic."
- (interactive "P")
- (if (and (called-interactively-p 'interactive) topic)
- (setq topic (read-string "New Topic: " rcirc-topic)))
- (rcirc-send-string process (concat "TOPIC " target
- (when (> (length topic) 0)
- (concat " :" topic)))))
+ (interactive (list (and current-prefix-arg
+ (read-string "List names in channel: "))))
+ (if (> (length topic) 0)
+ (rcirc-send-string process "TOPIC" : topic)
+ (rcirc-send-string process "TOPIC")))
-(defun-rcirc-command whois (nick)
+(rcirc-define-command whois (nick)
"Request information from server about NICK."
- (interactive (list
- (completing-read "Whois: "
- (with-rcirc-server-buffer rcirc-nick-table))))
- (rcirc-send-string process (concat "WHOIS " nick)))
-
-(defun-rcirc-command mode (args)
- "Set mode with ARGS."
- (interactive (list (concat (read-string "Mode nick or channel: ")
- " " (read-string "Mode: "))))
- (rcirc-send-string process (concat "MODE " args)))
-
-(defun-rcirc-command list (channels)
+ (interactive (list (completing-read
+ "Whois: "
+ (with-rcirc-server-buffer rcirc-nick-table))))
+ (rcirc-send-string process "WHOIS" nick))
+
+(rcirc-define-command mode (nick-or-chan mode)
+ "Set NICK-OR-CHAN mode to MODE."
+ (interactive (list (read-string "Mode nick or channel: ")
+ (read-string "Mode: ")))
+ (rcirc-send-string process "MODE" nick-or-chan mode))
+
+(rcirc-define-command list (channels)
"Request information on CHANNELS from server."
(interactive "sList Channels: ")
- (rcirc-send-string process (concat "LIST " channels)))
+ (rcirc-send-string process "LIST" channels))
-(defun-rcirc-command oper (args)
+(rcirc-define-command oper (args)
"Send operator command to server."
(interactive "sOper args: ")
- (rcirc-send-string process (concat "OPER " args)))
+ (rcirc-send-string process "OPER" args))
-(defun-rcirc-command quote (message)
+(rcirc-define-command quote (message)
"Send MESSAGE literally to server."
(interactive "sServer message: ")
(rcirc-send-string process message))
-(defun-rcirc-command kick (arg)
+(rcirc-define-command kick (nick reason)
"Kick NICK from current channel."
(interactive (list
- (concat (completing-read "Kick nick: "
- (rcirc-channel-nicks
- (rcirc-buffer-process)
- rcirc-target))
- (read-from-minibuffer "Kick reason: "))))
- (let* ((arglist (split-string arg))
- (argstring (concat (car arglist) " :"
- (mapconcat 'identity (cdr arglist) " "))))
- (rcirc-send-string process (concat "KICK " target " " argstring))))
+ (completing-read "Kick nick: "
+ (rcirc-channel-nicks
+ (rcirc-buffer-process)
+ rcirc-target))
+ (read-from-minibuffer "Kick reason: ")))
+ (rcirc-send-string process "KICK" target nick : reason))
(defun rcirc-cmd-ctcp (args &optional process _target)
+ "Handle ARGS as a CTCP command.
+PROCESS is the process object for the current connection."
(if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args)
(let* ((target (match-string 1 args))
(request (upcase (match-string 2 args)))
@@ -2329,14 +2619,18 @@ With a prefix arg, prompt for new topic."
"usage: /ctcp NICK REQUEST")))
(defun rcirc-ctcp-sender-PING (process target _request)
- "Send a CTCP PING message to TARGET."
+ "Send a CTCP PING message to TARGET.
+PROCESS is the process object for the current connection."
(let ((timestamp (format-time-string "%s")))
(rcirc-send-ctcp process target "PING" timestamp)))
(defun rcirc-cmd-me (args process target)
+ "Send an action message ARGS to TARGET.
+PROCESS is the process object for the current connection."
(when target (rcirc-send-ctcp process target "ACTION" args)))
(defun rcirc-add-or-remove (set &rest elements)
+ "Toggle membership of ELEMENTS in SET."
(dolist (elt elements)
(if (and elt (not (string= "" elt)))
(setq set (if (member-ignore-case elt set)
@@ -2344,7 +2638,8 @@ With a prefix arg, prompt for new topic."
(cons elt set)))))
set)
-(defun-rcirc-command ignore (nick)
+
+(rcirc-define-command ignore (nick)
"Manage the ignore list.
Ignore NICK, unignore NICK if already ignored, or list ignored
nicks when no NICK is given. When listing ignored nicks, the
@@ -2361,7 +2656,7 @@ ones added to the list automatically are marked with an asterisk."
"*" "")))
rcirc-ignore-list " ")))
-(defun-rcirc-command bright (nick)
+(rcirc-define-command bright (nick)
"Manage the bright nick list."
(interactive "sToggle emphasis of nick: ")
(setq rcirc-bright-nicks
@@ -2370,7 +2665,7 @@ ones added to the list automatically are marked with an asterisk."
(rcirc-print process nil "BRIGHT" target
(mapconcat 'identity rcirc-bright-nicks " ")))
-(defun-rcirc-command dim (nick)
+(rcirc-define-command dim (nick)
"Manage the dim nick list."
(interactive "sToggle deemphasis of nick: ")
(setq rcirc-dim-nicks
@@ -2379,7 +2674,7 @@ ones added to the list automatically are marked with an asterisk."
(rcirc-print process nil "DIM" target
(mapconcat 'identity rcirc-dim-nicks " ")))
-(defun-rcirc-command keyword (keyword)
+(rcirc-define-command keyword (keyword)
"Manage the keyword list.
Mark KEYWORD, unmark KEYWORD if already marked, or list marked
keywords when no KEYWORD is given."
@@ -2421,7 +2716,7 @@ keywords when no KEYWORD is given."
(concat
"\\(?:"
;; Match paired parentheses, e.g. in Wikipedia URLs:
- "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]"
+ "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]"
"\\|"
"[" chars punct "]+" "[" chars "]"
"\\)"))
@@ -2454,28 +2749,85 @@ If ARG is given, opens the URL in a new browser window."
arg)))
(defun rcirc-markup-timestamp (_sender _response)
+ "Insert a timestamp."
(goto-char (point-min))
- (insert (rcirc-facify (format-time-string rcirc-time-format)
- 'rcirc-timestamp)))
+ (let ((time (and-let* ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time))))
+ (insert (rcirc-facify (format-time-string rcirc-time-format time)
+ 'rcirc-timestamp))))
(defun rcirc-markup-attributes (_sender _response)
- (while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t)
+ "Highlight IRC markup, indicated by ASCII control codes."
+ (while (re-search-forward
+ (rx (group (or #x02 #x1d #x1f #x1e #x11))
+ (*? nonl)
+ (group (or (backref 1) (+ #x0f) eol)))
+ nil t)
(rcirc-add-face (match-beginning 0) (match-end 0)
- (cl-case (char-after (match-beginning 1))
- (?\C-b 'bold)
- (?\C-v 'italic)
- (?\C-_ 'underline)))
- ;; keep the ^O since it could terminate other attributes
- (when (not (eq ?\C-o (char-before (match-end 2))))
- (delete-region (match-beginning 2) (match-end 2)))
- (delete-region (match-beginning 1) (match-end 1))
- (goto-char (match-beginning 1)))
- ;; remove the ^O characters now
- (goto-char (point-min))
- (while (re-search-forward "\C-o+" nil t)
+ (cl-case (char-after (match-beginning 0))
+ (#x02 'bold)
+ (#x1d 'italic)
+ (#x1f 'underline)
+ (#x1e '(:strike-through t))
+ (#x11 'rcirc-monospace-text)))
+ (goto-char (1+ (match-beginning 0)))))
+
+(defconst rcirc-color-codes
+ ;; Taken from https://modern.ircdocs.horse/formatting.html
+ ["white" "black" "blue" "green" "red" "brown" "magenta"
+ "orange" "yellow" "light green" "cyan" "light cyan"
+ "light blue" "pink" "grey" "light grey"
+ "#470000" "#472100" "#474700" "#324700" "#004700" "#00472c"
+ "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a"
+ "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449"
+ "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045"
+ "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571"
+ "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b"
+ "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0"
+ "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098"
+ "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9"
+ "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc"
+ "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb"
+ "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3"
+ "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565"
+ "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"]
+ "Vector of colors for each IRC color code.")
+
+(defun rcirc-color-attributes (_sender _response)
+ "Highlight IRC color-codes, indicated by ASCII control codes."
+ (while (re-search-forward
+ (rx #x03
+ (? (group (= 2 digit)) (? "," (group (= 2 digit))))
+ (*? nonl)
+ (or #x03 #x0f eol))
+ nil t)
+ (let (foreground background)
+ (when-let ((fg-raw (match-string 1))
+ (fg (string-to-number fg-raw))
+ ((<= 0 fg (1- (length rcirc-color-codes)))))
+ (setq foreground (aref rcirc-color-codes fg)))
+ (when-let ((bg-raw (match-string 2))
+ (bg (string-to-number bg-raw))
+ ((<= 0 bg (1- (length rcirc-color-codes)))))
+ (setq background (aref rcirc-color-codes bg)))
+ (rcirc-add-face (match-beginning 0) (match-end 0)
+ `(face (:foreground
+ ,foreground
+ :background
+ ,background))))))
+
+(defun rcirc-remove-markup-codes (_sender _response)
+ "Remove ASCII control codes used to designate markup."
+ (while (re-search-forward
+ (rx (or #x02 #x1d #x1f #x1e #x11 #x0f
+ (: #x03 (? (= 2 digit) (? "," (= 2 digit))))))
+ nil t)
(delete-region (match-beginning 0) (match-end 0))))
(defun rcirc-markup-my-nick (_sender response)
+ "Highlight the users nick.
+If RESPONSE indicates that the nick was mentioned in a message,
+highlight the entire line and record the activity."
(with-syntax-table rcirc-nick-syntax-table
(while (re-search-forward (concat "\\b"
(regexp-quote (rcirc-nick
@@ -2490,6 +2842,7 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-record-activity (current-buffer) 'nick)))))
(defun rcirc-markup-urls (_sender _response)
+ "Highlight and activate URLs."
(while (and rcirc-url-regexp ; nil means disable URL catching.
(re-search-forward rcirc-url-regexp nil t))
(let* ((start (match-beginning 0))
@@ -2506,12 +2859,17 @@ If ARG is given, opens the URL in a new browser window."
'follow-link t
'rcirc-url url
'action (lambda (button)
- (browse-url (button-get button 'rcirc-url))))
+ (browse-url-button-open-url
+ (button-get button 'rcirc-url))))
;; Record the URL if it is not already the latest stored URL.
(unless (string= url (caar rcirc-urls))
(push (cons url start) rcirc-urls)))))
(defun rcirc-markup-keywords (sender response)
+ "Highlight keywords as specified by `rcirc-keywords'.
+Keywords are only highlighted in messages (as indicated by
+RESPONSE) when they were not written by the user (as indicated by
+SENDER)."
(when (and (string= response "PRIVMSG")
(not (string= sender (rcirc-nick (rcirc-buffer-process)))))
(let* ((target (or rcirc-target ""))
@@ -2526,6 +2884,9 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-record-activity (current-buffer) 'keyword))))))
(defun rcirc-markup-bright-nicks (_sender response)
+ "Highlight nicks brightly as specified by `rcirc-bright-nicks'.
+This highlighting only takes place in name lists (as indicated by
+RESPONSE)."
(when (and rcirc-bright-nicks
(string= response "NAMES"))
(with-syntax-table rcirc-nick-syntax-table
@@ -2534,6 +2895,8 @@ If ARG is given, opens the URL in a new browser window."
'rcirc-bright-nick)))))
(defun rcirc-markup-fill (_sender response)
+ "Fill messages as configured by `rcirc-fill-column'.
+MOTD messages are not filled (as indicated by RESPONSE)."
(when (not (string= response "372")) ; /motd
(let ((fill-prefix
(or rcirc-fill-prefix
@@ -2551,8 +2914,11 @@ If ARG is given, opens the URL in a new browser window."
;; server or a user, depending on the command, the ARGS, which is a
;; list of strings, and the TEXT, which is the original server text,
;; verbatim
-(defun rcirc-handler-001 (process sender args text)
- (rcirc-handler-generic process "001" sender args text)
+(defun rcirc-handler-001 (process sender args _text)
+ "Handle welcome message.
+SENDER and ARGS are used to initialize the current connection.
+PROCESS is the process object for the current connection."
+ (rcirc-handler-generic process "001" sender args nil)
(with-rcirc-process-buffer process
(setq rcirc-connecting nil)
(rcirc-reschedule-timeout process)
@@ -2576,11 +2942,16 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-join-channels process rcirc-startup-channels))))
(defun rcirc-join-channels-post-auth (process)
- "Join `rcirc-startup-channels' after authenticating."
+ "Join `rcirc-startup-channels' after authenticating.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(rcirc-join-channels process rcirc-startup-channels)))
(defun rcirc-handler-PRIVMSG (process sender args text)
+ "Handle a (private) message from SENDER.
+ARGS should have the form (TARGET MESSAGE). TEXT is the verbatim
+message as received from the server. PROCESS is the process
+object for the current connection."
(rcirc-check-auth-status process sender args text)
(let ((target (if (rcirc-channel-p (car args))
(car args)
@@ -2594,6 +2965,10 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-put-nick-channel process sender target rcirc-current-line))))
(defun rcirc-handler-NOTICE (process sender args text)
+ "Handle a notice message from SENDER.
+ARGS should have the form (TARGET MESSAGE).
+TEXT is the verbatim message as received from the server.
+PROCESS is the process object for the current connection."
(rcirc-check-auth-status process sender args text)
(let ((target (car args))
(message (cadr args)))
@@ -2603,7 +2978,7 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-print process sender "NOTICE"
(cond ((rcirc-channel-p target)
target)
- ;;; -ChanServ- [#gnu] Welcome...
+ ;; -ChanServ- [#gnu] Welcome...
((string-match "\\[\\(#[^] ]+\\)\\]" message)
(match-string 1 message))
(sender
@@ -2615,7 +2990,9 @@ If ARG is given, opens the URL in a new browser window."
(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."
+the only argument. ARGS should have the form (TARGET MESSAGE).
+SENDER is used the determine the authentication method. PROCESS
+is the process object for the current connection."
(with-rcirc-process-buffer process
(when (and (not rcirc-user-authenticated)
rcirc-authenticate-before-join
@@ -2626,12 +3003,16 @@ the only argument."
(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)
- (format "You are successfully identified as \C-b%s\C-b." rcirc-nick)
- "Password accepted - you are now recognized."
- )))
+ (cl-member
+ message
+ (list
+ (format "You are now identified for \C-b%s\C-b." rcirc-nick)
+ (format "You are successfully identified as \C-b%s\C-b."
+ rcirc-nick)
+ "Password accepted - you are now recognized.")
+ ;; The nick may have a different case, so match
+ ;; case-insensitively (Bug#39345).
+ :test #'cl-equalp))
(and ;; quakenet
(string= sender "Q")
(string= target rcirc-nick)
@@ -2641,9 +3022,17 @@ the only argument."
(remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t))))))
(defun rcirc-handler-WALLOPS (process sender args _text)
+ "Handle WALLOPS message from SENDER.
+ARGS should have the form (MESSAGE).
+PROCESS is the process object for the current
+connection."
(rcirc-print process sender "WALLOPS" sender (car args) t))
(defun rcirc-handler-JOIN (process sender args _text)
+ "Handle JOIN message from SENDER.
+ARGS should have the form (CHANNEL).
+PROCESS is the process object for the current
+connection."
(let ((channel (car args)))
(with-current-buffer (rcirc-get-buffer-create process channel)
;; when recently rejoining, restore the linestamp
@@ -2665,6 +3054,8 @@ the only argument."
;; PART and KICK are handled the same way
(defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args)
+ "Remove NICK from CHANNEL.
+PROCESS is the process object for the current connection."
(rcirc-ignore-update-automatic nick)
(if (not (string= nick (rcirc-nick process)))
;; this is someone else leaving
@@ -2682,6 +3073,9 @@ the only argument."
(rcirc-disconnect-buffer buffer)))))
(defun rcirc-handler-PART (process sender args _text)
+ "Handle PART message from SENDER.
+ARGS should have the form (CHANNEL REASON).
+PROCESS is the process object for the current connection."
(let* ((channel (car args))
(reason (cadr args))
(message (concat channel " " reason)))
@@ -2693,6 +3087,9 @@ the only argument."
(rcirc-handler-PART-or-KICK process "PART" channel sender sender reason)))
(defun rcirc-handler-KICK (process sender args _text)
+ "Handle PART message from SENDER.
+ARGS should have the form (CHANNEL NICK REASON).
+PROCESS is the process object for the current connection."
(let* ((channel (car args))
(nick (cadr args))
(reason (nth 2 args))
@@ -2705,7 +3102,8 @@ the only argument."
(rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason)))
(defun rcirc-maybe-remember-nick-quit (process nick channel)
- "Remember NICK as leaving CHANNEL if they recently spoke."
+ "Remember NICK as leaving CHANNEL if they recently spoke.
+PROCESS is the process object for the current connection."
(let ((elapsed-lines (rcirc-elapsed-lines process nick channel)))
(when (and elapsed-lines
(< elapsed-lines rcirc-omit-threshold))
@@ -2721,6 +3119,8 @@ the only argument."
rcirc-recent-quit-alist))))))))))
(defun rcirc-handler-QUIT (process sender args _text)
+ "Handle QUIT message from SENDER.
+PROCESS is the process object for the current connection."
(rcirc-ignore-update-automatic sender)
(mapc (lambda (channel)
;; broadcast quit message each channel
@@ -2731,6 +3131,9 @@ the only argument."
(rcirc-nick-remove process sender))
(defun rcirc-handler-NICK (process sender args _text)
+ "Handle NICK message from SENDER.
+ARGS should have the form (NEW-NICK).
+PROCESS is the process object for the current connection."
(let* ((old-nick sender)
(new-nick (car args))
(channels (rcirc-nick-channels process old-nick)))
@@ -2762,21 +3165,30 @@ the only argument."
(when rcirc-auto-authenticate-flag (rcirc-authenticate))))))
(defun rcirc-handler-PING (process _sender args _text)
- (rcirc-send-string process (concat "PONG :" (car args))))
+ "Respond to a PING with a PONG.
+ARGS should have the form (MESSAGE). MESSAGE is relayed back to
+the server. PROCESS is the process object for the current
+connection."
+ (rcirc-send-string process "PONG" : (car args)))
(defun rcirc-handler-PONG (_process _sender _args _text)
- ;; do nothing
- )
+ "Ignore all incoming PONG messages.")
(defun rcirc-handler-TOPIC (process sender args _text)
+ "Note the topic change from SENDER.
+PROCESS is the process object for the current connection."
(let ((topic (cadr args)))
(rcirc-print process sender "TOPIC" (car args) topic)
(with-current-buffer (rcirc-get-buffer process (car args))
(setq rcirc-topic topic))))
-(defvar rcirc-nick-away-alist nil)
+(defvar rcirc-nick-away-alist nil
+ "Alist from nicks to away messages.")
+
(defun rcirc-handler-301 (process _sender args text)
- "RPL_AWAY"
+ "Handle away messages (RPL_AWAY).
+ARGS should have the form (NICK AWAY-MESSAGE).
+PROCESS is the process object for the current connection."
(let* ((nick (cadr args))
(rec (assoc-string nick rcirc-nick-away-alist))
(away-message (nth 2 args)))
@@ -2790,7 +3202,9 @@ the only argument."
rcirc-nick-away-alist))))))
(defun rcirc-handler-317 (process sender args _text)
- "RPL_WHOISIDLE"
+ "Handle idle messages from SENDER (RPL_WHOISIDLE).
+ARGS should have the form (NICK IDLE-SECS SIGNON-TIME).
+PROCESS is the process object for the current connection."
(let* ((nick (nth 1 args))
(idle-secs (string-to-number (nth 2 args)))
(idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs))
@@ -2801,15 +3215,20 @@ the only argument."
(rcirc-print process sender "317" nil message t)))
(defun rcirc-handler-332 (process _sender args _text)
- "RPL_TOPIC"
+ "Update topic when notified by server (RPL_TOPIC).
+ARGS should have the form (CHANNEL TOPIC).
+PROCESS is the process object for the current connection."
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
(setq rcirc-topic (nth 2 args)))))
(defun rcirc-handler-333 (process sender args _text)
- "333 says who set the topic and when.
-Not in rfc1459.txt"
+ "Update when and who set the current topic.
+ARGS has the form (CHANNEL SETTER TIME). SENDER is passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection. This is a non-standard extension, not specified in
+RFC1459."
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
@@ -2820,10 +3239,17 @@ Not in rfc1459.txt"
(format "%s (%s on %s)" rcirc-topic setter time))))))
(defun rcirc-handler-477 (process sender args _text)
- "ERR_NOCHANMODES"
+ "Notify user that CHANNEL does not support modes (ERR_NOCHANMODES).
+ARGS has the form (CHANNEL MESSAGE). SENDER is passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection."
(rcirc-print process sender "477" (cadr args) (nth 2 args)))
(defun rcirc-handler-MODE (process sender args _text)
+ "Handle MODE messages.
+ARGS should have the form (TARGET . MESSAGE-LIST).
+SENDER is passed on to `rcirc-print'.
+PROCESS is the process object for the current connection."
(let ((target (car args))
(msg (mapconcat 'identity (cdr args) " ")))
(rcirc-print process sender "MODE"
@@ -2844,7 +3270,9 @@ Not in rfc1459.txt"
(get-buffer-create tmpnam)))
(defun rcirc-handler-353 (process _sender args _text)
- "RPL_NAMREPLY"
+ "Start handling list of users (RPL_NAMREPLY).
+ARGS should have the form (TYPE CHANNEL . NICK-LIST).
+PROCESS is the process object for the current connection."
(let ((channel (nth 2 args))
(names (or (nth 3 args) "")))
(mapc (lambda (nick)
@@ -2857,7 +3285,9 @@ Not in rfc1459.txt"
(insert (car (last args)) " "))))
(defun rcirc-handler-366 (process sender args _text)
- "RPL_ENDOFNAMES"
+ "Handle end of user list (RPL_ENDOFNAMES).
+SENDER is passed on to `rcirc-print'.
+PROCESS is the process object for the current connection."
(let* ((channel (cadr args))
(buffer (rcirc-get-temp-buffer-create process channel)))
(with-current-buffer buffer
@@ -2867,11 +3297,42 @@ Not in rfc1459.txt"
(kill-buffer buffer)))
(defun rcirc-handler-433 (process sender args text)
- "ERR_NICKNAMEINUSE"
+ "Warn user that nick is used (ERR_NICKNAMEINUSE).
+ARGS should have the form (NICK CHANNEL WARNING).
+SENDER is passed on to `rcirc-handler-generic'.
+PROCESS is the process object for the current connection."
(rcirc-handler-generic process "433" sender args text)
- (let* ((new-nick (concat (cadr args) "`")))
- (with-rcirc-process-buffer process
- (rcirc-cmd-nick new-nick nil process))))
+ (with-rcirc-process-buffer process
+ (let* ((length (string-to-number
+ (or (rcirc-server-parameter-value 'nicklen)
+ "16"))))
+ (rcirc-cmd-nick (rcirc--make-new-nick (cadr args) length) nil process))))
+
+(defun rcirc--make-new-nick (nick length)
+ "Attempt to create a unused nickname out of NICK.
+A new nick may at most be LENGTH characters long. If we already
+have some ` chars at the end, then shorten the non-` bit of the
+name."
+ (when (= (length nick) length)
+ (setq nick (replace-regexp-in-string "[^`]\\(`+\\)\\'" "\\1" nick)))
+ (concat
+ (if (>= (length nick) length)
+ (substring nick 0 (1- length))
+ nick)
+ "`"))
+
+(defun rcirc-handler-005 (process sender args text)
+ "Register supported server features (RPL_ISUPPORT).
+ARGS should be a list of string feature parameters, either of the
+form \"PARAMETER\" to enable a feature, \"PARAMETER=VALUE\" to
+configure a specific option or \"-PARAMETER\" to disable a
+previously specified feature. SENDER is passed on to
+`rcirc-handler-generic'. PROCESS is the process object for the
+current connection. Note that this is not the behaviour as
+specified in RFC2812, where 005 stood for RPL_BOUNCE."
+ (rcirc-handler-generic process "005" sender args text)
+ (with-rcirc-process-buffer process
+ (setq rcirc-server-parameters (append rcirc-server-parameters args))))
(defun rcirc-authenticate ()
"Send authentication to process associated with current buffer.
@@ -2903,7 +3364,8 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(rcirc-send-privmsg
process
"&bitlbee"
- (concat "IDENTIFY " (car args)))))
+ (concat "IDENTIFY " (car args))))
+ (sasl nil))
;; quakenet authentication doesn't rely on the user's nickname.
;; the variable `nick' here represents the Q account name.
(when (eq method 'quakenet)
@@ -2913,12 +3375,37 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(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))
+ "Notify user of an invitation from SENDER.
+ARGS should have the form (TARGET CHANNEL). PROCESS is the
+process object for the current connection."
+ (let ((self (buffer-local-value 'rcirc-nick rcirc-process))
+ (target (car args))
+ (chan (cadr args)))
+ (if (string= target self)
+ (rcirc-print process sender "INVITE" nil
+ (format "%s invited you to %s"
+ sender chan)
+ t)
+ (rcirc-print process sender "INVITE" chan
+ (format "%s invited %s"
+ sender target)
+ t))))
(defun rcirc-handler-ERROR (process sender args _text)
+ "Print a error message.
+SENDER and ARGS (in concatenated form) are passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection."
(rcirc-print process sender "ERROR" nil (mapconcat 'identity args " ")))
(defun rcirc-handler-CTCP (process target sender text)
+ "Handle Client-To-Client-Protocol message TEXT.
+The message is addressed from SENDER to TARGET. Attempt to find
+an appropriate handler, by invoicing the function
+`rcirc-handler-ctcp-REQUEST', where REQUEST is the message type
+as extracted from TEXT. If no handler was found, an error
+message will be printed. PROCESS is the process object for the
+current connection."
(if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text)
(let* ((request (upcase (match-string 1 text)))
(args (match-string 2 text))
@@ -2933,28 +3420,128 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(rcirc-print process sender "CTCP" target
(format "%s" text) t))))))
-(defun rcirc-handler-ctcp-VERSION (process _target sender _args)
- (rcirc-send-string process
- (concat "NOTICE " sender
- " :\C-aVERSION " rcirc-id-string
- "\C-a")))
+(defun rcirc-handler-ctcp-VERSION (process _target sender _message)
+ "Handle a CTCP VERSION message from SENDER.
+PROCESS is the process object for the current connection."
+ (rcirc-send-string process "NOTICE" sender :
+ (rcirc-ctcp-wrap "VERSION" rcirc-id-string)))
-(defun rcirc-handler-ctcp-ACTION (process target sender args)
- (rcirc-print process sender "ACTION" target args t))
+(defun rcirc-handler-ctcp-ACTION (process target sender message)
+ "Handle a CTCP ACTION MESSAGE from SENDER to TARGET.
+PROCESS is the process object for the current connection."
+ (rcirc-print process sender "ACTION" target message t))
-(defun rcirc-handler-ctcp-TIME (process _target sender _args)
- (rcirc-send-string process
- (concat "NOTICE " sender
- " :\C-aTIME " (current-time-string) "\C-a")))
+(defun rcirc-handler-ctcp-TIME (process _target sender _message)
+ "Respond to CTCP TIME message from SENDER.
+PROCESS is the process object for the current connection."
+ (rcirc-send-string process "NOTICE" sender :
+ (rcirc-ctcp-wrap "TIME" (current-time-string))))
(defun rcirc-handler-CTCP-response (process _target sender message)
+ "Handle CTCP response MESSAGE from SENDER.
+PROCESS is the process object for the current connection."
(rcirc-print process sender "CTCP" nil message t))
+
+
+(defun rcirc-handler-CAP (process _sender args _text)
+ "Handle capability negotiation messages.
+ARGS should have the form (USER SUBCOMMAND . ARGUMENTS). PROCESS
+is the process object for the current connection."
+ (with-rcirc-process-buffer process
+ (let ((subcmd (cadr args)))
+ (dolist (cap (cddr args))
+ (cond ((string= subcmd "ACK")
+ (push cap rcirc-acked-capabilities)
+ (setq rcirc-requested-capabilities
+ (delete cap rcirc-requested-capabilities)))
+ ((string= subcmd "NAK")
+ (setq rcirc-requested-capabilities
+ (delete cap rcirc-requested-capabilities))))))
+ (when (and (null rcirc-requested-capabilities) rcirc-finished-sasl)
+ ;; All requested capabilities have been responded to
+ (rcirc-send-string process "CAP" "END"))))
+
+(defun rcirc-handler-TAGMSG (process sender _args _text)
+ "Handle a empty tag message from SENDER.
+PROCESS is the process object for the current connection."
+ (dolist (tag rcirc-message-tags)
+ (when-let ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag))))
+ ((fboundp handler)))
+ (funcall handler process sender (cdr tag)))))
+
+(defun rcirc-handler-BATCH (process _sender args _text)
+ "Open or close a batch.
+ARGS should have the form (tag type . parameters) when starting a
+batch, or (tag) when closing a batch. PROCESS is the process
+object for the current connection."
+ (with-rcirc-process-buffer process
+ (let ((type (cadr args))
+ (id (substring (car args) 1)))
+ (cond
+ ((= (aref (car args) 0) ?+) ;start a new batch
+ (when (assoc id rcirc-batch-attributes)
+ (error "Starting batch with already used ID"))
+ (setf (alist-get id rcirc-batch-attributes nil nil #'string=)
+ (cons type (cddr args))))
+ ((= (aref (car args) 0) ?-) ;close a batch
+ (unless (assoc id rcirc-batch-attributes)
+ (error "Closing a unknown batch"))
+ (let ((type (car (alist-get id rcirc-batch-attributes
+ nil nil #'string=))))
+ (when (eq (car (alist-get type rcirc-supported-batch-types
+ nil nil #'string=))
+ 'deferred)
+ (let ((messages (alist-get id rcirc-batched-messages
+ nil nil #'string=))
+ (bhandler (intern-soft (concat "rcirc-batch-handler-" type))))
+ (if (fboundp bhandler)
+ (funcall bhandler process id (nreverse messages))
+ (dolist (message (nreverse messages))
+ (let ((cmd (nth 0 message))
+ (process (nth 1 message))
+ (sender (nth 2 message))
+ (args (nth 3 message))
+ (text (nth 4 message))
+ (rcirc-message-tags (nth 5 message)))
+ (if-let (handler (intern-soft (concat "rcirc-handler-" cmd)))
+ (funcall handler process sender args text)
+ (rcirc-handler-generic process cmd sender args text))))))))
+ (setq rcirc-batch-attributes
+ (delq (assoc id rcirc-batch-attributes)
+ rcirc-batch-attributes)
+ rcirc-batched-messages
+ (delq (assoc id rcirc-batched-messages)
+ rcirc-batched-messages)))))))
+
+(defun rcirc-handler-AUTHENTICATE (process _cmd _args _text)
+ "Respond to authentication request.
+PROCESS is the process object for the current connection."
+ (rcirc-send-string
+ process
+ "AUTHENTICATE"
+ (base64-encode-string
+ ;; use connection user-name
+ (concat "\0" (nth 3 rcirc-connection-info)
+ "\0" (rcirc-get-server-password rcirc-server)))))
+
+(defun rcirc-handler-900 (process sender args _text)
+ "Respond to a successful authentication response."
+ (rcirc-handler-generic process "900" sender args nil)
+ (when (not rcirc-finished-sasl)
+ (setq-local rcirc-finished-sasl t)
+ (rcirc-send-string process "CAP" "END"))
+ (rcirc-join-channels-post-auth process))
+
(defgroup rcirc-faces nil
"Faces for rcirc."
:group 'rcirc
:group 'faces)
+(defface rcirc-monospace-text
+ '((t :family "Monospace"))
+ "Face used for monospace text in messages.")
+
(defface rcirc-my-nick ; font-lock-function-name-face
'((((class color) (min-colors 88) (background light)) :foreground "Blue1")
(((class color) (min-colors 88) (background dark)) :foreground "LightSkyBlue")
@@ -3064,10 +3651,18 @@ Passwords are stored in `rcirc-authinfo' (which see)."
;; When using M-x flyspell-mode, only check words after the prompt
(put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input)
(defun rcirc-looking-at-input ()
- "Return true if point is past the input marker."
+ "Return non-nil if point is past the input marker."
(>= (point) rcirc-prompt-end-marker))
+(defun rcirc-server-parameter-value (parameter)
+ "Traverse `rcirc-server-parameters' for PARAMETER."
+ (cl-loop for elem in rcirc-server-parameters
+ for setting = (split-string elem "=")
+ when (and (= (length setting) 2)
+ (string-equal (downcase (car setting)) parameter))
+ return (cadr setting)))
+
(provide 'rcirc)
;;; rcirc.el ends here
diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el
index d7a1b9274d0..c03ac5a87bc 100644
--- a/lisp/net/rfc2104.el
+++ b/lisp/net/rfc2104.el
@@ -26,11 +26,9 @@
;;
;; Example:
;;
-;; (require 'md5)
;; (rfc2104-hash 'md5 64 16 "Jefe" "what do ya want for nothing?")
;; "750c783e6ab0b503eaa86e310a5db738"
;;
-;; (require 'sha1)
;; (rfc2104-hash 'sha1 64 20 "Jefe" "what do ya want for nothing?")
;; "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79"
;;
diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el
index 09c02035b01..3136e53b80b 100644
--- a/lisp/net/rlogin.el
+++ b/lisp/net/rlogin.el
@@ -208,10 +208,8 @@ variable."
(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)
+ (setq-local rlogin-host host)
+ (setq-local rlogin-remote-user user)
(ignore-errors
(cond ((eq rlogin-directory-tracking-mode t)
;; Do this here, rather than calling the tracking mode
diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el
index bc2612d9452..4022a35b391 100644
--- a/lisp/net/sasl-cram.el
+++ b/lisp/net/sasl-cram.el
@@ -1,4 +1,4 @@
-;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework
+;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework -*- lexical-binding: t -*-
;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el
index efc8f82890c..5afc195d4b4 100644
--- a/lisp/net/sasl-digest.el
+++ b/lisp/net/sasl-digest.el
@@ -1,4 +1,4 @@
-;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework -*- lexical-binding: t -*-
;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el
index a1c03e24511..dfb7e713302 100644
--- a/lisp/net/sasl-ntlm.el
+++ b/lisp/net/sasl-ntlm.el
@@ -1,10 +1,10 @@
-;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework
+;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework -*- lexical-binding: t -*-
;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc.
;; Author: Taro Kawagishi <tarok@transpulse.org>
;; Keywords: SASL, NTLM
-;; Version: 1.00
+;; Old-Version: 1.00
;; Created: February 2001
;; Package: sasl
@@ -40,7 +40,7 @@
"A list of functions to be called in sequence for the NTLM
authentication steps. They are called by `sasl-next-step'.")
-(defun sasl-ntlm-request (client step)
+(defun sasl-ntlm-request (client _step)
"SASL step function to generate a NTLM authentication request to the server.
Called from `sasl-next-step'.
CLIENT is a vector [mechanism user service server sasl-client-properties]
diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el
new file mode 100644
index 00000000000..c1df988a369
--- /dev/null
+++ b/lisp/net/sasl-scram-sha256.el
@@ -0,0 +1,59 @@
+;;; sasl-scram-sha256.el --- SCRAM-SHA-256 module for the SASL client framework -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Package: sasl
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Implement the SCRAM-SHA-256 mechanism from RFC 7677.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'sasl)
+(require 'hex-util)
+(require 'rfc2104)
+(require 'sasl-scram-rfc)
+
+;;; SCRAM-SHA-256
+
+(defconst sasl-scram-sha-256-steps
+ '(sasl-scram-client-first-message
+ sasl-scram-sha-256-client-final-message
+ sasl-scram-sha-256-authenticate-server))
+
+(defun sasl-scram-sha256 (object &optional start end binary)
+ (secure-hash 'sha256 object start end binary))
+
+(defun sasl-scram-sha-256-client-final-message (client step)
+ (sasl-scram--client-final-message
+ ;; HMAC-SHA256 uses block length 64 and hash length 32; see RFC 4634.
+ 'sasl-scram-sha256 64 32 client step))
+
+(defun sasl-scram-sha-256-authenticate-server (client step)
+ (sasl-scram--authenticate-server
+ 'sasl-scram-sha256 64 32 client step))
+
+(put 'sasl-scram-sha256 'sasl-mechanism
+ (sasl-make-mechanism "SCRAM-SHA-256" sasl-scram-sha-256-steps))
+
+(provide 'sasl-scram-sha256)
+
+;;; sasl-scram-sha256.el ends here
diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el
index f6beaf56082..b7f814f7237 100644
--- a/lisp/net/sasl.el
+++ b/lisp/net/sasl.el
@@ -1,4 +1,4 @@
-;;; sasl.el --- SASL client framework
+;;; sasl.el --- SASL client framework -*- lexical-binding: t -*-
;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc.
@@ -35,8 +35,8 @@
;;; Code:
(defvar sasl-mechanisms
- '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"
- "NTLM"))
+ '("SCRAM-SHA-256" "SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN"
+ "ANONYMOUS" "NTLM"))
(defvar sasl-mechanism-alist
'(("CRAM-MD5" sasl-cram)
@@ -45,6 +45,7 @@
("LOGIN" sasl-login)
("ANONYMOUS" sasl-anonymous)
("NTLM" sasl-ntlm)
+ ("SCRAM-SHA-256" sasl-scram-sha256)
("SCRAM-SHA-1" sasl-scram-rfc)))
(defvar sasl-unique-id-function #'sasl-unique-id-function)
@@ -160,15 +161,8 @@ the current challenge. At the first time STEP should be set to nil."
(if function
(vector function (funcall function client step)))))
-(defvar sasl-read-passphrase nil)
+(defvar sasl-read-passphrase 'read-passwd)
(defun sasl-read-passphrase (prompt)
- (if (not sasl-read-passphrase)
- (if (functionp 'read-passwd)
- (setq sasl-read-passphrase 'read-passwd)
- (if (load "passwd" t)
- (setq sasl-read-passphrase 'read-passwd)
- (autoload 'ange-ftp-read-passwd "ange-ftp")
- (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
(funcall sasl-read-passphrase prompt))
(defun sasl-unique-id ()
@@ -209,7 +203,7 @@ It contain at least 64 bits of entropy."
(defconst sasl-plain-steps
'(sasl-plain-response))
-(defun sasl-plain-response (client step)
+(defun sasl-plain-response (client _step)
(let ((passphrase
(sasl-read-passphrase
(format "PLAIN passphrase for %s: " (sasl-client-name client))))
@@ -235,12 +229,12 @@ It contain at least 64 bits of entropy."
sasl-login-response-1
sasl-login-response-2))
-(defun sasl-login-response-1 (client step)
+(defun sasl-login-response-1 (client _step)
;;; (unless (string-match "^Username:" (sasl-step-data step))
;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
(sasl-client-name client))
-(defun sasl-login-response-2 (client step)
+(defun sasl-login-response-2 (client _step)
;;; (unless (string-match "^Password:" (sasl-step-data step))
;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step))))
(sasl-read-passphrase
@@ -256,7 +250,7 @@ It contain at least 64 bits of entropy."
'(ignore ;no initial response
sasl-anonymous-response))
-(defun sasl-anonymous-response (client step)
+(defun sasl-anonymous-response (client _step)
(or (sasl-client-property client 'trace)
(sasl-client-name client)))
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index ec517ac9eab..4102b9d322a 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -23,7 +23,7 @@
;;; Commentary:
;; This package provides an implementation of the Secret Service API
-;; <http://www.freedesktop.org/wiki/Specifications/secret-storage-spec>.
+;; <https://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
@@ -643,7 +643,7 @@ starting with a colon. Example:
The object labels of the found items are returned as list."
(mapcar
(lambda (item-path) (secrets-get-item-property item-path "Label"))
- (apply 'secrets-search-item-paths collection attributes)))
+ (apply #'secrets-search-item-paths collection attributes)))
(defun secrets-create-item (collection item password &rest attributes)
"Create a new item in COLLECTION with label ITEM and password PASSWORD.
@@ -780,9 +780,9 @@ ITEM can also be an object path, which is used if contained in COLLECTION."
(defvar secrets-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (make-composed-keymap special-mode-map widget-keymap))
- (define-key map "n" 'next-line)
- (define-key map "p" 'previous-line)
- (define-key map "z" 'kill-current-buffer)
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ (define-key map "z" #'kill-current-buffer)
map)
"Keymap used in `secrets-mode' buffers.")
@@ -792,11 +792,11 @@ In this mode, widgets represent the search results.
\\{secrets-mode-map}"
(setq buffer-undo-list t)
- (set (make-local-variable 'revert-buffer-function)
- #'secrets-show-collections)
+ (setq-local revert-buffer-function
+ #'secrets-show-collections)
;; When we toggle, we must set temporary widgets.
- (set (make-local-variable 'tree-widget-after-toggle-functions)
- '(secrets-tree-widget-after-toggle-function)))
+ (add-hook 'tree-widget-after-toggle-functions
+ #'secrets-tree-widget-after-toggle-function nil t))
;; It doesn't make sense to call it interactively.
(put 'secrets-mode 'disabled t)
@@ -859,7 +859,7 @@ to their attributes."
;; padding is needed to format attribute names.
(padding
(apply
- 'max
+ #'max
(cons
(1+ (length "password"))
(mapcar
@@ -957,3 +957,5 @@ to their attributes."
;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be
;; used for the transfer of the secrets. Currently, we use the
;; plain algorithm.
+
+;;; secrets.el ends here
diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el
index ac1f701fd37..eb78a259a8c 100644
--- a/lisp/net/shr-color.el
+++ b/lisp/net/shr-color.el
@@ -36,14 +36,12 @@
(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-color
:type 'number)
(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'. It's an
absolute value without any unit."
- :group 'shr-color
:type 'integer)
(defconst shr-color-html-colors-alist
@@ -332,8 +330,8 @@ color will be adapted to be visible on 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))
+ (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 (subtract L component)
@@ -351,12 +349,12 @@ color will be adapted to be visible on BG."
(list
(if fixed-background
bg
- (apply 'format "#%02x%02x%02x"
+ (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"
+ (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))))))))))
+ (apply #'color-lab-to-srgb fg-lab))))))))))
(provide 'shr-color)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index c3b37a7392f..85d81b6bbcc 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -95,15 +95,31 @@ If nil, don't draw horizontal table lines."
:type 'character)
(defcustom shr-width nil
- "Frame width to use for rendering.
+ "Window width to use for HTML 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.
-If `shr-use-fonts' is set, the mean character width is used to
-compute the pixel width, which is used instead."
+or nil, meaning use the full width of the window.
+If `shr-use-fonts' is set, the value is interpreted as a multiple
+of the mean character width of the default face's font.
+
+Also see `shr-max-width'."
:version "25.1"
:type '(choice (integer :tag "Fixed width in characters")
(const :tag "Use the width of the window" nil)))
+(defcustom shr-max-width 120
+ "Maximum text width to use for HTML rendering.
+May either be an integer specifying a fixed width in characters,
+or nil, meaning that there is no width limit.
+
+If `shr-use-fonts' is set, the value of this variable is
+interpreted as a multiple of the mean character width of the
+default face's font.
+
+If `shr-width' is non-nil, it overrides this variable."
+ :version "28.1"
+ :type '(choice (integer :tag "Fixed width in characters")
+ (const :tag "No width limit" nil)))
+
(defcustom shr-bullet "* "
"Bullet used for unordered lists.
Alternative suggestions are:
@@ -130,12 +146,20 @@ same domain as the main data."
:version "24.4"
:type 'boolean)
+(defcustom shr-offer-extend-specpdl t
+ "Non-nil means offer to extend the specpdl if the HTML nests deeply.
+Complicated HTML can require more nesting than the current specpdl
+size permits. If this variable is t, ask the user whether to increase
+the specpdl size. If nil, just give up."
+ :version "28.1"
+ :type 'boolean)
+
(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
+(defvar shr-put-image-function #'shr-put-image
"Function called to put image and alt string.")
(defface shr-strike-through '((t :strike-through t))
@@ -159,8 +183,37 @@ temporarily blinks with this face."
"Face for <abbr> elements."
:version "27.1")
-(defvar shr-inhibit-images nil
- "If non-nil, inhibit loading images.")
+(defface shr-h1
+ '((t :height 1.3 :weight bold))
+ "Face for <h1> elements."
+ :version "28.1")
+
+(defface shr-h2
+ '((t :weight bold))
+ "Face for <h2> elements."
+ :version "28.1")
+
+(defface shr-h3
+ '((t :slant italic))
+ "Face for <h3> elements."
+ :version "28.1")
+
+(defface shr-h4 nil
+ "Face for <h4> elements."
+ :version "28.1")
+
+(defface shr-h5 nil
+ "Face for <h5> elements."
+ :version "28.1")
+
+(defface shr-h6 nil
+ "Face for <h6> elements."
+ :version "28.1")
+
+(defcustom shr-inhibit-images nil
+ "If non-nil, inhibit loading images."
+ :version "28.1"
+ :type 'boolean)
(defvar shr-external-rendering-functions nil
"Alist of tag/function pairs used to alter how shr renders certain tags.
@@ -185,29 +238,31 @@ and other things:
(defvar shr-depth 0)
(defvar shr-warning nil)
(defvar shr-ignore-cache nil)
-(defvar shr-target-id nil)
(defvar shr-table-separator-length 1)
(defvar shr-table-separator-pixel-width 0)
(defvar shr-table-id nil)
(defvar shr-current-font nil)
(defvar shr-internal-bullet nil)
+(defvar shr-target-id nil
+ "Target fragment identifier anchor.")
+
(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 "z" 'shr-zoom-image)
- (define-key map [?\t] 'shr-next-link)
- (define-key map [?\M-\t] 'shr-previous-link)
+ (define-key map "a" #'shr-show-alt-text)
+ (define-key map "i" #'shr-browse-image)
+ (define-key map "z" #'shr-zoom-image)
+ (define-key map [?\t] #'shr-next-link)
+ (define-key map [?\M-\t] #'shr-previous-link)
(define-key map [follow-link] 'mouse-face)
- (define-key map [mouse-2] 'shr-browse-url)
- (define-key map [C-down-mouse-1] 'shr-mouse-browse-url-new-window)
- (define-key map "I" 'shr-insert-image)
- (define-key map "w" 'shr-maybe-probe-and-copy-url)
- (define-key map "u" 'shr-maybe-probe-and-copy-url)
- (define-key map "v" 'shr-browse-url)
- (define-key map "O" 'shr-save-contents)
- (define-key map "\r" 'shr-browse-url)
+ (define-key map [mouse-2] #'shr-browse-url)
+ (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window)
+ (define-key map "I" #'shr-insert-image)
+ (define-key map "w" #'shr-maybe-probe-and-copy-url)
+ (define-key map "u" #'shr-maybe-probe-and-copy-url)
+ (define-key map "v" #'shr-browse-url)
+ (define-key map "O" #'shr-save-contents)
+ (define-key map "\r" #'shr-browse-url)
map))
(defvar shr-image-map
@@ -265,30 +320,43 @@ DOM should be a parse tree as generated by
(shr-table-separator-pixel-width (shr-string-pixel-width "-"))
(shr-internal-bullet (cons shr-bullet
(shr-string-pixel-width shr-bullet)))
- (shr-internal-width (or (and shr-width
- (if (not shr-use-fonts)
- shr-width
- (* shr-width (frame-char-width))))
- ;; We need to adjust the available
- ;; width for when the user disables
- ;; the fringes, which will cause the
- ;; display engine usurp one column for
- ;; the continuation glyph.
- (if (not shr-use-fonts)
- (- (window-body-width) 1
- (if (and (null shr-width)
- (not (shr--have-one-fringe-p)))
- 0
- 1))
- (- (window-body-width nil t)
- (* 2 (frame-char-width))
- (if (and (null shr-width)
- (not (shr--have-one-fringe-p)))
- (* (frame-char-width) 2)
- 0)
- 1))))
+ (shr-internal-width
+ (if shr-width
+ ;; Specified width; use it.
+ (if (not shr-use-fonts)
+ shr-width
+ (* shr-width (frame-char-width)))
+ ;; Compute the width based on the window width. We need to
+ ;; adjust the available width for when the user disables
+ ;; the fringes, which will cause the display engine usurp
+ ;; one column for the continuation glyph.
+ (if (not shr-use-fonts)
+ (- (window-body-width) 1
+ (if (shr--have-one-fringe-p)
+ 1
+ 0))
+ (- (window-body-width nil t)
+ (* 2 (frame-char-width))
+ (if (shr--have-one-fringe-p)
+ 0
+ (* (frame-char-width) 2))
+ 1))))
(max-specpdl-size max-specpdl-size)
+ ;; `bidi-display-reordering' is supposed to be only used for
+ ;; debugging purposes, but Shr's naïve filling algorithm
+ ;; cannot cope with the complexity of RTL text in an LTR
+ ;; paragraph, when a long line has been continued, and for
+ ;; most scripts the character metrics don't change when they
+ ;; are reordered, so... this is the best we could do :-(
bidi-display-reordering)
+ ;; Adjust for max width specification.
+ (when (and shr-max-width
+ (not shr-width))
+ (setq shr-internal-width
+ (min shr-internal-width
+ (if shr-use-fonts
+ (* shr-max-width (frame-char-width))
+ shr-max-width))))
;; If the window was hscrolled for some reason, shr-fill-lines
;; below will misbehave, because it silently assumes that it
;; starts with a non-hscrolled window (vertical-motion will move
@@ -365,25 +433,20 @@ If the URL is already at the front of the kill ring act like
(shr-copy-url url)))
(defun shr--current-link-region ()
- (let ((current (get-text-property (point) 'shr-url))
- start)
- (save-excursion
- ;; Go to the beginning.
- (while (and (not (bobp))
- (equal (get-text-property (point) 'shr-url) current))
- (forward-char -1))
- (unless (equal (get-text-property (point) 'shr-url) current)
- (forward-char 1))
- (setq start (point))
- ;; Go to the end.
- (while (and (not (eobp))
- (equal (get-text-property (point) 'shr-url) current))
- (forward-char 1))
- (list start (point)))))
+ "Return the start and end positions of the URL at point, if any.
+Value is a pair of positions (START . END) if there is a non-nil
+`shr-url' text property at point; otherwise nil."
+ (when (get-text-property (point) 'shr-url)
+ (let* ((end (or (next-single-property-change (point) 'shr-url)
+ (point-max)))
+ (beg (or (previous-single-property-change end 'shr-url)
+ (point-min))))
+ (cons beg end))))
(defun shr--blink-link ()
- (let* ((region (shr--current-link-region))
- (overlay (make-overlay (car region) (cadr region))))
+ "Briefly fontify URL at point with the face `shr-selected-link'."
+ (when-let* ((region (shr--current-link-region))
+ (overlay (make-overlay (car region) (cdr region))))
(overlay-put overlay 'face 'shr-selected-link)
(run-at-time 1 nil (lambda ()
(delete-overlay overlay)))))
@@ -406,6 +469,7 @@ If the URL is already at the front of the kill ring act like
(defun shr-show-alt-text ()
"Show the ALT text of the image under point."
+ (declare (completion (lambda (_ b) (command-completion-button-p 'shr b))))
(interactive)
(let ((text (get-text-property (point) 'shr-alt)))
(if (not text)
@@ -437,7 +501,7 @@ the URL of the image to the kill buffer instead."
(if (not url)
(message "No image under point")
(message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
+ (url-retrieve url #'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker))
t))))
@@ -463,7 +527,7 @@ size, and full-buffer size."
(when (> (- (point) start) 2)
(delete-region start (1- (point)))))
(message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
+ (url-retrieve url #'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker)
(list (cons 'size
(cond ((or (eq size 'default)
@@ -493,7 +557,7 @@ size, and full-buffer size."
((fboundp function)
(apply function dom args))
(t
- (apply 'shr-generic dom args)))))
+ (apply #'shr-generic dom args)))))
(defun shr-descend (dom)
(let ((function
@@ -507,7 +571,8 @@ size, and full-buffer size."
(start (point)))
;; shr uses many frames per nested node.
(if (and (> shr-depth (/ max-specpdl-size 15))
- (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?")
+ (not (and shr-offer-extend-specpdl
+ (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?")
(setq max-specpdl-size (* max-specpdl-size 2)))))
(setq shr-warning
"Not rendering the complete page because of too-deep nesting")
@@ -531,13 +596,16 @@ size, and full-buffer size."
(funcall function dom))
(t
(shr-generic dom)))
- (when (and shr-target-id
- (equal (dom-attr dom 'id) shr-target-id))
+ (when-let* ((id (dom-attr dom 'id)))
;; If the element was empty, we don't have anything to put the
;; anchor on. So just insert a dummy character.
(when (= start (point))
- (insert "*"))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ (if (not (bolp))
+ (insert ? )
+ (insert ? )
+ (shr-mark-fill start))
+ (put-text-property (1- (point)) (point) 'display ""))
+ (put-text-property start (1+ start) 'shr-target-id id))
;; If style is set, then this node has set the color.
(when style
(shr-colorize-region
@@ -655,8 +723,11 @@ size, and full-buffer size."
(goto-char start)
(when (looking-at "[ \t\n\r]+")
(replace-match "" t t))
- (while (re-search-forward "[ \t\n\r]+" nil t)
+ (while (re-search-forward "[\t\n\r]+" nil t)
(replace-match " " t t))
+ (goto-char start)
+ (while (re-search-forward " +" nil t)
+ (replace-match " " t t))
(shr--translate-insertion-chars)
(goto-char (point-max)))
;; We may have removed everything we inserted if it was just
@@ -694,7 +765,8 @@ size, and full-buffer size."
(forward-char 1))))
(defun shr-fill-line ()
- (let ((shr-indentation (get-text-property (point) 'shr-indentation))
+ (let ((shr-indentation (or (get-text-property (point) 'shr-indentation)
+ shr-indentation))
(continuation (get-text-property
(point) 'shr-continuation-indentation))
start)
@@ -730,10 +802,11 @@ size, and full-buffer size."
(let ((gap-start (point))
(face (get-text-property (point) 'face)))
;; Extend the background to the end of the line.
- (if face
- (insert (propertize "\n" 'face (shr-face-background face)))
- (insert "\n"))
+ (insert ?\n)
(shr-indent)
+ (when face
+ (put-text-property gap-start (point)
+ 'face (shr-face-background face)))
(when (and (> (1- gap-start) (point-min))
(get-text-property (point) 'shr-url)
;; The link on both sides of the newline are the
@@ -838,7 +911,7 @@ size, and full-buffer size."
;; Always chop off anchors.
(when (string-match "#.*" url)
(setq url (substring url 0 (match-beginning 0))))
- ;; NB: <base href="" > URI may itself be relative to the document s URI
+ ;; NB: <base href=""> URI may itself be relative to the document's URI.
(setq url (shr-expand-url url))
(let* ((parsed (url-generic-parse-url url))
(local (url-filename parsed)))
@@ -911,6 +984,22 @@ size, and full-buffer size."
(looking-at " *$")))
;; We're already at a new paragraph; do nothing.
)
+ ((and (not (bolp))
+ (save-excursion
+ (beginning-of-line)
+ (looking-at " *$"))
+ (save-excursion
+ (forward-line -1)
+ (looking-at " *$"))
+ ;; Check all chars on the current line and see whether
+ ;; they're all placeholders.
+ (cl-loop for pos from (line-beginning-position) upto (1- (point))
+ unless (get-text-property pos 'shr-target-id)
+ return nil
+ finally return t))
+ ;; We have some invisible markers from <div id="foo"></div>;
+ ;; do nothing.
+ )
((and prefix
(= prefix (- (point) (line-beginning-position))))
;; Do nothing; we're at the start of a <li>.
@@ -935,12 +1024,11 @@ size, and full-buffer size."
(defun shr-indent ()
(when (> shr-indentation 0)
- (insert
- (if (not shr-use-fonts)
- (make-string shr-indentation ?\s)
- (propertize " "
- 'display
- `(space :width (,shr-indentation)))))))
+ (if (not shr-use-fonts)
+ (insert-char ?\s shr-indentation)
+ (insert ?\s)
+ (put-text-property (1- (point)) (point)
+ 'display `(space :width (,shr-indentation))))))
(defun shr-fontize-dom (dom &rest types)
(let ((start (point)))
@@ -987,16 +1075,11 @@ the mouse click event."
(cond
((not url)
(message "No link under point"))
- ((string-match "^mailto:" url)
- (browse-url-mail url))
+ (external
+ (funcall browse-url-secondary-browser-function url)
+ (shr--blink-link))
(t
- (if external
- (progn
- (funcall browse-url-secondary-browser-function url)
- (shr--blink-link))
- (browse-url url (if new-window
- (not browse-url-new-window-flag)
- browse-url-new-window-flag)))))))
+ (browse-url url (xor new-window browse-url-new-window-flag))))))
(defun shr-save-contents (directory)
"Save the contents from URL in a file."
@@ -1005,7 +1088,7 @@ the mouse click event."
(if (not url)
(message "No link under point")
(url-retrieve (shr-encode-url url)
- 'shr-store-contents (list url directory)))))
+ #'shr-store-contents (list url directory)))))
(defun shr-store-contents (status url directory)
(unless (plist-get status :error)
@@ -1156,7 +1239,6 @@ width/height instead."
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
-(autoload 'browse-url-mail "browse-url")
(defun shr-get-image-data (url)
"Get image data for URL.
@@ -1195,44 +1277,27 @@ Return a string with image data."
;; that are non-ASCII.
(shr-dom-to-xml
(libxml-parse-xml-region (point) (point-max)) 'utf-8)))
- ;; SVG images often do not have a specified foreground/background
- ;; color, so wrap them in styles.
- (when (and (display-images-p)
- (eq content-type 'image/svg+xml))
- (setq data (svg--wrap-svg data)))
(list data content-type)))
-(defun svg--wrap-svg (data)
- "Add a default foreground colour to SVG images."
- (let ((size (image-size (create-image data nil t :scaling 1) t)))
- (with-temp-buffer
- (insert
- (format
- "<svg xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:xi=\"http://www.w3.org/2001/XInclude\" style=\"color: %s;\" viewBox=\"0 0 %d %d\"> <xi:include href=\"data:image/svg+xml;base64,%s\"></xi:include></svg>"
- (face-foreground 'default)
- (car size) (cdr size)
- (base64-encode-string data t)))
- (buffer-string))))
-
(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 markers."
- `(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 start end))
- (delete-region (point) end))))
- (url-retrieve url 'shr-image-fetched
- (list (current-buffer) start end)
- t t)))))
+ (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 start end))
+ (delete-region (point) end))))
+ (url-retrieve url #'shr-image-fetched
+ (list (current-buffer) start end)
+ t t)))))
(defun shr-heading (dom &rest types)
(shr-ensure-paragraph)
@@ -1265,7 +1330,9 @@ START, and END. Note that START and END should be markers."
(format "%s (%s)" iri title)
iri))
'follow-link t
- 'mouse-face 'highlight))
+ ;; Make separate regions not `eq' so that they'll get
+ ;; separate mouse highlights.
+ 'mouse-face (list 'highlight)))
;; Don't overwrite any keymaps that are already in the buffer (i.e.,
;; image keymaps).
(while (and start
@@ -1316,7 +1383,7 @@ ones, in case fg and bg are nil."
t))
(when bg
(add-face-text-property start end
- (list :background (car new-colors))
+ (list :background (car new-colors) :extend t)
t)))
new-colors)))
@@ -1438,7 +1505,7 @@ ones, in case fg and bg are nil."
(shr-fontize-dom dom 'underline))
(defun shr-tag-code (dom)
- (let ((shr-current-font 'default))
+ (let ((shr-current-font 'fixed-pitch))
(shr-generic dom)))
(defun shr-tag-tt (dom)
@@ -1485,8 +1552,9 @@ ones, in case fg and bg are nil."
plist)))
(defun shr-tag-base (dom)
- (when-let* ((base (dom-attr dom 'href)))
- (setq shr-base (shr-parse-base base)))
+ (let ((base (dom-attr dom 'href)))
+ (when (> (length base) 0)
+ (setq shr-base (shr-parse-base base))))
(shr-generic dom))
(defun shr-tag-a (dom)
@@ -1495,14 +1563,13 @@ ones, in case fg and bg are nil."
(start (point))
shr-start)
(shr-generic dom)
- (when (and shr-target-id
- (equal (dom-attr dom 'name) shr-target-id))
- ;; We have a zero-length <a name="foo"> element, so just
- ;; insert... something.
+ (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'.
+ (dom-attr dom 'name)))) ; Obsolete since HTML5.
+ ;; We have an empty element, so just insert... something.
(when (= start (point))
- (shr-ensure-newline)
- (insert " "))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ (insert ?\s)
+ (put-text-property (1- (point)) (point) 'display ""))
+ (put-text-property start (1+ start) 'shr-target-id id))
(when url
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
@@ -1677,7 +1744,7 @@ The preference is a float determined from `shr-prefer-media-type'."
(or alt "")))
(insert " ")
(url-queue-retrieve
- (shr-encode-url url) 'shr-image-fetched
+ (shr-encode-url url) #'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (point))
(list :width width :height height))
t
@@ -1899,24 +1966,22 @@ BASE is the URL of the HTML being rendered."
(shr-generic dom))
(defun shr-tag-h1 (dom)
- (shr-heading dom (if shr-use-fonts
- '(variable-pitch (:height 1.3 :weight bold))
- 'bold)))
+ (shr-heading dom 'shr-h1))
(defun shr-tag-h2 (dom)
- (shr-heading dom 'bold))
+ (shr-heading dom 'shr-h2))
(defun shr-tag-h3 (dom)
- (shr-heading dom 'italic))
+ (shr-heading dom 'shr-h3))
(defun shr-tag-h4 (dom)
- (shr-heading dom))
+ (shr-heading dom 'shr-h4))
(defun shr-tag-h5 (dom)
- (shr-heading dom))
+ (shr-heading dom 'shr-h5))
(defun shr-tag-h6 (dom)
- (shr-heading dom))
+ (shr-heading dom 'shr-h6))
(defun shr-tag-hr (_dom)
(shr-ensure-newline)
@@ -2004,12 +2069,11 @@ BASE is the URL of the HTML being rendered."
(cond
((null tbodies)
dom)
- ((= (length tbodies) 1)
+ ((null (cdr tbodies))
(car tbodies))
(t
;; Table with multiple tbodies. Convert into a single tbody.
- `(tbody nil ,@(cl-reduce 'append
- (mapcar 'dom-non-text-children tbodies)))))))
+ `(tbody nil ,@(mapcan #'dom-non-text-children tbodies))))))
(defun shr--fix-tbody (tbody)
(nconc (list 'tbody (dom-attributes tbody))
@@ -2253,7 +2317,7 @@ flags that control whether to collect or render objects."
(not background))
(setq background (cadr elem))))
(and background
- (list :background background))))))
+ (list :background background :extend t))))))
(defun shr-expand-alignments (start end)
(while (< (setq start (next-single-property-change
@@ -2309,8 +2373,8 @@ flags that control whether to collect or render objects."
(dolist (column row)
(aset natural-widths i (max (aref natural-widths i) column))
(setq i (1+ i)))))
- (let ((extra (- (apply '+ (append suggested-widths nil))
- (apply '+ (append widths nil))
+ (let ((extra (- (apply #'+ (append suggested-widths nil))
+ (apply #'+ (append widths nil))
(* shr-table-separator-pixel-width (1+ (length widths)))))
(expanded-columns 0))
;; We have extra, unused space, so divide this space amongst the
@@ -2585,12 +2649,28 @@ flags that control whether to collect or render objects."
i))
(defun shr-max-columns (dom)
- (let ((max 0))
+ (let ((max 0)
+ (this 0)
+ (rowspans nil))
(dolist (row (dom-children dom))
(when (and (not (stringp row))
(eq (dom-tag row) 'tr))
- (setq max (max max (+ (shr-count row 'td)
- (shr-count row 'th))))))
+ (setq this 0)
+ (dolist (column (dom-children row))
+ (when (and (not (stringp column))
+ (memq (dom-tag column) '(td th)))
+ (setq this (+ 1 this (length rowspans)))
+ ;; We have a rowspan, which we emulate later in rendering
+ ;; by adding an extra column to the following rows.
+ (when-let* ((span (dom-attr column 'rowspan)))
+ (push (string-to-number span) rowspans))))
+ (setq max (max max this)))
+ ;; Count down the rowspans in effect.
+ (let ((new nil))
+ (dolist (span rowspans)
+ (when (> span 1)
+ (push (1- span) new)))
+ (setq rowspans new)))
max))
(provide 'shr)
diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el
index c4d6ec4b6cc..1f08a15e570 100644
--- a/lisp/net/sieve-manage.el
+++ b/lisp/net/sieve-manage.el
@@ -89,18 +89,15 @@
(defcustom sieve-manage-log "*sieve-manage-log*"
"Name of buffer for managesieve session trace."
- :type 'string
- :group 'sieve-manage)
+ :type 'string)
(defcustom sieve-manage-server-eol "\r\n"
"The EOL string sent from the server."
- :type 'string
- :group 'sieve-manage)
+ :type 'string)
(defcustom sieve-manage-client-eol "\r\n"
"The EOL string we send to the server."
- :type 'string
- :group 'sieve-manage)
+ :type 'string)
(defcustom sieve-manage-authenticators '(digest-md5
cram-md5
@@ -112,8 +109,7 @@
;; FIXME Improve this. It's not `set'.
;; It's like (repeat (choice (const ...))), where each choice can
;; only appear once.
- :type '(repeat symbol)
- :group 'sieve-manage)
+ :type '(repeat symbol))
(defcustom sieve-manage-authenticator-alist
'((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth)
@@ -130,26 +126,22 @@ NAME names the authenticator. CHECK is a function returning non-nil if
the server support the authenticator and AUTHENTICATE is a function
for doing the actual authentication."
:type '(repeat (list (symbol :tag "Name") (function :tag "Check function")
- (function :tag "Authentication function")))
- :group 'sieve-manage)
+ (function :tag "Authentication function"))))
(defcustom sieve-manage-default-port "sieve"
"Default port number or service name for managesieve protocol."
:type '(choice integer string)
- :version "24.4"
- :group 'sieve-manage)
+ :version "24.4")
(defcustom sieve-manage-default-stream 'network
"Default stream type to use for `sieve-manage'."
:version "24.1"
- :type 'symbol
- :group 'sieve-manage)
+ :type 'symbol)
(defcustom sieve-manage-ignore-starttls nil
"Ignore STARTTLS even if STARTTLS capability is provided."
:version "26.1"
- :type 'boolean
- :group 'sieve-manage)
+ :type 'boolean)
;; Internal variables:
@@ -247,7 +239,7 @@ Return the buffer associated with the connection."
(sasl-read-passphrase
;; We *need* to copy the password, because sasl will modify it
;; somehow.
- `(lambda (prompt) ,(copy-sequence user-password)))
+ (lambda (_prompt) (copy-sequence user-password)))
(step (sasl-next-step client nil))
(_tag (sieve-manage-send
(concat
@@ -580,4 +572,4 @@ to local variable `sieve-manage-capability'."
(provide 'sieve-manage)
-;; sieve-manage.el ends here
+;;; sieve-manage.el ends here
diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el
index c94df1cfaf2..0e8fdc0a905 100644
--- a/lisp/net/sieve-mode.el
+++ b/lisp/net/sieve-mode.el
@@ -1,4 +1,4 @@
-;;; sieve-mode.el --- Sieve code editing commands for Emacs
+;;; sieve-mode.el --- Sieve code editing commands for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -26,11 +26,6 @@
;; sieve-style #-comments and a lightly hacked syntax table. It was
;; strongly influenced by awk-mode.el.
;;
-;; Put something similar to the following in your .emacs to use this file:
-;;
-;; (load "~/lisp/sieve")
-;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist))
-;;
;; References:
;;
;; RFC 3028,
@@ -48,8 +43,6 @@
(autoload 'sieve-manage "sieve")
(autoload 'sieve-upload "sieve")
-(eval-when-compile
- (require 'font-lock))
(defgroup sieve nil
"Sieve."
@@ -135,6 +128,9 @@
(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 in use in sieve-mode buffers.")
@@ -143,9 +139,9 @@
(defvar sieve-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-l" 'sieve-upload)
- (define-key map "\C-c\C-c" 'sieve-upload-and-kill)
- (define-key map "\C-c\C-m" 'sieve-manage)
+ (define-key map "\C-c\C-l" #'sieve-upload)
+ (define-key map "\C-c\C-c" #'sieve-upload-and-kill)
+ (define-key map "\C-c\C-m" #'sieve-manage)
map)
"Key map used in sieve mode.")
@@ -185,25 +181,29 @@
'syntax-table (string-to-syntax "|")))))
;;;###autoload
-(define-derived-mode sieve-mode c-mode "Sieve"
+(define-derived-mode sieve-mode prog-mode "Sieve"
"Major mode for editing Sieve code.
-This is much like C mode except for the syntax of comments. Its keymap
-inherits from C mode's and it has the same variables for customizing
-indentation. It has its own abbrev table and its own syntax table.
-
Turning on Sieve mode runs `sieve-mode-hook'."
- (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-end) "")
- ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *")
- (set (make-local-variable 'comment-start-skip) "#+ *")
- (set (make-local-variable 'syntax-propertize-function)
- #'sieve-syntax-propertize)
- (set (make-local-variable 'font-lock-defaults)
- '(sieve-font-lock-keywords nil nil ((?_ . "w"))))
+ (setq-local paragraph-start (concat "$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local comment-start "#")
+ (setq-local comment-end "")
+ ;; (setq-local comment-start-skip "\\(^\\|\\s-\\);?#+ *")
+ (setq-local comment-start-skip "#+ *")
+ (setq-local syntax-propertize-function #'sieve-syntax-propertize)
+ (setq-local font-lock-defaults
+ '(sieve-font-lock-keywords nil nil ((?_ . "w"))))
+ (setq-local indent-line-function #'sieve-mode-indent-function)
(easy-menu-add-item nil nil sieve-mode-menu))
+(defun sieve-mode-indent-function ()
+ (save-excursion
+ (beginning-of-line)
+ (let ((depth (car (syntax-ppss))))
+ (when (looking-at "[ \t]*}")
+ (setq depth (1- depth)))
+ (indent-line-to (* 2 depth)))))
+
(provide 'sieve-mode)
-;; sieve-mode.el ends here
+;;; sieve-mode.el ends here
diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el
index 0455d4867b4..6d571a0a30f 100644
--- a/lisp/net/sieve.el
+++ b/lisp/net/sieve.el
@@ -1,4 +1,4 @@
-;;; sieve.el --- Utilities to manage sieve scripts
+;;; sieve.el --- Utilities to manage sieve scripts -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -69,13 +69,11 @@
(defcustom sieve-new-script "<new script>"
"Name of name script indicator."
- :type 'string
- :group 'sieve)
+ :type 'string)
(defcustom sieve-buffer "*sieve*"
"Name of sieve management buffer."
- :type 'string
- :group 'sieve)
+ :type 'string)
(defcustom sieve-template "\
require \"fileinto\";
@@ -91,8 +89,7 @@ require \"fileinto\";
# }
"
"Template sieve script."
- :type 'string
- :group 'sieve)
+ :type 'string)
;; Internal variables:
@@ -104,31 +101,36 @@ require \"fileinto\";
;; Sieve-manage mode:
+;; This function is defined by `easy-menu-define' but it's only done
+;; at run time and the compiler is not aware of it.
+;; FIXME: This is arguably a bug/problem in `easy-menu-define'.
+(declare-function sieve-manage-mode-menu "sieve")
+
(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 "?" #'sieve-help)
+ (define-key map "h" #'sieve-help)
;; activating
- (define-key map "m" 'sieve-activate)
- (define-key map "u" 'sieve-deactivate)
- (define-key map "\M-\C-?" 'sieve-deactivate-all)
+ (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-bury-buffer)
- (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)
+ (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-bury-buffer)
+ (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'.")
@@ -143,8 +145,7 @@ require \"fileinto\";
(define-derived-mode sieve-manage-mode special-mode "Sieve-manage"
"Mode used for sieve script management."
(buffer-disable-undo (current-buffer))
- (setq truncate-lines t)
- (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))
+ (setq truncate-lines t))
;; Commands used in sieve-manage mode:
@@ -160,8 +161,8 @@ require \"fileinto\";
(interactive)
(bury-buffer))
-(defun sieve-activate (&optional pos)
- (interactive "d")
+(defun sieve-activate (&optional _pos)
+ (interactive)
(let ((name (sieve-script-at-point)) err)
(when (or (null name) (string-equal name sieve-new-script))
(error "No sieve script at point"))
@@ -172,20 +173,20 @@ require \"fileinto\";
(message "Activating script %s...done" name)
(message "Activating script %s...failed: %s" name (nth 2 err)))))
-(defun sieve-deactivate-all (&optional pos)
- (interactive "d")
- (let ((name (sieve-script-at-point)) err)
- (message "Deactivating scripts...")
- (setq err (sieve-manage-setactive "" sieve-manage-buffer))
+(defun sieve-deactivate-all (&optional _pos)
+ (interactive)
+ (message "Deactivating scripts...")
+ (let (;; (name (sieve-script-at-point))
+ (err (sieve-manage-setactive "" sieve-manage-buffer)))
(sieve-refresh-scriptlist)
(if (sieve-manage-ok-p err)
(message "Deactivating scripts...done")
(message "Deactivating scripts...failed: %s" (nth 2 err)))))
-(defalias 'sieve-deactivate 'sieve-deactivate-all)
+(defalias 'sieve-deactivate #'sieve-deactivate-all)
-(defun sieve-remove (&optional pos)
- (interactive "d")
+(defun sieve-remove (&optional _pos)
+ (interactive)
(let ((name (sieve-script-at-point)) err)
(when (or (null name) (string-equal name sieve-new-script))
(error "No sieve script at point"))
@@ -196,8 +197,8 @@ require \"fileinto\";
(sieve-refresh-scriptlist)
(message "Removing sieve script %s...done" name)))
-(defun sieve-edit-script (&optional pos)
- (interactive "d")
+(defun sieve-edit-script (&optional _pos)
+ (interactive)
(let ((name (sieve-script-at-point)))
(unless name
(error "No sieve script at point"))
@@ -225,11 +226,11 @@ require \"fileinto\";
(defmacro sieve-change-region (&rest body)
"Turns off sieve-region before executing BODY, then re-enables it after.
Used to bracket operations which move point in the sieve-buffer."
+ (declare (indent 0) (debug t))
`(progn
(sieve-highlight nil)
,@body
(sieve-highlight t)))
-(put 'sieve-change-region 'lisp-indent-function 0)
(defun sieve-next-line (&optional arg)
(interactive)
@@ -273,8 +274,7 @@ Used to bracket operations which move point in the sieve-buffer."
(let* ((port (or port sieve-manage-default-port))
(header (format "Server : %s:%s\n\n" server port)))
(insert header))
- (set (make-local-variable 'sieve-buffer-header-end)
- (point-max)))
+ (setq-local sieve-buffer-header-end (point-max)))
(defun sieve-script-at-point (&optional pos)
"Return name of sieve script at point POS, or nil."
@@ -305,8 +305,8 @@ Used to bracket operations which move point in the sieve-buffer."
"Open SERVER (on PORT) and authenticate."
(with-current-buffer
(or ;; open server
- (set (make-local-variable 'sieve-manage-buffer)
- (sieve-manage-open server port))
+ (setq-local sieve-manage-buffer
+ (sieve-manage-open server port))
(error "Error opening server %s" server))
(sieve-manage-authenticate)))
@@ -362,8 +362,8 @@ Used to bracket operations which move point in the sieve-buffer."
(if (not (sieve-manage-ok-p err))
(message "Sieve upload failed: %s" (nth 2 err))
(message "Sieve upload done. Use %s to manage scripts."
- (substitute-command-keys "\\[sieve-manage]"))
- (set-buffer-modified-p nil))))))
+ (substitute-command-keys "\\[sieve-manage]"))))
+ (set-buffer-modified-p nil))))
;;;###autoload
(defun sieve-upload-and-bury (&optional name)
@@ -379,4 +379,4 @@ Used to bracket operations which move point in the sieve-buffer."
(provide 'sieve)
-;; sieve.el ends here
+;;; sieve.el ends here
diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el
index 55cd527de29..ae878ef3a51 100644
--- a/lisp/net/snmp-mode.el
+++ b/lisp/net/snmp-mode.el
@@ -1,4 +1,4 @@
-;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode
+;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode -*- lexical-binding: t -*-
;; Copyright (C) 1995, 1998, 2001-2021 Free Software Foundation, Inc.
@@ -24,9 +24,7 @@
;; INTRODUCTION
;; ------------
-;; This package provides a major mode for editing SNMP MIBs. It
-;; provides all the modern Emacs 19 bells and whistles: default
-;; fontification via font-lock, imenu search functions, etc.
+;; This package provides a major mode for editing SNMP MIBs.
;;
;; SNMP mode also uses tempo, a textual boilerplate insertion package
;; distributed with Emacs, to add in boilerplate SNMP MIB structures.
@@ -71,16 +69,6 @@
;; Once the template is done, you can use C-cC-f and C-cC-b to move back
;; and forth between the Tempo sequence points to fill in the rest of
;; the information.
-;;
-;; Font Lock
-;; ------------
-;;
-;; If you want font-lock in your MIB buffers, add this:
-;;
-;; (add-hook 'snmp-common-mode-hook 'turn-on-font-lock)
-;;
-;; Enabling global-font-lock-mode is also sufficient.
-;;
;;; Code:
@@ -103,42 +91,35 @@
(defcustom snmp-special-indent t
"If non-nil, use a simple heuristic to try to guess the right indentation.
If nil, then no special indentation is attempted."
- :type 'boolean
- :group 'snmp)
+ :type 'boolean)
(defcustom snmp-indent-level 4
"Indentation level for SNMP MIBs."
- :type 'integer
- :group 'snmp)
+ :type 'integer)
(defcustom snmp-tab-always-indent nil
"Non-nil means TAB should always reindent the current line.
A value of nil means reindent if point is within the initial line indentation;
otherwise insert a TAB."
- :type 'boolean
- :group 'snmp)
+ :type 'boolean)
(defcustom snmp-completion-ignore-case t
"Non-nil means that case differences are ignored during completion.
A value of nil means that case is significant.
This is used during Tempo template completion."
- :type 'boolean
- :group 'snmp)
+ :type 'boolean)
(defcustom snmp-common-mode-hook nil
"Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode."
- :type 'hook
- :group 'snmp)
+ :type 'hook)
(defcustom snmp-mode-hook nil
"Hook(s) evaluated when a buffer enters SNMP mode."
- :type 'hook
- :group 'snmp)
+ :type 'hook)
(defcustom snmpv2-mode-hook nil
"Hook(s) evaluated when a buffer enters SNMPv2 mode."
- :type 'hook
- :group 'snmp)
+ :type 'hook)
(defvar snmp-tempo-tags nil
"Tempo tags for SNMP mode.")
@@ -293,7 +274,7 @@ This is used during Tempo template completion."
;; Set up the stuff that's common between snmp-mode and snmpv2-mode
;;
-(defun snmp-common-mode (name mode abbrev font-keywords imenu-index tempo-tags)
+(defun snmp-common-mode (name mode abbrev font-keywords imenu-index mode-tempo-tags)
(kill-all-local-variables)
;; Become the current major mode
@@ -306,52 +287,41 @@ This is used during Tempo template completion."
(setq local-abbrev-table abbrev)
;; Set up paragraphs (?)
- (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)
+ (setq-local paragraph-start (concat "$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local paragraph-ignore-fill-prefix t)
;; Set up comments
- (make-local-variable 'comment-start)
- (setq comment-start "-- ")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "--+[ \t]*")
- (make-local-variable 'comment-column)
- (setq comment-column 40)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
+ (setq-local comment-start "-- ")
+ (setq-local comment-start-skip "--+[ \t]*")
+ (setq-local comment-column 40)
+ (setq-local parse-sexp-ignore-comments t)
;; Set up indentation
(if snmp-special-indent
- (set (make-local-variable 'indent-line-function) 'snmp-indent-line))
- (set (make-local-variable 'tab-always-indent) snmp-tab-always-indent)
+ (setq-local indent-line-function 'snmp-indent-line))
+ (setq-local tab-always-indent snmp-tab-always-indent)
;; Font Lock
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults (cons font-keywords '(nil nil ((?- . "w 1234")))))
+ (setq-local font-lock-defaults (cons font-keywords '(nil nil ((?- . "w 1234")))))
;; Imenu
- (make-local-variable 'imenu-create-index-function)
- (setq imenu-create-index-function imenu-index)
+ (setq-local imenu-create-index-function imenu-index)
;; Tempo
- (tempo-use-tag-list tempo-tags)
- (make-local-variable 'tempo-match-finder)
- (setq tempo-match-finder "\\b\\(.+\\)\\=")
- (make-local-variable 'tempo-interactive)
- (setq tempo-interactive t)
+ (tempo-use-tag-list mode-tempo-tags)
+ (setq-local tempo-match-finder "\\b\\(.+\\)\\=")
+ (setq-local tempo-interactive t)
;; Miscellaneous customization
- (make-local-variable 'require-final-newline)
- (setq require-final-newline mode-require-final-newline))
+ (setq-local require-final-newline mode-require-final-newline))
;; SNMPv1 MIB Editing Mode.
;;
;;;###autoload
(defun snmp-mode ()
+ ;; FIXME: Use define-derived-mode.
"Major mode for editing SNMP MIBs.
Expression and list commands understand all C brackets.
Tab indents for C code.
@@ -372,14 +342,11 @@ Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then
'snmp-tempo-tags)
;; Completion lists
- (make-local-variable 'snmp-mode-syntax-list)
- (setq snmp-mode-syntax-list (append snmp-rfc1155-types
- snmp-rfc1213-types
- snmp-mode-syntax-list))
- (make-local-variable 'snmp-mode-access-list)
- (setq snmp-mode-access-list snmp-rfc1155-access)
- (make-local-variable 'snmp-mode-status-list)
- (setq snmp-mode-status-list snmp-rfc1212-status)
+ (setq-local snmp-mode-syntax-list (append snmp-rfc1155-types
+ snmp-rfc1213-types
+ snmp-mode-syntax-list))
+ (setq-local snmp-mode-access-list snmp-rfc1155-access)
+ (setq-local snmp-mode-status-list snmp-rfc1212-status)
;; Run hooks
(run-mode-hooks 'snmp-common-mode-hook 'snmp-mode-hook))
@@ -387,6 +354,7 @@ Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then
;;;###autoload
(defun snmpv2-mode ()
+ ;; FIXME: Use define-derived-mode.
"Major mode for editing SNMPv2 MIBs.
Expression and list commands understand all C brackets.
Tab indents for C code.
@@ -407,14 +375,11 @@ then `snmpv2-mode-hook'."
'snmpv2-tempo-tags)
;; Completion lists
- (make-local-variable 'snmp-mode-syntax-list)
- (setq snmp-mode-syntax-list (append snmp-rfc1902-types
- snmp-rfc1903-types
- snmp-mode-syntax-list))
- (make-local-variable 'snmp-mode-access-list)
- (setq snmp-mode-access-list snmp-rfc1902-access)
- (make-local-variable 'snmp-mode-status-list)
- (setq snmp-mode-status-list snmp-rfc1902-status)
+ (setq-local snmp-mode-syntax-list (append snmp-rfc1902-types
+ snmp-rfc1903-types
+ snmp-mode-syntax-list))
+ (setq-local snmp-mode-access-list snmp-rfc1902-access)
+ (setq-local snmp-mode-status-list snmp-rfc1902-status)
;; Run hooks
(run-mode-hooks 'snmp-common-mode-hook 'snmpv2-mode-hook))
@@ -494,13 +459,11 @@ lines for the purposes of this function."
(index-table-alist '())
(index-trap-alist '())
(case-fold-search nil) ; keywords must be uppercase
- prev-pos token end)
+ token end)
(goto-char (point-min))
- (imenu-progress-message prev-pos 0)
;; Search for a useful MIB item (that's not in a comment)
(save-match-data
(while (re-search-forward snmp-clause-regexp nil t)
- (imenu-progress-message prev-pos)
(setq
end (match-end 0)
token (cons (match-string 1)
@@ -518,7 +481,6 @@ lines for the purposes of this function."
(push token index-tc-alist)))
(goto-char end)))
;; Create the menu
- (imenu-progress-message prev-pos 100)
(setq index-alist (nreverse index-alist))
(and index-tc-alist
(push (cons "Textual Conventions" (nreverse index-tc-alist))
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index b7a365e5841..821ef4af8e0 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -5,11 +5,12 @@
;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Created: December, 2009
-;; Version: 3.1.5
+;; Version: 3.2.0
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
;; Homepage: https://github.com/alex-hhh/emacs-soap-client
;; Package-Requires: ((cl-lib "0.6.1"))
+;;FIXME: Put in `Package-Requires:' the Emacs version we expect.
;; This file is part of GNU Emacs.
@@ -551,30 +552,77 @@ This is a specialization of `soap-encode-value' for
(soap-validate-xs-basic-type value-string type)
(insert value-string)))))
-;; Inspired by rng-xsd-convert-date-time.
-(defun soap-decode-date-time (date-time-string datatype)
+(defun soap-decode-date-time (date-time-string &optional datatype)
"Decode DATE-TIME-STRING as DATATYPE.
DATE-TIME-STRING should be in ISO 8601 basic or extended format.
-DATATYPE is one of dateTime, time, date, gYearMonth, gYear,
-gMonthDay, gDay or gMonth.
-
-Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR
-SEC-FRACTION DATATYPE ZONE). This format is meant to be similar
-to that returned by `decode-time' (and compatible with
-`encode-time'). The differences are the SEC (seconds)
-field is always an integer, the DOW (day-of-week) field
-is replaced with SEC-FRACTION, a float representing the
-fractional seconds, and the DST (daylight savings time) field is
-replaced with DATATYPE, a symbol representing the XSD primitive
-datatype. This symbol can be used to determine which fields
-apply and which don't when it's not already clear from context.
-For example a datatype of `time' means the year, month and day
+DATATYPE can be omitted, or one of the symbols dateTime, time,
+date, gYearMonth, gYear, gMonthDay, gDay, or gMonth. If Emacs is
+a version that supports fractional seconds, DATATYPE can also be
+dateTime-subsecond, or time-subsecond. On older versions of
+Emacs (prior to 27.1), which do not support fractional seconds,
+leaving DATATYPE nil means that subseconds in DATE-TIME-STRING
+will be ignored.
+
+Return a list in a format identical or similar to that returned
+by `decode-time'. The returned format is always compatible with
+`encode-time'. If DATATYPE is omitted or nil, this function will
+return a list that has exactly the same format as that returned
+by `decode-time'.
+
+Note that on versions of Emacs that predate support for
+fractional seconds, `encode-time' will not notice the SUBSECOND
+field so it must be handled specially.
+
+The formats returned by this function are as follows, where _
+means \"should be ignored\":
+
+ DATATYPE | Return format
+------------+----------------------------------------------------------------
+ nil | (SECOND MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF)
+ dateTime | (SECOND MINUTE HOUR DAY MONTH YEAR SUBSECOND dateTime UTCOFF)
+ time | (SECOND MINUTE HOUR _ _ _ SUBSECOND time _)
+ date | (_ _ _ DAY MONTH YEAR _ date _)
+ gYearMonth | (_ _ _ _ MONTH YEAR _ gYearMonth _)
+ gYear | (_ _ _ _ _ YEAR _ gYear _)
+ gMonthDay | (_ _ _ DAY MONTH _ _ gMonthDay _)
+ gDay | (_ _ _ DAY _ _ _ gDay _)
+ gMonth | (_ _ _ _ MONTH _ _ gMonth _)
+
+When DATATYPE is dateTime or time, the DOW (day-of-week) field is
+replaced with SUBSECOND, a float representing the fractional
+seconds, and the DST (daylight savings time) field is replaced
+with DATATYPE, a symbol representing the XSD primitive datatype.
+This symbol can be used to determine which fields apply and which
+do not, when it is not already clear from context. For example a
+datatype of `time' means the year, month, day and time zone
fields should be ignored.
-This function will throw an error if DATE-TIME-STRING represents
-a leap second, since the XML Schema 1.1 standard explicitly
-disallows them."
- (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert)))
+New code that depends on Emacs 27.1 or newer anyway, and that
+wants dateTime or time but with the first argument with subsecond
+resolution, i.e., (TICKS . HZ), can set DATATYPE to
+dateTime-subsecond or time-subsecond respectively. This function
+throws an error if dateTime-subsecond or time-subsecond is
+specified when Emacs does not support subsecond resolution.
+
+This function throws an error if DATE-TIME-STRING represents a
+leap second, since the XML Schema 1.1 standard does not support
+representing leap seconds."
+ (let* ((new-decode-time (condition-case nil
+ (not (null
+ (with-no-warnings (decode-time nil nil t))))
+ (wrong-number-of-arguments)))
+ (new-decode-time-second nil)
+ (no-support "This Emacs version does not support %s")
+ (datetime-regexp-type
+ (cl-case datatype
+ ((dateTime-subsecond time-subsecond)
+ (if new-decode-time
+ (intern (replace-regexp-in-string
+ "-subsecond" "" (symbol-name datatype)))
+ (error (format no-support (symbol-name datatype)))))
+ ((nil) 'dateTime)
+ (otherwise datatype)))
+ (datetime-regexp (cadr (get datetime-regexp-type 'rng-xsd-convert)))
(year-sign (progn
(string-match datetime-regexp date-time-string)
(match-string 1 date-time-string)))
@@ -585,6 +633,7 @@ disallows them."
(minute (match-string 6 date-time-string))
(second (match-string 7 date-time-string))
(second-fraction (match-string 8 date-time-string))
+ (time-zone nil)
(has-time-zone (match-string 9 date-time-string))
(time-zone-sign (match-string 10 date-time-string))
(time-zone-hour (match-string 11 date-time-string))
@@ -605,11 +654,28 @@ disallows them."
(if hour (string-to-number hour) 0))
(setq minute
(if minute (string-to-number minute) 0))
+ (when new-decode-time
+ (setq new-decode-time-second
+ (if second
+ (if second-fraction
+ (let* ((second-fraction-significand
+ (replace-regexp-in-string "\\." "" second-fraction))
+ (hertz
+ (expt 10 (length second-fraction-significand)))
+ (ticks (+ (* hertz (string-to-number second))
+ (string-to-number
+ second-fraction-significand))))
+ (cons ticks hertz))
+ (cons second 1)))))
(setq second
(if second (string-to-number second) 0))
(setq second-fraction
(if second-fraction
- (float (string-to-number second-fraction))
+ (progn
+ (when (and (not datatype) (not new-decode-time))
+ (message
+ "soap-decode-date-time: Discarding fractional seconds"))
+ (float (string-to-number second-fraction)))
0.0))
(setq has-time-zone (and has-time-zone t))
(setq time-zone-sign
@@ -618,6 +684,14 @@ disallows them."
(if time-zone-hour (string-to-number time-zone-hour) 0))
(setq time-zone-minute
(if time-zone-minute (string-to-number time-zone-minute) 0))
+ (setq time-zone (if has-time-zone
+ (* (rng-xsd-time-to-seconds
+ time-zone-hour
+ time-zone-minute
+ 0)
+ time-zone-sign)
+ ;; UTC.
+ 0))
(unless (and
;; XSD does not allow year 0.
(> year 0)
@@ -635,18 +709,22 @@ disallows them."
(>= time-zone-minute 0)
(<= time-zone-minute 59))
(error "Invalid or unsupported time: %s" date-time-string))
- ;; Return a value in a format similar to that returned by decode-time, and
- ;; suitable for (apply #'encode-time ...).
- ;; FIXME: Nobody uses this idiosyncratic value. Perhaps stop returning it?
- (list second minute hour day month year second-fraction datatype
- (if has-time-zone
- (* (rng-xsd-time-to-seconds
- time-zone-hour
- time-zone-minute
- 0)
- time-zone-sign)
- ;; UTC.
- 0))))
+ ;; Return a value in a format identical or similar to that
+ ;; returned by decode-time, and always suitable for (apply
+ ;; #'encode-time ...).
+ (if datatype
+ (list (if (memq datatype '(dateTime-subsecond time-subsecond))
+ new-decode-time-second
+ second)
+ minute hour day month year second-fraction datatype time-zone)
+ (let ((time
+ (apply
+ #'encode-time (list
+ (if new-decode-time new-decode-time-second second)
+ minute hour day month year nil nil time-zone))))
+ (if new-decode-time
+ (with-no-warnings (decode-time time nil t))
+ (decode-time time))))))
(defun soap-decode-xs-basic-type (type node)
"Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE.
@@ -694,6 +772,8 @@ This is a specialization of `soap-decode-type' for
(Array (soap-decode-array node))))))
(defalias 'soap-type-of
+ ;; FIXME: Once we drop support for Emacs<25, use generic functions
+ ;; via `cl-defmethod' instead of our own ad-hoc version of it.
(if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type)))
;; `type-of' in Emacs ≥ 26 already does what we need.
#'type-of
@@ -1186,7 +1266,7 @@ See also `soap-wsdl-resolve-references'."
(soap-l2wk (xml-node-name node)))
(setf (soap-xs-simple-type-base type)
- (mapcar 'soap-l2fq
+ (mapcar #'soap-l2fq
(split-string
(or (xml-get-attribute-or-nil node 'memberTypes) ""))))
@@ -1266,7 +1346,7 @@ See also `soap-wsdl-resolve-references'."
(soap-validate-xs-basic-type value base))))
(error (push (cadr error-object) messages))))
(when messages
- (error (mapconcat 'identity (nreverse messages) "; and: "))))
+ (error (mapconcat #'identity (nreverse messages) "; and: "))))
(cl-labels ((fail-with-message (format value)
(push (format format value) messages)
(throw 'invalid nil)))
@@ -1716,6 +1796,7 @@ This is a specialization of `soap-encode-value' for
((and (not (eq indicator 'choice))
(= instance-count 0)
(not (soap-xs-element-optional? element))
+ (not (soap-xs-complex-type-optional? type))
(and (soap-xs-complex-type-p element-type)
(not (soap-xs-complex-type-optional-p
element-type))))
@@ -2000,7 +2081,7 @@ This is a specialization of `soap-decode-type' for
soap-headers ; list of (message part use)
soap-body ; message parts present in the body
use ; 'literal or 'encoded, see
- ; http://www.w3.org/TR/wsdl#_soap:body
+ ; https://www.w3.org/TR/wsdl#_soap:body
)
(cl-defstruct (soap-binding (:include soap-element))
@@ -2033,6 +2114,8 @@ This is a specialization of `soap-decode-type' for
;; Add the XSD types to the wsdl document
(let ((ns (soap-make-xs-basic-types
+ ;; The following string is a name and not an URL, so
+ ;; the "http:" should not be changed.
"http://www.w3.org/2001/XMLSchema" "xsd")))
(soap-wsdl-add-namespace ns wsdl)
(soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
@@ -2265,8 +2348,8 @@ See also `soap-resolve-references' and
(when (= (length (soap-operation-parameter-order operation)) 0)
(setf (soap-operation-parameter-order operation)
- (mapcar 'car (soap-message-parts
- (cdr (soap-operation-input operation))))))
+ (mapcar #'car (soap-message-parts
+ (cdr (soap-operation-input operation))))))
(setf (soap-operation-parameter-order operation)
(mapcar (lambda (p)
@@ -2311,13 +2394,13 @@ See also `soap-wsdl-resolve-references'."
;; Install resolvers for our types
(progn
(put (soap-type-of (make-soap-message)) 'soap-resolve-references
- 'soap-resolve-references-for-message)
+ #'soap-resolve-references-for-message)
(put (soap-type-of (make-soap-operation)) 'soap-resolve-references
- 'soap-resolve-references-for-operation)
+ #'soap-resolve-references-for-operation)
(put (soap-type-of (make-soap-binding)) 'soap-resolve-references
- 'soap-resolve-references-for-binding)
+ #'soap-resolve-references-for-binding)
(put (soap-type-of (make-soap-port)) 'soap-resolve-references
- 'soap-resolve-references-for-port))
+ #'soap-resolve-references-for-port))
(defun soap-wsdl-resolve-references (wsdl)
"Resolve all references inside the WSDL structure.
@@ -2431,7 +2514,7 @@ Build on WSDL if it is provided."
(soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl))
wsdl))
-(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl)
+(defalias 'soap-load-wsdl-from-url #'soap-load-wsdl)
(defun soap-parse-wsdl-phase-validate-node (node)
"Assert that NODE is valid."
@@ -2804,7 +2887,7 @@ decode function to perform the actual decoding."
(if (fboundp 'define-error)
(define-error 'soap-error "SOAP error")
- ;; Support older Emacs versions that do not have define-error, so
+ ;; Support Emacs<24.4 that do not have define-error, so
;; that soap-client can remain unchanged in GNU ELPA.
(put 'soap-error
'error-conditions
@@ -2918,8 +3001,6 @@ reference multiRef parts which are external to RESPONSE-NODE."
;;;; SOAP type encoding
-;; FIXME: Use `cl-defmethod' (but this requires Emacs-25).
-
(defun soap-encode-attributes (value type)
"Encode XML attributes for VALUE according to TYPE.
This is a generic function which determines the attribute encoder
@@ -3045,8 +3126,7 @@ http://schemas.xmlsoap.org/soap/encoding/\"\n"))
(defcustom soap-debug nil
"When t, enable some debugging facilities."
- :type 'boolean
- :group 'soap-client)
+ :type 'boolean)
(defun soap-find-port (wsdl service)
"Return the WSDL port having SERVICE name.
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
index 604e35c07cf..6f9ce6a2d69 100644
--- a/lisp/net/soap-inspect.el
+++ b/lisp/net/soap-inspect.el
@@ -109,7 +109,7 @@ soap-xs-attribute objects."
This is a specialization of `soap-sample-value' for
`soap-xs-simple-type' objects."
(append
- (mapcar 'soap-sample-value-for-xs-attribute
+ (mapcar #'soap-sample-value-for-xs-attribute
(soap-xs-type-attributes type))
(cond
((soap-xs-simple-type-enumeration type)
@@ -143,7 +143,7 @@ This is a specialization of `soap-sample-value' for
This is a specialization of `soap-sample-value' for
`soap-xs-complex-type' objects."
(append
- (mapcar 'soap-sample-value-for-xs-attribute
+ (mapcar #'soap-sample-value-for-xs-attribute
(soap-xs-type-attributes type))
(cl-case (soap-xs-complex-type-indicator type)
(array
@@ -176,47 +176,43 @@ This is a specialization of `soap-sample-value' for
;; Install soap-sample-value methods for our types
(put (soap-type-of (make-soap-xs-basic-type))
'soap-sample-value
- 'soap-sample-value-for-xs-basic-type)
+ #'soap-sample-value-for-xs-basic-type)
(put (soap-type-of (make-soap-xs-element))
'soap-sample-value
- 'soap-sample-value-for-xs-element)
+ #'soap-sample-value-for-xs-element)
(put (soap-type-of (make-soap-xs-attribute))
'soap-sample-value
- 'soap-sample-value-for-xs-attribute)
+ #'soap-sample-value-for-xs-attribute)
(put (soap-type-of (make-soap-xs-attribute))
'soap-sample-value
- 'soap-sample-value-for-xs-attribute-group)
+ #'soap-sample-value-for-xs-attribute-group)
(put (soap-type-of (make-soap-xs-simple-type))
'soap-sample-value
- 'soap-sample-value-for-xs-simple-type)
+ #'soap-sample-value-for-xs-simple-type)
(put (soap-type-of (make-soap-xs-complex-type))
'soap-sample-value
- 'soap-sample-value-for-xs-complex-type)
+ #'soap-sample-value-for-xs-complex-type)
(put (soap-type-of (make-soap-message))
'soap-sample-value
- 'soap-sample-value-for-message))
+ #'soap-sample-value-for-message))
;;; soap-inspect
-(defvar soap-inspect-previous-items nil
+(defvar-local 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
+(defvar-local 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
@@ -441,7 +437,7 @@ TYPE is a `soap-xs-complex-type'."
(funcall (list 'soap-invoke '*WSDL* "SomeService"
(soap-element-name operation))))
(let ((sample-invocation
- (append funcall (mapcar 'cdr sample-message-value))))
+ (append funcall (mapcar #'cdr sample-message-value))))
(pp sample-invocation (current-buffer)))))
(defun soap-inspect-port-type (port-type)
@@ -464,7 +460,7 @@ TYPE is a `soap-xs-complex-type'."
collect o))
op-name-width)
- (setq operations (sort operations 'string<))
+ (setq operations (sort operations #'string<))
(setq op-name-width (cl-loop for o in operations maximizing (length o)))
@@ -508,39 +504,39 @@ TYPE is a `soap-xs-complex-type'."
;; Install the soap-inspect methods for our types
(put (soap-type-of (make-soap-xs-basic-type)) 'soap-inspect
- 'soap-inspect-xs-basic-type)
+ #'soap-inspect-xs-basic-type)
(put (soap-type-of (make-soap-xs-element)) 'soap-inspect
- 'soap-inspect-xs-element)
+ #'soap-inspect-xs-element)
(put (soap-type-of (make-soap-xs-simple-type)) 'soap-inspect
- 'soap-inspect-xs-simple-type)
+ #'soap-inspect-xs-simple-type)
(put (soap-type-of (make-soap-xs-complex-type)) 'soap-inspect
- 'soap-inspect-xs-complex-type)
+ #'soap-inspect-xs-complex-type)
(put (soap-type-of (make-soap-xs-attribute)) 'soap-inspect
- 'soap-inspect-xs-attribute)
+ #'soap-inspect-xs-attribute)
(put (soap-type-of (make-soap-xs-attribute-group)) 'soap-inspect
- 'soap-inspect-xs-attribute-group)
+ #'soap-inspect-xs-attribute-group)
(put (soap-type-of (make-soap-message)) 'soap-inspect
- 'soap-inspect-message)
+ #'soap-inspect-message)
(put (soap-type-of (make-soap-operation)) 'soap-inspect
- 'soap-inspect-operation)
+ #'soap-inspect-operation)
(put (soap-type-of (make-soap-port-type)) 'soap-inspect
- 'soap-inspect-port-type)
+ #'soap-inspect-port-type)
(put (soap-type-of (make-soap-binding)) 'soap-inspect
- 'soap-inspect-binding)
+ #'soap-inspect-binding)
(put (soap-type-of (make-soap-port)) 'soap-inspect
- 'soap-inspect-port)
+ #'soap-inspect-port)
(put (soap-type-of (soap-make-wsdl "origin")) 'soap-inspect
- 'soap-inspect-wsdl))
+ #'soap-inspect-wsdl))
(provide 'soap-inspect)
;;; soap-inspect.el ends here
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 9bd1d58ed00..1da1d31d678 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -235,11 +235,10 @@
(let ((num 0)
(retval ""))
(mapc
- (function
- (lambda (x)
- (if (fboundp (cdr (cdr x)))
- (setq retval (format "%s%c" retval (car x))
- num (1+ num)))))
+ (lambda (x)
+ (if (fboundp (cdr (cdr x)))
+ (setq retval (format "%s%c" retval (car x))
+ num (1+ num))))
(reverse socks-authentication-methods))
(format "%c%s" num retval)))
@@ -261,7 +260,7 @@
(setq state (process-get proc 'socks-state))
(cond
((= state socks-state-waiting-for-auth)
- (cl-callf (lambda (s) (setq string (concat string s)))
+ (cl-callf (lambda (s) (setq string (concat s string)))
(process-get proc 'socks-scratch))
(if (< (length string) 2)
nil ; We need to spin some more
@@ -273,7 +272,7 @@
((= state socks-state-authenticated)
)
((= state socks-state-waiting)
- (cl-callf (lambda (s) (setq string (concat string s)))
+ (cl-callf (lambda (s) (setq string (concat s string)))
(process-get proc 'socks-scratch))
(setq version (process-get proc 'socks-server-protocol))
(cond
@@ -386,10 +385,13 @@
)
)
(process-put proc 'socks-state socks-state-authenticated)
+ (process-put proc 'socks-scratch "")
(set-process-filter proc #'socks-filter)))
proc)))
(defun socks-send-command (proc command atype address port)
+ "Send COMMAND to SOCKS service PROC for proxying ADDRESS and PORT.
+When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
(let ((addr (cond
((or (= atype socks-address-type-v4)
(= atype socks-address-type-v6))
@@ -528,7 +530,7 @@
(setq host (socks-nslookup-host host))
(if (not (listp host))
(error "Could not get IP address for: %s" host))
- (setq host (apply #'format "%c%c%c%c" host))
+ (setq host (apply #'unibyte-string host))
socks-address-type-v4)
(t
socks-address-type-name))))
@@ -543,7 +545,7 @@
service))
(process-put proc 'socks-buffer buffer)
(process-put proc 'socks-host host)
- (process-put proc 'socks-service host)
+ (process-put proc 'socks-service service)
(set-process-filter proc nil)
(set-process-buffer proc (if buffer (get-buffer-create buffer)))
proc))))
diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el
index 3890cd826b4..bb65ecaa981 100644
--- a/lisp/net/telnet.el
+++ b/lisp/net/telnet.el
@@ -1,4 +1,4 @@
-;;; telnet.el --- run a telnet session from within an Emacs buffer
+;;; telnet.el --- run a telnet session from within an Emacs buffer -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -63,24 +63,21 @@ LOGIN-NAME, which is optional, says what to log in as on that machine.")
(defvar telnet-new-line "\r")
(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)
+ (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
- (defvar telnet-remote-echoes t
- "True if the telnet process will echo input."))
-(make-variable-buffer-local
- (defvar telnet-interrupt-string "\C-c" "String sent by C-c."))
+(defvar-local telnet-remote-echoes t
+ "True if the telnet process will echo input.")
+(defvar-local telnet-interrupt-string "\C-c" "String sent by C-c.")
-(defvar telnet-count 0
+(defvar-local telnet-count 0
"Number of output strings from telnet process while looking for password.")
-(make-variable-buffer-local 'telnet-count)
(defvar telnet-program "telnet"
"Program to run to open a telnet connection.")
@@ -149,13 +146,13 @@ rejecting one login and prompting again for a username and password.")
((string-match "passw" string)
(telnet-filter proc string)
(setq telnet-count 0)
- (process-send-string proc (concat (comint-read-noecho "Password: " t)
+ (process-send-string proc (concat (read-passwd "Password: ")
telnet-new-line))
(clear-this-command-keys))
(t (telnet-check-software-type-initialize string)
(telnet-filter proc string)
(cond ((> telnet-count telnet-maximum-count)
- (set-process-filter proc 'telnet-filter))
+ (set-process-filter proc #'telnet-filter))
(t (setq telnet-count (1+ telnet-count)))))))))
;; Identical to comint-simple-send, except that it sends telnet-new-line
@@ -230,9 +227,9 @@ Normally input is edited in Emacs and sent a line at a time."
(if (and buffer (get-buffer-process buffer))
(switch-to-buffer (concat "*" name "*"))
(switch-to-buffer
- (apply 'make-comint name telnet-program nil telnet-options))
+ (apply #'make-comint name telnet-program nil telnet-options))
(setq process (get-buffer-process (current-buffer)))
- (set-process-filter process 'telnet-initial-filter)
+ (set-process-filter process #'telnet-initial-filter)
;; Don't send the `open' cmd till telnet is ready for it.
(accept-process-output process)
(erase-buffer)
@@ -253,9 +250,9 @@ There is a variable `telnet-interrupt-string' which is the character
sent to try to stop execution of a job on the remote host.
Data is sent to the remote host when RET is typed."
(setq-local revert-buffer-function 'telnet-revert-buffer)
- (set (make-local-variable 'window-point-insertion-type) t)
- (set (make-local-variable 'comint-prompt-regexp) telnet-prompt-pattern)
- (set (make-local-variable 'comint-use-prompt-regexp) t))
+ (setq-local window-point-insertion-type t)
+ (setq-local comint-prompt-regexp telnet-prompt-pattern)
+ (setq-local comint-use-prompt-regexp t))
;;;###autoload
(defun rsh (host)
@@ -266,7 +263,7 @@ Normally input is edited in Emacs and sent a line at a time."
(require 'shell)
(let ((name (concat "rsh-" host )))
(switch-to-buffer (make-comint name remote-shell-program nil host))
- (set-process-filter (get-process name) 'telnet-initial-filter)
+ (set-process-filter (get-process name) #'telnet-initial-filter)
(telnet-mode)
(setq-local telnet-connect-command (list 'rsh host))
(setq telnet-count -16)))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 5de2f37241c..5e0accc142a 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -44,7 +44,6 @@
:version "24.4"
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-adb-connect-if-not-connected nil
"Try to run `adb connect' if provided device is not connected currently.
It is used for TCP/IP devices."
@@ -56,16 +55,27 @@ It is used for TCP/IP devices."
(defconst tramp-adb-method "adb"
"When this method name is used, forward all calls to Android Debug Bridge.")
-;;;###tramp-autoload
-(defcustom tramp-adb-prompt
- "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]"
+(defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]"
"Regexp used as prompt in almquist shell."
:type 'regexp
- :version "24.4"
+ :version "28.1"
:group 'tramp)
+(eval-and-compile
+ (defconst tramp-adb-ls-date-year-regexp
+ "[[:digit:]]\\{4\\}-[[:digit:]]\\{2\\}-[[:digit:]]\\{2\\}"
+ "Regexp for date year format in ls output."))
+
+(eval-and-compile
+ (defconst tramp-adb-ls-date-time-regexp
+ "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}"
+ "Regexp for date time format in ls output."))
+
(defconst tramp-adb-ls-date-regexp
- "[[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]][0-9][0-9]:[0-9][0-9][[:space:]]"
+ (concat
+ "[[:space:]]" tramp-adb-ls-date-year-regexp
+ "[[:space:]]" tramp-adb-ls-date-time-regexp
+ "[[:space:]]")
"Regexp for date format in ls output.")
(defconst tramp-adb-ls-toolbox-regexp
@@ -75,7 +85,8 @@ It is used for TCP/IP devices."
"[[:space:]]*\\([^[:space:]]+\\)" ; \2 username
"[[:space:]]+\\([^[:space:]]+\\)" ; \3 group
"[[:space:]]+\\([[:digit:]]+\\)" ; \4 size
- "[[:space:]]+\\([-[:digit:]]+[[:space:]][:[:digit:]]+\\)" ; \5 date
+ "[[:space:]]+\\(" tramp-adb-ls-date-year-regexp
+ "[[:space:]]" tramp-adb-ls-date-time-regexp "\\)" ; \5 date
"[[:space:]]\\(.*\\)$") ; \6 filename
"Regexp for ls output.")
@@ -83,8 +94,11 @@ It is used for TCP/IP devices."
(tramp--with-startup
(add-to-list 'tramp-methods
`(,tramp-adb-method
- (tramp-tmpdir "/data/local/tmp")
- (tramp-default-port 5555)))
+ (tramp-login-program ,tramp-adb-program)
+ (tramp-login-args (("shell")))
+ (tramp-direct-async t)
+ (tramp-tmpdir "/data/local/tmp")
+ (tramp-default-port 5555)))
(add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil ""))
@@ -119,6 +133,7 @@ It is used for TCP/IP devices."
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-adb-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-adb-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -138,16 +153,18 @@ It is used for TCP/IP devices."
(file-selinux-context . tramp-handle-file-selinux-context)
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-adb-handle-file-system-info)
- (file-truename . tramp-adb-handle-file-truename)
+ (file-truename . tramp-handle-file-truename)
(file-writable-p . tramp-adb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-adb-handle-make-directory)
(make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . tramp-adb-handle-make-process)
(make-symbolic-link . tramp-handle-make-symbolic-link)
@@ -162,8 +179,11 @@ It is used for TCP/IP devices."
(start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-adb-handle-write-region))
@@ -179,14 +199,13 @@ It is used for TCP/IP devices."
tramp-adb-method)))
;;;###tramp-autoload
-(defun tramp-adb-file-name-handler (operation &rest arguments)
+(defun tramp-adb-file-name-handler (operation &rest args)
"Invoke the ADB handler for OPERATION.
First arg specifies the OPERATION, second arg is a list of
-ARGUMENTS to pass to the OPERATION."
- (let ((fn (assoc operation tramp-adb-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) arguments))
- (tramp-run-real-handler operation arguments))))
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###tramp-autoload
(tramp--with-startup
@@ -201,7 +220,7 @@ ARGUMENTS to pass to the OPERATION."
(lambda (line)
(when (string-match "^\\(\\S-+\\)[[:space:]]+device$" line)
;; Replace ":" by "#".
- `(nil ,(replace-regexp-in-string
+ `(nil ,(tramp-compat-string-replace
":" tramp-prefix-port-format (match-string 1 line)))))
(tramp-process-lines nil tramp-adb-program "devices"))))
@@ -216,11 +235,10 @@ ARGUMENTS to pass to the OPERATION."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (eval-when-compile
- (concat "[[:space:]]*[^[:space:]]+"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)")))
+ (concat "[[:space:]]*[^[:space:]]+"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"))
;; The values are given as 1k numbers, so we must change
;; them to number of bytes.
(list (* 1024 (string-to-number (match-string 1)))
@@ -230,105 +248,6 @@ ARGUMENTS to pass to the OPERATION."
(string-to-number (match-string 2))))
(* 1024 (string-to-number (match-string 3)))))))))
-;; This is derived from `tramp-sh-handle-file-truename'. Maybe the
-;; code could be shared?
-(defun tramp-adb-handle-file-truename (filename)
- "Like `file-truename' for Tramp files."
- ;; Preserve trailing "/".
- (funcall
- (if (tramp-compat-directory-name-p filename)
- #'file-name-as-directory #'identity)
- ;; Quote properly.
- (funcall
- (if (tramp-compat-file-name-quoted-p filename)
- #'tramp-compat-file-name-quote #'identity)
- (with-parsed-tramp-file-name
- (tramp-compat-file-name-unquote (expand-file-name filename)) nil
- (tramp-make-tramp-file-name
- v
- (with-tramp-file-property v localname "file-truename"
- (let (result) ; result steps in reverse order
- (tramp-message v 4 "Finding true name for `%s'" filename)
- (let* ((steps (split-string localname "/" 'omit))
- (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"
- (string-join
- (append '("") (reverse result) (list thisstep)) "/"))
- (setq symlink-target
- (tramp-compat-file-attribute-type
- (file-attributes
- (tramp-make-tramp-file-name
- v
- (string-join
- (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 (split-string symlink-target "/" 'omit)
- 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
- (string-join (cons "" result) "/")
- "/"))
- (when (and is-dir (or (string-empty-p result)
- (not (string= (substring result -1) "/"))))
- (setq result (concat result "/"))))
-
- ;; Detect cycle.
- (when (and (file-symlink-p filename)
- (string-equal result localname))
- (tramp-error
- v 'file-error
- "Apparent cycle of symbolic links for %s" filename))
- ;; If the resulting localname looks remote, we must quote it
- ;; for security reasons.
- (when (file-remote-p result)
- (setq result (tramp-compat-file-name-quote result 'top)))
- (tramp-message v 4 "True name of `%s' is `%s'" localname result)
- result)))))))
-
(defun tramp-adb-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
(unless id-format (setq id-format 'integer))
@@ -372,7 +291,9 @@ ARGUMENTS to pass to the OPERATION."
(if (eq id-format 'integer) 0 uid)
(if (eq id-format 'integer) 0 gid)
tramp-time-dont-know ; atime
- (date-to-time date) ; mtime
+ ;; `date-to-time' checks `iso8601-parse', which might fail.
+ (let (signal-hook-function)
+ (date-to-time date)) ; mtime
tramp-time-dont-know ; ctime
size
mod-string
@@ -383,18 +304,16 @@ ARGUMENTS to pass to the OPERATION."
file-properties)))
(defun tramp-adb-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format _count)
+ (directory &optional full match nosort id-format count)
"Like `directory-files-and-attributes' for Tramp files."
(unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
(when (file-directory-p directory)
(with-parsed-tramp-file-name (expand-file-name directory) nil
(copy-tree
(with-tramp-file-property
- v localname (format "directory-files-and-attributes-%s-%s-%s-%s"
- full match id-format nosort)
+ v localname (format "directory-files-and-attributes-%s-%s-%s-%s-%s"
+ full match id-format nosort count)
(with-current-buffer (tramp-get-buffer v)
(when (tramp-adb-send-command-and-check
v (format "%s -a -l %s"
@@ -408,9 +327,9 @@ ARGUMENTS to pass to the OPERATION."
v (format "%s -d -a -l %s %s"
(tramp-adb-get-ls-command v)
(tramp-shell-quote-argument
- (concat (file-name-as-directory localname) "."))
+ (tramp-compat-file-name-concat localname "."))
(tramp-shell-quote-argument
- (concat (file-name-as-directory localname) ".."))))
+ (tramp-compat-file-name-concat localname ".."))))
(widen)))
(tramp-adb-sh-fix-ls-output)
(let ((result (tramp-do-parse-file-attributes-with-ls
@@ -424,11 +343,17 @@ ARGUMENTS to pass to the OPERATION."
(unless nosort
(setq result
(sort result (lambda (x y) (string< (car x) (car y))))))
- (delq nil
- (mapcar (lambda (x)
- (if (or (not match) (string-match-p match (car x)))
- x))
- result)))))))))
+
+ (setq result (delq nil
+ (mapcar
+ (lambda (x) (if (or (not match)
+ (string-match-p
+ match (car x)))
+ x))
+ result)))
+ (when (and (natnump count) (> count 0))
+ (setq result (nbutlast result (- (length result) count))))
+ result)))))))
(defun tramp-adb-get-ls-command (vec)
"Determine `ls' command and its arguments."
@@ -439,7 +364,8 @@ ARGUMENTS to pass to the OPERATION."
;; by GNU Coreutils. Force "ls" to print one column and set
;; time-style to imitate other "ls" flavors.
((tramp-adb-send-command-and-check
- vec "ls --time-style=long-iso /dev/null")
+ vec (concat "ls --time-style=long-iso "
+ (tramp-get-remote-null-device vec)))
"ls -1 --time-style=long-iso")
;; Can't disable coloring explicitly for toybox ls command. We
;; also must force "ls" to print just one column.
@@ -447,25 +373,11 @@ ARGUMENTS to pass to the OPERATION."
;; On CyanogenMod based system BusyBox is used and "ls" output
;; coloring is enabled by default. So we try to disable it when
;; possible.
- ((tramp-adb-send-command-and-check vec "ls --color=never -al /dev/null")
+ ((tramp-adb-send-command-and-check
+ vec (concat "ls --color=never -al " (tramp-get-remote-null-device vec)))
"ls --color=never")
(t "ls"))))
-(defun tramp-adb--gnu-switches-to-ash (switches)
- "Almquist shell can't handle multiple arguments.
-Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"."
- (split-string
- (apply #'concat
- (mapcar (lambda (s)
- (replace-regexp-in-string
- "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s)))
- ;; FIXME: Warning about removed switches (long and non-dash).
- (delq nil
- (mapcar
- (lambda (s)
- (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s))
- switches))))))
-
(defun tramp-adb-sh-fix-ls-output (&optional sort-by-time)
"Insert dummy 0 in empty size columns.
Android's \"ls\" command doesn't insert size column for directories:
@@ -475,10 +387,16 @@ Emacs dired can't find files."
(goto-char (point-min))
(while
(search-forward-regexp
- "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t)
+ (eval-when-compile
+ (concat
+ "[[:space:]]"
+ "\\([[:space:]]" tramp-adb-ls-date-year-regexp "[[:space:]]\\)"))
+ nil t)
(replace-match "0\\1" "\\1" nil)
;; Insert missing "/".
- (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$")
+ (when (looking-at-p
+ (eval-when-compile
+ (concat tramp-adb-ls-date-time-regexp "[[:space:]]+$")))
(end-of-line)
(insert "/")))
;; Sort entries.
@@ -517,7 +435,7 @@ Emacs dired can't find files."
(setq dir (expand-file-name dir))
(with-parsed-tramp-file-name dir nil
(when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists "Directory already exists %s" dir))
+ (tramp-error v 'file-already-exists dir))
(when parents
(let ((par (expand-file-name ".." dir)))
(unless (file-directory-p par)
@@ -528,27 +446,25 @@ Emacs dired can't find files."
(and parents (file-directory-p dir)))
(tramp-error v 'file-error "Couldn't make directory %s" dir))))
-(defun tramp-adb-handle-delete-directory (directory &optional recursive _trash)
+(defun tramp-adb-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (setq directory (expand-file-name directory))
- (with-parsed-tramp-file-name (file-truename directory) nil
- (tramp-flush-directory-properties v localname))
- (with-parsed-tramp-file-name directory nil
- (tramp-flush-directory-properties v localname)
+ (tramp-skeleton-delete-directory directory recursive trash
(tramp-adb-barf-unless-okay
v (format "%s %s"
(if recursive "rm -r" "rmdir")
(tramp-shell-quote-argument localname))
"Couldn't delete %s" directory)))
-(defun tramp-adb-handle-delete-file (filename &optional _trash)
+(defun tramp-adb-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-properties v localname)
- (tramp-adb-barf-unless-okay
- v (format "rm %s" (tramp-shell-quote-argument localname))
- "Couldn't delete %s" filename)))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash filename)
+ (tramp-adb-barf-unless-okay
+ v (format "rm %s" (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename))))
(defun tramp-adb-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
@@ -582,16 +498,15 @@ Emacs dired can't find files."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p (file-truename filename))
- (tramp-error
- v tramp-file-missing
- "Cannot make local copy of non-existing file `%s'" filename))
+ (tramp-compat-file-missing v filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(with-tramp-progress-reporter
v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
;; "adb pull ..." does not always return an error code.
- (when (or (tramp-adb-execute-adb-command
- v "pull" (tramp-compat-file-name-unquote localname) tmpfile)
- (not (file-exists-p tmpfile)))
+ (unless
+ (and (tramp-adb-execute-adb-command
+ v "pull" (tramp-compat-file-name-unquote localname) tmpfile)
+ (file-exists-p tmpfile))
(ignore-errors (delete-file tmpfile))
(tramp-error
v 'file-error "Cannot make local copy of file `%s'" filename))
@@ -624,7 +539,8 @@ But handle the case, if the \"test\" command is not available."
(defun tramp-adb-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -633,19 +549,29 @@ But handle the case, if the \"test\" command is not available."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let* ((curbuf (current-buffer))
- (tmpfile (tramp-compat-make-temp-file filename)))
+ (let ((file-locked (eq (file-locked-p lockname) t))
+ (curbuf (current-buffer))
+ (tmpfile (tramp-compat-make-temp-file filename)))
+
+ ;; Lock file.
+ (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
+ (file-remote-p lockname)
+ (not file-locked))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok)
(set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600)))
- (tramp-run-real-handler
- #'write-region (list start end tmpfile append 'no-message lockname))
+ (let (create-lockfiles)
+ (write-region start end tmpfile append 'no-message))
(with-tramp-progress-reporter
- v 3 (format-message
- "Moving tmp file `%s' to `%s'" tmpfile filename)
+ v 3 (format-message
+ "Moving tmp file `%s' to `%s'" tmpfile filename)
(unwind-protect
- (when (tramp-adb-execute-adb-command
- v "push" tmpfile (tramp-compat-file-name-unquote localname))
+ (unless (tramp-adb-execute-adb-command
+ v "push" tmpfile (tramp-compat-file-name-unquote localname))
(tramp-error v 'file-error "Cannot write: `%s'" filename))
(delete-file tmpfile)))
@@ -661,8 +587,14 @@ But handle the case, if the \"test\" command is not available."
;; Set file modification time.
(when (or (eq visit t) (stringp visit))
(set-visited-file-modtime
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ (or (tramp-compat-file-attribute-modification-time
+ (file-attributes filename))
+ (current-time))))
+
+ ;; Unlock file.
+ (when file-locked
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
;; The end.
(when (and (null noninteractive)
@@ -670,13 +602,16 @@ But handle the case, if the \"test\" command is not available."
(tramp-message v 0 "Wrote %s" filename))
(run-hooks 'tramp-handle-write-region-hook))))
-(defun tramp-adb-handle-set-file-modes (filename mode &optional _flag)
+(defun tramp-adb-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-properties v localname)
- (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname))))
+ ;; ADB shell does not support "chmod -h".
+ (unless (and (eq flag 'nofollow) (file-symlink-p filename))
+ (tramp-flush-file-properties v localname)
+ (tramp-adb-send-command-and-check
+ v (format "chmod %o %s" mode (tramp-shell-quote-argument localname))))))
-(defun tramp-adb-handle-set-file-times (filename &optional time _flag)
+(defun tramp-adb-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
@@ -685,21 +620,23 @@ But handle the case, if the \"test\" command is not available."
(tramp-compat-time-equal-p time tramp-time-dont-know))
(current-time)
time))
+ (nofollow (if (eq flag 'nofollow) "-h" ""))
(quoted-name (tramp-shell-quote-argument localname)))
;; Older versions of toybox 'touch' mishandle nanoseconds and/or
;; trailing "Z", so fall back on plain seconds if nanoseconds+Z
;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d'
;; (introduced in POSIX.1-2008) fails.
(tramp-adb-send-command-and-check
- v (format (concat "touch -d %s %s 2>/dev/null || "
- "touch -d %s %s 2>/dev/null || "
- "touch -t %s %s")
- (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t)
- quoted-name
- (format-time-string "%Y-%m-%dT%H:%M:%S" time t)
- quoted-name
- (format-time-string "%Y%m%d%H%M.%S" time t)
- quoted-name)))))
+ v (format
+ (concat "touch -d %s %s %s 2>%s || "
+ "touch -d %s %s %s 2>%s || "
+ "touch -t %s %s %s")
+ (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t)
+ nofollow quoted-name (tramp-get-remote-null-device v)
+ (format-time-string "%Y-%m-%dT%H:%M:%S" time t)
+ nofollow quoted-name (tramp-get-remote-null-device v)
+ (format-time-string "%Y%m%d%H%M.%S" time t)
+ nofollow quoted-name)))))
(defun tramp-adb-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -713,16 +650,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(copy-directory filename newname keep-date t)
(let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname)))
+ (t2 (tramp-tramp-file-p newname))
+ ;; We don't want the target file to be compressed, so we
+ ;; let-bind `jka-compr-inhibit' to t.
+ (jka-compr-inhibit t))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "Copying file" "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(with-tramp-progress-reporter
@@ -742,46 +680,45 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(tramp-shell-quote-argument l2))
"Error copying %s to %s" filename newname))
- (let ((tmpfile (file-local-copy filename)))
-
- (if tmpfile
- ;; Remote filename.
- (condition-case err
- (rename-file tmpfile newname ok-if-already-exists)
- ((error quit)
- (delete-file tmpfile)
- (signal (car err) (cdr err))))
-
- ;; Remote newname.
- (when (and (file-directory-p newname)
- (tramp-compat-directory-name-p newname))
- (setq newname
- (expand-file-name
- (file-name-nondirectory filename) newname)))
-
- (with-parsed-tramp-file-name newname nil
- (when (and (not ok-if-already-exists)
- (file-exists-p newname))
- (tramp-error v 'file-already-exists newname))
-
- ;; We must also flush the cache of the directory,
- ;; because `file-attributes' reads the values from
- ;; there.
- (tramp-flush-file-properties v localname)
- (when (tramp-adb-execute-adb-command
+ (if-let ((tmpfile (file-local-copy filename)))
+ ;; Remote filename.
+ (condition-case err
+ (rename-file tmpfile newname ok-if-already-exists)
+ ((error quit)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ ;; Remote newname.
+ (when (and (file-directory-p newname)
+ (directory-name-p newname))
+ (setq newname
+ (expand-file-name
+ (file-name-nondirectory filename) newname)))
+
+ (with-parsed-tramp-file-name newname nil
+ (when (and (not ok-if-already-exists)
+ (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+
+ ;; We must also flush the cache of the directory,
+ ;; because `file-attributes' reads the values from
+ ;; there.
+ (tramp-flush-file-properties v localname)
+ (unless (tramp-adb-execute-adb-command
v "push"
(tramp-compat-file-name-unquote filename)
(tramp-compat-file-name-unquote localname))
- (tramp-error
- v 'file-error
- "Cannot copy `%s' `%s'" filename newname)))))))))
+ (tramp-error
+ v 'file-error
+ "Cannot copy `%s' `%s'" filename newname))))))))
;; KEEP-DATE handling.
(when keep-date
- (set-file-times
+ (tramp-compat-set-file-times
newname
(tramp-compat-file-attribute-modification-time
- (file-attributes filename))))))
+ (file-attributes filename))
+ (unless ok-if-already-exists 'nofollow)))))
(defun tramp-adb-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -795,16 +732,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(delete-directory filename 'recursive))
(let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname)))
+ (t2 (tramp-tramp-file-p newname))
+ ;; We don't want the target file to be compressed, so we
+ ;; let-bind `jka-compr-inhibit' to t.
+ (jka-compr-inhibit t))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "Renaming file" "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(with-tramp-progress-reporter
@@ -865,14 +803,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(when (and (numberp destination) (zerop destination))
(error "Implementation does not handle immediate return"))
- (with-parsed-tramp-file-name default-directory nil
+ (with-parsed-tramp-file-name (expand-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 input (tramp-get-remote-null-device v))
(setq infile (expand-file-name infile))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
@@ -914,7 +852,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
tmpstderr (tramp-make-tramp-file-name v stderr))))
;; stderr to be discarded.
((null (cadr destination))
- (setq stderr "/dev/null"))))
+ (setq stderr (tramp-get-remote-null-device v)))))
;; 't
(destination
(setq outbuf (current-buffer))))
@@ -973,164 +911,173 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; The complete STDERR buffer is available only when the process has
;; terminated.
(defun tramp-adb-handle-make-process (&rest args)
- "Like `make-process' for Tramp files."
- (when args
- (with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let ((name (plist-get args :name))
- (buffer (plist-get args :buffer))
- (command (plist-get args :command))
- (coding (plist-get args :coding))
- (noquery (plist-get args :noquery))
- (connection-type (plist-get args :connection-type))
- (filter (plist-get args :filter))
- (sentinel (plist-get args :sentinel))
- (stderr (plist-get args :stderr)))
- (unless (stringp name)
- (signal 'wrong-type-argument (list #'stringp name)))
- (unless (or (null buffer) (bufferp buffer) (stringp buffer))
- (signal 'wrong-type-argument (list #'stringp buffer)))
- (unless (consp command)
- (signal 'wrong-type-argument (list #'consp command)))
- (unless (or (null coding)
- (and (symbolp coding) (memq coding coding-system-list))
- (and (consp coding)
- (memq (car coding) coding-system-list)
- (memq (cdr coding) coding-system-list)))
- (signal 'wrong-type-argument (list #'symbolp coding)))
- (unless (or (null connection-type) (memq connection-type '(pipe pty)))
- (signal 'wrong-type-argument (list #'symbolp connection-type)))
- (unless (or (null filter) (functionp filter))
- (signal 'wrong-type-argument (list #'functionp filter)))
- (unless (or (null sentinel) (functionp sentinel))
- (signal 'wrong-type-argument (list #'functionp sentinel)))
- (unless (or (null stderr) (bufferp stderr) (stringp stderr))
- (signal 'wrong-type-argument (list #'stringp stderr)))
- (when (and (stringp stderr) (tramp-tramp-file-p stderr)
- (not (tramp-equal-remote default-directory stderr)))
- (signal 'file-error (list "Wrong stderr" stderr)))
-
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- ;; STDERR can also be a file name.
- (tmpstderr
- (and stderr
- (if (and (stringp stderr) (tramp-tramp-file-p stderr))
- (tramp-unquote-file-local-name stderr)
- (tramp-make-tramp-temp-file v))))
- (remote-tmpstderr
- (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
- (program (car command))
- (args (cdr command))
- (command
- (format "cd %s && exec %s %s"
- (tramp-shell-quote-argument localname)
- (if tmpstderr (format "2>'%s'" tmpstderr) "")
- (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))
-
- (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)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `make-process'
- ;; could be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (inhibit-read-only t))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-adb-maybe-open-connection', in
- ;; order to cleanup the prompt afterwards.
- (tramp-adb-maybe-open-connection v)
- (delete-region (point-min) (point-max))
- ;; Send the command.
- (let* ((p (tramp-get-connection-process v)))
- (tramp-adb-send-command v command nil t) ; nooutput
- ;; Set sentinel and filter.
- (when sentinel
- (set-process-sentinel p sentinel))
- (when filter
- (set-process-filter p filter))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the
- ;; process could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p (null noquery))
- (set-marker (process-mark p) (point)))
- ;; We must flush them here already; otherwise
- ;; `rename-file', `delete-file' or
- ;; `insert-file-contents' will fail.
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer")
- ;; Copy tmpstderr file.
- (when (and (stringp stderr)
- (not (tramp-tramp-file-p stderr)))
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (rename-file remote-tmpstderr stderr))))
- ;; Read initial output. Remove the first line,
- ;; which is the command echo.
- (while
- (progn
- (goto-char (point-min))
- (not (re-search-forward "[\n]" nil t)))
- (tramp-accept-process-output p 0))
- (delete-region (point-min) (point))
- ;; Provide error buffer. This shows only
- ;; initial error messages; messages arriving
- ;; later on will be inserted when the process
- ;; is deleted. The temporary file will exist
- ;; until the process is deleted.
- (when (bufferp stderr)
- (with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr 'visit))
- ;; Delete tmpstderr file.
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr 'visit nil nil 'replace))
- (delete-file remote-tmpstderr))))
- ;; Return process.
- p))))
-
- ;; Save exit.
- (if (string-match-p tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer (tramp-get-connection-process v) nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer"))))))))
+ "Like `make-process' for Tramp files.
+If method parameter `tramp-direct-async' and connection property
+\"direct-async-process\" are non-nil, an alternative
+implementation will be used."
+ (if (tramp-direct-async-process-p args)
+ (apply #'tramp-handle-make-process args)
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'bufferp stderr)))
+ (when (and (stringp stderr) (tramp-tramp-file-p stderr)
+ (not (tramp-equal-remote default-directory stderr)))
+ (signal 'file-error (list "Wrong stderr" stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ ;; STDERR can also be a file name.
+ (tmpstderr
+ (and stderr
+ (if (and (stringp stderr) (tramp-tramp-file-p stderr))
+ (tramp-unquote-file-local-name stderr)
+ (tramp-make-tramp-temp-file v))))
+ (remote-tmpstderr
+ (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (program (car command))
+ (args (cdr command))
+ (command
+ (format "cd %s && exec %s %s"
+ (tramp-shell-quote-argument localname)
+ (if tmpstderr (format "2>'%s'" tmpstderr) "")
+ (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))
+
+ (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)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process'
+ ;; could be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t)
+ (coding-system-for-write
+ (if (symbolp coding) coding (car coding)))
+ (coding-system-for-read
+ (if (symbolp coding) coding (cdr coding))))
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max))
+ ;; We call `tramp-adb-maybe-open-connection',
+ ;; in order to cleanup the prompt afterwards.
+ (tramp-adb-maybe-open-connection v)
+ (delete-region (point-min) (point-max))
+ ;; Send the command.
+ (let* ((p (tramp-get-connection-process v)))
+ (tramp-adb-send-command v command nil t) ; nooutput
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for
+ ;; this process. We ignore errors, because
+ ;; the process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; We must flush them here already;
+ ;; otherwise `rename-file', `delete-file' or
+ ;; `insert-file-contents' will fail.
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
+ ;; Copy tmpstderr file.
+ (when (and (stringp stderr)
+ (not (tramp-tramp-file-p stderr)))
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (rename-file remote-tmpstderr stderr))))
+ ;; Read initial output. Remove the first
+ ;; line, which is the command echo.
+ (while
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "[\n]" nil t)))
+ (tramp-accept-process-output p 0))
+ (delete-region (point-min) (point))
+ ;; Provide error buffer. This shows only
+ ;; initial error messages; messages arriving
+ ;; later on will be inserted when the
+ ;; process is deleted. The temporary file
+ ;; will exist until the process is deleted.
+ (when (bufferp stderr)
+ (with-current-buffer stderr
+ (insert-file-contents-literally
+ remote-tmpstderr 'visit))
+ ;; Delete tmpstderr file.
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (with-current-buffer stderr
+ (insert-file-contents-literally
+ remote-tmpstderr 'visit nil nil 'replace))
+ (delete-file remote-tmpstderr))))
+ ;; Return process.
+ p))))
+
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer (tramp-get-connection-process v) nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))))))
(defun tramp-adb-handle-exec-path ()
"Like `exec-path' for Tramp files."
(append
(with-parsed-tramp-file-name default-directory nil
- (with-tramp-connection-property v "remote-path"
+ (with-tramp-connection-property (tramp-get-process v) "remote-path"
(tramp-adb-send-command v "echo \\\"$PATH\\\"")
(split-string
(with-current-buffer (tramp-get-connection-buffer v)
@@ -1145,15 +1092,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Return full host name from VEC to be used in shell execution.
E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
a host name \"R38273882DE\" returns \"R38273882DE\"."
- ;; Sometimes this is called before there is a connection process
- ;; yet. In order to work with the connection cache, we flush all
- ;; unwanted entries first.
- (tramp-flush-connection-properties nil)
- (with-tramp-connection-property (tramp-get-connection-process vec) "device"
+ (with-tramp-connection-property (tramp-get-process vec) "device"
(let* ((host (tramp-file-name-host vec))
(port (tramp-file-name-port-or-default vec))
(devices (mapcar #'cadr (tramp-adb-parse-device-names nil))))
- (replace-regexp-in-string
+ (tramp-compat-string-replace
tramp-prefix-port-format ":"
(cond ((member host devices) host)
;; This is the case when the host is connected to the default port.
@@ -1167,10 +1110,10 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
;; Try to connect device.
((and tramp-adb-connect-if-not-connected
(not (zerop (length host)))
- (not (tramp-adb-execute-adb-command
- vec "connect"
- (replace-regexp-in-string
- tramp-prefix-port-format ":" host))))
+ (tramp-adb-execute-adb-command
+ vec "connect"
+ (tramp-compat-string-replace
+ tramp-prefix-port-format ":" host)))
;; When new device connected, running other adb command (e.g.
;; adb shell) immediately will fail. To get around this
;; problem, add sleep 0.1 second here.
@@ -1180,18 +1123,18 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
vec 'file-error "Could not find device %s" host)))))))
(defun tramp-adb-execute-adb-command (vec &rest args)
- "Return nil on success error-output on failure."
+ "Execute an adb command.
+Insert the result into the connection buffer. Return nil on
+error and non-nil on success."
(when (and (> (length (tramp-file-name-host vec)) 0)
;; The -s switch is only available for ADB device commands.
(not (member (car args) '("connect" "disconnect"))))
(setq args (append (list "-s" (tramp-adb-get-device vec)) args)))
- (with-temp-buffer
- (prog1
- (unless
- (zerop
- (apply #'tramp-call-process vec tramp-adb-program nil t nil args))
- (buffer-string))
- (tramp-message vec 6 "%s" (buffer-string)))))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Clean up the buffer. We cannot call `erase-buffer' because
+ ;; narrowing might be in effect.
+ (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
+ (zerop (apply #'tramp-call-process vec tramp-adb-program nil t nil args))))
(defun tramp-adb-find-test-command (vec)
"Check whether the ash has a builtin \"test\" command.
@@ -1203,25 +1146,37 @@ This happens for Android >= 4.0."
(defun tramp-adb-send-command (vec command &optional neveropen nooutput)
"Send the COMMAND to connection VEC."
- (unless neveropen (tramp-adb-maybe-open-connection vec))
- (tramp-message vec 6 "%s" command)
- (tramp-send-string vec command)
- (unless nooutput
- ;; FIXME: Race condition.
- (tramp-adb-wait-for-output (tramp-get-connection-process vec))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (save-excursion
- (goto-char (point-min))
- ;; We can't use stty to disable echo of command. stty is said
- ;; to be added to toybox 0.7.6. busybox shall have it, but this
- ;; isn't used any longer for Android.
- (delete-matching-lines (regexp-quote command))
- ;; When the local machine is W32, there are still trailing ^M.
- ;; There must be a better solution by setting the correct coding
- ;; system, but this requires changes in core Tramp.
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" nil nil))))))
+ (if (string-match-p "[[:multibyte:]]" command)
+ ;; Multibyte codepoints with four bytes are not supported at
+ ;; least by toybox.
+
+ ;; <https://android.stackexchange.com/questions/226638/how-to-use-multibyte-file-names-in-adb-shell/232379#232379>
+ ;; mksh uses UTF-8 internally, but is currently limited to the
+ ;; BMP (basic multilingua plane), which means U+0000 to
+ ;; U+FFFD. If you want to use SMP codepoints (U-00010000 to
+ ;; U-0010FFFD) on the input line, you currently have to disable
+ ;; the UTF-8 mode (sorry).
+ (tramp-adb-execute-adb-command vec "shell" command)
+
+ (unless neveropen (tramp-adb-maybe-open-connection vec))
+ (tramp-message vec 6 "%s" command)
+ (tramp-send-string vec command)
+ (unless nooutput
+ ;; FIXME: Race condition.
+ (tramp-adb-wait-for-output (tramp-get-connection-process vec))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (save-excursion
+ (goto-char (point-min))
+ ;; We can't use stty to disable echo of command. stty is said
+ ;; to be added to toybox 0.7.6. busybox shall have it, but this
+ ;; isn't used any longer for Android.
+ (delete-matching-lines (regexp-quote command))
+ ;; When the local machine is W32, there are still trailing ^M.
+ ;; There must be a better solution by setting the correct coding
+ ;; system, but this requires changes in core Tramp.
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" nil nil)))))))
(defun tramp-adb-send-command-and-check (vec command &optional exit-status)
"Run COMMAND and check its exit status.
@@ -1236,7 +1191,7 @@ the exit status."
(format "%s; echo tramp_exit_status $?" command)
"echo tramp_exit_status $?"))
(with-current-buffer (tramp-get-connection-buffer vec)
- (unless (tramp-search-regexp "tramp_exit_status [0-9]+")
+ (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+")
(tramp-error
vec 'file-error "Couldn't find exit status of `%s'" command))
(skip-chars-forward "^ ")
@@ -1334,18 +1289,33 @@ connection if a previous connection has died for some reason."
(process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
;; Change prompt.
(tramp-set-connection-property
p "prompt" (regexp-quote (format "///%s#$" prompt)))
(tramp-adb-send-command
vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt))
+ ;; Disable line editing.
+ (tramp-adb-send-command
+ vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
+
+ ;; Dump option settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-adb-send-command vec "set -o"))
+
;; Check whether the properties have been changed. If
;; yes, this is a strong indication that we must expire all
;; connection properties. We start again.
(tramp-message vec 5 "Checking system information")
(tramp-adb-send-command
- vec "echo \\\"`getprop ro.product.model` `getprop ro.product.version` `getprop ro.build.version.release`\\\"")
+ vec
+ (concat
+ "echo \\\"`getprop ro.product.model` "
+ "`getprop ro.product.version` "
+ "`getprop ro.build.version.release`\\\""))
(let ((old-getprop
(tramp-get-connection-property vec "getprop" nil))
(new-getprop
@@ -1369,33 +1339,32 @@ connection if a previous connection has died for some reason."
(tramp-adb-send-command vec (format "su %s" user))
(unless (tramp-adb-send-command-and-check vec nil)
(delete-process p)
- (tramp-flush-file-property vec "" "su-command-p")
+ ;; Do not flush, we need the nil value.
+ (tramp-set-file-property vec "" "su-command-p" nil)
(tramp-error
vec 'file-error "Cannot switch to user `%s'" user)))
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
;; Mark it as connected.
(tramp-set-connection-property p "connected" t)))))))
-;; Default settings for connection-local variables.
-(defconst tramp-adb-connection-local-default-profile
+;;; Default connection-local variables for Tramp:
+;; `connection-local-set-profile-variables' and
+;; `connection-local-set-profiles' exists since Emacs 26.1.
+(defconst tramp-adb-connection-local-default-shell-variables
'((shell-file-name . "/system/bin/sh")
(shell-command-switch . "-c"))
- "Default connection-local variables for remote adb connections.")
+ "Default connection-local shell variables for remote adb connections.")
+
+(tramp-compat-funcall
+ 'connection-local-set-profile-variables
+ 'tramp-adb-connection-local-default-shell-profile
+ tramp-adb-connection-local-default-shell-variables)
-;; `connection-local-set-profile-variables' and
-;; `connection-local-set-profiles' exists since Emacs 26.1.
(with-eval-after-load 'shell
(tramp-compat-funcall
- 'connection-local-set-profile-variables
- 'tramp-adb-connection-local-default-profile
- tramp-adb-connection-local-default-profile)
- (tramp-compat-funcall
'connection-local-set-profiles
`(:application tramp :protocol ,tramp-adb-method)
- 'tramp-adb-connection-local-default-profile))
+ 'tramp-adb-connection-local-default-shell-profile))
(add-hook 'tramp-unload-hook
(lambda ()
@@ -1403,4 +1372,9 @@ connection if a previous connection has died for some reason."
(provide 'tramp-adb)
+;;; TODO:
+;;
+;; * Support file names with multibyte codepoints. Use as fallback
+;; "adb shell COMMAND".
+;;
;;; tramp-adb.el ends here
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index e690687413a..67798e892ab 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -163,7 +163,7 @@
"List of suffixes which indicate a file archive.
It must be supported by libarchive(3).")
-;; <http://unix-memo.readthedocs.io/en/latest/vfs.html>
+;; <https://unix-memo.readthedocs.io/en/latest/vfs.html>
;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress.
;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab.
@@ -236,6 +236,7 @@ It must be supported by libarchive(3).")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-archive-handle-file-local-copy)
+ (file-locked-p . ignore)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-archive-handle-file-name-all-completions)
;; `file-name-as-directory' performed by default handler.
@@ -262,9 +263,11 @@ It must be supported by libarchive(3).")
(insert-directory . tramp-archive-handle-insert-directory)
(insert-file-contents . tramp-archive-handle-insert-file-contents)
(load . tramp-archive-handle-load)
+ (lock-file . ignore)
(make-auto-save-file-name . ignore)
(make-directory . tramp-archive-handle-not-implemented)
(make-directory-internal . tramp-archive-handle-not-implemented)
+ (make-lock-file-name . ignore)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-archive-handle-not-implemented)
@@ -279,8 +282,11 @@ It must be supported by libarchive(3).")
(start-file-process . tramp-archive-handle-not-implemented)
;; `substitute-in-file-name' performed by default handler.
(temporary-file-directory . tramp-archive-handle-temporary-file-directory)
- ;; `tramp-set-file-uid-gid' performed by default handler.
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
+ (tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-archive-handle-not-implemented))
@@ -326,6 +332,8 @@ arguments to pass to the OPERATION."
;; `filename' could be a quoted file name. Or the file
;; archive could be a directory, see Bug#30293.
(if (or (null archive)
+ (not (tramp-archive-run-real-handler
+ #'file-exists-p (list archive)))
(tramp-archive-run-real-handler
#'file-directory-p (list archive)))
(tramp-archive-run-real-handler operation args)
@@ -343,8 +351,17 @@ arguments to pass to the OPERATION."
(tramp-archive-run-real-handler operation args)))))))
;;;###autoload
-(defalias
- 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler)
+(progn (defun tramp-archive-autoload-file-name-handler (operation &rest args)
+ "Load Tramp archive file name handler, and perform OPERATION."
+ (when tramp-archive-enabled
+ ;; We cannot use `tramp-compat-temporary-file-directory' here due
+ ;; to autoload. When installing Tramp's GNU ELPA package, there
+ ;; might be an older, incompatible version active. We try to
+ ;; overload this.
+ (let ((default-directory temporary-file-directory)
+ (tramp-archive-autoload t))
+ tramp-archive-autoload ; Silence byte compiler.
+ (apply #'tramp-autoload-file-name-handler operation args)))))
;;;###autoload
(progn (defun tramp-register-archive-file-name-handler ()
@@ -353,7 +370,7 @@ arguments to pass to the OPERATION."
(add-to-list 'file-name-handler-alist
(cons (tramp-archive-autoload-file-name-regexp)
#'tramp-archive-autoload-file-name-handler))
- (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))))
+ (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))))
;;;###autoload
(progn
@@ -369,7 +386,7 @@ arguments to pass to the OPERATION."
(tramp-register-archive-file-name-handler)
;; Mark `operations' the handler is responsible for.
-(put 'tramp-archive-file-name-handler 'operations
+(put #'tramp-archive-file-name-handler 'operations
(mapcar #'car tramp-archive-file-name-handler-alist))
;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
@@ -520,13 +537,16 @@ offered."
(declare (debug (form symbolp body))
(indent 2))
(let ((bindings
- (mapcar (lambda (elem)
- `(,(if var (intern (format "%s-%s" var elem)) elem)
- (,(intern (format "tramp-file-name-%s" elem))
- ,(or var 'v))))
- `,(cons
- 'archive
- (delete 'hop (tramp-compat-tramp-file-name-slots))))))
+ (mapcar
+ (lambda (elem)
+ `(,(if var (intern (format "%s-%s" var elem)) elem)
+ (,(intern (format "tramp-file-name-%s" elem))
+ ,(or var 'v))))
+ (cons
+ 'archive
+ (delete
+ 'hop
+ (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))))))))
`(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
,@bindings)
;; We don't know which of those vars will be used, so we bind them all,
@@ -623,10 +643,8 @@ offered."
(let ((result
(insert-file-contents
(tramp-archive-gvfs-file-name filename) visit beg end replace)))
- (prog1
- (list (expand-file-name filename)
- (cadr result))
- (when visit (setq buffer-file-name filename)))))
+ (when visit (setq buffer-file-name filename))
+ (cons (expand-file-name filename) (cdr result))))
(defun tramp-archive-handle-load
(file &optional noerror nomessage nosuffix must-suffix)
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index c3213a7c682..fcfad012ec8 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -31,13 +31,13 @@
;; a process, has a unique cache. We distinguish 4 kind of caches,
;; depending on the key:
;;
-;; - localname is NIL. This are reusable properties. Examples:
+;; - localname is nil. These 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
;; the file `tramp-persistency-file-name'.
;;
-;; - localname is a string. This are temporary properties, which are
+;; - localname is a string. These are temporary properties, which are
;; related to the file localname is referring to. Examples:
;; "file-exists-p" is t or nil, depending on the file existence, or
;; "file-attributes" caches the result of the function
@@ -45,21 +45,35 @@
;; expire after `remote-file-name-inhibit-cache' seconds if this
;; variable is set.
;;
-;; - The key is a process. This are temporary properties related to
+;; - The key is a process. These are temporary properties related to
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
+;; "lock-pid" is the timestamp a (network) process is created, it is
+;; used instead of the pid in file locks.
;;
-;; - The key is nil. This are temporary properties related to the
+;; - The key is nil. These are temporary properties related to the
;; local machine. Examples: "parse-passwd" and "parse-group" keep
;; the results of parsing "/etc/passwd" and "/etc/group",
;; "{uid,gid}-{integer,string}" are the local uid and gid, and
;; "locale" is the used shell locale.
+;;
+;; - The key is `tramp-cache-undefined'. All functions return the
+;; expected values, but nothing is cached.
;; Some properties are handled special:
;;
;; - "process-name", "process-buffer" and "first-password-request" are
-;; not saved in the file `tramp-persistency-file-name'.
+;; not saved in the file `tramp-persistency-file-name', although
+;; being connection properties related to a `tramp-file-name'
+;; structure.
+;;
+;; - Reusable properties, which should not be saved, are kept in the
+;; process key retrieved by `tramp-get-process' (the main connection
+;; process). Other processes could reuse these properties, avoiding
+;; recomputation when a new asynchronous process is created by
+;; `make-process'. Examples are "unsafe-temporary-file",
+;; "remote-path", "device" (tramp-adb.el) or "share" (tramp-gvfs.el).
;;; Code:
@@ -96,25 +110,31 @@ details see the info pages."
(defvar tramp-cache-data-changed nil
"Whether persistent cache data have been changed.")
+;;;###tramp-autoload
+(defconst tramp-cache-undefined 'undef
+ "The symbol marking undefined hash keys and values.")
+
(defun tramp-get-hash-table (key)
"Return the hash table for KEY.
If it doesn't exist yet, it is created and initialized with
-matching entries of `tramp-connection-properties'."
- (or (gethash key tramp-cache-data)
- (let ((hash
- (puthash key (make-hash-table :test #'equal) tramp-cache-data)))
- (when (tramp-file-name-p key)
- (dolist (elt tramp-connection-properties)
- (when (string-match-p
- (or (nth 0 elt) "")
- (tramp-make-tramp-file-name key 'noloc 'nohop))
- (tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
- hash)))
+matching entries of `tramp-connection-properties'.
+If KEY is `tramp-cache-undefined', don't create anything, and return nil."
+ (unless (eq key tramp-cache-undefined)
+ (or (gethash key tramp-cache-data)
+ (let ((hash
+ (puthash key (make-hash-table :test #'equal) tramp-cache-data)))
+ (when (tramp-file-name-p key)
+ (dolist (elt tramp-connection-properties)
+ (when (string-match-p
+ (or (nth 0 elt) "")
+ (tramp-make-tramp-file-name key 'noloc 'nohop))
+ (tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
+ hash))))
;;;###tramp-autoload
(defun tramp-get-file-property (key file property default)
"Get the PROPERTY of FILE from the cache context of KEY.
-Returns DEFAULT if not set."
+Return DEFAULT if not set."
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
@@ -122,42 +142,47 @@ Returns DEFAULT if not set."
(tramp-run-real-handler #'directory-file-name (list file))
(tramp-file-name-hop key) nil)
(let* ((hash (tramp-get-hash-table key))
- (value (when (hash-table-p hash) (gethash property hash))))
- (if ;; We take the value only if there is any, and
- ;; `remote-file-name-inhibit-cache' indicates that it is still
- ;; valid. Otherwise, DEFAULT is set.
- (and (consp value)
+ (cached (and (hash-table-p hash) (gethash property hash)))
+ (cached-at (and (consp cached) (format-time-string "%T" (car cached))))
+ (value default)
+ cache-used)
+
+ (when ;; We take the value only if there is any, and
+ ;; `remote-file-name-inhibit-cache' indicates that it is
+ ;; still valid. Otherwise, DEFAULT is set.
+ (and (consp cached)
(or (null remote-file-name-inhibit-cache)
(and (integerp remote-file-name-inhibit-cache)
(time-less-p
- ;; `current-time' can be nil once we get rid of Emacs 24.
- (current-time)
- (time-add
- (car value)
- ;; `seconds-to-time' can be removed once we get
- ;; rid of Emacs 24.
- (seconds-to-time remote-file-name-inhibit-cache))))
+ nil
+ (time-add (car cached) remote-file-name-inhibit-cache)))
(and (consp remote-file-name-inhibit-cache)
(time-less-p
- remote-file-name-inhibit-cache (car value)))))
- (setq value (cdr value))
- (setq value default))
-
- (tramp-message key 8 "%s %s %s" file property value)
+ remote-file-name-inhibit-cache (car cached)))))
+ (setq value (cdr cached)
+ cache-used t))
+
+ (tramp-message
+ key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s"
+ file property value remote-file-name-inhibit-cache cache-used cached-at)
+ ;; For analysis purposes, count the number of getting this file attribute.
(when (>= tramp-verbose 10)
(let* ((var (intern (concat "tramp-cache-get-count-" property)))
- (val (or (bound-and-true-p var)
- (progn
- (add-hook 'tramp-cache-unload-hook
- (lambda () (makunbound var)))
- 0))))
+ (val (or (and (boundp var) (numberp (symbol-value var))
+ (symbol-value var))
+ 0)))
(set var (1+ val))))
value))
+(add-hook 'tramp-cache-unload-hook
+ (lambda ()
+ (dolist (var (all-completions "tramp-cache-get-count-" obarray))
+ (unintern var obarray))))
+
;;;###tramp-autoload
(defun tramp-set-file-property (key file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of KEY.
-Returns VALUE."
+Return VALUE."
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
@@ -168,16 +193,20 @@ Returns VALUE."
;; We put the timestamp there.
(puthash property (cons (current-time) value) hash)
(tramp-message key 8 "%s %s %s" file property value)
+ ;; For analysis purposes, count the number of setting this file attribute.
(when (>= tramp-verbose 10)
(let* ((var (intern (concat "tramp-cache-set-count-" property)))
- (val (or (bound-and-true-p var)
- (progn
- (add-hook 'tramp-cache-unload-hook
- (lambda () (makunbound var)))
- 0))))
+ (val (or (and (boundp var) (numberp (symbol-value var))
+ (symbol-value var))
+ 0)))
(set var (1+ val))))
value))
+(add-hook 'tramp-cache-unload-hook
+ (lambda ()
+ (dolist (var (all-completions "tramp-cache-set-count-" obarray))
+ (unintern var obarray))))
+
;;;###tramp-autoload
(defun tramp-flush-file-property (key file property)
"Remove PROPERTY of FILE in the cache context of KEY."
@@ -202,19 +231,16 @@ Returns VALUE."
key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key) file
(tramp-file-name-hop key) nil)
- (maphash
- (lambda (property _value)
- (when (string-match-p
- "^\\(directory-\\|file-name-all-completions\\|file-entries\\)"
- property)
- (tramp-flush-file-property key file property)))
- (tramp-get-hash-table key)))))
+ (dolist (property (hash-table-keys (tramp-get-hash-table key)))
+ (when (string-match-p
+ "^\\(directory-\\|file-name-all-completions\\|file-entries\\)"
+ property)
+ (tramp-flush-file-property key file property))))))
;;;###tramp-autoload
(defun tramp-flush-file-properties (key file)
"Remove all properties of FILE in the cache context of KEY."
- (let* ((file (tramp-run-real-handler
- #'directory-file-name (list file)))
+ (let* ((file (tramp-run-real-handler #'directory-file-name (list file)))
(truename (tramp-get-file-property key file "file-truename" nil)))
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
@@ -239,14 +265,12 @@ Remove also properties of all files in subdirectories."
#'directory-file-name (list directory)))
(truename (tramp-get-file-property key directory "file-truename" nil)))
(tramp-message key 8 "%s" directory)
- (maphash
- (lambda (key _value)
- (when (and (tramp-file-name-p key)
- (stringp (tramp-file-name-localname key))
- (string-match-p (regexp-quote directory)
- (tramp-file-name-localname key)))
- (remhash key tramp-cache-data)))
- tramp-cache-data)
+ (dolist (key (hash-table-keys tramp-cache-data))
+ (when (and (tramp-file-name-p key)
+ (stringp (tramp-file-name-localname key))
+ (string-match-p (regexp-quote directory)
+ (tramp-file-name-localname key)))
+ (remhash key tramp-cache-data)))
;; Remove file properties of symlinks.
(when (and (stringp truename)
(not (string-equal directory (directory-file-name truename))))
@@ -292,8 +316,9 @@ This is suppressed for temporary buffers."
"Get the named PROPERTY for the connection.
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
-used to cache connection properties of the local machine. If the
-value is not set for the connection, returns DEFAULT."
+used to cache connection properties of the local machine.
+If KEY is `tramp-cache-undefined', or if the value is not set for
+the connection, return DEFAULT."
;; Unify key by removing localname and hop from `tramp-file-name'
;; structure. Work with a copy in order to avoid side effects.
(when (tramp-file-name-p key)
@@ -301,15 +326,19 @@ value is not set for the connection, returns DEFAULT."
(setf (tramp-file-name-localname key) nil
(tramp-file-name-hop key) nil))
(let* ((hash (tramp-get-hash-table key))
- (value
- ;; If the key is an auxiliary process object, check whether
- ;; the process is still alive.
- (if (and (processp key) (not (process-live-p key)))
- default
- (if (hash-table-p hash)
- (gethash property hash default)
- default))))
- (tramp-message key 7 "%s %s" property value)
+ (cached (if (hash-table-p hash)
+ (gethash property hash tramp-cache-undefined)
+ tramp-cache-undefined))
+ (value default)
+ cache-used)
+
+ (when (and (not (eq cached tramp-cache-undefined))
+ ;; If the key is an auxiliary process object, check
+ ;; whether the process is still alive.
+ (not (and (processp key) (not (process-live-p key)))))
+ (setq value cached
+ cache-used t))
+ (tramp-message key 7 "%s %s; cache used: %s" property value cache-used)
value))
;;;###tramp-autoload
@@ -317,19 +346,22 @@ value is not set for the connection, returns DEFAULT."
"Set the named PROPERTY of a connection to VALUE.
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
-used to cache connection properties of the local machine.
-PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
+used to cache connection properties of the local machine. If KEY
+is `tramp-cache-undefined', nothing is set.
+PROPERTY is set persistent when KEY is a `tramp-file-name' structure.
+Return VALUE."
;; Unify key by removing localname and hop from `tramp-file-name'
;; structure. Work with a copy in order to avoid side effects.
(when (tramp-file-name-p key)
(setq key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key) nil
(tramp-file-name-hop key) nil))
- (let ((hash (tramp-get-hash-table key)))
- (puthash property value hash)
- (setq tramp-cache-data-changed t)
- (tramp-message key 7 "%s %s" property value)
- value))
+ (when-let ((hash (tramp-get-hash-table key)))
+ (puthash property value hash))
+ (setq tramp-cache-data-changed
+ (or tramp-cache-data-changed (tramp-file-name-p key)))
+ (tramp-message key 7 "%s %s" property value)
+ value)
;;;###tramp-autoload
(defun tramp-connection-property-p (key property)
@@ -337,7 +369,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
used to cache connection properties of the local machine."
- (not (eq (tramp-get-connection-property key property 'undef) 'undef)))
+ (not (eq (tramp-get-connection-property key property tramp-cache-undefined)
+ tramp-cache-undefined)))
;;;###tramp-autoload
(defun tramp-flush-connection-property (key property)
@@ -352,8 +385,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
(setq key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key) nil
(tramp-file-name-hop key) nil))
- (remhash property (tramp-get-hash-table key))
- (setq tramp-cache-data-changed t)
+ (when-let ((hash (tramp-get-hash-table key)))
+ (remhash property hash))
+ (setq tramp-cache-data-changed
+ (or tramp-cache-data-changed (tramp-file-name-p key)))
(tramp-message key 7 "%s" property))
;;;###tramp-autoload
@@ -370,12 +405,10 @@ used to cache connection properties of the local machine."
(tramp-file-name-hop key) nil))
(tramp-message
key 7 "%s %s" key
- (let ((hash (gethash key tramp-cache-data))
- properties)
- (when (hash-table-p hash)
- (maphash (lambda (x _y) (push x properties)) hash))
- properties))
- (setq tramp-cache-data-changed t)
+ (when-let ((hash (gethash key tramp-cache-data)))
+ (hash-table-keys hash)))
+ (setq tramp-cache-data-changed
+ (or tramp-cache-data-changed (tramp-file-name-p key)))
(remhash key tramp-cache-data))
;;;###tramp-autoload
@@ -386,20 +419,15 @@ used to cache connection properties of the local machine."
(maphash
(lambda (key value)
;; Remove text properties from KEY and VALUE.
- ;; `cl-struct-slot-*' functions exist since Emacs 25 only; we
- ;; ignore errors.
(when (tramp-file-name-p key)
- ;; (dolist
- ;; (slot
- ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name))))
- ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key))
- ;; (setf (cl-struct-slot-value 'tramp-file-name slot key)
- ;; (substring-no-properties
- ;; (cl-struct-slot-value 'tramp-file-name slot key))))))
- (dotimes (i (length key))
- (when (stringp (elt key i))
- (setf (elt key i) (substring-no-properties (elt key i))))))
- (when (stringp key)
+ (dolist
+ (slot
+ (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name))))
+ (when (stringp (cl-struct-slot-value 'tramp-file-name slot key))
+ (setf (cl-struct-slot-value 'tramp-file-name slot key)
+ (substring-no-properties
+ (cl-struct-slot-value 'tramp-file-name slot key))))))
+ (when (stringp key)
(setq key (substring-no-properties key)))
(when (stringp value)
(setq value (substring-no-properties value)))
@@ -421,18 +449,18 @@ used to cache connection properties of the local machine."
;;;###tramp-autoload
(defun tramp-list-connections ()
"Return all known `tramp-file-name' structs according to `tramp-cache'."
- (let (result tramp-verbose)
- (maphash
- (lambda (key _value)
- (when (and (tramp-file-name-p key)
- (null (tramp-file-name-localname key))
- (tramp-connection-property-p key "process-buffer"))
- (push key result)))
- tramp-cache-data)
- result))
+ (let ((tramp-verbose 0))
+ (delq nil (mapcar
+ (lambda (key)
+ (and (tramp-file-name-p key)
+ (null (tramp-file-name-localname key))
+ (tramp-connection-property-p key "process-buffer")
+ key))
+ (hash-table-keys tramp-cache-data)))))
(defun tramp-dump-connection-properties ()
- "Write persistent connection properties into file `tramp-persistency-file-name'."
+ "Write persistent connection properties into file \
+`tramp-persistency-file-name'."
;; We shouldn't fail, otherwise Emacs might not be able to be closed.
(ignore-errors
(when (and (hash-table-p tramp-cache-data)
@@ -445,11 +473,11 @@ used to cache connection properties of the local machine."
;; don't save either, because all other properties might
;; depend on the login name, and we want to give the
;; possibility to use another login name later on. Key
- ;; "started" exists for the "ftp" method only, which must be
+ ;; "started" exists for the "ftp" method only, which must not
;; be kept persistent.
(maphash
(lambda (key value)
- (if (and (tramp-file-name-p key) value
+ (if (and (tramp-file-name-p key) (hash-table-p value)
(not (string-equal
(tramp-file-name-method key) tramp-archive-method))
(not (tramp-file-name-localname key))
@@ -464,15 +492,10 @@ used to cache connection properties of the local machine."
;; Dump it.
(with-temp-file tramp-persistency-file-name
(insert
- ";; -*- emacs-lisp -*-"
- ;; `time-stamp-string' might not exist in all 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"))
+ ;; Starting with Emacs 28, we could use `lisp-data'.
+ (format ";; -*- emacs-lisp -*- <%s %s>\n"
+ (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
+ tramp-persistency-file-name)
";; Tramp connection history. Don't change this file.\n"
";; Run `M-x tramp-cleanup-all-connections' instead.\n\n"
(with-output-to-string
@@ -490,17 +513,14 @@ used to cache connection properties of the local machine."
"Return a list of (user host) tuples allowed to access for METHOD.
This function is added always in `tramp-get-completion-function'
for all methods. Resulting data are derived from connection history."
- (let (res)
- (maphash
- (lambda (key _value)
- (if (and (tramp-file-name-p key)
- (string-equal method (tramp-file-name-method key))
- (not (tramp-file-name-localname key)))
- (push (list (tramp-file-name-user key)
- (tramp-file-name-host key))
- res)))
- tramp-cache-data)
- res))
+ (mapcar
+ (lambda (key)
+ (and (tramp-file-name-p key)
+ (string-equal method (tramp-file-name-method key))
+ (not (tramp-file-name-localname key))
+ (list (tramp-file-name-user key)
+ (tramp-file-name-host key))))
+ (hash-table-keys tramp-cache-data)))
;; When "emacs -Q" has been called, both variables are nil. We do not
;; load the persistency file then, in order to have a clean test environment.
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index f01a93197ce..d30d22021a5 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -57,7 +57,9 @@ SYNTAX can be one of the symbols `default' (default),
(all-completions
"*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))
(all-completions
- "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
+ "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))
+ (all-completions
+ "*trace tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
(defun tramp-list-remote-buffers ()
"Return a list of all buffers with remote `default-directory'."
@@ -74,11 +76,13 @@ SYNTAX can be one of the symbols `default' (default),
Each function is called with the current vector as argument.")
;;;###tramp-autoload
-(defun tramp-cleanup-connection (vec &optional keep-debug keep-password)
+(defun tramp-cleanup-connection
+ (vec &optional keep-debug keep-password keep-processes)
"Flush all connection related objects.
This includes password cache, file cache, connection cache,
-buffers. KEEP-DEBUG non-nil preserves the debug buffer.
-KEEP-PASSWORD non-nil preserves the password cache.
+buffers, processes. KEEP-DEBUG non-nil preserves the debug
+buffer. KEEP-PASSWORD non-nil preserves the password cache.
+KEEP-PROCESSES non-nil preserves the asynchronous processes.
When called interactively, a Tramp connection has to be selected."
(interactive
;; When interactive, select the Tramp remote identification.
@@ -107,21 +111,21 @@ When called interactively, a Tramp connection has to be selected."
;; suppressed.
(setq tramp-current-connection nil)
- ;; Flush file cache.
- (tramp-flush-directory-properties vec "")
-
- ;; Flush connection cache.
- (when (processp (tramp-get-connection-process vec))
- (tramp-flush-connection-properties (tramp-get-connection-process vec))
- (delete-process (tramp-get-connection-process vec)))
- (tramp-flush-connection-properties vec)
-
;; Cancel timer.
(dolist (timer timer-list)
(when (and (eq (timer--function timer) 'tramp-timeout-session)
(tramp-file-name-equal-p vec (car (timer--args timer))))
(cancel-timer timer)))
+ ;; Delete processes.
+ (dolist (key (hash-table-keys tramp-cache-data))
+ (when (and (processp key)
+ (tramp-file-name-equal-p (process-get key 'vector) vec)
+ (or (not keep-processes)
+ (eq key (tramp-get-process vec))))
+ (tramp-flush-connection-properties key)
+ (delete-process key)))
+
;; Remove buffers.
(dolist
(buf (list (get-buffer (tramp-buffer-name vec))
@@ -130,17 +134,30 @@ When called interactively, a Tramp connection has to be selected."
(tramp-get-connection-property vec "process-buffer" nil)))
(when (bufferp buf) (kill-buffer buf)))
+ ;; Flush file cache.
+ (tramp-flush-directory-properties vec "")
+
+ ;; Flush connection cache.
+ (tramp-flush-connection-properties vec)
+
;; The end.
(run-hook-with-args 'tramp-cleanup-connection-hook vec)))
;;;###tramp-autoload
(defun tramp-cleanup-this-connection ()
"Flush all connection related objects of the current buffer's connection."
+ ;; (declare (completion tramp-command-completion-p)))
(interactive)
(and (tramp-tramp-file-p default-directory)
(tramp-cleanup-connection
(tramp-dissect-file-name default-directory 'noexpand))))
+;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form.
+;;;###tramp-autoload
+(function-put
+ #'tramp-cleanup-this-connection 'completion-predicate
+ #'tramp-command-completion-p)
+
;;;###tramp-autoload
(defvar tramp-cleanup-all-connections-hook nil
"List of functions to be called after all Tramp connections are cleaned up.")
@@ -151,9 +168,6 @@ When called interactively, a Tramp connection has to be selected."
This includes password cache, file cache, connection cache, buffers."
(interactive)
- ;; Unlock Tramp.
- (setq tramp-locked nil)
-
;; Flush password cache.
(password-reset)
@@ -176,8 +190,9 @@ This includes password cache, file cache, connection cache, buffers."
;; Cancel timers.
(cancel-function-timers 'tramp-timeout-session)
- ;; Remove buffers.
+ ;; Remove processes and buffers.
(dolist (name (tramp-list-tramp-buffers))
+ (when (processp (get-buffer-process name)) (delete-process name))
(when (bufferp (get-buffer name)) (kill-buffer name)))
;; The end.
@@ -195,7 +210,6 @@ This includes password cache, file cache, connection cache, buffers."
(dolist (name (tramp-list-remote-buffers))
(when (bufferp (get-buffer name)) (kill-buffer name))))
-;;;###tramp-autoload
(defcustom tramp-default-rename-alist nil
"Default target for renaming remote buffer file names.
This is an alist of cons cells (SOURCE . TARGET). The first
@@ -218,7 +232,6 @@ expression which always matches."
:type '(repeat (cons (choice :tag "Source regexp" regexp sexp)
(choice :tag "Target name" string (const nil)))))
-;;;###tramp-autoload
(defcustom tramp-confirm-rename-file-names t
"Whether renaming a buffer file name must be confirmed."
:group 'tramp
@@ -237,7 +250,7 @@ function returns nil"
(host (or (file-remote-p string 'host) ""))
item result)
(while (setq item (pop tdra))
- (when (string-match-p (or (eval (car item)) "") string)
+ (when (string-match-p (or (eval (car item) t) "") string)
(setq tdra nil
result
(format-spec
@@ -350,9 +363,8 @@ The remote connection identified by SOURCE is flushed by
(or (setq target (tramp-default-rename-file source))
(tramp-user-error
nil
- (eval-when-compile
- (concat "There is no target specified. "
- "Check `tramp-default-rename-alist' for a proper entry.")))))
+ (concat "There is no target specified. "
+ "Check `tramp-default-rename-alist' for a proper entry."))))
(when (tramp-equal-remote source target)
(tramp-user-error nil "Source and target must have different remote."))
@@ -379,8 +391,7 @@ ESC or `q' to quit without changing further buffers,
(switch-to-buffer buffer)
(let* ((bfn (buffer-file-name))
(new-bfn (and (stringp bfn)
- (replace-regexp-in-string
- (regexp-quote source) target bfn)))
+ (tramp-compat-string-replace source target bfn)))
(prompt (format-message
"Set visited file name to `%s' [Type yn!eq or %s] "
new-bfn (key-description (vector help-char)))))
@@ -427,6 +438,7 @@ Interactively, TARGET is selected from `tramp-default-rename-alist'
without confirmation if the prefix argument is non-nil.
For details, see `tramp-rename-files'."
+ ;; (declare (completion tramp-command-completion-p))
(interactive
(let ((source default-directory)
target
@@ -457,11 +469,59 @@ For details, see `tramp-rename-files'."
(tramp-rename-files default-directory target))
+;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form.
+;;;###tramp-autoload
+(function-put
+ #'tramp-rename-these-files 'completion-predicate #'tramp-command-completion-p)
+
+;; This function takes action since Emacs 28.1, when
+;; `read-extended-command-predicate' is set to
+;; `command-completion-default-include-p'.
+;;;###tramp-autoload
+(defun tramp-recompile-elpa-command-completion-p (_symbol _buffer)
+ "A predicate for `tramp-recompile-elpa'.
+It is completed by \"M-x TAB\" only if package.el is loaded, and
+Tramp is an installed ELPA package."
+ ;; We cannot apply `package-installed-p', this would also return the
+ ;; builtin package.
+ (and (assq 'tramp (bound-and-true-p package-alist))
+ (tramp-compat-funcall 'package--user-installed-p 'tramp)))
+
+;;;###tramp-autoload
+(defun tramp-recompile-elpa ()
+ "Recompile the installed Tramp ELPA package.
+This is needed if there are compatibility problems."
+ ;; (declare (completion tramp-recompile-elpa-command-completion-p))
+ (interactive)
+ ;; We expect just one Tramp package is installed.
+ (when-let
+ ((dir (tramp-compat-funcall
+ 'package-desc-dir
+ (car (alist-get 'tramp (bound-and-true-p package-alist))))))
+ (dolist (elc (directory-files dir 'full "\\.elc\\'"))
+ (delete-file elc))
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
+ (let ((inhibit-read-only t))
+ (compilation-mode)
+ (goto-char (point-max))
+ (insert "\f\n")
+ (call-process
+ (expand-file-name invocation-name invocation-directory) nil t t
+ "-Q" "-batch" "-L" dir
+ "--eval" (format "(byte-recompile-directory %S 0 t)" dir))
+ (message "Package `tramp' recompiled.")))))
+
+;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form.
+;;;###tramp-autoload
+(function-put
+ #'tramp-recompile-elpa 'completion-predicate
+ #'tramp-recompile-elpa-command-completion-p)
+
;; 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."
+ "Print version number of tramp.el in echo area or current buffer."
(interactive "P")
(if arg (insert tramp-version) (message tramp-version)))
@@ -474,9 +534,7 @@ For details, see `tramp-rename-files'."
(defun tramp-bug ()
"Submit a bug report to the Tramp developers."
(interactive)
- (let ((reporter-prompt-for-summary-p t)
- ;; In rare cases, it could contain the password. So we make it nil.
- tramp-password-save-function)
+ (let ((reporter-prompt-for-summary-p t))
(reporter-submit-bug-report
tramp-bug-report-address ; to-address
(format "tramp (%s %s/%s)" ; package name and version
@@ -484,10 +542,11 @@ For details, see `tramp-rename-files'."
(sort
(delq nil (mapcar
(lambda (x)
- (and x (boundp x) (cons x 'tramp-reporter-dump-variable)))
+ (and x (boundp x) (not (get x 'tramp-suppress-trace))
+ (cons x 'tramp-reporter-dump-variable)))
(append
(mapcar #'intern (all-completions "tramp-" obarray #'boundp))
- ;; Non-tramp variables of interest.
+ ;; Non-Tramp variables of interest.
'(shell-prompt-pattern
backup-by-copying
backup-by-copying-when-linked
@@ -544,11 +603,11 @@ buffer in your bug report.
(string-match-p
(concat "[^" (bound-and-true-p mm-7bit-chars) "]") val))
(with-current-buffer reporter-eval-buffer
- (set
- varsym
- (format
- "(decode-coding-string (base64-decode-string \"%s\") 'raw-text)"
- (base64-encode-string (encode-coding-string val 'raw-text)))))))
+ (set varsym
+ `(decode-coding-string
+ (base64-decode-string
+ ,(base64-encode-string (encode-coding-string val 'raw-text)))
+ 'raw-text)))))
;; Dump variable.
(reporter-dump-variable varsym mailbuf)
@@ -557,11 +616,10 @@ buffer in your bug report.
;; Remove string quotation.
(forward-line -1)
(when (looking-at
- (eval-when-compile
- (concat "\\(^.*\\)" "\"" ;; \1 "
- "\\((base64-decode-string \\)" "\\\\" ;; \2 \
- "\\(\".*\\)" "\\\\" ;; \3 \
- "\\(\")\\)" "\"$"))) ;; \4 "
+ (concat "\\(^.*\\)" "\"" ;; \1 "
+ "\\((base64-decode-string \\)" "\\\\" ;; \2 \
+ "\\(\".*\\)" "\\\\" ;; \3 \
+ "\\(\")\\)" "\"$")) ;; \4 "
(replace-match "\\1\\2\\3\\4")
(beginning-of-line)
(insert " ;; Variable encoded due to non-printable characters.\n"))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index e53a4477751..6e464073379 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -23,15 +23,15 @@
;;; Commentary:
-;; Tramp's main Emacs version for development is Emacs 27. This
-;; package provides compatibility functions for Emacs 24, Emacs 25 and
-;; Emacs 26.
+;; Tramp's main Emacs version for development is Emacs 28. This
+;; package provides compatibility functions for Emacs 25, Emacs 26 and
+;; Emacs 27.
;;; Code:
-;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not
-;; autoloaded. So we declare it here in order to avoid recursive
-;; load. This will be overwritten in tramp.el.
+;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded.
+;; So we declare it here in order to avoid recursive load. This will
+;; be overwritten in tramp.el.
(defun tramp-unload-file-name-handlers () ".")
(require 'auth-source)
@@ -41,8 +41,11 @@
(require 'shell)
(require 'subr-x)
+(declare-function tramp-error "tramp")
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
(declare-function tramp-handle-temporary-file-directory "tramp")
+(declare-function tramp-tramp-file-p "tramp")
+(defvar tramp-temp-name-prefix)
(defconst tramp-compat-emacs-compiled-version (eval-when-compile emacs-version)
"The Emacs version used for compilation.")
@@ -65,17 +68,21 @@
It is the default value of `temporary-file-directory'."
;; We must return a local directory. If it is remote, we could run
;; into an infloop.
- (eval (car (get 'temporary-file-directory 'standard-value))))
+ (eval (car (get 'temporary-file-directory 'standard-value)) t))
+
+(defsubst tramp-compat-make-temp-name ()
+ "Generate a local temporary file name (compat function)."
+ (make-temp-name
+ (expand-file-name
+ tramp-temp-name-prefix (tramp-compat-temporary-file-directory))))
(defsubst tramp-compat-make-temp-file (f &optional dir-flag)
"Create a local temporary file (compat function).
Add the extension of F, if existing."
- (let* (file-name-handler-alist
- (prefix (expand-file-name
- (symbol-value 'tramp-temp-name-prefix)
- (tramp-compat-temporary-file-directory)))
- (extension (file-name-extension f t)))
- (make-temp-file prefix dir-flag extension)))
+ (make-temp-file
+ (expand-file-name
+ tramp-temp-name-prefix (tramp-compat-temporary-file-directory))
+ dir-flag (file-name-extension f t)))
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
(defalias 'tramp-compat-temporary-file-directory-function
@@ -83,31 +90,7 @@ Add the extension of F, if existing."
#'temporary-file-directory
#'tramp-handle-temporary-file-directory))
-(defun tramp-compat-process-running-p (process-name)
- "Return t if system process PROCESS-NAME is running for `user-login-name'."
- (when (stringp process-name)
- (cond
- ;; GNU Emacs 22 on w32.
- ((fboundp 'w32-window-exists-p)
- (tramp-compat-funcall 'w32-window-exists-p process-name process-name))
-
- ;; GNU Emacs 23+.
- ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
- (let (result)
- (dolist (pid (tramp-compat-funcall 'list-system-processes) result)
- (let ((attributes (process-attributes pid)))
- (when (and (string-equal
- (cdr (assoc 'user attributes)) (user-login-name))
- (let ((comm (cdr (assoc 'comm attributes))))
- ;; The returned command name could be truncated
- ;; to 15 characters. Therefore, we cannot check
- ;; for `string-equal'.
- (and comm (string-match-p
- (concat "^" (regexp-quote comm))
- process-name))))
- (setq result t)))))))))
-
-;; `file-attribute-*' are introduced in Emacs 25.1.
+;; `file-attribute-*' are introduced in Emacs 26.1.
(defalias 'tramp-compat-file-attribute-type
(if (fboundp 'file-attribute-type)
@@ -189,31 +172,19 @@ and later, and is a float in Emacs 26 and earlier."
This is a string of ten letters or dashes as in ls -l."
(nth 8 attributes))))
-;; `format-message' is new in Emacs 25.1.
-(unless (fboundp 'format-message)
- (defalias 'format-message #'format))
-
-;; `directory-name-p' is new in Emacs 25.1.
-(defalias 'tramp-compat-directory-name-p
- (if (fboundp 'directory-name-p)
- #'directory-name-p
- (lambda (name)
- "Return non-nil if NAME ends with a directory separator character."
- (let ((len (length name))
- (lastc ?.))
- (if (> len 0)
- (setq lastc (aref name (1- len))))
- (or (= lastc ?/)
- (and (memq system-type '(windows-nt ms-dos))
- (= lastc ?\\)))))))
-
;; `file-missing' is introduced in Emacs 26.1.
(defconst tramp-file-missing
(if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
"The error symbol for the `file-missing' error.")
+(defsubst tramp-compat-file-missing (vec file)
+ "Emit the `file-missing' error."
+ (if (get 'file-missing 'error-conditions)
+ (tramp-error vec tramp-file-missing file)
+ (tramp-error vec tramp-file-missing "No such file or directory: %s" file)))
+
;; `file-local-name', `file-name-quoted-p', `file-name-quote' and
-;; `file-name-unquote' are introduced in Emacs 26.
+;; `file-name-unquote' are introduced in Emacs 26.1.
(defalias 'tramp-compat-file-local-name
(if (fboundp 'file-local-name)
#'file-local-name
@@ -223,7 +194,8 @@ It returns a file name which can be used directly as argument of
`process-file', `start-file-process', or `shell-command'."
(or (file-remote-p name 'localname) name))))
-;; `file-name-quoted-p' got a second argument in Emacs 27.1.
+;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got
+;; a second argument in Emacs 27.1.
(defalias 'tramp-compat-file-name-quoted-p
(if (and
(fboundp 'file-name-quoted-p)
@@ -265,7 +237,7 @@ NAME is unquoted."
localname (if (= (length localname) 2) "/" (substring localname 2))))
(concat (file-remote-p name) localname)))))
-;; `tramp-syntax' has changed its meaning in Emacs 26. We still
+;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still
;; support old settings.
(defsubst tramp-compat-tramp-syntax ()
"Return proper value of `tramp-syntax'."
@@ -274,13 +246,6 @@ NAME is unquoted."
((eq tramp-syntax 'sep) 'separate)
(t tramp-syntax)))
-;; `cl-struct-slot-info' has been introduced with Emacs 25.
-(defmacro tramp-compat-tramp-file-name-slots ()
- "Return a list of slot names."
- (if (fboundp 'cl-struct-slot-info)
- '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))
- '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots)))))
-
;; The signature of `tramp-make-tramp-file-name' has been changed.
;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior
;; Emacs 26.1. We use `temporary-file-directory' as indicator.
@@ -293,10 +258,9 @@ NAME is unquoted."
#'exec-path
(lambda ()
"List of directories to search programs to run in remote subprocesses."
- (let ((handler (find-file-name-handler default-directory 'exec-path)))
- (if handler
- (funcall handler 'exec-path)
- exec-path)))))
+ (if-let ((handler (find-file-name-handler default-directory 'exec-path)))
+ (funcall handler 'exec-path)
+ exec-path))))
;; `time-equal-p' has appeared in Emacs 27.1.
(defalias 'tramp-compat-time-equal-p
@@ -331,16 +295,106 @@ A nil value for either argument stands for the current time."
(lambda (reporter &optional value _suffix)
(progress-reporter-update reporter value))))
+;; `file-modes', `set-file-modes' and `set-file-times' got argument
+;; FLAG in Emacs 28.1.
+(defalias 'tramp-compat-file-modes
+ (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2))
+ #'file-modes
+ (lambda (filename &optional _flag)
+ (file-modes filename))))
+
+(defalias 'tramp-compat-set-file-modes
+ (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3))
+ #'set-file-modes
+ (lambda (filename mode &optional _flag)
+ (set-file-modes filename mode))))
+
+(defalias 'tramp-compat-set-file-times
+ (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3))
+ #'set-file-times
+ (lambda (filename &optional timestamp _flag)
+ (set-file-times filename timestamp))))
+
+;; `directory-files' and `directory-files-and-attributes' got argument
+;; COUNT in Emacs 28.1.
+(defalias 'tramp-compat-directory-files
+ (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5))
+ #'directory-files
+ (lambda (directory &optional full match nosort _count)
+ (directory-files directory full match nosort))))
+
+(defalias 'tramp-compat-directory-files-and-attributes
+ (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes)
+ '(1 . 6))
+ #'directory-files-and-attributes
+ (lambda (directory &optional full match nosort id-format _count)
+ (directory-files-and-attributes directory full match nosort id-format))))
+
+;; `directory-empty-p' is new in Emacs 28.1.
+(defalias 'tramp-compat-directory-empty-p
+ (if (fboundp 'directory-empty-p)
+ #'directory-empty-p
+ (lambda (dir)
+ (and (file-directory-p dir)
+ (null (tramp-compat-directory-files
+ dir nil directory-files-no-dot-files-regexp t 1))))))
+
+;; Function `null-device' is new in Emacs 28.1.
+(defalias 'tramp-compat-null-device
+ (if (fboundp 'null-device)
+ #'null-device
+ (lambda ()
+ (if (tramp-tramp-file-p default-directory) "/dev/null" null-device))))
+
+;; Function `string-replace' is new in Emacs 28.1.
+(defalias 'tramp-compat-string-replace
+ (if (fboundp 'string-replace)
+ #'string-replace
+ (lambda (fromstring tostring instring)
+ (replace-regexp-in-string (regexp-quote fromstring) tostring instring))))
+
+;; Function `make-lock-file-name' is new in Emacs 28.1.
+(defalias 'tramp-compat-make-lock-file-name
+ (if (fboundp 'make-lock-file-name)
+ #'make-lock-file-name
+ (lambda (filename)
+ (expand-file-name
+ (concat
+ ".#" (file-name-nondirectory filename))
+ (file-name-directory filename)))))
+
+;; Function `file-name-concat' is new in Emacs 28.1.
+(defalias 'tramp-compat-file-name-concat
+ (if (fboundp 'file-name-concat)
+ #'file-name-concat
+ (lambda (directory &rest components)
+ (unless (null directory)
+ (let ((components (delq nil components))
+ file-name-handler-alist)
+ (if (null components)
+ directory
+ (tramp-compat-file-name-concat
+ (concat (file-name-as-directory directory) (car components))
+ (cdr components))))))))
+
+(dolist (elt (all-completions "tramp-compat-" obarray 'functionp))
+ (put (intern elt) 'tramp-suppress-trace t))
+
(add-hook 'tramp-unload-hook
(lambda ()
(unload-feature 'tramp-loaddefs 'force)
(unload-feature 'tramp-compat 'force)))
+(provide 'tramp-compat)
+
;;; TODO:
;;
-;; * Starting with Emacs 25.1, replace `tramp-message-show-message' by
-;; the reverse of `inhibit-message'.
-
-(provide 'tramp-compat)
+;; * `func-arity' exists since Emacs 26.1.
+;;
+;; * Starting with Emacs 27.1, there's no need to escape open
+;; parentheses with a backslash in docstrings anymore.
+;;
+;; * Starting with Emacs 27.1, there's `make-empty-file'. Could be
+;; used instead of `write-region'.
;;; tramp-compat.el ends here
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
new file mode 100644
index 00000000000..fdb2907ec32
--- /dev/null
+++ b/lisp/net/tramp-crypt.el
@@ -0,0 +1,887 @@
+;;; tramp-crypt.el --- Tramp crypt utilities -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Access functions for crypted remote files. It uses encfs to
+;; encrypt / decrypt the files on a remote directory. A remote
+;; directory, which shall include crypted files, must be declared in
+;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'.
+;; All files in that directory, including all subdirectories, are
+;; stored there encrypted. This includes file names and directory
+;; names.
+
+;; This package is just responsible for the encryption part. Copying
+;; of the crypted files is still the responsibility of the remote file
+;; name handlers.
+
+;; A password protected encfs configuration file is created the very
+;; first time you access a crypted remote directory. It is kept in
+;; your user directory "~/.emacs.d/" with the url-encoded directory
+;; name as part of the basename, and ".encfs6.xml" as suffix. Do not
+;; loose this file and the corresponding password; otherwise there is
+;; no way to decrypt your crypted files.
+
+;; If the user option `tramp-crypt-save-encfs-config-remote' is
+;; non-nil (the default), the encfs configuration file ".encfs6.xml"
+;; is also kept in the crypted remote directory. It depends on you,
+;; whether you regard the password protection of this file as
+;; sufficient.
+
+;; If you use a remote file name with a quoted localname part, this
+;; localname and the corresponding file will not be encrypted/
+;; decrypted. For example, if you have a crypted remote directory
+;; "/nextcloud:user@host:/crypted_dir", the command
+;;
+;; C-x d /nextcloud:user@host:/crypted_dir
+;;
+;; will show the directory listing with the plain file names, and the
+;; command
+;;
+;; C-x d /nextcloud:user@host:/:/crypted_dir
+;;
+;; will show the directory with the encrypted file names, and visiting
+;; a file will show its crypted contents. However, it is highly
+;; discouraged to mix crypted and not crypted files in the same
+;; directory.
+
+;; If a remote directory shall not include crypted files anymore, it
+;; must be indicated by the command `tramp-crypt-remove-directory'.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'tramp)
+
+(autoload 'prop-match-beginning "text-property-search")
+(autoload 'prop-match-end "text-property-search")
+(autoload 'text-property-search-forward "text-property-search")
+
+(defconst tramp-crypt-method "crypt"
+ "Method name for crypted remote directories.")
+
+(defcustom tramp-crypt-encfs-program "encfs"
+ "Name of the encfs program."
+ :group 'tramp
+ :version "28.1"
+ :type 'string)
+
+(defcustom tramp-crypt-encfsctl-program "encfsctl"
+ "Name of the encfsctl program."
+ :group 'tramp
+ :version "28.1"
+ :type 'string)
+
+(defcustom tramp-crypt-encfs-option "--standard"
+ "Configuration option for encfs.
+This could be either \"--standard\" or \"--paranoia\". The file
+name IV chaining mode mode will always be disabled when
+initializing a new crypted remote directory."
+ :group 'tramp
+ :version "28.1"
+ :type '(choice (const "--standard")
+ (const "--paranoia")))
+
+;; We check only for encfs, assuming that encfsctl will be available
+;; as well. The autoloaded value is nil, the check will run when
+;; tramp-crypt.el is loaded by `tramp-crypt-add-directory'. It is a
+;; common technique to let-bind this variable to nil in order to
+;; suppress the file name operation of this package.
+;;;###tramp-autoload
+(defvar tramp-crypt-enabled nil
+ "Non-nil when encryption support is available.")
+(setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program))
+
+;; This function takes action since Emacs 28.1, when
+;; `read-extended-command-predicate' is set to
+;; `command-completion-default-include-p'.
+(defun tramp-crypt-command-completion-p (symbol _buffer)
+ "A predicate for Tramp interactive commands.
+They are completed by \"M-x TAB\" only when encryption support is enabled."
+ (and tramp-crypt-enabled
+ ;; `tramp-crypt-remove-directory' needs to be completed only in
+ ;; case we have already crypted directories.
+ (or (not (eq symbol #'tramp-crypt-remove-directory))
+ tramp-crypt-directories)))
+
+;;;###tramp-autoload
+(defconst tramp-crypt-encfs-config ".encfs6.xml"
+ "Encfs configuration file name.")
+
+(defcustom tramp-crypt-save-encfs-config-remote t
+ "Whether to keep the encfs configuration file in the crypted remote directory."
+ :group 'tramp
+ :version "28.1"
+ :type 'boolean)
+
+;;;###tramp-autoload
+(defvar tramp-crypt-directories nil
+ "List of crypted remote directories.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-crypt-file-name-p (name)
+ "Return the crypted remote directory NAME belongs to.
+If NAME doesn't belong to a crypted remote directory, retun nil."
+ (catch 'crypt-file-name-p
+ (and tramp-crypt-enabled (stringp name)
+ (not (tramp-compat-file-name-quoted-p name))
+ (not (string-suffix-p tramp-crypt-encfs-config name))
+ (dolist (dir tramp-crypt-directories)
+ (and (string-prefix-p
+ dir (file-name-as-directory (expand-file-name name)))
+ (throw 'crypt-file-name-p dir))))))
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-crypt-file-name-handler-alist
+ '((access-file . tramp-crypt-handle-access-file)
+ (add-name-to-file . tramp-handle-add-name-to-file)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ (copy-directory . tramp-handle-copy-directory)
+ (copy-file . tramp-crypt-handle-copy-file)
+ (delete-directory . tramp-crypt-handle-delete-directory)
+ (delete-file . tramp-crypt-handle-delete-file)
+ ;; `diff-latest-backup-file' performed by default handler.
+ ;; `directory-file-name' performed by default handler.
+ (directory-files . tramp-crypt-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . ignore)
+ ;; `expand-file-name' performed by default handler.
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-crypt-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-crypt-handle-file-executable-p)
+ (file-exists-p . tramp-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-crypt-handle-file-locked-p)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions . tramp-crypt-handle-file-name-all-completions)
+ ;; `file-name-as-directory' performed by default handler.
+ (file-name-case-insensitive-p . ignore)
+ (file-name-completion . tramp-handle-file-name-completion)
+ ;; `file-name-directory' performed by default handler.
+ ;; `file-name-nondirectory' performed by default handler.
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p)
+ (file-readable-p . tramp-crypt-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ ;; `file-remote-p' performed by default handler.
+ (file-selinux-context . ignore)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-crypt-handle-file-system-info)
+ ;; `file-truename' performed by default handler.
+ (file-writable-p . tramp-crypt-handle-file-writable-p)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-crypt-handle-insert-directory)
+ ;; `insert-file-contents' performed by default handler.
+ (load . tramp-handle-load)
+ (lock-file . tramp-crypt-handle-lock-file)
+ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
+ (make-directory . tramp-crypt-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . ignore)
+ (make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-file . ignore)
+ (rename-file . tramp-crypt-handle-rename-file)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-crypt-handle-set-file-modes)
+ (set-file-selinux-context . ignore)
+ (set-file-times . tramp-crypt-handle-set-file-times)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . ignore)
+ (start-file-process . ignore)
+ ;; `substitute-in-file-name' performed by default handler.
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ ;; `tramp-get-remote-gid' performed by default handler.
+ ;; `tramp-get-remote-uid' performed by default handler.
+ (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid)
+ (unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-crypt-handle-unlock-file)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-handle-write-region))
+ "Alist of handler functions for crypt method.
+Operations not mentioned here will be handled by the default Emacs primitives.")
+
+(defsubst tramp-crypt-file-name-for-operation (operation &rest args)
+ "Like `tramp-file-name-for-operation', but for crypted remote files."
+ (let ((tfnfo (apply #'tramp-file-name-for-operation operation args)))
+ ;; `tramp-file-name-for-operation' returns already the first argument
+ ;; if it is remote. So we check a possible second argument.
+ (unless (tramp-crypt-file-name-p tfnfo)
+ (setq tfnfo (apply
+ #'tramp-file-name-for-operation operation
+ (cons (tramp-compat-temporary-file-directory) (cdr args)))))
+ tfnfo))
+
+(defun tramp-crypt-run-real-handler (operation args)
+ "Invoke normal file name handler for OPERATION.
+First arg specifies the OPERATION, second arg ARGS is a list of
+arguments to pass to the OPERATION."
+ (let* ((inhibit-file-name-handlers
+ `(tramp-crypt-file-name-handler
+ .
+ ,(and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
+
+;;;###tramp-autoload
+(defun tramp-crypt-file-name-handler (operation &rest args)
+ "Invoke the crypted remote file related OPERATION.
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((filename
+ (apply #'tramp-crypt-file-name-for-operation operation args))
+ (fn (and (tramp-crypt-file-name-p filename)
+ (assoc operation tramp-crypt-file-name-handler-alist))))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-crypt-run-real-handler operation args)))
+
+;;;###tramp-autoload
+(progn (defun tramp-register-crypt-file-name-handler ()
+ "Add crypt file name handler to `file-name-handler-alist'."
+ (when (and tramp-crypt-enabled tramp-crypt-directories)
+ (add-to-list 'file-name-handler-alist
+ (cons tramp-file-name-regexp #'tramp-crypt-file-name-handler))
+ (put #'tramp-crypt-file-name-handler 'safe-magic t))))
+
+(tramp-register-file-name-handlers)
+
+;; Mark `operations' the handler is responsible for.
+(put #'tramp-crypt-file-name-handler 'operations
+ (mapcar #'car tramp-crypt-file-name-handler-alist))
+
+
+;; File name conversions.
+
+(defun tramp-crypt-config-file-name (vec)
+ "Return the encfs config file name for VEC."
+ (expand-file-name
+ (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)
+ user-emacs-directory))
+
+(defun tramp-crypt-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."
+ ;; For password handling, we need a process bound to the connection
+ ;; buffer. Therefore, we create a dummy process. Maybe there is a
+ ;; better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (process-put p 'vector vec)
+ (set-process-query-on-exit-flag p nil)))
+
+ ;; The following operations must be performed w/o
+ ;; `tramp-crypt-file-name-handler'.
+ (let* (tramp-crypt-enabled
+ ;; Don't check for a proper method.
+ (non-essential t)
+ (remote-config
+ (expand-file-name
+ tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec)))
+ (local-config (tramp-crypt-config-file-name vec)))
+ ;; There is no local encfs6 config file.
+ (when (not (file-exists-p local-config))
+ (if (and tramp-crypt-save-encfs-config-remote
+ (file-exists-p remote-config))
+ ;; Copy remote encfs6 config file if possible.
+ (copy-file remote-config local-config 'ok 'keep)
+
+ ;; Create local encfs6 config file otherwise.
+ (let* ((default-directory (tramp-compat-temporary-file-directory))
+ (tmpdir1 (file-name-as-directory
+ (tramp-compat-make-temp-file " .crypt" 'dir-flag)))
+ (tmpdir2 (file-name-as-directory
+ (tramp-compat-make-temp-file " .nocrypt" 'dir-flag))))
+ ;; Enable `auth-source', unless "emacs -Q" has been called.
+ (tramp-set-connection-property
+ vec "first-password-request" tramp-cache-read-persistent-data)
+ (with-temp-buffer
+ (insert
+ (tramp-read-passwd
+ (tramp-get-connection-process vec)
+ (format
+ "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec))))
+ (when
+ (zerop
+ (tramp-call-process-region
+ vec (point-min) (point-max)
+ tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec)
+ nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2))
+ ;; Save the password.
+ (ignore-errors
+ (and (functionp tramp-password-save-function)
+ (funcall tramp-password-save-function)))))
+
+ ;; Write local config file. Suppress file name IV chaining mode.
+ (with-temp-file local-config
+ (insert-file-contents
+ (expand-file-name tramp-crypt-encfs-config tmpdir1))
+ (when (search-forward
+ "<chainedNameIV>1</chainedNameIV>" nil 'noerror)
+ (replace-match "<chainedNameIV>0</chainedNameIV>")))
+
+ ;; Unmount encfs. Delete temporary directories.
+ (tramp-call-process
+ vec tramp-crypt-encfs-program nil nil nil
+ "--unmount" tmpdir1 tmpdir2)
+ (delete-directory tmpdir1 'recursive)
+ (delete-directory tmpdir2)
+
+ ;; Copy local encfs6 config file to remote.
+ (when tramp-crypt-save-encfs-config-remote
+ (copy-file local-config remote-config 'ok 'keep)))))))
+
+(defun tramp-crypt-send-command (vec &rest args)
+ "Send encfsctl command to connection VEC.
+ARGS are the arguments. It returns t if ran successful, and nil otherwise."
+ (tramp-crypt-maybe-open-connection vec)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (erase-buffer)
+ (set-buffer-multibyte nil))
+ (with-temp-buffer
+ (let* (;; Don't check for a proper method.
+ (non-essential t)
+ (default-directory (tramp-compat-temporary-file-directory))
+ ;; We cannot add it to `process-environment', because
+ ;; `tramp-call-process-region' doesn't use it.
+ (encfs-config
+ (format "ENCFS6_CONFIG=%s" (tramp-crypt-config-file-name vec)))
+ (args (delq nil args)))
+ ;; Enable `auth-source', unless "emacs -Q" has been called.
+ (tramp-set-connection-property
+ vec "first-password-request" tramp-cache-read-persistent-data)
+ (insert
+ (tramp-read-passwd
+ (tramp-get-connection-process vec)
+ (format "EncFS Password for %s " (tramp-crypt-get-remote-dir vec))))
+ (when (zerop
+ (apply
+ #'tramp-call-process-region vec (point-min) (point-max)
+ "env" nil (tramp-get-connection-buffer vec)
+ nil encfs-config tramp-crypt-encfsctl-program
+ (car args) "--extpass=cat" (cdr args)))
+ ;; Save the password.
+ (ignore-errors
+ (and (functionp tramp-password-save-function)
+ (funcall tramp-password-save-function)))
+ t))))
+
+(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name)
+ "Return encrypted / decrypted NAME if NAME belongs to a crypted directory.
+OP must be `encrypt' or `decrypt'. Raise an error if this fails.
+Otherwise, return NAME."
+ (if-let ((tramp-crypt-enabled t)
+ (dir (tramp-crypt-file-name-p name))
+ ;; It must be absolute for the cache.
+ (localname (substring name (1- (length dir))))
+ (crypt-vec (tramp-crypt-dissect-file-name dir)))
+ ;; Preserve trailing "/".
+ (funcall
+ (if (directory-name-p name) #'file-name-as-directory #'identity)
+ (concat
+ dir
+ (unless (string-equal localname "/")
+ (with-tramp-file-property
+ crypt-vec localname (concat (symbol-name op) "-file-name")
+ (unless (tramp-crypt-send-command
+ crypt-vec (if (eq op 'encrypt) "encode" "decode")
+ (tramp-compat-temporary-file-directory) localname)
+ (tramp-error
+ crypt-vec 'file-error "%s of file name %s failed."
+ (if (eq op 'encrypt) "Encoding" "Decoding") name))
+ (with-current-buffer (tramp-get-connection-buffer crypt-vec)
+ (goto-char (point-min))
+ (buffer-substring (point-min) (point-at-eol)))))))
+ ;; Nothing to do.
+ name))
+
+(defsubst tramp-crypt-encrypt-file-name (name)
+ "Return encrypted NAME if NAME belongs to a crypted directory.
+Otherwise, return NAME."
+ (tramp-crypt-do-encrypt-or-decrypt-file-name 'encrypt name))
+
+(defsubst tramp-crypt-decrypt-file-name (name)
+ "Return decrypted NAME if NAME belongs to a crypted directory.
+Otherwise, return NAME."
+ (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name))
+
+(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile)
+ "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT.
+Both files must be local files. OP must be `encrypt' or `decrypt'.
+If OP ist `decrypt', the basename of INFILE must be an encrypted file name.
+Raise an error if this fails."
+ (when-let ((tramp-crypt-enabled t)
+ (dir (tramp-crypt-file-name-p root))
+ (crypt-vec (tramp-crypt-dissect-file-name dir)))
+ (let ((coding-system-for-read
+ (if (eq op 'decrypt) 'binary coding-system-for-read))
+ (coding-system-for-write
+ (if (eq op 'encrypt) 'binary coding-system-for-write)))
+ (unless (tramp-crypt-send-command
+ crypt-vec "cat" (and (eq op 'encrypt) "--reverse")
+ (file-name-directory infile)
+ (concat "/" (file-name-nondirectory infile)))
+ (tramp-error
+ crypt-vec 'file-error "%s of file %s failed."
+ (if (eq op 'encrypt) "Encrypting" "Decrypting") infile))
+ (with-current-buffer (tramp-get-connection-buffer crypt-vec)
+ (write-region nil nil outfile)))))
+
+(defsubst tramp-crypt-encrypt-file (root infile outfile)
+ "Encrypt file INFILE to OUTFILE according to crypted directory ROOT.
+See `tramp-crypt-do-encrypt-or-decrypt-file'."
+ (tramp-crypt-do-encrypt-or-decrypt-file 'encrypt root infile outfile))
+
+(defsubst tramp-crypt-decrypt-file (root infile outfile)
+ "Decrypt file INFILE to OUTFILE according to crypted directory ROOT.
+See `tramp-crypt-do-encrypt-or-decrypt-file'."
+ (tramp-crypt-do-encrypt-or-decrypt-file 'decrypt root infile outfile))
+
+;;;###tramp-autoload
+(defun tramp-crypt-add-directory (name)
+ "Mark remote directory NAME for encryption.
+Files in that directory and all subdirectories will be encrypted
+before copying to, and decrypted after copying from that
+directory. File names will be also encrypted."
+ (interactive "DRemote directory name: ")
+ (unless tramp-crypt-enabled
+ (tramp-user-error nil "Feature is not enabled."))
+ (unless (and (tramp-tramp-file-p name) (file-directory-p name))
+ (tramp-user-error nil "%s must be an existing remote directory." name))
+ (when (tramp-compat-file-name-quoted-p name)
+ (tramp-user-error nil "%s must not be quoted." name))
+ (setq name (file-name-as-directory (expand-file-name name)))
+ (unless (member name tramp-crypt-directories)
+ (setq tramp-crypt-directories (cons name tramp-crypt-directories)))
+ (tramp-register-file-name-handlers))
+
+;; `tramp-crypt-command-completion-p' is not autoloaded, and this
+;; setting isn't either.
+(function-put
+ #'tramp-crypt-add-directory 'completion-predicate
+ #'tramp-crypt-command-completion-p)
+
+(defun tramp-crypt-remove-directory (name)
+ "Unmark remote directory NAME for encryption.
+Existing files in that directory and its subdirectories will be
+kept in their encrypted form."
+ ;; (declare (completion tramp-crypt-command-completion-p))
+ (interactive "DRemote directory name: ")
+ (unless tramp-crypt-enabled
+ (tramp-user-error nil "Feature is not enabled."))
+ (setq name (file-name-as-directory (expand-file-name name)))
+ (when (and (member name tramp-crypt-directories)
+ (delete
+ tramp-crypt-encfs-config
+ (directory-files name nil directory-files-no-dot-files-regexp))
+ (yes-or-no-p
+ "There exist encrypted files, do you want to continue? "))
+ (setq tramp-crypt-directories (delete name tramp-crypt-directories))
+ (tramp-register-file-name-handlers)))
+
+;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form.
+(function-put
+ #'tramp-crypt-remove-directory 'completion-predicate
+ #'tramp-crypt-command-completion-p)
+
+;; `auth-source' requires a user.
+(defun tramp-crypt-dissect-file-name (name)
+ "Return a `tramp-file-name' structure for NAME.
+The structure consists of the `tramp-crypt-method' method, the
+local user name, the hexlified directory NAME as host, and the
+localname."
+ (save-match-data
+ (if-let ((dir (tramp-crypt-file-name-p name)))
+ (make-tramp-file-name
+ :method tramp-crypt-method :user (user-login-name)
+ :host (url-hexify-string dir))
+ (tramp-user-error nil "Not a crypted remote directory: \"%s\"" name))))
+
+(defun tramp-crypt-get-remote-dir (vec)
+ "Return the name of the crypted remote directory to be used for encfs."
+ (url-unhex-string (tramp-file-name-host vec)))
+
+
+;; File name primitives.
+
+(defun tramp-crypt-handle-access-file (filename string)
+ "Like `access-file' for Tramp files."
+ (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename))
+ (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'"))
+ tramp-crypt-enabled)
+ (condition-case err
+ (access-file encrypt-filename string)
+ (error
+ (when (and (eq (car err) 'file-missing) (stringp (cadr err))
+ (string-match-p encrypt-regexp (cadr err)))
+ (setcar
+ (cdr err)
+ (replace-regexp-in-string encrypt-regexp filename (cadr err))))
+ (signal (car err) (cdr err))))))
+
+(defun tramp-crypt-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "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-EXTENDED-ATTRIBUTES is ignored.
+
+This function is invoked by `tramp-crypt-handle-copy-file' and
+`tramp-crypt-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))
+
+ (setq filename (file-truename filename))
+ (let ((t1 (tramp-crypt-file-name-p filename))
+ (t2 (tramp-crypt-file-name-p newname))
+ (encrypt-filename (tramp-crypt-encrypt-file-name filename))
+ (encrypt-newname (tramp-crypt-encrypt-file-name newname))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+ (if (file-directory-p filename)
+ (progn
+ (copy-directory filename newname keep-date t)
+ (when (eq op 'rename)
+ (delete-directory filename 'recursive)))
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (unless (file-exists-p filename)
+ (tramp-compat-file-missing v filename))
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+ (when (and (file-directory-p newname)
+ (not (directory-name-p newname)))
+ (tramp-error v 'file-error "File is a directory %s" newname))
+
+ (with-tramp-progress-reporter
+ v 0 (format "%s %s to %s" msg-operation filename newname)
+ (if (and t1 t2 (string-equal t1 t2))
+ ;; Both files are on the same crypted remote directory.
+ (let (tramp-crypt-enabled)
+ (if (eq op 'copy)
+ (copy-file
+ encrypt-filename encrypt-newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes)
+ (rename-file
+ encrypt-filename encrypt-newname ok-if-already-exists)))
+
+ (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir))
+ (tmpfile1
+ (expand-file-name
+ (file-name-nondirectory encrypt-filename) tmpdir))
+ (tmpfile2
+ (expand-file-name
+ (file-name-nondirectory encrypt-newname) tmpdir))
+ tramp-crypt-enabled)
+ (cond
+ ;; Source and target file are on a crypted remote directory.
+ ((and t1 t2)
+ (if (eq op 'copy)
+ (copy-file
+ encrypt-filename encrypt-newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes)
+ (rename-file
+ encrypt-filename encrypt-newname ok-if-already-exists)))
+ ;; Source file is on a crypted remote directory.
+ (t1
+ (if (eq op 'copy)
+ (copy-file
+ encrypt-filename tmpfile1 t keep-date preserve-uid-gid
+ preserve-extended-attributes)
+ (rename-file encrypt-filename tmpfile1 t))
+ (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2)
+ (rename-file tmpfile2 newname ok-if-already-exists))
+ ;; Target file is on a crypted remote directory.
+ (t2
+ (if (eq op 'copy)
+ (copy-file
+ filename tmpfile1 t keep-date preserve-uid-gid
+ preserve-extended-attributes)
+ (rename-file filename tmpfile1 t))
+ (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2)
+ (rename-file tmpfile2 encrypt-newname ok-if-already-exists)))
+ (delete-directory tmpdir 'recursive))))))
+
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties v1 v1-localname)))
+
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-properties v2 v2-localname)))))
+
+(defun tramp-crypt-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename)
+ 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-crypt-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ (tramp-run-real-handler
+ #'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))))
+
+;; Crypted files won't be trashed.
+(defun tramp-crypt-handle-delete-directory
+ (directory &optional recursive _trash)
+ "Like `delete-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+ (tramp-flush-directory-properties v localname)
+ (let (tramp-crypt-enabled)
+ (delete-directory (tramp-crypt-encrypt-file-name directory) recursive))))
+
+;; Crypted files won't be trashed.
+(defun tramp-crypt-handle-delete-file (filename &optional _trash)
+ "Like `delete-file' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (tramp-flush-file-properties v localname)
+ (let (tramp-crypt-enabled)
+ (delete-file (tramp-crypt-encrypt-file-name filename)))))
+
+(defun tramp-crypt-handle-directory-files
+ (directory &optional full match nosort count)
+ "Like `directory-files' for Tramp files."
+ (unless (file-exists-p directory)
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (when (file-directory-p directory)
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (let* (tramp-crypt-enabled
+ (result
+ (directory-files (tramp-crypt-encrypt-file-name directory) 'full)))
+ (setq result
+ (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result))
+ (when match
+ (setq result
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (when (string-match-p match (substring x (length directory)))
+ x))
+ result))))
+ (unless full
+ (setq result
+ (mapcar
+ (lambda (x)
+ (replace-regexp-in-string
+ (concat "^" (regexp-quote directory)) "" x))
+ result)))
+ (unless nosort
+ (setq result (sort result #'string<)))
+ (when (and (natnump count) (> count 0))
+ (setq result (nbutlast result (- (length result) count))))
+ result)))
+
+(defun tramp-crypt-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-attributes (tramp-crypt-encrypt-file-name filename) id-format)))
+
+(defun tramp-crypt-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-executable-p (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-file-locked-p (filename)
+ "Like `file-locked-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-locked-p (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (all-completions
+ filename
+ (let* (completion-regexp-list
+ tramp-crypt-enabled
+ (directory (file-name-as-directory directory))
+ (enc-dir (tramp-crypt-encrypt-file-name directory)))
+ (mapcar
+ (lambda (x)
+ (substring
+ (tramp-crypt-decrypt-file-name (concat enc-dir x))
+ (length directory)))
+ (file-name-all-completions "" enc-dir)))))
+
+(defun tramp-crypt-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-readable-p (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group)
+ "Like `file-ownership-preserved-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group)))
+
+(defun tramp-crypt-handle-file-system-info (filename)
+ "Like `file-system-info' for Tramp files."
+ (let (tramp-crypt-enabled)
+ ;; `file-system-info' exists since Emacs 27.1.
+ (tramp-compat-funcall
+ 'file-system-info (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-writable-p (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for Tramp files.
+WILDCARD is not supported."
+ ;; This package has been added to Emacs 27.1.
+ (when (load "text-property-search" 'noerror 'nomessage)
+ (let (tramp-crypt-enabled)
+ (tramp-handle-insert-directory
+ (tramp-crypt-encrypt-file-name filename)
+ switches wildcard full-directory-p)
+ (let* ((filename (file-name-as-directory filename))
+ (enc (tramp-crypt-encrypt-file-name filename))
+ match string)
+ (goto-char (point-min))
+ (while (setq match (text-property-search-forward 'dired-filename t t))
+ (setq string
+ (buffer-substring
+ (prop-match-beginning match) (prop-match-end match))
+ string (if (file-name-absolute-p string)
+ (tramp-crypt-decrypt-file-name string)
+ (substring
+ (tramp-crypt-decrypt-file-name (concat enc string))
+ (length filename))))
+ (delete-region (prop-match-beginning match) (prop-match-end match))
+ (insert (propertize string 'dired-filename t)))))))
+
+(defun tramp-crypt-handle-lock-file (filename)
+ "Like `lock-file' for Tramp files."
+ (let (tramp-crypt-enabled)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall
+ 'lock-file (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name dir) nil
+ (when (and (null parents) (file-exists-p dir))
+ (tramp-error v 'file-already-exists dir))
+ (let (tramp-crypt-enabled)
+ (make-directory (tramp-crypt-encrypt-file-name dir) parents))
+ ;; When PARENTS is non-nil, DIR could be a chain of non-existent
+ ;; directories a/b/c/... Instead of checking, we simply flush the
+ ;; whole cache.
+ (tramp-flush-directory-properties
+ v (if parents "/" (file-name-directory localname)))))
+
+(defun tramp-crypt-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ (setq filename (expand-file-name filename)
+ 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-crypt-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists
+ 'keep-date 'preserve-uid-gid)
+ (tramp-run-real-handler
+ #'rename-file (list filename newname ok-if-already-exists))))
+
+(defun tramp-crypt-handle-set-file-modes (filename mode &optional flag)
+ "Like `set-file-modes' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v localname)
+ (let (tramp-crypt-enabled)
+ (tramp-compat-set-file-modes
+ (tramp-crypt-encrypt-file-name filename) mode flag))))
+
+(defun tramp-crypt-handle-set-file-times (filename &optional time flag)
+ "Like `set-file-times' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v localname)
+ (let (tramp-crypt-enabled)
+ (tramp-compat-set-file-times
+ (tramp-crypt-encrypt-file-name filename) time flag))))
+
+(defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid)
+ "Like `tramp-set-file-uid-gid' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v localname)
+ (let (tramp-crypt-enabled)
+ (tramp-set-file-uid-gid
+ (tramp-crypt-encrypt-file-name filename) uid gid))))
+
+(defun tramp-crypt-handle-unlock-file (filename)
+ "Like `unlock-file' for Tramp files."
+ (let (tramp-crypt-enabled)
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall
+ 'unlock-file (tramp-crypt-encrypt-file-name filename))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-crypt 'force)))
+
+(provide 'tramp-crypt)
+
+;;; TODO:
+
+;; * I suggest having a feature where the user can specify to always
+;; use encryption for certain host names. So if you specify a host
+;; name which is on that list (of names, or perhaps regexps?), tramp
+;; would modify the request so as to do the encryption. (Richard Stallman)
+
+;;; tramp-crypt.el ends here
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index 7ac69495afb..fa2df89e495 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -31,8 +31,6 @@
(require 'tramp)
;; Pacify byte-compiler.
-(eval-when-compile
- (require 'custom))
(defvar ange-ftp-ftp-name-arg)
(defvar ange-ftp-ftp-name-res)
(defvar ange-ftp-name-format)
@@ -79,9 +77,9 @@ present for backward compatibility."
;;; This regexp recognizes absolute filenames with only one component
;;; on Windows, for the sake of hostname completion.
(and (memq system-type '(ms-dos windows-nt))
- (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
+ (or (assoc "^[[:alpha:]]:/[^/:]*\\'" file-name-handler-alist)
(setq file-name-handler-alist
- (cons '("^[a-zA-Z]:/[^/:]*\\'" .
+ (cons '("^[:alpha:]]:/[^/:]*\\'" .
ange-ftp-completion-hook-function)
file-name-handler-alist)))))
diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el
new file mode 100644
index 00000000000..93b184a36c2
--- /dev/null
+++ b/lisp/net/tramp-fuse.el
@@ -0,0 +1,214 @@
+;;; tramp-fuse.el --- Tramp access functions for FUSE mounts -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; These are helper functions for FUSE file systems.
+
+;;; Code:
+
+(require 'tramp)
+
+;; File name primitives.
+
+(defun tramp-fuse-handle-delete-directory
+ (directory &optional recursive trash)
+ "Like `delete-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+ (tramp-flush-directory-properties v localname)
+ (delete-directory (tramp-fuse-local-file-name directory) recursive trash)))
+
+(defun tramp-fuse-handle-delete-file (filename &optional trash)
+ "Like `delete-file' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (delete-file (tramp-fuse-local-file-name filename) trash)
+ (tramp-flush-file-properties v localname)))
+
+(defun tramp-fuse-handle-directory-files
+ (directory &optional full match nosort count)
+ "Like `directory-files' for Tramp files."
+ (unless (file-exists-p directory)
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
+ (when (file-directory-p directory)
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (with-parsed-tramp-file-name directory nil
+ (let ((result
+ (tramp-compat-directory-files
+ (tramp-fuse-local-file-name directory) full match nosort count)))
+ ;; Massage the result.
+ (when full
+ (let ((local (concat "^" (regexp-quote (tramp-fuse-mount-point v))))
+ (remote (directory-file-name
+ (funcall
+ (if (tramp-compat-file-name-quoted-p directory)
+ #'tramp-compat-file-name-quote #'identity)
+ (file-remote-p directory)))))
+ (setq result
+ (mapcar
+ (lambda (x) (replace-regexp-in-string local remote x))
+ result))))
+ ;; Some storage systems do not return "." and "..".
+ (dolist (item '(".." "."))
+ (when (and (string-match-p (or match (regexp-quote item)) item)
+ (not
+ (member (if full (setq item (concat directory item)) item)
+ result)))
+ (setq result (cons item result))))
+ ;; Return result.
+ (if nosort result (sort result #'string<))))))
+
+(defun tramp-fuse-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property
+ v localname (format "file-attributes-%s" id-format)
+ (file-attributes (tramp-fuse-local-file-name filename) id-format))))
+
+(defun tramp-fuse-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property v localname "file-executable-p"
+ (file-executable-p (tramp-fuse-local-file-name filename)))))
+
+(defun tramp-fuse-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (all-completions
+ filename
+ (delete-dups
+ (append
+ (file-name-all-completions
+ filename (tramp-fuse-local-file-name directory))
+ ;; Some storage systems do not return "." and "..".
+ (let (result)
+ (dolist (item '(".." ".") result)
+ (when (string-prefix-p filename item)
+ (catch 'match
+ (dolist (elt completion-regexp-list)
+ (unless (string-match-p elt item) (throw 'match nil)))
+ (setq result (cons (concat item "/") result))))))))))
+
+(defun tramp-fuse-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-tramp-file-property v localname "file-readable-p"
+ (file-readable-p (tramp-fuse-local-file-name filename)))))
+
+;; This function isn't used.
+(defun tramp-fuse-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for Tramp files."
+ (insert-directory
+ (tramp-fuse-local-file-name filename) switches wildcard full-directory-p)
+ (goto-char (point-min))
+ (while (search-forward (tramp-fuse-local-file-name filename) nil 'noerror)
+ (replace-match filename)))
+
+(defun tramp-fuse-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name dir) nil
+ (make-directory (tramp-fuse-local-file-name dir) parents)
+ ;; When PARENTS is non-nil, DIR could be a chain of non-existent
+ ;; directories a/b/c/... Instead of checking, we simply flush the
+ ;; whole file cache.
+ (tramp-flush-file-properties v localname)
+ (tramp-flush-directory-properties
+ v (if parents "/" (file-name-directory localname)))))
+
+
+;; File name helper functions.
+
+(defun tramp-fuse-mount-spec (vec)
+ "Return local mount spec of VEC."
+ (if-let ((host (tramp-file-name-host vec))
+ (user (tramp-file-name-user vec)))
+ (format "%s@%s:/" user host)
+ (format "%s:/" host)))
+
+(defun tramp-fuse-mount-point (vec)
+ "Return local mount point of VEC."
+ (or (tramp-get-connection-property vec "mount-point" nil)
+ (expand-file-name
+ (concat
+ tramp-temp-name-prefix
+ (tramp-file-name-method vec) "."
+ (when (tramp-file-name-user vec)
+ (concat (tramp-file-name-user-domain vec) "@"))
+ (tramp-file-name-host-port vec))
+ (tramp-compat-temporary-file-directory))))
+
+(defun tramp-fuse-mounted-p (vec)
+ "Check, whether fuse volume determined by VEC is mounted."
+ (when (tramp-get-connection-process vec)
+ ;; We cannot use `with-connection-property', because we don't want
+ ;; to cache a nil result.
+ (or (tramp-get-connection-property
+ (tramp-get-connection-process vec) "mounted" nil)
+ (let* ((default-directory (tramp-compat-temporary-file-directory))
+ (command (format "mount -t fuse.%s" (tramp-file-name-method vec)))
+ (mount (shell-command-to-string command)))
+ (tramp-message vec 6 "%s\n%s" command mount)
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "mounted"
+ (when (string-match
+ (format
+ "^\\(%s\\)\\s-" (regexp-quote (tramp-fuse-mount-spec vec)))
+ mount)
+ (match-string 1 mount)))))))
+
+(defun tramp-fuse-unmount (vec)
+ "Unmount fuse volume determined by VEC."
+ (let ((default-directory (tramp-compat-temporary-file-directory))
+ (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec))))
+ (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command))
+ (tramp-flush-connection-property
+ (tramp-get-connection-process vec) "mounted")
+ ;; Give the caches a chance to expire.
+ (sleep-for 1)))
+
+(defun tramp-fuse-local-file-name (filename)
+ "Return local mount name of FILENAME."
+ (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (with-parsed-tramp-file-name filename nil
+ ;; As long as we call `tramp-*-maybe-open-connection' here,
+ ;; we cache the result.
+ (with-tramp-file-property v localname "local-file-name"
+ (funcall
+ (intern
+ (format "tramp-%s-maybe-open-connection" (tramp-file-name-method v)))
+ v)
+ (let ((quoted (tramp-compat-file-name-quoted-p localname))
+ (localname (tramp-compat-file-name-unquote localname)))
+ (funcall
+ (if quoted #'tramp-compat-file-name-quote #'identity)
+ (expand-file-name
+ (if (file-name-absolute-p localname)
+ (substring localname 1) localname)
+ (tramp-fuse-mount-point v)))))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-fuse 'force)))
+
+(provide 'tramp-fuse)
+
+;;; tramp-fuse.el ends here
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 9e26c8fd6d4..eff14a2912f 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -49,11 +49,15 @@
;; The user option `tramp-gvfs-methods' contains the list of supported
;; connection methods. Per default, these are "afp", "dav", "davs",
-;; "gdrive", "nextcloud" and "sftp".
+;; "gdrive", "mtp", "nextcloud" and "sftp".
;; "gdrive" and "nextcloud" connection methods require a respective
;; account in GNOME Online Accounts, with enabled "Files" service.
+;; The "mtp" connection method is responsible for media devices,
+;; like cell phones, tablets, cameras etc. The device must already be
+;; connected via USB, before accessing it.
+
;; Other possible connection methods are "ftp", "http", "https" and
;; "smb". When one of these methods is added to the list, the remote
;; access for that method is performed via GVFS instead of the native
@@ -104,9 +108,6 @@
(require 'url-util)
;; Pacify byte-compiler.
-(eval-when-compile
- (require 'custom))
-
(declare-function zeroconf-init "zeroconf")
(declare-function zeroconf-list-service-types "zeroconf")
(declare-function zeroconf-list-services "zeroconf")
@@ -124,16 +125,16 @@
(or ;; Until Emacs 25, `process-attributes' could crash Emacs
;; for some processes. Better we don't check.
(<= emacs-major-version 25)
- (tramp-compat-process-running-p "gvfs-fuse-daemon")
- (tramp-compat-process-running-p "gvfsd-fuse"))))
+ (tramp-process-running-p "gvfs-fuse-daemon")
+ (tramp-process-running-p "gvfsd-fuse"))))
"Non-nil when GVFS is available.")
;;;###tramp-autoload
(defcustom tramp-gvfs-methods
- '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp")
+ '("afp" "dav" "davs" "gdrive" "mtp" "nextcloud" "sftp")
"List of methods for remote files, accessed with GVFS."
:group 'tramp
- :version "27.1"
+ :version "28.1"
:type '(repeat (choice (const "afp")
(const "dav")
(const "davs")
@@ -141,10 +142,12 @@
(const "gdrive")
(const "http")
(const "https")
+ (const "mtp")
(const "nextcloud")
(const "sftp")
(const "smb"))))
+;;;###tramp-autoload
(defconst tramp-goa-methods '("gdrive" "nextcloud")
"List of methods which require registration at GNOME Online Accounts.")
@@ -154,17 +157,24 @@
(dolist (method tramp-goa-methods)
(setq tramp-gvfs-methods (delete method tramp-gvfs-methods))))
-;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'.
;;;###tramp-autoload
-(tramp--with-startup
- (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)"
- user-mail-address)
- (add-to-list 'tramp-default-user-alist
- `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address)))
- (add-to-list 'tramp-default-host-alist
- '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))))
+(defvar tramp-media-methods '("afc" "gphoto2" "mtp")
+ "List of GVFS methods which are covered by the \"mtp\" method.
+They are checked during start up via
+`tramp-gvfs-interface-remotevolumemonitor'.")
+
+(defsubst tramp-gvfs-service-volumemonitor (method)
+ "Return the well known name of the volume monitor responsible for METHOD."
+ (symbol-value
+ (intern-soft (format "tramp-gvfs-service-%s-volumemonitor" method))))
+
+;; Remove media methods if not supported.
+(when tramp-gvfs-enabled
+ (dolist (method tramp-media-methods)
+ (unless (member (tramp-gvfs-service-volumemonitor method)
+ (dbus-list-known-names :session))
+ (setq tramp-media-methods (delete method tramp-media-methods)))))
-;;;###tramp-autoload
(defcustom tramp-gvfs-zeroconf-domain "local"
"Zeroconf domain to be used for discovering services, like host names."
:group 'tramp
@@ -172,13 +182,15 @@
:type 'string)
;; Add the methods to `tramp-methods', in order to allow minibuffer
-;; completion.
+;; completion. Add defaults for `tramp-default-host-alist'.
;;;###tramp-autoload
(when (featurep 'dbusbind)
(tramp--with-startup
- (dolist (elt tramp-gvfs-methods)
- (unless (assoc elt tramp-methods)
- (add-to-list 'tramp-methods (cons elt nil))))))
+ (dolist (method tramp-gvfs-methods)
+ (unless (assoc method tramp-methods)
+ (add-to-list 'tramp-methods `(,method)))
+ (when (member method tramp-goa-methods)
+ (add-to-list 'tramp-default-host-alist `(,method nil ""))))))
(defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
"The preceding object path for own objects.")
@@ -460,8 +472,209 @@ It has been changed in GVFS 1.14.")
;; </interface>
;; The basic structure for GNOME Online Accounts. We use a list :type,
-;; in order to be compatible with Emacs 24 and 25.
-(cl-defstruct (tramp-goa-name (:type list) :named) method user host port)
+;; in order to be compatible with Emacs 25.
+(cl-defstruct (tramp-goa-account (:type list) :named) method user host port)
+
+;;;###tramp-autoload
+(defconst tramp-gvfs-service-afc-volumemonitor "org.gtk.vfs.AfcVolumeMonitor"
+ "The well known name of the AFC volume monitor.")
+
+;; This one is not needed yet.
+(defconst tramp-gvfs-service-goa-volumemonitor "org.gtk.vfs.GoaVolumeMonitor"
+ "The well known name of the GOA volume monitor.")
+
+;;;###tramp-autoload
+(defconst tramp-gvfs-service-gphoto2-volumemonitor
+ "org.gtk.vfs.GPhoto2VolumeMonitor"
+ "The well known name of the GPhoto2 volume monitor.")
+
+;;;###tramp-autoload
+(defconst tramp-gvfs-service-mtp-volumemonitor "org.gtk.vfs.MTPVolumeMonitor"
+ "The well known name of the MTP volume monitor.")
+
+(defconst tramp-gvfs-path-remotevolumemonitor
+ "/org/gtk/Private/RemoteVolumeMonitor"
+ "The object path of the remote volume monitor.")
+
+(defconst tramp-gvfs-interface-remotevolumemonitor
+ "org.gtk.Private.RemoteVolumeMonitor"
+ "The volume monitor interface.")
+
+;; <interface name='org.gtk.Private.RemoteVolumeMonitor'>
+;; <method name="IsSupported">
+;; <arg type='b' name='is_supported' direction='out'/>
+;; </method>
+;; <method name="List">
+;; <arg type='a(ssssbbbbbbbbuasa{ss}sa{sv})' name='drives' direction='out'/>
+;; <arg type='a(ssssssbbssa{ss}sa{sv})' name='volumes' direction='out'/>
+;; <arg type='a(ssssssbsassa{sv})' name='mounts' direction='out'/>
+;; </method>
+;; <method name="CancelOperation">
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='b' name='was_cancelled' direction='out'/>
+;; </method>
+;; <method name="MountUnmount">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='u' name='unmount_flags' direction='in'/>
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; </method>
+;; <method name="VolumeMount">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='u' name='mount_flags' direction='in'/>
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; </method>
+;; <method name="DriveEject">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='u' name='unmount_flags' direction='in'/>
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; </method>
+;; <method name="DrivePollForMedia">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; </method>
+;; <method name="DriveStart">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='u' name='flags' direction='in'/>
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; </method>
+;; <method name="DriveStop">
+;; <arg type='s' name='id' direction='in'/>
+;; <arg type='s' name='cancellation_id' direction='in'/>
+;; <arg type='u' name='unmount_flags' direction='in'/>
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; </method>
+;; <method name="MountOpReply">
+;; <arg type='s' name='mount_op_id' direction='in'/>
+;; <arg type='i' name='result' direction='in'/>
+;; <arg type='s' name='user_name' direction='in'/>
+;; <arg type='s' name='domain' direction='in'/>
+;; <arg type='s' name='encoded_password' direction='in'/>
+;; <arg type='i' name='password_save' direction='in'/>
+;; <arg type='i' name='choice' direction='in'/>
+;; <arg type='b' name='anonymous' direction='in'/>
+;; </method>
+;; <signal name="DriveChanged">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/>
+;; </signal>
+;; <signal name="DriveConnected">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/>
+;; </signal>
+;; <signal name="DriveDisconnected">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/>
+;; </signal>
+;; <signal name="DriveEjectButton">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/>
+;; </signal>
+;; <signal name="DriveStopButton">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/>
+;; </signal>
+;; <signal name="VolumeChanged">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/>
+;; </signal>
+;; <signal name="VolumeAdded">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/>
+;; </signal>
+;; <signal name="VolumeRemoved">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/>
+;; </signal>
+;; <signal name="MountChanged">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbsassa{sv})' name='mount'/>
+;; </signal>
+;; <signal name="MountAdded">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbsassa{sv})' name='mount'/>
+;; </signal>
+;; <signal name="MountPreUnmount">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbsassa{sv})' name='mount'/>
+;; </signal>
+;; <signal name="MountRemoved">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='(ssssssbsassa{sv})' name='mount'/>
+;; </signal>
+;; <signal name="MountOpAskPassword">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='s' name='message_to_show'/>
+;; <arg type='s' name='default_user'/>
+;; <arg type='s' name='default_domain'/>
+;; <arg type='u' name='flags'/>
+;; </signal>
+;; <signal name="MountOpAskQuestion">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='s' name='message_to_show'/>
+;; <arg type='as' name='choices'/>
+;; </signal>
+;; <signal name="MountOpShowProcesses">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='s' name='message_to_show'/>
+;; <arg type='ai' name='pid'/>
+;; <arg type='as' name='choices'/>
+;; </signal>
+;; <signal name="MountOpShowUnmountProgress">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; <arg type='s' name='message_to_show'/>
+;; <arg type='x' name='time_left'/>
+;; <arg type='x' name='bytes_left'/>
+;; </signal>
+;; <signal name="MountOpAborted">
+;; <arg type='s' name='dbus_name'/>
+;; <arg type='s' name='id'/>
+;; </signal>
+;; </interface>
+
+;; STRUCT volume
+;; STRING id
+;; STRING name
+;; STRING gicon_data
+;; STRING symbolic_gicon_data
+;; STRING uuid
+;; STRING activation_uri
+;; BOOLEAN can-mount
+;; BOOLEAN should-automount
+;; STRING drive-id
+;; STRING mount-id
+;; ARRAY identifiers
+;; DICT
+;; STRING key (unix-device, class, uuid, ...)
+;; STRING value
+;; STRING sort_key
+;; ARRAY expansion
+;; DICT
+;; STRING key (always-call-mount, is-removable, ...)
+;; VARIANT value (boolean?)
+
+;; The basic structure for media devices. We use a list :type, in
+;; order to be compatible with Emacs 25.
+(cl-defstruct (tramp-media-device (:type list) :named) method host port)
;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We
;; must use "gio <command>" tool instead.
@@ -474,37 +687,38 @@ It has been changed in GVFS 1.14.")
("gvfs-mount" . "mount")
("gvfs-move" . "move")
("gvfs-rm" . "remove")
- ("gvfs-set-attribute" . "set")
- ("gvfs-trash" . "trash"))
+ ("gvfs-set-attribute" . "set"))
"List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".")
;; <http://www.pygtk.org/docs/pygobject/gio-constants.html>
-(defconst tramp-gvfs-file-attributes
- '("name"
- "type"
- "standard::display-name"
- "standard::symlink-target"
- "standard::is-volatile"
- "unix::nlink"
- "unix::uid"
- "owner::user"
- "unix::gid"
- "owner::group"
- "time::access"
- "time::modified"
- "time::changed"
- "standard::size"
- "unix::mode"
- "access::can-read"
- "access::can-write"
- "access::can-execute"
- "unix::inode"
- "unix::device")
- "GVFS file attributes.")
-
-(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
- (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)")
- "Regexp to parse GVFS file attributes with `gvfs-ls'.")
+(eval-and-compile
+ (defconst tramp-gvfs-file-attributes
+ '("name"
+ "type"
+ "standard::display-name"
+ "standard::symlink-target"
+ "standard::is-volatile"
+ "unix::nlink"
+ "unix::uid"
+ "owner::user"
+ "unix::gid"
+ "owner::group"
+ "time::access"
+ "time::modified"
+ "time::changed"
+ "standard::size"
+ "unix::mode"
+ "access::can-read"
+ "access::can-write"
+ "access::can-execute"
+ "unix::inode"
+ "unix::device")
+ "GVFS file attributes."))
+
+(eval-and-compile
+ (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
+ (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)")
+ "Regexp to parse GVFS file attributes with `gvfs-ls'."))
(defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
(concat "^[[:blank:]]*"
@@ -560,6 +774,7 @@ It has been changed in GVFS 1.14.")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -586,9 +801,11 @@ It has been changed in GVFS 1.14.")
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-gvfs-handle-make-directory)
(make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
@@ -603,8 +820,11 @@ It has been changed in GVFS 1.14.")
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -624,14 +844,13 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
;;;###tramp-autoload
(defun tramp-gvfs-file-name-handler (operation &rest args)
"Invoke the GVFS related OPERATION and ARGS.
-First arg specifies the OPERATION, second arg is a list of arguments to
-pass to the OPERATION."
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
(unless tramp-gvfs-enabled
(tramp-user-error nil "Package `tramp-gvfs' not supported"))
- (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+ (if-let ((fn (assoc operation tramp-gvfs-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###tramp-autoload
(when (featurep 'dbusbind)
@@ -645,20 +864,19 @@ pass to the OPERATION."
(defun tramp-gvfs-dbus-string-to-byte-array (string)
"Like `dbus-string-to-byte-array' but add trailing \\0 if needed."
(dbus-string-to-byte-array
- (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature)
+ (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature)
(concat string (string 0)) string)))
(defun tramp-gvfs-dbus-byte-array-to-string (byte-array)
"Like `dbus-byte-array-to-string' but remove trailing \\0 if exists.
Return nil for null BYTE-ARRAY."
;; The byte array could be a variant. Take care.
- (let ((byte-array
- (if (and (consp byte-array) (atom (car byte-array)))
- byte-array (car byte-array))))
- (and byte-array
- (dbus-byte-array-to-string
- (if (and (consp byte-array) (zerop (car (last byte-array))))
- (butlast byte-array) byte-array)))))
+ (when-let ((byte-array
+ (if (and (consp byte-array) (atom (car byte-array)))
+ byte-array (car byte-array))))
+ (dbus-byte-array-to-string
+ (if (and (consp byte-array) (zerop (car (last byte-array))))
+ (butlast byte-array) byte-array))))
(defun tramp-gvfs-stringify-dbus-message (message)
"Convert a D-Bus MESSAGE into readable UTF8 strings, used for traces."
@@ -683,6 +901,8 @@ The call will be traced by Tramp with trace level 6."
(tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result))
result))
+(put #'tramp-dbus-function 'tramp-suppress-trace t)
+
(defmacro with-tramp-dbus-call-method
(vec synchronous bus service path interface method &rest args)
"Apply a D-Bus call on bus BUS.
@@ -692,14 +912,15 @@ it is an asynchronous call, with `ignore' as callback function.
The other arguments have the same meaning as with `dbus-call-method'
or `dbus-call-method-asynchronously'."
+ (declare (indent 2) (debug t))
`(let ((func (if ,synchronous
#'dbus-call-method #'dbus-call-method-asynchronously))
(args (append (list ,bus ,service ,path ,interface ,method)
(if ,synchronous (list ,@args) (list 'ignore ,@args)))))
- (tramp-dbus-function ,vec func args)))
+ ;; We use `dbus-ignore-errors', because this macro is also called
+ ;; when loading.
+ (dbus-ignore-errors (tramp-dbus-function ,vec func args))))
-(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\\>"))
(defmacro with-tramp-dbus-get-all-properties
@@ -707,6 +928,7 @@ or `dbus-call-method-asynchronously'."
"Return all properties of INTERFACE.
The call will be traced by Tramp with trace level 6."
;; Check, that interface exists at object path. Retrieve properties.
+ (declare (indent 1) (debug t))
`(when (member
,interface
(tramp-dbus-function
@@ -715,8 +937,6 @@ The call will be traced by Tramp with trace level 6."
(tramp-dbus-function
,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface))))
-(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1)
-(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>"))
(defvar tramp-gvfs-dbus-event-vector nil
@@ -728,13 +948,13 @@ is no information where to trace the message.")
"Called when a D-Bus error message arrives, see `dbus-event-error-functions'."
(when tramp-gvfs-dbus-event-vector
(tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event)
- (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
+ (tramp-error tramp-gvfs-dbus-event-vector 'file-error (cadr err))))
(add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error)
-(add-hook
- 'tramp-gvfs-unload-hook
- (lambda ()
- (remove-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error)))
+(add-hook 'tramp-gvfs-unload-hook
+ (lambda ()
+ (remove-hook 'dbus-event-error-functions
+ #'tramp-gvfs-dbus-event-error)))
;; File name primitives.
@@ -768,89 +988,104 @@ file names."
(let ((t1 (tramp-tramp-file-p filename))
(t2 (tramp-tramp-file-p newname))
(equal-remote (tramp-equal-remote filename newname))
+ (volatile
+ (and (eq op 'rename) (tramp-gvfs-file-name-p filename)
+ (equal
+ (cdr
+ (assoc
+ "standard::is-volatile"
+ (tramp-gvfs-get-file-attributes filename)))
+ "TRUE")))
+ ;; "gvfs-rename" is not trustworthy.
(gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move"))
(msg-operation (if (eq op 'copy) "Copying" "Renaming")))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "%s file" msg-operation "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
- (if (or (and equal-remote
- (tramp-get-connection-property v "direct-copy-failed" nil))
- (and t1 (not (tramp-gvfs-file-name-p filename)))
- (and t2 (not (tramp-gvfs-file-name-p newname))))
-
- ;; We cannot copy or rename directly.
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (if (eq op 'copy)
- (copy-file
- filename tmpfile t keep-date preserve-uid-gid
- preserve-extended-attributes)
- (rename-file filename tmpfile t))
- (rename-file tmpfile newname ok-if-already-exists))
-
- ;; Direct action.
- (with-tramp-progress-reporter
- v 0 (format "%s %s to %s" msg-operation filename newname)
- (unless
- (and (apply
- #'tramp-gvfs-send-command v gvfs-operation
- (append
- (and (eq op 'copy) (or keep-date preserve-uid-gid)
- '("--preserve"))
- (list
- (tramp-gvfs-url-file-name filename)
- (tramp-gvfs-url-file-name newname))))
- ;; Some backends do not return a proper error
- ;; code in case of direct copy/move. Apply sanity checks.
- (or (not equal-remote)
- (tramp-gvfs-send-command
- v "gvfs-info" (tramp-gvfs-url-file-name newname))
- (eq op 'copy)
- (not (tramp-gvfs-send-command
- v "gvfs-info"
- (tramp-gvfs-url-file-name filename)))))
-
- (if (or (not equal-remote)
- (and equal-remote
- (tramp-get-connection-property
- v "direct-copy-failed" nil)))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error
- "%s failed, see buffer `%s' for details."
- msg-operation (buffer-name)))
-
- ;; Some WebDAV server, like the one from QNAP, do not
- ;; support direct copy/move. Try a fallback.
- (tramp-set-connection-property v "direct-copy-failed" t)
- (tramp-gvfs-do-copy-or-rename-file
- op filename newname ok-if-already-exists keep-date
- preserve-uid-gid preserve-extended-attributes))))
-
- (when (and t1 (eq op 'rename))
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-properties v localname)))
-
- (when t2
- (with-parsed-tramp-file-name newname nil
- (tramp-flush-file-properties v localname))))))))
+ (cond
+ ;; We cannot rename volatile files, as used by Google-drive.
+ ((and (not equal-remote) volatile)
+ (prog1 (copy-file
+ filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ (delete-file filename)))
+
+ ;; We cannot copy or rename directly.
+ ((or (and equal-remote
+ (tramp-get-connection-property v "direct-copy-failed" nil))
+ (and t1 (not (tramp-gvfs-file-name-p filename)))
+ (and t2 (not (tramp-gvfs-file-name-p newname))))
+ (let ((tmpfile (tramp-compat-make-temp-file filename)))
+ (if (eq op 'copy)
+ (copy-file
+ filename tmpfile t keep-date preserve-uid-gid
+ preserve-extended-attributes)
+ (rename-file filename tmpfile t))
+ (rename-file tmpfile newname ok-if-already-exists)))
+
+ ;; Direct action.
+ (t (with-tramp-progress-reporter
+ v 0 (format "%s %s to %s" msg-operation filename newname)
+ (unless
+ (and (apply
+ #'tramp-gvfs-send-command v gvfs-operation
+ (append
+ (and (eq op 'copy) (or keep-date preserve-uid-gid)
+ '("--preserve"))
+ (list
+ (tramp-gvfs-url-file-name filename)
+ (tramp-gvfs-url-file-name newname))))
+ ;; Some backends do not return a proper error
+ ;; code in case of direct copy/move. Apply
+ ;; sanity checks.
+ (or (not equal-remote)
+ (tramp-gvfs-send-command
+ v "gvfs-info" (tramp-gvfs-url-file-name newname))
+ (eq op 'copy)
+ (not (tramp-gvfs-send-command
+ v "gvfs-info"
+ (tramp-gvfs-url-file-name filename)))))
+
+ (if (or (not equal-remote)
+ (and equal-remote
+ (tramp-get-connection-property
+ v "direct-copy-failed" nil)))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error
+ "%s failed, see buffer `%s' for details."
+ msg-operation (buffer-name)))
+
+ ;; Some WebDAV server, like the one from QNAP, do
+ ;; not support direct copy/move. Try a fallback.
+ (tramp-set-connection-property v "direct-copy-failed" t)
+ (tramp-gvfs-do-copy-or-rename-file
+ op filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes))))
+
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v localname)))
+
+ (when t2
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-properties v localname)))))))))
(defun tramp-gvfs-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
"Like `copy-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -858,30 +1093,27 @@ file names."
'copy filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
(tramp-run-real-handler
- 'copy-file
+ #'copy-file
(list filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes))))
(defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (with-parsed-tramp-file-name directory nil
+ (tramp-skeleton-delete-directory directory recursive trash
(if (and recursive (not (file-symlink-p directory)))
(mapc (lambda (file)
(if (eq t (tramp-compat-file-attribute-type
(file-attributes file)))
- (delete-directory file recursive trash)
- (delete-file file trash)))
+ (delete-directory file recursive)
+ (delete-file file)))
(directory-files
directory 'full directory-files-no-dot-files-regexp))
- (when (directory-files directory nil directory-files-no-dot-files-regexp)
+ (unless (tramp-compat-directory-empty-p directory)
(tramp-error
v 'file-error "Couldn't delete non-empty %s" directory)))
- (tramp-flush-directory-properties v localname)
- (unless
- (tramp-gvfs-send-command
- v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
- (tramp-gvfs-url-file-name directory))
+ (unless (tramp-gvfs-send-command
+ v "gvfs-rm" (tramp-gvfs-url-file-name directory))
;; Propagate the error.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
@@ -892,15 +1124,15 @@ file names."
"Like `delete-file' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
- (unless
- (tramp-gvfs-send-command
- v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm")
- (tramp-gvfs-url-file-name filename))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error "Couldn't delete %s" filename)))))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash filename)
+ (unless (tramp-gvfs-send-command
+ v "gvfs-rm" (tramp-gvfs-url-file-name filename))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error "Couldn't delete %s" filename))))))
(defun tramp-gvfs-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
@@ -910,7 +1142,7 @@ file names."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -943,6 +1175,9 @@ file names."
;; There might be a double slash. Remove this.
(while (string-match "//" localname)
(setq localname (replace-match "/" t t localname)))
+ ;; Do not keep "/..".
+ (when (string-match-p "^/\\.\\.?$" localname)
+ (setq localname "/"))
;; No tilde characters in file name, do normal
;; `expand-file-name' (this does "/./" and "/../").
(tramp-make-tramp-file-name
@@ -966,10 +1201,11 @@ file names."
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(while (looking-at
- (concat "^\\(.+\\)[[:blank:]]"
- "\\([[:digit:]]+\\)[[:blank:]]"
- "(\\(.+?\\))"
- tramp-gvfs-file-attributes-with-gvfs-ls-regexp))
+ (eval-when-compile
+ (concat "^\\(.+\\)[[:blank:]]"
+ "\\([[:digit:]]+\\)[[:blank:]]"
+ "(\\(.+?\\))"
+ tramp-gvfs-file-attributes-with-gvfs-ls-regexp)))
(let ((item (list (cons "type" (match-string 3))
(cons "standard::size" (match-string 2))
(cons "name" (match-string 1)))))
@@ -1070,8 +1306,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::uid" attributes))
- (eval-when-compile
- (format "%s" tramp-unknown-id-integer))))
+ (eval-when-compile (format "%s" tramp-unknown-id-integer))))
(or (cdr (assoc "owner::user" attributes))
(cdr (assoc "unix::uid" attributes))
tramp-unknown-id-string)))
@@ -1079,8 +1314,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (eq id-format 'integer)
(string-to-number
(or (cdr (assoc "unix::gid" attributes))
- (eval-when-compile
- (format "%s" tramp-unknown-id-integer))))
+ (eval-when-compile (format "%s" tramp-unknown-id-integer))))
(or (cdr (assoc "owner::group" attributes))
(cdr (assoc "unix::gid" attributes))
tramp-unknown-id-string)))
@@ -1220,6 +1454,9 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(unless (process-live-p p)
(tramp-error
p 'file-notify-error "Monitoring not supported for `%s'" file-name))
+ ;; Set "gio-file-monitor" property. We believe, that "gio
+ ;; monitor" uses polling when applied for mounted files.
+ (tramp-set-connection-property p "gio-file-monitor" 'GPollFileMonitor)
p))))
(defun tramp-gvfs-monitor-process-filter (proc string)
@@ -1234,11 +1471,11 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(tramp-message proc 6 "%S\n%s" proc string)
(setq string (concat rest-string string)
;; Fix action names.
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"attributes changed" "attribute-changed" string)
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"changes done" "changes-done-hint" string)
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"renamed to" "moved" string))
;; https://bugs.launchpad.net/bugs/1742946
(when
@@ -1260,11 +1497,11 @@ If FILE-SYSTEM is non-nil, return file system attributes."
;; File names are returned as URL paths. We must convert them.
(when (string-match ddu file)
(setq file (replace-match dd nil nil file)))
- (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file)
+ (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" file)
(setq file (url-unhex-string file)))
(when (string-match ddu (or file1 ""))
(setq file1 (replace-match dd nil nil file1)))
- (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 ""))
+ (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" (or file1 ""))
(setq file1 (url-unhex-string file1)))
;; Remove watch when file or directory to be watched is deleted.
(when (and (member action '(moved deleted))
@@ -1297,7 +1534,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
;; If the user is different from what we guess to be
;; the user, we don't know. Let's check, whether
;; access is restricted explicitly.
- (and (/= (tramp-gvfs-get-remote-uid v 'integer)
+ (and (/= (tramp-get-remote-uid v 'integer)
(tramp-compat-file-attribute-user-id
(file-attributes filename 'integer)))
(not
@@ -1328,7 +1565,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(setq dir (directory-file-name (expand-file-name dir)))
(with-parsed-tramp-file-name dir nil
(when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists "Directory already exists %s" dir))
+ (tramp-error v 'file-already-exists dir))
(tramp-flush-directory-properties v localname)
(save-match-data
(let ((ldir (file-name-directory dir)))
@@ -1347,8 +1584,8 @@ If FILE-SYSTEM is non-nil, return file system attributes."
"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))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -1358,78 +1595,125 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(tramp-run-real-handler
#'rename-file (list filename newname ok-if-already-exists))))
-(defun tramp-gvfs-handle-set-file-modes (filename mode &optional _flag)
+(defun tramp-gvfs-set-attribute (vec &rest args)
+ "Call \"gio set ...\" if possible."
+ (let ((key (concat "gvfs-set-attribute-" (nth 3 args))))
+ (when (tramp-get-connection-property vec key t)
+ (or (apply #'tramp-gvfs-send-command vec "gvfs-set-attribute" args)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (goto-char (point-min))
+ (when (looking-at-p "gio: Operation not supported")
+ (tramp-set-connection-property vec key nil)))
+ nil))))
+
+(defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
- (tramp-gvfs-send-command
- v "gvfs-set-attribute" "-t" "uint32"
- (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v))
- "unix::mode" (number-to-string mode))))
+ (tramp-gvfs-set-attribute
+ v (if (eq flag 'nofollow) "-nt" "-t") "uint32"
+ (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode))))
-(defun tramp-gvfs-handle-set-file-times (filename &optional time _flag)
+(defun tramp-gvfs-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
- (let ((time
- (if (or (null time)
+ (tramp-gvfs-set-attribute
+ v (if (eq flag 'nofollow) "-nt" "-t") "uint64"
+ (tramp-gvfs-url-file-name filename) "time::modified"
+ (format-time-string
+ "%s" (if (or (null time)
(tramp-compat-time-equal-p time tramp-time-doesnt-exist)
(tramp-compat-time-equal-p time tramp-time-dont-know))
(current-time)
- time)))
- (tramp-gvfs-send-command
- v "gvfs-set-attribute" "-t" "uint64"
- (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v))
- "time::modified" (format-time-string "%s" time)))))
+ time)))))
-(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid)
+(defun tramp-gvfs-handle-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (if (equal id-format 'string)
+ (tramp-file-name-user vec)
+ (when-let ((localname
+ (tramp-get-connection-property
+ (tramp-get-process vec) "share"
+ (tramp-get-connection-property vec "default-location" nil))))
+ (tramp-compat-file-attribute-user-id
+ (file-attributes
+ (tramp-make-tramp-file-name vec localname) id-format)))))
+
+(defun tramp-gvfs-handle-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (when-let ((localname
+ (tramp-get-connection-property
+ (tramp-get-process vec) "share"
+ (tramp-get-connection-property vec "default-location" nil))))
+ (tramp-compat-file-attribute-group-id
+ (file-attributes
+ (tramp-make-tramp-file-name vec localname) id-format))))
+
+(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
(when (natnump uid)
- (tramp-gvfs-send-command
- v "gvfs-set-attribute" "-t" "uint32"
- (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v))
- "unix::uid" (number-to-string uid)))
+ (tramp-gvfs-set-attribute
+ v "-t" "uint32"
+ (tramp-gvfs-url-file-name filename) "unix::uid" (number-to-string uid)))
(when (natnump gid)
- (tramp-gvfs-send-command
- v "gvfs-set-attribute" "-t" "uint32"
- (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v))
+ (tramp-gvfs-set-attribute
+ v "-t" "uint32"
+ (tramp-gvfs-url-file-name filename)
"unix::gid" (number-to-string gid)))))
;; File name conversions.
+(defun tramp-gvfs-activation-uri (filename)
+ "Return activation URI to be used in gio commands."
+ (if (tramp-tramp-file-p filename)
+ (with-parsed-tramp-file-name filename nil
+ ;; Ensure that media devices are cached.
+ (when (string-equal method "mtp")
+ (tramp-get-media-device v))
+ (with-tramp-connection-property v "activation-uri"
+ (setq localname "/")
+ (when (string-equal "gdrive" method)
+ (setq method "google-drive"))
+ (when (string-equal "nextcloud" method)
+ (setq method "davs"
+ localname
+ (concat (tramp-gvfs-get-remote-prefix v) localname)))
+ (when (string-equal "mtp" method)
+ (when-let
+ ((media (tramp-get-connection-property v "media-device" nil)))
+ (setq method (tramp-media-device-method media)
+ host (tramp-media-device-host media)
+ port (tramp-media-device-port media))))
+ (when (and user domain)
+ (setq user (concat domain ";" user)))
+ (url-recreate-url
+ (url-parse-make-urlobj
+ method (and user (url-hexify-string user))
+ nil (and host (url-hexify-string host))
+ (if (stringp port) (string-to-number port) port)
+ localname nil nil t))))
+ ;; Local URI.
+ (url-recreate-url
+ (url-parse-make-urlobj "file" nil nil nil nil nil nil nil t))))
+
(defun tramp-gvfs-url-file-name (filename)
"Return FILENAME in URL syntax."
- ;; "/" must NOT be hexified.
(setq filename (tramp-compat-file-name-unquote filename))
- (let ((url-unreserved-chars (cons ?/ url-unreserved-chars))
- result)
- (setq
- result
- (url-recreate-url
- (if (tramp-tramp-file-p filename)
- (with-parsed-tramp-file-name filename nil
- (when (string-equal "gdrive" method)
- (setq method "google-drive"))
- (when (string-equal "nextcloud" method)
- (setq method "davs"
- localname
- (concat (tramp-gvfs-get-remote-prefix v) localname)))
- (when (and user domain)
- (setq user (concat domain ";" user)))
- (url-parse-make-urlobj
- method (and user (url-hexify-string user))
- nil (and host (url-hexify-string host))
- (if (stringp port) (string-to-number port) port)
- (and localname (url-hexify-string localname)) nil nil t))
- (url-parse-make-urlobj
- "file" nil nil nil nil
- (url-hexify-string (file-truename filename)) nil nil t))))
+ (let* (;; "/" must NOT be hexified.
+ (url-unreserved-chars (cons ?/ url-unreserved-chars))
+ (result
+ (concat (substring (tramp-gvfs-activation-uri filename) 0 -1)
+ (url-hexify-string (tramp-file-local-name filename)))))
(when (tramp-tramp-file-p filename)
- (with-parsed-tramp-file-name filename nil
- (tramp-message v 10 "remote file `%s' is URL `%s'" filename result)))
+ (tramp-message
+ (tramp-dissect-file-name filename) 10
+ "remote file `%s' is URL `%s'" filename result))
result))
(defun tramp-gvfs-object-path (filename)
@@ -1441,6 +1725,14 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(dbus-unescape-from-identifier
(replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path)))
+(defun tramp-gvfs-url-host (url)
+ "Return the host name part of URL, a string.
+We cannot use `url-host', because `url-generic-parse-url' returns
+a downcased host name only."
+ (and (stringp url)
+ (string-match "^[[:alnum:]]+://\\([^/:]+\\)" url)
+ (match-string 1 url)))
+
;; D-Bus GVFS functions.
@@ -1507,8 +1799,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(list
t ;; handled.
nil ;; no abort of D-Bus.
- (with-tramp-connection-property
- (tramp-get-connection-process v) message
+ (with-tramp-connection-property (tramp-get-process v) message
;; In theory, there can be several choices.
;; Until now, there is only the question whether
;; to accept an unknown host signature or certificate.
@@ -1581,11 +1872,22 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(when (string-equal "google-drive" method)
(setq method "gdrive"))
(when (and (string-equal "http" method) (stringp uri))
- (setq uri (url-generic-parse-url uri)
+ (setq host (tramp-gvfs-url-host uri)
+ uri (url-generic-parse-url uri)
method (url-type uri)
user (url-user uri)
- host (url-host uri)
port (url-portspec uri)))
+ (when (member method tramp-media-methods)
+ ;; Ensure that media devices are cached.
+ (tramp-get-media-devices nil)
+ (let ((v (tramp-get-connection-property
+ (make-tramp-media-device
+ :method method :host host :port port)
+ "vector" nil)))
+ (when v
+ (setq method (tramp-file-name-method v)
+ host (tramp-file-name-host v)
+ port (tramp-file-name-port v)))))
(when (member method tramp-gvfs-methods)
(with-parsed-tramp-file-name
(tramp-make-tramp-file-name method user domain host port "") nil
@@ -1671,11 +1973,22 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(when (string-equal "google-drive" method)
(setq method "gdrive"))
(when (and (string-equal "http" method) (stringp uri))
- (setq uri (url-generic-parse-url uri)
+ (setq host (tramp-gvfs-url-host uri)
+ uri (url-generic-parse-url uri)
method (url-type uri)
user (url-user uri)
- host (url-host uri)
port (url-portspec uri)))
+ (when (member method tramp-media-methods)
+ ;; Ensure that media devices are cached.
+ (tramp-get-media-devices vec)
+ (let ((v (tramp-get-connection-property
+ (make-tramp-media-device
+ :method method :host host :port port)
+ "vector" nil)))
+ (when v
+ (setq method (tramp-file-name-method v)
+ host (tramp-file-name-host v)
+ port (tramp-file-name-port v)))))
(when (and
(string-equal method (tramp-file-name-method vec))
(string-equal user (tramp-file-name-user vec))
@@ -1688,6 +2001,9 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
(tramp-set-connection-property
vec "default-location" default-location)
+ (when share
+ (tramp-set-connection-property
+ (tramp-get-process vec) "share" (concat "/" share)))
(throw 'mounted t)))))))
(defun tramp-gvfs-unmount (vec)
@@ -1700,8 +2016,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))
(while (tramp-gvfs-connection-mounted-p vec)
(read-event nil nil 0.1))
- (tramp-flush-connection-properties vec)
- (tramp-flush-connection-properties (tramp-get-connection-process vec)))
+ (tramp-cleanup-connection vec 'keep-debug 'keep-password))
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
@@ -1713,11 +2028,16 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(defun tramp-gvfs-mount-spec (vec)
"Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"."
- (let* ((method (tramp-file-name-method vec))
+ (let* ((media (tramp-get-media-device vec))
+ (method (if media
+ (tramp-media-device-method media)
+ (tramp-file-name-method vec)))
(user (tramp-file-name-user vec))
(domain (tramp-file-name-domain vec))
- (host (tramp-file-name-host vec))
- (port (tramp-file-name-port vec))
+ (host (if media
+ (tramp-media-device-host media) (tramp-file-name-host vec)))
+ (port (if media
+ (tramp-media-device-port media) (tramp-file-name-port vec)))
(localname (tramp-file-name-unquote-localname vec))
(share (when (string-match "^/?\\([^/]+\\)" localname)
(match-string 1 localname)))
@@ -1768,42 +2088,41 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
;; Return.
`(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec)))
+(defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume)
+ "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \
+and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals."
+ (ignore-errors
+ (let* ((signal-name (dbus-event-member-name last-input-event))
+ (uri (url-generic-parse-url (nth 5 volume)))
+ (method (url-type uri))
+ (vec (make-tramp-file-name
+ :method "mtp"
+ ;; A host name cannot contain spaces.
+ :host (tramp-compat-string-replace " " "_" (nth 1 volume))))
+ (media (make-tramp-media-device
+ :method method
+ :host (tramp-gvfs-url-host (nth 5 volume))
+ :port (and (url-portspec uri)))))
+ (when (member method tramp-media-methods)
+ (tramp-message
+ vec 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message volume))
+ (tramp-flush-connection-properties vec)
+ (tramp-flush-connection-properties media)
+ (tramp-get-media-devices nil)))))
+
+(when tramp-gvfs-enabled
+ (dbus-register-signal
+ :session nil tramp-gvfs-path-remotevolumemonitor
+ tramp-gvfs-interface-remotevolumemonitor "VolumeAdded"
+ #'tramp-gvfs-handler-volumeadded-volumeremoved)
+ (dbus-register-signal
+ :session nil tramp-gvfs-path-remotevolumemonitor
+ tramp-gvfs-interface-remotevolumemonitor "VolumeRemoved"
+ #'tramp-gvfs-handler-volumeadded-volumeremoved))
+
;; Connection functions.
-(defun tramp-gvfs-get-remote-uid (vec id-format)
- "The uid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (let ((user (tramp-file-name-user vec))
- (localname
- (tramp-get-connection-property vec "default-location" nil)))
- (cond
- ((and (equal id-format 'string) user))
- (localname
- (tramp-compat-file-attribute-user-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format)))
- ((equal id-format 'integer) tramp-unknown-id-integer)
- ((equal id-format 'string) tramp-unknown-id-string)))))
-
-(defun tramp-gvfs-get-remote-gid (vec id-format)
- "The gid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (let ((localname
- (tramp-get-connection-property vec "default-location" nil)))
- (cond
- (localname
- (tramp-compat-file-attribute-group-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format)))
- ((equal id-format 'integer) tramp-unknown-id-integer)
- ((equal id-format 'string) tramp-unknown-id-string)))))
-
-(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil
- "Indication, that remote uid and gid determination is in progress.")
-
(defun tramp-gvfs-get-remote-prefix (vec)
"The prefix of the remote connection VEC.
This is relevant for GNOME Online Accounts."
@@ -1811,7 +2130,7 @@ This is relevant for GNOME Online Accounts."
;; Ensure that GNOME Online Accounts are cached.
(when (member (tramp-file-name-method vec) tramp-goa-methods)
(tramp-get-goa-accounts vec))
- (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/")))
+ (tramp-get-connection-property (tramp-get-goa-account vec) "prefix" "/")))
(defun tramp-gvfs-maybe-open-connection (vec)
"Maybe open a connection VEC.
@@ -1834,7 +2153,13 @@ connection if a previous connection has died for some reason."
:buffer (tramp-get-connection-buffer vec)
:server t :host 'local :service t :noquery t)))
(process-put p 'vector vec)
- (set-process-query-on-exit-flag p nil)))
+ (set-process-query-on-exit-flag p nil)
+
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)))
(unless (tramp-gvfs-connection-mounted-p vec)
(let ((method (tramp-file-name-method vec))
@@ -1860,7 +2185,7 @@ connection if a previous connection has died for some reason."
;; Ensure that GNOME Online Accounts are cached.
(tramp-get-goa-accounts vec)
(when (tramp-get-connection-property
- (tramp-make-goa-name vec) "FilesDisabled" t)
+ (tramp-get-goa-account vec) "FilesDisabled" t)
(tramp-user-error
vec "There is no Online Account `%s'"
(tramp-make-tramp-file-name vec 'noloc))))
@@ -1938,21 +2263,9 @@ connection if a previous connection has died for some reason."
(and (functionp tramp-password-save-function)
(funcall tramp-password-save-function)))
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
;; Mark it as connected.
(tramp-set-connection-property
- (tramp-get-connection-process vec) "connected" t))))
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (unless tramp-gvfs-get-remote-uid-gid-in-progress
- (let ((tramp-gvfs-get-remote-uid-gid-in-progress t))
- (tramp-gvfs-get-remote-uid vec 'integer)
- (tramp-gvfs-get-remote-gid vec 'integer)
- (tramp-gvfs-get-remote-uid vec 'string)
- (tramp-gvfs-get-remote-gid vec 'string))))
+ (tramp-get-connection-process vec) "connected" t)))))
(defun tramp-gvfs-gio-tool-p (vec)
"Check, whether the gio tool is available."
@@ -1985,12 +2298,12 @@ is applied, and it returns t if the return code is zero."
(and (tramp-flush-file-properties vec "/") nil)))))
-;; D-Bus GNOME Online Accounts functions.
+;; GNOME Online Accounts functions.
-(defun tramp-make-goa-name (vec)
- "Transform VEC into a `tramp-goa-name' structure."
+(defun tramp-get-goa-account (vec)
+ "Transform VEC into a `tramp-goa-account' structure."
(when (tramp-file-name-p vec)
- (make-tramp-goa-name
+ (make-tramp-goa-account
:method (tramp-file-name-method vec)
:user (tramp-file-name-user vec)
:host (tramp-file-name-host vec)
@@ -1998,12 +2311,12 @@ is applied, and it returns t if the return code is zero."
(defun tramp-get-goa-accounts (vec)
"Retrieve GNOME Online Accounts, and cache them.
-The hash key is a `tramp-goa-name' structure. The value is an
+The hash key is a `tramp-goa-account' structure. The value is an
alist of the properties of `tramp-goa-interface-account' and
-`tramp-goa-interface-files' of the corresponding GNOME online
-account. Additionally, a property \"prefix\" is added.
+`tramp-goa-interface-files' of the corresponding GNOME Online
+Account. Additionally, a property \"prefix\" is added.
VEC is used only for traces."
- (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts"
+ (with-tramp-connection-property nil "goa-accounts"
(dolist
(object-path
(mapcar
@@ -2029,15 +2342,15 @@ VEC is used only for traces."
(cdr (assoc "ProviderType" account-properties))
'("google" "owncloud"))
(string-match tramp-goa-identity-regexp identity))
- (setq key (make-tramp-goa-name
+ (setq key (make-tramp-goa-account
:method (cdr (assoc "ProviderType" account-properties))
:user (match-string 1 identity)
:host (match-string 2 identity)
:port (match-string 3 identity)))
- (when (string-equal (tramp-goa-name-method key) "google")
- (setf (tramp-goa-name-method key) "gdrive"))
- (when (string-equal (tramp-goa-name-method key) "owncloud")
- (setf (tramp-goa-name-method key) "nextcloud"))
+ (when (string-equal (tramp-goa-account-method key) "google")
+ (setf (tramp-goa-account-method key) "gdrive"))
+ (when (string-equal (tramp-goa-account-method key) "owncloud")
+ (setf (tramp-goa-account-method key) "nextcloud"))
;; Cache all properties.
(dolist (prop (nconc account-properties files-properties))
(tramp-set-connection-property key (car prop) (cdr prop)))
@@ -2053,6 +2366,80 @@ VEC is used only for traces."
;; Mark, that goa accounts have been cached.
"cached"))
+(defun tramp-parse-goa-accounts (service)
+ "Return a list of (user host) tuples allowed to access.
+It checks for registered GNOME Online Accounts."
+ ;; SERVICE might be encoded as a DNS-SD service.
+ (and (string-match tramp-dns-sd-service-regexp service)
+ (setq service (match-string 1 service)))
+ (mapcar
+ (lambda (key)
+ (and (tramp-goa-account-p key)
+ (string-equal service (tramp-goa-account-method key))
+ (list (tramp-goa-account-user key)
+ (tramp-goa-account-host key))))
+ (hash-table-keys tramp-cache-data)))
+
+
+;; Media devices functions.
+
+(defun tramp-get-media-device (vec)
+ "Transform VEC into a `tramp-media-device' structure.
+Check, that respective cache values do exist."
+ (if-let ((media (tramp-get-connection-property vec "media-device" nil))
+ (prop (tramp-get-connection-property media "vector" nil)))
+ media
+ (tramp-get-media-devices vec)
+ (tramp-get-connection-property vec "media-device" nil)))
+
+(defun tramp-get-media-devices (vec)
+ "Retrieve media devices, and cache them.
+The hash key is a `tramp-media-device' structure.
+VEC is used only for traces."
+ (let (devices)
+ (dolist (method tramp-media-methods)
+ (dolist (volume (cadr (with-tramp-dbus-call-method vec t
+ :session (tramp-gvfs-service-volumemonitor method)
+ tramp-gvfs-path-remotevolumemonitor
+ tramp-gvfs-interface-remotevolumemonitor "List")))
+ (let* ((uri (url-generic-parse-url (nth 5 volume)))
+ (vec (make-tramp-file-name
+ :method "mtp"
+ ;; A host name cannot contain spaces.
+ :host (tramp-compat-string-replace " " "_" (nth 1 volume))))
+ (media (make-tramp-media-device
+ :method method
+ :host (tramp-gvfs-url-host (nth 5 volume))
+ :port (and (url-portspec uri)
+ (number-to-string (url-portspec uri))))))
+ (push (tramp-file-name-host vec) devices)
+ (tramp-set-connection-property vec "activation-uri" (nth 5 volume))
+ (tramp-set-connection-property vec "media-device" media)
+ (tramp-set-connection-property media "vector" vec))))
+
+ ;; Adapt default host name, supporting /mtp:: when possible.
+ (setq tramp-default-host-alist
+ (append
+ `(("mtp" nil ,(if (= (length devices) 1) (car devices) "")))
+ (delete
+ (assoc "mtp" tramp-default-host-alist)
+ tramp-default-host-alist)))))
+
+(defun tramp-parse-media-names (service)
+ "Return a list of (user host) tuples allowed to access.
+It checks for mounted media devices."
+ ;; SERVICE might be encoded as a DNS-SD service.
+ (and (string-match tramp-dns-sd-service-regexp service)
+ (setq service (match-string 1 service)))
+ (mapcar
+ (lambda (key)
+ (and (tramp-media-device-p key)
+ (string-equal service (tramp-media-device-method key))
+ (tramp-get-connection-property key "vector" nil)
+ (list nil (tramp-file-name-host
+ (tramp-get-connection-property key "vector" nil)))))
+ (hash-table-keys tramp-cache-data)))
+
;; D-Bus zeroconf functions.
@@ -2097,42 +2484,65 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
(list user host)))
result))))
-;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods.
(when tramp-gvfs-enabled
- ;; Suppress D-Bus error messages.
- (let (tramp-gvfs-dbus-event-vector
- ;; Sometimes, it fails with "Variable binding depth exceeds
+ ;; Suppress D-Bus error messages and Tramp traces.
+ (let (;; Sometimes, it fails with "Variable binding depth exceeds
;; max-specpdl-size". Shall be fixed in Emacs 27.
- (max-specpdl-size (* 2 max-specpdl-size)))
+ (max-specpdl-size (* 2 max-specpdl-size))
+ (tramp-verbose 0)
+ tramp-gvfs-dbus-event-vector fun)
+ ;; Add completion functions for services announced by DNS-SD.
+ ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types.
(zeroconf-init tramp-gvfs-zeroconf-domain)
- (if (zeroconf-list-service-types)
- (progn
- (tramp-set-completion-function
- "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp")))
- (tramp-set-completion-function
- "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
- (tramp-set-completion-function
- "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp")))
- (tramp-set-completion-function
- "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp")
- (tramp-zeroconf-parse-device-names "_workstation._tcp")))
- (when (member "smb" tramp-gvfs-methods)
- (tramp-set-completion-function
- "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp")))))
-
- (when (executable-find "avahi-browse")
+ (when (setq fun (or (and (zeroconf-list-service-types)
+ #'tramp-zeroconf-parse-device-names)
+ (and (executable-find "avahi-browse")
+ #'tramp-gvfs-parse-device-names)))
+ (when (member "afp" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "afp" `((,fun "_afpovertcp._tcp"))))
+ (when (member "dav" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "dav" `((,fun "_webdav._tcp")
+ (,fun "_webdavs._tcp"))))
+ (when (member "davs" tramp-gvfs-methods)
(tramp-set-completion-function
- "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp")))
+ "davs" `((,fun "_webdav._tcp")
+ (,fun "_webdavs._tcp"))))
+ (when (member "ftp" tramp-gvfs-methods)
(tramp-set-completion-function
- "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
+ "ftp" `((,fun "_ftp._tcp"))))
+ (when (member "http" tramp-gvfs-methods)
(tramp-set-completion-function
- "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp")))
+ "http" `((,fun "_http._tcp")
+ (,fun "_https._tcp"))))
+ (when (member "https" tramp-gvfs-methods)
(tramp-set-completion-function
- "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp")
- (tramp-gvfs-parse-device-names "_workstation._tcp")))
- (when (member "smb" tramp-gvfs-methods)
- (tramp-set-completion-function
- "smb" '((tramp-gvfs-parse-device-names "_smb._tcp"))))))))
+ "https" `((,fun "_http._tcp")
+ (,fun "_https._tcp"))))
+ (when (member "sftp" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "sftp" `((,fun "_sftp-ssh._tcp")
+ (,fun "_ssh._tcp")
+ (,fun "_workstation._tcp"))))
+ (when (member "smb" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "smb" `((,fun "_smb._tcp")))))
+
+ ;; Add completion functions for GNOME Online Accounts.
+ (tramp-get-goa-accounts nil)
+ (dolist (method tramp-goa-methods)
+ (when (member method tramp-gvfs-methods)
+ (tramp-set-completion-function
+ method `((tramp-parse-goa-accounts ,(format "_%s._tcp" method))))))
+
+ ;; Add completion functions for media devices.
+ (tramp-get-media-devices nil)
+ (tramp-set-completion-function
+ "mtp"
+ (mapcar
+ (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method)))
+ tramp-media-methods))))
(add-hook 'tramp-unload-hook
(lambda ()
@@ -2145,7 +2555,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el.
;;
;; * Host name completion for existing mount points (afp-server,
-;; smb-server, google-drive, nextcloud) or via smb-network or network.
+;; smb-server) or via smb-network or network.
;;
;; * Check, how two shares of the same SMB server can be mounted in
;; parallel.
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index d43081e27e1..17264193fd6 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -42,6 +42,8 @@
(declare-function tramp-dissect-file-name "tramp")
(declare-function tramp-file-name-equal-p "tramp")
(declare-function tramp-tramp-file-p "tramp")
+(declare-function tramp-rename-files "tramp-cmds")
+(declare-function tramp-rename-these-files "tramp-cmds")
(defvar eshell-path-env)
(defvar ido-read-file-name-non-ido)
(defvar info-lookup-alist)
@@ -49,6 +51,7 @@
(defvar recentf-exclude)
(defvar tramp-current-connection)
(defvar tramp-postfix-host-format)
+(defvar tramp-use-ssh-controlmaster-options)
;;; Fontification of `read-file-name':
@@ -183,14 +186,14 @@ NAME must be equal to `tramp-current-connection'."
;;; Integration of ido.el:
(with-eval-after-load 'ido
- (add-to-list 'ido-read-file-name-non-ido 'tramp-rename-files)
- (add-to-list 'ido-read-file-name-non-ido 'tramp-these-rename-files)
+ (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-files)
+ (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-these-files)
(add-hook 'tramp-integration-unload-hook
(lambda ()
(setq ido-read-file-name-non-ido
- (delq 'tramp-these-rename-files ido-read-file-name-non-ido)
+ (delq #'tramp-rename-these-files ido-read-file-name-non-ido)
ido-read-file-name-non-ido
- (delq 'tramp-rename-files ido-read-file-name-non-ido)))))
+ (delq #'tramp-rename-files ido-read-file-name-non-ido)))))
;;; Integration of ivy.el:
@@ -198,17 +201,17 @@ NAME must be equal to `tramp-current-connection'."
(add-to-list 'ivy-completing-read-handlers-alist
'(tramp-rename-files . completing-read-default))
(add-to-list 'ivy-completing-read-handlers-alist
- '(tramp-these-rename-files . completing-read-default))
+ '(tramp-rename-these-files . completing-read-default))
(add-hook
'tramp-integration-unload-hook
(lambda ()
(setq ivy-completing-read-handlers-alist
(delete
- (assq 'tramp-these-rename-files ivy-completing-read-handlers-alist)
+ (assq #'tramp-rename-these-files ivy-completing-read-handlers-alist)
ivy-completing-read-handlers-alist)
ivy-completing-read-handlers-alist
(delete
- (assq 'tramp-rename-files ivy-completing-read-handlers-alist)
+ (assq #'tramp-rename-files ivy-completing-read-handlers-alist)
ivy-completing-read-handlers-alist)))))
;;; Integration of info-look.el:
@@ -231,7 +234,7 @@ NAME must be equal to `tramp-current-connection'."
(delete (info-lookup->mode-cache 'symbol 'tramp-info-lookup-mode)
(info-lookup->topic-cache 'symbol)))))
- (dolist (mode (mapcar 'car (info-lookup->topic-value 'symbol)))
+ (dolist (mode (mapcar #'car (info-lookup->topic-value 'symbol)))
;; Add `tramp-info-lookup-mode' to `other-modes' for either
;; `emacs-lisp-mode' itself, or to modes which use
;; `emacs-lisp-mode' as `other-modes'. Reset `info-lookup-cache'.
@@ -261,24 +264,57 @@ NAME must be equal to `tramp-current-connection'."
(delete (info-lookup->mode-cache 'symbol ',mode)
(info-lookup->topic-cache 'symbol))))))))
+;;; Integration of compile.el:
+
+;; Compilation processes use `accept-process-output' such a way that
+;; Tramp's parallel `accept-process-output' blocks. See last part of
+;; Bug#45518. So we don't use ssh ControlMaster options.
+(defun tramp-compile-disable-ssh-controlmaster-options ()
+ "Don't allow ssh ControlMaster while compiling."
+ (setq-local tramp-use-ssh-controlmaster-options nil))
+
+(with-eval-after-load 'compile
+ (add-hook 'compilation-mode-hook
+ #'tramp-compile-disable-ssh-controlmaster-options)
+ (add-hook 'tramp-integration-unload-hook
+ (lambda ()
+ (remove-hook 'compilation-start-hook
+ #'tramp-compile-disable-ssh-controlmaster-options))))
+
;;; Default connection-local variables for Tramp:
+;; `connection-local-set-profile-variables' and
+;; `connection-local-set-profiles' exists since Emacs 26.1.
-(defconst tramp-connection-local-default-profile
+(defconst tramp-connection-local-default-system-variables
+ '((path-separator . ":")
+ (null-device . "/dev/null"))
+ "Default connection-local system variables for remote connections.")
+
+(tramp-compat-funcall
+ 'connection-local-set-profile-variables
+ 'tramp-connection-local-default-system-profile
+ tramp-connection-local-default-system-variables)
+
+(tramp-compat-funcall
+ 'connection-local-set-profiles
+ '(:application tramp)
+ 'tramp-connection-local-default-system-profile)
+
+(defconst tramp-connection-local-default-shell-variables
'((shell-file-name . "/bin/sh")
(shell-command-switch . "-c"))
- "Default connection-local variables for remote connections.")
+ "Default connection-local shell variables for remote connections.")
+
+(tramp-compat-funcall
+ 'connection-local-set-profile-variables
+ 'tramp-connection-local-default-shell-profile
+ tramp-connection-local-default-shell-variables)
-;; `connection-local-set-profile-variables' and
-;; `connection-local-set-profiles' exists since Emacs 26.1.
(with-eval-after-load 'shell
(tramp-compat-funcall
- 'connection-local-set-profile-variables
- 'tramp-connection-local-default-profile
- tramp-connection-local-default-profile)
- (tramp-compat-funcall
'connection-local-set-profiles
- `(:application tramp)
- 'tramp-connection-local-default-profile))
+ '(:application tramp)
+ 'tramp-connection-local-default-shell-profile))
(add-hook 'tramp-unload-hook
(lambda () (unload-feature 'tramp-integration 'force)))
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 5b26b66b8ec..49e366c01c6 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -35,14 +35,13 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
(require 'tramp)
+(require 'tramp-fuse)
;;;###tramp-autoload
(defconst tramp-rclone-method "rclone"
"When this method name is used, forward all calls to rclone mounts.")
-;;;###tramp-autoload
(defcustom tramp-rclone-program "rclone"
"Name of the rclone program."
:group 'tramp
@@ -53,7 +52,12 @@
(tramp--with-startup
(add-to-list 'tramp-methods
`(,tramp-rclone-method
- (tramp-mount-args nil)
+ ;; Be careful changing "--dir-cache-time", this could
+ ;; delay visibility of files. Since we use Tramp's
+ ;; internal cache for file attributes, there shouldn't
+ ;; be serious performance penalties when set to 0.
+ (tramp-mount-args
+ ("--no-unicode-normalization" "--dir-cache-time" "0s"))
(tramp-copyto-args nil)
(tramp-moveto-args nil)
(tramp-about-args ("--full"))))
@@ -72,11 +76,11 @@
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-handle-copy-directory)
(copy-file . tramp-rclone-handle-copy-file)
- (delete-directory . tramp-rclone-handle-delete-directory)
- (delete-file . tramp-rclone-handle-delete-file)
+ (delete-directory . tramp-fuse-handle-delete-directory)
+ (delete-file . tramp-fuse-handle-delete-file)
;; `diff-latest-backup-file' performed by default handler.
(directory-file-name . tramp-handle-directory-file-name)
- (directory-files . tramp-rclone-handle-directory-files)
+ (directory-files . tramp-fuse-handle-directory-files)
(directory-files-and-attributes
. tramp-handle-directory-files-and-attributes)
(dired-compress-file . ignore)
@@ -85,15 +89,16 @@
(expand-file-name . tramp-handle-expand-file-name)
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . ignore)
- (file-attributes . tramp-rclone-handle-file-attributes)
+ (file-attributes . tramp-fuse-handle-file-attributes)
(file-directory-p . tramp-handle-file-directory-p)
(file-equal-p . tramp-handle-file-equal-p)
- (file-executable-p . tramp-rclone-handle-file-executable-p)
+ (file-executable-p . tramp-fuse-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
- (file-name-all-completions . tramp-rclone-handle-file-name-all-completions)
+ (file-name-all-completions . tramp-fuse-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
(file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
(file-name-completion . tramp-handle-file-name-completion)
@@ -105,7 +110,7 @@
(file-notify-rm-watch . ignore)
(file-notify-valid-p . ignore)
(file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-rclone-handle-file-readable-p)
+ (file-readable-p . tramp-fuse-handle-file-readable-p)
(file-regular-p . tramp-handle-file-regular-p)
(file-remote-p . tramp-handle-file-remote-p)
(file-selinux-context . tramp-handle-file-selinux-context)
@@ -118,9 +123,11 @@
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
- (make-directory . tramp-rclone-handle-make-directory)
+ (make-directory . tramp-fuse-handle-make-directory)
(make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
@@ -135,8 +142,11 @@
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -155,12 +165,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
;;;###tramp-autoload
(defun tramp-rclone-file-name-handler (operation &rest args)
"Invoke the rclone handler for OPERATION and ARGS.
-First arg specifies the OPERATION, second arg is a list of arguments to
-pass to the OPERATION."
- (let ((fn (assoc operation tramp-rclone-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###tramp-autoload
(tramp--with-startup
@@ -214,13 +223,11 @@ file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "%s file" msg-operation "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(if (or (and t1 (not (tramp-rclone-file-name-p filename)))
@@ -248,31 +255,20 @@ file names."
"Error %s `%s' `%s'" msg-operation filename newname)))
(when (and t1 (eq op 'rename))
- (with-parsed-tramp-file-name filename v1
- (tramp-flush-file-properties v1 v1-localname)
- (when (tramp-rclone-file-name-p filename)
- (tramp-rclone-flush-directory-cache v1)
- ;; The mount point's directory cache might need time
- ;; to flush.
- (while (file-exists-p filename)
- (tramp-flush-file-properties v1 v1-localname)))))
+ (while (file-exists-p filename)
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties v1 v1-localname))))
(when t2
(with-parsed-tramp-file-name newname v2
- (tramp-flush-file-properties v2 v2-localname)
- (when (tramp-rclone-file-name-p newname)
- (tramp-rclone-flush-directory-cache v2)
- ;; The mount point's directory cache might need time
- ;; to flush.
- (while (not (file-exists-p newname))
- (tramp-flush-file-properties v2 v2-localname))))))))))
+ (tramp-flush-file-properties v2 v2-localname))))))))
(defun tramp-rclone-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
"Like `copy-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -284,90 +280,6 @@ file names."
(list filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes))))
-(defun tramp-rclone-handle-delete-directory
- (directory &optional recursive trash)
- "Like `delete-directory' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name directory) nil
- (delete-directory (tramp-rclone-local-file-name directory) recursive trash)
- (tramp-flush-directory-properties v localname)
- (tramp-rclone-flush-directory-cache v)))
-
-(defun tramp-rclone-handle-delete-file (filename &optional trash)
- "Like `delete-file' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (delete-file (tramp-rclone-local-file-name filename) trash)
- (tramp-flush-file-properties v localname)
- (tramp-rclone-flush-directory-cache v)))
-
-(defun tramp-rclone-handle-directory-files
- (directory &optional full match nosort _count)
- "Like `directory-files' for Tramp files."
- (unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
- (when (file-directory-p directory)
- (setq directory (file-name-as-directory (expand-file-name directory)))
- (with-parsed-tramp-file-name directory nil
- (let ((result
- (directory-files
- (tramp-rclone-local-file-name directory) full match)))
- ;; Massage the result.
- (when full
- (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v))))
- (remote (funcall (if (tramp-compat-file-name-quoted-p directory)
- #'tramp-compat-file-name-quote #'identity)
- (file-remote-p directory))))
- (setq result
- (mapcar
- (lambda (x) (replace-regexp-in-string local remote x))
- result))))
- ;; Some storage systems do not return "." and "..".
- (dolist (item '(".." "."))
- (when (and (string-match-p (or match (regexp-quote item)) item)
- (not
- (member (if full (setq item (concat directory item)) item)
- result)))
- (setq result (cons item result))))
- ;; Return result.
- (if nosort result (sort result #'string<))))))
-
-(defun tramp-rclone-handle-file-attributes (filename &optional id-format)
- "Like `file-attributes' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-tramp-file-property
- v localname (format "file-attributes-%s" id-format)
- (file-attributes (tramp-rclone-local-file-name filename) id-format))))
-
-(defun tramp-rclone-handle-file-executable-p (filename)
- "Like `file-executable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-tramp-file-property v localname "file-executable-p"
- (file-executable-p (tramp-rclone-local-file-name filename)))))
-
-(defun tramp-rclone-handle-file-name-all-completions (filename directory)
- "Like `file-name-all-completions' for Tramp files."
- (all-completions
- filename
- (delete-dups
- (append
- (file-name-all-completions
- filename (tramp-rclone-local-file-name directory))
- ;; Some storage systems do not return "." and "..".
- (let (result)
- (dolist (item '(".." ".") result)
- (when (string-prefix-p filename item)
- (catch 'match
- (dolist (elt completion-regexp-list)
- (unless (string-match-p elt item) (throw 'match nil)))
- (setq result (cons (concat item "/") result))))))))))
-
-(defun tramp-rclone-handle-file-readable-p (filename)
- "Like `file-readable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-tramp-file-property v localname "file-readable-p"
- (file-readable-p (tramp-rclone-local-file-name filename)))))
-
(defun tramp-rclone-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
(ignore-errors
@@ -395,42 +307,11 @@ file names."
(when (and total free)
(list total free (- total free))))))))
-(defun tramp-rclone-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
- "Like `insert-directory' for Tramp files."
- (insert-directory
- (tramp-rclone-local-file-name filename) switches wildcard full-directory-p)
- (goto-char (point-min))
- (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror)
- (replace-match filename)))
-
-(defun tramp-rclone-handle-insert-file-contents
- (filename &optional visit beg end replace)
- "Like `insert-file-contents' for Tramp files."
- (let ((result
- (insert-file-contents
- (tramp-rclone-local-file-name filename) visit beg end replace)))
- (prog1
- (list (expand-file-name filename) (cadr result))
- (when visit (setq buffer-file-name filename)))))
-
-(defun tramp-rclone-handle-make-directory (dir &optional parents)
- "Like `make-directory' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name dir) nil
- (make-directory (tramp-rclone-local-file-name dir) parents)
- ;; When PARENTS is non-nil, DIR could be a chain of non-existent
- ;; directories a/b/c/... Instead of checking, we simply flush the
- ;; whole file cache.
- (tramp-flush-file-properties v localname)
- (tramp-flush-directory-properties
- v (if parents "/" (file-name-directory localname)))
- (tramp-rclone-flush-directory-cache v)))
-
(defun tramp-rclone-handle-rename-file
(filename newname &optional ok-if-already-exists)
"Like `rename-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -443,82 +324,6 @@ file names."
;; File name conversions.
-(defun tramp-rclone-mount-point (vec)
- "Return local mount point of VEC."
- (expand-file-name
- (concat
- tramp-temp-name-prefix (tramp-file-name-method vec)
- "." (tramp-file-name-host vec))
- (tramp-compat-temporary-file-directory)))
-
-(defun tramp-rclone-mounted-p (vec)
- "Check, whether storage system determined by VEC is mounted."
- (when (tramp-get-connection-process vec)
- ;; We cannot use `with-connection-property', because we don't want
- ;; to cache a nil result.
- (or (tramp-get-connection-property
- (tramp-get-connection-process vec) "mounted" nil)
- (let* ((default-directory temporary-file-directory)
- (mount (shell-command-to-string "mount -t fuse.rclone")))
- (tramp-message vec 6 "%s" "mount -t fuse.rclone")
- (tramp-message vec 6 "\n%s" mount)
- (tramp-set-connection-property
- (tramp-get-connection-process vec) "mounted"
- (when (string-match
- (format
- "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec)))
- mount)
- (match-string 1 mount)))))))
-
-(defun tramp-rclone-flush-directory-cache (vec)
- "Flush directory cache of VEC mount."
- (let ((rclone-pid
- ;; Identify rclone process.
- (when (tramp-get-connection-process vec)
- (with-tramp-connection-property
- (tramp-get-connection-process vec) "rclone-pid"
- (catch 'pid
- (dolist
- (pid
- ;; Until Emacs 25, `process-attributes' could
- ;; crash Emacs for some processes. So we use
- ;; "pidof", which might not work everywhere.
- (if (<= emacs-major-version 25)
- (let ((default-directory temporary-file-directory))
- (mapcar
- #'string-to-number
- (split-string
- (shell-command-to-string "pidof rclone"))))
- (list-system-processes)))
- (and (string-match-p
- (regexp-quote
- (format "rclone mount %s:" (tramp-file-name-host vec)))
- (or (cdr (assoc 'args (process-attributes pid))) ""))
- (throw 'pid pid))))))))
- ;; Send a SIGHUP in order to flush directory cache.
- (when rclone-pid
- (tramp-message
- vec 6 "Send SIGHUP %d: %s"
- rclone-pid (cdr (assoc 'args (process-attributes rclone-pid))))
- (signal-process rclone-pid 'SIGHUP))))
-
-(defun tramp-rclone-local-file-name (filename)
- "Return local mount name of FILENAME."
- (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
- (with-parsed-tramp-file-name filename nil
- ;; As long as we call `tramp-rclone-maybe-open-connection' here,
- ;; we cache the result.
- (with-tramp-file-property v localname "local-file-name"
- (tramp-rclone-maybe-open-connection v)
- (let ((quoted (tramp-compat-file-name-quoted-p localname))
- (localname (tramp-compat-file-name-unquote localname)))
- (funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
- (expand-file-name
- (if (file-name-absolute-p localname)
- (substring localname 1) localname)
- (tramp-rclone-mount-point v)))))))
-
(defun tramp-rclone-remote-file-name (filename)
"Return FILENAME as used in the `rclone' command."
(setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
@@ -531,7 +336,7 @@ file names."
;; TODO: This shall be handled by `expand-file-name'.
(setq localname
(replace-regexp-in-string "^\\." "" (or localname "")))
- (format "%s%s" (tramp-rclone-mounted-p v) localname)))
+ (format "%s%s" (tramp-fuse-mounted-p v) localname)))
;; It is a local file name.
filename))
@@ -557,24 +362,26 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property
+ p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
;; Create directory.
- (unless (file-directory-p (tramp-rclone-mount-point vec))
- (make-directory (tramp-rclone-mount-point vec) 'parents))
+ (unless (file-directory-p (tramp-fuse-mount-point vec))
+ (make-directory (tramp-fuse-mount-point vec) 'parents))
;; Mount. This command does not return, so we use 0 as
;; DESTINATION of `tramp-call-process'.
- (unless (tramp-rclone-mounted-p vec)
+ (unless (tramp-fuse-mounted-p vec)
(apply
#'tramp-call-process
vec tramp-rclone-program nil 0 nil
- (delq nil
- `("mount" ,(concat host ":/")
- ,(tramp-rclone-mount-point vec)
- ;; This could be nil.
- ,(tramp-get-method-parameter vec 'tramp-mount-args))))
+ "mount" (tramp-fuse-mount-spec vec)
+ (tramp-fuse-mount-point vec)
+ (tramp-get-method-parameter vec 'tramp-mount-args))
(while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc)))
(tramp-cleanup-connection vec 'keep-debug 'keep-password))
@@ -609,9 +416,4 @@ The command is the list of strings ARGS."
(provide 'tramp-rclone)
-;;; TODO:
-
-;; * If possible, get rid of "rclone mount". Maybe it is more
-;; performant then.
-
;;; tramp-rclone.el ends here
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 49eb6415ad3..7cf90b96612 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -46,7 +46,6 @@
(defconst tramp-default-remote-shell "/bin/sh"
"The default remote shell Tramp applies.")
-;;;###tramp-autoload
(defcustom tramp-inline-compress-start-size 4096
"The minimum size of compressing where inline transfer.
When inline transfer, compress transferred data of file whose
@@ -56,24 +55,12 @@ If it is nil, no compression at all will be applied."
:group 'tramp
:type '(choice (const nil) integer))
-;;;###tramp-autoload
(defcustom tramp-copy-size-limit 10240
- "The maximum file size where inline copying is preferred over an \
-out-of-the-band copy.
+ "Maximum file size where inline copying is preferred to an out-of-the-band copy.
If it is nil, 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)
-
-;;;###tramp-autoload
(defcustom tramp-histfile-override "~/.tramp_history"
"When invoking a shell, override the HISTFILE with this value.
When setting to a string, it redirects the shell history to that
@@ -91,10 +78,10 @@ the default storage location, e.g. \"$HOME/.sh_history\"."
(string :tag "Redirect to a file")))
;;;###tramp-autoload
-(defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m"
+(defconst tramp-display-escape-sequence-regexp "\e[[:digit:];[]+m"
"Terminal control escape sequences for display attributes.")
-(defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n"
+(defconst tramp-device-escape-sequence-regexp "\e[[:digit:][]+n"
"Terminal control escape sequences for device status.")
;; ksh on OpenBSD 4.5 requires that $PS1 contains a `#' character for
@@ -116,11 +103,12 @@ detected as prompt when being sent on echoing hosts, therefore.")
(defconst tramp-end-of-heredoc (md5 tramp-end-of-output)
"String used to recognize end of heredoc strings.")
-;;;###tramp-autoload
-(defcustom tramp-use-ssh-controlmaster-options t
- "Whether to use `tramp-ssh-controlmaster-options'."
+(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type 'windows-nt))
+ "Whether to use `tramp-ssh-controlmaster-options'.
+Set it to nil, if you use Control* or Proxy* options in your ssh
+configuration."
:group 'tramp
- :version "24.4"
+ :version "28.1"
:type 'boolean)
(defvar tramp-ssh-controlmaster-options nil
@@ -137,6 +125,15 @@ depends on the installed local ssh version.
The string is used in `tramp-methods'.")
+(defvar tramp-scp-strict-file-name-checking nil
+ "Which scp strict file name checking argument to use.
+
+It is the string \"-T\" if supported by the local scp (since
+release 8.0), otherwise the string \"\". If it is nil, it will
+be auto-detected by Tramp.
+
+The string is used in `tramp-methods'.")
+
;; Initialize `tramp-methods' with the supported methods.
;;;###tramp-autoload
(tramp--with-startup
@@ -167,27 +164,29 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
(tramp-copy-program "scp")
- (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q")
- ("-r") ("%c")))
+ (tramp-copy-args (("-P" "%p") ("-p" "%k")
+ ("%x") ("-q") ("-r") ("%c")))
(tramp-copy-keep-date t)
(tramp-copy-recursive t)))
(add-to-list 'tramp-methods
`("scpx"
(tramp-login-program "ssh")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("-t" "-t") ("%h")
- ("%l")))
+ ("-e" "none") ("-t" "-t")
+ ("-o" "RemoteCommand=\"%l\"")
+ ("%h")))
(tramp-async-args (("-q")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
(tramp-copy-program "scp")
(tramp-copy-args (("-P" "%p") ("-p" "%k")
- ("-q") ("-r") ("%c")))
+ ("%x") ("-q") ("-r") ("%c")))
(tramp-copy-keep-date t)
(tramp-copy-recursive t)))
(add-to-list 'tramp-methods
@@ -196,6 +195,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
@@ -226,6 +226,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("%h")))
(tramp-async-args (("-q")))
+ (tramp-direct-async t)
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))))
@@ -233,8 +234,9 @@ The string is used in `tramp-methods'.")
`("sshx"
(tramp-login-program "ssh")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
- ("-e" "none") ("-t" "-t") ("%h")
- ("%l")))
+ ("-e" "none") ("-t" "-t")
+ ("-o" "RemoteCommand=\"%l\"")
+ ("%h")))
(tramp-async-args (("-q")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
@@ -242,14 +244,14 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-methods
`("telnet"
(tramp-login-program "telnet")
- (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
+ (tramp-login-args (("%h") ("%p") ("%n")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))))
(add-to-list 'tramp-methods
`("nc"
(tramp-login-program "telnet")
- (tramp-login-args (("%h") ("%p") ("2>/dev/null")))
+ (tramp-login-args (("%h") ("%p") ("%n")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-c"))
@@ -260,8 +262,7 @@ The string is used in `tramp-methods'.")
;; We use "-p" as required for newer busyboxes. For older
;; busybox/nc versions, the value must be (("-l") ("%r")). This
;; can be achieved by tweaking `tramp-connection-properties'.
- (tramp-remote-copy-args (("-l") ("-p" "%r")
- ("2>/dev/null")))))
+ (tramp-remote-copy-args (("-l") ("-p" "%r") ("%n")))))
(add-to-list 'tramp-methods
`("su"
(tramp-login-program "su")
@@ -409,16 +410,34 @@ The string is used in `tramp-methods'.")
;;;###tramp-autoload
(defconst tramp-completion-function-alist-ssh
- '((tramp-parse-rhosts "/etc/hosts.equiv")
+ `((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")
+ ;; On W32 systems, the ssh directory is located somewhere else.
+ (tramp-parse-shosts ,(expand-file-name
+ "ssh/ssh_known_hosts"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "ProgramData"))
+ "/etc/")))
+ (tramp-parse-sconfig ,(expand-file-name
+ "ssh/ssh_config"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "ProgramData"))
+ "/etc/")))
(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")
+ ;; On W32 systems, the .ssh directory is located somewhere else.
+ (tramp-parse-shosts ,(expand-file-name
+ ".ssh/known_hosts"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "USERPROFILE"))
+ "~/")))
+ (tramp-parse-sconfig ,(expand-file-name
+ ".ssh/config"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "USERPROFILE"))
+ "~/")))
(tramp-parse-shostkeys "~/.ssh2/hostkeys")
(tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
"Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
@@ -441,7 +460,7 @@ The string is used in `tramp-methods'.")
;;;###tramp-autoload
(defconst tramp-completion-function-alist-putty
`((tramp-parse-putty
- ,(if (memq system-type '(windows-nt))
+ ,(if (eq system-type 'windows-nt)
"HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"
"~/.putty/sessions")))
"Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.")
@@ -474,69 +493,6 @@ The string is used in `tramp-methods'.")
(tramp-set-completion-function "psftp" 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, RHEL): /bin:/usr/bin
-;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
-;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin
-;; IRIX64: /usr/bin
-;; QNAP QTS: ---
-;;;###tramp-autoload
-(defcustom tramp-remote-path
- '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin"
- "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin"
- "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin"
- "/opt/bin" "/opt/sbin" "/opt/local/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 head 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. This entry is represented in
-the list by the special value `tramp-default-remote-path'.
-
-`Private Directories' are the settings of the $PATH environment,
-as given in your `~/.profile'. This entry is represented in
-the list by the special value `tramp-own-remote-path'."
- :group 'tramp
- :type '(repeat (choice
- (const :tag "Default Directories" tramp-default-remote-path)
- (const :tag "Private Directories" tramp-own-remote-path)
- (string :tag "Directory"))))
-
-;;;###tramp-autoload
-(defcustom tramp-remote-process-environment
- '("ENV=''" "TMOUT=0" "LC_CTYPE=''"
- "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat"
- "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= disables the corresponding environment variable,
-which might have been set in the init files like ~/.profile.
-
-Special handling is applied to some environment variables,
-which should not be set here:
-
-The PATH environment variable should be set via `tramp-remote-path'.
-
-The TERM environment variable should be set via `tramp-terminal-type'.
-
-The INSIDE_EMACS environment variable will automatically be set
-based on the Tramp and Emacs versions, and should not be set here."
- :group 'tramp
- :version "26.1"
- :type '(repeat string))
-
-;;;###tramp-autoload
(defcustom tramp-sh-extra-args
'(("/bash\\'" . "-noediting -norc -noprofile")
("/zsh\\'" . "-f +Z -V"))
@@ -563,6 +519,7 @@ shell from reading its init file."
(tramp-yn-prompt-regexp tramp-action-yn)
(tramp-terminal-prompt-regexp tramp-action-terminal)
(tramp-antispoof-regexp tramp-action-confirm-message)
+ (tramp-yubikey-regexp tramp-action-show-and-confirm-message)
(tramp-process-alive-regexp tramp-action-process-alive))
"List of pattern/action pairs.
Whenever a pattern matches, the corresponding action is performed.
@@ -580,6 +537,7 @@ corresponding PATTERN matches, the ACTION function is called.")
'((tramp-password-prompt-regexp tramp-action-password)
(tramp-wrong-passwd-regexp tramp-action-permission-denied)
(tramp-copy-failed-regexp tramp-action-permission-denied)
+ (tramp-yubikey-regexp tramp-action-show-and-confirm-message)
(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.
@@ -593,10 +551,12 @@ rm -f %t"
"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.")
+we have this shell function.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-file-truename
- "%s -e '
+ "%p -e '
use File::Spec;
use Cwd \"realpath\";
@@ -631,14 +591,14 @@ if (!$result) {
$result =~ s/\"/\\\\\"/g;
print \"\\\"$result\\\"\\n\";
-' \"$1\" 2>/dev/null"
+' \"$1\" %n"
"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.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-file-name-all-completions
- "%s -e '
+ "%p -e '
opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\");
@files = readdir(d); closedir(d);
foreach $f (@files) {
@@ -650,11 +610,11 @@ foreach $f (@files) {
}
}
print \"ok\\n\"
-' \"$1\" 2>/dev/null"
+' \"$1\" %n"
"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.")
+`file-name-all-completions' on the remote file system.
+Format specifiers are replaced by `tramp-expand-script', 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
@@ -663,7 +623,7 @@ passed to `format', so percent characters need to be doubled.")
;; 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 '
+ "%p -e '
@stat = lstat($ARGV[0]);
if (!@stat) {
print \"nil\\n\";
@@ -700,14 +660,14 @@ printf(
$stat[7],
$stat[2],
$stat[1]
-);' \"$1\" \"$2\" 2>/dev/null"
+);' \"$1\" \"$2\" %n"
"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.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-directory-files-and-attributes
- "%s -e '
+ "%p -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);
@@ -752,31 +712,31 @@ for($i = 0; $i < $n; $i++)
$stat[2],
$stat[1]);
}
-printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null"
+printf(\")\\n\");' \"$1\" \"$2\" %n"
"Perl script implementing `directory-files-and-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.")
+Format specifiers are replaced by `tramp-expand-script', 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"
+ "%p -MMIME::Base64 -0777 -ne 'print encode_base64($_)' %n"
"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.")
+on the remote host.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-decode-with-module
- "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null"
+ "%p -MMIME::Base64 -0777 -ne 'print decode_base64($_)' %n"
"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.")
+on the remote host.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-encode
- "%s -e '
+ "%p -e '
# This script contributed by Juanma Barranquero <lektu@terra.es>.
# Copyright (C) 2002-2021 Free Software Foundation, Inc.
use strict;
@@ -809,13 +769,13 @@ while (read STDIN, $data, 54) {
(substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)),
$pad,
qq(\\n);
-}' 2>/dev/null"
+}' %n"
"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.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-decode
- "%s -e '
+ "%p -e '
# This script contributed by Juanma Barranquero <lektu@terra.es>.
# Copyright (C) 2002-2021 Free Software Foundation, Inc.
use strict;
@@ -853,24 +813,27 @@ while (my $data = <STDIN>) {
((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g);
last if $finished;
-}' 2>/dev/null"
+}' %n"
"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.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-pack
- "%s -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
+ "%p -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)' %n"
"Perl program to use for encoding a file.
-Escape sequence %s is replaced with name of Perl binary.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-perl-unpack
- "%s -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"
+ "%p -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)' %n"
"Perl program to use for decoding a file.
-Escape sequence %s is replaced with name of Perl binary.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-hexdump-encode "%h -v -e '16/1 \" %%02x\" \"\\n\"'"
"`hexdump' program to use for encoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-awk-encode
"%a '\\
@@ -904,21 +867,24 @@ END {
printf tail
}'"
"`awk' program to use for encoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-hexdump-awk-encode
(format "%s | %s" tramp-hexdump-encode tramp-awk-encode)
"`hexdump' / `awk' pipe to use for encoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-od-encode "%o -v -t x1 -A n"
"`od' program to use for encoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
-(defconst tramp-od-awk-encode
- (format "%s | %s" tramp-od-encode tramp-awk-encode)
+(defconst tramp-od-awk-encode (format "%s | %s" tramp-od-encode tramp-awk-encode)
"`od' / `awk' pipe to use for encoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-awk-decode
"%a '\\
@@ -935,7 +901,7 @@ BEGIN {
if (o) {
printf \"%%c\", o
} else {
- system(\"dd if=/dev/zero bs=1 count=1 2>/dev/null\")
+ system(\"dd if=/dev/zero bs=1 count=1 %n\")
}
obc=0; o=0
}
@@ -944,7 +910,8 @@ BEGIN {
}
}'"
"Awk program to use for decoding a file.
-This string is passed to `format', so percent characters need to be doubled.")
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
(defconst tramp-vc-registered-read-file-names
"echo \"(\"
@@ -966,7 +933,8 @@ echo \")\""
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.")
+of command line.
+Format specifiers \"%s\" are replaced before the script is used.")
;; New handlers should be added here.
;;;###tramp-autoload
@@ -996,6 +964,7 @@ of command line.")
(file-exists-p . tramp-sh-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-sh-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-sh-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -1004,7 +973,7 @@ of command line.")
(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-sh-handle-file-newer-than-file-p)
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-notify-add-watch . tramp-sh-handle-file-notify-add-watch)
(file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
(file-notify-valid-p . tramp-handle-file-notify-valid-p)
@@ -1022,9 +991,11 @@ of command line.")
(insert-directory . tramp-sh-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-sh-handle-make-directory)
;; `make-directory-internal' performed by default handler.
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . tramp-sh-handle-make-process)
(make-symbolic-link . tramp-sh-handle-make-symbolic-link)
@@ -1039,8 +1010,11 @@ of command line.")
(start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . tramp-sh-handle-vc-registered)
(verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime)
(write-region . tramp-sh-handle-write-region))
@@ -1078,7 +1052,8 @@ component is used as the target of the symlink."
(unless ln
(tramp-error
v 'file-error
- "Making a symbolic link. ln(1) does not exist on the remote host."))
+ (concat "Making a symbolic link. "
+ "ln(1) does not exist on the remote host.")))
;; Do the 'confirm if exists' thing.
(when (file-exists-p linkname)
@@ -1116,8 +1091,7 @@ component is used as the target of the symlink."
"Like `file-truename' for Tramp files."
;; Preserve trailing "/".
(funcall
- (if (tramp-compat-directory-name-p filename)
- #'file-name-as-directory #'identity)
+ (if (directory-name-p filename) #'file-name-as-directory #'identity)
;; Quote properly.
(funcall
(if (tramp-compat-file-name-quoted-p filename)
@@ -1154,59 +1128,9 @@ component is used as the target of the symlink."
(tramp-shell-quote-argument localname)))))
;; Do it yourself.
- (t (let ((steps (split-string localname "/" 'omit))
- (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"
- (string-join
- (append '("") (reverse result) (list thisstep)) "/"))
- (setq symlink-target
- (tramp-compat-file-attribute-type
- (file-attributes
- (tramp-make-tramp-file-name
- v
- (string-join
- (append
- '("") (reverse result) (list thisstep)) "/")
- 'nohop))))
- (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))
- (setq steps
- (append
- (split-string symlink-target "/" 'omit)
- 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 (string-join (cons "" result) "/") "/"))
- (when (string-empty-p result) (setq result "/")))))
+ (t (setq
+ result
+ (tramp-file-local-name (tramp-handle-file-truename filename)))))
;; Detect cycle.
(when (and (file-symlink-p filename)
@@ -1378,13 +1302,12 @@ component is used as the target of the symlink."
(tramp-send-command-and-read
vec
(format
- (eval-when-compile
- (concat
- ;; Apostrophes in the stat output are masked as
- ;; `tramp-stat-marker', in order to make a proper shell escape
- ;; of them in file names.
- "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |"
- " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')"))
+ (concat
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape of
+ ;; them in file names.
+ "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |"
+ " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')")
(tramp-get-remote-stat vec)
tramp-stat-marker tramp-stat-marker
(if (eq id-format 'integer)
@@ -1474,17 +1397,24 @@ of."
;; only if that agrees with the buffer's record.
(t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))))
-(defun tramp-sh-handle-set-file-modes (filename mode &optional _flag)
+(defun tramp-sh-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-properties v localname)
- ;; FIXME: extract the proper text from chmod's stderr.
- (tramp-barf-unless-okay
- v
- (format "chmod %o %s" mode (tramp-shell-quote-argument localname))
- "Error while changing file's mode %s" filename)))
+ ;; We need "chmod -h" when the flag is set.
+ (when (or (not (eq flag 'nofollow))
+ (not (file-symlink-p filename))
+ (tramp-get-remote-chmod-h v))
+ (tramp-flush-file-properties v localname)
+ ;; FIXME: extract the proper text from chmod's stderr.
+ (tramp-barf-unless-okay
+ v
+ (format
+ "chmod %s %o %s"
+ (if (and (eq flag 'nofollow) (tramp-get-remote-chmod-h v)) "-h" "")
+ mode (tramp-shell-quote-argument localname))
+ "Error while changing file's mode %s" filename))))
-(defun tramp-sh-handle-set-file-times (filename &optional time _flag)
+(defun tramp-sh-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(when (tramp-get-remote-touch v)
@@ -1497,13 +1427,34 @@ of."
time)))
(tramp-send-command-and-check
v (format
- "env TZ=UTC %s %s %s"
+ "env TZ=UTC %s %s %s %s"
(tramp-get-remote-touch v)
(if (tramp-get-connection-property v "touch-t" nil)
(format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t))
"")
+ (if (eq flag 'nofollow) "-h" "")
(tramp-shell-quote-argument localname)))))))
+(defun tramp-sh-handle-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (ignore-errors
+ (cond
+ ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format))
+ ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format))
+ ((tramp-get-remote-python vec)
+ (tramp-get-remote-uid-with-python vec id-format)))))
+
+(defun tramp-sh-handle-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (ignore-errors
+ (cond
+ ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format))
+ ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format))
+ ((tramp-get-remote-python vec)
+ (tramp-get-remote-gid-with-python vec id-format)))))
+
(defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
;; Modern Unices allow chown only for root. So we might need
@@ -1527,7 +1478,7 @@ of."
(defun tramp-remote-selinux-p (vec)
"Check, whether SELINUX is enabled on the remote host."
- (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p"
+ (with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(tramp-send-command-and-check vec "selinuxenabled")))
(defun tramp-sh-handle-file-selinux-context (filename)
@@ -1535,9 +1486,8 @@ of."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-selinux-context"
(let ((context '(nil nil nil nil))
- (regexp (eval-when-compile
- (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
- "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))))
+ (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):"
+ "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)")))
(when (and (tramp-remote-selinux-p v)
(tramp-send-command-and-check
v (format
@@ -1576,7 +1526,7 @@ of."
(defun tramp-remote-acl-p (vec)
"Check, whether ACL is enabled on the remote host."
- (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p"
+ (with-tramp-connection-property (tramp-get-process vec) "acl-p"
(tramp-send-command-and-check vec "getfacl /")))
(defun tramp-sh-handle-file-acl (filename)
@@ -1634,49 +1584,6 @@ of."
(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)
- (t ;; We are sure both files exist at this point. 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
- (tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time fa1)
- tramp-time-dont-know))
- (not
- (tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time fa2)
- tramp-time-dont-know)))
- (time-less-p
- (tramp-compat-file-attribute-modification-time fa2)
- (tramp-compat-file-attribute-modification-time 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)
@@ -1706,8 +1613,10 @@ of."
(defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group)
"Like `file-ownership-preserved-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (with-tramp-file-property v localname "file-ownership-preserved-p"
- (let ((attributes (file-attributes filename)))
+ (with-tramp-file-property
+ v localname
+ (format "file-ownership-preserved-p%s" (if group "-group" ""))
+ (let ((attributes (file-attributes filename 'integer)))
;; 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)
@@ -1715,19 +1624,24 @@ of."
(= (tramp-compat-file-attribute-user-id attributes)
(tramp-get-remote-uid v 'integer))
(or (not group)
+ ;; On BSD-derived systems files always inherit the
+ ;; parent directory's group, so skip the group-gid
+ ;; test.
+ (string-match-p
+ "BSD\\|DragonFly\\|Darwin"
+ (tramp-get-connection-property v "uname" ""))
(= (tramp-compat-file-attribute-group-id attributes)
(tramp-get-remote-gid v 'integer)))))))))
;; Directory listings.
(defun tramp-sh-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format _count)
+ (directory &optional full match nosort id-format count)
"Like `directory-files-and-attributes' for Tramp files."
(unless id-format (setq id-format 'integer))
(unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
+ (tramp-compat-file-missing
+ (tramp-dissect-file-name directory) directory))
(when (file-directory-p directory)
(setq directory (expand-file-name directory))
(let* ((temp
@@ -1756,13 +1670,18 @@ of."
(setcar item (expand-file-name (car item) directory)))
(push item result)))
- (or (if nosort
- result
- (sort result (lambda (x y) (string< (car x) (car y)))))
+ (unless nosort
+ (setq result (sort result (lambda (x y) (string< (car x) (car y))))))
+
+ (when (and (natnump count) (> count 0))
+ (setq result (nbutlast result (- (length result) count))))
+
+ (or result
;; The scripts could fail, for example with huge file size.
(tramp-handle-directory-files-and-attributes
- directory full match nosort id-format)))))
+ directory full match nosort id-format count)))))
+;; FIXME: Fix function to work with count parameter.
(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."
@@ -1778,6 +1697,7 @@ of."
(when (stringp object) (tramp-error vec 'file-error object))
object))
+;; FIXME: Fix function to work with count parameter.
(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."
@@ -1785,21 +1705,19 @@ of."
(tramp-send-command-and-read
vec
(format
- (eval-when-compile
- (concat
- ;; We must care about file names 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 use \000 as file separator.
- ;; `tramp-sh--quoting-style-options' do not work for file names
- ;; with spaces piped to "xargs".
- ;; Apostrophes in the stat output are masked as
- ;; `tramp-stat-marker', in order to make a proper shell escape
- ;; of them in file names.
- "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | "
- "xargs -0 %s -c "
- "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' "
- "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\""))
+ (concat
+ ;; We must care about file names 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 use
+ ;; \000 as file separator. `tramp-sh--quoting-style-options' do
+ ;; not work for file names with spaces piped to "xargs".
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape of
+ ;; them in file names.
+ "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | "
+ "xargs -0 %s -c "
+ "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' "
+ "-- 2>%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")
(tramp-shell-quote-argument localname)
(tramp-get-ls-command vec)
;; On systems which have no quoting style, file names with special
@@ -1815,6 +1733,7 @@ of."
"%g"
(eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker)))
tramp-stat-marker tramp-stat-marker
+ (tramp-get-remote-null-device vec)
tramp-stat-quoted-marker)))
;; This function should return "foo/" for directories and "bar" for
@@ -1840,16 +1759,17 @@ of."
(format "tramp_perl_file_name_all_completions %s"
(tramp-shell-quote-argument localname)))
- (format (eval-when-compile
- (concat
- "(cd %s 2>&1 && %s -a 2>/dev/null"
- " | while IFS= read f; do"
- " if %s -d \"$f\" 2>/dev/null;"
- " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
- " && \\echo ok) || \\echo fail"))
+ (format (concat
+ "(cd %s 2>&1 && %s -a 2>%s"
+ " | while IFS= read f; do"
+ " if %s -d \"$f\" 2>%s;"
+ " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
+ " && \\echo ok) || \\echo fail")
(tramp-shell-quote-argument localname)
(tramp-get-ls-command v)
- (tramp-get-test-command v))))
+ (tramp-get-remote-null-device v)
+ (tramp-get-test-command v)
+ (tramp-get-remote-null-device v))))
;; Now grab the output.
(with-current-buffer (tramp-get-buffer v)
@@ -1872,8 +1792,9 @@ of."
;; side.
(unless (looking-at-p "^ok$")
(tramp-error
- v 'file-error "\
-tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
+ v 'file-error
+ (concat "tramp-sh-handle-file-name-all-completions: "
+ "internal error accessing `%s': `%s'")
(tramp-shell-quote-argument localname) (buffer-string))))
(while (zerop (forward-line -1))
@@ -1928,7 +1849,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
'copy filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
(tramp-run-real-handler
- 'copy-file
+ #'copy-file
(list filename newname ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes))))
@@ -1939,9 +1860,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
(t2 (tramp-tramp-file-p newname)))
(with-parsed-tramp-file-name (if t1 dirname newname) nil
(unless (file-exists-p dirname)
- (tramp-error
- v tramp-file-missing
- "Copying directory" "No such file or directory" dirname))
+ (tramp-compat-file-missing v dirname))
(if (and (not copy-contents)
(tramp-get-method-parameter v 'tramp-copy-recursive)
;; When DIRNAME and NEWNAME are remote, they must have
@@ -1954,7 +1873,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
;; scp or rsync DTRT.
(progn
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-already-exists newname))
(setq dirname (directory-file-name (expand-file-name dirname))
newname (directory-file-name (expand-file-name newname)))
@@ -1967,11 +1886,11 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
(unless (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))
+ 'copy dirname newname 'ok-if-already-exists keep-date))
;; We must do it file-wise.
(tramp-run-real-handler
- 'copy-directory
+ #'copy-directory
(list dirname newname keep-date parents copy-contents)))
;; When newname did exist, we have wrong cached values.
@@ -1984,8 +1903,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
"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))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -2027,22 +1946,20 @@ file names."
(length (tramp-compat-file-attribute-size
(file-attributes (file-truename filename))))
(attributes (and preserve-extended-attributes
- (apply #'file-extended-attributes (list filename)))))
+ (file-extended-attributes filename)))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(with-tramp-progress-reporter
- v 0 (format "%s %s to %s"
- (if (eq op 'copy) "Copying" "Renaming")
- filename newname)
+ v 0 (format "%s %s to %s" msg-operation filename newname)
(cond
;; Both are Tramp files.
@@ -2063,7 +1980,7 @@ file names."
(tramp-method-out-of-band-p v1 length)
(tramp-method-out-of-band-p v2 length))
(tramp-do-copy-or-rename-file-out-of-band
- op filename newname keep-date))
+ op filename newname ok-if-already-exists keep-date))
;; No shortcut was possible. So we copy the file
;; first. If the operation was `rename', we go back
@@ -2076,7 +1993,7 @@ file names."
;; source and target file.
(t
(tramp-do-copy-or-rename-file-via-buffer
- op filename newname keep-date))))))
+ op filename newname ok-if-already-exists keep-date))))))
;; One file is a Tramp file, the other one is local.
((or t1 t2)
@@ -2091,11 +2008,11 @@ file names."
;; corresponding copy-program can be invoked.
((tramp-method-out-of-band-p v length)
(tramp-do-copy-or-rename-file-out-of-band
- op filename newname keep-date))
+ op filename newname ok-if-already-exists keep-date))
;; Use the inline method via a Tramp buffer.
(t (tramp-do-copy-or-rename-file-via-buffer
- op filename newname keep-date))))
+ op filename newname ok-if-already-exists keep-date))))
(t
;; One of them must be a Tramp file.
@@ -2105,7 +2022,7 @@ file names."
;; errors, because ACL strings could be incompatible.
(when attributes
(ignore-errors
- (apply #'set-file-extended-attributes (list newname attributes))))
+ (set-file-extended-attributes newname attributes)))
;; In case of `rename', we must flush the cache of the source file.
(when (and t1 (eq op 'rename))
@@ -2117,7 +2034,8 @@ file names."
(with-parsed-tramp-file-name newname v2
(tramp-flush-file-properties v2 v2-localname))))))))
-(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
+(defun tramp-do-copy-or-rename-file-via-buffer
+ (op filename newname ok-if-already-exists 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.
@@ -2145,10 +2063,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
(insert-file-contents-literally filename)))
;; KEEP-DATE handling.
(when keep-date
- (set-file-times
+ (tramp-compat-set-file-times
newname
(tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ (file-attributes filename))
+ (unless ok-if-already-exists 'nofollow)))
;; Set the mode.
(set-file-modes newname (tramp-default-file-modes filename))
;; If the operation was `rename', delete the original file.
@@ -2236,7 +2155,7 @@ the uid and gid from FILENAME."
(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)
+ ok-if-already-exists keep-date preserve-uid-gid)
;; We must change the ownership to the local user.
(tramp-set-file-uid-gid
(concat prefix localname2)
@@ -2302,17 +2221,19 @@ the uid and gid from FILENAME."
;; Set the time and mode. Mask possible errors.
(ignore-errors
(when keep-date
- (set-file-times newname file-times)
+ (tramp-compat-set-file-times
+ newname file-times (unless ok-if-already-exists 'nofollow))
(set-file-modes newname file-modes))))))
-(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date)
+(defun tramp-do-copy-or-rename-file-out-of-band
+ (op filename newname ok-if-already-exists keep-date)
"Invoke `scp' 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 listener spec
- options source target remote-copy-program remote-copy-args)
+ options source target remote-copy-program remote-copy-args p)
(with-parsed-tramp-file-name (if t1 filename newname) nil
(if (and t1 t2)
@@ -2328,9 +2249,9 @@ The method used must be an out-of-band method."
(unwind-protect
(progn
(tramp-do-copy-or-rename-file-out-of-band
- op filename tmpfile keep-date)
+ op filename tmpfile ok-if-already-exists keep-date)
(tramp-do-copy-or-rename-file-out-of-band
- 'rename tmpfile newname keep-date))
+ 'rename tmpfile newname ok-if-already-exists keep-date))
;; Save exit.
(ignore-errors
(if dir-flag
@@ -2347,10 +2268,10 @@ The method used must be an out-of-band method."
#'identity)
(if t1
(tramp-make-copy-program-file-name v)
- (tramp-unquote-shell-quote-argument filename)))
+ (tramp-compat-file-name-unquote filename)))
target (if t2
(tramp-make-copy-program-file-name v)
- (tramp-unquote-shell-quote-argument newname)))
+ (tramp-compat-file-name-unquote newname)))
;; Check for user. There might be an interactive setting.
(setq user (or (tramp-file-name-user v)
@@ -2364,52 +2285,37 @@ The method used must be an out-of-band method."
(setq listener (number-to-string (+ 50000 (random 10000))))))
;; Compose copy command.
- (setq host (or host "")
- user (or user "")
- port (or port "")
- spec (format-spec-make
- ?t (tramp-get-connection-property
- (tramp-get-connection-process v) "temp-file" ""))
- options (format-spec (tramp-ssh-controlmaster-options v) spec)
- spec (format-spec-make
- ?h host ?u user ?p port ?r listener ?c options
- ?k (if keep-date " " ""))
+ (setq options
+ (format-spec
+ (tramp-ssh-controlmaster-options v)
+ (format-spec-make
+ ?t (tramp-get-connection-property
+ (tramp-get-connection-process v) "temp-file" "")))
+ spec (list
+ ?h (or host "") ?u (or user "") ?p (or port "")
+ ?r listener ?c options ?k (if keep-date " " "")
+ ?n (concat "2>" (tramp-get-remote-null-device v))
+ ?x (tramp-scp-strict-file-name-checking v))
copy-program (tramp-get-method-parameter v 'tramp-copy-program)
copy-keep-date (tramp-get-method-parameter
v '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 v '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
+ ;; " " has either been a replacement of "%k" (when
+ ;; keep-date argument is non-nil), or a replacement for
+ ;; the whole keep-date sublist.
+ (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec))
+ ;; `tramp-ssh-controlmaster-options' is a string instead
+ ;; of a list. Unflatten it.
+ copy-args
+ (tramp-compat-flatten-tree
(mapcar
- (lambda (x)
- (setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (string-join x " ")))
- (tramp-get-method-parameter v 'tramp-copy-env)))
-
+ (lambda (x) (if (string-match-p " " x) (split-string x) x))
+ copy-args))
+ copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec)
remote-copy-program
- (tramp-get-method-parameter v 'tramp-remote-copy-program))
-
- (dolist (x (tramp-get-method-parameter v 'tramp-remote-copy-args))
- (setq remote-copy-args
- (append
- remote-copy-args
- (let ((y (mapcar (lambda (z) (format-spec z spec)) x)))
- (if (member "" y) '(" ") y)))))
+ (tramp-get-method-parameter v 'tramp-remote-copy-program)
+ remote-copy-args
+ (apply #'tramp-expand-args v 'tramp-remote-copy-args spec))
;; Check for local copy program.
(unless (executable-find copy-program)
@@ -2455,41 +2361,38 @@ The method used must be an out-of-band method."
v "process-name" (buffer-name (current-buffer)))
(tramp-set-connection-property
v "process-buffer" (current-buffer))
- (while copy-env
+ (when copy-env
(tramp-message
- orig-vec 6 "%s=\"%s\"" (car copy-env) (cadr copy-env))
- (setenv (pop copy-env) (pop copy-env)))
+ orig-vec 6 "%s=\"%s\""
+ (car copy-env) (string-join (cdr copy-env) " "))
+ (setenv (car copy-env) (string-join (cdr copy-env) " ")))
(setq
copy-args
(append
copy-args
(if remote-copy-program
(list (if t1 (concat ">" target) (concat "<" source)))
- (list source target))))
-
- ;; Use an asynchronous process. By this, password can
- ;; be handled. We don't set a timeout, because the
- ;; copying of large files can last longer than 60 secs.
- (let* ((command
- (mapconcat
- #'identity (append (list copy-program) copy-args)
- " "))
- (p (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (start-process-shell-command
- (tramp-get-connection-name v)
- (tramp-get-connection-buffer v)
- command))))
- (tramp-message orig-vec 6 "%s" command)
- (process-put p 'vector orig-vec)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
-
- ;; We must adapt `tramp-local-end-of-line' for
- ;; sending the password.
- (let ((tramp-local-end-of-line tramp-rsh-end-of-line))
- (tramp-process-actions
- p v nil tramp-actions-copy-out-of-band))))
+ (list source target)))
+ ;; Use an asynchronous process. By this, password
+ ;; can be handled. We don't set a timeout, because
+ ;; the copying of large files can last longer than 60
+ ;; secs.
+ p (let ((default-directory (tramp-compat-temporary-file-directory)))
+ (apply
+ #'start-process
+ (tramp-get-connection-name v)
+ (tramp-get-connection-buffer v)
+ copy-program copy-args)))
+ (tramp-message orig-vec 6 "%s" (string-join (process-command p) " "))
+ (process-put p 'vector orig-vec)
+ (process-put p 'adjust-window-size-function #'ignore)
+ (set-process-query-on-exit-flag p nil)
+
+ ;; We must adapt `tramp-local-end-of-line' for
+ ;; sending the password.
+ (let ((tramp-local-end-of-line tramp-rsh-end-of-line))
+ (tramp-process-actions
+ p v nil tramp-actions-copy-out-of-band)))
;; Reset the transfer process properties.
(tramp-flush-connection-property v "process-name")
@@ -2504,10 +2407,11 @@ The method used must be an out-of-band method."
;; Handle KEEP-DATE argument.
(when (and keep-date (not copy-keep-date))
- (set-file-times
+ (tramp-compat-set-file-times
newname
(tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ (file-attributes filename))
+ (unless ok-if-already-exists 'nofollow)))
;; Set the mode.
(unless (and keep-date copy-keep-date)
@@ -2525,7 +2429,7 @@ The method used must be an out-of-band method."
(setq dir (expand-file-name dir))
(with-parsed-tramp-file-name dir nil
(when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists "Directory already exists %s" dir))
+ (tramp-error v 'file-already-exists dir))
;; When PARENTS is non-nil, DIR could be a chain of non-existent
;; directories a/b/c/... Instead of checking, we simply flush the
;; whole cache.
@@ -2539,13 +2443,10 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (setq directory (expand-file-name directory))
- (with-parsed-tramp-file-name directory nil
- (tramp-flush-directory-properties v localname)
+ (tramp-skeleton-delete-directory directory recursive trash
(tramp-barf-unless-okay
v (format "cd / && %s %s"
- (or (and trash (tramp-get-remote-trash v))
- (if recursive "rm -rf" "rmdir"))
+ (if recursive "rm -rf" "rmdir")
(tramp-shell-quote-argument localname))
"Couldn't delete %s" directory)))
@@ -2554,11 +2455,11 @@ The method used must be an out-of-band method."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties 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)))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash filename)
+ (tramp-barf-unless-okay
+ v (format "rm -f %s" (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename))))
;; Dired.
@@ -2602,25 +2503,21 @@ The method used must be an out-of-band method."
(t nil)))))))))
(defun tramp-sh-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
+ (filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
- (setq filename (expand-file-name filename))
(unless switches (setq switches ""))
;; Check, whether directory is accessible.
(unless wildcard
(access-file filename "Reading directory"))
- (with-parsed-tramp-file-name filename nil
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
(if (and (featurep 'ls-lisp)
(not (symbol-value 'ls-lisp-use-insert-directory-program)))
(tramp-handle-insert-directory
filename switches wildcard full-directory-p)
(when (stringp switches)
(setq switches (split-string switches)))
- (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options?
- v "--quoting-style=literal --show-control-chars")
- (setq switches
- (append
- switches '("--quoting-style=literal" "--show-control-chars"))))
+ (setq switches
+ (append switches (split-string (tramp-sh--quoting-style-options v))))
(unless (tramp-get-ls-command-with v "--dired")
(setq switches (delete "--dired" switches)))
(when wildcard
@@ -2637,107 +2534,134 @@ The method used must be an out-of-band method."
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', 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 ".")))))
+ v (format "%s %s %s 2>%s"
+ (tramp-get-ls-command v)
+ switches
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument (concat localname ".")))
+ (tramp-get-remote-null-device v)))
(tramp-barf-unless-okay
- v
- (format "cd %s" (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-directory (list localname))))
+ 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 2>/dev/null"
- (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)))))))
-
- (save-restriction
- (let ((beg (point)))
- (narrow-to-region (point) (point))
- ;; We cannot use `insert-buffer-substring' because the Tramp
- ;; buffer changes its contents before insertion due to calling
- ;; `expand-file-name' and alike.
- (insert
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string)))
-
+ v (format "%s %s %s 2>%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))))
+ (tramp-get-remote-null-device v))))
+
+ (let ((beg-marker (copy-marker (point) nil))
+ (end-marker (copy-marker (point) t))
+ (emc enable-multibyte-characters))
+ ;; We cannot use `insert-buffer-substring' because the Tramp
+ ;; buffer changes its contents before insertion due to calling
+ ;; `expand-file-name' and alike.
+ (insert (with-current-buffer (tramp-get-buffer v) (buffer-string)))
+
+ ;; We must enable unibyte strings, because the "--dired"
+ ;; output counts in bytes.
+ (set-buffer-multibyte nil)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
;; Check for "--dired" output.
- (forward-line -2)
- (when (looking-at-p "//SUBDIRED//")
- (forward-line -1))
- (when (looking-at "//DIRED//\\s-+")
- (let ((databeg (match-end 0))
- (end (point-at-eol)))
+ (when (re-search-backward "^//DIRED//\\s-+\\(.+\\)$" nil 'noerror)
+ (let ((beg (match-beginning 1))
+ (end (match-end 0)))
;; Now read the numeric positions of file names.
- (goto-char databeg)
+ (goto-char beg)
(while (< (point) end)
- (let ((start (+ beg (read (current-buffer))))
- (end (+ beg (read (current-buffer)))))
+ (let ((start (+ (point-min) (read (current-buffer))))
+ (end (+ (point-min) (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))
+ (beginning-of-line)
(while (looking-at "//")
(forward-line 1)
- (delete-region (match-beginning 0) (point)))
+ (delete-region (match-beginning 0) (point))))
+ ;; Reset multibyte if needed.
+ (set-buffer-multibyte emc)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
;; Some busyboxes are reluctant to discard colors.
(unless
(string-match-p "color" (tramp-get-connection-property v "ls" ""))
- (goto-char beg)
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
+ (goto-char (point-min))
+ (while (re-search-forward tramp-display-escape-sequence-regexp nil t)
(replace-match "")))
- ;; Decode the output, it could be multibyte.
- (decode-coding-region
- beg (point-max)
- (or file-name-coding-system default-file-name-coding-system))
+ ;; Now decode what read if necessary. Stolen from `insert-directory'.
+ (let ((coding (or coding-system-for-read
+ file-name-coding-system
+ default-file-name-coding-system
+ 'undecided))
+ coding-no-eol
+ val pos)
+ (when (and enable-multibyte-characters
+ (not (memq (coding-system-base coding)
+ '(raw-text no-conversion))))
+ ;; If no coding system is specified or detection is
+ ;; requested, detect the coding.
+ (if (eq (coding-system-base coding) 'undecided)
+ (setq coding (detect-coding-region (point-min) (point) t)))
+ (unless (eq (coding-system-base coding) 'undecided)
+ (setq coding-no-eol
+ (coding-system-change-eol-conversion coding 'unix))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq pos (point)
+ val (get-text-property (point) 'dired-filename))
+ (goto-char (next-single-property-change
+ (point) 'dired-filename nil (point-max)))
+ ;; Force no eol conversion on a file name, so that
+ ;; CR is preserved.
+ (decode-coding-region
+ pos (point) (if val coding-no-eol coding))
+ (if val (put-text-property pos (point) 'dired-filename t))))))
;; 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)))
+ (goto-char (search-backward "->" (point-min) 'noerror)))
(search-backward
- (if (tramp-compat-directory-name-p filename)
+ (if (directory-name-p filename)
"."
(file-name-nondirectory filename))
- beg 'noerror)
+ (point-min) 'noerror)
(replace-match (file-relative-name filename) t))
;; Try to insert the amount of free space.
(goto-char (point-min))
;; First find the line to put it on.
(when (re-search-forward "^\\([[:space:]]*total\\)" nil t)
- (let ((available (get-free-disk-space ".")))
- (when available
- ;; Replace "total" with "total used", to avoid confusion.
- (replace-match "\\1 used in directory")
- (end-of-line)
- (insert " available " available))))
+ (when-let ((available (get-free-disk-space ".")))
+ ;; Replace "total" with "total used", to avoid confusion.
+ (replace-match "\\1 used in directory")
+ (end-of-line)
+ (insert " available " available))))
- (goto-char (point-max)))))))
+ (prog1 (goto-char end-marker)
+ (set-marker beg-marker nil)
+ (set-marker end-marker nil))))))
;; Canonicalization of file names.
@@ -2749,282 +2673,297 @@ the result will be a local, non-Tramp, file name."
(setq dir (or dir default-directory "/"))
;; Handle empty NAME.
(when (zerop (length name)) (setq name "."))
- ;; Unless NAME is absolute, concat DIR and NAME.
- (unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
- ;; If connection is not established yet, 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-p "\\`su\\(do\\)?\\'" method))
- (setq uname (concat uname user)))
- (setq uname
- (with-tramp-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 "/../").
- ;; `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
- v (tramp-drop-volume-letter
- (tramp-run-real-handler
- #'expand-file-name (list localname))))))))
+ ;; On MS Windows, some special file names are not returned properly
+ ;; by `file-name-absolute-p'.
+ (if (and (eq system-type 'windows-nt)
+ (string-match-p
+ (concat "^\\([[:alpha:]]:\\|" null-device "$\\)") name))
+ (tramp-run-real-handler #'expand-file-name (list name dir))
+ ;; Unless NAME is absolute, concat DIR and NAME.
+ (unless (file-name-absolute-p name)
+ (setq name (tramp-compat-file-name-concat dir name)))
+ ;; If connection is not established yet, 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-p "\\`su\\(do\\)?\\'" method))
+ (setq uname (concat uname user)))
+ (setq uname
+ (with-tramp-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)))
+ ;; Do not keep "/..".
+ (when (string-match-p "^/\\.\\.?$" localname)
+ (setq localname "/"))
+ ;; No tilde characters in file name, do normal
+ ;; `expand-file-name' (this does "/./" and "/../").
+ ;; `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
+ v (tramp-drop-volume-letter
+ (tramp-run-real-handler
+ #'expand-file-name (list localname)))))))))
;;; Remote commands:
;; 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.
-;; The complete STDERR buffer is available only when the process has
-;; terminated.
(defun tramp-sh-handle-make-process (&rest args)
"Like `make-process' for Tramp files.
-STDERR can also be a file name."
- (when args
- (with-parsed-tramp-file-name (expand-file-name default-directory) nil
- (let ((name (plist-get args :name))
- (buffer (plist-get args :buffer))
- (command (plist-get args :command))
- (coding (plist-get args :coding))
- (noquery (plist-get args :noquery))
- (connection-type (plist-get args :connection-type))
- (filter (plist-get args :filter))
- (sentinel (plist-get args :sentinel))
- (stderr (plist-get args :stderr)))
- (unless (stringp name)
- (signal 'wrong-type-argument (list #'stringp name)))
- (unless (or (null buffer) (bufferp buffer) (stringp buffer))
- (signal 'wrong-type-argument (list #'stringp buffer)))
- (unless (or (null command) (consp command))
- (signal 'wrong-type-argument (list #'consp command)))
- (unless (or (null coding)
- (and (symbolp coding) (memq coding coding-system-list))
- (and (consp coding)
- (memq (car coding) coding-system-list)
- (memq (cdr coding) coding-system-list)))
- (signal 'wrong-type-argument (list #'symbolp coding)))
- (unless (or (null connection-type) (memq connection-type '(pipe pty)))
- (signal 'wrong-type-argument (list #'symbolp connection-type)))
- (unless (or (null filter) (functionp filter))
- (signal 'wrong-type-argument (list #'functionp filter)))
- (unless (or (null sentinel) (functionp sentinel))
- (signal 'wrong-type-argument (list #'functionp sentinel)))
- (unless (or (null stderr) (bufferp stderr) (stringp stderr))
- (signal 'wrong-type-argument (list #'stringp stderr)))
- (when (and (stringp stderr) (tramp-tramp-file-p stderr)
- (not (tramp-equal-remote default-directory stderr)))
- (signal 'file-error (list "Wrong stderr" stderr)))
-
- (let* ((buffer
- (if buffer
- (get-buffer-create buffer)
- ;; BUFFER can be nil. We use a temporary buffer.
- (generate-new-buffer tramp-temp-buffer-name)))
- ;; STDERR can also be a file name.
- (tmpstderr
- (and stderr
- (if (and (stringp stderr) (tramp-tramp-file-p stderr))
- (tramp-unquote-file-local-name stderr)
- (tramp-make-tramp-temp-file v))))
- (remote-tmpstderr
- (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
- (program (car command))
- (args (cdr command))
- ;; When PROGRAM matches "*sh", and the first arg is
- ;; "-c", it might be that the arguments exceed the
- ;; command line length. Therefore, we modify the
- ;; command.
- (heredoc (and (stringp program)
- (string-match-p "sh$" program)
- (= (length args) 2)
- (string-equal "-c" (car args))
- ;; Don't if there is a string.
- (not (string-match-p "'\\|\"" (cadr args)))))
- ;; When PROGRAM is nil, we just provide a tty.
- (args (if (not heredoc) args
- (let ((i 250))
- (while (and (< i (length (cadr args)))
- (string-match " " (cadr args) i))
- (setcdr
- args
- (list
- (replace-match " \\\\\n" nil nil (cadr args))))
- (setq i (+ i 250))))
- (cdr args)))
- ;; Use a human-friendly prompt, for example for
- ;; `shell'. We discard hops, if existing, that's why
- ;; we cannot use `file-remote-p'.
- (prompt (format "PS1=%s %s"
- (tramp-make-tramp-file-name v nil 'nohop)
- tramp-initial-end-of-output))
- ;; We use as environment the difference to toplevel
- ;; `process-environment'.
- env uenv
- (env (dolist (elt (cons prompt process-environment) env)
- (or (member
- elt (default-toplevel-value 'process-environment))
- (if (string-match-p "=" elt)
- (setq env (append env `(,elt)))
- (if (tramp-get-env-with-u-option v)
- (setq env (append `("-u" ,elt) env))
- (setq uenv (cons elt uenv)))))))
- (command
- (when (stringp program)
- (format "cd %s && %s exec %s %s env %s %s"
- (tramp-shell-quote-argument localname)
- (if uenv
- (format
- "unset %s &&"
- (mapconcat
- #'tramp-shell-quote-argument uenv " "))
- "")
- (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "")
- (if tmpstderr (format "2>'%s'" tmpstderr) "")
- (mapconcat #'tramp-shell-quote-argument env " ")
- (if heredoc
- (format "%s\n(\n%s\n) </dev/tty\n%s"
- program (car args) tramp-end-of-heredoc)
- (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)
- ;; We do not want to raise an error when `make-process'
- ;; has been started several times in `eshell' and
- ;; friends.
- tramp-current-connection
- p)
-
- (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)
-
- (with-current-buffer (tramp-get-connection-buffer v)
- (unwind-protect
- ;; We catch this event. Otherwise, `make-process' could
- ;; be called on the local host.
- (save-excursion
- (save-restriction
- ;; Activate narrowing in order to save BUFFER
- ;; contents. Clear also the modification time;
- ;; otherwise we might be interrupted by
- ;; `verify-visited-file-modtime'.
- (let ((buffer-undo-list t)
- (inhibit-read-only t)
- (mark (point-max)))
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max))
- ;; We call `tramp-maybe-open-connection', in
- ;; order to cleanup the prompt afterwards.
- (catch 'suppress
- (tramp-maybe-open-connection v)
- (setq p (tramp-get-connection-process v))
- ;; Set the pid of the remote shell. This is
- ;; needed when sending signals remotely.
- (let ((pid (tramp-send-command-and-read v "echo $$")))
- (process-put p 'remote-pid pid)
- (tramp-set-connection-property p "remote-pid" pid))
- ;; `tramp-maybe-open-connection' and
- ;; `tramp-send-command-and-read' could have
- ;; trashed the connection buffer. Remove this.
- (widen)
- (delete-region mark (point-max))
+STDERR can also be a remote file name. If method parameter
+`tramp-direct-async' and connection property
+\"direct-async-process\" are non-nil, an alternative
+implementation will be used."
+ (if (tramp-direct-async-process-p args)
+ (apply #'tramp-handle-make-process args)
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (or (null command) (consp command))
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr) (stringp stderr))
+ (signal 'wrong-type-argument (list #'bufferp stderr)))
+ (when (and (stringp stderr)
+ (not (tramp-equal-remote default-directory stderr)))
+ (signal 'file-error (list "Wrong stderr" stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ ;; STDERR can also be a file name.
+ (tmpstderr
+ (and stderr
+ (tramp-unquote-file-local-name
+ (if (stringp stderr)
+ stderr (tramp-make-tramp-temp-name v)))))
+ (remote-tmpstderr
+ (and tmpstderr (tramp-make-tramp-file-name v tmpstderr)))
+ (program (car command))
+ (args (cdr command))
+ ;; When PROGRAM matches "*sh", and the first arg is
+ ;; "-c", it might be that the arguments exceed the
+ ;; command line length. Therefore, we modify the
+ ;; command.
+ (heredoc (and (not (bufferp stderr))
+ (stringp program)
+ (string-match-p "sh$" program)
+ (= (length args) 2)
+ (string-equal "-c" (car args))
+ ;; Don't if there is a string.
+ (not (string-match-p "'\\|\"" (cadr args)))))
+ ;; When PROGRAM is nil, we just provide a tty.
+ (args (if (not heredoc) args
+ (let ((i 250))
+ (while (and (< i (length (cadr args)))
+ (string-match " " (cadr args) i))
+ (setcdr
+ args
+ (list
+ (replace-match " \\\\\n" nil nil (cadr args))))
+ (setq i (+ i 250))))
+ (cdr args)))
+ ;; Use a human-friendly prompt, for example for
+ ;; `shell'. We discard hops, if existing, that's why
+ ;; we cannot use `file-remote-p'.
+ (prompt (format "PS1=%s %s"
+ (tramp-make-tramp-file-name v nil 'nohop)
+ tramp-initial-end-of-output))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ env uenv
+ (env (dolist (elt (cons prompt process-environment) env)
+ (or (member
+ elt (default-toplevel-value 'process-environment))
+ (if (string-match-p "=" elt)
+ (setq env (append env `(,elt)))
+ (setq uenv (cons elt uenv))))))
+ (env (setenv-internal
+ env "INSIDE_EMACS" (tramp-inside-emacs) 'keep))
+ (command
+ (when (stringp program)
+ (format "cd %s && %s exec %s %s env %s %s"
+ (tramp-shell-quote-argument localname)
+ (if uenv
+ (format
+ "unset %s &&"
+ (mapconcat
+ #'tramp-shell-quote-argument uenv " "))
+ "")
+ (if heredoc
+ (format "<<'%s'" tramp-end-of-heredoc) "")
+ (if tmpstderr (format "2>'%s'" tmpstderr) "")
+ (mapconcat #'tramp-shell-quote-argument env " ")
+ (if heredoc
+ (format "%s\n(\n%s\n) </dev/tty\n%s"
+ program (car args) tramp-end-of-heredoc)
+ (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)
+ ;; We do not want to raise an error when
+ ;; `make-process' has been started several times in
+ ;; `eshell' and friends.
+ tramp-current-connection
+ p)
+
+ ;; Handle error buffer.
+ (when (bufferp stderr)
+ (with-current-buffer stderr
+ (setq buffer-read-only nil))
+ ;; Create named pipe.
+ (tramp-send-command v (format "mknod %s p" tmpstderr))
+ ;; Create stderr process.
+ (make-process
+ :name (buffer-name stderr)
+ :buffer stderr
+ :command `("cat" ,tmpstderr)
+ :coding coding
+ :noquery t
+ :filter nil
+ :sentinel #'ignore
+ :file-handler t))
+
+ (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)
+
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (unwind-protect
+ ;; We catch this event. Otherwise, `make-process'
+ ;; could be called on the local host.
+ (save-excursion
+ (save-restriction
+ ;; Activate narrowing in order to save BUFFER
+ ;; contents. Clear also the modification time;
+ ;; otherwise we might be interrupted by
+ ;; `verify-visited-file-modtime'.
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t)
+ (mark (point-max))
+ (coding-system-for-write
+ (if (symbolp coding) coding (car coding)))
+ (coding-system-for-read
+ (if (symbolp coding) coding (cdr coding))))
+ (clear-visited-file-modtime)
(narrow-to-region (point-max) (point-max))
- ;; Now do it.
- (if command
- ;; Send the command.
- (tramp-send-command v command nil t) ; nooutput
- ;; Check, whether a pty is associated.
- (unless (process-get p 'remote-tty)
- (tramp-error
- v 'file-error
- "pty association is not supported for `%s'"
- name))))
- ;; Set sentinel and filter.
- (when sentinel
- (set-process-sentinel p sentinel))
- (when filter
- (set-process-filter p filter))
- ;; Set query flag and process marker for this
- ;; process. We ignore errors, because the
- ;; process could have finished already.
- (ignore-errors
- (set-process-query-on-exit-flag p (null noquery))
- (set-marker (process-mark p) (point)))
- ;; We must flush them here already; otherwise
- ;; `rename-file', `delete-file' or
- ;; `insert-file-contents' will fail.
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer")
- ;; Copy tmpstderr file.
- (when (and (stringp stderr)
- (not (tramp-tramp-file-p stderr)))
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (rename-file remote-tmpstderr stderr))))
- ;; Provide error buffer. This shows only
- ;; initial error messages; messages arriving
- ;; later on will be inserted when the process is
- ;; deleted. The temporary file will exist until
- ;; the process is deleted.
- (when (bufferp stderr)
- (with-current-buffer stderr
- (insert-file-contents-literally remote-tmpstderr))
- ;; Delete tmpstderr file.
- (add-function
- :after (process-sentinel p)
- (lambda (_proc _msg)
- (when (file-exists-p remote-tmpstderr)
- (with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr nil nil nil 'replace))
- (delete-file remote-tmpstderr)))))
- ;; Return process.
- p)))
+ (catch 'suppress
+ ;; Set the pid of the remote shell. This is
+ ;; needed when sending signals remotely.
+ (let ((pid (tramp-send-command-and-read v "echo $$")))
+ (setq p (tramp-get-connection-process v))
+ (process-put p 'remote-pid pid)
+ (tramp-set-connection-property p "remote-pid" pid))
+ ;; `tramp-maybe-open-connection' and
+ ;; `tramp-send-command-and-read' could have
+ ;; trashed the connection buffer. Remove this.
+ (widen)
+ (delete-region mark (point-max))
+ (narrow-to-region (point-max) (point-max))
+ ;; Now do it.
+ (if command
+ ;; Send the command.
+ (tramp-send-command v command nil t) ; nooutput
+ ;; Check, whether a pty is associated.
+ (unless (process-get p 'remote-tty)
+ (tramp-error
+ v 'file-error
+ "pty association is not supported for `%s'"
+ name))))
+ ;; Set sentinel and filter.
+ (when sentinel
+ (set-process-sentinel p sentinel))
+ (when filter
+ (set-process-filter p filter))
+ ;; Set query flag and process marker for this
+ ;; process. We ignore errors, because the
+ ;; process could have finished already.
+ (ignore-errors
+ (set-process-query-on-exit-flag p (null noquery))
+ (set-marker (process-mark p) (point)))
+ ;; Kill stderr process delete and named pipe.
+ (when (bufferp stderr)
+ (add-function
+ :after (process-sentinel p)
+ (lambda (_proc _msg)
+ (ignore-errors
+ (while (accept-process-output
+ (get-buffer-process stderr) 0 nil t))
+ (delete-process (get-buffer-process stderr)))
+ (ignore-errors
+ (delete-file remote-tmpstderr)))))
+ ;; Return process.
+ p)))
- ;; Save exit.
- (if (string-match-p tramp-temp-buffer-name (buffer-name))
- (ignore-errors
- (set-process-buffer p nil)
- (kill-buffer (current-buffer)))
- (set-buffer-modified-p bmp))
- (tramp-flush-connection-property v "process-name")
- (tramp-flush-connection-property v "process-buffer"))))))))
+ ;; Save exit.
+ (if (string-match-p tramp-temp-buffer-name (buffer-name))
+ (ignore-errors
+ (set-process-buffer p nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")))))))))
(defun tramp-sh-get-signal-strings (vec)
"Strings to return by `process-file' in case of signals."
@@ -3092,7 +3031,7 @@ STDERR can also be a file name."
(when (and (numberp destination) (zerop destination))
(error "Implementation does not handle immediate return"))
- (with-parsed-tramp-file-name default-directory nil
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
(let (command env uenv input tmpinput stderr tmpstderr outbuf ret)
;; Compute command.
(setq command (mapconcat #'tramp-shell-quote-argument
@@ -3102,9 +3041,8 @@ STDERR can also be a file name."
(or (member elt (default-toplevel-value 'process-environment))
(if (string-match-p "=" elt)
(setq env (append env `(,elt)))
- (if (tramp-get-env-with-u-option v)
- (setq env (append `("-u" ,elt) env))
- (setq uenv (cons elt uenv))))))
+ (setq uenv (cons elt uenv)))))
+ (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)
(when env
(setq command
(format
@@ -3117,7 +3055,7 @@ STDERR can also be a file name."
(mapconcat #'tramp-shell-quote-argument uenv " ") command)))
;; Determine input.
(if (null infile)
- (setq input "/dev/null")
+ (setq input (tramp-get-remote-null-device v))
(setq infile (expand-file-name infile))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
@@ -3159,7 +3097,7 @@ STDERR can also be a file name."
tmpstderr (tramp-make-tramp-file-name v stderr 'nohop))))
;; stderr to be discarded.
((null (cadr destination))
- (setq stderr "/dev/null"))))
+ (setq stderr (tramp-get-remote-null-device v)))))
;; 't
(destination
(setq outbuf (current-buffer))))
@@ -3225,9 +3163,7 @@ STDERR can also be a file name."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p (file-truename filename))
- (tramp-error
- v tramp-file-missing
- "Cannot make local copy of non-existing file `%s'" filename))
+ (tramp-compat-file-missing v filename))
(let* ((size (tramp-compat-file-attribute-size
(file-attributes (file-truename filename))))
@@ -3262,7 +3198,9 @@ STDERR can also be a file name."
;; correctly. Unset `file-name-handler-alist'.
;; Otherwise, epa-file gets confused.
(let (file-name-handler-alist
- (coding-system-for-write 'binary))
+ (coding-system-for-write 'binary)
+ (default-directory
+ (tramp-compat-temporary-file-directory)))
(with-temp-file tmpfile
(set-buffer-multibyte nil)
(insert-buffer-substring (tramp-get-buffer v))
@@ -3300,11 +3238,11 @@ STDERR can also be a file name."
(run-hooks 'tramp-handle-file-local-copy-hook)
tmpfile)))
-;; CCC grok LOCKNAME
(defun tramp-sh-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -3313,27 +3251,34 @@ STDERR can also be a file name."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((uid (or (tramp-compat-file-attribute-user-id
+ (let ((file-locked (eq (file-locked-p lockname) t))
+ (uid (or (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
(gid (or (tramp-compat-file-attribute-group-id
(file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer))))
+ ;; Lock file.
+ (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
+ (file-remote-p lockname)
+ (not file-locked))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(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)))))
+ (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))
+ (let ((create-lockfiles (not file-locked)))
+ (write-region start end localname append 'no-message lockname))
- (let* ((modes (save-excursion (tramp-default-file-modes filename)))
+ (let* ((modes (tramp-default-file-modes
+ filename (and (eq mustbenew 'excl) 'nofollow)))
;; 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
@@ -3363,13 +3308,11 @@ STDERR can also be a file name."
;; 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)))
+ (let ((file-coding-system-alist
+ (tramp-find-file-name-coding-system-alist filename tmpfile))
+ create-lockfiles)
(condition-case err
- (tramp-run-real-handler
- #'write-region
- (list start end tmpfile append 'no-message lockname))
+ (write-region start end tmpfile append 'no-message)
((error quit)
(setq tramp-temp-buffer-file-name nil)
(delete-file tmpfile)
@@ -3452,9 +3395,8 @@ STDERR can also be a file name."
loc-enc tmpfile t))
(tramp-error
v 'file-error
- (eval-when-compile
- (concat "Cannot write to `%s', "
- "local encoding command `%s' failed"))
+ (concat "Cannot write to `%s', "
+ "local encoding command `%s' failed")
filename loc-enc))))
;; Send buffer into remote decoding command which
@@ -3499,9 +3441,8 @@ STDERR can also be a file name."
(buffer-string))))
(tramp-error
v 'file-error
- (eval-when-compile
- (concat "Couldn't write region to `%s',"
- " decode using `%s' failed"))
+ (concat "Couldn't write region to `%s',"
+ " decode using `%s' failed")
filename rem-dec)))))
;; Save exit.
@@ -3511,14 +3452,13 @@ STDERR can also be a file name."
(t
(tramp-error
v 'file-error
- (eval-when-compile
- (concat "Method `%s' should specify both encoding and "
- "decoding command or an scp program"))
+ (concat "Method `%s' should specify both encoding and "
+ "decoding command or an scp program")
method))))
;; Make `last-coding-system-used' have the right value.
(when coding-system-used
- (set 'last-coding-system-used coding-system-used))))
+ (setq last-coding-system-used coding-system-used))))
(tramp-flush-file-properties v localname)
@@ -3532,7 +3472,8 @@ STDERR can also be a file name."
;; We must pass modtime explicitly, because FILENAME can
;; be different from (buffer-file-name), f.e. if
;; `file-precious-flag' is set.
- (tramp-compat-file-attribute-modification-time file-attr))
+ (or (tramp-compat-file-attribute-modification-time file-attr)
+ (current-time)))
(when (and (= (tramp-compat-file-attribute-user-id file-attr) uid)
(= (tramp-compat-file-attribute-group-id file-attr) gid))
(setq need-chown nil))))
@@ -3540,6 +3481,12 @@ STDERR can also be a file name."
;; Set the ownership.
(when need-chown
(tramp-set-file-uid-gid filename uid gid))
+
+ ;; Unlock file.
+ (when file-locked
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
(when (and (null noninteractive)
(or (eq visit t) (null visit) (stringp visit)))
(tramp-message v 0 "Wrote %s" filename))
@@ -3566,8 +3513,7 @@ STDERR can also be a file name."
(defun tramp-sh-handle-vc-registered (file)
"Like `vc-registered' for Tramp files."
(when vc-handled-backends
- (let ((tramp-message-show-message
- (and (not revert-buffer-in-progress-p) tramp-message-show-message))
+ (let ((inhibit-message (or revert-buffer-in-progress-p inhibit-message))
(temp-message (unless revert-buffer-in-progress-p "")))
(with-temp-message temp-message
(with-parsed-tramp-file-name file nil
@@ -3626,27 +3572,30 @@ STDERR can also be a file name."
;; calls shall be answered from the file cache. We unset
;; `process-file-side-effects' and `remote-file-name-inhibit-cache'
;; in order to keep the cache.
- (let ((vc-handled-backends vc-handled-backends)
+ (let ((vc-handled-backends (copy-sequence vc-handled-backends))
remote-file-name-inhibit-cache process-file-side-effects)
;; Reduce `vc-handled-backends' in order to minimize
;; process calls.
- (when (and (memq 'Bzr vc-handled-backends)
- (boundp 'vc-bzr-program)
+ (when (and
+ (memq 'Bzr vc-handled-backends)
+ (or (not (require 'vc-bzr nil 'noerror))
(not (with-tramp-connection-property v vc-bzr-program
(tramp-find-executable
- v vc-bzr-program (tramp-get-remote-path v)))))
+ v vc-bzr-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Bzr vc-handled-backends)))
- (when (and (memq 'Git vc-handled-backends)
- (boundp 'vc-git-program)
+ (when (and
+ (memq 'Git vc-handled-backends)
+ (or (not (require 'vc-git nil 'noerror))
(not (with-tramp-connection-property v vc-git-program
(tramp-find-executable
- v vc-git-program (tramp-get-remote-path v)))))
+ v vc-git-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Git vc-handled-backends)))
- (when (and (memq 'Hg vc-handled-backends)
- (boundp 'vc-hg-program)
+ (when (and
+ (memq 'Hg vc-handled-backends)
+ (or (not (require 'vc-hg nil 'noerror))
(not (with-tramp-connection-property v vc-hg-program
(tramp-find-executable
- v vc-hg-program (tramp-get-remote-path v)))))
+ v vc-hg-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Hg vc-handled-backends)))
;; Run.
(tramp-with-demoted-errors
@@ -3657,10 +3606,17 @@ STDERR can also be a file name."
(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."
- (let ((fn (assoc operation tramp-sh-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+ (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
+
+;;;###tramp-autoload
+(defun tramp-sh-file-name-handler-p (vec)
+ "Whether VEC uses a method from `tramp-sh-file-name-handler'."
+ (and (assoc (tramp-file-name-method vec) tramp-methods)
+ (eq (tramp-find-foreign-file-name-handler
+ (tramp-make-tramp-file-name vec nil 'nohop))
+ 'tramp-sh-file-name-handler)))
;; This must be the last entry, because `identity' always matches.
;;;###tramp-autoload
@@ -3704,6 +3660,8 @@ Fall back to normal file name handler if no Tramp handler exists."
(setq file-name (expand-file-name file-name))
(with-parsed-tramp-file-name file-name nil
(let ((default-directory (file-name-directory file-name))
+ (process-environment
+ (cons "GIO_USE_FILE_MONITOR=help" process-environment))
command events filter p sequence)
(cond
;; "inotifywait".
@@ -3712,19 +3670,17 @@ Fall back to normal file name handler if no Tramp handler exists."
events
(cond
((and (memq 'change flags) (memq 'attribute-change flags))
- (eval-when-compile
- (concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,attrib,ignored")))
+ (concat "create,modify,move,moved_from,moved_to,move_self,"
+ "delete,delete_self,attrib,ignored"))
((memq 'change flags)
- (eval-when-compile
- (concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,ignored")))
+ (concat "create,modify,move,moved_from,moved_to,move_self,"
+ "delete,delete_self,ignored"))
((memq 'attribute-change flags) "attrib,ignored"))
sequence `(,command "-mq" "-e" ,events ,localname)
;; Make events a list of symbols.
events
(mapcar
- (lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x)))
+ (lambda (x) (intern-soft (tramp-compat-string-replace "_" "-" x)))
(split-string events "," 'omit))))
;; "gio monitor".
((setq command (tramp-get-remote-gio-monitor v))
@@ -3738,18 +3694,6 @@ Fall back to normal file name handler if no Tramp handler exists."
'(created changed changes-done-hint moved deleted))
((memq 'attribute-change flags) '(attribute-changed)))
sequence `(,command "monitor" ,localname)))
- ;; "gvfs-monitor-dir".
- ((setq command (tramp-get-remote-gvfs-monitor-dir v))
- (setq filter #'tramp-sh-gvfs-monitor-dir-process-filter
- events
- (cond
- ((and (memq 'change flags) (memq 'attribute-change flags))
- '(created changed changes-done-hint moved deleted
- attribute-changed))
- ((memq 'change flags)
- '(created changed changes-done-hint moved deleted))
- ((memq 'attribute-change flags) '(attribute-changed)))
- sequence `(,command ,localname)))
;; None.
(t (tramp-error
v 'file-notify-error
@@ -3790,106 +3734,85 @@ Fall back to normal file name handler if no Tramp handler exists."
(remote-prefix
(with-current-buffer (process-buffer proc)
(file-remote-p default-directory)))
- (rest-string (process-get proc 'rest-string)))
+ (rest-string (process-get proc 'rest-string))
+ pos)
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
(tramp-message proc 6 "%S\n%s" proc string)
(setq string (concat rest-string string)
;; Fix action names.
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"attributes changed" "attribute-changed" string)
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"changes done" "changes-done-hint" string)
- string (replace-regexp-in-string
+ string (tramp-compat-string-replace
"renamed to" "moved" string))
- ;; https://bugs.launchpad.net/bugs/1742946
- (when
- (string-match-p "Monitoring not supported\\|No locations given" string)
- (delete-process proc))
-
- ;; Delete empty lines.
- (setq string (replace-regexp-in-string "\n\n" "\n" string))
-
- (while (string-match
- (eval-when-compile
- (concat "^[^:]+:"
- "[[:space:]]\\([^:]+\\):"
- "[[:space:]]" (regexp-opt tramp-gio-events t)
- "\\([[:space:]]\\([^:]+\\)\\)?$"))
- string)
-
- (let* ((file (match-string 1 string))
- (file1 (match-string 4 string))
- (object
- (list
- proc
- (list
- (intern-soft (match-string 2 string)))
- ;; File names are returned as absolute paths. We must
- ;; add the remote prefix.
- (concat remote-prefix file)
- (when file1 (concat remote-prefix file1)))))
- (setq string (replace-match "" nil nil string))
- ;; Usually, we would add an Emacs event now. Unfortunately,
- ;; `unread-command-events' does not accept several events at
- ;; once. Therefore, we apply the handler directly.
- (when (member (cl-caadr object) events)
- (tramp-compat-funcall
- (lookup-key special-event-map [file-notify])
- `(file-notify ,object file-notify-callback)))))
- ;; Save rest of the string.
- (when (zerop (length string)) (setq string nil))
- (when string (tramp-message proc 10 "Rest string:\n%s" string))
- (process-put proc 'rest-string string)))
-
-(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string)
- "Read output from \"gvfs-monitor-dir\" and add corresponding \
-`file-notify' events."
- (let ((events (process-get proc 'events))
- (remote-prefix
- (with-current-buffer (process-buffer proc)
- (file-remote-p default-directory)))
- (rest-string (process-get proc 'rest-string)))
- (when rest-string
- (tramp-message proc 10 "Previous string:\n%s" rest-string))
- (tramp-message proc 6 "%S\n%s" proc string)
- (setq string (concat rest-string string)
- ;; Attribute change is returned in unused wording.
- string (replace-regexp-in-string
- "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
-
- (while (string-match
- (eval-when-compile
- (concat "^[\n\r]*"
- "Directory Monitor Event:[\n\r]+"
- "Child = \\([^\n\r]+\\)[\n\r]+"
- "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?"
- "Event = \\([^[:blank:]]+\\)[\n\r]+"))
- string)
- (let* ((file (match-string 1 string))
- (file1 (match-string 3 string))
- (object
- (list
- proc
- (list
- (intern-soft
- (replace-regexp-in-string
- "_" "-" (downcase (match-string 4 string)))))
- ;; File names are returned as absolute paths. We must
- ;; add the remote prefix.
- (concat remote-prefix file)
- (when file1 (concat remote-prefix file1)))))
- (setq string (replace-match "" nil nil string))
- ;; Usually, we would add an Emacs event now. Unfortunately,
- ;; `unread-command-events' does not accept several events at
- ;; once. Therefore, we apply the handler directly.
- (when (member (cl-caadr object) events)
- (tramp-compat-funcall
- (lookup-key special-event-map [file-notify])
- `(file-notify ,object file-notify-callback)))))
+ (catch 'doesnt-work
+ ;; https://bugs.launchpad.net/bugs/1742946
+ (when
+ (string-match-p "Monitoring not supported\\|No locations given" string)
+ (delete-process proc)
+ (throw 'doesnt-work nil))
+
+ ;; Determine monitor name.
+ (unless (tramp-connection-property-p proc "gio-file-monitor")
+ (tramp-set-connection-property
+ proc "gio-file-monitor"
+ (cond
+ ;; We have seen this on cygwin gio and on emba. Let's make
+ ;; some assumptions.
+ ((string-match
+ "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string)
+ (setq pos (match-end 0))
+ (cond
+ ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor)
+ ((eq system-type 'cygwin) 'GPollFileMonitor)
+ (t nil)))
+ ;; TODO: What happens, if several monitor names are reported?
+ ((string-match "\
+Supported arguments for GIO_USE_FILE_MONITOR environment variable:
+\\s-*\\([[:alpha:]]+\\) - 20" string)
+ (setq pos (match-end 0))
+ (intern
+ (format "G%sFileMonitor" (capitalize (match-string 1 string)))))
+ (t (setq pos (length string)) nil)))
+ (setq string (substring string pos)))
+
+ ;; Delete empty lines.
+ (setq string (tramp-compat-string-replace "\n\n" "\n" string))
+
+ (while (string-match
+ (eval-when-compile
+ (concat "^[^:]+:"
+ "[[:space:]]\\([^:]+\\):"
+ "[[:space:]]" (regexp-opt tramp-gio-events t)
+ "\\([[:space:]]\\([^:]+\\)\\)?$"))
+ string)
+
+ (let* ((file (match-string 1 string))
+ (file1 (match-string 4 string))
+ (object
+ (list
+ proc
+ (list
+ (intern-soft (match-string 2 string)))
+ ;; File names are returned as absolute paths. We
+ ;; must add the remote prefix.
+ (concat remote-prefix file)
+ (when file1 (concat remote-prefix file1)))))
+ (setq string (replace-match "" nil nil string))
+ ;; Usually, we would add an Emacs event now. Unfortunately,
+ ;; `unread-command-events' does not accept several events at
+ ;; once. Therefore, we apply the handler directly.
+ (when (member (cl-caadr object) events)
+ (tramp-compat-funcall
+ (lookup-key special-event-map [file-notify])
+ `(file-notify ,object file-notify-callback))))))
;; Save rest of the string.
+ (while (string-match "^\n" string)
+ (setq string (replace-match "" nil nil string)))
(when (zerop (length string)) (setq string nil))
(when string (tramp-message proc 10 "Rest string:\n%s" string))
(process-put proc 'rest-string string)))
@@ -3901,12 +3824,11 @@ Fall back to normal file name handler if no Tramp handler exists."
(dolist (line (split-string string "[\n\r]+" 'omit))
;; Check, whether there is a problem.
(unless (string-match
- (eval-when-compile
- (concat "^[^[:blank:]]+"
- "[[:blank:]]+\\([^[:blank:]]+\\)"
- "\\([[:blank:]]+\\([^\n\r]+\\)\\)?"))
+ (concat "^[^[:blank:]]+"
+ "[[:blank:]]+\\([^[:blank:]]+\\)"
+ "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")
line)
- (tramp-error proc 'file-notify-error "%s" line))
+ (tramp-error proc 'file-notify-error line))
(let ((object
(list
@@ -3914,7 +3836,7 @@ Fall back to normal file name handler if no Tramp handler exists."
(mapcar
(lambda (x)
(intern-soft
- (replace-regexp-in-string "_" "-" (downcase x))))
+ (tramp-compat-string-replace "_" "-" (downcase x))))
(split-string (match-string 1 line) "," 'omit))
(or (match-string 3 line)
(file-name-nondirectory (process-get proc 'watch-name))))))
@@ -3940,11 +3862,10 @@ Fall back to normal file name handler if no Tramp handler exists."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (eval-when-compile
- (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?"
- "[[:space:]]*\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)")))
+ (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?"
+ "[[:space:]]*\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"))
(mapcar
(lambda (d)
(* d (tramp-get-connection-property v "df-blocksize" 0)))
@@ -3957,6 +3878,51 @@ Fall back to normal file name handler if no Tramp handler exists."
;;; Internal Functions:
+(defun tramp-expand-script (vec script)
+ "Expand SCRIPT with remote files or commands.
+\"%a\", \"%h\", \"%o\" and \"%p\" format specifiers are replaced
+by the respective `awk', `hexdump', `od' and `perl' commands.
+\"%n\" is replaced by \"2>/dev/null\", and \"%t\" is replaced by
+a temporary file name.
+If VEC is nil, the respective local commands are used.
+If there is a format specifier which cannot be expanded, this
+function returns nil."
+ (if (not (string-match-p "\\(^\\|[^%]\\)%[ahnopt]" script))
+ script
+ (catch 'wont-work
+ (let ((awk (when (string-match-p "\\(^\\|[^%]\\)%a" script)
+ (or
+ (if vec (tramp-get-remote-awk vec) (executable-find "awk"))
+ (throw 'wont-work nil))))
+ (hdmp (when (string-match-p "\\(^\\|[^%]\\)%h" script)
+ (or
+ (if vec (tramp-get-remote-hexdump vec)
+ (executable-find "hexdump"))
+ (throw 'wont-work nil))))
+ (dev (when (string-match-p "\\(^\\|[^%]\\)%n" script)
+ (or
+ (if vec (concat "2>" (tramp-get-remote-null-device vec))
+ (if (eq system-type 'windows-nt) ""
+ (concat "2>" null-device)))
+ (throw 'wont-work nil))))
+ (od (when (string-match-p "\\(^\\|[^%]\\)%o" script)
+ (or (if vec (tramp-get-remote-od vec) (executable-find "od"))
+ (throw 'wont-work nil))))
+ (perl (when (string-match-p "\\(^\\|[^%]\\)%p" script)
+ (or
+ (if vec
+ (tramp-get-remote-perl vec) (executable-find "perl"))
+ (throw 'wont-work nil))))
+ (tmp (when (string-match-p "\\(^\\|[^%]\\)%t" script)
+ (or
+ (if vec
+ (tramp-file-local-name (tramp-make-tramp-temp-name vec))
+ (tramp-compat-make-temp-name))
+ (throw 'wont-work nil)))))
+ (format-spec
+ script
+ (format-spec-make ?a awk ?h hdmp ?n dev ?o od ?p perl ?t tmp))))))
+
(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."
@@ -3969,16 +3935,17 @@ Only send the definition if it has not already been done."
vec 5 (format-message "Sending script `%s'" name)
;; In bash, leading TABs like in `tramp-vc-registered-read-file-names'
;; could result in unwanted command expansion. Avoid this.
- (setq script (replace-regexp-in-string
+ (setq script (tramp-compat-string-replace
(make-string 1 ?\t) (make-string 8 ? ) script))
- ;; The script could contain a call of Perl. This is masked with `%s'.
- (when (and (string-match-p "%s" script)
- (not (tramp-get-remote-perl vec)))
- (tramp-error vec 'file-error "No Perl available on remote host"))
+ ;; Expand format specifiers.
+ (unless (setq script (tramp-expand-script vec script))
+ (tramp-error
+ vec 'file-error
+ (format "Script %s is not applicable on remote host" name)))
+ ;; Send it.
(tramp-barf-unless-okay
vec
- (format "%s () {\n%s\n}"
- name (format script (tramp-get-remote-perl vec)))
+ (format "%s () {\n%s\n}" name script)
"Script %s sending failed" name)
(tramp-set-connection-property
(tramp-get-connection-process vec) "scripts" (cons name scripts))))))
@@ -3995,23 +3962,8 @@ Returns the exit code of the `test' program."
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))))))
+(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11"))
+ "Regexp to determine remote SunOS.")
(defun tramp-find-executable
(vec progname dirlist &optional ignore-tilde ignore-path)
@@ -4019,7 +3971,7 @@ hosts, or files, disagree."
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
+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.
@@ -4034,7 +3986,7 @@ This function expects to be in the right *tramp* buffer."
;; therefore.
(unless (or ignore-path
(string-match-p
- (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11")))
+ tramp-sunos-unames
(tramp-get-connection-property vec "uname" "")))
(tramp-send-command vec (format "which \\%s | wc -w" progname))
(goto-char (point-min))
@@ -4045,19 +3997,18 @@ This function expects to be in the right *tramp* buffer."
;; Remove all ~/foo directories from dirlist.
(let (newdl d)
(while dirlist
- (setq d (car dirlist))
- (setq dirlist (cdr dirlist))
+ (setq d (car dirlist)
+ dirlist (cdr dirlist))
(unless (char-equal ?~ (aref d 0))
(setq newdl (cons d newdl))))
(setq dirlist (nreverse newdl))))
(tramp-send-command
vec
- (format (eval-when-compile
- (concat "while read d; "
- "do if test -x $d/%s && test -f $d/%s; "
- "then echo tramp_executable $d/%s; "
- "break; fi; done <<'%s'\n"
- "%s\n%s"))
+ (format (concat "while read d; "
+ "do if test -x $d/%s && test -f $d/%s; "
+ "then echo tramp_executable $d/%s; "
+ "break; fi; done <<'%s'\n"
+ "%s\n%s")
progname progname progname
tramp-end-of-heredoc
(string-join dirlist "\n")
@@ -4083,7 +4034,10 @@ variable PATH."
(pipe-buf
(with-tramp-connection-property vec "pipe-buf"
(tramp-send-command-and-read
- vec "getconf PIPE_BUF / 2>/dev/null || echo 4096" 'noerror)))
+ vec
+ (format "getconf PIPE_BUF / 2>%s || echo 4096"
+ (tramp-get-remote-null-device vec))
+ 'noerror)))
tmpfile chunk chunksize)
(tramp-message vec 5 "Setting $PATH environment variable")
(if (< (length command) pipe-buf)
@@ -4098,7 +4052,7 @@ variable PATH."
chunk (substring command 0 chunksize)
command (substring command chunksize))
(tramp-send-command vec (format
- "echo -n %s >>%s"
+ "printf \"%%b\" \"$*\" %s >>%s"
(tramp-shell-quote-argument chunk)
(tramp-shell-quote-argument tmpfile))))
(tramp-send-command vec (format ". %s" tmpfile))
@@ -4193,14 +4147,15 @@ file exists and nonzero exit status otherwise."
;; ensure they have the correct values when the shell starts, not
;; just processes run within the shell. (Which processes include
;; our initial probes to ensure the remote shell is usable.)
+ ;; For the time being, we assume that all shells interpret -i as
+ ;; interactive shell. Must be the last argument, because (for
+ ;; example) bash expects long options first.
(tramp-send-command
vec (format
- (eval-when-compile
- (concat
- "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' "
- "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s"))
- tramp-terminal-type
- emacs-version tramp-version ; INSIDE_EMACS
+ (concat
+ "exec env TERM='%s' INSIDE_EMACS='%s' "
+ "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i")
+ tramp-terminal-type (tramp-inside-emacs)
(or (getenv-internal "ENV" tramp-remote-process-environment) "")
(if (stringp tramp-histfile-override)
(format "HISTFILE=%s"
@@ -4228,45 +4183,45 @@ file exists and nonzero exit status otherwise."
(defun tramp-find-shell (vec)
"Open a shell on the remote host which groks tilde expansion."
- (with-current-buffer (tramp-get-buffer vec)
- (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell))
- shell)
- (setq shell
- (with-tramp-connection-property vec "remote-shell"
- ;; CCC: "root" does not exist always, see my QNAP TS-459.
- ;; Which check could we apply instead?
- (tramp-send-command vec "echo ~root" t)
- (if (or (string-match-p "^~root$" (buffer-string))
- ;; The default shell (ksh93) of OpenSolaris and
- ;; Solaris is buggy. We've got reports for
- ;; "SunOS 5.10" and "SunOS 5.11" so far.
- (string-match-p
- (eval-when-compile
- (regexp-opt '("SunOS 5.10" "SunOS 5.11")))
- (tramp-get-connection-property vec "uname" "")))
-
- (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)
- ;; Maybe it works at least for some other commands.
- (prog1
- default-shell
- (tramp-message
- vec 2
- (eval-when-compile
+ ;; If we are in `make-process', we don't need another shell.
+ (unless (tramp-get-connection-property vec "process-name" nil)
+ (with-current-buffer (tramp-get-buffer vec)
+ (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell))
+ shell)
+ (setq shell
+ (with-tramp-connection-property vec "remote-shell"
+ ;; CCC: "root" does not exist always, see my QNAP
+ ;; TS-459. Which check could we apply instead?
+ (tramp-send-command vec "echo ~root" t)
+ (if (or (string-match-p "^~root$" (buffer-string))
+ ;; The default shell (ksh93) of OpenSolaris
+ ;; and Solaris is buggy. We've got reports
+ ;; for "SunOS 5.10" and "SunOS 5.11" so far.
+ (string-match-p
+ tramp-sunos-unames
+ (tramp-get-connection-property vec "uname" "")))
+
+ (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)
+ ;; Maybe it works at least for some other commands.
+ (prog1
+ default-shell
+ (tramp-message
+ vec 2
(concat
"Couldn't find a remote shell which groks tilde "
- "expansion, using `%s'"))
- default-shell)))
+ "expansion, using `%s'")
+ default-shell)))
- default-shell)))
+ default-shell)))
- ;; Open a new shell if needed.
- (unless (string-equal shell default-shell)
- (tramp-message
- vec 5 "Starting remote shell `%s' for tilde expansion" shell)
- (tramp-open-shell vec shell)))))
+ ;; Open a new shell if needed.
+ (unless (string-equal shell default-shell)
+ (tramp-message
+ vec 5 "Starting remote shell `%s' for tilde expansion" shell)
+ (tramp-open-shell vec shell))))))
;; Utility functions.
@@ -4328,11 +4283,15 @@ process to set up. VEC specifies the connection."
;; connection properties. We start again with
;; `tramp-maybe-open-connection', it will be caught there.
(tramp-message vec 5 "Checking system information")
- (let ((old-uname (tramp-get-connection-property vec "uname" nil))
- (uname
- (tramp-set-connection-property
- vec "uname"
- (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
+ (let* ((old-uname (tramp-get-connection-property vec "uname" nil))
+ (uname
+ ;; If we are in `make-process', we don't need to recompute.
+ (if (and old-uname
+ (tramp-get-connection-property vec "process-name" nil))
+ old-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 uname)))
(tramp-message
vec 3
@@ -4384,7 +4343,7 @@ process to set up. VEC specifies the connection."
(t
(tramp-message
vec 5 "Checking remote host type for `send-process-string' bug")
- (if (string-match-p "^FreeBSD" uname) 500 0))))
+ (if (string-match-p "FreeBSD\\|DragonFly" uname) 500 0))))
;; Set remote PATH variable.
(tramp-set-remote-path vec)
@@ -4402,22 +4361,28 @@ process to set up. VEC specifies the connection."
(tramp-find-shell vec)
;; Disable unexpected output.
- (tramp-send-command vec "mesg n 2>/dev/null; biff n 2>/dev/null" t)
+ (tramp-send-command
+ vec
+ (format "mesg n 2>%s; biff n 2>%s"
+ (tramp-get-remote-null-device vec)
+ (tramp-get-remote-null-device vec))
+ 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>.
+ ;; <https://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>.
(when (string-match-p "^IRIX64" uname)
(tramp-send-command vec "set +H" t))
;; Disable tab expansion.
- (if (string-match-p "BSD\\|Darwin" uname)
+ (if (string-match-p "BSD\\|DragonFly\\|Darwin" uname)
(tramp-send-command vec "stty tabs" t)
(tramp-send-command vec "stty tab0" t))
;; Set utf8 encoding. Needed for macOS, for example. This is
;; non-POSIX, so we must expect errors on some systems.
- (tramp-send-command vec "stty iutf8 2>/dev/null" t)
+ (tramp-send-command
+ vec (concat "stty iutf8 2>" (tramp-get-remote-null-device vec)) t)
;; Set `remote-tty' process property.
(let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"" 'noerror)))
@@ -4472,7 +4437,7 @@ process to set up. VEC specifies the connection."
(defconst tramp-local-coding-commands
`((b64 base64-encode-region base64-decode-region)
(uu tramp-uuencode-region uudecode-decode-region)
- (pack ,(format tramp-perl-pack "perl") ,(format tramp-perl-unpack "perl")))
+ (pack ,tramp-perl-pack ,tramp-perl-unpack))
"List of local coding commands for inline transfer.
Each item is a list that looks like this:
@@ -4533,7 +4498,8 @@ program will be transferred to the remote host, and it is
available as shell function with the same name. A \"%t\" format
specifier in the variable value denotes a temporary file.
\"%a\", \"%h\" and \"%o\" format specifiers are replaced by the
-respective `awk', `hexdump' and `od' commands.
+respective `awk', `hexdump' and `od' commands. \"%n\" is
+replaced by \"2>/dev/null\".
The optional TEST command can be used for further tests, whether
ENCODING and DECODING are applicable.")
@@ -4552,8 +4518,8 @@ Goes through the list `tramp-local-coding-commands' and
(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))
+ (setq loc-enc (nth 1 litem)
+ 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))
@@ -4561,6 +4527,8 @@ Goes through the list `tramp-local-coding-commands' and
vec 5 "Checking local encoding function `%s'" loc-enc)
(tramp-message
vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
+ (unless (stringp (setq loc-enc (tramp-expand-script nil loc-enc)))
+ (throw 'wont-work-local nil))
(unless (zerop (tramp-call-local-coding-command loc-enc nil nil))
(throw 'wont-work-local nil)))
(if (not (stringp loc-dec))
@@ -4568,6 +4536,8 @@ Goes through the list `tramp-local-coding-commands' and
vec 5 "Checking local decoding function `%s'" loc-dec)
(tramp-message
vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
+ (unless (stringp (setq loc-dec (tramp-expand-script nil loc-dec)))
+ (throw 'wont-work-local nil))
(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
@@ -4575,9 +4545,9 @@ Goes through the list `tramp-local-coding-commands' and
(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))
- (setq rem-test (nth 3 ritem))
+ (setq rem-enc (nth 1 ritem)
+ rem-dec (nth 2 ritem)
+ rem-test (nth 3 ritem))
;; Check the remote test command if exists.
(when (stringp rem-test)
(tramp-message
@@ -4595,68 +4565,25 @@ Goes through the list `tramp-local-coding-commands' and
(unless (stringp rem-enc)
(let ((name (symbol-name rem-enc))
(value (symbol-value rem-enc)))
- ;; Check if remote perl exists when necessary.
- (and (string-match-p "perl" name)
- (not (tramp-get-remote-perl vec))
- (throw 'wont-work-remote nil))
- ;; Check if remote awk exists when necessary.
- (and (string-match-p "\\(^\\|[^%]\\)%a" value)
- (not (tramp-get-remote-awk vec))
- (throw 'wont-work-remote nil))
- ;; Check if remote hexdump exists when necessary.
- (and (string-match-p "\\(^\\|[^%]\\)%h" value)
- (not (tramp-get-remote-hexdump vec))
- (throw 'wont-work-remote nil))
- ;; Check if remote od exists when necessary.
- (and (string-match-p "\\(^\\|[^%]\\)%o" value)
- (not (tramp-get-remote-od vec))
- (throw 'wont-work-remote nil))
(while (string-match "-" name)
(setq name (replace-match "_" nil t name)))
- (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value)
- (setq value
- (format-spec
- value
- (format-spec-make
- ?a (tramp-get-remote-awk vec)
- ?h (tramp-get-remote-hexdump vec)
- ?o (tramp-get-remote-od vec)))
- value (replace-regexp-in-string "%" "%%" value)))
(tramp-maybe-send-script vec value 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)
+ vec
+ (format
+ "%s <%s" rem-enc (tramp-get-remote-null-device vec))
+ t)
(throw 'wont-work-remote nil))
(unless (stringp rem-dec)
(let ((name (symbol-name rem-dec))
- (value (symbol-value rem-dec))
- tmpfile)
+ (value (symbol-value rem-dec)))
(while (string-match "-" name)
(setq name (replace-match "_" nil t name)))
- (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value)
- (setq value
- (format-spec
- value
- (format-spec-make
- ?a (tramp-get-remote-awk vec)
- ?h (tramp-get-remote-hexdump vec)
- ?o (tramp-get-remote-od vec)))
- value (replace-regexp-in-string "%" "%%" value)))
- (when (string-match-p "\\(^\\|[^%]\\)%t" value)
- (setq tmpfile
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-get-remote-tmpdir vec)))
- value
- (format-spec
- value
- (format-spec-make
- ?t (tramp-file-local-name tmpfile)))))
(tramp-maybe-send-script vec value name)
(setq rem-dec name)))
(tramp-message
@@ -4674,9 +4601,9 @@ Goes through the list `tramp-local-coding-commands' and
(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)))))))
+ (setq rem-enc (nth 1 ritem)
+ rem-dec (nth 2 ritem)
+ found t)))))))
(when found
;; Set connection properties. Since the commands are risky
@@ -4694,7 +4621,7 @@ Goes through the list `tramp-local-coding-commands' and
"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'.
+INPUT can also be nil which means `null-device'.
OUTPUT can be a string (which specifies a file name), or t (which
means standard output and thus the current buffer), or nil (which
means discard it)."
@@ -4789,99 +4716,6 @@ Goes through the list `tramp-inline-compress-commands'."
(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'."
- (let ((saved-tdpa tramp-default-proxies-alist)
- (target-alist `(,vec))
- (hops (or (tramp-file-name-hop vec) ""))
- (item vec)
- choices proxy)
-
- ;; Ad-hoc proxy definitions.
- (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit)))
- (let* ((host-port (tramp-file-name-host-port item))
- (user-domain (tramp-file-name-user-domain item))
- (proxy (concat
- tramp-prefix-format proxy tramp-postfix-host-format))
- (entry
- (list (and (stringp host-port)
- (concat "^" (regexp-quote host-port) "$"))
- (and (stringp user-domain)
- (concat "^" (regexp-quote user-domain) "$"))
- (propertize proxy 'tramp-ad-hoc t))))
- (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry)
- ;; Add the hop.
- (add-to-list 'tramp-default-proxies-alist entry)
- (setq item (tramp-dissect-file-name proxy))))
- ;; Save the new value.
- (when (and hops tramp-save-ad-hoc-proxies)
- (customize-save-variable
- 'tramp-default-proxies-alist tramp-default-proxies-alist))
-
- ;; Look for proxy hosts to be passed.
- (setq choices tramp-default-proxies-alist)
- (while choices
- (setq item (pop choices)
- proxy (eval (nth 2 item)))
- (when (and
- ;; Host.
- (string-match-p
- (or (eval (nth 0 item)) "")
- (or (tramp-file-name-host-port (car target-alist)) ""))
- ;; User.
- (string-match-p
- (or (eval (nth 1 item)) "")
- (or (tramp-file-name-user-domain (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.
- (push l target-alist)
- ;; Start next search.
- (setq choices tramp-default-proxies-alist)))))
-
- ;; Foreign and out-of-band methods are not supported for multi-hops.
- (when (cdr target-alist)
- (setq choices target-alist)
- (while (setq item (pop choices))
- (when (or (not (tramp-get-method-parameter item 'tramp-login-program))
- (tramp-get-method-parameter item 'tramp-copy-program))
- (setq tramp-default-proxies-alist saved-tdpa)
- (tramp-user-error
- vec "Method `%s' is not supported for multi-hops."
- (tramp-file-name-method item)))))
-
- ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the
- ;; host name in their command template. In this case, the remote
- ;; file name must use either a local host name (first hop), or a
- ;; host name matching the previous hop.
- (let ((previous-host (or tramp-local-host-regexp "")))
- (setq choices target-alist)
- (while (setq item (pop choices))
- (let ((host (tramp-file-name-host item)))
- (unless
- (or
- ;; The host name is used for the remote shell command.
- (member
- '("%h") (tramp-get-method-parameter item 'tramp-login-args))
- ;; The host name must match previous hop.
- (string-match-p previous-host host))
- (setq tramp-default-proxies-alist saved-tdpa)
- (tramp-user-error
- vec "Host name `%s' does not match `%s'" host previous-host))
- (setq previous-host (concat "^" (regexp-quote host) "$")))))
-
- ;; Result.
- target-alist))
-
(defun tramp-ssh-controlmaster-options (vec)
"Return the Control* arguments of the local ssh."
(cond
@@ -4929,18 +4763,46 @@ Goes through the list `tramp-inline-compress-commands'."
" -o ControlPersist=no")))))))))
tramp-ssh-controlmaster-options)))
+(defun tramp-scp-strict-file-name-checking (vec)
+ "Return the strict file name checking argument of the local scp."
+ (cond
+ ;; No options to be computed.
+ ((null (assoc "%x" (tramp-get-method-parameter vec 'tramp-copy-args)))
+ "")
+
+ ;; There is already a value to be used.
+ ((stringp tramp-scp-strict-file-name-checking)
+ tramp-scp-strict-file-name-checking)
+
+ ;; Determine the options.
+ (t (setq tramp-scp-strict-file-name-checking "")
+ (let ((case-fold-search t))
+ (ignore-errors
+ (when (executable-find "scp")
+ (with-tramp-progress-reporter
+ vec 4 "Computing strict file name argument"
+ (with-temp-buffer
+ (tramp-call-process vec "scp" nil t nil "-T")
+ (goto-char (point-min))
+ (unless
+ (search-forward-regexp
+ "\\(illegal\\|unknown\\) option -- T" nil t)
+ (setq tramp-scp-strict-file-name-checking "-T")))))))
+ tramp-scp-strict-file-name-checking)))
+
(defun tramp-timeout-session (vec)
"Close the connection VEC after a session timeout.
If there is just some editing, retry it after 5 seconds."
- (if (and tramp-locked tramp-locker
+ (if (and (tramp-get-connection-property
+ (tramp-get-connection-process vec) "locked" nil)
(tramp-file-name-equal-p vec (car tramp-current-connection)))
(progn
(tramp-message
vec 5 "Cannot timeout session, trying it again in %s seconds." 5)
- (run-at-time 5 nil 'tramp-timeout-session vec))
+ (run-at-time 5 nil #'tramp-timeout-session vec))
(tramp-message
vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc))
- (tramp-cleanup-connection vec 'keep-debug)))
+ (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes)))
(defun tramp-maybe-open-connection (vec)
"Maybe open a connection VEC.
@@ -4961,11 +4823,8 @@ connection if a previous connection has died for some reason."
(not (tramp-file-name-equal-p
vec (car tramp-current-connection)))
(time-less-p
- ;; `current-time' can be removed once we get rid of Emacs 24.
- (time-since (or (cdr tramp-current-connection) (current-time)))
- ;; `seconds-to-time' can be removed once we get rid
- ;; of Emacs 24.
- (seconds-to-time (or tramp-connection-min-time-diff 0))))
+ (time-since (cdr tramp-current-connection))
+ (or tramp-connection-min-time-diff 0)))
(throw 'suppress 'suppress))
;; If too much time has passed since last command was sent, look
@@ -4976,11 +4835,9 @@ connection if a previous connection has died for some reason."
;; try to send a command from time to time, then look again
;; whether the process is really alive.
(condition-case nil
- ;; `seconds-to-time' can be removed once we get rid of Emacs 24.
- (when (and (time-less-p (seconds-to-time 60)
- (time-since
- (tramp-get-connection-property
- p "last-cmd-time" (seconds-to-time 0))))
+ (when (and (time-less-p
+ 60 (time-since
+ (tramp-get-connection-property p "last-cmd-time" 0)))
(process-live-p p))
(tramp-send-command vec "echo are you awake" t t)
(unless (and (process-live-p p)
@@ -4997,10 +4854,12 @@ connection if a previous connection has died for some reason."
(with-tramp-progress-reporter
vec 3
(if (zerop (length (tramp-file-name-user vec)))
- (format "Opening connection for %s using %s"
+ (format "Opening connection %s for %s using %s"
+ process-name
(tramp-file-name-host vec)
(tramp-file-name-method vec))
- (format "Opening connection for %s@%s using %s"
+ (format "Opening connection %s for %s@%s using %s"
+ process-name
(tramp-file-name-user vec)
(tramp-file-name-host vec)
(tramp-file-name-method vec)))
@@ -5057,6 +4916,9 @@ connection if a previous connection has died for some reason."
(tramp-message vec 6 "%s" (string-join (process-command p) " "))
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
;; Check whether process is alive.
(tramp-barf-if-no-shell-prompt
p 10
@@ -5070,19 +4932,17 @@ connection if a previous connection has died for some reason."
(l-domain (tramp-file-name-domain hop))
(l-host (tramp-file-name-host hop))
(l-port (tramp-file-name-port hop))
- (login-program
- (tramp-get-method-parameter hop 'tramp-login-program))
- (login-args
- (tramp-get-method-parameter hop 'tramp-login-args))
(remote-shell
(tramp-get-method-parameter hop 'tramp-remote-shell))
(extra-args (tramp-get-sh-extra-args remote-shell))
(async-args
- (tramp-get-method-parameter hop 'tramp-async-args))
+ (tramp-compat-flatten-tree
+ (tramp-get-method-parameter hop 'tramp-async-args)))
(connection-timeout
(tramp-get-method-parameter
hop 'tramp-connection-timeout))
- (command login-program)
+ (command
+ (tramp-get-method-parameter hop 'tramp-login-program))
;; We don't create the temporary file. In
;; fact, it is just a prefix for the
;; ControlPath option of ssh; the real
@@ -5094,16 +4954,9 @@ connection if a previous connection has died for some reason."
;; we cannot use `tramp-get-connection-process'.
(tmpfile
(with-tramp-connection-property
- (get-process (tramp-buffer-name vec)) "temp-file"
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory)))))
- spec r-shell)
-
- ;; Add arguments for asynchronous processes.
- (when (and process-name async-args)
- (setq login-args (append async-args login-args)))
+ (tramp-get-process vec) "temp-file"
+ (tramp-compat-make-temp-name)))
+ r-shell)
;; Check, whether there is a restricted shell.
(dolist (elt tramp-restricted-shell-hosts-alist)
@@ -5128,31 +4981,24 @@ connection if a previous connection has died for some reason."
;; 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 ?t tmpfile)
- options (format-spec options spec)
- spec (format-spec-make
- ?h l-host ?u l-user ?p l-port ?c options
- ?l (concat remote-shell " " extra-args))
command
- (concat
- ;; We do not want to see the trailing local
- ;; prompt in `start-file-process'.
- (unless r-shell "exec ")
- command " "
- (mapconcat
- (lambda (x)
- (setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (string-join 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'. It could
- ;; also be a restricted shell, which does not
- ;; allow "exec".
- (when r-shell " && exit || exit")))
+ (mapconcat
+ #'identity
+ (append
+ ;; We do not want to see the trailing local
+ ;; prompt in `start-file-process'.
+ (unless r-shell '("exec"))
+ `(,command)
+ ;; Add arguments for asynchronous processes.
+ (when process-name async-args)
+ (tramp-expand-args
+ hop 'tramp-login-args
+ ?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
+ ?c (format-spec options (format-spec-make ?t tmpfile))
+ ?l (concat remote-shell " " extra-args " -i"))
+ ;; A restricted shell does not allow "exec".
+ (when r-shell '("&&" "exit" "||" "exit")))
+ " "))
;; Send the command.
(tramp-message vec 3 "Sending command `%s'" command)
@@ -5169,14 +5015,11 @@ connection if a previous connection has died for some reason."
(setq options ""
target-alist (cdr target-alist)))
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
;; Activate session timeout.
(when (tramp-get-connection-property p "session-timeout" nil)
(run-at-time
(tramp-get-connection-property p "session-timeout" nil) nil
- 'tramp-timeout-session vec))
+ #'tramp-timeout-session vec))
;; Make initial shell settings.
(tramp-open-connection-setup-interactive-shell p vec)
@@ -5267,18 +5110,21 @@ status is 0, and nil otherwise.
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.
+DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to \"/dev/null\".
Optional argument EXIT-STATUS, if non-nil, triggers the return of
the exit status."
(tramp-send-command
vec
(concat (if subshell "( " "")
command
- (if command (if dont-suppress-err "; " " 2>/dev/null; ") "")
+ (if command
+ (if dont-suppress-err
+ "; " (format " 2>%s; " (tramp-get-remote-null-device vec)))
+ "")
"echo tramp_exit_status $?"
(if subshell " )" "")))
(with-current-buffer (tramp-get-connection-buffer vec)
- (unless (tramp-search-regexp "tramp_exit_status [0-9]+")
+ (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+")
(tramp-error
vec 'file-error "Couldn't find exit status of `%s'" command))
(skip-chars-forward "^ ")
@@ -5438,15 +5284,16 @@ Return ATTR."
(directory-file-name (tramp-file-name-unquote-localname vec))))
(when (string-match-p tramp-ipv6-regexp host)
(setq host (format "[%s]" host)))
+ ;; This does not work for MS Windows scp, if there are characters
+ ;; to be quoted. OpenSSH 8 supports disabling of strict file name
+ ;; checking in scp, we use it when available.
(unless (string-match-p "ftp$" method)
- (setq localname (tramp-shell-quote-argument localname)))
+ (setq localname (tramp-unquote-shell-quote-argument localname)))
(cond
((tramp-get-method-parameter vec 'tramp-remote-copy-program)
localname)
- ((not (zerop (length user)))
- (format
- "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname)))
- (t (format "%s:%s" host (tramp-unquote-shell-quote-argument localname))))))
+ ((zerop (length user)) (format "%s:%s" host localname))
+ (t (format "%s@%s:%s" user host localname)))))
(defun tramp-method-out-of-band-p (vec size)
"Return t if this is an out-of-band method, nil otherwise."
@@ -5474,8 +5321,7 @@ Nonexistent directories are removed from spec."
;; 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)
+ (tramp-get-process vec) vec)
"remote-path"
(let* ((remote-path (copy-tree tramp-remote-path))
(elt1 (memq 'tramp-default-remote-path remote-path))
@@ -5484,12 +5330,16 @@ Nonexistent directories are removed from spec."
(when elt1
(or
(tramp-send-command-and-read
- vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror)
+ vec
+ (format
+ "echo \\\"`getconf PATH 2>%s`\\\""
+ (tramp-get-remote-null-device vec))
+ 'noerror)
;; Default if "getconf" is not available.
(progn
(tramp-message
vec 3
- "`getconf PATH' not successful, using default value \"%s\"."
+ "`getconf PATH' not successful, using default value \"%s\"."
"/bin:/usr/bin")
"/bin:/usr/bin"))))
(own-remote-path
@@ -5588,7 +5438,8 @@ Nonexistent directories are removed from spec."
vec (format "%s -lnd /" result))
(when (tramp-send-command-and-check
vec (format
- "%s --color=never -al /dev/null" result))
+ "%s --color=never -al %s"
+ result (tramp-get-remote-null-device vec)))
(setq result (concat result " --color=never")))
(throw 'ls-found result))
(setq dl (cdr dl))))))
@@ -5609,7 +5460,9 @@ Nonexistent directories are removed from spec."
(format
"%s --help 2>&1 | grep -iq busybox" (tramp-get-ls-command vec))))
(tramp-send-command-and-check
- vec (format "%s %s -al /dev/null" (tramp-get-ls-command vec) option))
+ vec (format
+ "%s %s -al %s"
+ (tramp-get-ls-command vec) option (tramp-get-remote-null-device vec)))
option)))
(defun tramp-get-test-command (vec)
@@ -5682,8 +5535,7 @@ Nonexistent directories are removed from spec."
;; stat on Solaris is buggy. We've got reports for "SunOS 5.10"
;; and "SunOS 5.11" so far.
(unless (string-match-p
- (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11")))
- (tramp-get-connection-property vec "uname" ""))
+ tramp-sunos-unames (tramp-get-connection-property vec "uname" ""))
(tramp-message vec 5 "Finding a suitable `stat' command")
(let ((result (tramp-find-executable
vec "stat" (tramp-get-remote-path vec)))
@@ -5691,15 +5543,15 @@ Nonexistent directories are removed from spec."
;; Check whether stat(1) returns usable syntax. "%s" does not
;; work on older AIX systems. Recent GNU stat versions
;; (8.24?) use shell quoted format for "%N", we check the
- ;; boundaries "`" and "'", therefore. See Bug#23422 in
- ;; coreutils. Since GNU stat 8.26, environment variable
- ;; QUOTING_STYLE is supported.
+ ;; boundaries "`" and "'" and their localized variants,
+ ;; therefore. See Bug#23422 in coreutils. Since GNU stat
+ ;; 8.26, environment variable QUOTING_STYLE is supported.
(when result
(setq result (concat "env QUOTING_STYLE=locale " result)
tmp (tramp-send-command-and-read
vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror))
(unless (and (listp tmp) (stringp (car tmp))
- (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp))
+ (string-match-p "^[\"`‘„â€Â«ã€Œ]/[\"'’“â€Â»ã€]$" (car tmp))
(integerp (cadr tmp)))
(setq result nil)))
result))))
@@ -5729,10 +5581,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
(tramp-message vec 5 "Finding a suitable `touch' command")
(let ((result (tramp-find-executable
vec "touch" (tramp-get-remote-path vec)))
- (tmpfile
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))))
+ (tmpfile (tramp-make-tramp-temp-name vec)))
;; Busyboxes do support the "-t" option only when they have been
;; built with the DESKTOP config option. Let's check it.
(when result
@@ -5777,18 +5626,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
(tramp-message vec 5 "Finding a suitable `gio-monitor' command")
(tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t)))
-(defun tramp-get-remote-gvfs-monitor-dir (vec)
- "Determine remote `gvfs-monitor-dir' command."
- (with-tramp-connection-property vec "gvfs-monitor-dir"
- (tramp-message vec 5 "Finding a suitable `gvfs-monitor-dir' command")
- ;; We distinguish "gvfs-monitor-dir.exe" from cygwin in order to
- ;; establish better timeouts in filenotify-tests.el. Any better
- ;; distinction approach would be welcome!
- (or (tramp-find-executable
- vec "gvfs-monitor-dir.exe" (tramp-get-remote-path vec) t t)
- (tramp-find-executable
- vec "gvfs-monitor-dir" (tramp-get-remote-path vec) t t))))
-
(defun tramp-get-remote-inotifywait (vec)
"Determine remote `inotifywait' command."
(with-tramp-connection-property vec "inotifywait"
@@ -5847,27 +5684,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
"import os; print (os.getuid())"
"import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')"))))
-(defun tramp-get-remote-uid (vec id-format)
- "The uid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (let ((res
- (ignore-errors
- (cond
- ((tramp-get-remote-id vec)
- (tramp-get-remote-uid-with-id vec id-format))
- ((tramp-get-remote-perl vec)
- (tramp-get-remote-uid-with-perl vec id-format))
- ((tramp-get-remote-python vec)
- (tramp-get-remote-uid-with-python vec id-format))))))
- ;; Ensure there is a valid result.
- (cond
- ((and (equal id-format 'integer) (not (integerp res)))
- tramp-unknown-id-integer)
- ((and (equal id-format 'string) (not (stringp res)))
- tramp-unknown-id-string)
- (t res)))))
-
(defun tramp-get-remote-gid-with-id (vec id-format)
"Implement `tramp-get-remote-gid' for Tramp files using `id'."
(tramp-send-command-and-read
@@ -5898,27 +5714,6 @@ ID-FORMAT valid values are `string' and `integer'."
"import os; print (os.getgid())"
"import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')"))))
-(defun tramp-get-remote-gid (vec id-format)
- "The gid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (let ((res
- (ignore-errors
- (cond
- ((tramp-get-remote-id vec)
- (tramp-get-remote-gid-with-id vec id-format))
- ((tramp-get-remote-perl vec)
- (tramp-get-remote-gid-with-perl vec id-format))
- ((tramp-get-remote-python vec)
- (tramp-get-remote-gid-with-python vec id-format))))))
- ;; Ensure there is a valid result.
- (cond
- ((and (equal id-format 'integer) (not (integerp res)))
- tramp-unknown-id-integer)
- ((and (equal id-format 'string) (not (stringp res)))
- tramp-unknown-id-string)
- (t res)))))
-
(defun tramp-get-remote-busybox (vec)
"Determine remote `busybox' command."
(with-tramp-connection-property vec "busybox"
@@ -5934,7 +5729,7 @@ ID-FORMAT valid values are `string' and `integer'."
(command (format "%s %s" busybox "awk")))
(and busybox
(tramp-send-command-and-check
- vec (concat command " {} </dev/null"))
+ vec (concat command " {} <" (tramp-get-remote-null-device vec)))
command)))))
(defun tramp-get-remote-hexdump (vec)
@@ -5945,7 +5740,8 @@ ID-FORMAT valid values are `string' and `integer'."
(let* ((busybox (tramp-get-remote-busybox vec))
(command (format "%s %s" busybox "hexdump")))
(and busybox
- (tramp-send-command-and-check vec (concat command " </dev/null"))
+ (tramp-send-command-and-check
+ vec (concat command " <" (tramp-get-remote-null-device vec)))
command)))))
(defun tramp-get-remote-od (vec)
@@ -5957,16 +5753,22 @@ ID-FORMAT valid values are `string' and `integer'."
(command (format "%s %s" busybox "od")))
(and busybox
(tramp-send-command-and-check
- vec (concat command " -A n </dev/null"))
+ vec
+ (concat command " -A n <" (tramp-get-remote-null-device vec)))
command)))))
-(defun tramp-get-env-with-u-option (vec)
- "Check, whether the remote `env' command supports the -u option."
- (with-tramp-connection-property vec "env-u-option"
- (tramp-message vec 5 "Checking, whether `env -u' works")
- ;; Option "-u" is a GNU extension.
- (tramp-send-command-and-check
- vec "env FOO=foo env -u FOO 2>/dev/null | grep -qv FOO" t)))
+(defun tramp-get-remote-chmod-h (vec)
+ "Check whether remote `chmod' supports nofollow argument."
+ (with-tramp-connection-property vec "chmod-h"
+ (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow")
+ (let ((tmpfile (tramp-make-tramp-temp-name vec)))
+ (prog1
+ (tramp-send-command-and-check
+ vec
+ (format
+ "ln -s foo %s && chmod -h %s 0777"
+ (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile)))
+ (delete-file tmpfile)))))
;; Some predefined connection properties.
(defun tramp-get-inline-compress (vec prop size)
@@ -5977,10 +5779,9 @@ 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-tramp-connection-property (tramp-get-connection-process vec) prop
+ (with-tramp-connection-property (tramp-get-process vec) prop
(tramp-find-inline-compress vec)
- (tramp-get-connection-property
- (tramp-get-connection-process vec) prop nil))))
+ (tramp-get-connection-property (tramp-get-process vec) prop nil))))
(defun tramp-get-inline-coding (vec prop size)
"Return the coding command related to PROP.
@@ -5998,11 +5799,9 @@ function cell is returned to be applied on a buffer."
;; no inline coding is found.
(ignore-errors
(let ((coding
- (with-tramp-connection-property
- (tramp-get-connection-process vec) prop
+ (with-tramp-connection-property (tramp-get-process vec) prop
(tramp-find-inline-encoding vec)
- (tramp-get-connection-property
- (tramp-get-connection-process vec) prop nil)))
+ (tramp-get-connection-property (tramp-get-process vec) prop nil)))
(prop1 (if (string-match-p "encoding" prop)
"inline-compress" "inline-decompress"))
compress)
@@ -6046,7 +5845,7 @@ function cell is returned to be applied on a buffer."
;; slashes as directory separators.
(cond
((and (string-match-p "local" prop)
- (memq system-type '(windows-nt)))
+ (eq system-type 'windows-nt))
"(%s | \"%s\")")
((string-match-p "local" prop) "(%s | %s)")
(t "(%s | %s >%%s)"))
@@ -6057,7 +5856,7 @@ function cell is returned to be applied on a buffer."
;; the pipe symbol be quoted if they use forward
;; slashes as directory separators.
(if (and (string-match-p "local" prop)
- (memq system-type '(windows-nt)))
+ (eq system-type 'windows-nt))
"(%s <%%s | \"%s\")"
"(%s <%%s | %s)")
compress coding))
@@ -6080,9 +5879,6 @@ function cell is returned to be applied on a buffer."
;; likely to produce long command lines, and some shells choke on
;; long command lines.
;;
-;; * 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.
@@ -6162,6 +5958,9 @@ function cell is returned to be applied on a buffer."
;; session could be reused after a connection loss. Use dtach, or
;; screen, or tmux, or mosh.
;;
-;; * Implement `:stderr' of `make-process' as pipe process.
+;; * One interesting solution (with other applications as well) would
+;; be to stipulate, as a directory or connection-local variable, an
+;; additional rc file on the remote machine that is sourced every
+;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306>
;;; tramp-sh.el ends here
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 18b98d86a2f..3d5be61d3f0 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -60,28 +60,24 @@
tramp-smb-method
'((tramp-parse-netrc "~/.netrc"))))
-;;;###tramp-autoload
(defcustom tramp-smb-program "smbclient"
"Name of SMB client to run."
:group 'tramp
:type 'string)
-;;;###tramp-autoload
(defcustom tramp-smb-acl-program "smbcacls"
"Name of SMB acls to run."
:group 'tramp
:type 'string
:version "24.4")
-;;;###tramp-autoload
-(defcustom tramp-smb-conf "/dev/null"
+(defcustom tramp-smb-conf null-device
"Path of the \"smb.conf\" file.
If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program'
call, letting the SMB client use the default one."
:group 'tramp
:type '(choice (const nil) (file :must-match t)))
-;;;###tramp-autoload
(defcustom tramp-smb-options nil
"List of additional options.
They are added to the `tramp-smb-program' call via \"--option '...'\".
@@ -90,7 +86,7 @@ For example, if the deprecated SMB1 protocol shall be used, add to
this variable (\"client min protocol=NT1\") ."
:group 'tramp
:type '(repeat string)
- :version "27.2")
+ :version "28.1")
(defvar tramp-smb-version nil
"Version string of the SMB client.")
@@ -156,6 +152,7 @@ this variable (\"client min protocol=NT1\") ."
"NT_STATUS_NO_SUCH_FILE"
"NT_STATUS_NO_SUCH_USER"
"NT_STATUS_NOT_A_DIRECTORY"
+ "NT_STATUS_NOT_SUPPORTED"
"NT_STATUS_OBJECT_NAME_COLLISION"
"NT_STATUS_OBJECT_NAME_INVALID"
"NT_STATUS_OBJECT_NAME_NOT_FOUND"
@@ -250,6 +247,7 @@ See `tramp-actions-before-shell' for more info.")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-smb-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-smb-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -276,9 +274,11 @@ See `tramp-actions-before-shell' for more info.")
(insert-directory . tramp-smb-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-smb-handle-make-directory)
(make-directory-internal . tramp-smb-handle-make-directory-internal)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-smb-handle-make-symbolic-link)
@@ -293,8 +293,11 @@ See `tramp-actions-before-shell' for more info.")
(start-file-process . tramp-smb-handle-start-file-process)
(substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-smb-handle-write-region))
@@ -302,7 +305,6 @@ See `tramp-actions-before-shell' for more info.")
Operations not mentioned here will be handled by the default Emacs primitives.")
;; Options for remote processes via winexe.
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-program "winexe"
"Name of winexe client to run.
If it isn't found in the local $PATH, the absolute path of winexe
@@ -311,7 +313,6 @@ shall be given. This is needed for remote processes."
:type 'string
:version "24.3")
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-shell-command "powershell.exe"
"Shell to be used for processes on remote machines.
This must be Powershell V2 compatible."
@@ -319,7 +320,6 @@ This must be Powershell V2 compatible."
:type 'string
:version "24.3")
-;;;###tramp-autoload
(defcustom tramp-smb-winexe-shell-command-switch "-file -"
"Command switch used together with `tramp-smb-winexe-shell-command'.
This can be used to disable echo etc."
@@ -339,12 +339,11 @@ This can be used to disable echo etc."
;;;###tramp-autoload
(defun tramp-smb-file-name-handler (operation &rest args)
"Invoke the SMB related OPERATION and ARGS.
-First arg specifies the OPERATION, second arg is a list of arguments to
-pass to the OPERATION."
- (let ((fn (assoc operation tramp-smb-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###tramp-autoload
(unless (memq system-type '(cygwin windows-nt))
@@ -370,17 +369,17 @@ pass to the OPERATION."
(tramp-error
v2 'file-error
"add-name-to-file: %s must not be a directory" filename))
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p newname)
- ;; 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? "
- v2-localname)))))
- (tramp-error v2 'file-already-exists newname)
- (delete-file newname)))
+ ;; Do the 'confirm if exists' thing.
+ (when (file-exists-p newname)
+ ;; 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? "
+ v2-localname)))))
+ (tramp-error v2 'file-already-exists newname)
+ (delete-file newname)))
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
(tramp-flush-file-properties v2 v2-localname)
@@ -428,20 +427,14 @@ pass to the OPERATION."
(with-tramp-progress-reporter
v 0 (format "Copying %s to %s" dirname newname)
(unless (file-exists-p dirname)
- (tramp-error
- v tramp-file-missing
- "Copying directory" "No such file or directory" dirname))
+ (tramp-compat-file-missing v dirname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-already-exists newname))
(cond
;; We must use a local temporary directory.
((and t1 t2)
- (let ((tmpdir
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory)))))
+ (let ((tmpdir (tramp-compat-make-temp-name)))
(unwind-protect
(progn
(make-directory tmpdir)
@@ -467,12 +460,9 @@ pass to the OPERATION."
(let* ((share (tramp-smb-get-share v))
(localname (file-name-as-directory
- (replace-regexp-in-string
- "\\\\" "/" (tramp-smb-get-localname v))))
- (tmpdir (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory))))
+ (tramp-compat-string-replace
+ "\\" "/" (tramp-smb-get-localname v))))
+ (tmpdir (tramp-compat-make-temp-name))
(args (list (concat "//" host "/" share) "-E"))
(options tramp-smb-options))
@@ -546,7 +536,7 @@ pass to the OPERATION."
(tramp-process-actions p v nil tramp-smb-actions-with-tar)
(while (process-live-p p)
- (sit-for 0.1))
+ (sleep-for 0.1))
(tramp-message v 6 "\n%s" (buffer-string))))
;; Reset the transfer process properties.
@@ -556,10 +546,11 @@ pass to the OPERATION."
;; Handle KEEP-DATE argument.
(when keep-date
- (set-file-times
+ (tramp-compat-set-file-times
newname
(tramp-compat-file-attribute-modification-time
- (file-attributes dirname))))
+ (file-attributes dirname))
+ (unless ok-if-already-exists 'nofollow)))
;; Set the mode.
(unless keep-date
@@ -592,89 +583,86 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(copy-directory filename newname keep-date 'parents 'copy-contents)
(unless (file-exists-p filename)
- (tramp-error
+ (tramp-compat-file-missing
(tramp-dissect-file-name
(if (tramp-tramp-file-p filename) filename newname))
- tramp-file-missing
- "Copying file" "No such file or directory" filename))
-
- (let ((tmpfile (file-local-copy filename)))
- (if tmpfile
- ;; Remote filename.
- (condition-case err
- (rename-file tmpfile newname ok-if-already-exists)
- ((error quit)
- (delete-file tmpfile)
- (signal (car err) (cdr err))))
-
- ;; Remote newname.
+ filename))
+
+ (if-let ((tmpfile (file-local-copy filename)))
+ ;; Remote filename.
+ (condition-case err
+ (rename-file tmpfile newname ok-if-already-exists)
+ ((error quit)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ ;; Remote newname.
+ (when (and (file-directory-p newname)
+ (directory-name-p newname))
+ (setq newname
+ (expand-file-name (file-name-nondirectory filename) newname)))
+
+ (with-parsed-tramp-file-name newname nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (tramp-compat-directory-name-p newname))
- (setq newname
- (expand-file-name (file-name-nondirectory filename) newname)))
+ (not (directory-name-p newname)))
+ (tramp-error v 'file-error "File is a directory %s" newname))
- (with-parsed-tramp-file-name newname nil
- (when (and (not ok-if-already-exists) (file-exists-p newname))
- (tramp-error v 'file-already-exists newname))
- (when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
- (tramp-error v 'file-error "File is a directory %s" newname))
-
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-properties v localname)
- (unless (tramp-smb-get-share v)
- (tramp-error
- v 'file-error "Target `%s' must contain a share name" newname))
- (unless (tramp-smb-send-command
- v (format "put \"%s\" \"%s\""
- (tramp-compat-file-name-unquote filename)
- (tramp-smb-get-localname v)))
- (tramp-error
- v 'file-error "Cannot copy `%s' to `%s'" filename newname))))))
+ ;; We must also flush the cache of the directory, because
+ ;; `file-attributes' reads the values from there.
+ (tramp-flush-file-properties v localname)
+ (unless (tramp-smb-get-share v)
+ (tramp-error
+ v 'file-error "Target `%s' must contain a share name" newname))
+ (unless (tramp-smb-send-command
+ v (format "put \"%s\" \"%s\""
+ (tramp-compat-file-name-unquote filename)
+ (tramp-smb-get-localname v)))
+ (tramp-error
+ v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))
;; KEEP-DATE handling.
(when keep-date
- (set-file-times
+ (tramp-compat-set-file-times
newname
(tramp-compat-file-attribute-modification-time
- (file-attributes filename))))))
+ (file-attributes filename))
+ (unless ok-if-already-exists 'nofollow)))))
-(defun tramp-smb-handle-delete-directory (directory &optional recursive _trash)
+(defun tramp-smb-handle-delete-directory (directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (setq directory (directory-file-name (expand-file-name directory)))
- (when (file-exists-p directory)
- (when recursive
- (mapc
- (lambda (file)
- (if (file-directory-p file)
- (delete-directory file recursive)
- (delete-file file)))
- ;; We do not want to delete "." and "..".
- (directory-files directory 'full directory-files-no-dot-files-regexp)))
-
- (with-parsed-tramp-file-name directory nil
+ (tramp-skeleton-delete-directory directory recursive trash
+ (when (file-exists-p directory)
+ (when recursive
+ (mapc
+ (lambda (file)
+ (if (file-directory-p file)
+ (delete-directory file recursive)
+ (delete-file file)))
+ ;; We do not want to delete "." and "..".
+ (directory-files directory 'full directory-files-no-dot-files-regexp)))
+
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
(tramp-flush-directory-properties v localname)
(unless (tramp-smb-send-command
v (format
"%s \"%s\""
- (if (tramp-smb-get-cifs-capabilities v) "posix_rmdir" "rmdir")
+ (if (tramp-smb-get-cifs-capabilities v)
+ "posix_rmdir" "rmdir")
(tramp-smb-get-localname v)))
;; Error.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(search-forward-regexp tramp-smb-errors nil t)
- (tramp-error
- v 'file-error "%s `%s'" (match-string 0) directory)))
+ (tramp-error v 'file-error "%s `%s'" (match-string 0) directory)))
;; "rmdir" does not report an error. So we check ourselves.
(when (file-exists-p directory)
- (tramp-error
- v 'file-error "`%s' not removed." directory)))))
+ (tramp-error v 'file-error "`%s' not removed." directory)))))
-(defun tramp-smb-handle-delete-file (filename &optional _trash)
+(defun tramp-smb-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
(setq filename (expand-file-name filename))
(when (file-exists-p filename)
@@ -682,25 +670,24 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
(tramp-flush-file-properties v localname)
- (unless (tramp-smb-send-command
- v (format
- "%s \"%s\""
- (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm")
- (tramp-smb-get-localname v)))
- ;; Error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (search-forward-regexp tramp-smb-errors nil t)
- (tramp-error
- v 'file-error "%s `%s'" (match-string 0) filename))))))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash filename)
+ (unless (tramp-smb-send-command
+ v (format
+ "%s \"%s\""
+ (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm")
+ (tramp-smb-get-localname v)))
+ ;; Error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (search-forward-regexp tramp-smb-errors nil t)
+ (tramp-error v 'file-error "%s `%s'" (match-string 0) filename)))))))
(defun tramp-smb-handle-directory-files
- (directory &optional full match nosort _count)
+ (directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
(let ((result (mapcar #'directory-file-name
(file-name-all-completions "" directory))))
;; Discriminate with regexp.
@@ -709,14 +696,22 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(delete nil
(mapcar (lambda (x) (when (string-match-p match x) x))
result))))
- ;; Append directory.
+
+ ;; Sort them if necessary.
+ (unless nosort
+ (setq result (sort result #'string-lessp)))
+
+ ;; Return count number of results.
+ (when (and (natnump count) (> count 0))
+ (setq result (nbutlast result (- (length result) count))))
+
+ ;; Prepend directory.
(when full
(setq result
(mapcar
- (lambda (x) (format "%s/%s" directory x))
+ (lambda (x) (format "%s/%s" (directory-file-name directory) x))
result)))
- ;; Sort them if necessary.
- (unless nosort (setq result (sort result #'string-lessp)))
+
result))
(defun tramp-smb-handle-expand-file-name (name &optional dir)
@@ -727,7 +722,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -745,6 +740,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Make the file name absolute.
(unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
+ ;; Do not keep "/..".
+ (when (string-match-p "^/\\.\\.?$" localname)
+ (setq localname "/"))
;; No tilde characters in file name, do normal
;; `expand-file-name' (this does "/./" and "/../").
(tramp-make-tramp-file-name
@@ -775,8 +773,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(with-tramp-file-property v localname "file-acl"
(when (executable-find tramp-smb-acl-program)
(let* ((share (tramp-smb-get-share v))
- (localname (replace-regexp-in-string
- "\\\\" "/" (tramp-smb-get-localname v)))
+ (localname (tramp-compat-string-replace
+ "\\" "/" (tramp-smb-get-localname v)))
(args (list (concat "//" host "/" share) "-E"))
(options tramp-smb-options))
@@ -795,7 +793,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq
args
(append args (list (tramp-unquote-shell-quote-argument localname)
- "2>/dev/null")))
+ (concat "2>" (tramp-get-remote-null-device v)))))
(unwind-protect
(with-temp-buffer
@@ -880,23 +878,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(while (not (eobp))
(cond
((looking-at
- "Size:\\s-+\\([0-9]+\\)\\s-+Blocks:\\s-+[0-9]+\\s-+\\(\\w+\\)")
+ (concat
+ "Size:\\s-+\\([[:digit:]]+\\)\\s-+"
+ "Blocks:\\s-+[[:digit:]]+\\s-+\\(\\w+\\)"))
(setq size (string-to-number (match-string 1))
id (if (string-equal "directory" (match-string 2)) t
(if (string-equal "symbolic" (match-string 2)) ""))))
((looking-at
- "Inode:\\s-+\\([0-9]+\\)\\s-+Links:\\s-+\\([0-9]+\\)")
+ "Inode:\\s-+\\([[:digit:]]+\\)\\s-+Links:\\s-+\\([[:digit:]]+\\)")
(setq inode (string-to-number (match-string 1))
link (string-to-number (match-string 2))))
((looking-at
- "Access:\\s-+([0-9]+/\\(\\S-+\\))\\s-+Uid:\\s-+\\([0-9]+\\)\\s-+Gid:\\s-+\\([0-9]+\\)")
+ (concat
+ "Access:\\s-+([[:digit:]]+/\\(\\S-+\\))\\s-+"
+ "Uid:\\s-+\\([[:digit:]]+\\)\\s-+"
+ "Gid:\\s-+\\([[:digit:]]+\\)"))
(setq mode (match-string 1)
uid (if (equal id-format 'string) (match-string 2)
(string-to-number (match-string 2)))
gid (if (equal id-format 'string) (match-string 3)
(string-to-number (match-string 3)))))
((looking-at
- "Access:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)")
+ (concat
+ "Access:\\s-+"
+ "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+"
+ "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)"))
(setq atime
(encode-time
(string-to-number (match-string 6)) ;; sec
@@ -906,7 +912,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(string-to-number (match-string 2)) ;; month
(string-to-number (match-string 1))))) ;; year
((looking-at
- "Modify:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)")
+ (concat
+ "Modify:\\s-+"
+ "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+"
+ "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)"))
(setq mtime
(encode-time
(string-to-number (match-string 6)) ;; sec
@@ -916,7 +925,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(string-to-number (match-string 2)) ;; month
(string-to-number (match-string 1))))) ;; year
((looking-at
- "Change:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)")
+ (concat
+ "Change:\\s-+"
+ "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+"
+ "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)"))
(setq ctime
(encode-time
(string-to-number (match-string 6)) ;; sec
@@ -945,9 +957,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name (file-truename filename) nil
(unless (file-exists-p (file-truename filename))
- (tramp-error
- v tramp-file-missing
- "Cannot make local copy of non-existing file `%s'" filename))
+ (tramp-compat-file-missing v filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(with-tramp-progress-reporter
v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
@@ -992,10 +1002,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (eval-when-compile
- (concat "[[:space:]]*\\([[:digit:]]+\\)"
- " blocks of size \\([[:digit:]]+\\)"
- "\\. \\([[:digit:]]+\\) blocks available")))
+ (concat "[[:space:]]*\\([[:digit:]]+\\)"
+ " blocks of size \\([[:digit:]]+\\)"
+ "\\. \\([[:digit:]]+\\) blocks available"))
(setq blocksize (string-to-number (match-string 2))
total (* blocksize (string-to-number (match-string 1)))
avail (* blocksize (string-to-number (match-string 3)))))
@@ -1025,7 +1034,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq filename (expand-file-name filename))
(unless switches (setq switches ""))
;; Mark trailing "/".
- (when (and (tramp-compat-directory-name-p filename)
+ (when (and (directory-name-p filename)
(not full-directory-p))
(setq switches (concat switches "F")))
(if full-directory-p
@@ -1137,12 +1146,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; of `default-directory'.
(let ((start (point)))
(insert
- (format
- "%s"
- (file-relative-name
- (expand-file-name
- (nth 0 x) (file-name-directory filename))
- (when full-directory-p (file-name-directory filename)))))
+ (file-relative-name
+ (expand-file-name
+ (nth 0 x) (file-name-directory filename))
+ (when full-directory-p (file-name-directory filename))))
(put-text-property start (point) 'dired-filename t))
;; Insert symlink.
@@ -1151,7 +1158,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(insert " -> " (tramp-compat-file-attribute-type attr))))
(insert "\n")
- (forward-line)
(beginning-of-line)))
entries))))))
@@ -1162,7 +1168,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq dir (expand-file-name dir default-directory)))
(with-parsed-tramp-file-name dir nil
(when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists "Directory already exists %s" dir))
+ (tramp-error v 'file-already-exists dir))
(let* ((ldir (file-name-directory dir)))
;; Make missing directory parts.
(when (and parents
@@ -1253,7 +1259,7 @@ component is used as the target of the symlink."
(when (and (numberp destination) (zerop destination))
(error "Implementation does not handle immediate return"))
- (with-parsed-tramp-file-name default-directory nil
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
(let* ((name (file-name-nondirectory program))
(name1 name)
(i 0)
@@ -1371,13 +1377,11 @@ component is used as the target of the symlink."
(with-parsed-tramp-file-name
(if (tramp-tramp-file-p filename) filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "Renaming file" "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(with-tramp-progress-reporter
@@ -1430,10 +1434,10 @@ component is used as the target of the symlink."
(when (and (stringp acl-string) (executable-find tramp-smb-acl-program))
(let* ((share (tramp-smb-get-share v))
- (localname (replace-regexp-in-string
- "\\\\" "/" (tramp-smb-get-localname v)))
+ (localname (tramp-compat-string-replace
+ "\\" "/" (tramp-smb-get-localname v)))
(args (list (concat "//" host "/" share) "-E" "-S"
- (replace-regexp-in-string
+ (tramp-compat-string-replace
"\n" "," acl-string)))
(options tramp-smb-options))
@@ -1479,7 +1483,7 @@ component is used as the target of the symlink."
;; This is meant for traces, and returning from the
;; function. No error is propagated outside, due to
;; the `ignore-errors' closure.
- (unless (tramp-search-regexp "tramp_exit_status [0-9]+")
+ (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+")
(tramp-error
v 'file-error
"Couldn't find exit status of `%s'" tramp-smb-acl-program))
@@ -1493,15 +1497,17 @@ component is used as the target of the symlink."
(tramp-flush-connection-property v "process-name")
(tramp-flush-connection-property v "process-buffer")))))))
-(defun tramp-smb-handle-set-file-modes (filename mode &optional _flag)
+(defun tramp-smb-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (when (tramp-smb-get-cifs-capabilities v)
- (tramp-flush-file-properties v localname)
- (unless (tramp-smb-send-command
- v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode))
- (tramp-error
- v 'file-error "Error while changing file's mode %s" filename)))))
+ ;; smbclient chmod does not support nofollow.
+ (unless (and (eq flag 'nofollow) (file-symlink-p filename))
+ (when (tramp-smb-get-cifs-capabilities v)
+ (tramp-flush-file-properties v localname)
+ (unless (tramp-smb-send-command
+ v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode))
+ (tramp-error
+ v 'file-error "Error while changing file's mode %s" filename))))))
;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
@@ -1573,7 +1579,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
(defun tramp-smb-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -1582,15 +1589,25 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((curbuf (current-buffer))
+ (let ((file-locked (eq (file-locked-p lockname) t))
+ (curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
+
+ ;; Lock file.
+ (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
+ (file-remote-p lockname)
+ (not file-locked))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(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.
- (tramp-run-real-handler
- #'write-region (list start end tmpfile append 'no-message lockname))
+ (let (create-lockfiles)
+ (write-region start end tmpfile append 'no-message))
(with-tramp-progress-reporter
v 3 (format "Moving tmp file %s to %s" tmpfile filename)
@@ -1613,8 +1630,14 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
;; Set file modification time.
(when (or (eq visit t) (stringp visit))
(set-visited-file-modtime
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ (or (tramp-compat-file-attribute-modification-time
+ (file-attributes filename))
+ (current-time))))
+
+ ;; Unlock file.
+ (when file-locked
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
;; The end.
(when (and (null noninteractive)
@@ -1722,21 +1745,21 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
;; Entries provided by smbclient DIR aren't fully regular.
;; They should have the format
;;
-;; \s-\{2,2} - leading spaces
+;; \s-\{2,2\} - leading spaces
;; \S-\(.*\S-\)\s-* - file name, 30 chars, left bound
;; \s-+[ADHRSV]* - permissions, 7 chars, right bound
;; \s- - space delimiter
-;; \s-+[0-9]+ - size, 8 chars, right bound
+;; \s-+[[:digit:]]+ - size, 8 chars, right bound
;; \s-\{2,2\} - space delimiter
;; \w\{3,3\} - weekday
;; \s- - space delimiter
;; \w\{3,3\} - month
;; \s- - space delimiter
-;; [ 12][0-9] - day
+;; [ 12][[:digit:]] - day
;; \s- - space delimiter
-;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time
+;; [[:digit:]]\{2,2\}:[[:digit:]]\{2,2\}:[[:digit:]]\{2,2\} - time
;; \s- - space delimiter
-;; [0-9]\{4,4\} - year
+;; [[:digit:]]\{4,4\} - year
;;
;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html)
;; has function display_finfo:
@@ -1784,13 +1807,14 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(cl-block nil
;; year.
- (if (string-match "\\([0-9]+\\)$" line)
+ (if (string-match "\\([[:digit:]]+\\)$" line)
(setq year (string-to-number (match-string 1 line))
line (substring line 0 -5))
(cl-return))
;; time.
- (if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line)
+ (if (string-match
+ "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)$" line)
(setq hour (string-to-number (match-string 1 line))
min (string-to-number (match-string 2 line))
sec (string-to-number (match-string 3 line))
@@ -1798,7 +1822,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(cl-return))
;; day.
- (if (string-match "\\([0-9]+\\)$" line)
+ (if (string-match "\\([[:digit:]]+\\)$" line)
(setq day (string-to-number (match-string 1 line))
line (substring line 0 -3))
(cl-return))
@@ -1815,7 +1839,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(cl-return))
;; size.
- (if (string-match "\\([0-9]+\\)$" line)
+ (if (string-match "\\([[:digit:]]+\\)$" line)
(let ((length (- (max 10 (1+ (length (match-string 1 line)))))))
(setq size (string-to-number (match-string 1 line)))
(when (string-match
@@ -1870,7 +1894,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(if (and (process-live-p (tramp-get-connection-process vec))
(tramp-get-connection-property vec "posix" t))
(with-tramp-connection-property
- (tramp-get-connection-process vec) "cifs-capabilities"
+ (tramp-get-process vec) "cifs-capabilities"
(save-match-data
(when (tramp-smb-send-command vec "posix")
(with-current-buffer (tramp-get-connection-buffer vec)
@@ -1887,8 +1911,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
;; When we are not logged in yet, we return nil.
(if (and (tramp-smb-get-share vec)
(process-live-p (tramp-get-connection-process vec)))
- (with-tramp-connection-property
- (tramp-get-connection-process vec) "stat-capability"
+ (with-tramp-connection-property (tramp-get-process vec) "stat-capability"
(tramp-smb-send-command vec "stat \"/\""))))
@@ -1918,7 +1941,7 @@ If ARGUMENT is non-nil, use it as argument for
;; Check whether we still have the same smbclient version.
;; Otherwise, we must delete the connection cache, because
- ;; capabilities migh have changed.
+ ;; capabilities might have changed.
(unless (or argument (processp p))
(let ((default-directory (tramp-compat-temporary-file-directory))
(command (concat tramp-smb-program " -V")))
@@ -1950,11 +1973,9 @@ If ARGUMENT is non-nil, use it as argument for
;; connection timeout.
(with-current-buffer buf
(goto-char (point-min))
- ;; `seconds-to-time' can be removed once we get rid of Emacs 24.
- (when (and (time-less-p (seconds-to-time 60)
- (time-since
- (tramp-get-connection-property
- p "last-cmd-time" (seconds-to-time 0))))
+ (when (and (time-less-p
+ 60 (time-since
+ (tramp-get-connection-property p "last-cmd-time" 0)))
(process-live-p p)
(re-search-forward tramp-smb-errors nil t))
(delete-process p)
@@ -1994,10 +2015,8 @@ If ARGUMENT is non-nil, use it as argument for
(when port (setq args (append args (list "-p" port))))
(when tramp-smb-conf
(setq args (append args (list "-s" tramp-smb-conf))))
- (while options
- (setq args
- (append args `("--option" ,(format "%s" (car options))))
- options (cdr options)))
+ (dolist (option options)
+ (setq args (append args (list "--option" option))))
(when argument
(setq args (append args (list argument))))
@@ -2024,8 +2043,11 @@ If ARGUMENT is non-nil, use it as argument for
(process-put p 'adjust-window-size-function #'ignore)
(set-process-query-on-exit-flag p nil)
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
(condition-case err
- (let (tramp-message-show-message)
+ (let ((inhibit-message t))
;; Play login scenario.
(tramp-process-actions
p vec nil
@@ -2057,9 +2079,6 @@ If ARGUMENT is non-nil, use it as argument for
(tramp-set-connection-property p "smb-share" share)
(tramp-set-connection-property p "chunksize" 1)
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
;; Mark it as connected.
(tramp-set-connection-property p "connected" t))
@@ -2131,8 +2150,7 @@ Removes smb prompt. Returns nil if an error message has appeared."
"%s %s"
tramp-smb-winexe-shell-command tramp-smb-winexe-shell-command-switch))
- (set (make-local-variable 'kill-buffer-hook)
- '(tramp-smb-kill-winexe-function))
+ (add-hook 'kill-buffer-hook #'tramp-smb-kill-winexe-function nil t)
;; Suppress "^M". Shouldn't we specify utf8?
(set-process-coding-system (tramp-get-connection-process vec) 'raw-text-dos)
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
new file mode 100644
index 00000000000..c5b84a6e4e4
--- /dev/null
+++ b/lisp/net/tramp-sshfs.el
@@ -0,0 +1,391 @@
+;;; tramp-sshfs.el --- Tramp access functions via sshfs -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; sshfs is a program to mount a virtual file system, based on an sftp
+;; connection. Tramp uses its mount utility to access files and
+;; directories there.
+
+;; A remote file under sshfs control has the form
+;; "/sshfs:user@host#port:/path/to/file". User name and port number
+;; are optional.
+
+;;; Code:
+
+(require 'tramp)
+(require 'tramp-fuse)
+
+;;;###tramp-autoload
+(defconst tramp-sshfs-method "sshfs"
+ "Tramp method for sshfs mounts.")
+
+(defcustom tramp-sshfs-program "sshfs"
+ "The sshfs mount command."
+ :group 'tramp
+ :version "28.1"
+ :type 'string)
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-sshfs-method
+ (tramp-mount-args (("-C") ("-p" "%p")
+ ("-o" "idmap=user,reconnect")))
+ ;; These are for remote processes.
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-q")("-l" "%u") ("-p" "%p")
+ ("-e" "none") ("%h") ("%l")))
+ (tramp-direct-async t)
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+
+ (add-to-list 'tramp-connection-properties
+ `(,(format "/%s:" tramp-sshfs-method) "direct-async-process" t))
+
+ (tramp-set-completion-function
+ tramp-sshfs-method tramp-completion-function-alist-ssh))
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-sshfs-file-name-handler-alist
+ '((access-file . tramp-handle-access-file)
+ (add-name-to-file . tramp-handle-add-name-to-file)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ (copy-directory . tramp-handle-copy-directory)
+ (copy-file . tramp-sshfs-handle-copy-file)
+ (delete-directory . tramp-fuse-handle-delete-directory)
+ (delete-file . tramp-fuse-handle-delete-file)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-handle-directory-file-name)
+ (directory-files . tramp-fuse-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . tramp-sshfs-handle-exec-path)
+ (expand-file-name . tramp-handle-expand-file-name)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-fuse-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-fuse-handle-file-executable-p)
+ (file-exists-p . tramp-handle-file-exists-p)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions . tramp-fuse-handle-file-name-all-completions)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
+ (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-handle-file-newer-than-file-p)
+ (file-notify-add-watch . ignore)
+ (file-notify-rm-watch . ignore)
+ (file-notify-valid-p . ignore)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-fuse-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (file-selinux-context . tramp-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-sshfs-handle-file-system-info)
+ (file-truename . tramp-handle-file-truename)
+ (file-writable-p . tramp-handle-file-writable-p)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-handle-insert-directory)
+ (insert-file-contents . tramp-sshfs-handle-insert-file-contents)
+ (load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
+ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
+ (make-directory . tramp-fuse-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . tramp-handle-make-process)
+ (make-symbolic-link . tramp-handle-make-symbolic-link)
+ (process-file . tramp-sshfs-handle-process-file)
+ (rename-file . tramp-sshfs-handle-rename-file)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-sshfs-handle-set-file-modes)
+ (set-file-selinux-context . ignore)
+ (set-file-times . ignore)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . tramp-handle-shell-command)
+ (start-file-process . tramp-handle-start-file-process)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
+ (tramp-set-file-uid-gid . ignore)
+ (unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-sshfs-handle-write-region))
+"Alist of handler functions for Tramp SSHFS method.
+Operations not mentioned here will be handled by the default Emacs primitives.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-sshfs-file-name-p (filename)
+ "Check if it's a FILENAME for sshfs."
+ (and (tramp-tramp-file-p filename)
+ (string= (tramp-file-name-method (tramp-dissect-file-name filename))
+ tramp-sshfs-method)))
+
+;;;###tramp-autoload
+(defun tramp-sshfs-file-name-handler (operation &rest args)
+ "Invoke the sshfs handler for OPERATION and ARGS.
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-sshfs-file-name-p #'tramp-sshfs-file-name-handler))
+
+
+;; File name primitives.
+
+(defun tramp-sshfs-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
+ (if (file-directory-p filename)
+ (copy-directory filename newname keep-date t)
+ (copy-file
+ (if (tramp-sshfs-file-name-p filename)
+ (tramp-fuse-local-file-name filename) filename)
+ (if (tramp-sshfs-file-name-p newname)
+ (tramp-fuse-local-file-name newname) newname)
+ ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ (when (tramp-sshfs-file-name-p newname)
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-properties v localname)))))
+
+(defun tramp-sshfs-handle-exec-path ()
+ "Like `exec-path' for Tramp files."
+ (append
+ (with-parsed-tramp-file-name default-directory nil
+ (with-tramp-connection-property (tramp-get-process v) "remote-path"
+ (with-temp-buffer
+ (process-file "getconf" nil t nil "PATH")
+ (split-string
+ (progn
+ ;; Read the expression.
+ (goto-char (point-min))
+ (buffer-substring (point) (point-at-eol)))
+ ":" 'omit))))
+ ;; The equivalent to `exec-directory'.
+ `(,(tramp-file-local-name (expand-file-name default-directory)))))
+
+(defun tramp-sshfs-handle-file-system-info (filename)
+ "Like `file-system-info' for Tramp files."
+ ;;`file-system-info' exists since Emacs 27.1.
+ (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename)))
+
+(defun tramp-sshfs-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for Tramp files."
+ (let ((result
+ (insert-file-contents
+ (tramp-fuse-local-file-name filename) visit beg end replace)))
+ (when visit (setq buffer-file-name filename))
+ (cons (expand-file-name filename) (cdr result))))
+
+(defun tramp-sshfs-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 (expand-file-name default-directory) nil
+ (let ((command
+ (format
+ "cd %s && exec %s"
+ localname
+ (mapconcat #'tramp-shell-quote-argument (cons program args) " "))))
+ (unwind-protect
+ (apply
+ #'tramp-call-process
+ v (tramp-get-method-parameter v 'tramp-login-program)
+ infile destination display
+ (tramp-expand-args
+ v 'tramp-login-args
+ ?h (or (tramp-file-name-host v) "")
+ ?u (or (tramp-file-name-user v) "")
+ ?p (or (tramp-file-name-port v) "")
+ ?l command))
+
+ (unless process-file-side-effects
+ (tramp-flush-directory-properties v ""))))))
+
+(defun tramp-sshfs-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
+ (rename-file
+ (if (tramp-sshfs-file-name-p filename)
+ (tramp-fuse-local-file-name filename) filename)
+ (if (tramp-sshfs-file-name-p newname)
+ (tramp-fuse-local-file-name newname) newname)
+ ok-if-already-exists)
+ (when (tramp-sshfs-file-name-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-properties v localname)))
+ (when (tramp-sshfs-file-name-p newname)
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-properties v localname))))
+
+(defun tramp-sshfs-handle-set-file-modes (filename mode &optional flag)
+ "Like `set-file-modes' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (unless (and (eq flag 'nofollow) (file-symlink-p filename))
+ (tramp-flush-file-properties v localname)
+ (tramp-compat-set-file-modes
+ (tramp-fuse-local-file-name filename) mode flag))))
+
+(defun tramp-sshfs-handle-write-region
+ (start end filename &optional append visit lockname mustbenew)
+ "Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
+ (with-parsed-tramp-file-name filename nil
+ (when (and mustbenew (file-exists-p filename)
+ (or (eq mustbenew 'excl)
+ (not
+ (y-or-n-p
+ (format "File %s exists; overwrite anyway? " filename)))))
+ (tramp-error v 'file-already-exists filename))
+
+ (let ((file-locked (eq (file-locked-p lockname) t)))
+
+ ;; Lock file.
+ (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
+ (file-remote-p lockname)
+ (not file-locked))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
+ (let (create-lockfiles)
+ (write-region
+ start end (tramp-fuse-local-file-name filename) append 'nomessage)
+ (tramp-flush-file-properties v localname))
+
+ ;; Unlock file.
+ (when file-locked
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
+ ;; The end.
+ (when (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook))))
+
+
+;; File name conversions.
+
+(defun tramp-sshfs-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."
+ ;; During completion, don't reopen a new connection.
+ (unless (tramp-connectable-p vec)
+ (throw 'non-essential 'non-essential))
+
+ ;; We need a process bound to the connection buffer. Therefore, we
+ ;; create a dummy process. Maybe there is a better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (process-put p 'vector vec)
+ (set-process-query-on-exit-flag p nil)
+
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ ;; Create directory.
+ (unless (file-directory-p (tramp-fuse-mount-point vec))
+ (make-directory (tramp-fuse-mount-point vec) 'parents))
+
+ (unless
+ (or (tramp-fuse-mounted-p vec)
+ (with-temp-buffer
+ (zerop
+ (apply
+ #'tramp-call-process
+ vec tramp-sshfs-program nil t nil
+ (tramp-fuse-mount-spec vec)
+ (tramp-fuse-mount-point vec)
+ (tramp-expand-args
+ vec 'tramp-mount-args
+ ?p (or (tramp-file-name-port vec) "")))))
+ (tramp-error
+ vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))))
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t)))
+
+ ;; In `tramp-check-cached-permissions', the connection properties
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
+ (with-tramp-connection-property
+ vec "uid-integer" (tramp-get-local-uid 'integer))
+ (with-tramp-connection-property
+ vec "gid-integer" (tramp-get-local-gid 'integer))
+ (with-tramp-connection-property
+ vec "uid-string" (tramp-get-local-uid 'string))
+ (with-tramp-connection-property
+ vec "gid-string" (tramp-get-local-gid 'string)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-sshfs 'force)))
+
+(provide 'tramp-sshfs)
+
+;;; tramp-sshfs.el ends here
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 22776e08361..5895f1d25b5 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -88,6 +88,7 @@ See `tramp-actions-before-shell' for more info.")
(file-exists-p . tramp-sudoedit-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions
. tramp-sudoedit-handle-file-name-all-completions)
@@ -115,9 +116,11 @@ See `tramp-actions-before-shell' for more info.")
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-sudoedit-handle-make-directory)
(make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link)
@@ -132,8 +135,11 @@ See `tramp-actions-before-shell' for more info.")
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-sudoedit-handle-write-region))
@@ -151,12 +157,11 @@ See `tramp-actions-before-shell' for more info.")
;;;###tramp-autoload
(defun tramp-sudoedit-file-name-handler (operation &rest args)
"Invoke the SUDOEDIT handler for OPERATION and ARGS.
-First arg specifies the OPERATION, second arg is a list of arguments to
-pass to the OPERATION."
- (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist)))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###tramp-autoload
(tramp--with-startup
@@ -232,7 +237,7 @@ absolute file names."
(file-attributes filename)))
(file-modes (tramp-default-file-modes filename))
(attributes (and preserve-extended-attributes
- (apply #'file-extended-attributes (list filename))))
+ (file-extended-attributes filename)))
(sudoedit-operation
(cond
((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p"))
@@ -242,13 +247,11 @@ absolute file names."
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "%s file" msg-operation "No such file or directory" filename))
+ (tramp-compat-file-missing v filename))
(when (and (not ok-if-already-exists) (file-exists-p newname))
(tramp-error v 'file-already-exists newname))
(when (and (file-directory-p newname)
- (not (tramp-compat-directory-name-p newname)))
+ (not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
(if (or (and (file-remote-p filename) (not t1))
@@ -282,14 +285,15 @@ absolute file names."
;; Set the time and mode. Mask possible errors.
(when keep-date
(ignore-errors
- (set-file-times newname file-times)
+ (tramp-compat-set-file-times
+ newname file-times (unless ok-if-already-exists 'nofollow))
(set-file-modes newname file-modes)))
;; Handle `preserve-extended-attributes'. We ignore possible
;; errors, because ACL strings could be incompatible.
(when attributes
(ignore-errors
- (apply #'set-file-extended-attributes (list newname attributes))))
+ (set-file-extended-attributes newname attributes)))
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename v1
@@ -303,8 +307,8 @@ absolute file names."
(filename newname &optional ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
"Like `copy-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -319,29 +323,25 @@ absolute file names."
(defun tramp-sudoedit-handle-delete-directory
(directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (setq directory (expand-file-name directory))
- (with-parsed-tramp-file-name directory nil
- (tramp-flush-directory-properties v localname)
- (unless
- (tramp-sudoedit-send-command
- v (or (and trash "trash")
- (if recursive '("rm" "-rf") "rmdir"))
- (tramp-compat-file-name-unquote localname))
+ (tramp-skeleton-delete-directory directory recursive trash
+ (unless (tramp-sudoedit-send-command
+ v (if recursive '("rm" "-rf") "rmdir")
+ (tramp-compat-file-name-unquote localname))
(tramp-error v 'file-error "Couldn't delete %s" directory))))
(defun tramp-sudoedit-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
- (unless
- (tramp-sudoedit-send-command
- v (if (and trash delete-by-moving-to-trash) "trash" "rm")
- (tramp-compat-file-name-unquote localname))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error "Couldn't delete %s" filename)))))
+ (if (and delete-by-moving-to-trash trash)
+ (move-file-to-trash filename)
+ (unless (tramp-sudoedit-send-command
+ v "rm" (tramp-compat-file-name-unquote localname))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error "Couldn't delete %s" filename))))))
(defun tramp-sudoedit-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files.
@@ -353,7 +353,7 @@ the result will be a local, non-Tramp, file name."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
(with-parsed-tramp-file-name name nil
;; Tilde expansion if necessary. We cannot accept "~/", because
;; under sudo "~/" is expanded to the local user home directory
@@ -368,12 +368,15 @@ the result will be a local, non-Tramp, file name."
(when (string-equal uname "~")
(setq uname (concat uname user)))
(setq localname (concat uname fname))))
+ ;; Do not keep "/..".
+ (when (string-match-p "^/\\.\\.?$" localname)
+ (setq localname "/"))
;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../").
(tramp-make-tramp-file-name v (expand-file-name localname))))
(defun tramp-sudoedit-remote-acl-p (vec)
"Check, whether ACL is enabled on the remote host."
- (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p"
+ (with-tramp-connection-property (tramp-get-process vec) "acl-p"
(zerop (tramp-call-process vec "getfacl" nil nil nil "/"))))
(defun tramp-sudoedit-handle-file-acl (filename)
@@ -464,19 +467,21 @@ the result will be a local, non-Tramp, file name."
(tramp-sudoedit-send-command
v "test" "-r" (tramp-compat-file-name-unquote localname)))))
-(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional _flag)
+(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-properties v localname)
- (unless (tramp-sudoedit-send-command
- v "chmod" (format "%o" mode)
- (tramp-compat-file-name-unquote localname))
- (tramp-error
- v 'file-error "Error while changing file's mode %s" filename))))
+ ;; It is unlikely that "chmod -h" works.
+ (unless (and (eq flag 'nofollow) (file-symlink-p filename))
+ (tramp-flush-file-properties v localname)
+ (unless (tramp-sudoedit-send-command
+ v "chmod" (format "%o" mode)
+ (tramp-compat-file-name-unquote localname))
+ (tramp-error
+ v 'file-error "Error while changing file's mode %s" filename)))))
(defun tramp-sudoedit-remote-selinux-p (vec)
"Check, whether SELINUX is enabled on the remote host."
- (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p"
+ (with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(zerop (tramp-call-process vec "selinuxenabled"))))
(defun tramp-sudoedit-handle-file-selinux-context (filename)
@@ -484,9 +489,8 @@ the result will be a local, non-Tramp, file name."
(with-parsed-tramp-file-name filename nil
(with-tramp-file-property v localname "file-selinux-context"
(let ((context '(nil nil nil nil))
- (regexp (eval-when-compile
- (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
- "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))))
+ (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):"
+ "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)")))
(when (and (tramp-sudoedit-remote-selinux-p v)
(tramp-sudoedit-send-command
v "ls" "-d" "-Z"
@@ -511,10 +515,9 @@ the result will be a local, non-Tramp, file name."
(goto-char (point-min))
(forward-line)
(when (looking-at
- (eval-when-compile
- (concat "[[:space:]]*\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)"
- "[[:space:]]+\\([[:digit:]]+\\)")))
+ (concat "[[:space:]]*\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"
+ "[[:space:]]+\\([[:digit:]]+\\)"))
(list (string-to-number (match-string 1))
;; The second value is the used size. We need the
;; free size.
@@ -522,7 +525,7 @@ the result will be a local, non-Tramp, file name."
(string-to-number (match-string 2)))
(string-to-number (match-string 3)))))))))
-(defun tramp-sudoedit-handle-set-file-times (filename &optional time _flag)
+(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
@@ -535,14 +538,14 @@ the result will be a local, non-Tramp, file name."
(tramp-sudoedit-send-command
v "env" "TZ=UTC" "touch" "-t"
(format-time-string "%Y%m%d%H%M.%S" time t)
+ (if (eq flag 'nofollow) "-h" "")
(tramp-compat-file-name-unquote localname)))))
(defun tramp-sudoedit-handle-file-truename (filename)
"Like `file-truename' for Tramp files."
;; Preserve trailing "/".
(funcall
- (if (tramp-compat-directory-name-p filename)
- #'file-name-as-directory #'identity)
+ (if (directory-name-p filename) #'file-name-as-directory #'identity)
;; Quote properly.
(funcall
(if (tramp-compat-file-name-quoted-p filename)
@@ -642,8 +645,8 @@ component is used as the target of the symlink."
(defun tramp-sudoedit-handle-rename-file
(filename newname &optional ok-if-already-exists)
"Like `rename-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
+ (setq filename (expand-file-name filename)
+ newname (expand-file-name newname))
;; At least one file a Tramp file?
(if (or (tramp-tramp-file-p filename)
(tramp-tramp-file-p newname))
@@ -651,7 +654,7 @@ component is used as the target of the symlink."
'rename filename newname ok-if-already-exists
'keep-date 'preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file (list filename newname ok-if-already-exists))))
+ #'rename-file (list filename newname ok-if-already-exists))))
(defun tramp-sudoedit-handle-set-file-acl (filename acl-string)
"Like `set-file-acl' for Tramp files."
@@ -687,21 +690,19 @@ component is used as the target of the symlink."
(tramp-flush-file-property v localname "file-selinux-context"))
t)))))
-(defun tramp-sudoedit-get-remote-uid (vec id-format)
+(defun tramp-sudoedit-handle-get-remote-uid (vec id-format)
"The uid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (if (equal id-format 'integer)
- (tramp-sudoedit-send-command-and-read vec "id" "-u")
- (tramp-sudoedit-send-command-string vec "id" "-un"))))
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-u")
+ (tramp-sudoedit-send-command-string vec "id" "-un")))
-(defun tramp-sudoedit-get-remote-gid (vec id-format)
+(defun tramp-sudoedit-handle-get-remote-gid (vec id-format)
"The gid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (if (equal id-format 'integer)
- (tramp-sudoedit-send-command-and-read vec "id" "-g")
- (tramp-sudoedit-send-command-string vec "id" "-gn"))))
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-g")
+ (tramp-sudoedit-send-command-string vec "id" "-gn")))
(defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
@@ -709,27 +710,30 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-sudoedit-send-command
v "chown"
(format "%d:%d"
- (or uid (tramp-sudoedit-get-remote-uid v 'integer))
- (or gid (tramp-sudoedit-get-remote-gid v 'integer)))
+ (or uid (tramp-get-remote-uid v 'integer))
+ (or gid (tramp-get-remote-gid v 'integer)))
(tramp-unquote-file-local-name filename))))
(defun tramp-sudoedit-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (let ((uid (or (tramp-compat-file-attribute-user-id
- (file-attributes filename 'integer))
- (tramp-sudoedit-get-remote-uid v 'integer)))
- (gid (or (tramp-compat-file-attribute-group-id
- (file-attributes filename 'integer))
- (tramp-sudoedit-get-remote-gid v 'integer)))
- (modes (tramp-default-file-modes filename)))
+ (let* ((uid (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (tramp-compat-file-attribute-group-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-gid v 'integer)))
+ (flag (and (eq mustbenew 'excl) 'nofollow))
+ (modes (tramp-default-file-modes filename flag))
+ (attributes (file-extended-attributes filename)))
(prog1
(tramp-handle-write-region
start end filename append visit lockname mustbenew)
- ;; Set the ownership and modes. This is not performed in
- ;; `tramp-handle-write-region'.
+ ;; Set the ownership, modes and extended attributes. This is
+ ;; not performed in `tramp-handle-write-region'.
(unless (and (= (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
uid)
@@ -737,7 +741,12 @@ ID-FORMAT valid values are `string' and `integer'."
(file-attributes filename 'integer))
gid))
(tramp-set-file-uid-gid filename uid gid))
- (set-file-modes filename modes)))))
+ (tramp-compat-set-file-modes filename modes flag)
+ ;; We ignore possible errors, because ACL strings could be
+ ;; incompatible.
+ (when attributes
+ (ignore-errors
+ (set-file-extended-attributes filename attributes)))))))
;; Internal functions.
@@ -778,18 +787,14 @@ connection if a previous connection has died for some reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
;; Mark it as connected.
- (tramp-set-connection-property p "connected" t))
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (tramp-sudoedit-get-remote-uid vec 'integer)
- (tramp-sudoedit-get-remote-gid vec 'integer)
- (tramp-sudoedit-get-remote-uid vec 'string)
- (tramp-sudoedit-get-remote-gid vec 'string)))
+ (tramp-set-connection-property p "connected" t))))
(defun tramp-sudoedit-send-command (vec &rest args)
"Send commands ARGS to connection VEC.
@@ -800,24 +805,21 @@ in case of error, t otherwise."
(tramp-sudoedit-maybe-open-connection vec)
(with-current-buffer (tramp-get-connection-buffer vec)
(erase-buffer)
- (let* ((login (tramp-get-method-parameter vec 'tramp-sudo-login))
- (host (or (tramp-file-name-host vec) ""))
- (user (or (tramp-file-name-user vec) ""))
- (spec (format-spec-make ?h host ?u user))
- (args (append
- (tramp-compat-flatten-tree
- (mapcar
- (lambda (x)
- (setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) x))
- login))
- (tramp-compat-flatten-tree (delq nil args))))
- (delete-exited-processes t)
+ (let* ((delete-exited-processes t)
(process-connection-type tramp-process-connection-type)
(p (apply #'start-process
- (tramp-get-connection-name vec) (current-buffer) args))
+ (tramp-get-connection-name vec) (current-buffer)
+ (append
+ (tramp-expand-args
+ vec 'tramp-sudo-login
+ ?h (or (tramp-file-name-host vec) "")
+ ?u (or (tramp-file-name-user vec) ""))
+ (tramp-compat-flatten-tree args))))
;; We suppress the messages `Waiting for prompts from remote shell'.
(tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose))
+ ;; The password shall be cached also in case of "emacs -Q".
+ ;; See `tramp-process-actions'.
+ (tramp-cache-read-persistent-data t)
;; We do not want to save the password.
auth-source-save-behavior)
(tramp-message vec 6 "%s" (string-join (process-command p) " "))
diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el
index 065f8a1b448..5171b9d1819 100644
--- a/lisp/net/tramp-uu.el
+++ b/lisp/net/tramp-uu.el
@@ -94,8 +94,3 @@
(provide 'tramp-uu)
;;; tramp-uu.el ends here
-
-;; Local Variables:
-;; mode: Emacs-Lisp
-;; coding: utf-8
-;; End:
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 570294e8b91..959a0e74352 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -7,10 +7,6 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp
-;; Version: 2.4.5.27.2
-;; Package-Requires: ((emacs "24.4"))
-;; Package-Type: multi
-;; URL: https://savannah.gnu.org/projects/tramp
;; This file is part of GNU Emacs.
@@ -64,9 +60,14 @@
;; Pacify byte-compiler.
(require 'cl-lib)
+(declare-function file-notify-rm-watch "filenotify")
(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
+;; Reload `tramp-compat' when we reload `tramp-autoloads' of the GNU ELPA package.
+;;;###autoload (when (featurep 'tramp-compat)
+;;;###autoload (load "tramp-compat" 'noerror 'nomessage))
+
;;; User Customizable Internal Variables:
(defgroup tramp nil
@@ -79,6 +80,7 @@
(eval-and-compile ;; So it's also available in tramp-loaddefs.el!
(defvar tramp--startup-hook nil
"Forms to be executed at the end of tramp.el.")
+ (put 'tramp--startup-hook 'tramp-suppress-trace t)
(defmacro tramp--with-startup (&rest body)
"Schedule BODY to be executed at the end of tramp.el."
@@ -107,9 +109,17 @@ Any level x includes messages for all levels 1 .. x-1. The levels are
7 file caching
8 connection properties
9 test commands
-10 traces (huge)."
+10 traces (huge)
+11 call traces (maintainer only)."
:type 'integer)
+(defcustom tramp-debug-to-file nil
+ "Whether Tramp debug messages shall be saved to file.
+The debug file has the same name as the debug buffer, written to
+`temporary-file-directory'."
+ :version "28.1"
+ :type 'boolean)
+
(defcustom tramp-backup-directory-alist nil
"Alist of filename patterns and backup directory names.
Each element looks like (REGEXP . DIRECTORY), with the same meaning like
@@ -242,6 +252,9 @@ pair of the form (KEY VALUE). The following KEYs are defined:
- \"%k\" indicates the keep-date parameter of a program, if exists.
- \"%c\" adds additional `tramp-ssh-controlmaster-options'
options for the first hop.
+ - \"%n\" expands to \"2>/dev/null\".
+ - \"%x\" is replaced by the `tramp-scp-strict-file-name-checking'
+ argument if it is supported.
The existence of `tramp-login-args', combined with the
absence of `tramp-copy-args', is an indication that the
@@ -253,6 +266,10 @@ pair of the form (KEY VALUE). The following KEYs are defined:
parameters to suppress diagnostic messages, in order not to
tamper the process output.
+ * `tramp-direct-async'
+ Whether the method supports direct asynchronous processes.
+ Until now, just \"ssh\"-based and \"adb\"-based methods do.
+
* `tramp-copy-program'
This specifies the name of the program to use for remotely copying
the file; this might be the absolute filename of scp or the name of
@@ -344,12 +361,13 @@ Notes:
All these arguments can be overwritten by connection properties.
See Info node `(tramp) Predefined connection information'.
-When using `su' or `sudo' the phrase \"open connection to a remote
-host\" sounds strange, but it is used nevertheless, for consistency.
-No connection is opened to a remote host, but `su' or `sudo' is
-started on the local host. You should specify a remote host
-`localhost' or the name of the local host. Another host name is
-useful only in combination with `tramp-default-proxies-alist'.")
+When using `su', `sudo' or `doas' the phrase \"open connection to
+a remote host\" sounds strange, but it is used nevertheless, for
+consistency. No connection is opened to a remote host, but `su',
+`sudo' or `doas' is started on the local host. You should
+specify a remote host `localhost' or the name of the local host.
+Another host name is useful only in combination with
+`tramp-default-proxies-alist'.")
(defcustom tramp-default-method
;; An external copy method seems to be preferred, because it performs
@@ -376,6 +394,8 @@ Also see `tramp-default-method-alist'."
:type 'string)
(defcustom tramp-default-method-alist nil
+ ;; FIXME: This is not an "alist", because its elements are not of
+ ;; the form (KEY . VAL) but (KEY1 KEY2 VAL).
"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
@@ -403,6 +423,8 @@ This variable is regarded as obsolete, and will be removed soon."
:type '(choice (const nil) string))
(defcustom tramp-default-user-alist nil
+ ;; FIXME: This is not an "alist", because its elements are not of
+ ;; the form (KEY . VAL) but (KEY1 KEY2 VAL).
"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
@@ -422,6 +444,8 @@ Useful for su and sudo methods mostly."
:type 'string)
(defcustom tramp-default-host-alist nil
+ ;; FIXME: This is not an "alist", because its elements are not of
+ ;; the form (KEY . VAL) but (KEY1 KEY2 VAL).
"Default host to use for specific method/user pairs.
This is an alist of items (METHOD USER HOST). The first matching item
specifies the host to use for a file name which does not specify a
@@ -437,6 +461,8 @@ empty string for the method name."
(choice :tag " Host name" string (const nil)))))
(defcustom tramp-default-proxies-alist nil
+ ;; FIXME: This is not an "alist", because its elements are not of
+ ;; the form (KEY . VAL) but (KEY1 KEY2 VAL).
"Route to be followed for specific host/user pairs.
This is an alist of items (HOST USER PROXY). The first matching
item specifies the proxy to be passed for a file name located on
@@ -469,7 +495,7 @@ interpreted as a regular expression which always matches."
;; either lower case or upper case letters. See
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38079#20>.
(defcustom tramp-restricted-shell-hosts-alist
- (when (memq system-type '(windows-nt))
+ (when (eq system-type 'windows-nt)
(list (format "\\`\\(%s\\|%s\\)\\'"
(regexp-quote (downcase tramp-system-name))
(regexp-quote (upcase tramp-system-name)))))
@@ -539,7 +565,7 @@ usually suffice.")
the remote shell.")
(defcustom tramp-local-end-of-line
- (if (memq system-type '(windows-nt)) "\r\n" "\n")
+ (if (eq system-type 'windows-nt) "\r\n" "\n")
"String used for end of line in local processes."
:version "24.1"
:type 'string)
@@ -560,12 +586,11 @@ Sometimes the prompt is reported to look like \"login as:\"."
(defcustom tramp-shell-prompt-pattern
;; Allow a prompt to start right after a ^M since it indeed would be
- ;; displayed at the beginning of the line (and Zsh uses it). This
- ;; regexp works only for GNU Emacs.
+ ;; displayed at the beginning of the line (and Zsh uses it).
;; Allow also [] style prompts. They can appear only during
;; connection initialization; Tramp redefines the prompt afterwards.
(concat "\\(?:^\\|\r\\)"
- "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*")
+ "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[[:digit:];]*[[:alpha:]] *\\)*")
"Regexp to match prompts from remote shell.
Normally, Tramp expects you to configure `shell-prompt-pattern'
correctly, but sometimes it happens that you are connecting to a
@@ -584,6 +609,11 @@ This regexp must match both `tramp-initial-end-of-output' and
"Regexp matching password-like prompts.
The regexp should match at end of buffer.
+This variable is, by default, initialised from
+`password-word-equivalents' when Tramp is loaded, and it is
+usually more convenient to add new passphrases to that variable
+instead of altering this variable.
+
The `sudo' program appears to insert a `^@' character into the prompt."
:version "24.4"
:type 'regexp)
@@ -606,7 +636,7 @@ The `sudo' program appears to insert a `^@' character into the prompt."
"\\|"
"^.*\\("
;; Here comes a list of regexes, separated by \\|
- "Received signal [0-9]+"
+ "Received signal [[:digit:]]+"
"\\).*")
"Regexp matching a `login failed' message.
The regexp should match at end of buffer."
@@ -637,6 +667,14 @@ The regexp should match at end of buffer.
See also `tramp-yesno-prompt-regexp'."
:type 'regexp)
+(defcustom tramp-terminal-type "dumb"
+ "Value of TERM environment variable for logging in to remote host.
+Because Tramp wants to parse the output of the remote shell, it is easily
+confused by ANSI color escape sequences and suchlike. Often, shell init
+files conditionalize this setup based on the TERM environment variable."
+ :group 'tramp
+ :type 'string)
+
(defcustom tramp-terminal-prompt-regexp
(concat "\\("
"TERM = (.*)"
@@ -659,6 +697,15 @@ The regexp should match at end of buffer."
:version "27.1"
:type 'regexp)
+;; Yubikey requires the user physically to touch the device with their
+;; finger. We must tell it to the user.
+(defcustom tramp-yubikey-regexp
+ "^\r*Confirm user presence for key .*[\r\n]*"
+ "Regular expression matching yubikey confirmation message.
+The regexp should match at end of buffer."
+ :version "28.1"
+ :type 'regexp)
+
(defcustom tramp-operation-not-permitted-regexp
(concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*"
(regexp-opt '("Operation not permitted") t))
@@ -751,7 +798,7 @@ to be set, depending on VALUE."
tramp-postfix-host-format (tramp-build-postfix-host-format)
tramp-postfix-host-regexp (tramp-build-postfix-host-regexp)
tramp-remote-file-name-spec-regexp
- (tramp-build-remote-file-name-spec-regexp)
+ (tramp-build-remote-file-name-spec-regexp)
tramp-file-name-structure (tramp-build-file-name-structure)
tramp-file-name-regexp (tramp-build-file-name-regexp)
tramp-completion-file-name-regexp
@@ -802,9 +849,9 @@ Used in `tramp-make-tramp-file-name'.")
Should always start with \"^\". Derived from `tramp-prefix-format'.")
(defconst tramp-method-regexp-alist
- '((default . "[a-zA-Z0-9-]+")
+ '((default . "[[:alnum:]-]+")
(simplified . "")
- (separate . "[a-zA-Z0-9-]*"))
+ (separate . "[[:alnum:]-]*"))
"Alist mapping Tramp syntax to regexps matching methods identifiers.")
(defun tramp-build-method-regexp ()
@@ -848,7 +895,7 @@ Derived from `tramp-postfix-method-format'.")
"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 "[[:alnum:]_.-]+"
"Regexp matching domain names.")
(defconst tramp-user-with-domain-regexp
@@ -865,7 +912,7 @@ Used in `tramp-make-tramp-file-name'.")
"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 "[[:alnum:]_.%-]+"
"Regexp matching host names.")
(defconst tramp-prefix-ipv6-format-alist
@@ -893,7 +940,7 @@ Derived from `tramp-prefix-ipv6-format'.")
;; The following regexp is a bit sloppy. But it shall serve our
;; purposes. It covers also IPv4 mapped IPv6 addresses, like in
;; "::ffff:192.168.0.1".
-(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+"
+(defconst tramp-ipv6-regexp "\\(?:[[:alnum:]]*:\\)+[[:alnum:].]+"
"Regexp matching IPv6 addresses.")
(defconst tramp-postfix-ipv6-format-alist
@@ -925,7 +972,7 @@ Derived from `tramp-postfix-ipv6-format'.")
"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 "[[:digit:]]+"
"Regexp matching port numbers.")
(defconst tramp-host-with-port-regexp
@@ -1003,8 +1050,8 @@ See `tramp-file-name-structure'."
5 6 7 8 1))
(defvar tramp-file-name-structure nil ;Initialized when defining `tramp-syntax'!
- "List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \
-the Tramp file name structure.
+ "List detailing the Tramp file name structure.
+This is a list of six elements (REGEXP METHOD USER HOST FILE HOP).
The first element REGEXP is a regular expression matching a Tramp file
name. The regex should contain parentheses around the method name,
@@ -1046,7 +1093,13 @@ initial value is overwritten by the car of `tramp-file-name-structure'.")
(defconst tramp-completion-file-name-regexp-default
(concat
- "\\`/\\("
+ "\\`"
+ ;; `file-name-completion' uses absolute paths for matching. This
+ ;; means that on W32 systems, something like "/ssh:host:~/path"
+ ;; becomes "c:/ssh:host:~/path". See also `tramp-drop-volume-letter'.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\("
;; Optional multi hop.
"\\([^/|:]+:[^/|:]*|\\)*"
;; Last hop.
@@ -1065,7 +1118,13 @@ On W32 systems, the volume letter must be ignored.")
(defconst tramp-completion-file-name-regexp-simplified
(concat
- "\\`/\\("
+ "\\`"
+ ;; Allow the volume letter at the beginning of the path. See the
+ ;; comment in `tramp-completion-file-name-regexp-default' for more
+ ;; details.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\("
;; Optional multi hop.
"\\([^/|:]*|\\)*"
;; Last hop.
@@ -1081,7 +1140,14 @@ See `tramp-file-name-structure' for more explanations.
On W32 systems, the volume letter must be ignored.")
(defconst tramp-completion-file-name-regexp-separate
- "\\`/\\(\\[[^]]*\\)?\\'"
+ (concat
+ "\\`"
+ ;; Allow the volume letter at the beginning of the path. See the
+ ;; comment in `tramp-completion-file-name-regexp-default' for more
+ ;; details.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\(\\[[^]]*\\)?\\'")
"Value for `tramp-completion-file-name-regexp' for separate remoting.
See `tramp-file-name-structure' for more explanations.")
@@ -1220,6 +1286,67 @@ let-bind this variable."
:version "24.4"
:type '(choice (const nil) integer))
+;; "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, RHEL): /bin:/usr/bin
+;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
+;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin
+;; IRIX64: /usr/bin
+;; QNAP QTS: ---
+;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin
+(defcustom tramp-remote-path
+ '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin"
+ "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin"
+ "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin"
+ "/opt/bin" "/opt/sbin" "/opt/local/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 head 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. This entry is represented in
+the list by the special value `tramp-default-remote-path'.
+
+`Private Directories' are the settings of the $PATH environment,
+as given in your `~/.profile'. This entry is represented in
+the list by the special value `tramp-own-remote-path'."
+ :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
+ '("ENV=''" "TMOUT=0" "LC_CTYPE=''"
+ "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat"
+ "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= disables the corresponding environment variable,
+which might have been set in the init files like ~/.profile.
+
+Special handling is applied to some environment variables,
+which should not be set here:
+
+The PATH environment variable should be set via `tramp-remote-path'.
+
+The TERM environment variable should be set via `tramp-terminal-type'.
+
+The INSIDE_EMACS environment variable will automatically be set
+based on the Tramp and Emacs versions, and should not be set here."
+ :group 'tramp
+ :version "26.1"
+ :type '(repeat string))
+
(defcustom tramp-completion-reread-directory-timeout 10
"Defines seconds since last remote command before rereading a directory.
A remote directory might have changed its contents. In order to
@@ -1244,6 +1371,7 @@ the (optional) timestamp of last activity on this connection.")
"Password save function.
Will be called once the password has been verified by successful
authentication.")
+(put 'tramp-password-save-function 'tramp-suppress-trace t)
(defconst tramp-completion-file-name-handler-alist
'((file-name-all-completions
@@ -1267,10 +1395,18 @@ calling HANDLER.")
;; data structure.
;; The basic structure for remote file names. We use a list :type,
-;; in order to be compatible with Emacs 24 and 25.
+;; in order to be compatible with Emacs 25.
(cl-defstruct (tramp-file-name (:type list) :named)
method user domain host port localname hop)
+(put #'tramp-file-name-method 'tramp-suppress-trace t)
+(put #'tramp-file-name-user 'tramp-suppress-trace t)
+(put #'tramp-file-name-domain 'tramp-suppress-trace t)
+(put #'tramp-file-name-host 'tramp-suppress-trace t)
+(put #'tramp-file-name-port 'tramp-suppress-trace t)
+(put #'tramp-file-name-localname 'tramp-suppress-trace t)
+(put #'tramp-file-name-hop 'tramp-suppress-trace t)
+
(defun tramp-file-name-user-domain (vec)
"Return user and domain components of VEC."
(when (or (tramp-file-name-user vec) (tramp-file-name-domain vec))
@@ -1279,6 +1415,8 @@ calling HANDLER.")
tramp-prefix-domain-format)
(tramp-file-name-domain vec))))
+(put #'tramp-file-name-user-domain 'tramp-suppress-trace t)
+
(defun tramp-file-name-host-port (vec)
"Return host and port components of VEC."
(when (or (tramp-file-name-host vec) (tramp-file-name-port vec))
@@ -1287,13 +1425,17 @@ calling HANDLER.")
tramp-prefix-port-format)
(tramp-file-name-port vec))))
+(put #'tramp-file-name-host-port 'tramp-suppress-trace t)
+
(defun tramp-file-name-port-or-default (vec)
"Return port component of VEC.
If nil, return `tramp-default-port'."
(or (tramp-file-name-port vec)
(tramp-get-method-parameter vec 'tramp-default-port)))
-;; Comparision of file names is performed by `tramp-equal-remote'.
+(put #'tramp-file-name-port-or-default 'tramp-suppress-trace t)
+
+;; Comparison of file names is performed by `tramp-equal-remote'.
(defun tramp-file-name-equal-p (vec1 vec2)
"Check, whether VEC1 and VEC2 denote the same `tramp-file-name'."
(and (tramp-file-name-p vec1) (tramp-file-name-p vec2)
@@ -1315,9 +1457,10 @@ entry does not exist, return nil."
;; We use the cached property.
(tramp-get-connection-property vec hash-entry nil)
;; Use the static value from `tramp-methods'.
- (let ((methods-entry
- (assoc param (assoc (tramp-file-name-method vec) tramp-methods))))
- (when methods-entry (cadr methods-entry))))))
+ (when-let ((methods-entry
+ (assoc
+ param (assoc (tramp-file-name-method vec) tramp-methods))))
+ (cadr methods-entry)))))
;; The localname can be quoted with "/:". Extract this.
(defun tramp-file-name-unquote-localname (vec)
@@ -1338,6 +1481,8 @@ entry does not exist, return nil."
(string-match-p tramp-file-name-regexp name)
t))
+(put #'tramp-tramp-file-p 'tramp-suppress-trace t)
+
;; This function bypasses the file name handler approach. It is NOT
;; recommended to use it in any package if not absolutely necessary.
;; However, it is more performant than `file-local-name', and might be
@@ -1377,8 +1522,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in
(setq item (pop choices))
(when (and (string-match-p (or (nth 0 item) "") (or host ""))
(string-match-p (or (nth 1 item) "") (or user "")))
- (setq lmethod (nth 2 item))
- (setq choices nil)))
+ (setq lmethod (nth 2 item)
+ choices nil)))
lmethod)
tramp-default-method)))
;; We must mark, whether a default value has been used.
@@ -1386,6 +1531,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
+(put #'tramp-find-method 'tramp-suppress-trace t)
+
(defun tramp-find-user (method user host)
"Return the right user string to use depending on METHOD and HOST.
This is USER, if non-nil. Otherwise, do a lookup in
@@ -1398,8 +1545,8 @@ This is USER, if non-nil. Otherwise, do a lookup in
(setq item (pop choices))
(when (and (string-match-p (or (nth 0 item) "") (or method ""))
(string-match-p (or (nth 1 item) "") (or host "")))
- (setq luser (nth 2 item))
- (setq choices nil)))
+ (setq luser (nth 2 item)
+ choices nil)))
luser)
tramp-default-user)))
;; We must mark, whether a default value has been used.
@@ -1407,6 +1554,8 @@ This is USER, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
+(put #'tramp-find-user 'tramp-suppress-trace t)
+
(defun tramp-find-host (method user host)
"Return the right host string to use depending on METHOD and USER.
This is HOST, if non-nil. Otherwise, do a lookup in
@@ -1419,8 +1568,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in
(setq item (pop choices))
(when (and (string-match-p (or (nth 0 item) "") (or method ""))
(string-match-p (or (nth 1 item) "") (or user "")))
- (setq lhost (nth 2 item))
- (setq choices nil)))
+ (setq lhost (nth 2 item)
+ choices nil)))
lhost)
tramp-default-host)))
;; We must mark, whether a default value has been used.
@@ -1428,6 +1577,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
+(put #'tramp-find-host 'tramp-suppress-trace t)
+
(defun tramp-dissect-file-name (name &optional nodefault)
"Return a `tramp-file-name' structure of NAME, a remote file name.
The structure consists of method, user, domain, host, port,
@@ -1482,19 +1633,18 @@ default values are used."
:method method :user user :domain domain :host host
:port port :localname localname :hop hop))
;; The method must be known.
- (unless (or nodefault (tramp-completion-mode-p)
+ (unless (or nodefault non-essential
(string-equal method tramp-default-method-marker)
(assoc method tramp-methods))
(tramp-user-error
v "Method `%s' is not known." method))
;; Only some methods from tramp-sh.el do support multi-hops.
- (when (and
- hop
- (or (not (tramp-get-method-parameter v 'tramp-login-program))
- (tramp-get-method-parameter v 'tramp-copy-program)))
+ (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v))
(tramp-user-error
v "Method `%s' is not supported for multi-hops." method)))))))
+(put #'tramp-dissect-file-name 'tramp-suppress-trace t)
+
(defun tramp-dissect-hop-name (name &optional nodefault)
"Return a `tramp-file-name' structure of `hop' part of NAME.
See `tramp-dissect-file-name' for details."
@@ -1505,14 +1655,15 @@ See `tramp-dissect-file-name' for details."
tramp-postfix-host-format name))
nodefault)))
;; Only some methods from tramp-sh.el do support multi-hops.
- (when (or (not (tramp-get-method-parameter v 'tramp-login-program))
- (tramp-get-method-parameter v 'tramp-copy-program))
+ (unless (or nodefault non-essential (tramp-multi-hop-p v))
(tramp-user-error
v "Method `%s' is not supported for multi-hops."
(tramp-file-name-method v)))
;; Return result.
v))
+(put #'tramp-dissect-hop-name 'tramp-suppress-trace t)
+
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
(let ((method (tramp-file-name-method vec))
@@ -1522,6 +1673,8 @@ See `tramp-dissect-file-name' for details."
(format "*tramp/%s %s@%s*" method user-domain host-port)
(format "*tramp/%s %s*" method host-port))))
+(put #'tramp-buffer-name 'tramp-suppress-trace t)
+
(defun tramp-make-tramp-file-name (&rest args)
"Construct a Tramp file name from ARGS.
@@ -1639,6 +1792,15 @@ from the default one."
(or (tramp-get-connection-property vec "process-name" nil)
(tramp-buffer-name vec)))
+(defun tramp-get-process (vec-or-proc)
+ "Get the default connection process to be used for VEC-OR-PROC.
+Return `tramp-cache-undefined' in case it doesn't exist."
+ (or (and (tramp-file-name-p vec-or-proc)
+ (get-buffer-process (tramp-buffer-name vec-or-proc)))
+ (and (processp vec-or-proc)
+ (tramp-get-process (process-get vec-or-proc 'vector)))
+ tramp-cache-undefined))
+
(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
@@ -1680,15 +1842,20 @@ version, the function does nothing."
(format "*debug tramp/%s %s@%s*" method user-domain host-port)
(format "*debug tramp/%s %s*" method host-port))))
+(put #'tramp-debug-buffer-name 'tramp-suppress-trace t)
+
(defconst tramp-debug-outline-regexp
- (eval-when-compile
- (concat
- "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ " ;; Timestamp.
- "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread.
- "[a-z0-9-]+ (\\([0-9]+\\)) #")) ;; Function name, verbosity.
+ (concat
+ "[[:digit:]]+:[[:digit:]]+:[[:digit:]]+\\.[[:digit:]]+ " ;; Timestamp.
+ "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread.
+ "[[:alnum:]-]+ (\\([[:digit:]]+\\)) #") ;; Function name, verbosity.
"Used for highlighting Tramp debug buffers in `outline-mode'.")
(defconst tramp-debug-font-lock-keywords
+ ;; FIXME: Make it a function instead of an ELisp expression, so you
+ ;; can evaluate it with `funcall' rather than `eval'!
+ ;; Also, in `font-lock-defaults' you can specify a function name for
+ ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords!
'(list
(concat "^\\(?:" tramp-debug-outline-regexp "\\).+")
'(1 font-lock-warning-face t t)
@@ -1702,11 +1869,13 @@ 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 2))))
+(put #'tramp-debug-outline-level 'tramp-suppress-trace t)
+
(defun tramp-get-debug-buffer (vec)
"Get the debug buffer for VEC."
- (with-current-buffer
- (get-buffer-create (tramp-debug-buffer-name vec))
+ (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec))
(when (bobp)
+ (set-buffer-file-coding-system 'utf-8)
(setq buffer-undo-list t)
;; Activate `outline-mode'. This runs `text-mode-hook' and
;; `outline-mode-hook'. We must prevent that local processes
@@ -1714,92 +1883,115 @@ The outline level is equal to the verbosity of the Tramp message."
;; `(custom-declare-variable outline-minor-mode-prefix ...)'
;; raises on error in `(outline-mode)', we don't want to see it
;; in the traces.
- (let ((default-directory (tramp-compat-temporary-file-directory))
- signal-hook-function)
+ (let ((default-directory (tramp-compat-temporary-file-directory)))
(outline-mode))
- (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)
- (set (make-local-variable 'font-lock-keywords)
- `(t (eval ,tramp-debug-font-lock-keywords)
- ,(eval tramp-debug-font-lock-keywords)))
+ (setq-local outline-level 'tramp-debug-outline-level)
+ (setq-local font-lock-keywords
+ ;; FIXME: This `(t FOO . BAR)' representation in
+ ;; `font-lock-keywords' is supposed to be an
+ ;; internal implementation "detail". Don't abuse it here!
+ `(t (eval ,tramp-debug-font-lock-keywords t)
+ ,(eval tramp-debug-font-lock-keywords t)))
;; Do not edit the debug buffer.
(use-local-map special-mode-map))
(current-buffer)))
-(defsubst tramp-debug-message (vec fmt-string &rest arguments)
+(put #'tramp-get-debug-buffer 'tramp-suppress-trace t)
+
+(defun tramp-get-debug-file-name (vec)
+ "Get the debug file name for VEC."
+ (expand-file-name
+ (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec))
+ (tramp-compat-temporary-file-directory)))
+
+(put #'tramp-get-debug-file-name 'tramp-suppress-trace t)
+
+(defun tramp-trace-buffer-name (vec)
+ "A name for the trace buffer for VEC."
+ (tramp-compat-string-replace "debug" "trace" (tramp-debug-buffer-name vec)))
+
+(put #'tramp-trace-buffer-name 'tramp-suppress-trace t)
+
+(defvar tramp-trace-functions nil
+ "A list of non-Tramp functions to be traced with tramp-verbose > 10.")
+
+(defun tramp-debug-message (vec fmt-string &rest arguments)
"Append message to debug buffer of VEC.
Message is formatted with FMT-STRING as control string and the remaining
ARGUMENTS to actually emit the message (if applicable)."
- (with-current-buffer (tramp-get-debug-buffer vec)
- (goto-char (point-max))
- ;; Headline.
- (when (bobp)
- (insert
- (format
- ";; Emacs: %s Tramp: %s -*- mode: outline; -*-"
- emacs-version tramp-version))
- (when (>= tramp-verbose 10)
- (let ((tramp-verbose 0))
+ (let ((inhibit-message t)
+ create-lockfiles file-name-handler-alist message-log-max
+ signal-hook-function)
+ (with-current-buffer (tramp-get-debug-buffer vec)
+ (goto-char (point-max))
+ (let ((point (point)))
+ (when (bobp)
+ ;; Headline.
(insert
(format
- "\n;; Location: %s Git: %s/%s"
- (locate-library "tramp")
- (or tramp-repository-branch "")
- (or tramp-repository-version ""))))))
- (unless (bolp)
- (insert "\n"))
- ;; Timestamp.
- (let ((now (current-time)))
- (insert (format-time-string "%T." now))
- (insert (format "%06d " (nth 2 now))))
- ;; 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)))
- (if (not btf)
- (setq fn "")
- (when (symbolp btf)
- (setq fn (symbol-name btf))
- (unless
- (and
- (string-match-p "^tramp" fn)
- (not
- (string-match-p
- (eval-when-compile
- (concat
- "^"
- (regexp-opt
- '("tramp-backtrace"
- "tramp-compat-funcall"
- "tramp-debug-message"
- "tramp-error"
- "tramp-error-with-buffer"
- "tramp-message"
- "tramp-signal-hook-function"
- "tramp-user-error")
- t)
- "$"))
- fn)))
- (setq fn nil)))
- (setq btn (1+ btn))))
- ;; The following code inserts filename and line number. Should
- ;; be inactive by default, because it is time consuming.
-; (let ((ffn (find-function-noselect (intern fn))))
-; (insert
-; (format
-; "%s:%d: "
-; (file-name-nondirectory (buffer-file-name (car ffn)))
-; (with-current-buffer (car ffn)
-; (1+ (count-lines (point-min) (cdr ffn)))))))
- (insert (format "%s " fn)))
- ;; The message.
- (insert (apply #'format-message fmt-string arguments))))
-
-(defvar tramp-message-show-message (null noninteractive)
- "Show Tramp message in the minibuffer.
-This variable is used to suppress progress reporter output, and
-to disable messages from `tramp-error'. Those messages are
-visible anyway, because an error is raised.")
+ ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-"
+ emacs-version tramp-version))
+ (when (>= tramp-verbose 10)
+ (let ((tramp-verbose 0))
+ (insert
+ (format
+ "\n;; Location: %s Git: %s/%s"
+ (locate-library "tramp")
+ (or tramp-repository-branch "")
+ (or tramp-repository-version "")))))
+ ;; Traces.
+ (when (>= tramp-verbose 11)
+ (dolist
+ (elt
+ (append
+ (mapcar #'intern (all-completions "tramp-" obarray 'functionp))
+ tramp-trace-functions))
+ (unless (get elt 'tramp-suppress-trace)
+ (trace-function-background elt))))
+ ;; Delete debug file.
+ (when (and tramp-debug-to-file (tramp-get-debug-file-name vec))
+ (ignore-errors (delete-file (tramp-get-debug-file-name vec)))))
+ (unless (bolp)
+ (insert "\n"))
+ ;; Timestamp.
+ (let ((now (current-time)))
+ (insert (format-time-string "%T." now))
+ (insert (format "%06d " (nth 2 now))))
+ ;; 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)))
+ (if (not btf)
+ (setq fn "")
+ (and (symbolp btf) (setq fn (symbol-name btf))
+ (or (not (string-match-p "^tramp" fn))
+ (get btf 'tramp-suppress-trace))
+ (setq fn nil))
+ (setq btn (1+ btn))))
+ ;; The following code inserts filename and line number.
+ ;; Should be inactive by default, because it is time consuming.
+ ;; (let ((ffn (find-function-noselect (intern fn))))
+ ;; (insert
+ ;; (format
+ ;; "%s:%d: "
+ ;; (file-name-nondirectory (buffer-file-name (car ffn)))
+ ;; (with-current-buffer (car ffn)
+ ;; (1+ (count-lines (point-min) (cdr ffn)))))))
+ (insert (format "%s " fn)))
+ ;; The message.
+ (insert (apply #'format-message fmt-string arguments))
+ ;; Write message to debug file.
+ (when tramp-debug-to-file
+ (ignore-errors
+ (write-region
+ point (point-max) (tramp-get-debug-file-name vec) 'append)))))))
+
+(put #'tramp-debug-message 'tramp-suppress-trace t)
+
+(defvar tramp-inhibit-progress-reporter nil
+ "Show Tramp progress reporter in the minibuffer.
+This variable is used to disable concurrent progress reporter messages.")
(defsubst tramp-message (vec-or-proc level fmt-string &rest arguments)
"Emit a message depending on verbosity level.
@@ -1816,8 +2008,9 @@ control string and the remaining ARGUMENTS to actually emit the message (if
applicable)."
(ignore-errors
(when (<= level tramp-verbose)
- ;; Display only when there is a minimum level.
- (when (and tramp-message-show-message (<= level 3))
+ ;; Display only when there is a minimum level, and the progress
+ ;; reporter doesn't suppress further messages.
+ (when (and (<= level 3) (null tramp-inhibit-progress-reporter))
(apply #'message
(concat
(cond
@@ -1849,6 +2042,8 @@ applicable)."
(concat (format "(%d) # " level) fmt-string)
arguments))))))
+(put #'tramp-message 'tramp-suppress-trace t)
+
(defsubst tramp-backtrace (&optional vec-or-proc)
"Dump a backtrace into the debug buffer.
If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This
@@ -1859,13 +2054,16 @@ function is meant for debugging purposes."
vec-or-proc 10 "\n%s" (with-output-to-string (backtrace)))
(with-output-to-temp-buffer "*debug tramp*" (backtrace)))))
-(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments)
+(put #'tramp-backtrace 'tramp-suppress-trace t)
+
+(defun tramp-error (vec-or-proc signal fmt-string &rest arguments)
"Emit an error.
VEC-OR-PROC identifies the connection to use, SIGNAL is the
signal identifier to be raised, remaining arguments passed to
`tramp-message'. Finally, signal SIGNAL is raised with
FMT-STRING and ARGUMENTS."
- (let (tramp-message-show-message signal-hook-function)
+ (let ((inhibit-message t)
+ signal-hook-function)
(tramp-backtrace vec-or-proc)
(unless arguments
;; FMT-STRING could be just a file name, as in
@@ -1883,6 +2081,8 @@ FMT-STRING and ARGUMENTS."
(signal signal (list (substring-no-properties
(apply #'format-message fmt-string arguments))))))
+(put #'tramp-error 'tramp-suppress-trace t)
+
(defsubst tramp-error-with-buffer
(buf vec-or-proc signal fmt-string &rest arguments)
"Emit an error, and show BUF.
@@ -1900,13 +2100,13 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(apply #'tramp-error vec-or-proc signal fmt-string arguments)
;; Save exit.
(when (and buf
- tramp-message-show-message
(not (zerop tramp-verbose))
;; Do not show when flagged from outside.
- (not (tramp-completion-mode-p))
+ (not non-essential)
;; Show only when Emacs has started already.
(current-message))
- (let ((enable-recursive-minibuffers t))
+ (let ((enable-recursive-minibuffers t)
+ inhibit-message)
;; `tramp-error' does not show messages. So we must do it
;; ourselves.
(apply #'message fmt-string arguments)
@@ -1918,19 +2118,21 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(when (tramp-file-name-equal-p vec (car tramp-current-connection))
(setcdr tramp-current-connection (current-time)))))))
+(put #'tramp-error-with-buffer 'tramp-suppress-trace t)
+
;; We must make it a defun, because it is used earlier already.
(defun tramp-user-error (vec-or-proc fmt-string &rest arguments)
"Signal a user error (or \"pilot error\")."
(unwind-protect
(apply #'tramp-error vec-or-proc 'user-error fmt-string arguments)
;; Save exit.
- (when (and tramp-message-show-message
- (not (zerop tramp-verbose))
+ (when (and (not (zerop tramp-verbose))
;; Do not show when flagged from outside.
- (not (tramp-completion-mode-p))
+ (not non-essential)
;; Show only when Emacs has started already.
(current-message))
- (let ((enable-recursive-minibuffers t))
+ (let ((enable-recursive-minibuffers t)
+ inhibit-message)
;; `tramp-error' does not show messages. So we must do it ourselves.
(apply #'message fmt-string arguments)
(discard-input)
@@ -1940,18 +2142,30 @@ an input event arrives. The other arguments are passed to `tramp-error'."
(tramp-file-name-equal-p vec-or-proc (car tramp-current-connection))
(setcdr tramp-current-connection (current-time)))))))
+(put #'tramp-user-error 'tramp-suppress-trace t)
+
(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body)
"Execute BODY while redirecting the error message to `tramp-message'.
BODY is executed like wrapped by `with-demoted-errors'. FORMAT
is a format-string containing a %-sequence meaning to substitute
the resulting error message."
- (declare (debug (symbolp body))
- (indent 2))
+ (declare (indent 2) (debug (symbolp form body)))
(let ((err (make-symbol "err")))
`(condition-case-unless-debug ,err
(progn ,@body)
(error (tramp-message ,vec-or-proc 3 ,format ,err) nil))))
+(put #'tramp-with-demoted-errors 'tramp-suppress-trace t)
+
+(defun tramp-test-message (fmt-string &rest arguments)
+ "Emit a Tramp message according `default-directory'."
+ (if (tramp-tramp-file-p default-directory)
+ (apply #'tramp-message
+ (tramp-dissect-file-name default-directory) 0 fmt-string arguments)
+ (apply #'message fmt-string arguments)))
+
+(put #'tramp-test-message 'tramp-suppress-trace t)
+
;; This function provides traces in case of errors not triggered by
;; Tramp functions.
(defun tramp-signal-hook-function (error-symbol data)
@@ -1961,7 +2175,9 @@ the resulting error message."
(unless (eq error-symbol 'void-variable)
(tramp-error
(car tramp-current-connection) error-symbol
- "%s" (mapconcat (lambda (x) (format "%s" x)) data " "))))
+ (mapconcat (lambda (x) (format "%s" x)) data " "))))
+
+(put #'tramp-signal-hook-function 'tramp-suppress-trace t)
(defmacro with-parsed-tramp-file-name (filename var &rest body)
"Parse a Tramp filename and make components available in the body.
@@ -1979,12 +2195,14 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit
If VAR is nil, then we bind `v' to the structure and `method', `user',
`domain', `host', `port', `localname', `hop' to the components."
+ (declare (indent 2) (debug (form symbolp body)))
(let ((bindings
- (mapcar (lambda (elem)
- `(,(if var (intern (format "%s-%s" var elem)) elem)
- (,(intern (format "tramp-file-name-%s" elem))
- ,(or var 'v))))
- `,(tramp-compat-tramp-file-name-slots))))
+ (mapcar
+ (lambda (elem)
+ `(,(if var (intern (format "%s-%s" var elem)) elem)
+ (,(intern (format "tramp-file-name-%s" elem))
+ ,(or var 'v))))
+ (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))))))
`(let* ((,(or var 'v) (tramp-dissect-file-name ,filename))
,@bindings)
;; We don't know which of those vars will be used, so we bind them all,
@@ -1993,8 +2211,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user',
(ignore ,@(mapcar #'car bindings))
,@body)))
-(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\\>"))
(defun tramp-progress-reporter-update (reporter &optional value suffix)
@@ -2005,25 +2221,30 @@ If VAR is nil, then we bind `v' to the structure and `method', `user',
(tramp-compat-progress-reporter-update reporter value suffix))))
(defmacro with-tramp-progress-reporter (vec level message &rest body)
- "Execute BODY, spinning a progress reporter with MESSAGE.
+ "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode.
If LEVEL does not fit for visible messages, there are only traces
without a visible progress reporter."
(declare (indent 3) (debug t))
- `(progn
+ `(if (or noninteractive inhibit-message)
+ (progn ,@body)
(tramp-message ,vec ,level "%s..." ,message)
(let ((cookie "failed")
(tm
;; We start a pulsing progress reporter after 3 seconds.
- (when (and tramp-message-show-message
- ;; Display only when there is a minimum level.
- (<= ,level (min tramp-verbose 3)))
- (let ((pr (make-progress-reporter ,message nil nil)))
- (when pr
- (run-at-time
- 3 0.1 #'tramp-progress-reporter-update pr))))))
+ ;; Start only when there is no other progress reporter
+ ;; running, and when there is a minimum level.
+ (when-let ((pr (and (null tramp-inhibit-progress-reporter)
+ (<= ,level (min tramp-verbose 3))
+ (make-progress-reporter ,message nil nil))))
+ (run-at-time 3 0.1 #'tramp-progress-reporter-update pr))))
(unwind-protect
;; Execute the body.
- (prog1 (progn ,@body) (setq cookie "done"))
+ (prog1
+ ;; Suppress concurrent progress reporter messages.
+ (let ((tramp-inhibit-progress-reporter
+ (or tramp-inhibit-progress-reporter tm)))
+ ,@body)
+ (setq cookie "done"))
;; Stop progress reporter.
(if tm (cancel-timer tm))
(tramp-message ,vec ,level "%s...%s" ,message cookie)))))
@@ -2034,34 +2255,34 @@ without a visible progress reporter."
(defmacro with-tramp-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."
+ (declare (indent 3) (debug t))
`(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)
+ (let ((value (tramp-get-file-property
+ ,vec ,file ,property tramp-cache-undefined)))
+ (when (eq value tramp-cache-undefined)
+ ;; 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-tramp-file-property 'lisp-indent-function 3)
-(put 'with-tramp-file-property 'edebug-form-spec t)
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>"))
(defmacro with-tramp-connection-property (key property &rest body)
"Check in Tramp for property PROPERTY, otherwise execute 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-tramp-connection-property 'lisp-indent-function 2)
-(put 'with-tramp-connection-property 'edebug-form-spec t)
+ (declare (indent 2) (debug t))
+ `(let ((value (tramp-get-connection-property
+ ,key ,property tramp-cache-undefined)))
+ (when (eq value tramp-cache-undefined)
+ ;; 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))
+
(font-lock-add-keywords
'emacs-lisp-mode '("\\<with-tramp-connection-property\\>"))
@@ -2074,12 +2295,15 @@ letter into the file name. This function removes it."
(save-match-data
(let ((quoted (tramp-compat-file-name-quoted-p name 'top))
(result (tramp-compat-file-name-unquote name 'top)))
- (setq result (if (string-match "\\`[a-zA-Z]:/" result)
+ (setq result (if (string-match "\\`[[:alpha:]]:/" result)
(replace-match "/" nil t result) result))
(if quoted (tramp-compat-file-name-quote result 'top) result))))
;;; Config Manipulation Functions:
+(defconst tramp-dns-sd-service-regexp "^_[-[:alnum:]]+\\._tcp$"
+ "DNS-SD service regexp.")
+
(defun tramp-set-completion-function (method function-list)
"Set the list of completion functions for METHOD.
FUNCTION-LIST is a list of entries of the form (FUNCTION FILE).
@@ -2112,10 +2336,10 @@ Example:
(zerop
(tramp-call-process
v "reg" nil nil nil "query" (nth 1 (car v))))))
- ;; Zeroconf service type.
+ ;; DNS-SD service type.
((string-match-p
- "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v))))
- ;; Configuration file.
+ tramp-dns-sd-service-regexp (nth 1 (car v))))
+ ;; Configuration file or empty string.
(t (file-exists-p (nth 1 (car v))))))
(setq r (delete (car v) r)))
(setq v (cdr v)))
@@ -2153,11 +2377,13 @@ For definition of that list see `tramp-set-completion-function'."
(defvar tramp-devices 0
"Keeps virtual device numbers.")
-(defun tramp-default-file-modes (filename)
+(defun tramp-default-file-modes (filename &optional flag)
"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)
+If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a
+symbolic link. If the file modes of FILENAME cannot be
+determined, return the value of `default-file-modes', without
+execute permissions."
+ (or (tramp-compat-file-modes filename flag)
(logand (default-file-modes) #o0666)))
(defun tramp-replace-environment-variables (filename)
@@ -2188,6 +2414,7 @@ arguments to pass to the OPERATION."
tramp-vc-file-name-handler
tramp-completion-file-name-handler
tramp-archive-file-name-handler
+ tramp-crypt-file-name-handler
cygwin-mount-name-hook-function
cygwin-mount-map-drive-hook-function
.
@@ -2236,6 +2463,8 @@ Must be handled by the callers."
file-name-case-insensitive-p
;; Emacs 27+ only.
file-system-info
+ ;; Emacs 28+ only.
+ file-locked-p lock-file make-lock-file-name unlock-file
;; Tramp internal magic file name function.
tramp-set-file-uid-gid))
(if (file-name-absolute-p (nth 0 args))
@@ -2253,7 +2482,7 @@ Must be handled by the callers."
file-newer-than-file-p rename-file))
(cond
((tramp-tramp-file-p (nth 0 args)) (nth 0 args))
- ((tramp-tramp-file-p (nth 1 args)) (nth 1 args))
+ ((file-name-absolute-p (nth 1 args)) (nth 1 args))
(t default-directory)))
;; FILE DIRECTORY resp FILE1 FILE2.
((eq operation 'expand-file-name)
@@ -2281,13 +2510,13 @@ Must be handled by the callers."
exec-path make-process))
default-directory)
;; PROC.
- ((member operation
- '(file-notify-rm-watch
- ;; Emacs 25+ only.
- file-notify-valid-p))
+ ((member operation '(file-notify-rm-watch file-notify-valid-p))
(when (processp (nth 0 args))
(with-current-buffer (process-buffer (nth 0 args))
default-directory)))
+ ;; VEC.
+ ((member operation '(tramp-get-remote-gid tramp-get-remote-uid))
+ (tramp-make-tramp-file-name (nth 0 args)))
;; Unknown file primitive.
(t (error "Unknown file I/O primitive: %s" operation))))
@@ -2304,33 +2533,6 @@ Must be handled by the callers."
res (cdr elt))))
res)))
-;; In Emacs, there is some concurrency due to timers. If a timer
-;; interrupts Tramp and wishes to use the same connection buffer as
-;; the "main" Emacs, then garbage might occur in the connection
-;; buffer. Therefore, we need to make sure that a timer does not use
-;; the same connection buffer as the "main" Emacs. We implement a
-;; cheap global lock, instead of locking each connection buffer
-;; separately. The global lock is based on two variables,
-;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true
-;; (with setq) to indicate a lock. But Tramp also calls itself during
-;; processing of a single file operation, so we need to allow
-;; recursive calls. That's where the `tramp-locker' variable comes in
-;; -- it is let-bound to t during the execution of the current
-;; handler. So if `tramp-locked' is t and `tramp-locker' is also t,
-;; then we should just proceed because we have been called
-;; recursively. But if `tramp-locker' is nil, then we are a timer
-;; interrupting the "main" Emacs, and then we signal an error.
-
-(defvar tramp-locked nil
- "If non-nil, then Tramp is currently busy.
-Together with `tramp-locker', this implements a locking mechanism
-preventing reentrant calls of Tramp.")
-
-(defvar tramp-locker nil
- "If non-nil, then a caller has locked Tramp.
-Together with `tramp-locked', this implements a locking mechanism
-preventing reentrant calls of Tramp.")
-
;; Main function.
(defun tramp-file-name-handler (operation &rest args)
"Invoke Tramp file name handler for OPERATION and ARGS.
@@ -2384,17 +2586,7 @@ Fall back to normal file name handler if no Tramp file name handler exists."
(setq result
(catch 'non-essential
(catch 'suppress
- (when (and tramp-locked (not tramp-locker))
- (setq tramp-locked nil)
- (tramp-error
- v 'file-error
- "Forbidden reentrant call of Tramp"))
- (let ((tl tramp-locked))
- (setq tramp-locked t)
- (unwind-protect
- (let ((tramp-locker t))
- (apply foreign operation args))
- (setq tramp-locked tl))))))
+ (apply foreign operation args))))
;; (tramp-message
;; v 4 "Running `%s'...`%s'" (cons operation args) result)
(cond
@@ -2404,7 +2596,7 @@ Fall back to normal file name handler if no Tramp file name handler exists."
(cons operation args))
(tramp-run-real-handler operation args))
((eq result 'suppress)
- (let (tramp-message-show-message)
+ (let ((inhibit-message t))
(tramp-message
v 1 "Suppress received in operation %s"
(cons operation args))
@@ -2433,18 +2625,25 @@ Fall back to normal file name handler if no Tramp file name handler exists."
(defun tramp-completion-file-name-handler (operation &rest args)
"Invoke Tramp file name completion handler for OPERATION and ARGS.
Falls back to normal file name handler if no Tramp file name handler exists."
- (let ((fn (assoc operation tramp-completion-file-name-handler-alist)))
- (if (and fn tramp-mode)
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
+ (if-let
+ ((fn (and tramp-mode
+ (assoc operation tramp-completion-file-name-handler-alist))))
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args)))
;;;###autoload
(progn (defun tramp-autoload-file-name-handler (operation &rest args)
"Load Tramp file name handler, and perform OPERATION."
(tramp-unload-file-name-handlers)
- (if tramp-mode
- (let ((default-directory temporary-file-directory))
- (load "tramp" 'noerror 'nomessage)))
+ (when tramp-mode
+ ;; We cannot use `tramp-compat-temporary-file-directory' here due
+ ;; to autoload. When installing Tramp's GNU ELPA package, there
+ ;; might be an older, incompatible version active. We try to
+ ;; overload this.
+ (let ((default-directory temporary-file-directory))
+ (when (bound-and-true-p tramp-archive-autoload)
+ (load "tramp-archive" 'noerror 'nomessage))
+ (load "tramp" 'noerror 'nomessage)))
(apply operation args)))
;; `tramp-autoload-file-name-handler' must be registered before
@@ -2455,8 +2654,8 @@ Falls back to normal file name handler if no Tramp file name handler exists."
"Add Tramp file name handlers to `file-name-handler-alist' during autoload."
(add-to-list 'file-name-handler-alist
(cons tramp-autoload-file-name-regexp
- 'tramp-autoload-file-name-handler))
- (put 'tramp-autoload-file-name-handler 'safe-magic t)))
+ #'tramp-autoload-file-name-handler))
+ (put #'tramp-autoload-file-name-handler 'safe-magic t)))
;;;###autoload (tramp-register-autoload-file-name-handlers)
@@ -2492,34 +2691,36 @@ remote file names."
(tramp-unload-file-name-handlers)
;; Add the handlers. We do not add anything to the `operations'
- ;; property of `tramp-file-name-handler' and
- ;; `tramp-archive-file-name-handler', this shall be done by the
+ ;; property of `tramp-file-name-handler',
+ ;; `tramp-archive-file-name-handler' and
+ ;; `tramp-crypt-file-name-handler', this shall be done by the
;; respective foreign handlers.
(add-to-list 'file-name-handler-alist
(cons tramp-file-name-regexp #'tramp-file-name-handler))
- (put 'tramp-file-name-handler 'safe-magic t)
+ (put #'tramp-file-name-handler 'safe-magic t)
+
+ (tramp-register-crypt-file-name-handler)
(add-to-list 'file-name-handler-alist
(cons tramp-completion-file-name-regexp
#'tramp-completion-file-name-handler))
- (put 'tramp-completion-file-name-handler 'safe-magic t)
+ (put #'tramp-completion-file-name-handler 'safe-magic t)
;; Mark `operations' the handler is responsible for.
- (put 'tramp-completion-file-name-handler 'operations
+ (put #'tramp-completion-file-name-handler 'operations
(mapcar #'car tramp-completion-file-name-handler-alist))
(when (bound-and-true-p tramp-archive-enabled)
(add-to-list 'file-name-handler-alist
(cons tramp-archive-file-name-regexp
#'tramp-archive-file-name-handler))
- (put 'tramp-archive-file-name-handler 'safe-magic t))
+ (put #'tramp-archive-file-name-handler 'safe-magic t))
;; If jka-compr or epa-file are already loaded, move them to the
;; front of `file-name-handler-alist'.
(dolist (fnh '(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)))))))
+ (when-let ((entry (rassoc fnh file-name-handler-alist)))
+ (setq file-name-handler-alist
+ (cons entry (delete entry file-name-handler-alist))))))
(tramp--with-startup (tramp-register-file-name-handlers))
@@ -2531,7 +2732,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
(add-to-list
'tramp-foreign-file-name-handler-alist `(,func . ,handler) append)
;; Mark `operations' the handler is responsible for.
- (put 'tramp-file-name-handler
+ (put #'tramp-file-name-handler
'operations
(delete-dups
(append
@@ -2572,24 +2773,19 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
;;; File name handler functions for completion mode:
-;;;###autoload
-(defvar tramp-completion-mode nil
- "If non-nil, external packages signal that they are in file name completion.")
-(make-obsolete-variable 'tramp-completion-mode 'non-essential "26.1")
-
-(defun tramp-completion-mode-p ()
- "Check, whether method / user name / host name completion is active."
- (or
- ;; Signal from outside.
- non-essential
- ;; This variable has been obsoleted in Emacs 26.
- tramp-completion-mode))
+;; This function takes action since Emacs 28.1, when
+;; `read-extended-command-predicate' is set to
+;; `command-completion-default-include-p'.
+(defun tramp-command-completion-p (_symbol buffer)
+ "A predicate for Tramp interactive commands.
+They are completed by \"M-x TAB\" only if the current buffer is remote."
+ (with-current-buffer buffer (tramp-tramp-file-p default-directory)))
(defun tramp-connectable-p (vec-or-filename)
"Check, whether it is possible to connect the remote host w/o side-effects.
This is true, if either the remote host is already connected, or if we are
not in completion mode."
- (let (tramp-verbose
+ (let ((tramp-verbose 0)
(vec
(cond
((tramp-file-name-p vec-or-filename) vec-or-filename)
@@ -2599,7 +2795,7 @@ not in completion mode."
;; `tramp-buffer-name'; otherwise `start-file-process'
;; wouldn't run ever when `non-essential' is non-nil.
(and vec (process-live-p (get-process (tramp-buffer-name vec))))
- (not (tramp-completion-mode-p)))))
+ (not non-essential))))
;; Method, host name and user name completion.
;; `tramp-completion-dissect-file-name' returns a list of
@@ -2670,7 +2866,7 @@ not in completion mode."
result1
(ignore-errors
(tramp-run-real-handler
- 'file-name-all-completions (list filename directory))))))
+ #'file-name-all-completions (list filename directory))))))
;; Method, host name and user name completion for a file.
(defun tramp-completion-handle-file-name-completion
@@ -2890,7 +3086,7 @@ Either user or host may be nil."
(defun tramp-parse-rhosts-group ()
"Return a (user host) tuple allowed to access.
Either user or host may be nil."
- (let ((result)
+ (let (result
(regexp
(concat
"^\\(" tramp-host-regexp "\\)"
@@ -2940,7 +3136,7 @@ User is always nil."
"Return a list of (user host) tuples allowed to access.
User is always nil."
(tramp-parse-shostkeys-sknownhosts
- dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$")))
+ dirname (concat "^key_[[:digit:]]+_\\(" tramp-host-regexp "\\)\\.pub$")))
(defun tramp-parse-sknownhosts (dirname)
"Return a list of (user host) tuples allowed to access.
@@ -2975,7 +3171,7 @@ Host is always \"localhost\"."
(defun tramp-parse-passwd-group ()
"Return a (user host) tuple allowed to access.
Host is always \"localhost\"."
- (let ((result)
+ (let (result
(regexp (concat "^\\(" tramp-user-regexp "\\):")))
(when (re-search-forward regexp (point-at-eol) t)
(setq result (list (match-string 1) "localhost")))
@@ -2997,7 +3193,7 @@ Host is always \"localhost\"."
(defun tramp-parse-etc-group-group ()
"Return a (group host) tuple allowed to access.
Host is always \"localhost\"."
- (let ((result)
+ (let (result
(split (split-string (buffer-substring (point) (point-at-eol)) ":")))
(when (member (user-login-name) (split-string (nth 3 split) "," 'omit))
(setq result (list (nth 0 split) "localhost")))
@@ -3019,7 +3215,7 @@ User may be nil."
(defun tramp-parse-putty (registry-or-dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
- (if (memq system-type '(windows-nt))
+ (if (eq system-type 'windows-nt)
(with-tramp-connection-property nil "parse-putty"
(with-temp-buffer
(when (zerop (tramp-call-process
@@ -3034,7 +3230,7 @@ User is always nil."
(defun tramp-parse-putty-group (registry)
"Return a (user host) tuple allowed to access.
User is always nil."
- (let ((result)
+ (let (result
(regexp (concat (regexp-quote registry) "\\\\\\(.+\\)")))
(when (re-search-forward regexp (point-at-eol) t)
(setq result (list nil (match-string 1))))
@@ -3052,9 +3248,9 @@ User is always nil."
(defun tramp-handle-access-file (filename string)
"Like `access-file' for Tramp files."
(unless (file-readable-p (file-truename filename))
- (tramp-error
- (tramp-dissect-file-name filename) tramp-file-missing
- "%s: No such file or directory %s" string filename)))
+ (tramp-compat-file-missing
+ (tramp-dissect-file-name filename)
+ (format "%s: %s" string filename))))
(defun tramp-handle-add-name-to-file
(filename newname &optional ok-if-already-exists)
@@ -3088,12 +3284,10 @@ User is always nil."
;; `copy-directory' creates NEWNAME before running this check. So
;; we do it ourselves.
(unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
;; We must do it file-wise.
(tramp-run-real-handler
- 'copy-directory
+ #'copy-directory
(list directory newname keep-date parents copy-contents)))
(defun tramp-handle-directory-file-name (directory)
@@ -3108,13 +3302,10 @@ User is always nil."
(setq directory (substring directory 0 -1)))
directory)
-(defun tramp-handle-directory-files
- (directory &optional full match nosort _count)
+(defun tramp-handle-directory-files (directory &optional full match nosort count)
"Like `directory-files' for Tramp files."
(unless (file-exists-p directory)
- (tramp-error
- (tramp-dissect-file-name directory) tramp-file-missing
- "No such file or directory" directory))
+ (tramp-compat-file-missing (tramp-dissect-file-name directory) directory))
(when (file-directory-p directory)
(setq directory (file-name-as-directory (expand-file-name directory)))
(let ((temp (nreverse (file-name-all-completions "" directory)))
@@ -3125,16 +3316,20 @@ User is always nil."
(when (or (null match) (string-match-p match item))
(push (if full (concat directory item) item)
result)))
- (if nosort result (sort result #'string<)))))
+ (unless nosort
+ (setq result (sort result #'string<)))
+ (when (and (natnump count) (> count 0))
+ (setq result (nbutlast result (- (length result) count))))
+ result)))
(defun tramp-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format _count)
+ (directory &optional full match nosort id-format count)
"Like `directory-files-and-attributes' for Tramp files."
(mapcar
(lambda (x)
(cons x (file-attributes
(if full x (expand-file-name x directory)) id-format)))
- (directory-files directory full match nosort)))
+ (tramp-compat-directory-files directory full match nosort count)))
(defun tramp-handle-dired-uncache (dir)
"Like `dired-uncache' for Tramp files."
@@ -3150,7 +3345,7 @@ User is always nil."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -3158,6 +3353,9 @@ User is always nil."
(with-parsed-tramp-file-name name nil
(unless (tramp-run-real-handler #'file-name-absolute-p (list localname))
(setq localname (concat "/" localname)))
+ ;; Do not keep "/..".
+ (when (string-match-p "^/\\.\\.?$" localname)
+ (setq localname "/"))
;; Do normal `expand-file-name' (this does "/./" and "/../").
;; `default-directory' is bound, because on Windows there would
;; be problems with UNC shares or Cygwin mounts.
@@ -3207,19 +3405,18 @@ User is always nil."
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
(unless (file-exists-p filename)
- (tramp-error
- v tramp-file-missing
- "Cannot make local copy of non-existing file `%s'" filename))
+ (tramp-compat-file-missing v filename))
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(copy-file filename tmpfile 'ok-if-already-exists 'keep-time)
tmpfile)))
-(defun tramp-handle-file-modes (filename &optional _flag)
+(defun tramp-handle-file-modes (filename &optional flag)
"Like `file-modes' for Tramp files."
- ;; Starting with Emacs 25.1, `when-let' can be used.
- (let ((attrs (file-attributes (or (file-truename filename) filename))))
- (when attrs
- (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs)))))
+ (when-let ((attrs (file-attributes filename))
+ (mode-string (tramp-compat-file-attribute-modes attrs)))
+ (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0)))
+ (file-modes (file-truename filename))
+ (tramp-mode-string-to-int mode-string))))
;; Localname manipulation functions that grok Tramp localnames...
(defun tramp-handle-file-name-as-directory (file)
@@ -3257,12 +3454,13 @@ User is always nil."
(let ((candidate
(tramp-compat-file-name-unquote
(directory-file-name filename)))
+ case-fold-search
tmpfile)
;; Check, whether we find an existing file with
;; lower case letters. This avoids us to create a
;; temporary file.
(while (and (string-match-p
- "[a-z]" (tramp-file-local-name candidate))
+ "[[:lower:]]" (tramp-file-local-name candidate))
(not (file-exists-p candidate)))
(setq candidate
(directory-file-name
@@ -3271,8 +3469,8 @@ User is always nil."
;; for comparison. `make-nearby-temp-file' is added
;; to Emacs 26+ like `file-name-case-insensitive-p',
;; so there is no compatibility problem calling it.
- (unless
- (string-match-p "[a-z]" (tramp-file-local-name candidate))
+ (unless (string-match-p
+ "[[:lower:]]" (tramp-file-local-name candidate))
(setq tmpfile
(let ((default-directory
(file-name-directory filename)))
@@ -3337,21 +3535,18 @@ User is always nil."
(cond
((not (file-exists-p file1)) nil)
((not (file-exists-p file2)) t)
- (t (time-less-p (tramp-compat-file-attribute-modification-time
- (file-attributes file2))
- (tramp-compat-file-attribute-modification-time
- (file-attributes file1))))))
+ (t (time-less-p
+ (tramp-compat-file-attribute-modification-time (file-attributes file2))
+ (tramp-compat-file-attribute-modification-time
+ (file-attributes file1))))))
(defun tramp-handle-file-regular-p (filename)
"Like `file-regular-p' for Tramp files."
(and (file-exists-p filename)
;; Sometimes, `file-attributes' does not return a proper value
;; even if `file-exists-p' does.
- (ignore-errors
- (eq ?-
- (aref
- (tramp-compat-file-attribute-modes (file-attributes filename))
- 0)))))
+ (when-let ((attr (file-attributes filename)))
+ (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0)))))
(defun tramp-handle-file-remote-p (filename &optional identification connected)
"Like `file-remote-p' for Tramp files."
@@ -3390,8 +3585,7 @@ User is always nil."
"Like `file-truename' for Tramp files."
;; Preserve trailing "/".
(funcall
- (if (tramp-compat-directory-name-p filename)
- #'file-name-as-directory #'identity)
+ (if (directory-name-p filename) #'file-name-as-directory #'identity)
;; Quote properly.
(funcall
(if (tramp-compat-file-name-quoted-p filename)
@@ -3403,6 +3597,8 @@ User is always nil."
;; something is wrong; otherwise they might think that Emacs
;; is hung. Of course, correctness has to come first.
(numchase-limit 20)
+ ;; Unquoting could enable encryption.
+ tramp-crypt-enabled
symlink-target)
(with-parsed-tramp-file-name result v1
;; We cache only the localname.
@@ -3419,8 +3615,10 @@ User is always nil."
(if (stringp symlink-target)
(if (file-remote-p symlink-target)
(tramp-compat-file-name-quote symlink-target 'top)
- (expand-file-name
- symlink-target (file-name-directory v2-localname)))
+ (tramp-drop-volume-letter
+ (expand-file-name
+ symlink-target
+ (file-name-directory v2-localname))))
v2-localname)
'nohop)))
(when (>= numchase numchase-limit)
@@ -3439,6 +3637,11 @@ User is always nil."
(and (file-directory-p (file-name-directory filename))
(file-writable-p (file-name-directory filename)))))))
+(defcustom tramp-allow-unsafe-temporary-files nil
+ "Whether root-owned auto-save, backup or lock files can be written to \"/tmp\"."
+ :version "28.1"
+ :type 'boolean)
+
(defun tramp-handle-find-backup-file-name (filename)
"Like `find-backup-file-name' for Tramp files."
(with-parsed-tramp-file-name filename nil
@@ -3454,15 +3657,33 @@ User is always nil."
(tramp-make-tramp-file-name v (cdr x))
(cdr x))))
tramp-backup-directory-alist)
- backup-directory-alist)))
- (tramp-run-real-handler #'find-backup-file-name (list filename)))))
+ backup-directory-alist))
+ result)
+ (prog1 ;; Run plain `find-backup-file-name'.
+ (setq result
+ (tramp-run-real-handler
+ #'find-backup-file-name (list filename)))
+ ;; Protect against security hole.
+ (when (and (not tramp-allow-unsafe-temporary-files)
+ (not backup-inhibited)
+ (file-in-directory-p (car result) temporary-file-directory)
+ (zerop (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ tramp-unknown-id-integer))
+ (not (with-tramp-connection-property
+ (tramp-get-process v) "unsafe-temporary-file"
+ (yes-or-no-p
+ (concat
+ "Backup file on local temporary directory, "
+ "do you want to continue? ")))))
+ (tramp-error v 'file-error "Unsafe backup file name"))))))
(defun tramp-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
(unless switches (setq switches ""))
;; Mark trailing "/".
- (when (and (tramp-compat-directory-name-p filename)
+ (when (and (directory-name-p filename)
(not full-directory-p))
(setq switches (concat switches "F")))
;; Check, whether directory is accessible.
@@ -3472,7 +3693,7 @@ User is always nil."
(with-tramp-progress-reporter v 0 (format "Opening directory %s" filename)
(let (ls-lisp-use-insert-directory-program start)
;; Silence byte compiler.
- ls-lisp-use-insert-directory-program
+ (ignore ls-lisp-use-insert-directory-program)
(tramp-run-real-handler
#'insert-directory
(list filename switches wildcard full-directory-p))
@@ -3502,9 +3723,7 @@ User is always nil."
(with-parsed-tramp-file-name filename nil
(unwind-protect
(if (not (file-exists-p filename))
- (tramp-error
- v tramp-file-missing
- "File `%s' not found on remote host" filename)
+ (tramp-compat-file-missing v filename)
(with-tramp-progress-reporter
v 3 (format-message "Inserting `%s'" filename)
@@ -3521,10 +3740,10 @@ User is always nil."
;; When we shall insert only a part of the file, we
;; copy this part. This works only for the shell file
- ;; name handlers.
+ ;; name handlers. It doesn't work for crypted files.
(when (and (or beg end)
- (tramp-get-method-parameter
- v 'tramp-login-program))
+ (tramp-sh-file-name-handler-p v)
+ (null tramp-crypt-enabled))
(setq remote-copy (tramp-make-tramp-temp-file v))
;; This is defined in tramp-sh.el. Let's assume
;; this is loaded already.
@@ -3594,21 +3813,114 @@ User is always nil."
(signal (car err) (cdr err))))))
;; 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 v remote-copy 'nohop)))))
+ (when visit
+ (setq buffer-file-name filename
+ 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 v remote-copy 'nohop))))
;; Result.
- (list (expand-file-name filename)
- (cadr result)))))
+ (cons (expand-file-name filename) (cdr result)))))
+
+(defun tramp-get-lock-file (file)
+ "Read lockfile info of FILE.
+Return nil when there is no lockfile."
+ (when-let ((lockname (tramp-compat-make-lock-file-name file)))
+ (or (file-symlink-p lockname)
+ (and (file-readable-p lockname)
+ (with-temp-buffer
+ (insert-file-contents-literally lockname)
+ (buffer-string))))))
+
+(defun tramp-get-lock-pid (file)
+ "Determine pid for lockfile of FILE."
+ ;; Some Tramp methods do not offer a connection process, but just a
+ ;; network process as a place holder. Those processes use the
+ ;; "lock-pid" connection property as fake pid, in fact it is the
+ ;; time stamp the process is created.
+ (let ((p (tramp-get-process (tramp-dissect-file-name file))))
+ (number-to-string
+ (or (process-id p)
+ (tramp-get-connection-property p "lock-pid" (emacs-pid))))))
+
+(defconst tramp-lock-file-info-regexp
+ ;; USER@HOST.PID[:BOOT_TIME]
+ "\\`\\(.+\\)@\\(.+\\)\\.\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\'"
+ "The format of a lock file.")
+
+(defun tramp-handle-file-locked-p (file)
+ "Like `file-locked-p' for Tramp files."
+ (when-let ((info (tramp-get-lock-file file))
+ (match (string-match tramp-lock-file-info-regexp info)))
+ (or (and (string-equal (match-string 1 info) (user-login-name))
+ (string-equal (match-string 2 info) (system-name))
+ (string-equal (match-string 3 info) (tramp-get-lock-pid file)))
+ (match-string 1 info))))
+
+(defun tramp-handle-lock-file (file)
+ "Like `lock-file' for Tramp files."
+ ;; See if this file is visited and has changed on disk since it
+ ;; was visited.
+ (catch 'dont-lock
+ (unless (eq (file-locked-p file) t) ;; Locked by me.
+ (when-let ((info (tramp-get-lock-file file))
+ (match (string-match tramp-lock-file-info-regexp info)))
+ (unless (ask-user-about-lock
+ file (format
+ "%s@%s (pid %s)" (match-string 1 info)
+ (match-string 2 info) (match-string 3 info)))
+ (throw 'dont-lock nil)))
+
+ (when-let ((lockname (tramp-compat-make-lock-file-name file))
+ ;; USER@HOST.PID[:BOOT_TIME]
+ (info
+ (format
+ "%s@%s.%s" (user-login-name) (system-name)
+ (tramp-get-lock-pid file))))
+
+ ;; Protect against security hole.
+ (with-parsed-tramp-file-name file nil
+ (when (and (not tramp-allow-unsafe-temporary-files)
+ create-lockfiles
+ (file-in-directory-p lockname temporary-file-directory)
+ (zerop (or (tramp-compat-file-attribute-user-id
+ (file-attributes file 'integer))
+ tramp-unknown-id-integer))
+ (not (with-tramp-connection-property
+ (tramp-get-process v) "unsafe-temporary-file"
+ (yes-or-no-p
+ (concat
+ "Lock file on local temporary directory, "
+ "do you want to continue? ")))))
+ (tramp-error v 'file-error "Unsafe lock file name")))
+
+ ;; Do the lock.
+ (let (create-lockfiles signal-hook-function)
+ (condition-case nil
+ (make-symbolic-link info lockname 'ok-if-already-exists)
+ (error
+ (with-file-modes #o0644
+ (write-region info nil lockname)))))))))
+
+(defun tramp-handle-make-lock-file-name (file)
+ "Like `make-lock-file-name' for Tramp files."
+ (and create-lockfiles
+ ;; This variable has been introduced with Emacs 28.1.
+ (not (bound-and-true-p remote-file-name-inhibit-locks))
+ (tramp-run-real-handler 'make-lock-file-name (list file))))
+
+(defun tramp-handle-unlock-file (file)
+ "Like `unlock-file' for Tramp files."
+ (when-let ((lockname (tramp-compat-make-lock-file-name file)))
+ (condition-case err
+ (delete-file lockname)
+ ;; `userlock--handle-unlock-error' exists since Emacs 28.1.
+ (error (tramp-compat-funcall 'userlock--handle-unlock-error err)))))
(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix)
"Like `load' for Tramp files."
@@ -3627,11 +3939,11 @@ User is always nil."
v 'file-error
"File `%s' does not include a `.el' or `.elc' suffix" file)))
(unless (or noerror (file-exists-p file))
- (tramp-error
- v tramp-file-missing "Cannot load nonexistent file `%s'" file))
+ (tramp-compat-file-missing v file))
(if (not (file-exists-p file))
nil
- (let ((tramp-message-show-message (not nomessage)))
+ (let ((signal-hook-function (unless noerror signal-hook-function))
+ (inhibit-message (or inhibit-message nomessage)))
(with-tramp-progress-reporter v 0 (format "Loading %s" file)
(let ((local-copy (file-local-copy file)))
(unwind-protect
@@ -3639,8 +3951,249 @@ User is always nil."
(delete-file local-copy)))))
t)))
+(defun tramp-multi-hop-p (vec)
+ "Whether the method of VEC is capable of multi-hops."
+ (and (tramp-sh-file-name-handler-p vec)
+ (not (tramp-get-method-parameter vec 'tramp-copy-program))))
+
+(defun tramp-compute-multi-hops (vec)
+ "Expands VEC according to `tramp-default-proxies-alist'."
+ (let ((saved-tdpa tramp-default-proxies-alist)
+ (target-alist `(,vec))
+ (hops (or (tramp-file-name-hop vec) ""))
+ (item vec)
+ choices proxy)
+
+ ;; Ad-hoc proxy definitions.
+ (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit)))
+ (let* ((host-port (tramp-file-name-host-port item))
+ (user-domain (tramp-file-name-user-domain item))
+ (proxy (concat
+ tramp-prefix-format proxy tramp-postfix-host-format))
+ (entry
+ (list (and (stringp host-port)
+ (concat "^" (regexp-quote host-port) "$"))
+ (and (stringp user-domain)
+ (concat "^" (regexp-quote user-domain) "$"))
+ (propertize proxy 'tramp-ad-hoc t))))
+ (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry)
+ ;; Add the hop.
+ (add-to-list 'tramp-default-proxies-alist entry)
+ (setq item (tramp-dissect-file-name proxy))))
+ ;; Save the new value.
+ (when (and hops tramp-save-ad-hoc-proxies)
+ (customize-save-variable
+ 'tramp-default-proxies-alist tramp-default-proxies-alist))
+
+ ;; Look for proxy hosts to be passed.
+ (setq choices tramp-default-proxies-alist)
+ (while choices
+ (setq item (pop choices)
+ proxy (eval (nth 2 item) t))
+ (when (and
+ ;; Host.
+ (string-match-p
+ (or (eval (nth 0 item) t) "")
+ (or (tramp-file-name-host-port (car target-alist)) ""))
+ ;; User.
+ (string-match-p
+ (or (eval (nth 1 item) t) "")
+ (or (tramp-file-name-user-domain (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.
+ (push l target-alist)
+ ;; Start next search.
+ (setq choices tramp-default-proxies-alist)))))
+
+ ;; Foreign and out-of-band methods are not supported for multi-hops.
+ (when (cdr target-alist)
+ (setq choices target-alist)
+ (while (setq item (pop choices))
+ (unless (tramp-multi-hop-p item)
+ (setq tramp-default-proxies-alist saved-tdpa)
+ (tramp-user-error
+ vec "Method `%s' is not supported for multi-hops."
+ (tramp-file-name-method item)))))
+
+ ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the
+ ;; host name in their command template. In this case, the remote
+ ;; file name must use either a local host name (first hop), or a
+ ;; host name matching the previous hop.
+ (let ((previous-host (or tramp-local-host-regexp "")))
+ (setq choices target-alist)
+ (while (setq item (pop choices))
+ (let ((host (tramp-file-name-host item)))
+ (unless
+ (or
+ ;; The host name is used for the remote shell command.
+ (member
+ '("%h") (tramp-get-method-parameter item 'tramp-login-args))
+ ;; The host name must match previous hop.
+ (string-match-p previous-host host))
+ (setq tramp-default-proxies-alist saved-tdpa)
+ (tramp-user-error
+ vec "Host name `%s' does not match `%s'" host previous-host))
+ (setq previous-host (concat "^" (regexp-quote host) "$")))))
+
+ ;; Result.
+ target-alist))
+
+(defun tramp-expand-args (vec parameter &rest spec-list)
+ "Expand login arguments as given by PARAMETER in `tramp-methods'.
+PARAMETER is a symbol like `tramp-login-args', denoting a list of
+list of strings from `tramp-methods', containing %-sequences for
+substitution. SPEC-LIST is a list of char/value pairs used for
+`format-spec-make'."
+ (let ((args (tramp-get-method-parameter vec parameter))
+ (spec (apply 'format-spec-make spec-list)))
+ ;; Expand format spec.
+ (tramp-compat-flatten-tree
+ (mapcar
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) x))
+ args))))
+
+(defun tramp-direct-async-process-p (&rest args)
+ "Whether direct async `make-process' can be called."
+ (let ((v (tramp-dissect-file-name default-directory))
+ (buffer (plist-get args :buffer))
+ (stderr (plist-get args :stderr)))
+ (and ;; The method supports it.
+ (tramp-get-method-parameter v 'tramp-direct-async)
+ ;; It has been indicated.
+ (tramp-get-connection-property v "direct-async-process" nil)
+ ;; There's no multi-hop.
+ (or (not (tramp-multi-hop-p v))
+ (= (length (tramp-compute-multi-hops v)) 1))
+ ;; There's no remote stdout or stderr file.
+ (or (not (stringp buffer)) (not (tramp-tramp-file-p buffer)))
+ (or (not (stringp stderr)) (not (tramp-tramp-file-p stderr))))))
+
+(defun tramp-handle-make-process (&rest args)
+ "An alternative `make-process' implementation for Tramp files."
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((default-directory (tramp-compat-temporary-file-directory))
+ (name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type (plist-get args :connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (null buffer) (bufferp buffer) (stringp buffer))
+ (signal 'wrong-type-argument (list #'stringp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (unless (or (null connection-type) (memq connection-type '(pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr))
+ (signal 'wrong-type-argument (list #'bufferp stderr)))
+
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ (env (mapcar
+ (lambda (elt)
+ (when (string-match-p "=" elt) elt))
+ tramp-remote-process-environment))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ (env (dolist (elt process-environment env)
+ (when
+ (and
+ (string-match-p "=" elt)
+ (not
+ (member
+ elt (default-toplevel-value 'process-environment))))
+ (setq env (cons elt env)))))
+ (env (setenv-internal
+ env "INSIDE_EMACS" (tramp-inside-emacs) 'keep))
+ (env (mapcar #'tramp-shell-quote-argument (delq nil env)))
+ ;; Quote command.
+ (command (mapconcat #'tramp-shell-quote-argument command " "))
+ ;; Set cwd and environment variables.
+ (command
+ (append `("cd" ,localname "&&" "(" "env") env `(,command ")"))))
+
+ ;; Check for `tramp-sh-file-name-handler', because something
+ ;; is different between tramp-sh.el, and tramp-adb.el or
+ ;; tramp-sshfs.el.
+ (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v))
+ (login-program
+ (tramp-get-method-parameter v 'tramp-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. The
+ ;; temporary file name is cached in the main
+ ;; connection process, therefore we cannot use
+ ;; `tramp-get-connection-process'.
+ (tmpfile
+ (when sh-file-name-handler-p
+ (with-tramp-connection-property
+ (tramp-get-process v) "temp-file"
+ (tramp-compat-make-temp-name))))
+ (options
+ (when sh-file-name-handler-p
+ (tramp-compat-funcall
+ 'tramp-ssh-controlmaster-options v)))
+ login-args p)
+
+ ;; Replace `login-args' place holders. Split
+ ;; ControlMaster options.
+ (setq
+ login-args
+ (append
+ (tramp-compat-flatten-tree
+ (tramp-get-method-parameter v 'tramp-async-args))
+ (tramp-compat-flatten-tree
+ (mapcar
+ (lambda (x) (split-string x " "))
+ (tramp-expand-args
+ v 'tramp-login-args
+ ?h (or host "") ?u (or user "") ?p (or port "")
+ ?c (format-spec (or options "") (format-spec-make ?t tmpfile))
+ ?l ""))))
+ p (make-process
+ :name name :buffer buffer
+ :command (append `(,login-program) login-args command)
+ :coding coding :noquery noquery :connection-type connection-type
+ :filter filter :sentinel sentinel :stderr stderr))
+
+ (tramp-message v 6 "%s" (string-join (process-command p) " "))
+ p))))))
+
(defun tramp-handle-make-symbolic-link
- (target linkname &optional ok-if-already-exists)
+ (target linkname &optional ok-if-already-exists)
"Like `make-symbolic-link' for Tramp files.
This is the fallback implementation for backends which do not
support symbolic links."
@@ -3653,8 +4206,7 @@ support symbolic links."
(tramp-run-real-handler
#'make-symbolic-link (list target linkname ok-if-already-exists))))
-(defun tramp-handle-shell-command
- (command &optional output-buffer error-buffer)
+(defun tramp-handle-shell-command (command &optional output-buffer error-buffer)
"Like `shell-command' for Tramp files."
(let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command))
(command (substring command 0 asynchronous))
@@ -3673,9 +4225,12 @@ support symbolic links."
(setq current-buffer-p t)
(current-buffer))
(t (get-buffer-create
+ ;; These variables have been introduced with Emacs 28.1.
(if asynchronous
- "*Async Shell Command*"
- "*Shell Command Output*")))))
+ (or (bound-and-true-p shell-command-buffer-name-async)
+ "*Async Shell Command*")
+ (or (bound-and-true-p shell-command-buffer-name)
+ "*Shell Command Output*"))))))
(error-buffer
(cond
((bufferp error-buffer) error-buffer)
@@ -3809,7 +4364,8 @@ support symbolic links."
(defun tramp-handle-start-file-process (name buffer program &rest args)
"Like `start-file-process' for Tramp files.
BUFFER might be a list, in this case STDERR is separated."
- ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only.
+ ;; `make-process' knows the `:file-handler' argument since Emacs
+ ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'.
(tramp-file-name-handler
'make-process
:name name
@@ -3907,7 +4463,8 @@ of."
(defun tramp-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -3916,8 +4473,25 @@ of."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((tmpfile (tramp-compat-make-temp-file filename))
- (modes (save-excursion (tramp-default-file-modes filename))))
+ (let ((file-locked (eq (file-locked-p lockname) t))
+ (tmpfile (tramp-compat-make-temp-file filename))
+ (modes (tramp-default-file-modes
+ filename (and (eq mustbenew 'excl) 'nofollow)))
+ (uid (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (tramp-compat-file-attribute-group-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-gid v 'integer))))
+
+ ;; Lock file.
+ (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
+ (file-remote-p lockname)
+ (not file-locked))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok))
;; The permissions of the temporary file should be set. If
@@ -3929,28 +4503,37 @@ of."
;; 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.
- (tramp-run-real-handler
- #'write-region (list start end tmpfile append 'no-message lockname))
+ (let (create-lockfiles)
+ (write-region start end tmpfile append 'no-message))
(condition-case nil
(rename-file tmpfile filename 'ok-if-already-exists)
(error
(delete-file tmpfile)
(tramp-error
- v 'file-error "Couldn't write region to `%s'" filename))))
+ v 'file-error "Couldn't write region to `%s'" filename)))
- (tramp-flush-file-properties v localname)
+ (tramp-flush-file-properties v localname)
- ;; Set file modification time.
- (when (or (eq visit t) (stringp visit))
- (set-visited-file-modtime
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ ;; Set file modification time.
+ (when (or (eq visit t) (stringp visit))
+ (set-visited-file-modtime
+ (or (tramp-compat-file-attribute-modification-time
+ (file-attributes filename))
+ (current-time))))
+
+ ;; Set the ownership.
+ (tramp-set-file-uid-gid filename uid gid)
- ;; The end.
- (when (and (null noninteractive)
- (or (eq visit t) (null visit) (stringp visit)))
- (tramp-message v 0 "Wrote %s" filename))
- (run-hooks 'tramp-handle-write-region-hook)))
+ ;; Unlock file.
+ (when file-locked
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
+ ;; The end.
+ (when (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook))))
;; This is used in tramp-sh.el and tramp-sudoedit.el.
(defconst tramp-stat-marker "/////"
@@ -3998,7 +4581,7 @@ of."
"Call `file-notify-rm-watch'."
(unless (process-live-p proc)
(tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event)
- (tramp-compat-funcall 'file-notify-rm-watch proc)))
+ (file-notify-rm-watch proc)))
;;; Functions for establishing connection:
@@ -4006,6 +4589,9 @@ of."
;; prompts from the remote host. See the variable
;; `tramp-actions-before-shell' for usage of these functions.
+(defvar tramp-process-action-regexp nil
+ "The regexp used to invoke an action in `tramp-process-one-action'.")
+
(defun tramp-action-login (_proc vec)
"Send the login name."
(let ((user (or (tramp-file-name-user vec)
@@ -4031,7 +4617,7 @@ of."
(unless (tramp-get-connection-property vec "first-password-request" nil)
(tramp-clear-passwd vec))
(goto-char (point-min))
- (tramp-check-for-regexp proc tramp-password-prompt-regexp)
+ (tramp-check-for-regexp proc tramp-process-action-regexp)
(tramp-message vec 3 "Sending %s" (match-string 1))
;; We don't call `tramp-send-string' in order to hide the
;; password from the debug buffer and the traces.
@@ -4096,6 +4682,23 @@ The terminal type can be configured with `tramp-terminal-type'."
(tramp-send-string vec tramp-local-end-of-line)
t)
+(defun tramp-action-show-and-confirm-message (proc vec)
+ "Show the user a message for confirmation.
+Wait, until the connection buffer changes."
+ (with-current-buffer (process-buffer proc)
+ (let ((stimers (with-timeout-suspend)))
+ (tramp-message vec 6 "\n%s" (buffer-string))
+ (goto-char (point-min))
+ (tramp-check-for-regexp proc tramp-process-action-regexp)
+ (with-temp-message (replace-regexp-in-string "[\r\n]" "" (match-string 0))
+ ;; Hide message in buffer.
+ (narrow-to-region (point-max) (point-max))
+ ;; Wait for new output.
+ (tramp-wait-for-regexp proc 30 "."))
+ ;; Reenable the timers.
+ (with-timeout-unsuspend stimers)))
+ t)
+
(defun tramp-action-process-alive (proc _vec)
"Check, whether a process has finished."
(unless (process-live-p proc)
@@ -4133,6 +4736,7 @@ The terminal type can be configured with `tramp-terminal-type'."
"Wait for output from the shell and perform one action.
See `tramp-process-actions' for the format of ACTIONS."
(let ((case-fold-search t)
+ tramp-process-action-regexp
found todo item pattern action)
(while (not found)
;; Reread output once all actions have been performed.
@@ -4140,9 +4744,10 @@ See `tramp-process-actions' for the format of ACTIONS."
(while (tramp-accept-process-output proc 0))
(setq todo actions)
(while todo
- (setq item (pop todo))
- (setq pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))))
- (setq action (nth 1 item))
+ (setq item (pop todo)
+ tramp-process-action-regexp (symbol-value (nth 0 item))
+ pattern (format "\\(%s\\)\\'" tramp-process-action-regexp)
+ action (nth 1 item))
(tramp-message
vec 5 "Looking for regexp \"%s\" from remote shell" pattern)
(when (tramp-check-for-regexp proc pattern)
@@ -4192,9 +4797,8 @@ performed successfully. Any other value means an error."
(catch 'tramp-action
(tramp-process-one-action proc vec actions)))))
(while (not exit)
- (setq exit
- (catch 'tramp-action
- (tramp-process-one-action proc vec actions)))))
+ (setq exit (catch 'tramp-action
+ (tramp-process-one-action proc vec actions)))))
(with-current-buffer (tramp-get-connection-buffer vec)
(widen)
(tramp-message vec 6 "\n%s" (buffer-string)))
@@ -4215,10 +4819,9 @@ performed successfully. Any other value means an error."
(tramp-get-connection-buffer vec)))
((eq exit 'process-died)
(substitute-command-keys
- (eval-when-compile
- (concat
- "Tramp failed to connect. If this happens repeatedly, try\n"
- " `\\[tramp-cleanup-this-connection]'"))))
+ (concat
+ "Tramp failed to connect. If this happens repeatedly, try\n"
+ " `\\[tramp-cleanup-this-connection]'")))
((eq exit 'timeout)
(format-message
"Timeout reached, see buffer `%s' for details"
@@ -4230,21 +4833,52 @@ performed successfully. Any other value means an error."
;;; Utility functions:
+;; In Emacs, there is some concurrency due to timers. If a timer
+;; interrupts Tramp and wishes to use the same connection buffer as
+;; the "main" Emacs, then garbage might occur in the connection
+;; buffer. Therefore, we need to make sure that a timer does not use
+;; the same connection buffer as the "main" Emacs. We lock each
+;; connection process separately by a connection property.
+
+(defmacro with-tramp-locked-connection (proc &rest body)
+ "Lock PROC for other communication, and run BODY.
+Mostly useful to protect BODY from being interrupted by timers."
+ (declare (indent 1) (debug t))
+ `(if (tramp-get-connection-property ,proc "locked" nil)
+ ;; Be kind for older Emacsen.
+ (if (member 'remote-file-error debug-ignored-errors)
+ (throw 'non-essential 'non-essential)
+ (tramp-error
+ ,proc 'remote-file-error "Forbidden reentrant call of Tramp"))
+ (unwind-protect
+ (progn
+ (tramp-set-connection-property ,proc "locked" t)
+ ,@body)
+ (tramp-flush-connection-property ,proc "locked"))))
+
+(font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-tramp-locked-connection\\>"))
+
(defun tramp-accept-process-output (proc &optional timeout)
"Like `accept-process-output' for Tramp processes.
This is needed in order to hide `last-coding-system-used', which is set
-for process communication also."
+for process communication also.
+If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'."
(with-current-buffer (process-buffer proc)
(let ((inhibit-read-only t)
last-coding-system-used
result)
- ;; JUST-THIS-ONE is set due to Bug#12145.
- (tramp-message
- proc 10 "%s %s %s %s\n%s"
- proc timeout (process-status proc)
- (with-local-quit
- (setq result (accept-process-output proc timeout nil t)))
- (buffer-string))
+ ;; This must be protected by the "locked" property.
+ (with-tramp-locked-connection proc
+ ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit'
+ ;; returns t in order to report success.
+ (if (with-local-quit
+ (setq result (accept-process-output proc timeout nil t)) t)
+ (tramp-message
+ proc 10 "%s %s %s %s\n%s"
+ proc timeout (process-status proc) result (buffer-string))
+ ;; Propagate quit.
+ (keyboard-quit)))
result)))
(defun tramp-search-regexp (regexp)
@@ -4361,19 +4995,21 @@ the remote host use line-endings as defined in the variable
(unless (or (string-empty-p string)
(string-equal (substring string -1) tramp-rsh-end-of-line))
(setq string (concat string tramp-rsh-end-of-line)))
- ;; Send the string.
- (with-local-quit
- (if (and chunksize (not (zerop chunksize)))
- (let ((pos 0)
- (end (length string)))
- (while (< pos end)
- (tramp-message
- vec 10 "Sending chunk from %s to %s"
- pos (min (+ pos chunksize) end))
- (process-send-string
- p (substring string pos (min (+ pos chunksize) end)))
- (setq pos (+ pos chunksize))))
- (process-send-string p string))))))
+ ;; This must be protected by the "locked" property.
+ (with-tramp-locked-connection p
+ ;; Send the string.
+ (with-local-quit
+ (if (and chunksize (not (zerop chunksize)))
+ (let ((pos 0)
+ (end (length string)))
+ (while (< pos end)
+ (tramp-message
+ vec 10 "Sending chunk from %s to %s"
+ pos (min (+ pos chunksize) end))
+ (process-send-string
+ p (substring string pos (min (+ pos chunksize) end)))
+ (setq pos (+ pos chunksize))))
+ (process-send-string p string)))))))
(defun tramp-process-sentinel (proc event)
"Flush file caches and remove shell prompt."
@@ -4402,7 +5038,7 @@ If it doesn't exist, generate a new one."
(with-tramp-connection-property (tramp-get-connection-process vec) "device"
(cons -1 (setq tramp-devices (1+ tramp-devices)))))
-;; Comparision of vectors is performed by `tramp-file-name-equal-p'.
+;; Comparison of vectors is performed by `tramp-file-name-equal-p'.
(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
@@ -4423,6 +5059,7 @@ If both files are local, the function returns t."
(and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2)
(string-equal (file-remote-p file1) (file-remote-p file2)))))
+;; See also `file-modes-symbolic-to-number'.
(defun tramp-mode-string-to-int (mode-string)
"Convert a ten-letter \"drwxrwxrwx\"-style MODE-STRING into mode bits."
(let* (case-fold-search
@@ -4502,6 +5139,7 @@ If both files are local, the function returns t."
"A list of file types returned from the `stat' system call.
This is used to map a mode number to a permission string.")
+;; See also `file-modes-number-to-symbolic'.
(defun tramp-file-mode-from-int (mode)
"Turn an integer representing a file MODE into an ls(1)-like string."
(let ((type (cdr
@@ -4512,9 +5150,9 @@ This is used to map a mode number to a permission string.")
(suid (> (logand (ash mode -9) 4) 0))
(sgid (> (logand (ash mode -9) 2) 0))
(sticky (> (logand (ash 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"))
+ (setq user (tramp-file-mode-permissions user suid "s")
+ group (tramp-file-mode-permissions group sgid "s")
+ other (tramp-file-mode-permissions other sticky "t"))
(concat type user group other)))
(defun tramp-file-mode-permissions (perm suid suid-text)
@@ -4544,16 +5182,15 @@ If FILENAME is remote, a file name handler is called."
(when (and modes (not (zerop (logand modes #o2000))))
(setq gid (tramp-compat-file-attribute-group-id (file-attributes dir)))))
- (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid)))
- (if handler
- (funcall handler #'tramp-set-file-uid-gid filename uid gid)
- ;; On W32 systems, "chown" does not work.
- (unless (memq system-type '(ms-dos windows-nt))
- (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer)))
- (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer))))
- (tramp-call-process
- nil "chown" nil nil nil (format "%d:%d" uid gid)
- (tramp-unquote-shell-quote-argument filename)))))))
+ (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid)))
+ (funcall handler #'tramp-set-file-uid-gid filename uid gid)
+ ;; On W32 systems, "chown" does not work.
+ (unless (memq system-type '(ms-dos windows-nt))
+ (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer)))
+ (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer))))
+ (tramp-call-process
+ nil "chown" nil nil nil (format "%d:%d" uid gid)
+ (tramp-unquote-shell-quote-argument filename))))))
(defun tramp-get-local-uid (id-format)
"The uid of the local user, in ID-FORMAT.
@@ -4583,7 +5220,7 @@ VEC is used for tracing."
(let ((candidates '("en_US.utf8" "C.utf8" "en_US.UTF-8"))
locale)
(with-temp-buffer
- (unless (or (memq system-type '(windows-nt))
+ (unless (or (eq system-type 'windows-nt)
(not (zerop (tramp-call-process
nil "locale" nil t nil "-a"))))
(while candidates
@@ -4619,12 +5256,8 @@ be granted."
(concat "file-attributes-" suffix) nil)
(file-attributes
(tramp-make-tramp-file-name vec) (intern suffix))))
- (remote-uid
- (tramp-get-connection-property
- vec (concat "uid-" suffix) nil))
- (remote-gid
- (tramp-get-connection-property
- vec (concat "gid-" suffix) nil))
+ (remote-uid (tramp-get-remote-uid vec (intern suffix)))
+ (remote-gid (tramp-get-remote-gid vec (intern suffix)))
(unknown-id
(if (string-equal suffix "string")
tramp-unknown-id-string tramp-unknown-id-integer)))
@@ -4658,6 +5291,32 @@ be granted."
(tramp-compat-file-attribute-group-id
file-attr))))))))))))
+(defun tramp-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "uid-%s" id-format)
+ (or (when-let
+ ((handler
+ (find-file-name-handler
+ (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid)))
+ (funcall handler #'tramp-get-remote-uid vec id-format))
+ ;; Ensure there is a valid result.
+ (and (equal id-format 'integer) tramp-unknown-id-integer)
+ (and (equal id-format 'string) tramp-unknown-id-string))))
+
+(defun tramp-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "gid-%s" id-format)
+ (or (when-let
+ ((handler
+ (find-file-name-handler
+ (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid)))
+ (funcall handler #'tramp-get-remote-gid vec id-format))
+ ;; Ensure there is a valid result.
+ (and (equal id-format 'integer) tramp-unknown-id-integer)
+ (and (equal id-format 'string) tramp-unknown-id-string))))
+
(defun tramp-local-host-p (vec)
"Return t if this points to the local host, nil otherwise.
This handles also chrooted environments, which are not regarded as local."
@@ -4671,16 +5330,16 @@ This handles also chrooted environments, which are not regarded as local."
;; The method shall be applied to one of the shell file name
;; handlers. `tramp-local-host-p' is also called for "smb" and
;; alike, where it must fail.
- (tramp-get-method-parameter vec 'tramp-login-program)
+ (tramp-sh-file-name-handler-p vec)
+ ;; Direct actions aren't possible for crypted directories.
+ (null tramp-crypt-enabled)
;; The local temp directory must be writable for the other user.
(file-writable-p
(tramp-make-tramp-file-name
vec (tramp-compat-temporary-file-directory) 'nohop))
;; On some systems, chown runs only for root.
(or (zerop (user-uid))
- ;; This is defined in tramp-sh.el. Let's assume this is
- ;; loaded already.
- (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer))))))
+ (zerop (tramp-get-remote-uid vec 'integer))))))
(defun tramp-get-remote-tmpdir (vec)
"Return directory for temporary files on the remote host identified by VEC."
@@ -4693,18 +5352,21 @@ This handles also chrooted environments, which are not regarded as local."
(tramp-error vec 'file-error "Directory %s not accessible" dir))
dir)))
+(defun tramp-make-tramp-temp-name (vec)
+ "Generate a temporary file name on the remote host identified by VEC."
+ (make-temp-name
+ (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))
+
(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 (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))
- result)
+ (let (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))
+ (setq result (tramp-make-tramp-temp-name vec))
(if (file-exists-p result)
(setq result nil)
;; This creates the file by side effect.
@@ -4729,37 +5391,54 @@ Return the local name of the temporary file."
"Like `make-auto-save-file-name' for Tramp files.
Returns a file name in `tramp-auto-save-directory' for autosaving
this file, if that variable is non-nil."
- (when (stringp tramp-auto-save-directory)
- (setq tramp-auto-save-directory
- (expand-file-name tramp-auto-save-directory)))
- ;; Create directory.
- (unless (or (null tramp-auto-save-directory)
- (file-exists-p tramp-auto-save-directory))
- (make-directory tramp-auto-save-directory t))
-
- (let ((system-type
- (if (and (stringp tramp-auto-save-directory)
- (tramp-tramp-file-p tramp-auto-save-directory))
- 'not-windows
- system-type))
- (auto-save-file-name-transforms
- (if (null tramp-auto-save-directory)
- auto-save-file-name-transforms))
- (buffer-file-name
- (if (null tramp-auto-save-directory)
- buffer-file-name
- (expand-file-name
- (tramp-subst-strs-in-string
- '(("_" . "|")
- ("/" . "_a")
- (":" . "_b")
- ("|" . "__")
- ("[" . "_l")
- ("]" . "_r"))
- (tramp-compat-file-name-unquote (buffer-file-name)))
- tramp-auto-save-directory))))
- ;; Run plain `make-auto-save-file-name'.
- (tramp-run-real-handler #'make-auto-save-file-name nil)))
+ (with-parsed-tramp-file-name buffer-file-name nil
+ (when (stringp tramp-auto-save-directory)
+ (setq tramp-auto-save-directory
+ (expand-file-name tramp-auto-save-directory)))
+ ;; Create directory.
+ (unless (or (null tramp-auto-save-directory)
+ (file-exists-p tramp-auto-save-directory))
+ (make-directory tramp-auto-save-directory t))
+
+ (let ((system-type
+ (if (and (stringp tramp-auto-save-directory)
+ (tramp-tramp-file-p tramp-auto-save-directory))
+ 'not-windows
+ system-type))
+ (auto-save-file-name-transforms
+ (if (null tramp-auto-save-directory)
+ auto-save-file-name-transforms))
+ (filename buffer-file-name)
+ (buffer-file-name
+ (if (null tramp-auto-save-directory)
+ buffer-file-name
+ (expand-file-name
+ (tramp-subst-strs-in-string
+ '(("_" . "|")
+ ("/" . "_a")
+ (":" . "_b")
+ ("|" . "__")
+ ("[" . "_l")
+ ("]" . "_r"))
+ (tramp-compat-file-name-unquote (buffer-file-name)))
+ tramp-auto-save-directory)))
+ result)
+ (prog1 ;; Run plain `make-auto-save-file-name'.
+ (setq result (tramp-run-real-handler #'make-auto-save-file-name nil))
+ ;; Protect against security hole.
+ (when (and (not tramp-allow-unsafe-temporary-files)
+ auto-save-default
+ (file-in-directory-p result temporary-file-directory)
+ (zerop (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ tramp-unknown-id-integer))
+ (not (with-tramp-connection-property
+ (tramp-get-process v) "unsafe-temporary-file"
+ (yes-or-no-p
+ (concat
+ "Autosave file on local temporary directory, "
+ "do you want to continue? ")))))
+ (tramp-error v 'file-error "Unsafe autosave file name"))))))
(defun tramp-subst-strs-in-string (alist string)
"Replace all occurrences of the string FROM with TO in STRING.
@@ -4877,6 +5556,19 @@ verbosity of 6."
(tramp-message vec 6 "%s" result)
result))
+(defun tramp-process-running-p (process-name)
+ "Return t if system process PROCESS-NAME is running for `user-login-name'."
+ (when (stringp process-name)
+ (catch 'result
+ (dolist (pid (list-system-processes))
+ (when-let ((attributes (process-attributes pid))
+ (comm (cdr (assoc 'comm attributes))))
+ (and (string-equal (cdr (assoc 'user attributes)) (user-login-name))
+ ;; The returned command name could be truncated to 15
+ ;; characters. Therefore, we cannot check for `string-equal'.
+ (string-prefix-p comm process-name)
+ (throw 'result t)))))))
+
(defun tramp-read-passwd (proc &optional prompt)
"Read a password from user (compat function).
Consults the auth-source package.
@@ -4899,6 +5591,8 @@ Invokes `password-read' if available, `read-passwd' else."
(tramp-check-for-regexp proc tramp-password-prompt-regexp)
(format "%s for %s " (capitalize (match-string 1)) key))))
(auth-source-creation-prompts `((secret . ,pw-prompt)))
+ ;; Use connection-local value.
+ (auth-sources (with-current-buffer (process-buffer proc) auth-sources))
;; We suspend the timers while reading the password.
(stimers (with-timeout-suspend))
auth-info auth-passwd)
@@ -4939,7 +5633,7 @@ Invokes `password-read' if available, `read-passwd' else."
(setq auth-passwd (funcall auth-passwd)))
auth-passwd)
- ;; Try the password cache.
+ ;; Try the password cache. Exists since Emacs 26.1.
(progn
(setq auth-passwd (password-read pw-prompt key)
tramp-password-save-function
@@ -4954,6 +5648,8 @@ Invokes `password-read' if available, `read-passwd' else."
;; Reenable the timers.
(with-timeout-unsuspend stimers))))
+(put #'tramp-read-passwd 'tramp-suppress-trace t)
+
(defun tramp-clear-passwd (vec)
"Clear password cache for connection related to VEC."
(let ((method (tramp-file-name-method vec))
@@ -4968,6 +5664,8 @@ Invokes `password-read' if available, `read-passwd' else."
:host ,host-port :port ,method))
(password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop))))
+(put #'tramp-clear-passwd 'tramp-suppress-trace t)
+
(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)."
@@ -5043,7 +5741,9 @@ name of a process or buffer, or nil to default to the current buffer."
(tramp-compat-funcall
'tramp-send-command
(process-get proc 'vector)
- (format "(\\kill -2 -%d || \\kill -2 %d) 2>/dev/null" pid pid))
+ (format "(\\kill -2 -%d || \\kill -2 %d) 2>%s"
+ pid pid
+ (tramp-get-remote-null-device (process-get proc 'vector))))
;; Wait, until the process has disappeared. If it doesn't,
;; fall back to the default implementation.
(while (tramp-accept-process-output proc 0))
@@ -5057,6 +5757,32 @@ name of a process or buffer, or nil to default to the current buffer."
(lambda ()
(remove-hook 'interrupt-process-functions #'tramp-interrupt-process))))
+(defun tramp-get-remote-null-device (vec)
+ "Return null device on the remote host identified by VEC.
+If VEC is nil, return local null device."
+ (if (null vec)
+ null-device
+ (with-tramp-connection-property vec "null-device"
+ (let ((default-directory (tramp-make-tramp-file-name vec)))
+ (tramp-compat-null-device)))))
+
+(defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body)
+ "Skeleton for `tramp-*-handle-delete-directory'.
+BODY is the backend specific code."
+ (declare (indent 3) (debug t))
+ `(with-parsed-tramp-file-name (expand-file-name ,directory) nil
+ (if (and delete-by-moving-to-trash ,trash)
+ ;; Move non-empty dir to trash only if recursive deletion was
+ ;; requested.
+ (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory)))
+ (tramp-error
+ v 'file-error "Directory is not empty, not moving to trash")
+ (move-file-to-trash ,directory))
+ ,@body)
+ (tramp-flush-directory-properties v localname)))
+
+(put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t)
+
;; Checklist for `tramp-unload-hook'
;; - Unload all `tramp-*' packages
;; - Reset `file-name-handler-alist'
@@ -5084,11 +5810,6 @@ name of a process or buffer, or nil to default to the current buffer."
;; strange when doing zerop, we should kill the process and start
;; again. (Greg Stark)
;;
-;; * I was wondering if 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
-;; are. (Andrea Crotti)
-;;
;; * Run emerge on two remote files. Bug is described here:
;; <https://www.mail-archive.com/tramp-devel@nongnu.org/msg01041.html>.
;; (Bug#6850)
@@ -5098,16 +5819,5 @@ name of a process or buffer, or nil to default to the current buffer."
;; and friends, for most of the handlers this is the major
;; difference between the different backends. Other handlers but
;; *-process-file would profit from this as well.
-;;
-;; * Get rid of `shell-command'. In its primary implementation, it
-;; uses `process-file-shell-command' and
-;; `start-file-process-shell-command', which is sufficient due to
-;; connection-local `shell-file-name'.
-
;;; tramp.el ends here
-
-;; Local Variables:
-;; mode: Emacs-Lisp
-;; coding: utf-8
-;; End:
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 5b858edf3cb..8ad641ee45b 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -7,6 +7,10 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp
+;; Version: 2.5.2-pre
+;; Package-Requires: ((emacs "25.1"))
+;; Package-Type: multi
+;; URL: https://www.gnu.org/software/tramp/
;; This file is part of GNU Emacs.
@@ -30,16 +34,13 @@
;;; Code:
-;; In the Tramp GIT, the version number is auto-frobbed from tramp.el,
-;; and the bug report address is auto-frobbed from configure.ac.
-;; Emacs version check is defined in macro AC_EMACS_INFO of
-;; aclocal.m4; should be changed only there.
-
-;; Needed for Emacs 24.
-(defvar inhibit-message)
+;; In the Tramp GIT repository, the version number, the bug report
+;; address and the required Emacs version are auto-frobbed from
+;; configure.ac, so you should edit that file and run "autoconf &&
+;; ./configure" to change them.
;;;###tramp-autoload
-(defconst tramp-version "2.4.5.27.2"
+(defconst tramp-version "2.5.2-pre"
"This version of Tramp.")
;;;###tramp-autoload
@@ -73,12 +74,17 @@
"The repository revision of the Tramp sources.")
;; Check for Emacs version.
-(let ((x (if (not (string-lessp emacs-version "24.4"))
+(let ((x (if (not (string-lessp emacs-version "25.1"))
"ok"
- (format "Tramp 2.4.5.27.2 is not fit for %s"
+ (format "Tramp 2.5.2-pre is not fit for %s"
(replace-regexp-in-string "\n" "" (emacs-version))))))
(unless (string-equal "ok" x) (error "%s" x)))
+(defun tramp-inside-emacs ()
+ "Version string provided by INSIDE_EMACS enmvironment variable."
+ (concat (or (getenv "INSIDE_EMACS") emacs-version)
+ ",tramp:" tramp-version))
+
;; Tramp versions integrated into Emacs. If a user option declares a
;; `:package-version' which doesn't belong to an integrated Tramp
;; version, it must be added here as well (see `tramp-syntax', for
@@ -104,8 +110,3 @@
(provide 'trampver)
;;; trampver.el ends here
-
-;; Local Variables:
-;; mode: Emacs-Lisp
-;; coding: utf-8
-;; End:
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index f9cd3a329cb..4baa657c0a5 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -1,10 +1,11 @@
-;;; webjump.el --- programmable Web hotlist
+;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
-;; Author: Neil W. Van Dyke <nwv@acm.org>
-;; Created: 09-Aug-1996
-;; Keywords: comm www
+;; Author: Neil W. Van Dyke <nwv@acm.org>
+;; Maintainer: emacs-devel@gnu.org
+;; Created: 09-Aug-1996
+;; Keywords: comm www
;; This file is part of GNU Emacs.
@@ -40,7 +41,6 @@
;; You may wish to add something like the following to your init file:
;;
-;; (require 'webjump)
;; (global-set-key "\C-cj" 'webjump)
;; (setq webjump-sites
;; (append '(
@@ -96,9 +96,6 @@
("DuckDuckGo" .
[simple-query "duckduckgo.com"
"duckduckgo.com/?q=" ""])
- ("Google" .
- [simple-query "www.google.com"
- "www.google.com/search?q=" ""])
("Google Groups" .
[simple-query "groups.google.com"
"groups.google.com/groups?q=" ""])
@@ -255,7 +252,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
(cond ((not expr) "")
((stringp expr) expr)
((vectorp expr) (webjump-builtin expr name))
- ((listp expr) (eval expr))
+ ((listp expr) (eval expr t))
((symbolp expr)
(if (fboundp expr)
(funcall expr name)
@@ -323,8 +320,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
(defun webjump-read-url-choice (what urls &optional default)
;; Note: Convert this to use `webjump-read-choice' someday.
- (let* ((completions (mapcar (function (lambda (n) (cons n n)))
- urls))
+ (let* ((completions (mapcar (lambda (n) (cons n n)) urls))
(input (completing-read (concat what
;;(if default " (RET for default)" "")
": ")
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index b7b832afed3..57a52effd14 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -304,7 +304,7 @@ This is useful when style-conventions require a certain minimal offset.
Python's PEP8 for example recommends two spaces, so you could do:
\(add-hook \\='python-mode-hook
- (lambda () (set (make-local-variable \\='comment-inline-offset) 2)))
+ (lambda () (setq-local comment-inline-offset 2)))
See `comment-padding' for whole-line comments."
:version "24.3"
@@ -361,21 +361,21 @@ function should first call this function explicitly."
(let ((cs (read-string "No comment syntax is defined. Use: ")))
(if (zerop (length cs))
(error "No comment syntax defined")
- (set (make-local-variable 'comment-start) cs)
- (set (make-local-variable 'comment-start-skip) cs))))
+ (setq-local comment-start cs)
+ (setq-local comment-start-skip cs))))
;; comment-use-syntax
(when (eq comment-use-syntax 'undecided)
- (set (make-local-variable 'comment-use-syntax)
- (let ((st (syntax-table))
- (cs comment-start)
- (ce (if (string= "" comment-end) "\n" comment-end)))
- ;; Try to skip over a comment using forward-comment
- ;; to see if the syntax tables properly recognize it.
- (with-temp-buffer
- (set-syntax-table st)
- (insert cs " hello " ce)
- (goto-char (point-min))
- (and (forward-comment 1) (eobp))))))
+ (setq-local comment-use-syntax
+ (let ((st (syntax-table))
+ (cs comment-start)
+ (ce (if (string= "" comment-end) "\n" comment-end)))
+ ;; Try to skip over a comment using forward-comment
+ ;; to see if the syntax tables properly recognize it.
+ (with-temp-buffer
+ (set-syntax-table st)
+ (insert cs " hello " ce)
+ (goto-char (point-min))
+ (and (forward-comment 1) (eobp))))))
;; comment-padding
(unless comment-padding (setq comment-padding 0))
(when (integerp comment-padding)
@@ -385,9 +385,9 @@ function should first call this function explicitly."
;;(setq comment-end (comment-string-strip comment-end nil t))
;; comment-continue
(unless (or comment-continue (string= comment-end ""))
- (set (make-local-variable 'comment-continue)
- (concat (if (string-match "\\S-\\S-" comment-start) " " "|")
- (substring comment-start 1)))
+ (setq-local comment-continue
+ (concat (if (string-match "\\S-\\S-" comment-start) " " "|")
+ (substring comment-start 1)))
;; Hasn't been necessary yet.
;; (unless (string-match comment-start-skip comment-continue)
;; (kill-local-variable 'comment-continue))
@@ -396,29 +396,29 @@ function should first call this function explicitly."
(unless (and comment-start-skip
;; In case comment-start has changed since last time.
(string-match comment-start-skip comment-start))
- (set (make-local-variable 'comment-start-skip)
- (concat (unless (eq comment-use-syntax t)
- ;; `syntax-ppss' will detect escaping.
- "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)")
- "\\(?:\\s<+\\|"
- (regexp-quote (comment-string-strip comment-start t t))
- ;; Let's not allow any \s- but only [ \t] since \n
- ;; might be both a comment-end marker and \s-.
- "+\\)[ \t]*")))
+ (setq-local comment-start-skip
+ (concat (unless (eq comment-use-syntax t)
+ ;; `syntax-ppss' will detect escaping.
+ "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)")
+ "\\(?:\\s<+\\|"
+ (regexp-quote (comment-string-strip comment-start t t))
+ ;; Let's not allow any \s- but only [ \t] since \n
+ ;; might be both a comment-end marker and \s-.
+ "+\\)[ \t]*")))
(unless (and comment-end-skip
;; In case comment-end has changed since last time.
(string-match comment-end-skip
(if (string= "" comment-end) "\n" comment-end)))
(let ((ce (if (string= "" comment-end) "\n"
(comment-string-strip comment-end t t))))
- (set (make-local-variable 'comment-end-skip)
- ;; We use [ \t] rather than \s- because we don't want to
- ;; remove ^L in C mode when uncommenting.
- (concat "[ \t]*\\(\\s>" (if comment-quote-nested "" "+")
- "\\|" (regexp-quote (substring ce 0 1))
- (if (and comment-quote-nested (<= (length ce) 1)) "" "+")
- (regexp-quote (substring ce 1))
- "\\)"))))))
+ (setq-local comment-end-skip
+ ;; We use [ \t] rather than \s- because we don't want to
+ ;; remove ^L in C mode when uncommenting.
+ (concat "[ \t]*\\(\\s>" (if comment-quote-nested "" "+")
+ "\\|" (regexp-quote (substring ce 0 1))
+ (if (and comment-quote-nested (<= (length ce) 1)) "" "+")
+ (regexp-quote (substring ce 1))
+ "\\)"))))))
(defun comment-quote-re (str unp)
(concat (regexp-quote (substring str 0 1))
@@ -832,12 +832,21 @@ Ensure that `comment-normalize-vars' has been called before you use this."
(when (and (stringp str) (string-match "\\S-" str))
;; Separate the actual string from any leading/trailing padding
(string-match "\\`\\s-*\\(.*?\\)\\s-*\\'" str)
- (let ((s (match-string 1 str)) ;actual string
+ (let ((s (match-string 1 str)) ;actual string
(lpad (substring str 0 (match-beginning 1))) ;left padding
- (rpad (concat (substring str (match-end 1)) ;original right padding
- (substring comment-padding ;additional right padding
- (min (- (match-end 0) (match-end 1))
- (length comment-padding)))))
+ (rpad (concat
+ (substring str (match-end 1)) ;original right padding
+ (if (numberp comment-padding)
+ (make-string (min comment-padding
+ (- (match-end 0) (match-end 1)))
+ ?\s)
+ (if (not (string-match-p "\\`\\s-" comment-padding))
+ ;; If the padding isn't spaces, then don't
+ ;; shorten the padding.
+ comment-padding
+ (substring comment-padding ;additional right padding
+ (min (- (match-end 0) (match-end 1))
+ (length comment-padding)))))))
;; We can only duplicate C if the comment-end has multiple chars
;; or if comments can be nested, else the comment-end `}' would
;; be turned into `}}}' where only the first ends the comment
@@ -852,7 +861,7 @@ Ensure that `comment-normalize-vars' has been called before you use this."
(concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
lpad "") ;padding is not required
(regexp-quote s)
- (when multi "+") ;the last char of S might be repeated
+ (when multi "+") ;the last char of S might be repeated
(mapconcat (lambda (c) (concat (regexp-quote (string c)) "?"))
rpad "")))))) ;padding is not required
@@ -871,9 +880,13 @@ Ensure that `comment-normalize-vars' has been called before you use this."
;; Only separate the left pad because we assume there is no right pad.
(string-match "\\`\\s-*" str)
(let ((s (substring str (match-end 0)))
- (pad (concat (substring comment-padding
- (min (- (match-end 0) (match-beginning 0))
- (length comment-padding)))
+ (pad (concat (if (not (string-match-p "\\`\\s-" comment-padding))
+ ;; If the padding isn't spaces, then don't
+ ;; shorten the padding.
+ comment-padding
+ (substring comment-padding
+ (min (- (match-end 0) (match-beginning 0))
+ (length comment-padding))))
(match-string 0 str)))
(c (aref str (match-end 0))) ;the first non-space char of STR
;; We can only duplicate C if the comment-end has multiple chars
@@ -1221,21 +1234,33 @@ changed with `comment-style'."
;; FIXME: maybe we should call uncomment depending on ARG.
(funcall comment-region-function beg end arg)))
-(defun comment-region-default-1 (beg end &optional arg)
+(defun comment-region-default-1 (beg end &optional arg noadjust)
+ "Comment region between BEG and END.
+See `comment-region' for ARG. If NOADJUST, do not skip past
+leading/trailing space when determining the region to comment
+out."
(let* ((numarg (prefix-numeric-value arg))
(style (cdr (assoc comment-style comment-styles)))
(lines (nth 2 style))
(block (nth 1 style))
(multi (nth 0 style)))
- ;; We use `chars' instead of `syntax' because `\n' might be
- ;; of end-comment syntax rather than of whitespace syntax.
- ;; sanitize BEG and END
- (goto-char beg) (skip-chars-forward " \t\n\r") (beginning-of-line)
- (setq beg (max beg (point)))
- (goto-char end) (skip-chars-backward " \t\n\r") (end-of-line)
- (setq end (min end (point)))
- (if (>= beg end) (error "Nothing to comment"))
+ (if noadjust
+ (when (bolp)
+ (setq end (1- end)))
+ ;; We use `chars' instead of `syntax' because `\n' might be
+ ;; of end-comment syntax rather than of whitespace syntax.
+ ;; sanitize BEG and END
+ (goto-char beg)
+ (skip-chars-forward " \t\n\r")
+ (beginning-of-line)
+ (setq beg (max beg (point)))
+ (goto-char end)
+ (skip-chars-backward " \t\n\r")
+ (end-of-line)
+ (setq end (min end (point)))
+ (when (>= beg end)
+ (error "Nothing to comment")))
;; sanitize LINES
(setq lines
@@ -1283,7 +1308,11 @@ changed with `comment-style'."
(let ((s (comment-padleft comment-end numarg)))
(and s (if (string-match comment-end-skip s) s
(comment-padright comment-end))))
- (if multi (comment-padright comment-continue numarg))
+ (if multi
+ (or (comment-padright comment-continue numarg)
+ ;; `comment-padright' returns nil when
+ ;; `comment-continue' contains only whitespace
+ (and (stringp comment-continue) comment-continue)))
(if multi
(comment-padleft (comment-string-reverse comment-continue) numarg))
block
diff --git a/lisp/notifications.el b/lisp/notifications.el
index 6615f8bb267..ebd74dd3ef2 100644
--- a/lisp/notifications.el
+++ b/lisp/notifications.el
@@ -1,4 +1,4 @@
-;;; notifications.el --- Client interface to desktop notifications.
+;;; notifications.el --- Client interface to desktop notifications. -*- lexical-binding: t -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
;;; Commentary:
;; This package provides an implementation of the Desktop Notifications
-;; <http://developer.gnome.org/notification-spec/>.
+;; <https://developer.gnome.org/notification-spec/>.
;; In order to activate this package, you must add the following code
;; into your .emacs:
@@ -229,56 +229,69 @@ of another `notifications-notify' call."
id)
;; Build hints array
(when urgency
- (add-to-list 'hints `(:dict-entry
- "urgency"
- (:variant :byte ,(pcase urgency
- ('low 0)
- ('critical 2)
- (_ 1)))) t))
+ (push `(:dict-entry
+ "urgency"
+ (:variant :byte ,(pcase urgency
+ ('low 0)
+ ('critical 2)
+ (_ 1))))
+ hints))
(when category
- (add-to-list 'hints `(:dict-entry
- "category"
- (:variant :string ,category)) t))
+ (push `(:dict-entry
+ "category"
+ (:variant :string ,category))
+ hints))
(when desktop-entry
- (add-to-list 'hints `(:dict-entry
- "desktop-entry"
- (:variant :string ,desktop-entry)) t))
+ (push `(:dict-entry
+ "desktop-entry"
+ (:variant :string ,desktop-entry))
+ hints))
(when image-data
- (add-to-list 'hints `(:dict-entry
- "image-data"
- (:variant :struct ,image-data)) t))
+ (push `(:dict-entry
+ "image-data"
+ (:variant :struct ,image-data))
+ hints))
(when image-path
- (add-to-list 'hints `(:dict-entry
- "image-path"
- (:variant :string ,image-path)) t))
+ (push `(:dict-entry
+ "image-path"
+ (:variant :string ,image-path))
+ hints))
(when action-items
- (add-to-list 'hints `(:dict-entry
- "action-items"
- (:variant :boolean ,action-items)) t))
+ (push `(:dict-entry
+ "action-items"
+ (:variant :boolean ,action-items))
+ hints))
(when sound-file
- (add-to-list 'hints `(:dict-entry
- "sound-file"
- (:variant :string ,sound-file)) t))
+ (push `(:dict-entry
+ "sound-file"
+ (:variant :string ,sound-file))
+ hints))
(when sound-name
- (add-to-list 'hints `(:dict-entry
- "sound-name"
- (:variant :string ,sound-name)) t))
+ (push `(:dict-entry
+ "sound-name"
+ (:variant :string ,sound-name))
+ hints))
(when suppress-sound
- (add-to-list 'hints `(:dict-entry
- "suppress-sound"
- (:variant :boolean ,suppress-sound)) t))
+ (push `(:dict-entry
+ "suppress-sound"
+ (:variant :boolean ,suppress-sound))
+ hints))
(when resident
- (add-to-list 'hints `(:dict-entry
- "resident"
- (:variant :boolean ,resident)) t))
+ (push `(:dict-entry
+ "resident"
+ (:variant :boolean ,resident))
+ hints))
(when transient
- (add-to-list 'hints `(:dict-entry
- "transient"
- (:variant :boolean ,transient)) t))
+ (push `(:dict-entry
+ "transient"
+ (:variant :boolean ,transient))
+ hints))
(when x
- (add-to-list 'hints `(:dict-entry "x" (:variant :int32 ,x)) t))
+ (push `(:dict-entry "x" (:variant :int32 ,x)) hints))
(when y
- (add-to-list 'hints `(:dict-entry "y" (:variant :int32 ,y)) t))
+ (push `(:dict-entry "y" (:variant :int32 ,y)) hints))
+
+ (setq hints (nreverse hints))
;; Call Notify method.
(setq id
@@ -313,8 +326,8 @@ of another `notifications-notify' call."
(on-close (plist-get params :on-close))
(unique-name (dbus-get-name-owner bus notifications-service)))
(when on-action
- (add-to-list 'notifications-on-action-map
- (list (list bus unique-name id) on-action))
+ (push (list (list bus unique-name id) on-action)
+ notifications-on-action-map)
(unless notifications-on-action-object
(setq notifications-on-action-object
(dbus-register-signal
@@ -326,8 +339,8 @@ of another `notifications-notify' call."
'notifications-on-action-signal))))
(when on-close
- (add-to-list 'notifications-on-close-map
- (list (list bus unique-name id) on-close))
+ (push (list (list bus unique-name id) on-close)
+ notifications-on-close-map)
(unless notifications-on-close-object
(setq notifications-on-close-object
(dbus-register-signal
@@ -407,3 +420,5 @@ version this library is compliant with."
notifications-get-server-information-method)))
(provide 'notifications)
+
+;;; notifications.el ends here
diff --git a/lisp/novice.el b/lisp/novice.el
index 22eca21784c..16766c253c5 100644
--- a/lisp/novice.el
+++ b/lisp/novice.el
@@ -1,4 +1,4 @@
-;;; novice.el --- handling of disabled commands ("novice mode") for Emacs
+;;; novice.el --- handling of disabled commands ("novice mode") for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1985-1987, 1994, 2001-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index fa5aa14d5ba..1bc905cee2d 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -54,26 +54,30 @@
"Non-nil means display glyph following character reference.
The glyph is displayed in face `nxml-glyph'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-sexp-element-flag t
"Non-nil means sexp commands treat an element as a single expression."
:version "27.1" ; nil -> t
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-slash-auto-complete-flag nil
"Non-nil means typing a slash automatically completes the end-tag.
This is used by `nxml-electric-slash'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-child-indent 2
"Indentation for the children of an element relative to the start-tag.
This only applies when the line or lines containing the start-tag contains
nothing else other than that start-tag."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-attribute-indent 4
"Indentation for the attributes of an element relative to the start-tag.
@@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts a line.
In other cases, the first attribute on one line is indented the same
as the first attribute on the previous line."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-bind-meta-tab-to-complete-flag t
"Non-nil means to use nXML completion in \\[completion-at-point]."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-to-utf-8-flag nil
"Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
@@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding declaration
and when its current `buffer-file-coding-system' specifies neither UTF-16
nor UTF-8."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type
'windows-nt)
@@ -103,20 +110,25 @@ This is used only for saving a buffer; when reading the byte-order is
auto-detected. It may be relevant both when there is no encoding declaration
and when the encoding declaration specifies `UTF-16'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-default-buffer-file-coding-system nil
"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."
+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)
+ :type 'coding-system
+ :safe #'coding-system-p)
(defcustom nxml-auto-insert-xml-declaration-flag nil
"Non-nil means automatically insert an XML declaration in a new file.
The XML declaration is inserted using `nxml-insert-xml-declaration'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defface nxml-delimited-data
'((t (:inherit font-lock-doc-face)))
@@ -534,7 +546,7 @@ Many aspects this mode can be customized using
(when (and nxml-default-buffer-file-coding-system
(not (local-variable-p 'buffer-file-coding-system)))
(setq buffer-file-coding-system nxml-default-buffer-file-coding-system))
- ;; When starting a new file, insert the XML declaraction.
+ ;; When starting a new file, insert the XML declaration.
(when (and nxml-auto-insert-xml-declaration-flag
(zerop (buffer-size)))
(nxml-insert-xml-declaration)))
@@ -2230,7 +2242,7 @@ ENDP is t in the former case, nil in the latter."
(skip-line-prefix fill-prefix)
fill-prefix))
-(defun nxml-newline-and-indent (soft)
+(defun nxml-newline-and-indent (&optional soft)
(delete-horizontal-space)
(if soft (insert-and-inherit ?\n) (newline 1))
(nxml-indent-line))
diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el
index dcbd7ed1dd7..1314ade9e31 100644
--- a/lisp/nxml/rng-cmpct.el
+++ b/lisp/nxml/rng-cmpct.el
@@ -26,7 +26,7 @@
;; specified in rng-pttrn.el.
;;
;; RELAX NG Compact Syntax is specified by
-;; http://relaxng.org/compact.html
+;; https://relaxng.org/compact.html
;;
;; This file uses the prefix "rng-c-".
@@ -123,8 +123,7 @@ Return a pattern."
(set-buffer-multibyte t)
(set-syntax-table rng-c-syntax-table))
-(defvar rng-c-current-token nil)
-(make-variable-buffer-local 'rng-c-current-token)
+(defvar-local rng-c-current-token nil)
(defun rng-c-advance ()
(cond ((looking-at rng-c-token-re)
@@ -334,11 +333,9 @@ OVERRIDE is either nil, require or t."
;;; Parsing
-(defvar rng-c-escape-positions nil)
-(make-variable-buffer-local 'rng-c-escape-positions)
+(defvar-local rng-c-escape-positions nil)
-(defvar rng-c-file-name nil)
-(make-variable-buffer-local 'rng-c-file-name)
+(defvar-local rng-c-file-name nil)
(defvar rng-c-file-index nil)
@@ -925,4 +922,4 @@ Current token after parse is token following ]."
(provide 'rng-cmpct)
-;;; rng-cmpct.el
+;;; rng-cmpct.el ends here
diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el
index d5a608d6ff2..a38da794226 100644
--- a/lisp/nxml/rng-loc.el
+++ b/lisp/nxml/rng-loc.el
@@ -182,7 +182,7 @@ If TYPE-ID is non-nil, then locate the schema for this TYPE-ID."
(while files
(setq type-ids (rng-possible-type-ids-using (car files) type-ids))
(setq files (cdr files)))
- (rng-uniquify-equal (sort type-ids 'string<))))
+ (seq-uniq (sort type-ids 'string<))))
(defun rng-locate-schema-file-using (files)
"Locate a schema using the schema locating files FILES.
diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el
index 4fc6727d0e6..7a2739c0616 100644
--- a/lisp/nxml/rng-match.el
+++ b/lisp/nxml/rng-match.el
@@ -472,7 +472,7 @@ list is nullable and whose cdr is the normalized list."
(cons nullable
(if sorted
head
- (rng-uniquify-eq (sort head 'rng-compare-ipattern))))))
+ (seq-uniq (sort head 'rng-compare-ipattern) #'eq)))))
(defun rng-compare-ipattern (p1 p2)
(< (rng--ipattern-index p1)
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index 7d74fd3c8a7..d70a346159a 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -24,7 +24,6 @@
;;; Code:
-(require 'easymenu)
(require 'xmltok)
(require 'nxml-util)
(require 'nxml-ns)
@@ -180,7 +179,8 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
;; attributes are required
(insert " "))))
((member completion extra-strings)
- (insert ">")))))))))
+ (insert ">"))))
+ :company-kind ,(lambda () 'property))))))
(defconst rng-in-end-tag-name-regex
(replace-regexp-in-string
@@ -255,7 +255,8 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
(when (and (eq status 'finished)
(not (looking-at "=")))
(insert "=\"\"")
- (forward-char -1)))))))))
+ (forward-char -1)))
+ :company-kind ,(lambda (_) 'enum-member)))))))
(defconst rng-in-attribute-value-regex
(replace-regexp-in-string
@@ -280,7 +281,8 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
(lambda (_completion status)
(when (eq status 'finished)
(let ((delim (char-before value-start)))
- (unless (eq (char-after) delim) (insert delim)))))))
+ (unless (eq (char-after) delim) (insert delim))))))
+ (kind-function (lambda (_) 'value)))
(and (rng-adjust-state-for-attribute lt-pos
name-start)
(if (string= (buffer-substring-no-properties name-start
@@ -291,14 +293,16 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
(rng-possible-namespace-uris
(and colon
(buffer-substring-no-properties (1+ colon) name-end))))
- :exit-function ,exit-function)
+ :exit-function ,exit-function
+ :company-kind ,kind-function)
(rng-adjust-state-for-attribute-value name-start
colon
name-end)
`(,value-start ,(point)
,(rng-strings-to-completion-table
(rng-match-possible-value-strings))
- :exit-function ,exit-function))))))
+ :exit-function ,exit-function
+ :company-kind ,kind-function))))))
(defun rng-possible-namespace-uris (prefix)
(let ((ns (if prefix (nxml-ns-get-prefix prefix)
@@ -523,7 +527,7 @@ set `xmltok-dtd'. Returns the position of the end of the token."
(unless attribute-flag
(setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
(setq iter (cdr iter)))
- (rng-uniquify-equal
+ (seq-uniq
(sort (apply #'append
(cons extra-strings
(mapcar (lambda (name)
diff --git a/lisp/nxml/rng-pttrn.el b/lisp/nxml/rng-pttrn.el
index 12ffa578200..034671feeb0 100644
--- a/lisp/nxml/rng-pttrn.el
+++ b/lisp/nxml/rng-pttrn.el
@@ -66,9 +66,8 @@
(defvar rng-schema-change-hook nil
"Hook to be run after `rng-current-schema' changes.")
-(defvar rng-current-schema nil
+(defvar-local rng-current-schema nil
"Pattern to be used as schema for the current buffer.")
-(make-variable-buffer-local 'rng-current-schema)
(defun rng-make-ref (name)
(list 'ref nil name))
diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el
index 59465c371eb..67e2ee9f1e3 100644
--- a/lisp/nxml/rng-util.el
+++ b/lisp/nxml/rng-util.el
@@ -1,4 +1,4 @@
-;;; rng-util.el --- utility functions for RELAX NG library
+;;; rng-util.el --- utility functions for RELAX NG library -*- lexical-binding: t; -*-
;; Copyright (C) 2003, 2007-2021 Free Software Foundation, Inc.
@@ -36,26 +36,6 @@
(defconst rng-builtin-datatypes-uri (rng-make-datatypes-uri ""))
-(defun rng-uniquify-eq (list)
- "Destructively remove `eq' duplicates from LIST."
- (and list
- (let ((head list))
- (while (cdr head)
- (if (eq (car head) (cadr head))
- (setcdr head (cddr head)))
- (setq head (cdr head)))
- list)))
-
-(defun rng-uniquify-equal (list)
- "Destructively remove `equal' duplicates from LIST."
- (and list
- (let ((head list))
- (while (cdr head)
- (if (equal (car head) (cadr head))
- (setcdr head (cddr head)))
- (setq head (cdr head)))
- list)))
-
(defun rng-blank-p (str) (string-match "\\`[ \t\n\r]*\\'" str))
(defun rng-substq (new old list)
@@ -104,6 +84,14 @@ LIST is not modified."
(define-error 'rng-error nil)
+;; Obsolete.
+
+(defun rng-uniquify-eq (list)
+ (declare (obsolete seq-uniq "28.1"))
+ (seq-uniq list #'eq))
+
+(define-obsolete-function-alias 'rng-uniquify-equal #'seq-uniq "28.1")
+
(provide 'rng-util)
;;; rng-util.el ends here
diff --git a/lisp/nxml/rng-valid.el b/lisp/nxml/rng-valid.el
index 6ea893404cb..a5eb893c554 100644
--- a/lisp/nxml/rng-valid.el
+++ b/lisp/nxml/rng-valid.el
@@ -132,36 +132,30 @@ A quick validation validates at most one chunk."
;; Global variables
-(defvar rng-validate-timer nil)
-(make-variable-buffer-local 'rng-validate-timer)
+(defvar-local rng-validate-timer nil)
;; ensure that we can cancel the timer even after a kill-all-local-variables
(put 'rng-validate-timer 'permanent-local t)
-(defvar rng-validate-quick-timer nil)
-(make-variable-buffer-local 'rng-validate-quick-timer)
+(defvar-local rng-validate-quick-timer nil)
;; ensure that we can cancel the timer even after a kill-all-local-variables
(put 'rng-validate-quick-timer 'permanent-local t)
-(defvar rng-error-count nil
+(defvar-local rng-error-count nil
"Number of errors in the current buffer.
Always equal to number of overlays with category `rng-error'.")
-(make-variable-buffer-local 'rng-error-count)
-(defvar rng-message-overlay nil
+(defvar-local rng-message-overlay nil
"Overlay in this buffer whose `help-echo' property was last printed.
It is nil if none.")
-(make-variable-buffer-local 'rng-message-overlay)
-(defvar rng-message-overlay-inhibit-point nil
+(defvar-local rng-message-overlay-inhibit-point nil
"Position at which message from overlay should be inhibited.
If point is equal to this and the error overlay around
point is `rng-message-overlay', then the `help-echo' property
of the error overlay should not be printed with `message'.")
-(make-variable-buffer-local 'rng-message-overlay-inhibit-point)
-(defvar rng-message-overlay-current nil
+(defvar-local rng-message-overlay-current nil
"Non-nil if `rng-message-overlay' is still the current message.")
-(make-variable-buffer-local 'rng-message-overlay-current)
(defvar rng-open-elements nil
"Stack of names of open elements represented as a list.
@@ -178,11 +172,10 @@ indicating an unresolvable entity or character reference.")
(defvar rng-collecting-text nil)
-(defvar rng-validate-up-to-date-end nil
+(defvar-local rng-validate-up-to-date-end nil
"Last position where validation is known to be up to date.")
-(make-variable-buffer-local 'rng-validate-up-to-date-end)
-(defvar rng-conditional-up-to-date-start nil
+(defvar-local rng-conditional-up-to-date-start nil
"Marker for the start of the conditionally up-to-date region.
It is nil if there is no conditionally up-to-date region. The
conditionally up-to-date region must be such that for any cached
@@ -191,20 +184,17 @@ if at some point it is determined that S becomes correct for P,
then all states with position >= P in the conditionally up to
date region must also then be correct and all errors between P
and the end of the region must then be correctly marked.")
-(make-variable-buffer-local 'rng-conditional-up-to-date-start)
-(defvar rng-conditional-up-to-date-end nil
+(defvar-local rng-conditional-up-to-date-end nil
"Marker for the end of the conditionally up-to-date region.
It is nil if there is no conditionally up-to-date region.
See the variable `rng-conditional-up-to-date-start'.")
-(make-variable-buffer-local 'rng-conditional-up-to-date-end)
(defvar rng-parsing-for-state nil
"Non-nil means we are currently parsing just to compute the state.
Should be dynamically bound.")
-(defvar rng-dtd nil)
-(make-variable-buffer-local 'rng-dtd)
+(defvar-local rng-dtd nil)
;;;###autoload
(define-minor-mode rng-validate-mode
diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el
index 81314b85ca9..9941aba6eb1 100644
--- a/lisp/nxml/rng-xsd.el
+++ b/lisp/nxml/rng-xsd.el
@@ -24,14 +24,14 @@
;; The main entry point is `rng-xsd-compile'. The validator
;; knows to use this for the datatype library with URI
-;; http://www.w3.org/2001/XMLSchema-datatypes because it
+;; https://www.w3.org/2001/XMLSchema-datatypes because it
;; is the value of the rng-dt-compile property on that URI
;; as a symbol.
;;
;; W3C XML Schema Datatypes are specified by
-;; http://www.w3.org/TR/xmlschema-2/
+;; https://www.w3.org/TR/xmlschema-2/
;; Guidelines for using them with RELAX NG are described in
-;; http://relaxng.org/xsd.html
+;; https://relaxng.org/xsd.html
;;; Code:
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index 8f89598a5ad..9824eebbd8b 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -324,8 +324,8 @@ and VALUE-END, otherwise a STRING giving the value."
(setq strs (cons (car arg) strs))
(setq names (cons (cdr arg) names)))
(setq args (cdr args))))
- (cons (apply 'concat (nreverse strs))
- (apply 'append (nreverse names))))))
+ (cons (apply #'concat (nreverse strs))
+ (apply #'append (nreverse names))))))
(eval-when-compile
;; Make a symbolic group named NAME from the regexp R.
@@ -338,7 +338,7 @@ and VALUE-END, otherwise a STRING giving the value."
(cons (concat "\\(" (car ,sym) "\\)") (cons ',name (cdr ,sym)))))))
(defun xmltok-p (&rest r) (xmltok+ "\\(?:"
- (apply 'xmltok+ r)
+ (apply #'xmltok+ r)
"\\)"))
;; Get the group index of ELEM in a LIST of symbols.
@@ -372,22 +372,23 @@ and VALUE-END, otherwise a STRING giving the value."
(defmacro xmltok-defregexp (sym r)
`(defalias ',sym
(let ((r ,r))
- `(macro lambda (action &optional group-name)
- (cond ((eq action 'regexp)
- ,(car r))
- ((or (eq action 'start) (eq action 'beginning))
- (list 'match-beginning (xmltok-get-index group-name
- ',(cdr r))))
- ((eq action 'end)
- (list 'match-end (xmltok-get-index group-name
- ',(cdr r))))
- ((eq action 'string)
- (list 'match-string
- (xmltok-get-index group-name ',(cdr r))))
- ((eq action 'string-no-properties)
- (list 'match-string-no-properties
- (xmltok-get-index group-name ',(cdr r))))
- (t (error "Invalid action: %s" action))))))))
+ `(macro
+ . ,(lambda (action &optional group-name)
+ (cond ((eq action 'regexp)
+ (car r))
+ ((or (eq action 'start) (eq action 'beginning))
+ (list 'match-beginning (xmltok-get-index group-name
+ (cdr r))))
+ ((eq action 'end)
+ (list 'match-end (xmltok-get-index group-name
+ (cdr r))))
+ ((eq action 'string)
+ (list 'match-string
+ (xmltok-get-index group-name (cdr r))))
+ ((eq action 'string-no-properties)
+ (list 'match-string-no-properties
+ (xmltok-get-index group-name (cdr r))))
+ (t (error "Invalid action: %s" action)))))))))
(eval-when-compile
@@ -878,7 +879,7 @@ and VALUE-END, otherwise a STRING giving the value."
(cons " " value-parts)))))
(< (point) end))))
(when well-formed
- (aset att 5 (apply 'concat (nreverse value-parts))))
+ (aset att 5 (apply #'concat (nreverse value-parts))))
(aset att 6 (nreverse refs))))
(defun xmltok-scan-after-amp (entity-handler)
@@ -1333,7 +1334,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT."
t))))
(if (not well-formed)
nil
- (apply 'concat
+ (apply #'concat
(nreverse (cons (buffer-substring-no-properties start lim)
value-parts))))))
@@ -1358,7 +1359,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT."
(defun xmltok-require-next-token (&rest types)
(xmltok-next-prolog-token)
- (apply 'xmltok-require-token types))
+ (apply #'xmltok-require-token types))
(defun xmltok-require-token (&rest types)
;; XXX Generate a more helpful error message
diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el
index cd2d21e37ad..f07ca6657ed 100644
--- a/lisp/nxml/xsd-regexp.el
+++ b/lisp/nxml/xsd-regexp.el
@@ -24,7 +24,7 @@
;; This handles the regular expressions in the syntax defined by:
;; W3C XML Schema Part 2: Datatypes
-;; <http://www.w3.org/TR/xmlschema-2/#regexs>
+;; <https://www.w3.org/TR/xmlschema-2/#regexs>
;;
;; The main entry point is `xsdre-translate'.
;;
@@ -387,9 +387,15 @@ consisting of a single char alternative delimited with []."
((eq first ?-)
(setq hyphen t)
(setq first (1+ first)))
+ ((eq last ?-)
+ (setq hyphen t)
+ (setq last (1- last)))
((eq first ?\])
(setq close-bracket t)
- (setq first (1+ first))))
+ (setq first (1+ first)))
+ ((eq last ?\])
+ (setq close-bracket t)
+ (setq last (1- last))))
(<= first last)))
(when (<= first last)
(setq chars
@@ -1219,7 +1225,7 @@ Code is inserted into the current buffer."
;; The rest of the file was auto-generated by doing M-x xsdre-gen-categories
;; on UnicodeData-3.1.0.txt available from
-;; http://www.unicode.org/Public/3.1-Update/UnicodeData-3.1.0.txt
+;; https://www.unicode.org/Public/3.1-Update/UnicodeData-3.1.0.txt
(xsdre-def-primitive-category 'Lu
'((65 . 90)
diff --git a/lisp/obsolete/abbrevlist.el b/lisp/obsolete/abbrevlist.el
index 1d517dbd116..c9c0956903f 100644
--- a/lisp/obsolete/abbrevlist.el
+++ b/lisp/obsolete/abbrevlist.el
@@ -1,4 +1,4 @@
-;;; abbrevlist.el --- list one abbrev table alphabetically ordered
+;;; abbrevlist.el --- list one abbrev table alphabetically ordered -*- lexical-binding: t; -*-
;; Copyright (C) 1986, 1992, 2001-2021 Free Software Foundation, Inc.
;; Suggested by a previous version by Gildea.
@@ -38,7 +38,7 @@
(function (lambda (abbrev)
(setq abbrev-list (cons abbrev abbrev-list))))
abbrev-table)
- (setq abbrev-list (sort abbrev-list 'string-lessp))
+ (setq abbrev-list (sort abbrev-list #'string-lessp))
(while abbrev-list
(if (> (+ first-column 40) (window-width))
(progn
diff --git a/lisp/obsolete/bruce.el b/lisp/obsolete/bruce.el
index 398f315c5d4..1c3581f7d05 100644
--- a/lisp/obsolete/bruce.el
+++ b/lisp/obsolete/bruce.el
@@ -1,4 +1,4 @@
-;;; bruce.el --- bruce phrase utility for overloading the Communications
+;;; bruce.el --- bruce phrase utility for overloading the Communications -*- lexical-binding: t; -*-
;;; Decency Act snoops, if any.
;; Copyright (C) 1988, 1993, 1997, 2001-2021 Free Software Foundation,
@@ -30,7 +30,7 @@
;; Decency Act of 1996. This Act bans "indecent speech", whatever that is,
;; from the Internet. For more on the CDA, see Richard Stallman's essay on
;; censorship, included in the etc directory of emacs distributions 19.34
-;; and up. See also http://www.eff.org/blueribbon.html.
+;; and up. See also https://www.eff.org/blueribbon.html.
;; For many years, emacs has included a program called Spook. This program
;; adds a series of "keywords" to email just before it goes out. On the
@@ -113,13 +113,11 @@
(defcustom bruce-phrases-file "~/bruce.lines"
"Keep your favorite phrases here."
- :type 'file
- :group 'bruce)
+ :type 'file)
(defcustom bruce-phrase-default-count 15
"Default number of phrases to insert."
- :type 'integer
- :group 'bruce)
+ :type 'integer)
;;;###autoload
(defun bruce ()
diff --git a/lisp/obsolete/cc-compat.el b/lisp/obsolete/cc-compat.el
index 96b036e892c..037a8e9e87c 100644
--- a/lisp/obsolete/cc-compat.el
+++ b/lisp/obsolete/cc-compat.el
@@ -1,4 +1,4 @@
-;;; cc-compat.el --- cc-mode compatibility with c-mode.el confusion
+;;; cc-compat.el --- cc-mode compatibility with c-mode.el confusion -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -156,7 +156,7 @@ This is in addition to c-continued-statement-offset.")
(if bracep 0 c-indent-level)))))
-(defun cc-substatement-open-offset (langelem)
+(defun cc-substatement-open-offset (_langelem)
(+ c-continued-statement-offset c-continued-brace-offset))
diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el
index 00b28b60156..619bc06122b 100644
--- a/lisp/obsolete/cl-compat.el
+++ b/lisp/obsolete/cl-compat.el
@@ -1,4 +1,4 @@
-;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility)
+;;; cl-compat.el --- Common Lisp extensions for GNU Emacs Lisp (compatibility) -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
@@ -46,31 +46,23 @@
;;; Code:
-;; This used to be:
-;; (or (featurep 'cl) (require 'cl))
-;; which just has the effect of fooling the byte-compiler into not
-;; loading cl when compiling. However, that leads to some bogus
-;; compiler warnings. Loading cl when compiling cannot do any harm,
-;; because for a long time bootstrap-emacs contained 'cl, due to being
-;; dumped from uncompiled files that eval-when-compile'd cl. So every
-;; file was compiled with 'cl loaded.
-(require 'cl)
+(require 'cl-lib)
;;; Keyword routines not supported by new package.
(defmacro defkeyword (x &optional doc)
- (list* 'defconst x (list 'quote x) (and doc (list doc))))
+ (cl-list* 'defconst x (list 'quote x) (and doc (list doc))))
(defun keyword-of (sym)
(or (keywordp sym) (keywordp (intern (format ":%s" sym)))))
-;;; Multiple values. Note that the new package uses a different
-;;; convention for multiple values. The following definitions
-;;; emulate the old convention; all function names have been changed
-;;; by capitalizing the first letter: Values, Multiple-value-*,
-;;; to avoid conflict with the new-style definitions in cl-macs.
+;; Multiple values. Note that the new package uses a different
+;; convention for multiple values. The following definitions
+;; emulate the old convention; all function names have been changed
+;; by capitalizing the first letter: Values, Multiple-value-*,
+;; to avoid conflict with the new-style definitions in cl-macs.
(defvar *mvalues-values* nil)
@@ -79,7 +71,7 @@
(car val-forms))
(defun Values-list (val-forms)
- (apply 'values val-forms))
+ (apply #'cl-values val-forms))
(defmacro Multiple-value-list (form)
(list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form))
@@ -95,7 +87,7 @@
(defmacro Multiple-value-bind (vars form &rest body)
(declare (indent 2))
- (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
+ (cl-list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
(defmacro Multiple-value-setq (vars form)
(declare (indent 2))
@@ -103,16 +95,16 @@
(defmacro Multiple-value-prog1 (form &rest body)
(declare (indent 1))
- (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
+ (list 'prog1 form (cl-list* 'let '((*mvalues-values* nil)) body)))
;;; Routines for parsing keyword arguments.
(defun build-klist (arglist keys &optional allow-others)
- (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist))))
+ (let ((res (Multiple-value-call #'cl-mapcar 'cons (unzip-lists arglist))))
(or allow-others
- (let ((bad (set-difference (mapcar 'car res) keys)))
- (if bad (error "Bad keywords: %s not in %s" bad keys))))
+ (let ((bad (cl-set-difference (mapcar #'car res) keys)))
+ (if bad (error "Bad keywords: %s not in %s" bad keys))))
res))
(defun extract-from-klist (klist key &optional def)
@@ -131,15 +123,15 @@
(defun safe-idiv (a b)
(let* ((q (/ (abs a) (abs b)))
- (s (* (signum a) (signum b))))
+ (s (* (cl-signum a) (cl-signum b))))
(Values q (- a (* s q b)) s)))
;; Internal routines.
(defun pair-with-newsyms (oldforms)
- (let ((newsyms (mapcar (lambda (x) (make-symbol "--cl-var--")) oldforms)))
- (Values (mapcar* 'list newsyms oldforms) newsyms)))
+ (let ((newsyms (mapcar (lambda (_) (make-symbol "--cl-var--")) oldforms)))
+ (Values (cl-mapcar #'list newsyms oldforms) newsyms)))
(defun zip-lists (evens odds)
(cl-mapcan 'list evens odds))
@@ -151,7 +143,7 @@
(Values (nreverse e) (nreverse o))))
(defun reassemble-argslists (list)
- (let ((n (apply 'min (mapcar 'length list))) (res nil))
+ (let ((n (apply #'min (mapcar #'length list))) (res nil))
(while (>= (setq n (1- n)) 0)
(setq res (cons (mapcar (function (lambda (x) (elt x n))) list) res)))
res))
diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el
index ee4d9931ee9..09f9ab7b7f2 100644
--- a/lisp/obsolete/cl.el
+++ b/lisp/obsolete/cl.el
@@ -113,7 +113,7 @@
most-positive-float
;; custom-print-functions
))
- (defvaralias var (intern (format "cl-%s" var))))
+ (define-obsolete-variable-alias var (intern (format "cl-%s" var)) "27.1"))
(dolist (fun '(
(get* . cl-get)
@@ -291,7 +291,7 @@
))
(let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
(intern (format "cl-%s" fun)))))
- (defalias fun new)))
+ (define-obsolete-function-alias fun new "27.1")))
(defun cl--wrap-in-nil-block (fun &rest args)
`(cl-block nil ,(apply fun args)))
@@ -331,7 +331,7 @@ The two cases that are handled are:
(cddr f))))
(if (and cl-closure-vars
(cl--expr-contains-any body cl-closure-vars))
- (let* ((new (mapcar 'cl-gensym cl-closure-vars))
+ (let* ((new (mapcar #'cl-gensym cl-closure-vars))
(sub (cl-pairlis cl-closure-vars new)) (decls nil))
(while (or (stringp (car body))
(eq (car-safe (car body)) 'interactive))
@@ -438,7 +438,7 @@ definitions, or lack thereof).
(let ((func `(cl-function
(lambda ,(cadr x)
(cl-block ,(car x) ,@(cddr x))))))
- (when (cl--compiling-file)
+ (when (macroexp-compiling-p)
;; Bug#411. It would be nice to fix this.
(and (get (car x) 'byte-compile)
(error "Byte-compiling a redefinition of `%s' \
@@ -446,7 +446,7 @@ will not work - use `labels' instead" (symbol-name (car x))))
;; FIXME This affects the rest of the file, when it
;; should be restricted to the flet body.
(and (boundp 'byte-compile-function-environment)
- (push (cons (car x) (eval func))
+ (push (cons (car x) (eval func t))
byte-compile-function-environment)))
(list `(symbol-function ',(car x)) func)))
bindings)
@@ -630,10 +630,10 @@ You can replace this macro with `gv-letplace'."
;;; Additional compatibility code.
;; For names that were clean but really aren't needed any more.
-(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3")
+(define-obsolete-function-alias 'cl-macroexpand #'macroexpand "24.3")
(define-obsolete-variable-alias 'cl-macro-environment
'macroexpand-all-environment "24.3")
-(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3")
+(define-obsolete-function-alias 'cl-macroexpand-all #'macroexpand-all "24.3")
;;; Hash tables.
;; This is just kept for compatibility with code byte-compiled by Emacs-20.
@@ -652,22 +652,22 @@ You can replace this macro with `gv-letplace'."
(defvar cl-builtin-maphash (symbol-function 'maphash))
(make-obsolete-variable 'cl-builtin-maphash nil "24.3")
-(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3")
-(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3")
-(define-obsolete-function-alias 'cl-gethash 'gethash "24.3")
-(define-obsolete-function-alias 'cl-puthash 'puthash "24.3")
-(define-obsolete-function-alias 'cl-remhash 'remhash "24.3")
-(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3")
-(define-obsolete-function-alias 'cl-maphash 'maphash "24.3")
-(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3")
-(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3")
-(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3")
+(define-obsolete-function-alias 'cl-map-keymap #'map-keymap "24.3")
+(define-obsolete-function-alias 'cl-copy-tree #'copy-tree "24.3")
+(define-obsolete-function-alias 'cl-gethash #'gethash "24.3")
+(define-obsolete-function-alias 'cl-puthash #'puthash "24.3")
+(define-obsolete-function-alias 'cl-remhash #'remhash "24.3")
+(define-obsolete-function-alias 'cl-clrhash #'clrhash "24.3")
+(define-obsolete-function-alias 'cl-maphash #'maphash "24.3")
+(define-obsolete-function-alias 'cl-make-hash-table #'make-hash-table "24.3")
+(define-obsolete-function-alias 'cl-hash-table-p #'hash-table-p "24.3")
+(define-obsolete-function-alias 'cl-hash-table-count #'hash-table-count "24.3")
(define-obsolete-function-alias 'cl-map-keymap-recursively
- 'cl--map-keymap-recursively "24.3")
-(define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3")
-(define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3")
-(define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3")
+ #'cl--map-keymap-recursively "24.3")
+(define-obsolete-function-alias 'cl-map-intervals #'cl--map-intervals "24.3")
+(define-obsolete-function-alias 'cl-map-extents #'cl--map-overlays "24.3")
+(define-obsolete-function-alias 'cl-set-getf #'cl--set-getf "24.3")
(defun cl-maclisp-member (item list)
(declare (obsolete member "24.3"))
diff --git a/lisp/obsolete/complete.el b/lisp/obsolete/complete.el
index f377041db1c..1c1167db89b 100644
--- a/lisp/obsolete/complete.el
+++ b/lisp/obsolete/complete.el
@@ -1,4 +1,4 @@
-;;; complete.el --- partial completion mechanism plus other goodies
+;;; complete.el --- partial completion mechanism plus other goodies -*- lexical-binding: t; -*-
;; Copyright (C) 1990-1993, 1999-2021 Free Software Foundation, Inc.
@@ -102,14 +102,12 @@ If non-nil and non-t, the first character is taken literally only for file name
completion."
:type '(choice (const :tag "delimiter" nil)
(const :tag "literal" t)
- (other :tag "find-file" find-file))
- :group 'partial-completion)
+ (other :tag "find-file" find-file)))
(defcustom PC-meta-flag t
"If non-nil, TAB means PC completion and M-TAB means normal completion.
Otherwise, TAB means normal completion and M-TAB means Partial Completion."
- :type 'boolean
- :group 'partial-completion)
+ :type 'boolean)
(defcustom PC-word-delimiters "-_. "
"A string of characters treated as word delimiters for completion.
@@ -119,19 +117,16 @@ If `^' is in this string, it must not come first.
If `-' is in this string, it must come first or right after `]'.
In other words, if S is this string, then `[S]' must be a valid Emacs regular
expression (not containing character ranges like `a-z')."
- :type 'string
- :group 'partial-completion)
+ :type 'string)
(defcustom PC-include-file-path '("/usr/include" "/usr/local/include")
"A list of directories in which to look for include files.
If nil, means use the colon-separated path in the variable $INCPATH instead."
- :type '(repeat directory)
- :group 'partial-completion)
+ :type '(repeat directory))
(defcustom PC-disable-includes nil
"If non-nil, include-file support in \\[find-file] is disabled."
- :type 'boolean
- :group 'partial-completion)
+ :type 'boolean)
(defvar PC-default-bindings t
"If non-nil, default partial completion key bindings are suppressed.")
@@ -146,36 +141,36 @@ If nil, means use the colon-separated path in the variable $INCPATH instead."
(cond ((not bind)
;; These bindings are the default bindings. It would be better to
;; restore the previous bindings.
- (define-key read-expression-map "\e\t" 'lisp-complete-symbol)
+ (define-key read-expression-map "\e\t" #'completion-at-point)
- (define-key completion-map "\t" 'minibuffer-complete)
- (define-key completion-map " " 'minibuffer-complete-word)
- (define-key completion-map "?" 'minibuffer-completion-help)
+ (define-key completion-map "\t" #'minibuffer-complete)
+ (define-key completion-map " " #'minibuffer-complete-word)
+ (define-key completion-map "?" #'minibuffer-completion-help)
- (define-key must-match-map "\r" 'minibuffer-complete-and-exit)
- (define-key must-match-map "\n" 'minibuffer-complete-and-exit)
+ (define-key must-match-map "\r" #'minibuffer-complete-and-exit)
+ (define-key must-match-map "\n" #'minibuffer-complete-and-exit)
(define-key global-map [remap lisp-complete-symbol] nil))
(PC-default-bindings
- (define-key read-expression-map "\e\t" 'PC-lisp-complete-symbol)
+ (define-key read-expression-map "\e\t" #'PC-lisp-complete-symbol)
- (define-key completion-map "\t" 'PC-complete)
- (define-key completion-map " " 'PC-complete-word)
- (define-key completion-map "?" 'PC-completion-help)
+ (define-key completion-map "\t" #'PC-complete)
+ (define-key completion-map " " #'PC-complete-word)
+ (define-key completion-map "?" #'PC-completion-help)
- (define-key completion-map "\e\t" 'PC-complete)
- (define-key completion-map "\e " 'PC-complete-word)
- (define-key completion-map "\e\r" 'PC-force-complete-and-exit)
- (define-key completion-map "\e\n" 'PC-force-complete-and-exit)
- (define-key completion-map "\e?" 'PC-completion-help)
+ (define-key completion-map "\e\t" #'PC-complete)
+ (define-key completion-map "\e " #'PC-complete-word)
+ (define-key completion-map "\e\r" #'PC-force-complete-and-exit)
+ (define-key completion-map "\e\n" #'PC-force-complete-and-exit)
+ (define-key completion-map "\e?" #'PC-completion-help)
- (define-key must-match-map "\r" 'PC-complete-and-exit)
- (define-key must-match-map "\n" 'PC-complete-and-exit)
+ (define-key must-match-map "\r" #'PC-complete-and-exit)
+ (define-key must-match-map "\n" #'PC-complete-and-exit)
- (define-key must-match-map "\e\r" 'PC-complete-and-exit)
- (define-key must-match-map "\e\n" 'PC-complete-and-exit)
+ (define-key must-match-map "\e\r" #'PC-complete-and-exit)
+ (define-key must-match-map "\e\n" #'PC-complete-and-exit)
- (define-key global-map [remap lisp-complete-symbol] 'PC-lisp-complete-symbol)))))
+ (define-key global-map [remap lisp-complete-symbol] #'PC-lisp-complete-symbol)))))
(defvar PC-do-completion-end nil
"Internal variable used by `PC-do-completion'.")
@@ -212,14 +207,15 @@ 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."
- :global t :group 'partial-completion
+ :global t
;; Deal with key bindings...
(PC-bindings partial-completion-mode)
;; Deal with include file feature...
(cond ((not partial-completion-mode)
- (remove-hook 'find-file-not-found-functions 'PC-look-for-include-file))
+ (remove-hook 'find-file-not-found-functions
+ #'PC-look-for-include-file))
((not PC-disable-includes)
- (add-hook 'find-file-not-found-functions 'PC-look-for-include-file)))
+ (add-hook 'find-file-not-found-functions #'PC-look-for-include-file)))
;; Adjust the completion selection in *Completion* buffers to the way
;; we work. The default minibuffer completion code only completes the
;; text before point and leaves the text after point alone (new in
@@ -229,9 +225,9 @@ second TAB brings up the `*Completions*' buffer."
;; to trick choose-completion into replacing the whole minibuffer text
;; rather than only the text before point. --Stef
(funcall
- (if partial-completion-mode 'add-hook 'remove-hook)
+ (if partial-completion-mode #'add-hook #'remove-hook)
'choose-completion-string-functions
- (lambda (choice buffer &rest ignored)
+ (lambda (_choice buffer &rest _)
;; When completing M-: (lisp- ) with point before the ), it is
;; not appropriate to go to point-max (unlike the filename case).
(if (and (not PC-goto-end)
@@ -431,6 +427,8 @@ of `minibuffer-completion-table' and the minibuffer contents.")
(let ((result (try-completion string alist predicate)))
(if (eq result t) string result)))
+(defvar completion-base-size)
+
;; TODO document MODE magic...
(defun PC-do-completion (&optional mode beg end goto-end)
"Internal function to do the work of partial completion.
@@ -646,7 +644,7 @@ GOTO-END is non-nil, however, it instead replaces up to END."
(when (string-match regex x)
(push x p)))
(setq basestr (try-completion "" p)))
- (setq basestr (mapconcat 'list str "-"))
+ (setq basestr (mapconcat #'list str "-"))
(delete-region beg end)
(setq end (+ beg (length basestr)))
(insert basestr))))
@@ -670,7 +668,7 @@ GOTO-END is non-nil, however, it instead replaces up to END."
(setq PC-ignored-regexp
(concat "\\("
(mapconcat
- 'regexp-quote
+ #'regexp-quote
(setq PC-ignored-extensions
completion-ignored-extensions)
"\\|")
@@ -813,7 +811,7 @@ GOTO-END is non-nil, however, it instead replaces up to END."
(eq mode 'help))
(let ((prompt-end (minibuffer-prompt-end)))
(with-output-to-temp-buffer "*Completions*"
- (display-completion-list (sort helpposs 'string-lessp))
+ (display-completion-list (sort helpposs #'string-lessp))
(setq PC-do-completion-end end
PC-goto-end goto-end)
(with-current-buffer standard-output
@@ -1091,7 +1089,7 @@ absolute rather than relative to some directory on the SEARCH-PATH."
file-lists))))
(setq search-path (cdr search-path))))
;; Compress out duplicates while building complete list (slloooow!)
- (let ((sorted (sort (apply 'nconc file-lists)
+ (let ((sorted (sort (apply #'nconc file-lists)
(lambda (x y) (not (string-lessp x y)))))
compressed)
(while sorted
diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el
index 91ff899c84d..69bf3ed12bc 100644
--- a/lisp/obsolete/crisp.el
+++ b/lisp/obsolete/crisp.el
@@ -1,4 +1,4 @@
-;;; crisp.el --- CRiSP/Brief Emacs emulator
+;;; crisp.el --- CRiSP/Brief Emacs emulator -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1999, 2001-2021 Free Software Foundation, Inc.
@@ -66,63 +66,63 @@
(defvar crisp-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [(f1)] 'other-window)
+ (define-key map [(f1)] #'other-window)
- (define-key map [(f2) (down)] 'enlarge-window)
- (define-key map [(f2) (left)] 'shrink-window-horizontally)
- (define-key map [(f2) (right)] 'enlarge-window-horizontally)
- (define-key map [(f2) (up)] 'shrink-window)
- (define-key map [(f3) (down)] 'split-window-below)
- (define-key map [(f3) (right)] 'split-window-right)
+ (define-key map [(f2) (down)] #'enlarge-window)
+ (define-key map [(f2) (left)] #'shrink-window-horizontally)
+ (define-key map [(f2) (right)] #'enlarge-window-horizontally)
+ (define-key map [(f2) (up)] #'shrink-window)
+ (define-key map [(f3) (down)] #'split-window-below)
+ (define-key map [(f3) (right)] #'split-window-right)
- (define-key map [(f4)] 'delete-window)
- (define-key map [(control f4)] 'delete-other-windows)
+ (define-key map [(f4)] #'delete-window)
+ (define-key map [(control f4)] #'delete-other-windows)
- (define-key map [(f5)] 'search-forward-regexp)
- (define-key map [(f19)] 'search-forward-regexp)
- (define-key map [(meta f5)] 'search-backward-regexp)
+ (define-key map [(f5)] #'search-forward-regexp)
+ (define-key map [(f19)] #'search-forward-regexp)
+ (define-key map [(meta f5)] #'search-backward-regexp)
- (define-key map [(f6)] 'query-replace)
+ (define-key map [(f6)] #'query-replace)
- (define-key map [(f7)] 'start-kbd-macro)
- (define-key map [(meta f7)] 'end-kbd-macro)
+ (define-key map [(f7)] #'start-kbd-macro)
+ (define-key map [(meta f7)] #'end-kbd-macro)
- (define-key map [(f8)] 'call-last-kbd-macro)
- (define-key map [(meta f8)] 'save-kbd-macro)
+ (define-key map [(f8)] #'call-last-kbd-macro)
+ ;;(define-key map [(meta f8)] #'save-kbd-macro) ;FIXME:Unknown command?
- (define-key map [(f9)] 'find-file)
- (define-key map [(meta f9)] 'load-library)
+ (define-key map [(f9)] #'find-file)
+ (define-key map [(meta f9)] #'load-library)
- (define-key map [(f10)] 'execute-extended-command)
- (define-key map [(meta f10)] 'compile)
+ (define-key map [(f10)] #'execute-extended-command)
+ (define-key map [(meta f10)] #'compile)
- (define-key map [(SunF37)] 'kill-buffer)
- (define-key map [(kp-add)] 'crisp-copy-line)
- (define-key map [(kp-subtract)] 'crisp-kill-line)
+ (define-key map [(SunF37)] #'kill-buffer)
+ (define-key map [(kp-add)] #'crisp-copy-line)
+ (define-key map [(kp-subtract)] #'crisp-kill-line)
;; just to cover all the bases (GNU Emacs, for instance)
- (define-key map [(f24)] 'crisp-kill-line)
- (define-key map [(insert)] 'crisp-yank-clipboard)
- (define-key map [(f16)] 'crisp-set-clipboard) ; copy on Sun5 kbd
- (define-key map [(f20)] 'crisp-kill-region) ; cut on Sun5 kbd
- (define-key map [(f18)] 'crisp-yank-clipboard) ; paste on Sun5 kbd
+ (define-key map [(f24)] #'crisp-kill-line)
+ (define-key map [(insert)] #'crisp-yank-clipboard)
+ (define-key map [(f16)] #'crisp-set-clipboard) ; copy on Sun5 kbd
+ (define-key map [(f20)] #'crisp-kill-region) ; cut on Sun5 kbd
+ (define-key map [(f18)] #'crisp-yank-clipboard) ; paste on Sun5 kbd
- (define-key map [(control f)] 'fill-paragraph-or-region)
+ ;; (define-key map [(control f)] #'fill-paragraph-or-region)
(define-key map [(meta d)] (lambda ()
(interactive)
(beginning-of-line) (kill-line)))
- (define-key map [(meta e)] 'find-file)
- (define-key map [(meta g)] 'goto-line)
- (define-key map [(meta h)] 'help)
- (define-key map [(meta i)] 'overwrite-mode)
- (define-key map [(meta j)] 'bookmark-jump)
- (define-key map [(meta l)] 'crisp-mark-line)
- (define-key map [(meta m)] 'set-mark-command)
- (define-key map [(meta n)] 'bury-buffer)
- (define-key map [(meta p)] 'crisp-unbury-buffer)
- (define-key map [(meta u)] 'undo)
- (define-key map [(f14)] 'undo)
- (define-key map [(meta w)] 'save-buffer)
- (define-key map [(meta x)] 'crisp-meta-x-wrapper)
+ (define-key map [(meta e)] #'find-file)
+ (define-key map [(meta g)] #'goto-line)
+ (define-key map [(meta h)] #'help)
+ (define-key map [(meta i)] #'overwrite-mode)
+ (define-key map [(meta j)] #'bookmark-jump)
+ (define-key map [(meta l)] #'crisp-mark-line)
+ (define-key map [(meta m)] #'set-mark-command)
+ (define-key map [(meta n)] #'bury-buffer)
+ (define-key map [(meta p)] #'crisp-unbury-buffer)
+ (define-key map [(meta u)] #'undo)
+ (define-key map [(f14)] #'undo)
+ (define-key map [(meta w)] #'save-buffer)
+ (define-key map [(meta x)] #'crisp-meta-x-wrapper)
(define-key map [(meta ?0)] (lambda ()
(interactive)
(bookmark-set "0")))
@@ -154,21 +154,21 @@
(interactive)
(bookmark-set "9")))
- (define-key map [(shift delete)] 'kill-word)
- (define-key map [(shift backspace)] 'backward-kill-word)
- (define-key map [(control left)] 'backward-word)
- (define-key map [(control right)] 'forward-word)
+ (define-key map [(shift delete)] #'kill-word)
+ (define-key map [(shift backspace)] #'backward-kill-word)
+ (define-key map [(control left)] #'backward-word)
+ (define-key map [(control right)] #'forward-word)
- (define-key map [(home)] 'crisp-home)
+ (define-key map [(home)] #'crisp-home)
(define-key map [(control home)] (lambda ()
(interactive)
(move-to-window-line 0)))
- (define-key map [(meta home)] 'beginning-of-line)
- (define-key map [(end)] 'crisp-end)
+ (define-key map [(meta home)] #'beginning-of-line)
+ (define-key map [(end)] #'crisp-end)
(define-key map [(control end)] (lambda ()
(interactive)
(move-to-window-line -1)))
- (define-key map [(meta end)] 'end-of-line)
+ (define-key map [(meta end)] #'end-of-line)
map)
"Local keymap for CRiSP emulation mode.
All the bindings are done here instead of globally to try and be
@@ -179,8 +179,7 @@ nice to the world.")
(defcustom crisp-mode-mode-line-string " *CRiSP*"
"String to display in the mode line when CRiSP emulation mode is enabled."
- :type 'string
- :group 'crisp)
+ :type 'string)
;;;###autoload
(defcustom crisp-mode nil
@@ -190,20 +189,18 @@ indicates CRiSP mode is enabled.
Setting this variable directly does not take effect;
use either M-x customize or the function `crisp-mode'."
- :set (lambda (symbol value) (crisp-mode (if value 1 0)))
- :initialize 'custom-initialize-default
+ :set (lambda (_symbol value) (crisp-mode (if value 1 0)))
+ :initialize #'custom-initialize-default
:require 'crisp
:version "20.4"
- :type 'boolean
- :group 'crisp)
+ :type 'boolean)
(defcustom crisp-override-meta-x t
"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."
- :type 'boolean
- :group 'crisp)
+ :type 'boolean)
(defcustom crisp-load-scroll-all nil
"Controls loading of the Scroll Lock in the CRiSP emulator.
@@ -212,18 +209,15 @@ package when enabling the CRiSP emulator.
If this variable is nil when you start the CRiSP emulator, it
does not load the scroll-all package."
- :type 'boolean
- :group 'crisp)
+ :type 'boolean)
(defcustom crisp-load-hook nil
"Hooks to run after loading the CRiSP emulator package."
- :type 'hook
- :group 'crisp)
+ :type 'hook)
(defcustom crisp-mode-hook nil
"Hook run by the function `crisp-mode'."
- :type 'hook
- :group 'crisp)
+ :type 'hook)
(defconst crisp-version "1.34"
"The version of the CRiSP emulator.")
@@ -370,11 +364,11 @@ normal CRiSP binding) and when it is nil M-x will run
(if crisp-load-scroll-all
(require 'scroll-all))
(if (featurep 'scroll-all)
- (define-key crisp-mode-map [(meta f1)] 'scroll-all-mode))))
+ (define-key crisp-mode-map [(meta f1)] #'scroll-all-mode))))
;; People might use Apropos on `brief'.
;;;###autoload
-(defalias 'brief-mode 'crisp-mode)
+(defalias 'brief-mode #'crisp-mode)
(run-hooks 'crisp-load-hook)
(provide 'crisp)
diff --git a/lisp/obsolete/cust-print.el b/lisp/obsolete/cust-print.el
index 4f75d1c5523..01fcd38199c 100644
--- a/lisp/obsolete/cust-print.el
+++ b/lisp/obsolete/cust-print.el
@@ -1,4 +1,4 @@
-;;; cust-print.el --- handles print-level and print-circle
+;;; cust-print.el --- handles print-level and print-circle -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
@@ -118,9 +118,6 @@
;; Emacs 18 doesn't have defalias.
;; Provide def for byte compiler.
-(eval-and-compile
- (or (fboundp 'defalias) (fset 'defalias 'fset)))
-
;; Variables:
;;=========================================================
@@ -141,8 +138,7 @@ If non-nil, components at levels equal to or greater than `print-level'
are printed simply as `#'. The object to be printed is at level 0,
and if the object is a list or vector, its top-level components are at
level 1."
- :type '(choice (const nil) integer)
- :group 'cust-print)
+ :type '(choice (const nil) integer))
(defcustom print-circle nil
@@ -156,18 +152,13 @@ If nil, printing proceeds recursively and may lead to
If non-nil, shared substructures anywhere in the structure are printed
with `#N=' before the first occurrence (in the order of the print
representation) and `#N#' in place of each subsequent occurrence,
-where N is a positive decimal integer.
-
-There is no way to read this representation in standard Emacs,
-but if you need to do so, try the cl-read.el package."
- :type 'boolean
- :group 'cust-print)
+where N is a positive decimal integer."
+ :type 'boolean)
(defcustom custom-print-vectors nil
"Non-nil if printing of vectors should obey `print-level' and `print-length'."
- :type 'boolean
- :group 'cust-print)
+ :type 'boolean)
;; Custom printers
@@ -204,7 +195,7 @@ Any pair that has the same PREDICATE is first removed."
(cust-print-update-custom-printers))
-(defun cust-print-use-custom-printer (object)
+(defun cust-print-use-custom-printer (_object)
;; Default function returns nil.
nil)
@@ -234,11 +225,11 @@ Any pair that has the same PREDICATE is first removed."
(defalias (car symbol-pair)
(symbol-function (car (cdr symbol-pair)))))
-(defun cust-print-original-princ (object &optional stream)) ; dummy def
+(defun cust-print-original-princ (_object &optional _stream) nil) ; dummy def
;; Save emacs routines.
(if (not (fboundp 'cust-print-original-prin1))
- (mapc 'cust-print-set-function-cell
+ (mapc #'cust-print-set-function-cell
'((cust-print-original-prin1 prin1)
(cust-print-original-princ princ)
(cust-print-original-print print)
@@ -246,14 +237,15 @@ Any pair that has the same PREDICATE is first removed."
(cust-print-original-format format)
(cust-print-original-message message)
(cust-print-original-error error))))
-
+(declare-function cust-print-original-format "cust-print")
+(declare-function cust-print-original-message "cust-print")
(defun custom-print-install ()
"Replace print functions with general, customizable, Lisp versions.
The Emacs subroutines are saved away, and you can reinstall them
by running `custom-print-uninstall'."
(interactive)
- (mapc 'cust-print-set-function-cell
+ (mapc #'cust-print-set-function-cell
'((prin1 custom-prin1)
(princ custom-princ)
(print custom-print)
@@ -267,7 +259,7 @@ by running `custom-print-uninstall'."
(defun custom-print-uninstall ()
"Reset print functions to their Emacs subroutines."
(interactive)
- (mapc 'cust-print-set-function-cell
+ (mapc #'cust-print-set-function-cell
'((prin1 cust-print-original-prin1)
(princ cust-print-original-princ)
(print cust-print-original-print)
@@ -278,22 +270,20 @@ by running `custom-print-uninstall'."
))
t)
-(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
+(defalias 'custom-print-funcs-installed-p #'custom-print-installed-p)
(defun custom-print-installed-p ()
"Return t if custom-print is currently installed, nil otherwise."
(eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
-(put 'with-custom-print-funcs 'edebug-form-spec '(body))
-(put 'with-custom-print 'edebug-form-spec '(body))
-
-(defalias 'with-custom-print-funcs 'with-custom-print)
(defmacro with-custom-print (&rest body)
"Temporarily install the custom print package while executing BODY."
+ (declare (debug t))
`(unwind-protect
(progn
(custom-print-install)
,@body)
(custom-print-uninstall)))
+(defalias 'with-custom-print-funcs #'with-custom-print)
;; Lisp replacements for prin1 and princ, and for some subrs that use them
@@ -372,7 +362,7 @@ vector, or symbol args. The format specification for such args should
be `%s' in any case, so a string argument will also work. The string
is generated with `custom-prin1-to-string', which quotes quotable
characters."
- (apply 'cust-print-original-format fmt
+ (apply #'cust-print-original-format fmt
(mapcar (function (lambda (arg)
(if (or (listp arg) (vectorp arg) (symbolp arg))
(custom-prin1-to-string arg)
@@ -396,7 +386,7 @@ See `custom-format' for the details."
;; because the echo area requires special handling
;; to avoid duplicating the output.
;; cust-print-original-message does it right.
- (apply 'cust-print-original-message fmt
+ (apply #'cust-print-original-message fmt
(mapcar (function (lambda (arg)
(if (or (listp arg) (vectorp arg) (symbolp arg))
(custom-prin1-to-string arg)
@@ -409,7 +399,7 @@ See `custom-format' for the details."
This is the custom-print replacement for the standard `error'.
See `custom-format' for the details."
- (signal 'error (list (apply 'custom-format fmt args))))
+ (signal 'error (list (apply #'custom-format fmt args))))
@@ -420,9 +410,9 @@ See `custom-format' for the details."
(defvar circle-table)
(defvar cust-print-current-level)
-(defun cust-print-original-printer (object)) ; One of the standard printers.
-(defun cust-print-low-level-prin (object)) ; Used internally.
-(defun cust-print-prin (object)) ; Call this to print recursively.
+(defun cust-print-original-printer (_object) nil) ; One of the standard printers.
+(defun cust-print-low-level-prin (_object) nil) ; Used internally.
+(defun cust-print-prin (_object) nil) ; Call this to print recursively.
(defun cust-print-top-level (object stream emacs-printer)
;; Set up for printing.
diff --git a/lisp/erc/erc-compat.el b/lisp/obsolete/erc-compat.el
index 1e8958fee18..9972e927e61 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/obsolete/erc-compat.el
@@ -1,10 +1,11 @@
-;;; erc-compat.el --- ERC compatibility code for XEmacs
+;;; erc-compat.el --- ERC compatibility code for XEmacs -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; URL: https://www.emacswiki.org/emacs/ERC
+;; Obsolete-since: 28.1
;; This file is part of GNU Emacs.
@@ -30,8 +31,7 @@
(require 'format-spec)
;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
-(defalias 'erc-define-minor-mode 'define-minor-mode)
-(put 'erc-define-minor-mode 'edebug-form-spec 'define-minor-mode)
+(defalias 'erc-define-minor-mode #'define-minor-mode)
(defun erc-decode-coding-string (s coding-system)
"Decode S using CODING-SYSTEM."
@@ -43,12 +43,12 @@ Return the same string, if the encoding operation is trivial.
See `erc-encoding-coding-alist'."
(encode-coding-string s coding-system t))
-(defalias 'erc-propertize 'propertize)
-(defalias 'erc-view-mode-enter 'view-mode-enter)
+(define-obsolete-function-alias 'erc-propertize #'propertize "28.1")
+(define-obsolete-function-alias 'erc-view-mode-enter #'view-mode-enter "28.1")
(autoload 'help-function-arglist "help-fns")
-(defalias 'erc-function-arglist 'help-function-arglist)
-(defalias 'erc-delete-dups 'delete-dups)
-(defalias 'erc-replace-regexp-in-string 'replace-regexp-in-string)
+(define-obsolete-function-alias 'erc-function-arglist #'help-function-arglist "28.1")
+(define-obsolete-function-alias 'erc-delete-dups #'delete-dups "28.1")
+(define-obsolete-function-alias 'erc-replace-regexp-in-string #'replace-regexp-in-string "28.1")
(defun erc-set-write-file-functions (new-val)
(set (make-local-variable 'write-file-functions) new-val))
@@ -72,17 +72,19 @@ are placed.
Note that this should end with a directory separator.")
(defun erc-replace-match-subexpression-in-string
- (newtext string match subexp start &optional fixedcase literal)
+ (newtext string _match subexp _start &optional fixedcase literal)
"Replace the subexpression SUBEXP of the last match in STRING with NEWTEXT.
MATCH is the text which matched the subexpression (see `match-string').
START is the beginning position of the last match (see `match-beginning').
See `replace-match' for explanations of FIXEDCASE and LITERAL."
(replace-match newtext fixedcase literal string subexp))
-(defalias 'erc-with-selected-window 'with-selected-window)
-(defalias 'erc-cancel-timer 'cancel-timer)
-(defalias 'erc-make-obsolete 'make-obsolete)
-(defalias 'erc-make-obsolete-variable 'make-obsolete-variable)
+(define-obsolete-function-alias 'erc-with-selected-window
+ #'with-selected-window "28.1")
+(define-obsolete-function-alias 'erc-cancel-timer #'cancel-timer "28.1")
+(define-obsolete-function-alias 'erc-make-obsolete #'make-obsolete "28.1")
+(define-obsolete-function-alias 'erc-make-obsolete-variable
+ #'make-obsolete-variable "28.1")
;; Provide a simpler replacement for `member-if'
(defun erc-member-if (predicate list)
diff --git a/lisp/obsolete/erc-hecomplete.el b/lisp/obsolete/erc-hecomplete.el
index f849dba2a14..36b08d56f7b 100644
--- a/lisp/obsolete/erc-hecomplete.el
+++ b/lisp/obsolete/erc-hecomplete.el
@@ -1,10 +1,10 @@
-;;; erc-hecomplete.el --- Provides Nick name completion for ERC
+;;; erc-hecomplete.el --- Provides Nick name completion for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
;; Inc.
;; Author: Alex Schroeder <alex@gnu.org>
-;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcCompletion
+;; URL: https://www.emacswiki.org/cgi-bin/wiki.pl?ErcCompletion
;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
@@ -39,8 +39,8 @@
;;;###autoload (autoload 'erc-hecomplete-mode "erc-hecomplete" nil t)
(define-erc-module hecomplete nil
"Complete nick at point."
- ((add-hook 'erc-complete-functions 'erc-hecomplete))
- ((remove-hook 'erc-complete-functions 'erc-hecomplete)))
+ ((add-hook 'erc-complete-functions #'erc-hecomplete))
+ ((remove-hook 'erc-complete-functions #'erc-hecomplete)))
(defun erc-hecomplete ()
"Complete nick at point.
@@ -70,15 +70,13 @@ or you may use an arbitrary lisp expression."
erc-nick-completion-exclude-myself)
(repeat :tag "List" (string :tag "Nick"))
function
- sexp)
- :group 'erc-hecomplete)
+ sexp))
(defcustom erc-nick-completion-ignore-case t
"Non-nil means don't consider case significant in nick completion.
Case will be automatically corrected when non-nil.
For instance if you type \"dely TAB\" the word completes and changes to
\"delYsid\"."
- :group 'erc-hecomplete
:type 'boolean)
(defun erc-nick-completion-exclude-myself ()
@@ -95,7 +93,6 @@ typing \"f o TAB\" will directly give you foobar. Use this with
(defcustom erc-nick-completion-postfix ": "
"When `erc-complete' is used in the first word after the prompt,
add this string when a unique expansion was found."
- :group 'erc-hecomplete
:type 'string)
(defun erc-command-list ()
diff --git a/lisp/obsolete/eudcb-ph.el b/lisp/obsolete/eudcb-ph.el
index c7212e3fdb7..187879ce2f7 100644
--- a/lisp/obsolete/eudcb-ph.el
+++ b/lisp/obsolete/eudcb-ph.el
@@ -1,4 +1,4 @@
-;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend
+;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -69,7 +69,7 @@ defaulting to `eudc-default-return-attributes'."
query
" "))
(if return-fields
- (concat " return " (mapconcat 'symbol-name return-fields " ")))))
+ (concat " return " (mapconcat #'symbol-name return-fields " ")))))
(and (> (length request) 6)
(eudc-ph-do-request request)
(eudc-ph-parse-query-result return-fields))))
@@ -189,7 +189,7 @@ SERVER is either a string naming the server or a list (NAME PORT)."
(with-current-buffer (process-buffer process)
(eudc-ph-send-command process "quit")
(eudc-ph-read-response process)
- (run-at-time 2 nil 'delete-process process)))
+ (run-at-time 2 nil #'delete-process process)))
(defun eudc-ph-send-command (process command)
(goto-char (point-max))
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index 8848c89c62f..960233d5627 100644
--- a/lisp/obsolete/fast-lock.el
+++ b/lisp/obsolete/fast-lock.el
@@ -1,4 +1,4 @@
-;;; fast-lock.el --- automagic text properties caching for fast Font Lock mode
+;;; fast-lock.el --- automagic text properties caching for fast Font Lock mode -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1998, 2001-2021 Free Software Foundation, Inc.
@@ -190,18 +190,6 @@
(defvar font-lock-face-list)
(eval-when-compile
- ;; 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
- (when (and (not modified) (buffer-modified-p))
- (set-buffer-modified-p nil))))
- (put 'save-buffer-state 'lisp-indent-function 1)
;;
;; We use this to verify that a face should be saved.
(defmacro fast-lock-save-facep (face)
@@ -244,8 +232,7 @@ for buffers in Rmail mode, and size is irrelevant otherwise."
(symbol :tag "name"))
(radio :tag "Size"
(const :tag "none" nil)
- (integer :tag "size")))))
- :group 'fast-lock)
+ (integer :tag "size"))))))
(defcustom fast-lock-cache-directories '("~/.emacs-flc")
; - `internal', keep each file's Font Lock cache file in the same file.
@@ -271,8 +258,7 @@ to avoid the possibility of using the cache of another user."
:type '(repeat (radio (directory :tag "directory")
(cons :tag "Matching"
(regexp :tag "regexp")
- (directory :tag "directory"))))
- :group 'fast-lock)
+ (directory :tag "directory")))))
(put 'fast-lock-cache-directories 'risky-local-variable t)
(defcustom fast-lock-save-events '(kill-buffer kill-emacs)
@@ -282,23 +268,20 @@ If concurrent editing sessions use the same associated cache file for a file's
buffer, then you should add `save-buffer' to this list."
:type '(set (const :tag "buffer saving" save-buffer)
(const :tag "buffer killing" kill-buffer)
- (const :tag "emacs killing" kill-emacs))
- :group 'fast-lock)
+ (const :tag "emacs killing" kill-emacs)))
(defcustom fast-lock-save-others t
"If non-nil, save Font Lock cache files irrespective of file owner.
If nil, means only buffer files known to be owned by you can have associated
Font Lock cache files saved. Ownership may be unknown for networked files."
- :type 'boolean
- :group 'fast-lock)
+ :type 'boolean)
(defcustom fast-lock-verbose font-lock-verbose
"If non-nil, means show status messages for cache processing.
If a number, only buffers greater than this size have processing messages."
:type '(choice (const :tag "never" nil)
(other :tag "always" t)
- (integer :tag "size"))
- :group 'fast-lock)
+ (integer :tag "size")))
(defvar fast-lock-save-faces
(when (featurep 'xemacs)
@@ -455,8 +438,7 @@ See `fast-lock-mode'."
;; Flag so that a cache will be saved later even if the file is never saved.
(setq fast-lock-cache-timestamp nil))
-(defalias 'fast-lock-after-unfontify-buffer
- 'ignore)
+(defalias 'fast-lock-after-unfontify-buffer #'ignore)
;; Miscellaneous Functions:
@@ -473,7 +455,7 @@ See `fast-lock-mode'."
(defun fast-lock-save-caches-before-kill-emacs ()
;; Do `fast-lock-save-cache's if `kill-emacs' is on `fast-lock-save-events'.
(when (memq 'kill-emacs fast-lock-save-events)
- (mapcar 'fast-lock-save-cache (buffer-list))))
+ (mapcar #'fast-lock-save-cache (buffer-list))))
(defun fast-lock-cache-directory (directory create)
"Return usable directory based on DIRECTORY.
@@ -534,7 +516,7 @@ See `fast-lock-cache-directory'."
(function (lambda (c) (or (cdr (assq c chars-alist)) (list c))))))
(concat
(file-name-as-directory (expand-file-name directory))
- (mapconcat 'char-to-string (apply 'append (mapcar mapchars bufile)) "")
+ (mapconcat #'char-to-string (apply #'append (mapcar mapchars bufile)) "")
".flc"))))
;; Font Lock Cache Processing Functions:
@@ -581,7 +563,7 @@ See `fast-lock-cache-directory'."
(defun fast-lock-cache-data (version timestamp
syntactic-keywords syntactic-properties
keywords face-properties
- &rest ignored)
+ &rest _ignored)
;; Find value of syntactic keywords in case it is a symbol.
(setq font-lock-syntactic-keywords (font-lock-eval-keywords
font-lock-syntactic-keywords))
@@ -708,86 +690,26 @@ See `fast-lock-get-face-properties'."
"Add `syntax-table' and `face' text properties to the current buffer.
Any existing `syntax-table' and `face' text properties are removed first.
See `fast-lock-get-face-properties'."
- (save-buffer-state (plist regions)
- (save-restriction
- (widen)
- (font-lock-unfontify-region (point-min) (point-max))
- ;;
- ;; Set the `syntax-table' property for each start/end region.
- (while syntactic-properties
- (setq plist (list 'syntax-table (car (car syntactic-properties)))
- regions (cdr (car syntactic-properties))
- syntactic-properties (cdr syntactic-properties))
- (while regions
- (add-text-properties (nth 0 regions) (nth 1 regions) plist)
- (setq regions (nthcdr 2 regions))))
- ;;
- ;; Set the `face' property for each start/end region.
- (while face-properties
- (setq plist (list 'face (car (car face-properties)))
- regions (cdr (car face-properties))
- face-properties (cdr face-properties))
- (while regions
- (add-text-properties (nth 0 regions) (nth 1 regions) plist)
- (setq regions (nthcdr 2 regions)))))))
+ (with-silent-modifications
+ (let ((inhibit-point-motion-hooks t))
+ (save-restriction
+ (widen)
+ (font-lock-unfontify-region (point-min) (point-max))
+ ;;
+ ;; Set the `syntax-table' property for each start/end region.
+ (pcase-dolist (`(,plist . ,regions) syntactic-properties)
+ (while regions
+ (add-text-properties (nth 0 regions) (nth 1 regions) plist)
+ (setq regions (nthcdr 2 regions))))
+ ;;
+ ;; Set the `face' property for each start/end region.
+ (pcase-dolist (`(,plist . ,regions) face-properties)
+ (while regions
+ (add-text-properties (nth 0 regions) (nth 1 regions) plist)
+ (setq regions (nthcdr 2 regions))))))))
;; Functions for XEmacs:
-(when (featurep 'xemacs)
- ;;
- ;; It would be better to use XEmacs' `map-extents' over extents with a
- ;; `font-lock' property, but `face' properties are on different extents.
- (defun fast-lock-get-face-properties ()
- "Return a list of `face' text properties in the current buffer.
-Each element of the list is of the form (VALUE START1 END1 START2 END2 ...)
-where VALUE is a `face' property value and STARTx and ENDx are positions.
-Only those `face' VALUEs in `fast-lock-save-faces' are returned."
- (save-restriction
- (widen)
- (let ((properties ()) cell)
- (map-extents
- (function (lambda (extent ignore)
- (let ((value (extent-face extent)))
- ;; We're only interested if it's one of `fast-lock-save-faces'.
- (when (and value (fast-lock-save-facep value))
- (let ((start (extent-start-position extent))
- (end (extent-end-position extent)))
- ;; Make or add to existing list of regions with the same
- ;; `face' property value.
- (if (setq cell (assoc value properties))
- (setcdr cell (cons start (cons end (cdr cell))))
- (push (list value start end) properties))))
- ;; Return nil to keep `map-extents' going.
- nil))))
- properties)))
- ;;
- ;; XEmacs does not support the `syntax-table' text property.
- (defalias 'fast-lock-get-syntactic-properties
- 'ignore)
- ;;
- ;; Make extents just like XEmacs' font-lock.el does.
- (defun fast-lock-add-properties (syntactic-properties face-properties)
- "Set `face' text properties in the current buffer.
-Any existing `face' text properties are removed first.
-See `fast-lock-get-face-properties'."
- (save-restriction
- (widen)
- (font-lock-unfontify-region (point-min) (point-max))
- ;; Set the `face' property, etc., for each start/end region.
- (while face-properties
- (let ((face (car (car face-properties)))
- (regions (cdr (car face-properties))))
- (while regions
- (font-lock-set-face (nth 0 regions) (nth 1 regions) face)
- (setq regions (nthcdr 2 regions)))
- (setq face-properties (cdr face-properties))))
- ;; XEmacs does not support the `syntax-table' text property.
- ))
- ;;
- ;; XEmacs 19.12 font-lock.el's `font-lock-fontify-buffer' runs a hook.
- (add-hook 'font-lock-after-fontify-buffer-hook
- 'fast-lock-after-fontify-buffer))
-
(unless (boundp 'font-lock-syntactic-keywords)
(defvar font-lock-syntactic-keywords nil))
@@ -795,14 +717,14 @@ See `fast-lock-get-face-properties'."
(defvar font-lock-inhibit-thing-lock nil))
(unless (fboundp 'font-lock-compile-keywords)
- (defalias 'font-lock-compile-keywords 'identity))
+ (defalias 'font-lock-compile-keywords #'identity))
(unless (fboundp 'font-lock-eval-keywords)
(defun font-lock-eval-keywords (keywords)
(if (symbolp keywords)
(font-lock-eval-keywords (if (fboundp keywords)
(funcall keywords)
- (eval keywords)))
+ (eval keywords t)))
keywords)))
(unless (fboundp 'font-lock-value-in-major-mode)
@@ -817,10 +739,10 @@ See `fast-lock-get-face-properties'."
;; Install ourselves:
-(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 'after-save-hook #'fast-lock-save-cache-after-save-file)
+(add-hook 'kill-buffer-hook #'fast-lock-save-cache-before-kill-buffer)
(unless noninteractive
- (add-hook 'kill-emacs-hook 'fast-lock-save-caches-before-kill-emacs))
+ (add-hook 'kill-emacs-hook #'fast-lock-save-caches-before-kill-emacs))
;;;###autoload
(when (fboundp 'add-minor-mode)
@@ -830,8 +752,6 @@ See `fast-lock-get-face-properties'."
(unless (assq 'fast-lock-mode minor-mode-alist)
(setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil)))))
-;; Provide ourselves:
-
(provide 'fast-lock)
;;; fast-lock.el ends here
diff --git a/lisp/obsolete/gs.el b/lisp/obsolete/gs.el
index 6ab3fc59380..5a82c6b05f0 100644
--- a/lisp/obsolete/gs.el
+++ b/lisp/obsolete/gs.el
@@ -1,4 +1,4 @@
-;;; gs.el --- interface to Ghostscript
+;;; gs.el --- interface to Ghostscript -*- lexical-binding: t; -*-
;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc.
@@ -205,7 +205,7 @@ the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful."
(gs-set-ghostview-window-prop frame spec img-width img-height)
(gs-set-ghostview-colors-window-prop frame pixel-colors)
(setenv "GHOSTVIEW" window-and-pixmap-id)
- (setq gs (apply 'start-process "gs" "*GS*" gs-program
+ (setq gs (apply #'start-process "gs" "*GS*" gs-program
(gs-options gs-device file)))
(set-process-query-on-exit-flag gs nil)
gs)
diff --git a/lisp/obsolete/gulp.el b/lisp/obsolete/gulp.el
index 0fbaa1cc4f8..6ec2f4f772c 100644
--- a/lisp/obsolete/gulp.el
+++ b/lisp/obsolete/gulp.el
@@ -1,4 +1,4 @@
-;;; gulp.el --- ask for updates for Lisp packages
+;;; gulp.el --- ask for updates for Lisp packages -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -37,18 +37,15 @@
(defcustom gulp-discard "^;+ *Maintainer: *\\(FSF\\|emacs-devel@gnu\\.org\\) *$"
"The regexp matching the packages not requiring the request for updates."
:version "24.4" ; added emacs-devel
- :type 'regexp
- :group 'gulp)
+ :type 'regexp)
(defcustom gulp-tmp-buffer "*gulp*"
"The name of the temporary buffer."
- :type 'string
- :group 'gulp)
+ :type 'string)
(defcustom gulp-max-len 2000
"Distance into a Lisp source file to scan for keywords."
- :type 'integer
- :group 'gulp)
+ :type 'integer)
(defcustom gulp-request-header
(concat
@@ -57,8 +54,7 @@ I'm going to start pretesting a new version of GNU Emacs soon, so I'd
like to ask if you have any updates for the Emacs packages you work on.
You're listed as the maintainer of the following package(s):\n\n")
"The starting text of a gulp message."
- :type 'string
- :group 'gulp)
+ :type 'string)
(defcustom gulp-request-end
(concat
@@ -75,8 +71,7 @@ of information to include.
Thanks.")
"The closing text in a gulp message."
- :type 'string
- :group 'gulp)
+ :type 'string)
(declare-function mail-subject "sendmail" ())
(declare-function mail-send "sendmail" ())
diff --git a/lisp/obsolete/html2text.el b/lisp/obsolete/html2text.el
index f01561bd12c..be0553cb3ae 100644
--- a/lisp/obsolete/html2text.el
+++ b/lisp/obsolete/html2text.el
@@ -1,4 +1,4 @@
-;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*-
+;;; html2text.el --- a simple html to plain text converter -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
diff --git a/lisp/obsolete/info-edit.el b/lisp/obsolete/info-edit.el
index c8a187c08ee..19958979a85 100644
--- a/lisp/obsolete/info-edit.el
+++ b/lisp/obsolete/info-edit.el
@@ -1,4 +1,4 @@
-;; info-edit.el --- Editing info files -*- lexical-binding:t -*-
+;;; info-edit.el --- Editing info files -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1992-2021 Free Software Foundation, Inc.
@@ -36,7 +36,7 @@
(define-obsolete-variable-alias 'Info-edit-map 'Info-edit-mode-map "24.1")
(defvar Info-edit-mode-map (let ((map (make-sparse-keymap)))
(set-keymap-parent map text-mode-map)
- (define-key map "\C-c\C-c" 'Info-cease-edit)
+ (define-key map "\C-c\C-c" #'Info-cease-edit)
map)
"Local keymap used within `e' command of Info.")
diff --git a/lisp/cedet/inversion.el b/lisp/obsolete/inversion.el
index 39e84b7ea7e..ac7749af5e8 100644
--- a/lisp/cedet/inversion.el
+++ b/lisp/obsolete/inversion.el
@@ -1,10 +1,11 @@
-;;; inversion.el --- When you need something in version XX.XX
+;;; inversion.el --- When you need something in version XX.XX -*- lexical-binding: t; -*-
-;;; Copyright (C) 2002-2003, 2005-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.3
;; Keywords: OO, lisp
+;; Obsolete-since: 28.1
;; This file is part of GNU Emacs.
@@ -222,7 +223,7 @@ not an indication of new features or bug fixes."
)))
(defun inversion-check-version (version incompatible-version
- minimum &rest reserved)
+ minimum &rest _reserved)
"Check that a given version meets the minimum requirement.
VERSION, INCOMPATIBLE-VERSION and MINIMUM are of similar format to
return entries of `inversion-decode-version', or a classic version
@@ -329,7 +330,7 @@ Return nil if everything is ok. Return an error string otherwise."
(t "Inversion version check failed."))))
(defun inversion-require (package version &optional file directory
- &rest reserved)
+ &rest _reserved)
"Declare that you need PACKAGE with at least VERSION.
PACKAGE might be found in FILE. (See `require'.)
Throws an error if VERSION is incompatible with what is installed.
@@ -349,7 +350,11 @@ Optional argument RESERVED is saved for later use."
;;;###autoload
(defun inversion-require-emacs (emacs-ver xemacs-ver sxemacs-ver)
"Declare that you need either EMACS-VER, XEMACS-VER or SXEMACS-ver.
-Only checks one based on which kind of Emacs is being run."
+Only checks one based on which kind of Emacs is being run.
+
+This function is obsolete; do this instead:
+ (when (version<= \"28.1\" emacs-version) ...)"
+ (declare (obsolete nil "28.1"))
(let ((err (inversion-test 'emacs
(cond ((featurep 'sxemacs)
sxemacs-ver)
@@ -449,7 +454,7 @@ If it is a URL, wget will be used for download.
Optional argument VERSION will restrict the list of available versions
to the file matching VERSION exactly, or nil."
;;DIRECTORY should also allow a URL:
-;; \"http://ftp1.sourceforge.net/PACKAGE\"
+;; \"https://ftp1.sourceforge.net/PACKAGE\"
;; but then I can get file listings easily.
(if (symbolp package) (setq package (symbol-name package)))
(directory-files directory t
@@ -520,31 +525,6 @@ The package should have VERSION available for download."
(copy-file (cdr (car files)) dest))))))
-;;; How we upgrade packages in Emacs has yet to be ironed out.
-
-;; (defun inversion-upgrade-package (package &optional directory)
-;; "Try to upgrade PACKAGE in DIRECTORY is available."
-;; (interactive "sPackage to upgrade: ")
-;; (if (stringp package) (setq package (intern package)))
-;; (if (not directory)
-;; ;; Hope that the package maintainer specified.
-;; (setq directory (symbol-value (or (intern-soft
-;; (concat (symbol-name package)
-;; "-url"))
-;; (intern-soft
-;; (concat (symbol-name package)
-;; "-directory"))))))
-;; (let ((files (inversion-locate-package-files-and-split
-;; package directory))
-;; (cver (inversion-package-version package))
-;; (newer nil))
-;; (mapc (lambda (f)
-;; (if (inversion-< cver (inversion-decode-version (car f)))
-;; (setq newer (cons f newer))))
-;; files)
-;; newer
-;; ))
-
(provide 'inversion)
;;; inversion.el ends here
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index a676f7aabc2..a630baf3543 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -1,4 +1,4 @@
-;;; iswitchb.el --- switch between buffers using substrings
+;;; iswitchb.el --- switch between buffers using substrings -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2000-2021 Free Software Foundation, Inc.
@@ -258,8 +258,7 @@
"Non-nil if searching of buffer names should ignore case.
If this is non-nil but the user input has any upper case letters, matching
is temporarily case sensitive."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-buffer-ignore
'("^ ")
@@ -267,8 +266,7 @@ is temporarily case sensitive."
For example, traditional behavior is not to list buffers whose names begin
with a space, for which the regexp is `^ '. See the source file for
example functions that filter buffer names."
- :type '(repeat (choice regexp function))
- :group 'iswitchb)
+ :type '(repeat (choice regexp function)))
(put 'iswitchb-buffer-ignore 'risky-local-variable t)
(defcustom iswitchb-max-to-show nil
@@ -277,8 +275,7 @@ If this value is N, and N is greater than the number of matching
buffers, the first N/2 and the last N/2 matching buffers are
shown. This can greatly speed up iswitchb if you have a
multitude of buffers open."
- :type '(choice (const :tag "Show all" nil) integer)
- :group 'iswitchb)
+ :type '(choice (const :tag "Show all" nil) integer))
(defcustom iswitchb-use-virtual-buffers nil
"If non-nil, refer to past buffers when none match.
@@ -289,8 +286,7 @@ enabled if this variable is configured to a non-nil value."
:set (function
(lambda (sym value)
(if value (recentf-mode 1))
- (set sym value)))
- :group 'iswitchb)
+ (set sym value))))
(defvar iswitchb-virtual-buffers nil)
@@ -299,8 +295,7 @@ enabled if this variable is configured to a non-nil value."
The most useful values are `iswitchb-completion-help', which pops up a
window with completion alternatives, or `iswitchb-next-match' or
`iswitchb-prev-match', which cycle the buffer list."
- :type 'hook
- :group 'iswitchb)
+ :type 'hook)
;; Examples for setting the value of iswitchb-buffer-ignore
;;(defun iswitchb-ignore-c-mode (name)
@@ -318,7 +313,7 @@ Possible values:
`otherwindow' Show new buffer in another window (same frame)
`display' Display buffer in another window without switching to it
`otherframe' Show new buffer in another frame
-`maybe-frame' If a buffer is visible in another frame, prompt to ask if you
+`maybe-frame' If a buffer is visible in another frame, prompt to ask if
you want to see the buffer in the same window of the current
frame or in the other frame.
`always-frame' If a buffer is visible in another frame, raise that
@@ -328,46 +323,38 @@ Possible values:
(const display)
(const otherframe)
(const maybe-frame)
- (const always-frame))
- :group 'iswitchb)
+ (const always-frame)))
(defcustom iswitchb-regexp nil
"Non-nil means that `iswitchb' will do regexp matching.
Value can be toggled within `iswitchb' using `iswitchb-toggle-regexp'."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-newbuffer t
"Non-nil means create new buffer if no buffer matches substring.
See also `iswitchb-prompt-newbuffer'."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-prompt-newbuffer t
"Non-nil means prompt user to confirm before creating new buffer.
See also `iswitchb-newbuffer'."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-use-faces t
"Non-nil means use font-lock faces for showing first match."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-use-frame-buffer-list nil
"Non-nil means use the currently selected frame's buffer list."
- :type 'boolean
- :group 'iswitchb)
+ :type 'boolean)
(defcustom iswitchb-make-buflist-hook nil
"Hook to run when list of matching buffers is created."
- :type 'hook
- :group 'iswitchb)
+ :type 'hook)
(defcustom iswitchb-delim ","
"Delimiter to put between buffer names when displaying results."
- :type 'string
- :group 'iswitchb)
+ :type 'string)
(defcustom iswitchb-all-frames 'visible
"Argument to pass to `walk-windows' when iswitchb is finding buffers.
@@ -375,8 +362,7 @@ See documentation of `walk-windows' for useful values."
:type '(choice (const :tag "Selected frame only" nil)
(const :tag "All existing frames" t)
(const :tag "All visible frames" visible)
- (const :tag "All frames on this terminal" 0))
- :group 'iswitchb)
+ (const :tag "All frames on this terminal" 0)))
(defcustom iswitchb-minibuffer-setup-hook nil
"Iswitchb-specific customization of minibuffer setup.
@@ -387,37 +373,32 @@ For instance:
\\='\(lambda () (set (make-local-variable \\='max-mini-window-height) 3)))
will constrain the minibuffer to a maximum height of 3 lines when
iswitchb is running."
- :type 'hook
- :group 'iswitchb)
+ :type 'hook)
(defface iswitchb-single-match
'((t
(:inherit font-lock-comment-face)))
"Iswitchb face for single matching buffer name."
- :version "22.1"
- :group 'iswitchb)
+ :version "22.1")
(defface iswitchb-current-match
'((t
(:inherit font-lock-function-name-face)))
"Iswitchb face for current matching buffer name."
- :version "22.1"
- :group 'iswitchb)
+ :version "22.1")
(defface iswitchb-virtual-matches
'((t
(:inherit font-lock-builtin-face)))
"Iswitchb face for matching virtual buffer names.
See also `iswitchb-use-virtual-buffers'."
- :version "22.1"
- :group 'iswitchb)
+ :version "22.1")
(defface iswitchb-invalid-regexp
'((t
(:inherit font-lock-warning-face)))
"Iswitchb face for indicating invalid regexp. "
- :version "22.1"
- :group 'iswitchb)
+ :version "22.1")
;; Do we need the variable iswitchb-use-mycompletion?
@@ -465,18 +446,18 @@ interfere with other minibuffer usage.")
(defvar iswitchb-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
- (define-key map "?" 'iswitchb-completion-help)
- (define-key map "\C-s" 'iswitchb-next-match)
- (define-key map "\C-r" 'iswitchb-prev-match)
- (define-key map [?\C-.] 'iswitchb-next-match)
- (define-key map [?\C-,] 'iswitchb-prev-match)
- (define-key map "\t" 'iswitchb-complete)
- (define-key map "\C-j" 'iswitchb-select-buffer-text)
- (define-key map "\C-t" 'iswitchb-toggle-regexp)
- (define-key map "\C-x\C-f" 'iswitchb-find-file)
- (define-key map "\C-c" 'iswitchb-toggle-case)
- (define-key map "\C-k" 'iswitchb-kill-buffer)
- (define-key map "\C-m" 'iswitchb-exit-minibuffer)
+ (define-key map "?" #'iswitchb-completion-help)
+ (define-key map "\C-s" #'iswitchb-next-match)
+ (define-key map "\C-r" #'iswitchb-prev-match)
+ (define-key map [?\C-.] #'iswitchb-next-match)
+ (define-key map [?\C-,] #'iswitchb-prev-match)
+ (define-key map "\t" #'iswitchb-complete)
+ (define-key map "\C-j" #'iswitchb-select-buffer-text)
+ (define-key map "\C-t" #'iswitchb-toggle-regexp)
+ (define-key map "\C-x\C-f" #'iswitchb-find-file)
+ (define-key map "\C-c" #'iswitchb-toggle-case)
+ (define-key map "\C-k" #'iswitchb-kill-buffer)
+ (define-key map "\C-m" #'iswitchb-exit-minibuffer)
map)
"Minibuffer keymap for `iswitchb-buffer'.")
@@ -596,17 +577,17 @@ the selection process begins. Used by isearchb.el."
(let ((map (copy-keymap minibuffer-local-map))
buf-sel iswitchb-final-text
icomplete-mode) ; prevent icomplete starting up
- (define-key map "?" 'iswitchb-completion-help)
- (define-key map "\C-s" 'iswitchb-next-match)
- (define-key map "\C-r" 'iswitchb-prev-match)
- (define-key map "\t" 'iswitchb-complete)
- (define-key map "\C-j" 'iswitchb-select-buffer-text)
- (define-key map "\C-t" 'iswitchb-toggle-regexp)
- (define-key map "\C-x\C-f" 'iswitchb-find-file)
- (define-key map "\C-n" 'iswitchb-toggle-ignore)
- (define-key map "\C-c" 'iswitchb-toggle-case)
- (define-key map "\C-k" 'iswitchb-kill-buffer)
- (define-key map "\C-m" 'iswitchb-exit-minibuffer)
+ (define-key map "?" #'iswitchb-completion-help)
+ (define-key map "\C-s" #'iswitchb-next-match)
+ (define-key map "\C-r" #'iswitchb-prev-match)
+ (define-key map "\t" #'iswitchb-complete)
+ (define-key map "\C-j" #'iswitchb-select-buffer-text)
+ (define-key map "\C-t" #'iswitchb-toggle-regexp)
+ (define-key map "\C-x\C-f" #'iswitchb-find-file)
+ (define-key map "\C-n" #'iswitchb-toggle-ignore)
+ (define-key map "\C-c" #'iswitchb-toggle-case)
+ (define-key map "\C-k" #'iswitchb-kill-buffer)
+ (define-key map "\C-m" #'iswitchb-exit-minibuffer)
(setq iswitchb-mode-map map)
(run-hooks 'iswitchb-define-mode-map-hook)
@@ -946,9 +927,9 @@ If `iswitchb-change-word-sub' cannot be found in WORD, return nil."
(if iswitchb-regexp
subs
(regexp-quote subs)))
- (setq res (mapcar 'iswitchb-word-matching-substring lis))
+ (setq res (mapcar #'iswitchb-word-matching-substring lis))
(setq res (delq nil res)) ;; remove any nil elements (shouldn't happen)
- (setq alist (mapcar 'iswitchb-makealist res)) ;; could use an OBARRAY
+ (setq alist (mapcar #'iswitchb-makealist res)) ;; could use an OBARRAY
;; try-completion returns t if there is an exact match.
(let ((completion-ignore-case (iswitchb-case)))
@@ -1148,43 +1129,6 @@ For details of keybindings, do `\\[describe-function] iswitchb'."
(setq iswitchb-method 'otherframe)
(iswitchb))
-;;; XEmacs hack for showing default buffer
-
-;; The first time we enter the minibuffer, Emacs puts up the default
-;; buffer to switch to, but XEmacs doesn't -- presumably there is a
-;; subtle difference in the two versions of post-command-hook. The
-;; default is shown for both whenever we delete all of our text
-;; though, indicating its just a problem the first time we enter the
-;; function. To solve this, we use another entry hook for emacs to
-;; show the default the first time we enter the minibuffer.
-
-(defun iswitchb-init-XEmacs-trick ()
- "Display default buffer when first entering minibuffer.
-This is a hack for XEmacs, and should really be handled by `iswitchb-exhibit'."
- (if (iswitchb-entryfn-p)
- (progn
- (iswitchb-exhibit)
- (goto-char (point-min)))))
-
-;; add this hook for XEmacs only.
-(if (featurep 'xemacs)
- (add-hook 'iswitchb-minibuffer-setup-hook
- 'iswitchb-init-XEmacs-trick))
-
-;;; XEmacs / backspace key
-;; For some reason, if the backspace key is pressed in XEmacs, the
-;; line gets confused, so I've added a simple key definition to make
-;; backspace act like the normal delete key.
-
-(defun iswitchb-xemacs-backspacekey ()
- "Bind backspace to `backward-delete-char'."
- (define-key iswitchb-mode-map '[backspace] 'backward-delete-char)
- (define-key iswitchb-mode-map '[(meta backspace)] 'backward-kill-word))
-
-(if (featurep 'xemacs)
- (add-hook 'iswitchb-define-mode-map-hook
- 'iswitchb-xemacs-backspacekey))
-
;;; ICOMPLETE TYPE CODE
(defun iswitchb-exhibit ()
@@ -1214,18 +1158,6 @@ Copied from `icomplete-exhibit' with two changes:
(insert (iswitchb-completions
contents))))))
-(defvar most-len)
-(defvar most-is-exact)
-
-(defun iswitchb-output-completion (com)
- (if (= (length com) most-len)
- ;; Most is one exact match,
- ;; note that and leave out
- ;; for later indication:
- (ignore
- (setq most-is-exact t))
- (substring com most-len)))
-
(defun iswitchb-completions (name)
"Return the string that is displayed after the user's text.
Modified from `icomplete-completions'."
@@ -1273,7 +1205,7 @@ Modified from `icomplete-completions'."
iswitchb-virtual-buffers)))
(setq head (cdr head)))
(setq iswitchb-virtual-buffers (nreverse iswitchb-virtual-buffers)
- comps (mapcar 'car iswitchb-virtual-buffers))
+ comps (mapcar #'car iswitchb-virtual-buffers))
(let ((comp comps))
(while comp
(put-text-property 0 (length (car comp))
@@ -1316,15 +1248,11 @@ Modified from `icomplete-completions'."
(nreverse res))
(list "...")
(nthcdr (- (length comps)
- (/ iswitchb-max-to-show 2)) comps))))
+ (/ iswitchb-max-to-show 2))
+ comps))))
(let* (
- ;;(most (try-completion name candidates predicate))
- (most nil)
- (most-len (length most))
- most-is-exact
(alternatives
- (mapconcat (if most 'iswitchb-output-completion
- 'identity) comps iswitchb-delim)))
+ (mapconcat #'identity comps iswitchb-delim)))
(concat
@@ -1338,17 +1266,9 @@ Modified from `icomplete-completions'."
close-bracket-determined))
;; end of partial matches...
- ;; think this bit can be ignored.
- (and (> most-len (length name))
- (concat open-bracket-determined
- (substring most (length name))
- close-bracket-determined))
-
;; list all alternatives
open-bracket-prospects
- (if most-is-exact
- (concat iswitchb-delim alternatives)
- alternatives)
+ alternatives
close-bracket-prospects))))))
(defun iswitchb-minibuffer-setup ()
@@ -1356,8 +1276,8 @@ Modified from `icomplete-completions'."
Copied from `icomplete-minibuffer-setup-hook'."
(when (iswitchb-entryfn-p)
(set (make-local-variable 'iswitchb-use-mycompletion) t)
- (add-hook 'pre-command-hook 'iswitchb-pre-command nil t)
- (add-hook 'post-command-hook 'iswitchb-post-command nil t)
+ (add-hook 'pre-command-hook #'iswitchb-pre-command nil t)
+ (add-hook 'post-command-hook #'iswitchb-post-command nil t)
(run-hooks 'iswitchb-minibuffer-setup-hook)))
(defun iswitchb-pre-command ()
@@ -1393,7 +1313,7 @@ Copied from `icomplete-tidy'."
"Move the summaries to the end of the list.
This is an example function which can be hooked on to
`iswitchb-make-buflist-hook'. Any buffer matching the regexps
-`Summary' or `output\*$'are put to the end of the list."
+`Summary' or `output\\*$'are put to the end of the list."
(let ((summaries (delq nil
(mapcar
(lambda (x)
@@ -1416,10 +1336,10 @@ See the variable `iswitchb-case' for details."
Iswitchb mode is a global minor mode that enables switching
between buffers using substrings. See `iswitchb' for details."
- nil nil iswitchb-global-map :global t :group 'iswitchb
+ :keymap iswitchb-global-map :global t
(if iswitchb-mode
- (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)
- (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))
+ (add-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)
+ (remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)))
(provide 'iswitchb)
diff --git a/lisp/obsolete/landmark.el b/lisp/obsolete/landmark.el
index c5581f7f35e..cc4fd19c389 100644
--- a/lisp/obsolete/landmark.el
+++ b/lisp/obsolete/landmark.el
@@ -163,51 +163,50 @@
(defcustom landmark-mode-hook nil
"If non-nil, its value is called on entry to Landmark mode."
- :type 'hook
- :group 'landmark)
+ :type 'hook)
(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
+ (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)
+ (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.")
@@ -219,14 +218,12 @@
(defface landmark-font-lock-face-O '((((class color)) :foreground "red")
(t :weight bold))
"Face to use for Emacs's O."
- :version "22.1"
- :group 'landmark)
+ :version "22.1")
(defface landmark-font-lock-face-X '((((class color)) :foreground "green")
(t :weight bold))
"Face to use for your X."
- :version "22.1"
- :group 'landmark)
+ :version "22.1")
(defvar landmark-font-lock-keywords
'(("O" . 'landmark-font-lock-face-O)
@@ -1132,12 +1129,10 @@ this program to add a random element to the way moves were made.")
"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 'landmark)
+ :type 'boolean)
(defcustom landmark-output-moves t
"If non-nil, output number of moves so far on a move-by-move basis."
- :type 'boolean
- :group 'landmark)
+ :type 'boolean)
(defun landmark-weights-debug ()
@@ -1153,7 +1148,7 @@ because it is overwritten by \"One moment please\"."
(defun landmark-print-distance ()
(insert (format "tree: %S \n" (landmark-calc-distance-of-robot-from 'landmark-tree)))
- (mapc 'landmark-print-distance-int landmark-directions))
+ (mapc #'landmark-print-distance-int landmark-directions))
;;(setq direction 'landmark-n)
@@ -1166,10 +1161,10 @@ because it is overwritten by \"One moment please\"."
(defun landmark-nslify-wts ()
(interactive)
- (let ((l (apply 'append (mapcar 'landmark-nslify-wts-int landmark-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))))))
+ (apply #'max l) (apply #'min l)))))
(defun landmark-print-wts-int (direction)
(mapc (lambda (target-direction)
@@ -1184,7 +1179,7 @@ because it is overwritten by \"One moment please\"."
(interactive)
(with-current-buffer "*landmark-wts*"
(insert "==============================\n")
- (mapc 'landmark-print-wts-int landmark-directions)))
+ (mapc #'landmark-print-wts-int landmark-directions)))
(defun landmark-print-moves (moves)
(interactive)
@@ -1204,7 +1199,7 @@ because it is overwritten by \"One moment please\"."
(interactive)
(with-current-buffer "*landmark-y,s,noise*"
(insert "==============================\n")
- (mapc 'landmark-print-y-s-noise-int landmark-directions)))
+ (mapc #'landmark-print-y-s-noise-int landmark-directions)))
(defun landmark-print-smell-int (direction)
(insert (format "%S: smell: %S \n"
@@ -1216,7 +1211,7 @@ because it is overwritten by \"One moment please\"."
(with-current-buffer "*landmark-smell*"
(insert "==============================\n")
(insert (format "tree: %S \n" (get 'z 't)))
- (mapc 'landmark-print-smell-int landmark-directions)))
+ (mapc #'landmark-print-smell-int landmark-directions)))
(defun landmark-print-w0-int (direction)
(insert (format "%S: w0: %S \n"
@@ -1227,7 +1222,7 @@ because it is overwritten by \"One moment please\"."
(interactive)
(with-current-buffer "*landmark-w0*"
(insert "==============================\n")
- (mapc 'landmark-print-w0-int landmark-directions)))
+ (mapc #'landmark-print-w0-int landmark-directions)))
(defun landmark-blackbox ()
(with-current-buffer "*landmark-blackbox*"
@@ -1252,35 +1247,31 @@ because it is overwritten by \"One moment please\"."
(defun landmark-print-wts-blackbox ()
(interactive)
- (mapc 'landmark-print-wts-int landmark-directions))
+ (mapc #'landmark-print-wts-int landmark-directions))
;;;_ - learning parameters
(defcustom landmark-bound 0.005
"The maximum that w0j may be."
- :type 'number
- :group 'landmark)
+ :type 'number)
(defcustom landmark-c 1.0
"A factor applied to modulate the increase in wij.
Used in the function landmark-update-normal-weights."
- :type 'number
- :group 'landmark)
+ :type 'number)
(defcustom landmark-c-naught 0.5
"A factor applied to modulate the increase in w0j.
Used in the function landmark-update-naught-weights."
- :type 'number
- :group 'landmark)
+ :type 'number)
(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 'landmark)
+ :type 'integer)
(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, landmark-random-move is called to push him out of it."
- :type 'integer
- :group 'landmark)
+After this limit is reached, landmark-random-move is called to
+push him out of it."
+ :type 'integer)
;;;_ + Randomizing functions
@@ -1345,7 +1336,8 @@ After this limit is reached, landmark-random-move is called to push him out of i
(put 'landmark-e 'y (/ landmark-board-height 2))
(put 'landmark-e 'sym 4)
- (mapc 'landmark-plot-internal '(landmark-n landmark-s landmark-e landmark-w landmark-tree)))
+ (mapc #'landmark-plot-internal
+ '(landmark-n landmark-s landmark-e landmark-w landmark-tree)))
@@ -1433,7 +1425,7 @@ After this limit is reached, landmark-random-move is called to push him out of i
;;;_ + Functions to move robot
(defun landmark-confidence-for (target-direction)
- (apply '+
+ (apply #'+
(get target-direction 'w0)
(mapcar (lambda (direction)
(*
@@ -1493,13 +1485,13 @@ After this limit is reached, landmark-random-move is called to push him out of i
(landmark-random-move)
(progn
(landmark-calc-confidences)
- (mapc 'landmark-y landmark-directions)
+ (mapc #'landmark-y landmark-directions)
(landmark-move)))
(landmark-calc-payoff)
- (mapc 'landmark-update-normal-weights landmark-directions)
- (mapc 'landmark-update-naught-weights landmark-directions)
+ (mapc #'landmark-update-normal-weights landmark-directions)
+ (mapc #'landmark-update-naught-weights landmark-directions)
(if landmark-debug
(landmark-weights-debug)))
(landmark-terminate-game nil))
@@ -1535,8 +1527,8 @@ If the game is finished, this command requests for another game."
(landmark-calc-payoff)
- (mapc 'landmark-update-normal-weights landmark-directions)
- (mapc 'landmark-update-naught-weights landmark-directions)
+ (mapc #'landmark-update-normal-weights landmark-directions)
+ (mapc #'landmark-update-naught-weights landmark-directions)
(landmark-amble-robot)
)))))))
@@ -1575,7 +1567,7 @@ If the game is finished, this command requests for another game."
(if (not save-weights)
(progn
- (mapc 'landmark-fix-weights-for landmark-directions)
+ (mapc #'landmark-fix-weights-for landmark-directions)
(dolist (direction landmark-directions)
(put direction 'w0 landmark-initial-w0)))
(message "Weights preserved for this run."))
@@ -1617,7 +1609,7 @@ If the game is finished, this command requests for another game."
;;;_ + landmark-test-run ()
;;;###autoload
-(defalias 'landmark-repeat 'landmark-test-run)
+(defalias 'landmark-repeat #'landmark-test-run)
;;;###autoload
(defun landmark-test-run ()
"Run 100 Landmark games, each time saving the weights from the previous game."
@@ -1669,13 +1661,13 @@ Use \\[describe-mode] for more info."
(if landmark-one-moment-please
(message "One moment, please..."))
(landmark-start-game landmark-n landmark-m)
- (eval (cons 'landmark-init
- (cond
- ((= parg 1) '(t nil))
- ((= parg 2) '(t t))
- ((= parg 3) '(nil t))
- ((= parg 4) '(nil nil))
- (t '(nil t))))))))
+ (apply #'landmark-init
+ (cond
+ ((= parg 1) '(t nil))
+ ((= parg 2) '(t t))
+ ((= parg 3) '(nil t))
+ ((= parg 4) '(nil nil))
+ (t '(nil t)))))))
;;;_ + Local variables
diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el
index e1a01913bea..13f14aad6d1 100644
--- a/lisp/obsolete/lazy-lock.el
+++ b/lisp/obsolete/lazy-lock.el
@@ -1,4 +1,4 @@
-;;; lazy-lock.el --- lazy demand-driven fontification for fast Font Lock mode
+;;; lazy-lock.el --- lazy demand-driven fontification for fast Font Lock mode -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1998, 2001-2021 Free Software Foundation, Inc.
@@ -270,30 +270,14 @@
(eval-when-compile (require 'cl-lib))
(eval-when-compile
- ;; 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
- (when (and (not modified) (buffer-modified-p))
- (restore-buffer-modified-p nil))))
- (put 'save-buffer-state 'lisp-indent-function 1)
;;
;; We use this for clarity and speed. Naughty but nice.
(defmacro do-while (test &rest body)
"(do-while TEST BODY...): eval BODY... and repeat if TEST yields non-nil.
The order of execution is thus BODY, TEST, BODY, TEST and so on
until TEST returns nil."
- `(while (progn ,@body ,test)))
- (put 'do-while 'lisp-indent-function (get 'while 'lisp-indent-function)))
+ (declare (indent 1) (debug t))
+ `(while (progn ,@body ,test))))
(defgroup lazy-lock nil
"Font Lock support mode to fontify lazily."
@@ -326,8 +310,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
(symbol :tag "name"))
(radio :tag "Size"
(const :tag "none" nil)
- (integer :tag "size")))))
- :group 'lazy-lock)
+ (integer :tag "size"))))))
(defcustom lazy-lock-defer-on-the-fly t
"If non-nil, means fontification after a change should be deferred.
@@ -346,8 +329,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
(set :menu-tag "mode specific" :tag "modes"
:value (not)
(const :tag "Except" not)
- (repeat :inline t (symbol :tag "mode"))))
- :group 'lazy-lock)
+ (repeat :inline t (symbol :tag "mode")))))
(defcustom lazy-lock-defer-on-scrolling nil
"If non-nil, means fontification after a scroll should be deferred.
@@ -371,8 +353,7 @@ makes little sense if `lazy-lock-defer-contextually' is non-nil.)
The value of this variable is used when Lazy Lock mode is turned on."
:type '(choice (const :tag "never" nil)
(const :tag "always" t)
- (other :tag "eventually" eventually))
- :group 'lazy-lock)
+ (other :tag "eventually" eventually)))
(defcustom lazy-lock-defer-contextually 'syntax-driven
"If non-nil, means deferred fontification should be syntactically true.
@@ -389,8 +370,7 @@ buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil.
The value of this variable is used when Lazy Lock mode is turned on."
:type '(choice (const :tag "never" nil)
(const :tag "always" t)
- (other :tag "syntax-driven" syntax-driven))
- :group 'lazy-lock)
+ (other :tag "syntax-driven" syntax-driven)))
(defcustom lazy-lock-defer-time 0.25
"Time in seconds to delay before beginning deferred fontification.
@@ -401,8 +381,7 @@ variables `lazy-lock-defer-on-the-fly', `lazy-lock-defer-on-scrolling' and
The value of this variable is used when Lazy Lock mode is turned on."
:type '(choice (const :tag "never" nil)
- (number :tag "seconds"))
- :group 'lazy-lock)
+ (number :tag "seconds")))
(defcustom lazy-lock-stealth-time 30
"Time in seconds to delay before beginning stealth fontification.
@@ -411,16 +390,14 @@ If nil, means stealth fontification is never performed.
The value of this variable is used when Lazy Lock mode is turned on."
:type '(choice (const :tag "never" nil)
- (number :tag "seconds"))
- :group 'lazy-lock)
+ (number :tag "seconds")))
(defcustom lazy-lock-stealth-lines (if font-lock-maximum-decoration 100 250)
"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."
- :type '(integer :tag "lines")
- :group 'lazy-lock)
+ :type '(integer :tag "lines"))
(defcustom lazy-lock-stealth-load
(if (condition-case nil (load-average) (error)) 200)
@@ -435,8 +412,7 @@ See also `lazy-lock-stealth-nice'."
:type (if (condition-case nil (load-average) (error))
'(choice (const :tag "never" nil)
(integer :tag "load"))
- '(const :format "%t: unsupported\n" nil))
- :group 'lazy-lock)
+ '(const :format "%t: unsupported\n" nil)))
(defcustom lazy-lock-stealth-nice 0.125
"Time in seconds to pause between chunks of stealth fontification.
@@ -447,14 +423,12 @@ To reduce machine load during stealth fontification, at the cost of stealth
taking longer to fontify, you could increase the value of this variable.
See also `lazy-lock-stealth-load'."
:type '(choice (const :tag "never" nil)
- (number :tag "seconds"))
- :group 'lazy-lock)
+ (number :tag "seconds")))
(defcustom lazy-lock-stealth-verbose
(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)
+ :type 'boolean)
;; User Functions:
@@ -580,30 +554,30 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; Add hook if lazy-lock.el is fontifying on scrolling or is deferring.
(when (or fontifying defer-change defer-scroll defer-context)
(add-hook 'window-scroll-functions (if defer-scroll
- 'lazy-lock-defer-after-scroll
- 'lazy-lock-fontify-after-scroll)
+ #'lazy-lock-defer-after-scroll
+ #'lazy-lock-fontify-after-scroll)
nil t))
;;
;; Add hook if lazy-lock.el is fontifying and is not deferring changes.
(when (and fontifying (not defer-change) (not defer-context))
- (add-hook 'before-change-functions 'lazy-lock-arrange-before-change nil t))
+ (add-hook 'before-change-functions #'lazy-lock-arrange-before-change nil t))
;;
;; Replace Font Lock mode hook.
- (remove-hook 'after-change-functions 'font-lock-after-change-function t)
+ (remove-hook 'after-change-functions #'font-lock-after-change-function t)
(add-hook 'after-change-functions
(cond ((and defer-change defer-context)
- 'lazy-lock-defer-rest-after-change)
+ #'lazy-lock-defer-rest-after-change)
(defer-change
- 'lazy-lock-defer-line-after-change)
+ #'lazy-lock-defer-line-after-change)
(defer-context
- 'lazy-lock-fontify-rest-after-change)
+ #'lazy-lock-fontify-rest-after-change)
(t
- 'lazy-lock-fontify-line-after-change))
+ #'lazy-lock-fontify-line-after-change))
nil t)
;;
;; Add package-specific hook.
- (add-hook 'outline-view-change-hook 'lazy-lock-fontify-after-visage nil t)
- (add-hook 'hs-hide-hook 'lazy-lock-fontify-after-visage nil t))
+ (add-hook 'outline-view-change-hook #'lazy-lock-fontify-after-visage nil t)
+ (add-hook 'hs-hide-hook #'lazy-lock-fontify-after-visage nil t))
(defun lazy-lock-install-timers (dtime stime)
;; Schedule or re-schedule the deferral and stealth timers.
@@ -616,13 +590,13 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(when (cdr defer)
(cancel-timer (cdr defer)))
(setcar lazy-lock-timers (cons dtime (and dtime
- (run-with-idle-timer dtime t 'lazy-lock-fontify-after-defer))))))
+ (run-with-idle-timer dtime t #'lazy-lock-fontify-after-defer))))))
(unless (eq stime (car (cdr lazy-lock-timers)))
(let ((stealth (cdr lazy-lock-timers)))
(when (cdr stealth)
(cancel-timer (cdr stealth)))
(setcdr lazy-lock-timers (cons stime (and stime
- (run-with-idle-timer stime t 'lazy-lock-fontify-after-idle)))))))
+ (run-with-idle-timer stime t #'lazy-lock-fontify-after-idle)))))))
(defun lazy-lock-unstall ()
;;
@@ -640,21 +614,21 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(save-restriction
(widen)
(lazy-lock-fontify-region (point-min) (point-max))))))
- (add-hook 'after-change-functions 'font-lock-after-change-function nil t))
+ (add-hook 'after-change-functions #'font-lock-after-change-function nil t))
;;
;; Remove the text properties.
(lazy-lock-after-unfontify-buffer)
;;
;; Remove the fontification hooks.
- (remove-hook 'window-scroll-functions 'lazy-lock-fontify-after-scroll t)
- (remove-hook 'window-scroll-functions 'lazy-lock-defer-after-scroll t)
- (remove-hook 'before-change-functions 'lazy-lock-arrange-before-change t)
- (remove-hook 'after-change-functions 'lazy-lock-fontify-line-after-change t)
- (remove-hook 'after-change-functions 'lazy-lock-fontify-rest-after-change t)
- (remove-hook 'after-change-functions 'lazy-lock-defer-line-after-change t)
- (remove-hook 'after-change-functions 'lazy-lock-defer-rest-after-change t)
- (remove-hook 'outline-view-change-hook 'lazy-lock-fontify-after-visage t)
- (remove-hook 'hs-hide-hook 'lazy-lock-fontify-after-visage t))
+ (remove-hook 'window-scroll-functions #'lazy-lock-fontify-after-scroll t)
+ (remove-hook 'window-scroll-functions #'lazy-lock-defer-after-scroll t)
+ (remove-hook 'before-change-functions #'lazy-lock-arrange-before-change t)
+ (remove-hook 'after-change-functions #'lazy-lock-fontify-line-after-change t)
+ (remove-hook 'after-change-functions #'lazy-lock-fontify-rest-after-change t)
+ (remove-hook 'after-change-functions #'lazy-lock-defer-line-after-change t)
+ (remove-hook 'after-change-functions #'lazy-lock-defer-rest-after-change t)
+ (remove-hook 'outline-view-change-hook #'lazy-lock-fontify-after-visage t)
+ (remove-hook 'hs-hide-hook #'lazy-lock-fontify-after-visage t))
;; Hook functions.
@@ -682,7 +656,7 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; result in an unnecessary trigger after this if we did not cancel it now.
(set-window-redisplay-end-trigger window nil))
-(defun lazy-lock-defer-after-scroll (window window-start)
+(defun lazy-lock-defer-after-scroll (window _window-start)
;; Called from `window-scroll-functions'.
;; Defer fontification following the scroll. Save the current buffer so that
;; we subsequently fontify in all windows showing the buffer.
@@ -750,7 +724,7 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(defalias 'lazy-lock-fontify-line-after-change
;; Called from `after-change-functions'.
;; Fontify the current change.
- 'font-lock-after-change-function)
+ #'font-lock-after-change-function)
(defun lazy-lock-fontify-rest-after-change (beg end old-len)
;; Called from `after-change-functions'.
@@ -758,29 +732,29 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; buffer. Save the current buffer so that we subsequently fontify in all
;; windows showing the buffer.
(lazy-lock-fontify-line-after-change beg end old-len)
- (save-buffer-state nil
+ (with-silent-modifications
(unless (memq (current-buffer) lazy-lock-buffers)
(push (current-buffer) lazy-lock-buffers))
(save-restriction
(widen)
(remove-text-properties end (point-max) '(lazy-lock nil)))))
-(defun lazy-lock-defer-line-after-change (beg end old-len)
+(defun lazy-lock-defer-line-after-change (beg end _old-len)
;; Called from `after-change-functions'.
;; Defer fontification of the current change. Save the current buffer so
;; that we subsequently fontify in all windows showing the buffer.
- (save-buffer-state nil
+ (with-silent-modifications
(unless (memq (current-buffer) lazy-lock-buffers)
(push (current-buffer) lazy-lock-buffers))
(remove-text-properties (max (1- beg) (point-min))
(min (1+ end) (point-max))
'(lazy-lock nil))))
-(defun lazy-lock-defer-rest-after-change (beg end old-len)
+(defun lazy-lock-defer-rest-after-change (beg _end _old-len)
;; Called from `after-change-functions'.
;; Defer fontification of the rest of the buffer. Save the current buffer so
;; that we subsequently fontify in all windows showing the buffer.
- (save-buffer-state nil
+ (with-silent-modifications
(unless (memq (current-buffer) lazy-lock-buffers)
(push (current-buffer) lazy-lock-buffers))
(save-restriction
@@ -809,10 +783,10 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(setq lazy-lock-buffers (cdr lazy-lock-buffers)))))
;; Add hook if fontification should now be defer-driven in this buffer.
(when (and lazy-lock-mode lazy-lock-defer-on-scrolling
- (memq 'lazy-lock-fontify-after-scroll window-scroll-functions)
+ (memq #'lazy-lock-fontify-after-scroll window-scroll-functions)
(not (or (input-pending-p) (lazy-lock-unfontified-p))))
- (remove-hook 'window-scroll-functions 'lazy-lock-fontify-after-scroll t)
- (add-hook 'window-scroll-functions 'lazy-lock-defer-after-scroll nil t)))
+ (remove-hook 'window-scroll-functions #'lazy-lock-fontify-after-scroll t)
+ (add-hook 'window-scroll-functions #'lazy-lock-defer-after-scroll nil t)))
(defun lazy-lock-fontify-after-idle ()
;; Called from `timer-idle-list'.
@@ -868,14 +842,14 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; Called from `font-lock-after-fontify-buffer'.
;; Mark the current buffer as fontified.
;; This is a conspiracy hack between lazy-lock.el and font-lock.el.
- (save-buffer-state nil
+ (with-silent-modifications
(add-text-properties (point-min) (point-max) '(lazy-lock t))))
(defun lazy-lock-after-unfontify-buffer ()
;; Called from `font-lock-after-unfontify-buffer'.
;; Mark the current buffer as unfontified.
;; This is a conspiracy hack between lazy-lock.el and font-lock.el.
- (save-buffer-state nil
+ (with-silent-modifications
(remove-text-properties (point-min) (point-max) '(lazy-lock nil))))
;; Fontification functions.
@@ -888,27 +862,27 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
(widen)
(when (setq beg (text-property-any beg end 'lazy-lock nil))
(save-excursion
- (save-match-data
- (save-buffer-state
- (next)
- ;; Find successive unfontified regions between BEG and END.
- (condition-case data
- (do-while beg
- (setq next (or (text-property-any beg end 'lazy-lock t) end))
- ;; Make sure the region end points are at beginning of line.
- (goto-char beg)
- (unless (bolp)
- (beginning-of-line)
- (setq beg (point)))
- (goto-char next)
- (unless (bolp)
- (forward-line)
- (setq next (point)))
- ;; Fontify the region, then flag it as fontified.
- (font-lock-fontify-region beg next)
- (add-text-properties beg next '(lazy-lock t))
- (setq beg (text-property-any next end 'lazy-lock nil)))
- ((error quit) (message "Fontifying region...%s" data)))))))))
+ (with-silent-modifications
+ (let ((inhibit-point-motion-hooks t))
+ ;; Find successive unfontified regions between BEG and END.
+ (condition-case data
+ (do-while beg
+ (let ((next (or (text-property-any beg end 'lazy-lock t)
+ end)))
+ ;; Make sure the region end points are at beginning of line.
+ (goto-char beg)
+ (unless (bolp)
+ (beginning-of-line)
+ (setq beg (point)))
+ (goto-char next)
+ (unless (bolp)
+ (forward-line)
+ (setq next (point)))
+ ;; Fontify the region, then flag it as fontified.
+ (font-lock-fontify-region beg next)
+ (add-text-properties beg next '(lazy-lock t))
+ (setq beg (text-property-any next end 'lazy-lock nil))))
+ ((error quit) (message "Fontifying region...%s" data)))))))))
(defun lazy-lock-fontify-chunk ()
;; Fontify the nearest chunk, for stealth, in the current buffer.
@@ -1036,14 +1010,12 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; Install ourselves:
-(add-hook 'window-size-change-functions 'lazy-lock-fontify-after-resize)
-(add-hook 'redisplay-end-trigger-functions 'lazy-lock-fontify-after-trigger)
+(add-hook 'window-size-change-functions #'lazy-lock-fontify-after-resize)
+(add-hook 'redisplay-end-trigger-functions #'lazy-lock-fontify-after-trigger)
(unless (assq 'lazy-lock-mode minor-mode-alist)
(setq minor-mode-alist (append minor-mode-alist '((lazy-lock-mode nil)))))
-;; Provide ourselves:
-
(provide 'lazy-lock)
;; Local Variables:
diff --git a/lisp/obsolete/ledit.el b/lisp/obsolete/ledit.el
deleted file mode 100644
index 75827a3648d..00000000000
--- a/lisp/obsolete/ledit.el
+++ /dev/null
@@ -1,157 +0,0 @@
-;;; ledit.el --- Emacs side of ledit interface
-
-;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
-
-;; Maintainer: emacs-devel@gnu.org
-;; Keywords: languages
-;; Obsolete-since: 24.3
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is a major mode for editing Liszt.
-
-;;; Code:
-
-;;; To do:
-;;; o lisp -> emacs side of things (grind-definition and find-definition)
-
-(defvar ledit-mode-map nil)
-
-(defconst ledit-zap-file
- (expand-file-name (concat (user-login-name) ".l1") temporary-file-directory)
- "File name for data sent to Lisp by Ledit.")
-(defconst ledit-read-file
- (expand-file-name (concat (user-login-name) ".l2") temporary-file-directory)
- "File name for data sent to Ledit by Lisp.")
-(defconst ledit-compile-file
- (expand-file-name (concat (user-login-name) ".l4") temporary-file-directory)
- "File name for data sent to Lisp compiler by Ledit.")
-(defconst ledit-buffer "*LEDIT*"
- "Name of buffer in which Ledit accumulates data to send to Lisp.")
-
-;;;###autoload
-(defconst ledit-save-files t "\
-*Non-nil means Ledit should save files before transferring to Lisp.")
-;;;###autoload
-(defconst ledit-go-to-lisp-string "%?lisp" "\
-*Shell commands to execute to resume Lisp job.")
-;;;###autoload
-(defconst ledit-go-to-liszt-string "%?liszt" "\
-*Shell commands to execute to resume Lisp compiler job.")
-
-(defun ledit-save-defun ()
- "Save the current defun in the ledit buffer."
- (interactive)
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (append-to-buffer ledit-buffer (point) end))
- (message "Current defun saved for Lisp")))
-
-(defun ledit-save-region (beg end)
- "Save the current region in the ledit buffer"
- (interactive "r")
- (append-to-buffer ledit-buffer beg end)
- (message "Region saved for Lisp"))
-
-(defun ledit-zap-defun-to-lisp ()
- "Carry the current defun to Lisp."
- (interactive)
- (ledit-save-defun)
- (ledit-go-to-lisp))
-
-(defun ledit-zap-defun-to-liszt ()
- "Carry the current defun to liszt."
- (interactive)
- (ledit-save-defun)
- (ledit-go-to-liszt))
-
-(defun ledit-zap-region-to-lisp (beg end)
- "Carry the current region to Lisp."
- (interactive "r")
- (ledit-save-region beg end)
- (ledit-go-to-lisp))
-
-(defun ledit-go-to-lisp ()
- "Suspend Emacs and restart a waiting Lisp job."
- (interactive)
- (if ledit-save-files
- (save-some-buffers))
- (if (get-buffer ledit-buffer)
- (with-current-buffer ledit-buffer
- (goto-char (point-min))
- (write-region (point-min) (point-max) ledit-zap-file)
- (erase-buffer)))
- (suspend-emacs ledit-go-to-lisp-string)
- (load ledit-read-file t t))
-
-(defun ledit-go-to-liszt ()
- "Suspend Emacs and restart a waiting Liszt job."
- (interactive)
- (if ledit-save-files
- (save-some-buffers))
- (if (get-buffer ledit-buffer)
- (with-current-buffer ledit-buffer
- (goto-char (point-min))
- (insert "(declare (macros t))\n")
- (write-region (point-min) (point-max) ledit-compile-file)
- (erase-buffer)))
- (suspend-emacs ledit-go-to-liszt-string)
- (load ledit-read-file t t))
-
-(defun ledit-setup ()
- "Set up key bindings for the Lisp/Emacs interface."
- (unless ledit-mode-map
- (setq ledit-mode-map (make-sparse-keymap))
- (set-keymap-parent ledit-mode-map lisp-mode-shared-map))
- (define-key ledit-mode-map "\e\^d" 'ledit-save-defun)
- (define-key ledit-mode-map "\e\^r" 'ledit-save-region)
- (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp)
- (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt))
-
-(ledit-setup)
-
-;;;###autoload
-(defun ledit-mode ()
- "\\<ledit-mode-map>Major mode for editing text and stuffing it to a Lisp job.
-Like Lisp mode, plus these special commands:
- \\[ledit-save-defun] -- record defun at or after point
- for later transmission to Lisp job.
- \\[ledit-save-region] -- record region for later transmission to Lisp job.
- \\[ledit-go-to-lisp] -- transfer to Lisp job and transmit saved text.
- \\[ledit-go-to-liszt] -- transfer to Liszt (Lisp compiler) job
- and transmit saved text.
-
-\\{ledit-mode-map}
-To make Lisp mode automatically change to Ledit mode,
-do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
- (interactive)
- (delay-mode-hooks (lisp-mode))
- (ledit-from-lisp-mode))
-
-;;;###autoload
-(defun ledit-from-lisp-mode ()
- (use-local-map ledit-mode-map)
- (setq mode-name "Ledit")
- (setq major-mode 'ledit-mode)
- (run-mode-hooks 'ledit-mode-hook))
-
-(provide 'ledit)
-
-;;; ledit.el ends here
diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el
deleted file mode 100644
index 0c2bb881bf0..00000000000
--- a/lisp/obsolete/levents.el
+++ /dev/null
@@ -1,292 +0,0 @@
-;;; levents.el --- emulate the Lucid event data type and associated functions
-
-;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
-
-;; Maintainer: emacs-devel@gnu.org
-;; Keywords: emulations
-;; Obsolete-since: 23.2
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Things we cannot emulate in Lisp:
-;; It is not possible to emulate current-mouse-event as a variable,
-;; though it is not hard to obtain the data from (this-command-keys).
-
-;; We do not have a variable unread-command-event;
-;; instead, we have the more general unread-command-events.
-
-;; Our read-key-sequence and read-char are not precisely
-;; compatible with those in Lucid Emacs, but they should work ok.
-
-;;; Code:
-
-(defun next-command-event (event)
- (error "You must rewrite to use `read-command-event' instead of `next-command-event'"))
-
-(defun next-event (event)
- (error "You must rewrite to use `read-event' instead of `next-event'"))
-
-(defun dispatch-event (event)
- (error "`dispatch-event' not supported"))
-
-;; Make events of type eval, menu and timeout
-;; execute properly.
-
-(define-key global-map [menu] 'execute-eval-event)
-(define-key global-map [timeout] 'execute-eval-event)
-(define-key global-map [eval] 'execute-eval-event)
-
-(defun execute-eval-event (event)
- (interactive "e")
- (funcall (nth 1 event) (nth 2 event)))
-
-(put 'eval 'event-symbol-elements '(eval))
-(put 'menu 'event-symbol-elements '(eval))
-(put 'timeout 'event-symbol-elements '(eval))
-
-(defun allocate-event ()
- "Return an empty event structure.
-In this emulation, it returns nil."
- nil)
-
-(defun button-press-event-p (obj)
- "True if the argument is a mouse-button-press event object."
- (and (consp obj) (symbolp (car obj))
- (memq 'down (get (car obj) 'event-symbol-elements))))
-
-(defun button-release-event-p (obj)
- "True if the argument is a mouse-button-release event object."
- (and (consp obj) (symbolp (car obj))
- (or (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun button-event-p (obj)
- "True if the argument is a mouse-button press or release event object."
- (and (consp obj) (symbolp (car obj))
- (or (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'down (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun mouse-event-p (obj)
- "True if the argument is a mouse-button press or release event object."
- (and (consp obj) (symbolp (car obj))
- (or (eq (car obj) 'mouse-movement)
- (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'down (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun character-to-event (ch &optional event)
- "Converts a numeric ASCII value to an event structure, replete with
-bucky bits. The character is the first argument, and the event to fill
-in is the second. This function contains knowledge about what the codes
-mean -- for example, the number 9 is converted to the character Tab,
-not the distinct character Control-I.
-
-Beware that character-to-event and event-to-character are not strictly
-inverse functions, since events contain much more information than the
-ASCII character set can encode."
- ch)
-
-(defun copy-event (event1 &optional event2)
- "Make a copy of the given event object.
-In this emulation, `copy-event' just returns its argument."
- event1)
-
-(defun deallocate-event (event)
- "Allow the given event structure to be reused.
-In actual Lucid Emacs, you MUST NOT use this event object after
-calling this function with it. You will lose. It is not necessary to
-call this function, as event objects are garbage- collected like all
-other objects; however, it may be more efficient to explicitly
-deallocate events when you are sure that this is safe.
-
-This emulation does not actually deallocate or reuse events
-except via garbage collection and `cons'."
- nil)
-
-(defun enqueue-eval-event: (function object)
- "Add an eval event to the back of the queue.
-It will be the next event read after all pending events."
- (setq unread-command-events
- (nconc unread-command-events
- (list (list 'eval function object)))))
-
-(defun eval-event-p (obj)
- "True if the argument is an eval or menu event object."
- (eq (car-safe obj) 'eval))
-
-(defun event-button (event)
- "Return the button-number of the given mouse-button-press event."
- (let ((sym (car (get (car event) 'event-symbol-elements))))
- (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3)
- (mouse-4 . 4) (mouse-5 . 5))))))
-
-(defun event-function (event)
- "Return the callback function of the given timeout, menu, or eval event."
- (nth 1 event))
-
-(defun event-key (event)
- "Return the KeySym of the given key-press event.
-The value is an ASCII printing character (not upper case) or a symbol."
- (if (symbolp event)
- (car (get event 'event-symbol-elements))
- (let ((base (logand event (1- (ash 1 18)))))
- (downcase (if (< base 32) (logior base 64) base)))))
-
-(defun event-object (event)
- "Return the function argument of the given timeout, menu, or eval event."
- (nth 2 event))
-
-(defun event-point (event)
- "Return the character position of the given mouse-related event.
-If the event did not occur over a window, or did
-not occur over text, then this returns nil. Otherwise, it returns an index
-into the buffer visible in the event's window."
- (posn-point (event-end event)))
-
-;; Return position of start of line LINE in WINDOW.
-;; If LINE is nil, return the last position
-;; visible in WINDOW.
-(defun event-closest-point-1 (window &optional line)
- (let* ((total (- (window-height window)
- (if (window-minibuffer-p window)
- 0 1)))
- (distance (or line total)))
- (save-excursion
- (goto-char (window-start window))
- (if (= (vertical-motion distance) distance)
- (if (not line)
- (forward-char -1)))
- (point))))
-
-(defun event-closest-point (event &optional start-window)
- "Return the nearest position to where EVENT ended its motion.
-This is computed for the window where EVENT's motion started,
-or for window WINDOW if that is specified."
- (or start-window (setq start-window (posn-window (event-start event))))
- (if (eq start-window (posn-window (event-end event)))
- (if (eq (event-point event) 'vertical-line)
- (event-closest-point-1 start-window
- (cdr (posn-col-row (event-end event))))
- (if (eq (event-point event) 'mode-line)
- (event-closest-point-1 start-window)
- (event-point event)))
- ;; EVENT ended in some other window.
- (let* ((end-w (posn-window (event-end event)))
- (end-w-top)
- (w-top (nth 1 (window-edges start-window))))
- (setq end-w-top
- (if (windowp end-w)
- (nth 1 (window-edges end-w))
- (/ (cdr (posn-x-y (event-end event)))
- (frame-char-height end-w))))
- (if (>= end-w-top w-top)
- (event-closest-point-1 start-window)
- (window-start start-window)))))
-
-(defun event-process (event)
- "Return the process of the given process-output event."
- (nth 1 event))
-
-(defun event-timestamp (event)
- "Return the timestamp of the given event object.
-In Lucid Emacs, this works for any kind of event.
-In this emulation, it returns nil for non-mouse-related events."
- (and (listp event)
- (posn-timestamp (event-end event))))
-
-(defun event-to-character (event &optional lenient)
- "Return the closest ASCII approximation to the given event object.
-If the event isn't a keypress, this returns nil.
-If the second argument is non-nil, then this is lenient in its
-translation; it will ignore modifier keys other than control and meta,
-and will ignore the shift modifier on those characters which have no
-shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
-the same ASCII code as Control-A.) If the second arg is nil, then nil
-will be returned for events which have no direct ASCII equivalent."
- (if (symbolp event)
- (and lenient
- (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9)
- (return . 10) (enter . 10)))))
- ;; Our interpretation is, ASCII means anything a number can represent.
- (if (integerp event)
- event nil)))
-
-(defun event-window (event)
- "Return the window of the given mouse-related event object."
- (posn-window (event-end event)))
-
-(defun event-x (event)
- "Return the X position in characters of the given mouse-related event."
- (/ (car (posn-col-row (event-end event)))
- (frame-char-width (window-frame (event-window event)))))
-
-(defun event-x-pixel (event)
- "Return the X position in pixels of the given mouse-related event."
- (car (posn-col-row (event-end event))))
-
-(defun event-y (event)
- "Return the Y position in characters of the given mouse-related event."
- (/ (cdr (posn-col-row (event-end event)))
- (frame-char-height (window-frame (event-window event)))))
-
-(defun event-y-pixel (event)
- "Return the Y position in pixels of the given mouse-related event."
- (cdr (posn-col-row (event-end event))))
-
-(defun key-press-event-p (obj)
- "True if the argument is a keyboard event object."
- (or (integerp obj)
- (and (symbolp obj)
- (get obj 'event-symbol-elements))))
-
-(defun menu-event-p (obj)
- "True if the argument is a menu event object."
- (eq (car-safe obj) 'menu))
-
-(defun motion-event-p (obj)
- "True if the argument is a mouse-motion event object."
- (eq (car-safe obj) 'mouse-movement))
-
-(defun read-command-event ()
- "Return the next keyboard or mouse event; execute other events.
-This is similar to the function `next-command-event' of Lucid Emacs,
-but different in that it returns the event rather than filling in
-an existing event object."
- (let (event)
- (while (progn
- (setq event (read-event))
- (not (or (key-press-event-p event)
- (button-press-event-p event)
- (button-release-event-p event)
- (menu-event-p event))))
- (let ((type (car-safe event)))
- (cond ((eq type 'eval)
- (funcall (nth 1 event) (nth 2 event)))
- ((eq type 'switch-frame)
- (select-frame (nth 1 event))))))
- event))
-
-(defun process-event-p (obj)
- "True if the argument is a process-output event object.
-GNU Emacs 19 does not currently generate process-output events."
- (eq (car-safe obj) 'process))
-
-(provide 'levents)
-
-;;; levents.el ends here
diff --git a/lisp/obsolete/lmenu.el b/lisp/obsolete/lmenu.el
deleted file mode 100644
index 9c0677485a2..00000000000
--- a/lisp/obsolete/lmenu.el
+++ /dev/null
@@ -1,445 +0,0 @@
-;;; lmenu.el --- emulate Lucid's menubar support
-
-;; Copyright (C) 1992-1994, 1997, 2001-2021 Free Software Foundation,
-;; Inc.
-
-;; Keywords: emulations obsolete
-;; Obsolete-since: 23.3
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 23.3.
-
-;;; Code:
-
-
-;; First, emulate the Lucid menubar support in GNU Emacs 19.
-
-;; Arrange to use current-menubar to set up part of the menu bar.
-
-(defvar current-menubar)
-(defvar lucid-menubar-map)
-(defvar lucid-failing-menubar)
-
-(defvar recompute-lucid-menubar 'recompute-lucid-menubar)
-(defun recompute-lucid-menubar ()
- (define-key lucid-menubar-map [menu-bar]
- (condition-case nil
- (make-lucid-menu-keymap "menu-bar" current-menubar)
- (error (message "Invalid data in current-menubar moved to lucid-failing-menubar")
- (sit-for 1)
- (setq lucid-failing-menubar current-menubar
- current-menubar nil))))
- (setq lucid-menu-bar-dirty-flag nil))
-
-(defvar lucid-menubar-map (make-sparse-keymap))
-(or (assq 'current-menubar minor-mode-map-alist)
- (setq minor-mode-map-alist
- (cons (cons 'current-menubar lucid-menubar-map)
- minor-mode-map-alist)))
-
-;; XEmacs compatibility
-(defun set-menubar-dirty-flag ()
- (force-mode-line-update)
- (setq lucid-menu-bar-dirty-flag t))
-
-(defvar add-menu-item-count 0)
-
-;; This is a variable whose value is always nil.
-(defvar make-lucid-menu-keymap-disable nil)
-
-;; Return a menu keymap corresponding to a Lucid-style menu list
-;; MENU-ITEMS, and with name MENU-NAME.
-(defun make-lucid-menu-keymap (menu-name menu-items)
- (let ((menu (make-sparse-keymap menu-name)))
- ;; Process items in reverse order,
- ;; since the define-key loop reverses them again.
- (setq menu-items (reverse menu-items))
- (while menu-items
- (let ((item (car menu-items))
- command name callback)
- (cond ((stringp item)
- (setq command nil)
- (setq name (if (string-match "^-+$" item) "" item)))
- ((consp item)
- (setq command (make-lucid-menu-keymap (car item) (cdr item)))
- (setq name (car item)))
- ((vectorp item)
- (setq command (make-symbol (format "menu-function-%d"
- add-menu-item-count))
- add-menu-item-count (1+ add-menu-item-count)
- name (aref item 0)
- callback (aref item 1))
- (if (symbolp callback)
- (fset command callback)
- (fset command (list 'lambda () '(interactive) callback)))
- (put command 'menu-alias t)
- (let ((i 2))
- (while (< i (length item))
- (cond
- ((eq (aref item i) ':active)
- (put command 'menu-enable
- (or (aref item (1+ i))
- 'make-lucid-menu-keymap-disable))
- (setq i (+ 2 i)))
- ((eq (aref item i) ':suffix)
- ;; unimplemented
- (setq i (+ 2 i)))
- ((eq (aref item i) ':keys)
- ;; unimplemented
- (setq i (+ 2 i)))
- ((eq (aref item i) ':style)
- ;; unimplemented
- (setq i (+ 2 i)))
- ((eq (aref item i) ':selected)
- ;; unimplemented
- (setq i (+ 2 i)))
- ((and (symbolp (aref item i))
- (= ?: (string-to-char (symbol-name (aref item i)))))
- (error "Unrecognized menu item keyword: %S"
- (aref item i)))
- ((= i 2)
- ;; old-style format: active-p &optional suffix
- (put command 'menu-enable
- (or (aref item i) 'make-lucid-menu-keymap-disable))
- ;; suffix is unimplemented
- (setq i (length item)))
- (t
- (error "Unexpected menu item value: %S"
- (aref item i))))))))
- (if (null command)
- ;; Handle inactive strings specially--allow any number
- ;; of identical ones.
- (setcdr menu (cons (list nil name) (cdr menu)))
- (if name
- (define-key menu (vector (intern name)) (cons name command)))))
- (setq menu-items (cdr menu-items)))
- menu))
-
-(declare-function x-popup-dialog "menu.c" (position contents &optional header))
-
-;; XEmacs compatibility function
-(defun popup-dialog-box (data)
- "Pop up a dialog box.
-A dialog box description is a list.
-
- - The first element of the list is a string to display in the dialog box.
- - The rest of the elements are descriptions of the dialog box's buttons.
- Each one is a vector of three elements:
- - The first element is the text of the button.
- - The second element is the `callback'.
- - The third element is t or nil, whether this button is selectable.
-
-If the `callback' of a button is a symbol, then it must name a command.
-It will be invoked with `call-interactively'. If it is a list, then it is
-evaluated with `eval'.
-
-One (and only one) of the buttons may be nil. This marker means that all
-following buttons should be flushright instead of flushleft.
-
-The syntax, more precisely:
-
- form := <something to pass to `eval'>
- command := <a symbol or string, to pass to `call-interactively'>
- callback := command | form
- active-p := <t, nil, or a form to evaluate to decide whether this
- button should be selectable>
- name := <string>
- partition := `nil'
- button := `[' name callback active-p `]'
- dialog := `(' name [ button ]+ [ partition [ button ]+ ] `)'"
- (let ((name (car data))
- (tail (cdr data))
- converted
- choice meaning)
- (while tail
- (if (null (car tail))
- (setq converted (cons nil converted))
- (let ((item (aref (car tail) 0))
- (callback (aref (car tail) 1))
- (enable (aref (car tail) 2)))
- (setq converted
- (cons (if enable (cons item callback) item)
- converted))))
- (setq tail (cdr tail)))
- (setq choice (x-popup-dialog t (cons name (nreverse converted))))
- (if choice
- (if (symbolp choice)
- (call-interactively choice)
- (eval choice)))))
-
-;; This is empty because the usual elements of the menu bar
-;; are provided by menu-bar.el instead.
-;; It would not make sense to duplicate them here.
-(defconst default-menubar nil)
-
-;; XEmacs compatibility
-(defun set-menubar (menubar)
- "Set the default menubar to be menubar."
- (setq-default current-menubar (copy-sequence menubar))
- (set-menubar-dirty-flag))
-
-;; XEmacs compatibility
-(defun set-buffer-menubar (menubar)
- "Set the buffer-local menubar to be menubar."
- (make-local-variable 'current-menubar)
- (setq current-menubar (copy-sequence menubar))
- (set-menubar-dirty-flag))
-
-
-;;; menu manipulation functions
-
-;; XEmacs compatibility
-(defun find-menu-item (menubar item-path-list &optional parent)
- "Searches MENUBAR for item given by ITEM-PATH-LIST.
-Returns (ITEM . PARENT), where PARENT is the immediate parent of
- the item found.
-Signals an error if the item is not found."
- (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
- (if (not (consp menubar))
- nil
- (let ((rest menubar)
- result)
- (while rest
- (if (and (car rest)
- (equal (car item-path-list)
- (downcase (if (vectorp (car rest))
- (aref (car rest) 0)
- (if (stringp (car rest))
- (car rest)
- (car (car rest)))))))
- (setq result (car rest) rest nil)
- (setq rest (cdr rest))))
- (if (cdr item-path-list)
- (if (consp result)
- (find-menu-item (cdr result) (cdr item-path-list) result)
- (if result
- (signal 'error (list "not a submenu" result))
- (signal 'error (list "no such submenu" (car item-path-list)))))
- (cons result parent)))))
-
-
-;; XEmacs compatibility
-(defun disable-menu-item (path)
- "Make the named menu item be unselectable.
-PATH is a list of strings which identify the position of the menu item in
-the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
-under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
-menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
- (let* ((menubar current-menubar)
- (pair (find-menu-item menubar path))
- (item (car pair))
- (menu (cdr pair)))
- (or item
- (signal 'error (list (if menu "No such menu item" "No such menu")
- path)))
- (if (consp item) (error "can't disable menus, only menu items"))
- (aset item 2 nil)
- (set-menubar-dirty-flag)
- item))
-
-
-;; XEmacs compatibility
-(defun enable-menu-item (path)
- "Make the named menu item be selectable.
-PATH is a list of strings which identify the position of the menu item in
-the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
-under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
-menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
- (let* ((menubar current-menubar)
- (pair (find-menu-item menubar path))
- (item (car pair))
- (menu (cdr pair)))
- (or item
- (signal 'error (list (if menu "No such menu item" "No such menu")
- path)))
- (if (consp item) (error "%S is a menu, not a menu item" path))
- (aset item 2 t)
- (set-menubar-dirty-flag)
- item))
-
-
-(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before)
- (if before (setq before (downcase before)))
- (let* ((menubar current-menubar)
- (menu (condition-case ()
- (car (find-menu-item menubar menu-path))
- (error nil)))
- (item (if (listp menu)
- (car (find-menu-item (cdr menu) (list item-name)))
- (signal 'error (list "not a submenu" menu-path)))))
- (or menu
- (let ((rest menu-path)
- (so-far menubar))
- (while rest
-;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
- (setq menu
- (if (eq so-far menubar)
- (car (find-menu-item so-far (list (car rest))))
- (car (find-menu-item (cdr so-far) (list (car rest))))))
- (or menu
- (let ((rest2 so-far))
- (or rest2
- (error "Trying to modify a menu that doesn't exist"))
- (while (and (cdr rest2) (car (cdr rest2)))
- (setq rest2 (cdr rest2)))
- (setcdr rest2
- (nconc (list (setq menu (list (car rest))))
- (cdr rest2)))))
- (setq so-far menu)
- (setq rest (cdr rest)))))
- (or menu (setq menu menubar))
- (if item
- nil ; it's already there
- (if item-p
- (setq item (vector item-name item-data enabled-p))
- (setq item (cons item-name item-data)))
- ;; if BEFORE is specified, try to add it there.
- (if before
- (setq before (car (find-menu-item menu (list before)))))
- (let ((rest menu)
- (added-before nil))
- (while rest
- (if (eq before (car (cdr rest)))
- (progn
- (setcdr rest (cons item (cdr rest)))
- (setq rest nil added-before t))
- (setq rest (cdr rest))))
- (if (not added-before)
- ;; adding before the first item on the menubar itself is harder
- (if (and (eq menu menubar) (eq before (car menu)))
- (setq menu (cons item menu)
- current-menubar menu)
- ;; otherwise, add the item to the end.
- (nconc menu (list item))))))
- (if item-p
- (progn
- (aset item 1 item-data)
- (aset item 2 (not (null enabled-p))))
- (setcar item item-name)
- (setcdr item item-data))
- (set-menubar-dirty-flag)
- item))
-
-;; XEmacs compatibility
-(defun add-menu-item (menu-path item-name function enabled-p &optional before)
- "Add a menu item to some menu, creating the menu first if necessary.
-If the named item exists already, it is changed.
-MENU-PATH identifies the menu under which the new menu item should be inserted.
- It is a list of strings; for example, (\"File\") names the top-level \"File\"
- menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
-ITEM-NAME is the string naming the menu item to be added.
-FUNCTION is the command to invoke when this menu item is selected.
- If it is a symbol, then it is invoked with `call-interactively', in the same
- way that functions bound to keys are invoked. If it is a list, then the
- list is simply evaluated.
-ENABLED-P controls whether the item is selectable or not.
-BEFORE, if provided, is the name of a menu item before which this item should
- be added, if this item is not on the menu already. If the item is already
- present, it will not be moved."
- (or menu-path (error "must specify a menu path"))
- (or item-name (error "must specify an item name"))
- (add-menu-item-1 t menu-path item-name function enabled-p before))
-
-
-;; XEmacs compatibility
-(defun delete-menu-item (path)
- "Remove the named menu item from the menu hierarchy.
-PATH is a list of strings which identify the position of the menu item in
-the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
-under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
-menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
- (let* ((menubar current-menubar)
- (pair (find-menu-item menubar path))
- (item (car pair))
- (menu (or (cdr pair) menubar)))
- (if (not item)
- nil
- ;; the menubar is the only special case, because other menus begin
- ;; with their name.
- (if (eq menu current-menubar)
- (setq current-menubar (delq item menu))
- (delq item menu))
- (set-menubar-dirty-flag)
- item)))
-
-
-;; XEmacs compatibility
-(defun relabel-menu-item (path new-name)
- "Change the string of the specified menu item.
-PATH is a list of strings which identify the position of the menu item in
-the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\"
-under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
-menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
-NEW-NAME is the string that the menu item will be printed as from now on."
- (or (stringp new-name)
- (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
- (let* ((menubar current-menubar)
- (pair (find-menu-item menubar path))
- (item (car pair))
- (menu (cdr pair)))
- (or item
- (signal 'error (list (if menu "No such menu item" "No such menu")
- path)))
- (if (and (consp item)
- (stringp (car item)))
- (setcar item new-name)
- (aset item 0 new-name))
- (set-menubar-dirty-flag)
- item))
-
-;; XEmacs compatibility
-(defun add-menu (menu-path menu-name menu-items &optional before)
- "Add a menu to the menubar or one of its submenus.
-If the named menu exists already, it is changed.
-MENU-PATH identifies the menu under which the new menu should be inserted.
- It is a list of strings; for example, (\"File\") names the top-level \"File\"
- menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
- If MENU-PATH is nil, then the menu will be added to the menubar itself.
-MENU-NAME is the string naming the menu to be added.
-MENU-ITEMS is a list of menu item descriptions.
- Each menu item should be a vector of three elements:
- - a string, the name of the menu item;
- - a symbol naming a command, or a form to evaluate;
- - and a form whose value determines whether this item is selectable.
-BEFORE, if provided, is the name of a menu before which this menu should
- be added, if this menu is not on its parent already. If the menu is already
- present, it will not be moved."
- (or menu-name (error "must specify a menu name"))
- (or menu-items (error "must specify some menu items"))
- (add-menu-item-1 nil menu-path menu-name menu-items t before))
-
-
-
-(defvar put-buffer-names-in-file-menu t)
-
-
-;; Don't unconditionally enable menu bars; leave that up to the user.
-;;(let ((frames (frame-list)))
-;; (while frames
-;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1)))
-;; (setq frames (cdr frames))))
-;;(or (assq 'menu-bar-lines default-frame-alist)
-;; (setq default-frame-alist
-;; (cons '(menu-bar-lines . 1) default-frame-alist)))
-
-(set-menubar default-menubar)
-
-(provide 'lmenu)
-
-;;; lmenu.el ends here
diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el
index 9fb03ff70f6..9676d6b28e9 100644
--- a/lisp/obsolete/longlines.el
+++ b/lisp/obsolete/longlines.el
@@ -1,4 +1,4 @@
-;;; longlines.el --- automatically wrap long lines -*- coding:utf-8 -*-
+;;; longlines.el --- automatically wrap long lines -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2001, 2004-2021 Free Software Foundation, Inc.
@@ -37,6 +37,7 @@
;; Special thanks to Rod Smith for many useful bug reports.
;;; Code:
+;;; Options
(defgroup longlines nil
"Automatic wrapping of long lines when loading files."
@@ -47,7 +48,6 @@
Otherwise, you can perform filling using `fill-paragraph' or
`auto-fill-mode'. In any case, the soft newlines will be removed
when the file is saved to disk."
- :group 'longlines
:type 'boolean)
(defcustom longlines-wrap-follows-window-size nil
@@ -59,7 +59,6 @@ with differing widths.
If the value is an integer, that specifies the distance from the
right edge of the window at which wrapping occurs. For any other
non-nil value, wrapping occurs 2 characters from the right edge."
- :group 'longlines
:type 'boolean)
(defcustom longlines-show-hard-newlines nil
@@ -67,16 +66,14 @@ non-nil value, wrapping occurs 2 characters from the right edge."
\(The variable `longlines-show-effect' controls what they look like.)
You can also enable the display temporarily, using the command
`longlines-show-hard-newlines'."
- :group 'longlines
:type 'boolean)
(defcustom longlines-show-effect (propertize "¶\n" 'face 'escape-glyph)
"A string to display when showing hard newlines.
This is used when `longlines-show-hard-newlines' is on."
- :group 'longlines
:type 'string)
-;; Internal variables
+;;; Internal variables
(defvar longlines-wrap-beg nil)
(defvar longlines-wrap-end nil)
@@ -90,7 +87,7 @@ This is used when `longlines-show-hard-newlines' is on."
(make-variable-buffer-local 'longlines-showing)
(make-variable-buffer-local 'longlines-decoded)
-;; Mode
+;;; Mode
(defvar message-indent-citation-function)
@@ -109,23 +106,23 @@ always call `fill-paragraph' to fill individual paragraphs.
If the variable `longlines-show-hard-newlines' is non-nil, hard
newlines are indicated with a symbol."
- :group 'longlines :lighter " ll"
+ :lighter " ll"
(if longlines-mode
;; Turn on longlines mode
(progn
(use-hard-newlines 1 'never)
(set (make-local-variable 'require-final-newline) nil)
(add-to-list 'buffer-file-format 'longlines)
- (add-hook 'change-major-mode-hook 'longlines-mode-off nil t)
- (add-hook 'before-revert-hook 'longlines-before-revert-hook nil t)
+ (add-hook 'change-major-mode-hook #'longlines-mode-off nil t)
+ (add-hook 'before-revert-hook #'longlines-before-revert-hook nil t)
(make-local-variable 'buffer-substring-filters)
(make-local-variable 'longlines-auto-wrap)
(set (make-local-variable 'isearch-search-fun-function)
- 'longlines-search-function)
+ #'longlines-search-function)
(set (make-local-variable 'replace-search-function)
- 'longlines-search-forward)
+ #'longlines-search-forward)
(set (make-local-variable 'replace-re-search-function)
- 'longlines-re-search-forward)
+ #'longlines-re-search-forward)
(add-to-list 'buffer-substring-filters 'longlines-encode-string)
(when longlines-wrap-follows-window-size
(let ((dw (if (and (integerp longlines-wrap-follows-window-size)
@@ -137,7 +134,7 @@ newlines are indicated with a symbol."
(set (make-local-variable 'fill-column)
(- (window-width) dw)))
(add-hook 'window-configuration-change-hook
- 'longlines-window-change-function nil t))
+ #'longlines-window-change-function nil t))
(let ((buffer-undo-list t)
(inhibit-read-only t)
(inhibit-modification-hooks t)
@@ -159,21 +156,22 @@ newlines are indicated with a symbol."
;; Hacks to make longlines play nice with various modes.
(cond ((eq major-mode 'mail-mode)
- (add-hook 'mail-setup-hook 'longlines-decode-buffer nil t)
+ (declare-function mail-indent-citation "sendmail" ())
+ (add-hook 'mail-setup-hook #'longlines-decode-buffer nil t)
(or mail-citation-hook
- (add-hook 'mail-citation-hook 'mail-indent-citation nil t))
- (add-hook 'mail-citation-hook 'longlines-decode-region nil t))
+ (add-hook 'mail-citation-hook #'mail-indent-citation nil t))
+ (add-hook 'mail-citation-hook #'longlines-decode-region nil t))
((eq major-mode 'message-mode)
- (add-hook 'message-setup-hook 'longlines-decode-buffer nil t)
+ (add-hook 'message-setup-hook #'longlines-decode-buffer nil t)
(make-local-variable 'message-indent-citation-function)
(if (not (listp message-indent-citation-function))
(setq message-indent-citation-function
(list message-indent-citation-function)))
- (add-to-list 'message-indent-citation-function
- 'longlines-decode-region t)))
+ (add-hook 'message-indent-citation-function
+ #'longlines-decode-region t t)))
- (add-hook 'after-change-functions 'longlines-after-change-function nil t)
- (add-hook 'post-command-hook 'longlines-post-command-function nil t)
+ (add-hook 'after-change-functions #'longlines-after-change-function nil t)
+ (add-hook 'post-command-hook #'longlines-post-command-function nil t)
(when longlines-auto-wrap
(auto-fill-mode 0)))
;; Turn off longlines mode
@@ -189,12 +187,12 @@ newlines are indicated with a symbol."
(widen)
(longlines-encode-region (point-min) (point-max))
(setq longlines-decoded nil))))
- (remove-hook 'change-major-mode-hook 'longlines-mode-off t)
- (remove-hook 'after-change-functions 'longlines-after-change-function t)
- (remove-hook 'post-command-hook 'longlines-post-command-function t)
- (remove-hook 'before-revert-hook 'longlines-before-revert-hook t)
+ (remove-hook 'change-major-mode-hook #'longlines-mode-off t)
+ (remove-hook 'after-change-functions #'longlines-after-change-function t)
+ (remove-hook 'post-command-hook #'longlines-post-command-function t)
+ (remove-hook 'before-revert-hook #'longlines-before-revert-hook t)
(remove-hook 'window-configuration-change-hook
- 'longlines-window-change-function t)
+ #'longlines-window-change-function t)
(when longlines-wrap-follows-window-size
(kill-local-variable 'fill-column))
(kill-local-variable 'isearch-search-fun-function)
@@ -210,7 +208,7 @@ This function exists to be called by `change-major-mode-hook' when the
major mode changes."
(longlines-mode 0))
-;; Showing the effect of hard newlines in the buffer
+;;; Showing the effect of hard newlines in the buffer
(defun longlines-show-hard-newlines (&optional arg)
"Make hard newlines visible by adding a face.
@@ -252,7 +250,7 @@ With optional argument ARG, make the hard newlines invisible again."
(setq pos (text-property-not-all (1+ pos) (point-max) 'hard nil)))
(restore-buffer-modified-p mod)))
-;; Wrapping the paragraphs.
+;;; Wrapping the paragraphs
(defun longlines-wrap-region (beg end)
"Wrap each successive line, starting with the line before BEG.
@@ -402,11 +400,12 @@ Hard newlines are left intact."
(setq pos (string-match "\n" str (1+ pos))))
str))
-;; Auto wrap
+;;; Auto wrap
(defun longlines-auto-wrap (&optional arg)
"Toggle automatic line wrapping.
-With optional argument ARG, turn on line wrapping if and only if ARG is positive.
+With optional argument ARG, turn on line wrapping if and only if
+ARG is positive.
If automatic line wrapping is turned on, wrap the entire buffer."
(interactive "P")
(setq arg (if arg
@@ -457,7 +456,7 @@ This is called by `window-configuration-change-hook'."
(setq fill-column (- (window-width) dw))
(longlines-wrap-region (point-min) (point-max)))))
-;; Isearch
+;;; Isearch
(defun longlines-search-function ()
(cond
@@ -477,22 +476,22 @@ This is called by `window-configuration-change-hook'."
(let ((search-spaces-regexp " *[ \n]"))
(re-search-forward string bound noerror count)))
-;; Loading and saving
+;;; Loading and saving
(defun longlines-before-revert-hook ()
- (add-hook 'after-revert-hook 'longlines-after-revert-hook nil t)
+ (add-hook 'after-revert-hook #'longlines-after-revert-hook nil t)
(longlines-mode 0))
(defun longlines-after-revert-hook ()
- (remove-hook 'after-revert-hook 'longlines-after-revert-hook t)
+ (remove-hook 'after-revert-hook #'longlines-after-revert-hook t)
(longlines-mode 1))
(add-to-list
'format-alist
(list 'longlines "Automatically wrap long lines." nil nil
- 'longlines-encode-region t nil))
+ #'longlines-encode-region t nil))
-;; Unloading
+;;; Unloading
(defun longlines-unload-function ()
"Unload the longlines library."
diff --git a/lisp/obsolete/lucid.el b/lisp/obsolete/lucid.el
deleted file mode 100644
index 7fd2d68f8ee..00000000000
--- a/lisp/obsolete/lucid.el
+++ /dev/null
@@ -1,211 +0,0 @@
-;;; lucid.el --- emulate some Lucid Emacs functions
-
-;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
-
-;; Maintainer: emacs-devel@gnu.org
-;; Keywords: emulations
-;; Obsolete-since: 23.2
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;; XEmacs autoloads CL so we might as well make use of it.
-(require 'cl)
-
-(defalias 'current-time-seconds 'current-time)
-
-(defun real-path-name (name &optional default)
- (file-truename (expand-file-name name default)))
-
-;; It's not clear what to return if the mouse is not in FRAME.
-(defun read-mouse-position (frame)
- (let ((pos (mouse-position)))
- (if (eq (car pos) frame)
- (cdr pos))))
-
-(defun switch-to-other-buffer (arg)
- "Switch to the previous buffer.
-With a numeric arg N, switch to the Nth most recent buffer.
-With an arg of 0, buries the current buffer at the
-bottom of the buffer stack."
- (interactive "p")
- (if (eq arg 0)
- (bury-buffer (current-buffer)))
- (switch-to-buffer
- (if (<= arg 1) (other-buffer (current-buffer))
- (nth arg
- (apply 'nconc
- (mapcar
- (lambda (buf)
- (if (= ?\ (string-to-char (buffer-name buf)))
- nil
- (list buf)))
- (buffer-list)))))))
-
-(defun device-class (&optional device)
- "Return the class (color behavior) of DEVICE.
-This will be one of `color', `grayscale', or `mono'.
-This function exists for compatibility with XEmacs."
- (cond
- ((display-color-p device) 'color)
- ((display-grayscale-p device) 'grayscale)
- (t 'mono)))
-
-(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)
-
-(defalias 'exec-to-string 'shell-command-to-string)
-
-
-;; Buffer context
-
-(defun buffer-syntactic-context (&optional buffer)
- "Syntactic context at point in BUFFER.
-Either of `string', `comment' or nil.
-This is an XEmacs compatibility function."
- (with-current-buffer (or buffer (current-buffer))
- (let ((state (syntax-ppss (point))))
- (cond
- ((nth 3 state) 'string)
- ((nth 4 state) 'comment)))))
-
-
-(defun buffer-syntactic-context-depth (&optional buffer)
- "Syntactic parenthesis depth at point in BUFFER.
-This is an XEmacs compatibility function."
- (with-current-buffer (or buffer (current-buffer))
- (nth 0 (syntax-ppss (point)))))
-
-
-;; Extents
-(defun make-extent (beg end &optional buffer)
- (make-overlay beg end buffer))
-
-(defun extent-properties (extent) (overlay-properties extent))
-(unless (fboundp 'extent-property) (defalias 'extent-property 'overlay-get))
-
-(defun extent-at (pos &optional object property before)
- (with-current-buffer (or object (current-buffer))
- (let ((overlays (overlays-at pos 'sorted)))
- (when property
- (let (filtered)
- (while overlays
- (if (overlay-get (car overlays) property)
- (setq filtered (cons (car overlays) filtered)))
- (setq overlays (cdr overlays)))
- (setq overlays filtered)))
- (if before
- (nth 1 (memq before overlays))
- (car overlays)))))
-
-(defun set-extent-property (extent prop value)
- ;; Make sure that separate adjacent extents
- ;; with the same mouse-face value
- ;; do not run together as one extent.
- (and (eq prop 'mouse-face)
- (symbolp value)
- (setq value (list value)))
- (if (eq prop 'duplicable)
- (cond ((and value (not (overlay-get extent prop)))
- ;; If becoming duplicable, copy all overlayprops to text props.
- (add-text-properties (overlay-start extent)
- (overlay-end extent)
- (overlay-properties extent)
- (overlay-buffer extent)))
- ;; If becoming no longer duplicable, remove these text props.
- ((and (not value) (overlay-get extent prop))
- (remove-text-properties (overlay-start extent)
- (overlay-end extent)
- (overlay-properties extent)
- (overlay-buffer extent))))
- ;; If extent is already duplicable, put this property
- ;; on the text as well as on the overlay.
- (if (overlay-get extent 'duplicable)
- (put-text-property (overlay-start extent)
- (overlay-end extent)
- prop value (overlay-buffer extent))))
- (overlay-put extent prop value))
-
-(defun set-extent-face (extent face)
- (set-extent-property extent 'face face))
-
-(defun set-extent-end-glyph (extent glyph)
- (set-extent-property extent 'after-string glyph))
-
-(defun delete-extent (extent)
- (set-extent-property extent 'duplicable nil)
- (delete-overlay extent))
-
-;; Support the Lucid names with `screen' instead of `frame'.
-
-(defalias 'current-screen-configuration 'current-frame-configuration)
-(defalias 'delete-screen 'delete-frame)
-(defalias 'find-file-new-screen 'find-file-other-frame)
-(defalias 'find-file-read-only-new-screen 'find-file-read-only-other-frame)
-(defalias 'find-tag-new-screen 'find-tag-other-frame)
-;;(defalias 'focus-screen 'focus-frame)
-(defalias 'iconify-screen 'iconify-frame)
-(defalias 'mail-new-screen 'mail-other-frame)
-(defalias 'make-screen-invisible 'make-frame-invisible)
-(defalias 'make-screen-visible 'make-frame-visible)
-;; (defalias 'minibuffer-screen-list 'minibuffer-frame-list)
-(defalias 'modify-screen-parameters 'modify-frame-parameters)
-(defalias 'next-screen 'next-frame)
-;; (defalias 'next-multiscreen-window 'next-multiframe-window)
-;; (defalias 'previous-multiscreen-window 'previous-multiframe-window)
-;; (defalias 'redirect-screen-focus 'redirect-frame-focus)
-(defalias 'redraw-screen 'redraw-frame)
-;; (defalias 'screen-char-height 'frame-char-height)
-;; (defalias 'screen-char-width 'frame-char-width)
-;; (defalias 'screen-configuration-to-register 'frame-configuration-to-register)
-;; (defalias 'screen-focus 'frame-focus)
-(defalias 'screen-list 'frame-list)
-;; (defalias 'screen-live-p 'frame-live-p)
-(defalias 'screen-parameters 'frame-parameters)
-(defalias 'screen-pixel-height 'frame-pixel-height)
-(defalias 'screen-pixel-width 'frame-pixel-width)
-(defalias 'screen-root-window 'frame-root-window)
-(defalias 'screen-selected-window 'frame-selected-window)
-(defalias 'lower-screen 'lower-frame)
-(defalias 'raise-screen 'raise-frame)
-(defalias 'screen-visible-p 'frame-visible-p)
-(defalias 'screenp 'framep)
-(defalias 'select-screen 'select-frame)
-(defalias 'selected-screen 'selected-frame)
-;; (defalias 'set-screen-configuration 'set-frame-configuration)
-;; (defalias 'set-screen-height 'set-frame-height)
-(defalias 'set-screen-position 'set-frame-position)
-(defalias 'set-screen-size 'set-frame-size)
-;; (defalias 'set-screen-width 'set-frame-width)
-(defalias 'switch-to-buffer-new-screen 'switch-to-buffer-other-frame)
-;; (defalias 'unfocus-screen 'unfocus-frame)
-(defalias 'visible-screen-list 'visible-frame-list)
-(defalias 'window-screen 'window-frame)
-(defalias 'x-create-screen 'x-create-frame)
-(defalias 'x-new-screen 'make-frame)
-
-(provide 'lucid)
-
-;; Local Variables:
-;; byte-compile-warnings: (not cl-functions)
-;; End:
-
-;;; lucid.el ends here
diff --git a/lisp/obsolete/mailpost.el b/lisp/obsolete/mailpost.el
index 2f74faf1d6c..5b3a76e2f79 100644
--- a/lisp/obsolete/mailpost.el
+++ b/lisp/obsolete/mailpost.el
@@ -1,4 +1,4 @@
-;;; mailpost.el --- RMAIL coupler to /usr/uci/post mailer
+;;; mailpost.el --- RMAIL coupler to /usr/uci/post mailer -*- lexical-binding: t; -*-
;; This is in the public domain
;; since Delp distributed it in 1986 without a copyright notice.
@@ -76,7 +76,7 @@ site-init."
(with-current-buffer errbuf
(erase-buffer))))
(with-file-modes 384 (setq temfile (make-temp-file ",rpost")))
- (apply 'call-process
+ (apply #'call-process
(append (list (if (boundp 'post-mail-program)
post-mail-program
"/usr/uci/lib/mh/post")
diff --git a/lisp/obsolete/mantemp.el b/lisp/obsolete/mantemp.el
index 287a5a732ca..97e70f29841 100644
--- a/lisp/obsolete/mantemp.el
+++ b/lisp/obsolete/mantemp.el
@@ -1,4 +1,4 @@
-;;; mantemp.el --- create manual template instantiations from g++ 2.7.2 output
+;;; mantemp.el --- create manual template instantiations from g++ 2.7.2 output -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/obsolete/meese.el b/lisp/obsolete/meese.el
index 81739dfa6cb..7443bacc8b2 100644
--- a/lisp/obsolete/meese.el
+++ b/lisp/obsolete/meese.el
@@ -1,4 +1,4 @@
-;;; meese.el --- protect the impressionable young minds of America
+;;; meese.el --- protect the impressionable young minds of America -*- lexical-binding: t; -*-
;; This is in the public domain on account of being distributed since
;; 1985 or 1986 without a copyright notice.
diff --git a/lisp/obsolete/messcompat.el b/lisp/obsolete/messcompat.el
index fa73dc7a0fd..be252395e45 100644
--- a/lisp/obsolete/messcompat.el
+++ b/lisp/obsolete/messcompat.el
@@ -1,4 +1,4 @@
-;;; messcompat.el --- making message mode compatible with mail mode
+;;; messcompat.el --- making message mode compatible with mail mode -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
diff --git a/lisp/mail/metamail.el b/lisp/obsolete/metamail.el
index af49e3fe4f0..72237239ddb 100644
--- a/lisp/mail/metamail.el
+++ b/lisp/obsolete/metamail.el
@@ -1,9 +1,10 @@
-;;; metamail.el --- Metamail interface for GNU Emacs
+;;; metamail.el --- Metamail interface for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1996, 2001-2021 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Keywords: mail, news, mime, multimedia
+;; Obsolete-since: 28.1
;; This file is part of GNU Emacs.
@@ -43,13 +44,11 @@
(defcustom metamail-program-name "metamail"
"Metamail program name."
- :type 'string
- :group 'metamail)
+ :type 'string)
(defcustom metamail-mailer-name "emacs"
"Mailer name set to MM_MAILER environment variable."
- :type 'string
- :group 'metamail)
+ :type 'string)
(defvar metamail-environment '("KEYHEADS=*" "MM_QUIET=1")
"Environment variables passed to `metamail'.
@@ -64,8 +63,7 @@ It is not expected to be altered globally by `set' or `setq'.
Instead, change its value temporary using `let' or `let*' form.
`-m MAILER' argument is automatically generated from the
`metamail-mailer-name' variable."
- :type '(repeat (string :tag "Switch"))
- :group 'metamail)
+ :type '(repeat (string :tag "Switch")))
;;;###autoload
(defun metamail-interpret-header ()
@@ -192,7 +190,7 @@ redisplayed as output is inserted."
(list "-m" (or metamail-mailer-name "emacs"))
(list metafile))))
;; `metamail' may not delete the temporary file!
- (condition-case error
+ (condition-case nil
(delete-file metafile)
(error nil))
)))
diff --git a/lisp/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el
index 608596e882b..36d9dc658c7 100644
--- a/lisp/obsolete/mouse-sel.el
+++ b/lisp/obsolete/mouse-sel.el
@@ -1,4 +1,4 @@
-;;; mouse-sel.el --- multi-click selection support
+;;; mouse-sel.el --- multi-click selection support -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2001-2021 Free Software Foundation, Inc.
@@ -146,20 +146,17 @@
If non-nil, \\[mouse-select] and \\[mouse-extend] will leave point at the end
of the region nearest to where the mouse last was.
If nil, point will always be placed at the beginning of the region."
- :type 'boolean
- :group 'mouse-sel)
+ :type 'boolean)
(defcustom mouse-sel-cycle-clicks t
"If non-nil, \\[mouse-select] cycles the click-counts after 4 clicks."
- :type 'boolean
- :group 'mouse-sel)
+ :type 'boolean)
(defcustom mouse-sel-default-bindings t
"Control mouse bindings."
:type '(choice (const :tag "none" nil)
(const :tag "cut and paste" interprogram-cut-paste)
- (other :tag "default bindings" t))
- :group 'mouse-sel)
+ (other :tag "default bindings" t)))
;;=== Key bindings ========================================================
@@ -216,14 +213,13 @@ the mouse position (or point, if `mouse-yank-at-point' is non-nil).
- mouse-2 while selecting or extending copies selection to the
kill ring; mouse-1 or mouse-3 kills it."
:global t
- :group 'mouse-sel
(if mouse-sel-mode
(progn
;; If mouse-2 has never been done by the user, initialize the
;; `event-kind' property to ensure that `follow-link' clicks
;; are interpreted correctly.
(put 'mouse-2 'event-kind 'mouse-click)
- (add-hook 'x-lost-selection-functions 'mouse-sel-lost-selection-hook)
+ (add-hook 'x-lost-selection-functions #'mouse-sel-lost-selection-hook)
(when mouse-sel-default-bindings
;; Save original bindings and replace them with new ones.
(setq mouse-sel-original-bindings
@@ -240,7 +236,7 @@ kill ring; mouse-1 or mouse-3 kills it."
#'mouse-sel--ignore))))
;; Restore original bindings
- (remove-hook 'x-lost-selection-functions 'mouse-sel-lost-selection-hook)
+ (remove-hook 'x-lost-selection-functions #'mouse-sel-lost-selection-hook)
(dolist (binding mouse-sel-original-bindings)
(global-set-key (car binding) (cdr binding)))
;; Restore the old values of these variables,
diff --git a/lisp/gnus/nnir.el b/lisp/obsolete/nnir.el
index 6bac245ec8e..40a8ec57b98 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -10,7 +10,9 @@
;; IMAP search improved by Daniel Pittman <daniel@rimspace.net>.
;; nnmaildir support for Swish++ and Namazu backends by:
;; Justus Piater <Justus <at> Piater.name>
+;; Mostly rewritten by Andrew Cohen <cohen@bu.edu> from 2010
;; Keywords: news mail searching ir
+;; Obsolete-since: 28.1
;; This file is part of GNU Emacs.
@@ -29,20 +31,11 @@
;;; Commentary:
-;; What does it do? Well, it allows you to search your mail using
-;; some search engine (imap, namazu, swish-e 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 `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.
+;; What does it do? Well, it searches your mail using some search
+;; engine (imap, namazu, swish-e, gmane and others -- see later).
;; The Lisp setup may involve setting a few variables and setting up the
-;; search engine. You can define the variables in the server definition
+;; search engine. You can define the variables in the server definition
;; like this :
;; (setq gnus-secondary-select-methods '(
;; (nnimap "" (nnimap-address "localhost")
@@ -53,6 +46,45 @@
;; an alist, type `C-h v nnir-engines RET' for more information; this
;; includes examples for setting `nnir-search-engine', too.)
+;; The entry to searching is the single function `nnir-run-query',
+;; which dispatches the search to the proper search function. The
+;; argument of `nnir-run-query' is an alist with two keys:
+;; 'nnir-query-spec and 'nnir-group-spec. The value for
+;; 'nnir-query-spec is an alist. The only required key/value pair is
+;; (query . "query") specifying the search string to pass to the query
+;; engine. Individual engines may have other elements. The value of
+;; 'nnir-group-spec is a list with the specification of the
+;; groups/servers to search. The format of the 'nnir-group-spec is
+;; (("server1" ("group11" "group12")) ("server2" ("group21"
+;; "group22"))). If any of the group lists is absent then all groups
+;; on that server are searched.
+
+;; The output of `nnir-run-query' is a vector, each element of which
+;; should in turn be a three-element vector with the form: [fully
+;; prefixed group-name of the article; the article number; the
+;; Retrieval Status Value (RSV)] as returned from the search engine.
+;; An RSV is the score assigned to the document by the search engine.
+;; For Boolean search engines, the RSV is always 1000 (or 1 or 100, or
+;; whatever you like).
+
+;; A vector of this form is used by the nnselect backend to create
+;; virtual groups. So nnir-run-query is a suitable function to use in
+;; nnselect groups.
+
+;; The default sorting order of articles in an nnselect summary buffer
+;; is based on the order of the articles in the above mentioned
+;; vector, so that's where you can do the sorting you'd like. Maybe
+;; it would be nice to have a way of displaying the search result
+;; sorted differently?
+
+;; So what do you need to do when you want to add another search
+;; engine? You write a function that executes the query. Temporary
+;; data from the search engine can be put in `nnir-tmp-buffer'. This
+;; 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' as a server variable.
+
;; If you use one of the local indices (namazu, find-grep, swish) you
;; must also set up a search engine backend.
@@ -75,13 +107,13 @@
;; ,----
;; | package conf; # Don't remove this line!
;; |
-;; | # Paths which will not be indexed. Don't use `^' or `$' anchors.
+;; | # Paths which will not be indexed. Don't use `^' or `$' anchors.
;; | $EXCLUDE_PATH = "spam|sent";
;; |
-;; | # Header fields which should be searchable. case-insensitive
+;; | # Header fields which should be searchable. case-insensitive
;; | $REMAIN_HEADER = "from|date|message-id|subject";
;; |
-;; | # Searchable fields. case-insensitive
+;; | # Searchable fields. case-insensitive
;; | $SEARCH_FIELD = "from|date|message-id|subject";
;; |
;; | # The max length of a word.
@@ -121,72 +153,17 @@
;; | (nnml-active-file "~/News/cache/active"))
;; `----
-;; Developer information:
-
-;; I have tried to make the code expandable. Basically, it is divided
-;; into two layers. The upper layer is somewhat like the `nnvirtual'
-;; 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
-;; function `nnir-run-query', which dispatches the search to the
-;; proper search function. The argument of `nnir-run-query' is an
-;; alist with two keys: 'nnir-query-spec and 'nnir-group-spec. The
-;; value for 'nnir-query-spec is an alist. The only required key/value
-;; pair is (query . "query") specifying the search string to pass to
-;; the query engine. Individual engines may have other elements. The
-;; value of 'nnir-group-spec is a list with the specification of the
-;; groups/servers to search. The format of the 'nnir-group-spec is
-;; (("server1" ("group11" "group12")) ("server2" ("group21"
-;; "group22"))). If any of the group lists is absent then all groups
-;; on that server are searched.
-
-;; The output of `nnir-run-query' is supposed to be a vector, each
-;; element of which should in turn be a three-element vector. The
-;; first element should be full group name of the article, the second
-;; element should be the article number, and the third element should
-;; be the Retrieval Status Value (RSV) as returned from the search
-;; engine. An RSV is the score assigned to the document by the search
-;; engine. For Boolean search engines, the RSV is always 1000 (or 1
-;; or 100, or whatever you like).
-
-;; The sorting order of the articles in the summary buffer created by
-;; nnir is based on the order of the articles in the above mentioned
-;; vector, so that's where you can do the sorting you'd like. Maybe
-;; it would be nice to have a way of displaying the search result
-;; sorted differently?
-
-;; So what do you need to do when you want to add another search
-;; engine? You write a function that executes the query. Temporary
-;; data from the search engine can be put in `nnir-tmp-buffer'. This
-;; 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' as a server variable.
;;; Code:
;;; Setup:
-(require 'nnoo)
-(require 'gnus-group)
-(require 'message)
-(require 'gnus-util)
(eval-when-compile (require 'cl-lib))
+(require 'gnus)
;;; Internal Variables:
-(defvar nnir-memo-query nil
- "Internal: stores current query.")
-
-(defvar nnir-memo-server nil
- "Internal: stores current server.")
-
-(defvar nnir-artlist nil
- "Internal: stores search result.")
+(defvar gnus-inhibit-demon)
(defvar nnir-search-history ()
"Internal: the history for querying search options in nnir.")
@@ -203,30 +180,19 @@
("to" . "TO")
("from" . "FROM")
("body" . "BODY")
- ("imap" . ""))
+ ("imap" . "")
+ ("gmail" . "X-GM-RAW"))
"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.")
+ "The IMAP search item 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.")
;;; Helper macros
-;; Data type article list.
-
-(defmacro nnir-artlist-length (artlist)
- "Return number of articles in artlist."
- `(length ,artlist))
-
-(defmacro nnir-artlist-article (artlist n)
- "Return from ARTLIST the Nth artitem (counting starting at 1)."
- `(when (> ,n 0)
- (elt ,artlist (1- ,n))))
-
(defmacro nnir-artitem-group (artitem)
"Return the group from the ARTITEM."
`(elt ,artitem 0))
@@ -239,52 +205,6 @@ email header field.")
"Return the Retrieval Status Value (RSV, score) from the ARTITEM."
`(elt ,artitem 2))
-(defmacro nnir-article-group (article)
- "Return the group for ARTICLE."
- `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
-
-(defmacro nnir-article-number (article)
- "Return the number for ARTICLE."
- `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
-
-(defmacro nnir-article-rsv (article)
- "Return the rsv for ARTICLE."
- `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
-
-(defsubst nnir-article-ids (article)
- "Return the pair `(nnir id . real id)' of ARTICLE."
- (cons article (nnir-article-number article)))
-
-(defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
- "Sort 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)
-
-(nnoo-declare nnir)
-(nnoo-define-basics nnir)
-
-(gnus-declare-backend "nnir" 'mail 'virtual)
-
;;; User Customizable Variables:
@@ -292,12 +212,9 @@ is `(VALUEFUNC member)'."
"Search groups in Gnus with assorted search engines."
:group 'gnus)
-(defcustom nnir-ignored-newsgroups ""
- "A regexp to match newsgroups in the active file that should
-be skipped when searching."
- :version "24.1"
- :type '(regexp)
- :group 'nnir)
+(make-obsolete-variable 'nnir-summary-line-format "The formatting
+specs previously unique to this variable may now be set in
+'gnus-summary-line-format." "28.1")
(defcustom nnir-summary-line-format nil
"The format specification of the lines in an nnir summary buffer.
@@ -311,40 +228,32 @@ with three items unique to nnir summary buffers:
If nil this will use `gnus-summary-line-format'."
:version "24.1"
- :type '(choice (const :tag "gnus-summary-line-format" nil) string)
- :group 'nnir)
+ :type '(choice (const :tag "gnus-summary-line-format" nil) string))
-(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.
-If this variable is nil, or if the provided function returns nil for
-a search result, `gnus-retrieve-headers' will be called instead."
+(defcustom nnir-ignored-newsgroups ""
+ "Newsgroups to skip when searching.
+Any newsgroup in the active file matching this regexp will be
+skipped when searching."
:version "24.1"
- :type '(choice (const :tag "gnus-retrieve-headers" nil) function)
- :group 'nnir)
+ :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\"."
+ "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\"."
:version "24.1"
:type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
- nnir-imap-search-arguments))
- :group 'nnir)
+ nnir-imap-search-arguments)))
(defcustom nnir-swish++-configuration-file
(expand-file-name "~/Mail/swish++.conf")
"Configuration file for swish++."
- :type '(file)
- :group 'nnir)
+ :type '(file))
(defcustom nnir-swish++-program "search"
"Name of swish++ search executable."
- :type '(string)
- :group 'nnir)
+ :type '(string))
(defcustom nnir-swish++-additional-switches '()
"A list of strings, to be given as additional arguments to swish++.
@@ -353,47 +262,32 @@ Note that this should be a list. I.e., do NOT use the following:
(setq nnir-swish++-additional-switches \"-i -w\") ; wrong
Instead, use this:
(setq nnir-swish++-additional-switches \\='(\"-i\" \"-w\"))"
- :type '(repeat (string))
- :group 'nnir)
+ :type '(repeat (string)))
(defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/")
- "The prefix to remove from each file name returned by swish++
-in order to get a group name (albeit with / instead of .). This is a
-regular expression.
+ "The prefix to remove from swish++ file names to get group names.
+Resulting names have '/' in place of '.'. This is a regular
+expression.
This variable is very similar to `nnir-namazu-remove-prefix', except
that it is for swish++, not Namazu."
- :type '(regexp)
- :group 'nnir)
+ :type '(regexp))
;; Swish-E.
-;; URL: http://swish-e.org/
-;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and
+;; URL: http://swish-e.org/ [dead link?]
+;; Variables `nnir-swish-e-index-files', `nnir-swish-e-program' and
;; `nnir-swish-e-additional-switches'
-(make-obsolete-variable 'nnir-swish-e-index-file
- 'nnir-swish-e-index-files "Emacs 23.1")
-(defcustom nnir-swish-e-index-file
- (expand-file-name "~/Mail/index.swish-e")
- "Index file for swish-e.
-This could be a server parameter.
-It is never consulted once `nnir-swish-e-index-files', which should be
-used instead, has been customized."
- :type '(file)
- :group 'nnir)
-
(defcustom nnir-swish-e-index-files
- (list nnir-swish-e-index-file)
+ (list (expand-file-name "~/Mail/index.swish-e"))
"List of index files for swish-e.
This could be a server parameter."
- :type '(repeat (file))
- :group 'nnir)
+ :type '(repeat (file)))
(defcustom nnir-swish-e-program "swish-e"
"Name of swish-e search executable.
This cannot be a server parameter."
- :type '(string)
- :group 'nnir)
+ :type '(string))
(defcustom nnir-swish-e-additional-switches '()
"A list of strings, to be given as additional arguments to swish-e.
@@ -404,27 +298,24 @@ Instead, use this:
(setq nnir-swish-e-additional-switches \\='(\"-i\" \"-w\"))
This could be a server parameter."
- :type '(repeat (string))
- :group 'nnir)
+ :type '(repeat (string)))
(defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/")
- "The prefix to remove from each file name returned by swish-e
-in order to get a group name (albeit with / instead of .). This is a
-regular expression.
+ "The prefix to remove from swish-e file names to get group names.
+Resulting names have '/' in place of '.'. This is a regular
+expression.
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)
- :group 'nnir)
+ :type '(regexp))
-;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/>
+;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/> [dead link?]
(defcustom nnir-hyrex-program "nnir-search"
"Name of the nnir-search executable."
- :type '(string)
- :group 'nnir)
+ :type '(string))
(defcustom nnir-hyrex-additional-switches '()
"A list of strings, to be given as additional arguments for nnir-search.
@@ -432,17 +323,15 @@ Note that this should be a list. I.e., do NOT use the following:
(setq nnir-hyrex-additional-switches \"-ddl ddl.xml -c nnir\") ; wrong !
Instead, use this:
(setq nnir-hyrex-additional-switches \\='(\"-ddl\" \"ddl.xml\" \"-c\" \"nnir\"))"
- :type '(repeat (string))
- :group 'nnir)
+ :type '(repeat (string)))
(defcustom nnir-hyrex-index-directory (getenv "HOME")
"Index directory for HyREX."
- :type '(directory)
- :group 'nnir)
+ :type '(directory))
(defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/")
- "The prefix to remove from each file name returned by HyREX
-in order to get a group name (albeit with / instead of .).
+ "The prefix to remove from HyREX file names to get group names.
+Resulting names have '/' in place of '.'.
For example, suppose that HyREX returns file names such as
\"/home/john/Mail/mail/misc/42\". For this example, use the following
@@ -450,20 +339,17 @@ setting: (setq nnir-hyrex-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)
+ :type '(directory))
;; Namazu engine, see <URL:http://www.namazu.org/>
(defcustom nnir-namazu-program "namazu"
"Name of Namazu search executable."
- :type '(string)
- :group 'nnir)
+ :type '(string))
(defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/")
"Index directory for Namazu."
- :type '(directory)
- :group 'nnir)
+ :type '(directory))
(defcustom nnir-namazu-additional-switches '()
"A list of strings, to be given as additional arguments to namazu.
@@ -474,12 +360,11 @@ Note that this should be a list. I.e., do NOT use the following:
(setq nnir-namazu-additional-switches \"-i -w\") ; wrong
Instead, use this:
(setq nnir-namazu-additional-switches \\='(\"-i\" \"-w\"))"
- :type '(repeat (string))
- :group 'nnir)
+ :type '(repeat (string)))
(defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/")
- "The prefix to remove from each file name returned by Namazu
-in order to get a group name (albeit with / instead of .).
+ "The prefix to remove from Namazu file names to get group names.
+Resulting names have '/' in place of '.'.
For example, suppose that Namazu returns file names such as
\"/home/john/Mail/mail/misc/42\". For this example, use the following
@@ -487,14 +372,12 @@ 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)
+ :type '(directory))
(defcustom nnir-notmuch-program "notmuch"
"Name of notmuch search executable."
:version "24.1"
- :type '(string)
- :group 'nnir)
+ :type '(string))
(defcustom nnir-notmuch-additional-switches '()
"A list of strings, to be given as additional arguments to notmuch.
@@ -504,20 +387,18 @@ Note that this should be a list. I.e., do NOT use the following:
Instead, use this:
(setq nnir-notmuch-additional-switches \\='(\"-i\" \"-w\"))"
:version "24.1"
- :type '(repeat (string))
- :group 'nnir)
+ :type '(repeat (string)))
(defcustom nnir-notmuch-remove-prefix
(regexp-quote (or (getenv "MAILDIR") (expand-file-name "~/Mail")))
- "The prefix to remove from each file name returned by notmuch
-in order to get a group name (albeit with / instead of .). This is a
-regular expression.
+ "The prefix to remove from notmuch file names to get group names.
+Resulting names have '/' in place of '.'. This is a regular
+expression.
This variable is very similar to `nnir-namazu-remove-prefix', except
that it is for notmuch, not Namazu."
:version "27.1"
- :type '(regexp)
- :group 'nnir)
+ :type '(regexp))
(defcustom nnir-notmuch-filter-group-names-function nil
"Whether and how to use Gnus group names as \"path:\" search terms.
@@ -543,7 +424,7 @@ like so:
`((imap nnir-run-imap
((criteria
"Imap Search in" ; Prompt
- ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing
+ ,(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
@@ -581,7 +462,6 @@ Add an entry here when adding a new search engine.")
(defcustom nnir-method-default-engines '((nnimap . imap))
"Alist of default search engines keyed by server method."
:version "27.1"
- :group 'nnir
:type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool)
(const nneething) (const nndir) (const nnmbox)
(const nnml) (const nnmh) (const nndraft)
@@ -590,346 +470,12 @@ Add an entry here when adding a new search engine.")
,@(mapcar (lambda (elem) (list 'const (car elem)))
nnir-engines)))))
-;; Gnus glue.
-
-(declare-function gnus-group-topic-name "gnus-topic" ())
-(declare-function gnus-topic-find-groups "gnus-topic"
- (topic &optional level all lowest recursive))
-
-(defun gnus-group-make-nnir-group (nnir-extra-parms &optional specs)
- "Create an nnir group.
-Prompt for a search query and determine the groups to search as
-follows: if called from the *Server* buffer search all groups
-belonging to the server on the current line; if called from the
-*Group* buffer search any marked groups, or the group on the current
-line, or all the groups under the current topic. Calling with a
-prefix-arg prompts for additional search-engine specific constraints.
-A non-nil `specs' arg must be an alist with `nnir-query-spec' and
-`nnir-group-spec' keys, and skips all prompting."
- (interactive "P")
- (let* ((group-spec
- (or (cdr (assq 'nnir-group-spec specs))
- (if (gnus-server-server-name)
- (list (list (gnus-server-server-name)))
- (nnir-categorize
- (or gnus-group-marked
- (if (gnus-group-group-name)
- (list (gnus-group-group-name))
- (mapcar (lambda (entry)
- (gnus-info-group (cadr entry)))
- (gnus-topic-find-groups (gnus-group-topic-name)))))
- gnus-group-server))))
- (query-spec
- (or (cdr (assq 'nnir-query-spec specs))
- (apply
- 'append
- (list (cons 'query
- (read-string "Query: " nil 'nnir-search-history)))
- (when nnir-extra-parms
- (mapcar
- (lambda (x)
- (nnir-read-parms (nnir-server-to-search-engine (car x))))
- group-spec))))))
- (gnus-group-read-ephemeral-group
- (concat "nnir-" (message-unique-id))
- (list 'nnir "nnir")
- nil
-; (cons (current-buffer) gnus-current-window-configuration)
- nil
- nil nil
- (list
- (cons 'nnir-specs (list (cons 'nnir-query-spec query-spec)
- (cons 'nnir-group-spec group-spec)))
- (cons 'nnir-artlist nil)))))
-
-(defun gnus-summary-make-nnir-group (nnir-extra-parms)
- "Search a group from the summary buffer."
- (interactive "P")
- (gnus-warp-to-article)
- (let ((spec
- (list
- (cons 'nnir-group-spec
- (list (list
- (gnus-group-server gnus-newsgroup-name)
- (list gnus-newsgroup-name)))))))
- (gnus-group-make-nnir-group nnir-extra-parms spec)))
-
-
-;; Gnus backend interface functions.
-
-(deffoo nnir-open-server (server &optional definitions)
- ;; Just set the server variables appropriately.
- (let ((backend (car (gnus-server-to-method server))))
- (if backend
- (nnoo-change-server backend server definitions)
- (add-hook 'gnus-summary-generate-hook 'nnir-mode)
- (nnoo-change-server 'nnir server definitions))))
-
-(deffoo nnir-request-group (group &optional server dont-check _info)
- (nnir-possibly-change-group group server)
- (let ((pgroup (gnus-group-guess-full-name-from-command-method group))
- length)
- ;; Check for cached search result or run the query and cache the
- ;; result.
- (unless (and nnir-artlist dont-check)
- (gnus-group-set-parameter
- pgroup 'nnir-artlist
- (setq nnir-artlist
- (nnir-run-query
- (gnus-group-get-parameter pgroup 'nnir-specs t))))
- (nnir-request-update-info pgroup (gnus-get-info pgroup)))
- (with-current-buffer nntp-server-buffer
- (if (zerop (setq length (nnir-artlist-length nnir-artlist)))
- (progn
- (nnir-close-group group)
- (nnheader-report 'nnir "Search produced empty results."))
- (nnheader-insert "211 %d %d %d %s\n"
- length ; total #
- 1 ; first #
- length ; last #
- group)))) ; group name
- nnir-artlist)
-
-(defvar gnus-inhibit-demon)
-
-(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old)
- (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)
- ;; (nnir-possibly-change-group nil server)
- (erase-buffer)
- (pcase (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
- (setq parsefunc 'nnheader-parse-nov))
- ('headers
- (setq parsefunc 'nnheader-parse-head))
- (_ (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 (and novitem
- (mail-header-number novitem)))
- (art (car (rassq artno articleids))))
- (when art
- (setf (mail-header-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)))
-
-(defvar gnus-article-decode-hook)
-
-(deffoo nnir-request-article (article &optional group server to-buffer)
- (nnir-possibly-change-group group server)
- (if (and (stringp article)
- (not (eq 'nnimap (car (gnus-server-to-method server)))))
- (nnheader-report
- 'nnir
- "nnir-request-article only groks message ids for nnimap servers: %s"
- server)
- (save-excursion
- (let ((article article)
- query)
- (when (stringp article)
- (setq gnus-override-method (gnus-server-to-method server))
- (setq query
- (list
- (cons 'query (format "HEADER Message-ID %s" article))
- (cons 'criteria "")
- (cons 'shortcut t)))
- (unless (and nnir-artlist (equal query nnir-memo-query)
- (equal server nnir-memo-server))
- (setq nnir-artlist (nnir-run-imap query server)
- nnir-memo-query query
- nnir-memo-server server))
- (setq article 1))
- (unless (zerop (nnir-artlist-length nnir-artlist))
- (let ((artfullgroup (nnir-article-group article))
- (artno (nnir-article-number article)))
- (message "Requesting article %d from group %s"
- artno artfullgroup)
- (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)
- (nnir-possibly-change-group group server)
- (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)
- (nnir-possibly-change-group group server)
- (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 ()
- (nnir-possibly-change-group gnus-newsgroup-name)
- (let* ((cur (if (> (gnus-summary-article-number) 0)
- (gnus-summary-article-number)
- (error "Can't warp to a pseudo-article")))
- (backend-article-group (nnir-article-group cur))
- (backend-article-number (nnir-article-number cur))
-; (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))
- )
-
- ;; what should we do here? we could leave all the buffers around
- ;; and assume that we have to exit from them one by one. or we can
- ;; try to clean up directly
-
- ;;first exit from the nnir summary buffer.
-; (gnus-summary-exit)
- ;; and if the nnir summary buffer in turn came from another
- ;; summary buffer we have to clean that summary up too.
- ; (when (not (eq (cdr quit-config) 'group))
-; (gnus-summary-exit))
- (gnus-summary-read-group-1 backend-article-group t t nil
- nil (list backend-article-number))))
-
-(deffoo nnir-request-update-mark (_group article mark)
- (let ((artgroup (nnir-article-group article))
- (artnumber (nnir-article-number article)))
- (or (and artgroup
- artnumber
- (gnus-request-update-mark artgroup artnumber mark))
- mark)))
-
-(deffoo nnir-request-set-mark (group actions &optional server)
- (nnir-possibly-change-group group server)
- (let (mlist)
- (dolist (action actions)
- (cl-destructuring-bind (range action marks) action
- (let ((articles-by-group (nnir-categorize
- (gnus-uncompress-range range)
- nnir-article-group nnir-article-number)))
- (dolist (artgroup articles-by-group)
- (push (list
- (car artgroup)
- (list (gnus-compress-sequence
- (sort (cadr artgroup) '<))
- action marks))
- mlist)))))
- (dolist (request (nnir-categorize mlist car cadr))
- (gnus-request-set-mark (car request) (cadr request)))))
-
-
-(deffoo nnir-request-update-info (group info &optional server)
- (nnir-possibly-change-group group server)
- ;; clear out all existing marks.
- (setf (gnus-info-marks info) nil)
- (setf (gnus-info-read info) nil)
- (let ((group (gnus-group-guess-full-name-from-command-method group))
- (articles-by-group
- (nnir-categorize
- (gnus-uncompress-range (cons 1 (nnir-artlist-length nnir-artlist)))
- nnir-article-group nnir-article-ids)))
- (gnus-set-active group
- (cons 1 (nnir-artlist-length nnir-artlist)))
- (while (not (null articles-by-group))
- (let* ((group-articles (pop articles-by-group))
- (articleids (reverse (cadr group-articles)))
- (group-info (gnus-get-info (car group-articles)))
- (marks (gnus-info-marks group-info))
- (read (gnus-info-read group-info)))
- (setf (gnus-info-read info)
- (gnus-add-to-range
- (gnus-info-read info)
- (delq nil
- (mapcar
- #'(lambda (art)
- (when (gnus-member-of-range (cdr art) read)
- (car art)))
- articleids))))
- (dolist (mark marks)
- (cl-destructuring-bind (type . range) mark
- (gnus-add-marked-articles
- group type
- (delq nil
- (mapcar
- #'(lambda (art)
- (when (gnus-member-of-range (cdr art) range) (car art)))
- articleids)))))))))
-
-
-(deffoo nnir-close-group (group &optional server)
- (nnir-possibly-change-group group server)
- (let ((pgroup (gnus-group-guess-full-name-from-command-method group)))
- (when (and nnir-artlist (not (gnus-ephemeral-group-p pgroup)))
- (gnus-group-set-parameter pgroup 'nnir-artlist nnir-artlist))
- (setq nnir-artlist nil)
- (when (gnus-ephemeral-group-p pgroup)
- (gnus-kill-ephemeral-group pgroup)
- (setq gnus-ephemeral-servers
- (delq (assq 'nnir gnus-ephemeral-servers)
- gnus-ephemeral-servers)))))
-;; (gnus-opened-servers-remove
-;; (car (assoc '(nnir "nnir-ephemeral" (nnir-address "nnir"))
-;; gnus-opened-servers))))
-
-
-
(defmacro nnir-add-result (dirnam artno score prefix server artlist)
- "Ask `nnir-compose-result' to construct a result vector,
-and if it is non-nil, add it to ARTLIST."
+ "Construct a result vector and add it to ARTLIST.
+DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to
+`nnir-compose-result' to make the vector. Only add the result if
+non-nil."
`(let ((result (nnir-compose-result ,dirnam ,artno ,score ,prefix ,server)))
(when (not (null result))
(push result ,artlist))))
@@ -939,9 +485,9 @@ and if it is non-nil, add it to ARTLIST."
;; Helper function currently used by the Swish++ and Namazu backends;
;; perhaps useful for other backends as well
(defun nnir-compose-result (dirnam article score prefix server)
- "Extract the group from DIRNAM, and create a result vector
-ready to be added to the list of search results."
-
+ "Construct a result vector.
+The DIRNAM, ARTICLE, SCORE, PREFIX, and SERVER are used to
+construct the vector entries."
;; remove nnir-*-remove-prefix from beginning of dirnam filename
(when (string-match (concat "^" prefix) dirnam)
(setq dirnam (replace-match "" t t dirnam)))
@@ -970,62 +516,64 @@ ready to be added to the list of search results."
;;; Search Engine Interfaces:
+(autoload 'gnus-server-get-active "gnus-int")
(autoload 'nnimap-change-group "nnimap")
(declare-function nnimap-buffer "nnimap" ())
(declare-function nnimap-command "nnimap" (&rest args))
;; 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."
+ "Run the QUERY search against an IMAP back-end server SRV.
+Search GROUPS, or all active groups on SRV if GROUPS is nil.
+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)))
-;; (defs (nth 2 (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))))
+ (groups
+ (or groups (gnus-server-get-active srv nnir-ignored-newsgroups))))
(message "Opening server %s" server)
(apply
- 'vconcat
+ #'vconcat
(catch 'found
(mapcar
#'(lambda (group)
- (let (artlist)
- (condition-case ()
- (when (nnimap-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)
- (when (assq 'shortcut query)
- (throw 'found (list 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)))
+ (let (artlist)
+ (condition-case ()
+ (when (nnimap-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)
+ (when (assq 'shortcut query)
+ (throw 'found (list 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
-expression, returning the string query to make.
+ "Make an IMAP search expression from QSTRING and CRITERIA.
This implements a little language designed to return the expected
results to an arbitrary query string to the end user.
@@ -1062,7 +610,7 @@ In the future the following will be added to the language:
(defun nnir-imap-query-to-imap (criteria query)
- "Turn an s-expression format QUERY into IMAP."
+ "Turn an s-expression format QUERY with CRITERIA into IMAP."
(mapconcat
;; Turn the expressions into IMAP text
(lambda (item)
@@ -1098,8 +646,9 @@ In the future the following will be added to the language:
(defun nnir-imap-parse-query (string)
- "Turn STRING into an s-expression based query based on the IMAP
-query language as defined in `nnir-imap-make-query'.
+ "Turn STRING into an s-expression query.
+STRING is based on the IMAP query language as defined in
+`nnir-imap-make-query'.
This involves turning individual tokens into higher level terms
that the search language can then understand and use."
@@ -1115,7 +664,7 @@ that the search language can then understand and use."
(defun nnir-imap-next-expr (&optional count)
- "Return the next expression from the current buffer."
+ "Return the next (COUNT) expression from the current buffer."
(let ((term (nnir-imap-next-term count))
(next (nnir-imap-peek-symbol)))
;; Are we looking at an 'or' expression?
@@ -1128,7 +677,7 @@ that the search language can then understand and use."
(defun nnir-imap-next-term (&optional count)
- "Return the next term from the current buffer."
+ "Return the next (COUNT) term from the current buffer."
(let ((term (nnir-imap-next-symbol count)))
;; What sort of term is this?
(cond
@@ -1146,9 +695,10 @@ that the search language can then understand and use."
(nnir-imap-next-symbol)))
(defun nnir-imap-next-symbol (&optional count)
- "Return the next symbol from the current buffer, or nil if we are
-at the end of the buffer. If supplied COUNT skips some symbols before
-returning the one at the supplied position."
+ "Return the next (COUNT) symbol from the current buffer.
+Return nil if we are at the end of the buffer. If supplied COUNT
+skips some symbols before returning the one at the supplied
+position."
(when (and (numberp count) (> count 1))
(nnir-imap-next-symbol (1- count)))
(let ((case-fold-search t))
@@ -1179,7 +729,7 @@ returning the one at the supplied position."
(buffer-substring start end)))))))
(defun nnir-imap-delimited-string (delimiter)
- "Return a delimited string from the current buffer."
+ "Return a string delimited by DELIMITER from the current buffer."
(let ((start (point)) end)
(forward-char 1) ; skip the first delimiter.
(while (not end)
@@ -1206,7 +756,7 @@ returning the one at the supplied position."
;; - file size
;; - group
(defun nnir-run-swish++ (query server &optional _group)
- "Run QUERY against swish++.
+ "Run QUERY on SERVER against swish++.
Returns a vector of (group name, file name) pairs (also vectors,
actually).
@@ -1234,7 +784,7 @@ Windows NT 4.0."
(when (equal "" qstring)
(error "swish++: You didn't enter anything"))
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(erase-buffer)
(if groupspec
@@ -1290,13 +840,13 @@ Windows NT 4.0."
;; Sort by score
(apply #'vector
(sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
+ (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y))))))))
;; Swish-E interface.
(defun nnir-run-swish-e (query server &optional _group)
- "Run given QUERY against swish-e.
+ "Run given QUERY on SERVER against swish-e.
Returns a vector of (group name, file name) pairs (also vectors,
actually).
@@ -1316,7 +866,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
(when (equal "" qstring)
(error "swish-e: You didn't enter anything"))
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(erase-buffer)
(message "Doing swish-e query %s..." query)
@@ -1385,12 +935,13 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
;; Sort by score
(apply #'vector
(sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
+ (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y))))))))
;; HyREX interface
(defun nnir-run-hyrex (query server &optional group)
+ "Run given QUERY with GROUP on SERVER against hyrex."
(save-excursion
(let ((artlist nil)
(groupspec (cdr (assq 'hyrex-group query)))
@@ -1401,7 +952,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
(setq groupspec
(regexp-opt
(mapcar (lambda (x) (gnus-group-real-name x)) group))))
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(erase-buffer)
(message "Doing hyrex-search query %s..." query)
(let* ((cp-list
@@ -1452,17 +1003,17 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
(message "Massaging hyrex-search output...done.")
(apply #'vector
(sort artlist
- (function (lambda (x y)
- (if (string-lessp (nnir-artitem-group x)
- (nnir-artitem-group y))
- t
- (< (nnir-artitem-number x)
- (nnir-artitem-number y)))))))
+ (lambda (x y)
+ (if (string-lessp (nnir-artitem-group x)
+ (nnir-artitem-group y))
+ t
+ (< (nnir-artitem-number x)
+ (nnir-artitem-number y))))))
)))
;; Namazu interface
(defun nnir-run-namazu (query server &optional _group)
- "Run given QUERY against Namazu.
+ "Run QUERY on SERVER against Namazu.
Returns a vector of (group name, file name) pairs (also vectors,
actually).
@@ -1480,7 +1031,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
score group article
(process-environment (copy-sequence process-environment)))
(setenv "LC_MESSAGES" "C")
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(erase-buffer)
(let* ((cp-list
`( ,nnir-namazu-program
@@ -1527,12 +1078,12 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
;; sort artlist by score
(apply #'vector
(sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
+ (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y))))))))
(defun nnir-run-notmuch (query server &optional groups)
- "Run QUERY against notmuch.
+ "Run QUERY with GROUPS from SERVER against notmuch.
Returns a vector of (group name, file name) pairs (also vectors,
actually). If GROUPS is a list of group names, use them to
construct path: search terms (see the variable
@@ -1561,7 +1112,7 @@ construct path: search terms (see the variable
(when (equal "" qstring)
(error "notmuch: You didn't enter anything"))
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(erase-buffer)
(if groups
@@ -1616,26 +1167,27 @@ construct path: search terms (see the variable
artlist)))
(defun nnir-run-find-grep (query server &optional grouplist)
- "Run find and grep to obtain matching articles."
+ "Run find and grep to QUERY GROUPLIST on SERVER for matching articles."
(let* ((method (gnus-server-to-method server))
(sym (intern
(concat (symbol-name (car method)) "-directory")))
(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))))
+ (grouplist
+ (or grouplist (gnus-server-get-active server nnir-ignored-newsgroups))))
(unless directory
(error "No directory found in method specification of server %s"
server))
(apply
- 'vconcat
+ #'vconcat
(mapcar (lambda (x)
(let ((group x)
artlist)
(message "Searching %s using find-grep..."
(or group server))
(save-window-excursion
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer (gnus-get-buffer-create nnir-tmp-buffer))
(if (> gnus-verbose 6)
(pop-to-buffer (current-buffer)))
(cd directory) ; Using relative paths simplifies
@@ -1661,7 +1213,7 @@ construct path: search terms (see the variable
(error "Cannot locate directory for group"))
(save-excursion
(apply
- 'call-process "find" nil t
+ #'call-process "find" nil t
"find" group "-maxdepth" "1" "-type" "f"
"-name" "[0-9]*" "-exec"
"grep"
@@ -1674,7 +1226,8 @@ construct path: search terms (see the variable
(let* ((path (split-string
(buffer-substring
(point)
- (line-end-position)) "/" t))
+ (line-end-position))
+ "/" t))
(art (string-to-number (car (last path)))))
(while (string= "." (car path))
(setq path (cdr path)))
@@ -1702,14 +1255,10 @@ construct path: search terms (see the variable
;;; Util Code:
-(defun gnus-nnir-group-p (group)
- "Say whether GROUP is nnir or not."
- (if (gnus-group-prefixed-p group)
- (eq 'nnir (car (gnus-find-method-for-group group)))
- (and group (string-match "^nnir" group))))
(defun nnir-read-parms (nnir-search-engine)
- "Read additional search parameters according to `nnir-engines'."
+ "Read additional search parameters for NNIR-SEARCH-ENGINE.
+Parameters are according to `nnir-engines'."
(let ((parmspec (nth 2 (assoc nnir-search-engine nnir-engines))))
(mapcar #'nnir-read-parm parmspec)))
@@ -1726,7 +1275,7 @@ PARMSPEC is a cons cell, the car is a symbol, the cdr is a prompt."
(cons sym (read-string prompt)))))
(defun nnir-run-query (specs)
- "Invoke appropriate search engine function (see `nnir-engines')."
+ "Invoke search engine appropriate for SPECS (see `nnir-engines')."
(apply #'vconcat
(mapcar
(lambda (x)
@@ -1735,10 +1284,11 @@ PARMSPEC is a cons cell, the car is a symbol, the cdr is a prompt."
(search-func (cadr (assoc search-engine nnir-engines))))
(and search-func
(funcall search-func (cdr (assq 'nnir-query-spec specs))
- server (cadr x)))))
+ server (cdr x)))))
(cdr (assq 'nnir-group-spec specs)))))
(defun nnir-server-to-search-engine (server)
+ "Find search engine for SERVER."
(or (nnir-read-server-parm 'nnir-search-engine server t)
(cdr (assoc (car (gnus-server-to-method server))
nnir-method-default-engines))))
@@ -1753,165 +1303,42 @@ environment unless NOT-GLOBAL is non-nil."
((and (not not-global) (boundp key)) (symbol-value key))
(t nil))))
-(defun nnir-possibly-change-group (group &optional server)
- (or (not server) (nnir-server-opened server) (nnir-open-server server))
- (when (gnus-nnir-group-p group)
- (setq nnir-artlist (gnus-group-get-parameter
- (gnus-group-prefixed-name
- (gnus-group-short-name group) '(nnir "nnir"))
- 'nnir-artlist t))))
-
-(defun nnir-server-opened (&optional server)
- (let ((backend (car (gnus-server-to-method server))))
- (nnoo-current-server-p (or backend 'nnir) server)))
-
-(autoload 'nnimap-make-thread-query "nnimap")
-(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
-
-(defun nnir-search-thread (header)
- "Make an nnir group based on the thread containing the article HEADER.
-The current server will be searched. If the registry is installed,
-the server that the registry reports the current article came from
-is also searched."
- (let* ((query
- (list (cons 'query (nnimap-make-thread-query header))
- (cons 'criteria "")))
- (server
- (list (list (gnus-method-to-server
- (gnus-find-method-for-group gnus-newsgroup-name)))))
- (registry-group (and
- (bound-and-true-p gnus-registry-enabled)
- (car (gnus-registry-get-id-key
- (mail-header-id header) 'group))))
- (registry-server
- (and registry-group
- (gnus-method-to-server
- (gnus-find-method-for-group registry-group)))))
- (when registry-server
- (cl-pushnew (list registry-server) server :test #'equal))
- (gnus-group-make-nnir-group nil (list
- (cons 'nnir-query-spec query)
- (cons 'nnir-group-spec server)))
- (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
-
-(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)))
- (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 (gnus-group-full-name
- (buffer-substring
- (point)
- (progn
- (skip-chars-forward "^ \t")
- (point)))
- method)
- groups))
- (forward-line))
- (while (not (eobp))
- (ignore-errors
- (push (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))
-
-;; Behind gnus-registry-enabled test.
-(declare-function gnus-registry-action "gnus-registry"
- (action data-header from &optional to method))
-
-(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)
- (when (and nnir-summary-line-format
- (not (string= nnir-summary-line-format
- gnus-summary-line-format)))
- (setq gnus-summary-line-format nnir-summary-line-format)
- (gnus-update-format-specifications nil 'summary))
- (when (bound-and-true-p gnus-registry-enabled)
- (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))))
-
-
-(defun gnus-summary-create-nnir-group ()
- (interactive)
- (or (nnir-server-opened "") (nnir-open-server "nnir"))
- (let ((name (gnus-read-group "Group name: "))
- (method '(nnir ""))
- (pgroup
- (gnus-group-guess-full-name-from-command-method gnus-newsgroup-name)))
- (with-current-buffer gnus-group-buffer
- (gnus-group-make-group
- name method nil
- (gnus-group-find-parameter pgroup)))))
-
-
-(deffoo nnir-request-create-group (group &optional _server args)
- (message "Creating nnir group %s" group)
- (let* ((group (gnus-group-prefixed-name group '(nnir "nnir")))
- (specs (assq 'nnir-specs args))
- (query-spec
- (or (cdr (assq 'nnir-query-spec specs))
- (list (cons 'query
- (read-string "Query: " nil 'nnir-search-history)))))
- (group-spec
- (or (cdr (assq 'nnir-group-spec specs))
- (list (list (read-string "Server: " nil nil)))))
- (nnir-specs (list (cons 'nnir-query-spec query-spec)
- (cons 'nnir-group-spec group-spec))))
- (gnus-group-set-parameter group 'nnir-specs nnir-specs)
- (gnus-group-set-parameter
- group 'nnir-artlist
- (or (cdr (assq 'nnir-artlist args))
- (nnir-run-query nnir-specs)))
- (nnir-request-update-info group (gnus-get-info group)))
- t)
-
-(deffoo nnir-request-delete-group (_group &optional _force _server)
- t)
-
-(deffoo nnir-request-list (&optional _server)
- t)
-
-(deffoo nnir-request-scan (_group _method)
- t)
-
-(deffoo nnir-request-close ()
- t)
-
-(nnoo-define-skeleton nnir)
-
-;; The end.
+(autoload 'gnus-group-topic-name "gnus-topic" nil nil)
+(defvar gnus-group-marked)
+(defvar gnus-topic-alist)
+
+(make-obsolete 'nnir-make-specs "This function should no longer
+be used." "28.1")
+
+(defun nnir-make-specs (nnir-extra-parms &optional specs)
+ "Make the query-spec and group-spec for a search with NNIR-EXTRA-PARMS.
+Query for the specs, or use SPECS."
+ (let* ((group-spec
+ (or (cdr (assq 'nnir-group-spec specs))
+ (if (gnus-server-server-name)
+ (list (list (gnus-server-server-name)))
+ (seq-group-by
+ (lambda (elt) (gnus-group-server elt))
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (cdr (assoc (gnus-group-topic-name) gnus-topic-alist))))))))
+ (query-spec
+ (or (cdr (assq 'nnir-query-spec specs))
+ (apply
+ #'append
+ (list (cons 'query
+ (read-string "Query: " nil 'nnir-search-history)))
+ (when nnir-extra-parms
+ (mapcar
+ (lambda (x)
+ (nnir-read-parms (nnir-server-to-search-engine (car x))))
+ group-spec))))))
+ (list (cons 'nnir-query-spec query-spec)
+ (cons 'nnir-group-spec group-spec))))
+
+(define-obsolete-function-alias 'nnir-get-active #'gnus-server-get-active "28.1")
+
(provide 'nnir)
;;; nnir.el ends here
diff --git a/lisp/obsolete/old-emacs-lock.el b/lisp/obsolete/old-emacs-lock.el
index 07bccd90711..ce4c60e6a17 100644
--- a/lisp/obsolete/old-emacs-lock.el
+++ b/lisp/obsolete/old-emacs-lock.el
@@ -1,4 +1,4 @@
-;;; emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked
+;;; old-emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -90,13 +90,13 @@ If the buffer is locked, signal error and display its name."
(setq emacs-lock-from-exiting t)))
(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)
-(add-hook 'telnet-mode-hook 'emacs-lock-was-buffer-locked)
-(add-hook 'telnet-mode-hook 'emacs-lock-shell-sentinel)
+ (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)
+(add-hook 'telnet-mode-hook #'emacs-lock-was-buffer-locked)
+(add-hook 'telnet-mode-hook #'emacs-lock-shell-sentinel)
(provide 'emacs-lock)
-;;; emacs-lock.el ends here
+;;; old-emacs-lock.el ends here
diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el
deleted file mode 100644
index 247bc1d3cec..00000000000
--- a/lisp/obsolete/old-whitespace.el
+++ /dev/null
@@ -1,801 +0,0 @@
-;;; whitespace.el --- warn about and clean bogus whitespaces in the file
-
-;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
-
-;; Author: Rajesh Vaidheeswarran <rv@gnu.org>
-;; Keywords: convenience
-;; Obsolete-since: 23.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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; URL: http://www.dsmit.com/lisp/
-;;
-;; The whitespace library is intended to find and help fix five different types
-;; of whitespace problems that commonly exist in source code.
-;;
-;; 1. Leading space (empty lines at the top of a file).
-;; 2. Trailing space (empty lines at the end of a file).
-;; 3. Indentation space (8 or more spaces at beginning of line, that should be
-;; replaced with TABS).
-;; 4. Spaces followed by a TAB. (Almost always, we never want that).
-;; 5. Spaces or TABS at the end of a line.
-;;
-;; Whitespace errors are reported in a buffer, and on the mode line.
-;;
-;; Mode line will show a W:<x>!<y> to denote a particular type of whitespace,
-;; where `x' and `y' can be one (or more) of:
-;;
-;; e - End-of-Line whitespace.
-;; i - Indentation whitespace.
-;; l - Leading whitespace.
-;; s - Space followed by Tab.
-;; t - Trailing whitespace.
-;;
-;; If any of the whitespace checks is turned off, the mode line will display a
-;; !<y>.
-;;
-;; (since (3) is the most controversial one, here is the rationale: Most
-;; terminal drivers and printer drivers have TAB configured or even
-;; hardcoded to be 8 spaces. (Some of them allow configuration, but almost
-;; always they default to 8.)
-;;
-;; Changing `tab-width' to other than 8 and editing will cause your code to
-;; look different from within Emacs, and say, if you cat it or more it, or
-;; even print it.
-;;
-;; Almost all the popular programming modes let you define an offset (like
-;; c-basic-offset or perl-indent-level) to configure the offset, so you
-;; should never have to set your `tab-width' to be other than 8 in all
-;; these modes. In fact, with an indent level of say, 4, 2 TABS will cause
-;; Emacs to replace your 8 spaces with one \t (try it). If vi users in
-;; your office complain, tell them to use vim, which distinguishes between
-;; tabstop and shiftwidth (vi equivalent of our offsets), and also ask them
-;; to set smarttab.)
-;;
-;; All the above have caused (and will cause) unwanted codeline integration and
-;; merge problems.
-;;
-;; whitespace.el will complain if it detects whitespaces on opening a file, and
-;; warn you on closing a file also (in case you had inserted any
-;; whitespaces during the process of your editing).
-;;
-;; Exported functions:
-;;
-;; `whitespace-buffer' - To check the current buffer for whitespace problems.
-;; `whitespace-cleanup' - To cleanup all whitespaces in the current buffer.
-;; `whitespace-region' - To check between point and mark for whitespace
-;; problems.
-;; `whitespace-cleanup-region' - To cleanup all whitespaces between point
-;; and mark in the current buffer.
-
-;;; Code:
-
-(defvar whitespace-version "3.5" "Version of the whitespace library.")
-
-(defvar whitespace-all-buffer-files nil
- "An associated list of buffers and files checked for whitespace cleanliness.
-
-This is to enable periodic checking of whitespace cleanliness in the files
-visited by the buffers.")
-
-(defvar whitespace-rescan-timer nil
- "Timer object used to rescan the files in buffers that have been modified.")
-
-;; Tell Emacs about this new kind of minor mode
-(defvar whitespace-mode nil
- "Non-nil when Whitespace mode (a minor mode) is enabled.")
-(make-variable-buffer-local 'whitespace-mode)
-
-(defvar whitespace-mode-line nil
- "String to display in the mode line for Whitespace mode.")
-(make-variable-buffer-local 'whitespace-mode-line)
-
-(defvar whitespace-check-buffer-leading nil
- "Test leading whitespace for file in current buffer if t.")
-(make-variable-buffer-local 'whitespace-check-buffer-leading)
-;;;###autoload(put 'whitespace-check-buffer-leading 'safe-local-variable 'booleanp)
-
-(defvar whitespace-check-buffer-trailing nil
- "Test trailing whitespace for file in current buffer if t.")
-(make-variable-buffer-local 'whitespace-check-buffer-trailing)
-;;;###autoload(put 'whitespace-check-buffer-trailing 'safe-local-variable 'booleanp)
-
-(defvar whitespace-check-buffer-indent nil
- "Test indentation whitespace for file in current buffer if t.")
-(make-variable-buffer-local 'whitespace-check-buffer-indent)
-;;;###autoload(put 'whitespace-check-buffer-indent 'safe-local-variable 'booleanp)
-
-(defvar whitespace-check-buffer-spacetab nil
- "Test Space-followed-by-TABS whitespace for file in current buffer if t.")
-(make-variable-buffer-local 'whitespace-check-buffer-spacetab)
-;;;###autoload(put 'whitespace-check-buffer-spacetab 'safe-local-variable 'booleanp)
-
-(defvar whitespace-check-buffer-ateol nil
- "Test end-of-line whitespace for file in current buffer if t.")
-(make-variable-buffer-local 'whitespace-check-buffer-ateol)
-;;;###autoload(put 'whitespace-check-buffer-ateol 'safe-local-variable 'booleanp)
-
-(defvar whitespace-highlighted-space nil
- "The variable to store the extent to highlight.")
-(make-variable-buffer-local 'whitespace-highlighted-space)
-
-(defalias 'whitespace-make-overlay
- (if (featurep 'xemacs) 'make-extent 'make-overlay))
-(defalias 'whitespace-overlay-put
- (if (featurep 'xemacs) 'set-extent-property 'overlay-put))
-(defalias 'whitespace-delete-overlay
- (if (featurep 'xemacs) 'delete-extent 'delete-overlay))
-(defalias 'whitespace-overlay-start
- (if (featurep 'xemacs) 'extent-start 'overlay-start))
-(defalias 'whitespace-overlay-end
- (if (featurep 'xemacs) 'extent-end 'overlay-end))
-(defalias 'whitespace-mode-line-update
- (if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update))
-
-(defgroup whitespace nil
- "Check for and fix five different types of whitespaces in source code."
- :version "21.1"
- :link '(emacs-commentary-link "whitespace.el")
- ;; Since XEmacs doesn't have a 'convenience group, use the next best group
- ;; which is 'editing?
- :group (if (featurep 'xemacs) 'editing 'convenience))
-
-(defcustom whitespace-check-leading-whitespace t
- "Flag to check leading whitespace. This is the global for the system.
-It can be overridden by setting a buffer local variable
-`whitespace-check-buffer-leading'."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-check-trailing-whitespace t
- "Flag to check trailing whitespace. This is the global for the system.
-It can be overridden by setting a buffer local variable
-`whitespace-check-buffer-trailing'."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-check-spacetab-whitespace t
- "Flag to check space followed by a TAB. This is the global for the system.
-It can be overridden by setting a buffer local variable
-`whitespace-check-buffer-spacetab'."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-spacetab-regexp "[ ]+\t"
- "Regexp to match one or more spaces followed by a TAB."
- :type 'regexp
- :group 'whitespace)
-
-(defcustom whitespace-check-indent-whitespace indent-tabs-mode
- "Flag to check indentation whitespace. This is the global for the system.
-It can be overridden by setting a buffer local variable
-`whitespace-check-buffer-indent'."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-indent-regexp "^\t*\\( \\)+"
- "Regexp to match multiples of eight spaces near line beginnings.
-The default value ignores leading TABs."
- :type 'regexp
- :group 'whitespace)
-
-(defcustom whitespace-check-ateol-whitespace t
- "Flag to check end-of-line whitespace. This is the global for the system.
-It can be overridden by setting a buffer local variable
-`whitespace-check-buffer-ateol'."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-ateol-regexp "[ \t]+$"
- "Regexp to match one or more TABs or spaces at line ends."
- :type 'regexp
- :group 'whitespace)
-
-(defcustom whitespace-errbuf "*Whitespace Errors*"
- "The name of the buffer where whitespace related messages will be logged."
- :type 'string
- :group 'whitespace)
-
-(defcustom whitespace-clean-msg "clean."
- "If non-nil, this message will be displayed after a whitespace check
-determines a file to be clean."
- :type 'string
- :group 'whitespace)
-
-(defcustom whitespace-abort-on-error nil
- "While writing a file, abort if the file is unclean.
-If `whitespace-auto-cleanup' is set, that takes precedence over
-this variable."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-auto-cleanup nil
- "Cleanup a buffer automatically on finding it whitespace unclean."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-silent nil
- "All whitespace errors will be shown only in the mode line when t.
-
-Note that setting this may cause all whitespaces introduced in a file to go
-unnoticed when the buffer is killed, unless the user visits the `*Whitespace
-Errors*' buffer before opening (or closing) another file."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-modes '(ada-mode asm-mode autoconf-mode awk-mode
- c-mode c++-mode cc-mode
- change-log-mode cperl-mode
- electric-nroff-mode emacs-lisp-mode
- f90-mode fortran-mode html-mode
- html3-mode java-mode jde-mode
- ksh-mode latex-mode LaTeX-mode
- lisp-mode m4-mode makefile-mode
- modula-2-mode nroff-mode objc-mode
- pascal-mode perl-mode prolog-mode
- python-mode scheme-mode sgml-mode
- sh-mode shell-script-mode simula-mode
- tcl-mode tex-mode texinfo-mode
- vrml-mode xml-mode)
-
- "Major modes in which we turn on whitespace checking.
-
-These are mostly programming and documentation modes. But you may add other
-modes that you want whitespaces checked in by adding something like the
-following to your `.emacs':
-
-\(setq whitespace-modes (cons \\='my-mode (cons \\='my-other-mode
- whitespace-modes))\)
-
-Or, alternately, you can use the Emacs `customize' command to set this."
- :type '(repeat symbol)
- :group 'whitespace)
-
-(defcustom whitespace-rescan-timer-time 600
- "Period in seconds to rescan modified buffers for whitespace creep.
-
-This is the period after which the timer will fire causing
-`whitespace-rescan-files-in-buffers' to check for whitespace creep in
-modified buffers.
-
-To disable timer scans, set this to zero."
- :type 'integer
- :group 'whitespace)
-
-(defcustom whitespace-display-in-modeline t
- "Display whitespace errors on the modeline."
- :type 'boolean
- :group 'whitespace)
-
-(defcustom whitespace-display-spaces-in-color t
- "Display the bogus whitespaces by coloring them with the face
-`whitespace-highlight'."
- :type 'boolean
- :group 'whitespace)
-
-(defface whitespace-highlight '((((class color) (background light))
- (:background "green1"))
- (((class color) (background dark))
- (:background "sea green"))
- (((class grayscale mono)
- (background light))
- (:background "black"))
- (((class grayscale mono)
- (background dark))
- (:background "white")))
- "Face used for highlighting the bogus whitespaces that exist in the buffer."
- :group 'whitespace)
-
-(if (not (assoc 'whitespace-mode minor-mode-alist))
- (setq minor-mode-alist (cons '(whitespace-mode whitespace-mode-line)
- minor-mode-alist)))
-
-(set-default 'whitespace-check-buffer-leading
- whitespace-check-leading-whitespace)
-(set-default 'whitespace-check-buffer-trailing
- whitespace-check-trailing-whitespace)
-(set-default 'whitespace-check-buffer-indent
- whitespace-check-indent-whitespace)
-(set-default 'whitespace-check-buffer-spacetab
- whitespace-check-spacetab-whitespace)
-(set-default 'whitespace-check-buffer-ateol
- whitespace-check-ateol-whitespace)
-
-(defun whitespace-check-whitespace-mode (&optional arg)
- "Test and set the whitespace-mode in qualifying buffers."
- (if (null whitespace-mode)
- (setq whitespace-mode
- (if (or arg (member major-mode whitespace-modes))
- t
- nil))))
-
-;;;###autoload
-(defun whitespace-toggle-leading-check ()
- "Toggle the check for leading space in the local buffer."
- (interactive)
- (let ((current-val whitespace-check-buffer-leading))
- (setq whitespace-check-buffer-leading (not current-val))
- (message "Will%s check for leading space in buffer."
- (if whitespace-check-buffer-leading "" " not"))
- (if whitespace-check-buffer-leading (whitespace-buffer-leading))))
-
-;;;###autoload
-(defun whitespace-toggle-trailing-check ()
- "Toggle the check for trailing space in the local buffer."
- (interactive)
- (let ((current-val whitespace-check-buffer-trailing))
- (setq whitespace-check-buffer-trailing (not current-val))
- (message "Will%s check for trailing space in buffer."
- (if whitespace-check-buffer-trailing "" " not"))
- (if whitespace-check-buffer-trailing (whitespace-buffer-trailing))))
-
-;;;###autoload
-(defun whitespace-toggle-indent-check ()
- "Toggle the check for indentation space in the local buffer."
- (interactive)
- (let ((current-val whitespace-check-buffer-indent))
- (setq whitespace-check-buffer-indent (not current-val))
- (message "Will%s check for indentation space in buffer."
- (if whitespace-check-buffer-indent "" " not"))
- (if whitespace-check-buffer-indent
- (whitespace-buffer-search whitespace-indent-regexp))))
-
-;;;###autoload
-(defun whitespace-toggle-spacetab-check ()
- "Toggle the check for space-followed-by-TABs in the local buffer."
- (interactive)
- (let ((current-val whitespace-check-buffer-spacetab))
- (setq whitespace-check-buffer-spacetab (not current-val))
- (message "Will%s check for space-followed-by-TABs in buffer."
- (if whitespace-check-buffer-spacetab "" " not"))
- (if whitespace-check-buffer-spacetab
- (whitespace-buffer-search whitespace-spacetab-regexp))))
-
-
-;;;###autoload
-(defun whitespace-toggle-ateol-check ()
- "Toggle the check for end-of-line space in the local buffer."
- (interactive)
- (let ((current-val whitespace-check-buffer-ateol))
- (setq whitespace-check-buffer-ateol (not current-val))
- (message "Will%s check for end-of-line space in buffer."
- (if whitespace-check-buffer-ateol "" " not"))
- (if whitespace-check-buffer-ateol
- (whitespace-buffer-search whitespace-ateol-regexp))))
-
-
-;;;###autoload
-(defun whitespace-buffer (&optional quiet)
- "Find five different types of white spaces in buffer.
-These are:
-1. Leading space \(empty lines at the top of a file\).
-2. Trailing space \(empty lines at the end of a file\).
-3. Indentation space \(8 or more spaces, that should be replaced with TABS\).
-4. Spaces followed by a TAB. \(Almost always, we never want that\).
-5. Spaces or TABS at the end of a line.
-
-Check for whitespace only if this buffer really contains a non-empty file
-and:
-1. the major mode is one of the whitespace-modes, or
-2. `whitespace-buffer' was explicitly called with a prefix argument."
- (interactive)
- (let ((whitespace-error nil))
- (whitespace-check-whitespace-mode current-prefix-arg)
- (if (and buffer-file-name (> (buffer-size) 0) whitespace-mode)
- (progn
- (whitespace-check-buffer-list (buffer-name) buffer-file-name)
- (whitespace-tickle-timer)
- (overlay-recenter (point-max))
- (remove-overlays nil nil 'face 'whitespace-highlight)
- (if whitespace-auto-cleanup
- (if buffer-read-only
- (if (not quiet)
- (message "Can't cleanup: %s is read-only" (buffer-name)))
- (whitespace-cleanup-internal))
- (let ((whitespace-leading (if whitespace-check-buffer-leading
- (whitespace-buffer-leading)
- nil))
- (whitespace-trailing (if whitespace-check-buffer-trailing
- (whitespace-buffer-trailing)
- nil))
- (whitespace-indent (if whitespace-check-buffer-indent
- (whitespace-buffer-search
- whitespace-indent-regexp)
- nil))
- (whitespace-spacetab (if whitespace-check-buffer-spacetab
- (whitespace-buffer-search
- whitespace-spacetab-regexp)
- nil))
- (whitespace-ateol (if whitespace-check-buffer-ateol
- (whitespace-buffer-search
- whitespace-ateol-regexp)
- nil))
- (whitespace-errmsg nil)
- (whitespace-filename buffer-file-name)
- (whitespace-this-modeline ""))
-
- ;; Now let's complain if we found any of the above.
- (setq whitespace-error (or whitespace-leading whitespace-indent
- whitespace-spacetab whitespace-ateol
- whitespace-trailing))
-
- (if whitespace-error
- (progn
- (setq whitespace-errmsg
- (concat whitespace-filename " contains:\n"
- (if whitespace-leading
- "Leading whitespace\n")
- (if whitespace-indent
- (concat "Indentation whitespace"
- whitespace-indent "\n"))
- (if whitespace-spacetab
- (concat "Space followed by Tab"
- whitespace-spacetab "\n"))
- (if whitespace-ateol
- (concat "End-of-line whitespace"
- whitespace-ateol "\n"))
- (if whitespace-trailing
- "Trailing whitespace\n")
- "\ntype `M-x whitespace-cleanup' to "
- "cleanup the file."))
- (setq whitespace-this-modeline
- (concat (if whitespace-ateol "e")
- (if whitespace-indent "i")
- (if whitespace-leading "l")
- (if whitespace-spacetab "s")
- (if whitespace-trailing "t")))))
- (whitespace-update-modeline whitespace-this-modeline)
- (if (get-buffer whitespace-errbuf)
- (kill-buffer whitespace-errbuf))
- (with-current-buffer (get-buffer-create whitespace-errbuf)
- (if whitespace-errmsg
- (progn
- (insert whitespace-errmsg)
- (if (not (or quiet whitespace-silent))
- (display-buffer (current-buffer) t))
- (if (not quiet)
- (message "Whitespaces: [%s%s] in %s"
- whitespace-this-modeline
- (let ((whitespace-unchecked
- (whitespace-unchecked-whitespaces)))
- (if whitespace-unchecked
- (concat "!" whitespace-unchecked)
- ""))
- whitespace-filename)))
- (if (and (not quiet) (not (equal whitespace-clean-msg "")))
- (message "%s %s" whitespace-filename
- whitespace-clean-msg))))))))
- whitespace-error))
-
-;;;###autoload
-(defun whitespace-region (s e)
- "Check the region for whitespace errors."
- (interactive "r")
- (save-excursion
- (save-restriction
- (narrow-to-region s e)
- (whitespace-buffer))))
-
-;;;###autoload
-(defun whitespace-cleanup ()
- "Cleanup the five different kinds of whitespace problems.
-It normally applies to the whole buffer, but in Transient Mark mode
-when the mark is active it applies to the region.
-See `whitespace-buffer' docstring for a summary of the problems."
- (interactive)
- (if (and transient-mark-mode mark-active)
- (whitespace-cleanup-region (region-beginning) (region-end))
- (whitespace-cleanup-internal)))
-
-(defun whitespace-cleanup-internal (&optional region-only)
- ;; If this buffer really contains a file, then run, else quit.
- (whitespace-check-whitespace-mode current-prefix-arg)
- (if (and buffer-file-name whitespace-mode)
- (let ((whitespace-any nil)
- (whitespace-tabwidth 8)
- (whitespace-tabwidth-saved tab-width))
-
- ;; since all printable TABS should be 8, irrespective of how
- ;; they are displayed.
- (setq tab-width whitespace-tabwidth)
-
- (if (and whitespace-check-buffer-leading
- (whitespace-buffer-leading))
- (progn
- (whitespace-buffer-leading-cleanup)
- (setq whitespace-any t)))
-
- (if (and whitespace-check-buffer-trailing
- (whitespace-buffer-trailing))
- (progn
- (whitespace-buffer-trailing-cleanup)
- (setq whitespace-any t)))
-
- (if (and whitespace-check-buffer-indent
- (whitespace-buffer-search whitespace-indent-regexp))
- (progn
- (whitespace-indent-cleanup)
- (setq whitespace-any t)))
-
- (if (and whitespace-check-buffer-spacetab
- (whitespace-buffer-search whitespace-spacetab-regexp))
- (progn
- (whitespace-buffer-cleanup whitespace-spacetab-regexp "\t")
- (setq whitespace-any t)))
-
- (if (and whitespace-check-buffer-ateol
- (whitespace-buffer-search whitespace-ateol-regexp))
- (progn
- (whitespace-buffer-cleanup whitespace-ateol-regexp "")
- (setq whitespace-any t)))
-
- ;; Call this recursively till everything is taken care of
- (if whitespace-any
- (whitespace-cleanup-internal region-only)
- ;; if we are done, talk to the user
- (progn
- (unless whitespace-silent
- (if region-only
- (message "The region is now clean")
- (message "%s is now clean" buffer-file-name)))
- (whitespace-update-modeline)))
- (setq tab-width whitespace-tabwidth-saved))))
-
-;;;###autoload
-(defun whitespace-cleanup-region (s e)
- "Whitespace cleanup on the region."
- (interactive "r")
- (save-excursion
- (save-restriction
- (narrow-to-region s e)
- (whitespace-cleanup-internal t))
- (whitespace-buffer t)))
-
-(defun whitespace-buffer-leading ()
- "Return t if the current buffer has leading newline characters.
-If highlighting is enabled, highlight these characters."
- (save-excursion
- (goto-char (point-min))
- (skip-chars-forward "\n")
- (unless (bobp)
- (whitespace-highlight-the-space (point-min) (point))
- t)))
-
-(defun whitespace-buffer-leading-cleanup ()
- "Remove any leading newline characters from current buffer."
- (save-excursion
- (goto-char (point-min))
- (skip-chars-forward "\n")
- (delete-region (point-min) (point))))
-
-(defun whitespace-buffer-trailing ()
- "Return t if the current buffer has extra trailing newline characters.
-If highlighting is enabled, highlight these characters."
- (save-excursion
- (goto-char (point-max))
- (skip-chars-backward "\n")
- (forward-line)
- (unless (eobp)
- (whitespace-highlight-the-space (point) (point-max))
- t)))
-
-(defun whitespace-buffer-trailing-cleanup ()
- "Remove extra trailing newline characters from current buffer."
- (save-excursion
- (goto-char (point-max))
- (skip-chars-backward "\n")
- (unless (eobp)
- (forward-line)
- (delete-region (point) (point-max)))))
-
-(defun whitespace-buffer-search (regexp)
- "Search for any given whitespace REGEXP."
- (with-local-quit
- (let (whitespace-retval)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (whitespace-highlight-the-space (match-beginning 0) (match-end 0))
- (push (match-beginning 0) whitespace-retval)))
- (when whitespace-retval
- (format " %s" (nreverse whitespace-retval))))))
-
-(defun whitespace-buffer-cleanup (regexp newregexp)
- "Search for any given whitespace REGEXP and replace it with the NEWREGEXP."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (replace-match newregexp))))
-
-(defun whitespace-indent-cleanup ()
- "Search for 8/more spaces at the start of a line and replace it with tabs."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward whitespace-indent-regexp nil t)
- (let ((column (current-column))
- (indent-tabs-mode t))
- (delete-region (match-beginning 0) (point))
- (indent-to column)))))
-
-(defun whitespace-unchecked-whitespaces ()
- "Return the list of whitespaces whose testing has been suppressed."
- (let ((unchecked-spaces
- (concat (if (not whitespace-check-buffer-ateol) "e")
- (if (not whitespace-check-buffer-indent) "i")
- (if (not whitespace-check-buffer-leading) "l")
- (if (not whitespace-check-buffer-spacetab) "s")
- (if (not whitespace-check-buffer-trailing) "t"))))
- (if (not (equal unchecked-spaces ""))
- unchecked-spaces
- nil)))
-
-(defun whitespace-update-modeline (&optional whitespace-err)
- "Update mode line with whitespace errors.
-Also with whitespaces whose testing has been turned off."
- (if whitespace-display-in-modeline
- (progn
- (setq whitespace-mode-line nil)
- ;; Whitespace errors
- (if (and whitespace-err (not (equal whitespace-err "")))
- (setq whitespace-mode-line whitespace-err))
- ;; Whitespace suppressed errors
- (let ((whitespace-unchecked (whitespace-unchecked-whitespaces)))
- (if whitespace-unchecked
- (setq whitespace-mode-line
- (concat whitespace-mode-line "!" whitespace-unchecked))))
- ;; Add the whitespace modeline prefix
- (setq whitespace-mode-line (if whitespace-mode-line
- (concat " W:" whitespace-mode-line)
- nil))
- (whitespace-mode-line-update))))
-
-(defun whitespace-highlight-the-space (b e)
- "Highlight the current line, unhighlighting a previously jumped to line."
- (if whitespace-display-spaces-in-color
- (let ((ol (whitespace-make-overlay b e)))
- (whitespace-overlay-put ol 'face 'whitespace-highlight))))
-
-(defun whitespace-unhighlight-the-space()
- "Unhighlight the currently highlight line."
- (if (and whitespace-display-spaces-in-color whitespace-highlighted-space)
- (progn
- (mapc 'whitespace-delete-overlay whitespace-highlighted-space)
- (setq whitespace-highlighted-space nil))))
-
-(defun whitespace-check-buffer-list (buf-name buf-file)
- "Add a buffer and its file to the whitespace monitor list.
-
-The buffer named BUF-NAME and its associated file BUF-FILE are now monitored
-periodically for whitespace."
- (if (and whitespace-mode (not (member (list buf-file buf-name)
- whitespace-all-buffer-files)))
- (add-to-list 'whitespace-all-buffer-files (list buf-file buf-name))))
-
-(defun whitespace-tickle-timer ()
- "Tickle timer to periodically to scan qualifying files for whitespace creep.
-
-If timer is not set, then set it to scan the files in
-`whitespace-all-buffer-files' periodically (defined by
-`whitespace-rescan-timer-time') for whitespace creep."
- (if (and whitespace-rescan-timer-time
- (/= whitespace-rescan-timer-time 0)
- (not whitespace-rescan-timer))
- (setq whitespace-rescan-timer
- (add-timeout whitespace-rescan-timer-time
- 'whitespace-rescan-files-in-buffers nil
- whitespace-rescan-timer-time))))
-
-(defun whitespace-rescan-files-in-buffers (&optional arg)
- "Check monitored files for whitespace creep since last scan."
- (let ((whitespace-all-my-files whitespace-all-buffer-files)
- buffile bufname thiselt buf)
- (if (not whitespace-all-my-files)
- (progn
- (disable-timeout whitespace-rescan-timer)
- (setq whitespace-rescan-timer nil))
- (while whitespace-all-my-files
- (setq thiselt (car whitespace-all-my-files))
- (setq whitespace-all-my-files (cdr whitespace-all-my-files))
- (setq buffile (car thiselt))
- (setq bufname (cadr thiselt))
- (setq buf (get-buffer bufname))
- (if (buffer-live-p buf)
- (with-current-buffer bufname
- ;;(message "buffer %s live" bufname)
- (if whitespace-mode
- (progn
- ;;(message "checking for whitespace in %s" bufname)
- (if whitespace-auto-cleanup
- (progn
- ;;(message "cleaning up whitespace in %s" bufname)
- (whitespace-cleanup-internal))
- (progn
- ;;(message "whitespace-buffer %s." (buffer-name))
- (whitespace-buffer t))))
- ;;(message "Removing %s from refresh list" bufname)
- (whitespace-refresh-rescan-list buffile bufname)))
- ;;(message "Removing %s from refresh list" bufname)
- (whitespace-refresh-rescan-list buffile bufname))))))
-
-(defun whitespace-refresh-rescan-list (buffile bufname)
- "Refresh the list of files to be rescanned for whitespace creep."
- (if whitespace-all-buffer-files
- (setq whitespace-all-buffer-files
- (delete (list buffile bufname) whitespace-all-buffer-files))
- (when whitespace-rescan-timer
- (disable-timeout whitespace-rescan-timer)
- (setq whitespace-rescan-timer nil))))
-
-;;;###autoload
-(defalias 'global-whitespace-mode 'whitespace-global-mode)
-
-;;;###autoload
-(define-minor-mode whitespace-global-mode
- "Toggle using Whitespace mode in new buffers.
-
-When this mode is active, `whitespace-buffer' is added to
-`find-file-hook' and `kill-buffer-hook'."
- :global t
- :group 'whitespace
- (if whitespace-global-mode
- (progn
- (add-hook 'find-file-hook 'whitespace-buffer)
- (add-hook 'write-file-functions 'whitespace-write-file-hook nil t)
- (add-hook 'kill-buffer-hook 'whitespace-buffer))
- (remove-hook 'find-file-hook 'whitespace-buffer)
- (remove-hook 'write-file-functions 'whitespace-write-file-hook t)
- (remove-hook 'kill-buffer-hook 'whitespace-buffer)))
-
-;;;###autoload
-(defun whitespace-write-file-hook ()
- "Hook function to be called on the buffer when whitespace check is enabled.
-This is meant to be added buffer-locally to `write-file-functions'."
- (let ((werr nil))
- (if whitespace-auto-cleanup
- (whitespace-cleanup-internal)
- (setq werr (whitespace-buffer)))
- (if (and whitespace-abort-on-error werr)
- (error "Abort write due to whitespaces in %s"
- buffer-file-name)))
- nil)
-
-(defun whitespace-unload-function ()
- "Unload the whitespace library."
- (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)
- ;; this only happens in the recursive call
- (whitespace-global-mode -1)
- (save-current-buffer
- (dolist (buf (buffer-list))
- (set-buffer buf)
- (remove-hook 'write-file-functions 'whitespace-write-file-hook t)))
- ;; continue standard unloading
- nil))
-
-(defun whitespace-unload-hook ()
- (remove-hook 'find-file-hook 'whitespace-buffer)
- (remove-hook 'write-file-functions 'whitespace-write-file-hook t)
- (remove-hook 'kill-buffer-hook 'whitespace-buffer))
-
-(add-hook 'whitespace-unload-hook 'whitespace-unload-hook)
-
-(provide 'whitespace)
-
-;;; whitespace.el ends here
diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el
index 8ff09b7da39..47f5089452f 100644
--- a/lisp/obsolete/otodo-mode.el
+++ b/lisp/obsolete/otodo-mode.el
@@ -1,4 +1,4 @@
-;;; todo-mode.el --- major mode for editing TODO list files
+;;; otodo-mode.el --- major mode for editing TODO list files -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
@@ -280,26 +280,21 @@ every day and it may also be marked on every day of the calendar.
Using \"&%%(equal (calendar-current-date) date)\" instead will only
show and mark todo entries for today, but may slow down processing of
the diary file somewhat."
- :type 'string
- :group 'todo)
+ :type 'string)
(defcustom todo-file-do (locate-user-emacs-file "todo-do" ".todo-do")
"TODO mode list file."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'todo)
+ :type 'file)
(defcustom todo-file-done (locate-user-emacs-file "todo-done" ".todo-done")
"TODO mode archive file."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'todo)
+ :type 'file)
(defcustom todo-mode-hook nil
"TODO mode hooks."
- :type 'hook
- :group 'todo)
+ :type 'hook)
(defcustom todo-edit-mode-hook nil
"TODO Edit mode hooks."
- :type 'hook
- :group 'todo)
+ :type 'hook)
(defcustom todo-insert-threshold 0
"TODO mode insertion accuracy.
@@ -314,8 +309,7 @@ your item just before that point. If you set the threshold to,
e.g. 8, it will stop as soon as the window size drops below that
amount and will insert the item in the approximate center of that
window."
- :type 'integer
- :group 'todo)
+ :type 'integer)
(defvar todo-edit-buffer " *TODO Edit*"
"TODO Edit buffer name.")
(defcustom todo-file-top (locate-user-emacs-file "todo-top" ".todo-top")
@@ -324,32 +318,26 @@ window."
Not in TODO format, but diary compatible.
Automatically generated when `todo-save-top-priorities' is non-nil."
:version "24.4" ; added locate-user-emacs-file
- :type 'string
- :group 'todo)
+ :type 'string)
(defcustom todo-print-function 'ps-print-buffer-with-faces
"Function to print the current buffer."
- :type 'symbol
- :group 'todo)
+ :type 'symbol)
(defcustom todo-show-priorities 1
"Default number of priorities to show by \\[todo-top-priorities].
0 means show all entries."
- :type 'integer
- :group 'todo)
+ :type 'integer)
(defcustom todo-print-priorities 0
"Default number of priorities to print by \\[todo-print].
0 means print all entries."
- :type 'integer
- :group 'todo)
+ :type 'integer)
(defcustom todo-remove-separator t
"Non-nil to remove category separators in\
\\[todo-top-priorities] and \\[todo-print]."
- :type 'boolean
- :group 'todo)
+ :type 'boolean)
(defcustom todo-save-top-priorities-too t
"Non-nil makes `todo-save' automatically save top-priorities in `todo-file-top'."
- :type 'boolean
- :group 'todo)
+ :type 'boolean)
;; Thanks for the ISO time stamp format go to Karl Eichwalder <ke@suse.de>
;; My format string for the appt.el package is "%3b %2d, %y, %02I:%02M%p".
@@ -358,17 +346,14 @@ Automatically generated when `todo-save-top-priorities' is non-nil."
"%:y-%02m-%02d %02H:%02M"
"TODO mode time string format for done entries.
For details see the variable `time-stamp-format'."
- :type 'string
- :group 'todo)
+ :type 'string)
(defcustom todo-entry-prefix-function 'todo-entry-timestamp-initials
"Function producing text to insert at start of todo entry."
- :type 'symbol
- :group 'todo)
+ :type 'symbol)
(defcustom todo-initials (or (getenv "INITIALS") (user-login-name))
"Initials of todo item author."
- :type 'string
- :group 'todo)
+ :type 'string)
(defun todo-entry-timestamp-initials ()
"Prepend timestamp and your initials to the head of a TODO entry."
@@ -395,25 +380,25 @@ Use `todo-categories' instead.")
(defvar todo-mode-map
(let ((map (make-keymap)))
(suppress-keymap map t)
- (define-key map "+" 'todo-forward-category)
- (define-key map "-" 'todo-backward-category)
- (define-key map "d" 'todo-file-item) ;done/delete
- (define-key map "e" 'todo-edit-item)
- (define-key map "E" 'todo-edit-multiline)
- (define-key map "f" 'todo-file-item)
- (define-key map "i" 'todo-insert-item)
- (define-key map "I" 'todo-insert-item-here)
- (define-key map "j" 'todo-jump-to-category)
- (define-key map "k" 'todo-delete-item)
- (define-key map "l" 'todo-lower-item)
- (define-key map "n" 'todo-forward-item)
- (define-key map "p" 'todo-backward-item)
- (define-key map "P" 'todo-print)
- (define-key map "q" 'todo-quit)
- (define-key map "r" 'todo-raise-item)
- (define-key map "s" 'todo-save)
- (define-key map "S" 'todo-save-top-priorities)
- (define-key map "t" 'todo-top-priorities)
+ (define-key map "+" #'todo-forward-category)
+ (define-key map "-" #'todo-backward-category)
+ (define-key map "d" #'todo-file-item) ;done/delete
+ (define-key map "e" #'todo-edit-item)
+ (define-key map "E" #'todo-edit-multiline)
+ (define-key map "f" #'todo-file-item)
+ (define-key map "i" #'todo-insert-item)
+ (define-key map "I" #'todo-insert-item-here)
+ (define-key map "j" #'todo-jump-to-category)
+ (define-key map "k" #'todo-delete-item)
+ (define-key map "l" #'todo-lower-item)
+ (define-key map "n" #'todo-forward-item)
+ (define-key map "p" #'todo-backward-item)
+ (define-key map "P" #'todo-print)
+ (define-key map "q" #'todo-quit)
+ (define-key map "r" #'todo-raise-item)
+ (define-key map "s" #'todo-save)
+ (define-key map "S" #'todo-save-top-priorities)
+ (define-key map "t" #'todo-top-priorities)
map)
"TODO mode keymap.")
@@ -451,7 +436,7 @@ Use `todo-categories' instead.")
(search-forward-regexp (concat "^" todo-category-end))
(narrow-to-region begin (line-beginning-position))
(goto-char (point-min)))))
-(defalias 'todo-cat-slct 'todo-category-select)
+(defalias 'todo-cat-slct #'todo-category-select)
(defun todo-forward-category ()
"Go forward to TODO list of next category."
@@ -459,7 +444,7 @@ Use `todo-categories' instead.")
(setq todo-category-number
(mod (1+ todo-category-number) (length todo-categories)))
(todo-category-select))
-(defalias 'todo-cmd-forw 'todo-forward-category)
+(defalias 'todo-cmd-forw #'todo-forward-category)
(defun todo-backward-category ()
"Go back to TODO list of previous category."
@@ -467,14 +452,14 @@ Use `todo-categories' instead.")
(setq todo-category-number
(mod (1- todo-category-number) (length todo-categories)))
(todo-category-select))
-(defalias 'todo-cmd-back 'todo-backward-category)
+(defalias 'todo-cmd-back #'todo-backward-category)
(defun todo-backward-item ()
"Select previous entry of TODO list."
(interactive)
(search-backward-regexp (concat "^" (regexp-quote todo-prefix)) nil t)
(message ""))
-(defalias 'todo-cmd-prev 'todo-backward-item)
+(defalias 'todo-cmd-prev #'todo-backward-item)
(defun todo-forward-item (&optional count)
"Select COUNT-th next entry of TODO list."
@@ -485,7 +470,7 @@ Use `todo-categories' instead.")
nil 'goto-end count)
(beginning-of-line)
(message ""))
-(defalias 'todo-cmd-next 'todo-forward-item)
+(defalias 'todo-cmd-next #'todo-forward-item)
(defun todo-save ()
"Save the TODO list."
@@ -494,7 +479,7 @@ Use `todo-categories' instead.")
(save-restriction
(save-buffer)))
(if todo-save-top-priorities-too (todo-save-top-priorities)))
-(defalias 'todo-cmd-save 'todo-save)
+(defalias 'todo-cmd-save #'todo-save)
(defun todo-quit ()
"Done with TODO list for now."
@@ -503,7 +488,7 @@ Use `todo-categories' instead.")
(todo-save)
(message "")
(bury-buffer))
-(defalias 'todo-cmd-done 'todo-quit)
+(defalias 'todo-cmd-done #'todo-quit)
(defun todo-edit-item ()
"Edit current TODO list entry."
@@ -518,7 +503,7 @@ Use `todo-categories' instead.")
(todo-backward-item)
(message ""))))
(error "No TODO list entry to edit")))
-(defalias 'todo-cmd-edit 'todo-edit-item)
+(defalias 'todo-cmd-edit #'todo-edit-item)
(defun todo-edit-multiline ()
"Set up a buffer for editing a multiline TODO list entry."
@@ -622,7 +607,7 @@ category."
(category (if arg (todo-completing-read) current-category)))
(todo-add-item-non-interactively new-item category))))
-(defalias 'todo-cmd-inst 'todo-insert-item)
+(defalias 'todo-cmd-inst #'todo-insert-item)
(defun todo-insert-item-here ()
"Insert a new TODO list entry directly above the entry at point.
@@ -650,7 +635,7 @@ If point is on an empty line, insert the entry there."
(setq todo-previous-answer
(y-or-n-p (format-message "More important than `%s'? " item)))))
todo-previous-answer)
-(defalias 'todo-ask-p 'todo-more-important-p)
+(defalias 'todo-ask-p #'todo-more-important-p)
(defun todo-delete-item ()
"Delete current TODO list entry."
@@ -664,7 +649,7 @@ If point is on an empty line, insert the entry there."
(todo-backward-item))
(message ""))
(error "No TODO list entry to delete")))
-(defalias 'todo-cmd-kill 'todo-delete-item)
+(defalias 'todo-cmd-kill #'todo-delete-item)
(defun todo-raise-item ()
"Raise priority of current entry."
@@ -677,7 +662,7 @@ If point is on an empty line, insert the entry there."
(insert item "\n"))
(message ""))
(error "No TODO list entry to raise")))
-(defalias 'todo-cmd-rais 'todo-raise-item)
+(defalias 'todo-cmd-rais #'todo-raise-item)
(defun todo-lower-item ()
"Lower priority of current entry."
@@ -691,7 +676,7 @@ If point is on an empty line, insert the entry there."
(insert item "\n"))
(message ""))
(error "No TODO list entry to lower")))
-(defalias 'todo-cmd-lowr 'todo-lower-item)
+(defalias 'todo-cmd-lowr #'todo-lower-item)
(defun todo-file-item (&optional comment)
"File the current TODO list entry away, annotated with an optional COMMENT."
@@ -923,7 +908,8 @@ If INCLUDE-SEP is non-nil, return point after the separator."
;;;###autoload
(define-derived-mode todo-mode nil "TODO"
"Major mode for editing TODO lists."
- (easy-menu-add todo-menu))
+ (when (featurep 'xemacs)
+ (easy-menu-add todo-menu)))
(with-suppressed-warnings ((lexical date entry))
(defvar date)
@@ -977,4 +963,4 @@ If INCLUDE-SEP is non-nil, return point after the separator."
(provide 'todo-mode)
-;;; todo-mode.el ends here
+;;; otodo-mode.el ends here
diff --git a/lisp/obsolete/patcomp.el b/lisp/obsolete/patcomp.el
index 8545f0721fa..2c35cb07007 100644
--- a/lisp/obsolete/patcomp.el
+++ b/lisp/obsolete/patcomp.el
@@ -1,4 +1,4 @@
-;;; patcomp.el --- used by patch files to update Emacs releases
+;;; patcomp.el --- used by patch files to update Emacs releases -*- lexical-binding: t; -*-
;; This file is part of GNU Emacs.
diff --git a/lisp/obsolete/pc-mode.el b/lisp/obsolete/pc-mode.el
index d4c90c2b298..cf0bc28b110 100644
--- a/lisp/obsolete/pc-mode.el
+++ b/lisp/obsolete/pc-mode.el
@@ -1,4 +1,4 @@
-;;; pc-mode.el --- emulate certain key bindings used on PCs
+;;; pc-mode.el --- emulate certain key bindings used on PCs -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -40,16 +40,16 @@ C-Escape does list-buffers."
(define-key function-key-map [delete] "\C-d")
(define-key function-key-map [M-delete] [?\M-d])
(define-key function-key-map [C-delete] [?\M-d])
- (global-set-key [C-M-delete] 'kill-sexp)
- (global-set-key [C-backspace] 'backward-kill-word)
- (global-set-key [M-backspace] 'undo)
+ (global-set-key [C-M-delete] #'kill-sexp)
+ (global-set-key [C-backspace] #'backward-kill-word)
+ (global-set-key [M-backspace] #'undo)
- (global-set-key [C-escape] 'list-buffers)
+ (global-set-key [C-escape] #'list-buffers)
- (global-set-key [home] 'beginning-of-line)
- (global-set-key [end] 'end-of-line)
- (global-set-key [C-home] 'beginning-of-buffer)
- (global-set-key [C-end] 'end-of-buffer))
+ (global-set-key [home] #'beginning-of-line)
+ (global-set-key [end] #'end-of-line)
+ (global-set-key [C-home] #'beginning-of-buffer)
+ (global-set-key [C-end] #'end-of-buffer))
(provide 'pc-mode)
diff --git a/lisp/obsolete/pc-select.el b/lisp/obsolete/pc-select.el
index 3f184881096..f999f507972 100644
--- a/lisp/obsolete/pc-select.el
+++ b/lisp/obsolete/pc-select.el
@@ -1,4 +1,4 @@
-;;; pc-select.el --- emulate mark, cut, copy and paste from Motif
+;;; pc-select.el --- emulate mark, cut, copy and paste from Motif -*- lexical-binding: t; -*-
;;; (or MAC GUI or MS-windoze (bah)) look-and-feel
;;; including key bindings.
@@ -94,25 +94,21 @@ 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)
+ :type 'boolean)
(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)
+ :type 'boolean)
(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)
+ :type 'boolean)
(defcustom pc-selection-mode-hook nil
"The hook to run when PC Selection mode is toggled."
- :type 'hook
- :group 'pc-select)
+ :type 'hook)
(defvar pc-select-saved-settings-alist nil
"The values of the variables before PC Selection mode was toggled on.
@@ -318,9 +314,6 @@ but before calling PC Selection mode):
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
diff --git a/lisp/obsolete/pgg-def.el b/lisp/obsolete/pgg-def.el
index 425093832f8..4d30e326148 100644
--- a/lisp/obsolete/pgg-def.el
+++ b/lisp/obsolete/pgg-def.el
@@ -1,4 +1,4 @@
-;;; pgg-def.el --- functions/macros for defining PGG functions
+;;; pgg-def.el --- functions/macros for defining PGG functions -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2002-2021 Free Software Foundation, Inc.
@@ -32,47 +32,39 @@
(defcustom pgg-default-scheme 'gpg
"Default PGP scheme."
- :group 'pgg
:type '(choice (const :tag "GnuPG" gpg)
(const :tag "PGP 5" pgp5)
(const :tag "PGP" pgp)))
(defcustom pgg-default-user-id (user-login-name)
"User ID of your default identity."
- :group 'pgg
:type 'string)
(defcustom pgg-default-keyserver-address "subkeys.pgp.net"
"Host name of keyserver."
- :group 'pgg
:type 'string)
(defcustom pgg-query-keyserver nil
"Whether PGG queries keyservers for missing keys when verifying messages."
:version "22.1"
- :group 'pgg
:type 'boolean)
(defcustom pgg-encrypt-for-me t
"If t, encrypt all outgoing messages with user's public key."
- :group 'pgg
:type 'boolean)
(defcustom pgg-cache-passphrase t
"If t, cache passphrase."
- :group 'pgg
:type 'boolean)
(defcustom pgg-passphrase-cache-expiry 16
"How many seconds the passphrase is cached.
Whether the passphrase is cached at all is controlled by
`pgg-cache-passphrase'."
- :group 'pgg
:type 'integer)
(defcustom pgg-passphrase-coding-system nil
"Coding system to encode passphrase."
- :group 'pgg
:type 'coding-system)
(defvar pgg-messages-coding-system nil
diff --git a/lisp/obsolete/pgg-gpg.el b/lisp/obsolete/pgg-gpg.el
index 90255fe2f7d..d06a485b975 100644
--- a/lisp/obsolete/pgg-gpg.el
+++ b/lisp/obsolete/pgg-gpg.el
@@ -1,4 +1,4 @@
-;;; pgg-gpg.el --- GnuPG support for PGG.
+;;; pgg-gpg.el --- GnuPG support for PGG. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2000, 2002-2021 Free Software Foundation, Inc.
@@ -37,23 +37,19 @@
(defcustom pgg-gpg-program "gpg"
"The GnuPG executable."
- :group 'pgg-gpg
:type 'string)
(defcustom pgg-gpg-extra-args nil
"Extra arguments for every GnuPG invocation."
- :group 'pgg-gpg
:type '(repeat (string :tag "Argument")))
(defcustom pgg-gpg-recipient-argument "--recipient"
"GnuPG option to specify recipient."
- :group 'pgg-gpg
:type '(choice (const :tag "New `--recipient' option" "--recipient")
(const :tag "Old `--remote-user' option" "--remote-user")))
(defcustom pgg-gpg-use-agent t
"Whether to use gnupg agent for key caching."
- :group 'pgg-gpg
:type 'boolean)
(defvar pgg-gpg-user-id nil
@@ -97,7 +93,7 @@
passphrase-with-newline
(coding-system-change-eol-conversion
pgg-passphrase-coding-system 'unix)))
- (pgg-clear-string passphrase-with-newline))
+ (clear-string passphrase-with-newline))
(setq encoded-passphrase-with-new-line passphrase-with-newline
passphrase-with-newline nil))
(process-send-string process encoded-passphrase-with-new-line))
@@ -125,9 +121,9 @@
(if (= 127 exit-status)
(error "%s could not be found" program))))
(if passphrase-with-newline
- (pgg-clear-string passphrase-with-newline))
+ (clear-string passphrase-with-newline))
(if encoded-passphrase-with-new-line
- (pgg-clear-string encoded-passphrase-with-new-line))
+ (clear-string encoded-passphrase-with-new-line))
(if (and process (eq 'run (process-status process)))
(interrupt-process process))
(if (file-exists-p output-file-name)
diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el
index edb5d4f6775..2c76365a415 100644
--- a/lisp/obsolete/pgg-parse.el
+++ b/lisp/obsolete/pgg-parse.el
@@ -1,4 +1,4 @@
-;;; pgg-parse.el --- OpenPGP packet parsing
+;;; pgg-parse.el --- OpenPGP packet parsing -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2002-2021 Free Software Foundation, Inc.
@@ -44,14 +44,12 @@
(defcustom pgg-parse-public-key-algorithm-alist
'((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
"Alist of the assigned number to the public key algorithm."
- :group 'pgg-parse
:type '(repeat
(cons (sexp :tag "Number") (sexp :tag "Type"))))
(defcustom pgg-parse-symmetric-key-algorithm-alist
'((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
"Alist of the assigned number to the symmetric key algorithm."
- :group 'pgg-parse
:type '(repeat
(cons (sexp :tag "Number") (sexp :tag "Type"))))
@@ -59,7 +57,6 @@
'((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
(10 . SHA512))
"Alist of the assigned number to the cryptographic hash algorithm."
- :group 'pgg-parse
:type '(repeat
(cons (sexp :tag "Number") (sexp :tag "Type"))))
@@ -68,7 +65,6 @@
(1 . ZIP)
(2 . ZLIB))
"Alist of the assigned number to the compression algorithm."
- :group 'pgg-parse
:type '(repeat
(cons (sexp :tag "Number") (sexp :tag "Type"))))
@@ -87,13 +83,11 @@
(48 . "Certification revocation signature")
(64 . "Timestamp signature."))
"Alist of the assigned number to the signature type."
- :group 'pgg-parse
:type '(repeat
(cons (sexp :tag "Number") (sexp :tag "Type"))))
(defcustom pgg-ignore-packet-checksum t; XXX
"If non-nil checksum of each ascii armored packet will be ignored."
- :group 'pgg-parse
:type 'boolean)
(defvar pgg-armor-header-lines
@@ -148,7 +142,7 @@
;; `(string-to-number-list (pgg-read-body-string ,ptag))
)
-(defalias 'pgg-skip-bytes 'forward-char)
+(defalias 'pgg-skip-bytes #'forward-char)
(defmacro pgg-skip-header (ptag)
`(pgg-skip-bytes (nth 2 ,ptag)))
@@ -345,7 +339,7 @@
;; 100 to 110 = internal or user-defined
))
-(defun pgg-parse-signature-packet (ptag)
+(defun pgg-parse-signature-packet (_ptag)
(let* ((signature-version (pgg-byte-after))
(result (list (cons 'version signature-version)))
hashed-material field n)
@@ -411,7 +405,7 @@
pgg-parse-hash-algorithm-alist)))
result))
-(defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
+(defun pgg-parse-public-key-encrypted-session-key-packet (_ptag)
(let (result)
(pgg-set-alist result
'version (pgg-read-byte))
@@ -425,7 +419,7 @@
pgg-parse-public-key-algorithm-alist)))
result))
-(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
+(defun pgg-parse-symmetric-key-encrypted-session-key-packet (_ptag)
(let (result)
(pgg-set-alist result
'version
@@ -436,7 +430,7 @@
pgg-parse-symmetric-key-algorithm-alist)))
result))
-(defun pgg-parse-public-key-packet (ptag)
+(defun pgg-parse-public-key-packet (_ptag)
(let* ((key-version (pgg-read-byte))
(result (list (cons 'version key-version)))
field)
diff --git a/lisp/obsolete/pgg-pgp.el b/lisp/obsolete/pgg-pgp.el
index e02032a6a57..665be0b2e2c 100644
--- a/lisp/obsolete/pgg-pgp.el
+++ b/lisp/obsolete/pgg-pgp.el
@@ -1,4 +1,4 @@
-;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
+;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2000, 2002-2021 Free Software Foundation, Inc.
@@ -35,23 +35,19 @@
(defcustom pgg-pgp-program "pgp"
"PGP 2.* and 6.* executable."
- :group 'pgg-pgp
:type 'string)
(defcustom pgg-pgp-shell-file-name "/bin/sh"
"File name to load inferior shells from.
Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
- :group 'pgg-pgp
:type 'string)
(defcustom pgg-pgp-shell-command-switch "-c"
"Switch used to have the shell execute its command line argument."
- :group 'pgg-pgp
:type 'string)
(defcustom pgg-pgp-extra-args nil
"Extra arguments for every PGP invocation."
- :group 'pgg-pgp
:type '(choice
(const :tag "None" nil)
(string :tag "Arguments")))
@@ -112,7 +108,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(delete-file errors-file-name)
(file-error nil)))))
-(defun pgg-pgp-lookup-key (string &optional type)
+(defun pgg-pgp-lookup-key (string &optional _type)
"Search keys associated with STRING."
(let ((args (list "+batchmode" "+language=en" "-kv" string)))
(with-current-buffer (get-buffer-create pgg-output-buffer)
@@ -133,7 +129,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase)
"Encrypt the current region between START and END."
(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
- (passphrase (or passphrase
+ (_passphrase (or passphrase
(when sign
(pgg-read-passphrase
(format "PGP passphrase for %s: "
@@ -143,10 +139,11 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(concat
"+encrypttoself=off +verbose=1 +batchmode +language=us -fate "
(if (or recipients pgg-encrypt-for-me)
- (mapconcat 'shell-quote-argument
+ (mapconcat #'shell-quote-argument
(append recipients
(if pgg-encrypt-for-me
- (list pgg-pgp-user-id))) " "))
+ (list pgg-pgp-user-id)))
+ " "))
(if sign (concat " -s -u " (shell-quote-argument pgg-pgp-user-id))))))
(pgg-pgp-process-region start end nil pgg-pgp-program args)
(pgg-process-when-success nil)))
@@ -203,6 +200,7 @@ passphrase cache or user."
(let* ((orig-file (pgg-make-temp-file "pgg"))
(args "+verbose=1 +batchmode +language=us"))
(with-file-modes 448
+ (defvar jam-zcat-filename-list)
(let ((coding-system-for-write 'binary)
jka-compr-compression-info-list jam-zcat-filename-list)
(write-region start end orig-file)))
diff --git a/lisp/obsolete/pgg-pgp5.el b/lisp/obsolete/pgg-pgp5.el
index 42ff1ca2bd6..d9523172418 100644
--- a/lisp/obsolete/pgg-pgp5.el
+++ b/lisp/obsolete/pgg-pgp5.el
@@ -1,4 +1,4 @@
-;;; pgg-pgp5.el --- PGP 5.* support for PGG.
+;;; pgg-pgp5.el --- PGP 5.* support for PGG. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2000, 2002-2021 Free Software Foundation, Inc.
@@ -35,38 +35,31 @@
(defcustom pgg-pgp5-pgpe-program "pgpe"
"PGP 5.* `pgpe' executable."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-pgps-program "pgps"
"PGP 5.* `pgps' executable."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-pgpk-program "pgpk"
"PGP 5.* `pgpk' executable."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-pgpv-program "pgpv"
"PGP 5.* `pgpv' executable."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-shell-file-name "/bin/sh"
"File name to load inferior shells from.
Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-shell-command-switch "-c"
"Switch used to have the shell execute its command line argument."
- :group 'pgg-pgp5
:type 'string)
(defcustom pgg-pgp5-extra-args nil
"Extra arguments for every PGP 5.* invocation."
- :group 'pgg-pgp5
:type '(choice
(const :tag "None" nil)
(string :tag "Arguments")))
@@ -128,7 +121,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(delete-file errors-file-name)
(file-error nil)))))
-(defun pgg-pgp5-lookup-key (string &optional type)
+(defun pgg-pgp5-lookup-key (string &optional _type)
"Search keys associated with STRING."
(let ((args (list "+language=en" "-l" string)))
(with-current-buffer (get-buffer-create pgg-output-buffer)
@@ -145,7 +138,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(defun pgg-pgp5-encrypt-region (start end recipients &optional sign passphrase)
"Encrypt the current region between START and END."
(let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
- (passphrase (or passphrase
+ (_passphrase (or passphrase
(when sign
(pgg-read-passphrase
(format "PGP passphrase for %s: "
@@ -209,6 +202,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(let ((orig-file (pgg-make-temp-file "pgg"))
(args '("+verbose=1" "+batchmode=1" "+language=us")))
(with-file-modes 448
+ (defvar jam-zcat-filename-list) ;Not sure where this comes from.
(let ((coding-system-for-write 'binary)
jka-compr-compression-info-list jam-zcat-filename-list)
(write-region start end orig-file)))
diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el
index ec93eeb93f8..5ed59933f23 100644
--- a/lisp/obsolete/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -1,4 +1,4 @@
-;;; pgg.el --- glue for the various PGP implementations.
+;;; pgg.el --- glue for the various PGP implementations. -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2000, 2002-2021 Free Software Foundation, Inc.
@@ -27,99 +27,19 @@
(require 'pgg-def)
(require 'pgg-parse)
-(autoload 'run-at-time "timer")
(eval-when-compile (require 'cl-lib))
;;; @ utility functions
;;;
-(eval-when-compile
- (when (featurep 'xemacs)
- (defmacro pgg-run-at-time-1 (time repeat function args)
- (if (condition-case nil
- (let ((delete-itimer 'delete-itimer)
- (itimer-driver-start 'itimer-driver-start)
- (itimer-value 'itimer-value)
- (start-itimer 'start-itimer))
- (unless (or (symbol-value 'itimer-process)
- (symbol-value 'itimer-timer))
- (funcall itimer-driver-start))
- ;; Check whether there is a bug to which the difference of
- ;; the present time and the time when the itimer driver was
- ;; woken up is subtracted from the initial itimer value.
- (let* ((inhibit-quit t)
- (ctime (current-time))
- (itimer-timer-last-wakeup
- (prog1
- ctime
- (setcar ctime (1- (car ctime)))))
- (itimer-list nil)
- (itimer (funcall start-itimer "pgg-run-at-time"
- 'ignore 5)))
- (sleep-for 0.1) ;; Accept the timeout interrupt.
- (prog1
- (> (funcall itimer-value itimer) 0)
- (funcall delete-itimer itimer))))
- (error nil))
- `(let ((time ,time))
- (apply #'start-itimer "pgg-run-at-time"
- ,function (if time (max time 1e-9) 1e-9)
- ,repeat nil t ,args))
- `(let ((time ,time)
- (itimers (list nil)))
- (setcar
- itimers
- (apply #'start-itimer "pgg-run-at-time"
- (lambda (itimers repeat function &rest args)
- (let ((itimer (car itimers)))
- (if repeat
- (progn
- (set-itimer-function
- itimer
- (lambda (itimer repeat function &rest args)
- (set-itimer-restart itimer repeat)
- (set-itimer-function itimer function)
- (set-itimer-function-arguments itimer args)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer repeat function) args)))
- (set-itimer-function
- itimer
- (lambda (itimer function &rest args)
- (delete-itimer itimer)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer function) args)))))
- 1e-9 (if time (max time 1e-9) 1e-9)
- nil t itimers ,repeat ,function ,args)))))))
-
-(eval-and-compile
- (if (featurep 'xemacs)
- (progn
- (defun pgg-run-at-time (time repeat function &rest args)
- "Emulating function run as `run-at-time'.
-TIME should be nil meaning now, or a number of seconds from now.
-Return an itimer object which can be used in either `delete-itimer'
-or `cancel-timer'."
- (pgg-run-at-time-1 time repeat function args))
- (defun pgg-cancel-timer (timer)
- "Emulate cancel-timer for xemacs."
- (let ((delete-itimer 'delete-itimer))
- (funcall delete-itimer timer))))
- (defalias 'pgg-run-at-time 'run-at-time)
- (defalias 'pgg-cancel-timer 'cancel-timer)))
-
(defun pgg-invoke (func scheme &rest args)
(progn
(require (intern (format "pgg-%s" scheme)))
- (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
-
-(put 'pgg-save-coding-system 'lisp-indent-function 2)
+ (apply #'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
(defmacro pgg-save-coding-system (start end &rest body)
+ (declare (indent 2) (debug t))
`(if (called-interactively-p 'interactive)
(let ((buffer (current-buffer)))
(with-temp-buffer
@@ -209,23 +129,16 @@ regulate cache behavior."
(let* ((key (if notruncate key (pgg-truncate-key-identifier key)))
(interned-timer-key (intern-soft key pgg-pending-timers))
(old-timer (symbol-value interned-timer-key))
- new-timer)
+ ) ;; new-timer
(when old-timer
(cancel-timer old-timer)
(unintern interned-timer-key pgg-pending-timers))
(set (intern key pgg-passphrase-cache)
passphrase)
(set (intern key pgg-pending-timers)
- (pgg-run-at-time pgg-passphrase-cache-expiry nil
- #'pgg-remove-passphrase-from-cache
- key notruncate))))
-
-(if (fboundp 'clear-string)
- (defalias 'pgg-clear-string 'clear-string)
- (defun pgg-clear-string (string)
- (fillarray string ?_)))
-
-(declare-function pgg-clear-string "pgg" (string))
+ (run-at-time pgg-passphrase-cache-expiry nil
+ #'pgg-remove-passphrase-from-cache
+ key notruncate))))
(defun pgg-remove-passphrase-from-cache (key &optional notruncate)
"Omit passphrase associated with KEY in time-limited passphrase cache.
@@ -245,10 +158,10 @@ regulate cache behavior."
(interned-timer-key (intern-soft key pgg-pending-timers))
(old-timer (symbol-value interned-timer-key)))
(when passphrase
- (pgg-clear-string passphrase)
+ (clear-string passphrase)
(unintern key pgg-passphrase-cache))
(when old-timer
- (pgg-cancel-timer old-timer)
+ (cancel-timer old-timer)
(unintern interned-timer-key pgg-pending-timers))))
(defmacro pgg-convert-lbt-region (start end lbt)
@@ -265,9 +178,8 @@ regulate cache behavior."
(while (re-search-forward "\r$" pgg-conversion-end t)
(replace-match ""))))))
-(put 'pgg-as-lbt 'lisp-indent-function 3)
-
(defmacro pgg-as-lbt (start end lbt &rest body)
+ (declare (indent 3) (debug t))
`(let ((inhibit-read-only t)
buffer-read-only
buffer-undo-list)
@@ -277,9 +189,8 @@ regulate cache behavior."
(push nil buffer-undo-list)
(ignore-errors (undo))))
-(put 'pgg-process-when-success 'lisp-indent-function 0)
-
(defmacro pgg-process-when-success (&rest body)
+ (declare (indent 0) (debug t))
`(with-current-buffer pgg-output-buffer
(if (zerop (buffer-size)) nil ,@body t)))
@@ -377,7 +288,7 @@ passphrase cache or user."
If optional PASSPHRASE is not specified, it will be obtained from the
passphrase cache or user."
(interactive "r")
- (let* ((buf (current-buffer))
+ (let* (;; (buf (current-buffer))
(status
(pgg-save-coding-system start end
(pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el
index 581ebcad6f4..d7020f0d074 100644
--- a/lisp/obsolete/rcompile.el
+++ b/lisp/obsolete/rcompile.el
@@ -1,4 +1,4 @@
-;;; rcompile.el --- run a compilation on a remote machine
+;;; rcompile.el --- run a compilation on a remote machine -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -76,33 +76,28 @@
(defcustom remote-compile-host nil
"Host for remote compilations."
- :type '(choice string (const nil))
- :group 'remote-compile)
+ :type '(choice string (const nil)))
(defcustom remote-compile-user nil
"User for remote compilations.
nil means use the value returned by \\[user-login-name]."
- :type '(choice string (const nil))
- :group 'remote-compile)
+ :type '(choice string (const nil)))
(defcustom remote-compile-run-before nil
"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.
+\(tcsh) and .bash_profile \(bash) are not run.
nil means run no commands."
- :type '(choice string (const nil))
- :group 'remote-compile)
+ :type '(choice string (const nil)))
(defcustom remote-compile-prompt-for-host nil
"Non-nil means prompt for host if not available from filename."
- :type 'boolean
- :group 'remote-compile)
+ :type 'boolean)
(defcustom remote-compile-prompt-for-user nil
"Non-nil means prompt for user if not available from filename."
- :type 'boolean
- :group 'remote-compile)
+ :type 'boolean)
;;;; internal variables
@@ -123,7 +118,7 @@ nil means run no commands."
"Compile the current buffer's directory on HOST. Log in as USER.
See \\[compile]."
(interactive
- (let (host user command prompt l l-host l-user)
+ (let (host user command prompt) ;; l l-host l-user
(setq prompt (if (stringp remote-compile-host)
(format "Compile on host (default %s): "
remote-compile-host)
@@ -153,7 +148,7 @@ See \\[compile]."
(setq remote-compile-user user))
((null remote-compile-user)
(setq remote-compile-user (user-login-name))))
- (let* (localname ;; Pacify byte-compiler.
+ (let* (;; localname ;; Pacify byte-compiler.
(compile-command
(format "%s %s -l %s \"(%scd %s; %s)\""
remote-shell-program
diff --git a/lisp/obsolete/s-region.el b/lisp/obsolete/s-region.el
index bcb5279d115..4d4c39e9b11 100644
--- a/lisp/obsolete/s-region.el
+++ b/lisp/obsolete/s-region.el
@@ -1,4 +1,4 @@
-;;; s-region.el --- set region using shift key
+;;; s-region.el --- set region using shift key -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
@@ -112,11 +112,11 @@ to global keymap."
[M-next] [M-previous] [M-home] [M-end]))
(or (global-key-binding [C-insert])
- (global-set-key [C-insert] 'copy-region-as-kill))
+ (global-set-key [C-insert] #'copy-region-as-kill))
(or (global-key-binding [S-delete])
- (global-set-key [S-delete] 'kill-region))
+ (global-set-key [S-delete] #'kill-region))
(or (global-key-binding [S-insert])
- (global-set-key [S-insert] 'yank))
+ (global-set-key [S-insert] #'yank))
(provide 's-region)
diff --git a/lisp/obsolete/sb-image.el b/lisp/obsolete/sb-image.el
new file mode 100644
index 00000000000..fc9e03eae6e
--- /dev/null
+++ b/lisp/obsolete/sb-image.el
@@ -0,0 +1,47 @@
+;;; sb-image.el --- Image management for speedbar -*- lexical-binding: t; -*-
+
+;; Copyright (C) 1999-2003, 2005-2019, 2021 Free Software Foundation,
+;; Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: file, tags, tools
+;; Obsolete-since: 28.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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file is obsolete.
+;;
+;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs,
+;; is a challenging task, which doesn't take kindly to being byte compiled.
+;; When sharing speedbar.elc between these three applications, the Image
+;; support can get lost.
+;;
+;; By splitting out that hard part into this file, and avoiding byte
+;; compilation, one copy speedbar can support all these platforms together.
+;;
+;; This file requires the `image' package if it is available.
+
+(require 'ezimage)
+
+;;; Code:
+
+(defalias 'defimage-speedbar 'defezimage)
+
+(provide 'sb-image)
+
+;;; sb-image.el ends here
diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el
index ac5f62dd67e..371dcbf8498 100644
--- a/lisp/obsolete/sregex.el
+++ b/lisp/obsolete/sregex.el
@@ -1,4 +1,4 @@
-;;; sregex.el --- symbolic regular expressions
+;;; sregex.el --- symbolic regular expressions -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc.
@@ -208,7 +208,7 @@
;; This is a "trapdoor" for including ordinary regular expression
;; strings in the result. Some regular expressions are clearer when
;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for
-;; instance. However, see the note under "Bugs," below.
+;; instance.
;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...)
;; has one of the following forms:
@@ -236,8 +236,6 @@
;; - add support for non-greedy operators *? and +?
;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?"
-;;; Bugs:
-
;;; Code:
(eval-when-compile (require 'cl-lib))
@@ -246,15 +244,15 @@
(defvar sregex--current-sregex nil)
(defun sregex-info () nil)
(defmacro sregex-save-match-data (&rest forms) (cons 'save-match-data forms))
-(defun sregex-replace-match (r &optional f l str subexp x)
+(defun sregex-replace-match (r &optional f l str subexp _x)
(replace-match r f l str subexp))
-(defun sregex-match-string (c &optional i x) (match-string c i))
-(defun sregex-match-string-no-properties (count &optional in-string sregex)
+(defun sregex-match-string (c &optional i _x) (match-string c i))
+(defun sregex-match-string-no-properties (count &optional in-string _sregex)
(match-string-no-properties count in-string))
-(defun sregex-match-beginning (count &optional sregex) (match-beginning count))
-(defun sregex-match-end (count &optional sregex) (match-end count))
-(defun sregex-match-data (&optional sregex) (match-data))
-(defun sregex-backref-num (n &optional sregex) n)
+(defun sregex-match-beginning (count &optional _sregex) (match-beginning count))
+(defun sregex-match-end (count &optional _sregex) (match-end count))
+(defun sregex-match-data (&optional _sregex) (match-data))
+(defun sregex-backref-num (n &optional _sregex) n)
(defun sregex (&rest exps)
@@ -525,23 +523,23 @@ has one of the following forms:
(concat "\\(?:" re "\\)")
re))))
-(defun sregex--group (exps combine) (concat "\\(" (sregex--sequence exps nil) "\\)"))
+(defun sregex--group (exps _combine) (concat "\\(" (sregex--sequence exps nil) "\\)"))
-(defun sregex--backref (exps combine) (concat "\\" (int-to-string (car exps))))
-(defun sregex--opt (exps combine) (concat (sregex--sequence exps 'suffix) "?"))
-(defun sregex--0+ (exps combine) (concat (sregex--sequence exps 'suffix) "*"))
-(defun sregex--1+ (exps combine) (concat (sregex--sequence exps 'suffix) "+"))
+(defun sregex--backref (exps _combine) (concat "\\" (int-to-string (car exps))))
+(defun sregex--opt (exps _combine) (concat (sregex--sequence exps 'suffix) "?"))
+(defun sregex--0+ (exps _combine) (concat (sregex--sequence exps 'suffix) "*"))
+(defun sregex--1+ (exps _combine) (concat (sregex--sequence exps 'suffix) "+"))
-(defun sregex--char (exps combine) (sregex--char-aux nil exps))
-(defun sregex--not-char (exps combine) (sregex--char-aux t exps))
+(defun sregex--char (exps _combine) (sregex--char-aux nil exps))
+(defun sregex--not-char (exps _combine) (sregex--char-aux t exps))
-(defun sregex--syntax (exps combine) (format "\\s%c" (car exps)))
-(defun sregex--not-syntax (exps combine) (format "\\S%c" (car exps)))
+(defun sregex--syntax (exps _combine) (format "\\s%c" (car exps)))
+(defun sregex--not-syntax (exps _combine) (format "\\S%c" (car exps)))
(defun sregex--regex (exps combine)
(if combine (concat "\\(?:" (car exps) "\\)") (car exps)))
-(defun sregex--repeat (exps combine)
+(defun sregex--repeat (exps _combine)
(let* ((min (or (pop exps) 0))
(minstr (number-to-string min))
(max (pop exps)))
diff --git a/lisp/obsolete/starttls.el b/lisp/obsolete/starttls.el
index 451c7eb2ffc..926248db9af 100644
--- a/lisp/obsolete/starttls.el
+++ b/lisp/obsolete/starttls.el
@@ -1,4 +1,4 @@
-;;; starttls.el --- STARTTLS functions
+;;; starttls.el --- STARTTLS functions -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -126,28 +126,24 @@
This program is used when GnuTLS is used, i.e. when
`starttls-use-gnutls' is non-nil."
:version "22.1"
- :type 'string
- :group 'starttls)
+ :type 'string)
(defcustom starttls-program "starttls"
"The program to run in a subprocess to open an TLSv1 connection.
This program is used when the `starttls' command is used,
i.e. when `starttls-use-gnutls' is nil."
- :type 'string
- :group 'starttls)
+ :type 'string)
(defcustom starttls-use-gnutls (not (executable-find starttls-program))
"Whether to use GnuTLS instead of the `starttls' command."
:version "22.1"
- :type 'boolean
- :group 'starttls)
+ :type 'boolean)
(defcustom starttls-extra-args nil
"Extra arguments to `starttls-program'.
These apply when the `starttls' command is used, i.e. when
`starttls-use-gnutls' is nil."
- :type '(repeat string)
- :group 'starttls)
+ :type '(repeat string))
(defcustom starttls-extra-arguments nil
"Extra arguments to `starttls-gnutls-program'.
@@ -157,14 +153,12 @@ For example, non-TLS compliant servers may require
\(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
find out which parameters are available."
:version "22.1"
- :type '(repeat string)
- :group 'starttls)
+ :type '(repeat string))
(defcustom starttls-process-connection-type nil
"Value for `process-connection-type' to use when starting STARTTLS process."
:version "22.1"
- :type 'boolean
- :group 'starttls)
+ :type 'boolean)
(defcustom starttls-connect "- Simple Client Mode:\n\n"
"Regular expression indicating successful connection.
@@ -173,8 +167,7 @@ The default is what GnuTLS's \"gnutls-cli\" outputs."
;; in the application read/write phase. If the logic, or the string
;; itself, is modified, this must be updated.
:version "22.1"
- :type 'regexp
- :group 'starttls)
+ :type 'regexp)
(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
"Regular expression indicating failed TLS handshake.
@@ -182,8 +175,7 @@ The default is what GnuTLS's \"gnutls-cli\" outputs."
;; GnuTLS cli.c:do_handshake() prints this string on failure. If the
;; logic, or the string itself, is modified, this must be updated.
:version "22.1"
- :type 'regexp
- :group 'starttls)
+ :type 'regexp)
(defcustom starttls-success "- Compression: "
"Regular expression indicating completed TLS handshakes.
@@ -193,8 +185,7 @@ The default is what GnuTLS's \"gnutls-cli\" outputs."
;; last. If that logic, or the string itself, is modified, this
;; must be updated.
:version "22.1"
- :type 'regexp
- :group 'starttls)
+ :type 'regexp)
(defun starttls-negotiate-gnutls (process)
"Negotiate TLS on PROCESS opened by `open-starttls-stream'.
@@ -296,9 +287,8 @@ GnuTLS requires a port number."
starttls-gnutls-program
starttls-program))))
-(defalias 'starttls-any-program-available 'starttls-available-p)
-(make-obsolete 'starttls-any-program-available 'starttls-available-p
- "2011-08-02")
+(define-obsolete-function-alias 'starttls-any-program-available
+ #'starttls-available-p "24.1")
(provide 'starttls)
diff --git a/lisp/obsolete/sup-mouse.el b/lisp/obsolete/sup-mouse.el
index f3db27f567e..4e312e968b3 100644
--- a/lisp/obsolete/sup-mouse.el
+++ b/lisp/obsolete/sup-mouse.el
@@ -1,4 +1,4 @@
-;;; sup-mouse.el --- supdup mouse support for lisp machines
+;;; sup-mouse.el --- supdup mouse support for lisp machines -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/obsolete/terminal.el b/lisp/obsolete/terminal.el
index 42f555d6e5a..dbfc79bf913 100644
--- a/lisp/obsolete/terminal.el
+++ b/lisp/obsolete/terminal.el
@@ -1,4 +1,4 @@
-;;; terminal.el --- terminal emulator for GNU Emacs
+;;; terminal.el --- terminal emulator for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986-1989, 1993-1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -32,7 +32,7 @@
;; For information on US government censorship of the Internet, and
;; what you can do to bring back freedom of the press, see the web
-;; site http://www.vtw.org/
+;; site https://www.eff.org/ [used to be vtw.org but that link is dead]
;;; Code:
@@ -44,6 +44,7 @@
;;>> more-processing enabled.
(require 'ehelp)
+(require 'shell)
(defgroup terminal nil
"Terminal emulator for Emacs."
@@ -57,22 +58,19 @@ to the emulator program itself. Type this character twice to send
it through the emulator. Type ? after typing it for a list of
possible commands.
This variable is local to each terminal-emulator buffer."
- :type 'character
- :group 'terminal)
+ :type 'character)
(defcustom terminal-scrolling t ;;>> Setting this to t sort-of defeats my whole aim in writing this package...
"If non-nil, the terminal-emulator will losingly `scroll' when output occurs
past the bottom of the screen. If nil, output will win and `wrap' to the top
of the screen.
This variable is local to each terminal-emulator buffer."
- :type 'boolean
- :group 'terminal)
+ :type 'boolean)
(defcustom terminal-more-processing t
"If non-nil, do more-processing.
This variable is local to each terminal-emulator buffer."
- :type 'boolean
- :group 'terminal)
+ :type 'boolean)
;; If you are the sort of loser who uses scrolling without more breaks
;; and expects to actually see anything, you should probably set this to
@@ -83,8 +81,7 @@ terminal-emulator before a screen redisplay is forced.
Set this to a large value for greater throughput,
set it smaller for more frequent updates but overall slower
performance."
- :type 'integer
- :group 'terminal)
+ :type 'integer)
(defvar terminal-more-break-insertion
"*** More break -- Press space to continue ***")
@@ -93,7 +90,7 @@ performance."
(if terminal-meta-map
nil
(let ((map (make-sparse-keymap)))
- (define-key map [t] 'te-pass-through)
+ (define-key map [t] #'te-pass-through)
(setq terminal-meta-map map)))
(defvar terminal-map nil)
@@ -103,8 +100,8 @@ performance."
;; Prevent defining [menu-bar] as te-pass-through
;; so we allow the global menu bar to be visible.
(define-key map [menu-bar] (make-sparse-keymap))
- (define-key map [t] 'te-pass-through)
- (define-key map [switch-frame] 'handle-switch-frame)
+ (define-key map [t] #'te-pass-through)
+ (define-key map [switch-frame] #'handle-switch-frame)
(define-key map "\e" terminal-meta-map)
;;(define-key map "\C-l"
;; (lambda () (interactive) (te-pass-through) (redraw-display)))
@@ -114,22 +111,22 @@ performance."
(if terminal-escape-map
nil
(let ((map (make-sparse-keymap)))
- (define-key map [t] 'undefined)
+ (define-key map [t] #'undefined)
(let ((s "0"))
(while (<= (aref s 0) ?9)
- (define-key map s 'digit-argument)
+ (define-key map s #'digit-argument)
(aset s 0 (1+ (aref s 0)))))
- (define-key map "b" 'switch-to-buffer)
- (define-key map "o" 'other-window)
- (define-key map "e" 'te-set-escape-char)
- (define-key map "\C-l" 'redraw-display)
- (define-key map "\C-o" 'te-flush-pending-output)
- (define-key map "m" 'te-toggle-more-processing)
- (define-key map "x" 'te-escape-extended-command)
+ (define-key map "b" #'switch-to-buffer)
+ (define-key map "o" #'other-window)
+ (define-key map "e" #'te-set-escape-char)
+ (define-key map "\C-l" #'redraw-display)
+ (define-key map "\C-o" #'te-flush-pending-output)
+ (define-key map "m" #'te-toggle-more-processing)
+ (define-key map "x" #'te-escape-extended-command)
;;>> What use is this? Why is it in the default terminal-emulator map?
- (define-key map "w" 'te-edit)
- (define-key map "?" 'te-escape-help)
- (define-key map (char-to-string help-char) 'te-escape-help)
+ (define-key map "w" #'te-edit)
+ (define-key map "?" #'te-escape-help)
+ (define-key map (char-to-string help-char) #'te-escape-help)
(setq terminal-escape-map map)))
(defvar te-escape-command-alist nil)
@@ -160,14 +157,14 @@ performance."
(if terminal-more-break-map
nil
(let ((map (make-sparse-keymap)))
- (define-key map [t] 'te-more-break-unread)
- (define-key map (char-to-string help-char) 'te-more-break-help)
- (define-key map " " 'te-more-break-resume)
- (define-key map "\C-l" 'redraw-display)
- (define-key map "\C-o" 'te-more-break-flush-pending-output)
+ (define-key map [t] #'te-more-break-unread)
+ (define-key map (char-to-string help-char) #'te-more-break-help)
+ (define-key map " " #'te-more-break-resume)
+ (define-key map "\C-l" #'redraw-display)
+ (define-key map "\C-o" #'te-more-break-flush-pending-output)
;;>>> this isn't right
- ;(define-key map "\^?" 'te-more-break-flush-pending-output) ;DEL
- (define-key map "\r" 'te-more-break-advance-one-line)
+ ;(define-key map "\^?" #'te-more-break-flush-pending-output) ;DEL
+ (define-key map "\r" #'te-more-break-advance-one-line)
(setq terminal-more-break-map map)))
@@ -524,7 +521,7 @@ lets you type a terminal emulator command."
(if terminal-edit-map
nil
(setq terminal-edit-map (make-sparse-keymap))
- (define-key terminal-edit-map "\C-c\C-c" 'terminal-cease-edit))
+ (define-key terminal-edit-map "\C-c\C-c" #'terminal-cease-edit))
;; Terminal Edit mode is suitable only for specially formatted data.
(put 'terminal-edit-mode 'mode-class 'special)
@@ -1056,12 +1053,6 @@ move to start of new line, clear to end of line."
;; This used to have `new' in it, but that loses outside BSD
;; and it's apparently not needed in BSD.
-(defcustom explicit-shell-file-name nil
- "If non-nil, is file name to use for explicitly requested inferior shell."
- :type '(choice (const :tag "None" nil)
- file)
- :group 'terminal)
-
;;;###autoload
(defun terminal-emulator (buffer program args &optional width height)
"Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS.
@@ -1145,10 +1136,10 @@ subprocess started."
;; Then finally start the program we wanted.
(format "%s; exec %s"
te-stty-string
- (mapconcat 'te-quote-arg-for-sh
+ (mapconcat #'te-quote-arg-for-sh
(cons program args) " "))))
- (set-process-filter te-process 'te-filter)
- (set-process-sentinel te-process 'te-sentinel))
+ (set-process-filter te-process #'te-filter)
+ (set-process-sentinel te-process #'te-sentinel))
(error (fundamental-mode)
(signal (car err) (cdr err))))
(setq inhibit-quit t) ;sport death
@@ -1156,8 +1147,8 @@ subprocess started."
(run-hooks 'terminal-mode-hook)
(message "Entering Emacs terminal-emulator... Type %s %s for help"
(single-key-description terminal-escape-char)
- (mapconcat 'single-key-description
- (where-is-internal 'te-escape-help terminal-escape-map t)
+ (mapconcat #'single-key-description
+ (where-is-internal #'te-escape-help terminal-escape-map t)
" ")))
@@ -1297,7 +1288,7 @@ in the directory specified by `te-terminfo-directory'."
(directory-file-name te-terminfo-directory))
process-environment)))
(set-process-sentinel (start-process "tic" nil "tic" file-name)
- 'te-tic-sentinel))))
+ #'te-tic-sentinel))))
(directory-file-name te-terminfo-directory))
(defun te-create-termcap ()
diff --git a/lisp/obsolete/tls.el b/lisp/obsolete/tls.el
index 70fcdaf65f6..5cba18d7897 100644
--- a/lisp/obsolete/tls.el
+++ b/lisp/obsolete/tls.el
@@ -1,4 +1,4 @@
-;;; tls.el --- TLS/SSL support via wrapper around GnuTLS
+;;; tls.el --- TLS/SSL support via wrapper around GnuTLS -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2002-2021 Free Software Foundation, Inc.
@@ -47,9 +47,6 @@
(require 'gnutls)
-(autoload 'format-spec "format-spec")
-(autoload 'format-spec-make "format-spec")
-
(defgroup tls nil
"Transport Layer Security (TLS) parameters."
:group 'comm)
@@ -73,8 +70,7 @@
Client data stream begins after the last character this matches.
The default matches the output of \"gnutls-cli\" (version 2.0.1)."
:version "22.2"
- :type 'regexp
- :group 'tls)
+ :type 'regexp)
(defcustom tls-program
'("gnutls-cli --x509cafile %t -p %p %h"
@@ -107,22 +103,19 @@ successful negotiation."
(repeat :inline t :tag "Other" (string)))
(list :tag "List of commands"
(repeat :tag "Command" (string))))
- :version "26.1" ; remove s_client
- :group 'tls)
+ :version "26.1")
(defcustom tls-process-connection-type nil
"Value for `process-connection-type' to use when starting TLS process."
:version "22.1"
- :type 'boolean
- :group 'tls)
+ :type 'boolean)
(defcustom tls-success "- Handshake was completed\\|SSL handshake has read "
"Regular expression indicating completed TLS handshakes.
The default is what GnuTLS's \"gnutls-cli\" outputs."
;; or OpenSSL's \"openssl s_client\"
:version "22.1"
- :type 'regexp
- :group 'tls)
+ :type 'regexp)
(defcustom tls-checktrust nil
"Indicate if certificates should be checked against trusted root certs.
@@ -133,13 +126,14 @@ the external program knows about the root certificates you
consider trustworthy, e.g.:
\(setq tls-program
- \\='(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\"
- \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3\"))"
+ \\='(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt \\
+-p %p %h\"
+ \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt \\
+-p %p %h --protocols ssl3\"))"
:type '(choice (const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "Ask" ask))
- :version "23.1" ;; No Gnus
- :group 'tls)
+ :version "23.1")
(defcustom tls-untrusted
"- Peer's certificate is NOT trusted\\|Verify return code: \\([^0] \\|.[^ ]\\)"
@@ -148,8 +142,7 @@ The default is what GnuTLS's \"gnutls-cli\" returns in the event of
unsuccessful verification."
;; or OpenSSL's \"openssl s_client\"
:type 'regexp
- :version "23.1" ;; No Gnus
- :group 'tls)
+ :version "23.1")
(defcustom tls-hostmismatch
"# The hostname in the certificate does NOT match"
@@ -159,20 +152,13 @@ name of the host you are connecting to, gnutls-cli issues a
warning to this effect. There is no such feature in openssl. Set
this to nil if you want to ignore host name mismatches."
:type 'regexp
- :version "23.1" ;; No Gnus
- :group 'tls)
+ :version "23.1")
(defcustom tls-certtool-program "certtool"
"Name of GnuTLS certtool.
Used by `tls-certificate-information'."
:version "22.1"
- :type 'string
- :group 'tls)
-
-(defalias 'tls-format-message
- (if (fboundp 'format-message) 'format-message
- ;; for Emacs < 25, and XEmacs, don't worry about quote translation.
- 'format))
+ :type 'string)
(defun tls-certificate-information (der)
"Parse X.509 certificate in DER format into an assoc list."
@@ -224,14 +210,11 @@ Fourth arg PORT is an integer specifying a port to connect to."
(while (and (not done) (setq cmd (pop cmds)))
(let ((process-connection-type tls-process-connection-type)
(formatted-cmd
- (format-spec
- cmd
- (format-spec-make
- ?t (car (gnutls-trustfiles))
- ?h host
- ?p (if (integerp port)
- (int-to-string port)
- port)))))
+ (format-spec cmd `((?t . ,(car (gnutls-trustfiles)))
+ (?h . ,host)
+ (?p . ,(if (integerp port)
+ (number-to-string port)
+ port))))))
(message "Opening TLS connection with `%s'..." formatted-cmd)
(setq process (start-process
name buffer shell-file-name shell-command-switch
@@ -276,7 +259,7 @@ Fourth arg PORT is an integer specifying a port to connect to."
(message "The certificate presented by `%s' is \
NOT trusted." host))
(not (yes-or-no-p
- (tls-format-message "\
+ (format-message "\
The certificate presented by `%s' is NOT trusted. Accept anyway? " host)))))
(and tls-hostmismatch
(save-excursion
diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el
index dc4bdc03f6d..1340618f055 100644
--- a/lisp/obsolete/tpu-edt.el
+++ b/lisp/obsolete/tpu-edt.el
@@ -1,4 +1,4 @@
-;;; tpu-edt.el --- Emacs emulating TPU emulating EDT
+;;; tpu-edt.el --- Emacs emulating TPU emulating EDT -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2000-2021 Free Software Foundation, Inc.
@@ -287,52 +287,40 @@
;;;
;;; User Configurable Variables
;;;
-(defcustom tpu-have-ispell t
- "Non-nil means `tpu-spell-check' uses `ispell-region' for spell checking.
-Otherwise, use `spell-region'."
- :type 'boolean
- :group 'tpu)
-(make-obsolete-variable 'tpu-have-ispell "the `spell' package is obsolete."
- "23.1")
-
(defcustom tpu-kill-buffers-silently nil
"If non-nil, TPU-edt kills modified buffers without asking."
- :type 'boolean
- :group 'tpu)
+ :type 'boolean)
(defcustom tpu-percent-scroll 75
"Percentage of the screen to scroll for next/previous screen commands."
- :type 'integer
- :group 'tpu)
+ :type 'integer)
(defcustom tpu-pan-columns 16
"Number of columns the tpu-pan functions scroll left or right."
- :type 'integer
- :group 'tpu)
+ :type 'integer)
;;;
;;; Global Keymaps
;;;
-(define-obsolete-variable-alias 'GOLD-map 'tpu-gold-map "23.1")
(defvar tpu-gold-map
(let ((map (make-keymap)))
;; Previously we used escape sequences here. We now instead presume
;; that term/*.el does its job to map the escape sequence to the right
;; key-symbol.
- (define-key map [up] 'tpu-move-to-beginning) ; up-arrow
- (define-key map [down] 'tpu-move-to-end) ; down-arrow
- (define-key map [right] 'end-of-line) ; right-arrow
- (define-key map [left] 'beginning-of-line) ; left-arrow
+ (define-key map [up] #'tpu-move-to-beginning) ; up-arrow
+ (define-key map [down] #'tpu-move-to-end) ; down-arrow
+ (define-key map [right] #'end-of-line) ; right-arrow
+ (define-key map [left] #'beginning-of-line) ; left-arrow
;; (define-key map [find] nil) ; Find
;; (define-key map [insert] nil) ; Insert Here
- (define-key map [delete] 'tpu-store-text) ; Remove
- (define-key map [select] 'tpu-unselect) ; Select
- (define-key map [prior] 'tpu-previous-window) ; Prev Screen
- (define-key map [next] 'tpu-next-window) ; Next Screen
+ (define-key map [delete] #'tpu-store-text) ; Remove
+ (define-key map [select] #'tpu-unselect) ; Select
+ (define-key map [prior] #'tpu-previous-window) ; Prev Screen
+ (define-key map [next] #'tpu-next-window) ; Next Screen
;; (define-key map [f1] nil) ; F1
;; (define-key map [f2] nil) ; F2
@@ -348,45 +336,45 @@ Otherwise, use `spell-region'."
;; (define-key map [f12] nil) ; F12
;; (define-key map [f13] nil) ; F13
;; (define-key map [f14] nil) ; F14
- (define-key map [help] 'describe-bindings) ; HELP
+ (define-key map [help] #'describe-bindings) ; HELP
;; (define-key map [menu] nil) ; DO
- (define-key map [f17] 'tpu-drop-breadcrumb) ; F17
+ (define-key map [f17] #'tpu-drop-breadcrumb) ; F17
;; (define-key map [f18] nil) ; F18
;; (define-key map [f19] nil) ; F19
;; (define-key map [f20] nil) ; F20
- (define-key map [kp-f1] 'keyboard-quit) ; PF1
- (define-key map [kp-f2] 'help-for-help) ; PF2
- (define-key map [kp-f3] 'tpu-search) ; PF3
- (define-key map [kp-f4] 'tpu-undelete-lines) ; PF4
- (define-key map [kp-0] 'open-line) ; KP0
- (define-key map [kp-1] 'tpu-change-case) ; KP1
- (define-key map [kp-2] 'tpu-delete-to-eol) ; KP2
- (define-key map [kp-3] 'tpu-special-insert) ; KP3
- (define-key map [kp-4] 'tpu-move-to-end) ; KP4
- (define-key map [kp-5] 'tpu-move-to-beginning) ; KP5
- (define-key map [kp-6] 'tpu-paste) ; KP6
- (define-key map [kp-7] 'execute-extended-command) ; KP7
- (define-key map [kp-8] 'tpu-fill) ; KP8
- (define-key map [kp-9] 'tpu-replace) ; KP9
- (define-key map [kp-subtract] 'tpu-undelete-words) ; KP-
- (define-key map [kp-separator] 'tpu-undelete-char) ; KP,
- (define-key map [kp-decimal] 'tpu-unselect) ; KP.
- (define-key map [kp-enter] 'tpu-substitute) ; KPenter
+ (define-key map [kp-f1] #'keyboard-quit) ; PF1
+ (define-key map [kp-f2] #'help-for-help) ; PF2
+ (define-key map [kp-f3] #'tpu-search) ; PF3
+ (define-key map [kp-f4] #'tpu-undelete-lines) ; PF4
+ (define-key map [kp-0] #'open-line) ; KP0
+ (define-key map [kp-1] #'tpu-change-case) ; KP1
+ (define-key map [kp-2] #'tpu-delete-to-eol) ; KP2
+ (define-key map [kp-3] #'tpu-special-insert) ; KP3
+ (define-key map [kp-4] #'tpu-move-to-end) ; KP4
+ (define-key map [kp-5] #'tpu-move-to-beginning) ; KP5
+ (define-key map [kp-6] #'tpu-paste) ; KP6
+ (define-key map [kp-7] #'execute-extended-command) ; KP7
+ (define-key map [kp-8] #'tpu-fill) ; KP8
+ (define-key map [kp-9] #'tpu-replace) ; KP9
+ (define-key map [kp-subtract] #'tpu-undelete-words) ; KP-
+ (define-key map [kp-separator] #'tpu-undelete-char) ; KP,
+ (define-key map [kp-decimal] #'tpu-unselect) ; KP.
+ (define-key map [kp-enter] #'tpu-substitute) ; KPenter
;;
- (define-key map "\C-A" 'tpu-toggle-overwrite-mode) ; ^A
+ (define-key map "\C-A" #'tpu-toggle-overwrite-mode) ; ^A
;; (define-key map "\C-B" nil) ; ^B
;; (define-key map "\C-C" nil) ; ^C
;; (define-key map "\C-D" nil) ; ^D
;; (define-key map "\C-E" nil) ; ^E
- (define-key map "\C-F" 'set-visited-file-name) ; ^F
- (define-key map "\C-g" 'keyboard-quit) ; safety first
- (define-key map "\C-h" 'delete-other-windows) ; BS
- (define-key map "\C-i" 'other-window) ; TAB
+ (define-key map "\C-F" #'set-visited-file-name) ; ^F
+ (define-key map "\C-g" #'keyboard-quit) ; safety first
+ (define-key map "\C-h" #'delete-other-windows) ; BS
+ (define-key map "\C-i" #'other-window) ; TAB
;; (define-key map "\C-J" nil) ; ^J
- (define-key map "\C-K" 'tpu-define-macro-key) ; ^K
- (define-key map "\C-l" 'downcase-region) ; ^L
+ (define-key map "\C-K" #'tpu-define-macro-key) ; ^K
+ (define-key map "\C-l" #'downcase-region) ; ^L
;; (define-key map "\C-M" nil) ; ^M
;; (define-key map "\C-N" nil) ; ^N
;; (define-key map "\C-O" nil) ; ^O
@@ -394,104 +382,104 @@ Otherwise, use `spell-region'."
;; (define-key map "\C-Q" nil) ; ^Q
;; (define-key map "\C-R" nil) ; ^R
;; (define-key map "\C-S" nil) ; ^S
- (define-key map "\C-T" 'tpu-toggle-control-keys) ; ^T
- (define-key map "\C-u" 'upcase-region) ; ^U
+ (define-key map "\C-T" #'tpu-toggle-control-keys) ; ^T
+ (define-key map "\C-u" #'upcase-region) ; ^U
;; (define-key map "\C-V" nil) ; ^V
- (define-key map "\C-w" 'tpu-write-current-buffers) ; ^W
+ (define-key map "\C-w" #'tpu-write-current-buffers) ; ^W
;; (define-key map "\C-X" nil) ; ^X
;; (define-key map "\C-Y" nil) ; ^Y
;; (define-key map "\C-Z" nil) ; ^Z
- (define-key map " " 'undo) ; SPC
+ (define-key map " " #'undo) ; SPC
;; (define-key map "!" nil) ; !
;; (define-key map "#" nil) ; #
- (define-key map "$" 'tpu-add-at-eol) ; $
- (define-key map "%" 'tpu-goto-percent) ; %
+ (define-key map "$" #'tpu-add-at-eol) ; $
+ (define-key map "%" #'tpu-goto-percent) ; %
;; (define-key map "&" nil) ; &
;; (define-key map "(" nil) ; (
;; (define-key map ")" nil) ; )
- (define-key map "*" 'tpu-toggle-regexp) ; *
+ (define-key map "*" #'tpu-toggle-regexp) ; *
;; (define-key map "+" nil) ; +
- (define-key map "," 'tpu-goto-breadcrumb) ; ,
- (define-key map "-" 'negative-argument) ; -
- (define-key map "." 'tpu-drop-breadcrumb) ; .
- (define-key map "/" 'tpu-emacs-replace) ; /
- (define-key map "0" 'digit-argument) ; 0
- (define-key map "1" 'digit-argument) ; 1
- (define-key map "2" 'digit-argument) ; 2
- (define-key map "3" 'digit-argument) ; 3
- (define-key map "4" 'digit-argument) ; 4
- (define-key map "5" 'digit-argument) ; 5
- (define-key map "6" 'digit-argument) ; 6
- (define-key map "7" 'digit-argument) ; 7
- (define-key map "8" 'digit-argument) ; 8
- (define-key map "9" 'digit-argument) ; 9
+ (define-key map "," #'tpu-goto-breadcrumb) ; ,
+ (define-key map "-" #'negative-argument) ; -
+ (define-key map "." #'tpu-drop-breadcrumb) ; .
+ (define-key map "/" #'tpu-emacs-replace) ; /
+ (define-key map "0" #'digit-argument) ; 0
+ (define-key map "1" #'digit-argument) ; 1
+ (define-key map "2" #'digit-argument) ; 2
+ (define-key map "3" #'digit-argument) ; 3
+ (define-key map "4" #'digit-argument) ; 4
+ (define-key map "5" #'digit-argument) ; 5
+ (define-key map "6" #'digit-argument) ; 6
+ (define-key map "7" #'digit-argument) ; 7
+ (define-key map "8" #'digit-argument) ; 8
+ (define-key map "9" #'digit-argument) ; 9
;; (define-key map ":" nil) ; :
- (define-key map ";" 'tpu-trim-line-ends) ; ;
+ (define-key map ";" #'tpu-trim-line-ends) ; ;
;; (define-key map "<" nil) ; <
;; (define-key map "=" nil) ; =
;; (define-key map ">" nil) ; >
- (define-key map "?" 'tpu-spell-check) ; ?
- ;; (define-key map "A" 'tpu-toggle-newline-and-indent) ; A
- ;; (define-key map "B" 'tpu-next-buffer) ; B
- ;; (define-key map "C" 'repeat-complex-command) ; C
- ;; (define-key map "D" 'shell-command) ; D
- ;; (define-key map "E" 'tpu-exit) ; E
- ;; (define-key map "F" 'tpu-cursor-free-mode) ; F
- ;; (define-key map "G" 'tpu-get) ; G
+ (define-key map "?" #'tpu-spell-check) ; ?
+ ;; (define-key map "A" #'tpu-toggle-newline-and-indent) ; A
+ ;; (define-key map "B" #'tpu-next-buffer) ; B
+ ;; (define-key map "C" #'repeat-complex-command) ; C
+ ;; (define-key map "D" #'shell-command) ; D
+ ;; (define-key map "E" #'tpu-exit) ; E
+ ;; (define-key map "F" #'tpu-cursor-free-mode) ; F
+ ;; (define-key map "G" #'tpu-get) ; G
;; (define-key map "H" nil) ; H
- ;; (define-key map "I" 'tpu-include) ; I
- ;; (define-key map "K" 'tpu-kill-buffer) ; K
- (define-key map "L" 'tpu-what-line) ; L
- ;; (define-key map "M" 'buffer-menu) ; M
- ;; (define-key map "N" 'tpu-next-file-buffer) ; N
- ;; (define-key map "O" 'occur) ; O
- (define-key map "P" 'lpr-buffer) ; P
- ;; (define-key map "Q" 'tpu-quit) ; Q
- ;; (define-key map "R" 'tpu-toggle-rectangle) ; R
- ;; (define-key map "S" 'replace) ; S
- ;; (define-key map "T" 'tpu-line-to-top-of-window) ; T
- ;; (define-key map "U" 'undo) ; U
- ;; (define-key map "V" 'tpu-version) ; V
- ;; (define-key map "W" 'save-buffer) ; W
- ;; (define-key map "X" 'tpu-save-all-buffers-kill-emacs) ; X
- ;; (define-key map "Y" 'copy-region-as-kill) ; Y
- ;; (define-key map "Z" 'suspend-emacs) ; Z
- (define-key map "[" 'blink-matching-open) ; [
+ ;; (define-key map "I" #'tpu-include) ; I
+ ;; (define-key map "K" #'tpu-kill-buffer) ; K
+ (define-key map "L" #'tpu-what-line) ; L
+ ;; (define-key map "M" #'buffer-menu) ; M
+ ;; (define-key map "N" #'tpu-next-file-buffer) ; N
+ ;; (define-key map "O" #'occur) ; O
+ (define-key map "P" #'lpr-buffer) ; P
+ ;; (define-key map "Q" #'tpu-quit) ; Q
+ ;; (define-key map "R" #'tpu-toggle-rectangle) ; R
+ ;; (define-key map "S" #'replace) ; S
+ ;; (define-key map "T" #'tpu-line-to-top-of-window) ; T
+ ;; (define-key map "U" #'undo) ; U
+ ;; (define-key map "V" #'tpu-version) ; V
+ ;; (define-key map "W" #'save-buffer) ; W
+ ;; (define-key map "X" #'tpu-save-all-buffers-kill-emacs) ; X
+ ;; (define-key map "Y" #'copy-region-as-kill) ; Y
+ ;; (define-key map "Z" #'suspend-emacs) ; Z
+ (define-key map "[" #'blink-matching-open) ; [
;; (define-key map "\\" nil) ; \
- (define-key map "]" 'blink-matching-open) ; ]
- (define-key map "^" 'tpu-add-at-bol) ; ^
- (define-key map "_" 'split-window-below) ; -
- (define-key map "`" 'what-line) ; `
- (define-key map "a" 'tpu-toggle-newline-and-indent) ; a
- (define-key map "b" 'tpu-next-buffer) ; b
- (define-key map "c" 'repeat-complex-command) ; c
- (define-key map "d" 'shell-command) ; d
- (define-key map "e" 'tpu-exit) ; e
- (define-key map "f" 'tpu-cursor-free-mode) ; f
- (define-key map "g" 'tpu-get) ; g
+ (define-key map "]" #'blink-matching-open) ; ]
+ (define-key map "^" #'tpu-add-at-bol) ; ^
+ (define-key map "_" #'split-window-below) ; -
+ (define-key map "`" #'what-line) ; `
+ (define-key map "a" #'tpu-toggle-newline-and-indent) ; a
+ (define-key map "b" #'tpu-next-buffer) ; b
+ (define-key map "c" #'repeat-complex-command) ; c
+ (define-key map "d" #'shell-command) ; d
+ (define-key map "e" #'tpu-exit) ; e
+ (define-key map "f" #'tpu-cursor-free-mode) ; f
+ (define-key map "g" #'tpu-get) ; g
;; (define-key map "h" nil) ; h
- (define-key map "i" 'tpu-include) ; i
- (define-key map "k" 'tpu-kill-buffer) ; k
- (define-key map "l" 'goto-line) ; l
- (define-key map "m" 'buffer-menu) ; m
- (define-key map "n" 'tpu-next-file-buffer) ; n
- (define-key map "o" 'occur) ; o
- (define-key map "p" 'lpr-region) ; p
- (define-key map "q" 'tpu-quit) ; q
- (define-key map "r" 'tpu-toggle-rectangle) ; r
- (define-key map "s" 'replace) ; s
- (define-key map "t" 'tpu-line-to-top-of-window) ; t
- (define-key map "u" 'undo) ; u
- (define-key map "v" 'tpu-version) ; v
- (define-key map "w" 'save-buffer) ; w
- (define-key map "x" 'tpu-save-all-buffers-kill-emacs) ; x
- (define-key map "y" 'copy-region-as-kill) ; y
- (define-key map "z" 'suspend-emacs) ; z
+ (define-key map "i" #'tpu-include) ; i
+ (define-key map "k" #'tpu-kill-buffer) ; k
+ (define-key map "l" #'goto-line) ; l
+ (define-key map "m" #'buffer-menu) ; m
+ (define-key map "n" #'tpu-next-file-buffer) ; n
+ (define-key map "o" #'occur) ; o
+ (define-key map "p" #'lpr-region) ; p
+ (define-key map "q" #'tpu-quit) ; q
+ (define-key map "r" #'tpu-toggle-rectangle) ; r
+ (define-key map "s" #'replace) ; s
+ (define-key map "t" #'tpu-line-to-top-of-window) ; t
+ (define-key map "u" #'undo) ; u
+ (define-key map "v" #'tpu-version) ; v
+ (define-key map "w" #'save-buffer) ; w
+ (define-key map "x" #'tpu-save-all-buffers-kill-emacs) ; x
+ (define-key map "y" #'copy-region-as-kill) ; y
+ (define-key map "z" #'suspend-emacs) ; z
;; (define-key map "{" nil) ; {
- (define-key map "|" 'split-window-right) ; |
+ (define-key map "|" #'split-window-right) ; |
;; (define-key map "}" nil) ; }
- (define-key map "~" 'exchange-point-and-mark) ; ~
- (define-key map "\177" 'delete-window) ; <X]
+ (define-key map "~" #'exchange-point-and-mark) ; ~
+ (define-key map "\177" #'delete-window) ; <X]
map)
"Maps the function keys on the VT100 keyboard preceded by PF1.
GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
@@ -501,12 +489,12 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
;; Previously defined in CSI-map. We now presume that term/*.el does
;; its job to map the escape sequence to the right key-symbol.
- (define-key map [find] 'tpu-search) ; Find
- (define-key map [insert] 'tpu-paste) ; Insert Here
- (define-key map [delete] 'tpu-cut) ; Remove
- (define-key map [select] 'tpu-select) ; Select
- (define-key map [prior] 'tpu-scroll-window-down) ; Prev Screen
- (define-key map [next] 'tpu-scroll-window-up) ; Next Screen
+ (define-key map [find] #'tpu-search) ; Find
+ (define-key map [insert] #'tpu-paste) ; Insert Here
+ (define-key map [delete] #'tpu-cut) ; Remove
+ (define-key map [select] #'tpu-select) ; Select
+ (define-key map [prior] #'tpu-scroll-window-down) ; Prev Screen
+ (define-key map [next] #'tpu-scroll-window-up) ; Next Screen
;; (define-key map [f1] nil) ; F1
;; (define-key map [f2] nil) ; F2
@@ -517,14 +505,14 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
;; (define-key map [f7] nil) ; F7
;; (define-key map [f8] nil) ; F8
;; (define-key map [f9] nil) ; F9
- (define-key map [f10] 'tpu-exit) ; F10
- (define-key map [f11] 'tpu-insert-escape) ; F11 (ESC)
- (define-key map [f12] 'tpu-next-beginning-of-line) ; F12 (BS)
- (define-key map [f13] 'tpu-delete-previous-word) ; F13 (LF)
- (define-key map [f14] 'tpu-toggle-overwrite-mode) ; F14
- (define-key map [help] 'tpu-help) ; HELP
- (define-key map [menu] 'execute-extended-command) ; DO
- (define-key map [f17] 'tpu-goto-breadcrumb) ; F17
+ (define-key map [f10] #'tpu-exit) ; F10
+ (define-key map [f11] #'tpu-insert-escape) ; F11 (ESC)
+ (define-key map [f12] #'tpu-next-beginning-of-line) ; F12 (BS)
+ (define-key map [f13] #'tpu-delete-previous-word) ; F13 (LF)
+ (define-key map [f14] #'tpu-toggle-overwrite-mode) ; F14
+ (define-key map [help] #'tpu-help) ; HELP
+ (define-key map [menu] #'execute-extended-command) ; DO
+ (define-key map [f17] #'tpu-goto-breadcrumb) ; F17
;; (define-key map [f18] nil) ; F18
;; (define-key map [f19] nil) ; F19
;; (define-key map [f20] nil) ; F20
@@ -534,28 +522,28 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.")
;; its job to map the escape sequence to the right key-symbol.
(define-key map [kp-f1] tpu-gold-map) ; GOLD map
;;
- (define-key map [up] 'tpu-previous-line) ; up
- (define-key map [down] 'tpu-next-line) ; down
- (define-key map [right] 'tpu-forward-char) ; right
- (define-key map [left] 'tpu-backward-char) ; left
-
- (define-key map [kp-f2] 'tpu-help) ; PF2
- (define-key map [kp-f3] 'tpu-search-again) ; PF3
- (define-key map [kp-f4] 'tpu-delete-current-line) ; PF4
- (define-key map [kp-0] 'tpu-line) ; KP0
- (define-key map [kp-1] 'tpu-word) ; KP1
- (define-key map [kp-2] 'tpu-end-of-line) ; KP2
- (define-key map [kp-3] 'tpu-char) ; KP3
- (define-key map [kp-4] 'tpu-advance-direction) ; KP4
- (define-key map [kp-5] 'tpu-backup-direction) ; KP5
- (define-key map [kp-6] 'tpu-cut) ; KP6
- (define-key map [kp-7] 'tpu-page) ; KP7
- (define-key map [kp-8] 'tpu-scroll-window) ; KP8
- (define-key map [kp-9] 'tpu-append-region) ; KP9
- (define-key map [kp-subtract] 'tpu-delete-current-word) ; KP-
- (define-key map [kp-separator] 'tpu-delete-current-char) ; KP,
- (define-key map [kp-decimal] 'tpu-select) ; KP.
- (define-key map [kp-enter] 'newline) ; KPenter
+ (define-key map [up] #'tpu-previous-line) ; up
+ (define-key map [down] #'tpu-next-line) ; down
+ (define-key map [right] #'tpu-forward-char) ; right
+ (define-key map [left] #'tpu-backward-char) ; left
+
+ (define-key map [kp-f2] #'tpu-help) ; PF2
+ (define-key map [kp-f3] #'tpu-search-again) ; PF3
+ (define-key map [kp-f4] #'tpu-delete-current-line) ; PF4
+ (define-key map [kp-0] #'tpu-line) ; KP0
+ (define-key map [kp-1] #'tpu-word) ; KP1
+ (define-key map [kp-2] #'tpu-end-of-line) ; KP2
+ (define-key map [kp-3] #'tpu-char) ; KP3
+ (define-key map [kp-4] #'tpu-advance-direction) ; KP4
+ (define-key map [kp-5] #'tpu-backup-direction) ; KP5
+ (define-key map [kp-6] #'tpu-cut) ; KP6
+ (define-key map [kp-7] #'tpu-page) ; KP7
+ (define-key map [kp-8] #'tpu-scroll-window) ; KP8
+ (define-key map [kp-9] #'tpu-append-region) ; KP9
+ (define-key map [kp-subtract] #'tpu-delete-current-word) ; KP-
+ (define-key map [kp-separator] #'tpu-delete-current-char) ; KP,
+ (define-key map [kp-decimal] #'tpu-select) ; KP.
+ (define-key map [kp-enter] #'newline) ; KPenter
map)
"TPU-edt global keymap.")
@@ -892,8 +880,7 @@ With argument, fill and justify."
if no region is selected."
(interactive)
(let ((m (tpu-mark)))
- (apply (if tpu-have-ispell 'ispell-region
- 'spell-region)
+ (apply #'ispell-region
(if m
(if (> m (point)) (list (point) m)
(list m (point)))
@@ -980,14 +967,14 @@ and the total number of lines in the buffer."
;;;###autoload
(define-minor-mode tpu-edt-mode
"Toggle TPU/edt emulation on or off."
- :global t :group 'tpu
+ :global t
(if tpu-edt-mode (tpu-edt-on) (tpu-edt-off)))
-(defalias 'TPU-EDT-MODE 'tpu-edt-mode)
+(defalias 'TPU-EDT-MODE #'tpu-edt-mode)
;;;###autoload
-(defalias 'tpu-edt 'tpu-edt-on)
-(defalias 'TPU-EDT 'tpu-edt-on)
+(defalias 'tpu-edt #'tpu-edt-on)
+(defalias 'TPU-EDT #'tpu-edt-on)
;; Note: The following functions have no `tpu-' prefix. This is unavoidable.
;; The real TPU/edt editor has interactive commands with these names,
@@ -995,42 +982,42 @@ and the total number of lines in the buffer."
;; to work. Therefore it really is necessary to define these functions,
;; even in cases where they redefine existing Emacs functions.
-(defalias 'exit 'tpu-exit)
-(defalias 'EXIT 'tpu-exit)
+(defalias 'exit #'tpu-exit)
+(defalias 'EXIT #'tpu-exit)
-(defalias 'Get 'tpu-get)
-(defalias 'GET 'tpu-get)
+(defalias 'Get #'tpu-get)
+(defalias 'GET #'tpu-get)
-(defalias 'include 'tpu-include)
-(defalias 'INCLUDE 'tpu-include)
+(defalias 'include #'tpu-include)
+(defalias 'INCLUDE #'tpu-include)
-(defalias 'quit 'tpu-quit)
-(defalias 'QUIT 'tpu-quit)
+(defalias 'quit #'tpu-quit)
+(defalias 'QUIT #'tpu-quit)
-(defalias 'spell 'tpu-spell-check)
-(defalias 'SPELL 'tpu-spell-check)
+(defalias 'spell #'tpu-spell-check)
+(defalias 'SPELL #'tpu-spell-check)
-(defalias 'what\ line 'tpu-what-line)
-(defalias 'WHAT\ LINE 'tpu-what-line)
+(defalias 'what\ line #'tpu-what-line)
+(defalias 'WHAT\ LINE #'tpu-what-line)
-(defalias 'replace 'tpu-lm-replace)
-(defalias 'REPLACE 'tpu-lm-replace)
+(defalias 'replace #'tpu-lm-replace)
+(defalias 'REPLACE #'tpu-lm-replace)
-(defalias 'help 'tpu-help)
-(defalias 'HELP 'tpu-help)
+(defalias 'help #'tpu-help)
+(defalias 'HELP #'tpu-help)
-(defalias 'set\ cursor\ free 'tpu-set-cursor-free)
-(defalias 'SET\ CURSOR\ FREE 'tpu-set-cursor-free)
+(defalias 'set\ cursor\ free #'tpu-set-cursor-free)
+(defalias 'SET\ CURSOR\ FREE #'tpu-set-cursor-free)
-(defalias 'set\ cursor\ bound 'tpu-set-cursor-bound)
-(defalias 'SET\ CURSOR\ BOUND 'tpu-set-cursor-bound)
+(defalias 'set\ cursor\ bound #'tpu-set-cursor-bound)
+(defalias 'SET\ CURSOR\ BOUND #'tpu-set-cursor-bound)
-(defalias 'set\ scroll\ margins 'tpu-set-scroll-margins)
-(defalias 'SET\ SCROLL\ MARGINS 'tpu-set-scroll-margins)
+(defalias 'set\ scroll\ margins #'tpu-set-scroll-margins)
+(defalias 'SET\ SCROLL\ MARGINS #'tpu-set-scroll-margins)
;; Real TPU error messages end in periods.
;; Define this to avoid openly flouting Emacs coding standards.
-(defalias 'tpu-error 'error)
+(defalias 'tpu-error #'error)
;;;
@@ -1237,7 +1224,7 @@ and the total number of lines in the buffer."
"Bind a set of keystrokes to a single key, or key combination."
(interactive)
(setq tpu-saved-control-r (global-key-binding "\C-r"))
- (global-set-key "\C-r" 'tpu-end-define-macro-key)
+ (global-set-key "\C-r" #'tpu-end-define-macro-key)
(start-kbd-macro nil))
@@ -1371,18 +1358,18 @@ If an argument is specified, don't set the search direction."
(if (not arg) (setq tpu-searching-forward tpu-advance))
(cond (tpu-searching-forward
(cond (tpu-regexp-p
- (fset 'tpu-emacs-search 're-search-forward)
- (fset 'tpu-emacs-rev-search 're-search-backward))
+ (fset 'tpu-emacs-search #'re-search-forward)
+ (fset 'tpu-emacs-rev-search #'re-search-backward))
(t
- (fset 'tpu-emacs-search 'search-forward)
- (fset 'tpu-emacs-rev-search 'search-backward))))
+ (fset 'tpu-emacs-search #'search-forward)
+ (fset 'tpu-emacs-rev-search #'search-backward))))
(t
(cond (tpu-regexp-p
- (fset 'tpu-emacs-search 're-search-backward)
- (fset 'tpu-emacs-rev-search 're-search-forward))
+ (fset 'tpu-emacs-search #'re-search-backward)
+ (fset 'tpu-emacs-rev-search #'re-search-forward))
(t
- (fset 'tpu-emacs-search 'search-backward)
- (fset 'tpu-emacs-rev-search 'search-forward))))))
+ (fset 'tpu-emacs-search #'search-backward)
+ (fset 'tpu-emacs-rev-search #'search-forward))))))
(defun tpu-search-internal (pat &optional quiet)
"Search for a string or regular expression."
@@ -2213,18 +2200,18 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll."
;; Standard Emacs settings under xterm in function-key-map map
;; "\eOM" to [kp-enter] and [kp-enter] to RET, but since the output of the map
;; is not fed back into the map, the key stays as kp-enter :-(.
-(define-key minibuffer-local-map [kp-enter] 'exit-minibuffer)
+(define-key minibuffer-local-map [kp-enter] #'exit-minibuffer)
;; These are not necessary because they are inherited.
;; (define-key minibuffer-local-ns-map [kp-enter] 'exit-minibuffer)
;; (define-key minibuffer-local-completion-map [kp-enter] 'exit-minibuffer)
-(define-key minibuffer-local-must-match-map [kp-enter] 'minibuffer-complete-and-exit)
+(define-key minibuffer-local-must-match-map [kp-enter] #'minibuffer-complete-and-exit)
;;;
;;; Minibuffer map additions to set search direction
;;;
-(define-key minibuffer-local-map [kp-4] 'tpu-search-forward-exit) ;KP4
-(define-key minibuffer-local-map [kp-5] 'tpu-search-backward-exit) ;KP5
+(define-key minibuffer-local-map [kp-4] #'tpu-search-forward-exit) ;KP4
+(define-key minibuffer-local-map [kp-5] #'tpu-search-backward-exit) ;KP5
;;;
@@ -2233,19 +2220,19 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll."
(defvar tpu-control-keys-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-\\" 'quoted-insert) ; ^\
- (define-key map "\C-a" 'tpu-toggle-overwrite-mode) ; ^A
- (define-key map "\C-b" 'repeat-complex-command) ; ^B
- (define-key map "\C-e" 'tpu-current-end-of-line) ; ^E
- (define-key map "\C-h" 'tpu-next-beginning-of-line) ; ^H (BS)
- (define-key map "\C-j" 'tpu-delete-previous-word) ; ^J (LF)
- (define-key map "\C-k" 'tpu-define-macro-key) ; ^K
- (define-key map "\C-l" 'tpu-insert-formfeed) ; ^L (FF)
- (define-key map "\C-r" 'recenter) ; ^R
- (define-key map "\C-u" 'tpu-delete-to-bol) ; ^U
- (define-key map "\C-v" 'tpu-quoted-insert) ; ^V
- (define-key map "\C-w" 'redraw-display) ; ^W
- (define-key map "\C-z" 'tpu-exit) ; ^Z
+ (define-key map "\C-\\" #'quoted-insert) ; ^\
+ (define-key map "\C-a" #'tpu-toggle-overwrite-mode) ; ^A
+ (define-key map "\C-b" #'repeat-complex-command) ; ^B
+ (define-key map "\C-e" #'tpu-current-end-of-line) ; ^E
+ (define-key map "\C-h" #'tpu-next-beginning-of-line) ; ^H (BS)
+ (define-key map "\C-j" #'tpu-delete-previous-word) ; ^J (LF)
+ (define-key map "\C-k" #'tpu-define-macro-key) ; ^K
+ (define-key map "\C-l" #'tpu-insert-formfeed) ; ^L (FF)
+ (define-key map "\C-r" #'recenter) ; ^R
+ (define-key map "\C-u" #'tpu-delete-to-bol) ; ^U
+ (define-key map "\C-v" #'tpu-quoted-insert) ; ^V
+ (define-key map "\C-w" #'redraw-display) ; ^W
+ (define-key map "\C-z" #'tpu-exit) ; ^Z
map))
(defun tpu-set-control-keys ()
@@ -2295,18 +2282,18 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll."
(defun tpu-arrow-history nil
"Modify minibuffer maps to use arrows for history recall."
(interactive)
- (dolist (cur (where-is-internal 'tpu-previous-line))
- (define-key read-expression-map cur 'tpu-previous-history-element)
- (define-key minibuffer-local-map cur 'tpu-previous-history-element)
+ (dolist (cur (where-is-internal #'tpu-previous-line))
+ (define-key read-expression-map cur #'tpu-previous-history-element)
+ (define-key minibuffer-local-map cur #'tpu-previous-history-element)
;; These are inherited anyway. --Stef
;; (define-key minibuffer-local-ns-map cur 'tpu-previous-history-element)
;; (define-key minibuffer-local-completion-map cur 'tpu-previous-history-element)
;; (define-key minibuffer-local-must-match-map cur 'tpu-previous-history-element)
)
- (dolist (cur (where-is-internal 'tpu-next-line))
- (define-key read-expression-map cur 'tpu-next-history-element)
- (define-key minibuffer-local-map cur 'tpu-next-history-element)
+ (dolist (cur (where-is-internal #'tpu-next-line))
+ (define-key read-expression-map cur #'tpu-next-history-element)
+ (define-key minibuffer-local-map cur #'tpu-next-history-element)
;; These are inherited anyway. --Stef
;; (define-key minibuffer-local-ns-map cur 'tpu-next-history-element)
;; (define-key minibuffer-local-completion-map cur 'tpu-next-history-element)
@@ -2392,7 +2379,7 @@ If FILE is nil, try to load a default file. The default file names are
(use-global-map global-map)
;; Then do the normal TPU setup.
(transient-mark-mode t)
- (add-hook 'post-command-hook 'tpu-search-highlight)
+ (add-hook 'post-command-hook #'tpu-search-highlight)
(tpu-set-mode-line t)
(tpu-advance-direction)
;; set page delimiter, display line truncation, and scrolling like TPU
@@ -2416,7 +2403,7 @@ If FILE is nil, try to load a default file. The default file names are
"Turn off TPU/edt emulation. Note that the keypad is left on."
(interactive)
(tpu-reset-control-keys nil)
- (remove-hook 'post-command-hook 'tpu-search-highlight)
+ (remove-hook 'post-command-hook #'tpu-search-highlight)
(tpu-set-mode-line nil)
(while tpu-edt-old-global-values
(let ((varval (pop tpu-edt-old-global-values)))
diff --git a/lisp/obsolete/tpu-extras.el b/lisp/obsolete/tpu-extras.el
index 10b9c893721..f375e05d8ac 100644
--- a/lisp/obsolete/tpu-extras.el
+++ b/lisp/obsolete/tpu-extras.el
@@ -1,4 +1,4 @@
-;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt
+;;; tpu-extras.el --- scroll margins and free cursor mode for TPU-edt -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2000-2021 Free Software Foundation, Inc.
@@ -144,12 +144,12 @@ the previous line when starting from a line beginning."
;;; Hooks -- Set cursor free in picture mode.
;;; Clean up when writing a file from cursor free mode.
-(add-hook 'picture-mode-hook 'tpu-set-cursor-free)
+(add-hook 'picture-mode-hook #'tpu-set-cursor-free)
(defun tpu-trim-line-ends-if-needed ()
"Eliminate whitespace at ends of lines, if the cursor is free."
(if (and (buffer-modified-p) tpu-cursor-free-mode) (tpu-trim-line-ends)))
-(add-hook 'before-save-hook 'tpu-trim-line-ends-if-needed)
+(add-hook 'before-save-hook #'tpu-trim-line-ends-if-needed)
;;; Utility routines for implementing scroll margins
@@ -368,34 +368,22 @@ A repeat count means scroll that many sections."
(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)
+(defun tpu--respect-bottom-scroll-margin (orig-fun &optional &rest args)
"Respect `tpu-bottom-scroll-margin'."
(let ((beg (tpu-current-line))
- (num (prefix-numeric-value (ad-get-arg 0))))
- ad-do-it
+ (num (prefix-numeric-value (car args))))
+ (apply orig-fun args)
(tpu-bottom-check beg num)))
-(defadvice newline-and-indent (around tpu-respect-bottom-scroll-margin)
- "Respect `tpu-bottom-scroll-margin'."
- (let ((beg (tpu-current-line)))
- ad-do-it
- (tpu-bottom-check beg 1)))
-
-(defadvice do-auto-fill (around tpu-respect-bottom-scroll-margin)
- "Respect `tpu-bottom-scroll-margin'."
- (let ((beg (tpu-current-line)))
- ad-do-it
- (tpu-bottom-check beg 1)))
-
-
;;; Function to set scroll margins
;;;###autoload
-(defun tpu-set-scroll-margins (top bottom)
+(defun tpu-set-scroll-margins (top bottom &optional emit-msg)
"Set scroll margins."
(interactive
"sEnter top scroll margin (N lines or N%% or RETURN for current value): \
-\nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
+\nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): \
+\np")
;; set top scroll margin
(or (string= top "")
(setq tpu-top-scroll-margin
@@ -411,10 +399,9 @@ A repeat count means scroll that many sections."
(/ (1- (+ (* (string-to-number bottom) 100) (window-height)))
(window-height)))))
(dolist (f '(newline newline-and-indent do-auto-fill))
- (ad-enable-advice f 'around 'tpu-respect-bottom-scroll-margin)
- (ad-activate f))
+ (advice-add f :around #'tpu--respect-bottom-scroll-margin))
;; report scroll margin settings if running interactively
- (and (called-interactively-p 'interactive)
+ (and emit-msg
(message "Scroll margins set. Top = %s%%, Bottom = %s%%"
tpu-top-scroll-margin tpu-bottom-scroll-margin)))
diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el
index 2735820ae49..5ae0a6558d5 100644
--- a/lisp/obsolete/tpu-mapper.el
+++ b/lisp/obsolete/tpu-mapper.el
@@ -1,4 +1,4 @@
-;;; tpu-mapper.el --- create a TPU-edt X-windows keymap file
+;;; tpu-mapper.el --- create a TPU-edt X-windows keymap file -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2001-2021 Free Software Foundation, Inc.
@@ -69,7 +69,7 @@
;;;###autoload
(defun tpu-mapper ()
- "Create an Emacs lisp file defining the TPU-edt keypad for X-windows.
+ "Create an Emacs Lisp file defining the TPU-edt keypad for X-windows.
This command displays an instruction screen showing the TPU-edt keypad
and asks you to press the TPU-edt editing keys. It uses the keys you
diff --git a/lisp/obsolete/url-ns.el b/lisp/obsolete/url-ns.el
index fff3be95453..b62ad829990 100644
--- a/lisp/obsolete/url-ns.el
+++ b/lisp/obsolete/url-ns.el
@@ -1,4 +1,4 @@
-;;; url-ns.el --- Various netscape-ish functions for proxy definitions
+;;; url-ns.el --- Various netscape-ish functions for proxy definitions -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1999, 2004-2021 Free Software Foundation, Inc.
@@ -55,9 +55,9 @@
(if (or (/= (length netc) (length ipc))
(/= (length ipc) (length maskc)))
nil
- (setq netc (mapcar 'string-to-number netc)
- ipc (mapcar 'string-to-number ipc)
- maskc (mapcar 'string-to-number maskc))
+ (setq netc (mapcar #'string-to-number netc)
+ ipc (mapcar #'string-to-number ipc)
+ maskc (mapcar #'string-to-number maskc))
(and
(= (logand (nth 0 netc) (nth 0 maskc))
(logand (nth 0 ipc) (nth 0 maskc)))
@@ -79,24 +79,23 @@
(if (not (and (file-exists-p file)
(file-readable-p file)))
(message "Could not open %s for reading" file)
- (save-excursion
- (let ((false nil)
- (true t))
- (setq url-ns-user-prefs (make-hash-table :size 13 :test 'equal))
- (set-buffer (get-buffer-create " *ns-parse*"))
- (erase-buffer)
- (insert-file-contents file)
- (goto-char (point-min))
- (while (re-search-forward "^//" nil t)
- (replace-match ";;"))
- (goto-char (point-min))
- (while (re-search-forward "^user_pref(" nil t)
- (replace-match "(url-ns-set-user-pref "))
- (goto-char (point-min))
- (while (re-search-forward "\"," nil t)
- (replace-match "\""))
- (goto-char (point-min))
- (eval-buffer)))))
+ (setq url-ns-user-prefs (make-hash-table :size 13 :test 'equal))
+ (with-current-buffer (get-buffer-create " *ns-parse*")
+ (erase-buffer)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (while (re-search-forward "^//" nil t)
+ (replace-match ";;"))
+ (goto-char (point-min))
+ (while (re-search-forward "^user_pref(" nil t)
+ (replace-match "(url-ns-set-user-pref "))
+ (goto-char (point-min))
+ (while (re-search-forward "\"," nil t)
+ (replace-match "\""))
+ (goto-char (point-min))
+ (with-suppressed-warnings ((lexical true false))
+ (dlet ((false nil) (true t))
+ (eval-buffer))))))
(defun url-ns-set-user-pref (key val)
(puthash key val url-ns-user-prefs))
diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el
index 2d466b93be7..cfbf981d3c8 100644
--- a/lisp/obsolete/vc-arch.el
+++ b/lisp/obsolete/vc-arch.el
@@ -26,7 +26,7 @@
;; The home page of the Arch version control system is at
;;
-;; http://www.gnuarch.org/
+;; https://www.gnu.org/software/gnu-arch/
;;
;; This is derived from vc-mcvs.el as follows:
;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
@@ -81,8 +81,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc-arch)
+ :version "23.1")
(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1")
@@ -92,8 +91,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(setq candidates (cdr candidates)))
(or (car candidates) "tla"))
"Name of the Arch executable."
- :type 'string
- :group 'vc-arch)
+ :type 'string)
;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
@@ -341,7 +339,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
("--" . permissions-changed)
("-/" . permissions-changed) ;directory
))
- (state-map-regexp (regexp-opt (mapcar 'car state-map) t))
+ (state-map-regexp (regexp-opt (mapcar #'car state-map) t))
(entry-regexp (concat "^" state-map-regexp " \\(.*\\)$"))
result)
(goto-char (point-min))
@@ -387,8 +385,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(defcustom vc-arch-mode-line-rewrite
'(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]"))
"Rewrite rules to shorten Arch's revision names on the mode-line."
- :type '(repeat (cons regexp string))
- :group 'vc-arch)
+ :type '(repeat (cons regexp string)))
(defun vc-arch-mode-line-string (file)
"Return a string for `vc-mode-line' to put in the mode line for FILE."
@@ -420,7 +417,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
;; The .rej file is obsolete.
(condition-case nil (delete-file rej) (error nil))
;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t))))))
+ (remove-hook 'after-save-hook #'vc-arch-delete-rej-if-obsolete t))))))
(defun vc-arch-find-file-hook ()
(let ((rej (concat buffer-file-name ".rej")))
@@ -433,7 +430,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(condition-case nil (delete-file rej) (error nil))
(smerge-mode 1)
(add-hook 'after-save-hook
- 'vc-arch-delete-rej-if-obsolete nil t)
+ #'vc-arch-delete-rej-if-obsolete nil t)
(message "There are unresolved conflicts in this file")))
(message "There are unresolved conflicts in %s"
(file-name-nondirectory rej))))))
@@ -488,11 +485,11 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(defun vc-arch-rename-file (old new)
(vc-arch-command nil 0 new "mv" (file-relative-name old)))
-(defalias 'vc-arch-responsible-p 'vc-arch-root)
+(defalias 'vc-arch-responsible-p #'vc-arch-root)
(defun vc-arch-command (buffer okstatus file &rest flags)
"A wrapper around `vc-do-command' for use in vc-arch.el."
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags))
+ (apply #'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags))
;;; Completion of versions and revisions.
@@ -571,7 +568,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(when (string-match "-\\([0-9]+\\)\\'" f)
(cons (string-to-number (match-string 1 f)) f)))
(directory-files dir nil nil 'nosort)))
- 'car-less-than-car))
+ #'car-less-than-car))
(subdirs nil))
(when (cddr revs)
(dotimes (_i (/ (length revs) 2))
@@ -597,28 +594,29 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(unless (file-writable-p rl-dir)
(error "No writable revlib directory found"))
(message "Revlib at %s" rl-dir)
- (let* ((archives (directory-files rl-dir 'full (rx (or (not ".") "..."))))
+ (let* ((archives (directory-files rl-dir 'full
+ directory-files-no-dot-files-regexp))
(categories
- (apply 'append
+ (apply #'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
- (directory-files dir 'full
- (rx (or (not ".") "...")))))
+ (directory-files
+ dir 'full directory-files-no-dot-files-regexp)))
archives)))
(branches
- (apply 'append
+ (apply #'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
- (directory-files dir 'full
- (rx (or (not ".") "...")))))
+ (directory-files
+ dir 'full directory-files-no-dot-files-regexp)))
categories)))
(versions
- (apply 'append
+ (apply #'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
(directory-files dir 'full "--.*--")))
branches))))
- (mapc 'vc-arch-trim-one-revlib versions))
+ (mapc #'vc-arch-trim-one-revlib versions))
))
(defvar vc-arch-extra-menu-map
diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el
index df5ddfdbcf9..91baa4d28ef 100644
--- a/lisp/obsolete/vi.el
+++ b/lisp/obsolete/vi.el
@@ -1,4 +1,4 @@
-;;; vi.el --- major mode for emulating "vi" editor under GNU Emacs
+;;; vi.el --- major mode for emulating "vi" editor under GNU Emacs -*- lexical-binding: t; -*-
;; This file is in the public domain because the authors distributed it
;; without a copyright notice before the US signed the Bern Convention.
@@ -48,7 +48,7 @@
(defvar vi-mode-old-case-fold)
(if (null (where-is-internal 'vi-switch-mode (current-local-map)))
- (define-key ctl-x-map "~" 'vi-switch-mode))
+ (define-key ctl-x-map "~" #'vi-switch-mode))
(defvar vi-tilde-map nil
"Keymap used for \\[vi-switch-mode] prefix key. Link to various major modes.")
@@ -56,24 +56,24 @@
(if vi-tilde-map
nil
(setq vi-tilde-map (make-keymap))
- (define-key vi-tilde-map "a" 'abbrev-mode)
- (define-key vi-tilde-map "c" 'c-mode)
- (define-key vi-tilde-map "d" 'vi-debugging)
- (define-key vi-tilde-map "e" 'emacs-lisp-mode)
- (define-key vi-tilde-map "f" 'auto-fill-mode)
- (define-key vi-tilde-map "g" 'prolog-mode)
- (define-key vi-tilde-map "h" 'hanoi)
- (define-key vi-tilde-map "i" 'info-mode)
- (define-key vi-tilde-map "l" 'lisp-mode)
- (define-key vi-tilde-map "n" 'nroff-mode)
- (define-key vi-tilde-map "o" 'overwrite-mode)
- (define-key vi-tilde-map "O" 'outline-mode)
- (define-key vi-tilde-map "P" 'picture-mode)
- (define-key vi-tilde-map "r" 'vi-readonly-mode)
- (define-key vi-tilde-map "t" 'text-mode)
- (define-key vi-tilde-map "v" 'vi-mode)
- (define-key vi-tilde-map "x" 'tex-mode)
- (define-key vi-tilde-map "~" 'vi-back-to-old-mode))
+ (define-key vi-tilde-map "a" #'abbrev-mode)
+ (define-key vi-tilde-map "c" #'c-mode)
+ (define-key vi-tilde-map "d" #'vi-debugging)
+ (define-key vi-tilde-map "e" #'emacs-lisp-mode)
+ (define-key vi-tilde-map "f" #'auto-fill-mode)
+ (define-key vi-tilde-map "g" #'prolog-mode)
+ (define-key vi-tilde-map "h" #'hanoi)
+ ;; (define-key vi-tilde-map "i" #'info-mode)
+ (define-key vi-tilde-map "l" #'lisp-mode)
+ (define-key vi-tilde-map "n" #'nroff-mode)
+ (define-key vi-tilde-map "o" #'overwrite-mode)
+ (define-key vi-tilde-map "O" #'outline-mode)
+ (define-key vi-tilde-map "P" #'picture-mode)
+ (define-key vi-tilde-map "r" #'vi-readonly-mode)
+ (define-key vi-tilde-map "t" #'text-mode)
+ (define-key vi-tilde-map "v" #'vi-mode)
+ (define-key vi-tilde-map "x" #'tex-mode)
+ (define-key vi-tilde-map "~" #'vi-back-to-old-mode))
(defun vi-switch-mode (arg mode-char)
"Switch the major mode of current buffer as specified by the following char \\{vi-tilde-map}"
@@ -123,143 +123,143 @@ command extensions.")
(put 'vi-undefined 'suppress-keymap t)
(if vi-com-map nil
(setq vi-com-map (make-keymap))
-;;(fillarray vi-com-map 'vi-undefined)
- (define-key vi-com-map "\C-@" 'vi-mark-region) ; extension
- (define-key vi-com-map "\C-a" 'vi-ask-for-info) ; extension
- (define-key vi-com-map "\C-b" 'vi-backward-windowful)
- (define-key vi-com-map "\C-c" 'vi-do-old-mode-C-c-command) ; extension
- (define-key vi-com-map "\C-d" 'vi-scroll-down-window)
- (define-key vi-com-map "\C-e" 'vi-expose-line-below)
- (define-key vi-com-map "\C-f" 'vi-forward-windowful)
- (define-key vi-com-map "\C-g" 'keyboard-quit)
- (define-key vi-com-map "\C-i" 'indent-relative-first-indent-point) ; TAB
- (define-key vi-com-map "\C-j" 'vi-next-line) ; LFD
- (define-key vi-com-map "\C-k" 'vi-kill-line) ; extension
- (define-key vi-com-map "\C-l" 'recenter)
- (define-key vi-com-map "\C-m" 'vi-next-line-first-nonwhite) ; RET
- (define-key vi-com-map "\C-n" 'vi-next-line)
- (define-key vi-com-map "\C-o" 'vi-split-open-line)
- (define-key vi-com-map "\C-p" 'previous-line)
- (define-key vi-com-map "\C-q" 'vi-query-replace) ; extension
- (define-key vi-com-map "\C-r" 'vi-isearch-backward) ; modification
- (define-key vi-com-map "\C-s" 'vi-isearch-forward) ; extension
- (define-key vi-com-map "\C-t" 'vi-transpose-objects) ; extension
- (define-key vi-com-map "\C-u" 'vi-scroll-up-window)
- (define-key vi-com-map "\C-v" 'scroll-up-command) ; extension
- (define-key vi-com-map "\C-w" 'vi-kill-region) ; extension
+;;(fillarray vi-com-map #'vi-undefined)
+ (define-key vi-com-map "\C-@" #'vi-mark-region) ; extension
+ (define-key vi-com-map "\C-a" #'vi-ask-for-info) ; extension
+ (define-key vi-com-map "\C-b" #'vi-backward-windowful)
+ (define-key vi-com-map "\C-c" #'vi-do-old-mode-C-c-command) ; extension
+ (define-key vi-com-map "\C-d" #'vi-scroll-down-window)
+ (define-key vi-com-map "\C-e" #'vi-expose-line-below)
+ (define-key vi-com-map "\C-f" #'vi-forward-windowful)
+ (define-key vi-com-map "\C-g" #'keyboard-quit)
+ (define-key vi-com-map "\C-i" #'indent-relative-first-indent-point) ; TAB
+ (define-key vi-com-map "\C-j" #'vi-next-line) ; LFD
+ (define-key vi-com-map "\C-k" #'vi-kill-line) ; extension
+ (define-key vi-com-map "\C-l" #'recenter)
+ (define-key vi-com-map "\C-m" #'vi-next-line-first-nonwhite) ; RET
+ (define-key vi-com-map "\C-n" #'vi-next-line)
+ (define-key vi-com-map "\C-o" #'vi-split-open-line)
+ (define-key vi-com-map "\C-p" #'previous-line)
+ (define-key vi-com-map "\C-q" #'vi-query-replace) ; extension
+ (define-key vi-com-map "\C-r" #'vi-isearch-backward) ; modification
+ (define-key vi-com-map "\C-s" #'vi-isearch-forward) ; extension
+ (define-key vi-com-map "\C-t" #'vi-transpose-objects) ; extension
+ (define-key vi-com-map "\C-u" #'vi-scroll-up-window)
+ (define-key vi-com-map "\C-v" #'scroll-up-command) ; extension
+ (define-key vi-com-map "\C-w" #'vi-kill-region) ; extension
(define-key vi-com-map "\C-x" 'Control-X-prefix) ; extension
- (define-key vi-com-map "\C-y" 'vi-expose-line-above)
- (define-key vi-com-map "\C-z" 'suspend-emacs)
+ (define-key vi-com-map "\C-y" #'vi-expose-line-above)
+ (define-key vi-com-map "\C-z" #'suspend-emacs)
(define-key vi-com-map "\e" 'ESC-prefix); C-[ (ESC)
- (define-key vi-com-map "\C-\\" 'vi-unimplemented)
- (define-key vi-com-map "\C-]" 'find-tag)
- (define-key vi-com-map "\C-^" 'vi-locate-def) ; extension
- (define-key vi-com-map "\C-_" 'vi-undefined)
-
- (define-key vi-com-map " " 'forward-char)
- (define-key vi-com-map "!" 'vi-operator)
- (define-key vi-com-map "\"" 'vi-char-argument)
- (define-key vi-com-map "#" 'universal-argument) ; extension
- (define-key vi-com-map "$" 'end-of-line)
- (define-key vi-com-map "%" 'vi-find-matching-paren)
- (define-key vi-com-map "&" 'vi-unimplemented)
- (define-key vi-com-map "'" 'vi-goto-line-mark)
- (define-key vi-com-map "(" 'backward-sexp)
- (define-key vi-com-map ")" 'forward-sexp)
- (define-key vi-com-map "*" 'vi-name-last-change-or-macro) ; extension
- (define-key vi-com-map "+" 'vi-next-line-first-nonwhite)
- (define-key vi-com-map "," 'vi-reverse-last-find-char)
- (define-key vi-com-map "-" 'vi-previous-line-first-nonwhite)
- (define-key vi-com-map "." 'vi-redo-last-change-command)
- (define-key vi-com-map "/" 'vi-search-forward)
- (define-key vi-com-map "0" 'beginning-of-line)
-
- (define-key vi-com-map "1" 'vi-digit-argument)
- (define-key vi-com-map "2" 'vi-digit-argument)
- (define-key vi-com-map "3" 'vi-digit-argument)
- (define-key vi-com-map "4" 'vi-digit-argument)
- (define-key vi-com-map "5" 'vi-digit-argument)
- (define-key vi-com-map "6" 'vi-digit-argument)
- (define-key vi-com-map "7" 'vi-digit-argument)
- (define-key vi-com-map "8" 'vi-digit-argument)
- (define-key vi-com-map "9" 'vi-digit-argument)
-
- (define-key vi-com-map ":" 'vi-ex-cmd)
- (define-key vi-com-map ";" 'vi-repeat-last-find-char)
- (define-key vi-com-map "<" 'vi-operator)
- (define-key vi-com-map "=" 'vi-operator)
- (define-key vi-com-map ">" 'vi-operator)
- (define-key vi-com-map "?" 'vi-search-backward)
- (define-key vi-com-map "@" 'vi-call-named-change-or-macro) ; extension
-
- (define-key vi-com-map "A" 'vi-append-at-end-of-line)
- (define-key vi-com-map "B" 'vi-backward-blank-delimited-word)
- (define-key vi-com-map "C" 'vi-change-rest-of-line)
- (define-key vi-com-map "D" 'vi-kill-line)
- (define-key vi-com-map "E" 'vi-end-of-blank-delimited-word)
- (define-key vi-com-map "F" 'vi-backward-find-char)
- (define-key vi-com-map "G" 'vi-goto-line)
- (define-key vi-com-map "H" 'vi-home-window-line)
- (define-key vi-com-map "I" 'vi-insert-before-first-nonwhite)
- (define-key vi-com-map "J" 'vi-join-lines)
- (define-key vi-com-map "K" 'vi-undefined)
- (define-key vi-com-map "L" 'vi-last-window-line)
- (define-key vi-com-map "M" 'vi-middle-window-line)
- (define-key vi-com-map "N" 'vi-reverse-last-search)
- (define-key vi-com-map "O" 'vi-open-above)
- (define-key vi-com-map "P" 'vi-put-before)
- (define-key vi-com-map "Q" 'vi-quote-words) ; extension
- (define-key vi-com-map "R" 'vi-replace-chars)
- (define-key vi-com-map "S" 'vi-substitute-lines)
- (define-key vi-com-map "T" 'vi-backward-upto-char)
- (define-key vi-com-map "U" 'vi-unimplemented)
- (define-key vi-com-map "V" 'vi-undefined)
- (define-key vi-com-map "W" 'vi-forward-blank-delimited-word)
- (define-key vi-com-map "X" 'call-last-kbd-macro) ; modification/extension
- (define-key vi-com-map "Y" 'vi-yank-line)
+ (define-key vi-com-map "\C-\\" #'vi-unimplemented)
+ (define-key vi-com-map "\C-]" #'xref-find-definitions)
+ (define-key vi-com-map "\C-^" #'vi-locate-def) ; extension
+ (define-key vi-com-map "\C-_" #'vi-undefined)
+
+ (define-key vi-com-map " " #'forward-char)
+ (define-key vi-com-map "!" #'vi-operator)
+ (define-key vi-com-map "\"" #'vi-char-argument)
+ (define-key vi-com-map "#" #'universal-argument) ; extension
+ (define-key vi-com-map "$" #'end-of-line)
+ (define-key vi-com-map "%" #'vi-find-matching-paren)
+ (define-key vi-com-map "&" #'vi-unimplemented)
+ (define-key vi-com-map "'" #'vi-goto-line-mark)
+ (define-key vi-com-map "(" #'backward-sexp)
+ (define-key vi-com-map ")" #'forward-sexp)
+ (define-key vi-com-map "*" #'vi-name-last-change-or-macro) ; extension
+ (define-key vi-com-map "+" #'vi-next-line-first-nonwhite)
+ (define-key vi-com-map "," #'vi-reverse-last-find-char)
+ (define-key vi-com-map "-" #'vi-previous-line-first-nonwhite)
+ (define-key vi-com-map "." #'vi-redo-last-change-command)
+ (define-key vi-com-map "/" #'vi-search-forward)
+ (define-key vi-com-map "0" #'beginning-of-line)
+
+ (define-key vi-com-map "1" #'vi-digit-argument)
+ (define-key vi-com-map "2" #'vi-digit-argument)
+ (define-key vi-com-map "3" #'vi-digit-argument)
+ (define-key vi-com-map "4" #'vi-digit-argument)
+ (define-key vi-com-map "5" #'vi-digit-argument)
+ (define-key vi-com-map "6" #'vi-digit-argument)
+ (define-key vi-com-map "7" #'vi-digit-argument)
+ (define-key vi-com-map "8" #'vi-digit-argument)
+ (define-key vi-com-map "9" #'vi-digit-argument)
+
+ (define-key vi-com-map ":" #'vi-ex-cmd)
+ (define-key vi-com-map ";" #'vi-repeat-last-find-char)
+ (define-key vi-com-map "<" #'vi-operator)
+ (define-key vi-com-map "=" #'vi-operator)
+ (define-key vi-com-map ">" #'vi-operator)
+ (define-key vi-com-map "?" #'vi-search-backward)
+ (define-key vi-com-map "@" #'vi-call-named-change-or-macro) ; extension
+
+ (define-key vi-com-map "A" #'vi-append-at-end-of-line)
+ (define-key vi-com-map "B" #'vi-backward-blank-delimited-word)
+ (define-key vi-com-map "C" #'vi-change-rest-of-line)
+ (define-key vi-com-map "D" #'vi-kill-line)
+ (define-key vi-com-map "E" #'vi-end-of-blank-delimited-word)
+ (define-key vi-com-map "F" #'vi-backward-find-char)
+ (define-key vi-com-map "G" #'vi-goto-line)
+ (define-key vi-com-map "H" #'vi-home-window-line)
+ (define-key vi-com-map "I" #'vi-insert-before-first-nonwhite)
+ (define-key vi-com-map "J" #'vi-join-lines)
+ (define-key vi-com-map "K" #'vi-undefined)
+ (define-key vi-com-map "L" #'vi-last-window-line)
+ (define-key vi-com-map "M" #'vi-middle-window-line)
+ (define-key vi-com-map "N" #'vi-reverse-last-search)
+ (define-key vi-com-map "O" #'vi-open-above)
+ (define-key vi-com-map "P" #'vi-put-before)
+ (define-key vi-com-map "Q" #'vi-quote-words) ; extension
+ (define-key vi-com-map "R" #'vi-replace-chars)
+ (define-key vi-com-map "S" #'vi-substitute-lines)
+ (define-key vi-com-map "T" #'vi-backward-upto-char)
+ (define-key vi-com-map "U" #'vi-unimplemented)
+ (define-key vi-com-map "V" #'vi-undefined)
+ (define-key vi-com-map "W" #'vi-forward-blank-delimited-word)
+ (define-key vi-com-map "X" #'call-last-kbd-macro) ; modification/extension
+ (define-key vi-com-map "Y" #'vi-yank-line)
(define-key vi-com-map "Z" (make-sparse-keymap)) ;allow below prefix command
- (define-key vi-com-map "ZZ" 'vi-save-all-and-exit)
-
- (define-key vi-com-map "[" 'vi-unimplemented)
- (define-key vi-com-map "\\" 'vi-operator) ; extension for vi-narrow-op
- (define-key vi-com-map "]" 'vi-unimplemented)
- (define-key vi-com-map "^" 'back-to-indentation)
- (define-key vi-com-map "_" 'vi-undefined)
- (define-key vi-com-map "`" 'vi-goto-char-mark)
-
- (define-key vi-com-map "a" 'vi-insert-after)
- (define-key vi-com-map "b" 'backward-word)
- (define-key vi-com-map "c" 'vi-operator)
- (define-key vi-com-map "d" 'vi-operator)
- (define-key vi-com-map "e" 'vi-end-of-word)
- (define-key vi-com-map "f" 'vi-forward-find-char)
- (define-key vi-com-map "g" 'vi-beginning-of-buffer) ; extension
- (define-key vi-com-map "h" 'backward-char)
- (define-key vi-com-map "i" 'vi-insert-before)
- (define-key vi-com-map "j" 'vi-next-line)
- (define-key vi-com-map "k" 'previous-line)
- (define-key vi-com-map "l" 'forward-char)
- (define-key vi-com-map "m" 'vi-set-mark)
- (define-key vi-com-map "n" 'vi-repeat-last-search)
- (define-key vi-com-map "o" 'vi-open-below)
- (define-key vi-com-map "p" 'vi-put-after)
- (define-key vi-com-map "q" 'vi-replace)
- (define-key vi-com-map "r" 'vi-replace-1-char)
- (define-key vi-com-map "s" 'vi-substitute-chars)
- (define-key vi-com-map "t" 'vi-forward-upto-char)
- (define-key vi-com-map "u" 'undo)
- (define-key vi-com-map "v" 'vi-verify-spelling)
- (define-key vi-com-map "w" 'vi-forward-word)
- (define-key vi-com-map "x" 'vi-kill-char)
- (define-key vi-com-map "y" 'vi-operator)
- (define-key vi-com-map "z" 'vi-adjust-window)
-
- (define-key vi-com-map "{" 'backward-paragraph)
- (define-key vi-com-map "|" 'vi-goto-column)
- (define-key vi-com-map "}" 'forward-paragraph)
- (define-key vi-com-map "~" 'vi-change-case)
- (define-key vi-com-map "\177" 'delete-backward-char))
+ (define-key vi-com-map "ZZ" #'vi-save-all-and-exit)
+
+ (define-key vi-com-map "[" #'vi-unimplemented)
+ (define-key vi-com-map "\\" #'vi-operator) ; extension for vi-narrow-op
+ (define-key vi-com-map "]" #'vi-unimplemented)
+ (define-key vi-com-map "^" #'back-to-indentation)
+ (define-key vi-com-map "_" #'vi-undefined)
+ (define-key vi-com-map "`" #'vi-goto-char-mark)
+
+ (define-key vi-com-map "a" #'vi-insert-after)
+ (define-key vi-com-map "b" #'backward-word)
+ (define-key vi-com-map "c" #'vi-operator)
+ (define-key vi-com-map "d" #'vi-operator)
+ (define-key vi-com-map "e" #'vi-end-of-word)
+ (define-key vi-com-map "f" #'vi-forward-find-char)
+ (define-key vi-com-map "g" #'vi-beginning-of-buffer) ; extension
+ (define-key vi-com-map "h" #'backward-char)
+ (define-key vi-com-map "i" #'vi-insert-before)
+ (define-key vi-com-map "j" #'vi-next-line)
+ (define-key vi-com-map "k" #'previous-line)
+ (define-key vi-com-map "l" #'forward-char)
+ (define-key vi-com-map "m" #'vi-set-mark)
+ (define-key vi-com-map "n" #'vi-repeat-last-search)
+ (define-key vi-com-map "o" #'vi-open-below)
+ (define-key vi-com-map "p" #'vi-put-after)
+ (define-key vi-com-map "q" #'vi-replace)
+ (define-key vi-com-map "r" #'vi-replace-1-char)
+ (define-key vi-com-map "s" #'vi-substitute-chars)
+ (define-key vi-com-map "t" #'vi-forward-upto-char)
+ (define-key vi-com-map "u" #'undo)
+ (define-key vi-com-map "v" #'vi-verify-spelling)
+ (define-key vi-com-map "w" #'vi-forward-word)
+ (define-key vi-com-map "x" #'vi-kill-char)
+ (define-key vi-com-map "y" #'vi-operator)
+ (define-key vi-com-map "z" #'vi-adjust-window)
+
+ (define-key vi-com-map "{" #'backward-paragraph)
+ (define-key vi-com-map "|" #'vi-goto-column)
+ (define-key vi-com-map "}" #'forward-paragraph)
+ (define-key vi-com-map "~" #'vi-change-case)
+ (define-key vi-com-map "\177" #'delete-backward-char))
(put 'backward-char 'point-moving-unit 'char)
(put 'vi-next-line 'point-moving-unit 'line)
@@ -1182,7 +1182,7 @@ SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)."
(defun vi-narrow-op (motion-command arg)
"Narrow to region specified by MOTION-COMMAND with ARG."
(let* ((range (vi-effective-range motion-command arg))
- (begin (car range)) (end (cdr range)) reg)
+ (begin (car range)) (end (cdr range)))
(if (= begin end)
nil ; point not moved, abort op
(narrow-to-region begin end))))
@@ -1225,7 +1225,7 @@ SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)."
(defun vi-end-of-blank-delimited-word (count)
"Forward to the end of the COUNT'th blank-delimited word."
(interactive "p")
- (if (re-search-forward "[^ \t\n\']+[ \t\n\']" nil t count)
+ (if (re-search-forward "[^ \t\n']+[ \t\n']" nil t count)
(if (not (eobp)) (backward-char 2))))
(defun vi-home-window-line (arg)
diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el
index 9202f580d15..16906b68a67 100644
--- a/lisp/obsolete/vip.el
+++ b/lisp/obsolete/vip.el
@@ -1,4 +1,4 @@
-;;; vip.el --- a VI Package for GNU Emacs
+;;; vip.el --- a VI Package for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986-1988, 1992-1993, 1998, 2001-2021 Free Software
;; Foundation, Inc.
@@ -80,7 +80,7 @@
(defvar vip-current-major-mode nil
"vip-current-major-mode is the major-mode vi considers it is now.
-\(buffer specific\)")
+\(buffer specific)")
(make-variable-buffer-local 'vip-current-major-mode)
@@ -95,13 +95,11 @@
(defcustom vip-shift-width 8
"The number of columns shifted by > and < command."
- :type 'integer
- :group 'vip)
+ :type 'integer)
(defcustom vip-re-replace nil
"If t then do regexp replace, if nil then do string replace."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defvar vip-d-char nil
"The character remembered by the vi \"r\" command.")
@@ -120,13 +118,11 @@
(defcustom vip-search-wrap-around t
"If t, search wraps around."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defcustom vip-re-search nil
"If t, search is reg-exp search, otherwise vanilla search."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defvar vip-s-string nil
"Last vip search string.")
@@ -136,24 +132,20 @@
(defcustom vip-case-fold-search nil
"If t, search ignores cases."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defcustom vip-re-query-replace nil
"If t then do regexp replace, if nil then do string replace."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defcustom vip-open-with-indent nil
"If t, indent when open a new line."
- :type 'boolean
- :group 'vip)
+ :type 'boolean)
(defcustom vip-help-in-insert-mode nil
"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)
+ :type 'boolean)
(defvar vip-quote-string "> "
"String inserted at the beginning of region.")
@@ -169,131 +161,131 @@ If nil then it is bound to `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 [?\S-\ ] 'vip-scroll-back)
- (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)
+ (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 [?\S-\ ] #'vip-scroll-back)
+ (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 ()
@@ -306,8 +298,8 @@ If nil then it is bound to `delete-backward-char'."
;;;###autoload
(defun vip-setup ()
"Set up bindings for C-x 7 and C-z that are useful for VIP users."
- (define-key ctl-x-map "7" 'vip-buffer-in-two-windows)
- (global-set-key "\C-z" 'vip-change-mode-to-vi))
+ (define-key ctl-x-map "7" #'vip-buffer-in-two-windows)
+ (global-set-key "\C-z" #'vip-change-mode-to-vi))
(defmacro vip-loop (count body)
"(COUNT BODY) Execute BODY COUNT times."
@@ -375,13 +367,13 @@ No message."
vip-emacs-local-map)))
(vip-change-mode-line "Insert")
(use-local-map vip-insert-local-map)
- (define-key vip-insert-local-map "\e" 'vip-change-mode-to-vi)
- (define-key vip-insert-local-map "\C-z" 'vip-ESC)
+ (define-key vip-insert-local-map "\e" #'vip-change-mode-to-vi)
+ (define-key vip-insert-local-map "\C-z" #'vip-ESC)
(define-key vip-insert-local-map "\C-h"
- (if vip-help-in-insert-mode 'help-command
- 'delete-backward-char))
+ (if vip-help-in-insert-mode #'help-command
+ #'delete-backward-char))
(define-key vip-insert-local-map "\C-w"
- 'vip-delete-backward-word))
+ #'vip-delete-backward-word))
((eq new-mode 'emacs-mode)
(vip-change-mode-line "Emacs:")
(use-local-map vip-emacs-local-map)))
@@ -461,13 +453,13 @@ Type `n' to quit this window for now.\n")
ARG is used as the prefix value for the executed command. If
EVENTS is a list of events, which become the beginning of the command."
(interactive "P")
- (let (com key (old-map (current-local-map)))
+ (let (com (old-map (current-local-map)))
(if events (setq unread-command-events
(append events unread-command-events)))
(setq prefix-arg arg)
(use-local-map vip-emacs-local-map)
(unwind-protect
- (setq com (key-binding (setq key (read-key-sequence nil))))
+ (setq com (key-binding (read-key-sequence nil)))
(use-local-map old-map))
(command-execute com prefix-arg)
(setq prefix-arg nil) ;; reset prefix arg
@@ -617,7 +609,7 @@ obtained so far, and COM is the command part obtained so far."
(defun vip-command-argument (arg)
"Accept a motion command as an argument."
(interactive "P")
- (condition-case conditions
+ (condition-case nil
(vip-prefix-arg-com
last-command-event
(cond ((null arg) nil)
@@ -918,11 +910,11 @@ each line in the region."
(defun vip-read-string (prompt &optional init)
(setq vip-save-minibuffer-local-map (copy-keymap minibuffer-local-map))
- (define-key minibuffer-local-map "\C-h" 'backward-char)
- (define-key minibuffer-local-map "\C-w" 'backward-word)
- (define-key minibuffer-local-map "\e" 'exit-minibuffer)
+ (define-key minibuffer-local-map "\C-h" #'backward-char)
+ (define-key minibuffer-local-map "\C-w" #'backward-word)
+ (define-key minibuffer-local-map "\e" #'exit-minibuffer)
(let (str)
- (condition-case conditions
+ (condition-case nil
(setq str (read-string prompt init))
(quit
(setq minibuffer-local-map vip-save-minibuffer-local-map)
@@ -1510,7 +1502,7 @@ used. This behavior is controlled by the sign of prefix numeric value."
(* (/ (point-max) 100) arg)
(/ (* (point-max) arg) 100)))
(back-to-indentation))
- (cond ((looking-at "[\(\[{]")
+ (cond ((looking-at "[([{]")
(if com (move-marker vip-com-point (point)))
(forward-sexp 1)
(if com
@@ -1719,7 +1711,7 @@ STRING. Search will be forward if FORWARD, otherwise backward."
(let (buffer)
(setq buffer
(read-buffer
- (format "switch to buffer \(%s\): "
+ (format "switch to buffer (%s): "
(buffer-name (other-buffer (current-buffer))))))
(switch-to-buffer buffer)
(vip-change-mode-to-vi)))
@@ -1730,7 +1722,7 @@ STRING. Search will be forward if FORWARD, otherwise backward."
(let (buffer)
(setq buffer
(read-buffer
- (format "Switch to buffer \(%s\): "
+ (format "Switch to buffer (%s): "
(buffer-name (other-buffer (current-buffer))))))
(switch-to-buffer-other-window buffer)
(vip-change-mode-to-vi)))
@@ -1741,7 +1733,7 @@ STRING. Search will be forward if FORWARD, otherwise backward."
(let (buffer buffer-name)
(setq buffer-name
(read-buffer
- (format "Kill buffer \(%s\): "
+ (format "Kill buffer (%s): "
(buffer-name (current-buffer)))))
(setq buffer
(if (null buffer-name)
@@ -2162,7 +2154,7 @@ is a command.")
(defun vip-get-ex-token ()
"get an ex-token which is either an address or a command.
-a token has type \(command, address, end-mark\) and value."
+a token has type \(command, address, end-mark) and value."
(with-current-buffer " *ex-working-space*"
(skip-chars-forward " \t")
(cond ((looking-at "[k#]")
@@ -2651,7 +2643,7 @@ a token has type \(command, address, end-mark\) and value."
(progn
(with-output-to-temp-buffer " *delete text*"
(princ (buffer-substring (point) (mark))))
- (condition-case conditions
+ (condition-case nil
(vip-read-string "[Hit return to continue] ")
(quit
(save-excursion (kill-buffer " *delete text*"))
@@ -2668,7 +2660,7 @@ a token has type \(command, address, end-mark\) and value."
"ex-edit"
(vip-get-ex-file)
(if (and (not ex-variant) (buffer-modified-p) buffer-file-name)
- (error "No write since last change \(:e! overrides\)"))
+ (error "No write since last change (:e! overrides)"))
(vip-change-mode-to-emacs)
(set-buffer
(find-file-noselect (concat default-directory ex-file)))
@@ -2759,7 +2751,7 @@ a token has type \(command, address, end-mark\) and value."
(progn
(with-output-to-temp-buffer " *text*"
(princ (buffer-substring (point) (mark))))
- (condition-case conditions
+ (condition-case nil
(progn
(vip-read-string "[Hit return to continue] ")
(ex-line-subr com (point) (mark)))
@@ -2829,12 +2821,9 @@ a token has type \(command, address, end-mark\) and value."
(define-key ex-map char
(or (lookup-key vip-mode-map char) 'vip-nil)))
(define-key vip-mode-map char
- (eval
- (list 'quote
- (cons 'lambda
- (list '(count)
- '(interactive "p")
- (list 'execute-kbd-macro string 'count))))))))
+ (lambda (count)
+ (interactive "p")
+ (execute-kbd-macro string count)))))
(defun ex-unmap ()
"ex unmap"
@@ -2892,10 +2881,7 @@ a token has type \(command, address, end-mark\) and value."
(with-no-warnings
(insert-file file)))))
-(defun ex-set ()
- (eval (list 'setq
- (read-variable "Variable: ")
- (eval (read-minibuffer "Value: ")))))
+(defalias 'ex-set #'set-variable)
(defun ex-shell ()
"ex shell"
@@ -2935,7 +2921,7 @@ vip-s-string"
(setq ex-addresses (cons (car ex-addresses) ex-addresses)))))
;(setq G opt-g)
(let ((beg (car ex-addresses)) (end (car (cdr ex-addresses)))
- (cont t) eol-mark)
+ eol-mark) ;;(cont t)
(save-excursion
(vip-enlarge-region beg end)
(let ((limit (save-excursion
diff --git a/lisp/obsolete/ws-mode.el b/lisp/obsolete/ws-mode.el
index d1ced86c468..235a1d7e43d 100644
--- a/lisp/obsolete/ws-mode.el
+++ b/lisp/obsolete/ws-mode.el
@@ -41,144 +41,144 @@
(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)
+ (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-right)
- (define-key map "wo" 'other-window)
- (define-key map "wv" 'split-window-below)
+ (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-right)
+ (define-key map "wo" #'other-window)
+ (define-key map "wv" #'split-window-below)
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)
+ (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-command)
- (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-a" #'backward-word)
+ (define-key map "\C-b" #'fill-paragraph)
+ (define-key map "\C-c" #'scroll-up-command)
+ (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-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-p" #'quoted-insert)
(define-key map "\C-q" wordstar-C-q-map)
- (define-key map "\C-r" 'scroll-down-command)
- (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)
+ (define-key map "\C-r" #'scroll-down-command)
+ (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
diff --git a/lisp/obsolete/yow.el b/lisp/obsolete/yow.el
index 76485f989c1..ca8de4f9224 100644
--- a/lisp/obsolete/yow.el
+++ b/lisp/obsolete/yow.el
@@ -1,4 +1,4 @@
-;;; yow.el --- quote random zippyisms
+;;; yow.el --- quote random zippyisms -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 2000-2021 Free Software Foundation, Inc.
@@ -39,8 +39,7 @@
(defcustom yow-file (expand-file-name "yow.lines" data-directory)
"File containing pertinent pinhead phrases."
- :type 'file
- :group 'yow)
+ :type 'file)
(defconst yow-load-message "Am I CONSING yet?...")
(defconst yow-after-load-message "I have SEEN the CONSING!!")
diff --git a/lisp/org/ChangeLog.1 b/lisp/org/ChangeLog.1
index 90394db16a2..d350a3117b0 100644
--- a/lisp/org/ChangeLog.1
+++ b/lisp/org/ChangeLog.1
@@ -1615,7 +1615,7 @@
(org-babel-load-in-session-maybe, org-babel-pop-to-session-maybe):
Use it.
(org-babel-execute-src-block): Use `copy-tree' to prevent setf
- from modifying users variables withing let-bound `info' variable.
+ from modifying users variables within let-bound `info' variable.
* ob-exp.el (org-export-babel-evaluate): Add a 'inline-only
option.
@@ -1821,7 +1821,7 @@
it is an ARRAY ref, otherwise print it without a final newline.
(org-babel-perl-preface): Content of this variable is prepended to
body before invocation of perl. Rename input parameter body to
- ibody and let-bind body to concatentation of
+ ibody and let-bind body to concatenation of
`org-babel-perl-preface' and ibody. Implement results
interpretation so that tables are easier to produce.
@@ -3142,7 +3142,7 @@
relatively to the current timestamp, not to today's date.
* org-agenda.el (org-agenda-filter-apply):
- Deactive `org-agenda-entry-text-mode' when filtering.
+ Deactivate `org-agenda-entry-text-mode' when filtering.
(org-agenda-entry-text-mode): Don't allow in filtered views.
Don't show the maximum number of lines when turning off.
@@ -3439,7 +3439,7 @@
(org-edit-src-exit): Cancel the timer.
(org-edit-src-save): Prevent saving when editing fixed-width
buffer, exiting will save already.
- (org-edit-src-exit): Inconditionally kill the src/example
+ (org-edit-src-exit): Unconditionally kill the src/example
editing buffer.
* org-pcomplete.el (pcomplete/org-mode/file-option):
@@ -3490,7 +3490,7 @@
* org-pcomplete.el (pcomplete/org-mode/file-option/x):
Resurrect. Use `org-default-options' to initialize completion
- fonctions for the most important keywords.
+ functions for the most important keywords.
* org-macs.el (org-default-options): Rename and adapt from
`org-get-current-options'.
@@ -3588,7 +3588,7 @@
new sorting strategies.
(org-agenda-get-todos, org-agenda-get-timestamps)
(org-agenda-get-deadlines, org-agenda-get-scheduled): Add a
- `ts-date' text property with scheduled, deadline or timetamp
+ `ts-date' text property with scheduled, deadline or timestamp
date.
(org-cmp-ts): New function to compare timestamps.
(org-em): Add a docstring.
@@ -4800,7 +4800,7 @@
(org-element-timestamp-interpreter): Parse warning delays.
* ox-beamer.el (org-beamer--format-section): Fix regression which
- prevents frames from being propely exported.
+ prevents frames from being properly exported.
* ox.el (org-export-with-backend): Ensure function will use
provided back-end.
@@ -4888,7 +4888,7 @@
which is always nil in this back-end.
* org.el (org-adaptive-fill-function): Look for a fill prefix at
- the beginning of the paragraph and subsquently on its second line
+ the beginning of the paragraph and subsequently on its second line
instead of the current line.
* ob-core.el (org-babel-get-src-block-info): Look for indentation
@@ -5595,7 +5595,7 @@
(org-export-async-start): Do not call `org-mode' since this is done
already in the previous function.
- * ox-beamer.el (org-beamer-keyword): Remove frame arount toc when
+ * ox-beamer.el (org-beamer-keyword): Remove frame around toc when
generated from a TOC keyword.
* org.el (org-export-backends): Do not reset list of loaded
@@ -5629,7 +5629,7 @@
during a body-only export.
* ox.el (org-export-as): Store export options in :export-options
- porperty within communication channel.
+ property within communication channel.
* ox-latex.el (org-latex-item): Fix wrong behavior when a counter
is set in an ordered list while its parent is not ordered.
@@ -5714,7 +5714,7 @@
(org-create-formula-image-with-dvipng)
(org-create-formula-image-with-imagemagick): Use new function.
- * ox.el (org-export-get-previous-element): Change order of retured
+ * ox.el (org-export-get-previous-element): Change order of returned
elements in `org-export-get-previous-element'.
* org-element.el (org-element-all-successors): Add `plain-link'
@@ -5839,10 +5839,10 @@
Remove reference to now renamed `e-ascii' back-end.
* ox-beamer.el (org-beamer-template): Allow to span documentclass
- options accross multiple lines in template.
+ options across multiple lines in template.
* ox-latex.el (org-latex-template): Allow to span documentclass
- options accross multiple lines in template.
+ options across multiple lines in template.
* ox-texinfo.el (org-texinfo--get-node): Upcase property name.
(org-texinfo--get-node): New function.
@@ -6524,7 +6524,7 @@
* org.el (org-open-at-point): The new code is being run in the
same spot as `org-open-link-functions'. In case they failed,
check if link matches "^id:" and if so, load the id interface and
- follwo the link.
+ follow the link.
2013-11-12 Rasmus Pank Roulund <rasmus@gmx.us> (tiny change)
@@ -6717,7 +6717,7 @@
2013-11-12 Vitalie Spinu <spinuvit@gmail.com>
* ob-tangle.el (org-babel-find-file-noselect-refresh):
- Call `find-file-noselect' with 'nowarn argument to surpress
+ Call `find-file-noselect' with 'nowarn argument to suppress
`yes-or-no-p' reversion message.
* ob-core.el (org-babel-where-is-src-block-head):
@@ -6990,7 +6990,7 @@
docstrings. Also fix typos.
* org-list.el (org-list-struct-fix-box): When a checkbox has to be
- resetted because of a non-nil ORDERED property value, make sure it
+ reset because of a non-nil ORDERED property value, make sure it
had a checkbox already.
2013-02-07 Tokuya Kameshima <kametoku@gmail.com> (tiny change)
@@ -9533,7 +9533,7 @@
* org-latex.el (org-export-latex-make-header): Ditto.
* org-clock.el (org-clocktable-write-default): Temporarily disable
- `delete-active-region' so that we don't accidently delete an
+ `delete-active-region' so that we don't accidentally delete an
active region when exporting a subtree/region.
* org-clock.el (org-program-exists): Remove.
@@ -10419,7 +10419,7 @@
space character when auto-filling.
* org.el (org-mode): Call external initalizers. Now both filling
- code and comments code have their own independant part in org.el.
+ code and comments code have their own independent part in org.el.
(org-setup-filling): Rename from `org-set-autofill-regexps'.
(org-setup-comments-handling): New function.
@@ -10652,7 +10652,7 @@
(org-list-struct-apply-struct, org-insert-item): Remove rule
check.
- * org-footnote.el (org-footnote-normalize): Fix positionning in
+ * org-footnote.el (org-footnote-normalize): Fix positioning in
HTML export without a footnote section.
* org-list.el (org-list-struct-indent):
@@ -11318,7 +11318,7 @@
2012-04-01 Shaun Johnson <shaun@slugfest.demon.co.uk> (tiny change)
* org-exp-blocks.el (org-ditaa-jar-path): Better heuristic to find
- the libary name.
+ the library name.
2012-04-01 Suvayu Ali <fatkasuvayu+linux@gmail.com>
@@ -11917,7 +11917,7 @@
2012-04-01 Nicolas Goaziou <n.goaziou@gmail.com>
* org-footnote.el (org-footnote-at-definition-p): Make sure to
- move point at the beginning of the separator before skiping white
+ move point at the beginning of the separator before skipping white
spaces. Refactor code.
2012-04-01 Eric Schulte <eric.schulte@gmx.com>
@@ -13692,7 +13692,7 @@
2012-01-03 Carsten Dominik <carsten.dominik@gmail.com>
* org-publish.el (org-publish-cache-file-needs-publishing):
- Fix regexp to not inlcude newlines.
+ Fix regexp to not include newlines.
2012-01-03 Carsten Dominik <carsten.dominik@gmail.com>
@@ -14560,7 +14560,7 @@
2012-01-03 Nicolas Goaziou <n.goaziou@gmail.com>
* org-footnote.el (org-footnote-normalize): Effectively remove
- any footnote tag in non Org buffers, as detailled in the
+ any footnote tag in non Org buffers, as detailed in the
docstring of `org-footnote-tag-for-non-org-mode-files'.
2012-01-03 Nicolas Goaziou <n.goaziou@gmail.com>
@@ -15622,7 +15622,7 @@
2011-07-28 David Maus <dmaus@ictsoc.de>
* ob-haskell.el (org-babel-haskell-export-to-lhs):
- Call `kill-buffer' with argument indiciating to kill current
+ Call `kill-buffer' with argument indicating to kill current
buffer. Emacs 22 compatibility.
2011-07-28 David Maus <dmaus@ictsoc.de>
@@ -18049,7 +18049,7 @@
* org-table.el (org-table-fedit-finish): Read more general LHS of
formulas.
- (org-table-formula-handle-@L): New function to hanle @L references.
+ (org-table-formula-handle-@L): New function to handle @L references.
(org-table-current-ncol): New variable.
(org-table-line-to-dline): New function.
(org-table-get-stored-formulas): Accept range formulas as matches.
@@ -18058,7 +18058,7 @@
only the region marked by the range, not the content.
(org-table-recalculate): Call `org-table-expand-lhs-ranges' to expand
range targets. Also check for duplicate access to fields.
- (org-table-expand-lhs-ranges): New funktion.
+ (org-table-expand-lhs-ranges): New function.
(org-table-get-remote-range): Bind `org-table-current-ncol' to protect
the caller's value.
(org-table-edit-formulas): Support highlighting of range targets.
@@ -19339,8 +19339,8 @@
* org-crypt.el (org-encrypt-string): New function.
(org-encrypt-entry): Use org-encrypt-string to encrypt, so we use
- cached crypted values.
- (org-decrypt-entry): Store crypted text in decrypted text.
+ cached encrypted values.
+ (org-decrypt-entry): Store encrypted text in decrypted text.
2011-07-28 Dan Davison <dandavison7@gmail.com>
@@ -20331,7 +20331,7 @@
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-clock-special-range): Define variables. Use org-floor*.
(org-clocktable-write-default): Define tcol.
* org-compat.el (org-floor*): New function.
@@ -22854,7 +22854,7 @@
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.
+ only if cycling is possible and succeeded.
2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
@@ -28181,7 +28181,7 @@
* 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
+ * org-exp.el (org-export-format-source-code-or-example): Deal with
the new structure of the `org-export-latex-listings-langs'
variable.
@@ -28529,7 +28529,7 @@
* org.el (org-adapt-indentation): Slightly improve the docstring.
(org-occur): Sends an error when the user inputs an empty string.
- (org-priority): Bugfix: the tag alignement should happen within
+ (org-priority): Bugfix: the tag alignment should happen within
save-excursion.
2009-08-06 Bastien Guerry <bzg@gnu.org>
@@ -28830,7 +28830,7 @@
* org-agenda.el (org-agenda-mode): Reset list of marks.
(org-agenda-mode-map): Define new keys for refile and bulk action.
- (org-agenda-menu): Add menu itesm for refile and bulk action.
+ (org-agenda-menu): Add menu items for refile and bulk action.
(org-agenda-refile): New function.
(org-agenda-set-tags): Optional arguments TAG and ONOFF.
(org-agenda-marked-entries): New variable.
@@ -29490,7 +29490,7 @@
New functions.
(org-protocol-check-filename-for-protocol): Call `server-edit'.
- * org.el (org-default-properties): New default properteis for
+ * org.el (org-default-properties): New default properties for
completion.
* org-exp.el (org-export-add-subtree-options): Add new properties
@@ -29842,7 +29842,7 @@
* org-faces.el (org-checkbox): New face.
* org-exp.el (org-export-html-preprocess): Only create LaTeX
- fragement images if there is an export file.
+ fragment images if there is an export file.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -30465,7 +30465,7 @@
workings of `org-toggle-heading'.
(org-toggle-item): Rename from `org-toggle-region-items'.
No longer needs a region defined, but will use it if there is one.
- (org-ctrl-c-minus): Simplify, relying more on the inernal
+ (org-ctrl-c-minus): Simplify, relying more on the internal
workings of `org-toggle-item'.
* org-export-latex.el (org-export-latex-preprocess): Fix bug in
@@ -30674,7 +30674,7 @@
converter.
* org-exp.el (org-export-preprocess-string): Remove clock lines
- and timestamps already in the preprocesor.
+ and timestamps already in the preprocessor.
(org-export-remove-timestamps, org-export-remove-clock-lines):
New functions.
(org-export-as-ascii, org-export-as-html): Add the timestamps
@@ -31158,14 +31158,14 @@
2008-11-24 Carsten Dominik <carsten.dominik@gmail.com>
* org-agenda.el (org-get-closed): Re-apply changes
- accidentially overwritten by last commit to Emacs.
+ accidentally 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-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
+ (org-link-escape): Re-apply changes accidentally overwritten
by last commit to Emacs.
2008-11-23 Carsten Dominik <carsten.dominik@gmail.com>
diff --git a/lisp/org/ob-R.el b/lisp/org/ob-R.el
index 89430dea7e1..309a0acf7e7 100644
--- a/lisp/org/ob-R.el
+++ b/lisp/org/ob-R.el
@@ -361,7 +361,7 @@ Each member of this list is a list with three members:
)
}
}(object=%s,transfer.file=\"%s\")"
- "A template for an R command to evaluate a block of code and write the result to a file.
+ "Template for an R command to evaluate a block of code and write result to file.
Has four %s escapes to be filled in:
1. Row names, \"TRUE\" or \"FALSE\"
diff --git a/lisp/org/ob-clojure.el b/lisp/org/ob-clojure.el
index df2d691f68b..9834509fb03 100644
--- a/lisp/org/ob-clojure.el
+++ b/lisp/org/ob-clojure.el
@@ -38,7 +38,7 @@
;; For SLIME, 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
+;; web page: https://technomancy.us/126
;;; Code:
(require 'ob)
diff --git a/lisp/org/ob-comint.el b/lisp/org/ob-comint.el
index 18d4f3c9388..b14849df691 100644
--- a/lisp/org/ob-comint.el
+++ b/lisp/org/ob-comint.el
@@ -44,7 +44,7 @@
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))
+ (declare (indent 1) (debug t))
`(progn
(unless (org-babel-comint-buffer-livep ,buffer)
(error "Buffer %s does not exist or has no process" ,buffer))
@@ -53,7 +53,6 @@ executed inside the protection of `save-excursion' and
(save-excursion
(let ((comint-input-filter (lambda (_input) nil)))
,@body))))))
-(def-edebug-spec org-babel-comint-in-buffer (form body))
(defmacro org-babel-comint-with-output (meta &rest body)
"Evaluate BODY in BUFFER and return process output.
@@ -67,7 +66,7 @@ elements are optional.
This macro ensures that the filter is removed in case of an error
or user `keyboard-quit' during execution of body."
- (declare (indent 1))
+ (declare (indent 1) (debug (sexp body)))
(let ((buffer (nth 0 meta))
(eoe-indicator (nth 1 meta))
(remove-echo (nth 2 meta))
@@ -112,7 +111,6 @@ or user `keyboard-quit' during execution of body."
string-buffer))
(setq string-buffer (substring string-buffer (match-end 0))))
(split-string string-buffer comint-prompt-regexp)))))
-(def-edebug-spec org-babel-comint-with-output (sexp body))
(defun org-babel-comint-input-command (buffer cmd)
"Pass CMD to BUFFER.
diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el
index b1aee1b6c95..b1fd6943716 100644
--- a/lisp/org/ob-core.el
+++ b/lisp/org/ob-core.el
@@ -1100,7 +1100,7 @@ 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))
+ (declare (indent 1) (debug t))
(let ((tempvar (make-symbol "file")))
`(let* ((case-fold-search t)
(,tempvar ,file)
@@ -1139,7 +1139,6 @@ end-body --------- point at the end of the body"
(goto-char end-block)))))
(unless visited-p (kill-buffer to-be-removed))
(goto-char point))))
-(def-edebug-spec org-babel-map-src-blocks (form body))
;;;###autoload
(defmacro org-babel-map-inline-src-blocks (file &rest body)
@@ -1354,7 +1353,7 @@ the `org-mode-hook'."
(goto-char (match-beginning 0))
(org-babel-hide-hash)
(goto-char (match-end 0))))))
-(add-hook 'org-mode-hook 'org-babel-hide-all-hashes)
+(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.
@@ -1372,7 +1371,7 @@ This can be called with `\\[org-ctrl-c-ctrl-c]'."
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)
+(add-hook 'org-mode-hook #'org-babel-result-hide-spec)
(defvar org-babel-hide-result-overlays nil
"Overlays hiding results.")
@@ -1443,11 +1442,11 @@ portions of results lines."
(push ov org-babel-hide-result-overlays)))))
;; org-tab-after-check-for-cycling-hook
-(add-hook 'org-tab-first-hook 'org-babel-hide-result-toggle-maybe)
+(add-hook 'org-tab-first-hook #'org-babel-hide-result-toggle-maybe)
;; Remove overlays when changing major mode
(add-hook 'org-mode-hook
(lambda () (add-hook 'change-major-mode-hook
- 'org-babel-show-result-all 'append 'local)))
+ #'org-babel-show-result-all 'append 'local)))
(defun org-babel-params-from-properties (&optional lang no-eval)
"Retrieve source block parameters specified as properties.
@@ -2995,7 +2994,7 @@ situations in which is it not appropriate."
"If STRING represents a number return its value.
Otherwise return nil."
(unless (or (string-match-p "\\s-" (org-trim string))
- (not (string-match-p "^[0-9-e.+ ]+$" string)))
+ (not (string-match-p "^[0-9e.+ -]+$" string)))
(let ((interned-string (ignore-errors (read string))))
(when (numberp interned-string)
interned-string))))
@@ -3075,8 +3074,7 @@ Emacs shutdown."))
(defmacro org-babel-result-cond (result-params scalar-form &rest table-forms)
"Call the code to parse raw string results according to RESULT-PARAMS."
- (declare (indent 1)
- (debug (form form &rest form)))
+ (declare (indent 1) (debug t))
(org-with-gensyms (params)
`(let ((,params ,result-params))
(unless (member "none" ,params)
@@ -3093,7 +3091,6 @@ Emacs shutdown."))
(not (member "table" ,params))))
,scalar-form
,@table-forms)))))
-(def-edebug-spec org-babel-result-cond (form form body))
(defun org-babel-temp-file (prefix &optional suffix)
"Create a temporary file in the `org-babel-temporary-directory'.
@@ -3136,7 +3133,7 @@ of `org-babel-temporary-directory'."
org-babel-temporary-directory
"[directory not defined]"))))))
-(add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory)
+(add-hook 'kill-emacs-hook #'org-babel-remove-temporary-directory)
(defun org-babel-one-header-arg-safe-p (pair safe-list)
"Determine if the PAIR is a safe babel header arg according to SAFE-LIST.
diff --git a/lisp/org/ob-hledger.el b/lisp/org/ob-hledger.el
index 3d2f46cdce2..48dcb8cea1a 100644
--- a/lisp/org/ob-hledger.el
+++ b/lisp/org/ob-hledger.el
@@ -1,4 +1,4 @@
-;; ob-hledger.el --- Babel Functions for hledger -*- lexical-binding: t; -*-
+;;; ob-hledger.el --- Babel Functions for hledger -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
diff --git a/lisp/org/ob-lilypond.el b/lisp/org/ob-lilypond.el
index fbdd905a5fe..47397e66259 100644
--- a/lisp/org/ob-lilypond.el
+++ b/lisp/org/ob-lilypond.el
@@ -220,7 +220,7 @@ If error in compilation, attempt to mark the error in lilypond org file."
FILE-NAME is full path to lilypond (.ly) file."
(message "Compiling LilyPond...")
(let ((arg-1 org-babel-lilypond-ly-command) ;program
- (arg-2 nil) ;infile
+ ;; (arg-2 nil) ;infile
(arg-3 "*lilypond*") ;buffer
(arg-4 t) ;display
(arg-5 (if org-babel-lilypond-gen-png "--png" "")) ;&rest...
@@ -231,10 +231,10 @@ FILE-NAME is full path to lilypond (.ly) file."
(arg-10 (concat "--output=" (file-name-sans-extension file-name)))
(arg-11 file-name))
(if test
- `(,arg-1 ,arg-2 ,arg-3 ,arg-4 ,arg-5 ,arg-6
+ `(,arg-1 ,nil ,arg-3 ,arg-4 ,arg-5 ,arg-6 ;; arg-2
,arg-7 ,arg-8 ,arg-9 ,arg-10 ,arg-11)
(call-process
- arg-1 arg-2 arg-3 arg-4 arg-5 arg-6
+ arg-1 nil arg-3 arg-4 arg-5 arg-6 ;; arg-2
arg-7 arg-8 arg-9 arg-10 arg-11))))
(defun org-babel-lilypond-check-for-compile-error (file-name &optional test)
diff --git a/lisp/org/ob-mscgen.el b/lisp/org/ob-mscgen.el
index 999d4f4140b..79c9f8702eb 100644
--- a/lisp/org/ob-mscgen.el
+++ b/lisp/org/ob-mscgen.el
@@ -1,4 +1,4 @@
-;;; ob-msc.el --- Babel Functions for Mscgen -*- lexical-binding: t; -*-
+;;; ob-mscgen.el --- Babel Functions for Mscgen -*- lexical-binding: t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -78,4 +78,4 @@ mscgen supported formats."
(provide 'ob-mscgen)
-;;; ob-msc.el ends here
+;;; ob-mscgen.el ends here
diff --git a/lisp/org/ob-ocaml.el b/lisp/org/ob-ocaml.el
index 0aa91afdb24..5fd6d1e09ff 100644
--- a/lisp/org/ob-ocaml.el
+++ b/lisp/org/ob-ocaml.el
@@ -32,7 +32,7 @@
;;; Requirements:
-;; - tuareg-mode :: http://www-rocq.inria.fr/~acohen/tuareg/
+;; - tuareg-mode :: https://www-rocq.inria.fr/~acohen/tuareg/
;;; Code:
(require 'ob)
diff --git a/lisp/org/ob-screen.el b/lisp/org/ob-screen.el
index a9bd422cfcd..c3388c3d3de 100644
--- a/lisp/org/ob-screen.el
+++ b/lisp/org/ob-screen.el
@@ -127,7 +127,7 @@ The terminal should shortly flicker."
;; 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
- (message "org-babel-screen: File not readable yet."))
+ (sit-for 0.1))
(setq tmp-string (with-temp-buffer
(insert-file-contents-literally tmpfile)
(buffer-substring (point-min) (point-max))))
diff --git a/lisp/org/ob-sql.el b/lisp/org/ob-sql.el
index 902194ae884..947acef1b27 100644
--- a/lisp/org/ob-sql.el
+++ b/lisp/org/ob-sql.el
@@ -164,7 +164,8 @@ SQL Server on Windows and Linux platform."
" "))
(defun org-babel-sql-dbstring-vertica (host port user password database)
- "Make Vertica command line args for database connection. Pass nil to omit that arg."
+ "Make Vertica command line args for database connection.
+Pass nil to omit that arg."
(mapconcat #'identity
(delq nil
(list (when host (format "-h %s" host))
diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el
index 3c3943c8fa9..aa0373ab88e 100644
--- a/lisp/org/ob-tangle.el
+++ b/lisp/org/ob-tangle.el
@@ -150,7 +150,7 @@ represented in the file."
"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))
+ (declare (indent 1) (debug t))
(let ((temp-path (make-symbol "temp-path"))
(temp-result (make-symbol "temp-result"))
(temp-file (make-symbol "temp-file"))
@@ -164,7 +164,6 @@ evaluating BODY."
(setf ,temp-result (progn ,@body)))
(unless ,visited-p (kill-buffer ,temp-file))
,temp-result)))
-(def-edebug-spec org-babel-with-temp-filebuffer (form body))
;;;###autoload
(defun org-babel-tangle-file (file &optional target-file lang-re)
diff --git a/lisp/org/ol-bbdb.el b/lisp/org/ol-bbdb.el
index 84537b12319..01a1fe93255 100644
--- a/lisp/org/ol-bbdb.el
+++ b/lisp/org/ol-bbdb.el
@@ -431,7 +431,7 @@ variable to be globally bound."
;;; to override the 7-day default.
(defun org-bbdb-date-list (d n)
- "Return a list of dates in (m d y) format from the given date D to n-1 days hence."
+ "Return list of dates in (m d y) format from the given date D to n-1 days hence."
(let ((abs (calendar-absolute-from-gregorian d)))
(mapcar (lambda (i) (calendar-gregorian-from-absolute (+ abs i)))
(number-sequence 0 (1- n)))))
diff --git a/lisp/org/ol-eshell.el b/lisp/org/ol-eshell.el
index 769e7ee5225..8920e0afb0d 100644
--- a/lisp/org/ol-eshell.el
+++ b/lisp/org/ol-eshell.el
@@ -1,4 +1,4 @@
-;;; ol-eshell.el - Links to Working Directories in Eshell -*- lexical-binding: t; -*-
+;;; ol-eshell.el --- Links to Working Directories in Eshell -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/org/ol-gnus.el b/lisp/org/ol-gnus.el
index 71051bc6830..2d51447e0c4 100644
--- a/lisp/org/ol-gnus.el
+++ b/lisp/org/ol-gnus.el
@@ -198,11 +198,11 @@ If `org-store-link' was called with a prefix arg the meaning of
(to (mail-fetch-field "To"))
(from (mail-fetch-field "From"))
(subject (mail-fetch-field "Subject"))
- newsgroup xarchive) ;those are always nil for gcc
+ ) ;; newsgroup xarchive ;those are always nil for gcc
(unless gcc (error "Can not create link: No Gcc header found"))
(org-link-store-props :type "gnus" :from from :subject subject
:message-id id :group gcc :to to)
- (let ((link (org-gnus-article-link gcc newsgroup id xarchive))
+ (let ((link (org-gnus-article-link gcc nil id nil)) ;;newsgroup xarchive
(description (org-link-email-description)))
(org-link-add-props :link link :description description)
link)))))))
diff --git a/lisp/org/ol-w3m.el b/lisp/org/ol-w3m.el
index f1f3afd764d..ebb11ce3d54 100644
--- a/lisp/org/ol-w3m.el
+++ b/lisp/org/ol-w3m.el
@@ -7,13 +7,13 @@
;; Homepage: https://orgmode.org
;;
;; This file is part of GNU Emacs.
-;;
-;; This program is free software: you can redistribute it and/or modify
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
diff --git a/lisp/org/ol.el b/lisp/org/ol.el
index d1db1683bbe..38e2dd6a02c 100644
--- a/lisp/org/ol.el
+++ b/lisp/org/ol.el
@@ -376,9 +376,9 @@ changes to the current buffer."
Shell links can be dangerous: just think about a link
- [[shell:rm -rf ~/*][Google Search]]
+ [[shell:rm -rf ~/*][Web Search]]
-This link would show up in your Org document as \"Google Search\",
+This link would show up in your Org document as \"Web Search\",
but really it would remove your entire home directory.
Therefore we advise against setting this variable to nil.
Just change it to `y-or-n-p' if you want to confirm with a
@@ -401,9 +401,9 @@ single keystroke rather than having to type \"yes\"."
"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]]
+ [[elisp:(shell-command \"rm -rf ~/*\")][Web Search]]
-This link would show up in your Org document as \"Google Search\",
+This link would show up in your Org document as \"Web Search\",
but really it would remove your entire home directory.
Therefore we advise against setting this variable to nil.
Just change it to `y-or-n-p' if you want to confirm with a
@@ -591,7 +591,7 @@ 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 can continue with other options like
+nil to indicate that Org can continue with other options like
exact and fuzzy text search.")
@@ -1467,7 +1467,7 @@ non-nil."
(move-beginning-of-line 2)
(set-mark (point)))))
(setq org-store-link-plist nil)
- (let (link cpltxt desc description search custom-id agenda-link)
+ (let (link cpltxt desc search custom-id agenda-link) ;; description
(cond
;; Store a link using an external link type, if any function is
;; available. If more than one can generate a link from current
@@ -1598,7 +1598,7 @@ non-nil."
'org-create-file-search-functions))
(setq link (concat "file:" (abbreviate-file-name buffer-file-name)
"::" search))
- (setq cpltxt (or description link)))
+ (setq cpltxt (or link))) ;; description
((and (buffer-file-name (buffer-base-buffer)) (derived-mode-p 'org-mode))
(org-with-limited-levels
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index dedf7e5bb90..8a4aa2b1be0 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -2090,6 +2090,7 @@ Note that functions in this alist don't need to be quoted."
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."
+ (declare (debug t))
(org-with-gensyms (marker)
`(let ((,marker (get-text-property (if ,string 0 (point-at-bol))
'org-hd-marker ,string)))
@@ -2097,7 +2098,6 @@ of the current line."
(save-excursion
(goto-char ,marker)
,@body)))))
-(def-edebug-spec org-agenda-with-point-at-orig-entry (form body))
(defun org-add-agenda-custom-command (entry)
"Replace or add a command in `org-agenda-custom-commands'.
@@ -3224,6 +3224,15 @@ s Search for keywords M Like m, but only TODO entries
(defvar org-agenda-overriding-cmd nil)
(defvar org-agenda-overriding-arguments nil)
(defvar org-agenda-overriding-cmd-arguments nil)
+
+(defun org-let (list &rest body) ;FIXME: So many kittens are suffering here.
+ (declare (indent 1))
+ (eval (cons 'let (cons list body))))
+
+(defun org-let2 (list1 list2 &rest body) ;FIXME: Where did our karma go?
+ (declare (indent 2))
+ (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body)))))))
+
(defun org-agenda-run-series (name series)
"Run agenda NAME as a SERIES of agenda commands."
(org-let (nth 1 series) '(org-agenda-prepare name))
@@ -7558,7 +7567,8 @@ With a prefix argument, do so in all agenda buffers."
"Filter lines in the agenda buffer that have a specific category.
The category is that of the current line.
With a `\\[universal-argument]' prefix argument, exclude the lines of that category.
-When there is already a category filter in place, this command removes the filter."
+When there is already a category filter in place, this command removes the
+filter."
(interactive "P")
(if (and org-agenda-filtered-by-category
org-agenda-category-filter)
@@ -7734,9 +7744,9 @@ the variable `org-agenda-auto-exclude-function'."
(negate (equal strip-or-accumulate '(4)))
(cf (mapconcat #'identity org-agenda-category-filter ""))
(tf (mapconcat #'identity org-agenda-tag-filter ""))
- (rpl-fn (lambda (c) (replace-regexp-in-string "^\+" "" (or (car c) ""))))
- (ef (replace-regexp-in-string "^\+" "" (or (car org-agenda-effort-filter) "")))
- (rf (replace-regexp-in-string "^\+" "" (or (car org-agenda-regexp-filter) "")))
+ (rpl-fn (lambda (c) (replace-regexp-in-string "^\\+" "" (or (car c) ""))))
+ (ef (replace-regexp-in-string "^\\+" "" (or (car org-agenda-effort-filter) "")))
+ (rf (replace-regexp-in-string "^\\+" "" (or (car org-agenda-regexp-filter) "")))
(ff (concat cf tf ef (when (not (equal rf "")) (concat "/" rf "/"))))
(f-string (completing-read
(concat
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index 5eb5b749927..46decacca03 100644
--- a/lisp/org/org-attach.el
+++ b/lisp/org/org-attach.el
@@ -182,7 +182,7 @@ attachment folders based on ID."
:type '(repeat (function :tag "Function with ID as input")))
(defvar org-attach-after-change-hook nil
- "Hook to be called when files have been added or removed to the attachment folder.")
+ "Hook called when files have been added or removed to the attachment folder.")
(defvar org-attach-open-hook nil
"Hook that is invoked by `org-attach-open'.
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
index f40f2b335ef..7ae8fae3aab 100644
--- a/lisp/org/org-capture.el
+++ b/lisp/org/org-capture.el
@@ -521,7 +521,7 @@ for a capture buffer.")
"Minor mode for special key bindings in a capture buffer.
Turning on this mode runs the normal hook `org-capture-mode-hook'."
- nil " Cap" org-capture-mode-map
+ :lighter " Cap"
(setq-local
header-line-format
(substitute-command-keys
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index 2073b33380b..1283970bc2b 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -539,8 +539,8 @@ of a different task.")
"Marker pointing to the task that has been interrupted by the current clock.")
(defvar org-clock-mode-line-map (make-sparse-keymap))
-(define-key org-clock-mode-line-map [mode-line mouse-2] 'org-clock-goto)
-(define-key org-clock-mode-line-map [mode-line mouse-1] 'org-clock-menu)
+(define-key org-clock-mode-line-map [mode-line mouse-2] #'org-clock-goto)
+(define-key org-clock-mode-line-map [mode-line mouse-1] #'org-clock-menu)
(defun org-clock--translate (s language)
"Translate string S into using string LANGUAGE.
@@ -911,17 +911,17 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'."
(defmacro org-with-clock-position (clock &rest forms)
"Evaluate FORMS with CLOCK as the current active clock."
+ (declare (indent 1) (debug t))
`(with-current-buffer (marker-buffer (car ,clock))
(org-with-wide-buffer
(goto-char (car ,clock))
(beginning-of-line)
,@forms)))
-(def-edebug-spec org-with-clock-position (form body))
-(put 'org-with-clock-position 'lisp-indent-function 1)
(defmacro org-with-clock (clock &rest forms)
"Evaluate FORMS with CLOCK as the current active clock.
This macro also protects the current active clock from being altered."
+ (declare (indent 1) (debug t))
`(org-with-clock-position ,clock
(let ((org-clock-start-time (cdr ,clock))
(org-clock-total-time)
@@ -932,8 +932,6 @@ This macro also protects the current active clock from being altered."
(org-back-to-heading t)
(point-marker))))
,@forms)))
-(def-edebug-spec org-with-clock (form body))
-(put 'org-with-clock 'lisp-indent-function 1)
(defsubst org-clock-clock-in (clock &optional resume start-time)
"Clock in to the clock located by CLOCK.
@@ -1416,12 +1414,12 @@ the default behavior."
(setq org-clock-mode-line-timer
(run-with-timer org-clock-update-period
org-clock-update-period
- 'org-clock-update-mode-line)))
+ #'org-clock-update-mode-line)))
(when org-clock-idle-timer
(cancel-timer org-clock-idle-timer)
(setq org-clock-idle-timer nil))
(setq org-clock-idle-timer
- (run-with-timer 60 60 'org-resolve-clocks-if-idle))
+ (run-with-timer 60 60 #'org-resolve-clocks-if-idle))
(message "Clock starts at %s - %s" ts org--msg-extra)
(run-hooks 'org-clock-in-hook))))))
@@ -1718,7 +1716,7 @@ to, overriding the existing value of `org-clock-out-switch-to-state'."
(unless (org-clocking-p)
(setq org-clock-current-task nil)))))))
-(add-hook 'org-clock-out-hook 'org-clock-remove-empty-clock-drawer)
+(add-hook 'org-clock-out-hook #'org-clock-remove-empty-clock-drawer)
(defun org-clock-remove-empty-clock-drawer ()
"Remove empty clock drawers in current subtree."
@@ -2014,7 +2012,7 @@ Use `\\[org-clock-remove-overlays]' to remove the subtree times."
(when time (org-clock-put-overlay time)))))
;; Arrange to remove the overlays upon next change.
(when org-remove-highlights-with-change
- (add-hook 'before-change-functions 'org-clock-remove-overlays
+ (add-hook 'before-change-functions #'org-clock-remove-overlays
nil 'local))))
(let* ((h (/ org-clock-file-total-minutes 60))
(m (- org-clock-file-total-minutes (* 60 h))))
@@ -2065,7 +2063,7 @@ If NOREMOVE is nil, remove this function from the
(setq org-clock-overlays nil)
(unless noremove
(remove-hook 'before-change-functions
- 'org-clock-remove-overlays 'local))))
+ #'org-clock-remove-overlays 'local))))
;;;###autoload
(defun org-clock-out-if-current ()
@@ -2241,7 +2239,7 @@ have priority."
((>= month 7) 3)
((>= month 4) 2)
(t 1)))
- m1 h1 d1 month1 y1 shiftedy shiftedm shiftedq)
+ h1 d1 month1 y1 shiftedy shiftedm shiftedq) ;; m1
(cond
((string-match "\\`[0-9]+\\'" skey)
(setq y (string-to-number skey) month 1 d 1 key 'year))
@@ -2344,7 +2342,7 @@ have priority."
(`interactive (org-read-date nil t nil "Range end? "))
(`untilnow (current-time))
(_ (encode-time 0
- (or m1 m)
+ m ;; (or m1 m)
(or h1 h)
(or d1 d)
(or month1 month)
@@ -2391,7 +2389,7 @@ the currently selected interval size."
(user-error "Line needs a :block definition before this command works")
(let* ((b (match-beginning 1)) (e (match-end 1))
(s (match-string 1))
- block shift ins y mw d date wp m)
+ block shift ins y mw d date wp) ;; m
(cond
((equal s "yesterday") (setq s "today-1"))
((equal s "lastweek") (setq s "thisweek-1"))
@@ -2416,7 +2414,7 @@ the currently selected interval size."
(cond
(d (setq ins (format-time-string
"%Y-%m-%d"
- (encode-time 0 0 0 (+ d n) m y))))
+ (encode-time 0 0 0 (+ d n) nil y)))) ;; m
((and wp (string-match "w\\|W" wp) mw (> (length wp) 0))
(require 'cal-iso)
(setq date (calendar-gregorian-from-absolute
@@ -2934,12 +2932,12 @@ PROPERTIES: The list properties specified in the `:properties' parameter
(save-excursion
(org-clock-sum ts te
(when matcher
- `(lambda ()
- (let* ((todo (org-get-todo-state))
- (tags-list (org-get-tags))
- (org-scanner-tags tags-list)
- (org-trust-scanner-tags t))
- (funcall ,matcher todo tags-list nil)))))
+ (lambda ()
+ (let* ((todo (org-get-todo-state))
+ (tags-list (org-get-tags))
+ (org-scanner-tags tags-list)
+ (org-trust-scanner-tags t))
+ (funcall matcher todo tags-list nil)))))
(goto-char (point-min))
(setq st t)
(while (or (and (bobp) (prog1 st (setq st nil))
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 75056d45a7e..2f039064404 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -162,20 +162,20 @@ See `org-columns-summary-types' for details.")
(org-overview)
(org-content))
-(org-defkey org-columns-map "c" 'org-columns-content)
-(org-defkey org-columns-map "o" 'org-overview)
-(org-defkey org-columns-map "e" 'org-columns-edit-value)
-(org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo)
-(org-defkey org-columns-map "\C-c\C-c" 'org-columns-toggle-or-columns-quit)
-(org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link)
-(org-defkey org-columns-map "v" 'org-columns-show-value)
-(org-defkey org-columns-map "q" 'org-columns-quit)
-(org-defkey org-columns-map "r" 'org-columns-redo)
-(org-defkey org-columns-map "g" 'org-columns-redo)
-(org-defkey org-columns-map [left] 'backward-char)
-(org-defkey org-columns-map "\M-b" 'backward-char)
-(org-defkey org-columns-map "a" 'org-columns-edit-allowed)
-(org-defkey org-columns-map "s" 'org-columns-edit-attributes)
+(org-defkey org-columns-map "c" #'org-columns-content)
+(org-defkey org-columns-map "o" #'org-overview)
+(org-defkey org-columns-map "e" #'org-columns-edit-value)
+(org-defkey org-columns-map "\C-c\C-t" #'org-columns-todo)
+(org-defkey org-columns-map "\C-c\C-c" #'org-columns-toggle-or-columns-quit)
+(org-defkey org-columns-map "\C-c\C-o" #'org-columns-open-link)
+(org-defkey org-columns-map "v" #'org-columns-show-value)
+(org-defkey org-columns-map "q" #'org-columns-quit)
+(org-defkey org-columns-map "r" #'org-columns-redo)
+(org-defkey org-columns-map "g" #'org-columns-redo)
+(org-defkey org-columns-map [left] #'backward-char)
+(org-defkey org-columns-map "\M-b" #'backward-char)
+(org-defkey org-columns-map "a" #'org-columns-edit-allowed)
+(org-defkey org-columns-map "s" #'org-columns-edit-attributes)
(org-defkey org-columns-map "\M-f"
(lambda () (interactive) (goto-char (1+ (point)))))
(org-defkey org-columns-map [right]
@@ -187,7 +187,7 @@ See `org-columns-summary-types' for details.")
(while (and (org-invisible-p2) (not (eobp)))
(beginning-of-line 2))
(move-to-column col)
- (if (eq major-mode 'org-agenda-mode)
+ (if (derived-mode-p 'org-agenda-mode)
(org-agenda-do-context-action)))))
(org-defkey org-columns-map [up]
(lambda () (interactive)
@@ -198,20 +198,20 @@ See `org-columns-summary-types' for details.")
(move-to-column col)
(if (eq major-mode 'org-agenda-mode)
(org-agenda-do-context-action)))))
-(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
-(org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
-(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
-(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value)
-(org-defkey org-columns-map "<" 'org-columns-narrow)
-(org-defkey org-columns-map ">" 'org-columns-widen)
-(org-defkey org-columns-map [(meta right)] 'org-columns-move-right)
-(org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
-(org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
-(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
+(org-defkey org-columns-map [(shift right)] #'org-columns-next-allowed-value)
+(org-defkey org-columns-map "n" #'org-columns-next-allowed-value)
+(org-defkey org-columns-map [(shift left)] #'org-columns-previous-allowed-value)
+(org-defkey org-columns-map "p" #'org-columns-previous-allowed-value)
+(org-defkey org-columns-map "<" #'org-columns-narrow)
+(org-defkey org-columns-map ">" #'org-columns-widen)
+(org-defkey org-columns-map [(meta right)] #'org-columns-move-right)
+(org-defkey org-columns-map [(meta left)] #'org-columns-move-left)
+(org-defkey org-columns-map [(shift meta right)] #'org-columns-new)
+(org-defkey org-columns-map [(shift meta left)] #'org-columns-delete)
(dotimes (i 10)
(org-defkey org-columns-map (number-to-string i)
- `(lambda () (interactive)
- (org-columns-next-allowed-value nil ,i))))
+ (lambda () (interactive)
+ (org-columns-next-allowed-value nil i))))
(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
'("Column"
@@ -490,7 +490,7 @@ for the duration of the command.")
(org-add-props " " nil 'display `(space :align-to ,linum-offset))
(org-add-props (substring title 0 -1) nil 'face 'org-column-title)))
(setq org-columns-previous-hscroll -1)
- (add-hook 'post-command-hook 'org-columns-hscroll-title nil 'local)))
+ (add-hook 'post-command-hook #'org-columns-hscroll-title nil 'local)))
(defun org-columns-hscroll-title ()
"Set the `header-line-format' so that it scrolls along with the table."
@@ -519,7 +519,7 @@ for the duration of the command.")
(when (local-variable-p 'org-previous-header-line-format)
(setq header-line-format org-previous-header-line-format)
(kill-local-variable 'org-previous-header-line-format)
- (remove-hook 'post-command-hook 'org-columns-hscroll-title 'local))
+ (remove-hook 'post-command-hook #'org-columns-hscroll-title 'local))
(set-marker org-columns-begin-marker nil)
(when (markerp org-columns-top-level-marker)
(set-marker org-columns-top-level-marker nil))
@@ -782,7 +782,7 @@ around it."
(setq time-after (copy-sequence time))
(setf (nth 3 time-before) (1- (nth 3 time)))
(setf (nth 3 time-after) (1+ (nth 3 time)))
- (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x)))
+ (mapcar (lambda (x) (format-time-string fmt (apply #'encode-time x)))
(list time-before time time-after)))))
(defun org-columns-open-link (&optional arg)
diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el
index 1f4e2e8308f..b68e5b58fca 100644
--- a/lisp/org/org-compat.el
+++ b/lisp/org/org-compat.el
@@ -1151,8 +1151,8 @@ key."
((guard (not (lookup-key calendar-mode-map "c")))
(local-set-key "c" #'org-calendar-goto-agenda))
(_ nil))
- (unless (and (boundp 'org-agenda-diary-file)
- (eq org-agenda-diary-file 'diary-file))
+ (when (and (boundp 'org-agenda-diary-file)
+ (not (eq org-agenda-diary-file 'diary-file)))
(local-set-key org-calendar-insert-diary-entry-key
#'org-agenda-diary-entry)))
diff --git a/lisp/org/org-crypt.el b/lisp/org/org-crypt.el
index caf9de91b98..103baeb49e0 100644
--- a/lisp/org/org-crypt.el
+++ b/lisp/org/org-crypt.el
@@ -284,6 +284,8 @@ Assume `epg-context' is set."
nil)))
(_ nil)))
+(defvar org--matcher-tags-todo-only)
+
;;;###autoload
(defun org-encrypt-entries ()
"Encrypt all top-level entries in the current buffer."
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
index 8dc177df648..dc2b3be6326 100644
--- a/lisp/org/org-ctags.el
+++ b/lisp/org/org-ctags.el
@@ -1,5 +1,5 @@
-;;; org-ctags.el - Integrate Emacs "tags" Facility with Org -*- lexical-binding: t; -*-
-;;
+;;; org-ctags.el --- Integrate Emacs "tags" Facility with Org -*- lexical-binding: t; -*-
+
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Author: Paul Sexton <eeeickythump@gmail.com>
@@ -165,7 +165,7 @@ See the ctags documentation for more information.")
'(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."
+ "List of functions to be prepended to ORG-OPEN-LINK-FUNCTIONS by ORG-CTAGS."
:group 'org-ctags
:version "24.1"
:type 'hook
diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el
index b7319d638ed..31f5f78eae0 100644
--- a/lisp/org/org-element.el
+++ b/lisp/org/org-element.el
@@ -4206,6 +4206,7 @@ looking into captions:
(lambda (b)
(and (org-element-map b \\='latex-snippet #\\='identity nil t) b))
nil nil nil t)"
+ (declare (indent 2))
;; Ensure TYPES and NO-RECURSION are a list, even of one element.
(let* ((types (if (listp types) types (list types)))
(no-recursion (if (listp no-recursion) no-recursion
@@ -4299,7 +4300,6 @@ looking into captions:
(funcall --walk-tree data)
;; Return value in a proper order.
(nreverse --acc)))))
-(put 'org-element-map 'lisp-indent-function 2)
;; The following functions are internal parts of the parser.
;;
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index af2485c01cf..3475cadc42d 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -85,15 +85,13 @@ 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 setting the variable `org-indent-mode' will \
-turn off indentation adaptation.
+ "Non-nil means setting `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 setting the variable `org-indent-mode' will \
-turn on `org-hide-leading-stars'."
+ "Non-nil means setting `org-indent-mode' will turn on `org-hide-leading-stars'."
:group 'org-indent
:type 'boolean)
@@ -169,7 +167,7 @@ properties, after each buffer modification, on the modified zone.
The process is synchronous. Though, initial indentation of
buffer, which can take a few seconds on large buffers, is done
during idle time."
- nil " Ind" nil
+ :lighter " Ind"
(cond
(org-indent-mode
;; mode was turned on.
diff --git a/lisp/org/org-install.el b/lisp/org/org-install.el
index 58359597363..d521d819db2 100644
--- a/lisp/org/org-install.el
+++ b/lisp/org/org-install.el
@@ -1,4 +1,4 @@
-;;; org-install.el --- backward compatibility file for obsolete configuration
+;;; org-install.el --- backward compatibility file for obsolete configuration -*- lexical-binding: t -*-
;;
;;; Code:
;;
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 39122e7ce41..f97164ee33b 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -2304,7 +2304,7 @@ is an integer, 0 means `-', 1 means `+' etc. If WHICH is
;;;###autoload
(define-minor-mode org-list-checkbox-radio-mode
"When turned on, use list checkboxes as radio buttons."
- nil " CheckBoxRadio" nil
+ :lighter " CheckBoxRadio"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn this mode outside org-mode buffers")))
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 56afdf6ef19..58d3fd39922 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -627,18 +627,10 @@ program is needed for, so that the error message can be more informative."
(let ((message-log-max nil))
(apply #'message args)))
-(defun org-let (list &rest body)
- (eval (cons 'let (cons list body))))
-(put 'org-let 'lisp-indent-function 1)
-
-(defun org-let2 (list1 list2 &rest body)
- (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body)))))))
-(put 'org-let2 'lisp-indent-function 2)
-
(defun org-eval (form)
"Eval FORM and return result."
(condition-case error
- (eval form)
+ (eval form t)
(error (format "%%![Error: %s]" error))))
(defvar org-outline-regexp) ; defined in org.el
@@ -877,7 +869,8 @@ delimiting S."
(let ((width (plist-get props :width)))
(and (wholenump width) width)))
(`(image . ,_)
- (ceiling (car (image-size spec))))
+ (and (fboundp 'image-size)
+ (ceiling (car (image-size spec)))))
((pred stringp)
;; Displayed string could contain invisible parts,
;; but no nested display.
@@ -1241,31 +1234,29 @@ Return 0. if S is not recognized as a valid value."
When ADDITIONAL-KEYS is not nil, also include SPC and DEL in the
allowed keys for scrolling, as expected in the export dispatch
window."
- (let ((scrlup (if additional-keys '(?\s 22) 22))
- (scrldn (if additional-keys `(?\d 134217846) 134217846)))
- (eval
- `(cl-case ,key
- ;; C-n
- (14 (if (not (pos-visible-in-window-p (point-max)))
- (ignore-errors (scroll-up 1))
- (message "End of buffer")
- (sit-for 1)))
- ;; C-p
- (16 (if (not (pos-visible-in-window-p (point-min)))
- (ignore-errors (scroll-down 1))
- (message "Beginning of buffer")
- (sit-for 1)))
- ;; SPC or
- (,scrlup
- (if (not (pos-visible-in-window-p (point-max)))
- (scroll-up nil)
- (message "End of buffer")
- (sit-for 1)))
- ;; DEL
- (,scrldn (if (not (pos-visible-in-window-p (point-min)))
- (scroll-down nil)
- (message "Beginning of buffer")
- (sit-for 1)))))))
+ (let ((scrlup (if additional-keys '(?\s ?\C-v) ?\C-v))
+ (scrldn (if additional-keys `(?\d ?\M-v) ?\M-v)))
+ (pcase key
+ (?\C-n (if (not (pos-visible-in-window-p (point-max)))
+ (ignore-errors (scroll-up 1))
+ (message "End of buffer")
+ (sit-for 1)))
+ (?\C-p (if (not (pos-visible-in-window-p (point-min)))
+ (ignore-errors (scroll-down 1))
+ (message "Beginning of buffer")
+ (sit-for 1)))
+ ;; SPC or
+ ((guard (memq key scrlup))
+ (if (not (pos-visible-in-window-p (point-max)))
+ (scroll-up nil)
+ (message "End of buffer")
+ (sit-for 1)))
+ ;; DEL
+ ((guard (memq key scrldn))
+ (if (not (pos-visible-in-window-p (point-min)))
+ (scroll-down nil)
+ (message "Beginning of buffer")
+ (sit-for 1))))))
(provide 'org-macs)
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index 5c222ea70d5..57281dd68c0 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -167,14 +167,12 @@ indirectly, for example, through the agenda buffer.")
(defcustom org-mouse-punctuation ":"
"Punctuation used when inserting text by drag and drop."
- :group 'org-mouse
:type 'string)
(defcustom org-mouse-features
'(context-menu yank-link activate-stars activate-bullets activate-checkboxes)
"The features of org-mouse that should be activated.
Changing this variable requires a restart of Emacs to get activated."
- :group 'org-mouse
:type '(set :greedy t
(const :tag "Mouse-3 shows context menu" context-menu)
(const :tag "C-mouse-1 and mouse-3 move trees" move-tree)
@@ -292,19 +290,19 @@ 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."
(mapcar
- `(lambda (keyword)
+ (lambda (keyword)
(vector (cond
- ((functionp ,itemformat) (funcall ,itemformat keyword))
- ((stringp ,itemformat) (format ,itemformat keyword))
+ ((functionp itemformat) (funcall itemformat keyword))
+ ((stringp itemformat) (format itemformat keyword))
(t keyword))
- (list 'funcall ,function keyword)
+ (list 'funcall function keyword)
:style (cond
- ((null ,selected) t)
- ((functionp ,selected) 'toggle)
+ ((null selected) t)
+ ((functionp selected) 'toggle)
(t 'radio))
- :selected (if (functionp ,selected)
- (and (funcall ,selected keyword) t)
- (equal ,selected keyword))))
+ :selected (if (functionp selected)
+ (and (funcall selected keyword) t)
+ (equal selected keyword))))
keywords))
(defun org-mouse-remove-match-and-spaces ()
@@ -344,12 +342,12 @@ string to (format ITEMFORMAT keyword). If it is neither a string
nor a function, elements of KEYWORDS are used directly."
(setq group (or group 0))
(let ((replace (org-mouse-match-closure
- (if nosurround 'replace-match
- 'org-mouse-replace-match-and-surround))))
+ (if nosurround #'replace-match
+ #'org-mouse-replace-match-and-surround))))
(append
(org-mouse-keyword-menu
keywords
- `(lambda (keyword) (funcall ,replace keyword t t nil ,group))
+ (lambda (keyword) (funcall replace keyword t t nil group))
(match-string group)
itemformat)
`(["None" org-mouse-remove-match-and-spaces
@@ -416,7 +414,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(let ((kwds org-todo-keywords-1))
(org-mouse-keyword-menu
kwds
- `(lambda (kwd) (org-todo kwd))
+ #'org-todo
(lambda (kwd) (equal state kwd))))))
(defun org-mouse-tag-menu () ;todo
@@ -424,14 +422,14 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(append
(let ((tags (org-get-tags nil t)))
(org-mouse-keyword-menu
- (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
- `(lambda (tag)
+ (sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
+ (lambda (tag)
(org-mouse-set-tags
- (sort (if (member tag (quote ,tags))
- (delete tag (quote ,tags))
- (cons tag (quote ,tags)))
- 'string-lessp)))
- `(lambda (tag) (member tag (quote ,tags)))
+ (sort (if (member tag tags)
+ (delete tag tags)
+ (cons tag tags))
+ #'string-lessp)))
+ (lambda (tag) (member tag tags))
))
'("--"
["Align Tags Here" (org-align-tags) t]
@@ -500,7 +498,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
["Check TODOs" org-show-todo-tree t]
("Check Tags"
,@(org-mouse-keyword-menu
- (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
+ (sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
#'(lambda (tag) (org-tags-sparse-tree nil tag)))
"--"
["Custom Tag ..." org-tags-sparse-tree t])
@@ -510,16 +508,16 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
["Display TODO List" org-todo-list t]
("Display Tags"
,@(org-mouse-keyword-menu
- (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
+ (sort (mapcar #'car (org-get-buffer-tags)) #'string-lessp)
#'(lambda (tag) (org-tags-view nil tag)))
"--"
["Custom Tag ..." org-tags-view t])
["Display Calendar" org-goto-calendar t]
"--"
,@(org-mouse-keyword-menu
- (mapcar 'car org-agenda-custom-commands)
+ (mapcar #'car org-agenda-custom-commands)
#'(lambda (key)
- (eval `(org-agenda nil (string-to-char ,key))))
+ (org-agenda nil (string-to-char key)))
nil
#'(lambda (key)
(let ((entry (assoc key org-agenda-custom-commands)))
@@ -594,10 +592,10 @@ This means, between the beginning of line and the point."
(defun org-mouse-match-closure (function)
(let ((match (match-data t)))
- `(lambda (&rest rest)
- (save-match-data
- (set-match-data ',match)
- (apply ',function rest)))))
+ (lambda (&rest rest)
+ (save-match-data
+ (set-match-data match)
+ (apply function rest)))))
(defun org-mouse-yank-link (click)
(interactive "e")
@@ -631,7 +629,7 @@ This means, between the beginning of line and the point."
((save-excursion (beginning-of-line) (looking-at "[ \t]*#\\+STARTUP: \\(.*\\)"))
(popup-menu
`(nil
- ,@(org-mouse-list-options-menu (mapcar 'car org-startup-options)
+ ,@(org-mouse-list-options-menu (mapcar #'car org-startup-options)
'org-mode-restart))))
((or (eolp)
(and (looking-at "\\( \\|\t\\)\\(\\+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$")
@@ -857,21 +855,21 @@ This means, between the beginning of line and the point."
(add-hook 'org-mode-hook
#'(lambda ()
- (setq org-mouse-context-menu-function 'org-mouse-context-menu)
+ (setq org-mouse-context-menu-function #'org-mouse-context-menu)
(when (memq 'context-menu org-mouse-features)
(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)
+ (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)
- (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))
+ (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)
- (org-defkey org-mode-map [S-mouse-2] 'org-mouse-yank-link)
- (org-defkey 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)
- (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))
+ (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
@@ -1086,11 +1084,11 @@ This means, between the beginning of line and the point."
(defvar org-agenda-mode-map)
(add-hook 'org-agenda-mode-hook
(lambda ()
- (setq org-mouse-context-menu-function 'org-mouse-agenda-context-menu)
- (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)
+ (setq org-mouse-context-menu-function #'org-mouse-agenda-context-menu)
+ (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")
(cl-case (org-mouse-get-gesture event)
diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el
index 29d9d58482a..d8a4937b95a 100644
--- a/lisp/org/org-pcomplete.el
+++ b/lisp/org/org-pcomplete.el
@@ -239,11 +239,11 @@ When completing for #+STARTUP, for example, this function returns
(require 'ox)
(pcomplete-here
(and org-export-exclude-tags
- (list (mapconcat 'identity org-export-exclude-tags " ")))))
+ (list (mapconcat #'identity org-export-exclude-tags " ")))))
(defun pcomplete/org-mode/file-option/filetags ()
"Complete arguments for the #+FILETAGS file option."
- (pcomplete-here (and org-file-tags (mapconcat 'identity org-file-tags " "))))
+ (pcomplete-here (and org-file-tags (mapconcat #'identity org-file-tags " "))))
(defun pcomplete/org-mode/file-option/language ()
"Complete arguments for the #+LANGUAGE file option."
@@ -264,13 +264,13 @@ When completing for #+STARTUP, for example, this function returns
(require 'ox)
(pcomplete-here
(and org-export-select-tags
- (list (mapconcat 'identity org-export-select-tags " ")))))
+ (list (mapconcat #'identity org-export-select-tags " ")))))
(defun pcomplete/org-mode/file-option/startup ()
"Complete arguments for the #+STARTUP file option."
(while (pcomplete-here
(let ((opts (pcomplete-uniquify-list
- (mapcar 'car org-startup-options))))
+ (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)
@@ -340,7 +340,8 @@ When completing for #+STARTUP, for example, this function returns
"Complete against TeX-style HTML entity names."
(require 'org-entities)
(while (pcomplete-here
- (pcomplete-uniquify-list (remove nil (mapcar 'car-safe org-entities)))
+ (pcomplete-uniquify-list
+ (remove nil (mapcar #'car-safe org-entities)))
(substring pcomplete-stub 1))))
(defun pcomplete/org-mode/todo ()
diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el
index 7f9a6ae0264..726c1ca2bae 100644
--- a/lisp/org/org-protocol.el
+++ b/lisp/org/org-protocol.el
@@ -181,7 +181,8 @@ Possible properties are:
:working-directory - the local working directory. This is, what base-url will
be replaced with.
:redirects - A list of cons cells, each of which maps a regular
- expression to match to a path relative to :working-directory.
+ expression to match to a path relative to
+ :working-directory.
Example:
@@ -202,7 +203,8 @@ Example:
:working-directory \"~/site/content/post/\"
:online-suffix \".html\"
:working-suffix \".md\"
- :rewrites ((\"\\(https://site.com/[0-9]+/[0-9]+/[0-9]+/\\)\" . \".md\")))
+ :rewrites ((\"\\(https://site.com/[0-9]+/[0-9]+/[0-9]+/\\)\"
+ . \".md\")))
(\"GNU emacs OpenGrok\"
:base-url \"https://opengrok.housegordon.com/source/xref/emacs/\"
:working-directory \"~/dev/gnu-emacs/\")))
@@ -533,7 +535,7 @@ The location for a browser's bookmark should look like this:
encodeURIComponent(location.href)"
;; As we enter this function for a match on our protocol, the return value
;; defaults to nil.
- (let ((result nil)
+ (let (;; (result nil)
(f (org-protocol-sanitize-uri
(plist-get (org-protocol-parse-parameters fname nil '(:url))
:url))))
@@ -584,7 +586,7 @@ The location for a browser's bookmark should look like this:
(if (file-exists-p the-file)
(message "%s: permission denied!" the-file)
(message "%s: no such file or directory." the-file))))))
- result)))
+ nil))) ;; FIXME: Really?
;;; Core functions:
diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el
index f7ba15606c9..8b42f817c1a 100644
--- a/lisp/org/org-refile.el
+++ b/lisp/org/org-refile.el
@@ -7,18 +7,18 @@
;;
;; This file is part of GNU Emacs.
-;; This program is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -373,7 +373,7 @@ the *old* location.")
(defvar org-refile-keep nil
"Non-nil means `org-refile' will copy instead of refile.")
-(define-obsolete-function-alias 'org-copy 'org-refile-copy)
+(define-obsolete-function-alias 'org-copy 'org-refile-copy "Org 9.4")
;;;###autoload
(defun org-refile-copy ()
diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el
index 20acee4e662..cabedecb689 100644
--- a/lisp/org/org-src.el
+++ b/lisp/org/org-src.el
@@ -682,7 +682,7 @@ This minor mode is turned on in two situations:
\\{org-src-mode-map}
See also `org-src-mode-hook'."
- nil " OrgSrc" nil
+ :lighter " OrgSrc"
(when org-edit-src-persistent-message
(setq header-line-format
(substitute-command-keys
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index ef4672e1b96..0e93fb271f3 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -495,7 +495,7 @@ This may be useful when columns have been shrunk."
;;;###autoload
(define-minor-mode org-table-header-line-mode
"Display the first row of the table at point in the header line."
- nil " TblHeader" nil
+ :lighter " TblHeader"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn org table header mode outside org-mode buffers"))
(if org-table-header-line-mode
@@ -1976,7 +1976,7 @@ lines."
When this mode is active, the field editor window will always show the
current field. The mode exits automatically when the cursor leaves the
table (but see `org-table-exit-follow-field-mode-when-leaving-table')."
- nil " TblFollow" nil
+ :lighter " TblFollow"
(if org-table-follow-field-mode
(add-hook 'post-command-hook 'org-table-follow-fields-with-editor
'append 'local)
@@ -2008,7 +2008,7 @@ toggle `org-table-follow-field-mode'."
(let ((b (save-excursion (skip-chars-backward "^|") (point)))
(e (save-excursion (skip-chars-forward "^|\r\n") (point))))
(remove-text-properties b e '(invisible t intangible t))
- (if (and (boundp 'font-lock-mode) font-lock-mode)
+ (if font-lock-mode
(font-lock-fontify-block))))
(t
(let ((pos (point-marker))
@@ -5149,7 +5149,7 @@ When LOCAL is non-nil, show references for the table at point."
;;;###autoload
(define-minor-mode orgtbl-mode
"The Org mode table editor as a minor mode for use in other modes."
- :lighter " OrgTbl" :keymap orgtbl-mode-map
+ :lighter " OrgTbl"
(org-load-modules-maybe)
(cond
((derived-mode-p 'org-mode)
diff --git a/lisp/org/org-tempo.el b/lisp/org/org-tempo.el
index 36b8614fe1c..c121b8e7aca 100644
--- a/lisp/org/org-tempo.el
+++ b/lisp/org/org-tempo.el
@@ -65,7 +65,7 @@ just like `org-structure-template-alist'. The tempo snippet
\"<KEY\" will be expanded using the KEYWORD value. For example
\"<L\" at the beginning of a line is expanded to \"#+latex:\".
-Do not use \"I\" as a KEY, as it it reserved for expanding
+Do not use \"I\" as a KEY, as it is reserved for expanding
\"#+include\"."
:group 'org-tempo
:type '(repeat (cons (string :tag "Key")
diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el
index b6802fe8b04..852d18579a4 100644
--- a/lisp/org/org-timer.el
+++ b/lisp/org/org-timer.el
@@ -366,7 +366,7 @@ VALUE can be `on', `off', or `paused'."
(setq org-timer-mode-line-timer nil))
(when org-timer-display
(setq org-timer-mode-line-timer
- (run-with-timer 1 1 'org-timer-update-mode-line))))))
+ (run-with-timer 1 1 #'org-timer-update-mode-line))))))
(defun org-timer-update-mode-line ()
"Update the timer time in the mode line."
@@ -456,14 +456,15 @@ using three `C-u' prefix arguments."
"Start countdown timer that will last SECS.
TITLE will be appended to the notification message displayed when
time is up."
- (let ((msg (format "%s: time out" title)))
+ (let ((msg (format "%s: time out" title))
+ (sound org-clock-sound))
(run-with-timer
- secs nil `(lambda ()
- (setq org-timer-countdown-timer nil
- org-timer-start-time nil)
- (org-notify ,msg ,org-clock-sound)
- (org-timer-set-mode-line 'off)
- (run-hooks 'org-timer-done-hook)))))
+ secs nil (lambda ()
+ (setq org-timer-countdown-timer nil
+ org-timer-start-time nil)
+ (org-notify msg sound)
+ (org-timer-set-mode-line 'off)
+ (run-hooks 'org-timer-done-hook)))))
(defun org-timer--get-timer-title ()
"Construct timer title.
diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el
index 25b3354bdd7..8871ef798d5 100644
--- a/lisp/org/org-version.el
+++ b/lisp/org/org-version.el
@@ -1,4 +1,4 @@
-;;; org-version.el --- autogenerated file, do not edit
+;;; org-version.el --- autogenerated file, do not edit -*- lexical-binding: t -*-
;;
;;; Code:
;;;###autoload
diff --git a/lisp/org/org.el b/lisp/org/org.el
index c61b8fb56c0..f560c65dc4f 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -1846,7 +1846,7 @@ link types. The types are:
bracket The recommended [[link][description]] or [[link]] links with hiding.
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.
+plain Plain links in normal text, no whitespace, like https://gnu.org.
radio Text that is matched by a radio target, see manual for details.
tag Tag settings in a headline (link to tag search).
date Time stamps (link to calendar).
@@ -4112,7 +4112,8 @@ groups carry important information:
"Regular expression to match a timestamp time or time range.
After a match, the following groups carry important information:
0 the full match
-1 date plus weekday, for back referencing to make sure both times are on the same day
+1 date plus weekday, for back referencing to make sure
+ both times are on the same day
2 the first time, range or not
4 the second time, if it is a range.")
@@ -4756,8 +4757,8 @@ This is for getting out of special buffers like capture.")
;; Other stuff we need.
(require 'time-date)
(unless (fboundp 'time-subtract) (defalias 'time-subtract 'subtract-time))
-(require 'easymenu)
-(require 'overlay)
+(when (< emacs-major-version 28) ; preloaded in Emacs 28
+ (require 'easymenu))
(require 'org-entities)
(require 'org-faces)
@@ -5519,7 +5520,7 @@ highlighting was done, nil otherwise."
(defun org-restart-font-lock ()
"Restart `font-lock-mode', to force refontification."
- (when (and (boundp 'font-lock-mode) font-lock-mode)
+ (when font-lock-mode
(font-lock-mode -1)
(font-lock-mode 1)))
@@ -15583,7 +15584,7 @@ When a buffer is unmodified, it is just killed. When modified, it is saved
This mode supports entering LaTeX environment and math in LaTeX fragments
in Org mode.
\\{org-cdlatex-mode-map}"
- nil " OCDL" nil
+ :lighter " OCDL"
(when org-cdlatex-mode
(require 'cdlatex)
(run-hooks 'cdlatex-mode-hook)
@@ -20317,7 +20318,7 @@ unless optional argument NO-INHERITANCE is non-nil."
(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
+If the heading only contains a TODO keyword, it is still considered
empty."
(let ((case-fold-search nil))
(and (looking-at "[ \t]*$")
diff --git a/lisp/org/ox-beamer.el b/lisp/org/ox-beamer.el
index 1a1732b6836..6ed95e84d6b 100644
--- a/lisp/org/ox-beamer.el
+++ b/lisp/org/ox-beamer.el
@@ -895,14 +895,16 @@ holding export options."
;;; Minor Mode
-(defvar org-beamer-mode-map (make-sparse-keymap)
+(defvar org-beamer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-b" 'org-beamer-select-environment)
+ map)
"The keymap for `org-beamer-mode'.")
-(define-key org-beamer-mode-map "\C-c\C-b" 'org-beamer-select-environment)
;;;###autoload
(define-minor-mode org-beamer-mode
"Support for editing Beamer oriented Org mode files."
- nil " Bm" 'org-beamer-mode-map)
+ :lighter " Bm")
(when (fboundp 'font-lock-add-keywords)
(font-lock-add-keywords
diff --git a/lisp/org/ox-man.el b/lisp/org/ox-man.el
index 6cace7e6989..27d2dedb8ed 100644
--- a/lisp/org/ox-man.el
+++ b/lisp/org/ox-man.el
@@ -1,4 +1,4 @@
-;; ox-man.el --- Man Back-End for Org Export Engine -*- lexical-binding: t; -*-
+;;; ox-man.el --- Man Back-End for Org Export Engine -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el
index 2d550d92774..a076d15978d 100644
--- a/lisp/org/ox-odt.el
+++ b/lisp/org/ox-odt.el
@@ -2111,7 +2111,8 @@ SHORT-CAPTION are strings."
(caption (let ((c (org-export-get-caption element-or-parent)))
(and c (org-export-data c info))))
;; FIXME: We don't use short-caption for now
- (short-caption nil))
+ ;; (short-caption nil)
+ )
(when (or label caption)
(let* ((default-category
(cl-case (org-element-type element)
@@ -2159,7 +2160,7 @@ SHORT-CAPTION are strings."
"<text:sequence text:ref-name=\"%s\" text:name=\"%s\" text:formula=\"ooow:%s+1\" style:num-format=\"1\">%s</text:sequence>"
label counter counter seqno))
(?c . ,(or caption "")))))
- short-caption))
+ nil)) ;; short-caption
;; Case 2: Handle Label reference.
(reference
(let* ((fmt (cddr (assoc-string label-style org-odt-label-styles t)))
@@ -2362,14 +2363,14 @@ used as a communication channel."
;; If yes, note down its contents. It will go in to frame
;; description. This quite useful for debugging.
(desc (and replaces (org-element-property :value replaces)))
- width height)
+ ) ;; width height
(cond
((eq embed-as 'character)
- (org-odt--render-image/formula "InlineFormula" href width height
+ (org-odt--render-image/formula "InlineFormula" href nil nil ;; width height
nil nil title desc))
(t
(let* ((equation (org-odt--render-image/formula
- "CaptionedDisplayFormula" href width height
+ "CaptionedDisplayFormula" href nil nil ;; width height
captions nil title desc))
(label
(let* ((org-odt-category-map-alist
diff --git a/lisp/org/ox-texinfo.el b/lisp/org/ox-texinfo.el
index cf080549a6a..6e8d0d62141 100644
--- a/lisp/org/ox-texinfo.el
+++ b/lisp/org/ox-texinfo.el
@@ -1627,6 +1627,22 @@ Return output file's name."
(org-export-to-file 'texinfo outfile
async subtreep visible-only body-only ext-plist)))
+(defun org-texinfo-export-to-texinfo-batch ()
+ "Export Org file INFILE to Texinfo file OUTFILE, in batch mode.
+Overwrites existing output file.
+Usage: emacs -batch -f org-texinfo-export-to-texinfo-batch INFILE OUTFILE"
+ (or noninteractive (user-error "Batch mode use only"))
+ (let ((infile (pop command-line-args-left))
+ (outfile (pop command-line-args-left))
+ (org-export-coding-system org-texinfo-coding-system)
+ (make-backup-files nil))
+ (unless (file-readable-p infile)
+ (message "File `%s' not readable" infile)
+ (kill-emacs 1))
+ (with-temp-buffer
+ (insert-file-contents infile)
+ (org-export-to-file 'texinfo outfile))))
+
;;;###autoload
(defun org-texinfo-export-to-info
(&optional async subtreep visible-only body-only ext-plist)
diff --git a/lisp/org/ox.el b/lisp/org/ox.el
index 050a8094d07..36ecf014830 100644
--- a/lisp/org/ox.el
+++ b/lisp/org/ox.el
@@ -2706,9 +2706,9 @@ a list of footnote definitions or in the widened buffer."
(and (or (eq (org-element-type f) 'footnote-definition)
(eq (org-element-property :type f) 'inline))
(org-element-property :label f)))))
- seen)
+ ) ;; seen
(dolist (l (funcall list-labels tree))
- (cond ((member l seen))
+ (cond ;; ((member l seen))
((member l known-definitions) (push l defined))
(t (push l undefined)))))
;; Complete MISSING-DEFINITIONS by finding the definition of every
diff --git a/lisp/outline.el b/lisp/outline.el
index b5853a031b7..0bb74ffd64a 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -1,4 +1,4 @@
-;;; outline.el --- outline mode commands for Emacs
+;;; outline.el --- outline mode commands for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986, 1993-1995, 1997, 2000-2021 Free Software
;; Foundation, Inc.
@@ -166,7 +166,7 @@ in the file it applies to.")
;; Remove extra separator
(cdr
;; Flatten the major mode's menus into a single menu.
- (apply 'append
+ (apply #'append
(mapcar (lambda (x)
(if (consp x)
;; Add a separator between each
@@ -175,8 +175,21 @@ in the file it applies to.")
outline-mode-menu-bar-map))))))
map))
+(defvar outline-mode-cycle-map
+ (let ((map (make-sparse-keymap)))
+ (let ((tab-binding `(menu-item
+ "" outline-cycle
+ ;; Only takes effect if point is on a heading.
+ :filter ,(lambda (cmd)
+ (when (outline-on-heading-p) cmd)))))
+ (define-key map (kbd "TAB") tab-binding)
+ (define-key map (kbd "<backtab>") #'outline-cycle-buffer))
+ map)
+ "Keymap used by `outline-mode-map' and `outline-minor-mode-cycle'.")
+
(defvar outline-mode-map
(let ((map (make-sparse-keymap)))
+ (set-keymap-parent map outline-mode-cycle-map)
(define-key map "\C-c" outline-mode-prefix-map)
(define-key map [menu-bar] outline-mode-menu-bar-map)
map))
@@ -185,52 +198,64 @@ in the file it applies to.")
'(
;; Highlight headings according to the level.
(eval . (list (concat "^\\(?:" outline-regexp "\\).+")
- 0 '(outline-font-lock-face) nil t)))
+ 0 '(if outline-minor-mode
+ (if outline-minor-mode-cycle
+ (if outline-minor-mode-highlight
+ (list 'face (outline-font-lock-face)
+ 'keymap outline-mode-cycle-map)
+ (list 'face nil
+ 'keymap outline-mode-cycle-map))
+ (if outline-minor-mode-highlight
+ (list 'face (outline-font-lock-face))))
+ (outline-font-lock-face))
+ (when outline-minor-mode
+ (pcase outline-minor-mode-highlight
+ ('override t)
+ ('append 'append)))
+ t)))
"Additional expressions to highlight in Outline mode.")
(defface outline-1
'((t :inherit font-lock-function-name-face))
- "Level 1."
- :group 'outlines)
+ "Level 1.")
(defface outline-2
'((t :inherit font-lock-variable-name-face))
- "Level 2."
- :group 'outlines)
+ "Level 2.")
(defface outline-3
'((t :inherit font-lock-keyword-face))
- "Level 3."
- :group 'outlines)
+ "Level 3.")
(defface outline-4
'((t :inherit font-lock-comment-face))
- "Level 4."
- :group 'outlines)
+ "Level 4.")
(defface outline-5
'((t :inherit font-lock-type-face))
- "Level 5."
- :group 'outlines)
+ "Level 5.")
(defface outline-6
'((t :inherit font-lock-constant-face))
- "Level 6."
- :group 'outlines)
+ "Level 6.")
(defface outline-7
'((t :inherit font-lock-builtin-face))
- "Level 7."
- :group 'outlines)
+ "Level 7.")
(defface outline-8
'((t :inherit font-lock-string-face))
- "Level 8."
- :group 'outlines)
+ "Level 8.")
(defvar outline-font-lock-faces
[outline-1 outline-2 outline-3 outline-4
outline-5 outline-6 outline-7 outline-8])
+
+(defvar outline-level #'outline-level
+ "Function of no args to compute a header's nesting level in an outline.
+It can assume point is at the beginning of a header line and that the match
+data reflects the `outline-regexp'.")
+;;;###autoload(put 'outline-level 'risky-local-variable t)
(defun outline-font-lock-face ()
"Return one of `outline-font-lock-faces' for current level."
@@ -273,59 +298,113 @@ beginning of the line. The longer the match, the deeper the level.
Turning on outline mode calls the value of `text-mode-hook' and then of
`outline-mode-hook', if they are non-nil."
- (make-local-variable 'line-move-ignore-invisible)
- (setq line-move-ignore-invisible t)
+ (setq-local line-move-ignore-invisible t)
;; Cause use of ellipses for invisible text.
(add-to-invisibility-spec '(outline . t))
- (set (make-local-variable 'paragraph-start)
- (concat paragraph-start "\\|\\(?:" outline-regexp "\\)"))
+ (setq-local paragraph-start
+ (concat paragraph-start "\\|\\(?:" outline-regexp "\\)"))
;; Inhibit auto-filling of header lines.
- (set (make-local-variable 'auto-fill-inhibit-regexp) outline-regexp)
- (set (make-local-variable 'paragraph-separate)
- (concat paragraph-separate "\\|\\(?:" outline-regexp "\\)"))
- (set (make-local-variable 'font-lock-defaults)
- '(outline-font-lock-keywords t nil nil backward-paragraph))
- (setq imenu-generic-expression
- (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0)))
- (add-hook 'change-major-mode-hook 'outline-show-all nil t))
+ (setq-local auto-fill-inhibit-regexp outline-regexp)
+ (setq-local paragraph-separate
+ (concat paragraph-separate "\\|\\(?:" outline-regexp "\\)"))
+ (setq-local font-lock-defaults
+ '(outline-font-lock-keywords t nil nil backward-paragraph))
+ (setq-local imenu-generic-expression
+ (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0)))
+ (add-hook 'change-major-mode-hook #'outline-show-all nil t))
+
+(defvar outline-minor-mode-map)
(defcustom outline-minor-mode-prefix "\C-c@"
"Prefix key to use for Outline commands in Outline minor mode.
The value of this variable is checked as part of loading Outline mode.
After that, changing the prefix key requires manipulating keymaps."
- :type 'string
- :group 'outlines)
+ :type 'key-sequence
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (define-key outline-minor-mode-map outline-minor-mode-prefix nil)
+ (define-key outline-minor-mode-map val outline-mode-prefix-map)
+ (set-default sym val)))
+
+(defcustom outline-minor-mode-cycle nil
+ "Enable cycling of headings in `outline-minor-mode'.
+When enabled, it puts a keymap with cycling keys on heading lines.
+When point is on a heading line, then typing `TAB' cycles between `hide all',
+`headings only' and `show all' (`outline-cycle'). Typing `S-TAB' on
+a heading line cycles the whole buffer (`outline-cycle-buffer').
+Typing these keys anywhere outside heading lines uses their default bindings."
+ :type 'boolean
+ :version "28.1")
+;;;###autoload(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp)
+
+(defcustom outline-minor-mode-highlight nil
+ "Highlight headings in `outline-minor-mode' using font-lock keywords.
+Non-nil value works well only when outline font-lock keywords
+don't conflict with the major mode's font-lock keywords.
+When t, it puts outline faces only if there are no major mode's faces
+on headings. When `override', it completely overwrites major mode's
+faces with outline faces. When `append', it tries to append outline
+faces to major mode's faces."
+ :type '(choice (const :tag "No highlighting" nil)
+ (const :tag "Overwrite major mode faces" override)
+ (const :tag "Append outline faces to major mode faces" append)
+ (const :tag "Highlight separately from major mode faces" t))
+ :version "28.1")
+;;;###autoload(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp)
+
+(defun outline-minor-mode-highlight-buffer ()
+ ;; Fallback to overlays when font-lock is unsupported.
+ (save-excursion
+ (goto-char (point-min))
+ (let ((regexp (concat "^\\(?:" outline-regexp "\\).*$")))
+ (while (re-search-forward regexp nil t)
+ (let ((overlay (make-overlay (match-beginning 0)
+ (match-end 0))))
+ (overlay-put overlay 'outline-overlay t)
+ (when (or (eq outline-minor-mode-highlight 'override)
+ (and (eq outline-minor-mode-highlight t)
+ (goto-char (match-beginning 0))
+ (not (get-text-property (point) 'face))))
+ (overlay-put overlay 'face (outline-font-lock-face)))
+ (when outline-minor-mode-cycle
+ (overlay-put overlay 'keymap outline-mode-cycle-map)))
+ (goto-char (match-end 0))))))
;;;###autoload
(define-minor-mode outline-minor-mode
"Toggle Outline minor mode.
See the command `outline-mode' for more information on this mode."
- nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
- (cons outline-minor-mode-prefix outline-mode-prefix-map))
- :group 'outlines
+ :lighter " Outl"
+ :keymap (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
+ (cons outline-minor-mode-prefix outline-mode-prefix-map))
(if outline-minor-mode
(progn
+ (when (or outline-minor-mode-cycle outline-minor-mode-highlight)
+ (if (and global-font-lock-mode (font-lock-specified-p major-mode))
+ (progn
+ (font-lock-add-keywords nil outline-font-lock-keywords t)
+ (font-lock-flush))
+ (outline-minor-mode-highlight-buffer)))
;; Turn off this mode if we change major modes.
(add-hook 'change-major-mode-hook
(lambda () (outline-minor-mode -1))
nil t)
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ (setq-local line-move-ignore-invisible t)
;; Cause use of ellipses for invisible text.
(add-to-invisibility-spec '(outline . t)))
+ (when (or outline-minor-mode-cycle outline-minor-mode-highlight)
+ (if font-lock-fontified
+ (font-lock-remove-keywords nil outline-font-lock-keywords))
+ (remove-overlays nil nil 'outline-overlay t)
+ (font-lock-flush))
(setq line-move-ignore-invisible nil)
;; Cause use of ellipses for invisible text.
(remove-from-invisibility-spec '(outline . t))
;; When turning off outline mode, get rid of any outline hiding.
(outline-show-all)))
-
-(defvar outline-level 'outline-level
- "Function of no args to compute a header's nesting level in an outline.
-It can assume point is at the beginning of a header line and that the match
-data reflects the `outline-regexp'.")
-;;;###autoload(put 'outline-level 'risky-local-variable t)
-(defvar outline-heading-alist ()
+(defvar-local outline-heading-alist ()
"Alist associating a heading for every possible level.
Each entry is of the form (HEADING . LEVEL).
This alist is used two ways: to find the heading corresponding to
@@ -344,7 +423,6 @@ within each set. For example in texinfo mode:
Instead of sorting the entries in each set, you can also separate the
sets with nil.")
-(make-variable-buffer-local 'outline-heading-alist)
;; This used to count columns rather than characters, but that made ^L
;; appear to be at level 2 instead of 1. Columns would be better for
@@ -389,6 +467,8 @@ at the end of the buffer."
If POS is nil, use `point' instead."
(eq (get-char-property (or pos (point)) 'invisible) 'outline))
+(define-error 'outline-before-first-heading "Before first heading")
+
(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."
@@ -399,7 +479,7 @@ Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
(while (not found)
(or (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
nil t)
- (error "Before first heading"))
+ (signal 'outline-before-first-heading nil))
(setq found (and (or invisible-ok (not (outline-invisible-p)))
(point)))))
(goto-char found)
@@ -464,9 +544,9 @@ nil for WHICH, or do not pass any argument)."
(if current-prefix-arg nil 'subtree))))
(cond
((eq which 'region)
- (outline-map-region 'outline-promote (region-beginning) (region-end)))
+ (outline-map-region #'outline-promote (region-beginning) (region-end)))
(which
- (outline-map-region 'outline-promote
+ (outline-map-region #'outline-promote
(point)
(save-excursion (outline-get-next-sibling) (point))))
(t
@@ -503,9 +583,9 @@ nil for WHICH, or do not pass any argument)."
(if current-prefix-arg nil 'subtree))))
(cond
((eq which 'region)
- (outline-map-region 'outline-demote (region-beginning) (region-end)))
+ (outline-map-region #'outline-demote (region-beginning) (region-end)))
(which
- (outline-map-region 'outline-demote
+ (outline-map-region #'outline-demote
(point)
(save-excursion (outline-get-next-sibling) (point))))
(t
@@ -685,12 +765,12 @@ This puts point at the start of the current subtree, and mark at the end."
(goto-char beg)))
-(defvar outline-isearch-open-invisible-function nil
+(defvar outline-isearch-open-invisible-function
+ #'outline-isearch-open-invisible
"Function called if `isearch' finishes in an invisible overlay.
-The function is called with the overlay as its only argument.
-If nil, `outline-show-entry' is called to reveal the invisible text.")
+The function is called with the overlay as its only argument.")
-(put 'outline 'reveal-toggle-invisible 'outline-reveal-toggle-invisible)
+(put 'outline 'reveal-toggle-invisible #'outline-reveal-toggle-invisible)
(defun outline-flag-region (from to flag)
"Hide or show lines from FROM to TO, according to FLAG.
If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
@@ -704,7 +784,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
(overlay-put o 'invisible 'outline)
(overlay-put o 'isearch-open-invisible
(or outline-isearch-open-invisible-function
- 'outline-isearch-open-invisible))))
+ #'outline-isearch-open-invisible))))
;; Seems only used by lazy-lock. I.e. obsolete.
(run-hooks 'outline-view-change-hook))
@@ -764,8 +844,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
(outline-end-of-heading)
(outline-flag-region (point) (progn (outline-next-preface) (point)) t)))
-(define-obsolete-function-alias
- 'hide-entry 'outline-hide-entry "25.1")
+(define-obsolete-function-alias 'hide-entry #'outline-hide-entry "25.1")
(defun outline-show-entry ()
"Show the body directly following this heading.
@@ -781,8 +860,7 @@ Show the heading too, if it is currently invisible."
(point)))
nil)))
-(define-obsolete-function-alias
- 'show-entry 'outline-show-entry "25.1")
+(define-obsolete-function-alias 'show-entry #'outline-show-entry "25.1")
(defun outline-hide-body ()
"Hide all body lines in buffer, leaving all headings visible.
@@ -790,8 +868,7 @@ Note that this does not hide the lines preceding the first heading line."
(interactive)
(outline-hide-region-body (point-min) (point-max)))
-(define-obsolete-function-alias
- 'hide-body 'outline-hide-body "25.1")
+(define-obsolete-function-alias 'hide-body #'outline-hide-body "25.1")
(defun outline-hide-region-body (start end)
"Hide all body lines between START and END, but not headings."
@@ -815,23 +892,21 @@ Note that this does not hide the lines preceding the first heading line."
(run-hooks 'outline-view-change-hook))
(define-obsolete-function-alias
- 'hide-region-body 'outline-hide-region-body "25.1")
+ 'hide-region-body #'outline-hide-region-body "25.1")
(defun outline-show-all ()
"Show all of the text in the buffer."
(interactive)
(outline-flag-region (point-min) (point-max) nil))
-(define-obsolete-function-alias
- 'show-all 'outline-show-all "25.1")
+(define-obsolete-function-alias 'show-all #'outline-show-all "25.1")
(defun outline-hide-subtree ()
"Hide everything after this heading at deeper levels."
(interactive)
(outline-flag-subtree t))
-(define-obsolete-function-alias
- 'hide-subtree 'outline-hide-subtree "25.1")
+(define-obsolete-function-alias 'hide-subtree #'outline-hide-subtree "25.1")
(defun outline-hide-leaves ()
"Hide the body after this heading and at deeper levels."
@@ -844,16 +919,14 @@ Note that this does not hide the lines preceding the first heading line."
(point)
(progn (outline-end-of-subtree) (point)))))
-(define-obsolete-function-alias
- 'hide-leaves 'outline-hide-leaves "25.1")
+(define-obsolete-function-alias 'hide-leaves #'outline-hide-leaves "25.1")
(defun outline-show-subtree ()
"Show everything after this heading at deeper levels."
(interactive)
(outline-flag-subtree nil))
-(define-obsolete-function-alias
- 'show-subtree 'outline-show-subtree "25.1")
+(define-obsolete-function-alias 'show-subtree #'outline-show-subtree "25.1")
(defun outline-show-heading ()
"Show the current heading and move to its end."
@@ -908,8 +981,7 @@ of the current heading, or to 1 if the current line is not a heading."
(outline-flag-region (1- (point)) (point) nil))))
(run-hooks 'outline-view-change-hook))
-(define-obsolete-function-alias
- 'hide-sublevels 'outline-hide-sublevels "25.1")
+(define-obsolete-function-alias 'hide-sublevels #'outline-hide-sublevels "25.1")
(defun outline-hide-other ()
"Hide everything except current body and parent and top-level headings.
@@ -927,8 +999,7 @@ This also unhides the top heading-less body, if any."
nil))))
(run-hooks 'outline-view-change-hook))
-(define-obsolete-function-alias
- 'hide-other 'outline-hide-other "25.1")
+(define-obsolete-function-alias 'hide-other #'outline-hide-other "25.1")
(defun outline-toggle-children ()
"Show or hide the current subtree depending on its current state."
@@ -972,8 +1043,7 @@ This also unhides the top heading-less body, if any."
(interactive)
(outline-show-children 1000))
-(define-obsolete-function-alias
- 'show-branches 'outline-show-branches "25.1")
+(define-obsolete-function-alias 'show-branches #'outline-show-branches "25.1")
(defun outline-show-children (&optional level)
"Show all direct subheadings of this heading.
@@ -1002,8 +1072,7 @@ Default is enough to cause the following heading to appear."
(if (eobp) (point-max) (1+ (point)))))))
(run-hooks 'outline-view-change-hook))
-(define-obsolete-function-alias
- 'show-children 'outline-show-children "25.1")
+(define-obsolete-function-alias 'show-children #'outline-show-children "25.1")
@@ -1118,6 +1187,133 @@ convenient way to make a table of contents of the buffer."
(insert "\n\n"))))))
(kill-new (buffer-string)))))))
+(defun outline--cycle-state ()
+ "Return the cycle state of current heading.
+Return either 'hide-all, 'headings-only, or 'show-all."
+ (save-excursion
+ (let (start end ov-list heading-end)
+ (outline-back-to-heading)
+ (setq start (point))
+ (outline-end-of-heading)
+ (setq heading-end (point))
+ (outline-end-of-subtree)
+ (setq end (point))
+ (setq ov-list
+ (seq-filter
+ (lambda (o)
+ (and (eq (overlay-get o 'invisible) 'outline)
+ (save-excursion
+ (goto-char (overlay-start o))
+ (outline-on-heading-p t))))
+ (overlays-in start end)))
+ (cond ((null ov-list) 'show-all)
+ ((and (or (= end (point-max)
+ (1+ (overlay-end (car ov-list))))
+ (= (overlay-end (car ov-list)) end))
+ (= (overlay-start (car ov-list)) heading-end))
+ 'hide-all)
+ (t 'headings-only)))))
+
+(defun outline-has-subheading-p ()
+ "Return t if this heading has subheadings, nil otherwise."
+ (save-excursion
+ (outline-back-to-heading)
+ (< (save-excursion (outline-next-heading) (point))
+ (save-excursion (outline-end-of-subtree) (point)))))
+
+(defun outline-cycle ()
+ "Cycle between `hide all', `headings only' and `show all'.
+
+`Hide all' means hide all subheadings and their bodies.
+`Headings only' means show sub headings but not their bodies.
+`Show all' means show all subheadings and their bodies."
+ (interactive)
+ (condition-case nil
+ (pcase (outline--cycle-state)
+ ('hide-all
+ (if (outline-has-subheading-p)
+ (progn (outline-show-children)
+ (message "Only headings"))
+ (outline-show-subtree)
+ (message "Show all")))
+ ('headings-only
+ (outline-show-subtree)
+ (message "Show all"))
+ ('show-all
+ (outline-hide-subtree)
+ (message "Hide all")))
+ (outline-before-first-heading nil)))
+
+(defvar-local outline--cycle-buffer-state 'show-all
+ "Internal variable used for tracking buffer cycle state.")
+
+(defun outline-cycle-buffer ()
+ "Cycle the whole buffer like in `outline-cycle'."
+ (interactive)
+ (let (has-top-level)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (or has-top-level (eobp)))
+ (when (outline-on-heading-p t)
+ (when (= (funcall outline-level) 1)
+ (setq has-top-level t)))
+ (outline-next-heading)))
+ (cond
+ ((and (eq outline--cycle-buffer-state 'show-all)
+ has-top-level)
+ (outline-hide-sublevels 1)
+ (setq outline--cycle-buffer-state 'top-level)
+ (message "Top level headings"))
+ ((or (eq outline--cycle-buffer-state 'show-all)
+ (eq outline--cycle-buffer-state 'top-level))
+ (outline-show-all)
+ (outline-hide-region-body (point-min) (point-max))
+ (setq outline--cycle-buffer-state 'all-heading)
+ (message "All headings"))
+ (t
+ (outline-show-all)
+ (setq outline--cycle-buffer-state 'show-all)
+ (message "Show all")))))
+
+(defvar outline-navigation-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-b") #'outline-backward-same-level)
+ (define-key map (kbd "b") #'outline-backward-same-level)
+ (define-key map (kbd "C-f") #'outline-forward-same-level)
+ (define-key map (kbd "f") #'outline-forward-same-level)
+ (define-key map (kbd "C-n") #'outline-next-visible-heading)
+ (define-key map (kbd "n") #'outline-next-visible-heading)
+ (define-key map (kbd "C-p") #'outline-previous-visible-heading)
+ (define-key map (kbd "p") #'outline-previous-visible-heading)
+ (define-key map (kbd "C-u") #'outline-up-heading)
+ (define-key map (kbd "u") #'outline-up-heading)
+ map))
+
+(dolist (command '(outline-backward-same-level
+ outline-forward-same-level
+ outline-next-visible-heading
+ outline-previous-visible-heading
+ outline-up-heading))
+ (put command 'repeat-map 'outline-navigation-repeat-map))
+
+(defvar outline-editing-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-v") #'outline-move-subtree-down)
+ (define-key map (kbd "v") #'outline-move-subtree-down)
+ (define-key map (kbd "C-^") #'outline-move-subtree-up)
+ (define-key map (kbd "^") #'outline-move-subtree-up)
+ (define-key map (kbd "C->") #'outline-demote)
+ (define-key map (kbd ">") #'outline-demote)
+ (define-key map (kbd "C-<") #'outline-promote)
+ (define-key map (kbd "<") #'outline-promote)
+ map))
+
+(dolist (command '(outline-move-subtree-down
+ outline-move-subtree-up
+ outline-demote
+ outline-promote))
+ (put command 'repeat-map 'outline-editing-repeat-map))
+
(provide 'outline)
(provide 'noutline)
diff --git a/lisp/password-cache.el b/lisp/password-cache.el
index 1df456b2f3b..83a25725199 100644
--- a/lisp/password-cache.el
+++ b/lisp/password-cache.el
@@ -31,7 +31,8 @@
;; ;; Minibuffer prompt for password.
;; => "foo"
;;
-;; (password-cache-add "test" "foo")
+;; (password-cache-add "test" (read-passwd "Password? "))
+;; ;; Minibuffer prompt from read-passwd, which returns "foo".
;; => nil
;; (password-read "Password? " "test")
@@ -93,22 +94,6 @@ The variable `password-cache' control whether the cache is used."
(or (password-read-from-cache key)
(read-passwd prompt)))
-(defun password-read-and-add (prompt &optional key)
- "Read password, for use with KEY, from user, or from cache if wanted.
-Then store the password in the cache. Uses `password-read' and
-`password-cache-add'. Custom variables `password-cache' and
-`password-cache-expiry' regulate cache behavior.
-
-Warning: the password is cached without checking that it is
-correct. It is better to check the password before caching. If
-you must use this function, take care to check passwords and
-remove incorrect ones from the cache."
- (declare (obsolete password-read "23.1"))
- (let ((password (password-read prompt key)))
- (when (and password key)
- (password-cache-add key password))
- password))
-
(defun password-cache-remove (key)
"Remove password indexed by KEY from password cache.
This is typically run by a timer setup from `password-cache-add',
@@ -118,9 +103,7 @@ that a password is invalid, so that `password-read' query the
user again."
(let ((password (gethash key password-data)))
(when (stringp password)
- (if (fboundp 'clear-string)
- (clear-string password)
- (fillarray password ?_)))
+ (clear-string password))
(remhash key password-data)))
(defun password-cache-add (key password)
diff --git a/lisp/pcmpl-cvs.el b/lisp/pcmpl-cvs.el
index c9d0f321971..588a5e725a8 100644
--- a/lisp/pcmpl-cvs.el
+++ b/lisp/pcmpl-cvs.el
@@ -1,4 +1,4 @@
-;;; pcmpl-cvs.el --- functions for dealing with cvs completions
+;;; pcmpl-cvs.el --- functions for dealing with cvs completions -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -29,7 +29,6 @@
(provide 'pcmpl-cvs)
(require 'pcomplete)
-(require 'executable)
(defgroup pcmpl-cvs nil
"Functions for dealing with CVS completions."
@@ -39,8 +38,7 @@
(defcustom pcmpl-cvs-binary (or (executable-find "cvs") "cvs")
"The full path of the `cvs' binary."
- :type 'file
- :group 'pcmpl-cvs)
+ :type 'file)
;; Functions:
@@ -139,7 +137,7 @@
(let ((entries (pcmpl-cvs-entries opers))
tags)
(with-temp-buffer
- (apply 'call-process pcmpl-cvs-binary nil t nil
+ (apply #'call-process pcmpl-cvs-binary nil t nil
"status" "-v" entries)
(goto-char (point-min))
(while (re-search-forward "Existing Tags:" nil t)
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index dc2ca1d605c..6c68645eb22 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -65,14 +65,14 @@
"Find all zipped or unzipped files: the inverse of UNZIP-P."
(pcomplete-entries
nil
- (function
- (lambda (entry)
- (when (and (file-readable-p entry)
- (file-regular-p entry))
- (let ((zipped (string-match "\\.\\(t?gz\\|\\(ta\\)?Z\\)\\'"
- entry)))
- (or (and unzip-p zipped)
- (and (not unzip-p) (not zipped)))))))))
+ (lambda (entry)
+ (or (file-directory-p entry)
+ (when (and (file-readable-p entry)
+ (file-regular-p entry))
+ (let ((zipped (string-match "\\.\\(t?gz\\|\\(ta\\)?Z\\)\\'"
+ entry)))
+ (or (and unzip-p zipped)
+ (and (not unzip-p) (not zipped)))))))))
;;;###autoload
(defun pcomplete/bzip2 ()
@@ -91,13 +91,12 @@
"Find all zipped or unzipped files: the inverse of UNZIP-P."
(pcomplete-entries
nil
- (function
- (lambda (entry)
- (when (and (file-readable-p entry)
- (file-regular-p entry))
- (let ((zipped (string-match "\\.\\(t?z2\\|bz2\\)\\'" entry)))
- (or (and unzip-p zipped)
- (and (not unzip-p) (not zipped)))))))))
+ (lambda (entry)
+ (when (and (file-readable-p entry)
+ (file-regular-p entry))
+ (let ((zipped (string-match "\\.\\(t?z2\\|bz2\\)\\'" entry)))
+ (or (and unzip-p zipped)
+ (and (not unzip-p) (not zipped))))))))
;;;###autoload
(defun pcomplete/make ()
@@ -107,7 +106,7 @@
(while (pcomplete-here (completion-table-in-turn
(pcmpl-gnu-make-rule-names)
(pcomplete-entries))
- nil 'identity))))
+ nil #'identity))))
(defun pcmpl-gnu-makefile-names ()
"Return a list of possible makefile names."
@@ -118,7 +117,7 @@
Return the new list."
(goto-char (point-min))
(while (re-search-forward
- "^\\s-*\\([^\n#%.$][^:=\n]*\\)\\s-*:[^=]" nil t)
+ "^\\([^\t\n#%.$][^:=\n]*\\)\\s-*:[^=]" nil t)
(setq targets (nconc (split-string (match-string-no-properties 1))
targets)))
targets)
@@ -337,7 +336,7 @@ Return the new list."
(pcomplete-match-string 1 0)))))
(unless saw-option
(pcomplete-here
- (mapcar 'char-to-string
+ (mapcar #'char-to-string
(string-to-list
"01234567ABCFGIKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz")))
(if (pcomplete-match "[xt]" 'first 1)
@@ -356,7 +355,7 @@ Return the new list."
(pcmpl-gnu-with-file-buffer
file (mapcar #'tar-header-name tar-parse-info)))))
(pcomplete-entries))
- nil 'identity))))
+ nil #'identity))))
;;;###autoload
@@ -392,7 +391,7 @@ Return the new list."
(string= prec "-execdir"))
(while (pcomplete-here* (funcall pcomplete-command-completion-function)
(pcomplete-arg 'last) t))))
- (while (pcomplete-here (pcomplete-dirs) nil 'identity))))
+ (while (pcomplete-here (pcomplete-dirs) nil #'identity))))
;;;###autoload
(defalias 'pcomplete/gdb 'pcomplete/xargs)
diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el
index f648cc720ff..39d4add2be1 100644
--- a/lisp/pcmpl-linux.el
+++ b/lisp/pcmpl-linux.el
@@ -1,4 +1,4 @@
-;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions
+;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -31,11 +31,6 @@
(require 'pcomplete)
-;; Unused.
-;;; (defgroup pcmpl-linux nil
-;;; "Functions for dealing with GNU/Linux completions."
-;;; :group 'pcomplete)
-
;; Functions:
;;;###autoload
@@ -50,33 +45,37 @@
(while (pcomplete-here
(if (file-directory-p "/proc")
(directory-files "/proc" nil "\\`[0-9]+\\'"))
- nil 'identity)))
+ nil #'identity)))
;;;###autoload
(defun pcomplete/umount ()
"Completion for GNU/Linux `umount'."
(pcomplete-opt "hVafrnvt(pcmpl-linux-fs-types)")
(while (pcomplete-here (pcmpl-linux-mounted-directories)
- nil 'identity)))
+ nil #'identity)))
;;;###autoload
(defun pcomplete/mount ()
"Completion for GNU/Linux `mount'."
(pcomplete-opt "hVanfFrsvwt(pcmpl-linux-fs-types)o?L?U?")
- (while (pcomplete-here (pcomplete-entries) nil 'identity)))
+ (while (pcomplete-here (pcomplete-entries) nil #'identity)))
+
+(defconst pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/")
(defun pcmpl-linux-fs-types ()
"Return a list of available fs modules on GNU/Linux systems."
(let ((kernel-ver (pcomplete-process-result "uname" "-r")))
(directory-files
- (concat "/lib/modules/" kernel-ver "/kernel/fs/"))))
+ (format pcmpl-linux-fs-modules-path-format kernel-ver))))
+
+(defconst pcmpl-linux-mtab-file "/etc/mtab")
(defun pcmpl-linux-mounted-directories ()
"Return a list of mounted directory names."
(let (points)
- (when (file-readable-p "/etc/mtab")
+ (when (file-readable-p pcmpl-linux-mtab-file)
(with-temp-buffer
- (insert-file-contents-literally "/etc/mtab")
+ (insert-file-contents-literally pcmpl-linux-mtab-file)
(while (not (eobp))
(let* ((line (buffer-substring (point) (line-end-position)))
(args (split-string line " ")))
diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el
index c985526b083..39f700cb362 100644
--- a/lisp/pcmpl-rpm.el
+++ b/lisp/pcmpl-rpm.el
@@ -1,4 +1,4 @@
-;;; pcmpl-rpm.el --- functions for dealing with rpm completions
+;;; pcmpl-rpm.el --- functions for dealing with rpm completions -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -47,14 +47,12 @@
:version "24.3"
:type '(choice (const :tag "No options" nil)
(string :tag "Single option")
- (repeat :tag "List of options" string))
- :group 'pcmpl-rpm)
+ (repeat :tag "List of options" string)))
(defcustom pcmpl-rpm-cache t
"Whether to cache the list of installed packages."
:version "24.3"
- :type 'boolean
- :group 'pcmpl-rpm)
+ :type 'boolean)
(defconst pcmpl-rpm-cache-stamp-file "/var/lib/rpm/Packages"
"File used to check that the list of installed packages is up-to-date.")
@@ -78,7 +76,7 @@
(message "Getting list of installed rpms...")
(setq pcmpl-rpm-cache-time (current-time)
pcmpl-rpm-packages
- (split-string (apply 'pcomplete-process-result "rpm"
+ (split-string (apply #'pcomplete-process-result "rpm"
(append '("-q" "-a")
(if (stringp pcmpl-rpm-query-options)
(list pcmpl-rpm-query-options)
diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el
index 63709ec2e7e..e1d104f74ff 100644
--- a/lisp/pcmpl-unix.el
+++ b/lisp/pcmpl-unix.el
@@ -1,4 +1,4 @@
-;;; pcmpl-unix.el --- standard UNIX completions
+;;; pcmpl-unix.el --- standard UNIX completions -*- lexical-binding:t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -77,15 +77,20 @@ being via `pcmpl-ssh-known-hosts-file'."
(let ((pcomplete-help "(fileutils)rm invocation"))
(pcomplete-opt "dfirRv")
(while (pcomplete-here (pcomplete-all-entries) nil
- 'expand-file-name))))
+ #'expand-file-name))))
;;;###autoload
(defun pcomplete/xargs ()
"Completion for `xargs'."
- (pcomplete-here (funcall pcomplete-command-completion-function))
+ (while (string-prefix-p "-" (pcomplete-arg 0))
+ (pcomplete-here (funcall pcomplete-default-completion-function)))
+ (funcall pcomplete-command-completion-function)
(funcall (or (pcomplete-find-completion-function (pcomplete-arg 1))
pcomplete-default-completion-function)))
+;; FIXME: Add completion of sudo-specific arguments.
+(defalias 'pcomplete/sudo #'pcomplete/xargs)
+
;;;###autoload
(defalias 'pcomplete/time 'pcomplete/xargs)
@@ -144,7 +149,7 @@ documentation), this function returns nil."
;; ssh support by Phil Hagelberg.
-;; http://www.emacswiki.org/cgi-bin/wiki/pcmpl-ssh.el
+;; https://www.emacswiki.org/cgi-bin/wiki/pcmpl-ssh.el
(defun pcmpl-ssh-known-hosts ()
"Return a list of hosts found in `pcmpl-ssh-known-hosts-file'."
@@ -155,12 +160,14 @@ documentation), this function returns nil."
(let ((host-re "\\(?:\\([-.[:alnum:]]+\\)\\|\\[\\([-.[:alnum:]]+\\)\\]:[0-9]+\\)[, ]")
ssh-hosts-list)
(while (re-search-forward (concat "^ *" host-re) nil t)
- (add-to-list 'ssh-hosts-list (concat (match-string 1)
- (match-string 2)))
+ (push (concat (match-string 1)
+ (match-string 2))
+ ssh-hosts-list)
(while (and (eq (char-before) ?,)
(re-search-forward host-re (line-end-position) t))
- (add-to-list 'ssh-hosts-list (concat (match-string 1)
- (match-string 2)))))
+ (push (concat (match-string 1)
+ (match-string 2))
+ ssh-hosts-list)))
ssh-hosts-list))))
(defun pcmpl-ssh-config-hosts ()
@@ -173,7 +180,7 @@ documentation), this function returns nil."
(case-fold-search t))
(while (re-search-forward "^ *host\\(name\\)? +\\([-.[:alnum:]]+\\)"
nil t)
- (add-to-list 'ssh-hosts-list (match-string 2)))
+ (push (match-string 2) ssh-hosts-list))
ssh-hosts-list))))
(defun pcmpl-ssh-hosts ()
@@ -181,7 +188,7 @@ documentation), this function returns nil."
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))
+ (push h hosts))
hosts))
;;;###autoload
@@ -215,6 +222,29 @@ Includes files as well as host names followed by a colon."
(pcmpl-ssh-hosts)))))))
(complete-with-action action table string pred))))))
+(defsubst pcmpl-unix-complete-hostname ()
+ "Complete a command that wants a hostname for an argument."
+ (pcomplete-here (pcomplete-read-host-names)))
+
+(defalias 'pcomplete/ftp 'pcmpl-unix-complete-hostname)
+(defalias 'pcomplete/ncftp 'pcmpl-unix-complete-hostname)
+(defalias 'pcomplete/ping 'pcmpl-unix-complete-hostname)
+(defalias 'pcomplete/rlogin 'pcmpl-unix-complete-hostname)
+
+;;;###autoload
+(defun pcomplete/telnet ()
+ (pcomplete-opt "xl(pcmpl-unix-user-names)")
+ (pcmpl-unix-complete-hostname))
+
+;;;###autoload
+(defun pcomplete/rsh ()
+ "Complete `rsh', which, after the user and hostname, is like xargs."
+ (pcomplete-opt "l(pcmpl-unix-user-names)")
+ (pcmpl-unix-complete-hostname)
+ (pcomplete-here (funcall pcomplete-command-completion-function))
+ (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1))
+ pcomplete-default-completion-function)))
+
(provide 'pcmpl-unix)
;;; pcmpl-unix.el ends here
diff --git a/lisp/pcmpl-x.el b/lisp/pcmpl-x.el
index f866dd53e1e..fd147101b69 100644
--- a/lisp/pcmpl-x.el
+++ b/lisp/pcmpl-x.el
@@ -27,7 +27,7 @@
(require 'pcomplete)
-;;;; tlmgr - http://www.tug.org/texlive/tlmgr.html
+;;;; tlmgr - https://www.tug.org/texlive/tlmgr.html
(defcustom pcmpl-x-tlmgr-program "tlmgr"
"Name of the tlmgr program."
@@ -141,7 +141,7 @@
(pcomplete-here* (pcomplete-dirs-or-entries)))))))
-;;;; ack - http://betterthangrep.com
+;;;; ack - https://betterthangrep.com
;; Usage:
;; - To complete short options type '-' first
@@ -286,5 +286,38 @@ long options."
(pcmpl-x-ag-options))))
(pcomplete-here* (pcomplete-dirs-or-entries)))))
+;;;###autoload
+(defun pcomplete/bcc32 ()
+ "Completion function for Borland's C++ compiler."
+ (let ((cur (pcomplete-arg 0)))
+ (cond
+ ((string-match "\\`-w\\([^;]+;\\)*\\([^;]*\\)\\'" cur)
+ (pcomplete-here
+ '("ali" "amb" "amp" "asc" "asm" "aus" "bbf" "bei" "big" "ccc"
+ "cln" "cod" "com" "cpt" "csu" "def" "dig" "dpu" "dsz" "dup"
+ "eas" "eff" "ext" "hch" "hid" "ias" "ibc" "ifr" "ill" "nil"
+ "lin" "lvc" "mcs" "mes" "mpc" "mpd" "msg" "nak" "ncf" "nci"
+ "ncl" "nfd" "ngu" "nin" "nma" "nmu" "nod" "nop" "npp" "nsf"
+ "nst" "ntd" "nto" "nvf" "obi" "obs" "ofp" "osh" "ovf" "par"
+ "pch" "pck" "pia" "pin" "pow" "prc" "pre" "pro" "rch" "ret"
+ "rng" "rpt" "rvl" "sig" "spa" "stl" "stu" "stv" "sus" "tai"
+ "tes" "thr" "ucp" "use" "voi" "zdi")
+ (match-string 2 cur)))
+ ((string-match "\\`-[LIn]\\([^;]+;\\)*\\([^;]*\\)\\'" cur)
+ (pcomplete-here (pcomplete-dirs) (match-string 2 cur)))
+ ((string-match "\\`-[Ee]\\(.*\\)\\'" cur)
+ (pcomplete-here (pcomplete-dirs-or-entries "\\.[Ee][Xx][Ee]\\'")
+ (match-string 1 cur)))
+ ((string-match "\\`-o\\(.*\\)\\'" cur)
+ (pcomplete-here (pcomplete-dirs-or-entries "\\.[Oo][Bb][Jj]\\'")
+ (match-string 1 cur)))
+ (t
+ (pcomplete-opt "3456ABCDEHIKLMNOPRSTUVXabcdefgijklnoptuvwxyz"))))
+ (while (pcomplete-here
+ (pcomplete-dirs-or-entries "\\.[iCc]\\([Pp][Pp]\\)?\\'"))))
+
+;;;###autoload
+(defalias 'pcomplete/bcc 'pcomplete/bcc32)
+
(provide 'pcmpl-x)
;;; pcmpl-x.el ends here
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 7506a54ff3e..64acc416c23 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -135,11 +135,8 @@
"A regexp of names to be disregarded during directory completion."
:type '(choice regexp (const :tag "None" nil)))
-(defcustom pcomplete-ignore-case (memq system-type '(ms-dos windows-nt cygwin))
- ;; FIXME: the doc mentions file-name completion, but the code
- ;; seems to apply it to all completions.
- "If non-nil, ignore case when doing filename completion."
- :type 'boolean)
+(define-obsolete-variable-alias 'pcomplete-ignore-case 'completion-ignore-case
+ "28.1")
(defcustom pcomplete-autolist nil
"If non-nil, automatically list possibilities on partial completion.
@@ -291,9 +288,8 @@ generate the completions list. This means that the hook
`(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only))
(defcustom pcomplete-command-completion-function
- (function
- (lambda ()
- (pcomplete-here (pcomplete-executables))))
+ (lambda ()
+ (pcomplete-here (pcomplete-executables)))
"Function called for completing the initial command argument."
:type 'function)
@@ -302,9 +298,8 @@ generate the completions list. This means that the hook
:type 'function)
(defcustom pcomplete-default-completion-function
- (function
- (lambda ()
- (while (pcomplete-here (pcomplete-entries)))))
+ (lambda ()
+ (while (pcomplete-here (pcomplete-entries))))
"Function called when no completion rule can be found.
This function is used to generate completions for every argument."
:type 'function)
@@ -325,22 +320,19 @@ already terminated by a character, this variable should be locally
modified to be an empty string, or the desired separation string."
:type 'string)
+(defcustom pcomplete-hosts-file "/etc/hosts"
+ "The name of the /etc/hosts file."
+ :type '(choice (const :tag "No hosts file" nil) file))
+
;;; Internal Variables:
;; for cycling completion support
-(defvar pcomplete-current-completions nil)
-(defvar pcomplete-last-completion-length)
-(defvar pcomplete-last-completion-stub)
-(defvar pcomplete-last-completion-raw)
-(defvar pcomplete-last-window-config nil)
-(defvar pcomplete-window-restore-timer nil)
-
-(make-variable-buffer-local 'pcomplete-current-completions)
-(make-variable-buffer-local 'pcomplete-last-completion-length)
-(make-variable-buffer-local 'pcomplete-last-completion-stub)
-(make-variable-buffer-local 'pcomplete-last-completion-raw)
-(make-variable-buffer-local 'pcomplete-last-window-config)
-(make-variable-buffer-local 'pcomplete-window-restore-timer)
+(defvar-local pcomplete-current-completions nil)
+(defvar-local pcomplete-last-completion-length nil)
+(defvar-local pcomplete-last-completion-stub nil)
+(defvar-local pcomplete-last-completion-raw nil)
+(defvar-local pcomplete-last-window-config nil)
+(defvar-local pcomplete-window-restore-timer nil)
;; used for altering pcomplete's behavior. These global variables
;; should always be nil.
@@ -348,7 +340,7 @@ 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
+;; for the sake of the byte-compiler, when compiling other files that
;; contain completion functions
(defvar pcomplete-args nil)
(defvar pcomplete-begins nil)
@@ -477,7 +469,7 @@ Same as `pcomplete' but using the standard completion UI."
(not (member
(funcall norm-func (directory-file-name f))
seen)))))))
- (when pcomplete-ignore-case
+ (when completion-ignore-case
(setq table (completion-table-case-fold table)))
(list beg (point) table
:predicate pred
@@ -736,8 +728,8 @@ user actually typed in."
COMPLETEF-SYM should be the symbol where the
dynamic-complete-functions are kept. For comint mode itself,
this is `comint-dynamic-complete-functions'."
- (set (make-local-variable 'pcomplete-parse-arguments-function)
- #'pcomplete-parse-comint-arguments)
+ (setq-local pcomplete-parse-arguments-function
+ #'pcomplete-parse-comint-arguments)
(add-hook 'completion-at-point-functions
#'pcomplete-completions-at-point nil 'local)
(set (make-local-variable completef-sym)
@@ -870,7 +862,7 @@ this is `comint-dynamic-complete-functions'."
(sort comps pcomplete-compare-entry-function)))
,@(cdr (completion-file-name-table s p a)))
(let ((completion-ignored-extensions nil)
- (completion-ignore-case pcomplete-ignore-case))
+ (completion-ignore-case completion-ignore-case))
(completion-table-with-predicate
#'comint-completion-file-name-table pred 'strict s p a))))))
@@ -984,9 +976,8 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored."
(setq index (1+ index))))
(throw 'pcomplete-completions
(mapcar
- (function
- (lambda (opt)
- (concat "-" opt)))
+ (lambda (opt)
+ (concat "-" opt))
(pcomplete-uniquify-list choices))))
(let ((arg (pcomplete-arg)))
(when (and (> (length arg) 1)
@@ -1122,7 +1113,7 @@ Typing SPC flushes the help buffer."
"Insert a completion entry at point.
Returns non-nil if a space was appended at the end."
(let ((here (point)))
- (if (not pcomplete-ignore-case)
+ (if (not completion-ignore-case)
(insert-and-inherit (if raw-p
(substring entry (length stub))
(comint-quote-filename
@@ -1200,7 +1191,7 @@ Returns `partial' if completed as far as possible with the matches.
Returns `listed' if a completion listing was shown.
See also `pcomplete-filename'."
- (let* ((completion-ignore-case pcomplete-ignore-case)
+ (let* ((completion-ignore-case completion-ignore-case)
(completions (all-completions stub candidates))
(entry (try-completion stub candidates))
result)
@@ -1269,18 +1260,9 @@ If specific documentation can't be given, be generic."
(defun pcomplete-uniquify-list (l)
"Sort and remove multiples in L."
- (setq l (sort l 'string-lessp))
- (let ((m l))
- (while m
- (while (and (cdr m)
- (string= (car m)
- (cadr m)))
- (setcdr m (cddr m)))
- (setq m (cdr m))))
- l)
-(define-obsolete-function-alias
- 'pcomplete-uniqify-list
- 'pcomplete-uniquify-list "27.1")
+ (setq l (sort l #'string-lessp))
+ (seq-uniq l))
+(define-obsolete-function-alias 'pcomplete-uniqify-list #'pcomplete-uniquify-list "27.1")
(defun pcomplete-process-result (cmd &rest args)
"Call CMD using `call-process' and return the simplest result."
@@ -1289,17 +1271,45 @@ If specific documentation can't be given, be generic."
(skip-chars-backward "\n")
(buffer-substring (point-min) (point))))
-;; create a set of aliases which allow completion functions to be not
-;; quite so verbose
-
-;;; jww (1999-10-20): are these a good idea?
-;; (defalias 'pc-here 'pcomplete-here)
-;; (defalias 'pc-test 'pcomplete-test)
-;; (defalias 'pc-opt 'pcomplete-opt)
-;; (defalias 'pc-match 'pcomplete-match)
-;; (defalias 'pc-match-string 'pcomplete-match-string)
-;; (defalias 'pc-match-beginning 'pcomplete-match-beginning)
-;; (defalias 'pc-match-end 'pcomplete-match-end)
+;; hostname completion
+
+(defvar pcomplete--host-name-cache nil
+ "A cache the names of frequently accessed hosts.")
+
+(defvar pcomplete--host-name-cache-timestamp nil
+ "A timestamp of when the hosts file was read.")
+
+(defun pcomplete-read-hosts-file (filename)
+ "Read in the hosts from FILENAME, default `pcomplete-hosts-file'."
+ (let (hosts)
+ (with-temp-buffer
+ (insert-file-contents (or filename pcomplete-hosts-file))
+ (goto-char (point-min))
+ (while (re-search-forward
+ ;; "^ \t\\([^# \t\n]+\\)[ \t]+\\([^ \t\n]+\\)\\([ \t]*\\([^ \t\n]+\\)\\)?"
+ "^[ \t]*\\([^# \t\n]+\\)[ \t]+\\([^ \t\n].+\\)" nil t)
+ (push (cons (match-string 1)
+ (split-string (match-string 2)))
+ hosts)))
+ (nreverse hosts)))
+
+(defun pcomplete-read-hosts (file result-var timestamp-var)
+ "Read the contents of /etc/hosts for host names."
+ (if (or (not (symbol-value result-var))
+ (not (symbol-value timestamp-var))
+ (time-less-p
+ (symbol-value timestamp-var)
+ (file-attribute-modification-time (file-attributes file))))
+ (progn
+ (set result-var (apply #'nconc (pcomplete-read-hosts-file file)))
+ (set timestamp-var (current-time))))
+ (symbol-value result-var))
+
+(defun pcomplete-read-host-names ()
+ "Read the contents of /etc/hosts for host names."
+ (if pcomplete-hosts-file
+ (pcomplete-read-hosts pcomplete-hosts-file 'pcomplete--host-name-cache
+ 'pcomplete--host-name-cache-timestamp)))
(provide 'pcomplete)
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index f722c25b751..78b8259b395 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -1,4 +1,4 @@
-;;; pixel-scroll.el --- Scroll a line smoothly
+;;; pixel-scroll.el --- Scroll a line smoothly -*- lexical-binding: t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
;; Author: Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
@@ -26,9 +26,8 @@
;;
;; M-x pixel-scroll-mode RET
;;
-;; To make the mode permanent, put these in your init file:
+;; To make the mode permanent, put this in your Init file:
;;
-;; (require 'pixel-scroll)
;; (pixel-scroll-mode 1)
;;; Commentary:
@@ -125,7 +124,7 @@ This is an alternative of `scroll-up'. Scope moves downward."
(or arg (setq arg 1))
(if (pixel-scroll-in-rush-p)
(scroll-up arg)
- (dotimes (ii arg) ; move scope downward
+ (dotimes (_ arg) ; move scope downward
(let ((amt (if pixel-resolution-fine-flag
(if (integerp pixel-resolution-fine-flag)
pixel-resolution-fine-flag
@@ -146,7 +145,7 @@ This is and alternative of `scroll-down'. Scope moves upward."
(or arg (setq arg 1))
(if (pixel-scroll-in-rush-p)
(scroll-down arg)
- (dotimes (ii arg)
+ (dotimes (_ arg)
(let ((amt (if pixel-resolution-fine-flag
(if (integerp pixel-resolution-fine-flag)
pixel-resolution-fine-flag
@@ -245,7 +244,7 @@ that was scrolled."
(dst (* line height)) ; goal @25 @25 @92
(delta (- dst src))) ; pixels to be scrolled 25 17 4
(pixel--whistlestop-pixel-up (1- delta)) ; until one less @24 @24 @91
- (dotimes (ii line)
+ (dotimes (_ line)
;; On horizontal scrolling, move cursor.
(when (> (window-hscroll) 0)
(vertical-motion 1))
diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el
index 4f9f77e1039..3630c199bc4 100644
--- a/lisp/play/5x5.el
+++ b/lisp/play/5x5.el
@@ -1,4 +1,4 @@
-;;; 5x5.el --- simple little puzzle game
+;;; 5x5.el --- simple little puzzle game -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -31,7 +31,7 @@
;; o The code for updating the grid needs to be re-done. At the moment it
;; simply re-draws the grid every time a move is made.
;;
-;; o Look into tarting up the display with color. gamegrid.el looks
+;; o Look into improving the display with color. gamegrid.el looks
;; interesting, perhaps that is the way to go?
;;; Thanks:
@@ -47,8 +47,6 @@
;;; Code:
-;; Things we need.
-
(eval-when-compile (require 'cl-lib))
;; Customize options.
@@ -60,55 +58,50 @@
(defcustom 5x5-grid-size 5
"Size of the playing area."
- :type 'integer
- :group '5x5)
+ :type 'integer)
(defcustom 5x5-x-scale 4
"X scaling factor for drawing the grid."
- :type 'integer
- :group '5x5)
+ :type 'integer)
(defcustom 5x5-y-scale 3
"Y scaling factor for drawing the grid."
- :type 'integer
- :group '5x5)
+ :type 'integer)
(defcustom 5x5-animate-delay .01
"Delay in seconds when animating a solution crack."
- :type 'number
- :group '5x5)
+ :type 'number)
(defcustom 5x5-hassle-me t
"Should 5x5 ask you when you want to do a destructive operation?"
- :type 'boolean
- :group '5x5)
+ :type 'boolean)
(defcustom 5x5-mode-hook nil
"Hook run on starting 5x5."
- :type 'hook
- :group '5x5)
+ :type 'hook)
;; Non-customize variables.
(defmacro 5x5-defvar-local (var value doc)
"Define VAR to VALUE with documentation DOC and make it buffer local."
+ (declare (obsolete defvar-local "28.1"))
`(progn
(defvar ,var ,value ,doc)
(make-variable-buffer-local (quote ,var))))
-(5x5-defvar-local 5x5-grid nil
+(defvar-local 5x5-grid nil
"5x5 grid contents.")
-(5x5-defvar-local 5x5-x-pos 2
+(defvar-local 5x5-x-pos 2
"X position of cursor.")
-(5x5-defvar-local 5x5-y-pos 2
+(defvar-local 5x5-y-pos 2
"Y position of cursor.")
-(5x5-defvar-local 5x5-moves 0
+(defvar-local 5x5-moves 0
"Moves made.")
-(5x5-defvar-local 5x5-cracking nil
+(defvar-local 5x5-cracking nil
"Are we in cracking mode?")
(defvar 5x5-buffer-name "*5x5*"
@@ -148,7 +141,7 @@
map)
"Local keymap for the 5x5 game.")
-(5x5-defvar-local 5x5-solver-output nil
+(defvar-local 5x5-solver-output nil
"List that is the output of an arithmetic solver.
This list L is such that
@@ -186,6 +179,7 @@ GRID is the grid of positions to click.")
(define-derived-mode 5x5-mode special-mode "5x5"
"A mode for playing `5x5'."
+ :interactive nil
(setq buffer-read-only t
truncate-lines t)
(buffer-disable-undo))
@@ -228,7 +222,7 @@ Quit current game \\[5x5-quit-game]"
(defun 5x5-new-game ()
"Start a new game of `5x5'."
- (interactive)
+ (interactive nil 5x5-mode)
(when (if (called-interactively-p 'interactive)
(5x5-y-or-n-p "Start a new game? ") t)
(setq 5x5-x-pos (/ 5x5-grid-size 2)
@@ -241,7 +235,7 @@ Quit current game \\[5x5-quit-game]"
(defun 5x5-quit-game ()
"Quit the current game of `5x5'."
- (interactive)
+ (interactive nil 5x5-mode)
(kill-buffer 5x5-buffer-name))
(defun 5x5-make-new-grid ()
@@ -296,7 +290,7 @@ Quit current game \\[5x5-quit-game]"
(defun 5x5-draw-grid-end ()
"Draw the top/bottom of the grid."
(insert "+")
- (dotimes (x 5x5-grid-size)
+ (dotimes (_ 5x5-grid-size)
(insert "-" (make-string 5x5-x-scale ?-)))
(insert "-+ "))
@@ -304,11 +298,11 @@ Quit current game \\[5x5-quit-game]"
"Draw the grids GRIDS into the current buffer."
(let ((inhibit-read-only t) grid-org)
(erase-buffer)
- (dolist (grid grids) (5x5-draw-grid-end))
+ (dolist (_ grids) (5x5-draw-grid-end))
(insert "\n")
(setq grid-org (point))
(dotimes (y 5x5-grid-size)
- (dotimes (lines 5x5-y-scale)
+ (dotimes (_lines 5x5-y-scale)
(dolist (grid grids)
(dotimes (x 5x5-grid-size)
(insert (if (zerop x) "| " " ")
@@ -338,7 +332,7 @@ Quit current game \\[5x5-quit-game]"
(forward-char (1+ 5x5-x-scale))))
(forward-line 5x5-y-scale))))
(setq 5x5-solver-output nil)))
- (dolist (grid grids) (5x5-draw-grid-end))
+ (dolist (_grid grids) (5x5-draw-grid-end))
(insert "\n")
(insert (format "On: %d Moves: %d" (5x5-grid-value (car grids)) 5x5-moves))))
@@ -482,11 +476,11 @@ position."
"Convert a grid matrix GRID-MATRIX in Calc format to a grid in
5x5 format. See function `5x5-grid-to-vec'."
(apply
- 'vector
+ #'vector
(mapcar
(lambda (x)
(apply
- 'vector
+ #'vector
(mapcar
(lambda (y) (/= (cadr y) 0))
(cdr x))))
@@ -510,7 +504,9 @@ position."
Log a matrix VALUE of (mod B 2) forms, only B is output and
Scilab matrix notation is used. VALUE is returned so that it is
easy to log a value with minimal rewrite of code."
- (when (buffer-live-p 5x5-log-buffer)
+ (when (buffer-live-p 5x5-log-buffer)
+ (defvar calc-matrix-brackets)
+ (defvar calc-vector-commas)
(let* ((unpacked-value
(math-map-vec
(lambda (row) (math-map-vec 'cadr row))
@@ -522,7 +518,7 @@ easy to log a value with minimal rewrite of code."
(insert name ?= value-to-log ?\n))))
value))
(defsubst 5x5-log-init ())
- (defsubst 5x5-log (name value) value)))
+ (defsubst 5x5-log (_name value) value)))
(declare-function math-map-vec "calc-vec" (f a))
(declare-function math-sub "calc" (a b))
@@ -540,6 +536,10 @@ easy to log a value with minimal rewrite of code."
(declare-function calcFunc-mcol "calc-vec" (mat n))
(declare-function calcFunc-vconcat "calc-vec" (a b))
(declare-function calcFunc-index "calc-vec" (n &optional start incr))
+(defvar calc-word-size)
+(defvar calc-leading-zeros)
+(defvar calc-number-radix)
+(defvar calc-command-flags)
(defun 5x5-solver (grid)
"Return a list of solutions for GRID.
@@ -582,7 +582,7 @@ Solutions are sorted from least to greatest Hamming weight."
(math-sub dest org))))
;; transferm is the transfer matrix, ie it is the 25x25
- ;; matrix applied everytime a flip is carried out where a
+ ;; matrix applied every time a flip is carried out where a
;; flip is defined by a 25x1 Dirac vector --- ie all zeros
;; but 1 in the position that is flipped.
(transferm
@@ -678,16 +678,16 @@ Solutions are sorted from least to greatest Hamming weight."
(5x5-log
"cb"
(math-mul inv-base-change targetv))); CB
- (row-1 (math-make-intv 3 1 transferm-kernel-size)) ; 1..2
+ ;; (row-1 (math-make-intv 3 1 transferm-kernel-size)) ; 1..2
(row-2 (math-make-intv 1 transferm-kernel-size
grid-size-squared)); 3..25
(col-1 (math-make-intv 3 1 (- grid-size-squared
transferm-kernel-size))); 1..23
- (col-2 (math-make-intv 1 (- grid-size-squared
- transferm-kernel-size)
- grid-size-squared)); 24..25
- (ctransferm-1-: (calcFunc-mrow ctransferm row-1))
- (ctransferm-1-1 (calcFunc-mcol ctransferm-1-: col-1))
+ ;; (col-2 (math-make-intv 1 (- grid-size-squared
+ ;; transferm-kernel-size)
+ ;; grid-size-squared)) ; 24..25
+ ;; (ctransferm-1-: (calcFunc-mrow ctransferm row-1))
+ ;; (ctransferm-1-1 (calcFunc-mcol ctransferm-1-: col-1))
;; By construction ctransferm-:-2 = 0, so ctransferm-1-2 = 0
;; and ctransferm-2-2 = 0.
@@ -703,8 +703,8 @@ Solutions are sorted from least to greatest Hamming weight."
;;
;;(ctransferm-2-2 (calcFunc-mcol ctransferm-2-: col-2))
- (ctarget-1 (calcFunc-mrow ctarget row-1))
- (ctarget-2 (calcFunc-mrow ctarget row-2))
+ ;; (ctarget-1 (calcFunc-mrow ctarget row-1))
+ (ctarget-2 (calcFunc-mrow ctarget row-2))
;; ctarget-1(2x1) = ctransferm-1-1(2x23) *cx-1(23x1)
;; + ctransferm-1-2(2x2) *cx-2(2x1);
@@ -777,13 +777,13 @@ Solutions are sorted from least to greatest Hamming weight."
(message "5x5 Solution computation done.")
solution-list)))
-(defun 5x5-solve-suggest (&optional n)
+(defun 5x5-solve-suggest (&optional _n)
"Suggest to the user where to click.
Argument N is ignored."
;; For the time being n is ignored, the idea was to use some numeric
;; argument to show a limited amount of positions.
- (interactive "P")
+ (interactive "P" 5x5-mode)
(5x5-log-init)
(let ((solutions (5x5-solver 5x5-grid)))
(setq 5x5-solver-output
@@ -806,7 +806,7 @@ list. The list of solution is ordered by number of strokes, so
rotating left just after calling `5x5-solve-suggest' will show
the solution with second least number of strokes, while rotating
right will show the solution with greatest number of strokes."
- (interactive "P")
+ (interactive "P" 5x5-mode)
(let ((len (length 5x5-solver-output)))
(when (>= len 3)
(setq n (if (integerp n) n 1)
@@ -840,7 +840,7 @@ right will show the solution with greatest number of strokes."
If N is not supplied, rotate by 1. Similar to function
`5x5-solve-rotate-left' except that rotation is right instead of
lest."
- (interactive "P")
+ (interactive "P" 5x5-mode)
(setq n
(if (integerp n) (- n)
-1))
@@ -852,7 +852,7 @@ lest."
(defun 5x5-flip-current ()
"Make a move on the current cursor location."
- (interactive)
+ (interactive nil 5x5-mode)
(setq 5x5-grid (5x5-make-move 5x5-grid 5x5-y-pos 5x5-x-pos))
(5x5-made-move)
(unless 5x5-cracking
@@ -864,61 +864,61 @@ lest."
(defun 5x5-up ()
"Move up."
- (interactive)
+ (interactive nil 5x5-mode)
(unless (zerop 5x5-y-pos)
(cl-decf 5x5-y-pos)
(5x5-position-cursor)))
(defun 5x5-down ()
"Move down."
- (interactive)
+ (interactive nil 5x5-mode)
(unless (= 5x5-y-pos (1- 5x5-grid-size))
(cl-incf 5x5-y-pos)
(5x5-position-cursor)))
(defun 5x5-left ()
"Move left."
- (interactive)
+ (interactive nil 5x5-mode)
(unless (zerop 5x5-x-pos)
(cl-decf 5x5-x-pos)
(5x5-position-cursor)))
(defun 5x5-right ()
"Move right."
- (interactive)
+ (interactive nil 5x5-mode)
(unless (= 5x5-x-pos (1- 5x5-grid-size))
(cl-incf 5x5-x-pos)
(5x5-position-cursor)))
(defun 5x5-bol ()
"Move to beginning of line."
- (interactive)
+ (interactive nil 5x5-mode)
(setq 5x5-x-pos 0)
(5x5-position-cursor))
(defun 5x5-eol ()
"Move to end of line."
- (interactive)
+ (interactive nil 5x5-mode)
(setq 5x5-x-pos (1- 5x5-grid-size))
(5x5-position-cursor))
(defun 5x5-first ()
"Move to the first cell."
- (interactive)
+ (interactive nil 5x5-mode)
(setq 5x5-x-pos 0
5x5-y-pos 0)
(5x5-position-cursor))
(defun 5x5-last ()
"Move to the last cell."
- (interactive)
+ (interactive nil 5x5-mode)
(setq 5x5-x-pos (1- 5x5-grid-size)
5x5-y-pos (1- 5x5-grid-size))
(5x5-position-cursor))
(defun 5x5-randomize ()
"Randomize the grid."
- (interactive)
+ (interactive nil 5x5-mode)
(when (5x5-y-or-n-p "Start a new game with a random grid? ")
(setq 5x5-x-pos (/ 5x5-grid-size 2)
5x5-y-pos (/ 5x5-grid-size 2)
diff --git a/lisp/play/animate.el b/lisp/play/animate.el
index f258ebb39f8..7eb1b277179 100644
--- a/lisp/play/animate.el
+++ b/lisp/play/animate.el
@@ -1,4 +1,4 @@
-;;; animate.el --- make text dance
+;;; animate.el --- make text dance -*- lexical-binding:t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -84,7 +84,7 @@
(defun animate-place-char (char vpos hpos)
(goto-char (window-start))
(let (abbrev-mode)
- (dotimes (i vpos)
+ (dotimes (_ vpos)
(end-of-line)
(if (= (forward-line 1) 1)
(insert "\n"))))
diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el
index e3854b55a14..13bcdcc8595 100644
--- a/lisp/play/blackbox.el
+++ b/lisp/play/blackbox.el
@@ -1,4 +1,4 @@
-;;; blackbox.el --- blackbox game in Emacs Lisp
+;;; blackbox.el --- blackbox game in Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1985-1987, 1992, 2001-2021 Free Software Foundation,
;; Inc.
@@ -274,45 +274,45 @@ a reflection."
))
(defun bb-right (count)
- (interactive "p")
+ (interactive "p" blackbox-mode)
(while (and (> count 0) (< bb-x 8))
(forward-char 2)
(setq bb-x (1+ bb-x))
(setq count (1- count))))
(defun bb-left (count)
- (interactive "p")
+ (interactive "p" blackbox-mode)
(while (and (> count 0) (> bb-x -1))
(backward-char 2)
(setq bb-x (1- bb-x))
(setq count (1- count))))
(defun bb-up (count)
- (interactive "p")
+ (interactive "p" blackbox-mode)
(while (and (> count 0) (> bb-y -1))
(with-no-warnings (previous-line))
(setq bb-y (1- bb-y))
(setq count (1- count))))
(defun bb-down (count)
- (interactive "p")
+ (interactive "p" blackbox-mode)
(while (and (> count 0) (< bb-y 8))
(with-no-warnings (next-line))
(setq bb-y (1+ bb-y))
(setq count (1- count))))
(defun bb-eol ()
- (interactive)
+ (interactive nil blackbox-mode)
(setq bb-x 8)
(bb-goto (cons bb-x bb-y)))
(defun bb-bol ()
- (interactive)
+ (interactive nil blackbox-mode)
(setq bb-x -1)
(bb-goto (cons bb-x bb-y)))
(defun bb-romp ()
- (interactive)
+ (interactive nil blackbox-mode)
(cond
((and
(or (= bb-x -1) (= bb-x 8))
@@ -379,7 +379,7 @@ a reflection."
(defun bb-done ()
"Finish the game and report score."
- (interactive)
+ (interactive nil blackbox-mode)
(let (bogus-balls)
(cond
((not (= (length bb-balls-placed) (length bb-board)))
diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el
index 3388d731d14..e695a75e083 100644
--- a/lisp/play/bubbles.el
+++ b/lisp/play/bubbles.el
@@ -28,14 +28,7 @@
;; possible in as few moves as possible.
;; Bubbles is an implementation of the "Same Game", similar to "Same
-;; GNOME" and many others, see <http://en.wikipedia.org/wiki/SameGame>.
-
-;; Installation
-;; ------------
-
-;; Add the following lines to your init file:
-;; (add-to-list 'load-path "/path/to/bubbles/")
-;; (autoload 'bubbles "bubbles" "Play Bubbles" t)
+;; GNOME" and many others, see <https://en.wikipedia.org/wiki/SameGame>.
;; ======================================================================
@@ -79,8 +72,6 @@
;;; Code:
-(defconst bubbles-version "0.5" "Version number of bubbles.el.")
-
(require 'gamegrid)
;; User options
@@ -88,6 +79,10 @@
;; Careful with that axe, Eugene! Order does matter in the custom
;; section below.
+(defgroup bubbles nil
+ "Bubbles, a puzzle game."
+ :group 'games)
+
(defcustom bubbles-game-theme
'easy
"Overall game theme.
@@ -97,8 +92,7 @@ and a shift mode."
(const :tag "Medium" medium)
(const :tag "Difficult" difficult)
(const :tag "Hard" hard)
- (const :tag "User defined" user-defined))
- :group 'bubbles)
+ (const :tag "User defined" user-defined)))
(defun bubbles-set-game-easy ()
"Set game theme to `easy'."
@@ -130,10 +124,6 @@ and a shift mode."
(setq bubbles-game-theme 'user-defined)
(bubbles))
-(defgroup bubbles nil
- "Bubbles, a puzzle game."
- :group 'games)
-
(defcustom bubbles-graphics-theme
'circles
"Graphics theme.
@@ -779,117 +769,46 @@ static char * dot3d_xpm[] = {
(defun bubbles-set-graphics-theme-ascii ()
"Set graphics theme to `ascii'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'ascii)
(bubbles--update-faces-or-images))
(defun bubbles-set-graphics-theme-circles ()
"Set graphics theme to `circles'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'circles)
(bubbles--initialize-images)
(bubbles--update-faces-or-images))
(defun bubbles-set-graphics-theme-squares ()
"Set graphics theme to `squares'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'squares)
(bubbles--initialize-images)
(bubbles--update-faces-or-images))
(defun bubbles-set-graphics-theme-diamonds ()
"Set graphics theme to `diamonds'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'diamonds)
(bubbles--initialize-images)
(bubbles--update-faces-or-images))
(defun bubbles-set-graphics-theme-balls ()
"Set graphics theme to `balls'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'balls)
(bubbles--initialize-images)
(bubbles--update-faces-or-images))
(defun bubbles-set-graphics-theme-emacs ()
"Set graphics theme to `emacs'."
- (interactive)
+ (interactive nil bubbles-mode)
(setq bubbles-graphics-theme 'emacs)
(bubbles--initialize-images)
(bubbles--update-faces-or-images))
-;; game theme menu
-(defvar bubbles-game-theme-menu
- (let ((menu (make-sparse-keymap "Game Theme")))
- (define-key menu [bubbles-set-game-userdefined]
- (list 'menu-item "User defined" 'bubbles-set-game-userdefined
- :button '(:radio . (eq bubbles-game-theme 'user-defined))))
- (define-key menu [bubbles-set-game-hard]
- (list 'menu-item "Hard" 'bubbles-set-game-hard
- :button '(:radio . (eq bubbles-game-theme 'hard))))
- (define-key menu [bubbles-set-game-difficult]
- (list 'menu-item "Difficult" 'bubbles-set-game-difficult
- :button '(:radio . (eq bubbles-game-theme 'difficult))))
- (define-key menu [bubbles-set-game-medium]
- (list 'menu-item "Medium" 'bubbles-set-game-medium
- :button '(:radio . (eq bubbles-game-theme 'medium))))
- (define-key menu [bubbles-set-game-easy]
- (list 'menu-item "Easy" 'bubbles-set-game-easy
- :button '(:radio . (eq bubbles-game-theme 'easy))))
- menu)
- "Map for bubbles game theme menu.")
-
-;; graphics theme menu
-(defvar bubbles-graphics-theme-menu
- (let ((menu (make-sparse-keymap "Graphics Theme")))
- (define-key menu [bubbles-set-graphics-theme-ascii]
- (list 'menu-item "ASCII" 'bubbles-set-graphics-theme-ascii
- :button '(:radio . (eq bubbles-graphics-theme 'ascii))))
- (define-key menu [bubbles-set-graphics-theme-emacs]
- (list 'menu-item "Emacs" 'bubbles-set-graphics-theme-emacs
- :button '(:radio . (eq bubbles-graphics-theme 'emacs))))
- (define-key menu [bubbles-set-graphics-theme-balls]
- (list 'menu-item "Balls" 'bubbles-set-graphics-theme-balls
- :button '(:radio . (eq bubbles-graphics-theme 'balls))))
- (define-key menu [bubbles-set-graphics-theme-diamonds]
- (list 'menu-item "Diamonds" 'bubbles-set-graphics-theme-diamonds
- :button '(:radio . (eq bubbles-graphics-theme 'diamonds))))
- (define-key menu [bubbles-set-graphics-theme-squares]
- (list 'menu-item "Squares" 'bubbles-set-graphics-theme-squares
- :button '(:radio . (eq bubbles-graphics-theme 'squares))))
- (define-key menu [bubbles-set-graphics-theme-circles]
- (list 'menu-item "Circles" 'bubbles-set-graphics-theme-circles
- :button '(:radio . (eq bubbles-graphics-theme 'circles))))
- menu)
- "Map for bubbles graphics theme menu.")
-
-;; menu
-(defvar bubbles-menu
- (let ((menu (make-sparse-keymap "Bubbles")))
- (define-key menu [bubbles-quit]
- (list 'menu-item "Quit" 'bubbles-quit))
- (define-key menu [bubbles]
- (list 'menu-item "New game" 'bubbles))
- (define-key menu [bubbles-separator-1]
- '("--"))
- (define-key menu [bubbles-save-settings]
- (list 'menu-item "Save all settings" 'bubbles-save-settings))
- (define-key menu [bubbles-customize]
- (list 'menu-item "Edit all settings" 'bubbles-customize))
- (define-key menu [bubbles-game-theme-menu]
- (list 'menu-item "Game Theme" bubbles-game-theme-menu))
- (define-key menu [bubbles-graphics-theme-menu]
- (list 'menu-item "Graphics Theme" bubbles-graphics-theme-menu
- :enable 'bubbles--playing))
- (define-key menu [bubbles-separator-2]
- '("--"))
- (define-key menu [bubbles-undo]
- (list 'menu-item "Undo last move" 'bubbles-undo
- :enable '(and bubbles--playing (listp buffer-undo-list))))
- menu)
- "Map for bubbles menu.")
-
-;; bubbles mode map
+
(defvar bubbles-mode-map
(let ((map (make-sparse-keymap 'bubbles-mode-map)))
;; (suppress-keymap map t)
@@ -904,12 +823,59 @@ static char * dot3d_xpm[] = {
(define-key map "n" 'next-line)
(define-key map "f" 'forward-char)
(define-key map "b" 'backward-char)
- ;; bind menu to mouse
- (define-key map [down-mouse-3] bubbles-menu)
- ;; Put menu in menu-bar
- (define-key map [menu-bar Bubbles] (cons "Bubbles" bubbles-menu))
map)
- "Mode map for bubbles.")
+ "Mode map for `bubbles'.")
+
+(easy-menu-define bubbles-menu bubbles-mode-map
+ "Menu for `bubbles'."
+ '("Bubbles"
+ ["Undo last move" bubbles-undo
+ :enable '(and bubbles--playing (listp buffer-undo-list))]
+ "---"
+ ("Graphics Theme"
+ :enable bubbles--playing
+ ["Circles" bubbles-set-graphics-theme-circles
+ :style radio
+ :selected (eq bubbles-graphics-theme 'circles)]
+ ["Squares" bubbles-set-graphics-theme-squares
+ :style radio
+ :selected (eq bubbles-graphics-theme 'squares)]
+ ["Diamonds" bubbles-set-graphics-theme-diamonds
+ :style radio
+ :selected (eq bubbles-graphics-theme 'diamonds)]
+ ["Balls" bubbles-set-graphics-theme-balls
+ :style radio
+ :selected (eq bubbles-graphics-theme 'balls)]
+ ["Emacs" bubbles-set-graphics-theme-emacs
+ :style radio
+ :selected (eq bubbles-graphics-theme 'emacs)]
+ ["ASCII" bubbles-set-graphics-theme-ascii
+ :style radio
+ :selected (eq bubbles-graphics-theme 'ascii)])
+ ("Game Theme"
+ ["Easy" bubbles-set-game-easy
+ :style radio
+ :selected (eq bubbles-game-theme 'easy)]
+ ["Medium" bubbles-set-game-medium
+ :style radio
+ :selected (eq bubbles-game-theme 'medium)]
+ ["Difficult" bubbles-set-game-difficult
+ :style radio
+ :selected (eq bubbles-game-theme 'difficult)]
+ ["Hard" bubbles-set-game-hard
+ :style radio
+ :selected (eq bubbles-game-theme 'hard)]
+ ["User defined" bubbles-set-game-userdefined
+ :style radio
+ :selected (eq bubbles-game-theme 'user-defined)])
+ ["Edit all settings" bubbles-customize]
+ ["Save all settings" bubbles-save-settings]
+ "---"
+ ["New game" bubbles]
+ ["Quit" bubbles-quit]))
+
+;; bind menu to mouse
+(define-key bubbles-mode-map [down-mouse-3] bubbles-menu)
(define-derived-mode bubbles-mode nil "Bubbles"
"Major mode for playing bubbles.
@@ -945,7 +911,7 @@ columns on its right towards the left.
(defun bubbles-quit ()
"Quit Bubbles."
- (interactive)
+ (interactive nil bubbles-mode)
(message "bubbles-quit")
(bury-buffer))
@@ -975,16 +941,14 @@ Set `bubbles--col-offset' and `bubbles--row-offset'."
(* image-vert-size (bubbles--grid-height)))
2)))))
-(defun bubbles--remove-overlays ()
- "Remove all overlays."
- (if (fboundp 'remove-overlays)
- (remove-overlays)))
+(define-obsolete-function-alias 'bubbles--remove-overlays
+ 'remove-overlays "28.1")
(defun bubbles--initialize ()
"Initialize Bubbles game."
(bubbles--initialize-faces)
(bubbles--initialize-images)
- (bubbles--remove-overlays)
+ (remove-overlays)
(switch-to-buffer (get-buffer-create "*bubbles*"))
(bubbles--compute-offsets)
@@ -1198,7 +1162,7 @@ Use optional parameter POS instead of point if given."
(defun bubbles-plop ()
"Remove active bubbles region."
- (interactive)
+ (interactive nil bubbles-mode)
(when (and bubbles--playing
(> bubbles--neighborhood-score 0))
(setq bubbles--save-data (list bubbles--score (buffer-string)))
@@ -1282,7 +1246,7 @@ Use optional parameter POS instead of point if given."
(defun bubbles-undo ()
"Undo last move."
- (interactive)
+ (interactive nil bubbles-mode)
(when bubbles--save-data
(let ((inhibit-read-only t)
(pos (point)))
@@ -1408,7 +1372,7 @@ Return t if new char is non-empty."
(defun bubbles--show-images ()
"Update images in the bubbles buffer."
- (bubbles--remove-overlays)
+ (remove-overlays)
(if (and (display-images-p)
bubbles--images-ok
(not (eq bubbles-graphics-theme 'ascii)))
@@ -1438,6 +1402,11 @@ Return t if new char is non-empty."
(forward-char 1)))
(put-text-property (point-min) (point-max) 'pointer 'arrow)))))
+;; Obsolete.
+
+(defconst bubbles-version "0.5" "Version number of bubbles.el.")
+(make-obsolete-variable 'bubbles-version 'emacs-version "28.1")
+
(provide 'bubbles)
;;; bubbles.el ends here
diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el
index 9cecb706f98..be35daf4da8 100644
--- a/lisp/play/cookie1.el
+++ b/lisp/play/cookie1.el
@@ -1,4 +1,4 @@
-;;; cookie1.el --- retrieve random phrases from fortune cookie files
+;;; cookie1.el --- retrieve random phrases from fortune cookie files -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
@@ -60,7 +60,6 @@
(defcustom cookie-file nil
"Default phrase file for cookie functions."
:type '(choice (const nil) file)
- :group 'cookie
:version "24.4")
(defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0"
@@ -178,11 +177,12 @@ Argument REQUIRE-MATCH non-nil forces a matching cookie."
"Randomly permute the elements of VECTOR (all permutations equally likely)."
(let ((len (length vector))
j temp)
- (dotimes (i len vector)
+ (dotimes (i len)
(setq j (+ i (random (- len i)))
temp (aref vector i))
(aset vector i (aref vector j))
- (aset vector j temp))))
+ (aset vector j temp))
+ vector))
(define-obsolete-function-alias 'shuffle-vector 'cookie-shuffle-vector "24.4")
@@ -205,9 +205,10 @@ If called interactively, or if DISPLAY is non-nil, display a list of matches."
(cookie-table-symbol (intern phrase-file cookie-cache))
(string-table (symbol-value cookie-table-symbol))
(matches nil))
- (and (dotimes (i (length string-table) matches)
- (and (string-match-p regexp (aref string-table i))
- (setq matches (cons (aref string-table i) matches))))
+ (dotimes (i (length string-table))
+ (and (string-match-p regexp (aref string-table i))
+ (setq matches (cons (aref string-table i) matches))))
+ (and matches
(setq matches (sort matches 'string-lessp)))
(and display
(if matches
diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el
index cf23778fc2c..47ed6e28b58 100644
--- a/lisp/play/decipher.el
+++ b/lisp/play/decipher.el
@@ -1,4 +1,4 @@
-;;; decipher.el --- cryptanalyze monoalphabetic substitution ciphers
+;;; decipher.el --- cryptanalyze monoalphabetic substitution ciphers -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1995-1996, 2001-2021 Free Software Foundation, Inc.
;;
@@ -71,7 +71,7 @@
;; Emacs commands.
;;
;; Decipher supports Font Lock mode. To use it, you can also add
-;; (add-hook 'decipher-mode-hook 'turn-on-font-lock)
+;; (add-hook 'decipher-mode-hook #'turn-on-font-lock)
;; See the variable `decipher-font-lock-keywords' if you want to customize
;; the faces used. I'd like to thank Simon Marshall for his help in making
;; Decipher work well with Font Lock.
@@ -84,6 +84,8 @@
;; 1. The consonant-line shortcut
;; 2. More functions for analyzing ciphertext
+;;; Code:
+
;;;===================================================================
;;; Variables:
;;;===================================================================
@@ -99,8 +101,7 @@
"Non-nil means to convert ciphertext to uppercase.
nil means the case of the ciphertext is preserved.
This variable must be set before typing `\\[decipher]'."
- :type 'boolean
- :group 'decipher)
+ :type 'boolean)
(defcustom decipher-ignore-spaces nil
@@ -108,21 +109,18 @@ This variable must be set before typing `\\[decipher]'."
You should set this to nil if the cipher message is divided into words,
or t if it is not.
This variable is buffer-local."
- :type 'boolean
- :group 'decipher)
+ :type 'boolean)
(make-variable-buffer-local 'decipher-ignore-spaces)
(defcustom decipher-undo-limit 5000
"The maximum number of entries in the undo list.
When the undo list exceeds this number, 100 entries are deleted from
the tail of the list."
- :type 'integer
- :group 'decipher)
+ :type 'integer)
(defcustom decipher-mode-hook nil
"Hook to run upon entry to decipher."
- :type 'hook
- :group 'decipher)
+ :type 'hook)
;; End of user modifiable variables
;;--------------------------------------------------------------------
@@ -143,20 +141,20 @@ the tail of the list."
(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)
+ (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)
+ (define-key map (vector key) #'decipher-keypress)
(cl-incf key)))
map)
"Keymap for Decipher mode.")
@@ -165,47 +163,40 @@ the tail of the 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)
+ (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.")
+ "Keymap for Decipher-Stats mode.")
-(defvar decipher-mode-syntax-table nil
- "Decipher mode syntax table")
-
-(if decipher-mode-syntax-table
- ()
+(defvar decipher-mode-syntax-table
(let ((table (make-syntax-table))
(c ?0))
(while (<= c ?9)
(modify-syntax-entry c "_" table) ;Digits are not part of words
(cl-incf c))
- (setq decipher-mode-syntax-table table)))
+ table)
+ "Decipher mode syntax table")
-(defvar decipher-alphabet nil)
+(defvar-local decipher-alphabet nil)
;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR),
;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase
;; letter or space (which means no mapping is known for that letter).
;; This *must* contain entries for all lowercase characters.
-(make-variable-buffer-local 'decipher-alphabet)
-(defvar decipher-stats-buffer nil
+(defvar-local decipher-stats-buffer nil
"The buffer which displays statistics for this ciphertext.
Do not access this variable directly, use the function
`decipher-stats-buffer' instead.")
-(make-variable-buffer-local 'decipher-stats-buffer)
-(defvar decipher-undo-list-size 0
+(defvar-local decipher-undo-list-size 0
"The number of entries in the undo list.")
-(make-variable-buffer-local 'decipher-undo-list-size)
-(defvar decipher-undo-list nil
+(defvar-local decipher-undo-list nil
"The undo list for this buffer.
Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a
list of such cons cells.")
-(make-variable-buffer-local 'decipher-undo-list)
(defvar decipher-pending-undo-list nil)
@@ -222,7 +213,6 @@ list of such cons cells.")
(defvar decipher--freqs)
;;;===================================================================
-;;; Code:
;;;===================================================================
;; Main entry points:
;;--------------------------------------------------------------------
@@ -264,7 +254,7 @@ ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n")
(decipher-mode))
;;;###autoload
-(defun decipher-mode ()
+(define-derived-mode decipher-mode nil "Decipher"
"Major mode for decrypting monoalphabetic substitution ciphers.
Lower-case letters enter plaintext.
Upper-case letters are commands.
@@ -280,26 +270,19 @@ The most useful commands are:
Show adjacency list for current letter (lists letters appearing next to it)
\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint)
\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)"
- (interactive)
- (kill-all-local-variables)
(setq buffer-undo-list t ;Disable undo
- indent-tabs-mode nil ;Do not use tab characters
- major-mode 'decipher-mode
- mode-name "Decipher")
+ indent-tabs-mode nil) ;Do not use tab characters
(if decipher-force-uppercase
(setq case-fold-search nil)) ;Case is significant when searching
- (use-local-map decipher-mode-map)
- (set-syntax-table decipher-mode-syntax-table)
(unless (= (point-min) (point-max))
(decipher-read-alphabet))
- (set (make-local-variable 'font-lock-defaults)
- '(decipher-font-lock-keywords t))
+ (setq-local font-lock-defaults
+ '(decipher-font-lock-keywords t))
;; Make the buffer writable when we exit Decipher mode:
(add-hook 'change-major-mode-hook
(lambda () (setq buffer-read-only nil
buffer-undo-list nil))
nil t)
- (run-mode-hooks 'decipher-mode-hook)
(setq buffer-read-only t))
(put 'decipher-mode 'mode-class 'special)
@@ -309,7 +292,7 @@ The most useful commands are:
(defun decipher-keypress ()
"Enter a plaintext or ciphertext character."
- (interactive)
+ (interactive nil decipher-mode)
(let ((decipher-function 'decipher-set-map)
buffer-read-only) ;Make buffer writable
(save-excursion
@@ -322,10 +305,10 @@ The most useful commands are:
((= ?> first-char)
nil)
((= ?\( first-char)
- (setq decipher-function 'decipher-alphabet-keypress)
+ (setq decipher-function #'decipher-alphabet-keypress)
t)
((= ?\) first-char)
- (setq decipher-function 'decipher-alphabet-keypress)
+ (setq decipher-function #'decipher-alphabet-keypress)
nil)
(t
(error "Bad location")))))
@@ -363,7 +346,7 @@ The most useful commands are:
(defun decipher-undo ()
"Undo a change in Decipher mode."
- (interactive)
+ (interactive nil decipher-mode)
;; If we don't get all the way thru, make last-command indicate that
;; for the following command.
(setq this-command t)
@@ -464,7 +447,7 @@ The most useful commands are:
(decipher-insert plain-char)
(setq case-fold-search t ;Case is not significant
cipher-string (downcase cipher-string))
- (let ((font-lock-fontify-region-function 'ignore))
+ (let ((font-lock-fontify-region-function #'ignore))
;; insert-and-inherit will pick the right face automatically
(while (search-forward-regexp "^:" nil t)
(setq bound (point-at-eol))
@@ -504,7 +487,7 @@ The most useful commands are:
This records the current alphabet so you can return to it later.
You may have any number of checkpoints.
Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
- (interactive "sCheckpoint description: ")
+ (interactive "sCheckpoint description: " decipher-mode)
(or (stringp desc)
(setq desc ""))
(let (alphabet
@@ -531,7 +514,7 @@ If point is not on a checkpoint line, moves to the first checkpoint line.
If point is on a checkpoint, restores that checkpoint.
Type `\\[decipher-make-checkpoint]' to make a checkpoint."
- (interactive)
+ (interactive nil decipher-mode)
(beginning-of-line)
(if (looking-at "%!\\([A-Z ]+\\)!")
;; Restore this checkpoint:
@@ -559,7 +542,7 @@ Type `\\[decipher-make-checkpoint]' to make a checkpoint."
This fills any blanks in the cipher alphabet with the unused letters
in alphabetical order. Use this when you have a keyword cipher and
you have determined the keyword."
- (interactive)
+ (interactive nil decipher-mode)
(let ((cipher-char ?A)
(ptr decipher-alphabet)
buffer-read-only ;Make buffer writable
@@ -576,7 +559,7 @@ you have determined the keyword."
(defun decipher-show-alphabet ()
"Display the current cipher alphabet in the message line."
- (interactive)
+ (interactive nil decipher-mode)
(message "%s"
(mapconcat (lambda (a)
(concat
@@ -589,7 +572,7 @@ you have determined the keyword."
"Reprocess the buffer using the alphabet from the top.
This regenerates all deciphered plaintext and clears the undo list.
You should use this if you edit the ciphertext."
- (interactive)
+ (interactive nil decipher-mode)
(message "Reprocessing buffer...")
(let (alphabet
buffer-read-only ;Make buffer writable
@@ -633,13 +616,13 @@ You should use this if you edit the ciphertext."
(defun decipher-frequency-count ()
"Display the frequency count in the statistics buffer."
- (interactive)
+ (interactive nil decipher-mode)
(decipher-analyze)
(decipher-display-regexp "^A" "^[A-Z][A-Z]"))
(defun decipher-digram-list ()
"Display the list of digrams in the statistics buffer."
- (interactive)
+ (interactive nil decipher-mode)
(decipher-analyze)
(decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$"))
@@ -656,7 +639,7 @@ words, and ends 3 words (`*' represents a space). X comes before 8
different letters, after 7 different letters, and is next to a total
of 11 different letters. It occurs 14 times, making up 9% of the
ciphertext."
- (interactive (list (upcase (following-char))))
+ (interactive (list (upcase (following-char))) decipher-mode)
(decipher-analyze)
(let (start end)
(with-current-buffer (decipher-stats-buffer)
@@ -876,12 +859,12 @@ Creates the statistics buffer if it doesn't exist."
(aset decipher--after i (make-vector 27 0))))
(if decipher-ignore-spaces
(progn
- (decipher-loop-no-breaks 'decipher--analyze)
+ (decipher-loop-no-breaks #'decipher--analyze)
;; The first character of ciphertext was marked as following a space:
(let ((i 26))
(while (>= (cl-decf i) 0)
(aset (aref decipher--after i) 26 0))))
- (decipher-loop-with-breaks 'decipher--analyze))
+ (decipher-loop-with-breaks #'decipher--analyze))
(message "Processing results...")
(setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram
;; Sort the digram list by frequency and alphabetical order:
@@ -962,18 +945,12 @@ Creates the statistics buffer if it doesn't exist."
;; Statistics Buffer:
;;====================================================================
-(defun decipher-stats-mode ()
+(define-derived-mode decipher-stats-mode nil "Decipher-Stats"
"Major mode for displaying ciphertext statistics."
- (interactive)
- (kill-all-local-variables)
(setq buffer-read-only t
buffer-undo-list t ;Disable undo
case-fold-search nil ;Case is significant when searching
- indent-tabs-mode nil ;Do not use tab characters
- major-mode 'decipher-stats-mode
- mode-name "Decipher-Stats")
- (use-local-map decipher-stats-mode-map)
- (run-mode-hooks 'decipher-stats-mode-hook))
+ indent-tabs-mode nil)) ;Do not use tab characters
(put 'decipher-stats-mode 'mode-class 'special)
;;--------------------------------------------------------------------
@@ -1009,9 +986,8 @@ if it can't, it signals an error."
(let ((stats-name (concat "*" (buffer-name) "*")))
(setq decipher-stats-buffer
(if (eq 'decipher-stats-mode
- (cdr-safe (assoc 'major-mode
- (buffer-local-variables
- (get-buffer stats-name)))))
+ (buffer-local-value 'major-mode
+ (get-buffer stats-name)))
;; We just lost track of the statistics buffer:
(get-buffer stats-name)
(generate-new-buffer stats-name))))
diff --git a/lisp/play/dissociate.el b/lisp/play/dissociate.el
index f593951f66a..a1cc4727b54 100644
--- a/lisp/play/dissociate.el
+++ b/lisp/play/dissociate.el
@@ -1,4 +1,4 @@
-;;; dissociate.el --- scramble text amusingly for Emacs
+;;; dissociate.el --- scramble text amusingly for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el
index 99fb3204b33..bf923f4f2e5 100644
--- a/lisp/play/doctor.el
+++ b/lisp/play/doctor.el
@@ -1,4 +1,4 @@
-;;; doctor.el --- psychological help for frustrated users
+;;; doctor.el --- psychological help for frustrated users -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1994, 1996, 2000-2021 Free Software
;; Foundation, Inc.
@@ -145,399 +145,399 @@ reads the sentence before point, and prints the Doctor's answer."
(insert "\n"))
(defun make-doctor-variables ()
- (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-sent) nil)
- (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))
+ (setq-local 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)))))
+ (setq-local doctor-sent nil)
+ (setq-local doctor-found nil)
+ (setq-local doctor-owner nil)
+ (setq-local doctor--history nil)
+ (setq-local doctor--inter '((well\,)
+ (hmmm \.\.\.\ so\,)
+ (so)
+ (\.\.\.and)
+ (then)))
+ (setq-local doctor--continue '((continue)
+ (proceed)
+ (go on)
+ (keep going)))
+ (setq-local doctor--relation
+ '((your relationship with)
+ (something you remember about)
+ (your feelings toward)
+ (some experiences you have had with)
+ (how you feel about)))
+ (setq-local 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) \?)))
+ (setq-local doctor--sure '((sure)
+ (positive)
+ (certain)
+ (absolutely sure)))
+ (setq-local doctor--afraidof '((afraid of)
+ (frightened by)
+ (scared of)))
+ (setq-local doctor--areyou '((are you)
+ (have you been)
+ (have you been)))
+ (setq-local doctor--isrelated
+ '((has something to do with)
+ (is related to)
+ (could be the reason for)
+ (is caused by)
+ (is because of)))
+ (setq-local doctor--arerelated '((have something to do with)
+ (are related to)
+ (could have caused)
+ (could be the reason for)
+ (are caused by)
+ (are because of)))
+ (setq-local 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) \?)))
+ (setq-local doctor--maybe '((maybe)
+ (perhaps)
+ (possibly)))
+ (setq-local doctor--whatwhen '((what happened when)
+ (what would happen if)))
+ (setq-local doctor--hello '((how do you do \?)
+ (hello \.)
+ (howdy!)
+ (hello \.)
+ (hi \.)
+ (hi there \.)))
+ (setq-local doctor--drnk
+ '((do you drink a lot of (doc// doctor-found) \?)
+ (do you get drunk often \?)
+ ((doc$ doctor--describe) your drinking habits \.)))
+ (setq-local 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) \.)))
+ (setq-local 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) \?)))
+ (setq-local 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 \.)))
+ (setq-local doctor--want '((want) (desire) (wish) (want) (hope)))
+ (setq-local 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 \?)))
+ (setq-local 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 \?)))
+ (setq-local doctor--huhlst
+ '(((doc$ doctor--whysay) (doc// doctor-sent) \?)
+ (is it because of (doc$ doctor--things) that you say (doc// doctor-sent) \?)))
+ (setq-local doctor--longhuhlst
+ '(((doc$ doctor--whysay) that \?)
+ (i don\'t understand \.)
+ ((doc$ doctor--thlst))
+ ((doc$ doctor--areyou) (doc$ doctor--afraidof) that \?)))
+ (setq-local doctor--feelings-about '((feelings about)
+ (apprehensions toward)
+ (thoughts on)
+ (emotions toward)))
+ (setq-local doctor--random-adjective
+ '((vivid)
+ (emotionally stimulating)
+ (exciting)
+ (boring)
+ (interesting)
+ (recent)
+ (random) ; how can we omit this?
+ (unusual)
+ (shocking)
+ (embarrassing)))
+ (setq-local doctor--whysay '((why do you say)
+ (what makes you believe)
+ (are you sure that)
+ (do you really think)
+ (what makes you think)))
+ (setq-local doctor--isee '((i see \.\.\.)
+ (yes\,)
+ (i understand \.)
+ (oh \.) ))
+ (setq-local doctor--please '((please\,)
+ (i would appreciate it if you would)
+ (perhaps you could)
+ (please\,)
+ (would you please)
+ (why don\'t you)
+ (could you)))
+ (setq-local 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 \.)))
+ (setq-local doctor--something '((something)
+ (more)
+ (how you feel)))
+ (setq-local doctor--thing '((your life)
+ (your sex life)))
+ (setq-local 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)))
+ (setq-local doctor--describe '((describe)
+ (tell me about)
+ (talk about)
+ (discuss)
+ (tell me more about)
+ (elaborate on)))
+ (setq-local doctor--ibelieve
+ '((i believe) (i think) (i have a feeling) (it seems to me that)
+ (it looks like)))
+ (setq-local doctor--problems '((problems)
+ (inhibitions)
+ (hangups)
+ (difficulties)
+ (anxieties)
+ (frustrations)))
+ (setq-local 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)))
+ (setq-local 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 \?)))
+ (setq-local 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 \.)))
+ (setq-local 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 \.)))
+ (setq-local 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 \?)))
+ (setq-local 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) \.\.\. \?)))
+ (setq-local doctor--neglst '((why not \?)
+ ((doc$ doctor--bother) i ask that \?)
+ (why not \?)
+ (why not \?)
+ (how come \?)
+ ((doc$ doctor--bother) i ask that \?)))
+ (setq-local 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) \? )))
+ (setq-local 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 \.)))
+ (setq-local 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) \?)))
+ (setq-local doctor--remlst
+ '((earlier you said (doc$ doctor--history) \?)
+ (you mentioned that (doc$ doctor--history) \?)
+ ((doc$ doctor--whysay) (doc$ doctor--history) \? )))
+ (setq-local 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 \?)))
+ (setq-local 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) \?)))
+ (setq-local 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))))
+ (setq-local 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 \.)))
+ (setq-local 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) \.)))
+ (setq-local doctor--improve
+ '((improve) (be better) (be improved) (be higher)))
+ (setq-local 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) \?)))
+ (setq-local 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) \?)))
+ (setq-local 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 \.)))
+ (setq-local doctor--zippylst
+ '(((doc$ doctor--areyou) Zippy \?)
+ ((doc$ doctor--ibelieve) you have some serious (doc$ doctor--problems) \.)
+ ((doc$ doctor--bother) you are a pinhead \?)))
+ (setq-local 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) \?)))
+ (setq-local 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!)))
+ (setq-local 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))
+ (setq-local 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)))
+ (setq-local doctor--whereoutp '(huh remem rthing))
+ (setq-local doctor-subj nil)
+ (setq-local doctor-verb nil)
+ (setq-local doctor-obj nil)
+ (setq-local doctor--feared nil)
+ (setq-local doctor--repetitive-shortness '(0 . 0))
+ (setq-local doctor--**mad** nil)
+ (setq-local doctor--rms-flag nil)
+ (setq-local doctor--eliza-flag nil)
+ (setq-local doctor--zippy-flag nil)
+ (setq-local doctor--suicide-flag nil)
+ (setq-local doctor--lover '(your partner))
+ (setq-local doctor--bak nil)
+ (setq-local doctor--lincount 0)
+ (setq-local doctor--*print-upcase* nil)
+ (setq-local doctor--*print-space* nil)
+ (setq-local doctor--howdyflag nil)
+ (setq-local doctor-object nil))
;; Define equivalence classes of words that get treated alike.
@@ -1583,7 +1583,7 @@ Hack on previous word, setting global variable DOCTOR-OWNER to correct result."
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/\ \.
+ https://www.befrienders.org/\ \.
(doc$ doctor--please) (doc$ doctor--continue) \.)))
(t (doctor-type (doc$ doctor--deathlst)))))
diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el
index 7672bcf0ebe..c3be029a658 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -4,7 +4,7 @@
;; Author: Ron Schnell <ronnie@driver-aces.com>
;; Created: 25 Jul 1992
-;; Version: 2.02
+;; Old-Version: 2.02
;; Keywords: games
;; This file is part of GNU Emacs.
@@ -25,7 +25,8 @@
;;; Commentary:
;; This game can be run in batch mode. To do this, use:
-;; emacs -batch -l dunnet
+;;
+;; emacs --batch -f dunnet
;;; Code:
@@ -41,15 +42,14 @@
(locate-user-emacs-file "games/")))
"Name of file to store score information for dunnet."
:version "26.1"
- :type 'file
- :group 'dunnet)
+ :type 'file)
;;;;
;;;; This section defines the globals that are used in dunnet.
-;;;;
-;;;; IMPORTANT
-;;;; All globals which can change must be saved from 'save-game. Add
-;;;; all new globals to bottom of this section.
+;;
+;; IMPORTANT
+;; All globals which can change must be saved from 'save-game.
+;; Add all new globals to bottom of this section.
(defvar dun-visited '(27))
(defvar dun-current-room 1)
@@ -771,7 +771,6 @@ A hole leads north."
)
-;;; How the user references *all* objects, permanent and regular.
(defconst dun-objnames
'((shovel . 0)
(lamp . 1)
@@ -831,7 +830,8 @@ A hole leads north."
(ladder . -27)
(subway . -28) (train . -28)
(pc . -29) (drive . -29) (coconut . -30) (coconuts . -30)
- (lake . -32) (water . -32)))
+ (lake . -32) (water . -32))
+ "How the user references *all* objects, permanent and regular.")
(dolist (x dun-objnames)
(let (name)
@@ -840,13 +840,6 @@ A hole leads north."
(defconst obj-special 255)
-;;; The initial setup of what objects are in each room.
-;;; Regular objects have whole numbers lower than 255.
-;;; Objects that cannot be taken but might move and are
-;;; described during room description are negative.
-;;; Stuff that is described and might change are 255, and are
-;;; handled specially by 'dun-describe-room.
-
(defvar dun-room-objects (list nil
(list obj-shovel) ;; treasure-room
@@ -899,10 +892,13 @@ A hole leads north."
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
-nil))
-
-;;; These are objects in a room that are only described in the
-;;; room description. They are permanent.
+nil)
+ "The initial setup of what objects are in each room.
+Regular objects have whole numbers lower than 255.
+Objects that cannot be taken but might move and are
+described during room description are negative.
+Stuff that is described and might change are 255, and are
+handled specially by 'dun-describe-room.")
(defconst dun-room-silents (list nil
(list obj-tree obj-coconut) ;; dead-end
@@ -947,12 +943,11 @@ nil))
nil nil nil nil nil nil nil nil
(list obj-pc) ;; pc-area
nil nil nil nil nil nil
-))
+ )
+ "These are objects in a room that are only described in the
+room description. They are permanent.")
(defvar dun-inventory '(1))
-;;; Descriptions of objects, as they appear in the room description, and
-;;; the inventory.
-
(defconst dun-objects
'(("There is a shovel here." "A shovel") ;0
("There is a lamp nearby." "A lamp") ;1
@@ -982,26 +977,24 @@ nil))
("There is a valuable amethyst here." "An amethyst") ;24
("The Mona Lisa is here." "The Mona Lisa") ;25
("There is a 100 dollar bill here." "A $100 bill") ;26
- ("There is a floppy disk here." "A floppy disk"))) ;27
-
-;;; Weight of objects
+ ("There is a floppy disk here." "A floppy disk")) ;27
+ "Descriptions of objects, as they appear in the room description, and
+the inventory.")
(defconst dun-object-lbs
- '(2 1 1 1 1 0 2 2 10 3 1 1 1 0 1 1 0 1 1 1 1 0 0 2 2 1 0 0))
+ '(2 1 1 1 1 0 2 2 10 3 1 1 1 0 1 1 0 1 1 1 1 0 0 2 2 1 0 0)
+ "Weight of objects.")
(defconst dun-object-pts
'(0 0 0 0 0 0 0 10 0 0 10 10 10 0 0 10 0 10 10 0 0 0 0 10 10 10 10 0))
-;;; Unix representation of objects.
(defconst dun-objfiles
'("shovel.o" "lamp.o" "cpu.o" "food.o" "key.o" "paper.o"
"rms.o" "diamond.o" "weight.o" "preserver.o" "bracelet.o"
"gold.o" "platinum.o" "towel.o" "axe.o" "silver.o" "license.o"
"coins.o" "egg.o" "jar.o" "bone.o" "nitric.o" "glycerine.o"
- "ruby.o" "amethyst.o"))
-
-;;; These are the descriptions for the negative numbered objects from
-;;; dun-room-objects
+ "ruby.o" "amethyst.o")
+ "Unix representation of objects.")
(defconst dun-perm-objects
'(nil
@@ -1016,11 +1009,10 @@ nil))
("There is a box with a slit in it, bolted to the wall here.")
nil nil
("There is a bus here.")
- nil nil nil))
-
+ nil nil nil)
+ "These are the descriptions for the negative numbered objects from
+`dun-room-objects'.")
-;;; These are the descriptions the user gets when regular objects are
-;;; examined.
(defconst dun-physobj-desc '(
"It is a normal shovel with a price tag attached that says $19.99."
@@ -1043,10 +1035,8 @@ nil nil
"They are old coins from the 19th century."
"It is a valuable Fabrege egg."
"It is a plain glass jar."
-nil nil nil nil nil))
-
-;;; These are the descriptions the user gets when non-regular objects
-;;; are examined.
+nil nil nil nil nil)
+ "The descriptions the user gets when regular objects are examined.")
(defconst dun-permobj-desc
'(nil
@@ -1087,7 +1077,8 @@ it. It is very big, though."
nil nil nil nil
"It is a normal ladder that is permanently attached to the hole."
"It is a passenger train that is ready to go."
-"It is a personal computer that has only one floppy disk drive."))
+"It is a personal computer that has only one floppy disk drive.")
+ "The descriptions the user gets when non-regular objects are examined.")
(defconst dun-diggables
(list nil nil nil (list obj-cpu) nil nil nil nil nil nil nil
@@ -1144,8 +1135,7 @@ treasures for points?" "4" "four")
(define-derived-mode dun-mode text-mode "Dungeon"
"Major mode for running dunnet."
- (make-local-variable 'scroll-step)
- (setq scroll-step 2))
+ (setq-local scroll-step 2))
(defun dun-parse (_arg)
"Function called when return is pressed in interactive mode to parse line."
@@ -1180,20 +1170,21 @@ treasures for points?" "4" "four")
(defun dunnet ()
"Switch to *dungeon* buffer and start game."
(interactive)
- (pop-to-buffer-same-window "*dungeon*")
- (dun-mode)
- (setq dun-dead nil)
- (setq dun-room 0)
- (dun-messages))
+ (if noninteractive
+ (dun--batch)
+ (pop-to-buffer-same-window "*dungeon*")
+ (dun-mode)
+ (setq dun-dead nil)
+ (setq dun-room 0)
+ (dun-messages)))
;;;;
;;;; This section contains all of the verbs and commands.
;;;;
-;;; Give long description of room if haven't been there yet. Otherwise
-;;; short. Also give long if we were called with negative room number.
-
(defun dun-describe-room (room)
+ "Give long description of room if haven't been there yet.
+Otherwise short. Also give long if we were called with negative room number."
(if (and (not (member (abs room) dun-light-rooms))
(not (member obj-lamp dun-inventory))
(not (member obj-lamp (nth dun-current-room dun-room-objects))))
@@ -1223,10 +1214,9 @@ treasures for points?" "4" "four")
(if (and (member obj-bus (nth dun-current-room dun-room-objects)) dun-inbus)
(dun-mprincl "You are on the bus."))))
-;;; There is a special object in the room. This object's description,
-;;; or lack thereof, depends on certain conditions.
-
(defun dun-special-object ()
+ "There is a special object in the room. This object's description,
+or lack thereof, depends on certain conditions."
(cond
((= dun-current-room computer-room)
(if dun-computer
@@ -1299,10 +1289,9 @@ disk bursts into flames, and disintegrates.")
(defun dun-quit (_args)
(dun-die nil))
-;;; Print every object in player's inventory. Special case for the jar,
-;;; as we must also print what is in it.
-
(defun dun-inven (_args)
+ "Print every object in player's inventory.
+Special case for the jar, as we must also print what is in it."
(dun-mprincl "You currently have:")
(dolist (curobj dun-inventory)
(when curobj
@@ -1353,9 +1342,8 @@ on your head.")
(if (member objnum (list obj-food obj-weight obj-jar))
(dun-drop-check objnum)))))))
-;;; Dropping certain things causes things to happen.
-
(defun dun-drop-check (objnum)
+ "Dropping certain things causes things to happen."
(cond
((and (= objnum obj-food) (= dun-room bear-hangout)
(member obj-bear (nth bear-hangout dun-room-objects)))
@@ -1382,9 +1370,8 @@ through.")))
((and (= objnum obj-weight) (= dun-current-room maze-button-room))
(dun-mprincl "A passageway opens."))))
-;;; Give long description of current room, or an object.
-
(defun dun-examine (obj)
+ "Give long description of current room, or an object."
(let ((objnum (dun-objnum-from-args obj)))
(cond
((eq objnum obj-special)
@@ -1475,10 +1462,9 @@ For an explosive time, go to Fourth St. and Vermont.")
(setq total (+ total (nth x dun-object-lbs))))
total))
-;;; We try to take an object that is untakable. Print a message
-;;; depending on what it is.
-
(defun dun-try-take (_obj)
+ "We try to take an object that is untakable.
+Print a message depending on what it is."
(dun-mprinc "You cannot take that."))
(defun dun-dig (_args)
@@ -1671,15 +1657,15 @@ just try dropping it."))
(defun dun-go (args)
(if (or (not (car args))
(eq (dun-doverb dun-ignore dun-verblist (car args)
- (cdr (cdr args))) -1))
+ (cdr (cdr args)))
+ -1))
(dun-mprincl "I don't understand where you want me to go.")))
-;;; Uses the dungeon-map to figure out where we are going. If the
-;;; requested direction yields 255, we know something special is
-;;; supposed to happen, or perhaps you can't go that way unless
-;;; certain conditions are met.
-
(defun dun-move (dir)
+ ;; Uses the dungeon-map to figure out where we are going. If the
+ ;; requested direction yields 255, we know something special is
+ ;; supposed to happen, or perhaps you can't go that way unless
+ ;; certain conditions are met.
(if (and (not (member dun-current-room dun-light-rooms))
(not (member obj-lamp dun-inventory))
(not (member obj-lamp (nth dun-current-room dun-room-objects))))
@@ -1710,17 +1696,17 @@ body.")
(list obj-bus)))))
(setq dun-current-room newroom)))))))
-;;; Movement in this direction causes something special to happen if the
-;;; right conditions exist. It may be that you can't go this way unless
-;;; you have a key, or a passage has been opened.
+(defun dun-special-move (dir)
+ ;; Movement in this direction causes something special to happen if the
+ ;; right conditions exist. It may be that you can't go this way unless
+ ;; you have a key, or a passage has been opened.
-;;; coding note: Each check of the current room is on the same 'if' level,
-;;; i.e. there aren't else's. If two rooms next to each other have
-;;; specials, and they are connected by specials, this could cause
-;;; a problem. Be careful when adding them to consider this, and
-;;; perhaps use else's.
+ ;; coding note: Each check of the current room is on the same 'if' level,
+ ;; i.e. there aren't else's. If two rooms next to each other have
+ ;; specials, and they are connected by specials, this could cause
+ ;; a problem. Be careful when adding them to consider this, and
+ ;; perhaps use else's.
-(defun dun-special-move (dir)
(if (= dun-current-room building-front)
(if (not (member obj-key dun-inventory))
(dun-mprincl "You don't have a key that can open this door.")
@@ -1957,7 +1943,7 @@ to swim.")
(defun dun-help (_args)
(dun-mprincl
-"Welcome to dunnet (2.02), by Ron Schnell (ronnie@driver-aces.com - @RonnieSchnell).
+"Welcome to dunnet by Ron Schnell (ronnie@driver-aces.com - @RonnieSchnell).
Here is some useful information (read carefully because there are one
or more clues in here):
- If you have a key that can open a door, you do not need to explicitly
@@ -2153,10 +2139,10 @@ for a moment, then straighten yourself up.\n")
;;;;
-;;; Function which takes a verb and a list of other words. Calls proper
-;;; function associated with the verb, and passes along the other words.
-
(defun dun-doverb (ignore verblist verb rest)
+ "Take a verb and a list of other words.
+Calls proper function associated with the verb, and passes along the
+other words."
(when verb
(if (member (intern verb) ignore)
(if (not (car rest)) -1
@@ -2166,9 +2152,8 @@ for a moment, then straighten yourself up.\n")
(funcall (cdr (assq (intern verb) verblist)) rest)))))
-;;; Function to take a string and change it into a list of lowercase words.
-
(defun dun-listify-string (strin)
+ "Take a string and change it into a list of lowercase words."
(let (pos ret-list end-pos)
(setq pos 0)
(setq ret-list nil)
@@ -2178,7 +2163,8 @@ for a moment, then straighten yourself up.\n")
(setq ret-list (append ret-list (list
(downcase
(substring strin pos end-pos))))))
- (setq pos (+ end-pos 1))) ret-list))
+ (setq pos (+ end-pos 1)))
+ ret-list))
(defun dun-listify-string2 (strin)
(let (pos ret-list end-pos)
@@ -2195,10 +2181,8 @@ for a moment, then straighten yourself up.\n")
(defun dun-replace (list n number)
(rplaca (nthcdr n list) number))
-
-;;; Get the first non-ignored word from a list.
-
(defun dun-firstword (list)
+ "Get the first non-ignored word from a list."
(when (car list)
(while (and list (memq (intern (car list)) dun-ignore))
(setq list (cdr list)))
@@ -2210,10 +2194,9 @@ for a moment, then straighten yourself up.\n")
(setq list (cdr list)))
list))
-;;; parse a line passed in as a string Call the proper verb with the
-;;; rest of the line passed in as a list.
-
(defun dun-vparse (ignore verblist line)
+ "Parse a line passed in as a string.
+Call the proper verb with the rest of the line passed in as a list."
(dun-mprinc "\n")
(setq dun-line-list (dun-listify-string (concat line " ")))
(dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list)))
@@ -2223,54 +2206,47 @@ for a moment, then straighten yourself up.\n")
(setq dun-line-list (dun-listify-string2 (concat line " ")))
(dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list)))
-;;; Read a line, in window mode
-
(defun dun-read-line ()
+ "Read a line, in window mode."
(let ((line (read-string "")))
(dun-mprinc line)
line))
-;;; Insert something into the window buffer
-
(defun dun-minsert (&rest args)
+ "Insert something into the window buffer."
(dolist (arg args)
(if (stringp arg)
(insert arg)
(insert (prin1-to-string arg)))))
-;;; Print something out, in window mode
-
(defun dun-mprinc (&rest args)
+ "Print something out, in window mode."
(dolist (arg args)
(if (stringp arg)
(insert arg)
(insert (prin1-to-string arg)))))
-;;; In window mode, keep screen from jumping by keeping last line at
-;;; the bottom of the screen.
-
(defun dun-fix-screen ()
+ "In window mode, keep screen from jumping by keeping last line at
+the bottom of the screen."
(interactive)
(forward-line (- 0 (- (window-height) 2 )))
(set-window-start (selected-window) (point))
(goto-char (point-max)))
-;;; Insert something into the buffer, followed by newline.
-
(defun dun-minsertl (&rest args)
+ "Insert something into the buffer, followed by newline."
(apply #'dun-minsert args)
(dun-minsert "\n"))
-;;; Print something, followed by a newline.
-
(defun dun-mprincl (&rest args)
+ "Print something, followed by a newline."
(apply #'dun-mprinc args)
(dun-mprinc "\n"))
-;;; Function which will get an object number given the list of
-;;; words in the command, except for the verb.
-
(defun dun-objnum-from-args (obj)
+ "Get an object number given the list of words in the command,
+except for the verb."
(setq obj (dun-firstword obj))
(if (not obj)
obj-special
@@ -2286,9 +2262,8 @@ for a moment, then straighten yourself up.\n")
nil
result)))
-;;; Given a unix style pathname, build a list of path components (recursive)
-
(defun dun-get-path (dirstring startlist)
+ "Given a unix style pathname, build a list of path components (recursive)"
(let (slash)
(if (= (length dirstring) 0)
startlist
@@ -2300,10 +2275,9 @@ for a moment, then straighten yourself up.\n")
(append startlist
(list (substring dirstring 0 slash)))))))))
-;;; Function to put objects in the treasure room. Also prints current
-;;; score to let user know he has scored.
-
(defun dun-put-objs-in-treas (objlist)
+ "Put objects in the treasure room.
+Also prints current score to let user know he has scored."
(let (oscore newscore)
(setq oscore (dun-reg-score))
(dun-replace dun-room-objects 0 (append (nth 0 dun-room-objects) objlist))
@@ -2311,9 +2285,8 @@ for a moment, then straighten yourself up.\n")
(if (not (= oscore newscore))
(dun-score nil))))
-;;; Load an encrypted file, and eval it.
-
(defun dun-load-d (filename)
+ "Load an encrypted file, and eval it."
(let ((result t))
(with-temp-buffer
(condition-case nil
@@ -2351,15 +2324,10 @@ for a moment, then straighten yourself up.\n")
(define-key dun-mode-map "\r" 'dun-parse)
(defvar dungeon-batch-map (make-keymap))
-(if (string= (substring emacs-version 0 2) "18")
- (let (n)
- (setq n 32)
- (while (< 0 (setq n (- n 1)))
- (aset dungeon-batch-map n 'dungeon-nil)))
- (let (n)
- (setq n 32)
- (while (< 0 (setq n (- n 1)))
- (aset (car (cdr dungeon-batch-map)) n 'dungeon-nil))))
+(let (n)
+ (setq n 32)
+ (while (< 0 (setq n (- n 1)))
+ (aset (car (cdr dungeon-batch-map)) n 'dungeon-nil)))
(define-key dungeon-batch-map "\r" 'exit-minibuffer)
(define-key dungeon-batch-map "\n" 'exit-minibuffer)
@@ -3160,18 +3128,30 @@ File not found")))
(dun-mprinc "\n")
(dun-batch-loop))
-(when noninteractive
- (fset 'dun-mprinc 'dun-batch-mprinc)
- (fset 'dun-mprincl 'dun-batch-mprincl)
- (fset 'dun-vparse 'dun-batch-parse)
- (fset 'dun-parse2 'dun-batch-parse2)
- (fset 'dun-read-line 'dun-batch-read-line)
- (fset 'dun-dos-interface 'dun-batch-dos-interface)
- (fset 'dun-unix-interface 'dun-batch-unix-interface)
+(defun dun--batch ()
+ "Start `dunnet' in batch mode."
+ (fset 'dun-mprinc #'dun-batch-mprinc)
+ (fset 'dun-mprincl #'dun-batch-mprincl)
+ (fset 'dun-vparse #'dun-batch-parse)
+ (fset 'dun-parse2 #'dun-batch-parse2)
+ (fset 'dun-read-line #'dun-batch-read-line)
+ (fset 'dun-dos-interface #'dun-batch-dos-interface)
+ (fset 'dun-unix-interface #'dun-batch-unix-interface)
(dun-mprinc "\n")
(setq dun-batch-mode t)
(dun-batch-loop))
+;; Apparently, there are many references out there to running us via
+;;
+;; emacs --batch -l dunnet
+;;
+;; So try and accommodate those without interfering with other cases
+;; where `dunnet.el' might be loaded in batch mode with no intention
+;; to run the game.
+(when (and noninteractive
+ (equal '("-l" "dunnet") (member "-l" command-line-args)))
+ (dun--batch))
+
(provide 'dunnet)
;; Local Variables:
diff --git a/lisp/play/fortune.el b/lisp/play/fortune.el
index d7709c29374..fb02edffe73 100644
--- a/lisp/play/fortune.el
+++ b/lisp/play/fortune.el
@@ -1,4 +1,4 @@
-;;; fortune.el --- use fortune to create signatures
+;;; fortune.el --- use fortune to create signatures -*- lexical-binding: t -*-
;; Copyright (C) 1999, 2001-2021 Free Software Foundation, Inc.
@@ -63,76 +63,75 @@
:link '(emacs-commentary-link "fortune.el")
:version "21.1"
:group 'games)
-(defgroup fortune-signature nil
- "Settings for use of fortune for signatures."
- :group 'fortune
- :group 'mail)
(defcustom fortune-dir "~/docs/ascii/misc/fortunes/"
"The directory to look in for local fortune cookies files."
- :type 'directory
- :group 'fortune)
+ :type 'directory)
+
(defcustom fortune-file
(expand-file-name "usenet" fortune-dir)
"The file in which local fortune cookies will be stored."
- :type 'file
- :group 'fortune)
+ :type 'file)
+
(defcustom fortune-database-extension ".dat"
"The extension of the corresponding fortune database.
Normally you won't have a reason to change it."
- :type 'string
- :group 'fortune)
+ :type 'string)
+
(defcustom fortune-program "fortune"
"Program to select a fortune cookie."
- :type 'string
- :group 'fortune)
+ :type 'string)
+
(defcustom fortune-program-options ()
"List of options to pass to the fortune program."
:type '(choice (repeat (string :tag "Option"))
(string :tag "Obsolete string of options"))
- :version "23.1"
- :group 'fortune)
+ :version "23.1")
+
(defcustom fortune-strfile "strfile"
"Program to compute a new fortune database."
- :type 'string
- :group 'fortune)
+ :type 'string)
+
(defcustom fortune-strfile-options ""
"Options to pass to the strfile program (a string)."
- :type 'string
- :group 'fortune)
-(defcustom fortune-quiet-strfile-options "> /dev/null"
+ :type 'string)
+
+(defcustom fortune-quiet-strfile-options (concat "> " null-device)
"Text added to the command for running `strfile'.
By default it discards the output produced by `strfile'.
Set this to \"\" if you would like to see the output."
- :type 'string
- :group 'fortune)
+ :type 'string)
(defcustom fortune-always-compile t
"Non-nil means automatically compile fortune files.
If nil, you must invoke `fortune-compile' manually to do that."
- :type 'boolean
- :group 'fortune)
+ :type 'boolean)
+
+(defgroup fortune-signature nil
+ "Settings for use of fortune for signatures."
+ :group 'fortune
+ :group 'mail)
+
(defcustom fortune-author-line-prefix " -- "
"Prefix to put before the author name of a fortunate."
- :type 'string
- :group 'fortune-signature)
+ :type 'string)
+
(defcustom fortune-fill-column fill-column
"Fill column for fortune files."
- :type 'integer
- :group 'fortune-signature)
+ :type 'integer)
+
(defcustom fortune-from-mail "private e-mail"
"String to use to characterize that the fortune comes from an e-mail.
No need to add an `in'."
- :type 'string
- :group 'fortune-signature)
+ :type 'string)
+
(defcustom fortune-sigstart ""
"Some text to insert before the fortune cookie, in a mail signature."
- :type 'string
- :group 'fortune-signature)
+ :type 'string)
+
(defcustom fortune-sigend ""
"Some text to insert after the fortune cookie, in a mail signature."
- :type 'string
- :group 'fortune-signature)
+ :type 'string)
;; not customizable settings
@@ -297,7 +296,7 @@ specifies the file to choose the fortune from."
(erase-buffer)
(if fortune-always-compile
(fortune-compile fort-file))
- (apply 'call-process
+ (apply #'call-process
fortune-program ; program to call
nil fortune-buffer nil ; INFILE BUFFER DISPLAY
(append (if (stringp fortune-program-options)
@@ -334,7 +333,6 @@ and choose the directory as the fortune-file."
(setq buffer-read-only t))
-;;; Provide ourselves.
(provide 'fortune)
;;; fortune.el ends here
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index d581b6b8fb5..8b64dfdf9b5 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Author: Glynn Clements <glynn@sensei.co.uk>
-;; Version: 1.02
+;; Old-Version: 1.02
;; Created: 1997-08-13
;; Keywords: games
@@ -28,36 +28,35 @@
;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar gamegrid-use-glyphs t
+(defvar-local gamegrid-use-glyphs t
"Non-nil means use glyphs when available.")
-(defvar gamegrid-use-color t
+(defvar-local gamegrid-use-color t
"Non-nil means use color when available.")
-(defvar gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
+(defvar-local gamegrid-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*"
"Name of the font used in X mode.")
-(defvar gamegrid-face nil
+(defvar-local gamegrid-face nil
"Indicates the face to use as a default.")
-(make-variable-buffer-local 'gamegrid-face)
-(defvar gamegrid-display-options nil)
+(defvar-local gamegrid-display-options nil)
-(defvar gamegrid-buffer-width 0)
-(defvar gamegrid-buffer-height 0)
-(defvar gamegrid-blank 0)
+(defvar-local gamegrid-buffer-width 0)
+(defvar-local gamegrid-buffer-height 0)
+(defvar-local gamegrid-blank 0)
-(defvar gamegrid-timer nil)
+(defvar-local gamegrid-timer nil)
-(defvar gamegrid-display-mode nil)
+(defvar-local gamegrid-display-mode nil)
-(defvar gamegrid-display-table)
+(defvar-local gamegrid-display-table nil)
-(defvar gamegrid-face-table nil)
+(defvar-local gamegrid-face-table nil)
-(defvar gamegrid-buffer-start 1)
+(defvar-local gamegrid-buffer-start 1)
-(defvar gamegrid-score-file-length 50
+(defvar-local gamegrid-score-file-length 50
"Number of high scores to keep.")
(defvar gamegrid-user-score-file-directory
@@ -66,19 +65,6 @@
If Emacs was built without support for shared game scores, then this
directory will be used.")
-(make-variable-buffer-local 'gamegrid-use-glyphs)
-(make-variable-buffer-local 'gamegrid-use-color)
-(make-variable-buffer-local 'gamegrid-font)
-(make-variable-buffer-local 'gamegrid-display-options)
-(make-variable-buffer-local 'gamegrid-buffer-width)
-(make-variable-buffer-local 'gamegrid-buffer-height)
-(make-variable-buffer-local 'gamegrid-blank)
-(make-variable-buffer-local 'gamegrid-timer)
-(make-variable-buffer-local 'gamegrid-display-mode)
-(make-variable-buffer-local 'gamegrid-display-table)
-(make-variable-buffer-local 'gamegrid-face-table)
-(make-variable-buffer-local 'gamegrid-buffer-start)
-(make-variable-buffer-local 'gamegrid-score-file-length)
;; ;;;;;;;;;;;;; global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -265,12 +251,7 @@ format."
(set-face-foreground face color)
(set-face-background face color)
(gamegrid-set-font face)
- (condition-case nil
- (set-face-background-pixmap face [nothing]);; XEmacs
- (error nil))
- (condition-case nil
- (set-face-background-pixmap face nil);; Emacs
- (error nil)))
+ (set-face-background-pixmap face nil))
(defun gamegrid-make-mono-tty-face ()
(let ((face (make-face 'gamegrid-mono-tty-face)))
@@ -640,6 +621,8 @@ FILE is created there."
(save-excursion
(setq file (expand-file-name file (or directory
temporary-file-directory)))
+ (unless (file-exists-p (file-name-directory file))
+ (make-directory (file-name-directory file) t))
(find-file-other-window file)
(setq buffer-read-only nil)
(goto-char (point-max))
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index 053cc5f4781..c6aef027e5f 100644
--- a/lisp/play/gametree.el
+++ b/lisp/play/gametree.el
@@ -1,4 +1,4 @@
-;;; gametree.el --- manage game analysis trees in Emacs
+;;; gametree.el --- manage game analysis trees in Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
@@ -79,7 +79,6 @@
;;; Code:
-(require 'derived)
(require 'outline)
;;;; Configuration variables
@@ -98,35 +97,30 @@ numbers of moves by Black (if considered in isolation) by the ellipsis
conflicts with the use of ellipsis by Outline mode to denote collapsed
subtrees. The author uses \":\" because it agrees nicely with a set of
LaTeX macros he uses for typesetting annotated games."
- :type 'regexp
- :group 'gametree)
+ :type 'regexp)
(defcustom gametree-full-ply-regexp (regexp-quote ".")
"Matches ends of numbers of moves by the \"first\" player.
For instance, it is an almost universal convention in chess to postfix
numbers of moves by White (if considered in isolation) by the dot \".\"."
- :type 'regexp
- :group 'gametree)
+ :type 'regexp)
(defcustom gametree-half-ply-format "%d:"
"Output format for move numbers of moves by the \"second\" player.
Has to contain \"%d\" to output the actual number."
- :type 'string
- :group 'gametree)
+ :type 'string)
(defcustom gametree-full-ply-format "%d."
"Output format for move numbers of moves by the \"first\" player.
Has to contain \"%d\" to output the actual number."
- :type 'string
- :group 'gametree)
+ :type 'string)
(defcustom gametree-make-heading-function
- (function (lambda (level)
- (insert (make-string level ?*))))
+ (lambda (level)
+ (insert (make-string level ?*)))
"A function of one numeric argument, LEVEL, to insert a heading at point.
You should change this if you change `outline-regexp'."
- :type 'function
- :group 'gametree)
+ :type 'function)
(defvar gametree-local-layout nil
"A list encoding the layout (i.e. the show or hide state) of the file.
@@ -138,18 +132,15 @@ the file is visited (subject to the usual restriction via
(defcustom gametree-score-opener "{score="
"The string which opens a score tag, and precedes the actual score."
- :type 'string
- :group 'gametree)
+ :type 'string)
(defcustom gametree-score-manual-flag "!"
"String marking the line as manually (as opposed to automatically) scored."
- :type 'string
- :group 'gametree)
+ :type 'string)
(defcustom gametree-score-closer "}"
"The string which closes a score tag, and follows the actual score."
- :type 'string
- :group 'gametree)
+ :type 'string)
(defcustom gametree-score-regexp
(concat "[^\n\^M]*\\("
@@ -167,13 +158,11 @@ line as *manually* (as opposed to automatically) scored, which
prevents the program from recursively applying the scoring algorithm
on the subtree headed by the marked line, and makes it use the manual
score instead."
- :type 'regexp
- :group 'gametree)
+ :type 'regexp)
(defcustom gametree-default-score 0
"Score to assume for branches lacking score tags."
- :type 'integer
- :group 'gametree)
+ :type 'integer)
;;;; Helper functions
@@ -324,7 +313,7 @@ This value is simply the outline heading level of the current line."
(defun gametree-hack-file-layout ()
(save-excursion
(goto-char (point-min))
- (if (looking-at "[^\n]*-*-[^\n]*gametree-local-layout: \\([^;\n]*\\);")
+ (if (looking-at "[^\n]*-[^\n]*gametree-local-layout: \\([^;\n]*\\);")
(progn
(goto-char (match-beginning 1))
(delete-region (point) (match-end 1))
diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el
index a9c2a311697..0a45885b875 100644
--- a/lisp/play/gomoku.el
+++ b/lisp/play/gomoku.el
@@ -28,39 +28,36 @@
;; RULES:
;;
;; Gomoku is a game played between two players on a rectangular board. Each
-;; player, in turn, marks a free square of its choice. The winner is the first
+;; player, in turn, marks a free square of its choice. The winner is the first
;; one to mark five contiguous squares in any direction (horizontally,
;; vertically or diagonally).
;;
;; I have been told that, in "The TRUE Gomoku", some restrictions are made
;; about the squares where one may play, or else there is a known forced win
-;; for the first player. This program has no such restriction, but it does not
+;; for the first player. This program has no such restriction, but it does not
;; know about the forced win, nor do I.
-;; See http://renju.se/rif/r1rulhis.htm for more information.
-
+;; See https://renju.se/rif/r1rulhis.htm for more information.
;; There are two main places where you may want to customize the program: key
-;; bindings and board display. These features are commented in the code. Go
+;; bindings and board display. These features are commented in the code. Go
;; and see.
-
;; HOW TO USE:
;;
-;; The command "M-x gomoku" displays a
-;; board, the size of which depends on the size of the current window. The
-;; size of the board is easily modified by giving numeric arguments to the
-;; gomoku command and/or by customizing the displaying parameters.
+;; The command `M-x gomoku' displays a board, the size of which depends on the
+;; size of the current window. The size of the board is easily modified by
+;; giving numeric arguments to the gomoku command and/or by customizing the
+;; displaying parameters.
;;
-;; Emacs plays when it is its turn. When it is your turn, just put the cursor
+;; Emacs plays when it is its turn. When it is your turn, just put the cursor
;; on the square where you want to play and hit RET, or X, or whatever key you
-;; bind to the command gomoku-human-plays. When it is your turn, Emacs is
+;; bind to the command `gomoku-human-plays'. When it is your turn, Emacs is
;; idle: you may switch buffers, read your mail, ... Just come back to the
;; *Gomoku* buffer and resume play.
-
;; ALGORITHM:
;;
-;; The algorithm is briefly described in section "THE SCORE TABLE". Some
+;; The algorithm is briefly described in section "THE SCORE TABLE". Some
;; parameters may be modified if you want to change the style exhibited by the
;; program.
@@ -76,8 +73,7 @@
(defcustom gomoku-mode-hook nil
"If non-nil, its value is called on entry to Gomoku mode.
One useful value to include is `turn-on-font-lock' to highlight the pieces."
- :type 'hook
- :group 'gomoku)
+ :type 'hook)
;;;
;;; CONSTANTS FOR BOARD
@@ -87,13 +83,15 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
"Name of the Gomoku buffer.")
;; 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).
+;; look rectangular.
(defconst gomoku-square-width 4
- "Horizontal spacing between squares on the Gomoku board.")
+ "Horizontal spacing between squares on the Gomoku board.
+SHOULD be at least 2 (MUST BE at least 1).")
(defconst gomoku-square-height 2
- "Vertical spacing between squares on the Gomoku board.")
+ "Vertical spacing between squares on the Gomoku board.
+SHOULD be at least 2 (MUST BE at least 1).")
(defconst gomoku-x-offset 3
"Number of columns between the Gomoku board and the side of the window.")
@@ -110,8 +108,8 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
(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 "h" 'gomoku-move-left) ; h
+ (define-key map "l" 'gomoku-move-right) ; l
(define-key map "j" 'gomoku-move-down) ; j
(define-key map "k" 'gomoku-move-up) ; k
@@ -119,11 +117,13 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
(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-4] 'gomoku-move-left)
+ (define-key map [kp-6] 'gomoku-move-right)
(define-key map [kp-2] 'gomoku-move-down)
(define-key map [kp-8] 'gomoku-move-up)
+ (define-key map "\C-b" 'gomoku-move-left) ; C-b
+ (define-key map "\C-f" 'gomoku-move-right) ; C-f
(define-key map "\C-n" 'gomoku-move-down) ; C-n
(define-key map "\C-p" 'gomoku-move-up) ; C-p
@@ -146,6 +146,10 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
(define-key map [mouse-2] 'gomoku-mouse-play)
(define-key map [drag-mouse-2] 'gomoku-mouse-play)
+ (define-key map [remap backward-char] 'gomoku-move-left)
+ (define-key map [remap left-char] 'gomoku-move-left)
+ (define-key map [remap forward-char] 'gomoku-move-right)
+ (define-key map [remap right-char] 'gomoku-move-right)
(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)
@@ -162,13 +166,11 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
(defface gomoku-O
'((((class color)) (:foreground "red" :weight bold)))
- "Face to use for Emacs's O."
- :group 'gomoku)
+ "Face to use for Emacs's O.")
(defface gomoku-X
'((((class color)) (:foreground "green" :weight bold)))
- "Face to use for your X."
- :group 'gomoku)
+ "Face to use for your X.")
(defvar gomoku-font-lock-keywords
'(("O" . 'gomoku-O)
@@ -189,9 +191,8 @@ You play by moving the cursor over the square you choose and hitting \\[gomoku-h
Other useful commands:\n
\\{gomoku-mode-map}"
(gomoku-display-statistics)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(gomoku-font-lock-keywords t)
- buffer-read-only t)
+ (setq-local font-lock-defaults '(gomoku-font-lock-keywords t))
+ (setq buffer-read-only t)
(add-hook 'post-command-hook #'gomoku--intangible nil t))
;;;
@@ -268,13 +269,13 @@ Other useful commands:\n
;; internested 5-tuples of contiguous squares (called qtuples).
;;
;; The aim of the program is to fill one qtuple with its O's while preventing
-;; you from filling another one with your X's. To that effect, it computes a
-;; score for every qtuple, with better qtuples having better scores. Of
+;; you from filling another one with your X's. To that effect, it computes a
+;; score for every qtuple, with better qtuples having better scores. Of
;; course, the score of a qtuple (taken in isolation) is just determined by
-;; its contents as a set, i.e. not considering the order of its elements. The
+;; 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 losing the game, and so on. Note that a
+;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
+;; 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.
@@ -282,11 +283,11 @@ Other useful commands:\n
;; Given the score of every qtuple, the score of a given free square on the
;; board is just the sum of the scores of all the qtuples to which it belongs,
;; because playing in that square is playing in all its containing qtuples at
-;; once. And it is that function which takes into account the internesting of
+;; once. And it is that function which takes into account the internesting of
;; the qtuples.
;;
;; This algorithm is rather simple but anyway it gives a not so dumb level of
-;; play. It easily extends to "n-dimensional Gomoku", where a win should not
+;; play. It easily extends to "n-dimensional Gomoku", where a win should not
;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !)
;; should be preferred.
@@ -321,8 +322,8 @@ Other useful commands:\n
;; 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.
+;; 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
@@ -341,9 +342,9 @@ Other useful commands:\n
;; If you do not modify drastically the previous constants, the only way for a
;; 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
+;; qtuple, thus to be a winning move. Similarly, the only way for a square to
;; 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
+;; qtuple. We may use these considerations to detect when a given move is
;; winning or losing.
(defconst gomoku-winning-threshold gomoku-OOOOscore
@@ -355,8 +356,8 @@ Other useful commands:\n
(defun gomoku-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
+ ;; 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
;; up future searches, we set the score of padding or occupied squares
;; to -1 whenever we meet them.
;; 2/ We want to choose randomly between equally good moves.
@@ -376,7 +377,7 @@ Other useful commands:\n
best-square square
score-max score)
(aset gomoku-score-table square -1))) ; no: kill it !
- ;; If score is equally good, choose randomly. But first check freedom:
+ ;; If score is equally good, choose randomly. But first check freedom:
((not (zerop (aref gomoku-board square)))
(aset gomoku-score-table square -1))
((zerop (random (setq count (1+ count))))
@@ -390,11 +391,11 @@ Other useful commands:\n
;;;
;; At initialization the board is empty so that every qtuple amounts for
-;; 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
+;; 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*gomoku-nil-score and then only
-;; consider squares at less than 5 squares from one side. We speed this up by
+;; 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
;; same size, it is a good idea to save the initial SCORE-TABLE configuration.
@@ -449,7 +450,7 @@ Other useful commands:\n
"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 !
+ ;; If you have a simpler (and correct) solution, send it to me. Thanks !
(let ((left (min 4 (1- i)))
(right (min 4 (- gomoku-board-width i)))
(up (min 4 (1- j)))
@@ -475,9 +476,9 @@ Other useful commands:\n
;;;
;; We do not provide functions for computing the SCORE-TABLE given the
-;; contents of the BOARD. This would involve heavy nested loops, with time
-;; proportional to the size of the board. It is better to update the
-;; SCORE-TABLE after each move. Updating needs not modify more than 36
+;; contents of the BOARD. This would involve heavy nested loops, with time
+;; proportional to the size of the board. It is better to update the
+;; SCORE-TABLE after each move. Updating needs not modify more than 36
;; squares: it is done in constant time.
(defun gomoku-update-score-table (square dval)
@@ -780,7 +781,7 @@ Use \\[describe-mode] for more info."
(defun gomoku-emacs-plays ()
"Compute Emacs next move and play it."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-switch-to-window)
(cond
(gomoku-emacs-is-computing
@@ -813,7 +814,7 @@ Use \\[describe-mode] for more info."
;; pixels, event's (X . Y) is a character's top-left corner.
(defun gomoku-click (click)
"Position at the square where you click."
- (interactive "e")
+ (interactive "e" gomoku-mode)
(and (windowp (posn-window (setq click (event-end click))))
(numberp (posn-point click))
(select-window (posn-window click))
@@ -842,7 +843,7 @@ Use \\[describe-mode] for more info."
(defun gomoku-mouse-play (click)
"Play at the square where you click."
- (interactive "e")
+ (interactive "e" gomoku-mode)
(if (gomoku-click click)
(gomoku-human-plays)))
@@ -850,7 +851,7 @@ Use \\[describe-mode] for more info."
"Signal to the Gomoku 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)
+ (interactive nil gomoku-mode)
(gomoku-switch-to-window)
(cond
(gomoku-emacs-is-computing
@@ -878,7 +879,7 @@ If the game is finished, this command requests for another game."
(defun gomoku-human-takes-back ()
"Signal to the Gomoku program that you wish to take back your last move."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-switch-to-window)
(cond
(gomoku-emacs-is-computing
@@ -902,7 +903,7 @@ If the game is finished, this command requests for another game."
(defun gomoku-human-resigns ()
"Signal to the Gomoku program that you may want to resign."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-switch-to-window)
(cond
(gomoku-emacs-is-computing
@@ -954,6 +955,11 @@ If the game is finished, this command requests for another game."
;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line !
gomoku-square-height)))
+(defun gomoku-point-x ()
+ "Return the board column where point is."
+ (1+ (/ (- (current-column) gomoku-x-offset)
+ gomoku-square-width)))
+
(defun gomoku-point-y ()
"Return the board row where point is."
(1+ (/ (- (count-lines (point-min) (point))
@@ -1143,17 +1149,32 @@ If the game is finished, this command requests for another game."
(skip-chars-forward gomoku--intangible-chars)
(when (eobp)
(skip-chars-backward gomoku--intangible-chars)
- (forward-char -1)))
+ (gomoku-move-left)))
(skip-chars-backward gomoku--intangible-chars)
(if (bobp)
(skip-chars-forward gomoku--intangible-chars)
- (forward-char -1))))
+ (gomoku-move-left))))
(setq gomoku--last-pos (point)))
+;; forward-char and backward-char don't always move the right number
+;; of characters. Also, these functions check if you're on the edge of
+;; the screen.
+(defun gomoku-move-right ()
+ "Move point right one column on the Gomoku board."
+ (interactive nil gomoku-mode)
+ (when (< (gomoku-point-x) gomoku-board-width)
+ (forward-char gomoku-square-width)))
+
+(defun gomoku-move-left ()
+ "Move point left one column on the Gomoku board."
+ (interactive nil gomoku-mode)
+ (when (> (gomoku-point-x) 1)
+ (backward-char gomoku-square-width)))
+
;; previous-line and next-line don't work right with intangible newlines
(defun gomoku-move-down ()
"Move point down one row on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(when (< (gomoku-point-y) gomoku-board-height)
(let ((column (current-column)))
(forward-line gomoku-square-height)
@@ -1161,7 +1182,7 @@ If the game is finished, this command requests for another game."
(defun gomoku-move-up ()
"Move point up one row on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(when (> (gomoku-point-y) 1)
(let ((column (current-column)))
(forward-line (- gomoku-square-height))
@@ -1169,36 +1190,36 @@ If the game is finished, this command requests for another game."
(defun gomoku-move-ne ()
"Move point North East on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-move-up)
- (forward-char))
+ (gomoku-move-right))
(defun gomoku-move-se ()
"Move point South East on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-move-down)
- (forward-char))
+ (gomoku-move-right))
(defun gomoku-move-nw ()
"Move point North West on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-move-up)
- (backward-char))
+ (gomoku-move-left))
(defun gomoku-move-sw ()
"Move point South West on the Gomoku board."
- (interactive)
+ (interactive nil gomoku-mode)
(gomoku-move-down)
- (backward-char))
+ (gomoku-move-left))
(defun gomoku-beginning-of-line ()
"Move point to first square on the Gomoku board row."
- (interactive)
+ (interactive nil gomoku-mode)
(move-to-column gomoku-x-offset))
(defun gomoku-end-of-line ()
"Move point to last square on the Gomoku board row."
- (interactive)
+ (interactive nil gomoku-mode)
(move-to-column (+ gomoku-x-offset
(* gomoku-square-width (1- gomoku-board-width)))))
diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el
index 1889288c572..cc058230751 100644
--- a/lisp/play/handwrite.el
+++ b/lisp/play/handwrite.el
@@ -1,8 +1,9 @@
-;;; handwrite.el --- turns your emacs buffer into a handwritten document
+;;; handwrite.el --- turns your emacs buffer into a handwritten document -*- lexical-binding: t -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
;; Author: Danny Roozendaal (was: <danny@tvs.kun.nl>)
+;; Maintainer: emacs-devel@gnu.org
;; Created: October 21 1996
;; Keywords: wp, print, postscript, cursive writing
@@ -22,11 +23,11 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
+
+;; The function `handwrite' creates PostScript output containing a
+;; handwritten version of the current buffer.
;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The function handwrite creates PostScript output containing a
-;; handwritten version of the current buffer..
-;; Other functions that may be useful are
+;; Other functions that may be useful are:
;;
;; handwrite-10pt: sets the font size to 10 and finds corresponding
;; values for the line spacing and the number of lines
@@ -41,16 +42,8 @@
;; If you are not satisfied with the type page there are a number of
;; variables you may want to set.
;;
-;;
-;; Installation
-;;
-;; type at your prompt "emacs -l handwrite.el" or put this file on your
-;; Emacs Lisp load path, add the following into your init file:
-;;
-;; (require 'handwrite)
-;;
-;; "M-x handwrite" or "Write by hand" in the edit menu should work now.
-;;
+;; To use this, say "M-x handwrite" or type at your prompt
+;; "emacs -l handwrite.el".
;;
;; I tried to make it `iso_8859_1'-friendly, but there are some exotic
;; characters missing.
@@ -62,8 +55,6 @@
;; unknown characters.
;;
;; Thanks to anyone who emailed me suggestions!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
;;; Code:
@@ -72,7 +63,6 @@
(defvar ps-lpr-command)
(defvar ps-lpr-switches)
-
;; Variables
(defgroup handwrite nil
@@ -100,50 +90,50 @@
(define-key map [handwrite] '("Write by hand" . handwrite))
map))
(fset 'menu-bar-handwrite-map menu-bar-handwrite-map)
-
+(make-obsolete 'menu-bar-handwrite-map nil "28.1")
+(make-obsolete-variable 'menu-bar-handwrite-map nil "28.1")
;; User definable variables
(defcustom handwrite-numlines 60
"The number of lines on a page of the PostScript output from `handwrite'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-fontsize 11
"The size of the font for the PostScript output from `handwrite'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-linespace 12
"The spacing for the PostScript output from `handwrite'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-xstart 30
"X-axis translation in the PostScript output from `handwrite'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-ystart 810
"Y-axis translation in the PostScript output from `handwrite'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-pagenumbering nil
"If non-nil, number each page of the PostScript output from `handwrite'."
- :type 'boolean
- :group 'handwrite)
+ :type 'boolean)
+
(defcustom handwrite-10pt-numlines 65
"The number of lines on a page for the function `handwrite-10pt'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-11pt-numlines 60
"The number of lines on a page for the function `handwrite-11pt'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-12pt-numlines 55
"The number of lines on a page for the function `handwrite-12pt'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
+
(defcustom handwrite-13pt-numlines 50
"The number of lines on a page for the function `handwrite-13pt'."
- :type 'integer
- :group 'handwrite)
+ :type 'integer)
;; Interactive functions
@@ -158,17 +148,17 @@ Variables: `handwrite-linespace' (default 12)
`handwrite-numlines' (default 60)
`handwrite-pagenumbering' (default nil)"
(interactive)
+ (setq handwrite-psindex (1+ handwrite-psindex))
(let
- (;(pmin) ; thanks, Havard
- (cur-buf (current-buffer))
+ ((cur-buf (current-buffer))
(tpoint (point))
(ps-ypos 63)
(lcount 0)
(ipage 1)
- (nlan next-line-add-newlines) ;remember the old value
+ (next-line-add-newlines t)
(buf-name (buffer-name) )
(textp)
- (ps-buf-name) ;name of the PostScript buffer
+ (ps-buf-name (format "*handwritten%d.ps*" handwrite-psindex))
(trans-table
'(("ÿ" . "264") ("á" . "207") ("à" . "210") ("â" . "211")
("ä" . "212") ("ã" . "213") ("å" . "214") ("é" . "216")
@@ -183,10 +173,6 @@ Variables: `handwrite-linespace' (default 12)
; on inserted backslashes
line)
(goto-char (point-min)) ;start at beginning
- (setq handwrite-psindex (1+ handwrite-psindex))
- (setq ps-buf-name
- (format "*handwritten%d.ps*" handwrite-psindex))
- (setq next-line-add-newlines t)
(switch-to-buffer ps-buf-name)
(handwrite-insert-header buf-name)
(insert "%%Creator: GNU Emacs's handwrite version " emacs-version "\n")
@@ -241,7 +227,7 @@ Variables: `handwrite-linespace' (default 12)
))
(switch-to-buffer ps-buf-name)
(forward-line 1)
- (insert "showpage exec Hwsave restore\n\n")
+ (insert " showpage exec Hwsave restore\n\n")
(insert "%%Pages " (number-to-string ipage) " 0\n")
(insert "%%EOF\n")
;;To avoid cumbersome code we simply ignore formfeeds
@@ -266,9 +252,7 @@ Variables: `handwrite-linespace' (default 12)
(message "")
(bury-buffer ())
(switch-to-buffer cur-buf)
- (goto-char tpoint)
- (setq next-line-add-newlines nlan)
- ))
+ (goto-char tpoint)))
(defun handwrite-set-pagenumber ()
@@ -288,7 +272,6 @@ values for `handwrite-linespace' and `handwrite-numlines'."
(setq handwrite-numlines handwrite-10pt-numlines)
(message "Handwrite output size set to 10 points"))
-
(defun handwrite-11pt ()
"Specify 11-point output for `handwrite'.
This sets `handwrite-fontsize' to 11 and finds correct
@@ -1246,28 +1229,16 @@ end
/Joepie Hwfdict definefont
%%EndFont Joepie\n\n"))
-;;Sets page numbering off
(defun handwrite-set-pagenumber-off ()
+ "Set page numbering off."
(setq handwrite-pagenumbering nil)
(message "page numbering off"))
-;;Sets page numbering on
(defun handwrite-set-pagenumber-on ()
+ "Set page numbering on."
(setq handwrite-pagenumbering t)
(message "page numbering on" ))
-
-;; Key bindings
-
-;; 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)
-
(provide 'handwrite)
-
;;; handwrite.el ends here
diff --git a/lisp/play/hanoi.el b/lisp/play/hanoi.el
index d762290f0da..ac28fba10a4 100644
--- a/lisp/play/hanoi.el
+++ b/lisp/play/hanoi.el
@@ -1,4 +1,4 @@
-;;; hanoi.el --- towers of hanoi in Emacs
+;;; hanoi.el --- towers of hanoi in Emacs -*- lexical-binding: t -*-
;; Author: Damon Anton Permezel
;; Maintainer: emacs-devel@gnu.org
@@ -71,33 +71,33 @@
(defcustom hanoi-horizontal-flag nil
"If non-nil, hanoi poles are oriented horizontally."
- :group 'hanoi :type 'boolean)
+ :type 'boolean)
(defcustom hanoi-move-period 1.0
"Time, in seconds, for each pole-to-pole move of a ring.
If nil, move rings as fast as possible while displaying all
intermediate positions."
- :group 'hanoi :type '(restricted-sexp :match-alternatives (numberp 'nil)))
+ :type '(restricted-sexp :match-alternatives (numberp 'nil)))
(defcustom hanoi-use-faces nil
"If nil, all hanoi-*-face variables are ignored."
- :group 'hanoi :type 'boolean)
+ :type 'boolean)
(defcustom hanoi-pole-face 'highlight
"Face for poles. Ignored if hanoi-use-faces is nil."
- :group 'hanoi :type 'face)
+ :type 'face)
(defcustom hanoi-base-face 'highlight
"Face for base. Ignored if hanoi-use-faces is nil."
- :group 'hanoi :type 'face)
+ :type 'face)
(defcustom hanoi-even-ring-face 'region
"Face for even-numbered rings. Ignored if hanoi-use-faces is nil."
- :group 'hanoi :type 'face)
+ :type 'face)
(defcustom hanoi-odd-ring-face 'secondary-selection
"Face for odd-numbered rings. Ignored if hanoi-use-faces is nil."
- :group 'hanoi :type 'face)
+ :type 'face)
;;;
diff --git a/lisp/play/life.el b/lisp/play/life.el
index c12397e4d2b..2abf8ccb74b 100644
--- a/lisp/play/life.el
+++ b/lisp/play/life.el
@@ -1,4 +1,4 @@
-;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
+;;; life.el --- John Horton Conway's Game of Life -*- lexical-binding:t -*-
;; Copyright (C) 1988, 2001-2021 Free Software Foundation, Inc.
@@ -29,6 +29,15 @@
;;; Code:
+(defgroup life nil
+ "Conway's Game of Life."
+ :group 'games)
+
+(defcustom life-step-time 0.5
+ "Time to sleep between steps (generations)."
+ :type 'number
+ :version "28.1")
+
(defvar life-patterns
[("@@@" " @@" "@@@")
("@@@ @@@" "@@ @@ " "@@@ @@@")
@@ -54,6 +63,7 @@
" @@")
("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@"
"@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")
+ ;; Glider Gun (infinite, Bill Gosper, 1970)
(" @ "
" @ @ "
" @@ @@ @@"
@@ -74,7 +84,26 @@
" @@"
" @@ @"
"@ @ @")
- ("@@@@@@@@ @@@@@ @@@ @@@@@@@ @@@@@")]
+ ("@@@@@@@@ @@@@@ @@@ @@@@@@@ @@@@@")
+ ;; Pentadecathlon (period 15, John Conway, 1970)
+ (" @ @ "
+ "@@ @@@@ @@"
+ " @ @ ")
+ ;; Queen Bee Shuttle (period 30, Bill Gosper, 1970)
+ (" @ "
+ " @ @ "
+ " @ @ "
+ "@@ @ @ @@"
+ "@@ @ @ @@"
+ " @ @ "
+ " @ ")
+ ;; 2x Figure eight (period 8, Simon Norton, 1970)
+ ("@@@ @@@ "
+ "@@@ @@@ "
+ "@@@ @@@ "
+ " @@@ @@@"
+ " @@@ @@@"
+ " @@@ @@@")]
"Vector of rectangles containing some Life startup patterns.")
;; Macros are used macros for manifest constants instead of variables
@@ -106,28 +135,45 @@
;; (scroll-up) and (scroll-down) when trying to center the display.
(defvar life-window-start nil)
+(defvar life--max-width nil
+ "If non-nil, restrict width to this positive integer. ")
+
+(defvar life--max-height nil
+ "If non-nil, restrict height to this positive integer. ")
+
;; For mode line
(defvar life-current-generation nil)
;; Sadly, mode-line-format won't display numbers.
(defvar life-generation-string nil)
+(defun life--tick ()
+ "Game tick for `life'."
+ (let ((inhibit-quit t)
+ (inhibit-read-only t))
+ (life-grim-reaper)
+ (life-expand-plane-if-needed)
+ (life-increment-generation)))
+
;;;###autoload
-(defun life (&optional sleeptime)
+(defun life (&optional step-time)
"Run Conway's Life simulation.
-The starting pattern is randomly selected. Prefix arg (optional first
-arg non-nil from a program) is the number of seconds to sleep between
-generations (this defaults to 1)."
- (interactive "p")
- (or sleeptime (setq sleeptime 1))
+The starting pattern is randomly selected from `life-patterns'.
+
+Prefix arg is the number of tenths of a second to sleep between
+generations (the default is `life-step-time').
+
+When called from Lisp, optional argument STEP-TIME is the time to
+sleep in seconds."
+ (interactive "P")
+ (setq step-time (or (and step-time (/ (if (consp step-time)
+ (car step-time)
+ step-time) 10.0))
+ life-step-time))
(life-setup)
(catch 'life-exit
(while t
- (let ((inhibit-quit t)
- (inhibit-read-only t))
- (life-display-generation sleeptime)
- (life-grim-reaper)
- (life-expand-plane-if-needed)
- (life-increment-generation)))))
+ (life-display-generation step-time)
+ (life--tick))))
(define-derived-mode life-mode special-mode "Life"
"Major mode for the buffer of `life'."
@@ -138,16 +184,17 @@ generations (this defaults to 1)."
(setq-local life-generation-string "0")
(setq-local mode-line-buffer-identification '("Life: generation "
life-generation-string))
- (setq-local fill-column (1- (window-width)))
+ (setq-local fill-column (min (or life--max-width most-positive-fixnum)
+ (1- (window-width))))
(setq-local life-window-start 1)
(buffer-disable-undo))
(defun life-setup ()
(switch-to-buffer (get-buffer-create "*Life*") t)
- (erase-buffer)
- (life-mode)
;; stuff in the random pattern
(let ((inhibit-read-only t))
+ (erase-buffer)
+ (life-mode)
(life-insert-random-pattern)
;; make sure (life-life-char) is used throughout
(goto-char (point-min))
@@ -160,7 +207,8 @@ generations (this defaults to 1)."
(indent-to n)
(forward-line)))
;; center the pattern vertically
- (let ((n (/ (- (1- (window-height))
+ (let ((n (/ (- (min (or life--max-height most-positive-fixnum)
+ (1- (window-height)))
(count-lines (point-min) (point-max)))
2)))
(goto-char (point-min))
@@ -276,12 +324,12 @@ generations (this defaults to 1)."
(insert ?\n)
(setq life-window-start (+ life-window-start fill-column 1)))))
-(defun life-display-generation (sleeptime)
+(defun life-display-generation (step-time)
(goto-char life-window-start)
(recenter 0)
;; Redisplay; if the user has hit a key, exit the loop.
- (or (and (sit-for sleeptime) (< 0 sleeptime))
+ (or (and (sit-for step-time) (< 0 step-time))
(not (input-pending-p))
(throw 'life-exit nil)))
diff --git a/lisp/play/morse.el b/lisp/play/morse.el
index 8e09c225059..bfb25ba1d56 100644
--- a/lisp/play/morse.el
+++ b/lisp/play/morse.el
@@ -79,17 +79,16 @@
("8" . "---..")
("9" . "----.")
;; Non-ASCII
- ("Ä" . ".-.-")
- ("Æ" . ".-.-")
- ("Ã" . ".--.-")
- ("Ã…" . ".--.-")
- ;; ligature character?? ("Ch" . "----")
- ("ß" . ".../...")
- ("É" . "..-..")
- ("Ñ" . "--.--")
- ("Ö" . "---.")
- ("Ø" . "---.")
- ("Ü" . "..--")
+ ("ä" . ".-.-")
+ ("æ" . ".-.-")
+ ("á" . ".--.-")
+ ("Ã¥" . ".--.-")
+ ("ß" . ".../...") ; also ...--..
+ ("é" . "..-..")
+ ("ñ" . "--.--")
+ ("ö" . "---.")
+ ("ø" . "---.")
+ ("ü" . "..--")
;; Recently standardized
("@" . ".--.-."))
"Morse code character set.")
@@ -146,7 +145,7 @@
"NATO phonetic alphabet.
See “International Code of Signals†(INTERCO), United States
Edition, 1969 Edition (Revised 2003) available from National
-Geospatial-Intelligence Agency at URL `http://www.nga.mil/'")
+Geospatial-Intelligence Agency at URL `https://www.nga.mil/'")
;;;###autoload
(defun morse-region (beg end)
@@ -165,7 +164,7 @@ Geospatial-Intelligence Agency at URL `http://www.nga.mil/'")
(setq sep ""))
((setq morse (assoc str morse-code))
(delete-char 1)
- (insert sep (cdr morse))
+ (insert-before-markers sep (cdr morse))
(setq sep "/"))
(t
(forward-char 1)
@@ -211,7 +210,7 @@ Geospatial-Intelligence Agency at URL `http://www.nga.mil/'")
(setq sep ""))
((setq nato (assoc str nato-alphabet))
(delete-char 1)
- (insert sep (cdr nato))
+ (insert-before-markers sep (cdr nato))
(setq sep "-"))
(t
(forward-char 1)
diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el
index 7fff604aead..838bddfb665 100644
--- a/lisp/play/mpuz.el
+++ b/lisp/play/mpuz.el
@@ -1,4 +1,4 @@
-;;; mpuz.el --- multiplication puzzle for GNU Emacs
+;;; mpuz.el --- multiplication puzzle for GNU Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1990, 2001-2021 Free Software Foundation, Inc.
@@ -40,49 +40,41 @@
The value t means never ding, and `error' means only ding on wrong input."
:type '(choice (const :tag "No" nil)
(const :tag "Yes" t)
- (const :tag "If correct" error))
- :group 'mpuz)
+ (const :tag "If correct" error)))
(defcustom mpuz-solve-when-trivial t
"Solve any row that can be trivially calculated from what you've found."
- :type 'boolean
- :group 'mpuz)
+ :type 'boolean)
(defcustom mpuz-allow-double-multiplicator nil
"Allow 2nd factors like 33 or 77."
- :type 'boolean
- :group 'mpuz)
+ :type 'boolean)
(defface mpuz-unsolved
'((default :weight bold)
(((class color)) :foreground "red1"))
- "Face for letters to be solved."
- :group 'mpuz)
+ "Face for letters to be solved.")
(defface mpuz-solved
'((default :weight bold)
(((class color)) :foreground "green1"))
- "Face for solved digits."
- :group 'mpuz)
+ "Face for solved digits.")
(defface mpuz-trivial
'((default :weight bold)
(((class color)) :foreground "blue"))
- "Face for trivial digits solved for you."
- :group 'mpuz)
+ "Face for trivial digits solved for you.")
(defface mpuz-text
'((t :inherit variable-pitch))
- "Face for text on right."
- :group 'mpuz)
+ "Face for text on right.")
;; Mpuz mode and keymaps
;;----------------------
(defcustom mpuz-mode-hook nil
"Hook to run upon entry to mpuz."
- :type 'hook
- :group 'mpuz)
+ :type 'hook)
(defvar mpuz-mode-map
(let ((map (make-sparse-keymap)))
@@ -341,8 +333,8 @@ You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]."
(defun mpuz-switch-to-window ()
"Find or create the Mult-Puzzle buffer, and display it."
- (let ((buf (mpuz-get-buffer)))
- (or buf (setq buf (mpuz-create-buffer)))
+ (let ((buf (or (mpuz-get-buffer)
+ (mpuz-create-buffer))))
(switch-to-buffer buf)
(setq buffer-read-only t)
(mpuz-mode)))
diff --git a/lisp/play/pong.el b/lisp/play/pong.el
index 70774e95bb2..b73dbc1010e 100644
--- a/lisp/play/pong.el
+++ b/lisp/play/pong.el
@@ -1,4 +1,4 @@
-;;; pong.el --- classical implementation of pong
+;;; pong.el --- classical implementation of pong -*- lexical-binding:t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -33,88 +33,72 @@
;;; Customization
(defgroup pong nil
- "Emacs-Lisp implementation of the classical game pong."
+ "Emacs Lisp implementation of the classical game pong."
:tag "Pong"
:group 'games)
(defcustom pong-buffer-name "*Pong*"
"Name of the buffer used to play."
- :group 'pong
:type '(string))
(defcustom pong-width 50
"Width of the playfield."
- :group 'pong
:type '(integer))
(defcustom pong-height (min 30 (- (frame-height) 6))
"Height of the playfield."
- :group 'pong
:type '(integer))
(defcustom pong-bat-width 3
"Width of the bats for pong."
- :group 'pong
:type '(integer))
(defcustom pong-blank-color "black"
"Color used for background."
- :group 'pong
:type 'color)
(defcustom pong-bat-color "yellow"
"Color used for bats."
- :group 'pong
:type 'color)
(defcustom pong-ball-color "red"
"Color used for the ball."
- :group 'pong
:type 'color)
(defcustom pong-border-color "white"
"Color used for pong borders."
- :group 'pong
:type 'color)
(defcustom pong-left-key "4"
"Alternate key to press for bat 1 to go up (primary one is [left])."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-right-key "6"
"Alternate key to press for bat 1 to go down (primary one is [right])."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-up-key "8"
"Alternate key to press for bat 2 to go up (primary one is [up])."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-down-key "2"
"Alternate key to press for bat 2 to go down (primary one is [down])."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-quit-key "q"
"Key to press to quit pong."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-pause-key "p"
"Key to press to pause pong."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-resume-key "p"
"Key to press to resume pong."
- :group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-timer-delay 0.1
"Time to wait between every cycle."
- :group 'pong
:type 'number)
diff --git a/lisp/play/snake.el b/lisp/play/snake.el
index 20fbabc72b9..29effa23460 100644
--- a/lisp/play/snake.el
+++ b/lisp/play/snake.el
@@ -1,4 +1,4 @@
-;;; snake.el --- implementation of Snake for Emacs
+;;; snake.el --- implementation of Snake for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -140,14 +140,14 @@
;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar snake-length 0)
-(defvar snake-velocity-x 1)
-(defvar snake-velocity-y 0)
-(defvar snake-positions nil)
-(defvar snake-score 0)
-(defvar snake-paused nil)
-(defvar snake-moved-p nil)
-(defvar snake-velocity-queue nil
+(defvar-local snake-length 0)
+(defvar-local snake-velocity-x 1)
+(defvar-local snake-velocity-y 0)
+(defvar-local snake-positions nil)
+(defvar-local snake-score 0)
+(defvar-local snake-paused nil)
+(defvar-local snake-moved-p nil)
+(defvar-local snake-velocity-queue nil
"This queue stores the velocities requested too quickly by user.
They will take effect one at a time at each clock-interval.
This is necessary for proper behavior.
@@ -158,16 +158,6 @@ we implemented all your keystrokes immediately, the snake would
effectively never move up. Thus, we need to move it up for one turn
and then start moving it leftwards.")
-
-(make-variable-buffer-local 'snake-length)
-(make-variable-buffer-local 'snake-velocity-x)
-(make-variable-buffer-local 'snake-velocity-y)
-(make-variable-buffer-local 'snake-positions)
-(make-variable-buffer-local 'snake-score)
-(make-variable-buffer-local 'snake-paused)
-(make-variable-buffer-local 'snake-moved-p)
-(make-variable-buffer-local 'snake-velocity-queue)
-
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar snake-mode-map
@@ -192,6 +182,7 @@ and then start moving it leftwards.")
(defvar snake-null-map
(let ((map (make-sparse-keymap 'snake-null-map)))
(define-key map "n" 'snake-start-game)
+ (define-key map "q" 'quit-window)
map)
"Keymap for finished Snake games.")
@@ -278,7 +269,7 @@ and then start moving it leftwards.")
snake-velocity-queue nil)
(let ((x snake-initial-x)
(y snake-initial-y))
- (dotimes (i snake-length)
+ (dotimes (_ snake-length)
(gamegrid-set-cell x y snake-snake)
(setq snake-positions (cons (vector x y) snake-positions))
(cl-incf x snake-velocity-x)
@@ -345,38 +336,38 @@ Argument SNAKE-BUFFER is the name of the buffer."
(defun snake-move-left ()
"Make the snake move left."
- (interactive)
+ (interactive nil snake-mode)
(when (zerop (snake-final-x-velocity))
(push '(-1 0) snake-velocity-queue)))
(defun snake-move-right ()
"Make the snake move right."
- (interactive)
+ (interactive nil snake-mode)
(when (zerop (snake-final-x-velocity))
(push '(1 0) snake-velocity-queue)))
(defun snake-move-up ()
"Make the snake move up."
- (interactive)
+ (interactive nil snake-mode)
(when (zerop (snake-final-y-velocity))
(push '(0 -1) snake-velocity-queue)))
(defun snake-move-down ()
"Make the snake move down."
- (interactive)
+ (interactive nil snake-mode)
(when (zerop (snake-final-y-velocity))
(push '(0 1) snake-velocity-queue)))
(defun snake-end-game ()
"Terminate the current game."
- (interactive)
+ (interactive nil snake-mode)
(gamegrid-kill-timer)
(use-local-map snake-null-map)
(gamegrid-add-score snake-score-file snake-score))
(defun snake-start-game ()
"Start a new game of Snake."
- (interactive)
+ (interactive nil snake-mode)
(snake-reset-game)
(snake-set-dot)
(use-local-map snake-mode-map)
@@ -384,7 +375,7 @@ Argument SNAKE-BUFFER is the name of the buffer."
(defun snake-pause-game ()
"Pause (or resume) the current game."
- (interactive)
+ (interactive nil snake-mode)
(setq snake-paused (not snake-paused))
(message (and snake-paused "Game paused (press p to resume)")))
@@ -395,6 +386,7 @@ Argument SNAKE-BUFFER is the name of the buffer."
(define-derived-mode snake-mode special-mode "Snake"
"A mode for playing Snake."
+ :interactive nil
(add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
diff --git a/lisp/play/solitaire.el b/lisp/play/solitaire.el
index 1be8cb6c697..e74ba98ca1b 100644
--- a/lisp/play/solitaire.el
+++ b/lisp/play/solitaire.el
@@ -1,4 +1,4 @@
-;;; solitaire.el --- game of solitaire in Emacs Lisp
+;;; solitaire.el --- game of solitaire in Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
@@ -38,8 +38,7 @@
(defcustom solitaire-mode-hook nil
"Hook to run upon entry to Solitaire."
- :type 'hook
- :group 'solitaire)
+ :type 'hook)
(defvar solitaire-mode-map
(let ((map (make-sparse-keymap)))
@@ -119,8 +118,7 @@ The usual mnemonic keys move the cursor around the board; in addition,
"Non-nil means check for possible moves after each major change.
This takes a while, so switch this on if you like to be informed when
the game is over, or off, if you are working on a slow machine."
- :type 'boolean
- :group 'solitaire)
+ :type 'boolean)
(defconst solitaire-valid-directions
'(solitaire-left solitaire-right solitaire-up solitaire-down))
diff --git a/lisp/play/spook.el b/lisp/play/spook.el
index d279aaee714..d0669eb1f46 100644
--- a/lisp/play/spook.el
+++ b/lisp/play/spook.el
@@ -1,4 +1,4 @@
-;;; spook.el --- spook phrase utility for overloading the NSA line eater
+;;; spook.el --- spook phrase utility for overloading the NSA line eater -*- lexical-binding:t -*-
;; Copyright (C) 1988, 1993, 2001-2021 Free Software Foundation, Inc.
@@ -45,13 +45,11 @@
(defcustom spook-phrases-file (expand-file-name "spook.lines" data-directory)
"Keep your favorite phrases here."
- :type 'file
- :group 'spook)
+ :type 'file)
(defcustom spook-phrase-default-count 15
"Default number of phrases to insert."
- :type 'integer
- :group 'spook)
+ :type 'integer)
;;;###autoload
(defun spook ()
diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el
index 89ad7c08fd4..f43aa47326f 100644
--- a/lisp/play/tetris.el
+++ b/lisp/play/tetris.el
@@ -1,9 +1,9 @@
-;;; tetris.el --- implementation of Tetris for Emacs
+;;; tetris.el --- implementation of Tetris for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Author: Glynn Clements <glynn@sensei.co.uk>
-;; Version: 2.01
+;; Old-Version: 2.01
;; Created: 1997-08-13
;; Keywords: games
@@ -39,22 +39,18 @@
(defcustom tetris-use-glyphs t
"Non-nil means use glyphs when available."
- :group 'tetris
:type 'boolean)
(defcustom tetris-use-color t
"Non-nil means use color when available."
- :group 'tetris
:type 'boolean)
(defcustom tetris-draw-border-with-glyphs t
"Non-nil means draw a border even when using glyphs."
- :group 'tetris
:type 'boolean)
(defcustom tetris-default-tick-period 0.3
"The default time taken for a shape to drop one row."
- :group 'tetris
:type 'number)
(defcustom tetris-update-speed-function
@@ -65,18 +61,15 @@ 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
:type 'function)
(defcustom tetris-mode-hook nil
"Hook run upon starting Tetris."
- :group 'tetris
:type 'hook)
(defcustom tetris-tty-colors
["blue" "white" "yellow" "magenta" "cyan" "green" "red"]
"Vector of colors of the various shapes in text mode."
- :group 'tetris
:type '(vector (color :tag "Shape 1")
(color :tag "Shape 2")
(color :tag "Shape 3")
@@ -88,7 +81,6 @@ If the return value is a number, it is used as the timer period."
(defcustom tetris-x-colors
[[0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
"Vector of RGB colors of the various shapes."
- :group 'tetris
:type '(vector (vector :tag "Shape 1" number number number)
(vector :tag "Shape 2" number number number)
(vector :tag "Shape 3" number number number)
@@ -99,37 +91,30 @@ If the return value is a number, it is used as the timer period."
(defcustom tetris-buffer-name "*Tetris*"
"Name used for Tetris buffer."
- :group 'tetris
:type 'string)
(defcustom tetris-buffer-width 30
"Width of used portion of buffer."
- :group 'tetris
:type 'number)
(defcustom tetris-buffer-height 22
"Height of used portion of buffer."
- :group 'tetris
:type 'number)
(defcustom tetris-width 10
"Width of playing area."
- :group 'tetris
:type 'number)
(defcustom tetris-height 20
"Height of playing area."
- :group 'tetris
:type 'number)
(defcustom tetris-top-left-x 3
"X position of top left of playing area."
- :group 'tetris
:type 'number)
(defcustom tetris-top-left-y 1
"Y position of top left of playing area."
- :group 'tetris
:type 'number)
(defvar tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width)
@@ -239,25 +224,15 @@ each one of its four blocks.")
;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar tetris-shape 0)
-(defvar tetris-rot 0)
-(defvar tetris-next-shape 0)
-(defvar tetris-n-shapes 0)
-(defvar tetris-n-rows 0)
-(defvar tetris-score 0)
-(defvar tetris-pos-x 0)
-(defvar tetris-pos-y 0)
-(defvar tetris-paused nil)
-
-(make-variable-buffer-local 'tetris-shape)
-(make-variable-buffer-local 'tetris-rot)
-(make-variable-buffer-local 'tetris-next-shape)
-(make-variable-buffer-local 'tetris-n-shapes)
-(make-variable-buffer-local 'tetris-n-rows)
-(make-variable-buffer-local 'tetris-score)
-(make-variable-buffer-local 'tetris-pos-x)
-(make-variable-buffer-local 'tetris-pos-y)
-(make-variable-buffer-local 'tetris-paused)
+(defvar-local tetris-shape 0)
+(defvar-local tetris-rot 0)
+(defvar-local tetris-next-shape 0)
+(defvar-local tetris-n-shapes 0)
+(defvar-local tetris-n-rows 0)
+(defvar-local tetris-score 0)
+(defvar-local tetris-pos-x 0)
+(defvar-local tetris-pos-y 0)
+(defvar-local tetris-paused nil)
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -335,11 +310,10 @@ each one of its four blocks.")
options))
(defun tetris-get-tick-period ()
- (if (boundp 'tetris-update-speed-function)
- (let ((period (apply tetris-update-speed-function
- tetris-n-shapes
- tetris-n-rows nil)))
- (and (numberp period) period))))
+ (let ((period (apply tetris-update-speed-function
+ tetris-n-shapes
+ tetris-n-rows nil)))
+ (and (numberp period) period)))
(defun tetris-get-shape-cell (block)
(aref (aref (aref tetris-shapes
@@ -532,7 +506,7 @@ Drops the shape one square, testing for collision."
(defun tetris-move-bottom ()
"Drop the shape to the bottom of the playing area."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(let ((hit nil))
(tetris-erase-shape)
@@ -545,7 +519,7 @@ Drops the shape one square, testing for collision."
(defun tetris-move-left ()
"Move the shape one square to the left."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(tetris-erase-shape)
(setq tetris-pos-x (1- tetris-pos-x))
@@ -555,7 +529,7 @@ Drops the shape one square, testing for collision."
(defun tetris-move-right ()
"Move the shape one square to the right."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(tetris-erase-shape)
(setq tetris-pos-x (1+ tetris-pos-x))
@@ -565,7 +539,7 @@ Drops the shape one square, testing for collision."
(defun tetris-move-down ()
"Move the shape one square to the bottom."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(tetris-erase-shape)
(setq tetris-pos-y (1+ tetris-pos-y))
@@ -575,7 +549,7 @@ Drops the shape one square, testing for collision."
(defun tetris-rotate-prev ()
"Rotate the shape clockwise."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(tetris-erase-shape)
(setq tetris-rot (% (+ 1 tetris-rot)
@@ -587,7 +561,7 @@ Drops the shape one square, testing for collision."
(defun tetris-rotate-next ()
"Rotate the shape anticlockwise."
- (interactive)
+ (interactive nil tetris-mode)
(unless tetris-paused
(tetris-erase-shape)
(setq tetris-rot (% (+ 3 tetris-rot)
@@ -599,14 +573,14 @@ Drops the shape one square, testing for collision."
(defun tetris-end-game ()
"Terminate the current game."
- (interactive)
+ (interactive nil tetris-mode)
(gamegrid-kill-timer)
(use-local-map tetris-null-map)
(gamegrid-add-score tetris-score-file tetris-score))
(defun tetris-start-game ()
"Start a new game of Tetris."
- (interactive)
+ (interactive nil tetris-mode)
(tetris-reset-game)
(use-local-map tetris-mode-map)
(let ((period (or (tetris-get-tick-period)
@@ -615,7 +589,7 @@ Drops the shape one square, testing for collision."
(defun tetris-pause-game ()
"Pause (or resume) the current game."
- (interactive)
+ (interactive nil tetris-mode)
(setq tetris-paused (not tetris-paused))
(message (and tetris-paused "Game paused (press p to resume)")))
@@ -626,6 +600,7 @@ Drops the shape one square, testing for collision."
(define-derived-mode tetris-mode nil "Tetris"
"A mode for playing Tetris."
+ :interactive nil
(add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
@@ -646,17 +621,15 @@ rotate the shape to fit in with those at the bottom of the screen so
as to form complete rows.
tetris-mode keybindings:
- \\<tetris-mode-map>
-\\[tetris-start-game] Starts a new game of Tetris
-\\[tetris-end-game] Terminates the current game
-\\[tetris-pause-game] Pauses (or resumes) the current game
-\\[tetris-move-left] Moves the shape one square to the left
-\\[tetris-move-right] Moves the shape one square to the right
-\\[tetris-rotate-prev] Rotates the shape clockwise
-\\[tetris-rotate-next] Rotates the shape anticlockwise
-\\[tetris-move-bottom] Drops the shape to the bottom of the playing area
-
-"
+\\<tetris-mode-map>
+\\[tetris-start-game] Start a new game of Tetris
+\\[tetris-end-game] Terminate the current game
+\\[tetris-pause-game] Pause (or resume) the current game
+\\[tetris-move-left] Move the shape one square to the left
+\\[tetris-move-right] Move the shape one square to the right
+\\[tetris-rotate-prev] Rotate the shape clockwise
+\\[tetris-rotate-next] Rotate the shape anticlockwise
+\\[tetris-move-bottom] Drop the shape to the bottom of the playing area"
(interactive)
(select-window (or (get-buffer-window tetris-buffer-name)
diff --git a/lisp/play/zone.el b/lisp/play/zone.el
index 70b6a01a017..19e4e399ff3 100644
--- a/lisp/play/zone.el
+++ b/lisp/play/zone.el
@@ -1,4 +1,4 @@
-;;; zone.el --- idle display hacks
+;;; zone.el --- idle display hacks -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -128,14 +128,17 @@ If the element is a function or a list of a function and a number,
(let ((pgm (elt zone-programs (random (length zone-programs))))
(ct (and f (frame-parameter f 'cursor-type)))
(show-trailing-whitespace nil)
- (restore (list '(kill-buffer outbuf))))
+ restore)
(when ct
- (modify-frame-parameters f '((cursor-type . (bar . 0))))
- (setq restore (cons '(modify-frame-parameters
- f (list (cons 'cursor-type ct)))
- restore)))
+ (modify-frame-parameters f '((cursor-type . (bar . 0)))))
;; Make `restore' a self-disabling one-shot thunk.
- (setq restore `(lambda () ,@restore (setq restore nil)))
+ (setq restore
+ (lambda ()
+ (when ct
+ (modify-frame-parameters
+ f (list (cons 'cursor-type ct))))
+ (kill-buffer outbuf)
+ (setq restore nil)))
(condition-case nil
(progn
(message "Zoning... (%s)" pgm)
@@ -419,7 +422,7 @@ If the element is a function or a list of a function and a number,
(defsubst zone-replace-char (count del-count char-as-string new-value)
(delete-char (or del-count (- count)))
(aset char-as-string 0 new-value)
- (dotimes (i count) (insert char-as-string)))
+ (dotimes (_ count) (insert char-as-string)))
(defsubst zone-park/sit-for (pos seconds)
(let ((p (point)))
@@ -460,7 +463,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"))
- (dotimes (i nl)
+ (dotimes (_ nl)
(insert line))))
(goto-char start)
(recenter 0)
diff --git a/lisp/plstore.el b/lisp/plstore.el
index 46533664d52..4ca5886bf15 100644
--- a/lisp/plstore.el
+++ b/lisp/plstore.el
@@ -1,4 +1,5 @@
;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
+
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@gnu.org>
@@ -19,7 +20,7 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;; Commentary
+;;; Commentary:
;; Plist based data store providing search and partial encryption.
;;
diff --git a/lisp/printing.el b/lisp/printing.el
index 0cd11482106..e7aab901d53 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; Version: 6.9.3
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
(defconst pr-version "6.9.3"
"printing.el, v 6.9.3 <2007/12/09 vinicius>
@@ -64,7 +64,7 @@ Please send all bug fixes and enhancements to
;; interface to ps-print package and it also provides some extra stuff.
;;
;; To download the latest ps-print package see
-;; `http://www.emacswiki.org/cgi-bin/wiki/PsPrintPackage'.
+;; `https://www.emacswiki.org/cgi-bin/wiki/PsPrintPackage'.
;; Please, see README file for ps-print installation instructions.
;;
;; `printing' was inspired by:
@@ -103,14 +103,14 @@ Please send all bug fixes and enhancements to
;; For example, after previewing a PostScript file, *Printing Command Output*
;; will have the following entry:
;;
-;; /usr/X11R6/bin/gv ("/home/user/example/file.ps")
+;; /usr/bin/gv ("/home/user/example/file.ps")
;; Exit status: 0
;;
;; In the example above, the previewing was successful. If during previewing,
;; you quit gv execution (by typing C-g during Emacs session), the log entry
;; would be:
;;
-;; /usr/X11R6/bin/gv ("/home/user/example/file.ps")
+;; /usr/bin/gv ("/home/user/example/file.ps")
;; Exit status: Quit
;;
;; So, if something goes wrong, a good place to take a look is the buffer
@@ -264,7 +264,7 @@ Please send all bug fixes and enhancements to
;; Also the gsprint utility comes together with gsview distribution.
;;
;; For more information about gsprint see
-;; `http://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'.
+;; `https://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'.
;;
;; As an example of gsprint declaration:
;;
@@ -944,24 +944,24 @@ Please send all bug fixes and enhancements to
;;
;; * For `printing' package:
;;
-;; printing `http://www.emacswiki.org/cgi-bin/emacs/download/printing.el'
-;; ps-print `http://www.emacswiki.org/cgi-bin/wiki/PsPrintPackage'
+;; printing `https://www.emacswiki.org/cgi-bin/emacs/download/printing.el'
+;; ps-print `https://www.emacswiki.org/cgi-bin/wiki/PsPrintPackage'
;;
;; * For GNU or Unix system:
;;
;; gs, gv `https://www.gnu.org/software/ghostscript/ghostscript.html'
-;; enscript `http://people.ssh.fi/mtr/genscript/'
+;; enscript `https://people.ssh.fi/mtr/genscript/'
;; psnup `http://www.knackered.org/angus/psutils/'
-;; mpage `http://www.mesa.nl/pub/mpage/'
+;; mpage `https://www.mesa.nl/pub/mpage/'
;;
;; * For Windows system:
;;
;; gswin32, gsview32
;; `https://www.gnu.org/software/ghostscript/ghostscript.html'
-;; gsprint `http://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'.
-;; enscript `http://people.ssh.fi/mtr/genscript/'
+;; gsprint `https://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'.
+;; enscript `https://people.ssh.fi/mtr/genscript/'
;; psnup `http://gnuwin32.sourceforge.net/packages/psutils.htm'
-;; redmon `http://www.cs.wisc.edu/~ghost/redmon/'
+;; redmon `http://www.ghostgum.com.au/software/redmon.htm'
;;
;;
;; Acknowledgments
@@ -1014,7 +1014,6 @@ Please send all bug fixes and enhancements to
(require 'lpr)
(require 'ps-print)
-(require 'easymenu)
(and (string< ps-print-version "6.6.4")
(error "`printing' requires `ps-print' package version 6.6.4 or later"))
@@ -1082,24 +1081,15 @@ Used by `pr-menu-bind' and `pr-update-menus'.")
"Specify Printing menu-bar entry.")
(defun pr-global-menubar (menu-spec)
- (let ((menu-file '("menu-bar" "file")))
- (cond
- (pr-menu-print-item
- (easy-menu-add-item global-map menu-file
- (easy-menu-create-menu "Print" menu-spec)
- "print-buffer")
- (dolist (item '("print-buffer" "print-region"
- "ps-print-buffer-faces" "ps-print-region-faces"
- "ps-print-buffer" "ps-print-region"))
- (easy-menu-remove-item global-map menu-file item))
- (setq pr-menu-print-item nil
- pr-menu-bar (vector 'menu-bar
- (easy-menu-intern (nth 1 menu-file))
- (easy-menu-intern "Print"))))
- (t
- (easy-menu-add-item global-map menu-file
- (easy-menu-create-menu "Print" menu-spec)))
- )))
+ (let ((menu-file '("menu-bar" "file"))
+ (submenu-path [menu-bar file Print])
+ (submenu (easy-menu-create-menu "Print" menu-spec)))
+ (cond (pr-menu-print-item
+ (easy-menu-add-item global-map menu-file submenu "Print")
+ (easy-menu-remove-item global-map menu-file "print")
+ (setq pr-menu-print-item nil
+ pr-menu-bar submenu-path))
+ (t (easy-menu-add-item global-map menu-file submenu)))))
(defun pr-menu-position (entry index horizontal)
(let ((pos (cdr (mouse-pixel-position))))
@@ -1521,22 +1511,19 @@ Examples:
Useful links:
* Information about the print command (print.exe)
- `http://www.computerhope.com/printhlp.htm'
+ `https://www.computerhope.com/printhlp.htm'
* RedMon - Redirection Port Monitor (redpr.exe)
- `http://www.cs.wisc.edu/~ghost/redmon/index.htm'
+ `http://www.ghostgum.com.au/software/redmon.htm'
* Redirection Port Monitor (redpr.exe on-line help)
- `http://www.cs.wisc.edu/~ghost/redmon/en/redmon.htm'
+ `https://www.cs.wisc.edu/~ghost/redmon/en/redmon.htm'
* UNIX man pages: lpr (or type `man lpr')
- `http://bama.ua.edu/cgi-bin/man-cgi?lpr'
- `http://www.mediacollege.com/cgi-bin/man/page.cgi?section=all&topic=lpr'
+ `https://linux.die.net/man/1/lpr-cups'
* UNIX man pages: lp (or type `man lp')
- `http://bama.ua.edu/cgi-bin/man-cgi?lp'
- `http://www.mediacollege.com/cgi-bin/man/page.cgi?section=all&topic=lp'
-"
+ `https://linux.die.net/man/1/lp'"
:type '(repeat
(list :tag "Text Printer"
(symbol :tag "Printer Symbol Name")
@@ -1761,30 +1748,28 @@ are not printed.
Useful links:
* GSPRINT - Ghostscript print to Windows printer
- `http://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'
+ `https://www.cs.wisc.edu/~ghost/gsview/gsprint.htm'
* Introduction to Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/intro.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/intro.htm'
* How to use Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
* Information about the print command (print.exe)
- `http://www.computerhope.com/printhlp.htm'
+ `https://www.computerhope.com/printhlp.htm'
* RedMon - Redirection Port Monitor (redpr.exe)
- `http://www.cs.wisc.edu/~ghost/redmon/index.htm'
+ `http://www.ghostgum.com.au/software/redmon.htm'
* Redirection Port Monitor (redpr.exe on-line help)
- `http://www.cs.wisc.edu/~ghost/redmon/en/redmon.htm'
+ `https://www.cs.wisc.edu/~ghost/redmon/en/redmon.htm'
* UNIX man pages: lpr (or type `man lpr')
- `http://bama.ua.edu/cgi-bin/man-cgi?lpr'
- `http://www.mediacollege.com/cgi-bin/man/page.cgi?section=all&topic=lpr'
+ `https://linux.die.net/man/1/lpr-cups'
* UNIX man pages: lp (or type `man lp')
- `http://bama.ua.edu/cgi-bin/man-cgi?lp'
- `http://www.mediacollege.com/cgi-bin/man/page.cgi?section=all&topic=lp'
+ `https://linux.die.net/man/1/lp'
* GNU utilities for w32 (cp.exe)
`http://unxutils.sourceforge.net/'
@@ -1874,28 +1859,28 @@ Useful links:
`https://www.gnu.org/software/gv/manual/gv.html'
* GSview Help
- `http://www.cs.wisc.edu/~ghost/gsview/gsviewen.htm'
+ `https://www.cs.wisc.edu/~ghost/gsview/gsviewen.htm'
* GSview Help - Common Problems
- `http://www.cs.wisc.edu/~ghost/gsview/gsviewen.htm#Common_Problems'
+ `https://www.cs.wisc.edu/~ghost/gsview/gsviewen.htm#Common_Problems'
* GSview Readme (compilation & installation)
- `http://www.cs.wisc.edu/~ghost/gsview/Readme.htm'
+ `https://www.cs.wisc.edu/~ghost/gsview/Readme.htm'
* GSview (main site)
- `http://www.cs.wisc.edu/~ghost/gsview/index.htm'
+ `https://www.cs.wisc.edu/~ghost/gsview/index.htm'
* Ghostscript, Ghostview and GSview
- `http://www.cs.wisc.edu/~ghost/'
+ `https://www.cs.wisc.edu/~ghost/'
* Ghostview
- `http://www.cs.wisc.edu/~ghost/gv/index.htm'
+ `https://www.cs.wisc.edu/~ghost/gv/index.htm'
* gv 3.5, June 1997
- `http://www.cs.wisc.edu/~ghost/gv/gv_doc/gv.html'
+ `http://pages.cs.wisc.edu/~ghost/gv/gv_doc/gv.html'
* MacGSView (Mac OS)
- `http://www.cs.wisc.edu/~ghost/macos/index.htm'
+ `http://pages.cs.wisc.edu/~ghost/macos/index.htm'
"
:type '(string :tag "Ghostview Utility"))
@@ -1911,16 +1896,16 @@ See also `pr-path-alist'.
Useful links:
* Ghostscript, Ghostview and GSview
- `http://www.cs.wisc.edu/~ghost/'
+ `https://www.cs.wisc.edu/~ghost/'
* Introduction to Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/intro.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/intro.htm'
* How to use Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
* Printer compatibility
- `http://www.cs.wisc.edu/~ghost/doc/printer.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/printer.htm'
"
:type '(string :tag "Ghostscript Utility"))
@@ -1955,13 +1940,13 @@ To see ghostscript documentation for more information:
Useful links:
* Introduction to Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/intro.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/intro.htm'
* How to use Ghostscript
- `http://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/cvs/Use.htm'
* Printer compatibility
- `http://www.cs.wisc.edu/~ghost/doc/printer.htm'
+ `https://www.cs.wisc.edu/~ghost/doc/printer.htm'
"
:type '(repeat (string :tag "Ghostscript Switch")))
@@ -2408,11 +2393,10 @@ Examples:
Useful links:
* mpage download (GNU or Unix)
- `http://www.mesa.nl/pub/mpage/'
+ `https://www.mesa.nl/pub/mpage/'
* mpage documentation (GNU or Unix - or type `man mpage')
- `http://www.cs.umd.edu/faq/guides/manual_unix/node48.html'
- `http://www.rt.com/man/mpage.1.html'
+ `https://linux.die.net/man/1/mpage'
* psnup (Windows, GNU or Unix)
`http://www.knackered.org/angus/psutils/'
@@ -2422,14 +2406,13 @@ Useful links:
`http://gnuwin32.sourceforge.net/packages/psutils.htm'
* psnup documentation (GNU or Unix - or type `man psnup')
- `http://linux.about.com/library/cmd/blcmdl1_psnup.htm'
- `http://amath.colorado.edu/computing/software/man/psnup.html'
+ `https://linux.die.net/man/1/psnup'
* GNU Enscript (Windows, GNU or Unix)
- `http://people.ssh.com/mtr/genscript/'
+ `https://people.ssh.com/mtr/genscript/'
* GNU Enscript documentation (Windows, GNU or Unix)
- `http://people.ssh.com/mtr/genscript/enscript.man.html'
+ `https://people.ssh.com/mtr/genscript/enscript.man.html'
(on GNU or Unix, type `man enscript')
"
:type '(repeat
@@ -4783,13 +4766,13 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-menu-create (name alist var-sym fun entry index)
(cons name
(mapcar
- #'(lambda (elt)
- (let ((sym (car elt)))
- (vector
- (symbol-name sym)
- `(,fun ',sym nil ',entry ',index)
- :style 'radio
- :selected `(eq ,var-sym ',sym))))
+ (lambda (elt)
+ (let ((sym (car elt)))
+ (vector
+ (symbol-name sym)
+ `(,fun ',sym nil ',entry ',index)
+ :style 'radio
+ :selected `(eq ,var-sym ',sym))))
alist)))
@@ -4891,23 +4874,23 @@ If menu binding was not done, calls `pr-menu-bind'."
(cons inherits old)))))
(mapc
(cond ((not local) ; global settings
- #'(lambda (option)
- (let ((var-sym (car option)))
- (or (eq var-sym 'inherits-from:)
- (set var-sym (eval (cdr option)))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (or (eq var-sym 'inherits-from:)
+ (set var-sym (eval (cdr option)))))))
(kill ; local settings with killing
- #'(lambda (option)
- (let ((var-sym (car option)))
- (unless (eq var-sym 'inherits-from:)
- (setq local-list (cons var-sym local-list))
- (set (make-local-variable var-sym)
- (eval (cdr option)))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (unless (eq var-sym 'inherits-from:)
+ (setq local-list (cons var-sym local-list))
+ (set (make-local-variable var-sym)
+ (eval (cdr option)))))))
(t ; local settings without killing
- #'(lambda (option)
- (let ((var-sym (car option)))
- (or (eq var-sym 'inherits-from:)
- (set (make-local-variable var-sym)
- (eval (cdr option))))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (or (eq var-sym 'inherits-from:)
+ (set (make-local-variable var-sym)
+ (eval (cdr option))))))))
(nthcdr 3 setting))
local-list))))
@@ -5085,9 +5068,9 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-complete-alist (prompt alist default)
- (let ((collection (mapcar #'(lambda (elt)
- (setq elt (car elt))
- (cons (symbol-name elt) elt))
+ (let ((collection (mapcar (lambda (elt)
+ (setq elt (car elt))
+ (cons (symbol-name elt) elt))
alist)))
(cdr (assoc (completing-read (concat prompt ": ")
collection nil t
@@ -5284,22 +5267,18 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-interactive-n-up (mess)
- (or (stringp mess) (setq mess "*"))
- (save-match-data
- (let* ((fmt-prompt "%s[%s] N-up printing (default 1): ")
- (prompt "")
- (str (read-string (format fmt-prompt prompt mess) nil nil "1"))
- int)
- (while (if (string-match "^\\s *[0-9]+$" str)
- (setq int (string-to-number str)
- prompt (cond ((< int 1) "Integer below 1; ")
- ((> int 100) "Integer above 100; ")
- (t nil)))
- (setq prompt "Invalid integer syntax; "))
- (ding)
- (setq str
- (read-string (format fmt-prompt prompt mess) str nil "1")))
- int)))
+ (unless (stringp mess)
+ (setq mess "*"))
+ (let (int)
+ (while (or (< (setq int (read-number (format "[%s] N-up printing:" mess) 1))
+ 0)
+ (> int 100))
+ (if (< int 0)
+ (message "Integer below 1")
+ (message "Integer above 100"))
+ (sit-for 1)
+ (ding))
+ int))
(defun pr-interactive-dir (mess)
@@ -5323,7 +5302,7 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-interactive-regexp (mess)
- (read-string (format "[%s] File regexp to print: " mess) nil nil ""))
+ (read-string (format "[%s] File regexp to print: " mess)))
(defun pr-interactive-dir-args (mess)
@@ -5425,19 +5404,19 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-file-list (dir file-regexp fun)
- (mapcar #'(lambda (file)
- (and (or pr-list-directory
- (not (file-directory-p file)))
- (let ((buffer (pr-find-buffer-visiting file))
- pop-up-windows
- pop-up-frames)
- (and (or buffer
- (file-readable-p file))
- (with-current-buffer (or buffer
- (find-file-noselect file))
- (funcall fun)
- (or buffer
- (kill-buffer (current-buffer))))))))
+ (mapcar (lambda (file)
+ (and (or pr-list-directory
+ (not (file-directory-p file)))
+ (let ((buffer (pr-find-buffer-visiting file))
+ pop-up-windows
+ pop-up-frames)
+ (and (or buffer
+ (file-readable-p file))
+ (with-current-buffer (or buffer
+ (find-file-noselect file))
+ (funcall fun)
+ (or buffer
+ (kill-buffer (current-buffer))))))))
(directory-files dir t file-regexp)))
@@ -5450,10 +5429,10 @@ If menu binding was not done, calls `pr-menu-bind'."
(pr-delete-file-if-exists (setq filename (expand-file-name filename)))
(let ((pr-spool-p t))
(pr-file-list dir file-regexp
- #'(lambda ()
- (if (pr-auto-mode-p)
- (pr-ps-mode n-up filename)
- (pr-text2ps 'buffer n-up filename)))))
+ (lambda ()
+ (if (pr-auto-mode-p)
+ (pr-ps-mode n-up filename)
+ (pr-text2ps 'buffer n-up filename)))))
(or pr-spool-p
(pr-despool-print filename)))
@@ -5622,8 +5601,6 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; header
(let ((versions (concat "printing v" pr-version
" ps-print v" ps-print-version)))
- ;; to keep compatibility with Emacs 20 & 21:
- ;; DO NOT REPLACE `?\ ' BY `?\s'
(widget-insert (make-string (- 79 (length versions)) ?\ ) versions))
(pr-insert-italic "\nCurrent Directory : " 1)
(pr-insert-italic default-directory)
@@ -5686,44 +5663,44 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-checkbox
"\n "
'pr-i-region
- #'(lambda (widget &rest _ignore)
- (let ((region-p (pr-interface-save
- (ps-mark-active-p))))
- (cond ((null (widget-value widget)) ; widget is nil
- (setq pr-i-region nil))
- (region-p ; widget is true and there is a region
- (setq pr-i-region t)
- (widget-value-set widget t)
- (widget-setup)) ; MUST be called after widget-value-set
- (t ; widget is true and there is no region
- (ding)
- (message "There is no region active")
- (setq pr-i-region nil)
- (widget-value-set widget nil)
- (widget-setup))))) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (let ((region-p (pr-interface-save
+ (ps-mark-active-p))))
+ (cond ((null (widget-value widget)) ; widget is nil
+ (setq pr-i-region nil))
+ (region-p ; widget is true and there is a region
+ (setq pr-i-region t)
+ (widget-value-set widget t)
+ (widget-setup)) ; MUST be called after widget-value-set
+ (t ; widget is true and there is no region
+ (ding)
+ (message "There is no region active")
+ (setq pr-i-region nil)
+ (widget-value-set widget nil)
+ (widget-setup))))) ; MUST be called after widget-value-set
" Region"))
;; 1a. Buffer: Mode
(put 'pr-i-mode 'pr-widget
(pr-insert-checkbox
" "
'pr-i-mode
- #'(lambda (widget &rest _ignore)
- (let ((mode-p (pr-interface-save
- (pr-mode-alist-p))))
- (cond
- ((null (widget-value widget)) ; widget is nil
- (setq pr-i-mode nil))
- (mode-p ; widget is true and there is a `mode'
- (setq pr-i-mode t)
- (widget-value-set widget t)
- (widget-setup)) ; MUST be called after widget-value-set
- (t ; widget is true and there is no `mode'
- (ding)
- (message
- "This buffer isn't in a mode that printing treats specially.")
- (setq pr-i-mode nil)
- (widget-value-set widget nil)
- (widget-setup))))) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (let ((mode-p (pr-interface-save
+ (pr-mode-alist-p))))
+ (cond
+ ((null (widget-value widget)) ; widget is nil
+ (setq pr-i-mode nil))
+ (mode-p ; widget is true and there is a `mode'
+ (setq pr-i-mode t)
+ (widget-value-set widget t)
+ (widget-setup)) ; MUST be called after widget-value-set
+ (t ; widget is true and there is no `mode'
+ (ding)
+ (message
+ "This buffer isn't in a mode that printing treats specially.")
+ (setq pr-i-mode nil)
+ (widget-value-set widget nil)
+ (widget-setup))))) ; MUST be called after widget-value-set
" Mode\n"))
;; 1b. Directory:
@@ -5783,14 +5760,14 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-checkbox
" "
'pr-i-despool
- #'(lambda (widget &rest _ignore)
- (if pr-spool-p
- (setq pr-i-despool (not pr-i-despool))
- (ding)
- (message "Can despool only when spooling is actually selected")
- (setq pr-i-despool nil))
- (widget-value-set widget pr-i-despool)
- (widget-setup)) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (if pr-spool-p
+ (setq pr-i-despool (not pr-i-despool))
+ (ding)
+ (message "Can despool only when spooling is actually selected")
+ (setq pr-i-despool nil))
+ (widget-value-set widget pr-i-despool)
+ (widget-setup)) ; MUST be called after widget-value-set
" Despool "))
;; 2. PostScript Printer: Preview Print Quit
(pr-insert-button 'pr-interface-preview "Preview" " ")
@@ -5849,9 +5826,9 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; 4. Settings:
;; 4. Settings: Landscape Auto Region Verbose
(pr-insert-checkbox "\n\n " 'ps-landscape-mode
- #'(lambda (&rest _ignore)
- (setq ps-landscape-mode (not ps-landscape-mode)
- pr-file-landscape ps-landscape-mode))
+ (lambda (&rest _ignore)
+ (setq ps-landscape-mode (not ps-landscape-mode)
+ pr-file-landscape ps-landscape-mode))
" Landscape ")
(pr-insert-toggle 'pr-auto-region " Auto Region ")
(pr-insert-toggle 'pr-buffer-verbose " Verbose\n ")
@@ -5871,28 +5848,28 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-toggle 'ps-zebra-stripes " Zebra Stripes")
(pr-insert-checkbox " "
'pr-spool-p
- #'(lambda (&rest _ignore)
- (setq pr-spool-p (not pr-spool-p))
- (unless pr-spool-p
- (setq pr-i-despool nil)
- (pr-update-checkbox 'pr-i-despool)))
+ (lambda (&rest _ignore)
+ (setq pr-spool-p (not pr-spool-p))
+ (unless pr-spool-p
+ (setq pr-i-despool nil)
+ (pr-update-checkbox 'pr-i-despool)))
" Spool Buffer")
;; 4. Settings: Duplex Print with faces
(pr-insert-checkbox "\n "
'ps-spool-duplex
- #'(lambda (&rest _ignore)
- (setq ps-spool-duplex (not ps-spool-duplex)
- pr-file-duplex ps-spool-duplex))
+ (lambda (&rest _ignore)
+ (setq ps-spool-duplex (not ps-spool-duplex)
+ pr-file-duplex ps-spool-duplex))
" Duplex ")
(pr-insert-toggle 'pr-faces-p " Print with faces")
;; 4. Settings: Tumble Print via Ghostscript
(pr-insert-checkbox "\n "
'ps-spool-tumble
- #'(lambda (&rest _ignore)
- (setq ps-spool-tumble (not ps-spool-tumble)
- pr-file-tumble ps-spool-tumble))
+ (lambda (&rest _ignore)
+ (setq ps-spool-tumble (not ps-spool-tumble)
+ pr-file-tumble ps-spool-tumble))
" Tumble ")
(pr-insert-toggle 'pr-print-using-ghostscript " Print via Ghostscript\n ")
@@ -5900,11 +5877,11 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-toggle 'ps-print-upside-down " Upside-Down")
(pr-insert-italic "\n\nSelect Pages : " 2 14)
(pr-insert-menu "Page Parity" 'ps-even-or-odd-pages
- (mapcar #'(lambda (alist)
- (list 'choice-item
- :format "%[%t%]"
- :tag (cdr alist)
- :value (car alist)))
+ (mapcar (lambda (alist)
+ (list 'choice-item
+ :format "%[%t%]"
+ :tag (cdr alist)
+ :value (car alist)))
pr-even-or-odd-alist)))
@@ -5912,7 +5889,7 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; 5. Customize:
(pr-insert-italic "\n\nCustomize : " 2 11)
(pr-insert-button 'pr-customize "printing" " ")
- (pr-insert-button #'(lambda (&rest _ignore) (ps-print-customize))
+ (pr-insert-button (lambda (&rest _ignore) (ps-print-customize))
"ps-print" " ")
(pr-insert-button 'lpr-customize "lpr"))
@@ -6221,18 +6198,18 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(defun pr-choice-alist (alist)
- (let ((max (apply #'max (mapcar #'(lambda (alist)
- (length (symbol-name (car alist))))
+ (let ((max (apply #'max (mapcar (lambda (alist)
+ (length (symbol-name (car alist))))
alist))))
- (mapcar #'(lambda (alist)
- (let* ((sym (car alist))
- (name (symbol-name sym)))
- (list
- 'choice-item
- :format "%[%t%]"
- :tag (concat name
- (make-string (- max (length name)) ?_))
- :value sym)))
+ (mapcar (lambda (alist)
+ (let* ((sym (car alist))
+ (name (symbol-name sym)))
+ (list
+ 'choice-item
+ :format "%[%t%]"
+ :tag (concat name
+ (make-string (- max (length name)) ?_))
+ :value sym)))
alist)))
@@ -6241,5 +6218,4 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(provide 'printing)
-
;;; printing.el ends here
diff --git a/lisp/proced.el b/lisp/proced.el
index 68e0c5d37ae..d1a243df8e0 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -1,4 +1,4 @@
-;;; proced.el --- operate on system processes like dired
+;;; proced.el --- operate on system processes like dired -*- lexical-binding:t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -55,17 +55,15 @@
:group 'unix
:prefix "proced-")
-(defcustom proced-signal-function 'signal-process
+(defcustom proced-signal-function #'signal-process
"Name of signal function.
It can be an elisp function (usually `signal-process') or a string specifying
the external command (usually \"kill\")."
- :group 'proced
:type '(choice (function :tag "function")
(string :tag "command")))
(defcustom proced-renice-command "renice"
"Name of renice command."
- :group 'proced
:version "24.3"
:type '(string :tag "command"))
@@ -95,7 +93,6 @@ the external command (usually \"kill\")."
("USR1" . " (User-defined signal 1)")
("USR2" . " (User-defined signal 2)"))
"List of signals, used for minibuffer completion."
- :group 'proced
:type '(repeat (cons (string :tag "signal name")
(string :tag "description"))))
@@ -205,7 +202,6 @@ of point. The function must return a list of PIDs that is used for the refined
listing. HELP-ECHO is a string that is shown when mouse is over this field.
If REFINER is nil no refinement is done."
- :group 'proced
:type '(repeat (list :tag "Attribute"
(symbol :tag "Key")
(string :tag "Header")
@@ -239,7 +235,6 @@ of a system process. It returns a cons cell of the form (KEY . VALUE)
like `process-attributes'. This cons cell is appended to the list
returned by `proced-process-attributes'.
If the function returns nil, the value is ignored."
- :group 'proced
:type '(repeat (function :tag "Attribute")))
;; Formatting and sorting rules are defined "per attribute". If formatting
@@ -263,7 +258,6 @@ The cdr is a list of attribute keys appearing in `proced-grammar-alist'.
An element of this list may also be a list of attribute keys that specifies
alternatives. If the first attribute is absent for a process, use the second
one, etc."
- :group 'proced
:type '(alist :key-type (symbol :tag "Format Name")
:value-type (repeat :tag "Keys"
(choice (symbol :tag "")
@@ -274,7 +268,6 @@ one, etc."
"Current format of Proced listing.
It can be the car of an element of `proced-format-alist'.
It can also be a list of keys appearing in `proced-grammar-alist'."
- :group 'proced
:type '(choice (symbol :tag "Format Name")
(repeat :tag "Keys" (symbol :tag ""))))
(make-variable-buffer-local 'proced-format)
@@ -304,7 +297,6 @@ An elementary filter can be one of the following:
of each. Accept the process if FUN returns non-nil.
\(fun-all . FUN) Apply function FUN to entire process list.
FUN must return the filtered list."
- :group 'proced
:type '(repeat (cons :tag "Filter"
(symbol :tag "Filter Name")
(repeat :tag "Filters"
@@ -318,7 +310,6 @@ An elementary filter can be one of the following:
It can be the car of an element of `proced-filter-alist'.
It can also be a list of elementary filters as in the cdrs of the elements
of `proced-filter-alist'."
- :group 'proced
:type '(choice (symbol :tag "Filter Name")
(repeat :tag "Filters"
(choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp)
@@ -332,38 +323,32 @@ of `proced-filter-alist'."
It must be the KEY of an element of `proced-grammar-alist'.
It can also be a list of KEYs as in the SORT-SCHEMEs of the elements
of `proced-grammar-alist'."
- :group 'proced
:type '(choice (symbol :tag "Sort Scheme")
(repeat :tag "Key List" (symbol :tag "Key"))))
(make-variable-buffer-local 'proced-sort)
(defcustom proced-descend t
"Non-nil if proced listing is sorted in descending order."
- :group 'proced
:type '(boolean :tag "Descending Sort Order"))
(make-variable-buffer-local 'proced-descend)
(defcustom proced-goal-attribute 'args
"If non-nil, key of the attribute that defines the `goal-column'."
- :group 'proced
:type '(choice (const :tag "none" nil)
(symbol :tag "key")))
(defcustom proced-auto-update-interval 5
"Time interval in seconds for auto updating Proced buffers."
- :group 'proced
:type 'integer)
(defcustom proced-auto-update-flag nil
"Non-nil for auto update of a Proced buffer.
Can be changed interactively via `proced-toggle-auto-update'."
- :group 'proced
:type 'boolean)
(make-variable-buffer-local 'proced-auto-update-flag)
(defcustom proced-tree-flag nil
"Non-nil for display of Proced buffer as process tree."
- :group 'proced
:type 'boolean)
(make-variable-buffer-local 'proced-tree-flag)
@@ -371,26 +356,23 @@ Can be changed interactively via `proced-toggle-auto-update'."
"Normal hook run after displaying or updating a Proced buffer.
May be used to adapt the window size via `fit-window-to-buffer'."
:type 'hook
- :options '(fit-window-to-buffer)
- :group 'proced)
+ :options '(fit-window-to-buffer))
(defcustom proced-after-send-signal-hook nil
"Normal hook run after sending a signal to processes by `proced-send-signal'.
May be used to revert the process listing."
:type 'hook
- :options '(proced-revert)
- :group 'proced)
+ :options '(proced-revert))
;; Internal variables
(defvar proced-available (not (null (list-system-processes)))
"Non-nil means Proced is known to work on this system.")
-(defvar proced-process-alist nil
+(defvar-local proced-process-alist nil
"Alist of processes displayed by Proced.
The car of each element is the PID, and the cdr is a list of
cons pairs, see `proced-process-attributes'.")
-(make-variable-buffer-local 'proced-process-alist)
(defvar proced-sort-internal nil
"Sort scheme for listing (internal format).
@@ -408,26 +390,22 @@ It is a list of lists (KEY PREDICATE REVERSE).")
(defface proced-mark
'((t (:inherit font-lock-constant-face)))
- "Face used for Proced marks."
- :group 'proced-faces)
+ "Face used for Proced marks.")
(defface proced-marked
'((t (:inherit error)))
- "Face used for marked processes."
- :group 'proced-faces)
+ "Face used for marked processes.")
(defface proced-sort-header
'((t (:inherit font-lock-keyword-face)))
- "Face used for header of attribute used for sorting."
- :group 'proced-faces)
+ "Face used for header of attribute used for sorting.")
(defvar proced-re-mark "^[^ \n]"
"Regexp matching a marked line.
Important: the match ends just after the marker.")
-(defvar proced-header-line nil
+(defvar-local proced-header-line nil
"Headers in Proced buffer as a string.")
-(make-variable-buffer-local 'proced-header-line)
(defvar proced-temp-alist nil
"Temporary alist (internal variable).")
@@ -615,14 +593,23 @@ Important: the match ends just after the marker.")
(defun proced-header-line ()
"Return header line for Proced buffer."
- (list (propertize " "
- 'display
- (list 'space :align-to
- (line-number-display-width 'columns)))
- (if (<= (window-hscroll) (length proced-header-line))
- (replace-regexp-in-string ;; preserve text properties
- "\\(%\\)" "\\1\\1"
- (substring proced-header-line (window-hscroll))))))
+ (let ((base (line-number-display-width 'columns))
+ (hl (if (<= (window-hscroll) (length proced-header-line))
+ (substring proced-header-line (window-hscroll)))))
+ (when hl
+ ;; From buff-menu.el: Turn whitespace chars in the header into
+ ;; stretch specs so they work regardless of the header-line face.
+ (let ((pos 0))
+ (while (string-match "[ \t\n]+" hl pos)
+ (setq pos (match-end 0))
+ (put-text-property (match-beginning 0) pos 'display
+ `(space :align-to ,(+ pos base))
+ hl)))
+ (setq hl (replace-regexp-in-string ;; preserve text properties
+ "\\(%\\)" "\\1\\1"
+ hl)))
+ (list (propertize " " 'display `(space :align-to ,base))
+ hl)))
(defun proced-pid-at-point ()
"Return pid of system process at point.
@@ -676,10 +663,10 @@ After displaying or updating a Proced buffer, Proced runs the normal hook
(setq buffer-read-only t
truncate-lines t
header-line-format '(:eval (proced-header-line)))
- (add-hook 'post-command-hook 'force-mode-line-update nil t)
- (set (make-local-variable 'revert-buffer-function) 'proced-revert)
- (set (make-local-variable 'font-lock-defaults)
- '(proced-font-lock-keywords t nil nil beginning-of-line))
+ (add-hook 'post-command-hook #'force-mode-line-update nil t) ;; FIXME: Why?
+ (setq-local revert-buffer-function #'proced-revert)
+ (setq-local font-lock-defaults
+ '(proced-font-lock-keywords t nil nil beginning-of-line))
(if (and (not proced-auto-update-timer) proced-auto-update-interval)
(setq proced-auto-update-timer
(run-at-time t proced-auto-update-interval
@@ -940,11 +927,12 @@ Return the filtered process list."
(if (funcall (car filter) (cdr process))
(push process new-alist))))
(t ;; apply predicate to specified attribute
- (let ((fun (if (stringp (cdr filter))
- `(lambda (val)
- (string-match ,(cdr filter) val))
- (cdr filter)))
- value)
+ (let* ((cdrfilter (cdr filter))
+ (fun (if (stringp cdrfilter)
+ (lambda (val)
+ (string-match cdrfilter val))
+ cdrfilter))
+ value)
(dolist (process process-alist)
(setq value (cdr (assq (car filter) (cdr process))))
(if (and value (funcall fun value))
@@ -1023,7 +1011,7 @@ The list of children does not include grandchildren."
"Return list of children PIDs of PPID (including PPID)."
(let ((cpids (cdr (assq ppid proced-temp-alist))))
(if cpids
- (cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
+ (cons ppid (apply #'append (mapcar #'proced-children-pids cpids)))
(list ppid))))
(defun proced-process-tree (process-alist)
@@ -1114,7 +1102,7 @@ Return the rearranged process list."
proced-process-tree)
(if (cdr process-tree)
(let ((proced-tree-depth (1+ proced-tree-depth)))
- (mapc 'proced-tree-insert (cdr process-tree))))))
+ (mapc #'proced-tree-insert (cdr process-tree))))))
;; Refining
@@ -1207,7 +1195,7 @@ Return `equal' if T1 equals T2. Return nil otherwise."
;;; Sorting
-(define-obsolete-function-alias 'proced-xor 'xor "27.1")
+(define-obsolete-function-alias 'proced-xor #'xor "27.1")
(defun proced-sort-p (p1 p2)
"Predicate for sorting processes P1 and P2."
@@ -1436,10 +1424,11 @@ Replace newline characters by \"^J\" (two characters)."
;; Loop over all attributes
(while (setq grammar (assq (pop format) proced-grammar-alist))
(let* ((key (car grammar))
- (fun (cond ((stringp (nth 2 grammar))
- `(lambda (arg) (format ,(nth 2 grammar) arg)))
- ((not (nth 2 grammar)) 'identity)
- ( t (nth 2 grammar))))
+ (nth2grm (nth 2 grammar))
+ (fun (cond ((stringp nth2grm)
+ (lambda (arg) (format nth2grm arg)))
+ ((not nth2grm) #'identity)
+ (t nth2grm)))
(whitespace (if format whitespace ""))
;; Text properties:
;; We use the text property `proced-key' to store in each
@@ -1479,13 +1468,13 @@ Replace newline characters by \"^J\" (two characters)."
(end-of-line)
(setq value (cdr (assq key (cdr process))))
(insert (if value
- (apply 'propertize (funcall fun value) fprops)
+ (apply #'propertize (funcall fun value) fprops)
(format (concat "%" (number-to-string (nth 3 grammar)) "s")
unknown))
whitespace)
(forward-line))
(push (format (concat "%" (number-to-string (nth 3 grammar)) "s")
- (apply 'propertize (nth 1 grammar) hprops))
+ (apply #'propertize (nth 1 grammar) hprops))
header-list))
( ;; last field left-justified
@@ -1493,10 +1482,10 @@ Replace newline characters by \"^J\" (two characters)."
(dolist (process process-alist)
(end-of-line)
(setq value (cdr (assq key (cdr process))))
- (insert (if value (apply 'propertize (funcall fun value) fprops)
+ (insert (if value (apply #'propertize (funcall fun value) fprops)
unknown))
(forward-line))
- (push (apply 'propertize (nth 1 grammar) hprops) header-list))
+ (push (apply #'propertize (nth 1 grammar) hprops) header-list))
(t ;; calculated field width
(let ((width (length (nth 1 grammar)))
@@ -1504,14 +1493,14 @@ Replace newline characters by \"^J\" (two characters)."
(dolist (process process-alist)
(setq value (cdr (assq key (cdr process))))
(if value
- (setq value (apply 'propertize (funcall fun value) fprops)
+ (setq value (apply #'propertize (funcall fun value) fprops)
width (max width (length value))
field-list (cons value field-list))
(push unknown field-list)
(setq width (max width (length unknown)))))
(let ((afmt (concat "%" (if (eq 'left (nth 3 grammar)) "-" "")
(number-to-string width) "s")))
- (push (format afmt (apply 'propertize (nth 1 grammar) hprops))
+ (push (format afmt (apply #'propertize (nth 1 grammar) hprops))
header-list)
(dolist (value (nreverse field-list))
(end-of-line)
@@ -1527,7 +1516,7 @@ Replace newline characters by \"^J\" (two characters)."
(forward-line))
;; Set header line
(setq proced-header-line
- (mapconcat 'identity (nreverse header-list) whitespace))
+ (mapconcat #'identity (nreverse header-list) whitespace))
(if (string-match "[ \t]+$" proced-header-line)
(setq proced-header-line (substring proced-header-line 0
(match-beginning 0))))
@@ -1742,7 +1731,7 @@ The value returned is the value of the last form in BODY."
(setq truncate-lines t
proced-header-line header-line ; inherit header line
header-line-format '(:eval (proced-header-line)))
- (add-hook 'post-command-hook 'force-mode-line-update nil t)
+ (add-hook 'post-command-hook #'force-mode-line-update nil t) ;FIXME: Why?
(let ((inhibit-read-only t))
(erase-buffer)
(buffer-disable-undo)
@@ -1780,8 +1769,8 @@ supported but discouraged. It will be removed in a future version of Emacs."
(format "%d processes" (length process-alist))))
(completion-ignore-case t)
(completion-extra-properties
- '(:annotation-function
- (lambda (s) (cdr (assoc s proced-signal-list))))))
+ `(:annotation-function
+ ,(lambda (s) (cdr (assoc s proced-signal-list))))))
(proced-with-processes-buffer process-alist
(list (completing-read (concat "Send signal [" pnum
"] (default TERM): ")
@@ -1805,8 +1794,8 @@ supported but discouraged. It will be removed in a future version of Emacs."
(format "%d processes" (length process-alist))))
(completion-ignore-case t)
(completion-extra-properties
- '(:annotation-function
- (lambda (s) (cdr (assoc s proced-signal-list))))))
+ `(:annotation-function
+ ,(lambda (s) (cdr (assoc s proced-signal-list))))))
(proced-with-processes-buffer process-alist
(setq signal (completing-read (concat "Send signal [" pnum
"] (default TERM): ")
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 7cdd3511277..8145e51d75d 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -34,7 +34,7 @@
:version "24.3"
:prefix "profiler-")
-(defconst profiler-version "24.3")
+(defconst profiler-version "28.1")
(defcustom profiler-sampling-interval 1000000
"Default sampling interval in nanoseconds."
@@ -85,6 +85,9 @@
(t
(profiler-ensure-string arg)))
for len = (length str)
+ if (zerop width)
+ collect str into frags
+ else
if (< width len)
collect (progn (put-text-property (max 0 (- width 2)) len
'invisible 'profiler str)
@@ -305,7 +308,7 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
(let ((fun-map (make-hash-table :test 'profiler-function-equal))
(parent-map (make-hash-table :test 'eq))
(leftover-tree (profiler-make-calltree
- :entry (intern "...") :parent tree)))
+ :entry '... :parent tree)))
(push leftover-tree (profiler-calltree-children tree))
(maphash
(lambda (backtrace _count)
@@ -445,14 +448,16 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
:group 'profiler)
(defvar profiler-report-cpu-line-format
- '((50 left)
- (24 right ((19 right)
- (5 right)))))
+ '((17 right ((12 right)
+ (5 right)))
+ (1 left "%s")
+ (0 left)))
(defvar profiler-report-memory-line-format
- '((55 left)
- (19 right ((14 right profiler-format-number)
- (5 right)))))
+ '((20 right ((15 right profiler-format-number)
+ (5 right)))
+ (1 left "%s")
+ (0 left)))
(defvar-local profiler-report-profile nil
"The current profile.")
@@ -495,7 +500,11 @@ RET: expand or collapse"))
(defun profiler-report-header-line-format (fmt &rest args)
(let* ((header (apply #'profiler-format fmt args))
(escaped (replace-regexp-in-string "%" "%%" header)))
- (concat " " escaped)))
+ (concat
+ (propertize " "
+ 'display '(space :align-to 0)
+ 'face 'fixed-pitch)
+ escaped)))
(defun profiler-report-line-format (tree)
(let ((diff-p (profiler-profile-diff-p profiler-report-profile))
@@ -505,13 +514,14 @@ RET: expand or collapse"))
(profiler-format (cl-ecase (profiler-profile-type profiler-report-profile)
(cpu profiler-report-cpu-line-format)
(memory profiler-report-memory-line-format))
- name-part
(if diff-p
(list (if (> count 0)
(format "+%s" count)
count)
"")
- (list count count-percent)))))
+ (list count count-percent))
+ " "
+ name-part)))
(defun profiler-report-insert-calltree (tree)
(let ((line (profiler-report-line-format tree)))
@@ -735,11 +745,11 @@ below entry at point."
(cpu
(profiler-report-header-line-format
profiler-report-cpu-line-format
- "Function" (list "CPU samples" "%")))
+ (list "Samples" "%") " " " Function"))
(memory
(profiler-report-header-line-format
profiler-report-memory-line-format
- "Function" (list "Bytes" "%")))))
+ (list "Bytes" "%") " " " Function"))))
(let ((predicate (cl-ecase order
(ascending #'profiler-calltree-count<)
(descending #'profiler-calltree-count>))))
@@ -820,7 +830,7 @@ If MODE is `mem' or `cpu+mem', start profiler that samples CPU
at a high enough frequency."
(interactive
(list (if (not (fboundp 'profiler-cpu-start)) 'mem
- (intern (completing-read "Mode (default cpu): "
+ (intern (completing-read (format-prompt "Mode" "cpu")
'("cpu" "mem" "cpu+mem")
nil t nil nil "cpu")))))
(cl-ecase mode
diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el
index 7db64bd4849..2a4b3482831 100644
--- a/lisp/progmodes/antlr-mode.el
+++ b/lisp/progmodes/antlr-mode.el
@@ -1,4 +1,4 @@
-;;; antlr-mode.el --- major mode for ANTLR grammar files
+;;; antlr-mode.el --- major mode for ANTLR grammar files -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -33,7 +33,7 @@
;; the manual style, follow all commands mentioned in the documentation of
;; `antlr-mode'. ANTLR is a LL(k)-based recognition tool which generates
;; lexers, parsers and tree transformers in Java, C++ or Sather and can be
-;; found at <http://www.antlr.org/>.
+;; found at <https://www.antlr.org/>.
;; Bug fixes, bug reports, improvements, and suggestions for the newest version
;; are strongly appreciated.
@@ -52,7 +52,7 @@
;;
;; * Probably. Show rules/dependencies for ANT like for Makefile (does ANT
;; support vocabularies and grammar inheritance?), I have to look at
-;; jde-ant.el: http://jakarta.apache.org/ant/manual/OptionalTasks/antlr.html
+;; jde-ant.el: https://jakarta.apache.org/ant/manual/OptionalTasks/antlr.html
;; * Probably. Make `indent-region' faster, especially in actions. ELP
;; profiling in a class init action shows half the time is spent in
;; `antlr-next-rule', the other half in `c-guess-basic-syntax'.
@@ -75,8 +75,8 @@
;; (add-hook 'speedbar-load-hook ; would be too late in antlr-mode.el
;; (lambda () (speedbar-add-supported-extension ".g")))
-;; I strongly recommend to use font-lock with a support mode like fast-lock,
-;; lazy-lock or better jit-lock (Emacs-21.1+) / lazy-shot (XEmacs).
+;; I strongly recommend to use font-lock with a support mode like
+;; jit-lock (Emacs) / lazy-shot (XEmacs).
;; To customize, use menu item "Antlr" -> "Customize Antlr".
@@ -84,98 +84,17 @@
(eval-when-compile (require 'cl-lib))
-(require 'easymenu)
+(when (< emacs-major-version 28) ; preloaded in Emacs 28
+ (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
- (defmacro cond-emacs-xemacs (&rest args)
- (cond-emacs-xemacs-macfn
- args "`cond-emacs-xemacs' must return exactly one element"))
- (defun cond-emacs-xemacs-macfn (args &optional msg)
- (if (atom args) args
- (and (eq (car args) :@) (null msg) ; (:@ ...spliced...)
- (setq args (cdr args)
- msg "(:@ ....) must return exactly one element"))
- (let ((ignore (if (featurep 'xemacs) :EMACS :XEMACS))
- (mode :BOTH) code)
- (while (consp args)
- (if (memq (car args) '(:EMACS :XEMACS :BOTH)) (setq mode (pop args)))
- (if (atom args)
- (or args (error "Used selector %s without elements" mode))
- (or (eq ignore mode)
- (push (cond-emacs-xemacs-macfn (car args)) code))
- (pop args)))
- (cond (msg (if (or args (cdr code)) (error msg) (car code)))
- ((or (null args) (eq ignore mode)) (nreverse code))
- (t (nconc (nreverse code) args))))))
- ;; Emacs/XEmacs-compatibility `defun': remove interactive "_" for Emacs, use
- ;; existing functions when they are `fboundp', provide shortcuts if they are
- ;; known to be defined in a specific Emacs branch (for short .elc)
- (defmacro defunx (name arglist &rest definition)
- (let ((xemacsp (featurep 'xemacs)) reuses)
- (while (memq (car definition)
- '(:try :emacs-and-try :xemacs-and-try))
- (if (eq (pop definition) (if xemacsp :xemacs-and-try :emacs-and-try))
- (setq reuses (car definition)
- definition nil)
- (push (pop definition) reuses)))
- (if (and reuses (symbolp reuses))
- `(defalias ',name ',reuses)
- (let* ((docstring (if (stringp (car definition)) (pop definition)))
- (spec (and (not xemacsp)
- (eq (car-safe (car definition)) 'interactive)
- (null (cddar definition))
- (cadar definition))))
- (if (and (stringp spec)
- (not (string-equal spec ""))
- (eq (aref spec 0) ?_))
- (setq definition
- (cons (if (string-equal spec "_")
- '(interactive)
- `(interactive ,(substring spec 1)))
- (cdr definition))))
- (if (null reuses)
- `(defun ,name ,arglist ,docstring
- ,@(cond-emacs-xemacs-macfn definition))
- ;; no dynamic docstring in this case
- `(eval-and-compile ; no warnings in Emacs
- (defalias ',name
- (cond ,@(mapcar (lambda (func) `((fboundp ',func) ',func))
- (nreverse reuses))
- (t ,(if definition
- `(lambda ,arglist ,docstring
- ,@(cond-emacs-xemacs-macfn definition))
- 'ignore))))))))))
- (defmacro ignore-errors-x (&rest body)
- (let ((specials '((scan-sexps . 4) (scan-lists . 5)))
- spec nils)
- (if (and (featurep 'xemacs)
- (null (cdr body)) (consp (car body))
- (setq spec (assq (caar body) specials))
- (>= (setq nils (- (cdr spec) (length (car body)))) 0))
- `(,@(car body) ,@(make-list nils nil) t)
- `(ignore-errors ,@body)))))
-
;; More compile-time-macros
(eval-when-compile
(defmacro save-buffer-state-x (&rest body) ; similar to EMACS/lazy-lock.el
- (let ((modified (with-no-warnings (gensym "save-buffer-state-x-modified-"))))
- `(let ((,modified (buffer-modified-p)))
- (unwind-protect
- (let ((buffer-undo-list t) (inhibit-read-only t)
- ,@(unless (featurep 'xemacs)
- '((inhibit-point-motion-hooks t) deactivate-mark))
- (inhibit-modification-hooks t)
- buffer-file-name buffer-file-truename)
- ,@body)
- (and (not ,modified) (buffer-modified-p)
- (set-buffer-modified-p nil)))))))
-(put 'save-buffer-state-x 'lisp-indent-function 0)
+ (declare (debug t) (indent 0))
+ `(let ((inhibit-point-motion-hooks t))
+ (with-silent-modifications
+ ,@body))))
(defvar outline-level)
(defvar imenu-use-markers)
@@ -188,7 +107,7 @@
;; Additional to the `defalias' below, we must set `antlr-c-forward-sws' to
;; `c-forward-syntactic-ws' when `c-forward-sws' is not defined after requiring
;; cc-mode.
-(defalias 'antlr-c-forward-sws 'c-forward-sws)
+(defalias 'antlr-c-forward-sws #'c-forward-sws)
;;;;##########################################################################
@@ -231,7 +150,6 @@ value of `antlr-language' if the first group in the string matched by
REGEXP in `antlr-language-limit-n-regexp' is one of the OPTION-VALUEs.
An OPTION-VALUE of nil denotes the fallback element. MODELINE-STRING is
also displayed in the mode line next to \"Antlr\"."
- :group 'antlr
:type '(repeat (group :value (java-mode "")
(function :tag "Major mode")
(string :tag "Mode line string")
@@ -245,7 +163,6 @@ also displayed in the mode line next to \"Antlr\"."
Looks like \(LIMIT . REGEXP). Search for REGEXP from the beginning of
the buffer to LIMIT and use the first group in the matched string to set
the language according to `antlr-language-alist'."
- :group 'antlr
:type '(cons (choice :tag "Limit" (const :tag "No" nil) (integer :value 0))
regexp))
@@ -259,7 +176,6 @@ the language according to `antlr-language-alist'."
If nil, the actions with their surrounding braces are hidden. If a
number, do not hide the braces, only hide the contents if its length is
greater than this number."
- :group 'antlr
:type '(choice (const :tag "Completely hidden" nil)
(integer :tag "Hidden if longer than" :value 3)))
@@ -268,7 +184,6 @@ greater than this number."
If nil, no continuation line of a block comment is changed. If t, they
are changed according to `c-indentation-line'. When not nil and not t,
they are only changed by \\[antlr-indent-command]."
- :group 'antlr
:type '(radio (const :tag "No" nil)
(const :tag "Always" t)
(sexp :tag "With TAB" :format "%t" :value tab)))
@@ -282,7 +197,6 @@ The first element whose MAJOR-MODE is nil or equal to `major-mode' and
whose REGEXP is nil or matches variable `buffer-file-name' is used to
set `tab-width' and `indent-tabs-mode'. This is useful to support both
ANTLR's and Java's indentation styles. Used by `antlr-set-tabs'."
- :group 'antlr
:type '(repeat (group :value (antlr-mode nil 8 nil)
(choice (const :tag "All" nil)
(function :tag "Major mode"))
@@ -294,14 +208,12 @@ ANTLR's and Java's indentation styles. Used by `antlr-set-tabs'."
"If non-nil, cc-mode indentation style used for `antlr-mode'.
See `c-set-style' and for details, where the most interesting part in
`c-style-alist' is the value of `c-basic-offset'."
- :group 'antlr
:type '(choice (const nil) regexp))
(defcustom antlr-indent-item-regexp
"[]}):;|&]" ; & is local ANTLR extension (SGML's and-connector)
"Regexp matching lines which should be indented by one TAB less.
See `antlr-indent-line' and command \\[antlr-indent-command]."
- :group 'antlr
:type 'regexp)
(defcustom antlr-indent-at-bol-alist
@@ -316,7 +228,6 @@ If `antlr-language' equals to a MODE, the line starting at the first
non-whitespace is matched by the corresponding REGEXP, and the line is
part of a header action, indent the line at column 0 instead according
to the normal rules of `antlr-indent-line'."
- :group 'antlr
:type '(repeat (cons (function :tag "Major mode") regexp)))
;; adopt indentation to cc-engine
@@ -337,7 +248,6 @@ to the normal rules of `antlr-indent-line'."
"Non-nil, if the major mode menu should include option submenus.
If nil, the menu just includes a command to insert options. Otherwise,
it includes four submenus to insert file/grammar/rule/subrule options."
- :group 'antlr
:type 'boolean)
(defcustom antlr-tool-version 20701
@@ -349,7 +259,6 @@ version correct option values when using \\[antlr-insert-option].
Don't use a number smaller than 20600 since the stored history of
Antlr's options starts with v2.06.00, see `antlr-options-alists'. You
can make this variable buffer-local."
- :group 'antlr
:type 'integer)
(defcustom antlr-options-auto-colon t
@@ -358,7 +267,6 @@ A `:' is only inserted if this value is non-nil, if a rule or subrule
option is inserted with \\[antlr-insert-option], if there was no rule or
subrule options section before, and if a `:' is not already present
after the section, ignoring whitespace, comments and the init action."
- :group 'antlr
:type 'boolean)
(defcustom antlr-options-style nil
@@ -369,7 +277,6 @@ identifier.
The only style symbol used in the default value of `antlr-options-alist'
is `language-as-string'. See also `antlr-read-value'."
- :group 'antlr
:type '(repeat (symbol :tag "Style symbol")))
(defcustom antlr-options-push-mark t
@@ -380,7 +287,6 @@ number, only set mark if point was outside the options area before and
the number of lines between point and the insert position is greater
than this value. Otherwise, only set mark if point was outside the
options area before."
- :group 'antlr
:type '(radio (const :tag "No" nil)
(const :tag "Always" t)
(integer :tag "Lines between" :value 10)
@@ -391,7 +297,6 @@ options area before."
This string is only used if the option to insert did not exist before
or if there was no `=' after it. In other words, the spacing around an
existing `=' won't be changed when changing an option value."
- :group 'antlr
:type 'string)
@@ -576,13 +481,11 @@ AS-STRING is non-nil and is either t or a symbol which is a member of
"Command used in \\[antlr-run-tool] to run the Antlr tool.
This variable should include all options passed to Antlr except the
option \"-glib\" which is automatically suggested if necessary."
- :group 'antlr
:type 'string)
(defcustom antlr-ask-about-save t
"If not nil, \\[antlr-run-tool] asks which buffers to save.
Otherwise, it saves all modified buffers before running without asking."
- :group 'antlr
:type 'boolean)
(defcustom antlr-makefile-specification
@@ -604,7 +507,6 @@ Then, GEN-VAR is a string with the name of the variable which contains
the file names of all makefile rules. GEN-VAR-FORMAT is a format string
producing the variable of each target with substitution COUNT/%d where
COUNT starts with 1. GEN-SEP is used to separate long variable values."
- :group 'antlr
:type '(list (string :tag "Rule separator")
(choice
(const :tag "Direct targets" nil)
@@ -683,7 +585,6 @@ DIRECTORY is the name of the current directory.")
"Non-nil, if a \"Index\" menu should be added to the menubar.
If it is a string, it is used instead \"Index\". Requires package
imenu."
- :group 'antlr
:type '(choice (const :tag "No menu" nil)
(const :tag "Index menu" t)
(string :tag "Other menu name")))
@@ -695,7 +596,7 @@ imenu."
(define-key map "\e\C-e" 'antlr-end-of-rule)
(define-key map "\C-c\C-a" 'antlr-beginning-of-body)
(define-key map "\C-c\C-e" 'antlr-end-of-body)
- (define-key map "\C-c\C-f" 'c-forward-into-nomenclature)
+ (define-key map "\C-c\C-f" 'subword-forward)
(define-key map "\C-c\C-b" 'c-backward-into-nomenclature)
(define-key map "\C-c\C-c" 'comment-region)
(define-key map "\C-c\C-v" 'antlr-hide-actions)
@@ -719,10 +620,7 @@ imenu."
(easy-menu-define antlr-mode-menu antlr-mode-map
"Major mode menu."
`("Antlr"
- ,@(if (cond-emacs-xemacs
- :EMACS (and antlr-options-use-submenus
- (>= emacs-major-version 21))
- :XEMACS antlr-options-use-submenus)
+ ,@(if antlr-options-use-submenus
`(("Insert File Option"
:filter ,(lambda (x) (antlr-options-menu-filter 1 x)))
("Insert Grammar Option"
@@ -745,7 +643,7 @@ imenu."
["Backward Statement" c-beginning-of-statement t]
["Forward Statement" c-end-of-statement t]
["Backward Into Nomencl." c-backward-into-nomenclature t]
- ["Forward Into Nomencl." c-forward-into-nomenclature t])
+ ["Forward Into Nomencl." subword-forward t])
["Indent Region" indent-region
:active (and (not buffer-read-only) (c-region-is-active-p))]
["Comment Out Region" comment-region
@@ -781,7 +679,6 @@ bound to `antlr-language'. For example, with value
((java-mode . 2) (c++-mode . 0))
Java actions are fontified with level 2 and C++ actions are not
fontified at all."
- :group 'antlr
:type '(choice (const :tag "None" none)
(const :tag "Inherit" inherit)
(const :tag "Default" nil)
@@ -825,62 +722,49 @@ in the grammar's actions and semantic predicates, see
(defface antlr-default '((t nil))
"Face to prevent strings from language dependent highlighting.
-Do not change."
- :group 'antlr)
+Do not change.")
(defface antlr-keyword
- (cond-emacs-xemacs
- '((((class color) (background light))
- (:foreground "black" :EMACS :weight bold :XEMACS :bold t))
- (t :inherit font-lock-keyword-face)))
- "ANTLR keywords."
- :group 'antlr)
+ '((((class color) (background light))
+ (:foreground "black" :weight bold))
+ (t :inherit font-lock-keyword-face))
+ "ANTLR keywords.")
(defface antlr-syntax
- (cond-emacs-xemacs
- '((((class color) (background light))
- (:foreground "black" :EMACS :weight bold :XEMACS :bold t))
- (t :inherit font-lock-constant-face)))
- "ANTLR syntax symbols like :, |, (, ), ...."
- :group 'antlr)
+ '((((class color) (background light))
+ (:foreground "black" :weight bold))
+ (t :inherit font-lock-constant-face))
+ "ANTLR syntax symbols like :, |, (, ), ....")
(defface antlr-ruledef
- (cond-emacs-xemacs
- '((((class color) (background light))
- (:foreground "blue" :EMACS :weight bold :XEMACS :bold t))
- (t :inherit font-lock-function-name-face)))
- "ANTLR rule references (definition)."
- :group 'antlr)
+ '((((class color) (background light))
+ (:foreground "blue" :weight bold))
+ (t :inherit font-lock-function-name-face))
+ "ANTLR rule references (definition).")
(defface antlr-tokendef
- (cond-emacs-xemacs
- '((((class color) (background light))
- (:foreground "blue" :EMACS :weight bold :XEMACS :bold t))
- (t :inherit font-lock-function-name-face)))
- "ANTLR token references (definition)."
- :group 'antlr)
+ '((((class color) (background light))
+ (:foreground "blue" :weight bold))
+ (t :inherit font-lock-function-name-face))
+ "ANTLR token references (definition).")
(defface antlr-ruleref
'((((class color) (background light)) (:foreground "blue4"))
(t :inherit font-lock-type-face))
- "ANTLR rule references (usage)."
- :group 'antlr)
+ "ANTLR rule references (usage).")
(defface antlr-tokenref
'((((class color) (background light)) (:foreground "orange4"))
(t :inherit font-lock-type-face))
- "ANTLR token references (usage)."
- :group 'antlr)
+ "ANTLR token references (usage).")
(defface antlr-literal
- (cond-emacs-xemacs
- '((((class color) (background light))
- (:foreground "brown4" :EMACS :weight bold :XEMACS :bold t))
- (t :inherit font-lock-string-face)))
+ '((((class color) (background light))
+ (:foreground "brown4" :weight bold))
+ (t :inherit font-lock-string-face))
"ANTLR special literal tokens.
It is used to highlight strings matched by the first regexp group of
-`antlr-font-lock-literal-regexp'."
- :group 'antlr)
+`antlr-font-lock-literal-regexp'.")
(defcustom antlr-font-lock-literal-regexp "\"\\(\\sw\\(\\sw\\|-\\)*\\)\""
"Regexp matching literals with special syntax highlighting, or nil.
@@ -888,7 +772,6 @@ If nil, there is no special syntax highlighting for some literals.
Otherwise, it should be a regular expression which must contain a regexp
group. The string matched by the first group is highlighted with
`antlr-font-lock-literal-face'."
- :group 'antlr
:type '(choice (const :tag "None" nil) regexp))
(defvar antlr-class-header-regexp
@@ -896,50 +779,48 @@ group. The string matched by the first group is highlighted with
"Regexp matching class headers.")
(defvar antlr-font-lock-additional-keywords
- (cond-emacs-xemacs
- `((antlr-invalidate-context-cache)
- ("\\$setType[ \t]*(\\([A-Za-z\300-\326\330-\337]\\sw*\\))"
- (1 'antlr-tokendef))
- ("\\$\\sw+" (0 'antlr-keyword))
- ;; the tokens are already fontified as string/docstrings:
- (,(lambda (limit)
- (if antlr-font-lock-literal-regexp
- (antlr-re-search-forward antlr-font-lock-literal-regexp limit)))
- (1 'antlr-literal t)
- :XEMACS (0 nil)) ; XEmacs bug workaround
- (,(lambda (limit)
- (antlr-re-search-forward antlr-class-header-regexp limit))
- (1 'antlr-keyword)
- (2 'antlr-ruledef)
- (3 'antlr-keyword)
- (4 (if (member (match-string 4) '("Lexer" "Parser" "TreeParser"))
- 'antlr-keyword
- 'font-lock-type-face)))
- (,(lambda (limit)
- (antlr-re-search-forward
- "\\<\\(header\\|options\\|tokens\\|exception\\|catch\\|returns\\)\\>"
- limit))
+ `((antlr-invalidate-context-cache)
+ ("\\$setType[ \t]*(\\([A-Za-z\300-\326\330-\337]\\sw*\\))"
+ (1 'antlr-tokendef))
+ ("\\$\\sw+" (0 'antlr-keyword))
+ ;; the tokens are already fontified as string/docstrings:
+ (,(lambda (limit)
+ (if antlr-font-lock-literal-regexp
+ (antlr-re-search-forward antlr-font-lock-literal-regexp limit)))
+ (1 'antlr-literal t))
+ (,(lambda (limit)
+ (antlr-re-search-forward antlr-class-header-regexp limit))
+ (1 'antlr-keyword)
+ (2 'antlr-ruledef)
+ (3 'antlr-keyword)
+ (4 (if (member (match-string 4) '("Lexer" "Parser" "TreeParser"))
+ 'antlr-keyword
+ 'font-lock-type-face)))
+ (,(lambda (limit)
+ (antlr-re-search-forward
+ "\\<\\(header\\|options\\|tokens\\|exception\\|catch\\|returns\\)\\>"
+ limit))
(1 'antlr-keyword))
- (,(lambda (limit)
- (antlr-re-search-forward
- "^\\(private\\|public\\|protected\\)\\>[ \t]*\\(\\(\\sw+[ \t]*\\(:\\)?\\)\\)?"
- limit))
- (1 'font-lock-type-face) ; not XEmacs's java level-3 fruit salad
+ (,(lambda (limit)
+ (antlr-re-search-forward
+ "^\\(private\\|public\\|protected\\)\\>[ \t]*\\(\\(\\sw+[ \t]*\\(:\\)?\\)\\)?"
+ limit))
+ (1 'font-lock-type-face) ; not XEmacs's java level-3 fruit salad
(3 (if (antlr-upcase-p (char-after (match-beginning 3)))
'antlr-tokendef
'antlr-ruledef)
nil t)
(4 'antlr-syntax nil t))
- (,(lambda (limit)
- (antlr-re-search-forward "^\\(\\sw+\\)[ \t]*\\(:\\)?" limit))
+ (,(lambda (limit)
+ (antlr-re-search-forward "^\\(\\sw+\\)[ \t]*\\(:\\)?" limit))
(1 (if (antlr-upcase-p (char-after (match-beginning 0)))
'antlr-tokendef
'antlr-ruledef)
nil t)
(2 'antlr-syntax nil t))
- (,(lambda (limit)
- ;; v:ruleref and v:"literal" is allowed...
- (antlr-re-search-forward "\\(\\sw+\\)[ \t]*\\([=:]\\)?" limit))
+ (,(lambda (limit)
+ ;; v:ruleref and v:"literal" is allowed...
+ (antlr-re-search-forward "\\(\\sw+\\)[ \t]*\\([=:]\\)?" limit))
(1 (if (match-beginning 2)
(if (eq (char-after (match-beginning 2)) ?=)
'antlr-default
@@ -948,9 +829,9 @@ group. The string matched by the first group is highlighted with
'antlr-tokenref
'antlr-ruleref)))
(2 'antlr-default nil t))
- (,(lambda (limit)
- (antlr-re-search-forward "[|&:;(~]\\|)\\([*+?]\\|=>\\)?" limit))
- (0 'antlr-syntax))))
+ (,(lambda (limit)
+ (antlr-re-search-forward "[|&:;(~]\\|)\\([*+?]\\|=>\\)?" limit))
+ (0 'antlr-syntax)))
"Font-lock keywords for ANTLR's normal grammar code.
See `antlr-font-lock-keywords-alist' for the keywords of actions.")
@@ -1016,35 +897,6 @@ Used for `antlr-slow-syntactic-context'.")
;;; Syntax functions -- Emacs vs XEmacs dependent, part 1
;;;===========================================================================
-;; From help.el (XEmacs-21.1), without `copy-syntax-table'
-(defmacro antlr-with-syntax-table (syntab &rest body)
- "Evaluate BODY with the syntax table SYNTAB."
- `(let ((stab (syntax-table)))
- (unwind-protect
- (progn (set-syntax-table ,syntab) ,@body)
- (set-syntax-table stab))))
-(put 'antlr-with-syntax-table 'lisp-indent-function 1)
-(put 'antlr-with-syntax-table 'edebug-form-spec '(form body))
-
-(defunx antlr-default-directory ()
- :xemacs-and-try default-directory
- "Return `default-directory'."
- default-directory)
-
-;; Check Emacs-21.1 simple.el, `shell-command'.
-(defunx antlr-read-shell-command (prompt &optional initial-input history)
- :xemacs-and-try read-shell-command
- "Read a string from the minibuffer, using `shell-command-history'."
- (read-from-minibuffer prompt initial-input nil nil
- (or history 'shell-command-history)))
-
-(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*"
- (save-excursion (funcall thunk))))
-
-
;;;===========================================================================
;;; Context cache
;;;===========================================================================
@@ -1057,26 +909,18 @@ Used for `antlr-slow-syntactic-context'.")
;;;(defvar antlr-statistics-cache 0)
;;;(defvar antlr-statistics-inval 0)
-(defunx antlr-invalidate-context-cache (&rest _dummies)
+(defun antlr-invalidate-context-cache (&rest _dummies)
;; checkdoc-params: (dummies)
"Invalidate context cache for syntactical context information."
- :XEMACS ; XEmacs bug workaround
- (with-current-buffer (get-buffer-create " ANTLR XEmacs bug workaround")
- (buffer-syntactic-context-depth)
- nil)
- :EMACS
;;; (cl-incf antlr-statistics-inval)
(setq antlr-slow-context-cache nil))
-(defunx antlr-syntactic-context ()
+(defun antlr-syntactic-context ()
"Return some syntactic context information.
Return `string' if point is within a string, `block-comment' or
`comment' is point is within a comment or the depth within all
parenthesis-syntax delimiters at point otherwise.
WARNING: this may alter `match-data'."
- :XEMACS
- (or (buffer-syntactic-context) (buffer-syntactic-context-depth))
- :EMACS
(let ((orig (point)) diff state
;; Arg, Emacs's (buffer-modified-tick) changes with font-lock. Use
;; hack that `loudly' is bound during font-locking => cache use will
@@ -1095,9 +939,9 @@ WARNING: this may alter `match-data'."
(if (>= orig antlr-slow-cache-diff-threshold)
(beginning-of-defun)
(goto-char (point-min)))
-;;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg))
-;;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff))
-;;; (t (cl-incf antlr-statistics-full-other)))
+ ;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg))
+ ;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff))
+ ;; (t (cl-incf antlr-statistics-full-other)))
(setq state (parse-partial-sexp (point) orig)))
(goto-char orig)
(if antlr-slow-context-cache
@@ -1109,52 +953,52 @@ WARNING: this may alter `match-data'."
((nth 4 state) 'comment) ; block-comment? -- we don't care
(t (car state)))))
-;;; (cl-incf (aref antlr-statistics 2))
-;;; (unless (and (eq (current-buffer)
-;;; (caar antlr-slow-context-cache))
-;;; (eq (buffer-modified-tick)
-;;; (cdar antlr-slow-context-cache)))
-;;; (cl-incf (aref antlr-statistics 1))
-;;; (setq antlr-slow-context-cache nil))
-;;; (let* ((orig (point))
-;;; (base (cadr antlr-slow-context-cache))
-;;; (curr (cddr antlr-slow-context-cache))
-;;; (state (cond ((eq orig (car curr)) (cdr curr))
-;;; ((eq orig (car base)) (cdr base))))
-;;; diff diff2)
-;;; (unless state
-;;; (cl-incf (aref antlr-statistics 3))
-;;; (when curr
-;;; (if (< (setq diff (abs (- orig (car curr))))
-;;; (setq diff2 (abs (- orig (car base)))))
-;;; (setq state curr)
-;;; (setq state base
-;;; diff diff2))
-;;; (if (or (>= (1+ diff) (point)) (>= diff 3000))
-;;; (setq state nil))) ; start from bod/bob
-;;; (if state
-;;; (setq state
-;;; (parse-partial-sexp (car state) orig nil nil (cdr state)))
-;;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min)))
-;;; (cl-incf (aref antlr-statistics 4))
-;;; (setq cw (list orig (point) base curr))
-;;; (setq state (parse-partial-sexp (point) orig)))
-;;; (goto-char orig)
-;;; (if antlr-slow-context-cache
-;;; (setcdr (cdr antlr-slow-context-cache) (cons orig state))
-;;; (setq antlr-slow-context-cache
-;;; (cons (cons (current-buffer) (buffer-modified-tick))
-;;; (cons (cons orig state) (cons orig state))))))
-;;; (cond ((nth 3 state) 'string)
-;;; ((nth 4 state) 'comment) ; block-comment? -- we don't care
-;;; (t (car state)))))
-
-;;; (beginning-of-defun)
-;;; (let ((state (parse-partial-sexp (point) orig)))
-;;; (goto-char orig)
-;;; (cond ((nth 3 state) 'string)
-;;; ((nth 4 state) 'comment) ; block-comment? -- we don't care
-;;; (t (car state))))))
+;; (cl-incf (aref antlr-statistics 2))
+;; (unless (and (eq (current-buffer)
+;; (caar antlr-slow-context-cache))
+;; (eq (buffer-modified-tick)
+;; (cdar antlr-slow-context-cache)))
+;; (cl-incf (aref antlr-statistics 1))
+;; (setq antlr-slow-context-cache nil))
+;; (let* ((orig (point))
+;; (base (cadr antlr-slow-context-cache))
+;; (curr (cddr antlr-slow-context-cache))
+;; (state (cond ((eq orig (car curr)) (cdr curr))
+;; ((eq orig (car base)) (cdr base))))
+;; diff diff2)
+;; (unless state
+;; (cl-incf (aref antlr-statistics 3))
+;; (when curr
+;; (if (< (setq diff (abs (- orig (car curr))))
+;; (setq diff2 (abs (- orig (car base)))))
+;; (setq state curr)
+;; (setq state base
+;; diff diff2))
+;; (if (or (>= (1+ diff) (point)) (>= diff 3000))
+;; (setq state nil))) ; start from bod/bob
+;; (if state
+;; (setq state
+;; (parse-partial-sexp (car state) orig nil nil (cdr state)))
+;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min)))
+;; (cl-incf (aref antlr-statistics 4))
+;; (setq cw (list orig (point) base curr))
+;; (setq state (parse-partial-sexp (point) orig)))
+;; (goto-char orig)
+;; (if antlr-slow-context-cache
+;; (setcdr (cdr antlr-slow-context-cache) (cons orig state))
+;; (setq antlr-slow-context-cache
+;; (cons (cons (current-buffer) (buffer-modified-tick))
+;; (cons (cons orig state) (cons orig state))))))
+;; (cond ((nth 3 state) 'string)
+;; ((nth 4 state) 'comment) ; block-comment? -- we don't care
+;; (t (car state)))))
+
+;; (beginning-of-defun)
+;; (let ((state (parse-partial-sexp (point) orig)))
+;; (goto-char orig)
+;; (cond ((nth 3 state) 'string)
+;; ((nth 4 state) 'comment) ; block-comment? -- we don't care
+;; (t (car state))))))
;;;===========================================================================
@@ -1208,7 +1052,7 @@ strings and actions/semantic predicates."
(defsubst antlr-skip-sexps (count)
"Skip the next COUNT balanced expressions and the comments after it.
Return position before the comments after the last expression."
- (goto-char (or (ignore-errors-x (scan-sexps (point) count)) (point-max)))
+ (goto-char (or (ignore-errors (scan-sexps (point) count)) (point-max)))
(prog1 (point)
(antlr-c-forward-sws)))
@@ -1230,7 +1074,8 @@ See `antlr-font-lock-additional-keywords', `antlr-language' and
antlr-font-lock-keywords-alist))
(if (eq antlr-font-lock-maximum-decoration 'inherit)
font-lock-maximum-decoration
- antlr-font-lock-maximum-decoration)))))))
+ antlr-font-lock-maximum-decoration)))
+ t))))
;;;===========================================================================
@@ -1247,10 +1092,9 @@ IF TOKENREFS-ONLY is non-nil, just return alist with tokenref names."
(let ((items nil)
(classes nil)
(continue t))
- ;; Using `imenu-progress-message' would require imenu for compilation, but
- ;; nobody is missing these messages. The generic imenu function searches
- ;; backward, which is slower and more likely not to work during editing.
- (antlr-with-syntax-table antlr-action-syntax-table
+ ;; The generic imenu function searches backward, which is slower
+ ;; and more likely not to work during editing.
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(goto-char (point-min))
(antlr-skip-file-prelude t)
@@ -1394,37 +1238,37 @@ Move to the beginning of the current rule if point is inside a rule."
A grammar class header and the file prelude are also considered as a
rule."
(save-excursion
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(not (antlr-outside-rule-p)))))
-(defunx antlr-end-of-rule (&optional arg)
+(defun antlr-end-of-rule (&optional arg)
"Move forward to next end of rule. Do it ARG [default: 1] many times.
A grammar class header and the file prelude are also considered as a
rule. Negative argument ARG means move back to ARGth preceding end of
rule. If ARG is zero, run `antlr-end-of-body'."
- (interactive "_p")
+ (interactive "^p")
(if (zerop arg)
(antlr-end-of-body)
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-next-rule arg nil))))
-(defunx antlr-beginning-of-rule (&optional arg)
+(defun antlr-beginning-of-rule (&optional arg)
"Move backward to preceding beginning of rule. Do it ARG many times.
A grammar class header and the file prelude are also considered as a
rule. Negative argument ARG means move forward to ARGth next beginning
of rule. If ARG is zero, run `antlr-beginning-of-body'."
- (interactive "_p")
+ (interactive "^p")
(if (zerop arg)
(antlr-beginning-of-body)
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-next-rule (- arg) t))))
-(defunx antlr-end-of-body (&optional msg)
+(defun antlr-end-of-body (&optional msg)
"Move to position after the `;' of the current rule.
A grammar class header is also considered as a rule. With optional
prefix arg MSG, move to `:'."
- (interactive "_")
- (antlr-with-syntax-table antlr-action-syntax-table
+ (interactive "^")
+ (with-syntax-table antlr-action-syntax-table
(let ((orig (point)))
(if (antlr-outside-rule-p)
(error "Outside an ANTLR rule"))
@@ -1442,9 +1286,9 @@ prefix arg MSG, move to `:'."
(error msg))
(antlr-c-forward-sws))))))
-(defunx antlr-beginning-of-body ()
+(defun antlr-beginning-of-body ()
"Move to the first element after the `:' of the current rule."
- (interactive "_")
+ (interactive "^")
(antlr-end-of-body "Class headers and the file prelude are without `:'"))
@@ -1460,7 +1304,7 @@ If non-nil, TRANSFORM is used on literals instead of `downcase-region'."
(let ((literals 0))
(save-excursion
(goto-char (point-min))
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(while (antlr-re-search-forward "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" nil)
(funcall transform (match-beginning 0) (match-end 0))
@@ -1489,10 +1333,10 @@ Display a message unless optional argument SILENT is non-nil."
(antlr-hide-actions 0 t)
(save-excursion
(goto-char (point-min))
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(while (antlr-re-search-forward regexp nil)
- (let ((beg (ignore-errors-x (scan-sexps (point) -1))))
+ (let ((beg (ignore-errors (scan-sexps (point) -1))))
(when beg
(if diff ; braces are visible
(if (> (point) (+ beg diff))
@@ -1685,7 +1529,7 @@ like \(AREA . PLACE), see `antlr-option-location'."
(cond ((null pos) 'error)
((looking-at "options[ \t\n]*{")
(goto-char (match-end 0))
- (setq pos (ignore-errors-x (scan-lists (point) 1 1)))
+ (setq pos (ignore-errors (scan-lists (point) 1 1)))
(antlr-option-location orig min0 max0
(point)
(if pos (1- pos) (point-max))
@@ -1710,7 +1554,7 @@ is undefined."
(widen)
(if (eq requested 1)
1
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(let* ((orig (point))
(outsidep (antlr-outside-rule-p))
@@ -2048,7 +1892,7 @@ Called in PHASE `after-insertion', see `antlr-options-alists'."
(let ((new-language (antlr-language-option t)))
(or (null new-language)
(eq new-language antlr-language)
- (let ((font-lock (and (boundp 'font-lock-mode) font-lock-mode)))
+ (let ((font-lock font-lock-mode))
(if font-lock (font-lock-mode 0))
(antlr-mode)
(and font-lock (null font-lock-mode) (font-lock-mode 1)))))))
@@ -2088,7 +1932,7 @@ its export vocabulary is used as an import vocabulary."
(unless buffer-file-name
(error "Grammar buffer does not visit a file"))
(let (classes export-vocabs import-vocabs superclasses default-vocab)
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(goto-char (point-min))
(while (antlr-re-search-forward antlr-class-header-regexp nil)
;; parse class definition --------------------------------------------
@@ -2241,9 +2085,9 @@ Use prefix argument ARG to return \(COMMAND FILE SAVED)."
(setq glibs (car (antlr-superclasses-glibs
supers
(car (antlr-directory-dependencies
- (antlr-default-directory)))))))
- (list (antlr-read-shell-command "Run Antlr on current file with: "
- (concat antlr-tool-command glibs " "))
+ default-directory))))))
+ (list (read-shell-command "Run Antlr on current file with: "
+ (concat antlr-tool-command glibs " "))
buffer-file-name
supers)))
@@ -2265,7 +2109,7 @@ Also insert strings PRE and POST before and after the variable."
"Insert Makefile rules in the current buffer at point.
IN-MAKEFILE is non-nil, if the current buffer is the Makefile. See
command `antlr-show-makefile-rules' for detail."
- (let* ((dirname (antlr-default-directory))
+ (let* ((dirname default-directory)
(deps0 (antlr-directory-dependencies dirname))
(classes (car deps0)) ; CLASS -> (FILE . EVOCAB) ...
(deps (cdr deps0)) ; FILE -> (c . s) (ev . iv) . LANGUAGE
@@ -2344,7 +2188,9 @@ 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 (derived-mode-p 'makefile-mode))
- (antlr-with-displaying-help-buffer 'antlr-insert-makefile-rules)
+ (with-output-to-temp-buffer "*Help*"
+ (save-excursion
+ (antlr-insert-makefile-rules)))
(push-mark)
(antlr-insert-makefile-rules t)))
@@ -2387,7 +2233,7 @@ to a lesser extent, `antlr-tab-offset-alist'."
(skip-chars-forward " \t")
(setq boi (point))
;; check syntax at beginning of indentation ----------------------------
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(setq syntax (antlr-syntactic-context))
(cond ((symbolp syntax)
@@ -2483,7 +2329,7 @@ ANTLR's syntax and influences the auto indentation, see
(interactive "*P")
(if (or arg
(save-excursion (skip-chars-backward " \t") (not (bolp)))
- (antlr-with-syntax-table antlr-action-syntax-table
+ (with-syntax-table antlr-action-syntax-table
(antlr-invalidate-context-cache)
(let ((context (antlr-syntactic-context)))
(not (and (numberp context)
@@ -2526,7 +2372,7 @@ ANTLR's syntax and influences the auto indentation, see
(while settings
(when (boundp (car settings))
(ignore-errors
- (set (car settings) (eval (cadr settings)))))
+ (set (car settings) (eval (cadr settings) t))))
(setq settings (cddr settings)))))
(defun antlr-language-option (search)
@@ -2573,29 +2419,21 @@ the default language."
(cadr (assq antlr-language antlr-language-alist)))))
;; indentation, for the C engine -------------------------------------------
(setq c-buffer-is-cc-mode antlr-language)
- (cond ((fboundp 'c-init-language-vars-for) ; cc-mode 5.30.5+
- (c-init-language-vars-for antlr-language))
- ((fboundp 'c-init-c-language-vars) ; cc-mode 5.30 to 5.30.4
- (c-init-c-language-vars) ; not perfect, but OK
- (setq c-recognize-knr-p nil))
- ((fboundp 'c-init-language-vars) ; cc-mode 5.29
- (let ((init-fn 'c-init-language-vars))
- (funcall init-fn))) ; is a function in v5.29
- (t ; cc-mode upto 5.28
- (antlr-c-init-language-vars))) ; do it myself
+ (c-init-language-vars-for antlr-language)
(c-basic-common-init antlr-language (or antlr-indent-style "gnu"))
(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 '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 -----------------------------------------------------------------
(set (make-local-variable 'font-lock-defaults) antlr-font-lock-defaults)
- (easy-menu-add antlr-mode-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add antlr-mode-menu))
(set (make-local-variable 'imenu-create-index-function)
- 'antlr-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)
@@ -2625,6 +2463,6 @@ Used in `antlr-mode'. Also a useful function in `java-mode-hook'."
(provide 'antlr-mode)
-;;; Local IspellPersDict: .ispell_antlr
+;; Local IspellPersDict: .ispell_antlr
;;; antlr-mode.el ends here
diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el
index 62ff783fbac..2f7d7bf7966 100644
--- a/lisp/progmodes/asm-mode.el
+++ b/lisp/progmodes/asm-mode.el
@@ -73,19 +73,19 @@
;; Note that the comment character isn't set up until asm-mode is called.
(define-key map ":" 'asm-colon)
(define-key map "\C-c;" '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 [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 [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.")
+(easy-menu-define asm-mode-menu asm-mode-map
+ "Menu for Asm mode."
+ '("Asm"
+ ["Insert Colon" asm-colon
+ :help "Insert a colon; if it follows a label, delete the label's indentation"]
+ ["Insert Newline and Indent" newline-and-indent
+ :help "Insert a newline, then indent according to major mode"]
+ ["Comment Region" comment-region
+ :help "Comment or uncomment each line in the region"]))
+
(defconst asm-font-lock-keywords
(append
'(("^\\(\\(\\sw\\|\\s_\\)+\\)\\>:?[ \t]*\\(\\sw+\\(\\.\\sw+\\)*\\)?"
@@ -141,8 +141,7 @@ Special commands:
(setq-local comment-add 1)
(setq-local comment-start-skip "\\(?:\\s<+\\|/[/*]+\\)[ \t]*")
(setq-local comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)")
- (setq-local comment-end "")
- (setq fill-prefix "\t"))
+ (setq-local comment-end ""))
(defun asm-indent-line ()
"Auto-indent the current line."
diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el
index bd1176a0787..73cf290f43c 100644
--- a/lisp/progmodes/autoconf.el
+++ b/lisp/progmodes/autoconf.el
@@ -1,4 +1,4 @@
-;;; autoconf.el --- mode for editing Autoconf configure.ac files
+;;; autoconf.el --- mode for editing Autoconf configure.ac files -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/bat-mode.el b/lisp/progmodes/bat-mode.el
index 8763885aea4..7ba8a69775e 100644
--- a/lisp/progmodes/bat-mode.el
+++ b/lisp/progmodes/bat-mode.el
@@ -1,4 +1,4 @@
-;;; bat-mode.el --- Major mode for editing DOS/Windows scripts
+;;; bat-mode.el --- Major mode for editing DOS/Windows scripts -*- lexical-binding: t -*-
;; Copyright (C) 2003, 2008-2021 Free Software Foundation, Inc.
@@ -42,7 +42,7 @@
;; See documentation of function `bat-mode'.
;;
;; Separate package `dos-indent' (Matthew Fidler) provides rudimentary
-;; indentation, see http://www.emacswiki.org/emacs/dos-indent.el.
+;; indentation, see https://www.emacswiki.org/emacs/dos-indent.el.
;;
;; Acknowledgements:
;;
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index eeb1060564a..9b9c58eb1f2 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -1,4 +1,4 @@
-;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
+;;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -25,10 +25,13 @@
;; This file provides minor modes for putting clickable overlays on
;; references to bugs. A bug reference is text like "PR foo/29292";
-;; this is mapped to a URL using a user-supplied format.
+;; this is mapped to a URL using a user-supplied format; see
+;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More
+;; extensive documentation is in (info "(emacs) Bug Reference").
;; Two minor modes are provided. One works on any text in the buffer;
-;; the other operates only on comments and strings.
+;; the other operates only on comments and strings. By default, the
+;; URL link is followed by invoking C-c RET or mouse-2.
;;; Code:
@@ -72,9 +75,8 @@ so that it is considered safe, see `enable-local-variables'.")
"\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
"Regular expression matching bug references.
The second subexpression should match the bug reference (usually a number)."
- :type 'string
- :version "24.3" ; previously defconst
- :group 'bug-reference)
+ :type 'regexp
+ :version "24.3") ; previously defconst
;;;###autoload
(put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
@@ -127,6 +129,9 @@ The second subexpression should match the bug reference (usually a number)."
"Open URL corresponding to the bug reference at POS."
(interactive
(list (if (integerp last-command-event) (point) last-command-event)))
+ (when (null bug-reference-url-format)
+ (user-error
+ "You must customize some bug-reference variables; see Emacs info node Bug Reference"))
(if (and (not (integerp pos)) (eventp pos))
;; POS is a mouse event; switch to the proper window/buffer
(let ((posn (event-start pos)))
@@ -139,12 +144,383 @@ The second subexpression should match the bug reference (usually a number)."
(when url
(browse-url url))))))
+(defun bug-reference-maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt)
+ (when (string-match url-rx url)
+ (setq-local bug-reference-bug-regexp bug-rx)
+ (setq-local bug-reference-url-format
+ (let (groups)
+ (dotimes (i (/ (length (match-data)) 2))
+ (push (match-string i url) groups))
+ (funcall bug-url-fmt (nreverse groups))))))
+
+(defvar bug-reference-setup-from-vc-alist
+ `(;;
+ ;; GNU projects on savannah.
+ ;;
+ ;; Not all of them use debbugs but that doesn't really matter
+ ;; because the auto-setup is only performed if
+ ;; `bug-reference-url-format' and `bug-reference-bug-regexp'
+ ;; aren't set already.
+ ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
+ "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>"
+ ,(lambda (_) "https://debbugs.gnu.org/%s"))
+ ;;
+ ;; GitHub projects.
+ ;;
+ ;; Here #17 may refer to either an issue or a pull request but
+ ;; visiting the issue/17 web page will automatically redirect to
+ ;; the pull/17 page if 17 is a PR. Explicit user/project#17 links
+ ;; to possibly different projects are also supported.
+ ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://github.com/"
+ (or
+ ;; Explicit user/proj#18 link.
+ (match-string 1)
+ ns-project)
+ "/issues/"
+ (match-string 2))))))
+ ;;
+ ;; Codeberg projects.
+ ;;
+ ;; The systematics is exactly as for Github projects.
+ ("[/@]codeberg.org[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://codeberg.org/"
+ (or
+ ;; Explicit user/proj#18 link.
+ (match-string 1)
+ ns-project)
+ "/issues/"
+ (match-string 2))))))
+ ;;
+ ;; GitLab projects.
+ ;;
+ ;; Here #18 is an issue and !17 is a merge request. Explicit
+ ;; namespace/project#18 or namespace/project!17 references to
+ ;; possibly different projects are also supported.
+ ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://gitlab.com/"
+ (or (match-string 1)
+ ns-project)
+ "/-/"
+ (if (string= (match-string 3) "#")
+ "issues/"
+ "merge_requests/")
+ (match-string 2))))))
+ ;;
+ ;; Sourcehut projects.
+ ;;
+ ;; #19 is an issue. Other project's issues can be referenced as
+ ;; #~user/project#19.
+ ;;
+ ;; Caveat: The code assumes that a project on git.sr.ht or
+ ;; hg.sr.ht has a tracker of the same name on todo.sh.ht. That's
+ ;; a very common setup but all sr.ht services are loosely coupled,
+ ;; so you can have a repo without tracker, or a repo with a
+ ;; tracker using a different name, etc. So we can only try to
+ ;; make a good guess.
+ ("[/@]\\(?:git\\|hg\\).sr.ht[/:]\\(~[.A-Za-z0-9_/-]+\\)"
+ "\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://todo.sr.ht/"
+ (or
+ ;; Explicit user/proj#18 link.
+ (match-string 1)
+ ns-project)
+ "/"
+ (match-string 2)))))))
+ "An alist for setting up `bug-reference-mode' based on VC URL.
+
+Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN).
+
+URL-REGEXP is matched against the version control URL of the
+current buffer's file. If it matches, BUG-REGEXP is set as
+`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one
+argument that receives a list of the groups 0 to N of matching
+URL-REGEXP against the VCS URL and returns the value to be set as
+`bug-reference-url-format'.")
+
+(defun bug-reference-try-setup-from-vc ()
+ "Try setting up `bug-reference-mode' based on VC information.
+Test each configuration in `bug-reference-setup-from-vc-alist'
+and apply it if applicable."
+ (let ((file-or-dir (or buffer-file-name
+ ;; Catches modes such as vc-dir and Magit.
+ default-directory)))
+ (when file-or-dir
+ (let* ((backend (vc-responsible-backend file-or-dir t))
+ (url
+ (or (ignore-errors
+ (vc-call-backend backend 'repository-url "upstream"))
+ (ignore-errors
+ (vc-call-backend backend 'repository-url)))))
+ (when url
+ (catch 'found
+ (dolist (config bug-reference-setup-from-vc-alist)
+ (when (apply #'bug-reference-maybe-setup-from-vc
+ url config)
+ (throw 'found t)))))))))
+
+(defvar bug-reference-setup-from-mail-alist
+ `((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words)
+ ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org"
+ ;; List-Id of Gnus devel mailing list.
+ "ding.gnus.org"))
+ "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+ "https://debbugs.gnu.org/%s"))
+ "An alist for setting up `bug-reference-mode' in mail modes.
+
+This takes action if `bug-reference-mode' is enabled in group and
+message buffers of Emacs mail clients. Currently, Gnus and Rmail
+are supported.
+
+Each element has the form
+
+ (GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT)
+
+GROUP-REGEXP is a regexp matched against the current mail folder
+or newsgroup name. HEADER-REGEXP is a regexp matched against the
+From, To, Cc, Newsgroup, and List-ID header values of the current
+mail or newsgroup message. If any of those matches, BUG-REGEXP
+is set as `bug-reference-bug-regexp' and URL-FORMAT is set as
+`bug-reference-url-format'.
+
+Note: In Gnus, if a summary buffer has been set up based on
+GROUP-REGEXP, all article buffers opened from there will get the
+same `bug-reference-url-format' and `bug-reference-url-format'.")
+
+(defvar gnus-newsgroup-name)
+
+(defun bug-reference-maybe-setup-from-mail (group header-values)
+ "Set up according to mail GROUP or HEADER-VALUES.
+Group is a mail group/folder name and HEADER-VALUES is a list of
+mail header values, e.g., the values of From, To, Cc, List-ID,
+and Newsgroup.
+
+If any GROUP-REGEXP or HEADER-REGEXP of
+`bug-reference-setup-from-mail-alist' matches GROUP or any
+element in HEADER-VALUES, the corresponding BUG-REGEXP and
+URL-FORMAT are set."
+ (catch 'setup-done
+ (dolist (config bug-reference-setup-from-mail-alist)
+ (when (or
+ (and group
+ (car config)
+ (string-match-p (car config) group))
+ (and header-values
+ (nth 1 config)
+ (catch 'matching-header
+ (dolist (h header-values)
+ (when (and h (string-match-p (nth 1 config) h))
+ (throw 'matching-header t))))))
+ (setq-local bug-reference-bug-regexp (nth 2 config))
+ (setq-local bug-reference-url-format (nth 3 config))
+ (throw 'setup-done t)))))
+
+(defun bug-reference-try-setup-from-gnus ()
+ "Try setting up `bug-reference-mode' based on Gnus group or article.
+Test each configuration in `bug-reference-setup-from-mail-alist'
+and set it if applicable."
+ (when (and (derived-mode-p 'gnus-summary-mode)
+ (bound-and-true-p gnus-newsgroup-name))
+ ;; Gnus reuses its article buffer so we have to check whenever the
+ ;; article changes.
+ (add-hook 'gnus-article-prepare-hook
+ #'bug-reference--try-setup-gnus-article)
+ (bug-reference-maybe-setup-from-mail gnus-newsgroup-name nil)))
+
+(defvar gnus-article-buffer)
+(defvar gnus-original-article-buffer)
+(defvar gnus-summary-buffer)
+(defvar bug-reference-mode)
+
+(defun bug-reference--try-setup-gnus-article ()
+ (when (and bug-reference-mode ;; Only if enabled in article buffers.
+ (derived-mode-p
+ 'gnus-article-mode
+ ;; Apparently, gnus-article-prepare-hook is run in the
+ ;; summary buffer...
+ 'gnus-summary-mode)
+ gnus-article-buffer
+ gnus-original-article-buffer
+ (buffer-live-p (get-buffer gnus-article-buffer))
+ (buffer-live-p (get-buffer gnus-original-article-buffer)))
+ (with-current-buffer gnus-article-buffer
+ (catch 'setup-done
+ ;; Copy over the values from the summary buffer.
+ (when (and gnus-summary-buffer
+ (buffer-live-p gnus-summary-buffer))
+ (setq-local bug-reference-bug-regexp
+ (with-current-buffer gnus-summary-buffer
+ bug-reference-bug-regexp))
+ (setq-local bug-reference-url-format
+ (with-current-buffer gnus-summary-buffer
+ bug-reference-url-format))
+ (when (and bug-reference-bug-regexp
+ bug-reference-url-format)
+ (throw 'setup-done t)))
+ ;; If the summary had no values, try setting according to
+ ;; the values of the From, To, and Cc headers.
+ (let (header-values)
+ (with-current-buffer
+ (get-buffer gnus-original-article-buffer)
+ (save-excursion
+ (goto-char (point-min))
+ ;; The Newsgroup is omitted because we already matched
+ ;; based on group name in the summary buffer.
+ (dolist (field '("list-id" "to" "from" "cc"))
+ (let ((val (mail-fetch-field field)))
+ (when val
+ (push val header-values))))))
+ (bug-reference-maybe-setup-from-mail nil header-values))))))
+
+(defun bug-reference-try-setup-from-rmail ()
+ "Try setting up `bug-reference-mode' from the current rmail mail.
+Guesses suitable `bug-reference-bug-regexp' and
+`bug-reference-url-format' values by matching the current Rmail
+file's name against GROUP-REGEXP and the values of List-Id, To,
+From, and Cc against HEADER-REGEXP in
+`bug-reference-setup-from-mail-alist'."
+ (when (and bug-reference-mode
+ (derived-mode-p 'rmail-mode))
+ (let (header-values)
+ (save-excursion
+ (goto-char (point-min))
+ (dolist (field '("list-id" "to" "from" "cc"))
+ (let ((val (mail-fetch-field field)))
+ (when val
+ (push val header-values)))))
+ (bug-reference-maybe-setup-from-mail
+ (buffer-file-name) header-values))))
+
+(defvar bug-reference-setup-from-irc-alist
+ `((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc"
+ "erc") 'words))
+ "Libera.Chat"
+ "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+ "https://debbugs.gnu.org/%s"))
+ "An alist for setting up `bug-reference-mode' in IRC modes.
+
+This takes action if `bug-reference-mode' is enabled in IRC
+channels using one of Emacs' IRC clients. Currently, rcirc and
+ERC are supported.
+
+Each element has the form
+
+ (CHANNEL-REGEXP NETWORK-REGEXP BUG-REGEXP URL-FORMAT)
+
+CHANNEL-REGEXP is a regexp matched against the current IRC
+channel name (e.g. #emacs). NETWORK-REGEXP is matched against
+the IRC network name (e.g. Libera.Chat). Both entries are
+optional. If all given entries match, BUG-REGEXP is set as
+`bug-reference-bug-regexp' and URL-FORMAT is set as
+`bug-reference-url-format'.")
+
+(defun bug-reference-maybe-setup-from-irc (channel network)
+ "Set up according to IRC CHANNEL or NETWORK.
+CHANNEL is an IRC channel name (or generally a target, i.e., it
+could also be a user name) and NETWORK is that channel's network
+name.
+
+If any `bug-reference-setup-from-irc-alist' entry's
+CHANNEL-REGEXP and NETWORK-REGEXP match CHANNEL and NETWORK, the
+corresponding BUG-REGEXP and URL-FORMAT are set."
+ (catch 'setup-done
+ (dolist (config bug-reference-setup-from-irc-alist)
+ (let ((channel-rx (car config))
+ (network-rx (nth 1 config)))
+ (when (and
+ ;; One of both has to be given.
+ (or channel-rx network-rx)
+ ;; The args have to be set.
+ channel network)
+ (when (and
+ (or (null channel-rx)
+ (string-match-p channel-rx channel))
+ (or (null network-rx)
+ (string-match-p network-rx network)))
+ (setq-local bug-reference-bug-regexp (nth 2 config))
+ (setq-local bug-reference-url-format (nth 3 config))
+ (throw 'setup-done t)))))))
+
+(defvar rcirc-target)
+(defvar rcirc-server-buffer)
+(defvar rcirc-server)
+
+(defun bug-reference-try-setup-from-rcirc ()
+ "Try setting up `bug-reference-mode' based on rcirc channel and server.
+Test each configuration in `bug-reference-setup-from-irc-alist'
+and set it if applicable."
+ (when (derived-mode-p 'rcirc-mode)
+ (bug-reference-maybe-setup-from-irc
+ rcirc-target
+ (and rcirc-server-buffer
+ (buffer-live-p rcirc-server-buffer)
+ (with-current-buffer rcirc-server-buffer
+ rcirc-server)))))
+
+(declare-function erc-format-target "erc")
+(declare-function erc-network-name "erc-networks")
+
+(defun bug-reference-try-setup-from-erc ()
+ "Try setting up `bug-reference-mode' based on ERC channel and server.
+Test each configuration in `bug-reference-setup-from-irc-alist'
+and set it if applicable."
+ (when (derived-mode-p 'erc-mode)
+ (bug-reference-maybe-setup-from-irc
+ (erc-format-target)
+ (erc-network-name))))
+
+(defvar bug-reference-auto-setup-functions
+ (list #'bug-reference-try-setup-from-vc
+ #'bug-reference-try-setup-from-gnus
+ #'bug-reference-try-setup-from-rmail
+ #'bug-reference-try-setup-from-rcirc
+ #'bug-reference-try-setup-from-erc)
+ "Functions trying to auto-setup `bug-reference-mode'.
+These functions are run after `bug-reference-mode' has been
+activated in a buffer and try to guess suitable values for
+`bug-reference-bug-regexp' and `bug-reference-url-format'. Their
+guesswork is based on these variables:
+
+- `bug-reference-setup-from-vc-alist' for guessing based on
+ version control, e.g., URL of repository.
+- `bug-reference-setup-from-mail-alist' for guessing based on
+ mail group names or mail header values.
+- `bug-reference-setup-from-irc-alist' for guessing based on IRC
+ channel or network names.")
+
+(defun bug-reference--run-auto-setup ()
+ (when (or bug-reference-mode
+ bug-reference-prog-mode)
+ ;; Automatic setup only if the variables aren't already set, e.g.,
+ ;; by a local variables section in the file.
+ (unless (and bug-reference-bug-regexp
+ bug-reference-url-format)
+ (with-demoted-errors
+ "Error during bug-reference auto-setup: %S"
+ (catch 'setup
+ (dolist (f bug-reference-auto-setup-functions)
+ (when (funcall f)
+ (throw 'setup t))))))))
+
;;;###autoload
(define-minor-mode bug-reference-mode
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
- nil
- ""
- nil
+ :after-hook (bug-reference--run-auto-setup)
(if bug-reference-mode
(jit-lock-register #'bug-reference-fontify)
(jit-lock-unregister #'bug-reference-fontify)
@@ -152,12 +528,22 @@ The second subexpression should match the bug reference (usually a number)."
(widen)
(bug-reference-unfontify (point-min) (point-max)))))
+(defun bug-reference-mode-force-auto-setup ()
+ "Enable `bug-reference-mode' and force auto-setup.
+Enabling `bug-reference-mode' runs its auto-setup only if
+`bug-reference-bug-regexp' and `bug-reference-url-format' are not
+set already. This function sets the latter to `nil'
+buffer-locally, so that the auto-setup will always run.
+
+This is mostly intended for MUA modes like `rmail-mode' where the
+same buffer is re-used for different contexts."
+ (setq-local bug-reference-url-format nil)
+ (bug-reference-mode))
+
;;;###autoload
(define-minor-mode bug-reference-prog-mode
"Like `bug-reference-mode', but only buttonize in comments and strings."
- nil
- ""
- nil
+ :after-hook (bug-reference--run-auto-setup)
(if bug-reference-prog-mode
(jit-lock-register #'bug-reference-fontify)
(jit-lock-unregister #'bug-reference-fontify)
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 3f39374008b..9234d0b19b9 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -1,4 +1,4 @@
-;;; cc-align.el --- custom indentation functions for CC Mode
+;;; cc-align.el --- custom indentation functions for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -44,6 +44,9 @@
(cc-require 'cc-vars)
(cc-require 'cc-engine)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
+
;; Standard line-up functions
;;
@@ -274,8 +277,10 @@ statement-block-intro, statement-case-intro, arglist-intro."
(save-excursion
(beginning-of-line)
(backward-up-list 1)
+ (forward-char)
(skip-chars-forward " \t" (c-point 'eol))
- (vector (1+ (current-column)))))
+ (if (eolp) (skip-chars-backward " \t"))
+ (vector (current-column))))
(defun c-lineup-arglist-close-under-paren (langelem)
"Line up a line under the enclosing open paren.
@@ -790,6 +795,38 @@ arglist-cont-nonempty."
(or (c-lineup-assignments langelem)
c-basic-offset))
+(defun c-lineup-ternary-bodies (langelem)
+ "Line up true and false branches of a ternary operator (i.e. `?:').
+More precisely, if the line starts with a colon which is a part of
+a said operator, align it with corresponding question mark; otherwise
+return nil. For example:
+
+ return arg % 2 == 0 ? arg / 2
+ : (3 * arg + 1); <- c-lineup-ternary-bodies
+
+Works with: arglist-cont, arglist-cont-nonempty and statement-cont."
+ (save-excursion
+ (back-to-indentation)
+ (when (and (eq ?: (char-after))
+ (not (eq ?: (char-after (1+ (point))))))
+ (let ((limit (c-langelem-pos langelem)) (depth 1))
+ (catch 'done
+ (while (and (c-syntactic-skip-backward "^?:" limit t)
+ (not (bobp)))
+ (backward-char)
+ (cond ((eq (char-after) ??)
+ ;; If we've found a question mark, decrease depth. If we've
+ ;; reached zero, we've found the one we were looking for.
+ (when (zerop (setq depth (1- depth)))
+ (throw 'done (vector (current-column)))))
+ ((or (eq ?: (char-before)) (eq ?? (char-before)))
+ ;; Step over `::' and `?:' operators. We don't have to
+ ;; handle `?:' here but doing so saves an iteration.
+ (if (eq (point) limit)
+ (throw 'done nil)
+ (goto-char (1- (point)))))
+ ((setq depth (1+ depth)))))))))) ; Otherwise increase depth.
+
(defun c-lineup-cascaded-calls (langelem)
"Line up \"cascaded calls\" under each other.
If the line begins with \"->\" or \".\" and the preceding line ends
@@ -1083,7 +1120,7 @@ arglist-cont."
(vector (+ (current-column) c-basic-offset))))
(vector 0)))))
-(defun c-lineup-2nd-brace-entry-in-arglist (langelem)
+(defun c-lineup-2nd-brace-entry-in-arglist (_langelem)
"Lineup the second entry of a brace block under the first, when the first
line is also contained in an arglist or an enclosing brace ON THAT LINE.
@@ -1113,7 +1150,8 @@ Works with brace-list-intro."
; the line.
(save-excursion ; "{" earlier on the line
(goto-char (c-langelem-pos
- (assq 'brace-list-intro c-syntactic-context)))
+ (assq 'brace-list-entry
+ c-syntactic-context)))
(and
(eq (c-backward-token-2
1 nil
@@ -1124,7 +1162,7 @@ Works with brace-list-intro."
(eq (char-after) ?{))))
'c-lineup-arglist-intro-after-paren))
-(defun c-lineup-class-decl-init-+ (langelem)
+(defun c-lineup-class-decl-init-+ (_langelem)
"Line up the second entry of a class (etc.) initializer c-basic-offset
characters in from the identifier when:
\(i) The type is a class, struct, union, etc. (but not an enum);
@@ -1165,7 +1203,7 @@ Works with: brace-list-intro."
(eq (point) init-pos)
(vector (+ (current-column) c-basic-offset)))))))
-(defun c-lineup-class-decl-init-after-brace (langelem)
+(defun c-lineup-class-decl-init-after-brace (_langelem)
"Line up the second entry of a class (etc.) initializer after its opening
brace when:
\(i) The type is a class, struct, union, etc. (but not an enum);
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index 802e75765b1..334e82114fc 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -1,4 +1,4 @@
-;;; cc-awk.el --- AWK specific code within cc-mode.
+;;; cc-awk.el --- AWK specific code within cc-mode. -*- lexical-binding: t -*-
;; Copyright (C) 1988, 1994, 1996, 2000-2021 Free Software Foundation,
;; Inc.
@@ -49,9 +49,11 @@
(load "cc-bytecomp" nil t)))
(cc-require 'cc-defs)
+(cc-require-when-compile 'cc-langs)
+(cc-require-when-compile 'cc-fonts)
+(cc-require 'cc-engine)
;; Silence the byte compiler.
-(cc-bytecomp-defvar font-lock-mode) ; Checked with boundp before use.
(cc-bytecomp-defvar c-new-BEG)
(cc-bytecomp-defvar c-new-END)
@@ -649,6 +651,46 @@
;; several lines back. The elisp "advice" feature is used on these functions
;; to allow this.
+(defun c-awk-font-lock-invalid-namespace-separators (limit)
+ ;; 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".
+ ;;
+ ;; This function gives invalid GAWK namepace separators (::)
+ ;; font-lock-warning-face. "Invalid" here means there are spaces, etc.,
+ ;; around a separator, or there are more than one of them in an identifier.
+ ;; Invalid separators inside function declaration parentheses are handled
+ ;; elsewhere.
+ (while (and
+ (< (point) limit)
+ (c-syntactic-re-search-forward
+ (eval-when-compile
+ (concat "\\([^" (c-lang-const c-symbol-chars awk) "]::\\)"
+ "\\|"
+ ;; "\\(::[^" (c-lang-const c-symbol-start awk) "]\\)"
+ "\\(::[^" c-alpha "_" "]\\)"
+ "\\|"
+ "\\(::[" (c-lang-const c-symbol-chars awk) "]*::\\)"))
+ limit 'bound))
+ (cond
+ ((match-beginning 1) ; " ::"
+ (c-put-font-lock-face (1+ (match-beginning 1)) (match-end 1)
+ 'font-lock-warning-face)
+ (goto-char (- (match-end 1) 2)))
+ ((match-beginning 2) ; ":: "
+ (c-put-font-lock-face (match-beginning 2) (1- (match-end 2))
+ 'font-lock-warning-face)
+ (goto-char (1- (match-end 2))))
+ (t ; "::foo::"
+ (c-put-font-lock-face (match-beginning 3) (+ 2 (match-beginning 3))
+ 'font-lock-warning-face)
+ (c-put-font-lock-face (- (match-end 3) 2) (match-end 3)
+ 'font-lock-warning-face)
+ (goto-char (- (match-end 3) 2)))))
+ nil)
+
(defun c-awk-beginning-of-logical-line (&optional pos)
;; Go back to the start of the (apparent) current line (or the start of the
;; line containing POS), returning the buffer position of that point. I.e.,
@@ -900,6 +942,13 @@
(goto-char c-new-BEG)
(c-awk-set-syntax-table-properties c-new-END)))
+(defun c-awk-context-expand-fl-region (beg end)
+ ;; Return a cons (NEW-BEG . NEW-END), where NEW-BEG is the beginning of the
+ ;; logical line BEG is on, and NEW-END is the beginning of the line after
+ ;; the end of the logical line that END is on.
+ (cons (save-excursion (c-awk-beginning-of-logical-line beg))
+ (c-awk-beyond-logical-line end)))
+
;; Awk regexps written with help from Peter Galbraith
;; <galbraith@mixing.qc.dfo.ca>.
;; Take GNU Emacs's 'words out of the following regexp-opts. They don't work
@@ -907,18 +956,34 @@
(defconst awk-font-lock-keywords
(eval-when-compile
(list
- ;; Function names.
- '("^\\s *\\(func\\(tion\\)?\\)\\>\\s *\\(\\sw+\\)?"
- (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
- ;;
+ ;; Function declarations.
+ `(,(c-make-font-lock-search-function
+ "^\\s *\\(func\\(tion\\)?\\)\\s +\\(\\(\\sw+\\(::\\sw+\\)?\\)\\s *\\)?\\(([^()]*)\\)?"
+ '(1 font-lock-keyword-face t)
+ ;; We can't use LAXMATCH in `c-make-font-lock-search-function', so....
+ '((when (match-beginning 4)
+ (c-put-font-lock-face
+ (match-beginning 4) (match-end 4) font-lock-function-name-face)
+ nil))
+ ;; Put warning face on any use of :: inside the parens.
+ '((when (match-beginning 6)
+ (goto-char (1+ (match-beginning 6)))
+ (let ((end (1- (match-end 6))))
+ (while (and (< (point) end)
+ (c-syntactic-re-search-forward "::" end t))
+ (c-put-font-lock-face (- (point) 2) (point)
+ 'font-lock-warning-face)))
+ nil))))
+
;; Variable names.
(cons
(concat "\\<"
(regexp-opt
'("ARGC" "ARGIND" "ARGV" "BINMODE" "CONVFMT" "ENVIRON"
- "ERRNO" "FIELDWIDTHS" "FILENAME" "FNR" "FS" "IGNORECASE"
- "LINT" "NF" "NR" "OFMT" "OFS" "ORS" "PROCINFO" "RLENGTH"
- "RS" "RSTART" "RT" "SUBSEP" "TEXTDOMAIN") t) "\\>")
+ "ERRNO" "FIELDWIDTHS" "FILENAME" "FNR" "FPAT" "FS" "FUNCTAB"
+ "IGNORECASE" "LINT" "NF" "NR" "OFMT" "OFS" "ORS" "PREC"
+ "PROCINFO" "RLENGTH" "ROUNDMODE" "RS" "RSTART" "RT" "SUBSEP"
+ "SYNTAB" "TEXTDOMAIN") t) "\\>")
'font-lock-variable-name-face)
;; Special file names. (acm, 2002/7/22)
@@ -949,7 +1014,8 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\
;; Keywords.
(concat "\\<"
(regexp-opt
- '("BEGIN" "END" "break" "case" "continue" "default" "delete"
+ '("BEGIN" "BEGINFILE" "END" "ENDFILE"
+ "break" "case" "continue" "default" "delete"
"do" "else" "exit" "for" "getline" "if" "in" "next"
"nextfile" "return" "switch" "while")
t) "\\>")
@@ -959,16 +1025,20 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\
,(concat
"\\<"
(regexp-opt
- '("adump" "and" "asort" "atan2" "bindtextdomain" "close"
- "compl" "cos" "dcgettext" "exp" "extension" "fflush"
- "gensub" "gsub" "index" "int" "length" "log" "lshift"
- "match" "mktime" "or" "print" "printf" "rand" "rshift"
+ '("adump" "and" "asort" "asorti" "atan2" "bindtextdomain" "close"
+ "compl" "cos" "dcgettext" "dcngettext" "exp" "extension" "fflush"
+ "gensub" "gsub" "index" "int" "isarray" "length" "log" "lshift"
+ "match" "mktime" "or" "patsplit" "print" "printf" "rand" "rshift"
"sin" "split" "sprintf" "sqrt" "srand" "stopme"
"strftime" "strtonum" "sub" "substr" "system"
- "systime" "tolower" "toupper" "xor") t)
+ "systime" "tolower" "toupper" "typeof" "xor")
+ t)
"\\>")
0 c-preprocessor-face-name))
+ ;; Directives
+ `(eval . '("@\\(include\\|load\\|namespace\\)\\>" 0 ,c-preprocessor-face-name))
+
;; gawk debugging keywords. (acm, 2002/7/21)
;; (Removed, 2003/6/6. These functions are now fontified as built-ins)
;; (list (concat "\\<" (regexp-opt '("adump" "stopme") t) "\\>")
@@ -980,6 +1050,9 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\
c-awk-escaped-nls*-with-space* "(")
(0 'font-lock-warning-face))
+ ;; Double :: tokens, or the same with space(s) around them.
+ #'c-awk-font-lock-invalid-namespace-separators
+
;; Space after \ in what looks like an escaped newline. 2002/5/31
'("\\\\\\s +$" 0 font-lock-warning-face t)
@@ -1003,7 +1076,7 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\
;; Matches an unterminated string/regexp, NOT including the eol at the end.
(defconst c-awk-harmless-pattern-characters*
- (concat "\\([^{;#/\"\\\\\n\r]\\|" c-awk-esc-pair-re "\\)*"))
+ (concat "\\([^{;#/\"\\\n\r]\\|" c-awk-esc-pair-re "\\)*"))
;; Matches any "harmless" character in a pattern or an escaped character pair.
(defun c-awk-at-statement-end-p ()
@@ -1154,4 +1227,4 @@ comment at the start of cc-engine.el for more info."
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
-;;; awk-mode.el ends here
+;;; cc-awk.el ends here
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index 3f7caf3c2e9..edbac64eadb 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -1,4 +1,4 @@
-;;; cc-bytecomp.el --- compile time setup for proper compilation
+;;; cc-bytecomp.el --- compile time setup for proper compilation -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -85,8 +85,8 @@
(defvar cc-bytecomp-environment-set nil)
-(defmacro cc-bytecomp-debug-msg (&rest args)
- (ignore args)
+(defmacro cc-bytecomp-debug-msg (&rest _args) ; Change to ARGS when needed.
+ ;; (declare (debug t))
;;`(message ,@args)
)
@@ -97,6 +97,8 @@
;; compilation can trigger loading (various `require' type forms)
;; and loading can trigger compilation (the package manager does
;; this). We walk the lisp stack if necessary.
+ ;; Never native compile to allow cc-defs.el:2345 hack.
+ (declare (speed -1))
(cond
((and load-in-progress
(boundp 'byte-compile-dest-file)
@@ -108,14 +110,15 @@
(memq (cadr elt)
'(load require
byte-compile-file byte-recompile-directory
- batch-byte-compile)))))
+ batch-byte-compile batch-native-compile)))))
(setq n (1+ n)))
(cond
((memq (cadr elt) '(load require))
'loading)
((memq (cadr elt) '(byte-compile-file
byte-recompile-directory
- batch-byte-compile))
+ batch-byte-compile
+ batch-native-compile))
'compiling)
(t ; Can't happen.
(message "cc-bytecomp-compiling-or-loading: System flags spuriously set")
@@ -284,7 +287,9 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten somewhere"))
(cons cc-file cc-bytecomp-loaded-files))
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loading %S" cc-file)
- (load cc-file nil t t)
+ ;; native-comp may async compile also intalled el.gz
+ ;; files therefore we may have to load here other el.gz.
+ (load cc-part nil t)
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loaded %S" cc-file)))
(cc-bytecomp-setup-environment)
@@ -297,6 +302,7 @@ during compilation, but compile in a `require'. Don't use within
Having cyclic cc-require's will result in infinite recursion. That's
somewhat intentional."
+ (declare (debug t))
`(progn
(eval-when-compile
(cc-bytecomp-load (symbol-name ,cc-part)))
@@ -309,6 +315,7 @@ time, (ii) generate code to load the file at load time.
CC-PART will normally be a quoted name such as \\='cc-fix.
CONDITION should not be quoted."
+ (declare (debug t))
(if (eval condition)
(progn
(cc-bytecomp-load (symbol-name (eval cc-part)))
@@ -323,6 +330,7 @@ after the loading of FILE.
CC-PART will normally be a quoted name such as \\='cc-fix. FILE
should be a string. CONDITION should not be quoted."
+ (declare (debug t))
(if (eval condition)
(progn
(cc-bytecomp-load (symbol-name (eval cc-part)))
@@ -333,6 +341,7 @@ should be a string. CONDITION should not be quoted."
(defmacro cc-provide (feature)
"A replacement for the `provide' form that restores the environment
after the compilation. Don't use within `eval-when-compile'."
+ (declare (debug t))
`(progn
(eval-when-compile (cc-bytecomp-restore-environment))
(provide ,feature)))
@@ -344,6 +353,7 @@ during compilation. Don't use outside `eval-when-compile' or
Having cyclic cc-load's will result in infinite recursion. That's
somewhat intentional."
+ (declare (debug t))
`(or (and (featurep 'cc-bytecomp)
(cc-bytecomp-load ,cc-part))
(load ,cc-part nil t nil)))
@@ -352,6 +362,7 @@ somewhat intentional."
"Force loading of the corresponding .el file in the current directory
during compilation, but do a compile time `require' otherwise. Don't
use within `eval-when-compile'."
+ (declare (debug t))
`(eval-when-compile
(if (and (fboundp 'cc-bytecomp-is-compiling)
(cc-bytecomp-is-compiling))
@@ -363,6 +374,7 @@ use within `eval-when-compile'."
"Do a `require' of an external package.
This restores and sets up the compilation environment before and
afterwards. Don't use within `eval-when-compile'."
+ (declare (debug t))
`(progn
(eval-when-compile (cc-bytecomp-restore-environment))
(require ,feature)
@@ -371,6 +383,7 @@ afterwards. Don't use within `eval-when-compile'."
(defmacro cc-bytecomp-defvar (var)
"Binds the symbol as a variable during compilation of the file,
to silence the byte compiler. Don't use within `eval-when-compile'."
+ (declare (debug nil))
`(eval-when-compile
(if (boundp ',var)
(cc-bytecomp-debug-msg
@@ -398,6 +411,7 @@ definition. That means that this macro will not shut up warnings
about incorrect number of arguments. It's dangerous to try to replace
existing functions since the byte compiler might need the definition
at compile time, e.g. for macros and inline functions."
+ (declare (debug nil))
`(eval-when-compile
(if (fboundp ',fun)
(cc-bytecomp-debug-msg
@@ -419,6 +433,7 @@ at compile time, e.g. for macros and inline functions."
(defmacro cc-bytecomp-put (symbol propname value)
"Set a property on a symbol during compilation (and evaluation) of
the file. Don't use outside `eval-when-compile'."
+ (declare (debug t))
`(eval-when-compile
(if (not (assoc (cons ,symbol ,propname) cc-bytecomp-original-properties))
(progn
@@ -439,6 +454,7 @@ the file. Don't use outside `eval-when-compile'."
the compilation. This is the same as using `boundp' but additionally
exclude any variables that have been bound during compilation with
`cc-bytecomp-defvar'."
+ (declare (debug t))
(if (and (cc-bytecomp-is-compiling)
(memq (car (cdr symbol)) cc-bytecomp-unbound-variables))
nil
@@ -449,6 +465,7 @@ exclude any variables that have been bound during compilation with
the compilation. This is the same as using `fboundp' but additionally
exclude any functions that have been bound during compilation with
`cc-bytecomp-defun'."
+ (declare (debug t))
(let (fun-elem)
(if (and (cc-bytecomp-is-compiling)
(setq fun-elem (assq (car (cdr symbol))
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index a80fb12af37..bdfdf178d43 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1,4 +1,4 @@
-;;; cc-cmds.el --- user level commands for CC Mode
+;;; cc-cmds.el --- user level commands for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -48,12 +48,12 @@
(cc-bytecomp-defvar filladapt-mode) ; c-fill-paragraph contains a kludge
; which looks at this.
(cc-bytecomp-defun electric-pair-post-self-insert-function)
+(cc-bytecomp-defvar c-indent-to-body-directives)
+(defvar c-syntactic-context)
;; Indentation / Display syntax functions
(defvar c-fix-backslashes t)
-(defvar c-syntactic-context)
-
(defun c-indent-line (&optional syntax quiet ignore-point-pos)
"Indent the current line according to the syntactic context,
if `c-syntactic-indentation' is non-nil. Optional SYNTAX is the
@@ -512,11 +512,11 @@ function to control that."
(let ((src (default-value 'post-self-insert-hook)))
(while src
(unless (memq (car src) c--unsafe-post-self-insert-hook-functions)
- (add-hook 'dest (car src) t)) ; Preserve the order of the functions.
+ (push (car src) dest))
(setq src (cdr src)))))
- (t (add-hook 'dest (car src) t))) ; Preserve the order of the functions.
+ (t (push (car src) dest)))
(setq src (cdr src)))
- (run-hooks 'dest)))
+ (mapc #'funcall (nreverse dest)))) ; Preserve the order of the functions.
(defmacro c--call-post-self-insert-hook-more-safely ()
;; Call post-self-insert-hook, if such exists. See comment for
@@ -906,7 +906,6 @@ settings of `c-cleanup-list' are done."
(when (and (boundp 'electric-pair-mode)
electric-pair-mode)
(let ((size (buffer-size))
- (c-in-electric-pair-functionality t)
post-self-insert-hook)
(electric-pair-post-self-insert-function)
(setq got-pair-} (and at-eol
@@ -1220,9 +1219,9 @@ numeric argument is supplied, or the point is inside a literal."
(self-insert-command (prefix-numeric-value arg)))
(setq final-pos (point))
-;;;; 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.
+;;;; 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 (and (not arg) (not literal))
;; Have we got a delimiter on a #include directive?
@@ -1441,6 +1440,98 @@ keyword on the line, the keyword is not inserted inside a literal, and
(indent-according-to-mode)
(delete-char -2)))))
+(defun c-align-cpp-indent-to-body ()
+ "Align a \"#pragma\" line under the previous line.
+This function is intented for use as a member of `c-special-indent-hook'."
+ (when (assq 'cpp-macro c-syntactic-context)
+ (when
+ (save-excursion
+ (save-match-data
+ (back-to-indentation)
+ (and
+ (looking-at (concat c-opt-cpp-symbol "[ \t]*\\([a-zA-Z0-9_]+\\)"))
+ (member (match-string-no-properties 1)
+ c-cpp-indent-to-body-directives))))
+ (c-indent-line (delete '(cpp-macro) c-syntactic-context)))))
+
+(defvar c-cpp-indent-to-body-flag nil)
+;; Non-nil when CPP directives such as "#pragma" should be indented to under
+;; the preceding statement.
+(make-variable-buffer-local 'c-cpp-indent-to-body-flag)
+
+(defun c-electric-pragma ()
+ "Reindent the current line if appropriate.
+
+This function is used to reindent a preprocessor line when the
+symbol for the directive, typically \"pragma\", triggers this
+function as a hook function of an abbreviation.
+
+The \"#\" of the preprocessor construct is aligned under the
+first anchor point of the line's syntactic context.
+
+The line is reindented if the construct is not in a string or
+comment, there is exactly one \"#\" contained in optional
+whitespace before it on the current line, and `c-electric-flag'
+and `c-syntactic-indentation' are both non-nil."
+ (save-excursion
+ (save-match-data
+ (when
+ (and
+ c-cpp-indent-to-body-flag
+ c-electric-flag
+ c-syntactic-indentation
+ last-abbrev-location
+ c-opt-cpp-symbol ; "#" or nil.
+ (progn (back-to-indentation)
+ (looking-at (concat c-opt-cpp-symbol "[ \t]*")))
+ (>= (match-end 0) last-abbrev-location)
+ (not (c-literal-limits)))
+ (c-indent-line (delete '(cpp-macro) (c-guess-basic-syntax)))))))
+
+(defun c-add-indent-to-body-to-abbrev-table (d)
+ ;; Create an abbreviation table entry for the directive D, and add it to the
+ ;; current abbreviation table. Existing abbreviation (e.g. for "else") do
+ ;; not get overwritten.
+ (when (and c-buffer-is-cc-mode
+ local-abbrev-table
+ (not (abbrev-symbol d local-abbrev-table)))
+ (condition-case nil
+ (define-abbrev local-abbrev-table d d 'c-electric-pragma 0 t)
+ (wrong-number-of-arguments
+ (define-abbrev local-abbrev-table d d 'c-electric-pragma)))))
+
+(defun c-clear-stale-indent-to-body-abbrevs ()
+ ;; Fill in this comment. FIXME!!!
+ (when (fboundp 'abbrev-get)
+ (mapatoms (lambda (a)
+ (when (and (abbrev-get a ':system) ; Preserve a user's abbrev!
+ (not (member (symbol-name a) c-std-abbrev-keywords))
+ (not (member (symbol-name a)
+ c-cpp-indent-to-body-directives)))
+ (unintern a local-abbrev-table)))
+ local-abbrev-table)))
+
+(defun c-toggle-cpp-indent-to-body (&optional arg)
+ "Toggle the C preprocessor indent-to-body feature.
+When enabled, preprocessor directives which are words in
+`c-indent-to-body-directives' are indented as if they were statements.
+
+Optional numeric ARG, if supplied, turns on the feature when positive,
+turns it off when negative, and just toggles it when zero or
+left out."
+ (interactive "P")
+ (setq c-cpp-indent-to-body-flag
+ (c-calculate-state arg c-cpp-indent-to-body-flag))
+ (if c-cpp-indent-to-body-flag
+ (progn
+ (c-clear-stale-indent-to-body-abbrevs)
+ (mapc 'c-add-indent-to-body-to-abbrev-table
+ c-cpp-indent-to-body-directives)
+ (add-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body nil t))
+ (remove-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body t))
+ (message "c-cpp-indent-to-body %sabled"
+ (if c-cpp-indent-to-body-flag "en" "dis")))
+
(declare-function subword-forward "subword" (&optional arg))
@@ -1461,19 +1552,6 @@ keyword on the line, the keyword is not inserted inside a literal, and
(declare-function c-backward-subword "ext:cc-subword" (&optional arg))
;; "nomenclature" functions + c-scope-operator.
-(defun c-forward-into-nomenclature (&optional arg)
- "Compatibility alias for `c-forward-subword'."
- (interactive "p")
- (if (fboundp 'subword-mode)
- (progn
- (require 'subword)
- (subword-forward arg))
- (require 'cc-subword)
- (c-forward-subword arg)))
-(make-obsolete 'c-forward-into-nomenclature
- (if (fboundp 'subword-mode) 'subword-forward 'c-forward-subword)
- "23.2")
-
(defun c-backward-into-nomenclature (&optional arg)
"Compatibility alias for `c-backward-subword'."
(interactive "p")
@@ -1560,8 +1638,8 @@ No indentation or other \"electric\" behavior is performed."
;;
;; This function might do hidden buffer changes.
(save-excursion
- (let* (kluge-start
- decl-result brace-decl-p
+ (let* (knr-start knr-res
+ decl-result
(start (point))
(paren-state (c-parse-state))
(least-enclosing (c-least-enclosing-brace paren-state)))
@@ -1591,63 +1669,54 @@ No indentation or other \"electric\" behavior is performed."
(not (looking-at c-defun-type-name-decl-key))))))
'at-function-end)
(t
- ;; Find the start of the current declaration. NOTE: If we're in the
- ;; variables after a "struct/eval" type block, we don't get to the
- ;; real declaration here - we detect and correct for this later.
-
- ;;If we're in the parameters' parens, move back out of them.
- (if least-enclosing (goto-char least-enclosing))
;; Kluge so that c-beginning-of-decl-1 won't go back if we're already
;; at a declaration.
(if (or (and (eolp) (not (eobp))) ; EOL is matched by "\\s>"
- (not (looking-at
-"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)")))
+ (not (c-looking-at-non-alphnumspace)))
(forward-char))
- (setq kluge-start (point))
- ;; First approximation as to whether the current "header" we're in is
- ;; one followed by braces.
- (setq brace-decl-p
- (save-excursion
- (and (c-syntactic-re-search-forward "[;{]" nil t t)
- (or (eq (char-before) ?\{)
- (and c-recognize-knr-p
- ;; Might have stopped on the
- ;; ';' in a K&R argdecl. In
- ;; that case the declaration
- ;; should contain a block.
- (c-in-knr-argdecl))))))
- (setq decl-result
- (car (c-beginning-of-decl-1
- ;; NOTE: If we're in a K&R region, this might be the start
- ;; of a parameter declaration, not the actual function.
- ;; It might also leave us at a label or "label" like
- ;; "private:".
- (and least-enclosing ; LIMIT for c-b-of-decl-1
- (c-safe-position least-enclosing paren-state)))))
-
- ;; Has the declaration we've gone back to got braces?
- (if (or (eq decl-result 'label)
- (looking-at c-protection-key))
- (setq brace-decl-p nil))
- (cond
- ((or (eq decl-result 'label) ; e.g. "private:" or invalid syntax.
- (= (point) kluge-start)) ; might be BOB or unbalanced parens.
- 'outwith-function)
- ((eq decl-result 'same)
- (if brace-decl-p
- (if (eq (point) start)
- 'at-header
+ (if (and least-enclosing
+ (eq (char-after least-enclosing) ?\())
+ (c-go-list-forward least-enclosing))
+ (c-forward-syntactic-ws)
+ (setq knr-start (point))
+ (if (and (c-syntactic-re-search-forward "[;{]" nil t t)
+ (eq (char-before) ?\{))
+ (progn
+ (backward-char)
+ (cond
+ ((or (progn
+ (c-backward-syntactic-ws)
+ (<= (point) start))
+ (and c-recognize-knr-p
+ (and (setq knr-res (c-in-knr-argdecl))
+ (<= knr-res knr-start))))
'in-header)
- 'outwith-function))
- ((eq decl-result 'previous)
- (if (and (not brace-decl-p)
- (c-in-function-trailer-p))
- 'at-function-end
- 'outwith-function))
- (t (error
- "c-where-wrt-brace-construct: c-beginning-of-decl-1 returned %s"
- decl-result))))))))
+ ((and knr-res
+ (goto-char knr-res)
+ (c-backward-syntactic-ws))) ; Always returns nil.
+ (t
+ (when (eq (char-before) ?\))
+ ;; The `c-go-list-backward' is a precaution against
+ ;; `c-beginning-of-decl-1' spuriously finding a C++ lambda
+ ;; function inside the parentheses.
+ (c-go-list-backward))
+ (setq decl-result
+ (car (c-beginning-of-decl-1
+ (and least-enclosing
+ (c-safe-position
+ least-enclosing paren-state)))))
+ (cond
+ ((> (point) start)
+ 'outwith-function)
+ ((eq decl-result 'same)
+ (if (eq (point) start)
+ 'at-header
+ 'in-header))
+ (t (error
+ "c-where-wrt-brace-construct: c-beginning-of-decl-1 returned %s"
+ decl-result))))))
+ 'outwith-function))))))
(defun c-backward-to-nth-BOF-{ (n where)
;; Skip to the opening brace of the Nth function before point. If
@@ -1670,9 +1739,11 @@ No indentation or other \"electric\" behavior is performed."
(goto-char (c-least-enclosing-brace (c-parse-state)))
(setq n (1- n)))
((eq where 'in-header)
- (c-syntactic-re-search-forward "{")
- (backward-char)
- (setq n (1- n)))
+ (let ((encl-paren (c-least-enclosing-brace (c-parse-state))))
+ (if encl-paren (goto-char encl-paren))
+ (c-syntactic-re-search-forward "{" nil t t)
+ (backward-char)
+ (setq n (1- n))))
((memq where '(at-header outwith-function at-function-end in-trailer))
(c-syntactic-skip-backward "^}")
(when (eq (char-before) ?\})
@@ -1753,15 +1824,18 @@ No indentation or other \"electric\" behavior is performed."
nil)))
(eval-and-compile
- (defmacro c-while-widening-to-decl-block (condition)
+ (defmacro c-while-widening-to-decl-block (condition &optional no-where)
;; Repeatedly evaluate CONDITION until it returns nil. After each
;; evaluation, if `c-defun-tactic' is set appropriately, widen to innards
;; of the next enclosing declaration block (e.g. namespace, class), or the
;; buffer's original restriction.
;;
+ ;; If NO-WHERE is non-nil, don't compile in a `(setq where ....)'.
+ ;;
;; This is a very special purpose macro, which assumes the existence of
;; several variables. It is for use only in c-beginning-of-defun and
;; c-end-of-defun.
+ (declare (debug t))
`(while
(and ,condition
(eq c-defun-tactic 'go-outward)
@@ -1769,7 +1843,8 @@ No indentation or other \"electric\" behavior is performed."
(setq paren-state (c-whack-state-after lim paren-state))
(setq lim (c-widen-to-enclosing-decl-scope
paren-state orig-point-min orig-point-max))
- (setq where 'in-block))))
+ ,@(if (not no-where)
+ `((setq where 'in-block))))))
(def-edebug-spec c-while-widening-to-decl-block t)
@@ -1886,21 +1961,24 @@ defun."
;; The actual movement is done below.
(setq n (1- n)))
((memq where '(at-function-end outwith-function at-header in-header))
- (when (c-syntactic-re-search-forward "{" nil 'eob)
+ (if (eq where 'in-header)
+ (let ((pos (c-least-enclosing-brace (c-parse-state))))
+ (if pos (c-go-list-forward pos))))
+ (when (c-syntactic-re-search-forward "{" nil 'eob t)
(backward-char)
(forward-sexp)
(setq n (1- n))))
(t (error "c-forward-to-nth-EOF-\\;-or-}: `where' is %s" where)))
- (when (c-in-function-trailer-p)
- (c-syntactic-re-search-forward ";" nil 'eob t))
-
;; Each time round the loop, go forward to a "}" at the outermost level.
(while (and (> n 0) (not (eobp)))
(when (c-syntactic-re-search-forward "{" nil 'eob)
(backward-char)
(forward-sexp)
(setq n (1- n))))
+
+ (when (c-in-function-trailer-p)
+ (c-syntactic-re-search-forward ";" nil 'eob t))
n)
(defun c-end-of-defun (&optional arg)
@@ -2024,6 +2102,23 @@ other top level construct with a brace block."
(c-backward-syntactic-ws)
(point))))
+ ((and (c-major-mode-is 'objc-mode) (looking-at "[-+]\\s-*(")) ; Objective-C method
+ ;; Move to the beginning of the method name.
+ (c-forward-token-2 2 t)
+ (let* ((class
+ (save-excursion
+ (when (re-search-backward
+ "^\\s-*@\\(implementation\\|class\\|interface\\)\\s-+\\(\\sw+\\)" nil t)
+ (match-string-no-properties 2))))
+ (limit (save-excursion (re-search-forward "[;{]" nil t)))
+ (method (when (re-search-forward "\\(\\sw+:?\\)" limit t)
+ (match-string-no-properties 1))))
+ (when (and class method)
+ ;; Add the parameter labels onto name. They always end in ':'.
+ (while (re-search-forward "\\(\\sw+:\\)" limit 1)
+ (setq method (concat method (match-string-no-properties 1))))
+ (concat "[" class " " method "]"))))
+
(t ; Normal function or initializer.
(when (looking-at c-defun-type-name-decl-key) ; struct, etc.
(goto-char (match-end 0))
@@ -2230,11 +2325,11 @@ with a brace block, at the outermost level of nesting."
(c-save-buffer-state ((paren-state (c-parse-state))
(orig-point-min (point-min))
(orig-point-max (point-max))
- lim name where limits fdoc)
+ lim name limits)
(setq lim (c-widen-to-enclosing-decl-scope
paren-state orig-point-min orig-point-max))
(and lim (setq lim (1- lim)))
- (c-while-widening-to-decl-block (not (setq name (c-defun-name-1))))
+ (c-while-widening-to-decl-block (not (setq name (c-defun-name-1))) t)
(when name
(setq limits (c-declaration-limits-1 near))
(cons name limits)))
@@ -2261,7 +2356,7 @@ With a prefix arg, push the name onto the kill ring too."
(put 'c-display-defun-name 'isearch-scroll t)
(defun c-mark-function ()
- "Put mark at end of the current top-level declaration or macro, point at beginning.
+ "Put mark at end of current top-level declaration or macro, point at beginning.
If point is not inside any then the closest following one is
chosen. Each successive call of this command extends the marked
region by one function.
@@ -2850,10 +2945,13 @@ function does not require the declaration to contain a brace block."
(c-looking-at-special-brace-list)))
(or allow-early-stop (/= here last))
(save-excursion ; Is this a check that we're NOT at top level?
-;;;; NO! This seems to check that (i) EITHER we're at the top level; OR (ii) The next enclosing
-;;;; level of bracketing is a '{'. HMM. Doesn't seem to make sense.
-;;;; 2003/8/8 This might have something to do with the GCC extension "Statement Expressions", e.g.
-;;;; while ({stmt1 ; stmt2 ; exp ;}). This form excludes such Statement Expressions.
+;;;; NO! This seems to check that (i) EITHER we're at the top level;
+;;;; OR (ii) The next enclosing level of bracketing is a '{'. HMM.
+;;;; Doesn't seem to make sense.
+;;;; 2003/8/8 This might have something to do with the GCC extension
+;;;; "Statement Expressions", e.g.
+;;;; while ({stmt1 ; stmt2 ; exp ;}).
+;;;; This form excludes such Statement Expressions.
(or (not (c-safe (up-list -1) t))
(= (char-after) ?{))))
(goto-char last)
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 02415943e4b..5d93435066f 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -1,4 +1,4 @@
-;;; cc-defs.el --- compile time definitions for CC Mode
+;;; cc-defs.el --- compile time definitions for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -87,7 +87,7 @@
;;; Variables also used at compile time.
-(defconst c-version "5.34.1"
+(defconst c-version "5.35.1"
"CC Mode version number.")
(defconst c-version-sym (intern c-version))
@@ -125,7 +125,7 @@ The result of the body appears to the compiler as a quoted constant.
This variant works around bugs in `eval-when-compile' in various
\(X)Emacs versions. See cc-defs.el for details."
-
+ (declare (indent 0) (debug t))
(if c-inside-eval-when-compile
;; XEmacs 21.4.6 has a bug in `eval-when-compile' in that it
;; evaluates its body at macro expansion time if it's nested
@@ -170,9 +170,7 @@ This variant works around bugs in `eval-when-compile' in various
;; constant that we eval. That otoh introduce a problem in
;; that a returned lambda expression doesn't get byte
;; compiled (even if `function' is used).
- (eval '(let ((c-inside-eval-when-compile t)) ,@body)))))
-
- (put 'cc-eval-when-compile 'lisp-indent-hook 0))
+ (eval '(let ((c-inside-eval-when-compile t)) ,@body))))))
;;; Macros.
@@ -181,6 +179,7 @@ This variant works around bugs in `eval-when-compile' in various
;; between the host [X]Emacsen."
;; The motivation for this macro is to avoid the irritating message
;; "function `mapcan' from cl package called at runtime" produced by Emacs.
+ (declare (debug t))
(cond
((and (fboundp 'mapcan)
(subrp (symbol-function 'mapcan)))
@@ -196,18 +195,21 @@ This variant works around bugs in `eval-when-compile' in various
(defmacro c--set-difference (liszt1 liszt2 &rest other-args)
;; Macro to smooth out the renaming of `set-difference' in Emacs 24.3.
+ (declare (debug (form form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-set-difference ,liszt1 ,liszt2 ,@other-args)
`(set-difference ,liszt1 ,liszt2 ,@other-args)))
(defmacro c--intersection (liszt1 liszt2 &rest other-args)
;; Macro to smooth out the renaming of `intersection' in Emacs 24.3.
+ (declare (debug (form form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-intersection ,liszt1 ,liszt2 ,@other-args)
`(intersection ,liszt1 ,liszt2 ,@other-args)))
(eval-and-compile
(defmacro c--macroexpand-all (form &optional environment)
+ (declare (debug t))
;; Macro to smooth out the renaming of `cl-macroexpand-all' in Emacs 24.3.
(if (fboundp 'macroexpand-all)
`(macroexpand-all ,form ,environment)
@@ -215,6 +217,7 @@ This variant works around bugs in `eval-when-compile' in various
(defmacro c--delete-duplicates (cl-seq &rest cl-keys)
;; Macro to smooth out the renaming of `delete-duplicates' in Emacs 24.3.
+ (declare (debug (form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-delete-duplicates ,cl-seq ,@cl-keys)
`(delete-duplicates ,cl-seq ,@cl-keys))))
@@ -222,6 +225,7 @@ This variant works around bugs in `eval-when-compile' in various
(defmacro c-font-lock-flush (beg end)
"Declare the region BEG...END's fontification as out-of-date.
On XEmacs and older Emacsen, this refontifies that region immediately."
+ (declare (debug t))
(if (fboundp 'font-lock-flush)
`(font-lock-flush ,beg ,end)
`(font-lock-fontify-region ,beg ,end)))
@@ -249,6 +253,7 @@ one of the following symbols:
If the referenced position doesn't exist, the closest accessible point
to it is returned. This function does not modify the point or the mark."
+ (declare (debug t))
(if (eq (car-safe position) 'quote)
(let ((position (eval position)))
(cond
@@ -417,6 +422,7 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-is-escaped (pos)
;; Are there an odd number of backslashes before POS?
+ (declare (debug t))
`(save-excursion
(goto-char ,pos)
(not (zerop (logand (skip-chars-backward "\\\\") 1)))))
@@ -424,6 +430,7 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-will-be-escaped (pos beg end)
;; Will the character after POS be escaped after the removal of (BEG END)?
;; It is assumed that (>= POS END).
+ (declare (debug t))
`(save-excursion
(let ((-end- ,end)
count)
@@ -434,10 +441,20 @@ to it is returned. This function does not modify the point or the mark."
(setq count (+ count (skip-chars-backward "\\\\"))))
(not (zerop (logand count 1))))))
+(defmacro c-will-be-unescaped (beg)
+ ;; Would the character after BEG be unescaped?
+ (declare (debug t))
+ `(save-excursion
+ (let (count)
+ (goto-char ,beg)
+ (setq count (skip-chars-backward "\\\\"))
+ (zerop (logand count 1)))))
+
(defvar c-use-extents)
(defmacro c-next-single-property-change (position prop &optional object limit)
;; See the doc string for either of the defuns expanded to.
+ (declare (debug t))
(if (and c-use-extents
(fboundp 'next-single-char-property-change))
;; XEmacs >= 2005-01-25
@@ -445,6 +462,16 @@ to it is returned. This function does not modify the point or the mark."
;; Emacs and earlier XEmacs
`(next-single-property-change ,position ,prop ,object ,limit)))
+(defmacro c-previous-single-property-change (position prop &optional object limit)
+ ;; See the doc string for either of the defuns expanded to.
+ (declare (debug t))
+ (if (and c-use-extents
+ (fboundp 'previous-single-char-property-change))
+ ;; XEmacs >= 2005-01-25
+ `(previous-single-char-property-change ,position ,prop ,object ,limit)
+ ;; Emacs and earlier XEmacs
+ `(previous-single-property-change ,position ,prop ,object ,limit)))
+
(defmacro c-region-is-active-p ()
;; Return t when the region is active. The determination of region
;; activeness is different in both Emacs and XEmacs.
@@ -457,6 +484,7 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-set-region-active (activate)
;; Activate the region if ACTIVE is non-nil, deactivate it
;; otherwise. Covers the differences between Emacs and XEmacs.
+ (declare (debug t))
(if (fboundp 'zmacs-activate-region)
;; XEmacs.
`(if ,activate
@@ -466,6 +494,7 @@ to it is returned. This function does not modify the point or the mark."
`(setq mark-active ,activate)))
(defmacro c-set-keymap-parent (map parent)
+ (declare (debug t))
(cond
;; XEmacs
((cc-bytecomp-fboundp 'set-keymap-parents)
@@ -478,6 +507,7 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-delete-and-extract-region (start end)
"Delete the text between START and END and return it."
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'delete-and-extract-region)
;; Emacs 21.1 and later
`(delete-and-extract-region ,start ,end)
@@ -488,15 +518,16 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-safe (&rest body)
;; safely execute BODY, return nil if an error occurred
+ (declare (indent 0) (debug t))
`(condition-case nil
(progn ,@body)
(error nil)))
-(put 'c-safe 'lisp-indent-function 0)
(defmacro c-int-to-char (integer)
;; In Emacs, a character is an integer. In XEmacs, a character is a
;; type distinct from an integer. Sometimes we need to convert integers to
;; characters. `c-int-to-char' makes this conversion, if necessary.
+ (declare (debug t))
(if (fboundp 'int-to-char)
`(int-to-char ,integer)
integer))
@@ -504,6 +535,7 @@ to it is returned. This function does not modify the point or the mark."
(defmacro c-characterp (arg)
;; Return t when ARG is a character (XEmacs) or integer (Emacs), otherwise
;; return nil.
+ (declare (debug t))
(if (integerp ?c)
`(integerp ,arg)
`(characterp ,arg)))
@@ -550,6 +582,7 @@ to it is returned. This function does not modify the point or the mark."
;; string opener, or after the introductory R of one. The match data is
;; overwritten. On success the opener's identifier will be (match-string
;; 1). Text properties on any characters are ignored.
+ (declare (debug t))
(if pos
`(save-excursion
(goto-char ,pos)
@@ -582,7 +615,7 @@ must not be within a `c-save-buffer-state', since the user then
wouldn't be able to undo them.
The return value is the value of the last form in BODY."
- (declare (debug t) (indent 1))
+ (declare (debug let*) (indent 1))
(if (fboundp 'with-silent-modifications)
`(with-silent-modifications (let* ,varlist ,@body))
`(let* ((modified (buffer-modified-p)) (buffer-undo-list t)
@@ -611,6 +644,7 @@ If BODY makes a change that unconditionally is undone then wrap this
macro inside `c-save-buffer-state'. That way the change can be done
even when the buffer is read-only, and without interference from
various buffer change hooks."
+ (declare (indent 0) (debug t))
`(let (-tnt-chng-keep
-tnt-chng-state)
(unwind-protect
@@ -621,7 +655,6 @@ various buffer change hooks."
-tnt-chng-state (c-tnt-chng-record-state)
-tnt-chng-keep (progn ,@body))
(c-tnt-chng-cleanup -tnt-chng-keep -tnt-chng-state))))
-(put 'c-tentative-buffer-changes 'lisp-indent-function 0)
(defun c-tnt-chng-record-state ()
;; Used internally in `c-tentative-buffer-changes'.
@@ -674,14 +707,17 @@ whitespace.
LIMIT sets an upper limit of the forward movement, if specified. If
LIMIT or the end of the buffer is reached inside a comment or
-preprocessor directive, the point will be left there.
+preprocessor directive, the point will be left there. If point starts
+on the wrong side of LIMIT, it stays unchanged.
Note that this function might do hidden buffer changes. See the
comment at the start of cc-engine.el for more info."
+ (declare (debug t))
(if limit
- `(save-restriction
- (narrow-to-region (point-min) (or ,limit (point-max)))
- (c-forward-sws))
+ `(when (< (point) (or ,limit (point-max)))
+ (save-restriction
+ (narrow-to-region (point-min) (or ,limit (point-max)))
+ (c-forward-sws)))
'(c-forward-sws)))
(defmacro c-backward-syntactic-ws (&optional limit)
@@ -693,14 +729,17 @@ whitespace.
LIMIT sets a lower limit of the backward movement, if specified. If
LIMIT is reached inside a line comment or preprocessor directive then
-the point is moved into it past the whitespace at the end.
+the point is moved into it past the whitespace at the end. If point
+starts on the wrong side of LIMIT, it stays unchanged.
Note that this function might do hidden buffer changes. See the
comment at the start of cc-engine.el for more info."
+ (declare (debug t))
(if limit
- `(save-restriction
- (narrow-to-region (or ,limit (point-min)) (point-max))
- (c-backward-sws))
+ `(when (> (point) (or ,limit (point-min)))
+ (save-restriction
+ (narrow-to-region (or ,limit (point-min)) (point-max))
+ (c-backward-sws)))
'(c-backward-sws)))
(defmacro c-forward-sexp (&optional count)
@@ -712,11 +751,13 @@ This is like `forward-sexp' except that it isn't interactive and does
not do any user friendly adjustments of the point and that it isn't
susceptible to user configurations such as disabling of signals in
certain situations."
+ (declare (debug t))
(or count (setq count 1))
`(goto-char (scan-sexps (point) ,count)))
(defmacro c-backward-sexp (&optional count)
"See `c-forward-sexp' and reverse directions."
+ (declare (debug t))
(or count (setq count 1))
`(c-forward-sexp ,(if (numberp count) (- count) `(- ,count))))
@@ -726,6 +767,7 @@ for unbalanced parens.
A limit for the search may be given. FROM is assumed to be on the
right side of it."
+ (declare (debug t))
(let ((res (if (featurep 'xemacs)
`(scan-lists ,from ,count ,depth nil t)
`(c-safe (scan-lists ,from ,count ,depth)))))
@@ -753,6 +795,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
before it."
+ (declare (debug t))
`(let ((dest (c-safe-scan-lists ,(or pos '(point)) 1 0 ,limit)))
(when dest (goto-char dest) dest)))
@@ -763,6 +806,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
after it."
+ (declare (debug t))
`(let ((dest (c-safe-scan-lists ,(or pos '(point)) -1 0 ,limit)))
(when dest (goto-char dest) dest)))
@@ -772,6 +816,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) 1 1 ,limit))
(defmacro c-up-list-backward (&optional pos limit)
@@ -780,6 +825,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) -1 1 ,limit))
(defmacro c-down-list-forward (&optional pos limit)
@@ -788,6 +834,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) 1 -1 ,limit))
(defmacro c-down-list-backward (&optional pos limit)
@@ -796,6 +843,7 @@ or nil if no such position exists. The point is used if POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) -1 -1 ,limit))
(defmacro c-go-up-list-forward (&optional pos limit)
@@ -805,6 +853,7 @@ position exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(let ((dest (c-up-list-forward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -815,6 +864,7 @@ position exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(let ((dest (c-up-list-backward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -825,6 +875,7 @@ exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(let ((dest (c-down-list-forward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -835,6 +886,7 @@ exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(let ((dest (c-down-list-backward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -946,6 +998,7 @@ be after it."
;; point)? Always returns nil for languages which don't have Virtual
;; semicolons.
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(if c-at-vsemi-p-fn
(funcall c-at-vsemi-p-fn ,@(if pos `(,pos)))))
@@ -963,6 +1016,7 @@ be after it."
(defmacro c-benign-error (format &rest args)
;; Formats an error message for the echo area and dings, i.e. like
;; `error' but doesn't abort.
+ (declare (debug t))
`(progn
(message ,format ,@args)
(ding)))
@@ -972,18 +1026,19 @@ be after it."
;; way to execute code.
;; Maintainers' note: If TABLE is `c++-template-syntax-table', DON'T call
;; any forms inside this that call `c-parse-state'. !!!!
+ (declare (indent 1) (debug t))
`(let ((c-with-syntax-table-orig-table (syntax-table)))
(unwind-protect
(progn
(set-syntax-table ,table)
,@code)
(set-syntax-table c-with-syntax-table-orig-table))))
-(put 'c-with-syntax-table 'lisp-indent-function 1)
(defmacro c-skip-ws-forward (&optional limit)
"Skip over any whitespace following point.
This function skips over horizontal and vertical whitespace and line
continuations."
+ (declare (debug t))
(if limit
`(let ((limit (or ,limit (point-max))))
(while (progn
@@ -1005,6 +1060,7 @@ continuations."
"Skip over any whitespace preceding point.
This function skips over horizontal and vertical whitespace and line
continuations."
+ (declare (debug t))
(if limit
`(let ((limit (or ,limit (point-min))))
(while (progn
@@ -1027,6 +1083,7 @@ continuations."
"Return non-nil if the current CC Mode major mode is MODE.
MODE is either a mode symbol or a list of mode symbols."
+ (declare (debug t))
(if c-langs-are-parametric
;; Inside a `c-lang-defconst'.
`(c-lang-major-mode-is ,mode)
@@ -1047,15 +1104,6 @@ MODE is either a mode symbol or a list of mode symbols."
;; properties set on a single character and that never spread to any
;; other characters.
-(defmacro c-put-syn-tab (pos value)
- ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to
- ;; VALUE (which should not be nil).
- `(let ((-pos- ,pos)
- (-value- ,value))
- (c-put-char-property -pos- 'syntax-table -value-)
- (c-put-char-property -pos- 'c-fl-syn-tab -value-)
- (c-truncate-lit-pos-cache -pos-)))
-
(eval-and-compile
;; Constant used at compile time to decide whether or not to use
;; XEmacs extents. Check all the extent functions we'll use since
@@ -1118,6 +1166,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; 21) then it's assumed that the property is present on it.
;;
;; This macro does a hidden buffer change.
+ (declare (debug t))
(setq property (eval property))
(if (or c-use-extents
(not (cc-bytecomp-boundp 'text-property-default-nonsticky)))
@@ -1135,6 +1184,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; Get the value of the given property on the character at POS if
;; it's been put there by `c-put-char-property'. PROPERTY is
;; assumed to be constant.
+ (declare (debug t))
(setq property (eval property))
(if c-use-extents
;; XEmacs.
@@ -1165,6 +1215,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; constant.
;;
;; This macro does a hidden buffer change.
+ (declare (debug t))
(setq property (eval property))
(cond (c-use-extents
;; XEmacs.
@@ -1183,17 +1234,11 @@ MODE is either a mode symbol or a list of mode symbols."
;; Emacs < 21.
`(c-clear-char-property-fun ,pos ',property))))
-(defmacro c-clear-syn-tab (pos)
- ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS.
- `(let ((-pos- ,pos))
- (c-clear-char-property -pos- 'syntax-table)
- (c-clear-char-property -pos- 'c-fl-syn-tab)
- (c-truncate-lit-pos-cache -pos-)))
-
(defmacro c-min-property-position (from to property)
;; Return the first position in the range [FROM to) where the text property
;; PROPERTY is set, or `most-positive-fixnum' if there is no such position.
;; PROPERTY should be a quoted constant.
+ (declare (debug t))
`(let ((-from- ,from) (-to- ,to) pos)
(cond
((and (< -from- -to-)
@@ -1215,6 +1260,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; `syntax-table'.
;;
;; This macro does hidden buffer changes.
+ (declare (debug t))
(setq property (eval property))
(if c-use-extents
;; XEmacs.
@@ -1234,9 +1280,20 @@ MODE is either a mode symbol or a list of mode symbols."
(defmacro c-clear-syn-tab-properties (from to)
;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text
;; properties between FROM and TO.
+ (declare (debug t))
`(let ((-from- ,from) (-to- ,to))
- (c-clear-char-properties -from- -to- 'syntax-table)
- (c-clear-char-properties -from- -to- 'c-fl-syn-tab)))
+ (when (and
+ c-min-syn-tab-mkr c-max-syn-tab-mkr
+ (< -from- c-max-syn-tab-mkr)
+ (> -to- c-min-syn-tab-mkr))
+ (let ((pos -from-))
+ (while (and
+ (< pos -to-)
+ (setq pos (c-min-property-position pos -to- 'c-fl-syn-tab))
+ (< pos -to-))
+ (c-clear-syn-tab pos)
+ (setq pos (1+ pos)))))
+ (c-clear-char-properties -from- -to- 'syntax-table)))
(defmacro c-search-forward-char-property (property value &optional limit)
"Search forward for a text-property PROPERTY having value VALUE.
@@ -1245,6 +1302,7 @@ 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."
+ (declare (debug t))
`(let ((place (point)))
(while
(and
@@ -1264,6 +1322,7 @@ 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."
+ (declare (debug t))
`(let ((place (point)))
(while
(and
@@ -1307,6 +1366,7 @@ been put there by c-put-char-property. POINT remains unchanged."
which have the value VALUE, as tested by `equal'. These
properties are assumed to be over individual characters, having
been put there by c-put-char-property. POINT remains unchanged."
+ (declare (debug t))
(if c-use-extents
;; XEmacs
`(let ((-property- ,property))
@@ -1327,6 +1387,7 @@ PROPERTY must be a constant.
Leave point just after the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-max)))
(-value- ,value))
@@ -1350,6 +1411,7 @@ PROPERTY must be a constant.
Leave point just before the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-min)))
(-value- ,value))
@@ -1373,6 +1435,7 @@ PROPERTY must be a constant.
Leave point just after the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-max)))
(-value- ,value))
@@ -1421,6 +1484,7 @@ by `equal'. These properties are assumed to be over individual
characters, having been put there by c-put-char-property. POINT
remains unchanged. Return the position of the first removed
property, or nil."
+ (declare (debug t))
(if c-use-extents
;; XEmacs
`(let ((-property- ,property)
@@ -1444,6 +1508,7 @@ property, or nil."
;; `c-put-char-property' must be a constant.
"Put the text property PROPERTY with value VALUE on characters
with value CHAR in the region [FROM to)."
+ (declare (debug t))
`(let ((skip-string (concat "^" (list ,char)))
(-to- ,to))
(save-excursion
@@ -1456,28 +1521,6 @@ with value CHAR in the region [FROM to)."
(c-put-char-property (point) ,property ,value)
(forward-char)))))
-(defmacro c-with-extended-string-fences (beg end &rest body)
- ;; If needed, extend the region with "mirrored" c-fl-syn-tab properties to
- ;; contain the region (BEG END), then evaluate BODY. If this mirrored
- ;; region was initially empty, restore it afterwards.
- `(let ((-beg- ,beg)
- (-end- ,end)
- )
- (cond
- ((null c-fl-syn-tab-region)
- (unwind-protect
- (progn
- (c-restore-string-fences -beg- -end-)
- ,@body)
- (c-clear-string-fences)))
- ((and (>= -beg- (car c-fl-syn-tab-region))
- (<= -end- (cdr c-fl-syn-tab-region)))
- ,@body)
- (t ; Crudely extend the mirrored region.
- (setq -beg- (min -beg- (car c-fl-syn-tab-region))
- -end- (max -end- (cdr c-fl-syn-tab-region)))
- (c-restore-string-fences -beg- -end-)
- ,@body))))
;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text.
;; For our purposes, these are characterized by being possible to
@@ -1488,6 +1531,7 @@ with value CHAR in the region [FROM to)."
;; Put an overlay/extent covering the given range in the current
;; buffer. It's currently undefined whether it's front/end sticky
;; or not. The overlay/extent object is returned.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'make-overlay)
;; Emacs.
`(let ((ol (make-overlay ,from ,to)))
@@ -1501,6 +1545,7 @@ with value CHAR in the region [FROM to)."
(defmacro c-delete-overlay (overlay)
;; Deletes an overlay/extent object previously retrieved using
;; `c-put-overlay'.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'make-overlay)
;; Emacs.
`(delete-overlay ,overlay)
@@ -1508,80 +1553,6 @@ with value CHAR in the region [FROM to)."
`(delete-extent ,overlay)))
-;; Make edebug understand the macros.
-;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '(progn
-(def-edebug-spec cc-eval-when-compile (&rest def-form))
-(def-edebug-spec c-font-lock-flush t)
-(def-edebug-spec c--mapcan t)
-(def-edebug-spec c--set-difference (form form &rest [symbolp form]))
-(def-edebug-spec c--intersection (form form &rest [symbolp form]))
-(def-edebug-spec c--delete-duplicates (form &rest [symbolp form]))
-(def-edebug-spec c-point t)
-(def-edebug-spec c-is-escaped t)
-(def-edebug-spec c-will-be-escaped t)
-(def-edebug-spec c-next-single-property-change t)
-(def-edebug-spec c-delete-and-extract-region t)
-(def-edebug-spec c-set-region-active t)
-(def-edebug-spec c-set-keymap-parent t)
-(def-edebug-spec c-safe t)
-(def-edebug-spec c-int-to-char t)
-(def-edebug-spec c-characterp t)
-(def-edebug-spec c-save-buffer-state let*)
-(def-edebug-spec c-tentative-buffer-changes t)
-(def-edebug-spec c-forward-syntactic-ws t)
-(def-edebug-spec c-backward-syntactic-ws t)
-(def-edebug-spec c-forward-sexp t)
-(def-edebug-spec c-backward-sexp t)
-(def-edebug-spec c-safe-scan-lists t)
-(def-edebug-spec c-go-list-forward t)
-(def-edebug-spec c-go-list-backward t)
-(def-edebug-spec c-up-list-forward t)
-(def-edebug-spec c-up-list-backward t)
-(def-edebug-spec c-down-list-forward t)
-(def-edebug-spec c-down-list-backward t)
-(def-edebug-spec c-go-up-list-forward t)
-(def-edebug-spec c-go-up-list-backward t)
-(def-edebug-spec c-go-down-list-forward t)
-(def-edebug-spec c-go-down-list-backward t)
-(def-edebug-spec c-at-vsemi-p t)
-(def-edebug-spec c-add-syntax t)
-(def-edebug-spec c-add-class-syntax t)
-(def-edebug-spec c-benign-error t)
-(def-edebug-spec c-with-syntax-table t)
-(def-edebug-spec c-skip-ws-forward t)
-(def-edebug-spec c-skip-ws-backward t)
-(def-edebug-spec c-major-mode-is t)
-(def-edebug-spec c-search-forward-char-property t)
-(def-edebug-spec c-search-backward-char-property t)
-(def-edebug-spec c-put-char-property t)
-(def-edebug-spec c-put-syn-tab t)
-(def-edebug-spec c-get-char-property t)
-(def-edebug-spec c-clear-char-property t)
-(def-edebug-spec c-clear-syn-tab t)
-;;(def-edebug-spec c-min-property-position nil) ; invoked only by macros
-(def-edebug-spec c-min-property-position t) ; Now invoked from functions (2019-07)
-(def-edebug-spec c-clear-char-property-with-value t)
-(def-edebug-spec c-clear-char-property-with-value-on-char t)
-(def-edebug-spec c-put-char-properties-on-char t)
-(def-edebug-spec c-clear-char-properties t)
-(def-edebug-spec c-clear-syn-tab-properties t)
-(def-edebug-spec c-with-extended-string-fences (form form body))
-(def-edebug-spec c-put-overlay t)
-(def-edebug-spec c-delete-overlay t)
-(def-edebug-spec c-mark-<-as-paren t)
-(def-edebug-spec c-mark->-as-paren t)
-(def-edebug-spec c-unmark-<->-as-paren t)
-(def-edebug-spec c-with-<->-as-parens-suppressed (body))
-(def-edebug-spec c-self-bind-state-cache (body))
-(def-edebug-spec c-sc-scan-lists-no-category+1+1 t)
-(def-edebug-spec c-sc-scan-lists-no-category+1-1 t)
-(def-edebug-spec c-sc-scan-lists-no-category-1+1 t)
-(def-edebug-spec c-sc-scan-lists-no-category-1-1 t)
-(def-edebug-spec c-sc-scan-lists t)
-(def-edebug-spec c-sc-parse-partial-sexp t);))
-
-
;;; Functions.
;; Note: All these after the macros, to be on safe side in avoiding
@@ -1611,6 +1582,7 @@ with value CHAR in the region [FROM to)."
;; 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'.
+ (declare (debug t))
(if c-use-category
`(c-put-char-property ,pos 'category 'c-<-as-paren-syntax)
`(c-put-char-property ,pos 'syntax-table c-<-as-paren-syntax)))
@@ -1625,6 +1597,7 @@ with value CHAR in the region [FROM to)."
;; 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'.
+ (declare (debug t))
(if c-use-category
`(c-put-char-property ,pos 'category 'c->-as-paren-syntax)
`(c-put-char-property ,pos 'syntax-table c->-as-paren-syntax)))
@@ -1638,6 +1611,7 @@ with value CHAR in the region [FROM to)."
;; 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'.
+ (declare (debug t))
`(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table)))
(defsubst c-suppress-<->-as-parens ()
@@ -1658,50 +1632,13 @@ with value CHAR in the region [FROM to)."
;; Like progn, except that the paren property is suppressed on all
;; template brackets whilst they are running. This macro does a hidden
;; buffer change.
+ (declare (debug (body)))
`(unwind-protect
(progn
(c-suppress-<->-as-parens)
,@forms)
(c-restore-<->-as-parens)))
-;;;;;;;;;;;;;;;
-
-(defmacro c-self-bind-state-cache (&rest forms)
- ;; Bind the state cache to itself and execute the FORMS. Return the result
- ;; of the last FORM executed. It is assumed that no buffer changes will
- ;; happen in FORMS, and no hidden buffer changes which could affect the
- ;; parsing will be made by FORMS.
- `(let* ((c-state-cache (copy-tree c-state-cache))
- (c-state-cache-good-pos c-state-cache-good-pos)
- ;(c-state-nonlit-pos-cache (copy-tree c-state-nonlit-pos-cache))
- ;(c-state-nonlit-pos-cache-limit c-state-nonlit-pos-cache-limit)
- ;(c-state-semi-nonlit-pos-cache (copy-tree c-state-semi-nonlit-pos-cache))
- ;(c-state-semi-nonlit-pos-cache-limit c-state-semi-nonlit-pos-cache)
- (c-state-brace-pair-desert (copy-tree c-state-brace-pair-desert))
- (c-state-point-min c-state-point-min)
- (c-state-point-min-lit-type c-state-point-min-lit-type)
- (c-state-point-min-lit-start c-state-point-min-lit-start)
- (c-state-min-scan-pos c-state-min-scan-pos)
- (c-state-old-cpp-beg-marker (if (markerp c-state-old-cpp-beg-marker)
- (copy-marker c-state-old-cpp-beg-marker)
- c-state-old-cpp-beg-marker))
- (c-state-old-cpp-beg (if (markerp c-state-old-cpp-beg)
- c-state-old-cpp-beg-marker
- c-state-old-cpp-beg))
- (c-state-old-cpp-end-marker (if (markerp c-state-old-cpp-end-marker)
- (copy-marker c-state-old-cpp-end-marker)
- c-state-old-cpp-end-marker))
- (c-state-old-cpp-end (if (markerp c-state-old-cpp-end)
- c-state-old-cpp-end-marker
- c-state-old-cpp-end))
- (c-parse-state-state c-parse-state-state))
- (prog1
- (progn ,@forms)
- (if (markerp c-state-old-cpp-beg-marker)
- (move-marker c-state-old-cpp-beg-marker nil))
- (if (markerp c-state-old-cpp-end-marker)
- (move-marker c-state-old-cpp-end-marker nil)))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following macros are to be used only in `c-parse-state' and its
;; subroutines. Their main purpose is to simplify the handling of C++/Java
@@ -1715,8 +1652,8 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM 1 1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
- `(let ((here (point))
- (pos (scan-lists ,from 1 1)))
+ (declare (debug t))
+ `(let ((pos (scan-lists ,from 1 1)))
(while (eq (char-before pos) ?>)
(setq pos (scan-lists pos 1 1)))
pos))
@@ -1725,8 +1662,8 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM 1 -1). Any finishing position which either (i) is
;; determined by an angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
- `(let ((here (point))
- (pos (scan-lists ,from 1 -1)))
+ (declare (debug t))
+ `(let ((pos (scan-lists ,from 1 -1)))
(while (eq (char-before pos) ?<)
(setq pos (scan-lists pos 1 1))
(setq pos (scan-lists pos 1 -1)))
@@ -1736,8 +1673,8 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM -1 1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
- `(let ((here (point))
- (pos (scan-lists ,from -1 1)))
+ (declare (debug t))
+ `(let ((pos (scan-lists ,from -1 1)))
(while (eq (char-after pos) ?<)
(setq pos (scan-lists pos -1 1)))
pos))
@@ -1746,14 +1683,15 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM -1 -1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
- `(let ((here (point))
- (pos (scan-lists ,from -1 -1)))
+ (declare (debug t))
+ `(let ((pos (scan-lists ,from -1 -1)))
(while (eq (char-after pos) ?>)
(setq pos (scan-lists pos -1 1))
(setq pos (scan-lists pos -1 -1)))
pos))
(defmacro c-sc-scan-lists (from count depth)
+ (declare (debug t))
(if c-use-category
`(scan-lists ,from ,count ,depth)
(cond
@@ -1801,6 +1739,7 @@ with value CHAR in the region [FROM to)."
(defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore
oldstate)
+ (declare (debug t))
(if c-use-category
`(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate)
`(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore
@@ -2361,6 +2300,7 @@ system."
"Can be used inside a VAL in `c-lang-defconst' to evaluate FORM
immediately, i.e. at the same time as the `c-lang-defconst' form
itself is evaluated."
+ (declare (debug t))
;; Evaluate at macro expansion time, i.e. in the
;; `c--macroexpand-all' inside `c-lang-defconst'.
(eval form))
@@ -2403,7 +2343,8 @@ one `c-lang-defconst' for each NAME is permitted per file. If there
already is one it will be completely replaced; the value in the
earlier definition will not affect `c-lang-const' on the same
constant. A file is identified by its base name."
-
+ (declare (indent 1)
+ (debug (&define name [&optional stringp] [&rest sexp def-form])))
(let* ((sym (intern (symbol-name name) c-lang-constants))
;; Make `c-lang-const' expand to a straightforward call to
;; `c-get-lang-constant' in `c--macroexpand-all' below.
@@ -2494,12 +2435,6 @@ constant. A file is identified by its base name."
(c-define-lang-constant ',name ,bindings
,@(and pre-files `(',pre-files))))))
-(put 'c-lang-defconst 'lisp-indent-function 1)
-;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '
-(def-edebug-spec c-lang-defconst
- (&define name [&optional stringp] [&rest sexp def-form]))
-
(defun c-define-lang-constant (name bindings &optional pre-files)
;; Used by `c-lang-defconst'.
@@ -2555,6 +2490,7 @@ LANG is the name of the language, i.e. the mode name without the
language. NAME and LANG are not evaluated so they should not be
quoted."
+ (declare (debug (name &optional symbolp)))
(or (symbolp name)
(error "Not a symbol: %S" name))
(or (symbolp lang)
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index 9cba87f4d91..984a75c4b83 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -1,4 +1,4 @@
-;;; cc-engine.el --- core syntax guessing engine for CC mode -*- coding: utf-8 -*-
+;;; cc-engine.el --- core syntax guessing engine for CC mode -*- lexical-binding:t; coding: utf-8 -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -163,7 +163,11 @@
(defvar c-doc-line-join-re)
(defvar c-doc-bright-comment-start-re)
(defvar c-doc-line-join-end-ch)
-(defvar c-fl-syn-tab-region)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
+(cc-bytecomp-defvar c-min-syn-tab-mkr)
+(cc-bytecomp-defvar c-max-syn-tab-mkr)
+(cc-bytecomp-defun c-clear-syn-tab)
(cc-bytecomp-defun c-clear-string-fences)
(cc-bytecomp-defun c-restore-string-fences)
@@ -405,7 +409,7 @@ comment at the start of cc-engine.el for more info."
(when (and (car c-macro-cache)
(> (point) (car c-macro-cache)) ; in case we have a
; zero-sized region.
- (not (eq (char-before (1- (point))) ?\\)))
+ (not lim))
(setcdr c-macro-cache (point))
(setq c-macro-cache-syntactic nil)))))))
@@ -733,6 +737,7 @@ comment at the start of cc-engine.el for more info."
'(setq stack (cons (cons state saved-pos)
stack)))
(defmacro c-bos-pop-state (&optional do-if-done)
+ (declare (debug t))
`(if (setq state (car (car stack))
saved-pos (cdr (car stack))
stack (cdr stack))
@@ -757,6 +762,7 @@ comment at the start of cc-engine.el for more info."
(goto-char pos)
(setq sym nil)))
(defmacro c-bos-save-error-info (missing got)
+ (declare (debug t))
`(setq saved-pos (vector pos ,missing ,got)))
(defmacro c-bos-report-error ()
'(unless noerror
@@ -970,7 +976,7 @@ comment at the start of cc-engine.el for more info."
;; that we've moved.
(while (progn
(setq pos (point))
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws lim)
;; Protect post-++/-- operators just before a virtual semicolon.
(and (not (c-at-vsemi-p))
(/= (skip-chars-backward "-+!*&~@`#") 0))))
@@ -982,7 +988,7 @@ comment at the start of cc-engine.el for more info."
(if (and (memq (char-before) delims)
(progn (forward-char -1)
(setq saved (point))
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws lim)
(or (memq (char-before) delims)
(memq (char-before) '(?: nil))
(eq (char-syntax (char-before)) ?\()
@@ -1162,7 +1168,7 @@ comment at the start of cc-engine.el for more info."
;; HERE IS THE SINGLE PLACE INSIDE THE PDA LOOP WHERE WE MOVE
;; BACKWARDS THROUGH THE SOURCE.
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws lim)
(let ((before-sws-pos (point))
;; The end position of the area to search for statement
;; barriers in this round.
@@ -1172,33 +1178,44 @@ comment at the start of cc-engine.el for more info."
;; Go back over exactly one logical sexp, taking proper
;; account of macros and escaped EOLs.
(while
- (progn
- (setq comma-delimited (and (not comma-delim)
- (eq (char-before) ?\,)))
- (unless (c-safe (c-backward-sexp) t)
- ;; Give up if we hit an unbalanced block. Since the
- ;; stack won't be empty the code below will report a
- ;; suitable error.
- (setq pre-stmt-found t)
- (throw 'loop nil))
- (cond
- ;; Have we moved into a macro?
- ((and (not macro-start)
- (c-beginning-of-macro))
- (save-excursion
- (c-backward-syntactic-ws)
- (setq before-sws-pos (point)))
- ;; Have we crossed a statement boundary? If not,
- ;; keep going back until we find one or a "real" sexp.
- (and
+ (and
+ (progn
+ (setq comma-delimited (and (not comma-delim)
+ (eq (char-before) ?\,)))
+ (unless (c-safe (c-backward-sexp) t)
+ ;; Give up if we hit an unbalanced block. Since the
+ ;; stack won't be empty the code below will report a
+ ;; suitable error.
+ (setq pre-stmt-found t)
+ (throw 'loop nil))
+ ;; Handle C++'s `constexpr', etc.
+ (if (save-excursion
+ (and (looking-at c-block-stmt-hangon-key)
+ (progn
+ (c-backward-syntactic-ws lim)
+ (c-safe (c-backward-sexp) t))
+ (looking-at c-block-stmt-2-key)
+ (setq pos (point))))
+ (goto-char pos))
+ (cond
+ ;; Have we moved into a macro?
+ ((and (not macro-start)
+ (c-beginning-of-macro))
(save-excursion
- (c-end-of-macro)
- (not (c-crosses-statement-barrier-p
- (point) maybe-after-boundary-pos)))
- (setq maybe-after-boundary-pos (point))))
- ;; Have we just gone back over an escaped NL? This
- ;; doesn't count as a sexp.
- ((looking-at "\\\\$")))))
+ (c-backward-syntactic-ws lim)
+ (setq before-sws-pos (point)))
+ ;; Have we crossed a statement boundary? If not,
+ ;; keep going back until we find one or a "real" sexp.
+ (and
+ (save-excursion
+ (c-end-of-macro)
+ (not (c-crosses-statement-barrier-p
+ (point) maybe-after-boundary-pos)))
+ (setq maybe-after-boundary-pos (point))))
+ ;; Have we just gone back over an escaped NL? This
+ ;; doesn't count as a sexp.
+ ((looking-at "\\\\$"))))
+ (>= (point) lim)))
;; Have we crossed a statement boundary?
(setq boundary-pos
@@ -1410,12 +1427,14 @@ comment at the start of cc-engine.el for more info."
(setq ret 'label)))
;; Skip over the unary operators that can start the statement.
- (while (progn
- (c-backward-syntactic-ws)
- ;; protect AWK post-inc/decrement operators, etc.
- (and (not (c-at-vsemi-p (point)))
- (/= (skip-chars-backward "-.+!*&~@`#") 0)))
+ (while (and (> (point) lim)
+ (progn
+ (c-backward-syntactic-ws lim)
+ ;; protect AWK post-inc/decrement operators, etc.
+ (and (not (c-at-vsemi-p (point)))
+ (/= (skip-chars-backward "-.+!*&~@`#") 0))))
(setq pos (point)))
+
(goto-char pos)
ret)))
@@ -1580,6 +1599,7 @@ comment at the start of cc-engine.el for more info."
(save-excursion (backward-char)
(looking-at "\\s("))
(c-crosses-statement-barrier-p (point) end)))))
+(make-obsolete 'c-at-expression-start-p nil "CC mode 5.35")
;; A set of functions that covers various idiosyncrasies in
@@ -1642,6 +1662,21 @@ comment at the start of cc-engine.el for more info."
(forward-char 2)
t))))
+(defmacro c-forward-comment-minus-1 ()
+ "Call (forward-comment -1), taking care of escaped newlines.
+Return the result of `forward-comment' if it gets called, nil otherwise."
+ `(if (not comment-end-can-be-escaped)
+ (forward-comment -1)
+ (when (and (< (skip-syntax-backward " >") 0)
+ (eq (char-after) ?\n))
+ (forward-char))
+ (cond
+ ((and (eq (char-before) ?\n)
+ (eq (char-before (1- (point))) ?\\))
+ (backward-char)
+ nil)
+ (t (forward-comment -1)))))
+
(defun c-backward-single-comment ()
"Move backward past whitespace and the closest preceding comment, if any.
Return t if a comment was found, nil otherwise. In either case, the
@@ -1675,12 +1710,12 @@ This function does not do any hidden buffer changes."
;; same line.
(re-search-forward "\\=\\s *[\n\r]" start t)
- (if (if (forward-comment -1)
+ (if (if (c-forward-comment-minus-1)
(if (eolp)
;; If forward-comment above succeeded and we're at eol
;; then the newline we moved over above didn't end a
;; line comment, so we give it another go.
- (forward-comment -1)
+ (c-forward-comment-minus-1)
t))
;; Emacs <= 20 and XEmacs move back over the closer of a
@@ -1709,7 +1744,7 @@ comment at the start of cc-engine.el for more info."
(if (let (moved-comment)
(while
- (and (not (setq moved-comment (forward-comment -1)))
+ (and (not (setq moved-comment (c-forward-comment-minus-1)))
;; Cope specifically with ^M^J here -
;; forward-comment sometimes gets stuck after ^Ms,
;; sometimes after ^M^J.
@@ -1838,51 +1873,51 @@ comment at the start of cc-engine.el for more info."
; (setq in-face (point)))
; (not (eobp)))))))
-(defmacro c-debug-sws-msg (&rest args)
- (ignore args)
+(defmacro c-debug-sws-msg (&rest _args)
+ ;; (declare (debug t))
;;`(message ,@args)
)
(defmacro c-put-is-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-is-sws t)
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-add-face beg end 'c-debug-is-sws-face)))))
-(def-edebug-spec c-put-is-sws t)
(defmacro c-put-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-in-sws t)
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-add-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-put-in-sws t)
(defmacro c-remove-is-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-is-sws-face)))))
-(def-edebug-spec c-remove-is-sws t)
(defmacro c-remove-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-remove-in-sws t)
(defmacro c-remove-is-and-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-is-sws-face)
(c-debug-remove-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-remove-is-and-in-sws t)
;; The type of literal position `end' is in a `before-change-functions'
;; function - one of `c', `c++', `pound', `noise', `attribute' or nil (but NOT
@@ -1895,52 +1930,29 @@ comment at the start of cc-engine.el for more info."
(defun c-enclosing-c++-attribute ()
;; If we're in C++ Mode, and point is within a correctly balanced [[ ... ]]
;; attribute structure, return a cons of its starting and ending positions.
- ;; Otherwise, return nil. We use the c-{in,is}-sws-face text properties for
- ;; this determination, this macro being intended only for use in the *-sws-*
- ;; functions and macros. The match data are NOT preserved over this macro.
- (let (attr-end pos-is-sws)
- (and
- (c-major-mode-is 'c++-mode)
- (> (point) (point-min))
- (setq pos-is-sws
- (if (get-text-property (1- (point)) 'c-is-sws)
- (1- (point))
- (1- (previous-single-property-change
- (point) 'c-is-sws nil (point-min)))))
- (save-excursion
- (goto-char pos-is-sws)
- (setq attr-end (c-looking-at-c++-attribute)))
- (> attr-end (point))
- (cons pos-is-sws attr-end))))
-
-(defun c-slow-enclosing-c++-attribute ()
- ;; Like `c-enclosing-c++-attribute', but does not depend on the c-i[ns]-sws
- ;; properties being set.
+ ;; Otherwise, return nil.
(and
(c-major-mode-is 'c++-mode)
(save-excursion
- (let ((paren-state (c-parse-state))
+ (let ((lim (max (- (point) 200) (point-min)))
cand)
(while
- (progn
- (setq cand
- (catch 'found-cand
- (while (cdr paren-state)
- (when (and (numberp (car paren-state))
- (numberp (cadr paren-state))
- (eq (car paren-state)
- (1+ (cadr paren-state)))
- (eq (char-after (car paren-state)) ?\[)
- (eq (char-after (cadr paren-state)) ?\[))
- (throw 'found-cand (cadr paren-state)))
- (setq paren-state (cdr paren-state)))))
- (and cand
- (not
- (and (c-go-list-forward cand)
- (eq (char-before) ?\])
- (eq (char-before (1- (point))) ?\])))))
- (setq paren-state (cdr paren-state)))
- (and cand (cons cand (point)))))))
+ (and
+ (progn
+ (skip-chars-backward "^[;{}" lim)
+ (eq (char-before) ?\[))
+ (not (eq (char-before (1- (point))) ?\[))
+ (> (point) lim))
+ (backward-char))
+ (and (eq (char-before) ?\[)
+ (eq (char-before (1- (point))) ?\[)
+ (progn (backward-char 2) t)
+ (setq cand (point))
+ (c-go-list-forward nil (min (+ (point) 200) (point-max)))
+ (eq (char-before) ?\])
+ (eq (char-before (1- (point))) ?\])
+ (not (c-literal-limits))
+ (cons cand (point)))))))
(defun c-invalidate-sws-region-before (beg end)
;; Called from c-before-change. BEG and END are the bounds of the change
@@ -2243,7 +2255,7 @@ comment at the start of cc-engine.el for more info."
((and c-opt-cpp-prefix
(looking-at c-noise-macro-name-re))
- ;; Skip over a noise macro.
+ ;; Skip over a noise macro without parens.
(goto-char (match-end 1))
(not (eobp)))
@@ -2666,7 +2678,7 @@ comment at the start of cc-engine.el for more info."
;; One of the above "near" caches is associated with each of these functions.
;;
;; When searching this cache, these functions first seek an exact match, then
-;; a "close" match from the assiciated near cache. If neither of these
+;; a "close" match from the associated near cache. If neither of these
;; succeed, the nearest preceding entry in the far cache is used.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2702,16 +2714,16 @@ comment at the start of cc-engine.el for more info."
;; or the car of the list is the "position element" of ELT, the position
;; where ELT is valid.
;;
- ;; POINT is left at the postition for which the returned state is valid. It
+ ;; POINT is left at the position for which the returned state is valid. It
;; will be either the position element of ELT, or one character before
;; that. (The latter happens in Emacs <= 25 and XEmacs, when ELT indicates
;; its position element directly follows a potential first character of a
;; two char construct (such as a comment opener or an escaped character).)
(if (and (consp elt) (>= (length elt) 3))
;; Inside a string or comment
- (let ((depth 0) (containing nil) (last nil)
- in-string in-comment (after-quote nil)
- (min-depth 0) com-style com-str-start (intermediate nil)
+ (let ((depth 0) (containing nil)
+ in-string in-comment
+ (min-depth 0) com-style com-str-start
(char-1 (nth 3 elt)) ; first char of poss. 2-char construct
(pos (car elt))
(type (cadr elt)))
@@ -2728,14 +2740,13 @@ comment at the start of cc-engine.el for more info."
(1- pos)
pos))
(if (memq 'pps-extended-state c-emacs-features)
- (list depth containing last
+ (list depth containing nil
in-string in-comment nil
min-depth com-style com-str-start
- intermediate nil)
- (list depth containing last
+ nil nil)
+ (list depth containing nil
in-string in-comment nil
- min-depth com-style com-str-start
- intermediate)))
+ min-depth com-style com-str-start nil)))
;; Not in a string or comment.
(if (memq 'pps-extended-state c-emacs-features)
@@ -2772,7 +2783,7 @@ comment at the start of cc-engine.el for more info."
((nth 3 state) ; A string
(list (point) (nth 3 state) (nth 8 state)))
((and (nth 4 state) ; A comment
- (not (eq (nth 7 state) 'syntax-table))) ; but not a psuedo comment.
+ (not (eq (nth 7 state) 'syntax-table))) ; but not a pseudo comment.
(list (point)
(if (eq (nth 7 state) 1) 'c++ 'c)
(nth 8 state)))
@@ -2899,7 +2910,7 @@ comment at the start of cc-engine.el for more info."
(setq nc-list (cdr nc-list))))))
(defun c-semi-get-near-cache-entry (here)
- ;; Return the near cache entry at the highest postion before HERE, if any,
+ ;; Return the near cache entry at the highest position before HERE, if any,
;; or nil. The near cache entry is of the form (POSITION . STATE), where
;; STATE has the form of a result of `parse-partial-sexp'.
(let ((nc-pos-state
@@ -2988,9 +2999,7 @@ comment at the start of cc-engine.el for more info."
c-block-comment-awkward-chars)))
(and (nth 4 s) (nth 7 s) ; Line comment
(not (memq (char-before here) '(?\\ ?\n)))))))
- (c-with-extended-string-fences
- pos here
- (setq s (parse-partial-sexp pos here nil nil s))))
+ (setq s (parse-partial-sexp pos here nil nil s)))
(when (not (eq near-pos here))
(c-semi-put-near-cache-entry here s))
(cond
@@ -3031,7 +3040,7 @@ comment at the start of cc-engine.el for more info."
(defun c-full-trim-near-cache ()
;; Remove stale entries in `c-full-lit-near-cache', i.e. those whose END
;; entries, or positions, are above `c-full-near-cache-limit'.
- (let ((nc-list c-full-lit-near-cache) elt)
+ (let ((nc-list c-full-lit-near-cache))
(while nc-list
(let ((elt (car nc-list)))
(if (if (car (cddr elt))
@@ -3194,6 +3203,24 @@ comment at the start of cc-engine.el for more info."
c-semi-near-cache-limit (min c-semi-near-cache-limit pos)
c-full-near-cache-limit (min c-full-near-cache-limit pos)))
+(defun c-foreign-truncate-lit-pos-cache (beg _end)
+ "Truncate CC Mode's literal cache.
+
+This function should be added to the `before-change-functions'
+hook by major modes that use CC Mode's filling functionality
+without initializing CC Mode. Currently (2020-06) these are
+js-mode and mhtml-mode."
+ (c-truncate-lit-pos-cache beg))
+
+(defun c-foreign-init-lit-pos-cache ()
+ "Initialize CC Mode's literal cache.
+
+This function should be called from the mode functions of major
+modes which use CC Mode's filling functionality without
+initializing CC Mode. Currently (2020-06) these are js-mode and
+mhtml-mode."
+ (c-truncate-lit-pos-cache 1))
+
;; A system for finding noteworthy parens before the point.
@@ -3492,6 +3519,7 @@ comment at the start of cc-engine.el for more info."
(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).
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(caar ,cash)
@@ -3500,6 +3528,7 @@ comment at the start of cc-engine.el for more info."
(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.
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(cdar ,cash)
@@ -3508,6 +3537,7 @@ comment at the start of cc-engine.el for more info."
(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.
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(cdar ,cash)
@@ -3554,18 +3584,23 @@ comment at the start of cc-engine.el for more info."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defuns which analyze 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.
+ ;; Return a start position for building `c-state-cache' from scratch. This
+ ;; will be at the top level, 2 defuns back. Return nil if we don't find
+ ;; these defun starts a reasonable way 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) ; Pure elisp BOD.
- (if (eq (char-after) ?\{)
- (setq cnt (1- cnt)))))
- (point)))
+ (save-restriction
+ (when (> here (* 10 c-state-cache-too-far))
+ (narrow-to-region (- here (* 10 c-state-cache-too-far)) here))
+ ;; 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) ; Pure elisp BOD.
+ (if (eq (char-after) ?\{)
+ (setq cnt (1- cnt)))))
+ (and (not (bobp))
+ (point)))))
(defun c-state-balance-parens-backwards (here- here+ top)
;; Return the position of the opening paren/brace/bracket before HERE- which
@@ -3656,9 +3691,7 @@ comment at the start of cc-engine.el for more info."
how-far 0))
((<= good-pos here)
(setq strategy 'forward
- start-point (if changed-macro-start
- cache-pos
- (max good-pos cache-pos))
+ 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
@@ -3677,7 +3710,8 @@ comment at the start of cc-engine.el for more info."
;; (not (c-major-mode-is 'c++-mode))
(> how-far c-state-cache-too-far))
(setq BOD-pos (c-get-fallback-scan-pos here)) ; somewhat EXPENSIVE!!!
- (if (< (- here BOD-pos) how-far)
+ (if (and BOD-pos
+ (< (- here BOD-pos) how-far))
(setq strategy 'BOD
start-point BOD-pos)))
@@ -3765,12 +3799,14 @@ comment at the start of cc-engine.el for more info."
(point)))
(bra ; Position of "{".
;; Don't start scanning in the middle of a CPP construct unless
- ;; it contains HERE - these constructs, in Emacs, are "commented
- ;; out" with category properties.
- (if (eq (c-get-char-property macro-start-or-from 'category)
- 'c-cpp-delimiter)
- macro-start-or-from
- from))
+ ;; it contains HERE.
+ (if (and (not (eq macro-start-or-from from))
+ (< macro-start-or-from here) ; Might not be needed.
+ (progn (goto-char macro-start-or-from)
+ (c-end-of-macro)
+ (>= (point) here)))
+ from
+ macro-start-or-from))
ce) ; Position of "}"
(or upper-lim (setq upper-lim from))
@@ -4300,34 +4336,29 @@ comment at the start of cc-engine.el for more info."
(setq c-state-nonlit-pos-cache-limit (1- here)))
(c-truncate-lit-pos-cache 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 or just below here, or nil.
- dropped-cons) ; was the last removed element a brace pair?
- ;; The easy bit - knock over-the-top bits off `c-state-cache'.
- (while (and c-state-cache
- (>= (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-append-lower-brace-pair-to-state-cache too-high-pa here here-bol))
- (setq c-state-cache-good-pos (or (c-state-cache-after-top-paren)
- (c-state-get-min-scan-pos)))))
+ (cond
+ ;; `c-state-cache':
+ ;; Case 1: if `here' is in a literal containing point-min, everything
+ ;; becomes (or is already) nil.
+ ((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))
+
+ ;; Case 2: `here' is below `c-state-cache-good-pos', so we need to amend
+ ;; the entire `c-state-cache' data.
+ ((< here c-state-cache-good-pos)
+ (let* ((res (c-remove-stale-state-cache-backwards here))
+ (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 here))
+ (setq c-state-cache-good-pos
+ (if scan-forward-p
+ (c-append-to-state-cache good-pos here)
+ good-pos)))))
;; The brace-pair desert marker:
(when (car c-state-brace-pair-desert)
@@ -4461,6 +4492,7 @@ comment at the start of cc-engine.el for more info."
(defmacro c-state-maybe-marker (place marker)
;; If PLACE is non-nil, return a marker marking it, otherwise nil.
;; We (re)use MARKER.
+ (declare (debug (form symbolp)))
`(let ((-place- ,place))
(and -place-
(or ,marker (setq ,marker (make-marker)))
@@ -4785,7 +4817,7 @@ comment at the start of cc-engine.el for more info."
;; Handle the "operator +" syntax in C++.
(when (and c-overloadable-operators-regexp
- (= (c-backward-token-2 0) 0))
+ (= (c-backward-token-2 0 nil (c-determine-limit 500)) 0))
(cond ((and (looking-at c-overloadable-operators-regexp)
(or (not c-opt-op-identifier-prefix)
@@ -5054,7 +5086,8 @@ See `c-forward-token-2' for details."
(while (and
(> count 0)
(progn
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws
+ limit)
(backward-char)
(if (looking-at jump-syntax)
(goto-char (scan-sexps (1+ (point)) -1))
@@ -5391,8 +5424,12 @@ comment at the start of cc-engine.el for more info."
;; Optimize for, in particular, large blocks of comments from
;; `comment-region'.
(progn (when opt-ws
- (c-backward-syntactic-ws)
- (setq paren-level-pos (point)))
+ (let ((opt-pos (point)))
+ (c-backward-syntactic-ws limit)
+ (if (or (null limit)
+ (> (point) limit))
+ (setq paren-level-pos (point))
+ (goto-char opt-pos))))
t)
;; Move back to a candidate end point which isn't in a literal
;; or in a macro we didn't start in.
@@ -5412,7 +5449,11 @@ comment at the start of cc-engine.el for more info."
(setq macro-start (point))))
(goto-char macro-start))))
(when opt-ws
- (c-backward-syntactic-ws)))
+ (let ((opt-pos (point)))
+ (c-backward-syntactic-ws limit)
+ (if (and limit
+ (<= (point) limit))
+ (goto-char opt-pos)))))
(< (point) pos))
;; Check whether we're at the wrong level of nesting (when
@@ -5463,7 +5504,7 @@ comment at the start of cc-engine.el for more info."
(progn
;; Skip syntactic ws afterwards so that we don't stop at the
;; end of a comment if `skip-chars' is something like "^/".
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws limit)
(point)))))
;; We might want to extend this with more useful return values in
@@ -5751,12 +5792,23 @@ comment at the start of cc-engine.el for more info."
(t 'c))) ; Assuming the range is valid.
range))
+(defun c-determine-limit-no-macro (here org-start)
+ ;; If HERE is inside a macro, and ORG-START is not also in the same macro,
+ ;; return the beginning of the macro. Otherwise return HERE. Point is not
+ ;; preserved by this function.
+ (goto-char here)
+ (let ((here-BOM (and (c-beginning-of-macro) (point))))
+ (if (and here-BOM
+ (not (eq (progn (goto-char org-start)
+ (and (c-beginning-of-macro) (point)))
+ here-BOM)))
+ here-BOM
+ here)))
+
(defsubst c-determine-limit-get-base (start try-size)
;; Get a "safe place" approximately TRY-SIZE characters before START.
;; This defsubst doesn't preserve point.
(goto-char start)
- (c-backward-syntactic-ws)
- (setq start (point))
(let* ((pos (max (- start try-size) (point-min)))
(s (c-semi-pp-to-literal pos))
(cand (or (car (cddr s)) pos)))
@@ -5765,20 +5817,23 @@ comment at the start of cc-engine.el for more info."
(parse-partial-sexp pos start nil nil (car s) 'syntax-table)
(point))))
-(defun c-determine-limit (how-far-back &optional start try-size)
+(defun c-determine-limit (how-far-back &optional start try-size org-start)
;; Return a buffer position approximately HOW-FAR-BACK non-literal
;; characters from START (default point). The starting position, either
;; point or START may not be in a comment or string.
;;
;; The position found will not be before POINT-MIN and won't be in a
- ;; literal.
+ ;; literal. It will also not be inside a macro, unless START/point is also
+ ;; in the same macro.
;;
;; We start searching for the sought position TRY-SIZE (default
;; twice HOW-FAR-BACK) bytes back from START.
;;
;; This function must be fast. :-)
+
(save-excursion
(let* ((start (or start (point)))
+ (org-start (or org-start start))
(try-size (or try-size (* 2 how-far-back)))
(base (c-determine-limit-get-base start try-size))
(pos base)
@@ -5831,21 +5886,27 @@ comment at the start of cc-engine.el for more info."
(setq elt (car stack)
stack (cdr stack))
(setq count (+ count (cdr elt))))
-
- ;; Have we found enough yet?
(cond
((null elt) ; No non-literal characters found.
- (if (> base (point-min))
- (c-determine-limit how-far-back base (* 2 try-size))
- (point-min)))
+ (cond
+ ((> pos start) ; Nothing but literals
+ base)
+ ((> base (point-min))
+ (c-determine-limit how-far-back base (* 2 try-size) org-start))
+ (t base)))
((>= count how-far-back)
- (+ (car elt) (- count how-far-back)))
+ (c-determine-limit-no-macro
+ (+ (car elt) (- count how-far-back))
+ org-start))
((eq base (point-min))
(point-min))
((> base (- start try-size)) ; Can only happen if we hit point-min.
- (car elt))
+ (c-determine-limit-no-macro
+ (car elt)
+ org-start))
(t
- (c-determine-limit (- how-far-back count) base (* 2 try-size)))))))
+ (c-determine-limit (- how-far-back count) base (* 2 try-size)
+ org-start))))))
(defun c-determine-+ve-limit (how-far &optional start-pos)
;; Return a buffer position about HOW-FAR non-literal characters forward
@@ -5918,6 +5979,7 @@ comment at the start of cc-engine.el for more info."
; spots and the preceding token end.")
(defmacro c-debug-put-decl-spot-faces (match-pos decl-pos)
+ (declare (debug t))
(when (facep 'c-debug-decl-spot-face)
`(c-save-buffer-state ((match-pos ,match-pos) (decl-pos ,decl-pos))
(c-debug-add-face (max match-pos (point-min)) decl-pos
@@ -5925,6 +5987,7 @@ comment at the start of cc-engine.el for more info."
(c-debug-add-face decl-pos (min (1+ decl-pos) (point-max))
'c-debug-decl-spot-face))))
(defmacro c-debug-remove-decl-spot-faces (beg end)
+ (declare (debug t))
(when (facep 'c-debug-decl-spot-face)
`(c-save-buffer-state ()
(c-debug-remove-face ,beg ,end 'c-debug-decl-spot-face)
@@ -6237,8 +6300,14 @@ comment at the start of cc-engine.el for more info."
;; preceding syntactic ws to set `cfd-match-pos' and to catch
;; any decl spots in the syntactic ws.
(unless cfd-re-match
- (c-backward-syntactic-ws)
- (setq cfd-re-match (point))))
+ (let ((cfd-cbsw-lim
+ (max (- (point) 1000) (point-min))))
+ (c-backward-syntactic-ws cfd-cbsw-lim)
+ (setq cfd-re-match
+ (if (or (bobp) (> (point) cfd-cbsw-lim))
+ (point)
+ (point-min)))) ; Set BOB case if the token's too far back.
+ ))
;; Choose whichever match is closer to the start.
(if (< cfd-re-match cfd-prop-match)
@@ -6399,7 +6468,7 @@ comment at the start of cc-engine.el for more info."
(while (and (not (bobp))
(c-got-face-at (1- (point)) c-literal-faces))
(goto-char (previous-single-property-change
- (point) 'face nil (point-min))))
+ (point) 'face nil (point-min)))) ; No limit. FIXME, perhaps? 2020-12-07.
;; XEmacs doesn't fontify the quotes surrounding string
;; literals.
@@ -6471,12 +6540,15 @@ comment at the start of cc-engine.el for more info."
(c-invalidate-find-decl-cache cfd-start-pos)
(setq syntactic-pos (point))
- (unless (eq syntactic-pos c-find-decl-syntactic-pos)
+ (unless
+ (eq syntactic-pos c-find-decl-syntactic-pos)
;; Don't have to do this if the cache is relevant here,
;; typically if the same line is refontified again. If
;; we're just some syntactic whitespace further down we can
;; still use the cache to limit the skipping.
- (c-backward-syntactic-ws c-find-decl-syntactic-pos))
+ (c-backward-syntactic-ws
+ (max (or c-find-decl-syntactic-pos (point-min))
+ (- (point) 10000) (point-min))))
;; If we hit `c-find-decl-syntactic-pos' and
;; `c-find-decl-match-pos' is set then we install the cached
@@ -6602,7 +6674,8 @@ comment at the start of cc-engine.el for more info."
;; syntactic ws.
(when (and cfd-match-pos (< cfd-match-pos syntactic-pos))
(goto-char syntactic-pos)
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws
+ (min (+ (point) 2000) (point-max)))
(and cfd-continue-pos
(< cfd-continue-pos (point))
(setq cfd-token-pos (point))))
@@ -6643,7 +6716,8 @@ comment at the start of cc-engine.el for more info."
;; can't be nested, and that's already been done in
;; `c-find-decl-prefix-search'.
(when (> cfd-continue-pos cfd-token-pos)
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws
+ (min (+ (point) 2000) (point-max)))
(setq cfd-token-pos (point)))
;; Continue if the following token fails the
@@ -7165,7 +7239,7 @@ comment at the start of cc-engine.el for more info."
;; characters.) If the raw string is not terminated, E\) and E\" are set to
;; nil.
;;
- ;; Note: this function is dependant upon the correct syntax-table text
+ ;; Note: this function is dependent upon the correct syntax-table text
;; properties being set.
(let ((state (c-semi-pp-to-literal (point)))
open-quote-pos open-paren-pos close-paren-pos close-quote-pos id)
@@ -7620,8 +7694,7 @@ comment at the start of cc-engine.el for more info."
;; entire raw string (when properly terminated) or just the delimiter
;; (otherwise). In either of these cases, return t, otherwise return nil.
;;
- (let ((here (point))
- in-macro macro-end id Rquote found)
+ (let (in-macro macro-end)
(when
(and
(eq (char-before (1- (point))) ?R)
@@ -7715,6 +7788,7 @@ comment at the start of cc-engine.el for more info."
(defvar c-last-identifier-range nil)
(defmacro c-record-type-id (range)
+ (declare (debug t))
(if (eq (car-safe range) 'cons)
;; Always true.
`(setq c-record-type-identifiers
@@ -7725,6 +7799,7 @@ comment at the start of cc-engine.el for more info."
(cons range c-record-type-identifiers))))))
(defmacro c-record-ref-id (range)
+ (declare (debug t))
(if (eq (car-safe range) 'cons)
;; Always true.
`(setq c-record-ref-identifiers
@@ -7750,6 +7825,7 @@ comment at the start of cc-engine.el for more info."
;; if TYPE is 'type or as a reference if TYPE is 'ref.
;;
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(let (res)
(setq c-last-identifier-range nil)
(while (if (setq res ,(if (eq type 'type)
@@ -7774,6 +7850,7 @@ comment at the start of cc-engine.el for more info."
;; `c-forward-keyword-prefixed-id'.
;;
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(while (and (progn
,(when update-safe-pos
'(setq safe-pos (point)))
@@ -8255,7 +8332,7 @@ comment at the start of cc-engine.el for more info."
;; 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 - 'operator if it's an operator identifier;
;; o - t if it's some other kind of name.
;;
;; This function records identifier ranges on
@@ -8271,9 +8348,11 @@ comment at the start of cc-engine.el for more info."
;; typically called from `c-forward-type' in this case, and
;; the caller only wants the top level type that it finds to
;; be promoted.
- c-promote-possible-types)
+ c-promote-possible-types
+ (lim+ (c-determine-+ve-limit 500)))
(while
(and
+ (< (point) lim+)
(looking-at c-identifier-key)
(progn
@@ -8301,7 +8380,7 @@ comment at the start of cc-engine.el for more info."
;; Handle a C++ operator or template identifier.
(goto-char id-end)
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
(cond ((eq (char-before id-end) ?e)
;; Got "... ::template".
(let ((subres (c-forward-name)))
@@ -8323,23 +8402,28 @@ comment at the start of cc-engine.el for more info."
;; '*', '&' or a name followed by ":: *",
;; where each can be followed by a sequence
;; of `c-opt-type-modifier-key'.
- (while (cond ((looking-at "[*&]")
- (goto-char (match-end 0))
- t)
- ((looking-at c-identifier-start)
- (and (c-forward-name)
- (looking-at "::")
- (progn
- (goto-char (match-end 0))
- (c-forward-syntactic-ws)
- (eq (char-after) ?*))
- (progn
- (forward-char)
- t))))
+ (while
+ (and
+ (< (point) lim+)
+ (cond ((looking-at "[*&]")
+ (goto-char (match-end 0))
+ t)
+ ((looking-at c-identifier-start)
+ (and (c-forward-name)
+ (looking-at "::")
+ (progn
+ (goto-char (match-end 0))
+ (c-forward-syntactic-ws lim+)
+ (eq (char-after) ?*))
+ (progn
+ (forward-char)
+ t)))))
(while (progn
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
(setq pos (point))
- (looking-at c-opt-type-modifier-key))
+ (and
+ (<= (point) lim+)
+ (looking-at c-opt-type-modifier-key)))
(goto-char (match-end 1))))))
((looking-at c-overloadable-operators-regexp)
@@ -8347,7 +8431,7 @@ comment at the start of cc-engine.el for more info."
(setq c-last-identifier-range
(cons (point) (match-end 0)))
(goto-char (match-end 0))
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
(setq pos (point)
res 'operator)))
@@ -8361,7 +8445,7 @@ comment at the start of cc-engine.el for more info."
(setq c-last-identifier-range
(cons id-start id-end)))
(goto-char id-end)
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
(setq pos (point)
res t)))
@@ -8377,7 +8461,7 @@ comment at the start of cc-engine.el for more info."
;; cases with tricky syntactic whitespace that aren't
;; covered in `c-identifier-key'.
(goto-char (match-end 0))
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
t)
((and c-recognize-<>-arglists
@@ -8385,8 +8469,11 @@ comment at the start of cc-engine.el for more info."
;; Maybe an angle bracket arglist.
(when (let (c-last-identifier-range)
(c-forward-<>-arglist nil))
+ ;; <> arglists can legitimately be very long, so recalculate
+ ;; `lim+'.
+ (setq lim+ (c-determine-+ve-limit 500))
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
(unless (eq (char-after) ?\()
(setq c-last-identifier-range nil)
(c-add-type start (1+ pos)))
@@ -8401,7 +8488,7 @@ comment at the start of cc-engine.el for more info."
(when (and c-record-type-identifiers id-start)
(c-record-ref-id (cons id-start id-end)))
(forward-char 2)
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws lim+)
t)
(when (and c-record-type-identifiers id-start
@@ -8434,6 +8521,7 @@ comment at the start of cc-engine.el for more info."
;; o - 'found if it's a type that matches one in `c-found-types';
;; o - 'maybe if it's an identifier that might be a type;
;; o - 'decltype if it's a decltype(variable) declaration; - or
+ ;; o - 'no-id if "auto" precluded parsing a type identifier.
;; 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.
@@ -8458,9 +8546,12 @@ comment at the start of cc-engine.el for more info."
;; prefix of a type.
(when c-opt-type-modifier-prefix-key ; e.g. "const" "volatile", but NOT "typedef"
(while (looking-at c-opt-type-modifier-prefix-key)
+ (when (looking-at c-no-type-key)
+ (setq res 'no-id))
(goto-char (match-end 1))
(c-forward-syntactic-ws)
- (setq res 'prefix)))
+ (or (eq res 'no-id)
+ (setq res 'prefix))))
(cond
((looking-at c-typeof-key) ; e.g. C++'s "decltype".
@@ -8511,28 +8602,30 @@ comment at the start of cc-engine.el for more info."
(setq res t))
(unless res (goto-char start))) ; invalid syntax
- ((progn
- (setq pos nil)
- (if (looking-at c-identifier-start)
- (save-excursion
- (setq id-start (point)
- name-res (c-forward-name))
- (when name-res
- (setq id-end (point)
- id-range c-last-identifier-range))))
- (and (cond ((looking-at c-primitive-type-key)
- (setq res t))
- ((c-with-syntax-table c-identifier-syntax-table
- (looking-at c-known-type-key))
- (setq res 'known)))
- (or (not id-end)
- (>= (save-excursion
- (save-match-data
- (goto-char (match-end 1))
- (c-forward-syntactic-ws)
- (setq pos (point))))
- id-end)
- (setq res nil))))
+ ((and
+ (not (eq res 'no-id))
+ (progn
+ (setq pos nil)
+ (if (looking-at c-identifier-start)
+ (save-excursion
+ (setq id-start (point)
+ name-res (c-forward-name))
+ (when name-res
+ (setq id-end (point)
+ id-range c-last-identifier-range))))
+ (and (cond ((looking-at c-primitive-type-key)
+ (setq res t))
+ ((c-with-syntax-table c-identifier-syntax-table
+ (looking-at c-known-type-key))
+ (setq res 'known)))
+ (or (not id-end)
+ (>= (save-excursion
+ (save-match-data
+ (goto-char (match-end 1))
+ (c-forward-syntactic-ws)
+ (setq pos (point))))
+ id-end)
+ (setq res nil)))))
;; Looking at a primitive or known type identifier. We've
;; checked for a name first so that we don't go here if the
;; known type match only is a prefix of another name.
@@ -8607,7 +8700,7 @@ comment at the start of cc-engine.el for more info."
(goto-char start)
(setq res nil)))))
- (when res
+ (when (not (memq res '(nil no-id)))
;; Skip trailing type modifiers. If any are found we know it's
;; a type.
(when c-opt-type-modifier-key
@@ -8714,6 +8807,7 @@ comment at the start of cc-engine.el for more info."
(defmacro c-pull-open-brace (ps)
;; Pull the next open brace from PS (which has the form of paren-state),
;; skipping over any brace pairs. Returns NIL when PS is exhausted.
+ (declare (debug (symbolp)))
`(progn
(while (consp (car ,ps))
(setq ,ps (cdr ,ps)))
@@ -8820,7 +8914,7 @@ comment at the start of cc-engine.el for more info."
(or res (goto-char here))
res))
-(defmacro c-back-over-list-of-member-inits ()
+(defmacro c-back-over-list-of-member-inits (limit)
;; Go back over a list of elements, each looking like:
;; <symbol> (<expression>) ,
;; or <symbol> {<expression>} , (with possibly a <....> expressions
@@ -8829,21 +8923,22 @@ comment at the start of cc-engine.el for more info."
;; a comma. If either of <symbol> or bracketed <expression> is missing,
;; throw nil to 'level. If the terminating } or ) is unmatched, throw nil
;; to 'done. This is not a general purpose macro!
- '(while (eq (char-before) ?,)
+ (declare (debug t))
+ `(while (eq (char-before) ?,)
(backward-char)
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws ,limit)
(when (not (memq (char-before) '(?\) ?})))
(throw 'level nil))
(when (not (c-go-list-backward))
(throw 'done nil))
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws ,limit)
(while (eq (char-before) ?>)
(when (not (c-backward-<>-arglist nil))
(throw 'done nil))
- (c-backward-syntactic-ws))
+ (c-backward-syntactic-ws ,limit))
(when (not (c-back-over-compound-identifier))
(throw 'level nil))
- (c-backward-syntactic-ws)))
+ (c-backward-syntactic-ws ,limit)))
(defun c-back-over-member-initializers (&optional limit)
;; Test whether we are in a C++ member initializer list, and if so, go back
@@ -8862,14 +8957,14 @@ comment at the start of cc-engine.el for more info."
(catch 'done
(setq level-plausible
(catch 'level
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws limit)
(when (memq (char-before) '(?\) ?}))
(when (not (c-go-list-backward))
(throw 'done nil))
- (c-backward-syntactic-ws))
+ (c-backward-syntactic-ws limit))
(when (c-back-over-compound-identifier)
- (c-backward-syntactic-ws))
- (c-back-over-list-of-member-inits)
+ (c-backward-syntactic-ws limit))
+ (c-back-over-list-of-member-inits limit)
(and (eq (char-before) ?:)
(save-excursion
(c-backward-token-2)
@@ -8883,14 +8978,14 @@ comment at the start of cc-engine.el for more info."
(setq level-plausible
(catch 'level
(goto-char pos)
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws limit)
(when (not (c-back-over-compound-identifier))
(throw 'level nil))
- (c-backward-syntactic-ws)
- (c-back-over-list-of-member-inits)
+ (c-backward-syntactic-ws limit)
+ (c-back-over-list-of-member-inits limit)
(and (eq (char-before) ?:)
(save-excursion
- (c-backward-token-2)
+ (c-backward-token-2 nil nil limit)
(not (looking-at c-:$-multichar-token-regexp)))
(c-just-after-func-arglist-p)))))
@@ -8971,14 +9066,15 @@ point unchanged and return nil."
(c-forward-noise-clause))
((and (looking-at c-type-decl-prefix-key)
(if (and (c-major-mode-is 'c++-mode)
- (match-beginning 3))
+ (match-beginning 4)) ; Was 3 - 2021-01-01
;; 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
(setq id-start (point))
(c-forward-name)
- (if (looking-at "\\(::\\)")
+ (if (save-match-data
+ (looking-at "\\(::\\)"))
;; We only check for a trailing "::" and
;; let the "*" that should follow be
;; matched in the next round.
@@ -8988,13 +9084,15 @@ point unchanged and return nil."
(setq got-identifier t)
nil))
t))
- (if (looking-at c-type-decl-operator-prefix-key)
+ (if (save-match-data
+ (looking-at c-type-decl-operator-prefix-key))
(setq decorated t))
(if (eq (char-after) ?\()
(progn
(setq paren-depth (1+ paren-depth))
(forward-char))
- (goto-char (match-end 1)))
+ (goto-char (or (match-end 1)
+ (match-end 2))))
(c-forward-syntactic-ws)
t)))
@@ -9138,6 +9236,12 @@ This function might do hidden buffer changes."
(catch 'is-function
(while
(progn
+ (while
+ (cond
+ ((looking-at c-decl-hangon-key)
+ (c-forward-keyword-clause 1))
+ ((looking-at c-noise-macro-with-parens-name-re)
+ (c-forward-noise-clause))))
(if (eq (char-after) ?\))
(throw 'is-function t))
(setq cdd-got-type (c-forward-type))
@@ -9213,6 +9317,7 @@ This function might do hidden buffer changes."
;; sometimes consumes the identifier in the declaration as a type.
;; This is used to "backtrack" and make the last type be treated as
;; an identifier instead.
+ (declare (debug nil))
`(progn
,(unless short
;; These identifiers are bound only in the inner let.
@@ -9373,8 +9478,8 @@ This function might do hidden buffer changes."
maybe-typeless
;; Save the value of kwd-sym between loops of the "Check for a
;; type" loop. Needed to distinguish a C++11 "auto" from a pre
- ;; C++11 one.
- prev-kwd-sym
+ ;; C++11 one. (Commented out, 2020-11-01).
+ ;; prev-kwd-sym
;; If a specifier is found that also can be a type prefix,
;; these flags are set instead of those above. If we need to
;; back up an identifier, they are copied to the real flag
@@ -9454,12 +9559,11 @@ This function might do hidden buffer changes."
(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 (and (c-major-mode-is 'c++-mode) ; C++11 style "auto"?
- (eq prev-kwd-sym (c-keyword-sym "auto"))
- (looking-at "[=(]")) ; FIXME!!! proper regexp.
- (setq new-style-auto t)
- (setq found-type nil)
- (goto-char start)) ; position of foo in "auto foo"
+ (when (and (eq found-type 'no-id)
+ (save-excursion
+ (and (c-forward-name) ; over the identifier
+ (looking-at "[=(]")))) ; FIXME!!! proper regexp.
+ (setq new-style-auto t)) ; position of foo in "auto foo"
(when at-type
;; Got two identifiers with nothing but whitespace
@@ -9534,7 +9638,7 @@ This function might do hidden buffer changes."
;; specifier keyword and we know we're in a
;; declaration.
(setq at-decl-or-cast t)
- (setq prev-kwd-sym kwd-sym)
+ ;; (setq prev-kwd-sym kwd-sym)
(goto-char kwd-clause-end))))
@@ -9542,7 +9646,7 @@ This function might do hidden buffer changes."
;; over all specifiers and type identifiers. The reason
;; to do this for a known type prefix is to make things
;; like "unsigned INT16" work.
- (and found-type (not (eq found-type t))))))
+ (and found-type (not (memq found-type '(t no-id)))))))
(cond
((eq at-type t)
@@ -9562,6 +9666,10 @@ This function might do hidden buffer changes."
;; followed by another type.
(setq at-type t))
+ ((eq at-type 'no-id)
+ ;; For an auto type, we assume we definitely have a type construct.
+ (setq at-type t))
+
((not at-type)
;; Got no type but set things up to continue anyway to handle
;; the various cases when a declaration doesn't start with a
@@ -9662,14 +9770,15 @@ This function might do hidden buffer changes."
(setq after-paren-pos (point))))
(while (and (looking-at c-type-decl-prefix-key)
(if (and (c-major-mode-is 'c++-mode)
- (match-beginning 3))
- ;; If the third submatch matches in C++ then
+ (match-beginning 4))
+ ;; If the fourth submatch matches in C++ then
;; we're looking at an identifier that's a
;; prefix only if it specifies a member pointer.
(when (progn (setq pos (point))
(setq got-identifier (c-forward-name)))
(setq name-start pos)
- (if (looking-at "\\(::\\)")
+ (if (save-match-data
+ (looking-at "\\(::\\)"))
;; We only check for a trailing "::" and
;; let the "*" that should follow be
;; matched in the next round.
@@ -9690,7 +9799,8 @@ This function might do hidden buffer changes."
(when (save-match-data
(looking-at c-type-decl-operator-prefix-key))
(setq got-function-name-prefix t))
- (goto-char (match-end 1)))
+ (goto-char (or (match-end 1)
+ (match-end 2))))
(c-forward-syntactic-ws)))
(setq got-parens (> paren-depth 0))
@@ -9790,6 +9900,16 @@ This function might do hidden buffer changes."
(save-excursion
(goto-char after-paren-pos)
(c-forward-syntactic-ws)
+ (progn
+ (while
+ (cond
+ ((and
+ c-opt-cpp-prefix
+ (looking-at c-noise-macro-with-parens-name-re))
+ (c-forward-noise-clause))
+ ((looking-at c-decl-hangon-key)
+ (c-forward-keyword-clause 1))))
+ t)
(or (c-forward-type)
;; Recognize a top-level typeless
;; function declaration in C.
@@ -10821,11 +10941,11 @@ comment at the start of cc-engine.el for more info."
(low-lim (max (or lim (point-min)) (or macro-start (point-min))))
before-lparen after-rparen
(here (point))
- (pp-count-out 20) ; Max number of paren/brace constructs before
- ; we give up.
+ (pp-count-out 20) ; Max number of paren/brace constructs before
+ ; we give up
ids ; List of identifiers in the parenthesized list.
- id-start after-prec-token decl-or-cast decl-res
- c-last-identifier-range identifier-ok)
+ id-start after-prec-token decl-or-cast
+ c-last-identifier-range semi-position+1)
(narrow-to-region low-lim (or macro-end (point-max)))
;; Search backwards for the defun's argument list. We give up if we
@@ -10859,8 +10979,8 @@ comment at the start of cc-engine.el for more info."
(setq after-rparen (point)))
((eq (char-before) ?\])
(setq after-rparen nil))
- (t ; either } (hit previous defun) or = or no more
- ; parens/brackets.
+ (t ; either } (hit previous defun) or = or no more
+ ; parens/brackets.
(throw 'knr nil)))
(if after-rparen
@@ -10917,31 +11037,35 @@ comment at the start of cc-engine.el for more info."
(forward-char) ; over the )
(setq after-prec-token after-rparen)
(c-forward-syntactic-ws)
+ ;; Each time around the following checks one
+ ;; declaration (which may contain several identifiers).
(while (and
- (or (consp (setq decl-or-cast
- (c-forward-decl-or-cast-1
- after-prec-token
- nil ; Or 'arglist ???
- nil)))
- (progn
- (goto-char after-prec-token)
- (c-forward-syntactic-ws)
- (setq identifier-ok (eq (char-after) ?{))
- nil))
- (eq (char-after) ?\;)
- (setq after-prec-token (1+ (point)))
+ (consp (setq decl-or-cast
+ (c-forward-decl-or-cast-1
+ after-prec-token
+ nil ; Or 'arglist ???
+ nil)))
+ (memq (char-after) '(?\; ?\,))
(goto-char (car decl-or-cast))
- (setq decl-res (c-forward-declarator))
- (setq identifier-ok
- (member (buffer-substring-no-properties
- (car decl-res) (cadr decl-res))
- ids))
- (progn
- (goto-char after-prec-token)
- (prog1 (< (point) here)
- (c-forward-syntactic-ws))))
- (setq identifier-ok nil))
- identifier-ok))
+ (save-excursion
+ (setq semi-position+1
+ (c-syntactic-re-search-forward
+ ";" (+ (point) 1000) t)))
+ (c-do-declarators
+ semi-position+1 t nil nil
+ (lambda (id-start id-end _next _not-top
+ _func _init)
+ (if (not (member
+ (buffer-substring-no-properties
+ id-start id-end)
+ ids))
+ (throw 'knr nil))))
+
+ (progn (forward-char)
+ (<= (point) here))
+ (progn (c-forward-syntactic-ws)
+ t)))
+ t))
;; ...Yes. We've identified the function's argument list.
(throw 'knr
(progn (goto-char after-rparen)
@@ -11107,6 +11231,7 @@ comment at the start of cc-engine.el for more info."
(c-backward-syntactic-ws lim)
(not (or (memq (char-before) '(?\; ?} ?: nil))
(c-at-vsemi-p))))
+ (not (and lim (<= (point) lim)))
(save-excursion
(backward-char)
(not (looking-at "\\s(")))
@@ -11235,7 +11360,7 @@ comment at the start of cc-engine.el for more info."
(c-syntactic-re-search-forward ";" nil 'move t)))
nil)))
-(defun c-looking-at-decl-block (_containing-sexp goto-start &optional limit)
+(defun c-looking-at-decl-block (goto-start &optional limit)
;; Assuming the point is at an open brace, check if it starts a
;; block that contains another declaration level, i.e. that isn't a
;; statement block or a brace list, and if so return non-nil.
@@ -11340,7 +11465,9 @@ comment at the start of cc-engine.el for more info."
;; also might be part of a declarator expression. Currently
;; there's no such language.
(not (or (looking-at c-symbol-start)
- (looking-at c-type-decl-prefix-key))))))
+ (looking-at c-type-decl-prefix-key)
+ (and (eq (char-after) ?{)
+ (not (c-looking-at-statement-block))))))))
;; In Pike a list of modifiers may be followed by a brace
;; to make them apply to many identifiers. Note that the
@@ -11415,9 +11542,7 @@ comment at the start of cc-engine.el for more info."
; *c-looking-at-decl-block
; containing-sexp goto-start &optional
; limit)
- (when (and (c-looking-at-decl-block
- (c-pull-open-brace paren-state)
- nil)
+ (when (and (c-looking-at-decl-block nil)
(looking-at c-class-key))
(goto-char (match-end 1))
(c-forward-syntactic-ws)
@@ -11436,9 +11561,7 @@ comment at the start of cc-engine.el for more info."
(save-excursion
(goto-char open-paren-pos)
(when (and (eq (char-after) ?{)
- (c-looking-at-decl-block
- (c-safe-position open-paren-pos paren-state)
- nil))
+ (c-looking-at-decl-block nil))
(back-to-indentation)
(vector (point) open-paren-pos))))))
@@ -11451,7 +11574,7 @@ comment at the start of cc-engine.el for more info."
(while (and open-brace
(save-excursion
(goto-char open-brace)
- (not (c-looking-at-decl-block next-open-brace nil))))
+ (not (c-looking-at-decl-block nil))))
(setq open-brace next-open-brace
next-open-brace (c-pull-open-brace paren-state)))
open-brace))
@@ -11549,6 +11672,194 @@ comment at the start of cc-engine.el for more info."
(or (looking-at c-brace-list-key)
(progn (goto-char here) nil))))
+(defun c-laomib-loop (lim)
+ ;; The "expensive" loop from `c-looking-at-or-maybe-in-bracelist'. Move
+ ;; backwards over comma separated sexps as far as possible, but no further
+ ;; than LIM, which may be nil, meaning no limit. Return the final value of
+ ;; `braceassignp', which is t if we encountered "= {", usually nil
+ ;; otherwise.
+ (let ((braceassignp 'dontknow)
+ (class-key
+ ;; Pike can have class definitions anywhere, so we must
+ ;; check for the class key here.
+ (and (c-major-mode-is 'pike-mode)
+ c-decl-block-key)))
+ (while (eq braceassignp 'dontknow)
+ (cond ((eq (char-after) ?\;)
+ (setq braceassignp nil))
+ ((and class-key
+ (looking-at class-key))
+ (setq braceassignp nil))
+ ((and c-has-compound-literals
+ (looking-at c-return-key))
+ (setq braceassignp t)
+ nil)
+ ((eq (char-after) ?=)
+ ;; We've seen a =, but must check earlier tokens so
+ ;; that it isn't something that should be ignored.
+ (setq braceassignp 'maybe)
+ (while (and (eq braceassignp 'maybe)
+ (zerop (c-backward-token-2 1 t lim)))
+ (setq braceassignp
+ (cond
+ ;; Check for operator =
+ ((and c-opt-op-identifier-prefix
+ (looking-at c-opt-op-identifier-prefix))
+ nil)
+ ;; Check for `<opchar>= in Pike.
+ ((and (c-major-mode-is 'pike-mode)
+ (or (eq (char-after) ?`)
+ ;; Special case for Pikes
+ ;; `[]=, since '[' is not in
+ ;; the punctuation class.
+ (and (eq (char-after) ?\[)
+ (eq (char-before) ?`))))
+ nil)
+ ((looking-at "\\s.") 'maybe)
+ ;; make sure we're not in a C++ template
+ ;; argument assignment
+ ((and
+ (c-major-mode-is 'c++-mode)
+ (save-excursion
+ (let ((here (point))
+ (pos< (progn
+ (skip-chars-backward "^<>")
+ (point))))
+ (and (eq (char-before) ?<)
+ (not (c-crosses-statement-barrier-p
+ pos< here))
+ (not (c-in-literal))
+ ))))
+ nil)
+ (t t)))))
+ ((and
+ (c-major-mode-is 'c++-mode)
+ (eq (char-after) ?\[)
+ ;; Be careful of "operator []"
+ (not (save-excursion
+ (c-backward-token-2 1 nil lim)
+ (looking-at c-opt-op-identifier-prefix))))
+ (setq braceassignp t)
+ nil))
+ (when (eq braceassignp 'dontknow)
+ (cond ((and
+ (not (eq (char-after) ?,))
+ (save-excursion
+ (c-backward-syntactic-ws)
+ (eq (char-before) ?})))
+ (setq braceassignp nil))
+ ((/= (c-backward-token-2 1 t lim) 0)
+ (if (save-excursion
+ (and c-has-compound-literals
+ (eq (c-backward-token-2 1 nil lim) 0)
+ (eq (char-after) ?\()))
+ (setq braceassignp t)
+ (setq braceassignp nil))))))
+ braceassignp))
+
+;; The following variable is a cache of up to four entries, each entry of
+;; which is a list representing a call to c-laomib-loop. It contains the
+;; following elements:
+;; 0: `lim' argument - used as an alist key, never nil.
+;; 1: Position in buffer where the scan started.
+;; 2: Position in buffer where the scan ended.
+;; 3: Result of the call to `c-laomib-loop'.
+(defvar c-laomib-cache nil)
+(make-variable-buffer-local 'c-laomib-cache)
+
+(defun c-laomib-get-cache (containing-sexp)
+ ;; Get an element from `c-laomib-cache' matching CONTAINING-SEXP.
+ ;; Return that element or nil if one wasn't found.
+ (let ((elt (assq containing-sexp c-laomib-cache)))
+ (when elt
+ ;; Move the fetched `elt' to the front of the cache.
+ (setq c-laomib-cache (delq elt c-laomib-cache))
+ (push elt c-laomib-cache)
+ elt)))
+
+(defun c-laomib-put-cache (lim start end result)
+ ;; Insert a new element into `c-laomib-cache', removing another element to
+ ;; make room, if necessary. The four parameters LIM, START, END, RESULT are
+ ;; the components of the new element (see comment for `c-laomib-cache').
+ ;; The return value is of no significance.
+ (when lim
+ (let ((old-elt (assq lim c-laomib-cache))
+ ;; (elt (cons containing-sexp (cons start nil)))
+ (new-elt (list lim start end result))
+ big-ptr
+ (cur-ptr c-laomib-cache)
+ togo (size 0) cur-size
+ )
+ (if old-elt (setq c-laomib-cache (delq old-elt c-laomib-cache)))
+
+ (while (>= (length c-laomib-cache) 4)
+ ;; We delete the least recently used elt which doesn't enclose START,
+ ;; or..
+ (dolist (elt c-laomib-cache)
+ (if (or (<= start (cadr elt))
+ (> start (car (cddr elt))))
+ (setq togo elt)))
+
+ ;; ... delete the least recently used elt which isn't the biggest.
+ (when (not togo)
+ (while (cdr cur-ptr)
+ (setq cur-size (- (nth 2 (cadr cur-ptr)) (car (cadr cur-ptr))))
+ (when (> cur-size size)
+ (setq size cur-size
+ big-ptr cur-ptr))
+ (setq cur-ptr (cdr cur-ptr)))
+ (setq togo (if (cddr big-ptr)
+ (car (last big-ptr))
+ (car big-ptr))))
+
+ (setq c-laomib-cache (delq togo c-laomib-cache)))
+
+ (push new-elt c-laomib-cache))))
+
+(defun c-laomib-fix-elt (lwm elt paren-state)
+ ;; Correct a c-laomib-cache entry ELT with respect to buffer changes, either
+ ;; doing nothing, signalling it is to be deleted, or replacing its start
+ ;; point with one lower in the buffer than LWM. PAREN-STATE is the paren
+ ;; state at LWM. Return the corrected entry, or nil (if it needs deleting).
+ ;; Note that corrections are made by `setcar'ing the original structure,
+ ;; which thus remains intact.
+ (cond
+ ((or (not lwm) (> lwm (cadr elt)))
+ elt)
+ ((<= lwm (nth 2 elt))
+ nil)
+ (t
+ ;; Search for the last brace in `paren-state' before (car `lim'). This
+ ;; brace will become our new 2nd element of `elt'.
+ (while
+ ;; Search one brace level per iteration.
+ (and paren-state
+ (progn
+ ;; (setq cur-brace (c-laomib-next-BRACE paren-state))
+ (while
+ ;; Go past non-brace levels, one per iteration.
+ (and paren-state
+ (not (eq (char-after
+ (c-state-cache-top-lparen paren-state))
+ ?{)))
+ (setq paren-state (cdr paren-state)))
+ (cadr paren-state))
+ (> (c-state-cache-top-lparen (cdr paren-state)) (car elt)))
+ (setq paren-state (cdr paren-state)))
+ (when (cadr paren-state)
+ (setcar (cdr elt) (c-state-cache-top-lparen paren-state))
+ elt))))
+
+(defun c-laomib-invalidate-cache (beg _end)
+ ;; Called from late in c-before-change. Amend `c-laomib-cache' to remove
+ ;; details pertaining to the buffer after position BEG.
+ (save-excursion
+ (goto-char beg)
+ (let ((paren-state (c-parse-state)))
+ (dolist (elt c-laomib-cache)
+ (when (not (c-laomib-fix-elt beg elt paren-state))
+ (setq c-laomib-cache (delq elt c-laomib-cache)))))))
+
(defun c-looking-at-or-maybe-in-bracelist (&optional containing-sexp lim)
;; Point is at an open brace. If this starts a brace list, return a list
;; whose car is the buffer position of the start of the construct which
@@ -11563,20 +11874,18 @@ comment at the start of cc-engine.el for more info."
;; POINT, or nil if there is no such position, or we do not know it. LIM is
;; a backward search limit.
;;
- ;; The determination of whether the brace starts a brace list is solely by
- ;; the context of the brace, not by its contents.
+ ;; The determination of whether the brace starts a brace list is mainly by
+ ;; the context of the brace, not by its contents. In exceptional
+ ;; circumstances (e.g. "struct A {" in C++ Mode), the contents are examined,
+ ;; too.
;;
;; Here, "brace list" does not include the body of an enum.
(save-excursion
(let ((start (point))
- (class-key
- ;; Pike can have class definitions anywhere, so we must
- ;; check for the class key here.
- (and (c-major-mode-is 'pike-mode)
- c-decl-block-key))
(braceassignp 'dontknow)
inexpr-brace-list bufpos macro-start res pos after-type-id-pos
- in-paren parens-before-brace)
+ pos2 in-paren parens-before-brace
+ paren-state paren-pos)
(setq res (c-backward-token-2 1 t lim))
;; Checks to do only on the first sexp before the brace.
@@ -11585,16 +11894,22 @@ comment at the start of cc-engine.el for more info."
(cond
((and (or (not (eq res 0))
(eq (char-after) ?,))
- (c-go-up-list-backward nil lim) ; FIXME!!! Check ; `lim' 2016-07-12.
- (eq (char-after) ?\())
+ (setq paren-state (c-parse-state))
+ (setq paren-pos (c-pull-open-brace paren-state))
+ (eq (char-after paren-pos) ?\())
+ (goto-char paren-pos)
(setq braceassignp 'c++-noassign
in-paren 'in-paren))
- ((looking-at c-pre-id-bracelist-key)
+ ((looking-at c-pre-brace-non-bracelist-key)
(setq braceassignp nil))
((looking-at c-return-key))
((and (looking-at c-symbol-start)
(not (looking-at c-keywords-regexp)))
- (setq after-type-id-pos (point)))
+ (if (save-excursion
+ (and (zerop (c-backward-token-2 1 t lim))
+ (looking-at c-pre-id-bracelist-key)))
+ (setq braceassignp 'c++-noassign)
+ (setq after-type-id-pos (point))))
((eq (char-after) ?\()
(setq parens-before-brace t)
nil)
@@ -11603,11 +11918,18 @@ comment at the start of cc-engine.el for more info."
(cond
((or (not (eq res 0))
(eq (char-after) ?,))
- (and (c-go-up-list-backward nil lim) ; FIXME!!! Check `lim' 2016-07-12.
- (eq (char-after) ?\()
- (setq in-paren 'in-paren)))
- ((looking-at c-pre-id-bracelist-key))
+ (and (setq paren-state (c-parse-state))
+ (setq paren-pos (c-pull-open-brace paren-state))
+ (eq (char-after paren-pos) ?\()
+ (setq in-paren 'in-paren)
+ (goto-char paren-pos)))
+ ((looking-at c-pre-brace-non-bracelist-key))
((looking-at c-return-key))
+ ((and (looking-at c-symbol-start)
+ (not (looking-at c-keywords-regexp))
+ (save-excursion
+ (and (zerop (c-backward-token-2 1 t lim))
+ (looking-at c-pre-id-bracelist-key)))))
(t (setq after-type-id-pos (point))
nil))))
(setq braceassignp 'c++-noassign))
@@ -11658,76 +11980,46 @@ comment at the start of cc-engine.el for more info."
(t
(goto-char pos)
- ;; Checks to do on all sexps before the brace, up to the
- ;; beginning of the statement.
- (while (eq braceassignp 'dontknow)
- (cond ((eq (char-after) ?\;)
- (setq braceassignp nil))
- ((and class-key
- (looking-at class-key))
- (setq braceassignp nil))
- ((and c-has-compound-literals
- (looking-at c-return-key))
- (setq braceassignp t)
- nil)
- ((eq (char-after) ?=)
- ;; We've seen a =, but must check earlier tokens so
- ;; that it isn't something that should be ignored.
- (setq braceassignp 'maybe)
- (while (and (eq braceassignp 'maybe)
- (zerop (c-backward-token-2 1 t lim)))
- (setq braceassignp
- (cond
- ;; Check for operator =
- ((and c-opt-op-identifier-prefix
- (looking-at c-opt-op-identifier-prefix))
- nil)
- ;; Check for `<opchar>= in Pike.
- ((and (c-major-mode-is 'pike-mode)
- (or (eq (char-after) ?`)
- ;; Special case for Pikes
- ;; `[]=, since '[' is not in
- ;; the punctuation class.
- (and (eq (char-after) ?\[)
- (eq (char-before) ?`))))
- nil)
- ((looking-at "\\s.") 'maybe)
- ;; make sure we're not in a C++ template
- ;; argument assignment
- ((and
- (c-major-mode-is 'c++-mode)
- (save-excursion
- (let ((here (point))
- (pos< (progn
- (skip-chars-backward "^<>")
- (point))))
- (and (eq (char-before) ?<)
- (not (c-crosses-statement-barrier-p
- pos< here))
- (not (c-in-literal))
- ))))
- nil)
- (t t))))))
- (when (eq braceassignp 'dontknow)
- (cond ((and
- (not (eq (char-after) ?,))
- (save-excursion
- (c-backward-syntactic-ws)
- (eq (char-before) ?})))
- (setq braceassignp nil))
- ((/= (c-backward-token-2 1 t lim) 0)
- (if (save-excursion
- (and c-has-compound-literals
- (eq (c-backward-token-2 1 nil lim) 0)
- (eq (char-after) ?\()))
- (setq braceassignp t)
- (setq braceassignp nil))))))
+ (when (eq braceassignp 'dontknow)
+ (let* ((cache-entry (and containing-sexp
+ (c-laomib-get-cache containing-sexp)))
+ (lim2 (or (cadr cache-entry) lim))
+ sub-bassign-p)
+ (if cache-entry
+ (cond
+ ((<= (point) (cadr cache-entry))
+ ;; We're inside the region we've already scanned over, so
+ ;; just go to that scan's end position.
+ (goto-char (nth 2 cache-entry))
+ (setq braceassignp (nth 3 cache-entry)))
+ ((> (point) (cadr cache-entry))
+ ;; We're beyond the previous scan region, so just scan as
+ ;; far as the end of that region.
+ (setq sub-bassign-p (c-laomib-loop lim2))
+ (if (<= (point) (cadr cache-entry))
+ (progn
+ (c-laomib-put-cache containing-sexp
+ start (nth 2 cache-entry)
+ (nth 3 cache-entry) ;; sub-bassign-p
+ )
+ (setq braceassignp (nth 3 cache-entry))
+ (goto-char (nth 2 cache-entry)))
+ (setq braceassignp sub-bassign-p)))
+ (t))
+
+ (setq braceassignp (c-laomib-loop lim))
+ (when lim
+ (c-laomib-put-cache lim start (point) braceassignp)))))
(cond
(braceassignp
;; We've hit the beginning of the aggregate list.
- (c-beginning-of-statement-1 containing-sexp)
- (cons (point) (or in-paren inexpr-brace-list)))
+ (setq pos2 (point))
+ (cons
+ (if (eq (c-beginning-of-statement-1 containing-sexp) 'same)
+ (point)
+ pos2)
+ (or in-paren inexpr-brace-list)))
((and after-type-id-pos
(save-excursion
(when (eq (char-after) ?\;)
@@ -11739,34 +12031,36 @@ comment at the start of cc-engine.el for more info."
(c-get-char-property (point) 'syntax-table))
(c-go-list-forward nil after-type-id-pos)
(c-forward-syntactic-ws)))
- (and
- (or (not (looking-at c-class-key))
- (save-excursion
- (goto-char (match-end 1))
- (c-forward-syntactic-ws)
- (not (eq (point) after-type-id-pos))))
- (progn
- (setq res
- (c-forward-decl-or-cast-1
- (save-excursion (c-backward-syntactic-ws) (point))
- nil nil))
- (and (consp res)
- (cond
- ((eq (car res) after-type-id-pos))
- ((> (car res) after-type-id-pos) nil)
- (t
- (catch 'find-decl
- (save-excursion
- (goto-char (car res))
- (c-do-declarators
- (point-max) t nil nil
- (lambda (id-start id-end tok not-top func init)
- (cond
- ((> id-start after-type-id-pos)
- (throw 'find-decl nil))
- ((eq id-start after-type-id-pos)
- (throw 'find-decl t)))))
- nil)))))))))
+ (if (and (not (eq (point) after-type-id-pos))
+ (or (not (looking-at c-class-key))
+ (save-excursion
+ (goto-char (match-end 1))
+ (c-forward-syntactic-ws)
+ (not (eq (point) after-type-id-pos)))))
+ (progn
+ (setq res
+ (c-forward-decl-or-cast-1 (c-point 'bosws)
+ nil nil))
+ (and (consp res)
+ (cond
+ ((eq (car res) after-type-id-pos))
+ ((> (car res) after-type-id-pos) nil)
+ (t
+ (catch 'find-decl
+ (save-excursion
+ (goto-char (car res))
+ (c-do-declarators
+ (point-max) t nil nil
+ (lambda (id-start _id-end _tok _not-top _func _init)
+ (cond
+ ((> id-start after-type-id-pos)
+ (throw 'find-decl nil))
+ ((eq id-start after-type-id-pos)
+ (throw 'find-decl t)))))
+ nil))))))
+ (save-excursion
+ (goto-char start)
+ (not (c-looking-at-statement-block))))))
(cons bufpos (or in-paren inexpr-brace-list)))
((or (eq (char-after) ?\;)
;; Brace lists can't contain a semicolon, so we're done.
@@ -11850,7 +12144,7 @@ comment at the start of cc-engine.el for more info."
(or accept-in-paren (not (eq (cdr bufpos) 'in-paren)))
(car bufpos))))))
-(defun c-looking-at-special-brace-list (&optional _lim)
+(defun c-looking-at-special-brace-list ()
;; If we're looking at the start of a pike-style list, i.e., `({ })',
;; `([ ])', `(< >)', etc., a cons of a cons of its starting and ending
;; positions and its entry in c-special-brace-lists is returned, nil
@@ -11913,47 +12207,34 @@ comment at the start of cc-engine.el for more info."
(cons (list beg) type)))))
(error nil))))
-(defun c-looking-at-bos (&optional _lim)
- ;; Return non-nil if between two statements or declarations, assuming
- ;; point is not inside a literal or comment.
- ;;
- ;; Obsolete - `c-at-statement-start-p' or `c-at-expression-start-p'
- ;; are recommended instead.
- ;;
- ;; This function might do hidden buffer changes.
- (c-at-statement-start-p))
-(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1")
-
(defun c-looking-at-statement-block ()
;; Point is at an opening brace. If this is a statement block (i.e. the
;; elements in the block are terminated by semicolons, or the block is
- ;; empty, or the block contains a keyword) return non-nil. Otherwise,
- ;; return nil.
+ ;; empty, or the block contains a characteristic keyword, or there is a
+ ;; nested statement block) return non-nil. Otherwise, return nil.
(let ((here (point)))
(prog1
(if (c-go-list-forward)
(let ((there (point)))
(backward-char)
- (c-syntactic-skip-backward "^;," here t)
+ (c-syntactic-skip-backward "^;" here t)
(cond
- ((eq (char-before) ?\;) t)
- ((eq (char-before) ?,) nil)
- (t ; We're at (1+ here).
- (cond
- ((progn (c-forward-syntactic-ws)
- (eq (point) (1- there))))
- ((c-syntactic-re-search-forward c-keywords-regexp there t))
- ((c-syntactic-re-search-forward "{" there t t)
- (backward-char)
- (c-looking-at-statement-block))
- (t nil)))))
+ ((eq (char-before) ?\;))
+ ((progn (c-forward-syntactic-ws)
+ (eq (point) (1- there))))
+ ((c-syntactic-re-search-forward
+ c-stmt-block-only-keywords-regexp there t))
+ ((c-syntactic-re-search-forward "{" there t t)
+ (backward-char)
+ (c-looking-at-statement-block))
+ (t nil)))
(forward-char)
(cond
- ((c-syntactic-re-search-forward "[;,]" nil t t)
- (eq (char-before) ?\;))
+ ((c-syntactic-re-search-forward ";" nil t t))
((progn (c-forward-syntactic-ws)
(eobp)))
- ((c-syntactic-re-search-forward c-keywords-regexp nil t t))
+ ((c-syntactic-re-search-forward c-stmt-block-only-keywords-regexp
+ nil t t))
((c-syntactic-re-search-forward "{" nil t t)
(backward-char)
(c-looking-at-statement-block))
@@ -12002,7 +12283,7 @@ comment at the start of cc-engine.el for more info."
(goto-char haskell-op-pos))
(while (and (eq res 'maybe)
- (progn (c-backward-syntactic-ws)
+ (progn (c-backward-syntactic-ws lim)
(> (point) closest-lim))
(not (bobp))
(progn (backward-char)
@@ -12094,7 +12375,7 @@ comment at the start of cc-engine.el for more info."
(c-backward-token-2 1 nil lim)
(and
(not (and (c-on-identifier)
- (looking-at c-symbol-chars)))
+ (looking-at c-symbol-char-key)))
(not (looking-at c-opt-op-identifier-prefix)))))))
(cons 'inlambda bracket-pos))
((and c-recognize-paren-inexpr-blocks
@@ -12491,8 +12772,7 @@ comment at the start of cc-engine.el for more info."
(defun c-add-class-syntax (symbol
containing-decl-open
containing-decl-start
- containing-decl-kwd
- _paren-state)
+ containing-decl-kwd)
;; The inclass and class-close syntactic symbols are added in
;; several places and some work is needed to fix everything.
;; Therefore it's collected here.
@@ -12541,7 +12821,7 @@ comment at the start of cc-engine.el for more info."
;; CASE B.1: class-open
((save-excursion
(and (eq (char-after) ?{)
- (c-looking-at-decl-block containing-sexp t)
+ (c-looking-at-decl-block t)
(setq beg-of-same-or-containing-stmt (point))))
(c-add-syntax 'class-open beg-of-same-or-containing-stmt))
@@ -12708,7 +12988,7 @@ comment at the start of cc-engine.el for more info."
literal char-before-ip before-ws-ip char-after-ip macro-start
in-macro-expr c-syntactic-context placeholder
step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos
- containing-<
+ tmp-pos2 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
@@ -12744,10 +13024,7 @@ comment at the start of cc-engine.el for more info."
(goto-char containing-sexp)
(eq (char-after) ?{))
(setq placeholder
- (c-looking-at-decl-block
- (c-most-enclosing-brace paren-state
- containing-sexp)
- t)))
+ (c-looking-at-decl-block t)))
(setq containing-decl-open containing-sexp
containing-decl-start (point)
containing-sexp nil)
@@ -12777,7 +13054,7 @@ comment at the start of cc-engine.el for more info."
(setq paren-state (cons containing-sexp paren-state)
containing-sexp nil)))
(setq lim (1+ containing-sexp))))
- (setq lim (point-min)))
+ (setq lim (c-determine-limit 1000)))
;; If we're in a parenthesis list then ',' delimits the
;; "statements" rather than being an operator (with the
@@ -12989,8 +13266,7 @@ comment at the start of cc-engine.el for more info."
(setq placeholder (c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state))
+ containing-decl-kwd))
;; Append access-label with the same anchor point as
;; inclass gets.
(c-append-syntax 'access-label placeholder))
@@ -13020,7 +13296,9 @@ comment at the start of cc-engine.el for more info."
;; 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)
+ (or
+ (c-safe-position containing-sexp paren-state)
+ (c-determine-limit 1000 containing-sexp))
containing-sexp
;; Have to turn on the heuristics after
;; the point even though it doesn't work
@@ -13062,7 +13340,7 @@ comment at the start of cc-engine.el for more info."
((save-excursion
(let (tmp)
(and (eq char-after-ip ?{)
- (setq tmp (c-looking-at-decl-block containing-sexp t))
+ (setq tmp (c-looking-at-decl-block t))
(progn
(setq placeholder (point))
(goto-char tmp)
@@ -13083,7 +13361,7 @@ comment at the start of cc-engine.el for more info."
(goto-char indent-point)
(skip-chars-forward " \t")
(and (eq (char-after) ?{)
- (c-looking-at-decl-block containing-sexp t)
+ (c-looking-at-decl-block t)
(setq placeholder (point))))
(c-add-syntax 'class-open placeholder))
@@ -13123,8 +13401,7 @@ comment at the start of cc-engine.el for more info."
(c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state))
+ containing-decl-kwd))
;; CASE 5A.5: ordinary defun open
(t
@@ -13146,7 +13423,8 @@ comment at the start of cc-engine.el for more info."
;; init lists can, in practice, be very large.
((save-excursion
(when (and (c-major-mode-is 'c++-mode)
- (setq placeholder (c-back-over-member-initializers)))
+ (setq placeholder (c-back-over-member-initializers
+ lim)))
(setq tmp-pos (point))))
(if (= (c-point 'bosws) (1+ tmp-pos))
(progn
@@ -13187,8 +13465,7 @@ comment at the start of cc-engine.el for more info."
(c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state)))
+ containing-decl-kwd)))
;; CASE 5B.4: Nether region after a C++ or Java func
;; decl, which could include a `throws' declaration.
@@ -13258,8 +13535,7 @@ comment at the start of cc-engine.el for more info."
(c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state)))
+ containing-decl-kwd)))
;; CASE 5C.3: in a Java implements/extends
(injava-inher
@@ -13445,8 +13721,7 @@ comment at the start of cc-engine.el for more info."
(c-add-class-syntax 'class-close
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state))
+ containing-decl-kwd))
;; CASE 5H: we could be looking at subsequent knr-argdecls
((and c-recognize-knr-p
@@ -13468,7 +13743,7 @@ comment at the start of cc-engine.el for more info."
;; CASE 5I: ObjC method definition.
((and c-opt-method-key
(looking-at c-opt-method-key))
- (c-beginning-of-statement-1 nil t)
+ (c-beginning-of-statement-1 (c-determine-limit 1000) 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
@@ -13541,7 +13816,16 @@ comment at the start of cc-engine.el for more info."
(if (>= (point) indent-point)
(throw 'not-in-directive t))
(setq placeholder (point)))
- nil)))))
+ nil))
+ (and macro-start
+ (not (c-beginning-of-statement-1 lim nil nil nil t))
+ (setq placeholder
+ (let ((ps-top (car paren-state)))
+ (if (consp ps-top)
+ (progn
+ (goto-char (cdr ps-top))
+ (c-forward-syntactic-ws indent-point))
+ (point-min))))))))
;; 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
@@ -13567,8 +13851,7 @@ comment at the start of cc-engine.el for more info."
(c-add-class-syntax 'inclass
containing-decl-open
containing-decl-start
- containing-decl-kwd
- paren-state)))
+ containing-decl-kwd)))
(when (and c-syntactic-indentation-in-macros
macro-start
(/= macro-start (c-point 'boi indent-point)))
@@ -13591,31 +13874,47 @@ comment at the start of cc-engine.el for more info."
(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-beginning-of-statement-1
+ (or
+ (c-safe-position (point) paren-state)
+ (c-determine-limit 1000)))
(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)
+ ((and
+ macro-start
+ (save-excursion
+ (prog1
+ (not (eq (c-beginning-of-statement-1
+ (or containing-sexp (c-determine-limit 1000))
+ nil nil nil t)
+ nil)))
+ (setq placeholder (point))))
+ (goto-char placeholder)
(c-add-stmt-syntax 'statement nil t containing-sexp paren-state))
- ;;CASE 5N: We are at a topmost continuation line and the only
+ ;;CASE 5S: We are at a topmost continuation line and the only
;;preceding items are annotations.
((and (c-major-mode-is 'java-mode)
(setq placeholder (point))
- (c-beginning-of-statement-1)
+ (c-beginning-of-statement-1 lim)
(progn
- (while (and (c-forward-annotation))
- (c-forward-syntactic-ws))
+ (while (and (setq tmp-pos (point))
+ (< (point) placeholder)
+ (c-forward-annotation))
+ (c-forward-syntactic-ws)
+ (setq tmp-pos2 tmp-pos))
t)
(prog1
(>= (point) placeholder)
(goto-char placeholder)))
- (c-add-syntax 'annotation-top-cont (c-point 'boi)))
+ (c-add-syntax 'annotation-top-cont (c-point 'boi tmp-pos2)))
;; CASE 5M: we are at a topmost continuation line
(t
- (c-beginning-of-statement-1 (c-safe-position (point) paren-state))
+ (c-beginning-of-statement-1
+ (or (c-safe-position (point) paren-state)
+ (c-determine-limit 1000)))
(when (c-major-mode-is 'objc-mode)
(setq placeholder (point))
(while (and (c-forward-objc-directive)
@@ -13671,8 +13970,9 @@ comment at the start of cc-engine.el for more info."
(setq tmpsymbol '(block-open . inexpr-statement)
placeholder
(cdr-safe (c-looking-at-inexpr-block
- (c-safe-position containing-sexp
- paren-state)
+ (or
+ (c-safe-position containing-sexp paren-state)
+ (c-determine-limit 1000 containing-sexp))
containing-sexp)))
;; placeholder is nil if it's a block directly in
;; a function arglist. That makes us skip out of
@@ -13804,7 +14104,9 @@ comment at the start of cc-engine.el for more info."
(setq placeholder (c-guess-basic-syntax))))
(setq c-syntactic-context placeholder)
(c-beginning-of-statement-1
- (c-safe-position (1- containing-sexp) paren-state))
+ (or
+ (c-safe-position (1- containing-sexp) paren-state)
+ (c-determine-limit 1000 (1- containing-sexp))))
(c-forward-token-2 0)
(while (cond
((looking-at c-specifier-key)
@@ -13838,7 +14140,8 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'brace-list-close (point))
(setq lim (or (save-excursion
(and
- (c-back-over-member-initializers)
+ (c-back-over-member-initializers
+ (c-determine-limit 1000))
(point)))
(c-most-enclosing-brace state-cache (point))))
(c-beginning-of-statement-1 lim nil nil t)
@@ -13871,7 +14174,8 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'brace-list-intro (point))
(setq lim (or (save-excursion
(and
- (c-back-over-member-initializers)
+ (c-back-over-member-initializers
+ (c-determine-limit 1000))
(point)))
(c-most-enclosing-brace state-cache (point))))
(c-beginning-of-statement-1 lim nil nil t)
@@ -13884,7 +14188,7 @@ comment at the start of cc-engine.el for more info."
(save-excursion
(goto-char indent-point)
(c-forward-syntactic-ws (c-point 'eol))
- (c-looking-at-special-brace-list (point)))))
+ (c-looking-at-special-brace-list))))
(c-add-syntax 'brace-entry-open (point))
(c-add-stmt-syntax 'brace-list-entry nil t containing-sexp
paren-state (point))
@@ -13927,7 +14231,9 @@ comment at the start of cc-engine.el for more info."
;; 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)
+ (or
+ (c-safe-position containing-sexp paren-state)
+ (c-determine-limit 1000 containing-sexp))
nil))
(setq tmpsymbol (if (eq (car placeholder) 'inlambda)
'inline-close
@@ -13950,9 +14256,7 @@ comment at the start of cc-engine.el for more info."
(and lim
(progn
(goto-char lim)
- (c-looking-at-decl-block
- (c-most-enclosing-brace paren-state lim)
- nil))
+ (c-looking-at-decl-block nil))
(setq placeholder (point))))
(c-backward-to-decl-anchor lim)
(back-to-indentation)
@@ -14092,7 +14396,9 @@ comment at the start of cc-engine.el for more info."
;; 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)
+ (or
+ (c-safe-position containing-sexp paren-state)
+ (c-determine-limit 1000 containing-sexp))
nil))
(setq tmpsymbol (if (eq (car placeholder) 'inlambda)
'defun-block-intro
@@ -14120,9 +14426,7 @@ comment at the start of cc-engine.el for more info."
(and (progn
(goto-char placeholder)
(eq (char-after) ?{))
- (c-looking-at-decl-block (c-most-enclosing-brace
- paren-state (point))
- nil))))
+ (c-looking-at-decl-block nil))))
(c-backward-to-decl-anchor lim)
(back-to-indentation)
(c-add-syntax 'defun-block-intro (point)))
@@ -14417,18 +14721,6 @@ Cannot combine absolute offsets %S and %S in `add' method"
indent)))
-(def-edebug-spec c-bos-pop-state t)
-(def-edebug-spec c-bos-save-error-info t)
-(def-edebug-spec c-state-cache-top-lparen t)
-(def-edebug-spec c-state-cache-top-paren t)
-(def-edebug-spec c-state-cache-after-top-paren t)
-(def-edebug-spec c-state-maybe-marker (form symbolp))
-(def-edebug-spec c-record-type-id t)
-(def-edebug-spec c-record-ref-id t)
-(def-edebug-spec c-forward-keyword-prefixed-id t)
-(def-edebug-spec c-forward-id-comma-list t)
-(def-edebug-spec c-pull-open-brace (symbolp))
-
(cc-provide 'cc-engine)
;; Local Variables:
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index fd00d65e335..a7c87125cdd 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -1,4 +1,4 @@
-;;; cc-fonts.el --- font lock support for CC Mode
+;;; cc-fonts.el --- font lock support for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -76,9 +76,6 @@
(cc-require-when-compile 'cc-langs)
(cc-require 'cc-vars)
(cc-require 'cc-engine)
-(cc-require-when-compile 'cc-awk) ; Change from cc-require, 2003/6/18 to
-;; prevent cc-awk being loaded when it's not needed. There is now a (require
-;; 'cc-awk) in (defun awk-mode ..).
;; Avoid repeated loading through the eval-after-load directive in
;; cc-mode.el.
@@ -221,6 +218,7 @@
;; incorrectly.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (fboundp 'font-lock-set-face)
;; Note: This function has no docstring in XEmacs so it might be
;; considered internal.
@@ -231,6 +229,7 @@
;; This is the inverse of `c-put-font-lock-face'.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (fboundp 'font-lock-remove-face)
`(font-lock-remove-face ,from ,to)
`(remove-text-properties ,from ,to '(face nil))))
@@ -241,11 +240,13 @@
;; region should include them.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (featurep 'xemacs)
`(c-put-font-lock-face (1+ ,from) (1- ,to) 'font-lock-string-face)
`(c-put-font-lock-face ,from ,to 'font-lock-string-face)))
(defmacro c-fontify-types-and-refs (varlist &rest body)
+ (declare (indent 1) (debug let*))
;; Like `let', but additionally activates `c-record-type-identifiers'
;; and `c-record-ref-identifiers', and fontifies the recorded ranges
;; accordingly on exit.
@@ -256,7 +257,6 @@
,@varlist)
(prog1 (progn ,@body)
(c-fontify-recorded-types-and-refs))))
- (put 'c-fontify-types-and-refs 'lisp-indent-function 1)
(defun c-skip-comments-and-strings (limit)
;; If the point is within a region fontified as a comment or
@@ -485,20 +485,7 @@
;; In the next form, check that point hasn't been moved beyond
;; `limit' in any of the above stanzas.
,(c-make-font-lock-search-form (car normal) (cdr normal) t)
- nil))))
-
-; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '(progn
-(def-edebug-spec c-put-font-lock-face t)
-(def-edebug-spec c-remove-font-lock-face t)
-(def-edebug-spec c-put-font-lock-string-face t)
- (def-edebug-spec c-fontify-types-and-refs let*)
- (def-edebug-spec c-make-syntactic-matcher t)
- ;; If there are literal quoted or backquoted highlight specs in
- ;; the call to `c-make-font-lock-search-function' then let's
- ;; instrument the forms in them.
- (def-edebug-spec c-make-font-lock-search-function
- (form &rest &or ("quote" (&rest form)) ("`" (&rest form)) form)));))
+ nil)))))
(defun c-fontify-recorded-types-and-refs ()
;; Convert the ranges recorded on `c-record-type-identifiers' and
@@ -947,7 +934,7 @@ casts and declarations are fontified. Used on level 2 and higher."
;; closest token before the region.
(save-excursion
(let ((pos (point)))
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws (max (- (point) 500) (point-min)))
(c-clear-char-properties
(if (and (not (bobp))
(memq (c-get-char-property (1- (point)) 'c-type)
@@ -969,7 +956,7 @@ casts and declarations are fontified. Used on level 2 and higher."
;; The declared identifiers are font-locked correctly as types, if
;; that is what they are.
(let ((prop (save-excursion
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws (max (- (point) 500) (point-min)))
(unless (bobp)
(c-get-char-property (1- (point)) 'c-type)))))
(when (memq prop '(c-decl-id-start c-decl-type-start))
@@ -1008,82 +995,92 @@ casts and declarations are fontified. Used on level 2 and higher."
(boundp 'parse-sexp-lookup-properties)))
(c-parse-and-markup-<>-arglists t)
c-restricted-<>-arglists
- id-start id-end id-face pos kwd-sym)
+ id-start id-end id-face pos kwd-sym
+ old-pos)
(while (and (< (point) limit)
- (re-search-forward c-opt-<>-arglist-start limit t))
-
- (setq id-start (match-beginning 1)
- id-end (match-end 1)
- pos (point))
-
- (goto-char id-start)
- (unless (c-skip-comments-and-strings limit)
- (setq kwd-sym nil
- c-restricted-<>-arglists nil
- id-face (get-text-property id-start 'face))
-
- (if (cond
- ((eq id-face 'font-lock-type-face)
- ;; The identifier got the type face so it has already been
- ;; handled in `c-font-lock-declarations'.
- nil)
-
- ((eq id-face 'font-lock-keyword-face)
- (when (looking-at c-opt-<>-sexp-key)
- ;; There's a special keyword before the "<" that tells
- ;; that it's an angle bracket arglist.
- (setq kwd-sym (c-keyword-sym (match-string 1)))))
-
- (t
- ;; There's a normal identifier before the "<". If we're not in
- ;; a declaration context then we set `c-restricted-<>-arglists'
- ;; to avoid recognizing templates in function calls like "foo (a
- ;; < b, c > d)".
- (c-backward-syntactic-ws)
- (when (and (memq (char-before) '(?\( ?,))
- (not (eq (get-text-property (1- (point)) 'c-type)
- 'c-decl-arg-start)))
- (setq c-restricted-<>-arglists t))
- t))
+ (setq old-pos (point))
+ (c-syntactic-re-search-forward "<" limit t nil t))
+ (setq pos (point))
+ (save-excursion
+ (backward-char)
+ (c-backward-syntactic-ws old-pos)
+ (if (re-search-backward
+ (concat "\\(\\`\\|" c-nonsymbol-key "\\)\\(" c-symbol-key"\\)\\=")
+ old-pos t)
+ (setq id-start (match-beginning 2)
+ id-end (match-end 2))
+ (setq id-start nil id-end nil)))
+
+ (when id-start
+ (goto-char id-start)
+ (unless (c-skip-comments-and-strings limit)
+ (setq kwd-sym nil
+ c-restricted-<>-arglists nil
+ id-face (get-text-property id-start 'face))
+
+ (if (cond
+ ((eq id-face 'font-lock-type-face)
+ ;; The identifier got the type face so it has already been
+ ;; handled in `c-font-lock-declarations'.
+ nil)
- (progn
- (goto-char (1- pos))
- ;; Check for comment/string both at the identifier and
- ;; at the "<".
- (unless (c-skip-comments-and-strings limit)
-
- (c-fontify-types-and-refs ()
- (when (c-forward-<>-arglist (c-keyword-member
- kwd-sym 'c-<>-type-kwds))
- (when (and c-opt-identifier-concat-key
- (not (get-text-property id-start 'face)))
- (c-forward-syntactic-ws)
- (cond ((looking-at c-opt-identifier-concat-key)
- (c-put-font-lock-face id-start id-end
- c-reference-face-name))
- ((eq (char-after) ?\())
- (t (c-put-font-lock-face id-start id-end
- 'font-lock-type-face))))))
-
- (goto-char pos)))
- (goto-char pos))))))
+ ((eq id-face 'font-lock-keyword-face)
+ (when (looking-at c-opt-<>-sexp-key)
+ ;; There's a special keyword before the "<" that tells
+ ;; that it's an angle bracket arglist.
+ (setq kwd-sym (c-keyword-sym (match-string 2)))))
+
+ (t
+ ;; There's a normal identifier before the "<". If we're not in
+ ;; a declaration context then we set `c-restricted-<>-arglists'
+ ;; to avoid recognizing templates in function calls like "foo (a
+ ;; < b, c > d)".
+ (c-backward-syntactic-ws)
+ (when (and (memq (char-before) '(?\( ?,))
+ (not (eq (get-text-property (1- (point)) 'c-type)
+ 'c-decl-arg-start)))
+ (setq c-restricted-<>-arglists t))
+ t))
+
+ (progn
+ (goto-char (1- pos))
+ ;; Check for comment/string both at the identifier and
+ ;; at the "<".
+ (unless (c-skip-comments-and-strings limit)
+
+ (c-fontify-types-and-refs ()
+ (when (c-forward-<>-arglist (c-keyword-member
+ kwd-sym 'c-<>-type-kwds))
+ (when (and c-opt-identifier-concat-key
+ (not (get-text-property id-start 'face)))
+ (c-forward-syntactic-ws)
+ (cond ((looking-at c-opt-identifier-concat-key)
+ (c-put-font-lock-face id-start id-end
+ c-reference-face-name))
+ ((eq (char-after) ?\())
+ (t (c-put-font-lock-face id-start id-end
+ 'font-lock-type-face))))))
+
+ (goto-char pos)))
+ (goto-char pos)))))))
nil)
(defun c-font-lock-declarators (limit list types not-top
&optional template-class)
;; 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'.)
+ ;; fontify the identifier it declares. (If TYPES is t, 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. If NOT-TOP is
- ;; non-nil, we are not at the top-level ("top-level" includes being directly
- ;; inside a class or namespace, etc.).
+ ;; If TYPES is t, fontify all identifiers as types, if it is nil fontify as
+ ;; either variables or functions, otherwise TYPES is a face to use. If
+ ;; NOT-TOP is non-nil, we are not at the top-level ("top-level" includes
+ ;; being directly inside a class or namespace, etc.).
;;
;; TEMPLATE-CLASS is non-nil when the declaration is in template delimiters
;; and was introduced by, e.g. "typename" or "class", such that if there is
@@ -1100,9 +1097,10 @@ casts and declarations are fontified. Used on level 2 and higher."
()
(c-do-declarators
limit list not-top
- (if types 'c-decl-type-start 'c-decl-id-start)
+ (cond ((eq types t) 'c-decl-type-start)
+ ((null types) 'c-decl-id-start))
(lambda (id-start _id-end end-pos _not-top is-function init-char)
- (if types
+ (if (eq types t)
;; Register and fontify the identifier as a type.
(let ((c-promote-possible-types t))
(goto-char id-start)
@@ -1121,9 +1119,10 @@ casts and declarations are fontified. Used on level 2 and higher."
;; `c-forward-declarator'.
(c-put-font-lock-face (car c-last-identifier-range)
(cdr c-last-identifier-range)
- (if is-function
- 'font-lock-function-name-face
- 'font-lock-variable-name-face))))
+ (cond
+ ((not (memq types '(nil t))) types)
+ (is-function 'font-lock-function-name-face)
+ (t 'font-lock-variable-name-face)))))
(and template-class
(eq init-char ?=) ; C++ "<class X = Y>"?
(progn
@@ -1357,7 +1356,8 @@ casts and declarations are fontified. Used on level 2 and higher."
'c-decl-id-start)))))
(c-font-lock-declarators
(min limit (point-max)) decl-list
- (cadr decl-or-cast) (not toplev) template-class))
+ (not (null (cadr decl-or-cast)))
+ (not toplev) template-class))
;; A declaration has been successfully identified, so do all the
;; fontification of types and refs that've been recorded.
@@ -1492,7 +1492,8 @@ casts and declarations are fontified. Used on level 2 and higher."
;; Check we haven't missed a preceding "typedef".
(when (not (looking-at c-typedef-key))
- (c-backward-syntactic-ws)
+ (c-backward-syntactic-ws
+ (max (- (point) 1000) (point-min)))
(c-backward-token-2)
(or (looking-at c-typedef-key)
(goto-char start-pos)))
@@ -1532,8 +1533,10 @@ casts and declarations are fontified. Used on level 2 and higher."
(c-backward-token-2)
(and
(not (looking-at c-opt-<>-sexp-key))
- (progn (c-backward-syntactic-ws)
- (memq (char-before) '(?\( ?,)))
+ (progn
+ (c-backward-syntactic-ws
+ (max (- (point) 1000) (point-min)))
+ (memq (char-before) '(?\( ?,)))
(not (eq (c-get-char-property (1- (point))
'c-type)
'c-decl-arg-start))))))
@@ -1666,9 +1669,7 @@ casts and declarations are fontified. Used on level 2 and higher."
c-recognize-knr-p) ; Strictly speaking, bogus, but it
; speeds up lisp.h tremendously.
(save-excursion
- (when (not (c-back-over-member-initializers
- (max (- (point) 2000) (point-min)))) ; c-determine-limit
- ; is too slow, here.
+ (when (not (c-back-over-member-initializers decl-search-lim))
(unless (or (eobp)
(looking-at "\\s(\\|\\s)"))
(forward-char))
@@ -2004,6 +2005,9 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
,@(when (c-major-mode-is 'c++-mode)
'(c-font-lock-c++-lambda-captures))
+ ,@(when (c-lang-const c-using-key)
+ `(c-font-lock-c++-using))
+
;; The first two rules here mostly find occurrences that
;; `c-font-lock-declarations' has found already, but not
;; declarations containing blocks in the type (see note below).
@@ -2263,6 +2267,41 @@ need for `c-font-lock-extra-types'.")
;;; C++.
+(defun c-font-lock-c++-using (limit)
+ ;; Fontify any clauses starting with the keyword `using'.
+ ;;
+ ;; 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".
+ (let (pos)
+ (while (c-syntactic-re-search-forward c-using-key limit 'end)
+ (while ; Do one declarator of a comma separated list, each time around.
+ (progn
+ (c-forward-syntactic-ws)
+ (setq pos (point)) ; token after "using".
+ (when (and (c-on-identifier)
+ (c-forward-name))
+ (cond
+ ((eq (char-after) ?=) ; using foo = <type-id>;
+ (goto-char pos)
+ (c-font-lock-declarators limit nil t nil))
+ ((save-excursion
+ (and c-colon-type-list-re
+ (c-go-up-list-backward)
+ (eq (char-after) ?{)
+ (eq (car (c-beginning-of-decl-1
+ (c-determine-limit 1000)))
+ 'same)
+ (looking-at c-colon-type-list-re)))
+ ;; Inherited protected member: leave unfontified
+ )
+ (t (goto-char pos)
+ (c-font-lock-declarators limit nil c-label-face-name nil)))
+ (eq (char-after) ?,)))
+ (forward-char))) ; over the comma.
+ nil))
(defun c-font-lock-c++-new (limit)
;; FIXME!!! Put in a comment about the context of this function's
@@ -2661,6 +2700,7 @@ need for `pike-font-lock-extra-types'.")
(defmacro c-set-doc-comment-re-element (suffix)
;; Set the variable `c-doc-line-join-re' to a buffer local value suitable
;; for the current doc comment style, or kill the local value.
+ (declare (debug t))
(let ((var (intern (concat "c-doc" suffix))))
`(let* ((styles (c-get-doc-comment-style))
elts)
@@ -2687,6 +2727,7 @@ need for `pike-font-lock-extra-types'.")
(defmacro c-set-doc-comment-char-list (suffix)
;; Set the variable 'c-doc-<suffix>' to the list of *-<suffix>, which must
;; be characters, and * represents the doc comment style.
+ (declare (debug t))
(let ((var (intern (concat "c-doc" suffix))))
`(let* ((styles (c-get-doc-comment-style))
elts)
@@ -2732,7 +2773,7 @@ need for `pike-font-lock-extra-types'.")
;; is used as a flag in other code to skip comments.
;;
;; This function might do hidden buffer changes.
-
+ (declare (indent 2))
(let (comment-beg region-beg)
(if (memq (get-text-property (point) 'face)
'(font-lock-comment-face font-lock-comment-delimiter-face))
@@ -2815,7 +2856,6 @@ need for `pike-font-lock-extra-types'.")
(goto-char region-end)))))
nil)
-(put 'c-font-lock-doc-comments 'lisp-indent-function 2)
(defun c-find-invalid-doc-markup (regexp limit)
;; Used to fontify invalid markup in doc comments after the correct
@@ -3016,6 +3056,84 @@ need for `pike-font-lock-extra-types'.")
(c-font-lock-doc-comments "/[*/]!" limit
autodoc-font-lock-doc-comments)))))
+;; Doxygen
+
+(defconst doxygen-font-lock-doc-comments
+ ;; TODO: Handle @code, @verbatim, @dot, @f etc. better by not highlighting
+ ;; text inside of those commands. Something smarter than just regexes may be
+ ;; needed to do that efficiently.
+ `((,(concat
+ ;; Make sure that the special character has not been escaped. E.g. in
+ ;; `\@foo' only `\@' is a command (similarly for other characters like
+ ;; `\\foo', `\<foo' and `\&foo'). The downside now is that we don't
+ ;; match command started just after an escaped character, e.g. in
+ ;; `\@\foo' we should match `\@' as well as `\foo' but only the former
+ ;; is matched.
+ "\\(?:^\\|[^\\@]\\)\\("
+ ;; Doxygen commands start with backslash or an at sign. Note that for
+ ;; brevity in the comments only `\' will be mentioned.
+ "[\\@]\\(?:"
+ ;; Doxygen commands except those starting with `f'
+ "[a-eg-z][a-z]*"
+ ;; Doxygen command starting with `f':
+ "\\|f\\(?:"
+ "[][$}]" ; \f$ \f} \f[ \f]
+ "\\|{\\(?:[a-zA-Z]+\\*?}{?\\)?" ; \f{ \f{env} \f{env}{
+ "\\|[a-z]+" ; \foo
+ "\\)"
+ "\\|~[a-zA-Z]*" ; \~ \~language
+ "\\|[$@&~<=>#%\".|\\\\]" ; single-character escapes
+ "\\|::\\|---?" ; \:: \-- \---
+ "\\)"
+ ;; HTML tags and entities:
+ "\\|</?\\sw\\(?:\\sw\\|\\s \\|[=\n\r*.:]\\|\"[^\"]*\"\\|'[^']*'\\)*>"
+ "\\|&\\(?:\\sw+\\|#[0-9]+\\|#x[0-9a-fA-F]+\\);"
+ "\\)")
+ 1 ,c-doc-markup-face-name prepend nil)
+ ;; Commands inside of strings are not commands so override highlighting with
+ ;; string face. This also affects HTML attribute values if they are
+ ;; surrounded with double quotes which may or may not be considered a good
+ ;; thing.
+ ("\\(?:^\\|[^\\@]\\)\\(\"[^\"[:cntrl:]]+\"\\)"
+ 1 font-lock-string-face prepend nil)
+ ;; HTML comments inside of the Doxygen comments.
+ ("\\(?:^\\|[^\\@]\\)\\(<!--.*?-->\\)"
+ 1 font-lock-comment-face prepend nil)
+ ;; Autolinking. Doxygen auto-links anything that is a class name but we have
+ ;; no hope of matching those. We are, however, able to match functions and
+ ;; members using explicit scoped syntax. For functions, we can also find
+ ;; them by noticing argument-list. Note that Doxygen accepts `::' as well
+ ;; as `#' as scope operators.
+ (,(let* ((ref "[\\@]ref\\s-+")
+ (ref-opt (concat "\\(?:" ref "\\)?"))
+ (id "[a-zA-Z_][a-zA-Z_0-9]*")
+ (args "\\(?:()\\|([^()]*)\\)")
+ (scope "\\(?:#\\|::\\)"))
+ (concat
+ "\\(?:^\\|[^\\@/%:]\\)\\(?:"
+ ref-opt "\\(?1:" scope "?" "\\(?:" id scope "\\)+" "~?" id "\\)"
+ "\\|" ref-opt "\\(?1:" scope "~?" id "\\)"
+ "\\|" ref-opt "\\(?1:" scope "?" "~?" id "\\)" args
+ "\\|" ref "\\(?1:" "~?" id "\\)"
+ "\\|" ref-opt "\\(?1:~[A-Z][a-zA-Z0-9_]+\\)"
+ "\\)"))
+ 1 font-lock-function-name-face prepend nil)
+ ;; Match URLs and emails. This has two purposes. First of all, Doxygen
+ ;; autolinks URLs. Second of all, `@bar' in `foo@bar.baz' has been matched
+ ;; above as a command; try and overwrite it.
+ (,(let* ((host "[A-Za-z0-9]\\(?:[A-Za-z0-9-]\\{0,61\\}[A-Za-z0-9]\\)")
+ (fqdn (concat "\\(?:" host "\\.\\)+" host))
+ (comp "[!-(*--/-=?-~]+")
+ (path (concat "/\\(?:" comp "[.]+" "\\)*" comp)))
+ (concat "\\(?:mailto:\\)?[a-zA-0_.]+@" fqdn
+ "\\|https?://" fqdn "\\(?:" path "\\)?"))
+ 0 font-lock-keyword-face prepend nil)))
+
+(defconst doxygen-font-lock-keywords
+ `((,(lambda (limit)
+ (c-font-lock-doc-comments "/\\(?:/[/!]\\|\\*[\\*!]\\)"
+ limit doxygen-font-lock-doc-comments)))))
+
;; 2006-07-10: awk-font-lock-keywords has been moved back to cc-awk.el.
(cc-provide 'cc-fonts)
diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el
index 1b852ec4910..9c88c14a6c1 100644
--- a/lisp/progmodes/cc-guess.el
+++ b/lisp/progmodes/cc-guess.el
@@ -1,4 +1,4 @@
-;;; cc-guess.el --- guess indentation values by scanning existing code
+;;; cc-guess.el --- guess indentation values by scanning existing code -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2006, 2011-2021 Free Software
;; Foundation, Inc.
@@ -58,7 +58,7 @@
;;
;; If you want to reuse the guessed style in future emacs sessions,
;; you may want to put it to your .emacs. `c-guess-view' is for
-;; you. It emits emacs lisp code which defines the last guessed
+;; you. It emits Emacs Lisp code which defines the last guessed
;; style, in a temporary buffer. You can put the emitted code into
;; your .emacs. This command was suggested by Alan Mackenzie.
@@ -527,7 +527,7 @@ is called with one argument, the guessed style."
(cdr needs-markers)))))
(defun c-guess-view (&optional with-name)
- "Emit emacs lisp code which defines the last guessed style.
+ "Emit Emacs Lisp code which defines the last guessed style.
So you can put the code into .emacs if you prefer the
guessed code.
\"STYLE NAME HERE\" is used as the name for the style in the
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 86627d9502b..35efadfd8d8 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -1,4 +1,4 @@
-;;; cc-langs.el --- language specific settings for CC Mode -*- coding: utf-8 -*-
+;;; cc-langs.el --- language specific settings for CC Mode -*- lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -159,7 +159,9 @@ evaluated and bound to VAR when the result from the macro
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
-
+ (declare (indent defun)
+ (debug (&define name def-form
+ &optional &or ("quote" symbolp) stringp)))
(when (and (not doc)
(eq (car-safe val) 'c-lang-const)
(eq (nth 1 val) var)
@@ -191,6 +193,7 @@ Emacs variable like `comment-start'.
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
+ (declare (debug (&define name def-form)))
(let ((elem (assq var (cdr c-emacs-variable-inits))))
(if elem
(setcdr elem (list val)) ; Maybe remove "list", sometime. 2006-07-19
@@ -200,13 +203,6 @@ the evaluated constant value at compile time."
;; Return the symbol, like the other def* forms.
`',var)
-(put 'c-lang-defvar 'lisp-indent-function 'defun)
-; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '
-(def-edebug-spec c-lang-defvar
- (&define name def-form &optional &or ("quote" symbolp) stringp))
-(def-edebug-spec c-lang-setvar (&define name def-form))
-
;; Suppress "might not be defined at runtime" warning.
;; This file is only used when compiling other cc files.
(declare-function cl-delete-duplicates "cl-seq" (cl-seq &rest cl-keys))
@@ -337,7 +333,8 @@ the evaluated constant value at compile time."
This includes setting \\=' and \" as string delimiters, and setting up
the comment syntax to handle both line style \"//\" and block style
\"/*\" \"*/\" comments."
-
+ ;; Never native compile to allow cc-mode.el:467 hack.
+ (declare (speed -1))
(modify-syntax-entry ?_ "_" table)
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?+ "." table)
@@ -378,12 +375,14 @@ 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 ((or (c-major-mode-is 'objc-mode) (c-major-mode-is 'java-mode))
+ ,(cond ((c-major-mode-is 'objc-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
;; every keyword is a single symbol.
'(modify-syntax-entry ?@ "_" table))
+ ((c-major-mode-is 'java-mode)
+ '(modify-syntax-entry ?@ "'" table))
((c-major-mode-is 'pike-mode)
'(modify-syntax-entry ?@ "." table)))
table)))
@@ -457,13 +456,11 @@ so that all identifiers are recognized as words.")
c-before-change-check-raw-strings
c-before-change-check-<>-operators
c-depropertize-CPP
- c-invalidate-macro-cache
c-truncate-bs-cache
c-before-change-check-unbalanced-strings
c-parse-quotes-before-change)
(c objc) '(c-extend-region-for-CPP
c-depropertize-CPP
- c-invalidate-macro-cache
c-truncate-bs-cache
c-before-change-check-unbalanced-strings
c-parse-quotes-before-change)
@@ -549,7 +546,7 @@ parameters (point-min), (point-max) and <buffer size>.")
(c-lang-defconst c-before-context-fontification-functions
t 'c-context-expand-fl-region
- awk nil)
+ awk 'c-awk-context-expand-fl-region)
;; 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.
(c-lang-defvar c-before-context-fontification-functions
@@ -581,10 +578,10 @@ don't have EOL terminated statements. "
(c-lang-defvar c-at-vsemi-p-fn (c-lang-const c-at-vsemi-p-fn))
(c-lang-defconst c-vsemi-status-unknown-p-fn
- "Contains a function \"are we unsure whether there is a virtual semicolon on this line?\".
+ "A function \"are we unsure whether there is a virtual semicolon on this line?\".
The (admittedly kludgy) purpose of such a function is to prevent an infinite
recursion in c-beginning-of-statement-1 when point starts at a `while' token.
-The function MUST NOT UNDER ANY CIRCUMSTANCES call c-beginning-of-statement-1,
+The function MUST NOT UNDER ANY CIRCUMSTANCES call `c-beginning-of-statement-1',
even indirectly. This variable contains nil for languages which don't have
EOL terminated statements."
t nil
@@ -699,6 +696,7 @@ It's assumed to not contain any submatchers."
;; The same thing regarding Unicode identifiers applies here as to
;; `c-symbol-key'.
t (concat "[" (c-lang-const c-nonsymbol-chars) "]"))
+(c-lang-defvar c-nonsymbol-key (c-lang-const c-nonsymbol-key))
(c-lang-defconst c-identifier-ops
"The operators that make up fully qualified identifiers. nil in
@@ -1174,7 +1172,7 @@ since CC Mode treats every identifier as an expression."
;; Exception.
,@(when (c-major-mode-is 'c++-mode)
- '((prefix "throw")))
+ '((prefix "throw" "co_await" "co_yield")))
;; Sequence.
(left-assoc ","))
@@ -1769,7 +1767,7 @@ ender."
`comment-start-skip' is initialized from this."
;; Default: Allow the last char of the comment starter(s) to be
;; repeated, then allow any amount of horizontal whitespace.
- t (concat "\\("
+ t (concat "\\(?:"
(c-concat-separated
(mapcar (lambda (cs)
(when cs
@@ -2040,6 +2038,7 @@ the appropriate place for that."
(c-lang-defconst c-return-kwds
"Keywords which return a value to the calling function."
t '("return")
+ c++ '("return" "co_return")
idl nil)
(c-lang-defconst c-return-key
@@ -2120,7 +2119,9 @@ fontified with the keyword face and not the type face."
t nil
c '("const" "restrict" "volatile")
c++ '("const" "noexcept" "volatile")
- objc '("const" "volatile"))
+ objc '("const" "volatile")
+ t (append (c-lang-const c-no-type-kwds)
+ (c-lang-const c-type-modifier-prefix-kwds)))
(c-lang-defconst c-opt-type-modifier-prefix-key
;; Adorned regexp matching `c-type-modifier-prefix-kwds', or nil in
@@ -2337,6 +2338,26 @@ will be handled."
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-using-kwds
+ "Keywords which behave like `using' in C++"
+ t nil
+ c++ '("using"))
+
+(c-lang-defconst c-using-key
+ ;; Regexp matching C++'s `using'.
+ t (c-make-keywords-re t (c-lang-const c-using-kwds)))
+(c-lang-defvar c-using-key (c-lang-const c-using-key))
+
+(c-lang-defconst c-no-type-kwds
+ "Keywords which remove the need to specify a type in declarations"
+ t nil
+ c++ '("auto"))
+
+(c-lang-defconst c-no-type-key
+ ;; Regexp matching an entry from `c-no-type-kwds'
+ t (c-make-keywords-re t (c-lang-const c-no-type-kwds)))
+(c-lang-defvar c-no-type-key (c-lang-const c-no-type-key))
+
(c-lang-defconst c-typeless-decl-kwds
"Keywords introducing declarations where the (first) identifier
\(declarator) follows directly after the keyword, without any type.
@@ -2350,7 +2371,6 @@ will be handled."
;; {...}").
t (append (c-lang-const c-class-decl-kwds)
(c-lang-const c-brace-list-decl-kwds))
- c++ (append (c-lang-const c-typeless-decl-kwds) '("auto")) ; C++11.
;; Note: "manages" for CORBA CIDL clashes with its presence on
;; `c-type-list-kwds' for IDL.
idl (append (c-lang-const c-typeless-decl-kwds)
@@ -2385,9 +2405,11 @@ 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 nil
- (c c++) '("auto" "extern" "inline" "register" "static")
+ (c c++) '("extern" "inline" "register" "static")
+ c (append '("auto") (c-lang-const c-modifier-kwds))
c++ (append '("constexpr" "explicit" "friend" "mutable" "template"
- "thread_local" "using" "virtual")
+ "thread_local" "virtual")
+ ;; "using" is now handled specially (2020-09-14).
(c-lang-const c-modifier-kwds))
objc '("auto" "bycopy" "byref" "extern" "in" "inout" "oneway" "out" "static")
;; FIXME: Some of those below ought to be on `c-other-decl-kwds' instead.
@@ -2415,7 +2437,8 @@ 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 nil
- objc '("@class" "@end" "@defs")
+ objc '("@class" "@defs" "@end" "@property" "@dynamic" "@synthesize"
+ "@compatibility_alias")
java '("import" "package")
pike '("import" "inherit"))
@@ -2538,7 +2561,8 @@ one of `c-type-list-kwds', `c-ref-list-kwds',
"Access protection label keywords in classes."
t nil
c++ '("private" "protected" "public")
- objc '("@private" "@protected" "@public"))
+ objc '("@private" "@protected" "@package" "@public"
+ "@required" "@optional"))
(c-lang-defconst c-protection-key
;; A regexp match an element of `c-protection-kwds' cleanly.
@@ -2754,7 +2778,7 @@ identifiers that follows the type in a normal declaration."
"Statement keywords followed directly by a substatement."
t '("do" "else")
c++ '("do" "else" "try")
- objc '("do" "else" "@finally" "@try")
+ objc '("do" "else" "@finally" "@try" "@autoreleasepool")
java '("do" "else" "finally" "try")
idl nil)
@@ -2784,7 +2808,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'."
java '("for" "if" "switch" "while" "catch" "synchronized")
idl nil
pike '("for" "if" "switch" "while" "foreach")
- awk '("for" "if" "while"))
+ awk '("for" "if" "switch" "while"))
(c-lang-defconst c-block-stmt-2-key
;; Regexp matching the start of any statement followed by a paren sexp
@@ -2823,6 +2847,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'."
(c-lang-defconst c-simple-stmt-kwds
"Statement keywords followed by an expression or nothing."
t '("break" "continue" "goto" "return")
+ c++ '("break" "continue" "goto" "return" "co_return")
objc '("break" "continue" "goto" "return" "@throw")
;; Note: `goto' is not valid in Java, but the keyword is still reserved.
java '("break" "continue" "goto" "return" "throw")
@@ -2863,8 +2888,7 @@ nevertheless contains a list separated with `;' and not `,'."
(c-lang-defconst c-case-kwds
"The keyword(s) which introduce a \"case\" like construct.
This construct is \"<keyword> <expression> :\"."
- t '("case")
- awk nil)
+ t '("case"))
(c-lang-defconst c-case-kwds-regexp
;; Adorned regexp matching any "case"-like keyword.
@@ -2896,7 +2920,8 @@ This construct is \"<keyword> <expression> :\"."
c++ (append
'("nullptr")
(c-lang-const c-constant-kwds c))
- objc '("nil" "Nil" "YES" "NO" "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER")
+ objc '("nil" "Nil" "YES" "NO" "IBAction" "IBOutlet"
+ "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER")
idl '("TRUE" "FALSE")
java '("true" "false" "null") ; technically "literals", not keywords
pike '("UNDEFINED")) ;; Not a keyword, but practically works as one.
@@ -3031,7 +3056,14 @@ Note that Java specific rules are currently applied to tell this from
;; can start a declaration.)
"entity" "process" "service" "session" "storage"))
-
+(c-lang-defconst c-std-abbrev-keywords
+ "List of keywords which may need to cause electric indentation."
+ t '("else" "while")
+ c++ (append (c-lang-const c-std-abbrev-keywords) '("catch"))
+ java (append (c-lang-const c-std-abbrev-keywords) '("catch" "finally"))
+ idl nil)
+(c-lang-defvar c-std-abbrev-keywords (c-lang-const c-std-abbrev-keywords))
+
;;; Constants built from keywords.
;; Note: No `*-kwds' language constants may be defined below this point.
@@ -3064,6 +3096,36 @@ Note that Java specific rules are currently applied to tell this from
t (c-make-keywords-re t (c-lang-const c-keywords)))
(c-lang-defvar c-keywords-regexp (c-lang-const c-keywords-regexp))
+(c-lang-defconst c-stmt-block-only-keywords
+ "All keywords which unambiguously signify a statement block (as opposed to
+ a brace list) when occurring inside braces."
+ t (c--set-difference
+ (c-lang-const c-keywords)
+ (append (c-lang-const c-primary-expr-kwds)
+ (c-lang-const c-constant-kwds)
+ `(,@(when (c-major-mode-is 'c++-mode)
+ '("typeid" "dynamic_cast" "static_cast" "const_cast"
+ "reinterpret_cast" "alignof")))
+ (c-lang-const c-type-modifier-prefix-kwds)
+ (c-lang-const c-overloadable-operators)
+ (c-lang-const c-template-typename-kwds)
+ `(,@(when (c-major-mode-is 'c++-mode)
+ '("reflexpr")))
+ `(,@(when (c-major-mode-is '(c-mode c++-mode))
+ '("sizeof")))
+ (c-lang-const c-pre-lambda-tokens)
+ (c-lang-const c-block-decls-with-vars)
+ (c-lang-const c-primitive-type-kwds))
+ :test 'string-equal))
+
+(c-lang-defconst c-stmt-block-only-keywords-regexp
+ ;; A regexp matching a keyword in `c-stmt-block-only-keywords'. Such a
+ ;; match can start and end only at token boundaries.
+ t (concat "\\(^\\|\\=\\|[^" (c-lang-const c-symbol-chars) "]\\)"
+ (c-make-keywords-re t (c-lang-const c-stmt-block-only-keywords))))
+(c-lang-defvar c-stmt-block-only-keywords-regexp
+ (c-lang-const c-stmt-block-only-keywords-regexp))
+
(c-lang-defconst c-keyword-member-alist
;; An alist with all the keywords in the cars. The cdr for each
;; keyword is a list of the symbols for the `*-kwds' lists that
@@ -3399,35 +3461,47 @@ possible for good performance."
t (c-make-bare-char-alt (c-lang-const c-block-prefix-disallowed-chars) t))
(c-lang-defvar c-block-prefix-charset (c-lang-const c-block-prefix-charset))
+(c-lang-defconst c-type-decl-prefix-keywords-key
+ ;; Regexp matching any keyword operator that might precede the identifier in
+ ;; a declaration, e.g. "const" or nil. It doesn't test there is no "_"
+ ;; following the keyword.
+ t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds))
+ (concat
+ (regexp-opt (c--delete-duplicates
+ (append (c-lang-const c-type-modifier-kwds)
+ (c-lang-const c-modifier-kwds))
+ :test 'string-equal)
+ t)
+ "\\>")))
+
(c-lang-defconst c-type-decl-prefix-key
"Regexp matching any declarator operator that might precede the
identifier in a declaration, e.g. the \"*\" in \"char *argv\". This
regexp should match \"(\" if parentheses are valid in declarators.
-The end of the first submatch is taken as the end of the operator.
-Identifier syntax is in effect when this is matched (see
-`c-identifier-syntax-table')."
- t (if (c-lang-const c-type-modifier-kwds)
- (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>")
- ;; Default to a regexp that never matches.
- regexp-unmatchable)
+The operator found is either the first submatch (if it is not a
+keyword) or the second submatch (if it is)."
+ t (if (c-lang-const c-type-decl-prefix-keywords-key)
+ (concat "\\(\\`a\\`\\)\\|" ; 1 - will never match.
+ (c-lang-const c-type-decl-prefix-keywords-key) ; 2
+ "\\([^_]\\|$\\)") ; 3
+ "\\`a\\`") ;; Default to a regexp that never matches.
;; Check that there's no "=" afterwards to avoid matching tokens
;; like "*=".
- (c objc) (concat "\\("
+ (c objc) (concat "\\(" ; 1
"[*(]"
- "\\|"
- (c-lang-const c-type-decl-prefix-key)
- "\\)"
- "\\([^=]\\|$\\)")
- c++ (concat "\\("
+ "\\)\\|"
+ (c-lang-const c-type-decl-prefix-keywords-key) ; 2
+ "\\([^=_]\\|$\\)") ; 3
+ c++ (concat "\\(" ; 1
"&&"
"\\|"
"\\.\\.\\."
"\\|"
"[*(&~]"
+ "\\)\\|\\(" ; 2
+ (c-lang-const c-type-decl-prefix-keywords-key) ; 3
"\\|"
- (c-lang-const c-type-decl-prefix-key)
- "\\|"
- (concat "\\(" ; 3
+ (concat "\\(" ; 4
;; If this matches there's special treatment in
;; `c-font-lock-declarators' and
;; `c-font-lock-declarations' that check for a
@@ -3435,8 +3509,9 @@ Identifier syntax is in effect when this is matched (see
(c-lang-const c-identifier-start)
"\\)")
"\\)"
- "\\([^=]\\|$\\)")
+ "\\([^=_]\\|$\\)") ; 5
pike "\\(\\*\\)\\([^=]\\|$\\)")
+
(c-lang-defvar c-type-decl-prefix-key (c-lang-const c-type-decl-prefix-key)
'dont-doc)
@@ -3603,13 +3678,25 @@ list."
c t)
(c-lang-defvar c-recognize-knr-p (c-lang-const c-recognize-knr-p))
+(c-lang-defconst c-pre-id-bracelist-kwds
+ "Keywords which, preceding an identifier and brace, signify a bracelist.
+This is only used in c++-mode."
+ t nil
+ c++ '("new" "throw"))
+
(c-lang-defconst c-pre-id-bracelist-key
- "A regexp matching tokens which, preceding an identifier, signify a bracelist.
-"
- t regexp-unmatchable
- c++ "new\\([^[:alnum:]_$]\\|$\\)\\|&&?\\(\\S.\\|$\\)")
+ ;; A regexp matching keywords which, preceding an identifier and brace,
+ ;; signify a bracelist. Only used in c++-mode.
+ t (c-make-keywords-re t (c-lang-const c-pre-id-bracelist-kwds)))
(c-lang-defvar c-pre-id-bracelist-key (c-lang-const c-pre-id-bracelist-key))
+(c-lang-defconst c-pre-brace-non-bracelist-key
+ "A regexp matching tokens which, preceding a brace, make it a non-bracelist."
+ t regexp-unmatchable
+ c++ "&&?\\(\\S.\\|$\\)")
+(c-lang-defvar c-pre-brace-non-bracelist-key
+ (c-lang-const c-pre-brace-non-bracelist-key))
+
(c-lang-defconst c-recognize-typeless-decls
"Non-nil means function declarations without return type should be
recognized. That can introduce an ambiguity with parenthesized macro
@@ -4004,6 +4091,7 @@ accomplish that conveniently."
This macro is expanded at compile time to a form tailored for the mode
in question, so MODE must be a constant. Therefore MODE is not
evaluated and should not be quoted."
+ (declare (debug nil))
`(funcall ,(c-make-init-lang-vars-fun mode)))
diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el
index 0ff6efb7d37..a099ec1de95 100644
--- a/lisp/progmodes/cc-menus.el
+++ b/lisp/progmodes/cc-menus.el
@@ -1,4 +1,4 @@
-;;; cc-menus.el --- imenu support for CC Mode
+;;; cc-menus.el --- imenu support for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 601e1811920..51085495bd8 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -1,4 +1,4 @@
-;;; cc-mode.el --- major mode for editing C and similar languages
+;;; cc-mode.el --- major mode for editing C and similar languages -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -113,6 +113,7 @@
;; Silence the compiler.
(cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs
(cc-bytecomp-defun run-mode-hooks) ; Emacs 21.1
+(cc-bytecomp-defvar awk-mode-syntax-table)
;; We set this variable during mode init, yet we don't require
;; font-lock.
@@ -278,6 +279,29 @@ control). See \"cc-mode.el\" for more info."
(setq defs (cdr defs)))))
(put 'c-define-abbrev-table 'lisp-indent-function 1)
+(defun c-populate-abbrev-table ()
+ ;; Insert the standard keywords which may need electric indentation into the
+ ;; current mode's abbreviation table.
+ (let ((table (intern (concat (symbol-name major-mode) "-abbrev-table")))
+ (defs c-std-abbrev-keywords)
+ )
+ (unless (and (boundp table)
+ (abbrev-table-p (symbol-value table)))
+ (define-abbrev-table table nil))
+ (setq local-abbrev-table (symbol-value table))
+ (while defs
+ (unless (intern-soft (car defs) local-abbrev-table) ; Don't overwrite the
+ ; abbrev's use count.
+ (condition-case nil
+ (define-abbrev (symbol-value table)
+ (car defs) (car defs)
+ 'c-electric-continued-statement 0 t)
+ (wrong-number-of-arguments
+ (define-abbrev (symbol-value table)
+ (car defs) (car defs)
+ 'c-electric-continued-statement 0))))
+ (setq defs (cdr defs)))))
+
(defun c-bind-special-erase-keys ()
;; Only used in Emacs to bind C-c C-<delete> and C-c C-<backspace>
;; to the proper keys depending on `normal-erase-is-backspace'.
@@ -476,11 +500,14 @@ preferably use the `c-mode-menu' language constant directly."
(save-excursion
(when (< beg end)
(goto-char beg)
+ (let ((lim (c-determine-limit 1000))
+ (lim+ (c-determine-+ve-limit 1000 end)))
(when
(and (not (bobp))
- (progn (c-backward-syntactic-ws) (eq (point) beg))
+ (progn (c-backward-syntactic-ws lim) (eq (point) beg))
(/= (skip-chars-backward c-symbol-chars (1- (point))) 0)
- (progn (goto-char beg) (c-forward-syntactic-ws) (<= (point) end))
+ (progn (goto-char beg) (c-forward-syntactic-ws lim+)
+ (<= (point) end))
(> (point) beg)
(goto-char end)
(looking-at c-symbol-char-key))
@@ -491,14 +518,14 @@ preferably use the `c-mode-menu' language constant directly."
(goto-char end)
(when
(and (not (eobp))
- (progn (c-forward-syntactic-ws) (eq (point) end))
+ (progn (c-forward-syntactic-ws lim+) (eq (point) end))
(looking-at c-symbol-char-key)
- (progn (c-backward-syntactic-ws) (>= (point) beg))
+ (progn (c-backward-syntactic-ws lim) (>= (point) beg))
(< (point) end)
(/= (skip-chars-backward c-symbol-chars (1- (point))) 0))
(goto-char (1+ end))
(c-end-of-current-token)
- (c-unfind-type (buffer-substring-no-properties end (point)))))))
+ (c-unfind-type (buffer-substring-no-properties 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
@@ -535,6 +562,18 @@ preferably use the `c-mode-menu' language constant directly."
;; and `after-change-functions'. Note that this variable is not set when
;; `c-before-change' is invoked by a change to text properties.
+(defvar c-min-syn-tab-mkr nil)
+;; The minimum buffer position where there's a `c-fl-syn-tab' text property,
+;; or nil if there aren't any. This is a marker, or nil if there's currently
+;; no such text property.
+(make-variable-buffer-local 'c-min-syn-tab-mkr)
+
+(defvar c-max-syn-tab-mkr nil)
+;; The maximum buffer position plus 1 where there's a `c-fl-syn-tab' text
+;; property, or nil if there aren't any. This is a marker, or nil if there's
+;; currently no such text property.
+(make-variable-buffer-local 'c-max-syn-tab-mkr)
+
(defun c-basic-common-init (mode default-style)
"Do the necessary initialization for the syntax handling routines
and the line breaking/filling code. Intended to be used by other
@@ -550,6 +589,8 @@ that requires a literal mode spec at compile time."
(setq c-buffer-is-cc-mode mode)
+ (c-populate-abbrev-table)
+
;; these variables should always be buffer local; they do not affect
;; indentation style.
(make-local-variable 'comment-start)
@@ -599,6 +640,8 @@ that requires a literal mode spec at compile time."
;; doesn't work with filladapt but it's better than nothing.
(set (make-local-variable 'fill-paragraph-function) 'c-fill-paragraph)
+ ;; Initialize the cache for `c-looking-at-or-maybe-in-bracelist'.
+ (setq c-laomib-cache nil)
;; Initialize the three literal sub-caches.
(c-truncate-lit-pos-cache 1)
;; Initialize the cache of brace pairs, and opening braces/brackets/parens.
@@ -606,6 +649,10 @@ that requires a literal mode spec at compile time."
;; Initialize the "brace stack" cache.
(c-init-bs-cache)
+ ;; Keep track of where `c-fl-syn-tab' text properties are set.
+ (setq c-min-syn-tab-mkr nil)
+ (setq c-max-syn-tab-mkr nil)
+
(when (or c-recognize-<>-arglists
(c-major-mode-is 'awk-mode)
(c-major-mode-is '(java-mode c-mode c++-mode objc-mode pike-mode)))
@@ -684,8 +731,8 @@ that requires a literal mode spec at compile time."
;; ;; Put submode indicators onto minor-mode-alist, but only once.
;; (or (assq 'c-submode-indicators minor-mode-alist)
;; (setq minor-mode-alist
-;; (cons '(c-submode-indicators c-submode-indicators)
-;; minor-mode-alist)))
+;; (cons '(c-submode-indicators c-submode-indicators)
+;; minor-mode-alist)))
(c-update-modeline)
;; Install the functions that ensure that various internal caches
@@ -922,6 +969,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
;; requires the use of the new function `run-mode-hooks'.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'run-mode-hooks)
`(run-mode-hooks ,@hooks)
`(progn ,@(mapcar (lambda (hook) `(run-hooks ,hook)) hooks))))
@@ -1207,52 +1255,94 @@ Note that the style variables are always made local to the buffer."
(c-put-syn-tab (1- (point)) '(15)))
(t nil)))))
-(defvar c-fl-syn-tab-region nil)
- ;; Non-nil when a `c-restore-string-fences' is "in force". It's value is a
- ;; cons of the BEG and END of the region currently "mirroring" the
- ;; c-fl-syn-tab properties as syntax-table properties.
+(defun c-put-syn-tab (pos value)
+ ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to
+ ;; VALUE (which should not be nil).
+ ;; `(let ((-pos- ,pos)
+ ;; (-value- ,value))
+ (c-put-char-property pos 'syntax-table value)
+ (c-put-char-property pos 'c-fl-syn-tab value)
+ (cond
+ ((null c-min-syn-tab-mkr)
+ (setq c-min-syn-tab-mkr (copy-marker pos t)))
+ ((< pos c-min-syn-tab-mkr)
+ (move-marker c-min-syn-tab-mkr pos)))
+ (cond
+ ((null c-max-syn-tab-mkr)
+ (setq c-max-syn-tab-mkr (copy-marker (1+ pos) nil)))
+ ((>= pos c-max-syn-tab-mkr)
+ (move-marker c-max-syn-tab-mkr (1+ pos))))
+ (c-truncate-lit-pos-cache pos))
+
+(defun c-clear-syn-tab (pos)
+ ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS.
+ (c-clear-char-property pos 'syntax-table)
+ (c-clear-char-property pos 'c-fl-syn-tab)
+ (when c-min-syn-tab-mkr
+ (if (and (eq pos (marker-position c-min-syn-tab-mkr))
+ (eq (1+ pos) (marker-position c-max-syn-tab-mkr)))
+ (progn
+ (move-marker c-min-syn-tab-mkr nil)
+ (move-marker c-max-syn-tab-mkr nil)
+ (setq c-min-syn-tab-mkr nil c-max-syn-tab-mkr nil))
+ (when (eq pos (marker-position c-min-syn-tab-mkr))
+ (move-marker c-min-syn-tab-mkr
+ (if (c-get-char-property (1+ pos) 'c-fl-syn-tab)
+ (1+ pos)
+ (c-next-single-property-change
+ (1+ pos) 'c-fl-syn-tab nil c-max-syn-tab-mkr))))
+ (when (eq (1+ pos) (marker-position c-max-syn-tab-mkr))
+ (move-marker c-max-syn-tab-mkr
+ (if (c-get-char-property (1- pos) 'c-fl-syn-tab)
+ pos
+ (c-previous-single-property-change
+ pos 'c-fl-syn-tab nil (1+ c-min-syn-tab-mkr)))))))
+ (c-truncate-lit-pos-cache pos))
(defun c-clear-string-fences ()
- ;; Clear syntax-table text properties in the region defined by
- ;; `c-cl-syn-tab-region' which are "mirrored" by c-fl-syn-tab text
- ;; properties. However, any such " character which ends up not being
+ ;; Clear syntax-table text properties which are "mirrored" by c-fl-syn-tab
+ ;; text properties. However, any such " character which ends up not being
;; balanced by another " is left with a '(1) syntax-table property.
- (when c-fl-syn-tab-region
- (let ((beg (car c-fl-syn-tab-region))
- (end (cdr c-fl-syn-tab-region))
- s pos)
- (setq pos beg)
+ (when
+ (and c-min-syn-tab-mkr c-max-syn-tab-mkr)
+ (let (s pos)
+ (setq pos c-min-syn-tab-mkr)
(while
(and
- (< pos end)
- (setq pos
- (c-min-property-position pos end 'c-fl-syn-tab))
- (< pos end))
+ (< pos c-max-syn-tab-mkr)
+ (setq pos (c-min-property-position pos
+ c-max-syn-tab-mkr
+ 'c-fl-syn-tab))
+ (< pos c-max-syn-tab-mkr))
(c-clear-char-property pos 'syntax-table)
(setq pos (1+ pos)))
;; Check we haven't left any unbalanced "s.
(save-excursion
- (setq pos beg)
+ (setq pos c-min-syn-tab-mkr)
;; Is there already an unbalanced " before BEG?
- (setq pos (c-min-property-position pos end 'c-fl-syn-tab))
- (when (< pos end) (goto-char pos))
+ (setq pos (c-min-property-position pos c-max-syn-tab-mkr
+ 'c-fl-syn-tab))
+ (when (< pos c-max-syn-tab-mkr)
+ (goto-char pos))
(when (and (save-match-data
(c-search-backward-char-property-with-value-on-char
'c-fl-syn-tab '(15) ?\"
(max (- (point) 500) (point-min))))
(not (equal (c-get-char-property (point) 'syntax-table) '(1))))
(setq pos (1+ pos)))
- (while (< pos end)
+ (while (< pos c-max-syn-tab-mkr)
(setq pos
- (c-min-property-position pos end 'c-fl-syn-tab))
- (when (< pos end)
+ (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab))
+ (when (< pos c-max-syn-tab-mkr)
(if (memq (char-after pos) c-string-delims)
(progn
;; Step over the ".
- (setq s (parse-partial-sexp pos end nil nil nil
+ (setq s (parse-partial-sexp pos c-max-syn-tab-mkr
+ nil nil nil
'syntax-table))
;; Seek a (bogus) matching ".
- (setq s (parse-partial-sexp (point) end nil nil s
+ (setq s (parse-partial-sexp (point) c-max-syn-tab-mkr
+ nil nil s
'syntax-table))
;; When a bogus matching " is found, do nothing.
;; Otherwise mark the " with 'syntax-table '(1).
@@ -1262,23 +1352,22 @@ Note that the style variables are always made local to the buffer."
(c-get-char-property (1- (point)) 'c-fl-syn-tab))
(c-put-char-property pos 'syntax-table '(1)))
(setq pos (point)))
- (setq pos (1+ pos))))))
- (setq c-fl-syn-tab-region nil))))
-
-(defun c-restore-string-fences (beg end)
- ;; Restore any syntax-table text properties in the region (BEG END) which
- ;; are "mirrored" by c-fl-syn-tab text properties.
- (let ((pos beg))
- (while
- (and
- (< pos end)
- (setq pos
- (c-min-property-position pos end 'c-fl-syn-tab))
- (< pos end))
- (c-put-char-property pos 'syntax-table
- (c-get-char-property pos 'c-fl-syn-tab))
- (setq pos (1+ pos)))
- (setq c-fl-syn-tab-region (cons beg end))))
+ (setq pos (1+ pos)))))))))
+
+(defun c-restore-string-fences ()
+ ;; Restore any syntax-table text properties which are "mirrored" by
+ ;; c-fl-syn-tab text properties.
+ (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr)
+ (let ((pos c-min-syn-tab-mkr))
+ (while
+ (and
+ (< pos c-max-syn-tab-mkr)
+ (setq pos
+ (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab))
+ (< pos c-max-syn-tab-mkr))
+ (c-put-char-property pos 'syntax-table
+ (c-get-char-property pos 'c-fl-syn-tab))
+ (setq pos (1+ pos))))))
(defvar c-bc-changed-stringiness nil)
;; Non-nil when, in a before-change function, the deletion of a range of text
@@ -1396,9 +1485,11 @@ Note that the style variables are always made local to the buffer."
(c-will-be-escaped end beg end))
(c-remove-string-fences end)
(goto-char (1+ end)))
- ;; Are we unescaping a newline by inserting stuff between \ and \n?
- ((and (eq end beg)
- (c-is-escaped end))
+ ;; Are we unescaping a newline ...
+ ((and
+ (c-is-escaped end)
+ (or (eq beg end) ; .... by inserting stuff between \ and \n?
+ (c-will-be-unescaped beg))) ; ... by removing an odd number of \s?
(goto-char (1+ end))) ; To after the NL which is being unescaped.
(t
(goto-char end)))
@@ -1406,7 +1497,7 @@ Note that the style variables are always made local to the buffer."
;; Move to end of logical line (as it will be after the change, or as it
;; was before unescaping a NL.)
- (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t)
+ (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t)
;; We're at an EOLL or point-max.
(if (equal (c-get-char-property (point) 'syntax-table) '(15))
(if (memq (char-after) '(?\n ?\r))
@@ -1436,10 +1527,11 @@ Note that the style variables are always made local to the buffer."
(not (c-characterp c-multiline-string-start-char))))
(when (and (eq end-literal-type 'string)
(not (eq (char-before (cdr end-limits)) ?\())
- (memq (char-after (car end-limits)) c-string-delims)
- (equal (c-get-char-property (car end-limits) 'syntax-table)
- '(15)))
- (c-remove-string-fences (car end-limits))
+ (memq (char-after (car end-limits)) c-string-delims))
+ (setq c-new-END (max c-new-END (cdr end-limits)))
+ (when (equal (c-get-char-property (car end-limits) 'syntax-table)
+ '(15))
+ (c-remove-string-fences (car end-limits)))
(setq c-new-END (max c-new-END (cdr end-limits))))
(when (and (eq beg-literal-type 'string)
@@ -1512,9 +1604,13 @@ Note that the style variables are always made local to the buffer."
; insertion/deletion of string delimiters.
(max
(progn
- (goto-char (min (1+ end) ; 1+, in case a NL has become escaped.
- (point-max)))
- (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*"
+ (goto-char
+ (if (and (memq (char-after end) '(?\n ?\r))
+ (c-is-escaped end))
+ (min (1+ end) ; 1+, if we're inside an escaped NL.
+ (point-max))
+ end))
+ (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*"
nil t)
(point))
c-new-END))
@@ -1595,7 +1691,7 @@ Note that the style variables are always made local to the buffer."
(c-beginning-of-macro))))
(goto-char (1+ end)) ; After the \
;; Search forward for EOLL
- (setq lim (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*"
+ (setq lim (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*"
nil t))
(goto-char (1+ end))
(when (c-search-forward-char-property-with-value-on-char
@@ -1888,7 +1984,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(widen)
(unwind-protect
(progn
- (c-restore-string-fences (point-min) (point-max))
+ (c-restore-string-fences)
(save-excursion
;; Are we inserting/deleting stuff in the middle of an
;; identifier?
@@ -1907,7 +2003,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; We search for appropriate c-type properties "near"
;; the change. First, find an appropriate boundary
;; for this property search.
- (let (lim
+ (let (lim lim-2
type type-pos
marked-id term-pos
(end1
@@ -1918,8 +2014,11 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(when (>= end1 beg) ; Don't hassle about changes entirely in
; comments.
;; Find a limit for the search for a `c-type' property
+ ;; Point is currently undefined. A `goto-char' somewhere is needed. (2020-12-06).
+ (setq lim-2 (c-determine-limit 1000 (point) ; that is wrong. FIXME!!! (2020-12-06)
+ ))
(while
- (and (/= (skip-chars-backward "^;{}") 0)
+ (and (/= (skip-chars-backward "^;{}" lim-2) 0)
(> (point) (point-min))
(memq (c-get-char-property (1- (point)) 'face)
'(font-lock-comment-face font-lock-string-face))))
@@ -1943,7 +2042,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(buffer-substring-no-properties (point) type-pos)))
(goto-char end1)
- (skip-chars-forward "^;{}") ; FIXME!!! loop for
+ (setq lim-2 (c-determine-+ve-limit 1000))
+ (skip-chars-forward "^;{}" lim-2) ; FIXME!!! loop for
; comment, maybe
(setq lim (point))
(setq term-pos
@@ -1958,13 +2058,19 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(if c-get-state-before-change-functions
(mapc (lambda (fn)
(funcall fn beg end))
- c-get-state-before-change-functions))))
+ c-get-state-before-change-functions))
+
+ (c-laomib-invalidate-cache beg end)))
(c-clear-string-fences))))
(c-truncate-lit-pos-cache beg)
;; The following must be done here rather than in `c-after-change'
;; because newly inserted parens would foul up the invalidation
;; algorithm.
- (c-invalidate-state-cache beg)))
+ (c-invalidate-state-cache beg)
+ ;; The following must happen after the previous, which likely alters
+ ;; the macro cache.
+ (when c-opt-cpp-symbol
+ (c-invalidate-macro-cache beg end))))
(defvar c-in-after-change-fontification nil)
(make-variable-buffer-local 'c-in-after-change-fontification)
@@ -2018,7 +2124,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(widen)
(unwind-protect
(progn
- (c-restore-string-fences (point-min) (point-max))
+ (c-restore-string-fences)
(when (> end (point-max))
;; Some emacsen might return positions past the end. This
;; has been observed in Emacs 20.7 when rereading a buffer
@@ -2109,7 +2215,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
old-pos
(new-pos pos)
capture-opener
- bod-lim bo-decl)
+ bod-lim bo-decl
+ paren-state containing-brace)
(goto-char (c-point 'bol new-pos))
(unless lit-start
(setq bod-lim (c-determine-limit 500))
@@ -2128,12 +2235,16 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(setq old-pos (point))
(let (pseudo)
(while
- (progn
- (c-syntactic-skip-backward "^;{}" bod-lim t)
- (and (eq (char-before) ?})
- (save-excursion
- (backward-char)
- (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state))))))
+ (and
+ ;; N.B. `c-syntactic-skip-backward' doesn't check (> (point)
+ ;; lim) and can loop if that's not the case.
+ (> (point) bod-lim)
+ (progn
+ (c-syntactic-skip-backward "^;{}" bod-lim t)
+ (and (eq (char-before) ?})
+ (save-excursion
+ (backward-char)
+ (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state)))))))
(goto-char pseudo))
t)
(> (point) bod-lim)
@@ -2166,7 +2277,14 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(and (eq (char-before) ?{)
(save-excursion
(backward-char)
- (consp (c-looking-at-or-maybe-in-bracelist))))
+ (setq paren-state (c-parse-state))
+ (while
+ (and
+ (setq containing-brace
+ (c-pull-open-brace paren-state))
+ (not (eq (char-after containing-brace) ?{))))
+ (consp (c-looking-at-or-maybe-in-bracelist
+ containing-brace containing-brace))))
)))
(not (bobp)))
(backward-char)) ; back over (, [, <.
@@ -2177,25 +2295,47 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
(defun c-fl-decl-end (pos)
;; If POS is inside a declarator, return the end of the token that follows
;; the declarator, otherwise return nil. POS being in a literal does not
- ;; count as being in a declarator (on pragmatic grounds).
+ ;; count as being in a declarator (on pragmatic grounds). POINT is not
+ ;; preserved.
(goto-char pos)
(let ((lit-start (c-literal-start))
+ (lim (c-determine-limit 1000))
enclosing-attribute pos1)
(unless lit-start
- (c-backward-syntactic-ws)
- (when (setq enclosing-attribute (c-slow-enclosing-c++-attribute))
+ (c-backward-syntactic-ws
+ lim)
+ (when (setq enclosing-attribute (c-enclosing-c++-attribute))
(goto-char (car enclosing-attribute))) ; Only happens in C++ Mode.
(when (setq pos1 (c-on-identifier))
(goto-char pos1)
(let ((lim (save-excursion
(and (c-beginning-of-macro)
(progn (c-end-of-macro) (point))))))
- (when (and (c-forward-declarator lim)
- (or (not (eq (char-after) ?\())
- (c-go-list-forward nil lim))
- (eq (c-forward-token-2 1 nil lim) 0))
- (c-backward-syntactic-ws)
- (point)))))))
+ (and (c-forward-declarator lim)
+ (if (eq (char-after) ?\()
+ (and
+ (c-go-list-forward nil lim)
+ (progn (c-forward-syntactic-ws lim)
+ (not (eobp)))
+ (progn
+ (if (looking-at c-symbol-char-key)
+ ;; Deal with baz (foo((bar)) type var), where
+ ;; foo((bar)) is not semantically valid. The result
+ ;; must be after var).
+ (and
+ (goto-char pos)
+ (setq pos1 (c-on-identifier))
+ (goto-char pos1)
+ (progn
+ (c-backward-syntactic-ws lim)
+ (eq (char-before) ?\())
+ (c-fl-decl-end (1- (point))))
+ (c-backward-syntactic-ws lim)
+ (point))))
+ (and (progn (c-forward-syntactic-ws lim)
+ (not (eobp)))
+ (c-backward-syntactic-ws lim)
+ (point)))))))))
(defun c-change-expand-fl-region (_beg _end _old-len)
;; Expand the region (c-new-BEG c-new-END) to an after-change font-lock
@@ -2255,69 +2395,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".")
;; line was fouled up by context fontification.
(save-restriction
(widen)
- (let (new-beg new-end new-region case-fold-search string-fence-beg lim)
- ;; Check how far back we need to extend the region where we reapply the
- ;; string fence syntax-table properties. These must be in place for the
- ;; coming fontification operations.
- (save-excursion
- (goto-char (if c-in-after-change-fontification
- (min beg c-new-BEG)
- beg))
- (setq lim (max (- (point) 500) (point-min)))
- (while
+ (let (new-beg new-end new-region case-fold-search)
+ (c-save-buffer-state nil
+ ;; Temporarily reapply the string fence syntax-table properties.
+ (unwind-protect
(progn
- (skip-chars-backward "^\"" lim)
- (or (bobp) (backward-char))
- (save-excursion
- (eq (logand (skip-chars-backward "\\\\") 1) 1))))
- (setq string-fence-beg
- (cond ((c-get-char-property (point) 'c-fl-syn-tab)
- (point))
- (c-in-after-change-fontification
- c-new-BEG)
- (t beg)))
- (c-save-buffer-state nil
- ;; Temporarily reapply the string fence syntax-table properties.
- (c-with-extended-string-fences
- string-fence-beg (if c-in-after-change-fontification
- (max end c-new-END)
- end)
-
- (if (and c-in-after-change-fontification
- (< beg c-new-END) (> end c-new-BEG))
- ;; Region and the latest after-change fontification region overlap.
- ;; Determine the upper and lower bounds of our adjusted region
- ;; separately.
- (progn
- (if (<= beg c-new-BEG)
- (setq c-in-after-change-fontification nil))
- (setq new-beg
- (if (and (>= beg (c-point 'bol c-new-BEG))
- (<= beg c-new-BEG))
- ;; Either jit-lock has accepted `c-new-BEG', or has
- ;; (probably) extended the change region spuriously
- ;; to BOL, which position likely has a
- ;; syntactically different position. To ensure
- ;; correct fontification, we start at `c-new-BEG',
- ;; assuming any characters to the left of
- ;; `c-new-BEG' on the line do not require
- ;; fontification.
- c-new-BEG
- (setq new-region (c-before-context-fl-expand-region beg end)
- new-end (cdr new-region))
- (car new-region)))
- (setq new-end
- (if (and (>= end (c-point 'bol c-new-END))
- (<= end c-new-END))
- c-new-END
- (or new-end
- (cdr (c-before-context-fl-expand-region beg end))))))
- ;; Context (etc.) fontification.
- (setq new-region (c-before-context-fl-expand-region beg end)
- new-beg (car new-region) new-end (cdr new-region)))
- ;; Finally invoke font lock's functionality.
- (funcall (default-value 'font-lock-fontify-region-function)
- new-beg new-end verbose)))))))
+ (c-restore-string-fences)
+ (if (and c-in-after-change-fontification
+ (< beg c-new-END) (> end c-new-BEG))
+ ;; Region and the latest after-change fontification region overlap.
+ ;; Determine the upper and lower bounds of our adjusted region
+ ;; separately.
+ (progn
+ (if (<= beg c-new-BEG)
+ (setq c-in-after-change-fontification nil))
+ (setq new-beg
+ (if (and (>= beg (c-point 'bol c-new-BEG))
+ (<= beg c-new-BEG))
+ ;; Either jit-lock has accepted `c-new-BEG', or has
+ ;; (probably) extended the change region spuriously
+ ;; to BOL, which position likely has a
+ ;; syntactically different position. To ensure
+ ;; correct fontification, we start at `c-new-BEG',
+ ;; assuming any characters to the left of
+ ;; `c-new-BEG' on the line do not require
+ ;; fontification.
+ c-new-BEG
+ (setq new-region (c-before-context-fl-expand-region beg end)
+ new-end (cdr new-region))
+ (car new-region)))
+ (setq new-end
+ (if (and (>= end (c-point 'bol c-new-END))
+ (<= end c-new-END))
+ c-new-END
+ (or new-end
+ (cdr (c-before-context-fl-expand-region beg end))))))
+ ;; Context (etc.) fontification.
+ (setq new-region (c-before-context-fl-expand-region beg end)
+ new-beg (car new-region) new-end (cdr new-region)))
+ ;; Finally invoke font lock's functionality.
+ (funcall (default-value 'font-lock-fontify-region-function)
+ new-beg new-end verbose))
+ (c-clear-string-fences))))))
(defun c-after-font-lock-init ()
;; Put on `font-lock-mode-hook'. This function ensures our after-change
@@ -2385,6 +2504,7 @@ This function is called from `c-common-init', once per mode initialization."
;; Emacs < 22 and XEmacs
(defmacro c-advise-fl-for-region (function)
+ (declare (debug t))
`(defadvice ,function (before get-awk-region activate)
;; Make sure that any string/regexp is completely font-locked.
(when c-buffer-is-cc-mode
@@ -2444,11 +2564,6 @@ opening \" and the next unescaped end of line."
(funcall (c-lang-const c-make-mode-syntax-table c))
"Syntax table used in c-mode buffers.")
-(c-define-abbrev-table 'c-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0))
- "Abbreviation table used in c-mode buffers.")
-
(defvar c-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2514,20 +2629,29 @@ Key bindings:
(setq abbrev-mode t)
(c-init-language-vars-for 'c-mode)
(c-common-init 'c-mode)
- (easy-menu-add c-c-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-c-menu))
(cc-imenu-init cc-imenu-c-generic-expression)
(add-hook 'flymake-diagnostic-functions 'flymake-cc nil t)
(c-run-mode-hooks 'c-mode-common-hook))
(defconst c-or-c++-mode--regexp
(eval-when-compile
- (let ((id "[a-zA-Z0-9_]+") (ws "[ \t\r]+") (ws-maybe "[ \t\r]*"))
+ (let ((id "[a-zA-Z_][a-zA-Z0-9_]*") (ws "[ \t]+") (ws-maybe "[ \t]*")
+ (headers '("string" "string_view" "iostream" "map" "unordered_map"
+ "set" "unordered_set" "vector" "tuple")))
(concat "^" ws-maybe "\\(?:"
- "using" ws "\\(?:namespace" ws "std;\\|std::\\)"
- "\\|" "namespace" "\\(:?" ws id "\\)?" ws-maybe "{"
- "\\|" "class" ws id ws-maybe "[:{\n]"
- "\\|" "template" ws-maybe "<.*>"
- "\\|" "#include" ws-maybe "<\\(?:string\\|iostream\\|map\\)>"
+ "using" ws "\\(?:namespace" ws
+ "\\|" id "::"
+ "\\|" id ws-maybe "=\\)"
+ "\\|" "\\(?:inline" ws "\\)?namespace"
+ "\\(:?" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{"
+ "\\|" "class" ws id
+ "\\(?:" ws "final" "\\)?" ws-maybe "[:{;\n]"
+ "\\|" "struct" ws id "\\(?:" ws "final" ws-maybe "[:{\n]"
+ "\\|" ws-maybe ":\\)"
+ "\\|" "template" ws-maybe "<.*?>"
+ "\\|" "#include" ws-maybe "<" (regexp-opt headers) ">"
"\\)")))
"A regexp applied to C header files to check if they are really C++.")
@@ -2543,6 +2667,7 @@ should be used.
This function attempts to use file contents to determine whether
the code is C or C++ and based on that chooses whether to enable
`c-mode' or `c++-mode'."
+ (interactive)
(if (save-excursion
(save-restriction
(save-match-data
@@ -2560,12 +2685,6 @@ the code is C or C++ and based on that chooses whether to enable
(funcall (c-lang-const c-make-mode-syntax-table c++))
"Syntax table used in c++-mode buffers.")
-(c-define-abbrev-table 'c++-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0)
- ("catch" "catch" c-electric-continued-statement 0))
- "Abbreviation table used in c++-mode buffers.")
-
(defvar c++-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2602,7 +2721,8 @@ Key bindings:
(setq abbrev-mode t)
(c-init-language-vars-for 'c++-mode)
(c-common-init 'c++-mode)
- (easy-menu-add c-c++-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-c++-menu))
(cc-imenu-init cc-imenu-c++-generic-expression)
(add-hook 'flymake-diagnostic-functions 'flymake-cc nil t)
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2614,11 +2734,6 @@ Key bindings:
(funcall (c-lang-const c-make-mode-syntax-table objc))
"Syntax table used in objc-mode buffers.")
-(c-define-abbrev-table 'objc-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0))
- "Abbreviation table used in objc-mode buffers.")
-
(defvar objc-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2654,7 +2769,8 @@ Key bindings:
(setq abbrev-mode t)
(c-init-language-vars-for 'objc-mode)
(c-common-init 'objc-mode)
- (easy-menu-add c-objc-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-objc-menu))
(cc-imenu-init nil 'cc-imenu-objc-function)
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2665,13 +2781,6 @@ Key bindings:
(funcall (c-lang-const c-make-mode-syntax-table java))
"Syntax table used in java-mode buffers.")
-(c-define-abbrev-table 'java-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0)
- ("catch" "catch" c-electric-continued-statement 0)
- ("finally" "finally" c-electric-continued-statement 0))
- "Abbreviation table used in java-mode buffers.")
-
(defvar java-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2683,7 +2792,7 @@ Key bindings:
;; since it's practically impossible to write a regexp that reliably
;; matches such a construct. Other tools are necessary.
(defconst c-Java-defun-prompt-regexp
- "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*")
+ "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*")
(easy-menu-define c-java-menu java-mode-map "Java Mode Commands"
(cons "Java" (c-lang-const c-mode-menu java)))
@@ -2711,7 +2820,8 @@ Key bindings:
(setq abbrev-mode t)
(c-init-language-vars-for 'java-mode)
(c-common-init 'java-mode)
- (easy-menu-add c-java-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-java-menu))
(cc-imenu-init cc-imenu-java-generic-expression)
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2722,9 +2832,6 @@ Key bindings:
(funcall (c-lang-const c-make-mode-syntax-table idl))
"Syntax table used in idl-mode buffers.")
-(c-define-abbrev-table 'idl-mode-abbrev-table nil
- "Abbreviation table used in idl-mode buffers.")
-
(defvar idl-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2756,7 +2863,8 @@ Key bindings:
(c-initialize-cc-mode t)
(c-init-language-vars-for 'idl-mode)
(c-common-init 'idl-mode)
- (easy-menu-add c-idl-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-idl-menu))
;;(cc-imenu-init cc-imenu-idl-generic-expression) ;TODO
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2767,11 +2875,6 @@ Key bindings:
(funcall (c-lang-const c-make-mode-syntax-table pike))
"Syntax table used in pike-mode buffers.")
-(c-define-abbrev-table 'pike-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0))
- "Abbreviation table used in pike-mode buffers.")
-
(defvar pike-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2806,7 +2909,8 @@ Key bindings:
(setq abbrev-mode t)
(c-init-language-vars-for 'pike-mode)
(c-common-init 'pike-mode)
- (easy-menu-add c-pike-menu)
+ (when (featurep 'xemacs)
+ (easy-menu-add c-pike-menu))
;;(cc-imenu-init cc-imenu-pike-generic-expression) ;TODO
(c-run-mode-hooks 'c-mode-common-hook))
@@ -2819,11 +2923,6 @@ Key bindings:
;;;###autoload (add-to-list 'interpreter-mode-alist '("nawk" . awk-mode))
;;;###autoload (add-to-list 'interpreter-mode-alist '("gawk" . awk-mode))
-(c-define-abbrev-table 'awk-mode-abbrev-table
- '(("else" "else" c-electric-continued-statement 0)
- ("while" "while" c-electric-continued-statement 0))
- "Abbreviation table used in awk-mode buffers.")
-
(defvar awk-mode-map
(let ((map (c-make-inherited-keymap)))
map)
@@ -2880,7 +2979,7 @@ Key bindings:
;; bug reporting
(defconst c-mode-help-address
- "submit@debbugs.gnu.org"
+ "bug-gnu-emacs@gnu.org"
"Address(es) for CC Mode bug reports.")
(defun c-version ()
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index e0dc9e83c73..8514434e9ac 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -1,4 +1,4 @@
-;;; cc-styles.el --- support for styles in CC Mode
+;;; cc-styles.el --- support for styles in CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -374,7 +374,7 @@ in this way.
If DONT-OVERRIDE is t, style variables that already have values (i.e., whose
values are not the symbol `set-from-style') will not be overridden. CC Mode
calls c-set-style internally in this way whilst initializing a buffer; if
-cc-set-style is called like this from anywhere else, it will usually behave as
+c-set-style is called like this from anywhere else, it will usually behave as
a null operation."
(interactive
(list (let ((completion-ignore-case t)
@@ -395,8 +395,7 @@ a null operation."
;; remain. This is not necessary for c-offsets-alist, since
;; c-get-style-variables contains every valid offset type in the
;; fallback entry.
- (setq c-special-indent-hook
- (default-value 'c-special-indent-hook)))
+ (kill-local-variable 'c-special-indent-hook))
(mapc (lambda (elem)
(c-set-style-1 elem dont-override))
;; Need to go through the variables backwards when we
@@ -465,7 +464,7 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil."
offset))
;;;###autoload
-(defun c-set-offset (symbol offset &optional ignored)
+(defun c-set-offset (symbol offset &optional _ignored)
"Change the value of a syntactic element symbol in `c-offsets-alist'.
SYMBOL is the syntactic element symbol to change and OFFSET is the new
offset for that syntactic element. The optional argument is not used
@@ -477,8 +476,8 @@ and exists only for compatibility reasons."
(if current-prefix-arg " or add" "")
": ")
(mapcar
- #'(lambda (langelem)
- (cons (format "%s" (car langelem)) nil))
+ (lambda (langelem)
+ (cons (format "%s" (car langelem)) nil))
(get 'c-offsets-alist 'c-stylevar-fallback))
nil (not current-prefix-arg)
;; initial contents tries to be the last element
@@ -644,7 +643,7 @@ CC Mode by making sure the proper entries are present on
(defun c-make-styles-buffer-local (&optional this-buf-only-p)
"Make all CC Mode style variables buffer local.
-If `this-buf-only-p' is non-nil, the style variables will be made
+If THIS-BUF-ONLY-P is non-nil, the style variables will be made
buffer local only in the current buffer. Otherwise they'll be made
permanently buffer local in any buffer that changes their values.
@@ -662,7 +661,6 @@ any reason to call this function directly."
;; Hooks must be handled specially
(if this-buf-only-p
(if (featurep 'xemacs) (make-local-hook 'c-special-indent-hook))
- (with-no-warnings (make-variable-buffer-local 'c-special-indent-hook))
(setq c-style-variables-are-local-p t))
))
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 407dcbac1bf..b33fea0b48c 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1,4 +1,4 @@
-;;; cc-vars.el --- user customization variables for CC Mode
+;;; cc-vars.el --- user customization variables for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -42,6 +42,9 @@
(cc-require 'cc-defs)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
+
(cc-eval-when-compile
(require 'custom)
(require 'widget))
@@ -575,7 +578,9 @@ comment styles:
javadoc -- Javadoc style for \"/** ... */\" comments (default in Java mode).
autodoc -- Pike autodoc style for \"//! ...\" comments (default in Pike mode).
- gtkdoc -- GtkDoc style for \"/** ... **/\" comments (default in C and C++ modes).
+ gtkdoc -- GtkDoc style for \"/** ... **/\" comments
+ (default in C and C++ modes).
+ doxygen -- Doxygen style.
The value may also be a list of doc comment styles, in which case all
of them are recognized simultaneously (presumably with markup cues
@@ -1649,6 +1654,15 @@ white space either before or after the operator, but not both."
:type 'boolean
:group 'c)
+(defcustom c-cpp-indent-to-body-directives '("pragma")
+ "Preprocessor directives which will be indented as statements.
+
+A list of Preprocessor directives which when reindented, or newly
+typed in, will cause the \"#\" introducing the directive to be
+indented as a statement."
+ :type '(repeat string)
+ :group 'c)
+
;; Initialize the next two to a regexp which never matches.
(defvar c-noise-macro-with-parens-name-re regexp-unmatchable)
(make-variable-buffer-local 'c-noise-macro-with-parens-name-re)
@@ -1660,7 +1674,8 @@ white space either before or after the operator, but not both."
like \"INLINE\" which are syntactic noise. Such a macro/extension is complete
in itself, never having parentheses. All these names must be syntactically
valid identifiers. Alternatively, this variable may be a regular expression
-which matches the names of such macros.
+which matches the names of such macros, in which case it must have a submatch
+1 which matches the actual noise macro name.
If you change this variable's value, call the function
`c-make-noise-macro-regexps' to set the necessary internal variables (or do
@@ -1676,7 +1691,8 @@ this implicitly by reinitializing C/C++/Objc Mode on any buffer)."
which optionally have arguments in parentheses, and which expand to nothing.
All these names must be syntactically valid identifiers. These are recognized
by CC Mode only in declarations. Alternatively, this variable may be a
-regular expression which matches the names of such macros.
+regular expression which matches the names of such macros, in which case it
+must have a submatch 1 which matches the actual noise macro name.
If you change this variable's value, call the function
`c-make-noise-macro-regexps' to set the necessary internal variables (or do
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 389e3ce9192..4649e506541 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -1,4 +1,4 @@
-;;; cfengine.el --- mode for editing Cfengine files
+;;; cfengine.el --- mode for editing Cfengine files -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -69,7 +69,6 @@
(defcustom cfengine-indent 2
"Size of a CFEngine indentation step in columns."
- :group 'cfengine
:type 'integer)
(defcustom cfengine-cf-promises
@@ -86,7 +85,6 @@ Used for syntax discovery and checking. Set to nil to disable
the `compile-command' override. In that case, the ElDoc support
will use a fallback syntax definition."
:version "24.4"
- :group 'cfengine
:type '(choice file (const nil)))
(defcustom cfengine-parameters-indent '(promise pname 2)
@@ -145,7 +143,6 @@ bundle agent rcfiles
}
"
:version "24.4"
- :group 'cfengine
:type '(list
(choice (const :tag "Anchor at beginning of promise" promise)
(const :tag "Anchor at beginning of line" bol))
@@ -799,7 +796,6 @@ bundle agent rcfiles
(defcustom cfengine-mode-abbrevs nil
"Abbrevs for CFEngine2 mode."
- :group 'cfengine
:type '(repeat (list (string :tag "Name")
(string :tag "Expansion")
(choice :tag "Hook" (const nil) function))))
@@ -991,13 +987,11 @@ Intended as the value of `indent-line-function'."
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos)))))
-;; This doesn't work too well in Emacs 21.2. See 22.1 development
-;; code.
(defun cfengine-fill-paragraph (&optional justify)
"Fill `paragraphs' in Cfengine code."
(interactive "P")
(or (if (fboundp 'fill-comment-paragraph)
- (fill-comment-paragraph justify) ; post Emacs 21.3
+ (fill-comment-paragraph justify)
;; else do nothing in a comment
(nth 4 (parse-partial-sexp (save-excursion
(beginning-of-defun)
@@ -1294,10 +1288,10 @@ Calls `cfengine-cf-promises' with \"-s json\"."
'symbols))
syntax)))
-(defun cfengine3-documentation-function ()
+(defun cfengine3-documentation-function (&rest _ignored)
"Document CFengine 3 functions around point.
-Intended as the value of `eldoc-documentation-function', which see.
-Use it by enabling `eldoc-mode'."
+Intended as the value of `eldoc-documentation-functions', which
+see. Use it by enabling `eldoc-mode'."
(let ((fdef (cfengine3--current-function)))
(when fdef
(cfengine3-format-function-docstring fdef))))
@@ -1314,19 +1308,19 @@ Use it by enabling `eldoc-mode'."
(append bounds (list (cdr flist))))))
(defun cfengine-common-settings ()
- (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 "\\"))))
- (set (make-local-variable 'parens-require-spaces) nil)
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
+ (setq-local 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-local parens-require-spaces nil)
+ (setq-local comment-start "# ")
+ (setq-local comment-start-skip
+ "\\(\\(?:^\\|[^\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*")
;; Like Lisp mode. Without this, we lose with, say,
;; `backward-up-list' when there's an unbalanced quote in a
;; preceding comment.
- (set (make-local-variable 'parse-sexp-ignore-comments) t))
+ (setq-local parse-sexp-ignore-comments t))
(defun cfengine-common-syntax (table)
;; The syntax defaults seem OK to give reasonable word movement.
@@ -1374,7 +1368,7 @@ to the action header."
(cfengine-common-settings)
(cfengine-common-syntax cfengine3-mode-syntax-table)
- (set (make-local-variable 'indent-line-function) #'cfengine3-indent-line)
+ (setq-local indent-line-function #'cfengine3-indent-line)
(setq font-lock-defaults
'(cfengine3-font-lock-keywords
@@ -1384,18 +1378,14 @@ to the action header."
;; `compile-command' is almost never a `make' call with CFEngine so
;; we override it
(when cfengine-cf-promises
- (set (make-local-variable 'compile-command)
- (concat cfengine-cf-promises
- " -f "
- (when buffer-file-name
- (shell-quote-argument buffer-file-name)))))
-
- ;; For emacs < 25.1 where `eldoc-documentation-function' defaults to
- ;; nil.
- (or eldoc-documentation-function
- (setq-local eldoc-documentation-function #'ignore))
- (add-function :before-until (local 'eldoc-documentation-function)
- #'cfengine3-documentation-function)
+ (setq-local compile-command
+ (concat cfengine-cf-promises
+ " -f "
+ (when buffer-file-name
+ (shell-quote-argument buffer-file-name)))))
+
+ (add-hook 'eldoc-documentation-functions
+ #'cfengine3-documentation-function nil t)
(add-hook 'completion-at-point-functions
#'cfengine3-completion-function nil t)
@@ -1422,20 +1412,18 @@ to the action header."
;; should avoid potential confusion in some cases.
(modify-syntax-entry ?\` "\"" cfengine2-mode-syntax-table)
- (set (make-local-variable 'indent-line-function) #'cfengine2-indent-line)
- (set (make-local-variable 'outline-regexp) "[ \t]*\\(\\sw\\|\\s_\\)+:+")
- (set (make-local-variable 'outline-level) #'cfengine2-outline-level)
- (set (make-local-variable 'fill-paragraph-function)
- #'cfengine-fill-paragraph)
+ (setq-local indent-line-function #'cfengine2-indent-line)
+ (setq-local outline-regexp "[ \t]*\\(\\sw\\|\\s_\\)+:+")
+ (setq-local outline-level #'cfengine2-outline-level)
+ (setq-local fill-paragraph-function #'cfengine-fill-paragraph)
(define-abbrev-table 'cfengine2-mode-abbrev-table cfengine-mode-abbrevs)
(setq font-lock-defaults
'(cfengine2-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.
(setq imenu-generic-expression cfengine2-imenu-expression)
- (set (make-local-variable 'beginning-of-defun-function)
- #'cfengine2-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function) #'cfengine2-end-of-defun))
+ (setq-local beginning-of-defun-function #'cfengine2-beginning-of-defun)
+ (setq-local end-of-defun-function #'cfengine2-end-of-defun))
;;;###autoload
(defun cfengine-auto-mode ()
@@ -1452,7 +1440,7 @@ to the action header."
(cfengine3-mode)
(cfengine2-mode)))
-(defalias 'cfengine-mode 'cfengine3-mode)
+(defalias 'cfengine-mode #'cfengine3-mode)
(provide 'cfengine3)
(provide 'cfengine)
diff --git a/lisp/progmodes/cl-font-lock.el b/lisp/progmodes/cl-font-lock.el
new file mode 100644
index 00000000000..178fe944f30
--- /dev/null
+++ b/lisp/progmodes/cl-font-lock.el
@@ -0,0 +1,290 @@
+;;; cl-font-lock.el --- Pretty Common Lisp font locking -*- lexical-binding: t; -*-
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+;; Author: Yue Daian <sheepduke@gmail.com>
+;; Maintainer: Spenser Truex <web@spensertruex.com>
+;; Created: 2019-06-16
+;; Old-Version: 0.3.0
+;; Package-Requires: ((emacs "24.5"))
+;; Keywords: lisp wp files convenience
+;; URL: https://github.com/cl-font-lock/cl-font-lock
+;; Homepage: https://github.com/cl-font-lock/cl-font-lock
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Highlight all the symbols in the Common Lisp ANSI Standard.
+;; Adds font-lock regexes to lisp-mode.
+
+;;;; Todo:
+
+;; - Integrate better into `lisp-mode' (e.g. enable it by default).
+;; - Distinguish functions from macros like `pushnew'.
+
+;;; Code:
+
+;; The list of built-in functions and variables was actually not
+;; extracted from the standard, but from SBCL with the following
+;; (Common Lisp) code:
+
+;; (defvar *functions* nil)
+;; (defvar *symbols* nil)
+;; (defvar *types* nil)
+
+;; (let ((pack (find-package :common-lisp)))
+;; (do-all-symbols (sym)
+;; (cond
+;; ((not (eql pack (symbol-package sym))) nil)
+;; ((fboundp sym) (pushnew sym *functions*))
+;; ((find-class sym nil) (pushnew sym *types*))
+;; (t (pushnew sym *symbols*)))))
+
+
+(defvar cl-font-lock-built-in--functions
+ '("+" "-" "/" "/=" "<" "<=" "=" ">" ">=" "*" "1-" "1+" "abs" "acons" "acos"
+ "acosh" "add-method" "adjoin" "adjustable-array-p" "adjust-array"
+ "allocate-instance" "alpha-char-p" "alphanumericp" "and" "append" "apply"
+ "apropos" "apropos-list" "aref" "arithmetic-error-operands"
+ "arithmetic-error-operation" "array-dimension" "array-dimensions"
+ "array-displacement" "array-element-type" "array-has-fill-pointer-p"
+ "array-in-bounds-p" "arrayp" "array-rank" "array-row-major-index"
+ "array-total-size" "ash" "asin" "asinh" "assoc" "assoc-if" "assoc-if-not"
+ "atan" "atanh" "atom" "bit" "bit-and" "bit-andc1" "bit-andc2" "bit-eqv"
+ "bit-ior" "bit-nand" "bit-nor" "bit-not" "bit-orc1" "bit-orc2"
+ "bit-vector-p" "bit-xor" "boole" "both-case-p" "boundp"
+ "broadcast-stream-streams" "butlast" "byte" "byte-position" "byte-size"
+ "call-method" "call-next-method" "car" "catch" "cdr" "ceiling"
+ "cell-error-name" "change-class" "char" "char/=" "char<" "char<=" "char="
+ "char>" "char>=" "character" "characterp" "char-code" "char-downcase"
+ "char-equal" "char-greaterp" "char-int" "char-lessp" "char-name"
+ "char-not-equal" "char-not-greaterp" "char-not-lessp" "char-upcase" "cis"
+ "class-name" "class-of" "clear-input" "clear-output" "close" "clrhash"
+ "code-char" "coerce" "compile" "compiled-function-p" "compile-file"
+ "compile-file-pathname" "compiler-macro-function" "complement" "complex"
+ "complexp" "compute-applicable-methods" "compute-restarts" "concatenate"
+ "concatenated-stream-streams" "conjugate" "cons" "consp" "constantly"
+ "constantp" "continue" "copy-alist" "copy-list" "copy-pprint-dispatch"
+ "copy-readtable" "copy-seq" "copy-structure" "copy-symbol" "copy-tree"
+ "cos" "cosh" "count" "count-if" "count-if-not" "decf" "decode-float"
+ "decode-universal-time" "delete" "delete-duplicates" "delete-file"
+ "delete-if" "delete-if-not" "delete-package" "denominator" "deposit-field"
+ "describe" "describe-object" "digit-char" "digit-char-p" "directory"
+ "directory-namestring" "disassemble" "do-all-symbols" "documentation"
+ "do-external-symbols" "do-symbols" "dpb" "dribble"
+ "echo-stream-input-stream" "echo-stream-output-stream" "ed" "eighth" "elt"
+ "encode-universal-time" "endp" "enough-namestring"
+ "ensure-directories-exist" "ensure-generic-function" "eq" "eql" "equal"
+ "equalp" "eval" "evenp" "every" "exp" "export" "expt" "fboundp" "fceiling"
+ "fdefinition" "ffloor" "fifth" "file-author" "file-error-pathname"
+ "file-length" "file-namestring" "file-position" "file-string-length"
+ "file-write-date" "fill" "fill-pointer" "find" "find-all-symbols"
+ "find-class" "find-if" "find-if-not" "find-method" "find-package"
+ "find-restart" "find-symbol" "finish-output" "first" "float" "float-digits"
+ "floatp" "float-precision" "float-radix" "float-sign" "floor" "fmakunbound"
+ "force-output" "format" "formatter" "fourth" "fresh-line" "fround"
+ "ftruncate" "funcall" "function" "function-keywords"
+ "function-lambda-expression" "functionp" "gcd" "gensym" "gentemp" "get"
+ "get-decoded-time" "get-dispatch-macro-character" "getf" "gethash"
+ "get-internal-real-time" "get-internal-run-time" "get-macro-character"
+ "get-output-stream-string" "get-properties" "get-setf-expansion"
+ "get-universal-time" "graphic-char-p" "hash-table-count" "hash-table-p"
+ "hash-table-rehash-size" "hash-table-rehash-threshold" "hash-table-size"
+ "hash-table-test" "host-namestring" "identity" "imagpart" "import" "incf"
+ "initialize-instance" "input-stream-p" "inspect" "integer-decode-float"
+ "integer-length" "integerp" "interactive-stream-p" "intern" "intersection"
+ "invalid-method-error" "invoke-debugger" "invoke-restart"
+ "invoke-restart-interactively" "isqrt" "keywordp" "last" "lcm" "ldb"
+ "ldb-test" "ldiff" "length" "lisp-implementation-type"
+ "lisp-implementation-version" "list" "list\\*" "list-all-packages" "listen"
+ "list-length" "listp" "load" "load-logical-pathname-translations"
+ "load-time-value" "log" "logand" "logandc1" "logandc2" "logbitp" "logcount"
+ "logeqv" "logical-pathname" "logical-pathname-translations" "logior"
+ "lognand" "lognor" "lognot" "logorc1" "logorc2" "logtest" "logxor"
+ "long-site-name" "loop-finish" "lower-case-p" "machine-instance"
+ "machine-type" "machine-version" "macroexpand" "macroexpand-1"
+ "macro-function" "make-array" "make-array" "make-broadcast-stream"
+ "make-concatenated-stream" "make-condition" "make-dispatch-macro-character"
+ "make-echo-stream" "make-hash-table" "make-instance"
+ "make-instances-obsolete" "make-list" "make-load-form"
+ "make-load-form-saving-slots" "make-method" "make-package" "make-pathname"
+ "make-random-state" "make-sequence" "make-string"
+ "make-string-input-stream" "make-string-output-stream" "make-symbol"
+ "make-synonym-stream" "make-two-way-stream" "makunbound" "map" "mapc"
+ "mapcan" "mapcar" "mapcon" "maphash" "map-into" "mapl" "maplist"
+ "mask-field" "max" "member" "member-if" "member-if-not" "merge"
+ "merge-pathnames" "method-combination-error" "method-qualifiers" "min"
+ "minusp" "mismatch" "mod" "muffle-warning" "multiple-value-call"
+ "multiple-value-list" "multiple-value-setq" "name-char" "namestring"
+ "nbutlast" "nconc" "next-method-p" "nintersection" "ninth"
+ "no-applicable-method" "no-next-method" "not" "notany" "notevery" "nreconc"
+ "nreverse" "nset-difference" "nset-exclusive-or" "nstring-capitalize"
+ "nstring-downcase" "nstring-upcase" "nsublis" "nsubst" "nsubst-if"
+ "nsubst-if-not" "nsubstitute" "nsubstitute-if" "nsubstitute-if-not" "nth"
+ "nthcdr" "nth-value" "null" "numberp" "numerator" "nunion" "oddp" "open"
+ "open-stream-p" "or" "output-stream-p" "package-error-package"
+ "package-name" "package-nicknames" "packagep" "package-shadowing-symbols"
+ "package-used-by-list" "package-use-list" "pairlis" "parse-integer"
+ "parse-namestring" "pathname" "pathname-device" "pathname-directory"
+ "pathname-host" "pathname-match-p" "pathname-name" "pathnamep"
+ "pathname-type" "pathname-version" "peek-char" "phase" "plusp" "pop"
+ "position" "position-if" "position-if-not" "pprint" "pprint-dispatch"
+ "pprint-exit-if-list-exhausted" "pprint-fill" "pprint-indent"
+ "pprint-linear" "pprint-logical-block" "pprint-newline" "pprint-pop"
+ "pprint-tab" "pprint-tabular" "prin1" "prin1-to-string" "princ"
+ "princ-to-string" "print" "print-not-readable-object" "print-object"
+ "print-unreadable-object" "probe-file" "provide" "psetf" "psetq" "push"
+ "pushnew" "quote" "random" "random-state-p" "rassoc" "rassoc-if"
+ "rassoc-if-not" "rational" "rationalize" "rationalp" "read" "read-byte"
+ "read-char" "read-char-no-hang" "read-delimited-list" "read-from-string"
+ "read-line" "read-preserving-whitespace" "read-sequence" "readtable-case"
+ "readtablep" "realp" "realpart" "reduce" "reinitialize-instance" "rem"
+ "remf" "remhash" "remove" "remove-duplicates" "remove-if" "remove-if-not"
+ "remove-method" "remprop" "rename-file" "rename-package" "replace"
+ "require" "rest" "restart-name" "revappend" "reverse" "room" "rotatef"
+ "round" "row-major-aref" "rplaca" "rplacd" "sbit" "scale-float" "schar"
+ "search" "second" "set" "set-difference" "set-dispatch-macro-character"
+ "set-exclusive-or" "setf" "set-macro-character" "set-pprint-dispatch"
+ "setq" "set-syntax-from-char" "seventh" "shadow" "shadowing-import"
+ "shared-initialize" "shiftf" "short-site-name" "signum"
+ "simple-bit-vector-p" "simple-condition-format-arguments"
+ "simple-condition-format-control" "simple-string-p" "simple-vector-p" "sin"
+ "sinh" "sixth" "sleep" "slot-boundp" "slot-exists-p" "slot-makunbound"
+ "slot-missing" "slot-unbound" "slot-value" "software-type"
+ "software-version" "some" "sort" "special-operator-p" "sqrt" "stable-sort"
+ "standard-char-p" "step" "store-value" "stream-element-type"
+ "stream-error-stream" "stream-external-format" "streamp" "string"
+ "string/=" "string<" "string<=" "string=" "string>" "string>="
+ "string-capitalize" "string-downcase" "string-equal" "string-greaterp"
+ "string-left-trim" "string-lessp" "string-not-equal" "string-not-greaterp"
+ "string-not-lessp" "stringp" "string-right-trim" "string-trim"
+ "string-upcase" "sublis" "subseq" "subsetp" "subst" "subst-if"
+ "subst-if-not" "substitute" "substitute-if" "substitute-if-not" "subtypep"
+ "svref" "sxhash" "symbol-function" "symbol-name" "symbolp" "symbol-package"
+ "symbol-plist" "symbol-value" "synonym-stream-symbol" "tailp" "tan" "tanh"
+ "tenth" "terpri" "third" "throw" "time" "trace"
+ "translate-logical-pathname" "translate-pathname" "tree-equal" "truename"
+ "truncate" "two-way-stream-input-stream" "two-way-stream-output-stream"
+ "type-error-datum" "type-error-expected-type" "type-of" "typep"
+ "unbound-slot-instance" "unexport" "unintern" "union" "unread-char"
+ "untrace" "unuse-package" "update-instance-for-different-class"
+ "update-instance-for-redefined-class" "upgraded-array-element-type"
+ "upgraded-complex-part-type" "upper-case-p" "use-package"
+ "user-homedir-pathname" "use-value" "values" "values-list" "vector"
+ "vectorp" "vector-pop" "vector-push" "vector-push-extend" "wild-pathname-p"
+ "write" "write-byte" "write-char" "write-line" "write-sequence"
+ "write-string" "write-to-string" "yes-or-no-p" "y-or-n-p" "zerop"))
+
+(defvar cl-font-lock-built-in--variables
+ '("//" "///" "\\*load-pathname\\*" "\\*print-pprint-dispatch\\*"
+ "\\*break-on-signals\\*" "\\*load-print\\*" "\\*print-pprint-dispatch\\*"
+ "\\*break-on-signals\\*" "\\*load-truename\\*" "\\*print-pretty\\*"
+ "\\*load-verbose\\*" "\\*print-radix\\*" "\\*compile-file-pathname\\*"
+ "\\*macroexpand-hook\\*" "\\*print-readably\\*"
+ "\\*compile-file-pathname\\*" "\\*modules\\*" "\\*print-right-margin\\*"
+ "\\*compile-file-truename\\*" "\\*package\\*" "\\*print-right-margin\\*"
+ "\\*compile-file-truename\\*" "\\*print-array\\*" "\\*query-io\\*"
+ "\\*compile-print\\*" "\\*print-base\\*" "\\*random-state\\*"
+ "\\*compile-verbose\\*" "\\*default-pathname-defaults\\*"
+ "\\*print-length\\*" "\\*readtable\\*" "\\*error-output\\*"
+ "\\*print-level\\*" "\\*standard-input\\*" "\\*print-case\\*"
+ "\\*read-base\\*" "\\*compile-verbose\\*" "\\*print-circle\\*"
+ "\\*print-lines\\*" "\\*standard-output\\*" "\\*features\\*"
+ "\\*print-miser-width\\*" "\\*read-default-float-format\\*"
+ "\\*debug-io\\*" "\\*print-escape\\*" "\\*read-eval\\*"
+ "\\*debugger-hook\\*" "\\*print-gensym\\*" "\\*read-suppress\\*"
+ "\\*terminal-io\\*" "\\*gensym-counter\\*" "\\*print-miser-width\\*"
+ "\\*trace-output\\*" "array-dimension-limit" "array-rank-limit"
+ "array-total-size-limit" "boole-1" "boole-2" "boole-and" "boole-andc1"
+ "boole-andc2" "boole-c1" "boole-c2" "boole-clr" "boole-eqv" "boole-ior"
+ "boole-nand" "boole-nor" "boole-orc1" "boole-orc2" "boole-set" "boole-xor"
+ "call-arguments-limit" "char-code-limit" "double-float-epsilon"
+ "double-float-negative-epsilon" "internal-time-units-per-second"
+ "lambda-list-keywords" "lambda-parameters-limit"
+ "least-negative-double-float" "least-negative-long-float"
+ "least-negative-normalized-double-float"
+ "least-negative-normalized-long-float"
+ "least-negative-normalized-short-float"
+ "least-negative-normalized-single-float" "least-negative-short-float"
+ "least-negative-single-float" "least-positive-double-float"
+ "least-positive-long-float" "least-positive-normalized-double-float"
+ "least-positive-normalized-long-float"
+ "least-positive-normalized-short-float"
+ "least-positive-normalized-single-float" "least-positive-short-float"
+ "least-positive-single-float" "long-float-epsilon"
+ "long-float-negative-epsilon" "most-negative-double-float"
+ "most-negative-fixnum" "most-negative-long-float"
+ "most-negative-short-float" "most-negative-single-float"
+ "most-positive-double-float" "most-positive-fixnum"
+ "most-positive-long-float" "most-positive-short-float"
+ "most-positive-single-float" "multiple-values-limit" "short-float-epsilon"
+ "short-float-negative-epsilon" "single-float-epsilon"
+ "single-float-negative-epsilon" "pi"))
+
+(defvar cl-font-lock-built-in--types
+ '("arithmetic-error" "array" "base-char" "base-string" "bignum" "bit-vector"
+ "boolean" "broadcast-stream" "built-in-class" "cell-error" "class"
+ "compiled-function" "concatenated-stream" "condition" "control-error"
+ "division-by-zero" "double-float" "echo-stream" "end-of-file"
+ "extended-char" "file-error" "file-stream" "fixnum"
+ "floating-point-inexact" "floating-point-invalid-operation"
+ "floating-point-overflow" "floating-point-underflow" "generic-function"
+ "hash-table" "integer" "keyword" "long-float" "method" "method-combination"
+ "number" "package" "package-error" "parse-error" "print-not-readable"
+ "program-error" "random-state" "ratio" "reader-error" "readtable" "real"
+ "restart" "sequence" "serious-condition" "short-float" "signed-byte"
+ "simple-array" "simple-base-string" "simple-bit-vector" "simple-condition"
+ "simple-error" "simple-string" "simple-type-error" "simple-vector"
+ "simple-warning" "single-float" "standard-char" "standard-class"
+ "standard-generic-function" "standard-method" "standard-object"
+ "storage-condition" "stream" "stream-error" "string-stream"
+ "structure-class" "structure-object" "style-warning" "symbol"
+ "synonym-stream" "two-way-stream" "type-error" "unbound-slot"
+ "unbound-variable" "undefined-function" "unsigned-byte" "warning"))
+
+(defvar cl-font-lock-built-in--symbols
+ '("compilation-speed" "compiler-macro" "debug" "declaration" "dynamic-extent"
+ "ftype" "ignorable" "ignore" "inline" "notinline" "optimize" "otherwise"
+ "safety" "satisfies" "space" "special" "speed" "structure" "type"))
+
+(defvar cl-font-lock--character-names
+ '("newline" "space" "rubout" "page" "tab" "backspace" "return" "linefeed"))
+
+(defvar cl-font-lock-built-in-keywords
+ (mapcar (lambda (s)
+ `(,(regexp-opt (symbol-value (car s)) 'symbols)
+ . ,(cdr s)))
+ '((cl-font-lock-built-in--functions . font-lock-function-name-face)
+ (cl-font-lock-built-in--variables . font-lock-variable-name-face)
+ (cl-font-lock-built-in--types . font-lock-type-face)
+ (cl-font-lock-built-in--symbols . font-lock-builtin-face)
+ (cl-font-lock--character-names . font-lock-variable-name-face))))
+
+;;;###autoload
+(define-minor-mode cl-font-lock-built-in-mode
+ "Highlight built-in functions, variables, and types in `lisp-mode'."
+ :global t
+ :group 'tools
+ (funcall
+ (if cl-font-lock-built-in-mode
+ #'font-lock-add-keywords
+ #'font-lock-remove-keywords)
+ 'lisp-mode
+ cl-font-lock-built-in-keywords))
+
+(provide 'cl-font-lock)
+
+;;; cl-font-lock.el ends here
diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el
index a393ca9be87..0f7c8c6f31a 100644
--- a/lisp/progmodes/cmacexp.el
+++ b/lisp/progmodes/cmacexp.el
@@ -1,7 +1,6 @@
-;;; cmacexp.el --- expand C macros in a region
+;;; cmacexp.el --- expand C macros in a region -*- lexical-binding: t -*-
-;; Copyright (C) 1992, 1994, 1996, 2000-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
;; Author: Francesco Potortì <pot@gnu.org>
;; Adapted-By: ESR
@@ -33,20 +32,20 @@
;; USAGE =============================================================
-;; In C mode C-C C-e is bound to c-macro-expand. The result of the
+;; In C mode C-c C-e is bound to `c-macro-expand'. The result of the
;; expansion is put in a separate buffer. A user option allows the
;; window displaying the buffer to be optimally sized.
;;
-;; When called with a C-u prefix, c-macro-expand replaces the selected
+;; When called with a C-u prefix, `c-macro-expand' replaces the selected
;; region with the expansion. Both the preprocessor name and the
-;; initial flag can be set by the user. If c-macro-prompt-flag is set
+;; initial flag can be set by the user. If `c-macro-prompt-flag' is set
;; to a non-nil value the user is offered to change the options to the
-;; preprocessor each time c-macro-expand is invoked. Preprocessor
-;; arguments default to the last ones entered. If c-macro-prompt-flag
+;; preprocessor each time `c-macro-expand' is invoked. Preprocessor
+;; arguments default to the last ones entered. If `c-macro-prompt-flag'
;; is nil, one must use M-x set-variable to set a different value for
-;; c-macro-cppflags.
+;; `c-macro-cppflags'.
-;; A c-macro-expansion function is provided for non-interactive use.
+;; A `c-macro-expansion' function is provided for non-interactive use.
;; INSTALLATION ======================================================
@@ -54,33 +53,28 @@
;; If you want the *Macroexpansion* window to be not higher than
;; necessary:
-;;(setq c-macro-shrink-window-flag t)
+;;
+;; (setq c-macro-shrink-window-flag t)
;;
;; If you use a preprocessor other than /lib/cpp (be careful to set a
;; -C option or equivalent in order to make the preprocessor not to
;; strip the comments):
-;;(setq c-macro-preprocessor "gpp -C")
+;;
+;; (setq c-macro-preprocessor "gpp -C")
;;
;; If you often use a particular set of flags:
-;;(setq c-macro-cppflags "-I /usr/include/local -DDEBUG"
+;;
+;; (setq c-macro-cppflags "-I /usr/include/local -DDEBUG"
;;
;; If you want the "Preprocessor arguments: " prompt:
-;;(setq c-macro-prompt-flag t)
+;;
+;; (setq c-macro-prompt-flag t)
;; BUG REPORTS =======================================================
;; Please report bugs, suggestions, complaints and so on to
;; bug-gnu-emacs@gnu.org and pot@gnu.org (Francesco Potortì).
-;; IMPROVEMENTS OVER emacs 18.xx cmacexp.el ==========================
-
-;; - A lot of user and programmer visible changes. See above.
-;; - #line directives are inserted, so __LINE__ and __FILE__ are
-;; correctly expanded. Works even with START inside a string, a
-;; comment or a region #ifdef'd away by cpp. cpp is invoked with -C,
-;; making comments visible in the expansion.
-;; - All work is done in core memory, no need for temporary files.
-
;; ACKNOWLEDGMENTS ===================================================
;; A lot of thanks to Don Maszle who did a great work of testing, bug
@@ -96,25 +90,19 @@
(require 'cc-mode)
-(provide 'cmacexp)
-
(defvar msdos-shells)
-
(defgroup c-macro nil
"Expand C macros in a region."
:group 'c)
-
(defcustom c-macro-shrink-window-flag nil
"Non-nil means shrink the *Macroexpansion* window to fit its contents."
- :type 'boolean
- :group 'c-macro)
+ :type 'boolean)
(defcustom c-macro-prompt-flag nil
"Non-nil makes `c-macro-expand' prompt for preprocessor arguments."
- :type 'boolean
- :group 'c-macro)
+ :type 'boolean)
(defcustom c-macro-preprocessor
(cond ;; Solaris has it in an unusual place.
@@ -138,13 +126,11 @@
If you change this, be sure to preserve the `-C' (don't strip comments)
option, or to set an equivalent one."
- :type 'string
- :group 'c-macro)
+ :type 'string)
(defcustom c-macro-cppflags ""
"Preprocessor flags used by `c-macro-expand'."
- :type 'string
- :group 'c-macro)
+ :type 'string)
(defconst c-macro-buffer-name "*Macroexpansion*")
@@ -405,4 +391,6 @@ Optional arg DISPLAY non-nil means show messages in the echo area."
;; Cleanup.
(kill-buffer outbuf))))
+(provide 'cmacexp)
+
;;; cmacexp.el ends here
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index c687a664608..1fb6124ab56 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -33,6 +33,7 @@
(eval-when-compile (require 'cl-lib))
(require 'tool-bar)
(require 'comint)
+(require 'text-property-search)
(defgroup compilation nil
"Run compiler as inferior of Emacs, parse error messages."
@@ -64,7 +65,8 @@ If nil, use Emacs default."
If the replacement is nil, the file will not be considered an
error after all. If not nil, it should be a regexp replacement
string."
- :type '(repeat (list regexp string))
+ :type '(repeat (list regexp (choice (const :tag "No replacement" nil)
+ string)))
:version "27.1")
(defvar compilation-filter-hook nil
@@ -171,6 +173,7 @@ and a string describing how the process finished.")
;; emacs -batch -l compile-tests.el -f ert-run-tests-batch-and-exit
(defvar compilation-error-regexp-alist-alist
+ (eval-when-compile
`((absoft
"^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\
of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
@@ -212,18 +215,14 @@ 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)
-
(msft
;; Must be before edg-1, so that MSVC's longer messages are
;; considered before EDG.
;; The message may be a "warning", "error", or "fatal error" with
;; an error code, or "see declaration of" without an error code.
- "^ *\\([0-9]+>\\)?\\(\\(?:[a-zA-Z]:\\)?[^ :(\t\n][^:(\t\n]*\\)(\\([0-9]+\\)) ?\
+ "^ *\\([0-9]+>\\)?\\(\\(?:[a-zA-Z]:\\)?[^ :(\t\n][^:(\t\n]*\\)(\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?) ?\
: \\(?:see declaration\\|\\(?:warnin\\(g\\)\\|[a-z ]+\\) C[0-9]+:\\)"
- 2 3 nil (4))
+ 2 3 4 (5))
(edg-1
"^\\([^ \n]+\\)(\\([0-9]+\\)): \\(?:error\\|warnin\\(g\\)\\|remar\\(k\\)\\)"
@@ -243,11 +242,20 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
;; GradleStyleMessagerRenderer.kt in kotlin sources, see
;; https://youtrack.jetbrains.com/issue/KT-34683).
(gradle-kotlin
- ,(concat
- "^\\(?:\\(w\\)\\|.\\): *" ;type
- "\\(\\(?:[A-Za-z]:\\)?[^:\n]+\\): *" ;file
- "(\\([0-9]+\\), *\\([0-9]+\\))") ;line, column
- 2 3 4 (1))
+ ,(rx bol
+ (| (group "w") ; 1: warning
+ (group (in "iv")) ; 2: info
+ "e") ; error
+ ": "
+ (group ; 3: file
+ (? (in "A-Za-z") ":")
+ (+ (not (in "\n:"))))
+ ": ("
+ (group (+ digit)) ; 4: line
+ ", "
+ (group (+ digit)) ; 5: column
+ "): ")
+ 3 4 5 (1 . 2))
(iar
"^\"\\(.*\\)\",\\([0-9]+\\)\\s-+\\(?:Error\\|Warnin\\(g\\)\\)\\[[0-9]+\\]:"
@@ -265,6 +273,23 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(java
"^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1))
+ (javac
+ ,(rx bol
+ (group ; file
+ (? (in "A-Za-z") ":")
+ (+ (not (in "\n:"))))
+ ":"
+ (group (+ (in "0-9"))) ; line number
+ ": "
+ (? (group "warning: ")) ; type (optional)
+ (* nonl) "\n" ; message
+ (* nonl) "\n" ; source line containing error
+ (* " ") "^" ; caret line; ^ marks error
+ eol)
+ 1 2
+ ,#'current-column
+ (3))
+
(jikes-file
"^\\(?:Found\\|Issued\\) .* compiling \"\\(.+\\)\":$" 1 nil nil 0)
@@ -302,8 +327,8 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(gcc-include
"^\\(?:In file included \\| \\|\t\\)from \
\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\):\
-\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?"
- 1 2 3 (4 . 5))
+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\(?:\\([:,]\\|$\\)\\)?"
+ 1 2 3 (nil . 4))
(ruby-Test::Unit
"^ [[ ]?\\([^ (].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:in " 1 2)
@@ -315,48 +340,44 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
": \\*\\*\\* \\[\\(\\(.+?\\):\\([0-9]+\\): .+\\)\\]" 2 3 nil 0 1)
(gnu
- ;; The first line matches the program name for
-
- ;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE
-
- ;; format, which is used for non-interactive programs other than
- ;; compilers (e.g. the "jade:" entry in compilation.txt).
-
- ;; This first line makes things ambiguous with output such as
- ;; "foo:344:50:blabla" since the "foo" part can match this first
- ;; line (in which case the file name as "344"). To avoid this,
- ;; the second line disallows filenames exclusively composed of
- ;; digits.
-
- ;; Similarly, we get lots of false positives with messages including
- ;; times of the form "HH:MM:SS" where MM is taken as a line number, so
- ;; the last line tries to rule out message where the info after the
- ;; line number starts with "SS". --Stef
-
- ;; 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 -, or a colon followed by a space.
- ;;
- ;; The "in \\|from " exception was added to handle messages from Ruby.
,(rx
bol
+ ;; Match an optional program name in the format
+ ;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE
+ ;; which is used for non-interactive programs other than
+ ;; compilers (e.g. the "jade:" entry in compilation.txt).
(? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?")
+ ;; FIXME: This pattern was added for handling messages
+ ;; from Ruby, but it is unclear whether it is actually
+ ;; used since the gcc-include rule above seems to cover
+ ;; it.
(regexp "[ \t]+\\(?:in \\|from\\)")))
- (group-n 1 (: (regexp "[0-9]*[^0-9\n]")
- (*? (| (regexp "[^\n :]")
- (regexp " [^-/\n]")
- (regexp ":[^ \n]")))))
+
+ ;; File name group.
+ (group-n 1
+ ;; Avoid matching the file name as a program in the pattern
+ ;; above by disallow file names entirely composed of digits.
+ (: (regexp "[0-9]*[^0-9\n]")
+ ;; This rule 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 -, or a
+ ;; colon followed by a space.
+ (*? (| (regexp "[^\n :]")
+ (regexp " [^-/\n]")
+ (regexp ":[^ \n]")))))
(regexp ": ?")
+
+ ;; Line number group.
(group-n 2 (regexp "[0-9]+"))
(? (| (: "-"
- (group-n 4 (regexp "[0-9]+"))
- (? "." (group-n 5 (regexp "[0-9]+"))))
+ (group-n 4 (regexp "[0-9]+")) ; ending line
+ (? "." (group-n 5 (regexp "[0-9]+")))) ; ending column
(: (in ".:")
- (group-n 3 (regexp "[0-9]+"))
+ (group-n 3 (regexp "[0-9]+")) ; starting column
(? "-"
- (? (group-n 4 (regexp "[0-9]+")) ".")
- (group-n 5 (regexp "[0-9]+"))))))
+ (? (group-n 4 (regexp "[0-9]+")) ".") ; ending line
+ (group-n 5 (regexp "[0-9]+")))))) ; ending column
":"
(| (: (* " ")
(group-n 6 (| "FutureWarning"
@@ -373,12 +394,28 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(regexp "[Nn]ote"))))
(: (* " ")
(regexp "[Ee]rror"))
+
+ ;; Avoid matching time stamps on the form "HH:MM:SS" where
+ ;; MM is interpreted as a line number by trying to rule out
+ ;; messages where the text after the line number starts with
+ ;; a 2-digit number.
(: (regexp "[0-9]?")
(| (regexp "[^0-9\n]")
eol))
(regexp "[0-9][0-9][0-9]")))
1 (2 . 4) (3 . 5) (6 . 7))
+ (cucumber
+ ,(rx (| (: bol
+ (| (: "cucumber" (? " -p " (+ (not space))))
+ " "))
+ "#")
+ " "
+ (group (not "(") (* nonl)) ; file
+ ":"
+ (group (in "1-9") (* (in "0-9")))) ; line
+ 1 2)
+
(lcc
"^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)"
2 3 4 (1))
@@ -435,6 +472,9 @@ during global destruction\\.$\\)" 1 2)
\\([0-9]+\\) of file://\\(.+\\)"
4 2 3 (1))
+ (shellcheck
+ "^In \\(.+\\) line \\([0-9]+\\):" 1 2)
+
(sparc-pascal-file
"^\\w\\w\\w \\w\\w\\w +[0-3]?[0-9] +[0-2][0-9]:[0-5][0-9]:[0-5][0-9]\
[12][09][0-9][0-9] +\\(.*\\):$"
@@ -576,7 +616,7 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
;; we do not know what lines will follow.
(guile-file "^In \\(.+\\..+\\):\n" 1 nil nil 0)
(guile-line "^ *\\([0-9]+\\): *\\([0-9]+\\)" nil 1 2)
- )
+ ))
"Alist of values for `compilation-error-regexp-alist'.")
(defcustom compilation-error-regexp-alist
@@ -646,6 +686,16 @@ matched file names, and weeding out false positives."
:link `(file-link :tag "example file"
,(expand-file-name "compilation.txt" data-directory)))
+(defvar compilation-error-case-fold-search nil
+ "If non-nil, use case-insensitive matching of compilation errors
+by the regexps of `compilation-error-regexp-alist' and
+`compilation-error-regexp-alist-alist'.
+If nil, matching is case-sensitive.
+
+This variable should only be set for backward compatibility as a temporary
+measure. The proper solution is to use a regexp that matches the
+messages without case-folding.")
+
;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp)
(defvar compilation-directory nil
"Directory to restore to when doing `recompile'.")
@@ -716,6 +766,18 @@ variable, and you might not notice. Therefore, `compile-command'
is considered unsafe if this variable is nil."
:type 'boolean)
+(defcustom compilation-search-all-directories t
+ "Whether further upward directories should be used when searching a file.
+When doing a parallel build, several files from different
+directories can be compiled at the same time. This makes it
+difficult to determine the base directory for a relative file
+name in a compiler error or warning. If this variable is
+non-nil, instead of just relying on the previous directory change
+in the compilation buffer, all other directories further upwards
+will be used as well."
+ :type 'boolean
+ :version "28.1")
+
;;;###autoload
(defcustom compilation-ask-about-save t
"Non-nil means \\[compile] asks which buffers to save before compiling.
@@ -755,7 +817,7 @@ You might also use mode hooks to specify it in certain modes, like this:
(lambda ()
(unless (or (file-exists-p \"makefile\")
(file-exists-p \"Makefile\"))
- (set (make-local-variable \\='compile-command)
+ (setq-local compile-command
(concat \"make -k \"
(if buffer-file-name
(shell-quote-argument
@@ -892,13 +954,11 @@ Faces `compilation-error-face', `compilation-warning-face',
:type 'boolean
:version "23.1")
-(defvar compilation-auto-jump-to-next nil
+(defvar-local compilation-auto-jump-to-next nil
"If non-nil, automatically jump to the next error encountered.")
-(make-variable-buffer-local 'compilation-auto-jump-to-next)
-;; (defvar compilation-buffer-modtime nil
+;; (defvar-local 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.")
@@ -1022,17 +1082,16 @@ from a different message."
(:constructor nil)
(:copier nil)
;; (:type list) ;Old representation.
- (:constructor compilation--make-message (loc type end-loc))
+ (:constructor compilation--make-message (loc type end-loc rule))
(:conc-name compilation--message->))
- loc type end-loc)
+ loc type end-loc rule)
-(defvar compilation--previous-directory-cache nil
+(defvar-local 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
@@ -1097,7 +1156,7 @@ POS and RES.")
(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)
+ compilation-message ,(compilation--make-message nil 0 nil nil)
mouse-face highlight
keymap compilation-button-map
help-echo "mouse-2: visit destination directory")))
@@ -1124,18 +1183,20 @@ POS and RES.")
(setcdr l1 (cons (list ,key) l2)))))))
(defun compilation-auto-jump (buffer pos)
- (with-current-buffer buffer
- (goto-char pos)
- (let ((win (get-buffer-window buffer 0)))
- (if win (set-window-point win pos)))
- (if compilation-auto-jump-to-first-error
- (compile-goto-error))))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (goto-char pos)
+ (let ((win (get-buffer-window buffer 0)))
+ (if win (set-window-point win pos)))
+ (if compilation-auto-jump-to-first-error
+ (compile-goto-error)))))
;; This function is the central driver, called when font-locking to gather
;; all information needed to later jump to corresponding source code.
;; 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)
+(defun compilation-error-properties (file line end-line col end-col type fmt
+ rule)
(unless (text-property-not-all (match-beginning 0) (point)
'compilation-message nil)
(if file
@@ -1188,23 +1249,26 @@ POS and RES.")
(setq col (match-string-no-properties col))
(string-to-number col))))
(setq end-col
- (or (if (functionp end-col) (funcall end-col)
- (and end-col
- (setq end-col (match-string-no-properties end-col))
- (- (string-to-number end-col) -1)))
- (and end-line -1)))
+ (let ((ec (if (functionp end-col)
+ (funcall end-col)
+ (and end-col (match-beginning end-col)
+ (string-to-number
+ (match-string-no-properties end-col))))))
+ (if ec
+ (1+ ec) ; Add one to get an exclusive upper bound.
+ (and end-line -1))))
(if (consp type) ; not a static type, check what it is.
(setq type (or (and (car type) (match-end (car type)) 1)
(and (cdr type) (match-end (cdr type)) 0)
2)))
;; Remove matches like /bin/sh and do other file name transforms.
(save-match-data
- (let ((file-name
- (and (consp file)
- (not (bufferp (car file)))
- (if (cdr file)
- (expand-file-name (car file) (cdr file))
- (car file)))))
+ (when-let ((file-name
+ (and (consp file)
+ (not (bufferp (car file)))
+ (if (cdr file)
+ (expand-file-name (car file) (cdr file))
+ (car file)))))
(cl-loop for (regexp replacement)
in compilation-transform-file-match-alist
when (string-match regexp file-name)
@@ -1223,7 +1287,7 @@ POS and RES.")
(current-buffer) (match-beginning 0)))
(compilation-internal-error-properties
- file line end-line col end-col type fmt))))
+ file line end-line col end-col type fmt rule))))
(defun compilation-beginning-of-line (&optional n)
"Like `beginning-of-line', but accounts for lines hidden by `selective-display'."
@@ -1246,13 +1310,15 @@ just char-counts."
(let ((tab-width 8)) (move-to-column (max col 0)))
(goto-char (min (+ (line-beginning-position) col) (line-end-position)))))
-(defun compilation-internal-error-properties (file line end-line col end-col type fmts)
+(defun compilation-internal-error-properties (file line end-line col end-col
+ type fmts rule)
"Get the meta-info that will be added as text-properties.
LINE, END-LINE, COL, END-COL are integers or nil.
TYPE can be 0, 1, or 2, meaning error, warning, or just info.
FILE should be (FILENAME) or (RELATIVE-FILENAME . DIRNAME) or (BUFFER) or
nil.
FMTS is a list of format specs for transforming the file name.
+RULE is the name (symbol) of the rule used or nil if anonymous.
(See `compilation-error-regexp-alist'.)"
(unless file (setq file '("*unknown*")))
(let* ((file-struct (compilation-get-file-structure file fmts))
@@ -1339,7 +1405,7 @@ FMTS is a list of format specs for transforming the file name.
;; Must start with face
`(font-lock-face ,compilation-message-face
- compilation-message ,(compilation--make-message loc type end-loc)
+ compilation-message ,(compilation--make-message loc type end-loc rule)
help-echo ,(if col
"mouse-2: visit this file, line and column"
(if line
@@ -1431,101 +1497,111 @@ This updates the appropriate variable used by the mode-line."
"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)))
-
- (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)
- (let ((this-type (if (consp type)
- (compilation-type type)
- (or type 2))))
- (compilation--note-type this-type)
-
- (compilation--put-prop
- file 'font-lock-face
- (symbol-value (aref [compilation-info-face
- compilation-warning-face
- compilation-error-face]
- this-type)))))
-
- (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)
-
- ;; Obey HIGHLIGHT.
- (dolist (extra-item (nthcdr 6 item))
- (let ((mn (pop extra-item)))
- (when (match-beginning mn)
- (let ((face (eval (car extra-item))))
- (cond
- ((null face))
- ((or (symbolp face) (stringp face))
- (put-text-property
- (match-beginning mn) (match-end mn)
- 'font-lock-face face))
- ((and (listp face)
- (eq (car face) 'face)
- (or (symbolp (cadr face))
- (stringp (cadr face))))
- (compilation--put-prop mn 'font-lock-face (cadr face))
- (add-text-properties
- (match-beginning mn) (match-end mn)
- (nthcdr 2 face)))
- (t
- (error "Don't know how to handle face %S"
- face)))))))
- (let ((mn (or (nth 5 item) 0)))
- (when compilation-debug
+ (let ((case-fold-search compilation-error-case-fold-search)
+ (omake-included (memq 'omake compilation-error-regexp-alist)))
+ (dolist (rule-item (or rules compilation-error-regexp-alist))
+ (let* ((item
+ (if (symbolp rule-item)
+ (cdr (assq rule-item compilation-error-regexp-alist-alist))
+ rule-item))
+ (pat (car item))
+ (file (nth 1 item))
+ (line (nth 2 item))
+ (col (nth 3 item))
+ (type (nth 4 item))
+ (rule (and (symbolp rule-item) rule-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 omake-included) nil)
+ ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat)
+ nil) ;; Not anchored or anchored but already allows empty spaces.
+ (t (setq pat (concat "^\\(?: \\)?" (substring pat 1)))))
+
+ (if (and (consp file) (not (functionp file)))
+ (setq fmt (cdr file)
+ file (car file)))
+ (if (and (consp line) (not (functionp line)))
+ (setq end-line (cdr line)
+ line (car line)))
+ (if (and (consp col) (not (functionp col)))
+ (setq end-col (cdr col)
+ col (car col)))
+
+ (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 rule))
+
+ (when file
+ (let ((this-type (if (consp type)
+ (compilation-type type)
+ (or type 2))))
+ (compilation--note-type this-type)
+
+ (compilation--put-prop
+ file 'font-lock-face
+ (symbol-value (aref [compilation-info-face
+ compilation-warning-face
+ compilation-error-face]
+ this-type)))))
+
+ (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)
+
+ ;; Obey HIGHLIGHT.
+ (dolist (extra-item (nthcdr 6 item))
+ (let ((mn (pop extra-item)))
+ (when (match-beginning mn)
+ (let ((face (eval (car extra-item))))
+ (cond
+ ((null face))
+ ((or (symbolp face) (stringp face))
+ (put-text-property
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face face))
+ ((and (listp face)
+ (eq (car face) 'face)
+ (or (symbolp (cadr face))
+ (stringp (cadr face))))
+ (compilation--put-prop mn 'font-lock-face (cadr face))
+ (add-text-properties
+ (match-beginning mn) (match-end mn)
+ (nthcdr 2 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 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)
+ (match-beginning mn) (match-end mn)
+ 'font-lock-face (cadr props)))))))))
+
+(defvar-local compilation--parsed -1)
(defun compilation--ensure-parse (limit)
"Make sure the text has been parsed up to LIMIT."
@@ -1537,7 +1613,14 @@ to `compilation-error-regexp-alist' if RULES is nil."
;; 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)))
+ (setq compilation--parsed
+ (set-marker (make-marker)
+ (save-excursion
+ (goto-char (point-min))
+ (text-property-search-forward 'compilation-header-end)
+ ;; If we have no end marker, this will be
+ ;; `point-min' still.
+ (point)))))
(when (< compilation--parsed limit)
(let ((start (max compilation--parsed (point-min))))
(move-marker compilation--parsed limit)
@@ -1765,14 +1848,13 @@ Returns the compilation buffer created."
;; default-directory' can't be used reliably for that because it may be
;; affected by the special handling of "cd ...;".
;; NB: must be done after (funcall mode) as that resets local variables
- (set (make-local-variable 'compilation-directory) thisdir)
- (set (make-local-variable 'compilation-environment) thisenv)
+ (setq-local compilation-directory thisdir)
+ (setq-local compilation-environment thisenv)
(if highlight-regexp
- (set (make-local-variable 'compilation-highlight-regexp)
- highlight-regexp))
+ (setq-local compilation-highlight-regexp highlight-regexp))
(if (or compilation-auto-jump-to-first-error
(eq compilation-scroll-output 'first-error))
- (set (make-local-variable 'compilation-auto-jump-to-next) t))
+ (setq-local compilation-auto-jump-to-next t))
;; Output a mode setter, for saving and later reloading this buffer.
(insert "-*- mode: " name-of-mode
"; default-directory: "
@@ -1782,6 +1864,9 @@ Returns the compilation buffer created."
mode-name
(substring (current-time-string) 0 19))
command "\n")
+ ;; Mark the end of the header so that we don't interpret
+ ;; anything in it as an error.
+ (put-text-property (1- (point)) (point) 'compilation-header-end t)
(setq thisdir default-directory))
(set-buffer-modified-p nil))
;; Pop up the compilation buffer.
@@ -1791,13 +1876,13 @@ Returns the compilation buffer created."
(let ((process-environment
(append
compilation-environment
- (comint-term-environment)
+ (and (derived-mode-p 'comint-mode)
+ (comint-term-environment))
(list (format "INSIDE_EMACS=%s,compile" emacs-version))
(copy-sequence process-environment))))
- (set (make-local-variable 'compilation-arguments)
- (list command mode name-function highlight-regexp))
- (set (make-local-variable 'revert-buffer-function)
- 'compilation-revert-buffer)
+ (setq-local compilation-arguments
+ (list command mode name-function highlight-regexp))
+ (setq-local revert-buffer-function 'compilation-revert-buffer)
(and outwin
;; Forcing the window-start overrides the usual redisplay
;; feature of bringing point into view, so setting the
@@ -1988,6 +2073,10 @@ Returns the compilation buffer created."
(define-key map "\M-p" 'compilation-previous-error)
(define-key map "\M-{" 'compilation-previous-file)
(define-key map "\M-}" 'compilation-next-file)
+ (define-key map "n" 'next-error-no-select)
+ (define-key map "p" 'previous-error-no-select)
+ (define-key map "l" 'recenter-current-error)
+
(define-key map "g" 'recompile) ; revert
;; Set up the menu-bar
(define-key map [menu-bar compilation]
@@ -2033,6 +2122,8 @@ Returns the compilation buffer created."
(define-key map "\M-p" 'compilation-previous-error)
(define-key map "\M-{" 'compilation-previous-file)
(define-key map "\M-}" 'compilation-next-file)
+ (define-key map "n" 'next-error-no-select)
+ (define-key map "p" 'previous-error-no-select)
(define-key map "\t" 'compilation-next-error)
(define-key map [backtab] 'compilation-previous-error)
(define-key map "g" 'recompile) ; revert
@@ -2056,8 +2147,7 @@ Returns the compilation buffer created."
'(menu-item "Compile..." compile
:help "Compile the program including the current buffer. Default: run `make'"))
map)
- "Keymap for compilation log buffers.
-`compilation-minor-mode-map' is a parent of this.")
+ "Keymap for compilation log buffers.")
(defvar compilation-mode-tool-bar-map
;; When bootstrapping, tool-bar-map is not properly initialized yet,
@@ -2101,20 +2191,19 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see).
(kill-all-local-variables)
(use-local-map compilation-mode-map)
;; 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-local window-point-insertion-type t)
+ (setq-local tool-bar-map compilation-mode-tool-bar-map)
(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)
+ (setq-local page-delimiter compilation-page-delimiter)
+ ;; (setq-local compilation-buffer-modtime nil)
(compilation-setup)
;; Turn off deferred fontifications in the compilation buffer, if
;; the user turned them on globally. This is because idle timers
;; aren't re-run after receiving input from a subprocess, so the
;; buffer is left unfontified after the compilation exits, until
;; some other input event happens.
- (set (make-local-variable 'jit-lock-defer-time) nil)
+ (setq-local jit-lock-defer-time nil)
(setq buffer-read-only t)
(run-mode-hooks 'compilation-mode-hook))
@@ -2184,7 +2273,7 @@ Optional argument MINOR indicates this is called from
(setq-local compilation-num-errors-found 0)
(setq-local compilation-num-warnings-found 0)
(setq-local compilation-num-infos-found 0)
- (set (make-local-variable 'overlay-arrow-string) "")
+ (setq-local overlay-arrow-string "")
(setq next-error-overlay-arrow-position nil)
(add-hook 'kill-buffer-hook
(lambda () (setq next-error-overlay-arrow-position nil)) nil t)
@@ -2192,10 +2281,10 @@ Optional argument MINOR indicates this is called from
;; with the next-error function in simple.el, and it's only
;; coincidentally named similarly to compilation-next-error.
(setq next-error-function 'compilation-next-error-function)
- (set (make-local-variable 'comint-file-name-prefix)
- (or (file-remote-p default-directory) ""))
- (set (make-local-variable 'compilation-locs)
- (make-hash-table :test 'equal :weakness 'value))
+ (setq-local comint-file-name-prefix
+ (or (file-remote-p default-directory) ""))
+ (setq-local compilation-locs
+ (make-hash-table :test 'equal :weakness 'value))
;; 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.
@@ -2333,8 +2422,7 @@ and runs `compilation-filter-hook'."
(set-marker (process-mark proc) (point))
;; Update the number of errors in compilation-mode-line-errors
(compilation--ensure-parse (point))
- ;; (set (make-local-variable 'compilation-buffer-modtime)
- ;; (current-time))
+ ;; (setq-local compilation-buffer-modtime (current-time))
(run-hooks 'compilation-filter-hook))
(goto-char pos)
(narrow-to-region min max)
@@ -2342,12 +2430,10 @@ and runs `compilation-filter-hook'."
(set-marker min nil)
(set-marker max nil))))))
-;;; test if a buffer is a compilation buffer, assuming we're in the buffer
(defsubst compilation-buffer-internal-p ()
"Test if inside a compilation buffer."
(local-variable-p 'compilation-locs))
-;;; test if a buffer is a compilation buffer, using compilation-buffer-internal-p
(defsubst compilation-buffer-p (buffer)
"Test if BUFFER is a compilation buffer."
(with-current-buffer buffer
@@ -2388,12 +2474,9 @@ and runs `compilation-filter-hook'."
&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))))))
+ (or limit (point-max)))))
(and (or (not (setq res (next-single-property-change
position prop object limit)))
(eq res limit))
@@ -2594,9 +2677,8 @@ This is the value of `next-error-function' in Compilation buffers."
(compilation--loc->marker end-loc))
(setf (compilation--loc->visited loc) t)))
-(defvar compilation-gcpro nil
+(defvar-local compilation-gcpro nil
"Internal variable used to keep some values from being GC'd.")
-(make-variable-buffer-local 'compilation-gcpro)
(defun compilation-fake-loc (marker file &optional line col)
"Preassociate MARKER with FILE.
@@ -2766,8 +2848,9 @@ and overlay is highlighted between MK and END-MK."
(when (and (not pre-existing) w)
(compilation-set-window-height w))
- (if from-compilation-buffer
- ;; If the compilation buffer window was selected,
+ (if (or from-compilation-buffer
+ (eq w (selected-window)))
+ ;; If the compilation buffer window is selected,
;; keep the compilation buffer in this window;
;; display the source in another window.
(let ((pop-up-windows t))
@@ -2873,6 +2956,28 @@ attempts to find a file whose name is produced by (format FMT FILENAME)."
(find-file-noselect name))
fmts (cdr fmts)))
(setq dirs (cdr dirs)))
+ ;; If we haven't found it, this might be a parallel build.
+ ;; Search the directories further up the buffer.
+ (when (and (null buffer)
+ compilation-search-all-directories)
+ (with-current-buffer (marker-buffer marker)
+ (save-excursion
+ (goto-char (marker-position marker))
+ (when-let ((prev (compilation--previous-directory (point))))
+ (goto-char prev))
+ (setq dirs (cdr (or (get-text-property
+ (1- (point)) 'compilation-directory)
+ (get-text-property
+ (point) 'compilation-directory))))))
+ (while (and dirs (null buffer))
+ (setq thisdir (car dirs)
+ fmts formats)
+ (while (and fmts (null buffer))
+ (setq name (expand-file-name (format (car fmts) filename) thisdir)
+ buffer (and (file-exists-p name)
+ (find-file-noselect name))
+ fmts (cdr fmts)))
+ (setq dirs (cdr dirs))))
(while (null buffer) ;Repeat until the user selects an existing file.
;; The file doesn't exist. Ask the user where to find it.
(save-excursion ;This save-excursion is probably not right.
@@ -2884,11 +2989,8 @@ attempts to find a file whose name is produced by (format FMT FILENAME)."
(and w (progn (compilation-set-window w marker)
(compilation-set-overlay-arrow w))))
(let* ((name (read-file-name
- (format "Find this %s in%s: "
- compilation-error
- (if filename
- (format " (default %s)" filename)
- ""))
+ (format-prompt "Find this %s in"
+ filename compilation-error)
spec-dir filename t nil
;; The predicate below is fine when called from
;; minibuffer-complete-and-exit, but it's too
@@ -3039,7 +3141,7 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given."
;; 'font-lock-face 'font-lock-warning-face)
(put-text-property src (line-end-position)
'compilation-message
- (compilation--make-message loc 2 nil)))))))
+ (compilation--make-message loc 2 nil nil)))))))
(goto-char limit)
nil)
@@ -3074,9 +3176,9 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given."
;; Again, since this command is used in buffers that contain several
;; compilations, to set the beginning of "this compilation", it's a good
;; place to reset compilation-auto-jump-to-next.
- (set (make-local-variable 'compilation-auto-jump-to-next)
- (or compilation-auto-jump-to-first-error
- (eq compilation-scroll-output 'first-error))))
+ (setq-local compilation-auto-jump-to-next
+ (or compilation-auto-jump-to-first-error
+ (eq compilation-scroll-output 'first-error))))
(provide 'compile)
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 2df3ed4c567..3370df64919 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -7,6 +7,7 @@
;; Jonathan Rockway <jon@jrock.us>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: languages, Perl
+;; Package-Requires: ((emacs "26.1"))
;; This file is part of GNU Emacs.
@@ -32,7 +33,7 @@
;; support.
;; The latest version is available from
-;; http://github.com/jrockway/cperl-mode
+;; https://github.com/jrockway/cperl-mode
;;
;; (perhaps in the moosex-declare branch)
@@ -47,10 +48,12 @@
;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<<
;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<
;; `cperl-praise', `cperl-speed'. <<<<<<
+;;
+;; Or search for "Short extra-docs" further down in this file for
+;; details on how to use `cperl-mode' instead of `perl-mode' and lots
+;; of other details.
;; The mode information (on C-h m) provides some customization help.
-;; If you use font-lock feature of this mode, it is advisable to use
-;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock.
;; Faces used now: three faces for first-class and second-class keywords
;; and control flow words, one for each: comments, string, labels,
@@ -66,29 +69,36 @@
;; (define-key global-map [M-S-down-mouse-3] 'imenu)
-;;;; Font lock bugs as of v4.32:
-
-;; The following kinds of Perl code erroneously start strings:
-;; \$` \$' \$"
-;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../
-;; likewise with m, tr, y, q, qX instead of s
-
;;; Code:
+;;; Compatibility with older versions (for publishing on ELPA)
+;; The following helpers allow cperl-mode.el to work with older
+;; versions of Emacs.
+;;
+;; Whenever the minimum version is bumped (see "Package-Requires"
+;; above), please eliminate the corresponding compatibility-helpers.
+;; Whenever you create a new compatibility-helper, please add it here.
+
+;; Available in Emacs 27.1: time-convert
+(defalias 'cperl--time-convert
+ (if (fboundp 'time-convert) 'time-convert
+ 'encode-time))
+
+;; Available in Emacs 28: format-prompt
+(defalias 'cperl--format-prompt
+ (if (fboundp 'format-prompt) 'format-prompt
+ (lambda (msg default)
+ (if default (format "%s (default %s): " msg default)
+ (concat msg ": ")))))
+
(eval-when-compile (require 'cl-lib))
+(require 'facemenu)
(defvar msb-menu-cond)
(defvar gud-perldb-history)
(defvar vc-rcs-header)
(defvar vc-sccs-header)
-(defmacro cperl-force-face (arg descr) ; Takes unquoted arg
- `(progn
- (or (facep (quote ,arg))
- (make-face ,arg))
- (or (boundp (quote ,arg)) ; We use unquoted variants too
- (defvar ,arg (quote ,arg) ,descr))))
-
(defun cperl-choose-color (&rest list)
(let (answer)
(while list
@@ -223,7 +233,9 @@ Versions 5.2 ... 5.20 behaved as if this were nil."
:group 'cperl-indentation-details)
(defcustom cperl-indent-subs-specially t
- "Non-nil means indent subs that are inside other blocks (hash values, for example) relative to the beginning of the \"sub\" keyword, rather than relative to the statement that contains the declaration."
+ "If non-nil, indent subs inside other blocks relative to \"sub\" keyword.
+Otherwise, indent them relative to statement that contains the declaration.
+This applies to, for example, hash values."
:type 'boolean
:group 'cperl-indentation-details)
@@ -391,7 +403,7 @@ Font for POD headers."
:version "21.1"
:group 'cperl-faces)
-(defcustom cperl-pod-here-fontify '(featurep 'font-lock)
+(defcustom cperl-pod-here-fontify t
"Not-nil after evaluation means to highlight POD and here-docs sections."
:type 'boolean
:group 'cperl-faces)
@@ -429,12 +441,6 @@ after reload."
:type 'boolean
:group 'cperl-speed)
-(defcustom cperl-imenu-addback nil
- "Not-nil means add backreferences to generated `imenu's.
-May require patched `imenu' and `imenu-go'. Obsolete."
- :type 'boolean
- :group 'cperl-help-system)
-
(defcustom cperl-max-help-size 66
"Non-nil means shrink-wrapping of info-buffer allowed up to these percents."
:type '(choice integer (const nil))
@@ -451,8 +457,7 @@ Older version of this page was called `perl5', newer `perl'."
:type 'string
:group 'cperl-help-system)
-(defcustom cperl-use-syntax-table-text-property
- (boundp 'parse-sexp-lookup-properties)
+(defcustom cperl-use-syntax-table-text-property t
"Non-nil means CPerl sets up and uses `syntax-table' text property."
:type 'boolean
:group 'cperl-speed)
@@ -535,8 +540,7 @@ One should tune up `cperl-close-paren-offset' as well."
:type 'boolean
:group 'cperl-indentation-details)
-(defcustom cperl-syntaxify-by-font-lock
- (boundp 'parse-sexp-lookup-properties)
+(defcustom cperl-syntaxify-by-font-lock t
"Non-nil means that CPerl uses the `font-lock' routines for syntaxification."
:type '(choice (const message) boolean)
:group 'cperl-speed)
@@ -650,8 +654,8 @@ Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing.
Switch auto-help on/off with Perl/Tools/Auto-help.
-Though with contemporary Emaxen CPerl mode should maintain the correct
-parsing of Perl even when editing, sometimes it may be lost. Fix this by
+Though CPerl mode should maintain the correct parsing of Perl even when
+editing, sometimes it may be lost. Fix this by
\\[normal-mode]
@@ -665,69 +669,22 @@ micro-docs on what I know about CPerl problems.")
(defvar cperl-problems 'please-ignore-this-line
"Description of problems in CPerl mode.
-Some faces will not be shown on some versions of Emacs unless you
-install choose-color.el, available from
- http://ilyaz.org/software/emacs
-
`fill-paragraph' on a comment may leave the point behind the
paragraph. It also triggers a bug in some versions of Emacs (CPerl tries
-to detect it and bulk out).
-
-See documentation of a variable `cperl-problems-old-emaxen' for the
-problems which disappear if you upgrade Emacs to a reasonably new
-version (20.3 for Emacs).")
+to detect it and bulk out).")
(defvar cperl-problems-old-emaxen 'please-ignore-this-line
- "Description of problems in CPerl mode specific for older Emacs versions.
-
-Emacs had a _very_ restricted syntax parsing engine until version
-20.1. Most problems below are corrected starting from this version of
-Emacs, and all of them should be fixed in version 20.3. (Or apply
-patches to Emacs 19.33/34 - see tips.)
-
-Note that even with newer Emacsen in some very rare cases the details
-of interaction of `font-lock' and syntaxification may be not cleaned
-up yet. You may get slightly different colors basing on the order of
-fontification and syntaxification. Say, the initial faces is correct,
-but editing the buffer breaks this.
-
-Even with older Emacsen CPerl mode tries to corrects some Emacs
-misunderstandings, however, for efficiency reasons the degree of
-correction is different for different operations. The partially
-corrected problems are: POD sections, here-documents, regexps. The
-operations are: highlighting, indentation, electric keywords, electric
-braces.
-
-This may be confusing, since the regexp s#//#/#; may be highlighted
-as a comment, but it will be recognized as a regexp by the indentation
-code. Or the opposite case, when a POD section is highlighted, but
-may break the indentation of the following code (though indentation
-should work if the balance of delimiters is not broken by POD).
-
-The main trick (to make $ a \"backslash\") makes constructions like
-${aaa} look like unbalanced braces. The only trick I can think of is
-to insert it as $ {aaa} (valid in perl5, not in perl4).
-
-Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
-as /($|\\s)/. Note that such a transposition is not always possible.
-
-The solution is to upgrade your Emacs or patch an older one. Note
-that Emacs 20.2 has some bugs related to `syntax-table' text
-properties. Patches are available on the main CPerl download site,
-and on CPAN.
-
-If these bugs cannot be fixed on your machine (say, you have an inferior
-environment and cannot recompile), you may still disable all the fancy stuff
-via `cperl-use-syntax-table-text-property'.")
+ "This used to contain a description of problems in CPerl mode
+specific for very old Emacs versions. This is no longer relevant
+and has been removed.")
+(make-obsolete-variable 'cperl-problems-old-emaxen nil "28.1")
(defvar cperl-praise 'please-ignore-this-line
"Advantages of CPerl mode.
0) It uses the newest `syntax-table' property ;-);
-1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
-mode - but the latter number may have improved too in last years) even
-with old Emaxen which do not support `syntax-table' property.
+1) It does 99% of Perl syntax correct.
When using `syntax-table' property for syntax assist hints, it should
handle 99.995% of lines correct - or somesuch. It automatically
@@ -808,15 +765,14 @@ the settings present before the switch.
9) When doing indentation of control constructs, may correct
line-breaks/spacing between elements of the construct.
-10) Uses a linear-time algorithm for indentation of regions (on Emaxen with
-capable syntax engines).
+10) Uses a linear-time algorithm for indentation of regions.
11) Syntax-highlight, indentation, sexp-recognition inside regular expressions.
")
(defvar cperl-speed 'please-ignore-this-line
"This is an incomplete compendium of what is available in other parts
-of CPerl documentation. (Please inform me if I skept anything.)
+of CPerl documentation. (Please inform me if I skipped anything.)
There is a perception that CPerl is slower than alternatives. This part
of documentation is designed to overcome this misconception.
@@ -833,8 +789,8 @@ syntax-parsing routines, and marks them up so that either
A1) CPerl may work around these deficiencies (for big chunks, mostly
PODs and HERE-documents), or
- A2) On capable Emaxen CPerl will use improved syntax-handling
- which reads mark-up hints directly.
+ A2) CPerl will use improved syntax-handling which reads mark-up
+ hints directly.
The scan in case A2 is much more comprehensive, thus may be slower.
@@ -928,19 +884,12 @@ In regular expressions (including character classes):
(defun cperl-putback-char (c) ; Emacs 19
(push c unread-command-events)) ; Avoid undefined warning
-(defvar cperl-do-not-fontify
- ;; FIXME: This is not doing what it claims!
- (if (string< emacs-version "19.30")
- 'fontified
- 'lazy-lock)
- "Text property which inhibits refontification.")
-
(defsubst cperl-put-do-not-fontify (from to &optional post)
;; If POST, do not do it with postponed fontification
(if (and post cperl-syntaxify-by-font-lock)
nil
(put-text-property (max (point-min) (1- from))
- to cperl-do-not-fontify t)))
+ to 'fontified t)))
(defcustom cperl-mode-hook nil
"Hook run by CPerl mode."
@@ -959,22 +908,12 @@ In regular expressions (including character classes):
(defun cperl-make-indent (column &optional minimum keep)
- "Makes indent of the current line the requested amount.
-Unless KEEP, removes the old indentation. Works around a bug in ancient
-versions of Emacs."
- (let ((prop (get-text-property (point) 'syntax-type)))
- (or keep
- (delete-horizontal-space))
- (indent-to column minimum)
- ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties
- (and prop
- (> (current-column) 0)
- (save-excursion
- (beginning-of-line)
- (or (get-text-property (point) 'syntax-type)
- (and (looking-at "\\=[ \t]")
- (put-text-property (point) (match-end 0)
- 'syntax-type prop)))))))
+ "Indent from point with tabs and spaces until COLUMN is reached.
+MINIMUM is like in `indent-to', which see.
+Unless KEEP, removes the old indentation."
+ (or keep
+ (delete-horizontal-space))
+ (indent-to column minimum))
;; Probably it is too late to set these guys already, but it can help later:
@@ -1021,9 +960,12 @@ versions of Emacs."
"Abbrev table in use in CPerl mode buffers."
:parents (list cperl-mode-electric-keywords-abbrev-table))
-(when (boundp 'edit-var-mode-alist)
- ;; FIXME: What package uses this?
- (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))))
+;; ;; TODO: Commented out as we don't know what it is used for. If
+;; ;; there are no bug reports about this for Emacs 28.1, this
+;; ;; can probably be removed. (Code search online reveals nothing.)
+;; (when (boundp 'edit-var-mode-alist)
+;; ;; FIXME: What package uses this?
+;; (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))))
(defvar cperl-mode-map
(let ((map (make-sparse-keymap)))
@@ -1081,10 +1023,6 @@ versions of Emacs."
(define-key map [(control ?c) (control ?h) ?v]
;;(concat (char-to-string help-char) "v") ; does not work
'cperl-get-help))
- (or (boundp 'fill-paragraph-function)
- (substitute-key-definition
- 'fill-paragraph 'cperl-fill-paragraph
- map global-map))
(substitute-key-definition
'indent-sexp 'cperl-indent-exp
map global-map)
@@ -1097,175 +1035,314 @@ versions of Emacs."
map)
"Keymap used in CPerl mode.")
-(defvar cperl-menu)
(defvar cperl-lazy-installed)
(defvar cperl-old-style nil)
-(condition-case nil
- (progn
- (require 'easymenu)
- (easy-menu-define
- cperl-menu cperl-mode-map "Menu for CPerl mode"
- '("Perl"
- ["Beginning of function" beginning-of-defun t]
- ["End of function" end-of-defun t]
- ["Mark function" mark-defun t]
- ["Indent expression" cperl-indent-exp t]
- ["Fill paragraph/comment" fill-paragraph t]
- "----"
- ["Line up a construction" cperl-lineup (use-region-p)]
- ["Invert if/unless/while etc" cperl-invert-if-unless t]
- ("Regexp"
- ["Beautify" cperl-beautify-regexp
- cperl-use-syntax-table-text-property]
- ["Beautify one level deep" (cperl-beautify-regexp 1)
- cperl-use-syntax-table-text-property]
- ["Beautify a group" cperl-beautify-level
- cperl-use-syntax-table-text-property]
- ["Beautify a group one level deep" (cperl-beautify-level 1)
- cperl-use-syntax-table-text-property]
- ["Contract a group" cperl-contract-level
- cperl-use-syntax-table-text-property]
- ["Contract groups" cperl-contract-levels
- cperl-use-syntax-table-text-property]
- "----"
- ["Find next interpolated" cperl-next-interpolated-REx
- (next-single-property-change (point-min) 'REx-interpolated)]
- ["Find next interpolated (no //o)"
- cperl-next-interpolated-REx-0
- (or (text-property-any (point-min) (point-max) 'REx-interpolated t)
- (text-property-any (point-min) (point-max) 'REx-interpolated 1))]
- ["Find next interpolated (neither //o nor whole-REx)"
- cperl-next-interpolated-REx-1
- (text-property-any (point-min) (point-max) 'REx-interpolated t)])
- ["Insert spaces if needed to fix style" cperl-find-bad-style t]
- ["Refresh \"hard\" constructions" cperl-find-pods-heres t]
- "----"
- ["Indent region" cperl-indent-region (use-region-p)]
- ["Comment region" cperl-comment-region (use-region-p)]
- ["Uncomment region" cperl-uncomment-region (use-region-p)]
- "----"
- ["Run" mode-compile (fboundp 'mode-compile)]
- ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
- (get-buffer "*compilation*"))]
- ["Next error" next-error (get-buffer "*compilation*")]
- ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
- "----"
- ["Debugger" cperl-db t]
- "----"
- ("Tools"
- ["Imenu" imenu (fboundp 'imenu)]
- ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)]
- "----"
- ["Ispell PODs" cperl-pod-spell
- ;; Better not to update syntaxification here:
- ;; debugging syntaxification can be broken by this???
- (or
- (get-text-property (point-min) 'in-pod)
- (< (progn
- (and cperl-syntaxify-for-menu
- (cperl-update-syntaxification (point-max) (point-max)))
- (next-single-property-change (point-min) 'in-pod nil (point-max)))
- (point-max)))]
- ["Ispell HERE-DOCs" cperl-here-doc-spell
- (< (progn
- (and cperl-syntaxify-for-menu
- (cperl-update-syntaxification (point-max) (point-max)))
- (next-single-property-change (point-min) 'here-doc-group nil (point-max)))
- (point-max))]
- ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc
- (eq 'here-doc (progn
- (and cperl-syntaxify-for-menu
- (cperl-update-syntaxification (point) (point)))
- (get-text-property (point) 'syntax-type)))]
- ["Select this HERE-DOC or POD section"
- cperl-select-this-pod-or-here-doc
- (memq (progn
- (and cperl-syntaxify-for-menu
- (cperl-update-syntaxification (point) (point)))
- (get-text-property (point) 'syntax-type))
- '(here-doc pod))]
- "----"
- ["CPerl pretty print (experimental)" cperl-ps-print
- (fboundp 'ps-extend-face-list)]
- "----"
- ["Syntaxify region" cperl-find-pods-heres-region
- (use-region-p)]
- ["Profile syntaxification" cperl-time-fontification t]
- ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t]
- ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t]
- ["Debug backtrace on syntactic scan (BEWARE!!!)"
- (cperl-toggle-set-debug-unwind nil t) t]
- "----"
- ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
- ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
- ("Tags"
- ;; ["Create tags for current file" cperl-etags t]
- ;; ["Add tags for current file" (cperl-etags t) t]
- ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
- ;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
- ;; ["Create tags for Perl files in (sub)directories"
- ;; (cperl-etags nil 'recursive) t]
- ;; ["Add tags for Perl files in (sub)directories"
- ;; (cperl-etags t 'recursive) t])
- ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer)
- ["Create tags for current file" (cperl-write-tags nil t) t]
- ["Add tags for current file" (cperl-write-tags) t]
- ["Create tags for Perl files in directory"
- (cperl-write-tags nil t nil t) t]
- ["Add tags for Perl files in directory"
- (cperl-write-tags nil nil nil t) t]
- ["Create tags for Perl files in (sub)directories"
- (cperl-write-tags nil t t t) t]
- ["Add tags for Perl files in (sub)directories"
- (cperl-write-tags nil nil t t) t]))
- ("Perl docs"
- ["Define word at point" imenu-go-find-at-position
- (fboundp 'imenu-go-find-at-position)]
- ["Help on function" cperl-info-on-command t]
- ["Help on function at point" cperl-info-on-current-command t]
- ["Help on symbol at point" cperl-get-help t]
- ["Perldoc" cperl-perldoc t]
- ["Perldoc on word at point" cperl-perldoc-at-point t]
- ["View manpage of POD in this file" cperl-build-manpage t]
- ["Auto-help on" cperl-lazy-install
- (not cperl-lazy-installed)]
- ["Auto-help off" cperl-lazy-unstall
- cperl-lazy-installed])
- ("Toggle..."
- ["Auto newline" cperl-toggle-auto-newline t]
- ["Electric parens" cperl-toggle-electric t]
- ["Electric keywords" cperl-toggle-abbrev t]
- ["Fix whitespace on indent" cperl-toggle-construct-fix t]
- ["Auto-help on Perl constructs" cperl-toggle-autohelp t]
- ["Auto fill" auto-fill-mode t])
- ("Indent styles..."
- ["CPerl" (cperl-set-style "CPerl") t]
- ["PerlStyle" (cperl-set-style "PerlStyle") t]
- ["GNU" (cperl-set-style "GNU") t]
- ["C++" (cperl-set-style "C++") t]
- ["K&R" (cperl-set-style "K&R") t]
- ["BSD" (cperl-set-style "BSD") t]
- ["Whitesmith" (cperl-set-style "Whitesmith") t]
- ["Memorize Current" (cperl-set-style "Current") t]
- ["Memorized" (cperl-set-style-back) cperl-old-style])
- ("Micro-docs"
- ["Tips" (describe-variable 'cperl-tips) t]
- ["Problems" (describe-variable 'cperl-problems) t]
- ["Speed" (describe-variable 'cperl-speed) t]
- ["Praise" (describe-variable 'cperl-praise) t]
- ["Faces" (describe-variable 'cperl-tips-faces) t]
- ["CPerl mode" (describe-function 'cperl-mode) t]
- ["CPerl version"
- (message "The version of master-file for this CPerl is %s-Emacs"
- cperl-version)
- t]))))
- (error nil))
+(easy-menu-define cperl-menu cperl-mode-map
+ "Menu for CPerl mode."
+ '("Perl"
+ ["Beginning of function" beginning-of-defun t]
+ ["End of function" end-of-defun t]
+ ["Mark function" mark-defun t]
+ ["Indent expression" cperl-indent-exp t]
+ ["Fill paragraph/comment" fill-paragraph t]
+ "----"
+ ["Line up a construction" cperl-lineup (use-region-p)]
+ ["Invert if/unless/while etc" cperl-invert-if-unless t]
+ ("Regexp"
+ ["Beautify" cperl-beautify-regexp
+ cperl-use-syntax-table-text-property]
+ ["Beautify one level deep" (cperl-beautify-regexp 1)
+ cperl-use-syntax-table-text-property]
+ ["Beautify a group" cperl-beautify-level
+ cperl-use-syntax-table-text-property]
+ ["Beautify a group one level deep" (cperl-beautify-level 1)
+ cperl-use-syntax-table-text-property]
+ ["Contract a group" cperl-contract-level
+ cperl-use-syntax-table-text-property]
+ ["Contract groups" cperl-contract-levels
+ cperl-use-syntax-table-text-property]
+ "----"
+ ["Find next interpolated" cperl-next-interpolated-REx
+ (next-single-property-change (point-min) 'REx-interpolated)]
+ ["Find next interpolated (no //o)"
+ cperl-next-interpolated-REx-0
+ (or (text-property-any (point-min) (point-max) 'REx-interpolated t)
+ (text-property-any (point-min) (point-max) 'REx-interpolated 1))]
+ ["Find next interpolated (neither //o nor whole-REx)"
+ cperl-next-interpolated-REx-1
+ (text-property-any (point-min) (point-max) 'REx-interpolated t)])
+ ["Insert spaces if needed to fix style" cperl-find-bad-style t]
+ ["Refresh \"hard\" constructions" cperl-find-pods-heres t]
+ "----"
+ ["Indent region" cperl-indent-region (use-region-p)]
+ ["Comment region" cperl-comment-region (use-region-p)]
+ ["Uncomment region" cperl-uncomment-region (use-region-p)]
+ "----"
+ ["Run" mode-compile (fboundp 'mode-compile)]
+ ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
+ (get-buffer "*compilation*"))]
+ ["Next error" next-error (get-buffer "*compilation*")]
+ ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
+ "----"
+ ["Debugger" cperl-db t]
+ "----"
+ ("Tools"
+ ["Imenu" imenu (fboundp 'imenu)]
+ ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)]
+ "----"
+ ["Ispell PODs" cperl-pod-spell
+ ;; Better not to update syntaxification here:
+ ;; debugging syntaxification can be broken by this???
+ (or
+ (get-text-property (point-min) 'in-pod)
+ (< (progn
+ (and cperl-syntaxify-for-menu
+ (cperl-update-syntaxification (point-max)))
+ (next-single-property-change (point-min) 'in-pod nil (point-max)))
+ (point-max)))]
+ ["Ispell HERE-DOCs" cperl-here-doc-spell
+ (< (progn
+ (and cperl-syntaxify-for-menu
+ (cperl-update-syntaxification (point-max)))
+ (next-single-property-change (point-min) 'here-doc-group nil (point-max)))
+ (point-max))]
+ ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc
+ (eq 'here-doc (progn
+ (and cperl-syntaxify-for-menu
+ (cperl-update-syntaxification (point)))
+ (get-text-property (point) 'syntax-type)))]
+ ["Select this HERE-DOC or POD section"
+ cperl-select-this-pod-or-here-doc
+ (memq (progn
+ (and cperl-syntaxify-for-menu
+ (cperl-update-syntaxification (point)))
+ (get-text-property (point) 'syntax-type))
+ '(here-doc pod))]
+ "----"
+ ["CPerl pretty print (experimental)" cperl-ps-print
+ (fboundp 'ps-extend-face-list)]
+ "----"
+ ["Syntaxify region" cperl-find-pods-heres-region
+ (use-region-p)]
+ ["Profile syntaxification" cperl-time-fontification t]
+ ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t]
+ ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t]
+ ["Debug backtrace on syntactic scan (BEWARE!!!)"
+ (cperl-toggle-set-debug-unwind nil t) t]
+ "----"
+ ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
+ ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
+ ("Tags"
+ ;; ["Create tags for current file" cperl-etags t]
+ ;; ["Add tags for current file" (cperl-etags t) t]
+ ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
+ ;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
+ ;; ["Create tags for Perl files in (sub)directories"
+ ;; (cperl-etags nil 'recursive) t]
+ ;; ["Add tags for Perl files in (sub)directories"
+ ;; (cperl-etags t 'recursive) t])
+ ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer)
+ ["Create tags for current file" (cperl-write-tags nil t) t]
+ ["Add tags for current file" (cperl-write-tags) t]
+ ["Create tags for Perl files in directory"
+ (cperl-write-tags nil t nil t) t]
+ ["Add tags for Perl files in directory"
+ (cperl-write-tags nil nil nil t) t]
+ ["Create tags for Perl files in (sub)directories"
+ (cperl-write-tags nil t t t) t]
+ ["Add tags for Perl files in (sub)directories"
+ (cperl-write-tags nil nil t t) t]))
+ ("Perl docs"
+ ["Define word at point" imenu-go-find-at-position
+ (fboundp 'imenu-go-find-at-position)]
+ ["Help on function" cperl-info-on-command t]
+ ["Help on function at point" cperl-info-on-current-command t]
+ ["Help on symbol at point" cperl-get-help t]
+ ["Perldoc" cperl-perldoc t]
+ ["Perldoc on word at point" cperl-perldoc-at-point t]
+ ["View manpage of POD in this file" cperl-build-manpage t]
+ ["Auto-help on" cperl-lazy-install
+ (not cperl-lazy-installed)]
+ ["Auto-help off" cperl-lazy-unstall
+ cperl-lazy-installed])
+ ("Toggle..."
+ ["Auto newline" cperl-toggle-auto-newline t]
+ ["Electric parens" cperl-toggle-electric t]
+ ["Electric keywords" cperl-toggle-abbrev t]
+ ["Fix whitespace on indent" cperl-toggle-construct-fix t]
+ ["Auto-help on Perl constructs" cperl-toggle-autohelp t]
+ ["Auto fill" auto-fill-mode t])
+ ("Indent styles..."
+ ["CPerl" (cperl-set-style "CPerl") t]
+ ["PBP" (cperl-set-style "PBP") t]
+ ["PerlStyle" (cperl-set-style "PerlStyle") t]
+ ["GNU" (cperl-set-style "GNU") t]
+ ["C++" (cperl-set-style "C++") t]
+ ["K&R" (cperl-set-style "K&R") t]
+ ["BSD" (cperl-set-style "BSD") t]
+ ["Whitesmith" (cperl-set-style "Whitesmith") t]
+ ["Memorize Current" (cperl-set-style "Current") t]
+ ["Memorized" (cperl-set-style-back) cperl-old-style])
+ ("Micro-docs"
+ ["Tips" (describe-variable 'cperl-tips) t]
+ ["Problems" (describe-variable 'cperl-problems) t]
+ ["Speed" (describe-variable 'cperl-speed) t]
+ ["Praise" (describe-variable 'cperl-praise) t]
+ ["Faces" (describe-variable 'cperl-tips-faces) t]
+ ["CPerl mode" (describe-function 'cperl-mode) t])))
(autoload 'c-macro-expand "cmacexp"
"Display the result of expanding all C macros occurring in the region.
The expansion is entirely correct because it uses the C preprocessor."
t)
+
+;;; Perl Grammar Components
+;;
+;; The following regular expressions are building blocks for a
+;; minimalistic Perl grammar, to be used instead of individual (and
+;; not always consistent) literal regular expressions.
+
+(defconst cperl--basic-identifier-regexp
+ (rx (sequence (or alpha "_") (* (or word "_"))))
+ "A regular expression for the name of a \"basic\" Perl variable.
+Neither namespace separators nor sigils are included. As is,
+this regular expression applies to labels,subroutine calls where
+the ampersand sigil is not required, and names of subroutine
+attributes.")
+
+(defconst cperl--label-regexp
+ (rx-to-string
+ `(sequence
+ symbol-start
+ (regexp ,cperl--basic-identifier-regexp)
+ (0+ space)
+ ":"))
+ "A regular expression for a Perl label.
+By convention, labels are uppercase alphabetics, but this isn't
+enforced.")
+
+(defconst cperl--normal-identifier-regexp
+ (rx-to-string
+ `(or
+ (sequence
+ (1+ (sequence
+ (opt (regexp ,cperl--basic-identifier-regexp))
+ "::"))
+ (opt (regexp ,cperl--basic-identifier-regexp)))
+ (regexp ,cperl--basic-identifier-regexp)))
+ "A regular expression for a Perl variable name with optional namespace.
+Examples are `foo`, `Some::Module::VERSION`, and `::` (yes, that
+is a legal variable name).")
+
+(defconst cperl--special-identifier-regexp
+ (rx-to-string
+ `(or
+ (1+ digit) ; $0, $1, $2, ...
+ (sequence "^" (any "A-Z" "]^_?\\")) ; $^V
+ (sequence "{" (0+ space) ; ${^MATCH}
+ "^" (any "A-Z" "]^_?\\")
+ (0+ (any "A-Z" "_" digit))
+ (0+ space) "}")
+ (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~"))) ; $., $|, $", ... but not $^ or ${
+ "The list of Perl \"punctuation\" variables, as listed in perlvar.")
+
+(defconst cperl--ws-regexp
+ (rx-to-string
+ '(or space "\n"))
+ "Regular expression for a single whitespace in Perl.")
+
+(defconst cperl--eol-comment-regexp
+ (rx-to-string
+ '(sequence "#" (0+ (not (in "\n"))) "\n"))
+ "Regular expression for a single end-of-line comment in Perl")
+
+(defconst cperl--ws-or-comment-regexp
+ (rx-to-string
+ `(1+
+ (or
+ (regexp ,cperl--ws-regexp)
+ (regexp ,cperl--eol-comment-regexp))))
+ "Regular expression for a sequence of whitespace and comments in Perl.")
+
+(defconst cperl--ows-regexp
+ (rx-to-string
+ `(opt (regexp ,cperl--ws-or-comment-regexp)))
+ "Regular expression for optional whitespaces or comments in Perl")
+
+(defconst cperl--version-regexp
+ (rx-to-string
+ `(or
+ (sequence (opt "v")
+ (>= 2 (sequence (1+ digit) "."))
+ (1+ digit)
+ (opt (sequence "_" (1+ word))))
+ (sequence (1+ digit)
+ (opt (sequence "." (1+ digit)))
+ (opt (sequence "_" (1+ word))))))
+ "A sequence for recommended version number schemes in Perl.")
+
+(defconst cperl--package-regexp
+ (rx-to-string
+ `(sequence
+ "package" ; FIXME: the "class" and "role" keywords need to be
+ ; recognized soon...ish.
+ (regexp ,cperl--ws-or-comment-regexp)
+ (group (regexp ,cperl--normal-identifier-regexp))
+ (opt
+ (sequence
+ (regexp ,cperl--ws-or-comment-regexp)
+ (group (regexp ,cperl--version-regexp))))))
+ "A regular expression for package NAME VERSION in Perl.
+Contains two groups for the package name and version.")
+
+(defconst cperl--package-for-imenu-regexp
+ (rx-to-string
+ `(sequence
+ (regexp ,cperl--package-regexp)
+ (regexp ,cperl--ows-regexp)
+ (group (or ";" "{"))))
+ "A regular expression to collect package names for `imenu`.
+Catches \"package NAME;\", \"package NAME VERSION;\", \"package
+NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three
+groups: Two from `cperl--package-regexp` for the package name and
+version, and a third to detect \"package BLOCK\" syntax.")
+
+(defconst cperl--sub-name-regexp
+ (rx-to-string
+ `(sequence
+ (optional (sequence (group (or "my" "state" "our"))
+ (regexp ,cperl--ws-or-comment-regexp)))
+ "sub" ; FIXME: the "method" and maybe "fun" keywords need to be
+ ; recognized soon...ish.
+ (regexp ,cperl--ws-or-comment-regexp)
+ (group (regexp ,cperl--normal-identifier-regexp))))
+ "A regular expression to detect a subroutine start.
+Contains two groups: One for to distinguish lexical from
+\"normal\" subroutines and one for the subroutine name.")
+
+(defconst cperl--pod-heading-regexp
+ (rx-to-string
+ `(sequence
+ line-start "=head"
+ (group (in "1-4"))
+ (1+ (in " \t"))
+ (group (1+ (not (in "\n"))))
+ line-end)) ; that line-end seems to be redundant?
+ "A regular expression to detect a POD heading.
+Contains two groups: One for the heading level, and one for the
+heading text.")
+
+(defconst cperl--imenu-entries-regexp
+ (rx-to-string
+ `(or
+ (regexp ,cperl--package-for-imenu-regexp) ; 1..3
+ (regexp ,cperl--sub-name-regexp) ; 4..5
+ (regexp ,cperl--pod-heading-regexp))) ; 6..7
+ "A regular expression to collect stuff that goes into the `imenu` index.
+Covers packages, subroutines, and POD headings.")
+
+
;; These two must be unwound, otherwise take exponential time
(defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*"
"Regular expression to match optional whitespace with interspersed comments.
@@ -1277,8 +1354,7 @@ Should contain exactly one group.")
Should contain exactly one group.")
-;; Is incorporated in `cperl-imenu--function-name-regexp-perl'
-;; `cperl-outline-regexp', `defun-prompt-regexp'.
+;; Is incorporated in `cperl-outline-regexp', `defun-prompt-regexp'.
;; Details of groups in this may be used in several functions; see comments
;; near mentioned above variable(s)...
;; sub($$):lvalue{} sub:lvalue{} Both allowed...
@@ -1306,7 +1382,7 @@ the last)."
cperl-maybe-white-and-comment-rex ; whitespace-comments
"\\(\\sw\\|_\\)+" ; attr-name
;; attr-arg (1 level of internal parens allowed!)
- "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?"
+ "\\((\\(\\\\.\\|[^\\()]\\|([^\\()]*)\\)*)\\)?"
"\\(" ; optional : (XXX allows trailing???)
cperl-maybe-white-and-comment-rex ; whitespace-comments
":\\)?"
@@ -1405,13 +1481,15 @@ the last)."
(defvar cperl-font-lock-multiline nil)
(defvar cperl-font-locking nil)
-;; NB as it stands the code in cperl-mode assumes this only has one
-;; element. If XEmacs 19 support were dropped, this could all be simplified.
-(defvar cperl-compilation-error-regexp-alist
+(defvar cperl-compilation-error-regexp-list
;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS).
- '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"
- 2 3))
- "Alist that specifies how to match errors in perl output.")
+ '("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"
+ 2 3)
+ "List that specifies how to match errors in Perl output.")
+
+(defvar cperl-compilation-error-regexp-alist)
+(make-obsolete-variable 'cperl-compilation-error-regexp-alist
+ 'cperl-compilation-error-regexp-list "28.1")
(defvar compilation-error-regexp-alist)
@@ -1521,8 +1599,7 @@ span the needed amount of lines.
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
`cperl-pod-face', `cperl-pod-head-face' control processing of POD and
-here-docs sections. With capable Emaxen results of scan are used
-for indentation too, otherwise they are used for highlighting only.
+here-docs sections. Results of scan are used for indentation too.
Variables controlling indentation style:
`cperl-tab-always-indent'
@@ -1559,12 +1636,12 @@ Variables controlling indentation style:
`cperl-min-label-indent'
Minimal indentation for line that is a label.
-Settings for classic indent-styles: K&R BSD=C++ GNU PerlStyle=Whitesmith
- `cperl-indent-level' 5 4 2 4
- `cperl-brace-offset' 0 0 0 0
- `cperl-continued-brace-offset' -5 -4 0 0
- `cperl-label-offset' -5 -4 -2 -4
- `cperl-continued-statement-offset' 5 4 2 4
+Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith
+ `cperl-indent-level' 5 4 2 4 4
+ `cperl-brace-offset' 0 0 0 0 0
+ `cperl-continued-brace-offset' -5 -4 0 0 0
+ `cperl-label-offset' -5 -4 -2 -2 -4
+ `cperl-continued-statement-offset' 5 4 2 4 4
CPerl knows several indentation styles, and may bulk set the
corresponding variables. Use \\[cperl-set-style] to do this. Use
@@ -1604,132 +1681,102 @@ or as help on variables `cperl-tips', `cperl-problems',
(if (cperl-val 'cperl-electric-keywords)
(abbrev-mode 1))
(set-syntax-table cperl-mode-syntax-table)
+ ;; Workaround for Bug#30393, needed for Emacs 26.
+ (when (< emacs-major-version 27)
+ (setq-local open-paren-in-column-0-is-defun-start nil))
;; Until Emacs is multi-threaded, we do not actually need it local:
(make-local-variable 'cperl-font-lock-multiline-start)
(make-local-variable 'cperl-font-locking)
- (set (make-local-variable 'outline-regexp) cperl-outline-regexp)
- (set (make-local-variable 'outline-level) 'cperl-outline-level)
- (set (make-local-variable 'add-log-current-defun-function)
- (lambda ()
- (save-excursion
- (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
- (match-string-no-properties 1)))))
-
- (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) #'cperl-indent-line)
- (set (make-local-variable 'require-final-newline) mode-require-final-newline)
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-end) "")
- (set (make-local-variable 'comment-column) cperl-comment-column)
- (set (make-local-variable 'comment-start-skip) "#+ *")
+ (setq-local outline-regexp cperl-outline-regexp)
+ (setq-local outline-level 'cperl-outline-level)
+ (setq-local add-log-current-defun-function
+ (lambda ()
+ (save-excursion
+ (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
+ (match-string-no-properties 1)))))
+
+ (setq-local paragraph-start (concat "^$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local paragraph-ignore-fill-prefix t)
+ (setq-local indent-line-function #'cperl-indent-line)
+ (setq-local require-final-newline mode-require-final-newline)
+ (setq-local comment-start "# ")
+ (setq-local comment-end "")
+ (setq-local comment-column cperl-comment-column)
+ (setq-local comment-start-skip "#+ *")
;; "[ \t]*sub"
;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start
;; cperl-maybe-white-and-comment-rex ; 15=pre-block
- (set (make-local-variable 'defun-prompt-regexp)
- (concat "^[ \t]*\\("
- cperl-sub-regexp
- (cperl-after-sub-regexp 'named 'attr-groups)
- "\\|" ; per toke.c
- "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
- "\\)"
- cperl-maybe-white-and-comment-rex))
- (set (make-local-variable 'comment-indent-function) #'cperl-comment-indent)
- (and (boundp 'fill-paragraph-function)
- (set (make-local-variable 'fill-paragraph-function)
- #'cperl-fill-paragraph))
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'indent-region-function) #'cperl-indent-region)
+ (setq-local defun-prompt-regexp
+ (concat "^[ \t]*\\("
+ cperl-sub-regexp
+ (cperl-after-sub-regexp 'named 'attr-groups)
+ "\\|" ; per toke.c
+ "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
+ "\\)"
+ cperl-maybe-white-and-comment-rex))
+ (setq-local comment-indent-function #'cperl-comment-indent)
+ (setq-local fill-paragraph-function #'cperl-fill-paragraph)
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local indent-region-function #'cperl-indent-region)
;;(setq auto-fill-function #'cperl-do-auto-fill) ; Need to switch on and off!
- (set (make-local-variable 'imenu-create-index-function)
- #'cperl-imenu--create-perl-index)
- (set (make-local-variable 'imenu-sort-function) nil)
- (set (make-local-variable 'vc-rcs-header) cperl-vc-rcs-header)
- (set (make-local-variable 'vc-sccs-header) cperl-vc-sccs-header)
- (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
- (set (make-local-variable 'compilation-error-regexp-alist-alist)
- (cons (cons 'cperl (car cperl-compilation-error-regexp-alist))
- compilation-error-regexp-alist-alist))
- (if (fboundp 'compilation-build-compilation-error-regexp-alist)
- (let ((f 'compilation-build-compilation-error-regexp-alist))
- (funcall f))
- (make-local-variable 'compilation-error-regexp-alist)
- (push 'cperl compilation-error-regexp-alist)))
- ((boundp 'compilation-error-regexp-alist);; xemacs 19.x
- (set (make-local-variable 'compilation-error-regexp-alist)
- (append cperl-compilation-error-regexp-alist
- compilation-error-regexp-alist))))
- (set (make-local-variable 'font-lock-defaults)
- '((cperl-load-font-lock-keywords
- cperl-load-font-lock-keywords-1
- cperl-load-font-lock-keywords-2) nil nil ((?_ . "w"))))
+ (setq-local imenu-create-index-function #'cperl-imenu--create-perl-index)
+ (setq-local imenu-sort-function nil)
+ (setq-local vc-rcs-header cperl-vc-rcs-header)
+ (setq-local vc-sccs-header cperl-vc-sccs-header)
+ (when (boundp 'compilation-error-regexp-alist-alist)
+ ;; The let here is just a compatibility kludge for the obsolete
+ ;; variable `cperl-compilation-error-regexp-alist'. It can be removed
+ ;; when that variable is removed.
+ (let ((regexp (if (boundp 'cperl-compilation-error-regexp-alist)
+ (car cperl-compilation-error-regexp-alist)
+ cperl-compilation-error-regexp-list)))
+ (setq-local compilation-error-regexp-alist-alist
+ (cons (cons 'cperl regexp)
+ compilation-error-regexp-alist-alist)))
+ (make-local-variable 'compilation-error-regexp-alist)
+ (push 'cperl compilation-error-regexp-alist))
+ (setq-local font-lock-defaults
+ '((cperl-load-font-lock-keywords
+ cperl-load-font-lock-keywords-1
+ cperl-load-font-lock-keywords-2)
+ nil nil ((?_ . "w"))))
;; Reset syntaxification cache.
- (set (make-local-variable 'cperl-syntax-state) nil)
- (if cperl-use-syntax-table-text-property
- (if (eval-when-compile (fboundp 'syntax-propertize-rules))
- (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)
- ;; Even if cperl-fontify-syntaxically has already gone
- ;; beyond `start', syntax-propertize has just removed
- ;; syntax-table properties between start and end, so we have
- ;; to re-apply them.
- (setq cperl-syntax-done-to start)
- (cperl-fontify-syntaxically end))))
- ;; Do not introduce variable if not needed, we check it!
- (set (make-local-variable 'parse-sexp-lookup-properties) t)
- ;; Fix broken font-lock:
- (or (boundp 'font-lock-unfontify-region-function)
- (setq font-lock-unfontify-region-function
- #'font-lock-default-unfontify-region))
- ;; Our: just a plug for wrong font-lock
- (set (make-local-variable 'font-lock-unfontify-region-function)
- ;; not present with old Emacs
- #'cperl-font-lock-unfontify-region-function)
- ;; Reset syntaxification cache.
- (set (make-local-variable 'cperl-syntax-done-to) nil)
- (set (make-local-variable 'font-lock-syntactic-keywords)
- (if cperl-syntaxify-by-font-lock
- '((cperl-fontify-syntaxically))
- ;; unless font-lock-syntactic-keywords, font-lock (pre-22.1)
- ;; used to ignore syntax-table text-properties. (t) is a hack
- ;; to make font-lock think that font-lock-syntactic-keywords
- ;; are defined.
- '(t)))))
- (if (boundp 'font-lock-multiline) ; Newer font-lock; use its facilities
- (progn
- (setq cperl-font-lock-multiline t) ; Not localized...
- (set (make-local-variable 'font-lock-multiline) t))
- (set (make-local-variable 'font-lock-fontify-region-function)
- ;; not present with old Emacs
- #'cperl-font-lock-fontify-region-function))
- (set (make-local-variable 'font-lock-fontify-region-function)
- #'cperl-font-lock-fontify-region-function)
+ (setq-local cperl-syntax-state nil)
+ (when cperl-use-syntax-table-text-property
+ ;; Reset syntaxification cache.
+ (setq-local cperl-syntax-done-to nil)
+ (setq-local syntax-propertize-function
+ (lambda (start end)
+ (goto-char start)
+ ;; Even if cperl-fontify-syntactically has already gone
+ ;; beyond `start', syntax-propertize has just removed
+ ;; syntax-table properties between start and end, so we have
+ ;; to re-apply them.
+ (setq cperl-syntax-done-to start)
+ (cperl-fontify-syntactically end))))
+ (setq cperl-font-lock-multiline t) ; Not localized...
+ (setq-local font-lock-multiline t)
+ (setq-local font-lock-fontify-region-function
+ #'cperl-font-lock-fontify-region-function)
(make-local-variable 'cperl-old-style)
- (set (make-local-variable 'normal-auto-fill-function)
- #'cperl-do-auto-fill)
+ (setq-local normal-auto-fill-function
+ #'cperl-do-auto-fill)
(if (cperl-val 'cperl-font-lock)
(progn (or cperl-faces-init (cperl-init-faces))
(font-lock-mode 1)))
- (set (make-local-variable 'facemenu-add-face-function)
- #'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
+ (setq-local facemenu-add-face-function
+ #'cperl-facemenu-add-face-function) ; XXXX What this guy is for???
(and (boundp 'msb-menu-cond)
(not cperl-msb-fixed)
(cperl-msb-fix))
- (if (fboundp 'easy-menu-add)
- (easy-menu-add cperl-menu)) ; A NOP in Emacs.
(if cperl-hook-after-change
(add-hook 'after-change-functions #'cperl-after-change-function nil t))
;; After hooks since fontification will break this
- (if cperl-pod-here-scan
- (or cperl-syntaxify-by-font-lock
- (progn (or cperl-faces-init (cperl-init-faces-weak))
- (cperl-find-pods-heres))))
+ (when (and cperl-pod-here-scan
+ (not cperl-syntaxify-by-font-lock))
+ (cperl-find-pods-heres))
;; Setup Flymake
(add-hook 'flymake-diagnostic-functions #'perl-flymake nil t))
@@ -2177,7 +2224,7 @@ Help message may be switched off by setting `cperl-message-electric-keyword'
to nil."
(let ((beg (point-at-bol)))
(and (save-excursion
- (backward-sexp 1)
+ (skip-chars-backward "[:alpha:]")
(cperl-after-expr-p nil "{;:"))
(save-excursion
(not
@@ -2425,7 +2472,7 @@ means indent rigidly all the lines of the expression starting after point
so that this line becomes properly indented.
The relative indentation among the lines of the expression are preserved."
(interactive "P")
- (cperl-update-syntaxification (point) (point))
+ (cperl-update-syntaxification (point))
(if whole-exp
;; If arg, always indent this line as Perl
;; and shift remaining lines of expression the same amount.
@@ -2553,7 +2600,7 @@ Will not look before LIM."
(defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start
;; the sniffer logic to understand what the current line MEANS.
- (cperl-update-syntaxification (point) (point))
+ (cperl-update-syntaxification (point))
(let ((res (get-text-property (point) 'syntax-type)))
(save-excursion
(cond
@@ -3045,7 +3092,7 @@ Returns true if comment is found. In POD will not move the point."
;; then looks for literal # or end-of-line.
(let (state stop-in cpoint (lim (point-at-eol)) pr e)
(or cperl-font-locking
- (cperl-update-syntaxification lim lim))
+ (cperl-update-syntaxification lim))
(beginning-of-line)
(if (setq pr (get-text-property (point) 'syntax-type))
(setq e (next-single-property-change (point) 'syntax-type nil (point-max))))
@@ -3253,8 +3300,8 @@ Return the error message (if any). Does not work if delimiter is `)'.
Works before syntax recognition is done."
;; Works *before* syntax recognition is done
(or st-l (setq st-l (list nil))) ; Avoid overwriting '()
- (let (st b reset-st)
- (condition-case b
+ (let (st result reset-st)
+ (condition-case err
(progn
(setq st (cperl-cached-syntax-table st-l))
(modify-syntax-entry ?\( "()" st)
@@ -3262,8 +3309,7 @@ Works before syntax recognition is done."
(setq reset-st (syntax-table))
(set-syntax-table st)
(forward-sexp 1))
- (error (message
- "cperl-forward-group-in-re: error %s" b)))
+ (error (setq result err)))
;; now restore the initial state
(if st
(progn
@@ -3271,12 +3317,9 @@ Works before syntax recognition is done."
(modify-syntax-entry ?\) "." st)))
(if reset-st
(set-syntax-table reset-st))
- b))
+ result))
-(defvar font-lock-string-face)
-;;(defvar font-lock-reference-face)
-(defvar font-lock-constant-face)
(defsubst cperl-postpone-fontification (b e type val &optional now)
;; Do after syntactic fontification?
(if cperl-syntaxify-by-font-lock
@@ -3342,16 +3385,6 @@ Works before syntax recognition is done."
(setq end (point)))))
(or end pos)))))
-;; These are needed for byte-compile (at least with v19)
-(defvar cperl-nonoverridable-face)
-(defvar font-lock-variable-name-face)
-(defvar font-lock-function-name-face)
-(defvar font-lock-keyword-face)
-(defvar font-lock-builtin-face)
-(defvar font-lock-type-face)
-(defvar font-lock-comment-face)
-(defvar font-lock-warning-face)
-
(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos)
"Syntactically mark (and fontify) attributes of a subroutine.
Should be called with the point before leading colon of an attribute."
@@ -3457,8 +3490,8 @@ Should be called with the point before leading colon of an attribute."
(match-beginning 4) (match-end 4)
'face dashface))
;; save match data (for looking-at)
- (setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt)
- (match-end elt))))
+ (setq lll (mapcar (lambda (elt) (cons (match-beginning elt)
+ (match-end elt)))
l))
(while lll
(setq ll (car lll))
@@ -3509,49 +3542,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(font-lock-string-face (if (boundp 'font-lock-string-face)
font-lock-string-face
'font-lock-string-face))
- (my-cperl-delimiters-face (if (boundp 'font-lock-constant-face)
- font-lock-constant-face
- 'font-lock-constant-face))
+ (my-cperl-delimiters-face
+ font-lock-constant-face)
(my-cperl-REx-spec-char-face ; [] ^.$ and wrapper-of ({})
- (if (boundp 'font-lock-function-name-face)
- font-lock-function-name-face
- 'font-lock-function-name-face))
- (font-lock-variable-name-face ; interpolated vars and ({})-code
- (if (boundp 'font-lock-variable-name-face)
- font-lock-variable-name-face
- 'font-lock-variable-name-face))
- (font-lock-function-name-face ; used in `cperl-find-sub-attrs'
- (if (boundp 'font-lock-function-name-face)
- font-lock-function-name-face
- 'font-lock-function-name-face))
- (font-lock-constant-face ; used in `cperl-find-sub-attrs'
- (if (boundp 'font-lock-constant-face)
- font-lock-constant-face
- 'font-lock-constant-face))
+ font-lock-function-name-face)
(my-cperl-REx-0length-face ; 0-length, (?:)etc, non-literal \
- (if (boundp 'font-lock-builtin-face)
- font-lock-builtin-face
- 'font-lock-builtin-face))
- (font-lock-comment-face
- (if (boundp 'font-lock-comment-face)
- font-lock-comment-face
- 'font-lock-comment-face))
- (font-lock-warning-face
- (if (boundp 'font-lock-warning-face)
- font-lock-warning-face
- 'font-lock-warning-face))
+ font-lock-builtin-face)
(my-cperl-REx-ctl-face ; (|)
- (if (boundp 'font-lock-keyword-face)
- font-lock-keyword-face
- 'font-lock-keyword-face))
+ font-lock-keyword-face)
(my-cperl-REx-modifiers-face ; //gims
- (if (boundp 'cperl-nonoverridable-face)
- cperl-nonoverridable-face
- 'cperl-nonoverridable-face))
+ 'cperl-nonoverridable-face)
(my-cperl-REx-length1-face ; length=1 escaped chars, POSIX classes
- (if (boundp 'font-lock-type-face)
- font-lock-type-face
- 'font-lock-type-face))
+ font-lock-type-face)
(stop-point (if ignore-max
(point-max)
max))
@@ -3560,19 +3562,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
"\\(\\`\n?\\|^\n\\)=" ; POD
"\\|"
;; One extra () before this:
- "<<~?" ; HERE-DOC
- "\\(" ; 1 + 1
+ "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2
+ "\\(" ; 2 + 1
;; First variant "BLAH" or just ``.
"[ \t]*" ; Yes, whitespace is allowed!
- "\\([\"'`]\\)" ; 2 + 1 = 3
- "\\([^\"'`\n]*\\)" ; 3 + 1
- "\\3"
+ "\\([\"'`]\\)" ; 3 + 1 = 4
+ "\\([^\"'`\n]*\\)" ; 4 + 1
+ "\\4"
"\\|"
;; Second variant: Identifier or \ID (same as 'ID') or empty
- "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1
+ "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
;; Do not have <<= or << 30 or <<30 or << $blah.
;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
- "\\(\\)" ; To preserve count of pars :-( 6 + 1
"\\)"
"\\|"
;; 1+6 extra () before this:
@@ -3584,7 +3585,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
"\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT
"\\|"
;; 1+6+2+1=10 extra () before this:
- "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
+ "\\([/<]\\)" ; /blah/ or <file*glob>
"\\|"
;; 1+6+2+1+1=11 extra () before this
"\\<" cperl-sub-regexp "\\>" ; sub with proto/attr
@@ -3607,7 +3608,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; 1+6+2+1+1+6+1+1+1=20 extra () before this:
"\\|"
"\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy
- ""))))
+ "")))
+ warning-message)
(unwind-protect
(progn
(save-excursion
@@ -3670,7 +3672,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(looking-at "\\(cut\\|end\\)\\>"))
(if (or (nth 3 state) (nth 4 state) ignore-max)
nil ; Doing a chunk only
- (message "=cut is not preceded by a POD section")
+ (setq warning-message "=cut is not preceded by a POD section")
(or (car err-l) (setcar err-l (point))))
(beginning-of-line)
@@ -3685,7 +3687,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(goto-char b)
(if (re-search-forward "\n=\\(cut\\|end\\)\\>" stop-point 'toend)
(progn
- (message "=cut is not preceded by an empty line")
+ (setq warning-message "=cut is not preceded by an empty line")
(setq b1 t)
(or (car err-l) (setcar err-l b))))))
(beginning-of-line 2) ; An empty line after =cut is not POD!
@@ -3762,13 +3764,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
;; "\\(\\)" ; To preserve count of pars :-( 6 + 1
;; "\\)"
- ((match-beginning 2) ; 1 + 1
+ ((match-beginning 3) ; 2 + 1: found "<<", detect its type
(setq b (point)
tb (match-beginning 0)
c (and ; not HERE-DOC
- (match-beginning 5)
+ (match-beginning 6)
(save-match-data
(or (looking-at "[ \t]*(") ; << function_call()
+ (looking-at ">>") ; <<>> operator
(save-excursion ; 1 << func_name, or $foo << 10
(condition-case nil
(progn
@@ -3793,17 +3796,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>")))
(error t)))))))
(error nil))) ; func(<<EOF)
- (and (not (match-beginning 6)) ; Empty
+ (and (not (match-beginning 7)) ; Empty
(looking-at
"[ \t]*[=0-9$@%&(]"))))))
(if c ; Not here-doc
nil ; Skip it.
- (setq c (match-end 2)) ; 1 + 1
- (if (match-beginning 5) ;4 + 1
- (setq b1 (match-beginning 5) ; 4 + 1
- e1 (match-end 5)) ; 4 + 1
- (setq b1 (match-beginning 4) ; 3 + 1
- e1 (match-end 4))) ; 3 + 1
+ (setq c (match-end 3)) ; 2 + 1
+ (if (match-beginning 6) ;6 + 1
+ (setq b1 (match-beginning 6) ; 5 + 1
+ e1 (match-end 6)) ; 5 + 1
+ (setq b1 (match-beginning 5) ; 4 + 1
+ e1 (match-end 5))) ; 4 + 1
(setq tag (buffer-substring b1 e1)
qtag (regexp-quote tag))
(cond (cperl-pod-here-fontify
@@ -3818,14 +3821,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(setq b (point))
;; We do not search to max, since we may be called from
;; some hook of fontification, and max is random
- (or (and (re-search-forward (concat "^[ \t]*" qtag "$")
- stop-point 'toend)
+ (or (and (re-search-forward
+ (concat "^" (when (equal (match-string 2) "~") "[ \t]*")
+ qtag "$")
+ stop-point 'toend)
;;;(eq (following-char) ?\n) ; XXXX WHY???
)
(progn ; Pretend we matched at the end
(goto-char (point-max))
(re-search-forward "\\'")
- (message "End of here-document `%s' not found." tag)
+ (setq warning-message
+ (format "End of here-document `%s' not found." tag))
(or (car err-l) (setcar err-l b))))
(if cperl-pod-here-fontify
(progn
@@ -3902,7 +3908,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
'face font-lock-string-face)
(cperl-commentify (point) (+ (point) 2) nil)
(cperl-put-do-not-fontify (point) (+ (point) 2) t))
- (message "End of format `%s' not found." name)
+ (setq warning-message
+ (format "End of format `%s' not found." name))
(or (car err-l) (setcar err-l b)))
(forward-line)
(if (> (point) max)
@@ -3913,7 +3920,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; 1+6+2=9 extra () before this:
;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
;; "\\|"
- ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>
+ ;; "\\([/<]\\)" ; /blah/ or <file*glob>
(setq b1 (if (match-beginning 10) 10 11)
argument (buffer-substring
(match-beginning b1) (match-end b1))
@@ -3923,21 +3930,24 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
bb (char-after (1- (match-beginning b1))) ; tmp holder
;; bb == "Not a stringy"
bb (if (eq b1 10) ; user variables/whatever
- (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y)
- (cond ((eq bb ?-) (eq c ?s)) ; -s file test
- ((eq bb ?\:) ; $opt::s
- (eq (char-after
- (- (match-beginning b1) 2))
- ?\:))
- ((eq bb ?\>) ; $foo->s
- (eq (char-after
- (- (match-beginning b1) 2))
- ?\-))
- ((eq bb ?\&)
- (not (eq (char-after ; &&m/blah/
- (- (match-beginning b1) 2))
- ?\&)))
- (t t)))
+ (or
+ ; false positive: "y_" has no word boundary
+ (save-match-data (looking-at "_"))
+ (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y)
+ (cond ((eq bb ?-) (eq c ?s)) ; -s file test
+ ((eq bb ?\:) ; $opt::s
+ (eq (char-after
+ (- (match-beginning b1) 2))
+ ?\:))
+ ((eq bb ?\>) ; $foo->s
+ (eq (char-after
+ (- (match-beginning b1) 2))
+ ?\-))
+ ((eq bb ?\&)
+ (not (eq (char-after ; &&m/blah/
+ (- (match-beginning b1) 2))
+ ?\&)))
+ (t t))))
;; <file> or <$file>
(and (eq c ?\<)
;; Do not stringify <FH>, <$fh> :
@@ -3948,7 +3958,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(goto-char (match-beginning b1))
(cperl-backward-to-noncomment (point-min))
(or bb
- (if (eq b1 11) ; bare /blah/ or ?blah? or <foo>
+ (if (eq b1 11) ; bare /blah/ or <foo>
(setq argument ""
b1 nil
bb ; Not a regexp?
@@ -3956,7 +3966,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; What is below: regexp-p?
(and
(or (memq (preceding-char)
- (append (if (memq c '(?\? ?\<))
+ (append (if (char-equal c ?\<)
;; $a++ ? 1 : 2
"~{(=|&*!,;:["
"~{(=|&+-*!,;:[") nil))
@@ -3967,17 +3977,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(forward-sexp -1)
;; After these keywords `/' starts a RE. One should add all the
;; functions/builtins which expect an argument, but ...
- (if (eq (preceding-char) ?-)
- ;; -d ?foo? is a RE
- (looking-at "[a-zA-Z]\\>")
(and
(not (memq (preceding-char)
'(?$ ?@ ?& ?%)))
(looking-at
- "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\)\\>")))))
+ "\\(while\\|if\\|unless\\|until\\|for\\(each\\)?\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>"))))
(and (eq (preceding-char) ?.)
(eq (char-after (- (point) 2)) ?.))
(bobp))
+ ;; { $a++ / $b } doesn't start a regex, nor does $a--
+ (not (and (memq (preceding-char) '(?+ ?-))
+ (eq (preceding-char) (char-before (1- (point))))))
;; m|blah| ? foo : bar;
(not
(and (eq c ?\?)
@@ -4416,8 +4426,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
REx-subgr-end argument) ; continue
(setq argument nil)))
(and argument
- (message "Couldn't find end of charclass in a REx, pos=%s"
- REx-subgr-start))
+ (setq warning-message
+ (format "Couldn't find end of charclass in a REx, pos=%s"
+ REx-subgr-start)))
(setq argument (1- (point)))
(goto-char REx-subgr-end)
(cperl-highlight-charclass
@@ -4473,7 +4484,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(setq qtag "Can't find })")))
(progn
(goto-char (1- e))
- (message "%s" qtag))
+ (setq warning-message
+ (format "%s" qtag)))
(cperl-postpone-fontification
(1- tag) (1- (point))
'face font-lock-variable-name-face)
@@ -4494,7 +4506,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
'syntax-table cperl-st-cfence))))
(setq was-subgr nil))
(t ; (?#)-comment
- ;; Inside "(" and "\" arn't special in any way
+ ;; Inside "(" and "\" aren't special in any way
;; Works also if the outside delimiters are ().
(or;;(if (eq (char-after b) ?\) )
;;(re-search-forward
@@ -4502,9 +4514,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; (1- e) 'toend)
(search-forward ")" (1- e) 'toend)
;;)
- (message
- "Couldn't find end of (?#...)-comment in a REx, pos=%s"
- REx-subgr-start))))
+ (setq warning-message
+ (format "Couldn't find end of (?#...)-comment in a REx, pos=%s"
+ REx-subgr-start)))))
(if (>= (point) e)
(goto-char (1- e)))
(cond
@@ -4582,8 +4594,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(if (> (point) stop-point)
(progn
(if end
- (message "Garbage after __END__/__DATA__ ignored")
- (message "Unbalanced syntax found while scanning")
+ (setq warning-message "Garbage after __END__/__DATA__ ignored")
+ (setq warning-message "Unbalanced syntax found while scanning")
(or (car err-l) (setcar err-l b)))
(goto-char stop-point))))
(setq cperl-syntax-state (cons state-point state)
@@ -4602,6 +4614,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
;; cperl-mode-syntax-table.
;; (set-syntax-table cperl-mode-syntax-table)
)
+ (when warning-message (message warning-message))
(list (car err-l) overshoot)))
(defun cperl-find-pods-heres-region (min max)
@@ -4700,7 +4713,7 @@ CHARS is a string that contains good characters to have before us (however,
`}' is treated \"smartly\" if it is not in the list)."
(let ((lim (or lim (point-min)))
stop p)
- (cperl-update-syntaxification (point) (point))
+ (cperl-update-syntaxification (point))
(save-excursion
(while (and (not stop) (> (point) lim))
(skip-chars-backward " \t\n\f" lim)
@@ -4828,9 +4841,10 @@ conditional/loop constructs."
(while (< (point) tmp-end)
(parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
(or (eolp) (forward-sexp 1)))
- (if (> (point) tmp-end) ; Yes, there an unfinished block
+ (if (> (point) tmp-end) ; Check for an unfinished block
nil
(if (eq ?\) (preceding-char))
+ ;; closing parens can be preceded by up to three sexps
(progn ;; Plan B: find by REGEXP block followup this line
(setq top (point))
(condition-case nil
@@ -4851,7 +4865,9 @@ conditional/loop constructs."
(progn
(goto-char top)
(forward-sexp 1)
- (setq top (point)))))
+ (setq top (point)))
+ ;; no block to be processed: expression ends here
+ (setq done t)))
(error (setq done t)))
(goto-char top))
(if (looking-at ; Try Plan C: continuation block
@@ -4884,7 +4900,7 @@ Returns some position at the last line."
;; }? continue
;; blah; }
(if (not
- (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")
+ (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|unless\\|until\\)\\_>")
(setq have-brace (save-excursion (search-forward "}" ee t)))))
nil ; Do not need to do anything
;; Looking at:
@@ -4892,7 +4908,7 @@ Returns some position at the last line."
;; else
(if cperl-merge-trailing-else
(if (looking-at
- "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")
+ "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\_>")
(progn
(search-forward "}")
(setq p (point))
@@ -4900,7 +4916,7 @@ Returns some position at the last line."
(delete-region p (point))
(insert (make-string cperl-indent-region-fix-constructs ?\s))
(beginning-of-line)))
- (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\>")
+ (if (looking-at "[ \t]*}[ \t]*\\(els\\(e\\|if\\)\\|continue\\)\\_>")
(save-excursion
(search-forward "}")
(delete-horizontal-space)
@@ -4912,7 +4928,7 @@ Returns some position at the last line."
(setq ret (point)))))))
;; Looking at:
;; } else
- (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>")
+ (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\_>")
(progn
(search-forward "}")
(delete-horizontal-space)
@@ -5084,7 +5100,7 @@ inclusive.
If `cperl-indent-region-fix-constructs', will improve spacing on
conditional/loop constructs."
(interactive "r")
- (cperl-update-syntaxification end end)
+ (cperl-update-syntaxification end)
(save-excursion
(let (cperl-update-start cperl-update-end (h-a-c after-change-functions))
(let ((indent-info (list nil nil nil) ; Cannot use '(), since will modify
@@ -5263,117 +5279,80 @@ indentation and initial hashes. Behaves usually outside of comment."
;; Previous space could have gone:
(or (memq (preceding-char) '(?\s ?\t)) (insert " "))))))
-(defun cperl-imenu-addback (lst &optional isback name)
- ;; We suppose that the lst is a DAG, unless the first element only
- ;; loops back, and ISBACK is set. Thus this function cannot be
- ;; applied twice without ISBACK set.
- (cond ((not cperl-imenu-addback) lst)
- (t
- (or name
- (setq name "+++BACK+++"))
- (mapc (lambda (elt)
- (if (and (listp elt) (listp (cdr elt)))
- (progn
- ;; In the other order it goes up
- ;; one level only ;-(
- (setcdr elt (cons (cons name lst)
- (cdr elt)))
- (cperl-imenu-addback (cdr elt) t name))))
- (if isback (cdr lst) lst))
- lst)))
-
-(defun cperl-imenu--create-perl-index (&optional regexp)
- (require 'imenu) ; May be called from TAGS creator
- (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
+(defun cperl-imenu--create-perl-index ()
+ "Implement `imenu-create-index-function` for CPerl mode.
+This function relies on syntaxification to exclude lines which
+look like declarations but actually are part of a string, a
+comment, or POD."
+ (interactive) ; We'll remove that at some point
+ (goto-char (point-min))
+ (cperl-update-syntaxification (point-max))
+ (let ((case-fold-search nil)
+ (index-alist '())
+ (index-package-alist '())
+ (index-pod-alist '())
+ (index-sub-alist '())
(index-unsorted-alist '())
- (index-meth-alist '()) meth
- packages ends-ranges p marker is-proto
- is-pack index index1 name (end-range 0) package)
- (goto-char (point-min))
- (cperl-update-syntaxification (point-max) (point-max))
- ;; Search for the function
- (progn ;;save-match-data
- (while (re-search-forward
- (or regexp cperl-imenu--function-name-regexp-perl)
- nil t)
- ;; 2=package-group, 5=package-name 8=sub-name
+ (package-stack '()) ; for package NAME BLOCK
+ (current-package "(main)")
+ (current-package-end (point-max))) ; end of package scope
+ ;; collect index entries
+ (while (re-search-forward cperl--imenu-entries-regexp nil t)
+ ;; First, check whether we have left the scope of previously
+ ;; recorded packages, and if so, eliminate them from the stack.
+ (while (< current-package-end (point))
+ (setq current-package (pop package-stack))
+ (setq current-package-end (pop package-stack)))
+ (let ((state (syntax-ppss))
+ name marker) ; for the "current" entry
(cond
- ((and ; Skip some noise if building tags
- (match-beginning 5) ; package name
- ;;(eq (char-after (match-beginning 2)) ?p) ; package
- (not (save-match-data
- (looking-at "[ \t\n]*;")))) ; Plain text word 'package'
- nil)
- ((and
- (or (match-beginning 2)
- (match-beginning 8)) ; package or sub
- ;; Skip if quoted (will not skip multi-line ''-strings :-():
- (null (get-text-property (match-beginning 1) 'syntax-table))
- (null (get-text-property (match-beginning 1) 'syntax-type))
- (null (get-text-property (match-beginning 1) 'in-pod)))
- (setq is-pack (match-beginning 2))
- ;; (if (looking-at "([^()]*)[ \t\n\f]*")
- ;; (goto-char (match-end 0))) ; Messes what follows
- (setq meth nil
- p (point))
- (while (and ends-ranges (>= p (car ends-ranges)))
- ;; delete obsolete entries
- (setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
- (setq package (or (car packages) "")
- end-range (or (car ends-ranges) 0))
- (if is-pack ; doing "package"
- (progn
- (if (match-beginning 5) ; named package
- (setq name (buffer-substring (match-beginning 5)
- (match-end 5))
- name (progn
- (set-text-properties 0 (length name) nil name)
- name)
- package (concat name "::")
- name (concat "package " name))
- ;; Support nameless packages
- (setq name "package;" package ""))
- (setq end-range
- (save-excursion
- (parse-partial-sexp (point) (point-max) -1) (point))
- ends-ranges (cons end-range ends-ranges)
- packages (cons package packages)))
- (setq is-proto
- (or (eq (following-char) ?\;)
- (eq 0 (get-text-property (point) 'attrib-group)))))
- ;; Skip this function name if it is a prototype declaration.
- (if (and is-proto (not is-pack)) nil
- (or is-pack
- (setq name
- (buffer-substring (match-beginning 8) (match-end 8)))
- (set-text-properties 0 (length name) nil name))
- (setq marker (make-marker))
- (set-marker marker (match-end (if is-pack 2 8)))
- (cond (is-pack nil)
- ((string-match "[:']" name)
- (setq meth t))
- ((> p end-range) nil)
- (t
- (setq name (concat package name) meth t)))
- (setq index (cons name marker))
- (if is-pack
- (push index index-pack-alist)
- (push index index-alist))
- (if meth (push index index-meth-alist))
- (push index index-unsorted-alist)))
- ((match-beginning 16) ; POD section
- (setq name (buffer-substring (match-beginning 17) (match-end 17))
- marker (make-marker))
- (set-marker marker (match-beginning 17))
- (set-text-properties 0 (length name) nil name)
- (setq name (concat (make-string
- (* 3 (- (char-after (match-beginning 16)) ?1))
- ?\ )
- name)
- index (cons name marker))
- (setq index1 (cons (concat "=" name) (cdr index)))
- (push index index-pod-alist)
- (push index1 index-unsorted-alist)))))
+ ((nth 3 state) nil) ; matched in a string, so skip
+ ((match-string 1) ; found a package name!
+ (unless (nth 4 state) ; skip if in a comment
+ (setq name (match-string-no-properties 1)
+ marker (copy-marker (match-end 1)))
+ (if (string= (match-string 3) ";")
+ (setq current-package name) ; package NAME;
+ ;; No semicolon, therefore we have: package NAME BLOCK.
+ ;; Stash the current package, because we need to restore
+ ;; it after the end of BLOCK.
+ (push current-package-end package-stack)
+ (push current-package package-stack)
+ ;; record the current name and its scope
+ (setq current-package name)
+ (setq current-package-end (save-excursion
+ (goto-char (match-beginning 3))
+ (forward-sexp)
+ (point)))
+ (push (cons name marker) index-package-alist)
+ (push (cons (concat "package " name) marker) index-unsorted-alist))))
+ ((match-string 5) ; found a sub name!
+ (unless (nth 4 state) ; skip if in a comment
+ (setq name (match-string-no-properties 5)
+ marker (copy-marker (match-end 5)))
+ ;; Qualify the sub name with the package if it doesn't
+ ;; already have one, and if it isn't lexically scoped.
+ ;; "my" and "state" subs are lexically scoped, but "our"
+ ;; are just lexical aliases to package subs.
+ (if (and (null (string-match "::" name))
+ (or (null (match-string 4))
+ (string-equal (match-string 4) "our")))
+ (setq name (concat current-package "::" name)))
+ (let ((index (cons name marker)))
+ (push index index-alist)
+ (push index index-sub-alist)
+ (push index index-unsorted-alist))))
+ ((match-string 6) ; found a POD heading!
+ (when (get-text-property (match-beginning 6) 'in-pod)
+ (setq name (concat (make-string
+ (* 3 (- (char-after (match-beginning 6)) ?1))
+ ?\ )
+ (match-string-no-properties 7))
+ marker (copy-marker (match-beginning 7)))
+ (push (cons name marker) index-pod-alist)
+ (push (cons (concat "=" name) marker) index-unsorted-alist)))
+ (t (error "Unidentified match: %s" (match-string 0))))))
+ ;; Now format the collected stuff
(setq index-alist
(if (default-value 'imenu-sort-function)
(sort index-alist (default-value 'imenu-sort-function))
@@ -5382,14 +5361,14 @@ indentation and initial hashes. Behaves usually outside of comment."
(push (cons "+POD headers+..."
(nreverse index-pod-alist))
index-alist))
- (and (or index-pack-alist index-meth-alist)
- (let ((lst index-pack-alist) hier-list pack elt group name)
- ;; Remove "package ", reverse and uniquify.
+ (and (or index-package-alist index-sub-alist)
+ (let ((lst index-package-alist) hier-list pack elt group name)
+ ;; reverse and uniquify.
(while lst
- (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))
+ (setq elt (car lst) lst (cdr lst) name (car elt))
(if (assoc name hier-list) nil
(setq hier-list (cons (cons name (cdr elt)) hier-list))))
- (setq lst index-meth-alist)
+ (setq lst index-sub-alist)
(while lst
(setq elt (car lst) lst (cdr lst))
(cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))
@@ -5417,17 +5396,18 @@ indentation and initial hashes. Behaves usually outside of comment."
(push (cons "+Hierarchy+..."
hier-list)
index-alist)))
- (and index-pack-alist
+ (and index-package-alist
(push (cons "+Packages+..."
- (nreverse index-pack-alist))
+ (nreverse index-package-alist))
index-alist))
- (and (or index-pack-alist index-pod-alist
+ (and (or index-package-alist index-pod-alist
(default-value 'imenu-sort-function))
index-unsorted-alist
(push (cons "+Unsorted List+..."
(nreverse index-unsorted-alist))
index-alist))
- (cperl-imenu-addback index-alist)))
+ ;; Finally, return the whole collection
+ index-alist))
;; Suggested by Mark A. Hershberger
@@ -5447,16 +5427,14 @@ indentation and initial hashes. Behaves usually outside of comment."
(cond ((featurep 'ps-print)
(or cperl-faces-init
(progn
- (and (boundp 'font-lock-multiline)
- (setq cperl-font-lock-multiline t))
+ (setq cperl-font-lock-multiline t)
(cperl-init-faces))))
((not cperl-faces-init)
(add-hook 'font-lock-mode-hook
- (function
- (lambda ()
- (if (memq major-mode '(perl-mode cperl-mode))
- (progn
- (or cperl-faces-init (cperl-init-faces)))))))
+ (lambda ()
+ (if (memq major-mode '(perl-mode cperl-mode))
+ (progn
+ (or cperl-faces-init (cperl-init-faces))))))
(eval-after-load
"ps-print"
'(or cperl-faces-init (cperl-init-faces))))))
@@ -5480,27 +5458,11 @@ indentation and initial hashes. Behaves usually outside of comment."
(or cperl-faces-init (cperl-init-faces))
cperl-font-lock-keywords-2)
-(defun cperl-init-faces-weak ()
- ;; Allow `cperl-find-pods-heres' to run.
- (or (boundp 'font-lock-constant-face)
- (cperl-force-face font-lock-constant-face
- "Face for constant and label names"))
- (or (boundp 'font-lock-warning-face)
- (cperl-force-face font-lock-warning-face
- "Face for things which should stand out"))
- ;;(setq font-lock-constant-face 'font-lock-constant-face)
- )
-
(defun cperl-init-faces ()
(condition-case errs
(progn
- (require 'font-lock)
- (and (fboundp 'font-lock-fontify-anchored-keywords)
- (featurep 'font-lock-extra)
- (message "You have an obsolete package `font-lock-extra'. Install `choose-color'."))
(let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored)
- (if (fboundp 'font-lock-fontify-anchored-keywords)
- (setq font-lock-anchored t))
+ (setq font-lock-anchored t)
(setq
t-font-lock-keywords
(list
@@ -5508,121 +5470,80 @@ indentation and initial hashes. Behaves usually outside of comment."
(cons
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; FIXME: Use regexp-opt.
- (mapconcat
- #'identity
+ (regexp-opt
(append
cperl-sub-keywords
'("if" "until" "while" "elsif" "else"
- "given" "when" "default" "break"
- "unless" "for"
- "try" "catch" "finally"
- "foreach" "continue" "exit" "die" "last" "goto" "next"
- "redo" "return" "local" "exec"
- "do" "dump"
- "use" "our"
- "require" "package" "eval" "evalbytes" "my" "state"
- "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))
- "\\|") ; Flow control
+ "given" "when" "default" "break"
+ "unless" "for"
+ "try" "catch" "finally"
+ "foreach" "continue" "exit" "die" "last" "goto" "next"
+ "redo" "return" "local" "exec"
+ "do" "dump"
+ "use" "our"
+ "require" "package" "eval" "evalbytes" "my" "state"
+ "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))) ; Flow control
"\\)\\>") 2) ; was "\\)[ \n\t;():,|&]"
; In what follows we use `type' style
; for overwritable builtins
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; FIXME: Use regexp-opt.
- ;; "CORE" "__FILE__" "__LINE__" "__SUB__" "abs" "accept" "alarm"
- ;; "and" "atan2" "bind" "binmode" "bless" "caller"
- ;; "chdir" "chmod" "chown" "chr" "chroot" "close"
- ;; "closedir" "cmp" "connect" "continue" "cos" "crypt"
- ;; "dbmclose" "dbmopen" "die" "dump" "endgrent"
- ;; "endhostent" "endnetent" "endprotoent" "endpwent"
- ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl"
- ;; "fileno" "flock" "fork" "formline" "ge" "getc"
- ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"
- ;; "gethostbyname" "gethostent" "getlogin"
- ;; "getnetbyaddr" "getnetbyname" "getnetent"
- ;; "getpeername" "getpgrp" "getppid" "getpriority"
- ;; "getprotobyname" "getprotobynumber" "getprotoent"
- ;; "getpwent" "getpwnam" "getpwuid" "getservbyname"
- ;; "getservbyport" "getservent" "getsockname"
- ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
- ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
- ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt"
- ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
- ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
- ;; "quotemeta" "rand" "read" "readdir" "readline"
- ;; "readlink" "readpipe" "recv" "ref" "rename" "require"
- ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"
- ;; "seekdir" "select" "semctl" "semget" "semop" "send"
- ;; "setgrent" "sethostent" "setnetent" "setpgrp"
- ;; "setpriority" "setprotoent" "setpwent" "setservent"
- ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
- ;; "shutdown" "sin" "sleep" "socket" "socketpair"
- ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"
- ;; "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell"
- ;; "telldir" "time" "times" "truncate" "uc" "ucfirst"
- ;; "umask" "unlink" "unpack" "utime" "values" "vec"
- ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"
- "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|"
- "b\\(in\\(d\\|mode\\)\\|less\\)\\|"
- "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|"
- "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|"
- "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|"
- "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|"
- "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|"
- "f\\(ileno\\|c\\(ntl\\)?\\|lock\\|or\\(k\\|mline\\)\\)\\|"
- "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|"
- "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w"
- "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|"
- "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|"
- "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|"
- "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"
- "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"
- "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"
- "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"
- "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"
- "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"
- "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"
- "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name"
- "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r"
- "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|"
- "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|"
- "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|"
- "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\|seek\\)\\|"
- "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|"
- "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"
- "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"
- "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"
- "x\\(\\|or\\)\\|__\\(FILE\\|LINE\\|PACKAGE\\|SUB\\)__"
- "\\)\\>") 2 'font-lock-type-face)
+ (regexp-opt
+ '("CORE" "__FILE__" "__LINE__" "__SUB__" "__PACKAGE__"
+ "abs" "accept" "alarm" "and" "atan2"
+ "bind" "binmode" "bless" "caller"
+ "chdir" "chmod" "chown" "chr" "chroot" "close"
+ "closedir" "cmp" "connect" "continue" "cos" "crypt"
+ "dbmclose" "dbmopen" "die" "dump" "endgrent"
+ "endhostent" "endnetent" "endprotoent" "endpwent"
+ "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl"
+ "fileno" "flock" "fork" "formline" "ge" "getc"
+ "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"
+ "gethostbyname" "gethostent" "getlogin"
+ "getnetbyaddr" "getnetbyname" "getnetent"
+ "getpeername" "getpgrp" "getppid" "getpriority"
+ "getprotobyname" "getprotobynumber" "getprotoent"
+ "getpwent" "getpwnam" "getpwuid" "getservbyname"
+ "getservbyport" "getservent" "getsockname"
+ "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"
+ "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
+ "link" "listen" "localtime" "lock" "log" "lstat" "lt"
+ "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
+ "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
+ "quotemeta" "rand" "read" "readdir" "readline"
+ "readlink" "readpipe" "recv" "ref" "rename" "require"
+ "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"
+ "seekdir" "select" "semctl" "semget" "semop" "send"
+ "setgrent" "sethostent" "setnetent" "setpgrp"
+ "setpriority" "setprotoent" "setpwent" "setservent"
+ "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
+ "shutdown" "sin" "sleep" "socket" "socketpair"
+ "sprintf" "sqrt" "srand" "stat" "substr" "symlink"
+ "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell"
+ "telldir" "time" "times" "truncate" "uc" "ucfirst"
+ "umask" "unlink" "unpack" "utime" "values" "vec"
+ "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"))
+ "\\)\\>")
+ 2 'font-lock-type-face)
;; In what follows we use `other' style
;; for nonoverwritable builtins
- ;; Somehow 's', 'm' are not auto-generated???
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp"
- ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif"
- ;; "eval" "evalbytes" "exists" "for" "foreach" "format" "given" "goto"
- ;; "grep" "if" "keys" "last" "local" "map" "my" "next"
- ;; "no" "our" "package" "pop" "pos" "print" "printf" "prototype" "push"
- ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift"
- ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr"
- ;; "undef" "unless" "unshift" "untie" "until" "use"
- ;; "when" "while" "y"
- "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|c\\(atch\\|ho\\(p\\|mp\\)\\)\\|d\\(e\\(f\\(inally\\|ault\\|ined\\)\\|lete\\)\\|"
- "o\\)\\|DESTROY\\|e\\(ach\\|val\\(bytes\\)?\\|xists\\|ls\\(e\\|if\\)\\)\\|"
- "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|"
- "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|"
- "p\\(ackage\\|rototype\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"
- "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|"
- "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(ry?\\|ied?\\)\\|"
- "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"
- "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually
- "\\|[sm]" ; Added manually
- "\\)\\>")
- 2 'cperl-nonoverridable-face)
+ (regexp-opt
+ '("AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK"
+ "__END__" "__DATA__" "break" "catch" "chomp" "chop" "default"
+ "defined" "delete" "do" "each" "else" "elsif" "eval"
+ "evalbytes" "exists" "finally" "for" "foreach" "format" "given"
+ "goto" "grep" "if" "keys" "last" "local" "m" "map" "my" "next"
+ "no" "our" "package" "pop" "pos" "print" "printf" "prototype"
+ "push" "q" "qq" "qr" "qw" "qx" "redo" "return" "s" "say" "scalar"
+ "shift" "sort" "splice" "split" "state" "study" "sub" "tie"
+ "tied" "tr" "try" "undef" "unless" "unshift" "untie" "until"
+ "use" "when" "while" "y"))
+ "\\)\\>")
+ 2 ''cperl-nonoverridable-face) ; unbound as var, so: doubly quoted
;; (mapconcat #'identity
;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
;; "#include" "#define" "#undef")
@@ -5658,17 +5579,13 @@ indentation and initial hashes. Behaves usually outside of comment."
2 font-lock-function-name-face)
'("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"
1 font-lock-function-name-face)
- (cond ((featurep 'font-lock-extra)
- '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
- (2 font-lock-string-face t)
- (0 '(restart 2 t)))) ; To highlight $a{bc}{ef}
- (font-lock-anchored
- '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+ (cond (font-lock-anchored
+ '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
(2 font-lock-string-face t)
("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
nil nil
(1 font-lock-string-face t))))
- (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+ (t '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
2 font-lock-string-face t)))
'("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1
font-lock-string-face t)
@@ -5680,15 +5597,7 @@ indentation and initial hashes. Behaves usually outside of comment."
;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
;;; (2 (cons font-lock-variable-name-face '(underline))))
- (cond ((featurep 'font-lock-extra)
- '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
- (3 font-lock-variable-name-face)
- (4 '(another 4 nil
- ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"
- (1 font-lock-variable-name-face)
- (2 '(restart 2 nil) nil t)))
- nil t))) ; local variables, multiple
- (font-lock-anchored
+ (cond (font-lock-anchored
;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
`(,(concat "\\<\\(state\\|my\\|local\\|our\\)"
cperl-maybe-white-and-comment-rex
@@ -5752,8 +5661,8 @@ indentation and initial hashes. Behaves usually outside of comment."
(if (eq (char-after (match-beginning 2)) ?%)
'cperl-hash-face
'cperl-array-face)
- t) ; arrays and hashes
- ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+ nil) ; arrays and hashes
+ ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
1
(if (= (- (match-end 2) (match-beginning 2)) 1)
(if (eq (char-after (match-beginning 3)) ?{)
@@ -5787,167 +5696,9 @@ indentation and initial hashes. Behaves usually outside of comment."
t-font-lock-keywords)
cperl-font-lock-keywords cperl-font-lock-keywords-1
cperl-font-lock-keywords-2 (append
- cperl-font-lock-keywords-1
- t-font-lock-keywords-1)))
+ t-font-lock-keywords-1
+ cperl-font-lock-keywords-1)))
(if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
- (if (or (featurep 'choose-color) (featurep 'font-lock-extra))
- (eval ; Avoid a warning
- '(font-lock-require-faces
- (list
- ;; Color-light Color-dark Gray-light Gray-dark Mono
- (list 'font-lock-comment-face
- ["Firebrick" "OrangeRed" "DimGray" "Gray80"]
- nil
- [nil nil t t t]
- [nil nil t t t]
- nil)
- (list 'font-lock-string-face
- ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]
- nil
- nil
- [nil nil t t t]
- nil)
- (list 'font-lock-function-name-face
- (vector
- "Blue" "LightSkyBlue" "Gray50" "LightGray"
- (cdr (assq 'background-color ; if mono
- (frame-parameters))))
- (vector
- nil nil nil nil
- (cdr (assq 'foreground-color ; if mono
- (frame-parameters))))
- [nil nil t t t]
- nil
- nil)
- (list 'font-lock-variable-name-face
- ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]
- nil
- [nil nil t t t]
- [nil nil t t t]
- nil)
- (list 'font-lock-type-face
- ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]
- nil
- [nil nil t t t]
- nil
- [nil nil t t t])
- (list 'font-lock-warning-face
- ["Pink" "Red" "Gray50" "LightGray"]
- ["gray20" "gray90"
- "gray80" "gray20"]
- [nil nil t t t]
- nil
- [nil nil t t t]
- )
- (list 'font-lock-constant-face
- ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]
- nil
- [nil nil t t t]
- nil
- [nil nil t t t])
- (list 'cperl-nonoverridable-face
- ["chartreuse3" ("orchid1" "orange")
- nil "Gray80"]
- [nil nil "gray90"]
- [nil nil nil t t]
- [nil nil t t]
- [nil nil t t t])
- (list 'cperl-array-face
- ["blue" "yellow" nil "Gray80"]
- ["lightyellow2" ("navy" "os2blue" "darkgreen")
- "gray90"]
- t
- nil
- nil)
- (list 'cperl-hash-face
- ["red" "red" nil "Gray80"]
- ["lightyellow2" ("navy" "os2blue" "darkgreen")
- "gray90"]
- t
- t
- nil))))
- ;; Do it the dull way, without choose-color
- (cperl-force-face font-lock-constant-face
- "Face for constant and label names")
- (cperl-force-face font-lock-variable-name-face
- "Face for variable names")
- (cperl-force-face font-lock-type-face
- "Face for data types")
- (cperl-force-face cperl-nonoverridable-face
- "Face for data types from another group")
- (cperl-force-face font-lock-warning-face
- "Face for things which should stand out")
- (cperl-force-face font-lock-comment-face
- "Face for comments")
- (cperl-force-face font-lock-function-name-face
- "Face for function names")
- ;;(defvar font-lock-constant-face 'font-lock-constant-face)
- ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)
- ;;(or (boundp 'font-lock-type-face)
- ;; (defconst font-lock-type-face
- ;; 'font-lock-type-face
- ;; "Face to use for data types."))
- ;;(or (boundp 'cperl-nonoverridable-face)
- ;; (defconst cperl-nonoverridable-face
- ;; 'cperl-nonoverridable-face
- ;; "Face to use for data types from another group."))
- (if (and
- (not (facep 'cperl-array-face))
- (facep 'font-lock-emphasized-face))
- (copy-face 'font-lock-emphasized-face 'cperl-array-face))
- (if (and
- (not (facep 'cperl-hash-face))
- (facep 'font-lock-other-emphasized-face))
- (copy-face 'font-lock-other-emphasized-face 'cperl-hash-face))
- (if (and
- (not (facep 'cperl-nonoverridable-face))
- (facep 'font-lock-other-type-face))
- (copy-face 'font-lock-other-type-face 'cperl-nonoverridable-face))
- ;;(or (boundp 'cperl-hash-face)
- ;; (defconst cperl-hash-face
- ;; 'cperl-hash-face
- ;; "Face to use for hashes."))
- ;;(or (boundp 'cperl-array-face)
- ;; (defconst cperl-array-face
- ;; 'cperl-array-face
- ;; "Face to use for arrays."))
- (let ((background 'light))
- (and (not (facep 'font-lock-constant-face))
- (facep 'font-lock-reference-face)
- (copy-face 'font-lock-reference-face 'font-lock-constant-face))
- (if (facep 'font-lock-type-face) nil
- (copy-face 'default 'font-lock-type-face)
- (cond
- ((eq background 'light)
- (set-face-foreground 'font-lock-type-face
- (if (x-color-defined-p "seagreen")
- "seagreen"
- "sea green")))
- ((eq background 'dark)
- (set-face-foreground 'font-lock-type-face
- (if (x-color-defined-p "os2pink")
- "os2pink"
- "pink")))
- (t
- (set-face-background 'font-lock-type-face "gray90"))))
- (if (facep 'cperl-nonoverridable-face)
- nil
- (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)
- (cond
- ((eq background 'light)
- (set-face-foreground 'cperl-nonoverridable-face
- (if (x-color-defined-p "chartreuse3")
- "chartreuse3"
- "chartreuse")))
- ((eq background 'dark)
- (set-face-foreground 'cperl-nonoverridable-face
- (if (x-color-defined-p "orchid1")
- "orchid1"
- "orange")))))
- (if (facep 'font-lock-variable-name-face) nil
- (copy-face 'italic 'font-lock-variable-name-face))
- (if (facep 'font-lock-constant-face) nil
- (copy-face 'italic 'font-lock-constant-face))))
(setq cperl-faces-init t))
(error (message "cperl-init-faces (ignored): %s" errs))))
@@ -6057,7 +5808,19 @@ if (foo) {
stop;
}
-### PerlStyle (=CPerl with 4 as indent) 4/0/0/-4/4/t/nil
+### PBP (=Perl Best Practices) 4/0/0/-4/4/nil/nil
+if (foo) {
+ bar
+ baz;
+ label:
+ {
+ boon;
+ }
+}
+else {
+ stop;
+}
+### PerlStyle (=CPerl with 4 as indent) 4/0/0/-2/4/t/nil
if (foo) {
bar
baz;
@@ -6160,6 +5923,19 @@ else
(cperl-extra-newline-before-brace-multiline . nil)
(cperl-merge-trailing-else . t))
+ ("PBP" ;; Perl Best Practices by Damian Conway
+ (cperl-indent-level . 4)
+ (cperl-brace-offset . 0)
+ (cperl-continued-brace-offset . 0)
+ (cperl-label-offset . -2)
+ (cperl-continued-statement-offset . 4)
+ (cperl-close-paren-offset . -4)
+ (cperl-extra-newline-before-brace . nil)
+ (cperl-extra-newline-before-brace-multiline . nil)
+ (cperl-merge-trailing-else . nil)
+ (cperl-indent-parens-as-block . t)
+ (cperl-tab-always-indent . t))
+
("PerlStyle" ; CPerl with 4 as indent
(cperl-indent-level . 4)
(cperl-brace-offset . 0)
@@ -6231,7 +6007,8 @@ See examples in `cperl-style-examples'.")
"Set CPerl mode variables to use one of several different indentation styles.
The arguments are a string representing the desired style.
The list of styles is in `cperl-style-alist', available styles
-are CPerl, PerlStyle, GNU, K&R, BSD, C++ and Whitesmith.
+are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\"
+and \"Whitesmith\".
The current value of style is memorized (unless there is a memorized
data already), may be restored by `cperl-set-style-back'.
@@ -6242,9 +6019,8 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
(list (completing-read "Enter style: " cperl-style-alist nil 'insist)))
(or cperl-old-style
(setq cperl-old-style
- (mapcar (function
- (lambda (name)
- (cons name (eval name))))
+ (mapcar (lambda (name)
+ (cons name (eval name)))
cperl-styles-entries)))
(let ((style (cdr (assoc style cperl-style-alist))) setting)
(while style
@@ -6294,7 +6070,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
(set-buffer "*info-perl-tmp*")
(rename-buffer "*info*")
(set-buffer bname)))
- (set (make-local-variable 'window-min-height) 2)
+ (setq-local window-min-height 2)
(current-buffer)))))
(defun cperl-word-at-point (&optional p)
@@ -6317,8 +6093,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
(interactive
(let* ((default (cperl-word-at-point))
(read (read-string
- (format "Find doc for Perl function (default %s): "
- default))))
+ (cperl--format-prompt "Find doc for Perl function" default))))
(list (if (equal read "")
default
read))))
@@ -6499,9 +6274,10 @@ If optional argument ALL is `recursive', will process Perl files
in subdirectories too."
(interactive)
(let ((cmd "etags")
- (args '("-l" "none" "-r"
+ (args `("-l" "none" "-r"
;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!)
- "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/"
+ ,(concat
+ "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/")
"-r"
"/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/"
"-r"
@@ -6612,7 +6388,7 @@ by CPerl."
(if cperl-use-syntax-table-text-property-for-tags
(progn
;; Do not introduce variable if not needed, we check it!
- (set (make-local-variable 'parse-sexp-lookup-properties) t))))
+ (setq-local parse-sexp-lookup-properties t))))
;; Copied from imenu-example--name-and-position.
(defvar imenu-use-markers)
@@ -6696,22 +6472,21 @@ Does not move point."
(setq lst (cdr (assoc "+Unsorted List+..." ind))))
(setq lst
(mapcar
- (function
- (lambda (elt)
- (cond ((string-match "^[_a-zA-Z]" (car elt))
- (goto-char (cdr elt))
- (beginning-of-line) ; pos should be of the start of the line
- (list (car elt)
- (point)
- (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
- (buffer-substring (progn
- (goto-char (cdr elt))
- ;; After name now...
- (or (eolp) (forward-char 1))
- (point))
- (progn
- (beginning-of-line)
- (point))))))))
+ (lambda (elt)
+ (cond ((string-match "^[_a-zA-Z]" (car elt))
+ (goto-char (cdr elt))
+ (beginning-of-line) ; pos should be of the start of the line
+ (list (car elt)
+ (point)
+ (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
+ (buffer-substring (progn
+ (goto-char (cdr elt))
+ ;; After name now...
+ (or (eolp) (forward-char 1))
+ (point))
+ (progn
+ (beginning-of-line)
+ (point)))))))
lst))
(erase-buffer)
(while lst
@@ -6754,7 +6529,7 @@ Does not move point."
(defun cperl-add-tags-recurse-noxs ()
"Add to TAGS data for \"pure\" Perl files in the current directory and kids.
Use as
- emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\
-f cperl-add-tags-recurse-noxs
"
(cperl-write-tags nil nil t t nil t))
@@ -6763,7 +6538,7 @@ Use as
"Add to TAGS data for \"pure\" Perl in the current directory and kids.
Writes down fullpath, so TAGS is relocatable (but if the build directory
is relocated, the file TAGS inside it breaks). Use as
- emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\
-f cperl-add-tags-recurse-noxs-fullpath
"
(cperl-write-tags nil nil t t nil t ""))
@@ -6771,11 +6546,14 @@ is relocated, the file TAGS inside it breaks). Use as
(defun cperl-add-tags-recurse ()
"Add to TAGS file data for Perl files in the current directory and kids.
Use as
- emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\
-f cperl-add-tags-recurse
"
(cperl-write-tags nil nil t t))
+(defvar cperl-tags-file-name "TAGS"
+ "TAGS file name to use in `cperl-write-tags'.")
+
(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir)
;; If INBUFFER, do not select buffer, and do not save
;; If ERASE is `ignore', do not erase, and do not try to delete old info.
@@ -6785,7 +6563,8 @@ Use as
(if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))
(or topdir
(setq topdir default-directory))
- (let ((tags-file-name "TAGS")
+ (let ((tags-file-name cperl-tags-file-name)
+ (inhibit-read-only t)
(case-fold-search nil)
xs rel)
(save-excursion
@@ -6813,16 +6592,15 @@ Use as
(setq cperl-unreadable-ok t)
nil) ; Return empty list
(error "Aborting: unreadable directory %s" file)))))))
- (mapc (function
- (lambda (file)
- (cond
- ((string-match cperl-noscan-files-regexp file)
- nil)
- ((not (file-directory-p file))
- (if (string-match cperl-scan-files-regexp file)
- (cperl-write-tags file erase recurse nil t noxs topdir)))
- ((not recurse) nil)
- (t (cperl-write-tags file erase recurse t t noxs topdir)))))
+ (mapc (lambda (file)
+ (cond
+ ((string-match cperl-noscan-files-regexp file)
+ nil)
+ ((not (file-directory-p file))
+ (if (string-match cperl-scan-files-regexp file)
+ (cperl-write-tags file erase recurse nil t noxs topdir)))
+ ((not recurse) nil)
+ (t (cperl-write-tags file erase recurse t t noxs topdir))))
files)))
(t
(setq xs (string-match "\\.xs$" file))
@@ -6851,7 +6629,7 @@ Use as
(insert (cperl-find-tags file xs topdir))))))
(if inbuffer nil ; Delegate to the caller
(save-buffer 0) ; No backup
- (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
+ (if (fboundp 'initialize-new-tags-table)
(initialize-new-tags-table))))))
(defvar cperl-tags-hier-regexp-list
@@ -6926,21 +6704,20 @@ One may build such TAGS files from CPerl mode menu."
(require 'etags)
(require 'imenu)
(if (or update (null (nth 2 cperl-hierarchy)))
- (let ((remover (function (lambda (elt) ; (name (file1...) (file2..))
- (or (nthcdr 2 elt)
- ;; Only in one file
- (setcdr elt (cdr (nth 1 elt)))))))
- to l1 l2 l3)
+ (let ((remover (lambda (elt) ; (name (file1...) (file2..))
+ (or (nthcdr 2 elt)
+ ;; Only in one file
+ (setcdr elt (cdr (nth 1 elt))))))
+ to) ;; l1 l2 l3
;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
- (setq cperl-hierarchy (list l1 l2 l3))
+ (setq cperl-hierarchy (list () () ())) ;; (list l1 l2 l3)
(or tags-table-list
(call-interactively 'visit-tags-table))
(mapc
- (function
- (lambda (tagsfile)
- (message "Updating list of classes... %s" tagsfile)
- (set-buffer (get-file-buffer tagsfile))
- (cperl-tags-hier-fill)))
+ (lambda (tagsfile)
+ (message "Updating list of classes... %s" tagsfile)
+ (set-buffer (get-file-buffer tagsfile))
+ (cperl-tags-hier-fill))
tags-table-list)
(message "Updating list of classes... postprocessing...")
(mapc remover (car cperl-hierarchy))
@@ -6950,9 +6727,7 @@ One may build such TAGS files from CPerl mode menu."
(cperl-tags-treeify to 1)
(setcar (nthcdr 2 cperl-hierarchy)
(cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))
- (message "Updating list of classes: done, requesting display...")
- ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))
- ))
+ (message "Updating list of classes: done, requesting display...")))
(or (nth 2 cperl-hierarchy)
(error "No items found"))
(setq update
@@ -6981,61 +6756,60 @@ One may build such TAGS files from CPerl mode menu."
"\\)\\(::\\)?"))
(packages (cdr (nth 1 to)))
(methods (cdr (nth 2 to)))
- l1 head cons1 cons2 ord writeto recurse
+ head cons1 cons2 ord writeto recurse ;; l1
root-packages root-functions
(move-deeper
- (function
- (lambda (elt)
- (cond ((and (string-match regexp (car elt))
- (or (eq ord 1) (match-end 2)))
- (setq head (substring (car elt) 0 (match-end 1))
- recurse t)
- (if (setq cons1 (assoc head writeto)) nil
- ;; Need to init new head
- (setcdr writeto (cons (list head (list "Packages: ")
- (list "Methods: "))
- (cdr writeto)))
- (setq cons1 (nth 1 writeto)))
- (setq cons2 (nth ord cons1)) ; Either packs or meths
- (setcdr cons2 (cons elt (cdr cons2))))
- ((eq ord 2)
- (setq root-functions (cons elt root-functions)))
- (t
- (setq root-packages (cons elt root-packages))))))))
- (setcdr to l1) ; Init to dynamic space
+ (lambda (elt)
+ (cond ((and (string-match regexp (car elt))
+ (or (eq ord 1) (match-end 2)))
+ (setq head (substring (car elt) 0 (match-end 1))
+ recurse t)
+ (if (setq cons1 (assoc head writeto)) nil
+ ;; Need to init new head
+ (setcdr writeto (cons (list head (list "Packages: ")
+ (list "Methods: "))
+ (cdr writeto)))
+ (setq cons1 (nth 1 writeto)))
+ (setq cons2 (nth ord cons1)) ; Either packs or meths
+ (setcdr cons2 (cons elt (cdr cons2))))
+ ((eq ord 2)
+ (setq root-functions (cons elt root-functions)))
+ (t
+ (setq root-packages (cons elt root-packages)))))))
+ (setcdr to nil) ;; l1 ; Init to dynamic space
(setq writeto to)
(setq ord 1)
(mapc move-deeper packages)
(setq ord 2)
(mapc move-deeper methods)
(if recurse
- (mapc (function (lambda (elt)
- (cperl-tags-treeify elt (1+ level))))
+ (mapc (lambda (elt)
+ (cperl-tags-treeify elt (1+ level)))
(cdr to)))
;;Now clean up leaders with one child only
- (mapc (function (lambda (elt)
- (if (not (and (listp (cdr elt))
- (eq (length elt) 2)))
- nil
- (setcar elt (car (nth 1 elt)))
- (setcdr elt (cdr (nth 1 elt))))))
+ (mapc (lambda (elt)
+ (if (not (and (listp (cdr elt))
+ (eq (length elt) 2)))
+ nil
+ (setcar elt (car (nth 1 elt)))
+ (setcdr elt (cdr (nth 1 elt)))))
(cdr to))
;; Sort the roots of subtrees
(if (default-value 'imenu-sort-function)
(setcdr to
(sort (cdr to) (default-value 'imenu-sort-function))))
;; Now add back functions removed from display
- (mapc (function (lambda (elt)
- (setcdr to (cons elt (cdr to)))))
+ (mapc (lambda (elt)
+ (setcdr to (cons elt (cdr to))))
(if (default-value 'imenu-sort-function)
(nreverse
(sort root-functions (default-value 'imenu-sort-function)))
root-functions))
;; Now add back packages removed from display
- (mapc (function (lambda (elt)
- (setcdr to (cons (cons (concat "package " (car elt))
- (cdr elt))
- (cdr to)))))
+ (mapc (lambda (elt)
+ (setcdr to (cons (cons (concat "package " (car elt))
+ (cdr elt))
+ (cdr to))))
(if (default-value 'imenu-sort-function)
(nreverse
(sort root-packages (default-value 'imenu-sort-function)))
@@ -7071,16 +6845,15 @@ One may build such TAGS files from CPerl mode menu."
(let (list)
(cons 'keymap
(mapcar
- (function
- (lambda (elt)
- (cond ((listp (cdr elt))
- (setq list (cperl-list-fold
- (cdr elt) (car elt) imenu-max-items))
- (cons nil
- (cons (car elt)
- (cperl-menu-to-keymap list))))
- (t
- (list (cdr elt) (car elt) t))))) ; t is needed in 19.34
+ (lambda (elt)
+ (cond ((listp (cdr elt))
+ (setq list (cperl-list-fold
+ (cdr elt) (car elt) imenu-max-items))
+ (cons nil
+ (cons (car elt)
+ (cperl-menu-to-keymap list))))
+ (t
+ (list (cdr elt) (car elt) t)))) ; t is needed in 19.34
(cperl-list-fold menu "Root" imenu-max-items)))))
@@ -7456,8 +7229,7 @@ $~ The name of the current report format.
... >= ... Numeric greater than or equal to.
... >> ... Bitwise shift right.
... >>= ... Bitwise shift right assignment.
-... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.
-?PATTERN? One-time pattern match.
+... ? ... : ... Condition=if-then-else operator.
@ARGV Command line arguments (not including the command name - see $0).
@INC List of places to look for perl scripts during do/include/use.
@_ Parameter array for subroutines; result of split() unless in list context.
@@ -7484,6 +7256,7 @@ __DATA__ Ends program source.
__FILE__ Current (source) filename.
__LINE__ Current line in current source.
__PACKAGE__ Current package.
+__SUB__ Current sub.
ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.
ARGVOUT Output filehandle with -i flag.
BEGIN { ... } Immediately executed (during compilation) piece of code.
@@ -7749,14 +7522,17 @@ use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
prototype \\&SUB Returns prototype of the function given a reference.
=head1 Top-level heading.
=head2 Second-level heading.
-=head3 Third-level heading (is there such?).
+=head3 Third-level heading.
+=head4 Fourth-level heading.
=over [ NUMBER ] Start list.
=item [ TITLE ] Start new item in the list.
=back End list.
=cut Switch from POD to Perl.
=pod Switch from Perl to POD.
-=begin Switch from Perl6 to POD.
-=end Switch from POD to Perl6.
+=begin formatname Start directly formatted region.
+=end formatname End directly formatted region.
+=for formatname text Paragraph in special format.
+=encoding encodingname Encoding of the document.
")
(defun cperl-switch-to-doc-buffer (&optional interactive)
@@ -8275,10 +8051,7 @@ the appropriate statement modifier."
(interactive
(list (let* ((default-entry (cperl-word-at-point))
(input (read-string
- (format "perldoc entry%s: "
- (if (string= default-entry "")
- ""
- (format " (default %s)" default-entry))))))
+ (cperl--format-prompt "perldoc entry" default-entry))))
(if (string= input "")
(if (string= default-entry "")
(error "No perldoc args given")
@@ -8335,7 +8108,7 @@ the appropriate statement modifier."
(defun cperl-pod2man-build-command ()
"Builds the entire background manpage and cleaning command."
- (let ((command (concat pod2man-program " %s 2>/dev/null"))
+ (let ((command (concat pod2man-program " %s 2>" null-device))
(flist (and (boundp 'Man-filter-list) Man-filter-list)))
(while (and flist (car flist))
(let ((pcom (car (car flist)))
@@ -8382,11 +8155,11 @@ a result of qr//, this is not a performance hit), t for the rest."
(and (eq (get-text-property beg 'syntax-type) 'string)
(setq beg (next-single-property-change beg 'syntax-type nil limit)))
(cperl-map-pods-heres
- (function (lambda (s _e _p)
- (if (memq (get-text-property s 'REx-interpolated) skip)
- t
- (setq pp s)
- nil))) ; nil stops
+ (lambda (s _e _p)
+ (if (memq (get-text-property s 'REx-interpolated) skip)
+ t
+ (setq pp s)
+ nil)) ; nil stops
'REx-interpolated beg limit)
(if pp (goto-char pp)
(message "No more interpolated REx"))))
@@ -8410,15 +8183,14 @@ If a region is highlighted, restricts to the region."
end (max (mark) (point)))
(setq beg (point-min)
end (point-max)))
- (cperl-map-pods-heres (function
- (lambda (s e _p)
- (if do-heres
- (setq e (save-excursion
- (goto-char e)
- (forward-line -1)
- (point))))
- (ispell-region s e)
- t))
+ (cperl-map-pods-heres (lambda (s e _p)
+ (if do-heres
+ (setq e (save-excursion
+ (goto-char e)
+ (forward-line -1)
+ (point))))
+ (ispell-region s e)
+ t)
(if do-heres 'here-doc-group 'in-pod)
beg end))))
@@ -8430,7 +8202,7 @@ function returns nil."
(or prop (setq prop 'in-pod))
(or s (setq s (point-min)))
(or end (setq end (point-max)))
- (cperl-update-syntaxification end end)
+ (cperl-update-syntaxification end)
(save-excursion
(goto-char (setq pos s))
(while (and cont (< pos end))
@@ -8446,7 +8218,7 @@ function returns nil."
Return nil if the point is not in a HERE document region. If POD is non-nil,
will return a POD section if point is in a POD section."
(or pos (setq pos (point)))
- (cperl-update-syntaxification pos pos)
+ (cperl-update-syntaxification pos)
(if (or (eq 'here-doc (get-text-property pos 'syntax-type))
(and pod
(eq 'pod (get-text-property pos 'syntax-type))))
@@ -8505,7 +8277,7 @@ start with default arguments, then refine the slowdown regions."
(or l (setq l 1))
(or step (setq step 500))
(or lim (setq lim 40))
- (let* ((timems (function (lambda () (car (time-convert nil 1000)))))
+ (let* ((timems (lambda () (car (cperl--time-convert nil 1000))))
(tt (funcall timems)) (c 0) delta tot)
(goto-char (point-min))
(forward-line (1- l))
@@ -8516,7 +8288,7 @@ start with default arguments, then refine the slowdown regions."
(forward-line step)
(setq l (+ l step))
(setq c (1+ c))
- (cperl-update-syntaxification (point) (point))
+ (cperl-update-syntaxification (point))
(setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta))
(message "to %s:%6s,%7s" l delta tot))
tot))
@@ -8539,7 +8311,7 @@ may be used to debug problems with delayed incremental fontification."
(goto-char pos)
(normal-mode)
;; Why needed??? With older font-locks???
- (set (make-local-variable 'font-lock-cache-position) (make-marker))
+ (setq-local font-lock-cache-position (make-marker))
(while (if (> window-size 0)
(< pos (point-max))
(> pos (point-min)))
@@ -8626,19 +8398,12 @@ do extra unwind via `cperl-unwind-to-safe'."
(setq end (point)))
(font-lock-default-fontify-region beg end loudly))
-(defvar cperl-d-l nil)
-(defvar edebug-backtrace-buffer) ;FIXME: Why?
-(defun cperl-fontify-syntaxically (end)
+(defun cperl-fontify-syntactically (end)
;; Some vars for debugging only
;; (message "Syntaxifying...")
(let ((dbg (point)) (iend end) (idone cperl-syntax-done-to)
(istate (car cperl-syntax-state))
- start from-start edebug-backtrace-buffer)
- (if (eq cperl-syntaxify-by-font-lock 'backtrace)
- (progn
- (require 'edebug)
- (let ((f 'edebug-backtrace))
- (funcall f)))) ; Avoid compile-time warning
+ start from-start)
(or cperl-syntax-done-to
(setq cperl-syntax-done-to (point-min)
from-start t))
@@ -8694,22 +8459,20 @@ do extra unwind via `cperl-unwind-to-safe'."
(if cperl-syntax-done-to
(setq cperl-syntax-done-to (min cperl-syntax-done-to beg))))
-(defun cperl-update-syntaxification (from to)
- (cond
- ((not cperl-use-syntax-table-text-property) nil)
- ((fboundp 'syntax-propertize) (syntax-propertize to))
- ((and cperl-syntaxify-by-font-lock
- (or (null cperl-syntax-done-to)
- (< cperl-syntax-done-to to)))
- (save-excursion
- (goto-char from)
- (cperl-fontify-syntaxically to)))))
+(defun cperl-update-syntaxification (to)
+ (when cperl-use-syntax-table-text-property
+ (syntax-propertize to)))
(defvar cperl-version
(let ((v "Revision: 6.2"))
(string-match ":\\s *\\([0-9.]+\\)" v)
(substring v (match-beginning 1) (match-end 1)))
"Version of IZ-supported CPerl package this file is based on.")
+(make-obsolete-variable 'cperl-version 'emacs-version "28.1")
+
+(defvar cperl-do-not-fontify 'fontified
+ "Text property which inhibits refontification.")
+(make-obsolete-variable 'cperl-do-not-fontify nil "28.1")
(provide 'cperl-mode)
diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el
index f60f9dcc8a3..6602a79b2a4 100644
--- a/lisp/progmodes/cpp.el
+++ b/lisp/progmodes/cpp.el
@@ -1,4 +1,4 @@
-;;; cpp.el --- highlight or hide text according to cpp conditionals
+;;; cpp.el --- highlight or hide text according to cpp conditionals -*- lexical-binding: t -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
@@ -53,8 +53,7 @@
(defcustom cpp-config-file (convert-standard-filename ".cpp.el")
"File name to save cpp configuration."
- :type 'file
- :group 'cpp)
+ :type 'file)
(define-widget 'cpp-face 'lazy
"Either a face or the special symbol `invisible'."
@@ -62,13 +61,11 @@
(defcustom cpp-known-face 'invisible
"Face used for known cpp symbols."
- :type 'cpp-face
- :group 'cpp)
+ :type 'cpp-face)
(defcustom cpp-unknown-face 'highlight
"Face used for unknown cpp symbols."
- :type 'cpp-face
- :group 'cpp)
+ :type 'cpp-face)
(defcustom cpp-face-type 'light
"Indicate what background face type you prefer.
@@ -76,18 +73,15 @@ Can be either light or dark for color screens, mono for monochrome
screens, and none if you don't use a window system and don't have
a color-capable display."
:options '(light dark mono nil)
- :type 'symbol
- :group 'cpp)
+ :type 'symbol)
(defcustom cpp-known-writable t
"Non-nil means you are allowed to modify the known conditionals."
- :type 'boolean
- :group 'cpp)
+ :type 'boolean)
(defcustom cpp-unknown-writable t
"Non-nil means you are allowed to modify the unknown conditionals."
- :type 'boolean
- :group 'cpp)
+ :type 'boolean)
(defcustom cpp-edit-list nil
"Alist of cpp macros and information about how they should be displayed.
@@ -101,20 +95,17 @@ Each entry is a list with the following elements:
(cpp-face :tag "False")
(choice (const :tag "True branch writable" t)
(const :tag "False branch writable" nil)
- (const :tag "Both branches writable" both))))
- :group 'cpp)
+ (const :tag "Both branches writable" both)))))
(defcustom cpp-message-min-time-interval 1.0
"Minimum time interval in seconds for `cpp-progress-message' messages.
If nil, `cpp-progress-message' prints no progress messages."
:type '(choice (const :tag "Disable progress messages" nil)
float)
- :group 'cpp
:version "26.1")
-(defvar cpp-overlay-list nil)
-;; List of cpp overlays active in the current buffer.
-(make-variable-buffer-local 'cpp-overlay-list)
+(defvar-local cpp-overlay-list nil
+ "List of cpp overlays active in the current buffer.")
(defvar cpp-callback-data)
(defvar cpp-state-stack)
@@ -134,9 +125,8 @@ If nil, `cpp-progress-message' prints no progress messages."
(defvar cpp-button-event nil)
;; This will be t in the callback for `cpp-make-button'.
-(defvar cpp-edit-buffer nil)
-;; Real buffer whose cpp display information we are editing.
-(make-variable-buffer-local 'cpp-edit-buffer)
+(defvar-local cpp-edit-buffer nil
+ "Real buffer whose cpp display information we are editing.")
(defconst cpp-branch-list
;; Alist of branches.
@@ -155,36 +145,31 @@ or a cons cell (background-color . COLOR)."
:value-type (choice face
(const invisible)
(cons (const background-color)
- (string :tag "Color"))))
- :group 'cpp)
+ (string :tag "Color")))))
(defcustom cpp-face-light-name-list
'("light gray" "light blue" "light cyan" "light yellow" "light pink"
"pale green" "beige" "orange" "magenta" "violet" "medium purple"
"turquoise")
"Background colors useful with dark foreground colors."
- :type '(repeat string)
- :group 'cpp)
+ :type '(repeat string))
(defcustom cpp-face-dark-name-list
'("dim gray" "blue" "cyan" "yellow" "red"
"dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple"
"dark turquoise")
"Background colors useful with light foreground colors."
- :type '(repeat string)
- :group 'cpp)
+ :type '(repeat string))
(defcustom cpp-face-light-list nil
"Alist of names and faces to be used for light backgrounds."
:type '(repeat (cons string (choice face
- (cons (const background-color) string))))
- :group 'cpp)
+ (cons (const background-color) string)))))
(defcustom cpp-face-dark-list nil
"Alist of names and faces to be used for dark backgrounds."
:type '(repeat (cons string (choice face
- (cons (const background-color) string))))
- :group 'cpp)
+ (cons (const background-color) string)))))
(defcustom cpp-face-mono-list
'(("bold" . bold)
@@ -192,15 +177,13 @@ or a cons cell (background-color . COLOR)."
("italic" . italic)
("underline" . underline))
"Alist of names and faces to be used for monochrome screens."
- :type '(repeat (cons string face))
- :group 'cpp)
+ :type '(repeat (cons string face)))
(defcustom cpp-face-none-list
'(("default" . default)
("invisible" . invisible))
"Alist of names and faces available even if you don't use a window system."
- :type '(repeat (cons string cpp-face))
- :group 'cpp)
+ :type '(repeat (cons string cpp-face)))
(defvar cpp-face-all-list
(append cpp-face-light-list
@@ -211,9 +194,8 @@ or a cons cell (background-color . COLOR)."
;;; Parse Buffer:
-(defvar cpp-parse-symbols nil
+(defvar-local cpp-parse-symbols nil
"List of cpp macros used in the local buffer.")
-(make-variable-buffer-local 'cpp-parse-symbols)
(defconst cpp-parse-regexp
;; Regexp matching all tokens needed to find conditionals.
@@ -471,9 +453,8 @@ A prefix arg suppresses display of that buffer."
-(defvar cpp-edit-symbols nil)
-;; Symbols defined in the edit buffer.
-(make-variable-buffer-local 'cpp-edit-symbols)
+(defvar-local cpp-edit-symbols nil
+ "Symbols defined in the edit buffer.")
(define-derived-mode cpp-edit-mode fundamental-mode "CPP Edit"
"Major mode for editing the criteria for highlighting cpp conditionals.
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index 7529c8daf1d..7fd592fb2e1 100644
--- a/lisp/progmodes/cwarn.el
+++ b/lisp/progmodes/cwarn.el
@@ -1,10 +1,10 @@
-;;; cwarn.el --- highlight suspicious C and C++ constructions
+;;; cwarn.el --- highlight suspicious C and C++ constructions -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Author: Anders Lindgren
;; Keywords: c, languages, faces
-;; Version: 1.3.1
+;; Old-Version: 1.3.1
;; This file is part of GNU Emacs.
@@ -104,8 +104,6 @@
;;{{{ Dependencies
-(require 'custom)
-(require 'font-lock)
(require 'cc-mode)
;;}}}
@@ -130,8 +128,7 @@ on one of three forms:
See variable `cwarn-font-lock-feature-keywords-alist' for available
features."
- :type '(repeat sexp)
- :group 'cwarn)
+ :type '(repeat sexp))
(defcustom cwarn-font-lock-feature-keywords-alist
'((assign . cwarn-font-lock-assignment-keywords)
@@ -144,15 +141,13 @@ keyword list."
:type '(alist :key-type (choice (const assign)
(const semicolon)
(const reference))
- :value-type (sexp :tag "Value"))
- :group 'cwarn)
+ :value-type (sexp :tag "Value")))
(defcustom cwarn-verbose t
"When nil, CWarn mode will not generate any messages.
Currently, messages are generated when the mode is activated and
deactivated."
- :group 'cwarn
:type 'boolean)
(defcustom cwarn-mode-text " CWarn"
@@ -160,14 +155,14 @@ deactivated."
\(When the string is not empty, make sure that it has a leading space.)"
:tag "CWarn mode text" ; To separate it from `global-...'
- :group 'cwarn
:type 'string)
(defcustom cwarn-load-hook nil
"Functions to run when CWarn mode is first loaded."
:tag "Load Hook"
- :group 'cwarn
:type 'hook)
+(make-obsolete-variable 'cwarn-load-hook
+ "use `with-eval-after-load' instead." "28.1")
;;}}}
;;{{{ The modes
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index fa35c726839..ed024f24344 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1,4 +1,4 @@
-;;; dcl-mode.el --- major mode for editing DCL command files
+;;; dcl-mode.el --- major mode for editing DCL command files -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -23,28 +23,23 @@
;;; Commentary:
-;; DCL mode is a package for editing DCL command files. It helps you
-;; indent lines, add leading `$' and trailing `-', move around in the
-;; code and insert lexical functions.
+;; DCL mode is a package for editing
+;; [DCL](https://en.wikipedia.org/wiki/DIGITAL_Command_Language)
+;; command files.
+;; It helps you indent lines, add leading `$' and trailing `-', move
+;; around in the code and insert lexical functions.
;;
;; Type `C-h m' when you are editing a .COM file to get more
;; information about this mode.
;;
-;; To use templates you will need a version of tempo.el that is at
-;; least later than the buggy 1.1.1, which was included with my versions of
-;; Emacs. I used version 1.2.4.
-;; The latest tempo.el distribution can be fetched from
-;; ftp.lysator.liu.se in the directory /pub/emacs.
+;; Support for templates is based on the built-in tempo.el.
;; I recommend setting (setq tempo-interactive t). This will make
;; tempo prompt you for values to put in the blank spots in the templates.
;;
-;; There is limited support for imenu. The limitation is that you need
-;; a version of imenu.el that uses imenu-generic-expression. I found
-;; the version I use in Emacs 19.30. (It was *so* much easier to hook
-;; into that version than the one in 19.27...)
+;; There is limited support for imenu.
;;
;; Any feedback will be welcomed. If you write functions for
-;; dcl-calc-command-indent-function or dcl-calc-cont-indent-function,
+;; `dcl-calc-command-indent-function' or `dcl-calc-cont-indent-function',
;; please send them to the maintainer.
;;
;;
@@ -100,12 +95,11 @@ Presently this includes some syntax, .OP.erators, and \"f$\" lexicals.")
(defcustom dcl-basic-offset 4
"Number of columns to indent a block in DCL.
A block is the commands between THEN-ELSE-ENDIF and between the commands
-dcl-block-begin-regexp and dcl-block-end-regexp.
+`dcl-block-begin-regexp' and `dcl-block-end-regexp'.
The meaning of this variable may be changed if
-dcl-calc-command-indent-function is set to a function."
- :type 'integer
- :group 'dcl)
+`dcl-calc-command-indent-function' is set to a function."
+ :type 'integer)
(defcustom dcl-continuation-offset 6
@@ -113,9 +107,8 @@ dcl-calc-command-indent-function is set to a function."
A continuation line is a line that follows a line ending with `-'.
The meaning of this variable may be changed if
-dcl-calc-cont-indent-function is set to a function."
- :type 'integer
- :group 'dcl)
+`dcl-calc-cont-indent-function' is set to a function."
+ :type 'integer)
(defcustom dcl-margin-offset 8
@@ -124,37 +117,32 @@ The first command line in a file or after a SUBROUTINE statement is indented
this much. Other command lines are indented the same number of columns as
the preceding command line.
A command line is a line that starts with `$'."
- :type 'integer
- :group 'dcl)
+ :type 'integer)
(defcustom dcl-margin-label-offset 2
"Number of columns to indent a margin label in DCL.
A margin label is a label that doesn't begin or end a block, i.e. it
-doesn't match dcl-block-begin-regexp or dcl-block-end-regexp."
- :type 'integer
- :group 'dcl)
+doesn't match `dcl-block-begin-regexp' or `dcl-block-end-regexp'."
+ :type 'integer)
(defcustom dcl-comment-line-regexp "^\\$!"
"Regexp describing the start of a comment line in DCL.
Comment lines are not indented."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-block-begin-regexp "loop[0-9]*:"
"Regexp describing a command that begins an indented block in DCL.
Set to nil to only indent at THEN-ELSE-ENDIF."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-block-end-regexp "endloop[0-9]*:"
"Regexp describing a command that ends an indented block in DCL.
Set to nil to only indent at THEN-ELSE-ENDIF."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-calc-command-indent-function nil
@@ -183,10 +171,9 @@ If this variable is nil, the indentation is calculated as
CUR-INDENT + EXTRA-INDENT.
This package includes two functions suitable for this:
- dcl-calc-command-indent-multiple
- dcl-calc-command-indent-hang"
- :type '(choice (const nil) function)
- :group 'dcl)
+ `dcl-calc-command-indent-multiple'
+ `dcl-calc-command-indent-hang'"
+ :type '(choice (const nil) function))
(defcustom dcl-calc-cont-indent-function 'dcl-calc-cont-indent-relative
@@ -202,9 +189,8 @@ If this variable is nil, the indentation is calculated as
CUR-INDENT + EXTRA-INDENT.
This package includes one function suitable for this:
- dcl-calc-cont-indent-relative"
- :type 'function
- :group 'dcl)
+ `dcl-calc-cont-indent-relative'"
+ :type 'function)
(defcustom dcl-tab-always-indent t
@@ -213,50 +199,41 @@ If t, pressing TAB always indents the current line.
If nil, pressing TAB indents the current line if point is at the left margin.
Data lines (i.e. lines not part of a command line or continuation line) are
never indented."
- :type 'boolean
- :group 'dcl)
+ :type 'boolean)
(defcustom dcl-electric-characters t
"Non-nil means reindent immediately when a label, ELSE or ENDIF is inserted."
- :type 'boolean
- :group 'dcl)
+ :type 'boolean)
(defcustom dcl-tempo-comma ", "
"Text to insert when a comma is needed in a template, in DCL mode."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-tempo-left-paren "("
"Text to insert when a left parenthesis is needed in a template in DCL."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-tempo-right-paren ")"
"Text to insert when a right parenthesis is needed in a template in DCL."
- :type 'string
- :group 'dcl)
+ :type 'string)
; I couldn't decide what looked best, so I'll let you decide...
; Remember, you can also customize this with imenu-submenu-name-format.
(defcustom dcl-imenu-label-labels "Labels"
"Imenu menu title for sub-listing with label names."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-imenu-label-goto "GOTO"
"Imenu menu title for sub-listing with GOTO statements."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-imenu-label-gosub "GOSUB"
"Imenu menu title for sub-listing with GOSUB statements."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-imenu-label-call "CALL"
"Imenu menu title for sub-listing with CALL statements."
- :type 'string
- :group 'dcl)
+ :type 'string)
(defcustom dcl-imenu-generic-expression
`((nil "^\\$[ \t]*\\([A-Za-z0-9_$]+\\):[ \t]+SUBROUTINE\\b" 1)
@@ -270,14 +247,12 @@ never indented."
The default includes SUBROUTINE labels in the main listing and
sub-listings for other labels, CALL, GOTO and GOSUB statements.
See `imenu-generic-expression' for details."
- :type '(repeat (sexp :tag "Imenu Expression"))
- :group 'dcl)
+ :type '(repeat (sexp :tag "Imenu Expression")))
(defcustom dcl-mode-hook nil
"Hook called by `dcl-mode'."
- :type 'hook
- :group 'dcl)
+ :type 'hook)
;;; *** Global variables ****************************************************
@@ -297,83 +272,59 @@ See `imenu-generic-expression' for details."
(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))))
+ (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)
map)
"Keymap used in DCL-mode buffers.")
+(easy-menu-define dcl-mode-menu dcl-mode-map
+ "Menu for DCL-mode buffers."
+ '("DCL"
+ ["Buffer index menu" imenu]
+ "---"
+ ["Beginning of statement" dcl-backward-command]
+ ["End of statement" dcl-forward-command]
+ ["Back to indentation" dcl-back-to-indentation]
+ ["Indent line/insert tab" dcl-tab]
+ ["Indent command" dcl-indent-command]
+ ["Split line" dcl-split-line]
+ ["Delete indentation" dcl-delete-indentation]
+ "---"
+ ["Set option" dcl-set-option]
+ ["Save changed options" dcl-save-nondefault-options]
+ ["Save all options" dcl-save-all-options]
+ "---"
+ ["Complete template tag" tempo-complete-tag]
+ ["Next template mark" tempo-forward-mark]
+ ["Previous template mark" tempo-backward-mark]))
+
(defcustom dcl-ws-r
"\\([ \t]*-[ \t]*\\(!.*\\)*\n\\)*[ \t]*"
"Regular expression describing white space in a DCL command line.
White space is any number of continued lines with only space,tab,endcomment
followed by space or tab."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-label-r
"[a-zA-Z0-9_$]*:\\([ \t!]\\|$\\)"
"Regular expression describing a label.
A label is a name followed by a colon followed by white-space or end-of-line."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-cmd-r
@@ -383,8 +334,7 @@ A line starting with $, optionally followed by continuation lines,
followed by the end of the command line.
A continuation line is any characters followed by `-',
optionally followed by a comment, followed by a newline."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-command-regexp
@@ -394,21 +344,19 @@ A line starting with $, optionally followed by continuation lines,
followed by the end of the command line.
A continuation line is any characters followed by `-',
optionally followed by a comment, followed by a newline."
- :type 'regexp
- :group 'dcl)
+ :type 'regexp)
(defcustom dcl-electric-reindent-regexps
(list "endif" "else" dcl-label-r)
"Regexps that can trigger an electric reindent.
A list of regexps that will trigger a reindent if the last letter
-is defined as dcl-electric-character.
+is defined as `dcl-electric-character'.
E.g.: if this list contains `endif', the key `f' is defined as
-dcl-electric-character and you have just typed the `f' in
+`dcl-electric-character' and you have just typed the `f' in
`endif', the line will be reindented."
- :type '(repeat regexp)
- :group 'dcl)
+ :type '(repeat regexp))
(defvar dcl-option-alist
@@ -430,7 +378,7 @@ dcl-electric-character and you have just typed the `f' in
(comment-start curval)
(comment-start-skip curval)
)
- "Options and default values for dcl-set-option.
+ "Options and default values for `dcl-set-option'.
An alist with option variables and functions or keywords to get a
default value for the option.
@@ -444,8 +392,8 @@ toggle the opposite of the current value (for t/nil)")
(mapcar (lambda (option-assoc)
(format "%s" (car option-assoc)))
dcl-option-alist)
- "The history list for dcl-set-option.
-Preloaded with all known option names from dcl-option-alist")
+ "The history list for `dcl-set-option'.
+Preloaded with all known option names from `dcl-option-alist'")
;; Must be defined after dcl-cmd-r
@@ -463,8 +411,7 @@ Preloaded with all known option names from dcl-option-alist")
;The default includes SUBROUTINE labels in the main listing and
;sub-listings for other labels, CALL, GOTO and GOSUB statements.
-;See `imenu-generic-expression' in a recent (e.g. Emacs 19.30) imenu.el
-;for details.")
+;See `imenu-generic-expression' for details.")
;;; *** Mode initialization *************************************************
@@ -557,8 +504,7 @@ Variables controlling indentation style and extra features:
dcl-imenu-label-call
Change the text that is used as sub-listing labels in imenu.
-Loading this package calls the value of the variable
-`dcl-mode-load-hook' with no args, if that value is non-nil.
+To run code after DCL mode has loaded, use `with-eval-after-load'.
Turning on DCL mode calls the value of the variable `dcl-mode-hook'
with no args, if that value is non-nil.
@@ -589,22 +535,21 @@ $
There is some minimal font-lock support (see vars
`dcl-font-lock-defaults' and `dcl-font-lock-keywords')."
- (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)
+ (setq-local indent-line-function #'dcl-indent-line)
+ (setq-local comment-start "!")
+ (setq-local comment-end "")
+ (setq-local 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.
- (set (make-local-variable 'comment-start-skip) "\\$[ \t]*![ \t]*")
+ (setq-local comment-start-skip "\\$[ \t]*![ \t]*")
- (if (boundp 'imenu-generic-expression)
- (progn (setq imenu-generic-expression dcl-imenu-generic-expression)
- (setq imenu-case-fold-search t)))
- (setq imenu-create-index-function 'dcl-imenu-create-index-function)
+ (setq imenu-generic-expression dcl-imenu-generic-expression)
+ (setq imenu-case-fold-search t)
+ (setq imenu-create-index-function #'dcl-imenu-create-index-function)
(make-local-variable 'dcl-comment-line-regexp)
(make-local-variable 'dcl-block-begin-regexp)
@@ -620,7 +565,7 @@ There is some minimal font-lock support (see vars
(make-local-variable 'dcl-electric-reindent-regexps)
;; font lock
- (set (make-local-variable 'font-lock-defaults) dcl-font-lock-defaults)
+ (setq-local font-lock-defaults dcl-font-lock-defaults)
(tempo-use-tag-list 'dcl-tempo-tags))
@@ -912,7 +857,7 @@ Returns one of the following symbols:
;;;---------------------------------------------------------------------------
(defun dcl-show-line-type ()
- "Test dcl-get-line-type."
+ "Test `dcl-get-line-type'."
(interactive)
(let ((type (dcl-get-line-type)))
(cond
@@ -957,8 +902,7 @@ $ if cond
$ then
$ if cond
$ then
-$ ! etc
-"
+$ ! etc"
;; calculate indentation if it's an interesting indent-type,
;; otherwise return nil to get the default indentation
(let ((indent))
@@ -987,8 +931,7 @@ $ xxx
If you use this function you will probably want to add \"then\" to
dcl-electric-reindent-regexps and define the key \"n\" as
-dcl-electric-character.
-"
+dcl-electric-character."
(let ((case-fold-search t))
(save-excursion
(cond
@@ -1031,17 +974,17 @@ see if the current lines should be indented.
Analyze the current line to see if it should be `outdented'.
Calculate the indentation of the current line, either with the default
-method or by calling dcl-calc-command-indent-function if it is
+method or by calling `dcl-calc-command-indent-function' if it is
non-nil.
If the current line should be outdented, calculate its indentation,
either with the default method or by calling
-dcl-calc-command-indent-function if it is non-nil.
+`dcl-calc-command-indent-function' if it is non-nil.
Rules for default indentation:
-If it is the first line in the buffer, indent dcl-margin-offset.
+If it is the first line in the buffer, indent `dcl-margin-offset'.
Go to the previous command line with a command on it.
Find out how much it is indented (cur-indent).
@@ -1049,7 +992,7 @@ Look at the first word on the line to see if the indentation should be
adjusted. Skip margin-label, continuations and comments while looking for
the first word. Save this buffer position as `last-point'.
If the first word after a label is SUBROUTINE, set extra-indent to
-dcl-margin-offset.
+`dcl-margin-offset'.
First word extra-indent
THEN +dcl-basic-offset
@@ -1206,8 +1149,7 @@ Indented lines will align with either:
* the innermost nonclosed parenthesis
$ if ((a.eq.b .and. -
d.eq.c .or. f$function(xxxx, -
- yyy)))
-"
+ yyy)))"
(let ((case-fold-search t)
indent)
(save-excursion
@@ -1387,7 +1329,7 @@ Adjusts indentation on the current line. Data lines are not indented."
;;;-------------------------------------------------------------------------
(defun dcl-indent-command ()
- "Indents the complete command line that point is on.
+ "Indent the complete command line that point is on.
This includes continuation lines."
(interactive "*")
(let ((type (dcl-get-line-type)))
@@ -1434,7 +1376,7 @@ the lines indentation; otherwise insert a tab."
;;;-------------------------------------------------------------------------
(defun dcl-electric-character (arg)
- "Inserts a character and indents if necessary.
+ "Insert a character and indent if necessary.
Insert a character if the user gave a numeric argument or the flag
`dcl-electric-characters' is not set. If an argument was given,
insert that many characters.
@@ -1451,7 +1393,7 @@ regexps in `dcl-electric-reindent-regexps'."
(let ((case-fold-search t))
;; There must be a better way than (memq t ...).
;; (apply 'or ...) didn't work
- (if (memq t (mapcar 'dcl-was-looking-at dcl-electric-reindent-regexps))
+ (if (memq t (mapcar #'dcl-was-looking-at dcl-electric-reindent-regexps))
(dcl-indent-line)))))
@@ -1627,7 +1569,7 @@ Must return a string."
((fboundp action)
(funcall action option-assoc))
((eq action 'toggle)
- (not (eval option)))
+ (not (symbol-value option)))
((eq action 'curval)
(cond ((or (stringp (symbol-value option))
(numberp (symbol-value option)))
@@ -1795,7 +1737,7 @@ Set or update the value of VAR in the current buffers
(setq continue nil)
(beginning-of-line)
(insert (concat prefix-string (symbol-name var) ": "
- (prin1-to-string (eval var)) " "
+ (prin1-to-string (symbol-value var)) " "
suffix-string "\n")))
;; Is it the variable we are looking for?
(if (eq var found-var)
@@ -1808,7 +1750,7 @@ Set or update the value of VAR in the current buffers
(delete-region (point) (progn (read (current-buffer))
(point)))
(insert " ")
- (prin1 (eval var) (current-buffer))
+ (prin1 (symbol-value var) (current-buffer))
(skip-chars-backward "\n")
(skip-chars-forward " \t")
(or (if suffix (looking-at suffix) (eolp))
@@ -1841,15 +1783,15 @@ Set or update the value of VAR in the current buffers
(concat " " comment-end))))))
(insert (concat def-prefix "Local variables:" def-suffix "\n"))
(insert (concat def-prefix (symbol-name var) ": "
- (prin1-to-string (eval var)) def-suffix "\n"))
+ (prin1-to-string (symbol-value var)) def-suffix "\n"))
(insert (concat def-prefix "end:" def-suffix)))
)))
;;;-------------------------------------------------------------------------
(defun dcl-save-all-options ()
- "Save all dcl-mode options for this buffer.
-Saves or updates all dcl-mode related options in a `Local Variables:'
+ "Save all `dcl-mode' options for this buffer.
+Saves or updates all `dcl-mode' related options in a `Local Variables:'
section at the end of the current buffer."
(interactive "*")
(mapcar (lambda (option-assoc)
@@ -1875,7 +1817,8 @@ still be present in the `Local Variables:' section with its old value."
(option-name (symbol-name option)))
(if (and (string-equal "dcl-"
(substring option-name 0 4))
- (not (equal (default-value option) (eval option))))
+ (not (equal (default-value option)
+ (symbol-value option))))
(dcl-save-local-variable option "$! "))))
dcl-option-alist))
@@ -2192,6 +2135,8 @@ otherwise return nil."
(provide 'dcl-mode)
+(make-obsolete-variable 'dcl-mode-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'dcl-mode-load-hook) ; for your customizations
;;; dcl-mode.el ends here
diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index 54a7009d4b1..2a37110f6ae 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -1,4 +1,4 @@
-;;; ebnf-abn.el --- parser for ABNF (Augmented BNF)
+;;; ebnf-abn.el --- parser for ABNF (Augmented BNF) -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -38,11 +38,7 @@
;; -----------
;;
;; See the URL:
-;; `http://www.ietf.org/rfc/rfc2234.txt'
-;; or
-;; `http://www.faqs.org/rfcs/rfc2234.html'
-;; or
-;; `http://www.rnp.br/ietf/rfc/rfc2234.txt'
+;; `https://www.ietf.org/rfc/rfc2234.txt'
;; ("Augmented BNF for Syntax Specifications: ABNF").
;;
;;
@@ -474,11 +470,10 @@
(aset ebnf-abn-token-table ?\; 'comment)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-abn-non-terminal-chars
- (ebnf-range-regexp "-_0-9A-Za-z" ?\240 ?\377))
+ "-_0-9A-Za-z\u00a0-\u00ff")
(defconst ebnf-abn-non-terminal-letter-chars
- (ebnf-range-regexp "A-Za-z" ?\240 ?\377))
+ "A-Za-z\u00a0-\u00ff")
(defun ebnf-abn-lex ()
@@ -572,9 +567,8 @@ See documentation for variable `ebnf-abn-lex'."
(not eor-p)))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-abn-comment-chars
- (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237))
+ "^\n\000-\010\016-\037\177\u0080-\u009f")
(defun ebnf-abn-skip-comment ()
@@ -612,9 +606,8 @@ See documentation for variable `ebnf-abn-lex'."
(ebnf-buffer-substring ebnf-abn-comment-chars))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-abn-string-chars
- (ebnf-range-regexp " -!#-~" ?\240 ?\377))
+ " !#-~\u00a0-\u00ff")
(defun ebnf-abn-string ()
diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el
index ff15d6a9814..e6717cbdf01 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -1,4 +1,4 @@
-;;; ebnf-bnf.el --- parser for EBNF
+;;; ebnf-bnf.el --- parser for EBNF -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -419,9 +419,8 @@
(aset ebnf-bnf-token-table ebnf-lex-eop-char 'period)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-bnf-non-terminal-chars
- (ebnf-range-regexp "!#%&'*-,0-:<>@-Z\\\\^-z~" ?\240 ?\377))
+ "!#%&'*-,0-:<>@-Z\\\\^-z~\u00a0-\u00ff")
(defun ebnf-bnf-lex ()
@@ -520,9 +519,8 @@ See documentation for variable `ebnf-bnf-lex'."
))))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-bnf-comment-chars
- (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237))
+ "^\n\000-\010\016-\037\177\u0080-\u009f")
(defun ebnf-bnf-skip-comment ()
diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el
index 1b80519a98e..93bae5a33c5 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -1,4 +1,4 @@
-;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML)
+;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML) -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -38,11 +38,11 @@
;; ----------
;;
;; See the URLs:
-;; `http://www.w3.org/TR/2004/REC-xml-20040204/'
+;; `https://www.w3.org/TR/2004/REC-xml-20040204/'
;; (Extensible Markup Language (XML) 1.0 (Third Edition))
-;; `http://www.w3.org/TR/html40/'
+;; `https://www.w3.org/TR/html40/'
;; (HTML 4.01 Specification)
-;; `http://www.w3.org/TR/NOTE-html-970421'
+;; `https://www.w3.org/TR/NOTE-html-970421'
;; (HTML DTD with support for Style Sheets)
;;
;;
@@ -1108,9 +1108,8 @@
(aset ebnf-dtd-token-table ?\] 'end-subset)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-dtd-name-chars
- (ebnf-range-regexp "-._:0-9A-Za-z" ?\240 ?\377))
+ "-._:0-9A-Za-z\u00a0-\u00ff")
(defconst ebnf-dtd-decl-alist
@@ -1263,11 +1262,10 @@ See documentation for variable `ebnf-dtd-lex'."
(format "%s%s;" start char)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-dtd-double-string-chars
- (ebnf-range-regexp "\t -!#-~" ?\240 ?\377))
+ "\t -!#-~\u00a0-\u00ff")
(defconst ebnf-dtd-single-string-chars
- (ebnf-range-regexp "\t -&(-~" ?\240 ?\377))
+ "\t -&(-~\u00a0-\u00ff")
(defun ebnf-dtd-string (delim)
@@ -1287,11 +1285,10 @@ See documentation for variable `ebnf-dtd-lex'."
(forward-char)))))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-dtd-comment-chars
- (ebnf-range-regexp "^-\000-\010\013\014\016-\037" ?\177 ?\237))
+ "^-\000-\010\013\014\016-\037\177\u0080-\u009f")
(defconst ebnf-dtd-filename-chars
- (ebnf-range-regexp "^-\000-\037" ?\177 ?\237))
+ "^-\000-\037\177\u0080-\u009f")
(defun ebnf-dtd-skip-comment ()
diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el
index 606d883b892..5d8541931e1 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -1,4 +1,4 @@
-;;; ebnf-ebx.el --- parser for EBNF used to specify XML (EBNFX)
+;;; ebnf-ebx.el --- parser for EBNF used to specify XML (EBNFX) -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -38,7 +38,7 @@
;; ------------
;;
;; See the URL:
-;; `http://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
+;; `https://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
;; (Extensible Markup Language (XML) 1.0 (Third Edition))
;;
;;
@@ -405,11 +405,10 @@
(aset ebnf-ebx-token-table ?/ 'comment)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-ebx-non-terminal-chars
- (ebnf-range-regexp "-_A-Za-z" ?\240 ?\377))
+ "-_A-Za-z\u00a0-\u00ff")
(defconst ebnf-ebx-non-terminal-letter-chars
- (ebnf-range-regexp "A-Za-z" ?\240 ?\377))
+ "A-Za-z\u00a0-\u00ff")
(defun ebnf-ebx-lex ()
@@ -488,9 +487,8 @@ See documentation for variable `ebnf-ebx-lex'."
))))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-ebx-constraint-chars
- (ebnf-range-regexp "^\000-\010\016-\037]" ?\177 ?\237))
+ "^\000-\010\016-\037]\177\u0080-\u009f")
(defun ebnf-ebx-skip-constraint ()
@@ -517,11 +515,10 @@ See documentation for variable `ebnf-ebx-lex'."
(not eor-p)))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-ebx-comment-chars
- (ebnf-range-regexp "^\000-\010\016-\037\\*" ?\177 ?\237))
+ "^\000-\010\016-\037*\177\u0080-\u009f")
(defconst ebnf-ebx-filename-chars
- (ebnf-range-regexp "^\000-\037\\*" ?\177 ?\237))
+ "^\000-\037*\177\u0080-\u009f")
(defun ebnf-ebx-skip-comment ()
@@ -581,11 +578,10 @@ See documentation for variable `ebnf-ebx-lex'."
(concat fname (make-string nchar ?*)))))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-ebx-double-string-chars
- (ebnf-range-regexp "\t -!#-~" ?\240 ?\377))
+ "\t -!#-~\u00a0-\u00ff")
(defconst ebnf-ebx-single-string-chars
- (ebnf-range-regexp "\t -&(-~" ?\240 ?\377))
+ "\t -&(-~\u00a0-\u00ff")
(defun ebnf-ebx-string (delim)
diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el
index a45f03a2bb7..b4532c76251 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -1,4 +1,4 @@
-;;; ebnf-iso.el --- parser for ISO EBNF
+;;; ebnf-iso.el --- parser for ISO EBNF -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -38,7 +38,7 @@
;; ---------------
;;
;; See the URL:
-;; `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
+;; `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
;; ("International Standard of the ISO EBNF Notation").
;;
;;
@@ -379,9 +379,8 @@
(aset ebnf-iso-token-table ?. 'character)))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
(defconst ebnf-iso-non-terminal-chars
- (ebnf-range-regexp " 0-9A-Za-z_" ?\240 ?\377))
+ " 0-9A-Za-z_\u00a0-\u00ff")
(defun ebnf-iso-lex ()
@@ -487,9 +486,8 @@ See documentation for variable `ebnf-iso-lex'."
))))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-iso-comment-chars
- (ebnf-range-regexp "^*(\000-\010\016-\037" ?\177 ?\237))
+ "^*(\000-\010\016-\037\177\u0080-\u009f")
(defun ebnf-iso-skip-comment ()
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
index b724d75a7e5..84e59cc0a51 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -1,4 +1,4 @@
-;;; ebnf-otz.el --- syntactic chart OpTimiZer
+;;; ebnf-otz.el --- syntactic chart OpTimiZer -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index c0640b06531..816cc432d1b 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -1,4 +1,4 @@
-;;; ebnf-yac.el --- parser for Yacc/Bison
+;;; ebnf-yac.el --- parser for Yacc/Bison -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -271,13 +271,13 @@
(let ((table (make-vector 256 'error)))
;; upper & lower case letters:
(mapc
- #'(lambda (char)
- (aset table char 'non-terminal))
+ (lambda (char)
+ (aset table char 'non-terminal))
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
;; printable characters:
(mapc
- #'(lambda (char)
- (aset table char 'character))
+ (lambda (char)
+ (aset table char 'character))
"!#$&()*+-.0123456789=?@[\\]^_`~")
;; Override space characters:
(aset table ?\n 'space) ; [NL] linefeed
@@ -397,9 +397,8 @@ See documentation for variable `ebnf-yac-lex'."
(< (point) ebnf-limit))
-;; replace the range "\177-\377" (see `ebnf-range-regexp').
(defconst ebnf-yac-skip-chars
- (ebnf-range-regexp "^{}/'\"\000-\010\013\016-\037" ?\177 ?\377))
+ "^{}/'\"\000-\010\013\016-\037\177\u0080-\u009f")
(defun ebnf-yac-skip-code ()
@@ -442,9 +441,8 @@ See documentation for variable `ebnf-yac-lex'."
))
-;; replace the range "\177-\237" (see `ebnf-range-regexp').
(defconst ebnf-yac-comment-chars
- (ebnf-range-regexp "^*\000-\010\013\016-\037" ?\177 ?\237))
+ "^*\000-\010\013\016-\037\177\u0080-\u009f")
(defun ebnf-yac-skip-comment ()
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index a321b073d82..a00440d898c 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, ebnf, PostScript
;; Version: 4.4
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; This file is part of GNU Emacs.
@@ -326,11 +326,11 @@ Please send all bug fixes and enhancements to
;; `ebnf-lex-comment-char' and `ebnf-lex-eop-char'.
;;
;; `abnf' ebnf2ps recognizes the syntax described in the URL:
-;; `http://www.ietf.org/rfc/rfc2234.txt'
+;; `https://www.ietf.org/rfc/rfc2234.txt'
;; ("Augmented BNF for Syntax Specifications: ABNF").
;;
;; `iso-ebnf' ebnf2ps recognizes the syntax described in the URL:
-;; `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
+;; `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
;; ("International Standard of the ISO EBNF Notation").
;; The following variables *ONLY* have effect with this
;; setting:
@@ -342,11 +342,11 @@ Please send all bug fixes and enhancements to
;; `ebnf-yac-ignore-error-recovery'.
;;
;; `ebnfx' ebnf2ps recognizes the syntax described in the URL:
-;; `http://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
+;; `https://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
;; ("Extensible Markup Language (XML) 1.0 (Third Edition)")
;;
;; `dtd' ebnf2ps recognizes the syntax described in the URL:
-;; `http://www.w3.org/TR/2004/REC-xml-20040204/'
+;; `https://www.w3.org/TR/2004/REC-xml-20040204/'
;; ("Extensible Markup Language (XML) 1.0 (Third Edition)")
;;
;; Any other value is treated as `ebnf'.
@@ -1157,21 +1157,6 @@ Please send all bug fixes and enhancements to
(and (string< ps-print-version "5.2.3")
(error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later"))
-
-;; to avoid gripes with Emacs 20
-(or (fboundp 'assq-delete-all)
- (defun assq-delete-all (key alist)
- "Delete from ALIST all elements whose car is KEY.
-Return the modified alist.
-Elements of ALIST that are not conses are ignored."
- (let ((tail alist))
- (while tail
- (if (and (consp (car tail))
- (eq (car (car tail)) key))
- (setq alist (delq (car tail) alist)))
- (setq tail (cdr tail)))
- alist)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:
@@ -1794,11 +1779,11 @@ Valid values are:
`ebnf-lex-comment-char' and `ebnf-lex-eop-char'.
`abnf' ebnf2ps recognizes the syntax described in the URL:
- `http://www.ietf.org/rfc/rfc2234.txt'
+ `https://www.ietf.org/rfc/rfc2234.txt'
(\"Augmented BNF for Syntax Specifications: ABNF\").
`iso-ebnf' ebnf2ps recognizes the syntax described in the URL:
- `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
+ `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
(\"International Standard of the ISO EBNF Notation\").
The following variables *ONLY* have effect with this
setting:
@@ -1810,11 +1795,11 @@ Valid values are:
`ebnf-yac-ignore-error-recovery'.
`ebnfx' ebnf2ps recognizes the syntax described in the URL:
- `http://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
+ `https://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
(\"Extensible Markup Language (XML) 1.0 (Third Edition)\")
`dtd' ebnf2ps recognizes the syntax described in the URL:
- `http://www.w3.org/TR/2004/REC-xml-20040204/'
+ `https://www.w3.org/TR/2004/REC-xml-20040204/'
(\"Extensible Markup Language (XML) 1.0 (Third Edition)\")
Any other value is treated as `ebnf'."
@@ -2053,8 +2038,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)."
;; Printing color requires x-color-values.
-(defcustom ebnf-color-p (or (fboundp 'x-color-values) ; Emacs
- (fboundp 'color-instance-rgb-components)) ; XEmacs
+(defcustom ebnf-color-p t
"Non-nil means use color."
:type 'boolean
:version "20"
@@ -2738,8 +2722,7 @@ Used in functions `ebnf-reset-style', `ebnf-push-style' and
(ebnf-eps-footer-font . '(7 Helvetica "Black" "White" bold))
(ebnf-eps-footer . nil)
(ebnf-entry-percentage . 0.5)
- (ebnf-color-p . (or (fboundp 'x-color-values) ; Emacs
- (fboundp 'color-instance-rgb-components))) ; XEmacs
+ (ebnf-color-p . t)
(ebnf-line-width . 1.0)
(ebnf-line-color . "Black")
(ebnf-debug-ps . nil)
@@ -2937,7 +2920,7 @@ See `ebnf-style-database' documentation."
value
(and (car value) (ebnf-apply-style1 (car value)))
(while (setq value (cdr value))
- (set (caar value) (eval (cdar value)))))))
+ (set (caar value) (eval (cdar value) t))))))
(defun ebnf-check-style-values (values)
@@ -2958,16 +2941,11 @@ See `ebnf-style-database' documentation."
(defvar ebnf-eps-executing nil)
(defvar ebnf-eps-header-comment nil)
(defvar ebnf-eps-footer-comment nil)
-(defvar ebnf-eps-upper-x 0.0)
-(make-variable-buffer-local 'ebnf-eps-upper-x)
-(defvar ebnf-eps-upper-y 0.0)
-(make-variable-buffer-local 'ebnf-eps-upper-y)
-(defvar ebnf-eps-prod-width 0.0)
-(make-variable-buffer-local 'ebnf-eps-prod-width)
-(defvar ebnf-eps-max-height 0.0)
-(make-variable-buffer-local 'ebnf-eps-max-height)
-(defvar ebnf-eps-max-width 0.0)
-(make-variable-buffer-local 'ebnf-eps-max-width)
+(defvar-local ebnf-eps-upper-x 0.0)
+(defvar-local ebnf-eps-upper-y 0.0)
+(defvar-local ebnf-eps-prod-width 0.0)
+(defvar-local ebnf-eps-max-height 0.0)
+(defvar-local ebnf-eps-max-width 0.0)
(defvar ebnf-eps-context nil
@@ -4420,8 +4398,8 @@ end
(defun ebnf-format-float (&rest floats)
(mapconcat
- #'(lambda (float)
- (format ebnf-format-float float))
+ (lambda (float)
+ (format ebnf-format-float float))
floats
" "))
@@ -4544,7 +4522,7 @@ end
(let* ((ebnf-tree tree)
(ps-color-p (and ebnf-color-p (ps-color-device)))
(ps-print-color-scale (if ps-color-p
- (float (car (ps-color-values "white")))
+ (float (car (color-values "white")))
1.0))
(ebnf-total (length ebnf-tree))
(ebnf-nprod 0)
@@ -4646,7 +4624,7 @@ end
(let* ((ebnf-tree tree)
(ps-color-p (and ebnf-color-p (ps-color-device)))
(ps-print-color-scale (if ps-color-p
- (float (car (ps-color-values "white")))
+ (float (car (color-values "white")))
1.0))
ps-zebra-stripes ps-line-number ps-razzle-dazzle
ps-print-hook
@@ -4979,22 +4957,10 @@ killed after process termination."
(kill-buffer (current-buffer))))
-;; function `ebnf-range-regexp' is used to avoid a bug of `skip-chars-forward'
-;; on version 20.4.1, that is, it doesn't accept ranges like "\240-\377" (or
-;; "\177-\237"), but it accepts the character sequence from \240 to \377 (or
-;; from \177 to \237). It seems that version 20.7 has the same problem.
-(defun ebnf-range-regexp (prefix from to)
- (let (str)
- (while (<= from to)
- (setq str (concat str (char-to-string from))
- from (1+ from)))
- (concat prefix str)))
-
-
(defvar ebnf-map-name
(let ((map (make-vector 256 ?\_)))
- (mapc #'(lambda (char)
- (aset map char char))
+ (mapc (lambda (char)
+ (aset map char char))
(concat "#$%&+-.0123456789=?@~"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"))
@@ -5004,8 +4970,6 @@ killed after process termination."
(defun ebnf-eps-filename (str)
(let* ((len (length str))
(stri 0)
- ;; to keep compatibility with Emacs 20 & 21:
- ;; DO NOT REPLACE `?\ ' BY `?\s'
(new (make-string len ?\ )))
(while (< stri len)
(aset new stri (aref ebnf-map-name (aref str stri)))
@@ -5523,7 +5487,7 @@ killed after process termination."
(ebnf-shape-value ebnf-chart-shape
ebnf-terminal-shape-alist))
(format "/UserArrow{%s}def\n"
- (let ((arrow (eval ebnf-user-arrow)))
+ (let ((arrow (eval ebnf-user-arrow t)))
(if (stringp arrow)
arrow
"")))
@@ -5987,8 +5951,7 @@ killed after process termination."
(point))))
-;; replace the range "\240-\377" (see `ebnf-range-regexp').
-(defconst ebnf-8-bit-chars (ebnf-range-regexp "" ?\240 ?\377))
+(defconst ebnf-8-bit-chars "\u00a0-\u00ff")
(defun ebnf-string (chars eos-char kind)
@@ -6023,8 +5986,6 @@ killed after process termination."
(defun ebnf-trim-right (str)
(let* ((len (1- (length str)))
(index len))
- ;; to keep compatibility with Emacs 20 & 21:
- ;; DO NOT REPLACE `?\ ' BY `?\s'
(while (and (> index 0) (= (aref str index) ?\ ))
(setq index (1- index)))
(if (= index len)
@@ -6329,7 +6290,7 @@ killed after process termination."
(defun ebnf-log-header (format-str &rest args)
(when ebnf-log
(apply
- 'ebnf-log
+ #'ebnf-log
(concat
"\n\n===============================================================\n\n"
format-str)
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index 59fbd40fcbc..7524c280f25 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -34,7 +34,7 @@
;;; Code:
(require 'cl-lib)
-(require 'easymenu)
+(require 'seq)
(require 'view)
(require 'ebuff-menu)
@@ -52,32 +52,27 @@
"List of directories to search for source files in a class tree.
Elements should be directory names; nil as an element means to try
to find source files relative to the location of the BROWSE file loaded."
- :group 'ebrowse
:type '(repeat (choice (const :tag "Default" nil)
(string :tag "Directory"))))
(defcustom ebrowse-view/find-hook nil
"Hooks run after finding or viewing a member or class."
- :group 'ebrowse
:type 'hook)
(defcustom ebrowse-not-found-hook nil
"Hooks run when finding or viewing a member or class was not successful."
- :group 'ebrowse
:type 'hook)
(defcustom ebrowse-electric-list-mode-hook nil
"Hook called by `ebrowse-electric-position-mode'."
- :group 'ebrowse
:type 'hook)
(defcustom ebrowse-max-positions 50
"Number of markers saved on electric position stack."
- :group 'ebrowse
:type 'integer)
@@ -89,32 +84,27 @@ to find source files relative to the location of the BROWSE file loaded."
(defcustom ebrowse-tree-mode-hook nil
"Hook run in each new tree buffer."
- :group 'ebrowse-tree
:type 'hook)
(defcustom ebrowse-tree-buffer-name "*Tree*"
"The default name of class tree buffers."
- :group 'ebrowse-tree
:type 'string)
(defcustom ebrowse--indentation 4
"The amount by which subclasses are indented in the tree."
- :group 'ebrowse-tree
:type 'integer)
(defcustom ebrowse-source-file-column 40
"The column in which source file names are displayed in the tree."
- :group 'ebrowse-tree
:type 'integer)
(defcustom ebrowse-tree-left-margin 2
"Amount of space left at the left side of the tree display.
This space is used to display markers."
- :group 'ebrowse-tree
:type 'integer)
@@ -126,25 +116,21 @@ This space is used to display markers."
(defcustom ebrowse-default-declaration-column 25
"The column in which member declarations are displayed in member buffers."
- :group 'ebrowse-member
:type 'integer)
(defcustom ebrowse-default-column-width 25
"The width of the columns in member buffers (short display form)."
- :group 'ebrowse-member
:type 'integer)
(defcustom ebrowse-member-buffer-name "*Members*"
"The name of the buffer for member display."
- :group 'ebrowse-member
:type 'string)
(defcustom ebrowse-member-mode-hook nil
"Run in each new member buffer."
- :group 'ebrowse-member
:type 'hook)
@@ -156,81 +142,47 @@ This space is used to display markers."
(defface ebrowse-tree-mark
'((((min-colors 88)) :foreground "red1")
(t :foreground "red"))
- "Face for the mark character in the Ebrowse tree."
- :group 'ebrowse-faces)
+ "Face for the mark character in the Ebrowse tree.")
(defface ebrowse-root-class
'((((min-colors 88)) :weight bold :foreground "blue1")
(t :weight bold :foreground "blue"))
- "Face for root classes in the Ebrowse tree."
- :group 'ebrowse-faces)
+ "Face for root classes in the Ebrowse tree.")
(defface ebrowse-file-name '((t :slant italic))
- "Face for filenames in the Ebrowse tree."
- :group 'ebrowse-faces)
+ "Face for filenames in the Ebrowse tree.")
(defface ebrowse-default '((t))
- "Face for items in the Ebrowse tree which do not have other faces."
- :group 'ebrowse-faces)
+ "Face for items in the Ebrowse tree which do not have other faces.")
(defface ebrowse-member-attribute
'((((min-colors 88)) :foreground "red1")
(t :foreground "red"))
- "Face for member attributes."
- :group 'ebrowse-faces)
+ "Face for member attributes.")
(defface ebrowse-member-class
'((t :foreground "purple"))
- "Face used to display the class title in member buffers."
- :group 'ebrowse-faces)
+ "Face used to display the class title in member buffers.")
(defface ebrowse-progress
'((((min-colors 88)) :background "blue1")
(t :background "blue"))
- "Face for progress indicator."
- :group 'ebrowse-faces)
+ "Face for progress indicator.")
;;; Utilities.
-(defun ebrowse-some (predicate vector)
- "Return true if PREDICATE is true of some element of VECTOR.
-If so, return the value returned by PREDICATE."
- (let ((length (length vector))
- (i 0)
- result)
- (while (and (< i length) (not result))
- (setq result (funcall predicate (aref vector i))
- i (1+ i)))
- result))
+(define-obsolete-function-alias 'ebrowse-some #'seq-some "28.1")
-(defun ebrowse-every (predicate vector)
- "Return true if PREDICATE is true of every element of VECTOR."
- (let ((length (length vector))
- (i 0)
- (result t))
- (while (and (< i length) result)
- (setq result (funcall predicate (aref vector i))
- i (1+ i)))
- result))
+(define-obsolete-function-alias 'ebrowse-every #'seq-every-p "28.1")
(defun ebrowse-position (item list &optional test)
"Return the position of ITEM in LIST or nil if not found.
Compare items with `eq' or TEST if specified."
- (let ((i 0) found)
- (cond (test
- (while list
- (when (funcall test item (car list))
- (setq found i list nil))
- (setq list (cdr list) i (1+ i))))
- (t
- (while list
- (when (eq item (car list))
- (setq found i list nil))
- (setq list (cdr list) i (1+ i)))))
- found))
+ (declare (obsolete seq-position "28.1"))
+ (seq-position list item (or test #'eql)))
(defmacro ebrowse-ignoring-completion-case (&rest body)
@@ -242,17 +194,13 @@ Compare items with `eq' or TEST if specified."
(defmacro ebrowse-for-all-trees (spec &rest body)
"For all trees in SPEC, eval BODY."
(declare (indent 1) (debug ((sexp form) body)))
- (let ((var (make-symbol "var"))
- (spec-var (car spec))
+ (let ((spec-var (car spec))
(array (cadr spec)))
- `(cl-loop for ,var being the symbols of ,array
- as ,spec-var = (get ,var 'ebrowse-root) do
- (when (vectorp ,spec-var)
- ,@body))))
-
-;;; Set indentation for macros above.
-
-
+ `(maphash (lambda (_k ,spec-var)
+ (when ,spec-var
+ (cl-assert (cl-typep ,spec-var 'ebrowse-ts))
+ ,@body))
+ ,array)))
(defsubst ebrowse-set-face (start end face)
"Set face of a region START END to FACE."
@@ -264,8 +212,7 @@ Compare items with `eq' or TEST if specified."
Case is ignored in completions.
PROMPT is a string to prompt with; normally it ends in a colon and a space.
-TABLE is an alist whose elements' cars are strings, or an obarray.
-TABLE can also be a function to do the completion itself.
+TABLE is a completion table.
If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
If it is (STRING . POSITION), the initial input
is STRING, but point is placed POSITION characters into the string."
@@ -304,6 +251,9 @@ otherwise use the current frame's width."
;;; Structure definitions
+;; Note: These use `(:type vector) :named' in order to match the
+;; format used in src/BROWSE.
+
(cl-defstruct (ebrowse-hs (:type vector) :named)
"Header structure found at the head of BROWSE files."
;; A version string that is compared against the version number of
@@ -457,19 +407,17 @@ members."
This must be the same that `ebrowse' uses.")
-(defvar ebrowse--last-regexp nil
+(defvar-local ebrowse--last-regexp nil
"Last regular expression searched for in tree and member buffers.
Each tree and member buffer maintains its own search history.")
-(make-variable-buffer-local 'ebrowse--last-regexp)
-
(defconst ebrowse-member-list-accessors
- '(ebrowse-ts-member-variables
- ebrowse-ts-member-functions
- ebrowse-ts-static-variables
- ebrowse-ts-static-functions
- ebrowse-ts-friends
- ebrowse-ts-types)
+ (list #'ebrowse-ts-member-variables
+ #'ebrowse-ts-member-functions
+ #'ebrowse-ts-static-variables
+ #'ebrowse-ts-static-functions
+ #'ebrowse-ts-friends
+ #'ebrowse-ts-types)
"List of accessors for member lists.
Each element is the symbol of an accessor function.
The nth element must be the accessor for the nth member list
@@ -478,8 +426,8 @@ in an `ebrowse-ts' structure.")
;;; FIXME: Add more doc strings for the buffer-local variables below.
-(defvar ebrowse--tree-obarray nil
- "Obarray holding all `ebrowse-ts' structures of a class tree.
+(defvar ebrowse--tree-table nil
+ "Hash-table holding all `ebrowse-ts' structures of a class tree.
Buffer-local in Ebrowse buffers.")
@@ -637,12 +585,12 @@ Buffer-local in Ebrowse buffers.")
;;; Operations on `ebrowse-ts' structures
(defun ebrowse-files-table (&optional marked-only)
- "Return an obarray containing all files mentioned in the current tree.
-The tree is expected in the buffer-local variable `ebrowse--tree-obarray'.
+ "Return a hash table containing all files mentioned in the current tree.
+The tree is expected in the buffer-local variable `ebrowse--tree-table'.
MARKED-ONLY non-nil means include marked classes only."
(let ((files (make-hash-table :test 'equal))
(i -1))
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(when (or (not marked-only) (ebrowse-ts-mark tree))
(let ((class (ebrowse-ts-class tree)))
(when (zerop (% (cl-incf i) 20))
@@ -677,7 +625,7 @@ MARKED-ONLY non-nil means include marked classes only."
(cl-defun ebrowse-marked-classes-p ()
"Value is non-nil if any class in the current class tree is marked."
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(when (ebrowse-ts-mark tree)
(cl-return-from ebrowse-marked-classes-p tree))))
@@ -695,21 +643,21 @@ MARKED-ONLY non-nil means include marked classes only."
(ebrowse-cs-name class)))
-(defun ebrowse-tree-obarray-as-alist (&optional qualified-names-p)
+(defun ebrowse-tree-table-as-alist (&optional qualified-names-p)
"Return an alist describing all classes in a tree.
Each elements in the list has the form (CLASS-NAME . TREE).
CLASS-NAME is the name of the class. TREE is the
class tree whose root is QUALIFIED-CLASS-NAME.
QUALIFIED-NAMES-P non-nil means return qualified names as CLASS-NAME.
-The class tree is found in the buffer-local variable `ebrowse--tree-obarray'."
+The class tree is found in the buffer-local variable `ebrowse--tree-table'."
(let (alist)
(if qualified-names-p
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(setq alist
(cl-acons (ebrowse-qualified-class-name
(ebrowse-ts-class tree))
tree alist)))
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(setq alist
(cl-acons (ebrowse-cs-name (ebrowse-ts-class tree))
tree alist))))
@@ -751,7 +699,7 @@ computes this information lazily."
with result = nil
as search = (pop to-search)
while search finally return result
- do (ebrowse-for-all-trees (ti ebrowse--tree-obarray)
+ do (ebrowse-for-all-trees (ti ebrowse--tree-table)
(when (memq search (ebrowse-ts-subclasses ti))
(unless (memq ti result)
(setq result (nconc result (list ti))))
@@ -846,7 +794,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree."
(ebrowse-hs-version header) ebrowse-version-string))
;; Read Lisp objects. Temporarily increase `gc-cons-threshold' to
;; prevent a GC that would not free any memory.
- (let ((gc-cons-threshold 2000000))
+ (let ((gc-cons-threshold (max gc-cons-threshold 2000000)))
(while (not (progn (skip-chars-forward " \t\n") (eobp)))
(let* ((root (read (current-buffer)))
(old-root-ptr (ebrowse-class-in-tree root tree)))
@@ -875,7 +823,7 @@ NOCONFIRM."
"Create a new tree buffer for tree TREE.
The tree was loaded from file TAGS-FILE.
HEADER is the header structure of the file.
-CLASSES is an obarray with a symbol for each class in the tree.
+CLASSES is a hash-table with an entry 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))
@@ -883,7 +831,7 @@ Return the buffer created."
(ebrowse-tree-mode)
(setq ebrowse--tree tree
ebrowse--tags-file-name tags-file
- ebrowse--tree-obarray classes
+ ebrowse--tree-table classes
ebrowse--header header
ebrowse--frozen-flag nil)
(ebrowse-redraw-tree)
@@ -895,13 +843,13 @@ Return the buffer created."
-;;; Operations for member obarrays
+;;; Operations for member tables
(defun ebrowse-fill-member-table ()
- "Return an obarray holding all members of all classes in the current tree.
+ "Return a hash table holding all members of all classes in the current tree.
-For each member, a symbol is added to the obarray. Members are
-extracted from the buffer-local tree `ebrowse--tree-obarray'.
+For each member, a symbol is added to the table. Members are
+extracted from the buffer-local tree `ebrowse--tree-table'.
Each symbol has its property `ebrowse-info' set to a list (TREE MEMBER-LIST
MEMBER) where TREE is the tree in which the member is defined,
@@ -909,26 +857,23 @@ MEMBER-LIST is a symbol describing the member list in which the member
is found, and MEMBER is a MEMBER structure describing the member.
The slot `member-table' of the buffer-local header structure of
-type `ebrowse-hs' is set to the resulting obarray."
+type `ebrowse-hs' is set to the resulting table."
(let ((members (make-hash-table :test 'equal))
(i -1))
(setf (ebrowse-hs-member-table ebrowse--header) nil)
(garbage-collect)
;; For all classes...
- (ebrowse-for-all-trees (c ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (c ebrowse--tree-table)
(when (zerop (% (cl-incf i) 10))
(ebrowse-show-progress "Preparing member lookup" (zerop i)))
(dolist (f ebrowse-member-list-accessors)
(dolist (m (funcall f c))
- (let* ((member-name (ebrowse-ms-name m))
- (value (gethash member-name members)))
- (push (list c f m) value)
- (puthash member-name value members)))))
+ (push (list c f m) (gethash (ebrowse-ms-name m) members)))))
(setf (ebrowse-hs-member-table ebrowse--header) members)))
(defun ebrowse-member-table (header)
- "Return the member obarray. Build it if it hasn't been set up yet.
+ "Return the member table. Build it if it hasn't been set up yet.
HEADER is the tree header structure of the class tree."
(when (null (ebrowse-hs-member-table header))
(cl-loop for buffer in (ebrowse-browser-buffer-list)
@@ -940,19 +885,18 @@ HEADER is the tree header structure of the class tree."
-;;; Operations on TREE obarrays
+;;; Operations on TREE tables
-(defun ebrowse-build-tree-obarray (tree)
+(defun ebrowse-build-tree-table (tree)
"Make sure every class in TREE is represented by a unique object.
-Build obarray of all classes in TREE."
- (let ((classes (make-vector 127 0)))
+Build hash table of all classes in TREE."
+ (let ((classes (make-hash-table :test #'equal)))
;; Add root classes...
(cl-loop for root in tree
- as sym =
- (intern (ebrowse-qualified-class-name (ebrowse-ts-class root))
- classes)
- do (unless (get sym 'ebrowse-root)
- (setf (get sym 'ebrowse-root) root)))
+ do (let ((name (ebrowse-qualified-class-name
+ (ebrowse-ts-class root))))
+ (unless (gethash name classes)
+ (setf (gethash name classes) root))))
;; Process subclasses
(ebrowse-insert-supers tree classes)
classes))
@@ -962,7 +906,7 @@ Build obarray of all classes in TREE."
"Build base class lists in class tree TREE.
CLASSES is an obarray used to collect classes.
-Helper function for `ebrowse-build-tree-obarray'. Base classes should
+Helper function for `ebrowse-build-tree-table'. Base classes should
be ordered so that immediate base classes come first, then the base
class of the immediate base class and so on. This means that we must
construct the base-class list top down with adding each level at the
@@ -974,23 +918,21 @@ if for some reason a circle is in the inheritance graph."
as subclasses = (ebrowse-ts-subclasses class) do
;; Make sure every class is represented by a unique object
(cl-loop for subclass on subclasses
- as sym = (intern
- (ebrowse-qualified-class-name
- (ebrowse-ts-class (car subclass)))
- classes)
do
- ;; Replace the subclass tree with the one found in
- ;; CLASSES if there is already an entry for that class
- ;; in it. Otherwise make a new entry.
- ;;
- ;; CAVEAT: If by some means (e.g., use of the
- ;; preprocessor in class declarations, a name is marked
- ;; as a subclass of itself on some path, we would end up
- ;; in an endless loop. We have to omit subclasses from
- ;; the recursion that already have been processed.
- (if (get sym 'ebrowse-root)
- (setf (car subclass) (get sym 'ebrowse-root))
- (setf (get sym 'ebrowse-root) (car subclass))))
+ (let ((name (ebrowse-qualified-class-name
+ (ebrowse-ts-class (car subclass)))))
+ ;; Replace the subclass tree with the one found in
+ ;; CLASSES if there is already an entry for that class
+ ;; in it. Otherwise make a new entry.
+ ;;
+ ;; CAVEAT: If by some means (e.g., use of the
+ ;; preprocessor in class declarations, a name is marked
+ ;; as a subclass of itself on some path, we would end up
+ ;; in an endless loop. We have to omit subclasses from
+ ;; the recursion that already have been processed.
+ (if (gethash name classes)
+ (setf (car subclass) (gethash name classes))
+ (setf (gethash name classes) (car subclass)))))
;; Process subclasses
(ebrowse-insert-supers subclasses classes)))
@@ -1072,20 +1014,17 @@ Tree mode key bindings:
(erase-buffer)
(message nil))
- (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-local ebrowse--show-file-names-flag nil)
+ (setq-local ebrowse--frozen-flag nil)
(setq mode-line-buffer-identification ident)
(setq buffer-read-only t)
(add-to-invisibility-spec '(ebrowse . 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)
+ (setq-local revert-buffer-function #'ebrowse-revert-tree-buffer-from-file)
+ (setq-local ebrowse--header header)
+ (setq-local ebrowse--tree tree)
+ (setq-local ebrowse--tags-file-name buffer-file-name)
+ (setq-local ebrowse--tree-table (and tree (ebrowse-build-tree-table tree)))
+ (setq-local ebrowse--frozen-flag nil)
(add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t)
(modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))
@@ -1110,18 +1049,18 @@ Tree mode key bindings:
(defun ebrowse-remove-class-and-kill-member-buffers (tree class)
"Remove from TREE class CLASS.
Kill all member buffers still containing a reference to the class."
- (let ((sym (intern-soft (ebrowse-cs-name (ebrowse-ts-class class))
- ebrowse--tree-obarray)))
- (setf tree (delq class tree)
- (get sym 'ebrowse-root) nil)
- (dolist (root tree)
- (setf (ebrowse-ts-subclasses root)
- (delq class (ebrowse-ts-subclasses root))
- (ebrowse-ts-base-classes root) nil)
- (ebrowse-remove-class-and-kill-member-buffers
- (ebrowse-ts-subclasses root) class))
- (ebrowse-kill-member-buffers-displaying class)
- tree))
+ (setf tree (delq class tree)
+ (gethash (ebrowse-cs-name (ebrowse-ts-class class))
+ ebrowse--tree-table)
+ nil)
+ (dolist (root tree)
+ (setf (ebrowse-ts-subclasses root)
+ (delq class (ebrowse-ts-subclasses root))
+ (ebrowse-ts-base-classes root) nil)
+ (ebrowse-remove-class-and-kill-member-buffers
+ (ebrowse-ts-subclasses root) class))
+ (ebrowse-kill-member-buffers-displaying class)
+ tree)
(defun ebrowse-remove-class-at-point (forced)
@@ -1184,7 +1123,7 @@ If given a numeric N-TIMES argument, mark that many classes."
(defun ebrowse-mark-all-classes (prefix)
"Unmark, with PREFIX mark, all classes in the tree."
(interactive "P")
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(setf (ebrowse-ts-mark tree) prefix))
(ebrowse-redraw-marks (point-min) (point-max)))
@@ -1277,17 +1216,17 @@ With PREFIX, insert that many filenames."
(defun ebrowse-browser-buffer-list ()
"Return a list of all tree or member buffers."
- (cl-delete-if-not 'ebrowse-buffer-p (buffer-list)))
+ (cl-delete-if-not #'ebrowse-buffer-p (buffer-list)))
(defun ebrowse-member-buffer-list ()
"Return a list of all member buffers."
- (cl-delete-if-not 'ebrowse-member-buffer-p (buffer-list)))
+ (cl-delete-if-not #'ebrowse-member-buffer-p (buffer-list)))
(defun ebrowse-tree-buffer-list ()
"Return a list of all tree buffers."
- (cl-delete-if-not 'ebrowse-tree-buffer-p (buffer-list)))
+ (cl-delete-if-not #'ebrowse-tree-buffer-p (buffer-list)))
(defun ebrowse-known-class-trees-buffer-list ()
@@ -1396,7 +1335,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise."
"): ")
nil nil ebrowse--indentation))))
(when (cl-plusp width)
- (set (make-local-variable 'ebrowse--indentation) width)
+ (setq-local ebrowse--indentation width)
(ebrowse-redraw-tree))))
@@ -1409,7 +1348,7 @@ Read a class name from the minibuffer if CLASS is nil."
(unless class
(setf class
(completing-read "Goto class: "
- (ebrowse-tree-obarray-as-alist) nil t)))
+ (ebrowse-tree-table-as-alist) nil t)))
(goto-char (point-min))
(widen)
(setq ebrowse--last-regexp (concat "\\b" class "\\b"))
@@ -1426,37 +1365,37 @@ Read a class name from the minibuffer if CLASS is nil."
(defun ebrowse-tree-command:show-member-variables (arg)
"Display member variables; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-member-variables arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-member-variables arg))
(defun ebrowse-tree-command:show-member-functions (&optional arg)
"Display member functions; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-member-functions arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-member-functions arg))
(defun ebrowse-tree-command:show-static-member-variables (arg)
"Display static member variables; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-static-variables arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-static-variables arg))
(defun ebrowse-tree-command:show-static-member-functions (arg)
"Display static member functions; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-static-functions arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-static-functions arg))
(defun ebrowse-tree-command:show-friends (arg)
"Display friend functions; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-friends arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-friends arg))
(defun ebrowse-tree-command:show-types (arg)
"Display types defined in a class; with prefix ARG in frozen member buffer."
(interactive "P")
- (ebrowse-display-member-buffer 'ebrowse-ts-types arg))
+ (ebrowse-display-member-buffer #'ebrowse-ts-types arg))
@@ -1562,12 +1501,12 @@ 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)
- (set (make-local-variable 'ebrowse--frame-configuration)
+ (setq-local ebrowse--frame-configuration
old-frame-configuration)
- (set (make-local-variable 'ebrowse--view-exit-action)
+ (setq-local ebrowse--view-exit-action
(and (not had-a-buf)
(not (buffer-modified-p buf-to-view))
- 'kill-buffer))
+ #'kill-buffer))
(view-mode-enter (cons (selected-window) (cons (selected-window) t))
'ebrowse-view-exit-fn)))
@@ -1934,7 +1873,7 @@ COLLAPSE non-nil means collapse the branch."
(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"))
- (set (make-local-variable 'Helper-return-blurb) "return to buffer editing")
+ (setq-local Helper-return-blurb "return to buffer editing")
(setq truncate-lines t
buffer-read-only t))
@@ -2145,41 +2084,31 @@ See `Electric-command-loop' for a description of STATE and CONDITION."
(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
- ebrowse--column-width ;width of columns above
- ebrowse--show-inherited-flag ;include inherited members?
- ebrowse--filters ;public, protected, private
+ '(ebrowse--n-columns ;number of short columns
ebrowse--accessor ;vars, functions, friends
ebrowse--displayed-class ;class displayed
- ebrowse--long-display-flag ;display with regexps?
- ebrowse--source-regexp-flag ;show source regexp?
- ebrowse--attributes-flag ;show `virtual' and `inline'
ebrowse--member-list ;list of members displayed
ebrowse--tree ;the class tree
ebrowse--member-mode-strings ;part of mode line
ebrowse--tags-file-name ;
ebrowse--header
- ebrowse--tree-obarray
- ebrowse--virtual-display-flag
- ebrowse--inline-display-flag
- ebrowse--const-display-flag
- ebrowse--pure-display-flag
+ ebrowse--tree-table
ebrowse--frozen-flag)) ;buffer not automagically reused
- (setq mode-line-buffer-identification
- (propertized-buffer-identification "C++ Members")
- buffer-read-only t
- ebrowse--long-display-flag nil
- ebrowse--attributes-flag t
- ebrowse--show-inherited-flag t
- ebrowse--source-regexp-flag nil
- ebrowse--filters [0 1 2]
- ebrowse--decl-column ebrowse-default-declaration-column
- ebrowse--column-width ebrowse-default-column-width
- ebrowse--virtual-display-flag nil
- ebrowse--inline-display-flag nil
- ebrowse--const-display-flag nil
- ebrowse--pure-display-flag nil)
+ (setq-local
+ mode-line-buffer-identification
+ (propertized-buffer-identification "C++ Members")
+ buffer-read-only t
+ ebrowse--long-display-flag nil ;display with regexps?
+ ebrowse--attributes-flag t ;show `virtual' and `inline'
+ ebrowse--show-inherited-flag t ;include inherited members?
+ ebrowse--source-regexp-flag nil ;show source regexp?
+ ebrowse--filters [0 1 2] ;public, protected, private
+ ebrowse--decl-column ebrowse-default-declaration-column ;display column
+ ebrowse--column-width ebrowse-default-column-width ;width of columns above
+ ebrowse--virtual-display-flag nil
+ ebrowse--inline-display-flag nil
+ ebrowse--const-display-flag nil
+ ebrowse--pure-display-flag nil)
(modify-syntax-entry ?_ (char-to-string (char-syntax ?a))))
@@ -2257,10 +2186,10 @@ make one."
(ebrowse-create-tree-buffer ebrowse--tree
ebrowse--tags-file-name
ebrowse--header
- ebrowse--tree-obarray
+ ebrowse--tree-table
'pop))))
(and buf
- (funcall (if arg 'switch-to-buffer 'pop-to-buffer) buf))
+ (funcall (if arg #'switch-to-buffer #'pop-to-buffer) buf))
buf))
@@ -2276,8 +2205,9 @@ make one."
(defun ebrowse-cyclic-display-next/previous-member-list (incr)
"Switch buffer to INCR'th next/previous list of members."
- (let ((index (ebrowse-position ebrowse--accessor
- ebrowse-member-list-accessors)))
+ (let ((index (seq-position ebrowse-member-list-accessors
+ ebrowse--accessor
+ #'eql)))
(setf ebrowse--accessor
(cond ((cl-plusp incr)
(or (nth (1+ index)
@@ -2306,37 +2236,37 @@ make one."
(defun ebrowse-display-function-member-list ()
"Display the list of member functions."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-functions))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-functions))
(defun ebrowse-display-variables-member-list ()
"Display the list of member variables."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-variables))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-variables))
(defun ebrowse-display-static-variables-member-list ()
"Display the list of static member variables."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-variables))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-variables))
(defun ebrowse-display-static-functions-member-list ()
"Display the list of static member functions."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-functions))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-functions))
(defun ebrowse-display-friends-member-list ()
"Display the list of friends."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-friends))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-friends))
(defun ebrowse-display-types-member-list ()
"Display the list of types."
(interactive)
- (ebrowse-display-member-list-for-accessor 'ebrowse-ts-types))
+ (ebrowse-display-member-list-for-accessor #'ebrowse-ts-types))
@@ -2565,8 +2495,8 @@ TAGS-FILE is the file name of the BROWSE file."
"Force buffer redisplay."
(interactive)
(let ((display-fn (if ebrowse--long-display-flag
- 'ebrowse-draw-member-long-fn
- 'ebrowse-draw-member-short-fn)))
+ #'ebrowse-draw-member-long-fn
+ #'ebrowse-draw-member-short-fn)))
(with-silent-modifications
(erase-buffer)
;; Show this class
@@ -2610,7 +2540,7 @@ the class cursor is on."
"Start point for member buffer creation.
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)
+ (let* ((classes ebrowse--tree-table)
(tree ebrowse--tree)
(tags-file ebrowse--tags-file-name)
(header ebrowse--header)
@@ -2630,7 +2560,7 @@ means the member buffer is standalone. CLASS is its class."
(setq ebrowse--member-list (funcall list class)
ebrowse--displayed-class class
ebrowse--accessor list
- ebrowse--tree-obarray classes
+ ebrowse--tree-table classes
ebrowse--frozen-flag stand-alone
ebrowse--tags-file-name tags-file
ebrowse--header header
@@ -2842,7 +2772,7 @@ REPEAT, if specified, says repeat the search REPEAT times."
(cl-defun ebrowse-move-point-to-member (name &optional count &aux member)
- "Set point on member NAME in the member buffer
+ "Set point on member NAME in the member buffer.
COUNT, if specified, says search the COUNT'th member with the same name."
(goto-char (point-min))
(widen)
@@ -2867,7 +2797,8 @@ COMPL-LIST is a completion list to use."
(class (or (ebrowse-completing-read-value title compl-list initial)
(error "Not found"))))
(setf ebrowse--displayed-class class
- ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class))
+ ebrowse--member-list (funcall ebrowse--accessor
+ ebrowse--displayed-class))
(ebrowse-redisplay-member-buffer)))
@@ -2875,7 +2806,9 @@ COMPL-LIST is a completion list to use."
"Switch member buffer to a class read from the minibuffer."
(interactive)
(ebrowse-switch-member-buffer-to-other-class
- "Goto class: " (ebrowse-tree-obarray-as-alist)))
+ "Goto class: "
+ ;; FIXME: Why not use the hash-table as-is?
+ (ebrowse-tree-table-as-alist)))
(defun ebrowse-switch-member-buffer-to-base-class (arg)
@@ -2927,8 +2860,9 @@ Prefix arg INC specifies which one."
(cl-first supers))))
(unless tree (error "Not found"))
(setq containing-list (ebrowse-ts-subclasses tree)))))
- (setq index (+ inc (ebrowse-position ebrowse--displayed-class
- containing-list)))
+ (setq index (+ inc (seq-position containing-list
+ ebrowse--displayed-class
+ #'eql)))
(cond ((cl-minusp index) (message "No previous class"))
((null (nth index containing-list)) (message "No next class")))
(setq index (max 0 (min index (1- (length containing-list)))))
@@ -2943,16 +2877,16 @@ Prefix arg INC specifies which one."
Prefix arg ARG says which class should be displayed. Default is
the first derived class."
(interactive "P")
- (cl-flet ((ebrowse-tree-obarray-as-alist ()
+ (cl-flet ((ebrowse-tree-table-as-alist ()
(cl-loop for s in (ebrowse-ts-subclasses
ebrowse--displayed-class)
- collect (cons (ebrowse-cs-name
- (ebrowse-ts-class s)) s))))
+ collect (cons (ebrowse-cs-name (ebrowse-ts-class s))
+ s))))
(let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class)
(error "No derived classes"))))
(if (and arg (cl-second subs))
(ebrowse-switch-member-buffer-to-other-class
- "Goto derived class: " (ebrowse-tree-obarray-as-alist))
+ "Goto derived class: " (ebrowse-tree-table-as-alist))
(setq ebrowse--displayed-class (cl-first subs)
ebrowse--member-list
(funcall ebrowse--accessor ebrowse--displayed-class))
@@ -3250,8 +3184,8 @@ MEMBER-NAME is the name of the member found."
(let* ((start (point))
(name (progn (skip-chars-forward "a-zA-Z0-9_")
(buffer-substring start (point))))
- class)
- (list class name))))
+ ) ;; class
+ (list nil name)))) ;; class
(defun ebrowse-tags-choose-class (_tree header name initial-class-name)
@@ -3403,7 +3337,8 @@ It is a list (TREE ACCESSOR MEMBER)."
(switch-to-buffer buffer)
(setq ebrowse--displayed-class (cl-first info)
ebrowse--accessor (cl-second info)
- ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class))
+ ebrowse--member-list (funcall ebrowse--accessor
+ ebrowse--displayed-class))
(ebrowse-redisplay-member-buffer)))
(ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info)))))
@@ -3513,28 +3448,20 @@ KIND is an additional string printed in the buffer."
(_ "unknown"))
"\n")))
-(defvar ebrowse-last-completion nil
+(defvar-local ebrowse-last-completion nil
"Text inserted by the last completion operation.")
-(defvar ebrowse-last-completion-start nil
+(defvar-local ebrowse-last-completion-start nil
"String which was the basis for the last completion operation.")
-(defvar ebrowse-last-completion-location nil
+(defvar-local ebrowse-last-completion-location nil
"Buffer position at which the last completion operation was initiated.")
-(defvar ebrowse-last-completion-obarray nil
+(defvar-local ebrowse-last-completion-table nil
"Member used in last completion operation.")
-
-
-(make-variable-buffer-local 'ebrowse-last-completion-obarray)
-(make-variable-buffer-local 'ebrowse-last-completion-location)
-(make-variable-buffer-local 'ebrowse-last-completion)
-(make-variable-buffer-local 'ebrowse-last-completion-start)
-
-
(defun ebrowse-some-member-table ()
"Return a hash table containing all members of a tree.
@@ -3552,7 +3479,7 @@ use choose a tree."
(defun ebrowse-cyclic-successor-in-string-list (string list)
"Return the item following STRING in LIST.
If STRING is the last element, return the first element as successor."
- (or (nth (1+ (ebrowse-position string list 'string=)) list)
+ (or (nth (1+ (seq-position list string #'string=)) list)
(cl-first list)))
@@ -3583,7 +3510,7 @@ completion."
;; expansion ended, insert the next expansion.
((eq (point) ebrowse-last-completion-location)
(setf list (all-completions ebrowse-last-completion-start
- ebrowse-last-completion-obarray)
+ ebrowse-last-completion-table)
completion (ebrowse-cyclic-successor-in-string-list
ebrowse-last-completion list))
(cond ((null completion)
@@ -3599,7 +3526,7 @@ completion."
;; buffer: Start new completion.
(t
(let* ((members (ebrowse-some-member-table))
- (completion (cl-first (all-completions pattern members nil))))
+ (completion (cl-first (all-completions pattern members))))
(cond ((eq completion t))
((null completion)
(error "Can't find completion for `%s'" pattern))
@@ -3610,14 +3537,14 @@ completion."
(setf ebrowse-last-completion-location (point)
ebrowse-last-completion-start pattern
ebrowse-last-completion completion
- ebrowse-last-completion-obarray members))))))))
+ ebrowse-last-completion-table members))))))))
;;; Tags query replace & search
-(defvar ebrowse-tags-loop-form ()
- "Form for `ebrowse-tags-loop-continue'.
-Evaluated for each file in the tree. If it returns nil, proceed
+(defvar ebrowse-tags-loop-call '(ignore)
+ "Function call for `ebrowse-tags-loop-continue'.
+Passed to `apply' for each file in the tree. If it returns nil, proceed
with the next file.")
(defvar ebrowse-tags-next-file-list ()
@@ -3684,7 +3611,7 @@ TREE-BUFFER if indirectly specifies which files to loop over."
(when first-time
(ebrowse-tags-next-file first-time tree-buffer)
(goto-char (point-min)))
- (while (not (eval ebrowse-tags-loop-form))
+ (while (not (apply ebrowse-tags-loop-call))
(ebrowse-tags-next-file)
(message "Scanning file `%s'..." buffer-file-name)
(goto-char (point-min))))
@@ -3697,9 +3624,9 @@ If marked classes exist, process marked classes, only.
If regular expression is nil, repeat last search."
(interactive "sTree search (regexp): ")
(if (and (string= regexp "")
- (eq (car ebrowse-tags-loop-form) 're-search-forward))
+ (eq (car ebrowse-tags-loop-call) #'re-search-forward))
(ebrowse-tags-loop-continue)
- (setq ebrowse-tags-loop-form (list 're-search-forward regexp nil t))
+ (setq ebrowse-tags-loop-call `(re-search-forward ,regexp nil t))
(ebrowse-tags-loop-continue 'first-time)))
@@ -3709,10 +3636,11 @@ If regular expression is nil, repeat last search."
With prefix arg, process files of marked classes only."
(interactive
"sTree query replace (regexp): \nsTree query replace %s by: ")
- (setq ebrowse-tags-loop-form
- (list 'and (list 'save-excursion
- (list 're-search-forward from nil t))
- (list 'not (list 'perform-replace from to t t nil))))
+ (setq ebrowse-tags-loop-call
+ (list (lambda ()
+ (and (save-excursion
+ (re-search-forward from nil t))
+ (not (perform-replace from to t t nil))))))
(ebrowse-tags-loop-continue 'first-time))
@@ -3737,7 +3665,7 @@ looks like a function call to the member."
(cl-values-list (ebrowse-tags-read-name header "Find calls of: "))))
;; Set tags loop form to search for member and begin loop.
(setq regexp (concat "\\<" name "[ \t]*(")
- ebrowse-tags-loop-form (list 're-search-forward regexp nil t))
+ ebrowse-tags-loop-call `(re-search-forward ,regexp nil t))
(ebrowse-tags-loop-continue 'first-time tree-buffer))))
@@ -3746,7 +3674,7 @@ looks like a function call to the member."
;;; Structures of this kind are the elements of the position stack.
-(cl-defstruct (ebrowse-position (:type vector) :named)
+(cl-defstruct (ebrowse-position)
file-name ; in which file
point ; point in file
target ; t if target of a jump
@@ -3839,18 +3767,10 @@ Prefix arg ARG says how much."
;;; Electric position list
-(defvar ebrowse-electric-position-mode-map ()
- "Keymap used in electric position stack window.")
-
-
-(defvar ebrowse-electric-position-mode-hook nil
- "If non-nil, its value is called by `ebrowse-electric-position-mode'.")
-
-
-(unless ebrowse-electric-position-mode-map
+(defvar ebrowse-electric-position-mode-map
(let ((map (make-keymap))
(submap (make-keymap)))
- (setq ebrowse-electric-position-mode-map map)
+ ;; FIXME: Yuck!
(fillarray (car (cdr map)) 'ebrowse-electric-position-undefined)
(fillarray (car (cdr submap)) 'ebrowse-electric-position-undefined)
(define-key map "\e" submap)
@@ -3873,14 +3793,19 @@ Prefix arg ARG says how much."
(define-key map "\e\C-v" 'scroll-other-window)
(define-key map "\e>" 'end-of-buffer)
(define-key map "\e<" 'beginning-of-buffer)
- (define-key map "\e>" 'end-of-buffer)))
+ (define-key map "\e>" 'end-of-buffer)
+ map)
+ "Keymap used in electric position stack window.")
+
+
+(defvar ebrowse-electric-position-mode-hook nil
+ "If non-nil, its value is called by `ebrowse-electric-position-mode'.")
-(put 'ebrowse-electric-position-mode 'mode-class 'special)
(put 'ebrowse-electric-position-undefined 'suppress-keymap t)
(define-derived-mode ebrowse-electric-position-mode
- fundamental-mode "Electric Position Menu"
+ special-mode "Electric Position Menu"
"Mode for electric position buffers.
Runs the hook `ebrowse-electric-position-mode-hook'."
(setq mode-line-buffer-identification "Electric Position Menu")
@@ -3888,7 +3813,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'."
(setq mode-line-format (copy-sequence mode-line-format))
;; FIXME: Why not set `mode-name' to "Positions"?
(setcar (memq 'mode-name mode-line-format) "Positions"))
- (set (make-local-variable 'Helper-return-blurb) "return to buffer editing")
+ (setq-local Helper-return-blurb "return to buffer editing")
(setq truncate-lines t
buffer-read-only t))
@@ -4101,7 +4026,7 @@ NUMBER-OF-INSTANCE-VARIABLES NUMBER-OF-STATIC-FUNCTIONS
NUMBER-OF-STATIC-VARIABLES:"
(let ((classes 0) (member-functions 0) (member-variables 0)
(static-functions 0) (static-variables 0))
- (ebrowse-for-all-trees (tree ebrowse--tree-obarray)
+ (ebrowse-for-all-trees (tree ebrowse--tree-table)
(cl-incf classes)
(cl-incf member-functions (length (ebrowse-ts-member-functions tree)))
(cl-incf member-variables (length (ebrowse-ts-member-variables tree)))
@@ -4391,10 +4316,4 @@ EVENT is the mouse event."
(provide 'ebrowse)
-
-;; Local variables:
-;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0)
-;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1)
-;; End:
-
;;; ebrowse.el ends here
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 01f09a12404..7ed2d3d08cc 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -38,165 +38,156 @@ It has `lisp-mode-abbrev-table' as its parent."
:parents (list lisp-mode-abbrev-table))
(defvar emacs-lisp-mode-syntax-table
- (let ((table (make-syntax-table lisp--mode-syntax-table)))
- (modify-syntax-entry ?\[ "(] " table)
- (modify-syntax-entry ?\] ")[ " table)
+ (let ((table (make-syntax-table lisp-data-mode-syntax-table)))
+ ;; These are redundant, now.
+ ;;(modify-syntax-entry ?\[ "(] " table)
+ ;;(modify-syntax-entry ?\] ")[ " table)
table)
"Syntax table used in `emacs-lisp-mode'.")
(defvar emacs-lisp-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Emacs-Lisp"))
- (lint-map (make-sparse-keymap))
- (prof-map (make-sparse-keymap))
- (tracing-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\t" 'completion-at-point)
(define-key map "\e\C-x" 'eval-defun)
(define-key map "\e\C-q" 'indent-pp-sexp)
- (bindings--define-key map [menu-bar emacs-lisp]
- (cons "Emacs-Lisp" menu-map))
- (bindings--define-key menu-map [eldoc]
- '(menu-item "Auto-Display Documentation Strings" eldoc-mode
- :button (:toggle . (bound-and-true-p eldoc-mode))
- :help "Display the documentation string for the item under cursor"))
- (bindings--define-key menu-map [checkdoc]
- '(menu-item "Check Documentation Strings" checkdoc
- :help "Check documentation strings for style requirements"))
- (bindings--define-key menu-map [re-builder]
- '(menu-item "Construct Regexp" re-builder
- :help "Construct a regexp interactively"))
- (bindings--define-key menu-map [tracing] (cons "Tracing" tracing-map))
- (bindings--define-key tracing-map [tr-a]
- '(menu-item "Untrace All" untrace-all
- :help "Untrace all currently traced functions"))
- (bindings--define-key tracing-map [tr-uf]
- '(menu-item "Untrace Function..." untrace-function
- :help "Untrace function, and possibly activate all remaining advice"))
- (bindings--define-key tracing-map [tr-sep] menu-bar-separator)
- (bindings--define-key tracing-map [tr-q]
- '(menu-item "Trace Function Quietly..." trace-function-background
- :help "Trace the function with trace output going quietly to a buffer"))
- (bindings--define-key tracing-map [tr-f]
- '(menu-item "Trace Function..." trace-function
- :help "Trace the function given as an argument"))
- (bindings--define-key menu-map [profiling] (cons "Profiling" prof-map))
- (bindings--define-key prof-map [prof-restall]
- '(menu-item "Remove Instrumentation for All Functions" elp-restore-all
- :help "Restore the original definitions of all functions being profiled"))
- (bindings--define-key prof-map [prof-restfunc]
- '(menu-item "Remove Instrumentation for Function..." elp-restore-function
- :help "Restore an instrumented function to its original definition"))
-
- (bindings--define-key prof-map [sep-rem] menu-bar-separator)
- (bindings--define-key prof-map [prof-resall]
- '(menu-item "Reset Counters for All Functions" elp-reset-all
- :help "Reset the profiling information for all functions being profiled"))
- (bindings--define-key prof-map [prof-resfunc]
- '(menu-item "Reset Counters for Function..." elp-reset-function
- :help "Reset the profiling information for a function"))
- (bindings--define-key prof-map [prof-res]
- '(menu-item "Show Profiling Results" elp-results
- :help "Display current profiling results"))
- (bindings--define-key prof-map [prof-pack]
- '(menu-item "Instrument Package..." elp-instrument-package
- :help "Instrument for profiling all function that start with a prefix"))
- (bindings--define-key prof-map [prof-func]
- '(menu-item "Instrument Function..." elp-instrument-function
- :help "Instrument a function for profiling"))
- ;; Maybe this should be in a separate submenu from the ELP stuff?
- (bindings--define-key prof-map [sep-natprof] menu-bar-separator)
- (bindings--define-key prof-map [prof-natprof-stop]
- '(menu-item "Stop Native Profiler" profiler-stop
- :help "Stop recording profiling information"
- :enable (and (featurep 'profiler)
- (profiler-running-p))))
- (bindings--define-key prof-map [prof-natprof-report]
- '(menu-item "Show Profiler Report" profiler-report
- :help "Show the current profiler report"
- :enable (and (featurep 'profiler)
- (profiler-running-p))))
- (bindings--define-key prof-map [prof-natprof-start]
- '(menu-item "Start Native Profiler..." profiler-start
- :help "Start recording profiling information"))
-
- (bindings--define-key menu-map [lint] (cons "Linting" lint-map))
- (bindings--define-key lint-map [lint-di]
- '(menu-item "Lint Directory..." elint-directory
- :help "Lint a directory"))
- (bindings--define-key lint-map [lint-f]
- '(menu-item "Lint File..." elint-file
- :help "Lint a file"))
- (bindings--define-key lint-map [lint-b]
- '(menu-item "Lint Buffer" elint-current-buffer
- :help "Lint the current buffer"))
- (bindings--define-key lint-map [lint-d]
- '(menu-item "Lint Defun" elint-defun
- :help "Lint the function at point"))
- (bindings--define-key menu-map [edebug-defun]
- '(menu-item "Instrument Function for Debugging" edebug-defun
- :help "Evaluate the top level form point is in, stepping through with Edebug"
- :keys "C-u C-M-x"))
- (bindings--define-key menu-map [separator-byte] menu-bar-separator)
- (bindings--define-key menu-map [disas]
- '(menu-item "Disassemble Byte Compiled Object..." disassemble
- :help "Print disassembled code for OBJECT in a buffer"))
- (bindings--define-key menu-map [byte-recompile]
- '(menu-item "Byte-recompile Directory..." byte-recompile-directory
- :help "Recompile every `.el' file in DIRECTORY that needs recompilation"))
- (bindings--define-key menu-map [emacs-byte-compile-and-load]
- '(menu-item "Byte-compile and Load" emacs-lisp-byte-compile-and-load
- :help "Byte-compile the current file (if it has changed), then load compiled code"))
- (bindings--define-key menu-map [byte-compile]
- '(menu-item "Byte-compile This File" emacs-lisp-byte-compile
- :help "Byte compile the file containing the current buffer"))
- (bindings--define-key menu-map [separator-eval] menu-bar-separator)
- (bindings--define-key menu-map [ielm]
- '(menu-item "Interactive Expression Evaluation" ielm
- :help "Interactively evaluate Emacs Lisp expressions"))
- (bindings--define-key menu-map [eval-buffer]
- '(menu-item "Evaluate Buffer" eval-buffer
- :help "Execute the current buffer as Lisp code"))
- (bindings--define-key menu-map [eval-region]
- '(menu-item "Evaluate Region" eval-region
- :help "Execute the region as Lisp code"
- :enable mark-active))
- (bindings--define-key menu-map [eval-sexp]
- '(menu-item "Evaluate Last S-expression" eval-last-sexp
- :help "Evaluate sexp before point; print value in echo area"))
- (bindings--define-key menu-map [separator-format] menu-bar-separator)
- (bindings--define-key menu-map [comment-region]
- '(menu-item "Comment Out Region" comment-region
- :help "Comment or uncomment each line in the region"
- :enable mark-active))
- (bindings--define-key menu-map [indent-region]
- '(menu-item "Indent Region" indent-region
- :help "Indent each nonblank line in the region"
- :enable mark-active))
- (bindings--define-key menu-map [indent-line]
- '(menu-item "Indent Line" lisp-indent-line))
map)
"Keymap for Emacs Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
+(easy-menu-define emacs-lisp-mode-menu emacs-lisp-mode-map
+ "Menu for Emacs Lisp mode."
+ '("Emacs-Lisp"
+ ["Indent Line" lisp-indent-line]
+ ["Indent Region" indent-region
+ :help "Indent each nonblank line in the region"
+ :active mark-active]
+ ["Comment Out Region" comment-region
+ :help "Comment or uncomment each line in the region"
+ :active mark-active]
+ "---"
+ ["Evaluate Last S-expression" eval-last-sexp
+ :help "Evaluate sexp before point; print value in echo area"]
+ ["Evaluate Region" eval-region
+ :help "Execute the region as Lisp code"
+ :active mark-active]
+ ["Evaluate Buffer" eval-buffer
+ :help "Execute the current buffer as Lisp code"]
+ ["Interactive Expression Evaluation" ielm
+ :help "Interactively evaluate Emacs Lisp expressions"]
+ "---"
+ ["Byte-compile This File" emacs-lisp-byte-compile
+ :help "Byte compile the file containing the current buffer"]
+ ["Byte-compile and Load" emacs-lisp-byte-compile-and-load
+ :help "Byte-compile the current file (if it has changed), then load compiled code"]
+ ["Byte-recompile Directory..." byte-recompile-directory
+ :help "Recompile every `.el' file in DIRECTORY that needs recompilation"]
+ ["Disassemble Byte Compiled Object..." disassemble
+ :help "Print disassembled code for OBJECT in a buffer"]
+ "---"
+ ["Instrument Function for Debugging" edebug-defun
+ :help "Evaluate the top level form point is in, stepping through with Edebug"
+ :keys "C-u C-M-x"]
+ ("Navigation"
+ ["Forward Sexp" forward-sexp
+ :help "Go to the next s-expression"]
+ ["Backward Sexp" backward-sexp
+ :help "Go to the previous s-expression"]
+ ["Beginning Of Defun" beginning-of-defun
+ :help "Go to the start of the current function definition"]
+ ["Up List" up-list
+ :help "Go one level up and forward"])
+ ("Linting"
+ ["Lint Defun" elint-defun
+ :help "Lint the function at point"]
+ ["Lint Buffer" elint-current-buffer
+ :help "Lint the current buffer"]
+ ["Lint File..." elint-file
+ :help "Lint a file"]
+ ["Lint Directory..." elint-directory
+ :help "Lint a directory"])
+ ("Profiling"
+ ;; Maybe this should be in a separate submenu from the ELP stuff?
+ ["Start Native Profiler..." profiler-start
+ :help "Start recording profiling information"]
+ ["Show Profiler Report" profiler-report
+ :help "Show the current profiler report"
+ :active (and (featurep 'profiler)
+ (profiler-running-p))]
+ ["Stop Native Profiler" profiler-stop
+ :help "Stop recording profiling information"
+ :active (and (featurep 'profiler)
+ (profiler-running-p))]
+ "---"
+ ["Instrument Function..." elp-instrument-function
+ :help "Instrument a function for profiling"]
+ ["Instrument Package..." elp-instrument-package
+ :help "Instrument for profiling all function that start with a prefix"]
+ ["Show Profiling Results" elp-results
+ :help "Display current profiling results"]
+ ["Reset Counters for Function..." elp-reset-function
+ :help "Reset the profiling information for a function"]
+ ["Reset Counters for All Functions" elp-reset-all
+ :help "Reset the profiling information for all functions being profiled"]
+ "---"
+ ["Remove Instrumentation for All Functions" elp-restore-all
+ :help "Restore the original definitions of all functions being profiled"]
+ ["Remove Instrumentation for Function..." elp-restore-function
+ :help "Restore an instrumented function to its original definition"])
+ ("Tracing"
+ ["Trace Function..." trace-function
+ :help "Trace the function given as an argument"]
+ ["Trace Function Quietly..." trace-function-background
+ :help "Trace the function with trace output going quietly to a buffer"]
+ "---"
+ ["Untrace All" untrace-all
+ :help "Untrace all currently traced functions"]
+ ["Untrace Function..." untrace-function
+ :help "Untrace function, and possibly activate all remaining advice"])
+ ["Construct Regexp" re-builder
+ :help "Construct a regexp interactively"]
+ ["Check Documentation Strings" checkdoc
+ :help "Check documentation strings for style requirements"]
+ ["Auto-Display Documentation Strings" eldoc-mode
+ :help "Display the documentation string for the item under cursor"
+ :style toggle
+ :selected (bound-and-true-p eldoc-mode)]))
+
(defun emacs-lisp-byte-compile ()
"Byte compile the file containing the current buffer."
- (interactive)
+ (interactive nil emacs-lisp-mode)
(if buffer-file-name
(byte-compile-file buffer-file-name)
(error "The buffer must be saved in a file first")))
-(defun emacs-lisp-byte-compile-and-load ()
- "Byte-compile the current file (if it has changed), then load compiled code."
- (interactive)
+(defun emacs-lisp--before-compile-buffer ()
+ "Make sure the buffer is saved before compiling."
(or buffer-file-name
(error "The buffer must be saved in a file first"))
- (require 'bytecomp)
;; Recompile if file or buffer has changed since last compilation.
(if (and (buffer-modified-p)
(y-or-n-p (format "Save buffer %s first? " (buffer-name))))
- (save-buffer))
- (byte-recompile-file buffer-file-name nil 0 t))
+ (save-buffer)))
+
+(defun emacs-lisp-byte-compile-and-load ()
+ "Byte-compile the current file (if it has changed), then load compiled code."
+ (interactive nil emacs-lisp-mode)
+ (emacs-lisp--before-compile-buffer)
+ (require 'bytecomp)
+ (byte-recompile-file buffer-file-name nil 0)
+ (load buffer-file-name))
+
+(declare-function native-compile "comp")
+(defun emacs-lisp-native-compile-and-load ()
+ "Native-compile synchronously the current file (if it has changed).
+Load the compiled code when finished.
+
+Use `emacs-lisp-byte-compile-and-load' in combination with
+`native-comp-deferred-compilation' set to `t' to achieve asynchronous
+native compilation."
+ (interactive nil emacs-lisp-mode)
+ (emacs-lisp--before-compile-buffer)
+ (load (native-compile buffer-file-name)))
(defun emacs-lisp-macroexpand ()
"Macroexpand the form after point.
@@ -231,8 +222,35 @@ Comments in the form will be lost."
(setq-local electric-pair-text-pairs elisp-pairs)))))
(remove-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs))
+(defun elisp-enable-lexical-binding (&optional interactive)
+ "Make the current buffer use `lexical-binding'."
+ (interactive "p")
+ (if lexical-binding
+ (when interactive
+ (message "lexical-binding already enabled!")
+ (ding))
+ (when (or (not interactive)
+ (y-or-n-p (format "Enable lexical-binding in this %s? "
+ (if buffer-file-name "file" "buffer"))))
+ (setq-local lexical-binding t)
+ (add-file-local-variable-prop-line 'lexical-binding t interactive))))
+
+(defvar elisp--dynlex-modeline-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mode-line mouse-1] 'elisp-enable-lexical-binding)
+ map))
+
;;;###autoload
-(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp"
+(define-derived-mode emacs-lisp-mode lisp-data-mode
+ `("ELisp"
+ (lexical-binding (:propertize "/l"
+ help-echo "Using lexical-binding mode")
+ (:propertize "/d"
+ help-echo "Using old dynamic scoping mode\n\
+mouse-1: Enable lexical-binding mode"
+ face warning
+ mouse-face mode-line-highlight
+ local-map ,elisp--dynlex-modeline-map)))
"Major mode for editing Lisp code to run in Emacs.
Commands:
Delete converts tabs to spaces as it moves back.
@@ -241,35 +259,28 @@ Blank lines separate paragraphs. Semicolons start comments.
\\{emacs-lisp-mode-map}"
:group 'lisp
(defvar project-vc-external-roots-function)
- (lisp-mode-variables nil nil 'elisp)
+ (setcar font-lock-defaults
+ '(lisp-el-font-lock-keywords
+ lisp-el-font-lock-keywords-1
+ lisp-el-font-lock-keywords-2))
+ (setf (nth 2 font-lock-defaults) nil)
(add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers)
(if (boundp 'electric-pair-text-pairs)
(setq-local electric-pair-text-pairs
- (append '((?\` . ?\') (?‘ . ?’))
+ (append '((?\` . ?\') (?\‘ . ?\’))
electric-pair-text-pairs))
(add-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs))
- (setq-local electric-quote-string t)
- (setq imenu-case-fold-search nil)
- (add-function :before-until (local 'eldoc-documentation-function)
- #'elisp-eldoc-documentation-function)
+ (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-funcall nil t)
+ (add-hook 'eldoc-documentation-functions
+ #'elisp-eldoc-var-docstring nil t)
(add-hook 'xref-backend-functions #'elisp--xref-backend nil t)
(setq-local project-vc-external-roots-function #'elisp-load-path-roots)
(add-hook 'completion-at-point-functions
#'elisp-completion-at-point nil 'local)
- ;; .dir-locals.el and lock files will cause the byte-compiler and
- ;; checkdoc emit spurious warnings, because they don't follow the
- ;; conventions of Emacs Lisp sources. Until we have a better fix,
- ;; like teaching elisp-mode about files that only hold data
- ;; structures, we disable the ELisp Flymake backend for these files.
- (unless
- (let* ((bfname (buffer-file-name))
- (fname (and (stringp bfname) (file-name-nondirectory bfname))))
- (and (stringp fname)
- (or (string-match "\\`\\.#" fname)
- (string-equal dir-locals-file fname))))
- (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t)
- (add-hook 'flymake-diagnostic-functions
- #'elisp-flymake-byte-compile nil t)))
+ (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t)
+ (add-hook 'flymake-diagnostic-functions
+ #'elisp-flymake-byte-compile nil t))
;; Font-locking support.
@@ -501,7 +512,7 @@ functions are annotated with \"<f>\" via the
(end
(unless (or (eq beg (point-max))
(member (char-syntax (char-after beg))
- '(?\s ?\" ?\( ?\))))
+ '(?\" ?\()))
(condition-case nil
(save-excursion
(goto-char beg)
@@ -535,6 +546,7 @@ functions are annotated with \"<f>\" via the
((elisp--expect-function-p beg)
(list nil obarray
:predicate #'fboundp
+ :company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location))
@@ -548,6 +560,7 @@ functions are annotated with \"<f>\" via the
(symbol-plist sym)))
:annotation-function
(lambda (str) (if (fboundp (intern-soft str)) " <f>"))
+ :company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location))
@@ -558,6 +571,11 @@ functions are annotated with \"<f>\" via the
obarray
#'boundp
'strict))
+ :company-kind
+ (lambda (s)
+ (if (test-completion s elisp--local-variables-completion-table)
+ 'value
+ 'variable))
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location)))
@@ -604,11 +622,13 @@ functions are annotated with \"<f>\" via the
(looking-at "\\_<let\\*?\\_>"))))
(list t obarray
:predicate #'boundp
+ :company-kind (lambda (_) 'variable)
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location))
(_ (list nil obarray
:predicate #'fboundp
+ :company-kind #'elisp--company-kind
:company-doc-buffer #'elisp--company-doc-buffer
:company-docsig #'elisp--company-doc-string
:company-location #'elisp--company-location
@@ -624,6 +644,16 @@ functions are annotated with \"<f>\" via the
" " (cadr table-etc)))
(cddr table-etc)))))))))
+(defun elisp--company-kind (str)
+ (let ((sym (intern-soft str)))
+ (cond
+ ((or (macrop sym) (special-form-p sym)) 'keyword)
+ ((fboundp sym) 'function)
+ ((boundp sym) 'variable)
+ ((featurep sym) 'module)
+ ((facep sym) 'color)
+ (t 'text))))
+
(defun lisp-completion-at-point (&optional _predicate)
(declare (obsolete elisp-completion-at-point "25.1"))
(elisp-completion-at-point))
@@ -637,18 +667,16 @@ functions are annotated with \"<f>\" via the
;; WORKAROUND: This is nominally a constant, but the text properties
;; are not preserved thru dump if use defconst. See bug#21237.
(defvar elisp--xref-format
- (let ((str "(%s %s)"))
- (put-text-property 1 3 'face 'font-lock-keyword-face str)
- (put-text-property 4 6 'face 'font-lock-function-name-face str)
- str))
+ #("(%s %s)"
+ 1 3 (face font-lock-keyword-face)
+ 4 6 (face font-lock-function-name-face)))
;; WORKAROUND: This is nominally a constant, but the text properties
;; are not preserved thru dump if use defconst. See bug#21237.
(defvar elisp--xref-format-extra
- (let ((str "(%s %s %s)"))
- (put-text-property 1 3 'face 'font-lock-keyword-face str)
- (put-text-property 4 6 'face 'font-lock-function-name-face str)
- str))
+ #("(%s %s %s)"
+ 1 3 (face font-lock-keyword-face)
+ 4 6 (face font-lock-function-name-face)))
(defvar find-feature-regexp);; in find-func.el
@@ -662,10 +690,10 @@ otherwise build the summary from TYPE and SYMBOL."
(xref-make-elisp-location symbol type file)))
(defvar elisp-xref-find-def-functions nil
- "List of functions to be run from `elisp--xref-find-definitions' to add additional xrefs.
+ "List of functions run from `elisp--xref-find-definitions' to add more xrefs.
Called with one arg; the symbol whose definition is desired.
Each function should return a list of xrefs, or nil; the first
-non-nil result supercedes the xrefs produced by
+non-nil result supersedes the xrefs produced by
`elisp--xref-find-definitions'.")
(cl-defmethod xref-backend-definitions ((_backend (eql elisp)) identifier)
@@ -845,11 +873,12 @@ non-nil result supercedes the xrefs produced by
xrefs))
-(declare-function project-external-roots "project")
+(declare-function xref-apropos-regexp "xref" (pattern))
-(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp)
+(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) pattern)
(apply #'nconc
- (let (lst)
+ (let ((regexp (xref-apropos-regexp pattern))
+ lst)
(dolist (sym (apropos-internal regexp))
(push (elisp--xref-find-definitions sym) lst))
(nreverse lst))))
@@ -877,11 +906,19 @@ non-nil result supercedes the xrefs produced by
(let ((buffer-point (find-function-search-for-symbol symbol type file)))
(with-current-buffer (car buffer-point)
(save-excursion
- (goto-char (or (cdr buffer-point) (point-min)))
- (point-marker))))))
+ (save-restriction
+ (widen)
+ (goto-char (or (cdr buffer-point) (point-min)))
+ (point-marker)))))))
(cl-defmethod xref-location-group ((l xref-elisp-location))
- (xref-elisp-location-file l))
+ (let ((file (xref-elisp-location-file l)))
+ (defvar find-function-C-source-directory)
+ (if (and find-function-C-source-directory
+ (string-match-p "\\`src/" file))
+ (concat find-function-C-source-directory
+ (substring file 3))
+ file)))
(defun elisp-load-path-roots ()
(if (boundp 'package-user-dir)
@@ -891,35 +928,31 @@ non-nil result supercedes the xrefs produced by
;;; Elisp Interaction mode
(defvar lisp-interaction-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Lisp-Interaction")))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\C-x" 'eval-defun)
(define-key map "\e\C-q" 'indent-pp-sexp)
(define-key map "\e\t" 'completion-at-point)
(define-key map "\n" 'eval-print-last-sexp)
- (bindings--define-key map [menu-bar lisp-interaction]
- (cons "Lisp-Interaction" menu-map))
- (bindings--define-key menu-map [eval-defun]
- '(menu-item "Evaluate Defun" eval-defun
- :help "Evaluate the top-level form containing point, or after point"))
- (bindings--define-key menu-map [eval-print-last-sexp]
- '(menu-item "Evaluate and Print" eval-print-last-sexp
- :help "Evaluate sexp before point; print value into current buffer"))
- (bindings--define-key menu-map [edebug-defun-lisp-interaction]
- '(menu-item "Instrument Function for Debugging" edebug-defun
- :help "Evaluate the top level form point is in, stepping through with Edebug"
- :keys "C-u C-M-x"))
- (bindings--define-key menu-map [indent-pp-sexp]
- '(menu-item "Indent or Pretty-Print" indent-pp-sexp
- :help "Indent each line of the list starting just after point, or prettyprint it"))
- (bindings--define-key menu-map [complete-symbol]
- '(menu-item "Complete Lisp Symbol" completion-at-point
- :help "Perform completion on Lisp symbol preceding point"))
map)
"Keymap for Lisp Interaction mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
+(easy-menu-define lisp-interaction-mode-menu lisp-interaction-mode-map
+ "Menu for Lisp Interaction mode."
+ '("Lisp-Interaction"
+ ["Complete Lisp Symbol" completion-at-point
+ :help "Perform completion on Lisp symbol preceding point"]
+ ["Indent or Pretty-Print" indent-pp-sexp
+ :help "Indent each line of the list starting just after point, or prettyprint it"]
+ ["Instrument Function for Debugging" edebug-defun
+ :help "Evaluate the top level form point is in, stepping through with Edebug"
+ :keys "C-u C-M-x"]
+ ["Evaluate and Print" eval-print-last-sexp
+ :help "Evaluate sexp before point; print value into current buffer"]
+ ["Evaluate Defun" eval-defun
+ :help "Evaluate the top-level form containing point, or after point"]))
+
(define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction"
"Major mode for typing and evaluating Lisp forms.
Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression
@@ -1171,7 +1204,8 @@ character)."
;; Setup the lexical environment if lexical-binding is enabled.
(elisp--eval-last-sexp-print-value
(eval (macroexpand-all
- (eval-sexp-add-defvars (elisp--preceding-sexp)))
+ (eval-sexp-add-defvars
+ (elisp--eval-defun-1 (macroexpand (elisp--preceding-sexp)))))
lexical-binding)
(if insert-value (current-buffer) t) no-truncate char-print-limit)))
@@ -1227,6 +1261,10 @@ POS specifies the starting position where EXP was found and defaults to point."
Interactively, with a non `-' prefix argument, print output into
current buffer.
+This commands handles `defvar', `defcustom' and `defface' the
+same way that `eval-defun' does. See the doc string of that
+function for details.
+
Normally, this function truncates long output according to the
value of the variables `eval-expression-print-length' and
`eval-expression-print-level'. With a prefix argument of zero,
@@ -1240,7 +1278,8 @@ If `eval-expression-debug-on-error' is non-nil, which is the default,
this command arranges for all errors to enter the debugger."
(interactive "P")
(if (null eval-expression-debug-on-error)
- (elisp--eval-last-sexp eval-last-sexp-arg-internal)
+ (values--store-value
+ (elisp--eval-last-sexp eval-last-sexp-arg-internal))
(let ((value
(let ((debug-on-error elisp--eval-last-sexp-fake-value))
(cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
@@ -1286,8 +1325,7 @@ Reinitialize the face according to the `defface' specification."
((eq (car form) 'custom-declare-face)
;; Reset the face.
(let ((face-symbol (eval (nth 1 form) lexical-binding)))
- (setq face-new-frame-defaults
- (assq-delete-all face-symbol face-new-frame-defaults))
+ (remhash face-symbol face--new-frame-defaults)
(put face-symbol 'face-defface-spec nil)
(put face-symbol 'face-override-spec nil))
form)
@@ -1307,9 +1345,11 @@ if it already has a value.)
Return the result of evaluation."
;; FIXME: the print-length/level bindings should only be applied while
;; printing, not while evaluating.
+ (defvar elisp--eval-defun-result)
(let ((debug-on-error eval-expression-debug-on-error)
(print-length eval-expression-print-length)
- (print-level eval-expression-print-level))
+ (print-level eval-expression-print-level)
+ elisp--eval-defun-result)
(save-excursion
;; Arrange for eval-region to "read" the (possibly) altered form.
;; eval-region handles recording which file defines a function or
@@ -1321,21 +1361,25 @@ Return the result of evaluation."
(end-of-defun)
(beginning-of-defun)
(setq beg (point))
- (setq form (read (current-buffer)))
+ (setq form (funcall load-read-function (current-buffer)))
(setq end (point)))
;; Alter the form if necessary.
(let ((form (eval-sexp-add-defvars
- (elisp--eval-defun-1 (macroexpand form)))))
+ (elisp--eval-defun-1
+ (macroexpand form)))))
(eval-region beg end standard-output
(lambda (_ignore)
;; Skipping to the end of the specified region
;; will make eval-region return.
(goto-char end)
- form))))))
- (let ((str (eval-expression-print-format (car values))))
- (if str (princ str)))
- ;; The result of evaluation has been put onto VALUES. So return it.
- (car values))
+ ;; This `setq' needs to be added *after* passing
+ ;; form through `elisp--eval-defun-1' since it
+ ;; would otherwise "hide" forms like `defvar's and
+ ;; thus defeat their special treatment.
+ `(setq elisp--eval-defun-result ,form))))))
+ (let ((str (eval-expression-print-format elisp--eval-defun-result)))
+ (if str (princ str)))
+ elisp--eval-defun-result))
(defun eval-defun (edebug-it)
"Evaluate the top-level form containing point, or after point.
@@ -1365,6 +1409,7 @@ which see."
(interactive "P")
(cond (edebug-it
(require 'edebug)
+ (defvar edebug-all-defs)
(eval-defun (not edebug-all-defs)))
(t
(if (null eval-expression-debug-on-error)
@@ -1386,20 +1431,54 @@ which see."
or argument string for functions.
2 - `function' if function args, `variable' if variable documentation.")
-(defun elisp-eldoc-documentation-function ()
- "`eldoc-documentation-function' (which see) for Emacs Lisp."
- (let ((current-symbol (elisp--current-symbol))
- (current-fnsym (elisp--fnsym-in-current-sexp)))
- (cond ((null current-fnsym)
- nil)
- ((eq current-symbol (car current-fnsym))
- (or (apply #'elisp-get-fnsym-args-string current-fnsym)
- (elisp-get-var-docstring current-symbol)))
- (t
- (or (elisp-get-var-docstring current-symbol)
- (apply #'elisp-get-fnsym-args-string current-fnsym))))))
-
-(defun elisp-get-fnsym-args-string (sym &optional index prefix)
+(defun elisp--documentation-one-liner ()
+ (let* (str
+ (callback (lambda (doc &rest plist)
+ (when doc
+ (setq str
+ (format "%s: %s"
+ (propertize (prin1-to-string
+ (plist-get plist :thing))
+ 'face (plist-get plist :face))
+ doc))))))
+ (or (progn (elisp-eldoc-var-docstring callback) str)
+ (progn (elisp-eldoc-funcall callback) str))))
+
+(defalias 'elisp-eldoc-documentation-function 'elisp--documentation-one-liner
+ "Return Elisp documentation for the thing at point as one-line string.
+This is meant as a backward compatibility aide to the \"old\"
+Elisp eldoc behaviour. Consider variable docstrings and function
+signatures only, in this order. If none applies, returns nil.
+Changes to `eldoc-documentation-functions' and
+`eldoc-documentation-strategy' are _not_ reflected here. As such
+it is preferrable to use ElDoc's interfaces directly.")
+
+(make-obsolete 'elisp-eldoc-documentation-function
+ "use ElDoc's interfaces instead." "28.1")
+
+(defun elisp-eldoc-funcall (callback &rest _ignored)
+ "Document function call at point.
+Intended for `eldoc-documentation-functions' (which see)."
+ (let* ((sym-info (elisp--fnsym-in-current-sexp))
+ (fn-sym (car sym-info)))
+ (when fn-sym
+ (funcall callback (apply #'elisp-get-fnsym-args-string sym-info)
+ :thing fn-sym
+ :face (if (functionp fn-sym)
+ 'font-lock-function-name-face
+ 'font-lock-keyword-face)))))
+
+(defun elisp-eldoc-var-docstring (callback &rest _ignored)
+ "Document variable at point.
+Intended for `eldoc-documentation-functions' (which see)."
+ (let* ((sym (elisp--current-symbol))
+ (docstring (and sym (elisp-get-var-docstring sym))))
+ (when docstring
+ (funcall callback docstring
+ :thing sym
+ :face 'font-lock-variable-name-face))))
+
+(defun elisp-get-fnsym-args-string (sym &optional index)
"Return a string containing the parameter list of the function SYM.
If SYM is a subr and no arglist is obtainable from the docstring
or elsewhere, return a 1-line docstring."
@@ -1425,20 +1504,13 @@ or elsewhere, return a 1-line docstring."
;; Stringify, and store before highlighting, downcasing, etc.
(elisp--last-data-store sym (elisp-function-argstring args)
'function))))))
- ;; Highlight, truncate.
+ ;; Highlight
(if argstring
(elisp--highlight-function-argument
- sym argstring index
- (or prefix
- (concat (propertize (symbol-name sym) 'face
- (if (functionp sym)
- 'font-lock-function-name-face
- 'font-lock-keyword-face))
- ": "))))))
-
-(defun elisp--highlight-function-argument (sym args index prefix)
- "Highlight argument INDEX in ARGS list for function SYM.
-In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'."
+ sym argstring index))))
+
+(defun elisp--highlight-function-argument (sym args index)
+ "Highlight argument INDEX in ARGS list for function SYM."
;; FIXME: This should probably work on the list representation of `args'
;; rather than its string representation.
;; FIXME: This function is much too long, we need to split it up!
@@ -1541,7 +1613,6 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'."
(when start
(setq doc (copy-sequence args))
(add-text-properties start end (list 'face argument-face) doc))
- (setq doc (eldoc-docstring-format-sym-doc prefix doc))
doc)))
;; Return a string containing a brief (one-line) documentation string for
@@ -1554,9 +1625,7 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'."
(t
(let ((doc (documentation-property sym 'variable-documentation t)))
(when doc
- (let ((doc (eldoc-docstring-format-sym-doc
- sym (elisp--docstring-first-line doc)
- 'font-lock-variable-name-face)))
+ (let ((doc (elisp--docstring-first-line doc)))
(elisp--last-data-store sym doc 'variable)))))))
(defun elisp--last-data-store (symbol doc type)
@@ -1668,7 +1737,8 @@ Calls REPORT-FN directly."
collect
(flymake-make-diagnostic
(current-buffer)
- start end :note text)))
+ (or start 1) (or end (1+ (or start 1)))
+ :note text)))
collected))
(defun elisp-flymake--byte-compile-done (report-fn
@@ -1775,12 +1845,9 @@ Runs in a batch-mode Emacs. Interactively use variable
(interactive (list buffer-file-name))
(let* ((file (or file
(car command-line-args-left)))
- (dummy-elc-file)
(byte-compile-log-buffer
(generate-new-buffer " *dummy-byte-compile-log-buffer*"))
- (byte-compile-dest-file-function
- (lambda (source)
- (setq dummy-elc-file (make-temp-file (file-name-nondirectory source)))))
+ (byte-compile-dest-file-function #'ignore)
(collected)
(byte-compile-log-warning-function
(lambda (string &optional position fill level)
@@ -1790,7 +1857,6 @@ Runs in a batch-mode Emacs. Interactively use variable
(unwind-protect
(byte-compile-file file)
(ignore-errors
- (delete-file dummy-elc-file)
(kill-buffer byte-compile-log-buffer)))
(prin1 :elisp-flymake-output-start)
(terpri)
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index 4c65cfbea05..f0180ceeeca 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -34,7 +34,6 @@
;; prefixes but somewhere within the name.
(require 'ring)
-(require 'button)
(require 'xref)
(require 'fileloop)
@@ -259,9 +258,9 @@ One argument, the tag info returned by `snarf-tag-function'.")
Return non-nil if it is a valid tags table, and
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)
- (set (make-local-variable 'tags-included-tables) nil)
+ (setq-local tags-table-files nil)
+ (setq-local tags-completion-table nil)
+ (setq-local tags-included-tables nil)
;; We used to initialize find-tag-marker-ring and tags-location-ring
;; here, to new empty rings. But that is wrong, because those
;; are global.
@@ -837,11 +836,7 @@ If no tags table is loaded, do nothing and return nil."
"Read a tag name, with defaulting and completion."
(let* ((completion-ignore-case (find-tag--completion-ignore-case))
(default (find-tag--default))
- (spec (completing-read (if default
- (format "%s (default %s): "
- (substring string 0 (string-match "[ :]+\\'" string))
- default)
- string)
+ (spec (completing-read (format-prompt string default)
(tags-lazy-completion-table)
nil nil nil nil default)))
(if (equal spec "")
@@ -900,7 +895,7 @@ onto a ring and may be popped back to with \\[pop-tag-mark].
Contrast this with the ring of marks gone to by the command.
See documentation of variable `tags-file-name'."
- (interactive (find-tag-interactive "Find tag: "))
+ (interactive (find-tag-interactive "Find tag"))
(setq find-tag-history (cons tagname find-tag-history))
;; Save the current buffer's value of `find-tag-hook' before
@@ -972,7 +967,7 @@ Contrast this with the ring of marks gone to by the command.
See documentation of variable `tags-file-name'."
(declare (obsolete xref-find-definitions "25.1"))
- (interactive (find-tag-interactive "Find tag: "))
+ (interactive (find-tag-interactive "Find tag"))
(let* ((buf (find-tag-noselect tagname next-p regexp-p))
(pos (with-current-buffer buf (point))))
(condition-case nil
@@ -1001,7 +996,7 @@ Contrast this with the ring of marks gone to by the command.
See documentation of variable `tags-file-name'."
(declare (obsolete xref-find-definitions-other-window "25.1"))
- (interactive (find-tag-interactive "Find tag other window: "))
+ (interactive (find-tag-interactive "Find tag other window"))
;; This hair is to deal with the case where the tag is found in the
;; selected window's buffer; without the hair, point is moved in both
@@ -1042,7 +1037,7 @@ Contrast this with the ring of marks gone to by the command.
See documentation of variable `tags-file-name'."
(declare (obsolete xref-find-definitions-other-frame "25.1"))
- (interactive (find-tag-interactive "Find tag other frame: "))
+ (interactive (find-tag-interactive "Find tag other frame"))
(let ((pop-up-frames t))
(with-suppressed-warnings ((obsolete find-tag-other-window))
(find-tag-other-window tagname next-p))))
@@ -1066,7 +1061,7 @@ Contrast this with the ring of marks gone to by the command.
See documentation of variable `tags-file-name'."
(declare (obsolete xref-find-apropos "25.1"))
- (interactive (find-tag-interactive "Find tag regexp: " t))
+ (interactive (find-tag-interactive "Find tag regexp" t))
;; We go through find-tag-other-window to do all the display hair there.
(funcall (if other-window 'find-tag-other-window 'find-tag)
regexp next-p t))
@@ -1235,34 +1230,29 @@ error message."
"If `etags-verify-tags-table', make buffer-local format variables.
If current buffer is a valid etags TAGS file, then give it
buffer-local values of tags table format variables."
- (and (etags-verify-tags-table)
- ;; It is annoying to flash messages on the screen briefly,
- ;; and this message is not useful. -- rms
- ;; (message "%s is an `etags' TAGS file" buffer-file-name)
- (mapc (lambda (elt) (set (make-local-variable (car elt)) (cdr elt)))
- '((file-of-tag-function . etags-file-of-tag)
- (tags-table-files-function . etags-tags-table-files)
- (tags-completion-table-function . etags-tags-completion-table)
- (snarf-tag-function . etags-snarf-tag)
- (goto-tag-location-function . etags-goto-tag-location)
- (find-tag-regexp-search-function . re-search-forward)
- (find-tag-regexp-tag-order . (tag-re-match-p))
- (find-tag-regexp-next-line-after-failure-p . t)
- (find-tag-search-function . search-forward)
- (find-tag-tag-order . (tag-exact-file-name-match-p
- tag-file-name-match-p
- tag-exact-match-p
- tag-implicit-name-match-p
- tag-symbol-match-p
- tag-word-match-p
- tag-partial-file-name-match-p
- tag-any-match-p))
- (find-tag-next-line-after-failure-p . nil)
- (list-tags-function . etags-list-tags)
- (tags-apropos-function . etags-tags-apropos)
- (tags-included-tables-function . etags-tags-included-tables)
- (verify-tags-table-function . etags-verify-tags-table)
- ))))
+ (when (etags-verify-tags-table)
+ (setq-local file-of-tag-function 'etags-file-of-tag)
+ (setq-local tags-table-files-function 'etags-tags-table-files)
+ (setq-local tags-completion-table-function 'etags-tags-completion-table)
+ (setq-local snarf-tag-function 'etags-snarf-tag)
+ (setq-local goto-tag-location-function 'etags-goto-tag-location)
+ (setq-local find-tag-regexp-search-function 're-search-forward)
+ (setq-local find-tag-regexp-tag-order '(tag-re-match-p))
+ (setq-local find-tag-regexp-next-line-after-failure-p t)
+ (setq-local find-tag-search-function 'search-forward)
+ (setq-local find-tag-tag-order '(tag-exact-file-name-match-p
+ tag-file-name-match-p
+ tag-exact-match-p
+ tag-implicit-name-match-p
+ tag-symbol-match-p
+ tag-word-match-p
+ tag-partial-file-name-match-p
+ tag-any-match-p))
+ (setq-local find-tag-next-line-after-failure-p nil)
+ (setq-local list-tags-function 'etags-list-tags)
+ (setq-local tags-apropos-function 'etags-tags-apropos)
+ (setq-local tags-included-tables-function 'etags-tags-included-tables)
+ (setq-local verify-tags-table-function 'etags-verify-tags-table)))
(defun etags-verify-tags-table ()
"Return non-nil if the current buffer is a valid etags TAGS file."
@@ -1424,6 +1414,10 @@ hits the start of file."
(goto-func goto-tag-location-function)
tag tag-info pt)
(forward-line 1)
+ ;; Exuberant ctags add a line starting with the DEL character;
+ ;; skip past it.
+ (when (looking-at "\177")
+ (forward-line 1))
(while (not (or (eobp) (looking-at "\f")))
;; We used to use explicit tags when available, but the current goto-func
;; can only handle implicit tags.
@@ -1590,27 +1584,27 @@ hits the start of file."
"Return non-nil if current buffer is empty.
If empty, make buffer-local values of the tags table format variables
that do nothing."
- (and (zerop (buffer-size))
- (mapc (lambda (sym) (set (make-local-variable sym) 'ignore))
- '(tags-table-files-function
- tags-completion-table-function
- find-tag-regexp-search-function
- find-tag-search-function
- tags-apropos-function
- tags-included-tables-function))
- (set (make-local-variable 'verify-tags-table-function)
- (lambda () (zerop (buffer-size))))))
+ (when (zerop (buffer-size))
+ (setq-local tags-table-files-function #'ignore)
+ (setq-local tags-completion-table-function #'ignore)
+ (setq-local find-tag-regexp-search-function #'ignore)
+ (setq-local find-tag-search-function #'ignore)
+ (setq-local tags-apropos-function #'ignore)
+ (setq-local tags-included-tables-function #'ignore)
+ (setq-local verify-tags-table-function
+ (lambda () (zerop (buffer-size))))))
+
;; Match qualifier functions for tagnames.
;; These functions assume the etags file format defined in etc/ETAGS.EBNF.
;; This might be a neat idea, but it's too hairy at the moment.
;;(defmacro tags-with-syntax (&rest body)
+;; (declare (debug t))
;; `(with-syntax-table
;; (with-current-buffer (find-file-noselect (file-of-tag))
;; (syntax-table))
;; ,@body))
-;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form))
;; exact file name match, i.e. searched tag must match complete file
;; name including directories parts if there are some.
@@ -1814,10 +1808,10 @@ argument is passed to `next-file', which see)."
(defun tags-search (regexp &optional files)
"Search through all files listed in tags table for match for REGEXP.
Stops when a match is found.
-To continue searching for next match, use command \\[tags-loop-continue].
+To continue searching for next match, use the command \\[fileloop-continue].
-If FILES if non-nil should be a list or an iterator returning the files to search.
-The search will be restricted to these files.
+If FILES if non-nil should be a list or an iterator returning the
+files to search. The search will be restricted to these files.
Also see the documentation of the `tags-file-name' variable."
(interactive "sTags search (regexp): ")
@@ -1840,8 +1834,8 @@ Also see the documentation of the `tags-file-name' variable."
"Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
-with the command \\[tags-loop-continue].
-For non-interactive use, superceded by `fileloop-initialize-replace'."
+with the command \\[fileloop-continue].
+For non-interactive use, superseded by `fileloop-initialize-replace'."
(declare (advertised-calling-convention (from to &optional delimited) "27.1"))
(interactive (query-replace-read-args "Tags query replace (regexp)" t t))
(fileloop-initialize-replace
@@ -2080,8 +2074,8 @@ file name, add `tag-partial-file-name-match-p' to the list value.")
(cl-defmethod xref-backend-definitions ((_backend (eql etags)) symbol)
(etags--xref-find-definitions symbol))
-(cl-defmethod xref-backend-apropos ((_backend (eql etags)) symbol)
- (etags--xref-find-definitions symbol t))
+(cl-defmethod xref-backend-apropos ((_backend (eql etags)) pattern)
+ (etags--xref-find-definitions (xref-apropos-regexp pattern) t))
(defun etags--xref-find-definitions (pattern &optional regexp?)
;; This emulates the behavior of `find-tag-in-order' but instead of
@@ -2131,8 +2125,10 @@ file name, add `tag-partial-file-name-match-p' to the list value.")
(let ((buffer (find-file-noselect file)))
(with-current-buffer buffer
(save-excursion
- (etags-goto-tag-location tag-info)
- (point-marker))))))
+ (save-restriction
+ (widen)
+ (etags-goto-tag-location tag-info)
+ (point-marker)))))))
(cl-defmethod xref-location-line ((l xref-etags-location))
(with-slots (tag-info) l
diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el
index 4fe5c2239c5..0d8b09c33c1 100644
--- a/lisp/progmodes/executable.el
+++ b/lisp/progmodes/executable.el
@@ -1,4 +1,4 @@
-;;; executable.el --- base functionality for executable interpreter scripts
+;;; executable.el --- base functionality for executable interpreter scripts -*- lexical-binding: t -*-
;; Copyright (C) 1994-1996, 2000-2021 Free Software Foundation, Inc.
@@ -54,41 +54,31 @@
"Base functionality for executable interpreter scripts."
:group 'processes)
-;; This used to default to `other', but that doesn't seem to have any
-;; significance. fx 2000-02-11.
-(defcustom executable-insert t ; 'other
+(defcustom executable-insert t
"Non-nil means offer to add a magic number to a file.
This takes effect when you switch to certain major modes,
including Shell-script mode (`sh-mode').
When you type \\[executable-set-magic], it always offers to add or
update the magic number."
-;;; :type '(choice (const :tag "off" nil)
-;;; (const :tag "on" t)
-;;; symbol)
- :type 'boolean
- :group 'executable)
-
+ :type 'boolean)
(defcustom executable-query 'function
"If non-nil, ask user before changing an existing magic number.
When this is `function', only ask when called non-interactively."
:type '(choice (const :tag "Don't Ask" nil)
(const :tag "Ask when non-interactive" function)
- (other :tag "Ask" t))
- :group 'executable)
+ (other :tag "Ask" t)))
(defcustom executable-magicless-file-regexp "/[Mm]akefile$\\|/\\.\\(z?profile\\|bash_profile\\|z?login\\|bash_login\\|z?logout\\|bash_logout\\|.+shrc\\|esrc\\|rcrc\\|[kz]shenv\\)$"
"On files with this kind of name no magic is inserted or changed."
- :type 'regexp
- :group 'executable)
+ :type 'regexp)
(defcustom executable-prefix "#!"
"Interpreter magic number prefix inserted when there was no magic number.
Use of `executable-prefix-env' is preferable to this option."
:version "26.1" ; deprecated
- :type 'string
- :group 'executable)
+ :type 'string)
(defcustom executable-prefix-env nil
"If non-nil, use \"/usr/bin/env\" in interpreter magic number.
@@ -96,8 +86,7 @@ If this variable is non-nil, the interpreter magic number inserted
by `executable-set-magic' will be \"#!/usr/bin/env INTERPRETER\",
otherwise it will be \"#!/path/to/INTERPRETER\"."
:version "26.1"
- :type 'boolean
- :group 'executable)
+ :type 'boolean)
(defcustom executable-chmod 73
"After saving, if the file is not executable, set this mode.
@@ -105,8 +94,7 @@ This mode passed to `set-file-modes' is taken absolutely when negative, or
relative to the files existing modes. Do nothing if this is nil.
Typical values are 73 (+x) or -493 (rwxr-xr-x)."
:type '(choice integer
- (const nil))
- :group 'executable)
+ (const nil)))
(defvar executable-command nil)
@@ -114,8 +102,7 @@ Typical values are 73 (+x) or -493 (rwxr-xr-x)."
(defcustom executable-self-display "tail"
"Command you use with argument `-n+2' to make text files self-display.
Note that the like of `more' doesn't work too well under Emacs \\[shell]."
- :type 'string
- :group 'executable)
+ :type 'string)
(make-obsolete-variable 'executable-self-display nil "25.1" 'set)
@@ -197,7 +184,7 @@ command to find the next error. The buffer is also in `comint-mode' and
buffer-file-name))))
(require 'compile)
(save-some-buffers (not compilation-ask-about-save))
- (set (make-local-variable 'executable-command) command)
+ (setq-local executable-command command)
(let ((compilation-error-regexp-alist executable-error-regexp-alist))
(compilation-start command t (lambda (_x) "*interpretation*"))))
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index 9770035fa42..5c0b7880e8b 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -117,11 +117,10 @@
;; correctly, but I imagine them to be rare.
;; 3) Regexps for hilit19 are no longer supported.
;; 4) For FIXED FORMAT code, use fortran mode.
-;; 5) This mode does not work under emacs-18.x.
-;; 6) Preprocessor directives, i.e., lines starting with # are left-justified
+;; 5) Preprocessor directives, i.e., lines starting with # are left-justified
;; and are untouched by all case-changing commands. There is, at present, no
;; mechanism for treating multi-line directives (continued by \ ).
-;; 7) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented.
+;; 6) f77 do-loops do 10 i=.. ; ; 10 continue are not correctly indented.
;; You are urged to use f90-do loops (with labels if you wish).
;; List of user commands
@@ -718,10 +717,7 @@ Can be overridden by the value of `font-lock-maximum-decoration'.")
(modify-syntax-entry ?* "." table)
(modify-syntax-entry ?/ "." table)
(modify-syntax-entry ?% "." table) ; bug#8820
- ;; I think that the f95 standard leaves the behavior of \
- ;; unspecified, but that f2k will require it to be non-special.
- ;; Use `f90-backslash-not-special' to change.
- (modify-syntax-entry ?\\ "\\" table) ; escape chars
+ (modify-syntax-entry ?\\ "." table)
table)
"Syntax table used in F90 mode.")
@@ -926,9 +922,8 @@ then the presence of the token here allows a line-break before or
after the other character, where a break would not normally be
allowed. This minor issue currently only affects \"(/\" and \"/)\".")
-(defvar f90-cache-position nil
+(defvar-local f90-cache-position nil
"Temporary position used to speed up region operations.")
-(make-variable-buffer-local 'f90-cache-position)
;; Hideshow support.
@@ -1179,29 +1174,26 @@ Turning on F90 mode calls the value of the variable `f90-mode-hook'
with no args, if that value is non-nil."
: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 'comment-start) "!")
- (set (make-local-variable 'comment-start-skip) "!+ *")
- (set (make-local-variable 'comment-indent-function) 'f90-comment-indent)
- (set (make-local-variable 'abbrev-all-caps) t)
- (set (make-local-variable 'normal-auto-fill-function) 'f90-do-auto-fill)
+ (setq-local indent-line-function #'f90-indent-line)
+ (setq-local indent-region-function #'f90-indent-region)
+ (setq-local comment-start "!")
+ (setq-local comment-start-skip "!+ *")
+ (setq-local comment-indent-function 'f90-comment-indent)
+ (setq-local abbrev-all-caps t)
+ (setq-local normal-auto-fill-function #'f90-do-auto-fill)
(setq indent-tabs-mode nil) ; auto buffer local
- (set (make-local-variable 'fill-paragraph-function) 'f90-fill-paragraph)
- (set (make-local-variable 'font-lock-defaults)
- '((f90-font-lock-keywords f90-font-lock-keywords-1
- f90-font-lock-keywords-2
- f90-font-lock-keywords-3
- f90-font-lock-keywords-4)
- nil t))
- (set (make-local-variable 'imenu-case-fold-search) t)
- (set (make-local-variable 'imenu-generic-expression)
- f90-imenu-generic-expression)
- (set (make-local-variable 'beginning-of-defun-function)
- '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))
+ (setq-local fill-paragraph-function #'f90-fill-paragraph)
+ (setq-local font-lock-defaults
+ '((f90-font-lock-keywords f90-font-lock-keywords-1
+ f90-font-lock-keywords-2
+ f90-font-lock-keywords-3
+ f90-font-lock-keywords-4)
+ nil t))
+ (setq-local imenu-case-fold-search t)
+ (setq-local imenu-generic-expression f90-imenu-generic-expression)
+ (setq-local beginning-of-defun-function #'f90-beginning-of-subprogram)
+ (setq-local end-of-defun-function #'f90-end-of-subprogram)
+ (setq-local add-log-current-defun-function #'f90-current-defun))
;; Inline-functions.
@@ -1649,25 +1641,28 @@ Return (TYPE NAME), or nil if not found."
(interactive)
(let ((count 1) (case-fold-search t) matching-beg)
(beginning-of-line)
- (while (and (> count 0)
- (re-search-backward f90-program-block-re nil 'move))
- (beginning-of-line)
- (skip-chars-forward " \t0-9")
- ;; Check if in string in case using non-standard feature where
- ;; continued strings do not need "&" at start of continuations.
- (cond ((f90-in-string))
- ((setq matching-beg (f90-looking-at-program-block-start))
- (setq count (1- count)))
- ((f90-looking-at-program-block-end)
- (setq count (1+ count)))))
- (beginning-of-line)
- (if (zerop count)
- matching-beg
- ;; Note this includes the case of an un-named main program,
- ;; in which case we go to (point-min).
- (if (called-interactively-p 'interactive)
- (message "No beginning found"))
- nil)))
+ ;; Check whether we're already at the start of a subprogram.
+ (or (f90-looking-at-program-block-start)
+ ;; We're not; search backwards.
+ (while (and (> count 0)
+ (re-search-backward f90-program-block-re nil 'move))
+ (beginning-of-line)
+ (skip-chars-forward " \t0-9")
+ ;; Check if in string in case using non-standard feature where
+ ;; continued strings do not need "&" at start of continuations.
+ (cond ((f90-in-string))
+ ((setq matching-beg (f90-looking-at-program-block-start))
+ (setq count (1- count)))
+ ((f90-looking-at-program-block-end)
+ (setq count (1+ count)))))
+ (beginning-of-line)
+ (if (zerop count)
+ matching-beg
+ ;; Note this includes the case of an un-named main program,
+ ;; in which case we go to (point-min).
+ (if (called-interactively-p 'interactive)
+ (message "No beginning found"))
+ nil))))
(defun f90-end-of-subprogram ()
"Move point to the end of the current subprogram.
@@ -2396,9 +2391,11 @@ CHANGE-WORD should be one of `upcase-word', `downcase-word', `capitalize-word'."
(defun f90-backslash-not-special (&optional all)
"Make the backslash character (\\) be non-special in the current buffer.
+This is the default in `f90-mode'.
+
With optional argument ALL, change the default for all present
-and future F90 buffers. F90 mode normally treats backslash as an
-escape character."
+and future F90 buffers."
+ (declare (obsolete nil "28.1"))
(or (derived-mode-p 'f90-mode)
(user-error "This function should only be used in F90 buffers"))
(when (equal (char-syntax ?\\ ) ?\\ )
diff --git a/lisp/progmodes/flymake-cc.el b/lisp/progmodes/flymake-cc.el
index 843d3f87218..bd403faf7c4 100644
--- a/lisp/progmodes/flymake-cc.el
+++ b/lisp/progmodes/flymake-cc.el
@@ -5,18 +5,20 @@
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: languages, c
-;; This program is free software; you can redistribute it and/or modify
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
@@ -48,7 +50,7 @@ SOURCE."
;; TODO: if you can understand it, use `compilation-mode's regexps
;; or even some of its machinery here.
;;
- ;; (set (make-local-variable 'compilation-locs)
+ ;; (setq-local compilation-locs
;; (make-hash-table :test 'equal :weakness 'value))
;; (compilation-parse-errors (point-min) (point-max)
;; 'gnu 'gcc-include)
diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el
index dffb19df806..9cbad121d1f 100644
--- a/lisp/progmodes/flymake-proc.el
+++ b/lisp/progmodes/flymake-proc.el
@@ -37,7 +37,7 @@
;;; Bugs/todo:
;; - Only uses "Makefile", not "makefile" or "GNUmakefile"
-;; (from http://bugs.debian.org/337339).
+;; (from https://bugs.debian.org/337339).
;;; Code:
@@ -120,8 +120,10 @@ This is an alist with elements of the form:
REGEXP INIT [CLEANUP [NAME]]
REGEXP is a regular expression that matches a file name.
INIT is the init function to use.
-CLEANUP is the cleanup function to use, default `flymake-proc-simple-cleanup'.
-NAME is the file name function to use, default `flymake-proc-get-real-file-name'."
+CLEANUP is the cleanup function to use, default
+ `flymake-proc-simple-cleanup'.
+NAME is the file name function to use, default
+ `flymake-proc-get-real-file-name'."
:group 'flymake
:type '(alist :key-type (regexp :tag "File regexp")
:value-type
@@ -429,16 +431,15 @@ instead of reading master file from disk."
(defun flymake-proc--read-file-to-temp-buffer (file-name)
"Insert contents of FILE-NAME into newly created temp buffer."
- (let* ((temp-buffer (get-buffer-create (generate-new-buffer-name (concat "flymake:" (file-name-nondirectory file-name))))))
- (with-current-buffer temp-buffer
- (insert-file-contents file-name))
- temp-buffer))
+ (with-current-buffer (generate-new-buffer
+ (concat "flymake:" (file-name-nondirectory file-name)))
+ (insert-file-contents file-name)
+ (current-buffer)))
(defun flymake-proc--copy-buffer-to-temp-buffer (buffer)
"Copy contents of BUFFER into newly created temp buffer."
- (with-current-buffer
- (get-buffer-create (generate-new-buffer-name
- (concat "flymake:" (buffer-name buffer))))
+ (with-current-buffer (generate-new-buffer
+ (concat "flymake:" (buffer-name buffer)))
(insert-buffer-substring buffer)
(current-buffer)))
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 56567e5a1a3..77a807f21ae 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -4,9 +4,12 @@
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
-;; Version: 1.0.8
-;; Package-Requires: ((emacs "26.1"))
+;; Version: 1.1.1
;; Keywords: c languages tools
+;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0"))
+
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
;; This file is part of GNU Emacs.
@@ -223,10 +226,10 @@ Specifically, start it when the saved buffer is actually displayed."
(defcustom flymake-suppress-zero-counters :warning
"Control appearance of zero-valued diagnostic counters in mode line.
-If set to t, supress all zero counters. If set to a severity
+If set to t, suppress all zero counters. If set to a severity
symbol like `:warning' (the default) suppress zero counters less
severe than that severity, according to `warning-numeric-level'.
-If set to nil, don't supress any zero counters."
+If set to nil, don't suppress any zero counters."
:type 'symbol)
(when (fboundp 'define-fringe-bitmap)
@@ -281,17 +284,17 @@ If set to nil, don't supress any zero counters."
(defmacro flymake-log (level msg &rest args)
"Log, at level LEVEL, the message MSG formatted with ARGS.
LEVEL is passed to `display-warning', which is used to display
-the warning. If this form is included in a byte-compiled file,
+the warning. If this form is included in a file,
the generated warning contains an indication of the file that
generated it."
- (let* ((compile-file (and (boundp 'byte-compile-current-file)
- (symbol-value 'byte-compile-current-file)))
- (sublog (if (and
- compile-file
- (not load-file-name))
+ (let* ((file (if (fboundp 'macroexp-file-name)
+ (macroexp-file-name)
+ (and (not load-file-name)
+ (bound-and-true-p byte-compile-current-file))))
+ (sublog (if file
(intern
(file-name-nondirectory
- (file-name-sans-extension compile-file))))))
+ (file-name-sans-extension file))))))
`(flymake--log-1 ,level ',sublog ,msg ,@args)))
(defun flymake-error (text &rest args)
@@ -349,12 +352,20 @@ diagnostics at BEG."
(flymake--diag-accessor flymake-diagnostic-data flymake--diag-data backend)
(defun flymake-diagnostic-beg (diag)
- "Get Flymake diagnostic DIAG's start position."
- (overlay-start (flymake--diag-overlay diag)))
+ "Get Flymake diagnostic DIAG's start position.
+This position only be queried after DIAG has been reported to Flymake."
+ (let ((overlay (flymake--diag-overlay diag)))
+ (unless overlay
+ (error "DIAG %s not reported to Flymake yet" diag))
+ (overlay-start overlay)))
(defun flymake-diagnostic-end (diag)
- "Get Flymake diagnostic DIAG's end position."
- (overlay-end (flymake--diag-overlay diag)))
+ "Get Flymake diagnostic DIAG's end position.
+This position only be queried after DIAG has been reported to Flymake."
+ (let ((overlay (flymake--diag-overlay diag)))
+ (unless overlay
+ (error "DIAG %s not reported to Flymake yet" diag))
+ (overlay-end overlay)))
(cl-defun flymake--overlays (&key beg end filter compare key)
"Get flymake-related overlays.
@@ -409,44 +420,46 @@ verify FILTER, a function, and sort them by COMPARE (using KEY)."
(defun flymake-diag-region (buffer line &optional col)
"Compute BUFFER's region (BEG . END) corresponding to LINE and COL.
If COL is nil, return a region just for LINE. Return nil if the
-region is invalid."
+region is invalid. This function saves match data."
(condition-case-unless-debug _err
(with-current-buffer buffer
(let ((line (min (max line 1)
(line-number-at-pos (point-max) 'absolute))))
(save-excursion
- (goto-char (point-min))
- (forward-line (1- line))
- (cl-flet ((fallback-bol
- ()
- (back-to-indentation)
- (if (eobp)
- (line-beginning-position 0)
- (point)))
- (fallback-eol
- (beg)
- (progn
- (end-of-line)
- (skip-chars-backward " \t\f\n" beg)
- (if (eq (point) beg)
- (line-beginning-position 2)
- (point)))))
- (if (and col (cl-plusp col))
- (let* ((beg (progn (forward-char (1- col))
- (point)))
- (sexp-end (ignore-errors (end-of-thing 'sexp)))
- (end (or (and sexp-end
- (not (= sexp-end beg))
- sexp-end)
- (and (< (goto-char (1+ beg)) (point-max))
- (point)))))
- (if end
- (cons beg end)
- (cons (setq beg (fallback-bol))
- (fallback-eol beg))))
- (let* ((beg (fallback-bol))
- (end (fallback-eol beg)))
- (cons beg end)))))))
+ (save-match-data
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (cl-flet ((fallback-bol
+ ()
+ (back-to-indentation)
+ (if (eobp)
+ (line-beginning-position 0)
+ (point)))
+ (fallback-eol
+ (beg)
+ (progn
+ (end-of-line)
+ (skip-chars-backward " \t\f\n" beg)
+ (if (eq (point) beg)
+ (line-beginning-position 2)
+ (point)))))
+ (if (and col (cl-plusp col))
+ (let* ((beg (progn (forward-char (1- col))
+ (point)))
+ (sexp-end (or (ignore-errors (end-of-thing 'sexp))
+ (ignore-errors (end-of-thing 'symbol))))
+ (end (or (and sexp-end
+ (not (= sexp-end beg))
+ sexp-end)
+ (and (< (goto-char (1+ beg)) (point-max))
+ (point)))))
+ (if end
+ (cons beg end)
+ (cons (setq beg (fallback-bol))
+ (fallback-eol beg))))
+ (let* ((beg (fallback-bol))
+ (end (fallback-eol beg)))
+ (cons beg end))))))))
(error (flymake-log :warning "Invalid region line=%s col=%s" line col)
nil)))
@@ -470,7 +483,7 @@ Currently, Flymake may provide these keyword-value pairs:
* `:recent-changes', a list of recent changes since the last time
the backend function was called for the buffer. An empty list
- indicates that no changes have been reocrded. If it is the
+ indicates that no changes have been recorded. If it is the
first time that this backend function is called for this
activation of `flymake-mode', then this argument isn't provided
at all (i.e. it's not merely nil).
@@ -629,7 +642,7 @@ associated `flymake-category' return DEFAULT."
for (ov-prop . value) in
(append (reverse
(flymake--diag-overlay-properties diagnostic))
- (reverse ; ensure ealier props override later ones
+ (reverse ; ensure earlier props override later ones
(flymake--lookup-type-property type 'flymake-overlay-control))
(alist-get type flymake-diagnostic-types-alist))
do (overlay-put ov ov-prop value))
@@ -728,7 +741,10 @@ to handle a report even if TOKEN was not expected. REGION is
a (BEG . END) pair of buffer positions indicating that this
report applies to that region."
(let* ((state (gethash backend flymake--backend-state))
- (first-report (not (flymake--backend-state-reported-p state))))
+ first-report)
+ (unless state
+ (error "Can't find state for %s in `flymake--backend-state'" backend))
+ (setf first-report (not (flymake--backend-state-reported-p state)))
(setf (flymake--backend-state-reported-p state) t)
(let (expected-token
new-diags)
@@ -992,15 +1008,16 @@ suitable for the current buffer. The commands
`flymake-running-backends', `flymake-disabled-backends' and
`flymake-reporting-backends' summarize the situation, as does the
special *Flymake log* buffer." :group 'flymake :lighter
- flymake--mode-line-format :keymap flymake-mode-map
+ flymake-mode-line-format :keymap flymake-mode-map
(cond
;; Turning the mode ON.
(flymake-mode
(add-hook 'after-change-functions 'flymake-after-change-function nil t)
(add-hook 'after-save-hook 'flymake-after-save-hook nil t)
(add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)
+ (add-hook 'eldoc-documentation-functions 'flymake-eldoc-function t t)
- ;; If Flymake happened to be alrady already ON, we must cleanup
+ ;; If Flymake happened to be already already ON, we must cleanup
;; existing diagnostic overlays, lest we forget them by blindly
;; reinitializing `flymake--backend-state' in the next line.
;; See https://github.com/joaotavora/eglot/issues/223.
@@ -1016,6 +1033,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(remove-hook 'after-save-hook 'flymake-after-save-hook t)
(remove-hook 'kill-buffer-hook 'flymake-kill-buffer-hook t)
;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t)
+ (remove-hook 'eldoc-documentation-functions 'flymake-eldoc-function t)
(mapc #'delete-overlay (flymake--overlays))
@@ -1083,6 +1101,14 @@ START and STOP and LEN are as in `after-change-functions'."
(flymake-mode)
(flymake-log :warning "Turned on in `flymake-find-file-hook'")))
+(defun flymake-eldoc-function (report-doc &rest _)
+ "Document diagnostics at point.
+Intended for `eldoc-documentation-functions' (which see)."
+ (let ((diags (flymake-diagnostics (point))))
+ (when diags
+ (funcall report-doc
+ (mapconcat #'flymake-diagnostic-text diags "\n")))))
+
(defun flymake-goto-next-error (&optional n filter interactive)
"Go to Nth next Flymake diagnostic that matches FILTER.
Interactively, always move to the next diagnostic. With a prefix
@@ -1171,123 +1197,142 @@ default) no filter is applied."
[ "Go to log buffer" flymake-switch-to-log-buffer t ]
[ "Turn off Flymake" flymake-mode t ]))
-(defvar flymake--mode-line-format '(:eval (flymake--mode-line-format)))
-
-(put 'flymake--mode-line-format 'risky-local-variable t)
-
-
-(defun flymake--mode-line-format ()
- "Produce a pretty minor mode indicator."
- (let* ((known (hash-table-keys flymake--backend-state))
- (running (flymake-running-backends))
- (disabled (flymake-disabled-backends))
- (reported (flymake-reporting-backends))
- (diags-by-type (make-hash-table))
- (all-disabled (and disabled (null running)))
- (some-waiting (cl-set-difference running reported)))
- (maphash (lambda (_b state)
- (mapc (lambda (diag)
- (push diag
- (gethash (flymake--diag-type diag)
- diags-by-type)))
- (flymake--backend-state-diags state)))
- flymake--backend-state)
- `((:propertize " Flymake"
- mouse-face mode-line-highlight
- help-echo
- ,(concat (format "%s known backends\n" (length known))
- (format "%s running\n" (length running))
- (format "%s disabled\n" (length disabled))
- "mouse-1: Display minor mode menu\n"
- "mouse-2: Show help for minor mode")
- keymap
- ,(let ((map (make-sparse-keymap)))
- (define-key map [mode-line down-mouse-1]
- flymake-menu)
- (define-key map [mode-line mouse-2]
- (lambda ()
- (interactive)
- (describe-function 'flymake-mode)))
- map))
- ,@(pcase-let ((`(,ind ,face ,explain)
- (cond ((null known)
- '("?" mode-line "No known backends"))
- (some-waiting
- `("Wait" compilation-mode-line-run
- ,(format "Waiting for %s running backend(s)"
- (length some-waiting))))
- (all-disabled
- '("!" compilation-mode-line-run
- "All backends disabled"))
- (t
- '(nil nil nil)))))
- (when ind
- `((":"
- (:propertize ,ind
- face ,face
- help-echo ,explain
- keymap
- ,(let ((map (make-sparse-keymap)))
+(defcustom flymake-mode-line-format
+ '(" " flymake-mode-line-title flymake-mode-line-exception
+ flymake-mode-line-counters)
+ "Mode line construct for customizing Flymake information."
+ :type '(repeat (choice string symbol)))
+
+(defcustom flymake-mode-line-counter-format
+ '("["
+ flymake-mode-line-error-counter
+ flymake-mode-line-warning-counter
+ flymake-mode-line-note-counter "]")
+ "Mode-line construct for formatting Flymake diagnostic counters.
+This is a suitable place for placing the `flymake-error-counter',
+`flymake-warning-counter' and `flymake-note-counter' constructs.
+Separating each of these with space is not necessary."
+ :type '(repeat (choice string symbol)))
+
+(defvar flymake-mode-line-title '(:eval (flymake--mode-line-title))
+ "Mode-line construct to show Flymake's mode name and menu.")
+
+(defvar flymake-mode-line-exception '(:eval (flymake--mode-line-exception))
+ "Mode-line construct to report on exceptional Flymake status.")
+
+(defvar flymake-mode-line-counters '(:eval (flymake--mode-line-counters))
+ "Mode-line construct for counting Flymake diagnostics.
+The counters are only placed if some Flymake backend initialized
+correctly.")
+
+(defvar flymake-mode-line-error-counter
+ `(:eval (flymake--mode-line-counter :error t)))
+(defvar flymake-mode-line-warning-counter
+ `(:eval (flymake--mode-line-counter :warning)))
+(defvar flymake-mode-line-note-counter
+ `(:eval (flymake--mode-line-counter :note)))
+
+(put 'flymake-mode-line-format 'risky-local-variable t)
+(put 'flymake-mode-line-title 'risky-local-variable t)
+(put 'flymake-mode-line-exception 'risky-local-variable t)
+(put 'flymake-mode-line-counters 'risky-local-variable t)
+(put 'flymake-mode-line-error-counter 'risky-local-variable t)
+(put 'flymake-mode-line-warning-counter 'risky-local-variable t)
+(put 'flymake-mode-line-note-counter 'risky-local-variable t)
+
+(defun flymake--mode-line-title ()
+ `(:propertize
+ "Flymake"
+ mouse-face mode-line-highlight
+ help-echo
+ ,(lambda (&rest _)
+ (concat
+ (format "%s known backends\n" (hash-table-count flymake--backend-state))
+ (format "%s running\n" (length (flymake-running-backends)))
+ (format "%s disabled\n" (length (flymake-disabled-backends)))
+ "mouse-1: Display minor mode menu\n"
+ "mouse-2: Show help for minor mode"))
+ keymap
+ ,(let ((map (make-sparse-keymap)))
+ (define-key map [mode-line down-mouse-1]
+ flymake-menu)
+ (define-key map [mode-line mouse-2]
+ (lambda ()
+ (interactive)
+ (describe-function 'flymake-mode)))
+ map)))
+
+(defun flymake--mode-line-exception ()
+ "Helper for `flymake-mode-line-exception'."
+ (pcase-let* ((running) (reported)
+ (`(,ind ,face ,explain)
+ (cond ((zerop (hash-table-count flymake--backend-state))
+ '("?" nil "No known backends"))
+ ((cl-set-difference
+ (setq running (flymake-running-backends))
+ (setq reported (flymake-reporting-backends)))
+ `("Wait" compilation-mode-line-run
+ ,(format "Waiting for %s running backend(s)"
+ (length (cl-set-difference running reported)))))
+ ((and (flymake-disabled-backends) (null running))
+ '("!" compilation-mode-line-run
+ "All backends disabled"))
+ (t
+ '(nil nil nil)))))
+ (when ind
+ `(":"
+ (:propertize ,ind face ,face
+ help-echo ,explain
+ keymap ,(let ((map (make-sparse-keymap)))
(define-key map [mode-line mouse-1]
'flymake-switch-to-log-buffer)
map))))))
- ,@(unless (or all-disabled
- (null known))
- (cl-loop
- with types = (hash-table-keys diags-by-type)
- with _augmented = (cl-loop for extra in '(:error :warning)
- do (cl-pushnew extra types
- :key #'flymake--severity))
- for type in (cl-sort types #'> :key #'flymake--severity)
- for diags = (gethash type diags-by-type)
- for face = (flymake--lookup-type-property type
- 'mode-line-face
- 'compilation-error)
- when (or diags
- (cond ((eq flymake-suppress-zero-counters t)
- nil)
- (flymake-suppress-zero-counters
- (>= (flymake--severity type)
- (warning-numeric-level
- flymake-suppress-zero-counters)))
- (t t)))
- collect `(:propertize
- ,(format "%d" (length diags))
- face ,face
- mouse-face mode-line-highlight
- keymap
- ,(let ((map (make-sparse-keymap))
- (type type))
- (define-key map (vector 'mode-line
- mouse-wheel-down-event)
- (lambda (event)
- (interactive "e")
- (with-selected-window (posn-window (event-start event))
- (flymake-goto-prev-error 1 (list type) t))))
- (define-key map (vector 'mode-line
- mouse-wheel-up-event)
- (lambda (event)
- (interactive "e")
- (with-selected-window (posn-window (event-start event))
- (flymake-goto-next-error 1 (list type) t))))
- map)
- help-echo
- ,(concat (format "%s diagnostics of type %s\n"
- (propertize (format "%d"
- (length diags))
- 'face face)
- (propertize (format "%s" type)
- 'face face))
- (format "%s/%s: previous/next of this type"
- mouse-wheel-down-event
- mouse-wheel-up-event)))
- into forms
- finally return
- `((:propertize "[")
- ,@(cl-loop for (a . rest) on forms by #'cdr
- collect a when rest collect
- '(:propertize " "))
- (:propertize "]")))))))
+
+(defun flymake--mode-line-counters ()
+ (when (flymake-running-backends) flymake-mode-line-counter-format))
+
+(defun flymake--mode-line-counter (type &optional no-space)
+ "Compute number of diagnostics in buffer with TYPE's severity.
+TYPE is usually keyword `:error', `:warning' or `:note'."
+ (let ((count 0)
+ (face (flymake--lookup-type-property type
+ 'mode-line-face
+ 'compilation-error)))
+ (maphash (lambda
+ (_b state)
+ (dolist (d (flymake--backend-state-diags state))
+ (when (= (flymake--severity type)
+ (flymake--severity (flymake--diag-type d)))
+ (cl-incf count))))
+ flymake--backend-state)
+ (when (or (cl-plusp count)
+ (cond ((eq flymake-suppress-zero-counters t)
+ nil)
+ (flymake-suppress-zero-counters
+ (>= (flymake--severity type)
+ (warning-numeric-level
+ flymake-suppress-zero-counters)))
+ (t t)))
+ `(,(if no-space "" '(:propertize " "))
+ (:propertize
+ ,(format "%d" count)
+ face ,face
+ mouse-face mode-line-highlight
+ keymap
+ ,(let ((map (make-sparse-keymap)))
+ (define-key map (vector 'mode-line
+ mouse-wheel-down-event)
+ (lambda (event)
+ (interactive "e")
+ (with-selected-window (posn-window (event-start event))
+ (flymake-goto-prev-error 1 (list type) t))))
+ (define-key map (vector 'mode-line
+ mouse-wheel-up-event)
+ (lambda (event)
+ (interactive "e")
+ (with-selected-window (posn-window (event-start event))
+ (flymake-goto-next-error 1 (list type) t))))
+ map))))))
;;; Diagnostics buffer
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index db4d239f694..707226fb2a5 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -1,4 +1,4 @@
-;;; fortran.el --- Fortran mode for GNU Emacs
+;;; fortran.el --- Fortran mode for GNU Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1986, 1993-1995, 1997-2021 Free Software Foundation,
;; Inc.
@@ -429,7 +429,7 @@ The only difference is, it returns t in a case when the default returns nil."
fortran-font-lock-keywords-1
;; All type specifiers plus their declared items.
(list
- (list (concat fortran-type-types "[ \t(/]*\\(*\\)?")
+ (list (concat fortran-type-types "[ \t(/]*\\(\\*\\)?")
;; Type specifier.
'(1 font-lock-type-face)
;; Declaration item (or just /.../ block name).
@@ -495,14 +495,15 @@ This is used to fontify fixed-format Fortran comments."
;; `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
+ `(syntax-propertize-rules
("^[CcDd\\*]" (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 "^[^CcDd\\*\t\n].\\{%d\\}\\(.+\\)" (1- line-length))
- (1 "<")))))
+ (,(format "^[^CcDd\\*\t\n].\\{%d\\}\\(.+\\)" (1- line-length))
+ (1 "<")))
+ t))
(defvar fortran-font-lock-keywords fortran-font-lock-keywords-1
"Default expressions to highlight in Fortran mode.")
@@ -649,74 +650,6 @@ Used in the Fortran entry in `hs-special-modes-alist'.")
(define-key map "7" 'fortran-electric-line-number)
(define-key map "8" 'fortran-electric-line-number)
(define-key map "9" 'fortran-electric-line-number)
-
- (easy-menu-define fortran-menu map "Menu for Fortran mode."
- `("Fortran"
- ["Manual" (info "(emacs)Fortran") :active t
- :help "Read the Emacs manual chapter on Fortran mode"]
- ("Customization"
- ,(custom-menu-create 'fortran)
- ;; FIXME useless?
- ["Set" Custom-set :active t
- :help "Set current value of all edited settings in the buffer"]
- ["Save" Custom-save :active t
- :help "Set and save all edited settings"]
- ["Reset to Current" Custom-reset-current :active t
- :help "Reset all edited settings to current"]
- ["Reset to Saved" Custom-reset-saved :active t
- :help "Reset all edited or set settings to saved"]
- ["Reset to Standard Settings" Custom-reset-standard :active t
- :help "Erase all customizations in buffer"]
- )
- "--"
- ["Comment Region" fortran-comment-region mark-active]
- ["Uncomment Region"
- (fortran-comment-region (region-beginning) (region-end) 1)
- mark-active]
- ["Indent Region" indent-region mark-active]
- ["Indent Subprogram" fortran-indent-subprogram t]
- "--"
- ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t
- :help "Move point to the start of the current subprogram"]
- ["End of Subprogram" fortran-end-of-subprogram :active t
- :help "Move point to the end of the current subprogram"]
- ("Mark"
- :help "Mark a region of code"
- ["Subprogram" mark-defun t]
- ["IF Block" fortran-mark-if t]
- ["DO Block" fortran-mark-do t]
- )
- ["Narrow to Subprogram" narrow-to-defun t]
- ["Widen" widen t]
- "--"
- ["Temporary Column Ruler" fortran-column-ruler :active t
- :help "Briefly display Fortran column numbers"]
- ;; May not be '72', depending on fortran-line-length, but this
- ;; seems ok for a menu item.
- ["72-column Window" fortran-window-create :active t
- :help "Set window width to Fortran line length"]
- ["Full Width Window"
- (enlarge-window-horizontally (- (frame-width) (window-width)))
- :active (not (window-full-width-p))
- :help "Make window full width"]
- ["Momentary 72-Column Window" fortran-window-create-momentarily
- :active t :help "Briefly set window width to Fortran line length"]
- "--"
- ["Break Line at Point" fortran-split-line :active t
- :help "Break the current line at point"]
- ["Join Line" fortran-join-line :active t
- :help "Join the current line to the previous one"]
- ["Fill Statement/Comment" fill-paragraph t]
- "--"
- ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function
- :style toggle
- :help "Automatically fill text while typing in this buffer"]
- ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode
- :style toggle :help "Expand abbreviations while typing in this buffer"]
- ["Add Imenu Menu" imenu-add-menubar-index
- :active (not (lookup-key (current-local-map) [menu-bar index]))
- :included (fboundp 'imenu-add-to-menubar)
- :help "Add an index menu to the menu-bar"]))
map)
"Keymap used in Fortran mode.")
@@ -860,36 +793,34 @@ with no args, if that value is non-nil."
: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)
+ (setq-local indent-line-function 'fortran-indent-line)
+ (setq-local indent-region-function
(lambda (start end)
(let (fortran-blink-matching-if ; avoid blinking delay
indent-region-function)
(indent-region start end nil))))
- (set (make-local-variable 'require-final-newline) mode-require-final-newline)
+ (setq-local require-final-newline mode-require-final-newline)
;; The syntax tables don't understand the column-0 comment-markers.
- (set (make-local-variable 'comment-use-syntax) nil)
- (set (make-local-variable 'comment-padding) "$$$")
- (set (make-local-variable 'comment-start) fortran-comment-line-start)
- (set (make-local-variable 'comment-start-skip)
+ (setq-local comment-use-syntax nil)
+ (setq-local comment-padding "$$$")
+ (setq-local comment-start fortran-comment-line-start)
+ (setq-local comment-start-skip
;; We can't reuse `fortran-comment-line-start-skip' directly because
;; it contains backrefs whereas we need submatch-1 to end at the
;; beginning of the comment delimiter.
;; (concat "\\(\\)\\(![ \t]*\\|" fortran-comment-line-start-skip "\\)")
"\\(\\)\\(?:^[CcDd*]\\|!\\)\\(?:\\([^ \t\n]\\)\\2+\\)?[ \t]*")
- (set (make-local-variable 'comment-indent-function) 'fortran-comment-indent)
- (set (make-local-variable 'comment-region-function) 'fortran-comment-region)
- (set (make-local-variable 'uncomment-region-function)
- 'fortran-uncomment-region)
- (set (make-local-variable 'comment-insert-comment-function)
- 'fortran-indent-comment)
- (set (make-local-variable 'abbrev-all-caps) t)
- (set (make-local-variable 'normal-auto-fill-function) 'fortran-auto-fill)
- (set (make-local-variable 'indent-tabs-mode) (fortran-analyze-file-format))
+ (setq-local comment-indent-function 'fortran-comment-indent)
+ (setq-local comment-region-function 'fortran-comment-region)
+ (setq-local uncomment-region-function 'fortran-uncomment-region)
+ (setq-local comment-insert-comment-function 'fortran-indent-comment)
+ (setq-local abbrev-all-caps t)
+ (setq-local normal-auto-fill-function 'fortran-auto-fill)
+ (setq-local indent-tabs-mode (fortran-analyze-file-format))
(setq mode-line-process '(indent-tabs-mode fortran-tab-mode-string))
- (set (make-local-variable 'fill-column) fortran-line-length)
- (set (make-local-variable 'fill-paragraph-function) 'fortran-fill-paragraph)
- (set (make-local-variable 'font-lock-defaults)
+ (setq-local fill-column fortran-line-length)
+ (setq-local fill-paragraph-function 'fortran-fill-paragraph)
+ (setq-local font-lock-defaults
'((fortran-font-lock-keywords
fortran-font-lock-keywords-1
fortran-font-lock-keywords-2
@@ -897,20 +828,19 @@ with no args, if that value is non-nil."
fortran-font-lock-keywords-4)
nil t ((?/ . "$/") ("_$" . "w"))
fortran-beginning-of-subprogram))
- (set (make-local-variable 'syntax-propertize-function)
+ (setq-local 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)
- (set (make-local-variable 'imenu-syntax-alist) '(("_$" . "w")))
- (set (make-local-variable 'beginning-of-defun-function)
- #'fortran-beginning-of-subprogram)
- (set (make-local-variable 'end-of-defun-function)
- #'fortran-end-of-subprogram)
- (set (make-local-variable 'add-log-current-defun-function)
- #'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)
+ (setq-local imenu-case-fold-search t)
+ (setq-local imenu-generic-expression fortran-imenu-generic-expression)
+ (setq-local imenu-syntax-alist '(("_$" . "w")))
+ (setq-local beginning-of-defun-function
+ #'fortran-beginning-of-subprogram)
+ (setq-local end-of-defun-function
+ #'fortran-end-of-subprogram)
+ (setq-local add-log-current-defun-function
+ #'fortran-current-defun)
+ (setq-local dabbrev-case-fold-search 'case-fold-search)
+ (setq-local gud-find-expr-function 'fortran-gud-find-expr)
(add-hook 'hack-local-variables-hook 'fortran-hack-local-variables nil t))
@@ -1220,25 +1150,32 @@ Auto-indent does not happen if a numeric ARG is used."
;; Note that unlike the latter, we don't have to worry about nested
;; subprograms (?).
;; FIXME push-mark?
-(defun fortran-beginning-of-subprogram ()
- "Move point to the beginning of the current Fortran subprogram."
+(defun fortran-beginning-of-subprogram (&optional arg)
+ "Move point to the beginning of the current Fortran subprogram.
+If ARG is negative, and point is between subprograms, the
+\"current\" subprogram is the next one."
(interactive)
- (let ((case-fold-search t))
- ;; If called already at the start of subprogram, go to the previous.
- (beginning-of-line (if (bolp) 0 1))
- (save-match-data
- (or (looking-at fortran-start-prog-re)
- ;; This leaves us at bob if before the first subprogram.
- (eq (fortran-previous-statement) 'first-statement)
- (if (or (catch 'ok
- (while (re-search-backward fortran-end-prog-re nil 'move)
- (if (fortran-check-end-prog-re) (throw 'ok t))))
- ;; If the search failed, must be at bob.
- ;; First code line is the start of the subprogram.
- ;; FIXME use a more rigorous test, cf fortran-next-statement?
- ;; Though that needs to handle continuations too.
- (not (looking-at "^\\([ \t]*[0-9]\\|[ \t]+[^!#]\\)")))
- (fortran-next-statement))))))
+ (if (and arg
+ (< arg 0))
+ (progn
+ (fortran-end-of-subprogram)
+ (fortran-beginning-of-subprogram))
+ (let ((case-fold-search t))
+ ;; If called already at the start of subprogram, go to the previous.
+ (beginning-of-line (if (bolp) 0 1))
+ (save-match-data
+ (or (looking-at fortran-start-prog-re)
+ ;; This leaves us at bob if before the first subprogram.
+ (eq (fortran-previous-statement) 'first-statement)
+ (if (or (catch 'ok
+ (while (re-search-backward fortran-end-prog-re nil 'move)
+ (if (fortran-check-end-prog-re) (throw 'ok t))))
+ ;; If the search failed, must be at bob.
+ ;; First code line is the start of the subprogram.
+ ;; FIXME use a more rigorous test, cf fortran-next-statement?
+ ;; Though that needs to handle continuations too.
+ (not (looking-at "^\\([ \t]*[0-9]\\|[ \t]+[^!#]\\)")))
+ (fortran-next-statement)))))))
;; This is simpler than f-beginning-of-s because the end of a
;; subprogram is never implicit.
@@ -2204,6 +2141,81 @@ arg DO-SPACE prevents stripping the whitespace."
(point)))))
"main"))))
+;; The menu is defined at the end because `custom-menu-create' is
+;; called at load time and will result in (recursively) loading this
+;; file otherwise.
+(easy-menu-define fortran-menu fortran-mode-map "Menu for Fortran mode."
+ `("Fortran"
+ ["Manual" (info "(emacs)Fortran") :active t
+ :help "Read the Emacs manual chapter on Fortran mode"]
+ ("Customization"
+ ,(progn
+ ;; Tell the byte compiler that `features' is lexical.
+ (with-no-warnings (defvar features))
+ (let ((features (cons 'fortran features)))
+ (custom-menu-create 'fortran)))
+ ;; FIXME useless?
+ ["Set" Custom-set :active t
+ :help "Set current value of all edited settings in the buffer"]
+ ["Save" Custom-save :active t
+ :help "Set and save all edited settings"]
+ ["Reset to Current" Custom-reset-current :active t
+ :help "Reset all edited settings to current"]
+ ["Reset to Saved" Custom-reset-saved :active t
+ :help "Reset all edited or set settings to saved"]
+ ["Reset to Standard Settings" Custom-reset-standard :active t
+ :help "Erase all customizations in buffer"]
+ )
+ "--"
+ ["Comment Region" fortran-comment-region mark-active]
+ ["Uncomment Region"
+ (fortran-comment-region (region-beginning) (region-end) 1)
+ mark-active]
+ ["Indent Region" indent-region mark-active]
+ ["Indent Subprogram" fortran-indent-subprogram t]
+ "--"
+ ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t
+ :help "Move point to the start of the current subprogram"]
+ ["End of Subprogram" fortran-end-of-subprogram :active t
+ :help "Move point to the end of the current subprogram"]
+ ("Mark"
+ :help "Mark a region of code"
+ ["Subprogram" mark-defun t]
+ ["IF Block" fortran-mark-if t]
+ ["DO Block" fortran-mark-do t]
+ )
+ ["Narrow to Subprogram" narrow-to-defun t]
+ ["Widen" widen t]
+ "--"
+ ["Temporary Column Ruler" fortran-column-ruler :active t
+ :help "Briefly display Fortran column numbers"]
+ ;; May not be '72', depending on fortran-line-length, but this
+ ;; seems ok for a menu item.
+ ["72-column Window" fortran-window-create :active t
+ :help "Set window width to Fortran line length"]
+ ["Full Width Window"
+ (enlarge-window-horizontally (- (frame-width) (window-width)))
+ :active (not (window-full-width-p))
+ :help "Make window full width"]
+ ["Momentary 72-Column Window" fortran-window-create-momentarily
+ :active t :help "Briefly set window width to Fortran line length"]
+ "--"
+ ["Break Line at Point" fortran-split-line :active t
+ :help "Break the current line at point"]
+ ["Join Line" fortran-join-line :active t
+ :help "Join the current line to the previous one"]
+ ["Fill Statement/Comment" fill-paragraph t]
+ "--"
+ ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function
+ :style toggle
+ :help "Automatically fill text while typing in this buffer"]
+ ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode
+ :style toggle :help "Expand abbreviations while typing in this buffer"]
+ ["Add Imenu Menu" imenu-add-menubar-index
+ :active (not (lookup-key (current-local-map) [menu-bar index]))
+ :included (fboundp 'imenu-add-to-menubar)
+ :help "Add an index menu to the menu-bar"]))
+
(provide 'fortran)
;;; fortran.el ends here
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 51a237a38e8..b9c8305bed0 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -8,7 +8,7 @@
;; This file is part of GNU Emacs.
-;; Homepage: http://www.emacswiki.org/emacs/GDB-MI
+;; Homepage: https://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
@@ -89,9 +89,9 @@
;;; Code:
(require 'gud)
-(require 'json)
-(require 'bindat)
(require 'cl-lib)
+(require 'cl-seq)
+(eval-when-compile (require 'pcase))
(declare-function speedbar-change-initial-expansion-list
"speedbar" (new-default))
@@ -101,17 +101,41 @@
(declare-function speedbar-delete-subblock "speedbar" (indent))
(declare-function speedbar-center-buffer-smartly "speedbar" ())
+;; FIXME: The declares below are necessary because we don't call `gud-def'
+;; at toplevel, so the compiler doesn't know under which circumstances
+;; they're defined.
+(declare-function gud-until "gud" (arg))
+(declare-function gud-print "gud" (arg))
+(declare-function gud-down "gud" (arg))
+(declare-function gud-up "gud" (arg))
+(declare-function gud-jump "gud" (arg))
+(declare-function gud-finish "gud" (arg))
+(declare-function gud-next "gud" (arg))
+(declare-function gud-stepi "gud" (arg))
+(declare-function gud-tbreak "gud" (arg))
+
(defvar tool-bar-map)
(defvar speedbar-initial-expansion-list-name)
(defvar speedbar-frame)
-(defvar gdb-memory-address "main")
-(defvar gdb-memory-last-address nil
+(defvar-local gdb-memory-address-expression "main"
+ "This expression is passed to gdb.
+Possible value: main, $rsp, x+3.")
+(defvar-local gdb-memory-address nil
+ "Address of memory display.")
+(defvar-local 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-local gdb--memory-display-warning nil
+ "Display warning on memory header if t.
+
+When error occurs when retrieving memory, gdb-mi displays the
+last successful page. In that case the expression might not
+match the memory displayed. We want to let the user be aware of
+that, so display a warning exclamation mark in the header line.")
(defvar gdb-thread-number nil
"Main current thread.
@@ -154,7 +178,7 @@ May be manually changed by user with `gdb-select-frame'.")
"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
+returned from -thread-info by `gdb-mi--partial-output'. Updated in
`gdb-thread-list-handler-custom'.")
(defvar gdb-running-threads-count nil
@@ -173,7 +197,7 @@ See also `gdb-running-threads-count'.")
"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'
+as returned from \"-break-list\" by `gdb-mi--partial-output'
\(\"body\" field is used). Updated in
`gdb-breakpoints-list-handler-custom'.")
@@ -211,7 +235,9 @@ Only used for files that Emacs can't find.")
(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-source-window-list nil
+ "List of windows used for displaying source files.
+Sorted in most-recently-visited-first order.")
(defvar gdb-inferior-status nil)
(defvar gdb-continuation nil)
(defvar gdb-supports-non-stop nil)
@@ -242,6 +268,27 @@ Possible values are these symbols:
disposition of output generated by commands that
gdb mode sends to gdb on its own behalf.")
+(defvar gdb--window-configuration-before nil
+ "Stores the window configuration before starting GDB.")
+
+(defcustom gdb-restore-window-configuration-after-quit nil
+ "If non-nil, restore window configuration as of before GDB started.
+
+Possible values are:
+ t -- Always restore.
+ nil -- Don't restore.
+ `if-gdb-show-main' -- Restore only if variable `gdb-show-main'
+ is non-nil
+ `if-gdb-many-windows' -- Restore only if variable `gdb-many-windows'
+ is non-nil."
+ :type '(choice
+ (const :tag "Always restore" t)
+ (const :tag "Don't restore" nil)
+ (const :tag "Depends on `gdb-show-main'" 'if-gdb-show-main)
+ (const :tag "Depends on `gdb-many-windows'" 'if-gdb-many-windows))
+ :group 'gdb
+ :version "28.1")
+
(defcustom gdb-discard-unordered-replies t
"Non-nil means discard any out-of-order GDB replies.
This protects against lost GDB replies, assuming that GDB always
@@ -339,19 +386,17 @@ were not yet received."
(dolist (handler gdb-handler-list)
(setf (gdb-handler-pending-trigger handler) nil)))
-(defmacro gdb-wait-for-pending (&rest body)
- "Wait for all pending GDB commands to finish and evaluate BODY.
+(defun gdb-wait-for-pending (func)
+ "Wait for all pending GDB commands to finish and call FUNC.
This function checks every 0.5 seconds if there are any pending
triggers in `gdb-handler-list'."
- `(run-with-timer
- 0.5 nil
- '(lambda ()
- (if (not (cl-find-if (lambda (handler)
- (gdb-handler-pending-trigger handler))
- gdb-handler-list))
- (progn ,@body)
- (gdb-wait-for-pending ,@body)))))
+ (run-with-timer
+ 0.5 nil
+ (lambda ()
+ (if (cl-some #'gdb-handler-pending-trigger gdb-handler-list)
+ (gdb-wait-for-pending func)
+ (funcall func)))))
;; Publish-subscribe
@@ -480,8 +525,6 @@ contains fields of corresponding MI *stopped async record:
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)
@@ -538,6 +581,23 @@ stopped thread is already selected."
:group 'gdb-buffers
:version "23.2")
+(defcustom gdb-registers-enable-filter nil
+ "If non-nil, enable register name filter in register buffer.
+Use `gdb-registers-filter-pattern-list' to control what register to
+filter."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "28.1")
+
+(defcustom gdb-registers-filter-pattern-list nil
+ "Patterns for names that are displayed in register buffer.
+Each pattern is a regular expression. GDB displays registers
+whose name matches any pattern in the list. Refresh the register
+buffer for the change to take effect."
+ :type '(repeat regexp)
+ :group 'gdb-buffers
+ :version "28.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
@@ -592,6 +652,41 @@ Also display the main routine in the disassembly buffer if present."
:group 'gdb
:version "22.1")
+(defcustom gdb-window-configuration-directory user-emacs-directory
+ "Directory where GDB window configuration files are stored.
+If nil, use `default-directory'."
+ :type 'string
+ :group 'gdb
+ :version "28.1")
+
+(defcustom gdb-default-window-configuration-file nil
+ "If non-nil, load this window configuration (layout) on startup.
+This should be the full name of the window configuration file.
+If this is not an absolute path, GDB treats it as a relative path
+and looks under `gdb-window-configuration-directory'.
+
+Note that this variable only takes effect when variable
+`gdb-many-windows' is t."
+ :type '(choice (const :tag "None" nil)
+ string)
+ :group 'gdb
+ :version "28.1")
+
+(defcustom gdb-display-source-buffer-action '(nil . ((inhibit-same-window . t)))
+ "`display-buffer' action used when GDB displays a source buffer."
+ :type 'sexp
+ :group 'gdb
+ :version "28.1")
+
+(defcustom gdb-max-source-window-count 1
+ "Maximum number of source windows to use.
+Until there are such number of source windows on screen, GDB
+tries to open a new window when visiting a new source file; after
+that GDB starts to reuse existing source windows."
+ :type 'number
+ :group 'gdb
+ :version "28.1")
+
(defvar gdbmi-debug-mode nil
"When non-nil, print the messages sent/received from GDB/MI in *Messages*.")
@@ -669,15 +764,17 @@ NOARG must be t when this macro is used outside `gud-def'."
(unless (zerop (length string))
(remove-function (process-filter proc) #'gdb--check-interpreter)
(unless (memq (aref string 0) '(?^ ?~ ?@ ?& ?* ?=))
- ;; Apparently we're not running with -i=mi.
- (let ((msg "Error: you did not specify -i=mi on GDB's command line!"))
+ ;; Apparently we're not running with -i=mi (or we're, for
+ ;; instance, debugging something inside a Docker instance with
+ ;; Emacs on the outside).
+ (let ((msg "Error: Either -i=mi wasn't specified on the GDB command line, or the extra socket couldn't be established. Consider using `M-x gud-gdb' instead."))
(message msg)
(setq string (concat (propertize msg 'font-lock-face 'error)
"\n" string)))
;; Use the old gud-gbd filter, not because it works, but because it
;; will properly display GDB's answers rather than hanging waiting for
;; answers that aren't coming.
- (set (make-local-variable 'gud-marker-filter) #'gud-gdb-marker-filter))
+ (setq-local gud-marker-filter #'gud-gdb-marker-filter))
(funcall filter proc string)))
(defvar gdb-control-level 0)
@@ -750,6 +847,12 @@ detailed description of this mode.
(gdb-restore-windows)
(error
"Multiple debugging requires restarting in text command mode"))
+
+ ;; Save window configuration before starting gdb so we can restore
+ ;; it after gdb quits. Save it regardless of the value of
+ ;; `gdb-restore-window-configuration-after-quit'.
+ (setq gdb--window-configuration-before (window-state-get))
+
;;
(gud-common-init command-line nil 'gud-gdbmi-marker-filter)
@@ -758,8 +861,8 @@ detailed description of this mode.
(let ((proc (get-buffer-process gud-comint-buffer)))
(add-function :around (process-filter proc) #'gdb--check-interpreter))
- (set (make-local-variable 'gud-minor-mode) 'gdbmi)
- (set (make-local-variable 'gdb-control-level) 0)
+ (setq-local gud-minor-mode 'gdbmi)
+ (setq-local gdb-control-level 0)
(setq comint-input-sender 'gdb-send)
(when (ring-empty-p comint-input-ring) ; cf shell-mode
(let ((hfile (expand-file-name (or (getenv "GDBHISTFILE")
@@ -788,9 +891,9 @@ detailed description of this mode.
(and (stringp hsize)
(integerp (setq hsize (string-to-number hsize)))
(> hsize 0)
- (set (make-local-variable 'comint-input-ring-size) hsize))
+ (setq-local comint-input-ring-size hsize))
(if (stringp hfile)
- (set (make-local-variable 'comint-input-ring-file-name) hfile))
+ (setq-local 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.")
@@ -893,8 +996,9 @@ detailed description of this mode.
(define-key gud-minor-mode-map [left-margin C-mouse-3]
'gdb-mouse-jump)
- (set (make-local-variable 'gud-gdb-completion-function)
- 'gud-gdbmi-completions)
+ (gud-set-repeat-map-property 'gud-gdb-repeat-map)
+
+ (setq-local gud-gdb-completion-function 'gud-gdbmi-completions)
(add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point
nil 'local)
@@ -925,7 +1029,7 @@ detailed description of this mode.
gdb-first-done-or-error t
gdb-buffer-fringe-width (car (window-fringes))
gdb-debug-log nil
- gdb-source-window nil
+ gdb-source-window-list nil
gdb-inferior-status nil
gdb-continuation nil
gdb-buf-publisher '()
@@ -1035,7 +1139,10 @@ no input, and GDB is waiting for input."
(declare-function tooltip-show "tooltip" (text &optional use-echo-area))
-(defconst gdb--string-regexp "\"\\(?:[^\\\"]\\|\\\\.\\)*\"")
+(defconst gdb--string-regexp (rx "\""
+ (* (or (seq "\\" nonl)
+ (not (any "\"\\"))))
+ "\""))
(defun gdb-tooltip-print (expr)
(with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
@@ -1045,11 +1152,11 @@ no input, and GDB is waiting for input."
"\\)")
nil t)
(tooltip-show
- (concat expr " = " (read (match-string 1)))
+ (concat expr " = " (gdb-mi--c-string-from-string (match-string 1)))
(or gud-tooltip-echo-area
(not (display-graphic-p)))))
((re-search-forward "msg=\\(\".+\"\\)$" nil t)
- (tooltip-show (read (match-string 1))
+ (tooltip-show (gdb-mi--c-string-from-string (match-string 1))
(or gud-tooltip-echo-area
(not (display-graphic-p))))))))
@@ -1062,11 +1169,11 @@ no input, and GDB is waiting for input."
(if (search-forward "expands to: " nil t)
(unless (looking-at "\\S-+.*(.*).*")
(gdb-input (concat "-data-evaluate-expression \"" expr "\"")
- `(lambda () (gdb-tooltip-print ,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)
+ (setq-local gud-minor-mode 'gdbmi)
+ (setq-local tool-bar-map gud-tool-bar-map)
(when gud-tooltip-mode
(make-local-variable 'gdb-define-alist)
(gdb-create-define-alist)
@@ -1182,23 +1289,26 @@ With arg, enter name of variable to be watched in the minibuffer."
(tooltip-identifier-from-point (point)))))))
(set-text-properties 0 (length expr) nil expr)
(gdb-input (concat "-var-create - * " expr "")
- `(lambda () (gdb-var-create-handler ,expr))))))
+ (lambda () (gdb-var-create-handler expr))))))
(message "gud-watch is a no-op in this mode."))))
+(defsubst gdb-mi--field (value field)
+ (cdr (assq field value)))
+
(defun gdb-var-create-handler (expr)
- (let* ((result (gdb-json-partial-output)))
- (if (not (bindat-get-field result 'msg))
+ (let* ((result (gdb-mi--partial-output)))
+ (if (not (gdb-mi--field result 'msg))
(let ((var
- (list (bindat-get-field result 'name)
+ (list (gdb-mi--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)
+ (gdb-mi--field result 'numchild)
+ (gdb-mi--field result 'type)
+ (gdb-mi--field result 'value)
nil
- (bindat-get-field result 'has_more)
+ (gdb-mi--field result 'has_more)
gdb-frame-address)))
(push var gdb-var-list)
(speedbar 1)
@@ -1219,41 +1329,31 @@ With arg, enter name of variable to be watched in the minibuffer."
(raise-frame speedbar-frame))
(speedbar-timer-fn))
-(defun gdb-var-evaluate-expression-handler (varnum changed)
- (goto-char (point-min))
- (re-search-forward (concat ".*value=\\(" gdb--string-regexp "\\)")
- 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 (concat "-var-update " varnum) 'ignore)
(gdb-input (concat "-var-list-children --all-values " varnum)
- `(lambda () (gdb-var-list-children-handler ,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)))
+ (output (gdb-mi--partial-output 'child))
+ (children (gdb-mi--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))
+ (setcar (nthcdr 2 var) (gdb-mi--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)
+ (let ((varchild (list (gdb-mi--field child 'name)
+ (gdb-mi--field child 'exp)
+ (gdb-mi--field child 'numchild)
+ (gdb-mi--field child 'type)
+ (gdb-mi--field child 'value)
nil
- (bindat-get-field child 'has_more))))
+ (gdb-mi--field child 'has_more))))
(if (assoc (car varchild) gdb-var-list)
(throw 'child-already-watched nil))
(push varchild var-list))))
@@ -1296,7 +1396,7 @@ With arg, enter name of variable to be watched in the minibuffer."
(varnum (car var))
(value (read-string "New value: ")))
(gdb-input (concat "-var-assign " varnum " " value)
- `(lambda () (gdb-edit-value-handler ,value)))))
+ (lambda () (gdb-edit-value-handler value)))))
(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)")
@@ -1312,17 +1412,17 @@ With arg, enter name of variable to be watched in the minibuffer."
'gdb-var-update))
(defun gdb-var-update-handler ()
- (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
+ (let ((changelist (gdb-mi--field (gdb-mi--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))
+ (let* ((varnum (gdb-mi--field change 'name))
(var (assoc varnum gdb-var-list))
- (new-num (bindat-get-field change 'new_num_children)))
+ (new-num (gdb-mi--field change 'new_num_children)))
(when var
- (let ((scope (bindat-get-field change 'in_scope))
- (has-more (bindat-get-field change 'has_more)))
+ (let ((scope (gdb-mi--field change 'in_scope))
+ (has-more (gdb-mi--field change 'has_more)))
(cond ((string-equal scope "false")
(if gdb-delete-out-of-scope
(gdb-var-delete-1 var varnum)
@@ -1334,12 +1434,12 @@ With arg, enter name of variable to be watched in the minibuffer."
(not new-num)
(string-equal (nth 2 var) "0"))
(setcar (nthcdr 4 var)
- (bindat-get-field change 'value))
+ (gdb-mi--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)))
+ (children (gdb-mi--field change 'new_children)))
(when new-num
(setq var1 (pop temp-var-list))
(while var1
@@ -1355,13 +1455,13 @@ With arg, enter name of variable to be watched in the minibuffer."
(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)
+ (list (gdb-mi--field child 'name)
+ (gdb-mi--field child 'exp)
+ (gdb-mi--field child 'numchild)
+ (gdb-mi--field child 'type)
+ (gdb-mi--field child 'value)
'changed
- (bindat-get-field child 'has_more))))
+ (gdb-mi--field child 'has_more))))
(push varchild var-list))))
;; Remove deleted children from list.
((< new previous)
@@ -1442,7 +1542,7 @@ thread."
(defun gdb-current-buffer-frame ()
"Get current stack frame object for thread of current buffer."
- (bindat-get-field (gdb-current-buffer-thread) 'frame))
+ (gdb-mi--field (gdb-current-buffer-thread) 'frame))
(defun gdb-buffer-type (buffer)
"Get value of `gdb-buffer-type' for BUFFER."
@@ -1489,10 +1589,10 @@ this trigger is subscribed to `gdb-buf-publisher' and called with
(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)
+ (setq-local gdb-thread-number thread))
+ (setq-local gud-minor-mode
+ (buffer-local-value 'gud-minor-mode gud-comint-buffer))
+ (setq-local tool-bar-map gud-tool-bar-map)
(rename-buffer (funcall (gdb-rules-name-maker rules)))
(when trigger
(gdb-add-subscriber gdb-buf-publisher
@@ -1504,9 +1604,9 @@ this trigger is subscribed to `gdb-buf-publisher' and called with
(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))))
+ (lambda (&rest args)
+ (with-current-buffer buffer
+ (apply expr args))))
;; Used to display windows with thread-bound buffers
(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc
@@ -1546,17 +1646,16 @@ this trigger is subscribed to `gdb-buf-publisher' and called with
;; (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))))))))
+ (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
@@ -1667,25 +1766,25 @@ this trigger is subscribed to `gdb-buf-publisher' and called with
"Interrupt the program being debugged."
(interactive)
(interrupt-process
- (get-buffer-process gud-comint-buffer) comint-ptyp))
+ (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) 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))
+ (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp))
(defun gdb-io-stop ()
"Stop the program being debugged."
(interactive)
(stop-process
- (get-buffer-process gud-comint-buffer) comint-ptyp))
+ (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) 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)))
+ (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io))))
(defun gdb-clear-inferior-io ()
(with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
@@ -1788,7 +1887,8 @@ static char *magick[] = {
"\\|def\\(i\\(ne?\\)?\\)?\\|doc\\(u\\(m\\(e\\(nt?\\)?\\)?\\)?\\)?\\|"
gdb-python-guile-commands-regexp
"\\|while-stepping\\|stepp\\(i\\(ng?\\)?\\)?\\|ws\\|actions"
- "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)?$")
+ "\\|expl\\(o\\(re?\\)?\\)?"
+ "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)*$")
"Regexp matching GDB commands that enter a recursive reading loop.
As long as GDB is in the recursive reading loop, it does not expect
commands to be prefixed by \"-interpreter-exec console\".")
@@ -1976,7 +2076,7 @@ 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)
+ (string= (gdb-mi--field (gdb-current-buffer-thread) 'state)
"running"))
;; Set frame number to "0" when _current_ threads stops.
(when (and (gdb-current-buffer-thread)
@@ -2007,17 +2107,36 @@ is running."
;; 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))
+ "Find a window to display BUFFER.
+Always find a window to display buffer, and return it."
+ ;; This function doesn't take care of setting up source window(s) at startup,
+ ;; that's handled by `gdb-setup-windows' (if `gdb-many-windows' is non-nil).
+ ;; If `buffer' is already shown in a window, use that window.
+ (or (get-buffer-window buffer)
+ (progn
+ ;; First, update the window list.
+ (setq gdb-source-window-list
+ (cl-remove-duplicates
+ (cl-remove-if-not
+ (lambda (win)
+ (and (window-live-p win)
+ (eq (window-frame win)
+ (selected-frame))))
+ gdb-source-window-list)))
+ ;; Should we create a new window or reuse one?
+ (if (> gdb-max-source-window-count
+ (length gdb-source-window-list))
+ ;; Create a new window, push it to window list and return it.
+ (car (push (display-buffer buffer gdb-display-source-buffer-action)
+ gdb-source-window-list))
+ ;; Reuse a window, we use the oldest window and put that to
+ ;; the front of the window list.
+ (let ((last-win (car (last gdb-source-window-list)))
+ (rest (butlast gdb-source-window-list)))
+ (set-window-buffer last-win buffer)
+ (setq gdb-source-window-list
+ (cons last-win rest))
+ last-win)))))
(defun gdbmi-start-with (str offset match)
@@ -2214,7 +2333,8 @@ a GDB/MI reply message."
;; Suppress "No registers." GDB 6.8 and earlier
;; duplicates MI error message on internal stream.
;; Don't print to GUD buffer.
- (if (not (string-equal (read c-string) "No registers.\n"))
+ (if (not (string-equal (gdb-mi--c-string-from-string c-string)
+ "No registers.\n"))
(gdb-internals c-string)))
@@ -2336,7 +2456,7 @@ the end of the current result or async record is reached."
is-complete)))
-; The following grammar rules are not yet implemented by this GDBMI-BNF parser.
+; The following grammar rules are not parsed directly by this GDBMI-BNF parser.
; The handling of those rules is currently done by the handlers registered
; in gdbmi-bnf-result-state-configs
;
@@ -2358,19 +2478,17 @@ the end of the current result or async record is reached."
; list ==>
; "[]" | "[" value ( "," value )* "]" | "[" result ( "," result )* "]"
-(defcustom gdb-mi-decode-strings nil
+;; FIXME: This is fragile: it relies on the assumption that all the
+;; non-ASCII strings output by GDB, including names of the source
+;; files, values of string variables in the inferior, etc., are all
+;; encoded in the same encoding.
+
+(defcustom gdb-mi-decode-strings t
"When non-nil, decode octal escapes in GDB output into non-ASCII text.
If the value is a coding-system, use that coding-system to decode
the bytes reconstructed from octal escapes. Any other non-nil value
-means to decode using the coding-system set for the GDB process.
-
-Warning: setting this non-nil might mangle strings reported by GDB
-that have literal substrings which match the \\nnn octal escape
-patterns, where nnn is an octal number between 200 and 377. So
-we only recommend to set this variable non-nil if the program you
-are debugging really reports non-ASCII text, or some of its source
-file names include non-ASCII characters."
+means to decode using the coding-system set for the GDB process."
:type '(choice
(const :tag "Don't decode" nil)
(const :tag "Decode using default coding-system" t)
@@ -2378,47 +2496,9 @@ file names include non-ASCII characters."
:group 'gdb
:version "25.1")
-;; The idea of the following function was suggested
-;; by Kenichi Handa <handa@gnu.org>.
-;;
-;; FIXME: This is fragile: it relies on the assumption that all the
-;; non-ASCII strings output by GDB, including names of the source
-;; files, values of string variables in the inferior, etc., are all
-;; encoded in the same encoding. It also assumes that the \nnn
-;; sequences are not split between chunks of output of the GDB process
-;; due to buffering, and arrive together. Finally, if some string
-;; included literal \nnn strings (as opposed to non-ASCII characters
-;; converted by GDB/MI to octal escapes), this decoding will mangle
-;; those strings. When/if GDB acquires the ability to not
-;; escape-protect non-ASCII characters in its MI output, this kludge
-;; should be removed.
-(defun gdb-mi-decode (string)
- "Decode octal escapes in MI output STRING into multibyte text."
- (let ((coding
- (if (coding-system-p gdb-mi-decode-strings)
- gdb-mi-decode-strings
- (with-current-buffer
- (gdb-get-buffer-create 'gdb-partial-output-buffer)
- buffer-file-coding-system))))
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (prin1 string (current-buffer))
- (goto-char (point-min))
- ;; prin1 quotes the octal escapes as well, which interferes with
- ;; their interpretation by 'read' below. Remove the extra
- ;; backslashes to countermand that.
- (while (re-search-forward "\\\\\\(\\\\[2-3][0-7][0-7]\\)" nil t)
- (replace-match "\\1" nil nil))
- (goto-char (point-min))
- (decode-coding-string (read (current-buffer)) coding))))
-
(defun gud-gdbmi-marker-filter (string)
"Filter GDB/MI output."
- ;; If required, decode non-ASCII text encoded with octal escapes.
- (or (null gdb-mi-decode-strings)
- (setq string (gdb-mi-decode string)))
-
;; Record transactions if logging is enabled.
(when gdb-enable-debug
(push (cons 'recv string) gdb-debug-log)
@@ -2446,7 +2526,13 @@ file names include non-ASCII characters."
gdb-filter-output)
-(defun gdb-gdb (_output-field))
+(defun gdb-gdb (_output-field)
+ ;; This is needed because the "explore" command is not ended by the
+ ;; likes of "end" or "quit", but instead by a RET at the appropriate
+ ;; place, and we know we have exited "explore" when we get the
+ ;; "(gdb)" prompt.
+ (and (> gdb-control-level 0)
+ (setq gdb-control-level (1- gdb-control-level))))
(defun gdb-shell (output-field)
(setq gdb-filter-output
@@ -2459,7 +2545,7 @@ file names include non-ASCII characters."
(defun gdb-thread-exited (_token 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)))
+ (let* ((thread-id (gdb-mi--field (gdb-mi--from-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,
@@ -2467,29 +2553,28 @@ Unset `gdb-thread-number' if current thread exited and update threads list."
;; 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))))
+ (lambda () (gdb-emit-signal gdb-buf-publisher 'update-threads)))))
(defun gdb-thread-selected (_token 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)))
+ (let* ((result (gdb-mi--from-string output-field))
+ (thread-id (gdb-mi--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 too fast and second call (from
;; gdb-thread-selected handler) gets cut off by our beloved
;; pending triggers.
- ;; Solution is `gdb-wait-for-pending' macro: it guarantees that its
- ;; body will get executed when `gdb-handler-list' if free of
+ ;; Solution is `gdb-wait-for-pending': it guarantees that its
+ ;; argument will get called when `gdb-handler-list' if free of
;; pending triggers.
- (gdb-wait-for-pending
- (gdb-update))))
+ (gdb-wait-for-pending #'gdb-update)))
(defun gdb-running (_token output-field)
(let* ((thread-id
- (bindat-get-field (gdb-json-string output-field) 'thread-id)))
+ (gdb-mi--field (gdb-mi--from-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
@@ -2518,11 +2603,11 @@ Sets `gdb-thread-number' to new id."
"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))
- (retval (bindat-get-field result 'return-value))
- (varnum (bindat-get-field result 'gdb-result-var)))
+ (let* ((result (gdb-mi--from-string output-field))
+ (reason (gdb-mi--field result 'reason))
+ (thread-id (gdb-mi--field result 'thread-id))
+ (retval (gdb-mi--field result 'return-value))
+ (varnum (gdb-mi--field result 'gdb-result-var)))
;; -data-list-register-names needs to be issued for any stopped
;; thread
@@ -2565,7 +2650,7 @@ current thread and update GDB buffers."
;; gdb-switch-when-another-stopped:
(when (or gdb-switch-when-another-stopped
(not (string= "stopped"
- (bindat-get-field (gdb-current-buffer-thread) 'state))))
+ (gdb-mi--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)
@@ -2598,7 +2683,7 @@ current thread and update GDB buffers."
(if (string= output-field "\"\\n\"")
""
(let ((error-message
- (read output-field)))
+ (gdb-mi--c-string-from-string output-field)))
(put-text-property
0 (length error-message)
'face font-lock-warning-face
@@ -2609,7 +2694,8 @@ current thread and update GDB buffers."
;; (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))))
+ (gdb-concat-output gdb-filter-output
+ (gdb-mi--c-string-from-string output-field))))
(defun gdb-done (token-number output-field is-complete)
(gdb-done-or-error token-number 'done output-field is-complete))
@@ -2626,7 +2712,8 @@ current thread and update GDB buffers."
;; MI error - send to minibuffer
(when (eq type 'error)
;; Skip "msg=" from `output-field'
- (message "%s" (read (substring output-field 4)))
+ (message "%s" (gdb-mi--c-string-from-string
+ (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)))
@@ -2674,83 +2761,154 @@ current thread and update GDB buffers."
(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.
+;; Parse GDB/MI result records: this process converts
+;; list [...] -> list
+;; tuple {...} -> list
+;; result KEY=VALUE -> (KEY . VALUE) where KEY is a symbol
+;; c-string "..." -> string
+
+(defun gdb-mi--parse-tuple-or-list (end-char)
+ "Parse a tuple or list, either returned as a Lisp list.
+END-CHAR is the ending delimiter; will stop at end-of-buffer otherwise."
+ (let ((items nil))
+ (while (not (or (eobp)
+ (eq (following-char) end-char)))
+ (let ((item (gdb-mi--parse-result-or-value)))
+ (push item items)
+ (when (eq (following-char) ?,)
+ (forward-char))))
+ (when (eq (following-char) end-char)
+ (forward-char))
+ (nreverse items)))
+
+(defun gdb-mi--parse-c-string ()
+ "Parse a c-string."
+ (let ((start (point))
+ (pieces nil)
+ (octals-used nil))
+ (while (and (re-search-forward (rx (or ?\\ ?\")))
+ (not (eq (preceding-char) ?\")))
+ (push (buffer-substring start (1- (point))) pieces)
+ (cond
+ ((looking-at (rx (any "0-7") (? (any "0-7") (? (any "0-7")))))
+ (push (unibyte-string (string-to-number (match-string 0) 8)) pieces)
+ (setq octals-used t)
+ (goto-char (match-end 0)))
+ ((looking-at (rx (any "ntrvfab\"\\")))
+ (push (cdr (assq (following-char)
+ '((?n . "\n")
+ (?t . "\t")
+ (?r . "\r")
+ (?v . "\v")
+ (?f . "\f")
+ (?a . "\a")
+ (?b . "\b")
+ (?\" . "\"")
+ (?\\ . "\\"))))
+ pieces)
+ (forward-char))
+ (t
+ (warn "Unrecognised escape char: %c" (following-char))))
+ (setq start (point)))
+ (push (buffer-substring start (1- (point))) pieces)
+ (let ((s (apply #'concat (nreverse pieces))))
+ (if (and octals-used gdb-mi-decode-strings)
+ (let ((coding
+ (if (coding-system-p gdb-mi-decode-strings)
+ gdb-mi-decode-strings
+ (buffer-local-value
+ 'buffer-file-coding-system
+ ;; FIXME: This is somewhat expensive.
+ (gdb-get-buffer-create 'gdb-partial-output-buffer)))))
+ (decode-coding-string s coding))
+ s))))
+
+;; FIXME: Ideally this function should not be needed.
+(defun gdb-mi--c-string-from-string (string)
+ "Parse a c-string from (the beginning of) STRING."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (1+ (point-min))) ; Skip leading double quote.
+ (gdb-mi--parse-c-string)))
-If `default-directory' is remote, full file names are adapted accordingly."
- (save-excursion
+(defun gdb-mi--parse-value ()
+ "Parse a value."
+ (cond
+ ((eq (following-char) ?\{)
+ (forward-char)
+ (gdb-mi--parse-tuple-or-list ?\}))
+ ((eq (following-char) ?\[)
+ (forward-char)
+ (gdb-mi--parse-tuple-or-list ?\]))
+ ((eq (following-char) ?\")
+ (forward-char)
+ (gdb-mi--parse-c-string))
+ (t (error "Bad start of result or value: %c" (following-char)))))
+
+(defun gdb-mi--parse-result-or-value ()
+ "Parse a result (key=value) or value."
+ (if (looking-at (rx (group (+ (any "a-zA-Z" ?_ ?-))) "="))
+ (progn
+ (goto-char (match-end 0))
+ (let* ((variable (intern (match-string 1)))
+ (value (gdb-mi--parse-value)))
+ (cons variable value)))
+ (gdb-mi--parse-value)))
+
+(defun gdb-mi--parse-results ()
+ "Parse zero or more result productions as a list."
+ (gdb-mi--parse-tuple-or-list nil))
+
+(defun gdb-mi--fix-key (key value)
+ "Convert any result (key-value pair) in VALUE whose key is KEY to its value."
+ (cond
+ ((atom value) value)
+ ((symbolp (car value))
+ (if (eq (car value) key)
+ (cdr value)
+ (cons (car value) (gdb-mi--fix-key key (cdr value)))))
+ (t (mapcar (lambda (x) (gdb-mi--fix-key key x)) value))))
+
+(defun gdb-mi--extend-fullname (remote value)
+ "Prepend REMOTE to any result string with `fullname' as the key in VALUE."
+ (cond
+ ((atom value) value)
+ ((symbolp (car value))
+ (if (and (eq (car value) 'fullname)
+ (stringp (cdr value)))
+ (cons 'fullname (concat remote (cdr value)))
+ (cons (car value) (gdb-mi--extend-fullname remote (cdr value)))))
+ (t (mapcar (lambda (x) (gdb-mi--extend-fullname remote x)) value))))
+
+(defun gdb-mi--read-buffer (fix-key)
+ "Parse the current buffer as a list of result productions.
+If FIX-KEY is a non-nil symbol, convert all FIX-KEY=VALUE results into VALUE.
+This is used to get rid of useless keys in lists in MI messages;
+eg, [key=.., key=..]. -stack-list-frames and -break-info are
+examples of MI commands which issue such responses."
+ (goto-char (point-min))
+ (let ((results (gdb-mi--parse-results)))
(let ((remote (file-remote-p default-directory)))
(when remote
- (goto-char (point-min))
- (while (re-search-forward "[\\[,]fullname=\"\\(.+?\\)\"" nil t)
- (replace-match (concat remote "\\1") nil nil nil 1))))
- (goto-char (point-min))
+ (setq results (gdb-mi--extend-fullname remote results))))
(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 "{")
- (let ((re (concat "\\([[:alnum:]_-]+\\)=")))
- (while (re-search-forward re nil t)
- (replace-match "\"\\1\":" nil nil)
- (if (eq (char-after) ?\") (forward-sexp) (forward-char))))
- (goto-char (point-max))
- (insert "}")))
+ (setq results (gdb-mi--fix-key fix-key results)))
+ results))
-(defun gdb-json-read-buffer (&optional fix-key fix-list)
- "Prepare and parse GDB/MI output in current buffer with `json-read'.
+(defun gdb-mi--from-string (string &optional fix-key)
+ "Prepare and parse STRING containing GDB/MI output.
-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'."
+FIX-KEY works as in `gdb-mi--read-buffer'."
(with-temp-buffer
(insert string)
- (gdb-json-read-buffer fix-key fix-list)))
+ (gdb-mi--read-buffer fix-key)))
-(defun gdb-json-partial-output (&optional fix-key fix-list)
- "Prepare and parse gdb-partial-output-buffer with `json-read'.
+(defun gdb-mi--partial-output (&optional fix-key)
+ "Prepare and parse gdb-partial-output-buffer.
-FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'."
+FIX-KEY works as in `gdb-mi--read-buffer'."
(with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
- (gdb-json-read-buffer fix-key fix-list)))
+ (gdb-mi--read-buffer fix-key)))
(defun gdb-line-posns (line)
"Return a pair of LINE beginning and end positions."
@@ -2831,14 +2989,6 @@ calling `gdb-table-string'."
(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)
- (push (bindat-get-field struct field) values))
- (nreverse values)))
-
(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
handler-name
&optional signal-list)
@@ -2926,26 +3076,27 @@ See `def-gdb-auto-update-handler'."
'gdb-invalidate-breakpoints)
(defun gdb-breakpoints-list-handler-custom ()
- (let ((breakpoints-list (bindat-get-field
- (gdb-json-partial-output "bkpt" "script")
- 'BreakpointTable 'body))
+ (let ((breakpoints-list (gdb-mi--field
+ (gdb-mi--field (gdb-mi--partial-output 'bkpt)
+ '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)
+ (cons (gdb-mi--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)))
+ (let ((at (gdb-mi--field breakpoint 'at))
+ (pending (gdb-mi--field breakpoint 'pending))
+ (func (gdb-mi--field breakpoint 'func))
+ (type (gdb-mi--field breakpoint 'type)))
(gdb-table-add-row table
(list
- (bindat-get-field breakpoint 'number)
+ (gdb-mi--field breakpoint 'number)
(or type "")
- (or (bindat-get-field breakpoint 'disp) "")
- (let ((flag (bindat-get-field breakpoint 'enabled)))
+ (or (gdb-mi--field breakpoint 'disp) "")
+ (let ((flag (gdb-mi--field breakpoint 'enabled)))
(if (string-equal flag "y")
(eval-when-compile
(propertize "y" 'font-lock-face
@@ -2953,10 +3104,10 @@ See `def-gdb-auto-update-handler'."
(eval-when-compile
(propertize "n" 'font-lock-face
font-lock-comment-face))))
- (bindat-get-field breakpoint 'addr)
- (or (bindat-get-field breakpoint 'times) "")
+ (gdb-mi--field breakpoint 'addr)
+ (or (gdb-mi--field breakpoint 'times) "")
(if (and type (string-match ".*watchpoint" type))
- (bindat-get-field breakpoint 'what)
+ (gdb-mi--field breakpoint 'what)
(or pending at
(concat "in "
(propertize (or func "unknown")
@@ -2981,11 +3132,11 @@ See `def-gdb-auto-update-handler'."
(dolist (breakpoint gdb-breakpoints-list)
(let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is
; an associative list
- (line (bindat-get-field breakpoint 'line)))
+ (line (gdb-mi--field breakpoint 'line)))
(when line
- (let ((file (bindat-get-field breakpoint 'fullname))
- (flag (bindat-get-field breakpoint 'enabled))
- (bptno (bindat-get-field breakpoint 'number)))
+ (let ((file (gdb-mi--field breakpoint 'fullname))
+ (flag (gdb-mi--field breakpoint 'enabled))
+ (bptno (gdb-mi--field breakpoint 'number)))
(unless (and file (file-exists-p file))
(setq file (cdr (assoc bptno gdb-location-alist))))
(if (or (null file)
@@ -2993,11 +3144,11 @@ See `def-gdb-auto-update-handler'."
;; If the full filename is not recorded in the
;; breakpoint structure or in `gdb-location-alist', use
;; -file-list-exec-source-file to extract it.
- (when (setq file (bindat-get-field breakpoint 'file))
+ (when (setq file (gdb-mi--field breakpoint 'file))
(gdb-input (concat "list " file ":1") 'ignore)
(gdb-input "-file-list-exec-source-file"
- `(lambda () (gdb-get-location
- ,bptno ,line ,flag))))
+ (lambda () (gdb-get-location
+ bptno line flag))))
(with-current-buffer (find-file-noselect file 'nowarn)
(gdb-init-buffer)
;; Only want one breakpoint icon at each location.
@@ -3008,24 +3159,27 @@ See `def-gdb-auto-update-handler'."
(concat "fullname=\\(" gdb--string-regexp "\\)"))
(defun gdb-get-location (bptno line flag)
- "Find the directory containing the relevant source file.
-Put in buffer and place breakpoint icon."
+ "Glean name of source file using `gdb-source-file-regexp', and visit it.
+Place breakpoint icon in its buffer."
(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)
- ;; FIXME: Why/how do we use (match-string 1) when the search failed?
- (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.
+ (let (source-file)
+ (if (re-search-forward gdb-source-file-regexp nil t)
+ (progn
+ (setq source-file (gdb-mi--c-string-from-string (match-string 1)))
+ (delete (cons bptno "File not found") gdb-location-alist)
+ (push (cons bptno source-file) 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)))))
+ (throw 'file-not-found nil))
+ (with-current-buffer (find-file-noselect source-file)
+ (gdb-init-buffer)
+ ;; Only want one breakpoint icon at each location.
+ (gdb-put-breakpoint-icon (string-equal flag "y") bptno
+ (string-to-number line))))))
(add-hook 'find-file-hook 'gdb-find-file-hook)
@@ -3244,12 +3398,11 @@ corresponding to the mode line clicked."
(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))
+ (setq-local 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))
+ (let ((threads-list (gdb-mi--field (gdb-mi--partial-output) 'threads))
(table (make-gdb-table))
(marked-line nil))
(setq gdb-threads-list nil)
@@ -3258,9 +3411,9 @@ corresponding to the mode line clicked."
(set-marker gdb-thread-position nil)
(dolist (thread (reverse threads-list))
- (let ((running (equal (bindat-get-field thread 'state) "running")))
+ (let ((running (equal (gdb-mi--field thread 'state) "running")))
(add-to-list 'gdb-threads-list
- (cons (bindat-get-field thread 'id)
+ (cons (gdb-mi--field thread 'id)
thread))
(cl-incf (if running
gdb-running-threads-count
@@ -3269,37 +3422,41 @@ corresponding to the mode line clicked."
(gdb-table-add-row
table
(list
- (bindat-get-field thread 'id)
+ (gdb-mi--field thread 'id)
(concat
(if gdb-thread-buffer-verbose-names
- (concat (bindat-get-field thread 'target-id) " ") "")
- (bindat-get-field thread 'state)
+ (concat (gdb-mi--field thread 'target-id) " ") "")
+ (gdb-mi--field thread 'state)
;; Include frame information for stopped threads
(if (not running)
(concat
- " in " (bindat-get-field thread 'frame 'func)
+ " in " (gdb-mi--field (gdb-mi--field thread 'frame) 'func)
(if gdb-thread-buffer-arguments
(concat
" ("
- (let ((args (bindat-get-field thread 'frame 'args)))
+ (let ((args (gdb-mi--field (gdb-mi--field thread 'frame)
+ 'args)))
(mapconcat
(lambda (arg)
- (apply #'format "%s=%s"
- (gdb-get-many-fields arg 'name 'value)))
+ (format "%s=%s"
+ (gdb-mi--field arg 'name)
+ (gdb-mi--field arg 'value)))
args ","))
")")
"")
(if gdb-thread-buffer-locations
- (gdb-frame-location (bindat-get-field thread 'frame)) "")
+ (gdb-frame-location (gdb-mi--field thread 'frame)) "")
(if gdb-thread-buffer-addresses
- (concat " at " (bindat-get-field thread 'frame 'addr)) ""))
+ (concat " at " (gdb-mi--field (gdb-mi--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))
+ (gdb-mi--field thread 'id))
(setq marked-line (length gdb-threads-list))))
(insert (gdb-table-string table " "))
(when marked-line
@@ -3331,11 +3488,11 @@ If `gdb-thread' is nil, error is signaled."
"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))
+ (,buffer-command (gdb-mi--field thread 'id))
,doc))
(def-gdb-thread-buffer-command gdb-select-thread
- (let ((new-id (bindat-get-field thread 'id)))
+ (let ((new-id (gdb-mi--field thread 'id)))
(gdb-setq-thread-number new-id)
(gdb-input (concat "-thread-select " new-id) 'ignore)
(gdb-update))
@@ -3387,7 +3544,7 @@ on the current line."
line."
`(def-gdb-thread-buffer-command ,name
(if gdb-non-stop
- (let ((gdb-thread-number (bindat-get-field thread 'id))
+ (let ((gdb-thread-number (gdb-mi--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'"))
@@ -3450,7 +3607,7 @@ line."
(def-gdb-trigger-and-handler
gdb-invalidate-memory
(format "-data-read-memory %s %s %d %d %d"
- gdb-memory-address
+ (gdb-mi-quote gdb-memory-address-expression)
gdb-memory-format
gdb-memory-unit
gdb-memory-rows
@@ -3486,27 +3643,35 @@ in `gdb-memory-format'."
(error "Unknown format"))))
(defun gdb-read-memory-custom ()
- (let* ((res (gdb-json-partial-output))
- (err-msg (bindat-get-field res 'msg)))
+ (let* ((res (gdb-mi--partial-output))
+ (err-msg (gdb-mi--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))
+ (let ((memory (gdb-mi--field res 'memory)))
+ (when gdb-memory-last-address
+ ;; Nil means last retrieve emits error or just started the session.
+ (setq gdb--memory-display-warning nil))
+ (setq gdb-memory-address (gdb-mi--field res 'addr))
+ (setq gdb-memory-next-page (gdb-mi--field res 'next-page))
+ (setq gdb-memory-prev-page (gdb-mi--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 (concat (gdb-mi--field row 'addr) ":"))
+ (dolist (column (gdb-mi--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))
+ (when gdb-memory-last-address
+ (let ((gdb-memory-address-expression gdb-memory-last-address))
+ ;; If we don't set `gdb-memory-last-address' to nil,
+ ;; `gdb-invalidate-memory' eventually calls
+ ;; `gdb-read-memory-custom', making an infinite loop.
+ (setq gdb-memory-last-address nil
+ gdb--memory-display-warning t)
(gdb-invalidate-memory 'update)
- (error err-msg))))))
+ (user-error "Error when retrieving memory: %s Displaying last successful page" err-msg))))))
(defvar gdb-memory-mode-map
(let ((map (make-sparse-keymap)))
@@ -3540,7 +3705,7 @@ in `gdb-memory-format'."
"Set the start memory address."
(interactive)
(let ((arg (read-from-minibuffer "Memory address: ")))
- (setq gdb-memory-address arg))
+ (setq gdb-memory-address-expression arg))
(gdb-invalidate-memory 'update))
(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
@@ -3723,7 +3888,19 @@ DOC is an optional documentation string."
(defvar gdb-memory-header
'(:eval
(concat
- "Start address["
+ "Start address "
+ ;; If `gdb-memory-address-expression' is nil, `propertize' would error.
+ (propertize (or gdb-memory-address-expression "N/A")
+ '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))
+ (if gdb--memory-display-warning
+ (propertize " !" 'face '(:inherit error :weight bold))
+ "")
+ " ["
(propertize "-"
'face font-lock-warning-face
'help-echo "mouse-1: decrement address"
@@ -3740,13 +3917,9 @@ DOC is an optional documentation string."
'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))
+ ;; If `gdb-memory-address' is nil, `propertize' would error.
+ (propertize (or gdb-memory-address "N/A")
+ 'face font-lock-warning-face)
" Rows: "
(propertize (number-to-string gdb-memory-rows)
'face font-lock-warning-face
@@ -3780,8 +3953,7 @@ DOC is an optional documentation string."
(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))
+ (setq-local font-lock-defaults '(gdb-memory-font-lock-keywords))
'gdb-invalidate-memory)
(defun gdb-memory-buffer-name ()
@@ -3822,8 +3994,8 @@ DOC is an optional documentation string."
(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)))
+ (file (gdb-mi--field frame 'fullname))
+ (line (gdb-mi--field frame 'line)))
(if file
(format "-data-disassemble -f %s -l %s -n -1 -- 0" file line)
;; If we're unable to get a file name / line for $PC, simply
@@ -3873,28 +4045,27 @@ DOC is an optional documentation string."
;; 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))
+ (setq-local gdb-disassembly-position (make-marker))
+ (setq-local 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))
+ (let* ((instructions (gdb-mi--field (gdb-mi--partial-output) 'asm_insns))
+ (address (gdb-mi--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)
+ (gdb-mi--field instr 'address)
(let
- ((func-name (bindat-get-field instr 'func-name))
- (offset (bindat-get-field instr 'offset)))
+ ((func-name (gdb-mi--field instr 'func-name))
+ (offset (gdb-mi--field instr 'offset)))
(if func-name
(format "<%s+%s>:" func-name offset)
""))
- (bindat-get-field instr 'inst)))
- (when (string-equal (bindat-get-field instr 'address)
+ (gdb-mi--field instr 'inst)))
+ (when (string-equal (gdb-mi--field instr 'address)
address)
(progn
(setq marked-line (length (gdb-table-rows table)))
@@ -3913,15 +4084,15 @@ DOC is an optional documentation string."
(setq mode-name
(gdb-current-context-mode-name
(concat "Disassembly: "
- (bindat-get-field (gdb-current-buffer-frame) 'func))))))
+ (gdb-mi--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)))
+ (bptno (gdb-mi--field breakpoint 'number))
+ (flag (gdb-mi--field breakpoint 'enabled))
+ (address (gdb-mi--field breakpoint 'addr)))
(save-excursion
(goto-char (point-min))
(if (re-search-forward (concat "^" address) nil t)
@@ -3951,10 +4122,10 @@ DOC is an optional documentation string."
(let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
(if breakpoint
(gud-basic-call
- (concat (if (equal "y" (bindat-get-field breakpoint 'enabled))
+ (concat (if (equal "y" (gdb-mi--field breakpoint 'enabled))
"-break-disable "
"-break-enable ")
- (bindat-get-field breakpoint 'number)))
+ (gdb-mi--field breakpoint 'number)))
(error "Not recognized as break/watchpoint line")))))
(defun gdb-delete-breakpoint ()
@@ -3965,7 +4136,7 @@ DOC is an optional documentation string."
(let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
(if breakpoint
(gud-basic-call (concat "-break-delete "
- (bindat-get-field breakpoint 'number)))
+ (gdb-mi--field breakpoint 'number)))
(error "Not recognized as break/watchpoint line")))))
(defun gdb-goto-breakpoint (&optional event)
@@ -3979,16 +4150,14 @@ DOC is an optional documentation string."
(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)))
+ (let ((bptno (gdb-mi--field breakpoint 'number))
+ (file (gdb-mi--field breakpoint 'fullname))
+ (line (gdb-mi--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)
+ (window (gdb-display-source-buffer buffer)))
(with-current-buffer buffer
(goto-char (point-min))
(forward-line (1- (string-to-number line)))
@@ -4014,28 +4183,28 @@ DOC is an optional documentation string."
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 ((file (gdb-mi--field frame 'file))
+ (line (gdb-mi--field frame 'line))
+ (from (gdb-mi--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))
+ (let ((stack (gdb-mi--field (gdb-mi--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)
+ (gdb-mi--field frame 'level)
"in"
(concat
- (bindat-get-field frame 'func)
+ (gdb-mi--field frame 'func)
(if gdb-stack-buffer-locations
(gdb-frame-location frame) "")
(if gdb-stack-buffer-addresses
- (concat " at " (bindat-get-field frame 'addr)) "")))
+ (concat " at " (gdb-mi--field frame 'addr)) "")))
`(mouse-face highlight
help-echo "mouse-2, RET: Select frame"
gdb-frame ,frame)))
@@ -4084,8 +4253,7 @@ member."
(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))
+ (setq-local font-lock-defaults '(gdb-frames-font-lock-keywords))
'gdb-invalidate-frames)
(defun gdb-select-frame (&optional event)
@@ -4095,7 +4263,7 @@ member."
(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)))
+ (let ((new-level (gdb-mi--field frame 'level)))
(setq gdb-frame-number new-level)
(gdb-input (concat "-stack-select-frame " new-level)
'ignore)
@@ -4141,7 +4309,7 @@ member."
(save-excursion
(if event (posn-set-point (event-end event)))
(beginning-of-line)
- (let* ((var (bindat-get-field
+ (let* ((var (gdb-mi--field
(get-text-property (point) 'gdb-local-variable) 'name))
(value (read-string (format "New value (%s): " var))))
(gud-basic-call
@@ -4150,12 +4318,12 @@ member."
;; Don't 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))
+ (let ((locals-list (gdb-mi--field (gdb-mi--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)))
+ (let ((name (gdb-mi--field local 'name))
+ (value (gdb-mi--field local 'value))
+ (type (gdb-mi--field local 'type)))
(when (not value)
(setq value "<complex data type>"))
(if (or (not value)
@@ -4181,7 +4349,7 @@ member."
(setq mode-name
(gdb-current-context-mode-name
(concat "Locals: "
- (bindat-get-field (gdb-current-buffer-frame) 'func))))))
+ (gdb-mi--field (gdb-current-buffer-frame) 'func))))))
(defvar gdb-locals-header
(list
@@ -4244,27 +4412,57 @@ member."
'gdb-registers-mode
'gdb-invalidate-registers)
+(defun gdb-header-click-event-handler (function)
+ "Return a function that handles clicking event on gdb header buttons.
+
+This function switches to the window where the header locates and
+executes FUNCTION."
+ (lambda (event)
+ (interactive "e")
+ (save-selected-window
+ ;; Make sure we are in the right buffer.
+ (select-window (posn-window (event-start event)))
+ (funcall function))))
+
+(defun gdb-registers-toggle-filter ()
+ "Toggle register filter."
+ (interactive)
+ (setq gdb-registers-enable-filter
+ (not gdb-registers-enable-filter))
+ ;; Update the register buffer.
+ (gdb-invalidate-registers 'update))
+
(defun gdb-registers-handler-custom ()
(when gdb-register-names
(let ((register-values
- (bindat-get-field (gdb-json-partial-output) 'register-values))
+ (gdb-mi--field (gdb-mi--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))
+ (let* ((register-number (gdb-mi--field register 'number))
+ (value (gdb-mi--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))))
+ ;; Add register if `gdb-registers-filter-pattern-list' is nil;
+ ;; or any pattern that `gdb-registers-filter-pattern-list'
+ ;; matches.
+ (when (or (null gdb-registers-enable-filter)
+ ;; Return t if any register name matches a pattern.
+ (cl-loop for pattern
+ in gdb-registers-filter-pattern-list
+ if (string-match pattern register-name)
+ return t
+ finally return nil))
+ (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"))))
@@ -4275,8 +4473,7 @@ member."
(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)))
+ (let* ((var (get-text-property (point) 'gdb-register-name))
(value (read-string (format "New value (%s): " var))))
(gud-basic-call
(concat "-gdb-set variable $" var " = " value)))))
@@ -4293,6 +4490,7 @@ member."
(gdb-get-buffer-create
'gdb-locals-buffer
gdb-thread-number) t)))
+ (define-key map "f" #'gdb-registers-toggle-filter)
map))
(defvar gdb-registers-header
@@ -4302,7 +4500,31 @@ member."
mode-line-inactive)
" "
(gdb-propertize-header "Registers" gdb-registers-buffer
- nil nil mode-line)))
+ nil nil mode-line)
+ " "
+ '(:eval
+ (format
+ "[filter %s %s]"
+ (propertize
+ (if gdb-registers-enable-filter "[on]" "[off]")
+ 'face (if gdb-registers-enable-filter
+ '(:weight bold :inherit success)
+ 'shadow)
+ 'help-echo "mouse-1: toggle filter"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1 (gdb-header-click-event-handler
+ #'gdb-registers-toggle-filter)))
+ (propertize
+ "[set]"
+ 'face 'mode-line
+ 'help-echo "mouse-1: Customize filter patterns"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1 (lambda ()
+ (interactive)
+ (customize-variable-other-window
+ 'gdb-registers-filter-pattern-list))))))))
(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers"
"Major mode for gdb registers."
@@ -4338,7 +4560,7 @@ member."
(defun gdb-changed-registers-handler ()
(setq gdb-changed-registers nil)
(dolist (register-number
- (bindat-get-field (gdb-json-partial-output) 'changed-registers))
+ (gdb-mi--field (gdb-mi--partial-output) 'changed-registers))
(push register-number gdb-changed-registers)))
(defun gdb-register-names-handler ()
@@ -4346,7 +4568,7 @@ member."
;; only once (in gdb-init-1)
(setq gdb-register-names nil)
(dolist (register-name
- (bindat-get-field (gdb-json-partial-output) 'register-names))
+ (gdb-mi--field (gdb-mi--partial-output) 'register-names))
(push register-name gdb-register-names))
(setq gdb-register-names (reverse gdb-register-names)))
@@ -4357,7 +4579,8 @@ 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 (read (match-string 1)) gdb-source-file-list))
+ (push (gdb-mi--c-string-from-string (match-string 1))
+ gdb-source-file-list))
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (member buffer-file-name gdb-source-file-list)
@@ -4373,13 +4596,13 @@ Called from `gdb-update'."
(defun gdb-frame-handler ()
"Set `gdb-selected-frame' and `gdb-selected-file' to show
overlay arrow in source buffer."
- (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame)))
+ (let ((frame (gdb-mi--field (gdb-mi--partial-output) 'frame)))
(when frame
- (setq gdb-selected-frame (bindat-get-field frame 'func))
- (setq gdb-selected-file (file-local-name (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-frame (gdb-mi--field frame 'func))
+ (setq gdb-selected-file (file-local-name (gdb-mi--field frame 'fullname)))
+ (setq gdb-frame-number (gdb-mi--field frame 'level))
+ (setq gdb-frame-address (gdb-mi--field frame 'addr))
+ (let ((line (gdb-mi--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))
@@ -4404,7 +4627,7 @@ overlay arrow in source buffer."
(goto-char (point-min))
(setq gdb-prompt-name nil)
(re-search-forward gdb-prompt-name-regexp nil t)
- (setq gdb-prompt-name (read (match-string 1)))
+ (setq gdb-prompt-name (gdb-mi--c-string-from-string (match-string 1)))
;; Insert first prompt.
(setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
@@ -4441,17 +4664,17 @@ SPLIT-HORIZONTAL and show BUF in the new window."
(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)))))))
+ (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)))))))
+ (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)
@@ -4464,6 +4687,26 @@ SPLIT-HORIZONTAL and show BUF in the new window."
(define-key gud-menu-map [displays]
`(menu-item "GDB-Windows" ,menu
:visible (eq gud-minor-mode 'gdbmi)))
+ (define-key menu [gdb-restore-windows]
+ '(menu-item "Restore Initial Layout" gdb-restore-windows
+ :help "Restore the initial GDB window layout."))
+ ;; Window layout vs window configuration: We use "window layout" in
+ ;; GDB UI. Internally we refer to "window configuration" because
+ ;; that's the data structure used to store window layouts. Though
+ ;; bare in mind that there is a small difference between what we
+ ;; store and what normal window configuration functions
+ ;; output. Because GDB buffers (source, local, breakpoint, etc) are
+ ;; different between each debugging sessions, simply save/load
+ ;; window configurations doesn't
+ ;; work. `gdb-save-window-configuration' and
+ ;; `gdb-load-window-configuration' do some tricks to store and
+ ;; recreate each buffer in the layout.
+ (define-key menu [load-layout] '("Load Layout" "Load GDB window configuration (layout) from a file" . gdb-load-window-configuration))
+ (define-key menu [save-layout] '("Save Layout" "Save current GDB window configuration (layout) to a file" . gdb-save-window-configuration))
+ (define-key menu [restore-layout-after-quit]
+ '(menu-item "Restore Layout After Quit" gdb-toggle-restore-window-configuration
+ :button (:toggle . gdb-restore-window-configuration-after-quit)
+ :help "Toggle between always restore the window configuration (layout) after GDB quits and never restore.\n You can also change this setting in Customize to conditionally restore."))
(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))
@@ -4496,44 +4739,41 @@ SPLIT-HORIZONTAL and show BUF in the new window."
(let ((menu (make-sparse-keymap "GDB-MI")))
(define-key menu [gdb-customize]
- '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb))
+ `(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))
+ `(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))
+ `(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))))
+ `(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"))
+ (menu-bar-make-toggle-command
+ 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))))
@@ -4579,41 +4819,173 @@ window is dedicated."
(set-window-buffer window (get-buffer name))
(set-window-dedicated-p window t))
+(defun gdb-toggle-restore-window-configuration ()
+ "Toggle whether to restore window configuration when GDB quits."
+ (interactive)
+ (setq gdb-restore-window-configuration-after-quit
+ (not gdb-restore-window-configuration-after-quit)))
+
+(defun gdb-get-source-buffer ()
+ "Return a buffer displaying source file or nil if we can't find one.
+The source file is the file that contains the source location
+where GDB stops. There could be multiple source files during a
+debugging session, we get the most recently showed one. If
+program hasn't started running yet, the source file is the \"main
+file\" where the GDB session starts (see `gdb-main-file')."
+ (if gud-last-last-frame
+ (gud-find-file (car gud-last-last-frame))
+ (when gdb-main-file
+ (gud-find-file gdb-main-file))))
+
(defun gdb-setup-windows ()
- "Layout the window pattern for option `gdb-many-windows'."
- (gdb-get-buffer-create 'gdb-locals-buffer)
- (gdb-get-buffer-create 'gdb-stack-buffer)
- (gdb-get-buffer-create 'gdb-breakpoints-buffer)
- (set-window-dedicated-p (selected-window) nil)
- (switch-to-buffer gud-comint-buffer)
- (delete-other-windows)
- (let ((win0 (selected-window))
- (win1 (split-window nil ( / ( * (window-height) 3) 4)))
- (win2 (split-window nil ( / (window-height) 3)))
- (win3 (split-window-right)))
- (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3)
- (select-window win2)
- (set-window-buffer
- win2
- (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))
- (let ((win4 (split-window-right)))
- (gdb-set-window-buffer
- (gdb-get-buffer-create 'gdb-inferior-io) nil win4))
- (select-window win1)
- (gdb-set-window-buffer (gdb-stack-buffer-name))
- (let ((win5 (split-window-right)))
- (gdb-set-window-buffer (if gdb-show-threads-by-default
- (gdb-threads-buffer-name)
- (gdb-breakpoints-buffer-name))
- nil win5))
- (select-window win0)))
+ "Lay out the window pattern for option `gdb-many-windows'."
+ (if gdb-default-window-configuration-file
+ (gdb-load-window-configuration
+ (if (file-name-absolute-p gdb-default-window-configuration-file)
+ gdb-default-window-configuration-file
+ (expand-file-name gdb-default-window-configuration-file
+ gdb-window-configuration-directory)))
+ ;; Create default layout as before.
+ (gdb-get-buffer-create 'gdb-locals-buffer)
+ (gdb-get-buffer-create 'gdb-stack-buffer)
+ (gdb-get-buffer-create 'gdb-breakpoints-buffer)
+ (set-window-dedicated-p (selected-window) nil)
+ (switch-to-buffer gud-comint-buffer)
+ (delete-other-windows)
+ (let ((win0 (selected-window))
+ (win1 (split-window nil ( / ( * (window-height) 3) 4)))
+ (win2 (split-window nil ( / (window-height) 3)))
+ (win3 (split-window-right)))
+ (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3)
+ (select-window win2)
+ (set-window-buffer win2 (or (gdb-get-source-buffer)
+ (list-buffers-noselect)))
+ (setq gdb-source-window-list (list (selected-window)))
+ (let ((win4 (split-window-right)))
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io) nil win4))
+ (select-window win1)
+ (gdb-set-window-buffer (gdb-stack-buffer-name))
+ (let ((win5 (split-window-right)))
+ (gdb-set-window-buffer (if gdb-show-threads-by-default
+ (gdb-threads-buffer-name)
+ (gdb-breakpoints-buffer-name))
+ nil win5))
+ (select-window win0))))
+
+(defun gdb-buffer-p (buffer)
+ "Return t if BUFFER is GDB-related."
+ (with-current-buffer buffer
+ (eq gud-minor-mode 'gdbmi)))
+
+(defun gdb-function-buffer-p (buffer)
+ "Return t if BUFFER is a GDB function buffer.
+
+Function buffers are locals buffer, registers buffer, etc, but
+not including main command buffer (the one where you type GDB
+commands) or source buffers (that display program source code)."
+ (with-current-buffer buffer
+ (derived-mode-p 'gdb-parent-mode 'gdb-inferior-io-mode)))
+
+(defun gdb--buffer-type (buffer)
+ "Return the type of BUFFER if it is a function buffer.
+Buffer type is like `gdb-registers-type', `gdb-stack-buffer'.
+These symbols are used by `gdb-get-buffer-create'.
+
+Return nil if BUFFER is not a GDB function buffer."
+ (with-current-buffer buffer
+ (cl-loop for rule in gdb-buffer-rules
+ for mode-name = (gdb-rules-buffer-mode rule)
+ for type = (car rule)
+ if (eq mode-name major-mode)
+ return type
+ finally return nil)))
+
+(defun gdb-save-window-configuration (file)
+ "Save current window configuration (layout) to FILE.
+You can later restore this configuration from that file by
+`gdb-load-window-configuration'."
+ (interactive (list (read-file-name
+ "Save window configuration to file: "
+ (or gdb-window-configuration-directory
+ default-directory))))
+ ;; We replace the buffer in each window with a placeholder, store
+ ;; the buffer type (register, breakpoint, etc) in window parameters,
+ ;; and write the window configuration to the file.
+ (save-window-excursion
+ (let ((placeholder (get-buffer-create " *gdb-placeholder*"))
+ (window-persistent-parameters
+ (cons '(gdb-buffer-type . writable) window-persistent-parameters)))
+ (unwind-protect
+ (dolist (win (window-list nil 'no-minibuffer))
+ (select-window win)
+ (when (gdb-buffer-p (current-buffer))
+ (set-window-parameter
+ nil 'gdb-buffer-type
+ (cond ((gdb-function-buffer-p (current-buffer))
+ ;; 1) If a user arranged the window
+ ;; configuration herself and saves it, windows
+ ;; are probably not dedicated. 2) We use the
+ ;; same dedication flag as in
+ ;; `gdb-display-buffer'.
+ (set-window-dedicated-p nil t)
+ ;; We save this gdb-buffer-type symbol so
+ ;; we can later pass it to `gdb-get-buffer-create';
+ ;; one example: `gdb-registers-buffer'.
+ (or (gdb--buffer-type (current-buffer))
+ (error "Unrecognized gdb buffer mode: %s" major-mode)))
+ ;; Command buffer.
+ ((derived-mode-p 'gud-mode) 'command)
+ ;; Consider everything else as source buffer.
+ (t 'source)))
+ (with-window-non-dedicated nil
+ (set-window-buffer nil placeholder)
+ (set-window-prev-buffers (selected-window) nil)
+ (set-window-next-buffers (selected-window) nil))))
+ ;; Save the window configuration to FILE.
+ (let ((window-config (window-state-get nil t)))
+ (with-temp-buffer
+ (prin1 window-config (current-buffer))
+ (write-file file t)))
+ (kill-buffer placeholder)))))
+
+(defun gdb-load-window-configuration (file)
+ "Restore window configuration (layout) from FILE.
+FILE should be a window configuration file saved by
+`gdb-save-window-configuration'."
+ (interactive (list (read-file-name
+ "Restore window configuration from file: "
+ (or gdb-window-configuration-directory
+ default-directory))))
+ ;; Basically, we restore window configuration and go through each
+ ;; window and restore the function buffers.
+ (let* ((placeholder (get-buffer-create " *gdb-placeholder*")))
+ (unwind-protect ; Don't leak buffer.
+ (let ((window-config (with-temp-buffer
+ (insert-file-contents file)
+ ;; We need to go to point-min because
+ ;; `read' reads from point
+ (goto-char (point-min))
+ (read (current-buffer))))
+ (source-buffer (or (gdb-get-source-buffer)
+ ;; Do the same thing as in
+ ;; `gdb-setup-windows' if no source
+ ;; buffer is found.
+ (list-buffers-noselect)))
+ buffer-type)
+ (window-state-put window-config (frame-root-window))
+ (dolist (window (window-list nil 'no-minibuffer))
+ (with-selected-window window
+ (setq buffer-type (window-parameter nil 'gdb-buffer-type))
+ (pcase buffer-type
+ ('source (when source-buffer
+ (set-window-buffer nil source-buffer)
+ (push (selected-window) gdb-source-window-list)))
+ ('command (switch-to-buffer gud-comint-buffer))
+ (_ (let ((buffer (gdb-get-buffer-create buffer-type)))
+ (with-window-non-dedicated nil
+ (set-window-buffer nil buffer))))))))
+ (kill-buffer placeholder))))
(define-minor-mode gdb-many-windows
"If nil just pop up the GUD buffer unless `gdb-show-main' is t.
@@ -4631,7 +5003,12 @@ of the debugged program. Non-nil means display the layout shown for
(defun gdb-restore-windows ()
"Restore the basic arrangement of windows used by gdb.
-This arrangement depends on the value of option `gdb-many-windows'."
+This arrangement depends on the values of variable
+`gdb-many-windows' and `gdb-default-window-configuration-file'."
+ ;; This function is used when the user messed up window
+ ;; configuration and wants to "reset to default". The function that
+ ;; sets up window configuration on start up is
+ ;; `gdb-get-source-file'.
(interactive)
(switch-to-buffer gud-comint-buffer) ;Select the right window and frame.
(delete-other-windows)
@@ -4644,7 +5021,7 @@ This arrangement depends on the value of option `gdb-many-windows'."
(if gud-last-last-frame
(gud-find-file (car gud-last-last-frame))
(gud-find-file gdb-main-file)))
- (setq gdb-source-window win)))))
+ (setq gdb-source-window-list (list win))))))
;; Called from `gud-sentinel' in gud.el:
(defun gdb-reset ()
@@ -4678,14 +5055,28 @@ Kills the gdb buffers, and resets variables and the source buffers."
(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))
+ (remove-hook 'after-save-hook 'gdb-create-define-alist t)
+ ;; Recover window configuration.
+ (when (or (eq gdb-restore-window-configuration-after-quit t)
+ (and (eq gdb-restore-window-configuration-after-quit
+ 'if-gdb-show-main)
+ gdb-show-main)
+ (and (eq gdb-restore-window-configuration-after-quit
+ 'if-gdb-many-windows)
+ gdb-many-windows))
+ (when gdb--window-configuration-before
+ (window-state-put gdb--window-configuration-before)
+ ;; This way we don't accidentally restore an outdated window
+ ;; configuration.
+ (setq gdb--window-configuration-before nil))))
(defun gdb-get-source-file ()
"Find the source file where the program starts and display it with related
buffers, if required."
+ ;; This function is called only once on startup.
(goto-char (point-min))
(if (re-search-forward gdb-source-file-regexp nil t)
- (setq gdb-main-file (read (match-string 1))))
+ (setq gdb-main-file (gdb-mi--c-string-from-string (match-string 1))))
(if gdb-many-windows
(gdb-setup-windows)
(gdb-get-buffer-create 'gdb-breakpoints-buffer)
diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el
index dbbc2269fc9..cd92175bd61 100644
--- a/lisp/progmodes/glasses.el
+++ b/lisp/progmodes/glasses.el
@@ -1,4 +1,4 @@
-;;; glasses.el --- make cantReadThis readable
+;;; glasses.el --- make cantReadThis readable -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -66,7 +66,6 @@ defined by `glasses-original-separator'. If you don't want to add missing
separators, set `glasses-separator' to an empty string. If you don't want to
replace existent separators, set `glasses-original-separator' to an empty
string."
- :group 'glasses
:type 'string
:set 'glasses-custom-set
:initialize 'custom-initialize-default)
@@ -78,7 +77,6 @@ For instance, if you set it to \"_\" and set `glasses-separator' to \"-\",
underscore separators are displayed as hyphens.
If `glasses-original-separator' is an empty string, no such display change is
performed."
- :group 'glasses
:type 'string
:set 'glasses-custom-set
:initialize 'custom-initialize-default
@@ -92,7 +90,6 @@ If it is nil, no face is placed at the capitalized letter.
For example, you can set `glasses-separator' to an empty string and
`glasses-face' to `bold'. Then unreadable identifiers will have no separators,
but will have their capitals in bold."
- :group 'glasses
:type '(choice (const :tag "None" nil) face)
:set 'glasses-custom-set
:initialize 'custom-initialize-default)
@@ -100,7 +97,6 @@ but will have their capitals in bold."
(defcustom glasses-separate-parentheses-p t
"If non-nil, ensure space between an identifier and an opening parenthesis."
- :group 'glasses
:type 'boolean)
(defcustom glasses-separate-parentheses-exceptions
@@ -108,7 +104,6 @@ but will have their capitals in bold."
"List of regexp that are exceptions for `glasses-separate-parentheses-p'.
They are matched to the current line truncated to the point where the
parenthesis expression starts."
- :group 'glasses
:type '(repeat regexp))
(defcustom glasses-separate-capital-groups t
@@ -116,7 +111,6 @@ parenthesis expression starts."
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")
@@ -124,7 +118,6 @@ if you prefer to display them unchanged."
"If non-nil, downcase embedded capital letters in identifiers.
Only identifiers starting with lower case letters are affected, letters inside
other identifiers are unchanged."
- :group 'glasses
:type 'boolean
:set 'glasses-custom-set
:initialize 'custom-initialize-default)
@@ -135,7 +128,6 @@ other identifiers are unchanged."
Only words starting with this regexp are uncapitalized.
The regexp is case sensitive.
It has any effect only when `glasses-uncapitalize-p' is non-nil."
- :group 'glasses
:type 'regexp
:set 'glasses-custom-set
:initialize 'custom-initialize-default)
@@ -149,7 +141,6 @@ file write then.
Note the removal action does not try to be much clever, so it can remove real
separators too."
- :group 'glasses
:type 'boolean)
@@ -330,10 +321,6 @@ separators (like underscores) at places they belong to."
(remove-hook 'write-file-functions
'glasses-convert-to-unreadable t)))))
-
-;;; Announce
-
(provide 'glasses)
-
;;; glasses.el ends here
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index d49534f8bb0..8f0a5acf708 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -64,8 +64,7 @@ SYMBOL should be one of `grep-command', `grep-template',
"Number of lines in a grep window. If nil, use `compilation-window-height'."
:type '(choice (const :tag "Default" nil)
integer)
- :version "22.1"
- :group 'grep)
+ :version "22.1")
(defcustom grep-highlight-matches 'auto-detect
"Use special markers to highlight grep matches.
@@ -80,7 +79,7 @@ This option sets the environment variable GREP_COLORS to specify
markers for highlighting and adds the --color option in front of
any explicit grep options before starting the grep.
-When this option is `auto', grep uses `--color' to highlight
+When this option is `auto', grep uses `--color=auto' to highlight
matches only when it outputs to a terminal (when `grep' is the last
command in the pipe), thus avoiding the use of any potentially-harmful
escape sequences when standard output goes to a file or pipe.
@@ -89,18 +88,24 @@ To make grep highlight matches even into a pipe, you need the option
`always' that forces grep to use `--color=always' to unconditionally
output escape sequences.
-In interactive usage, the actual value of this variable is set up
-by `grep-compute-defaults' when the default value is `auto-detect'.
-To change the default value, use \\[customize] or call the function
+If the value is `auto-detect' (the default), `grep' will call
+`grep-compute-defaults' to compute the value. To change the
+default value, use \\[customize] or call the function
`grep-apply-setting'."
:type '(choice (const :tag "Do not highlight matches with grep markers" nil)
(const :tag "Highlight matches with grep markers" t)
(const :tag "Use --color=always" always)
- (const :tag "Use --color" auto)
+ (const :tag "Use --color=auto" auto)
(other :tag "Not Set" auto-detect))
- :set 'grep-apply-setting
- :version "22.1"
- :group 'grep)
+ :set #'grep-apply-setting
+ :version "22.1")
+
+(defcustom grep-match-regexp "\033\\[\\(?:0?1;\\)?31m\\(.*?\\)\033\\[[0-9]*m"
+ "Regular expression matching grep markers to highlight.
+It matches SGR ANSI escape sequences which are emitted by grep to
+color its output. This variable is used in `grep-filter'."
+ :type 'regexp
+ :version "28.1")
(defcustom grep-scroll-output nil
"Non-nil to scroll the *grep* buffer window as output appears.
@@ -109,8 +114,7 @@ Setting it causes the grep commands to put point at the end of their
output window so that the end of the output is always visible rather
than the beginning."
:type 'boolean
- :version "22.1"
- :group 'grep)
+ :version "22.1")
;;;###autoload
(defcustom grep-command nil
@@ -124,8 +128,7 @@ by `grep-compute-defaults'; to change the default value, use
\\[customize] or call the function `grep-apply-setting'."
:type '(choice string
(const :tag "Not Set" nil))
- :set 'grep-apply-setting
- :group 'grep)
+ :set #'grep-apply-setting)
(defcustom grep-template nil
"The default command to run for \\[lgrep].
@@ -141,9 +144,8 @@ by `grep-compute-defaults'; to change the default value, use
\\[customize] or call the function `grep-apply-setting'."
:type '(choice string
(const :tag "Not Set" nil))
- :set 'grep-apply-setting
- :version "22.1"
- :group 'grep)
+ :set #'grep-apply-setting
+ :version "22.1")
(defcustom grep-use-null-device 'auto-detect
"If t, append the value of `null-device' to `grep' commands.
@@ -157,8 +159,7 @@ by `grep-compute-defaults'; to change the default value, use
:type '(choice (const :tag "Do Not Append Null Device" nil)
(const :tag "Append Null Device" t)
(other :tag "Not Set" auto-detect))
- :set 'grep-apply-setting
- :group 'grep)
+ :set #'grep-apply-setting)
(defcustom grep-use-null-filename-separator 'auto-detect
"If non-nil, use `grep's `--null' option.
@@ -167,19 +168,23 @@ This is done to disambiguate file names in `grep's output."
:type '(choice (const :tag "Do Not Use `--null'" nil)
(const :tag "Use `--null'" t)
(other :tag "Not Set" auto-detect))
- :set 'grep-apply-setting
- :group 'grep)
+ :set #'grep-apply-setting)
;;;###autoload
(defcustom grep-find-command nil
"The default find command for \\[grep-find].
In interactive usage, the actual value of this variable is set up
by `grep-compute-defaults'; to change the default value, use
-\\[customize] or call the function `grep-apply-setting'."
+\\[customize] or call the function `grep-apply-setting'.
+
+This variable can either be a string, or a cons of the
+form (COMMAND . POSITION). In the latter case, COMMAND will be
+used as the default command, and point will be placed at POSITION
+for easier editing."
:type '(choice string
+ (cons string integer)
(const :tag "Not Set" nil))
- :set 'grep-apply-setting
- :group 'grep)
+ :set #'grep-apply-setting)
(defcustom grep-find-template nil
"The default command to run for \\[rgrep].
@@ -194,9 +199,8 @@ by `grep-compute-defaults'; to change the default value, use
\\[customize] or call the function `grep-apply-setting'."
:type '(choice string
(const :tag "Not Set" nil))
- :set 'grep-apply-setting
- :version "22.1"
- :group 'grep)
+ :set #'grep-apply-setting
+ :version "22.1")
(defcustom grep-files-aliases
'(("all" . "* .[!.]* ..?*") ;; Don't match `..'. See bug#22577
@@ -213,8 +217,7 @@ by `grep-compute-defaults'; to change the default value, use
("texi" . "*.texi")
("asm" . "*.[sS]"))
"Alist of aliases for the FILES argument to `lgrep' and `rgrep'."
- :type 'alist
- :group 'grep)
+ :type 'alist)
(defcustom grep-find-ignored-directories vc-directory-exclusion-list
"List of names of sub-directories which `rgrep' shall not recurse into.
@@ -223,8 +226,7 @@ to determine whether cdr should not be recursed into.
The default value is inherited from `vc-directory-exclusion-list'."
:type '(choice (repeat :tag "Ignored directories" string)
- (const :tag "No ignored directories" nil))
- :group 'grep)
+ (const :tag "No ignored directories" nil)))
(defcustom grep-find-ignored-files
(cons ".#*" (delq nil (mapcar (lambda (s)
@@ -235,8 +237,7 @@ The default value is inherited from `vc-directory-exclusion-list'."
If an element is a cons cell, the car is called on the search directory
to determine whether cdr should not be excluded."
:type '(choice (repeat :tag "Ignored file" string)
- (const :tag "No ignored files" nil))
- :group 'grep)
+ (const :tag "No ignored files" nil)))
(defcustom grep-save-buffers 'ask
"If non-nil, save buffers before running the grep commands.
@@ -251,22 +252,19 @@ to limit saving to files located under `my-grep-root'."
(const :tag "Ask before saving" ask)
(const :tag "Don't save buffers" nil)
function
- (other :tag "Save all buffers" t))
- :group 'grep)
+ (other :tag "Save all buffers" t)))
(defcustom grep-error-screen-columns nil
"If non-nil, column numbers in grep hits are screen columns.
See `compilation-error-screen-columns'."
:type '(choice (const :tag "Default" nil)
integer)
- :version "22.1"
- :group 'grep)
+ :version "22.1")
;;;###autoload
(defcustom grep-setup-hook nil
"List of hook functions run by `grep-process-setup' (see `run-hooks')."
- :type 'hook
- :group 'grep)
+ :type 'hook)
(defvar grep-mode-map
(let ((map (make-sparse-keymap)))
@@ -277,63 +275,51 @@ See `compilation-error-screen-columns'."
(define-key map "\C-c\C-f" 'next-error-follow-minor-mode)
(define-key map "\r" 'compile-goto-error) ;; ?
- (define-key map "n" 'next-error-no-select)
- (define-key map "p" 'previous-error-no-select)
(define-key map "{" 'compilation-previous-file)
(define-key map "}" 'compilation-next-file)
(define-key map "\t" 'compilation-next-error)
(define-key map [backtab] 'compilation-previous-error)
-
- ;; Set up the menu-bar
- (define-key map [menu-bar grep]
- (cons "Grep" (make-sparse-keymap "Grep")))
-
- (define-key map [menu-bar grep grep-find-toggle-abbreviation]
- '(menu-item "Toggle command abbreviation"
- grep-find-toggle-abbreviation
- :help "Toggle showing verbose command options"))
- (define-key map [menu-bar grep compilation-separator3] '("----"))
- (define-key map [menu-bar grep compilation-kill-compilation]
- '(menu-item "Kill Grep" kill-compilation
- :help "Kill the currently running grep process"))
- (define-key map [menu-bar grep compilation-separator2] '("----"))
- (define-key map [menu-bar grep compilation-compile]
- '(menu-item "Compile..." compile
- :help "Compile the program including the current buffer. Default: run `make'"))
- (define-key map [menu-bar grep compilation-rgrep]
- '(menu-item "Recursive grep..." rgrep
- :help "User-friendly recursive grep in directory tree"))
- (define-key map [menu-bar grep compilation-lgrep]
- '(menu-item "Local grep..." lgrep
- :help "User-friendly grep in a directory"))
- (define-key map [menu-bar grep compilation-grep-find]
- '(menu-item "Grep via Find..." grep-find
- :help "Run grep via find, with user-specified args"))
- (define-key map [menu-bar grep compilation-grep]
- '(menu-item "Another grep..." grep
- :help "Run grep, with user-specified args, and collect output in a buffer."))
- (define-key map [menu-bar grep compilation-recompile]
- '(menu-item "Repeat grep" recompile
- :help "Run grep again"))
- (define-key map [menu-bar grep compilation-separator1] '("----"))
- (define-key map [menu-bar grep compilation-first-error]
- '(menu-item "First Match" first-error
- :help "Restart at the first match, visit corresponding location"))
- (define-key map [menu-bar grep compilation-previous-error]
- '(menu-item "Previous Match" previous-error
- :help "Visit the previous match and corresponding location"))
- (define-key map [menu-bar grep compilation-next-error]
- '(menu-item "Next Match" next-error
- :help "Visit the next match and corresponding location"))
map)
"Keymap for grep buffers.
`compilation-minor-mode-map' is a cdr of this.")
+(easy-menu-define grep-menu-map grep-mode-map
+ "Menu for grep buffers."
+ '("Grep"
+ ["Next Match" next-error
+ :help "Visit the next match and corresponding location"]
+ ["Previous Match" previous-error
+ :help "Visit the previous match and corresponding location"]
+ ["First Match" first-error
+ :help "Restart at the first match, visit corresponding location"]
+ "----"
+ ["Repeat grep" recompile
+ :help "Run grep again"]
+ ["Another grep..." grep
+ :help "Run grep, with user-specified args, and collect output in a buffer."]
+ ["Grep via Find..." grep-find
+ :help "Run grep via find, with user-specified args"]
+ ["Local grep..." lgrep
+ :help "User-friendly grep in a directory"]
+ ["Recursive grep..." rgrep
+ :help "User-friendly recursive grep in directory tree"]
+ ["Compile..." compile
+ :help "Compile the program including the current buffer. Default: run `make'"]
+ "----"
+ ["Kill Grep" kill-compilation
+ :help "Kill the currently running grep process"]
+ "----"
+ ["Toggle command abbreviation" grep-find-toggle-abbreviation
+ :help "Toggle showing verbose command options"]))
+
(defvar grep-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))
+ ;; We have to `copy-keymap' rather than use keymap inheritance because
+ ;; we want to put the new items at the *end* of the tool-bar.
(let ((map (butlast (copy-keymap tool-bar-map)))
+ ;; FIXME: Nowadays the last button is not "help" but "search"!
(help (last tool-bar-map))) ;; Keep Help last in tool bar
(tool-bar-local-item
"left-arrow" 'previous-error-no-select 'previous-error-no-select map
@@ -388,7 +374,8 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
(when grep-highlight-matches
(let* ((beg (match-end 0))
(end (save-excursion (goto-char beg) (line-end-position)))
- (mbeg (text-property-any beg end 'font-lock-face grep-match-face)))
+ (mbeg
+ (text-property-any beg end 'font-lock-face grep-match-face)))
(when mbeg
(- mbeg beg)))))
.
@@ -396,13 +383,16 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
(when grep-highlight-matches
(let* ((beg (match-end 0))
(end (save-excursion (goto-char beg) (line-end-position)))
- (mbeg (text-property-any beg end 'font-lock-face grep-match-face))
- (mend (and mbeg (next-single-property-change mbeg 'font-lock-face nil end))))
+ (mbeg
+ (text-property-any beg end 'font-lock-face grep-match-face))
+ (mend
+ (and mbeg (next-single-property-change
+ mbeg 'font-lock-face nil end))))
(when mend
- (- mend beg))))))
+ (- mend beg 1))))))
nil nil
(3 '(face nil display ":")))
- ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1))
+ ("^Binary file \\(.+\\) matches" 1 nil nil 0 1))
"Regexp used to match grep hits.
See `compilation-error-regexp-alist' for format details.")
@@ -439,15 +429,13 @@ and reveals the entire command line. The visibility of the
abbreviated part can also be toggled with
`grep-find-toggle-abbreviation'."
:type 'boolean
- :version "27.1"
- :group 'grep)
+ :version "27.1")
(defcustom grep-search-path '(nil)
"List of directories to search for files named in grep messages.
Elements should be directory names, not file names of
directories. The value nil as an element means the grep messages
buffer `default-directory'."
- :group 'grep
:version "27.1"
:type '(repeat (choice (const :tag "Default" nil)
(string :tag "Directory"))))
@@ -485,7 +473,7 @@ buffer `default-directory'."
(1 (if (eq (char-after (match-beginning 1)) ?\0)
`(face nil display ,(match-string 2)))))
;; Hide excessive part of rgrep command
- ("^find \\(\\. -type d .*\\\\)\\)"
+ ("^find \\(\\(?:-H \\)?\\. -type d .*\\(?:\\\\)\\|\")\"\\)\\)"
(1 (if grep-find-abbreviate grep-find-abbreviate-properties
'(face nil abbreviated-command t))))
;; Hide excessive part of lgrep command
@@ -528,9 +516,8 @@ This variable's value takes effect when `grep-compute-defaults' is called."
(const :tag "find -print0 | sort -z | xargs -0'" gnu-sort)
string
(const :tag "Not Set" nil))
- :set 'grep-apply-setting
- :version "27.1"
- :group 'grep)
+ :set #'grep-apply-setting
+ :version "27.1")
;; History of grep commands.
;;;###autoload
@@ -561,8 +548,7 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'."
;; GREP_COLORS is used in GNU grep 2.5.2 and later versions
(setenv "GREP_COLORS" "mt=01;31:fn=:ln=:bn=:se=:sl=:cx=:ne"))
(setq-local grep-num-matches-found 0)
- (set (make-local-variable 'compilation-exit-message-function)
- 'grep-exit-message)
+ (setq-local compilation-exit-message-function #'grep-exit-message)
(run-hooks 'grep-setup-hook))
(defun grep-exit-message (status code msg)
@@ -599,7 +585,7 @@ This function is called from `compilation-filter-hook'."
(when (< (point) end)
(setq end (copy-marker end))
;; Highlight grep matches and delete marking sequences.
- (while (re-search-forward "\033\\[0?1;31m\\(.*?\\)\033\\[[0-9]*m" end 1)
+ (while (re-search-forward grep-match-regexp end 1)
(replace-match (propertize (match-string 1)
'face nil 'font-lock-face grep-match-face)
t t)
@@ -612,10 +598,19 @@ This function is called from `compilation-filter-hook'."
(defun grep-probe (command args &optional func result)
(let (process-file-side-effects)
(equal (condition-case nil
- (apply (or func 'process-file) command args)
+ (apply (or func #'process-file) command args)
(error nil))
(or result 0))))
+(defun grep-hello-file ()
+ (let ((result
+ (if (file-remote-p default-directory)
+ (make-temp-file (file-name-as-directory (temporary-file-directory)))
+ (expand-file-name "HELLO" data-directory))))
+ (when (file-remote-p result)
+ (write-region "Copyright\n" nil result))
+ result))
+
;;;###autoload
(defun grep-compute-defaults ()
"Compute the defaults for the `grep' command.
@@ -657,37 +652,46 @@ The value depends on `grep-command', `grep-template',
(unless (or (not grep-use-null-device) (eq grep-use-null-device t))
(setq grep-use-null-device
(with-temp-buffer
- (let ((hello-file (expand-file-name "HELLO" data-directory)))
- (not
- (and (if grep-command
- ;; `grep-command' is already set, so
- ;; use that for testing.
- (grep-probe grep-command
- `(nil t nil "^Copyright" ,hello-file)
- #'call-process-shell-command)
- ;; otherwise use `grep-program'
- (grep-probe grep-program
- `(nil t nil "-nH" "^Copyright" ,hello-file)))
- (progn
- (goto-char (point-min))
- (looking-at
- (concat (regexp-quote hello-file)
- ":[0-9]+:Copyright")))))))))
+ (let ((hello-file (grep-hello-file)))
+ (prog1
+ (not
+ (and (if grep-command
+ ;; `grep-command' is already set, so
+ ;; use that for testing.
+ (grep-probe
+ grep-command
+ `(nil t nil "^Copyright"
+ ,(file-local-name hello-file))
+ #'process-file-shell-command)
+ ;; otherwise use `grep-program'
+ (grep-probe
+ grep-program
+ `(nil t nil "-nH" "^Copyright"
+ ,(file-local-name hello-file))))
+ (progn
+ (goto-char (point-min))
+ (looking-at
+ (concat (regexp-quote (file-local-name hello-file))
+ ":[0-9]+:Copyright")))))
+ (when (file-remote-p hello-file) (delete-file hello-file)))))))
(when (eq grep-use-null-filename-separator 'auto-detect)
(setq grep-use-null-filename-separator
(with-temp-buffer
- (let* ((hello-file (expand-file-name "HELLO" data-directory))
- (args `("--null" "-ne" "^Copyright" ,hello-file)))
+ (let* ((hello-file (grep-hello-file))
+ (args `("--null" "-ne" "^Copyright"
+ ,(file-local-name hello-file))))
(if grep-use-null-device
- (setq args (append args (list null-device)))
+ (setq args (append args (list (null-device))))
(push "-H" args))
- (and (grep-probe grep-program `(nil t nil ,@args))
- (progn
- (goto-char (point-min))
- (looking-at
- (concat (regexp-quote hello-file)
- "\0[0-9]+:Copyright"))))))))
+ (prog1
+ (and (grep-probe grep-program `(nil t nil ,@args))
+ (progn
+ (goto-char (point-min))
+ (looking-at
+ (concat (regexp-quote (file-local-name hello-file))
+ "\0[0-9]+:Copyright"))))
+ (when (file-remote-p hello-file) (delete-file hello-file)))))))
(when (eq grep-highlight-matches 'auto-detect)
(setq grep-highlight-matches
@@ -705,22 +709,23 @@ The value depends on `grep-command', `grep-template',
(let ((grep-options
(concat (if grep-use-null-device "-n" "-nH")
(if grep-use-null-filename-separator " --null")
- (if (grep-probe grep-program
- `(nil nil nil "-e" "foo" ,null-device)
- nil 1)
- " -e"))))
+ (when (grep-probe grep-program
+ `(nil nil nil "-e" "foo" ,(null-device))
+ nil 1)
+ " -e"))))
(unless grep-command
(setq grep-command
(format "%s %s %s " grep-program
(or
(and grep-highlight-matches
- (grep-probe grep-program
- `(nil nil nil "--color" "x" ,null-device)
- nil 1)
+ (grep-probe
+ grep-program
+ `(nil nil nil "--color" "x" ,(null-device))
+ nil 1)
(if (eq grep-highlight-matches 'always)
- "--color=always" "--color"))
+ "--color=always" "--color=auto"))
"")
- grep-options)))
+ grep-options)))
(unless grep-template
(setq grep-template
(format "%s <X> <C> %s <R> <F>" grep-program grep-options)))
@@ -728,11 +733,12 @@ The value depends on `grep-command', `grep-template',
(setq grep-find-use-xargs
(cond
((grep-probe find-program
- `(nil nil nil ,null-device "-exec" "echo"
+ `(nil nil nil ,(null-device) "-exec" "echo"
"{}" "+"))
'exec-plus)
((and
- (grep-probe find-program `(nil nil nil ,null-device "-print0"))
+ (grep-probe
+ find-program `(nil nil nil ,(null-device) "-print0"))
(grep-probe xargs-program '(nil nil nil "-0" "echo")))
'gnu)
(t
@@ -752,12 +758,13 @@ The value depends on `grep-command', `grep-template',
(let ((cmd0 (format "%s . -type f -exec %s"
find-program grep-command))
(null (if grep-use-null-device
- (format "%s " null-device)
+ (format "%s " (null-device))
"")))
(cons
(if (eq grep-find-use-xargs 'exec-plus)
(format "%s %s%s +" cmd0 null quot-braces)
- (format "%s %s %s%s" cmd0 quot-braces null quot-scolon))
+ (format "%s %s %s%s"
+ cmd0 quot-braces null quot-scolon))
(1+ (length cmd0)))))
(t
(format "%s . -type f -print | \"%s\" %s"
@@ -767,25 +774,24 @@ The value depends on `grep-command', `grep-template',
(let ((gcmd (format "%s <C> %s <R>"
grep-program grep-options))
(null (if grep-use-null-device
- (format "%s " null-device)
- "")))
- (cond ((eq grep-find-use-xargs 'gnu)
- (format "%s <D> <X> -type f <F> -print0 | \"%s\" -0 %s"
- find-program xargs-program gcmd))
- ((eq grep-find-use-xargs 'gnu-sort)
- (format "%s <D> <X> -type f <F> -print0 | sort -z | \"%s\" -0 %s"
- find-program xargs-program gcmd))
- ((eq grep-find-use-xargs 'exec)
- (format "%s <D> <X> -type f <F> -exec %s %s %s%s"
- find-program gcmd quot-braces null quot-scolon))
- ((eq grep-find-use-xargs 'exec-plus)
- (format "%s <D> <X> -type f <F> -exec %s %s%s +"
- find-program gcmd null quot-braces))
- (t
- (format "%s <D> <X> -type f <F> -print | \"%s\" %s"
- find-program xargs-program gcmd))))))))
-
- ;; Save defaults for this host.
+ (format "%s " (null-device))
+ "")))
+ (cond ((eq grep-find-use-xargs 'gnu)
+ (format "%s -H <D> <X> -type f <F> -print0 | \"%s\" -0 %s"
+ find-program xargs-program gcmd))
+ ((eq grep-find-use-xargs 'gnu-sort)
+ (format "%s -H <D> <X> -type f <F> -print0 | sort -z | \"%s\" -0 %s"
+ find-program xargs-program gcmd))
+ ((eq grep-find-use-xargs 'exec)
+ (format "%s -H <D> <X> -type f <F> -exec %s %s %s%s"
+ find-program gcmd quot-braces null quot-scolon))
+ ((eq grep-find-use-xargs 'exec-plus)
+ (format "%s -H <D> <X> -type f <F> -exec %s %s%s +"
+ find-program gcmd null quot-braces))
+ (t
+ (format "%s -H <D> <X> -type f <F> -print | \"%s\" %s"
+ find-program xargs-program gcmd))))))))
+ ;; Save defaults for this host.
(setq grep-host-defaults-alist
(delete (assq host-id grep-host-defaults-alist)
grep-host-defaults-alist))
@@ -808,7 +814,7 @@ The value depends on `grep-command', `grep-template',
(buffer-substring-no-properties (point) (mark)))
(funcall (or find-tag-default-function
(get major-mode 'find-tag-default-function)
- 'find-tag-default))
+ #'find-tag-default))
""))
(defun grep-default-command ()
@@ -816,7 +822,8 @@ The value depends on `grep-command', `grep-template',
(let ((tag-default (shell-quote-argument (grep-tag-default)))
;; This a regexp to match single shell arguments.
;; Could someone please add comments explaining it?
- (sh-arg-re "\\(\\(?:\"\\(?:[^\"]\\|\\\\\"\\)+\"\\|'[^']+'\\|[^\"' \t\n]\\)+\\)")
+ (sh-arg-re
+ "\\(\\(?:\"\\(?:[^\"]\\|\\\\\"\\)+\"\\|'[^']+'\\|[^\"' \t\n]\\)+\\)")
(grep-default (or (car grep-history) grep-command)))
;; In the default command, find the arg that specifies the pattern.
(when (or (string-match
@@ -851,23 +858,23 @@ The value depends on `grep-command', `grep-template',
(define-compilation-mode grep-mode "Grep"
"Sets `grep-last-buffer' and `compilation-window-height'."
(setq grep-last-buffer (current-buffer))
- (set (make-local-variable 'tool-bar-map) grep-mode-tool-bar-map)
- (set (make-local-variable 'compilation-error-face)
- grep-hit-face)
- (set (make-local-variable 'compilation-error-regexp-alist)
- grep-regexp-alist)
- (set (make-local-variable 'compilation-mode-line-errors)
- grep-mode-line-matches)
+ (setq-local tool-bar-map grep-mode-tool-bar-map)
+ (setq-local compilation-error-face
+ grep-hit-face)
+ (setq-local compilation-error-regexp-alist
+ grep-regexp-alist)
+ (setq-local compilation-mode-line-errors
+ grep-mode-line-matches)
;; compilation-directory-matcher can't be nil, so we set it to a regexp that
;; can never match.
- (set (make-local-variable 'compilation-directory-matcher)
- (list regexp-unmatchable))
- (set (make-local-variable 'compilation-process-setup-function)
- 'grep-process-setup)
- (set (make-local-variable 'compilation-disable-input) t)
- (set (make-local-variable 'compilation-error-screen-columns)
- grep-error-screen-columns)
- (add-hook 'compilation-filter-hook 'grep-filter nil t))
+ (setq-local compilation-directory-matcher
+ (list regexp-unmatchable))
+ (setq-local compilation-process-setup-function
+ #'grep-process-setup)
+ (setq-local compilation-disable-input t)
+ (setq-local compilation-error-screen-columns
+ grep-error-screen-columns)
+ (add-hook 'compilation-filter-hook #'grep-filter nil t))
(defun grep--save-buffers ()
(when grep-save-buffers
@@ -907,14 +914,17 @@ list is empty)."
(if current-prefix-arg default grep-command)
'grep-history
(if current-prefix-arg nil default))))))
-
+ ;; If called non-interactively, also compute the defaults if we
+ ;; haven't already.
+ (when (eq grep-highlight-matches 'auto-detect)
+ (grep-compute-defaults))
(grep--save-buffers)
;; Setting process-setup-function makes exit-message-function work
;; even when async processes aren't supported.
- (compilation-start (if (and grep-use-null-device null-device)
- (concat command-args " " null-device)
+ (compilation-start (if (and grep-use-null-device null-device (null-device))
+ (concat command-args " " (null-device))
command-args)
- 'grep-mode))
+ #'grep-mode))
;;;###autoload
@@ -950,7 +960,7 @@ easily repeat a find command."
'(("<C>" . (mapconcat #'identity opts " "))
("<D>" . (or dir "."))
("<F>" . files)
- ("<N>" . null-device)
+ ("<N>" . (null-device))
("<X>" . excl)
("<R>" . (shell-quote-argument (or regexp ""))))
"List of substitutions performed by `grep-expand-template'.
@@ -961,10 +971,10 @@ The substitution is based on variables bound dynamically, and
these include `opts', `dir', `files', `null-device', `excl' and
`regexp'.")
-(defun grep-expand-template (template &optional regexp files dir excl)
+(defun grep-expand-template (template &optional regexp files dir excl more-opts)
"Expand grep COMMAND string replacing <C>, <D>, <F>, <R>, and <X>."
(let* ((command template)
- (env `((opts . ,(let (opts)
+ (env `((opts . ,(let ((opts more-opts))
(when (and case-fold-search
(isearch-no-upper-case-p regexp t))
(push "-i" opts))
@@ -972,7 +982,7 @@ these include `opts', `dir', `files', `null-device', `excl' and
((eq grep-highlight-matches 'always)
(push "--color=always" opts))
((eq grep-highlight-matches 'auto)
- (push "--color" opts)))
+ (push "--color=auto" opts)))
opts))
(excl . ,excl)
(dir . ,dir)
@@ -993,23 +1003,31 @@ these include `opts', `dir', `files', `null-device', `excl' and
"Read regexp arg for interactive grep using `read-regexp'."
(read-regexp "Search for" 'grep-tag-default 'grep-regexp-history))
+(defvar grep-read-files-function #'grep-read-files--default)
+
+(defun grep-read-files--default ()
+ ;; Instead of a `grep-read-files-function' variable, we used to lookup
+ ;; mode-specific functions in the major mode's symbol properties, so preserve
+ ;; this behavior for backward compatibility.
+ (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1
+ (if old-function
+ (funcall old-function)
+ (let ((file-name-at-point
+ (run-hook-with-args-until-success 'file-name-at-point-functions)))
+ (or (if (and (stringp file-name-at-point)
+ (not (file-directory-p file-name-at-point)))
+ file-name-at-point)
+ (buffer-file-name)
+ (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name)))))))
+
(defun grep-read-files (regexp)
"Read a file-name pattern arg for interactive grep.
-The pattern can include shell wildcards. As whitespace triggers
+The pattern can include shell wildcards. As SPC can triggers
completion when entering a pattern, including it requires
quoting, e.g. `\\[quoted-insert]<space>'.
REGEXP is used as a string in the prompt."
- (let* ((grep-read-files-function (get major-mode 'grep-read-files))
- (file-name-at-point
- (run-hook-with-args-until-success 'file-name-at-point-functions))
- (bn (if grep-read-files-function
- (funcall grep-read-files-function)
- (or (if (and (stringp file-name-at-point)
- (not (file-directory-p file-name-at-point)))
- file-name-at-point)
- (buffer-file-name)
- (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name)))))
+ (let* ((bn (funcall grep-read-files-function))
(fn (and bn
(stringp bn)
(file-name-nondirectory bn)))
@@ -1022,7 +1040,7 @@ REGEXP is used as a string in the prompt."
(setq alias (car aliases)
aliases (cdr aliases))
(if (string-match (mapconcat
- 'wildcard-to-regexp
+ #'wildcard-to-regexp
(split-string (cdr alias) nil t)
"\\|")
fn)
@@ -1043,15 +1061,18 @@ REGEXP is used as a string in the prompt."
"\" in files matching wildcard"
(if default (concat " (default " default ")"))
": ")
- 'read-file-name-internal
+ #'read-file-name-internal
nil nil nil 'grep-files-history
(delete-dups
- (delq nil (append (list default default-alias default-extension)
- (mapcar 'car grep-files-aliases)))))))
+ (delq nil
+ (append (list default default-alias default-extension)
+ (mapcar #'car grep-files-aliases)))))))
(and files
(or (cdr (assoc files grep-files-aliases))
files))))
+(defvar grep-use-directories-skip 'auto-detect)
+
;;;###autoload
(defun lgrep (regexp &optional files dir confirm)
"Run grep, searching for REGEXP in FILES in directory DIR.
@@ -1097,6 +1118,13 @@ command before it's run."
(if (string= command grep-command)
(setq command nil))
(setq dir (file-name-as-directory (expand-file-name dir)))
+ (unless (or (not grep-use-directories-skip)
+ (eq grep-use-directories-skip t))
+ (setq grep-use-directories-skip
+ (grep-probe grep-program
+ `(nil nil nil "--directories=skip" "foo"
+ ,(null-device))
+ nil 1)))
(setq command (grep-expand-template
grep-template
regexp
@@ -1105,15 +1133,17 @@ command before it's run."
(and grep-find-ignored-files
(concat " --exclude="
(mapconcat
- #'(lambda (ignore)
- (cond ((stringp ignore)
- (shell-quote-argument ignore))
- ((consp ignore)
- (and (funcall (car ignore) dir)
- (shell-quote-argument
- (cdr ignore))))))
+ (lambda (ignore)
+ (cond ((stringp ignore)
+ (shell-quote-argument ignore))
+ ((consp ignore)
+ (and (funcall (car ignore) dir)
+ (shell-quote-argument
+ (cdr ignore))))))
grep-find-ignored-files
- " --exclude=")))))
+ " --exclude=")))
+ (and (eq grep-use-directories-skip t)
+ '("--directories=skip"))))
(when command
(if confirm
(setq command
@@ -1125,10 +1155,11 @@ command before it's run."
;; Setting process-setup-function makes exit-message-function work
;; even when async processes aren't supported.
(grep--save-buffers)
- (compilation-start (if (and grep-use-null-device null-device)
- (concat command " " null-device)
- command)
- 'grep-mode))
+ (compilation-start
+ (if (and grep-use-null-device null-device (null-device))
+ (concat command " " (null-device))
+ command)
+ 'grep-mode))
;; Set default-directory if we started lgrep in the *grep* buffer.
(if (eq next-error-last-buffer (current-buffer))
(setq default-directory dir))))))
@@ -1242,13 +1273,13 @@ command before it's run."
;; we should use shell-quote-argument here
" -name "
(mapconcat
- #'(lambda (ignore)
- (cond ((stringp ignore)
- (shell-quote-argument ignore))
- ((consp ignore)
- (and (funcall (car ignore) dir)
- (shell-quote-argument
- (cdr ignore))))))
+ (lambda (ignore)
+ (cond ((stringp ignore)
+ (shell-quote-argument ignore))
+ ((consp ignore)
+ (and (funcall (car ignore) dir)
+ (shell-quote-argument
+ (cdr ignore))))))
grep-find-ignored-files
" -o -name ")
" "
@@ -1314,6 +1345,13 @@ command before it's run."
(grep-highlight-matches 'always))
(rgrep regexp files dir confirm)))
+(defun grep-file-at-point (point)
+ "Return the name of the file at POINT a `grep-mode' buffer.
+The returned file name is relative."
+ (when-let ((msg (get-text-property point 'compilation-message))
+ (loc (compilation--message->loc msg)))
+ (caar (compilation--loc->file-struct loc))))
+
;;;###autoload
(defalias 'rzgrep 'zrgrep)
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index fab42d3f167..05ad82acc4a 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -50,6 +50,30 @@
(defvar hl-line-mode)
(defvar hl-line-sticky-flag)
+(declare-function gdb-tooltip-print "gdb-mi" (expr))
+(declare-function gdb-tooltip-print-1 "gdb-mi" (expr))
+(declare-function gud-pp "gdb-mi" (arg))
+(declare-function gdb-var-delete "gdb-mi" ())
+(declare-function speedbar-toggle-line-expansion "gud" ())
+(declare-function speedbar-edit-line "gud" ())
+;; FIXME: The declares below are necessary because we don't call `gud-def'
+;; at toplevel, so the compiler doesn't know under which circumstances
+;; they're defined.
+(declare-function gud-statement "gud" (arg))
+(declare-function gud-until "gud" (arg))
+(declare-function gud-pv "gud" (arg))
+(declare-function gud-print "gud" (arg))
+(declare-function gud-down "gud" (arg))
+(declare-function gud-up "gud" (arg))
+(declare-function gud-jump "gud" (arg))
+(declare-function gud-finish "gud" (arg))
+(declare-function gud-cont "gud" (arg))
+(declare-function gud-next "gud" (arg))
+(declare-function gud-stepi "gud" (arg))
+(declare-function gud-step "gud" (arg))
+(declare-function gud-remove "gud" (arg))
+(declare-function gud-tbreak "gud" (arg))
+(declare-function gud-break "gud" (arg))
;; ======================================================================
;; GUD commands must be visible in C buffers visited by GUD
@@ -64,10 +88,9 @@ pdb (Python), and jdb."
(defcustom gud-key-prefix "\C-x\C-a"
"Prefix of all GUD commands valid in C buffers."
- :type 'key-sequence
- :group 'gud)
+ :type 'key-sequence)
-(global-set-key (vconcat gud-key-prefix "\C-l") 'gud-refresh)
+(global-set-key (vconcat gud-key-prefix "\C-l") #'gud-refresh)
;; (define-key ctl-x-map " " 'gud-break); backward compatibility hack
(defvar gud-marker-filter nil)
@@ -151,10 +174,11 @@ Used to gray out relevant toolbar icons.")
(or (not (gdb-show-run-p))
(bound-and-true-p
gdb-active-process)))))
- ([go] menu-item (if (bound-and-true-p gdb-active-process)
- "Continue" "Run") gud-go
+ ([go] . (menu-item (if (bound-and-true-p gdb-active-process)
+ "Continue" "Run")
+ gud-go
:visible (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-run-p)))
+ (gdb-show-run-p))))
([stop] menu-item "Stop" gud-stop-subjob
:visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
(and (eq gud-minor-mode 'gdbmi)
@@ -186,13 +210,15 @@ Used to gray out relevant toolbar icons.")
(bound-and-true-p gdb-active-process))
:visible (and (string-equal
(buffer-local-value
- 'gud-target-name gud-comint-buffer) "emacs")
+ 'gud-target-name gud-comint-buffer)
+ "emacs")
(eq gud-minor-mode 'gdbmi)))
- ([print*] menu-item (if (eq gud-minor-mode 'jdb)
- "Dump object"
- "Print Dereference") gud-pstar
+ ([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 gdb jdb)))
+ :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
@@ -294,6 +320,32 @@ Used to gray out relevant toolbar icons.")
(tool-bar-local-item-from-menu
(car x) (cdr x) map gud-minor-mode-map))))
+(defvar gud-gdb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `gud-gdb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
+(defun gud-set-repeat-map-property (keymap-symbol)
+ "Set the `repeat-map' property of relevant gud commands to KEYMAP-SYMBOL.
+
+KEYMAP-SYMBOL is a symbol corresponding to some
+`<FOO>-repeat-map', a keymap containing gud commands that may be
+repeated when `repeat-mode' is on."
+ (map-keymap-internal (lambda (_ cmd)
+ (put cmd 'repeat-map keymap-symbol))
+ (symbol-value keymap-symbol)))
+
+
(defun gud-file-name (f)
"Transform a relative file name to an absolute file name.
Uses `gud-<MINOR-MODE>-directories' to find the source files."
@@ -333,7 +385,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files."
(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))
+ (add-hook 'after-save-hook #'gdb-create-define-alist nil t))
(make-local-variable 'gud-keep-buffer))
buf)))
@@ -380,8 +432,8 @@ we're in the GUD buffer)."
`(gud-call ,cmd arg)
;; Unused lexical warning if cmd does not use "arg".
cmd))))
- ,(if key `(local-set-key ,(concat "\C-c" key) ',func))
- ,(if key `(global-set-key (vconcat gud-key-prefix ,key) ',func))))
+ ,(if key `(local-set-key ,(concat "\C-c" key) #',func))
+ ,(if key `(global-set-key (vconcat gud-key-prefix ,key) #',func))))
;; Where gud-display-frame should put the debugging arrow; a cons of
;; (filename . line-number). This is set by the marker-filter, which scans
@@ -447,12 +499,12 @@ The value t means that there is no stack, and we are in display-file mode.")
"Install those variables used by speedbar to enhance gud/gdb."
(unless gud-speedbar-key-map
(setq gud-speedbar-key-map (speedbar-make-specialized-keymap))
- (define-key gud-speedbar-key-map "j" 'speedbar-edit-line)
- (define-key gud-speedbar-key-map "e" 'speedbar-edit-line)
- (define-key gud-speedbar-key-map "\C-m" 'speedbar-edit-line)
- (define-key gud-speedbar-key-map " " 'speedbar-toggle-line-expansion)
- (define-key gud-speedbar-key-map "D" 'gdb-var-delete)
- (define-key gud-speedbar-key-map "p" 'gud-pp))
+ (define-key gud-speedbar-key-map "j" #'speedbar-edit-line)
+ (define-key gud-speedbar-key-map "e" #'speedbar-edit-line)
+ (define-key gud-speedbar-key-map "\C-m" #'speedbar-edit-line)
+ (define-key gud-speedbar-key-map " " #'speedbar-toggle-line-expansion)
+ (define-key gud-speedbar-key-map "D" #'gdb-var-delete)
+ (define-key gud-speedbar-key-map "p" #'gud-pp))
(speedbar-add-expansion-list '("GUD" gud-speedbar-menu-items
gud-speedbar-key-map
@@ -486,9 +538,8 @@ The value t means that there is no stack, and we are in display-file mode.")
"Additional menu items to add to the speedbar frame.")
;; Make sure our special speedbar mode is loaded
-(if (featurep 'speedbar)
- (gud-install-speedbar-variables)
- (add-hook 'speedbar-load-hook 'gud-install-speedbar-variables))
+(with-eval-after-load 'speedbar
+ (gud-install-speedbar-variables))
(defun gud-expansion-speedbar-buttons (_directory _zero)
"Wrapper for call to `speedbar-add-expansion-list'.
@@ -623,8 +674,7 @@ required by the caller."
(defcustom gud-gud-gdb-command-name "gdb --fullname"
"Default command to run an executable under GDB in text command mode.
The option \"--fullname\" must be included in this value."
- :type 'string
- :group 'gud)
+ :type 'string)
(defvar gud-gdb-marker-regexp
;; This used to use path-separator instead of ":";
@@ -639,8 +689,7 @@ The option \"--fullname\" must be included in this value."
;; receive a chunk of text which looks like it might contain the
;; beginning of a marker, we save it here between calls to the
;; filter.
-(defvar gud-marker-acc "")
-(make-variable-buffer-local 'gud-marker-acc)
+(defvar-local gud-marker-acc "")
(defun gud-gdb-marker-filter (string)
(setq gud-marker-acc (concat gud-marker-acc string))
@@ -759,7 +808,7 @@ the buffer in which this command was invoked."
"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)
+ (setq-local gud-minor-mode 'gdb)
(gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "tbreak %f:%l" "\C-t"
@@ -787,11 +836,13 @@ the buffer in which this command was invoked."
(gud-def gud-until "until %l" "\C-u" "Continue to current line.")
(gud-def gud-run "run" nil "Run the program.")
+ (gud-set-repeat-map-property 'gud-gdb-repeat-map)
+
(add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point
nil 'local)
- (set (make-local-variable 'gud-gdb-completion-function) 'gud-gdb-completions)
+ (setq-local gud-gdb-completion-function #'gud-gdb-completions)
- (local-set-key "\C-i" 'completion-at-point)
+ (local-set-key "\C-i" #'completion-at-point)
(setq comint-prompt-regexp "^(.*gdb[+]?) *")
(setq paragraph-start comint-prompt-regexp)
(setq gdb-first-prompt t)
@@ -986,6 +1037,18 @@ SKIP is the number of chars to skip on each line, it defaults to 0."
(defvar gud-sdb-lastfile nil)
+(defvar gud-sdb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `sdb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(defun gud-sdb-marker-filter (string)
(setq gud-marker-acc
(if gud-marker-acc (concat gud-marker-acc string) string))
@@ -1045,7 +1108,7 @@ and source-file directory for your debugger."
(error "The sdb support requires a valid tags table to work"))
(gud-common-init command-line nil 'gud-sdb-marker-filter 'gud-sdb-find-file)
- (set (make-local-variable 'gud-minor-mode) 'sdb)
+ (setq-local gud-minor-mode 'sdb)
(gud-def gud-break "%l b" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "%l c" "\C-t" "Set temporary breakpoint at current line.")
@@ -1056,6 +1119,8 @@ and source-file directory for your debugger."
(gud-def gud-cont "c" "\C-r" "Continue with display.")
(gud-def gud-print "%e/" "\C-p" "Evaluate C expression at point.")
+ (gud-set-repeat-map-property 'gud-sdb-repeat-map)
+
(setq comint-prompt-regexp "\\(^\\|\n\\)\\*")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'sdb-mode-hook)
@@ -1076,8 +1141,7 @@ The file names should be absolute, or relative to the directory
containing the executable being debugged."
:type '(choice (const :tag "Current Directory" nil)
(repeat :value ("")
- directory))
- :group 'gud)
+ directory)))
(defun gud-dbx-massage-args (_file args)
(nconc (let ((directories gud-dbx-directories)
@@ -1215,6 +1279,23 @@ whereby $stopformat=1 produces an output format compatible with
;; whereby `set $stopformat=1' reportedly produces output compatible
;; with `gud-dbx-marker-filter', which we prefer.
+(defvar gud-dbx-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key map key cmd))
+ (when (or gud-mips-p
+ gud-irix-p)
+ (define-key map "f" 'gud-finish))
+ map)
+ "Keymap to repeat `dbx' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
;; The process filter is also somewhat
;; unreliable, sometimes not spotting the markers; I don't know
;; whether there's anything that can be done about that.]
@@ -1324,7 +1405,7 @@ and source-file directory for your debugger."
(gud-common-init command-line 'gud-dbx-massage-args
'gud-dbx-marker-filter)))
- (set (make-local-variable 'gud-minor-mode) 'dbx)
+ (setq-local gud-minor-mode 'dbx)
(cond
(gud-mips-p
@@ -1362,6 +1443,8 @@ and source-file directory for your debugger."
(gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
(gud-def gud-run "run" nil "Run the program.")
+ (gud-set-repeat-map-property 'gud-dbx-repeat-map)
+
(setq comint-prompt-regexp "^[^)\n]*dbx) *")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'dbx-mode-hook)
@@ -1373,6 +1456,21 @@ and source-file directory for your debugger."
;; History of argument lists passed to xdb.
(defvar gud-xdb-history nil)
+(defvar gud-xdb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `xdb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(defcustom gud-xdb-directories nil
"A list of directories that xdb should search for source code.
If nil, only source files in the program directory
@@ -1382,8 +1480,7 @@ The file names should be absolute, or relative to the directory
containing the executable being debugged."
:type '(choice (const :tag "Current Directory" nil)
(repeat :value ("")
- directory))
- :group 'gud)
+ directory)))
(defun gud-xdb-massage-args (_file args)
(nconc (let ((directories gud-xdb-directories)
@@ -1425,7 +1522,7 @@ directories if your program contains sources from more than one directory."
(gud-common-init command-line 'gud-xdb-massage-args
'gud-xdb-marker-filter)
- (set (make-local-variable 'gud-minor-mode) 'xdb)
+ (setq-local gud-minor-mode 'xdb)
(gud-def gud-break "b %f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-tbreak "b %f:%l\\t" "\C-t"
@@ -1439,6 +1536,8 @@ directories if your program contains sources from more than one directory."
(gud-def gud-finish "bu\\t" "\C-f" "Finish executing current function.")
(gud-def gud-print "p %e" "\C-p" "Evaluate C expression at point.")
+ (gud-set-repeat-map-property 'gud-xdb-repeat-map)
+
(setq comint-prompt-regexp "^>")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'xdb-mode-hook))
@@ -1449,6 +1548,17 @@ directories if your program contains sources from more than one directory."
;; History of argument lists passed to perldb.
(defvar gud-perldb-history nil)
+(defvar gud-perldb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `perldb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(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.
@@ -1565,8 +1675,7 @@ into one that invokes an Emacs-enabled debugging session.
(defcustom gud-perldb-command-name "perl -d"
"Default command to execute a Perl script under debugger."
- :type 'string
- :group 'gud)
+ :type 'string)
;;;###autoload
(defun perldb (command-line)
@@ -1579,7 +1688,7 @@ and source-file directory for your debugger."
(gud-common-init command-line 'gud-perldb-massage-args
'gud-perldb-marker-filter)
- (set (make-local-variable 'gud-minor-mode) 'perldb)
+ (setq-local gud-minor-mode 'perldb)
(gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "B %l" "\C-d" "Remove breakpoint at current line")
@@ -1592,6 +1701,7 @@ and source-file directory for your debugger."
(gud-def gud-print "p %e" "\C-p" "Evaluate perl expression at point.")
(gud-def gud-until "c %l" "\C-u" "Continue to current line.")
+ (gud-set-repeat-map-property 'gud-perldb-repeat-map)
(setq comint-prompt-regexp "^ DB<+[0-9]+>+ ")
(setq paragraph-start comint-prompt-regexp)
@@ -1620,6 +1730,20 @@ and source-file directory for your debugger."
(defvar gud-pdb-marker-regexp-start "^> ")
+(defvar gud-pdb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `pdb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
;; There's no guarantee that Emacs will hand the filter the entire
;; marker at once; it could be broken up across several strings. We
;; might even receive a big chunk with several markers in it. If we
@@ -1679,12 +1803,11 @@ and source-file directory for your debugger."
(if (executable-find "pdb") "pdb" "python -m pdb")
"Command that executes the Python debugger."
:version "27.1"
- :type 'string
- :group 'gud)
+ :type 'string)
;;;###autoload
(defun pdb (command-line)
- "Run COMMAND-LINE in the `*gud-FILE*' buffer.
+ "Run COMMAND-LINE in the `*gud-FILE*' buffer to debug Python programs.
COMMAND-LINE should include the pdb executable
name (`gud-pdb-command-name') and the file to be debugged.
@@ -1697,7 +1820,7 @@ directory and source-file directory for your debugger."
(list (gud-query-cmdline 'pdb)))
(gud-common-init command-line nil 'gud-pdb-marker-filter)
- (set (make-local-variable 'gud-minor-mode) 'pdb)
+ (setq-local gud-minor-mode 'pdb)
(gud-def gud-break "break %d%f:%l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "clear %d%f:%l" "\C-d" "Remove breakpoint at current line")
@@ -1710,6 +1833,8 @@ directory and source-file directory for your debugger."
(gud-def gud-print "p %e" "\C-p" "Evaluate Python expression at point.")
(gud-def gud-statement "!%e" "\C-e" "Execute Python statement at point.")
+ (gud-set-repeat-map-property 'gud-pdb-repeat-map)
+
;; (setq comint-prompt-regexp "^(.*pdb[+]?) *")
(setq comint-prompt-regexp "^(Pdb) *")
(setq paragraph-start comint-prompt-regexp)
@@ -1723,6 +1848,19 @@ directory and source-file directory for your debugger."
(defvar gud-guiler-lastfile nil)
+(defvar gud-guiler-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("l" . gud-refresh)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `guiler' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(defun gud-guiler-marker-filter (string)
(setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string))
@@ -1761,8 +1899,7 @@ directory and source-file directory for your debugger."
"File name for executing the Guile debugger.
This should be an executable on your path, or an absolute file name."
:version "25.1"
- :type 'string
- :group 'gud)
+ :type 'string)
;;;###autoload
(defun guiler (command-line)
@@ -1789,6 +1926,8 @@ and source-file directory for your debugger."
(gud-def gud-down ",down" ">" "Down one stack frame.")
(gud-def gud-print "%e" "\C-p" "Evaluate Guile expression at point.")
+ (gud-set-repeat-map-property 'gud-guiler-repeat-map)
+
(setq comint-prompt-regexp "^scheme@([^>]+> ")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'guiler-mode-hook))
@@ -1846,7 +1985,7 @@ and source-file directory for your debugger."
;; JDB command will get out of the debugger. There is some truly
;; pathetic JDB documentation available at:
;;
-;; http://java.sun.com/products/jdk/1.1/debugging/
+;; https://java.sun.com/products/jdk/1.1/debugging/
;;
;; KNOWN PROBLEMS AND FIXME's:
;;
@@ -1885,8 +2024,7 @@ and source-file directory for your debugger."
(defcustom gud-jdb-command-name "jdb"
"Command that executes the Java debugger."
- :type 'string
- :group 'gud)
+ :type 'string)
(defcustom gud-jdb-use-classpath t
"If non-nil, search for Java source files in classpath directories.
@@ -1901,8 +2039,7 @@ and parsing all Java files for class information.
Set to nil to use `gud-jdb-directories' to scan java sources for
class information on jdb startup (original method)."
- :type 'boolean
- :group 'gud)
+ :type 'boolean)
(defvar gud-jdb-classpath nil
"Java/jdb classpath directories list.
@@ -2177,9 +2314,9 @@ extension EXTN. Normally EXTN is given as the regular expression
(setq gud-jdb-analysis-buffer (get-buffer-create " *gud-jdb-scratch*"))
(prog1
(apply
- 'nconc
+ #'nconc
(mapcar
- 'gud-jdb-build-class-source-alist-for-file
+ #'gud-jdb-build-class-source-alist-for-file
sources))
(kill-buffer gud-jdb-analysis-buffer)
(setq gud-jdb-analysis-buffer nil)))
@@ -2236,6 +2373,21 @@ extension EXTN. Normally EXTN is given as the regular expression
;; Note: Reset to this value every time a prompt is seen
(defvar gud-jdb-lowest-stack-level 999)
+(defvar gud-jdb-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)
+ ("l" . gud-refresh)))
+ (define-key map key cmd))
+ map)
+ "Keymap to repeat `jdb' stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(defun gud-jdb-find-source-using-classpath (p)
"Find source file corresponding to fully qualified class P.
Convert P from jdb's output, converted to a pathname
@@ -2246,13 +2398,14 @@ relative to a classpath directory."
;; name relative to classpath
(filename
(concat
- (mapconcat 'identity
+ (mapconcat #'identity
(split-string
;; Eliminate any subclass references in the class
;; name string. These start with a "$"
(if (string-match "\\$.*" p)
(replace-match "" t t p) p)
- "\\.") "/")
+ "\\.")
+ "/")
".java"))
(cplist (append gud-jdb-sourcepath gud-jdb-classpath))
found-file)
@@ -2274,7 +2427,7 @@ during jdb initialization depending on the value of
"Parse the classpath list and convert each item to an absolute pathname."
(mapcar (lambda (s) (if (string-match "[/\\]$" s)
(replace-match "" nil nil s) s))
- (mapcar 'file-truename
+ (mapcar #'file-truename
(split-string
string
(concat "[ \t\n\r,\"" path-separator "]+")))))
@@ -2359,17 +2512,17 @@ during jdb initialization depending on the value of
(if (< n gud-jdb-lowest-stack-level)
(progn (setq gud-jdb-lowest-stack-level n) t)))
t)
- (if (setq file-found
- (gud-jdb-find-source (match-string 2 gud-marker-acc)))
- (setq gud-last-frame
- (cons file-found
- (string-to-number
- (let
- ((numstr (match-string 4 gud-marker-acc)))
- (if (string-match "[.,]" numstr)
- (replace-match "" nil nil numstr)
- numstr)))))
- (message "Could not find source file.")))
+ (let ((class (match-string 2 gud-marker-acc)))
+ (if (setq file-found (gud-jdb-find-source class))
+ (setq gud-last-frame
+ (cons file-found
+ (string-to-number
+ (let
+ ((numstr (match-string 4 gud-marker-acc)))
+ (if (string-match "[.,]" numstr)
+ (replace-match "" nil nil numstr)
+ numstr)))))
+ (message "Could not find source file for %s" class))))
;; Set the accumulator to the remaining text.
(setq gud-marker-acc (substring gud-marker-acc (match-end 0))))
@@ -2419,7 +2572,7 @@ gud, see `gud-mode'."
(gud-common-init command-line 'gud-jdb-massage-args
'gud-jdb-marker-filter)
- (set (make-local-variable 'gud-minor-mode) 'jdb)
+ (setq-local gud-minor-mode 'jdb)
;; If a -classpath option was provided, set gud-jdb-classpath
(if gud-jdb-classpath-string
@@ -2443,6 +2596,8 @@ gud, see `gud-mode'."
(gud-def gud-print "print %e" "\C-p" "Print value of expression at point.")
(gud-def gud-pstar "dump %e" nil "Print all object information at point.")
+ (gud-set-repeat-map-property 'gud-jdb-repeat-map)
+
(setq comint-prompt-regexp "^> \\|^[^ ]+\\[[0-9]+\\] ")
(setq paragraph-start comint-prompt-regexp)
(run-hooks 'jdb-mode-hook)
@@ -2453,7 +2608,7 @@ gud, see `gud-mode'."
(if (string-match "-attach" command-line)
(gud-call "classpath"))
(fset 'gud-jdb-find-source
- 'gud-jdb-find-source-using-classpath))
+ #'gud-jdb-find-source-using-classpath))
;; Else create and bind the class/source association list as well
;; as the source file list.
@@ -2461,8 +2616,8 @@ gud, see `gud-mode'."
(gud-jdb-build-class-source-alist
(setq gud-jdb-source-files
(gud-jdb-build-source-files-list gud-jdb-directories
- "\\.java$"))))
- (fset 'gud-jdb-find-source 'gud-jdb-find-source-file)))
+ "\\.java\\'"))))
+ (fset 'gud-jdb-find-source #'gud-jdb-find-source-file)))
;;
;; End of debugger-specific information
@@ -2567,22 +2722,25 @@ You may use the `gud-def' macro in the initialization hook to define other
commands.
Other commands for interacting with the debugger process are inherited from
-comint mode, which see."
+`comint-mode', which see.
+
+Commands:
+
+\\{gud-mode-map}"
(setq mode-line-process '(":%s"))
- (define-key (current-local-map) "\C-c\C-l" 'gud-refresh)
- (set (make-local-variable 'gud-last-frame) nil)
+ (define-key (current-local-map) "\C-c\C-l" #'gud-refresh)
+ (setq-local gud-last-frame nil)
(if (boundp 'tool-bar-map) ; not --without-x
(setq-local tool-bar-map gud-tool-bar-map))
(make-local-variable 'comint-prompt-regexp)
;; Don't put repeated commands in command history many times.
- (set (make-local-variable 'comint-input-ignoredups) t)
+ (setq-local comint-input-ignoredups t)
(make-local-variable 'paragraph-start)
- (set (make-local-variable 'gud-delete-prompt-marker) (make-marker))
- (add-hook 'kill-buffer-hook 'gud-kill-buffer-hook nil t))
+ (setq-local gud-delete-prompt-marker (make-marker))
+ (add-hook 'kill-buffer-hook #'gud-kill-buffer-hook nil t))
(defcustom gud-chdir-before-run t
"Non-nil if GUD should `cd' to the debugged executable."
- :group 'gud
:type 'boolean)
;; Perform initializations common to all debuggers.
@@ -2646,18 +2804,18 @@ comint mode, which see."
(setq w (cdr w)))
;; Tramp has already been loaded if we are here.
(if w (setcar w (setq file (file-local-name file)))))
- (apply 'make-comint (concat "gud" filepart) program nil
+ (apply #'make-comint (concat "gud" filepart) program nil
(if massage-args (funcall massage-args file args) args))
;; Since comint clobbered the mode, we don't set it until now.
(gud-mode)
- (set (make-local-variable 'gud-target-name)
+ (setq-local gud-target-name
(and file-word (file-name-nondirectory file))))
- (set (make-local-variable 'gud-marker-filter) marker-filter)
- (if find-file (set (make-local-variable 'gud-find-file) find-file))
+ (setq-local gud-marker-filter marker-filter)
+ (if find-file (setq-local gud-find-file find-file))
(setq gud-last-last-frame nil)
- (set-process-filter (get-buffer-process (current-buffer)) 'gud-filter)
- (set-process-sentinel (get-buffer-process (current-buffer)) 'gud-sentinel)
+ (set-process-filter (get-buffer-process (current-buffer)) #'gud-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer)) #'gud-sentinel)
(gud-set-buffer))
(defun gud-set-buffer ()
@@ -2827,9 +2985,13 @@ Obeying it means displaying in another window the specified file and line."
(buffer
(with-current-buffer gud-comint-buffer
(gud-find-file true-file)))
- (window (and buffer
- (or (get-buffer-window buffer)
- (display-buffer buffer '(nil (inhibit-same-window . t))))))
+ (window
+ (when buffer
+ (if (eq gud-minor-mode 'gdbmi)
+ (gdb-display-source-buffer buffer)
+ ;; Gud still has the old behavior.
+ (or (get-buffer-window buffer)
+ (display-buffer buffer '(nil (inhibit-same-window . t)))))))
(pos))
(when buffer
(with-current-buffer buffer
@@ -2859,9 +3021,7 @@ Obeying it means displaying in another window the specified file and line."
(widen)
(goto-char pos))))
(when window
- (set-window-point window gud-overlay-arrow-position)
- (if (eq gud-minor-mode 'gdbmi)
- (setq gdb-source-window window))))))
+ (set-window-point window gud-overlay-arrow-position)))))
;; The gud-call function must do the right thing whether its invoking
;; keystroke is from the GUD buffer itself (via major-mode binding)
@@ -3176,10 +3336,11 @@ class of the file (using s to separate nested class ids)."
(while (and cplist (not class-found))
(if (string-match (car cplist) f)
(setq class-found
- (mapconcat 'identity
+ (mapconcat #'identity
(split-string
(substring f (+ (match-end 0) 1))
- "/") ".")))
+ "/")
+ ".")))
(setq cplist (cdr cplist)))
;; if f is visited by a java(cc-mode) buffer, walk up the
;; syntactic information chain and collect any 'inclass
@@ -3218,7 +3379,7 @@ class of the file (using s to separate nested class ids)."
))
(string-match (concat (car nclass) "$") class-found)
(setq class-found
- (replace-match (mapconcat 'identity nclass "$")
+ (replace-match (mapconcat #'identity nclass "$")
t t class-found)))))
(if (not class-found)
(message "gud-find-class: class for file %s not found!" f))
@@ -3347,23 +3508,23 @@ Treats actions as defuns."
;;;###autoload
(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-*")
- (set (make-local-variable 'outline-regexp) "[ \t]")
- (set (make-local-variable 'imenu-generic-expression)
- '((nil "^define[ \t]+\\(\\w+\\)" 1)))
- (set (make-local-variable 'indent-line-function) 'gdb-script-indent-line)
- (set (make-local-variable 'beginning-of-defun-function)
- #'gdb-script-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function)
- #'gdb-script-end-of-defun)
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
- (font-lock-syntactic-face-function
- . gdb-script-font-lock-syntactic-face)))
+ (setq-local comment-start "#")
+ (setq-local comment-start-skip "#+\\s-*")
+ (setq-local outline-regexp "[ \t]")
+ (setq-local imenu-generic-expression
+ '((nil "^define[ \t]+\\(\\w+\\)" 1)))
+ (setq-local indent-line-function #'gdb-script-indent-line)
+ (setq-local beginning-of-defun-function
+ #'gdb-script-beginning-of-defun)
+ (setq-local end-of-defun-function
+ #'gdb-script-end-of-defun)
+ (setq-local font-lock-defaults
+ '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
+ (font-lock-syntactic-face-function
+ . gdb-script-font-lock-syntactic-face)))
;; Recognize docstrings.
- (set (make-local-variable 'syntax-propertize-function)
- gdb-script-syntax-propertize-function)
+ (setq-local syntax-propertize-function
+ gdb-script-syntax-propertize-function)
(add-hook 'syntax-propertize-extend-region-functions
#'syntax-propertize-multiline 'append 'local))
@@ -3383,14 +3544,14 @@ Treats actions as defuns."
(require 'tooltip)
(if gud-tooltip-mode
(progn
- (add-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode)
- (add-hook 'pre-command-hook 'tooltip-hide)
- (add-hook 'tooltip-functions 'gud-tooltip-tips)
- (define-key global-map [mouse-movement] 'gud-tooltip-mouse-motion))
- (unless tooltip-mode (remove-hook 'pre-command-hook 'tooltip-hide)
- (remove-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode)
- (remove-hook 'tooltip-functions 'gud-tooltip-tips)
- (define-key global-map [mouse-movement] 'ignore)))
+ (add-hook 'change-major-mode-hook #'gud-tooltip-change-major-mode)
+ (add-hook 'pre-command-hook #'tooltip-hide)
+ (add-hook 'tooltip-functions #'gud-tooltip-tips)
+ (define-key global-map [mouse-movement] #'gud-tooltip-mouse-motion))
+ (unless tooltip-mode (remove-hook 'pre-command-hook #'tooltip-hide)
+ (remove-hook 'change-major-mode-hook #'gud-tooltip-change-major-mode)
+ (remove-hook 'tooltip-functions #'gud-tooltip-tips)
+ (define-key global-map [mouse-movement] #'ignore)))
(gud-tooltip-activate-mouse-motions-if-enabled)
(if (and gud-comint-buffer
(buffer-name gud-comint-buffer); gud-comint-buffer might be killed
@@ -3407,15 +3568,14 @@ Treats actions as defuns."
(make-local-variable 'gdb-define-alist)
(gdb-create-define-alist)
(add-hook 'after-save-hook
- 'gdb-create-define-alist nil t))))))
+ #'gdb-create-define-alist nil t))))))
(kill-local-variable 'gdb-define-alist)
- (remove-hook 'after-save-hook 'gdb-create-define-alist t))))
+ (remove-hook 'after-save-hook #'gdb-create-define-alist t))))
(defcustom gud-tooltip-modes '(gud-mode c-mode c++-mode fortran-mode
python-mode)
"List of modes for which to enable GUD tooltips."
:type '(repeat (symbol :tag "Major mode"))
- :group 'gud
:group 'tooltip)
(defcustom gud-tooltip-display
@@ -3427,13 +3587,11 @@ Forms in the list are combined with AND. The default is to display
only tooltips in the buffer containing the overlay arrow."
:type 'sexp
:risky t
- :group 'gud
:group 'tooltip)
(defcustom gud-tooltip-echo-area nil
"Use the echo area instead of frames for GUD tooltips."
:type 'boolean
- :group 'gud
:group 'tooltip)
(make-obsolete-variable 'gud-tooltip-echo-area
@@ -3443,12 +3601,12 @@ only tooltips in the buffer containing the overlay arrow."
(defun gud-tooltip-change-major-mode ()
"Function added to `change-major-mode-hook' when tooltip mode is on."
- (add-hook 'post-command-hook 'gud-tooltip-activate-mouse-motions-if-enabled))
+ (add-hook 'post-command-hook #'gud-tooltip-activate-mouse-motions-if-enabled))
(defun gud-tooltip-activate-mouse-motions-if-enabled ()
"Reconsider for all buffers whether mouse motion events are desired."
(remove-hook 'post-command-hook
- 'gud-tooltip-activate-mouse-motions-if-enabled)
+ #'gud-tooltip-activate-mouse-motions-if-enabled)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(if (and gud-tooltip-mode
@@ -3470,8 +3628,8 @@ only tooltips in the buffer containing the overlay arrow."
ACTIVATEP non-nil means activate mouse motion events."
(if activatep
(progn
- (set (make-local-variable 'gud-tooltip-mouse-motions-active) t)
- (set (make-local-variable 'track-mouse) t))
+ (setq-local gud-tooltip-mouse-motions-active t)
+ (setq-local track-mouse t))
(when gud-tooltip-mouse-motions-active
(kill-local-variable 'gud-tooltip-mouse-motions-active)
(kill-local-variable 'track-mouse))))
@@ -3557,7 +3715,7 @@ This function must return nil if it doesn't handle EVENT."
(posn-point (event-end event))
(or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process))
(progn (setq gud-tooltip-event event)
- (eval (cons 'and gud-tooltip-display)))))
+ (eval (cons 'and gud-tooltip-display) t))))
(let ((expr (tooltip-expr-to-print event)))
(when expr
(if (and (eq gud-minor-mode 'gdbmi)
@@ -3587,10 +3745,10 @@ so they have been disabled."))
(gdb-input
(concat
"server macro expand " expr "\n")
- `(lambda () (gdb-tooltip-print-1 ,expr)))
+ (lambda () (gdb-tooltip-print-1 expr)))
(gdb-input
(concat cmd "\n")
- `(lambda () (gdb-tooltip-print ,expr))))
+ (lambda () (gdb-tooltip-print expr))))
(add-function :override (process-filter process)
#'gud-tooltip-process-output)
(gud-basic-call cmd))
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 9f0727eb42d..4a1da62c7e9 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -55,10 +55,10 @@
;; Use M-x hide-ifdef-undef (C-c @ u) to undefine a symbol.
;;
;; If you define or undefine a symbol while hide-ifdef-mode is in effect,
-;; the display will be updated. Only the define list for the current
-;; buffer will be affected. You can save changes to the local define
-;; list with hide-ifdef-set-define-alist. This adds entries
-;; to hide-ifdef-define-alist.
+;; the display will be updated. The global define list hide-ifdef-env
+;; is affected accordingly. You can save changes to this globally define
+;; list with hide-ifdef-set-define-alist. This adds entries to
+;; hide-ifdef-define-alist.
;;
;; If you have defined a hide-ifdef-mode-hook, you can set
;; up a list of symbols that may be used by hide-ifdefs as in the
@@ -68,10 +68,19 @@
;; (lambda ()
;; (unless hide-ifdef-define-alist
;; (setq hide-ifdef-define-alist
-;; '((list1 ONE TWO)
-;; (list2 TWO THREE))))
+;; '((list1 (ONE . 1) (TWO . 2))
+;; (list2 (TWO . 2) (THREE . 3)))))
;; (hide-ifdef-use-define-alist 'list2))) ; use list2 by default
;;
+;; Currently recursive #include is not yet supported, a quick and reliable
+;; way is to let the compiler generates all the #include-d defined macros
+;; into a file, then open it in Emacs with hide-ifdefs (C-c @ h).
+;; Take gcc and hello.c for example, hello.c #include-s <stdio.h>:
+;;
+;; $ gcc -dM -E hello.c -o hello.hh
+;;
+;; Then, open hello.hh and perform hide-ifdefs.
+;;
;; You can call hide-ifdef-use-define-alist (C-c @ U) at any time to specify
;; another list to use.
;;
@@ -99,7 +108,11 @@
;; Extensively modified by Daniel LaLiberte (while at Gould).
;;
;; Extensively modified by Luke Lee in 2013 to support complete C expression
-;; evaluation and argumented macro expansion.
+;; evaluation and argumented macro expansion; C++11, C++14, C++17, GCC
+;; extension literals and gcc/clang matching behaviours are supported in 2021.
+;; Various floating point types and operations are also supported but the
+;; actual precision is limited by the Emacs internal floating representation,
+;; which is the C data type "double" or IEEE binary64 format.
;;; Code:
@@ -136,7 +149,10 @@
:type '(choice (const nil) string)
:version "25.1")
-(defcustom hide-ifdef-expand-reinclusion-protection t
+(define-obsolete-variable-alias 'hide-ifdef-expand-reinclusion-protection
+ 'hide-ifdef-expand-reinclusion-guard "28.1")
+
+(defcustom hide-ifdef-expand-reinclusion-guard t
"Non-nil means don't hide an entire header file enclosed by #ifndef...#endif.
Most C/C++ headers are usually wrapped with ifdefs to prevent re-inclusion:
@@ -153,16 +169,16 @@ The first time we visit such a file, _XXX_HEADER_FILE_INCLUDED_ is
undefined, and so nothing is hidden. The next time we visit it, everything will
be hidden.
-This behavior is generally undesirable. If this option is non-nil, the outermost
-#if is always visible."
+This behavior is generally undesirable. If this option is non-nil, the
+outermost #if is always visible."
:type 'boolean
:version "25.1")
(defcustom hide-ifdef-header-regexp
"\\.h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\'"
"C/C++ header file name patterns to determine if current buffer is a header.
-Effective only if `hide-ifdef-expand-reinclusion-protection' is t."
- :type 'string
+Effective only if `hide-ifdef-expand-reinclusion-guard' is t."
+ :type 'regexp
:version "25.1")
(defvar hide-ifdef-mode-submap
@@ -195,6 +211,21 @@ Effective only if `hide-ifdef-expand-reinclusion-protection' is t."
:type 'key-sequence
:version "27.1")
+(defcustom hide-ifdef-verbose nil
+ "Show some defining symbols on hiding for a visible feedback."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom hide-ifdef-evalulate-enter-hook nil
+ "Hook function to be called when entering `hif-evaluate-macro'."
+ :type 'hook
+ :version "28.1")
+
+(defcustom hide-ifdef-evalulate-leave-hook nil
+ "Hook function to be called when leaving `hif-evaluate-macro'."
+ :type 'hook
+ :version "28.1")
+
(defvar hide-ifdef-mode-map
;; Set up the mode's main map, which leads via the prefix key to the submap.
(let ((map (make-sparse-keymap)))
@@ -301,18 +332,18 @@ Several variables affect how the hiding is done:
;; `hide-ifdef-env' is now a global variable.
;; We can still simulate the behavior of older hideif versions (i.e.
;; `hide-ifdef-env' being buffer local) by clearing this variable
- ;; (C-c @ C) everytime before hiding current buffer.
-;; (set (make-local-variable 'hide-ifdef-env)
+ ;; (C-c @ C) every time before hiding current buffer.
+;; (setq-local hide-ifdef-env
;; (default-value 'hide-ifdef-env))
- (set 'hide-ifdef-env (default-value 'hide-ifdef-env))
+ (setq hide-ifdef-env (default-value 'hide-ifdef-env))
;; Some C/C++ headers might have other ways to prevent reinclusion and
- ;; thus would like `hide-ifdef-expand-reinclusion-protection' to be nil.
- (set (make-local-variable 'hide-ifdef-expand-reinclusion-protection)
- (default-value 'hide-ifdef-expand-reinclusion-protection))
- (set (make-local-variable 'hide-ifdef-hiding)
- (default-value 'hide-ifdef-hiding))
- (set (make-local-variable 'hif-outside-read-only) buffer-read-only)
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ ;; thus would like `hide-ifdef-expand-reinclusion-guard' to be nil.
+ (setq-local hide-ifdef-expand-reinclusion-guard
+ (default-value 'hide-ifdef-expand-reinclusion-guard))
+ (setq-local hide-ifdef-hiding
+ (default-value 'hide-ifdef-hiding))
+ (setq-local hif-outside-read-only buffer-read-only)
+ (setq-local line-move-ignore-invisible t)
(add-hook 'change-major-mode-hook
(lambda () (hide-ifdef-mode -1)) nil t)
@@ -330,23 +361,42 @@ Several variables affect how the hiding is done:
(defun hif-clear-all-ifdef-defined ()
"Clears all symbols defined in `hide-ifdef-env'.
It will backup this variable to `hide-ifdef-env-backup' before clearing to
-prevent accidental clearance."
+prevent accidental clearance.
+When prefixed, it swaps current symbols with the backup ones."
(interactive)
- (when (y-or-n-p "Clear all #defined symbols? ")
- (setq hide-ifdef-env-backup hide-ifdef-env)
- (setq hide-ifdef-env nil)))
-
-(defun hif-show-all ()
- "Show all of the text in the current buffer."
- (interactive)
- (hif-show-ifdef-region (point-min) (point-max)))
+ (if current-prefix-arg
+ (if hide-ifdef-env-backup
+ (when (y-or-n-p (format
+ "Restore all %d #defined symbols just cleared? "
+ (length hide-ifdef-env-backup)))
+ (let ((tmp hide-ifdef-env-backup))
+ (setq hide-ifdef-env hide-ifdef-env-backup)
+ (setq hide-ifdef-env-backup tmp))
+ (message "Backup symbols restored."))
+ (message "No backup symbol to restore."))
+ (when (y-or-n-p (format "Clear all %d #defined symbols? "
+ (length hide-ifdef-env)))
+ (if hide-ifdef-env ;; backup only if not empty
+ (setq hide-ifdef-env-backup hide-ifdef-env))
+ (setq hide-ifdef-env nil)
+ (message "All defined symbols cleared." ))))
+
+(defun hif-show-all (&optional start end)
+ "Show all of the text in the current buffer.
+If there is a marked region from START to END it only shows the symbols within."
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (hif-show-ifdef-region
+ (or start (point-min)) (or end (point-max))))
;; By putting this on after-revert-hook, we arrange that it only
;; does anything when revert-buffer avoids turning off the mode.
;; (That can happen in VC.)
(defun hif-after-revert-function ()
(and hide-ifdef-mode hide-ifdef-hiding
- (hide-ifdefs t)))
+ (hide-ifdefs nil nil t)))
(add-hook 'after-revert-hook 'hif-after-revert-function)
(defun hif-end-of-line ()
@@ -427,9 +477,17 @@ Everything including these lines is made invisible."
;;===%%SF%% evaluation (Start) ===
+(defun hif-eval (form)
+ "Evaluate hideif internal representation."
+ (let ((val (eval form)))
+ (if (stringp val)
+ (or (get-text-property 0 'hif-value val)
+ val)
+ val)))
+
;; It is not useful to set this to anything but `eval'.
;; In fact, the variable might as well be eliminated.
-(defvar hide-ifdef-evaluator 'eval
+(defvar hide-ifdef-evaluator #'hif-eval
"The function to use to evaluate a form.
The evaluator is given a canonical form and returns t if text under
that form should be displayed.")
@@ -442,23 +500,42 @@ that form should be displayed.")
"Prepend (VAR VALUE) pair to `hide-ifdef-env'."
(setq hide-ifdef-env (cons (cons var value) hide-ifdef-env)))
+(defconst hif-predefine-alist
+ '((__LINE__ . hif-__LINE__)
+ (__FILE__ . hif-__FILE__)
+ (__COUNTER__ . hif-__COUNTER__)
+ (__cplusplus . hif-__cplusplus)
+ (__DATE__ . hif-__DATE__)
+ (__TIME__ . hif-__TIME__)
+ (__STDC__ . hif-__STDC__)
+ (__STDC_VERSION__ . hif-__STDC_VERSION__)
+ (__STDC_HOST__ . hif-__STDC_HOST__)
+ (__BASE_FILE__ . hif-__FILE__)))
+
(declare-function semantic-c-hideif-lookup "semantic/bovine/c" (var))
(declare-function semantic-c-hideif-defined "semantic/bovine/c" (var))
(defun hif-lookup (var)
(or (when (bound-and-true-p semantic-c-takeover-hideif)
(semantic-c-hideif-lookup var))
- (let ((val (assoc var hide-ifdef-env)))
+ (let ((val (assq var hide-ifdef-env)))
(if val
(cdr val)
- hif-undefined-symbol))))
+ (if (setq val (assq var hif-predefine-alist))
+ (funcall (cdr val))
+ hif-undefined-symbol)))))
(defun hif-defined (var)
- (cond
- ((bound-and-true-p semantic-c-takeover-hideif)
- (semantic-c-hideif-defined var))
- ((assoc var hide-ifdef-env) 1)
- (t 0)))
+ (let (def)
+ (cond
+ ((bound-and-true-p semantic-c-takeover-hideif)
+ (semantic-c-hideif-defined var))
+ ;; Here we can't use hif-lookup as an empty definition like `#define EMPTY'
+ ;; is considered defined but is evaluated as `nil'.
+ ((assq var hide-ifdef-env) 1)
+ ((and (setq def (assq var hif-predefine-alist))
+ (funcall (cdr def))) 1)
+ (t 0))))
;;===%%SF%% evaluation (End) ===
@@ -484,7 +561,7 @@ that form should be displayed.")
(defconst hif-define-regexp (concat hif-cpp-prefix "\\(define\\|undef\\)"))
(defconst hif-id-regexp (concat "[[:alpha:]_][[:alnum:]_]*"))
(defconst hif-macroref-regexp
- (concat hif-white-regexp "\\(" hif-id-regexp "\\)" hif-white-regexp
+ (concat hif-white-regexp "\\(" hif-id-regexp "\\)"
"\\("
"(" hif-white-regexp
"\\(" hif-id-regexp "\\)?" hif-white-regexp
@@ -493,6 +570,75 @@ that form should be displayed.")
")"
"\\)?" ))
+;; The point here is *NOT* to do "syntax error checking" for C(++) compiler, but
+;; to parse and recognize *already valid* numeric literals. Therefore we don't
+;; need to worry if number like "0x12'" is invalid, leave it to the compiler.
+;; Otherwise, the runtime performance of hideif would be poor.
+;;
+;; GCC fixed-point literal extension:
+;;
+;; ‘ullk’ or ‘ULLK’ for unsigned long long _Accum and _Sat unsigned long long _Accum
+;; ‘ullr’ or ‘ULLR’ for unsigned long long _Fract and _Sat unsigned long long _Fract
+;;
+;; ‘llk’ or ‘LLK’ for long long _Accum and _Sat long long _Accum
+;; ‘llr’ or ‘LLR’ for long long _Fract and _Sat long long _Fract
+;; ‘uhk’ or ‘UHK’ for unsigned short _Accum and _Sat unsigned short _Accum
+;; ‘ulk’ or ‘ULK’ for unsigned long _Accum and _Sat unsigned long _Accum
+;; ‘uhr’ or ‘UHR’ for unsigned short _Fract and _Sat unsigned short _Fract
+;; ‘ulr’ or ‘ULR’ for unsigned long _Fract and _Sat unsigned long _Fract
+;;
+;; ‘lk’ or ‘LK’ for long _Accum and _Sat long _Accum
+;; ‘lr’ or ‘LR’ for long _Fract and _Sat long _Fract
+;; ‘uk’ or ‘UK’ for unsigned _Accum and _Sat unsigned _Accum
+;; ‘ur’ or ‘UR’ for unsigned _Fract and _Sat unsigned _Fract
+;; ‘hk’ or ‘HK’ for short _Accum and _Sat short _Accum
+;; ‘hr’ or ‘HR’ for short _Fract and _Sat short _Fract
+;;
+;; ‘r’ or ‘R’ for _Fract and _Sat _Fract
+;; ‘k’ or ‘K’ for _Accum and _Sat _Accum
+
+;; C++14 also include '0b' for binary and "'" as separator
+(defconst hif-numtype-suffix-regexp
+ ;; "\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|[uUlLfF]\\)"
+ (concat
+ "\\(\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|"
+ "[uU][hH]\\)[kKrR]?\\|" ; GCC fixed-point extension
+ "[dD][dDfFlL]\\|" ; GCC floating-point extension
+ "[uUlLfF]\\)"))
+(defconst hif-bin-regexp
+ (concat "[+-]?0[bB]\\([01']+\\)"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-hex-regexp
+ (concat "[+-]?0[xX]\\([[:xdigit:]']+\\)"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-oct-regexp
+ (concat "[+-]?0[0-7']+"
+ hif-numtype-suffix-regexp "?"))
+(defconst hif-dec-regexp
+ (concat "[+-]?\\(0\\|[1-9][0-9']*\\)"
+ hif-numtype-suffix-regexp "?"))
+
+(defconst hif-decfloat-regexp
+ ;; `hif-string-to-decfloat' relies on the number and ordering of parentheses
+ (concat
+ "\\(?:"
+ "\\([+-]?[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[fFlL]?"
+ "\\|\\([+-]?[0-9]+\\)\\.\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?"
+ "\\|\\([+-]?[0-9]*\\.[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?"
+ "\\)"))
+
+;; C++17 hexadecimal floating point literal
+(defconst hif-hexfloat-regexp
+ ;; `hif-string-to-hexfloat' relies on the ordering of regexp groupings
+ (concat
+ "[+-]?\\(?:"
+ "0[xX]\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\|"
+ "0[xX]\\([[:xdigit:]']+\\)\\.[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\|"
+ "0[xX]\\([[:xdigit:]']*\\)\\.\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?"
+ "\\)"))
+
;; Store the current token and the whole token list during parsing.
;; Bound dynamically.
(defvar hif-token)
@@ -530,29 +676,113 @@ that form should be displayed.")
(":" . hif-colon)
("," . hif-comma)
("#" . hif-stringify)
- ("..." . hif-etc)))
+ ("..." . hif-etc)
+ ("defined" . hif-defined)))
(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist))
(defconst hif-token-regexp
- (concat (regexp-opt (mapcar 'car hif-token-alist))
- "\\|0x[[:xdigit:]]+\\.?[[:xdigit:]]*"
- "\\|[0-9]+\\.?[0-9]*" ;; decimal/octal
- "\\|\\w+"))
-
-(defconst hif-string-literal-regexp "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)")
+ ;; The ordering of regexp grouping is crutial to `hif-strtok'
+ (concat
+ ;; hex/binary:
+ "\\([+-]?0[xXbB]\\([[:xdigit:]']+\\)?\\.?\\([[:xdigit:]']+\\)?\\([pP]\\([+-]?[0-9]+\\)\\)?"
+ hif-numtype-suffix-regexp "?\\)"
+ ;; decimal/octal:
+ "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?"
+ hif-numtype-suffix-regexp "?\\)"
+ "\\|" (regexp-opt (mapcar 'car hif-token-alist) t)
+ "\\|\\(\\w+\\)"))
+
+;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"")
+(defconst hif-unicode-prefix-regexp "\\(?:u8R?\\|[uUL]R?\\|R\\)")
+(defconst hif-string-literal-regexp
+ (concat hif-unicode-prefix-regexp "?"
+ "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)"))
+
+;; matching and conversion
+
+(defun hif-full-match (regexp string)
+ "A full REGEXP match of STRING instead of partially match."
+ (string-match (concat "\\`" regexp "\\'") string))
+
+(defun hif-is-number (string)
+ "Check if STRING is a valid C(++) numeric literal."
+ (or (hif-full-match hif-dec-regexp string)
+ (hif-full-match hif-hex-regexp string)
+ (hif-full-match hif-oct-regexp string)
+ (hif-full-match hif-bin-regexp string)))
+
+(defun hif-is-float (string)
+ "Check if STRING is a valid C(++) floating point literal."
+ (or (hif-full-match hif-decfloat-regexp string)
+ (hif-full-match hif-hexfloat-regexp string)))
+
+(defun hif-delete-char-in-string (char string)
+ "Delete CHAR in STRING inplace."
+ (let ((i (length string))
+ (s nil))
+ (while (> i 0)
+ (setq i (1- i))
+ (unless (eq (aref string i) char)
+ (setq s (cons (aref string i) s))))
+ (concat s)))
+
+(defun hif-string-to-decfloat (string &optional fix exp)
+ "Convert a C(++) decimal floating formatted string into float.
+Assuming we've just regexp-matched with `hif-decfloat-regexp' and it matched.
+if REMATCH is t, do a rematch."
+ ;; In elisp `(string-to-number "01.e2")' will return 1 instead of the expected
+ ;; 100.0; therefore we need to write our own.
+ ;; This function relies on the regexp groups of `hif-dexfloat-regexp'
+ (if (or fix exp)
+ (setq fix (hif-delete-char-in-string ?' fix)
+ exp (hif-delete-char-in-string ?' exp))
+ ;; rematch
+ (setq string (hif-delete-char-in-string ?' string))
+ (hif-full-match hif-decfloat-regexp string)
+ (setq fix (or (match-string 1 string)
+ (match-string 3 string)
+ (match-string 5 string))
+ exp (or (match-string 2 string)
+ (match-string 4 string)
+ (match-string 6 string))))
+ (setq fix (string-to-number fix)
+ exp (if (zerop (length exp)) ;; nil or ""
+ 0 (string-to-number (substring-no-properties exp 1))))
+ (* fix (expt 10 exp)))
+
+(defun hif-string-to-hexfloat (string &optional int fra exp)
+ "Convert a C++17 hex float formatted string into float.
+Assuming we've just regexp-matched with `hif-hexfloat-regexp' and it matched.
+if REMATCH is t, do a rematch."
+ ;; This function relies on the regexp groups of `hif-hexfloat-regexp'
+ (let ((negate (if (eq ?- (aref string 0)) -1.0 1.0)))
+ (if (or int fra exp)
+ (setq int (hif-delete-char-in-string ?' int)
+ fra (hif-delete-char-in-string ?' fra)
+ exp (hif-delete-char-in-string ?' exp))
+ (setq string (hif-delete-char-in-string ?' string))
+ (hif-full-match hif-hexfloat-regexp string)
+ (setq int (or (match-string 1 string)
+ (match-string 3 string)
+ (match-string 5 string))
+ fra (or (match-string 2 string)
+ (match-string 4 string)
+ (match-string 6 string))
+ exp (match-string 7 string)))
+ (setq int (if (zerop (length int)) ;; nil or ""
+ 0 (string-to-number int 16))
+ fra (if (zerop (length fra))
+ 0 (/ (string-to-number fra 16)
+ (expt 16.0 (length fra))))
+ exp (if (zerop (length exp))
+ 0 (string-to-number exp)))
+ (* negate (+ int fra) (expt 2.0 exp))))
(defun hif-string-to-number (string &optional base)
- "Like `string-to-number', but it understands non-decimal floats."
- (if (or (not base) (= base 10))
- (string-to-number string base)
- (let* ((parts (split-string string "\\." t "[ \t]+"))
- (frac (cadr parts))
- (fraclen (length frac))
- (quot (expt (if (zerop fraclen)
- base
- (* base 1.0)) fraclen)))
- (/ (string-to-number (concat (car parts) frac) base) quot))))
+ "Like `string-to-number', but it understands C(++) literals."
+ (setq string (hif-delete-char-in-string ?' string))
+ (string-to-number string base))
;; The dynamic binding variable `hif-simple-token-only' is shared only by
;; `hif-tokenize' and `hif-find-define'. The purpose is to prevent `hif-tokenize'
@@ -562,52 +792,204 @@ that form should be displayed.")
;; Check the long comments before `hif-find-define' for more details. [lukelee]
(defvar hif-simple-token-only)
+(defsubst hif-is-white (c)
+ (memq c '(? ?\t ?\n ?\r)))
+
+(defun hif-strtok (string &optional rematch)
+ "Convert STRING into a hideif mode internal token.
+Assuming we've just performed a `hif-token-regexp' lookup."
+ ;; This function relies on the regexp groups of `hif-token-regexp'
+ ;; New hideif internal number representation: a text string with `hif-value'
+ ;; property to keep its value. Strings without `hif-value' property is a
+ ;; normal C(++) string. This is mainly for stringification. The original
+ ;; implementation only keep the value thus a C++ number like octal 01234
+ ;; will become "668" after being stringified instead of the expected "01234".
+ (let (bufstr m1 m3 m5 m6 m8 neg ch val dec)
+ (when rematch
+ (string-match hif-token-regexp string)
+ (setq bufstr string))
+
+ (cond
+
+ ;; decimal/octal
+ ((match-string 8 bufstr)
+ (setq m6 (match-string 9 bufstr))
+ (setq val
+ (if (or (setq m8 (match-string 11 bufstr))
+ (match-string 10 bufstr)) ;; floating
+ ;; TODO: do we need to add 'hif-type property for
+ ;; type-checking, but this will slow things down
+ (hif-string-to-decfloat string m6 m8)
+ (setq ch (aref string 0))
+ (hif-string-to-number
+ string
+ ;; octal begin with `0'
+ (if (and (> (length string) 1)
+ (or (eq ch ?0)
+ ;; -0... or +0...
+ (and (memq ch '(?- ?+))
+ (eq (aref string 1) ?0))))
+ 8 (setq dec 10)))))
+ ;; Decimal integer without sign and extension is identical to its
+ ;; string form, make it as simple as possible
+ (if (and dec
+ (null (match-string 12 bufstr)) ;; no extension like 'UL'
+ (not (memq ch '(?- ?+))))
+ val
+ (add-text-properties 0 1 (list 'hif-value val) string)
+ string))
+
+ ;; hex/binary
+ ((match-string 1 bufstr)
+ (setq m3 (match-string 3 bufstr))
+ (add-text-properties
+ 0 1
+ (list 'hif-value
+ (if (or (setq m5 (match-string 5 bufstr))
+ m3)
+ (hif-string-to-hexfloat
+ string
+ (match-string 2 bufstr) m3 m5) ;; hexfloat
+ (setq neg (if (eq (aref string 0) ?-) -1 1))
+ (* neg
+ (hif-string-to-number
+ ;; (5-(-1))/2=3; (5-1)/2=2
+ (substring-no-properties string (ash (- 5 neg) -1))
+ ;; (3-(-1))/2=2; (3-1)/2=1
+ (if (or (eq (setq ch (aref string (ash (- 3 neg) -1))) ?x)
+ (eq ch ?X)) ;; hex
+ 16 2)))))
+ string) string)
+
+ ;; operator
+ ((setq m1 (match-string 14 bufstr))
+ (cdr (assoc m1 hif-token-alist #'string-equal)))
+
+ (t
+ (setq hif-simple-token-only nil)
+ (intern-safe string)))))
+
+(defun hif-backward-comment (&optional start end)
+ "If we're currently within a C(++) comment, skip them backwards."
+ ;; Ignore trailing white spaces after comment
+ (setq end (or end (point)))
+ (while (and (> (1- end) 1)
+ (hif-is-white (char-after (1- end))))
+ (cl-decf end))
+ (let ((p0 end)
+ p cmt ce ws we ;; ce:comment start, ws:white start, we whilte end
+ cmtlist) ;; pair of (start.end) of comments
+ (setq start (or start (progn (beginning-of-line) (point)))
+ p start)
+ (while (< (1+ p) end)
+ (if (char-equal ?/ (char-after p)) ; /
+ (if (char-equal ?/ (char-after (1+ p))) ; //
+ (progn
+ ;; merge whites immediately ahead
+ (setq ce (if (and we (= (1- p) we)) ws p))
+ ;; scan for end of line
+ (while (and (< (cl-incf p) end)
+ (not (char-equal ?\n (char-after p)))
+ (not (char-equal ?\r (char-after p)))))
+ ;; Merge with previous comment if immediately followed
+ (push (cons (if (and cmtlist
+ (= (cdr (car cmtlist)) ce))
+ (car (pop cmtlist)) ;; extend previous comment
+ ce)
+ p)
+ cmtlist))
+ (when (char-equal ?* (char-after (1+ p))) ; /*
+ ;; merge whites immediately ahead
+ (setq ce (if (and we (= (1- p) we)) ws p))
+ ;; Check if it immediately follows previous /*...*/ comment;
+ ;; if yes, extend and merge into previous comment
+ (setq cmt (if (and cmtlist
+ (= (cdr (car cmtlist)) ce))
+ (car (pop cmtlist)) ;; extend previous comment
+ ce))
+ (setq p (+ 2 p))
+ ;; Scanning for `*/'
+ (catch 'break
+ (while (< (1+ p) end)
+ (if (not (and (char-equal ?* (char-after p))
+ (char-equal ?/ (char-after (1+ p)))))
+ (cl-incf p)
+ ;; found `*/', mark end pos
+ (push (cons cmt (1+ (setq p (1+ p)))) cmtlist)
+ (throw 'break nil)))
+ ;; (1+ p) >= end
+ (push (cons cmt end) cmtlist))))
+ ;; Trace most recent continuous white spaces before a comment
+ (if (char-equal ? (char-after p))
+ (if (and ws (= we (1- p))) ;; continued
+ (setq we p)
+ (setq ws p
+ we p))
+ (setq ws nil
+ we nil)))
+ (cl-incf p))
+ ;; Goto beginning of the last comment, if we're within
+ (setq cmt (car cmtlist)) ;; last cmt
+ (setq cmt (if (and cmt
+ (>= p0 (car cmt))
+ (<= p0 (cdr cmt)))
+ (car cmt) ;; beginning of the last comment
+ p0))
+ ;; Ignore leading whites ahead of comment
+ (while (and (> (1- cmt) 1)
+ (hif-is-white (char-after (1- cmt))))
+ (cl-decf cmt))
+ (goto-char cmt)))
+
(defun hif-tokenize (start end)
"Separate string between START and END into a list of tokens."
- (let ((token-list nil))
+ (let ((token-list nil)
+ (white-regexp "[ \t]+")
+ token)
(setq hif-simple-token-only t)
(with-syntax-table hide-ifdef-syntax-table
(save-excursion
- (goto-char start)
- (while (progn (forward-comment (point-max)) (< (point) end))
- ;; (message "expr-start = %d" expr-start) (sit-for 1)
- (cond
- ((looking-at "\\\\\n")
- (forward-char 2))
-
- ((looking-at hif-string-literal-regexp)
- (push (substring-no-properties (match-string 1)) token-list)
- (goto-char (match-end 0)))
-
- ((looking-at hif-token-regexp)
- (let ((token (buffer-substring-no-properties
- (point) (match-end 0))))
+ (save-restriction
+ ;; Narrow down to the focusing region so that the ending white spaces
+ ;; of that line will not be treated as a white, as `looking-at' won't
+ ;; look outside the restriction; otherwise it will note the last token
+ ;; or string as one with an `hif-space' property.
+ (setq end (hif-backward-comment start end))
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (progn (forward-comment (point-max)) (< (point) end))
+ ;; (message "expr-start = %d" expr-start) (sit-for 1)
+ (cond
+ ((looking-at "\\\\\n")
+ (forward-char 2))
+
+ ((looking-at hif-string-literal-regexp)
+ (setq token (substring-no-properties (match-string 1)))
+ (goto-char (match-end 0))
+ (when (looking-at white-regexp)
+ (add-text-properties 0 1 '(hif-space t) token)
+ (goto-char (match-end 0)))
+ (push token token-list))
+
+ ((looking-at hif-token-regexp)
(goto-char (match-end 0))
- ;; (message "token: %s" token) (sit-for 1)
- (push
- (or (cdr (assoc token hif-token-alist))
- (if (string-equal token "defined") 'hif-defined)
- ;; TODO:
- ;; 1. postfix 'l', 'll', 'ul' and 'ull'
- ;; 2. floating number formats (like 1.23e4)
- ;; 3. 098 is interpreted as octal conversion error
- (if (string-match "0x\\([[:xdigit:]]+\\.?[[:xdigit:]]*\\)"
- token)
- (hif-string-to-number (match-string 1 token) 16)) ;; hex
- (if (string-match "\\`0[0-9]+\\(\\.[0-9]+\\)?\\'" token)
- (hif-string-to-number token 8)) ;; octal
- (if (string-match "\\`[1-9][0-9]*\\(\\.[0-9]+\\)?\\'"
- token)
- (string-to-number token)) ;; decimal
- (prog1 (intern token)
- (setq hif-simple-token-only nil)))
- token-list)))
-
- ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in
- (forward-char 1)) ; the source code. Let's not get stuck here.
- (t (error "Bad #if expression: %s" (buffer-string)))))))
-
- (nreverse token-list)))
+ (setq token (hif-strtok
+ (substring-no-properties (match-string 0))))
+ (push token token-list)
+ (when (looking-at white-regexp)
+ ;; We can't just append a space to the token string, otherwise
+ ;; `0xf0 ' ## `01' will become `0xf0 01' instead of the expected
+ ;; `0xf001', hence a standalone `hif-space' is placed instead.
+ (push 'hif-space token-list)
+ (goto-char (match-end 0))))
+
+ ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in
+ (forward-char 1)) ; the source code. Let's not get stuck here.
+
+ (t (error "Bad #if expression: %s" (buffer-string)))))))
+ (if (eq 'hif-space (car token-list))
+ (setq token-list (cdr token-list))) ;; remove trailing white space
+ (nreverse token-list))))
;;------------------------------------------------------------------------
;; Translate C preprocessor #if expressions using recursive descent.
@@ -637,50 +1019,96 @@ that form should be displayed.")
;; | | ^= = | |
;; | Comma | , | left-to-right |
-(defsubst hif-nexttoken ()
+(defun hif-nexttoken (&optional keep-space)
"Pop the next token from token-list into the let variable `hif-token'."
- (setq hif-token (pop hif-token-list)))
+ (let ((prevtoken hif-token))
+ (while (progn
+ (setq hif-token (pop hif-token-list))
+ (if keep-space ; keep only one space
+ (and (eq prevtoken 'hif-space)
+ (eq hif-token 'hif-space))
+ (eq hif-token 'hif-space)))))
+ hif-token)
+
+(defun hif-split-signed-token ()
+ "Split current numeric token into two (hif-plus/minus num)."
+ (let* (val ch0 head)
+ (when (and (stringp hif-token)
+ (setq val (get-text-property 0 'hif-value hif-token))
+ ;; explicitly signed?
+ (memq (setq ch0 (aref hif-token 0)) '(?+ ?-)))
+ (if (eq ch0 ?+)
+ (setq head 'hif-plus)
+ (setq head 'hif-minus
+ val (- val)))
+ (setq hif-token (substring hif-token 1))
+ (add-text-properties 0 1 (list 'hif-value val) hif-token)
+ (push hif-token hif-token-list)
+ (setq hif-token head))))
(defsubst hif-if-valid-identifier-p (id)
(not (or (numberp id)
- (stringp id))))
+ (stringp id)
+ (and (atom id)
+ (eq 'defined id)))))
(defun hif-define-operator (tokens)
"\"Upgrade\" hif-define XXX to `(hif-define XXX)' so it won't be substituted."
- (let ((result nil)
- (tok nil))
- (while (setq tok (pop tokens))
- (push
- (if (eq tok 'hif-defined)
- (progn
- (setq tok (cadr tokens))
- (if (eq (car tokens) 'hif-lparen)
- (if (and (hif-if-valid-identifier-p tok)
- (eq (nth 2 tokens) 'hif-rparen))
- (setq tokens (cl-cdddr tokens))
- (error "#define followed by non-identifier: %S" tok))
- (setq tok (car tokens)
- tokens (cdr tokens))
- (unless (hif-if-valid-identifier-p tok)
- (error "#define followed by non-identifier: %S" tok)))
- (list 'hif-defined 'hif-lparen tok 'hif-rparen))
- tok)
- result))
- (nreverse result)))
+ (if (memq 'hif-defined tokens)
+ (let* ((hif-token-list tokens)
+ hif-token
+ target
+ paren)
+ (setq tokens nil) ;; now it becomes the result
+ (while (hif-nexttoken t) ;; keep `hif-space'
+ (when (eq hif-token 'hif-defined)
+ ;; defined XXX, start ignoring `hif-space'
+ (hif-nexttoken)
+ (if (setq paren (eq hif-token 'hif-lparen))
+ (hif-nexttoken))
+ (if (not (hif-if-valid-identifier-p
+ (setq target hif-token)))
+ (error "`defined' followed by non-identifier: %S" target))
+ (if (and paren
+ (not (eq (hif-nexttoken) 'hif-rparen)))
+ (error "missing right parenthesis for `defined'"))
+ (setq hif-token
+ (list 'hif-defined 'hif-lparen target 'hif-rparen)))
+ (push hif-token tokens))
+ (nreverse tokens))
+ tokens))
(define-obsolete-function-alias 'hif-flatten #'flatten-tree "27.1")
-(defun hif-expand-token-list (tokens &optional macroname expand_list)
+(defun hif-keep-single (l e)
+ "Prevent two or more consecutive E in list L."
+ (if (memq e l)
+ (let (prev curr result)
+ (while (progn
+ (setq prev curr
+ curr (car l)
+ l (cdr l))
+ curr)
+ (unless (and (eq prev e)
+ (eq curr e))
+ (push curr result)))
+ (nreverse result))
+ l))
+
+(defun hif-expand-token-list (tokens &optional macroname expand_list level)
"Perform expansion on TOKENS till everything expanded.
Self-reference (directly or indirectly) tokens are not expanded.
EXPAND_LIST is the list of macro names currently being expanded, used for
-detecting self-reference."
+detecting self-reference.
+Function-like macros with calling depth LEVEL 0 does not expand arguments,
+this is to emulate the stringification behavior of C++ preprocessor."
(catch 'self-referencing
(let ((expanded nil)
(remains (hif-define-operator
(hif-token-concatenation
(hif-token-stringification tokens))))
tok rep)
+ (setq level (if level level 0))
(if macroname
(setq expand_list (cons macroname expand_list)))
;; Expanding all tokens till list exhausted
@@ -699,21 +1127,31 @@ detecting self-reference."
(if (and (listp rep)
(eq (car rep) 'hif-define-macro)) ; A defined macro
;; Recursively expand it
+ ;; only in defined macro do we increase the nesting LEVEL
(if (cadr rep) ; Argument list is not nil
- (if (not (eq (car remains) 'hif-lparen))
+ (if (not (or (eq (car remains) 'hif-lparen)
+ ;; hif-space hif-lparen
+ (and (eq (car remains) 'hif-space)
+ (eq (cadr remains) 'hif-lparen)
+ (setq remains (cdr remains)))))
;; No argument, no invocation
tok
;; Argumented macro, get arguments and invoke it.
- ;; Dynamically bind hif-token-list and hif-token
- ;; for hif-macro-supply-arguments
+ ;; Dynamically bind `hif-token-list' and `hif-token'
+ ;; for `hif-macro-supply-arguments'
(let* ((hif-token-list (cdr remains))
(hif-token nil)
- (parmlist (mapcar #'hif-expand-token-list
- (hif-get-argument-list)))
+ (parmlist
+ (if (zerop level)
+ (hif-get-argument-list t)
+ (mapcar (lambda (a)
+ (hif-expand-token-list
+ a nil nil (1+ level)))
+ (hif-get-argument-list t))))
(result
(hif-expand-token-list
(hif-macro-supply-arguments tok parmlist)
- tok expand_list)))
+ tok expand_list (1+ level))))
(setq remains (cons hif-token hif-token-list))
result))
;; Argument list is nil, direct expansion
@@ -745,16 +1183,20 @@ detecting self-reference."
"Parse the TOKEN-LIST.
Return translated list in prefix form. MACRONAME is applied when invoking
macros to prevent self-reference."
- (let ((hif-token-list (hif-expand-token-list token-list macroname)))
+ (let ((hif-token-list (hif-expand-token-list token-list macroname nil))
+ (hif-token nil))
(hif-nexttoken)
(prog1
(and hif-token
(hif-exprlist))
(if hif-token ; is there still a token?
- (error "Error: unexpected token: %s" hif-token)))))
+ (error "Error: unexpected token at line %d: `%s'"
+ (line-number-at-pos)
+ (or (car (rassq hif-token hif-token-alist))
+ hif-token))))))
(defun hif-exprlist ()
- "Parse an exprlist: expr { `,' expr}."
+ "Parse an exprlist: expr { `,' expr }."
(let ((result (hif-expr)))
(if (eq hif-token 'hif-comma)
(let ((temp (list result)))
@@ -824,7 +1266,7 @@ expr : or-expr | or-expr `?' expr `:' expr."
(defun hif-eq-expr ()
"Parse an eq-expr : comp | eq-expr `=='|`!=' comp."
(let ((result (hif-comp-expr))
- (eq-token nil))
+ (eq-token nil))
(while (memq hif-token '(hif-equal hif-notequal))
(setq eq-token hif-token)
(hif-nexttoken)
@@ -857,7 +1299,9 @@ expr : or-expr | or-expr `?' expr `:' expr."
math : muldiv | math `+'|`-' muldiv."
(let ((result (hif-muldiv-expr))
(math-op nil))
- (while (memq hif-token '(hif-plus hif-minus))
+ (while (or (memq hif-token '(hif-plus hif-minus))
+ ;; One token lookahead
+ (hif-split-signed-token))
(setq math-op hif-token)
(hif-nexttoken)
(setq result (list math-op result (hif-muldiv-expr))))
@@ -876,7 +1320,7 @@ expr : or-expr | or-expr `?' expr `:' expr."
(defun hif-factor ()
"Parse a factor.
-factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' |
+factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' |
id `(' parmlist `)' | strings | id."
(cond
((eq hif-token 'hif-not)
@@ -908,10 +1352,14 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' |
(hif-nexttoken)
`(hif-defined (quote ,ident))))
+ ((stringp hif-token)
+ (if (get-text-property 0 'hif-value hif-token)
+ ;; new hideif internal number format for string concatenation
+ (prog1 hif-token (hif-nexttoken))
+ (hif-string-concatenation)))
+
((numberp hif-token)
(prog1 hif-token (hif-nexttoken)))
- ((stringp hif-token)
- (hif-string-concatenation))
;; Unary plus/minus.
((memq hif-token '(hif-minus hif-plus))
@@ -924,12 +1372,12 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' |
(hif-place-macro-invocation ident)
`(hif-lookup (quote ,ident)))))))
-(defun hif-get-argument-list ()
+(defun hif-get-argument-list (&optional keep-space)
(let ((nest 0)
(parmlist nil) ; A "token" list of parameters, will later be parsed
(parm nil))
- (while (or (not (eq (hif-nexttoken) 'hif-rparen))
+ (while (or (not (eq (hif-nexttoken keep-space) 'hif-rparen))
(/= nest 0))
(if (eq (car (last parm)) 'hif-comma)
(setq parm nil))
@@ -945,7 +1393,7 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' |
(push hif-token parm))
(push (nreverse parm) parmlist) ; Okay even if PARM is nil
- (hif-nexttoken) ; Drop the `hif-rparen', get next token
+ (hif-nexttoken keep-space) ; Drop the `hif-rparen', get next token
(nreverse parmlist)))
(defun hif-place-macro-invocation (ident)
@@ -973,10 +1421,21 @@ This macro cannot be evaluated alone without parameters input."
(cond
((numberp a)
(number-to-string a))
- ((atom a)
- (symbol-name a))
((stringp a)
- (concat "\"" a "\""))
+ ;; Remove properties here otherwise a string like "0x12 + 0x34" will be
+ ;; later evaluated as (0x12 + 0x34) and become 0x70.
+ ;; See also `hif-eval' and `hif-mathify'.
+ (concat (substring-no-properties a)
+ (if (get-text-property 0 'hif-space a) " ")))
+ ((atom a)
+ (if (memq a hif-valid-token-list)
+ (car (rassq a hif-token-alist))
+ (if (eq a 'hif-space)
+ " "
+ (symbol-name a))))
+ ((listp a) ;; stringify each element then concat
+ (cl-loop for e in a
+ concat (hif-stringify e)))
(t
(error "Invalid token to stringify"))))
@@ -984,32 +1443,34 @@ This macro cannot be evaluated alone without parameters input."
(if (stringp str)
(intern str)))
-(defun hif-token-concat (a b)
- "Concatenate two tokens into a longer token.
-Currently support only simple token concatenation. Also support weird (but
-valid) token concatenation like `>' ## `>' becomes `>>'. Here we take care only
-those that can be evaluated during preprocessing time and ignore all those that
-can only be evaluated at C(++) runtime (like `++', `--' and `+='...)."
- (if (or (memq a hif-valid-token-list)
- (memq b hif-valid-token-list))
- (let* ((ra (car (rassq a hif-token-alist)))
- (rb (car (rassq b hif-token-alist)))
- (result (and ra rb
- (cdr (assoc (concat ra rb) hif-token-alist)))))
- (or result
- ;;(error "Invalid token to concatenate")
- (error "Concatenating \"%s\" and \"%s\" does not give a valid \
-preprocessing token"
- (or ra (symbol-name a))
- (or rb (symbol-name b)))))
- (intern-safe (concat (hif-stringify a)
- (hif-stringify b)))))
+(defun hif-token-concat (l)
+ "Concatenate a list of tokens into a longer token.
+Also support weird (but valid) token concatenation like `>' ## `>' becomes `>>'.
+Here we take care only those that can be evaluated during preprocessing time and
+ignore all those that can only be evaluated at C(++) runtime (like `++', `--'
+and `+='...)."
+ (let ((str nil))
+ (dolist (i l)
+ ;;(assert (not (eq i 'hif-space)) nil ;; debug
+ ;; "Internal error: should not be concatenating `hif-space'")
+ (setq str
+ (concat str
+ (if (memq i hif-valid-token-list)
+ (car (rassq i hif-token-alist))
+ (hif-stringify i)))))
+ ;; Check if it's a number, if yes, return the number instead of a symbol.
+ ;; 'hif-value and 'hif-space properties are trimmed off by `hif-stringify'
+ (hif-strtok str t)))
(defun hif-mathify (val)
- "Treat VAL as a number: if it's t or nil, use 1 or 0."
- (cond ((eq val t) 1)
- ((null val) 0)
- (t val)))
+ "Treat VAL as a hideif number: if it's t or nil, use 1 or 0."
+ (cond
+ ((stringp val)
+ (or (get-text-property 0 'hif-value val)
+ val))
+ ((eq val t) 1)
+ ((null val) 0)
+ (t val)))
(defun hif-conditional (a b c)
(if (not (zerop (hif-mathify a))) (hif-mathify b) (hif-mathify c)))
@@ -1053,49 +1514,108 @@ preprocessing token"
(defalias 'hif-logxor (hif-mathify-binop logxor))
(defalias 'hif-logand (hif-mathify-binop logand))
+(defun hif-__LINE__ ()
+ (line-number-at-pos))
+
+(defun hif-__FILE__ ()
+ (file-name-nondirectory (buffer-file-name)))
+
+(defvar hif-__COUNTER__ 0)
+(defun hif-__COUNTER__ ()
+ (prog1 hif-__COUNTER__ (cl-incf hif-__COUNTER__)))
+
+(defun hif-__cplusplus ()
+ (and (string-match
+ "\\.c\\(c\\|xx\\|pp\\|\\+\\+\\)\\'"
+ (buffer-file-name))
+ (memq major-mode '(c++-mode cc-mode cpp-mode))
+ 201710))
+
+(defun hif-__DATE__ ()
+ (format-time-string "%Y/%m/%d"))
+
+(defun hif-__TIME__ ()
+ (format-time-string "%H:%M:%S"))
+
+(defun hif-__STDC__ () 1)
+(defun hif-__STDC_VERSION__ () 201710)
+(defun hif-__STDC_HOST__ () 1)
(defun hif-comma (&rest expr)
"Evaluate a list of EXPR, return the result of the last item."
(let ((result nil))
- (dolist (e expr)
+ (dolist (e expr result)
(ignore-errors
- (setq result (funcall hide-ifdef-evaluator e))))
- result))
+ (setq result (funcall hide-ifdef-evaluator e))))))
(defun hif-token-stringification (l)
- "Scan token list for `hif-stringify' ('#') token and stringify the next token."
- (let (result)
- (while l
- (push (if (eq (car l) 'hif-stringify)
- (prog1
- (if (cadr l)
- (hif-stringify (cadr l))
- (error "No token to stringify"))
- (setq l (cdr l)))
- (car l))
- result)
- (setq l (cdr l)))
- (nreverse result)))
+ "Scan token list for `hif-stringify' (`#') token and stringify the next token."
+ (if (memq 'hif-stringify l)
+ (let (result)
+ (while l
+ (push (if (eq (car l) 'hif-stringify)
+ (prog1
+ (if (cadr l)
+ (hif-stringify (cadr l))
+ (error "No token to stringify"))
+ (setq l (cdr l)))
+ (car l))
+ result)
+ (setq l (cdr l)))
+ (nreverse result))
+ ;; no `#' presents
+ l))
(defun hif-token-concatenation (l)
- "Scan token list for `hif-token-concat' ('##') token and concatenate two tokens."
- (let ((prev nil)
- result)
- (while l
- (while (eq (car l) 'hif-token-concat)
- (unless prev
- (error "No token before ## to concatenate"))
- (unless (cdr l)
- (error "No token after ## to concatenate"))
- (setq prev (hif-token-concat prev (cadr l)))
- (setq l (cddr l)))
- (if prev
- (setq result (append result (list prev))))
- (setq prev (car l)
- l (cdr l)))
- (if prev
- (append result (list prev))
- result)))
+ "Scan token list for `hif-token-concat' ('##') token and concatenate tokens."
+ (if (memq 'hif-token-concat l)
+ ;; Notice that after some substitutions, there could be more than
+ ;; one `hif-space' in a list.
+ (let ((items nil)
+ (tk nil)
+ (count 0) ; count of `##'
+ result)
+ (setq l (hif-keep-single l 'hif-space))
+ (while (setq tk (car l))
+ (if (not (eq tk 'hif-token-concat))
+ ;; In reverse order so that we don't have to use `last' or
+ ;; `butlast'
+ (progn
+ (push tk result)
+ (setq l (cdr l)))
+ ;; First `##' met, start `##' sequence
+ ;; We only drop `hif-space' when doing token concatenation
+ (setq items nil
+ count 0)
+ (setq tk (pop result))
+ (if (or (null tk)
+ (and (eq tk 'hif-space)
+ (null (setq tk (pop result)))))
+ (error "No token before `##' to concatenate")
+ (push tk items) ; first item, in reverse order
+ (setq tk 'hif-token-concat))
+ (while (eq tk 'hif-token-concat)
+ (cl-incf count)
+ ;; 2+ item
+ (setq l (cdr l)
+ tk (car l))
+ ;; only one 'hif-space could appear here
+ (if (eq tk 'hif-space) ; ignore it
+ (setq l (cdr l)
+ tk (car l)))
+ (if (or (null tk)
+ (eq tk 'hif-token-concat))
+ (error
+ "No token after the %d-th `##' to concatenate at line %d"
+ count (line-number-at-pos))
+ (push tk items)
+ (setq l (cdr l)
+ tk (car l))))
+ ;; `##' sequence ended, concat them, then push into result
+ (push (hif-token-concat (nreverse items)) result)))
+ (nreverse result))
+ ;; no need to reassemble the list if no `##' presents
+ l))
(defun hif-delimit (lis atom)
(nconc (mapcan (lambda (l) (list l atom))
@@ -1105,7 +1625,7 @@ preprocessing token"
;; Perform token replacement:
(defun hif-macro-supply-arguments (macro-name actual-parms)
"Expand a macro call, replace ACTUAL-PARMS in the macro body."
- (let* ((SA (assoc macro-name hide-ifdef-env))
+ (let* ((SA (assq macro-name hide-ifdef-env))
(macro (and SA
(cdr SA)
(eq (cadr SA) 'hif-define-macro)
@@ -1156,11 +1676,14 @@ preprocessing token"
formal macro-body))
(setq actual-parms (cdr actual-parms)))
- ;; Replacement completed, flatten the whole token list
- (setq macro-body (flatten-tree macro-body))
+ ;; Replacement completed, stringifiy and concatenate the token list.
+ ;; Stringification happens must take place before flattening, otherwise
+ ;; only the first token will be stringified.
+ (setq macro-body
+ (flatten-tree (hif-token-stringification macro-body)))
- ;; Stringification and token concatenation happens here
- (hif-token-concatenation (hif-token-stringification macro-body)))))
+ ;; Token concatenation happens here, keep single 'hif-space
+ (hif-keep-single (hif-token-concatenation macro-body) 'hif-space))))
(defun hif-invoke (macro-name actual-parms)
"Invoke a macro by expanding it, reparse macro-body and finally invoke it."
@@ -1432,7 +1955,7 @@ Point is left unchanged."
;; A bit slimy.
(defun hif-hide-line (point)
- "Hide the line containing point.
+ "Hide the line containing POINT.
Does nothing if `hide-ifdef-lines' is nil."
(when hide-ifdef-lines
(save-excursion
@@ -1441,7 +1964,7 @@ Does nothing if `hide-ifdef-lines' is nil."
(line-beginning-position) (progn (hif-end-of-line) (point))))))
-;; Hif-Possibly-Hide
+;; hif-Possibly-Hide
;; There are four cases. The #ifX expression is "taken" if it
;; the hide-ifdef-evaluator returns T. Presumably, this means the code
;; inside the #ifdef would be included when the program was
@@ -1484,13 +2007,13 @@ Does nothing if `hide-ifdef-lines' is nil."
"Called at #ifX expression, this hides those parts that should be hidden.
It uses the judgment of `hide-ifdef-evaluator'. EXPAND-REINCLUSION is a flag
indicating that we should expand the #ifdef even if it should be hidden.
-Refer to `hide-ifdef-expand-reinclusion-protection' for more details."
+Refer to `hide-ifdef-expand-reinclusion-guard' for more details."
;; (message "hif-possibly-hide") (sit-for 1)
(let* ((case-fold-search nil)
(test (hif-canonicalize hif-ifx-regexp))
(range (hif-find-range))
(elifs (hif-range-elif range))
- (if-part t) ; Everytime we start from if-part
+ (if-part t) ; Every time we start from if-part
(complete nil))
;; (message "test = %s" test) (sit-for 1)
@@ -1564,23 +2087,83 @@ Refer to `hide-ifdef-expand-reinclusion-protection' for more details."
(result (funcall hide-ifdef-evaluator expr)))
result))
+(defun hif-display-macro (name def &optional result)
+ (if (and def
+ (listp def)
+ (eq (car def) 'hif-define-macro))
+ (let ((cdef (concat "#define " name))
+ (parmlist (cadr def))
+ s)
+ (setq def (caddr def))
+ ;; parmlist
+ (when parmlist
+ (setq cdef (concat cdef "("))
+ (while (car parmlist)
+ (setq cdef (concat cdef (symbol-name (car parmlist))
+ (if (cdr parmlist) ","))
+ parmlist (cdr parmlist)))
+ (setq cdef (concat cdef ")")))
+ (setq cdef (concat cdef " "))
+ ;; body
+ (while def
+ (if (listp def)
+ (setq s (car def)
+ def (cdr def))
+ (setq s def
+ def nil))
+ (setq cdef
+ (concat cdef
+ (cond
+ ;;((setq tok (car (rassoc s hif-token-alist)))
+ ;; (concat tok (if (eq s 'hif-comma) " ")))
+ ((symbolp s)
+ (concat (hif-stringify s)
+ (if (eq s 'hif-comma) " ")))
+ ((stringp s)
+ (hif-stringify s))
+ (t ;; (numberp s)
+ (format "%S" s))))))
+ (if (and result
+ ;; eg: "#define RECURSIVE_SYMBOL RECURSIVE_SYMBOL"
+ (not (and (listp result)
+ (eq (car result) 'hif-define-macro))))
+ (setq cdef (concat cdef
+ (if (integerp result)
+ (format "\n=> %S (%#x)" result result)
+ (format "\n=> %S" result)))))
+ (message "%s" cdef))
+ (message "%S <= `%s'" def name)))
+
(defun hif-evaluate-macro (rstart rend)
"Evaluate the macro expansion result for the active region.
-If no region active, find the current #ifdefs and evaluate the result.
+If no region is currently active, find the current #ifdef/#define and evaluate
+the result; otherwise it looks for current word at point.
Currently it supports only math calculations, strings or argumented macros can
-not be expanded."
+not be expanded.
+This function by default ignores parsing error and return `false' on evaluating
+runtime C(++) statements or tokens that normal C(++) preprocessor can't perform;
+however, when this command is prefixed, it will display the error instead."
(interactive
- (if (use-region-p)
- (list (region-beginning) (region-end))
- '(nil nil)))
- (let ((case-fold-search nil))
+ (if (not (use-region-p))
+ '(nil nil)
+ (list (region-beginning) (region-end))))
+ (run-hooks 'hide-ifdef-evalulate-enter-hook)
+ (let ((case-fold-search nil)
+ (currpnt (point))
+ bounds)
(save-excursion
(unless (use-region-p)
(setq rstart nil rend nil)
(beginning-of-line)
- (when (and (re-search-forward hif-macro-expr-prefix-regexp nil t)
- (string= "define" (match-string 2)))
- (re-search-forward hif-macroref-regexp nil t)))
+ (if (and (re-search-forward hif-macro-expr-prefix-regexp nil t)
+ (= (line-number-at-pos currpnt) (line-number-at-pos)))
+ (if (string= "define" (match-string 2))
+ (re-search-forward hif-macroref-regexp nil t))
+ (goto-char currpnt)
+ (setq bounds (bounds-of-thing-at-point 'word)
+ ;; TODO: BOUNDS need a C++ syntax word boundary finder
+ rstart (car bounds)
+ rend (cdr bounds))))
(let* ((start (or rstart (point)))
(end (or rend (progn (hif-end-of-line) (point))))
(defined nil)
@@ -1588,34 +2171,61 @@ not be expanded."
(tokens (ignore-errors ; Prevent C statement things like
; 'do { ... } while (0)'
(hif-tokenize start end)))
+ ;; Note that on evaluating we can't simply define the symbol
+ ;; even if we are currently at a #define line, as this #define
+ ;; might actually be wrapped up in a #if 0 block. We can only
+ ;; define that explicitly with `hide-ifdef-define'.
(expr (or (and (<= (length tokens) 1) ; Simple token
- (setq defined (assoc (car tokens) hide-ifdef-env))
+ (setq defined
+ (or (assq (car tokens) hide-ifdef-env)
+ (assq (car tokens) hif-predefine-alist)))
(setq simple (atom (hif-lookup (car tokens))))
(hif-lookup (car tokens)))
(and tokens
- (condition-case nil
+ (condition-case err
(hif-parse-exp tokens)
(error
- nil)))))
- (result (funcall hide-ifdef-evaluator expr))
- (exprstring (replace-regexp-in-string
- ;; Trim off leading/trailing whites
- "^[ \t]*\\([^ \t]+\\)[ \t]*" "\\1"
- (replace-regexp-in-string
- "\\(//.*\\)" "" ; Trim off end-of-line comments
- (buffer-substring-no-properties start end)))))
- (cond
- ((and (<= (length tokens) 1) simple) ; Simple token
- (if defined
- (message "%S <= `%s'" result exprstring)
- (message "`%s' is not defined" exprstring)))
- ((integerp result)
- (if (or (= 0 result) (= 1 result))
- (message "%S <= `%s'" result exprstring)
- (message "%S (%#x) <= `%s'" result result exprstring)))
- ((null result) (message "%S <= `%s'" 'false exprstring))
- ((eq t result) (message "%S <= `%s'" 'true exprstring))
- (t (message "%S <= `%s'" result exprstring)))
+ ;; when prefixed, pass the error on for later
+ ;; `hide-ifdef-evaluator'
+ (if current-prefix-arg err))))))
+ (exprstring (hif-stringify tokens))
+ (result (condition-case err
+ (funcall hide-ifdef-evaluator expr)
+ ;; in case of arithmetic error or others
+ (error (error "Error: line %d %S when evaluating `%s'"
+ (line-number-at-pos) err exprstring)))))
+ (setq
+ result
+ (cond
+ ((= (length tokens) 0)
+ (message "`%s'" exprstring))
+ ((= (length tokens) 1) ; Simple token
+ (if simple
+ (if defined
+ (hif-display-macro exprstring result)
+ (if (and (hif-is-number exprstring)
+ result (numberp result))
+ (message "%S (%#x)" result result)
+ (if (and (hif-is-float exprstring)
+ result (numberp result))
+ (message "%S (%s)" result exprstring)
+ (if (string-match hif-string-literal-regexp exprstring)
+ (message "%s" exprstring)
+ (message "`%s' is not defined" exprstring)))))
+ (if defined
+ (hif-display-macro exprstring (cdr defined) result)
+ (message "`%s' is not defined" exprstring))))
+ ((integerp result)
+ (if (or (= 0 result) (= 1 result))
+ (message "%S <= `%s'" result exprstring)
+ (message "%S (%#x) <= `%s'" result result exprstring)))
+ ((null result)
+ (message "%S <= `%s'" 'false exprstring))
+ ((eq t result)
+ (message "%S <= `%s'" 'true exprstring))
+ (t
+ (message "%S <= `%s'" result exprstring))))
+ (run-hooks 'hide-ifdef-evalulate-leave-hook)
result))))
(defun hif-parse-macro-arglist (str)
@@ -1650,7 +2260,7 @@ first arg will be `hif-etc'."
;; postponed the evaluation process one stage and store the "parsed tree"
;; into symbol database. The evaluation process was then "strings -> tokens
;; -> [parsed tree] -> value". Hideif therefore run slower since it need to
-;; evaluate the parsed tree everytime when trying to expand the symbol. These
+;; evaluate the parsed tree every time when trying to expand the symbol. These
;; temporarily code changes are obsolete and not in Emacs source repository.
;;
;; Furthermore, CPP did allow partial expression to be defined in several
@@ -1659,7 +2269,7 @@ first arg will be `hif-etc'."
;; further, otherwise those partial expression will be fail on parsing and
;; we'll miss all macros that reference it. The evaluation process thus
;; became "strings -> [tokens] -> parsed tree -> value." This degraded the
-;; performance since we need to parse tokens and evaluate them everytime
+;; performance since we need to parse tokens and evaluate them every time
;; when that symbol is referenced.
;;
;; In real cases I found a lot portion of macros are "simple macros" that
@@ -1667,6 +2277,8 @@ first arg will be `hif-etc'."
;; the performance I use this `hif-simple-token-only' to notify my code and
;; save the final [value] into symbol database. [lukelee]
+(defvar hif-verbose-define-count 0)
+
(defun hif-find-define (&optional min max)
"Parse texts and retrieve all defines within the region MIN and MAX."
(interactive)
@@ -1676,8 +2288,11 @@ first arg will be `hif-etc'."
(let* ((defining (string= "define" (match-string 2)))
(name (and (re-search-forward hif-macroref-regexp max t)
(match-string 1)))
- (parmlist (and (match-string 3) ; First arg id found
- (hif-parse-macro-arglist (match-string 2)))))
+ (parmlist (or (and (match-string 3) ; First arg id found
+ (delq 'hif-space
+ (hif-parse-macro-arglist (match-string 2))))
+ (and (match-string 2) ; empty arglist
+ (list nil)))))
(if defining
;; Ignore name (still need to return 't), or define the name
(or (and hide-ifdef-exclude-define-regexp
@@ -1689,6 +2304,14 @@ first arg will be `hif-etc'."
(hif-simple-token-only nil) ; Dynamic binding
(tokens
(and name
+ (prog1 t
+ (cl-incf hif-verbose-define-count)
+ ;; only show 1/50 to not slow down to much
+ (if (and hide-ifdef-verbose
+ (= (% hif-verbose-define-count 50) 1))
+ (message "[Line %d] defining %S"
+ (line-number-at-pos (point))
+ (substring-no-properties name))))
;; `hif-simple-token-only' is set/clear
;; only in this block
(condition-case nil
@@ -1700,8 +2323,10 @@ first arg will be `hif-etc'."
;; this will stop hideif from searching
;; for more #defines.
(setq hif-simple-token-only t)
- (buffer-substring-no-properties
- start end)))))
+ (replace-regexp-in-string
+ "^[ \t]*\\|[ \t]*$" ""
+ (buffer-substring-no-properties
+ start end))))))
;; For simple tokens we save only the parsed result;
;; otherwise we save the tokens and parse it after
;; parameter replacement
@@ -1715,17 +2340,19 @@ first arg will be `hif-etc'."
`(hif-define-macro ,parmlist
,tokens))))
(SA (and name
- (assoc (intern name) hide-ifdef-env))))
+ (assq (intern name) hide-ifdef-env))))
(and name
(if SA
(or (setcdr SA expr) t)
- ;; Lazy evaluation, eval only if hif-lookup find it.
+ ;; Lazy evaluation, eval only if `hif-lookup' find it.
;; Define it anyway, even if nil it's still in list
;; and therefore considered defined.
(push (cons (intern name) expr) hide-ifdef-env)))))
;; #undef
(and name
- (hif-undefine-symbol (intern name))))))
+ (intern-soft name)
+ (hif-undefine-symbol (intern name)))
+ t)))
t))
@@ -1735,7 +2362,10 @@ first arg will be `hif-etc'."
(save-excursion
(save-restriction
;; (mark-region min max) ;; for debugging
+ (setq hif-verbose-define-count 0)
+ (forward-comment (point-max))
(while (hif-find-define min max)
+ (forward-comment (point-max))
(setf min (point)))
(if max (goto-char max)
(goto-char (point-max))))))
@@ -1743,24 +2373,33 @@ first arg will be `hif-etc'."
(defun hide-ifdef-guts ()
"Does most of the work of `hide-ifdefs'.
It does not do the work that's pointless to redo on a recursive entry."
- ;; (message "hide-ifdef-guts")
(save-excursion
(let* ((case-fold-search t) ; Ignore case for `hide-ifdef-header-regexp'
- (expand-header (and hide-ifdef-expand-reinclusion-protection
+ (expand-header (and hide-ifdef-expand-reinclusion-guard
+ (buffer-file-name)
(string-match hide-ifdef-header-regexp
(buffer-file-name))
(zerop hif-recurse-level)))
(case-fold-search nil)
min max)
+ (setq hif-__COUNTER__ 0)
(goto-char (point-min))
(setf min (point))
- (cl-loop do
- (setf max (hif-find-any-ifX))
- (hif-add-new-defines min max)
- (if max
- (hif-possibly-hide expand-header))
- (setf min (point))
- while max))))
+ ;; Without this `condition-case' it would be easier to see which
+ ;; operation went wrong thru the backtrace `iff' user realize
+ ;; the underlying meaning of all hif-* operation; for example,
+ ;; `hif-shiftleft' refers to C(++) '<<' operator and floating
+ ;; operation arguments would be invalid.
+ (condition-case err
+ (cl-loop do
+ (setf max (hif-find-any-ifX))
+ (hif-add-new-defines min max)
+ (if max
+ (hif-possibly-hide expand-header))
+ (setf min (point))
+ while max)
+ (error (error "Error: failed at line %d %S"
+ (line-number-at-pos) err))))))
;;===%%SF%% hide-ifdef-hiding (End) ===
@@ -1792,7 +2431,7 @@ It does not do the work that's pointless to redo on a recursive entry."
(defun hide-ifdef-toggle-shadowing ()
"Toggle shadowing."
(interactive)
- (set (make-local-variable 'hide-ifdef-shadow) (not hide-ifdef-shadow))
+ (setq-local hide-ifdef-shadow (not hide-ifdef-shadow))
(message "Shadowing %s" (if hide-ifdef-shadow "ON" "OFF"))
(save-restriction
(widen)
@@ -1821,13 +2460,17 @@ This allows #ifdef VAR to be hidden."
nil nil t nil "1")))
(list var val)))
(hif-set-var var (or val 1))
- (message "%s set to %s" var (or val 1))
- (sleep-for 1)
- (if hide-ifdef-hiding (hide-ifdefs)))
+ (if hide-ifdef-hiding (hide-ifdefs))
+ (message "%s set to %s" var (or val 1)))
(defun hif-undefine-symbol (var)
- (setq hide-ifdef-env
- (delete (assoc var hide-ifdef-env) hide-ifdef-env)))
+ (when (assq var hide-ifdef-env)
+ (setq hide-ifdef-env
+ (delete (assq var hide-ifdef-env) hide-ifdef-env))
+ ;; We can override things in `hif-predefine-alist' so keep them
+ (unless (assq var hif-predefine-alist)
+ (unintern (symbol-name var) nil))
+ t))
(defun hide-ifdef-undef (start end)
"Undefine a VAR so that #ifdef VAR would not be included."
@@ -1848,35 +2491,54 @@ This allows #ifdef VAR to be hidden."
(if hide-ifdef-hiding (hide-ifdefs))
(message "`%S' undefined" sym))))
-(defun hide-ifdefs (&optional nomsg)
+(defun hide-ifdefs (&optional start end nomsg)
"Hide the contents of some #ifdefs.
Assume that defined symbols have been added to `hide-ifdef-env'.
The text hidden is the text that would not be included by the C
preprocessor if it were given the file with those symbols defined.
With prefix command presents it will also hide the #ifdefs themselves.
+Hiding will only be performed within the marked region if there is one.
+
Turn off hiding by calling `show-ifdefs'."
- (interactive)
- (let ((hide-ifdef-lines current-prefix-arg))
- (or nomsg
- (message "Hiding..."))
- (setq hif-outside-read-only buffer-read-only)
- (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; Turn on hide-ifdef-mode
- (if hide-ifdef-hiding
- (show-ifdefs)) ; Otherwise, deep confusion.
- (setq hide-ifdef-hiding t)
- (hide-ifdef-guts)
- (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))
- (or nomsg
- (message "Hiding done"))))
-
-
-(defun show-ifdefs ()
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+
+ (setq current-prefix-arg (or hide-ifdef-lines current-prefix-arg))
+ (save-restriction
+ (let* ((hide-ifdef-lines current-prefix-arg)
+ (outer-hide-ifdef-verbose hide-ifdef-verbose)
+ (hide-ifdef-verbose (and outer-hide-ifdef-verbose
+ (not (or nomsg (use-region-p)))))
+ (hide-start-time (current-time)))
+ (and hide-ifdef-verbose
+ (message "Hiding..."))
+ (setq hif-outside-read-only buffer-read-only)
+ (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; Turn on hide-ifdef-mode
+ (if hide-ifdef-hiding
+ (show-ifdefs)) ; Otherwise, deep confusion.
+ (setq hide-ifdef-hiding t)
+ (narrow-to-region (or start (point-min)) (or end (point-max)))
+ (hide-ifdef-guts)
+ (setq buffer-read-only
+ (or hide-ifdef-read-only hif-outside-read-only))
+ (and hide-ifdef-verbose
+ (message "Hiding done, %.1f seconds elapsed"
+ (float-time (time-subtract (current-time)
+ hide-start-time)))))))
+
+
+(defun show-ifdefs (&optional start end)
"Cancel the effects of `hide-ifdef': show the contents of all #ifdefs."
- (interactive)
+ (interactive
+ (if (use-region-p)
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
(setq buffer-read-only hif-outside-read-only)
- (hif-show-all)
+ (hif-show-all (or start (point-min)) (or end (point-max)))
(setq hide-ifdef-hiding nil))
@@ -1960,21 +2622,17 @@ With optional prefix argument ARG, also hide the #ifdefs themselves."
;;; definition alist support
+;; The old implementation that match symbol only to 't is now considered
+;; obsolete.
(defvar hide-ifdef-define-alist nil
"A global assoc list of pre-defined symbol lists.")
-(defun hif-compress-define-list (env)
- "Compress the define list ENV into a list of defined symbols only."
- (let ((new-defs nil))
- (dolist (def env new-defs)
- (if (hif-lookup (car def)) (push (car def) new-defs)))))
-
(defun hide-ifdef-set-define-alist (name)
"Set the association for NAME to `hide-ifdef-env'."
(interactive "SSet define list: ")
- (push (cons name (hif-compress-define-list hide-ifdef-env))
- hide-ifdef-define-alist))
+ (push (cons name hide-ifdef-env)
+ hide-ifdef-define-alist))
(defun hide-ifdef-use-define-alist (name)
"Set `hide-ifdef-env' to the define list specified by NAME."
@@ -1986,9 +2644,8 @@ With optional prefix argument ARG, also hide the #ifdefs themselves."
(if (stringp name) (setq name (intern name)))
(let ((define-list (assoc name hide-ifdef-define-alist)))
(if define-list
- (setq hide-ifdef-env
- (mapcar (lambda (arg) (cons arg t))
- (cdr define-list)))
+ (setq hide-ifdef-env
+ (cdr define-list))
(error "No define list for %s" name))
(if hide-ifdef-hiding (hide-ifdefs))))
diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el
index 66e57191648..b2557587c6c 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -232,13 +232,11 @@
(defcustom hs-hide-comments-when-hiding-all t
"Hide the comments too when you do an `hs-hide-all'."
- :type 'boolean
- :group 'hideshow)
+ :type 'boolean)
(defcustom hs-minor-mode-hook nil
"Hook called when hideshow minor mode is activated or deactivated."
:type 'hook
- :group 'hideshow
:version "21.1")
(defcustom hs-isearch-open 'code
@@ -254,8 +252,7 @@ This has effect only if `search-invisible' is set to `open'."
:type '(choice (const :tag "open only code blocks" code)
(const :tag "open only comment blocks" comment)
(const :tag "open both code and comment blocks" t)
- (const :tag "don't open any of them" nil))
- :group 'hideshow)
+ (const :tag "don't open any of them" nil)))
;;;###autoload
(defvar hs-special-modes-alist
@@ -264,7 +261,10 @@ This has effect only if `search-invisible' is set to `open'."
(c++-mode "{" "}" "/[*/]" nil nil)
(bibtex-mode ("@\\S(*\\(\\s(\\)" 1))
(java-mode "{" "}" "/[*/]" nil nil)
- (js-mode "{" "}" "/[*/]" nil)))
+ (js-mode "{" "}" "/[*/]" nil)
+ (mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil)
+ ;; Add more support here.
+ ))
"Alist for initializing the hideshow variables for different modes.
Each element has the form
(MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC).
@@ -310,7 +310,7 @@ a block), `hs-hide-all', `hs-hide-block' and `hs-hide-level'.")
These commands include the toggling commands (when the result is to show
a block), `hs-show-all' and `hs-show-block'.")
-(defvar hs-set-up-overlay #'ignore
+(defcustom hs-set-up-overlay #'ignore
"Function called with one arg, OV, a newly initialized overlay.
Hideshow puts a unique overlay on each range of text to be hidden
in the buffer. Here is a simple example of how to use this variable:
@@ -326,7 +326,9 @@ in the buffer. Here is a simple example of how to use this variable:
This example shows how to get information from the overlay as well
as how to set its `display' property. See `hs-make-overlay' and
-info node `(elisp)Overlays'.")
+info node `(elisp)Overlays'."
+ :type 'function
+ :version "28.1")
;;---------------------------------------------------------------------------
;; internal variables
@@ -945,8 +947,7 @@ Key bindings:
(add-hook 'change-major-mode-hook
#'turn-off-hideshow
nil t)
- (easy-menu-add hs-minor-mode-menu)
- (set (make-local-variable 'line-move-ignore-invisible) t)
+ (setq-local line-move-ignore-invisible t)
(add-to-invisibility-spec '(hs . t)))
(remove-from-invisibility-spec '(hs . t))
;; hs-show-all does nothing unless h-m-m is non-nil.
diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el
index 330bfa8cff5..e9a21d4a0cf 100644
--- a/lisp/progmodes/icon.el
+++ b/lisp/progmodes/icon.el
@@ -1,4 +1,4 @@
-;;; icon.el --- mode for editing Icon code
+;;; icon.el --- mode for editing Icon code -*- lexical-binding: t -*-
;; Copyright (C) 1989, 2001-2021 Free Software Foundation, Inc.
@@ -31,53 +31,48 @@
"Abbrev table in use in Icon-mode buffers.")
(define-abbrev-table 'icon-mode-abbrev-table ())
-(defvar icon-mode-map ()
- "Keymap used in Icon mode.")
-(if icon-mode-map
- ()
+(defvar icon-mode-map
(let ((map (make-sparse-keymap "Icon")))
- (setq icon-mode-map (make-sparse-keymap))
- (define-key icon-mode-map "{" 'electric-icon-brace)
- (define-key icon-mode-map "}" 'electric-icon-brace)
- (define-key icon-mode-map "\e\C-h" 'mark-icon-function)
- (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun)
- (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun)
- (define-key icon-mode-map "\e\C-q" 'indent-icon-exp)
- (define-key icon-mode-map "\177" 'backward-delete-char-untabify)
-
- (define-key icon-mode-map [menu-bar] (make-sparse-keymap "Icon"))
- (define-key icon-mode-map [menu-bar icon]
- (cons "Icon" map))
- (define-key map [beginning-of-icon-defun] '("Beginning of function" . beginning-of-icon-defun))
- (define-key map [end-of-icon-defun] '("End of function" . end-of-icon-defun))
- (define-key map [comment-region] '("Comment Out Region" . comment-region))
- (define-key map [indent-region] '("Indent Region" . indent-region))
- (define-key map [indent-line] '("Indent Line" . icon-indent-command))
- (put 'eval-region 'menu-enable 'mark-active)
- (put 'comment-region 'menu-enable 'mark-active)
- (put 'indent-region 'menu-enable 'mark-active)))
-
-(defvar icon-mode-syntax-table nil
- "Syntax table in use in Icon-mode buffers.")
+ (define-key map "{" 'electric-icon-brace)
+ (define-key map "}" 'electric-icon-brace)
+ (define-key map "\e\C-h" 'mark-icon-function)
+ (define-key map "\e\C-a" 'beginning-of-icon-defun)
+ (define-key map "\e\C-e" 'end-of-icon-defun)
+ (define-key map "\e\C-q" 'indent-icon-exp)
+ (define-key map "\177" 'backward-delete-char-untabify)
+ map)
+ "Keymap used in Icon mode.")
-(if icon-mode-syntax-table
- ()
- (setq icon-mode-syntax-table (make-syntax-table))
- (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table)
- (modify-syntax-entry ?# "<" icon-mode-syntax-table)
- (modify-syntax-entry ?\n ">" icon-mode-syntax-table)
- (modify-syntax-entry ?$ "." icon-mode-syntax-table)
- (modify-syntax-entry ?/ "." icon-mode-syntax-table)
- (modify-syntax-entry ?* "." icon-mode-syntax-table)
- (modify-syntax-entry ?+ "." icon-mode-syntax-table)
- (modify-syntax-entry ?- "." icon-mode-syntax-table)
- (modify-syntax-entry ?= "." icon-mode-syntax-table)
- (modify-syntax-entry ?% "." icon-mode-syntax-table)
- (modify-syntax-entry ?< "." icon-mode-syntax-table)
- (modify-syntax-entry ?> "." icon-mode-syntax-table)
- (modify-syntax-entry ?& "." icon-mode-syntax-table)
- (modify-syntax-entry ?| "." icon-mode-syntax-table)
- (modify-syntax-entry ?\' "\"" icon-mode-syntax-table))
+(easy-menu-define icon-mode-menu icon-mode-map
+ "Menu for Icon mode."
+ '("Icon"
+ ["Beginning of function" beginning-of-icon-defun]
+ ["Comment Out Region" comment-region
+ :enable mark-active]
+ ["End of function" end-of-icon-defun]
+ ["Indent Line" icon-indent-command]
+ ["Indent Region" indent-region
+ :enable mark-active]))
+
+(defvar icon-mode-syntax-table
+ (let ((table (make-syntax-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)
+ (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)
+ (modify-syntax-entry ?\' "\"" table)
+ table)
+ "Syntax table in use in Icon-mode buffers.")
(defgroup icon nil
"Mode for editing Icon code."
@@ -86,42 +81,35 @@
(defcustom icon-indent-level 4
"Indentation of Icon statements with respect to containing block."
- :type 'integer
- :group 'icon)
+ :type 'integer)
(defcustom icon-brace-imaginary-offset 0
"Imagined indentation of an Icon open brace that actually follows a statement."
- :type 'integer
- :group 'icon)
+ :type 'integer)
(defcustom icon-brace-offset 0
"Extra indentation for braces, compared with other text in same context."
- :type 'integer
- :group 'icon)
+ :type 'integer)
(defcustom icon-continued-statement-offset 4
"Extra indent for Icon lines not starting new statements."
- :type 'integer
- :group 'icon)
+ :type 'integer)
(defcustom icon-continued-brace-offset 0
"Extra indent for Icon substatements that start with open-braces.
This is in addition to `icon-continued-statement-offset'."
- :type 'integer
- :group 'icon)
+ :type 'integer)
(defcustom icon-auto-newline nil
"Non-nil means automatically newline before and after braces Icon code.
This applies when braces are inserted."
- :type 'boolean
- :group 'icon)
+ :type 'boolean)
(defcustom icon-tab-always-indent t
"Non-nil means TAB in Icon mode should always reindent the current line.
It will then reindent, regardless of where in the line point is
when the TAB command is used."
- :type 'boolean
- :group 'icon)
+ :type 'boolean)
(defvar icon-imenu-generic-expression
'((nil "^[ \t]*procedure[ \t]+\\(\\sw+\\)[ \t]*(" 1))
@@ -163,25 +151,24 @@ 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."
: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)
+ (setq-local paragraph-start (concat "$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local indent-line-function #'icon-indent-line)
+ (setq-local comment-start "# ")
+ (setq-local comment-end "")
+ (setq-local comment-start-skip "# *")
+ (setq-local comment-indent-function 'icon-comment-indent)
+ (setq-local indent-line-function 'icon-indent-line)
;; font-lock support
- (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)))
+ (setq-local 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
- (set (make-local-variable 'imenu-generic-expression)
- icon-imenu-generic-expression)
+ (setq-local 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)
@@ -210,12 +197,11 @@ with no args, if that value is non-nil."
(progn
(insert last-command-event)
(icon-indent-line)
- (if icon-auto-newline
- (progn
- (newline)
- ;; (newline) may have done auto-fill
- (setq insertpos (- (point) 2))
- (icon-indent-line)))
+ (when icon-auto-newline
+ (newline)
+ ;; (newline) may have done auto-fill
+ (setq insertpos (- (point) 2))
+ (icon-indent-line))
(save-excursion
(if insertpos (goto-char (1+ insertpos)))
(delete-char -1))))
diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el
index 68fb05e1015..6d2d402e358 100644
--- a/lisp/progmodes/idlw-complete-structtag.el
+++ b/lisp/progmodes/idlw-complete-structtag.el
@@ -1,4 +1,4 @@
-;;; idlw-complete-structtag.el --- Completion of structure tags.
+;;; idlw-complete-structtag.el --- Completion of structure tags. -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -49,15 +49,14 @@
;;
;; New versions of IDLWAVE, documentation, and more information available
;; from:
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;; INSTALLATION
;; ============
-;; Put this file on the emacs load path and load it with the following
-;; line in your init file:
+;; Load it with the following line in your init file:
;;
-;; (add-hook 'idlwave-load-hook
-;; (lambda () (require 'idlw-complete-structtag)))
+;; (with-eval-after-load 'idlwave
+;; (require 'idlw-complete-structtag))
;;
;; DESCRIPTION
;; ===========
@@ -101,12 +100,11 @@
(defvar idlwave-sint-structtags nil)
;; Create the sintern type for structure talks
-(declare-function idlwave-sintern-structtag "idlw-complete-structtag" t t)
-(idlwave-new-sintern-type 'structtag)
+(idlwave-new-sintern-type structtag)
;; Hook the plugin into idlwave
-(add-to-list 'idlwave-complete-special 'idlwave-complete-structure-tag)
-(add-hook 'idlwave-update-rinfo-hook 'idlwave-structtag-reset)
+(add-hook 'idlwave-complete-functions #'idlwave-complete-structure-tag)
+(add-hook 'idlwave-update-rinfo-hook #'idlwave-structtag-reset)
;;; The main code follows below
(defvar idlwave-completion-help-info)
diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el
index ad0f86a2c69..db76df96a56 100644
--- a/lisp/progmodes/idlw-help.el
+++ b/lisp/progmodes/idlw-help.el
@@ -1,4 +1,4 @@
-;;; idlw-help.el --- HTML Help code for IDLWAVE
+;;; idlw-help.el --- HTML Help code for IDLWAVE -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;;
@@ -32,7 +32,7 @@
;; along with new versions of IDLWAVE, documentation, and more
;; information, at:
;;
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -50,7 +50,6 @@
(defcustom idlwave-html-help-pre-v6 nil
"Whether pre or post-v6.0 IDL help documents are being used."
- :group 'idlwave-online-help
:type 'boolean)
(defvar idlwave-html-link-sep
@@ -60,7 +59,6 @@
"The directory, relative to `idlwave-system-directory', where the IDL
HTML help files live, for IDL 6.2 and later. This location, if found,
is used in preference to the old `idlwave-html-help-location'."
- :group 'idlwave-online-help
:type 'directory)
(defcustom idlwave-html-help-location
@@ -69,7 +67,6 @@ is used in preference to the old `idlwave-html-help-location'."
"/usr/local/etc/")
"The directory where the idl_html_help/ dir lives. Obsolete for IDL
6.2 or later (see `idlwave-html-system-help-location')."
- :group 'idlwave-online-help
:type 'directory)
(defvar idlwave-help-use-hh nil
@@ -77,18 +74,15 @@ is used in preference to the old `idlwave-html-help-location'."
(defcustom idlwave-help-use-assistant t
"Whether to use the IDL Assistant as the help browser."
- :group 'idlwave-online-help
:type 'boolean)
(defcustom idlwave-help-browser-function browse-url-browser-function
"Function to use to display HTML help.
Defaults to `browse-url-browser-function', which see."
- :group 'idlwave-online-help
:type 'function)
(defcustom idlwave-help-browser-generic-program browse-url-generic-program
"Program to run if using `browse-url-generic-program'."
- :group 'idlwave-online-help
:type '(choice (const nil) string))
;; AFAICS, never used since it was introduced in 2004.
@@ -96,7 +90,6 @@ Defaults to `browse-url-browser-function', which see."
(if (boundp 'browse-url-generic-args)
browse-url-generic-args "")
"Program args to use if using `browse-url-generic-program'."
- :group 'idlwave-online-help
:type '(repeat string))
(defcustom idlwave-help-browser-is-local nil
@@ -106,7 +99,6 @@ external programs. If the browser name contains \"-w3\", it is
assumed to be local to Emacs. For other local browsers, this variable
must be explicitly set non-nil in order for the variable
`idlwave-help-use-dedicated-frame' to function."
- :group 'idlwave-online-help
:type 'boolean)
(defvar idlwave-help-directory ""
@@ -114,7 +106,6 @@ must be explicitly set non-nil in order for the variable
(defcustom idlwave-help-use-dedicated-frame t
"Non-nil means, use a separate frame for Online Help if possible."
- :group 'idlwave-online-help
:type 'boolean)
(defcustom idlwave-help-frame-parameters
@@ -123,14 +114,12 @@ must be explicitly set non-nil in order for the variable
See also `idlwave-help-use-dedicated-frame'.
If you do not set the frame width here, the value specified in
`idlw-help.el' will be used."
- :group 'idlwave-online-help
:type '(repeat
(cons symbol sexp)))
(defcustom idlwave-max-popup-menu-items 20
"Maximum number of items per pane in popup menus.
Currently only used for class selection during completion help."
- :group 'idlwave-online-help
:type 'integer)
(defcustom idlwave-extra-help-function 'idlwave-help-with-source
@@ -158,12 +147,10 @@ The default value for this function is `idlwave-help-with-source' which
loads the routine source file into the help buffer. If you try to write
a different function which accesses a special help file or so, it is
probably a good idea to still call this function as a fallback."
- :group 'idlwave-online-help
:type 'symbol)
(defcustom idlwave-help-fontify-source-code nil
"Non-nil means, fontify source code displayed as help like normal code."
- :group 'idlwave-online-help
:type 'boolean)
(defcustom idlwave-help-source-try-header t
@@ -173,7 +160,6 @@ help text. When this variable is non-nil, we try to find a description of
the help item in the first routine doclib header above the routine definition.
If the variable is nil, or if we cannot find/parse the header, the routine
definition is displayed instead."
- :group 'idlwave-online-help
:type 'boolean)
@@ -181,20 +167,17 @@ definition is displayed instead."
"A regexp for the heading word to search for in doclib headers
which specifies the `name' section. Can be used for localization
support."
- :group 'idlwave-online-help
- :type 'string)
+ :type 'regexp)
(defcustom idlwave-help-doclib-keyword "KEYWORD"
"A regexp for the heading word to search for in doclib headers
which specifies the `keywords' section. Can be used for localization
support."
- :group 'idlwave-online-help
- :type 'string)
+ :type 'regexp)
(defface idlwave-help-link
'((t :inherit link))
- "Face for highlighting links into IDLWAVE online help."
- :group 'idlwave-online-help)
+ "Face for highlighting links into IDLWAVE online help.")
(defvar idlwave-help-activate-links-aggressively nil
"Obsolete variable.")
@@ -219,20 +202,20 @@ support."
(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 "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-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map [delete] 'scroll-down-command)
- (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)
+ (define-key map " " #'scroll-up-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map [delete] #'scroll-down-command)
+ (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'.")
@@ -267,7 +250,6 @@ support."
(declare-function idlwave-find-class-definition "idlwave")
(declare-function idlwave-find-inherited-class "idlwave")
(declare-function idlwave-find-struct-tag "idlwave")
-(declare-function idlwave-get-buffer-visiting "idlwave")
(declare-function idlwave-in-quote "idlwave")
(declare-function idlwave-make-full-name "idlwave")
(declare-function idlwave-members-only "idlwave")
@@ -307,7 +289,6 @@ Jump: [h] to function doclib header
Here are all keybindings.
\\{idlwave-help-mode-map}"
(buffer-disable-undo)
- (easy-menu-add idlwave-help-menu idlwave-help-mode-map)
(setq truncate-lines t)
(setq case-fold-search t)
(setq mode-line-format
@@ -376,7 +357,7 @@ It collects and prints the diagnostics messages."
(setq idlwave-last-context-help-pos marker)
(idlwave-do-context-help1 arg)
(if idlwave-help-diagnostics
- (message "%s" (mapconcat 'identity
+ (message "%s" (mapconcat #'identity
(nreverse idlwave-help-diagnostics)
"; "))))))
@@ -386,6 +367,12 @@ It collects and prints the diagnostics messages."
(defvar idlwave-system-variables-alist)
(defvar idlwave-executive-commands-alist)
(defvar idlwave-system-class-info)
+(defvar idlwave-query-class)
+(defvar idlwave-force-class-query)
+(defvar idlw-help-name)
+(defvar idlw-help-kwd)
+(defvar idlw-help-link)
+
(defun idlwave-do-context-help1 (&optional arg)
"The work-horse version of `idlwave-context-help', which see."
(save-excursion
@@ -551,16 +538,16 @@ It collects and prints the diagnostics messages."
(setq mod1 (append (list t) module))))
(if mod3
(condition-case nil
- (apply 'idlwave-online-help mod1)
+ (apply #'idlwave-online-help mod1)
(error (condition-case nil
- (apply 'idlwave-online-help mod2)
- (error (apply 'idlwave-online-help mod3)))))
+ (apply #'idlwave-online-help mod2)
+ (error (apply #'idlwave-online-help mod3)))))
(if mod2
(condition-case nil
- (apply 'idlwave-online-help mod1)
- (error (apply 'idlwave-online-help mod2)))
+ (apply #'idlwave-online-help mod1)
+ (error (apply #'idlwave-online-help mod2)))
(if mod1
- (apply 'idlwave-online-help mod1)
+ (apply #'idlwave-online-help mod1)
(error "Don't know which item to show help for")))))))
(defun idlwave-do-mouse-completion-help (ev)
@@ -662,7 +649,7 @@ Those words in `idlwave-completion-help-links' have links. The
(props (list 'face 'idlwave-help-link))
(info idlwave-completion-help-info) ; global passed in
(what (nth 0 info)) ; what was completed, or a func
- (class (nth 3 info)) ; any class
+ ;; (class (nth 3 info)) ; any class
word beg end doit)
(goto-char (point-min))
(re-search-forward "possible completions are:" nil t)
@@ -687,7 +674,7 @@ Those words in `idlwave-completion-help-links' have links. The
;; Arrange for this function to be called after completion
(add-hook 'idlwave-completion-setup-hook
- 'idlwave-highlight-linked-completions)
+ #'idlwave-highlight-linked-completions)
(defvar idlwave-help-return-frame nil
"The frame to return to from the help frame.")
@@ -880,7 +867,7 @@ This function can be used as `idlwave-extra-help-function'."
(setq in-buf ; structure-tag completion is always in current buffer
(if struct-tag
idlwave-current-tags-buffer
- (idlwave-get-buffer-visiting file)))
+ (find-buffer-visiting file)))
;; see if file is in a visited buffer, insert those contents
(if in-buf
(progn
@@ -949,7 +936,7 @@ This function can be used as `idlwave-extra-help-function'."
(point)))
-(defun idlwave-help-find-routine-definition (name type class keyword)
+(defun idlwave-help-find-routine-definition (name type class _keyword)
"Find the definition of routine CLASS::NAME in current buffer.
Returns the point of match if successful, nil otherwise.
KEYWORD is ignored."
@@ -969,7 +956,7 @@ KEYWORD is ignored."
(defvar idlwave-doclib-start)
(defvar idlwave-doclib-end)
-(defun idlwave-help-find-in-doc-header (name type class keyword
+(defun idlwave-help-find-in-doc-header (name _type class keyword
&optional exact)
"Find the requested help in the doc-header above point.
@@ -1027,9 +1014,9 @@ If there is a match, we assume it is the keyword description."
":[ \t]*$\\)"))
;; Header start plus name
- (header-re (concat "\\(" idlwave-doclib-start "\\).*\n"
- "\\(^;+.*\n\\)*"
- "\\(" name-re "\\)"))
+ ;; (header-re (concat "\\(" idlwave-doclib-start "\\).*\n"
+ ;; "\\(^;+.*\n\\)*"
+ ;; "\\(" name-re "\\)"))
;; A keywords section
(kwds-re (concat ; forgiving
"^;+\\*?[ \t]*"
@@ -1097,8 +1084,8 @@ When DING is non-nil, ring the bell as well."
(cons string idlwave-help-diagnostics))
(if ding (ding)))))
-(defun idlwave-help-toggle-header-top-and-def (arg)
- (interactive "P")
+(defun idlwave-help-toggle-header-top-and-def (&optional _arg)
+ (interactive)
(let (pos)
(if idlwave-help-in-header
;; Header was the last thing displayed
@@ -1121,8 +1108,8 @@ When DING is non-nil, ring the bell as well."
(goto-char pos)
(recenter 0)))))
-(defun idlwave-help-find-first-header (arg)
- (interactive "P")
+(defun idlwave-help-find-first-header (&optional _arg)
+ (interactive)
(let (pos)
(save-excursion
(goto-char (point-min))
@@ -1142,8 +1129,8 @@ When DING is non-nil, ring the bell as well."
(setq idlwave-help-in-header nil)
(idlwave-help-toggle-header-match-and-def arg 'top)))
-(defun idlwave-help-toggle-header-match-and-def (arg &optional top)
- (interactive "P")
+(defun idlwave-help-toggle-header-match-and-def (&optional _arg top)
+ (interactive)
(let ((args idlwave-help-args)
pos)
(if idlwave-help-in-header
@@ -1152,7 +1139,7 @@ When DING is non-nil, ring the bell as well."
(setq idlwave-help-in-header nil)
(setq pos idlwave-help-def-pos))
;; Try to display header
- (setq pos (apply 'idlwave-help-find-in-doc-header
+ (setq pos (apply #'idlwave-help-find-in-doc-header
(if top
(list (car args) (nth 1 args) (nth 2 args) nil)
args)))
@@ -1174,20 +1161,19 @@ When DING is non-nil, ring the bell as well."
Useful when source code is displayed as help. See the option
`idlwave-help-fontify-source-code'."
(interactive)
- (if (featurep 'font-lock)
- (let ((major-mode 'idlwave-mode)
- (font-lock-verbose
- (if (called-interactively-p 'interactive) font-lock-verbose nil)))
- (with-syntax-table idlwave-mode-syntax-table
- (set (make-local-variable 'font-lock-defaults)
- idlwave-font-lock-defaults)
- (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1
- (font-lock-ensure)
- ;; Silence "interactive use only" warning on Emacs >= 25.1.
- (with-no-warnings (font-lock-fontify-buffer)))))))
-
-
-(defun idlwave-help-error (name type class keyword)
+ (let ((major-mode 'idlwave-mode)
+ (font-lock-verbose
+ (if (called-interactively-p 'interactive) font-lock-verbose nil)))
+ (with-syntax-table idlwave-mode-syntax-table
+ (set (make-local-variable 'font-lock-defaults)
+ idlwave-font-lock-defaults)
+ (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1
+ (font-lock-ensure)
+ ;; Silence "interactive use only" warning on Emacs >= 25.1.
+ (with-no-warnings (font-lock-fontify-buffer))))))
+
+
+(defun idlwave-help-error (name _type class keyword)
(error "Can't find help on %s%s %s"
(or (and (or class name) (idlwave-make-full-name class name))
"<unknown>")
@@ -1203,16 +1189,9 @@ Useful when source code is displayed as help. See the option
(setq idlwave-help-frame
(make-frame idlwave-help-frame-parameters))
;; Strip menubar (?) and toolbar from the Help frame.
- (if (fboundp 'set-specifier)
- (progn
- ;; XEmacs
- (let ((sval (cons idlwave-help-frame nil)))
- ;; (set-specifier menubar-visible-p sval)
- (set-specifier default-toolbar-visible-p sval)))
- ;; Emacs
- (modify-frame-parameters idlwave-help-frame
- '(;;(menu-bar-lines . 0)
- (tool-bar-lines . 0)))))
+ (modify-frame-parameters idlwave-help-frame
+ '(;;(menu-bar-lines . 0)
+ (tool-bar-lines . 0))))
(select-frame idlwave-help-frame))
(defun idlwave-help-get-help-buffer ()
@@ -1282,11 +1261,11 @@ IDL assistant.")
(delete-process idlwave-help-assistant-socket))
(setq idlwave-help-assistant-process
- (apply 'start-process
+ (apply #'start-process
"IDL_ASSISTANT_PROC" nil command "-server" extra-args))
(set-process-filter idlwave-help-assistant-process
- (lambda (proc string)
+ (lambda (_proc string)
(setq port (string-to-number string))))
(unless (accept-process-output idlwave-help-assistant-process 15)
(error "Failed binding IDL_ASSISTANT socket"))
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index 7da4230ceba..ad8feb988f5 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -1,4 +1,4 @@
-;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*-
+;;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -26,8 +26,7 @@
;;; Commentary:
;;
-;; This mode is for IDL version 5 or later. It should work on
-;; Emacs>20.3 or XEmacs>20.4.
+;; This mode is for IDL version 5 or later.
;;
;; Runs IDL as an inferior process of Emacs, much like the Emacs
;; `shell' or `telnet' commands. Provides command history and
@@ -40,7 +39,7 @@
;;
;; New versions of IDLWAVE, documentation, and more information
;; available from:
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;; INSTALLATION:
;; =============
@@ -58,7 +57,7 @@
;; The newest version of this file can be found on the maintainers
;; web site.
;;
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;; DOCUMENTATION
;; =============
@@ -68,15 +67,6 @@
;; maintainers webpage (see under SOURCE)
;;
;;
-;; KNOWN PROBLEMS
-;; ==============
-;;
-;; Under XEmacs the Debug menu in the shell does not display the
-;; keybindings in the prefix map. There bindings are available anyway - so
-;; it is a bug in XEmacs.
-;; The Debug menu in source buffers *does* display the bindings correctly.
-;;
-;;
;; CUSTOMIZATION VARIABLES
;; =======================
;;
@@ -166,7 +156,6 @@ t Arrows force the cursor back to the current command line and
"Non-nil means, use the debugging toolbar in all IDL related buffers.
Starting the shell will then add the toolbar to all idlwave-mode buffers.
Exiting the shell will removed everywhere.
-Available on XEmacs and on Emacs 21.x or later.
At any time you can toggle the display of the toolbar with
`C-c C-d C-t' (`idlwave-shell-toggle-toolbar')."
:group 'idlwave-shell-general-setup
@@ -606,12 +595,6 @@ the directory stack.")
(defvar idlwave-shell-last-save-and-action-file nil
"The last file which was compiled with `idlwave-shell-save-and-...'.")
-;; Highlighting uses overlays. When necessary, require the emulation.
-(if (not (fboundp 'make-overlay))
- (condition-case nil
- (require 'overlay)
- (error nil)))
-
(defvar idlwave-shell-stop-line-overlay nil
"The overlay for where IDL is currently stopped.")
(defvar idlwave-shell-is-stopped nil)
@@ -746,7 +729,7 @@ IDL is currently stopped.")
(defconst idlwave-shell-halt-messages-re
- (mapconcat 'identity idlwave-shell-halt-messages "\\|")
+ (mapconcat #'identity idlwave-shell-halt-messages "\\|")
"The regular expression computed from `idlwave-shell-halt-messages'.")
(defconst idlwave-shell-trace-message-re
@@ -896,7 +879,7 @@ IDL has currently stepped.")
Info documentation for this package is available. Use \\[idlwave-info]
to display (complain to your sysadmin if that does not work).
For PostScript and HTML versions of the documentation, check IDLWAVE's
- homepage at URL `http://github.com/jdtsmith/idlwave'.
+ homepage at URL `https://github.com/jdtsmith/idlwave'.
IDLWAVE has customize support - see the group `idlwave'.
8. Keybindings
@@ -951,8 +934,8 @@ IDL has currently stepped.")
"[ \t\n]*\\'"))
(when idlwave-shell-query-for-class
- (add-to-list (make-local-variable 'idlwave-determine-class-special)
- 'idlwave-shell-get-object-class)
+ (add-hook 'idlwave-determine-class-functions
+ #'idlwave-shell-get-object-class nil t)
(setq idlwave-store-inquired-class t))
;; Make sure comint-last-input-end does not go to beginning of
@@ -967,13 +950,10 @@ IDL has currently stepped.")
(setq idlwave-shell-default-directory default-directory)
(setq idlwave-shell-hide-output nil)
- ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility
- ;; (make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'idlwave-shell-kill-shell-buffer-confirm
+ (add-hook 'kill-buffer-hook #'idlwave-shell-kill-shell-buffer-confirm
nil 'local)
- (add-hook 'kill-buffer-hook 'idlwave-shell-delete-temp-files nil 'local)
- (add-hook 'kill-emacs-hook 'idlwave-shell-delete-temp-files)
- (easy-menu-add idlwave-shell-mode-menu idlwave-shell-mode-map)
+ (add-hook 'kill-buffer-hook #'idlwave-shell-delete-temp-files nil 'local)
+ (add-hook 'kill-emacs-hook #'idlwave-shell-delete-temp-files)
;; Set the optional comint variables
(when idlwave-shell-comint-settings
@@ -982,7 +962,7 @@ IDL has currently stepped.")
(set (make-local-variable (car entry)) (cdr entry)))))
- (unless (memq 'comint-carriage-motion
+ (unless (memq #'comint-carriage-motion
(default-value 'comint-output-filter-functions))
;; Strip those pesky ctrl-m's.
(add-hook 'comint-output-filter-functions
@@ -996,20 +976,21 @@ IDL has currently stepped.")
(while (search-forward "\r" pmark t)
(delete-region (point) (line-beginning-position)))))))
'append 'local)
- (add-hook 'comint-output-filter-functions 'comint-strip-ctrl-m nil 'local))
+ (add-hook 'comint-output-filter-functions #'comint-strip-ctrl-m nil 'local))
;; Python-mode, bundled with many Emacs installs, quite cavalierly
;; adds this function to the global default hook. It interferes
;; with overlay-arrows.
- (remove-hook 'comint-output-filter-functions 'py-pdbtrack-track-stack-file)
+ ;; FIXME: We should fix this interference rather than globally turn it off.
+ (when (fboundp 'py-pdbtrack-track-stack-file)
+ (remove-hook 'comint-output-filter-functions
+ #'py-pdbtrack-track-stack-file))
;; IDLWAVE syntax, and turn on abbreviations
(set (make-local-variable 'comment-start) ";")
(setq abbrev-mode t)
- ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility
- ;; make-local-hook 'post-command-hook)
- (add-hook 'post-command-hook 'idlwave-command-hook nil t)
+ (add-hook 'post-command-hook #'idlwave-command-hook nil t)
;; Read the command history?
(when (and idlwave-shell-save-command-history
@@ -1067,7 +1048,7 @@ IDL has currently stepped.")
(setq idlwave-path-alist old-path-alist))))
(if (not (fboundp 'idl-shell))
- (fset 'idl-shell 'idlwave-shell))
+ (defalias 'idl-shell #'idlwave-shell))
(defvar idlwave-shell-idl-wframe nil
"Frame for displaying the IDL shell window.")
@@ -1142,7 +1123,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
(and idlwave-shell-use-dedicated-frame
(setq idlwave-shell-idl-wframe (selected-frame)))
(add-hook 'idlwave-shell-sentinel-hook
- 'save-buffers-kill-emacs t))
+ #'save-buffers-kill-emacs t))
;; A non-nil arg means, we want a dedicated frame. This will last
;; for the current editing session.
@@ -1152,7 +1133,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
;; Check if the process still exists. If not, create it.
(unless (comint-check-proc (idlwave-shell-buffer))
(let* ((prg (or idlwave-shell-explicit-file-name "idl"))
- (buf (apply 'make-comint
+ (buf (apply #'make-comint
idlwave-shell-process-name prg nil
(if (stringp idlwave-shell-command-line-options)
(idlwave-split-string
@@ -1160,8 +1141,8 @@ See also the variable `idlwave-shell-prompt-pattern'.
idlwave-shell-command-line-options)))
(process (get-buffer-process buf)))
(setq idlwave-idlwave_routine_info-compiled nil)
- (set-process-filter process 'idlwave-shell-filter)
- (set-process-sentinel process 'idlwave-shell-sentinel)
+ (set-process-filter process #'idlwave-shell-filter)
+ (set-process-sentinel process #'idlwave-shell-sentinel)
(set-buffer buf)
(idlwave-shell-mode)))
(let ((window (idlwave-display-buffer (idlwave-shell-buffer) nil
@@ -1337,10 +1318,7 @@ See also the variable `idlwave-shell-input-mode-spells'."
(setq idlwave-shell-char-mode-active 'exit))
((string-match (nth 1 idlwave-shell-input-mode-spells) string)
;; Set a timer which will soon start the character loop
- (if (fboundp 'start-itimer)
- (start-itimer "IDLWAVE Char Mode" 'idlwave-shell-char-mode-loop 0.5
- nil nil t 'no-error)
- (run-at-time 0.5 nil 'idlwave-shell-char-mode-loop 'no-error)))))
+ (run-at-time 0.5 nil #'idlwave-shell-char-mode-loop 'no-error))))
(defvar keyboard-quit)
(defun idlwave-shell-char-mode-loop (&optional no-error)
@@ -1418,7 +1396,7 @@ Otherwise just move the line. Move down unless UP is non-nil."
(idlwave-shell-move-or-history nil arg))
(define-obsolete-function-alias 'idlwave-shell-comint-filter
- 'comint-output-filter "25.1")
+ #'comint-output-filter "25.1")
(defun idlwave-shell-is-running ()
"Return t if the shell process is running."
@@ -1532,13 +1510,12 @@ and then calls `idlwave-shell-send-command' for any pending commands."
proc filtered))))))
;; Call the post-command hook
- (if (listp idlwave-shell-post-command-hook)
- (progn
- ;;(message "Calling list")
- ;;(prin1 idlwave-shell-post-command-hook)
- (eval idlwave-shell-post-command-hook))
- ;;(message "Calling command function")
- (funcall idlwave-shell-post-command-hook))
+ (if (functionp idlwave-shell-post-command-hook)
+ ;;(message "Calling command function")
+ (funcall idlwave-shell-post-command-hook)
+ ;;(message "Calling list")
+ ;;(prin1 idlwave-shell-post-command-hook)
+ (eval idlwave-shell-post-command-hook t))
;; Reset to default state for next command.
;; Also we do not want to find this prompt again.
@@ -1598,7 +1575,7 @@ number.")
"A regular expression to match any IDL error.")
(defvar idlwave-shell-halting-error
- "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+\\s-*.*\\)\n"
+ "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+.*\\)\n"
"A regular expression to match errors which halt execution.")
(defvar idlwave-shell-cant-continue-error
@@ -1712,7 +1689,7 @@ the above."
(if bp
(let ((cmd (idlwave-shell-bp-get bp 'cmd)))
(if cmd ;; Execute any breakpoint command
- (if (listp cmd) (eval cmd) (funcall cmd))))
+ (if (functionp cmd) (funcall cmd) (eval cmd t))))
;; A breakpoint that we did not know about - perhaps it was
;; set by the user... Let's update our list.
(idlwave-shell-bp-query)))
@@ -1841,7 +1818,7 @@ The size is given by `idlwave-shell-graphics-window-size'."
(interactive "P")
(let ((n (if n (prefix-numeric-value n) 0)))
(idlwave-shell-send-command
- (apply 'format "window,%d,xs=%d,ys=%d"
+ (apply #'format "window,%d,xs=%d,ys=%d"
n idlwave-shell-graphics-window-size)
nil (idlwave-shell-hide-p 'misc) nil t)))
@@ -1913,7 +1890,7 @@ HEAP_GC, /VERBOSE"
(while (string-match "^PATH:[ \t]*<\\(.*\\)>[ \t]*\n" path-string start)
(push (match-string 1 path-string) dirs)
(setq start (match-end 0)))
- (setq dirs (mapcar 'file-name-as-directory dirs))
+ (setq dirs (mapcar #'file-name-as-directory dirs))
(if (string-match "^SYSDIR:[ \t]*<\\(.*\\)>[ \t]*\n" path-string)
(setq sysdir (file-name-as-directory
(match-string 1 path-string))))
@@ -1960,13 +1937,14 @@ HEAP_GC, /VERBOSE"
key (nth 4 specs)
keys (if (and (stringp key)
(not (string-match "\\` *\\'" key)))
- (mapcar 'list
+ (mapcar #'list
(delete "" (idlwave-split-string key " +")))))
(setq name (idlwave-sintern-routine-or-method name class t)
class (idlwave-sintern-class class t)
file (if (equal file "") nil file)
keys (mapcar (lambda (x)
- (list (idlwave-sintern-keyword (car x) t))) keys))
+ (list (idlwave-sintern-keyword (car x) t)))
+ keys))
;; In the following ignore routines already defined in buffers,
;; assuming that if the buffer stuff differs, it is a "new"
@@ -2075,7 +2053,7 @@ Change the default directory for the process buffer to concur."
(match-string 1 idlwave-shell-command-output)))))
(defvar idlwave-sint-sysvars nil)
-(idlwave-new-sintern-type 'execcomm)
+(idlwave-new-sintern-type execcomm)
(defun idlwave-shell-complete (&optional arg)
"Do completion in the idlwave-shell buffer.
@@ -2202,7 +2180,7 @@ overlays."
(defun idlwave-shell-parse-stack-and-display ()
(let* ((lines (delete "" (idlwave-split-string
idlwave-shell-command-output "^%")))
- (stack (delq nil (mapcar 'idlwave-shell-parse-line lines)))
+ (stack (delq nil (mapcar #'idlwave-shell-parse-line lines)))
(nmax (1- (length stack)))
(nmin 0) message)
(cond
@@ -2640,7 +2618,7 @@ Assumes that `idlwave-shell-sources-alist' contains an entry for that module."
(if (or (not source-file)
(not (file-regular-p source-file))
(not (setq buf
- (or (idlwave-get-buffer-visiting source-file)
+ (or (find-buffer-visiting source-file)
(find-file-noselect source-file)))))
(progn
(message "The source file for module %s is probably not compiled"
@@ -2732,44 +2710,34 @@ Runs to the last statement and then steps 1 statement. Use the .out command."
(interactive "P")
(idlwave-shell-print arg 'help))
-(defmacro idlwave-shell-mouse-examine (help &optional ev)
- "Create a function for generic examination of expressions."
- `(lambda (event)
- "Expansion function for expression examination."
- (interactive "e")
- (let* ((drag-track (fboundp 'mouse-drag-track))
- (transient-mark-mode t)
- (tracker
- ;; Emacs 22 no longer completes the drag with
- ;; mouse-drag-region, without an additional
- ;; event. mouse-drag-track does so.
- (if drag-track 'mouse-drag-track 'mouse-drag-region)))
- (funcall tracker event)
- (idlwave-shell-print (if (idlwave-region-active-p) '(4) nil)
- ,help ,ev))))
-
-;; Begin terrible hack section -- XEmacs tests for button2 explicitly
-;; on drag events, calling drag-n-drop code if detected. Ughhh...
-(defun idlwave-default-mouse-track-event-is-with-button (_event _n)
- t)
-
-(define-obsolete-function-alias 'idlwave-xemacs-hack-mouse-track 'ignore "27.1")
+(defun idlwave-shell--mouse-examine (event help &optional ev)
+ "Expansion function for expression examination."
+ (let* ((transient-mark-mode t))
+ (mouse-drag-track event)
+ (idlwave-shell-print (if (region-active-p) '(4) nil)
+ help ev)))
+
+(define-obsolete-function-alias
+ 'idlwave-default-mouse-track-event-is-with-button #'always "28.1")
+
+(define-obsolete-function-alias 'idlwave-xemacs-hack-mouse-track
+ #'ignore "27.1")
;;; End terrible hack section
(defun idlwave-shell-mouse-print (event)
"Print value of variable at the mouse position, with `print'."
(interactive "e")
- (funcall (idlwave-shell-mouse-examine nil) event))
+ (idlwave-shell--mouse-examine event nil))
(defun idlwave-shell-mouse-help (event)
"Print value of variable at the mouse position, with `help'."
(interactive "e")
- (funcall (idlwave-shell-mouse-examine 'help) event))
+ (idlwave-shell--mouse-examine event 'help))
(defun idlwave-shell-examine-select (event)
"Pop-up a list to select from for examining the expression."
(interactive "e")
- (funcall (idlwave-shell-mouse-examine nil event) event))
+ (idlwave-shell--mouse-examine event nil event))
(defmacro idlwave-shell-examine (help)
"Create a function for key-driven expression examination."
@@ -2830,12 +2798,12 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key."
(cond
((equal arg '(16))
(setq expr (read-string "Expression: ")))
- ((and (or arg (idlwave-region-active-p))
+ ((and (or arg (region-active-p))
(< (- (region-end) (region-beginning)) 2000))
(setq beg (region-beginning)
end (region-end)))
(t
- (idlwave-with-special-syntax
+ (with-syntax-table idlwave-find-symbol-syntax-table
;; Move to beginning of current or previous expression
(if (looking-at "\\<\\|(")
;; At beginning of expression, don't move backwards unless
@@ -2868,9 +2836,9 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key."
(move-overlay idlwave-shell-expression-overlay beg end
(current-buffer))
(add-hook 'pre-command-hook
- 'idlwave-shell-delete-expression-overlay))
+ #'idlwave-shell-delete-expression-overlay))
(add-hook 'pre-command-hook
- 'idlwave-shell-delete-output-overlay)
+ #'idlwave-shell-delete-output-overlay)
;; Remove empty or comment-only lines
(while (string-match "\n[ \t]*\\(;.*\\)?\r*\n" expr)
@@ -2902,7 +2870,7 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key."
;; "Print")
(idlwave-popup-select
ev
- (mapcar 'car idlwave-shell-examine-alist)
+ (mapcar #'car idlwave-shell-examine-alist)
"Examine with"))
idlwave-shell-examine-alist))))
(setq help (cdr help-cons))
@@ -2937,9 +2905,8 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key."
"Variable to hold the win/height pairs for all *Examine* windows.")
(defvar idlwave-shell-examine-map (make-sparse-keymap))
-(define-key idlwave-shell-examine-map "q" 'idlwave-shell-examine-display-quit)
-(define-key idlwave-shell-examine-map "c" 'idlwave-shell-examine-display-clear)
-
+(define-key idlwave-shell-examine-map "q" #'idlwave-shell-examine-display-quit)
+(define-key idlwave-shell-examine-map "c" #'idlwave-shell-examine-display-clear)
(defun idlwave-shell-check-compiled-and-display ()
"Check examine output for warning about undefined procedure/function."
@@ -3241,8 +3208,7 @@ Does not work for a region with multiline blocks - use
"Delete the temporary files and kill associated buffers."
(if (stringp idlwave-shell-temp-pro-file)
(condition-case nil
- (let ((buf (idlwave-get-buffer-visiting
- idlwave-shell-temp-pro-file)))
+ (let ((buf (find-buffer-visiting idlwave-shell-temp-pro-file)))
(if (buffer-live-p buf)
(kill-buffer buf))
(delete-file idlwave-shell-temp-pro-file))
@@ -3369,9 +3335,10 @@ the breakpoint overlays."
count nil condition disabled))))))
(setq idlwave-shell-bp-alist (cdr idlwave-shell-bp-alist))
;; Update breakpoint data
- (if (eq bp-re bp-re54)
- (mapc 'idlwave-shell-update-bp old-bp-alist)
- (mapc 'idlwave-shell-update-bp-command-only old-bp-alist))))
+ (mapc (if (eq bp-re bp-re54)
+ #'idlwave-shell-update-bp
+ #'idlwave-shell-update-bp-command-only)
+ old-bp-alist)))
;; Update the breakpoint overlays
(unless no-show (idlwave-shell-update-bp-overlays))
;; Return the new list
@@ -3506,7 +3473,7 @@ The actual line number for a breakpoint in IDL may be different from
the line number used with the IDL breakpoint command.
Looks for a new breakpoint index number in the list. This is
considered the new breakpoint if the file name of frame matches."
- (let ((obp-index (mapcar 'idlwave-shell-bp-get idlwave-shell-old-bp))
+ (let ((obp-index (mapcar #'idlwave-shell-bp-get idlwave-shell-old-bp))
(bpl idlwave-shell-bp-alist))
(while (and (member (idlwave-shell-bp-get (car bpl)) obp-index)
(setq bpl (cdr bpl))))
@@ -3532,7 +3499,7 @@ considered the new breakpoint if the file name of frame matches."
(defvar idlwave-shell-debug-line-map (make-sparse-keymap))
(define-key idlwave-shell-debug-line-map [mouse-3]
- 'idlwave-shell-mouse-active-bp)
+ #'idlwave-shell-mouse-active-bp)
(defun idlwave-shell-update-bp-overlays ()
"Update the overlays which mark breakpoints in the source code.
@@ -3554,7 +3521,7 @@ Existing overlays are recycled, in order to minimize consumption."
(setq ov-alist idlwave-shell-bp-overlays
idlwave-shell-bp-overlays
(if idlwave-shell-bp-glyph
- (mapcar 'list (mapcar 'car idlwave-shell-bp-glyph))
+ (mapcar #'list (mapcar #'car idlwave-shell-bp-glyph))
(list (list 'bp))))
(while (setq bp (pop bp-list))
(save-excursion
@@ -3590,7 +3557,7 @@ Existing overlays are recycled, in order to minimize consumption."
(if help-list
(concat
" - "
- (mapconcat 'identity help-list ", ")))
+ (mapconcat #'identity help-list ", ")))
(if (and (not count) (not condition))
" (use mouse-3 for breakpoint actions)")))
(full-type (if disabled
@@ -3613,10 +3580,8 @@ Existing overlays are recycled, in order to minimize consumption."
(when use-glyph
(if old-buffers
(setq old-buffers (delq (current-buffer) old-buffers)))
- (if (fboundp 'set-specifier) ;; XEmacs
- (set-specifier left-margin-width (cons (current-buffer) 2))
- (if (< left-margin-width 2)
- (setq left-margin-width 2)))
+ (if (< left-margin-width 2)
+ (setq left-margin-width 2))
(let ((window (get-buffer-window (current-buffer) 0)))
(if window
(set-window-margins
@@ -3624,9 +3589,7 @@ Existing overlays are recycled, in order to minimize consumption."
(if use-glyph
(while (setq buf (pop old-buffers))
(with-current-buffer buf
- (if (fboundp 'set-specifier) ;; XEmacs
- (set-specifier left-margin-width (cons (current-buffer) 0))
- (setq left-margin-width 0))
+ (setq left-margin-width 0)
(let ((window (get-buffer-window buf 0)))
(if window
(set-window-margins
@@ -3788,7 +3751,7 @@ handled by this command."
(save-buffer)
(setq idlwave-shell-last-save-and-action-file (buffer-file-name)))
(idlwave-shell-last-save-and-action-file
- (if (setq buf (idlwave-get-buffer-visiting
+ (if (setq buf (find-buffer-visiting
idlwave-shell-last-save-and-action-file))
(with-current-buffer buf
(save-buffer))))
@@ -3988,73 +3951,73 @@ Otherwise, just expand the file name."
;;(define-key map "\M-?" 'comint-dynamic-list-completions)
;;(define-key map "\t" 'comint-dynamic-complete)
- (define-key map "\C-w" 'comint-kill-region)
- (define-key map "\t" 'idlwave-shell-complete)
- (define-key map "\M-\t" 'idlwave-shell-complete)
- (define-key map "\C-c\C-s" 'idlwave-shell)
- (define-key map "\C-c?" 'idlwave-routine-info)
- (define-key map "\C-g" 'idlwave-keyboard-quit)
- (define-key map "\M-?" 'idlwave-context-help)
+ (define-key map "\C-w" #'comint-kill-region)
+ (define-key map "\t" #'idlwave-shell-complete)
+ (define-key map "\M-\t" #'idlwave-shell-complete)
+ (define-key map "\C-c\C-s" #'idlwave-shell)
+ (define-key map "\C-c?" #'idlwave-routine-info)
+ (define-key map "\C-g" #'idlwave-keyboard-quit)
+ (define-key map "\M-?" #'idlwave-context-help)
(define-key map [(control meta ?\?)]
- 'idlwave-help-assistant-help-with-topic)
- (define-key map "\C-c\C-i" 'idlwave-update-routine-info)
- (define-key map "\C-c\C-y" 'idlwave-shell-char-mode-loop)
- (define-key map "\C-c\C-x" 'idlwave-shell-send-char)
- (define-key map "\C-c=" 'idlwave-resolve)
- (define-key map "\C-c\C-v" 'idlwave-find-module)
- (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers)
+ #'idlwave-help-assistant-help-with-topic)
+ (define-key map "\C-c\C-i" #'idlwave-update-routine-info)
+ (define-key map "\C-c\C-y" #'idlwave-shell-char-mode-loop)
+ (define-key map "\C-c\C-x" #'idlwave-shell-send-char)
+ (define-key map "\C-c=" #'idlwave-resolve)
+ (define-key map "\C-c\C-v" #'idlwave-find-module)
+ (define-key map "\C-c\C-k" #'idlwave-kill-autoloaded-buffers)
(define-key map idlwave-shell-prefix-key
- 'idlwave-shell-debug-map)
- (define-key map [(up)] 'idlwave-shell-up-or-history)
- (define-key map [(down)] 'idlwave-shell-down-or-history)
+ #'idlwave-shell-debug-map)
+ (define-key map [(up)] #'idlwave-shell-up-or-history)
+ (define-key map [(down)] #'idlwave-shell-down-or-history)
(define-key idlwave-shell-mode-map [(shift mouse-3)]
- 'idlwave-mouse-context-help)
+ #'idlwave-mouse-context-help)
map)
"Keymap for `idlwave-mode'.")
(defvar idlwave-shell-electric-debug-mode-map
(let ((map (make-sparse-keymap)))
;; A few extras in the electric debug map
- (define-key map " " 'idlwave-shell-step)
- (define-key map "+" 'idlwave-shell-stack-up)
- (define-key map "=" 'idlwave-shell-stack-up)
- (define-key map "-" 'idlwave-shell-stack-down)
- (define-key map "_" 'idlwave-shell-stack-down)
+ (define-key map " " #'idlwave-shell-step)
+ (define-key map "+" #'idlwave-shell-stack-up)
+ (define-key map "=" #'idlwave-shell-stack-up)
+ (define-key map "-" #'idlwave-shell-stack-down)
+ (define-key map "_" #'idlwave-shell-stack-down)
(define-key map "e" (lambda () (interactive) (idlwave-shell-print '(16))))
- (define-key map "q" 'idlwave-shell-retall)
+ (define-key map "q" #'idlwave-shell-retall)
(define-key map "t"
(lambda () (interactive) (idlwave-shell-send-command "help,/TRACE")))
- (define-key map [(control ??)] 'idlwave-shell-electric-debug-help)
+ (define-key map [(control ??)] #'idlwave-shell-electric-debug-help)
(define-key map "x"
(lambda (arg) (interactive "P")
(idlwave-shell-print arg nil nil t)))
map))
(defvar idlwave-shell-mode-prefix-map (make-sparse-keymap))
-(fset 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map)
+(defalias 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map)
(defvar idlwave-mode-prefix-map (make-sparse-keymap))
-(fset 'idlwave-mode-prefix-map idlwave-mode-prefix-map)
+(defalias 'idlwave-mode-prefix-map idlwave-mode-prefix-map)
(defun idlwave-shell-define-key-both (key hook)
"Define a key in both the shell and buffer mode maps."
(define-key idlwave-mode-map key hook)
(define-key idlwave-shell-mode-map key hook))
-(define-key idlwave-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop)
-(define-key idlwave-mode-map "\C-c\C-x" 'idlwave-shell-send-char)
+(define-key idlwave-mode-map "\C-c\C-y" #'idlwave-shell-char-mode-loop)
+(define-key idlwave-mode-map "\C-c\C-x" #'idlwave-shell-send-char)
;; The mouse bindings for PRINT and HELP
(idlwave-shell-define-key-both [(shift down-mouse-2)]
- 'idlwave-shell-mouse-print)
+ #'idlwave-shell-mouse-print)
(idlwave-shell-define-key-both [(control meta down-mouse-2)]
- 'idlwave-shell-mouse-help)
+ #'idlwave-shell-mouse-help)
(idlwave-shell-define-key-both [(control shift down-mouse-2)]
- 'idlwave-shell-examine-select)
+ #'idlwave-shell-examine-select)
;; We need to turn off the button release events.
-(idlwave-shell-define-key-both [(shift mouse-2)] 'ignore)
-(idlwave-shell-define-key-both [(shift control mouse-2)] 'ignore)
-(idlwave-shell-define-key-both [(control meta mouse-2)] 'ignore)
+(idlwave-shell-define-key-both [(shift mouse-2)] #'ignore)
+(idlwave-shell-define-key-both [(shift control mouse-2)] #'ignore)
+(idlwave-shell-define-key-both [(control meta mouse-2)] #'ignore)
;; The following set of bindings is used to bind the debugging keys.
@@ -4135,8 +4098,8 @@ Otherwise, just expand the file name."
cmd))))
; Enter the prefix map in two places.
-(fset 'idlwave-debug-map idlwave-mode-prefix-map)
-(fset 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map)
+(defalias 'idlwave-debug-map idlwave-mode-prefix-map)
+(defalias 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map)
;; The Electric Debug Minor Mode --------------------------------------------
@@ -4353,21 +4316,12 @@ Shell debugging commands are available as single key sequences."
["Toggle Toolbar" idlwave-shell-toggle-toolbar t]
["Exit IDL" idlwave-shell-quit t]))
-(if (or (featurep 'easymenu) (load "easymenu" t))
- (progn
- (easy-menu-define
- idlwave-mode-debug-menu idlwave-mode-map "IDL debugging menus"
- idlwave-shell-menu-def)
- (easy-menu-define
- idlwave-shell-mode-menu idlwave-shell-mode-map "IDL shell menus"
- idlwave-shell-menu-def)
- (save-current-buffer
- (dolist (buf (buffer-list))
- (set-buffer buf)
- (if (derived-mode-p 'idlwave-mode)
- (progn
- (easy-menu-remove idlwave-mode-debug-menu)
- (easy-menu-add idlwave-mode-debug-menu)))))))
+(easy-menu-define
+ idlwave-mode-debug-menu idlwave-mode-map "IDL debugging menus"
+ idlwave-shell-menu-def)
+(easy-menu-define
+ idlwave-shell-mode-menu idlwave-shell-mode-map "IDL shell menus"
+ idlwave-shell-menu-def)
;; The Breakpoint Glyph -------------------------------------------------------
@@ -4531,6 +4485,6 @@ static char * file[] = {
(idlwave-toolbar-toggle))
(if idlwave-shell-use-toolbar
- (add-hook 'idlwave-shell-mode-hook 'idlwave-toolbar-add-everywhere))
+ (add-hook 'idlwave-shell-mode-hook #'idlwave-toolbar-add-everywhere))
;;; idlw-shell.el ends here
diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el
index 45349cd99e0..d3f47fcf45e 100644
--- a/lisp/progmodes/idlw-toolbar.el
+++ b/lisp/progmodes/idlw-toolbar.el
@@ -1,4 +1,4 @@
-;;; idlw-toolbar.el --- a debugging toolbar for IDLWAVE
+;;; idlw-toolbar.el --- a debugging toolbar for IDLWAVE -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -24,33 +24,27 @@
;;; Commentary:
-;; This file implements a debugging toolbar for IDLWAVE. It requires
-;; Emacs or XEmacs with toolbar and xpm support.
+;; This file implements a debugging toolbar for IDLWAVE.
+;; It requires toolbar and xpm support.
;; New versions of IDLWAVE, documentation, and more information
;; available from:
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;; Code:
(defun idlwave-toolbar-make-button (image)
- (if (featurep 'xemacs)
- (toolbar-make-button-list image)
- (list 'image :type 'xpm :data image)))
+ (list 'image :type 'xpm :data image))
(defvar idlwave-toolbar)
(defvar default-toolbar)
(defvar idlwave-toolbar-is-possible)
-(if (not (or (and (featurep 'xemacs) ; This is XEmacs
- (featurep 'xpm) ; need xpm
- (featurep 'toolbar)) ; ... and the toolbar
- (and (not (featurep 'xemacs)) ; This is Emacs
- (boundp 'tool-bar-button-margin) ; need toolbar
- (fboundp 'image-type-available-p) ; need image stuff
- (image-type-available-p 'xpm)) ; need xpm
- ))
+(if (not (and (boundp 'tool-bar-button-margin) ; need toolbar
+ (fboundp 'image-type-available-p) ; need image stuff
+ (image-type-available-p 'xpm)) ; need xpm
+ )
;; oops - cannot do the toolbar
(message "Sorry, IDLWAVE xpm toolbar cannot be used on this version of Emacs")
;; OK, we can define a toolbar
@@ -873,23 +867,12 @@ static char * file[] = {
;; When the shell exits, arrange to remove the special toolbar everywhere.
(add-hook 'idlwave-shell-cleanup-hook
- 'idlwave-toolbar-remove-everywhere)
+ #'idlwave-toolbar-remove-everywhere)
);; End can define toolbar
-(defun idlwave-toolbar-add ()
- "Add the IDLWAVE toolbar if appropriate."
- (if (and (featurep 'xemacs) ; This is a noop on Emacs
- (boundp 'idlwave-toolbar-is-possible)
- (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
- (set-specifier default-toolbar (cons (current-buffer)
- idlwave-toolbar))))
-
-(defun idlwave-toolbar-remove ()
- "Add the IDLWAVE toolbar if appropriate."
- (if (and (featurep 'xemacs) ; This is a noop on Emacs
- (boundp 'idlwave-toolbar-is-possible)
- (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
- (remove-specifier default-toolbar (current-buffer))))
+(define-obsolete-function-alias 'idlwave-toolbar-add #'ignore "28.1")
+
+(define-obsolete-function-alias 'idlwave-toolbar-remove #'ignore "28.1")
(defvar idlwave-shell-mode-map)
(defvar idlwave-mode-map)
@@ -898,57 +881,40 @@ static char * file[] = {
"Add the toolbar in all appropriate buffers."
(when (boundp 'idlwave-toolbar-is-possible)
- ;; First make sure new buffers will get the toolbar
- (add-hook 'idlwave-mode-hook 'idlwave-toolbar-add)
;; Then add it to all existing buffers
- (if (featurep 'xemacs)
- ;; For XEmacs, map over all buffers to add toolbar
- (save-excursion
- (mapcar (lambda (buf)
- (set-buffer buf)
- (idlwave-toolbar-add))
- (buffer-list)))
- ;; For Emacs, add the key definitions to the mode maps
- (mapc (lambda (x)
- (let* ((icon (aref x 0))
- (func (aref x 1))
- (show (aref x 2))
- (help (aref x 3))
- (key (vector 'tool-bar func))
- (def (list 'menu-item
- ""
- func
- :image (symbol-value icon)
- :visible show
- :help help)))
- (define-key idlwave-mode-map key def)
- (define-key idlwave-shell-mode-map key def)))
- (reverse idlwave-toolbar)))
+ ;; For Emacs, add the key definitions to the mode maps
+ (mapc (lambda (x)
+ (let* ((icon (aref x 0))
+ (func (aref x 1))
+ (show (aref x 2))
+ (help (aref x 3))
+ (key (vector 'tool-bar func))
+ (def (list 'menu-item
+ ""
+ func
+ :image (symbol-value icon)
+ :visible show
+ :help help)))
+ (define-key idlwave-mode-map key def)
+ (define-key idlwave-shell-mode-map key def)))
+ (reverse idlwave-toolbar))
(setq idlwave-toolbar-visible t)))
(defun idlwave-toolbar-remove-everywhere ()
"Remove the toolbar in all appropriate buffers."
;; First make sure new buffers won't get the toolbar
(when idlwave-toolbar-is-possible
- (remove-hook 'idlwave-mode-hook 'idlwave-toolbar-add)
;; Then remove it in all existing buffers.
- (if (featurep 'xemacs)
- ;; For XEmacs, map over all buffers to remove toolbar
- (save-excursion
- (mapcar (lambda (buf)
- (set-buffer buf)
- (idlwave-toolbar-remove))
- (buffer-list)))
- ;; For Emacs, remove the key definitions from the mode maps
- (mapc (lambda (x)
- (let* (;;(icon (aref x 0))
- (func (aref x 1))
- ;;(show (aref x 2))
- ;;(help (aref x 3))
- (key (vector 'tool-bar func)))
- (define-key idlwave-mode-map key nil)
- (define-key idlwave-shell-mode-map key nil)))
- idlwave-toolbar))
+ ;; For Emacs, remove the key definitions from the mode maps
+ (mapc (lambda (x)
+ (let* (;;(icon (aref x 0))
+ (func (aref x 1))
+ ;;(show (aref x 2))
+ ;;(help (aref x 3))
+ (key (vector 'tool-bar func)))
+ (define-key idlwave-mode-map key nil)
+ (define-key idlwave-shell-mode-map key nil)))
+ idlwave-toolbar)
(setq idlwave-toolbar-visible nil)))
(defun idlwave-toolbar-toggle (&optional force-on)
@@ -956,11 +922,8 @@ static char * file[] = {
(if idlwave-toolbar-visible
(or force-on (idlwave-toolbar-remove-everywhere))
(idlwave-toolbar-add-everywhere))
- ;; Now make sure this
- (if (featurep 'xemacs)
- nil ; no action necessary, toolbar gets updated automatically
- ;; On Emacs, redraw the frame to make sure the Toolbar is updated.
- (redraw-frame)))
+ ;; On Emacs, redraw the frame to make sure the Toolbar is updated.
+ (redraw-frame))
(provide 'idlw-toolbar)
(provide 'idlwave-toolbar)
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index 14c7876f0fb..b55a98af0b3 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -1,4 +1,4 @@
-;; idlwave.el --- IDL editing mode for GNU Emacs
+;;; idlwave.el --- IDL editing mode for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -44,7 +44,7 @@
;;
;; New versions of IDLWAVE, documentation, and more information
;; available from:
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;; INSTALLATION
;; ============
@@ -64,7 +64,7 @@
;; The newest version of this file is available from the maintainer's
;; Webpage:
;;
-;; http://github.com/jdtsmith/idlwave
+;; https://github.com/jdtsmith/idlwave
;;
;; DOCUMENTATION
;; =============
@@ -154,21 +154,6 @@
(eval-when-compile (require 'cl-lib))
(require 'idlw-help)
-;; For XEmacs
-(unless (fboundp 'line-beginning-position)
- (defalias 'line-beginning-position 'point-at-bol))
-(unless (fboundp 'line-end-position)
- (defalias 'line-end-position 'point-at-eol))
-(unless (fboundp 'char-valid-p)
- (defalias 'char-valid-p 'characterp))
-(unless (fboundp 'match-string-no-properties)
- (defalias 'match-string-no-properties 'match-string))
-
-(if (not (fboundp 'cancel-timer))
- (condition-case nil
- (require 'timer)
- (error nil)))
-
(declare-function idlwave-shell-get-path-info "idlw-shell")
(declare-function idlwave-shell-temp-file "idlw-shell")
(declare-function idlwave-shell-is-running "idlw-shell")
@@ -179,7 +164,7 @@
"Major mode for editing IDL .pro files."
:tag "IDLWAVE"
:link '(url-link :tag "Home Page"
- "http://github.com/jdtsmith/idlwave")
+ "https://github.com/jdtsmith/idlwave")
:link '(emacs-commentary-link :tag "Commentary in idlw-shell.el"
"idlw-shell.el")
:link '(emacs-commentary-link :tag "Commentary in idlwave.el" "idlwave.el")
@@ -314,7 +299,7 @@ split then a terminal beep and warning are issued."
expression will not be changed. Note that the indentation of a comment
at the beginning of a line is never changed."
:group 'idlwave-code-formatting
- :type 'string)
+ :type 'regexp)
(defcustom idlwave-begin-line-comment nil
"A comment anchored at the beginning of line.
@@ -596,12 +581,7 @@ like this:
MyMethod <Class1,Class2,Class3>
The value of this variable may be nil to inhibit display, or an integer to
-indicate the maximum number of classes to display.
-
-On XEmacs, a full list of classes will also be placed into a `help-echo'
-property on the completion items, so that the list of classes for the current
-item is displayed in the echo area. If the value of this variable is a
-negative integer, the `help-echo' property will be suppressed."
+indicate the maximum number of classes to display."
:group 'idlwave-completion
:type '(choice (const :tag "Don't show" nil)
(integer :tag "Number of classes shown" 1)))
@@ -801,7 +781,7 @@ definitions, use the command `list-abbrevs', for abbrevs that move
point. Moving point is useful, for example, to place point between
parentheses of expanded functions.
-See `idlwave-check-abbrev'."
+See `idlwave-modify-abbrev'."
:group 'idlwave-abbrev-and-indent-action
:type 'boolean)
@@ -839,18 +819,19 @@ Has effect only if in abbrev-mode."
;; Example actions:
;;
;; Capitalize system vars
-;; (idlwave-action-and-binding idlwave-sysvar '(capitalize-word 1) t)
+;; (idlwave-action-and-binding idlwave-sysvar
+;; (lambda (_) (capitalize-word 1)) t)
;;
;; Capitalize procedure name
;; (idlwave-action-and-binding "\\<\\(pro\\|function\\)\\>[ \t]*\\<"
-;; '(capitalize-word 1) t)
+;; (lambda (_) (capitalize-word 1)) t)
;;
;; Capitalize common block name
;; (idlwave-action-and-binding "\\<common\\>[ \t]+\\<"
-;; '(capitalize-word 1) t)
+;; (lambda (_) (capitalize-word 1)) t)
;; Capitalize label
;; (idlwave-action-and-binding (concat "^[ \t]*" idlwave-label)
-;; '(capitalize-word -1) t)
+;; (lambda (_) (capitalize-word 1)) t)
(defvar idlwave-indent-action-table nil
"Associated array containing action lists of search string (car),
@@ -1069,7 +1050,6 @@ goto Goto Statements
common-blocks Common Blocks
keyword-parameters Keyword Parameters in routine definitions and calls
system-variables System Variables
-fixme FIXME: Warning in comments (on XEmacs only v. 21.0 and up)
class-arrows Object Arrows with class property"
:group 'idlwave-misc
:type '(set
@@ -1084,7 +1064,6 @@ class-arrows Object Arrows with class property"
(const :tag "Common Blocks" common-blocks)
(const :tag "Keyword Parameters" keyword-parameters)
(const :tag "System Variables" system-variables)
- (const :tag "FIXME: Warning" fixme)
(const :tag "Object Arrows with class property " class-arrows)))
(defcustom idlwave-mode-hook nil
@@ -1096,6 +1075,8 @@ class-arrows Object Arrows with class property"
"Normal hook. Executed when idlwave.el is loaded."
:group 'idlwave-misc
:type 'hook)
+(make-obsolete-variable 'idlwave-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defvar idlwave-experimental nil
"Non-nil means turn on a few experimental features.
@@ -1141,98 +1122,101 @@ As a user, you should not set this to t.")
"\\<\\(&&\\|and\\|b\\(egin\\|reak\\)\\|c\\(ase\\|o\\(mpile_opt\\|ntinue\\)\\)\\|do\\|e\\(lse\\|nd\\(case\\|else\\|for\\|if\\|rep\\|switch\\|while\\)?\\|q\\)\\|for\\(ward_function\\)?\\|g\\(oto\\|[et]\\)\\|i\\(f\\|nherits\\)\\|l[et]\\|mod\\|n\\(e\\|ot\\)\\|o\\(n_\\(error\\|ioerror\\)\\|[fr]\\)\\|re\\(peat\\|turn\\)\\|switch\\|then\\|until\\|while\\|xor\\|||\\)\\>")
-(let* (;; Procedure declarations. Fontify keyword plus procedure name.
- ;; Function declarations. Fontify keyword plus function name.
- (pros-and-functions
- '("\\<\\(function\\|pro\\)\\>[ \t]+\\(\\sw+\\(::\\sw+\\)?\\)"
- (1 font-lock-keyword-face)
- (2 font-lock-function-name-face nil t)))
-
- ;; Common blocks
- (common-blocks
- '("\\<\\(common\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*,?"
- (1 font-lock-keyword-face) ; "common"
- (2 font-lock-constant-face nil t) ; block name
- ("[ \t]*\\(\\sw+\\)[ ,]*"
- ;; Start with point after block name and comma
- (goto-char (match-end 0)) ; needed for XEmacs, could be nil
- nil
- (1 font-lock-variable-name-face) ; variable names
- )))
-
- ;; Batch files
- (batch-files
- '("^[ \t]*\\(@[^ \t\n]+\\)" (1 font-lock-string-face)))
-
- ;; FIXME warning.
- (fixme
- '("\\<FIXME:" (0 font-lock-warning-face t)))
-
- ;; Labels
- (label
- '("^[ \t]*\\([a-zA-Z]\\sw*:\\)" (1 font-lock-constant-face)))
-
- ;; The goto statement and its label
- (goto
- '("\\(goto\\)[ \t]*,[ \t]*\\([a-zA-Z]\\sw*\\)"
- (1 font-lock-keyword-face)
- (2 font-lock-constant-face)))
-
- ;; Tags in structure definitions. Note that this definition
- ;; actually collides with labels, so we have to use the same
- ;; face. It also matches named subscript ranges,
- ;; e.g. vec{bottom:top]. No good way around this.
- (structtag
- '("\\<\\([a-zA-Z][a-zA-Z0-9_]*:\\)[^:]" (1 font-lock-constant-face)))
-
- ;; Structure names
- (structname
- '("\\({\\|\\<inherits\\s-\\)\\s-*\\([a-zA-Z][a-zA-Z0-9_]*\\)[},\t \n]"
- (2 font-lock-function-name-face)))
-
- ;; Keyword parameters, like /xlog or ,xrange=[]
- ;; This is anchored to the comma preceding the keyword.
- ;; Treats continuation lines, works only during whole buffer
- ;; fontification. Slow, use it only in fancy fontification.
- (keyword-parameters
- '("\\(,\\|[a-zA-Z0-9_](\\)[ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\([ \t]*\\(;.*\\)?\n\\)*[ \t]*\\)?\\(/[a-zA-Z_]\\sw*\\|[a-zA-Z_]\\sw*[ \t]*=\\)"
- (6 font-lock-constant-face)))
-
- ;; System variables start with a bang.
- (system-variables
- '("\\(![a-zA-Z_0-9]+\\(\\.\\sw+\\)?\\)"
- (1 font-lock-variable-name-face)))
-
- ;; Special and unusual operators (not used because too noisy)
- ;; (special-operators
- ;; '("[<>#]" (0 font-lock-keyword-face)))
-
- ;; All operators (not used because too noisy)
- ;; (all-operators
- ;; '("[-*^#+<>/]" (0 font-lock-keyword-face)))
-
- ;; Arrows with text property `idlwave-class'
- (class-arrows
- '(idlwave-match-class-arrows (0 idlwave-class-arrow-face))))
+(defmacro idlwave--dlet (binders &rest body)
+ "Like `dlet' but without warnings about non-prefixed var names."
+ (declare (indent 1) (debug let))
+ (let ((vars (mapcar (lambda (binder)
+ (if (consp binder) (car binder) binder))
+ binders)))
+ `(with-suppressed-warnings ((lexical ,@vars))
+ (dlet ,binders ,@body))))
+
+(idlwave--dlet
+ (;; Procedure declarations. Fontify keyword plus procedure name.
+ ;; Function declarations. Fontify keyword plus function name.
+ (pros-and-functions
+ '("\\<\\(function\\|pro\\)\\>[ \t]+\\(\\sw+\\(::\\sw+\\)?\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-function-name-face nil t)))
+
+ ;; Common blocks
+ (common-blocks
+ '("\\<\\(common\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*,?"
+ (1 font-lock-keyword-face) ; "common"
+ (2 font-lock-constant-face nil t) ; block name
+ ("[ \t]*\\(\\sw+\\)[ ,]*"
+ ;; Start with point after block name and comma
+ nil nil (1 font-lock-variable-name-face)))) ; variable names
+
+ ;; Batch files
+ (batch-files
+ '("^[ \t]*\\(@[^ \t\n]+\\)" (1 font-lock-string-face)))
+
+ ;; Labels
+ (label
+ '("^[ \t]*\\([a-zA-Z]\\sw*:\\)" (1 font-lock-constant-face)))
+
+ ;; The goto statement and its label
+ (goto
+ '("\\(goto\\)[ \t]*,[ \t]*\\([a-zA-Z]\\sw*\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-constant-face)))
+
+ ;; Tags in structure definitions. Note that this definition
+ ;; actually collides with labels, so we have to use the same
+ ;; face. It also matches named subscript ranges,
+ ;; e.g. vec{bottom:top]. No good way around this.
+ (structtag
+ '("\\<\\([a-zA-Z][a-zA-Z0-9_]*:\\)[^:]" (1 font-lock-constant-face)))
+
+ ;; Structure names
+ (structname
+ '("\\({\\|\\<inherits\\s-\\)\\s-*\\([a-zA-Z][a-zA-Z0-9_]*\\)[},\t \n]"
+ (2 font-lock-function-name-face)))
+
+ ;; Keyword parameters, like /xlog or ,xrange=[]
+ ;; This is anchored to the comma preceding the keyword.
+ ;; Treats continuation lines, works only during whole buffer
+ ;; fontification. Slow, use it only in fancy fontification.
+ (keyword-parameters
+ '("\\(,\\|[a-zA-Z0-9_](\\)[ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\([ \t]*\\(;.*\\)?\n\\)*[ \t]*\\)?\\(/[a-zA-Z_]\\sw*\\|[a-zA-Z_]\\sw*[ \t]*=\\)"
+ (6 font-lock-constant-face)))
+
+ ;; System variables start with a bang.
+ (system-variables
+ '("\\(![a-zA-Z_0-9]+\\(\\.\\sw+\\)?\\)"
+ (1 font-lock-variable-name-face)))
+
+ ;; Special and unusual operators (not used because too noisy)
+ ;; (special-operators
+ ;; '("[<>#]" (0 font-lock-keyword-face)))
+
+ ;; All operators (not used because too noisy)
+ ;; (all-operators
+ ;; '("[-*^#+<>/]" (0 font-lock-keyword-face)))
+
+ ;; Arrows with text property `idlwave-class'
+ (class-arrows
+ '(idlwave-match-class-arrows (0 idlwave-class-arrow-face))))
(defconst idlwave-font-lock-keywords-1
(list pros-and-functions batch-files)
"Subdued level highlighting for IDLWAVE mode.")
(defconst idlwave-font-lock-keywords-2
- (mapcar 'symbol-value idlwave-default-font-lock-items)
+ (mapcar #'symbol-value idlwave-default-font-lock-items)
"Medium level highlighting for IDLWAVE mode.")
(defconst idlwave-font-lock-keywords-3
- (list pros-and-functions
- batch-files
- idlwave-idl-keywords
- label goto
- structtag
- structname
- common-blocks
- keyword-parameters
- system-variables
+ (list pros-and-functions
+ batch-files
+ idlwave-idl-keywords
+ label goto
+ structtag
+ structname
+ common-blocks
+ keyword-parameters
+ system-variables
class-arrows)
"Gaudy level highlighting for IDLWAVE mode."))
@@ -1254,9 +1238,6 @@ As a user, you should not set this to t.")
((?$ . "w") (?_ . "w") (?. . "w") (?| . "w") (?& . "w"))
beginning-of-line))
-(put 'idlwave-mode 'font-lock-defaults
- idlwave-font-lock-defaults) ; XEmacs
-
(defconst idlwave-comment-line-start-skip "^[ \t]*;"
"Regexp to match the start of a full-line comment.
That is the _beginning_ of a line containing a comment delimiter `;' preceded
@@ -1342,13 +1323,16 @@ blocks starting with a BEGIN statement. The matches must have associations
(cons 'call (list (concat "\\(" idlwave-variable "\\) *= *"
"\\(" idlwave-method-call "\\s *\\)?"
idlwave-identifier
- "\\s *(") nil))
+ "\\s *(")
+ nil))
(cons 'call (list (concat
"\\(" idlwave-method-call "\\s *\\)?"
idlwave-identifier
- "\\( *\\($\\|\\$\\)\\|\\s *,\\)") nil))
+ "\\( *\\($\\|\\$\\)\\|\\s *,\\)")
+ nil))
(cons 'assign (list (concat
- "\\(" idlwave-variable "\\) *=") nil)))
+ "\\(" idlwave-variable "\\) *=")
+ nil)))
"Associated list of statement matching regular expressions.
Each regular expression matches the start of an IDL statement.
@@ -1363,10 +1347,6 @@ 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.")
-
(defvar idlwave-comment-indent-function 'comment-indent-function
"IDL mode comment indent function.")
@@ -1383,28 +1363,9 @@ Normally a space.")
(defconst idlwave-mode-version "6.1_em22")
-(defmacro idlwave-keyword-abbrev (&rest args)
- "Creates a function for abbrev hooks to call `idlwave-check-abbrev' with args."
- `(quote (lambda ()
- ,(append '(idlwave-check-abbrev) args))))
-
-;; If I take the time I can replace idlwave-keyword-abbrev with
-;; idlwave-code-abbrev and remove the quoted abbrev check from
-;; idlwave-check-abbrev. Then, e.g, (idlwave-keyword-abbrev 0 t) becomes
-;; (idlwave-code-abbrev idlwave-check-abbrev 0 t). In fact I should change
-;; the name of idlwave-check-abbrev to something like idlwave-modify-abbrev.
-
-(defmacro idlwave-code-abbrev (&rest args)
- "Creates a function for abbrev hooks that ensures abbrevs are not quoted.
-Specifically, if the abbrev is in a comment or string it is unexpanded.
-Otherwise ARGS forms a list that is evaluated."
- ;; FIXME: it would probably be better to rely on the new :enable-function
- ;; to enforce the "don't expand in comments or strings".
- `(lambda ()
- ,(prin1-to-string args) ;; Puts the code in the doc string
- (if (idlwave-quoted)
- (progn (unexpand-abbrev) nil)
- ,(append args))))
+(defun idlwave-keyword-abbrev (&rest args)
+ "Create a function for abbrev hooks to call `idlwave-modify-abbrev' with args."
+ (lambda () (append #'idlwave-modify-abbrev args)))
(autoload 'idlwave-shell "idlw-shell"
"Run an inferior IDL, with I/O through buffer `(idlwave-shell-buffer)'." t)
@@ -1418,41 +1379,41 @@ Otherwise ARGS forms a list that is evaluated."
(autoload 'idlwave-shell-run-region "idlw-shell"
"Compile and run the region." t)
-(fset 'idlwave-debug-map (make-sparse-keymap))
+(defalias 'idlwave-debug-map (make-sparse-keymap))
(defvar idlwave-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c " 'idlwave-hard-tab)
- (define-key map [(control tab)] 'idlwave-hard-tab)
- ;;(define-key map "\C-c\C- " 'idlwave-hard-tab)
- (define-key map "'" 'idlwave-show-matching-quote)
- (define-key map "\"" 'idlwave-show-matching-quote)
- (define-key map "\C-g" 'idlwave-keyboard-quit)
- (define-key map "\C-c;" 'idlwave-toggle-comment-region)
- (define-key map "\C-\M-a" 'idlwave-beginning-of-subprogram)
- (define-key map "\C-\M-e" 'idlwave-end-of-subprogram)
- (define-key map "\C-c{" 'idlwave-beginning-of-block)
- (define-key map "\C-c}" 'idlwave-end-of-block)
- (define-key map "\C-c]" 'idlwave-close-block)
- (define-key map [(meta control h)] 'idlwave-mark-subprogram)
- (define-key map "\M-\C-n" 'idlwave-forward-block)
- (define-key map "\M-\C-p" 'idlwave-backward-block)
- (define-key map "\M-\C-d" 'idlwave-down-block)
- (define-key map "\M-\C-u" 'idlwave-backward-up-block)
- (define-key map "\M-\r" 'idlwave-split-line)
- (define-key map "\M-\C-q" 'idlwave-indent-subprogram)
- (define-key map "\C-c\C-p" 'idlwave-previous-statement)
- (define-key map "\C-c\C-n" 'idlwave-next-statement)
- ;; (define-key map "\r" 'idlwave-newline)
- ;; (define-key map "\t" 'idlwave-indent-line)
- (define-key map [(shift iso-lefttab)] 'idlwave-indent-statement)
- (define-key map "\C-c\C-a" 'idlwave-auto-fill-mode)
- (define-key map "\M-q" 'idlwave-fill-paragraph)
- (define-key map "\M-s" 'idlwave-edit-in-idlde)
- (define-key map "\C-c\C-h" 'idlwave-doc-header)
- (define-key map "\C-c\C-m" 'idlwave-doc-modification)
- (define-key map "\C-c\C-c" 'idlwave-case)
- (define-key map "\C-c\C-d" 'idlwave-debug-map)
+ (define-key map "\C-c " #'idlwave-hard-tab)
+ (define-key map [(control tab)] #'idlwave-hard-tab)
+ ;;(define-key map "\C-c\C- " #'idlwave-hard-tab)
+ (define-key map "'" #'idlwave-show-matching-quote)
+ (define-key map "\"" #'idlwave-show-matching-quote)
+ (define-key map "\C-g" #'idlwave-keyboard-quit)
+ (define-key map "\C-c;" #'idlwave-toggle-comment-region)
+ (define-key map "\C-\M-a" #'idlwave-beginning-of-subprogram)
+ (define-key map "\C-\M-e" #'idlwave-end-of-subprogram)
+ (define-key map "\C-c{" #'idlwave-beginning-of-block)
+ (define-key map "\C-c}" #'idlwave-end-of-block)
+ (define-key map "\C-c]" #'idlwave-close-block)
+ (define-key map [(meta control h)] #'idlwave-mark-subprogram)
+ (define-key map "\M-\C-n" #'idlwave-forward-block)
+ (define-key map "\M-\C-p" #'idlwave-backward-block)
+ (define-key map "\M-\C-d" #'idlwave-down-block)
+ (define-key map "\M-\C-u" #'idlwave-backward-up-block)
+ (define-key map "\M-\r" #'idlwave-split-line)
+ (define-key map "\M-\C-q" #'idlwave-indent-subprogram)
+ (define-key map "\C-c\C-p" #'idlwave-previous-statement)
+ (define-key map "\C-c\C-n" #'idlwave-next-statement)
+ ;; (define-key map "\r" #'idlwave-newline)
+ ;; (define-key map "\t" #'idlwave-indent-line)
+ (define-key map [(shift iso-lefttab)] #'idlwave-indent-statement)
+ (define-key map "\C-c\C-a" #'auto-fill-mode)
+ (define-key map "\M-q" #'idlwave-fill-paragraph)
+ (define-key map "\M-s" #'idlwave-edit-in-idlde)
+ (define-key map "\C-c\C-h" #'idlwave-doc-header)
+ (define-key map "\C-c\C-m" #'idlwave-doc-modification)
+ (define-key map "\C-c\C-c" #'idlwave-case)
+ (define-key map "\C-c\C-d" #'idlwave-debug-map)
(when (and (listp idlwave-shell-debug-modifiers)
(not (equal idlwave-shell-debug-modifiers '())))
;; Bind the debug commands also with the special modifiers.
@@ -1461,40 +1422,39 @@ Otherwise ARGS forms a list that is evaluated."
(delq 'shift (copy-sequence idlwave-shell-debug-modifiers))))
(define-key map
(vector (append mods-noshift (list (if shift ?C ?c))))
- 'idlwave-shell-save-and-run)
+ #'idlwave-shell-save-and-run)
(define-key map
(vector (append mods-noshift (list (if shift ?B ?b))))
- 'idlwave-shell-break-here)
+ #'idlwave-shell-break-here)
(define-key map
(vector (append mods-noshift (list (if shift ?E ?e))))
- 'idlwave-shell-run-region)))
- (define-key map "\C-c\C-d\C-c" 'idlwave-shell-save-and-run)
- (define-key map "\C-c\C-d\C-b" 'idlwave-shell-break-here)
- (define-key map "\C-c\C-d\C-e" 'idlwave-shell-run-region)
- (define-key map "\C-c\C-f" 'idlwave-for)
- ;; (define-key map "\C-c\C-f" 'idlwave-function)
- ;; (define-key map "\C-c\C-p" 'idlwave-procedure)
- (define-key map "\C-c\C-r" 'idlwave-repeat)
- (define-key map "\C-c\C-w" 'idlwave-while)
- (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers)
- (define-key map "\C-c\C-s" 'idlwave-shell)
- (define-key map "\C-c\C-l" 'idlwave-shell-recenter-shell-window)
- (define-key map "\C-c\C-b" 'idlwave-list-buffer-load-path-shadows)
- (define-key map "\C-c\C-v" 'idlwave-find-module)
- (define-key map "\C-c\C-t" 'idlwave-find-module-this-file)
- (define-key map "\C-c?" 'idlwave-routine-info)
- (define-key map "\M-?" 'idlwave-context-help)
+ #'idlwave-shell-run-region)))
+ (define-key map "\C-c\C-d\C-c" #'idlwave-shell-save-and-run)
+ (define-key map "\C-c\C-d\C-b" #'idlwave-shell-break-here)
+ (define-key map "\C-c\C-d\C-e" #'idlwave-shell-run-region)
+ (define-key map "\C-c\C-f" #'idlwave-for)
+ ;; (define-key map "\C-c\C-f" #'idlwave-function)
+ ;; (define-key map "\C-c\C-p" #'idlwave-procedure)
+ (define-key map "\C-c\C-r" #'idlwave-repeat)
+ (define-key map "\C-c\C-w" #'idlwave-while)
+ (define-key map "\C-c\C-k" #'idlwave-kill-autoloaded-buffers)
+ (define-key map "\C-c\C-s" #'idlwave-shell)
+ (define-key map "\C-c\C-l" #'idlwave-shell-recenter-shell-window)
+ (define-key map "\C-c\C-b" #'idlwave-list-buffer-load-path-shadows)
+ (define-key map "\C-c\C-v" #'idlwave-find-module)
+ (define-key map "\C-c\C-t" #'idlwave-find-module-this-file)
+ (define-key map "\C-c?" #'idlwave-routine-info)
+ (define-key map "\M-?" #'idlwave-context-help)
(define-key map [(control meta ?\?)]
- 'idlwave-help-assistant-help-with-topic)
+ #'idlwave-help-assistant-help-with-topic)
;; Pickup both forms of Esc/Meta binding
- (define-key map [(meta tab)] 'idlwave-complete)
- (define-key map [?\e?\t] 'idlwave-complete)
- (define-key map "\M-\C-i" 'idlwave-complete)
- (define-key map "\C-c\C-i" 'idlwave-update-routine-info)
- (define-key map "\C-c=" 'idlwave-resolve)
- (define-key map
- (if (featurep 'xemacs) [(shift button3)] [(shift mouse-3)])
- 'idlwave-mouse-context-help)
+ ;; FIXME: Use `completion-at-point'!
+ (define-key map [(meta tab)] #'idlwave-complete)
+ (define-key map [?\e?\t] #'idlwave-complete)
+ (define-key map "\M-\C-i" #'idlwave-complete)
+ (define-key map "\C-c\C-i" #'idlwave-update-routine-info)
+ (define-key map "\C-c=" #'idlwave-resolve)
+ (define-key map [(shift mouse-3)] #'idlwave-mouse-context-help)
map)
"Keymap used in IDL mode.")
@@ -1533,28 +1493,15 @@ Otherwise ARGS forms a list that is evaluated."
st)
"Syntax table that treats symbol characters as word characters.")
-(defmacro idlwave-with-special-syntax (&rest body)
- "Execute BODY with a different syntax table."
- `(let ((saved-syntax (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table idlwave-find-symbol-syntax-table)
- ,@body)
- (set-syntax-table saved-syntax))))
-
-;(defmacro idlwave-with-special-syntax1 (&rest body)
-; "Execute BODY with a different syntax table."
-; `(let ((saved-syntax (syntax-table)))
-; (unwind-protect
-; (progn
-; (set-syntax-table idlwave-find-symbol-syntax-table)
-; ,@body)
-; (set-syntax-table saved-syntax))))
+;;(defmacro idlwave-with-special-syntax (&rest body)
+;; "Execute BODY with `idlwave-find-symbol-syntax-table'."
+;; `(with-syntax-table idlwave-find-symbol-syntax-table
+;; ,@body))
(defun idlwave-action-and-binding (key cmd &optional select)
"KEY and CMD are made into a key binding and an indent action.
KEY is a string - same as for the `define-key' function. CMD is a
-function of no arguments or a list to be evaluated. CMD is bound to
+function of one argument. CMD is bound to
KEY in `idlwave-mode-map' by defining an anonymous function calling
`self-insert-command' followed by CMD. If KEY contains more than one
character a binding will only be set if SELECT is `both'.
@@ -1571,62 +1518,59 @@ Otherwise, if SELECT is non-nil then only an action is created.
Some examples:
No spaces before and 1 after a comma
- (idlwave-action-and-binding \",\" \\='(idlwave-surround 0 1))
+ (idlwave-action-and-binding \",\" (lambda (_) (idlwave-surround 0 1)))
A minimum of 1 space before and after `=' (see `idlwave-expand-equal').
- (idlwave-action-and-binding \"=\" \\='(idlwave-expand-equal -1 -1))
+ (idlwave-action-and-binding \"=\" (lambda (_) (idlwave-expand-equal -1 -1)))
Capitalize system variables - action only
- (idlwave-action-and-binding idlwave-sysvar \\='(capitalize-word 1) t)"
+ (idlwave-action-and-binding idlwave-sysvar (lambda (_) (capitalize-word 1) t))"
(if (not (equal select 'noaction))
;; Add action
(let* ((table (if select 'idlwave-indent-action-table
'idlwave-indent-expand-table))
- (table-key (regexp-quote key))
- (cell (assoc table-key (eval table))))
- (if cell
- ;; Replace action command
- (setcdr cell cmd)
- ;; New action
- (set table (append (eval table) (list (cons table-key cmd)))))))
+ (table-key (regexp-quote key)))
+ (setf (alist-get table-key (symbol-value table) nil nil #'equal) cmd)))
;; Make key binding for action
- (if (or (and (null select) (= (length key) 1))
- (equal select 'noaction)
- (equal select 'both))
+ (if (if (null select) (= (length key) 1)
+ (memq select '(noaction both)))
+ ;; FIXME: Use `post-self-insert-hook'!
(define-key idlwave-mode-map key
- `(lambda ()
- (interactive)
- (self-insert-command 1)
- ,(if (listp cmd) cmd (list cmd))))))
+ (lambda ()
+ (interactive)
+ (self-insert-command 1)
+ (if (functionp cmd) (funcall cmd nil) (eval cmd t))))))
;; Set action and key bindings.
;; See description of the function `idlwave-action-and-binding'.
;; Automatically add spaces for the following characters
;; Actions for & are complicated by &&
-(idlwave-action-and-binding "&" 'idlwave-custom-ampersand-surround)
+(idlwave-action-and-binding "&" #'idlwave-custom-ampersand-surround)
;; Automatically add spaces to equal sign if not keyword. This needs
;; to go ahead of > and <, so >= and <= will be treated correctly
-(idlwave-action-and-binding "=" '(idlwave-expand-equal -1 -1))
+(idlwave-action-and-binding "=" (lambda (_) (idlwave-expand-equal -1 -1)))
;; Actions for > and < are complicated by >=, <=, and ->...
-(idlwave-action-and-binding "<" '(idlwave-custom-ltgtr-surround nil))
-(idlwave-action-and-binding ">" '(idlwave-custom-ltgtr-surround 'gtr))
+(idlwave-action-and-binding "<" (lambda (a) (idlwave-custom-ltgtr-surround nil a)))
+(idlwave-action-and-binding ">" (lambda (a) (idlwave-custom-ltgtr-surround t a)))
-(idlwave-action-and-binding "," '(idlwave-surround 0 -1 1))
+(idlwave-action-and-binding "," (lambda (a) (idlwave-surround 0 -1 1 a)))
;;;
;;; Abbrev Section
;;;
-;;; When expanding abbrevs and the abbrev hook moves backward, an extra
-;;; space is inserted (this is the space typed by the user to expanded
-;;; the abbrev).
-;;;
-(defvar idlwave-mode-abbrev-table nil
- "Abbreviation table used for IDLWAVE mode.")
-(define-abbrev-table 'idlwave-mode-abbrev-table ())
+;; When expanding abbrevs and the abbrev hook moves backward, an extra
+;; space is inserted (this is the space typed by the user to expanded
+;; the abbrev).
+;; FIXME: This can be controlled with `no-self-insert' property.
+;;
+(define-abbrev-table 'idlwave-mode-abbrev-table ()
+ "Abbreviation table used for IDLWAVE mode."
+ :enable-function (lambda () (not (idlwave-quoted))))
(defun idlwave-define-abbrev (name expansion hook &optional noprefix table)
+ ;; FIXME: `table' is never passed.
"Define-abbrev with backward compatibility.
If NOPREFIX is non-nil, don't prepend prefix character. Installs into
@@ -1637,8 +1581,8 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into
expansion
hook)))
(condition-case nil
- (apply 'define-abbrev (append args '(0 t)))
- (error (apply 'define-abbrev args)))))
+ (apply #'define-abbrev (append args '(0 t)))
+ (error (apply #'define-abbrev args)))))
(condition-case nil
(modify-syntax-entry (string-to-char idlwave-abbrev-start-char)
@@ -1648,15 +1592,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into
;;
;; Templates
;;
-(idlwave-define-abbrev "c" "" (idlwave-code-abbrev idlwave-case))
-(idlwave-define-abbrev "sw" "" (idlwave-code-abbrev idlwave-switch))
-(idlwave-define-abbrev "f" "" (idlwave-code-abbrev idlwave-for))
-(idlwave-define-abbrev "fu" "" (idlwave-code-abbrev idlwave-function))
-(idlwave-define-abbrev "pr" "" (idlwave-code-abbrev idlwave-procedure))
-(idlwave-define-abbrev "r" "" (idlwave-code-abbrev idlwave-repeat))
-(idlwave-define-abbrev "w" "" (idlwave-code-abbrev idlwave-while))
-(idlwave-define-abbrev "i" "" (idlwave-code-abbrev idlwave-if))
-(idlwave-define-abbrev "elif" "" (idlwave-code-abbrev idlwave-elif))
+(idlwave-define-abbrev "c" "" #'idlwave-case)
+(idlwave-define-abbrev "sw" "" #'idlwave-switch)
+(idlwave-define-abbrev "f" "" #'idlwave-for)
+(idlwave-define-abbrev "fu" "" #'idlwave-function)
+(idlwave-define-abbrev "pr" "" #'idlwave-procedure)
+(idlwave-define-abbrev "r" "" #'idlwave-repeat)
+(idlwave-define-abbrev "w" "" #'idlwave-while)
+(idlwave-define-abbrev "i" "" #'idlwave-if)
+(idlwave-define-abbrev "elif" "" #'idlwave-elif)
;;
;; Keywords, system functions, conversion routines
;;
@@ -1671,15 +1615,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into
(idlwave-define-abbrev "cc" "complex()" (idlwave-keyword-abbrev 1))
(idlwave-define-abbrev "cd" "double()" (idlwave-keyword-abbrev 1))
(idlwave-define-abbrev "e" "else" (idlwave-keyword-abbrev 0 t))
-(idlwave-define-abbrev "ec" "endcase" 'idlwave-show-begin)
-(idlwave-define-abbrev "es" "endswitch" 'idlwave-show-begin)
-(idlwave-define-abbrev "ee" "endelse" 'idlwave-show-begin)
-(idlwave-define-abbrev "ef" "endfor" 'idlwave-show-begin)
-(idlwave-define-abbrev "ei" "endif else if" 'idlwave-show-begin)
-(idlwave-define-abbrev "el" "endif else" 'idlwave-show-begin)
-(idlwave-define-abbrev "en" "endif" 'idlwave-show-begin)
-(idlwave-define-abbrev "er" "endrep" 'idlwave-show-begin)
-(idlwave-define-abbrev "ew" "endwhile" 'idlwave-show-begin)
+(idlwave-define-abbrev "ec" "endcase" #'idlwave-show-begin)
+(idlwave-define-abbrev "es" "endswitch" #'idlwave-show-begin)
+(idlwave-define-abbrev "ee" "endelse" #'idlwave-show-begin)
+(idlwave-define-abbrev "ef" "endfor" #'idlwave-show-begin)
+(idlwave-define-abbrev "ei" "endif else if" #'idlwave-show-begin)
+(idlwave-define-abbrev "el" "endif else" #'idlwave-show-begin)
+(idlwave-define-abbrev "en" "endif" #'idlwave-show-begin)
+(idlwave-define-abbrev "er" "endrep" #'idlwave-show-begin)
+(idlwave-define-abbrev "ew" "endwhile" #'idlwave-show-begin)
(idlwave-define-abbrev "g" "goto," (idlwave-keyword-abbrev 0 t))
(idlwave-define-abbrev "h" "help," (idlwave-keyword-abbrev 0))
(idlwave-define-abbrev "k" "keyword_set()" (idlwave-keyword-abbrev 1))
@@ -1727,15 +1671,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into
(idlwave-define-abbrev "continue" "continue" (idlwave-keyword-abbrev 0 t) t)
(idlwave-define-abbrev "do" "do" (idlwave-keyword-abbrev 0 t) t)
(idlwave-define-abbrev "else" "else" (idlwave-keyword-abbrev 0 t) t)
-(idlwave-define-abbrev "end" "end" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endcase" "endcase" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endelse" "endelse" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endfor" "endfor" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endif" "endif" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endrep" "endrep" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endswitch" "endswitch" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endwhi" "endwhi" 'idlwave-show-begin-check t)
-(idlwave-define-abbrev "endwhile" "endwhile" 'idlwave-show-begin-check t)
+(idlwave-define-abbrev "end" "end" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endcase" "endcase" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endelse" "endelse" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endfor" "endfor" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endif" "endif" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endrep" "endrep" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endswitch" "endswitch" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endwhi" "endwhi" #'idlwave-show-begin-check t)
+(idlwave-define-abbrev "endwhile" "endwhile" #'idlwave-show-begin-check t)
(idlwave-define-abbrev "eq" "eq" (idlwave-keyword-abbrev 0 t) t)
(idlwave-define-abbrev "for" "for" (idlwave-keyword-abbrev 0 t) t)
(idlwave-define-abbrev "function" "function" (idlwave-keyword-abbrev 0 t) t)
@@ -1795,7 +1739,7 @@ The main features of this mode are
Use \\[idlwave-fill-paragraph] to refill a paragraph inside a
comment. The indentation of the second line of the paragraph
relative to the first will be retained. Use
- \\[idlwave-auto-fill-mode] to toggle auto-fill mode for these
+ \\[auto-fill-mode] to toggle auto-fill mode for these
comments. When the variable `idlwave-fill-comment-line-only' is
nil, code can also be auto-filled and auto-indented.
@@ -1870,7 +1814,6 @@ The main features of this mode are
8. Hooks
-----
- Loading idlwave.el runs `idlwave-load-hook'.
Turning on `idlwave-mode' runs `idlwave-mode-hook'.
9. Documentation and Customization
@@ -1879,7 +1822,7 @@ The main features of this mode are
\\[idlwave-info] to display (complain to your sysadmin if that does
not work). For Postscript, PDF, and HTML versions of the
documentation, check IDLWAVE's homepage at URL
- `http://github.com/jdtsmith/idlwave'.
+ `https://github.com/jdtsmith/idlwave'.
IDLWAVE has customize support - see the group `idlwave'.
10.Keybindings
@@ -1894,7 +1837,7 @@ The main features of this mode are
(message "Emacs IDLWAVE mode version %s." idlwave-mode-version))
(setq idlwave-startup-message nil)
- (set (make-local-variable 'indent-line-function) 'idlwave-indent-and-action)
+ (set (make-local-variable 'indent-line-function) #'idlwave-indent-and-action)
(set (make-local-variable idlwave-comment-indent-function)
#'idlwave-comment-hook)
@@ -1906,13 +1849,9 @@ The main features of this mode are
(set (make-local-variable 'indent-tabs-mode) nil)
(set (make-local-variable 'completion-ignore-case) t)
- (when (featurep 'easymenu)
- (easy-menu-add idlwave-mode-menu idlwave-mode-map)
- (easy-menu-add idlwave-mode-debug-menu idlwave-mode-map))
-
(setq abbrev-mode t)
- (set (make-local-variable idlwave-fill-function) 'idlwave-auto-fill)
+ (set (make-local-variable 'normal-auto-fill-function) #'idlwave-auto-fill)
(setq comment-end "")
(set (make-local-variable 'comment-multi-line) nil)
(set (make-local-variable 'paragraph-separate)
@@ -1923,28 +1862,27 @@ The main features of this mode are
;; ChangeLog
(set (make-local-variable 'add-log-current-defun-function)
- 'idlwave-current-routine-fullname)
+ #'idlwave-current-routine-fullname)
;; Set tag table list to use IDLTAGS as file name.
(if (boundp 'tag-table-alist)
- (add-to-list 'tag-table-alist '("\\.pro$" . "IDLTAGS")))
+ (add-to-list 'tag-table-alist '("\\.pro\\'" . "IDLTAGS")))
;; Font-lock additions
- ;; Following line is for Emacs - XEmacs uses the corresponding property
- ;; on the `idlwave-mode' symbol.
(set (make-local-variable 'font-lock-defaults) idlwave-font-lock-defaults)
(set (make-local-variable 'font-lock-mark-block-function)
- 'idlwave-mark-subprogram)
+ #'idlwave-mark-subprogram)
(set (make-local-variable 'font-lock-fontify-region-function)
- 'idlwave-font-lock-fontify-region)
+ #'idlwave-font-lock-fontify-region)
;; Imenu setup
- (set (make-local-variable 'imenu-create-index-function)
- 'imenu-default-create-index-function)
+ ;;(set (make-local-variable 'imenu-create-index-function)
+ ;; ;; FIXME: Why set it explicitly to the value it already has?
+ ;; #'imenu-default-create-index-function)
(set (make-local-variable 'imenu-extract-index-name-function)
- 'idlwave-unit-name)
+ #'idlwave-unit-name)
(set (make-local-variable 'imenu-prev-index-position-function)
- 'idlwave-prev-index-position)
+ #'idlwave-prev-index-position)
;; HideShow setup
(add-to-list 'hs-special-modes-alist
@@ -1955,17 +1893,12 @@ The main features of this mode are
'idlwave-forward-block nil))
;; Make a local post-command-hook and add our hook to it
- ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility
- ;; (make-local-hook 'post-command-hook)
- (add-hook 'post-command-hook 'idlwave-command-hook nil 'local)
+ (add-hook 'post-command-hook #'idlwave-command-hook nil 'local)
;; Make local hooks for buffer updates
- ;; NB: `make-local-hook' needed for older/alternative Emacs compatibility
- ;; (make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'idlwave-kill-buffer-update nil 'local)
- ;; (make-local-hook 'after-save-hook)
- (add-hook 'after-save-hook 'idlwave-save-buffer-update nil 'local)
- (add-hook 'after-save-hook 'idlwave-revoke-license-to-kill nil 'local)
+ (add-hook 'kill-buffer-hook #'idlwave-kill-buffer-update nil 'local)
+ (add-hook 'after-save-hook #'idlwave-save-buffer-update nil 'local)
+ (add-hook 'after-save-hook #'idlwave-revoke-license-to-kill nil 'local)
;; Setup directories and file, if necessary
(idlwave-setup)
@@ -2018,29 +1951,27 @@ The main features of this mode are
;;; This stuff is experimental
-(defvar idlwave-command-hook nil
- "If non-nil, a list that can be evaluated using `eval'.
+(defvar idlwave--command-function nil
+ "If non-nil, a function called from `post-command-hook'.
It is evaluated in the lisp function `idlwave-command-hook' which is
placed in `post-command-hook'.")
(defun idlwave-command-hook ()
"Command run after every command.
-Evaluates a non-nil value of the *variable* `idlwave-command-hook' and
+Evaluates a non-nil value of the *variable* `idlwave--command-function' and
sets the variable to zero afterwards."
- (and idlwave-command-hook
- (listp idlwave-command-hook)
- (condition-case nil
- (eval idlwave-command-hook)
- (error nil)))
- (setq idlwave-command-hook nil))
+ (and idlwave--command-function
+ (with-demoted-errors "idlwave-command-hook: %S"
+ (funcall (prog1 idlwave--command-function
+ (setq idlwave--command-function nil))))))
;;; End experiment
;; It would be better to use expand.el for better abbrev handling and
;; versatility.
-(defun idlwave-check-abbrev (arg &optional reserved)
- "Reverse abbrev expansion if in comment or string.
+(defun idlwave-modify-abbrev (arg &optional reserved)
+ "Tweak the abbrev we just expanded.
Argument ARG is the number of characters to move point
backward if `idlwave-abbrev-move' is non-nil.
If optional argument RESERVED is non-nil then the expansion
@@ -2050,21 +1981,16 @@ Otherwise, the abbrev will be capitalized if `idlwave-abbrev-change-case'
is non-nil, unless its value is `down' in which case the abbrev will be
made into all lowercase.
Returns non-nil if abbrev is left expanded."
- (if (idlwave-quoted)
- (progn (unexpand-abbrev)
- nil)
- (if (and reserved idlwave-reserved-word-upcase)
- (upcase-region last-abbrev-location (point))
- (cond
- ((equal idlwave-abbrev-change-case 'down)
- (downcase-region last-abbrev-location (point)))
- (idlwave-abbrev-change-case
- (upcase-region last-abbrev-location (point)))))
- (if (and idlwave-abbrev-move (> arg 0))
- (if (boundp 'post-command-hook)
- (setq idlwave-command-hook (list 'backward-char (1+ arg)))
- (backward-char arg)))
- t))
+ (if (and reserved idlwave-reserved-word-upcase)
+ (upcase-region last-abbrev-location (point))
+ (cond
+ ((equal idlwave-abbrev-change-case 'down)
+ (downcase-region last-abbrev-location (point)))
+ (idlwave-abbrev-change-case
+ (upcase-region last-abbrev-location (point)))))
+ (if (and idlwave-abbrev-move (> arg 0))
+ (setq idlwave--command-function (lambda () (backward-char (1+ arg)))))
+ t)
(defun idlwave-in-comment ()
"Return t if point is inside a comment, nil otherwise."
@@ -2091,11 +2017,7 @@ Returns point if comment found and nil otherwise."
(backward-char 1)
(point)))))
-(defun idlwave-region-active-p ()
- "Should we operate on an active region?"
- (if (fboundp 'use-region-p)
- (use-region-p)
- (region-active-p)))
+(define-obsolete-function-alias 'idlwave-region-active-p #'use-region-p "28.1")
(defun idlwave-show-matching-quote ()
"Insert quote and show matching quote if this is end of a string."
@@ -2115,13 +2037,12 @@ Returns point if comment found and nil otherwise."
(defun idlwave-show-begin-check ()
"Ensure that the previous word was a token before `idlwave-show-begin'.
An END token must be preceded by whitespace."
- (if (not (idlwave-quoted))
- (if
- (save-excursion
- (backward-word-strictly 1)
- (backward-char 1)
- (looking-at "[ \t\n\f]"))
- (idlwave-show-begin))))
+ (if
+ (save-excursion
+ (backward-word-strictly 1)
+ (backward-char 1)
+ (looking-at "[ \t\n\f]"))
+ (idlwave-show-begin)))
(defun idlwave-show-begin ()
"Find the start of current block and blinks to it for a second.
@@ -2136,7 +2057,7 @@ Also checks if the correct END statement has been used."
begin-pos end-pos end end1 )
(if idlwave-reindent-end (idlwave-indent-line))
(setq last-abbrev-location (marker-position last-abbrev-marker))
- (when (and (idlwave-check-abbrev 0 t)
+ (when (and (idlwave-modify-abbrev 0 t)
idlwave-show-block)
(save-excursion
;; Move inside current block
@@ -2226,11 +2147,11 @@ Also checks if the correct END statement has been used."
(next-char (char-after (point)))
(method-invoke (and gtr (eq prev-char ?-)))
(len (if method-invoke 2 1)))
- (unless (eq next-char ?=)
+ (unless (eq next-char ?=)
;; Key binding: pad only on left, to save for possible >=/<=
(idlwave-surround -1 (if (or is-action method-invoke) -1) len))))
-(defun idlwave-surround (&optional before after length is-action)
+(defun idlwave-surround (&optional before after length _is-action)
"Surround the LENGTH characters before point with blanks.
LENGTH defaults to 1.
Optional arguments BEFORE and AFTER affect the behavior before and
@@ -2689,7 +2610,7 @@ statement."
(if st
(append st (match-end 0))))))
-(defun idlwave-expand-equal (&optional before after is-action)
+(defun idlwave-expand-equal (&optional before after _is-action)
"Pad `=' with spaces.
Two cases: Assignment statement, and keyword assignment.
Which case is determined using `idlwave-start-of-substatement' and
@@ -2797,10 +2718,10 @@ If the optional argument EXPAND is non-nil then the actions in
;; Before indenting, run action routines.
;;
(if (and expand idlwave-do-actions)
- (mapc 'idlwave-do-action idlwave-indent-expand-table))
+ (mapc #'idlwave-do-action idlwave-indent-expand-table))
;;
(if idlwave-do-actions
- (mapc 'idlwave-do-action idlwave-indent-action-table))
+ (mapc #'idlwave-do-action idlwave-indent-action-table))
;;
;; No longer expand abbrevs on the line. The user can do this
;; manually using expand-region-abbrevs.
@@ -2820,10 +2741,7 @@ If the optional argument EXPAND is non-nil then the actions in
;; Adjust parallel comment
(end-of-line)
(if (idlwave-in-comment)
- ;; Emacs 21 is too smart with fill-column on comment indent
- (let ((fill-column (if (fboundp 'comment-indent-new-line)
- (1- (frame-width))
- fill-column)))
+ (let ((fill-column (1- (frame-width))))
(indent-for-comment)))))
(goto-char mloc)
;; Get rid of marker
@@ -2832,18 +2750,19 @@ If the optional argument EXPAND is non-nil then the actions in
(defun idlwave-do-action (action)
"Perform an action repeatedly on a line.
ACTION is a list (REG . FUNC). REG is a regular expression. FUNC is
-either a function name to be called with `funcall' or a list to be
-evaluated with `eval'. The action performed by FUNC should leave
-point after the match for REG - otherwise an infinite loop may be
-entered. FUNC is always passed a final argument of `is-action', so it
+either a function which will be called with one argument `is-action' or
+a list to be evaluated with `eval'.
+The action performed by FUNC should leave point after the match for REG
+- otherwise an infinite loop may be entered.
+FUNC is always passed a final argument of `is-action', so it
can discriminate between being run as an action, or a key binding."
(let ((action-key (car action))
(action-routine (cdr action)))
(beginning-of-line)
(while (idlwave-look-at action-key)
- (if (listp action-routine)
- (eval (append action-routine '('is-action)))
- (funcall action-routine 'is-action)))))
+ (if (functionp action-routine)
+ (funcall action-routine 'is-action)
+ (eval (append action-routine '('is-action)) t)))))
(defun idlwave-indent-to (col &optional min)
"Indent from point with spaces until column COL.
@@ -3104,7 +3023,7 @@ Return value is the beginning of the match or (in case of failure) nil."
(let ((case-fold-search t)
(search-func (if (> dir 0) 're-search-forward 're-search-backward))
found)
- (idlwave-with-special-syntax
+ (with-syntax-table idlwave-find-symbol-syntax-table
(save-excursion
(catch 'exit
(while (funcall search-func key-re limit t)
@@ -3232,7 +3151,7 @@ If successful leaves point after the match, otherwise, does not move point."
(if cont (idlwave-end-of-statement) (end-of-line))
(point)))
found)
- (idlwave-with-special-syntax
+ (with-syntax-table idlwave-find-symbol-syntax-table
(if beg (idlwave-beginning-of-statement))
(while (and (setq found (re-search-forward regexp eos t))
(idlwave-quoted))))
@@ -3516,25 +3435,7 @@ if `idlwave-auto-fill-split-string' is non-nil."
(idlwave-indent-line))
)))))
-(defun idlwave-auto-fill-mode (arg)
- "Toggle auto-fill mode for IDL mode.
-With arg, turn auto-fill mode on if arg is positive.
-In auto-fill mode, inserting a space at a column beyond `fill-column'
-automatically breaks the line at a previous space."
- (interactive "P")
- (prog1 (set idlwave-fill-function
- (if (if (null arg)
- (not (symbol-value idlwave-fill-function))
- (> (prefix-numeric-value arg) 0))
- 'idlwave-auto-fill
- nil))
- ;; update mode-line
- (set-buffer-modified-p (buffer-modified-p))))
-
-;(defun idlwave-fill-routine-call ()
-; "Fill a routine definition or statement, indenting appropriately."
-; (let ((where (idlwave-where)))))
-
+(define-obsolete-function-alias 'idlwave-auto-fill-mode #'auto-fill-mode "28.1")
(defun idlwave-doc-header (&optional nomark)
"Insert a documentation header at the beginning of the unit.
@@ -3629,6 +3530,7 @@ Calling from a program, arguments are START END."
(defun idlwave-quoted ()
"Return t if point is in a comment or quoted string.
Returns nil otherwise."
+ ;; FIXME: Use (nth 8 (synx-ppss))!
(and (or (idlwave-in-comment) (idlwave-in-quote)) t))
(defun idlwave-in-quote ()
@@ -3832,15 +3734,8 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(setq start (match-end 0)))
(setq ret_string (concat ret_string (substring string start last)))))
-(defun idlwave-get-buffer-visiting (file)
- ;; Return the buffer currently visiting FILE
- (cond
- ((boundp 'find-file-compare-truenames) ; XEmacs
- (let ((find-file-compare-truenames t))
- (get-file-buffer file)))
- ((fboundp 'find-buffer-visiting) ; Emacs
- (find-buffer-visiting file))
- (t (error "This should not happen (idlwave-get-buffer-visiting)"))))
+(define-obsolete-function-alias 'idlwave-get-buffer-visiting
+ #'find-buffer-visiting "28.1")
(defvar idlwave-outlawed-buffers nil
"List of buffers pulled up by IDLWAVE for special reasons.
@@ -3848,7 +3743,7 @@ Buffers in this list may be killed by `idlwave-kill-autoloaded-buffers'.")
(defun idlwave-find-file-noselect (file &optional why)
;; Return a buffer visiting file.
- (or (idlwave-get-buffer-visiting file)
+ (or (find-buffer-visiting file)
(let ((buf (find-file-noselect file)))
(if why (add-to-list 'idlwave-outlawed-buffers (cons buf why)))
buf)))
@@ -3916,7 +3811,7 @@ Intended for `after-save-hook'."
(setq idlwave-outlawed-buffers
(delq entry idlwave-outlawed-buffers)))
;; Remove this function from the hook.
- (remove-hook 'after-save-hook 'idlwave-revoke-license-to-kill 'local)))
+ (remove-hook 'after-save-hook #'idlwave-revoke-license-to-kill 'local)))
(defvar idlwave-path-alist)
(defun idlwave-locate-lib-file (file)
@@ -4042,12 +3937,7 @@ blank lines."
;; skip blank lines
(skip-chars-forward " \t\n")
(if (looking-at (concat "[ \t]*\\(" comment-start "+\\)"))
- (if (fboundp 'uncomment-region)
- (uncomment-region beg end)
- (comment-region beg end
- (- (length (buffer-substring
- (match-beginning 1)
- (match-end 1))))))
+ (uncomment-region beg end)
(comment-region beg end)))))
@@ -4093,11 +3983,6 @@ blank lines."
(defun idlwave-reset-sintern (&optional what)
"Reset all sintern hashes."
;; Make sure the hash functions are accessible.
- (unless (and (fboundp 'gethash)
- (fboundp 'puthash))
- (require 'cl)
- (or (fboundp 'puthash)
- (defalias 'puthash 'cl-puthash)))
(let ((entries '((idlwave-sint-routines 1000 10)
(idlwave-sint-keywords 1000 10)
(idlwave-sint-methods 100 10)
@@ -4166,10 +4051,10 @@ blank lines."
(set (idlwave-sintern-set name 'class idlwave-sint-classes set))
(name)))
-(defun idlwave-sintern-dir (dir &optional set)
+(defun idlwave-sintern-dir (dir &optional _set)
(car (or (member dir idlwave-sint-dirs)
(setq idlwave-sint-dirs (cons dir idlwave-sint-dirs)))))
-(defun idlwave-sintern-libname (name &optional set)
+(defun idlwave-sintern-libname (name &optional _set)
(car (or (member name idlwave-sint-libnames)
(setq idlwave-sint-libnames (cons name idlwave-sint-libnames)))))
@@ -4237,7 +4122,7 @@ the base of the directory."
;; Creating new sintern tables
-(defun idlwave-new-sintern-type (tag)
+(defmacro idlwave-new-sintern-type (tag)
"Define a variable and a function to sintern the new type TAG.
This defines the function `idlwave-sintern-TAG' and the variable
`idlwave-sint-TAGs'."
@@ -4245,15 +4130,15 @@ This defines the function `idlwave-sintern-TAG' and the variable
(names (concat name "s"))
(var (intern (concat "idlwave-sint-" names)))
(func (intern (concat "idlwave-sintern-" name))))
- (set var nil) ; initial value of the association list
- (fset func ; set the function
- `(lambda (name &optional set)
- (cond ((not (stringp name)) name)
- ((cdr (assoc (downcase name) ,var)))
- (set
- (setq ,var (cons (cons (downcase name) name) ,var))
- name)
- (name))))))
+ `(progn
+ (defvar ,var nil) ; initial value of the association list
+ (defun ,func (name &optional set)
+ (cond ((not (stringp name)) name)
+ ((cdr (assoc (downcase name) ,var)))
+ (set
+ (push (cons (downcase name) name) ,var)
+ name)
+ (name))))))
(defun idlwave-reset-sintern-type (tag)
"Reset the sintern variable associated with TAG."
@@ -4364,12 +4249,12 @@ will re-read the catalog."
"-l" (expand-file-name "~/.emacs")
"-l" "idlwave"
"-f" "idlwave-rescan-catalog-directories"))
- (process (apply 'start-process "idlcat"
+ (process (apply #'start-process "idlcat"
nil emacs args)))
(setq idlwave-catalog-process process)
(set-process-sentinel
process
- (lambda (pro why)
+ (lambda (_pro why)
(when (string-match "finished" why)
(setq idlwave-routines nil
idlwave-system-routines nil
@@ -4517,7 +4402,7 @@ information updated immediately, leave NO-CONCATENATE nil."
(setq idlwave-load-rinfo-idle-timer
(run-with-idle-timer
idlwave-init-rinfo-when-idle-after
- nil 'idlwave-load-rinfo-next-step)))
+ nil #'idlwave-load-rinfo-next-step)))
(error nil))))
;;------ XML Help routine info system
@@ -5003,7 +4888,7 @@ Cache to disk for quick recovery."
(setq idlwave-load-rinfo-idle-timer
(run-with-idle-timer
idlwave-init-rinfo-when-idle-after
- nil 'idlwave-load-rinfo-next-step))))))
+ nil #'idlwave-load-rinfo-next-step))))))
(defvar idlwave-after-load-rinfo-hook nil)
@@ -5177,7 +5062,7 @@ Can run from `after-save-hook'."
(error nil)))
(push res routine-lists)))))
;; Concatenate the individual lists and return the result
- (apply 'nconc routine-lists)))
+ (apply #'nconc routine-lists)))
(defun idlwave-get-buffer-routine-info ()
"Scan the current buffer for routine info. Return (PRO-LIST FUNC-LIST)."
@@ -5253,10 +5138,10 @@ Can run from `after-save-hook'."
(if args
(concat
(if (string= type "function") "(" ", ")
- (mapconcat 'identity args ", ")
+ (mapconcat #'identity args ", ")
(if (string= type "function") ")" ""))))
(if keywords
- (cons nil (mapcar 'list keywords)) ;No help file
+ (cons nil (mapcar #'list keywords)) ;No help file
nil))))
@@ -5314,7 +5199,7 @@ as last time - so no widget will pop up."
(cons x (cdr path-entry))
(list x))))
(idlwave-expand-path idlwave-library-path))
- (mapcar 'list (idlwave-expand-path idlwave-library-path)))))
+ (mapcar #'list (idlwave-expand-path idlwave-library-path)))))
;; Ask the shell for the path and then run the widget
(t
@@ -5382,7 +5267,7 @@ directories and save the routine info.
(widget-insert " ")
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(let ((path-list (widget-get idlwave-widget :path-dirs)))
(dolist (x path-list)
(unless (memq 'lib (cdr x))
@@ -5392,7 +5277,7 @@ directories and save the routine info.
(widget-insert " ")
(widget-create 'push-button
:notify
- (lambda (&rest ignore)
+ (lambda (&rest _ignore)
(let ((path-list (widget-get idlwave-widget :path-dirs)))
(dolist (x path-list)
(idlwave-path-alist-remove-flag x 'user))
@@ -5400,7 +5285,7 @@ directories and save the routine info.
"Deselect All")
(widget-insert " ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
+ :notify (lambda (&rest _ignore)
(kill-buffer (current-buffer)))
"Quit")
(widget-insert "\n\n")
@@ -5408,7 +5293,7 @@ directories and save the routine info.
(widget-insert "Select Directories: \n")
(setq idlwave-widget
- (apply 'widget-create
+ (apply #'widget-create
'checklist
:value (delq nil (mapcar (lambda (x)
(if (memq 'user (cdr x))
@@ -5420,7 +5305,8 @@ directories and save the routine info.
(list 'item
(if (memq 'lib (cdr x))
(concat "[LIB] " (car x) )
- (car x)))) dirs-list)))
+ (car x))))
+ dirs-list)))
(widget-put idlwave-widget :path-dirs dirs-list)
(widget-insert "\n")
(use-local-map widget-keymap)
@@ -5428,14 +5314,14 @@ directories and save the routine info.
(goto-char (point-min))
(delete-other-windows))
-(defun idlwave-delete-user-catalog-file (&rest ignore)
+(defun idlwave-delete-user-catalog-file (&rest _ignore)
(if (yes-or-no-p
(format "Delete file %s " idlwave-user-catalog-file))
(progn
(delete-file idlwave-user-catalog-file)
(message "%s has been deleted" idlwave-user-catalog-file))))
-(defun idlwave-widget-scan-user-lib-files (&rest ignore)
+(defun idlwave-widget-scan-user-lib-files (&rest _ignore)
;; Call `idlwave-scan-user-lib-files' with data taken from the widget.
(let* ((widget idlwave-widget)
(selected-dirs (widget-value widget))
@@ -5585,7 +5471,7 @@ be set to nil to disable library catalog scanning."
(let ((dirs
(if idlwave-library-path
(idlwave-expand-path idlwave-library-path)
- (mapcar 'car idlwave-path-alist)))
+ (mapcar #'car idlwave-path-alist)))
(old-libname "")
dir-entry dir catalog all-routines)
(if message-base (message "%s" message-base))
@@ -5798,11 +5684,10 @@ end
(defvar idlwave-completion-help-info nil)
(defvar idlwave-completion-help-links nil)
(defvar idlwave-current-obj_new-class nil)
-(defvar idlwave-complete-special nil)
-(defvar method-selector)
-(defvar class-selector)
-(defvar type-selector)
-(defvar super-classes)
+(defvar idlwave--method-selector)
+(defvar idlwave--class-selector)
+(defvar idlwave--type-selector)
+(defvar idlwave--super-classes)
(defun idlwave-complete (&optional arg module class)
"Complete a function, procedure or keyword name at point.
@@ -5883,8 +5768,7 @@ When we force a method or a method keyword, CLASS can specify the class."
(idlwave-complete-filename))
;; Check for any special completion functions
- ((and idlwave-complete-special
- (idlwave-call-special idlwave-complete-special)))
+ ((run-hook-with-args-until-success 'idlwave-complete-functions))
((null what)
(error "Nothing to complete here"))
@@ -5897,22 +5781,26 @@ When we force a method or a method keyword, CLASS can specify the class."
((eq what 'procedure)
;; Complete a procedure name
(let* ((cw-list (nth 3 where-list))
- (class-selector (idlwave-determine-class cw-list 'pro))
- (super-classes (unless (idlwave-explicit-class-listed cw-list)
- (idlwave-all-class-inherits class-selector)))
- (isa (concat "procedure" (if class-selector "-method" "")))
- (type-selector 'pro))
+ (idlwave--class-selector (idlwave-determine-class cw-list 'pro))
+ (idlwave--super-classes
+ (unless (idlwave-explicit-class-listed cw-list)
+ (idlwave-all-class-inherits idlwave--class-selector)))
+ (isa (concat "procedure"
+ (if idlwave--class-selector "-method" "")))
+ (idlwave--type-selector 'pro))
(setq idlwave-completion-help-info
- (list 'routine nil type-selector class-selector nil super-classes))
+ (list 'routine nil
+ idlwave--type-selector idlwave--class-selector
+ nil idlwave--super-classes))
(idlwave-complete-in-buffer
- 'procedure (if class-selector 'method 'routine)
+ 'procedure (if idlwave--class-selector 'method 'routine)
(idlwave-routines) 'idlwave-selector
(format "Select a %s name%s"
isa
- (if class-selector
+ (if idlwave--class-selector
(format " (class is %s)"
- (if (eq class-selector t)
- "unknown" class-selector))
+ (if (eq idlwave--class-selector t)
+ "unknown" idlwave--class-selector))
""))
isa
'idlwave-attach-method-classes 'idlwave-add-file-link-selector)))
@@ -5920,22 +5808,25 @@ When we force a method or a method keyword, CLASS can specify the class."
((eq what 'function)
;; Complete a function name
(let* ((cw-list (nth 3 where-list))
- (class-selector (idlwave-determine-class cw-list 'fun))
- (super-classes (unless (idlwave-explicit-class-listed cw-list)
- (idlwave-all-class-inherits class-selector)))
- (isa (concat "function" (if class-selector "-method" "")))
- (type-selector 'fun))
+ (idlwave--class-selector (idlwave-determine-class cw-list 'fun))
+ (idlwave--super-classes
+ (unless (idlwave-explicit-class-listed cw-list)
+ (idlwave-all-class-inherits idlwave--class-selector)))
+ (isa (concat "function" (if idlwave--class-selector "-method" "")))
+ (idlwave--type-selector 'fun))
(setq idlwave-completion-help-info
- (list 'routine nil type-selector class-selector nil super-classes))
+ (list 'routine nil
+ idlwave--type-selector idlwave--class-selector
+ nil idlwave--super-classes))
(idlwave-complete-in-buffer
- 'function (if class-selector 'method 'routine)
+ 'function (if idlwave--class-selector 'method 'routine)
(idlwave-routines) 'idlwave-selector
(format "Select a %s name%s"
isa
- (if class-selector
+ (if idlwave--class-selector
(format " (class is %s)"
- (if (eq class-selector t)
- "unknown" class-selector))
+ (if (eq idlwave--class-selector t)
+ "unknown" idlwave--class-selector))
""))
isa
'idlwave-attach-method-classes 'idlwave-add-file-link-selector)))
@@ -5948,11 +5839,12 @@ When we force a method or a method keyword, CLASS can specify the class."
;; Complete a procedure keyword
(let* ((where (nth 3 where-list))
(name (car where))
- (method-selector name)
- (type-selector 'pro)
+ (idlwave--method-selector name)
+ (idlwave--type-selector 'pro)
(class (idlwave-determine-class where 'pro))
- (class-selector class)
- (super-classes (idlwave-all-class-inherits class-selector))
+ (idlwave--class-selector class)
+ (idlwave--super-classes (idlwave-all-class-inherits
+ idlwave--class-selector))
(isa (format "procedure%s-keyword" (if class "-method" "")))
(entry (idlwave-best-rinfo-assq
name 'pro class (idlwave-routines)))
@@ -5962,11 +5854,13 @@ When we force a method or a method keyword, CLASS can specify the class."
(error "Nothing known about procedure %s"
(idlwave-make-full-name class name)))
(setq list (idlwave-fix-keywords name 'pro class list
- super-classes system))
+ idlwave--super-classes system))
(unless list (error "No keywords available for procedure %s"
(idlwave-make-full-name class name)))
(setq idlwave-completion-help-info
- (list 'keyword name type-selector class-selector entry super-classes))
+ (list 'keyword name
+ idlwave--type-selector idlwave--class-selector
+ entry idlwave--super-classes))
(idlwave-complete-in-buffer
'keyword 'keyword list nil
(format "Select keyword for procedure %s%s"
@@ -5981,11 +5875,12 @@ When we force a method or a method keyword, CLASS can specify the class."
;; Complete a function keyword
(let* ((where (nth 3 where-list))
(name (car where))
- (method-selector name)
- (type-selector 'fun)
+ (idlwave--method-selector name)
+ (idlwave--type-selector 'fun)
(class (idlwave-determine-class where 'fun))
- (class-selector class)
- (super-classes (idlwave-all-class-inherits class-selector))
+ (idlwave--class-selector class)
+ (idlwave--super-classes (idlwave-all-class-inherits
+ idlwave--class-selector))
(isa (format "function%s-keyword" (if class "-method" "")))
(entry (idlwave-best-rinfo-assq
name 'fun class (idlwave-routines)))
@@ -5996,7 +5891,7 @@ When we force a method or a method keyword, CLASS can specify the class."
(error "Nothing known about function %s"
(idlwave-make-full-name class name)))
(setq list (idlwave-fix-keywords name 'fun class list
- super-classes system))
+ idlwave--super-classes system))
;; OBJ_NEW: Messages mention the proper Init method
(setq msg-name (if (and (null class)
(string= (upcase name) "OBJ_NEW"))
@@ -6006,7 +5901,9 @@ When we force a method or a method keyword, CLASS can specify the class."
(unless list (error "No keywords available for function %s"
msg-name))
(setq idlwave-completion-help-info
- (list 'keyword name type-selector class-selector nil super-classes))
+ (list 'keyword name
+ idlwave--type-selector idlwave--class-selector
+ nil idlwave--super-classes))
(idlwave-complete-in-buffer
'keyword 'keyword list nil
(format "Select keyword for function %s%s" msg-name
@@ -6018,7 +5915,9 @@ When we force a method or a method keyword, CLASS can specify the class."
(t (error "This should not happen (idlwave-complete)")))))
-(defvar idlwave-complete-special nil
+(define-obsolete-variable-alias 'idlwave-complete-special
+ 'idlwave-complete-functions "28.1")
+(defvar idlwave-complete-functions nil
"List of special completion functions.
These functions are called for each completion. Each function must
check if its own special completion context is present. If yes, it
@@ -6028,6 +5927,7 @@ complete other contexts will be done. If the function returns nil,
other completions will be tried.")
(defun idlwave-call-special (functions &rest args)
+ (declare (obsolete run-hook-with-args-until-success "28.1"))
(let ((funcs functions)
fun ret)
(catch 'exit
@@ -6070,9 +5970,9 @@ other completions will be tried.")
(list nil-list nil-list 'procedure nil-list nil))
((eq what 'procedure-keyword)
- (let* ((class-selector nil)
- (super-classes nil)
- (type-selector 'pro)
+ (let* ((idlwave--class-selector nil)
+ (idlwave--super-classes nil)
+ (idlwave--type-selector 'pro)
(pro (or module
(idlwave-completing-read
"Procedure: " (idlwave-routines) 'idlwave-selector))))
@@ -6084,9 +5984,9 @@ other completions will be tried.")
(list nil-list nil-list 'function nil-list nil))
((eq what 'function-keyword)
- (let* ((class-selector nil)
- (super-classes nil)
- (type-selector 'fun)
+ (let* ((idlwave--class-selector nil)
+ (idlwave--super-classes nil)
+ (idlwave--type-selector 'fun)
(func (or module
(idlwave-completing-read
"Function: " (idlwave-routines) 'idlwave-selector))))
@@ -6099,12 +5999,14 @@ other completions will be tried.")
((eq what 'procedure-method-keyword)
(let* ((class (idlwave-determine-class class-list 'pro))
- (class-selector class)
- (super-classes (idlwave-all-class-inherits class-selector))
- (type-selector 'pro)
+ (idlwave--class-selector class)
+ (idlwave--super-classes (idlwave-all-class-inherits
+ idlwave--class-selector))
+ (idlwave--type-selector 'pro)
(pro (or module
(idlwave-completing-read
- (format "Procedure in %s class: " class-selector)
+ (format "Procedure in %s class: "
+ idlwave--class-selector)
(idlwave-routines) 'idlwave-selector))))
(setq pro (idlwave-sintern-method pro))
(list nil-list nil-list 'procedure-keyword
@@ -6115,12 +6017,14 @@ other completions will be tried.")
((eq what 'function-method-keyword)
(let* ((class (idlwave-determine-class class-list 'fun))
- (class-selector class)
- (super-classes (idlwave-all-class-inherits class-selector))
- (type-selector 'fun)
+ (idlwave--class-selector class)
+ (idlwave--super-classes (idlwave-all-class-inherits
+ idlwave--class-selector))
+ (idlwave--type-selector 'fun)
(func (or module
(idlwave-completing-read
- (format "Function in %s class: " class-selector)
+ (format "Function in %s class: "
+ idlwave--class-selector)
(idlwave-routines) 'idlwave-selector))))
(setq func (idlwave-sintern-method func))
(list nil-list nil-list 'function-keyword
@@ -6137,14 +6041,14 @@ other completions will be tried.")
(unwind-protect
(progn
(setq-default completion-ignore-case t)
- (apply 'completing-read args))
+ (apply #'completing-read args))
(setq-default completion-ignore-case old-value))))
(defvar idlwave-shell-default-directory)
(defun idlwave-complete-filename ()
"Use the comint stuff to complete a file name."
(require 'comint)
- (let* ((comint-file-name-chars "~/A-Za-z0-9+@:_.$#%={}\\-")
+ (dlet ((comint-file-name-chars "~/A-Za-z0-9+@:_.$#%={}\\-")
(comint-completion-addsuffix nil)
(default-directory
(if (and (boundp 'idlwave-shell-default-directory)
@@ -6178,7 +6082,7 @@ other completions will be tried.")
(defun idlwave-rinfo-assq-any-class (name type class list)
;; Return the first matching method on the inheritance list
(let* ((classes (cons class (idlwave-all-class-inherits class)))
- class rtn)
+ rtn) ;; class
(while classes
(if (setq rtn (idlwave-rinfo-assq name type (pop classes) list))
(setq classes nil)))
@@ -6195,7 +6099,7 @@ syslib files."
list))
syslibp)
(when (> (length twins) 1)
- (setq twins (sort twins 'idlwave-routine-entry-compare-twins))
+ (setq twins (sort twins #'idlwave-routine-entry-compare-twins))
(if (and (null keep-system)
(eq 'system (car (nth 3 (car twins))))
(setq syslibp (idlwave-any-syslib (cdr twins)))
@@ -6242,7 +6146,7 @@ If yes, return the index (>=1)."
TYPE is `fun' or `pro'.
When TYPE is not specified, both procedures and functions will be considered."
(if (null method)
- (mapcar 'car (idlwave-class-alist))
+ (mapcar #'car (idlwave-class-alist))
(let (rtn)
(mapc (lambda (x)
(and (nth 2 x)
@@ -6296,9 +6200,11 @@ INFO is as returned by `idlwave-what-function' or `-procedure'."
(save-excursion (goto-char apos)
(looking-at "->[a-zA-Z][a-zA-Z0-9$_]*::")))))
-(defvar idlwave-determine-class-special nil
- "List of special functions for determining class.
-Must accept two arguments: `apos' and `info'.")
+(define-obsolete-variable-alias 'idlwave-determine-class-special
+ 'idlwave-determine-class-functions "28.1")
+(defvar idlwave-determine-class-functions nil
+ "Special hook to determine a class.
+The functions should accept one argument, APOS.")
(defun idlwave-determine-class (info type)
;; Determine the class of a routine call.
@@ -6343,10 +6249,10 @@ Must accept two arguments: `apos' and `info'.")
;; Before prompting, try any special class determination routines
(when (and (eq t class)
- idlwave-determine-class-special
(not force-query))
(setq special-class
- (idlwave-call-special idlwave-determine-class-special apos))
+ (run-hook-with-args-until-success
+ 'idlwave-determine-class-functions apos))
(if special-class
(setq class (idlwave-sintern-class special-class)
store idlwave-store-inquired-class)))
@@ -6355,7 +6261,7 @@ Must accept two arguments: `apos' and `info'.")
(when (and (eq class t)
(or force-query query))
(setq class-alist
- (mapcar 'list (idlwave-all-method-classes (car info) type)))
+ (mapcar #'list (idlwave-all-method-classes (car info) type)))
(setq class
(idlwave-sintern-class
(cond
@@ -6389,10 +6295,10 @@ Must accept two arguments: `apos' and `info'.")
(t class))))
(defun idlwave-selector (a)
- (and (eq (nth 1 a) type-selector)
- (or (and (nth 2 a) (eq class-selector t))
- (eq (nth 2 a) class-selector)
- (memq (nth 2 a) super-classes))))
+ (and (eq (nth 1 a) idlwave--type-selector)
+ (or (and (nth 2 a) (eq idlwave--class-selector t))
+ (eq (nth 2 a) idlwave--class-selector)
+ (memq (nth 2 a) idlwave--super-classes))))
(defun idlwave-add-file-link-selector (a)
;; Record a file link, if any, for the tested names during selection.
@@ -6510,7 +6416,7 @@ ARROW: Location of the arrow"
func-point
(cnt 0)
func arrow-start class)
- (idlwave-with-special-syntax
+ (with-syntax-table idlwave-find-symbol-syntax-table
(save-restriction
(save-excursion
(narrow-to-region (max 1 (or bound 0)) (point-max))
@@ -6540,7 +6446,7 @@ ARROW: Location of the arrow"
(goto-char pos))
(throw 'exit nil)))))))
-(defun idlwave-what-procedure (&optional bound)
+(defun idlwave-what-procedure (&optional _bound)
;; Find out if point is within the argument list of a procedure.
;; The return value is ("procedure-name" class arrow-pos (point)).
@@ -6630,13 +6536,12 @@ This function is not general, can only be used for completion stuff."
(throw 'exit nil)))
(t (throw 'exit (preceding-char))))))))
-(defvar idlwave-complete-after-success-form nil
- "A form to evaluate after successful completion.")
-(defvar idlwave-complete-after-success-form-force nil
- "A form to evaluate after completion selection in *Completions* buffer.")
+(defvar idlwave--complete-after-success-function #'ignore
+ "A function to evaluate after successful completion.")
+(defvar idlwave--complete-after-success-force-function #'ignore
+ "A function to evaluate after completion selection in *Completions* buffer.")
(defconst idlwave-completion-mark (make-marker)
"A mark pointing to the beginning of the completion string.")
-(defvar completion-highlight-first-word-only) ;XEmacs.
(defun idlwave-complete-in-buffer (type stype list selector prompt isa
&optional prepare-display-function
@@ -6659,12 +6564,12 @@ accumulate information on matching completions."
(skip-chars-backward "a-zA-Z0-9_$")
(setq slash (eq (preceding-char) ?/)
beg (point)
- idlwave-complete-after-success-form
- (list 'idlwave-after-successful-completion
- (list 'quote type) slash beg)
- idlwave-complete-after-success-form-force
- (list 'idlwave-after-successful-completion
- (list 'quote type) slash (list 'quote 'force))))
+ idlwave--complete-after-success-function
+ (lambda () (idlwave-after-successful-completion
+ type slash beg))
+ idlwave--complete-after-success-force-function
+ (lambda () (idlwave-after-successful-completion
+ type slash 'force))))
;; Try a completion
(setq part (buffer-substring beg end)
@@ -6715,12 +6620,7 @@ accumulate information on matching completions."
list))
(let* ((list all-completions)
;; "complete" means, this is already a valid completion
- (complete (memq spart all-completions))
- (completion-highlight-first-word-only t)) ; XEmacs
- ;; (completion-fixup-function ; Emacs
- ;; (lambda () (and (eq (preceding-char) ?>)
- ;; (re-search-backward " <" beg t)))))
-
+ (complete (memq spart all-completions)))
(setq list (sort list (lambda (a b)
(string< (downcase a) (downcase b)))))
(if prepare-display-function
@@ -6773,21 +6673,20 @@ accumulate information on matching completions."
;; 'class-tag, for class tags, and otherwise for methods.
;; SHOW-CLASSES is the value of `idlwave-completion-show-classes'.
(if (or (null show-classes) ; don't want to see classes
- (null class-selector) ; not a method call
+ (null idlwave--class-selector) ; not a method call
(and
- (stringp class-selector) ; the class is already known
- (not super-classes))) ; no possibilities for inheritance
+ (stringp idlwave--class-selector) ; the class is already known
+ (not idlwave--super-classes))) ; no possibilities for inheritance
;; In these cases, we do not have to do anything
list
- (let* ((do-prop (and (>= show-classes 0)
- (>= emacs-major-version 21)))
+ (let* ((do-prop (>= show-classes 0))
(do-buf (not (= show-classes 0)))
- ;; (do-dots (featurep 'xemacs))
- (do-dots t)
- (inherit (if (and (not (eq type 'class-tag)) super-classes)
- (cons class-selector super-classes)))
+ ;; (do-dots t)
+ (inherit (if (and (not (eq type 'class-tag)) idlwave--super-classes)
+ (cons idlwave--class-selector idlwave--super-classes)))
(max (abs show-classes))
- (lmax (if do-dots (apply 'max (mapcar 'length list))))
+ (lmax ;; (if do-dots
+ (apply #'max (mapcar #'length list))) ;;)
classes nclasses class-info space)
(mapcar
(lambda (x)
@@ -6796,13 +6695,14 @@ accumulate information on matching completions."
;; Just one class for tags
(setq classes
(list
- (idlwave-class-or-superclass-with-tag class-selector x)))
+ (idlwave-class-or-superclass-with-tag
+ idlwave--class-selector x)))
;; Multiple classes for method or method-keyword
(setq classes
(if (eq type 'kwd)
(idlwave-all-method-keyword-classes
- method-selector x type-selector)
- (idlwave-all-method-classes x type-selector)))
+ idlwave--method-selector x idlwave--type-selector)
+ (idlwave-all-method-classes x idlwave--type-selector)))
(if inherit
(setq classes
(delq nil
@@ -6810,22 +6710,22 @@ accumulate information on matching completions."
classes)))))
(setq nclasses (length classes))
;; Make the separator between item and class-info
- (if do-dots
- (setq space (concat " " (make-string (- lmax (length x)) ?.)))
- (setq space " "))
+ ;; (if do-dots
+ (setq space (concat " " (make-string (- lmax (length x)) ?.)))
+ ;; (setq space " "))
(if do-buf
;; We do want info in the buffer
(if (<= nclasses max)
(setq class-info (concat
space
- "<" (mapconcat 'identity classes ",") ">"))
+ "<" (mapconcat #'identity classes ",") ">"))
(setq class-info (format "%s<%d classes>" space nclasses)))
(setq class-info nil))
(when do-prop
;; We do want properties
(setq x (copy-sequence x))
(put-text-property 0 (length x)
- 'help-echo (mapconcat 'identity classes " ")
+ 'help-echo (mapconcat #'identity classes " ")
x))
(if class-info
(list x class-info)
@@ -6848,10 +6748,6 @@ accumulate information on matching completions."
;;----------------------------------------------------------------------
;;----------------------------------------------------------------------
;;----------------------------------------------------------------------
-(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.
@@ -6862,17 +6758,6 @@ sort the list before displaying."
(cond ((null list))
((= 1 (length list))
(setq rtn (car list)))
- ((featurep 'xemacs)
- (if sort (setq list (sort list (lambda (a b)
- (string< (upcase a) (upcase b))))))
- (setq menu
- (append (list title)
- (mapcar (lambda (x) (vector x (list 'idlwave-pset
- x)))
- list)))
- (setq menu (idlwave-split-menu-xemacs menu maxpopup))
- (let ((resp (get-popup-menu-response menu)))
- (funcall (event-function resp) (event-object resp))))
(t
(if sort (setq list (sort list (lambda (a b)
(string< (upcase a) (upcase b))))))
@@ -6880,36 +6765,14 @@ sort the list before displaying."
(list
(append (list "")
(mapcar (lambda(x) (cons x x)) list)))))
- (setq menu (idlwave-split-menu-emacs menu maxpopup))
+ (setq menu (idlwave-split-menu menu maxpopup))
(setq rtn (x-popup-menu ev menu))))
rtn))
-(defun idlwave-split-menu-xemacs (menu N)
- "Split the MENU into submenus of maximum length N."
- (if (<= (length menu) (1+ N))
- ;; No splitting needed
- menu
- (let* ((title (car menu))
- (entries (cdr menu))
- (menu (list title))
- (cnt 0)
- (nextmenu nil))
- (while entries
- (while (and entries (< cnt N))
- (setq cnt (1+ cnt)
- nextmenu (cons (car entries) nextmenu)
- entries (cdr entries)))
- (setq nextmenu (nreverse nextmenu))
- (setq nextmenu (cons (format "%s...%s"
- (aref (car nextmenu) 0)
- (aref (nth (1- cnt) nextmenu) 0))
- nextmenu))
- (setq menu (cons nextmenu menu)
- nextmenu nil
- cnt 0))
- (nreverse menu))))
+(define-obsolete-function-alias 'idlwave-split-menu-emacs
+ #'idlwave-split-menu "28.1")
-(defun idlwave-split-menu-emacs (menu N)
+(defun idlwave-split-menu (menu N)
"Split the MENU into submenus of maximum length N."
(if (<= (length (nth 1 menu)) (1+ N))
;; No splitting needed
@@ -6952,7 +6815,7 @@ sort the list before displaying."
(nth 2 last-command))
(progn
(select-window win)
- (eval idlwave-complete-after-success-form))
+ (funcall idlwave--complete-after-success-function))
(set-window-start cwin (point-min)))))
(and message (message "%s" message)))
(select-window win))))
@@ -6964,10 +6827,7 @@ sort the list before displaying."
(move-marker idlwave-completion-mark beg)
(setq idlwave-before-completion-wconf (current-window-configuration)))
- (if (featurep 'xemacs)
- (idlwave-display-completion-list-xemacs
- list)
- (idlwave-display-completion-list-emacs list))
+ (idlwave-display-completion-list-1 list)
;; Store a special value in `this-command'. When `idlwave-complete'
;; finds this in `last-command', it will scroll the *Completions* buffer.
@@ -6992,14 +6852,13 @@ sort the list before displaying."
(let ((completion-ignore-case t)) ; install correct value
(apply function args))
(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
(let ((beg (save-excursion
(skip-chars-backward "a-zA-Z0-9_")
(point))))
(remove-text-properties beg (point) '(face nil))))
- (eval idlwave-complete-after-success-form-force))
+ (funcall idlwave--complete-after-success-force-function))
(defun idlwave-keyboard-quit ()
(interactive)
@@ -7025,8 +6884,7 @@ The key which is associated with each option is generated automatically.
First, the strings are checked for preselected keys, like in \"[P]rint\".
If these don't exist, a letter in the string is automatically selected."
(let* ((alist (symbol-value sym))
- (temp-buffer-show-hook (if (fboundp 'fit-window-to-buffer)
- '(fit-window-to-buffer)))
+ (temp-buffer-show-hook '(fit-window-to-buffer))
keys-alist char)
;; First check the cache
(if (and (eq (symbol-value sym) (get sym :one-key-alist-last)))
@@ -7108,46 +6966,20 @@ If these don't exist, a letter in the string is automatically selected."
(defun idlwave-local-value (var &optional buffer)
"Return the value of VAR in BUFFER, but only if VAR is local to BUFFER."
- (with-current-buffer (or buffer (current-buffer))
- (and (local-variable-p var (current-buffer))
- (symbol-value var))))
-
-;; In XEmacs, we can use :activate-callback directly to advice the
-;; choose functions. We use the private keymap only for the online
-;; help feature.
+ (when (local-variable-p var buffer)
+ (buffer-local-value var (or buffer (current-buffer)))))
(defvar idlwave-completion-map nil
"Keymap for `completion-list-mode' with `idlwave-complete'.")
-(defun idlwave-display-completion-list-xemacs (list &rest cl-args)
- (with-output-to-temp-buffer "*Completions*"
- (apply 'display-completion-list list
- ':activate-callback 'idlwave-default-choose-completion
- cl-args))
- (with-current-buffer "*Completions*"
- (use-local-map
- (or idlwave-completion-map
- (setq idlwave-completion-map
- (idlwave-make-modified-completion-map-xemacs
- (current-local-map)))))))
-
-(defun idlwave-default-choose-completion (&rest args)
- "Execute `default-choose-completion' and then restore the win-conf."
- (apply 'idlwave-choose 'default-choose-completion args))
+;; (defun idlwave-default-choose-completion (&rest args)
+;; "Execute `default-choose-completion' and then restore the win-conf."
+;; (apply #'idlwave-choose #'default-choose-completion args))
-(defun idlwave-make-modified-completion-map-xemacs (old-map)
- "Replace `choose-completion' and `mouse-choose-completion' in OLD-MAP."
- (let ((new-map (copy-keymap old-map)))
- (define-key new-map [button3up] 'idlwave-mouse-completion-help)
- (define-key new-map [button3] (lambda ()
- (interactive)
- (setq this-command last-command)))
- new-map))
+(define-obsolete-function-alias 'idlwave-display-completion-list-emacs
+ #'idlwave-display-completion-list-1 "28.1")
-;; In Emacs we also replace keybindings in the completion
-;; map in order to install our wrappers.
-
-(defun idlwave-display-completion-list-emacs (list)
+(defun idlwave-display-completion-list-1 (list)
"Display completion list and install the choose wrappers."
(with-output-to-temp-buffer "*Completions*"
(display-completion-list list))
@@ -7155,28 +6987,26 @@ If these don't exist, a letter in the string is automatically selected."
(use-local-map
(or idlwave-completion-map
(setq idlwave-completion-map
- (idlwave-make-modified-completion-map-emacs
- (current-local-map)))))))
+ (idlwave-make-modified-completion-map (current-local-map)))))))
+
+(define-obsolete-function-alias 'idlwave-make-modified-completion-map-emacs
+ #'idlwave-make-modified-completion-map "28.1")
-(defun idlwave-make-modified-completion-map-emacs (old-map)
- "Replace `choose-completion' and `mouse-choose-completion' in OLD-MAP."
+(defun idlwave-make-modified-completion-map (old-map)
+ "Replace `choose-completion' in OLD-MAP."
(let ((new-map (copy-keymap old-map)))
(substitute-key-definition
- 'choose-completion 'idlwave-choose-completion new-map)
- (substitute-key-definition
- 'mouse-choose-completion 'idlwave-mouse-choose-completion new-map)
- (define-key new-map [mouse-3] 'idlwave-mouse-completion-help)
+ #'choose-completion #'idlwave-choose-completion new-map)
+ (define-key new-map [mouse-3] #'idlwave-mouse-completion-help)
new-map))
(defun idlwave-choose-completion (&rest args)
"Choose the completion that point is in or next to."
(interactive (list last-nonmenu-event))
- (apply 'idlwave-choose 'choose-completion args))
+ (apply #'idlwave-choose #'choose-completion args))
-(defun idlwave-mouse-choose-completion (&rest args)
- "Click on an alternative in the `*Completions*' buffer to choose it."
- (interactive "e")
- (apply 'idlwave-choose 'mouse-choose-completion args))
+(define-obsolete-function-alias 'idlwave-mouse-choose-completion
+ #'idlwave-choose-completion "28.1")
;;----------------------------------------------------------------------
;;----------------------------------------------------------------------
@@ -7370,7 +7200,7 @@ class/struct definition."
(file (idlwave-routine-source-file
(nth 3 (idlwave-rinfo-assoc pro 'pro nil
(idlwave-routines))))))
- (cons file (if file (idlwave-get-buffer-visiting file)))))
+ (cons file (if file (find-buffer-visiting file)))))
(defun idlwave-scan-class-info (class)
@@ -7423,8 +7253,8 @@ class/struct definition."
(defun idlwave-all-class-tags (class)
"Return a list of native and inherited tags in CLASS."
(condition-case err
- (apply 'append (mapcar 'idlwave-class-tags
- (cons class (idlwave-all-class-inherits class))))
+ (apply #'append (mapcar #'idlwave-class-tags
+ (cons class (idlwave-all-class-inherits class))))
(error
(idlwave-class-tag-reset)
(error "%s" (error-message-string err)))))
@@ -7514,10 +7344,9 @@ property indicating the link is added."
(defvar idlwave-current-class-tags nil)
(defvar idlwave-current-native-class-tags nil)
(defvar idlwave-sint-class-tags nil)
-(declare-function idlwave-sintern-class-tag "idlwave" t t)
-(idlwave-new-sintern-type 'class-tag)
-(add-to-list 'idlwave-complete-special 'idlwave-complete-class-structure-tag)
-(add-hook 'idlwave-update-rinfo-hook 'idlwave-class-tag-reset)
+(idlwave-new-sintern-type class-tag)
+(add-hook 'idlwave-complete-functions #'idlwave-complete-class-structure-tag)
+(add-hook 'idlwave-update-rinfo-hook #'idlwave-class-tag-reset)
(defun idlwave-complete-class-structure-tag ()
"Complete a structure tag on a `self' argument in an object method."
@@ -7529,25 +7358,26 @@ property indicating the link is added."
(skip-chars-backward "a-zA-Z0-9._$")
(and (< (point) (- pos 4))
(looking-at "self\\.")))
- (let* ((class-selector (nth 2 (idlwave-current-routine)))
- (super-classes (idlwave-all-class-inherits class-selector)))
+ (let* ((idlwave--class-selector (nth 2 (idlwave-current-routine)))
+ (idlwave--super-classes (idlwave-all-class-inherits
+ idlwave--class-selector)))
;; Check if we are in a class routine
- (unless class-selector
+ (unless idlwave--class-selector
(error "Not in a method procedure or function"))
;; Check if we need to update the "current" class
- (if (not (equal class-selector idlwave-current-tags-class))
- (idlwave-prepare-class-tag-completion class-selector))
+ (if (not (equal idlwave--class-selector idlwave-current-tags-class))
+ (idlwave-prepare-class-tag-completion idlwave--class-selector))
(setq idlwave-completion-help-info
(list 'idlwave-complete-class-structure-tag-help
(idlwave-sintern-routine
- (concat class-selector "__define"))
+ (concat idlwave--class-selector "__define"))
nil))
;; FIXME: idlwave-cpl-bold doesn't seem used anywhere.
- (let ((idlwave-cpl-bold idlwave-current-native-class-tags))
+ (let ((_idlwave-cpl-bold idlwave-current-native-class-tags))
(idlwave-complete-in-buffer
'class-tag 'class-tag
idlwave-current-class-tags nil
- (format "Select a tag of class %s" class-selector)
+ (format "Select a tag of class %s" idlwave--class-selector)
"class tag"
'idlwave-attach-class-tag-classes))
t) ; return t to skip other completions
@@ -7565,7 +7395,7 @@ property indicating the link is added."
(list (idlwave-sintern-class-tag x 'set)))
(idlwave-all-class-tags class)))
(setq idlwave-current-native-class-tags
- (mapcar 'downcase (idlwave-class-tags class))))
+ (mapcar #'downcase (idlwave-class-tags class))))
;===========================================================================
;;
@@ -7574,13 +7404,11 @@ property indicating the link is added."
(defvar idlwave-sint-sysvars nil)
(defvar idlwave-sint-sysvartags nil)
-(declare-function idlwave-sintern-sysvar "idlwave" t t)
-(declare-function idlwave-sintern-sysvartag "idlwave" t t)
-(idlwave-new-sintern-type 'sysvar)
-(idlwave-new-sintern-type 'sysvartag)
-(add-to-list 'idlwave-complete-special 'idlwave-complete-sysvar-or-tag)
-(add-hook 'idlwave-update-rinfo-hook 'idlwave-sysvars-reset)
-(add-hook 'idlwave-after-load-rinfo-hook 'idlwave-sintern-sysvar-alist)
+(idlwave-new-sintern-type sysvar)
+(idlwave-new-sintern-type sysvartag)
+(add-hook 'idlwave-complete-functions #'idlwave-complete-sysvar-or-tag)
+(add-hook 'idlwave-update-rinfo-hook #'idlwave-sysvars-reset)
+(add-hook 'idlwave-after-load-rinfo-hook #'idlwave-sintern-sysvar-alist)
(defun idlwave-complete-sysvar-or-tag ()
@@ -7736,7 +7564,7 @@ associated TAG, if any."
(let ((text idlwave-shell-command-output)
(start 0)
(old idlwave-system-variables-alist)
- var tags type name class link old-entry)
+ var tags link old-entry) ;; type name class
(setq idlwave-system-variables-alist nil)
(while (string-match "^IDLWAVE-SYSVAR: !\\([a-zA-Z0-9_$]+\\)\\( \\(.*\\)\\)?"
text start)
@@ -7756,7 +7584,8 @@ associated TAG, if any."
(cdr (assq
(idlwave-sintern-sysvartag x)
(cdr (assq 'tags old-entry))))))
- tags)) link)
+ tags))
+ link)
idlwave-system-variables-alist)))
;; Keep the old value if query was not successful
(setq idlwave-system-variables-alist
@@ -7764,23 +7593,13 @@ associated TAG, if any."
(defun idlwave-completion-fontify-classes ()
"Goto the *Completions* buffer and fontify the class info."
- (when (featurep 'font-lock)
- (with-current-buffer "*Completions*"
- (save-excursion
- (goto-char (point-min))
- (let ((buffer-read-only nil))
- (while (re-search-forward "\\.*<[^>]+>" nil t)
- (put-text-property (match-beginning 0) (match-end 0)
- 'face 'font-lock-string-face)))))))
-
-(defun idlwave-uniquify (list)
- (let ((ht (make-hash-table :size (length list) :test 'equal)))
- (delq nil
- (mapcar (lambda (x)
- (unless (gethash x ht)
- (puthash x t ht)
- x))
- list))))
+ (with-current-buffer "*Completions*"
+ (save-excursion
+ (goto-char (point-min))
+ (let ((buffer-read-only nil))
+ (while (re-search-forward "\\.*<[^>]+>" nil t)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face 'font-lock-string-face))))))
(defun idlwave-after-successful-completion (type slash &optional verify)
"Add `=' or `(' after successful completion of keyword and function.
@@ -7846,7 +7665,7 @@ itself."
(setq this-command last-command)
(idlwave-do-mouse-completion-help ev))
-(defun idlwave-routine-info (&optional arg external)
+(defun idlwave-routine-info (&optional arg _external)
"Display a routines calling sequence and list of keywords.
When point is on the name a function or procedure, or in the argument
list of a function or procedure, this command displays a help buffer with
@@ -7883,7 +7702,7 @@ arg, the class property is cleared out."
(idlwave-force-class-query (equal arg '(4)))
(module (idlwave-what-module)))
(if (car module)
- (apply 'idlwave-display-calling-sequence
+ (apply #'idlwave-display-calling-sequence
(idlwave-fix-module-if-obj_new module))
(error "Don't know which calling sequence to show")))))
@@ -7966,7 +7785,7 @@ force class query for object methods."
(name (idlwave-completing-read
(if (or (not this-buffer)
(assoc default list))
- (format "Module (Default %s): " default)
+ (format-prompt "Module" default)
(format "Module in this file: "))
list))
type class)
@@ -8100,7 +7919,7 @@ Used by `idlwave-routine-info' and `idlwave-find-module'."
(stringp class))
(list (car module)
(nth 1 module)
- (apply 'idlwave-find-inherited-class module))
+ (apply #'idlwave-find-inherited-class module))
module)))
(defun idlwave-find-inherited-class (name type class)
@@ -8125,7 +7944,7 @@ appropriate Init method."
(setq string (buffer-substring (point) pos))
(string-match "obj_new([^'\"]*['\"]\\([a-zA-Z0-9_]+\\)"
string)))
- (let ((name "Init")
+ (let (;; (name "Init")
(class (match-string 1 string)))
(setq module (list (idlwave-sintern-method "Init")
'fun
@@ -8138,7 +7957,8 @@ appropriate Init method."
Translate OBJ_NEW, adding all super-class keywords, or all keywords
from all classes if CLASS equals t. If SYSTEM is non-nil, don't
demand _EXTRA in the keyword list."
- (let ((case-fold-search t))
+ (let ((case-fold-search t)
+ (idlwave--super-classes super-classes))
;; If this is the OBJ_NEW function, try to figure out the class and use
;; the keywords from the corresponding INIT method.
@@ -8159,7 +7979,8 @@ demand _EXTRA in the keyword list."
(idlwave-sintern-method "INIT")
'fun
class
- (idlwave-routines)) 'do-link))))))
+ (idlwave-routines))
+ 'do-link))))))
;; If the class is t, combine all keywords of all methods NAME
(when (eq class t)
@@ -8176,7 +7997,7 @@ demand _EXTRA in the keyword list."
;; If we have inheritance, add all keywords from superclasses, if
;; the user indicated that method in `idlwave-keyword-class-inheritance'
(when (and
- super-classes
+ idlwave--super-classes
idlwave-keyword-class-inheritance
(stringp class)
(or
@@ -8191,7 +8012,7 @@ demand _EXTRA in the keyword list."
(cl-loop for entry in (idlwave-routines) do
(and (nth 2 entry) ; non-nil class
- (memq (nth 2 entry) super-classes) ; an inherited class
+ (memq (nth 2 entry) idlwave--super-classes) ;an inherited class
(eq (nth 1 entry) type) ; correct type
(eq (car entry) name) ; correct name
(mapc (lambda (k) (add-to-list 'keywords k))
@@ -8241,22 +8062,16 @@ If we do not know about MODULE, just return KEYWORD literally."
(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)
+ (define-key map [mouse-2] #'idlwave-mouse-active-rinfo)
+ (define-key map [(shift mouse-2)] #'idlwave-mouse-active-rinfo-shift)
+ (define-key map [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)
+ (define-key map "q" #'idlwave-quit-help)
map))
(defvar idlwave-popup-source nil)
@@ -8301,10 +8116,9 @@ If we do not know about MODULE, just return KEYWORD literally."
"Button2: Display info about same method in superclass")
(col 0)
(data (list name type class (current-buffer) nil initial-class))
- (km-prop (if (featurep 'xemacs) 'keymap 'local-map))
(face 'idlwave-help-link)
beg props win cnt total)
- ;; Fix keywords, but don't add chained super-classes, since these
+ ;; Fix keywords, but don't add chained idlwave--super-classes, since these
;; are shown separately for that super-class
(setq keywords (idlwave-fix-keywords name type class keywords))
(cond
@@ -8326,7 +8140,7 @@ If we do not know about MODULE, just return KEYWORD literally."
idlwave-current-obj_new-class)
(when superclasses
(setq props (list 'mouse-face 'highlight
- km-prop idlwave-rinfo-mouse-map
+ 'local-map idlwave-rinfo-mouse-map
'help-echo help-echo-class
'data (cons 'class data)))
(let ((classes (cons initial-class superclasses)) c)
@@ -8342,7 +8156,7 @@ If we do not know about MODULE, just return KEYWORD literally."
(add-text-properties beg (point) props))))
(insert "\n")))
(setq props (list 'mouse-face 'highlight
- km-prop idlwave-rinfo-mouse-map
+ 'local-map idlwave-rinfo-mouse-map
'help-echo help-echo-use
'data (cons 'usage data)))
(if html-file (setq props (append (list 'face face 'link html-file)
@@ -8370,7 +8184,7 @@ If we do not know about MODULE, just return KEYWORD literally."
(setq beg (point)
;; Relevant keywords already have link property attached
props (list 'mouse-face 'highlight
- km-prop idlwave-rinfo-mouse-map
+ 'local-map idlwave-rinfo-mouse-map
'data (cons 'keyword data)
'help-echo help-echo-kwd
'keyword (car x)))
@@ -8384,7 +8198,7 @@ If we do not know about MODULE, just return KEYWORD literally."
;; Here entry is (key file (list of type-conses))
(while (setq entry (pop all))
(setq props (list 'mouse-face 'highlight
- km-prop idlwave-rinfo-mouse-map
+ 'local-map idlwave-rinfo-mouse-map
'help-echo help-echo-src
'source (list (car (car (nth 2 entry))) ;type
(nth 1 entry)
@@ -8489,8 +8303,7 @@ to it."
(add-text-properties beg (point) (list 'face 'bold)))
(when (and file (not (equal file "")))
(setq beg (point))
- (insert (apply 'abbreviate-file-name
- (if (featurep 'xemacs) (list file t) (list file))))
+ (insert (apply #'abbreviate-file-name (list file)))
(if file-props
(add-text-properties beg (point) file-props)))))
@@ -8595,9 +8408,9 @@ was pressed."
idlwave-keyword-completion-adds-equal)
(insert "=")))))
-(defun idlwave-list-buffer-load-path-shadows (&optional arg)
+(defun idlwave-list-buffer-load-path-shadows (&optional _arg)
"List the load path shadows of all routines defined in current buffer."
- (interactive "P")
+ (interactive)
(idlwave-routines)
(if (derived-mode-p 'idlwave-mode)
(idlwave-list-load-path-shadows
@@ -8605,13 +8418,13 @@ was pressed."
"in current buffer")
(error "Current buffer is not in idlwave-mode")))
-(defun idlwave-list-shell-load-path-shadows (&optional arg)
+(defun idlwave-list-shell-load-path-shadows (&optional _arg)
"List the load path shadows of all routines compiled under the shell.
This is very useful for checking an IDL application. Just compile the
application, do RESOLVE_ALL, and `C-c C-i' to compile all referenced
routines and update IDLWAVE internal info. Then check for shadowing
with this command."
- (interactive "P")
+ (interactive)
(cond
((or (not (fboundp 'idlwave-shell-is-running))
(not (idlwave-shell-is-running)))
@@ -8622,15 +8435,15 @@ with this command."
(idlwave-list-load-path-shadows nil idlwave-compiled-routines
"in the shell"))))
-(defun idlwave-list-all-load-path-shadows (&optional arg)
+(defun idlwave-list-all-load-path-shadows (&optional _arg)
"List the load path shadows of all routines known to IDLWAVE."
- (interactive "P")
+ (interactive)
(idlwave-list-load-path-shadows nil nil "globally"))
(defvar idlwave-sort-prefer-buffer-info t
"Internal variable used to influence `idlwave-routine-twin-compare'.")
-(defun idlwave-list-load-path-shadows (arg &optional special-routines loc)
+(defun idlwave-list-load-path-shadows (_arg &optional special-routines loc)
"List the routines which are defined multiple times.
Search the information IDLWAVE has about IDL routines for multiple
definitions.
@@ -8650,10 +8463,9 @@ can be used to detect possible name clashes during this process."
idlwave-user-catalog-routines
idlwave-buffer-routines
nil))
- (km-prop (if (featurep 'xemacs) 'keymap 'local-map))
(keymap (make-sparse-keymap))
(props (list 'mouse-face 'highlight
- km-prop keymap
+ 'local-map keymap
'help-echo "Mouse2: Find source"))
(nroutines (length (or special-routines routines)))
(step (/ nroutines 100))
@@ -8676,16 +8488,16 @@ can be used to detect possible name clashes during this process."
(nth 2 b) (car b)))))))
(message "Sorting routines...done")
- (define-key keymap (if (featurep 'xemacs) [(button2)] [(mouse-2)])
+ (define-key keymap [(mouse-2)]
(lambda (ev)
(interactive "e")
(mouse-set-point ev)
- (apply 'idlwave-do-find-module
+ (apply #'idlwave-do-find-module
(get-text-property (point) 'find-args))))
(define-key keymap [(return)]
(lambda ()
(interactive)
- (apply 'idlwave-do-find-module
+ (apply #'idlwave-do-find-module
(get-text-property (point) 'find-args))))
(message "Compiling list...( 0%%)")
(with-current-buffer (get-buffer-create "*Shadows*")
@@ -8761,6 +8573,10 @@ ENTRY will also be returned, as the first item of this list."
(push candidate twins))
(cons entry (nreverse twins))))
+;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins.
+(defvar idlwave-twin-class)
+(defvar idlwave-twin-name)
+
(defun idlwave-study-twins (entries)
"Return dangerous twins of first entry in ENTRIES.
Dangerous twins are routines with same name, but in different files on
@@ -8773,7 +8589,7 @@ routines, and may have been scanned."
(type (nth 1 entry)) ; Must be bound for
(idlwave-twin-class (nth 2 entry)) ; idlwave-routine-twin-compare
(cnt 0)
- source type type-cons file alist syslibp key)
+ source type-cons file alist syslibp key)
(while (setq entry (pop entries))
(cl-incf cnt)
(setq source (nth 3 entry)
@@ -8809,12 +8625,12 @@ routines, and may have been scanned."
(when (and (idlwave-syslib-scanned-p)
(setq entry (assoc 'system alist)))
(setcar entry 'builtin))
- (sort alist 'idlwave-routine-twin-compare)))
+ (sort alist #'idlwave-routine-twin-compare)))
;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix.
;; (defvar type)
-(define-obsolete-function-alias 'idlwave-xor 'xor "27.1")
+(define-obsolete-function-alias 'idlwave-xor #'xor "27.1")
(defun idlwave-routine-entry-compare (a b)
"Compare two routine info entries for sorting.
@@ -8845,7 +8661,7 @@ names and path locations."
"Compare two routine entries, under the assumption that they are twins.
This basically calls `idlwave-routine-twin-compare' with the correct args."
(let* ((idlwave-twin-name (car a))
- (type (nth 1 a))
+ ;; (type (nth 1 a))
(idlwave-twin-class (nth 2 a)) ; used in idlwave-routine-twin-compare
(asrc (nth 3 a))
(atype (car asrc))
@@ -8861,10 +8677,6 @@ This basically calls `idlwave-routine-twin-compare' with the correct args."
(list (file-truename bfile) bfile (list btype))
(list btype bfile (list btype))))))
-;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins.
-(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
@@ -8964,9 +8776,7 @@ This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values."
(defun idlwave-path-alist-add-flag (list-entry flag)
"Add a flag to the path list entry, if not set."
- (let ((flags (cdr list-entry)))
- (add-to-list 'flags flag)
- (setcdr list-entry flags)))
+ (cl-pushnew flag (cdr list-entry) :test #'equal))
(defun idlwave-path-alist-remove-flag (list-entry flag)
"Remove a flag to the path list entry, if set."
@@ -9023,9 +8833,7 @@ Assumes that point is at the beginning of the unit as found by
(let ((begin (point)))
(re-search-forward
"[a-zA-Z_][a-zA-Z0-9$_]+\\(::[a-zA-Z_][a-zA-Z0-9$_]+\\)?")
- (if (fboundp 'buffer-substring-no-properties)
- (buffer-substring-no-properties begin (point))
- (buffer-substring begin (point)))))
+ (buffer-substring-no-properties begin (point))))
(defalias 'idlwave-function-menu
(condition-case nil
@@ -9038,23 +8846,6 @@ Assumes that point is at the beginning of the unit as found by
'imenu)
(error nil)))))
-;; Here we hack func-menu.el in order to support this new mode.
-;; The latest versions of func-menu.el already have this stuff in, so
-;; we hack only if it is not already there.
-(when (featurep 'xemacs)
- (eval-after-load "func-menu"
- '(progn
- (or (assq 'idlwave-mode fume-function-name-regexp-alist)
- (not (boundp 'fume-function-name-regexp-idl)) ; avoid problems
- (setq fume-function-name-regexp-alist
- (cons '(idlwave-mode . fume-function-name-regexp-idl)
- fume-function-name-regexp-alist)))
- (or (assq 'idlwave-mode fume-find-function-name-method-alist)
- (not (fboundp 'fume-find-next-idl-function-name)) ; avoid problems
- (setq fume-find-function-name-method-alist
- (cons '(idlwave-mode . fume-find-next-idl-function-name)
- fume-find-function-name-method-alist))))))
-
(defun idlwave-edit-in-idlde ()
"Edit the current file in IDL Development environment."
(interactive)
@@ -9094,8 +8885,8 @@ Assumes that point is at the beginning of the unit as found by
["(Un)Comment Region" idlwave-toggle-comment-region t]
["Continue/Split line" idlwave-split-line t]
"--"
- ["Toggle Auto Fill" idlwave-auto-fill-mode :style toggle
- :selected (symbol-value idlwave-fill-function)])
+ ["Toggle Auto Fill" auto-fill-mode :style toggle
+ :selected auto-fill-function])
("Templates"
["Procedure" idlwave-procedure t]
["Function" idlwave-function t]
@@ -9158,8 +8949,7 @@ Assumes that point is at the beginning of the unit as found by
("Customize"
["Browse IDLWAVE Group" idlwave-customize t]
"--"
- ["Build Full Customize Menu" idlwave-create-customize-menu
- (fboundp 'customize-menu-create)])
+ ["Build Full Customize Menu" idlwave-create-customize-menu t])
("Documentation"
["Describe Mode" describe-mode t]
["Abbreviation List" idlwave-list-abbrevs t]
@@ -9180,14 +8970,12 @@ Assumes that point is at the beginning of the unit as found by
(and (boundp 'idlwave-shell-automatic-start)
idlwave-shell-automatic-start)]))
-(if (or (featurep 'easymenu) (load "easymenu" t))
- (progn
- (easy-menu-define idlwave-mode-menu idlwave-mode-map
- "IDL and WAVE CL editing menu"
- idlwave-mode-menu-def)
- (easy-menu-define idlwave-mode-debug-menu idlwave-mode-map
- "IDL and WAVE CL editing menu"
- idlwave-mode-debug-menu-def)))
+(easy-menu-define idlwave-mode-menu idlwave-mode-map
+ "IDL and WAVE CL editing menu"
+ idlwave-mode-menu-def)
+(easy-menu-define idlwave-mode-debug-menu idlwave-mode-map
+ "IDL and WAVE CL editing menu"
+ idlwave-mode-debug-menu-def)
(defun idlwave-customize ()
"Call the customize function with `idlwave' as argument."
@@ -9201,24 +8989,21 @@ Assumes that point is at the beginning of the unit as found by
(defun idlwave-create-customize-menu ()
"Create a full customization menu for IDLWAVE, insert it into the menu."
(interactive)
- (if (fboundp 'customize-menu-create)
- (progn
- ;; Try to load the code for the shell, so that we can customize it
- ;; as well.
- (or (featurep 'idlw-shell)
- (load "idlw-shell" t))
- (easy-menu-change
- '("IDLWAVE") "Customize"
- `(["Browse IDLWAVE group" idlwave-customize t]
- "--"
- ,(customize-menu-create 'idlwave)
- ["Set" Custom-set t]
- ["Save" Custom-save t]
- ["Reset to Current" Custom-reset-current t]
- ["Reset to Saved" Custom-reset-saved t]
- ["Reset to Standard Settings" Custom-reset-standard t]))
- (message "\"IDLWAVE\"-menu now contains full customization menu"))
- (error "Cannot expand menu (outdated version of cus-edit.el)")))
+ ;; Try to load the code for the shell, so that we can customize it
+ ;; as well.
+ (or (featurep 'idlw-shell)
+ (load "idlw-shell" t))
+ (easy-menu-change
+ '("IDLWAVE") "Customize"
+ `(["Browse IDLWAVE group" idlwave-customize t]
+ "--"
+ ,(customize-menu-create 'idlwave)
+ ["Set" Custom-set t]
+ ["Save" Custom-save t]
+ ["Reset to Current" Custom-reset-current t]
+ ["Reset to Saved" Custom-reset-saved t]
+ ["Reset to Standard Settings" Custom-reset-standard t]))
+ (message "\"IDLWAVE\"-menu now contains full customization menu"))
(defun idlwave-show-commentary ()
"Use the finder to view the file documentation from `idlwave.el'."
@@ -9249,7 +9034,7 @@ With arg, list all abbrevs with the corresponding hook.
This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
(interactive "P")
- (let ((table (symbol-value 'idlwave-mode-abbrev-table))
+ (let ((table idlwave-mode-abbrev-table)
abbrevs
str rpl func fmt (len-str 0) (len-rpl 0))
(mapatoms
@@ -9307,6 +9092,9 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
;; Run the hook
(run-hooks 'idlwave-load-hook)
+;; Obsolete.
+(define-obsolete-function-alias 'idlwave-uniquify #'seq-uniq "28.1")
+
(provide 'idlwave)
;;; idlwave.el ends here
diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el
index 66b6feea550..e69a9ff394e 100644
--- a/lisp/progmodes/inf-lisp.el
+++ b/lisp/progmodes/inf-lisp.el
@@ -1,7 +1,6 @@
-;;; inf-lisp.el --- an inferior-lisp mode
+;;; inf-lisp.el --- an inferior-lisp mode -*- lexical-binding: t -*-
-;; Copyright (C) 1988, 1993-1994, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1988-2021 Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Keywords: processes, lisp
@@ -23,13 +22,13 @@
;;; Commentary:
-;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
+;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
;; This file defines a lisp-in-a-buffer package (inferior-lisp mode)
;; built on top of comint mode. This version is more featureful,
;; robust, and uniform than the Emacs 18 version. The key bindings are
;; also more compatible with the bindings of Hemlock and Zwei (the
-;; Lisp Machine emacs).
+;; Lisp Machine Emacs).
;; Since this mode is built on top of the general command-interpreter-in-
;; a-buffer mode (comint mode), it shares a common base functionality,
@@ -40,19 +39,19 @@
;; the hooks available for customizing it, see the file comint.el.
;; For further information on inferior-lisp mode, see the comments below.
-;; Needs fixin:
+;; Needs fixing:
;; The load-file/compile-file default mechanism could be smarter -- it
;; doesn't know about the relationship between filename extensions and
-;; whether the file is source or executable. If you compile foo.lisp
+;; whether the file is source or executable. If you compile foo.lisp
;; with compile-file, then the next load-file should use foo.bin for
-;; the default, not foo.lisp. This is tricky to do right, particularly
+;; the default, not foo.lisp. This is tricky to do right, particularly
;; because the extension for executable files varies so much (.o, .bin,
;; .lbin, .mo, .vo, .ao, ...).
;;
;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes
;; had a verbose minor mode wherein sending or compiling defuns, etc.
;; would be reflected in the transcript with suitable comments, e.g.
-;; ";;; redefining fact". Several ways to do this. Which is right?
+;; ";;; redefining fact". Several ways to do this. Which is right?
;;
;; When sending text from a source file to a subprocess, the process-mark can
;; move off the window, so you can lose sight of the process interactions.
@@ -63,6 +62,7 @@
(require 'comint)
(require 'lisp-mode)
+(require 'shell)
(defgroup inferior-lisp nil
@@ -76,25 +76,24 @@
Input matching this regexp is not saved on the input history in Inferior Lisp
mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword
\(as in :a, :c, etc.)"
- :type 'regexp
- :group 'inferior-lisp)
+ :type 'regexp)
(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)
+ (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))
(easy-menu-define
inferior-lisp-menu
inferior-lisp-mode-map
- "Inferior Lisp Menu"
+ "Inferior Lisp Menu."
'("Inf-Lisp"
["Eval Last Sexp" lisp-eval-last-sexp t]
"--"
@@ -108,56 +107,53 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword
;;; These commands augment Lisp mode, so you can process Lisp code in
;;; the source files.
-(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; GNU convention
-(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; GNU convention
-(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
-(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
-(define-key lisp-mode-map "\C-c\C-n" 'lisp-eval-form-and-next)
-(define-key lisp-mode-map "\C-c\C-p" 'lisp-eval-paragraph)
-(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
-(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
-(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
-(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file
-(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
-(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
-(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
-(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
-
-
-;;; This function exists for backwards compatibility.
-;;; Previous versions of this package bound commands to C-c <letter>
-;;; bindings, which is not allowed by the Emacs standard.
+(define-key lisp-mode-map "\M-\C-x" #'lisp-eval-defun) ; GNU convention
+(define-key lisp-mode-map "\C-x\C-e" #'lisp-eval-last-sexp) ; GNU convention
+(define-key lisp-mode-map "\C-c\C-e" #'lisp-eval-defun)
+(define-key lisp-mode-map "\C-c\C-r" #'lisp-eval-region)
+(define-key lisp-mode-map "\C-c\C-n" #'lisp-eval-form-and-next)
+(define-key lisp-mode-map "\C-c\C-p" #'lisp-eval-paragraph)
+(define-key lisp-mode-map "\C-c\C-c" #'lisp-compile-defun)
+(define-key lisp-mode-map "\C-c\C-z" #'switch-to-lisp)
+(define-key lisp-mode-map "\C-c\C-l" #'lisp-load-file)
+(define-key lisp-mode-map "\C-c\C-k" #'lisp-compile-file) ; "kompile" file
+(define-key lisp-mode-map "\C-c\C-a" #'lisp-show-arglist)
+(define-key lisp-mode-map "\C-c\C-d" #'lisp-describe-sym)
+(define-key lisp-mode-map "\C-c\C-f" #'lisp-show-function-documentation)
+(define-key lisp-mode-map "\C-c\C-v" #'lisp-show-variable-documentation)
+
+
+;; This function exists for backwards compatibility.
+;; Previous versions of this package bound commands to C-c <letter>
+;; bindings, which is not allowed by the Emacs standard.
;;; "This function binds many inferior-lisp commands to C-c <letter> bindings,
;;;where they are more accessible. C-c <letter> bindings are reserved for the
-;;;user, so these bindings are non-standard. If you want them, you should
-;;;have this function called by the inferior-lisp-load-hook:
-;;; (add-hook 'inferior-lisp-load-hook 'inferior-lisp-install-letter-bindings)
+;;;user, so these bindings are non-standard. If you want them:
+;;; (with-eval-after-load 'inf-lisp 'inferior-lisp-install-letter-bindings)
;;;You can modify this function to install just the bindings you want."
(defun inferior-lisp-install-letter-bindings ()
- (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
- (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
- (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
- (define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
- (define-key lisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
-
- (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key inferior-lisp-mode-map "\C-cv"
- 'lisp-show-variable-documentation))
+ (define-key lisp-mode-map "\C-ce" #'lisp-eval-defun-and-go)
+ (define-key lisp-mode-map "\C-cr" #'lisp-eval-region-and-go)
+ (define-key lisp-mode-map "\C-cc" #'lisp-compile-defun-and-go)
+ (define-key lisp-mode-map "\C-cz" #'switch-to-lisp)
+ (define-key lisp-mode-map "\C-cl" #'lisp-load-file)
+ (define-key lisp-mode-map "\C-ck" #'lisp-compile-file)
+ (define-key lisp-mode-map "\C-ca" #'lisp-show-arglist)
+ (define-key lisp-mode-map "\C-cd" #'lisp-describe-sym)
+ (define-key lisp-mode-map "\C-cf" #'lisp-show-function-documentation)
+ (define-key lisp-mode-map "\C-cv" #'lisp-show-variable-documentation)
+
+ (define-key inferior-lisp-mode-map "\C-cl" #'lisp-load-file)
+ (define-key inferior-lisp-mode-map "\C-ck" #'lisp-compile-file)
+ (define-key inferior-lisp-mode-map "\C-ca" #'lisp-show-arglist)
+ (define-key inferior-lisp-mode-map "\C-cd" #'lisp-describe-sym)
+ (define-key inferior-lisp-mode-map "\C-cf" #'lisp-show-function-documentation)
+ (define-key inferior-lisp-mode-map "\C-cv" #'lisp-show-variable-documentation))
(defcustom inferior-lisp-program "lisp"
"Program name for invoking an inferior Lisp in Inferior Lisp mode."
- :type 'string
- :group 'inferior-lisp)
+ :type 'string)
(defcustom inferior-lisp-load-command "(load \"%s\")\n"
"Format-string for building a Lisp expression to load a file.
@@ -167,8 +163,7 @@ to load that file. The default works acceptably on most Lisps.
The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\n\"
produces cosmetically superior output for this application,
but it works only in Common Lisp."
- :type 'string
- :group 'inferior-lisp)
+ :type 'string)
(defcustom inferior-lisp-prompt "^[^> \n]*>+:? *"
"Regexp to recognize prompts in the Inferior Lisp mode.
@@ -183,10 +178,9 @@ More precise choices:
Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\"
franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\"
kcl: \"^>+ *\""
- :type 'regexp
- :group 'inferior-lisp)
+ :type 'regexp)
-(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer.
+(defvar inferior-lisp-buffer nil "*The current `inferior-lisp' process buffer.
MULTIPLE PROCESS SUPPORT
===========================================================================
@@ -275,7 +269,8 @@ If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
(setq comint-prompt-regexp inferior-lisp-prompt)
(setq mode-line-process '(":%s"))
- (lisp-mode-variables t)
+ (lisp-mode-variables)
+ (set-syntax-table lisp-mode-syntax-table)
(setq comint-get-old-input (function lisp-get-old-input))
(setq comint-input-filter (function lisp-input-filter)))
@@ -295,15 +290,20 @@ to continue it."
"Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'.
If there is a process already running in `*inferior-lisp*', just switch
to that buffer.
+
With argument, allows you to edit the command line (default is value
of `inferior-lisp-program'). Runs the hooks from
`inferior-lisp-mode-hook' (after the `comint-mode-hook' is run).
+
+If any parts of the command name contains spaces, they should be
+quoted using shell quote syntax.
+
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(interactive (list (if current-prefix-arg
(read-string "Run lisp: " inferior-lisp-program)
inferior-lisp-program)))
(if (not (comint-check-proc "*inferior-lisp*"))
- (let ((cmdlist (split-string cmd)))
+ (let ((cmdlist (split-string-shell-command cmd)))
(set-buffer (apply (function make-comint)
"inferior-lisp" (car cmdlist) nil (cdr cmdlist)))
(inferior-lisp-mode)))
@@ -330,18 +330,18 @@ Prefix argument means switch to the Lisp buffer afterwards."
(if and-go (switch-to-lisp t)))
(defun lisp-compile-string (string)
- "Send the string to the inferior Lisp process to be compiled and executed."
+ "Send STRING to the inferior Lisp process to be compiled and executed."
(comint-send-string
(inferior-lisp-proc)
(format "(funcall (compile nil (lambda () %s)))\n" string)))
(defun lisp-eval-string (string)
- "Send the string to the inferior Lisp process to be executed."
+ "Send STRING to the inferior Lisp process to be executed."
(comint-send-string (inferior-lisp-proc) (concat string "\n")))
(defun lisp-do-defun (do-string do-region)
"Send the current defun to the inferior Lisp process.
-The actually processing is done by `do-string' and `do-region'
+The actually processing is done by DO-STRING and DO-REGION
which determine whether the code is compiled before evaluation.
DEFVAR forms reset the variables to the init values."
(save-excursion
@@ -448,7 +448,7 @@ With argument, positions cursor at end of buffer."
;;; (let ((name-start (point)))
;;; (forward-sexp 1)
;;; (process-send-string "inferior-lisp"
-;;; (format "(compile '%s #'(lambda "
+;;; (format "(compile '%s (lambda "
;;; (buffer-substring name-start
;;; (point)))))
;;; (let ((body-start (point)))
@@ -464,7 +464,7 @@ With argument, positions cursor at end of buffer."
;;; (interactive "r")
;;; (save-excursion
;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
-;;; (if (< (point) start) (error "region begins in middle of defun"))
+;;; (if (< (point) start) (error "Region begins in middle of defun"))
;;; (goto-char start)
;;; (let ((s start))
;;; (end-of-defun)
@@ -487,12 +487,11 @@ describing the last `lisp-load-file' or `lisp-compile-file' command.")
If it's loaded into a buffer that is in one of these major modes, it's
considered a Lisp source file by `lisp-load-file' and `lisp-compile-file'.
Used by these commands to determine defaults."
- :type '(repeat symbol)
- :group 'inferior-lisp)
+ :type '(repeat symbol))
(defun lisp-load-file (file-name)
"Load a Lisp file into the inferior Lisp process."
- (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
+ (interactive (comint-get-source "Load Lisp file" lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; nil because LOAD
; doesn't need an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
@@ -505,7 +504,7 @@ Used by these commands to determine defaults."
(defun lisp-compile-file (file-name)
"Compile a Lisp file in the inferior Lisp process."
- (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
+ (interactive (comint-get-source "Compile Lisp file" lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; nil = don't need
; suffix .lisp
(comint-check-source file-name) ; Check to see if buffer needs saved.
@@ -555,10 +554,7 @@ Used by these commands to determine defaults."
;;; Reads a string from the user.
(defun lisp-symprompt (prompt default)
- (list (let* ((prompt (if default
- (format "%s (default %s): " prompt default)
- (concat prompt ": ")))
- (ans (read-string prompt)))
+ (list (let ((ans (read-string (format-prompt prompt default))))
(if (zerop (length ans)) default ans))))
@@ -599,7 +595,7 @@ See variable `lisp-function-doc-command'."
(format lisp-function-doc-command fn)))
(defun lisp-show-variable-documentation (var)
- "Send a command to the inferior Lisp to give documentation for function FN.
+ "Send a command to the inferior Lisp to give documentation for variable VAR.
See variable `lisp-var-doc-command'."
(interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
(comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var)))
@@ -628,10 +624,12 @@ See variable `lisp-describe-sym-command'."
(error "No Lisp subprocess; see variable `inferior-lisp-buffer'"))))
-;;; Do the user's customization...
-;;;===============================
+;; Obsolete.
+
(defvar inferior-lisp-load-hook nil
"This hook is run when the library `inf-lisp' is loaded.")
+(make-obsolete-variable 'inferior-lisp-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'inferior-lisp-load-hook)
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index ffd4e310452..c2481f6095a 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -282,7 +282,7 @@ Match group 1 is the name of the macro.")
"continue" "debugger" "default" "delete" "do" "else"
"enum" "export" "extends" "final" "finally" "for"
"function" "goto" "if" "implements" "import" "in"
- "instanceof" "interface" "native" "new" "package"
+ "instanceof" "interface" "native" "new" "of" "package"
"private" "protected" "public" "return" "static"
"super" "switch" "synchronized" "throw"
"throws" "transient" "try" "typeof" "var" "void" "let"
@@ -427,22 +427,19 @@ Match group 1 is the name of the macro.")
(defcustom js-indent-level 4
"Number of spaces for each indentation step in `js-mode'."
:type 'integer
- :safe 'integerp
- :group 'js)
+ :safe 'integerp)
(defcustom js-expr-indent-offset 0
"Number of additional spaces for indenting continued expressions.
The value must be no less than minus `js-indent-level'."
:type 'integer
- :safe 'integerp
- :group 'js)
+ :safe 'integerp)
(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
:safe 'integerp
- :group 'js
:version "24.1")
(defcustom js-square-indent-offset 0
@@ -450,7 +447,6 @@ The value must be no less than minus `js-indent-level'."
The value must be no less than minus `js-indent-level'."
:type 'integer
:safe 'integerp
- :group 'js
:version "24.1")
(defcustom js-curly-indent-offset 0
@@ -458,7 +454,6 @@ The value must be no less than minus `js-indent-level'."
The value must be no less than minus `js-indent-level'."
:type 'integer
:safe 'integerp
- :group 'js
:version "24.1")
(defcustom js-switch-indent-offset 0
@@ -466,26 +461,22 @@ The value must be no less than minus `js-indent-level'."
The value must not be negative."
:type 'integer
:safe 'integerp
- :group 'js
:version "24.4")
(defcustom js-flat-functions nil
"Treat nested functions as top-level functions in `js-mode'.
This applies to function movement, marking, and so on."
- :type 'boolean
- :group 'js)
+ :type 'boolean)
(defcustom js-indent-align-list-continuation t
"Align continuation of non-empty ([{ lines in `js-mode'."
:version "26.1"
:type 'boolean
- :safe 'booleanp
- :group 'js)
+ :safe 'booleanp)
(defcustom js-comment-lineup-func #'c-lineup-C-comments
"Lineup function for `cc-mode-style', for C comments in `js-mode'."
- :type 'function
- :group 'js)
+ :type 'function)
(defcustom js-enabled-frameworks js--available-frameworks
"Frameworks recognized by `js-mode'.
@@ -493,30 +484,27 @@ To improve performance, you may turn off some frameworks you
seldom use, either globally or on a per-buffer basis."
:type (cons 'set (mapcar (lambda (x)
(list 'const x))
- js--available-frameworks))
- :group 'js)
+ js--available-frameworks)))
(defcustom js-js-switch-tabs
(and (memq system-type '(darwin)) t)
"Whether `js-mode' should display tabs while selecting them.
This is useful only if the windowing system has a good mechanism
for preventing Firefox from stealing the keyboard focus."
- :type 'boolean
- :group 'js)
+ :type 'boolean)
(defcustom js-js-tmpdir
- "~/.emacs.d/js/js"
+ (locate-user-emacs-file "js/js")
"Temporary directory used by `js-mode' to communicate with Mozilla.
This directory must be readable and writable by both Mozilla and Emacs."
:type 'directory
- :group 'js)
+ :version "28.1")
(defcustom js-js-timeout 5
"Reply timeout for executing commands in Mozilla via `js-mode'.
The value is given in seconds. Increase this value if you are
getting timeout messages."
- :type 'integer
- :group 'js)
+ :type 'integer)
(defcustom js-indent-first-init nil
"Non-nil means specially indent the first variable declaration's initializer.
@@ -557,8 +545,7 @@ don't indent the first one's initializer; otherwise, indent it.
bar = 2;"
:version "25.1"
:type '(choice (const nil) (const t) (const dynamic))
- :safe 'symbolp
- :group 'js)
+ :safe 'symbolp)
(defcustom js-chain-indent nil
"Use \"chained\" indentation.
@@ -571,8 +558,7 @@ then the \".\"s will be lined up:
"
:version "26.1"
:type 'boolean
- :safe 'booleanp
- :group 'js)
+ :safe 'booleanp)
(defcustom js-jsx-detect-syntax t
"When non-nil, automatically detect whether JavaScript uses JSX.
@@ -581,8 +567,7 @@ t. The detection strategy can be customized by adding elements
to `js-jsx-regexps', which see."
:version "27.1"
:type 'boolean
- :safe 'booleanp
- :group 'js)
+ :safe 'booleanp)
(defcustom js-jsx-syntax nil
"When non-nil, parse JavaScript with consideration for JSX syntax.
@@ -600,8 +585,7 @@ When `js-mode' is already enabled, you should call
It is set to be buffer-local (and t) when in `js-jsx-mode'."
:version "27.1"
:type 'boolean
- :safe 'booleanp
- :group 'js)
+ :safe 'booleanp)
(defcustom js-jsx-align->-with-< t
"When non-nil, “>†will be indented to the opening “<†in JSX.
@@ -625,8 +609,7 @@ When this is disabled, JSX indentation looks like this:
/>"
:version "27.1"
:type 'boolean
- :safe 'booleanp
- :group 'js)
+ :safe 'booleanp)
(defcustom js-jsx-indent-level nil
"When non-nil, indent JSX by this value, instead of like JS.
@@ -655,8 +638,7 @@ indentation looks like this (different):
:version "27.1"
:type '(choice integer
(const :tag "Not Set" nil))
- :safe (lambda (x) (or (null x) (integerp x)))
- :group 'js)
+ :safe (lambda (x) (or (null x) (integerp x))))
;; This is how indentation behaved out-of-the-box until Emacs 27. JSX
;; indentation was controlled with `sgml-basic-offset', which defaults
;; to 2, whereas `js-indent-level' defaults to 4. Users who had the
@@ -685,8 +667,7 @@ indentation looks like this:
This variable is like `sgml-attribute-offset'."
:version "27.1"
:type 'integer
- :safe 'integerp
- :group 'js)
+ :safe 'integerp)
;;; KeyMap
@@ -717,26 +698,20 @@ This variable is like `sgml-attribute-offset'."
table)
"Syntax table for `js-mode'.")
-(defvar js--quick-match-re nil
+(defvar-local js--quick-match-re nil
"Autogenerated regexp used by `js-mode' to match buffer constructs.")
-(defvar js--quick-match-re-func nil
+(defvar-local js--quick-match-re-func nil
"Autogenerated regexp used by `js-mode' to match constructs and functions.")
-(make-variable-buffer-local 'js--quick-match-re)
-(make-variable-buffer-local 'js--quick-match-re-func)
-
-(defvar js--cache-end 1
+(defvar-local js--cache-end 1
"Last valid buffer position for the `js-mode' function cache.")
-(make-variable-buffer-local 'js--cache-end)
-(defvar js--last-parse-pos nil
+(defvar-local js--last-parse-pos nil
"Latest parse position reached by `js--ensure-cache'.")
-(make-variable-buffer-local 'js--last-parse-pos)
-(defvar js--state-at-last-parse-pos nil
+(defvar-local js--state-at-last-parse-pos nil
"Parse state at `js--last-parse-pos'.")
-(make-variable-buffer-local 'js--state-at-last-parse-pos)
(defun js--maybe-join (prefix separator suffix &rest list)
"Helper function for `js--update-quick-match-re'.
@@ -1085,7 +1060,7 @@ Return the pitem of the function we went to the beginning of."
(t
(js--beginning-of-defun-nested))))))
-(defun js--flush-caches (&optional beg ignored)
+(defun js--flush-caches (&optional beg _ignored)
"Flush the `js-mode' syntax cache after position BEG.
BEG defaults to `point-min', meaning to flush the entire cache."
(interactive)
@@ -1365,7 +1340,6 @@ LIMIT defaults to point."
(defun js--end-of-defun-nested ()
"Helper function for `js-end-of-defun'."
- (message "test")
(let* (pitem
(this-end (save-excursion
(and (setq pitem (js--beginning-of-defun-nested))
@@ -1499,14 +1473,12 @@ LIMIT defaults to point."
"Helper function for building `js--font-lock-keywords'.
Create a byte-compiled function for matching a concatenation of
REGEXPS, but only if FRAMEWORK is in `js-enabled-frameworks'."
- (setq regexps (apply #'concat regexps))
- (byte-compile
- `(lambda (limit)
- (when (memq (quote ,framework) js-enabled-frameworks)
- (re-search-forward ,regexps limit t)))))
+ (let ((regexp (apply #'concat regexps)))
+ (lambda (limit)
+ (when (memq framework js-enabled-frameworks)
+ (re-search-forward regexp limit t)))))
-(defvar js--tmp-location nil)
-(make-variable-buffer-local 'js--tmp-location)
+(defvar-local js--tmp-location nil)
(defun js--forward-destructuring-spec (&optional func)
"Move forward over a JavaScript destructuring spec.
@@ -2888,7 +2860,11 @@ return nil."
((nth 3 parse-status) 0) ; inside string
((when (and js-jsx-syntax (not js-jsx--indent-col))
(save-excursion (js-jsx--indentation parse-status))))
- ((eq (char-after) ?#) 0)
+ ((and (eq (char-after) ?#)
+ (save-excursion
+ (forward-char 1)
+ (looking-at-p cpp-font-lock-keywords-source-directives)))
+ 0)
((save-excursion (js--beginning-of-macro)) 4)
;; Indent array comprehension continuation lines specially.
((let ((bracket (nth 1 parse-status))
@@ -3726,8 +3702,7 @@ Otherwise, use the current value of `process-mark'."
Strings and numbers are JSON-encoded. Lists (including nil) are
made into JavaScript array literals and their contents encoded
with `js--js-encode-value'."
- (cond ((stringp x) (json-encode-string x))
- ((numberp x) (json-encode-number x))
+ (cond ((or (stringp x) (numberp x)) (json-encode x))
((symbolp x) (format "{objid:%S}" (symbol-name x)))
((js--js-handle-p x)
@@ -4205,8 +4180,9 @@ browser, respectively."
"style" "")
cmds)))
- (eval (list 'with-js
- (cons 'js-list (nreverse cmds))))))
+ (eval `(with-js
+ (js-list ,@(nreverse cmds)))
+ t)))
(command-hook
()
@@ -4417,7 +4393,8 @@ If one hasn't been set, or if it's stale, prompt for a new one."
(with-temp-buffer
(insert js--js-inserter)
(insert "(")
- (insert (json-encode-list defun-info))
+ (let ((standard-output (current-buffer)))
+ (json--print-list defun-info))
(insert ",\n")
(insert defun-body)
(insert "\n)")
@@ -4570,7 +4547,7 @@ This function is intended for use in `after-change-functions'."
;; Comments
(setq-local comment-start "// ")
- (setq-local comment-start-skip "\\(//+\\|/\\*+\\)\\s *")
+ (setq-local comment-start-skip "\\(?://+\\|/\\*+\\)\\s *")
(setq-local comment-end "")
(setq-local fill-paragraph-function #'js-fill-paragraph)
(setq-local normal-auto-fill-function #'js-do-auto-fill)
@@ -4591,7 +4568,8 @@ This function is intended for use in `after-change-functions'."
(setq imenu-create-index-function #'js--imenu-create-index)
;; for filling, pretend we're cc-mode
- (c-init-language-vars js-mode)
+ (c-foreign-init-lit-pos-cache)
+ (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t)
(setq-local comment-line-break-function #'c-indent-new-comment-line)
(setq-local comment-multi-line t)
(setq-local electric-indent-chars
@@ -4655,8 +4633,19 @@ could set `js-jsx-syntax' to t in your init file, or in a
one of the aforementioned options instead of using this mode."
:group 'js
(js-jsx-enable)
+ (setq-local comment-region-function #'js-jsx--comment-region)
(js-use-syntactic-mode-name))
+(defun js-jsx--comment-region (beg end &optional arg)
+ (if (or (js-jsx--context)
+ (save-excursion
+ (skip-chars-forward " \t")
+ (js-jsx--looking-at-start-tag-p)))
+ (let ((comment-start "{/* ")
+ (comment-end " */}"))
+ (comment-region-default beg end arg))
+ (comment-region-default beg end arg)))
+
;;;###autoload (defalias 'javascript-mode 'js-mode)
(eval-after-load 'folding
@@ -4669,4 +4658,4 @@ one of the aforementioned options instead of using this mode."
(provide 'js)
-;; js.el ends here
+;;; js.el ends here
diff --git a/lisp/progmodes/ld-script.el b/lisp/progmodes/ld-script.el
index a61398a16ef..485e64e2492 100644
--- a/lisp/progmodes/ld-script.el
+++ b/lisp/progmodes/ld-script.el
@@ -1,4 +1,4 @@
-;;; ld-script.el --- GNU linker script editing mode for Emacs
+;;; ld-script.el --- GNU linker script editing mode for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -35,8 +35,7 @@
(defvar ld-script-location-counter-face 'ld-script-location-counter)
(defface ld-script-location-counter
'((t :weight bold :inherit font-lock-builtin-face))
- "Face for location counter in GNU ld script."
- :group 'ld-script)
+ "Face for location counter in GNU ld script.")
;; Syntax rules
(defvar ld-script-mode-syntax-table
@@ -173,10 +172,9 @@
;;;###autoload
(define-derived-mode ld-script-mode prog-mode "LD-Script"
"A major mode to edit GNU ld script files"
- (set (make-local-variable 'comment-start) "/* ")
- (set (make-local-variable 'comment-end) " */")
- (set (make-local-variable 'font-lock-defaults)
- '(ld-script-font-lock-keywords nil)))
+ (setq-local comment-start "/* ")
+ (setq-local comment-end " */")
+ (setq-local font-lock-defaults '(ld-script-font-lock-keywords nil)))
(provide 'ld-script)
diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el
index 4e0429ac1f2..d9c09f6fe6b 100644
--- a/lisp/progmodes/m4-mode.el
+++ b/lisp/progmodes/m4-mode.el
@@ -1,4 +1,4 @@
-;;; m4-mode.el --- m4 code editing commands for Emacs
+;;; m4-mode.el --- m4 code editing commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
@@ -48,32 +48,51 @@
"File name of the m4 executable.
If m4 is not in your PATH, set this to an absolute file name."
:version "24.4"
- :type 'file
- :group 'm4)
+ :type 'file)
;;options to m4
(defcustom m4-program-options nil
"Options to pass to `m4-program'."
- :type '(repeat string)
- :group 'm4)
+ :type '(repeat string))
;;to use --prefix-builtins, you can use
;;(defconst m4-program-options '("-P"))
;;or
;;(defconst m4-program-options '("--prefix-builtins"))
+;; Needed at compile-time for `m4-font-lock-keywords' below.
+(eval-and-compile
+ (defconst m4--macro-list
+ ;; From (info "(m4) Macro index")
+ '("__file__" "__gnu__" "__line__" "__os2__" "__program__" "__unix__"
+ "__windows__" "argn" "array" "array_set" "builtin" "capitalize"
+ "changecom" "changequote" "changeword" "cleardivert" "cond" "copy"
+ "curry" "debugfile" "debugmode" "decr" "define" "define_blind"
+ "defn" "divert" "divnum" "dnl" "downcase" "dquote" "dquote_elt"
+ "dumpdef" "errprint" "esyscmd" "eval" "example" "exch"
+ "fatal_error" "file" "foreach" "foreachq" "forloop" "format" "gnu"
+ "ifdef" "ifelse" "include" "incr" "index" "indir" "join" "joinall"
+ "len" "line" "m4exit" "m4wrap" "maketemp" "mkstemp" "nargs" "os2"
+ "patsubst" "popdef" "pushdef" "quote" "regexp" "rename" "reverse"
+ "shift" "sinclude" "stack_foreach" "stack_foreach_lifo"
+ "stack_foreach_sep" "stack_foreach_sep_lifo" "substr" "syscmd"
+ "sysval" "traceoff" "traceon" "translit" "undefine" "undivert"
+ "unix" "upcase" "windows")
+ "List of valid m4 macros for M4 mode."))
+
(defvar m4-font-lock-keywords
- '(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" (0 font-lock-comment-face t))
- ("\\$[*#@0-9]" . font-lock-variable-name-face)
- ("\\$@" . font-lock-variable-name-face)
- ("\\$\\*" . font-lock-variable-name-face)
- ("\\_<\\(m4_\\)?\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\_>" . font-lock-keyword-face))
+ (eval-when-compile
+ `(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" (0 font-lock-comment-face t))
+ ("\\$[*#@0-9]" . font-lock-variable-name-face)
+ ("\\$@" . font-lock-variable-name-face)
+ ("\\$\\*" . font-lock-variable-name-face)
+ (,(concat "\\_<\\(m4_\\)?" (regexp-opt m4--macro-list) "\\_>")
+ . font-lock-keyword-face)))
"Default `font-lock-keywords' for M4 mode.")
(defcustom m4-mode-hook nil
"Hook called by `m4-mode'."
- :type 'hook
- :group 'm4)
+ :type 'hook)
;;this may still need some work
(defvar m4-mode-syntax-table
@@ -103,29 +122,29 @@ If m4 is not in your PATH, set this to an absolute file name."
(string-to-syntax "."))))))
(defvar m4-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-b" 'm4-m4-buffer)
(define-key map "\C-c\C-r" 'm4-m4-region)
(define-key map "\C-c\C-c" 'comment-region)
- (define-key map [menu-bar m4-mode] (cons "M4" menu-map))
- (define-key menu-map [m4c]
- '(menu-item "Comment Region" comment-region
- :help "Comment Region"))
- (define-key menu-map [m4b]
- '(menu-item "M4 Buffer" m4-m4-buffer
- :help "Send contents of the current buffer to m4"))
- (define-key menu-map [m4r]
- '(menu-item "M4 Region" m4-m4-region
- :help "Send contents of the current region to m4"))
- map))
+ map)
+ "Keymap for M4 Mode.")
+
+(easy-menu-define m4-mode-menu m4-mode-map
+ "Menu for M4 Mode."
+ '("M4"
+ ["M4 Region" m4-m4-region
+ :help "Send contents of the current region to m4"]
+ ["M4 Buffer" m4-m4-buffer
+ :help "Send contents of the current buffer to m4"]
+ ["Comment Region" comment-region
+ :help "Comment Region"]))
(defun m4-m4-buffer ()
"Send contents of the current buffer to m4."
(interactive)
(shell-command-on-region
(point-min) (point-max)
- (mapconcat 'identity (cons m4-program m4-program-options) "\s")
+ (mapconcat #'identity (cons m4-program m4-program-options) "\s")
"*m4-output*" nil)
(switch-to-buffer-other-window "*m4-output*"))
@@ -134,7 +153,7 @@ If m4 is not in your PATH, set this to an absolute file name."
(interactive)
(shell-command-on-region
(point) (mark)
- (mapconcat 'identity (cons m4-program m4-program-options) "\s")
+ (mapconcat #'identity (cons m4-program m4-program-options) "\s")
"*m4-output*" nil)
(switch-to-buffer-other-window "*m4-output*"))
@@ -158,22 +177,4 @@ If m4 is not in your PATH, set this to an absolute file name."
;;stuff to play with for debugging
;(char-to-string (char-syntax ?`))
-;;;how I generate the nasty looking regexps at the top
-;;;(make-regexp '("builtin" "changecom" "changequote" "changeword" "debugfile"
-;;; "debugmode" "decr" "define" "defn" "divert" "divnum" "dnl"
-;;; "dumpdef" "errprint" "esyscmd" "eval" "file" "format" "gnu"
-;;; "ifdef" "ifelse" "include" "incr" "index" "indir" "len" "line"
-;;; "m4exit" "m4wrap" "maketemp" "patsubst" "popdef" "pushdef" "regexp"
-;;; "shift" "sinclude" "substr" "syscmd" "sysval" "traceoff" "traceon"
-;;; "translit" "undefine" "undivert" "unix"))
-;;;(make-regexp '("m4_builtin" "m4_changecom" "m4_changequote" "m4_changeword"
-;;; "m4_debugfile" "m4_debugmode" "m4_decr" "m4_define" "m4_defn"
-;;; "m4_divert" "m4_divnum" "m4_dnl" "m4_dumpdef" "m4_errprint"
-;;; "m4_esyscmd" "m4_eval" "m4_file" "m4_format" "m4_ifdef" "m4_ifelse"
-;;; "m4_include" "m4_incr" "m4_index" "m4_indir" "m4_len" "m4_line"
-;;; "m4_m4exit" "m4_m4wrap" "m4_maketemp" "m4_patsubst" "m4_popdef"
-;;; "m4_pushdef" "m4_regexp" "m4_shift" "m4_sinclude" "m4_substr"
-;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit"
-;;; "m4_m4_undefine" "m4_undivert"))
-
;;; m4-mode.el ends here
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index 63a51567c05..4d277755aeb 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -101,14 +101,12 @@
(defface makefile-space
'((((class color)) (:background "hotpink"))
(t (:reverse-video t)))
- "Face to use for highlighting leading spaces in Font-Lock mode."
- :group 'makefile)
+ "Face to use for highlighting leading spaces in Font-Lock mode.")
(defface makefile-targets
;; This needs to go along both with foreground and background colors (i.e. shell)
'((t (:inherit font-lock-function-name-face)))
"Face to use for additionally highlighting rule targets in Font-Lock mode."
- :group 'makefile
:version "22.1")
(defface makefile-shell
@@ -116,7 +114,6 @@
;;'((((class color) (min-colors 88) (background light)) (:background "seashell1"))
;; (((class color) (min-colors 88) (background dark)) (:background "seashell4")))
"Face to use for additionally highlighting Shell commands in Font-Lock mode."
- :group 'makefile
:version "22.1")
(defface makefile-makepp-perl
@@ -124,19 +121,16 @@
(((class color) (background dark)) (:background "DarkBlue"))
(t (:reverse-video t)))
"Face to use for additionally highlighting Perl code in Font-Lock mode."
- :group 'makefile
:version "22.1")
(defcustom makefile-browser-buffer-name "*Macros and Targets*"
"Name of the macro- and target browser buffer."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defcustom makefile-target-colon ":"
"String to append to all target names inserted by `makefile-insert-target'.
\":\" or \"::\" are common values."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defcustom makefile-macro-assign " = "
"String to append to all macro names inserted by `makefile-insert-macro'.
@@ -144,70 +138,58 @@ The normal value should be \" = \", since this is what
standard make expects. However, newer makes such as dmake
allow a larger variety of different macro assignments, so you
might prefer to use \" += \" or \" := \" ."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defcustom makefile-electric-keys nil
"If non-nil, Makefile mode should install electric keybindings.
Default is nil."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-use-curly-braces-for-macros-p nil
"Controls the style of generated macro references.
Non-nil means macro references should use curly braces, like `${this}'.
nil means use parentheses, like `$(this)'."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-tab-after-target-colon t
"If non-nil, insert a TAB after a target colon.
Otherwise, a space is inserted.
The default is t."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-browser-leftmost-column 10
"Number of blanks to the left of the browser selection mark."
- :type 'integer
- :group 'makefile)
+ :type 'integer)
(defcustom makefile-browser-cursor-column 10
"Column the cursor goes to when it moves up or down in the Makefile browser."
- :type 'integer
- :group 'makefile)
+ :type 'integer)
(defcustom makefile-backslash-column 48
"Column in which `makefile-backslash-region' inserts backslashes."
- :type 'integer
- :group 'makefile)
+ :type 'integer)
(defcustom makefile-backslash-align t
"If non-nil, `makefile-backslash-region' will align backslashes."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-browser-selected-mark "+ "
"String used to mark selected entries in the Makefile browser."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defcustom makefile-browser-unselected-mark " "
"String used to mark unselected entries in the Makefile browser."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defcustom makefile-browser-auto-advance-after-selection-p t
"If non-nil, cursor will move after item is selected in Makefile browser."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-pickup-everything-picks-up-filenames-p nil
"If non-nil, `makefile-pickup-everything' picks up filenames as targets.
This means it calls `makefile-pickup-filenames-as-targets'.
Otherwise filenames are omitted."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-cleanup-continuations nil
"If non-nil, automatically clean up continuation lines when saving.
@@ -215,13 +197,11 @@ A line is cleaned up by removing all whitespace following a trailing
backslash. This is done silently.
IMPORTANT: Please note that enabling this option causes Makefile mode
to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\"."
- :type 'boolean
- :group 'makefile)
+ :type 'boolean)
(defcustom makefile-mode-hook nil
"Normal hook run by `makefile-mode'."
- :type 'hook
- :group 'makefile)
+ :type 'hook)
(defvar makefile-browser-hook '())
@@ -240,8 +220,7 @@ to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\"."
"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'."
- :type '(repeat string)
- :group 'makefile)
+ :type '(repeat string))
(put 'makefile-special-targets-list 'risky-local-variable t)
(defcustom makefile-runtime-macros-list
@@ -250,8 +229,7 @@ you enter a \".\" at the beginning of a line in `makefile-mode'."
If you insert a macro reference using `makefile-insert-macro-ref', the name
of the macro is checked against this list. If it can be found its name will
not be enclosed in { } or ( )."
- :type '(repeat (list string))
- :group 'makefile)
+ :type '(repeat (list string)))
;; Note that the first big subexpression is used by font lock. Note
;; that if you change this regexp you might have to fix the imenu
@@ -294,7 +272,7 @@ not be enclosed in { } or ( )."
"Regex used to find macro assignment lines in a makefile.")
(defconst makefile-var-use-regex
- "[^$]\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)"
+ "\\(^\\|[^$]\\)\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)"
"Regex used to find $(macro) uses in a makefile.")
(defconst makefile-ignored-files-in-pickup-regex
@@ -316,7 +294,7 @@ not be enclosed in { } or ( )."
(defconst makefile-gmake-statements
`("-sinclude" "sinclude" ; makefile-makepp-statements takes rest
"ifdef" "ifndef" "ifeq" "ifneq" "-include" "define" "endef" "export"
- "override define" "override" "unexport" "vpath"
+ "override define" "override" "unexport" "vpath" "undefine"
,@(cdr makefile-automake-statements))
"List of keywords understood by gmake.")
@@ -343,8 +321,9 @@ not be enclosed in { } or ( )."
"List of keywords understood by gmake.")
(defconst makefile-bsdmake-statements
- '(".elif" ".elifdef" ".elifmake" ".elifndef" ".elifnmake" ".else" ".endfor"
- ".endif" ".for" ".if" ".ifdef" ".ifmake" ".ifndef" ".ifnmake" ".undef")
+ '("elif" "elifdef" "elifmake" "elifndef" "elifnmake" "else" "endfor"
+ "endif" "for" "if" "ifdef" "ifmake" "ifndef" "ifnmake" "poison"
+ "undef" "include")
"List of keywords understood by BSD make.")
(defun makefile-make-font-lock-keywords (var keywords space
@@ -367,7 +346,7 @@ not be enclosed in { } or ( )."
(3 font-lock-builtin-face prepend t))
;; Variable references even in targets/strings/comments.
- (,var 1 font-lock-variable-name-face prepend)
+ (,var 2 font-lock-variable-name-face prepend)
;; Automatic variable references and single character variable references,
;; but not shell variables references.
@@ -376,8 +355,9 @@ not be enclosed in { } or ( )."
("[^$]\\(\\$[@%*]\\)"
1 'makefile-targets append)
- ;; Fontify conditionals and includes.
- (,(concat "^\\(?: [ \t]*\\)?"
+ ,@(if keywords
+ ;; Fontify conditionals and includes.
+ `((,(concat "^\\(?: [ \t]*\\)?"
(replace-regexp-in-string
" " "[ \t]+"
(if (eq (car keywords) t)
@@ -385,7 +365,7 @@ not be enclosed in { } or ( )."
(regexp-opt (cdr keywords) t))
(regexp-opt keywords t)))
"\\>[ \t]*\\([^: \t\n#]*\\)")
- (1 font-lock-keyword-face) (2 font-lock-variable-name-face))
+ (1 font-lock-keyword-face) (2 font-lock-variable-name-face))))
,@(if negation
`((,negation (1 font-lock-negation-char-face prepend)
@@ -433,6 +413,9 @@ not be enclosed in { } or ( )."
'("[^$]\\(\\$[({][@%*][DF][})]\\)"
1 'makefile-targets append)
+ ;; Automatic variables.
+ '("[^$]\\(\\$[@%*?+^|]\\)" 1 'makefile-targets append)
+
;; $(function ...) ${function ...}
'("[^$]\\$[({]\\([-a-zA-Z0-9_.]+\\s \\)"
1 font-lock-function-name-face prepend)
@@ -493,13 +476,17 @@ not be enclosed in { } or ( )."
1 'makefile-makepp-perl t)))
(defconst makefile-bsdmake-font-lock-keywords
- (makefile-make-font-lock-keywords
- ;; A lot more could be done for variables here:
- makefile-var-use-regex
- makefile-bsdmake-statements
- t
- "^\\(?: [ \t]*\\)?\\.\\(?:el\\)?if\\(n?\\)\\(?:def\\|make\\)?\\>[ \t]*\\(!?\\)"
- '("^[ \t]*\\.for[ \t].+[ \t]\\(in\\)\\>" 1 font-lock-keyword-face)))
+ (append
+ (makefile-make-font-lock-keywords
+ ;; A lot more could be done for variables here:
+ makefile-var-use-regex
+ nil
+ t
+ "^\\(?: [ \t]*\\)?\\.\\(?:el\\)?if\\(n?\\)\\(?:def\\|make\\)?\\>[ \t]*\\(!?\\)"
+ '("^[ \t]*\\.for[ \t].+[ \t]\\(in\\)\\>" 1 font-lock-keyword-face))
+ `((,(concat "^\\. *" (regexp-opt makefile-bsdmake-statements) "\\>") 0
+ font-lock-keyword-face))))
+
(defconst makefile-imake-font-lock-keywords
(append
@@ -554,8 +541,7 @@ not be enclosed in { } or ( )."
(defcustom makefile-brave-make "make"
"How to invoke make, for `makefile-query-targets'.
This should identify a `make' command that can handle the `-q' option."
- :type 'string
- :group 'makefile)
+ :type 'string)
(defvaralias 'makefile-query-one-target-method
'makefile-query-one-target-method-function)
@@ -575,13 +561,11 @@ The function must satisfy this calling convention:
* It must return the integer value 0 (zero) if the given target
should be considered up-to-date in the context of the given
makefile, any nonzero integer value otherwise."
- :type 'function
- :group 'makefile)
+ :type 'function)
(defcustom makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*"
"Name of the Up-to-date overview buffer."
- :type 'string
- :group 'makefile)
+ :type 'string)
;;; --- end of up-to-date-overview configuration ------------------
@@ -589,8 +573,7 @@ The function must satisfy this calling convention:
"Abbrev table in use in Makefile buffers.")
(defvar makefile-mode-map
- (let ((map (make-sparse-keymap))
- (opt-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
;; set up the keymap
(define-key map "\C-c:" 'makefile-insert-target-ref)
(if makefile-electric-keys
@@ -615,72 +598,62 @@ The function must satisfy this calling convention:
(define-key map "\M-p" 'makefile-previous-dependency)
(define-key map "\M-n" 'makefile-next-dependency)
(define-key map "\e\t" 'completion-at-point)
-
- ;; Make menus.
- (define-key map [menu-bar makefile-mode]
- (cons "Makefile" (make-sparse-keymap "Makefile")))
-
- (define-key map [menu-bar makefile-mode makefile-type]
- (cons "Switch Makefile Type" opt-map))
- (define-key opt-map [makefile-makepp-mode]
- '(menu-item "Makepp" makefile-makepp-mode
- :help "An adapted `makefile-mode' that knows about makepp"
- :button (:radio . (eq major-mode 'makefile-makepp-mode))))
- (define-key opt-map [makefile-imake-mode]
- '(menu-item "Imake" makefile-imake-mode
- :help "An adapted `makefile-mode' that knows about imake"
- :button (:radio . (eq major-mode 'makefile-imake-mode))))
- (define-key opt-map [makefile-mode]
- '(menu-item "Classic" makefile-mode
- :help "`makefile-mode' with no special functionality"
- :button (:radio . (eq major-mode 'makefile-mode))))
- (define-key opt-map [makefile-bsdmake-mode]
- '(menu-item "BSD" makefile-bsdmake-mode
- :help "An adapted `makefile-mode' that knows about BSD make"
- :button (:radio . (eq major-mode 'makefile-bsdmake-mode))))
- (define-key opt-map [makefile-automake-mode]
- '(menu-item "Automake" makefile-automake-mode
- :help "An adapted `makefile-mode' that knows about automake"
- :button (:radio . (eq major-mode 'makefile-automake-mode))))
- (define-key opt-map [makefile-gmake-mode]
- '(menu-item "GNU make" makefile-gmake-mode
- :help "An adapted `makefile-mode' that knows about GNU make"
- :button (:radio . (eq major-mode 'makefile-gmake-mode))))
- (define-key map [menu-bar makefile-mode browse]
- '(menu-item "Pop up Makefile Browser" makefile-switch-to-browser
- ;; XXX: this needs a better string, the function is not documented...
- :help "Pop up Makefile Browser"))
- (define-key map [menu-bar makefile-mode overview]
- '(menu-item "Up To Date Overview" makefile-create-up-to-date-overview
- :help "Create a buffer containing an overview of the state of all known targets"))
- ;; Target related
- (define-key map [menu-bar makefile-mode separator1] '("----"))
- (define-key map [menu-bar makefile-mode pickup-file]
- '(menu-item "Pick File Name as Target" makefile-pickup-filenames-as-targets
- :help "Scan the current directory for filenames to use as targets"))
- (define-key map [menu-bar makefile-mode function]
- '(menu-item "Insert GNU make function" makefile-insert-gmake-function
- :help "Insert a GNU make function call"))
- (define-key map [menu-bar makefile-mode pickup]
- '(menu-item "Find Targets and Macros" makefile-pickup-everything
- :help "Notice names of all macros and targets in Makefile"))
- (define-key map [menu-bar makefile-mode complete]
- '(menu-item "Complete Target or Macro" completion-at-point
- :help "Perform completion on Makefile construct preceding point"))
- (define-key map [menu-bar makefile-mode backslash]
- '(menu-item "Backslash Region" makefile-backslash-region
- :help "Insert, align, or delete end-of-line backslashes on the lines in the region"))
- ;; Motion
- (define-key map [menu-bar makefile-mode separator] '("----"))
- (define-key map [menu-bar makefile-mode prev]
- '(menu-item "Move to Previous Dependency" makefile-previous-dependency
- :help "Move point to the beginning of the previous dependency line"))
- (define-key map [menu-bar makefile-mode next]
- '(menu-item "Move to Next Dependency" makefile-next-dependency
- :help "Move point to the beginning of the next dependency line"))
map)
"The keymap that is used in Makefile mode.")
+(easy-menu-define makefile-mode-menu makefile-mode-map
+ "Menu for Makefile mode."
+ '("Makefile"
+ ;; Motion
+ ["Move to Next Dependency" makefile-next-dependency
+ :help "Move point to the beginning of the next dependency line"]
+ ["Move to Previous Dependency" makefile-previous-dependency
+ :help "Move point to the beginning of the previous dependency line"]
+ "----"
+ ;; Target related
+ ["Backslash Region" makefile-backslash-region
+ :help "Insert, align, or delete end-of-line backslashes on the lines in the region"]
+ ["Complete Target or Macro" completion-at-point
+ :help "Perform completion on Makefile construct preceding point"]
+ ["Find Targets and Macros" makefile-pickup-everything
+ :help "Notice names of all macros and targets in Makefile"]
+ ["Insert GNU make function" makefile-insert-gmake-function
+ :help "Insert a GNU make function call"]
+ ["Pick File Name as Target" makefile-pickup-filenames-as-targets
+ :help "Scan the current directory for filenames to use as targets"]
+ "----"
+ ;; Other.
+ ["Up To Date Overview" makefile-create-up-to-date-overview
+ :help "Create a buffer containing an overview of the state of all known targets"]
+ ["Pop up Makefile Browser" makefile-switch-to-browser
+ ;; XXX: this needs a better string, the function is not documented...
+ :help "Pop up Makefile Browser"]
+ ("Switch Makefile Type"
+ ["GNU make" makefile-gmake-mode
+ :help "An adapted `makefile-mode' that knows about GNU make"
+ :style radio
+ :selected (eq major-mode 'makefile-gmake-mode)]
+ ["Automake" makefile-automake-mode
+ :help "An adapted `makefile-mode' that knows about automake"
+ :style radio
+ :selected (eq major-mode 'makefile-automake-mode)]
+ ["BSD" makefile-bsdmake-mode
+ :help "An adapted `makefile-mode' that knows about BSD make"
+ :style radio
+ :selected (eq major-mode 'makefile-bsdmake-mode)]
+ ["Classic" makefile-mode
+ :help "`makefile-mode' with no special functionality"
+ :style radio
+ :selected (eq major-mode 'makefile-mode)]
+ ["Imake" makefile-imake-mode
+ :help "An adapted `makefile-mode' that knows about imake"
+ :style radio
+ :selected (eq major-mode 'makefile-imake-mode)]
+ ["Makepp" makefile-makepp-mode
+ :help "An adapted `makefile-mode' that knows about makepp"
+ :style radio
+ :selected (eq major-mode 'makefile-makepp-mode)])))
+
(defvar makefile-browser-map
(let ((map (make-sparse-keymap)))
@@ -1370,13 +1343,11 @@ Fill comments, backslashed lines, and variable definitions specially."
(goto-char (point-min))
(erase-buffer)
(mapconcat
- (function
- (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n")))
+ (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n"))
targets
"")
(mapconcat
- (function
- (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n")))
+ (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n"))
macros
"")
(sort-lines nil (point-min) (point-max))
@@ -1413,7 +1384,7 @@ Fill comments, backslashed lines, and variable definitions specially."
"Leave the browser and return to the makefile buffer."
(interactive)
(let ((my-client makefile-browser-client))
- (setq makefile-browser-client nil) ; we quitted, so NO client!
+ (setq makefile-browser-client nil) ; we quit, so NO client!
(set-buffer-modified-p nil)
(quit-window t)
(pop-to-buffer my-client)))
@@ -1600,20 +1571,19 @@ Checks each target in TARGET-TABLE using
and generates the overview, one line per target name."
(insert
(mapconcat
- (function (lambda (item)
- (let* ((target-name (car item))
- (no-prereqs (not (member target-name prereq-list)))
- (needs-rebuild (or no-prereqs
- (funcall
- makefile-query-one-target-method-function
- target-name
- filename))))
- (format "\t%s%s"
- target-name
- (cond (no-prereqs " .. has no prerequisites")
- (needs-rebuild " .. NEEDS REBUILD")
- (t " .. is up to date"))))
- ))
+ (lambda (item)
+ (let* ((target-name (car item))
+ (no-prereqs (not (member target-name prereq-list)))
+ (needs-rebuild (or no-prereqs
+ (funcall
+ makefile-query-one-target-method-function
+ target-name
+ filename))))
+ (format "\t%s%s"
+ target-name
+ (cond (no-prereqs " .. has no prerequisites")
+ (needs-rebuild " .. NEEDS REBUILD")
+ (t " .. is up to date")))))
target-table "\n"))
(goto-char (point-min))
(delete-file filename)) ; remove the tmpfile
@@ -1687,9 +1657,9 @@ Then prompts for all required parameters."
(defun makefile-prompt-for-gmake-funargs (function-name prompt-list)
(mapconcat
- (function (lambda (one-prompt)
- (read-string (format "[%s] %s: " function-name one-prompt)
- nil)))
+ (lambda (one-prompt)
+ (read-string (format "[%s] %s: " function-name one-prompt)
+ nil))
prompt-list
","))
@@ -1721,7 +1691,9 @@ matched in a rule action."
(while (progn (skip-chars-forward makefile-dependency-skip bound)
(< (point) (or bound (point-max))))
(forward-char)
- (or (eq (char-after) ?=)
+ ;; The GNU immediate assignment operator is ":=", while the
+ ;; POSIX operator is "::=".
+ (or (looking-at ":?=")
(get-text-property (1- (point)) 'face)
(if (> (line-beginning-position) (+ (point-min) 2))
(eq (char-before (line-end-position 0)) ?\\))
diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el
index 44e8a5dc670..50268446025 100644
--- a/lisp/progmodes/meta-mode.el
+++ b/lisp/progmodes/meta-mode.el
@@ -88,8 +88,6 @@
;;; Code:
-(require 'easymenu)
-
(defgroup meta-font nil
"Major mode for editing Metafont or MetaPost sources."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
@@ -109,44 +107,31 @@
"\\(def\\|let\\|mode_def\\|vardef\\)")
(macro-keywords-2
"\\(primarydef\\|secondarydef\\|tertiarydef\\)")
-;(make-regexp
-; '("expr" "suffix" "text" "primary" "secondary" "tertiary") t)
(args-keywords
- (concat "\\(expr\\|primary\\|s\\(econdary\\|uffix\\)\\|"
- "te\\(rtiary\\|xt\\)\\)"))
-;(make-regexp
-; '("boolean" "color" "numeric" "pair" "path" "pen" "picture"
-; "string" "transform" "newinternal") t)
+ (eval-when-compile
+ (regexp-opt
+ '("expr" "suffix" "text" "primary" "secondary" "tertiary")
+ t)))
(type-keywords
- (concat "\\(boolean\\|color\\|n\\(ewinternal\\|umeric\\)\\|"
- "p\\(a\\(ir\\|th\\)\\|en\\|icture\\)\\|string\\|"
- "transform\\)"))
-;(make-regexp
-; '("for" "forever" "forsuffixes" "endfor"
-; "step" "until" "upto" "downto" "thru" "within"
-; "iff" "if" "elseif" "else" "fi" "exitif" "exitunless"
-; "let" "def" "vardef" "enddef" "mode_def"
-; "true" "false" "known" "unknown" "and" "or" "not"
-; "save" "interim" "inner" "outer" "relax"
-; "begingroup" "endgroup" "expandafter" "scantokens"
-; "generate" "input" "endinput" "end" "bye"
-; "message" "errmessage" "errhelp" "special" "numspecial"
-; "readstring" "readfrom" "write") t)
+ (eval-when-compile
+ (regexp-opt
+ '("boolean" "color" "numeric" "pair" "path" "pen" "picture"
+ "string" "transform" "newinternal")
+ t)))
(syntactic-keywords
- (concat "\\(and\\|b\\(egingroup\\|ye\\)\\|"
- "d\\(ef\\|ownto\\)\\|e\\(lse\\(\\|if\\)"
- "\\|nd\\(\\|def\\|for\\|group\\|input\\)"
- "\\|rr\\(help\\|message\\)"
- "\\|x\\(it\\(if\\|unless\\)\\|pandafter\\)\\)\\|"
- "f\\(alse\\|i\\|or\\(\\|ever\\|suffixes\\)\\)\\|"
- "generate\\|i\\(ff?\\|n\\(ner\\|put\\|terim\\)\\)\\|"
- "known\\|let\\|m\\(essage\\|ode_def\\)\\|"
- "n\\(ot\\|umspecial\\)\\|o\\(r\\|uter\\)\\|"
- "re\\(ad\\(from\\|string\\)\\|lax\\)\\|"
- "s\\(ave\\|cantokens\\|pecial\\|tep\\)\\|"
- "t\\(hru\\|rue\\)\\|"
- "u\\(n\\(known\\|til\\)\\|pto\\)\\|"
- "vardef\\|w\\(ithin\\|rite\\)\\)"))
+ (eval-when-compile
+ (regexp-opt
+ '("for" "forever" "forsuffixes" "endfor"
+ "step" "until" "upto" "downto" "thru" "within"
+ "iff" "if" "elseif" "else" "fi" "exitif" "exitunless"
+ "let" "def" "vardef" "enddef" "mode_def"
+ "true" "false" "known" "unknown" "and" "or" "not"
+ "save" "interim" "inner" "outer" "relax"
+ "begingroup" "endgroup" "expandafter" "scantokens"
+ "generate" "input" "endinput" "end" "bye"
+ "message" "errmessage" "errhelp" "special" "numspecial"
+ "readstring" "readfrom" "write")
+ t)))
)
(list
;; embedded TeX code in btex ... etex
@@ -463,25 +448,21 @@ If the list was changed, sort the list and remove duplicates first."
(defcustom meta-indent-level 2
"Indentation of begin-end blocks in Metafont or MetaPost mode."
- :type 'integer
- :group 'meta-font)
+ :type 'integer)
(defcustom meta-left-comment-regexp "%%+"
"Regexp matching comments that should be placed on the left margin."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defcustom meta-right-comment-regexp nil
"Regexp matching comments that should be placed on the right margin."
:type '(choice regexp
- (const :tag "None" nil))
- :group 'meta-font)
+ (const :tag "None" nil)))
(defcustom meta-ignore-comment-regexp "%[^%]"
"Regexp matching comments whose indentation should not be touched."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defcustom meta-begin-environment-regexp
@@ -489,22 +470,19 @@ If the list was changed, sort the list and remove duplicates first."
"def\\|for\\(\\|ever\\|suffixes\\)\\|if\\|mode_def\\|"
"primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)")
"Regexp matching the beginning of environments to be indented."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(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."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defcustom meta-within-environment-regexp
; (concat "\\(e\\(lse\\(\\|if\\)\\|xit\\(if\\|unless\\)\\)\\)")
(concat "\\(else\\(\\|if\\)\\)")
"Regexp matching keywords within environments not to be indented."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defun meta-comment-indent ()
@@ -689,14 +667,12 @@ If the list was changed, sort the list and remove duplicates first."
(concat "\\(begin\\(char\\|fig\\|logochar\\)\\|def\\|mode_def\\|"
"primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)")
"Regexp matching beginning of defuns in Metafont or MetaPost mode."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defcustom meta-end-defun-regexp
(concat "\\(end\\(char\\|def\\|fig\\)\\)")
"Regexp matching the end of defuns in Metafont or MetaPost mode."
- :type 'regexp
- :group 'meta-font)
+ :type 'regexp)
(defun meta-beginning-of-defun (&optional arg)
@@ -893,22 +869,21 @@ The environment marked is the one that contains point or follows point."
(defcustom meta-mode-load-hook nil
"Hook evaluated when first loading Metafont or MetaPost mode."
- :type 'hook
- :group 'meta-font)
+ :type 'hook)
+(make-obsolete-variable 'meta-mode-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom meta-common-mode-hook nil
"Hook evaluated by both `metafont-mode' and `metapost-mode'."
- :type 'hook
- :group 'meta-font)
+ :type 'hook)
(defcustom metafont-mode-hook nil
"Hook evaluated by `metafont-mode' after `meta-common-mode-hook'."
- :type 'hook
- :group 'meta-font)
+ :type 'hook)
+
(defcustom metapost-mode-hook nil
"Hook evaluated by `metapost-mode' after `meta-common-mode-hook'."
- :type 'hook
- :group 'meta-font)
+ :type 'hook)
@@ -917,63 +892,55 @@ The environment marked is the one that contains point or follows point."
(define-derived-mode meta-common-mode prog-mode "-Meta-common-"
"Common initialization for Metafont or MetaPost mode."
:abbrev-table meta-mode-abbrev-table
- (set (make-local-variable 'paragraph-start)
- (concat page-delimiter "\\|$"))
- (set (make-local-variable 'paragraph-separate)
- (concat page-delimiter "\\|$"))
+ (setq-local paragraph-start (concat page-delimiter "\\|$"))
+ (setq-local paragraph-separate (concat page-delimiter "\\|$"))
- (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
+ (setq-local 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)
+ (setq-local comment-start-skip "%+[ \t\f]*")
+ (setq-local comment-start "%")
+ (setq-local comment-end "")
+ (setq-local comment-multi-line nil)
;; We use `back-to-indentation' but \f is no indentation sign.
(modify-syntax-entry ?\f "_ ")
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (setq-local parse-sexp-ignore-comments t)
(add-hook 'completion-at-point-functions #'meta-completions-at-point nil t)
- (set (make-local-variable 'comment-indent-function) #'meta-comment-indent)
- (set (make-local-variable 'indent-line-function) #'meta-indent-line)
+ (setq-local comment-indent-function #'meta-comment-indent)
+ (setq-local 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.
- (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.
- (easy-menu-add meta-mode-menu))
+ (setq-local font-lock-defaults
+ '(meta-font-lock-keywords
+ nil nil ((?_ . "w")) nil
+ (font-lock-comment-start-regexp . "%"))))
;;;###autoload
(define-derived-mode metafont-mode meta-common-mode "Metafont"
"Major mode for editing Metafont sources."
;; Set defaults for completion function.
- (set (make-local-variable 'meta-symbol-list) nil)
- (set (make-local-variable 'meta-symbol-changed) nil)
+ (setq-local meta-symbol-list nil)
+ (setq-local meta-symbol-changed nil)
(apply 'meta-add-symbols metafont-symbol-list)
- (set (make-local-variable 'meta-complete-list)
- (list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
- (list "" 'ispell-complete-word))))
+ (setq-local meta-complete-list
+ (list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
+ (list "" 'ispell-complete-word))))
;;;###autoload
(define-derived-mode metapost-mode meta-common-mode "MetaPost"
"Major mode for editing MetaPost sources."
;; Set defaults for completion function.
- (set (make-local-variable 'meta-symbol-list) nil)
- (set (make-local-variable 'meta-symbol-changed) nil)
+ (setq-local meta-symbol-list nil)
+ (setq-local meta-symbol-changed nil)
(apply 'meta-add-symbols metapost-symbol-list)
- (set (make-local-variable 'meta-complete-list)
- (list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
- (list "" 'ispell-complete-word))))
-
-
-;;; Just in case ...
+ (setq-local meta-complete-list
+ (list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
+ (list "" 'ispell-complete-word))))
(provide 'meta-mode)
(run-hooks 'meta-mode-load-hook)
diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el
index 394561efb73..59e87b87411 100644
--- a/lisp/progmodes/mixal-mode.el
+++ b/lisp/progmodes/mixal-mode.el
@@ -1,11 +1,11 @@
-;;; mixal-mode.el --- Major mode for the mix asm language.
+;;; mixal-mode.el --- Major mode for the mix asm language. -*- lexical-binding:t -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
;; Author: Pieter E.J. Pareit <pieter.pareit@gmail.com>
-;; Maintainer: emacs-devel@gnu.org
+;; Maintainer: Jose A Ortega Ruiz <jao@gnu.org>
;; Created: 09 Nov 2002
-;; Version: 0.1
+;; Version: 0.4
;; Keywords: languages, Knuth, mix, mixal, asm, mixvm, The Art Of Computer Programming
;; This file is part of GNU Emacs.
@@ -24,6 +24,7 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
+
;; Major mode for the mix asm language.
;; The mix asm language is described in "The Art Of Computer Programming".
;;
@@ -34,8 +35,9 @@
;;
;; To use this mode, place the following in your init file:
;; `(load-file "/PATH-TO-FILE/mixal-mode.el")'.
+;;
;; When you load a file with the extension .mixal the mode will be started
-;; automatic. If you want to start the mode manual, use `M-x mixal-mode'.
+;; automatically. If you want to start the mode manually, use `M-x mixal-mode'.
;; Font locking will work, the behavior of tabs is the same as Emacs's
;; default behavior. You can compile a source file with `C-c c' you can
;; run a compiled file with `C-c r' or run it in debug mode with `C-c d'.
@@ -45,6 +47,9 @@
;; Have fun.
;;; History:
+;; Version 0.4:
+;; 16/10/20: Jose A Ortega Ruiz <jao@gnu.org>
+;; Add missed instructions: SLB,SRB,JAE,JAO,JXE,JXO
;; Version 0.3:
;; 12/10/05: Stefan Monnier <monnier@iro.umontreal.ca>
;; Use font-lock-syntactic-keywords to detect/mark comments.
@@ -683,6 +688,18 @@ Register J is set to the value of the next instruction that would have
been executed when there was no jump."
1)
+ (JAE jump "jump A even" 40
+ "Jump if the content of rA is even.
+Register J is set to the value of the next instruction that would have
+been executed when there was no jump."
+ 1)
+
+ (JAO jump "jump A odd" 40
+ "Jump if the content of rA is odd.
+Register J is set to the value of the next instruction that would have
+been executed when there was no jump."
+ 1)
+
(JXN jump "jump X negative" 47
"Jump if the content of rX is negative.
Register J is set to the value of the next instruction that would have
@@ -719,12 +736,24 @@ Register J is set to the value of the next instruction that would have
been executed when there was no jump."
1)
- (J1N jump "jump I1 negative" 41
- "Jump if the content of rI1 is negative.
+ (JXE jump "jump X even" 47
+ "Jump if the content of rX is even.
+Register J is set to the value of the next instruction that would have
+been executed when there was no jump."
+ 1)
+
+ (JXO jump "jump X odd" 47
+ "Jump if the content of rX is odd.
Register J is set to the value of the next instruction that would have
been executed when there was no jump."
1)
+ (J1N jump "jump I1 negative" 41
+ "Jump if the content of rI1 is negative.
+Register J is set to the value of the next instruction that would have
+been executed when there was no jump."
+ 1)
+
(J1Z jump "jump I1 zero" 41
"Jump if the content of rI1 is zero.
Register J is set to the value of the next instruction that would have
@@ -950,7 +979,6 @@ Zeros will be added to the left."
Zeros will be added to the right."
2)
-
(SRAX miscellaneous "shift right AX" 6
"Shift AX, M bytes right.
Zeros will be added to the left."
@@ -966,6 +994,14 @@ The bytes that fall off to the left will be added to the right."
The bytes that fall off to the right will be added to the left."
2)
+ (SLB miscellaneous "shift left AX binary" 6
+ "Shift AX, M binary places left."
+ 2)
+
+ (SRB miscellaneous "shift right AX binary" 6
+ "Shift AX, M binary places right."
+ 2)
+
(MOVE miscellaneous "move" 7 number
"Move MOD words from M to the location stored in rI1."
(+ 1 (* 2 number)))
@@ -1105,18 +1141,18 @@ Assumes that file has been compiled with debugging support."
;;;###autoload
(define-derived-mode mixal-mode prog-mode "mixal"
"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))
- (set (make-local-variable 'syntax-propertize-function)
- mixal-syntax-propertize-function)
+ (setq-local comment-start "*")
+ (setq-local comment-start-skip "^\\*[ \t]*")
+ (setq-local font-lock-defaults
+ '(mixal-font-lock-keywords))
+ (setq-local 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 "
- (if buffer-file-name
- (shell-quote-argument buffer-file-name)))))
+ ;; (setq-local indent-line-function 'mixal-indent-line)
+ (setq-local compile-command
+ (concat "mixasm "
+ (if buffer-file-name
+ (shell-quote-argument buffer-file-name)))))
(provide 'mixal-mode)
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index aa412304c59..a8d644dba0e 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/progmodes/modula2.el
@@ -1,4 +1,4 @@
-;;; modula2.el --- Modula-2 editing support package
+;;; modula2.el --- Modula-2 editing support package -*- lexical-binding: t -*-
;; Author: Michael Schmidt <michael@pbinfo.UUCP>
;; Tom Perrine <Perrin@LOGICON.ARPA>
@@ -51,62 +51,57 @@
(defcustom m2-compile-command "m2c"
"Command to compile Modula-2 programs."
- :type 'string
- :group 'modula2)
+ :type 'string)
(defcustom m2-link-command "m2l"
"Command to link Modula-2 programs."
- :type 'string
- :group 'modula2)
+ :type 'string)
(defcustom m2-link-name nil
"Name of the Modula-2 executable."
- :type '(choice (const nil) string)
- :group 'modula2)
+ :type '(choice (const nil) string))
(defcustom m2-end-comment-column 75
"Column for aligning the end of a comment, in Modula-2."
- :type 'integer
- :group 'modula2)
+ :type 'integer)
;;; Added by TEP
(defvar m2-mode-map
(let ((map (make-sparse-keymap)))
;; 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)
- (define-key map "\C-ce" 'm2-else)
- (define-key map "\C-cf" 'm2-for)
- (define-key map "\C-ch" 'm2-header)
- (define-key map "\C-ci" 'm2-if)
- (define-key map "\C-cm" 'm2-module)
- (define-key map "\C-cl" 'm2-loop)
- (define-key map "\C-co" 'm2-or)
- (define-key map "\C-cp" 'm2-procedure)
- (define-key map "\C-c\C-w" 'm2-with)
- (define-key map "\C-cr" 'm2-record)
- (define-key map "\C-cs" 'm2-stdio)
- (define-key map "\C-ct" 'm2-type)
- (define-key map "\C-cu" 'm2-until)
- (define-key map "\C-cv" 'm2-var)
- (define-key map "\C-cw" 'm2-while)
- (define-key map "\C-cx" 'm2-export)
- (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-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)
+ (define-key map "\C-cb" #'m2-begin)
+ (define-key map "\C-cc" #'m2-case)
+ (define-key map "\C-cd" #'m2-definition)
+ (define-key map "\C-ce" #'m2-else)
+ (define-key map "\C-cf" #'m2-for)
+ (define-key map "\C-ch" #'m2-header)
+ (define-key map "\C-ci" #'m2-if)
+ (define-key map "\C-cm" #'m2-module)
+ (define-key map "\C-cl" #'m2-loop)
+ (define-key map "\C-co" #'m2-or)
+ (define-key map "\C-cp" #'m2-procedure)
+ (define-key map "\C-c\C-w" #'m2-with)
+ (define-key map "\C-cr" #'m2-record)
+ (define-key map "\C-cs" #'m2-stdio)
+ (define-key map "\C-ct" #'m2-type)
+ (define-key map "\C-cu" #'m2-until)
+ (define-key map "\C-cv" #'m2-var)
+ (define-key map "\C-cw" #'m2-while)
+ (define-key map "\C-cx" #'m2-export)
+ (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-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)
map)
"Keymap used in Modula-2 mode.")
(defcustom m2-indent 5
"This variable gives the indentation in Modula-2 mode."
- :type 'integer
- :group 'modula2)
+ :type 'integer)
(put 'm2-indent 'safe-local-variable
(lambda (v) (or (null v) (integerp v))))
@@ -206,7 +201,10 @@
((zerop (length tok))
(let ((forward-sexp-function nil))
(condition-case nil
- (forward-sexp -1)
+ (let ((p (point)))
+ (forward-sexp -1)
+ (when (= p (point))
+ (setq res ":")))
(scan-error (setq res ":")))))
((member tok '("|" "OF" "..")) (setq res ":-case"))
((member tok '(":" "END" ";" "BEGIN" "VAR" "RECORD" "PROCEDURE"))
@@ -308,14 +306,14 @@ 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."
- (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)
+ (setq-local paragraph-start (concat "$\\|" page-delimiter))
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local paragraph-ignore-fill-prefix t)
+ (setq-local comment-start "(* ")
+ (setq-local comment-end " *)")
+ (setq-local comment-start-skip "\\(?:(\\*+\\|//+\\) *")
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local font-lock-defaults
'((m3-font-lock-keywords
m3-font-lock-keywords-1 m3-font-lock-keywords-2)
nil nil ((?_ . "w") (?. . "w") (?< . ". 1") (?> . ". 4")) nil
diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el
index 81f9aa9a1ad..aff3066c698 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -215,9 +215,15 @@ newline or semicolon after an else or end keyword."
(concat "[^#%\n]*\\(" octave-continuation-marker-regexp
"\\)\\s-*\\(\\s<.*\\)?$"))
-;; Char \ is considered a bad decision for continuing a line.
(defconst octave-continuation-string "..."
- "Character string used for Octave continuation lines.")
+ "Character string used for Octave continuation lines.
+Joins current line with following line, except within
+double-quoted strings, where `octave-string-continuation-marker'
+is used instead.")
+
+(defconst octave-string-continuation-marker "\\"
+ "Line continuation marker for double-quoted Octave strings.
+Non-string statements use `octave-continuation-string'.")
(defvar octave-mode-imenu-generic-expression
(list
@@ -454,7 +460,8 @@ Non-nil means always go to the next Octave code line after sending."
(smie-rule-parent octave-block-offset)
;; For (invalid) code between switch and case.
;; (if (smie-rule-parent-p "switch") 4)
- nil))))
+ nil))
+ ('(:after . "=") (smie-rule-parent octave-block-offset))))
(defun octave-indent-comment ()
"A function for `smie-indent-functions' (which see)."
@@ -485,8 +492,8 @@ Non-nil means always go to the next Octave code line after sending."
'font-lock-keyword-face)
;; Note: 'end' also serves as the last index in an indexing expression,
;; and 'enumerate' is also a function.
- ;; Ref: http://www.mathworks.com/help/matlab/ref/end.html
- ;; Ref: http://www.mathworks.com/help/matlab/ref/enumeration.html
+ ;; Ref: https://www.mathworks.com/help/matlab/ref/end.html
+ ;; Ref: https://www.mathworks.com/help/matlab/ref/enumeration.html
(list (lambda (limit)
(while (re-search-forward "\\_<en\\(?:d\\|umeratio\\(n\\)\\)\\_>"
limit 'move)
@@ -619,10 +626,7 @@ Key bindings:
(add-hook 'before-save-hook 'octave-sync-function-file-names nil t)
(setq-local beginning-of-defun-function 'octave-beginning-of-defun)
(and octave-font-lock-texinfo-comment (octave-font-lock-texinfo-comment))
- (add-function :before-until (local 'eldoc-documentation-function)
- 'octave-eldoc-function)
-
- (easy-menu-add octave-mode-menu))
+ (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t))
(defcustom inferior-octave-program "octave"
@@ -756,7 +760,7 @@ Key bindings:
(setq font-lock-defaults '(inferior-octave-font-lock-keywords nil nil))
(setq-local info-lookup-mode 'octave-mode)
- (setq-local eldoc-documentation-function 'octave-eldoc-function)
+ (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t)
(setq-local comint-input-ring-file-name
(or (getenv "OCTAVE_HISTFILE") "~/.octave_hist"))
@@ -967,8 +971,7 @@ output is passed to the filter `inferior-octave-output-digest'."
(setq list (cdr list)))
(set-process-filter proc filter))))
-(defvar inferior-octave-directory-tracker-resync nil)
-(make-variable-buffer-local 'inferior-octave-directory-tracker-resync)
+(defvar-local inferior-octave-directory-tracker-resync nil)
(defun inferior-octave-directory-tracker (string)
"Tracks `cd' commands issued to the inferior Octave process.
@@ -1036,11 +1039,11 @@ directory and makes this the current buffer's default directory."
(looking-at regexp)))
(defun octave-maybe-insert-continuation-string ()
- (if (or (octave-in-comment-p)
- (save-excursion
- (beginning-of-line)
- (looking-at octave-continuation-regexp)))
- nil
+ (declare (obsolete nil "28.1"))
+ (unless (or (octave-in-comment-p)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at octave-continuation-regexp)))
(delete-horizontal-space)
(insert (concat " " octave-continuation-string))))
@@ -1049,10 +1052,9 @@ directory and makes this the current buffer's default directory."
(save-excursion
(skip-syntax-backward "-(")
(thing-at-point 'symbol)))))
- (completing-read
- (format (if def "Function (default %s): " "Function: ") def)
- (inferior-octave-completion-table)
- nil nil nil nil def)))
+ (completing-read (format-prompt "Function" def)
+ (inferior-octave-completion-table)
+ nil nil nil nil def)))
(defun octave-goto-function-definition (fn)
"Go to the function definition of FN in current buffer."
@@ -1173,10 +1175,7 @@ q: Don't fix\n" func file))
(min (line-end-position 4) end)
t)
(match-string 1))))
- (old-func (read-string (format (if old-func
- "Name to replace (default %s): "
- "Name to replace: ")
- old-func)
+ (old-func (read-string (format-prompt "Name to replace" old-func)
nil nil old-func)))
(if (and func old-func (not (equal func old-func)))
(perform-replace old-func func 'query
@@ -1226,23 +1225,22 @@ q: Don't fix\n" func file))
(defun octave-indent-new-comment-line (&optional soft)
"Break Octave line at point, continuing comment if within one.
Insert `octave-continuation-string' before breaking the line
-unless inside a list. Signal an error if within a single-quoted
-string."
+unless inside a list. If within a double-quoted string, insert
+`octave-string-continuation-marker' instead. Signal an error if
+within a single-quoted string."
(interactive)
(funcall comment-line-break-function soft))
(defun octave--indent-new-comment-line (orig &rest args)
- (cond
- ((octave-in-comment-p) nil)
- ((eq (octave-in-string-p) ?')
- (error "Cannot split a single-quoted string"))
- ((eq (octave-in-string-p) ?\")
- (insert octave-continuation-string))
- (t
- (delete-horizontal-space)
- (unless (and (cadr (syntax-ppss))
- (eq (char-after (cadr (syntax-ppss))) ?\())
- (insert " " octave-continuation-string))))
+ (pcase (syntax-ppss)
+ ((app ppss-string-terminator ?\')
+ (user-error "Cannot split a single-quoted string"))
+ ((app ppss-string-terminator ?\")
+ (insert octave-string-continuation-marker))
+ ((pred (not ppss-comment-depth))
+ (delete-horizontal-space)
+ (unless (octave-smie--in-parens-p)
+ (insert " " octave-continuation-string))))
(apply orig args)
(indent-according-to-mode))
@@ -1455,7 +1453,7 @@ The block marked is the one that contains point or follows point."
Prompt for the function's name, arguments and return values (to be
entered without parens)."
(let* ((defname (file-name-sans-extension (buffer-name)))
- (name (read-string (format "Function name (default %s): " defname)
+ (name (read-string (format-prompt "Function name" defname)
nil nil defname))
(args (read-string "Arguments: "))
(vals (read-string "Return values: ")))
@@ -1519,28 +1517,13 @@ current buffer file unless called with a prefix arg \\[universal-argument]."
(interactive "r")
(inferior-octave t)
(let ((proc inferior-octave-process)
- (string (buffer-substring-no-properties beg end))
- line)
+ (string (buffer-substring-no-properties beg end)))
(with-current-buffer inferior-octave-buffer
;; https://lists.gnu.org/r/emacs-devel/2013-10/msg00095.html
(compilation-forget-errors)
- (setq inferior-octave-output-list nil)
- (while (not (string-equal string ""))
- (if (string-match "\n" string)
- (setq line (substring string 0 (match-beginning 0))
- string (substring string (match-end 0)))
- (setq line string string ""))
- (setq inferior-octave-receive-in-progress t)
- (inferior-octave-send-list-and-digest (list (concat line "\n")))
- (while inferior-octave-receive-in-progress
- (accept-process-output proc))
- (insert-before-markers
- (mapconcat 'identity
- (append
- (if octave-send-echo-input (list line) (list ""))
- inferior-octave-output-list
- (list inferior-octave-output-string))
- "\n")))))
+ (insert-before-markers string "\n")
+ (comint-send-string proc (concat string "\n")))
+ (deactivate-mark))
(if octave-send-show-buffer
(display-buffer inferior-octave-buffer)))
@@ -1612,8 +1595,9 @@ code line."
(defun octave-eldoc-function-signatures (fn)
(unless (equal fn (car octave-eldoc-cache))
- (inferior-octave-send-list-and-digest
- (list (format "print_usage ('%s');\n" fn)))
+ (while-no-input
+ (inferior-octave-send-list-and-digest
+ (list (format "print_usage ('%s');\n" fn))))
(let (result)
(dolist (line inferior-octave-output-list)
;; The help output has changed a few times in GNU Octave.
@@ -1640,8 +1624,8 @@ code line."
(nreverse result)))))
(cdr octave-eldoc-cache))
-(defun octave-eldoc-function ()
- "A function for `eldoc-documentation-function' (which see)."
+(defun octave-eldoc-function (&rest _ignored)
+ "A function for `eldoc-documentation-functions' (which see)."
(when (inferior-octave-process-live-p)
(let* ((ppss (syntax-ppss))
(paren-pos (cadr ppss))
@@ -1685,9 +1669,7 @@ code line."
(define-button-type 'octave-help-function
'follow-link t
- 'action (lambda (b)
- (octave-help
- (buffer-substring (button-start b) (button-end b)))))
+ 'action (lambda (b) (octave-help (button-label b))))
(defvar octave-help-mode-map
(let ((map (make-sparse-keymap)))
@@ -1788,8 +1770,8 @@ sentence."
(insert "\nRetry with ")
(insert-text-button "'-all'"
'follow-link t
- 'action #'(lambda (_b)
- (octave-lookfor str '-all)))
+ 'action (lambda (_b)
+ (octave-lookfor str '-all)))
(insert ".\n"))
(octave-help-mode)))))
diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el
index bed3687d0cc..662d2b4b74f 100644
--- a/lisp/progmodes/opascal.el
+++ b/lisp/progmodes/opascal.el
@@ -1688,7 +1688,7 @@ comment block. If not in a // comment, just does a normal newline."
;; as comment starters. Fix it here by removing the "2" from the syntax
;; of the second char of such sequences.
("/\\(\\*\\)" (1 ". 3b"))
- ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil)))
+ ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil)))
;; Pascal uses '' and "" rather than \' and \" to escape quotes.
("''\\|\"\"" (0 (if (save-excursion
(nth 3 (syntax-ppss (match-beginning 0))))
diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el
index 3059113be76..e6e6e40aa19 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -187,7 +187,7 @@
;; as comment starters. Fix it here by removing the "2" from the syntax
;; of the second char of such sequences.
("/\\(\\*\\)" (1 ". 3b"))
- ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil)))
+ ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil)))
;; Pascal uses '' and "" rather than \' and \" to escape quotes.
("''\\|\"\"" (0 (if (save-excursion
(nth 3 (syntax-ppss (match-beginning 0))))
@@ -199,38 +199,32 @@
(defcustom pascal-indent-level 3
"Indentation of Pascal statements with respect to containing block."
- :type 'integer
- :group 'pascal)
+ :type 'integer)
(defcustom pascal-case-indent 2
"Indentation for case statements."
- :type 'integer
- :group 'pascal)
+ :type 'integer)
(defcustom pascal-auto-newline nil
"Non-nil means automatically insert newlines in certain cases.
These include after semicolons and after the punctuation mark after an `end'."
- :type 'boolean
- :group 'pascal)
+ :type 'boolean)
(defcustom pascal-indent-nested-functions t
"Non-nil means nested functions are indented."
- :type 'boolean
- :group 'pascal)
+ :type 'boolean)
(defcustom pascal-tab-always-indent t
"Non-nil means TAB in Pascal mode should always reindent the current line.
If this is nil, TAB inserts a tab if it is at the end of the line
and follows non-whitespace text."
- :type 'boolean
- :group 'pascal)
+ :type 'boolean)
(defcustom pascal-auto-endcomments t
"Non-nil means automatically insert comments after certain `end's.
Specifically, this is done after the ends of case statements and functions.
The name of the function or case is included between the braces."
- :type 'boolean
- :group 'pascal)
+ :type 'boolean)
(defcustom pascal-auto-lineup '(all)
"List of contexts where auto lineup of :'s or ='s should be done.
@@ -243,8 +237,7 @@ will do all lineups."
(const :tag "Everything" all)
(const :tag "Parameter lists" paramlist)
(const :tag "Declarations" declaration)
- (const :tag "Case statements" case))
- :group 'pascal)
+ (const :tag "Case statements" case)))
(defvar pascal-toggle-completions nil
"If non-nil, `pascal-complete-word' tries all possible completions.
@@ -260,8 +253,7 @@ completions.")
These include integer, real, char, etc.
The types defined within the Pascal program
are handled in another way, and should not be added to this list."
- :type '(repeat (string :tag "Keyword"))
- :group 'pascal)
+ :type '(repeat (string :tag "Keyword")))
(defcustom pascal-start-keywords
'("begin" "end" "function" "procedure" "repeat" "until" "while"
@@ -270,8 +262,7 @@ are handled in another way, and should not be added to this list."
These are keywords such as begin, repeat, until, readln.
The procedures and variables defined within the Pascal program
are handled in another way, and should not be added to this list."
- :type '(repeat (string :tag "Keyword"))
- :group 'pascal)
+ :type '(repeat (string :tag "Keyword")))
(defcustom pascal-separator-keywords
'("downto" "else" "mod" "div" "then")
@@ -279,8 +270,7 @@ are handled in another way, and should not be added to this list."
These are keywords such as downto, else, mod, then.
Variables and function names defined within the Pascal program
are handled in another way, and should not be added to this list."
- :type '(repeat (string :tag "Keyword"))
- :group 'pascal)
+ :type '(repeat (string :tag "Keyword")))
;;;
@@ -589,7 +579,7 @@ See also `pascal-comment-area'."
(interactive)
(catch 'found
(if (not (looking-at (concat "\\s \\|\\s)\\|" pascal-defun-re)))
- (forward-sexp 1))
+ (ignore-errors (forward-sexp 1)))
(let ((nest 0) (max -1) (func 0)
(reg (concat pascal-beg-block-re "\\|"
pascal-end-block-re "\\|"
@@ -1170,26 +1160,27 @@ indent of the current line in parameterlist."
(defun pascal-type-completion (pascal-str)
"Calculate all possible completions for types."
- (let ((start (point))
- (pascal-all ())
- goon)
- ;; Search for all reachable type declarations
- (while (or (pascal-beg-of-defun)
- (setq goon (not goon)))
- (save-excursion
- (if (and (< start (prog1 (save-excursion (pascal-end-of-defun)
- (point))
- (forward-char 1)))
- (re-search-forward
- "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>"
- start t)
- (not (match-end 1)))
- ;; Check current type declaration
- (setq pascal-all
- (nconc (pascal-get-completion-decl pascal-str)
- pascal-all)))))
+ (save-excursion
+ (let ((start (point))
+ (pascal-all ())
+ goon)
+ ;; Search for all reachable type declarations
+ (while (or (pascal-beg-of-defun)
+ (setq goon (not goon)))
+ (save-excursion
+ (if (and (< start (prog1 (save-excursion (pascal-end-of-defun)
+ (point))
+ (forward-char 1)))
+ (re-search-forward
+ "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>"
+ start t)
+ (not (match-end 1)))
+ ;; Check current type declaration
+ (setq pascal-all
+ (nconc (pascal-get-completion-decl pascal-str)
+ pascal-all)))))
- pascal-all))
+ pascal-all)))
(defun pascal-var-completion (prefix)
"Calculate all possible completions for variables (or constants)."
@@ -1263,11 +1254,13 @@ indent of the current line in parameterlist."
(and (eq state 'defun)
(save-excursion
(re-search-backward ")[ \t]*:" (point-at-bol) t))))
- (if (or (eq state 'paramlist) (eq state 'defun))
- (pascal-beg-of-defun))
- (nconc
- (pascal-type-completion pascal-str)
- (pascal-keyword-completion pascal-type-keywords pascal-str)))
+ (save-excursion
+ (if (or (eq state 'paramlist) (eq state 'defun))
+ (pascal-beg-of-defun))
+ (nconc
+ (pascal-type-completion pascal-str)
+ (pascal-keyword-completion pascal-type-keywords
+ pascal-str))))
( ;--Starting a new statement
(and (not (eq state 'contexp))
(save-excursion
@@ -1392,7 +1385,7 @@ The default is a name found in the buffer around point."
(defvar pascal-outline-map
(let ((map (make-sparse-keymap)))
(if (fboundp 'set-keymap-name)
- (set-keymap-name pascal-outline-map 'pascal-outline-map))
+ (set-keymap-name map 'pascal-outline-map))
(define-key map "\M-\C-a" 'pascal-outline-prev-defun)
(define-key map "\M-\C-e" 'pascal-outline-next-defun)
(define-key map "\C-c\C-d" 'pascal-outline-goto-defun)
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 378a7fd8503..f49ee4cb2b5 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -95,6 +95,11 @@
:prefix "perl-"
:group 'languages)
+(defface perl-non-scalar-variable
+ '((t :inherit font-lock-variable-name-face :underline t))
+ "Face used for non-scalar variables."
+ :version "28.1")
+
(defvar perl-mode-abbrev-table nil
"Abbrev table in use in perl-mode buffers.")
(define-abbrev-table 'perl-mode-abbrev-table ())
@@ -137,7 +142,7 @@
'(;; Functions
(nil "^[ \t]*sub\\s-+\\([-[:alnum:]+_:]+\\)" 1)
;;Variables
- ("Variables" "^[ \t]*\\(?:anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1)
+ ("Variables" "^[ \t]*\\(?:has\\|local\\|my\\|our\\|state\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1)
("Packages" "^[ \t]*package\\s-+\\([-[:alnum:]+_:]+\\);" 1)
("Doc sections" "^=head[0-9][ \t]+\\(.*\\)" 1))
"Imenu generic expression for Perl mode. See `imenu-generic-expression'.")
@@ -165,9 +170,9 @@
;; (1 font-lock-constant-face) (2 font-lock-variable-name-face nil t))
;;
;; Fontify function and package names in declarations.
- ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\sw+\\)?"
+ ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\(?:\\sw\\|::\\)+\\)?"
(1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
- ("\\(^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?"
+ ("\\(?:^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\(?:\\sw\\|::\\)+\\)?"
(1 font-lock-keyword-face) (2 font-lock-constant-face nil t)))
"Subdued level highlighting for Perl mode.")
@@ -182,16 +187,16 @@
"\\>")
;;
;; Fontify declarators and prefixes as types.
- ("\\<\\(anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\>" . font-lock-type-face) ; declarators
- ("\\<\\(let\\|temp\\)\\>" . font-lock-type-face) ; prefixes
- ;;
+ ("\\<\\(has\\|local\\|my\\|our\\|state\\)\\>" . font-lock-keyword-face) ; declarators
+ ;;
;; Fontify function, variable and file name references.
("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face)
- ;; Additionally underline non-scalar variables. Maybe this is a bad idea.
+ ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable'
+ ;; will underline them by default.
;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face)
("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face)
("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)"
- (2 (cons font-lock-variable-name-face '(underline))))
+ (2 'perl-non-scalar-variable))
("<\\(\\sw+\\)>" 1 font-lock-constant-face)
;;
;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'.
@@ -209,12 +214,14 @@
(eval-and-compile
(defconst perl--syntax-exp-intro-keywords
'("split" "if" "unless" "until" "while" "print"
- "grep" "map" "not" "or" "and" "for" "foreach"))
+ "grep" "map" "not" "or" "and" "for" "foreach" "return"))
(defconst perl--syntax-exp-intro-regexp
(concat "\\(?:\\(?:^\\|[^$@&%[:word:]]\\)"
(regexp-opt perl--syntax-exp-intro-keywords)
- "\\|[-?:.,;|&+*=!~({[]\\|\\(^\\)\\)[ \t\n]*")))
+ "\\|[?:.,;|&*=!~({[]"
+ "\\|[^-+][-+]" ;Bug#42168: `+' is intro but `++' isn't!
+ "\\|\\(^\\)\\)[ \t\n]*")))
(defun perl-syntax-propertize-function (start end)
(let ((case-fold-search nil))
@@ -235,7 +242,7 @@
(match-beginning 0))))))
(string-to-syntax ". p"))))
;; Handle funny names like $DB'stop.
- ("\\$ ?{?^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_"))
+ ("\\$ ?{?\\^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_"))
;; format statements
("^[ \t]*format.*=[ \t]*\\(\n\\)"
(1 (prog1 "\"" (perl-syntax-propertize-special-constructs end))))
@@ -256,7 +263,7 @@
;; (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
+ ;; *opening* slash. We can afford to mismatch the closing ones
;; here, because they will be re-treated separately later in
;; perl-font-lock-special-syntactic-constructs.
((concat perl--syntax-exp-intro-regexp "\\(/\\)")
@@ -278,7 +285,7 @@
(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]\\)\\|\\(?3:=\\)[^>]\\)"
+ ("\\(^\\|[?:.,;=|&!~({[ \t]\\|=>\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\(?:\\s-\\|\n\\)*\\(?:\\([^])}>= \n\t]\\)\\|\\(?3:=\\)[^>]\\)"
;; Nasty cases:
;; /foo/m $a->m $#m $m @m %m
;; \s (appears often in regexps).
@@ -297,12 +304,21 @@
;; $a = "foo y \"toto\" bar" where we'd end up changing the
;; syntax of the backslash and hence de-escaping the embedded
;; double quote.
- (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 "\"")))
+ (let* ((b3 (match-beginning 3))
+ (c (char-after b3)))
+ (put-text-property
+ b3 (match-end 3) 'syntax-table
+ (cond
+ ((assoc c perl-quote-like-pairs)
+ (string-to-syntax "|"))
+ ;; If the separator is a normal quote and the operation
+ ;; only takes a single arg, then there's nothing
+ ;; special to do.
+ ((and (memq c '(?\" ?\'))
+ (memq (char-after (match-beginning 2)) '(?m ?q)))
+ nil)
+ (t
+ (string-to-syntax "\"")))))
(perl-syntax-propertize-special-constructs end))))))
;; Here documents.
((concat
@@ -313,13 +329,33 @@
;; disambiguate with the left-bitshift operator.
"\\|" perl--syntax-exp-intro-regexp "<<\\(?2:\\sw+\\)\\)"
".*\\(\n\\)")
- (4 (let* ((st (get-text-property (match-beginning 4) 'syntax-table))
+ (4 (let* ((eol (match-beginning 4))
+ (st (get-text-property eol 'syntax-table))
(name (match-string 2))
(indented (match-beginning 1)))
(goto-char (match-end 2))
(if (save-excursion (nth 8 (syntax-ppss (match-beginning 0))))
+ ;; '<<' occurred in a string, or in a comment.
;; Leave the property of the newline unchanged.
st
+ ;; Beware of `foo <<'BAR' #baz` because
+ ;; the newline needs to start the here-doc
+ ;; and can't be used to close the comment.
+ (let ((eol-state (save-excursion (syntax-ppss eol))))
+ (when (nth 4 eol-state)
+ (if (/= (1- eol) (nth 8 eol-state))
+ ;; make the last char of the comment closing it
+ (put-text-property (1- eol) eol
+ 'syntax-table (string-to-syntax ">"))
+ ;; In `foo <<'BAR' #` the # is the last character
+ ;; before eol and can't both open and close the
+ ;; comment. Workaround: disguise the "#" as
+ ;; whitespace and fontify it as a comment.
+ (put-text-property (1- eol) eol
+ 'syntax-table (string-to-syntax "-"))
+ (put-text-property (1- eol) eol
+ 'font-lock-face
+ 'font-lock-comment-face))))
(cons (car (string-to-syntax "< c"))
;; Remember the names of heredocs found on this line.
(cons (cons (pcase (aref name 0)
@@ -377,7 +413,8 @@
(put-text-property (1- (point)) (point) 'syntax-table
(string-to-syntax "> c"))))))
((or (null (setq char (nth 3 state)))
- (and (characterp char) (eq (char-syntax (nth 3 state)) ?\")))
+ (and (characterp char)
+ (null (get-text-property (nth 8 state) 'syntax-table))))
;; Normal text, or comment, or docstring, or normal string.
nil)
((eq (nth 3 state) ?\n)
@@ -398,6 +435,7 @@
(point)))
'("tr" "s" "y"))))
(close (cdr (assq char perl-quote-like-pairs)))
+ (middle nil)
(st (perl-quote-syntax-table char)))
(when (with-syntax-table st
(if close
@@ -428,6 +466,7 @@
;; In the case of s{...}{...}, we only handle the
;; first part here and the next below.
(when (and twoargs (not close))
+ (setq middle (point))
(nth 8 (parse-partial-sexp
(point) limit
nil nil state 'syntax-table)))))))
@@ -435,11 +474,14 @@
(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 (and middle (memq char '(?\" ?\')))
+ (put-text-property (1- middle) middle
+ '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.
@@ -466,8 +508,15 @@
;; as twoarg).
(perl-syntax-propertize-special-constructs limit)))))))))
+(defface perl-heredoc
+ '((t (:inherit font-lock-string-face)))
+ "The face for here-documents. Inherits from font-lock-string-face.")
+
(defun perl-font-lock-syntactic-face-function (state)
(cond
+ ((and (eq 2 (nth 7 state)) ; c-style comment
+ (cdr-safe (get-text-property (nth 8 state) 'syntax-table))) ; HERE doc
+ 'perl-heredoc)
((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
@@ -590,7 +639,6 @@ This is a non empty list of strings, the checker tool possibly
followed by required arguments. Once launched it will receive
the Perl source to be checked as its standard input."
:version "26.1"
- :group 'perl
:type '(repeat string))
(defvar-local perl--flymake-proc nil)
diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el
index d88d3505586..19de7545bf3 100644
--- a/lisp/progmodes/prog-mode.el
+++ b/lisp/progmodes/prog-mode.el
@@ -41,8 +41,7 @@
:type 'hook
:options '(flyspell-prog-mode abbrev-mode flymake-mode
display-line-numbers-mode
- prettify-symbols-mode)
- :group 'prog-mode)
+ prettify-symbols-mode))
(defvar prog-mode-map
(let ((map (make-sparse-keymap)))
@@ -166,8 +165,7 @@ on the symbol."
:version "25.1"
:type '(choice (const :tag "Never unprettify" nil)
(const :tag "Unprettify when point is inside" t)
- (const :tag "Unprettify when point is inside or at right edge" right-edge))
- :group 'prog-mode)
+ (const :tag "Unprettify when point is inside or at right edge" right-edge)))
(defun prettify-symbols--post-command-hook ()
(cl-labels ((get-prop-as-list
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index ca0755cf8cd..0e732864268 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,6 +1,11 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
+;; Version: 0.6.0
+;; Package-Requires: ((emacs "26.1") (xref "1.0.2"))
+
+;; This is a GNU ELPA :core package. Avoid using functionality that
+;; not compatible with the version of Emacs recorded above.
;; This file is part of GNU Emacs.
@@ -19,6 +24,11 @@
;;; Commentary:
+;; NOTE: The project API is still experimental and can change in major,
+;; backward-incompatible ways. Everyone is encouraged to try it, and
+;; report to us any problems or use cases we hadn't anticipated, by
+;; sending an email to emacs-devel, or `M-x report-emacs-bug'.
+;;
;; This file contains generic infrastructure for dealing with
;; projects, some utility functions, and commands using that
;; infrastructure.
@@ -27,27 +37,83 @@
;; current project, without having to know which package handles
;; detection of that project type, parsing its config files, etc.
;;
-;; NOTE: The project API is still experimental and can change in major,
-;; backward-incompatible ways. Everyone is encouraged to try it, and
-;; report to us any problems or use cases we hadn't anticipated, by
-;; sending an email to emacs-devel, or `M-x report-emacs-bug'.
+;; This file consists of following parts:
+;;
+;; Infrastructure (the public API):
+;;
+;; Function `project-current' that returns the current project
+;; instance based on the value of the hook `project-find-functions',
+;; and several generic functions that act on it.
+;;
+;; `project-root' must be defined for every project.
+;; `project-files' can be overridden for performance purposes.
+;; `project-ignores' and `project-external-roots' describe the project
+;; files and its relations to external directories. `project-files'
+;; should be consistent with `project-ignores'.
+;;
+;; This list can change in future versions.
;;
-;; Infrastructure:
+;; VC project:
;;
-;; Function `project-current', to determine the current project
-;; instance, and 5 (at the moment) generic functions that act on it.
-;; This list is to be extended in future versions.
+;; Originally conceived as an example implementation, now it's a
+;; relatively fast backend that delegates to 'git ls-files' or 'hg
+;; status' to list the project's files. It honors the VC ignore
+;; files, but supports additions to the list using the user option
+;; `project-vc-ignores' (usually through .dir-locals.el).
;;
;; Utils:
;;
;; `project-combine-directories' and `project-subtract-directories',
;; mainly for use in the abovementioned generics' implementations.
;;
+;; `project-known-project-roots' and `project-remember-project' to
+;; interact with the "known projects" list.
+;;
;; Commands:
;;
-;; `project-find-file', `project-find-regexp' and
-;; `project-or-external-find-regexp' use the current API, and thus
-;; will work in any project that has an adapter.
+;; `project-prefix-map' contains the full list of commands defined in
+;; this package. This map uses the prefix `C-x p' by default.
+;; Type `C-x p f' to find file in the current project.
+;; Type `C-x p C-h' to see all available commands and bindings.
+;;
+;; All commands defined in this package are implemented using the
+;; public API only. As a result, they will work with any project
+;; backend that follows the protocol.
+;;
+;; Any third-party code that wants to use this package should likewise
+;; target the public API. Use any of the built-in commands as the
+;; example.
+;;
+;; How to create a new backend:
+;;
+;; - Consider whether you really should, or whether there are other
+;; ways to reach your goals. If the backend's performance is
+;; significantly lower than that of the built-in one, and it's first
+;; in the list, it will affect all commands that use it. Unless you
+;; are going to be using it only yourself or in special circumstances,
+;; you will probably want it to be fast, and it's unlikely to be a
+;; trivial endeavor. `project-files' is the method to optimize (the
+;; default implementation gets slower the more files the directory
+;; has, and the longer the list of ignores is).
+;;
+;; - Choose the format of the value that represents a project for your
+;; backend (we call it project instance). Don't use any of the
+;; formats from other backends. The format can be arbitrary, as long
+;; as the datatype is something `cl-defmethod' can dispatch on. The
+;; value should be stable (when compared with `equal') across
+;; invocations, meaning calls to that function from buffers belonging
+;; to the same project should return equal values.
+;;
+;; - Write a new function that will determine the current project
+;; based on the directory and add it to `project-find-functions'
+;; (which see) using `add-hook'. It is a good idea to depend on the
+;; directory only, and not on the current major mode, for example.
+;; Because the usual expectation is that all files in the directory
+;; belong to the same project (even if some/most of them are ignored).
+;;
+;; - Define new methods for some or all generic functions for this
+;; backend using `cl-defmethod'. A `project-root' method is
+;; mandatory, `project-files' is recommended, the rest are optional.
;;; TODO:
@@ -72,9 +138,7 @@
;; whole Emacs session, independent of the current directory. Or,
;; in the more advanced case, open a set of projects, and have some
;; project-related commands to use them all. E.g., have a command
-;; to search for a regexp across all open projects. Provide a
-;; history of projects that were opened in the past (storing it as a
-;; list of directories should suffice).
+;; to search for a regexp across all open projects.
;;
;; * Support for project-local variables: a UI to edit them, and a
;; utility function to retrieve a value. Probably useless without
@@ -88,43 +152,89 @@
;;; Code:
(require 'cl-generic)
+(require 'seq)
+(eval-when-compile (require 'subr-x))
+
+(defgroup project nil
+ "Operations on the current project."
+ :version "28.1"
+ :group 'tools)
(defvar project-find-functions (list #'project-try-vc)
"Special hook to find the project containing a given directory.
Each functions on this hook is called in turn with one
-argument (the directory) and should return either nil to mean
-that it is not applicable, or a project instance.")
+argument, the directory in which to look, and should return
+either nil to mean that it is not applicable, or a project instance.
+The exact form of the project instance is up to each respective
+function; the only practical limitation is to use values that
+`cl-defmethod' can dispatch on, like a cons cell, or a list, or a
+CL struct.")
+
+(defvar project-current-inhibit-prompt nil
+ "Non-nil to skip prompting the user in `project-current'.")
;;;###autoload
-(defun project-current (&optional maybe-prompt dir)
- "Return the project instance in DIR or `default-directory'.
-When no project found in DIR, and MAYBE-PROMPT is non-nil, ask
-the user for a different directory to look in. If that directory
-is not a part of a detectable project either, return a
-`transient' project instance rooted in it."
- (unless dir (setq dir default-directory))
- (let ((pr (project--find-in-directory dir)))
+(defun project-current (&optional maybe-prompt directory)
+ "Return the project instance in DIRECTORY, defaulting to `default-directory'.
+
+When no project is found in that directory, the result depends on
+the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
+else ask the user for a directory in which to look for the
+project, and if no project is found there, return a \"transient\"
+project instance.
+
+The \"transient\" project instance is a special kind of value
+which denotes a project rooted in that directory and includes all
+the files under the directory except for those that should be
+ignored (per `project-ignores').
+
+See the doc string of `project-find-functions' for the general form
+of the project instance object."
+ (unless directory (setq directory default-directory))
+ (let ((pr (project--find-in-directory directory)))
(cond
(pr)
- (maybe-prompt
- (setq dir (read-directory-name "Choose the project directory: " dir nil t)
- pr (project--find-in-directory dir))
- (unless pr
- (message "Using `%s' as a transient project root" dir)
- (setq pr (cons 'transient dir)))))
+ ((unless project-current-inhibit-prompt
+ maybe-prompt)
+ (setq directory (project-prompt-project-dir)
+ pr (project--find-in-directory directory))))
+ (when maybe-prompt
+ (if pr
+ (project-remember-project pr)
+ (project--remove-from-project-list
+ directory "Project `%s' not found; removed from list")
+ (setq pr (cons 'transient directory))))
pr))
(defun project--find-in-directory (dir)
(run-hook-with-args-until-success 'project-find-functions dir))
-(cl-defgeneric project-roots (project)
- "Return the list of directory roots of the current project.
+(defvar project--within-roots-fallback nil)
+
+(cl-defgeneric project-root (project)
+ "Return root directory of the current project.
+
+It usually contains the main build file, dependencies
+configuration file, etc. Though neither is mandatory.
-Most often it's just one directory which contains the project
-build file and everything else in the project. But in more
-advanced configurations, a project can span multiple directories.
+The directory name must be absolute.")
-The directory names should be absolute.")
+(cl-defmethod project-root (project
+ &context (project--within-roots-fallback
+ (eql nil)))
+ (car (project-roots project)))
+
+(cl-defgeneric project-roots (project)
+ "Return the list containing the current project root.
+
+The function is obsolete, all projects have one main root anyway,
+and the rest should be possible to express through
+`project-external-roots'."
+ ;; FIXME: Can we specify project's version here?
+ ;; FIXME: Could we make this affect cl-defmethod calls too?
+ (declare (obsolete project-root "0.3.0"))
+ (let ((project--within-roots-fallback t))
+ (list (project-root project))))
;; FIXME: Add MODE argument, like in `ede-source-paths'?
(cl-defgeneric project-external-roots (_project)
@@ -133,18 +243,14 @@ The directory names should be absolute.")
It's the list of directories outside of the project that are
still related to it. If the project deals with source code then,
depending on the languages used, this list should include the
-headers search path, load path, class path, and so on.
-
-The rule of thumb for whether to include a directory here, and
-not in `project-roots', is whether its contents are meant to be
-edited together with the rest of the project."
+headers search path, load path, class path, and so on."
nil)
(cl-defgeneric project-ignores (_project _dir)
"Return the list of glob patterns to ignore inside DIR.
Patterns can match both regular files and directories.
To root an entry, start it with `./'. To match directories only,
-end it with `/'. DIR must be one of `project-roots' or
+end it with `/'. DIR must be either `project-root' or one of
`project-external-roots'."
;; TODO: Document and support regexp ignores as used by Hg.
;; TODO: Support whitelist entries.
@@ -165,21 +271,22 @@ end it with `/'. DIR must be one of `project-roots' or
(t
(complete-with-action action all-files string pred)))))
-(cl-defmethod project-roots ((project (head transient)))
- (list (cdr project)))
+(cl-defmethod project-root ((project (head transient)))
+ (cdr project))
(cl-defgeneric project-files (project &optional dirs)
"Return a list of files in directories DIRS in PROJECT.
DIRS is a list of absolute directories; it should be some
-subset of the project roots and external roots.
+subset of the project root and external roots.
The default implementation uses `find-program'. PROJECT is used
to find the list of ignores for each directory."
- (cl-mapcan
+ (mapcan
(lambda (dir)
(project--files-in-directory dir
(project--dir-ignores project dir)))
- (or dirs (project-roots project))))
+ (or dirs
+ (list (project-root project)))))
(defun project--files-in-directory (dir ignores &optional files)
(require 'find-dired)
@@ -189,10 +296,11 @@ to find the list of ignores for each directory."
;; Make sure ~/ etc. in local directory name is
;; expanded and not left for the shell command
;; to interpret.
- (localdir (file-local-name (expand-file-name dir)))
- (command (format "%s %s %s -type f %s -print0"
+ (localdir (file-name-unquote (file-local-name (expand-file-name dir))))
+ (command (format "%s -H %s %s -type f %s -print0"
find-program
- localdir
+ (shell-quote-argument
+ (directory-file-name localdir)) ; Bug#48471
(xref--find-ignores-arguments ignores localdir)
(if files
(concat (shell-quote-argument "(")
@@ -202,30 +310,49 @@ to find the list of ignores for each directory."
(split-string files)
(concat " -o " find-name-arg " "))
" "
- (shell-quote-argument ")"))"")
- )))
+ (shell-quote-argument ")"))
+ "")))
+ (output (with-output-to-string
+ (with-current-buffer standard-output
+ (let ((status
+ (process-file-shell-command command nil t)))
+ (unless (zerop status)
+ (error "File listing failed: %s" (buffer-string))))))))
(project--remote-file-names
- (sort (split-string (shell-command-to-string command) "\0" t)
+ (sort (split-string output "\0" t)
#'string<))))
(defun project--remote-file-names (local-files)
- "Return LOCAL-FILES as if they were on the system of `default-directory'."
+ "Return LOCAL-FILES as if they were on the system of `default-directory'.
+Also quote LOCAL-FILES if `default-directory' is quoted."
(let ((remote-id (file-remote-p default-directory)))
(if (not remote-id)
- local-files
+ (if (file-name-quoted-p default-directory)
+ (mapcar #'file-name-quote local-files)
+ local-files)
(mapcar (lambda (file)
(concat remote-id file))
local-files))))
(defgroup project-vc nil
- "Project implementation using the VC package."
+ "Project implementation based on the VC package."
:version "25.1"
- :group 'tools)
+ :group 'project)
(defcustom project-vc-ignores nil
- "List of patterns to include in `project-ignores'."
+ "List of patterns to add to `project-ignores'."
:type '(repeat string)
- :safe 'listp)
+ :safe #'listp)
+
+(defcustom project-vc-merge-submodules t
+ "Non-nil to consider submodules part of the parent project.
+
+After changing this variable (using Customize or .dir-locals.el)
+you might have to restart Emacs to see the effect."
+ :type 'boolean
+ :version "28.1"
+ :package-version '(project . "0.2.0")
+ :safe #'booleanp)
;; FIXME: Using the current approach, major modes are supposed to set
;; this variable to a buffer-local value. So we don't have access to
@@ -263,20 +390,56 @@ The directory names should be absolute. Used in the VC project
backend implementation of `project-external-roots'.")
(defun project-try-vc (dir)
- (let* ((backend (ignore-errors (vc-responsible-backend dir)))
+ (let* ((backend
+ ;; FIXME: This is slow. Cache it.
+ (ignore-errors (vc-responsible-backend dir)))
(root
(pcase backend
('Git
;; Don't stop at submodule boundary.
+ ;; FIXME: Cache for a shorter time.
(or (vc-file-getprop dir 'project-git-root)
- (vc-file-setprop dir 'project-git-root
- (vc-find-root dir ".git/"))))
+ (let ((root (vc-call-backend backend 'root dir)))
+ (vc-file-setprop
+ dir 'project-git-root
+ (if (and
+ ;; FIXME: Invalidate the cache when the value
+ ;; of this variable changes.
+ (project--vc-merge-submodules-p root)
+ (project--submodule-p root))
+ (let* ((parent (file-name-directory
+ (directory-file-name root))))
+ (vc-call-backend backend 'root parent))
+ root)))))
('nil nil)
(_ (ignore-errors (vc-call-backend backend 'root dir))))))
(and root (cons 'vc root))))
-(cl-defmethod project-roots ((project (head vc)))
- (list (cdr project)))
+(defun project--submodule-p (root)
+ ;; XXX: We only support Git submodules for now.
+ ;;
+ ;; For submodules, at least, we expect the users to prefer them to
+ ;; be considered part of the parent project. For those who don't,
+ ;; there is the custom var now.
+ ;;
+ ;; Some users may also set up things equivalent to Git submodules
+ ;; using "git worktree" (for example). However, we expect that most
+ ;; of them would prefer to treat those as separate projects anyway.
+ (let* ((gitfile (expand-file-name ".git" root)))
+ (cond
+ ((file-directory-p gitfile)
+ nil)
+ ((with-temp-buffer
+ (insert-file-contents gitfile)
+ (goto-char (point-min))
+ ;; Kind of a hack to distinguish a submodule from
+ ;; other cases of .git files pointing elsewhere.
+ (looking-at "gitdir: [./]+/\\.git/modules/"))
+ t)
+ (t nil))))
+
+(cl-defmethod project-root ((project (head vc)))
+ (cdr project))
(cl-defmethod project-external-roots ((project (head vc)))
(project-subtract-directories
@@ -284,25 +447,27 @@ backend implementation of `project-external-roots'.")
(mapcar
#'file-name-as-directory
(funcall project-vc-external-roots-function)))
- (project-roots project)))
+ (list (project-root project))))
(cl-defmethod project-files ((project (head vc)) &optional dirs)
- (cl-mapcan
+ (mapcan
(lambda (dir)
- (let (backend)
+ (let ((ignores (project--value-in-dir 'project-vc-ignores dir))
+ backend)
(if (and (file-equal-p dir (cdr project))
(setq backend (vc-responsible-backend dir))
(cond
((eq backend 'Hg))
((and (eq backend 'Git)
(or
- (not project-vc-ignores)
+ (not ignores)
(version<= "1.9" (vc-git--program-version)))))))
- (project--vc-list-files dir backend project-vc-ignores)
+ (project--vc-list-files dir backend ignores)
(project--files-in-directory
dir
(project--dir-ignores project dir)))))
- (or dirs (project-roots project))))
+ (or dirs
+ (list (project-root project)))))
(declare-function vc-git--program-version "vc-git")
(declare-function vc-git--run-command-string "vc-git")
@@ -321,9 +486,26 @@ backend implementation of `project-external-roots'.")
(cons "--"
(mapcar
(lambda (i)
- (if (string-match "\\./" i)
- (format ":!/:%s" (substring i 2))
- (format ":!:%s" i)))
+ (format
+ ":(exclude,glob,top)%s"
+ (if (string-match "\\*\\*" i)
+ ;; Looks like pathspec glob
+ ;; format already.
+ i
+ (if (string-match "\\./" i)
+ ;; ./abc -> abc
+ (setq i (substring i 2))
+ ;; abc -> **/abc
+ (setq i (concat "**/" i))
+ ;; FIXME: '**/abc' should also
+ ;; match a directory with that
+ ;; name, but doesn't (git 2.25.1).
+ ;; Maybe we should replace
+ ;; such entries with two.
+ (if (string-match "/\\'" i)
+ ;; abc/ -> abc/**
+ (setq i (concat i "**"))))
+ i)))
extra-ignores)))))
(setq files
(mapcar
@@ -331,20 +513,23 @@ backend implementation of `project-external-roots'.")
(split-string
(apply #'vc-git--run-command-string nil "ls-files" args)
"\0" t)))
- ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
- (let* ((submodules (project--git-submodules))
- (sub-files
- (mapcar
- (lambda (module)
- (when (file-directory-p module)
- (project--vc-list-files
- (concat default-directory module)
- backend
- extra-ignores)))
- submodules)))
- (setq files
- (apply #'nconc files sub-files)))
- files))
+ (when (project--vc-merge-submodules-p default-directory)
+ ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
+ (let* ((submodules (project--git-submodules))
+ (sub-files
+ (mapcar
+ (lambda (module)
+ (when (file-directory-p module)
+ (project--vc-list-files
+ (concat default-directory module)
+ backend
+ extra-ignores)))
+ submodules)))
+ (setq files
+ (apply #'nconc files sub-files))))
+ ;; 'git ls-files' returns duplicate entries for merge conflicts.
+ ;; XXX: Better solutions welcome, but this seems cheap enough.
+ (delete-consecutive-dups files)))
(`Hg
(let ((default-directory (expand-file-name (file-name-as-directory dir)))
args)
@@ -362,6 +547,11 @@ backend implementation of `project-external-roots'.")
(lambda (s) (concat default-directory s))
(split-string (buffer-string) "\0" t)))))))
+(defun project--vc-merge-submodules-p (dir)
+ (project--value-in-dir
+ 'project-vc-merge-submodules
+ dir))
+
(defun project--git-submodules ()
;; 'git submodule foreach' is much slower.
(condition-case nil
@@ -376,16 +566,30 @@ backend implementation of `project-external-roots'.")
(cl-defmethod project-ignores ((project (head vc)) dir)
(let* ((root (cdr project))
- backend)
+ backend)
(append
(when (file-equal-p dir root)
(setq backend (vc-responsible-backend root))
- (mapcar
- (lambda (entry)
- (if (string-match "\\`/" entry)
- (replace-match "./" t t entry)
- entry))
- (vc-call-backend backend 'ignore-completion-table root)))
+ (delq
+ nil
+ (mapcar
+ (lambda (entry)
+ (cond
+ ((eq ?! (aref entry 0))
+ ;; No support for whitelisting (yet).
+ nil)
+ ((string-match "\\(/\\)[^/]" entry)
+ ;; FIXME: This seems to be Git-specific.
+ ;; And / in the entry (start or even the middle) means
+ ;; the pattern is "rooted". Or actually it is then
+ ;; relative to its respective .gitignore (of which there
+ ;; could be several), but we only support .gitignore at
+ ;; the root.
+ (if (= (match-beginning 0) 0)
+ (replace-match "./" t t entry 1)
+ (concat "./" entry)))
+ (t entry)))
+ (vc-call-backend backend 'ignore-completion-table root))))
(project--value-in-dir 'project-vc-ignores root)
(mapcar
(lambda (dir)
@@ -424,6 +628,103 @@ DIRS must contain directory names."
(hack-dir-local-variables-non-file-buffer))
(symbol-value var)))
+
+;;; Project commands
+
+;;;###autoload
+(defvar project-prefix-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "!" 'project-shell-command)
+ (define-key map "&" 'project-async-shell-command)
+ (define-key map "f" 'project-find-file)
+ (define-key map "F" 'project-or-external-find-file)
+ (define-key map "b" 'project-switch-to-buffer)
+ (define-key map "s" 'project-shell)
+ (define-key map "d" 'project-dired)
+ (define-key map "v" 'project-vc-dir)
+ (define-key map "c" 'project-compile)
+ (define-key map "e" 'project-eshell)
+ (define-key map "k" 'project-kill-buffers)
+ (define-key map "p" 'project-switch-project)
+ (define-key map "g" 'project-find-regexp)
+ (define-key map "G" 'project-or-external-find-regexp)
+ (define-key map "r" 'project-query-replace-regexp)
+ (define-key map "x" 'project-execute-extended-command)
+ map)
+ "Keymap for project commands.")
+
+;;;###autoload (define-key ctl-x-map "p" project-prefix-map)
+
+;; We can't have these place-specific maps inherit from
+;; project-prefix-map because project--other-place-command needs to
+;; know which map the key binding came from, as if it came from one of
+;; these maps, we don't want to set display-buffer-overriding-action
+
+(defvar project-other-window-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-o" #'project-display-buffer)
+ map)
+ "Keymap for project commands that display buffers in other windows.")
+
+(defvar project-other-frame-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-o" #'project-display-buffer-other-frame)
+ map)
+ "Keymap for project commands that display buffers in other frames.")
+
+(defun project--other-place-command (action &optional map)
+ (let* ((key (read-key-sequence-vector nil t))
+ (place-cmd (lookup-key map key))
+ (generic-cmd (lookup-key project-prefix-map key))
+ (switch-to-buffer-obey-display-actions t)
+ (display-buffer-overriding-action (unless place-cmd action)))
+ (if-let ((cmd (or place-cmd generic-cmd)))
+ (call-interactively cmd)
+ (user-error "%s is undefined" (key-description key)))))
+
+;;;###autoload
+(defun project-other-window-command ()
+ "Run project command, displaying resultant buffer in another window.
+
+The following commands are available:
+
+\\{project-prefix-map}
+\\{project-other-window-map}"
+ (interactive)
+ (project--other-place-command '((display-buffer-pop-up-window)
+ (inhibit-same-window . t))
+ project-other-window-map))
+
+;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command)
+
+;;;###autoload
+(defun project-other-frame-command ()
+ "Run project command, displaying resultant buffer in another frame.
+
+The following commands are available:
+
+\\{project-prefix-map}
+\\{project-other-frame-map}"
+ (interactive)
+ (project--other-place-command '((display-buffer-pop-up-frame))
+ project-other-frame-map))
+
+;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command)
+
+;;;###autoload
+(defun project-other-tab-command ()
+ "Run project command, displaying resultant buffer in a new tab.
+
+The following commands are available:
+
+\\{project-prefix-map}"
+ (interactive)
+ (project--other-place-command '((display-buffer-in-new-tab))))
+
+;;;###autoload
+(when (bound-and-true-p tab-prefix-map)
+ (define-key tab-prefix-map "p" #'project-other-tab-command))
+
(declare-function grep-read-files "grep")
(declare-function xref--show-xrefs "xref")
(declare-function xref--find-ignores-arguments "xref")
@@ -440,13 +741,14 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
(interactive (list (project--read-regexp)))
(require 'xref)
(require 'grep)
- (let* ((pr (project-current t))
- (default-directory (car (project-roots pr)))
+ (let* ((caller-dir default-directory)
+ (pr (project-current t))
+ (default-directory (project-root pr))
(files
(if (not current-prefix-arg)
- (project-files pr (project-roots pr))
+ (project-files pr)
(let ((dir (read-directory-name "Base directory: "
- nil default-directory t)))
+ caller-dir nil t)))
(project--files-in-directory dir
nil
(grep-read-files regexp))))))
@@ -455,9 +757,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
nil)))
(defun project--dir-ignores (project dir)
- (let* ((roots (project-roots project))
- (root (cl-find dir roots :test #'file-in-directory-p)))
- (if (not root)
+ (let ((root (project-root project)))
+ (if (not (file-in-directory-p dir root))
(project-ignores nil nil) ;The defaults.
(let ((ignores (project-ignores project root)))
(if (file-equal-p root dir)
@@ -474,10 +775,10 @@ pattern to search for."
(interactive (list (project--read-regexp)))
(require 'xref)
(let* ((pr (project-current t))
- (default-directory (car (project-roots pr)))
+ (default-directory (project-root pr))
(files
- (project-files pr (append
- (project-roots pr)
+ (project-files pr (cons
+ (project-root pr)
(project-external-roots pr)))))
(xref--show-xrefs
(apply-partially #'project--find-regexp-in-files regexp files)
@@ -491,47 +792,34 @@ pattern to search for."
(user-error "No matches for: %s" regexp))
xrefs))
-(defun project--process-file-region (start end program
- &optional buffer display
- &rest args)
- ;; FIXME: This branching shouldn't be necessary, but
- ;; call-process-region *is* measurably faster, even for a program
- ;; doing some actual work (for a period of time). Even though
- ;; call-process-region also creates a temp file internally
- ;; (http://lists.gnu.org/archive/html/emacs-devel/2019-01/msg00211.html).
- (if (not (file-remote-p default-directory))
- (apply #'call-process-region
- start end program nil buffer display args)
- (let ((infile (make-temp-file "ppfr")))
- (unwind-protect
- (progn
- (write-region start end infile nil 'silent)
- (apply #'process-file program infile buffer display args))
- (delete-file infile)))))
+(defvar project-regexp-history-variable 'grep-regexp-history)
(defun project--read-regexp ()
- (let ((sym (thing-at-point 'symbol)))
- (read-regexp "Find regexp" (and sym (regexp-quote sym)))))
+ (let ((sym (thing-at-point 'symbol t)))
+ (read-regexp "Find regexp" (and sym (regexp-quote sym))
+ project-regexp-history-variable)))
;;;###autoload
(defun project-find-file ()
- "Visit a file (with completion) in the current project's roots.
-The completion default is the filename at point, if one is
-recognized."
+ "Visit a file (with completion) in the current project.
+
+The completion default is the filename at point, determined by
+`thing-at-point' (whether such file exists or not)."
(interactive)
(let* ((pr (project-current t))
- (dirs (project-roots pr)))
+ (dirs (list (project-root pr))))
(project-find-file-in (thing-at-point 'filename) dirs pr)))
;;;###autoload
(defun project-or-external-find-file ()
- "Visit a file (with completion) in the current project's roots or external roots.
-The completion default is the filename at point, if one is
-recognized."
+ "Visit a file (with completion) in the current project or external roots.
+
+The completion default is the filename at point, determined by
+`thing-at-point' (whether such file exists or not)."
(interactive)
(let* ((pr (project-current t))
- (dirs (append
- (project-roots pr)
+ (dirs (cons
+ (project-root pr)
(project-external-roots pr))))
(project-find-file-in (thing-at-point 'filename) dirs pr)))
@@ -543,6 +831,7 @@ For the arguments list, see `project--read-file-cpd-relative'."
(const :tag "Read with completion from absolute names"
project--read-file-absolute)
(function :tag "Custom function" nil))
+ :group 'project
:version "27.1")
(defun project--read-file-cpd-relative (prompt
@@ -579,9 +868,10 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in
(defun project-find-file-in (filename dirs project)
"Complete FILENAME in DIRS in PROJECT and visit the result."
(let* ((all-files (project-files project dirs))
+ (completion-ignore-case read-file-name-completion-ignore-case)
(file (funcall project-read-file-name-function
- "Find file" all-files nil nil
- filename)))
+ "Find file" all-files nil nil
+ filename)))
(if (string= file "")
(user-error "You didn't specify the file")
(find-file file))))
@@ -607,6 +897,65 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in
collection predicate t res hist nil)))
res))
+;;;###autoload
+(defun project-dired ()
+ "Start Dired in the current project's root."
+ (interactive)
+ (dired (project-root (project-current t))))
+
+;;;###autoload
+(defun project-vc-dir ()
+ "Run VC-Dir in the current project's root."
+ (interactive)
+ (vc-dir (project-root (project-current t))))
+
+;;;###autoload
+(defun project-shell ()
+ "Start an inferior shell in the current project's root directory.
+If a buffer already exists for running a shell in the project's root,
+switch to it. Otherwise, create a new shell buffer.
+With \\[universal-argument] prefix arg, create a new inferior shell buffer even
+if one already exists."
+ (interactive)
+ (let* ((default-directory (project-root (project-current t)))
+ (default-project-shell-name (project-prefixed-buffer-name "shell"))
+ (shell-buffer (get-buffer default-project-shell-name)))
+ (if (and shell-buffer (not current-prefix-arg))
+ (pop-to-buffer-same-window shell-buffer)
+ (shell (generate-new-buffer-name default-project-shell-name)))))
+
+;;;###autoload
+(defun project-eshell ()
+ "Start Eshell in the current project's root directory.
+If a buffer already exists for running Eshell in the project's root,
+switch to it. Otherwise, create a new Eshell buffer.
+With \\[universal-argument] prefix arg, create a new Eshell buffer even
+if one already exists."
+ (interactive)
+ (defvar eshell-buffer-name)
+ (let* ((default-directory (project-root (project-current t)))
+ (eshell-buffer-name (project-prefixed-buffer-name "eshell"))
+ (eshell-buffer (get-buffer eshell-buffer-name)))
+ (if (and eshell-buffer (not current-prefix-arg))
+ (pop-to-buffer-same-window eshell-buffer)
+ (eshell t))))
+
+;;;###autoload
+(defun project-async-shell-command ()
+ "Run `async-shell-command' in the current project's root directory."
+ (declare (interactive-only async-shell-command))
+ (interactive)
+ (let ((default-directory (project-root (project-current t))))
+ (call-interactively #'async-shell-command)))
+
+;;;###autoload
+(defun project-shell-command ()
+ "Run `shell-command' in the current project's root directory."
+ (declare (interactive-only shell-command))
+ (interactive)
+ (let ((default-directory (project-root (project-current t))))
+ (call-interactively #'shell-command)))
+
(declare-function fileloop-continue "fileloop" ())
;;;###autoload
@@ -634,5 +983,424 @@ loop using the command \\[fileloop-continue]."
from to (project-files (project-current t)) 'default)
(fileloop-continue))
+(defvar compilation-read-command)
+(declare-function compilation-read-command "compile")
+
+(defun project-prefixed-buffer-name (mode)
+ (concat "*"
+ (file-name-nondirectory
+ (directory-file-name default-directory))
+ "-"
+ (downcase mode)
+ "*"))
+
+(defcustom project-compilation-buffer-name-function nil
+ "Function to compute the name of a project compilation buffer.
+If non-nil, it overrides `compilation-buffer-name-function' for
+`project-compile'."
+ :version "28.1"
+ :group 'project
+ :type '(choice (const :tag "Default" nil)
+ (const :tag "Prefixed with root directory name"
+ project-prefixed-buffer-name)
+ (function :tag "Custom function")))
+
+;;;###autoload
+(defun project-compile ()
+ "Run `compile' in the project root."
+ (declare (interactive-only compile))
+ (interactive)
+ (let ((default-directory (project-root (project-current t)))
+ (compilation-buffer-name-function
+ (or project-compilation-buffer-name-function
+ compilation-buffer-name-function)))
+ (call-interactively #'compile)))
+
+(defun project--read-project-buffer ()
+ (let* ((pr (project-current t))
+ (current-buffer (current-buffer))
+ (other-buffer (other-buffer current-buffer))
+ (other-name (buffer-name other-buffer))
+ (predicate
+ (lambda (buffer)
+ ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist.
+ (and (cdr buffer)
+ (equal pr
+ (with-current-buffer (cdr buffer)
+ (project-current)))))))
+ (read-buffer
+ "Switch to buffer: "
+ (when (funcall predicate (cons other-name other-buffer))
+ other-name)
+ nil
+ predicate)))
+
+;;;###autoload
+(defun project-switch-to-buffer (buffer-or-name)
+ "Display buffer BUFFER-OR-NAME in the selected window.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical."
+ (interactive (list (project--read-project-buffer)))
+ (switch-to-buffer buffer-or-name))
+
+;;;###autoload
+(defun project-display-buffer (buffer-or-name)
+ "Display BUFFER-OR-NAME in some window, without selecting it.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical.
+
+This function uses `display-buffer' as a subroutine, which see
+for how it is determined where the buffer will be displayed."
+ (interactive (list (project--read-project-buffer)))
+ (display-buffer buffer-or-name))
+
+;;;###autoload
+(defun project-display-buffer-other-frame (buffer-or-name)
+ "Display BUFFER-OR-NAME preferably in another frame.
+When called interactively, prompts for a buffer belonging to the
+current project. Two buffers belong to the same project if their
+project instances, as reported by `project-current' in each
+buffer, are identical.
+
+This function uses `display-buffer-other-frame' as a subroutine,
+which see for how it is determined where the buffer will be
+displayed."
+ (interactive (list (project--read-project-buffer)))
+ (display-buffer-other-frame buffer-or-name))
+
+(defcustom project-kill-buffer-conditions
+ '(buffer-file-name ; All file-visiting buffers are included.
+ ;; Most of the temp buffers in the background:
+ (major-mode . fundamental-mode)
+ ;; non-text buffer such as xref, occur, vc, log, ...
+ (and (derived-mode . special-mode)
+ (not (major-mode . help-mode)))
+ (derived-mode . compilation-mode)
+ (derived-mode . dired-mode)
+ (derived-mode . diff-mode))
+ "List of conditions to kill buffers related to a project.
+This list is used by `project-kill-buffers'.
+Each condition is either:
+- a regular expression, to match a buffer name,
+- a predicate function that takes a buffer object as argument
+ and returns non-nil if the buffer should be killed,
+- a cons-cell, where the car describes how to interpret the cdr.
+ The car can be one of the following:
+ * `major-mode': the buffer is killed if the buffer's major
+ mode is eq to the cons-cell's cdr
+ * `derived-mode': the buffer is killed if the buffer's major
+ mode is derived from the major mode denoted by the cons-cell's
+ cdr
+ * `not': the cdr is interpreted as a negation of a condition.
+ * `and': the cdr is a list of recursive conditions, that all have
+ to be met.
+ * `or': the cdr is a list of recursive conditions, of which at
+ least one has to be met.
+
+If any of these conditions are satisfied for a buffer in the
+current project, it will be killed."
+ :type '(repeat (choice regexp function symbol
+ (cons :tag "Major mode"
+ (const major-mode) symbol)
+ (cons :tag "Derived mode"
+ (const derived-mode) symbol)
+ (cons :tag "Negation"
+ (const not) sexp)
+ (cons :tag "Conjunction"
+ (const and) sexp)
+ (cons :tag "Disjunction"
+ (const or) sexp)))
+ :version "28.1"
+ :group 'project
+ :package-version '(project . "0.6.0"))
+
+(defun project--buffer-list (pr)
+ "Return the list of all buffers in project PR."
+ (let ((conn (file-remote-p (project-root pr)))
+ bufs)
+ (dolist (buf (buffer-list))
+ ;; For now we go with the assumption that a project must reside
+ ;; entirely on one host. We might relax that in the future.
+ (when (and (equal conn
+ (file-remote-p (buffer-local-value 'default-directory buf)))
+ (equal pr
+ (with-current-buffer buf
+ (project-current))))
+ (push buf bufs)))
+ (nreverse bufs)))
+
+(defun project--kill-buffer-check (buf conditions)
+ "Check if buffer BUF matches any element of the list CONDITIONS.
+See `project-kill-buffer-conditions' for more details on the form
+of CONDITIONS."
+ (catch 'kill
+ (dolist (c conditions)
+ (when (cond
+ ((stringp c)
+ (string-match-p c (buffer-name buf)))
+ ((symbolp c)
+ (funcall c buf))
+ ((eq (car-safe c) 'major-mode)
+ (eq (buffer-local-value 'major-mode buf)
+ (cdr c)))
+ ((eq (car-safe c) 'derived-mode)
+ (provided-mode-derived-p
+ (buffer-local-value 'major-mode buf)
+ (cdr c)))
+ ((eq (car-safe c) 'not)
+ (not (project--kill-buffer-check buf (cdr c))))
+ ((eq (car-safe c) 'or)
+ (project--kill-buffer-check buf (cdr c)))
+ ((eq (car-safe c) 'and)
+ (seq-every-p
+ (apply-partially #'project--kill-buffer-check
+ buf)
+ (mapcar #'list (cdr c)))))
+ (throw 'kill t)))))
+
+(defun project--buffers-to-kill (pr)
+ "Return list of buffers in project PR to kill.
+What buffers should or should not be killed is described
+in `project-kill-buffer-conditions'."
+ (let (bufs)
+ (dolist (buf (project--buffer-list pr))
+ (when (project--kill-buffer-check buf project-kill-buffer-conditions)
+ (push buf bufs)))
+ bufs))
+
+;;;###autoload
+(defun project-kill-buffers (&optional no-confirm)
+ "Kill the buffers belonging to the current project.
+Two buffers belong to the same project if their project
+instances, as reported by `project-current' in each buffer, are
+identical. Only the buffers that match a condition in
+`project-kill-buffer-conditions' will be killed. If NO-CONFIRM
+is non-nil, the command will not ask the user for confirmation.
+NO-CONFIRM is always nil when the command is invoked
+interactively."
+ (interactive)
+ (let* ((pr (project-current t))
+ (bufs (project--buffers-to-kill pr)))
+ (cond (no-confirm
+ (mapc #'kill-buffer bufs))
+ ((null bufs)
+ (message "No buffers to kill"))
+ ((yes-or-no-p (format "Kill %d buffers in %s? "
+ (length bufs)
+ (project-root pr)))
+ (mapc #'kill-buffer bufs)))))
+
+
+;;; Project list
+
+(defcustom project-list-file (locate-user-emacs-file "projects")
+ "File in which to save the list of known projects."
+ :type 'file
+ :version "28.1"
+ :group 'project)
+
+(defvar project--list 'unset
+ "List structure containing root directories of known projects.
+With some possible metadata (to be decided).")
+
+(defun project--read-project-list ()
+ "Initialize `project--list' using contents of `project-list-file'."
+ (let ((filename project-list-file))
+ (setq project--list
+ (when (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (read (current-buffer)))))
+ (unless (seq-every-p
+ (lambda (elt) (stringp (car-safe elt)))
+ project--list)
+ (warn "Contents of %s are in wrong format, resetting"
+ project-list-file)
+ (setq project--list nil))))
+
+(defun project--ensure-read-project-list ()
+ "Initialize `project--list' if it isn't already initialized."
+ (when (eq project--list 'unset)
+ (project--read-project-list)))
+
+(defun project--write-project-list ()
+ "Save `project--list' in `project-list-file'."
+ (let ((filename project-list-file))
+ (with-temp-buffer
+ (insert ";;; -*- lisp-data -*-\n")
+ (let ((print-length nil)
+ (print-level nil))
+ (pp project--list (current-buffer)))
+ (write-region nil nil filename nil 'silent))))
+
+;;;###autoload
+(defun project-remember-project (pr)
+ "Add project PR to the front of the project list.
+Save the result in `project-list-file' if the list of projects has changed."
+ (project--ensure-read-project-list)
+ (let ((dir (project-root pr)))
+ (unless (equal (caar project--list) dir)
+ (dolist (ent project--list)
+ (when (equal dir (car ent))
+ (setq project--list (delq ent project--list))))
+ (push (list dir) project--list)
+ (project--write-project-list))))
+
+(defun project--remove-from-project-list (project-root report-message)
+ "Remove directory PROJECT-ROOT of a missing project from the project list.
+If the directory was in the list before the removal, save the
+result in `project-list-file'. Announce the project's removal
+from the list using REPORT-MESSAGE, which is a format string
+passed to `message' as its first argument."
+ (project--ensure-read-project-list)
+ (when-let ((ent (assoc project-root project--list)))
+ (setq project--list (delq ent project--list))
+ (message report-message project-root)
+ (project--write-project-list)))
+
+;;;###autoload
+(defun project-remove-known-project (project-root)
+ "Remove directory PROJECT-ROOT from the project list.
+PROJECT-ROOT is the root directory of a known project listed in
+the project list."
+ (interactive (list (project-prompt-project-dir)))
+ (project--remove-from-project-list
+ project-root "Project `%s' removed from known projects"))
+
+(defun project-prompt-project-dir ()
+ "Prompt the user for a directory that is one of the known project roots.
+The project is chosen among projects known from the project list,
+see `project-list-file'.
+It's also possible to enter an arbitrary directory not in the list."
+ (project--ensure-read-project-list)
+ (let* ((dir-choice "... (choose a dir)")
+ (choices
+ ;; XXX: Just using this for the category (for the substring
+ ;; completion style).
+ (project--file-completion-table
+ (append project--list `(,dir-choice))))
+ (pr-dir (completing-read "Select project: " choices nil t)))
+ (if (equal pr-dir dir-choice)
+ (read-directory-name "Select directory: " default-directory nil t)
+ pr-dir)))
+
+;;;###autoload
+(defun project-known-project-roots ()
+ "Return the list of root directories of all known projects."
+ (project--ensure-read-project-list)
+ (mapcar #'car project--list))
+
+;;;###autoload
+(defun project-execute-extended-command ()
+ "Execute an extended command in project root."
+ (declare (interactive-only command-execute))
+ (interactive)
+ (let ((default-directory (project-root (project-current t))))
+ (call-interactively #'execute-extended-command)))
+
+
+;;; Project switching
+
+(defcustom project-switch-commands
+ '((project-find-file "Find file")
+ (project-find-regexp "Find regexp")
+ (project-dired "Dired")
+ (project-vc-dir "VC-Dir")
+ (project-eshell "Eshell"))
+ "Alist mapping commands to descriptions.
+Used by `project-switch-project' to construct a dispatch menu of
+commands available upon \"switching\" to another project.
+
+Each element is of the form (COMMAND LABEL &optional KEY) where
+COMMAND is the command to run when KEY is pressed. LABEL is used
+to distinguish the menu entries in the dispatch menu. If KEY is
+absent, COMMAND must be bound in `project-prefix-map', and the
+key is looked up in that map."
+ :version "28.1"
+ :group 'project
+ :package-version '(project . "0.6.0")
+ :type '(repeat
+ (list
+ (symbol :tag "Command")
+ (string :tag "Label")
+ (choice :tag "Key to press"
+ (const :tag "Infer from the keymap" nil)
+ (character :tag "Explicit key")))))
+
+(defcustom project-switch-use-entire-map nil
+ "Make `project-switch-project' use entire `project-prefix-map'.
+If nil, `project-switch-project' will only recognize commands
+listed in `project-switch-commands' and signal an error when
+others are invoked. Otherwise, all keys in `project-prefix-map'
+are legal even if they aren't listed in the dispatch menu."
+ :type 'boolean
+ :group 'project
+ :version "28.1")
+
+(defun project--keymap-prompt ()
+ "Return a prompt for the project switching dispatch menu."
+ (mapconcat
+ (pcase-lambda (`(,cmd ,label ,key))
+ (when (characterp cmd) ; Old format, apparently user-customized.
+ (let ((tmp cmd))
+ ;; TODO: Add a deprecation warning, probably.
+ (setq cmd key
+ key tmp)))
+ (let ((key (if key
+ (vector key)
+ (where-is-internal cmd (list project-prefix-map) t))))
+ (format "[%s] %s"
+ (propertize (key-description key) 'face 'bold)
+ label)))
+ project-switch-commands
+ " "))
+
+;;;###autoload
+(defun project-switch-project (dir)
+ "\"Switch\" to another project by running an Emacs command.
+The available commands are presented as a dispatch menu
+made from `project-switch-commands'.
+
+When called in a program, it will use the project corresponding
+to directory DIR."
+ (interactive (list (project-prompt-project-dir)))
+ (let* ((commands-menu
+ (mapcar
+ (lambda (row)
+ (if (characterp (car row))
+ ;; Deprecated format.
+ ;; XXX: Add a warning about it?
+ (reverse row)
+ row))
+ project-switch-commands))
+ (commands-map
+ (let ((temp-map (make-sparse-keymap)))
+ (set-keymap-parent temp-map project-prefix-map)
+ (dolist (row commands-menu temp-map)
+ (when-let ((cmd (nth 0 row))
+ (keychar (nth 2 row)))
+ (define-key temp-map (vector keychar) cmd)))))
+ command)
+ (while (not command)
+ (let* ((overriding-local-map commands-map)
+ (choice (read-key-sequence (project--keymap-prompt))))
+ (when (setq command (lookup-key commands-map choice))
+ (unless (or project-switch-use-entire-map
+ (assq command commands-menu))
+ ;; TODO: Add some hint to the prompt, like "key not
+ ;; recognized" or something.
+ (setq command nil)))
+ (let ((global-command (lookup-key (current-global-map) choice)))
+ (when (memq global-command
+ '(keyboard-quit keyboard-escape-quit))
+ (call-interactively global-command)))))
+ (let ((default-directory dir)
+ (project-current-inhibit-prompt t))
+ (call-interactively command))))
+
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 89e3177a784..0b520e39074 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -261,20 +261,14 @@
(require 'comint)
(eval-when-compile
- (require 'font-lock)
;; We need imenu everywhere because of the predicate index!
(require 'imenu)
;)
(require 'shell)
)
-(require 'easymenu)
(require 'align)
-(eval-when-compile
- (or (fboundp 'use-region-p)
- (defsubst use-region-p () (region-exists-p))))
-
(defgroup prolog nil
"Editing and running Prolog and Mercury files."
:group 'languages)
@@ -780,12 +774,6 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
(modify-syntax-entry ?> "." table)
(modify-syntax-entry ?| "." table)
(modify-syntax-entry ?\' "\"" table)
-
- ;; Any better way to handle the 0'<char> construct?!?
- (when (and prolog-char-quote-workaround
- (not (fboundp 'syntax-propertize-rules)))
- (modify-syntax-entry ?0 "\\" table))
-
(modify-syntax-entry ?% "<" table)
(modify-syntax-entry ?\n ">" table)
(modify-syntax-entry ?* ". 23b" table)
@@ -1051,21 +1039,19 @@ VERSION is of the format (Major . Minor)"
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][[:xdigit:]]*\\(\\\\\\)" (1 "_"))
- )))
+ (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][[:xdigit:]]*\\(\\\\\\)" (1 "_"))))
(defun prolog-mode-variables ()
"Set some common variables to Prolog code specific values."
@@ -1214,7 +1200,9 @@ Commands:
(define-derived-mode mercury-mode prolog-mode "Prolog[Mercury]"
"Major mode for editing Mercury programs.
Actually this is just customized `prolog-mode'."
- (setq-local prolog-system 'mercury))
+ (setq-local prolog-system 'mercury)
+ ;; Run once more to set up based on `prolog-system'
+ (prolog-mode-variables))
;;-------------------------------------------------------------------
@@ -1305,8 +1293,7 @@ To find out what version of Prolog mode you are running, enter
(setq-local shell-dirstack-query "pwd.")
(setq-local compilation-error-regexp-alist
prolog-inferior-error-regexp-alist)
- (compilation-shell-minor-mode)
- (prolog-inferior-menu))
+ (compilation-shell-minor-mode))
(defun prolog-input-filter (str)
(cond ((string-match "\\`\\s *\\'" str) nil) ;whitespace
@@ -1328,6 +1315,7 @@ With prefix argument ARG, restart the Prolog process if running before."
(progn
(process-send-string "prolog" "halt.\n")
(while (get-process "prolog") (sit-for 0.1))))
+ (prolog-ensure-process)
(let ((buff (buffer-name)))
(if (not (string= buff "*prolog*"))
(prolog-goto-prolog-process-buffer))
@@ -1337,7 +1325,6 @@ With prefix argument ARG, restart the Prolog process if running before."
prolog-use-sicstus-sd)
(prolog-enable-sicstus-sd))
(prolog-mode-variables)
- (prolog-ensure-process)
))
(defun prolog-inferior-guess-flavor (&optional ignored)
@@ -1362,56 +1349,57 @@ With prefix argument ARG, restart the Prolog process if running before."
"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)
-
- ;; The "INFERIOR=yes" hack is for SWI-Prolog 7.2.3 and earlier,
- ;; which assumes it is running under Emacs if either INFERIOR=yes or
- ;; if EMACS is set to a nonempty value. The EMACS setting is
- ;; obsolescent, so set INFERIOR. Newer versions of SWI-Prolog should
- ;; know about INSIDE_EMACS (which replaced EMACS) and should not need
- ;; this hack.
- (let ((process-environment
- (if (getenv "INFERIOR")
- process-environment
- (cons "INFERIOR=yes" process-environment))))
- (apply 'make-comint-in-buffer "prolog" (current-buffer)
- (prolog-program-name) nil (prolog-program-switches)))
-
- (unless prolog-system
- ;; Setup auto-detection.
- (setq-local
- 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)))))))
+ (let ((pname (prolog-program-name))
+ (pswitches (prolog-program-switches)))
+ (if (null pname)
+ (error "This Prolog system has defined no interpreter."))
+ (unless (comint-check-proc "*prolog*")
+ (with-current-buffer (get-buffer-create "*prolog*")
+ (prolog-inferior-mode)
+
+ ;; The "INFERIOR=yes" hack is for SWI-Prolog 7.2.3 and earlier,
+ ;; which assumes it is running under Emacs if either INFERIOR=yes or
+ ;; if EMACS is set to a nonempty value. The EMACS setting is
+ ;; obsolescent, so set INFERIOR. Newer versions of SWI-Prolog should
+ ;; know about INSIDE_EMACS (which replaced EMACS) and should not need
+ ;; this hack.
+ (let ((process-environment
+ (if (getenv "INFERIOR")
+ process-environment
+ (cons "INFERIOR=yes" process-environment))))
+ (apply 'make-comint-in-buffer "prolog" (current-buffer)
+ pname nil pswitches))
+
+ (unless prolog-system
+ ;; Setup auto-detection.
+ (setq-local
+ 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*")
@@ -1890,20 +1878,11 @@ Argument BOUND is a buffer position limiting searching."
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)))
+(define-obsolete-function-alias 'prolog-face-name-p 'facep "28.1")
;; 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
@@ -1932,6 +1911,8 @@ Argument BOUND is a buffer position limiting searching."
(t (:underline t)))
"Face name to use for compiler warnings."
:group 'prolog-faces)
+ (define-obsolete-face-alias 'prolog-warning-face
+ 'font-lock-warning-face "28.1")
(defface prolog-builtin-face
'((((class color) (background light)) (:foreground "Purple"))
(((class color) (background dark)) (:foreground "Cyan"))
@@ -1941,15 +1922,11 @@ Argument BOUND is a buffer position limiting searching."
(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)
+ (define-obsolete-face-alias 'prolog-builtin-face
+ 'font-lock-builtin-face "28.1")
+ (defvar prolog-warning-face 'font-lock-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)
+ (defvar prolog-builtin-face 'font-lock-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.")
@@ -2107,7 +2084,7 @@ Argument BOUND is a buffer position limiting searching."
(delq
nil
(cond
- ((eq major-mode 'prolog-mode)
+ ((derived-mode-p 'prolog-mode)
(list
head-predicates
head-predicates-1
@@ -2295,12 +2272,12 @@ between them)."
(progn
(goto-char cbeg)
(search-forward-regexp "%+[ \t]*" end t)
- (prolog-replace-in-string (buffer-substring beg (point))
- "[^ \t%]" " "))
+ (replace-regexp-in-string "[^ \t%]" " "
+ (buffer-substring beg (point))))
;(goto-char beg)
(if (search-forward-regexp "^[ \t]*\\(%+\\|\\*+\\|/\\*+\\)[ \t]*"
end t)
- (prolog-replace-in-string (buffer-substring beg (point)) "/" " ")
+ (replace-regexp-in-string "/" " " (buffer-substring beg (point)))
(beginning-of-line)
(when (search-forward-regexp "^[ \t]+" end t)
(buffer-substring beg (point)))))))))
@@ -2340,11 +2317,10 @@ In effect it sets the `fill-prefix' when inside comments and then calls
(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))))
+(defun prolog-replace-in-string (str regexp newtext &optional literal)
+ (declare (obsolete replace-regexp-in-string "28.1"))
+ (replace-regexp-in-string regexp newtext str nil literal))
+
;;-------------------------------------------------------------------
;; Online help
@@ -2373,12 +2349,8 @@ In effect it sets the `fill-prefix' when inside comments and then calls
;; 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))
+ (predicate (read-string (format-prompt "Help on predicate" word)
+ nil nil word))
;;point
)
(if prolog-help-function-i
@@ -2752,20 +2724,6 @@ When called with prefix argument ARG, disable zipping instead."
(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."
;; FIXME: Use SMIE.
@@ -3105,12 +3063,8 @@ The module name should be written manually just before the semi-colon."
(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))))
+(define-obsolete-function-alias 'prolog-uncomment-region
+ 'uncomment-region "28.1")
(defun prolog-indent-predicate ()
"Indent the current predicate."
@@ -3396,7 +3350,7 @@ PREFIX is the prefix of the search regexp."
"Commands for Prolog code manipulation."
'("Prolog"
["Comment region" comment-region (use-region-p)]
- ["Uncomment region" prolog-uncomment-region (use-region-p)]
+ ["Uncomment region" uncomment-region (use-region-p)]
["Add comment/move to comment" indent-for-comment t]
["Convert variables in region to '_'" prolog-variables-to-anonymous
:active (use-region-p) :included (not (eq prolog-system 'mercury))]
@@ -3425,9 +3379,6 @@ PREFIX is the prefix of the search regexp."
(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
(setq-local imenu-create-index-function
'imenu-default-create-index-function)
@@ -3438,9 +3389,7 @@ PREFIX is the prefix of the search regexp."
(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))
+ (imenu-add-to-menubar "Predicates")))
(easy-menu-define
prolog-inferior-menu-all prolog-inferior-mode-map
@@ -3483,8 +3432,8 @@ PREFIX is the prefix of the search regexp."
"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))
+ (declare (obsolete nil "28.1"))
+ nil)
(defun prolog-mode-version ()
"Echo the current version of Prolog mode in the minibuffer."
diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el
index e08c9fd0752..67c034d0905 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -1,4 +1,4 @@
-;;; ps-mode.el --- PostScript mode for GNU Emacs
+;;; ps-mode.el --- PostScript mode for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2001-2021 Free Software Foundation, Inc.
@@ -39,7 +39,6 @@
"Peter Kleiweg <p.c.j.kleiweg@rug.nl>, bug-gnu-emacs@gnu.org")
(require 'comint)
-(require 'easymenu)
(require 'smie)
;; Define core `PostScript' group.
@@ -282,20 +281,20 @@ If nil, use `temporary-file-directory'."
(defvar ps-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-v" 'ps-run-boundingbox)
- (define-key map "\C-c\C-u" 'ps-mode-uncomment-region)
- (define-key map "\C-c\C-t" 'ps-mode-epsf-rich)
- (define-key map "\C-c\C-s" 'ps-run-start)
- (define-key map "\C-c\C-r" 'ps-run-region)
- (define-key map "\C-c\C-q" 'ps-run-quit)
- (define-key map "\C-c\C-p" 'ps-mode-print-buffer)
- (define-key map "\C-c\C-o" 'ps-mode-comment-out-region)
- (define-key map "\C-c\C-k" 'ps-run-kill)
- (define-key map "\C-c\C-j" 'ps-mode-other-newline)
- (define-key map "\C-c\C-l" 'ps-run-clear)
- (define-key map "\C-c\C-b" 'ps-run-buffer)
+ (define-key map "\C-c\C-v" #'ps-run-boundingbox)
+ (define-key map "\C-c\C-u" #'ps-mode-uncomment-region)
+ (define-key map "\C-c\C-t" #'ps-mode-epsf-rich)
+ (define-key map "\C-c\C-s" #'ps-run-start)
+ (define-key map "\C-c\C-r" #'ps-run-region)
+ (define-key map "\C-c\C-q" #'ps-run-quit)
+ (define-key map "\C-c\C-p" #'ps-mode-print-buffer)
+ (define-key map "\C-c\C-o" #'ps-mode-comment-out-region)
+ (define-key map "\C-c\C-k" #'ps-run-kill)
+ (define-key map "\C-c\C-j" #'ps-mode-other-newline)
+ (define-key map "\C-c\C-l" #'ps-run-clear)
+ (define-key map "\C-c\C-b" #'ps-run-buffer)
;; FIXME: Add `indent' to backward-delete-char-untabify-method instead?
- (define-key map "\177" 'ps-mode-backward-delete-char)
+ (define-key map "\177" #'ps-mode-backward-delete-char)
map)
"Local keymap to use in PostScript mode.")
@@ -337,10 +336,10 @@ If nil, use `temporary-file-directory'."
(defvar ps-run-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map comint-mode-map)
- (define-key map "\C-c\C-q" 'ps-run-quit)
- (define-key map "\C-c\C-k" 'ps-run-kill)
- (define-key map "\C-c\C-e" 'ps-run-goto-error)
- (define-key map [mouse-2] 'ps-run-mouse-goto-error)
+ (define-key map "\C-c\C-q" #'ps-run-quit)
+ (define-key map "\C-c\C-k" #'ps-run-kill)
+ (define-key map "\C-c\C-e" #'ps-run-goto-error)
+ (define-key map [mouse-2] #'ps-run-mouse-goto-error)
map)
"Local keymap to use in PostScript run mode.")
@@ -501,18 +500,18 @@ point to the corresponding spot in the PostScript window, if input
to the interpreter was sent from that window.
Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number has the same effect."
(setq-local syntax-propertize-function #'ps-mode-syntax-propertize)
- (set (make-local-variable 'font-lock-defaults)
- '((ps-mode-font-lock-keywords
- ps-mode-font-lock-keywords-1
- ps-mode-font-lock-keywords-2
- ps-mode-font-lock-keywords-3)
- nil))
+ (setq-local font-lock-defaults
+ '((ps-mode-font-lock-keywords
+ ps-mode-font-lock-keywords-1
+ ps-mode-font-lock-keywords-2
+ ps-mode-font-lock-keywords-3)
+ nil))
(smie-setup nil #'ps-mode-smie-rules)
(setq-local electric-indent-chars
(append '(?> ?\] ?\}) electric-indent-chars))
- (set (make-local-variable 'comment-start) "%")
+ (setq-local comment-start "%")
;; NOTE: `\' has a special meaning in strings only
- (set (make-local-variable 'comment-start-skip) "%+[ \t]*")
+ (setq-local comment-start-skip "%+[ \t]*")
;; enable doc-view-minor-mode => C-c C-c starts viewing the current ps file
;; with doc-view-mode.
(doc-view-minor-mode 1))
@@ -910,11 +909,11 @@ plus the usually uncoded characters inserted on positions 1 through 28."
(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."
- (set (make-local-variable 'font-lock-defaults)
- '((ps-run-font-lock-keywords
- ps-run-font-lock-keywords-1
- ps-run-font-lock-keywords-2)
- t))
+ (setq-local font-lock-defaults
+ '((ps-run-font-lock-keywords
+ ps-run-font-lock-keywords-1
+ ps-run-font-lock-keywords-2)
+ t))
(setq mode-line-process '(":%s")))
(defun ps-run-running ()
@@ -1093,7 +1092,7 @@ Use line numbers if `ps-run-error-line-numbers' is not nil."
;;
-(add-hook 'kill-emacs-hook 'ps-run-cleanup)
+(add-hook 'kill-emacs-hook #'ps-run-cleanup)
(provide 'ps-mode)
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index d41ac6adb64..2557704e403 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -4,8 +4,8 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
-;; Version: 0.26.1
-;; Package-Requires: ((emacs "24.1") (cl-lib "1.0"))
+;; Version: 0.27.1
+;; Package-Requires: ((emacs "24.2") (cl-lib "1.0"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
;; Keywords: languages
@@ -29,7 +29,7 @@
;; Major mode for editing Python files with some fontification and
;; indentation bits extracted from original Dave Love's python.el
-;; found in GNU/Emacs.
+;; found in GNU Emacs.
;; Implements Syntax highlighting, Indentation, Movement, Shell
;; interaction, Shell completion, Shell virtualenv support, Shell
@@ -54,14 +54,7 @@
;; `python-nav-backward-statement',
;; `python-nav-beginning-of-statement', `python-nav-end-of-statement',
;; `python-nav-beginning-of-block', `python-nav-end-of-block' and
-;; `python-nav-if-name-main' are included but no bound to any key. At
-;; last but not least the specialized `python-nav-forward-sexp' allows
-;; easy navigation between code blocks. If you prefer `cc-mode'-like
-;; `forward-sexp' movement, setting `forward-sexp-function' to nil is
-;; enough, You can do that using the `python-mode-hook':
-
-;; (add-hook 'python-mode-hook
-;; (lambda () (setq forward-sexp-function nil)))
+;; `python-nav-if-name-main' are included but no bound to any key.
;; Shell interaction: is provided and allows opening Python shells
;; inside Emacs and executing any block of code of your current buffer
@@ -135,7 +128,7 @@
;; values enable completion for both CPython and IPython, and probably
;; any readline based shell (it's known to work with PyPy). If your
;; Python installation lacks readline (like CPython for Windows),
-;; installing pyreadline (URL `http://ipython.org/pyreadline.html')
+;; installing pyreadline (URL `https://ipython.org/pyreadline.html')
;; should suffice. To troubleshoot why you are not getting any
;; completions, you can try the following in your Python shell:
@@ -241,27 +234,17 @@
;; 2) Add the following hook in your .emacs:
;; (add-hook 'python-mode-hook
-;; #'(lambda ()
-;; (define-key python-mode-map "\C-m" 'newline-and-indent)))
+;; (lambda ()
+;; (define-key python-mode-map "\C-m" 'newline-and-indent)))
;; I'd recommend the first one since you'll get the same behavior for
;; all modes out-of-the-box.
-;;; Installation:
-
-;; Add this to your .emacs:
-
-;; (add-to-list 'load-path "/folder/containing/file")
-;; (require 'python)
-
-;;; TODO:
-
;;; Code:
(require 'ansi-color)
(require 'cl-lib)
(require 'comint)
-(require 'json)
(require 'tramp-sh)
;; Avoid compiler warnings
@@ -284,24 +267,6 @@
:link '(emacs-commentary-link "python"))
-;;; 24.x Compat
-
-
-(eval-and-compile
- (unless (fboundp 'prog-first-column)
- (defun prog-first-column ()
- 0))
- (unless (fboundp 'file-local-name)
- (defun file-local-name (file)
- "Return the local name component of FILE.
-It returns a file name which can be used directly as argument of
-`process-file', `start-file-process', or `shell-command'."
- (or (file-remote-p file 'localname) file))))
-
-;; In Emacs 24.3 and earlier, `define-derived-mode' does not define
-;; the hook variable, it only puts documentation on the symbol.
-(defvar inferior-python-mode-hook)
-
;;; Bindings
@@ -420,6 +385,12 @@ This variant of `rx' supports common Python named REGEXPS."
(any ?' ?\") "__main__" (any ?' ?\")
(* space) ?:))
(symbol-name (seq (any letter ?_) (* (any word ?_))))
+ (assignment-target (seq (? ?*)
+ (* symbol-name ?.) symbol-name
+ (? ?\[ (+ (not ?\])) ?\])))
+ (grouped-assignment-target (seq (? ?*)
+ (* symbol-name ?.) (group symbol-name)
+ (? ?\[ (+ (not ?\])) ?\])))
(open-paren (or "{" "[" "("))
(close-paren (or "}" "]" ")"))
(simple-operator (any ?+ ?- ?/ ?& ?^ ?~ ?| ?* ?< ?> ?= ?%))
@@ -520,6 +491,52 @@ The type returned can be `comment', `string' or `paren'."
font-lock-string-face)
font-lock-comment-face))
+(defun python--f-string-p (ppss)
+ "Return non-nil if the pos where PPSS was found is inside an f-string."
+ (and (nth 3 ppss)
+ (let ((spos (1- (nth 8 ppss))))
+ (and (memq (char-after spos) '(?f ?F))
+ (or (< (point-min) spos)
+ (not (memq (char-syntax (char-before spos)) '(?w ?_))))))))
+
+(defun python--font-lock-f-strings (limit)
+ "Mark {...} holes as being code.
+Remove the (presumably `font-lock-string-face') `face' property from
+the {...} holes that appear within f-strings."
+ ;; FIXME: This will fail to properly highlight strings appearing
+ ;; within the {...} of an f-string.
+ ;; We could presumably fix it by running
+ ;; `font-lock-fontify-syntactically-region' (as is done in
+ ;; `sm-c--cpp-fontify-syntactically', for example) after removing
+ ;; the `face' property, but I'm not sure it's worth the effort and
+ ;; the risks.
+ (let ((ppss (syntax-ppss)))
+ (while
+ (progn
+ (while (and (not (python--f-string-p ppss))
+ (re-search-forward "\\<f['\"]" limit 'move))
+ (setq ppss (syntax-ppss)))
+ (< (point) limit))
+ (cl-assert (python--f-string-p ppss))
+ (let ((send (save-excursion
+ (goto-char (nth 8 ppss))
+ (condition-case nil
+ (progn (let ((forward-sexp-function nil))
+ (forward-sexp 1))
+ (min limit (1- (point))))
+ (scan-error limit)))))
+ (while (re-search-forward "{" send t)
+ (if (eq ?\{ (char-after))
+ (forward-char 1) ;Just skip over {{
+ (let ((beg (match-beginning 0))
+ (end (condition-case nil
+ (progn (up-list 1) (min send (point)))
+ (scan-error send))))
+ (goto-char end)
+ (put-text-property beg end 'face nil))))
+ (goto-char (min limit (1+ send)))
+ (setq ppss (syntax-ppss))))))
+
(defvar python-font-lock-keywords-level-1
`((,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_))))
(1 font-lock-function-name-face))
@@ -585,8 +602,21 @@ This is the medium decoration level, including everything in
`python-font-lock-keywords-level-1', as well as keywords and
builtins.")
+(defun python-font-lock-assignment-matcher (regexp)
+ "Font lock matcher for assignments based on REGEXP.
+Return nil if REGEXP matched within a `paren' context (to avoid,
+e.g., default values for arguments or passing arguments by name
+being treated as assignments) or is followed by an '=' sign (to
+avoid '==' being treated as an assignment."
+ (lambda (limit)
+ (let ((res (re-search-forward regexp limit t)))
+ (unless (or (python-syntax-context 'paren)
+ (equal (char-after (point)) ?=))
+ res))))
+
(defvar python-font-lock-keywords-maximum-decoration
- `(,@python-font-lock-keywords-level-2
+ `((python--font-lock-f-strings)
+ ,@python-font-lock-keywords-level-2
;; Constants
(,(rx symbol-start
(or
@@ -594,7 +624,8 @@ builtins.")
;; copyright, license, credits, quit and exit are added by the site
;; module and they are not intended to be used in programs
"copyright" "credits" "exit" "license" "quit")
- symbol-end) . font-lock-constant-face)
+ symbol-end)
+ . font-lock-constant-face)
;; Decorators.
(,(rx line-start (* (any " \t")) (group "@" (1+ (or word ?_))
(0+ "." (1+ (or word ?_)))))
@@ -628,31 +659,59 @@ builtins.")
;; OS specific
"VMSError" "WindowsError"
)
- symbol-end) . font-lock-type-face)
- ;; assignments
- ;; support for a = b = c = 5
- (,(lambda (limit)
- (let ((re (python-rx (group (+ (any word ?. ?_)))
- (? ?\[ (+ (not (any ?\]))) ?\]) (* space)
- assignment-operator))
- (res nil))
- (while (and (setq res (re-search-forward re limit t))
- (or (python-syntax-context 'paren)
- (equal (char-after (point)) ?=))))
- res))
- (1 font-lock-variable-name-face nil nil))
- ;; support for a, b, c = (1, 2, 3)
- (,(lambda (limit)
- (let ((re (python-rx (group (+ (any word ?. ?_))) (* space)
- (* ?, (* space) (+ (any word ?. ?_)) (* space))
- ?, (* space) (+ (any word ?. ?_)) (* space)
- assignment-operator))
- (res nil))
- (while (and (setq res (re-search-forward re limit t))
- (goto-char (match-end 1))
- (python-syntax-context 'paren)))
- res))
- (1 font-lock-variable-name-face nil nil)))
+ symbol-end)
+ . font-lock-type-face)
+ ;; multiple assignment
+ ;; (note that type hints are not allowed for multiple assignments)
+ ;; a, b, c = 1, 2, 3
+ ;; a, *b, c = 1, 2, 3, 4, 5
+ ;; [a, b] = (1, 2)
+ ;; (l[1], l[2]) = (10, 11)
+ ;; (a, b, c, *d) = *x, y = 5, 6, 7, 8, 9
+ ;; (a,) = 'foo'
+ ;; (*a,) = ['foo', 'bar', 'baz']
+ ;; d.x, d.y[0], *d.z = 'a', 'b', 'c', 'd', 'e'
+ ;; and variants thereof
+ ;; the cases
+ ;; (a) = 5
+ ;; [a] = 5
+ ;; [*a] = 5, 6
+ ;; are handled separately below
+ (,(python-font-lock-assignment-matcher
+ (python-rx (? (or "[" "(") (* space))
+ grouped-assignment-target (* space) ?, (* space)
+ (* assignment-target (* space) ?, (* space))
+ (? assignment-target (* space))
+ (? ?, (* space))
+ (? (or ")" "]") (* space))
+ (group assignment-operator)))
+ (1 font-lock-variable-name-face)
+ (,(python-rx grouped-assignment-target)
+ (progn
+ (goto-char (match-end 1)) ; go back after the first symbol
+ (match-beginning 2)) ; limit the search until the assignment
+ nil
+ (1 font-lock-variable-name-face)))
+ ;; single assignment with type hints, e.g.
+ ;; a: int = 5
+ ;; b: Tuple[Optional[int], Union[Sequence[str], str]] = (None, 'foo')
+ ;; c: Collection = {1, 2, 3}
+ ;; d: Mapping[int, str] = {1: 'bar', 2: 'baz'}
+ (,(python-font-lock-assignment-matcher
+ (python-rx grouped-assignment-target (* space)
+ (? ?: (* space) (+ not-simple-operator) (* space))
+ assignment-operator))
+ (1 font-lock-variable-name-face))
+ ;; special cases
+ ;; (a) = 5
+ ;; [a] = 5
+ ;; [*a] = 5, 6
+ (,(python-font-lock-assignment-matcher
+ (python-rx (or "[" "(") (* space)
+ grouped-assignment-target (* space)
+ (or ")" "]") (* space)
+ assignment-operator))
+ (1 font-lock-variable-name-face)))
"Font lock keywords to use in python-mode for maximum decoration.
This decoration level includes everything in
@@ -849,7 +908,7 @@ work on `python-indent-calculate-indentation' instead."
(python-util-forward-comment)
(current-indentation))))
(if (and indentation (not (zerop indentation)))
- (set (make-local-variable 'python-indent-offset) indentation)
+ (setq-local python-indent-offset indentation)
(when python-indent-guess-indent-offset-verbose
(message "Can't guess python-indent-offset, using defaults: %s"
python-indent-offset))))))))
@@ -1378,7 +1437,7 @@ With positive ARG search backwards, else search forwards."
(line-beg-pos (line-beginning-position))
(line-content-start (+ line-beg-pos (current-indentation)))
(pos (point-marker))
- (beg-indentation
+ (body-indentation
(and (> arg 0)
(save-excursion
(while (and
@@ -1389,9 +1448,16 @@ With positive ARG search backwards, else search forwards."
0))))
(found
(progn
- (when (and (< arg 0)
- (python-info-looking-at-beginning-of-defun))
+ (when (and (python-info-looking-at-beginning-of-defun)
+ (or (< arg 0)
+ ;; If looking at beginning of defun, and if
+ ;; pos is > line-content-start, ensure a
+ ;; backward re search match this defun by
+ ;; going to end of line before calling
+ ;; re-search-fn bug#40563
+ (and (> arg 0) (> pos line-content-start))))
(end-of-line 1))
+
(while (and (funcall re-search-fn
python-nav-beginning-of-defun-regexp nil t)
(or (python-syntax-context-type)
@@ -1399,7 +1465,7 @@ With positive ARG search backwards, else search forwards."
;; backwards by checking indentation.
(and (> arg 0)
(not (= (current-indentation) 0))
- (>= (current-indentation) beg-indentation)))))
+ (>= (current-indentation) body-indentation)))))
(and (python-info-looking-at-beginning-of-defun)
(or (not (= (line-number-at-pos pos)
(line-number-at-pos)))
@@ -1952,8 +2018,12 @@ position, else returns nil."
:group 'python
:safe 'stringp)
-(defcustom python-shell-interpreter "python"
+(defcustom python-shell-interpreter
+ (cond ((executable-find "python3") "python3")
+ ((executable-find "python") "python")
+ (t "python3"))
"Default Python interpreter for shell."
+ :version "28.1"
:type 'string
:group 'python)
@@ -1993,7 +2063,7 @@ position, else returns nil."
;; IPython prompts activated, this adds some safeguard for that.
"In : " "\\.\\.\\.: ")
"List of regular expressions matching input prompts."
- :type '(repeat string)
+ :type '(repeat regexp)
:version "24.4")
(defcustom python-shell-prompt-output-regexps
@@ -2001,28 +2071,28 @@ position, else returns nil."
"Out\\[[0-9]+\\]: " ; IPython
"Out :") ; ipdb safeguard
"List of regular expressions matching output prompts."
- :type '(repeat string)
+ :type '(repeat regexp)
:version "24.4")
(defcustom python-shell-prompt-regexp ">>> "
"Regular expression matching top level input prompt of Python shell.
It should not contain a caret (^) at the beginning."
- :type 'string)
+ :type 'regexp)
(defcustom python-shell-prompt-block-regexp "\\.\\.\\.:? "
"Regular expression matching block input prompt of Python shell.
It should not contain a caret (^) at the beginning."
- :type 'string)
+ :type 'regexp)
(defcustom python-shell-prompt-output-regexp ""
"Regular expression matching output prompt of Python shell.
It should not contain a caret (^) at the beginning."
- :type 'string)
+ :type 'regexp)
(defcustom python-shell-prompt-pdb-regexp "[(<]*[Ii]?[Pp]db[>)]+ "
"Regular expression matching pdb input prompt of Python shell.
It should not contain a caret (^) at the beginning."
- :type 'string)
+ :type 'regexp)
(define-obsolete-variable-alias
'python-shell-enable-font-lock 'python-shell-font-lock-enable "25.1")
@@ -2076,7 +2146,7 @@ that they are prioritized when looking for executables."
When this variable is non-nil, values are exported into remote
hosts PATH before starting processes. Values defined in
`python-shell-exec-path' will take precedence to paths defined
-here. Normally you wont use this variable directly unless you
+here. Normally you won't use this variable directly unless you
plan to ensure a particular set of paths to all Python shell
executed through tramp connections."
:version "25.1"
@@ -2091,7 +2161,7 @@ executed through tramp connections."
This variable, when set to a string, makes the environment to be
modified such that shells are started within the specified
virtualenv."
- :type '(choice (const nil) string)
+ :type '(choice (const nil) directory)
:group 'python)
(defcustom python-shell-setup-codes nil
@@ -2111,7 +2181,7 @@ virtualenv."
"(" (group (1+ digit)) ")" (1+ (not (any "("))) "()")
1 2))
"`compilation-error-regexp-alist' for inferior Python."
- :type '(alist string)
+ :type '(alist regexp)
:group 'python)
(defmacro python-shell--add-to-path-with-priority (pathvar paths)
@@ -2276,6 +2346,18 @@ Do not set this variable directly, instead use
Do not set this variable directly, instead use
`python-shell-prompt-set-calculated-regexps'.")
+(defalias 'python--parse-json-array
+ (if (fboundp 'json-parse-string)
+ (lambda (string)
+ (json-parse-string string :array-type 'list))
+ (require 'json)
+ (defvar json-array-type)
+ (declare-function json-read-from-string "json" (string))
+ (lambda (string)
+ (let ((json-array-type 'list))
+ (json-read-from-string string))))
+ "Parse the JSON array in STRING into a Lisp list.")
+
(defun python-shell-prompt-detect ()
"Detect prompts for the current `python-shell-interpreter'.
When prompts can be retrieved successfully from the
@@ -2324,11 +2406,11 @@ detection and just returns nil."
(catch 'prompts
(dolist (line (split-string output "\n" t))
(let ((res
- ;; Check if current line is a valid JSON array
- (and (string= (substring line 0 2) "[\"")
+ ;; Check if current line is a valid JSON array.
+ (and (string-prefix-p "[\"" line)
(ignore-errors
- ;; Return prompts as a list, not vector
- (append (json-read-from-string line) nil)))))
+ ;; Return prompts as a list.
+ (python--parse-json-array line)))))
;; The list must contain 3 strings, where the first
;; is the input prompt, the second is the block
;; prompt and the last one is the output prompt. The
@@ -2585,7 +2667,7 @@ also `with-current-buffer'."
(set-buffer python-shell--font-lock-buffer)
(when (not font-lock-mode)
(font-lock-mode 1))
- (set (make-local-variable 'delay-mode-hooks) t)
+ (setq-local delay-mode-hooks t)
(let ((python-indent-guess-indent-offset nil))
(when (not (derived-mode-p 'python-mode))
(python-mode))
@@ -2664,7 +2746,7 @@ With argument MSG show activation message."
(interactive "p")
(python-shell-with-shell-buffer
(python-shell-font-lock-kill-buffer)
- (set (make-local-variable 'python-shell--font-lock-buffer) nil)
+ (setq-local python-shell--font-lock-buffer nil)
(add-hook 'post-command-hook
#'python-shell-font-lock-post-command-hook nil 'local)
(add-hook 'kill-buffer-hook
@@ -2687,7 +2769,7 @@ With argument MSG show deactivation message."
(cdr (python-util-comint-last-prompt))
(line-end-position)
'(face nil font-lock-face nil)))
- (set (make-local-variable 'python-shell--font-lock-buffer) nil)
+ (setq-local python-shell--font-lock-buffer nil)
(remove-hook 'post-command-hook
#'python-shell-font-lock-post-command-hook 'local)
(remove-hook 'kill-buffer-hook
@@ -2703,8 +2785,8 @@ With argument MSG show deactivation message."
With argument MSG show activation/deactivation message."
(interactive "p")
(python-shell-with-shell-buffer
- (set (make-local-variable 'python-shell-font-lock-enable)
- (not python-shell-font-lock-enable))
+ (setq-local python-shell-font-lock-enable
+ (not python-shell-font-lock-enable))
(if python-shell-font-lock-enable
(python-shell-font-lock-turn-on msg)
(python-shell-font-lock-turn-off msg))
@@ -2727,9 +2809,9 @@ eventually provide a shell."
(defun python-shell-comint-watch-for-first-prompt-output-filter (output)
"Run `python-shell-first-prompt-hook' when first prompt is found in OUTPUT."
(when (not python-shell--first-prompt-received)
- (set (make-local-variable 'python-shell--first-prompt-received-output-buffer)
- (concat python-shell--first-prompt-received-output-buffer
- (ansi-color-filter-apply output)))
+ (setq-local python-shell--first-prompt-received-output-buffer
+ (concat python-shell--first-prompt-received-output-buffer
+ (ansi-color-filter-apply output)))
(when (python-shell-comint-end-of-output-p
python-shell--first-prompt-received-output-buffer)
(if (string-match-p
@@ -2737,7 +2819,7 @@ eventually provide a shell."
(or python-shell--first-prompt-received-output-buffer ""))
;; Skip pdb prompts and reset the buffer.
(setq python-shell--first-prompt-received-output-buffer nil)
- (set (make-local-variable 'python-shell--first-prompt-received) t)
+ (setq-local python-shell--first-prompt-received t)
(setq python-shell--first-prompt-received-output-buffer nil)
(with-current-buffer (current-buffer)
(let ((inhibit-quit nil))
@@ -2777,29 +2859,30 @@ variable.
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(when python-shell--parent-buffer
(python-util-clone-local-variables python-shell--parent-buffer))
- (set (make-local-variable 'indent-tabs-mode) nil)
+ (setq-local indent-tabs-mode nil)
;; Users can interactively override default values for
;; `python-shell-interpreter' and `python-shell-interpreter-args'
;; when calling `run-python'. This ensures values let-bound in
;; `python-shell-make-comint' are locally set if needed.
- (set (make-local-variable 'python-shell-interpreter)
- (or python-shell--interpreter python-shell-interpreter))
- (set (make-local-variable 'python-shell-interpreter-args)
- (or python-shell--interpreter-args python-shell-interpreter-args))
- (set (make-local-variable 'python-shell--prompt-calculated-input-regexp) nil)
- (set (make-local-variable 'python-shell--block-prompt) nil)
- (set (make-local-variable 'python-shell--prompt-calculated-output-regexp) nil)
+ (setq-local python-shell-interpreter
+ (or python-shell--interpreter python-shell-interpreter))
+ (setq-local python-shell-interpreter-args
+ (or python-shell--interpreter-args python-shell-interpreter-args))
+ (setq-local python-shell--prompt-calculated-input-regexp nil)
+ (setq-local python-shell--block-prompt nil)
+ (setq-local python-shell--prompt-calculated-output-regexp nil)
(python-shell-prompt-set-calculated-regexps)
(setq comint-prompt-regexp python-shell--prompt-calculated-input-regexp)
- (set (make-local-variable 'comint-prompt-read-only) t)
+ (setq-local comint-prompt-read-only t)
(setq mode-line-process '(":%s"))
- (set (make-local-variable 'comint-output-filter-functions)
- '(ansi-color-process-output
- python-shell-comint-watch-for-first-prompt-output-filter
- python-comint-postoutput-scroll-to-bottom
- comint-watch-for-password-prompt))
- (set (make-local-variable 'compilation-error-regexp-alist)
- python-shell-compilation-regexp-alist)
+ (setq-local comint-output-filter-functions
+ '(ansi-color-process-output
+ python-shell-comint-watch-for-first-prompt-output-filter
+ python-comint-postoutput-scroll-to-bottom
+ comint-watch-for-password-prompt))
+ (setq-local comint-highlight-input nil)
+ (setq-local compilation-error-regexp-alist
+ python-shell-compilation-regexp-alist)
(add-hook 'completion-at-point-functions
#'python-shell-completion-at-point nil 'local)
(define-key inferior-python-mode-map "\t"
@@ -2876,7 +2959,7 @@ process buffer for a list of commands.)"
(python-shell-make-comint
(or cmd (python-shell-calculate-command))
(python-shell-get-process-name dedicated) show)))
- (pop-to-buffer buffer)
+ (set-buffer buffer)
(get-buffer-process buffer)))
(defun run-python-internal ()
@@ -3080,7 +3163,7 @@ Returns the output. See `python-shell-send-string-no-output'."
(define-obsolete-function-alias
'python-send-string 'python-shell-internal-send-string "24.3")
-(defun python-shell-buffer-substring (start end &optional nomain)
+(defun python-shell-buffer-substring (start end &optional nomain no-cookie)
"Send buffer substring from START to END formatted for shell.
This is a wrapper over `buffer-substring' that takes care of
different transformations for the code sent to be evaluated in
@@ -3094,9 +3177,16 @@ the python shell:
4. Wraps indented regions under an \"if True:\" block so the
interpreter evaluates them correctly."
(let* ((start (save-excursion
- ;; Normalize start to the line beginning position.
+ ;; If we're at the start of the expression, and
+ ;; there's just blank space ahead of it, then expand
+ ;; the region to include the start of the line.
+ ;; This makes things work better with the rest of
+ ;; the data we're sending over.
(goto-char start)
- (line-beginning-position)))
+ (if (string-blank-p
+ (buffer-substring (line-beginning-position) start))
+ (line-beginning-position)
+ start)))
(substring (buffer-substring-no-properties start end))
(starts-at-point-min-p (save-restriction
(widen)
@@ -3106,12 +3196,13 @@ the python shell:
(goto-char start)
(python-util-forward-comment 1)
(current-indentation))))
- (fillstr (when (not starts-at-point-min-p)
- (concat
- (format "# -*- coding: %s -*-\n" encoding)
- (make-string
- ;; Subtract 2 because of the coding cookie.
- (- (line-number-at-pos start) 2) ?\n)))))
+ (fillstr (and (not no-cookie)
+ (not starts-at-point-min-p)
+ (concat
+ (format "# -*- coding: %s -*-\n" encoding)
+ (make-string
+ ;; Subtract 2 because of the coding cookie.
+ (- (line-number-at-pos start) 2) ?\n)))))
(with-temp-buffer
(python-mode)
(when fillstr
@@ -3150,7 +3241,10 @@ the python shell:
(line-beginning-position) (line-end-position))))
(buffer-substring-no-properties (point-min) (point-max)))))
-(defun python-shell-send-region (start end &optional send-main msg)
+(declare-function compilation-forget-errors "compile")
+
+(defun python-shell-send-region (start end &optional send-main msg
+ no-cookie)
"Send the region delimited by START and END to inferior Python process.
When optional argument SEND-MAIN is non-nil, allow execution of
code inside blocks delimited by \"if __name__== \\='__main__\\=':\".
@@ -3160,12 +3254,18 @@ non-nil, forces display of a user-friendly message if there's no
process running; defaults to t when called interactively."
(interactive
(list (region-beginning) (region-end) current-prefix-arg t))
- (let* ((string (python-shell-buffer-substring start end (not send-main)))
+ (let* ((string (python-shell-buffer-substring start end (not send-main)
+ no-cookie))
(process (python-shell-get-process-or-error msg))
(original-string (buffer-substring-no-properties start end))
(_ (string-match "\\`\n*\\(.*\\)" original-string)))
(message "Sent: %s..." (match-string 1 original-string))
- (python-shell-send-string string process)))
+ ;; Recalculate positions to avoid landing on the wrong line if
+ ;; lines have been removed/added.
+ (with-current-buffer (process-buffer process)
+ (compilation-forget-errors))
+ (python-shell-send-string string process)
+ (deactivate-mark)))
(defun python-shell-send-statement (&optional send-main msg)
"Send the statement at point to inferior Python process.
@@ -3184,7 +3284,7 @@ interactively."
(python-shell-send-region
(save-excursion (python-nav-beginning-of-statement))
(save-excursion (python-nav-end-of-statement))
- send-main msg)))
+ send-main msg t)))
(defun python-shell-send-buffer (&optional send-main msg)
"Send the entire buffer to inferior Python process.
@@ -3206,27 +3306,29 @@ optional argument MSG is non-nil, forces display of a
user-friendly message if there's no process running; defaults to
t when called interactively."
(interactive (list current-prefix-arg t))
- (save-excursion
- (python-shell-send-region
- (progn
- (end-of-line 1)
- (while (and (or (python-nav-beginning-of-defun)
- (beginning-of-line 1))
- (> (current-indentation) 0)))
- (when (not arg)
- (while (and
- (eq (forward-line -1) 0)
- (if (looking-at (python-rx decorator))
- t
- (forward-line 1)
- nil))))
- (point-marker))
- (progn
- (or (python-nav-end-of-defun)
- (end-of-line 1))
- (point-marker))
- nil ;; noop
- msg)))
+ (let ((starting-pos (point)))
+ (save-excursion
+ (python-shell-send-region
+ (progn
+ (end-of-line 1)
+ (while (and (or (python-nav-beginning-of-defun)
+ (beginning-of-line 1))
+ (> (current-indentation) 0)))
+ (when (not arg)
+ (while (and
+ (eq (forward-line -1) 0)
+ (if (looking-at (python-rx decorator))
+ t
+ (forward-line 1)
+ nil))))
+ (point-marker))
+ (progn
+ (goto-char starting-pos)
+ (or (python-nav-end-of-defun)
+ (end-of-line 1))
+ (point-marker))
+ nil ;; noop
+ msg))))
(defun python-shell-send-file (file-name &optional process temp-file-name
delete msg)
@@ -3274,7 +3376,8 @@ user-friendly message if there's no process running; defaults to
t when called interactively."
(interactive "p")
(pop-to-buffer
- (process-buffer (python-shell-get-process-or-error msg)) nil t))
+ (process-buffer (python-shell-get-process-or-error msg))
+ nil 'mark-for-redisplay))
(defun python-shell-send-setup-code ()
"Send all setup code for shell.
@@ -3548,7 +3651,7 @@ __PYTHON_EL_native_completion_setup()" process)
With argument MSG show deactivation message."
(interactive "p")
(python-shell-with-shell-buffer
- (set (make-local-variable 'python-shell-completion-native-enable) nil)
+ (setq-local python-shell-completion-native-enable nil)
(when msg
(message "Shell native completion is disabled, using fallback"))))
@@ -3557,7 +3660,7 @@ With argument MSG show deactivation message."
With argument MSG show deactivation message."
(interactive "p")
(python-shell-with-shell-buffer
- (set (make-local-variable 'python-shell-completion-native-enable) t)
+ (setq-local python-shell-completion-native-enable t)
(python-shell-completion-native-turn-on-maybe msg)))
(defun python-shell-completion-native-turn-on-maybe (&optional msg)
@@ -3787,7 +3890,7 @@ the top stack frame has been reached.
Filename is expected in the first parenthesized expression.
Line number is expected in the second parenthesized expression."
- :type 'string
+ :type 'regexp
:version "27.1"
:safe 'stringp)
@@ -3802,7 +3905,7 @@ was `continue'. This behavior slightly differentiates the `continue' command
from the `exit' command listed in `python-pdbtrack-exit-command'.
See `python-pdbtrack-activate' for pdbtracking session overview."
- :type 'list
+ :type '(repeat string)
:version "27.1")
(defcustom python-pdbtrack-exit-command '("q" "quit" "exit")
@@ -3811,7 +3914,7 @@ After one of this commands is sent to pdb, pdbtracking session is
considered over.
See `python-pdbtrack-activate' for pdbtracking session overview."
- :type 'list
+ :type '(repeat string)
:version "27.1")
(defcustom python-pdbtrack-kill-buffers t
@@ -3865,8 +3968,8 @@ Returns the tracked buffer."
"Finish tracking."
(python-pdbtrack-unset-tracked-buffer)
(when python-pdbtrack-kill-buffers
- (mapc #'(lambda (buffer)
- (ignore-errors (kill-buffer buffer)))
+ (mapc (lambda (buffer)
+ (ignore-errors (kill-buffer buffer)))
python-pdbtrack-buffers-to-kill))
(setq python-pdbtrack-buffers-to-kill nil))
@@ -3937,7 +4040,7 @@ Argument OUTPUT is a string with the output from the comint process."
(tracked-buffer-window (get-buffer-window tracked-buffer))
(tracked-buffer-line-pos))
(with-current-buffer tracked-buffer
- (set (make-local-variable 'overlay-arrow-position) (make-marker))
+ (setq-local overlay-arrow-position (make-marker))
(setq tracked-buffer-line-pos (progn
(goto-char (point-min))
(forward-line (1- line-number))
@@ -3954,8 +4057,8 @@ Argument OUTPUT is a string with the output from the comint process."
"Setup pdb tracking in current buffer."
(make-local-variable 'python-pdbtrack-buffers-to-kill)
(make-local-variable 'python-pdbtrack-tracked-buffer)
- (add-to-list (make-local-variable 'comint-input-filter-functions)
- #'python-pdbtrack-comint-input-filter-function)
+ (add-hook 'comint-input-filter-functions
+ #'python-pdbtrack-comint-input-filter-function nil t)
(add-to-list (make-local-variable 'comint-output-filter-functions)
#'python-pdbtrack-comint-output-filter-function)
(add-function :before (process-sentinel (get-buffer-process (current-buffer)))
@@ -4129,6 +4232,11 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
(point)))))
(num-quotes (python-syntax-count-quotes
(char-after str-start-pos) str-start-pos))
+ (str-line-start-pos
+ (save-excursion
+ (goto-char str-start-pos)
+ (beginning-of-line)
+ (point-marker)))
(str-end-pos
(save-excursion
(goto-char (+ str-start-pos num-quotes))
@@ -4136,7 +4244,7 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
(goto-char (point-max)))
(point-marker)))
(multi-line-p
- ;; Docstring styles may vary for oneliners and multi-liners.
+ ;; Docstring styles may vary for one-liners and multi-liners.
(> (count-matches "\n" str-start-pos str-end-pos) 0))
(delimiters-style
(pcase python-fill-docstring-style
@@ -4152,7 +4260,7 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
('symmetric (and multi-line-p (cons 1 1)))))
(fill-paragraph-function))
(save-restriction
- (narrow-to-region str-start-pos str-end-pos)
+ (narrow-to-region str-line-start-pos str-end-pos)
(fill-paragraph justify))
(save-excursion
(when (and (python-info-docstring-p) python-fill-docstring-style)
@@ -4562,7 +4670,7 @@ returns will be used. If not FORCE-PROCESS is passed what
:type 'boolean
:version "25.1")
-(defun python-eldoc-function ()
+(defun python-eldoc-function (&rest _ignored)
"`eldoc-documentation-function' for Python.
For this to work as best as possible you should call
`python-shell-send-buffer' from time to time so context in
@@ -4591,9 +4699,7 @@ Interactively, prompt for symbol."
(interactive
(let ((symbol (python-eldoc--get-symbol-at-point))
(enable-recursive-minibuffers t))
- (list (read-string (if symbol
- (format "Describe symbol (default %s): " symbol)
- "Describe symbol: ")
+ (list (read-string (format-prompt "Describe symbol" symbol)
nil nil symbol))))
(message (python-eldoc--get-doc-at-point symbol)))
@@ -5137,21 +5243,22 @@ point's current `syntax-ppss'."
(>=
2
(let (last-backward-sexp-point)
- (while (save-excursion
- (python-nav-backward-sexp)
- (setq backward-sexp-point (point))
- (and (= indentation (current-indentation))
- ;; Make sure we're always moving point.
- ;; If we get stuck in the same position
- ;; on consecutive loop iterations,
- ;; bail out.
- (prog1 (not (eql last-backward-sexp-point
- backward-sexp-point))
- (setq last-backward-sexp-point
- backward-sexp-point))
- (looking-at-p
- (concat "[uU]?[rR]?"
- (python-rx string-delimiter)))))
+ (while (and (<= counter 2)
+ (save-excursion
+ (python-nav-backward-sexp)
+ (setq backward-sexp-point (point))
+ (and (= indentation (current-indentation))
+ ;; Make sure we're always moving point.
+ ;; If we get stuck in the same position
+ ;; on consecutive loop iterations,
+ ;; bail out.
+ (prog1 (not (eql last-backward-sexp-point
+ backward-sexp-point))
+ (setq last-backward-sexp-point
+ backward-sexp-point))
+ (looking-at-p
+ (concat "[uU]?[rR]?"
+ (python-rx string-delimiter))))))
;; Previous sexp was a string, restore point.
(goto-char backward-sexp-point)
(cl-incf counter))
@@ -5343,7 +5450,7 @@ To use `flake8' you would set this to (\"flake8\" \"-\")."
:group 'python-flymake
:type '(repeat string))
-;; The default regexp accomodates for older pyflakes, which did not
+;; The default regexp accommodates for older pyflakes, which did not
;; report the column number, and at the same time it's compatible with
;; flake8 output, although it may be redefined to explicitly match the
;; TYPE
@@ -5391,6 +5498,13 @@ By default messages are considered errors."
:type '(alist :key-type (regexp)
:value-type (symbol)))
+(defcustom python-forward-sexp-function #'python-nav-forward-sexp
+ "Function to use when navigating between expressions."
+ :version "28.1"
+ :type '(choice (const :tag "Python blocks" python-nav-forward-sexp)
+ (const :tag "CC-mode like" nil)
+ function))
+
(defvar-local python--flymake-proc nil)
(defun python--flymake-parse-output (source proc report-fn)
@@ -5479,48 +5593,43 @@ REPORT-FN is Flymake's callback function."
"Major mode for editing Python files.
\\{python-mode-map}"
- (set (make-local-variable 'tab-width) 8)
- (set (make-local-variable 'indent-tabs-mode) nil)
+ (setq-local tab-width 8)
+ (setq-local indent-tabs-mode nil)
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-start-skip) "#+\\s-*")
+ (setq-local comment-start "# ")
+ (setq-local comment-start-skip "#+\\s-*")
- (set (make-local-variable 'parse-sexp-lookup-properties) t)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (setq-local parse-sexp-lookup-properties t)
+ (setq-local parse-sexp-ignore-comments t)
- (set (make-local-variable 'forward-sexp-function)
- 'python-nav-forward-sexp)
+ (setq-local forward-sexp-function python-forward-sexp-function)
- (set (make-local-variable 'font-lock-defaults)
- `(,python-font-lock-keywords
- nil nil nil nil
- (font-lock-syntactic-face-function
- . python-font-lock-syntactic-face-function)))
+ (setq-local font-lock-defaults
+ `(,python-font-lock-keywords
+ nil nil nil nil
+ (font-lock-syntactic-face-function
+ . python-font-lock-syntactic-face-function)))
- (set (make-local-variable 'syntax-propertize-function)
- python-syntax-propertize-function)
+ (setq-local syntax-propertize-function
+ python-syntax-propertize-function)
- (set (make-local-variable 'indent-line-function)
- #'python-indent-line-function)
- (set (make-local-variable 'indent-region-function) #'python-indent-region)
+ (setq-local indent-line-function #'python-indent-line-function)
+ (setq-local indent-region-function #'python-indent-region)
;; Because indentation is not redundant, we cannot safely reindent code.
- (set (make-local-variable 'electric-indent-inhibit) t)
- (set (make-local-variable 'electric-indent-chars)
- (cons ?: electric-indent-chars))
+ (setq-local electric-indent-inhibit t)
+ (setq-local electric-indent-chars
+ (cons ?: electric-indent-chars))
;; Add """ ... """ pairing to electric-pair-mode.
(add-hook 'post-self-insert-hook
#'python-electric-pair-string-delimiter 'append t)
- (set (make-local-variable 'paragraph-start) "\\s-*$")
- (set (make-local-variable 'fill-paragraph-function)
- #'python-fill-paragraph)
- (set (make-local-variable 'normal-auto-fill-function) #'python-do-auto-fill)
+ (setq-local paragraph-start "\\s-*$")
+ (setq-local fill-paragraph-function #'python-fill-paragraph)
+ (setq-local normal-auto-fill-function #'python-do-auto-fill)
- (set (make-local-variable 'beginning-of-defun-function)
- #'python-nav-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function)
- #'python-nav-end-of-defun)
+ (setq-local beginning-of-defun-function #'python-nav-beginning-of-defun)
+ (setq-local end-of-defun-function #'python-nav-end-of-defun)
(add-hook 'completion-at-point-functions
#'python-completion-at-point nil 'local)
@@ -5528,26 +5637,29 @@ REPORT-FN is Flymake's callback function."
(add-hook 'post-self-insert-hook
#'python-indent-post-self-insert-function 'append 'local)
- (set (make-local-variable 'imenu-create-index-function)
- #'python-imenu-create-index)
+ (setq-local imenu-create-index-function
+ #'python-imenu-create-index)
- (set (make-local-variable 'add-log-current-defun-function)
- #'python-info-current-defun)
+ (setq-local add-log-current-defun-function
+ #'python-info-current-defun)
(add-hook 'which-func-functions #'python-info-current-defun nil t)
- (set (make-local-variable 'skeleton-further-elements)
- '((abbrev-mode nil)
- (< '(backward-delete-char-untabify (min python-indent-offset
- (current-column))))
- (^ '(- (1+ (current-indentation))))))
-
- (if (null eldoc-documentation-function)
- ;; Emacs<25
- (set (make-local-variable 'eldoc-documentation-function)
- #'python-eldoc-function)
- (add-function :before-until (local 'eldoc-documentation-function)
- #'python-eldoc-function))
+ (setq-local skeleton-further-elements
+ '((abbrev-mode nil)
+ (< '(backward-delete-char-untabify (min python-indent-offset
+ (current-column))))
+ (^ '(- (1+ (current-indentation))))))
+
+ (with-no-warnings
+ ;; suppress warnings about eldoc-documentation-function being obsolete
+ (if (null eldoc-documentation-function)
+ ;; Emacs<25
+ (setq-local eldoc-documentation-function #'python-eldoc-function)
+ (if (boundp 'eldoc-documentation-functions)
+ (add-hook 'eldoc-documentation-functions #'python-eldoc-function nil t)
+ (add-function :before-until (local 'eldoc-documentation-function)
+ #'python-eldoc-function))))
(add-to-list
'hs-special-modes-alist
@@ -5560,16 +5672,14 @@ REPORT-FN is Flymake's callback function."
python-hideshow-forward-sexp-function
nil))
- (set (make-local-variable 'outline-regexp)
- (python-rx (* space) block-start))
- (set (make-local-variable 'outline-heading-end-regexp) ":[^\n]*\n")
- (set (make-local-variable 'outline-level)
- #'(lambda ()
- "`outline-level' function for Python mode."
- (1+ (/ (current-indentation) python-indent-offset))))
+ (setq-local outline-regexp (python-rx (* space) block-start))
+ (setq-local outline-heading-end-regexp ":[^\n]*\n")
+ (setq-local outline-level
+ (lambda ()
+ "`outline-level' function for Python mode."
+ (1+ (/ (current-indentation) python-indent-offset))))
- (set (make-local-variable 'prettify-symbols-alist)
- python-prettify-symbols-alist)
+ (setq-local prettify-symbols-alist python-prettify-symbols-alist)
(python-skeleton-add-menu-items)
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 95b142d1592..01fb044161b 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -4,7 +4,7 @@
;; Authors: Yukihiro Matsumoto
;; Nobuyoshi Nakada
-;; URL: http://www.emacswiki.org/cgi-bin/wiki/RubyMode
+;; URL: https://www.emacswiki.org/cgi-bin/wiki/RubyMode
;; Created: Fri Feb 4 14:49:13 JST 1994
;; Keywords: languages ruby
;; Version: 1.2
@@ -28,18 +28,11 @@
;; Provides font-locking, indentation support, and navigation for Ruby code.
;;
-;; If you're installing manually, you should add this to your .emacs
-;; file after putting it on your load path:
-;;
-;; (autoload 'ruby-mode "ruby-mode" "Major mode for ruby files" t)
-;; (add-to-list 'auto-mode-alist '("\\.rb\\'" . ruby-mode))
-;; (add-to-list 'interpreter-mode-alist '("ruby" . ruby-mode))
-;;
;; Still needs more docstrings; search below for TODO.
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(defgroup ruby nil
"Major mode for editing Ruby code."
@@ -82,7 +75,7 @@
(defconst ruby-block-mid-re
(regexp-opt ruby-block-mid-keywords)
- "Regexp to match where the indentation gets shallower in middle of block statements.")
+ "Regexp for where the indentation gets shallower in middle of block statements.")
(defconst ruby-block-op-keywords
'("and" "or" "not")
@@ -108,7 +101,7 @@
"Regexp to match the beginning of a heredoc.")
(defconst ruby-expression-expansion-re
- "\\(?:[^\\]\\|\\=\\)\\(\\\\\\\\\\)*\\(#\\({[^}\n\\]*\\(\\\\.[^}\n\\]*\\)*}\\|\\(\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)\\)"))
+ "#\\({[^}\n\\]*\\(\\\\.[^}\n\\]*\\)*}\\|\\(?:\\$\\|@\\|@@\\)\\(\\w\\|_\\)+\\|\\$[^a-zA-Z \n]\\)"))
(defun ruby-here-doc-end-match ()
"Return a regexp to find the end of a heredoc.
@@ -142,12 +135,11 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
"Regexp to match symbols.")
(defvar ruby-use-smie t)
+(make-obsolete-variable 'ruby-use-smie nil "28.1")
(defvar ruby-mode-map
(let ((map (make-sparse-keymap)))
(unless ruby-use-smie
- (define-key map (kbd "M-C-b") 'ruby-backward-sexp)
- (define-key map (kbd "M-C-f") 'ruby-forward-sexp)
(define-key map (kbd "M-C-q") 'ruby-indent-exp))
(when ruby-use-smie
(define-key map (kbd "M-C-d") 'smie-down-list))
@@ -170,14 +162,8 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
"--"
["Toggle String Quotes" ruby-toggle-string-quotes t]
"--"
- ["Backward Sexp" ruby-backward-sexp
- :visible (not ruby-use-smie)]
- ["Backward Sexp" backward-sexp
- :visible ruby-use-smie]
- ["Forward Sexp" ruby-forward-sexp
- :visible (not ruby-use-smie)]
- ["Forward Sexp" forward-sexp
- :visible ruby-use-smie]
+ ["Backward Sexp" backward-sexp t]
+ ["Forward Sexp" forward-sexp t]
["Indent Sexp" ruby-indent-exp
:visible (not ruby-use-smie)]
["Indent Sexp" prog-indent-sexp
@@ -305,6 +291,7 @@ Only has effect when `ruby-use-smie' is nil."
(defcustom ruby-encoding-map
'((us-ascii . nil) ;; Do not put coding: us-ascii
+ (utf-8 . nil) ;; Default since Ruby 2.0
(shift-jis . cp932) ;; Emacs charset name of Shift_JIS
(shift_jis . cp932) ;; MIME charset name of Shift_JIS
(japanese-cp932 . cp932)) ;; Emacs charset name of CP932
@@ -345,7 +332,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(require 'smie)
;; Here's a simplified BNF grammar, for reference:
-;; http://www.cse.buffalo.edu/~regan/cse305/RubyBNF.pdf
+;; https://www.cse.buffalo.edu/~regan/cse305/RubyBNF.pdf
(defconst ruby-smie-grammar
(smie-prec2->grammar
(smie-merge-prec2s
@@ -415,7 +402,10 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(or (and (bolp)
;; Newline is escaped.
(not (eq (char-before (1- (point))) ?\\)))
- (memq (char-before) '(?\; ?=)))))
+ (eq (char-before) ?\;)
+ (and (eq (char-before) ?=)
+ (equal (syntax-after (1- (point)))
+ (string-to-syntax "."))))))
(defun ruby-smie--implicit-semi-p ()
(save-excursion
@@ -609,7 +599,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(`(:before . ,(or "(" "[" "{"))
(cond
((and (equal token "{")
- (not (smie-rule-prev-p "(" "{" "[" "," "=>" "=" "return" ";"))
+ (not (smie-rule-prev-p "(" "{" "[" "," "=>" "=" "return" ";" "do"))
(save-excursion
(forward-comment -1)
(not (eq (preceding-char) ?:))))
@@ -741,10 +731,10 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(defun ruby-mode-variables ()
"Set up initial buffer-local variables for Ruby mode."
(setq indent-tabs-mode ruby-indent-tabs-mode)
- (if ruby-use-smie
- (smie-setup ruby-smie-grammar #'ruby-smie-rules
- :forward-token #'ruby-smie--forward-token
- :backward-token #'ruby-smie--backward-token)
+ (smie-setup ruby-smie-grammar #'ruby-smie-rules
+ :forward-token #'ruby-smie--forward-token
+ :backward-token #'ruby-smie--backward-token)
+ (unless ruby-use-smie
(setq-local indent-line-function #'ruby-indent-line))
(setq-local comment-start "# ")
(setq-local comment-end "")
@@ -771,7 +761,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'."
(defun ruby--detect-encoding ()
(if (eq ruby-insert-encoding-magic-comment 'always-utf8)
- "utf-8"
+ 'utf-8
(let ((coding-system
(or save-buffer-coding-system
buffer-file-coding-system)))
@@ -780,12 +770,11 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'."
(or (coding-system-get coding-system 'mime-charset)
(coding-system-change-eol-conversion coding-system nil))))
(if coding-system
- (symbol-name
- (if ruby-use-encoding-map
- (let ((elt (assq coding-system ruby-encoding-map)))
- (if elt (cdr elt) coding-system))
- coding-system))
- "ascii-8bit"))))
+ (if ruby-use-encoding-map
+ (let ((elt (assq coding-system ruby-encoding-map)))
+ (if elt (cdr elt) coding-system))
+ coding-system)
+ 'ascii-8bit))))
(defun ruby--encoding-comment-required-p ()
(or (eq ruby-insert-encoding-magic-comment 'always-utf8)
@@ -794,24 +783,25 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'."
(defun ruby-mode-set-encoding ()
"Insert a magic comment header with the proper encoding if necessary."
(save-excursion
- (widen)
- (goto-char (point-min))
- (when (ruby--encoding-comment-required-p)
+ (save-restriction
+ (widen)
(goto-char (point-min))
- (let ((coding-system (ruby--detect-encoding)))
- (when coding-system
- (if (looking-at "^#!") (beginning-of-line 2))
- (cond ((looking-at "\\s *#\\s *.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)")
- ;; update existing encoding comment if necessary
- (unless (string= (match-string 2) coding-system)
- (goto-char (match-beginning 2))
- (delete-region (point) (match-end 2))
- (insert coding-system)))
- ((looking-at "\\s *#.*coding\\s *[:=]"))
- (t (when ruby-insert-encoding-magic-comment
- (ruby--insert-coding-comment coding-system))))
- (when (buffer-modified-p)
- (basic-save-buffer-1)))))))
+ (when (ruby--encoding-comment-required-p)
+ (goto-char (point-min))
+ (let ((coding-system (ruby--detect-encoding)))
+ (when coding-system
+ (if (looking-at "^#!") (beginning-of-line 2))
+ (cond ((looking-at "\\s *#.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)")
+ ;; update existing encoding comment if necessary
+ (unless (string= (match-string 2) coding-system)
+ (goto-char (match-beginning 2))
+ (delete-region (point) (match-end 2))
+ (insert (symbol-name coding-system))))
+ ((looking-at "\\s *#.*coding\\s *[:=]"))
+ (t (when ruby-insert-encoding-magic-comment
+ (ruby--insert-coding-comment coding-system))))
+ (when (buffer-modified-p)
+ (basic-save-buffer-1))))))))
(defvar ruby--electric-indent-chars '(?. ?\) ?} ?\]))
@@ -1060,22 +1050,12 @@ delimiter."
(goto-char (point))
)
((looking-at "[\\[{(]")
- (let ((deep (ruby-deep-indent-paren-p (char-after))))
- (if (and deep (or (not (eq (char-after) ?\{)) (ruby-expr-beg)))
- (progn
- (and (eq deep 'space) (looking-at ".\\s +[^# \t\n]")
- (setq pnt (1- (match-end 0))))
- (setq nest (cons (cons (char-after (point)) pnt) nest))
- (setq pcol (cons (cons pnt depth) pcol))
- (setq depth 0))
- (setq nest (cons (cons (char-after (point)) pnt) nest))
- (setq depth (1+ depth))))
+ (setq nest (cons (cons (char-after (point)) pnt) nest))
+ (setq depth (1+ depth))
(goto-char pnt)
)
((looking-at "[])}]")
- (if (ruby-deep-indent-paren-p (matching-paren (char-after)))
- (setq depth (cdr (car pcol)) pcol (cdr pcol))
- (setq depth (1- depth)))
+ (setq depth (1- depth))
(setq nest (cdr nest))
(goto-char pnt))
((looking-at ruby-block-end-re)
@@ -1388,7 +1368,8 @@ move forward."
The defun begins at or after the point. This function is called
by `end-of-defun'."
(interactive "p")
- (ruby-forward-sexp)
+ (with-suppressed-warnings ((obsolete ruby-forward-sexp))
+ (ruby-forward-sexp))
(let (case-fold-search)
(when (looking-back (concat "^\\s *" ruby-block-end-re)
(line-beginning-position))
@@ -1477,11 +1458,14 @@ With ARG, move out of multiple blocks."
(defun ruby-forward-sexp (&optional arg)
"Move forward across one balanced expression (sexp).
With ARG, do it many times. Negative ARG means move backward."
+ (declare (obsolete forward-sexp "28.1"))
;; TODO: Document body
(interactive "p")
(cond
(ruby-use-smie (forward-sexp arg))
- ((and (numberp arg) (< arg 0)) (ruby-backward-sexp (- arg)))
+ ((and (numberp arg) (< arg 0))
+ (with-suppressed-warnings ((obsolete ruby-backward-sexp))
+ (ruby-backward-sexp (- arg))))
(t
(let ((i (or arg 1)))
(condition-case nil
@@ -1525,11 +1509,14 @@ With ARG, do it many times. Negative ARG means move backward."
(defun ruby-backward-sexp (&optional arg)
"Move backward across one balanced expression (sexp).
With ARG, do it many times. Negative ARG means move forward."
+ (declare (obsolete backward-sexp "28.1"))
;; TODO: Document body
(interactive "p")
(cond
(ruby-use-smie (backward-sexp arg))
- ((and (numberp arg) (< arg 0)) (ruby-forward-sexp (- arg)))
+ ((and (numberp arg) (< arg 0))
+ (with-suppressed-warnings ((obsolete ruby-forward-sexp))
+ (ruby-forward-sexp (- arg))))
(t
(let ((i (or arg 1)))
(condition-case nil
@@ -1611,13 +1598,16 @@ See `add-log-current-defun-function'."
(let* ((indent 0) mname mlist
(start (point))
(make-definition-re
- (lambda (re)
+ (lambda (re &optional method-name?)
(concat "^[ \t]*" re "[ \t]+"
"\\("
;; \\. and :: for class methods
- "\\([A-Za-z_]" ruby-symbol-re "*[?!]?\\|\\.\\|::" "\\)"
+ "\\([A-Za-z_]" ruby-symbol-re "*[?!]?"
+ "\\|"
+ (if method-name? ruby-operator-re "\\.")
+ "\\|::" "\\)"
"+\\)")))
- (definition-re (funcall make-definition-re ruby-defun-beg-re))
+ (definition-re (funcall make-definition-re ruby-defun-beg-re t))
(module-re (funcall make-definition-re "\\(class\\|module\\)")))
;; Get the current method definition (or class/module).
(when (re-search-backward definition-re nil t)
@@ -1681,7 +1671,8 @@ See `add-log-current-defun-function'."
(defun ruby-block-contains-point (pt)
(save-excursion
(save-match-data
- (ruby-forward-sexp)
+ (with-suppressed-warnings ((obsolete ruby-forward-sexp))
+ (ruby-forward-sexp))
(> (point) pt))))
(defun ruby-brace-to-do-end (orig end)
@@ -1759,7 +1750,8 @@ If the result is do-end block, it will always be multiline."
(progn
(goto-char (or (match-beginning 1) (match-beginning 2)))
(setq beg (point))
- (save-match-data (ruby-forward-sexp))
+ (with-suppressed-warnings ((obsolete ruby-forward-sexp))
+ (save-match-data (ruby-forward-sexp)))
(setq end (point))
(> end start)))
(if (match-beginning 1)
@@ -1810,12 +1802,12 @@ FEATURE-NAME is a relative file name, file extension is optional.
This commands delegates to `gem which', which searches both
installed gems and the standard library. When called
interactively, defaults to the feature name in the `require'
-statement around point."
+or `gem' statement around point."
(interactive)
(unless feature-name
(let ((init (save-excursion
(forward-line 0)
- (when (looking-at "require [\"']\\(.*\\)[\"']")
+ (when (looking-at "\\(?:require\\| *gem\\) [\"']\\(.*?\\)[\"']")
(match-string 1)))))
(setq feature-name (read-string "Feature name: " init))))
(let ((out
@@ -1875,10 +1867,18 @@ It will be properly highlighted even when the call omits parens.")
'syntax-table (string-to-syntax "_"))
(string-to-syntax "'"))))
;; Symbols with special characters.
- ("\\(^\\|[^:]\\)\\(:\\([-+~]@?\\|[/%&|^`]\\|\\*\\*?\\|<\\(<\\|=>?\\)?\\|>[>=]?\\|===?\\|=~\\|![~=]?\\|\\[\\]=?\\)\\)"
- (3 (unless (nth 8 (syntax-ppss (match-beginning 3)))
+ (":\\([-+~]@?\\|[/%&|^`]\\|\\*\\*?\\|<\\(<\\|=>?\\)?\\|>[>=]?\\|===?\\|=~\\|![~=]?\\|\\[\\]=?\\)"
+ (1 (unless (or
+ (nth 8 (syntax-ppss (match-beginning 1)))
+ (eq (char-before (match-beginning 0)) ?:))
(goto-char (match-end 0))
(string-to-syntax "_"))))
+ ;; Symbols ending with '=' (bug#42846).
+ (":[[:alpha:]][[:alnum:]_]*\\(=\\)"
+ (1 (unless (or (nth 8 (syntax-ppss))
+ (eq (char-before (match-beginning 0)) ?:)
+ (eq (char-after (match-end 3)) ?>))
+ (string-to-syntax "_"))))
;; Part of method name when at the end of it.
("[!?]"
(0 (unless (save-excursion
@@ -1893,9 +1893,14 @@ It will be properly highlighted even when the call omits parens.")
;; (semi-important for indentation).
("\\(:\\)\\(?:[({]\\|\\[[^]]\\)"
(1 (string-to-syntax ".")))
- ;; Regular expressions. Start with matching unescaped slash.
- ("\\(?:\\=\\|[^\\]\\)\\(?:\\\\\\\\\\)*\\(/\\)"
- (1 (let ((state (save-excursion (syntax-ppss (match-beginning 1)))))
+ ;; Regular expressions.
+ ("\\(/\\)"
+ (1
+ ;; No unescaped slashes in front.
+ (when (save-excursion
+ (forward-char -1)
+ (cl-evenp (skip-chars-backward "\\\\")))
+ (let ((state (save-excursion (syntax-ppss (match-beginning 1)))))
(when (or
;; Beginning of a regexp.
(and (null (nth 8 state))
@@ -1908,11 +1913,17 @@ It will be properly highlighted even when the call omits parens.")
;; string interpolation inside, or span
;; several lines.
(eq ?/ (nth 3 state)))
- (string-to-syntax "\"/")))))
+ (string-to-syntax "\"/"))))))
;; Expression expansions in strings. We're handling them
;; here, so that the regexp rule never matches inside them.
(ruby-expression-expansion-re
- (0 (ignore (ruby-syntax-propertize-expansion))))
+ (0 (ignore
+ (if (save-excursion
+ (goto-char (match-beginning 0))
+ ;; The hash character is not escaped.
+ (cl-evenp (skip-chars-backward "\\\\")))
+ (ruby-syntax-propertize-expansion)
+ (goto-char (match-beginning 1))))))
("^=en\\(d\\)\\_>" (1 "!"))
("^\\(=\\)begin\\_>" (1 "!"))
;; Handle here documents.
@@ -2002,8 +2013,8 @@ It will be properly highlighted even when the call omits parens.")
(defun ruby-syntax-propertize-expansion ()
;; Save the match data to a text property, for font-locking later.
;; Set the syntax of all double quotes and backticks to punctuation.
- (let* ((beg (match-beginning 2))
- (end (match-end 2))
+ (let* ((beg (match-beginning 0))
+ (end (match-end 0))
(state (and beg (save-excursion (syntax-ppss beg)))))
(when (ruby-syntax-expansion-allowed-p state)
(put-text-property beg (1+ beg) 'ruby-expansion-match-data
@@ -2116,11 +2127,9 @@ It will be properly highlighted even when the call omits parens.")
"loop"
"open"
"p"
- "print"
"printf"
"proc"
"putc"
- "puts"
"require"
"require_relative"
"spawn"
@@ -2169,9 +2178,11 @@ It will be properly highlighted even when the call omits parens.")
"fork"
"global_variables"
"local_variables"
+ "print"
"private"
"protected"
"public"
+ "puts"
"raise"
"rand"
"readline"
@@ -2195,12 +2206,7 @@ It will be properly highlighted even when the call omits parens.")
(0 font-lock-builtin-face))
;; Symbols.
("\\(^\\|[^:]\\)\\(:@\\{0,2\\}\\(?:\\sw\\|\\s_\\)+\\)"
- (2 font-lock-constant-face)
- (3 (unless (and (eq (char-before (match-end 3)) ?=)
- (eq (char-after (match-end 3)) ?>))
- ;; bug#18644
- font-lock-constant-face)
- nil t))
+ (2 font-lock-constant-face))
;; Special globals.
(,(concat "\\$\\(?:[:\"!@;,/._><\\$?~=*&`'+0-9]\\|-[0adFiIlpvw]\\|"
(regexp-opt '("LOAD_PATH" "LOADED_FEATURES" "PROGRAM_NAME"
@@ -2235,7 +2241,7 @@ It will be properly highlighted even when the call omits parens.")
(1 font-lock-builtin-face))
;; Expression expansion.
(ruby-match-expression-expansion
- 2 font-lock-variable-name-face t)
+ 0 font-lock-variable-name-face t)
;; Negation char.
("\\(?:^\\|[^[:alnum:]_]\\)\\(!+\\)[^=~]"
1 font-lock-negation-char-face)
@@ -2415,6 +2421,15 @@ If there is no Rubocop config file, Rubocop will be passed a flag
report-fn
args))
+(defconst ruby--prettify-symbols-alist
+ '(("<=" . ?≤)
+ (">=" . ?≥)
+ ("->" . ?→)
+ ("=>" . ?⇒)
+ ("::" . ?∷)
+ ("lambda" . ?λ))
+ "Value for `prettify-symbols-alist' in `ruby-mode'.")
+
;;;###autoload
(define-derived-mode ruby-mode prog-mode "Ruby"
"Major mode for editing Ruby code."
@@ -2431,6 +2446,7 @@ If there is no Rubocop config file, Rubocop will be passed a flag
(setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil
((?_ . "w"))))
+ (setq-local prettify-symbols-alist ruby--prettify-symbols-alist)
(setq-local syntax-propertize-function #'ruby-syntax-propertize))
@@ -2444,7 +2460,7 @@ If there is no Rubocop config file, Rubocop will be passed a flag
"\\)"
"\\|/"
"\\(?:Gem\\|Rake\\|Cap\\|Thor"
- "\\|Puppet\\|Berks"
+ "\\|Puppet\\|Berks\\|Brew"
"\\|Vagrant\\|Guard\\|Pod\\)file"
"\\)\\'"))
'ruby-mode))
diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index 91e6d6a9098..57351a7308d 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -28,7 +28,7 @@
;; the Lisp mode documented in the Emacs manual. `dsssl-mode' is a
;; variant of scheme-mode for editing DSSSL specifications for SGML
;; documents. [As of Apr 1997, some pointers for DSSSL may be found,
-;; for instance, at <URL:http://www.sil.org/sgml/related.html#dsssl>.]
+;; for instance, at <URL:https://www.sil.org/sgml/related.html#dsssl>.]
;; All these Lisp-ish modes vary basically in details of the language
;; syntax they highlight/indent/index, but dsssl-mode uses "^;;;" as
;; the page-delimiter since ^L isn't normally a valid SGML character.
@@ -116,7 +116,7 @@
(defvar scheme-imenu-generic-expression
'((nil
- "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4)
+ "^(define\\(?:-\\(?:generic\\(?:-procedure\\)?\\|method\\)\\)?\\s-+(?\\(\\sw+\\)" 1)
("Types"
"^(define-class\\s-+(?\\(\\sw+\\)" 1)
("Macros"
@@ -162,25 +162,26 @@
(defvar scheme-mode-line-process "")
(defvar scheme-mode-map
- (let ((smap (make-sparse-keymap))
- (map (make-sparse-keymap "Scheme")))
- (set-keymap-parent smap lisp-mode-shared-map)
- (define-key smap [menu-bar scheme] (cons "Scheme" map))
- (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme))
- (define-key map [uncomment-region]
- '("Uncomment Out Region" . (lambda (beg end)
- (interactive "r")
- (comment-region beg end '(4)))))
- (define-key map [comment-region] '("Comment Out Region" . comment-region))
- (define-key map [indent-region] '("Indent Region" . indent-region))
- (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
- (put 'comment-region 'menu-enable 'mark-active)
- (put 'uncomment-region 'menu-enable 'mark-active)
- (put 'indent-region 'menu-enable 'mark-active)
- smap)
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map lisp-mode-shared-map)
+ map)
"Keymap for Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
+(easy-menu-define scheme-mode-menu scheme-mode-map
+ "Menu for Scheme mode."
+ '("Scheme"
+ ["Indent Line" lisp-indent-line]
+ ["Indent Region" indent-region
+ :enable mark-active]
+ ["Comment Out Region" comment-region
+ :enable mark-active]
+ ["Uncomment Out Region" (lambda (beg end)
+ (interactive "r")
+ (comment-region beg end '(4)))
+ :enable mark-active]
+ ["Run Inferior Scheme" run-scheme]))
+
;; Used by cmuscheme
(defun scheme-mode-commands (map)
;;(define-key map "\t" 'indent-for-tab-command) ; default
@@ -215,8 +216,7 @@ Blank lines separate paragraphs. Semicolons start comments.
(defcustom scheme-mit-dialect t
"If non-nil, scheme mode is specialized for MIT Scheme.
Set this to nil if you normally use another dialect."
- :type 'boolean
- :group 'scheme)
+ :type 'boolean)
(defcustom dsssl-sgml-declaration
"<!DOCTYPE style-sheet PUBLIC \"-//James Clark//DTD DSSSL Style Sheet//EN\">
@@ -226,26 +226,22 @@ If it is defined as a string this will be inserted into an empty buffer
which is in `dsssl-mode'. It is typically James Clark's style-sheet
doctype, as required for Jade."
:type '(choice (string :tag "Specified string")
- (const :tag "None" :value nil))
- :group 'scheme)
+ (const :tag "None" :value nil)))
(defcustom scheme-mode-hook nil
"Normal hook run when entering `scheme-mode'.
See `run-hooks'."
- :type 'hook
- :group 'scheme)
+ :type 'hook)
(defcustom dsssl-mode-hook nil
"Normal hook run when entering `dsssl-mode'.
See `run-hooks'."
- :type 'hook
- :group 'scheme)
+ :type 'hook)
;; This is shared by cmuscheme and xscheme.
(defcustom scheme-program-name "scheme"
"Program invoked by the `run-scheme' command."
- :type 'string
- :group 'scheme)
+ :type 'string)
(defvar dsssl-imenu-generic-expression
;; Perhaps this should also look for the style-sheet DTD tags. I'm
@@ -303,7 +299,9 @@ See `run-hooks'."
(concat
"(" (regexp-opt
'("begin" "call-with-current-continuation" "call/cc"
- "call-with-input-file" "call-with-output-file" "case" "cond"
+ "call-with-input-file" "call-with-output-file"
+ "call-with-port"
+ "case" "cond"
"do" "else" "for-each" "if" "lambda" "λ"
"let" "let*" "let-syntax" "letrec" "letrec-syntax"
;; R6RS library subforms.
@@ -429,12 +427,10 @@ that variable's value is a string."
'(1 font-lock-keyword-face)
'(4 font-lock-function-name-face))
(cons
- (concat "(\\("
- ;; (make-regexp '("case" "cond" "else" "if" "lambda"
- ;; "let" "let*" "letrec" "and" "or" "map" "with-mode"))
- "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|"
- "l\\(ambda\\|et\\(\\|\\*\\|rec\\)\\)\\|map\\|or\\|with-mode"
- "\\)\\>")
+ (concat "(" (regexp-opt
+ '("case" "cond" "else" "if" "lambda"
+ "let" "let*" "letrec" "and" "or" "map" "with-mode")
+ 'words))
1)
;; DSSSL syntax
'("(\\(element\\|mode\\|declare-\\w+\\)\\>[ \t]*\\(\\sw+\\)"
@@ -548,6 +544,7 @@ indentation."
(put 'library 'scheme-indent-function 1) ; R6RS
(put 'call-with-input-file 'scheme-indent-function 1)
+(put 'call-with-port 'scheme-indent-function 1)
(put 'with-input-from-file 'scheme-indent-function 1)
(put 'with-input-from-port 'scheme-indent-function 1)
(put 'call-with-output-file 'scheme-indent-function 1)
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index a9ad3113e19..91db4ae21cb 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -4,7 +4,7 @@
;; Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
-;; Version: 2.0f
+;; Old-Version: 2.0f
;; Maintainer: emacs-devel@gnu.org
;; Keywords: languages, unix
@@ -64,61 +64,10 @@
;; * Indent right half sh-basic-offset
;; / Indent left half sh-basic-offset.
;;
-;; There are 4 commands to help set the indentation variables:
-;;
-;; `sh-show-indent'
-;; This shows what variable controls the indentation of the current
-;; line and its value.
-;;
-;; `sh-set-indent'
-;; This allows you to set the value of the variable controlling the
-;; current line's indentation. You can enter a number or one of a
-;; number of special symbols to denote the value of sh-basic-offset,
-;; or its negative, or half it, or twice it, etc. If you've used
-;; cc-mode this should be familiar. If you forget which symbols are
-;; valid simply press C-h at the prompt.
-;;
-;; `sh-learn-line-indent'
-;; Simply make the line look the way you want it, then invoke this
-;; command. It will set the variable to the value that makes the line
-;; indent like that. If called with a prefix argument then it will set
-;; the value to one of the symbols if applicable.
-;;
-;; `sh-learn-buffer-indent'
-;; This is the deluxe function! It "learns" the whole buffer (use
-;; narrowing if you want it to process only part). It outputs to a
-;; buffer *indent* any conflicts it finds, and all the variables it has
-;; learned. This buffer is a sort of Occur mode buffer, allowing you to
-;; easily find where something was set. It is popped to automatically
-;; if there are any conflicts found or if `sh-popup-occur-buffer' is
-;; non-nil.
-;; `sh-indent-comment' will be set if all comments follow the same
-;; pattern; if they don't it will be set to nil.
-;; Whether `sh-basic-offset' is set is determined by variable
-;; `sh-learn-basic-offset'.
-;;
-;; Unfortunately, `sh-learn-buffer-indent' can take a long time to run
-;; (e.g. if there are large case statements). Perhaps it does not make
-;; sense to run it on large buffers: if lots of lines have different
-;; indentation styles it will produce a lot of diagnostics in the
-;; *indent* buffer; if there is a consistent style then running
-;; `sh-learn-buffer-indent' on a small region of the buffer should
-;; suffice.
-;;
;; Saving indentation values
;; -------------------------
-;; After you've learned the values in a buffer, how to you remember
-;; them? Originally I had hoped that `sh-learn-buffer-indent'
-;; would make this unnecessary; simply learn the values when you visit
-;; the buffer.
-;; You can do this automatically like this:
-;; (add-hook 'sh-set-shell-hook #'sh-learn-buffer-indent)
-;;
-;; However... `sh-learn-buffer-indent' is extremely slow,
-;; especially on large-ish buffer. Also, if there are conflicts the
-;; "last one wins" which may not produce the desired setting.
-;;
-;; So...There is a minimal way of being able to save indentation values and
+;; After you've learned the values in a buffer, how to you remember them?
+;; There is a minimal way of being able to save indentation values and
;; to reload them in another buffer or at another point in time.
;;
;; Use `sh-name-style' to give a name to the indentation settings of
@@ -132,7 +81,7 @@
;; Indentation variables - buffer local or global?
;; ----------------------------------------------
;; I think that often having them buffer-local makes sense,
-;; especially if one is using `sh-learn-buffer-indent'. However, if
+;; especially if one is using `smie-config-guess'. However, if
;; a user sets values using customization, these changes won't appear
;; to work if the variables are already local!
;;
@@ -175,18 +124,10 @@
;; - Indenting many lines is slow. It currently does each line
;; independently, rather than saving state information.
;;
-;; - `sh-learn-buffer-indent' is extremely slow.
-;;
-;; - "case $x in y) echo ;; esac)" the last ) is mis-identified as being
-;; part of a case-pattern. You need to add a semi-colon after "esac" to
-;; coerce sh-script into doing the right thing.
-;;
;; - "echo $z in ps | head)" the last ) is mis-identified as being part of
;; a case-pattern. You need to put the "in" between quotes to coerce
;; sh-script into doing the right thing.
;;
-;; - A line starting with "}>foo" is not indented like "} >foo".
-;;
;; Richard Sharman <rsharman@pobox.com> June 1999.
;;; Code:
@@ -445,6 +386,7 @@ name symbol."
?~ "_"
?, "_"
?= "."
+ ?/ "."
?\; "."
?| "."
?& "."
@@ -461,8 +403,7 @@ This is buffer-local in every such buffer.")
"Syntax-table used in Shell-Script mode. See `sh-feature'.")
(defvar sh-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(define-key map "\C-c(" 'sh-function)
(define-key map "\C-c\C-w" 'sh-while)
(define-key map "\C-c\C-u" 'sh-until)
@@ -474,10 +415,10 @@ This is buffer-local in every such buffer.")
(define-key map "\C-c\C-i" 'sh-if)
(define-key map "\C-c\C-f" 'sh-for)
(define-key map "\C-c\C-c" 'sh-case)
- (define-key map "\C-c?" 'sh-show-indent)
- (define-key map "\C-c=" 'sh-set-indent)
- (define-key map "\C-c<" 'sh-learn-line-indent)
- (define-key map "\C-c>" 'sh-learn-buffer-indent)
+ (define-key map "\C-c?" #'smie-config-show-indent)
+ (define-key map "\C-c=" #'smie-config-set-indent)
+ (define-key map "\C-c<" #'smie-config-set-indent)
+ (define-key map "\C-c>" #'smie-config-guess)
(define-key map "\C-c\C-\\" 'sh-backslash-region)
(define-key map "\C-c+" 'sh-add)
@@ -492,77 +433,57 @@ This is buffer-local in every such buffer.")
(define-key map "\C-c:" 'sh-set-shell)
(define-key map [remap backward-sentence] 'sh-beginning-of-command)
(define-key map [remap forward-sentence] 'sh-end-of-command)
- (define-key map [menu-bar sh-script] (cons "Sh-Script" menu-map))
- (define-key menu-map [sh-learn-buffer-indent]
- '(menu-item "Learn buffer indentation" sh-learn-buffer-indent
- :help "Learn how to indent the buffer the way it currently is."))
- (define-key menu-map [sh-learn-line-indent]
- '(menu-item "Learn line indentation" sh-learn-line-indent
- :help "Learn how to indent a line as it currently is indented"))
- (define-key menu-map [sh-show-indent]
- '(menu-item "Show indentation" sh-show-indent
- :help "Show the how the current line would be indented"))
- (define-key menu-map [sh-set-indent]
- '(menu-item "Set indentation" sh-set-indent
- :help "Set the indentation for the current line"))
-
- (define-key menu-map [sh-pair]
- '(menu-item "Insert braces and quotes in pairs"
- electric-pair-mode
- :button (:toggle . (bound-and-true-p electric-pair-mode))
- :help "Inserting a brace or quote automatically inserts the matching pair"))
-
- (define-key menu-map [sh-s0] '("--"))
- ;; Insert
- (define-key menu-map [sh-function]
- '(menu-item "Function..." sh-function
- :help "Insert a function definition"))
- (define-key menu-map [sh-add]
- '(menu-item "Addition..." sh-add
- :help "Insert an addition of VAR and prefix DELTA for Bourne (type) shell"))
- (define-key menu-map [sh-until]
- '(menu-item "Until Loop" sh-until
- :help "Insert an until loop"))
- (define-key menu-map [sh-repeat]
- '(menu-item "Repeat Loop" sh-repeat
- :help "Insert a repeat loop definition"))
- (define-key menu-map [sh-while]
- '(menu-item "While Loop" sh-while
- :help "Insert a while loop"))
- (define-key menu-map [sh-getopts]
- '(menu-item "Options Loop" sh-while-getopts
- :help "Insert a while getopts loop."))
- (define-key menu-map [sh-indexed-loop]
- '(menu-item "Indexed Loop" sh-indexed-loop
- :help "Insert an indexed loop from 1 to n."))
- (define-key menu-map [sh-select]
- '(menu-item "Select Statement" sh-select
- :help "Insert a select statement "))
- (define-key menu-map [sh-if]
- '(menu-item "If Statement" sh-if
- :help "Insert an if statement"))
- (define-key menu-map [sh-for]
- '(menu-item "For Loop" sh-for
- :help "Insert a for loop"))
- (define-key menu-map [sh-case]
- '(menu-item "Case Statement" sh-case
- :help "Insert a case/switch statement"))
- (define-key menu-map [sh-s1] '("--"))
- (define-key menu-map [sh-exec]
- '(menu-item "Execute region" sh-execute-region
- :help "Pass optional header and region to a subshell for noninteractive execution"))
- (define-key menu-map [sh-exec-interpret]
- '(menu-item "Execute script..." executable-interpret
- :help "Run script with user-specified args, and collect output in a buffer"))
- (define-key menu-map [sh-set-shell]
- '(menu-item "Set shell type..." sh-set-shell
- :help "Set this buffer's shell to SHELL (a string)"))
- (define-key menu-map [sh-backslash-region]
- '(menu-item "Backslash region" sh-backslash-region
- :help "Insert, align, or delete end-of-line backslashes on the lines in the region."))
map)
"Keymap used in Shell-Script mode.")
+(easy-menu-define sh-mode-menu sh-mode-map
+ "Menu for Shell-Script mode."
+ '("Sh-Script"
+ ["Backslash region" sh-backslash-region
+ :help "Insert, align, or delete end-of-line backslashes on the lines in the region."]
+ ["Set shell type..." sh-set-shell
+ :help "Set this buffer's shell to SHELL (a string)"]
+ ["Execute script..." executable-interpret
+ :help "Run script with user-specified args, and collect output in a buffer"]
+ ["Execute region" sh-execute-region
+ :help "Pass optional header and region to a subshell for noninteractive execution"]
+ "---"
+ ;; Insert
+ ["Case Statement" sh-case
+ :help "Insert a case/switch statement"]
+ ["For Loop" sh-for
+ :help "Insert a for loop"]
+ ["If Statement" sh-if
+ :help "Insert an if statement"]
+ ["Select Statement" sh-select
+ :help "Insert a select statement "]
+ ["Indexed Loop" sh-indexed-loop
+ :help "Insert an indexed loop from 1 to n."]
+ ["Options Loop" sh-while-getopts
+ :help "Insert a while getopts loop."]
+ ["While Loop" sh-while
+ :help "Insert a while loop"]
+ ["Repeat Loop" sh-repeat
+ :help "Insert a repeat loop definition"]
+ ["Until Loop" sh-until
+ :help "Insert an until loop"]
+ ["Addition..." sh-add
+ :help "Insert an addition of VAR and prefix DELTA for Bourne (type) shell"]
+ ["Function..." sh-function
+ :help "Insert a function definition"]
+ "---"
+ ;; Other
+ ["Insert braces and quotes in pairs" electric-pair-mode
+ :style toggle
+ :selected (bound-and-true-p electric-pair-mode)
+ :help "Inserting a brace or quote automatically inserts the matching pair"]
+ ["Set indentation" smie-config-set-indent
+ :help "Set the indentation for the current line"]
+ ["Show indentation" smie-config-show-indent
+ :help "Show the how the current line would be indented"]
+ ["Learn buffer indentation" smie-config-guess
+ :help "Learn how to indent the buffer the way it currently is."]))
+
(defvar sh-skeleton-pair-default-alist '((?\( _ ?\)) (?\))
(?\[ ?\s _ ?\s ?\]) (?\])
(?{ _ ?}) (?\}))
@@ -602,10 +523,9 @@ sign. See `sh-feature'."
:group 'sh-script)
-(defvar sh-header-marker nil
+(defvar-local 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:]:]\\)"
@@ -900,7 +820,7 @@ See `sh-feature'.")
font-lock-variable-name-face))
(rc sh-append es)
- (bash sh-append sh ("\\$(\\(\\sw+\\)" (1 'sh-quoted-exec t) ))
+ (bash sh-append sh ("\\$(\\([^)\n]+\\)" (1 'sh-quoted-exec t) ))
(sh sh-append shell
;; Variable names.
("\\$\\({#?\\)?\\([[:alpha:]_][[:alnum:]_]*\\|[-#?@!]\\)" 2
@@ -1158,7 +1078,7 @@ subshells can nest."
(")" (0 (sh-font-lock-paren (match-beginning 0))))
;; Highlight (possibly nested) subshells inside "" quoted
;; regions correctly.
- ("\"\\(?:\\(?:[^\\\"]\\|\\\\.\\)*?\\)??\\(\\$(\\|`\\)"
+ ("\"\\(?:[^\\\"]\\|\\\\.\\)*?\\(\\$(\\|`\\)"
(1 (ignore
(if (nth 8 (save-excursion (syntax-ppss (match-beginning 0))))
(goto-char (1+ (match-beginning 0)))
@@ -1196,20 +1116,8 @@ and command `sh-reset-indent-vars-to-global-values'."
:options '(sh-electric-here-document-mode)
:group 'sh-script)
-(defcustom sh-learn-basic-offset nil
- "When `sh-guess-basic-offset' should learn `sh-basic-offset'.
-
-nil mean: never.
-t means: only if there seems to be an obvious value.
-Anything else means: whenever we have a \"good guess\" as to the value."
- :type '(choice
- (const :tag "Never" nil)
- (const :tag "Only if sure" t)
- (const :tag "If have a good guess" usually))
- :group 'sh-indentation)
-
(defcustom sh-popup-occur-buffer nil
- "Controls when `sh-learn-buffer-indent' pops the `*indent*' buffer.
+ "Controls when `smie-config-guess' pops the `*indent*' buffer.
If t it is always shown. If nil, it is shown only when there
are conflicts."
:type '(choice
@@ -1217,14 +1125,6 @@ are conflicts."
(const :tag "Always" t))
:group 'sh-indentation)
-(defcustom sh-blink t
- "If non-nil, `sh-show-indent' shows the line indentation is relative to.
-The position on the line is not necessarily meaningful.
-In some cases the line will be the matching keyword, but this is not
-always the case."
- :type 'boolean
- :group 'sh-indentation)
-
(defcustom sh-first-lines-indent 0
"The indentation of the first non-blank non-comment line.
Usually 0 meaning first column.
@@ -1567,11 +1467,9 @@ following commands are available, based on the current shell's syntax:
\\[sh-while] while loop
For sh and rc shells indentation commands are:
-\\[sh-show-indent] Show the variable controlling this line's indentation.
-\\[sh-set-indent] Set then variable controlling this line's indentation.
-\\[sh-learn-line-indent] Change the indentation variable so this line
-would indent to the way it currently is.
-\\[sh-learn-buffer-indent] Set the indentation variables so the
+\\[smie-config-show-indent] Show the rules controlling this line's indentation.
+\\[smie-config-set-indent] Change the rules controlling this line's indentation.
+\\[smie-config-guess] Try to tweak the indentation rules so the
buffer indents as it currently is indented.
@@ -1639,7 +1537,7 @@ with your script for an edit-interpret-debug cycle."
(sh-set-shell
(cond ((save-excursion
(goto-char (point-min))
- (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)"))
+ (looking-at auto-mode-interpreter-regexp))
(match-string 2))
((not buffer-file-name) sh-shell-file)
;; Checks that use `buffer-file-name' follow.
@@ -1698,6 +1596,8 @@ This adds rules for comments and assignments."
;;; Completion
+(defvar sh--completion-keywords '("if" "while" "until" "for"))
+
(defun sh--vars-before-point ()
(save-excursion
(let ((vars ()))
@@ -1719,7 +1619,7 @@ This adds rules for comments and assignments."
(sh--vars-before-point))
(locate-file-completion-table
exec-path exec-suffixes string pred t)
- '("if" "while" "until" "for"))))
+ sh--completion-keywords)))
(complete-with-action action cmds string pred)))
(defun sh-completion-at-point-function ()
@@ -1730,21 +1630,22 @@ This adds rules for comments and assignments."
(start (point)))
(cond
((eq (char-before) ?$)
- (list start end (sh--vars-before-point)))
+ (list start end (sh--vars-before-point)
+ :company-kind (lambda (_) 'variable)))
((sh-smie--keyword-p)
- (list start end #'sh--cmd-completion-table))))))
+ (list start end #'sh--cmd-completion-table
+ :company-kind
+ (lambda (s)
+ (cond
+ ((member s sh--completion-keywords) 'keyword)
+ ((string-suffix-p "=" s) 'variable)
+ (t 'function)))
+ ))))))
;;; Indentation and navigation with SMIE.
(require 'smie)
-;; The SMIE code should generally be preferred, but it currently does not obey
-;; the various indentation custom-vars, and it misses some important features
-;; of the old code, mostly: sh-learn-line/buffer-indent, sh-show-indent,
-;; sh-name/save/load-style.
-(defvar sh-use-smie t
- "Whether to use the SMIE code for navigation and indentation.")
-
(defun sh-smie--keyword-p ()
"Non-nil if we're at a keyword position.
A keyword position is one where if we're looking at something that looks
@@ -2047,12 +1948,18 @@ May return nil if the line should not be treated as continued."
('(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt)
(sh-var-value 'sh-indent-for-case-label)))
(`(:before . ,(or "(" "{" "[" "while" "if" "for" "case"))
- (if (not (smie-rule-prev-p "&&" "||" "|"))
- (when (smie-rule-hanging-p)
- (smie-rule-parent))
+ (cond
+ ((and (equal token "{") (smie-rule-parent-p "for"))
+ (let ((data (smie-backward-sexp "in")))
+ (when (equal (nth 2 data) "for")
+ `(column . ,(smie-indent-virtual)))))
+ ((not (smie-rule-prev-p "&&" "||" "|"))
+ (when (smie-rule-hanging-p)
+ (smie-rule-parent)))
+ (t
(unless (smie-rule-bolp)
(while (equal "|" (nth 2 (smie-backward-sexp 'halfexp))))
- `(column . ,(smie-indent-virtual)))))
+ `(column . ,(smie-indent-virtual))))))
;; FIXME: Maybe this handling of ;; should be made into
;; a smie-rule-terminator function that takes the substitute ";" as arg.
(`(:before . ,(or ";;" ";&" ";;&"))
@@ -2279,66 +2186,14 @@ Point should be before the newline."
(defvar sh-regexp-for-done nil
"A buffer-local regexp to match opening keyword for done.")
-(defvar sh-kw-alist nil
- "A buffer-local, since it is shell-type dependent, list of keywords.")
-
-;; ( key-word first-on-this on-prev-line )
-;; This is used to set `sh-kw-alist' which is a list of sublists each
-;; having 3 elements:
-;; a keyword
-;; a rule to check when the keyword appears on "this" line
-;; a rule to check when the keyword appears on "the previous" line
-;; The keyword is usually a string and is the first word on a line.
-;; If this keyword appears on the line whose indentation is to be
-;; calculated, the rule in element 2 is called. If this returns
-;; non-zero, the resulting point (which may be changed by the rule)
-;; is used as the default indentation.
-;; If it returned false or the keyword was not found in the table,
-;; then the keyword from the previous line is looked up and the rule
-;; in element 3 is called. In this case, however,
-;; `sh-get-indent-info' does not stop but may keep going and test
-;; other keywords against rules in element 3. This is because the
-;; preceding line could have, for example, an opening "if" and an
-;; opening "while" keyword and we need to add the indentation offsets
-;; for both.
-;;
-(defconst sh-kw
- '((sh
- ("if" nil sh-handle-prev-if)
- ("elif" sh-handle-this-else sh-handle-prev-else)
- ("else" sh-handle-this-else sh-handle-prev-else)
- ("fi" sh-handle-this-fi sh-handle-prev-fi)
- ("then" sh-handle-this-then sh-handle-prev-then)
- ("(" nil sh-handle-prev-open)
- ("{" nil sh-handle-prev-open)
- ("[" nil sh-handle-prev-open)
- ("}" sh-handle-this-close nil)
- (")" sh-handle-this-close nil)
- ("]" sh-handle-this-close nil)
- ("case" nil sh-handle-prev-case)
- ("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))
-
- ;; Note: we don't need specific stuff for bash and zsh shells;
- ;; the regexp `sh-regexp-for-done' handles the extra keywords
- ;; these shells use.
- (rc
- ("{" nil sh-handle-prev-open)
- ("}" sh-handle-this-close nil)
- ("case" sh-handle-this-rc-case sh-handle-prev-rc-case))))
-
-
(defun sh-set-shell (shell &optional no-query-flag insert-flag)
"Set this buffer's shell to SHELL (a string).
When used interactively, insert the proper starting #!-line,
and make the visited file executable via `executable-set-magic',
perhaps querying depending on the value of `executable-query'.
+(If given a prefix (i.e., `C-u') don't insert any starting #!
+line.)
When this function is called noninteractively, INSERT-FLAG (the third
argument) controls whether to insert a #!-line and think about making
@@ -2351,8 +2206,7 @@ Shell script files can cause this function be called automatically
when the file is visited by having a `sh-shell' file-local variable
whose value is the shell name (don't quote it)."
(interactive (list (completing-read
- (format "Shell (default %s): "
- sh-shell-file)
+ (format-prompt "Shell" sh-shell-file)
;; This used to use interpreter-mode-alist, but that is
;; no longer appropriate now that uses regexps.
;; Maybe there could be a separate variable that lists
@@ -2363,7 +2217,7 @@ whose value is the shell name (don't quote it)."
'("csh" "rc" "sh"))
nil nil nil nil sh-shell-file)
(eq executable-query 'function)
- t))
+ (not current-prefix-arg)))
(if (string-match "\\.exe\\'" shell)
(setq shell (substring shell 0 (match-beginning 0))))
(setq sh-shell (sh-canonicalize-shell shell))
@@ -2400,16 +2254,6 @@ whose value is the shell name (don't quote it)."
(funcall mksym "rules")
:forward-token (funcall mksym "forward-token")
:backward-token (funcall mksym "backward-token")))
- (unless sh-use-smie
- (setq-local sh-kw-alist (sh-feature sh-kw))
- (let ((regexp (sh-feature sh-kws-for-done)))
- (if regexp
- (setq-local sh-regexp-for-done
- (sh-mkword-regexpr (regexp-opt regexp t)))))
- (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-local indent-line-function #'sh-indent-line))
(if sh-make-vars-local
(sh-make-vars-local))
(message "Indentation setup for shell type %s" sh-shell))
@@ -2564,11 +2408,6 @@ region, clear header."
(eq -1 (% (save-excursion (skip-chars-backward "\\\\")) 2)))
;; Indentation stuff.
-(defun sh-must-support-indent ()
- "Signal an error if the shell type for this buffer is not supported.
-Also, the buffer must be in Shell-script mode."
- (unless sh-indent-supported-here
- (error "This buffer's shell does not support indentation through Emacs")))
(defun sh-make-vars-local ()
"Make the indentation variables local to this buffer.
@@ -2589,654 +2428,12 @@ Then, if variable `sh-make-vars-local' is non-nil, make them local."
(if sh-make-vars-local
(mapcar 'make-local-variable sh-var-list)))
-
-;; Theoretically these are only needed in shell and derived modes.
-;; However, the routines which use them are only called in those modes.
-(defconst sh-special-keywords "then\\|do")
-
-(defun sh-help-string-for-variable (var)
- "Construct a string for `sh-read-variable' when changing variable VAR ."
- (let ((msg (documentation-property var 'variable-documentation))
- (msg2 ""))
- (unless (memq var '(sh-first-lines-indent sh-indent-comment))
- (setq msg2
- (format "\n
-You can enter a number (positive to increase indentation,
-negative to decrease indentation, zero for no change to indentation).
-
-Or, you can enter one of the following symbols which are relative to
-the value of variable `sh-basic-offset'
-which in this buffer is currently %s.
-
-\t%s."
- sh-basic-offset
- (mapconcat (lambda (x)
- (nth (1- (length x)) x))
- sh-symbol-list "\n\t"))))
- (concat
- ;; The following shows the global not the local value!
- ;; (format "Current value of %s is %s\n\n" var (symbol-value var))
- msg msg2)))
-
-(defun sh-read-variable (var)
- "Read a new value for indentation variable VAR."
- (let ((minibuffer-help-form `(sh-help-string-for-variable
- (quote ,var)))
- val)
- (setq val (read-from-minibuffer
- (format "New value for %s (press %s for help): "
- var (single-key-description help-char))
- (format "%s" (symbol-value var))
- nil t))
- val))
-
-
-
(defun sh-in-comment-or-string (start)
"Return non-nil if START is in a comment or string."
(save-excursion
(let ((state (syntax-ppss start)))
(or (nth 3 state) (nth 4 state)))))
-(defun sh-goto-matching-if ()
- "Go to the matching if for a fi.
-This handles nested if..fi pairs."
- (let ((found (sh-find-prev-matching "\\bif\\b" "\\bfi\\b" 1)))
- (if found
- (goto-char found))))
-
-
-;; Functions named sh-handle-this-XXX are called when the keyword on the
-;; line whose indentation is being handled contain XXX;
-;; those named sh-handle-prev-XXX are when XXX appears on the previous line.
-
-(defun sh-handle-prev-if ()
- (list '(+ sh-indent-after-if)))
-
-(defun sh-handle-this-else ()
- (if (sh-goto-matching-if)
- ;; (list "aligned to if")
- (list "aligned to if" '(+ sh-indent-for-else))
- nil
- ))
-
-(defun sh-handle-prev-else ()
- (if (sh-goto-matching-if)
- (list '(+ sh-indent-after-if))
- ))
-
-(defun sh-handle-this-fi ()
- (if (sh-goto-matching-if)
- (list "aligned to if" '(+ sh-indent-for-fi))
- nil
- ))
-
-(defun sh-handle-prev-fi ()
- ;; Why do we have this rule? Because we must go back to the if
- ;; to get its indent. We may continue back from there.
- ;; We return nil because we don't have anything to add to result,
- ;; the side affect of setting align-point is all that matters.
- ;; we could return a comment (a string) but I can't think of a good one...
- (sh-goto-matching-if)
- nil)
-
-(defun sh-handle-this-then ()
- (let ((p (sh-goto-matching-if)))
- (if p
- (list '(+ sh-indent-for-then))
- )))
-
-(defun sh-handle-prev-then ()
- (let ((p (sh-goto-matching-if)))
- (if p
- (list '(+ sh-indent-after-if))
- )))
-
-(defun sh-handle-prev-open ()
- (save-excursion
- (let ((x (sh-prev-stmt)))
- (if (and x
- (progn
- (goto-char x)
- (or
- (looking-at "function\\b")
- (looking-at "\\s-*\\S-+\\s-*()")
- )))
- (list '(+ sh-indent-after-function))
- (list '(+ sh-indent-after-open)))
- )))
-
-(defun sh-handle-this-close ()
- (forward-char 1) ;; move over ")"
- (if (sh-safe-forward-sexp -1)
- (list "aligned to opening paren")))
-
-(defun sh-goto-matching-case ()
- (let ((found (sh-find-prev-matching "\\bcase\\b" "\\besac\\b" 1)))
- (if found (goto-char found))))
-
-(defun sh-handle-prev-case ()
- ;; This is typically called when point is on same line as a case
- ;; we shouldn't -- and can't find prev-case
- (if (looking-at ".*\\<case\\>")
- (list '(+ sh-indent-for-case-label))
- (error "We don't seem to be on a line with a case"))) ;; debug
-
-(defun sh-handle-this-esac ()
- (if (sh-goto-matching-case)
- (list "aligned to matching case")))
-
-(defun sh-handle-prev-esac ()
- (if (sh-goto-matching-case)
- (list "matching case")))
-
-(defun sh-handle-after-case-label ()
- (if (sh-goto-matching-case)
- (list '(+ sh-indent-for-case-alt))))
-
-(defun sh-handle-prev-case-alt-end ()
- (if (sh-goto-matching-case)
- (list '(+ sh-indent-for-case-label))))
-
-(defun sh-safe-forward-sexp (&optional arg)
- "Try and do a `forward-sexp', but do not error.
-Return new point if successful, nil if an error occurred."
- (condition-case nil
- (progn
- (forward-sexp (or arg 1))
- (point)) ;; return point if successful
- (error
- (sh-debug "oops!(1) %d" (point))
- nil))) ;; return nil if fail
-
-(defun sh-goto-match-for-done ()
- (let ((found (sh-find-prev-matching sh-regexp-for-done sh-re-done 1)))
- (if found
- (goto-char found))))
-
-(defun sh-handle-this-done ()
- (if (sh-goto-match-for-done)
- (list "aligned to do stmt" '(+ sh-indent-for-done))))
-
-(defun sh-handle-prev-done ()
- (if (sh-goto-match-for-done)
- (list "previous done")))
-
-(defun sh-handle-this-do ()
- (if (sh-goto-match-for-done)
- (list '(+ sh-indent-for-do))))
-
-(defun sh-handle-prev-do ()
- (cond
- ((save-restriction
- (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)))
- ((sh-goto-match-for-done)
- (sh-debug "match for done found on PREV line")
- (list '(+ sh-indent-after-do)))
- (t
- (message "match for done NOT found")
- nil)))
-
-;; for rc:
-(defun sh-find-prev-switch ()
- "Find the line for the switch keyword matching this line's case keyword."
- (re-search-backward "\\<switch\\>" nil t))
-
-(defun sh-handle-this-rc-case ()
- (if (sh-find-prev-switch)
- (list '(+ sh-indent-after-switch))
- ;; (list '(+ sh-indent-for-case-label))
- nil))
-
-(defun sh-handle-prev-rc-case ()
- (list '(+ sh-indent-after-case)))
-
-(defun sh-check-rule (n thing)
- (let ((rule (nth n (assoc thing sh-kw-alist)))
- (val nil))
- (if rule
- (progn
- (setq val (funcall rule))
- (sh-debug "rule (%d) for %s at %d is %s\n-> returned %s"
- n thing (point) rule val)))
- val))
-
-
-(defun sh-get-indent-info ()
- "Return indent-info for this line.
-This is a list. nil means the line is to be left as is.
-Otherwise it contains one or more of the following sublists:
-\(t NUMBER) NUMBER is the base location in the buffer that indentation is
- relative to. If present, this is always the first of the
- sublists. The indentation of the line in question is
- derived from the indentation of this point, possibly
- modified by subsequent sublists.
-\(+ VAR)
-\(- VAR) Get the value of variable VAR and add to or subtract from
- the indentation calculated so far.
-\(= VAR) Get the value of variable VAR and *replace* the
- indentation with its value. This only occurs for
- special variables such as `sh-indent-comment'.
-STRING This is ignored for the purposes of calculating
- indentation, it is printed in certain cases to help show
- what the indentation is based on."
- ;; See comments before `sh-kw'.
- (save-excursion
- (let ((have-result nil)
- this-kw
- val
- (result nil)
- (align-point nil)
- prev-line-end x)
- (beginning-of-line)
- ;; Note: setting result to t means we are done and will return nil.
- ;;(This function never returns just t.)
- (cond
- ((or (nth 3 (syntax-ppss (point)))
- (eq (get-text-property (point) 'face) 'sh-heredoc))
- ;; String continuation -- don't indent
- (setq result t)
- (setq have-result t))
- ((looking-at "\\s-*#") ; was (equal this-kw "#")
- (if (bobp)
- (setq result t) ;; return nil if 1st line!
- (setq result (list '(= sh-indent-comment)))
- ;; we still need to get previous line in case
- ;; sh-indent-comment is t (indent as normal)
- (setq align-point (sh-prev-line nil))
- (setq have-result nil)
- ))
- ) ;; cond
-
- (unless have-result
- ;; Continuation lines are handled specially
- (if (sh-this-is-a-continuation)
- (progn
- (setq result
- (if (save-excursion
- (beginning-of-line)
- (not (memq (char-before (- (point) 2)) '(?\s ?\t))))
- ;; By convention, if the continuation \ is not
- ;; preceded by a SPC or a TAB it means that the line
- ;; is cut at a place where spaces cannot be freely
- ;; added/removed. I.e. do not indent the line.
- (list '(= nil))
- ;; We assume the line being continued is already
- ;; properly indented...
- ;; (setq prev-line-end (sh-prev-line))
- (setq align-point (sh-prev-line nil))
- (list '(+ sh-indent-for-continuation))))
- (setq have-result t))
- (beginning-of-line)
- (skip-chars-forward " \t")
- (setq this-kw (sh-get-kw)))
-
- ;; Handle "this" keyword: first word on the line we're
- ;; calculating indentation info for.
- (if this-kw
- (if (setq val (sh-check-rule 1 this-kw))
- (progn
- (setq align-point (point))
- (sh-debug
- "this - setting align-point to %d" align-point)
- (setq result (append result val))
- (setq have-result t)
- ;; set prev-line to continue processing remainder
- ;; of this line as a previous line
- (setq prev-line-end (point))
- ))))
-
- (unless have-result
- (setq prev-line-end (sh-prev-line 'end)))
-
- (if prev-line-end
- (save-excursion
- ;; We start off at beginning of this line.
- ;; Scan previous statements while this is <=
- ;; start of previous line.
- (goto-char prev-line-end)
- (setq x t)
- (while (and x (setq x (sh-prev-thing)))
- (sh-debug "at %d x is: %s result is: %s" (point) x result)
- (cond
- ((and (equal x ")")
- (equal (get-text-property (1- (point)) 'syntax-table)
- sh-st-punc))
- (sh-debug "Case label) here")
- (setq x 'case-label)
- (if (setq val (sh-check-rule 2 x))
- (progn
- (setq result (append result val))
- (setq align-point (point))))
- (or (bobp)
- (forward-char -1))
- (skip-chars-forward "*0-9?[]a-z")
- )
- ((string-match "[])}]" x)
- (setq x (sh-safe-forward-sexp -1))
- (if x
- (progn
- (setq align-point (point))
- (setq result (append result
- (list "aligned to opening paren")))
- )))
- ((string-match "[[({]" x)
- (sh-debug "Checking special thing: %s" x)
- (if (setq val (sh-check-rule 2 x))
- (setq result (append result val)))
- (forward-char -1)
- (setq align-point (point)))
- ((string-match "[\"'`]" x)
- (sh-debug "Skipping back for %s" x)
- ;; this was oops-2
- (setq x (sh-safe-forward-sexp -1)))
- ((stringp x)
- (sh-debug "Checking string %s at %s" x (point))
- (if (setq val (sh-check-rule 2 x))
- ;; (or (eq t (car val))
- ;; (eq t (car (car val))))
- (setq result (append result val)))
- ;; not sure about this test Wed Jan 27 23:48:35 1999
- (setq align-point (point))
- (unless (bolp)
- (forward-char -1)))
- (t
- (error "Don't know what to do with %s" x))
- )
- ) ;; while
- (sh-debug "result is %s" result)
- )
- (sh-debug "No prev line!")
- (sh-debug "result: %s align-point: %s" result align-point)
- )
-
- (if align-point
- ;; was: (setq result (append result (list (list t align-point))))
- (setq result (append (list (list t align-point)) result))
- )
- (sh-debug "result is now: %s" result)
-
- (or result
- (setq result (list (if prev-line-end
- (list t prev-line-end)
- (list '= 'sh-first-lines-indent)))))
-
- (if (eq result t)
- (setq result nil))
- (sh-debug "result is: %s" result)
- result
- ) ;; let
- ))
-
-
-(defun sh-get-indent-var-for-line (&optional info)
- "Return the variable controlling indentation for this line.
-If there is not [just] one such variable, return a string
-indicating the problem.
-If INFO is supplied it is used, else it is calculated."
- (let ((var nil)
- (result nil)
- (reason nil)
- sym elt)
- (or info
- (setq info (sh-get-indent-info)))
- (if (null info)
- (setq result "this line to be left as is")
- (while (and info (null result))
- (setq elt (car info))
- (cond
- ((stringp elt)
- (setq reason elt)
- )
- ((not (listp elt))
- (error "sh-get-indent-var-for-line invalid elt: %s" elt))
- ;; so it is a list
- ((eq t (car elt))
- ) ;; nothing
- ((symbolp (setq sym (nth 1 elt)))
- ;; A bit of a kludge - when we see the sh-indent-comment
- ;; ignore other variables. Otherwise it is tricky to
- ;; "learn" the comment indentation.
- (if (eq var 'sh-indent-comment)
- (setq result var)
- (if var
- (setq result
- "this line is controlled by more than 1 variable.")
- (setq var sym))))
- (t
- (error "sh-get-indent-var-for-line invalid list elt: %s" elt)))
- (setq info (cdr info))
- ))
- (or result
- (setq result var))
- (or result
- (setq result reason))
- (if (null result)
- ;; e.g. just had (t POS)
- (setq result "line has default indentation"))
- result))
-
-
-
-;; Finding the previous line isn't trivial.
-;; We must *always* go back one more and see if that is a continuation
-;; line -- it is the PREVIOUS line which is continued, not the one
-;; we are going to!
-;; Also, we want to treat a whole "here document" as one big line,
-;; because we may want to align to the beginning of it.
-;;
-;; What we do:
-;; - go back to previous non-empty line
-;; - if this is in a here-document, go to the beginning of it
-;; - while previous line is continued, go back one line
-(defun sh-prev-line (&optional end)
- "Back to end of previous non-comment non-empty line.
-Go to beginning of logical line unless END is non-nil, in which case
-we go to the end of the previous line and do not check for continuations."
- (save-excursion
- (beginning-of-line)
- (forward-comment (- (point-max)))
- (unless end (beginning-of-line))
- (when (and (not (bobp))
- (eq (get-text-property (1- (point)) 'face) 'sh-heredoc))
- (let ((p1 (previous-single-property-change (1- (point)) 'face)))
- (when p1
- (goto-char p1)
- (if end
- (end-of-line)
- (beginning-of-line)))))
- (unless end
- ;; we must check previous lines to see if they are continuation lines
- ;; if so, we must return position of first of them
- (while (and (sh-this-is-a-continuation)
- (>= 0 (forward-line -1))))
- (beginning-of-line)
- (skip-chars-forward " \t"))
- (point)))
-
-
-(defun sh-prev-stmt ()
- "Return the address of the previous stmt or nil."
- ;; This is used when we are trying to find a matching keyword.
- ;; Searching backward for the keyword would certainly be quicker, but
- ;; it is hard to remove "false matches" -- such as if the keyword
- ;; appears in a string or quote. This way is slower, but (I think) safer.
- (interactive)
- (save-excursion
- (let ((going t)
- (start (point))
- (found nil)
- (prev nil))
- (skip-chars-backward " \t;|&({[")
- (while (and (not found)
- (not (bobp))
- going)
- ;; Do a backward-sexp if possible, else backup bit by bit...
- (if (sh-safe-forward-sexp -1)
- (progn
- (if (looking-at sh-special-keywords)
- (progn
- (setq found prev))
- (setq prev (point))
- ))
- ;; backward-sexp failed
- (if (zerop (skip-chars-backward " \t()[]{};`'"))
- (forward-char -1))
- (if (bolp)
- (let ((back (sh-prev-line nil)))
- (if back
- (goto-char back)
- (setq going nil)))))
- (unless found
- (skip-chars-backward " \t")
- (if (or (and (bolp) (not (sh-this-is-a-continuation)))
- (eq (char-before) ?\;)
- (looking-at "\\s-*[|&]"))
- (setq found (point)))))
- (if found
- (goto-char found))
- (if found
- (progn
- (skip-chars-forward " \t|&({[")
- (setq found (point))))
- (if (>= (point) start)
- (progn
- (debug "We didn't move!")
- (setq found nil))
- (or found
- (sh-debug "Did not find prev stmt.")))
- found)))
-
-
-(defun sh-get-word ()
- "Get a shell word skipping whitespace from point."
- (interactive)
- (skip-chars-forward "\t ")
- (let ((start (point)))
- (while
- (if (looking-at "[\"'`]")
- (sh-safe-forward-sexp)
- ;; (> (skip-chars-forward "^ \t\n\"'`") 0)
- (> (skip-chars-forward "-_$[:alnum:]") 0)
- ))
- (buffer-substring start (point))
- ))
-
-(defun sh-prev-thing ()
- "Return the previous thing this logical line."
- ;; This is called when `sh-get-indent-info' is working backwards on
- ;; the previous line(s) finding what keywords may be relevant for
- ;; indenting. It moves over sexps if possible, and will stop
- ;; on a ; and at the beginning of a line if it is not a continuation
- ;; line.
- ;;
- ;; Added a kludge for ";;"
- ;; Possible return values:
- ;; nil - nothing
- ;; a string - possibly a keyword
- ;;
- (if (bolp)
- nil
- (let ((start (point))
- (min-point (if (sh-this-is-a-continuation)
- (sh-prev-line nil)
- (line-beginning-position))))
- (skip-chars-backward " \t;" min-point)
- (if (looking-at "\\s-*;[;&]")
- ;; (message "Found ;; !")
- ";;"
- (skip-chars-backward "^)}];\"'`({[" min-point)
- (let ((c (if (> (point) min-point) (char-before))))
- (sh-debug "stopping at %d c is %s start=%d min-point=%d"
- (point) c start min-point)
- (if (not (memq c '(?\n nil ?\;)))
- ;; c -- return a string
- (char-to-string c)
- ;; Return the leading keyword of the "command" we supposedly
- ;; skipped over. Maybe we skipped too far (e.g. past a `do' or
- ;; `then' that precedes the actual command), so check whether
- ;; we're looking at such a keyword and if so, move back forward.
- (let ((boundary (point))
- kwd next)
- (while
- (progn
- ;; Skip forward over white space newline and \ at eol.
- (skip-chars-forward " \t\n\\\\" start)
- (if (>= (point) start)
- (progn
- (sh-debug "point: %d >= start: %d" (point) start)
- nil)
- (if next (setq boundary next))
- (sh-debug "Now at %d start=%d" (point) start)
- (setq kwd (sh-get-word))
- (if (member kwd (sh-feature sh-leading-keywords))
- (progn
- (setq next (point))
- t)
- nil))))
- (goto-char boundary)
- kwd)))))))
-
-
-(defun sh-this-is-a-continuation ()
- "Return non-nil if current line is a continuation of previous line."
- (save-excursion
- (and (zerop (forward-line -1))
- (looking-at ".*\\\\$")
- (not (nth 4 (parse-partial-sexp (match-beginning 0) (match-end 0)
- nil nil nil t))))))
-
-(defun sh-get-kw (&optional where and-move)
- "Return first word of line from WHERE.
-If AND-MOVE is non-nil then move to end of word."
- (let ((start (point)))
- (if where
- (goto-char where))
- (prog1
- (buffer-substring (point)
- (progn (skip-chars-forward "^ \t\n;&|")(point)))
- (unless and-move
- (goto-char start)))))
-
-(defun sh-find-prev-matching (open close &optional depth)
- "Find a matching token for a set of opening and closing keywords.
-This takes into account that there may be nested open..close pairings.
-OPEN and CLOSE are regexps denoting the tokens to be matched.
-Optional parameter DEPTH (usually 1) says how many to look for."
- (let ((parse-sexp-ignore-comments t)
- (forward-sexp-function nil)
- prev)
- (setq depth (or depth 1))
- (save-excursion
- (condition-case nil
- (while (and
- (/= 0 depth)
- (not (bobp))
- (setq prev (sh-prev-stmt)))
- (goto-char prev)
- (save-excursion
- (if (looking-at "\\\\\n")
- (progn
- (forward-char 2)
- (skip-chars-forward " \t")))
- (cond
- ((looking-at open)
- (setq depth (1- depth))
- (sh-debug "found open at %d - depth = %d" (point) depth))
- ((looking-at close)
- (setq depth (1+ depth))
- (sh-debug "found close - depth = %d" depth))
- (t
- ))))
- (error nil))
- (if (eq depth 0)
- prev ;; (point)
- nil)
- )))
-
(defun sh-var-value (var &optional ignore-error)
"Return the value of variable VAR, interpreting symbols.
@@ -3268,620 +2465,16 @@ IGNORE-ERROR is non-nil."
"Don't know how to handle %s's value of %s" var val)
0))))
-(defun sh-set-var-value (var value &optional no-symbol)
- "Set variable VAR to VALUE.
-Unless optional argument NO-SYMBOL is non-nil, then if VALUE is
-can be represented by a symbol then do so."
- (cond
- (no-symbol
- (set var value))
- ((= value sh-basic-offset)
- (set var '+))
- ((= value (- sh-basic-offset))
- (set var '-))
- ((eq value (* 2 sh-basic-offset))
- (set var '++))
- ((eq value (* 2 (- sh-basic-offset)))
- (set var '--))
- ((eq value (/ sh-basic-offset 2))
- (set var '*))
- ((eq value (/ (- sh-basic-offset) 2))
- (set var '/))
- (t
- (set var value)))
- )
-
-
-(defun sh-calculate-indent (&optional info)
- "Return the indentation for the current line.
-If INFO is supplied it is used, else it is calculated from current line."
- (let ((ofs 0)
- (base-value 0)
- elt a b val)
- (or info
- (setq info (sh-get-indent-info)))
- (when info
- (while info
- (sh-debug "info: %s ofs=%s" info ofs)
- (setq elt (car info))
- (cond
- ((stringp elt)) ;; do nothing?
- ((listp elt)
- (setq a (car (car info)))
- (setq b (nth 1 (car info)))
- (cond
- ((eq a t)
- (save-excursion
- (goto-char b)
- (setq val (current-indentation)))
- (setq base-value val))
- ((symbolp b)
- (setq val (sh-var-value b))
- (cond
- ((eq a '=)
- (cond
- ((null val)
- ;; no indentation
- ;; set info to nil so we stop immediately
- (setq base-value nil ofs nil info nil))
- ((eq val t) (setq ofs 0)) ;; indent as normal line
- (t
- ;; The following assume the (t POS) come first!
- (setq ofs val base-value 0)
- (setq info nil)))) ;; ? stop now
- ((eq a '+) (setq ofs (+ ofs val)))
- ((eq a '-) (setq ofs (- ofs val)))
- (t
- (error "sh-calculate-indent invalid a a=%s b=%s" a b))))
- (t
- (error "sh-calculate-indent invalid elt: a=%s b=%s" a b))))
- (t
- (error "sh-calculate-indent invalid elt %s" elt)))
- (sh-debug "a=%s b=%s val=%s base-value=%s ofs=%s"
- a b val base-value ofs)
- (setq info (cdr info)))
- ;; return value:
- (sh-debug "at end: base-value: %s ofs: %s" base-value ofs)
-
- (cond
- ((or (null base-value)(null ofs))
- nil)
- ((and (numberp base-value)(numberp ofs))
- (sh-debug "base (%d) + ofs (%d) = %d"
- base-value ofs (+ base-value ofs))
- (+ base-value ofs)) ;; return value
- (t
- (error "sh-calculate-indent: Help. base-value=%s ofs=%s"
- base-value ofs)
- nil)))))
+(define-obsolete-function-alias 'sh-show-indent
+ #'smie-config-show-indent "28.1")
+(define-obsolete-function-alias 'sh-set-indent #'smie-config-set-indent "28.1")
-(defun sh-indent-line ()
- "Indent the current line."
- (interactive)
- (let ((indent (sh-calculate-indent))
- (pos (- (point-max) (point))))
- (when indent
- (beginning-of-line)
- (skip-chars-forward " \t")
- (indent-line-to indent)
- ;; If initial point was within line's indentation,
- ;; position after the indentation. Else stay at same point in text.
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos))))))
-
-
-(defun sh-blink (blinkpos &optional msg)
- "Move cursor momentarily to BLINKPOS and display MSG."
- ;; We can get here without it being a number on first line
- (if (numberp blinkpos)
- (save-excursion
- (goto-char blinkpos)
- (if msg (message "%s" msg) (message nil))
- (sit-for blink-matching-delay))
- (if msg (message "%s" msg) (message nil))))
-
-(defun sh-show-indent (arg)
- "Show how the current line would be indented.
-This tells you which variable, if any, controls the indentation of
-this line.
-If optional arg ARG is non-null (called interactively with a prefix),
-a pop up window describes this variable.
-If variable `sh-blink' is non-nil then momentarily go to the line
-we are indenting relative to, if applicable."
- (interactive "P")
- (sh-must-support-indent)
- (if sh-use-smie
- (smie-config-show-indent)
- (let* ((info (sh-get-indent-info))
- (var (sh-get-indent-var-for-line info))
- (curr-indent (current-indentation))
- val msg)
- (if (stringp var)
- (message "%s" (setq msg var))
- (setq val (sh-calculate-indent info))
-
- (if (eq curr-indent val)
- (setq msg (format "%s is %s" var (symbol-value var)))
- (setq msg
- (if val
- (format "%s (%s) would change indent from %d to: %d"
- var (symbol-value var) curr-indent val)
- (format "%s (%s) would leave line as is"
- var (symbol-value var)))
- ))
- (if (and arg var)
- (describe-variable var)))
- (if sh-blink
- (let ((info (sh-get-indent-info)))
- (if (and info (listp (car info))
- (eq (car (car info)) t))
- (sh-blink (nth 1 (car info)) msg)
- (message "%s" msg)))
- (message "%s" msg))
- )))
+(define-obsolete-function-alias 'sh-learn-line-indent
+ #'smie-config-set-indent "28.1")
-(defun sh-set-indent ()
- "Set the indentation for the current line.
-If the current line is controlled by an indentation variable, prompt
-for a new value for it."
- (interactive)
- (sh-must-support-indent)
- (if sh-use-smie
- (smie-config-set-indent)
- (let* ((info (sh-get-indent-info))
- (var (sh-get-indent-var-for-line info))
- val old-val indent-val)
- (if (stringp var)
- (message "Cannot set indent - %s" var)
- (setq old-val (symbol-value var))
- (setq val (sh-read-variable var))
- (condition-case nil
- (progn
- (set var val)
- (setq indent-val (sh-calculate-indent info))
- (if indent-val
- (message "Variable: %s Value: %s would indent to: %d"
- var (symbol-value var) indent-val)
- (message "Variable: %s Value: %s would leave line as is."
- var (symbol-value var)))
- ;; I'm not sure about this, indenting it now?
- ;; No. Because it would give the impression that an undo would
- ;; restore thing, but the value has been altered.
- ;; (sh-indent-line)
- )
- (error
- (set var old-val)
- (message "Bad value for %s, restoring to previous value %s"
- var old-val)
- (sit-for 1)
- nil))
- ))))
-
-
-(defun sh-learn-line-indent (arg)
- "Learn how to indent a line as it currently is indented.
-
-If there is an indentation variable which controls this line's indentation,
-then set it to a value which would indent the line the way it
-presently is.
-
-If the value can be represented by one of the symbols then do so
-unless optional argument ARG (the prefix when interactive) is non-nil."
- (interactive "*P")
- (sh-must-support-indent)
- (if sh-use-smie
- (smie-config-set-indent)
- ;; I'm not sure if we show allow learning on an empty line.
- ;; Though it might occasionally be useful I think it usually
- ;; would just be confusing.
- (if (save-excursion
- (beginning-of-line)
- (looking-at "\\s-*$"))
- (message "sh-learn-line-indent ignores empty lines.")
- (let* ((info (sh-get-indent-info))
- (var (sh-get-indent-var-for-line info))
- ival sval diff new-val
- (no-symbol arg)
- (curr-indent (current-indentation)))
- (cond
- ((stringp var)
- (message "Cannot learn line - %s" var))
- ((eq var 'sh-indent-comment)
- ;; This is arbitrary...
- ;; - if curr-indent is 0, set to curr-indent
- ;; - else if it has the indentation of a "normal" line,
- ;; then set to t
- ;; - else set to curr-indent.
- (setq sh-indent-comment
- (if (= curr-indent 0)
- 0
- (let* ((sh-indent-comment t)
- (val2 (sh-calculate-indent info)))
- (if (= val2 curr-indent)
- t
- curr-indent))))
- (message "%s set to %s" var (symbol-value var))
- )
- ((numberp (setq sval (sh-var-value var)))
- (setq ival (sh-calculate-indent info))
- (setq diff (- curr-indent ival))
-
- (sh-debug "curr-indent: %d ival: %d diff: %d var:%s sval %s"
- curr-indent ival diff var sval)
- (setq new-val (+ sval diff))
- ;; I commented out this because someone might want to replace
- ;; a value of `+' with the current value of sh-basic-offset
- ;; or vice-versa.
- ;;(if (= 0 diff)
- ;; (message "No change needed!")
- (sh-set-var-value var new-val no-symbol)
- (message "%s set to %s" var (symbol-value var))
- )
- (t
- (debug)
- (message "Cannot change %s" var)))))))
-
-
-
-(defun sh-mark-init (buffer)
- "Initialize a BUFFER to be used by `sh-mark-line'."
- (with-current-buffer (get-buffer-create buffer)
- (erase-buffer)
- (occur-mode)))
-
-
-(defun sh-mark-line (message point buffer &optional add-linenum occur-point)
- "Insert MESSAGE referring to location POINT in current buffer into BUFFER.
-Buffer BUFFER is in `occur-mode'.
-If ADD-LINENUM is non-nil the message is preceded by the line number.
-If OCCUR-POINT is non-nil then the line is marked as a new occurrence
-so that `occur-next' and `occur-prev' will work."
- (let ((m1 (make-marker))
- start
- (line ""))
- (when point
- (set-marker m1 point (current-buffer))
- (if add-linenum
- (setq line (format "%d: " (1+ (count-lines 1 point))))))
- (save-excursion
- (if (get-buffer buffer)
- (set-buffer (get-buffer buffer))
- (set-buffer (get-buffer-create buffer))
- (occur-mode)
- )
- (goto-char (point-max))
- (setq start (point))
- (let ((inhibit-read-only t))
- (insert line)
- (if occur-point
- (setq occur-point (point)))
- (insert message)
- (if point
- (add-text-properties
- start (point)
- '(mouse-face highlight
- help-echo "mouse-2: go to the line where I learned this")))
- (insert "\n")
- (when point
- (put-text-property start (point) 'occur-target m1)
- (if occur-point
- (put-text-property start occur-point
- 'occur-match t))
- )))))
-
-;; Is this really worth having?
-(defvar sh-learned-buffer-hook nil
- "An abnormal hook, called with an alist of learned variables.")
-;; Example of how to use sh-learned-buffer-hook
-;;
-;; (defun what-i-learned (list)
-;; (let ((p list))
-;; (with-current-buffer "*scratch*"
-;; (goto-char (point-max))
-;; (insert "(setq\n")
-;; (while p
-;; (insert (format " %s %s \n"
-;; (nth 0 (car p)) (nth 1 (car p))))
-;; (setq p (cdr p)))
-;; (insert ")\n")
-;; )))
-;;
-;; (add-hook 'sh-learned-buffer-hook #'what-i-learned)
-
-
-;; Originally this was sh-learn-region-indent (beg end)
-;; However, in practice this was awkward so I changed it to
-;; use the whole buffer. Use narrowing if need be.
-(defun sh-learn-buffer-indent (&optional arg)
- "Learn how to indent the buffer the way it currently is.
-
-If `sh-use-smie' is non-nil, call `smie-config-guess'.
-Otherwise, run the sh-script specific indent learning command, as
-described below.
-
-Output in buffer \"*indent*\" shows any lines which have conflicting
-values of a variable, and the final value of all variables learned.
-When called interactively, pop to this buffer automatically if
-there are any discrepancies.
-
-If no prefix ARG is given, then variables are set to numbers.
-If a prefix arg is given, then variables are set to symbols when
-applicable -- e.g. to symbol `+' if the value is that of the
-basic indent.
-If a positive numerical prefix is given, then `sh-basic-offset'
-is set to the prefix's numerical value.
-Otherwise, sh-basic-offset may or may not be changed, according
-to the value of variable `sh-learn-basic-offset'.
-
-Abnormal hook `sh-learned-buffer-hook' if non-nil is called when the
-function completes. The function is abnormal because it is called
-with an alist of variables learned.
-
-This command can often take a long time to run."
- (interactive "P")
- (sh-must-support-indent)
- (if sh-use-smie
- (smie-config-guess)
- (save-excursion
- (goto-char (point-min))
- (let ((learned-var-list nil)
- (out-buffer "*indent*")
- (num-diffs 0)
- previous-set-info
- (max 17)
- vec
- msg
- (comment-col nil) ;; number if all same, t if seen diff values
- (comments-always-default t) ;; nil if we see one not default
- initial-msg
- (specified-basic-offset (and arg (numberp arg)
- (> arg 0)))
- (linenum 0)
- suggested)
- (setq vec (make-vector max 0))
- (sh-mark-init out-buffer)
-
- (if specified-basic-offset
- (progn
- (setq sh-basic-offset arg)
- (setq initial-msg
- (format "Using specified sh-basic-offset of %d"
- sh-basic-offset)))
- (setq initial-msg
- (format "Initial value of sh-basic-offset: %s"
- sh-basic-offset)))
-
- (while (< (point) (point-max))
- (setq linenum (1+ linenum))
- ;; (if (zerop (% linenum 10))
- (message "line %d" linenum)
- ;; )
- (unless (looking-at "\\s-*$") ;; ignore empty lines!
- (let* ((sh-indent-comment t) ;; info must return default indent
- (info (sh-get-indent-info))
- (var (sh-get-indent-var-for-line info))
- sval ival diff new-val
- (curr-indent (current-indentation)))
- (cond
- ((null var)
- nil)
- ((stringp var)
- nil)
- ((numberp (setq sval (sh-var-value var 'no-error)))
- ;; the numberp excludes comments since sval will be t.
- (setq ival (sh-calculate-indent))
- (setq diff (- curr-indent ival))
- (setq new-val (+ sval diff))
- (sh-set-var-value var new-val 'no-symbol)
- (unless (looking-at "\\s-*#") ;; don't learn from comments
- (if (setq previous-set-info (assoc var learned-var-list))
- (progn
- ;; it was already there, is it same value ?
- (unless (eq (symbol-value var)
- (nth 1 previous-set-info))
- (sh-mark-line
- (format "Variable %s was set to %s"
- var (symbol-value var))
- (point) out-buffer t t)
- (sh-mark-line
- (format " but was previously set to %s"
- (nth 1 previous-set-info))
- (nth 2 previous-set-info) out-buffer t)
- (setq num-diffs (1+ num-diffs))
- ;; (delete previous-set-info learned-var-list)
- (setcdr previous-set-info
- (list (symbol-value var) (point)))
- )
- )
- (setq learned-var-list
- (append (list (list var (symbol-value var)
- (point)))
- learned-var-list)))
- (if (numberp new-val)
- (progn
- (sh-debug
- "This line's indent value: %d" new-val)
- (if (< new-val 0)
- (setq new-val (- new-val)))
- (if (< new-val max)
- (aset vec new-val (1+ (aref vec new-val))))))
- ))
- ((eq var 'sh-indent-comment)
- (unless (= curr-indent (sh-calculate-indent info))
- ;; this is not the default indentation
- (setq comments-always-default nil)
- (if comment-col ;; then we have see one before
- (or (eq comment-col curr-indent)
- (setq comment-col t)) ;; seen a different one
- (setq comment-col curr-indent))
- ))
- (t
- (sh-debug "Cannot learn this line!!!")
- ))
- (sh-debug
- "at %s learned-var-list is %s" (point) learned-var-list)
- ))
- (forward-line 1)
- ) ;; while
- (if sh-debug
- (progn
- (setq msg (format
- "comment-col = %s comments-always-default = %s"
- comment-col comments-always-default))
- ;; (message msg)
- (sh-mark-line msg nil out-buffer)))
- (cond
- ((eq comment-col 0)
- (setq msg "\nComments are all in 1st column.\n"))
- (comments-always-default
- (setq msg "\nComments follow default indentation.\n")
- (setq comment-col t))
- ((numberp comment-col)
- (setq msg (format "\nComments are in col %d." comment-col)))
- (t
- (setq msg "\nComments seem to be mixed, leaving them as is.\n")
- (setq comment-col nil)
- ))
- (sh-debug msg)
- (sh-mark-line msg nil out-buffer)
-
- (sh-mark-line initial-msg nil out-buffer t t)
-
- (setq suggested (sh-guess-basic-offset vec))
-
- (if (and suggested (not specified-basic-offset))
- (let ((new-value
- (cond
- ;; t => set it if we have a single value as a number
- ((and (eq sh-learn-basic-offset t) (numberp suggested))
- suggested)
- ;; other non-nil => set it if only one value was found
- (sh-learn-basic-offset
- (if (numberp suggested)
- suggested
- (if (= (length suggested) 1)
- (car suggested))))
- (t
- nil))))
- (if new-value
- (progn
- (setq learned-var-list
- (append (list (list 'sh-basic-offset
- (setq sh-basic-offset new-value)
- (point-max)))
- learned-var-list))
- ;; Not sure if we need to put this line in, since
- ;; it will appear in the "Learned variable settings".
- (sh-mark-line
- (format "Changed sh-basic-offset to: %d" sh-basic-offset)
- nil out-buffer))
- (sh-mark-line
- (if (listp suggested)
- (format "Possible value(s) for sh-basic-offset: %s"
- (mapconcat 'int-to-string suggested " "))
- (format "Suggested sh-basic-offset: %d" suggested))
- nil out-buffer))))
-
-
- (setq learned-var-list
- (append (list (list 'sh-indent-comment comment-col (point-max)))
- learned-var-list))
- (setq sh-indent-comment comment-col)
- (let ((name (buffer-name)))
- (sh-mark-line "\nLearned variable settings:" nil out-buffer)
- (if arg
- ;; Set learned variables to symbolic rather than numeric
- ;; values where possible.
- (dolist (learned-var (reverse learned-var-list))
- (let ((var (car learned-var))
- (val (nth 1 learned-var)))
- (when (and (not (eq var 'sh-basic-offset))
- (numberp val))
- (sh-set-var-value var val)))))
- (dolist (learned-var (reverse learned-var-list))
- (let ((var (car learned-var)))
- (sh-mark-line (format " %s %s" var (symbol-value var))
- (nth 2 learned-var) out-buffer)))
- (with-current-buffer out-buffer
- (goto-char (point-min))
- (let ((inhibit-read-only t))
- (insert
- (format "Indentation values for buffer %s.\n" name)
- (format "%d indentation variable%s different values%s\n\n"
- num-diffs
- (if (= num-diffs 1)
- " has" "s have")
- (if (zerop num-diffs)
- "." ":"))))))
- (run-hook-with-args 'sh-learned-buffer-hook learned-var-list)
- (and (called-interactively-p 'any)
- (or sh-popup-occur-buffer (> num-diffs 0))
- (pop-to-buffer out-buffer))))))
-
-(defun sh-guess-basic-offset (vec)
- "See if we can determine a reasonable value for `sh-basic-offset'.
-This is experimental, heuristic and arbitrary!
-Argument VEC is a vector of information collected by
-`sh-learn-buffer-indent'.
-Return values:
- number - there appears to be a good single value
- list of numbers - no obvious one, here is a list of one or more
- reasonable choices
- nil - we couldn't find a reasonable one."
- (let* ((max (1- (length vec)))
- (i 1)
- (totals (make-vector max 0)))
- (while (< i max)
- (cl-incf (aref totals i) (* 4 (aref vec i)))
- (if (zerop (% i 2))
- (cl-incf (aref totals i) (aref vec (/ i 2))))
- (if (< (* i 2) max)
- (cl-incf (aref totals i) (aref vec (* i 2))))
- (setq i (1+ i)))
-
- (let ((x nil)
- (result nil)
- tot sum p)
- (setq i 1)
- (while (< i max)
- (if (/= (aref totals i) 0)
- (push (cons i (aref totals i)) x))
- (setq i (1+ i)))
-
- (setq x (sort (nreverse x) (lambda (a b) (> (cdr a) (cdr b)))))
- (setq tot (apply '+ (append totals nil)))
- (sh-debug (format "vec: %s\ntotals: %s\ntot: %d"
- vec totals tot))
- (cond
- ((zerop (length x))
- (message "no values!")) ;; we return nil
- ((= (length x) 1)
- (message "only value is %d" (car (car x)))
- (setq result (car (car x)))) ;; return single value
- ((> (cdr (car x)) (/ tot 2))
- ;; 1st is > 50%
- (message "basic-offset is probably %d" (car (car x)))
- (setq result (car (car x)))) ;; again, return a single value
- ((>= (cdr (car x)) (* 2 (cdr (car (cdr x)))))
- ;; 1st is >= 2 * 2nd
- (message "basic-offset could be %d" (car (car x)))
- (setq result (car (car x))))
- ((>= (+ (cdr (car x))(cdr (car (cdr x)))) (/ tot 2))
- ;; 1st & 2nd together >= 50% - return a list
- (setq p x sum 0 result nil)
- (while (and p
- (<= (setq sum (+ sum (cdr (car p)))) (/ tot 2)))
- (setq result (append result (list (car (car p)))))
- (setq p (cdr p)))
- (message "Possible choices for sh-basic-offset: %s"
- (mapconcat 'int-to-string result " ")))
- (t
- (message "No obvious value for sh-basic-offset. Perhaps %d"
- (car (car x)))
- ;; result is nil here
- ))
- result)))
+(define-obsolete-function-alias 'sh-learn-buffer-indent
+ #'smie-config-guess "28.1")
;; ========================================================================
@@ -4207,12 +2800,12 @@ t means to return a list of all possible completions of STRING.
(not (bolp))
?\n)
"exit:\n"
- "rm $tmp* >&/dev/null" > \n)
+ "rm $tmp* >&" null-device > \n)
(es (file-name-nondirectory (buffer-file-name))
> "local( signals = $signals sighup sigint;" \n
> "tmp = `{ mktemp -t " str ".XXXXXX } ) {" \n
> "catch @ e {" \n
- > "rm $tmp^* >[2]/dev/null" \n
+ > "rm $tmp^* >[2]" null-device \n
"throw $e" \n
"} {" > \n
_ \n
@@ -4222,10 +2815,10 @@ t means to return a list of all possible completions of STRING.
7 "EXIT")
(rc (file-name-nondirectory (buffer-file-name))
> "tmp = `{ mktemp -t " str ".XXXXXX }" \n
- "fn sigexit { rm $tmp^* >[2]/dev/null }" \n)
+ "fn sigexit { rm $tmp^* >[2]" null-device " }" \n)
(sh (file-name-nondirectory (buffer-file-name))
> "TMP=`mktemp -t " str ".XXXXXX`" \n
- "trap \"rm $TMP* 2>/dev/null\" " ?0 \n))
+ "trap \"rm $TMP* 2>" null-device "\" " ?0 \n))
@@ -4333,8 +2926,8 @@ option followed by a colon `:' if the option accepts an argument."
(put 'sh-assignment 'delete-selection t)
(defun sh-assignment (arg)
"Remember preceding identifier for future completion and do self-insert."
- (interactive "p")
(declare (obsolete nil "27.1"))
+ (interactive "p")
(self-insert-command arg)
(sh--assignment-collect))
@@ -4386,7 +2979,7 @@ The document is bounded by `sh-here-document-word'."
(define-minor-mode sh-electric-here-document-mode
"Make << insert a here document skeleton."
- nil nil nil
+ :lighter nil
(if sh-electric-here-document-mode
(add-hook 'post-self-insert-hook #'sh--maybe-here-document nil t)
(remove-hook 'post-self-insert-hook #'sh--maybe-here-document t)))
diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el
index a9c2c14f841..7c0de9fc359 100644
--- a/lisp/progmodes/simula.el
+++ b/lisp/progmodes/simula.el
@@ -1,4 +1,4 @@
-;;; simula.el --- SIMULA 87 code editing commands for Emacs
+;;; simula.el --- SIMULA 87 code editing commands for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 1994, 1996, 2001-2021 Free Software Foundation,
;; Inc.
@@ -51,16 +51,15 @@ the run of whitespace at the beginning of the line.")
"Non-nil means TAB in SIMULA mode should always reindent the current line.
Otherwise TAB indents only when point is within
the run of whitespace at the beginning of the line."
- :type 'boolean
- :group 'simula)
+ :type 'boolean)
+(make-obsolete-variable 'simula-tab-always-indent 'tab-always-indent "28.1")
(defconst simula-indent-level-default 3
"Indentation of SIMULA statements with respect to containing block.")
(defcustom simula-indent-level simula-indent-level-default
"Indentation of SIMULA statements with respect to containing block."
- :type 'integer
- :group 'simula)
+ :type 'integer)
(defconst simula-substatement-offset-default 3
@@ -68,8 +67,7 @@ the run of whitespace at the beginning of the line."
(defcustom simula-substatement-offset simula-substatement-offset-default
"Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE."
- :type 'integer
- :group 'simula)
+ :type 'integer)
(defconst simula-continued-statement-offset-default 3
"Extra indentation for lines not starting a statement or substatement.
@@ -83,16 +81,14 @@ the previous line of the statement.")
If value is a list, each line in a multipleline continued statement
will have the car of the list extra indentation with respect to
the previous line of the statement."
- :type 'integer
- :group 'simula)
+ :type 'integer)
(defconst simula-label-offset-default -4711
"Offset of SIMULA label lines relative to usual indentation.")
(defcustom simula-label-offset simula-label-offset-default
"Offset of SIMULA label lines relative to usual indentation."
- :type 'integer
- :group 'simula)
+ :type 'integer)
(defconst simula-if-indent-default '(0 . 0)
"Extra indentation of THEN and ELSE with respect to the starting IF.
@@ -103,8 +99,7 @@ extra ELSE indentation. IF after ELSE is indented as the starting IF.")
"Extra indentation of THEN and ELSE with respect to the starting IF.
Value is a cons cell, the car is extra THEN indentation and the cdr
extra ELSE indentation. IF after ELSE is indented as the starting IF."
- :type '(cons integer integer)
- :group 'simula)
+ :type '(cons integer integer))
(defconst simula-inspect-indent-default '(0 . 0)
"Extra indentation of WHEN and OTHERWISE with respect to the INSPECT.
@@ -115,16 +110,14 @@ and the cdr extra OTHERWISE indentation.")
"Extra indentation of WHEN and OTHERWISE with respect to the INSPECT.
Value is a cons cell, the car is extra WHEN indentation
and the cdr extra OTHERWISE indentation."
- :type '(cons integer integer)
- :group 'simula)
+ :type '(cons integer integer))
(defconst simula-electric-indent-default nil
"Non-nil means `simula-indent-line' function may reindent previous line.")
(defcustom simula-electric-indent simula-electric-indent-default
"Non-nil means `simula-indent-line' function may reindent previous line."
- :type 'boolean
- :group 'simula)
+ :type 'boolean)
(defconst simula-abbrev-keyword-default 'upcase
"Specify how to convert case for SIMULA keywords.
@@ -135,8 +128,7 @@ Value is one of the symbols `upcase', `downcase', `capitalize',
"Specify how to convert case for SIMULA keywords.
Value is one of the symbols `upcase', `downcase', `capitalize',
\(as in) `abbrev-table' or nil if they should not be changed."
- :type '(choice (const upcase) (const downcase) (const capitalize)(const nil))
- :group 'simula)
+ :type '(choice (const upcase) (const downcase) (const capitalize)(const nil)))
(defconst simula-abbrev-stdproc-default 'abbrev-table
"Specify how to convert case for standard SIMULA procedure and class names.
@@ -148,18 +140,33 @@ Value is one of the symbols `upcase', `downcase', `capitalize',
Value is one of the symbols `upcase', `downcase', `capitalize',
\(as in) `abbrev-table', or nil if they should not be changed."
:type '(choice (const upcase) (const downcase) (const capitalize)
- (const abbrev-table) (const nil))
- :group 'simula)
+ (const abbrev-table) (const nil)))
(defcustom simula-abbrev-file nil
"File with extra abbrev definitions for use in SIMULA mode.
These are used together with the standard abbrev definitions for SIMULA.
Please note that the standard definitions are required
for SIMULA mode to function correctly."
- :type '(choice file (const nil))
- :group 'simula)
-
-(defvar simula-mode-syntax-table nil
+ :type '(choice file (const nil)))
+
+(defvar simula-mode-syntax-table
+ (let ((st (copy-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?! "<" st)
+ (modify-syntax-entry ?$ "." st)
+ (modify-syntax-entry ?% "< b" st)
+ (modify-syntax-entry ?\n "> b" 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)
+ (modify-syntax-entry ?_ "_" st)
+ (modify-syntax-entry ?\| "." st)
+ (modify-syntax-entry ?\{ "." st)
+ (modify-syntax-entry ?\} "." st)
+ st)
"Syntax table in SIMULA mode buffers.")
(defconst simula-syntax-propertize-function
@@ -248,90 +255,45 @@ for SIMULA mode to function correctly."
["Forward Statement" simula-next-statement t]
["Backward Up Level" simula-backward-up-level t]
["Forward Down Statement" simula-forward-down-level t])
- "Lucid Emacs menu for SIMULA mode.")
-
-(if simula-mode-syntax-table
- ()
- (setq simula-mode-syntax-table (copy-syntax-table (standard-syntax-table)))
- (modify-syntax-entry ?! "<" simula-mode-syntax-table)
- (modify-syntax-entry ?$ "." simula-mode-syntax-table)
- (modify-syntax-entry ?% "< b" simula-mode-syntax-table)
- (modify-syntax-entry ?\n "> b" simula-mode-syntax-table)
- (modify-syntax-entry ?' "\"" simula-mode-syntax-table)
- (modify-syntax-entry ?\( "()" simula-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" simula-mode-syntax-table)
- (modify-syntax-entry ?\; ">" simula-mode-syntax-table)
- (modify-syntax-entry ?\[ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\\ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\] "." simula-mode-syntax-table)
- (modify-syntax-entry ?_ "_" simula-mode-syntax-table)
- (modify-syntax-entry ?\| "." simula-mode-syntax-table)
- (modify-syntax-entry ?\{ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\} "." simula-mode-syntax-table))
+ "Emacs menu for SIMULA mode.")
(defvar simula-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-u" 'simula-backward-up-level)
- (define-key map "\C-c\C-p" 'simula-previous-statement)
- (define-key map "\C-c\C-d" 'simula-forward-down-level)
- (define-key map "\C-c\C-n" 'simula-next-statement)
- ;; (define-key map "\C-c\C-g" 'simula-goto-definition)
- ;; (define-key map "\C-c\C-h" 'simula-standard-help)
- (define-key map "\177" 'backward-delete-char-untabify)
- (define-key map ":" 'simula-electric-label)
- (define-key map "\e\C-q" 'simula-indent-exp)
- (define-key map "\t" 'simula-indent-command)
- ;; Emacs 19 defines menus in the mode map
- (define-key map [menu-bar simula]
- (cons "SIMULA" (make-sparse-keymap "SIMULA")))
- (define-key map [menu-bar simula indent-exp]
- '("Indent Expression" . simula-indent-exp))
- (define-key map [menu-bar simula indent-line]
- '("Indent Line" . simula-indent-command))
- (define-key map [menu-bar simula separator-navigate]
- '("--"))
- (define-key map [menu-bar simula backward-stmt]
- '("Previous Statement" . simula-previous-statement))
- (define-key map [menu-bar simula forward-stmt]
- '("Next Statement" . simula-next-statement))
- (define-key map [menu-bar simula backward-up]
- '("Backward Up Level" . simula-backward-up-level))
- (define-key map [menu-bar simula forward-down]
- '("Forward Down Statement" . simula-forward-down-level))
-
- (put 'simula-next-statement 'menu-enable '(not (eobp)))
- (put 'simula-previous-statement 'menu-enable '(not (bobp)))
- (put 'simula-forward-down-level 'menu-enable '(not (eobp)))
- (put 'simula-backward-up-level 'menu-enable '(not (bobp)))
- (put 'simula-indent-command 'menu-enable '(not buffer-read-only))
- (put 'simula-indent-exp 'menu-enable '(not buffer-read-only))
-
- ;; RMS: mouse-3 should not select this menu. mouse-3's global
- ;; definition is useful in SIMULA mode and we should not interfere
- ;; with that. The menu is mainly for beginners, and for them,
- ;; the menubar requires less memory than a special click.
- ;; in Lucid Emacs, we want the menu to popup when the 3rd button is
- ;; hit. In 19.10 and beyond this is done automatically if we put
- ;; the menu on mode-popup-menu variable, see c-common-init [cc-mode.el]
- ;;(if (not (boundp 'mode-popup-menu))
- ;; (define-key simula-mode-map 'button3 'simula-popup-menu))
+ (define-key map "\C-c\C-u" #'simula-backward-up-level)
+ (define-key map "\C-c\C-p" #'simula-previous-statement)
+ (define-key map "\C-c\C-d" #'simula-forward-down-level)
+ (define-key map "\C-c\C-n" #'simula-next-statement)
+ ;; (define-key map "\C-c\C-g" #'simula-goto-definition)
+ ;; (define-key map "\C-c\C-h" #'simula-standard-help)
+ (define-key map "\177" #'backward-delete-char-untabify)
+ (define-key map ":" #'simula-electric-label)
+ (define-key map "\e\C-q" #'simula-indent-exp)
+ ;; (define-key map "\t" #'simula-indent-command)
map)
"Keymap used in `simula-mode'.")
-;; menus for Lucid
-(defun simula-popup-menu (_e)
- "Pops up the SIMULA menu."
- (interactive "@e")
- (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu)))
+(easy-menu-define simula-mode-menu simula-mode-map
+ "Menu for `simula-mode'."
+ '("SIMULA"
+ ["Forward Down Statement" simula-forward-down-level
+ :enable (not (eobp))]
+ ["Backward Up Level" simula-backward-up-level
+ :enable (not (bobp))]
+ ["Next Statement" simula-next-statement
+ :enable (not (eobp))]
+ ["Previous Statement" simula-previous-statement
+ :enable (not (bobp))]
+ "---"
+ ;; ["Indent Line" simula-indent-command
+ ;; :enable (not buffer-read-only)]
+ ["Indent Expression" simula-indent-exp
+ :enable (not buffer-read-only)]))
;;;###autoload
(define-derived-mode simula-mode prog-mode "Simula"
"Major mode for editing SIMULA code.
\\{simula-mode-map}
Variables controlling indentation style:
- `simula-tab-always-indent'
- Non-nil means TAB in SIMULA mode should always reindent the current line,
- regardless of where in the line point is when the TAB command is used.
`simula-indent-level'
Indentation of SIMULA statements with respect to containing block.
`simula-substatement-offset'
@@ -365,22 +327,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."
- (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)
+ (setq-local comment-column 40)
+ ;; (setq-local end-comment-column 75)
+ (setq-local paragraph-start "[ \t]*$\\|\f")
+ (setq-local paragraph-separate paragraph-start)
+ (setq-local indent-line-function #'simula-indent-line)
+ (setq-local comment-start "! ")
+ (setq-local comment-end " ;")
+ (setq-local comment-start-skip "!+ *")
+ (setq-local parse-sexp-ignore-comments nil)
+ (setq-local comment-multi-line t)
+ (setq-local 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"))))
+ (setq-local syntax-propertize-function
+ simula-syntax-propertize-function)
(abbrev-mode 1))
(defun simula-indent-exp ()
@@ -449,6 +411,7 @@ A numeric argument, regardless of its value, means indent rigidly
all the lines of the SIMULA statement after point so that this line
becomes properly indented.
The relative indentation among the lines of the statement are preserved."
+ (declare (obsolete indent-for-tab-command "28.1"))
(interactive "P")
(let ((case-fold-search t))
(if (or whole-exp simula-tab-always-indent
@@ -1598,20 +1561,8 @@ If not nil and not t, move to limit of search and return nil."
(simula-install-standard-abbrevs))
;; Hilit mode support.
-(when (fboundp 'hilit-set-mode-patterns)
- (when (and (boundp 'hilit-patterns-alist)
- (not (assoc 'simula-mode hilit-patterns-alist)))
- (hilit-set-mode-patterns
- 'simula-mode
- '(
- ("^%\\([ \t\f].*\\)?$" nil comment)
- ("^%include\\>" nil include)
- ("\"[^\"\n]*\"\\|'.'\\|'![0-9]+!'" nil string)
- ("\\<\\(ACTIVATE\\|AFTER\\|AND\\|ARRAY\\|AT\\|BEFORE\\|BEGIN\\|BOOLEAN\\|CHARACTER\\|CLASS\\|DELAY\\|DO\\|ELSE\\|END\\|EQ\\|EQV\\|EXTERNAL\\|FALSE\\|FOR\\|GE\\|GO\\|GOTO\\|GT\\|HIDDEN\\|IF\\|IMP\\|IN\\|INNER\\|INSPECT\\|INTEGER\\|IS\\|LABEL\\|LE\\|LONG\\|LT\\|NAME\\|NE\\|NEW\\|NONE\\|NOT\\|NOTEXT\\|OR\\|OTHERWISE\\|PRIOR\\|PROCEDURE\\|PROTECTED\\|QUA\\|REACTIVATE\\|REAL\\|REF\\|SHORT\\|STEP\\|SWITCH\\|TEXT\\|THEN\\|THIS\\|TO\\|TRUE\\|UNTIL\\|VALUE\\|VIRTUAL\\|WHEN\\|WHILE\\)\\>" nil keyword)
- ("!\\|\\<COMMENT\\>" ";" comment))
- nil 'case-insensitive)))
-;; defuns for submitting bug reports
+;; obsolete
(defconst simula-mode-help-address "bug-gnu-emacs@gnu.org"
"Address accepting submission of `simula-mode' bug reports.")
@@ -1620,7 +1571,13 @@ If not nil and not t, move to limit of search and return nil."
"24.4")
(define-obsolete-function-alias 'simula-submit-bug-report
- 'report-emacs-bug "24.4")
+ #'report-emacs-bug "24.4")
+
+(defun simula-popup-menu (_e)
+ "Pops up the SIMULA menu."
+ (declare (obsolete simula-mode-menu "28.1"))
+ (interactive "@e")
+ (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu)))
(provide 'simula)
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 38cc0b4ff93..f144549cf6d 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -6,7 +6,6 @@
;; Maintainer: Michael Mauger <michael@mauger.com>
;; Version: 3.6
;; Keywords: comm languages processes
-;; URL: https://savannah.gnu.org/projects/emacs/
;; This file is part of GNU Emacs.
@@ -232,10 +231,6 @@
(require 'cl-lib)
(require 'comint)
-;; Need the following to allow GNU Emacs 19 to compile the file.
-(eval-when-compile
- (require 'regexp-opt))
-(require 'custom)
(require 'thingatpt)
(require 'view)
(eval-when-compile (require 'subr-x)) ; string-empty-p
@@ -257,7 +252,6 @@
(defcustom sql-user ""
"Default username."
:type 'string
- :group 'SQL
:safe 'stringp)
(defcustom sql-password ""
@@ -265,33 +259,28 @@
If you customize this, the value will be stored in your init
file. Since that is a plaintext file, this could be dangerous."
:type 'string
- :group 'SQL
:risky t)
(defcustom sql-database ""
"Default database."
:type 'string
- :group 'SQL
:safe 'stringp)
(defcustom sql-server ""
"Default server or host."
:type 'string
- :group 'SQL
:safe 'stringp)
(defcustom sql-port 0
"Default port for connecting to a MySQL or Postgres server."
:version "24.1"
:type 'number
- :group 'SQL
:safe 'numberp)
(defcustom sql-default-directory nil
"Default directory for SQL processes."
:version "25.1"
:type '(choice (const nil) string)
- :group 'SQL
:safe 'stringp)
;; Login parameter type
@@ -348,8 +337,7 @@ file. Since that is a plaintext file, this could be dangerous."
(const :format "" :completion)
(sexp :tag ":completion")
(const :format "" :must-match)
- (restricted-sexp
- :match-alternatives (listp stringp))))
+ (symbol :tag ":must-match")))
(const port)))
;; SQL Product support
@@ -461,7 +449,7 @@ file. Since that is a plaintext file, this could be dangerous."
:prompt-regexp "^mysql> "
:prompt-length 6
:prompt-cont-regexp "^ -> "
- :syntax-alist ((?# . "< b"))
+ :syntax-alist ((?# . "< b") (?\\ . "\\"))
:input-filter sql-remove-tabs-filter)
(oracle
@@ -496,6 +484,7 @@ file. Since that is a plaintext file, this could be dangerous."
:prompt-regexp "^[[:alnum:]_]*=[#>] "
:prompt-length 5
:prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] "
+ :statement sql-postgres-statement-starters
:input-filter sql-remove-tabs-filter
:terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g"))
@@ -707,9 +696,9 @@ making new SQLi sessions."
(repeat :inline t
(list :tab "Other"
(symbol :tag " Variable Symbol")
+ ;; FIXME: Why "Value *Expression*"?
(sexp :tag "Value Expression")))))
- :version "24.1"
- :group 'SQL)
+ :version "24.1")
(defvaralias 'sql-dialect 'sql-product)
@@ -723,7 +712,6 @@ This allows highlighting buffers properly when you open them."
(capitalize (symbol-name (car prod-info))))
,(car prod-info)))
sql-product-alist))
- :group 'SQL
:safe 'symbolp)
;; SQL indent support
@@ -735,7 +723,6 @@ SQL statements with easy customizations to support varied layout
requirements.
The package must be available to be loaded and activated."
- :group 'SQL
:link '(url-link "https://elpa.gnu.org/packages/sql-indent.html")
:type 'boolean
:version "27.1")
@@ -846,12 +833,11 @@ host key."
(setq w (locate-user-emacs-file (concat "sql-wallet" ext)
(concat ".sql-wallet" ext)))
(when (file-exists-p w)
- (setq wallet w)))))
+ (setq wallet (list w))))))
"Identification of the password wallet.
See `sql-password-search-wallet-function' to understand how this value
is used to locate the password wallet."
- :type `(plist-get (symbol-plist 'auth-sources) 'custom-type)
- :group 'SQL
+ :type (plist-get (symbol-plist 'auth-sources) 'custom-type)
:version "27.1")
(defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet
@@ -878,8 +864,7 @@ current input in the SQLi buffer to the process."
:type '(choice (const :tag "Nothing" nil)
(const :tag "The semicolon `;'" semicolon)
(const :tag "The string `go' by itself" go))
- :version "20.8"
- :group 'SQL)
+ :version "20.8")
(defcustom sql-send-terminator nil
"When non-nil, add a terminator to text sent to the SQL interpreter.
@@ -905,10 +890,9 @@ it automatically."
(const :tag "Default Terminator" t)
(string :tag "Terminator String")
(cons :tag "Terminator Pattern and String"
- (string :tag "Terminator Pattern")
+ (regexp :tag "Terminator Pattern")
(string :tag "Terminator String")))
- :version "22.2"
- :group 'SQL)
+ :version "22.2")
(defvar sql-contains-names nil
"When non-nil, the current buffer contains database names.
@@ -932,8 +916,7 @@ buffer."
:type '(choice (const :tag "Default" t)
(const :tag "No display" nil)
(function :tag "Display Buffer function"))
- :version "27.1"
- :group 'SQL)
+ :version "27.1")
;; imenu support for sql-mode.
@@ -971,8 +954,7 @@ This is used to initialize `comint-input-ring-file-name'.
Note that the size of the input history is determined by the variable
`comint-input-ring-size'."
:type '(choice (const :tag "none" nil)
- (file))
- :group 'SQL)
+ (file)))
(defcustom sql-input-ring-separator "\n--\n"
"Separator between commands in the history file.
@@ -987,21 +969,18 @@ does not have it, setting `sql-input-ring-separator' will have no
effect. In that case multiline commands will be split into several
commands when the input history is read, as if you had set
`sql-input-ring-separator' to \"\\n\"."
- :type 'string
- :group 'SQL)
+ :type 'string)
;; The usual hooks
(defcustom sql-interactive-mode-hook '(sql-indent-enable)
"Hook for customizing `sql-interactive-mode'."
:type 'hook
- :group 'SQL
:version "27.1")
(defcustom sql-mode-hook '(sql-indent-enable)
"Hook for customizing `sql-mode'."
:type 'hook
- :group 'SQL
:version "27.1")
(defcustom sql-set-sqli-hook '()
@@ -1009,8 +988,7 @@ commands when the input history is read, as if you had set
This is called by `sql-set-sqli-buffer' when the value of `sql-buffer'
is changed."
- :type 'hook
- :group 'SQL)
+ :type 'hook)
(defcustom sql-login-hook '()
"Hook for interacting with a buffer in `sql-interactive-mode'.
@@ -1018,23 +996,7 @@ is changed."
This hook is invoked in a buffer once it is ready to accept input
for the first time."
:version "24.1"
- :type 'hook
- :group 'SQL)
-
-;; Customization for ANSI
-
-(defcustom sql-ansi-statement-starters
- (regexp-opt '("create" "alter" "drop"
- "select" "insert" "update" "delete" "merge"
- "grant" "revoke"))
- "Regexp of keywords that start SQL commands.
-
-All products share this list; products should define a regexp to
-identify additional keywords in a variable defined by
-the :statement feature."
- :version "24.1"
- :type 'string
- :group 'SQL)
+ :type 'hook)
;; Customization for Oracle
@@ -1046,27 +1008,17 @@ 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."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-oracle-options '("-L")
"List of additional options for `sql-oracle-program'."
:type '(repeat string)
- :version "24.4"
- :group 'SQL)
+ :version "24.4")
(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-oracle-statement-starters
- (regexp-opt '("declare" "begin" "with"))
- "Additional statement starting keywords in Oracle."
- :version "24.1"
- :type 'string
- :group 'SQL)
+ :version "24.1")
(defcustom sql-oracle-scan-on t
"Non-nil if placeholders should be replaced in Oracle SQLi.
@@ -1082,8 +1034,7 @@ You need to issue the following command in SQL*Plus to be safe:
In older versions of SQL*Plus, this was the SET SCAN OFF command."
:version "24.1"
- :type 'boolean
- :group 'SQL)
+ :type 'boolean)
(defcustom sql-db2-escape-newlines nil
"Non-nil if newlines should be escaped by a backslash in DB2 SQLi.
@@ -1092,8 +1043,7 @@ When non-nil, Emacs will automatically insert a space and
backslash prior to every newline in multi-line SQL statements as
they are submitted to an interactive DB2 session."
:version "24.3"
- :type 'boolean
- :group 'SQL)
+ :type 'boolean)
;; Customization for SQLite
@@ -1103,21 +1053,18 @@ they are submitted to an interactive DB2 session."
"Command to start SQLite.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-sqlite-options nil
"List of additional options for `sql-sqlite-program'."
:type '(repeat string)
- :version "20.8"
- :group 'SQL)
+ :version "20.8")
(defcustom sql-sqlite-login-params '((database :file nil
:must-match confirm))
"List of login parameters needed to connect to SQLite."
:type 'sql-login-params
- :version "26.1"
- :group 'SQL)
+ :version "26.1")
;; Customization for MariaDB
@@ -1134,22 +1081,19 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start mysql by Oracle.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-mysql-options nil
"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)
+ :version "20.8")
(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)
+ :version "24.1")
;; Customization for Solid
@@ -1157,14 +1101,12 @@ on Windows: \"-C\" \"-t\" \"-f\" \"-n\"."
"Command to start SOLID SQL Editor.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(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)
+ :version "24.1")
;; Customization for Sybase
@@ -1172,21 +1114,18 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start isql by Sybase.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-sybase-options nil
"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)
+ :version "20.8")
(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)
+ :version "24.1")
;; Customization for Informix
@@ -1194,14 +1133,12 @@ Some versions of isql might require the -n option in order to work."
"Command to start dbaccess by Informix.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-informix-login-params '(database)
"List of login parameters needed to connect to Informix."
:type 'sql-login-params
- :version "24.1"
- :group 'SQL)
+ :version "24.1")
;; Customization for Ingres
@@ -1209,14 +1146,12 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start sql by Ingres.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-ingres-login-params '(database)
"List of login parameters needed to connect to Ingres."
:type 'sql-login-params
- :version "24.1"
- :group 'SQL)
+ :version "24.1")
;; Customization for Microsoft
@@ -1229,21 +1164,18 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start osql by Microsoft.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-ms-options '("-w" "300" "-n")
;; -w is the linesize
"List of additional options for `sql-ms-program'."
:type '(repeat string)
- :version "22.1"
- :group 'SQL)
+ :version "22.1")
(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)
+ :version "24.1")
;; Customization for Postgres
@@ -1251,8 +1183,7 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start psql by Postgres.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-postgres-options '("-P" "pager=off")
"List of additional options for `sql-postgres-program'.
@@ -1263,8 +1194,7 @@ name, add the string \"-u\" to the list of options. If you want to
provide a user name on the command line (newer versions such as 7.1),
add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
:type '(repeat string)
- :version "20.8"
- :group 'SQL)
+ :version "20.8")
(defcustom sql-postgres-login-params
`((user :default ,(user-login-name))
@@ -1275,8 +1205,7 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
server)
"List of login parameters needed to connect to Postgres."
:type 'sql-login-params
- :version "26.1"
- :group 'SQL)
+ :version "26.1")
(defun sql-postgres-list-databases ()
"Return a list of available PostgreSQL databases."
@@ -1297,20 +1226,17 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
"Command to start isql by Interbase.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-interbase-options nil
"List of additional options for `sql-interbase-program'."
:type '(repeat string)
- :version "20.8"
- :group 'SQL)
+ :version "20.8")
(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)
+ :version "24.1")
;; Customization for DB2
@@ -1318,20 +1244,17 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start db2 by IBM.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-db2-options nil
"List of additional options for `sql-db2-program'."
:type '(repeat string)
- :version "20.8"
- :group 'SQL)
+ :version "20.8")
(defcustom sql-db2-login-params nil
"List of login parameters needed to connect to DB2."
:type 'sql-login-params
- :version "24.1"
- :group 'SQL)
+ :version "24.1")
;; Customization for Linter
@@ -1339,20 +1262,17 @@ Starts `sql-interactive-mode' after doing some setup."
"Command to start inl by RELEX.
Starts `sql-interactive-mode' after doing some setup."
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-linter-options nil
"List of additional options for `sql-linter-program'."
:type '(repeat string)
- :version "21.3"
- :group 'SQL)
+ :version "21.3")
(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)
+ :version "24.1")
@@ -1436,10 +1356,7 @@ specified, it's `sql-product' or `sql-connection' must match."
(defvar sql-interactive-mode-map
(let ((map (make-sparse-keymap)))
- (if (fboundp 'set-keymap-parent)
- (set-keymap-parent map comint-mode-map); Emacs
- (if (fboundp 'set-keymap-parents)
- (set-keymap-parents map (list comint-mode-map)))); XEmacs
+ (set-keymap-parent map comint-mode-map)
(if (fboundp 'set-keymap-name)
(set-keymap-name map 'sql-interactive-mode-map)); XEmacs
(define-key map (kbd "C-j") 'sql-accumulate-and-indent)
@@ -1566,6 +1483,26 @@ Based on `comint-mode-map'.")
table)
"Syntax table used in `sql-mode' and `sql-interactive-mode'.")
+;; Motion Function Keywords
+
+(defvar sql-ansi-statement-starters
+ (regexp-opt '("create" "alter" "drop"
+ "select" "insert" "update" "delete" "merge"
+ "grant" "revoke"))
+ "Regexp of keywords that start SQL commands.
+
+All products share this list; products should define a regexp to
+identify additional keywords in a variable defined by
+the :statement feature.")
+
+(defvar sql-oracle-statement-starters
+ (regexp-opt '("declare" "begin" "with"))
+ "Additional statement-starting keywords in Oracle.")
+
+(defvar sql-postgres-statement-starters
+ (regexp-opt '("with"))
+ "Additional statement-starting keywords in Postgres.")
+
;; Font lock support
(defvar sql-mode-font-lock-object-name
@@ -1609,9 +1546,7 @@ statement. The format of variable should be a valid
;; `sql-font-lock-keywords-builder' function and follow the
;; implementation pattern used for the other products in this file.
-(eval-when-compile
- (defvar sql-mode-ansi-font-lock-keywords)
- (setq sql-mode-ansi-font-lock-keywords nil))
+(defvar sql-mode-ansi-font-lock-keywords)
(eval-and-compile
(defun sql-font-lock-keywords-builder (face boundaries &rest keywords)
@@ -1788,7 +1723,7 @@ to add functions and PL/SQL keywords.")
"ORDER BY 2 DESC, 3 DESC, 4 DESC, 5 DESC, 6 DESC, 1;")
nil nil)
(with-current-buffer b
- (set (make-local-variable 'sql-product) 'oracle)
+ (setq-local sql-product 'oracle)
(sql-product-font-lock t nil)
(font-lock-mode +1)))))
@@ -2374,7 +2309,8 @@ function `regexp-opt'.")
"ansi_warnings" "forceplan" "showplan_all" "showplan_text"
"statistics" "implicit_transactions" "remote_proc_transactions"
"transaction" "xact_abort"
-) t)
+)
+ t)
"\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$")
'font-lock-doc-face)
@@ -2856,7 +2792,7 @@ See `sql-product-alist' for a list of products and supported features."
(member feature sql-indirect-features)
(not not-indirect)
(symbolp v))
- (eval v)
+ (symbol-value v)
v))
(error "`%s' is not a known product; use `sql-add-product' to add it first." product)
nil)))
@@ -2874,7 +2810,7 @@ configured."
((syntax-alist (sql-product-font-lock-syntax-alist)))
;; Get the product-specific keywords.
- (set (make-local-variable 'sql-mode-font-lock-keywords)
+ (setq-local sql-mode-font-lock-keywords
(append
(unless (eq sql-product 'ansi)
(sql-get-product-feature sql-product :font-lock))
@@ -2886,15 +2822,13 @@ configured."
;; Setup font-lock. Force re-parsing of `font-lock-defaults'.
(kill-local-variable 'font-lock-set-defaults)
- (set (make-local-variable 'font-lock-defaults)
+ (setq-local 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)
+ (when font-lock-mode
(font-lock-mode-internal nil)
(font-lock-mode-internal t))
@@ -3057,7 +2991,7 @@ displayed."
;; (defconst sql-smie-grammar
;; (smie-prec2->grammar
;; (smie-bnf->prec2
-;; ;; Partly based on http://www.h2database.com/html/grammar.html
+;; ;; Partly based on https://www.h2database.com/html/grammar.html
;; '((cmd ("SELECT" select-exp "FROM" select-table-exp)
;; )
;; (select-exp ("*") (exp) (exp "AS" column-alias))
@@ -3790,8 +3724,7 @@ to avoid deleting non-prompt output."
;; If we've found all the expected prompts, stop looking
(if (= sql-output-newline-count 0)
- (setq sql-output-newline-count nil
- oline (concat "\n" oline))
+ (setq sql-output-newline-count nil)
;; Still more possible prompts, leave them for the next pass
(setq sql-preoutput-hold oline
@@ -3836,6 +3769,8 @@ to avoid deleting non-prompt output."
(with-current-buffer sql-buffer
(when sql-debug-send
(message ">>SQL> %S" s))
+ (insert "\n")
+ (comint-set-process-mark)
;; Send the string (trim the trailing whitespace)
(sql-input-sender (get-buffer-process (current-buffer)) s)
@@ -4196,8 +4131,8 @@ details or extends the listing to include other schemas objects."
(sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil)
(with-current-buffer sqlbuf
;; Contains the name of database objects
- (set (make-local-variable 'sql-contains-names) t)
- (set (make-local-variable 'sql-buffer) sqlbuf))))
+ (setq-local sql-contains-names t)
+ (setq-local sql-buffer sqlbuf))))
(defun sql-list-table (name &optional enhanced)
"List the details of a database table named NAME.
@@ -4244,15 +4179,15 @@ must tell Emacs. Here's how to do that in your init file:
\(add-hook \\='sql-mode-hook
(lambda ()
- (modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))"
- :group 'SQL
+ (modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))"
:abbrev-table sql-mode-abbrev-table
- (if sql-mode-menu
- (easy-menu-add sql-mode-menu)); XEmacs
+ (when (and (featurep 'xemacs)
+ sql-mode-menu)
+ (easy-menu-add sql-mode-menu))
;; (smie-setup sql-smie-grammar #'sql-smie-rules)
- (set (make-local-variable 'comment-start) "--")
+ (setq-local 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
@@ -4262,12 +4197,24 @@ must tell Emacs. Here's how to do that in your init file:
imenu-case-fold-search t)
;; Make `sql-send-paragraph' work on paragraphs that contain indented
;; lines.
- (set (make-local-variable 'paragraph-separate) "[\f]*$")
- (set (make-local-variable 'paragraph-start) "[\n\f]")
+ (setq-local paragraph-separate "[\f]*$")
+ (setq-local paragraph-start "[\n\f]")
;; Abbrevs
(setq-local abbrev-all-caps 1)
;; Contains the name of database objects
- (set (make-local-variable 'sql-contains-names) t)
+ (setq-local sql-contains-names t)
+ (setq-local syntax-propertize-function
+ (syntax-propertize-rules
+ ;; Handle escaped apostrophes within strings.
+ ("''"
+ (0
+ (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0))))
+ (string-to-syntax ".")
+ (forward-char -1)
+ nil)))
+ ;; Propertize rules to not have /- and -* start comments.
+ ("\\(/-\\)" (1 "."))
+ ("\\(-\\*\\)" (1 "."))))
;; Set syntax and font-face highlighting
;; Catch changes to sql-product and highlight accordingly
(sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591
@@ -4280,7 +4227,7 @@ must tell Emacs. Here's how to do that in your init file:
(put 'sql-interactive-mode 'mode-class 'special)
(put 'sql-interactive-mode 'custom-mode-group 'SQL)
;; FIXME: Why not use `define-derived-mode'?
-(defun sql-interactive-mode ()
+(define-derived-mode sql-interactive-mode comint-mode "SQLi[?]"
"Major mode to use a SQL interpreter interactively.
Do not call this function by yourself. The environment must be
@@ -4340,32 +4287,30 @@ Here is an example for your init file. It keeps the SQLi buffer a
certain length.
\(add-hook \\='sql-interactive-mode-hook
- (function (lambda ()
- (setq comint-output-filter-functions #\\='comint-truncate-buffer))))
+ (lambda ()
+ (setq comint-output-filter-functions #\\='comint-truncate-buffer)))
Here is another example. It will always put point back to the statement
you entered, right above the output it created.
\(setq comint-output-filter-functions
- (function (lambda (STR) (comint-show-output))))"
+ (lambda (STR) (comint-show-output)))"
+ :syntax-table sql-mode-syntax-table
;; FIXME: The doc above uses `setq' on `comint-output-filter-functions',
;; whereas hooks should be manipulated with things like `add/remove-hook'.
- (delay-mode-hooks (comint-mode))
+ :after-hook (sql--adjust-interactive-setup)
;; Get the `sql-product' for this interactive session.
- (set (make-local-variable 'sql-product)
- (or sql-interactive-product
- sql-product))
+ (setq-local sql-product (or sql-interactive-product
+ sql-product))
;; Setup the mode.
- (setq major-mode 'sql-interactive-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)
+ (when (and (featurep 'xemacs)
+ sql-interactive-mode-menu)
+ (easy-menu-add sql-interactive-mode-menu))
;; 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
@@ -4374,7 +4319,7 @@ you entered, right above the output it created.
(sql-product-font-lock t nil)
;; Enable commenting and uncommenting of the region.
- (set (make-local-variable 'comment-start) "--")
+ (setq-local comment-start "--")
;; Abbreviation table init and case-insensitive. It is not activated
;; by default.
(setq local-abbrev-table sql-mode-abbrev-table)
@@ -4383,35 +4328,36 @@ you entered, right above the output it created.
(let ((proc (get-buffer-process (current-buffer))))
(when proc (set-process-sentinel proc #'sql-stop)))
;; Save the connection and login params
- (set (make-local-variable 'sql-user) sql-user)
- (set (make-local-variable 'sql-database) sql-database)
- (set (make-local-variable 'sql-server) sql-server)
- (set (make-local-variable 'sql-port) sql-port)
- (set (make-local-variable 'sql-connection) sql-connection)
+ (setq-local sql-user sql-user)
+ (setq-local sql-database sql-database)
+ (setq-local sql-server sql-server)
+ (setq-local sql-port sql-port)
+ (setq-local sql-connection sql-connection)
(setq-default sql-connection nil)
;; Contains the name of database objects
- (set (make-local-variable 'sql-contains-names) t)
+ (setq-local sql-contains-names t)
;; Keep track of existing object names
- (set (make-local-variable 'sql-completion-object) nil)
- (set (make-local-variable 'sql-completion-column) nil)
+ (setq-local sql-completion-object nil)
+ (setq-local sql-completion-column nil)
;; Create a useful name for renaming this buffer later.
- (set (make-local-variable 'sql-alternate-buffer-name)
- (sql-make-alternate-buffer-name))
+ (setq-local sql-alternate-buffer-name
+ (sql-make-alternate-buffer-name))
;; User stuff. Initialize before the hook.
- (set (make-local-variable 'sql-prompt-regexp)
- (or (sql-get-product-feature sql-product :prompt-regexp) "^"))
- (set (make-local-variable 'sql-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))
+ (setq-local sql-prompt-regexp
+ (or (sql-get-product-feature sql-product :prompt-regexp) "^"))
+ (setq-local sql-prompt-length
+ (sql-get-product-feature sql-product :prompt-length))
+ (setq-local sql-prompt-cont-regexp
+ (sql-get-product-feature sql-product :prompt-cont-regexp))
(make-local-variable 'sql-output-newline-count)
(make-local-variable 'sql-preoutput-hold)
(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 the mode hook (along with comint's hooks).
- (run-mode-hooks 'sql-interactive-mode-hook)
+ (make-local-variable 'sql-input-ring-file-name))
+
+(defun sql--adjust-interactive-setup ()
+ "Finish the mode's setup after running the mode hook."
;; Set comint based on user overrides.
(setq comint-prompt-regexp
(if sql-prompt-cont-regexp
@@ -4420,7 +4366,7 @@ you entered, right above the output it created.
sql-prompt-regexp))
(setq left-margin (or sql-prompt-length 0))
;; Install input sender
- (set (make-local-variable 'comint-input-sender) #'sql-input-sender)
+ (setq-local 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.
@@ -4490,7 +4436,7 @@ is specified in the connection settings."
(dolist (vv connect-set)
(let ((var (car vv))
(val (cadr vv)))
- (set-default var (eval val))))
+ (set-default var (eval val)))) ;FIXME: Why `eval'?
(setq-default sql-connection connection)
;; :sqli-login params variable
@@ -4521,10 +4467,10 @@ is specified in the connection settings."
(if vals (cons var vals) var)))))
;; Start the SQLi session with revised list of login parameters
- (eval `(let ((,param-var ',rem-vars))
- (sql-product-interactive
- ',sql-product
- ',(or buf-name (format "<%s>" connection))))))
+ (cl-progv (list param-var) (list rem-vars)
+ (sql-product-interactive
+ sql-product
+ (or buf-name (format "<%s>" connection)))))
(user-error "SQL Connection <%s> does not exist" connection)
nil)))
@@ -4595,7 +4541,10 @@ optionally is saved to the user's init file."
(format "Connection <%s>\t%s" (car conn)
(let ((sql-user "") (sql-database "")
(sql-server "") (sql-port 0))
- (eval `(let ,(cdr conn) (sql-make-alternate-buffer-name)))))
+ (cl-progv
+ (mapcar #'car (cdr conn))
+ (mapcar #'cadr (cdr conn))
+ (sql-make-alternate-buffer-name))))
(list 'sql-connect (car conn))
t))
sql-connection-alist)
@@ -4698,8 +4647,7 @@ the call to \\[sql-product-interactive] with
;; Set the new buffer name
(setq new-sqli-buffer (current-buffer))
- (set (make-local-variable 'sql-buffer)
- (buffer-name new-sqli-buffer))
+ (setq-local sql-buffer (buffer-name new-sqli-buffer))
;; Set `sql-buffer' in the start buffer
(with-current-buffer start-buffer
@@ -4977,8 +4925,7 @@ The default comes from `process-coding-system-alist' and
See the distinct values in ALL_OBJECTS.OBJECT_TYPE for possible values."
:version "24.1"
- :type '(repeat string)
- :group 'SQL)
+ :type '(repeat string))
(defun sql-oracle-completion-object (sqlbuf schema)
(sql-redirect-value
@@ -5624,21 +5571,18 @@ buffer.
(defcustom sql-vertica-program "vsql"
"Command to start the Vertica client."
:version "25.1"
- :type 'file
- :group 'SQL)
+ :type 'file)
(defcustom sql-vertica-options '("-P" "pager=off")
"List of additional options for `sql-vertica-program'.
The default value disables the internal pager."
:version "25.1"
- :type '(repeat string)
- :group 'SQL)
+ :type '(repeat string))
(defcustom sql-vertica-login-params '(user password database server)
"List of login parameters needed to connect to Vertica."
:version "25.1"
- :type 'sql-login-params
- :group 'SQL)
+ :type 'sql-login-params)
(defun sql-comint-vertica (product options &optional buf-name)
"Create comint buffer and connect to Vertica."
@@ -5664,7 +5608,7 @@ The default value disables the internal pager."
(provide 'sql)
-;;; sql.el ends here
-
; LocalWords: sql SQL SQLite sqlite Sybase Informix MySQL
; LocalWords: Postgres SQLServer SQLi
+
+;;; sql.el ends here
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index c17c5214939..33b70d83bed 100644
--- a/lisp/progmodes/subword.el
+++ b/lisp/progmodes/subword.el
@@ -115,6 +115,8 @@ treat nomenclature boundaries as word boundaries."
(when subword-mode (superword-mode -1))
(subword-setup-buffer))
+;; This is defined also in cc-cmds.el, but as obsolete since 24.3.
+;; Let's keep this until the other one can also be removed.
(define-obsolete-function-alias 'c-subword-mode 'subword-mode "23.2")
;;;###autoload
@@ -330,7 +332,7 @@ as parts of words: e.g., in `superword-mode',
searching subwords in order to avoid unwanted reentrancy.")
(defun subword-setup-buffer ()
- (set (make-local-variable 'find-word-boundary-function-table)
+ (setq-local find-word-boundary-function-table
(if (or subword-mode superword-mode)
subword-find-word-boundary-function-table
subword-empty-char-table)))
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el
index 690938591f9..f6a50bf1a88 100644
--- a/lisp/progmodes/tcl.el
+++ b/lisp/progmodes/tcl.el
@@ -1,4 +1,4 @@
-;;; tcl.el --- Tcl code editing commands for Emacs
+;;; tcl.el --- Tcl code editing commands for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 1998-2021 Free Software Foundation, Inc.
@@ -120,20 +120,17 @@
(defcustom tcl-indent-level 4
"Indentation of Tcl statements with respect to containing block."
- :type 'integer
- :group 'tcl)
-(put 'tcl-indent-level 'safe-local-variable 'integerp)
+ :type 'integer)
+(put 'tcl-indent-level 'safe-local-variable #'integerp)
(defcustom tcl-continued-indent-level 4
"Indentation of continuation line relative to first line of command."
- :type 'integer
- :group 'tcl)
-(put 'tcl-continued-indent-level 'safe-local-variable 'integerp)
+ :type 'integer)
+(put 'tcl-continued-indent-level 'safe-local-variable #'integerp)
(defcustom tcl-auto-newline nil
"Non-nil means automatically newline before and after braces you insert."
- :type 'boolean
- :group 'tcl)
+ :type 'boolean)
(defcustom tcl-tab-always-indent tab-always-indent
"Control effect of TAB key.
@@ -151,8 +148,7 @@ to take place:
6. Move backward to start of comment, indenting if necessary."
:type '(choice (const :tag "Always" t)
(const :tag "Beginning only" nil)
- (other :tag "Maybe move or make or delete comment" tcl))
- :group 'tcl)
+ (other :tag "Maybe move or make or delete comment" tcl)))
(defcustom tcl-electric-hash-style nil ;; 'smart
@@ -163,28 +159,23 @@ meaning that the choice between `backslash' and `quote' should be
made depending on the number of hashes inserted; or nil, meaning that
no quoting should be done. Any other value for this variable is
taken to mean `smart'. The default is nil."
- :type '(choice (const backslash) (const quote) (const smart) (const nil))
- :group 'tcl)
+ :type '(choice (const backslash) (const quote) (const smart) (const nil)))
(defcustom tcl-help-directory-list nil
"List of topmost directories containing TclX help files."
- :type '(repeat directory)
- :group 'tcl)
+ :type '(repeat directory))
(defcustom tcl-use-smart-word-finder t
"If not nil, use smart way to find current word, for Tcl help feature."
- :type 'boolean
- :group 'tcl)
+ :type 'boolean)
(defcustom tcl-application "wish"
"Name of Tcl program to run in inferior Tcl mode."
- :type 'string
- :group 'tcl)
+ :type 'string)
(defcustom tcl-command-switches nil
"List of switches to supply to the `tcl-application' program."
- :type '(repeat string)
- :group 'tcl)
+ :type '(repeat string))
(defcustom tcl-prompt-regexp "^\\(% \\|\\)"
"If not nil, a regexp that will match the prompt in the inferior process.
@@ -192,8 +183,7 @@ If nil, the prompt is the name of the application with \">\" appended.
The default is \"^\\(% \\|\\)\", which will match the default primary
and secondary prompts for tclsh and wish."
- :type 'regexp
- :group 'tcl)
+ :type 'regexp)
(defcustom inferior-tcl-source-command "source %s\n"
"Format-string for building a Tcl command to load a file.
@@ -201,12 +191,10 @@ This format string should use `%s' to substitute a file name
and should result in a Tcl expression that will command the
inferior Tcl to load that file. The filename will be appropriately
quoted for Tcl."
- :type 'string
- :group 'tcl)
+ :type 'string)
(defface tcl-escaped-newline '((t :inherit font-lock-string-face))
"Face used for (non-escaped) backslash at end of a line in Tcl mode."
- :group 'tcl
:version "22.1")
;;
@@ -266,16 +254,16 @@ quoted for Tcl."
;; Maybe someone has a better set?
(let ((map (make-sparse-keymap)))
;; Will inherit from `comint-mode-map' thanks to define-derived-mode.
- (define-key map "\t" 'completion-at-point)
- (define-key map "\M-?" 'comint-dynamic-list-filename-completions)
- (define-key map "\177" 'backward-delete-char-untabify)
- (define-key map "\M-\C-x" 'tcl-eval-defun)
- (define-key map "\C-c\C-i" 'tcl-help-on-word)
- (define-key map "\C-c\C-v" 'tcl-eval-defun)
- (define-key map "\C-c\C-f" 'tcl-load-file)
- (define-key map "\C-c\C-t" 'inferior-tcl)
- (define-key map "\C-c\C-x" 'tcl-eval-region)
- (define-key map "\C-c\C-s" 'switch-to-tcl)
+ (define-key map "\t" #'completion-at-point)
+ (define-key map "\M-?" #'comint-dynamic-list-filename-completions)
+ (define-key map "\177" #'backward-delete-char-untabify)
+ (define-key map "\M-\C-x" #'tcl-eval-defun)
+ (define-key map "\C-c\C-i" #'tcl-help-on-word)
+ (define-key map "\C-c\C-v" #'tcl-eval-defun)
+ (define-key map "\C-c\C-f" #'tcl-load-file)
+ (define-key map "\C-c\C-t" #'inferior-tcl)
+ (define-key map "\C-c\C-x" #'tcl-eval-region)
+ (define-key map "\C-c\C-s" #'switch-to-tcl)
map)
"Keymap used in `inferior-tcl-mode'.")
@@ -356,7 +344,7 @@ information):
Add functions to the hook with `add-hook':
- (add-hook 'tcl-mode-hook 'tcl-guess-application)")
+ (add-hook 'tcl-mode-hook #'tcl-guess-application)")
(defvar tcl-proc-list
@@ -407,10 +395,65 @@ This variable is generally set from `tcl-proc-regexp',
`tcl-typeword-list', and `tcl-keyword-list' by the function
`tcl-set-font-lock-keywords'.")
+(eval-and-compile
+ (defconst tcl--word-delimiters "[;{ \t\n"))
+
+(defun tcl--syntax-of-quote (pos)
+ "Decide whether a double quote opens a string or not."
+ ;; This is pretty tricky, because strings can be written as "..."
+ ;; or as {...} or without any quoting at all for some simple and not so
+ ;; simple cases (e.g. `abc' but also `a"b'). To make things more
+ ;; interesting, code is represented as strings, so the content of
+ ;; strings can be later re-lexed to find nested strings.
+ (save-excursion
+ (let ((ppss (syntax-ppss pos)))
+ (cond
+ ((nth 8 ppss) nil) ;; Within a string or a comment.
+ ((not (memq (char-before pos)
+ (cons nil
+ (eval-when-compile
+ (mapcar #'identity tcl--word-delimiters)))))
+ ;; The double quote appears within some other lexical entity.
+ ;; FIXME: Similar treatment should be used for `{' which can appear
+ ;; within non-delimited strings (but only at top-level, so
+ ;; maybe it's not worth worrying about).
+ (string-to-syntax "."))
+ ((zerop (nth 0 ppss))
+ ;; Not within a { ... }, so can't be truncated by a }.
+ ;; FIXME: The syntax-table also considers () and [] as paren
+ ;; delimiters just like {}, even though Tcl treats them differently.
+ ;; Tho I'm not sure it's worth worrying about, either.
+ nil)
+ (t
+ ;; A double quote within a {...}: leave it as a normal string
+ ;; delimiter only if we don't find a closing } before we
+ ;; find a closing ".
+ (let ((type nil)
+ (depth 0))
+ (forward-char 1)
+ (while (and (not type)
+ (re-search-forward "[\"{}\\]" nil t))
+ (pcase (char-after (match-beginning 0))
+ (?\\ (forward-char 1))
+ (?\" (setq type 'matched))
+ (?\{ (cl-incf depth))
+ (?\} (if (zerop depth) (setq type 'unmatched)
+ (cl-incf depth)))))
+ (when (> (line-beginning-position) pos)
+ ;; The quote is not on the same line as the deciding
+ ;; factor, so make sure we revisit this choice later.
+ (put-text-property pos (point) 'syntax-multiline t))
+ (when (eq type 'unmatched)
+ ;; The quote has no matching close because a } closes the
+ ;; surrounding string before, so it doesn't really "open a string".
+ (string-to-syntax "."))))))))
+
(defconst tcl-syntax-propertize-function
+ ;; FIXME: Handle the [...] commands nested inside "..." strings.
(syntax-propertize-rules
;; Mark the few `#' that are not comment-markers.
- ("[^;[{ \t\n][ \t]*\\(#\\)" (1 ".")))
+ ((concat "[^" tcl--word-delimiters "][ \t]*\\(#\\)") (1 "."))
+ ("\"" (0 (tcl--syntax-of-quote (match-beginning 0)))))
"Syntactic keywords for `tcl-mode'.")
;; FIXME need some way to recognize variables because array refs look
@@ -573,45 +616,42 @@ 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."
(unless (and (boundp 'filladapt-mode) filladapt-mode)
- (set (make-local-variable 'paragraph-ignore-fill-prefix) t))
+ (setq-local paragraph-ignore-fill-prefix t))
- (set (make-local-variable 'indent-line-function) 'tcl-indent-line)
- (set (make-local-variable 'comment-indent-function) 'tcl-comment-indent)
+ (setq-local indent-line-function #'tcl-indent-line)
+ (setq-local comment-indent-function #'tcl-comment-indent)
;; Tcl doesn't require a final newline.
- ;; (make-local-variable 'require-final-newline)
- ;; (setq require-final-newline t)
+ ;; (setq-local require-final-newline t)
- (set (make-local-variable 'comment-start) "# ")
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(^\\|[;{[]\\)\\s-*\\)#+ *")
- (set (make-local-variable 'comment-end) "")
+ (setq-local comment-start "# ")
+ (setq-local comment-start-skip
+ "\\(\\(^\\|[;{[]\\)\\s-*\\)#+ *")
+ (setq-local comment-end "")
- (set (make-local-variable 'outline-regexp) ".")
- (set (make-local-variable 'outline-level) 'tcl-outline-level)
+ (setq-local outline-regexp ".")
+ (setq-local outline-level 'tcl-outline-level)
- (set (make-local-variable 'font-lock-defaults)
- '(tcl-font-lock-keywords nil nil nil beginning-of-defun))
- (set (make-local-variable 'syntax-propertize-function)
- tcl-syntax-propertize-function)
+ (setq-local font-lock-defaults
+ '(tcl-font-lock-keywords nil nil nil beginning-of-defun))
+ (setq-local syntax-propertize-function
+ tcl-syntax-propertize-function)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'syntax-propertize-multiline 'append 'local)
- (set (make-local-variable 'imenu-generic-expression)
- tcl-imenu-generic-expression)
+ (setq-local imenu-generic-expression tcl-imenu-generic-expression)
;; Settings for new dabbrev code.
- (set (make-local-variable 'dabbrev-case-fold-search) nil)
- (set (make-local-variable 'dabbrev-case-replace) nil)
- (set (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) "[$!]")
- (set (make-local-variable 'dabbrev-abbrev-char-regexp) "\\sw\\|\\s_")
-
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp)
- (set (make-local-variable 'add-log-current-defun-function)
- 'tcl-add-log-defun)
+ (setq-local dabbrev-case-fold-search nil)
+ (setq-local dabbrev-case-replace nil)
+ (setq-local dabbrev-abbrev-skip-leading-regexp "[$!]")
+ (setq-local dabbrev-abbrev-char-regexp "\\sw\\|\\s_")
- (setq-local beginning-of-defun-function #'tcl-beginning-of-defun-function)
- (setq-local end-of-defun-function #'tcl-end-of-defun-function)
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local defun-prompt-regexp tcl-omit-ws-regexp)
+ (setq-local add-log-current-defun-function
+ #'tcl-add-log-defun)
- (easy-menu-add tcl-mode-menu))
+ (setq-local end-of-defun-function #'tcl-end-of-defun-function))
@@ -808,14 +848,12 @@ Returns nil if line starts inside a string, t if in a comment."
state
containing-sexp
found-next-line)
- (cond
- (parse-start
+
+ (if parse-start
(goto-char parse-start))
- ((not (beginning-of-defun))
- ;; If we're not in a function, don't use
- ;; `tcl-beginning-of-defun-function'.
- (let ((beginning-of-defun-function nil))
- (beginning-of-defun))))
+
+ (beginning-of-defun)
+
(while (< (point) indent-point)
(setq parse-start (point))
(setq state (parse-partial-sexp (point) indent-point 0))
@@ -994,22 +1032,6 @@ Returns nil if line starts inside a string, t if in a comment."
;; Interfaces to other packages.
;;
-(defun tcl-beginning-of-defun-function (&optional arg)
- "`beginning-of-defun-function' for Tcl mode."
- (when (or (not arg) (= arg 0))
- (setq arg 1))
- (let* ((search-fn (if (> arg 0)
- ;; Positive arg means to search backward.
- #'re-search-backward
- #'re-search-forward))
- (arg (abs arg))
- (result t))
- (while (and (> arg 0) result)
- (unless (funcall search-fn tcl-proc-regexp nil t)
- (setq result nil))
- (setq arg (1- arg)))
- result))
-
(defun tcl-end-of-defun-function ()
"`end-of-defun-function' for Tcl mode."
;; Because we let users redefine tcl-proc-list, we don't really know
@@ -1158,14 +1180,14 @@ Variables controlling Inferior Tcl mode:
The following commands are available:
\\{inferior-tcl-mode-map}"
- (set (make-local-variable 'comint-prompt-regexp)
- (or tcl-prompt-regexp
- (concat "^" (regexp-quote tcl-application) ">")))
+ (setq-local comint-prompt-regexp
+ (or tcl-prompt-regexp
+ (concat "^" (regexp-quote tcl-application) ">")))
(setq mode-line-process '(": %s"))
(setq local-abbrev-table tcl-mode-abbrev-table)
(set-syntax-table tcl-mode-syntax-table)
- (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp)
- (set (make-local-variable 'inferior-tcl-delete-prompt-marker) (make-marker))
+ (setq-local defun-prompt-regexp tcl-omit-ws-regexp)
+ (setq-local inferior-tcl-delete-prompt-marker (make-marker))
(set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter))
;;;###autoload
@@ -1186,11 +1208,11 @@ See documentation for function `inferior-tcl-mode' for more information."
(unless (process-tty-name (inferior-tcl-proc))
(tcl-send-string (inferior-tcl-proc)
"set ::tcl_interactive 1; concat\n")))
- (set (make-local-variable 'tcl-application) cmd)
+ (setq-local tcl-application cmd)
(setq inferior-tcl-buffer "*inferior-tcl*")
(pop-to-buffer "*inferior-tcl*"))
-(defalias 'run-tcl 'inferior-tcl)
+(defalias 'run-tcl #'inferior-tcl)
@@ -1346,9 +1368,8 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'."
(not tcl-use-smart-word-finder)
tcl-use-smart-word-finder))))
(completing-read
- (if (or (null word) (string= word ""))
- "Help on Tcl command: "
- (format "Help on Tcl command (default %s): " word))
+ (format-prompt "Help on Tcl command: "
+ (and (not (equal word "")) word))
tcl-help-alist nil t nil nil word)))
current-prefix-arg))
(if (not (equal tcl-help-directory-list tcl-help-saved-dirs))
@@ -1392,7 +1413,7 @@ Prefix argument means switch to the Tcl buffer afterwards."
(list
;; car because comint-get-source returns a list holding the
;; filename.
- (car (comint-get-source "Load Tcl file: "
+ (car (comint-get-source "Load Tcl file"
(or (and
(derived-mode-p 'tcl-mode)
(buffer-file-name))
@@ -1412,7 +1433,7 @@ If an inferior Tcl process exists, it is killed first.
Prefix argument means switch to the Tcl buffer afterwards."
(interactive
(list
- (car (comint-get-source "Restart with Tcl file: "
+ (car (comint-get-source "Restart with Tcl file"
(or (and
(derived-mode-p 'tcl-mode)
(buffer-file-name))
@@ -1451,7 +1472,7 @@ Prefix argument means switch to the Tcl buffer afterwards."
(interactive "P")
(auto-fill-mode arg)
(if auto-fill-function
- (set (make-local-variable 'comment-auto-fill-only-comments) t)
+ (setq-local comment-auto-fill-only-comments t)
(kill-local-variable 'comment-auto-fill-only-comments)))
(defun tcl-electric-hash (&optional count)
@@ -1532,7 +1553,7 @@ The first line is assumed to look like \"#!.../program ...\"."
(save-excursion
(goto-char (point-min))
(if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)")
- (set (make-local-variable 'tcl-application) (match-string 1)))))
+ (setq-local tcl-application (match-string 1)))))
(defun tcl-popup-menu (_e)
"XEmacs menu support."
@@ -1556,21 +1577,21 @@ The first line is assumed to look like \"#!.../program ...\"."
(char-to-string char)))
string ""))
+
+
;;
-;; Bug reporting.
+;; Obsolete.
;;
-
-;; These are relics kept "just in case".
-(defalias 'tcl-uncomment-region 'uncomment-region)
-(defalias 'tcl-indent-for-comment 'comment-indent)
-(defalias 'add-log-tcl-defun 'tcl-add-log-defun)
-(defalias 'indent-tcl-exp 'tcl-indent-exp)
-(defalias 'calculate-tcl-indent 'tcl-calculate-indent)
-(defalias 'tcl-beginning-of-defun 'beginning-of-defun)
-(defalias 'tcl-end-of-defun 'end-of-defun)
-(defalias 'tcl-mark-defun 'mark-defun)
-(defun tcl-mark () (mark t))
+(define-obsolete-function-alias 'tcl-uncomment-region #'uncomment-region "28.1")
+(define-obsolete-function-alias 'tcl-indent-for-comment #'comment-indent "28.1")
+(define-obsolete-function-alias 'add-log-tcl-defun #'tcl-add-log-defun "28.1")
+(define-obsolete-function-alias 'indent-tcl-exp #'tcl-indent-exp "28.1")
+(define-obsolete-function-alias 'calculate-tcl-indent #'tcl-calculate-indent "28.1")
+(define-obsolete-function-alias 'tcl-beginning-of-defun #'beginning-of-defun "28.1")
+(define-obsolete-function-alias 'tcl-end-of-defun #'end-of-defun "28.1")
+(define-obsolete-function-alias 'tcl-mark-defun #'mark-defun "28.1")
+(defun tcl-mark () (declare (obsolete nil "28.1")) (mark t))
(provide 'tcl)
diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el
index 0fce70558c2..4622256bb9c 100644
--- a/lisp/progmodes/vera-mode.el
+++ b/lisp/progmodes/vera-mode.el
@@ -1,11 +1,11 @@
-;;; vera-mode.el --- major mode for editing Vera files
+;;; vera-mode.el --- major mode for editing Vera files -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
;; Author: Reto Zimmermann <reto@gnu.org>
;; Version: 2.28
;; Keywords: languages vera
-;; WWW: http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html
+;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 18/3/2008, and the maintainer agreed that when a bug is
@@ -33,9 +33,7 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commentary:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This package provides a simple Emacs major mode for editing Vera code.
;; It includes the following features:
@@ -44,38 +42,11 @@
;; - Indentation
;; - Word/keyword completion
;; - Block commenting
-;; - Works under GNU Emacs and XEmacs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Documentation
;; See comment string of function `vera-mode' or type `C-h m' in Emacs.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Installation
-
-;; Prerequisites: GNU Emacs 20.X/21.X, XEmacs 20.X/21.X
-
-;; Put `vera-mode.el' into the `site-lisp' directory of your Emacs installation
-;; or into an arbitrary directory that is added to the load path by the
-;; following line in your Emacs start-up file (`.emacs'):
-
-;; (setq load-path (cons (expand-file-name "<directory-name>") load-path))
-
-;; If you already have the compiled `vera-mode.elc' file, put it in the same
-;; directory. Otherwise, byte-compile the source file:
-;; Emacs: M-x byte-compile-file -> vera-mode.el
-;; Unix: emacs -batch -q -no-site-file -f batch-byte-compile vera-mode.el
-
-;; Add the following lines to the `site-start.el' file in the `site-lisp'
-;; directory of your Emacs installation or to your Emacs start-up file
-;; (`.emacs'):
-
-;; (autoload 'vera-mode "vera-mode" "Vera Mode" t)
-;; (setq auto-mode-alist (cons '("\\.vr[hi]?\\'" . vera-mode) auto-mode-alist))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -90,16 +61,14 @@
(defcustom vera-basic-offset 2
"Amount of basic offset used for indentation."
- :type 'integer
- :group 'vera)
+ :type 'integer)
(defcustom vera-underscore-is-part-of-word nil
"Non-nil means consider the underscore character `_' as part of word.
An identifier containing underscores is then treated as a single word in
select and move operations. All parts of an identifier separated by underscore
are treated as single words otherwise."
- :type 'boolean
- :group 'vera)
+ :type 'boolean)
(make-obsolete-variable 'vera-underscore-is-part-of-word
'superword-mode "24.4")
@@ -110,8 +79,7 @@ else if not at beginning of line then insert tab,
else if last command was a `TAB' or `RET' then dedent one step,
else indent current line.
If nil, TAB always indents current line."
- :type 'boolean
- :group 'vera)
+ :type 'boolean)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -125,9 +93,6 @@ If nil, TAB always indents current line."
(let ((map (make-sparse-keymap)))
;; Backspace/delete key bindings.
(define-key map [backspace] 'backward-delete-char-untabify)
- (unless (boundp 'delete-key-deletes-forward) ; XEmacs variable
- (define-key map [delete] 'delete-char)
- (define-key map [(meta delete)] 'kill-word))
;; Standard key bindings.
(define-key map "\M-e" 'vera-forward-statement)
(define-key map "\M-a" 'vera-backward-statement)
@@ -154,8 +119,6 @@ If nil, TAB always indents current line."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Menu
-(require 'easymenu)
-
(easy-menu-define vera-mode-menu vera-mode-map
"Menu keymap for Vera Mode."
'("Vera"
@@ -227,9 +190,7 @@ If nil, TAB always indents current line."
(modify-syntax-entry ?\{ "(}" syntax-table)
(modify-syntax-entry ?\} "){" syntax-table)
;; comment
- (if (featurep 'xemacs)
- (modify-syntax-entry ?\/ ". 1456" syntax-table) ; XEmacs
- (modify-syntax-entry ?\/ ". 124b" syntax-table)) ; Emacs
+ (modify-syntax-entry ?\/ ". 124b" syntax-table)
(modify-syntax-entry ?\* ". 23" syntax-table)
;; newline and CR
(modify-syntax-entry ?\n "> b" syntax-table)
@@ -288,7 +249,7 @@ Add a description of the problem and include a reproducible test case.
Feel free to send questions and enhancement requests to <reto@gnu.org>.
Official distribution is at
-URL `http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html'
+URL `https://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html'
The Vera Mode Maintainer
@@ -314,8 +275,6 @@ Key bindings:
;; initialize font locking
(set (make-local-variable 'font-lock-defaults)
'(vera-font-lock-keywords nil nil ((?\_ . "w"))))
- ;; add menu (XEmacs)
- (easy-menu-add vera-mode-menu)
;; miscellaneous
(message "Vera Mode %s. Type C-c C-h for documentation." vera-version))
@@ -542,12 +501,6 @@ Key bindings:
)
"List of Vera-RVM predefined constants.")
-;; `regexp-opt' undefined (`xemacs-devel' not installed)
-(unless (fboundp 'regexp-opt)
- (defun regexp-opt (strings &optional paren)
- (let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
- (concat open (mapconcat 'regexp-quote strings "\\|") close))))
-
(defconst vera-keywords-regexp
(concat "\\<\\(" (regexp-opt vera-keywords) "\\)\\>")
"Regexp for Vera keywords.")
@@ -796,10 +749,7 @@ This function does not modify point or mark."
(defun vera-skip-forward-literal ()
"Skip forward literal and return t if within one."
- (let ((state (save-excursion
- (if (fboundp 'syntax-ppss)
- (syntax-ppss)
- (parse-partial-sexp (point-min) (point))))))
+ (let ((state (save-excursion (syntax-ppss))))
(when (nth 8 state)
;; Inside a string or comment.
(goto-char (nth 8 state))
@@ -814,10 +764,7 @@ This function does not modify point or mark."
(defun vera-skip-backward-literal ()
"Skip backward literal and return t if within one."
- (let ((state (save-excursion
- (if (fboundp 'syntax-ppss)
- (syntax-ppss)
- (parse-partial-sexp (point-min) (point))))))
+ (let ((state (save-excursion (syntax-ppss))))
(when (nth 8 state)
;; Inside a string or comment.
(goto-char (nth 8 state))
@@ -1232,6 +1179,8 @@ Calls `indent-region' for whole buffer."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; electrifications
+(defvar hippie-expand-only-buffers)
+
(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',
@@ -1243,7 +1192,7 @@ If `vera-intelligent-tab' is nil, always indent line."
(interactive "*P")
(if vera-intelligent-tab
(progn
- (cond ((and (not (featurep 'xemacs)) (use-region-p))
+ (cond ((use-region-p)
(vera-indent-region (region-beginning) (region-end) nil))
((memq (char-syntax (preceding-char)) '(?w ?_))
(let ((case-fold-search t)
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index d5c155aecf1..2b88120eb9c 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -9,7 +9,7 @@
;; Keywords: languages
;; The "Version" is the date followed by the decimal rendition of the Git
;; commit hex.
-;; Version: 2019.12.17.268053413
+;; Version: 2021.04.12.188864585
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 19/3/2008, and the maintainer agreed that when a bug is
@@ -124,7 +124,7 @@
;;
;; This variable will always hold the version number of the mode
-(defconst verilog-mode-version "2019-12-17-ffa2ba5-vpo-GNU"
+(defconst verilog-mode-version "2021-04-12-b41d849-vpo-GNU"
"Version of this Verilog mode.")
(defconst verilog-mode-release-emacs t
"If non-nil, this version of Verilog mode was released with Emacs itself.")
@@ -134,6 +134,16 @@
(interactive)
(message "Using verilog-mode version %s" verilog-mode-version))
+(defmacro verilog--suppressed-warnings (warnings &rest body)
+ (declare (indent 1) (debug t))
+ (cond
+ ((fboundp 'with-suppressed-warnings)
+ `(with-suppressed-warnings ,warnings ,@body))
+ ((fboundp 'with-no-warnings)
+ `(with-no-warnings ,@body))
+ (t
+ `(progn ,@body))))
+
;; Insure we have certain packages, and deal with it if we don't
;; Be sure to note which Emacs flavor and version added each feature.
(eval-when-compile
@@ -220,7 +230,7 @@ STRING should be given if the last search was by `string-match' on STRING."
)
(if (fboundp 'defface)
nil ; great!
- (defmacro defface (var values doc &rest _args)
+ (defmacro defface (var _values _doc &rest _args)
`(make-face ,var))
)
@@ -280,7 +290,7 @@ STRING should be given if the last search was by `string-match' on STRING."
(concat open (mapconcat 'regexp-quote strings "\\|") close)))
)
;; Emacs.
- (defalias 'verilog-regexp-opt 'regexp-opt)))
+ (defalias 'verilog-regexp-opt #'regexp-opt)))
;; emacs >=22 has looking-back, but older emacs and xemacs don't.
;; This function is lifted directly from emacs's subr.el
@@ -290,7 +300,7 @@ STRING should be given if the last search was by `string-match' on STRING."
(eval-and-compile
(cond
((fboundp 'looking-back)
- (defalias 'verilog-looking-back 'looking-back))
+ (defalias 'verilog-looking-back #'looking-back))
(t
(defun verilog-looking-back (regexp limit &optional greedy)
"Return non-nil if text before point matches regular expression REGEXP.
@@ -330,16 +340,16 @@ wherever possible, since it is slow."
(cond
((fboundp 'restore-buffer-modified-p)
;; Faster, as does not update mode line when nothing changes
- (defalias 'verilog-restore-buffer-modified-p 'restore-buffer-modified-p))
+ (defalias 'verilog-restore-buffer-modified-p #'restore-buffer-modified-p))
(t
- (defalias 'verilog-restore-buffer-modified-p 'set-buffer-modified-p))))
+ (defalias 'verilog-restore-buffer-modified-p #'set-buffer-modified-p))))
(eval-and-compile
(cond
((fboundp 'quit-window)
- (defalias 'verilog-quit-window 'quit-window))
+ (defalias 'verilog-quit-window #'quit-window))
(t
- (defun verilog-quit-window (kill-ignored window)
+ (defun verilog-quit-window (_kill-ignored window)
"Quit WINDOW and bury its buffer. KILL-IGNORED is ignored."
(delete-window window)))))
@@ -369,7 +379,7 @@ wherever possible, since it is slow."
;; Added in Emacs 25.1
(condition-case nil
(unless (fboundp 'forward-word-strictly)
- (defalias 'forward-word-strictly 'forward-word))
+ (defalias 'forward-word-strictly #'forward-word))
(error nil)))
(eval-when-compile
@@ -407,7 +417,7 @@ wherever possible, since it is slow."
"Filter `define-abbrev-table' TABLENAME DEFINITIONS
Provides DOCSTRING PROPS in newer Emacs (23.1)."
(condition-case nil
- (apply 'define-abbrev-table tablename definitions docstring props)
+ (apply #'define-abbrev-table tablename definitions docstring props)
(error
(define-abbrev-table tablename definitions))))
@@ -572,7 +582,7 @@ entry \"Fontify Buffer\"). XEmacs: turn off and on font locking."
:type 'boolean
:group 'verilog-mode-indent)
;; Note we don't use :safe, as that would break on Emacsen before 22.0.
-(put 'verilog-highlight-translate-off 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-highlight-translate-off 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-lineup 'declarations
"Type of statements to lineup across multiple lines.
@@ -605,13 +615,13 @@ are lineup only when \\[verilog-pretty-declarations] is typed."
(function :tag "Other"))
:group 'verilog-mode-indent )
(put 'verilog-auto-lineup 'safe-local-variable
- '(lambda (x) (memq x '(nil all assignments declarations))))
+ (lambda (x) (memq x '(nil all assignments declarations))))
(defcustom verilog-indent-level 3
"Indentation of Verilog statements with respect to containing block."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-indent-level 'safe-local-variable 'integerp)
+(put 'verilog-indent-level 'safe-local-variable #'integerp)
(defcustom verilog-indent-level-module 3
"Indentation of Module level Verilog statements (eg always, initial).
@@ -619,14 +629,14 @@ Set to 0 to get initial and always statements lined up on the left side of
your screen."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-indent-level-module 'safe-local-variable 'integerp)
+(put 'verilog-indent-level-module 'safe-local-variable #'integerp)
(defcustom verilog-indent-level-declaration 3
"Indentation of declarations with respect to containing block.
Set to 0 to get them list right under containing block."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-indent-level-declaration 'safe-local-variable 'integerp)
+(put 'verilog-indent-level-declaration 'safe-local-variable #'integerp)
(defcustom verilog-indent-declaration-macros nil
"How to treat macro expansions in a declaration.
@@ -640,7 +650,7 @@ If non-nil, treat as:
output c;"
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-indent-declaration-macros 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-indent-declaration-macros 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-indent-lists t
"How to treat indenting items in a list.
@@ -653,72 +663,72 @@ If nil, treat as:
reset ) begin"
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-indent-lists 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-indent-lists 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-indent-level-behavioral 3
"Absolute indentation of first begin in a task or function block.
Set to 0 to get such code to start at the left side of the screen."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-indent-level-behavioral 'safe-local-variable 'integerp)
+(put 'verilog-indent-level-behavioral 'safe-local-variable #'integerp)
(defcustom verilog-indent-level-directive 1
"Indentation to add to each level of \\=`ifdef declarations.
Set to 0 to have all directives start at the left side of the screen."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-indent-level-directive 'safe-local-variable 'integerp)
+(put 'verilog-indent-level-directive 'safe-local-variable #'integerp)
(defcustom verilog-cexp-indent 2
"Indentation of Verilog statements split across lines."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-cexp-indent 'safe-local-variable 'integerp)
+(put 'verilog-cexp-indent 'safe-local-variable #'integerp)
(defcustom verilog-case-indent 2
"Indentation for case statements."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-case-indent 'safe-local-variable 'integerp)
+(put 'verilog-case-indent 'safe-local-variable #'integerp)
(defcustom verilog-auto-newline t
"Non-nil means automatically newline after semicolons."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-auto-newline 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-newline 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-indent-on-newline t
"Non-nil means automatically indent line after newline."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-auto-indent-on-newline 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-indent-on-newline 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-tab-always-indent t
"Non-nil means TAB should always re-indent the current line.
A nil value means TAB will only reindent when at the beginning of the line."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-tab-always-indent 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-tab-always-indent 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-tab-to-comment nil
"Non-nil means TAB moves to the right hand column in preparation for a comment."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-tab-to-comment 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-tab-to-comment 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-indent-begin-after-if t
"Non-nil means indent begin statements following if, else, while, etc.
Otherwise, line them up."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-indent-begin-after-if 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-indent-begin-after-if 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-align-ifelse nil
"Non-nil means align `else' under matching `if'.
Otherwise else is lined up with first character on line holding matching if."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-align-ifelse 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-align-ifelse 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-minimum-comment-distance 10
"Minimum distance (in lines) between begin and end required before a comment.
@@ -726,7 +736,7 @@ Setting this variable to zero results in every end acquiring a comment; the
default avoids too many redundant comments in tight quarters."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-minimum-comment-distance 'safe-local-variable 'integerp)
+(put 'verilog-minimum-comment-distance 'safe-local-variable #'integerp)
(defcustom verilog-highlight-p1800-keywords nil
"Obsolete.
@@ -734,7 +744,7 @@ Was non-nil means highlight SystemVerilog IEEE-1800 differently.
All code is now highlighted as if SystemVerilog IEEE-1800."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-highlight-p1800-keywords 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-highlight-p1800-keywords 'safe-local-variable #'verilog-booleanp)
(make-obsolete-variable 'verilog-highlight-p1800-keywords nil "27.1")
(defcustom verilog-highlight-grouping-keywords nil
@@ -745,7 +755,7 @@ Some find that special highlighting on these grouping constructs
allow the structure of the code to be understood at a glance."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-highlight-grouping-keywords 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-highlight-grouping-keywords 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-highlight-modules nil
"Non-nil means highlight module statements for `verilog-load-file-at-point'.
@@ -754,7 +764,7 @@ module definition. If false, this is not supported. Setting
this is experimental, and may lead to bad performance."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-highlight-modules 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-highlight-modules 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-highlight-includes t
"Non-nil means highlight module statements for `verilog-load-file-at-point'.
@@ -762,7 +772,17 @@ When true, mousing over include file names will allow jumping to the
file referenced. If false, this is not supported."
:group 'verilog-mode-indent
:type 'boolean)
-(put 'verilog-highlight-includes 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-highlight-includes 'safe-local-variable #'verilog-booleanp)
+
+(defcustom verilog-highlight-max-lookahead 10000
+ "Maximum size of declaration statement that undergoes highlighting.
+Highlighting is performed only on the first `verilog-highlight-max-lookahead'
+characters in a declaration statement.
+Setting this variable to zero would remove this limit. Note that removing
+the limit can greatly slow down highlighting for very large files."
+ :group 'verilog-mode-indent
+ :type 'integer)
+(put 'verilog-highlight-max-lookahead 'safe-local-variable #'integerp)
(defcustom verilog-auto-declare-nettype nil
"Non-nil specifies the data type to use with `verilog-auto-input' etc.
@@ -772,14 +792,14 @@ mode is experimental."
:version "24.1" ; rev670
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-declare-nettype 'safe-local-variable 'stringp)
+(put 'verilog-auto-declare-nettype 'safe-local-variable #'stringp)
(defcustom verilog-auto-wire-comment t
"Non-nil indicates to insert to/from comments with `verilog-auto-wire' etc."
:version "25.1"
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-wire-comment 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-wire-comment 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-wire-type nil
"Non-nil specifies the data type to use with `verilog-auto-wire' etc.
@@ -790,21 +810,21 @@ containing SystemVerilog cells."
:version "24.1" ; rev673
:group 'verilog-mode-actions
:type '(choice (const nil) string))
-(put 'verilog-auto-wire-type 'safe-local-variable 'stringp)
+(put 'verilog-auto-wire-type 'safe-local-variable #'stringp)
(defcustom verilog-auto-endcomments t
"Non-nil means insert a comment /* ... */ after `end's.
The name of the function or case will be set between the braces."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-endcomments 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-endcomments 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-delete-trailing-whitespace nil
"Non-nil means to `delete-trailing-whitespace' in `verilog-auto'."
:version "24.1" ; rev703
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-delete-trailing-whitespace 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-delete-trailing-whitespace 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-ignore-concat nil
"Non-nil means ignore signals in {...} concatenations for AUTOWIRE etc.
@@ -812,7 +832,7 @@ This will exclude signals referenced as pin connections in {...}
or (...) from AUTOWIRE, AUTOOUTPUT and friends."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-ignore-concat 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-ignore-concat 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-read-includes nil
"Non-nil means to automatically read includes before AUTOs.
@@ -822,7 +842,7 @@ but can result in very slow reading times if there are many or large
include files."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-read-includes 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-read-includes 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-save-policy nil
"Non-nil indicates action to take when saving a Verilog buffer with AUTOs.
@@ -843,7 +863,7 @@ They will be expanded in the same way as if there was an AUTOINST in the
instantiation. See also `verilog-auto-star' and `verilog-auto-star-save'."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-star-expand 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-star-expand 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-star-save nil
"Non-nil means save to disk SystemVerilog .* instance expansions.
@@ -854,7 +874,7 @@ Instead of setting this, you may want to use /*AUTOINST*/, which will
always be saved."
:group 'verilog-mode-actions
:type 'boolean)
-(put 'verilog-auto-star-save 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-star-save 'safe-local-variable #'verilog-booleanp)
(defvar verilog-auto-update-tick nil
"Modification tick at which autos were last performed.")
@@ -862,7 +882,7 @@ always be saved."
(defvar verilog-auto-last-file-locals nil
"Text from file-local-variables during last evaluation.")
-(defvar verilog-diff-function 'verilog-diff-report
+(defvar verilog-diff-function #'verilog-diff-report
"Function to run when `verilog-diff-auto' detects differences.
Function takes three arguments, the original buffer, the
difference buffer, and the point in original buffer with the
@@ -917,7 +937,7 @@ See `compilation-error-regexp-alist' for the formatting. For Emacs 22+.")
;; Emacs form is '((v-tool "re" 1 2) ...)
;; XEmacs form is '(verilog ("re" 1 2) ...)
;; So we can just map from Emacs to XEmacs
- (cons 'verilog (mapcar 'cdr verilog-error-regexp-emacs-alist))
+ (cons 'verilog (mapcar #'cdr verilog-error-regexp-emacs-alist))
"List of regexps for Verilog compilers.
See `compilation-error-regexp-alist-alist' for the formatting. For XEmacs.")
@@ -958,8 +978,8 @@ See `compilation-error-regexp-alist-alist' for the formatting. For XEmacs.")
("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 1 bold t)
("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 2 bold t)
;; verilog-verilator
- (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t)
- (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t)
+ (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t)
+ (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t)
;; verilog-leda
("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 1 bold t)
("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 2 bold t)
@@ -997,7 +1017,7 @@ have problems, use \\[find-alternate-file] RET to have these take effect.
See also the variables mentioned above."
:group 'verilog-mode-auto
:type '(repeat string))
-(put 'verilog-library-flags 'safe-local-variable 'listp)
+(put 'verilog-library-flags 'safe-local-variable #'listp)
(defcustom verilog-library-directories '(".")
"List of directories when looking for files for /*AUTOINST*/.
@@ -1020,7 +1040,7 @@ See also `verilog-library-flags', `verilog-library-files'
and `verilog-library-extensions'."
:group 'verilog-mode-auto
:type '(repeat file))
-(put 'verilog-library-directories 'safe-local-variable 'listp)
+(put 'verilog-library-directories 'safe-local-variable #'listp)
(defcustom verilog-library-files '()
"List of files to search for modules.
@@ -1042,14 +1062,14 @@ have problems, use \\[find-alternate-file] RET to have these take effect.
See also `verilog-library-flags', `verilog-library-directories'."
:group 'verilog-mode-auto
:type '(repeat directory))
-(put 'verilog-library-files 'safe-local-variable 'listp)
+(put 'verilog-library-files 'safe-local-variable #'listp)
(defcustom verilog-library-extensions '(".v" ".va" ".sv")
"List of extensions to use when looking for files for /*AUTOINST*/.
See also `verilog-library-flags', `verilog-library-directories'."
:type '(repeat string)
:group 'verilog-mode-auto)
-(put 'verilog-library-extensions 'safe-local-variable 'listp)
+(put 'verilog-library-extensions 'safe-local-variable #'listp)
(defcustom verilog-active-low-regexp nil
"If true, treat signals matching this regexp as active low.
@@ -1057,7 +1077,7 @@ This is used for AUTORESET and AUTOTIEOFF. For proper behavior,
you will probably also need `verilog-auto-reset-widths' set."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-active-low-regexp 'safe-local-variable 'stringp)
+(put 'verilog-active-low-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-sense-include-inputs nil
"Non-nil means AUTOSENSE should include all inputs.
@@ -1065,7 +1085,7 @@ If nil, only inputs that are NOT output signals in the same block are
included."
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-sense-include-inputs 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-sense-include-inputs 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-sense-defines-constant nil
"Non-nil means AUTOSENSE should assume all defines represent constants.
@@ -1074,7 +1094,7 @@ maintain compatibility with other sites, this should be set at the bottom
of each Verilog file that requires it, rather than being set globally."
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-sense-defines-constant 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-sense-defines-constant 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-simplify-expressions t
"Non-nil means AUTOs will simplify expressions when calculating bit ranges.
@@ -1086,7 +1106,7 @@ file that requires it, rather than being set globally."
:version "27.1"
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-simplify-expressions 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-simplify-expressions 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-reset-blocking-in-non t
"Non-nil means AUTORESET will reset blocking statements.
@@ -1101,7 +1121,7 @@ those temporaries reset. See example in `verilog-auto-reset'."
:version "24.1" ; rev718
:type 'boolean
:group 'verilog-mode-auto)
-(put 'verilog-auto-reset-blocking-in-non 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-reset-blocking-in-non 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-reset-widths t
"True means AUTORESET should determine the width of signals.
@@ -1118,13 +1138,13 @@ SystemVerilog designs."
:type 'boolean
:group 'verilog-mode-auto)
(put 'verilog-auto-reset-widths 'safe-local-variable
- '(lambda (x) (memq x '(nil t unbased))))
+ (lambda (x) (memq x '(nil t unbased))))
(defcustom verilog-assignment-delay ""
"Text used for delays in delayed assignments. Add a trailing space if set."
:group 'verilog-mode-auto
:type 'string)
-(put 'verilog-assignment-delay 'safe-local-variable 'stringp)
+(put 'verilog-assignment-delay 'safe-local-variable #'stringp)
(defcustom verilog-auto-arg-format 'packed
"Formatting to use for AUTOARG signal names.
@@ -1138,7 +1158,7 @@ line."
(const :tag "Line up Assignment statements" single))
:group 'verilog-mode-auto)
(put 'verilog-auto-arg-format 'safe-local-variable
- '(lambda (x) (memq x '(packed single))))
+ (lambda (x) (memq x '(packed single))))
(defcustom verilog-auto-arg-sort nil
"Non-nil means AUTOARG signal names will be sorted, not in declaration order.
@@ -1150,7 +1170,7 @@ it's bad practice to rely on order based instantiations anyhow.
See also `verilog-auto-inst-sort'."
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-arg-sort 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-arg-sort 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-dot-name nil
"Non-nil means when creating ports with AUTOINST, use .name syntax.
@@ -1160,7 +1180,7 @@ simulators. Setting `verilog-auto-inst-vector' to nil may also
be desirable to increase how often .name will be used."
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-inst-dot-name 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-inst-dot-name 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-param-value nil
"Non-nil means AUTOINST will replace parameters with the parameter value.
@@ -1227,7 +1247,7 @@ This second expansion of parameter types can be overridden with
`verilog-auto-inst-param-value-type'."
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-inst-param-value 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-inst-param-value 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-param-value-type t
"Non-nil means expand parameter type in instantiations.
@@ -1237,7 +1257,7 @@ See `verilog-auto-inst-param-value'."
:version "25.1"
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-inst-param-value-type 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-inst-param-value-type 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-sort nil
"Non-nil means AUTOINST signals will be sorted, not in declaration order.
@@ -1250,7 +1270,7 @@ See also `verilog-auto-arg-sort'."
:version "24.1" ; rev688
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-inst-sort 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-inst-sort 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-vector t
"True means when creating default ports with AUTOINST, use bus subscripts.
@@ -1263,7 +1283,7 @@ otherwise no vectors if sizes match (like using nil)."
:group 'verilog-mode-auto
:type '(choice (const nil) (const t) (const unsigned)))
(put 'verilog-auto-inst-vector 'safe-local-variable
- '(lambda (x) (memq x '(nil t unsigned))))
+ (lambda (x) (memq x '(nil t unsigned))))
(defcustom verilog-auto-inst-template-numbers nil
"If true, when creating templated ports with AUTOINST, add a comment.
@@ -1280,48 +1300,60 @@ won't merge conflict."
:group 'verilog-mode-auto
:type '(choice (const nil) (const t) (const lhs)))
(put 'verilog-auto-inst-template-numbers 'safe-local-variable
- '(lambda (x) (memq x '(nil t lhs))))
+ (lambda (x) (memq x '(nil t lhs))))
+
+(defcustom verilog-auto-inst-template-required nil
+ "If non-nil, when creating a port with AUTOINST, require a template.
+Any port which does not have a template will be omitted from the
+instantiation.
+
+If nil, if a port is not templated it will be inserted to connect
+to a net with the same name as the port."
+ :version "28.0"
+ :group 'verilog-mode-auto
+ :type 'boolean)
+(put 'verilog-auto-inst-template-required 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-column 40
"Indent-to column number for net name part of AUTOINST created pin."
:group 'verilog-mode-indent
:type 'integer)
-(put 'verilog-auto-inst-column 'safe-local-variable 'integerp)
+(put 'verilog-auto-inst-column 'safe-local-variable #'integerp)
(defcustom verilog-auto-inst-interfaced-ports nil
"Non-nil means include interfaced ports in AUTOINST expansions."
:version "24.3" ; rev773, default change rev815
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-inst-interfaced-ports 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-inst-interfaced-ports 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-input-ignore-regexp nil
"If non-nil, when creating AUTOINPUT, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-input-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-input-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-reg-input-assigned-ignore-regexp nil
"If non-nil, when creating AUTOINPUTREG, ignore signals matching this regexp."
:version "27.1"
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-reg-input-assigned-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-reg-input-assigned-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-inout-ignore-regexp nil
"If non-nil, when creating AUTOINOUT, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-inout-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-inout-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-output-ignore-regexp nil
"If non-nil, when creating AUTOOUTPUT, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-output-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-output-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-template-warn-unused nil
"Non-nil means report warning if an AUTO_TEMPLATE line is not used.
@@ -1329,7 +1361,7 @@ This feature is not supported before Emacs 21.1 or XEmacs 21.4."
:version "24.3" ; rev787
:group 'verilog-mode-auto
:type 'boolean)
-(put 'verilog-auto-template-warn-unused 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-auto-template-warn-unused 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-tieoff-declaration "wire"
"Data type used for the declaration for AUTOTIEOFF.
@@ -1338,21 +1370,21 @@ assignment, else the data type for variable creation."
:version "24.1" ; rev713
:group 'verilog-mode-auto
:type 'string)
-(put 'verilog-auto-tieoff-declaration 'safe-local-variable 'stringp)
+(put 'verilog-auto-tieoff-declaration 'safe-local-variable #'stringp)
(defcustom verilog-auto-tieoff-ignore-regexp nil
"If non-nil, when creating AUTOTIEOFF, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-tieoff-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-tieoff-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-auto-unused-ignore-regexp nil
"If non-nil, when creating AUTOUNUSED, ignore signals matching this regexp.
See the \\[verilog-faq] for examples on using this."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-auto-unused-ignore-regexp 'safe-local-variable 'stringp)
+(put 'verilog-auto-unused-ignore-regexp 'safe-local-variable #'stringp)
(defcustom verilog-case-fold t
"Non-nil means `verilog-mode' regexps should ignore case.
@@ -1360,7 +1392,7 @@ This variable is t for backward compatibility; nil is suggested."
:version "24.4"
:group 'verilog-mode
:type 'boolean)
-(put 'verilog-case-fold 'safe-local-variable 'verilog-booleanp)
+(put 'verilog-case-fold 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-typedef-regexp nil
"If non-nil, regular expression that matches Verilog-2001 typedef names.
@@ -1368,9 +1400,9 @@ For example, \"_t$\" matches typedefs named with _t, as in the C language.
See also `verilog-case-fold'."
:group 'verilog-mode-auto
:type '(choice (const nil) regexp))
-(put 'verilog-typedef-regexp 'safe-local-variable 'stringp)
+(put 'verilog-typedef-regexp 'safe-local-variable #'stringp)
-(defcustom verilog-mode-hook 'verilog-set-compile-command
+(defcustom verilog-mode-hook (list #'verilog-set-compile-command)
"Hook run after Verilog mode is loaded."
:type 'hook
:group 'verilog-mode)
@@ -1418,7 +1450,7 @@ See also `verilog-case-fold'."
:type 'hook)
(defvar verilog-imenu-generic-expression
- '((nil "^\\s-*\\(?:m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1)
+ '((nil "^\\s-*\\(?:connectmodule\\|m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1)
("*Variables*" "^\\s-*\\(reg\\|wire\\|logic\\)\\s-+\\(\\|\\[[^]]+\\]\\s-+\\)\\([A-Za-z0-9_]+\\)" 3)
("*Classes*" "^\\s-*\\(?:\\(?:virtual\\|interface\\)\\s-+\\)?class\\s-+\\([A-Za-z_][A-Za-z0-9_]+\\)" 1)
("*Tasks*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*task\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1)
@@ -1451,48 +1483,48 @@ If set will become buffer local.")
(defvar verilog-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map ";" 'electric-verilog-semi)
- (define-key map [(control 59)] 'electric-verilog-semi-with-comment)
- (define-key map ":" 'electric-verilog-colon)
+ (define-key map ";" #'electric-verilog-semi)
+ (define-key map [(control 59)] #'electric-verilog-semi-with-comment)
+ (define-key map ":" #'electric-verilog-colon)
;;(define-key map "=" 'electric-verilog-equal)
- (define-key map "`" 'electric-verilog-tick)
- (define-key map "\t" 'electric-verilog-tab)
- (define-key map "\r" 'electric-verilog-terminate-line)
+ (define-key map "`" #'electric-verilog-tick)
+ (define-key map "\t" #'electric-verilog-tab)
+ (define-key map "\r" #'electric-verilog-terminate-line)
;; backspace/delete key bindings
- (define-key map [backspace] 'backward-delete-char-untabify)
+ (define-key map [backspace] #'backward-delete-char-untabify)
(unless (boundp 'delete-key-deletes-forward) ; XEmacs variable
- (define-key map [delete] 'delete-char)
- (define-key map [(meta delete)] 'kill-word))
- (define-key map "\M-\C-b" 'electric-verilog-backward-sexp)
- (define-key map "\M-\C-f" 'electric-verilog-forward-sexp)
- (define-key map "\M-\r" 'electric-verilog-terminate-and-indent)
+ (define-key map [delete] #'delete-char)
+ (define-key map [(meta delete)] #'kill-word))
+ (define-key map "\M-\C-b" #'electric-verilog-backward-sexp)
+ (define-key map "\M-\C-f" #'electric-verilog-forward-sexp)
+ (define-key map "\M-\r" #'electric-verilog-terminate-and-indent)
(define-key map "\M-\t" (if (fboundp 'completion-at-point)
- 'completion-at-point 'verilog-complete-word))
+ #'completion-at-point #'verilog-complete-word))
(define-key map "\M-?" (if (fboundp 'completion-help-at-point)
- 'completion-help-at-point 'verilog-show-completions))
+ #'completion-help-at-point #'verilog-show-completions))
;; Note \C-c and letter are reserved for users
- (define-key map "\C-c`" 'verilog-lint-off)
- (define-key map "\C-c*" 'verilog-delete-auto-star-implicit)
- (define-key map "\C-c?" 'verilog-diff-auto)
- (define-key map "\C-c\C-r" 'verilog-label-be)
- (define-key map "\C-c\C-i" 'verilog-pretty-declarations)
- (define-key map "\C-c=" 'verilog-pretty-expr)
- (define-key map "\C-c\C-b" 'verilog-submit-bug-report)
- (define-key map "\C-c/" 'verilog-star-comment)
- (define-key map "\C-c\C-c" 'verilog-comment-region)
- (define-key map "\C-c\C-u" 'verilog-uncomment-region)
+ (define-key map "\C-c`" #'verilog-lint-off)
+ (define-key map "\C-c*" #'verilog-delete-auto-star-implicit)
+ (define-key map "\C-c?" #'verilog-diff-auto)
+ (define-key map "\C-c\C-r" #'verilog-label-be)
+ (define-key map "\C-c\C-i" #'verilog-pretty-declarations)
+ (define-key map "\C-c=" #'verilog-pretty-expr)
+ (define-key map "\C-c\C-b" #'verilog-submit-bug-report)
+ (define-key map "\C-c/" #'verilog-star-comment)
+ (define-key map "\C-c\C-c" #'verilog-comment-region)
+ (define-key map "\C-c\C-u" #'verilog-uncomment-region)
(when (featurep 'xemacs)
- (define-key map [(meta control h)] 'verilog-mark-defun)
- (define-key map "\M-\C-a" 'verilog-beg-of-defun)
- (define-key map "\M-\C-e" 'verilog-end-of-defun))
- (define-key map "\C-c\C-d" 'verilog-goto-defun)
- (define-key map "\C-c\C-k" 'verilog-delete-auto)
- (define-key map "\C-c\C-a" 'verilog-auto)
- (define-key map "\C-c\C-s" 'verilog-auto-save-compile)
- (define-key map "\C-c\C-p" 'verilog-preprocess)
- (define-key map "\C-c\C-z" 'verilog-inject-auto)
- (define-key map "\C-c\C-e" 'verilog-expand-vector)
- (define-key map "\C-c\C-h" 'verilog-header)
+ (define-key map [(meta control h)] #'verilog-mark-defun)
+ (define-key map "\M-\C-a" #'verilog-beg-of-defun)
+ (define-key map "\M-\C-e" #'verilog-end-of-defun))
+ (define-key map "\C-c\C-d" #'verilog-goto-defun)
+ (define-key map "\C-c\C-k" #'verilog-delete-auto)
+ (define-key map "\C-c\C-a" #'verilog-auto)
+ (define-key map "\C-c\C-s" #'verilog-auto-save-compile)
+ (define-key map "\C-c\C-p" #'verilog-preprocess)
+ (define-key map "\C-c\C-z" #'verilog-inject-auto)
+ (define-key map "\C-c\C-e" #'verilog-expand-vector)
+ (define-key map "\C-c\C-h" #'verilog-header)
map)
"Keymap used in Verilog mode.")
@@ -1937,7 +1969,11 @@ To call on \\[verilog-auto], set `verilog-auto-delete-trailing-whitespace'."
(unless (bolp) (insert "\n"))))
(defvar compile-command)
+;; These are known to be from other packages and may not be defined
+(defvar diff-command)
+;; There are known to be from newer versions of Emacs
(defvar create-lockfiles) ; Emacs 24
+(defvar which-func-modes)
;; compilation program
(defun verilog-set-compile-command ()
@@ -1977,9 +2013,10 @@ portion, will be substituted."
(t
(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 "")))
+ (let ((cmd (symbol-value verilog-tool)))
+ (if (string-match "%s" cmd)
+ (format cmd (or buffer-file-name ""))
+ (concat cmd " " (or buffer-file-name ""))))
""))))
(verilog-modify-compile-command))
@@ -2023,17 +2060,25 @@ be substituted."
(set (make-local-variable 'verilog-compile-command-post-mod)
compile-command))))
-(if (featurep 'xemacs)
+(when (featurep 'xemacs)
+ (defvar compilation-error-regexp-systems-alist)
+ (if (not (and (= emacs-major-version 21) (<= emacs-minor-version 4)))
+ ;; XEmacs 21.5 and newer match GNU, see bug1700
+ (defun verilog-error-regexp-add-xemacs ()
+ (interactive)
+ (verilog-error-regexp-add-xemacs))
+ ;; XEmacs 21.4 and older
;; Following code only gets called from compilation-mode-hook on XEmacs to add error handling.
(defun verilog-error-regexp-add-xemacs ()
- "Teach XEmacs about verilog errors.
+ "Teach XEmacs about Verilog errors.
Called by `compilation-mode-hook'. This allows \\[next-error] to
find the errors."
(interactive)
(if (boundp 'compilation-error-regexp-systems-alist)
(if (and
(not (equal compilation-error-regexp-systems-list 'all))
- (not (member compilation-error-regexp-systems-list 'verilog)))
+ ;; eval required due to bug1700, XEmacs otherwise errors on compile
+ (not (eval "(member compilation-error-regexp-systems-list 'verilog)")))
(push 'verilog compilation-error-regexp-systems-list)))
(if (boundp 'compilation-error-regexp-alist-alist)
(if (not (assoc 'verilog compilation-error-regexp-alist-alist))
@@ -2048,7 +2093,7 @@ find the errors."
;; Need to re-run compilation-error-regexp builder
(if (fboundp 'compilation-build-compilation-error-regexp-alist)
(compilation-build-compilation-error-regexp-alist))
- ))
+ )))
;; Following code only gets called from compilation-mode-hook on Emacs to add error handling.
(defun verilog-error-regexp-add-emacs ()
@@ -2058,14 +2103,16 @@ find the errors."
(interactive)
(when (boundp 'compilation-error-regexp-alist-alist)
(when (not (assoc 'verilog-xl-1 compilation-error-regexp-alist-alist))
- (mapcar
+ (mapc
(lambda (item)
(push (car item) compilation-error-regexp-alist)
(push item compilation-error-regexp-alist-alist))
verilog-error-regexp-emacs-alist))))
-(if (featurep 'xemacs) (add-hook 'compilation-mode-hook 'verilog-error-regexp-add-xemacs))
-(if (featurep 'emacs) (add-hook 'compilation-mode-hook 'verilog-error-regexp-add-emacs))
+(add-hook 'compilation-mode-hook
+ (if (featurep 'xemacs)
+ #'verilog-error-regexp-add-xemacs
+ #'verilog-error-regexp-add-emacs))
(defconst verilog-compiler-directives
(eval-when-compile
@@ -2273,7 +2320,8 @@ find the errors."
"`ovm_update_sequence_lib_and_item"
"`ovm_warning"
"`static_dut_error"
- "`static_message") nil )))
+ "`static_message")
+ nil )))
(defconst verilog-uvm-statement-re
(eval-when-compile
@@ -2412,7 +2460,8 @@ find the errors."
"`uvm_update_sequence_lib" ; Deprecated in 1.1
"`uvm_update_sequence_lib_and_item" ; Deprecated in 1.1
"`uvm_warning"
- "`uvm_warning_context") nil )))
+ "`uvm_warning_context")
+ nil )))
;;
@@ -2503,11 +2552,13 @@ find the errors."
(eval-when-compile
(verilog-regexp-words
'( "begin"
+ "connectmodule"
"else"
"end"
"endcase"
"endclass"
"endclocking"
+ "endconnectmodule"
"endgroup"
"endfunction"
"endmodule"
@@ -2550,11 +2601,12 @@ find the errors."
"\\(sequence\\)\\|" ; 14
"\\(clocking\\)\\|" ; 15
"\\(property\\)\\|" ; 16
+ "\\(connectmodule\\)\\|" ; 17
"\\)\\>\\)"))
+
(defconst verilog-end-block-re
(eval-when-compile
(verilog-regexp-words
-
'("end" ; closes begin
"endcase" ; closes any of case, casex casez or randcase
"join" "join_any" "join_none" ; closes fork
@@ -2591,7 +2643,6 @@ find the errors."
"`vmm_xactor_member_end"
))))
-
(defconst verilog-endcomment-reason-re
;; Parenthesis indicate type of keyword found
(concat
@@ -2710,6 +2761,7 @@ find the errors."
"endclass"
"endclocking"
"endconfig"
+ "endconnectmodule"
"endfunction"
"endgenerate"
"endgroup"
@@ -2728,7 +2780,7 @@ find the errors."
(defconst verilog-declaration-opener
(eval-when-compile
(verilog-regexp-words
- '("module" "begin" "task" "function"))))
+ '("connectmodule" "module" "begin" "task" "function"))))
(defconst verilog-declaration-prefix-re
(eval-when-compile
@@ -2759,6 +2811,8 @@ find the errors."
"shortreal" "real" "realtime"
;; net_type
"supply0" "supply1" "tri" "triand" "trior" "trireg" "tri0" "tri1" "uwire" "wire" "wand" "wor"
+ ;; parameters
+ "localparam" "parameter" "var"
;; misc
"string" "event" "chandle" "virtual" "enum" "genvar"
"struct" "union"
@@ -2790,9 +2844,9 @@ find the errors."
(defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro))
(defconst verilog-defun-re
- (eval-when-compile (verilog-regexp-words '("macromodule" "module" "class" "program" "interface" "package" "primitive" "config"))))
+ (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config"))))
(defconst verilog-end-defun-re
- (eval-when-compile (verilog-regexp-words '("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
+ (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
(defconst verilog-zero-indent-re
(concat verilog-defun-re "\\|" verilog-end-defun-re))
(defconst verilog-inst-comment-re
@@ -2824,7 +2878,7 @@ find the errors."
"generate" "endgenerate"
"initial"
"interface" "endinterface"
- "module" "macromodule" "endmodule"
+ "connectmodule" "module" "macromodule" "endconnectmodule" "endmodule"
"package" "endpackage"
"primitive" "endprimitive"
"program" "endprogram"
@@ -2892,14 +2946,14 @@ find the errors."
(defconst verilog-defun-level-not-generate-re
(eval-when-compile
(verilog-regexp-words
- '( "module" "macromodule" "primitive" "class" "program"
+ '( "connectmodule" "module" "macromodule" "primitive" "class" "program"
"interface" "package" "config"))))
(defconst verilog-defun-level-re
(eval-when-compile
(verilog-regexp-words
(append
- '( "module" "macromodule" "primitive" "class" "program"
+ '( "connectmodule" "module" "macromodule" "primitive" "class" "program"
"interface" "package" "config")
'( "initial" "final" "always" "always_comb" "always_ff"
"always_latch" "endtask" "endfunction" )))))
@@ -2914,7 +2968,7 @@ find the errors."
(eval-when-compile
(verilog-regexp-words
'(
- "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass"
+ "endconnectmodule" "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass"
))))
(defconst verilog-dpi-import-export-re
@@ -2935,7 +2989,7 @@ find the errors."
(eval-when-compile
(verilog-regexp-words
'(
- "always" "assign" "always_latch" "always_ff" "always_comb" "constraint"
+ "always" "assign" "always_latch" "always_ff" "always_comb" "connectmodule" "constraint"
"import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while"
"if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert"
))))
@@ -3053,6 +3107,8 @@ find the errors."
"sync_reject_on" "unique0" "until" "until_with" "untyped" "weak"
;; 1800-2012
"implements" "interconnect" "nettype" "soft"
+ ;; AMS
+ "connectmodule" "endconnectmodule"
))
"List of Verilog keywords.")
@@ -3117,7 +3173,7 @@ See also `verilog-font-lock-extra-types'.")
(:foreground "DimGray" :italic t))
(((class grayscale) (background dark))
(:foreground "LightGray" :italic t))
- (t (:italis t)))
+ (t (:italic t)))
"Font lock mode face used to background highlight translate-off regions."
:group 'font-lock-highlighting-faces)
@@ -3199,7 +3255,7 @@ See also `verilog-font-lock-extra-types'.")
"atan2" "atanh" "branch" "ceil" "connect" "connectmodule"
"connectrules" "continuous" "cos" "cosh" "ddt" "ddt_nature"
"ddx" "discipline" "discrete" "domain" "driver_update"
- "endconnectrules" "enddiscipline" "endnature" "endparamset"
+ "endconnectmodule" "endconnectrules" "enddiscipline" "endnature" "endparamset"
"exclude" "exp" "final_step" "flicker_noise" "floor" "flow"
"from" "ground" "hypot" "idt" "idt_nature" "idtmod" "inf"
"initial_step" "laplace_nd" "laplace_np" "laplace_zd"
@@ -3278,9 +3334,9 @@ See also `verilog-font-lock-extra-types'.")
(list
;; Fontify module definitions
(list
- "\\<\\(\\(macro\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)"
+ "\\<\\(\\(macro\\|connect\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)"
'(1 font-lock-keyword-face)
- '(3 font-lock-function-name-face 'prepend))
+ '(3 font-lock-function-name-face prepend))
;; Fontify function definitions
(list
(concat "\\<function\\>\\s-+\\(integer\\|real\\(time\\)?\\|time\\)\\s-+\\(\\sw+\\)" )
@@ -3290,7 +3346,23 @@ See also `verilog-font-lock-extra-types'.")
(1 font-lock-keyword-face)
(2 font-lock-constant-face append))
'("\\<function\\>\\s-+\\(\\sw+\\)"
- 1 'font-lock-constant-face append))))
+ 1 'font-lock-constant-face append)
+ ;; Fontify variable names in declarations
+ (list
+ verilog-declaration-re
+ (list
+ ;; Anchored matcher (lookup Search-Based Fontification)
+ 'verilog-declaration-varname-matcher
+ ;; Pre-form for this anchored matcher:
+ ;; First, avoid declaration keywords written in comments,
+ ;; which can also trigger this anchor.
+ '(if (not (verilog-in-comment-p))
+ (verilog-single-declaration-end verilog-highlight-max-lookahead)
+ (point)) ;; => current declaration statement is of 0 length
+ nil ;; Post-form: nothing to be done
+ '(0 font-lock-variable-name-face t t)))
+ )))
+
(setq verilog-font-lock-keywords-2
(append verilog-font-lock-keywords-1
@@ -3375,7 +3447,7 @@ For insignificant changes, see instead `verilog-save-buffer-state'."
(verilog-run-hooks 'verilog-before-save-font-hook)
(let* ((verilog-save-font-mod-hooked (- (point-max) (point-min)))
;; Significant speed savings with no font-lock properties
- (fontlocked (when (and (boundp 'font-lock-mode) font-lock-mode)
+ (fontlocked (when font-lock-mode
(font-lock-mode 0)
t)))
(run-hook-with-args 'before-change-functions (point-min) (point-max))
@@ -3535,7 +3607,88 @@ inserted using a single call to `verilog-insert'."
;; More searching
(defun verilog-declaration-end ()
- (search-forward ";"))
+ (search-forward ";" nil t))
+
+(defun verilog-single-declaration-end (limit)
+ "Returns pos where current (single) declaration statement ends.
+Also, this function moves POINT forward to the start of a variable name
+(skipping the range-part and whitespace).
+Function expected to be called with POINT just after a declaration keyword.
+LIMIT sets the max POINT for searching and moving to. No such limit if LIMIT
+is 0.
+
+Meaning of *single* declaration:
+ Eg. In a module's port-list -
+ module test(input clk, rst, x, output [1:0] y);
+ Here 'input clk, rst, x' is 1 *single* declaration statement,
+and 'output [1:0] y' is the other single declaration. In the 1st single
+declaration, POINT is moved to start of 'clk'. And in the 2nd declaration,
+POINT is moved to 'y'."
+
+
+ (let (maxpoint old-point)
+ ;; maxpoint = min(curr-point + limit, buffer-size)
+ (setq maxpoint (if (eq limit 0)
+ (point-max) ;; no bounds if search-bound is zero
+ (+ (point) limit)))
+ (if (> maxpoint (buffer-size)) (setq maxpoint (buffer-size)))
+
+ ;; Skip comment - range - comment
+ (verilog-forward-ws&directives maxpoint)
+ (when (eq (char-after) ?\[)
+ (re-search-forward verilog-range-re maxpoint t))
+ (verilog-forward-ws&directives maxpoint)
+
+ ;; Move forward until a delimiter is reached which marks end of current
+ ;; single declaration. Return point at found delimiter
+ (save-excursion
+ (while (and (< (point) maxpoint)
+ (not (eq old-point (point)))
+ (not (eq (char-after) ?\; ))
+ (not (eq (char-after) ?\) ))
+ (not (looking-at verilog-declaration-re)))
+ (setq old-point (point))
+ (ignore-errors
+ (forward-sexp)
+ (verilog-forward-ws&directives maxpoint)
+ (when (eq (char-after) ?,)
+ (forward-char)
+ (verilog-forward-ws&directives maxpoint))))
+ (point))))
+
+(defun verilog-declaration-varname-matcher (limit)
+ "Match first variable name b/w POINT & LIMIT, move POINT to next variable.
+Expected to be called within a declaration statement, with POINT already beyond
+the declaration keyword and range ([a:b])
+This function moves POINT to the next variable within the same declaration (if
+it exists).
+LIMIT is expected to be the pos at which current single-declaration ends,
+obtained using `verilog-single-declaration-end'."
+
+ (let (found-var old-point)
+
+ ;; Remove starting whitespace
+ (verilog-forward-ws&directives limit)
+
+ (when (< (point) limit) ;; no matching if this is violated
+
+ ;; Find the variable name (match-data is set here)
+ (setq found-var (re-search-forward verilog-symbol-re limit t))
+
+ ;; Walk to this variable's delimiter
+ (save-match-data
+ (verilog-forward-ws&directives limit)
+ (setq old-point nil)
+ (while (and (< (point) limit)
+ (not (member (char-after) '(?, ?\) ?\;)))
+ (not (eq old-point (point))))
+ (setq old-point (point))
+ (verilog-forward-ws&directives limit)
+ (forward-sexp)
+ (verilog-forward-ws&directives limit))
+ ;; Only a comma or semicolon expected at this point
+ (skip-syntax-forward "."))
+ found-var)))
(defun verilog-point-text (&optional pointnum)
"Return text describing where POINTNUM or current point is (for errors).
@@ -3596,7 +3749,7 @@ Use filename, if current buffer being edited shorten to just buffer name."
(setq found 't))))))
((looking-at verilog-end-block-re)
(verilog-leap-to-head))
- ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)")
+ ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)\\|\\(\\<endconnectmodule\\>\\)")
(cond
((match-end 1)
(verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move))
@@ -3610,6 +3763,8 @@ Use filename, if current buffer being edited shorten to just buffer name."
(verilog-re-search-backward "\\<interface\\>" nil 'move))
((match-end 6)
(verilog-re-search-backward "\\<package\\>" nil 'move))
+ ((match-end 7)
+ (verilog-re-search-backward "\\<connectmodule\\>" nil 'move))
(t
(goto-char st)
(backward-sexp 1))))
@@ -3735,7 +3890,8 @@ Use filename, if current buffer being edited shorten to just buffer name."
"\\(\\<class\\>\\)\\|"
"\\(\\<program\\>\\)\\|"
"\\(\\<interface\\>\\)\\|"
- "\\(\\<package\\>\\)"))
+ "\\(\\<package\\>\\)\\|"
+ "\\(\\<connectmodule\\>\\)"))
(cond
((match-end 1)
(verilog-re-search-forward "\\<endmodule\\>" nil 'move))
@@ -3749,6 +3905,8 @@ Use filename, if current buffer being edited shorten to just buffer name."
(verilog-re-search-forward "\\<endinterface\\>" nil 'move))
((match-end 6)
(verilog-re-search-forward "\\<endpackage\\>" nil 'move))
+ ((match-end 7)
+ (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move))
(t
(goto-char st)
(if (= (following-char) ?\) )
@@ -3902,13 +4060,13 @@ Key bindings specific to `verilog-mode-map' are:
\\{verilog-mode-map}"
:abbrev-table verilog-mode-abbrev-table
(set (make-local-variable 'beginning-of-defun-function)
- 'verilog-beg-of-defun)
+ #'verilog-beg-of-defun)
(set (make-local-variable 'end-of-defun-function)
- 'verilog-end-of-defun)
+ #'verilog-end-of-defun)
(set-syntax-table verilog-mode-syntax-table)
(set (make-local-variable 'indent-line-function)
#'verilog-indent-line-relative)
- (set (make-local-variable 'comment-indent-function) 'verilog-comment-indent)
+ (set (make-local-variable 'comment-indent-function) #'verilog-comment-indent)
(set (make-local-variable 'parse-sexp-ignore-comments) nil)
(set (make-local-variable 'comment-start) "// ")
(set (make-local-variable 'comment-end) "")
@@ -3919,7 +4077,7 @@ Key bindings specific to `verilog-mode-map' are:
(setq verilog-tool 'verilog-linter)
(verilog-set-compile-command)
(when (boundp 'hack-local-variables-hook) ; Also modify any file-local-variables
- (add-hook 'hack-local-variables-hook 'verilog-modify-compile-command t))
+ (add-hook 'hack-local-variables-hook #'verilog-modify-compile-command t))
;; Setting up menus
(when (featurep 'xemacs)
@@ -3941,6 +4099,10 @@ Key bindings specific to `verilog-mode-map' are:
;; verilog-beg-of-defun.
nil
'verilog-beg-of-defun)))
+
+ ;; Stuff for multiline font-lock
+ (set (make-local-variable 'font-lock-multiline) t)
+
;;------------------------------------------------------------
;; now hook in 'verilog-highlight-include-files (eldo-mode.el&spice-mode.el)
;; all buffer local:
@@ -3949,9 +4111,9 @@ Key bindings specific to `verilog-mode-map' are:
(make-local-hook 'font-lock-mode-hook)
(make-local-hook 'font-lock-after-fontify-buffer-hook); doesn't exist in Emacs
(make-local-hook 'after-change-functions))
- (add-hook 'font-lock-mode-hook 'verilog-highlight-buffer t t)
- (add-hook 'font-lock-after-fontify-buffer-hook 'verilog-highlight-buffer t t) ; not in Emacs
- (add-hook 'after-change-functions 'verilog-highlight-region t t))
+ (add-hook 'font-lock-mode-hook #'verilog-highlight-buffer t t)
+ (add-hook 'font-lock-after-fontify-buffer-hook #'verilog-highlight-buffer t t) ; not in Emacs
+ (add-hook 'after-change-functions #'verilog-highlight-region t t))
;; Tell imenu how to handle Verilog.
(set (make-local-variable 'imenu-generic-expression)
@@ -3973,7 +4135,7 @@ Key bindings specific to `verilog-mode-map' are:
;; Stuff for autos
(add-hook (if (boundp 'write-contents-hooks) 'write-contents-hooks
'write-contents-functions) ; Emacs >= 22.1
- 'verilog-auto-save-check nil 'local)
+ #'verilog-auto-save-check nil 'local)
;; verilog-mode-hook call added by define-derived-mode
)
@@ -4556,13 +4718,13 @@ More specifically, point @ in the line foo : @ begin"
(let ((nest 1))
(while t
(verilog-re-search-backward
- (concat "\\(\\<module\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|"
+ (concat "\\(\\<module\\>\\)\\|\\(\\<connectmodule\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|"
"\\(\\<endcase\\>\\)\\>")
nil 'move)
(cond
- ((match-end 3)
+ ((match-end 4)
(setq nest (1+ nest)))
- ((match-end 2)
+ ((match-end 3)
(if (= nest 1)
(throw 'found 1))
(setq nest (1- nest)))
@@ -4571,9 +4733,11 @@ More specifically, point @ in the line foo : @ begin"
nil)))
(defun verilog-backward-up-list (arg)
- "Call `backward-up-list' ARG, ignoring comments."
+ "Call `backward-up-list' ARG, ignoring comments and errors."
(let ((parse-sexp-ignore-comments t))
- (backward-up-list arg)))
+ (condition-case nil
+ (backward-up-list arg) ;; May throw Unbalanced parenthesis
+ (error nil))))
(defun verilog-forward-sexp-cmt (arg)
"Call `forward-sexp' ARG, inside comments."
@@ -4595,13 +4759,15 @@ More specifically, after a generate and before an endgenerate."
(while (and
(/= nest 0)
(verilog-re-search-backward
- "\\<\\(module\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move)
+ "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move)
(cond
((match-end 1) ; module - we have crawled out
(throw 'done 1))
- ((match-end 2) ; generate
+ ((match-end 2) ; connectmodule - we have crawled out
+ (throw 'done 1))
+ ((match-end 3) ; generate
(setq nest (1- nest)))
- ((match-end 3) ; endgenerate
+ ((match-end 4) ; endgenerate
(setq nest (1+ nest))))))))
(= nest 0) )) ; return nest
@@ -5064,6 +5230,8 @@ primitive or interface named NAME."
(setq reg "\\(\\<clocking\\>\\)\\|\\<endclocking\\>"))
((match-end 16) ; of verilog-end-block-ordered-re
(setq reg "\\(\\<property\\>\\)\\|\\<endproperty\\>"))
+ ((match-end 17) ; of verilog-end-block-ordered-re
+ (setq reg "\\(\\<connectmodule\\>\\)\\|\\<endconnectmodule\\>"))
(t (error "Problem in verilog-set-auto-endcomments")))
(let (b e)
@@ -5089,7 +5257,7 @@ primitive or interface named NAME."
(setq string (buffer-substring b e)))
(t
(ding 't)
- (setq string "unmatched end(function|task|module|primitive|interface|package|class|clocking)")))))
+ (setq string "unmatched end(function|task|module|connectmodule|primitive|interface|package|class|clocking)")))))
(end-of-line)
(insert (concat " // " string )))
))))))))))
@@ -5155,7 +5323,7 @@ Useful for creating tri's and other expanded fields."
(verilog-expand-vector-internal "[" "]"))
(defun verilog-expand-vector-internal (bra ket)
- "Given BRA, the start brace and KET, the end brace, expand one line into many lines."
+ "Given start brace BRA, and end brace KET, expand one line into many lines."
(save-excursion
(forward-line 0)
(let ((signal-string (buffer-substring (point)
@@ -5292,8 +5460,7 @@ becomes:
(let* ((code (match-string 2))
(file (match-string 3))
(line (match-string 4))
- (buffer (get-file-buffer file))
- dir filename)
+ (buffer (get-file-buffer file)))
(unless buffer
(progn
(setq buffer
@@ -5305,9 +5472,8 @@ becomes:
(read-file-name
(format "Find this error in: (default %s) "
file)
- dir file t))))
- (if (file-directory-p name)
- (setq name (expand-file-name filename name)))
+ nil ;; dir
+ file t))))
(setq buffer
(and (file-exists-p name)
(find-file-noselect name))))))))
@@ -5345,7 +5511,7 @@ becomes:
(interactive)
(save-excursion
(beginning-of-line)
- (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\):?.*$")
+ (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\).*$")
(replace-match (format
;; %3s makes numbers 1-999 line up nicely
"\\1//Verilint %3s off // WARNING: \\3"
@@ -5372,7 +5538,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'."
default nil nil
'verilog-preprocess-history default)))))
(unless command (setq command (verilog-expand-command verilog-preprocessor)))
- (let* ((fontlocked (and (boundp 'font-lock-mode) font-lock-mode))
+ (let* ((fontlocked font-lock-mode)
(dir (file-name-directory (or filename buffer-file-name)))
(cmd (concat "cd " dir "; " command)))
(with-output-to-temp-buffer "*Verilog-Preprocessed*"
@@ -5386,22 +5552,23 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'."
;; We should use font-lock-ensure in preference to
;; font-lock-fontify-buffer, but IIUC the problem this is supposed to
;; solve only appears in Emacsen older than font-lock-ensure anyway.
- ;; So avoid bytecomp's interactive-only by going through intern.
- (when fontlocked (funcall (intern "font-lock-fontify-buffer"))))))))
+ (when fontlocked
+ (verilog--suppressed-warnings
+ ((interactive-only font-lock-fontify-buffer))
+ (font-lock-fontify-buffer))))))))
;;; Batch:
;;
(defun verilog-warn (string &rest args)
"Print a warning with `format' using STRING and optional ARGS."
- (apply 'message (concat "%%Warning: " string) args))
+ (apply #'message (concat "%%Warning: " string) args))
(defun verilog-warn-error (string &rest args)
"Call `error' using STRING and optional ARGS.
If `verilog-warn-fatal' is non-nil, call `verilog-warn' instead."
- (if verilog-warn-fatal
- (apply 'error string args)
- (apply 'verilog-warn string args)))
+ (apply (if verilog-warn-fatal #'error #'verilog-warn)
+ string args))
(defmacro verilog-batch-error-wrapper (&rest body)
"Execute BODY and add error prefix to any errors found.
@@ -5449,12 +5616,11 @@ Save the result unless optional NO-SAVE is t."
;; Process the files
(mapc (lambda (buf)
(when (buffer-file-name buf)
- (save-excursion
- (if (not (file-exists-p (buffer-file-name buf)))
- (error
- "File not found: %s" (buffer-file-name buf)))
- (message "Processing %s" (buffer-file-name buf))
- (set-buffer buf)
+ (if (not (file-exists-p (buffer-file-name buf)))
+ (error
+ "File not found: %s" (buffer-file-name buf)))
+ (message "Processing %s" (buffer-file-name buf))
+ (with-current-buffer buf
(funcall funref)
(verilog-star-cleanup)
(when (and (not no-save)
@@ -5560,7 +5726,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)."
(case-fold-search nil)
(par 0)
(begin (looking-at "[ \t]*begin\\>"))
- (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)" nil t)))
+ (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)" nil t)))
(structres nil)
(type (catch 'nesting
;; Keep working backwards until we can figure out
@@ -6414,6 +6580,7 @@ Return >0 for nested struct."
(let ((p (point)))
(and
(equal (char-after) ?\{)
+ (not (verilog-at-streaming-op-p))
(ignore-errors (forward-list))
(progn (backward-char 1)
(verilog-backward-ws&directives)
@@ -6451,6 +6618,18 @@ Return >0 for nested struct."
;; not
nil))
+(defconst verilog-streaming-op-re
+ ;; Regexp to detect Streaming Operator expressions
+ (concat
+ "{" "\\s-*"
+ "\\(<<\\|>>\\)" ".*"
+ "{" ".*" "}" "\\s-*" "}"
+ ))
+
+(defun verilog-at-streaming-op-p ()
+ "If at the { of a streaming operator, return t."
+ (looking-at verilog-streaming-op-re))
+
(defun verilog-at-struct-p ()
"If at the { of a struct, return true, not moving point."
(save-excursion
@@ -6471,14 +6650,9 @@ Return >0 for nested struct."
(defun verilog-at-close-struct-p ()
"If at the } that closes a struct, return true."
- (if (and
- (equal (char-after) ?\})
- (verilog-in-struct-p))
- ;; true
- (save-excursion
- (if (looking-at "}\\(?:\\s-*\\w+\\s-*\\)?;") 1))
- ;; false
- nil))
+ (and (equal (char-after) ?\})
+ (verilog-in-struct-p)
+ (looking-at "}\\(?:\\s-*\\w+\\s-*\\(?:,\\s-*\\w+\\s-*\\)*\\)?;")))
(defun verilog-parenthesis-depth ()
"Return non zero if in parenthetical-expression."
@@ -6683,16 +6857,19 @@ Only look at a few lines to determine indent level."
(indent-line-to val)))
(t
(goto-char here)
- (let ((val))
- (verilog-beg-of-statement-1)
- (if (and (< (point) here)
- (verilog-re-search-forward "=[ \t]*" here 'move)
- ;; not at a |=>, #=#, or [=n] operator
- (not (string-match "\\[=.\\|#=#\\||=>"
- (or (buffer-substring (- (point) 2) (1+ (point)))
- "")))) ; don't let buffer over/under-run spoil the party
- (setq val (current-column))
- (setq val (eval (cdr (assoc type verilog-indent-alist)))))
+ (verilog-beg-of-statement-1)
+ (let ((val
+ (if (and (< (point) here)
+ (verilog-re-search-forward "=[ \t]*" here 'move)
+ ;; not at a |=>, #=#, or [=n] operator
+ (not (string-match "\\[=.\\|#=#\\||=>"
+ (or (buffer-substring
+ (- (point) 2) (1+ (point)))
+ ;; Don't let buffer over/under
+ ;; run spoil the party.
+ ""))))
+ (current-column)
+ (eval (cdr (assoc type verilog-indent-alist))))))
(goto-char here)
(indent-line-to val))))))
@@ -6788,7 +6965,7 @@ Do not count named blocks or case-statements."
((looking-at verilog-named-block-re)
(current-column))
((and (not (looking-at verilog-extended-case-re))
- (looking-at "^[^:;]+[ \t]*:"))
+ (looking-at "^[^:;]+:"))
(verilog-re-search-forward ":" nil t)
(skip-chars-forward " \t")
(current-column))
@@ -7113,7 +7290,7 @@ BASEIND is the base indent to offset everything."
(let ((pos (point-marker))
(lim (save-excursion
;; (verilog-re-search-backward verilog-declaration-opener nil 'move)
- (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)\\|\\(\\<task\\>\\)" nil 'move)
+ (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)\\|\\(\\<task\\>\\)" nil 'move)
(point)))
(ind)
(val)
@@ -7128,7 +7305,8 @@ BASEIND is the base indent to offset everything."
(if (verilog-re-search-backward
(or (and verilog-indent-declaration-macros
verilog-declaration-re-1-macro)
- verilog-declaration-re-1-no-macro) lim t)
+ verilog-declaration-re-1-no-macro)
+ lim t)
(progn
(goto-char (match-end 0))
(skip-chars-forward " \t")
@@ -7246,9 +7424,7 @@ BEG and END."
;;
(defvar verilog-str nil)
(defvar verilog-all nil)
-(defvar verilog-pred nil)
(defvar verilog-buffer-to-use nil)
-(defvar verilog-flag nil)
(defvar verilog-toggle-completions nil
"True means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one.
Repeated use of \\[verilog-complete-word] will show you all of them.
@@ -7272,7 +7448,7 @@ it displays a list of all possible completions.")
\(integer, real, reg...)")
(defvar verilog-cpp-keywords
- '("module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else"
+ '("connectmodule" "module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else"
"endif")
"Keywords to complete when at first word of a line in declarative scope.
\(initial, always, begin, assign...)
@@ -7283,7 +7459,7 @@ will be completed at runtime and should not be added to this list.")
(append
'(
"always" "always_comb" "always_ff" "always_latch" "assign"
- "begin" "end" "generate" "endgenerate" "module" "endmodule"
+ "begin" "end" "connectmodule" "endconnectmodule" "generate" "endgenerate" "module" "endmodule"
"specify" "endspecify" "function" "endfunction" "initial" "final"
"task" "endtask" "primitive" "endprimitive"
)
@@ -7379,27 +7555,25 @@ will be completed at runtime and should not be added to this list.")
TYPE is `module', `tf' for task or function, or t if unknown."
(if (string= verilog-str "")
(setq verilog-str "[a-zA-Z_]"))
- (let ((verilog-str (concat (cond
- ((eq type 'module) "\\<\\(module\\)\\s +")
- ((eq type 'tf) "\\<\\(task\\|function\\)\\s +")
- (t "\\<\\(task\\|function\\|module\\)\\s +"))
- "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>"))
+ (let ((verilog-str
+ (concat (cond
+ ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +")
+ ((eq type 'tf) "\\<\\(task\\|function\\)\\s +")
+ (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +"))
+ "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>"))
match)
- (if (not (looking-at verilog-defun-re))
- (verilog-re-search-backward verilog-defun-re nil t))
- (forward-char 1)
+ (save-excursion
+ (if (not (looking-at verilog-defun-re))
+ (verilog-re-search-backward verilog-defun-re nil t))
+ (forward-char 1)
- ;; Search through all reachable functions
- (goto-char (point-min))
- (while (verilog-re-search-forward verilog-str (point-max) t)
- (progn (setq match (buffer-substring (match-beginning 2)
- (match-end 2)))
- (if (or (null verilog-pred)
- (funcall verilog-pred match))
- (setq verilog-all (cons match verilog-all)))))
- (if (match-beginning 0)
- (goto-char (match-beginning 0)))))
+ ;; Search through all reachable functions
+ (goto-char (point-min))
+ (while (verilog-re-search-forward verilog-str (point-max) t)
+ (setq match (buffer-substring (match-beginning 2)
+ (match-end 2)))
+ (setq verilog-all (cons match verilog-all))))))
(defun verilog-get-completion-decl (end)
"Macro for searching through current declaration (var, type or const)
@@ -7417,9 +7591,7 @@ for matches of `str' and adding the occurrence tp `all' through point END."
(not (match-end 1)))
(setq match (buffer-substring (match-beginning 0) (match-end 0)))
(if (string-match (concat "\\<" verilog-str) match)
- (if (or (null verilog-pred)
- (funcall verilog-pred match))
- (setq verilog-all (cons match verilog-all)))))
+ (setq verilog-all (cons match verilog-all))))
(forward-line 1)))
verilog-all)
@@ -7434,28 +7606,25 @@ for matches of `str' and adding the occurrence tp `all' through point END."
(defun verilog-keyword-completion (keyword-list)
"Give list of all possible completions of keywords in KEYWORD-LIST."
- (mapcar (lambda (s)
- (if (string-match (concat "\\<" verilog-str) s)
- (if (or (null verilog-pred)
- (funcall verilog-pred s))
- (setq verilog-all (cons s verilog-all)))))
- keyword-list))
-
-
-(defun verilog-completion (verilog-str verilog-pred verilog-flag)
- "Function passed to `completing-read', `try-completion' or `all-completions'.
-Called to get completion on VERILOG-STR. If VERILOG-PRED is non-nil, it
-must be a function to be called for every match to check if this should
-really be a match. If VERILOG-FLAG is t, the function returns a list of
-all possible completions. If VERILOG-FLAG is nil it returns a string,
-the longest possible completion, or t if VERILOG-STR is an exact match.
-If VERILOG-FLAG is `lambda', the function returns t if VERILOG-STR is an
-exact match, nil otherwise."
- (save-excursion
- (let ((verilog-all nil))
- ;; Set buffer to use for searching labels. This should be set
- ;; within functions which use verilog-completions
- (set-buffer verilog-buffer-to-use)
+ (dolist (s keyword-list)
+ (if (string-match (concat "\\<" verilog-str) s)
+ (push s verilog-all))))
+
+
+(defun verilog-completion (str pred flag)
+ "Completion table for Verilog tokens.
+Function passed to `completing-read', `try-completion' or `all-completions'.
+Called to get completion on STR.
+If FLAG is t, the function returns a list of all possible completions.
+If FLAG is nil it returns a string, the longest possible completion,
+or t if STR is an exact match.
+If FLAG is `lambda', the function returns t if STR is an exact match,
+nil otherwise."
+ (let ((verilog-str str)
+ (verilog-all nil))
+ ;; Set buffer to use for searching labels. This should be set
+ ;; within functions which use verilog-completions
+ (with-current-buffer verilog-buffer-to-use
;; Determine what should be completed
(let ((state (car (verilog-calculate-indent))))
@@ -7497,43 +7666,47 @@ exact match, nil otherwise."
(verilog-keyword-completion verilog-separator-keywords))))
;; Now we have built a list of all matches. Give response to caller
- (verilog-completion-response))))
-
-(defun verilog-completion-response ()
- (cond ((or (equal verilog-flag 'lambda) (null verilog-flag))
- ;; This was not called by all-completions
- (if (null verilog-all)
- ;; Return nil if there was no matching label
- nil
- ;; Get longest string common in the labels
- ;; FIXME: Why not use `try-completion'?
- (let* ((elm (cdr verilog-all))
- (match (car verilog-all))
- (min (length match))
- tmp)
- (if (string= match verilog-str)
- ;; Return t if first match was an exact match
- (setq match t)
- (while (not (null elm))
- ;; Find longest common string
- (if (< (setq tmp (verilog-string-diff match (car elm))) min)
- (progn
- (setq min tmp)
- (setq match (substring match 0 min))))
- ;; Terminate with match=t if this is an exact match
- (if (string= (car elm) verilog-str)
- (progn
- (setq match t)
- (setq elm nil))
- (setq elm (cdr elm)))))
- ;; If this is a test just for exact match, return nil ot t
- (if (and (equal verilog-flag 'lambda) (not (equal match 't)))
- nil
- match))))
- ;; If flag is t, this was called by all-completions. Return
- ;; list of all possible completions
- (verilog-flag
- verilog-all)))
+ (verilog--complete-with-action flag verilog-all verilog-str pred))))
+
+
+(defalias 'verilog--complete-with-action
+ (if (fboundp 'complete-with-action)
+ #'complete-with-action
+ (lambda (flag collection string _predicate)
+ (cond ((or (equal flag 'lambda) (null flag))
+ ;; This was not called by all-completions
+ (if (null collection)
+ ;; Return nil if there was no matching label
+ nil
+ ;; Get longest string common in the labels
+ (let* ((elm (cdr collection))
+ (match (car collection))
+ (min (length match))
+ tmp)
+ (if (string= match string)
+ ;; Return t if first match was an exact match
+ (setq match t)
+ (while (not (null elm))
+ ;; Find longest common string
+ (if (< (setq tmp (verilog-string-diff match (car elm)))
+ min)
+ (progn
+ (setq min tmp)
+ (setq match (substring match 0 min))))
+ ;; Terminate with match=t if this is an exact match
+ (if (string= (car elm) string)
+ (progn
+ (setq match t)
+ (setq elm nil))
+ (setq elm (cdr elm)))))
+ ;; If this is a test just for exact match, return nil ot t
+ (if (and (equal flag 'lambda) (not (equal match 't)))
+ nil
+ match))))
+ ;; If flag is t, this was called by all-completions. Return
+ ;; list of all possible completions
+ (flag
+ collection)))))
(defvar verilog-last-word-numb 0)
(defvar verilog-last-word-shown nil)
@@ -7551,7 +7724,7 @@ exact match, nil otherwise."
(allcomp (if (and verilog-toggle-completions
(string= verilog-last-word-shown verilog-str))
verilog-last-completions
- (all-completions verilog-str 'verilog-completion))))
+ (all-completions verilog-str #'verilog-completion))))
(list b e allcomp)))
(defun verilog-complete-word ()
@@ -7567,9 +7740,7 @@ and `verilog-separator-keywords'.)"
(verilog-str (buffer-substring b e))
(allcomp (nth 2 comp-info))
(match (if verilog-toggle-completions
- "" (try-completion
- verilog-str (mapcar (lambda (elm)
- (cons elm 0)) allcomp)))))
+ "" (try-completion verilog-str allcomp))))
;; Delete old string
(delete-region b e)
@@ -7641,39 +7812,38 @@ With optional second ARG non-nil, STR is the complete name of the instruction."
(setq str (concat str "[a-zA-Z0-9_]*")))
(concat "^\\s-*\\(function\\|task\\|module\\)[ \t]+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(" str "\\)\\>"))
-(defun verilog-comp-defun (verilog-str verilog-pred verilog-flag)
- "Function passed to `completing-read', `try-completion' or `all-completions'.
-Returns a completion on any function name based on VERILOG-STR prefix. If
-VERILOG-PRED is non-nil, it must be a function to be called for every match
-to check if this should really be a match. If VERILOG-FLAG is t, the
-function returns a list of all possible completions. If it is nil it
-returns a string, the longest possible completion, or t if VERILOG-STR is
-an exact match. If VERILOG-FLAG is `lambda', the function returns t if
-VERILOG-STR is an exact match, nil otherwise."
- (save-excursion
- (let ((verilog-all nil)
- match)
-
- ;; Set buffer to use for searching labels. This should be set
- ;; within functions which use verilog-completions
- (set-buffer verilog-buffer-to-use)
+(defun verilog-comp-defun (str pred flag)
+ "Completion table for function names.
+Function passed to `completing-read', `try-completion' or `all-completions'.
+Returns a completion on any function name based on STR prefix.
+If FLAG is t, the function returns a list of all possible completions.
+If it is nil it returns a string, the longest possible completion,
+or t if STR is an exact match.
+If FLAG is `lambda', the function returns t if STR is an exact match,
+nil otherwise."
+ (let ((verilog-all nil)
+ (verilog-str str)
+ match)
+
+ ;; Set buffer to use for searching labels. This should be set
+ ;; within functions which use verilog-completions
+ (with-current-buffer verilog-buffer-to-use
(let ((verilog-str verilog-str))
;; Build regular expression for functions
- (if (string= verilog-str "")
- (setq verilog-str (verilog-build-defun-re "[a-zA-Z_]"))
- (setq verilog-str (verilog-build-defun-re verilog-str)))
+ (setq verilog-str
+ (verilog-build-defun-re (if (string= verilog-str "")
+ "[a-zA-Z_]"
+ verilog-str)))
(goto-char (point-min))
;; Build a list of all possible completions
(while (verilog-re-search-forward verilog-str nil t)
(setq match (buffer-substring (match-beginning 2) (match-end 2)))
- (if (or (null verilog-pred)
- (funcall verilog-pred match))
- (setq verilog-all (cons match verilog-all)))))
+ (setq verilog-all (cons match verilog-all))))
;; Now we have built a list of all matches. Give response to caller
- (verilog-completion-response))))
+ (verilog--complete-with-action flag verilog-all verilog-str pred))))
(defun verilog-goto-defun ()
"Move to specified Verilog module/interface/task/function.
@@ -7688,10 +7858,10 @@ If search fails, other files are checked based on
;; Do completion with default
(completing-read (concat "Goto-Label: (default "
default ") ")
- 'verilog-comp-defun nil nil "")
+ #'verilog-comp-defun nil nil "")
;; There is no default value. Complete without it
(completing-read "Goto-Label: "
- 'verilog-comp-defun nil nil "")))
+ #'verilog-comp-defun nil nil "")))
pt)
;; Make sure library paths are correct, in case need to resolve module
(verilog-auto-reeval-locals)
@@ -7724,7 +7894,7 @@ If search fails, other files are checked based on
(first 1)
(prevpos (point-min))
(final-context-start (make-marker))
- (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)"))
+ (regexp "\\(\\(connect\\)?module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)"))
(with-output-to-temp-buffer "*Occur*"
(save-excursion
(message "Searching for %s ..." regexp)
@@ -7750,10 +7920,9 @@ If search fails, other files are checked based on
(tag (format "%3d" linenum))
(empty (make-string (length tag) ?\ ))
tem)
- (save-excursion
- (setq tem (make-marker))
- (set-marker tem (point))
- (set-buffer standard-output)
+ (setq tem (make-marker))
+ (set-marker tem (point))
+ (with-current-buffer standard-output
(setq occur-pos-list (cons tem occur-pos-list))
(or first (zerop nlines)
(insert "--------\n"))
@@ -7782,7 +7951,7 @@ If search fails, other files are checked based on
"Return point if within translate-off region, else nil."
(and (save-excursion
(re-search-backward
- (concat "//\\s-*.*\\s-*" verilog-directive-regexp "\\(on\\|off\\)\\>")
+ (concat "//.*" verilog-directive-regexp "\\(on\\|off\\)\\>")
nil t))
(equal "off" (match-string 2))
(point)))
@@ -7790,14 +7959,14 @@ If search fails, other files are checked based on
(defun verilog-start-translate-off (limit)
"Return point before translate-off directive if before LIMIT, else nil."
(when (re-search-forward
- (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>")
+ (concat "//.*" verilog-directive-regexp "off\\>")
limit t)
(match-beginning 0)))
(defun verilog-back-to-start-translate-off (limit)
"Return point before translate-off directive if before LIMIT, else nil."
(when (re-search-backward
- (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>")
+ (concat "//.*" verilog-directive-regexp "off\\>")
limit t)
(match-beginning 0)))
@@ -7805,7 +7974,7 @@ If search fails, other files are checked based on
"Return point after translate-on directive if before LIMIT, else nil."
(re-search-forward (concat
- "//\\s-*.*\\s-*" verilog-directive-regexp "on\\>") limit t))
+ "//.*" verilog-directive-regexp "on\\>") limit t))
(defun verilog-match-translate-off (limit)
"Match a translate-off block, setting `match-data' and returning t, else nil.
@@ -7923,6 +8092,8 @@ See also `verilog-sk-header' for an alternative format."
;; Unfortunately we use 'assoc' on this, so can't be a vector
(defsubst verilog-sig-new (name bits comment mem enum signed type multidim modport)
(list name bits comment mem enum signed type multidim modport))
+(defsubst verilog-sig-new-renamed (name old-sig)
+ (cons name (cdr old-sig)))
(defsubst verilog-sig-name (sig)
(car sig))
(defsubst verilog-sig-bits (sig) ; First element of packed array (pre signal-name)
@@ -8277,7 +8448,7 @@ Tieoff value uses `verilog-active-low-regexp' and
(t
(let* ((width (verilog-sig-width sig)))
(cond ((not width)
- "`0/*NOWIDTH*/")
+ "'0/*NOWIDTH*/")
((string-match "^[0-9]+$" width)
(concat width (if (verilog-sig-signed sig) "'sh0" "'h0")))
(t
@@ -8445,7 +8616,8 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters."
(let ((olist))
(save-excursion
;; /*AUTOPUNT("parameter", "parameter")*/
- (backward-sexp 1)
+ (when (not (eq (char-before) ?\*)) ; Not .*
+ (backward-sexp 1))
(while (looking-at "(?\\s *\"\\([^\"]*\\)\"\\s *,?")
(setq olist (cons (match-string-no-properties 1) olist))
(goto-char (match-end 0))))
@@ -8458,9 +8630,20 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters."
(error "%s: Expected <= %d parameters" (verilog-point-text) max-param))
(nreverse olist)))
+;; Prevent compile warnings; these are let's, not globals.
+(defvar sigs-in)
+(defvar sigs-inout)
+(defvar sigs-intf)
+(defvar sigs-intfd)
+(defvar sigs-out)
+(defvar sigs-out-d)
+(defvar sigs-out-i)
+(defvar sigs-out-unk)
+(defvar sigs-temp)
+
(defun verilog-read-decls ()
"Compute signal declaration information for the current module at point.
-Return an array of [outputs inouts inputs wire reg assign const]."
+Return an array of [outputs inouts inputs wire reg assign const gparam intf]."
(let ((end-mod-point (or (verilog-get-end-of-defun) (point-max)))
(functask 0) (paren 0) (sig-paren 0) (v2kargs-ok t)
in-modport in-clocking in-ign-to-semi ptype ign-prop
@@ -8738,25 +8921,6 @@ Return an array of [outputs inouts inputs wire reg assign const]."
(defvar verilog-read-sub-decls-gate-ios nil
"For `verilog-read-sub-decls', gate IO pins remaining, nil if non-primitive.")
-(eval-when-compile
- ;; Prevent compile warnings; these are let's, not globals
- ;; Do not remove the eval-when-compile
- ;; - we want an error when we are debugging this code if they are refed.
- (defvar sigs-in)
- (defvar sigs-inout)
- (defvar sigs-intf)
- (defvar sigs-intfd)
- (defvar sigs-out)
- (defvar sigs-out-d)
- (defvar sigs-out-i)
- (defvar sigs-out-unk)
- (defvar sigs-temp)
- ;; These are known to be from other packages and may not be defined
- (defvar diff-command)
- ;; There are known to be from newer versions of Emacs
- (defvar create-lockfiles)
- (defvar which-func-modes))
-
(defun verilog-read-sub-decls-type (par-values portdata)
"For `verilog-read-sub-decls-line', decode a signal type."
(let* ((type (verilog-sig-type portdata))
@@ -8855,7 +9019,8 @@ Return an array of [outputs inouts inputs wire reg assign const]."
"For `verilog-read-sub-decls-line', parse a subexpression and add signals."
;;(message "vrsde: `%s'" expr)
;; Replace special /*[....]*/ comments inserted by verilog-auto-inst-port
- (setq expr (verilog-string-replace-matches "/\\*\\(\\.?\\[[^*]+\\]\\)\\*/" "\\1" nil nil expr))
+ (setq expr (verilog-string-replace-matches
+ "/\\*\\(\\.?\\[\\([^*]+\\|[*][^/]\\)+\\]\\)\\*/" "\\1" nil nil expr))
;; Remove front operators
(setq expr (verilog-string-replace-matches "^\\s-*[---+~!|&]+\\s-*" "" nil nil expr))
;;
@@ -9770,10 +9935,10 @@ Use DEFAULT-DIR to anchor paths if non-nil."
"Convert `verilog-library-flags' into standard library variables."
;; If the flags are local, then all the outputs should be local also
(when (local-variable-p 'verilog-library-flags (current-buffer))
- (mapc 'make-local-variable '(verilog-library-extensions
- verilog-library-directories
- verilog-library-files
- verilog-library-flags)))
+ (mapc #'make-local-variable '(verilog-library-extensions
+ verilog-library-directories
+ verilog-library-files
+ verilog-library-flags)))
;; Allow user to customize
(verilog-run-hooks 'verilog-before-getopt-flags-hook)
;; Process arguments
@@ -9895,7 +10060,7 @@ Allows version control to check out the file if need be."
(while (and
;; It may be tempting to look for verilog-defun-re,
;; don't, it slows things down a lot!
- (verilog-re-search-forward-quick "\\<\\(module\\|interface\\|program\\)\\>" nil t)
+ (verilog-re-search-forward-quick "\\<\\(connectmodule\\|module\\|interface\\|program\\)\\>" nil t)
(setq type (match-string-no-properties 0))
(verilog-re-search-forward-quick "[(;]" nil t))
(if (equal module (verilog-read-module-name))
@@ -9921,7 +10086,7 @@ If undefined, and WING-IT, return just SYMBOL without the tick, else nil."
;; variable in only one buffer returns t in another.
;; This can confuse, so check for nil.
;; Namespace intentionally short for AUTOs and compatibility
- (let ((val (eval (intern (concat "vh-" symbol)))))
+ (let ((val (symbol-value (intern (concat "vh-" symbol)))))
(if (eq val nil)
(if wing-it symbol nil)
val))
@@ -9960,7 +10125,7 @@ This function is intended for use in AUTO_TEMPLATE Lisp expressions."
;; variable in only one buffer returns t in another.
;; This can confuse, so check for nil.
;; Namespace intentionally short for AUTOs and compatibility
- (setq val (eval (intern (concat "vh-" symbol)))))
+ (setq val (symbol-value (intern (concat "vh-" symbol)))))
(setq text (replace-match val nil nil text)))
(t (setq ok nil)))))
text)
@@ -9978,11 +10143,11 @@ Or, just the existing dirnames themselves if there are no wildcards."
(setq dirnames (reverse dirnames)) ; not nreverse
(let ((dirlist nil)
pattern dirfile dirfiles dirname root filename rest basefile)
- (setq dirnames (mapcar 'substitute-in-file-name dirnames))
+ (setq dirnames (mapcar #'substitute-in-file-name dirnames))
(while dirnames
(setq dirname (car dirnames)
dirnames (cdr dirnames))
- (cond ((string-match (concat "^\\(\\|[/\\]*[^*?]*[/\\]\\)" ; root
+ (cond ((string-match (concat "^\\(\\|[^*?]*[/\\]\\)" ; root
"\\([^/\\]*[*?][^/\\]*\\)" ; filename with *?
"\\(.*\\)") ; rest
dirname)
@@ -10073,7 +10238,8 @@ variables to build the path."
;; A modi is: [module-name-string file-name begin-point]
(defvar verilog-cache-enabled t
- "Non-nil enables caching of signals, etc. Set to nil for debugging to make things SLOW!")
+ "Non-nil enables caching of signals, etc.
+Set to nil for debugging to make things SLOW!")
(defvar verilog-modi-cache-list nil
"Cache of ((Module Function) Buf-Tick Buf-Modtime Func-Returns)...
@@ -10170,7 +10336,7 @@ Return modi if successful, else print message unless IGNORE-ERROR is true."
(if (not (equal module realname))
(concat " (Expanded macro to " realname ")")
"")
- (mapconcat 'concat orig-filenames "\n\t")))
+ (mapconcat #'concat orig-filenames "\n\t")))
(when (eval-when-compile (fboundp 'make-hash-table))
(unless verilog-modi-lookup-cache
(setq verilog-modi-lookup-cache
@@ -10308,42 +10474,47 @@ those clocking block's signals."
(defun verilog-signals-matching-enum (in-list enum)
"Return all signals in IN-LIST matching the given ENUM."
(let (out-list)
- (while in-list
- (if (equal (verilog-sig-enum (car in-list)) enum)
- (setq out-list (cons (car in-list) out-list)))
- (setq in-list (cdr in-list)))
+ (dolist (sig in-list)
+ (if (equal (verilog-sig-enum sig) enum)
+ (push sig out-list)))
;; New scheme
;; Namespace intentionally short for AUTOs and compatibility
- (let* ((enumvar (intern (concat "venum-" enum)))
- (enumlist (and (boundp enumvar) (eval enumvar))))
- (while enumlist
- (add-to-list 'out-list (list (car enumlist)))
- (setq enumlist (cdr enumlist))))
+ (let* ((enumvar (intern (concat "venum-" enum))))
+ (dolist (en (and (boundp enumvar) (symbol-value enumvar)))
+ (let ((sig (list en)))
+ (unless (member sig out-list)
+ (push sig out-list)))))
(nreverse out-list)))
(defun verilog-signals-matching-regexp (in-list regexp)
- "Return all signals in IN-LIST matching the given REGEXP, if non-nil."
+ "Return all signals in IN-LIST matching the given REGEXP, if non-nil.
+Allow regexp inversion if REGEXP begins with ?!."
(if (or (not regexp) (equal regexp ""))
in-list
- (let ((case-fold-search verilog-case-fold)
- out-list)
- (while in-list
- (if (string-match regexp (verilog-sig-name (car in-list)))
- (setq out-list (cons (car in-list) out-list)))
- (setq in-list (cdr in-list)))
- (nreverse out-list))))
+ (if (string-match "^\\?!" regexp)
+ (verilog-signals-not-matching-regexp in-list (substring regexp 2))
+ (let ((case-fold-search verilog-case-fold)
+ out-list)
+ (while in-list
+ (if (string-match regexp (verilog-sig-name (car in-list)))
+ (setq out-list (cons (car in-list) out-list)))
+ (setq in-list (cdr in-list)))
+ (nreverse out-list)))))
(defun verilog-signals-not-matching-regexp (in-list regexp)
- "Return all signals in IN-LIST not matching the given REGEXP, if non-nil."
+ "Return all signals in IN-LIST not matching the given REGEXP, if non-nil.
+Allow regexp inversion if REGEXP begins with ?!."
(if (or (not regexp) (equal regexp ""))
in-list
- (let ((case-fold-search verilog-case-fold)
- out-list)
- (while in-list
- (if (not (string-match regexp (verilog-sig-name (car in-list))))
- (setq out-list (cons (car in-list) out-list)))
- (setq in-list (cdr in-list)))
- (nreverse out-list))))
+ (if (string-match "^\\?!" regexp)
+ (verilog-signals-matching-regexp in-list (substring regexp 2))
+ (let ((case-fold-search verilog-case-fold)
+ out-list)
+ (while in-list
+ (if (not (string-match regexp (verilog-sig-name (car in-list))))
+ (setq out-list (cons (car in-list) out-list)))
+ (setq in-list (cdr in-list)))
+ (nreverse out-list)))))
(defun verilog-signals-matching-dir-re (in-list decl-type regexp)
"Return all signals in IN-LIST matching the given DECL-TYPE and REGEXP,
@@ -10356,7 +10527,7 @@ if non-nil."
(setq to-match (concat
decl-type
" " (verilog-sig-signed (car in-list))
- " " (verilog-sig-multidim (car in-list))
+ " " (verilog-sig-multidim-string (car in-list))
(verilog-sig-bits (car in-list))))
(if (string-match regexp to-match)
(setq out-list (cons (car in-list) out-list)))
@@ -10370,6 +10541,20 @@ if non-nil."
(verilog-sig-type-set sig nil))
sig) in-list))
+(defun verilog-signals-add-prefix (in-list prefix)
+ "Return all signals in IN-LIST with PREFIX added."
+ (if (or (not prefix) (equal prefix ""))
+ in-list
+ (let (out-list)
+ (while in-list
+ (setq out-list (cons (verilog-sig-new-renamed
+ (concat prefix (verilog-sig-name (car in-list)))
+ (car in-list))
+ out-list))
+ (setq in-list (cdr in-list)))
+ (nreverse out-list))))
+;(verilog-signals-add-prefix (list (list "foo" "...") (list "bar" "...")) "p_")
+
;; Combined
(defun verilog-decls-get-signals (decls)
"Return all declared signals in DECLS, excluding `assign' statements."
@@ -10410,7 +10595,7 @@ if non-nil."
;;
(defun verilog-auto-re-search-do (search-for func)
- "Search for the given auto text regexp SEARCH-FOR, and perform FUNC where it occurs."
+ "Given start brace BRA, and end brace KET, expand one line into many lines."
(goto-char (point-min))
(while (verilog-re-search-forward-quick search-for nil t)
(funcall func)))
@@ -10500,11 +10685,7 @@ When MODI is non-null, also add to modi-cache, for tracking."
(verilog-insert "// " (verilog-sig-comment sig) "\n"))
(setq sigs (cdr sigs)))))
-(eval-when-compile
- (if (not (boundp 'indent-pt))
- (defvar indent-pt nil "Local used by `verilog-insert-indent'.")))
-
-(defun verilog-insert-indent (&rest stuff)
+(defun verilog--insert-indent (indent-pt &rest stuff)
"Indent to position stored in local `indent-pt' variable, then insert STUFF.
Presumes that any newlines end a list element."
(let ((need-indent t))
@@ -10514,6 +10695,10 @@ Presumes that any newlines end a list element."
(verilog-insert (car stuff))
(setq need-indent (string-match "\n$" (car stuff))
stuff (cdr stuff)))))
+
+(defmacro verilog-insert-indent (&rest stuff)
+ `(verilog--insert-indent indent-pt ,@stuff))
+
;;(let ((indent-pt 10)) (verilog-insert-indent "hello\n" "addon" "there\n"))
(defun verilog-forward-or-insert-line ()
@@ -10609,11 +10794,15 @@ This repairs those mis-inserted by an AUTOARG."
(match-string 3 out))
nil nil out)))
;; For precedence do *,/ before +,-,>>,<<
- (while (string-match
- (concat "\\([[({:*/<>+-]\\)"
- "\\([0-9]+\\)\\s *\\([*/]\\)\\s *\\([0-9]+\\)"
- "\\([])}:*/<>+-]\\)")
- out)
+ (while (and
+ (string-match
+ (concat "\\([[({:*/<>+-]\\)"
+ "\\([0-9]+\\)\\s *\\([*/]\\)\\s *\\([0-9]+\\)"
+ "\\([])}:*/<>+-]\\)")
+ out)
+ (not (and (equal (match-string 3 out) "/")
+ (not (equal 0 (% (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out))))))))
(setq out (replace-match
(concat (match-string 1 out)
(if (equal (match-string 3 out) "/")
@@ -10685,6 +10874,7 @@ This repairs those mis-inserted by an AUTOARG."
;;(verilog-simplify-range-expression "[(TEST[1])-1:0]")
;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2]
;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]")
+;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]")
(defun verilog-clog2 (value)
"Compute $clog2 - ceiling log2 of VALUE."
@@ -10822,7 +11012,8 @@ removed."
(defun verilog-delete-auto-buffer ()
"Perform `verilog-delete-auto' on the current buffer.
-Intended for internal use inside a `verilog-save-font-no-change-functions' block."
+Intended for internal use inside a
+`verilog-save-font-no-change-functions' block."
;; Allow user to customize
(verilog-run-hooks 'verilog-before-delete-auto-hook)
@@ -10923,9 +11114,9 @@ shown) will make this into:
;; Presume one module per file.
(save-excursion
(goto-char (point-min))
- (while (verilog-re-search-forward-quick "\\<module\\>" nil t)
+ (while (verilog-re-search-forward-quick "\\<\\(connect\\)?module\\>" nil t)
(let ((endmodp (save-excursion
- (verilog-re-search-forward-quick "\\<endmodule\\>" nil t)
+ (verilog-re-search-forward-quick "\\<end\\(connect\\)?module\\>" nil t)
(point))))
;; See if there's already a comment .. inside a comment so not verilog-re-search
(when (not (re-search-forward "/\\*AUTOARG\\*/" endmodp t))
@@ -11295,6 +11486,8 @@ making verification modules that connect to UVM interfaces.
The optional fourth parameter is a regular expression, and only
signals matching the regular expression will be included.
+ The optional fifth parameter is a prefix to add to the signals.
+
Limitations:
Interface names must be resolvable to filenames. See `verilog-auto-inst'.
@@ -11308,12 +11501,14 @@ Limitations:
See the example in `verilog-auto-inout-modport'."
(save-excursion
- (let* ((params (verilog-read-auto-params 3 4))
+ (let* ((params (verilog-read-auto-params 3 5))
(submod (nth 0 params))
(modport-re (nth 1 params))
(inst-name (nth 2 params))
(regexp (nth 3 params))
- direction-re submodi) ; direction argument not supported until requested
+ (prefix (nth 4 params))
+ ;; direction-re ; direction argument not supported until requested
+ submodi)
;; Lookup position, etc of co-module
;; Note this may raise an error
(when (setq submodi (verilog-modi-lookup submod t))
@@ -11334,11 +11529,11 @@ See the example in `verilog-auto-inout-modport'."
(setq sig-list-i (verilog-signals-edit-wire-reg
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-i regexp)
- "input" direction-re))
+ "input" nil)) ;; direction-re
sig-list-o (verilog-signals-edit-wire-reg
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-o regexp)
- "output" direction-re)))
+ "output" nil))) ;; direction-re
(setq sig-list-i (sort (copy-alist sig-list-i) #'verilog-signals-sort-compare))
(setq sig-list-o (sort (copy-alist sig-list-o) #'verilog-signals-sort-compare))
(when (or sig-list-i sig-list-o)
@@ -11346,15 +11541,18 @@ See the example in `verilog-auto-inout-modport'."
;; Don't sort them so an upper AUTOINST will match the main module
(let ((sigs sig-list-o))
(while sigs
- (verilog-insert-indent "assign " (verilog-sig-name (car sigs))
- " = " inst-name
- "." (verilog-sig-name (car sigs)) ";\n")
+ (verilog-insert-indent "assign "
+ (concat prefix (verilog-sig-name (car sigs)))
+ " = " inst-name
+ "." (verilog-sig-name (car sigs)) ";\n")
(setq sigs (cdr sigs))))
(let ((sigs sig-list-i))
(while sigs
- (verilog-insert-indent "assign " inst-name
- "." (verilog-sig-name (car sigs))
- " = " (verilog-sig-name (car sigs)) ";\n")
+ (verilog-insert-indent "assign " inst-name
+ "." (verilog-sig-name (car sigs))
+ " = "
+ (concat prefix (verilog-sig-name (car sigs)))
+ ";\n")
(setq sigs (cdr sigs))))
(verilog-insert-indent "// End of automatics\n")))))))
@@ -11363,6 +11561,7 @@ See the example in `verilog-auto-inout-modport'."
(defvar vl-cell-type nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-cell-name nil "See `verilog-auto-inst'.") ; Prevent compile warning
+(defvar vl-memory nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-modport nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-name nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-width nil "See `verilog-auto-inst'.") ; Prevent compile warning
@@ -11370,9 +11569,10 @@ See the example in `verilog-auto-inout-modport'."
(defvar vl-bits nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-mbits nil "See `verilog-auto-inst'.") ; Prevent compile warning
-(defun verilog-auto-inst-port (port-st indent-pt moddecls tpl-list tpl-num for-star par-values)
+(defun verilog-auto-inst-port (section port-st indent-pt moddecls tpl-list tpl-num
+ for-star par-values)
"Print out an instantiation connection for this PORT-ST.
-Insert to INDENT-PT, use template TPL-LIST.
+Inside SECTION, insert to INDENT-PT, use template TPL-LIST.
@ are instantiation numbers, replaced with TPL-NUM.
@\"(expression @)\" are evaluated, with @ as a variable.
If FOR-STAR add comment it is a .* expansion.
@@ -11474,60 +11674,74 @@ If PAR-VALUES replace final strings with these parameter values."
(setq tpl-net (verilog-string-replace-matches "\\[\\]\\[\\]" dflt-bits nil nil tpl-net))
(setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net)))
;; Insert it
- (indent-to indent-pt)
- (insert "." port)
- (unless (and verilog-auto-inst-dot-name
- (equal port tpl-net))
- (indent-to verilog-auto-inst-column)
- (insert "(" tpl-net ")"))
- (insert ",")
- (cond (tpl-ass
- (verilog-read-auto-template-hit tpl-ass)
- (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16)
- verilog-auto-inst-column))
- ;; verilog-insert requires the complete comment in one call - including the newline
- (cond ((equal verilog-auto-inst-template-numbers 'lhs)
- (verilog-insert " // Templated"
- " LHS: " (nth 0 tpl-ass)
- "\n"))
- (verilog-auto-inst-template-numbers
- (verilog-insert " // Templated"
- " T" (int-to-string (nth 2 tpl-ass))
- " L" (int-to-string (nth 3 tpl-ass))
- "\n"))
- (t
- (verilog-insert " // Templated\n"))))
- (for-star
- (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16)
- verilog-auto-inst-column))
- (verilog-insert " // Implicit .*\n"))
- (t
- (insert "\n")))))
-;;(verilog-auto-inst-port (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3")
+ (when (or tpl-ass (not verilog-auto-inst-template-required))
+ (verilog--auto-inst-first indent-pt section)
+ (indent-to indent-pt)
+ (insert "." port)
+ (unless (and verilog-auto-inst-dot-name
+ (equal port tpl-net))
+ (indent-to verilog-auto-inst-column)
+ (insert "(" tpl-net ")"))
+ (insert ",")
+ (cond (tpl-ass
+ (verilog-read-auto-template-hit tpl-ass)
+ (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16)
+ verilog-auto-inst-column))
+ ;; verilog-insert requires the complete comment in one call - including the newline
+ (cond ((equal verilog-auto-inst-template-numbers 'lhs)
+ (verilog-insert " // Templated"
+ " LHS: " (nth 0 tpl-ass)
+ "\n"))
+ (verilog-auto-inst-template-numbers
+ (verilog-insert " // Templated"
+ " T" (int-to-string (nth 2 tpl-ass))
+ " L" (int-to-string (nth 3 tpl-ass))
+ "\n"))
+ (t
+ (verilog-insert " // Templated\n"))))
+ (for-star
+ (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16)
+ verilog-auto-inst-column))
+ (verilog-insert " // Implicit .*\n"))
+ (t
+ (insert "\n"))))))
+;;(verilog-auto-inst-port "" (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3")
;;(x "incom[@\"(+ (* 8 @) 7)\":@\"(* 8 @)\"]")
;;(x ".out (outgo[@\"(concat (+ (* 8 @) 7) \\\":\\\" ( * 8 @))\"]));")
-(defun verilog-auto-inst-port-list (sig-list indent-pt moddecls tpl-list tpl-num for-star par-values)
- "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'."
- (when verilog-auto-inst-sort
- (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare)))
- (mapc (lambda (port)
- (verilog-auto-inst-port port indent-pt moddecls
- tpl-list tpl-num for-star par-values))
- sig-list))
+(defvar verilog-auto-inst-first-section nil
+ "Local first-in-section for `verilog-auto-inst-first'.")
+(defvar verilog-auto-inst-first-any nil
+ "Local first-in-any-section for `verilog-auto-inst-first'.")
-(defun verilog-auto-inst-first ()
- "Insert , etc before first ever port in this instant, as part of \\[verilog-auto-inst]."
+(defun verilog--auto-inst-first (indent-pt section)
+ "Insert , and SECTION before port, as part of \\[verilog-auto-inst]."
;; Do we need a trailing comma?
;; There maybe an ifdef or something similar before us. What a mess. Thus
;; to avoid trouble we only insert on preceding ) or *.
;; Insert first port on new line
- (insert "\n") ; Must insert before search, so point will move forward if insert comma
- (save-excursion
- (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil)
- (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure
- (forward-char 1)
- (insert ","))))
+ (when verilog-auto-inst-first-any
+ (setq verilog-auto-inst-first-any nil)
+ (insert "\n") ; Must insert before search, so point will move forward if insert comma
+ (save-excursion
+ (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil)
+ (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure
+ (forward-char 1)
+ (insert ","))))
+ (when verilog-auto-inst-first-section
+ (setq verilog-auto-inst-first-section nil)
+ (verilog-insert-indent section)))
+
+(defun verilog-auto-inst-port-list (section sig-list indent-pt moddecls
+ tpl-list tpl-num for-star par-values)
+ "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'."
+ (when verilog-auto-inst-sort
+ (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare)))
+ (let ((verilog-auto-inst-first-section t))
+ (mapc (lambda (port)
+ (verilog-auto-inst-port section port indent-pt moddecls
+ tpl-list tpl-num for-star par-values))
+ sig-list)))
(defun verilog-auto-star ()
"Expand SystemVerilog .* pins, as part of \\[verilog-auto].
@@ -11554,6 +11768,11 @@ Replace the pin connections to an instantiation or interface
declaration with ones automatically derived from the module or
interface header of the instantiated item.
+You may also provide an optional regular expression, in which
+case only I/O matching the regular expression will be included,
+or excluded if the regexp begins with ?! (question-mark
+exclamation-mark).
+
If `verilog-auto-star-expand' is set, also expand SystemVerilog .* ports,
and delete them before saving unless `verilog-auto-star-save' is set.
See `verilog-auto-star' for more information.
@@ -11697,6 +11916,10 @@ Templates:
debugging is completed though, it will result in lots of extra differences
and merge conflicts.
+ If a connection name does not match any template, it is
+ connected to a net by the same name as the port (unless
+ `verilog-auto-inst-template-required' is true).
+
Setting `verilog-auto-template-warn-unused' will report errors
if any template lines are unused.
@@ -11841,6 +12064,7 @@ Lisp Templates:
vl-width Width of the input/output port (`3' for [2:0]).
May be a (...) expression if bits isn't a constant.
vl-dir Direction of the pin input/output/inout/interface.
+ vl-memory The unpacked array part of the I/O port (`[5:0]').
vl-modport The modport, if an interface with a modport.
vl-cell-type Module name/type of the cell (`InstModule').
vl-cell-name Instance name of the cell (`instName').
@@ -11868,16 +12092,19 @@ For more information see the \\[verilog-faq] and forums at URL
`https://www.veripool.org'."
(save-excursion
;; Find beginning
- (let* ((pt (point))
+ (let* ((params (verilog-read-auto-params 0 1))
+ (regexp (nth 0 params))
+ (pt (point))
(for-star (save-excursion (backward-char 2) (looking-at "\\.\\*")))
(indent-pt (save-excursion (verilog-backward-open-paren)
(1+ (current-column))))
(verilog-auto-inst-column (max verilog-auto-inst-column
(+ 16 (* 8 (/ (+ indent-pt 7) 8)))))
+ (verilog-auto-inst-first-any t)
(modi (verilog-modi-current))
(moddecls (verilog-modi-get-decls modi))
submod submodi submoddecls
- inst skip-pins tpl-list tpl-num did-first par-values)
+ inst skip-pins tpl-list tpl-num par-values)
;; Find module name that is instantiated
(setq submod (verilog-read-inst-module)
@@ -11912,53 +12139,58 @@ For more information see the \\[verilog-faq] and forums at URL
(verilog-decls-get-vars submoddecls)
skip-pins)))
(vl-dir "interfaced"))
+ (when regexp
+ (setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when (and sig-list
verilog-auto-inst-interfaced-ports)
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
;; Note these are searched for in verilog-read-sub-decls.
- (verilog-insert-indent "// Interfaced\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
+ (verilog-auto-inst-port-list "// Interfaced\n"
+ sig-list indent-pt moddecls
tpl-list tpl-num for-star par-values)))
(let ((sig-list (verilog-signals-not-in
(verilog-decls-get-interfaces submoddecls)
skip-pins))
(vl-dir "interface"))
+ (when regexp
+ (setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when sig-list
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
;; Note these are searched for in verilog-read-sub-decls.
- (verilog-insert-indent "// Interfaces\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
- tpl-list tpl-num for-star par-values)))
+ (verilog-auto-inst-port-list "// Interfaces\n"
+ sig-list indent-pt moddecls
+ tpl-list tpl-num for-star par-values)))
(let ((sig-list (verilog-signals-not-in
(verilog-decls-get-outputs submoddecls)
skip-pins))
(vl-dir "output"))
+ (when regexp
+ (setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when sig-list
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
- (verilog-insert-indent "// Outputs\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
+ (verilog-auto-inst-port-list "// Outputs\n"
+ sig-list indent-pt moddecls
tpl-list tpl-num for-star par-values)))
(let ((sig-list (verilog-signals-not-in
(verilog-decls-get-inouts submoddecls)
skip-pins))
(vl-dir "inout"))
+ (when regexp
+ (setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when sig-list
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
- (verilog-insert-indent "// Inouts\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
+ (verilog-auto-inst-port-list "// Inouts\n"
+ sig-list indent-pt moddecls
tpl-list tpl-num for-star par-values)))
(let ((sig-list (verilog-signals-not-in
(verilog-decls-get-inputs submoddecls)
skip-pins))
(vl-dir "input"))
+ (when regexp
+ (setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when sig-list
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
- (verilog-insert-indent "// Inputs\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
+ (verilog-auto-inst-port-list "// Inputs\n"
+ sig-list indent-pt moddecls
tpl-list tpl-num for-star par-values)))
;; Kill extra semi
(save-excursion
- (cond (did-first
+ (cond ((not verilog-auto-inst-first-any)
(re-search-backward "," pt t)
(delete-char 1)
(insert ");")
@@ -11976,7 +12208,8 @@ automatically derived from the module header of the instantiated netlist.
You may also provide an optional regular expression, in which
case only parameters matching the regular expression will be
-included.
+included, or excluded if the regexp begins with ?! (question-mark
+exclamation-mark).
See \\[verilog-auto-inst] for limitations, and templates to customize the
output.
@@ -12020,10 +12253,11 @@ Templates:
(1+ (current-column))))
(verilog-auto-inst-column (max verilog-auto-inst-column
(+ 16 (* 8 (/ (+ indent-pt 7) 8)))))
+ (verilog-auto-inst-first-any t)
(modi (verilog-modi-current))
(moddecls (verilog-modi-get-decls modi))
submod submodi submoddecls
- inst skip-pins tpl-list tpl-num did-first)
+ inst skip-pins tpl-list tpl-num)
;; Find module name that is instantiated
(setq submod (save-excursion
;; Get to the point where AUTOINST normally is to read the module
@@ -12060,14 +12294,13 @@ Templates:
(when regexp
(setq sig-list (verilog-signals-matching-regexp sig-list regexp)))
(when sig-list
- (when (not did-first) (verilog-auto-inst-first) (setq did-first t))
;; Note these are searched for in verilog-read-sub-decls.
- (verilog-insert-indent "// Parameters\n")
- (verilog-auto-inst-port-list sig-list indent-pt moddecls
+ (verilog-auto-inst-port-list "// Parameters\n"
+ sig-list indent-pt moddecls
tpl-list tpl-num nil nil)))
;; Kill extra semi
(save-excursion
- (cond (did-first
+ (cond ((not verilog-auto-inst-first-any)
(re-search-backward "," pt t)
(delete-char 1)
(insert ")")
@@ -12395,9 +12628,11 @@ Typing \\[verilog-auto] will make this into:
wire o = tempb;
endmodule
-You may also provide an optional regular expression, in which case only
-signals matching the regular expression will be included. For example the
-same expansion will result from only extracting outputs starting with ov:
+You may also provide an optional regular expression, in which
+case only signals matching the regular expression will be
+included,or excluded if the regexp begins with ?! (question-mark
+exclamation-mark). For example the same expansion will result
+from only extracting outputs starting with ov:
/*AUTOOUTPUTEVERY(\"^ov\")*/"
(save-excursion
@@ -12473,9 +12708,12 @@ Typing \\[verilog-auto] will make this into:
.i (i));
endmodule
-You may also provide an optional regular expression, in which case only
-signals matching the regular expression will be included. For example the
-same expansion will result from only extracting inputs starting with i:
+You may also provide an optional regular expression, in which
+case only signals matching the regular expression will be
+included. or excluded if the regexp begins with
+?! (question-mark exclamation-mark). For example the same
+expansion will result from only extracting inputs starting with
+i:
/*AUTOINPUT(\"^i\")*/"
(save-excursion
@@ -12557,9 +12795,11 @@ Typing \\[verilog-auto] will make this into:
.io (io));
endmodule
-You may also provide an optional regular expression, in which case only
-signals matching the regular expression will be included. For example the
-same expansion will result from only extracting inouts starting with i:
+You may also provide an optional regular expression, in which
+case only signals matching the regular expression will be
+included, or excluded if the regexp begins with ?! (question-mark
+exclamation-mark). For example the same expansion will result
+from only extracting inouts starting with i:
/*AUTOINOUT(\"^i\")*/"
(save-excursion
@@ -12640,9 +12880,11 @@ Typing \\[verilog-auto] will make this into:
// End of automatics
endmodule
-You may also provide an optional regular expression, in which case only
-signals matching the regular expression will be included. For example the
-same expansion will result from only extracting signals starting with i:
+You may also provide an optional regular expression, in which
+case only signals matching the regular expression will be
+included, or excluded if the regexp begins with ?! (question-mark
+exclamation-mark). For example the same expansion will result
+from only extracting signals starting with i:
/*AUTOINOUTMODULE(\"ExampMain\",\"^i\")*/
@@ -12707,21 +12949,25 @@ that expression are included."
(verilog-signals-not-matching-regexp
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-i regexp)
- "input" direction-re) not-re))
+ "input" direction-re)
+ not-re))
sig-list-o (verilog-signals-edit-wire-reg
(verilog-signals-not-matching-regexp
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-o regexp)
- "output" direction-re) not-re))
+ "output" direction-re)
+ not-re))
sig-list-io (verilog-signals-edit-wire-reg
(verilog-signals-not-matching-regexp
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-io regexp)
- "inout" direction-re) not-re))
+ "inout" direction-re)
+ not-re))
sig-list-if (verilog-signals-not-matching-regexp
(verilog-signals-matching-dir-re
(verilog-signals-matching-regexp sig-list-if regexp)
- "interface" direction-re) not-re))
+ "interface" direction-re)
+ not-re))
(when v2k (verilog-repair-open-comma))
(when (or sig-list-i sig-list-o sig-list-io sig-list-if)
(verilog-insert-indent "// Beginning of automatic in/out/inouts (from specific module)\n")
@@ -12848,9 +13094,11 @@ Typing \\[verilog-auto] will make this into:
// End of automatics
endmodule
-You may also provide an optional regular expression, in which case only
-signals matching the regular expression will be included. For example the
-same expansion will result from only extracting signals starting with i:
+You may also provide an optional regular expression, in which
+case only signals matching the regular expression will be
+included, or excluded if the regexp begins with ?! (question-mark
+exclamation-mark). For example the same expansion will result
+from only extracting signals starting with i:
/*AUTOINOUTIN(\"ExampMain\",\"^i\")*/"
(verilog-auto-inout-module nil t))
@@ -12938,6 +13186,8 @@ for making verification modules that connect to UVM interfaces.
The optional third parameter is a regular expression, and only
signals matching the regular expression will be included.
+ The optional fourth parameter is a prefix to add to the signals.
+
Limitations:
If placed inside the parenthesis of a module declaration, it creates
Verilog 2001 style, else uses Verilog 1995 style.
@@ -12961,10 +13211,16 @@ An example:
modport mp(clocking mon_clkblk);
endinterface
+
module ExampMain
( input clk,
/*AUTOINOUTMODPORT(\"ExampIf\", \"mp\")*/
);
+
+ ExampleIf i;
+
+ /*AUTOASSIGNMODPORT(\"ExampIf\", \"mp\", \"i\")*/
+
endmodule
Typing \\[verilog-auto] will make this into:
@@ -12977,17 +13233,28 @@ Typing \\[verilog-auto] will make this into:
input [7:0] req_dat
// End of automatics
);
+
+ ExampleIf i;
+
+ /*AUTOASSIGNMODPORT(\"ExampIf\", \"mp\", \"i\")*/
+ // Beginning of automatic assignments from modport
+ assign i.req_dat = req_dat;
+ assign i.req_val = req_val;
+ // End of automatics
+
endmodule
If the modport is part of a UVM monitor/driver class, this
creates a wrapper module that may be used to instantiate the
driver/monitor using AUTOINST in the testbench."
(save-excursion
- (let* ((params (verilog-read-auto-params 2 3))
+ (let* ((params (verilog-read-auto-params 2 4))
(submod (nth 0 params))
(modport-re (nth 1 params))
(regexp (nth 2 params))
- direction-re submodi) ; direction argument not supported until requested
+ (prefix (nth 3 params))
+ ;; direction-re ; direction argument not supported until requested
+ submodi)
;; Lookup position, etc of co-module
;; Note this may raise an error
(when (setq submodi (verilog-modi-lookup submod t))
@@ -13001,33 +13268,42 @@ driver/monitor using AUTOINST in the testbench."
(verilog-decls-get-vars submoddecls)
(verilog-signals-not-in
(verilog-decls-get-inputs submodportdecls)
- (append (verilog-decls-get-ports submoddecls)
- (verilog-decls-get-ports moddecls)))))
+ (verilog-decls-get-ports submoddecls))))
(sig-list-o (verilog-signals-in ; Decls doesn't have data types, must resolve
(verilog-decls-get-vars submoddecls)
(verilog-signals-not-in
(verilog-decls-get-outputs submodportdecls)
- (append (verilog-decls-get-ports submoddecls)
- (verilog-decls-get-ports moddecls)))))
+ (verilog-decls-get-ports submoddecls))))
(sig-list-io (verilog-signals-in ; Decls doesn't have data types, must resolve
(verilog-decls-get-vars submoddecls)
(verilog-signals-not-in
(verilog-decls-get-inouts submodportdecls)
- (append (verilog-decls-get-ports submoddecls)
- (verilog-decls-get-ports moddecls))))))
+ (verilog-decls-get-ports submoddecls)))))
(forward-line 1)
(setq sig-list-i (verilog-signals-edit-wire-reg
- (verilog-signals-matching-dir-re
- (verilog-signals-matching-regexp sig-list-i regexp)
- "input" direction-re))
+ (verilog-signals-not-in
+ (verilog-signals-add-prefix
+ (verilog-signals-matching-dir-re
+ (verilog-signals-matching-regexp sig-list-i regexp)
+ "input" nil) ;; direction-re
+ prefix)
+ (verilog-decls-get-ports moddecls)))
sig-list-o (verilog-signals-edit-wire-reg
- (verilog-signals-matching-dir-re
- (verilog-signals-matching-regexp sig-list-o regexp)
- "output" direction-re))
+ (verilog-signals-not-in
+ (verilog-signals-add-prefix
+ (verilog-signals-matching-dir-re
+ (verilog-signals-matching-regexp sig-list-o regexp)
+ "output" nil) ;; direction-re
+ prefix)
+ (verilog-decls-get-ports moddecls)))
sig-list-io (verilog-signals-edit-wire-reg
- (verilog-signals-matching-dir-re
- (verilog-signals-matching-regexp sig-list-io regexp)
- "inout" direction-re)))
+ (verilog-signals-not-in
+ (verilog-signals-add-prefix
+ (verilog-signals-matching-dir-re
+ (verilog-signals-matching-regexp sig-list-io regexp)
+ "inout" nil) ;; direction-re
+ prefix)
+ (verilog-decls-get-ports moddecls))))
(when v2k (verilog-repair-open-comma))
(when (or sig-list-i sig-list-o sig-list-io)
(verilog-insert-indent "// Beginning of automatic in/out/inouts (from modport)\n")
@@ -13264,7 +13540,7 @@ them to a one.
AUTORESET may try to reset arrays or structures that cannot be
reset by a simple assignment, resulting in compile errors. This
is a feature to be taken as a hint that you need to reset these
-signals manually (or put them into a \"\\=`ifdef NEVER signal<=\\=`0;
+signals manually (or put them into a \"\\=`ifdef NEVER signal<=\\='0;
\\=`endif\" so Verilog-Mode ignores them.)
An example:
@@ -13488,7 +13764,7 @@ defines the regular expression will be undefed."
(t
(setq defs (delete (match-string-no-properties 2) defs))))))
;; Insert
- (setq defs (sort defs 'string<))
+ (setq defs (sort defs #'string<))
(when defs
(verilog-forward-or-insert-line)
(verilog-insert-indent "// Beginning of automatic undefs\n")
@@ -13996,37 +14272,37 @@ Wilson Snyder (wsnyder@wsnyder.org)."
(defvar verilog-template-map
(let ((map (make-sparse-keymap)))
- (define-key map "a" 'verilog-sk-always)
- (define-key map "b" 'verilog-sk-begin)
- (define-key map "c" 'verilog-sk-case)
- (define-key map "f" 'verilog-sk-for)
- (define-key map "g" 'verilog-sk-generate)
- (define-key map "h" 'verilog-sk-header)
- (define-key map "i" 'verilog-sk-initial)
- (define-key map "j" 'verilog-sk-fork)
- (define-key map "m" 'verilog-sk-module)
- (define-key map "o" 'verilog-sk-ovm-class)
- (define-key map "p" 'verilog-sk-primitive)
- (define-key map "r" 'verilog-sk-repeat)
- (define-key map "s" 'verilog-sk-specify)
- (define-key map "t" 'verilog-sk-task)
- (define-key map "u" 'verilog-sk-uvm-object)
- (define-key map "w" 'verilog-sk-while)
- (define-key map "x" 'verilog-sk-casex)
- (define-key map "z" 'verilog-sk-casez)
- (define-key map "?" 'verilog-sk-if)
- (define-key map ":" 'verilog-sk-else-if)
- (define-key map "/" 'verilog-sk-comment)
- (define-key map "A" 'verilog-sk-assign)
- (define-key map "F" 'verilog-sk-function)
- (define-key map "I" 'verilog-sk-input)
- (define-key map "O" 'verilog-sk-output)
- (define-key map "S" 'verilog-sk-state-machine)
- (define-key map "=" 'verilog-sk-inout)
- (define-key map "U" 'verilog-sk-uvm-component)
- (define-key map "W" 'verilog-sk-wire)
- (define-key map "R" 'verilog-sk-reg)
- (define-key map "D" 'verilog-sk-define-signal)
+ (define-key map "a" #'verilog-sk-always)
+ (define-key map "b" #'verilog-sk-begin)
+ (define-key map "c" #'verilog-sk-case)
+ (define-key map "f" #'verilog-sk-for)
+ (define-key map "g" #'verilog-sk-generate)
+ (define-key map "h" #'verilog-sk-header)
+ (define-key map "i" #'verilog-sk-initial)
+ (define-key map "j" #'verilog-sk-fork)
+ (define-key map "m" #'verilog-sk-module)
+ (define-key map "o" #'verilog-sk-ovm-class)
+ (define-key map "p" #'verilog-sk-primitive)
+ (define-key map "r" #'verilog-sk-repeat)
+ (define-key map "s" #'verilog-sk-specify)
+ (define-key map "t" #'verilog-sk-task)
+ (define-key map "u" #'verilog-sk-uvm-object)
+ (define-key map "w" #'verilog-sk-while)
+ (define-key map "x" #'verilog-sk-casex)
+ (define-key map "z" #'verilog-sk-casez)
+ (define-key map "?" #'verilog-sk-if)
+ (define-key map ":" #'verilog-sk-else-if)
+ (define-key map "/" #'verilog-sk-comment)
+ (define-key map "A" #'verilog-sk-assign)
+ (define-key map "F" #'verilog-sk-function)
+ (define-key map "I" #'verilog-sk-input)
+ (define-key map "O" #'verilog-sk-output)
+ (define-key map "S" #'verilog-sk-state-machine)
+ (define-key map "=" #'verilog-sk-inout)
+ (define-key map "U" #'verilog-sk-uvm-component)
+ (define-key map "W" #'verilog-sk-wire)
+ (define-key map "R" #'verilog-sk-reg)
+ (define-key map "D" #'verilog-sk-define-signal)
map)
"Keymap used in Verilog mode for smart template operations.")
@@ -14417,13 +14693,13 @@ and the case items."
(let ((map (make-sparse-keymap))) ; as described in info pages, make a map
(set-keymap-parent map verilog-mode-map)
;; mouse button bindings
- (define-key map "\r" 'verilog-load-file-at-point)
- (if (featurep 'xemacs)
- (define-key map 'button2 'verilog-load-file-at-mouse);ffap-at-mouse ?
- (define-key map [mouse-2] 'verilog-load-file-at-mouse))
+ (define-key map "\r" #'verilog-load-file-at-point)
+ (define-key map
+ (if (featurep 'xemacs) 'button2 [mouse-2])
+ #'verilog-load-file-at-mouse)
(if (featurep 'xemacs)
- (define-key map 'Sh-button2 'mouse-yank) ; you wanna paste don't you ?
- (define-key map [S-mouse-2] 'mouse-yank-at-click))
+ (define-key map 'Sh-button2 #'mouse-yank) ; you wanna paste don't you ?
+ (define-key map [S-mouse-2] #'mouse-yank-at-click))
map)
"Map containing mouse bindings for `verilog-mode'.")
@@ -14496,7 +14772,7 @@ Clicking on the middle-mouse button loads them in a buffer (as in dired)."
(verilog-highlight-region (point-min) (point-max) nil))
;; Deprecated, but was interactive, so we'll keep it around
-(defalias 'verilog-colorize-include-files-buffer 'verilog-highlight-buffer)
+(defalias 'verilog-colorize-include-files-buffer #'verilog-highlight-buffer)
;; ffap-at-mouse isn't useful for Verilog mode. It uses library paths.
;; so define this function to do more or less the same as ffap-at-mouse
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index f0978b81d71..5eeac8af3b8 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -1,4 +1,4 @@
-;;; vhdl-mode.el --- major mode for editing VHDL code
+;;; vhdl-mode.el --- major mode for editing VHDL code -*- lexical-binding: t; -*-
;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
@@ -6,12 +6,15 @@
;; Rodney J. Whitby <software.vhdl-mode@rwhitby.net>
;; Maintainer: Reto Zimmermann <reto@gnu.org>
;; Keywords: languages vhdl
-;; WWW: http://www.iis.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html
+;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 18/3/2008, and the maintainer agreed that when a bug is
;; filed in the Emacs bug reporting system against this file, a copy
;; of the bug report be sent to the maintainer's email address.
+;;
+;; Reto also said in Apr 2021 that he preferred to keep the XEmacs
+;; compatibility code.
(defconst vhdl-version "3.38.1"
"VHDL Mode version number.")
@@ -77,7 +80,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Installation
-;; Prerequisites: GNU Emacs 20/21/22/23/24, XEmacs 20/21.
+;; Prerequisites: GNU Emacs >= 21, XEmacs 20/21.
;; Put `vhdl-mode.el' into the `site-lisp' directory of your Emacs installation
;; or into an arbitrary directory that is added to the load path by the
@@ -92,7 +95,7 @@
;; Add the following lines to the `site-start.el' file in the `site-lisp'
;; directory of your Emacs installation or to your Emacs start-up file `.emacs'
-;; (not required in Emacs 20 and higher):
+;; (not required in Emacs):
;; (autoload 'vhdl-mode "vhdl-mode" "VHDL Mode" t)
;; (push '("\\.vhdl?\\'" . vhdl-mode) auto-mode-alist)
@@ -136,12 +139,9 @@
(when (< emacs-major-version 25)
(condition-case nil (require 'cl-lib) (file-missing (require 'cl))))
-;; Emacs 21+ handling
-(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs)))
- "Non-nil if GNU Emacs 21, 22, ... is used.")
;; Emacs 22+ handling
(defconst vhdl-emacs-22 (and (<= 22 emacs-major-version) (not (featurep 'xemacs)))
- "Non-nil if GNU Emacs 22, ... is used.")
+ "Non-nil if GNU Emacs >= 22, ... is used.")
(defvar compilation-file-regexp-alist)
(defvar conf-alist)
@@ -490,7 +490,7 @@ NOTE: Activate new error and file message regexps and reflect the new setting
(const :tag "Upcase" upcase)
(const :tag "Downcase" downcase))))))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-update-mode-menu))
+ (vhdl-custom-set variable value #'vhdl-update-mode-menu))
:version "24.4"
:group 'vhdl-compile)
@@ -668,8 +668,8 @@ NOTE: Reflect the new setting in the choice list of option `vhdl-project'
:format "%t\n%v\n")))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-update-mode-menu
- 'vhdl-speedbar-refresh))
+ #'vhdl-update-mode-menu
+ #'vhdl-speedbar-refresh))
:group 'vhdl-project)
(defcustom vhdl-project nil
@@ -713,7 +713,7 @@ All project setup files that match the file names specified in option
\(alphabetically) last loaded setup of the first `vhdl-project-file-name'
entry is activated.
A project setup file can be obtained by exporting a project (see menu).
- At startup: project setup file is loaded at Emacs startup"
+ At startup: project setup file is loaded at Emacs startup."
:type '(set (const :tag "At startup" startup))
:group 'vhdl-project)
@@ -751,12 +751,12 @@ NOTE: Activate the new setting in a VHDL buffer by using the menu entry
(const :tag "Math packages" math)))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-template-map-init
- 'vhdl-mode-abbrev-table-init
- 'vhdl-template-construct-alist-init
- 'vhdl-template-package-alist-init
- 'vhdl-update-mode-menu
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-template-map-init
+ #'vhdl-mode-abbrev-table-init
+ #'vhdl-template-construct-alist-init
+ #'vhdl-template-package-alist-init
+ #'vhdl-update-mode-menu
+ #'vhdl-words-init 'vhdl-font-lock-init))
:group 'vhdl-style)
(defcustom vhdl-basic-offset 2
@@ -770,7 +770,7 @@ This value is used by + and - symbols in `vhdl-offsets-alist'."
This is done when typed or expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-types nil
@@ -778,7 +778,7 @@ This is done when typed or expanded or by the fix case functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-attributes nil
@@ -786,7 +786,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-enum-values nil
@@ -794,7 +794,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-constants t
@@ -802,7 +802,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-use-direct-instantiation 'standard
@@ -909,7 +909,7 @@ follows:
:type '(set (const :tag "VHDL keywords" vhdl)
(const :tag "User model keywords" user))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-mode-abbrev-table-init))
+ (vhdl-custom-set variable value #'vhdl-mode-abbrev-table-init))
:group 'vhdl-template)
(defcustom vhdl-optional-labels 'process
@@ -1192,10 +1192,10 @@ NOTE: Activate the new setting in a VHDL buffer by using the menu entry
(string :tag "Keyword " :format "%t: %v\n")))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-model-map-init
- 'vhdl-model-defun
- 'vhdl-mode-abbrev-table-init
- 'vhdl-update-mode-menu))
+ #'vhdl-model-map-init
+ #'vhdl-model-defun
+ #'vhdl-mode-abbrev-table-init
+ #'vhdl-update-mode-menu))
:group 'vhdl-model)
@@ -1598,7 +1598,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-names t
@@ -1615,7 +1615,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-special-words nil
@@ -1628,7 +1628,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-forbidden-words nil
@@ -1643,7 +1643,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
:type 'boolean
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-verilog-keywords nil
@@ -1656,7 +1656,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
:type 'boolean
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-translate-off nil
@@ -1670,7 +1670,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-case-sensitive nil
@@ -1724,7 +1724,7 @@ NOTE: Activate a changed regexp in a VHDL buffer by re-fontifying it (menu
(string :tag "Color (dark) ")
(boolean :tag "In comments ")))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-forbidden-words '()
@@ -1737,7 +1737,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
:type '(repeat (string :format "%v"))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-forbidden-syntax ""
@@ -1752,7 +1752,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
:type 'regexp
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-directive-keywords '("psl" "pragma" "synopsys")
@@ -1763,7 +1763,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu
:type '(repeat (string :format "%v"))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
@@ -2159,7 +2159,8 @@ your style, only those that are different from the default.")
;; mandatory
(require 'compile) ; XEmacs
-(require 'easymenu)
+(when (< emacs-major-version 28) ; preloaded in Emacs 28
+ (require 'easymenu))
(require 'hippie-exp)
;; optional (minimize warning messages during compile)
@@ -2237,11 +2238,11 @@ Ignore byte-compiler warnings you might see."
; (vhdl-warning-when-idle "Please install `xemacs-devel' package.")
(defun regexp-opt (strings &optional paren)
(let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
- (concat open (mapconcat 'regexp-quote strings "\\|") close))))
+ (concat open (mapconcat #'regexp-quote strings "\\|") close))))
;; `match-string-no-properties' undefined (XEmacs, what else?)
(unless (fboundp 'match-string-no-properties)
- (defalias 'match-string-no-properties 'match-string))
+ (defalias 'match-string-no-properties #'match-string))
;; `subst-char-in-string' undefined (XEmacs)
(unless (fboundp 'subst-char-in-string)
@@ -2268,7 +2269,7 @@ Ignore byte-compiler warnings you might see."
(let* ((nondir (file-name-nondirectory pattern))
(dirpart (file-name-directory pattern))
(dirs (if (and dirpart (string-match "[[*?]" dirpart))
- (mapcar 'file-name-as-directory
+ (mapcar #'file-name-as-directory
(file-expand-wildcards (directory-file-name dirpart)))
(list dirpart)))
contents)
@@ -2286,7 +2287,7 @@ Ignore byte-compiler warnings you might see."
(setq contents
(nconc
(if (and (car dirs) (not full))
- (mapcar (function (lambda (name) (concat (car dirs) name)))
+ (mapcar (lambda (name) (concat (car dirs) name))
this-dir-contents)
this-dir-contents)
contents))))
@@ -2295,7 +2296,7 @@ Ignore byte-compiler warnings you might see."
;; `member-ignore-case' undefined (XEmacs)
(unless (fboundp 'member-ignore-case)
- (defalias 'member-ignore-case 'member))
+ (defalias 'member-ignore-case #'member))
;; `last-input-char' obsolete in Emacs 24, `last-input-event' different
;; behavior in XEmacs
@@ -2304,10 +2305,6 @@ Ignore byte-compiler warnings you might see."
(defvaralias 'vhdl-last-input-event 'last-input-char)
(defvaralias 'vhdl-last-input-event 'last-input-event))
-;; `help-print-return-message' changed to `print-help-return-message' in Emacs
-;;;(unless (fboundp 'help-print-return-message)
-;;; (defalias 'help-print-return-message 'print-help-return-message))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Compatibility with older VHDL Mode versions
@@ -2498,6 +2495,7 @@ current buffer if no project is defined."
"Enable case insensitive search and switch to syntax table that includes `_',
then execute BODY, and finally restore the old environment. Used for
consistent searching."
+ (declare (debug t))
`(let ((case-fold-search t)) ; case insensitive search
;; use extended syntax table
(with-syntax-table vhdl-mode-ext-syntax-table
@@ -2507,55 +2505,59 @@ consistent searching."
"Enable case insensitive search, switch to syntax table that includes `_',
arrange to ignore `intangible' overlays, then execute BODY, and finally restore
the old environment. Used for consistent searching."
+ (declare (debug t))
`(let ((case-fold-search t) ; case insensitive search
- (current-syntax-table (syntax-table))
(inhibit-point-motion-hooks t))
;; use extended syntax table
- (set-syntax-table vhdl-mode-ext-syntax-table)
- ;; execute BODY safely
- (unwind-protect
- (progn ,@body)
- ;; restore syntax table
- (set-syntax-table current-syntax-table))))
+ (with-syntax-table vhdl-mode-ext-syntax-table
+ ;; execute BODY safely
+ (progn ,@body))))
(defmacro vhdl-visit-file (file-name issue-error &rest body)
"Visit file FILE-NAME and execute BODY."
- `(if (null ,file-name)
- (progn ,@body)
- (unless (file-directory-p ,file-name)
- (let ((source-buffer (current-buffer))
- (visiting-buffer (find-buffer-visiting ,file-name))
- file-opened)
- (when (or (and visiting-buffer (set-buffer visiting-buffer))
- (condition-case ()
- (progn (set-buffer (create-file-buffer ,file-name))
- (setq file-opened t)
- (vhdl-insert-file-contents ,file-name)
- ;; FIXME: This modifies a global syntax-table!
- (modify-syntax-entry ?\- ". 12" (syntax-table))
- (modify-syntax-entry ?\n ">" (syntax-table))
- (modify-syntax-entry ?\^M ">" (syntax-table))
- (modify-syntax-entry ?_ "w" (syntax-table))
- t)
- (error
- (if ,issue-error
- (progn
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)
- (error "ERROR: File cannot be opened: \"%s\"" ,file-name))
- (vhdl-warning (format "File cannot be opened: \"%s\"" ,file-name) t)
- nil))))
- (condition-case info
- (progn ,@body)
- (error
- (if ,issue-error
- (progn
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)
- (error (cadr info)))
- (vhdl-warning (cadr info))))))
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)))))
+ (declare (debug t) (indent 2))
+ `(vhdl--visit-file ,file-name ,issue-error (lambda () . ,body)))
+
+(defun vhdl--visit-file (file-name issue-error body-fun)
+ (if (null file-name)
+ (funcall body-fun)
+ (unless (file-directory-p file-name)
+ (let ((source-buffer (current-buffer))
+ (visiting-buffer (find-buffer-visiting file-name))
+ file-opened)
+ (when (or (and visiting-buffer (set-buffer visiting-buffer))
+ (condition-case ()
+ (progn (set-buffer (create-file-buffer file-name))
+ (setq file-opened t)
+ (vhdl-insert-file-contents file-name)
+ (let ((st (copy-syntax-table (syntax-table))))
+ (modify-syntax-entry ?\- ". 12" st)
+ (modify-syntax-entry ?\n ">" st)
+ (modify-syntax-entry ?\^M ">" st)
+ (modify-syntax-entry ?_ "w" st)
+ ;; FIXME: We should arguably reset the
+ ;; syntax-table after running `body-fun'.
+ (set-syntax-table st))
+ t)
+ (error
+ (if issue-error
+ (progn
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)
+ (error "ERROR: File cannot be opened: \"%s\"" file-name))
+ (vhdl-warning (format "File cannot be opened: \"%s\"" file-name) t)
+ nil))))
+ (condition-case info
+ (funcall body-fun)
+ (error
+ (if issue-error
+ (progn
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)
+ (error (cadr info)))
+ (vhdl-warning (cadr info))))))
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)))))
(defun vhdl-insert-file-contents (filename)
"Nicked from `insert-file-contents-literally', but allow coding system
@@ -2567,7 +2569,7 @@ conversion."
(defun vhdl-sort-alist (alist)
"Sort ALIST."
- (sort alist (function (lambda (a b) (string< (car a) (car b))))))
+ (sort alist (lambda (a b) (string< (car a) (car b)))))
(defun vhdl-get-subdirs (directory)
"Recursively get subdirectories of DIRECTORY."
@@ -2603,7 +2605,7 @@ conversion."
"Refresh directory or project with name KEY."
(when (and (boundp 'speedbar-frame)
(frame-live-p speedbar-frame))
- (let ((pos (point))
+ (let (;; (pos (point))
(last-frame (selected-frame)))
(if (null key)
(speedbar-refresh)
@@ -2680,96 +2682,96 @@ elements > `vhdl-menu-max-size'."
"Initialize `vhdl-template-map'."
(setq vhdl-template-map (make-sparse-keymap))
;; key bindings for VHDL templates
- (define-key vhdl-template-map "al" 'vhdl-template-alias)
- (define-key vhdl-template-map "ar" 'vhdl-template-architecture)
- (define-key vhdl-template-map "at" 'vhdl-template-assert)
- (define-key vhdl-template-map "ad" 'vhdl-template-attribute-decl)
- (define-key vhdl-template-map "as" 'vhdl-template-attribute-spec)
- (define-key vhdl-template-map "bl" 'vhdl-template-block)
- (define-key vhdl-template-map "ca" 'vhdl-template-case-is)
- (define-key vhdl-template-map "cd" 'vhdl-template-component-decl)
- (define-key vhdl-template-map "ci" 'vhdl-template-component-inst)
- (define-key vhdl-template-map "cs" 'vhdl-template-conditional-signal-asst)
- (define-key vhdl-template-map "Cb" 'vhdl-template-block-configuration)
- (define-key vhdl-template-map "Cc" 'vhdl-template-component-conf)
- (define-key vhdl-template-map "Cd" 'vhdl-template-configuration-decl)
- (define-key vhdl-template-map "Cs" 'vhdl-template-configuration-spec)
- (define-key vhdl-template-map "co" 'vhdl-template-constant)
- (define-key vhdl-template-map "ct" 'vhdl-template-context)
- (define-key vhdl-template-map "di" 'vhdl-template-disconnect)
- (define-key vhdl-template-map "el" 'vhdl-template-else)
- (define-key vhdl-template-map "ei" 'vhdl-template-elsif)
- (define-key vhdl-template-map "en" 'vhdl-template-entity)
- (define-key vhdl-template-map "ex" 'vhdl-template-exit)
- (define-key vhdl-template-map "fi" 'vhdl-template-file)
- (define-key vhdl-template-map "fg" 'vhdl-template-for-generate)
- (define-key vhdl-template-map "fl" 'vhdl-template-for-loop)
- (define-key vhdl-template-map "\C-f" 'vhdl-template-footer)
- (define-key vhdl-template-map "fb" 'vhdl-template-function-body)
- (define-key vhdl-template-map "fd" 'vhdl-template-function-decl)
- (define-key vhdl-template-map "ge" 'vhdl-template-generic)
- (define-key vhdl-template-map "gd" 'vhdl-template-group-decl)
- (define-key vhdl-template-map "gt" 'vhdl-template-group-template)
- (define-key vhdl-template-map "\C-h" 'vhdl-template-header)
- (define-key vhdl-template-map "ig" 'vhdl-template-if-generate)
- (define-key vhdl-template-map "it" 'vhdl-template-if-then)
- (define-key vhdl-template-map "li" 'vhdl-template-library)
- (define-key vhdl-template-map "lo" 'vhdl-template-bare-loop)
- (define-key vhdl-template-map "\C-m" 'vhdl-template-modify)
- (define-key vhdl-template-map "\C-t" 'vhdl-template-insert-date)
- (define-key vhdl-template-map "ma" 'vhdl-template-map)
- (define-key vhdl-template-map "ne" 'vhdl-template-next)
- (define-key vhdl-template-map "ot" 'vhdl-template-others)
- (define-key vhdl-template-map "Pd" 'vhdl-template-package-decl)
- (define-key vhdl-template-map "Pb" 'vhdl-template-package-body)
- (define-key vhdl-template-map "(" 'vhdl-template-paired-parens)
- (define-key vhdl-template-map "po" 'vhdl-template-port)
- (define-key vhdl-template-map "pb" 'vhdl-template-procedure-body)
- (define-key vhdl-template-map "pd" 'vhdl-template-procedure-decl)
- (define-key vhdl-template-map "pc" 'vhdl-template-process-comb)
- (define-key vhdl-template-map "ps" 'vhdl-template-process-seq)
- (define-key vhdl-template-map "rp" 'vhdl-template-report)
- (define-key vhdl-template-map "rt" 'vhdl-template-return)
- (define-key vhdl-template-map "ss" 'vhdl-template-selected-signal-asst)
- (define-key vhdl-template-map "si" 'vhdl-template-signal)
- (define-key vhdl-template-map "su" 'vhdl-template-subtype)
- (define-key vhdl-template-map "ty" 'vhdl-template-type)
- (define-key vhdl-template-map "us" 'vhdl-template-use)
- (define-key vhdl-template-map "va" 'vhdl-template-variable)
- (define-key vhdl-template-map "wa" 'vhdl-template-wait)
- (define-key vhdl-template-map "wl" 'vhdl-template-while-loop)
- (define-key vhdl-template-map "wi" 'vhdl-template-with)
- (define-key vhdl-template-map "wc" 'vhdl-template-clocked-wait)
- (define-key vhdl-template-map "\C-pb" 'vhdl-template-package-numeric-bit)
- (define-key vhdl-template-map "\C-pn" 'vhdl-template-package-numeric-std)
- (define-key vhdl-template-map "\C-ps" 'vhdl-template-package-std-logic-1164)
- (define-key vhdl-template-map "\C-pA" 'vhdl-template-package-std-logic-arith)
- (define-key vhdl-template-map "\C-pM" 'vhdl-template-package-std-logic-misc)
- (define-key vhdl-template-map "\C-pS" 'vhdl-template-package-std-logic-signed)
- (define-key vhdl-template-map "\C-pT" 'vhdl-template-package-std-logic-textio)
- (define-key vhdl-template-map "\C-pU" 'vhdl-template-package-std-logic-unsigned)
- (define-key vhdl-template-map "\C-pt" 'vhdl-template-package-textio)
- (define-key vhdl-template-map "\C-dn" 'vhdl-template-directive-translate-on)
- (define-key vhdl-template-map "\C-df" 'vhdl-template-directive-translate-off)
- (define-key vhdl-template-map "\C-dN" 'vhdl-template-directive-synthesis-on)
- (define-key vhdl-template-map "\C-dF" 'vhdl-template-directive-synthesis-off)
- (define-key vhdl-template-map "\C-q" 'vhdl-template-search-prompt)
+ (define-key vhdl-template-map "al" #'vhdl-template-alias)
+ (define-key vhdl-template-map "ar" #'vhdl-template-architecture)
+ (define-key vhdl-template-map "at" #'vhdl-template-assert)
+ (define-key vhdl-template-map "ad" #'vhdl-template-attribute-decl)
+ (define-key vhdl-template-map "as" #'vhdl-template-attribute-spec)
+ (define-key vhdl-template-map "bl" #'vhdl-template-block)
+ (define-key vhdl-template-map "ca" #'vhdl-template-case-is)
+ (define-key vhdl-template-map "cd" #'vhdl-template-component-decl)
+ (define-key vhdl-template-map "ci" #'vhdl-template-component-inst)
+ (define-key vhdl-template-map "cs" #'vhdl-template-conditional-signal-asst)
+ (define-key vhdl-template-map "Cb" #'vhdl-template-block-configuration)
+ (define-key vhdl-template-map "Cc" #'vhdl-template-component-conf)
+ (define-key vhdl-template-map "Cd" #'vhdl-template-configuration-decl)
+ (define-key vhdl-template-map "Cs" #'vhdl-template-configuration-spec)
+ (define-key vhdl-template-map "co" #'vhdl-template-constant)
+ (define-key vhdl-template-map "ct" #'vhdl-template-context)
+ (define-key vhdl-template-map "di" #'vhdl-template-disconnect)
+ (define-key vhdl-template-map "el" #'vhdl-template-else)
+ (define-key vhdl-template-map "ei" #'vhdl-template-elsif)
+ (define-key vhdl-template-map "en" #'vhdl-template-entity)
+ (define-key vhdl-template-map "ex" #'vhdl-template-exit)
+ (define-key vhdl-template-map "fi" #'vhdl-template-file)
+ (define-key vhdl-template-map "fg" #'vhdl-template-for-generate)
+ (define-key vhdl-template-map "fl" #'vhdl-template-for-loop)
+ (define-key vhdl-template-map "\C-f" #'vhdl-template-footer)
+ (define-key vhdl-template-map "fb" #'vhdl-template-function-body)
+ (define-key vhdl-template-map "fd" #'vhdl-template-function-decl)
+ (define-key vhdl-template-map "ge" #'vhdl-template-generic)
+ (define-key vhdl-template-map "gd" #'vhdl-template-group-decl)
+ (define-key vhdl-template-map "gt" #'vhdl-template-group-template)
+ (define-key vhdl-template-map "\C-h" #'vhdl-template-header)
+ (define-key vhdl-template-map "ig" #'vhdl-template-if-generate)
+ (define-key vhdl-template-map "it" #'vhdl-template-if-then)
+ (define-key vhdl-template-map "li" #'vhdl-template-library)
+ (define-key vhdl-template-map "lo" #'vhdl-template-bare-loop)
+ (define-key vhdl-template-map "\C-m" #'vhdl-template-modify)
+ (define-key vhdl-template-map "\C-t" #'vhdl-template-insert-date)
+ (define-key vhdl-template-map "ma" #'vhdl-template-map)
+ (define-key vhdl-template-map "ne" #'vhdl-template-next)
+ (define-key vhdl-template-map "ot" #'vhdl-template-others)
+ (define-key vhdl-template-map "Pd" #'vhdl-template-package-decl)
+ (define-key vhdl-template-map "Pb" #'vhdl-template-package-body)
+ (define-key vhdl-template-map "(" #'vhdl-template-paired-parens)
+ (define-key vhdl-template-map "po" #'vhdl-template-port)
+ (define-key vhdl-template-map "pb" #'vhdl-template-procedure-body)
+ (define-key vhdl-template-map "pd" #'vhdl-template-procedure-decl)
+ (define-key vhdl-template-map "pc" #'vhdl-template-process-comb)
+ (define-key vhdl-template-map "ps" #'vhdl-template-process-seq)
+ (define-key vhdl-template-map "rp" #'vhdl-template-report)
+ (define-key vhdl-template-map "rt" #'vhdl-template-return)
+ (define-key vhdl-template-map "ss" #'vhdl-template-selected-signal-asst)
+ (define-key vhdl-template-map "si" #'vhdl-template-signal)
+ (define-key vhdl-template-map "su" #'vhdl-template-subtype)
+ (define-key vhdl-template-map "ty" #'vhdl-template-type)
+ (define-key vhdl-template-map "us" #'vhdl-template-use)
+ (define-key vhdl-template-map "va" #'vhdl-template-variable)
+ (define-key vhdl-template-map "wa" #'vhdl-template-wait)
+ (define-key vhdl-template-map "wl" #'vhdl-template-while-loop)
+ (define-key vhdl-template-map "wi" #'vhdl-template-with)
+ (define-key vhdl-template-map "wc" #'vhdl-template-clocked-wait)
+ (define-key vhdl-template-map "\C-pb" #'vhdl-template-package-numeric-bit)
+ (define-key vhdl-template-map "\C-pn" #'vhdl-template-package-numeric-std)
+ (define-key vhdl-template-map "\C-ps" #'vhdl-template-package-std-logic-1164)
+ (define-key vhdl-template-map "\C-pA" #'vhdl-template-package-std-logic-arith)
+ (define-key vhdl-template-map "\C-pM" #'vhdl-template-package-std-logic-misc)
+ (define-key vhdl-template-map "\C-pS" #'vhdl-template-package-std-logic-signed)
+ (define-key vhdl-template-map "\C-pT" #'vhdl-template-package-std-logic-textio)
+ (define-key vhdl-template-map "\C-pU" #'vhdl-template-package-std-logic-unsigned)
+ (define-key vhdl-template-map "\C-pt" #'vhdl-template-package-textio)
+ (define-key vhdl-template-map "\C-dn" #'vhdl-template-directive-translate-on)
+ (define-key vhdl-template-map "\C-df" #'vhdl-template-directive-translate-off)
+ (define-key vhdl-template-map "\C-dN" #'vhdl-template-directive-synthesis-on)
+ (define-key vhdl-template-map "\C-dF" #'vhdl-template-directive-synthesis-off)
+ (define-key vhdl-template-map "\C-q" #'vhdl-template-search-prompt)
(when (vhdl-standard-p 'ams)
- (define-key vhdl-template-map "br" 'vhdl-template-break)
- (define-key vhdl-template-map "cu" 'vhdl-template-case-use)
- (define-key vhdl-template-map "iu" 'vhdl-template-if-use)
- (define-key vhdl-template-map "lm" 'vhdl-template-limit)
- (define-key vhdl-template-map "na" 'vhdl-template-nature)
- (define-key vhdl-template-map "pa" 'vhdl-template-procedural)
- (define-key vhdl-template-map "qf" 'vhdl-template-quantity-free)
- (define-key vhdl-template-map "qb" 'vhdl-template-quantity-branch)
- (define-key vhdl-template-map "qs" 'vhdl-template-quantity-source)
- (define-key vhdl-template-map "sn" 'vhdl-template-subnature)
- (define-key vhdl-template-map "te" 'vhdl-template-terminal)
+ (define-key vhdl-template-map "br" #'vhdl-template-break)
+ (define-key vhdl-template-map "cu" #'vhdl-template-case-use)
+ (define-key vhdl-template-map "iu" #'vhdl-template-if-use)
+ (define-key vhdl-template-map "lm" #'vhdl-template-limit)
+ (define-key vhdl-template-map "na" #'vhdl-template-nature)
+ (define-key vhdl-template-map "pa" #'vhdl-template-procedural)
+ (define-key vhdl-template-map "qf" #'vhdl-template-quantity-free)
+ (define-key vhdl-template-map "qb" #'vhdl-template-quantity-branch)
+ (define-key vhdl-template-map "qs" #'vhdl-template-quantity-source)
+ (define-key vhdl-template-map "sn" #'vhdl-template-subnature)
+ (define-key vhdl-template-map "te" #'vhdl-template-terminal)
)
(when (vhdl-standard-p 'math)
- (define-key vhdl-template-map "\C-pc" 'vhdl-template-package-math-complex)
- (define-key vhdl-template-map "\C-pr" 'vhdl-template-package-math-real)
+ (define-key vhdl-template-map "\C-pc" #'vhdl-template-package-math-complex)
+ (define-key vhdl-template-map "\C-pr" #'vhdl-template-package-math-real)
))
;; initialize template map for VHDL Mode
@@ -2815,119 +2817,120 @@ STRING are replaced by `-' and substrings are converted to lower case."
;; model key bindings
(define-key vhdl-mode-map "\C-c\C-m" vhdl-model-map)
;; standard key bindings
- (define-key vhdl-mode-map "\M-a" 'vhdl-beginning-of-statement)
- (define-key vhdl-mode-map "\M-e" 'vhdl-end-of-statement)
- (define-key vhdl-mode-map "\M-\C-f" 'vhdl-forward-sexp)
- (define-key vhdl-mode-map "\M-\C-b" 'vhdl-backward-sexp)
- (define-key vhdl-mode-map "\M-\C-u" 'vhdl-backward-up-list)
- (define-key vhdl-mode-map "\M-\C-a" 'vhdl-backward-same-indent)
- (define-key vhdl-mode-map "\M-\C-e" 'vhdl-forward-same-indent)
+ (define-key vhdl-mode-map "\M-a" #'vhdl-beginning-of-statement)
+ (define-key vhdl-mode-map "\M-e" #'vhdl-end-of-statement)
+ (define-key vhdl-mode-map "\M-\C-f" #'vhdl-forward-sexp)
+ (define-key vhdl-mode-map "\M-\C-b" #'vhdl-backward-sexp)
+ (define-key vhdl-mode-map "\M-\C-u" #'vhdl-backward-up-list)
+ (define-key vhdl-mode-map "\M-\C-a" #'vhdl-backward-same-indent)
+ (define-key vhdl-mode-map "\M-\C-e" #'vhdl-forward-same-indent)
(unless (featurep 'xemacs) ; would override `M-backspace' in XEmacs
- (define-key vhdl-mode-map "\M-\C-h" 'vhdl-mark-defun))
- (define-key vhdl-mode-map "\M-\C-q" 'vhdl-indent-sexp)
- (define-key vhdl-mode-map "\M-^" 'vhdl-delete-indentation)
+ (define-key vhdl-mode-map "\M-\C-h" #'vhdl-mark-defun))
+ (define-key vhdl-mode-map "\M-\C-q" #'vhdl-indent-sexp)
+ (define-key vhdl-mode-map "\M-^" #'vhdl-delete-indentation)
;; mode specific key bindings
- (define-key vhdl-mode-map "\C-c\C-m\C-e" 'vhdl-electric-mode)
- (define-key vhdl-mode-map "\C-c\C-m\C-s" 'vhdl-stutter-mode)
- (define-key vhdl-mode-map "\C-c\C-s\C-p" 'vhdl-set-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-d" 'vhdl-duplicate-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-m" 'vhdl-import-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-x" 'vhdl-export-project)
- (define-key vhdl-mode-map "\C-c\C-s\C-k" 'vhdl-set-compiler)
- (define-key vhdl-mode-map "\C-c\C-k" 'vhdl-compile)
- (define-key vhdl-mode-map "\C-c\M-\C-k" 'vhdl-make)
- (define-key vhdl-mode-map "\C-c\M-k" 'vhdl-generate-makefile)
- (define-key vhdl-mode-map "\C-c\C-p\C-w" 'vhdl-port-copy)
- (define-key vhdl-mode-map "\C-c\C-p\M-w" 'vhdl-port-copy)
- (define-key vhdl-mode-map "\C-c\C-p\C-e" 'vhdl-port-paste-entity)
- (define-key vhdl-mode-map "\C-c\C-p\C-c" 'vhdl-port-paste-component)
- (define-key vhdl-mode-map "\C-c\C-p\C-i" 'vhdl-port-paste-instance)
- (define-key vhdl-mode-map "\C-c\C-p\C-s" 'vhdl-port-paste-signals)
- (define-key vhdl-mode-map "\C-c\C-p\M-c" 'vhdl-port-paste-constants)
- (if (featurep 'xemacs) ; `... C-g' not allowed in XEmacs
- (define-key vhdl-mode-map "\C-c\C-p\M-g" 'vhdl-port-paste-generic-map)
- (define-key vhdl-mode-map "\C-c\C-p\C-g" 'vhdl-port-paste-generic-map))
- (define-key vhdl-mode-map "\C-c\C-p\C-z" 'vhdl-port-paste-initializations)
- (define-key vhdl-mode-map "\C-c\C-p\C-t" 'vhdl-port-paste-testbench)
- (define-key vhdl-mode-map "\C-c\C-p\C-f" 'vhdl-port-flatten)
- (define-key vhdl-mode-map "\C-c\C-p\C-r" 'vhdl-port-reverse-direction)
- (define-key vhdl-mode-map "\C-c\C-s\C-w" 'vhdl-subprog-copy)
- (define-key vhdl-mode-map "\C-c\C-s\M-w" 'vhdl-subprog-copy)
- (define-key vhdl-mode-map "\C-c\C-s\C-d" 'vhdl-subprog-paste-declaration)
- (define-key vhdl-mode-map "\C-c\C-s\C-b" 'vhdl-subprog-paste-body)
- (define-key vhdl-mode-map "\C-c\C-s\C-c" 'vhdl-subprog-paste-call)
- (define-key vhdl-mode-map "\C-c\C-s\C-f" 'vhdl-subprog-flatten)
- (define-key vhdl-mode-map "\C-c\C-m\C-n" 'vhdl-compose-new-component)
- (define-key vhdl-mode-map "\C-c\C-m\C-p" 'vhdl-compose-place-component)
- (define-key vhdl-mode-map "\C-c\C-m\C-w" 'vhdl-compose-wire-components)
- (define-key vhdl-mode-map "\C-c\C-m\C-f" 'vhdl-compose-configuration)
- (define-key vhdl-mode-map "\C-c\C-m\C-k" 'vhdl-compose-components-package)
- (define-key vhdl-mode-map "\C-c\C-c" 'vhdl-comment-uncomment-region)
- (define-key vhdl-mode-map "\C-c-" 'vhdl-comment-append-inline)
- (define-key vhdl-mode-map "\C-c\M--" 'vhdl-comment-display-line)
- (define-key vhdl-mode-map "\C-c\C-i\C-l" 'indent-according-to-mode)
- (define-key vhdl-mode-map "\C-c\C-i\C-g" 'vhdl-indent-group)
- (define-key vhdl-mode-map "\M-\C-\\" 'vhdl-indent-region)
- (define-key vhdl-mode-map "\C-c\C-i\C-b" 'vhdl-indent-buffer)
- (define-key vhdl-mode-map "\C-c\C-a\C-g" 'vhdl-align-group)
- (define-key vhdl-mode-map "\C-c\C-a\C-a" 'vhdl-align-group)
- (define-key vhdl-mode-map "\C-c\C-a\C-i" 'vhdl-align-same-indent)
- (define-key vhdl-mode-map "\C-c\C-a\C-l" 'vhdl-align-list)
- (define-key vhdl-mode-map "\C-c\C-a\C-d" 'vhdl-align-declarations)
- (define-key vhdl-mode-map "\C-c\C-a\M-a" 'vhdl-align-region)
- (define-key vhdl-mode-map "\C-c\C-a\C-b" 'vhdl-align-buffer)
- (define-key vhdl-mode-map "\C-c\C-a\C-c" 'vhdl-align-inline-comment-group)
- (define-key vhdl-mode-map "\C-c\C-a\M-c" 'vhdl-align-inline-comment-region)
- (define-key vhdl-mode-map "\C-c\C-f\C-l" 'vhdl-fill-list)
- (define-key vhdl-mode-map "\C-c\C-f\C-f" 'vhdl-fill-list)
- (define-key vhdl-mode-map "\C-c\C-f\C-g" 'vhdl-fill-group)
- (define-key vhdl-mode-map "\C-c\C-f\C-i" 'vhdl-fill-same-indent)
- (define-key vhdl-mode-map "\C-c\C-f\M-f" 'vhdl-fill-region)
- (define-key vhdl-mode-map "\C-c\C-l\C-w" 'vhdl-line-kill)
- (define-key vhdl-mode-map "\C-c\C-l\M-w" 'vhdl-line-copy)
- (define-key vhdl-mode-map "\C-c\C-l\C-y" 'vhdl-line-yank)
- (define-key vhdl-mode-map "\C-c\C-l\t" 'vhdl-line-expand)
- (define-key vhdl-mode-map "\C-c\C-l\C-n" 'vhdl-line-transpose-next)
- (define-key vhdl-mode-map "\C-c\C-l\C-p" 'vhdl-line-transpose-previous)
- (define-key vhdl-mode-map "\C-c\C-l\C-o" 'vhdl-line-open)
- (define-key vhdl-mode-map "\C-c\C-l\C-g" 'goto-line)
- (define-key vhdl-mode-map "\C-c\C-l\C-c" 'vhdl-comment-uncomment-line)
- (define-key vhdl-mode-map "\C-c\C-x\C-s" 'vhdl-fix-statement-region)
- (define-key vhdl-mode-map "\C-c\C-x\M-s" 'vhdl-fix-statement-buffer)
- (define-key vhdl-mode-map "\C-c\C-x\C-p" 'vhdl-fix-clause)
- (define-key vhdl-mode-map "\C-c\C-x\M-c" 'vhdl-fix-case-region)
- (define-key vhdl-mode-map "\C-c\C-x\C-c" 'vhdl-fix-case-buffer)
- (define-key vhdl-mode-map "\C-c\C-x\M-w" 'vhdl-fixup-whitespace-region)
- (define-key vhdl-mode-map "\C-c\C-x\C-w" 'vhdl-fixup-whitespace-buffer)
- (define-key vhdl-mode-map "\C-c\M-b" 'vhdl-beautify-region)
- (define-key vhdl-mode-map "\C-c\C-b" 'vhdl-beautify-buffer)
- (define-key vhdl-mode-map "\C-c\C-u\C-s" 'vhdl-update-sensitivity-list-process)
- (define-key vhdl-mode-map "\C-c\C-u\M-s" 'vhdl-update-sensitivity-list-buffer)
- (define-key vhdl-mode-map "\C-c\C-i\C-f" 'vhdl-fontify-buffer)
- (define-key vhdl-mode-map "\C-c\C-i\C-s" 'vhdl-statistics-buffer)
- (define-key vhdl-mode-map "\C-c\M-m" 'vhdl-show-messages)
- (define-key vhdl-mode-map "\C-c\C-h" 'vhdl-doc-mode)
- (define-key vhdl-mode-map "\C-c\C-v" 'vhdl-version)
- (define-key vhdl-mode-map "\M-\t" 'insert-tab)
+ (define-key vhdl-mode-map "\C-c\C-m\C-e" #'vhdl-electric-mode)
+ (define-key vhdl-mode-map "\C-c\C-m\C-s" #'vhdl-stutter-mode)
+ (define-key vhdl-mode-map "\C-c\C-s\C-p" #'vhdl-set-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-d" #'vhdl-duplicate-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-m" #'vhdl-import-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-x" #'vhdl-export-project)
+ (define-key vhdl-mode-map "\C-c\C-s\C-k" #'vhdl-set-compiler)
+ (define-key vhdl-mode-map "\C-c\C-k" #'vhdl-compile)
+ (define-key vhdl-mode-map "\C-c\M-\C-k" #'vhdl-make)
+ (define-key vhdl-mode-map "\C-c\M-k" #'vhdl-generate-makefile)
+ (define-key vhdl-mode-map "\C-c\C-p\C-w" #'vhdl-port-copy)
+ (define-key vhdl-mode-map "\C-c\C-p\M-w" #'vhdl-port-copy)
+ (define-key vhdl-mode-map "\C-c\C-p\C-e" #'vhdl-port-paste-entity)
+ (define-key vhdl-mode-map "\C-c\C-p\C-c" #'vhdl-port-paste-component)
+ (define-key vhdl-mode-map "\C-c\C-p\C-i" #'vhdl-port-paste-instance)
+ (define-key vhdl-mode-map "\C-c\C-p\C-s" #'vhdl-port-paste-signals)
+ (define-key vhdl-mode-map "\C-c\C-p\M-c" #'vhdl-port-paste-constants)
+ (define-key vhdl-mode-map
+ ;; `... C-g' not allowed in XEmacs.
+ (if (featurep 'xemacs) "\C-c\C-p\M-g" "\C-c\C-p\C-g")
+ #'vhdl-port-paste-generic-map)
+ (define-key vhdl-mode-map "\C-c\C-p\C-z" #'vhdl-port-paste-initializations)
+ (define-key vhdl-mode-map "\C-c\C-p\C-t" #'vhdl-port-paste-testbench)
+ (define-key vhdl-mode-map "\C-c\C-p\C-f" #'vhdl-port-flatten)
+ (define-key vhdl-mode-map "\C-c\C-p\C-r" #'vhdl-port-reverse-direction)
+ (define-key vhdl-mode-map "\C-c\C-s\C-w" #'vhdl-subprog-copy)
+ (define-key vhdl-mode-map "\C-c\C-s\M-w" #'vhdl-subprog-copy)
+ (define-key vhdl-mode-map "\C-c\C-s\C-d" #'vhdl-subprog-paste-declaration)
+ (define-key vhdl-mode-map "\C-c\C-s\C-b" #'vhdl-subprog-paste-body)
+ (define-key vhdl-mode-map "\C-c\C-s\C-c" #'vhdl-subprog-paste-call)
+ (define-key vhdl-mode-map "\C-c\C-s\C-f" #'vhdl-subprog-flatten)
+ (define-key vhdl-mode-map "\C-c\C-m\C-n" #'vhdl-compose-new-component)
+ (define-key vhdl-mode-map "\C-c\C-m\C-p" #'vhdl-compose-place-component)
+ (define-key vhdl-mode-map "\C-c\C-m\C-w" #'vhdl-compose-wire-components)
+ (define-key vhdl-mode-map "\C-c\C-m\C-f" #'vhdl-compose-configuration)
+ (define-key vhdl-mode-map "\C-c\C-m\C-k" #'vhdl-compose-components-package)
+ (define-key vhdl-mode-map "\C-c\C-c" #'vhdl-comment-uncomment-region)
+ (define-key vhdl-mode-map "\C-c-" #'vhdl-comment-append-inline)
+ (define-key vhdl-mode-map "\C-c\M--" #'vhdl-comment-display-line)
+ (define-key vhdl-mode-map "\C-c\C-i\C-l" #'indent-according-to-mode)
+ (define-key vhdl-mode-map "\C-c\C-i\C-g" #'vhdl-indent-group)
+ (define-key vhdl-mode-map "\M-\C-\\" #'indent-region)
+ (define-key vhdl-mode-map "\C-c\C-i\C-b" #'vhdl-indent-buffer)
+ (define-key vhdl-mode-map "\C-c\C-a\C-g" #'vhdl-align-group)
+ (define-key vhdl-mode-map "\C-c\C-a\C-a" #'vhdl-align-group)
+ (define-key vhdl-mode-map "\C-c\C-a\C-i" #'vhdl-align-same-indent)
+ (define-key vhdl-mode-map "\C-c\C-a\C-l" #'vhdl-align-list)
+ (define-key vhdl-mode-map "\C-c\C-a\C-d" #'vhdl-align-declarations)
+ (define-key vhdl-mode-map "\C-c\C-a\M-a" #'vhdl-align-region)
+ (define-key vhdl-mode-map "\C-c\C-a\C-b" #'vhdl-align-buffer)
+ (define-key vhdl-mode-map "\C-c\C-a\C-c" #'vhdl-align-inline-comment-group)
+ (define-key vhdl-mode-map "\C-c\C-a\M-c" #'vhdl-align-inline-comment-region)
+ (define-key vhdl-mode-map "\C-c\C-f\C-l" #'vhdl-fill-list)
+ (define-key vhdl-mode-map "\C-c\C-f\C-f" #'vhdl-fill-list)
+ (define-key vhdl-mode-map "\C-c\C-f\C-g" #'vhdl-fill-group)
+ (define-key vhdl-mode-map "\C-c\C-f\C-i" #'vhdl-fill-same-indent)
+ (define-key vhdl-mode-map "\C-c\C-f\M-f" #'vhdl-fill-region)
+ (define-key vhdl-mode-map "\C-c\C-l\C-w" #'vhdl-line-kill)
+ (define-key vhdl-mode-map "\C-c\C-l\M-w" #'vhdl-line-copy)
+ (define-key vhdl-mode-map "\C-c\C-l\C-y" #'vhdl-line-yank)
+ (define-key vhdl-mode-map "\C-c\C-l\t" #'vhdl-line-expand)
+ (define-key vhdl-mode-map "\C-c\C-l\C-n" #'vhdl-line-transpose-next)
+ (define-key vhdl-mode-map "\C-c\C-l\C-p" #'vhdl-line-transpose-previous)
+ (define-key vhdl-mode-map "\C-c\C-l\C-o" #'vhdl-line-open)
+ (define-key vhdl-mode-map "\C-c\C-l\C-g" #'goto-line)
+ (define-key vhdl-mode-map "\C-c\C-l\C-c" #'vhdl-comment-uncomment-line)
+ (define-key vhdl-mode-map "\C-c\C-x\C-s" #'vhdl-fix-statement-region)
+ (define-key vhdl-mode-map "\C-c\C-x\M-s" #'vhdl-fix-statement-buffer)
+ (define-key vhdl-mode-map "\C-c\C-x\C-p" #'vhdl-fix-clause)
+ (define-key vhdl-mode-map "\C-c\C-x\M-c" #'vhdl-fix-case-region)
+ (define-key vhdl-mode-map "\C-c\C-x\C-c" #'vhdl-fix-case-buffer)
+ (define-key vhdl-mode-map "\C-c\C-x\M-w" #'vhdl-fixup-whitespace-region)
+ (define-key vhdl-mode-map "\C-c\C-x\C-w" #'vhdl-fixup-whitespace-buffer)
+ (define-key vhdl-mode-map "\C-c\M-b" #'vhdl-beautify-region)
+ (define-key vhdl-mode-map "\C-c\C-b" #'vhdl-beautify-buffer)
+ (define-key vhdl-mode-map "\C-c\C-u\C-s" #'vhdl-update-sensitivity-list-process)
+ (define-key vhdl-mode-map "\C-c\C-u\M-s" #'vhdl-update-sensitivity-list-buffer)
+ (define-key vhdl-mode-map "\C-c\C-i\C-f" #'vhdl-fontify-buffer)
+ (define-key vhdl-mode-map "\C-c\C-i\C-s" #'vhdl-statistics-buffer)
+ (define-key vhdl-mode-map "\C-c\M-m" #'vhdl-show-messages)
+ (define-key vhdl-mode-map "\C-c\C-h" #'vhdl-doc-mode)
+ (define-key vhdl-mode-map "\C-c\C-v" #'vhdl-version)
+ (define-key vhdl-mode-map "\M-\t" #'insert-tab)
;; insert commands bindings
- (define-key vhdl-mode-map "\C-c\C-i\C-t" 'vhdl-template-insert-construct)
- (define-key vhdl-mode-map "\C-c\C-i\C-p" 'vhdl-template-insert-package)
- (define-key vhdl-mode-map "\C-c\C-i\C-d" 'vhdl-template-insert-directive)
- (define-key vhdl-mode-map "\C-c\C-i\C-m" 'vhdl-model-insert)
+ (define-key vhdl-mode-map "\C-c\C-i\C-t" #'vhdl-template-insert-construct)
+ (define-key vhdl-mode-map "\C-c\C-i\C-p" #'vhdl-template-insert-package)
+ (define-key vhdl-mode-map "\C-c\C-i\C-d" #'vhdl-template-insert-directive)
+ (define-key vhdl-mode-map "\C-c\C-i\C-m" #'vhdl-model-insert)
;; electric key bindings
- (define-key vhdl-mode-map " " 'vhdl-electric-space)
+ (define-key vhdl-mode-map " " #'vhdl-electric-space)
(when vhdl-intelligent-tab
- (define-key vhdl-mode-map "\t" 'vhdl-electric-tab))
- (define-key vhdl-mode-map "\r" 'vhdl-electric-return)
- (define-key vhdl-mode-map "-" 'vhdl-electric-dash)
- (define-key vhdl-mode-map "[" 'vhdl-electric-open-bracket)
- (define-key vhdl-mode-map "]" 'vhdl-electric-close-bracket)
- (define-key vhdl-mode-map "'" 'vhdl-electric-quote)
- (define-key vhdl-mode-map ";" 'vhdl-electric-semicolon)
- (define-key vhdl-mode-map "," 'vhdl-electric-comma)
- (define-key vhdl-mode-map "." 'vhdl-electric-period)
+ (define-key vhdl-mode-map "\t" #'vhdl-electric-tab))
+ (define-key vhdl-mode-map "\r" #'vhdl-electric-return)
+ (define-key vhdl-mode-map "-" #'vhdl-electric-dash)
+ (define-key vhdl-mode-map "[" #'vhdl-electric-open-bracket)
+ (define-key vhdl-mode-map "]" #'vhdl-electric-close-bracket)
+ (define-key vhdl-mode-map "'" #'vhdl-electric-quote)
+ (define-key vhdl-mode-map ";" #'vhdl-electric-semicolon)
+ (define-key vhdl-mode-map "," #'vhdl-electric-comma)
+ (define-key vhdl-mode-map "." #'vhdl-electric-period)
(when (vhdl-standard-p 'ams)
- (define-key vhdl-mode-map "=" 'vhdl-electric-equal)))
+ (define-key vhdl-mode-map "=" #'vhdl-electric-equal)))
;; initialize mode map for VHDL Mode
(vhdl-mode-map-init)
@@ -2938,17 +2941,16 @@ STRING are replaced by `-' and substrings are converted to lower case."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(when vhdl-word-completion-in-minibuffer
- (define-key map "\t" 'vhdl-minibuffer-tab))
+ (define-key map "\t" #'vhdl-minibuffer-tab))
map)
"Keymap for minibuffer used in VHDL Mode.")
;; set up electric character functions to work with
;; `delete-selection-mode' (Emacs) and `pending-delete-mode' (XEmacs)
(mapc
- (function
- (lambda (sym)
- (put sym 'delete-selection t) ; for `delete-selection-mode' (Emacs)
- (put sym 'pending-delete t))) ; for `pending-delete-mode' (XEmacs)
+ (lambda (sym)
+ (put sym 'delete-selection t) ; for `delete-selection-mode' (Emacs)
+ (put sym 'pending-delete t)) ; for `pending-delete-mode' (XEmacs)
'(vhdl-electric-space
vhdl-electric-tab
vhdl-electric-return
@@ -3172,7 +3174,8 @@ STRING are replaced by `-' and substrings are converted to lower case."
(unless (equal keyword "")
(push (list keyword ""
(vhdl-function-name
- "vhdl-model" (nth 0 elem) "hook") 0 'system)
+ "vhdl-model" (nth 0 elem) "hook")
+ 0 'system)
abbrev-list)))
abbrev-list)))))
@@ -3321,7 +3324,7 @@ STRING are replaced by `-' and substrings are converted to lower case."
(setq menu-list
(if vhdl-project-sort
(sort menu-list
- (function (lambda (a b) (string< (elt a 0) (elt b 0)))))
+ (lambda (a b) (string< (elt a 0) (elt b 0))))
(nreverse menu-list)))
(vhdl-menu-split menu-list "Project"))
'("--" "--"
@@ -3579,7 +3582,7 @@ STRING are replaced by `-' and substrings are converted to lower case."
("Indent"
["Line" indent-according-to-mode :keys "C-c C-i C-l"]
["Group" vhdl-indent-group :keys "C-c C-i C-g"]
- ["Region" vhdl-indent-region (mark)]
+ ["Region" indent-region (mark)]
["Buffer" vhdl-indent-buffer :keys "C-c C-i C-b"])
("Align"
["Group" vhdl-align-group t]
@@ -4209,9 +4212,11 @@ STRING are replaced by `-' and substrings are converted to lower case."
(defun vhdl-update-mode-menu ()
"Update VHDL Mode menu."
(interactive)
- (easy-menu-remove vhdl-mode-menu-list) ; for XEmacs
+ (when (featurep 'xemacs)
+ (easy-menu-remove vhdl-mode-menu-list))
(setq vhdl-mode-menu-list (vhdl-create-mode-menu))
- (easy-menu-add vhdl-mode-menu-list) ; for XEmacs
+ (when (featurep 'xemacs)
+ (easy-menu-add vhdl-mode-menu-list))
(easy-menu-define vhdl-mode-menu vhdl-mode-map
"Menu keymap for VHDL Mode." vhdl-mode-menu-list))
@@ -4317,7 +4322,8 @@ The directory of the current source file is scanned."
(push ["*Rescan*" vhdl-add-source-files-menu t] menu-list)
(push "Sources" menu-list)
;; Create menu
- (easy-menu-add menu-list)
+ (when (featurep 'xemacs)
+ (easy-menu-add menu-list))
(easy-menu-define vhdl-sources-menu newmap
"VHDL source files menu" menu-list))
(message ""))
@@ -4886,7 +4892,7 @@ Key bindings:
(set (make-local-variable 'paragraph-separate) paragraph-start)
(set (make-local-variable 'paragraph-ignore-fill-prefix) t)
(set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'indent-line-function) 'vhdl-indent-line)
+ (set (make-local-variable 'indent-line-function) #'vhdl-indent-line)
(set (make-local-variable 'comment-start) "--")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'comment-column) vhdl-inline-comment-column)
@@ -4899,13 +4905,13 @@ Key bindings:
;; setup the comment indent variable in an Emacs version portable way
;; ignore any byte compiler warnings you might get here
(when (boundp 'comment-indent-function)
- (set (make-local-variable '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))
+ (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
@@ -4914,7 +4920,7 @@ Key bindings:
("\\('\\).\\('\\)" (1 "\"'") (2 "\"'"))))
(set (make-local-variable 'font-lock-syntactic-keywords)
vhdl-font-lock-syntactic-keywords))
- (unless vhdl-emacs-21
+ (when (featurep 'xemacs)
(set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode)
(set (make-local-variable 'lazy-lock-defer-contextually) nil)
(set (make-local-variable 'lazy-lock-defer-on-the-fly) t)
@@ -4930,7 +4936,8 @@ Key bindings:
;; add source file menu
(if vhdl-source-file-menu (vhdl-add-source-files-menu))
;; add VHDL menu
- (easy-menu-add vhdl-mode-menu-list) ; for XEmacs
+ (when (featurep 'xemacs)
+ (easy-menu-add vhdl-mode-menu-list))
(easy-menu-define vhdl-mode-menu vhdl-mode-map
"Menu keymap for VHDL Mode." vhdl-mode-menu-list)
;; initialize hideshow and add menu
@@ -4959,10 +4966,10 @@ Key bindings:
(defun vhdl-write-file-hooks-init ()
"Add/remove hooks when buffer is saved."
(if vhdl-modify-date-on-saving
- (add-hook 'write-file-functions 'vhdl-template-modify-noerror nil t)
- (remove-hook 'write-file-functions 'vhdl-template-modify-noerror t))
+ (add-hook 'write-file-functions #'vhdl-template-modify-noerror nil t)
+ (remove-hook 'write-file-functions #'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))
+ (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."
@@ -5340,9 +5347,6 @@ Key bindings:
(defvar vhdl-reserved-words-regexp nil
"Regexp for additional reserved words.")
-(defvar vhdl-directive-keywords-regexp nil
- "Regexp for compiler directive keywords.")
-
(defun vhdl-upcase-list (condition list)
"Upcase all elements in LIST based on CONDITION."
(when condition
@@ -5420,9 +5424,6 @@ Key bindings:
(concat vhdl-forbidden-syntax "\\|"))
(regexp-opt vhdl-reserved-words)
"\\)\\>"))
- (setq vhdl-directive-keywords-regexp
- (concat "\\<\\(" (mapconcat 'regexp-quote
- vhdl-directive-keywords "\\|") "\\)\\>"))
(vhdl-abbrev-list-init))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -5572,9 +5573,8 @@ offset for that syntactic element. Optional ADD-P says to add SYMBOL to
(if current-prefix-arg " or add" "")
": ")
(mapcar
- (function
- (lambda (langelem)
- (cons (format "%s" (car langelem)) nil)))
+ (lambda (langelem)
+ (cons (format "%s" (car langelem)) nil))
vhdl-offsets-alist)
nil (not current-prefix-arg)
;; initial contents tries to be the last element
@@ -5621,26 +5621,24 @@ argument. The styles are chosen from the `vhdl-style-alist' variable."
(error "ERROR: Invalid VHDL indentation style `%s'" style))
;; set all the variables
(mapc
- (function
- (lambda (varentry)
- (let ((var (car varentry))
- (val (cdr varentry)))
- ;; special case for vhdl-offsets-alist
- (if (not (eq var 'vhdl-offsets-alist))
- (set (if local (make-local-variable var) var) val)
- ;; reset vhdl-offsets-alist to the default value first
- (set (if local (make-local-variable var) var)
- (copy-alist vhdl-offsets-alist-default))
- ;; now set the langelems that are different
- (mapcar
- (function
- (lambda (langentry)
- (let ((langelem (car langentry))
- (offset (cdr langentry)))
- (vhdl-set-offset langelem offset)
- )))
- val))
- )))
+ (lambda (varentry)
+ (let ((var (car varentry))
+ (val (cdr varentry)))
+ ;; special case for vhdl-offsets-alist
+ (if (not (eq var 'vhdl-offsets-alist))
+ (set (if local (make-local-variable var) var) val)
+ ;; reset vhdl-offsets-alist to the default value first
+ (set (if local (make-local-variable var) var)
+ (copy-alist vhdl-offsets-alist-default))
+ ;; now set the langelems that are different
+ (mapcar
+ (lambda (langentry)
+ (let ((langelem (car langentry))
+ (offset (cdr langentry)))
+ (vhdl-set-offset langelem offset)
+ ))
+ val))
+ ))
vars))
(vhdl-keep-region-active))
@@ -5754,7 +5752,7 @@ negative, skip forward otherwise."
;; XEmacs hack: work around buggy `forward-comment' in XEmacs 21.4+
(unless (and (featurep 'xemacs) (string< "21.2" emacs-version))
- (defalias 'vhdl-forward-comment 'forward-comment))
+ (defalias 'vhdl-forward-comment #'forward-comment))
(defun vhdl-back-to-indentation ()
"Move point to the first non-whitespace character on this line."
@@ -5818,7 +5816,7 @@ negative, skip forward otherwise."
state)))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-in-literal 'vhdl-win-il))
+ (fset 'vhdl-in-literal #'vhdl-win-il))
;; Skipping of "syntactic whitespace". Syntactic whitespace is
;; defined as lexical whitespace or comments. Search no farther back
@@ -5856,9 +5854,9 @@ negative, skip forward otherwise."
(t (setq stop t))))))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-forward-syntactic-ws 'vhdl-win-fsws))
+ (fset 'vhdl-forward-syntactic-ws #'vhdl-win-fsws))
-(defun vhdl-beginning-of-macro (&optional lim)
+(defun vhdl-beginning-of-macro (&optional _lim)
"Go to the beginning of a cpp macro definition (nicked from `cc-engine')."
(let ((here (point)))
(beginning-of-line)
@@ -5871,7 +5869,7 @@ negative, skip forward otherwise."
(goto-char here)
nil)))
-(defun vhdl-beginning-of-directive (&optional lim)
+(defun vhdl-beginning-of-directive (&optional _lim)
"Go to the beginning of a directive (nicked from `cc-engine')."
(let ((here (point)))
(beginning-of-line)
@@ -5915,7 +5913,7 @@ negative, skip forward otherwise."
(t (setq stop t))))))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-backward-syntactic-ws 'vhdl-win-bsws))
+ (fset 'vhdl-backward-syntactic-ws #'vhdl-win-bsws))
;; Functions to help finding the correct indentation column:
@@ -6063,7 +6061,7 @@ keyword."
t)
))
-(defun vhdl-corresponding-mid (&optional lim)
+(defun vhdl-corresponding-mid (&optional _lim)
(cond
((looking-at "is\\|block\\|generate\\|process\\|procedural")
"begin")
@@ -6279,7 +6277,7 @@ of an identifier that just happens to contain an \"end\" keyword."
"A regular expression for searching backward that matches all known
\"statement\" keywords.")
-(defun vhdl-statement-p (&optional lim)
+(defun vhdl-statement-p (&optional _lim)
"Return t if we are looking at a real \"statement\" keyword.
Assumes that the caller will make sure that we are looking at
vhdl-statement-fwd-re, and are not inside a literal, and that we are not
@@ -6471,7 +6469,7 @@ searches."
;; internal-p controls where the statement keyword can
;; be found.
(internal-p (aref begin-vec 3))
- (last-backward (point)) last-forward
+ (last-backward (point)) ;; last-forward
foundp literal keyword)
;; Look for the statement keyword.
(while (and (not foundp)
@@ -6506,7 +6504,7 @@ searches."
(setq begin-re
(concat "\\b\\(" begin-re "\\)\\b[^_]"))
(save-excursion
- (setq last-forward (point))
+ ;; (setq last-forward (point))
;; Look for the supplementary keyword
;; (bounded by the backward search start
;; point).
@@ -6558,7 +6556,7 @@ With argument, do this that many times."
(setq target (point)))
(goto-char target)))
-(defun vhdl-end-of-defun (&optional count)
+(defun vhdl-end-of-defun (&optional _count)
"Move forward to the end of a VHDL defun."
(interactive)
(let ((case-fold-search t))
@@ -7330,7 +7328,7 @@ after the containing paren which starts the arglist."
(current-column))))
(- ce-curcol cs-curcol -1))))
-(defun vhdl-lineup-comment (langelem)
+(defun vhdl-lineup-comment (_langelem)
"Support old behavior for comment indentation. We look at
vhdl-comment-only-line-offset to decide how to indent comment
only-lines."
@@ -7392,27 +7390,13 @@ only-lines."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Progress reporting
-(defvar vhdl-progress-info nil
- "Array variable for progress information: 0 begin, 1 end, 2 time.")
-
-(defun vhdl-update-progress-info (string pos)
- "Update progress information."
- (when (and vhdl-progress-info (not noninteractive)
- (time-less-p vhdl-progress-interval
- (time-since (aref vhdl-progress-info 2))))
- (let ((delta (- (aref vhdl-progress-info 1)
- (aref vhdl-progress-info 0))))
- (message "%s... (%2d%%)" string
- (if (= 0 delta)
- 100
- (floor (* 100.0 (- pos (aref vhdl-progress-info 0)))
- delta))))
- (aset vhdl-progress-info 2 (time-convert nil 'integer))))
+(defvar vhdl--progress-reporter nil
+ "Holds the progress reporter data during long running operations.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Indentation commands
-(defun vhdl-electric-tab (&optional prefix-arg)
+(defun vhdl-electric-tab (&optional arg)
"If preceding character is part of a word or a paren then hippie-expand,
else if right of non whitespace on line then insert tab,
else if last command was a tab or return then dedent one step or if a comment
@@ -7423,7 +7407,7 @@ else indent `correctly'."
(cond
;; indent region if region is active
((and (not (featurep 'xemacs)) (use-region-p))
- (vhdl-indent-region (region-beginning) (region-end) nil))
+ (indent-region (region-beginning) (region-end) nil))
;; expand word
((= (char-syntax (preceding-char)) ?w)
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
@@ -7432,12 +7416,12 @@ else indent `correctly'."
(or (and (boundp 'hippie-expand-only-buffers)
hippie-expand-only-buffers)
'(vhdl-mode))))
- (vhdl-expand-abbrev prefix-arg)))
+ (vhdl-expand-abbrev arg)))
;; expand parenthesis
((or (= (preceding-char) ?\() (= (preceding-char) ?\)))
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
(case-replace nil))
- (vhdl-expand-paren prefix-arg)))
+ (vhdl-expand-paren arg)))
;; insert tab
((> (current-column) (current-indentation))
(insert-tab))
@@ -7496,7 +7480,7 @@ indentation change."
(setq syntax (vhdl-get-syntactic-context)))))
(when is-comment
(push (cons 'comment nil) syntax))
- (apply '+ (mapcar 'vhdl-get-offset syntax)))
+ (apply #'+ (mapcar #'vhdl-get-offset syntax)))
;; indent like previous nonblank line
(save-excursion (beginning-of-line)
(re-search-backward "^[^\n]" nil t)
@@ -7518,25 +7502,17 @@ indentation change."
(when (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))
(run-hooks 'vhdl-special-indent-hook)
- (vhdl-update-progress-info "Indenting" (vhdl-current-line))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))
shift-amt))
-(defun vhdl-indent-region (beg end &optional column)
- "Indent region as VHDL code.
-Adds progress reporting to `indent-region'."
- (interactive "r\nP")
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0)))
- (indent-region beg end column)
- (when vhdl-progress-interval (message "Indenting...done"))
- (setq vhdl-progress-info nil))
+(define-obsolete-function-alias 'vhdl-indent-region #'indent-region "28.1")
(defun vhdl-indent-buffer ()
"Indent whole buffer as VHDL code.
Calls `indent-region' for whole buffer and adds progress reporting."
(interactive)
- (vhdl-indent-region (point-min) (point-max)))
+ (indent-region (point-min) (point-max)))
(defun vhdl-indent-group ()
"Indent group of lines between empty lines."
@@ -7549,7 +7525,7 @@ Calls `indent-region' for whole buffer and adds progress reporting."
(if (re-search-forward vhdl-align-group-separate nil t)
(point-marker)
(point-max-marker)))))
- (vhdl-indent-region beg end)))
+ (indent-region beg end)))
(defun vhdl-indent-sexp (&optional endpos)
"Indent each line of the list starting just after point.
@@ -7584,12 +7560,11 @@ ENDPOS is encountered."
(expurgated))
;; remove the library unit symbols
(mapc
- (function
- (lambda (elt)
- (if (memq (car elt) '(entity configuration context package
- package-body architecture))
- nil
- (setq expurgated (append expurgated (list elt))))))
+ (lambda (elt)
+ (if (memq (car elt) '(entity configuration context package
+ package-body architecture))
+ nil
+ (setq expurgated (append expurgated (list elt)))))
actual)
(if (and (not arg) expected (listp expected))
(if (not (equal expected expurgated))
@@ -7709,7 +7684,7 @@ parentheses."
;; run FUNCTION
(funcall function beg end spacing)))
-(defun vhdl-align-region-1 (begin end &optional spacing alignment-list indent)
+(defun vhdl-align-region-1 (begin end &optional spacing alignment-list _indent)
"Attempt to align a range of lines based on the content of the
lines. The definition of `alignment-list' determines the matching
order and the manner in which the lines are aligned. If ALIGNMENT-LIST
@@ -7719,12 +7694,15 @@ indentation is done before aligning."
(setq alignment-list (or alignment-list vhdl-align-alist))
(setq spacing (or spacing 1))
(save-excursion
- (let (bol indent)
+ (let (bol) ;; indent
(goto-char end)
(setq end (point-marker))
(goto-char begin)
(setq bol (setq begin (progn (beginning-of-line) (point))))
- (when indent
+ ;; FIXME: The `indent' arg is not used, and I think it's because
+ ;; the let binding commented out above `indent' was hiding it, so
+ ;; the test below should maybe still test `indent'?
+ (when nil ;; indent
(indent-region bol end nil))))
(let ((copy (copy-alist alignment-list)))
(vhdl-prepare-search-2
@@ -7809,18 +7787,21 @@ the token in MATCH."
"Align region, treat groups of lines separately."
(interactive "r\nP")
(save-excursion
- (let (orig pos)
- (goto-char beg)
- (beginning-of-line)
- (setq orig (point-marker))
- (setq beg (point))
- (goto-char end)
- (setq end (point-marker))
- (untabify beg end)
- (unless no-message
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0))))
+ (goto-char beg)
+ (beginning-of-line)
+ (setq beg (point))
+ (goto-char end)
+ (setq end (point-marker))
+ (untabify beg end)
+ (let ((orig (copy-marker beg))
+ pos
+ (vhdl--progress-reporter
+ (if no-message
+ ;; Preserve a potential progress reporter from
+ ;; when called from `vhdl-align-region' call.
+ vhdl--progress-reporter
+ (when vhdl-progress-interval
+ (make-progress-reporter "Aligning..." beg (copy-marker end))))))
(when (nth 0 vhdl-beautify-options)
(vhdl-fixup-whitespace-region beg end t))
(goto-char beg)
@@ -7835,19 +7816,21 @@ the token in MATCH."
(setq pos (point-marker))
(vhdl-align-region-1 beg pos spacing)
(unless no-comments (vhdl-align-inline-comment-region-1 beg pos))
- (vhdl-update-progress-info "Aligning" (vhdl-current-line))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))
(setq beg (1+ pos))
(goto-char beg))
;; align last group
(when (< beg end)
(vhdl-align-region-1 beg end spacing)
(unless no-comments (vhdl-align-inline-comment-region-1 beg end))
- (vhdl-update-progress-info "Aligning" (vhdl-current-line))))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))))
(when vhdl-indent-tabs-mode
(tabify orig end))
(unless no-message
- (when vhdl-progress-interval (message "Aligning...done"))
- (setq vhdl-progress-info nil)))))
+ (when vhdl--progress-reporter
+ (progress-reporter-done vhdl--progress-reporter))))))
(defun vhdl-align-region (beg end &optional spacing)
"Align region, treat blocks with same indent and argument lists separately."
@@ -7858,10 +7841,10 @@ the token in MATCH."
;; align blocks with same indent and argument lists
(save-excursion
(let ((cur-beg beg)
- indent cur-end)
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0)))
+ indent cur-end
+ (vhdl--progress-reporter
+ (when vhdl-progress-interval
+ (make-progress-reporter "Aligning..." beg (copy-marker end)))))
(goto-char end)
(setq end (point-marker))
(goto-char cur-beg)
@@ -7884,15 +7867,16 @@ the token in MATCH."
(= (current-indentation) indent))
(<= (save-excursion
(nth 0 (parse-partial-sexp
- (point) (vhdl-point 'eol)))) 0))
+ (point) (vhdl-point 'eol))))
+ 0))
(unless (looking-at "^\\s-*$")
(setq cur-end (vhdl-point 'bonl)))
(beginning-of-line 2)))
;; align region
(vhdl-align-region-groups cur-beg cur-end spacing t t))
(vhdl-align-inline-comment-region beg end spacing noninteractive)
- (when vhdl-progress-interval (message "Aligning...done"))
- (setq vhdl-progress-info nil)))))
+ (when vhdl--progress-reporter
+ (progress-reporter-done vhdl--progress-reporter))))))
(defun vhdl-align-group (&optional spacing)
"Align group of lines between empty lines."
@@ -7956,7 +7940,7 @@ the token in MATCH."
(push (cons start length) comment-list))
(beginning-of-line 2))
(setq comment-list
- (sort comment-list (function (lambda (a b) (> (car a) (car b))))))
+ (sort comment-list (lambda (a b) (> (car a) (car b)))))
;; reduce start positions
(setq start-list (list (caar comment-list)))
(setq comment-list (cdr comment-list))
@@ -8041,7 +8025,7 @@ empty lines are aligned individually, if `vhdl-align-groups' is non-nil."
(tabify orig end))
(unless no-message (message "Aligning inline comments...done")))))
-(defun vhdl-align-inline-comment-group (&optional spacing)
+(defun vhdl-align-inline-comment-group (&optional _spacing)
"Align inline comments within a group of lines between empty lines."
(interactive)
(save-excursion
@@ -8136,7 +8120,8 @@ end of line, do nothing in comments."
"Convert all words matching WORD-REGEXP in region to lower or upper case,
depending on parameter UPPER-CASE."
(let ((case-replace nil)
- (last-update 0))
+ (pr (when (and count vhdl-progress-interval (not noninteractive))
+ (make-progress-reporter "Fixing case..." beg (copy-marker end)))))
(vhdl-prepare-search-2
(save-excursion
(goto-char end)
@@ -8147,19 +8132,13 @@ depending on parameter UPPER-CASE."
(if upper-case
(upcase-word -1)
(downcase-word -1)))
- (when (and count vhdl-progress-interval (not noninteractive)
- (time-less-p vhdl-progress-interval
- (time-since last-update)))
- (message "Fixing case... (%2d%s)"
- (+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg)))
- "%")
- (setq last-update (time-convert nil 'integer))))
- (goto-char end)))))
-
-(defun vhdl-fix-case-region (beg end &optional arg)
+ (when pr (progress-reporter-update pr (point))))
+ (when pr (progress-reporter-done pr))))))
+
+(defun vhdl-fix-case-region (beg end &optional _arg)
"Convert all VHDL words in region to lower or upper case, depending on
options vhdl-upper-case-{keywords,types,attributes,enum-values}."
- (interactive "r\nP")
+ (interactive "r")
(vhdl-fix-case-region-1
beg end vhdl-upper-case-keywords vhdl-keywords-regexp 0)
(vhdl-fix-case-region-1
@@ -8205,11 +8184,11 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}."
;; - force each statement to be on a separate line except when on same line
;; with 'end' keyword
-(defun vhdl-fix-statement-region (beg end &optional arg)
+(defun vhdl-fix-statement-region (beg end &optional _arg)
"Force statements in region on separate line except when on same line
with `end' keyword (necessary for correct indentation).
Currently supported keywords: `begin', `if'."
- (interactive "r\nP")
+ (interactive "r")
(vhdl-prepare-search-2
(let (point)
(save-excursion
@@ -8261,9 +8240,9 @@ with `end' keyword (necessary for correct indentation)."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Trailing spaces
-(defun vhdl-remove-trailing-spaces-region (beg end &optional arg)
+(defun vhdl-remove-trailing-spaces-region (beg end &optional _arg)
"Remove trailing spaces in region."
- (interactive "r\nP")
+ (interactive "r")
(save-excursion
(goto-char end)
(setq end (point-marker))
@@ -8293,7 +8272,7 @@ case fixing to a region. Calls functions `vhdl-indent-buffer',
(replace-match "" nil t)))
(when (nth 0 vhdl-beautify-options) (vhdl-fixup-whitespace-region beg end t))
(when (nth 1 vhdl-beautify-options) (vhdl-fix-statement-region beg end))
- (when (nth 2 vhdl-beautify-options) (vhdl-indent-region beg end))
+ (when (nth 2 vhdl-beautify-options) (indent-region beg end))
(when (nth 3 vhdl-beautify-options)
(let ((vhdl-align-groups t)) (vhdl-align-region beg end)))
(when (nth 4 vhdl-beautify-options) (vhdl-fix-case-region beg end))
@@ -8526,7 +8505,7 @@ buffer."
(delete-region sens-beg sens-end)
(when read-list
(insert " ()") (backward-char)))
- (setq read-list (sort read-list 'string<))
+ (setq read-list (sort read-list #'string<))
(when read-list
(setq margin (current-column))
(insert (car read-list))
@@ -8558,7 +8537,7 @@ buffer."
(concat (vhdl-replace-string vhdl-entity-file-name entity-name t)
"." (file-name-extension (buffer-file-name)))))
(vhdl-visit-file
- file-name t
+ file-name t
(vhdl-prepare-search-2
(goto-char (point-min))
(if (not (re-search-forward (concat "^entity\\s-+" entity-name "\\>") nil t))
@@ -8566,7 +8545,8 @@ buffer."
(when (setq beg (vhdl-re-search-forward
"\\<port[ \t\n\r\f]*("
(save-excursion
- (re-search-forward "^end\\>" nil t)) t))
+ (re-search-forward "^end\\>" nil t))
+ t))
(setq end (save-excursion
(backward-char) (forward-sexp) (point)))
(vhdl-forward-syntactic-ws)
@@ -8698,9 +8678,9 @@ buffer."
Used for undoing after template abortion.")
;; correct different behavior of function `unread-command-events' in XEmacs
-(defun vhdl-character-to-event (arg))
+(defun vhdl-character-to-event (_arg) nil)
(defalias 'vhdl-character-to-event
- (if (fboundp 'character-to-event) 'character-to-event 'identity))
+ (if (fboundp 'character-to-event) #'character-to-event #'identity))
(defun vhdl-work-library ()
"Return the working library name of the current project or \"work\" if no
@@ -9157,7 +9137,8 @@ a configuration declaration if not within a design unit."
(re-search-backward "^\\(configuration\\|end\\)\\>" nil t))
(equal "CONFIGURATION" (upcase (match-string 1))))
(if (eq (vhdl-decision-query
- "configuration" "(b)lock or (c)omponent configuration?" t) ?c)
+ "configuration" "(b)lock or (c)omponent configuration?" t)
+ ?c)
(vhdl-template-component-conf)
(vhdl-template-block-configuration)))
(t (vhdl-template-configuration-decl))))) ; otherwise
@@ -9266,7 +9247,7 @@ a configuration declaration if not within a design unit."
(interactive)
(let ((margin (current-indentation))
(start (point))
- entity-exists string name position)
+ name position) ;; entity-exists string
(vhdl-insert-keyword "CONTEXT ")
(when (setq name (vhdl-template-field "name" nil t start (point)))
(vhdl-insert-keyword " IS\n")
@@ -9422,7 +9403,8 @@ otherwise."
(re-search-backward "^\\(configuration\\|end\\)\\>" nil t))
(equal "CONFIGURATION" (upcase (match-string 1))))
(if (eq (vhdl-decision-query
- "for" "(b)lock or (c)omponent configuration?" t) ?c)
+ "for" "(b)lock or (c)omponent configuration?" t)
+ ?c)
(vhdl-template-component-conf)
(vhdl-template-block-configuration)))
((and (save-excursion
@@ -9537,11 +9519,12 @@ otherwise."
(defun vhdl-template-group ()
"Insert group or group template declaration."
(interactive)
- (let ((start (point)))
- (if (eq (vhdl-decision-query
- "group" "(d)eclaration or (t)emplate declaration?" t) ?t)
- (vhdl-template-group-template)
- (vhdl-template-group-decl))))
+ ;; (let ((start (point)))
+ (if (eq (vhdl-decision-query
+ "group" "(d)eclaration or (t)emplate declaration?" t)
+ ?t)
+ (vhdl-template-group-template)
+ (vhdl-template-group-decl))) ;; )
(defun vhdl-template-group-decl ()
"Insert group declaration."
@@ -10482,7 +10465,8 @@ specification, if not already there."
(and (not (bobp))
(re-search-backward
(concat "^\\s-*\\(\\(library\\)\\s-+\\(\\w+\\s-*,\\s-*\\)*"
- library "\\|end\\)\\>") nil t)
+ library "\\|end\\)\\>")
+ nil t)
(match-string 2))))
(equal (downcase library) "work"))
(vhdl-insert-keyword "LIBRARY ")
@@ -10842,9 +10826,9 @@ If starting after end-comment-column, start a new line."
(vhdl-line-kill-entire)))))
(goto-char final-pos))))
-(defun vhdl-comment-uncomment-region (beg end &optional arg)
+(defun vhdl-comment-uncomment-region (beg end &optional _arg)
"Comment out region if not commented out, uncomment otherwise."
- (interactive "r\nP")
+ (interactive "r")
(save-excursion
(goto-char (1- end))
(end-of-line)
@@ -10921,7 +10905,7 @@ Point is left between them."
"Read from user a procedure or function argument list."
(insert " (")
(let ((margin (current-column))
- (start (point))
+ ;; (start (point))
(end-pos (point))
not-empty interface semicolon-pos)
(unless vhdl-argument-list-indent
@@ -10930,7 +10914,8 @@ Point is left between them."
(indent-to margin))
(setq interface (vhdl-template-field
(concat "[CONSTANT | SIGNAL"
- (unless is-function " | VARIABLE") "]") " " t))
+ (unless is-function " | VARIABLE") "]")
+ " " t))
(while (vhdl-template-field "[names]" nil t)
(setq not-empty t)
(insert " : ")
@@ -10947,7 +10932,8 @@ Point is left between them."
(indent-to margin)
(setq interface (vhdl-template-field
(concat "[CONSTANT | SIGNAL"
- (unless is-function " | VARIABLE") "]") " " t)))
+ (unless is-function " | VARIABLE") "]")
+ " " t)))
(delete-region end-pos (point))
(when semicolon-pos (goto-char semicolon-pos))
(if not-empty
@@ -11167,7 +11153,7 @@ with double-quotes is to be inserted. DEFAULT specifies a default string."
"Adjust case of following NUM words."
(if vhdl-upper-case-keywords (upcase-word num) (downcase-word num)))
-(defun vhdl-minibuffer-tab (&optional prefix-arg)
+(defun vhdl-minibuffer-tab (&optional arg)
"If preceding character is part of a word or a paren then hippie-expand,
else insert tab (used for word completion in VHDL minibuffer)."
(interactive "P")
@@ -11180,12 +11166,12 @@ else insert tab (used for word completion in VHDL minibuffer)."
(or (and (boundp 'hippie-expand-only-buffers)
hippie-expand-only-buffers)
'(vhdl-mode))))
- (vhdl-expand-abbrev prefix-arg)))
+ (vhdl-expand-abbrev arg)))
;; expand parenthesis
((or (= (preceding-char) ?\() (= (preceding-char) ?\)))
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
(case-replace nil))
- (vhdl-expand-paren prefix-arg)))
+ (vhdl-expand-paren arg)))
;; insert tab
(t (insert-tab))))
@@ -11572,7 +11558,8 @@ but not if inside a comment or quote."
(unless (equal model-keyword "")
(eval `(defun
,(vhdl-function-name
- "vhdl-model" model-name "hook") ()
+ "vhdl-model" model-name "hook")
+ ()
(vhdl-hooked-abbrev
',(vhdl-function-name "vhdl-model" model-name)))))
(setq model-alist (cdr model-alist)))))
@@ -11868,7 +11855,7 @@ reflected in a subsequent paste operation."
(defun vhdl-port-paste-context-clause (&optional exclude-pack-name)
"Paste a context clause."
- (let ((margin (current-indentation))
+ (let (;; (margin (current-indentation))
(clause-list (nth 3 vhdl-port-list))
clause)
(while clause-list
@@ -11878,7 +11865,8 @@ reflected in a subsequent paste operation."
(save-excursion
(re-search-backward
(concat "^\\s-*use\\s-+" (car clause)
- "." (cdr clause) "\\>") nil t)))
+ "." (cdr clause) "\\>")
+ nil t)))
(vhdl-template-standard-package (car clause) (cdr clause))
(insert "\n"))
(setq clause-list (cdr clause-list)))))
@@ -12270,7 +12258,8 @@ reflected in a subsequent paste operation."
(cond ((and vhdl-include-direction-comments (nth 2 port))
(format "%-6s" (concat "[" (nth 2 port) "] ")))
(vhdl-include-direction-comments " "))
- (when vhdl-include-port-comments (nth 4 port))) t))
+ (when vhdl-include-port-comments (nth 4 port)))
+ t))
(setq port-list (cdr port-list))
(when port-list (insert "\n") (indent-to margin)))
;; align signal list
@@ -12324,7 +12313,7 @@ reflected in a subsequent paste operation."
(let ((case-fold-search t)
(ent-name (vhdl-replace-string vhdl-testbench-entity-name
(nth 0 vhdl-port-list)))
- (source-buffer (current-buffer))
+ ;; (source-buffer (current-buffer))
arch-name config-name ent-file-name arch-file-name
ent-buffer arch-buffer position)
;; open entity file
@@ -12421,7 +12410,7 @@ reflected in a subsequent paste operation."
(insert "\n")
(setq position (point))
(vhdl-insert-string-or-file vhdl-testbench-declarations)
- (vhdl-indent-region position (point)))
+ (indent-region position (point)))
(setq position (point))
(insert "\n\n")
(vhdl-comment-display-line) (insert "\n")
@@ -12452,7 +12441,7 @@ reflected in a subsequent paste operation."
(insert "\n")
(setq position (point))
(vhdl-insert-string-or-file vhdl-testbench-statements)
- (vhdl-indent-region position (point)))
+ (indent-region position (point)))
(insert "\n")
(indent-to vhdl-basic-offset)
(unless (eq vhdl-testbench-create-files 'none)
@@ -12825,7 +12814,7 @@ expressions (e.g. for index ranges of types and signals)."
;; override `he-list-beg' from `hippie-exp'
(unless (and (boundp 'viper-mode) viper-mode)
- (defalias 'he-list-beg 'vhdl-he-list-beg))
+ (defalias 'he-list-beg #'vhdl-he-list-beg))
;; function for expanding abbrevs and dabbrevs
(defalias 'vhdl-expand-abbrev (make-hippie-expand-function
@@ -12872,14 +12861,14 @@ expressions (e.g. for index ranges of types and signals)."
(beginning-of-line)
(yank))
-(defun vhdl-line-expand (&optional prefix-arg)
+(defun vhdl-line-expand (&optional arg)
"Hippie-expand current line."
(interactive "P")
(require 'hippie-exp)
(let ((case-fold-search t) (case-replace nil)
(hippie-expand-try-functions-list
'(try-expand-line try-expand-line-all-buffers)))
- (hippie-expand prefix-arg)))
+ (hippie-expand arg)))
(defun vhdl-line-transpose-next (&optional arg)
"Interchange this line with next line."
@@ -13001,7 +12990,7 @@ File statistics: \"%s\"\n\
# total lines : %5d\n"
(buffer-file-name) no-stats no-code-lines no-empty-lines
no-comm-lines no-comments no-lines)
- (unless vhdl-emacs-21 (vhdl-show-messages))))
+ (when (featurep 'xemacs) (vhdl-show-messages))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Help functions
@@ -13050,7 +13039,7 @@ File statistics: \"%s\"\n\
(customize-set-variable 'vhdl-project vhdl-project)
(customize-save-customized))
-(defun vhdl-toggle-project (name token indent)
+(defun vhdl-toggle-project (name _token _indent)
"Set current project to NAME or unset if NAME is current project."
(vhdl-set-project (if (equal name vhdl-project) "" name)))
@@ -13254,6 +13243,7 @@ File statistics: \"%s\"\n\
"Toggle hideshow minor mode and update menu bar."
(interactive "P")
(require 'hideshow)
+ (declare-function hs-hide-all "hideshow" ())
;; check for hideshow version 5.x
(if (not (boundp 'hs-block-start-mdata-select))
(vhdl-warning-when-idle "Install included `hideshow.el' patch first (see INSTALL file)")
@@ -13265,8 +13255,8 @@ File statistics: \"%s\"\n\
hs-special-modes-alist)))
(if (featurep 'xemacs) (make-local-hook 'hs-minor-mode-hook))
(if vhdl-hide-all-init
- (add-hook 'hs-minor-mode-hook 'hs-hide-all nil t)
- (remove-hook 'hs-minor-mode-hook 'hs-hide-all t))
+ (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)
(force-mode-line-update))) ; hack to update menu bar
@@ -13533,6 +13523,8 @@ This does background highlighting of translate-off regions.")
(while syntax-alist
(setq name (vhdl-function-name
"vhdl-font-lock" (nth 0 (car syntax-alist)) "face"))
+ ;; FIXME: This `defvar' shouldn't be needed: just quote the face
+ ;; name when you use it.
(eval `(defvar ,name ',name
,(concat "Face name to use for "
(nth 0 (car syntax-alist)) ".")))
@@ -13635,7 +13627,10 @@ This does background highlighting of translate-off regions.")
vhdl-template-prompt-syntax ">\\)")
2 'vhdl-font-lock-prompt-face t)
(list (concat "--\\s-*"
- vhdl-directive-keywords-regexp "\\s-+\\(.*\\)$")
+ "\\<"
+ (regexp-opt vhdl-directive-keywords t)
+ "\\>"
+ "\\s-+\\(.*\\)$")
2 'vhdl-font-lock-directive-face t)
;; highlight c-preprocessor directives
(list "^#[ \t]*\\(\\w+\\)\\([ \t]+\\(\\w+\\)\\)?"
@@ -13742,7 +13737,7 @@ This does background highlighting of translate-off regions.")
(when (boundp 'ps-print-color-p)
(vhdl-ps-print-settings))
(if (featurep 'xemacs) (make-local-hook 'ps-print-hook))
- (add-hook 'ps-print-hook 'vhdl-ps-print-settings nil t)))
+ (add-hook 'ps-print-hook #'vhdl-ps-print-settings nil t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -13914,7 +13909,7 @@ hierarchy otherwise.")
pack-list pack-body-list inst-list inst-ent-list)
;; scan file
(vhdl-visit-file
- file-name nil
+ file-name nil
(vhdl-prepare-search-2
(save-excursion
;; scan for design units
@@ -14089,7 +14084,8 @@ hierarchy otherwise.")
"component[ \t\n\r\f]+\\(\\w+\\)\\|"
"\\(\\(entity\\)\\|configuration\\)[ \t\n\r\f]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n\r\f]*(\\(\\w+\\))\\)?\\|"
"\\(\\(for\\|if\\)\\>[^;:]+\\<generate\\>\\|block\\>\\)\\)\\|"
- "\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)") end-of-unit t)
+ "\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)")
+ end-of-unit t)
(or (not limit-hier-inst-no)
(<= (if (or (match-string 14)
(match-string 16))
@@ -14451,12 +14447,15 @@ of PROJECT."
;; (inst-key inst-file-marker comp-ent-key comp-ent-file-marker
;; comp-arch-key comp-arch-file-marker comp-conf-key comp-conf-file-marker
;; comp-lib-name level)
-(defun vhdl-get-hierarchy (ent-alist conf-alist ent-key arch-key conf-key
- conf-inst-alist level indent
- &optional include-top ent-hier)
+(defun vhdl-get-hierarchy ( ent-alist-arg conf-alist-arg ent-key arch-key
+ conf-key-arg conf-inst-alist level indent
+ &optional include-top ent-hier)
"Get instantiation hierarchy beginning in architecture ARCH-KEY of
entity ENT-KEY."
- (let* ((ent-entry (vhdl-aget ent-alist ent-key))
+ (let* ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ (conf-key conf-key-arg)
+ (ent-entry (vhdl-aget ent-alist ent-key))
(arch-entry (if arch-key (vhdl-aget (nth 3 ent-entry) arch-key)
(cdar (last (nth 3 ent-entry)))))
(inst-alist (nth 3 arch-entry))
@@ -14588,6 +14587,8 @@ entity ENT-KEY."
(error (progn (vhdl-warning "ERROR: An error occurred while saving the hierarchy caches")
(sit-for 2)))))
+(defvar vhdl-cache-version)
+
(defun vhdl-save-cache (key)
"Save current hierarchy cache to file."
(let* ((orig-buffer (current-buffer))
@@ -14674,7 +14675,7 @@ entity ENT-KEY."
(file-dir-name (expand-file-name file-name directory))
vhdl-cache-version)
(unless (memq 'vhdl-save-caches kill-emacs-hook)
- (add-hook 'kill-emacs-hook 'vhdl-save-caches))
+ (add-hook 'kill-emacs-hook #'vhdl-save-caches))
(when (file-exists-p file-dir-name)
(condition-case ()
(progn (load-file file-dir-name)
@@ -14714,6 +14715,8 @@ if required."
(declare-function speedbar-change-initial-expansion-list "speedbar"
(new-default))
(declare-function speedbar-add-expansion-list "speedbar" (new-list))
+(declare-function speedbar-expand-line "speedbar" (&optional arg))
+(declare-function speedbar-edit-line "speedbar" ())
(defun vhdl-speedbar-initialize ()
"Initialize speedbar."
@@ -14738,19 +14741,19 @@ if required."
;; keymap
(unless vhdl-speedbar-mode-map
(setq vhdl-speedbar-mode-map (speedbar-make-specialized-keymap))
- (define-key vhdl-speedbar-mode-map "e" 'speedbar-edit-line)
- (define-key vhdl-speedbar-mode-map "\C-m" 'speedbar-edit-line)
- (define-key vhdl-speedbar-mode-map "+" 'speedbar-expand-line)
- (define-key vhdl-speedbar-mode-map "=" 'speedbar-expand-line)
- (define-key vhdl-speedbar-mode-map "-" 'vhdl-speedbar-contract-level)
- (define-key vhdl-speedbar-mode-map "_" 'vhdl-speedbar-contract-all)
- (define-key vhdl-speedbar-mode-map "C" 'vhdl-speedbar-port-copy)
- (define-key vhdl-speedbar-mode-map "P" 'vhdl-speedbar-place-component)
- (define-key vhdl-speedbar-mode-map "F" 'vhdl-speedbar-configuration)
- (define-key vhdl-speedbar-mode-map "A" 'vhdl-speedbar-select-mra)
- (define-key vhdl-speedbar-mode-map "K" 'vhdl-speedbar-make-design)
- (define-key vhdl-speedbar-mode-map "R" 'vhdl-speedbar-rescan-hierarchy)
- (define-key vhdl-speedbar-mode-map "S" 'vhdl-save-caches)
+ (define-key vhdl-speedbar-mode-map "e" #'speedbar-edit-line)
+ (define-key vhdl-speedbar-mode-map "\C-m" #'speedbar-edit-line)
+ (define-key vhdl-speedbar-mode-map "+" #'speedbar-expand-line)
+ (define-key vhdl-speedbar-mode-map "=" #'speedbar-expand-line)
+ (define-key vhdl-speedbar-mode-map "-" #'vhdl-speedbar-contract-level)
+ (define-key vhdl-speedbar-mode-map "_" #'vhdl-speedbar-contract-all)
+ (define-key vhdl-speedbar-mode-map "C" #'vhdl-speedbar-port-copy)
+ (define-key vhdl-speedbar-mode-map "P" #'vhdl-speedbar-place-component)
+ (define-key vhdl-speedbar-mode-map "F" #'vhdl-speedbar-configuration)
+ (define-key vhdl-speedbar-mode-map "A" #'vhdl-speedbar-select-mra)
+ (define-key vhdl-speedbar-mode-map "K" #'vhdl-speedbar-make-design)
+ (define-key vhdl-speedbar-mode-map "R" #'vhdl-speedbar-rescan-hierarchy)
+ (define-key vhdl-speedbar-mode-map "S" #'vhdl-save-caches)
(let ((key 0))
(while (<= key 9)
(define-key vhdl-speedbar-mode-map (int-to-string key)
@@ -14821,7 +14824,7 @@ if required."
(setq speedbar-initial-expansion-list-name "vhdl directory"))
(when (eq vhdl-speedbar-display-mode 'project)
(setq speedbar-initial-expansion-list-name "vhdl project"))
- (add-hook 'speedbar-timer-hook 'vhdl-update-hierarchy)))
+ (add-hook 'speedbar-timer-hook #'vhdl-update-hierarchy)))
(defun vhdl-speedbar (&optional arg)
"Open/close speedbar."
@@ -14839,17 +14842,17 @@ if required."
"Name of last selected project.")
;; macros must be defined in the file they are used (copied from `speedbar.el')
-;;; (defmacro speedbar-with-writable (&rest forms)
-;;; "Allow the buffer to be writable and evaluate FORMS."
-;;; (list 'let '((inhibit-read-only t))
-;;; (cons 'progn forms)))
-;;; (put 'speedbar-with-writable 'lisp-indent-function 0)
+;; (defmacro speedbar-with-writable (&rest forms)
+;; "Allow the buffer to be writable and evaluate FORMS."
+;; (declare (indent 0) (debug t))
+;; (list 'let '((inhibit-read-only t))
+;; (cons 'progn forms)))
(declare-function speedbar-extension-list-to-regex "speedbar" (extlist))
(declare-function speedbar-directory-buttons "speedbar" (directory _index))
(declare-function speedbar-file-lists "speedbar" (directory))
-(defun vhdl-speedbar-display-directory (directory depth &optional rescan)
+(defun vhdl-speedbar-display-directory (directory depth &optional _rescan)
"Display directory and hierarchy information in speedbar."
(setq vhdl-speedbar-show-projects nil)
(setq speedbar-ignored-directory-regexp
@@ -14870,7 +14873,7 @@ if required."
(when (= depth 0) (vhdl-speedbar-expand-dirs directory)))
(error (vhdl-warning-when-idle "ERROR: Invalid hierarchy information, unable to display correctly")))))
-(defun vhdl-speedbar-display-projects (project depth &optional rescan)
+(defun vhdl-speedbar-display-projects (_project _depth &optional _rescan)
"Display projects and hierarchy information in speedbar."
(setq vhdl-speedbar-show-projects t)
(setq speedbar-ignored-directory-regexp ".")
@@ -14886,6 +14889,8 @@ if required."
(declare-function speedbar-make-tag-line "speedbar"
(type char func data tag tfunc tdata tface depth))
+(defvar vhdl-speedbar-update-current-unit)
+
(defun vhdl-speedbar-insert-projects ()
"Insert all projects in speedbar."
(vhdl-speedbar-make-title-line "Projects:")
@@ -14896,9 +14901,9 @@ if required."
;; insert projects
(while project-alist
(speedbar-make-tag-line
- 'angle ?+ 'vhdl-speedbar-expand-project
+ 'angle ?+ #'vhdl-speedbar-expand-project
(caar project-alist) (caar project-alist)
- 'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0)
+ #'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0)
(setq project-alist (cdr project-alist)))
(setq project-alist vhdl-project-alist)
;; expand projects
@@ -14945,12 +14950,14 @@ otherwise use cached data."
(vhdl-speedbar-expand-units directory)
(vhdl-aput 'vhdl-directory-alist directory (list (list directory))))
-(defun vhdl-speedbar-insert-hierarchy (ent-alist conf-alist pack-alist
- ent-inst-list depth)
+(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg pack-alist
+ ent-inst-list depth)
"Insert hierarchy of ENT-ALIST, CONF-ALIST, and PACK-ALIST."
(if (not (or ent-alist conf-alist pack-alist))
(vhdl-speedbar-make-title-line "No VHDL design units!" depth)
- (let (ent-entry conf-entry pack-entry)
+ (let ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ ent-entry conf-entry pack-entry)
;; insert entities
(when ent-alist (vhdl-speedbar-make-title-line "Entities:" depth))
(while ent-alist
@@ -15011,7 +15018,7 @@ otherwise use cached data."
(declare-function speedbar-goto-this-file "speedbar" (file))
-(defun vhdl-speedbar-expand-dirs (directory)
+(defun vhdl-speedbar-expand-dirs (_directory)
"Expand subdirectories in DIRECTORY according to
`speedbar-shown-directories'."
;; (nicked from `speedbar-default-directory-list')
@@ -15050,7 +15057,8 @@ otherwise use cached data."
(goto-char position)
(when (re-search-forward
(concat "^[0-9]+:\\s-*\\(\\[\\|{.}\\s-+"
- (car arch-alist) "\\>\\)") nil t)
+ (car arch-alist) "\\>\\)")
+ nil t)
(beginning-of-line)
(when (looking-at "^[0-9]+:\\s-*{")
(goto-char (match-end 0))
@@ -15419,6 +15427,7 @@ otherwise use cached data."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Display help functions
+;; FIXME: This `defvar' should be moved before its first use.
(defvar vhdl-speedbar-update-current-unit t
"Non-nil means to run `vhdl-speedbar-update-current-unit'.")
@@ -15854,7 +15863,7 @@ NO-POSITION non-nil means do not re-position cursor."
(abbreviate-file-name
(file-name-as-directory (speedbar-line-directory indent)))))
-(defun vhdl-speedbar-line-project (&optional indent)
+(defun vhdl-speedbar-line-project (&optional _indent)
"Get currently displayed project name."
(and vhdl-speedbar-show-projects
(save-excursion
@@ -15889,8 +15898,7 @@ NO-POSITION non-nil means do not re-position cursor."
(setq path-list-1
(append
(mapcar
- (function
- (lambda (var) (concat path-beg var path-end)))
+ (lambda (var) (concat path-beg var path-end))
(let ((all-list (vhdl-directory-files
(match-string 2 dir) t
(concat "\\<" (wildcard-to-regexp
@@ -15925,7 +15933,7 @@ NO-POSITION non-nil means do not re-position cursor."
;; speedbar loads dframe at runtime.
(declare-function dframe-maybee-jump-to-attached-frame "dframe" ())
-(defun vhdl-speedbar-find-file (text token indent)
+(defun vhdl-speedbar-find-file (_text token _indent)
"When user clicks on TEXT, load file with name and position in TOKEN.
Jump to the design unit if `vhdl-speedbar-jump-to-unit' is t or if the file
is already shown in a buffer."
@@ -15953,12 +15961,12 @@ is already shown in a buffer."
(let ((token (get-text-property
(match-beginning 3) 'speedbar-token)))
(vhdl-visit-file (car token) t
- (progn (goto-char (point-min))
- (forward-line (1- (cdr token)))
- (end-of-line)
- (if is-entity
- (vhdl-port-copy)
- (vhdl-subprog-copy)))))
+ (goto-char (point-min))
+ (forward-line (1- (cdr token)))
+ (end-of-line)
+ (if is-entity
+ (vhdl-port-copy)
+ (vhdl-subprog-copy))))
(error (error "ERROR: %s not scanned successfully\n (%s)"
(if is-entity "Port" "Interface") (cadr info))))
(error "ERROR: No entity/component or subprogram on current line")))))
@@ -16148,7 +16156,7 @@ expansion function)."
;; initialize speedbar
(if (not (boundp 'speedbar-frame))
- (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize)
+ (with-no-warnings (add-hook 'speedbar-load-hook #'vhdl-speedbar-initialize))
(vhdl-speedbar-initialize)
(when speedbar-frame (vhdl-speedbar-refresh)))
@@ -16176,7 +16184,7 @@ expansion function)."
(read-from-minibuffer "architecture name: "
nil vhdl-minibuffer-local-map)
(vhdl-replace-string vhdl-compose-architecture-name ent-name)))
- ent-file-name arch-file-name ent-buffer arch-buffer project end-pos)
+ ent-file-name arch-file-name ent-buffer arch-buffer end-pos) ;; project
(message "Creating component \"%s(%s)\"..." ent-name arch-name)
;; open entity file
(unless (eq vhdl-compose-create-files 'none)
@@ -16376,7 +16384,7 @@ component instantiation."
(if comp-name
;; ... from component declaration
(vhdl-visit-file
- (when vhdl-use-components-package pack-file-name) t
+ (when vhdl-use-components-package pack-file-name) t
(save-excursion
(goto-char (point-min))
(unless (re-search-forward (concat "^\\s-*component[ \t\n\r\f]+" comp-name "\\>") nil t)
@@ -16387,7 +16395,7 @@ component instantiation."
(concat (vhdl-replace-string vhdl-entity-file-name comp-ent-name t)
"." (file-name-extension (buffer-file-name))))
(vhdl-visit-file
- comp-ent-file-name t
+ comp-ent-file-name t
(save-excursion
(goto-char (point-min))
(unless (re-search-forward (concat "^\\s-*entity[ \t\n\r\f]+" comp-ent-name "\\>") nil t)
@@ -16660,6 +16668,8 @@ component instantiation."
(vhdl-comment-insert-inline (nth 4 entry) t))
(insert "\n"))
+(defvar lazy-lock-minimum-size)
+
(defun vhdl-compose-components-package ()
"Generate a package containing component declarations for all entities in the
current project/directory."
@@ -16712,10 +16722,10 @@ current project/directory."
;; insert component declarations
(while ent-alist
(vhdl-visit-file (nth 2 (car ent-alist)) nil
- (progn (goto-char (point-min))
- (forward-line (1- (nth 3 (car ent-alist))))
- (end-of-line)
- (vhdl-port-copy)))
+ (goto-char (point-min))
+ (forward-line (1- (nth 3 (car ent-alist))))
+ (end-of-line)
+ (vhdl-port-copy))
(goto-char component-pos)
(vhdl-port-paste-component t)
(when (cdr ent-alist) (insert "\n\n") (indent-to vhdl-basic-offset))
@@ -16729,13 +16739,16 @@ current project/directory."
(message "Generating components package \"%s\"...done\n File created: \"%s\""
pack-name pack-file-name)))
-(defun vhdl-compose-configuration-architecture (ent-name arch-name ent-alist
- conf-alist inst-alist
- &optional insert-conf)
+(defun vhdl-compose-configuration-architecture ( _ent-name arch-name
+ ent-alist-arg conf-alist-arg
+ inst-alist
+ &optional insert-conf)
"Generate block configuration for architecture."
- (let ((margin (current-indentation))
+ (let ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ (margin (current-indentation))
(beg (point-at-bol))
- ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist)
+ ent-entry inst-entry inst-path inst-prev-path tmp-alist) ;; cons-key
;; insert block configuration (for architecture)
(vhdl-insert-keyword "FOR ") (insert arch-name "\n")
(setq margin (+ margin vhdl-basic-offset))
@@ -17086,7 +17099,7 @@ do not print any file names."
(file-relative-name (buffer-file-name))))
(when (and (= 0 (nth 1 (nth 10 compiler)))
(= 0 (nth 1 (nth 11 compiler))))
- (setq compilation-process-setup-function 'vhdl-compile-print-file-name))
+ (setq compilation-process-setup-function #'vhdl-compile-print-file-name))
;; run compilation
(if options
(when command
@@ -17160,7 +17173,7 @@ specified by a target."
vhdl-error-regexp-emacs-alist)))
(when vhdl-emacs-22
- (add-hook 'compilation-mode-hook 'vhdl-error-regexp-add-emacs))
+ (add-hook 'compilation-mode-hook #'vhdl-error-regexp-add-emacs))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Makefile generation
@@ -17439,12 +17452,12 @@ specified by a target."
(setq tmp-list rule-alist)
(while tmp-list ; pre-sort rule targets
(setq cell (cdar tmp-list))
- (setcar cell (sort (car cell) 'string<))
+ (setcar cell (sort (car cell) #'string<))
(setq tmp-list (cdr tmp-list)))
(setq rule-alist ; sort by first rule target
(sort rule-alist
- (function (lambda (a b)
- (string< (car (cadr a)) (car (cadr b)))))))
+ (lambda (a b)
+ (string< (car (cadr a)) (car (cadr b))))))
;; open and clear Makefile
(set-buffer (find-file-noselect makefile-path-name t t))
(erase-buffer)
@@ -17529,9 +17542,9 @@ specified by a target."
;; insert rule for each library unit
(insert "\n\n# Rules for compiling single library units and their subhierarchy\n")
(while prim-list
- (setq second-list (sort (nth 1 (car prim-list)) 'string<))
+ (setq second-list (sort (nth 1 (car prim-list)) #'string<))
(setq subcomp-list
- (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<))
+ (sort (vhdl-uniquify (nth 2 (car prim-list))) #'string<))
(setq unit-key (caar prim-list)
unit-name (or (nth 0 (vhdl-aget ent-alist unit-key))
(nth 0 (vhdl-aget conf-alist unit-key))
@@ -17561,7 +17574,7 @@ specified by a target."
(vhdl-get-compile-options project compiler (nth 0 rule) t))
;; insert rule if file is supposed to be compiled
(setq target-list (nth 1 rule)
- depend-list (sort (vhdl-uniquify (nth 2 rule)) 'string<))
+ depend-list (sort (vhdl-uniquify (nth 2 rule)) #'string<))
;; insert targets
(setq tmp-list target-list)
(while target-list
@@ -17584,7 +17597,8 @@ specified by a target."
(if (eq options 'default) "$(OPTIONS)" options) " "
(nth 0 rule)
(if (equal vhdl-compile-post-command "") ""
- " $(POST-COMPILE)") "\n")
+ " $(POST-COMPILE)")
+ "\n")
(insert "\n"))
(unless (and options mapping-exist)
(setq tmp-list target-list)
@@ -17624,6 +17638,7 @@ specified by a target."
"Submit via mail a bug report on VHDL Mode."
(interactive)
;; load in reporter
+ (defvar reporter-prompt-for-summary-p)
(and
(y-or-n-p "Do you want to submit a report on VHDL Mode? ")
(let ((reporter-prompt-for-summary-p t))
@@ -17755,16 +17770,15 @@ specified by a target."
'vhdl-word-completion-in-minibuffer
'vhdl-underscore-is-part-of-word
'vhdl-mode-hook)
- (function
- (lambda ()
- (insert
- (if vhdl-special-indent-hook
- (concat "\n@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
- "vhdl-special-indent-hook is set to '"
- (format "%s" vhdl-special-indent-hook)
- ".\nPerhaps this is your problem?\n"
- "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n\n")
- "\n"))))
+ (lambda ()
+ (insert
+ (if vhdl-special-indent-hook
+ (concat "\n@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
+ "vhdl-special-indent-hook is set to '"
+ (format "%s" vhdl-special-indent-hook)
+ ".\nPerhaps this is your problem?\n"
+ "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n\n")
+ "\n")))
nil
"Hi Reto,"))))
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 53b9b869988..02a8d72758c 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 -*- lexical-binding:t -*-
-;; Copyright (C) 1994, 1997-1998, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
;; Author: Alex Rezinsky <alexr@msil.sps.mot.com>
;; (doesn't seem to be responsive any more)
@@ -25,17 +24,17 @@
;;; Commentary:
;; This package prints name of function where your current point is
-;; located in mode line. It assumes that you work with imenu package
-;; and imenu--index-alist is up to date.
+;; located in mode line. It assumes that you work with the imenu
+;; package and `imenu--index-alist' is up to date.
;; KNOWN BUGS
;; ----------
;; Really this package shows not "function where the current point is
;; located now", but "nearest function which defined above the current
-;; point". So if your current point is located after end of function
-;; FOO but before begin of function BAR, FOO will be displayed in mode
-;; line.
-;; - if two windows display the same buffer, both windows
+;; point". So if your current point is located after the end of
+;; function FOO but before the beginning of function BAR, FOO will be
+;; displayed in the mode line.
+;; - If two windows display the same buffer, both windows
;; show the same `which-func' information.
;; TODO LIST
@@ -44,7 +43,7 @@
;; function determination mechanism should be used to determine the end
;; of a function as well as the beginning of a function.
;; 2. This package should be realized with the help of overlay
-;; properties instead of imenu--index-alist variable.
+;; properties instead of the `imenu--index-alist' variable.
;;; History:
@@ -186,7 +185,7 @@ and you want to simplify them for the mode line
"Non-nil means display current function name in mode line.
This makes a difference only if `which-function-mode' is non-nil.")
-(add-hook 'find-file-hook 'which-func-ff-hook t)
+(add-hook 'after-change-major-mode-hook #'which-func-ff-hook t)
(defun which-func-try-to-enable ()
(unless (or (not which-function-mode)
@@ -195,7 +194,7 @@ This makes a difference only if `which-function-mode' is non-nil.")
(member major-mode which-func-modes)))))
(defun which-func-ff-hook ()
- "File find hook for Which Function mode.
+ "`after-change-major-mode-hook' for Which Function mode.
It creates the Imenu index for the buffer, if necessary."
(which-func-try-to-enable)
@@ -214,9 +213,10 @@ It creates the Imenu index for the buffer, if necessary."
(setq which-func-mode nil))))
(defun which-func-update ()
- ;; "Update the Which-Function mode display for all windows."
+ "Update the Which-Function mode display for all windows."
;; (walk-windows 'which-func-update-1 nil 'visible))
- (which-func-update-1 (selected-window)))
+ (let ((non-essential t))
+ (which-func-update-1 (selected-window))))
(defun which-func-update-1 (window)
"Update the Which Function mode display for window WINDOW."
@@ -282,52 +282,55 @@ If no function name is found, return nil."
(when (null name)
(setq name (add-log-current-defun)))
;; If Imenu is loaded, try to make an index alist with it.
+ ;; If `add-log-current-defun' ran and gave nil, accept that.
(when (and (null name)
- (boundp 'imenu--index-alist)
- (or (null imenu--index-alist)
- ;; Update if outdated
- (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick))
- (null which-function-imenu-failed))
- (ignore-errors (imenu--make-index-alist t))
- (unless imenu--index-alist
- (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)
- (let ((alist imenu--index-alist)
- (minoffset (point-max))
- offset pair mark imstack namestack)
- ;; Elements of alist are either ("name" . marker), or
- ;; ("submenu" ("name" . marker) ... ). The list can be
- ;; arbitrarily nested.
- (while (or alist 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)))
-
- ((or (number-or-marker-p (setq mark (cdr pair)))
- (and (overlayp mark)
- (setq mark (overlay-start mark))))
- (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))))))))))))
+ (null add-log-current-defun-function))
+ (when (and (null name)
+ (boundp 'imenu--index-alist)
+ (or (null imenu--index-alist)
+ ;; Update if outdated
+ (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick))
+ (null which-function-imenu-failed))
+ (ignore-errors (imenu--make-index-alist t))
+ (unless imenu--index-alist
+ (setq-local which-function-imenu-failed t)))
+ ;; If we have an index alist, use it.
+ (when (and (null name)
+ (boundp 'imenu--index-alist) imenu--index-alist)
+ (let ((alist imenu--index-alist)
+ (minoffset (point-max))
+ offset pair mark imstack namestack)
+ ;; Elements of alist are either ("name" . marker), or
+ ;; ("submenu" ("name" . marker) ... ). The list can be
+ ;; arbitrarily nested.
+ (while (or alist 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)))
+
+ ((or (number-or-marker-p (setq mark (cdr pair)))
+ (and (overlayp mark)
+ (setq mark (overlay-start mark))))
+ (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)))))))))))))
;; Filter the name if requested.
(when name
(if which-func-cleanup-function
@@ -353,7 +356,7 @@ This function is meant to be called from `ediff-select-hook'."
(when ediff-window-C
(which-func-update-1 ediff-window-C))))
-(add-hook 'ediff-select-hook 'which-func-update-ediff-windows)
+(add-hook 'ediff-select-hook #'which-func-update-ediff-windows)
(provide 'which-func)
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 309f48a8177..7453dbed992 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1,6 +1,11 @@
-;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*-
+;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
+;; Version: 1.1.0
+;; Package-Requires: ((emacs "26.1"))
+
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
;; This file is part of GNU Emacs.
@@ -19,11 +24,6 @@
;;; Commentary:
-;; NOTE: The xref API is still experimental and can change in major,
-;; backward-incompatible ways. Everyone is encouraged to try it, and
-;; report to us any problems or use cases we hadn't anticipated, by
-;; sending an email to emacs-devel, or `M-x report-emacs-bug'.
-;;
;; This file provides a somewhat generic infrastructure for cross
;; referencing commands, in particular "find-definition".
;;
@@ -98,14 +98,22 @@ This is typically the filename.")
;;;; Commonly needed location classes are defined here:
-(defcustom xref-file-name-display 'abs
+(defcustom xref-file-name-display 'project-relative
"Style of file name display in *xref* buffers.
+
If the value is the symbol `abs', the default, show the file names
in their full absolute form.
+
If `nondirectory', show only the nondirectory (a.k.a. \"base name\")
-part of the file name."
+part of the file name.
+
+If `project-relative', show only the file name relative to the
+current project root. If there is no current project, or if the
+file resides outside of its root, show that particular file name
+in its full absolute form."
:type '(choice (const :tag "absolute file name" abs)
- (const :tag "nondirectory file name" nondirectory))
+ (const :tag "nondirectory file name" nondirectory)
+ (const :tag "relative to project root" project-relative))
:version "27.1")
;; FIXME: might be useful to have an optional "hint" i.e. a string to
@@ -140,10 +148,31 @@ Line numbers start from 1 and columns from 0.")
(forward-char column))
(point-marker))))))
+(defvar xref--project-root-memo nil
+ "Cons mapping `default-directory' value to the search root.")
+
(cl-defmethod xref-location-group ((l xref-file-location))
(cl-ecase xref-file-name-display
- (abs (oref l file))
- (nondirectory (file-name-nondirectory (oref l file)))))
+ (abs
+ (oref l file))
+ (nondirectory
+ (file-name-nondirectory (oref l file)))
+ (project-relative
+ (unless (and xref--project-root-memo
+ (equal (car xref--project-root-memo)
+ default-directory))
+ (setq xref--project-root-memo
+ (cons default-directory
+ (let ((root
+ (let ((pr (project-current)))
+ (and pr (xref--project-root pr)))))
+ (and root (expand-file-name root))))))
+ (let ((file (oref l file))
+ (search-root (cdr xref--project-root-memo)))
+ (if (and search-root
+ (string-prefix-p search-root file))
+ (substring file (length search-root))
+ file)))))
(defclass xref-buffer-location (xref-location)
((buffer :type buffer :initarg :buffer)
@@ -258,17 +287,21 @@ be found, return nil.
The default implementation uses `semantic-symref-tool-alist' to
find a search tool; by default, this uses \"find | grep\" in the
-`project-current' roots."
- (cl-mapcan
+current project's main and external roots."
+ (mapcan
(lambda (dir)
(xref-references-in-directory identifier dir))
(let ((pr (project-current t)))
- (append
- (project-roots pr)
+ (cons
+ (xref--project-root pr)
(project-external-roots pr)))))
(cl-defgeneric xref-backend-apropos (backend pattern)
- "Find all symbols that match regexp PATTERN.")
+ "Find all symbols that match PATTERN string.
+The second argument has the same meaning as in `apropos'.
+
+If BACKEND is implemented in Lisp, it can use
+`xref-apropos-regexp' to convert the pattern to regexp.")
(cl-defgeneric xref-backend-identifier-at-point (_backend)
"Return the relevant identifier at point.
@@ -373,6 +406,12 @@ elements is negated: these commands will NOT prompt."
"Functions called after returning to a pre-jump location."
:type 'hook)
+(defcustom xref-after-update-hook nil
+ "Functions called after the xref buffer is updated."
+ :type 'hook
+ :version "28.1"
+ :package-version '(xref . "1.0.4"))
+
(defvar xref--marker-ring (make-ring xref-marker-ring-length)
"Ring of markers to implement the marker stack.")
@@ -477,7 +516,7 @@ If SELECT is non-nil, select the target window."
"Face for displaying line numbers in the xref buffer."
:version "27.1")
-(defface xref-match '((t :inherit highlight))
+(defface xref-match '((t :inherit match))
"Face used to highlight matches in the xref buffer."
:version "27.1")
@@ -505,8 +544,7 @@ If SELECT is non-nil, select the target window."
"Goto and display position POS of buffer BUF in a window.
Honor `xref--original-window-intent', run `xref-after-jump-hook'
and finally return the window."
- (let* ((xref-buf (current-buffer))
- (pop-up-frames
+ (let* ((pop-up-frames
(or (eq xref--original-window-intent 'frame)
pop-up-frames))
(action
@@ -524,9 +562,6 @@ and finally return the window."
(with-selected-window (display-buffer buf action)
(xref--goto-char pos)
(run-hooks 'xref-after-jump-hook)
- (let ((buf (current-buffer)))
- (with-current-buffer xref-buf
- (setq-local other-window-scroll-buffer buf)))
(selected-window))))
(defun xref--display-buffer-in-other-window (buffer alist)
@@ -569,40 +604,78 @@ SELECT is `quit', also quit the *xref* window."
(when xref
(xref--show-location (xref-item-location xref)))))
+(defun xref-next-line-no-show ()
+ "Move to the next xref but don't display its source."
+ (interactive)
+ (xref--search-property 'xref-item))
+
(defun xref-next-line ()
"Move to the next xref and display its source in the appropriate window."
(interactive)
- (xref--search-property 'xref-item)
+ (xref-next-line-no-show)
(xref-show-location-at-point))
+(defun xref-prev-line-no-show ()
+ "Move to the previous xref but don't display its source."
+ (interactive)
+ (xref--search-property 'xref-item t))
+
(defun xref-prev-line ()
"Move to the previous xref and display its source in the appropriate window."
(interactive)
- (xref--search-property 'xref-item t)
+ (xref-prev-line-no-show)
+ (xref-show-location-at-point))
+
+(defun xref-next-group ()
+ "Move to the first item of the next xref group and display its source."
+ (interactive)
+ (xref--search-property 'xref-group)
+ (xref--search-property 'xref-item)
+ (xref-show-location-at-point))
+
+(defun xref-prev-group ()
+ "Move to the first item of the previous xref group and display its source."
+ (interactive)
+ ;; Search for the xref group of the current item, provided that the
+ ;; point is not already in an xref group.
+ (unless (plist-member (text-properties-at (point)) 'xref-group)
+ (xref--search-property 'xref-group t))
+ ;; Search for the previous xref group.
+ (xref--search-property 'xref-group t)
+ (xref--search-property 'xref-item)
(xref-show-location-at-point))
(defun xref--item-at-point ()
- (save-excursion
- (back-to-indentation)
- (get-text-property (point) 'xref-item)))
+ (get-text-property
+ (if (eolp) (1- (point)) (point))
+ 'xref-item))
(defun xref-goto-xref (&optional quit)
"Jump to the xref on the current line and select its window.
-Non-interactively, non-nil QUIT means to first quit the *xref*
-buffer."
- (interactive)
+If QUIT is non-nil (interactively, with prefix argument), also
+quit the *xref* buffer."
+ (interactive "P")
(let* ((buffer (current-buffer))
(xref (or (xref--item-at-point)
(user-error "No reference at point")))
(xref--current-item xref))
(xref--show-location (xref-item-location xref) (if quit 'quit t))
- (next-error-found buffer (current-buffer))))
+ (if (fboundp 'next-error-found)
+ (next-error-found buffer (current-buffer))
+ ;; Emacs < 27
+ (setq next-error-last-buffer buffer))))
(defun xref-quit-and-goto-xref ()
"Quit *xref* buffer, then jump to xref on current line."
(interactive)
(xref-goto-xref t))
+(defun xref-quit-and-pop-marker-stack ()
+ "Quit *xref* buffer, then pop the xref marker stack."
+ (interactive)
+ (quit-window)
+ (xref-pop-marker-stack))
+
(defun xref-query-replace-in-results (from to)
"Perform interactive replacement of FROM with TO in all displayed xrefs.
@@ -647,10 +720,7 @@ references displayed in the current *xref* buffer."
(push pair all-pairs)
;; Perform sanity check first.
(xref--goto-location loc)
- (if (xref--outdated-p item
- (buffer-substring-no-properties
- (line-beginning-position)
- (line-end-position)))
+ (if (xref--outdated-p item)
(message "Search result out of date, skipping")
(cond
((null file-buf)
@@ -667,18 +737,38 @@ references displayed in the current *xref* buffer."
(move-marker (car pair) nil)
(move-marker (cdr pair) nil)))))))
-(defun xref--outdated-p (item line-text)
- ;; FIXME: The check should probably be a generic function instead of
- ;; the assumption that all matches contain the full line as summary.
- (let ((summary (xref-item-summary item))
- (strip (lambda (s) (if (string-match "\r\\'" s)
- (substring-no-properties s 0 -1)
- s))))
+(defun xref--outdated-p (item)
+ "Check that the match location at current position is up-to-date.
+ITEMS is an xref item which "
+ ;; FIXME: The check should most likely be a generic function instead
+ ;; of the assumption that all matches' summaries relate to the
+ ;; buffer text in a particular way.
+ (let* ((summary (xref-item-summary item))
+ ;; Sometimes buffer contents include ^M, and sometimes Grep
+ ;; output includes it, and they don't always match.
+ (strip (lambda (s) (if (string-match "\r\\'" s)
+ (substring-no-properties s 0 -1)
+ s)))
+ (stripped-summary (funcall strip summary))
+ (lendpos (line-end-position))
+ (check (lambda ()
+ (let ((comparison-end
+ (+ (point) (length stripped-summary))))
+ (and (>= lendpos comparison-end)
+ (equal stripped-summary
+ (buffer-substring-no-properties
+ (point) comparison-end)))))))
(not
- ;; Sometimes buffer contents include ^M, and sometimes Grep
- ;; output includes it, and they don't always match.
- (equal (funcall strip line-text)
- (funcall strip summary)))))
+ (or
+ ;; Either summary contains match text and after
+ ;; (2nd+ match on the line)...
+ (funcall check)
+ ;; ...or it starts at bol, includes the match and after.
+ (and (< (point) (+ (line-beginning-position)
+ (length stripped-summary)))
+ (save-excursion
+ (forward-line 0)
+ (funcall check)))))))
;; FIXME: Write a nicer UI.
(defun xref--query-replace-1 (from to iter)
@@ -723,6 +813,8 @@ references displayed in the current *xref* buffer."
(let ((map (make-sparse-keymap)))
(define-key map (kbd "n") #'xref-next-line)
(define-key map (kbd "p") #'xref-prev-line)
+ (define-key map (kbd "N") #'xref-next-group)
+ (define-key map (kbd "P") #'xref-prev-group)
(define-key map (kbd "r") #'xref-query-replace-in-results)
(define-key map (kbd "RET") #'xref-goto-xref)
(define-key map (kbd "TAB") #'xref-quit-and-goto-xref)
@@ -731,6 +823,7 @@ references displayed in the current *xref* buffer."
(define-key map (kbd ".") #'xref-next-line)
(define-key map (kbd ",") #'xref-prev-line)
(define-key map (kbd "g") #'xref-revert-buffer)
+ (define-key map (kbd "M-,") #'xref-quit-and-pop-marker-stack)
map))
(define-derived-mode xref--xref-buffer-mode special-mode "XREF"
@@ -803,6 +896,44 @@ beginning of the line."
(xref--search-property 'xref-item))
(xref-show-location-at-point))
+(defcustom xref-truncation-width 400
+ "The column to visually \"truncate\" each Xref buffer line to."
+ :type '(choice
+ (integer :tag "Number of columns")
+ (const :tag "Disable truncation" nil)))
+
+(defun xref--apply-truncation ()
+ (let ((bol (line-beginning-position))
+ (eol (line-end-position))
+ (inhibit-read-only t)
+ pos adjusted-bol)
+ (when (and xref-truncation-width
+ (> (- eol bol) xref-truncation-width)
+ ;; Either truncation not applied yet, or it hides the current
+ ;; position: need to refresh.
+ (or (and (null (get-text-property (1- eol) 'invisible))
+ (null (get-text-property bol 'invisible)))
+ (get-text-property (point) 'invisible)))
+ (setq adjusted-bol
+ (cond
+ ((eq (get-text-property bol 'face) 'xref-line-number)
+ (next-single-char-property-change bol 'face))
+ (t bol)))
+ (cond
+ ((< (- (point) bol) xref-truncation-width)
+ (setq pos (+ bol xref-truncation-width))
+ (remove-text-properties bol pos '(invisible))
+ (put-text-property pos eol 'invisible 'ellipsis))
+ ((< (- eol (point)) xref-truncation-width)
+ (setq pos (- eol xref-truncation-width))
+ (remove-text-properties pos eol '(invisible))
+ (put-text-property adjusted-bol pos 'invisible 'ellipsis))
+ (t
+ (setq pos (- (point) (/ xref-truncation-width 2)))
+ (put-text-property adjusted-bol pos 'invisible 'ellipsis)
+ (remove-text-properties pos (+ pos xref-truncation-width) '(invisible))
+ (put-text-property (+ pos xref-truncation-width) eol 'invisible 'ellipsis))))))
+
(defun xref--insert-xrefs (xref-alist)
"Insert XREF-ALIST in the current-buffer.
XREF-ALIST is of the form ((GROUP . (XREF ...)) ...), where
@@ -817,6 +948,8 @@ GROUP is a string for decoration purposes and XREF is an
(length (and line (format "%d" line)))))
for line-format = (and max-line-width
(format "%%%dd: " max-line-width))
+ with prev-group = nil
+ with prev-line = nil
do
(xref--insert-propertized '(face xref-file-header xref-group t)
group "\n")
@@ -824,10 +957,18 @@ GROUP is a string for decoration purposes and XREF is an
(with-slots (summary location) xref
(let* ((line (xref-location-line location))
(prefix
- (if line
- (propertize (format line-format line)
- 'face 'xref-line-number)
- " ")))
+ (cond
+ ((not line) " ")
+ ((and (equal line prev-line)
+ (equal prev-group group))
+ "")
+ (t (propertize (format line-format line)
+ 'face 'xref-line-number)))))
+ ;; Render multiple matches on the same line, together.
+ (when (and (equal prev-group group)
+ (or (null line)
+ (not (equal prev-line line))))
+ (insert "\n"))
(xref--insert-propertized
(list 'xref-item xref
'mouse-face 'highlight
@@ -835,8 +976,16 @@ GROUP is a string for decoration purposes and XREF is an
'help-echo
(concat "mouse-2: display in another window, "
"RET or mouse-1: follow reference"))
- prefix summary)))
- (insert "\n"))))
+ prefix summary)
+ (setq prev-line line
+ prev-group group))))
+ (insert "\n"))
+ (add-to-invisibility-spec '(ellipsis . t))
+ (save-excursion
+ (goto-char (point-min))
+ (while (= 0 (forward-line 1))
+ (xref--apply-truncation)))
+ (run-hooks 'xref-after-update-hook))
(defun xref--analyze (xrefs)
"Find common filenames in XREFS.
@@ -861,12 +1010,19 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(pop-to-buffer (current-buffer))
(current-buffer))))
+(defun xref--project-root (project)
+ (if (fboundp 'project-root)
+ (project-root project)
+ (with-no-warnings
+ (car (project-roots project)))))
+
(defun xref--show-common-initialize (xref-alist fetcher alist)
(setq buffer-undo-list nil)
(let ((inhibit-read-only t)
(buffer-undo-list t))
(erase-buffer)
(xref--insert-xrefs xref-alist)
+ (add-hook 'post-command-hook 'xref--apply-truncation nil t)
(goto-char (point-min))
(setq xref--original-window (assoc-default 'window alist)
xref--original-window-intent (assoc-default 'display-action alist))
@@ -889,7 +1045,10 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(error-message-string err)
'face 'error)))))))
-(defun xref--show-defs-buffer (fetcher alist)
+(defun xref-show-definitions-buffer (fetcher alist)
+ "Show the definitions list in a regular window.
+
+When only one definition found, jump to it right away instead."
(let ((xrefs (funcall fetcher)))
(cond
((not (cdr xrefs))
@@ -900,13 +1059,21 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(cons (cons 'fetched-xrefs xrefs)
alist))))))
-(defun xref--show-defs-buffer-at-bottom (fetcher alist)
- "Show definitions list in a window at the bottom.
+(define-obsolete-function-alias
+ 'xref--show-defs-buffer #'xref-show-definitions-buffer "28.1")
+
+(defun xref-show-definitions-buffer-at-bottom (fetcher alist)
+ "Show the definitions list in a window at the bottom.
+
When there is more than one definition, split the selected window
and show the list in a small window at the bottom. And use a
local keymap that binds `RET' to `xref-quit-and-goto-xref'."
- (let ((xrefs (funcall fetcher))
- (dd default-directory))
+ (let* ((xrefs (funcall fetcher))
+ (dd default-directory)
+ ;; XXX: Make percentage customizable maybe?
+ (max-height (/ (window-height) 2))
+ (size-fun (lambda (window)
+ (fit-window-to-buffer window max-height))))
(cond
((not (cdr xrefs))
(xref-pop-to-location (car xrefs)
@@ -917,9 +1084,82 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'."
(xref--transient-buffer-mode)
(xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
(pop-to-buffer (current-buffer)
- '(display-buffer-in-direction . ((direction . below))))
+ `(display-buffer-in-direction . ((direction . below)
+ (window-height . ,size-fun))))
(current-buffer))))))
+(define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom
+ #'xref-show-definitions-buffer-at-bottom "28.1")
+
+(defun xref--completing-read-group (cand transform)
+ "Return group title of candidate CAND or TRANSFORM the candidate."
+ (if transform
+ (substring cand (1+ (next-single-property-change 0 'xref--group cand)))
+ (get-text-property 0 'xref--group cand)))
+
+(defun xref-show-definitions-completing-read (fetcher alist)
+ "Let the user choose the target definition with completion.
+
+When there is more than one definition, let the user choose
+between them by typing in the minibuffer with completion."
+ (let* ((xrefs (funcall fetcher))
+ (xref-alist (xref--analyze xrefs))
+ xref-alist-with-line-info
+ xref
+ (group-prefix-length
+ ;; FIXME: Groups are not always file names, but they often
+ ;; are. At least this shouldn't make the other kinds of
+ ;; groups look worse.
+ (let ((common-prefix (try-completion "" xref-alist)))
+ (if (> (length common-prefix) 0)
+ (length (file-name-directory common-prefix))
+ 0))))
+
+ (cl-loop for ((group . xrefs) . more1) on xref-alist
+ do
+ (cl-loop for (xref . more2) on xrefs do
+ (with-slots (summary location) xref
+ (let* ((line (xref-location-line location))
+ (line-fmt
+ (if line
+ (format #("%d:" 0 2 (face xref-line-number))
+ line)
+ ""))
+ (group-prefix
+ (substring group group-prefix-length))
+ (group-fmt
+ (propertize group-prefix
+ 'face 'xref-file-header
+ 'xref--group group-prefix))
+ (candidate
+ (format "%s:%s%s" group-fmt line-fmt summary)))
+ (push (cons candidate xref) xref-alist-with-line-info)))))
+
+ (setq xref (if (not (cdr xrefs))
+ (car xrefs)
+ (let* ((collection (reverse xref-alist-with-line-info))
+ (ctable
+ (lambda (string pred action)
+ (cond
+ ((eq action 'metadata)
+ `(metadata
+ . ((category . xref-location)
+ (group-function . ,#'xref--completing-read-group))))
+ (t
+ (complete-with-action action collection string pred)))))
+ (def (caar collection)))
+ (cdr (assoc (completing-read "Choose definition: "
+ ctable nil t
+ nil nil
+ def)
+ collection)))))
+
+ (xref-pop-to-location xref (assoc-default 'display-action alist))))
+
+;; TODO: Can delete this alias before Emacs 28's release.
+(define-obsolete-function-alias
+ 'xref--show-defs-minibuffer #'xref-show-definitions-completing-read "28.1")
+
(defcustom xref-show-xrefs-function 'xref--show-xref-buffer
"Function to display a list of search results.
@@ -940,18 +1180,39 @@ displayed. The possible values are nil, `window' meaning the
other window, or `frame' meaning the other frame."
:type 'function)
-(defcustom xref-show-definitions-function 'xref--show-defs-buffer
- "Function to display a list of definitions.
+(defcustom xref-show-definitions-function 'xref-show-definitions-buffer
+ "Function to handle the definition search results.
-Accepts the same arguments as `xref-show-xrefs-function'."
- :type 'function)
+Accepts the same arguments as `xref-show-xrefs-function'.
+
+Generally, it is expected to jump to the definition if there's
+only one, and otherwise provide some way to choose among the
+definitions."
+ :type '(choice
+ (const :tag "Show a regular list of locations"
+ xref-show-definitions-buffer)
+ (const :tag "Show a \"transient\" list at the bottom of the window"
+ xref-show-definitions-buffer-at-bottom)
+ (const :tag "Choose the definition with completion"
+ xref-show-definitions-completing-read)
+ (function :tag "Custom function")))
(defvar xref--read-identifier-history nil)
(defvar xref--read-pattern-history nil)
-(defun xref--show-xrefs (fetcher display-action)
+(defun xref--show-xrefs (fetcher display-action &optional _always-show-list)
(xref--push-markers)
+ (unless (functionp fetcher)
+ ;; Old convention.
+ (let ((xrefs fetcher))
+ (setq fetcher
+ (lambda ()
+ (if (eq xrefs 'called-already)
+ (user-error "Refresh is not supported")
+ (prog1
+ xrefs
+ (setq xrefs 'called-already)))))))
(funcall xref-show-xrefs-function fetcher
`((window . ,(selected-window))
(display-action . ,display-action))))
@@ -1097,14 +1358,24 @@ The argument has the same meaning as in `apropos'."
"Search for pattern (word list or regexp): "
nil 'xref--read-pattern-history)))
(require 'apropos)
- (xref--find-xrefs pattern 'apropos
- (apropos-parse-pattern
- (if (string-equal (regexp-quote pattern) pattern)
- ;; Split into words
- (or (split-string pattern "[ \t]+" t)
- (user-error "No word list given"))
- pattern))
- nil))
+ (let* ((newpat
+ (if (and (version< emacs-version "28.0.50")
+ (memq (xref-find-backend) '(elisp etags)))
+ ;; Handle backends in older Emacs.
+ (xref-apropos-regexp pattern)
+ ;; Delegate pattern handling to the backend fully.
+ ;; The old way didn't work for "external" backends.
+ pattern)))
+ (xref--find-xrefs pattern 'apropos newpat nil)))
+
+(defun xref-apropos-regexp (pattern)
+ "Return an Emacs regexp from PATTERN similar to `apropos'."
+ (apropos-parse-pattern
+ (if (string-equal (regexp-quote pattern) pattern)
+ ;; Split into words
+ (or (split-string pattern "[ \t]+" t)
+ (user-error "No word list given"))
+ pattern)))
;;; Key bindings
@@ -1196,7 +1467,9 @@ IGNORES is a list of glob patterns for files to ignore."
;; do that reliably enough, without creating false negatives?
(command (xref--rgrep-command (xref--regexp-to-extended regexp)
files
- (file-local-name (expand-file-name dir))
+ (directory-file-name
+ (file-name-unquote
+ (file-local-name (expand-file-name dir))))
ignores))
(def default-directory)
(buf (get-buffer-create " *xref-grep*"))
@@ -1231,12 +1504,61 @@ IGNORES is a list of glob patterns for files to ignore."
(declare-function tramp-tramp-file-p "tramp")
(declare-function tramp-file-local-name "tramp")
+;; TODO: Experiment with 'xargs -P4' (or any other number).
+;; This speeds up either command, even more than rg's '-j4' does.
+;; Ripgrep gets jumbled output, though, even with --line-buffered.
+;; But Grep seems to be stable. Even without --line-buffered.
+(defcustom xref-search-program-alist
+ '((grep
+ .
+ ;; '-s' because 'git ls-files' can output broken symlinks.
+ "xargs -0 grep <C> -snHE -e <R>")
+ (ripgrep
+ .
+ ;; Note: by default, ripgrep's output order is non-deterministic
+ ;; (https://github.com/BurntSushi/ripgrep/issues/152)
+ ;; because it does the search in parallel. You can use the template
+ ;; without the '| sort ...' part if GNU sort is not available on
+ ;; your system and/or stable ordering is not important to you.
+ ;; Note#2: '!*/' is there to filter out dirs (e.g. submodules).
+ "xargs -0 rg <C> -nH --no-messages -g '!*/' -e <R> | sort -t: -k1,1 -k2n,2"
+ ))
+ "Associative list mapping program identifiers to command templates.
+
+Program identifier should be a symbol, named after the search program.
+
+The command template must be a shell command (or usually a
+pipeline) that will search the files based on the list of file
+names that is piped from stdin, separated by null characters.
+The template should have the following fields:
+
+ <C> for extra arguments such as -i and --color
+ <R> for the regexp itself (in Extended format)"
+ :type '(repeat
+ (cons (symbol :tag "Program identifier")
+ (string :tag "Command template")))
+ :version "28.1"
+ :package-version '(xref . "1.0.4"))
+
+(defcustom xref-search-program 'grep
+ "The program to use for regexp search inside files.
+
+This must reference a corresponding entry in `xref-search-program-alist'."
+ :type `(choice
+ (const :tag "Use Grep" grep)
+ (const :tag "Use ripgrep" ripgrep)
+ (symbol :tag "User defined"))
+ :version "28.1"
+ :package-version '(xref . "1.0.4"))
+
;;;###autoload
(defun xref-matches-in-files (regexp files)
"Find all matches for REGEXP in FILES.
Return a list of xref values.
FILES must be a list of absolute file names."
(cl-assert (consp files))
+ (require 'grep)
+ (defvar grep-highlight-matches)
(pcase-let*
((output (get-buffer-create " *project grep output*"))
(`(,grep-re ,file-group ,line-group . ,_) (car grep-regexp-alist))
@@ -1246,13 +1568,17 @@ FILES must be a list of absolute file names."
;; first file is remote, they all are, and on the same host.
(dir (file-name-directory (car files)))
(remote-id (file-remote-p dir))
- ;; 'git ls-files' can output broken symlinks.
- (command (format "xargs -0 grep %s -snHE -e %s"
- (if (and case-fold-search
- (isearch-no-upper-case-p regexp t))
- "-i"
- "")
- (shell-quote-argument (xref--regexp-to-extended regexp)))))
+ ;; The 'auto' default would be fine too, but ripgrep can't handle
+ ;; the options we pass in that case.
+ (grep-highlight-matches nil)
+ (command (grep-expand-template (cdr
+ (or
+ (assoc
+ xref-search-program
+ xref-search-program-alist)
+ (user-error "Unknown search program `%s'"
+ xref-search-program)))
+ (xref--regexp-to-extended regexp))))
(when remote-id
(require 'tramp)
(setq files (mapcar
@@ -1260,19 +1586,21 @@ FILES must be a list of absolute file names."
#'tramp-file-local-name
#'file-local-name)
files)))
+ (when (file-name-quoted-p (car files))
+ (setq files (mapcar #'file-name-unquote files)))
(with-current-buffer output
(erase-buffer)
(with-temp-buffer
(insert (mapconcat #'identity files "\0"))
(setq default-directory dir)
(setq status
- (project--process-file-region (point-min)
- (point-max)
- shell-file-name
- output
- nil
- shell-command-switch
- command)))
+ (xref--process-file-region (point-min)
+ (point-max)
+ shell-file-name
+ output
+ nil
+ shell-command-switch
+ command)))
(goto-char (point-min))
(when (and (/= (point-min) (point-max))
(not (looking-at grep-re))
@@ -1287,6 +1615,24 @@ FILES must be a list of absolute file names."
hits)))
(xref--convert-hits (nreverse hits) regexp)))
+(defun xref--process-file-region ( start end program
+ &optional buffer display
+ &rest args)
+ ;; FIXME: This branching shouldn't be necessary, but
+ ;; call-process-region *is* measurably faster, even for a program
+ ;; doing some actual work (for a period of time). Even though
+ ;; call-process-region also creates a temp file internally
+ ;; (https://lists.gnu.org/archive/html/emacs-devel/2019-01/msg00211.html).
+ (if (not (file-remote-p default-directory))
+ (apply #'call-process-region
+ start end program nil buffer display args)
+ (let ((infile (make-temp-file "ppfr")))
+ (unwind-protect
+ (progn
+ (write-region start end infile nil 'silent)
+ (apply #'process-file program infile buffer display args))
+ (delete-file infile)))))
+
(defun xref--rgrep-command (regexp files dir ignores)
(require 'find-dired) ; for `find-name-arg'
(defvar grep-find-template)
@@ -1321,11 +1667,11 @@ directory, used as the root of the ignore globs."
(lambda (ignore)
(when (string-match-p "/\\'" ignore)
(setq ignore (concat ignore "*")))
- (if (string-match "\\`\\./" ignore)
- (setq ignore (replace-match dir t t ignore))
- (unless (string-prefix-p "*" ignore)
- (setq ignore (concat "*/" ignore))))
- (shell-quote-argument ignore))
+ (shell-quote-argument (if (string-match "\\`\\./" ignore)
+ (replace-match dir t t ignore)
+ (if (string-prefix-p "*" ignore)
+ ignore
+ (concat "*/" ignore)))))
ignores
" -o -path ")
" "
@@ -1368,8 +1714,8 @@ Such as the current syntax table and the applied syntax properties."
(let (xref--last-file-buffer
(tmp-buffer (generate-new-buffer " *xref-temp*")))
(unwind-protect
- (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer))
- hits)
+ (mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer))
+ hits)
(kill-buffer tmp-buffer))))
(defun xref--collect-matches (hit regexp tmp-buffer)
@@ -1412,20 +1758,30 @@ Such as the current syntax table and the applied syntax properties."
syntax-needed)))))
(defun xref--collect-matches-1 (regexp file line line-beg line-end syntax-needed)
- (let (matches)
+ (let (match-pairs matches)
(when syntax-needed
(syntax-propertize line-end))
- ;; FIXME: This results in several lines with the same
- ;; summary. Solve with composite pattern?
(while (and
;; REGEXP might match an empty string. Or line.
- (or (null matches)
+ (or (null match-pairs)
(> (point) line-beg))
(re-search-forward regexp line-end t))
- (let* ((beg-column (- (match-beginning 0) line-beg))
- (end-column (- (match-end 0) line-beg))
+ (push (cons (match-beginning 0)
+ (match-end 0))
+ match-pairs))
+ (setq match-pairs (nreverse match-pairs))
+ (while match-pairs
+ (let* ((beg-end (pop match-pairs))
+ (beg-column (- (car beg-end) line-beg))
+ (end-column (- (cdr beg-end) line-beg))
(loc (xref-make-file-location file line beg-column))
- (summary (buffer-substring line-beg line-end)))
+ (summary (buffer-substring (if matches (car beg-end) line-beg)
+ (if match-pairs
+ (caar match-pairs)
+ line-end))))
+ (when matches
+ (cl-decf beg-column (- (car beg-end) line-beg))
+ (cl-decf end-column (- (car beg-end) line-beg)))
(add-face-text-property beg-column end-column 'xref-match
t summary)
(push (xref-make-match summary loc (- end-column beg-column))
diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el
index 96870e365e1..613863dd613 100644
--- a/lisp/progmodes/xscheme.el
+++ b/lisp/progmodes/xscheme.el
@@ -104,20 +104,17 @@ reading-string reading prompt string")
(defcustom scheme-band-name nil
"Band loaded by the `run-scheme' command."
- :type '(choice (const nil) string)
- :group 'xscheme)
+ :type '(choice (const nil) string))
(defcustom scheme-program-arguments nil
"Arguments passed to the Scheme program by the `run-scheme' command."
- :type '(choice (const nil) string)
- :group 'xscheme)
+ :type '(choice (const nil) string))
(defcustom xscheme-allow-pipelined-evaluation t
"If non-nil, an expression may be transmitted while another is evaluating.
Otherwise, attempting to evaluate an expression before the previous expression
has finished evaluating will signal an error."
- :type 'boolean
- :group 'xscheme)
+ :type 'boolean)
(defcustom xscheme-startup-message
"This is the Scheme process buffer.
@@ -128,19 +125,16 @@ Type \\[describe-mode] for more information.
"
"String to insert into Scheme process buffer first time it is started.
Is processed with `substitute-command-keys' first."
- :type 'string
- :group 'xscheme)
+ :type 'string)
(defcustom xscheme-signal-death-message nil
"If non-nil, causes a message to be generated when the Scheme process dies."
- :type 'boolean
- :group 'xscheme)
+ :type 'boolean)
(defcustom xscheme-start-hook nil
"If non-nil, a procedure to call when the Scheme process is started.
When called, the current buffer will be the Scheme process-buffer."
:type 'hook
- :group 'xscheme
:version "20.3")
(defun xscheme-evaluation-commands (keymap)
@@ -173,7 +167,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))
- (set (make-local-variable 'xscheme-process-command-line) command-line))
+ (setq-local xscheme-process-command-line command-line))
(defun xscheme-read-command-line (arg)
(let ((default
@@ -264,11 +258,11 @@ With argument, asks for a command line."
xscheme-buffer-name
t)))
(let ((process-name (verify-xscheme-buffer buffer-name t)))
- (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))))
+ (setq-local xscheme-buffer-name buffer-name)
+ (setq-local xscheme-process-name process-name)
+ (setq-local 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."
@@ -375,10 +369,10 @@ Entry to this mode runs `scheme-mode-hook' and then
(kill-all-local-variables)
(make-local-variable 'xscheme-runlight-string)
(make-local-variable 'xscheme-runlight)
- (set (make-local-variable 'xscheme-previous-mode) previous-mode)
+ (setq-local xscheme-previous-mode previous-mode)
(let ((buffer (current-buffer)))
- (set (make-local-variable 'xscheme-buffer-name) (buffer-name buffer))
- (set (make-local-variable 'xscheme-last-input-end) (make-marker))
+ (setq-local xscheme-buffer-name (buffer-name buffer))
+ (setq-local xscheme-last-input-end (make-marker))
(let ((process (get-buffer-process buffer)))
(when process
(setq-local xscheme-process-name (process-name process))
@@ -446,8 +440,6 @@ Entry to this mode runs `scheme-mode-hook' and then
(scheme-interaction-mode-initialize)
(scheme-interaction-mode t)))))
-(define-obsolete-function-alias 'advertised-xscheme-send-previous-expression
- 'xscheme-send-previous-expression "23.2")
;;;; Debugger Mode
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index 7bf2f71822a..72cbcf8bd68 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -1,4 +1,4 @@
-;;; ps-bdf.el --- BDF font file handler for ps-print
+;;; ps-bdf.el --- BDF font file handler for ps-print -*- lexical-binding: t; -*-
;; Copyright (C) 1998-1999, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
@@ -138,7 +138,7 @@ See the documentation of the function `bdf-read-font-info' for more detail."
(defun bdf-initialize ()
"Initialize `bdf' library."
(and (bdf-read-cache)
- (add-hook 'kill-emacs-hook 'bdf-write-cache)))
+ (add-hook 'kill-emacs-hook #'bdf-write-cache)))
(defun bdf-compact-code (code code-range)
(if (or (< code (aref code-range 4))
diff --git a/lisp/ps-def.el b/lisp/ps-def.el
index 943098d96af..b9c3ab57a26 100644
--- a/lisp/ps-def.el
+++ b/lisp/ps-def.el
@@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
;; Keywords: wp, print, PostScript
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
;; This file is part of GNU Emacs.
@@ -55,24 +55,14 @@
(face-background face nil t))
-(defalias 'ps-frame-parameter 'frame-parameter)
+(define-obsolete-function-alias 'ps-frame-parameter #'frame-parameter "28.1")
;; Return t if the device (which can be changed during an emacs session) can
-;; handle colors. This function is not yet implemented for GNU emacs.
+;; handle colors.
(defun ps-color-device ()
- (if (fboundp 'color-values)
- (funcall 'color-values "Green")
- t))
-
-
-(defun ps-color-values (x-color)
- (cond
- ((fboundp 'color-values)
- (funcall 'color-values x-color))
- ((fboundp 'x-color-values)
- (funcall 'x-color-values x-color))
- (t
- (error "No available function to determine X color values"))))
+ (color-values "Green"))
+
+(define-obsolete-function-alias 'ps-color-values #'color-values "28.1")
(defun ps-face-bold-p (face)
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index db86f9400e7..ab8af40628a 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -1,4 +1,4 @@
-;;; ps-mule.el --- provide multi-byte character facility to ps-print
+;;; ps-mule.el --- provide multi-byte character facility to ps-print -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -612,7 +612,7 @@ f2, f3, h0, h1, and H0 respectively."
(push (/ code 256) code-list)
(push (% code 256) code-list))))
(forward-char 1)))
- (apply 'unibyte-string (nreverse code-list))))
+ (apply #'unibyte-string (nreverse code-list))))
(defun ps-mule-plot-composition (composition font-spec-table)
"Generate PostScript code for plotting COMPOSITION with FONT-SPEC-TABLE."
@@ -673,7 +673,7 @@ the sequence."
(not (vectorp (aref (nth 2 composition) 0))))
(car composition)
to))
- (ascii-or-latin-1 "[\000-\377]+")
+ (ascii-or-latin-1 "[\000-ÿ]+")
(run-width 0)
(endpos nil)
(font-spec-table (aref ps-mule-font-spec-tables
@@ -699,6 +699,7 @@ the sequence."
(setq composition (find-composition (point) to nil t))
(setq stop (if composition (car composition) to)))))
+ ;; We fold lines that contain ASCII or Latin-1.
((looking-at ascii-or-latin-1)
(let ((nchars (- (min (match-end 0) stop) (point))))
(setq width (* average-width nchars))
@@ -710,6 +711,7 @@ the sequence."
(setq run-width (+ run-width width))
(forward-char nchars))))
+ ;; Don't fold other lines. (But why?)
(t
(while (and (< (point) stop) (not endpos))
(setq width (char-width (following-char)))
@@ -1041,10 +1043,11 @@ Any other value is treated as \"/H0\"."
(list (ps-mule-encode-region (point-min) (point-max)
(aref ps-mule-font-spec-tables
(aref ps-mule-font-number-to-type
- (cond ((string= fonttag "/h0") 4)
- ((string= fonttag "/h1") 5)
- ((string= fonttag "/L0") 6)
- (t 0))))))))
+ (pcase fonttag
+ ("/h0" 4)
+ ("/h1" 5)
+ ("/L0" 6)
+ (_ 0))))))))
;;;###autoload
(defun ps-mule-begin-job (from to)
@@ -1055,20 +1058,17 @@ It checks if all multi-byte characters in the region are printable or not."
(goto-char from)
(= (skip-chars-forward "\x00-\x7F" to) to)))
;; All characters can be printed by normal PostScript fonts.
- (setq ps-basic-plot-string-function 'ps-basic-plot-string
+ (setq ps-basic-plot-string-function #'ps-basic-plot-string
;; FIXME: Doesn't ps-encode-header-string-function take 2 args?
- ps-encode-header-string-function 'identity)
- (setq ps-basic-plot-string-function 'ps-mule-plot-string
- ps-encode-header-string-function 'ps-mule-encode-header-string
+ ps-encode-header-string-function #'identity)
+ (setq ps-basic-plot-string-function #'ps-mule-plot-string
+ ps-encode-header-string-function #'ps-mule-encode-header-string
ps-mule-font-info-database
- (cond ((eq ps-multibyte-buffer 'non-latin-printer)
- ps-mule-font-info-database-ps)
- ((eq ps-multibyte-buffer 'bdf-font)
- ps-mule-font-info-database-bdf)
- ((eq ps-multibyte-buffer 'bdf-font-except-latin)
- ps-mule-font-info-database-ps-bdf)
- (t
- ps-mule-font-info-database-default)))
+ (pcase ps-multibyte-buffer
+ ('non-latin-printer ps-mule-font-info-database-ps)
+ ('bdf-font ps-mule-font-info-database-bdf)
+ ('bdf-font-except-latin ps-mule-font-info-database-ps-bdf)
+ (_ ps-mule-font-info-database-default)))
;; Be sure to have font information for Latin-1.
(or (assq 'iso-8859-1 ps-mule-font-info-database)
@@ -1112,10 +1112,12 @@ It checks if all multi-byte characters in the region are printable or not."
id-max (1+ id-max))
(if (ps-mule-check-font font-spec)
(aset font-spec-vec
- (cond ((eq (car e) 'normal) 0)
- ((eq (car e) 'bold) 1)
- ((eq (car e) 'italic) 2)
- (t 3)) font-spec)))
+ (pcase (car e)
+ ('normal 0)
+ ('bold 1)
+ ('italic 2)
+ (_ 3))
+ font-spec)))
(when (aref font-spec-vec 0)
(or (aref font-spec-vec 3)
(aset font-spec-vec 3 (or (aref font-spec-vec 1)
@@ -1182,7 +1184,7 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n"
(let ((output-head (list t))
(ps-mule-output-list (list t)))
(dotimes (i 4)
- (map-char-table 'ps-mule-prepare-glyph
+ (map-char-table #'ps-mule-prepare-glyph
(aref ps-mule-font-spec-tables i)))
(ps-mule-restruct-output-list (cdr ps-mule-output-list) output-head)
(ps-output-prologue (cdr output-head)))
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 7b76dcff083..1b8654ead2b 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -9,7 +9,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
;; Version: 7.3.5
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
(eval-when-compile (require 'cl-lib))
@@ -3856,7 +3856,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'."
(defun ps-color-scale (color)
;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
(mapcar #'(lambda (value) (/ value ps-print-color-scale))
- (ps-color-values color)))
+ (color-values color)))
(defun ps-face-underlined-p (face)
@@ -4114,7 +4114,6 @@ If EXTENSION is any other symbol, it is ignored."
(defun ps-message-log-max ()
(and (not (string= (buffer-name) "*Messages*"))
- (boundp 'message-log-max)
message-log-max))
@@ -4523,7 +4522,7 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th
(let* ((name (concat (file-name-nondirectory (or (buffer-file-name)
(buffer-name)))
".ps"))
- (prompt (format "Save PostScript to file (default %s): " name))
+ (prompt (format-prompt "Save PostScript to file" name))
(res (read-file-name prompt default-directory name nil)))
(while (cond ((file-directory-p res)
(ding)
@@ -5752,7 +5751,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
;; evaluated at dump-time because X isn't initialized.
ps-color-p (and ps-print-color-p (ps-color-device))
ps-print-color-scale (if ps-color-p
- (float (car (ps-color-values "white")))
+ (float (car (color-values "white")))
1.0)
ps-default-background (ps-rgb-color
(cond
@@ -5761,7 +5760,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(eq genfunc 'ps-generate-postscript))
nil)
((eq ps-default-bg 'frame-parameter)
- (ps-frame-parameter nil 'background-color))
+ (frame-parameter nil 'background-color))
((eq ps-default-bg t)
(ps-face-background-name 'default))
(t
@@ -5775,7 +5774,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(eq genfunc 'ps-generate-postscript))
nil)
((eq ps-default-fg 'frame-parameter)
- (ps-frame-parameter nil 'foreground-color))
+ (frame-parameter nil 'foreground-color))
((eq ps-default-fg t)
(ps-face-foreground-name 'default))
(t
@@ -6275,10 +6274,6 @@ If FACE is not a valid face name, use default face."
(goto-char to))
-;; Ensure that face-list is fbound.
-(or (fboundp 'face-list) (defalias 'face-list 'list-faces))
-
-
(defun ps-build-reference-face-lists ()
(setq ps-print-face-alist nil)
(if ps-auto-font-detect
@@ -6511,10 +6506,11 @@ If FACE is not a valid face name, use default face."
(and (buffer-live-p ps-buffer)
(buffer-modified-p ps-buffer)
(not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
- (error "Unprinted PostScript"))))
+ (error "Unprinted PostScript")))
+ t)
(unless noninteractive
- (add-hook 'kill-emacs-hook #'ps-kill-emacs-check))
+ (add-hook 'kill-emacs-query-functions #'ps-kill-emacs-check))
(provide 'ps-print)
diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el
index 1e8e2486a56..22a29b8b4b1 100644
--- a/lisp/ps-samp.el
+++ b/lisp/ps-samp.el
@@ -1,4 +1,4 @@
-;;; ps-samp.el --- ps-print sample setup code
+;;; ps-samp.el --- ps-print sample setup code -*- lexical-binding: t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -8,7 +8,7 @@
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: wp, print, PostScript
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/recentf.el b/lisp/recentf.el
index fee6e842a8a..9ae059a70dd 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1,4 +1,4 @@
-;;; recentf.el --- setup a menu of recently opened files
+;;; recentf.el --- setup a menu of recently opened files -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -24,20 +24,21 @@
;;; Commentary:
;; This package maintains a menu for visiting files that were operated
-;; on recently. When enabled a new "Open Recent" sub menu is
+;; on recently. When enabled a new "Open Recent" submenu is
;; displayed in the "File" menu. The recent files list is
-;; automatically saved across Emacs sessions. You can customize the
-;; number of recent files displayed, the location of the menu and
-;; others options (see the source code for details).
+;; automatically saved across Emacs sessions.
-;; To enable this package, add the following to your .emacs:
-;; (recentf-mode 1)
+;; You can customize the number of recent files displayed, the
+;; location of the menu and others options. Type:
+;;
+;; M-x customize-group RET recentf RET
-;;; History:
+;; To enable this package, add this line to your Init file:
;;
+;; (recentf-mode 1)
;;; Code:
-(require 'easymenu)
+
(require 'tree-widget)
(require 'timer)
@@ -77,7 +78,7 @@ See the command `recentf-save-list'."
:type 'file
:initialize 'custom-initialize-default
:set (lambda (symbol value)
- (let ((oldvalue (eval symbol)))
+ (let ((oldvalue (symbol-value symbol)))
(custom-set-default symbol value)
(and (not (equal value oldvalue))
recentf-mode
@@ -245,7 +246,10 @@ The following values can be set:
- A number
Cleanup each time Emacs has been idle that number of seconds.
- A time string
- Cleanup at specified time string, for example at \"11:00pm\".
+ Cleanup at specified time string daily, for example at \"11:00pm\".
+
+If a time string is provided and it is already past the specified time
+for the current day, the first cleanup happens immediately as for `mode'.
Setting this variable directly does not take effect;
use \\[customize].
@@ -257,7 +261,7 @@ cleanup the list."
:value mode)
(const :tag "Never"
:value never)
- (number :tag "When idle that seconds"
+ (number :tag "When idle after (seconds)"
:value 300)
(string :tag "At time"
:value "11:00pm"))
@@ -277,6 +281,8 @@ If `file-name-history' is not empty, do nothing."
"Normal hook run at end of loading the `recentf' package."
:group 'recentf
:type 'hook)
+(make-obsolete-variable 'recentf-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom recentf-filename-handlers nil
"Functions to post process recent file names.
@@ -291,7 +297,7 @@ They are successively passed a file name to transform it."
(function :tag "Other function")))))
(defcustom recentf-show-file-shortcuts-flag t
- "Whether to show \"[N]\" for the Nth item up to 10.
+ "Non-nil means to show \"[N]\" for the Nth item up to 10.
If non-nil, `recentf-open-files' will show labels for keys that can be
used as shortcuts to open the Nth file."
:group 'recentf
@@ -326,15 +332,6 @@ Ignore case if `recentf-case-fold-search' is non-nil."
(setq list (cdr list)))
list)
-(defsubst recentf-trunc-list (l n)
- "Return from L the list of its first N elements."
- (let (nl)
- (while (and l (> n 0))
- (setq nl (cons (car l) nl)
- n (1- n)
- l (cdr l)))
- (nreverse nl)))
-
(defun recentf-dump-variable (variable &optional limit)
"Insert a \"(setq VARIABLE value)\" in the current buffer.
When the value of VARIABLE is a list, optional argument LIMIT
@@ -344,7 +341,7 @@ the full list."
(if (atom value)
(insert (format "\n(setq %S '%S)\n" variable value))
(when (and (integerp limit) (> limit 0))
- (setq value (recentf-trunc-list value limit)))
+ (setq value (seq-take value limit)))
(insert (format "\n(setq %S\n '(" variable))
(dolist (e value)
(insert (format "\n %S" e)))
@@ -369,7 +366,8 @@ See also the option `recentf-auto-cleanup'.")
recentf-auto-cleanup t 'recentf-cleanup))
((stringp recentf-auto-cleanup)
(run-at-time
- recentf-auto-cleanup nil 'recentf-cleanup))))))
+ ;; Repeat every 24 hours.
+ recentf-auto-cleanup (* 24 60 60) 'recentf-cleanup))))))
;;; File functions
;;
@@ -514,7 +512,7 @@ filter function this variable is reset to nil.")
(defsubst recentf-elements (n)
"Return a list of the first N elements of the recent list."
- (recentf-trunc-list recentf-list n))
+ (seq-take recentf-list n))
(defsubst recentf-make-menu-element (menu-item menu-value)
"Create a new menu-element.
@@ -554,7 +552,7 @@ This a menu element (FILE . FILE)."
(defsubst recentf-menu-elements (n)
"Return a list of the first N default menu elements from the recent list.
See also `recentf-make-default-menu-element'."
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
(recentf-elements n)))
(defun recentf-apply-menu-filter (filter l)
@@ -595,7 +593,7 @@ This is a menu filter function which ignores the MENU argument."
(let* ((recentf-menu-shortcuts 0)
(file-items
(condition-case err
- (mapcar 'recentf-make-menu-item
+ (mapcar #'recentf-make-menu-item
(recentf-apply-menu-filter
recentf-menu-filter
(recentf-menu-elements recentf-max-menu-items)))
@@ -637,7 +635,7 @@ Return nil if file NAME is not one of the ten more recent."
(let ((item (recentf-menu-element-item elt))
(value (recentf-menu-element-value elt)))
(if (recentf-sub-menu-element-p elt)
- (cons item (mapcar 'recentf-make-menu-item value))
+ (cons item (mapcar #'recentf-make-menu-item value))
(let ((k (and (< recentf-menu-shortcuts 10)
(recentf-menu-value-shortcut value))))
(vector item
@@ -762,12 +760,12 @@ This filter combines the `recentf-sort-basenames-descending' and
(defun recentf-relative-filter (l)
"Filter the list of menu-elements L to show relative filenames.
Filenames are relative to the `default-directory'."
- (mapcar #'(lambda (menu-element)
- (let* ((ful (recentf-menu-element-value menu-element))
- (rel (file-relative-name ful default-directory)))
- (if (string-match "^\\.\\." rel)
- menu-element
- (recentf-make-menu-element rel ful))))
+ (mapcar (lambda (menu-element)
+ (let* ((ful (recentf-menu-element-value menu-element))
+ (rel (file-relative-name ful default-directory)))
+ (if (string-match "^\\.\\." rel)
+ menu-element
+ (recentf-make-menu-element rel ful))))
l))
;;; Rule based menu filters
@@ -939,10 +937,10 @@ Rules obey `recentf-arrange-rules' format."
This simplified version of `recentf-show-basenames' does not handle
duplicates. It is used by `recentf-arrange-by-dir' as its
`recentf-arrange-by-rule-subfilter'."
- (mapcar #'(lambda (e)
- (recentf-make-menu-element
- (file-name-nondirectory (recentf-menu-element-value e))
- (recentf-menu-element-value e)))
+ (mapcar (lambda (e)
+ (recentf-make-menu-element
+ (file-name-nondirectory (recentf-menu-element-value e))
+ (recentf-menu-element-value e)))
l))
(defun recentf-dir-rule (file)
@@ -995,15 +993,15 @@ Filtering of L is delegated to the selected filter in the menu."
(list
`("Show files"
,@(mapcar
- #'(lambda (f)
- `[,(cdr f)
- (setq recentf-filter-changer-current ',(car f))
- ;;:active t
- :style radio ;;radio Don't work with GTK :-(
- :selected (eq recentf-filter-changer-current
- ',(car f))
- ;;:help ,(cdr f)
- ])
+ (lambda (f)
+ `[,(cdr f)
+ (setq recentf-filter-changer-current ',(car f))
+ ;;:active t
+ :style radio ;;radio Don't work with GTK :-(
+ :selected (eq recentf-filter-changer-current
+ ',(car f))
+ ;;:help ,(cdr f)
+ ])
recentf-filter-changer-alist))))
(recentf-apply-menu-filter recentf-filter-changer-current l)))
@@ -1060,9 +1058,9 @@ Go to the beginning of buffer if not found."
(defvar recentf-dialog-mode-map
(let ((km (copy-keymap recentf--shortcuts-keymap)))
(set-keymap-parent km widget-keymap)
- (define-key km "q" 'recentf-cancel-dialog)
- (define-key km "n" 'next-line)
- (define-key km "p" 'previous-line)
+ (define-key km "q" #'recentf-cancel-dialog)
+ (define-key km "n" #'next-line)
+ (define-key km "p" #'previous-line)
km)
"Keymap used in recentf dialogs.")
@@ -1081,8 +1079,8 @@ Go to the beginning of buffer if not found."
;; Cleanup buffer
(let ((inhibit-read-only t)
(ol (overlay-lists)))
- (mapc 'delete-overlay (car ol))
- (mapc 'delete-overlay (cdr ol))
+ (mapc #'delete-overlay (car ol))
+ (mapc #'delete-overlay (cdr ol))
(erase-buffer))
(recentf-dialog-mode)
,@forms
@@ -1121,7 +1119,7 @@ IGNORE arguments."
(unless recentf-list
(error "The list of recent files is empty"))
(recentf-dialog (format "*%s - Edit list*" recentf-menu-title)
- (set (make-local-variable 'recentf-edit-list) nil)
+ (setq-local recentf-edit-list nil)
(widget-insert
(format-message
"Click on OK to delete selected files from the recent list.
@@ -1176,7 +1174,7 @@ IGNORE other arguments."
:node (item :tag ,(car menu-element)
:sample-face bold
:format "%{%t%}:\n")
- ,@(mapcar 'recentf-open-files-item
+ ,@(mapcar #'recentf-open-files-item
(cdr menu-element)))
;; Represent a single file with a link widget
`(link :tag ,(car menu-element)
@@ -1190,9 +1188,9 @@ IGNORE other arguments."
(defun recentf-open-files-items (files)
"Return a list of widgets to display FILES in a dialog buffer."
- (set (make-local-variable 'recentf--files-with-key)
- (recentf-trunc-list files 10))
- (mapcar 'recentf-open-files-item
+ (setq-local recentf--files-with-key
+ (seq-take files 10))
+ (mapcar #'recentf-open-files-item
(append
;; When requested group the files with shortcuts together
;; at the top of the list.
@@ -1200,12 +1198,12 @@ IGNORE other arguments."
(setq files (nthcdr 10 files))
(recentf-apply-menu-filter
'recentf-show-digit-shortcut-filter
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
recentf--files-with-key)))
;; Then the other files.
(recentf-apply-menu-filter
recentf-menu-filter
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
files)))))
(defun recentf-open-files (&optional files buffer-name)
@@ -1226,7 +1224,7 @@ use for the dialog. It defaults to \"*`recentf-menu-title'*\"."
(format-message "Click on Cancel or type `q' to cancel.\n"))
;; Use a L&F that looks like the recentf menu.
(tree-widget-set-theme "folder")
- (apply 'widget-create
+ (apply #'widget-create
`(group
:indent 2
:format "\n%v\n"
@@ -1287,7 +1285,8 @@ Write data into the file specified by `recentf-save-file'."
(insert "\n \n;; Local Variables:\n"
(format ";; coding: %s\n" recentf-save-file-coding-system)
";; End:\n")
- (write-file (expand-file-name recentf-save-file))
+ (write-region (point-min) (point-max)
+ (expand-file-name recentf-save-file))
(when recentf-save-file-modes
(set-file-modes recentf-save-file recentf-save-file-modes))
nil)
@@ -1307,7 +1306,7 @@ empty `file-name-history' with the recent list."
(load-file file)
(and recentf-initialize-file-name-history
(not file-name-history)
- (setq file-name-history (mapcar 'abbreviate-file-name
+ (setq file-name-history (mapcar #'abbreviate-file-name
recentf-list))))))
(defun recentf-cleanup ()
@@ -1345,7 +1344,14 @@ That is, remove duplicates, non-kept, and excluded files."
When Recentf mode is enabled, a \"Open Recent\" submenu is
displayed in the \"File\" menu, containing a list of files that
-were operated on recently, in the most-recently-used order."
+were operated on recently, in the most-recently-used order.
+
+By default, only operations like opening a file, writing a buffer
+to a file, and killing a buffer is counted as \"operating\" on
+the file. If instead you want to prioritize files that appear in
+buffers you switch to a lot, you can say something like the following:
+
+ (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)"
:global t
:group 'recentf
:keymap recentf-mode-map
@@ -1367,6 +1373,10 @@ were operated on recently, in the most-recently-used order."
;; continue standard unloading
nil)
+;; Obsolete.
+
+(define-obsolete-function-alias 'recentf-trunc-list #'seq-take "28.1")
+
(provide 'recentf)
(run-hooks 'recentf-load-hook)
diff --git a/lisp/rect.el b/lisp/rect.el
index e26c377a70d..504be41b673 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -521,8 +521,9 @@ Called from a program, takes three args; START, END and STRING."
#'rectangle--string-erase-preview nil t)
(add-hook 'post-command-hook
#'rectangle--string-preview nil t))
- (read-string (format "String rectangle (default %s): "
- (or (car string-rectangle-history) ""))
+ (read-string (format-prompt
+ "String rectangle"
+ (or (car string-rectangle-history) ""))
nil 'string-rectangle-history
(car string-rectangle-history)
'inherit-input-method))))))
@@ -549,8 +550,8 @@ This command does not delete or overwrite any existing text."
(list
(region-beginning)
(region-end)
- (read-string (format "String insert rectangle (default %s): "
- (or (car string-rectangle-history) ""))
+ (read-string (format-prompt "String insert rectangle"
+ (or (car string-rectangle-history) ""))
nil 'string-rectangle-history
(car string-rectangle-history)))))
(apply-on-rectangle 'string-rectangle-line start end string nil))
@@ -651,7 +652,7 @@ with a prefix argument, prompt for START-AT and FORMAT."
"Toggle the region as rectangular.
Activates the region if needed. Only lasts until the region is deactivated."
- nil nil nil
+ :lighter nil
(rectangle--reset-crutches)
(when rectangle-mark-mode
(add-hook 'deactivate-mark-hook
diff --git a/lisp/registry.el b/lisp/registry.el
index fb23bd53c85..258f7fc9046 100644
--- a/lisp/registry.el
+++ b/lisp/registry.el
@@ -1,4 +1,4 @@
-;;; registry.el --- Track and remember data items by various fields
+;;; registry.el --- Track and remember data items by various fields -*- lexical-binding: t; -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
@@ -128,7 +128,7 @@
:type hash-table
:documentation "The data hash table.")))
-(cl-defmethod initialize-instance :before ((this registry-db) slots)
+(cl-defmethod initialize-instance :before ((_this registry-db) slots)
"Check whether a registry object needs to be upgraded."
;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the
;; :max-soft slot to disappear, and the :max-hard slot to be renamed
@@ -212,7 +212,7 @@ When SET is not nil, set it for VAL (use t for an empty list)."
(:regex
(string-match (car vals)
(mapconcat
- 'prin1-to-string
+ #'prin1-to-string
(cdr-safe (assoc key entry))
"\0"))))
vals (cdr-safe vals)))
@@ -247,7 +247,7 @@ 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)))
+ (apply #'registry-search db spec)))
(tracked (oref db tracked)))
(dolist (key keys)
@@ -308,19 +308,18 @@ Errors out if the key exists already."
(let ((count 0)
(expected (* (length (oref db tracked)) (registry-size db))))
(dolist (tr (oref db tracked))
- (let (values)
- (maphash
- (lambda (key v)
- (cl-incf count)
- (when (and (< 0 expected)
- (= 0 (mod count 1000)))
- (message "reindexing: %d of %d (%.2f%%)"
- count expected (/ (* 100.0 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))))))
+ (maphash
+ (lambda (key v)
+ (cl-incf count)
+ (when (and (< 0 expected)
+ (= 0 (mod count 1000)))
+ (message "reindexing: %d of %d (%.2f%%)"
+ count expected (/ (* 100.0 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)))))
(cl-defmethod registry-prune ((db registry-db) &optional sortfunc)
"Prune the registry-db object DB.
diff --git a/lisp/repeat.el b/lisp/repeat.el
index 705ae5f7a10..cec3cb643a1 100644
--- a/lisp/repeat.el
+++ b/lisp/repeat.el
@@ -4,7 +4,7 @@
;; Author: Will Mengarini <seldon@eskimo.com>
;; Created: Mo 02 Mar 98
-;; Version: 0.51
+;; Old-Version: 0.51
;; Keywords: convenience, vi, repeat
;; This file is part of GNU Emacs.
@@ -85,10 +85,6 @@
;; C-x { shrink-window-horizontally
;; C-x } enlarge-window-horizontally
-;; This command was first called `vi-dot', because
-;; it was inspired by the `.' command in the vi editor,
-;; but it was renamed to make its name more meaningful.
-
;;; Code:
;;;;; ************************* USER OPTIONS ************************** ;;;;;
@@ -184,7 +180,7 @@ this function is always whether the value of `this-command' would've been
(= repeat-num-input-keys-at-repeat num-input-keys))
;; An example of the use of (repeat-is-really-this-command) may still be
-;; available in <http://www.eskimo.com/~seldon/dotemacs.el>; search for
+;; available in <https://www.eskimo.com/~seldon/dotemacs.el>; search for
;; "defun wm-switch-buffer".
;;;;; ******************* THE REPEAT COMMAND ITSELF ******************* ;;;;;
@@ -243,9 +239,7 @@ recently executed command not bound to an input event\"."
(car (memq last-command-event
(listify-key-sequence
repeat-on-final-keystroke))))))
- (if (memq last-repeatable-command '(exit-minibuffer
- minibuffer-complete-and-exit
- self-insert-and-exit))
+ (if (eq last-repeatable-command (caar command-history))
(let ((repeat-command (car command-history)))
(repeat-message "Repeating %S" repeat-command)
(eval repeat-command))
@@ -335,6 +329,188 @@ recently executed command not bound to an input event\"."
;;;;; ************************* EMACS CONTROL ************************* ;;;;;
+
+;; And now for something completely different.
+
+;;; repeat-mode
+
+(defcustom repeat-exit-key nil
+ "Key that stops the modal repeating of keys in sequence.
+For example, you can set it to <return> like `isearch-exit'."
+ :type '(choice (const :tag "No special key to exit repeating sequence" nil)
+ (key-sequence :tag "Key that exits repeating sequence"))
+ :group 'convenience
+ :version "28.1")
+
+(defcustom repeat-exit-timeout nil
+ "Break the repetition chain of keys after specified timeout.
+When a number, exit the repeat mode after idle time of the specified
+number of seconds."
+ :type '(choice (const :tag "No timeout to exit repeating sequence" nil)
+ (number :tag "Timeout in seconds to exit repeating"))
+ :group 'convenience
+ :version "28.1")
+
+(defvar repeat-exit-timer nil
+ "Timer activated after the last key typed in the repeating key sequence.")
+
+(defcustom repeat-keep-prefix t
+ "Keep the prefix arg of the previous command."
+ :type 'boolean
+ :group 'convenience
+ :version "28.1")
+
+(defcustom repeat-echo-function #'repeat-echo-message
+ "Function to display a hint about available keys.
+Function is called after every repeatable command with one argument:
+a repeating map, or nil after deactivating the repeat mode."
+ :type '(choice (const :tag "Show hints in the echo area"
+ repeat-echo-message)
+ (const :tag "Show indicator in the mode line"
+ repeat-echo-mode-line)
+ (const :tag "No visual feedback" ignore)
+ (function :tag "Function"))
+ :group 'convenience
+ :version "28.1")
+
+(defvar repeat-in-progress nil
+ "Non-nil when the repeating map is active.")
+
+;;;###autoload
+(defvar repeat-map nil
+ "The value of the repeating map for the next command.
+A command called from the map can set it again to the same map when
+the map can't be set on the command symbol property `repeat-map'.")
+
+;;;###autoload
+(define-minor-mode repeat-mode
+ "Toggle Repeat mode.
+When Repeat mode is enabled, and the command symbol has the property named
+`repeat-map', this map is activated temporarily for the next command."
+ :global t :group 'convenience
+ (if (not repeat-mode)
+ (remove-hook 'post-command-hook 'repeat-post-hook)
+ (add-hook 'post-command-hook 'repeat-post-hook)
+ (let* ((keymaps nil)
+ (commands (all-completions
+ "" obarray (lambda (s)
+ (and (commandp s)
+ (get s 'repeat-map)
+ (push (get s 'repeat-map) keymaps))))))
+ (message "Repeat mode is enabled for %d commands and %d keymaps; see `describe-repeat-maps'."
+ (length commands)
+ (length (delete-dups keymaps))))))
+
+(defun repeat-post-hook ()
+ "Function run after commands to set transient keymap for repeatable keys."
+ (let ((was-in-progress repeat-in-progress))
+ (setq repeat-in-progress nil)
+ (when repeat-mode
+ (let ((rep-map (or repeat-map
+ (and (symbolp real-this-command)
+ (get real-this-command 'repeat-map)))))
+ (when rep-map
+ (when (boundp rep-map)
+ (setq rep-map (symbol-value rep-map)))
+ (let ((map (copy-keymap rep-map)))
+
+ ;; Exit when the last char is not among repeatable keys,
+ ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't.
+ (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts
+ (or (lookup-key map (this-command-keys-vector))
+ prefix-arg))
+
+ ;; Messaging
+ (unless prefix-arg
+ (funcall repeat-echo-function map))
+
+ ;; Adding an exit key
+ (when repeat-exit-key
+ (define-key map repeat-exit-key 'ignore))
+
+ (when (and repeat-keep-prefix (not prefix-arg))
+ (setq prefix-arg current-prefix-arg))
+
+ (setq repeat-in-progress t)
+ (let ((exitfun (set-transient-map map)))
+
+ (when repeat-exit-timer
+ (cancel-timer repeat-exit-timer)
+ (setq repeat-exit-timer nil))
+
+ (when repeat-exit-timeout
+ (setq repeat-exit-timer
+ (run-with-idle-timer
+ repeat-exit-timeout nil
+ (lambda ()
+ (setq repeat-in-progress nil)
+ (funcall exitfun)
+ (funcall repeat-echo-function nil)))))))))))
+
+ (setq repeat-map nil)
+ (when (and was-in-progress (not repeat-in-progress))
+ (when repeat-exit-timer
+ (cancel-timer repeat-exit-timer)
+ (setq repeat-exit-timer nil))
+ (funcall repeat-echo-function nil))))
+
+(defun repeat-echo-message-string (keymap)
+ "Return a string with a list of repeating keys."
+ (let (keys)
+ (map-keymap (lambda (key _) (push key keys)) keymap)
+ (format-message "Repeat with %s%s"
+ (mapconcat (lambda (key)
+ (key-description (vector key)))
+ keys ", ")
+ (if repeat-exit-key
+ (format ", or exit with %s"
+ (key-description repeat-exit-key))
+ ""))))
+
+(defun repeat-echo-message (keymap)
+ "Display available repeating keys in the echo area."
+ (if keymap
+ (let ((mess (repeat-echo-message-string keymap)))
+ (if (current-message)
+ (message "%s [%s]" (current-message) mess)
+ (message mess)))
+ (when (string-prefix-p "Repeat with " (current-message))
+ (message nil))))
+
+(defvar repeat-echo-mode-line-string
+ (propertize "[Repeating...] " 'face 'mode-line-emphasis)
+ "String displayed in the mode line in repeating mode.")
+
+(defun repeat-echo-mode-line (keymap)
+ "Display the repeat indicator in the mode line."
+ (if keymap
+ (unless (assq 'repeat-in-progress mode-line-modes)
+ (add-to-list 'mode-line-modes (list 'repeat-in-progress
+ repeat-echo-mode-line-string)))
+ (force-mode-line-update t)))
+
+(defun describe-repeat-maps ()
+ "Describe mappings of commands repeatable by symbol property `repeat-map'."
+ (interactive)
+ (help-setup-xref (list #'describe-repeat-maps)
+ (called-interactively-p 'interactive))
+ (let ((keymaps nil))
+ (all-completions
+ "" obarray (lambda (s)
+ (and (commandp s)
+ (get s 'repeat-map)
+ (push s (alist-get (get s 'repeat-map) keymaps)))))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n")
+
+ (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b)))))
+ (princ (format-message "`%s' keymap is repeatable by these commands:\n"
+ (car keymap)))
+ (dolist (command (sort (cdr keymap) 'string-lessp))
+ (princ (format-message " `%s'\n" command)))
+ (princ "\n"))))))
+
(provide 'repeat)
;;; repeat.el ends here
diff --git a/lisp/replace.el b/lisp/replace.el
index 43534d23bb5..54d652b2ed8 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -126,6 +126,18 @@ This variable affects only `query-replace-regexp'."
:type 'boolean
:group 'matching)
+(defcustom query-replace-highlight-submatches t
+ "Whether to highlight regexp subexpressions during query replacement.
+The faces used to do the highlights are named `isearch-group-1',
+`isearch-group-2', etc. (By default, only these 2 are defined.)
+When there are more matches than faces, then faces are reused from the
+beginning, in a cyclical manner, so the `isearch-group-1' face is
+isreused for the third match. If you want to use more distinctive colors,
+you can define more of these faces using the same numbering scheme."
+ :type 'boolean
+ :group 'matching
+ :version "28.1")
+
(defcustom query-replace-lazy-highlight t
"Controls the lazy-highlighting during query replacements.
When non-nil, all text in the buffer matching the current match
@@ -174,6 +186,21 @@ See `replace-regexp' and `query-replace-regexp-eval'.")
length)
length)))))
+(defun query-replace-read-from-suggestions ()
+ "Return a list of standard suggestions for `query-replace-read-from'.
+By default, the list includes the active region, the identifier
+(a.k.a. \"tag\") at point (see Info node `(emacs) Identifier Search'),
+the last isearch string, and the last replacement regexp.
+`query-replace-read-from' appends the list returned
+by this function to the end of values available via
+\\<minibuffer-local-map>\\[next-history-element]."
+ (delq nil (list (when (use-region-p)
+ (buffer-substring-no-properties
+ (region-beginning) (region-end)))
+ (find-tag-default)
+ (car search-ring)
+ (car (symbol-value query-replace-from-history-variable)))))
+
(defun query-replace-read-from (prompt regexp-flag)
"Query and return the `from' argument of a query-replace operation.
Prompt with PROMPT. REGEXP-FLAG non-nil means the response should be a regexp.
@@ -208,12 +235,15 @@ wants to replace FROM with TO."
(minibuffer-allow-text-properties t) ; separator uses text-properties
(prompt
(cond ((and query-replace-defaults separator)
- (format "%s (default %s): " prompt (car minibuffer-history)))
+ (format-prompt prompt (car minibuffer-history)))
(query-replace-defaults
- (format "%s (default %s -> %s): " prompt
- (query-replace-descr (caar query-replace-defaults))
- (query-replace-descr (cdar query-replace-defaults))))
- (t (format "%s: " prompt))))
+ (format-prompt
+ prompt (format "%s -> %s"
+ (query-replace-descr
+ (caar query-replace-defaults))
+ (query-replace-descr
+ (cdar query-replace-defaults)))))
+ (t (format-prompt prompt nil))))
(from
;; The save-excursion here is in case the user marks and copies
;; a region in order to specify the minibuffer input.
@@ -227,7 +257,8 @@ wants to replace FROM with TO."
(if regexp-flag
(read-regexp prompt nil 'minibuffer-history)
(read-from-minibuffer
- prompt nil nil nil nil (car search-ring) t)))))
+ prompt nil nil nil nil
+ (query-replace-read-from-suggestions) t)))))
(to))
(if (and (zerop (length from)) query-replace-defaults)
(cons (caar query-replace-defaults)
@@ -312,14 +343,15 @@ Prompt with PROMPT. REGEXP-FLAG non-nil means the response should a regexp."
(defun query-replace-read-args (prompt regexp-flag &optional noerror)
(unless noerror
(barf-if-buffer-read-only))
- (let* ((from (query-replace-read-from prompt regexp-flag))
- (to (if (consp from) (prog1 (cdr from) (setq from (car from)))
- (query-replace-read-to from prompt regexp-flag))))
- (list from to
- (or (and current-prefix-arg (not (eq current-prefix-arg '-)))
- (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function)
- (get-text-property 0 'isearch-regexp-function from)))
- (and current-prefix-arg (eq current-prefix-arg '-)))))
+ (save-mark-and-excursion
+ (let* ((from (query-replace-read-from prompt regexp-flag))
+ (to (if (consp from) (prog1 (cdr from) (setq from (car from)))
+ (query-replace-read-to from prompt regexp-flag))))
+ (list from to
+ (or (and current-prefix-arg (not (eq current-prefix-arg '-)))
+ (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function)
+ (get-text-property 0 'isearch-regexp-function from)))
+ (and current-prefix-arg (eq current-prefix-arg '-))))))
(defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p)
"Replace some occurrences of FROM-STRING with TO-STRING.
@@ -400,6 +432,9 @@ In Transient Mark mode, if the mark is active, operate on the contents
of the region. Otherwise, operate from point to the end of the buffer's
accessible portion.
+When invoked interactively, matching a newline with `\\n' will not work;
+use `C-q C-j' instead. To match a tab character (`\\t'), just press `TAB'.
+
Use \\<minibuffer-local-map>\\[next-history-element] \
to pull the last incremental search regexp to the minibuffer
that reads REGEXP, or invoke replacements from
@@ -757,6 +792,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-highlight-overlays nil
+ "Overlays used to temporarily highlight occur matches.")
+
(defvar occur-collect-regexp-history '("\\1")
"History of regexp for occur's collect operation")
@@ -786,13 +824,16 @@ the function that you set this to can check `this-command'."
(defun read-regexp-suggestions ()
"Return a list of standard suggestions for `read-regexp'.
-By default, the list includes the identifier (a.k.a. \"tag\")
-at point (see Info node `(emacs) Identifier Search'), the last
-isearch regexp, the last isearch string, and the last
+By default, the list includes the active region, the identifier
+(a.k.a. \"tag\") at point (see Info node `(emacs) Identifier Search'),
+the last isearch regexp, the last isearch string, and the last
replacement regexp. `read-regexp' appends the list returned
by this function to the end of values available via
\\<minibuffer-local-map>\\[next-history-element]."
(list
+ (when (use-region-p)
+ (buffer-substring-no-properties
+ (region-beginning) (region-end)))
(find-tag-default-as-regexp)
(find-tag-default-as-symbol-regexp)
(car regexp-search-ring)
@@ -850,13 +891,10 @@ If nil, use `regexp-history'."
;; Do not automatically add default to the history for empty input.
(history-add-new-input nil)
(input (read-from-minibuffer
- (cond ((string-match-p ":[ \t]*\\'" prompt)
- prompt)
- ((and default (> (length default) 0))
- (format "%s (default %s): " prompt
- (query-replace-descr default)))
- (t
- (format "%s: " prompt)))
+ (if (string-match-p ":[ \t]*\\'" prompt)
+ prompt
+ (format-prompt prompt (and (length> default 0)
+ (query-replace-descr default))))
nil nil nil (or history 'regexp-history) suggestions t)))
(if (equal input "")
;; Return the default value when the user enters empty input.
@@ -890,7 +928,8 @@ and `search-upper-case' is non-nil, the matching is case-sensitive.
Second and third arg RSTART and REND specify the region to operate on.
This command operates on (the accessible part of) all lines whose
accessible part is entirely contained in the region determined by RSTART
-and REND. (A newline ending a line counts as part of that line.)
+and REND. (A newline ending a line counts as part of that line.) If RSTART
+is non-nil, REND also has to be given.
Interactively, in Transient Mark mode when the mark is active, operate
on all lines whose accessible part is entirely contained in the region.
@@ -1011,6 +1050,130 @@ also print the number."
count))
count))
+(defun kill-matching-lines (regexp &optional rstart rend interactive)
+ "Kill lines containing matches for REGEXP.
+
+When called from Lisp (and usually when called interactively as
+well, see below), applies to the part of the buffer after point.
+The line point is in is killed if and only if it contains a match
+for REGEXP starting after point.
+
+If REGEXP contains upper case characters (excluding those
+preceded by `\\') and `search-upper-case' is non-nil, the
+matching is case-sensitive.
+
+Second and third args RSTART and REND specify the region to
+operate on. Lines partially contained in this region are killed
+if and only if they contain a match entirely contained in the
+region.
+
+Interactively, in Transient Mark mode when the mark is active,
+operate on the contents of the region. Otherwise, operate from
+point to the end of (the accessible portion of) the buffer.
+
+If a match is split across lines, all the lines it lies in are
+killed. They are killed _before_ looking for the next match.
+Hence, a match starting on the same line at which another match
+ended is ignored.
+
+Return the number of killed matching lines. When called
+interactively, also print the number."
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (keep-lines-read-args "Kill lines containing match for regexp")))
+ (if rstart
+ (progn
+ (goto-char (min rstart rend))
+ (setq rend (copy-marker (max rstart rend))))
+ (if (and interactive (use-region-p))
+ (setq rstart (region-beginning)
+ rend (copy-marker (region-end)))
+ (setq rstart (point)
+ rend (point-max-marker)))
+ (goto-char rstart))
+ (let ((count 0)
+ (case-fold-search
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)))
+ (save-excursion
+ (while (and (< (point) rend)
+ (re-search-forward regexp rend t))
+ (unless (zerop count)
+ (setq last-command 'kill-region))
+ (kill-region (save-excursion (goto-char (match-beginning 0))
+ (forward-line 0)
+ (point))
+ (progn (forward-line 1) (point)))
+ (setq count (1+ count))))
+ (set-marker rend nil)
+ (when interactive (message (ngettext "Killed %d matching line"
+ "Killed %d matching lines"
+ count)
+ count))
+ count))
+
+(defun copy-matching-lines (regexp &optional rstart rend interactive)
+ "Copy lines containing matches for REGEXP to the kill ring.
+
+When called from Lisp (and usually when called interactively as
+well, see below), applies to the part of the buffer after point.
+The line point is in is copied if and only if it contains a match
+for REGEXP starting after point.
+
+If REGEXP contains upper case characters (excluding those
+preceded by `\\') and `search-upper-case' is non-nil, the
+matching is case-sensitive.
+
+Second and third args RSTART and REND specify the region to
+operate on. Lines partially contained in this region are copied
+if and only if they contain a match entirely contained in the
+region.
+
+Interactively, in Transient Mark mode when the mark is active,
+operate on the contents of the region. Otherwise, operate from
+point to the end of (the accessible portion of) the buffer.
+
+If a match is split across lines, all the lines it lies in are
+copied.
+
+Return the number of copied matching lines. When called
+interactively, also print the number."
+ (interactive
+ (keep-lines-read-args "Copy lines containing match for regexp"))
+ (if rstart
+ (progn
+ (goto-char (min rstart rend))
+ (setq rend (copy-marker (max rstart rend))))
+ (if (and interactive (use-region-p))
+ (setq rstart (region-beginning)
+ rend (copy-marker (region-end)))
+ (setq rstart (point)
+ rend (point-max-marker)))
+ (goto-char rstart))
+ (let ((count 0)
+ (case-fold-search
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)))
+ (save-excursion
+ (while (and (< (point) rend)
+ (re-search-forward regexp rend t))
+ (unless (zerop count)
+ (setq last-command 'kill-region))
+ (copy-region-as-kill (save-excursion (goto-char (match-beginning 0))
+ (forward-line 0)
+ (point))
+ (progn (forward-line 1) (point)))
+ (setq count (1+ count))))
+ (set-marker rend nil)
+ (when interactive (message (ngettext "Copied %d matching line"
+ "Copied %d matching lines"
+ count)
+ count))
+ count))
+
(defun how-many (regexp &optional rstart rend interactive)
"Print and return number of matches for REGEXP following point.
When called from Lisp and INTERACTIVE is omitted or nil, just return
@@ -1046,17 +1209,17 @@ a previously found match."
rend (point-max)))
(goto-char rstart))
(let ((count 0)
- opoint
(case-fold-search
(if (and case-fold-search search-upper-case)
(isearch-no-upper-case-p regexp t)
case-fold-search)))
(while (and (< (point) rend)
- (progn (setq opoint (point))
- (re-search-forward regexp rend t)))
- (if (= opoint (point))
- (forward-char 1)
- (setq count (1+ count))))
+ (re-search-forward regexp rend t))
+ ;; Ensure forward progress on zero-length matches like "^$".
+ (when (and (= (match-beginning 0) (match-end 0))
+ (not (eobp)))
+ (forward-char 1))
+ (setq count (1+ count)))
(when interactive (message (ngettext "%d occurrence"
"%d occurrences"
count)
@@ -1064,51 +1227,39 @@ a previously found match."
count)))
-(defvar occur-menu-map
- (let ((map (make-sparse-keymap)))
- (bindings--define-key map [next-error-follow-minor-mode]
- '(menu-item "Auto Occurrence Display"
- next-error-follow-minor-mode
- :help "Display another occurrence when moving the cursor"
- :button (:toggle . (and (boundp 'next-error-follow-minor-mode)
- next-error-follow-minor-mode))))
- (bindings--define-key map [separator-1] menu-bar-separator)
- (bindings--define-key map [kill-this-buffer]
- '(menu-item "Kill Occur Buffer" kill-this-buffer
- :help "Kill the current *Occur* buffer"))
- (bindings--define-key map [quit-window]
- '(menu-item "Quit Occur Window" quit-window
- :help "Quit the current *Occur* buffer. Bury it, and maybe delete the selected frame"))
- (bindings--define-key map [revert-buffer]
- '(menu-item "Revert Occur Buffer" revert-buffer
- :help "Replace the text in the *Occur* buffer with the results of rerunning occur"))
- (bindings--define-key map [clone-buffer]
- '(menu-item "Clone Occur Buffer" clone-buffer
- :help "Create and return a twin copy of the current *Occur* buffer"))
- (bindings--define-key map [occur-rename-buffer]
- '(menu-item "Rename Occur Buffer" occur-rename-buffer
- :help "Rename the current *Occur* buffer to *Occur: original-buffer-name*."))
- (bindings--define-key map [occur-edit-buffer]
- '(menu-item "Edit Occur Buffer" occur-edit-mode
- :help "Edit the *Occur* buffer and apply changes to the original buffers."))
- (bindings--define-key map [separator-2] menu-bar-separator)
- (bindings--define-key map [occur-mode-goto-occurrence-other-window]
- '(menu-item "Go To Occurrence Other Window" occur-mode-goto-occurrence-other-window
- :help "Go to the occurrence the current line describes, in another window"))
- (bindings--define-key map [occur-mode-goto-occurrence]
- '(menu-item "Go To Occurrence" occur-mode-goto-occurrence
- :help "Go to the occurrence the current line describes"))
- (bindings--define-key map [occur-mode-display-occurrence]
- '(menu-item "Display Occurrence" occur-mode-display-occurrence
- :help "Display in another window the occurrence the current line describes"))
- (bindings--define-key map [occur-next]
- '(menu-item "Move to Next Match" occur-next
- :help "Move to the Nth (default 1) next match in an Occur mode buffer"))
- (bindings--define-key map [occur-prev]
- '(menu-item "Move to Previous Match" occur-prev
- :help "Move to the Nth (default 1) previous match in an Occur mode buffer"))
- map)
- "Menu keymap for `occur-mode'.")
+(easy-menu-define occur-menu-map nil
+ "Menu for `occur-mode'."
+ '("Occur"
+ ["Move to Previous Match" occur-prev
+ :help "Move to the Nth (default 1) previous match in an Occur mode buffer"]
+ ["Move to Next Match" occur-next
+ :help "Move to the Nth (default 1) next match in an Occur mode buffer"]
+ ["Display Occurrence" occur-mode-display-occurrence
+ :help "Display in another window the occurrence the current line describes"]
+ ["Go To Occurrence" occur-mode-goto-occurrence
+ :help "Go to the occurrence the current line describes"]
+ ["Go To Occurrence Other Window" occur-mode-goto-occurrence-other-window
+ :help "Go to the occurrence the current line describes, in another window"]
+ "---"
+ ["Edit Occur Buffer" occur-edit-mode
+ :help "Edit the *Occur* buffer and apply changes to the original buffers."]
+ ["Rename Occur Buffer" occur-rename-buffer
+ :help "Rename the current *Occur* buffer to *Occur: original-buffer-name*."]
+ ["Clone Occur Buffer" clone-buffer
+ :help "Create and return a twin copy of the current *Occur* buffer"]
+ ["Revert Occur Buffer" revert-buffer
+ :help "Replace the text in the *Occur* buffer with the results of rerunning occur"]
+ ["Quit Occur Window" quit-window
+ :help "Quit the current *Occur* buffer. Bury it, and maybe delete the selected frame"]
+ ["Kill Occur Buffer" kill-this-buffer
+ :help "Kill the current *Occur* buffer"]
+ "---"
+ ["Auto Occurrence Display"
+ next-error-follow-minor-mode
+ :help "Display another occurrence when moving the cursor"
+ :style toggle
+ :selected (and (boundp 'next-error-follow-minor-mode)
+ next-error-follow-minor-mode)]))
(defvar occur-mode-map
(let ((map (make-sparse-keymap)))
@@ -1119,6 +1270,9 @@ a previously found match."
(define-key map "\C-m" 'occur-mode-goto-occurrence)
(define-key map "o" 'occur-mode-goto-occurrence-other-window)
(define-key map "\C-o" 'occur-mode-display-occurrence)
+ (define-key map "n" 'next-error-no-select)
+ (define-key map "p" 'previous-error-no-select)
+ (define-key map "l" 'recenter-current-error)
(define-key map "\M-n" 'occur-next)
(define-key map "\M-p" 'occur-prev)
(define-key map "r" 'occur-rename-buffer)
@@ -1199,18 +1353,27 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(occur-mode)
(message "Switching to Occur mode.")))
+(defun occur--targets-start (targets)
+ "First marker of the `occur-target' property value TARGETS."
+ (if (consp targets)
+ (caar targets)
+ ;; Tolerate an `occur-target' value that is a single marker for
+ ;; compatibility.
+ targets))
+
(defun occur-after-change-function (beg end length)
(save-excursion
(goto-char beg)
(let* ((line-beg (line-beginning-position))
- (m (get-text-property line-beg 'occur-target))
+ (targets (get-text-property line-beg 'occur-target))
+ (m (occur--targets-start targets))
(buf (marker-buffer m))
col)
(when (and (get-text-property line-beg 'occur-prefix)
(not (get-text-property end 'occur-prefix)))
(when (= length 0)
;; Apply occur-target property to inserted (e.g. yanked) text.
- (put-text-property beg end 'occur-target m)
+ (put-text-property beg end 'occur-target targets)
;; Did we insert a newline? Occur Edit mode can't create new
;; Occur entries; just discard everything after the newline.
(save-excursion
@@ -1235,8 +1398,27 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(recenter line)
(if readonly
(message "Buffer `%s' is read only." buf)
- (delete-region (line-beginning-position) (line-end-position))
- (insert text))
+ ;; Replace the line, but make the change as small as
+ ;; possible by shrink-wrapping. That way, we avoid
+ ;; disturbing markers unnecessarily.
+ (let* ((beg-pos (line-beginning-position))
+ (end-pos (line-end-position))
+ (buf-str (buffer-substring-no-properties beg-pos end-pos))
+ (common-prefix
+ (lambda (s1 s2)
+ (let ((c (compare-strings s1 nil nil s2 nil nil)))
+ (if (numberp c)
+ (1- (abs c))
+ (length s1)))))
+ (prefix-len (funcall common-prefix buf-str text))
+ (suffix-len (funcall common-prefix
+ (reverse buf-str) (reverse text))))
+ (setq beg-pos (+ beg-pos prefix-len))
+ (setq end-pos (- end-pos suffix-len))
+ (setq text (substring text prefix-len (- suffix-len)))
+ (delete-region beg-pos end-pos)
+ (goto-char beg-pos)
+ (insert text)))
(move-to-column col)))))))
@@ -1244,32 +1426,56 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
"Handle `revert-buffer' for Occur mode buffers."
(apply #'occur-1 (append occur-revert-arguments (list (buffer-name)))))
+;; Retained for compatibility.
(defun occur-mode-find-occurrence ()
- (let ((pos (get-text-property (point) 'occur-target)))
- (unless pos
+ "Return a marker to the first match of the line at point."
+ (occur--targets-start (occur-mode--find-occurrences)))
+
+(defun occur-mode--find-occurrences ()
+ ;; The `occur-target' property value is a list of (BEG . END) for each
+ ;; match on the line, or (for compatibility) a single marker to the start
+ ;; of the first match.
+ (let* ((targets (get-text-property (point) 'occur-target))
+ (start (occur--targets-start targets)))
+ (unless targets
(error "No occurrence on this line"))
- (unless (buffer-live-p (marker-buffer pos))
+ (unless (buffer-live-p (marker-buffer start))
(error "Buffer for this occurrence was killed"))
- pos))
+ targets))
+
+(defun occur--set-arrow ()
+ "Set the overlay arrow at the first line of the occur match at point."
+ (save-excursion
+ (let ((target (get-text-property (point) 'occur-target))
+ ;; Find the start of the occur match, in case it's multi-line.
+ (prev (previous-single-property-change (point) 'occur-target)))
+ (when (and prev (eq (get-text-property prev 'occur-target) target))
+ (goto-char prev))
+ (setq overlay-arrow-position
+ (set-marker (or overlay-arrow-position (make-marker))
+ (line-beginning-position))))))
(defalias 'occur-mode-mouse-goto 'occur-mode-goto-occurrence)
(defun occur-mode-goto-occurrence (&optional event)
"Go to the occurrence specified by EVENT, a mouse click.
If not invoked by a mouse click, go to occurrence on the current line."
(interactive (list last-nonmenu-event))
- (let ((buffer (when event (current-buffer)))
- (pos
- (if (null event)
- ;; Actually `event-end' works correctly with a nil argument as
- ;; well, so we could dispense with this test, but let's not
- ;; rely on this undocumented behavior.
- (occur-mode-find-occurrence)
- (with-current-buffer (window-buffer (posn-window (event-end event)))
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (occur-mode-find-occurrence))))))
+ (let* ((buffer (when event (current-buffer)))
+ (targets
+ (if (null event)
+ ;; Actually `event-end' works correctly with a nil argument as
+ ;; well, so we could dispense with this test, but let's not
+ ;; rely on this undocumented behavior.
+ (occur-mode--find-occurrences)
+ (with-current-buffer (window-buffer (posn-window (event-end event)))
+ (save-excursion
+ (goto-char (posn-point (event-end event)))
+ (occur-mode--find-occurrences)))))
+ (pos (occur--targets-start targets)))
+ (occur--set-arrow)
(pop-to-buffer (marker-buffer pos))
(goto-char pos)
+ (occur--highlight-occurrences targets)
(when buffer (next-error-found buffer (current-buffer)))
(run-hooks 'occur-mode-find-occurrence-hook)))
@@ -1277,23 +1483,73 @@ If not invoked by a mouse click, go to occurrence on the current line."
"Go to the occurrence the current line describes, in another window."
(interactive)
(let ((buffer (current-buffer))
- (pos (occur-mode-find-occurrence)))
+ (pos (occur--targets-start (occur-mode--find-occurrences))))
+ (occur--set-arrow)
(switch-to-buffer-other-window (marker-buffer pos))
(goto-char pos)
(next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook)))
+(defun occur-goto-locus-delete-o ()
+ (mapc #'delete-overlay occur-highlight-overlays)
+ (setq occur-highlight-overlays nil)
+ ;; Get rid of timer and hook that would try to do this again.
+ (if (timerp next-error-highlight-timer)
+ (cancel-timer next-error-highlight-timer))
+ (remove-hook 'pre-command-hook
+ #'occur-goto-locus-delete-o))
+
+;; Highlight the current visited occurrence.
+(defun occur--highlight-occurrences (targets)
+ (let ((start-marker (occur--targets-start targets)))
+ (occur-goto-locus-delete-o)
+ (with-current-buffer (marker-buffer start-marker)
+ (when (or (eq next-error-highlight t)
+ (numberp next-error-highlight))
+ (setq occur-highlight-overlays
+ (mapcar (lambda (target)
+ (let ((o (make-overlay (car target) (cdr target))))
+ (overlay-put o 'face 'next-error)
+ o))
+ (if (listp targets)
+ targets
+ ;; `occur-target' compatibility: when we only
+ ;; have a single starting point, highlight the
+ ;; rest of the line.
+ (let ((end-pos (save-excursion
+ (goto-char start-marker)
+ (line-end-position))))
+ (list (cons start-marker end-pos))))))
+ (add-hook 'pre-command-hook #'occur-goto-locus-delete-o)
+ (when (numberp next-error-highlight)
+ ;; We want highlighting for a limited time:
+ ;; set up a timer to delete it.
+ (setq next-error-highlight-timer
+ (run-at-time next-error-highlight nil
+ 'occur-goto-locus-delete-o))))
+
+ (when (eq next-error-highlight 'fringe-arrow)
+ ;; We want a fringe arrow (instead of highlighting).
+ (setq next-error-overlay-arrow-position
+ (copy-marker (line-beginning-position)))))))
+
(defun occur-mode-display-occurrence ()
"Display in another window the occurrence the current line describes."
(interactive)
- (let ((buffer (current-buffer))
- (pos (occur-mode-find-occurrence))
- window)
+ (let* ((buffer (current-buffer))
+ (targets (occur-mode--find-occurrences))
+ (pos (occur--targets-start targets))
+ (next-error-highlight next-error-highlight-no-select)
+ (display-buffer-overriding-action
+ '(nil (inhibit-same-window . t)))
+ window)
(setq window (display-buffer (marker-buffer pos) t))
+ (occur--set-arrow)
;; This is the way to set point in the proper window.
(save-selected-window
(select-window window)
(goto-char pos)
+ (occur--highlight-occurrences targets)
(next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook))))
@@ -1342,7 +1598,7 @@ This is a compatibility function for \\[next-error] invocations."
(defface match
'((((class color) (min-colors 88) (background light))
- :background "yellow1")
+ :background "khaki1")
(((class color) (min-colors 88) (background dark))
:background "RoyalBlue3")
(((class color) (min-colors 8) (background light))
@@ -1431,7 +1687,7 @@ which means to discard all text properties."
;; Get the regexp for collection pattern.
(let ((default (car occur-collect-regexp-history)))
(read-regexp
- (format "Regexp to collect (default %s): " default)
+ (format-prompt "Regexp to collect" default)
default 'occur-collect-regexp-history)))
;; Otherwise normal occur takes numerical prefix argument.
(when current-prefix-arg
@@ -1450,7 +1706,10 @@ You can add this to `occur-hook' if you always want a separate
(with-current-buffer
(if (eq major-mode 'occur-mode) (current-buffer) (get-buffer "*Occur*"))
(rename-buffer (concat "*Occur: "
- (mapconcat #'buffer-name
+ (mapconcat (lambda (boo)
+ (buffer-name (if (overlayp boo)
+ (overlay-buffer boo)
+ boo)))
(car (cddr occur-revert-arguments)) "/")
"*")
(or unique-p (not interactive-p)))))
@@ -1526,6 +1785,19 @@ is not modified."
(defvar ido-ignore-item-temp-list)
+(defun multi-occur--prompt ()
+ (concat
+ "Next buffer to search "
+ (cond
+ ((or (eq read-buffer-function #'ido-read-buffer)
+ (bound-and-true-p ido-everywhere))
+ (substitute-command-keys
+ "(\\<ido-completion-map>\\[ido-select-text] to end): "))
+ ((bound-and-true-p fido-mode)
+ (substitute-command-keys
+ "(\\<icomplete-fido-mode-map>\\[icomplete-fido-exit] to end): "))
+ (t "(RET to end): "))))
+
(defun multi-occur (bufs regexp &optional nlines)
"Show all lines in buffers BUFS containing a match for REGEXP.
Optional argument NLINES specifies the number of context lines to show
@@ -1541,11 +1813,7 @@ See also `multi-occur-in-matching-buffers'."
(buf nil)
(ido-ignore-item-temp-list bufs))
(while (not (string-equal
- (setq buf (read-buffer
- (if (eq read-buffer-function #'ido-read-buffer)
- "Next buffer to search (C-j to end): "
- "Next buffer to search (RET to end): ")
- nil t))
+ (setq buf (read-buffer (multi-occur--prompt) nil t))
""))
(cl-pushnew buf bufs)
(setq ido-ignore-item-temp-list bufs))
@@ -1609,7 +1877,8 @@ See also `multi-occur'."
(and (overlayp boo)
(overlay-buffer boo)))
boo))
- bufs))))
+ bufs)))
+ (source-buffer-default-directory default-directory))
;; Handle the case where one of the buffers we're searching is the
;; output buffer. Just rename it.
(when (member buf-name
@@ -1626,6 +1895,9 @@ See also `multi-occur'."
(setq occur-buf (get-buffer-create buf-name))
(with-current-buffer occur-buf
+ ;; Make the default-directory of the *Occur* buffer match that of
+ ;; the buffer where the occurrences come from
+ (setq default-directory source-buffer-default-directory)
(if (stringp nlines)
(fundamental-mode) ;; This is for collect operation.
(occur-mode))
@@ -1683,7 +1955,8 @@ See also `multi-occur'."
42)
(window-width))
"" (occur-regexp-descr regexp))))
- (occur--garbage-collect-revert-args)
+ (unless (eq bufs (nth 2 occur-revert-arguments))
+ (occur--garbage-collect-revert-args))
(setq occur-revert-arguments (list regexp nlines bufs))
(if (= count 0)
(kill-buffer occur-buf)
@@ -1732,7 +2005,7 @@ See also `multi-occur'."
(origpt nil)
(begpt nil)
(endpt nil)
- (marker nil)
+ markers ; list of (BEG-MARKER . END-MARKER)
(curstring "")
(ret nil)
;; The following binding is for when case-fold-search
@@ -1758,8 +2031,7 @@ See also `multi-occur'."
(setq endpt (line-end-position)))
;; Sum line numbers up to the first match line.
(setq curr-line (+ curr-line (count-lines origpt begpt)))
- (setq marker (make-marker))
- (set-marker marker matchbeg)
+ (setq markers nil)
(setq curstring (occur-engine-line begpt endpt keep-props))
;; Highlight the matches
(let ((len (length curstring))
@@ -1781,6 +2053,11 @@ See also `multi-occur'."
(setq orig-line-shown-p t)))
(while (and (< start len)
(string-match regexp curstring start))
+ (push (cons (set-marker (make-marker)
+ (+ begpt (match-beginning 0)))
+ (set-marker (make-marker)
+ (+ begpt (match-end 0))))
+ markers)
(setq matches (1+ matches))
(add-text-properties
(match-beginning 0) (match-end 0)
@@ -1793,6 +2070,7 @@ See also `multi-occur'."
;; Avoid infloop (Bug#7593).
(let ((end (match-end 0)))
(setq start (if (= start end) (1+ start) end)))))
+ (setq markers (nreverse markers))
;; Generate the string to insert for this match
(let* ((match-prefix
;; Using 7 digits aligns tabs properly.
@@ -1806,7 +2084,7 @@ See also `multi-occur'."
;; (for Occur Edit mode).
front-sticky t
rear-nonsticky t
- occur-target ,marker
+ occur-target ,markers
follow-link t
help-echo "mouse-2: go to this occurrence"))))
(match-str
@@ -1814,7 +2092,7 @@ See also `multi-occur'."
;; because that loses. And don't put it
;; on context lines to reduce flicker.
(propertize curstring
- 'occur-target marker
+ 'occur-target markers
'follow-link t
'help-echo
"mouse-2: go to this occurrence"))
@@ -1826,15 +2104,17 @@ See also `multi-occur'."
"\n"
(if prefix-face
(propertize
- "\n :" 'font-lock-face prefix-face)
- "\n :")
+ "\n :" 'font-lock-face prefix-face
+ 'occur-target markers)
+ (propertize
+ "\n :" 'occur-target markers))
;; Add mouse face in one section to
;; ensure the prefix and the string
;; get a contiguous highlight.
(propertize (concat match-prefix match-str)
'mouse-face 'highlight))
- ;; Add marker at eol, but no mouse props.
- (propertize "\n" 'occur-target marker)))
+ ;; Add markers at eol, but no mouse props.
+ (propertize "\n" 'occur-target markers)))
(data
(if (= nlines 0)
;; The simple display style
@@ -1970,10 +2250,8 @@ See also `multi-occur'."
global-matches)))
(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 font-lock-mode)
+ (font-lock-ensure beg end))
(if (and keep-props (not (eq occur-excluded-properties t)))
(let ((str (buffer-substring beg end)))
(remove-list-of-text-properties
@@ -2345,6 +2623,7 @@ It is called with three arguments, as if it were
(funcall search-function search-string limit t)))
(defvar replace-overlay nil)
+(defvar replace-submatches-overlays nil)
(defun replace-highlight (match-beg match-end range-beg range-end
search-string regexp-flag delimited-flag
@@ -2355,6 +2634,29 @@ It is called with three arguments, as if it were
(setq replace-overlay (make-overlay match-beg match-end))
(overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays
(overlay-put replace-overlay 'face 'query-replace)))
+
+ (when (and query-replace-highlight-submatches regexp-flag)
+ (mapc 'delete-overlay replace-submatches-overlays)
+ (setq replace-submatches-overlays nil)
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr (match-data t)))
+ (group 0)
+ b e ov face)
+ (while submatch-data
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov replace-submatches-overlays)))))
+
(if query-replace-lazy-highlight
(let ((isearch-string search-string)
(isearch-regexp regexp-flag)
@@ -2375,6 +2677,9 @@ It is called with three arguments, as if it were
(defun replace-dehighlight ()
(when replace-overlay
(delete-overlay replace-overlay))
+ (when query-replace-highlight-submatches
+ (mapc 'delete-overlay replace-submatches-overlays)
+ (setq replace-submatches-overlays nil))
(when query-replace-lazy-highlight
(lazy-highlight-cleanup lazy-highlight-cleanup)
(setq isearch-lazy-highlight-last-string nil))
@@ -2904,6 +3209,8 @@ characters."
(replace-dehighlight)
(save-excursion (recursive-edit))
(setq replaced t))
+ ((commandp def t)
+ (call-interactively def))
;; Note: we do not need to treat `exit-prefix'
;; specially here, since we reread
;; any unrecognized character.
diff --git a/lisp/reposition.el b/lisp/reposition.el
index 7ed44b6c74d..02bee4165a8 100644
--- a/lisp/reposition.el
+++ b/lisp/reposition.el
@@ -1,4 +1,4 @@
-;;; reposition.el --- center a Lisp function or comment on the screen
+;;; reposition.el --- center a Lisp function or comment on the screen -*- lexical-binding: t -*-
;; Copyright (C) 1991, 1994, 2001-2021 Free Software Foundation, Inc.
@@ -38,7 +38,7 @@
;;; Code:
;;;###autoload
-(defun reposition-window (&optional arg)
+(defun reposition-window (&optional arg interactive)
"Make the current definition and/or comment visible.
Further invocations move it to the top of the window or toggle the
visibility of comments that precede it.
@@ -55,118 +55,124 @@ the comment lines.
visible (if only part could otherwise be made so), to make the defun line
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 (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
- (ht (- (window-height) 2))
- (line (repos-count-screen-lines (window-start) (point)))
- (comment-height
- ;; The call to max deals with the case of cursor between defuns.
- (max 0
- (repos-count-screen-lines-signed
- ;; the beginning of the preceding comment
- (save-excursion
- (if (not (eobp)) (forward-char 1))
- (end-of-defun -1)
- ;; Skip whitespace, newlines, and form feeds.
- (if (re-search-forward "[^ \t\n\f]" nil t)
- (backward-char 1))
- (point))
- here)))
- (defun-height
- (repos-count-screen-lines-signed
- (save-excursion
- (end-of-defun 1) ; so comments associate with following defuns
- (beginning-of-defun 1)
- (point))
- here))
- ;; This must be positive, so don't use the signed version.
- (defun-depth (repos-count-screen-lines here
- (save-excursion
- (end-of-defun 1)
- (point))))
- (defun-line-onscreen-p
- (and (<= defun-height line)
- (<= (- line defun-height) ht))))
- (cond ((or (= comment-height line)
- (and (= line ht)
- (> comment-height line)
- ;; if defun line offscreen, we should be in case 4
- defun-line-onscreen-p))
- ;; Either first comment line is at top of screen or (point at
- ;; bottom of screen, defun line onscreen, and first comment line
- ;; off top of screen). That is, it looks like we just did
- ;; recenter-definition, trying to fit as much of the comment
- ;; onscreen as possible. Put defun line at top of screen; that
- ;; is, show as much code, and as few comments, as possible.
-
- (if (and arg (> defun-depth (1+ ht)))
- ;; Can't fit whole defun onscreen without moving point.
- (progn (end-of-defun) (beginning-of-defun) (recenter 0))
- (recenter (max defun-height 0)))
- ;;(repos-debug-macro "1")
- )
-
- ((or (= defun-height line)
- (= line 0)
- (and (< line comment-height)
- (< defun-height 0)))
- ;; Defun line or cursor at top of screen, OR cursor in comment
- ;; whose first line is offscreen.
- ;; Avoid moving definition up even if defun runs offscreen;
- ;; we care more about getting the comment onscreen.
-
- (cond ((= line ht)
- ;; cursor on last screen line (and so in a comment)
- (if arg (progn (end-of-defun) (beginning-of-defun)))
- (recenter 0)
- ;;(repos-debug-macro "2a")
- )
-
- ;; This condition, copied from case 4, may not be quite right
-
- ((and arg (< ht comment-height))
- ;; Can't get first comment line onscreen.
- ;; Go there and try again.
- (forward-line (- comment-height))
- (beginning-of-line)
- ;; was (reposition-window)
- (recenter 0)
- ;;(repos-debug-macro "2b")
- )
- (t
- (recenter (min ht comment-height))
- ;;(repos-debug-macro "2c")
- ))
- ;; (recenter (min ht comment-height))
- )
-
- ((and (> (+ line defun-depth -1) ht)
- defun-line-onscreen-p)
- ;; Defun runs off the bottom of the screen and the defun line
- ;; is onscreen.
- ;; Move the defun up.
- (recenter (max 0 (1+ (- ht defun-depth)) defun-height))
- ;;(repos-debug-macro "3")
- )
-
- (t
- ;; If on the bottom line and comment start is offscreen
- ;; then just move all comments offscreen, or at least as
- ;; far as they'll go.
-
- ;; Try to get as much of the comments onscreen as possible.
- (if (and arg (< ht comment-height))
- ;; Can't get defun line onscreen; go there and try again.
- (progn (forward-line (- defun-height))
- (beginning-of-line)
- (reposition-window))
- (recenter (min ht comment-height)))
- ;;(repos-debug-macro "4")
- ))))
+first comment line visible (if point is in a comment).
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "P\nd")
+ (if interactive
+ (condition-case e
+ (reposition-window arg nil)
+ (scan-error (user-error (cadr e))))
+ (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
+ (ht (- (window-height) 2))
+ (line (repos-count-screen-lines (window-start) (point)))
+ (comment-height
+ ;; The call to max deals with the case of cursor between defuns.
+ (max 0
+ (repos-count-screen-lines-signed
+ ;; the beginning of the preceding comment
+ (save-excursion
+ (if (not (eobp)) (forward-char 1))
+ (end-of-defun -1)
+ ;; Skip whitespace, newlines, and form feeds.
+ (if (re-search-forward "[^ \t\n\f]" nil t)
+ (backward-char 1))
+ (point))
+ here)))
+ (defun-height
+ (repos-count-screen-lines-signed
+ (save-excursion
+ (end-of-defun 1) ; so comments associate with following defuns
+ (beginning-of-defun 1)
+ (point))
+ here))
+ ;; This must be positive, so don't use the signed version.
+ (defun-depth (repos-count-screen-lines here
+ (save-excursion
+ (end-of-defun 1)
+ (point))))
+ (defun-line-onscreen-p
+ (and (<= defun-height line)
+ (<= (- line defun-height) ht))))
+ (cond ((or (= comment-height line)
+ (and (= line ht)
+ (> comment-height line)
+ ;; if defun line offscreen, we should be in case 4
+ defun-line-onscreen-p))
+ ;; Either first comment line is at top of screen or (point at
+ ;; bottom of screen, defun line onscreen, and first comment line
+ ;; off top of screen). That is, it looks like we just did
+ ;; recenter-definition, trying to fit as much of the comment
+ ;; onscreen as possible. Put defun line at top of screen; that
+ ;; is, show as much code, and as few comments, as possible.
+
+ (if (and arg (> defun-depth (1+ ht)))
+ ;; Can't fit whole defun onscreen without moving point.
+ (progn (end-of-defun) (beginning-of-defun) (recenter 0))
+ (recenter (max defun-height 0)))
+ ;;(repos-debug-macro "1")
+ )
+
+ ((or (= defun-height line)
+ (= line 0)
+ (and (< line comment-height)
+ (< defun-height 0)))
+ ;; Defun line or cursor at top of screen, OR cursor in comment
+ ;; whose first line is offscreen.
+ ;; Avoid moving definition up even if defun runs offscreen;
+ ;; we care more about getting the comment onscreen.
+
+ (cond ((= line ht)
+ ;; cursor on last screen line (and so in a comment)
+ (if arg (progn (end-of-defun) (beginning-of-defun)))
+ (recenter 0)
+ ;;(repos-debug-macro "2a")
+ )
+
+ ;; This condition, copied from case 4, may not be quite right
+
+ ((and arg (< ht comment-height))
+ ;; Can't get first comment line onscreen.
+ ;; Go there and try again.
+ (forward-line (- comment-height))
+ (beginning-of-line)
+ ;; was (reposition-window)
+ (recenter 0)
+ ;;(repos-debug-macro "2b")
+ )
+ (t
+ (recenter (min ht comment-height))
+ ;;(repos-debug-macro "2c")
+ ))
+ ;; (recenter (min ht comment-height))
+ )
+
+ ((and (> (+ line defun-depth -1) ht)
+ defun-line-onscreen-p)
+ ;; Defun runs off the bottom of the screen and the defun line
+ ;; is onscreen.
+ ;; Move the defun up.
+ (recenter (max 0 (1+ (- ht defun-depth)) defun-height))
+ ;;(repos-debug-macro "3")
+ )
+
+ (t
+ ;; If on the bottom line and comment start is offscreen
+ ;; then just move all comments offscreen, or at least as
+ ;; far as they'll go.
+
+ ;; Try to get as much of the comments onscreen as possible.
+ (if (and arg (< ht comment-height))
+ ;; Can't get defun line onscreen; go there and try again.
+ (progn (forward-line (- defun-height))
+ (beginning-of-line)
+ (reposition-window))
+ (recenter (min ht comment-height)))
+ ;;(repos-debug-macro "4")
+ )))))
;;; Auxiliary functions
diff --git a/lisp/reveal.el b/lisp/reveal.el
index 6f13b801eb1..697df45c5c3 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -60,13 +60,18 @@
:type 'boolean
:group 'reveal)
-(defvar reveal-open-spots nil
+(defcustom reveal-auto-hide t
+ "Automatically hide revealed text when leaving it.
+If nil, the `reveal-hide-revealed' command can be useful to hide
+revealed text manually."
+ :type 'boolean
+ :version "28.1")
+
+(defvar-local reveal-open-spots nil
"List of spots in the buffer which are open.
Each element has the form (WINDOW . OVERLAY).")
-(make-variable-buffer-local 'reveal-open-spots)
-(defvar reveal-last-tick nil)
-(make-variable-buffer-local 'reveal-last-tick)
+(defvar-local reveal-last-tick nil)
;; Actual code
@@ -97,7 +102,8 @@ Each element has the form (WINDOW . OVERLAY).")
(cdr x))))
reveal-open-spots))))
(setq old-ols (reveal-open-new-overlays old-ols))
- (reveal-close-old-overlays old-ols)))))
+ (when reveal-auto-hide
+ (reveal-close-old-overlays old-ols))))))
(defun reveal-open-new-overlays (old-ols)
(let ((repeat t))
@@ -196,6 +202,14 @@ Each element has the form (WINDOW . OVERLAY).")
(delq (rassoc ol reveal-open-spots)
reveal-open-spots)))))))
+(defun reveal-hide-revealed ()
+ "Hide all revealed text.
+If there is revealed text under point, this command does not hide
+that text."
+ (interactive)
+ (let ((reveal-auto-hide t))
+ (reveal-post-command)))
+
(defvar reveal-mode-map
(let ((map (make-sparse-keymap)))
;; Override the default move-beginning-of-line and move-end-of-line
@@ -209,13 +223,15 @@ Each element has the form (WINDOW . OVERLAY).")
"Toggle uncloaking of invisible text near point (Reveal mode).
Reveal mode is a buffer-local minor mode. When enabled, it
-reveals invisible text around point."
+reveals invisible text around point.
+
+Also see the `reveal-auto-hide' variable."
:group 'reveal
:lighter (global-reveal-mode nil " Reveal")
:keymap reveal-mode-map
(if reveal-mode
(progn
- (set (make-local-variable 'search-invisible) t)
+ (setq-local search-invisible t)
(add-hook 'post-command-hook 'reveal-post-command nil t))
(kill-local-variable 'search-invisible)
(remove-hook 'post-command-hook 'reveal-post-command t)))
diff --git a/lisp/rfn-eshadow.el b/lisp/rfn-eshadow.el
index f9842b52b13..378358feac2 100644
--- a/lisp/rfn-eshadow.el
+++ b/lisp/rfn-eshadow.el
@@ -1,4 +1,4 @@
-;;; rfn-eshadow.el --- Highlight `shadowed' part of read-file-name input text
+;;; rfn-eshadow.el --- Highlight `shadowed' part of read-file-name input text -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;;
diff --git a/lisp/rot13.el b/lisp/rot13.el
index dfcf4adc179..4e4e60fea3f 100644
--- a/lisp/rot13.el
+++ b/lisp/rot13.el
@@ -3,6 +3,7 @@
;; Copyright (C) 1988, 2001-2021 Free Software Foundation, Inc.
;; Author: Howard Gayle
+;; Simon Josefsson
;; Maintainer: emacs-devel@gnu.org
;; This file is part of GNU Emacs.
@@ -22,18 +23,26 @@
;;; Commentary:
-;; The entry point, `rot13-other-window', performs a Caesar cipher
-;; encrypt/decrypt on the current buffer and displays the result in another
-;; window. ROT13 encryption is sometimes used on USENET as a read-at-your-
-;; own-risk wrapper for material some might consider offensive, such as
-;; ethnic humor.
+;; "ROT13 ('rotate by 13 places') is a simple letter substitution
+;; cipher that replaces a letter with the 13th letter after it in
+;; the alphabet. ROT13 is a special case of the Caesar cipher
+;; which was developed in ancient Rome.
;;
-;; Written by Howard Gayle.
-;; This hack is mainly to show off the char table stuff.
+;; Because there are 26 letters (2×13) in the basic Latin
+;; alphabet, ROT13 is its own inverse; that is, to undo ROT13, the
+;; same algorithm is applied, so the same action can be used for
+;; encoding and decoding. The algorithm provides virtually no
+;; cryptographic security, and is often cited as a canonical
+;; example of weak encryption.
;;
-;; New entry points, `rot13', `rot13-string', and `rot13-region' that
-;; performs Caesar cipher encrypt/decrypt on buffers and strings, was
-;; added by Simon Josefsson.
+;; ROT13 is used in online forums as a means of hiding spoilers,
+;; punchlines, puzzle solutions, and offensive materials from the
+;; casual glance." - Wikipedia article on ROT13
+;;
+;; The entry points, `rot13', `rot13-string', and `rot13-region' performs ROT13
+;; encoding/decoding on buffers and strings. The entry point
+;; `rot13-other-window' performs a ROT13 encoding/decoding on the current
+;; buffer and displays the result in another window.
;;; Code:
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index 74f017b23ff..a0d4f6e96c2 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -1,10 +1,10 @@
-;;; ruler-mode.el --- display a ruler in the header line
+;;; ruler-mode.el --- display a ruler in the header line -*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Created: 24 Mar 2001
-;; Version: 1.6
+;; Old-Version: 1.6
;; Keywords: convenience
;; This file is part of GNU Emacs.
@@ -25,7 +25,7 @@
;;; Commentary:
;; This library provides a minor mode to display a ruler in the header
-;; line. It works from Emacs 21 onwards.
+;; line.
;;
;; You can use the mouse to change the `fill-column' `comment-column',
;; `goal-column', `window-margins' and `tab-stop-list' settings:
@@ -100,10 +100,7 @@
;; To automatically display the ruler in specific major modes use:
;;
;; (add-hook '<major-mode>-hook 'ruler-mode)
-;;
-;;; History:
-;;
;;; Code:
(eval-when-compile
@@ -122,7 +119,6 @@ Also allowing to visually change `tab-stop-list' setting using
<C-down-mouse-1> and <C-down-mouse-3> on the ruler to respectively add
or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
<C-down-mouse-2> on the ruler toggles showing/editing of tab stops."
- :group 'ruler-mode
:type 'boolean)
;; IMPORTANT: This function must be defined before the following
@@ -140,7 +136,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
?\¶
?\|)
"Character used at the `fill-column' location."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -148,7 +143,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-comment-column-char ?\#
"Character used at the `comment-column' location."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -156,7 +150,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-goal-column-char ?G
"Character used at the `goal-column' location."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -166,7 +159,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
?\¦
?\@)
"Character used at the `current-column' location."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -174,7 +166,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-tab-stop-char ?\T
"Character used at `tab-stop-list' locations."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -182,7 +173,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-basic-graduation-char ?\.
"Character used for basic graduations."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -190,7 +180,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-inter-graduation-char ?\!
"Character used for intermediate graduations."
- :group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
@@ -198,7 +187,6 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(defcustom ruler-mode-set-goal-column-ding-flag t
"Non-nil means do `ding' when `goal-column' is set."
- :group 'ruler-mode
:type 'boolean)
(defface ruler-mode-default
@@ -215,8 +203,7 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
:line-width 1
:style released-button)
)))
- "Default face used by the ruler."
- :group 'ruler-mode)
+ "Default face used by the ruler.")
(defface ruler-mode-pad
'((((type tty))
@@ -227,64 +214,56 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
(:inherit ruler-mode-default
:background "grey64"
)))
- "Face used to pad inactive ruler areas."
- :group 'ruler-mode)
+ "Face used to pad inactive ruler areas.")
(defface ruler-mode-margins
'((t
(:inherit ruler-mode-default
:foreground "white"
)))
- "Face used to highlight margin areas."
- :group 'ruler-mode)
+ "Face used to highlight margin areas.")
(defface ruler-mode-fringes
'((t
(:inherit ruler-mode-default
:foreground "green"
)))
- "Face used to highlight fringes areas."
- :group 'ruler-mode)
+ "Face used to highlight fringes areas.")
(defface ruler-mode-column-number
'((t
(:inherit ruler-mode-default
:foreground "black"
)))
- "Face used to highlight number graduations."
- :group 'ruler-mode)
+ "Face used to highlight number graduations.")
(defface ruler-mode-fill-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
- "Face used to highlight the fill column character."
- :group 'ruler-mode)
+ "Face used to highlight the fill column character.")
(defface ruler-mode-comment-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
- "Face used to highlight the comment column character."
- :group 'ruler-mode)
+ "Face used to highlight the comment column character.")
(defface ruler-mode-goal-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
- "Face used to highlight the goal column character."
- :group 'ruler-mode)
+ "Face used to highlight the goal column character.")
(defface ruler-mode-tab-stop
'((t
(:inherit ruler-mode-default
:foreground "steelblue"
)))
- "Face used to highlight tab stop characters."
- :group 'ruler-mode)
+ "Face used to highlight tab stop characters.")
(defface ruler-mode-current-column
'((t
@@ -292,8 +271,7 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
:weight bold
:foreground "yellow"
)))
- "Face used to highlight the `current-column' character."
- :group 'ruler-mode)
+ "Face used to highlight the `current-column' character.")
(defsubst ruler-mode-full-window-width ()
@@ -429,7 +407,7 @@ dragging. See also the variable `ruler-mode-dragged-symbol'."
;; `ding' flushes the next messages about setting goal
;; column. So here I force fetch the event(mouse-2) and
;; throw away.
- (read-event)
+ (read--potential-mouse-event)
;; Ding BEFORE `message' is OK.
(when ruler-mode-set-goal-column-ding-flag
(ding))
@@ -460,7 +438,7 @@ the mouse has been clicked."
(track-mouse
;; Signal the display engine to freeze the mouse pointer shape.
(setq track-mouse 'dragging)
- (while (mouse-movement-p (setq event (read-event)))
+ (while (mouse-movement-p (setq event (read--potential-mouse-event)))
(setq drags (1+ drags))
(when (eq window (posn-window (event-end event)))
(ruler-mode-mouse-drag-any-column event)
@@ -547,15 +525,15 @@ START-EVENT is the mouse click event."
(define-key km [header-line (control down-mouse-2)]
#'ruler-mode-toggle-show-tab-stops)
(define-key km [header-line (shift mouse-1)]
- 'ignore)
+ #'ignore)
(define-key km [header-line (shift mouse-3)]
- 'ignore)
+ #'ignore)
(define-key km [header-line (control mouse-1)]
- 'ignore)
+ #'ignore)
(define-key km [header-line (control mouse-3)]
- 'ignore)
+ #'ignore)
(define-key km [header-line (control mouse-2)]
- 'ignore)
+ #'ignore)
km)
"Keymap for ruler minor mode.")
@@ -572,10 +550,9 @@ 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
+(defvar-local 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.
@@ -584,15 +561,13 @@ 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-local ruler-mode-header-line-format-old
+ header-line-format))
(setq header-line-format ruler-mode-header-line-format))
;;;###autoload
(define-minor-mode ruler-mode
"Toggle display of ruler in header line (Ruler mode)."
- nil nil
- ruler-mode-map
:group 'ruler-mode
:variable (ruler-mode
. (lambda (enable)
diff --git a/lisp/savehist.el b/lisp/savehist.el
index 81a5a134308..6745d379cb3 100644
--- a/lisp/savehist.el
+++ b/lisp/savehist.el
@@ -4,8 +4,8 @@
;; Author: Hrvoje Nikšić <hrvoje.niksic@avl.com>
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: minibuffer
-;; Version: 24
+;; Keywords: convenience, minibuffer
+;; Old-Version: 24
;; This file is part of GNU Emacs.
@@ -27,7 +27,7 @@
;; Many editors (e.g. Vim) have the feature of saving minibuffer
;; history to an external file after exit. This package provides the
;; same feature in Emacs. When set up, it saves recorded minibuffer
-;; histories to a file (`~/.emacs-history' by default). Additional
+;; histories to a file (`~/.emacs.d/history' by default). Additional
;; variables may be specified by customizing
;; `savehist-additional-variables'.
@@ -47,8 +47,6 @@
;;; Code:
-(require 'custom)
-
;; User variables
(defgroup savehist nil
@@ -215,6 +213,7 @@ Normally invoked by calling `savehist-mode' to unset the minor mode."
(cancel-timer savehist-timer)
(setq savehist-timer nil)))
+(defvar savehist--has-given-file-warning nil)
(defun savehist-save (&optional auto-save)
"Save the values of minibuffer history variables.
Unbound symbols referenced in `savehist-additional-variables' are ignored.
@@ -288,23 +287,29 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved,
;; If autosaving, avoid writing if nothing has changed since the
;; last write.
(let ((checksum (md5 (current-buffer) nil nil savehist-coding-system)))
- (unless (and auto-save (equal checksum savehist-last-checksum))
- ;; Set file-precious-flag when saving the buffer because we
- ;; don't want a half-finished write ruining the entire
- ;; history. Remember that this is run from a timer and from
- ;; kill-emacs-hook, and also that multiple Emacs instances
- ;; could write to this file at once.
- (let ((file-precious-flag t)
- (coding-system-for-write savehist-coding-system)
- (dir (file-name-directory savehist-file)))
- ;; Ensure that the directory exists before saving.
- (unless (file-exists-p dir)
- (make-directory dir t))
- (write-region (point-min) (point-max) savehist-file nil
- (unless (called-interactively-p 'interactive) 'quiet)))
- (when savehist-file-modes
- (set-file-modes savehist-file savehist-file-modes))
- (setq savehist-last-checksum checksum)))))
+ (condition-case err
+ (unless (and auto-save (equal checksum savehist-last-checksum))
+ ;; Set file-precious-flag when saving the buffer because we
+ ;; don't want a half-finished write ruining the entire
+ ;; history. Remember that this is run from a timer and from
+ ;; kill-emacs-hook, and also that multiple Emacs instances
+ ;; could write to this file at once.
+ (let ((file-precious-flag t)
+ (coding-system-for-write savehist-coding-system)
+ (dir (file-name-directory savehist-file)))
+ ;; Ensure that the directory exists before saving.
+ (unless (file-exists-p dir)
+ (make-directory dir t))
+ (write-region (point-min) (point-max) savehist-file nil
+ (unless (called-interactively-p 'interactive) 'quiet)))
+ (when savehist-file-modes
+ (set-file-modes savehist-file savehist-file-modes))
+ (setq savehist-last-checksum checksum))
+ (file-error
+ (unless savehist--has-given-file-warning
+ (lwarn '(savehist-file) :warning "Error writing `%s': %s"
+ savehist-file (caddr err))
+ (setq savehist--has-given-file-warning t)))))))
(defun savehist-autosave ()
"Save the minibuffer history if it has been modified since the last save.
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 40aba391309..2a95b39da87 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -1,4 +1,4 @@
-;;; saveplace.el --- automatically save place in files
+;;; saveplace.el --- automatically save place in files -*- lexical-binding:t -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -42,7 +42,6 @@
"Automatically save place in files."
:group 'data)
-
(defvar save-place-alist nil
"Alist of saved places to go back to when revisiting files.
Each element looks like (FILENAME . POSITION);
@@ -88,6 +87,11 @@ this happens automatically before saving `save-place-alist' to
`save-place-file'."
:type 'boolean)
+(defcustom save-place-abbreviate-file-names nil
+ "If non-nil, abbreviate file names before saving them."
+ :type 'boolean
+ :version "28.1")
+
(defcustom save-place-save-skipped t
"If non-nil, remember files matching `save-place-skip-check-regexp'.
@@ -175,10 +179,14 @@ file:
(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
(defun save-place-to-alist ()
- ;; put filename and point in a cons box and then cons that onto the
- ;; front of the save-place-alist, if save-place-mode is non-nil.
- ;; Otherwise, just delete that file from the alist.
- ;; first check to make sure alist has been loaded in from the master
+ "Add current buffer filename and position to `save-place-alist'.
+Put filename and point in a cons box and then cons that onto the
+front of the `save-place-alist', if `save-place-mode' is non-nil.
+Otherwise, just delete that file from the alist.
+
+If `save-place-abbreviate-file-names' is non-nil, abbreviate the
+file names."
+ ;; First check to make sure alist has been loaded in from the master
;; file. If not, do so, then feel free to modify the alist. It
;; will be saved again when Emacs is killed.
(or save-place-loaded (load-save-place-alist-from-file))
@@ -195,6 +203,8 @@ file:
(or (not save-place-ignore-files-regexp)
(not (string-match save-place-ignore-files-regexp
item))))
+ (when save-place-abbreviate-file-names
+ (setq item (abbreviate-file-name item)))
(let ((cell (assoc item save-place-alist))
(position (cond ((eq major-mode 'hexl-mode)
(with-no-warnings
@@ -248,8 +258,8 @@ may have changed) back to `save-place-alist'."
(delete-region (point-min) (point-max))
(when save-place-forget-unreadable-files
(save-place-forget-unreadable-files))
- (insert (format ";;; -*- coding: %s -*-\n"
- (symbol-name coding-system-for-write)))
+ (insert (format ";;; -*- coding: %s; mode: lisp-data -*-\n"
+ coding-system-for-write))
(let ((print-length nil)
(print-level nil))
(pp save-place-alist (current-buffer)))
diff --git a/lisp/sb-image.el b/lisp/sb-image.el
deleted file mode 100644
index 5e219d1a7dc..00000000000
--- a/lisp/sb-image.el
+++ /dev/null
@@ -1,107 +0,0 @@
-;;; sb-image --- Image management for speedbar
-
-;; Copyright (C) 1999-2003, 2005-2021 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: file, tags, 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs,
-;; is a challenging task, which doesn't take kindly to being byte compiled.
-;; When sharing speedbar.elc between these three applications, the Image
-;; support can get lost.
-;;
-;; By splitting out that hard part into this file, and avoiding byte
-;; compilation, one copy speedbar can support all these platforms together.
-;;
-;; This file requires the `image' package if it is available.
-
-(require 'ezimage)
-
-;;; Code:
-(defcustom speedbar-use-images ezimage-use-images
- "Non-nil if speedbar should display icons."
- :group 'speedbar
- :version "21.1"
- :type 'boolean)
-
-(defalias 'defimage-speedbar 'defezimage)
-
-(defvar speedbar-expand-image-button-alist
- '(("<+>" . ezimage-directory-plus)
- ("<->" . ezimage-directory-minus)
- ("< >" . ezimage-directory)
- ("[+]" . ezimage-page-plus)
- ("[-]" . ezimage-page-minus)
- ("[?]" . ezimage-page)
- ("[ ]" . ezimage-page)
- ("{+}" . ezimage-box-plus)
- ("{-}" . ezimage-box-minus)
- ("<M>" . ezimage-mail)
- ("<d>" . ezimage-document-tag)
- ("<i>" . ezimage-info-tag)
- (" =>" . ezimage-tag)
- (" +>" . ezimage-tag-gt)
- (" ->" . ezimage-tag-v)
- (">" . ezimage-tag)
- ("@" . ezimage-tag-type)
- (" @" . ezimage-tag-type)
- ("*" . ezimage-checkout)
- ("#" . ezimage-object)
- ("!" . ezimage-object-out-of-date)
- ("//" . ezimage-label)
- ("%" . ezimage-lock)
- )
- "List of text and image associations.")
-
-(defun speedbar-insert-image-button-maybe (start length)
- "Insert an image button based on text starting at START for LENGTH chars.
-If buttontext is unknown, just insert that text.
-If we have an image associated with it, use that image."
- (when speedbar-use-images
- (let ((ezimage-expand-image-button-alist
- speedbar-expand-image-button-alist))
- (ezimage-insert-image-button-maybe start length))))
-
-(defun speedbar-image-dump ()
- "Dump out the current state of the Speedbar image alist.
-See `speedbar-expand-image-button-alist' for details."
- (interactive)
- (with-output-to-temp-buffer "*Speedbar Images*"
- (with-current-buffer "*Speedbar Images*"
- (goto-char (point-max))
- (insert "Speedbar image cache.\n\n")
- (let ((start (point)) (end nil))
- (insert "Image\tText\tImage Name")
- (setq end (point))
- (insert "\n")
- (put-text-property start end 'face 'underline))
- (let ((ia speedbar-expand-image-button-alist))
- (while ia
- (let ((start (point)))
- (insert (car (car ia)))
- (insert "\t")
- (speedbar-insert-image-button-maybe start
- (length (car (car ia))))
- (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n"))
- (setq ia (cdr ia)))))))
-
-(provide 'sb-image)
-
-;;; sb-image.el ends here
diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el
index 25b245e4b63..415244f9e92 100644
--- a/lisp/scroll-all.el
+++ b/lisp/scroll-all.el
@@ -1,4 +1,4 @@
-;;; scroll-all.el --- scroll all buffers together minor mode
+;;; scroll-all.el --- scroll all buffers together minor mode -*- lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -47,38 +47,41 @@
(condition-case nil
(funcall func arg)
;; Ignore beginning- or end-of-buffer error in other windows.
- (error nil)
- )
+ (error nil))
(other-window 1)
(setq count (1+ count))))))
(defun scroll-all-scroll-down-all (arg)
- "Scroll down in all visible windows."
+ "Scroll down ARG lines in all visible windows."
(interactive "p")
(scroll-all-function-all 'next-line arg))
(defun scroll-all-scroll-up-all (arg)
- "Scroll up in all visible windows."
+ "Scroll up ARG lines in all visible windows."
(interactive "p")
(scroll-all-function-all 'previous-line arg))
(defun scroll-all-page-down-all (arg)
- "Page down in all visible windows."
+ "Page down in all visible windows.
+ARG is like in `scroll-up'."
(interactive "P")
(scroll-all-function-all 'scroll-up arg))
(defun scroll-all-page-up-all (arg)
- "Page up in all visible windows."
+ "Page up in all visible windows.
+ARG is like in `scroll-down'."
(interactive "P")
(scroll-all-function-all 'scroll-down arg))
(defun scroll-all-beginning-of-buffer-all (arg)
- "Go to the beginning of the buffer in all visible windows."
+ "Go to the beginning of the buffer in all visible windows.
+ARG is like in `beginning-of-buffer'."
(interactive "P")
(scroll-all-function-all 'beginning-of-buffer arg))
(defun scroll-all-end-of-buffer-all (arg)
- "Go to the end of the buffer in all visible windows."
+ "Go to the end of the buffer in all visible windows.
+ARG is like in `end-of-buffer'."
(interactive "P")
(scroll-all-function-all 'end-of-buffer arg))
@@ -105,7 +108,7 @@
When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame."
- nil " *SL*" nil
+ :lighter " *SL*"
:global t
:group 'windows
(if scroll-all-mode
diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el
index 802cb3072fa..eecdb60f3a4 100644
--- a/lisp/scroll-bar.el
+++ b/lisp/scroll-bar.el
@@ -1,4 +1,4 @@
-;;; scroll-bar.el --- window system-independent scroll bar support
+;;; scroll-bar.el --- window system-independent scroll bar support -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el
index 7b529c10741..d283b8089ce 100644
--- a/lisp/scroll-lock.el
+++ b/lisp/scroll-lock.el
@@ -1,4 +1,4 @@
-;;; scroll-lock.el --- Scroll lock scrolling.
+;;; scroll-lock.el --- Scroll lock scrolling. -*- lexical-binding:t -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -40,9 +40,8 @@
map)
"Keymap for Scroll Lock mode.")
-(defvar scroll-lock-preserve-screen-pos-save scroll-preserve-screen-position
+(defvar-local scroll-lock-preserve-screen-pos-save scroll-preserve-screen-position
"Used for saving the state of `scroll-preserve-screen-position'.")
-(make-variable-buffer-local 'scroll-lock-preserve-screen-pos-save)
(defvar scroll-lock-temporary-goal-column 0
"Like `temporary-goal-column' but for scroll-lock-* commands.")
@@ -64,7 +63,7 @@ MS-Windows systems if `w32-scroll-lock-modifier' is non-nil."
(progn
(setq scroll-lock-preserve-screen-pos-save
scroll-preserve-screen-position)
- (set (make-local-variable 'scroll-preserve-screen-position) 'always))
+ (setq-local scroll-preserve-screen-position 'always))
(setq scroll-preserve-screen-position
scroll-lock-preserve-screen-pos-save)))
diff --git a/lisp/select.el b/lisp/select.el
index c39bc93deab..eaa74cebd80 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -184,11 +184,17 @@ decoded. If `gui-get-selection' signals an error, return nil."
(let ((clip-text
(when select-enable-clipboard
(let ((text (gui--selection-value-internal 'CLIPBOARD)))
- (if (string= text "") (setq text nil))
-
- ;; Check the CLIPBOARD selection for 'newness', is it different
- ;; from what we remembered them to be last time we did a
- ;; cut/paste operation.
+ (when (string= text "")
+ (setq text nil))
+ ;; When `select-enable-clipboard' is non-nil,
+ ;; killing/copying text (with, say, `C-w') will push the
+ ;; text to the clipboard (and store it in
+ ;; `gui--last-selected-text-clipboard'). We check
+ ;; whether the text on the clipboard is identical to this
+ ;; text, and if so, we report that the clipboard is
+ ;; empty. See (bug#27442) for further discussion about
+ ;; this DWIM action, and possible ways to make this check
+ ;; less fragile, if so desired.
(prog1
(unless (equal text gui--last-selected-text-clipboard)
text)
diff --git a/lisp/server.el b/lisp/server.el
index a783f676ee0..ac5db197f3e 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -197,9 +197,8 @@ The created frame is selected when the hook is called."
"List of current server clients.
Each element is a process.")
-(defvar server-buffer-clients nil
+(defvar-local server-buffer-clients nil
"List of client processes requesting editing of current buffer.")
-(make-variable-buffer-local 'server-buffer-clients)
;; Changing major modes should not erase this local.
(put 'server-buffer-clients 'permanent-local t)
@@ -239,11 +238,10 @@ in this way."
:type 'boolean
:version "21.1")
-(defvar server-existing-buffer nil
+(defvar-local server-existing-buffer nil
"Non-nil means the buffer existed before the server was asked to visit it.
This means that the server should not kill the buffer when you say you
are done with it in the server.")
-(make-variable-buffer-local 'server-existing-buffer)
(defvar server--external-socket-initialized nil
"When an external socket is passed into Emacs, we need to call
@@ -268,16 +266,23 @@ the \"-f\" switch otherwise."
:type 'string
:version "23.1")
+(defcustom server-client-instructions t
+ "If non-nil, display instructions on how to exit the client on connection.
+If nil, no instructions are displayed."
+ :version "28.1"
+ :type 'boolean)
+
;; We do not use `temporary-file-directory' here, because emacsclient
;; does not read the init file.
(defvar server-socket-dir
(if internal--daemon-sockname
(file-name-directory internal--daemon-sockname)
(and (featurep 'make-network-process '(:family local))
- (let ((xdg_runtime_dir (getenv "XDG_RUNTIME_DIR")))
- (if xdg_runtime_dir
- (format "%s/emacs" xdg_runtime_dir)
- (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))))))
+ (let ((runtime-dir (getenv "XDG_RUNTIME_DIR")))
+ (if runtime-dir
+ (expand-file-name "emacs" runtime-dir)
+ (expand-file-name (format "emacs%d" (user-uid))
+ (or (getenv "TMPDIR") "/tmp"))))))
"The directory in which to place the server socket.
If local sockets are not supported, this is nil.")
@@ -353,9 +358,11 @@ Updates `server-clients'."
(setq server-clients (delq proc server-clients))
- ;; Delete the client's tty, except on Windows (both GUI and console),
- ;; where there's only one terminal and does not make sense to delete it.
- (unless (eq system-type 'windows-nt)
+ ;; Delete the client's tty, except on Windows (both GUI and
+ ;; console), where there's only one terminal and does not make
+ ;; sense to delete it, or if we are explicitly told not.
+ (unless (or (eq system-type 'windows-nt)
+ (process-get proc 'no-delete-terminal))
(let ((terminal (process-get proc 'terminal)))
;; Only delete the terminal if it is non-nil.
(when (and terminal (eq (terminal-live-p terminal) t))
@@ -406,9 +413,14 @@ 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)
+ ;; If this variable is non-nil, the socket was passed in to
+ ;; Emacs, and not created by Emacs itself (for instance,
+ ;; created by systemd). In that case, don't delete the socket.
+ (not internal--daemon-sockname)
(ignore-errors
(delete-file (process-get proc :server-file))))
- (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
+ (server-log (format "Status changed to %s: %s"
+ (process-status proc) msg) proc)
(server-delete-client proc))
(defun server--on-display-p (frame display)
@@ -563,7 +575,7 @@ See variable `server-auth-dir' for details."
(format "it is not owned by you (owner = %s (%d))"
(user-full-name uid) uid))
(w32 nil) ; on NTFS?
- ((let ((modes (file-modes dir)))
+ ((let ((modes (file-modes dir 'nofollow)))
(unless (zerop (logand (or modes 0) #o077))
(format "it is accessible by others (%03o)" modes))))
(t nil))))
@@ -645,7 +657,17 @@ the `server-process' variable."
;; Remove any leftover socket or authentication file.
(ignore-errors
(let (delete-by-moving-to-trash)
- (delete-file server-file)))
+ (delete-file server-file)
+ ;; Also delete the directory that the server file was
+ ;; created in -- but only in /tmp (see bug#44644).
+ ;; There may be other servers running, too, so this may
+ ;; fail.
+ (when (equal (file-name-directory
+ (directory-file-name
+ (file-name-directory server-file)))
+ "/tmp/")
+ (ignore-errors
+ (delete-directory (file-name-directory server-file))))))
(setq server-mode nil) ;; already set by the minor mode code
(display-warning
'server
@@ -727,7 +749,8 @@ If server is running, it is first stopped.
NAME defaults to `server-name'. With argument, ask for NAME."
(interactive
(list (if current-prefix-arg
- (read-string "Server name: " nil nil server-name))))
+ (read-string (format-prompt "Server name" server-name)
+ nil nil server-name))))
(when server-mode (with-temp-message nil (server-mode -1)))
(let ((file (expand-file-name (or name server-name)
(if server-use-tcp
@@ -828,7 +851,6 @@ This handles splitting the command if it would be bigger than
(error "Invalid terminal device"))
(unless type
(error "Invalid terminal type"))
- (add-to-list 'frame-inherited-parameters 'client)
(let ((frame
(server-with-environment
(process-get proc 'env)
@@ -840,32 +862,19 @@ This handles splitting the command if it would be bigger than
"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))
- ,@parameters)))))
+ (server--create-frame
+ ;; Ignore nowait here; we always need to
+ ;; clean up opened ttys when the client dies.
+ nil proc
+ `((window-system . nil)
+ (tty . ,tty)
+ (tty-type . ,type)
+ ,@parameters)))))
;; ttys don't use the `display' parameter, but callproc.c does to set
;; the DISPLAY environment on subprocesses.
(set-frame-parameter frame 'display
(getenv-internal "DISPLAY" (process-get proc 'env)))
- (select-frame frame)
- (process-put proc 'frame frame)
- (process-put proc 'terminal (frame-terminal frame))
frame))
(defun server-create-window-system-frame (display nowait proc parent-id
@@ -891,31 +900,56 @@ This handles splitting the command if it would be bigger than
)
(cond (w
- ;; Flag frame as client-created, but use a dummy client.
- ;; This will prevent the frame from being deleted when
- ;; emacsclient quits while also preventing
- ;; `server-save-buffers-kill-terminal' from unexpectedly
- ;; killing emacs on that frame.
- (let* ((params `((client . ,(if nowait 'nowait proc))
- ;; This is a leftover, see above.
- (environment . ,(process-get proc 'env))
- ,@parameters))
- frame)
- (if parent-id
- (push (cons 'parent-id (string-to-number parent-id)) params))
- (add-to-list 'frame-inherited-parameters 'client)
- (setq frame (make-frame-on-display display params))
- (server-log (format "%s created" frame) proc)
- (select-frame frame)
- (process-put proc 'frame frame)
- (process-put proc 'terminal (frame-terminal frame))
- frame))
+ (server--create-frame
+ nowait proc
+ `((display . ,display)
+ ,@(if parent-id
+ `((parent-id . ,(string-to-number parent-id))))
+ ,@parameters)))
(t
(server-log "Window system unsupported" proc)
(server-send-string proc "-window-system-unsupported \n")
nil))))
+(defun server-create-dumb-terminal-frame (nowait proc &optional parameters)
+ ;; If the destination is a dumb terminal, we can't really run Emacs
+ ;; in its tty. So instead, we use whichever terminal is currently
+ ;; selected. This situation typically occurs when `emacsclient' is
+ ;; running inside something like an Emacs shell buffer (bug#25547).
+ (let ((frame (server--create-frame nowait proc parameters)))
+ ;; The client is not the exclusive owner of this terminal, so don't
+ ;; delete the terminal when the client exits.
+ ;; FIXME: Maybe we just shouldn't set the `terminal' property instead?
+ (process-put proc 'no-delete-terminal t)
+ frame))
+
+(defun server--create-frame (nowait proc parameters)
+ (add-to-list 'frame-inherited-parameters 'client)
+ ;; When `nowait' is set, flag frame as client-created, but use
+ ;; a dummy client. This will prevent the frame from being deleted
+ ;; when emacsclient quits while also preventing
+ ;; `server-save-buffers-kill-terminal' from unexpectedly killing
+ ;; emacs on that frame.
+ (let ((frame (make-frame `((client . ,(if nowait 'nowait 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))
+ ,@parameters))))
+ (server-log (format "%s created" frame) proc)
+ (select-frame frame)
+ (process-put proc 'frame frame)
+ (process-put proc 'terminal (frame-terminal frame))
+ frame))
+
(defun server-goto-toplevel (proc)
(condition-case nil
;; If we're running isearch, we must abort it to allow Emacs to
@@ -1262,6 +1296,9 @@ The following commands are accepted by the client:
terminal-frame)))))
(setq tty-name nil tty-type nil)
(if display (server-select-display display)))
+ ((equal tty-type "dumb")
+ (server-create-dumb-terminal-frame nowait proc
+ frame-parameters))
((or (and (eq system-type 'windows-nt)
(daemonp)
(setq display "w32"))
@@ -1271,7 +1308,17 @@ The following commands are accepted by the client:
frame-parameters))
;; When resuming on a tty, tty-name is nil.
(tty-name
- (server-create-tty-frame tty-name tty-type proc))))
+ (server-create-tty-frame tty-name tty-type proc))
+
+ ;; If there won't be a current frame to use, fall
+ ;; back to trying to create a new one.
+ ((and use-current-frame
+ (daemonp)
+ (null (cdr (frame-list)))
+ (eq (selected-frame) terminal-frame)
+ display)
+ (setq tty-name nil tty-type nil)
+ (server-select-display display))))
(process-put
proc 'continuation
@@ -1332,15 +1379,25 @@ The following commands are accepted by the client:
nil)
((and frame (null buffers))
(run-hooks 'server-after-make-frame-hook)
- (message "%s" (substitute-command-keys
- "When done with this frame, type \\[delete-frame]")))
+ (when server-client-instructions
+ (message "%s"
+ (substitute-command-keys
+ "When done with this frame, type \\[delete-frame]"))))
((not (null buffers))
(run-hooks 'server-after-make-frame-hook)
- (server-switch-buffer (car buffers) nil (cdr (car files)))
+ (server-switch-buffer
+ (car buffers) nil (cdr (car files))
+ ;; When triggered from "emacsclient -c", we popped up a
+ ;; new frame. Ensure that we switch to the requested
+ ;; buffer in that frame, and not in some other frame
+ ;; where it may be displayed.
+ (plist-get (process-plist proc) 'frame))
(run-hooks 'server-switch-hook)
- (unless nowait
- (message "%s" (substitute-command-keys
- "When done with a buffer, type \\[server-edit]")))))
+ (when (and (not nowait)
+ server-client-instructions)
+ (message "%s"
+ (substitute-command-keys
+ "When done with a buffer, type \\[server-edit]")))))
(when (and frame (null tty-name))
(server-unselect-display frame)))
((quit error)
@@ -1556,7 +1613,9 @@ prevent a backup for it.) The variable `server-temp-file-regexp' controls
which filenames are considered temporary.
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]."
+starts server process and that is all. Invoked by \\[server-edit].
+
+To abort an edit instead of saying \"Done\", use \\[server-edit-abort]."
(interactive "P")
(cond
((or arg
@@ -1566,7 +1625,19 @@ starts server process and that is all. Invoked by \\[server-edit]."
(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)
+(defun server-edit-abort ()
+ "Abort editing the current client buffer."
+ (interactive)
+ (if server-clients
+ (mapc (lambda (proc)
+ (server-send-string
+ proc (concat "-error "
+ (server-quote-arg "Aborted by the user"))))
+ server-clients)
+ (message "This buffer has no clients")))
+
+(defun server-switch-buffer (&optional next-buffer killed-one filepos
+ this-frame-only)
"Switch to another buffer, preferably one that has a client.
Arg NEXT-BUFFER is a suggestion; if it is a live buffer, use it.
@@ -1600,7 +1671,8 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)."
;; OK, we know next-buffer is live, let's display and select it.
(if (functionp server-window)
(funcall server-window next-buffer)
- (let ((win (get-buffer-window next-buffer 0)))
+ (let ((win (get-buffer-window next-buffer
+ (if this-frame-only nil 0))))
(if (and win (not server-window))
;; The buffer is already displayed: just reuse the
;; window. If FILEPOS is non-nil, use it to replace the
@@ -1618,7 +1690,8 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)."
(setq server-window (make-frame)))
(select-window (frame-selected-window server-window))))
(when (window-minibuffer-p)
- (select-window (next-window nil 'nomini 0)))
+ (select-window (next-window nil 'nomini
+ (if this-frame-only nil 0))))
;; Move to a non-dedicated window, if we have one.
(when (window-dedicated-p)
(select-window
diff --git a/lisp/ses.el b/lisp/ses.el
index f9b204797a3..ca515f829dc 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -1,4 +1,4 @@
-;;; ses.el -- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
+;;; ses.el --- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -172,14 +172,14 @@ Each function is called with ARG=1."
(defvar ses--completion-table nil
"Set globally to what completion table to use depending on type
- of completion (local printers, cells, etc.). We need to go
- through a local variable to pass the SES buffer local variable
- to completing function while the current buffer is the
- minibuffer.")
+of completion (local printers, cells, etc.). We need to go
+through a local variable to pass the SES buffer local variable
+to completing function while the current buffer is the
+minibuffer.")
(defvar ses--list-orig-buffer nil
- "Calling buffer for SES listing help. Used for listing local
- printers or renamed cells.")
+ "Calling buffer for SES listing help.
+Used for listing local printers or renamed cells.")
(defconst ses-mode-edit-map
@@ -332,9 +332,9 @@ column or default printer and then modify its output.")
next-line-add-newlines transient-mark-mode)
"Buffer-local variables used by SES."))
-(defmacro ses--metaprogramming (exp) (declare (debug t)) (eval exp t))
-(ses--metaprogramming
- `(progn ,@(mapcar (lambda (x) `(defvar ,(or (car-safe x) x))) ses-localvars)))
+(defmacro ses--\,@ (exp) (declare (debug t)) (macroexp-progn (eval exp t)))
+(ses--\,@
+ (mapcar (lambda (x) `(defvar ,(or (car-safe x) x))) ses-localvars))
(defun ses-set-localvars ()
"Set buffer-local and initialize some SES variables."
@@ -395,8 +395,9 @@ left-justification of the result. Set to error-signal if `ses-call-printer'
encountered an error during printing. Otherwise nil.")
(defvar ses-start-time nil
- "Time when current operation started. Used by `ses--time-check' to decide
-when to emit a progress message.")
+ "Time when current operation started.
+Used by `ses--time-check' to decide when to emit a progress
+message.")
;;----------------------------------------------------------------------------
@@ -430,7 +431,8 @@ when to emit a progress message.")
local-printer-list)
(defmacro ses-cell-symbol (row &optional col)
- "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value. (0,0) => A1."
+ "Return symbol of the local-variable holding value of CELL or pair (ROW,COL).
+For example, (0,0) => A1."
(declare (debug t))
`(ses-cell--symbol ,(if col `(ses-get-cell ,row ,col) row)))
(put 'ses-cell-symbol 'safe-function t)
@@ -559,9 +561,10 @@ the corresponding cell with name PROPERTY-NAME."
(eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
(defun ses--cell (sym value formula printer references)
- "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
-FORMULA, does not reprint using PRINTER, does not check REFERENCES.
-Safety-checking for FORMULA and PRINTER are deferred until first use."
+ "Load a cell SYM from the spreadsheet file.
+Does not recompute VALUE from FORMULA, does not reprint using
+PRINTER, does not check REFERENCES. Safety-checking for FORMULA
+and PRINTER are deferred until first use."
(let ((rowcol (ses-sym-rowcol sym)))
(ses-formula-record formula)
(ses-printer-record printer)
@@ -579,8 +582,7 @@ Safety-checking for FORMULA and PRINTER are deferred until first use."
(set sym value))
(defun ses-local-printer-compile (printer)
- "Convert local printer function into faster printer
-definition."
+ "Convert local printer function into faster printer definition."
(cond
((functionp printer) printer)
((stringp printer)
@@ -609,8 +611,8 @@ Return the printer info."
ses--local-printer-hashmap))
(defmacro ses-column-widths (widths)
- "Load the vector of column widths from the spreadsheet file. This is a
-macro to prevent propagate-on-load viruses."
+ "Load the vector of column widths from the spreadsheet file.
+This is a macro to prevent propagate-on-load viruses."
(or (and (vectorp widths) (= (length widths) ses--numcols))
(error "Bad column-width vector"))
;;To save time later, we also calculate the total width of each line in the
@@ -747,8 +749,8 @@ for this spreadsheet."
(intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
(defun ses-decode-cell-symbol (str)
- "Decode a symbol \"A1\" => (0,0). Return nil if STR is not a
-canonical cell name."
+ "Decode a symbol \"A1\" => (0,0).
+Return nil if STR is not a canonical cell name."
(let (case-fold-search)
(and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str)
(let* ((col-str (match-string-no-properties 1 str))
@@ -839,31 +841,31 @@ and ARGS and reset `ses-start-time' to the current time."
"Install VAL as the contents for field FIELD (named by a quoted symbol) of
cell (ROW,COL). This is undoable. The cell's data will be updated through
`post-command-hook'."
- `(let ((row ,row)
- (col ,col)
- (val ,val))
- (let* ((cell (ses-get-cell row col))
+ (macroexp-let2 nil row row
+ (macroexp-let2 nil col col
+ (macroexp-let2 nil val val
+ `(let* ((cell (ses-get-cell ,row ,col))
(change
,(let ((field (progn (cl-assert (eq (car field) 'quote))
(cadr field))))
(if (eq field 'value)
- '(ses-set-with-undo (ses-cell-symbol cell) val)
+ `(ses-set-with-undo (ses-cell-symbol cell) ,val)
;; (let* ((slots (get 'ses-cell 'cl-struct-slots))
;; (slot (or (assq field slots)
;; (error "Unknown field %S" field)))
;; (idx (- (length slots)
;; (length (memq slot slots)))))
- ;; `(ses-aset-with-undo cell ,idx val))
+ ;; `(ses-aset-with-undo cell ,idx ,val))
(let ((getter (intern-soft (format "ses-cell--%s" field))))
`(ses-setter-with-undo
(eval-when-compile
(cons #',getter
(lambda (newval cell)
(setf (,getter cell) newval))))
- val cell))))))
+ ,val cell))))))
(if change
- (add-to-list 'ses--deferred-write (cons row col))))
- nil)) ; Make coverage-tester happy.
+ (add-to-list 'ses--deferred-write (cons ,row ,col)))
+ nil))))) ; Make coverage-tester happy.
(defun ses-cell-set-formula (row col formula)
"Store a new formula for (ROW . COL) and enqueue the cell for
@@ -1060,15 +1062,15 @@ the old and FORCE is nil."
(ses-cell-set-formula row col nil))
(defcustom ses-self-reference-early-detection nil
- "True if cycle detection is early for cells that refer to themselves."
+ "Non-nil if cycle detection is early for cells that refer to themselves."
:version "24.1"
:type 'boolean
:group 'ses)
(defun ses-update-cells (list &optional force)
- "Recalculate cells in LIST, checking for dependency loops. Prints
-progress messages every second. Dependent cells are not recalculated
-if the cell's value is unchanged and FORCE is nil."
+ "Recalculate cells in LIST, checking for dependency loops.
+Print progress messages every second. Dependent cells are not
+recalculated if the cell's value is unchanged and FORCE is nil."
(let ((ses--deferred-recalc list)
(nextlist list)
(pos (point))
@@ -2024,7 +2026,7 @@ Delete overlays, remove special text properties."
When you invoke SES in a new buffer, it is divided into cells
that you can enter data into. You can navigate the cells with
the arrow keys and add more cells with the tab key. The contents
-of these cells can be numbers, text, or Lisp expressions. (To
+of these cells can be numbers, text, or Lisp expressions. (To
enter text, enclose it in double quotes.)
In an expression, you can use cell coordinates to refer to the
@@ -2130,9 +2132,9 @@ formula:
(defun ses-command-hook ()
"Invoked from `post-command-hook'. If point has moved to a different cell,
-moves the underlining overlay. Performs any recalculations or cell-data
+move the underlining overlay. Perform any recalculations or cell-data
writes that have been deferred. If buffer-narrowing has been deferred,
-narrows the buffer now."
+narrow the buffer now."
(condition-case err
(when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
(when ses--deferred-recalc
@@ -2250,9 +2252,8 @@ Based on the current set of columns and `window-hscroll' position."
(push (symbol-name key) names))
ses--named-cell-hashmap)
names)))))
- (if
- (string= s "")
- (error "Invalid cell name")
+ (if (string= s "")
+ (user-error "Invalid cell name")
(list (intern s)))))
(let ((rowcol (ses-sym-rowcol sym)))
(or rowcol (error "Invalid cell name"))
@@ -2266,8 +2267,8 @@ Based on the current set of columns and `window-hscroll' position."
(ses-jump cell)))
(defun ses-reprint-all (&optional nonarrow)
- "Recreate the display area. Calls all printer functions. Narrows to
-print area if NONARROW is nil."
+ "Recreate the display area. Call all printer functions.
+Narrow to print area if optional argument NONARROW is nil."
(interactive "*P")
(widen)
(unless nonarrow
@@ -2494,8 +2495,8 @@ to are recalculated first."
(and collection (list start end collection))))))
(defun ses-edit-cell (row col newval)
- "Display current cell contents in minibuffer, for editing. Returns nil if
-cell formula was unsafe and user declined confirmation."
+ "Display current cell contents in minibuffer, for editing.
+Return nil if cell formula was unsafe and user declined confirmation."
(interactive
(progn
(barf-if-buffer-read-only)
@@ -2540,10 +2541,8 @@ cell formula was unsafe and user declined confirmation."
(if (equal initial "\"")
(progn
(if (not (stringp curval)) (setq curval nil))
- (read-string (if curval
- (format "String Cell %s (default %s): "
- ses--curcell curval)
- (format "String Cell %s: " ses--curcell))
+ (read-string (format-prompt "String Cell %s"
+ curval ses--curcell)
nil 'ses-read-string-history curval))
(read-from-minibuffer
(format "Cell %s: " ses--curcell)
@@ -2560,8 +2559,9 @@ cell formula was unsafe and user declined confirmation."
(funcall x 1))))
(defun ses-read-symbol (row col symb)
- "Self-insert for a symbol as a cell formula. The set of all symbols that
-have been used as formulas in this spreadsheet is available for completions."
+ "Self-insert for a symbol as a cell formula.
+The set of all symbols that have been used as formulas in this
+spreadsheet is available for completions."
(interactive
(let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
newval)
@@ -2594,7 +2594,7 @@ With prefix, deletes several cells."
(forward-char 1))))
(defun ses-clear-cell-backward (count)
- "Move to previous cell and then delete it. With prefix, deletes several
+ "Move to previous cell and then delete it. With prefix, delete several
cells."
(interactive "*p")
(if (< count 0)
@@ -2654,9 +2654,7 @@ canceled."
(barf-if-buffer-read-only)
(if (eq default t)
(setq default "")
- (setq prompt (format "%s (default %S): "
- (substring prompt 0 -2)
- default)))
+ (setq prompt (format-prompt prompt default)))
(dolist (key ses-completion-keys)
(define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol))
;; make it globally visible, so that it can be visible from the minibuffer.
@@ -2703,7 +2701,7 @@ right-justified) or a list of one string (will be left-justified)."
;;Range contains differing printer functions
(setq default t)
(throw 'ses-read-cell-printer t))))))
- (list (ses-read-printer (format "Cell %S printer: " ses--curcell)
+ (list (ses-read-printer (format "Cell %S printer" ses--curcell)
default))))
(unless (eq newval t)
(ses-begin-change)
@@ -2717,7 +2715,7 @@ See `ses-read-cell-printer' for input forms."
(interactive
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(ses-check-curcell)
- (list col (ses-read-printer (format "Column %s printer: "
+ (list col (ses-read-printer (format "Column %s printer"
(ses-column-letter col))
(ses-col-printer col)))))
@@ -2732,7 +2730,7 @@ See `ses-read-cell-printer' for input forms."
"Set the default printer function for cells that have no other.
See `ses-read-cell-printer' for input forms."
(interactive
- (list (ses-read-printer "Default printer: " ses--default-printer)))
+ (list (ses-read-printer "Default printer" ses--default-printer)))
(unless (eq newval t)
(ses-begin-change)
(ses-set-parameter 'ses--default-printer newval)
@@ -3007,9 +3005,9 @@ inserts a new row if at bottom of print area. Repeat COUNT times."
(list col
(if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
- (read-from-minibuffer (format "Column %s width (default %d): "
- (ses-column-letter col)
- (ses-col-width col))
+ (read-from-minibuffer (format-prompt "Column %s width"
+ (ses-col-width col)
+ (ses-column-letter col))
nil ; No initial contents.
nil ; No override keymap.
t ; Convert to Lisp object.
@@ -3374,15 +3372,15 @@ is non-nil. Newlines and tabs in the export text are escaped."
;;----------------------------------------------------------------------------
(defun ses-list-local-printers (&optional local-printer-hashmap)
- "List local printers in a help buffer. Can be called either
-during editing a printer or a formula, or while in the SES
-buffer."
+ "List local printers in a help buffer.
+Can be called either during editing a printer or a formula, or
+while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--local-printer-hashmap)
((minibufferp) ses--completion-table)
((derived-mode-p 'help-mode) nil)
- (t (error "Not in a SES buffer")))))
+ (t (user-error "Not in a SES buffer")))))
(when local-printer-hashmap
(let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
(help-setup-xref
@@ -3408,15 +3406,15 @@ buffer."
(buffer-string)))))))
(defun ses-list-named-cells (&optional named-cell-hashmap)
- "List named cells in a help buffer. Can be called either
-during editing a printer or a formula, or while in the SES
-buffer."
+ "List named cells in a help buffer.
+Can be called either during editing a printer or a formula, or
+while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--named-cell-hashmap)
((minibufferp) ses--completion-table)
((derived-mode-p 'help-mode) nil)
- (t (error "Not in a SES buffer")))))
+ (t (user-error "Not in a SES buffer")))))
(when named-cell-hashmap
(let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
(help-setup-xref
@@ -3459,7 +3457,9 @@ With a \\[universal-argument] prefix arg, prompt the user.
The top row is row 1. Selecting row 0 displays the default header row."
(interactive
(list (if (numberp current-prefix-arg) current-prefix-arg
- (let ((currow (1+ (car (ses-sym-rowcol ses--curcell)))))
+ (let* ((curcell (or (ses--cell-at-pos (point))
+ (user-error "Invalid header-row")))
+ (currow (1+ (car (ses-sym-rowcol curcell)))))
(if current-prefix-arg
(read-number "Header row: " currow)
currow)))))
@@ -3674,7 +3674,7 @@ highlighted range in the spreadsheet."
;; 'rowcol' corresponding to 'ses-cell' property of symbol
;; 'sym'. Both must be the same.
(unless (eq sym old-name)
- (error "Spreadsheet is broken, both symbols %S and %S refering to cell (%d,%d)" sym old-name row col))
+ (error "Spreadsheet is broken, both symbols %S and %S referring to cell (%d,%d)" sym old-name row col))
(if new-rowcol
;; the new name is of A1 type, so we test that the coordinate
;; inferred from new name
@@ -3687,7 +3687,7 @@ highlighted range in the spreadsheet."
(puthash new-name rowcol ses--named-cell-hashmap))
(push `(ses-rename-cell ,old-name ,cell) buffer-undo-list)
(cl-pushnew rowcol ses--deferred-write :test #'equal)
- ;; Replace name by new name in formula of cells refering to renamed cell.
+ ;; Replace name by new name in formula of cells referring to renamed cell.
(dolist (ref (ses-cell-references cell))
(let* ((x (ses-sym-rowcol ref))
(xcell (ses-get-cell (car x) (cdr x))))
@@ -3774,7 +3774,7 @@ function is redefined."
(setq name (intern name))
(let* ((cur-printer (gethash name ses--local-printer-hashmap))
(default (and cur-printer (ses--locprn-def cur-printer))))
- (setq def (ses-read-printer (format "Enter definition of printer %S: " name)
+ (setq def (ses-read-printer (format "Enter definition of printer %S" name)
default)))
(list name def)))
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index 4cd3770c919..f67b0b9b39c 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -1,4 +1,4 @@
-;;; shadowfile.el --- automatic file copying
+;;; shadowfile.el --- automatic file copying -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -90,27 +90,23 @@
"If t, always copy shadow files without asking.
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)
+ :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe)))
(defcustom shadow-inhibit-message nil
"If non-nil, do not display a message when a file needs copying."
- :type 'boolean
- :group 'shadow)
+ :type 'boolean)
(defcustom shadow-inhibit-overload nil
"If non-nil, shadowfile won't redefine \\[save-buffers-kill-emacs].
Normally it overloads the function `save-buffers-kill-emacs' to check for
files that have been changed and need to be copied to other systems."
- :type 'boolean
- :group 'shadow)
+ :type 'boolean)
(defcustom shadow-info-file (locate-user-emacs-file "shadows" ".shadows")
"File to keep shadow information in.
The `shadow-info-file' should be shadowed to all your accounts to
ensure consistency. Default: ~/.emacs.d/shadows"
:type 'file
- :group 'shadow
:version "26.2")
(defcustom shadow-todo-file
@@ -122,18 +118,17 @@ remember and ask you again in your next Emacs session.
This file must NOT be shadowed to any other system, it is host-specific.
Default: ~/.emacs.d/shadow_todo"
:type 'file
- :group 'shadow
:version "26.2")
-;;; 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).
+;; 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).
(defvar shadow-system-name (concat "/" (system-name) ":")
"The identification for local files on this machine.")
-(defvar shadow-homedir "~"
+(defvar shadow-homedir "~/"
"Your home directory on this machine.")
;;;
@@ -160,7 +155,7 @@ created by `shadow-define-regexp-group'.")
(defvar shadow-files-to-copy nil) ; List of files that need to
; be copied to remote hosts.
-(defvar shadow-hashtable nil) ; for speed
+(defvar shadow-hashtable (make-hash-table :test #'equal)) ; for speed
(defvar shadow-info-buffer nil) ; buf visiting shadow-info-file
(defvar shadow-todo-buffer nil) ; buf visiting shadow-todo-file
@@ -172,20 +167,6 @@ created by `shadow-define-regexp-group'.")
;;; Syntactic sugar; General list and string manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun shadow-union (a b)
- "Add members of list A to list B if not equal to items already in B."
- (if (null a)
- b
- (if (member (car a) b)
- (shadow-union (cdr a) b)
- (shadow-union (cdr a) (cons (car a) b)))))
-
-(defun shadow-find (func list)
- "If FUNC applied to some element of LIST is non-nil, return first such element."
- (while (and list (not (funcall func (car list))))
- (setq list (cdr list)))
- (car list))
-
(defun shadow-regexp-superquote (string)
"Like `regexp-quote', but includes the \\` and \\'.
This makes sure regexp matches nothing but STRING."
@@ -205,11 +186,11 @@ PREFIX."
;;; Clusters and sites
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; I use the term `site' to refer to a string which may be the
-;;; cluster identification "/name:", a remote identification
-;;; "/method:user@host:", or "/system-name:" (the value of
-;;; `shadow-system-name') for the location of local files. All
-;;; user-level commands should accept either.
+;; I use the term `site' to refer to a string which may be the
+;; cluster identification "/name:", a remote identification
+;; "/method:user@host:", or "/system-name:" (the value of
+;; `shadow-system-name') for the location of local files. All
+;; user-level commands should accept either.
(cl-defstruct (shadow-cluster (:type list) :named) name primary regexp)
@@ -226,7 +207,7 @@ information defining the cluster. For interactive use, call
(defun shadow-get-cluster (name)
"Return cluster named NAME, or nil."
- (shadow-find
+ (seq-find
(lambda (x) (string-equal (shadow-cluster-name x) name))
shadow-clusters))
@@ -252,7 +233,7 @@ information defining the cluster. For interactive use, call
(defun shadow-site-cluster (site)
"Given a SITE, return cluster it is in, or nil."
(or (shadow-get-cluster (shadow-site-name site))
- (shadow-find
+ (seq-find
(lambda (x)
(string-match (shadow-cluster-regexp x) (shadow-name-site site)))
shadow-clusters)))
@@ -303,9 +284,13 @@ Argument can be a simple name, remote file name, or already a
(defsubst shadow-make-fullname (hup &optional host name)
"Make a Tramp style fullname out of HUP, a `tramp-file-name' structure.
-Replace HOST, and NAME when non-nil."
+Replace HOST, and NAME when non-nil. HOST can also be a remote file name."
(let ((hup (copy-tramp-file-name hup)))
- (when host (setf (tramp-file-name-host hup) host))
+ (when host
+ (if (file-remote-p host)
+ (setq name (or name (and hup (tramp-file-name-localname hup)))
+ hup (tramp-dissect-file-name (file-remote-p host)))
+ (setf (tramp-file-name-host hup) host)))
(when name (setf (tramp-file-name-localname hup) name))
(if (null (tramp-file-name-method hup))
(format
@@ -367,15 +352,16 @@ Will return the name bare if it is a local file."
(defun shadow-contract-file-name (file)
"Simplify FILE.
-Do so by replacing (when possible) home directory with ~, and hostname
-with cluster name that includes it. Filename should be absolute and
-true."
+Do so by replacing (when possible) home directory with ~/, and
+hostname with cluster name that includes it. Filename should be
+absolute and true."
(let* ((hup (shadow-parse-name file))
(homedir (if (shadow-local-file hup)
shadow-homedir
(file-name-as-directory
(file-local-name
- (expand-file-name (shadow-make-fullname hup nil "~"))))))
+ (expand-file-name
+ (shadow-make-fullname hup nil shadow-homedir))))))
(suffix (shadow-suffix homedir (tramp-file-name-localname hup)))
(cluster (shadow-site-cluster (shadow-make-fullname hup nil ""))))
(when cluster
@@ -384,7 +370,7 @@ true."
(shadow-make-fullname
hup nil
(if suffix
- (concat "~/" suffix)
+ (concat shadow-homedir suffix)
(tramp-file-name-localname hup)))))
(defun shadow-same-site (pattern file)
@@ -524,10 +510,9 @@ call it manually."
(if (called-interactively-p 'interactive)
(message "No files need to be shadowed."))
(save-excursion
- (map-y-or-n-p (function
- (lambda (pair)
- (or arg shadow-noquery
- (format "Copy shadow file %s? " (cdr pair)))))
+ (map-y-or-n-p (lambda (pair)
+ (or arg shadow-noquery
+ (format "Copy shadow file %s? " (cdr pair))))
(function shadow-copy-file)
shadow-files-to-copy
'("shadow" "shadows" "copy"))
@@ -540,11 +525,11 @@ them again, unless you make more changes to the files. To cancel a shadow
permanently, remove the group from `shadow-literal-groups' or
`shadow-regexp-groups'."
(interactive)
- (map-y-or-n-p (function (lambda (pair)
- (format "Cancel copying %s to %s? "
- (car pair) (cdr pair))))
- (function (lambda (pair)
- (shadow-remove-from-todo pair)))
+ (map-y-or-n-p (lambda (pair)
+ (format "Cancel copying %s to %s? "
+ (car pair) (cdr pair)))
+ (lambda (pair)
+ (shadow-remove-from-todo pair))
shadow-files-to-copy
'("shadow" "shadows" "cancel copy"))
(message "There are %d shadows to be updated."
@@ -595,14 +580,14 @@ be shadowed), and list of SITES."
Filename should have clusters expanded, but otherwise can have any format.
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))
+ (or (gethash file shadow-hashtable)
(let* ((absolute-file (shadow-expand-file-name
(or (shadow-local-file file) file)
shadow-homedir))
(canonical-file (shadow-contract-file-name absolute-file))
(shadows
- (mapcar (function (lambda (shadow)
- (cons absolute-file shadow)))
+ (mapcar (lambda (shadow)
+ (cons absolute-file shadow))
(append
(shadow-shadows-of-1
canonical-file shadow-literal-groups nil)
@@ -613,7 +598,7 @@ and to are absolute file names."
"shadow-shadows-of: %s %s %s %s %s"
file (shadow-local-file file) shadow-homedir
absolute-file canonical-file))
- (set (intern file shadow-hashtable) shadows))))
+ (puthash file shadows shadow-hashtable))))
(defun shadow-shadows-of-1 (file groups regexp)
"Return list of FILE's shadows in GROUPS.
@@ -632,9 +617,8 @@ Consider them as regular expressions if third arg REGEXP is true."
"shadow-shadows-of-1: %s %s %s"
file (shadow-parse-name file) realname))
(mapcar
- (function
- (lambda (x)
- (shadow-replace-name-component x realname)))
+ (lambda (x)
+ (shadow-replace-name-component x realname))
nonmatching)))
(t nonmatching))
(shadow-shadows-of-1 file (cdr groups) regexp)))))
@@ -655,7 +639,7 @@ Consider them as regular expressions if third arg REGEXP is true."
shadows shadow-files-to-copy (with-output-to-string (backtrace))))
(when shadows
(setq shadow-files-to-copy
- (shadow-union shadows shadow-files-to-copy))
+ (nreverse (cl-union shadows shadow-files-to-copy :test #'equal)))
(when (not shadow-inhibit-message)
(message "%s" (substitute-command-keys
"Use \\[shadow-copy-files] to update shadows."))
@@ -751,7 +735,7 @@ With non-nil argument also saves the buffer."
(sit-for 1))))))
(defun shadow-invalidate-hashtable ()
- (setq shadow-hashtable (make-vector 37 0)))
+ (clrhash shadow-hashtable))
(defun shadow-insert-var (variable)
"Build a `setq' to restore VARIABLE.
@@ -760,17 +744,17 @@ will restore VARIABLE to its current setting.
VARIABLE must be the name of a variable whose value is a list."
(let ((standard-output (current-buffer)))
(insert (format "(setq %s" variable))
- (cond ((consp (eval variable))
+ (cond ((consp (symbol-value variable))
(insert "\n '(")
- (prin1 (car (eval variable)))
- (let ((rest (cdr (eval variable))))
+ (prin1 (car (symbol-value variable)))
+ (let ((rest (cdr (symbol-value variable))))
(while rest
(insert "\n ")
(prin1 (car rest))
(setq rest (cdr rest)))
(insert "))\n\n")))
(t (insert " ")
- (prin1 (eval variable))
+ (prin1 (symbol-value variable))
(insert ")\n\n")))))
(defun shadow-save-buffers-kill-emacs (&optional arg)
@@ -779,6 +763,11 @@ With prefix arg, silently save all file-visiting buffers, then kill.
Extended by shadowfile to automatically save `shadow-todo-file' and
look for files that have been changed and need to be copied to other systems."
+ (interactive "P")
+ (shadow--save-buffers-kill-emacs arg)
+ (save-buffers-kill-emacs arg))
+
+(defun shadow--save-buffers-kill-emacs (&optional arg &rest _)
;; This function is necessary because we need to get control and save
;; the todo file /after/ saving other files, but /before/ the warning
;; message about unsaved buffers (because it can get modified by the
@@ -786,28 +775,10 @@ look for files that have been changed and need to be copied to other systems."
;; because it is not called at the correct time, and also because it is
;; called when the terminal is disconnected and we cannot ask whether
;; to copy files.
- (interactive "P")
(shadow-save-todo-file)
(save-some-buffers arg t)
(shadow-copy-files)
- (shadow-save-todo-file)
- (and (or (not (memq t (mapcar (function
- (lambda (buf) (and (buffer-file-name buf)
- (buffer-modified-p buf))))
- (buffer-list))))
- (yes-or-no-p "Modified buffers exist; exit anyway? "))
- (or (not (fboundp 'process-list))
- ;; `process-list' is not defined on MSDOS.
- (let ((processes (process-list))
- active)
- (while processes
- (and (memq (process-status (car processes)) '(run stop open listen))
- (process-query-on-exit-flag (car processes))
- (setq active t))
- (setq processes (cdr processes)))
- (or (not active)
- (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
- (kill-emacs)))
+ (shadow-save-todo-file))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hook us up
@@ -826,22 +797,29 @@ look for files that have been changed and need to be copied to other systems."
(message "Shadowfile information files not found - aborting")
(beep)
(sit-for 3))
- (when (and (not shadow-inhibit-overload)
- (not (fboundp 'shadow-orig-save-buffers-kill-emacs)))
- (defalias 'shadow-orig-save-buffers-kill-emacs
- (symbol-function 'save-buffers-kill-emacs))
- (defalias 'save-buffers-kill-emacs 'shadow-save-buffers-kill-emacs))
- (add-hook 'write-file-functions 'shadow-add-to-todo)
- (define-key ctl-x-4-map "s" 'shadow-copy-files)))
+ (unless shadow-inhibit-overload
+ (advice-add 'save-buffers-kill-emacs :before
+ #'shadow--save-buffers-kill-emacs))
+ (add-hook 'write-file-functions #'shadow-add-to-todo)
+ (define-key ctl-x-4-map "s" #'shadow-copy-files)))
(defun shadowfile-unload-function ()
- (substitute-key-definition 'shadow-copy-files nil ctl-x-4-map)
- (when (fboundp 'shadow-orig-save-buffers-kill-emacs)
- (fset 'save-buffers-kill-emacs
- (symbol-function 'shadow-orig-save-buffers-kill-emacs)))
+ (substitute-key-definition #'shadow-copy-files nil ctl-x-4-map)
+ (advice-remove 'save-buffers-kill-emacs #'shadow--save-buffers-kill-emacs)
;; continue standard unloading
nil)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Obsolete
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun shadow-union (a b)
+ "Add members of list A to list B if not equal to items already in B."
+ (declare (obsolete cl-union "28.1"))
+ (nreverse (cl-union a b :test #'equal)))
+
+(define-obsolete-function-alias 'shadow-find #'seq-find "28.1")
+
(provide 'shadowfile)
;;; shadowfile.el ends here
diff --git a/lisp/shell.el b/lisp/shell.el
index 560653eac91..5aab80d1031 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -26,9 +26,7 @@
;;; Commentary:
;; This file defines a shell-in-a-buffer package (shell mode) built on
-;; top of comint mode. This is actually cmushell with things renamed
-;; to replace its counterpart in Emacs 18. cmushell is more
-;; featureful, robust, and uniform than the Emacs 18 version.
+;; top of comint mode.
;; Since this mode is built on top of the general command-interpreter-in-
;; a-buffer mode (comint mode), it shares a common base functionality,
@@ -112,11 +110,6 @@
"Directory support in shell mode."
:group 'shell)
-;; Unused.
-;;; (defgroup shell-faces nil
-;;; "Faces in shell buffers."
-;;; :group 'shell)
-
;;;###autoload
(defcustom shell-dumb-shell-regexp (purecopy "cmd\\(proxy\\)?\\.exe")
"Regexp to match shells that don't save their command history, and
@@ -249,7 +242,7 @@ This mirrors the optional behavior of tcsh."
(defcustom shell-chdrive-regexp
(if (memq system-type '(ms-dos windows-nt))
; NetWare allows the five chars between upper and lower alphabetics.
- "[]a-zA-Z^_`\\[\\\\]:"
+ "[]a-zA-Z^_`[\\]:"
nil)
"If non-nil, is regexp used to track drive changes."
:type '(choice regexp
@@ -265,10 +258,11 @@ see the function `dirtrack-mode'."
:group 'shell-directories)
(defcustom explicit-shell-file-name nil
- "If non-nil, is file name to use for explicitly requested inferior shell.
-When nil, such interactive shell sessions fallback to using either
-the shell specified in $ESHELL or in `shell-file-name'."
- :type '(choice (const :tag "None" nil) file)
+ "If non-nil, the file name to use for explicitly requested inferior shells.
+When nil, such interactive shell sessions fall back to using the
+shell specified in either the environment variable \"ESHELL\" or
+`shell-file-name'."
+ :type '(choice (const :tag "Default" nil) file)
:group 'shell)
;; Note: There are no explicit references to the variable `explicit-csh-args'.
@@ -327,6 +321,15 @@ 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.")
+(defcustom shell-has-auto-cd nil
+ "If non-nil, `shell-mode' handles implicit \"cd\" commands.
+Implicit \"cd\" is changing the directory if the command is a directory.
+You can make this variable buffer-local to change it, per shell-mode instance.
+Useful for shells like zsh that has this feature."
+ :type 'boolean
+ :group 'shell-directories
+ :version "28.1")
+
(defvar shell-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-f" 'shell-forward-command)
@@ -334,6 +337,7 @@ Thus, this does not include the shell's current directory.")
(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 (kbd "C-x n d") 'shell-narrow-to-prompt)
(define-key map [menu-bar completion]
(cons "Complete"
(copy-keymap (lookup-key comint-mode-map [menu-bar completion]))))
@@ -374,7 +378,7 @@ Thus, this does not include the shell's current directory.")
"\\|\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)"
"\\|{\\(?1:[^{}]+\\)}\\)"
(when (memq system-type '(ms-dos windows-nt))
- "\\|%\\(?1:[^\\\\/]*\\)%")
+ "\\|%\\(?1:[^\\/]*\\)%")
(when comint-file-name-quote-list
"\\|\\\\\\(.\\)")))
(qupos nil)
@@ -455,43 +459,56 @@ Thus, this does not include the shell's current directory.")
(push (mapconcat #'identity (nreverse arg) "") args)))
(cons (nreverse args) (nreverse begins)))))
+;;;###autoload
+(defun split-string-shell-command (string)
+ "Split STRING (a shell command) into a list of strings.
+General shell syntax, like single and double quoting, as well as
+backslash quoting, is respected."
+ (with-temp-buffer
+ (insert string)
+ (let ((comint-file-name-quote-list shell-file-name-quote-list))
+ (car (shell--parse-pcomplete-arguments)))))
+
(defun shell-command-completion-function ()
"Completion function for shell command names.
This is the value of `pcomplete-command-completion-function' for
Shell buffers. It implements `shell-completion-execonly' for
`pcomplete' completion."
- (pcomplete-here (pcomplete-entries nil
- (if shell-completion-execonly
- 'file-executable-p))))
+ (if (pcomplete-match "/")
+ (pcomplete-here (pcomplete-entries nil
+ (if shell-completion-execonly
+ #'file-executable-p)))
+ (pcomplete-here
+ (nth 2 (shell--command-completion-data)))))
(defun shell-completion-vars ()
"Setup completion vars for `shell-mode' and `read-shell-command'."
- (set (make-local-variable 'comint-completion-fignore)
- shell-completion-fignore)
- (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-file-name-prefix)
- (or (file-remote-p default-directory) ""))
- (set (make-local-variable 'comint-dynamic-complete-functions)
- shell-dynamic-complete-functions)
+ (setq-local comint-completion-fignore
+ shell-completion-fignore)
+ (setq-local comint-delimiter-argument-list
+ shell-delimiter-argument-list)
+ (setq-local comint-file-name-chars shell-file-name-chars)
+ (setq-local comint-file-name-quote-list
+ shell-file-name-quote-list)
+ (setq-local comint-file-name-prefix
+ (or (file-remote-p default-directory) ""))
+ (setq-local comint-dynamic-complete-functions
+ shell-dynamic-complete-functions)
(setq-local comint-unquote-function #'shell--unquote-argument)
(setq-local comint-requote-function #'shell--requote-argument)
- (set (make-local-variable 'pcomplete-parse-arguments-function)
- #'shell--parse-pcomplete-arguments)
- (set (make-local-variable 'pcomplete-termination-string)
- (cond ((not comint-completion-addsuffix) "")
- ((stringp comint-completion-addsuffix)
- comint-completion-addsuffix)
- ((not (consp comint-completion-addsuffix)) " ")
- (t (cdr comint-completion-addsuffix))))
- (set (make-local-variable 'pcomplete-command-completion-function)
- #'shell-command-completion-function)
+ (setq-local pcomplete-parse-arguments-function
+ #'shell--parse-pcomplete-arguments)
+ (setq-local pcomplete-termination-string
+ (cond ((not comint-completion-addsuffix) "")
+ ((stringp comint-completion-addsuffix)
+ comint-completion-addsuffix)
+ ((not (consp comint-completion-addsuffix)) " ")
+ (t (cdr comint-completion-addsuffix))))
+ (setq-local pcomplete-command-completion-function
+ #'shell-command-completion-function)
;; Don't use pcomplete's defaulting mechanism, rely on
;; shell-dynamic-complete-functions instead.
- (set (make-local-variable 'pcomplete-default-completion-function) #'ignore)
+ (setq-local pcomplete-default-completion-function #'ignore)
(setq-local comint-input-autoexpand shell-input-autoexpand)
;; Not needed in shell-mode because it's inherited from comint-mode, but
;; placed here for read-shell-command.
@@ -553,8 +570,7 @@ Variables `comint-output-filter-functions', a hook, and
`comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output'
control whether input and output cause the window to scroll to the end of the
buffer."
- (when (called-interactively-p 'any)
- (error "Can't be called interactively; did you mean `shell-script-mode' instead?"))
+ :interactive nil
(setq comint-prompt-regexp shell-prompt-pattern)
(shell-completion-vars)
(setq-local paragraph-separate "\\'")
@@ -591,17 +607,18 @@ buffer."
(and (stringp hsize)
(integerp (setq hsize (string-to-number hsize)))
(> hsize 0)
- (set (make-local-variable 'comint-input-ring-size) hsize))
+ (setq-local comint-input-ring-size hsize))
(setq comint-input-ring-file-name
(concat
remote
(or hfile
(cond ((string-equal shell "bash") "~/.bash_history")
((string-equal shell "ksh") "~/.sh_history")
+ ((string-equal shell "zsh") "~/.zsh_history")
(t "~/.history")))))
(if (or (equal comint-input-ring-file-name "")
(equal (file-truename comint-input-ring-file-name)
- (file-truename "/dev/null")))
+ (file-truename null-device)))
(setq comint-input-ring-file-name nil))
;; Arrange to write out the input ring on exit, if the shell doesn't
;; do this itself.
@@ -619,7 +636,12 @@ buffer."
;; Bypass a bug in certain versions of bash.
(when (string-equal shell "bash")
(add-hook 'comint-preoutput-filter-functions
- #'shell-filter-ctrl-a-ctrl-b nil t)))
+ #'shell-filter-ctrl-a-ctrl-b nil t))
+
+ ;; Skip extended history for zsh.
+ (when (string-equal shell "zsh")
+ (setq-local comint-input-ring-file-prefix
+ ": [[:digit:]]+:[[:digit:]]+;")))
(comint-read-input-ring t)))
(defun shell-apply-ansi-color (beg end face)
@@ -735,20 +757,20 @@ Make the shell buffer the current buffer, and return it.
(current-buffer)))
;; The buffer's window must be correctly set when we call comint
;; (so that comint sets the COLUMNS env var properly).
- (pop-to-buffer buffer)
+ (pop-to-buffer-same-window buffer)
(with-connection-local-variables
;; On remote hosts, the local `shell-file-name' might be useless.
- (when (file-remote-p default-directory)
- (if (and (called-interactively-p 'any)
+ (when (and (file-remote-p default-directory)
+ (called-interactively-p 'any)
(null explicit-shell-file-name)
(null (getenv "ESHELL")))
- (set (make-local-variable 'explicit-shell-file-name)
- (file-local-name
- (expand-file-name
- (read-file-name
- "Remote shell path: " default-directory shell-file-name
- t shell-file-name))))))
+ (setq-local explicit-shell-file-name
+ (file-local-name
+ (expand-file-name
+ (read-file-name "Remote shell path: " default-directory
+ shell-file-name t shell-file-name
+ #'file-remote-p)))))
;; Rain or shine, BUFFER must be current by now.
(unless (comint-check-proc buffer)
@@ -775,8 +797,7 @@ Make the shell buffer the current buffer, and return it.
;; that tracks cd, pushd, and popd commands issued to the shell, and
;; changes the current directory of the shell buffer accordingly.
;;
-;; This is basically a fragile hack, although it's more accurate than
-;; the version in Emacs 18's shell.el. It has the following failings:
+;; This is basically a fragile hack. It has the following failings:
;; 1. It doesn't know about the cdpath shell variable.
;; 2. It cannot infallibly deal with command sequences, though it does well
;; with these and with ignoring commands forked in another shell with ()s.
@@ -835,13 +856,15 @@ Environment variables are expanded, see function `substitute-in-file-name'."
str) ; skip whitespace
(match-end 0)))
(case-fold-search)
- end cmd arg1)
+ end cmd arg1 cmd-subst-fn)
(while (string-match shell-command-regexp str start)
(setq end (match-end 0)
cmd (comint-arguments (substring str start end) 0 0)
arg1 (comint-arguments (substring str start end) 1 1))
(if arg1
(setq arg1 (shell-unquote-argument arg1)))
+ (if shell-has-auto-cd
+ (setq cmd-subst-fn (comint-substitute-in-file-name cmd)))
(cond ((string-match (concat "\\`\\(" shell-popd-regexp
"\\)\\($\\|[ \t]\\)")
cmd)
@@ -858,7 +881,9 @@ Environment variables are expanded, see function `substitute-in-file-name'."
(string-match (concat "\\`\\(" shell-chdrive-regexp
"\\)\\($\\|[ \t]\\)")
cmd))
- (shell-process-cd (comint-substitute-in-file-name cmd))))
+ (shell-process-cd (comint-substitute-in-file-name cmd)))
+ ((and shell-has-auto-cd (file-directory-p cmd-subst-fn))
+ (shell-process-cd cmd-subst-fn)))
(setq start (progn (string-match shell-command-separator-regexp
str end)
;; skip again
@@ -979,15 +1004,12 @@ Environment variables are expanded, see function `substitute-in-file-name'."
The `dirtrack' package provides an alternative implementation of
this feature; see the function `dirtrack-mode'."
- nil nil nil
+ :lighter nil
(setq list-buffers-directory (if shell-dirtrack-mode default-directory))
(if shell-dirtrack-mode
(add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t)
(remove-hook 'comint-input-filter-functions #'shell-directory-tracker t)))
-(define-obsolete-function-alias 'shell-dirtrack-toggle #'shell-dirtrack-mode
- "23.1")
-
(defun shell-cd (dir)
"Do normal `cd' to DIR, and set `list-buffers-directory'."
(cd dir)
@@ -1033,25 +1055,41 @@ command again."
(accept-process-output proc)
(goto-char pt)))
(goto-char pmark) (delete-char 1) ; remove the extra newline
- ;; That's the dirlist. grab it & parse it.
- (let* ((dl (buffer-substring (match-beginning 2) (1- (match-end 2))))
- (dl-len (length dl))
- (ds '()) ; new dir stack
- (i 0))
- (while (< i dl-len)
- ;; regexp = optional whitespace, (non-whitespace), optional whitespace
- (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir
- (setq ds (cons (concat comint-file-name-prefix
- (substring dl (match-beginning 1)
- (match-end 1)))
- ds))
- (setq i (match-end 0)))
- (let ((ds (nreverse ds)))
- (with-demoted-errors "Couldn't cd: %s"
- (shell-cd (car ds))
- (setq shell-dirstack (cdr ds)
- shell-last-dir (car shell-dirstack))
- (shell-dirstack-message)))))
+ ;; That's the dirlist. Grab it & parse it.
+ (let* ((dls (buffer-substring-no-properties
+ (match-beginning 0) (1- (match-end 0))))
+ (dlsl nil)
+ (pos 0)
+ (ds nil))
+ ;; Split the dirlist into whitespace and non-whitespace chunks.
+ ;; dlsl will be a reversed list of tokens.
+ (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos)
+ (push (match-string 1 dls) dlsl)
+ (setq pos (match-end 1)))
+
+ ;; Prepend trailing entries until they form an existing directory,
+ ;; whitespace and all. Discard the next whitespace and repeat.
+ (while dlsl
+ (let ((newelt "")
+ tem1 tem2)
+ (while newelt
+ ;; We need tem1 because we don't want to prepend
+ ;; `comint-file-name-prefix' repeatedly into newelt via tem2.
+ (setq tem1 (pop dlsl)
+ tem2 (concat comint-file-name-prefix tem1 newelt))
+ (cond ((file-directory-p tem2)
+ (push tem2 ds)
+ (when (string= " " (car dlsl))
+ (pop dlsl))
+ (setq newelt nil))
+ (t
+ (setq newelt (concat tem1 newelt)))))))
+
+ (with-demoted-errors "Couldn't cd: %s"
+ (shell-cd (car ds))
+ (setq shell-dirstack (cdr ds)
+ shell-last-dir (car shell-dirstack))
+ (shell-dirstack-message))))
(if started-at-pmark (goto-char (marker-position pmark)))))
;; For your typing convenience:
@@ -1187,7 +1225,7 @@ Returns t if successful."
(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 (lambda (x) (concat (regexp-quote x) "\\'"))
comint-completion-fignore "\\|")))
(dir "") (comps-in-dir ())
(file "") (abs-file-name "") (completions ()))
@@ -1345,6 +1383,48 @@ Returns t if successful."
(let ((f (shell-c-a-p-replace-by-expanded-directory)))
(if f (funcall f))))
+(defun shell--prompt-begin-position ()
+ ;; We need this convoluted function because `looking-at-p' does not work on
+ ;; multiline regexps _and_ `re-search-backward' skips the current line.
+ (save-excursion
+ (let ((old-point (point)))
+ (max
+ (save-excursion
+ ;; Right result if not on prompt.
+ (call-interactively #'comint-previous-prompt)
+ (re-search-backward comint-prompt-regexp)
+ (point))
+ (save-excursion
+ ;; Right result if on first char after prompt.
+ (re-search-backward comint-prompt-regexp)
+ (point))
+ (save-excursion
+ ;; Right result if on prompt.
+ (call-interactively #'comint-next-prompt)
+ (re-search-backward comint-prompt-regexp)
+ (if (<= (point) old-point)
+ (point)
+ (point-min)))))))
+
+(defun shell--prompt-end-position ()
+ (save-excursion
+ (goto-char (shell--prompt-begin-position))
+ (comint-next-prompt 1)
+ (point)))
+
+(defun shell-narrow-to-prompt ()
+ "Narrow buffer to the command line (and any following command output) at point."
+ (interactive)
+ (let ((begin (shell--prompt-begin-position)))
+ (narrow-to-region
+ begin
+ (save-excursion
+ (goto-char (shell--prompt-end-position))
+ (call-interactively #'comint-next-prompt)
+ (if (= begin (shell--prompt-begin-position))
+ (point-max)
+ (shell--prompt-begin-position))))))
+
(provide 'shell)
;;; shell.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index 28738a262d3..5ec7fd80eb5 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -118,6 +118,30 @@ If non-nil, the value is passed directly to `recenter'."
:group 'next-error
:version "23.1")
+(defcustom next-error-message-highlight nil
+ "If non-nil, highlight the current error message in the `next-error' buffer.
+If the value is `keep', highlighting is permanent, so all visited error
+messages are highlighted; this helps to see what messages were visited."
+ :type '(choice (const :tag "Highlight the current error" t)
+ (const :tag "Highlight all visited errors" keep)
+ (const :tag "No highlighting" nil))
+ :group 'next-error
+ :version "28.1")
+
+(defface next-error-message
+ '((t (:inherit highlight :extend t)))
+ "Face used to highlight the current error message in the `next-error' buffer."
+ :group 'next-error
+ :version "28.1")
+
+(defvar-local next-error--message-highlight-overlay
+ nil
+ "Overlay highlighting the current error message in the `next-error' buffer.")
+
+(defvar global-minor-modes nil
+ "A list of the currently enabled global minor modes.
+This is a list of symbols.")
+
(defcustom next-error-hook nil
"List of hook functions run by `next-error' after visiting source file."
:type 'hook
@@ -144,15 +168,14 @@ A buffer becomes most recent when its compilation, grep, or
similar mode is started, or when it is used with \\[next-error]
or \\[compile-goto-error].")
-(defvar next-error-buffer nil
+(defvar-local next-error-buffer nil
"The buffer-local value of the most recent `next-error' buffer.")
;; next-error-buffer is made buffer-local to keep the reference
;; to the parent buffer used to navigate to the current buffer, so the
;; next call of next-buffer will use the same parent buffer to
;; continue navigation from it.
-(make-variable-buffer-local 'next-error-buffer)
-(defvar next-error-function nil
+(defvar-local next-error-function nil
"Function to use to find the next error in the current buffer.
The function is called with 2 parameters:
ARG is an integer specifying by how many errors to move.
@@ -161,15 +184,13 @@ of the errors before moving.
Major modes providing compile-like functionality should set this variable
to indicate to `next-error' that this is a candidate buffer and how
to navigate in it.")
-(make-variable-buffer-local 'next-error-function)
-(defvar next-error-move-function nil
+(defvar-local next-error-move-function nil
"Function to use to move to an error locus.
It takes two arguments, a buffer position in the error buffer
and a buffer position in the error locus buffer.
The buffer for the error locus should already be current.
-nil means use goto-char using the second argument position.")
-(make-variable-buffer-local 'next-error-move-function)
+nil means use `goto-char' using the second argument position.")
(defsubst next-error-buffer-p (buffer
&optional avoid-current
@@ -199,7 +220,7 @@ rejected, and the function returns nil."
(and extra-test-inclusive
(funcall extra-test-inclusive))))))
-(defcustom next-error-find-buffer-function #'next-error-buffer-unnavigated-current
+(defcustom next-error-find-buffer-function #'ignore
"Function called to find a `next-error' capable buffer.
This functions takes the same three arguments as the function
`next-error-find-buffer', and should return the buffer to be
@@ -215,16 +236,7 @@ all other buffers."
next-error-buffer-unnavigated-current)
(function :tag "Other function"))
:group 'next-error
- :version "27.1")
-
-(defcustom next-error-found-function #'ignore
- "Function called when a next locus is found and displayed.
-Function is called with two arguments: a FROM-BUFFER buffer
-from which next-error navigated, and a target buffer TO-BUFFER."
- :type '(choice (const :tag "No default" ignore)
- (function :tag "Other function"))
- :group 'next-error
- :version "27.1")
+ :version "28.1")
(defun next-error-buffer-on-selected-frame (&optional _avoid-current
extra-test-inclusive
@@ -365,9 +377,29 @@ To control which errors are matched, customize the variable
(not (eq prev next-error-last-buffer)))
(message "Current locus from %s" next-error-last-buffer)))))
+(defun next-error-quit-window (from-buffer to-buffer)
+ "Quit window of FROM-BUFFER when the prefix arg is 0.
+Intended to be used in `next-error-found-function'."
+ (when (and (eq current-prefix-arg 0) from-buffer
+ (not (eq from-buffer to-buffer)))
+ (let ((window (get-buffer-window from-buffer)))
+ (when (window-live-p window)
+ (quit-restore-window window)))))
+
+(defcustom next-error-found-function #'ignore
+ "Function called when a next locus is found and displayed.
+Function is called with two arguments: a FROM-BUFFER buffer
+from which `next-error' navigated, and a target buffer TO-BUFFER."
+ :type '(choice (const :tag "No default" ignore)
+ (const :tag "Quit previous window with M-0"
+ next-error-quit-window)
+ (function :tag "Other function"))
+ :group 'next-error
+ :version "27.1")
+
(defun next-error-found (&optional from-buffer to-buffer)
"Function to call when the next locus is found and displayed.
-FROM-BUFFER is a buffer from which next-error navigated,
+FROM-BUFFER is a buffer from which `next-error' navigated,
and TO-BUFFER is a target buffer."
(setq next-error-last-buffer (or from-buffer (current-buffer)))
(when to-buffer
@@ -376,6 +408,7 @@ and TO-BUFFER is a target buffer."
(when next-error-recenter
(recenter next-error-recenter))
(funcall next-error-found-function from-buffer to-buffer)
+ (next-error-message-highlight from-buffer)
(run-hooks 'next-error-hook))
(defun next-error-select-buffer (buffer)
@@ -460,6 +493,30 @@ buffer causes automatic display of the corresponding source code location."
(next-error-no-select 0))
(error t))))
+(defun next-error-message-highlight (error-buffer)
+ "Highlight the current error message in the ‘next-error’ buffer."
+ (when next-error-message-highlight
+ (with-current-buffer error-buffer
+ (when (and next-error--message-highlight-overlay
+ (not (eq next-error-message-highlight 'keep)))
+ (delete-overlay next-error--message-highlight-overlay))
+ (let ((ol (make-overlay (line-beginning-position) (1+ (line-end-position)))))
+ ;; do not override region highlighting
+ (overlay-put ol 'priority -50)
+ (overlay-put ol 'face 'next-error-message)
+ (overlay-put ol 'window (get-buffer-window))
+ (setf next-error--message-highlight-overlay ol)))))
+
+(defun recenter-current-error (&optional arg)
+ "Recenter the current displayed error in the `next-error' buffer."
+ (interactive "P")
+ (save-selected-window
+ (let ((next-error-highlight next-error-highlight-no-select)
+ (display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (next-error 0)
+ (set-buffer (window-buffer))
+ (recenter-top-bottom arg))))
;;;
@@ -503,7 +560,7 @@ It must be called via `run-hook-with-args-until-success' with no arguments.
If any function on this hook returns a non-nil value, `delete-selection-mode'
will act on that value (see `delete-selection-helper') and will
usually delete the region. If all the functions on this hook return
-nil, it is an indiction that `self-insert-command' needs the region
+nil, it is an indication that `self-insert-command' needs the region
untouched by `delete-selection-mode' and will itself do whatever is
appropriate with the region.
Any function on `post-self-insert-hook' that acts on the region should
@@ -516,7 +573,7 @@ This hook is run by `delete-selection-uses-region-p', which see.")
"Propertized string representing a hard newline character.")
(defun newline (&optional arg interactive)
- "Insert a newline, and move to left margin of the new line if it's blank.
+ "Insert a newline, and move to left margin of the new line.
With prefix argument ARG, insert that many newlines.
If `electric-indent-mode' is enabled, this indents the final new line
@@ -540,10 +597,12 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
;; Don't auto-fill if we have a prefix argument.
(auto-fill-function (if arg nil auto-fill-function))
(arg (prefix-numeric-value arg))
+ (procsym (make-symbol "newline-postproc")) ;(bug#46326)
(postproc
;; Do the rest in post-self-insert-hook, because we want to do it
;; *before* other functions on that hook.
(lambda ()
+ (remove-hook 'post-self-insert-hook procsym t)
;; Mark the newline(s) `hard'.
(if use-hard-newlines
(set-hard-newline-properties
@@ -553,7 +612,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
(save-excursion
(goto-char beforepos)
(beginning-of-line)
- (and (looking-at "[ \t]$")
+ (and (looking-at "[ \t]+$")
(> (current-left-margin) 0)
(delete-region (point)
(line-end-position))))
@@ -562,6 +621,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
;; starts a page.
(or was-page-start
(move-to-left-margin nil t)))))
+ (fset procsym postproc)
(if (not interactive)
;; FIXME: For non-interactive uses, many calls actually
;; just want (insert "\n"), so maybe we should do just
@@ -571,13 +631,13 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
(self-insert-command arg))
(unwind-protect
(progn
- (add-hook 'post-self-insert-hook postproc nil t)
+ (add-hook 'post-self-insert-hook procsym nil t)
(self-insert-command 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
;; protect only the buffer-local value.
- (remove-hook 'post-self-insert-hook postproc t))))
+ (remove-hook 'post-self-insert-hook procsym t))))
nil)
(defun set-hard-newline-properties (from to)
@@ -635,6 +695,30 @@ When called from Lisp code, ARG may be a prefix string to copy."
(indent-to col 0)
(goto-char pos)))
+(defface separator-line
+ '((((type graphic) (background dark))
+ :height 0.1 :background "#505050")
+ (((type graphic) (background light))
+ :height 0.1 :background "#a0a0a0")
+ (t :foreground "ForestGreen"))
+ "Face for separator lines."
+ :version "28.1"
+ :group 'text)
+
+(defun make-separator-line (&optional length)
+ "Make a string appropriate for usage as a visual separator line.
+This uses the `separator-line' face.
+
+If LENGTH is nil, use the window width."
+ (if (display-graphic-p)
+ (if length
+ (concat (propertize (make-string length ?\s) 'face 'separator-line)
+ "\n")
+ (propertize "\n" 'face '(:inherit separator-line :extend t)))
+ (concat (propertize (make-string (or length (1- (window-width))) ?-)
+ 'face 'separator-line)
+ "\n")))
+
(defun delete-indentation (&optional arg beg end)
"Join this line to previous and fix up whitespace at join.
If there is a fill prefix, delete it from the beginning of this
@@ -779,14 +863,18 @@ In programming language modes, this is the same as TAB.
In some text modes, where TAB inserts a tab, this command indents to the
column specified by the function `current-left-margin'.
-With ARG, perform this action that many times."
+With ARG, perform this action that many times.
+
+Also see `open-line' (bound to \\[open-line]) for a command that
+just inserts a newline without doing any indentation."
(interactive "*p")
(delete-horizontal-space t)
(unless arg
(setq arg 1))
- (dotimes (_ arg)
- (newline nil t)
- (indent-according-to-mode)))
+ (let ((electric-indent-mode nil))
+ (dotimes (_ arg)
+ (newline nil t)
+ (indent-according-to-mode))))
(defun reindent-then-newline-and-indent ()
"Reindent current line, insert newline, then indent the new line.
@@ -796,7 +884,8 @@ In programming language modes, this is the same as TAB.
In some text modes, where TAB inserts a tab, this indents to the
column specified by the function `current-left-margin'."
(interactive "*")
- (let ((pos (point)))
+ (let ((pos (point))
+ (electric-indent-mode nil))
;; Be careful to insert the newline before indenting the line.
;; Otherwise, the indentation might be wrong.
(newline)
@@ -1098,7 +1187,11 @@ is supplied, or Transient Mark mode is enabled and the mark is active."
;; If the end of the buffer is not already on the screen,
;; then scroll specially to put it near, but not at, the bottom.
(overlay-recenter (point))
- (recenter -3))))
+ ;; FIXME: Arguably if `scroll-conservatively' is set, then
+ ;; we should pass -1 to `recenter'.
+ (recenter (if (and scroll-minibuffer-conservatively
+ (window-minibuffer-p))
+ -1 -3)))))
(defcustom delete-active-region t
"Whether single-char deletion commands delete an active region.
@@ -1224,10 +1317,58 @@ that uses or sets the mark."
;; minibuffer, this is at the end of the prompt.
(goto-char (minibuffer-prompt-end)))
-
;; Counting lines, one way or another.
-(defun goto-line (line &optional buffer)
+(defcustom goto-line-history-local nil
+ "If this option is nil, `goto-line-history' is shared between all buffers.
+If it is non-nil, each buffer has its own value of this history list.
+
+Note that on changing from non-nil to nil, the former contents of
+`goto-line-history' for each buffer are discarded on use of
+`goto-line' in that buffer."
+ :group 'editing
+ :type 'boolean
+ :safe #'booleanp
+ :version "28.1")
+
+(defvar goto-line-history nil
+ "History of values entered with `goto-line'.")
+
+(defun goto-line-read-args (&optional relative)
+ "Read arguments for `goto-line' related commands."
+ (if (and current-prefix-arg (not (consp current-prefix-arg)))
+ (list (prefix-numeric-value current-prefix-arg))
+ ;; Look for a default, a number in the buffer at point.
+ (let* ((number (number-at-point))
+ (default (and (natnump number) number))
+ ;; Decide if we're switching buffers.
+ (buffer
+ (if (consp current-prefix-arg)
+ (other-buffer (current-buffer) t)))
+ (buffer-prompt
+ (if buffer
+ (concat " in " (buffer-name buffer))
+ "")))
+ ;; Has the buffer locality of `goto-line-history' changed?
+ (cond ((and goto-line-history-local (not (local-variable-p 'goto-line-history)))
+ (make-local-variable 'goto-line-history))
+ ((and (not goto-line-history-local) (local-variable-p 'goto-line-history))
+ (kill-local-variable 'goto-line-history)))
+ ;; Read the argument, offering that number (if any) as default.
+ (list (read-number (format "Goto%s line%s: "
+ (if (buffer-narrowed-p)
+ (if relative " relative" " absolute")
+ "")
+ buffer-prompt)
+ (list default (if (or relative (not (buffer-narrowed-p)))
+ (line-number-at-pos)
+ (save-restriction
+ (widen)
+ (line-number-at-pos))))
+ 'goto-line-history)
+ buffer))))
+
+(defun goto-line (line &optional buffer relative)
"Go to LINE, counting from line 1 at beginning of buffer.
If called interactively, a numeric prefix argument specifies
LINE; without a numeric prefix argument, read LINE from the
@@ -1237,6 +1378,13 @@ If optional argument BUFFER is non-nil, switch to that buffer and
move to line LINE there. If called interactively with \\[universal-argument]
as argument, BUFFER is the most recently selected other buffer.
+If optional argument RELATIVE is non-nil, counting starts at the beginning
+of the accessible portion of the (potentially narrowed) buffer.
+
+If the variable `widen-automatically' is non-nil, cancel narrowing and
+leave all lines accessible. If `widen-automatically' is nil, just move
+point to the edge of visible portion and don't change the buffer bounds.
+
Prior to moving point, this function sets the mark (without
activating it), unless Transient Mark mode is enabled and the
mark is already active.
@@ -1248,31 +1396,7 @@ What you probably want instead is something like:
If at all possible, an even better solution is to use char counts
rather than line counts."
(declare (interactive-only forward-line))
- (interactive
- (if (and current-prefix-arg (not (consp current-prefix-arg)))
- (list (prefix-numeric-value current-prefix-arg))
- ;; Look for a default, a number in the buffer at point.
- (let* ((default
- (save-excursion
- (skip-chars-backward "0-9")
- (if (looking-at "[0-9]")
- (string-to-number
- (buffer-substring-no-properties
- (point)
- (progn (skip-chars-forward "0-9")
- (point)))))))
- ;; Decide if we're switching buffers.
- (buffer
- (if (consp current-prefix-arg)
- (other-buffer (current-buffer) t)))
- (buffer-prompt
- (if buffer
- (concat " in " (buffer-name buffer))
- "")))
- ;; Read the argument, offering that number (if any) as default.
- (list (read-number (format "Goto line%s: " buffer-prompt)
- (list default (line-number-at-pos)))
- buffer))))
+ (interactive (goto-line-read-args))
;; Switch to the desired buffer, one way or another.
(if buffer
(let ((window (get-buffer-window buffer)))
@@ -1281,12 +1405,29 @@ rather than line counts."
;; Leave mark at previous position
(or (region-active-p) (push-mark))
;; Move to the specified line number in that buffer.
- (save-restriction
- (widen)
- (goto-char (point-min))
- (if (eq selective-display t)
- (re-search-forward "[\n\C-m]" nil 'end (1- line))
- (forward-line (1- line)))))
+ (let ((pos (save-restriction
+ (unless relative (widen))
+ (goto-char (point-min))
+ (if (eq selective-display t)
+ (re-search-forward "[\n\C-m]" nil 'end (1- line))
+ (forward-line (1- line)))
+ (point))))
+ (when (and (not relative)
+ (buffer-narrowed-p)
+ widen-automatically
+ ;; Position is outside narrowed part of buffer
+ (or (> (point-min) pos) (> pos (point-max))))
+ (widen))
+ (goto-char pos)))
+
+(defun goto-line-relative (line &optional buffer)
+ "Go to LINE, counting from line at (point-min).
+The line number is relative to the accessible portion of the narrowed
+buffer. The argument BUFFER is the same as in the function `goto-line'."
+ (declare (interactive-only forward-line))
+ (interactive (goto-line-read-args t))
+ (with-suppressed-warnings ((interactive-only goto-line))
+ (goto-line line buffer t)))
(defun count-words-region (start end &optional arg)
"Count the number of words in the region.
@@ -1318,7 +1459,9 @@ If called from Lisp, return the number of words between START and
END, without printing any message."
(interactive (list nil nil))
(cond ((not (called-interactively-p 'any))
- (let ((words 0))
+ (let ((words 0)
+ ;; Count across field boundaries. (Bug#41761)
+ (inhibit-field-text-motion t))
(save-excursion
(save-restriction
(narrow-to-region start end)
@@ -1361,48 +1504,52 @@ END, without printing any message."
(message "line %d (narrowed line %d)"
(+ n (line-number-at-pos start) -1) n))))))
-(defun count-lines (start end)
+(defun count-lines (start end &optional ignore-invisible-lines)
"Return number of lines between START and END.
-This is usually the number of newlines between them,
-but can be one more if START is not equal to END
-and the greater of them is not at the start of a line."
+This is usually the number of newlines between them, but can be
+one more if START is not equal to END and the greater of them is
+not at the start of a line.
+
+When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not
+included in the count."
(save-excursion
(save-restriction
(narrow-to-region start end)
- (goto-char (point-min))
- (if (eq selective-display t)
- (save-match-data
- (let ((done 0))
- (while (re-search-forward "[\n\C-m]" nil t 40)
- (setq done (+ 40 done)))
- (while (re-search-forward "[\n\C-m]" nil t 1)
- (setq done (+ 1 done)))
- (goto-char (point-max))
- (if (and (/= start end)
- (not (bolp)))
- (1+ done)
- done)))
- (- (buffer-size) (forward-line (buffer-size)))))))
-
-(defun line-number-at-pos (&optional pos absolute)
- "Return buffer line number at position POS.
-If POS is nil, use current buffer location.
-
-If ABSOLUTE is nil, the default, counting starts
-at (point-min), so the value refers to the contents of the
-accessible portion of the (potentially narrowed) buffer. If
-ABSOLUTE is non-nil, ignore any narrowing and return the
-absolute line number."
- (save-restriction
- (when absolute
- (widen))
- (let ((opoint (or pos (point))) start)
- (save-excursion
- (goto-char (point-min))
- (setq start (point))
- (goto-char opoint)
- (forward-line 0)
- (1+ (count-lines start (point)))))))
+ (cond ((and (not ignore-invisible-lines)
+ (eq selective-display t))
+ (goto-char (point-min))
+ (save-match-data
+ (let ((done 0))
+ (while (re-search-forward "\n\\|\r[^\n]" nil t 40)
+ (setq done (+ 40 done)))
+ (while (re-search-forward "\n\\|\r[^\n]" nil t 1)
+ (setq done (+ 1 done)))
+ (goto-char (point-max))
+ (if (and (/= start end)
+ (not (bolp)))
+ (1+ done)
+ done))))
+ (ignore-invisible-lines
+ (goto-char (point-min))
+ (save-match-data
+ (- (buffer-size)
+ (forward-line (buffer-size))
+ (let ((invisible-count 0)
+ prop)
+ (goto-char (point-min))
+ (while (re-search-forward "\n\\|\r[^\n]" nil t)
+ (setq prop (get-char-property (1- (point)) 'invisible))
+ (if (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq invisible-count (1+ invisible-count))))
+ invisible-count))))
+ (t
+ (goto-char (point-max))
+ (if (bolp)
+ (1- (line-number-at-pos))
+ (line-number-at-pos)))))))
(defcustom what-cursor-show-names nil
"Whether to show character names in `what-cursor-position'."
@@ -1474,7 +1621,11 @@ in *Help* buffer. See also the command `describe-char'."
encoded encoding-msg display-prop under-display)
(if (or (not coding)
(eq (coding-system-type coding) t))
- (setq coding (default-value 'buffer-file-coding-system)))
+ (setq coding (or (default-value 'buffer-file-coding-system)
+ ;; A nil value of `buffer-file-coding-system'
+ ;; means "no conversion" which means each byte
+ ;; is a char and vice versa.
+ 'binary)))
(if (eq (char-charset char) 'eight-bit)
(setq encoding-msg
(format "(%d, #o%o, #x%x%s, raw-byte)" char char char char-name-fmt))
@@ -1532,6 +1683,9 @@ in *Help* buffer. See also the command `describe-char'."
;; Might as well bind TAB to completion, since inserting a TAB char is
;; much too rarely useful.
(define-key m "\t" 'completion-at-point)
+ (define-key m "\r" 'read--expression-try-read)
+ (define-key m "\n" 'read--expression-try-read)
+ (define-key m "\M-g\M-c" 'read-expression-switch-to-completions)
(set-keymap-parent m minibuffer-local-map)
m))
@@ -1614,11 +1768,18 @@ display the result of expression evaluation."
"Hook run by `eval-expression' when entering the minibuffer.")
(defun read--expression (prompt &optional initial-contents)
+ "Read an Emacs Lisp expression from the minibuffer.
+
+PROMPT and optional argument INITIAL-CONTENTS do the same as in
+function `read-from-minibuffer'."
(let ((minibuffer-completing-symbol t))
(minibuffer-with-setup-hook
(lambda ()
- ;; FIXME: call emacs-lisp-mode (see also
- ;; `eldoc--eval-expression-setup')?
+ ;; FIXME: instead of just applying the syntax table, maybe
+ ;; use a special major mode tailored to reading Lisp
+ ;; expressions from the minibuffer? (`emacs-lisp-mode'
+ ;; doesn't preserve the necessary keybindings.)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
(add-hook 'completion-at-point-functions
#'elisp-completion-at-point nil t)
(run-hooks 'eval-expression-minibuffer-setup-hook))
@@ -1626,10 +1787,49 @@ display the result of expression evaluation."
read-expression-map t
'read-expression-history))))
+(defun read--expression-try-read ()
+ "Try to read an Emacs Lisp expression in the minibuffer.
+
+Exit the minibuffer if successful, else report the error to the
+user and move point to the location of the error. If point is
+not already at the location of the error, push a mark before
+moving point."
+ (interactive)
+ (unless (> (minibuffer-depth) 0)
+ (error "Minibuffer must be active"))
+ (if (let* ((contents (minibuffer-contents))
+ (error-point nil))
+ (with-temp-buffer
+ (condition-case err
+ (progn
+ (insert contents)
+ (goto-char (point-min))
+ ;; `read' will signal errors like "End of file during
+ ;; parsing" and "Invalid read syntax".
+ (read (current-buffer))
+ ;; Since `read' does not signal the "Trailing garbage
+ ;; following expression" error, we check for trailing
+ ;; garbage ourselves.
+ (or (progn
+ ;; This check is similar to what `string_to_object'
+ ;; does in minibuf.c.
+ (skip-chars-forward " \t\n")
+ (= (point) (point-max)))
+ (error "Trailing garbage following expression")))
+ (error
+ (setq error-point (+ (length (minibuffer-prompt)) (point)))
+ (with-current-buffer (window-buffer (minibuffer-window))
+ (unless (= (point) error-point)
+ (push-mark))
+ (goto-char error-point)
+ (minibuffer-message (error-message-string err)))
+ nil))))
+ (exit-minibuffer)))
+
(defun eval-expression-get-print-arguments (prefix-argument)
"Get arguments for commands that print an expression result.
-Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT)
-based on PREFIX-ARG. This function determines the interpretation
+Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT) based
+on PREFIX-ARGUMENT. This function determines the interpretation
of the prefix argument for `eval-expression' and
`eval-last-sexp'."
(let ((num (prefix-numeric-value prefix-argument)))
@@ -1672,31 +1872,34 @@ this command arranges for all errors to enter the debugger."
(cons (read--expression "Eval: ")
(eval-expression-get-print-arguments current-prefix-arg)))
- (if (null eval-expression-debug-on-error)
- (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)
- values)
- (let ((old-value (make-symbol "t")) new-value)
- ;; Bind debug-on-error to something unique so that we can
- ;; detect when evalled code changes it.
- (let ((debug-on-error old-value))
- (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)
- values)
- (setq new-value debug-on-error))
- ;; If evalled code has changed the value of debug-on-error,
- ;; propagate that change to the global binding.
- (unless (eq old-value new-value)
- (setq debug-on-error new-value))))
-
- (let ((print-length (unless no-truncate eval-expression-print-length))
- (print-level (unless no-truncate eval-expression-print-level))
- (eval-expression-print-maximum-character char-print-limit)
- (deactivate-mark))
- (let ((out (if insert-value (current-buffer) t)))
- (prog1
- (prin1 (car values) out)
- (let ((str (and char-print-limit
- (eval-expression-print-format (car values)))))
- (when str (princ str out)))))))
+ (let (result)
+ (if (null eval-expression-debug-on-error)
+ (setq result
+ (values--store-value
+ (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
+ (let ((old-value (make-symbol "t")) new-value)
+ ;; Bind debug-on-error to something unique so that we can
+ ;; detect when evalled code changes it.
+ (let ((debug-on-error old-value))
+ (setq result
+ (values--store-value
+ (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
+ (setq new-value debug-on-error))
+ ;; If evalled code has changed the value of debug-on-error,
+ ;; propagate that change to the global binding.
+ (unless (eq old-value new-value)
+ (setq debug-on-error new-value))))
+
+ (let ((print-length (unless no-truncate eval-expression-print-length))
+ (print-level (unless no-truncate eval-expression-print-level))
+ (eval-expression-print-maximum-character char-print-limit)
+ (deactivate-mark))
+ (let ((out (if insert-value (current-buffer) t)))
+ (prog1
+ (prin1 result out)
+ (let ((str (and char-print-limit
+ (eval-expression-print-format result))))
+ (when str (princ str out))))))))
(defun edit-and-eval-command (prompt command)
"Prompting with PROMPT, let user edit COMMAND and eval result.
@@ -1760,60 +1963,190 @@ to get different commands to edit and resubmit."
(defvar extended-command-history nil)
(defvar execute-extended-command--last-typed nil)
+(defcustom read-extended-command-predicate nil
+ "Predicate to use to determine which commands to include when completing.
+If it's nil, include all the commands.
+If it's a function, it will be called with two parameters: the
+symbol of the command and a buffer. The predicate should return
+non-nil if the command should be present when doing `M-x TAB'
+in that buffer."
+ :version "28.1"
+ :group 'completion
+ :type '(choice (const :tag "Don't exclude any commands" nil)
+ (const :tag "Exclude commands irrelevant to current buffer's mode"
+ command-completion-default-include-p)
+ (function :tag "Other function")))
+
(defun read-extended-command ()
- "Read command name to invoke in `execute-extended-command'."
- (minibuffer-with-setup-hook
- (lambda ()
- (add-hook 'post-self-insert-hook
- (lambda ()
- (setq execute-extended-command--last-typed
- (minibuffer-contents)))
- nil 'local)
- (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 ")
- (lambda (string pred action)
- (let ((pred
- (if (memq action '(nil t))
- ;; Exclude obsolete commands from completions.
- (lambda (sym)
- (and (funcall pred sym)
- (or (equal string (symbol-name sym))
- (not (get sym 'byte-obsolete-info)))))
- pred)))
- (complete-with-action action obarray string pred)))
- #'commandp t nil 'extended-command-history)))
+ "Read command name to invoke in `execute-extended-command'.
+This function uses the `read-extended-command-predicate' user option."
+ (let ((buffer (current-buffer)))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (add-hook 'post-self-insert-hook
+ (lambda ()
+ (setq execute-extended-command--last-typed
+ (minibuffer-contents)))
+ nil 'local)
+ (setq-local minibuffer-default-add-function
+ (lambda ()
+ ;; Get a command name at point in the original buffer
+ ;; to propose it after M-n.
+ (let ((def
+ (with-current-buffer
+ (window-buffer (minibuffer-selected-window))
+ (and (commandp (function-called-at-point))
+ (format
+ "%S" (function-called-at-point)))))
+ (all (sort (minibuffer-default-add-completions)
+ #'string<)))
+ (if def
+ (cons def (delete def all))
+ all)))))
+ ;; 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: ".
+ (if (memq 'shift (event-modifiers last-command-event))
+ "M-X "
+ "M-x "))
+ (lambda (string pred action)
+ (if (and suggest-key-bindings (eq action 'metadata))
+ '(metadata
+ (affixation-function . read-extended-command--affixation)
+ (category . command))
+ (let ((pred
+ (if (memq action '(nil t))
+ ;; Exclude from completions obsolete commands
+ ;; lacking a `current-name', or where `when' is
+ ;; not the current major version.
+ (lambda (sym)
+ (let ((obsolete (get sym 'byte-obsolete-info)))
+ (and (funcall pred sym)
+ (or (equal string (symbol-name sym))
+ (not obsolete)
+ (and
+ ;; Has a current-name.
+ (functionp (car obsolete))
+ ;; when >= emacs-major-version
+ (condition-case nil
+ (>= (car (version-to-list
+ (caddr obsolete)))
+ emacs-major-version)
+ ;; If the obsoletion version isn't
+ ;; valid, include the command.
+ (error t)))))))
+ pred)))
+ (complete-with-action action obarray string pred))))
+ (lambda (sym)
+ (and (commandp sym)
+ (cond ((null read-extended-command-predicate))
+ ((functionp read-extended-command-predicate)
+ ;; Don't let bugs break M-x completion; interpret
+ ;; them as the absence of a predicate.
+ (condition-case-unless-debug err
+ (funcall read-extended-command-predicate sym buffer)
+ (error (message "read-extended-command-predicate: %s: %s"
+ sym (error-message-string err))))))))
+ t nil 'extended-command-history))))
+
+(defun command-completion-using-modes-p (symbol buffer)
+ "Say whether SYMBOL has been marked as a mode-specific command in BUFFER."
+ ;; Check the modes.
+ (let ((modes (command-modes symbol)))
+ ;; Common case: Just a single mode.
+ (if (null (cdr modes))
+ (or (provided-mode-derived-p
+ (buffer-local-value 'major-mode buffer) (car modes))
+ (memq (car modes)
+ (buffer-local-value 'local-minor-modes buffer))
+ (memq (car modes) global-minor-modes))
+ ;; Uncommon case: Multiple modes.
+ (apply #'provided-mode-derived-p
+ (buffer-local-value 'major-mode buffer)
+ modes)
+ (seq-intersection modes
+ (buffer-local-value 'local-minor-modes buffer)
+ #'eq)
+ (seq-intersection modes global-minor-modes #'eq))))
+
+(defun command-completion-default-include-p (symbol buffer)
+ "Say whether SYMBOL should be offered as a completion.
+If there's a `completion-predicate' for SYMBOL, the result from
+calling that predicate is called. If there isn't one, this
+predicate is true if the command SYMBOL is applicable to the
+major mode in BUFFER, or any of the active minor modes in
+BUFFER."
+ (if (get symbol 'completion-predicate)
+ ;; An explicit completion predicate takes precedence.
+ (funcall (get symbol 'completion-predicate) symbol buffer)
+ (or (null (command-modes symbol))
+ (command-completion-using-modes-p symbol buffer))))
+
+(defun command-completion-with-modes-p (modes buffer)
+ "Say whether MODES are in action in BUFFER.
+This is the case if either the major mode is derived from one of MODES,
+or (if one of MODES is a minor mode), if it is switched on in BUFFER."
+ (or (apply #'provided-mode-derived-p
+ (buffer-local-value 'major-mode buffer)
+ modes)
+ ;; It's a minor mode.
+ (seq-intersection modes
+ (buffer-local-value 'local-minor-modes buffer)
+ #'eq)
+ (seq-intersection modes global-minor-modes #'eq)))
+
+(defun command-completion-button-p (category buffer)
+ "Return non-nil if there's a button of CATEGORY at point in BUFFER."
+ (with-current-buffer buffer
+ (and (get-text-property (point) 'button)
+ (eq (get-text-property (point) 'category) category))))
+
+(defun read-extended-command--affixation (command-names)
+ (with-selected-window (or (minibuffer-selected-window) (selected-window))
+ (mapcar
+ (lambda (command-name)
+ (let* ((fun (and (stringp command-name) (intern-soft command-name)))
+ (binding (where-is-internal fun overriding-local-map t))
+ (obsolete (get fun 'byte-obsolete-info))
+ (alias (symbol-function fun))
+ (suffix (cond ((symbolp alias)
+ (format " (%s)" alias))
+ (obsolete
+ (format " (%s)" (car obsolete)))
+ ((and binding (not (stringp binding)))
+ (format " (%s)" (key-description binding)))
+ (t ""))))
+ (put-text-property 0 (length suffix)
+ 'face 'completions-annotations suffix)
+ (list command-name "" suffix)))
+ command-names)))
(defcustom suggest-key-bindings t
"Non-nil means show the equivalent key-binding when M-x command has one.
The value can be a length of time to show the message for.
If the value is non-nil and not a number, we wait 2 seconds.
-Also see `extended-command-suggest-shorter'."
+Also see `extended-command-suggest-shorter'.
+
+Equivalent key-bindings are also shown in the completion list of
+M-x for all commands that have them."
:group 'keyboard
:type '(choice (const :tag "off" nil)
(integer :tag "time" 2)
@@ -1935,17 +2268,54 @@ invoking, give a prefix argument to `execute-extended-command'."
suggest-key-bindings
2))))))))
+(defun execute-extended-command-for-buffer (prefixarg &optional
+ command-name typed)
+ "Query user for a command relevant for the current mode, and then execute it.
+This is like `execute-extended-command', but it limits the
+completions to commands that are particularly relevant to the
+current buffer. This includes commands that have been marked as
+being specially designed for the current major mode (and enabled
+minor modes), as well as commands bound in the active local key
+maps."
+ (declare (interactive-only command-execute))
+ (interactive
+ (let* ((execute-extended-command--last-typed nil)
+ (keymaps
+ ;; The major mode's keymap and any active minor modes.
+ (cons
+ (current-local-map)
+ (mapcar
+ #'cdr
+ (seq-filter
+ (lambda (elem)
+ (symbol-value (car elem)))
+ minor-mode-map-alist))))
+ (read-extended-command-predicate
+ (lambda (symbol buffer)
+ (or (command-completion-using-modes-p symbol buffer)
+ (where-is-internal symbol keymaps)))))
+ (list current-prefix-arg
+ (read-extended-command)
+ execute-extended-command--last-typed)))
+ (with-suppressed-warnings ((interactive-only execute-extended-command))
+ (execute-extended-command prefixarg command-name typed)))
+
(defun command-execute (cmd &optional record-flag keys special)
;; BEWARE: Called directly from the C code.
"Execute CMD as an editor command.
CMD must be a symbol that satisfies the `commandp' predicate.
-Optional second arg RECORD-FLAG non-nil
-means unconditionally put this command in the variable `command-history'.
-Otherwise, that is done only if an arg is read using the minibuffer.
-The argument KEYS specifies the value to use instead of (this-command-keys)
-when reading the arguments; if it is nil, (this-command-keys) is used.
-The argument SPECIAL, if non-nil, means that this command is executing
-a special event, so ignore the prefix argument and don't clear it."
+
+Optional second arg RECORD-FLAG non-nil means unconditionally put
+this command in the variable `command-history'. Otherwise, that
+is done only if an arg is read using the minibuffer.
+
+The argument KEYS specifies the value to use instead of the
+return value of the `this-command-keys' function when reading the
+arguments; if it is nil, `this-command-keys' is used.
+
+The argument SPECIAL, if non-nil, means that this command is
+executing a special event, so ignore the prefix argument and
+don't clear it."
(setq debug-on-next-call nil)
(let ((prefixarg (unless special
;; FIXME: This should probably be done around
@@ -2020,7 +2390,8 @@ in this use of the minibuffer.")
"Minibuffer history variables for which matching should ignore case.
If a history variable is a member of this list, then the
\\[previous-matching-history-element] and \\[next-matching-history-element]\
- commands ignore case when searching it, regardless of `case-fold-search'."
+ commands ignore case when searching it,
+regardless of `case-fold-search'."
:type '(repeat variable)
:group 'minibuffer)
@@ -2036,11 +2407,9 @@ See also `minibuffer-history-case-insensitive-variables'."
(interactive
(let* ((enable-recursive-minibuffers t)
(regexp (read-from-minibuffer
- (format "Previous element matching regexp%s: "
- (if minibuffer-history-search-history
- (format " (default %s)"
- (car minibuffer-history-search-history))
- ""))
+ (format-prompt "Previous element matching regexp"
+ (and minibuffer-history-search-history
+ (car minibuffer-history-search-history)))
nil minibuffer-local-map nil
'minibuffer-history-search-history
(car minibuffer-history-search-history))))
@@ -2136,14 +2505,12 @@ once. In special cases, when this function needs to be called more
than once, it can set `minibuffer-default-add-done' to nil explicitly,
overriding the setting of this variable to t in `goto-history-element'.")
-(defvar minibuffer-default-add-done nil
+(defvar-local minibuffer-default-add-done nil
"When nil, add more elements to the end of the list of default values.
The value nil causes `goto-history-element' to add more elements to
the list of defaults when it reaches the end of this list. It does
this by calling a function defined by `minibuffer-default-add-function'.")
-(make-variable-buffer-local 'minibuffer-default-add-done)
-
(defun minibuffer-default-add-completions ()
"Return a list of all completions without the default value.
This function is used to add all elements of the completion table to
@@ -2199,10 +2566,10 @@ negative number -N means the Nth entry of \"future history.\""
(unless (memq last-command '(next-history-element
previous-history-element))
(let ((prompt-end (minibuffer-prompt-end)))
- (set (make-local-variable 'minibuffer-temporary-goal-position)
- (cond ((<= (point) prompt-end) prompt-end)
- ((eobp) nil)
- (t (point))))))
+ (setq-local minibuffer-temporary-goal-position
+ (cond ((<= (point) prompt-end) prompt-end)
+ ((eobp) nil)
+ (t (point))))))
(goto-char (point-max))
(delete-minibuffer-contents)
(setq minibuffer-history-position nabs)
@@ -2299,11 +2666,24 @@ previous element of the minibuffer history in the minibuffer."
(save-excursion
(goto-char (1- prompt-end))
(current-column)))
- 0)
+ 1)
(current-column)))))
(condition-case nil
(with-no-warnings
- (previous-line arg))
+ (previous-line arg)
+ ;; Avoid moving point to the prompt
+ (when (< (point) (minibuffer-prompt-end))
+ ;; If there is minibuffer contents on the same line
+ (if (<= (minibuffer-prompt-end)
+ (save-excursion
+ (if (or truncate-lines (not line-move-visual))
+ (end-of-line)
+ (end-of-visual-line))
+ (point)))
+ ;; Move to the beginning of minibuffer contents
+ (goto-char (minibuffer-prompt-end))
+ ;; Otherwise, go to the previous history element
+ (signal 'beginning-of-buffer nil))))
(beginning-of-buffer
;; Restore old position since `line-move-visual' moves point to
;; the beginning of the line when it fails to go to the previous line.
@@ -2323,15 +2703,17 @@ previous element of the minibuffer history in the minibuffer."
(goto-char (1- (minibuffer-prompt-end)))
(current-column))))
(move-to-column old-column))
- ;; Put the cursor at the end of the visual line instead of the
- ;; logical line, so the next `previous-line-or-history-element'
- ;; would move to the previous history element, not to a possible upper
- ;; visual line from the end of logical line in `line-move-visual' mode.
- (end-of-visual-line)
- ;; Since `end-of-visual-line' puts the cursor at the beginning
- ;; of the next visual line, move it one char back to the end
- ;; of the first visual line (bug#22544).
- (unless (eolp) (backward-char 1)))))))
+ (if (not line-move-visual) ; Handle logical lines (bug#42862)
+ (end-of-line)
+ ;; Put the cursor at the end of the visual line instead of the
+ ;; logical line, so the next `previous-line-or-history-element'
+ ;; would move to the previous history element, not to a possible upper
+ ;; visual line from the end of logical line in `line-move-visual' mode.
+ (end-of-visual-line)
+ ;; Since `end-of-visual-line' puts the cursor at the beginning
+ ;; of the next visual line, move it one char back to the end
+ ;; of the first visual line (bug#22544).
+ (unless (eolp) (backward-char 1))))))))
(defun next-complete-history-element (n)
"Get next history element that completes the minibuffer before the point.
@@ -2373,14 +2755,14 @@ Return 0 if current buffer is not a minibuffer."
(defun minibuffer-history-isearch-setup ()
"Set up a minibuffer for using isearch to search the minibuffer history.
Intended to be added to `minibuffer-setup-hook'."
- (set (make-local-variable 'isearch-search-fun-function)
- 'minibuffer-history-isearch-search)
- (set (make-local-variable 'isearch-message-function)
- 'minibuffer-history-isearch-message)
- (set (make-local-variable 'isearch-wrap-function)
- 'minibuffer-history-isearch-wrap)
- (set (make-local-variable 'isearch-push-state-function)
- 'minibuffer-history-isearch-push-state)
+ (setq-local isearch-search-fun-function
+ #'minibuffer-history-isearch-search)
+ (setq-local isearch-message-function
+ #'minibuffer-history-isearch-message)
+ (setq-local isearch-wrap-function
+ #'minibuffer-history-isearch-wrap)
+ (setq-local isearch-push-state-function
+ #'minibuffer-history-isearch-push-state)
(add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t))
(defun minibuffer-history-isearch-end ()
@@ -2470,7 +2852,6 @@ or to the last history element for a backward search."
(if isearch-forward
(goto-history-element (length (minibuffer-history-value)))
(goto-history-element 0))
- (setq isearch-success t)
(goto-char (if isearch-forward (minibuffer-prompt-end) (point-max))))
(defun minibuffer-history-isearch-push-state ()
@@ -2498,8 +2879,10 @@ Go to the history element by the absolute history position HIST-POS."
The same as `command-error-default-function' but display error messages
at the end of the minibuffer using `minibuffer-message' to not obscure
the minibuffer contents."
- (discard-input)
- (ding)
+ (if (memq 'minibuffer-quit (get (car data) 'error-conditions))
+ (ding t)
+ (discard-input)
+ (ding))
(let ((string (error-message-string data)))
;; If we know from where the error was signaled, show it in
;; *Messages*.
@@ -2515,8 +2898,35 @@ the minibuffer contents."
(defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
"Table mapping redo records to the corresponding undo one.
-A redo record for undo-in-region maps to t.
-A redo record for ordinary undo maps to the following (earlier) undo.")
+A redo record for an undo in region maps to 'undo-in-region.
+A redo record for ordinary undo maps to the following (earlier) undo.
+A redo record that undoes to the beginning of the undo list maps to t.
+In the rare case where there are (erroneously) consecutive nil's in
+`buffer-undo-list', `undo' maps the previous valid undo record to
+'empty, if the previous record is a redo record, `undo' doesn't change
+its mapping.
+
+To be clear, a redo record is just an undo record, the only difference
+is that it is created by an undo command (instead of an ordinary buffer
+edit). Since a record used to undo ordinary change is called undo
+record, a record used to undo an undo is called redo record.
+
+`undo' uses this table to make sure the previous command is `undo'.
+`undo-redo' uses this table to set the correct `pending-undo-list'.
+
+When you undo, `pending-undo-list' shrinks and `buffer-undo-list'
+grows, and Emacs maps the tip of `buffer-undo-list' to the tip of
+`pending-undo-list' in this table.
+
+For example, consider this undo list where each node represents an
+undo record: if we undo from 4, `pending-undo-list' will be at 3,
+`buffer-undo-list' at 5, and 5 will map to 3.
+
+ |
+ 3 5
+ | /
+ |/
+ 4")
(defvar undo-in-region nil
"Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
@@ -2528,6 +2938,11 @@ A redo record for ordinary undo maps to the following (earlier) undo.")
"Within a run of consecutive undo commands, list remaining to be undone.
If t, we undid all the way to the end of it.")
+(defun undo--last-change-was-undo-p (undo-list)
+ (while (and (consp undo-list) (eq (car undo-list) nil))
+ (setq undo-list (cdr undo-list)))
+ (gethash undo-list undo-equiv-table))
+
(defun undo (&optional arg)
"Undo some previous changes.
Repeat this command to undo more changes.
@@ -2558,17 +2973,14 @@ as an argument limits undo to changes within the current region."
;; the next command should not be a "consecutive undo".
;; So set `this-command' to something other than `undo'.
(setq this-command 'undo-start)
-
+ ;; Here we decide whether to break the undo chain. If the
+ ;; previous command is `undo', we don't call `undo-start', i.e.,
+ ;; don't break the undo chain.
(unless (and (eq last-command 'undo)
(or (eq pending-undo-list t)
;; If something (a timer or filter?) changed the buffer
;; since the previous command, don't continue the undo seq.
- (let ((list buffer-undo-list))
- (while (eq (car list) nil)
- (setq list (cdr list)))
- ;; If the last undo record made was made by undo
- ;; it shows nothing else happened in between.
- (gethash list undo-equiv-table))))
+ (undo--last-change-was-undo-p buffer-undo-list)))
(setq undo-in-region
(and (or (region-active-p) (and arg (not (numberp arg))))
(not inhibit-region)))
@@ -2592,7 +3004,7 @@ as an argument limits undo to changes within the current region."
;; undo-redo-undo-redo-... so skip to the very last equiv.
(while (let ((next (gethash equiv undo-equiv-table)))
(if next (setq equiv next))))
- (setq pending-undo-list equiv)))
+ (setq pending-undo-list (if (consp equiv) equiv t))))
(undo-more
(if (numberp arg)
(prefix-numeric-value arg)
@@ -2608,11 +3020,17 @@ as an argument limits undo to changes within the current region."
(while (eq (car list) nil)
(setq list (cdr list)))
(puthash list
- ;; Prevent identity mapping. This can happen if
- ;; consecutive nils are erroneously in undo list.
- (if (or undo-in-region (eq list pending-undo-list))
- t
- pending-undo-list)
+ (cond
+ (undo-in-region 'undo-in-region)
+ ;; Prevent identity mapping. This can happen if
+ ;; consecutive nils are erroneously in undo list. It
+ ;; has to map to _something_ so that the next `undo'
+ ;; command recognizes that the previous command is
+ ;; `undo' and doesn't break the undo chain.
+ ((eq list pending-undo-list)
+ (or (gethash list undo-equiv-table)
+ 'empty))
+ (t pending-undo-list))
undo-equiv-table))
;; Don't specify a position in the undo record for the undo command.
;; Instead, undoing this should move point to where the change is.
@@ -2658,6 +3076,26 @@ Contrary to `undo', this will not redo a previous undo."
(interactive "*p")
(let ((undo-no-redo t)) (undo arg)))
+(defun undo-redo (&optional arg)
+ "Undo the last ARG undos, i.e., redo the last ARG changes.
+Interactively, ARG is the prefix numeric argument and defaults to 1."
+ (interactive "*p")
+ (cond
+ ((not (undo--last-change-was-undo-p buffer-undo-list))
+ (user-error "No undone changes to redo"))
+ (t
+ (let* ((ul buffer-undo-list)
+ (new-ul
+ (let ((undo-in-progress t))
+ (while (and (consp ul) (eq (car ul) nil))
+ (setq ul (cdr ul)))
+ (primitive-undo arg ul)))
+ (new-pul (undo--last-change-was-undo-p new-ul)))
+ (message "Redo%s" (if undo-in-region " in region" ""))
+ (setq this-command 'undo)
+ (setq pending-undo-list new-pul)
+ (setq buffer-undo-list new-ul)))))
+
(defvar undo-in-progress nil
"Non-nil while performing an undo.
Some change-hooks test this variable to do something different.")
@@ -2714,8 +3152,7 @@ Return what remains of the list."
(and (consp time)
(equal (list (car time) (cdr time))
(visited-file-modtime))))
- (when (fboundp 'unlock-buffer)
- (unlock-buffer))
+ (unlock-buffer)
(set-buffer-modified-p nil)))
;; Element (nil PROP VAL BEG . END) is property change.
(`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
@@ -2906,7 +3343,7 @@ list can be applied to the current buffer."
undo-elt)
(while ulist
(when undo-no-redo
- (while (gethash ulist undo-equiv-table)
+ (while (consp (gethash ulist undo-equiv-table))
(setq ulist (gethash ulist undo-equiv-table))))
(setq undo-elt (car ulist))
(cond
@@ -2992,8 +3429,7 @@ is not *inside* the region START...END."
(> (cdr undo-elt) start)))))
(defun undo-adjust-elt (elt deltas)
- "Return adjustment of undo element ELT by the undo DELTAS
-list."
+ "Return adjustment of undo element ELT by the undo DELTAS list."
(pcase elt
;; POSITION
((pred integerp)
@@ -3037,8 +3473,7 @@ list."
;; There was no strong reason to prefer one or the other, except that
;; the first is more consistent with prior undo in region behavior.
(defun undo-adjust-beg-end (beg end deltas)
- "Return cons of adjustments to BEG and END by the undo DELTAS
-list."
+ "Return cons of adjustments to BEG and END by the undo DELTAS list."
(let ((adj-beg (undo-adjust-pos beg deltas)))
;; Note: option 2 above would be like (cons (min ...) adj-end)
(cons adj-beg
@@ -3272,13 +3707,12 @@ excessively long before answering the question."
:group 'undo
:version "22.1")
-(defvar undo-extra-outer-limit nil
+(defvar-local undo-extra-outer-limit nil
"If non-nil, an extra level of size that's ok in an undo item.
We don't ask the user about truncating the undo list until the
current item gets bigger than this amount.
This variable matters only if `undo-ask-before-discard' is non-nil.")
-(make-variable-buffer-local 'undo-extra-outer-limit)
;; When the first undo batch in an undo list is longer than
;; undo-outer-limit, this function gets called to warn the user that
@@ -3329,6 +3763,14 @@ which is defined in the `warnings' library.\n")
(setq buffer-undo-list nil)
t))
+;;;; Shell commands
+
+(defconst shell-command-buffer-name "*Shell Command Output*"
+ "Name of the output buffer for shell commands.")
+
+(defconst shell-command-buffer-name-async "*Async Shell Command*"
+ "Name of the output buffer for asynchronous shell commands.")
+
(defvar shell-command-history nil
"History list for some commands that read shell commands.
@@ -3382,8 +3824,8 @@ to `shell-command-history'."
(minibuffer-with-setup-hook
(lambda ()
(shell-completion-vars)
- (set (make-local-variable 'minibuffer-default-add-function)
- 'minibuffer-default-add-shell-commands))
+ (setq-local minibuffer-default-add-function
+ #'minibuffer-default-add-shell-commands))
(apply #'read-from-minibuffer prompt initial-contents
minibuffer-local-shell-command-map
nil
@@ -3393,8 +3835,9 @@ to `shell-command-history'."
(defcustom async-shell-command-buffer 'confirm-new-buffer
"What to do when the output buffer is used by another shell command.
This option specifies how to resolve the conflict where a new command
-wants to direct its output to the buffer `*Async Shell Command*',
-but this buffer is already taken by another running shell command.
+wants to direct its output to the buffer whose name is stored
+in `shell-command-buffer-name-async', but that buffer is already
+taken by another running shell command.
The value `confirm-kill-process' is used to ask for confirmation before
killing the already running process and running a new process
@@ -3545,14 +3988,18 @@ whose `car' is BUFFER."
Like `shell-command', but adds `&' at the end of COMMAND
to execute it asynchronously.
-The output appears in the buffer `*Async Shell Command*'.
-That buffer is in shell mode.
+The output appears in the buffer whose name is stored in the
+variable `shell-command-buffer-name-async'. That buffer is in
+shell mode.
You can configure `async-shell-command-buffer' to specify what to do
-when the `*Async Shell Command*' buffer is already taken by another
-running shell command. To run COMMAND without displaying the output
-in a window you can configure `display-buffer-alist' to use the action
-`display-buffer-no-window' for the buffer `*Async Shell Command*'.
+when the buffer specified by `shell-command-buffer-name-async' is
+already taken by another running shell command.
+
+To run COMMAND without displaying the output in a window you can
+configure `display-buffer-alist' to use the action
+`display-buffer-no-window' for the buffer given by
+`shell-command-buffer-name-async'.
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
@@ -3578,6 +4025,7 @@ a shell (with its need to quote arguments)."
(shell-command command output-buffer error-buffer))
(declare-function comint-output-filter "comint" (process string))
+(declare-function comint-term-environment "comint" ())
(defun shell-command (command &optional output-buffer error-buffer)
"Execute string COMMAND in inferior shell; display output, if any.
@@ -3588,16 +4036,18 @@ If `shell-command-prompt-show-cwd' is non-nil, show the current
directory in the prompt.
If COMMAND ends in `&', execute it asynchronously.
-The output appears in the buffer `*Async Shell Command*'.
-That buffer is in shell mode. You can also use
-`async-shell-command' that automatically adds `&'.
+The output appears in the buffer whose name is specified
+by `shell-command-buffer-name-async'. That buffer is in shell
+mode. You can also use `async-shell-command' that automatically
+adds `&'.
Otherwise, COMMAND is executed synchronously. The output appears in
-the buffer `*Shell Command Output*'. If the output is short enough to
-display in the echo area (which is determined by the variables
-`resize-mini-windows' and `max-mini-window-height'), it is shown
-there, but it is nonetheless available in buffer `*Shell Command
-Output*' even though that buffer is not automatically displayed.
+the buffer named by `shell-command-buffer-name'. If the output is
+short enough to display in the echo area (which is determined by the
+variables `resize-mini-windows' and `max-mini-window-height'), it is
+shown there, but it is nonetheless available in buffer named by
+`shell-command-buffer-name' even though that buffer is not
+automatically displayed.
To specify a coding system for converting non-ASCII characters
in the shell command output, use \\[universal-coding-system-argument] \
@@ -3716,7 +4166,7 @@ impose the use of a shell (with its need to quote arguments)."
(if (string-match "[ \t]*&[ \t]*\\'" command)
;; Command ending with ampersand means asynchronous.
(let* ((buffer (get-buffer-create
- (or output-buffer "*Async Shell Command*")))
+ (or output-buffer shell-command-buffer-name-async)))
(bname (buffer-name buffer))
(proc (get-buffer-process buffer))
(directory default-directory))
@@ -3754,15 +4204,22 @@ impose the use of a shell (with its need to quote arguments)."
(with-current-buffer buffer
(shell-command-save-pos-or-erase)
(setq default-directory directory)
- (let ((process-environment
- (if (natnump async-shell-command-width)
- (cons (format "COLUMNS=%d" async-shell-command-width)
- process-environment)
- process-environment)))
+ (require 'shell)
+ (let ((process-environment
+ (append
+ (and (natnump async-shell-command-width)
+ (list
+ (format "COLUMNS=%d"
+ async-shell-command-width)))
+ (comint-term-environment)
+ process-environment)))
(setq proc
(start-process-shell-command "Shell" buffer command)))
(setq mode-line-process '(":%s"))
- (require 'shell) (shell-mode)
+ (shell-mode)
+ (setq-local revert-buffer-function
+ (lambda (&rest _)
+ (async-shell-command command buffer)))
(set-process-sentinel proc #'shell-command-sentinel)
;; Use the comint filter for proper handling of
;; carriage motion (see comint-inhibit-carriage-motion).
@@ -3786,12 +4243,22 @@ impose the use of a shell (with its need to quote arguments)."
(shell-command-on-region (point) (point) command
output-buffer nil error-buffer)))))))
+(defun max-mini-window-lines (&optional frame)
+ "Compute maximum number of lines for echo area in FRAME.
+As defined by `max-mini-window-height'. FRAME defaults to the
+selected frame. Result may be a floating-point number,
+i.e. include a fractional number of lines."
+ (cond ((floatp max-mini-window-height) (* (frame-height frame)
+ max-mini-window-height))
+ ((integerp max-mini-window-height) max-mini-window-height)
+ (t 1)))
+
(defun display-message-or-buffer (message &optional buffer-name action frame)
"Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
MESSAGE may be either a string or a buffer.
A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long
-for maximum height of the echo area, as defined by `max-mini-window-height'
+for maximum height of the echo area, as defined by `max-mini-window-lines'
if `resize-mini-windows' is non-nil.
Returns either the string shown in the echo area, or when a pop-up
@@ -3830,14 +4297,7 @@ and are used only if a pop-up buffer is displayed."
(cond ((= lines 0))
((and (or (<= lines 1)
(<= lines
- (if resize-mini-windows
- (cond ((floatp max-mini-window-height)
- (* (frame-height)
- max-mini-window-height))
- ((integerp max-mini-window-height)
- max-mini-window-height)
- (t
- 1))
+ (if resize-mini-windows (max-mini-window-lines)
1)))
;; Don't use the echo area if the output buffer is
;; already displayed in the selected frame.
@@ -3868,9 +4328,9 @@ and are used only if a pop-up buffer is displayed."
error-buffer display-error-buffer
region-noncontiguous-p)
"Execute string COMMAND in inferior shell with region as input.
-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.
+Normally display output (if any) in temp buffer specified
+by `shell-command-buffer-name'; 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]
@@ -3887,7 +4347,7 @@ 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*'.
+Otherwise it is displayed in the buffer named by `shell-command-buffer-name'.
The output is available in that buffer in both cases.
If there is output and an error, a message about the error
@@ -3897,13 +4357,13 @@ Optional fourth arg OUTPUT-BUFFER specifies where to put the
command's output. If the value is a buffer or buffer name,
erase that buffer and insert the output there; a non-nil value of
`shell-command-dont-erase-buffer' prevent to erase the buffer.
-If the value is nil, use the buffer `*Shell Command Output*'.
+If the value is nil, use the buffer specified by `shell-command-buffer-name'.
Any other non-nil value means to insert the output in the
current buffer after START.
Optional fifth arg REPLACE, if non-nil, means to insert the
output in place of text from START to END, putting point and mark
-around it.
+around it. If REPLACE is the symbol `no-mark', don't set the mark.
Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer
or buffer name to which to direct the command's standard error
@@ -3945,7 +4405,7 @@ characters."
exit-status)
;; Unless a single contiguous chunk is selected, operate on multiple chunks.
(if region-noncontiguous-p
- (let ((input (concat (funcall region-extract-function 'delete) "\n"))
+ (let ((input (concat (funcall region-extract-function (when replace 'delete)) "\n"))
output)
(with-temp-buffer
(insert input)
@@ -3953,9 +4413,24 @@ characters."
shell-file-name t t
nil shell-command-switch
command)
- (setq output (split-string (buffer-string) "\n")))
- (goto-char start)
- (funcall region-insert-function output))
+ (setq output (split-string (buffer-substring
+ (point-min)
+ ;; Trim the trailing newline.
+ (if (eq (char-before (point-max)) ?\n)
+ (1- (point-max))
+ (point-max)))
+ "\n")))
+ (cond
+ (replace
+ (goto-char start)
+ (funcall region-insert-function output))
+ (t
+ (let ((buffer (get-buffer-create
+ (or output-buffer shell-command-buffer-name))))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (funcall region-insert-function output))
+ (display-message-or-buffer buffer)))))
(if (or replace
(and output-buffer
(not (or (bufferp output-buffer) (stringp output-buffer)))))
@@ -3963,27 +4438,32 @@ characters."
(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))
+ (when (and replace
+ (not (eq replace 'no-mark)))
+ (push-mark (point) 'nomsg))
(setq exit-status
(call-shell-region start end command replace
(if error-file
(list t error-file)
t)))
;; It is rude to delete a buffer that the command is not using.
- ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
+ ;; (let ((shell-buffer (get-buffer shell-command-buffer-name)))
;; (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)))
+ (when (and replace swap
+ (not (eq replace 'no-mark)))
+ (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*"))))
+ (or output-buffer shell-command-buffer-name))))
(set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111)
(unwind-protect
(if (and (eq buffer (current-buffer))
(or (memq shell-command-dont-erase-buffer '(nil erase))
- (and (not (eq buffer (get-buffer "*Shell Command Output*")))
+ (and (not (eq buffer (get-buffer
+ shell-command-buffer-name)))
(not (region-active-p)))))
;; If the input is the same buffer as the output,
;; delete everything but the specified region,
@@ -4013,6 +4493,9 @@ characters."
buffer))))
;; Report the output.
(with-current-buffer buffer
+ (setq-local revert-buffer-function
+ (lambda (&rest _)
+ (shell-command command)))
(setq mode-line-process
(cond ((null exit-status)
" - Error")
@@ -4070,8 +4553,7 @@ characters."
(defun shell-command-to-string (command)
"Execute shell command COMMAND and return its output as a string."
(with-output-to-string
- (with-current-buffer
- standard-output
+ (with-current-buffer standard-output
(shell-command command t))))
(defun process-file (program &optional infile buffer display &rest args)
@@ -4118,6 +4600,20 @@ its behavior with respect to remote file attribute caching.
You should only ever change this variable with a let-binding;
never with `setq'.")
+(defcustom process-file-return-signal-string nil
+ "Whether to return a string describing the signal interrupting a process.
+When a process returns an exit code greater than 128, it is
+interpreted as a signal. `process-file' requires to return a
+string describing this signal.
+Since there are processes violating this rule, returning exit
+codes greater than 128 which are not bound to a signal,
+`process-file' returns the exit code as natural number also in
+this case. Setting this user option to non-nil forces
+`process-file' to interpret such exit codes as signals, and to
+return a corresponding string."
+ :version "28.1"
+ :type 'boolean)
+
(defun start-file-process (name buffer program &rest program-args)
"Start a program in a subprocess. Return the process object for it.
@@ -4215,7 +4711,7 @@ Also, delete any process that is exited or signaled."
((thread-name (process-thread p)))
(t "--")))
(cmd
- (if (memq type '(network serial))
+ (if (memq type '(network serial pipe))
(let ((contact (process-contact p t t)))
(if (eq type 'network)
(format "(%s %s)"
@@ -4287,7 +4783,7 @@ see other processes running on the system, use `list-system-processes'."
(setq prefix-command--last-echo
(let ((strs nil))
(run-hook-wrapped 'prefix-command-echo-keystrokes-functions
- (lambda (fun) (push (funcall fun) strs)))
+ (lambda (fun) (push (funcall fun) strs) nil))
(setq strs (delq nil strs))
(when strs (mapconcat #'identity strs " "))))))
@@ -4567,12 +5063,19 @@ ring directly.")
"The tail of the kill ring whose car is the last thing yanked.")
(defcustom save-interprogram-paste-before-kill nil
- "Save existing clipboard text into kill ring before replacing it.
-A non-nil value ensures that Emacs kill operations do not
-irrevocably overwrite existing clipboard text by saving it to the
-`kill-ring' prior to the kill. Such text can subsequently be
-retrieved via \\[yank] \\[yank-pop]."
- :type 'boolean
+ "Whether to save existing clipboard text into kill ring before replacing it.
+A non-nil value means the clipboard text is saved to the `kill-ring'
+prior to any kill command. Such text can subsequently be retrieved
+via \\[yank] \\[yank-pop]. This ensures that Emacs kill operations
+do not irrevocably overwrite existing clipboard text.
+
+The value of this variable can also be a number, in which case the
+clipboard data is only saved to the `kill-ring' if it's shorter
+(in characters) than that number. Any other non-nil value will save
+the clipboard data unconditionally."
+ :type '(choice (const nil)
+ number
+ (other :tag "Always" t))
:group 'killing
:version "23.2")
@@ -4583,6 +5086,16 @@ The comparison is done using `equal-including-properties'."
:group 'killing
:version "23.2")
+(defcustom kill-transform-function nil
+ "Function to call to transform a string before it's put on the kill ring.
+The function is called with one parameter (the string that's to
+be put on the kill ring). It should return a string or nil. If
+the latter, the string is not put on the kill ring."
+ :type '(choice (const :tag "No transform" nil)
+ function)
+ :group 'killing
+ :version "28.1")
+
(defun kill-new (string &optional replace)
"Make STRING the latest kill in the kill ring.
Set `kill-ring-yank-pointer' to point to it.
@@ -4598,33 +5111,41 @@ When the yank handler has a non-nil PARAM element, the original STRING
argument is not used by `insert-for-yank'. However, since Lisp code
may access and use elements from the kill ring directly, the STRING
argument should still be a \"useful\" string for such uses."
- (unless (and kill-do-not-save-duplicates
- ;; Due to text properties such as 'yank-handler that
- ;; can alter the contents to yank, comparison using
- ;; `equal' is unsafe.
- (equal-including-properties 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
- (dolist (s (if (listp interprogram-paste)
- ;; Use `reverse' to avoid modifying external data.
- (reverse interprogram-paste)
- (list interprogram-paste)))
- (unless (and kill-do-not-save-duplicates
- (equal-including-properties s (car kill-ring)))
- (push s kill-ring))))))
- (unless (and kill-do-not-save-duplicates
- (equal-including-properties string (car kill-ring)))
- (if (and replace kill-ring)
- (setcar kill-ring string)
- (let ((history-delete-duplicates nil))
- (add-to-history 'kill-ring string kill-ring-max t))))
- (setq kill-ring-yank-pointer kill-ring)
- (if interprogram-cut-function
- (funcall interprogram-cut-function string)))
+ ;; Allow the user to transform or ignore the string.
+ (when (or (not kill-transform-function)
+ (setq string (funcall kill-transform-function string)))
+ (unless (and kill-do-not-save-duplicates
+ ;; Due to text properties such as 'yank-handler that
+ ;; can alter the contents to yank, comparison using
+ ;; `equal' is unsafe.
+ (equal-including-properties 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
+ (setq interprogram-paste
+ (if (listp interprogram-paste)
+ ;; Use `reverse' to avoid modifying external data.
+ (reverse interprogram-paste)
+ (list interprogram-paste)))
+ (when (or (not (numberp save-interprogram-paste-before-kill))
+ (< (seq-reduce #'+ (mapcar #'length interprogram-paste) 0)
+ save-interprogram-paste-before-kill))
+ (dolist (s interprogram-paste)
+ (unless (and kill-do-not-save-duplicates
+ (equal-including-properties s (car kill-ring)))
+ (push s kill-ring)))))))
+ (unless (and kill-do-not-save-duplicates
+ (equal-including-properties string (car kill-ring)))
+ (if (and replace kill-ring)
+ (setcar kill-ring string)
+ (let ((history-delete-duplicates nil))
+ (add-to-history 'kill-ring string kill-ring-max t))))
+ (setq kill-ring-yank-pointer kill-ring)
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function string))))
;; It has been argued that this should work like `self-insert-command'
;; which merges insertions in `buffer-undo-list' in groups of 20
@@ -4806,8 +5327,7 @@ region instead.
This command's old key binding has been given to `kill-ring-save'."
;; Pass mark first, then point, because the order matters when
;; calling `kill-append'.
- (interactive (list (mark) (point)
- (prefix-numeric-value current-prefix-arg)))
+ (interactive (list (mark) (point) 'region))
(let ((str (if region
(funcall region-extract-function nil)
(filter-buffer-substring beg end))))
@@ -4839,19 +5359,27 @@ This command is similar to `copy-region-as-kill', except that it gives
visual feedback indicating the extent of the region being copied."
;; Pass mark first, then point, because the order matters when
;; calling `kill-append'.
- (interactive (list (mark) (point)
- (prefix-numeric-value current-prefix-arg)))
+ (interactive (list (mark) (point) 'region))
(copy-region-as-kill beg end region)
;; This use of called-interactively-p is correct because the code it
;; controls just gives the user visual feedback.
(if (called-interactively-p 'interactive)
(indicate-copied-region)))
+(defcustom copy-region-blink-delay 1
+ "Time in seconds to delay after showing the other end of the region.
+It's used by the command `kill-ring-save' and the function
+`indicate-copied-region' to blink the cursor between point and mark.
+The value 0 disables blinking."
+ :type 'number
+ :group 'killing
+ :version "28.1")
+
(defun indicate-copied-region (&optional message-len)
"Indicate that the region text has been copied interactively.
-If the mark is visible in the selected window, blink the cursor
-between point and mark if there is currently no active region
-highlighting.
+If the mark is visible in the selected window, blink the cursor between
+point and mark if there is currently no active region highlighting.
+The option `copy-region-blink-delay' can disable blinking.
If the mark lies outside the selected window, display an
informative message containing a sample of the copied text. The
@@ -4865,12 +5393,14 @@ of this sample text; it defaults to 40."
(if (pos-visible-in-window-p mark (selected-window))
;; Swap point-and-mark quickly so as to show the region that
;; was selected. Don't do it if the region is highlighted.
- (unless (and (region-active-p)
- (face-background 'region nil t))
+ (when (and (numberp copy-region-blink-delay)
+ (> copy-region-blink-delay 0)
+ (or (not (region-active-p))
+ (not (face-background 'region nil t))))
;; Swap point and mark.
(set-marker (mark-marker) (point) (current-buffer))
(goto-char mark)
- (sit-for blink-matching-delay)
+ (sit-for copy-region-blink-delay)
;; Swap back.
(set-marker (mark-marker) mark (current-buffer))
(goto-char point)
@@ -4881,11 +5411,14 @@ of this sample text; it defaults to 40."
(let ((len (min (abs (- mark point))
(or message-len 40))))
(if (< point mark)
- ;; Don't say "killed"; that is misleading.
- (message "Saved text until \"%s\""
- (buffer-substring-no-properties (- mark len) mark))
- (message "Saved text from \"%s\""
- (buffer-substring-no-properties mark (+ mark len))))))))
+ ;; Don't say "killed" or "saved"; that is misleading.
+ (message "Copied text until \"%s\""
+ ;; Don't show newlines literally
+ (query-replace-descr
+ (buffer-substring-no-properties (- mark len) mark)))
+ (message "Copied text from \"%s\""
+ (query-replace-descr
+ (buffer-substring-no-properties mark (+ mark len)))))))))
(defun append-next-kill (&optional interactive)
"Cause following command, if it kills, to add to previous kill.
@@ -5090,45 +5623,51 @@ Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.")
(defun yank-pop (&optional arg)
"Replace just-yanked stretch of killed text with a different stretch.
-This command is allowed only immediately after a `yank' or a
+The main use of this command is immediately after a `yank' or a
`yank-pop'. At such a time, the region contains a stretch of
-reinserted previously-killed text. `yank-pop' deletes that text
-and inserts in its place a different stretch of killed text by
-traversing the value of the `kill-ring' variable.
+reinserted (\"pasted\") previously-killed text. `yank-pop' deletes
+that text and inserts in its place a different stretch of killed text
+by traversing the value of the `kill-ring' variable and selecting
+another kill from there.
With no argument, the previous kill is inserted.
With argument N, insert the Nth previous kill.
-If N is negative, this is a more recent kill.
+If N is negative, it means to use a more recent kill.
+
+The sequence of kills wraps around, so if you keep invoking this command
+time after time, and pass the oldest kill, you get the newest one.
-The sequence of kills wraps around, so that after the oldest one
-comes the newest one.
+You can also invoke this command after a command other than `yank'
+or `yank-pop'. This is the same as invoking `yank-from-kill-ring',
+including the effect of the prefix argument; see there for the details.
This command honors the `yank-handled-properties' and
`yank-excluded-properties' variables, and the `yank-handler' text
property, in the way that `yank' does."
- (interactive "*p")
+ (interactive "p")
(if (not (eq last-command 'yank))
- (user-error "Previous command was not a yank"))
- (setq this-command 'yank)
- (unless arg (setq arg 1))
- (let ((inhibit-read-only t)
- (before (< (point) (mark t))))
- (if before
- (funcall (or yank-undo-function 'delete-region) (point) (mark t))
- (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
- (setq yank-undo-function nil)
- (set-marker (mark-marker) (point) (current-buffer))
- (insert-for-yank (current-kill arg))
- ;; Set the window start back where it was in the yank command,
- ;; if possible.
- (set-window-start (selected-window) yank-window-start t)
- (if before
- ;; 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))))))
- nil)
+ (yank-from-kill-ring (read-from-kill-ring "Yank from kill-ring: ")
+ current-prefix-arg)
+ (setq this-command 'yank)
+ (unless arg (setq arg 1))
+ (let ((inhibit-read-only t)
+ (before (< (point) (mark t))))
+ (if before
+ (funcall (or yank-undo-function 'delete-region) (point) (mark t))
+ (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
+ (setq yank-undo-function nil)
+ (set-marker (mark-marker) (point) (current-buffer))
+ (insert-for-yank (current-kill arg))
+ ;; Set the window start back where it was in the yank command,
+ ;; if possible.
+ (set-window-start (selected-window) yank-window-start t)
+ (if before
+ ;; 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))))))
+ nil))
(defun yank (&optional arg)
"Reinsert (\"paste\") the last stretch of killed text.
@@ -5195,6 +5734,112 @@ See also the command `yank-pop' (\\[yank-pop])."
With ARG, rotate that many kills forward (or backward, if negative)."
(interactive "p")
(current-kill arg))
+
+(defvar read-from-kill-ring-history)
+(defun read-from-kill-ring (prompt)
+ "Read a `kill-ring' entry using completion and minibuffer history.
+PROMPT is a string to prompt with."
+ ;; `current-kill' updates `kill-ring' with a possible interprogram-paste
+ (current-kill 0)
+ (let* ((history-add-new-input nil)
+ (history-pos (when yank-from-kill-ring-rotate
+ (- (length kill-ring)
+ (length kill-ring-yank-pointer))))
+ (ellipsis (if (char-displayable-p ?…) "…" "..."))
+ ;; Remove keymaps from text properties of copied string,
+ ;; because typing RET in the minibuffer might call
+ ;; an irrelevant command from the map of copied string.
+ (read-from-kill-ring-history
+ (mapcar (lambda (s)
+ (remove-list-of-text-properties
+ 0 (length s)
+ '(
+ keymap local-map action mouse-action
+ button category help-args)
+ s)
+ s)
+ kill-ring))
+ (completions
+ (mapcar (lambda (s)
+ (let* ((s (query-replace-descr s))
+ (b 0)
+ (limit (frame-text-cols)))
+ ;; Add ellipsis on leading whitespace
+ (when (string-match "\\`[[:space:]]+" s)
+ (setq b (match-end 0))
+ (add-text-properties 0 b `(display ,ellipsis) s))
+ ;; Add ellipsis at the end of a long string
+ (when (> (length s) (+ limit b))
+ (add-text-properties
+ (min (+ limit b) (length s)) (length s)
+ `(display ,ellipsis) s))
+ s))
+ read-from-kill-ring-history)))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ ;; Allow ‘SPC’ to be self-inserting
+ (use-local-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (current-local-map))
+ (define-key map " " nil)
+ (define-key map "?" nil)
+ map)))
+ (completing-read
+ prompt
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ ;; Keep sorted by recency
+ '(metadata (display-sort-function . identity))
+ (complete-with-action action completions string pred)))
+ nil nil nil
+ (if history-pos
+ (cons 'read-from-kill-ring-history
+ (if (zerop history-pos) history-pos (1+ history-pos)))
+ 'read-from-kill-ring-history)))))
+
+(defcustom yank-from-kill-ring-rotate t
+ "Whether using `yank-from-kill-ring' should rotate `kill-ring-yank-pointer'.
+If non-nil, the kill ring is rotated after selecting previously killed text."
+ :type 'boolean
+ :group 'killing
+ :version "28.1")
+
+(defun yank-from-kill-ring (string &optional arg)
+ "Select a stretch of previously killed text and insert (\"paste\") it.
+This command allows to choose one of the stretches of text killed
+or yanked by previous commands, which are recorded in `kill-ring',
+and reinsert the chosen kill at point.
+
+This command prompts for a previously-killed text in the minibuffer.
+Use the minibuffer history and search commands, or the minibuffer
+completion commands, to select a previously-killed text. In
+particular, typing \\<minibuffer-local-completion-map>\\[minibuffer-complete] at the prompt will pop up a buffer showing
+all the previously-killed stretches of text from which you can
+choose the one you want to reinsert.
+Once you select the text you want to reinsert, type \\<minibuffer-local-map>\\[exit-minibuffer] to actually
+insert it and exit the minibuffer.
+You can also edit the selected text in the minibuffer before
+inserting it.
+
+With \\[universal-argument] as argument, this command puts point at
+beginning of the inserted text and mark at the end, like `yank' does.
+
+When called from Lisp, insert STRING like `insert-for-yank' does."
+ (interactive (list (read-from-kill-ring "Yank from kill-ring: ")
+ current-prefix-arg))
+ (setq yank-window-start (window-start))
+ (push-mark)
+ (insert-for-yank string)
+ (when yank-from-kill-ring-rotate
+ (let ((pos (seq-position kill-ring string)))
+ (if pos
+ (setq kill-ring-yank-pointer (nthcdr pos kill-ring))
+ (kill-new string))))
+ (if (consp arg)
+ ;; Swap point and mark like in `yank' and `yank-pop'.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer))))))
+
;; Some kill commands.
@@ -5223,7 +5868,13 @@ Can be `untabify' -- turn a tab to many spaces, then delete one space;
(defun backward-delete-char-untabify (arg &optional killp)
"Delete characters backward, changing tabs into spaces.
The exact behavior depends on `backward-delete-char-untabify-method'.
+
Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
+
+If Transient Mark mode is enabled, the mark is active, and ARG is 1,
+delete the text in the region and deactivate the mark instead.
+To disable this, set option ‘delete-active-region’ to nil.
+
Interactively, ARG is the prefix arg (default 1)
and KILLP is t if a prefix arg was specified."
(interactive "*p\nP")
@@ -5271,7 +5922,9 @@ See also `zap-up-to-char'."
;; kill-line and its subroutines.
(defcustom kill-whole-line nil
- "If non-nil, `kill-line' with no arg at start of line kills the whole line."
+ "If non-nil, `kill-line' with no arg at start of line kills the whole line.
+This variable also affects `kill-visual-line' in the same way as
+it does `kill-line'."
:type 'boolean
:group 'killing)
@@ -5964,8 +6617,6 @@ Does not set point. Does nothing if mark ring is empty."
(pop mark-ring))
(deactivate-mark))
-(define-obsolete-function-alias
- 'exchange-dot-and-mark 'exchange-point-and-mark "23.3")
(defun exchange-point-and-mark (&optional arg)
"Put the mark where point is now, and point where the mark is now.
This command works even when the mark is not active,
@@ -6057,6 +6708,10 @@ or \"mark.*active\" at the prompt."
;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
:variable (default-value 'transient-mark-mode))
+(define-minor-mode indent-tabs-mode
+ "Toggle whether indentation can insert TAB characters."
+ :global t :group 'indent :variable indent-tabs-mode)
+
(defvar widen-automatically t
"Non-nil means it is ok for commands to call `widen' when they want to.
Some commands will do this in order to go to positions outside
@@ -6091,7 +6746,8 @@ for it.")
(<= position (point-max)))
(if widen-automatically
(widen)
- (error "Global mark position is outside accessible part of buffer")))
+ (error "Global mark position is outside accessible part of buffer %s"
+ (buffer-name buffer))))
(goto-char position)
(switch-to-buffer buffer)))
@@ -6386,11 +7042,13 @@ The value is a floating-point number."
(or (null rbot) (= rbot 0)))
nil)
;; If cursor is not in the bottom scroll margin, and the
- ;; current line is not too tall, move forward.
+ ;; current line is not too tall, or if there's a continuation
+ ;; line below this one, move forward.
((and (or (null this-height) (<= this-height winh))
vpos
(> vpos 0)
- (< py last-line))
+ (or (< py last-line)
+ (display--line-is-continued-p)))
nil)
;; When already vscrolled, we vscroll some more if we can,
;; or clear vscroll and move forward at end of tall image.
@@ -6863,9 +7521,8 @@ rests."
(setq done t)))))))
(defun move-beginning-of-line (arg)
- "Move point to beginning of current line as displayed.
-\(If there's an image in the line, this disregards newlines
-that are part of the text that the image rests on.)
+ "Move point to visible beginning of current logical line.
+This disregards any invisible newline characters.
When moving from position that has no `field' property, this
command doesn't enter text which has non-nil `field' property.
@@ -6877,7 +7534,9 @@ With argument ARG not nil or 1, move forward ARG - 1 lines first.
If point reaches the beginning or end of buffer, it stops there.
\(But if the buffer doesn't end in a newline, it stops at the
beginning of the last line.)
-To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+
+To ignore intangibility, bind `inhibit-point-motion-hooks' to t.
+For motion by visual lines, see `beginning-of-visual-line'."
(interactive "^p")
(or arg (setq arg 1))
@@ -6985,6 +7644,10 @@ If ARG is negative, kill visual lines backward.
If ARG is zero, kill the text before point on the current visual
line.
+If the variable `kill-whole-line' is non-nil, and this command is
+invoked at start of a line that ends in a newline, kill the newline
+as well.
+
If you want to append the killed line to the last killed text,
use \\[append-next-kill] before \\[kill-line].
@@ -6997,18 +7660,27 @@ even beep.)"
;; Like in `kill-line', it's better to move point to the other end
;; of the kill before killing.
(let ((opoint (point))
- (kill-whole-line (and kill-whole-line (bolp))))
+ (kill-whole-line (and kill-whole-line (bolp)))
+ (orig-vlnum (cdr (nth 6 (posn-at-point)))))
(if arg
(vertical-motion (prefix-numeric-value arg))
(end-of-visual-line 1)
(if (= (point) opoint)
(vertical-motion 1)
- ;; Skip any trailing whitespace at the end of the visual line.
- ;; We used to do this only if `show-trailing-whitespace' is
- ;; nil, but that's wrong; the correct thing would be to check
- ;; whether the trailing whitespace is highlighted. But, it's
- ;; OK to just do this unconditionally.
- (skip-chars-forward " \t")))
+ ;; The first condition below verifies we are still on the same
+ ;; screen line, i.e. that the line isn't continued, and that
+ ;; end-of-visual-line didn't overshoot due to complications
+ ;; like display or overlay strings, intangible text, etc.:
+ ;; otherwise, we don't want to kill a character that's
+ ;; unrelated to the place where the visual line wraps.
+ (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum)
+ ;; Make sure we delete the character where the line wraps
+ ;; under visual-line-mode, be it whitespace or a
+ ;; character whose category set allows to wrap at it.
+ (or (looking-at-p "[ \t]")
+ (and word-wrap-by-category
+ (aref (char-category-set (following-char)) ?\|)))
+ (forward-char))))
(kill-region opoint (if (and kill-whole-line (= (following-char) ?\n))
(1+ (point))
(point)))))
@@ -7090,17 +7762,18 @@ Mode' for details."
:lighter " Wrap"
(if visual-line-mode
(progn
- (set (make-local-variable 'visual-line--saved-state) nil)
- ;; Save the local values of some variables, to be restored if
- ;; visual-line-mode is turned off.
- (dolist (var '(line-move-visual truncate-lines
- truncate-partial-width-windows
- word-wrap fringe-indicator-alist))
- (if (local-variable-p var)
- (push (cons var (symbol-value var))
- visual-line--saved-state)))
- (set (make-local-variable 'line-move-visual) t)
- (set (make-local-variable 'truncate-partial-width-windows) nil)
+ (unless visual-line--saved-state
+ (setq-local visual-line--saved-state (list nil))
+ ;; Save the local values of some variables, to be restored if
+ ;; visual-line-mode is turned off.
+ (dolist (var '(line-move-visual truncate-lines
+ truncate-partial-width-windows
+ word-wrap fringe-indicator-alist))
+ (if (local-variable-p var)
+ (push (cons var (symbol-value var))
+ visual-line--saved-state))))
+ (setq-local line-move-visual t)
+ (setq-local truncate-partial-width-windows nil)
(setq truncate-lines nil
word-wrap t
fringe-indicator-alist
@@ -7112,7 +7785,8 @@ Mode' for details."
(kill-local-variable 'truncate-partial-width-windows)
(kill-local-variable 'fringe-indicator-alist)
(dolist (saved visual-line--saved-state)
- (set (make-local-variable (car saved)) (cdr saved)))
+ (when (car saved)
+ (set (make-local-variable (car saved)) (cdr saved))))
(kill-local-variable 'visual-line--saved-state)))
(defun turn-on-visual-line-mode ()
@@ -7143,62 +7817,70 @@ are interchanged."
(interactive "*p")
(transpose-subr 'forward-word arg))
-(defun transpose-sexps (arg)
+(defun transpose-sexps (arg &optional interactive)
"Like \\[transpose-chars] (`transpose-chars'), but applies to sexps.
Unlike `transpose-words', point must be between the two sexps and not
in the middle of a sexp to be transposed.
With non-zero prefix arg ARG, effect is to take the sexp before point
and drag it forward past ARG other sexps (backward if ARG is negative).
If ARG is zero, the sexps ending at or after point and at or after mark
-are interchanged."
- (interactive "*p")
- (transpose-subr
- (lambda (arg)
- ;; Here we should try to simulate the behavior of
- ;; (cons (progn (forward-sexp x) (point))
- ;; (progn (forward-sexp (- x)) (point)))
- ;; Except that we don't want to rely on the second forward-sexp
- ;; putting us back to where we want to be, since forward-sexp-function
- ;; might do funny things like infix-precedence.
- (if (if (> arg 0)
- (looking-at "\\sw\\|\\s_")
- (and (not (bobp))
- (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
- ;; Jumping over a symbol. We might be inside it, mind you.
- (progn (funcall (if (> arg 0)
- 'skip-syntax-backward 'skip-syntax-forward)
- "w_")
- (cons (save-excursion (forward-sexp arg) (point)) (point)))
- ;; Otherwise, we're between sexps. Take a step back before jumping
- ;; to make sure we'll obey the same precedence no matter which direction
- ;; we're going.
- (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
- (cons (save-excursion (forward-sexp arg) (point))
- (progn (while (or (forward-comment (if (> arg 0) 1 -1))
- (not (zerop (funcall (if (> arg 0)
- 'skip-syntax-forward
- 'skip-syntax-backward)
- ".")))))
- (point)))))
- arg 'special))
+are interchanged.
+If INTERACTIVE is non-nil, as it is interactively,
+report errors as appropriate for this kind of usage."
+ (interactive "*p\nd")
+ (if interactive
+ (condition-case nil
+ (transpose-sexps arg nil)
+ (scan-error (user-error "Not between two complete sexps")))
+ (transpose-subr
+ (lambda (arg)
+ ;; Here we should try to simulate the behavior of
+ ;; (cons (progn (forward-sexp x) (point))
+ ;; (progn (forward-sexp (- x)) (point)))
+ ;; Except that we don't want to rely on the second forward-sexp
+ ;; putting us back to where we want to be, since forward-sexp-function
+ ;; might do funny things like infix-precedence.
+ (if (if (> arg 0)
+ (looking-at "\\sw\\|\\s_")
+ (and (not (bobp))
+ (save-excursion
+ (forward-char -1)
+ (looking-at "\\sw\\|\\s_"))))
+ ;; Jumping over a symbol. We might be inside it, mind you.
+ (progn (funcall (if (> arg 0)
+ 'skip-syntax-backward 'skip-syntax-forward)
+ "w_")
+ (cons (save-excursion (forward-sexp arg) (point)) (point)))
+ ;; Otherwise, we're between sexps. Take a step back before jumping
+ ;; to make sure we'll obey the same precedence no matter which
+ ;; direction we're going.
+ (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward)
+ " .")
+ (cons (save-excursion (forward-sexp arg) (point))
+ (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+ (not (zerop (funcall (if (> arg 0)
+ 'skip-syntax-forward
+ 'skip-syntax-backward)
+ ".")))))
+ (point)))))
+ arg 'special)))
(defun transpose-lines (arg)
"Exchange current line and previous line, leaving point after both.
With argument ARG, takes previous line and moves it past ARG lines.
With argument 0, interchanges line point is in with line mark is in."
(interactive "*p")
- (transpose-subr (function
- (lambda (arg)
- (if (> arg 0)
- (progn
- ;; Move forward over ARG lines,
- ;; but create newlines if necessary.
- (setq arg (forward-line arg))
- (if (/= (preceding-char) ?\n)
- (setq arg (1+ arg)))
- (if (> arg 0)
- (newline arg)))
- (forward-line arg))))
+ (transpose-subr (lambda (arg)
+ (if (> arg 0)
+ (progn
+ ;; Move forward over ARG lines,
+ ;; but create newlines if necessary.
+ (setq arg (forward-line arg))
+ (if (/= (preceding-char) ?\n)
+ (setq arg (1+ arg)))
+ (if (> arg 0)
+ (newline arg)))
+ (forward-line arg)))
arg))
;; FIXME seems to leave point BEFORE the current object when ARG = 0,
@@ -7657,11 +8339,17 @@ a specialization of overwrite mode, entered by setting the
Line numbers do not appear for very large buffers and buffers
with very long lines; see variables `line-number-display-limit'
-and `line-number-display-limit-width'."
+and `line-number-display-limit-width'.
+
+See `mode-line-position-line-format' for how this number is
+presented."
:init-value t :global t :group 'mode-line)
(define-minor-mode column-number-mode
- "Toggle column number display in the mode line (Column Number mode)."
+ "Toggle column number display in the mode line (Column Number mode).
+
+See `mode-line-position-column-format' for how this number is
+presented."
:global t :group 'mode-line)
(define-minor-mode size-indication-mode
@@ -7780,6 +8468,7 @@ The function should return non-nil if the two tokens do not match.")
(blinkpos
(save-excursion
(save-restriction
+ (syntax-propertize (point))
(if blink-matching-paren-distance
(narrow-to-region
(max (minibuffer-prompt-end) ;(point-min) unless minibuf.
@@ -7790,7 +8479,6 @@ The function should return non-nil if the two tokens do not match.")
(not blink-matching-paren-dont-ignore-comments))))
(condition-case ()
(progn
- (syntax-propertize (point))
(forward-sexp -1)
;; backward-sexp skips backward over prefix chars,
;; so move back to the matching paren.
@@ -8161,7 +8849,7 @@ makes it easier to edit it."
(interactive
(let* ((default-var (variable-at-point))
(var (if (custom-variable-p default-var)
- (read-variable (format "Set variable (default %s): " default-var)
+ (read-variable (format-prompt "Set variable" default-var)
default-var)
(read-variable "Set variable: ")))
(minibuffer-help-form `(describe-variable ',var))
@@ -8217,6 +8905,8 @@ makes it easier to edit it."
(defvar completion-list-mode-map
(let ((map (make-sparse-keymap)))
+ (set-keymap-parent map special-mode-map)
+ (define-key map "g" nil) ;; There's nothing to revert from.
(define-key map [mouse-2] 'choose-completion)
(define-key map [follow-link] 'mouse-face)
(define-key map [down-mouse-2] nil)
@@ -8226,8 +8916,10 @@ makes it easier to edit it."
(define-key map [right] 'next-completion)
(define-key map [?\t] 'next-completion)
(define-key map [backtab] 'previous-completion)
- (define-key map "q" 'quit-window)
(define-key map "z" 'kill-current-buffer)
+ (define-key map "n" 'next-completion)
+ (define-key map "p" 'previous-completion)
+ (define-key map "\M-g\M-c" 'switch-to-minibuffer)
map)
"Local map for completion list buffers.")
@@ -8256,18 +8948,6 @@ Called with three arguments (BEG END TEXT), it should replace the text
between BEG and END with TEXT. Expected to be set buffer-locally
in the *Completions* buffer.")
-(defvar completion-base-size nil
- "Number of chars before point not involved in completion.
-This is a local variable in the completion list buffer.
-It refers to the chars in the minibuffer if completing in the
-minibuffer, or in `completion-reference-buffer' otherwise.
-Only characters in the field at point are included.
-
-If nil, Emacs determines which part of the tail end of the
-buffer's text is involved in completion by comparing the text
-directly.")
-(make-obsolete-variable 'completion-base-size 'completion-base-position "23.2")
-
(defun delete-completion-window ()
"Delete the completion list window.
Go to the window from which completion was requested."
@@ -8321,24 +9001,22 @@ If EVENT, use EVENT's position to determine the starting position."
(run-hooks 'mouse-leave-buffer-hook)
(with-current-buffer (window-buffer (posn-window (event-start event)))
(let ((buffer completion-reference-buffer)
- (base-size completion-base-size)
(base-position completion-base-position)
(insert-function completion-list-insert-choice-function)
(choice
(save-excursion
(goto-char (posn-point (event-start event)))
- (let (beg end)
+ (let (beg)
(cond
((and (not (eobp)) (get-text-property (point) 'mouse-face))
- (setq end (point) beg (1+ (point))))
+ (setq beg (1+ (point))))
((and (not (bobp))
(get-text-property (1- (point)) 'mouse-face))
- (setq end (1- (point)) beg (point)))
+ (setq beg (point)))
(t (error "No completion here")))
(setq beg (previous-single-property-change beg 'mouse-face))
- (setq end (or (next-single-property-change end 'mouse-face)
- (point-max)))
- (buffer-substring-no-properties beg end)))))
+ (substring-no-properties
+ (get-text-property beg 'completion--string))))))
(unless (buffer-live-p buffer)
(error "Destination buffer is dead"))
@@ -8348,10 +9026,6 @@ If EVENT, use EVENT's position to determine the starting position."
(choose-completion-string
choice buffer
(or base-position
- (when base-size
- ;; Someone's using old completion code that doesn't know
- ;; about base-position yet.
- (list (+ base-size (field-beginning))))
;; If all else fails, just guess.
(list (choose-completion-guess-base-position choice)))
insert-function)))))
@@ -8379,10 +9053,6 @@ If EVENT, use EVENT's position to determine the starting position."
(forward-char 1))
(point))))
-(defun choose-completion-delete-max-match (string)
- (declare (obsolete choose-completion-guess-base-position "23.2"))
- (delete-region (choose-completion-guess-base-position string) (point)))
-
(defvar choose-completion-string-functions nil
"Functions that may override the normal insertion of a completion choice.
These functions are called in order with three arguments:
@@ -8411,13 +9081,6 @@ back on `completion-list-insert-choice-function' when nil."
;; unless it is reading a file name and CHOICE is a directory,
;; or completion-no-auto-exit is non-nil.
- ;; Some older code may call us passing `base-size' instead of
- ;; `base-position'. It's difficult to make any use of `base-size',
- ;; so we just ignore it.
- (unless (consp base-position)
- (message "Obsolete `base-size' passed to choose-completion-string")
- (setq base-position nil))
-
(let* ((buffer (or buffer completion-reference-buffer))
(mini-p (minibufferp buffer)))
;; If BUFFER is a minibuffer, barf unless it's the currently
@@ -8473,8 +9136,10 @@ Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
to select the completion near point.
Or click to select one with the mouse.
-\\{completion-list-mode-map}"
- (set (make-local-variable 'completion-base-size) nil))
+See the `completions-format' user option to control how this
+buffer is formatted.
+
+\\{completion-list-mode-map}")
(defun completion-list-mode-finish ()
"Finish setup of the completions buffer.
@@ -8511,19 +9176,17 @@ Called from `temp-buffer-show-hook'."
(if minibuffer-completing-file-name
(file-name-as-directory
(expand-file-name
- (buffer-substring (minibuffer-prompt-end)
- (- (point) (or completion-base-size 0))))))))
+ (buffer-substring (minibuffer-prompt-end) (point)))))))
(with-current-buffer standard-output
- (let ((base-size completion-base-size) ;Read before killing localvars.
- (base-position completion-base-position)
+ (let ((base-position completion-base-position)
(insert-fun completion-list-insert-choice-function))
(completion-list-mode)
- (set (make-local-variable 'completion-base-size) base-size)
- (set (make-local-variable 'completion-base-position) base-position)
- (set (make-local-variable 'completion-list-insert-choice-function)
- insert-fun))
- (set (make-local-variable 'completion-reference-buffer) mainbuf)
+ (setq-local completion-base-position base-position)
+ (setq-local completion-list-insert-choice-function insert-fun))
+ (setq-local completion-reference-buffer mainbuf)
(if base-dir (setq default-directory base-dir))
+ (when completion-tab-width
+ (setq tab-width completion-tab-width))
;; Maybe insert help string.
(when completion-show-help
(goto-char (point-min))
@@ -8548,6 +9211,18 @@ select the completion near point.\n\n"))))))
;; FIXME: Perhaps this should be done in `minibuffer-completion-help'.
(when (bobp)
(next-completion 1)))))
+
+(defun read-expression-switch-to-completions ()
+ "Select the completion list window while reading an expression."
+ (interactive)
+ (completion-help-at-point)
+ (switch-to-completions))
+
+(defun switch-to-minibuffer ()
+ "Select the minibuffer window."
+ (interactive)
+ (when (active-minibuffer-window)
+ (select-window (active-minibuffer-window))))
;;; Support keyboard commands to turn on various modifiers.
@@ -8860,9 +9535,9 @@ call `normal-erase-is-backspace-mode' (which see) instead."
:set (lambda (symbol value)
;; The fboundp is because of a problem with :set when
;; dumping Emacs. It doesn't really matter.
- (if (fboundp 'normal-erase-is-backspace-mode)
- (normal-erase-is-backspace-mode (or value 0))
- (set-default symbol value))))
+ (when (fboundp 'normal-erase-is-backspace-mode)
+ (normal-erase-is-backspace-mode (or value 0)))
+ (set-default symbol value)))
(defun normal-erase-is-backspace-setup-frame (&optional frame)
"Set up `normal-erase-is-backspace-mode' on FRAME, if necessary."
@@ -8980,8 +9655,7 @@ to a non-nil value."
(cond
((and (not buffer-read-only) view-mode)
(View-exit-and-edit)
- (make-local-variable 'view-read-only)
- (setq view-read-only t)) ; Must leave view mode.
+ (setq-local view-read-only t)) ; Must leave view mode.
((and buffer-read-only view-read-only
;; If view-mode is already active, `view-mode-enter' is a nop.
(not view-mode)
@@ -8999,8 +9673,8 @@ and setting it to nil."
(setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec)
(kill-local-variable 'vis-mode-saved-buffer-invisibility-spec))
(when visible-mode
- (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec)
- buffer-invisibility-spec)
+ (setq-local vis-mode-saved-buffer-invisibility-spec
+ buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
(defvar messages-buffer-mode-map
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index b942c54af61..c363fb2c489 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -1,4 +1,4 @@
-;;; skeleton.el --- Lisp language extension for writing statement skeletons
+;;; skeleton.el --- Lisp language extension for writing statement skeletons -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1996, 2001-2021 Free Software Foundation, Inc.
@@ -104,10 +104,10 @@ are integer buffer positions in the reverse order of the insertion order.")
(defvar skeleton-point)
(defvar skeleton-regions)
-(def-edebug-spec skeleton-edebug-spec
- ([&or null stringp (stringp &rest stringp) [[&not atom] sexp]]
- &rest &or "n" "_" "-" ">" "@" "&" "!" "|" "resume:"
- ("quote" def-form) skeleton-edebug-spec def-form))
+(def-edebug-elem-spec 'skeleton-edebug-spec
+ '([&or null stringp (stringp &rest stringp) [[&not atom] sexp]]
+ &rest &or "n" "_" "-" ">" "@" "&" "!" "|" "resume:"
+ ("quote" def-form) skeleton-edebug-spec def-form))
;;;###autoload
(defmacro define-skeleton (command documentation &rest skeleton)
"Define a user-configurable COMMAND that enters a statement skeleton.
@@ -135,7 +135,8 @@ A prefix argument of -1 says to wrap around region, even if not highlighted.
A prefix argument of zero says to wrap around zero words---that is, nothing.
This is a way of overriding the use of a highlighted region.")
(interactive "*P\nP")
- (skeleton-proxy-new ',skeleton str arg))))
+ (atomic-change-group
+ (skeleton-proxy-new ',skeleton str arg)))))
;;;###autoload
(defun skeleton-proxy-new (skeleton &optional str arg)
@@ -154,8 +155,7 @@ of `str' whereas the skeleton's interactor is then ignored."
(prefix-numeric-value (or arg
current-prefix-arg))
(and skeleton-autowrap
- (or (eq last-command 'mouse-drag-region)
- (and transient-mark-mode mark-active))
+ (use-region-p)
;; Deactivate the mark, in case one of the
;; elements of the skeleton is sensitive
;; to such situations (e.g. it is itself a
@@ -258,23 +258,25 @@ available:
(goto-char (car skeleton-regions))
(setq skeleton-regions (cdr skeleton-regions)))
(let ((beg (point))
- skeleton-modified skeleton-point resume: help input v1 v2)
- (setq skeleton-positions nil)
- (unwind-protect
- (cl-progv
- (mapcar #'car skeleton-further-elements)
- (mapcar (lambda (x) (eval (cadr x))) skeleton-further-elements)
- (skeleton-internal-list skeleton str))
- (or (eolp) (not skeleton-end-newline) (newline-and-indent))
- (run-hooks 'skeleton-end-hook)
- (sit-for 0)
- (or (not (eq (window-buffer) (current-buffer)))
- (pos-visible-in-window-p beg)
- (progn
- (goto-char beg)
- (recenter 0)))
- (if skeleton-point
- (goto-char skeleton-point))))))
+ skeleton-modified skeleton-point) ;; resume:
+ (with-suppressed-warnings ((lexical help input v1 v2))
+ (dlet (help input v1 v2)
+ (setq skeleton-positions nil)
+ (unwind-protect
+ (cl-progv
+ (mapcar #'car skeleton-further-elements)
+ (mapcar (lambda (x) (eval (cadr x) t)) skeleton-further-elements)
+ (skeleton-internal-list skeleton str))
+ (or (eolp) (not skeleton-end-newline) (newline-and-indent))
+ (run-hooks 'skeleton-end-hook)
+ (sit-for 0)
+ (or (not (eq (window-buffer) (current-buffer)))
+ (pos-visible-in-window-p beg)
+ (progn
+ (goto-char beg)
+ (recenter 0)))
+ (if skeleton-point
+ (goto-char skeleton-point))))))))
(defun skeleton-read (prompt &optional initial-input recursive)
"Function for reading a string from the minibuffer within skeletons.
@@ -288,7 +290,8 @@ i.e. we are handling the iterator of a subskeleton, returns empty string if
user didn't modify input.
While reading, the value of `minibuffer-help-form' is variable `help' if that
is non-nil or a default string."
- (let ((minibuffer-help-form (or (if (boundp 'help) (symbol-value 'help))
+ (with-suppressed-warnings ((lexical help)) (defvar help)) ;FIXME: Prefix!
+ (let ((minibuffer-help-form (or (bound-and-true-p help)
(if recursive "\
As long as you provide input you will insert another subskeleton.
@@ -310,10 +313,15 @@ automatically, and you are prompted to fill in the variable parts.")))
(save-excursion (insert "\n")))
(unwind-protect
(setq prompt (cond ((stringp prompt)
- (read-string (format prompt skeleton-subprompt)
- (setq initial-input
- (or initial-input
- (symbol-value 'input)))))
+ ;; The user may issue commands to move
+ ;; around (like `C-M-v'). Ensure that we
+ ;; insert the skeleton at the correct
+ ;; (initial) point.
+ (save-excursion
+ (read-string (format prompt skeleton-subprompt)
+ (setq initial-input
+ (or initial-input
+ (symbol-value 'input))))))
((functionp prompt)
(funcall prompt))
(t (eval prompt))))
@@ -327,36 +335,40 @@ automatically, and you are prompted to fill in the variable parts.")))
(signal 'quit t)
prompt))
-(defun skeleton-internal-list (skeleton-il &optional str recursive)
+(defun skeleton-internal-list (skeleton &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-il) nil ,recursive))))
- (when (and (eq (cadr skeleton-il) '\n) (not recursive)
- (save-excursion (skip-chars-backward " \t") (bolp)))
- (setq skeleton-il (cons nil (cons '> (cddr skeleton-il)))))
- (while (setq skeleton-modified (eq opoint (point))
- opoint (point)
- skeleton-il (cdr skeleton-il))
- (condition-case quit
- (skeleton-internal-1 (car skeleton-il) nil recursive)
- (quit
- (if (eq (cdr quit) 'recursive)
- (setq recursive 'quit
- 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)
- (delete-region start (point))
- (insert line)
- (move-to-column column)
- (if (cdr quit)
- (setq skeleton-il ()
- recursive nil)
- (signal 'quit 'recursive)))))))
+ (skeleton-il skeleton)
+ opoint)
+ (with-suppressed-warnings ((lexical str))
+ (dlet ((str (or str
+ `(setq str
+ (skeleton-read ',(car skeleton-il)
+ nil ,recursive))))
+ resume:)
+ (when (and (eq (cadr skeleton-il) '\n) (not recursive)
+ (save-excursion (skip-chars-backward " \t") (bolp)))
+ (setq skeleton-il (cons nil (cons '> (cddr skeleton-il)))))
+ (while (setq skeleton-modified (eq opoint (point))
+ opoint (point)
+ skeleton-il (cdr skeleton-il))
+ (condition-case quit
+ (skeleton-internal-1 (car skeleton-il) nil recursive)
+ (quit
+ (if (eq (cdr quit) 'recursive)
+ (setq recursive 'quit
+ 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)
+ (delete-region start (point))
+ (insert line)
+ (move-to-column column)
+ (if (cdr quit)
+ (setq skeleton-il ()
+ recursive nil)
+ (signal 'quit 'recursive)))))))))
;; maybe continue loop or go on to next outer resume: section
(if (eq recursive 'quit)
(signal 'quit 'recursive)
diff --git a/lisp/so-long.el b/lisp/so-long.el
index 281a4b04ae4..d765d3449ca 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -50,15 +50,14 @@
;; performance further, as well as making the so-long activity more obvious to
;; the user. These kinds of minified files are typically not intended to be
;; edited, so not providing the usual editing mode in such cases will rarely be
-;; an issue. However, should the user wish to do so, the original state of the
-;; buffer may be reinstated by calling `so-long-revert' (the key binding for
-;; which is advertised when the major mode change occurs). If you prefer that
-;; the major mode not be changed, the `so-long-minor-mode' action can be
-;; configured.
+;; an issue. However, you can reinstate the original state of the buffer by
+;; calling `so-long-revert' (the key binding of which is advertised when the major
+;; mode change occurs). If you prefer that the major mode not be changed, you
+;; can customize the `so-long-minor-mode' action.
;;
;; The user options `so-long-action' and `so-long-action-alist' determine what
-;; will happen when `so-long' and `so-long-revert' are invoked, allowing
-;; alternative actions (including custom actions) to be configured. As well as
+;; actions `so-long' and `so-long-revert' will take. This allows you to configure
+;; alternative actions (including custom actions). As well as
;; the major and minor mode actions provided by this library, `longlines-mode'
;; is also supported by default as an alternative action.
;;
@@ -389,7 +388,7 @@
;; this caveat is the `mode' pseudo-variable, which is processed early in all
;; versions of Emacs, and can be set to `so-long-mode' if desired.
-;;; * Change Log:
+;; * Change Log:
;;
;; 1.0 - Included in Emacs 27.1, and in GNU ELPA for prior versions of Emacs.
;; - New global mode `global-so-long-mode' to enable/disable the library.
@@ -833,7 +832,7 @@ available in Emacs versions < 27). For more information refer to info node
`(emacs) Bidirectional Editing' and info node `(elisp) Bidirectional Display'.
Buffers are made read-only by default to prevent potentially-slow editing from
-occurring inadvertantly, as buffers with excessively long lines are likely not
+occurring inadvertently, as buffers with excessively long lines are likely not
intended to be edited manually."
:type '(alist :key-type (variable :tag "Variable")
:value-type (sexp :tag "Value"))
@@ -1001,8 +1000,10 @@ This command calls `so-long' with the selected action as an argument.")
(cl-letf (((symbol-function 'finder-summary) #'ignore))
(finder-commentary "so-long"))
(let ((inhibit-read-only t))
- (when (looking-at "^Commentary:\n\n")
- (replace-match "so-long.el\n\n"))
+ (if (looking-at "^Commentary:\n\n")
+ (replace-match "so-long.el\n\n")
+ (insert "so-long.el\n")
+ (forward-line 1))
(save-excursion
(while (re-search-forward "^-+$" nil :noerror)
(replace-match ""))))
@@ -1184,7 +1185,7 @@ current buffer, and buffer-local values are assigned to variables in accordance
with `so-long-variable-overrides'.
This minor mode is a standard `so-long-action' option."
- nil nil nil
+ :lighter nil
(if so-long-minor-mode ;; We are enabling the mode.
(progn
;; Housekeeping. `so-long-minor-mode' might be invoked directly rather
@@ -1647,7 +1648,8 @@ invoking the new action."
(when so-long--active
(so-long-revert))
;; Invoke the new action.
- (let ((so-long--calling t))
+ (let ((so-long--calling t)
+ (view-mode-active view-mode))
(so-long--ensure-enabled)
;; ACTION takes precedence if supplied.
(when action
@@ -1676,7 +1678,10 @@ invoking the new action."
;; functions need to modify the buffer. We use `inhibit-read-only' to
;; side-step the issue (and likewise in `so-long-revert').
(let ((inhibit-read-only t))
- (run-hooks 'so-long-hook)))))
+ (run-hooks 'so-long-hook))
+ ;; Restore `view-mode'.
+ (when view-mode-active
+ (view-mode)))))
(defun so-long-revert ()
"Revert the active `so-long-action' and run `so-long-revert-hook'.
diff --git a/lisp/sort.el b/lisp/sort.el
index b3401c5684c..0d2fd416649 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -251,7 +251,7 @@ the sort order."
(narrow-to-region beg end)
(goto-char (point-min))
(sort-subr reverse
- (function (lambda () (skip-chars-forward "\n")))
+ (lambda () (skip-chars-forward "\n"))
'forward-page))))
(defvar sort-fields-syntax-table nil)
@@ -316,16 +316,16 @@ FIELD, BEG and END. BEG and END specify region to sort."
;;region to sort."
;; (interactive "p\nr")
;; (sort-fields-1 field beg end
-;; (function (lambda ()
-;; (sort-skip-fields field)
-;; (string-to-number
-;; (buffer-substring
-;; (point)
-;; (save-excursion
-;; (re-search-forward
-;; "[+-]?[0-9]*\\.?[0-9]*\\([eE][+-]?[0-9]+\\)?")
-;; (point))))))
-;; nil))
+;; (lambda ()
+;; (sort-skip-fields field)
+;; (string-to-number
+;; (buffer-substring
+;; (point)
+;; (save-excursion
+;; (re-search-forward
+;; "[+-]?[0-9]*\\.?[0-9]*\\([eE][+-]?[0-9]+\\)?")
+;; (point)))))
+;; nil))
;;;###autoload
(defun sort-fields (field beg end)
@@ -340,10 +340,10 @@ the sort order."
(let ;; To make `end-of-line' and etc. to ignore fields.
((inhibit-field-text-motion t))
(sort-fields-1 field beg end
- (function (lambda ()
- (sort-skip-fields field)
- nil))
- (function (lambda () (skip-chars-forward "^ \t\n"))))))
+ (lambda ()
+ (sort-skip-fields field)
+ nil)
+ (lambda () (skip-chars-forward "^ \t\n")))))
(defun sort-fields-1 (field beg end startkeyfun endkeyfun)
(let ((tbl (syntax-table)))
@@ -457,21 +457,21 @@ sRegexp specifying key within record: \nr")
(goto-char (match-beginning 0))
(sort-subr reverse
'sort-regexp-fields-next-record
- (function (lambda ()
- (goto-char sort-regexp-record-end)))
- (function (lambda ()
- (let ((n 0))
- (cond ((numberp key-regexp)
- (setq n key-regexp))
- ((re-search-forward
- key-regexp sort-regexp-record-end t)
- (setq n 0))
- (t (throw 'key nil)))
- (condition-case ()
- (cons (match-beginning n)
- (match-end n))
- ;; if there was no such register
- (error (throw 'key nil)))))))))))
+ (lambda ()
+ (goto-char sort-regexp-record-end))
+ (lambda ()
+ (let ((n 0))
+ (cond ((numberp key-regexp)
+ (setq n key-regexp))
+ ((re-search-forward
+ key-regexp sort-regexp-record-end t)
+ (setq n 0))
+ (t (throw 'key nil)))
+ (condition-case ()
+ (cons (match-beginning n)
+ (match-end n))
+ ;; if there was no such register
+ (error (throw 'key nil))))))))))
(defvar sort-columns-subprocess t)
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index fe6b18e1764..34fbec9c218 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -1,17 +1,10 @@
-;;; speedbar --- quick access to files and tags in a frame
+;;; speedbar.el --- quick access to files and tags in a frame -*- lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
-(defvar speedbar-version "1.0"
- "The current version of speedbar.")
-(defvar speedbar-incompatible-version "0.14beta4"
- "This version of speedbar is incompatible with this version.
-Due to massive API changes (removing the use of the word PATH)
-this version is not backward compatible to 0.14 or earlier.")
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -113,9 +106,8 @@ this version is not backward compatible to 0.14 or earlier.")
;;; TODO:
;; - Timeout directories we haven't visited in a while.
-(require 'easymenu)
(require 'dframe)
-(require 'sb-image)
+(require 'ezimage)
;; customization stuff
(defgroup speedbar nil
@@ -141,26 +133,13 @@ this version is not backward compatible to 0.14 or earlier.")
:prefix "speedbar-"
:group 'speedbar)
-;;; Code:
+(defcustom speedbar-use-images ezimage-use-images
+ "Non-nil if speedbar should display icons."
+ :group 'speedbar
+ :version "21.1"
+ :type 'boolean)
-;; Note: `inversion-test' requires parts of the CEDET package that are
-;; not included with Emacs.
-;;
-;; (defun speedbar-require-version (major minor &optional beta)
-;; "Non-nil if this version of SPEEDBAR does not satisfy a specific version.
-;; Arguments can be:
-;;
-;; (MAJOR MINOR &optional BETA)
-;;
-;; Values MAJOR and MINOR must be integers. BETA can be an integer, or
-;; excluded if a released version is required.
-;;
-;; It is assumed that if the current version is newer than that specified,
-;; everything passes. Exceptions occur when known incompatibilities are
-;; introduced."
-;; (inversion-test 'speedbar
-;; (concat major "." minor
-;; (when beta (concat "beta" beta)))))
+;;; Code:
(defvar speedbar-initial-expansion-mode-alist
'(("buffers" speedbar-buffer-easymenu-definition speedbar-buffers-key-map
@@ -296,6 +275,8 @@ The default buffer is the buffer in the selected window in the attached frame."
"Hooks run when speedbar is loaded."
:group 'speedbar
:type 'hook)
+(make-obsolete-variable 'speedbar-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom speedbar-reconfigure-keymaps-hook nil
"Hooks run when the keymaps are regenerated."
@@ -308,22 +289,6 @@ A nil value means don't show the file in the list."
:group 'speedbar
:type 'boolean)
-;;; EVENTUALLY REMOVE THESE
-
-;; When I moved to a repeating timer, I had the horrible misfortune
-;; of losing the ability for adaptive speed choice. This update
-;; speed currently causes long delays when it should have been turned off.
-(defvar speedbar-update-speed dframe-update-speed)
-(make-obsolete-variable 'speedbar-update-speed
- 'dframe-update-speed
- "speedbar 1.0pre3 (Emacs 23.1)")
-
-(defvar speedbar-navigating-speed dframe-update-speed)
-(make-obsolete-variable 'speedbar-navigating-speed
- 'dframe-update-speed
- "speedbar 1.0pre3 (Emacs 23.1)")
-;;; END REMOVE THESE
-
(defcustom speedbar-frame-parameters '((minibuffer . nil)
(width . 20)
(border-width . 0)
@@ -641,7 +606,7 @@ They should include commonly existing directories which are not
useful. It is no longer necessary to include version-control
directories here; see `vc-directory-exclusion-list'."
:group 'speedbar
- :type 'string)
+ :type 'regexp)
(defcustom speedbar-file-unshown-regexp
(let ((nstr "") (noext completion-ignored-extensions))
@@ -654,7 +619,7 @@ directories here; see `vc-directory-exclusion-list'."
"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)
+ :type 'regexp)
(defvar speedbar-file-regexp nil
"Regular expression matching files we know how to expand.
@@ -889,12 +854,9 @@ This basically creates a sparse keymap, and makes its parent be
"Additional menu items while in file-mode.")
(defvar speedbar-easymenu-definition-trailer
- (append
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
- (list ["Customize..." speedbar-customize t]))
- (list
+ '(["Customize..." speedbar-customize t]
["Close" dframe-close-frame t]
- ["Quit" delete-frame t] ))
+ ["Quit" delete-frame t])
"Menu items appearing at the end of the speedbar menu.")
(defvar speedbar-desired-buffer nil
@@ -972,10 +934,9 @@ supported at a time.
(speedbar-set-timer dframe-update-speed)
)
;; Frame modifications
- (set (make-local-variable 'dframe-delete-frame-function)
- 'speedbar-handle-delete-frame)
+ (setq-local dframe-delete-frame-function 'speedbar-handle-delete-frame)
;; hscroll
- (set (make-local-variable 'auto-hscroll-mode) nil)
+ (setq-local auto-hscroll-mode nil)
;; reset the selection variable
(setq speedbar-last-selected-file nil))
@@ -1068,9 +1029,8 @@ in the selected file.
(save-excursion
(setq font-lock-keywords nil) ;; no font-locking please
(setq truncate-lines t)
- (make-local-variable 'frame-title-format)
- (setq frame-title-format (concat "Speedbar " speedbar-version)
- case-fold-search nil
+ (setq-local frame-title-format "Speedbar")
+ (setq case-fold-search nil
buffer-read-only t)
(speedbar-set-mode-line-format)
;; Add in our dframe hooks.
@@ -1137,6 +1097,7 @@ frame and window to be the currently active frame and window."
(defvar speedbar-previous-menu nil
"The menu before the last `speedbar-reconfigure-keymaps' was called.")
+(make-obsolete-variable 'speedbar-previous-menu "no longer used." "28.1")
(defun speedbar-reconfigure-keymaps ()
"Reconfigure the menu-bar in a speedbar frame.
@@ -1188,10 +1149,7 @@ and the existence of packages."
(speedbar-initial-keymap)
;; This creates a small keymap we can glom the
;; menu adjustments into.
- (speedbar-make-specialized-keymap)))
- ;; Delete the old menu if applicable.
- (if speedbar-previous-menu (easy-menu-remove speedbar-previous-menu))
- (setq speedbar-previous-menu md)
+ (speedbar-make-specialized-keymap)))
;; Now add the new menu
(easy-menu-define speedbar-menu-map (current-local-map)
"Speedbar menu" md))
@@ -1382,7 +1340,7 @@ Argument ARG represents to force a refresh past any caches that may exist."
(if (and (file-exists-p f) (string-match "\\.el\\'" f))
(progn
(dframe-select-attached-frame speedbar-frame)
- (byte-compile-file f nil)
+ (byte-compile-file f)
(select-frame sf)
(speedbar-reset-scanners)))
))
@@ -1646,7 +1604,7 @@ variable `speedbar-obj-alist'."
(defmacro speedbar-with-writable (&rest forms)
"Allow the buffer to be writable and evaluate FORMS."
- (declare (indent 0))
+ (declare (indent 0) (debug t))
`(let ((inhibit-read-only t))
,@forms))
@@ -1703,7 +1661,7 @@ argument."
(put-text-property start end 'help-echo #'dframe-help-echo))
(if function (put-text-property start end 'speedbar-function function))
(if token (put-text-property start end 'speedbar-token token))
- ;; So far the only text we have is less that 3 chars.
+ ;; So far the only text we have is less than 3 chars.
(if (<= (- end start) 3)
(speedbar-insert-image-button-maybe start (- end start)))
)
@@ -1749,8 +1707,9 @@ This is based on `speedbar-initial-expansion-list-name' referencing
"Change speedbar's default expansion list to NEW-DEFAULT."
(interactive
(list
- (completing-read (format "Speedbar Mode (default %s): "
- speedbar-previously-used-expansion-list-name)
+ (completing-read (format-prompt
+ "Speedbar Mode"
+ speedbar-previously-used-expansion-list-name)
speedbar-initial-expansion-mode-alist
nil t "" nil
speedbar-previously-used-expansion-list-name)))
@@ -1808,16 +1767,13 @@ of the special mode functions."
(setq v (intern-soft (concat ms "-speedbar-key-map")))
(if (not v)
nil ;; don't add special keymap
- (make-local-variable 'speedbar-special-mode-key-map)
- (setq speedbar-special-mode-key-map
- (symbol-value v)))
+ (setq-local speedbar-special-mode-key-map
+ (symbol-value v)))
(setq v (intern-soft (concat ms "-speedbar-menu-items")))
(if (not v)
nil ;; don't add special menus
- (make-local-variable 'speedbar-easymenu-definition-special)
- (setq speedbar-easymenu-definition-special
- (symbol-value v)))
- )))))))
+ (setq-local speedbar-easymenu-definition-special
+ (symbol-value v))))))))))
(defun speedbar-remove-localized-speedbar-support (buffer)
"Remove any traces that BUFFER supports speedbar in a specialized way."
@@ -2203,10 +2159,13 @@ passes some tests."
;; way by displaying the range over which we
;; have grouped them.
(setq work-list
- (cons (cons (concat short-start-name
- " to "
- short-end-name)
- short-group-list)
+ (cons (cons
+ (concat short-start-name
+ " to " short-end-name)
+ (sort (copy-sequence short-group-list)
+ (lambda (e1 e2)
+ (string< (car e1)
+ (car e2)))))
work-list))))
;; Reset short group list information every time.
(setq short-group-list nil
@@ -3230,19 +3189,21 @@ With universal argument ARG, flush cached data."
"Expand the line under the cursor and all descendants.
Optional argument ARG indicates that any cache should be flushed."
(interactive "P")
- (speedbar-expand-line arg)
- ;; Now, inside the area expanded here, expand all subnodes of
- ;; the same descendant type.
- (save-excursion
- (speedbar-next 1) ;; Move into the list.
- (let ((err nil))
- (while (not err)
- (condition-case nil
- (progn
- (speedbar-expand-line-descendants arg)
- (speedbar-restricted-next 1))
- (error (setq err t))))))
- )
+ (save-restriction
+ (narrow-to-region (line-beginning-position)
+ (line-beginning-position 2))
+ (speedbar-expand-line arg)
+ ;; Now, inside the area expanded here, expand all subnodes of
+ ;; the same descendant type.
+ (save-excursion
+ (speedbar-next 1) ;; Move into the list.
+ (let ((err nil))
+ (while (not err)
+ (condition-case nil
+ (progn
+ (speedbar-expand-line-descendants arg)
+ (speedbar-restricted-next 1))
+ (error (setq err t))))))))
(defun speedbar-contract-line-descendants ()
"Expand the line under the cursor and all descendants."
@@ -3286,7 +3247,7 @@ subdirectory chosen will be at INDENT level."
;; in case.
(let ((speedbar-smart-directory-expand-flag nil))
(speedbar-update-contents))
- (speedbar-set-timer speedbar-navigating-speed)
+ (speedbar-set-timer dframe-update-speed)
(setq speedbar-last-selected-file nil)
(speedbar-stealthy-updates))
@@ -3349,7 +3310,7 @@ INDENT is the current indentation level and is unused."
;; update contents will change directory without
;; having to touch the attached frame.
(speedbar-update-contents)
- (speedbar-set-timer speedbar-navigating-speed))
+ (speedbar-set-timer dframe-update-speed))
(defun speedbar-tag-file (text token indent)
"The cursor is on a selected line. Expand the tags in the specified file.
@@ -4007,11 +3968,6 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
"Speedbar face for separator labels in a display."
:group 'speedbar-faces)
-;; some edebug hooks
-(add-hook 'edebug-setup-hook
- (lambda ()
- (def-edebug-spec speedbar-with-writable def-body)))
-
;; Fix a font lock problem for some versions of Emacs
(and (boundp 'font-lock-global-modes)
font-lock-global-modes
@@ -4022,9 +3978,83 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
(setq font-lock-global-modes (delq 'speedbar-mode
font-lock-global-modes)))))
+;;; Image management
+
+(defvar speedbar-expand-image-button-alist
+ '(("<+>" . ezimage-directory-plus)
+ ("<->" . ezimage-directory-minus)
+ ("< >" . ezimage-directory)
+ ("[+]" . ezimage-page-plus)
+ ("[-]" . ezimage-page-minus)
+ ("[?]" . ezimage-page)
+ ("[ ]" . ezimage-page)
+ ("{+}" . ezimage-box-plus)
+ ("{-}" . ezimage-box-minus)
+ ("<M>" . ezimage-mail)
+ ("<d>" . ezimage-document-tag)
+ ("<i>" . ezimage-info-tag)
+ (" =>" . ezimage-tag)
+ (" +>" . ezimage-tag-gt)
+ (" ->" . ezimage-tag-v)
+ (">" . ezimage-tag)
+ ("@" . ezimage-tag-type)
+ (" @" . ezimage-tag-type)
+ ("*" . ezimage-checkout)
+ ("#" . ezimage-object)
+ ("!" . ezimage-object-out-of-date)
+ ("//" . ezimage-label)
+ ("%" . ezimage-lock)
+ )
+ "List of text and image associations.")
+
+(defun speedbar-insert-image-button-maybe (start length)
+ "Insert an image button based on text starting at START for LENGTH chars.
+If buttontext is unknown, just insert that text.
+If we have an image associated with it, use that image."
+ (when speedbar-use-images
+ (let ((ezimage-expand-image-button-alist
+ speedbar-expand-image-button-alist))
+ (ezimage-insert-image-button-maybe start length))))
+
+(defun speedbar-image-dump ()
+ "Dump out the current state of the Speedbar image alist.
+See `speedbar-expand-image-button-alist' for details."
+ (interactive)
+ (with-output-to-temp-buffer "*Speedbar Images*"
+ (with-current-buffer "*Speedbar Images*"
+ (goto-char (point-max))
+ (insert "Speedbar image cache.\n\n")
+ (let ((start (point)) (end nil))
+ (insert "Image\tText\tImage Name")
+ (setq end (point))
+ (insert "\n")
+ (put-text-property start end 'face 'underline))
+ (let ((ia speedbar-expand-image-button-alist))
+ (while ia
+ (let ((start (point)))
+ (insert (car (car ia)))
+ (insert "\t")
+ (speedbar-insert-image-button-maybe start
+ (length (car (car ia))))
+ (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n"))
+ (setq ia (cdr ia)))))))
+
+
+;; Obsolete
+
+(defvar speedbar-version "1.0"
+ "The current version of speedbar.")
+(make-obsolete-variable 'speedbar-version 'emacs-version "28.1")
+
+(defvar speedbar-incompatible-version "0.14beta4"
+ "This version of speedbar is incompatible with this version.
+Due to massive API changes (removing the use of the word PATH)
+this version is not backward compatible to 0.14 or earlier.")
+(make-obsolete-variable 'speedbar-incompatible-version nil "28.1")
+
+
(provide 'speedbar)
-;; run load-time hooks
(run-hooks 'speedbar-load-hook)
-;;; speedbar ends here
+;;; speedbar.el ends here
diff --git a/lisp/startup.el b/lisp/startup.el
index b60c13e4487..f337f7c6bcf 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -320,6 +320,8 @@ early init file.")
This variable is used to define the proper function and keypad
keys for use under X. It is used in a fashion analogous to the
environment variable TERM.")
+(make-obsolete-variable 'keyboard-type nil "28.1")
+(internal-make-var-non-special 'keyboard-type)
(defvar window-setup-hook nil
"Normal hook run after loading init files and handling the command line.
@@ -463,9 +465,6 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'."
(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))
@@ -520,6 +519,7 @@ DIRS are relative."
xdg-dir)
(t emacs-d-dir))))
+(defvar native-comp-eln-load-path)
(defun normal-top-level ()
"Emacs calls this function when it first starts up.
It sets `command-line-processed', processes the command-line,
@@ -537,6 +537,22 @@ It is the default value of the variable `top-level'."
(setq user-emacs-directory
(startup--xdg-or-homedot startup--xdg-config-home-emacs nil))
+ (when (featurep 'native-compile)
+ ;; Form `native-comp-eln-load-path'.
+ (let ((path-env (getenv "EMACSNATIVELOADPATH")))
+ (when path-env
+ (dolist (path (split-string path-env path-separator))
+ (unless (string= "" path)
+ (push path native-comp-eln-load-path)))))
+ (push (expand-file-name "eln-cache/" user-emacs-directory)
+ native-comp-eln-load-path)
+ ;; When $HOME is set to '/nonexistent' means we are running the
+ ;; testsuite, add a temporary folder in front to produce there
+ ;; new compilations.
+ (when (equal (getenv "HOME") "/nonexistent")
+ (let ((tmp-dir (make-temp-file "emacs-testsuite-" t)))
+ (add-hook 'kill-emacs-hook (lambda () (delete-directory tmp-dir t)))
+ (push tmp-dir native-comp-eln-load-path))))
;; 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. This needs to be done before setting
@@ -623,6 +639,16 @@ It is the default value of the variable `top-level'."
(set pathsym (mapcar (lambda (dir)
(decode-coding-string dir coding t))
path)))))
+ (when (featurep 'native-compile)
+ (let ((npath (symbol-value 'native-comp-eln-load-path)))
+ (set 'native-comp-eln-load-path
+ (mapcar (lambda (dir)
+ ;; Call expand-file-name to remove all the
+ ;; pesky ".." from the directyory names in
+ ;; native-comp-eln-load-path.
+ (expand-file-name
+ (decode-coding-string dir coding t)))
+ npath))))
(dolist (filesym '(data-directory doc-directory exec-directory
installation-directory
invocation-directory invocation-name
@@ -636,7 +662,7 @@ It is the default value of the variable `top-level'."
(with-current-buffer "*Messages*"
(messages-buffer-mode)
;; Make it easy to do like "tail -f".
- (set (make-local-variable 'window-point-insertion-type) t)
+ (setq-local window-point-insertion-type t)
;; Give *Messages* the same default-directory as *scratch*,
;; just to keep things predictable.
(setq default-directory (or dir (expand-file-name "~/")))))
@@ -645,16 +671,13 @@ It is the default value of the variable `top-level'."
(list (default-value 'user-full-name)))
;; If the PWD environment variable isn't accurate, delete it.
(let ((pwd (getenv "PWD")))
- (and (stringp pwd)
- ;; Use FOO/., so that if FOO is a symlink, file-attributes
- ;; describes the directory linked to, not FOO itself.
+ (and pwd
(or (and default-directory
(ignore-errors
(equal (file-attributes
- (concat (file-name-as-directory pwd) "."))
+ (file-name-as-directory pwd))
(file-attributes
- (concat (file-name-as-directory default-directory)
- ".")))))
+ (file-name-as-directory default-directory)))))
(setq process-environment
(delete (concat "PWD=" pwd)
process-environment)))))
@@ -956,10 +979,10 @@ init-file, or to a default value if loading is not possible."
(when (and (eq user-init-file t) alternate-filename-function)
(let ((alt-file (funcall alternate-filename-function)))
- (and (equal (file-name-extension alt-file) "el")
- (setq alt-file (file-name-sans-extension alt-file)))
(unless init-file-name
(setq init-file-name alt-file))
+ (and (equal (file-name-extension alt-file) "el")
+ (setq alt-file (file-name-sans-extension alt-file)))
(load alt-file 'noerror 'nomessage)))
;; If we did not find the user's init file, set
@@ -1101,7 +1124,7 @@ please check its value")
("--no-x-resources") ("--debug-init")
("--user") ("--iconic") ("--icon-type") ("--quick")
("--no-blinking-cursor") ("--basic-display")
- ("--dump-file") ("--temacs")))
+ ("--dump-file") ("--temacs") ("--seccomp")))
(argi (pop args))
(orig-argi argi)
argval)
@@ -1153,7 +1176,8 @@ please check its value")
(push '(visibility . icon) initial-frame-alist))
((member argi '("-nbc" "-no-blinking-cursor"))
(setq no-blinking-cursor t))
- ((member argi '("-dump-file" "-temacs")) ; Handled in C
+ ((member argi '("-dump-file" "-temacs" "-seccomp"))
+ ;; Handled in C
(or argval (pop args))
(setq argval nil))
;; Push the popped arg back on the list of arguments.
@@ -1173,12 +1197,12 @@ please check its value")
;; Re-evaluate predefined variables whose initial value depends on
;; the runtime context.
- (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH
- (setq custom-delayed-init-variables
- ;; Initialize them in the same order they were loaded, in case there
- ;; are dependencies between them.
- (nreverse custom-delayed-init-variables))
- (mapc 'custom-reevaluate-setting custom-delayed-init-variables))
+ (when (listp custom-delayed-init-variables)
+ (mapc #'custom-reevaluate-setting
+ ;; Initialize them in the same order they were loaded, in
+ ;; case there are dependencies between them.
+ (reverse custom-delayed-init-variables)))
+ (setq custom-delayed-init-variables t)
;; Warn for invalid user name.
(when init-file-user
@@ -1237,17 +1261,7 @@ please check its value")
package-enable-at-startup
(not (bound-and-true-p package--activated))
(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)
+ (let ((dirs (cons package-user-dir package-directory-list)))
(dolist (dir dirs)
(when (file-directory-p dir)
(dolist (subdir (directory-files dir))
@@ -1305,8 +1319,7 @@ please check its value")
(if (or noninteractive emacs-basic-display)
(setq menu-bar-mode nil
tab-bar-mode nil
- tool-bar-mode nil
- no-blinking-cursor t))
+ tool-bar-mode nil))
(frame-initialize))
(when (fboundp 'x-create-frame)
@@ -1315,26 +1328,10 @@ please check its value")
(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
- emacs-basic-display
- (and (memq window-system '(x w32 ns))
- (not (member (x-get-resource "cursorBlink" "CursorBlink")
- '("no" "off" "false" "0")))))
- (setq no-blinking-cursor t))
-
(unless noninteractive
(startup--setup-quote-display)
(setq internal--text-quoting-flag t))
- ;; Re-evaluate again the predefined variables whose initial value
- ;; depends on the runtime context, in case some of them depend on
- ;; the window-system features. Example: blink-cursor-mode.
- (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH
- (mapc 'custom-reevaluate-setting custom-delayed-init-variables)
- (setq custom-delayed-init-variables nil))
-
(normal-erase-is-backspace-setup-frame)
;; Register default TTY colors for the case the terminal hasn't a
@@ -1389,7 +1386,7 @@ please check its value")
"~/.emacs")))
(lambda ()
(expand-file-name
- "init"
+ "init.el"
startup-init-directory))
t)
@@ -1417,7 +1414,7 @@ please check its value")
(equal user-mail-address
(let (mail-host-address)
(ignore-errors
- (eval (car (get 'user-mail-address 'standard-value))))))
+ (custom--standard-value 'user-mail-address))))
(custom-reevaluate-setting 'user-mail-address))
;; If parameter have been changed in the init file which influence
@@ -1515,13 +1512,13 @@ to reading the init file), or afterwards when the user first
opens a graphical frame.
This can set the values of `menu-bar-mode', `tool-bar-mode',
-`tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face.
+`tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face.
Changed settings will be marked as \"CHANGED outside of Customize\"."
(let ((no-vals '("no" "off" "false" "0"))
(settings '(("menuBar" "MenuBar" menu-bar-mode nil)
("toolBar" "ToolBar" tool-bar-mode nil)
("scrollBar" "ScrollBar" scroll-bar-mode nil)
- ("cursorBlink" "CursorBlink" no-blinking-cursor t))))
+ ("cursorBlink" "CursorBlink" blink-cursor-mode nil))))
(dolist (x settings)
(if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals)
(set (nth 2 x) (nth 3 x)))))
@@ -2006,7 +2003,7 @@ splash screen in another window."
(setq buffer-read-only nil)
(erase-buffer)
(setq default-directory command-line-default-directory)
- (set (make-local-variable 'tab-width) 8)
+ (setq-local tab-width 8)
(if pure-space-overflow
(insert pure-space-overflow-message))
@@ -2320,6 +2317,9 @@ A fancy display is used on graphic displays, normal otherwise."
(set-buffer-major-mode (current-buffer))
(current-buffer))))
+;; This avoids byte-compiler warning in the unexec build.
+(declare-function pdumper-stats "pdumper.c" ())
+
(defun command-line-1 (args-left)
"A subroutine of `command-line'."
(display-startup-echo-area-message)
@@ -2391,6 +2391,7 @@ nil default-directory" name)
(command-line-normalize-file-name name)
dir))
(buf (find-file-noselect file)))
+ (file-name-history--add file)
(setq displayable-buffers (cons buf displayable-buffers))
;; Set the file buffer to the current buffer so
;; that it will be used with "--eval" and
@@ -2500,7 +2501,7 @@ nil default-directory" name)
(or argval (pop command-line-args-left))))
;; Take file from default dir if it exists there;
;; otherwise let `load' search for it.
- (file-ex (expand-file-name file)))
+ (file-ex (file-truename (expand-file-name file))))
(when (file-regular-p file-ex)
(setq file file-ex))
(load file nil t)))
@@ -2511,7 +2512,7 @@ nil default-directory" name)
(let* ((file (command-line-normalize-file-name
(or argval (pop command-line-args-left))))
;; Take file from default dir.
- (file-ex (expand-file-name file)))
+ (file-ex (file-truename (expand-file-name file))))
(load file-ex nil t t)))
((equal argi "-insert")
diff --git a/lisp/strokes.el b/lisp/strokes.el
index 36e76de979e..18595cb0947 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -1,4 +1,4 @@
-;;; strokes.el --- control Emacs through mouse strokes
+;;; strokes.el --- control Emacs through mouse strokes -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc.
@@ -138,15 +138,14 @@
;; the user to enter strokes which "remove the pencil from the paper"
;; so to speak, so one character can have multiple strokes.
-;; NOTE (Oct 7, 2006): The URLs below seem to be invalid!!!
-
;; You can read more about strokes at:
-;; http://www.mit.edu/people/cadet/strokes-help.html
+;; https://web.archive.org/web/20041209171947/http://www.mit.edu/people/cadet/strokes-help.html
;; If you're interested in using strokes for writing English into Emacs
;; using strokes, then you'll want to read about it on the web page above
-;; or just download from http://www.mit.edu/people/cadet/strokes-abc.el,
+;; or just download from:
+;; https://web.archive.org/web/20041204163338/http://www.mit.edu/people/cadet/strokes-abc.el
;; which is nothing but a file with some helper commands for inserting
;; alphanumerics and punctuation.
@@ -216,14 +215,12 @@ static char * stroke_xpm[] = {
(defcustom strokes-lighter " Strokes"
"Mode line identifier for Strokes mode."
- :type 'string
- :group 'strokes)
+ :type 'string)
(defcustom strokes-character ?@
"Character used when drawing strokes in the strokes buffer.
\(The default is `@', which works well.)"
- :type 'character
- :group 'strokes)
+ :type 'character)
(defcustom strokes-minimum-match-score 1000
"Minimum score for a stroke to be considered a possible match.
@@ -239,8 +236,7 @@ then you can set `strokes-minimum-match-score' to something that works
for you. The only purpose of this variable is to insure that if you
do a bogus stroke that really doesn't match any of the predefined
ones, then strokes should NOT pick the one that came closest."
- :type 'integer
- :group 'strokes)
+ :type 'integer)
(defcustom strokes-grid-resolution 9
"Integer defining dimensions of the stroke grid.
@@ -256,14 +252,12 @@ WARNING: Changing the value of this variable will gravely affect the
figure out what it should be based on your needs and on how
quick the particular platform(s) you're operating on, and
only then start programming in your custom strokes."
- :type 'integer
- :group 'strokes)
+ :type 'integer)
(defcustom strokes-file (locate-user-emacs-file "strokes" ".strokes")
"File containing saved strokes for Strokes mode."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'strokes)
+ :type 'file)
(defvar strokes-buffer-name " *strokes*"
"The name of the buffer that the strokes take place in.")
@@ -273,8 +267,7 @@ WARNING: Changing the value of this variable will gravely affect the
If nil, strokes will be read the same, however the user will not be
able to see the strokes. This be helpful for people who don't like
the delay in switching to the strokes buffer."
- :type 'boolean
- :group 'strokes)
+ :type 'boolean)
;;; internal variables...
@@ -296,6 +289,8 @@ the corresponding interactive function.")
(defvar strokes-load-hook nil
"Functions to be called when Strokes is loaded.")
+(make-obsolete-variable 'strokes-load-hook
+ "use `with-eval-after-load' instead." "28.1")
;;; ### NOT IMPLEMENTED YET ###
;;(defvar edit-strokes-menu
@@ -311,12 +306,6 @@ the corresponding interactive function.")
;;; Macros...
-;; unused
-;; (defmacro strokes-while-inhibiting-garbage-collector (&rest forms)
-;; "Execute FORMS without interference from the garbage collector."
-;; `(let ((gc-cons-threshold 134217727))
-;; ,@forms))
-
(defsubst strokes-click-p (stroke)
"Non-nil if STROKE is really click."
(< (length stroke) 2))
@@ -572,9 +561,8 @@ Optional GRID-RESOLUTION may be used in place of `strokes-grid-resolution'.
The grid is a square whose dimension is [0,GRID-RESOLUTION)."
(or grid-resolution (setq grid-resolution strokes-grid-resolution))
(let ((stroke-extent (strokes-get-stroke-extent positions)))
- (mapcar (function
- (lambda (pos)
- (strokes-get-grid-position stroke-extent pos grid-resolution)))
+ (mapcar (lambda (pos)
+ (strokes-get-grid-position stroke-extent pos grid-resolution))
positions)))
(defun strokes-fill-stroke (unfilled-stroke &optional force)
@@ -755,12 +743,12 @@ Optional EVENT is acceptable as the starting event of the stroke."
(strokes-fill-current-buffer-with-whitespace))
(when prompt
(message "%s" prompt)
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (strokes-button-press-event-p event)
(error "You must draw with the mouse")))
(unwind-protect
(track-mouse
- (or event (setq event (read-event)
+ (or event (setq event (read--potential-mouse-event)
safe-to-draw-p t))
(while (not (strokes-button-release-event-p event))
(if (strokes-mouse-event-p event)
@@ -775,7 +763,7 @@ Optional EVENT is acceptable as the starting event of the stroke."
(setq safe-to-draw-p t))
(push (cdr (mouse-pixel-position))
pix-locs)))
- (setq event (read-event)))))
+ (setq event (read--potential-mouse-event)))))
;; protected
;; clean up strokes buffer and then bury it.
(when (equal (buffer-name) strokes-buffer-name)
@@ -786,16 +774,16 @@ Optional EVENT is acceptable as the starting event of the stroke."
;; Otherwise, don't use strokes buffer and read stroke silently
(when prompt
(message "%s" prompt)
- (setq event (read-event))
+ (setq event (read--potential-mouse-event))
(or (strokes-button-press-event-p event)
(error "You must draw with the mouse")))
(track-mouse
- (or event (setq event (read-event)))
+ (or event (setq event (read--potential-mouse-event)))
(while (not (strokes-button-release-event-p event))
(if (strokes-mouse-event-p event)
(push (cdr (mouse-pixel-position))
pix-locs))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs)))
(strokes-fill-stroke
(strokes-eliminate-consecutive-redundancies grid-locs)))))
@@ -816,10 +804,10 @@ Optional EVENT is acceptable as the starting event of the stroke."
(if prompt
(while (not (strokes-button-press-event-p event))
(message "%s" prompt)
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(unwind-protect
(track-mouse
- (or event (setq event (read-event)))
+ (or event (setq event (read--potential-mouse-event)))
(while (not (and (strokes-button-press-event-p event)
(eq 'mouse-3
(car (get (car event)
@@ -833,14 +821,15 @@ Optional EVENT is acceptable as the starting event of the stroke."
?\s strokes-character))
(push (cdr (mouse-pixel-position))
pix-locs)))
- (setq event (read-event)))
+ (setq event (read--potential-mouse-event)))
(push strokes-lift pix-locs)
(while (not (strokes-button-press-event-p event))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
;; ### KLUDGE! ### sit and wait
;; for some useless event to
;; happen to fix the minibuffer bug.
- (while (not (strokes-button-release-event-p (read-event))))
+ (while (not (strokes-button-release-event-p
+ (read--potential-mouse-event))))
(setq pix-locs (nreverse (cdr pix-locs))
grid-locs (strokes-renormalize-to-grid pix-locs))
(strokes-fill-stroke
@@ -1042,7 +1031,7 @@ o Strokes are a bit computer-dependent in that they depend somewhat on
(help-mode)
(help-print-return-message)))
-(define-obsolete-function-alias 'strokes-report-bug 'report-emacs-bug "24.1")
+(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.
@@ -1230,8 +1219,8 @@ the stroke as a character in some language."
;; mode-popup-menu edit-strokes-menu) ; what about extent-specific stuff?
;; (and (featurep 'menubar)
;; current-menubar
-;; (set (make-local-variable 'current-menubar)
-;; (copy-sequence current-menubar))
+;; (setq-local current-menubar
+;; (copy-sequence current-menubar))
;; (add-submenu nil edit-strokes-menu)))
;;(let ((map edit-strokes-mode-map))
@@ -1362,25 +1351,23 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead."
finally do (unless (eobp)
(kill-region (1+ (point)) (point-max))))
(view-buffer "*Strokes List*" nil)
- (set (make-local-variable 'view-mode-map)
- (let ((map (copy-keymap view-mode-map)))
- (define-key map "q" `(lambda ()
- (interactive)
- (View-quit)
- (set-window-configuration ,config)))
- map))
+ (setq-local view-mode-map
+ (let ((map (copy-keymap view-mode-map)))
+ (define-key map "q" `(lambda ()
+ (interactive)
+ (View-quit)
+ (set-window-configuration ,config)))
+ map))
(goto-char (point-min))))
(defun strokes-alphabetic-lessp (stroke1 stroke2)
"Return t if STROKE1's command name precedes STROKE2's in lexicographic order."
- (let ((command-name-1 (symbol-name (cdr stroke1)))
- (command-name-2 (symbol-name (cdr stroke2))))
- (string-lessp command-name-1 command-name-2)))
+ (string-lessp (cdr stroke1) (cdr stroke2)))
(defvar strokes-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [(shift down-mouse-2)] 'strokes-do-stroke)
- (define-key map [(meta down-mouse-2)] 'strokes-do-complex-stroke)
+ (define-key map [(shift down-mouse-2)] #'strokes-do-stroke)
+ (define-key map [(meta down-mouse-2)] #'strokes-do-complex-stroke)
map))
;;;###autoload
@@ -1399,8 +1386,7 @@ Encode/decode your strokes with \\[strokes-encode-buffer],
\\[strokes-decode-buffer].
\\{strokes-mode-map}"
- nil strokes-lighter strokes-mode-map
- :group 'strokes :global t
+ :lighter strokes-lighter :global t
(cond ((not (display-mouse-p))
(error "Can't use Strokes without a mouse"))
(strokes-mode ; turn on strokes
@@ -1408,15 +1394,15 @@ Encode/decode your strokes with \\[strokes-encode-buffer],
(null strokes-global-map)
(strokes-load-user-strokes))
(add-hook 'kill-emacs-query-functions
- 'strokes-prompt-user-save-strokes)
+ #'strokes-prompt-user-save-strokes)
(add-hook 'select-frame-hook
- 'strokes-update-window-configuration)
+ #'strokes-update-window-configuration)
(strokes-update-window-configuration))
(t ; turn off strokes
(if (get-buffer strokes-buffer-name)
(kill-buffer (get-buffer strokes-buffer-name)))
(remove-hook 'select-frame-hook
- 'strokes-update-window-configuration))))
+ #'strokes-update-window-configuration))))
;;;; strokes-xpm stuff (later may be separate)...
@@ -1426,74 +1412,75 @@ Encode/decode your strokes with \\[strokes-encode-buffer],
(defface strokes-char '((t (:background "lightgray")))
"Face for strokes characters."
- :version "21.1"
- :group 'strokes)
+ :version "21.1")
(put 'strokes 'char-table-extra-slots 0)
-(defconst strokes-char-table (make-char-table 'strokes) ;
+(defconst strokes-char-table
+ (let ((ct (make-char-table 'strokes))) ;
+ (aset ct ?0 0)
+ (aset ct ?1 1)
+ (aset ct ?2 2)
+ (aset ct ?3 3)
+ (aset ct ?4 4)
+ (aset ct ?5 5)
+ (aset ct ?6 6)
+ (aset ct ?7 7)
+ (aset ct ?8 8)
+ (aset ct ?9 9)
+ (aset ct ?a 10)
+ (aset ct ?b 11)
+ (aset ct ?c 12)
+ (aset ct ?d 13)
+ (aset ct ?e 14)
+ (aset ct ?f 15)
+ (aset ct ?g 16)
+ (aset ct ?h 17)
+ (aset ct ?i 18)
+ (aset ct ?j 19)
+ (aset ct ?k 20)
+ (aset ct ?l 21)
+ (aset ct ?m 22)
+ (aset ct ?n 23)
+ (aset ct ?o 24)
+ (aset ct ?p 25)
+ (aset ct ?q 26)
+ (aset ct ?r 27)
+ (aset ct ?s 28)
+ (aset ct ?t 29)
+ (aset ct ?u 30)
+ (aset ct ?v 31)
+ (aset ct ?w 32)
+ (aset ct ?x 33)
+ (aset ct ?y 34)
+ (aset ct ?z 35)
+ (aset ct ?A 36)
+ (aset ct ?B 37)
+ (aset ct ?C 38)
+ (aset ct ?D 39)
+ (aset ct ?E 40)
+ (aset ct ?F 41)
+ (aset ct ?G 42)
+ (aset ct ?H 43)
+ (aset ct ?I 44)
+ (aset ct ?J 45)
+ (aset ct ?K 46)
+ (aset ct ?L 47)
+ (aset ct ?M 48)
+ (aset ct ?N 49)
+ (aset ct ?O 50)
+ (aset ct ?P 51)
+ (aset ct ?Q 52)
+ (aset ct ?R 53)
+ (aset ct ?S 54)
+ (aset ct ?T 55)
+ (aset ct ?U 56)
+ (aset ct ?V 57)
+ (aset ct ?W 58)
+ (aset ct ?X 59)
+ (aset ct ?Y 60)
+ (aset ct ?Z 61)
+ ct)
"The table which stores values for the character keys.")
-(aset strokes-char-table ?0 0)
-(aset strokes-char-table ?1 1)
-(aset strokes-char-table ?2 2)
-(aset strokes-char-table ?3 3)
-(aset strokes-char-table ?4 4)
-(aset strokes-char-table ?5 5)
-(aset strokes-char-table ?6 6)
-(aset strokes-char-table ?7 7)
-(aset strokes-char-table ?8 8)
-(aset strokes-char-table ?9 9)
-(aset strokes-char-table ?a 10)
-(aset strokes-char-table ?b 11)
-(aset strokes-char-table ?c 12)
-(aset strokes-char-table ?d 13)
-(aset strokes-char-table ?e 14)
-(aset strokes-char-table ?f 15)
-(aset strokes-char-table ?g 16)
-(aset strokes-char-table ?h 17)
-(aset strokes-char-table ?i 18)
-(aset strokes-char-table ?j 19)
-(aset strokes-char-table ?k 20)
-(aset strokes-char-table ?l 21)
-(aset strokes-char-table ?m 22)
-(aset strokes-char-table ?n 23)
-(aset strokes-char-table ?o 24)
-(aset strokes-char-table ?p 25)
-(aset strokes-char-table ?q 26)
-(aset strokes-char-table ?r 27)
-(aset strokes-char-table ?s 28)
-(aset strokes-char-table ?t 29)
-(aset strokes-char-table ?u 30)
-(aset strokes-char-table ?v 31)
-(aset strokes-char-table ?w 32)
-(aset strokes-char-table ?x 33)
-(aset strokes-char-table ?y 34)
-(aset strokes-char-table ?z 35)
-(aset strokes-char-table ?A 36)
-(aset strokes-char-table ?B 37)
-(aset strokes-char-table ?C 38)
-(aset strokes-char-table ?D 39)
-(aset strokes-char-table ?E 40)
-(aset strokes-char-table ?F 41)
-(aset strokes-char-table ?G 42)
-(aset strokes-char-table ?H 43)
-(aset strokes-char-table ?I 44)
-(aset strokes-char-table ?J 45)
-(aset strokes-char-table ?K 46)
-(aset strokes-char-table ?L 47)
-(aset strokes-char-table ?M 48)
-(aset strokes-char-table ?N 49)
-(aset strokes-char-table ?O 50)
-(aset strokes-char-table ?P 51)
-(aset strokes-char-table ?Q 52)
-(aset strokes-char-table ?R 53)
-(aset strokes-char-table ?S 54)
-(aset strokes-char-table ?T 55)
-(aset strokes-char-table ?U 56)
-(aset strokes-char-table ?V 57)
-(aset strokes-char-table ?W 58)
-(aset strokes-char-table ?X 59)
-(aset strokes-char-table ?Y 60)
-(aset strokes-char-table ?Z 61)
(defconst strokes-base64-chars
;; I wanted to make this a vector of individual like (vector ?0
diff --git a/lisp/subr.el b/lisp/subr.el
index f0afecc7a30..b8286600664 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -31,7 +31,8 @@
"Tell the byte-compiler that function FN is defined, in FILE.
The FILE argument is not used by the byte-compiler, but by the
`check-declare' package, which checks that FILE contains a
-definition for FN.
+definition for FN. (FILE can be nil, and that disables this
+check.)
FILE can be either a Lisp file (in which case the \".el\"
extension is optional), or a C file. C files are expanded
@@ -64,8 +65,8 @@ For more information, see Info node `(elisp)Declaring Functions'."
;;;; Basic Lisp macros.
-(defalias 'not 'null)
-(defalias 'sxhash 'sxhash-equal)
+(defalias 'not #'null)
+(defalias 'sxhash #'sxhash-equal)
(defmacro noreturn (form)
"Evaluate FORM, expecting it not to return.
@@ -82,14 +83,27 @@ Testcover will raise an error."
form)
(defmacro def-edebug-spec (symbol spec)
- "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
+ "Set the Edebug SPEC to use for sexps which have SYMBOL as head.
Both SYMBOL and SPEC are unevaluated. The SPEC can be:
0 (instrument no arguments); t (instrument all arguments);
a symbol (naming a function with an Edebug specification); or a list.
The elements of the list describe the argument types; see
Info node `(elisp)Specification List' for details."
+ (declare (indent 1))
`(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
+(defun def-edebug-elem-spec (name spec)
+ "Define a new Edebug spec element NAME as shorthand for SPEC.
+The SPEC has to be a list."
+ (declare (indent 1))
+ (when (string-match "\\`[&:]" (symbol-name name))
+ ;; & and : have special meaning in spec element names.
+ (error "Edebug spec name cannot start with '&' or ':'"))
+ (unless (consp spec)
+ (error "Edebug spec has to be a list: %S" spec))
+ (put name 'edebug-elem-spec spec))
+
+
(defmacro lambda (&rest cdr)
"Return an anonymous function.
Under dynamic binding, a call of the form (lambda ARGS DOCSTRING
@@ -182,6 +196,14 @@ buffer-local wherever it is set."
(list 'progn (list 'defvar var val docstring)
(list 'make-variable-buffer-local (list 'quote var))))
+(defun buffer-local-boundp (symbol buffer)
+ "Return non-nil if SYMBOL is bound in BUFFER.
+Also see `local-variable-p'."
+ (condition-case nil
+ (buffer-local-value symbol buffer)
+ (:success t)
+ (void-variable nil)))
+
(defmacro push (newelt place)
"Add NEWELT to the list stored in the generalized variable PLACE.
This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
@@ -193,9 +215,9 @@ except that PLACE is evaluated only once (after NEWELT)."
(list 'setq place
(list 'cons newelt place))
(require 'macroexp)
- (macroexp-let2 macroexp-copyable-p v newelt
+ (macroexp-let2 macroexp-copyable-p x newelt
(gv-letplace (getter setter) place
- (funcall setter `(cons ,v ,getter))))))
+ (funcall setter `(cons ,x ,getter))))))
(defmacro pop (place)
"Return the first element of PLACE's value, and remove it from the list.
@@ -233,6 +255,11 @@ value of last one, or nil if there are none.
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
+(defsubst subr-primitive-p (object)
+ "Return t if OBJECT is a built-in primitive function."
+ (and (subrp object)
+ (not (subr-native-elisp-p object))))
+
(defsubst xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
@@ -257,10 +284,9 @@ Then evaluate RESULT to get return value, default nil.
;; use dolist.
;; FIXME: This cost disappears in byte-compiled lexical-binding files.
(let ((temp '--dolist-tail--))
- ;; 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.
+ ;; This test does not matter much because both semantics are acceptable,
+ ;; but 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
@@ -295,9 +321,9 @@ in compilation warnings about unused variables.
(let ((temp '--dotimes-limit--)
(start 0)
(end (nth 1 spec)))
- ;; 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.
+ ;; This test does not matter much because both semantics are acceptable,
+ ;; but one is slightly faster with dynamic scoping and the other has
+ ;; cleaner semantics.
(if lexical-binding
(let ((counter '--dotimes-counter--))
`(let ((,temp ,end)
@@ -361,10 +387,18 @@ PREFIX is a string, and defaults to \"g\"."
(defun ignore (&rest _arguments)
"Do nothing and return nil.
-This function accepts any number of ARGUMENTS, but ignores them."
+This function accepts any number of ARGUMENTS, but ignores them.
+Also see `always'."
+ (declare (completion ignore))
(interactive)
nil)
+(defun always (&rest _arguments)
+ "Do nothing and return t.
+This function accepts any number of ARGUMENTS, but ignores them.
+Also see `ignore'."
+ t)
+
;; Signal a compile-error if the first arg is missing.
(defun error (&rest args)
"Signal an error, making a message by passing ARGS to `format-message'.
@@ -770,11 +804,10 @@ If that is non-nil, the element matches; then `assoc-default'
If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
- (declare (side-effect-free t))
(let (found (tail alist) value)
(while (and tail (not found))
(let ((elt (car tail)))
- (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+ (when (funcall (or test #'equal) (if (consp elt) (car elt) elt) key)
(setq found t value (if (consp elt) (cdr elt) default))))
(setq tail (cdr tail)))
value))
@@ -834,10 +867,11 @@ Elements of ALIST that are not conses are ignored."
If KEY is not found in ALIST, return DEFAULT.
Equality with KEY is tested by TESTFN, defaulting to `eq'.
-You can use `alist-get' in PLACE expressions. This will modify
-an existing association (more precisely, the first one if
-multiple exist), or add a new element to the beginning of ALIST,
-destructively modifying the list stored in ALIST.
+You can use `alist-get' in \"place expressions\"; i.e., as a
+generalized variable. Doing this will modify an existing
+association (more precisely, the first one if multiple exist), or
+add a new element to the beginning of ALIST, destructively
+modifying the list stored in ALIST.
Example:
@@ -867,7 +901,9 @@ Example:
(defun remove (elt seq)
"Return a copy of SEQ with all occurrences of ELT removed.
-SEQ must be a list, vector, or string. The comparison is done with `equal'."
+SEQ must be a list, vector, or string. The comparison is done with `equal'.
+Contrary to `delete', this does not use side-effects, and the argument
+SEQ is not modified."
(declare (side-effect-free t))
(if (nlistp seq)
;; If SEQ isn't a list, there's no need to copy SEQ because
@@ -897,11 +933,13 @@ This is the same format used for saving keyboard macros (see
For an approximate inverse of this, see `key-description'."
;; Don't use a defalias, since the `pure' property is true only for
;; the calling convention of `kbd'.
- (read-kbd-macro keys))
-(put 'kbd 'pure t)
+ (declare (pure t) (side-effect-free t))
+ ;; A pure function is expected to preserve the match data.
+ (save-match-data (read-kbd-macro keys)))
(defun undefined ()
"Beep to tell the user this binding is undefined."
+ (declare (completion ignore))
(interactive)
(ding)
(if defining-kbd-macro
@@ -922,14 +960,14 @@ For an approximate inverse of this, see `key-description'."
"Make MAP override all normally self-inserting keys to be undefined.
Normally, as an exception, digits and minus-sign are set to make prefix args,
but optional second arg NODIGITS non-nil treats them like other chars."
- (define-key map [remap self-insert-command] 'undefined)
+ (define-key map [remap self-insert-command] #'undefined)
(or nodigits
(let (loop)
- (define-key map "-" 'negative-argument)
+ (define-key map "-" #'negative-argument)
;; Make plain numbers do numeric args.
(setq loop ?0)
(while (<= loop ?9)
- (define-key map (char-to-string loop) 'digit-argument)
+ (define-key map (char-to-string loop) #'digit-argument)
(setq loop (1+ loop))))))
(defun make-composed-keymap (maps &optional parent)
@@ -966,8 +1004,8 @@ a menu, so this function is not useful for non-menu keymaps."
(setq key
(if (<= (length key) 1) (aref key 0)
(setq keymap (lookup-key keymap
- (apply 'vector
- (butlast (mapcar 'identity key)))))
+ (apply #'vector
+ (butlast (mapcar #'identity key)))))
(aref key (1- (length key)))))
(let ((tail keymap) done inserted)
(while (and (not done) tail)
@@ -995,6 +1033,22 @@ a menu, so this function is not useful for non-menu keymaps."
(setq inserted t)))
(setq tail (cdr tail)))))
+(defun define-prefix-command (command &optional mapvar name)
+ "Define COMMAND as a prefix command. COMMAND should be a symbol.
+A new sparse keymap is stored as COMMAND's function definition and its
+value.
+This prepares COMMAND for use as a prefix key's binding.
+If a second optional argument MAPVAR is given, it should be a symbol.
+The map is then stored as MAPVAR's value instead of as COMMAND's
+value; but COMMAND is still defined as a function.
+The third optional argument NAME, if given, supplies a menu name
+string for the map. This is required to use the keymap as a menu.
+This function returns COMMAND."
+ (let ((map (make-sparse-keymap name)))
+ (fset command map)
+ (set (or mapvar command) map)
+ command))
+
(defun map-keymap-sorted (function keymap)
"Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
@@ -1079,7 +1133,7 @@ Subkeymaps may be modified but are not canonicalized."
(push (cons key item) bindings)))
map)))
;; Create the new map.
- (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
+ (setq map (funcall (if ranges #'make-keymap #'make-sparse-keymap) prompt))
(dolist (binding ranges)
;; Treat char-ranges specially. FIXME: need to merge as well.
(define-key map (vector (car binding)) (cdr binding)))
@@ -1162,6 +1216,30 @@ KEY is a string or vector representing a sequence of keystrokes."
(if (current-local-map)
(local-set-key key nil))
nil)
+
+(defun local-key-binding (keys &optional accept-default)
+ "Return the binding for command KEYS in current local keymap only.
+KEYS is a string or vector, a sequence of keystrokes.
+The binding is probably a symbol with a function definition.
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `lookup-key' for more details
+about this."
+ (let ((map (current-local-map)))
+ (when map (lookup-key map keys accept-default))))
+
+(defun global-key-binding (keys &optional accept-default)
+ "Return the binding for command KEYS in current global keymap only.
+KEYS is a string or vector, a sequence of keystrokes.
+The binding is probably a symbol with a function definition.
+This function's return values are the same as those of `lookup-key'
+\(which see).
+
+If optional argument ACCEPT-DEFAULT is non-nil, recognize default
+bindings; see the description of `lookup-key' for more details
+about this."
+ (lookup-key (current-global-map) keys accept-default))
+
;;;; substitute-key-definition and its subroutines.
@@ -1239,35 +1317,86 @@ in a cleaner way with command remapping, like this:
;;;; The global keymap tree.
-;; global-map, esc-map, and ctl-x-map have their values set up in
-;; keymap.c; we just give them docstrings here.
-
-(defvar global-map nil
- "Default global keymap mapping Emacs keyboard input into commands.
-The value is a keymap that is usually (but not necessarily) Emacs's
-global map.")
-
-(defvar esc-map nil
+(defvar esc-map
+ (let ((map (make-keymap)))
+ (define-key map "u" #'upcase-word)
+ (define-key map "l" #'downcase-word)
+ (define-key map "c" #'capitalize-word)
+ (define-key map "x" #'execute-extended-command)
+ (define-key map "X" #'execute-extended-command-for-buffer)
+ map)
"Default keymap for ESC (meta) commands.
The normal global definition of the character ESC indirects to this keymap.")
-
-(defvar ctl-x-map nil
- "Default keymap for C-x commands.
-The normal global definition of the character C-x indirects to this keymap.")
+(fset 'ESC-prefix esc-map)
+(make-obsolete 'ESC-prefix 'esc-map "28.1")
(defvar ctl-x-4-map (make-sparse-keymap)
"Keymap for subcommands of C-x 4.")
(defalias 'ctl-x-4-prefix ctl-x-4-map)
-(define-key ctl-x-map "4" 'ctl-x-4-prefix)
(defvar ctl-x-5-map (make-sparse-keymap)
"Keymap for frame commands.")
(defalias 'ctl-x-5-prefix ctl-x-5-map)
-(define-key ctl-x-map "5" 'ctl-x-5-prefix)
(defvar tab-prefix-map (make-sparse-keymap)
"Keymap for tab-bar related commands.")
-(define-key ctl-x-map "t" tab-prefix-map)
+
+(defvar ctl-x-map
+ (let ((map (make-keymap)))
+ (define-key map "4" 'ctl-x-4-prefix)
+ (define-key map "5" 'ctl-x-5-prefix)
+ (define-key map "t" tab-prefix-map)
+
+ (define-key map "b" #'switch-to-buffer)
+ (define-key map "k" #'kill-buffer)
+ (define-key map "\C-u" #'upcase-region) (put 'upcase-region 'disabled t)
+ (define-key map "\C-l" #'downcase-region) (put 'downcase-region 'disabled t)
+ (define-key map "<" #'scroll-left)
+ (define-key map ">" #'scroll-right)
+ map)
+ "Default keymap for C-x commands.
+The normal global definition of the character C-x indirects to this keymap.")
+(fset 'Control-X-prefix ctl-x-map)
+(make-obsolete 'Control-X-prefix 'ctl-x-map "28.1")
+
+(defvar global-map
+ (let ((map (make-keymap)))
+ (define-key map "\C-[" 'ESC-prefix)
+ (define-key map "\C-x" 'Control-X-prefix)
+
+ (define-key map "\C-i" #'self-insert-command)
+ (let* ((vec1 (make-vector 1 nil))
+ (f (lambda (from to)
+ (while (< from to)
+ (aset vec1 0 from)
+ (define-key map vec1 #'self-insert-command)
+ (setq from (1+ from))))))
+ (funcall f #o040 #o0177)
+ (when (eq system-type 'ms-dos) ;FIXME: Why?
+ (funcall f #o0200 #o0240))
+ (funcall f #o0240 #o0400))
+
+ (define-key map "\C-a" #'beginning-of-line)
+ (define-key map "\C-b" #'backward-char)
+ (define-key map "\C-e" #'end-of-line)
+ (define-key map "\C-f" #'forward-char)
+
+ (define-key map "\C-z" #'suspend-emacs) ;FIXME: Re-bound later!
+ (define-key map "\C-x\C-z" #'suspend-emacs) ;FIXME: Re-bound later!
+
+ (define-key map "\C-v" #'scroll-up-command)
+ (define-key map "\M-v" #'scroll-down-command)
+ (define-key map "\M-\C-v" #'scroll-other-window)
+
+ (define-key map "\M-\C-c" #'exit-recursive-edit)
+ (define-key map "\C-]" #'abort-recursive-edit)
+ map)
+ "Default global keymap mapping Emacs keyboard input into commands.
+The value is a keymap that is usually (but not necessarily) Emacs's
+global map.
+
+See also `current-global-map'.")
+(use-global-map global-map)
;;;; Event manipulation functions.
@@ -1278,10 +1407,10 @@ The normal global definition of the character C-x indirects to this keymap.")
"Convert a key sequence to a list of events."
(if (vectorp key)
(append key nil)
- (mapcar (function (lambda (c)
- (if (> c 127)
- (logxor c listify-key-sequence-1)
- c)))
+ (mapcar (lambda (c)
+ (if (> c 127)
+ (logxor c listify-key-sequence-1)
+ c))
key)))
(defun eventp (object)
@@ -1363,7 +1492,8 @@ EVENT is nil, the value of `posn-at-point' is used instead.
The following accessor functions are used to access the elements
of the position:
-`posn-window': The window the event is in.
+`posn-window': The window of the event end, or its frame if the
+event end point belongs to no window.
`posn-area': A symbol identifying the area the event occurred in,
or nil if the event occurred in the text area.
`posn-point': The buffer position of the event.
@@ -1419,8 +1549,9 @@ than a window, return nil."
(defsubst posn-window (position)
"Return the window in POSITION.
-POSITION should be a list of the form returned by the `event-start'
-and `event-end' functions."
+If POSITION is outside the frame where the event was initiated,
+return that frame instead. POSITION should be a list of the form
+returned by the `event-start' and `event-end' functions."
(nth 0 position))
(defsubst posn-area (position)
@@ -1447,9 +1578,14 @@ a click on a scroll bar)."
(defun posn-set-point (position)
"Move point to POSITION.
Select the corresponding window as well."
- (if (not (windowp (posn-window position)))
+ (if (framep (posn-window position))
+ (progn
+ (unless (windowp (frame-selected-window (posn-window position)))
+ (error "Position not in text area of window"))
+ (select-window (frame-selected-window (posn-window position))))
+ (unless (windowp (posn-window position))
(error "Position not in text area of window"))
- (select-window (posn-window position))
+ (select-window (posn-window position)))
(if (numberp (posn-point position))
(goto-char (posn-point position))))
@@ -1558,10 +1694,15 @@ The return value has the form (WIDTH . HEIGHT). POSITION should
be a list of the form returned by `event-start' and `event-end'."
(nth 9 position))
+(defun values--store-value (value)
+ "Store VALUE in the obsolete `values' variable."
+ (with-suppressed-warnings ((obsolete values))
+ (push value values))
+ value)
+
;;;; Obsolescent names for functions.
-(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
(make-obsolete 'buffer-has-markers-at nil "24.3")
(make-obsolete 'invocation-directory "use the variable of the same name."
@@ -1598,17 +1739,15 @@ be a list of the form returned by `event-start' and `event-end'."
;;;; Obsolescence declarations for variables, and aliases.
-(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-variable 'redisplay-dont-pause nil "24.5")
(make-obsolete 'window-redisplay-end-trigger nil "23.1")
(make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
+(make-obsolete-variable 'operating-system-release nil "28.1")
(make-obsolete 'run-window-configuration-change-hook nil "27.1")
-(make-obsolete 'process-filter-multibyte-p nil "23.1")
-(make-obsolete 'set-process-filter-multibyte nil "23.1")
(make-obsolete-variable 'command-debug-status
"expect it to be removed in a future version." "25.2")
@@ -1622,33 +1761,47 @@ be a list of the form returned by `event-start' and `event-end'."
(make-obsolete-variable 'x-gtk-use-window-move nil "26.1")
(defvaralias 'messages-buffer-max-lines 'message-log-max)
-(define-obsolete-variable-alias 'inhibit-null-byte-detection
- 'inhibit-nul-byte-detection "27.1")
+(define-obsolete-variable-alias 'inhibit-nul-byte-detection
+ 'inhibit-null-byte-detection "28.1")
+(make-obsolete-variable 'load-dangerous-libraries
+ "no longer used." "27.1")
+
+(defvar inhibit--record-char nil
+ "Obsolete variable.
+This was used internally by quail.el and keyboard.c in Emacs 27.
+It does nothing in Emacs 28.")
+(make-obsolete-variable 'inhibit--record-char nil "28.1")
+
+;; We can't actually make `values' obsolete, because that will result
+;; in warnings when using `values' in let-bindings.
+;;(make-obsolete-variable 'values "no longer used" "28.1")
+
;;;; Alternate names for functions - these are not being phased out.
-(defalias 'send-string 'process-send-string)
-(defalias 'send-region 'process-send-region)
-(defalias 'string= 'string-equal)
-(defalias 'string< 'string-lessp)
-(defalias 'string> 'string-greaterp)
-(defalias 'move-marker 'set-marker)
-(defalias 'rplaca 'setcar)
-(defalias 'rplacd 'setcdr)
-(defalias 'beep 'ding) ;preserve lingual purity
-(defalias 'indent-to-column 'indent-to)
-(defalias 'backward-delete-char 'delete-backward-char)
+(defalias 'send-string #'process-send-string)
+(defalias 'send-region #'process-send-region)
+(defalias 'string= #'string-equal)
+(defalias 'string< #'string-lessp)
+(defalias 'string> #'string-greaterp)
+(defalias 'move-marker #'set-marker)
+(defalias 'rplaca #'setcar)
+(defalias 'rplacd #'setcdr)
+(defalias 'beep #'ding) ;preserve lingual purity
+(defalias 'indent-to-column #'indent-to)
+(defalias 'backward-delete-char #'delete-backward-char)
(defalias 'search-forward-regexp (symbol-function 're-search-forward))
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
-(defalias 'int-to-string 'number-to-string)
-(defalias 'store-match-data 'set-match-data)
-(defalias 'chmod 'set-file-modes)
-(defalias 'mkdir 'make-directory)
+(defalias 'int-to-string #'number-to-string)
+(defalias 'store-match-data #'set-match-data)
+(defalias 'chmod #'set-file-modes)
+(defalias 'mkdir #'make-directory)
;; These are the XEmacs names:
-(defalias 'point-at-eol 'line-end-position)
-(defalias 'point-at-bol 'line-beginning-position)
+(defalias 'point-at-eol #'line-end-position)
+(defalias 'point-at-bol #'line-beginning-position)
-(defalias 'user-original-login-name 'user-login-name)
+(define-obsolete-function-alias 'user-original-login-name
+ #'user-login-name "28.1")
;;;; Hook manipulation functions.
@@ -1677,9 +1830,15 @@ This makes the hook buffer-local, and it makes t a member of the
buffer-local value. That acts as a flag to run the hook
functions of the global value as well as in the local value.
-HOOK should be a symbol, and FUNCTION may be any valid function. If
-HOOK is void, it is first set to nil. If HOOK's value is a single
-function, it is changed to a list of functions."
+HOOK should be a symbol. If HOOK is void, it is first set to
+nil. If HOOK's value is a single function, it is changed to a
+list of functions.
+
+FUNCTION may be any valid function, but it's recommended to use a
+function symbol and not a lambda form. Using a symbol will
+ensure that the function is not re-added if the function is
+edited, and using lambda forms may also have a negative
+performance impact when running `add-hook' and `remove-hook'."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
(unless (numberp depth) (setq depth (if depth 90 0)))
@@ -1697,12 +1856,13 @@ function, it is changed to a list of functions."
(unless (member function hook-value)
(when (stringp function) ;FIXME: Why?
(setq function (purecopy function)))
+ ;; All those `equal' tests performed between functions can end up being
+ ;; costly since those functions may be large recursive and even cyclic
+ ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326)
(when (or (get hook 'hook--depth-alist) (not (zerop depth)))
;; Note: The main purpose of the above `when' test is to avoid running
;; this `setf' before `gv' is loaded during bootstrap.
- (setf (alist-get function (get hook 'hook--depth-alist)
- 0 'remove #'equal)
- depth))
+ (push (cons function depth) (get hook 'hook--depth-alist)))
(setq hook-value
(if (< 0 depth)
(append hook-value (list function))
@@ -1712,8 +1872,8 @@ function, it is changed to a list of functions."
(setq hook-value
(sort (if (< 0 depth) hook-value (copy-sequence hook-value))
(lambda (f1 f2)
- (< (alist-get f1 depth-alist 0 nil #'equal)
- (alist-get f2 depth-alist 0 nil #'equal))))))))
+ (< (alist-get f1 depth-alist 0 nil #'eq)
+ (alist-get f2 depth-alist 0 nil #'eq))))))))
;; Set the actual variable
(if local
(progn
@@ -1734,7 +1894,36 @@ FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
list of hooks to run in HOOK, then nothing is done. See `add-hook'.
The optional third argument, LOCAL, if non-nil, says to modify
-the hook's buffer-local value rather than its default value."
+the hook's buffer-local value rather than its default value.
+
+Interactively, prompt for the various arguments (skipping local
+unless HOOK has both local and global functions). If multiple
+functions have the same representation under `princ', the first
+one will be removed."
+ (interactive
+ (let* ((default (and (symbolp (variable-at-point))
+ (symbol-name (variable-at-point))))
+ (hook (intern (completing-read
+ (format-prompt "Hook variable" default)
+ obarray #'boundp t nil nil default)))
+ (local
+ (and
+ (local-variable-p hook)
+ (symbol-value hook)
+ ;; No need to prompt if there's nothing global
+ (or (not (default-value hook))
+ (y-or-n-p (format "%s has a buffer-local binding, use that? "
+ hook)))))
+ (fn-alist (mapcar
+ (lambda (x) (cons (with-output-to-string (prin1 x)) x))
+ (if local (symbol-value hook) (default-value hook))))
+ (function (alist-get (completing-read
+ (format "%s hook to remove: "
+ (if local "Buffer-local" "Global"))
+ fn-alist
+ nil t)
+ fn-alist nil nil #'string=)))
+ (list hook function local)))
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
;; Do nothing if LOCAL is t but this hook has no local binding.
@@ -1745,11 +1934,21 @@ the hook's buffer-local value rather than its default value."
(not (and (consp (symbol-value hook))
(memq t (symbol-value hook)))))
(setq local t))
- (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook)))
+ (old-fun nil))
;; Remove the function, for both the list and the non-list cases.
(if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (if (equal hook-value function) (setq hook-value nil))
- (setq hook-value (delete function (copy-sequence hook-value))))
+ (when (equal hook-value function)
+ (setq old-fun hook-value)
+ (setq hook-value nil))
+ (when (setq old-fun (car (member function hook-value)))
+ (setq hook-value (remq old-fun hook-value))))
+ (when old-fun
+ ;; Remove auxiliary depth info to avoid leaks (bug#46414)
+ ;; and to avoid the list growing too long.
+ (let* ((depths (get hook 'hook--depth-alist))
+ (di (assq old-fun depths)))
+ (when di (put hook 'hook--depth-alist (delq di depths)))))
;; If the function is on the global hook, we need to shadow it locally
;;(when (and local (member function (default-value hook))
;; (not (member (cons 'not function) hook-value)))
@@ -1773,9 +1972,48 @@ all symbols are bound before any of the VALUEFORMs are evalled."
;; 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))
+ ;; Use plain `let*' for the non-recursive definitions.
+ ;; This only handles the case where the first few definitions are not
+ ;; recursive. Nothing as fancy as an SCC analysis.
+ (let ((seqbinds nil))
+ ;; Our args haven't yet been macro-expanded, so `macroexp--fgrep'
+ ;; may fail to see references that will be introduced later by
+ ;; macroexpansion. We could call `macroexpand-all' to avoid that,
+ ;; but in order to avoid that, we instead check to see if the binders
+ ;; appear in the macroexp environment, since that's how references can be
+ ;; introduced later on.
+ (unless (macroexp--fgrep binders macroexpand-all-environment)
+ (while (and binders
+ (null (macroexp--fgrep binders (nth 1 (car binders)))))
+ (push (pop binders) seqbinds)))
+ (let ((nbody (if (null binders)
+ (macroexp-progn body)
+ `(let ,(mapcar #'car binders)
+ ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+ ,@body))))
+ (cond
+ ;; All bindings are recursive.
+ ((null seqbinds) nbody)
+ ;; Special case for trivial uses.
+ ((and (symbolp nbody) (null (cdr seqbinds)) (eq nbody (caar seqbinds)))
+ (nth 1 (car seqbinds)))
+ ;; General case.
+ (t `(let* ,(nreverse seqbinds) ,nbody))))))
+
+(defmacro dlet (binders &rest body)
+ "Like `let' but using dynamic scoping."
+ (declare (indent 1) (debug let))
+ ;; (defvar FOO) only affects the current scope, but in order for
+ ;; this not to affect code after the main `let' we need to create a new scope,
+ ;; which is what the surrounding `let' is for.
+ ;; FIXME: (let () ...) currently doesn't actually create a new scope,
+ ;; which is why we use (let (_) ...).
+ `(let (_)
+ ,@(mapcar (lambda (binder)
+ `(defvar ,(if (consp binder) (car binder) binder)))
+ binders)
+ (let ,binders ,@body)))
+
(defmacro with-wrapper-hook (hook args &rest body)
"Run BODY, using wrapper functions from HOOK with additional ARGS.
@@ -1807,6 +2045,7 @@ FUN is then called once."
(defmacro subr--with-wrapper-hook-no-warnings (hook args &rest body)
"Like (with-wrapper-hook HOOK ARGS BODY), but without warnings."
+ (declare (debug (form sexp def-body)))
;; We need those two gensyms because CL's lexical scoping is not available
;; for function arguments :-(
(let ((funs (make-symbol "funs"))
@@ -1897,7 +2136,7 @@ can do the job."
,(if append
`(setq ,sym (append ,sym (list ,x)))
`(push ,x ,sym))))))
- (if (not (macroexp--compiling-p))
+ (if (not (macroexp-compiling-p))
code
`(progn
(macroexp--funcall-if-compiled ',warnfun)
@@ -1905,9 +2144,9 @@ can do the job."
(if (cond
((null compare-fn)
(member element (symbol-value list-var)))
- ((eq compare-fn 'eq)
+ ((eq compare-fn #'eq)
(memq element (symbol-value list-var)))
- ((eq compare-fn 'eql)
+ ((eq compare-fn #'eql)
(memql element (symbol-value list-var)))
(t
(let ((lst (symbol-value list-var)))
@@ -1926,9 +2165,8 @@ can do the job."
"Add ELEMENT to the value of LIST-VAR if it isn't there yet.
The test for presence of ELEMENT is done with `eq'.
-The resulting list is reordered so that the elements are in the
-order given by each element's numeric list order. Elements
-without a numeric list order are placed at the end of the list.
+The value of LIST-VAR is kept ordered based on the ORDER
+parameter.
If the third optional argument ORDER is a number (integer or
float), set the element's list order to the given value. If
@@ -2062,9 +2300,13 @@ Affects only hooks run in the current buffer."
;; PUBLIC: find if the current mode derives from another.
(defun provided-mode-derived-p (mode &rest modes)
- "Non-nil if MODE is derived from one of MODES or their aliases.
+ "Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
If you just want to check `major-mode', use `derived-mode-p'."
+ ;; If MODE is an alias, then look up the real mode function first.
+ (when-let ((alias (symbol-function mode)))
+ (when (symbolp alias)
+ (setq mode alias)))
(while
(and
(not (memq mode modes))
@@ -2122,7 +2364,8 @@ tho trying to avoid AVOIDED-MODES."
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
"Register a new minor mode.
-This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
+This function shouldn't be used directly -- use `define-minor-mode'
+instead (which will then call this function).
TOGGLE is a symbol that is the name of a buffer-local variable that
is toggled on or off to say whether the minor mode is active or not.
@@ -2242,7 +2485,11 @@ file name without extension.
If TYPE is nil, then any kind of definition is acceptable. If
TYPE is `defun', `defvar', or `defface', that specifies function
definition, variable definition, or face definition only.
-Otherwise TYPE is assumed to be a symbol property."
+Otherwise TYPE is assumed to be a symbol property.
+
+This function only works for symbols defined in Lisp files. For
+symbols that are defined in C files, use `help-C-file-name'
+instead."
(if (and (or (null type) (eq type 'defun))
(symbolp symbol)
(autoloadp (symbol-function symbol)))
@@ -2266,6 +2513,8 @@ Otherwise TYPE is assumed to be a symbol property."
(not (eq 'require (car match)))))))
(throw 'found file))))))
+(declare-function read-library-name "find-func" nil)
+
(defun locate-library (library &optional nosuffix path interactive-call)
"Show the precise file name of Emacs library LIBRARY.
LIBRARY should be a relative file name of the library, a string.
@@ -2282,12 +2531,7 @@ is used instead of `load-path'.
When called from a program, the file name is normally returned as a
string. When run interactively, the argument INTERACTIVE-CALL is t,
and the file name is displayed in the echo area."
- (interactive (list (completing-read "Locate library: "
- (apply-partially
- 'locate-file-completion-table
- load-path (get-load-suffixes)))
- nil nil
- t))
+ (interactive (list (read-library-name) nil nil t))
(let ((file (locate-file library
(or path load-path)
(append (unless nosuffix (get-load-suffixes))
@@ -2330,13 +2574,19 @@ use `start-file-process'."
(if program
(list :command (cons program program-args))))))
-(defun process-lines (program &rest args)
+(defun process-lines-handling-status (program status-handler &rest args)
"Execute PROGRAM with ARGS, returning its output as a list of lines.
-Signal an error if the program returns with a non-zero exit status."
+If STATUS-HANDLER is non-nil, it must be a function with one
+argument, which will be called with the exit status of the
+program before the output is collected. If STATUS-HANDLER is
+nil, an error is signaled if the program returns with a non-zero
+exit status."
(with-temp-buffer
- (let ((status (apply 'call-process program nil (current-buffer) nil args)))
- (unless (eq status 0)
- (error "%s exited with status %s" program status))
+ (let ((status (apply #'call-process program nil (current-buffer) nil args)))
+ (if status-handler
+ (funcall status-handler status)
+ (unless (eq status 0)
+ (error "%s exited with status %s" program status)))
(goto-char (point-min))
(let (lines)
(while (not (eobp))
@@ -2347,6 +2597,18 @@ Signal an error if the program returns with a non-zero exit status."
(forward-line 1))
(nreverse lines)))))
+(defun process-lines (program &rest args)
+ "Execute PROGRAM with ARGS, returning its output as a list of lines.
+Signal an error if the program returns with a non-zero exit status.
+Also see `process-lines-ignore-status'."
+ (apply #'process-lines-handling-status program nil args))
+
+(defun process-lines-ignore-status (program &rest args)
+ "Execute PROGRAM with ARGS, returning its output as a list of lines.
+The exit status of the program is ignored.
+Also see `process-lines'."
+ (apply #'process-lines-handling-status program #'ignore args))
+
(defun process-live-p (process)
"Return non-nil if PROCESS is alive.
A process is considered alive if its status is `run', `open',
@@ -2366,7 +2628,7 @@ process."
(format "Buffer %S has a running process; kill it? "
(buffer-name (current-buffer)))))))
-(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function)
+(add-hook 'kill-buffer-query-functions #'process-kill-buffer-query-function)
;; process plist management
@@ -2388,23 +2650,52 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'."
;;;; Input and display facilities.
-(defconst read-key-empty-map (make-sparse-keymap))
+;; The following maps are used by `read-key' to remove all key
+;; bindings while calling `read-key-sequence'. This way the keys
+;; returned are independent of the key binding state.
+
+(defconst read-key-empty-map (make-sparse-keymap)
+ "Used internally by `read-key'.")
+
+(defconst read-key-full-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [t] 'dummy)
+
+ ;; ESC needs to be unbound so that escape sequences in
+ ;; `input-decode-map' are still processed by `read-key-sequence'.
+ (define-key map [?\e] nil)
+ map)
+ "Used internally by `read-key'.")
(defvar read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully.
-(defun read-key (&optional prompt)
+(defun read-key (&optional prompt disable-fallbacks)
"Read a key from the keyboard.
Contrary to `read-event' this will not return a raw event but instead will
obey the input decoding and translations usually done by `read-key-sequence'.
So escape sequences and keyboard encoding are taken into account.
When there's an ambiguity because the key looks like the prefix of
-some sort of escape sequence, the ambiguity is resolved via `read-key-delay'."
+some sort of escape sequence, the ambiguity is resolved via `read-key-delay'.
+
+If the optional argument PROMPT is non-nil, display that as a
+prompt.
+
+If the optional argument DISABLE-FALLBACKS is non-nil, all
+unbound fallbacks usually done by `read-key-sequence' are
+disabled such as discarding mouse down events. This is generally
+what you want as `read-key' temporarily removes all bindings
+while calling `read-key-sequence'. If nil or unspecified, the
+only unbound fallback disabled is downcasing of the last event."
;; This overriding-terminal-local-map binding also happens to
;; disable quail's input methods, so although read-key-sequence
;; always inherits the input method, in practice read-key does not
;; inherit the input method (at least not if it's based on quail).
(let ((overriding-terminal-local-map nil)
- (overriding-local-map read-key-empty-map)
+ (overriding-local-map
+ ;; FIXME: Audit existing uses of `read-key' to see if they
+ ;; should always specify disable-fallbacks to be more in line
+ ;; with `read-event'.
+ (if disable-fallbacks read-key-full-map read-key-empty-map))
(echo-keystrokes 0)
(old-global-map (current-global-map))
(timer (run-with-idle-timer
@@ -2458,6 +2749,23 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'."
(message nil)
(use-global-map old-global-map))))
+;; FIXME: Once there's a safe way to transition away from read-event,
+;; callers to this function should be updated to that way and this
+;; function should be deleted.
+(defun read--potential-mouse-event ()
+ "Read an event that might be a mouse event.
+
+This function exists for backward compatibility in code packaged
+with Emacs. Do not call it directly in your own packages."
+ ;; `xterm-mouse-mode' events must go through `read-key' as they
+ ;; are decoded via `input-decode-map'.
+ (if xterm-mouse-mode
+ (read-key nil
+ ;; Normally `read-key' discards all mouse button
+ ;; down events. However, we want them here.
+ t)
+ (read-event)))
+
(defvar read-passwd-map
;; BEWARE: `defconst' would purecopy it, breaking the sharing with
;; minibuffer-local-map along the way!
@@ -2508,7 +2816,7 @@ by doing (clear-string STRING)."
(use-local-map read-passwd-map)
(setq-local inhibit-modification-hooks nil) ;bug#15501.
(setq-local show-paren-mode nil) ;bug#16091.
- (add-hook 'post-command-hook 'read-password--hide-password nil t))
+ (add-hook 'post-command-hook #'read-password--hide-password nil t))
(unwind-protect
(let ((enable-recursive-minibuffers t)
(read-hide-char (or read-hide-char ?*)))
@@ -2518,33 +2826,38 @@ by doing (clear-string STRING)."
;; Not sure why but it seems that there might be cases where the
;; minibuffer is not always properly reset later on, so undo
;; whatever we've done here (bug#11392).
- (remove-hook 'after-change-functions 'read-password--hide-password
- 'local)
+ (remove-hook 'after-change-functions
+ #'read-password--hide-password 'local)
(kill-local-variable 'post-self-insert-hook)
;; And of course, don't keep the sensitive data around.
(erase-buffer))))))))
-(defun read-number (prompt &optional default)
+(defvar read-number-history nil
+ "The default history for the `read-number' function.")
+
+(defun read-number (prompt &optional default hist)
"Read a numeric value in the minibuffer, prompting with PROMPT.
DEFAULT specifies a default value to return if the user just types RET.
The value of DEFAULT is inserted into PROMPT.
+HIST specifies a history list variable. See `read-from-minibuffer'
+for details of the HIST argument.
This function is used by the `interactive' code letter `n'."
(let ((n nil)
(default1 (if (consp default) (car default) default)))
(when default1
(setq prompt
(if (string-match "\\(\\):[ \t]*\\'" prompt)
- (replace-match (format " (default %s)" default1) t t prompt 1)
+ (replace-match (format minibuffer-default-prompt-format default1) t t prompt 1)
(replace-regexp-in-string "[ \t]*\\'"
- (format " (default %s) " default1)
+ (format minibuffer-default-prompt-format default1)
prompt t t))))
(while
(progn
(let ((str (read-from-minibuffer
- prompt nil nil nil nil
+ prompt nil nil nil (or hist 'read-number-history)
(when default
(if (consp default)
- (mapcar 'number-to-string (delq nil default))
+ (mapcar #'number-to-string (delq nil default))
(number-to-string default))))))
(condition-case nil
(setq n (cond
@@ -2557,12 +2870,25 @@ This function is used by the `interactive' code letter `n'."
t)))
n))
+(defvar read-char-choice-use-read-key nil
+ "Prefer `read-key' when reading a character by `read-char-choice'.
+Otherwise, use the minibuffer.")
+
(defun read-char-choice (prompt chars &optional inhibit-keyboard-quit)
+ (if (not read-char-choice-use-read-key)
+ (read-char-from-minibuffer prompt chars)
+ (read-char-choice-with-read-key prompt chars inhibit-keyboard-quit)))
+
+(defun read-char-choice-with-read-key (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."
+keyboard-quit events while waiting for a valid input.
+
+If you bind the variable `help-form' to a non-nil value
+while calling this function, then pressing `help-char'
+causes it to evaluate `help-form' and display the result."
(unless (consp chars)
(error "Called `read-char-choice' without valid char choices"))
(let (char done show-help (helpbuf " *Char Help*"))
@@ -2671,6 +2997,15 @@ floating point support."
(push (cons t read) unread-command-events)
nil))))))
+(defun goto-char--read-natnum-interactive (prompt)
+ "Get a natural number argument, optionally prompting with PROMPT.
+If there is a natural number at point, use it as default."
+ (if (and current-prefix-arg (not (consp current-prefix-arg)))
+ (list (prefix-numeric-value current-prefix-arg))
+ (let* ((number (number-at-point))
+ (default (and (natnump number) number)))
+ (list (read-number prompt (list default (point)))))))
+
(defvar read-char-history nil
"The default history for the `read-char-from-minibuffer' function.")
@@ -2679,19 +3014,19 @@ floating point support."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
- (define-key map [remap self-insert-command] 'read-char-from-minibuffer-insert-char)
+ (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char)
- (define-key map [remap recenter-top-bottom] 'minibuffer-recenter-top-bottom)
- (define-key map [remap scroll-up-command] 'minibuffer-scroll-up-command)
- (define-key map [remap scroll-down-command] 'minibuffer-scroll-down-command)
- (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window)
- (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down)
+ (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom)
+ (define-key map [remap scroll-up-command] #'minibuffer-scroll-up-command)
+ (define-key map [remap scroll-down-command] #'minibuffer-scroll-down-command)
+ (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window)
+ (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down)
map)
"Keymap for the `read-char-from-minibuffer' function.")
(defconst read-char-from-minibuffer-map-hash
- (make-hash-table :weakness 'key :test 'equal))
+ (make-hash-table :test 'equal))
(defun read-char-from-minibuffer-insert-char ()
"Insert the character you type in the minibuffer and exit.
@@ -2714,8 +3049,6 @@ Also discard all previous input in the minibuffer."
(minibuffer-message "Wrong answer")
(sit-for 2)))
-(defvar empty-history)
-
(defun read-char-from-minibuffer (prompt &optional chars history)
"Read a character from the minibuffer, prompting for it with PROMPT.
Like `read-char', but uses the minibuffer to read and return a character.
@@ -2724,20 +3057,38 @@ the function will ignore any input that is not one of CHARS.
Optional argument HISTORY, if non-nil, should be a symbol that
specifies the history list variable to use for navigating in input
history using `M-p' and `M-n', with `RET' to select a character from
-history."
+history.
+If you bind the variable `help-form' to a non-nil value
+while calling this function, then pressing `help-char'
+causes it to evaluate `help-form' and display the result.
+There is no need to explicitly add `help-char' to CHARS;
+`help-char' is bound automatically to `help-form-show'."
+ (defvar empty-history)
(let* ((empty-history '())
(map (if (consp chars)
- (or (gethash chars read-char-from-minibuffer-map-hash)
- (puthash chars
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map read-char-from-minibuffer-map)
- (dolist (char chars)
- (define-key map (vector char)
- 'read-char-from-minibuffer-insert-char))
- (define-key map [remap self-insert-command]
- 'read-char-from-minibuffer-insert-other)
- map)
- read-char-from-minibuffer-map-hash))
+ (or (gethash (list help-form (cons help-char chars))
+ read-char-from-minibuffer-map-hash)
+ (let ((map (make-sparse-keymap))
+ (msg help-form))
+ (set-keymap-parent map read-char-from-minibuffer-map)
+ ;; If we have a dynamically bound `help-form'
+ ;; here, then the `C-h' (i.e., `help-char')
+ ;; character should output that instead of
+ ;; being a command char.
+ (when help-form
+ (define-key map (vector help-char)
+ (lambda ()
+ (interactive)
+ (let ((help-form msg)) ; lexically bound msg
+ (help-form-show)))))
+ (dolist (char chars)
+ (define-key map (vector char)
+ #'read-char-from-minibuffer-insert-char))
+ (define-key map [remap self-insert-command]
+ #'read-char-from-minibuffer-insert-other)
+ (puthash (list help-form (cons help-char chars))
+ map read-char-from-minibuffer-map-hash)
+ map))
read-char-from-minibuffer-map))
;; Protect this-command when called from pre-command-hook (bug#45029)
(this-command this-command)
@@ -2767,26 +3118,26 @@ history."
(set-keymap-parent map minibuffer-local-map)
(dolist (symbol '(act act-and-show act-and-exit automatic))
- (define-key map (vector 'remap symbol) 'y-or-n-p-insert-y))
+ (define-key map (vector 'remap symbol) #'y-or-n-p-insert-y))
- (define-key map [remap skip] 'y-or-n-p-insert-n)
+ (define-key map [remap skip] #'y-or-n-p-insert-n)
- (dolist (symbol '(help backup undo undo-all edit edit-replacement
+ (dolist (symbol '(backup undo undo-all edit edit-replacement
delete-and-edit ignore self-insert-command))
- (define-key map (vector 'remap symbol) 'y-or-n-p-insert-other))
+ (define-key map (vector 'remap symbol) #'y-or-n-p-insert-other))
- (define-key map [remap recenter] 'minibuffer-recenter-top-bottom)
- (define-key map [remap scroll-up] 'minibuffer-scroll-up-command)
- (define-key map [remap scroll-down] 'minibuffer-scroll-down-command)
- (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window)
- (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down)
+ (define-key map [remap recenter] #'minibuffer-recenter-top-bottom)
+ (define-key map [remap scroll-up] #'minibuffer-scroll-up-command)
+ (define-key map [remap scroll-down] #'minibuffer-scroll-down-command)
+ (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window)
+ (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down)
- (define-key map [escape] 'abort-recursive-edit)
+ (define-key map [escape] #'abort-recursive-edit)
(dolist (symbol '(quit exit exit-prefix))
- (define-key map (vector 'remap symbol) 'abort-recursive-edit))
+ (define-key map (vector 'remap symbol) #'abort-recursive-edit))
;; FIXME: try catch-all instead of explicit bindings:
- ;; (define-key map [remap t] 'y-or-n-p-insert-other)
+ ;; (define-key map [remap t] #'y-or-n-p-insert-other)
map)
"Keymap that defines additional bindings for `y-or-n-p' answers.")
@@ -2821,7 +3172,9 @@ Also discard all previous input in the minibuffer."
(minibuffer-message "Please answer y or n")
(sit-for 2)))
-(defvar empty-history)
+(defvar y-or-n-p-use-read-key nil
+ "Prefer `read-key' when answering a \"y or n\" question by `y-or-n-p'.
+Otherwise, use the minibuffer.")
(defun y-or-n-p (prompt)
"Ask user a \"y or n\" question.
@@ -2829,6 +3182,12 @@ Return t if answer is \"y\" and nil if it is \"n\".
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.
+If you bind the variable `help-form' to a non-nil value
+while calling this function, then pressing `help-char'
+causes it to evaluate `help-form' and display the result.
+PROMPT is also updated to show `help-char' like \"(y, n or C-h) \",
+where `help-char' is automatically bound to `help-form-show'.
+
No confirmation of the answer is requested; a single character is
enough. SPC also means yes, and DEL means no.
@@ -2851,7 +3210,13 @@ is nil and `use-dialog-box' is non-nil."
(concat prompt
(if (or (zerop l) (eq ?\s (aref prompt (1- l))))
"" " ")
- (if dialog "" "(y or n) "))))))
+ (if dialog ""
+ (if help-form
+ (format "(y, n or %s) "
+ (key-description
+ (vector help-char)))
+ "(y or n) "
+ )))))))
(cond
(noninteractive
(setq prompt (funcall padded prompt))
@@ -2860,6 +3225,7 @@ is nil and `use-dialog-box' is non-nil."
(let ((str (read-string temp-prompt)))
(cond ((member str '("y" "Y")) (setq answer 'act))
((member str '("n" "N")) (setq answer 'skip))
+ ((and (member str '("h" "H")) help-form) (print help-form))
(t (setq temp-prompt (concat "Please answer y or n. "
prompt))))))))
((and (display-popup-menus-p)
@@ -2868,16 +3234,62 @@ is nil and `use-dialog-box' is non-nil."
use-dialog-box)
(setq prompt (funcall padded prompt t)
answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
+ (y-or-n-p-use-read-key
+ ;; ¡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.
+ (setq prompt (funcall padded prompt))
+ (while
+ (let* ((scroll-actions '(recenter scroll-up scroll-down
+ scroll-other-window scroll-other-window-down))
+ (key
+ (let ((cursor-in-echo-area t))
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame (minibuffer-window))))
+ (read-key (propertize (if (memq answer scroll-actions)
+ 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)
+ ((eq answer 'scroll-up)
+ (ignore-errors (scroll-up-command)) t)
+ ((eq answer 'scroll-down)
+ (ignore-errors (scroll-down-command)) t)
+ ((eq answer 'scroll-other-window)
+ (ignore-errors (scroll-other-window)) t)
+ ((eq answer 'scroll-other-window-down)
+ (ignore-errors (scroll-other-window-down)) t)
+ ((or (memq answer '(exit-prefix quit)) (eq key ?\e))
+ (signal 'quit nil) t)
+ (t t)))
+ (ding)
+ (discard-input)))
(t
(setq prompt (funcall padded prompt))
+ (defvar empty-history)
(let* ((empty-history '())
(enable-recursive-minibuffers t)
+ (msg help-form)
+ (keymap (let ((map (make-composed-keymap
+ y-or-n-p-map query-replace-map)))
+ (when help-form
+ ;; Create a new map before modifying
+ (setq map (copy-keymap map))
+ (define-key map (vector help-char)
+ (lambda ()
+ (interactive)
+ (let ((help-form msg)) ; lexically bound msg
+ (help-form-show)))))
+ map))
;; Protect this-command when called from pre-command-hook (bug#45029)
(this-command this-command)
(str (read-from-minibuffer
- prompt nil
- (make-composed-keymap y-or-n-p-map query-replace-map)
- nil
+ prompt nil keymap nil
(or y-or-n-p-history-variable 'empty-history))))
(setq answer (if (member str '("y" "Y")) 'act 'skip)))))
(let ((ret (eq answer 'act)))
@@ -2957,7 +3369,21 @@ to `accept-change-group' or `cancel-change-group'."
(dolist (elt handle)
(with-current-buffer (car elt)
(if (eq buffer-undo-list t)
- (setq buffer-undo-list nil)))))
+ (setq buffer-undo-list nil)
+ ;; Add a boundary to make sure the upcoming changes won't be
+ ;; merged/combined with any previous changes (bug#33341).
+ ;; We're not supposed to introduce a real (visible)
+ ;; `undo-boundary', tho, so we have to push something else
+ ;; that acts like a boundary w.r.t preventing merges while
+ ;; being harmless.
+ ;; We use for that an "empty insertion", but in order to be harmless,
+ ;; it has to be at a harmless position. Currently only
+ ;; insertions are ever merged/combined, so we use such a "boundary"
+ ;; only when the last change was an insertion and we use the position
+ ;; of the last insertion.
+ (when (numberp (car-safe (car buffer-undo-list)))
+ (push (cons (caar buffer-undo-list) (caar buffer-undo-list))
+ buffer-undo-list))))))
(defun accept-change-group (handle)
"Finish a change group made with `prepare-change-group' (which see).
@@ -3008,7 +3434,7 @@ This finishes the change group by reverting all of its changes."
;; For compatibility.
(define-obsolete-function-alias 'redraw-modeline
- 'force-mode-line-update "24.3")
+ #'force-mode-line-update "24.3")
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
@@ -3063,9 +3489,17 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
o1))
(defun remove-overlays (&optional beg end name val)
- "Clear BEG and END of overlays whose property NAME has value VAL.
-Overlays might be moved and/or split.
-BEG and END default respectively to the beginning and end of buffer."
+ "Remove overlays between BEG and END that have property NAME with value VAL.
+Overlays might be moved and/or split. If any targeted overlays
+start before BEG, the overlays will be altered so that they end
+at BEG. Likewise, if the targeted overlays end after END, they
+will be altered so that they start at END. Overlays that start
+at or after BEG and end before END will be removed completely.
+
+BEG and END default respectively to the beginning and end of the
+buffer.
+Values are compared with `eq'.
+If either NAME or VAL are specified, both should be specified."
;; This speeds up the loops over overlays.
(unless beg (setq beg (point-min)))
(unless end (setq end (point-max)))
@@ -3144,7 +3578,7 @@ When in a major mode that does not provide its own
symbol at point exactly."
(let ((tag (funcall (or find-tag-default-function
(get major-mode 'find-tag-default-function)
- 'find-tag-default))))
+ #'find-tag-default))))
(if tag (regexp-quote tag))))
(defun find-tag-default-as-symbol-regexp ()
@@ -3158,8 +3592,8 @@ symbol at point exactly."
(if (and tag-regexp
(eq (or find-tag-default-function
(get major-mode 'find-tag-default-function)
- 'find-tag-default)
- 'find-tag-default))
+ #'find-tag-default)
+ #'find-tag-default))
(format "\\_<%s\\_>" tag-regexp)
tag-regexp)))
@@ -3214,7 +3648,7 @@ See Info node `(elisp)Security Considerations'."
;; First, quote argument so that CommandLineToArgvW will
;; understand it. See
- ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx
+ ;; https://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
@@ -3417,6 +3851,14 @@ Before insertion, process text properties according to
(insert-buffer-substring buffer start end)
(remove-yank-excluded-properties opoint (point))))
+(defun insert-into-buffer (buffer &optional start end)
+ "Insert the contents of the current buffer into BUFFER.
+If START/END, only insert that region from the current buffer.
+Point in BUFFER will be placed after the inserted text."
+ (let ((current (current-buffer)))
+ (with-current-buffer buffer
+ (insert-buffer-substring current start end))))
+
(defun yank-handle-font-lock-face-property (face start end)
"If `font-lock-defaults' is nil, apply FACE as a `face' property.
START and END denote the start and end of the text to act on.
@@ -3441,7 +3883,7 @@ Do nothing if FACE is nil."
;;;; Synchronous shell commands.
-(defun start-process-shell-command (name buffer &rest args)
+(defun start-process-shell-command (name buffer command)
"Start a program in a subprocess. Return the process object for it.
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.
@@ -3449,27 +3891,18 @@ BUFFER is the buffer (or buffer name) to associate with the process.
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
-COMMAND is the shell command to run.
-
-An old calling convention accepted any number of arguments after COMMAND,
-which were just concatenated to COMMAND. This is still supported but strongly
-discouraged."
- (declare (advertised-calling-convention (name buffer command) "23.1"))
+COMMAND is the shell command to run."
;; We used to use `exec' to replace the shell with the command,
;; but that failed to handle (...) and semicolon, etc.
- (start-process name buffer shell-file-name shell-command-switch
- (mapconcat 'identity args " ")))
+ (start-process name buffer shell-file-name shell-command-switch command))
-(defun start-file-process-shell-command (name buffer &rest args)
+(defun start-file-process-shell-command (name buffer command)
"Start a program in a subprocess. Return the process object for it.
Similar to `start-process-shell-command', but calls `start-file-process'."
- (declare (advertised-calling-convention (name buffer command) "23.1"))
;; On remote hosts, the local `shell-file-name' might be useless.
(with-connection-local-variables
(start-file-process
- name buffer
- shell-file-name shell-command-switch
- (mapconcat 'identity args " "))))
+ name buffer shell-file-name shell-command-switch command)))
(defun call-process-shell-command (command &optional infile buffer display
&rest args)
@@ -3502,7 +3935,7 @@ discouraged."
(call-process shell-file-name
infile buffer display
shell-command-switch
- (mapconcat 'identity (cons command args) " ")))
+ (mapconcat #'identity (cons command args) " ")))
(defun process-file-shell-command (command &optional infile buffer display
&rest args)
@@ -3514,7 +3947,7 @@ Similar to `call-process-shell-command', but calls `process-file'."
(with-connection-local-variables
(process-file
shell-file-name infile buffer display shell-command-switch
- (mapconcat 'identity (cons command args) " "))))
+ (mapconcat #'identity (cons command args) " "))))
(defun call-shell-region (start end command &optional delete buffer)
"Send text from START to END as input to an inferior shell running COMMAND.
@@ -3545,7 +3978,7 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
Within a `track-mouse' form, mouse motion generates input events that
you can read with `read-event'.
Normally, mouse motion is ignored."
- (declare (debug t) (indent 0))
+ (declare (debug (def-body)) (indent 0))
`(internal--track-mouse (lambda () ,@body)))
(defmacro with-current-buffer (buffer-or-name &rest body)
@@ -3582,10 +4015,11 @@ also `with-temp-buffer'."
(when (window-live-p (nth 1 state))
(select-window (nth 1 state) 'norecord)))
-(defun generate-new-buffer (name)
+(defun generate-new-buffer (name &optional inhibit-buffer-hooks)
"Create and return a buffer with a name based on NAME.
-Choose the buffer's name using `generate-new-buffer-name'."
- (get-buffer-create (generate-new-buffer-name name)))
+Choose the buffer's name using `generate-new-buffer-name'.
+See `get-buffer-create' for the meaning of INHIBIT-BUFFER-HOOKS."
+ (get-buffer-create (generate-new-buffer-name name) inhibit-buffer-hooks))
(defmacro with-selected-window (window &rest body)
"Execute the forms in BODY with WINDOW as the selected window.
@@ -3747,12 +4181,14 @@ See the related form `with-temp-buffer-window'."
(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.
+The buffer does not run the hooks `kill-buffer-hook',
+`kill-buffer-query-functions', and `buffer-list-update-hook'.
See also `with-temp-buffer'."
(declare (indent 1) (debug t))
(let ((temp-file (make-symbol "temp-file"))
(temp-buffer (make-symbol "temp-buffer")))
`(let ((,temp-file ,file)
- (,temp-buffer (generate-new-buffer " *temp file*")))
+ (,temp-buffer (generate-new-buffer " *temp file*" t)))
(unwind-protect
(prog1
(with-current-buffer ,temp-buffer
@@ -3787,10 +4223,12 @@ Use a MESSAGE of \"\" to temporarily clear the echo area."
(defmacro with-temp-buffer (&rest body)
"Create a temporary buffer, and evaluate BODY there like `progn'.
+The buffer does not run the hooks `kill-buffer-hook',
+`kill-buffer-query-functions', and `buffer-list-update-hook'.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
(let ((temp-buffer (make-symbol "temp-buffer")))
- `(let ((,temp-buffer (generate-new-buffer " *temp*")))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*" t)))
;; `kill-buffer' can change current-buffer in some odd cases.
(with-current-buffer ,temp-buffer
(unwind-protect
@@ -3825,7 +4263,7 @@ of that nature."
(defmacro with-output-to-string (&rest body)
"Execute BODY, return the text it sent to `standard-output', as a string."
(declare (indent 0) (debug t))
- `(let ((standard-output (generate-new-buffer " *string-output*")))
+ `(let ((standard-output (generate-new-buffer " *string-output*" t)))
(unwind-protect
(progn
(let ((standard-output standard-output))
@@ -3854,7 +4292,7 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
;; Don't throw `throw-on-input' on those events by default.
(setq while-no-input-ignore-events
'(focus-in focus-out help-echo iconify-frame
- make-frame-visible selection-request buffer-switch))
+ make-frame-visible selection-request))
(defmacro while-no-input (&rest body)
"Execute BODY only as long as there's no pending input.
@@ -3970,6 +4408,8 @@ the specified region. It must not change
Additionally, the buffer modifications of BODY are recorded on
the buffer's undo list as a single (apply ...) entry containing
the function `undo--wrap-and-run-primitive-undo'."
+ (if (markerp beg) (setq beg (marker-position beg)))
+ (if (markerp end) (setq end (marker-position end)))
(let ((old-bul buffer-undo-list)
(end-marker (copy-marker end t))
result)
@@ -3981,7 +4421,7 @@ the function `undo--wrap-and-run-primitive-undo'."
(let (;; (inhibit-modification-hooks t)
(before-change-functions
;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize
- ;; (e.g. via a regexp-search or sexp-movement trigerring
+ ;; (e.g. via a regexp-search or sexp-movement triggering
;; on-the-fly syntax-propertize), make sure that this gets
;; properly refreshed after subsequent changes.
(if (memq #'syntax-ppss-flush-cache before-change-functions)
@@ -4023,7 +4463,7 @@ the function `undo--wrap-and-run-primitive-undo'."
(defmacro combine-change-calls (beg end &rest body)
"Evaluate BODY, running the change hooks just once.
-BODY is a sequence of lisp forms to evaluate. BEG and END bound
+BODY is a sequence of Lisp forms to evaluate. BEG and END bound
the region the change hooks will be run for.
Firstly, `before-change-functions' is invoked for the region
@@ -4041,7 +4481,8 @@ change `before-change-functions' or `after-change-functions'.
Additionally, the buffer modifications of BODY are recorded on
the buffer's undo list as a single \(apply ...) entry containing
-the function `undo--wrap-and-run-primitive-undo'. "
+the function `undo--wrap-and-run-primitive-undo'."
+ (declare (debug (form form def-body)) (indent 2))
`(combine-change-calls-1 ,beg ,end (lambda () ,@body)))
(defun undo--wrap-and-run-primitive-undo (beg end list)
@@ -4094,8 +4535,6 @@ MODES is as for `set-default-file-modes'."
;;; Matching and match data.
-(defvar save-match-data-internal)
-
;; We use save-match-data-internal as the local variable because
;; that works ok in practice (people should not use that variable elsewhere).
;; We used to use an uninterned symbol; the compiler handles that properly
@@ -4159,11 +4598,7 @@ Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
meaning as for `replace-match'."
(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)))
+ (match-data--translate (- (match-beginning 0)))
(replace-match replacement fixedcase literal match subexp))))
@@ -4396,6 +4831,27 @@ Unless optional argument INPLACE is non-nil, return a new string."
(aset newstr i tochar)))
newstr))
+(defun string-replace (fromstring tostring instring)
+ "Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
+ (declare (pure t) (side-effect-free t))
+ (when (equal fromstring "")
+ (signal 'wrong-length-argument '(0)))
+ (let ((start 0)
+ (result nil)
+ pos)
+ (while (setq pos (string-search fromstring instring start))
+ (unless (= start pos)
+ (push (substring instring start pos) result))
+ (push tostring result)
+ (setq start (+ pos (length fromstring))))
+ (if (null result)
+ ;; No replacements were done, so just return the original string.
+ instring
+ ;; Get any remaining bit.
+ (unless (= start (length instring))
+ (push (substring instring start) result))
+ (apply #'concat (nreverse result)))))
+
(defun replace-regexp-in-string (regexp rep string &optional
fixedcase literal subexp start)
"Replace all matches for REGEXP with REP in STRING.
@@ -4439,10 +4895,9 @@ and replace a sub-expression, e.g.
(when (= me mb) (setq me (min l (1+ mb))))
;; Generate a replacement for the matched substring.
;; Operate on only the substring to minimize string consing.
- ;; Set up match data for the substring for replacement;
- ;; presumably this is likely to be faster than munging the
- ;; match data directly in Lisp.
- (string-match regexp (setq str (substring string mb me)))
+ ;; Translate the match data so that it applies to the matched substring.
+ (match-data--translate (- mb))
+ (setq str (substring string mb me))
(setq matches
(cons (replace-match (if (stringp rep)
rep
@@ -4511,8 +4966,8 @@ FILE, a string, is described in the function `eval-after-load'."
""
;; Note: regexp-opt can't be used here, since we need to call
;; this before Emacs has been fully started. 2006-05-21
- (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?"))
- "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|")
+ (concat "\\(" (mapconcat #'regexp-quote load-suffixes "\\|") "\\)?"))
+ "\\(" (mapconcat #'regexp-quote jka-compr-load-suffixes "\\|")
"\\)?\\'"))
(defun load-history-filename-element (file-regexp)
@@ -4528,7 +4983,6 @@ 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 loaded, FORM will be run immediately afterwards.
If FILE is already loaded, evaluate FORM right now.
@@ -4560,8 +5014,11 @@ file, FORM is evaluated immediately after the provide statement.
Usually FILE is just a library name like \"font-lock\" or a feature name
like `font-lock'.
-This function makes or adds to an entry on `after-load-alist'."
- (declare (compiler-macro
+This function makes or adds to an entry on `after-load-alist'.
+
+See also `with-eval-after-load'."
+ (declare (indent 1)
+ (compiler-macro
(lambda (whole)
(if (eq 'quote (car-safe form))
;; Quote with lambda so the compiler can look inside.
@@ -4599,7 +5056,8 @@ This function makes or adds to an entry on `after-load-alist'."
(funcall func)
(let ((lfn load-file-name)
;; Don't use letrec, because equal (in
- ;; add/remove-hook) would get trapped in a cycle.
+ ;; add/remove-hook) could get trapped in a cycle
+ ;; (bug#46326).
(fun (make-symbol "eval-after-load-helper")))
(fset fun (lambda (file)
(when (equal file lfn)
@@ -4615,7 +5073,7 @@ This function makes or adds to an entry on `after-load-alist'."
FILE is normally a feature name, but it can also be a file name,
in case that file does not provide any feature. See `eval-after-load'
for more details about the different forms of FILE and their semantics."
- (declare (indent 1) (debug t))
+ (declare (indent 1) (debug (form def-body)))
`(eval-after-load ,file (lambda () ,@body)))
(defvar after-load-functions nil
@@ -4642,14 +5100,10 @@ This function is called directly from the C code."
obarray))
(msg (format "Package %s is deprecated" package))
(fun (lambda (msg) (message "%s" msg))))
- ;; Cribbed from cl--compiling-file.
(when (or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete package))
(cond
- ((and (boundp 'byte-compile--outbuffer)
- (bufferp (symbol-value 'byte-compile--outbuffer))
- (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
- " *Compiler Output*"))
+ ((bound-and-true-p byte-compile-current-file)
;; Don't warn about obsolete files using other obsolete files.
(unless (and (stringp byte-compile-current-file)
(string-match-p "/obsolete/[^/]*\\'"
@@ -4663,19 +5117,12 @@ This function is called directly from the C code."
;; Finally, run any other hook.
(run-hook-with-args 'after-load-functions abs-file))
-(defun eval-next-after-load (file)
- "Read the following input sexp, and run it whenever FILE is loaded.
-This makes or adds to an entry on `after-load-alist'.
-FILE should be the name of a library, with no directory name."
- (declare (obsolete eval-after-load "23.2"))
- (eval-after-load file (read)))
-
(defun display-delayed-warnings ()
"Display delayed warnings from `delayed-warnings-list'.
Used from `delayed-warnings-hook' (which see)."
(dolist (warning (nreverse delayed-warnings-list))
- (apply 'display-warning warning))
+ (apply #'display-warning warning))
(setq delayed-warnings-list nil))
(defun collapse-delayed-warnings ()
@@ -5008,7 +5455,7 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
`abortfunc', and `hookvar'."
(put symbol 'composefunc composefunc)
(put symbol 'sendfunc sendfunc)
- (put symbol 'abortfunc (or abortfunc 'kill-buffer))
+ (put symbol 'abortfunc (or abortfunc #'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
@@ -5120,7 +5567,7 @@ command is called from a keyboard macro?"
;; Now `frame' should be "the function from which we were called".
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
- (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
+ (`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) . ,_) . ,_) nil)
;; In case #<subr funcall-interactively> without going through the
;; `funcall-interactively' symbol (bug#3984).
(`(,_ . (t ,(pred (lambda (f)
@@ -5149,6 +5596,8 @@ use `called-interactively-p'.
To test whether a function can be called interactively, use
`commandp'."
+ ;; Kept around for now. See discussion at:
+ ;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html
(declare (obsolete called-interactively-p "23.2"))
(called-interactively-p 'interactive))
@@ -5171,7 +5620,7 @@ To test whether a function can be called interactively, use
(set symbol tail)))))
(define-obsolete-function-alias
- 'set-temporary-overlay-map 'set-transient-map "24.4")
+ 'set-temporary-overlay-map #'set-transient-map "24.4")
(defun set-transient-map (map &optional keep-pred on-exit)
"Set MAP as a temporary keymap taking precedence over other keymaps.
@@ -5196,8 +5645,8 @@ to deactivate this transient map, regardless of KEEP-PRED."
(internal-pop-keymap map 'overriding-terminal-local-map)
(remove-hook 'pre-command-hook clearfun)
(when on-exit (funcall on-exit)))))
- ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
- ;; in a cycle.
+ ;; Don't use letrec, because equal (in add/remove-hook) could get trapped
+ ;; in a cycle. (bug#46326)
(fset clearfun
(lambda ()
(with-demoted-errors "set-transient-map PCH: %S"
@@ -5717,6 +6166,22 @@ This is the simplest safe way to acquire and release a mutex."
(mutex-unlock ,sym)))))
+;;; Apropos.
+
+(defun apropos-internal (regexp &optional predicate)
+ "Show all symbols whose names contain match for REGEXP.
+If optional 2nd arg PREDICATE is non-nil, (funcall PREDICATE SYMBOL) is done
+for each symbol and a symbol is mentioned only if that returns non-nil.
+Return list of symbols found."
+ (let (found)
+ (mapatoms (lambda (symbol)
+ (when (and (string-match regexp (symbol-name symbol))
+ (or (not predicate)
+ (funcall predicate symbol)))
+ (push symbol found))))
+ (sort found #'string-lessp)))
+
+
;;; Misc.
(defvar definition-prefixes (make-hash-table :test 'equal)
@@ -5783,10 +6248,76 @@ returned list are in the same order as in TREE.
;; Technically, `flatten-list' is a misnomer, but we provide it here
;; for discoverability:
-(defalias 'flatten-list 'flatten-tree)
+(defalias 'flatten-list #'flatten-tree)
+
+(defun string-trim-left (string &optional regexp)
+ "Trim STRING of leading string matching REGEXP.
+
+REGEXP defaults to \"[ \\t\\n\\r]+\"."
+ (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
+ (substring string (match-end 0))
+ string))
+
+(defun string-trim-right (string &optional regexp)
+ "Trim STRING of trailing string matching REGEXP.
+
+REGEXP defaults to \"[ \\t\\n\\r]+\"."
+ (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
+ string)))
+ (if i (substring string 0 i) string)))
+
+(defun string-trim (string &optional trim-left trim-right)
+ "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
+
+TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
+ (string-trim-left (string-trim-right string trim-right) trim-left))
;; The initial anchoring is for better performance in searching matches.
(defconst regexp-unmatchable "\\`a\\`"
"Standard regexp guaranteed not to match any string at all.")
+(defun run-hook-query-error-with-timeout (hook)
+ "Run HOOK, catching errors, and querying the user about whether to continue.
+If a function in HOOK signals an error, the user will be prompted
+whether to continue or not. If the user doesn't respond,
+evaluation will continue if the user doesn't respond within five
+seconds."
+ (run-hook-wrapped
+ hook
+ (lambda (fun)
+ (condition-case err
+ (funcall fun)
+ (error
+ (unless (y-or-n-p-with-timeout (format "Error %s; continue?" err)
+ 5 t)
+ (error err))))
+ ;; Continue running.
+ nil)))
+
+(defun internal--fill-string-single-line (str)
+ "Fill string STR to `fill-column'.
+This is intended for very simple filling while bootstrapping
+Emacs itself, and does not support all the customization options
+of fill.el (for example `fill-region')."
+ (if (< (string-width str) fill-column)
+ str
+ (let ((fst (substring str 0 fill-column))
+ (lst (substring str fill-column)))
+ (if (string-match ".*\\( \\(.+\\)\\)$" fst)
+ (setq fst (replace-match "\n\\2" nil nil fst 1)))
+ (concat fst (internal--fill-string-single-line lst)))))
+
+(defun internal--format-docstring-line (string &rest objects)
+ "Format a documentation string out of STRING and OBJECTS.
+This is intended for internal use only."
+ (internal--fill-string-single-line (apply #'format string objects)))
+
+(defun json-available-p ()
+ "Return non-nil if Emacs has libjansson support."
+ (and (fboundp 'json-serialize)
+ (condition-case nil
+ (json-serialize t)
+ (:success t)
+ (json-unavailable nil))))
+
;;; subr.el ends here
diff --git a/lisp/svg.el b/lisp/svg.el
index 4f9f11bd448..05accf4f13f 100644
--- a/lisp/svg.el
+++ b/lisp/svg.el
@@ -5,7 +5,7 @@
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Felix E. Klee <felix.klee@inka.de>
;; Keywords: image
-;; Version: 1.0
+;; Version: 1.1
;; Package-Requires: ((emacs "25"))
;; This file is part of GNU Emacs.
@@ -41,7 +41,7 @@
;; into the buffer:
;;
;; (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5))
-;; (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue"))
+;; (svg-gradient svg "gradient" 'linear '((0 . "red") (100 . "blue")))
;; (save-excursion (goto-char (point-max)) (svg-insert-image svg))
;; Then add various elements to the structure:
@@ -81,7 +81,7 @@ STOPS is a list of percentage/color pairs."
(svg--def
svg
(apply
- 'dom-node
+ #'dom-node
(if (eq type 'linear)
'linearGradient
'radialGradient)
@@ -184,6 +184,19 @@ otherwise. IMAGE-TYPE should be a MIME image type, like
`((xlink:href . ,(svg--image-data image image-type datap))
,@(svg--arguments svg args)))))
+(defun svg-embed-base-uri-image (svg relative-filename &rest args)
+ "Insert image placed at RELATIVE-FILENAME into the SVG structure.
+RELATIVE-FILENAME will be searched in `file-name-directory' of the
+image's `:base-uri' property. If `:base-uri' is not specified for the
+image, then embedding won't work. Embedding large images using this
+function is much faster than `svg-embed'."
+ (svg--append
+ svg
+ (dom-node
+ 'image
+ `((xlink:href . ,relative-filename)
+ ,@(svg--arguments svg args)))))
+
(defun svg-text (svg text &rest args)
"Add TEXT to SVG."
(svg--append
@@ -345,8 +358,7 @@ This is in contrast to merely setting it to 0."
(plist-get command-args :default-relative))))
(intern (if relative (downcase char) (upcase char)))))
-(defun svg--elliptical-arc-coordinates
- (rx ry x y &rest args)
+(defun svg--elliptical-arc-coordinates (rx ry x y &rest args)
(list
rx ry
(or (plist-get args :x-axis-rotation) 0)
@@ -357,21 +369,19 @@ This is in contrast to merely setting it to 0."
(defun svg--elliptical-arc-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'a args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (apply 'svg--elliptical-arc-coordinates
- coordinates))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (apply #'svg--elliptical-arc-coordinates
+ coordinates))
+ coordinates-list)))
(defun svg--moveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'm args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (list (car coordinates) (cdr coordinates)))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (list (car coordinates) (cdr coordinates)))
+ coordinates-list)))
(defun svg--closepath-command (&rest args)
(list (svg--path-command-symbol 'z args)))
@@ -379,11 +389,10 @@ This is in contrast to merely setting it to 0."
(defun svg--lineto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'l args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (list (car coordinates) (cdr coordinates)))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (list (car coordinates) (cdr coordinates)))
+ coordinates-list)))
(defun svg--horizontal-lineto-command (coordinate-list &rest args)
(cons
@@ -398,24 +407,24 @@ This is in contrast to merely setting it to 0."
(defun svg--curveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'c args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--smooth-curveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 's args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--quadratic-bezier-curveto-command (coordinates-list
&rest args)
(cons
(svg--path-command-symbol 'q args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--smooth-quadratic-bezier-curveto-command (coordinates-list
&rest args)
(cons
(svg--path-command-symbol 't args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--eval-path-command (command default-relative)
(cl-letf
@@ -437,7 +446,7 @@ This is in contrast to merely setting it to 0."
#'svg--elliptical-arc-command)
(extended-command (append command (list :default-relative
default-relative))))
- (mapconcat 'prin1-to-string (apply extended-command) " ")))
+ (mapconcat #'prin1-to-string (apply extended-command) " ")))
(defun svg-path (svg commands &rest args)
"Add the outline of a shape to SVG according to COMMANDS.
@@ -446,7 +455,7 @@ modifiers. If :relative is t, then coordinates are relative to
the last position, or -- initially -- to the origin."
(let* ((default-relative (plist-get args :relative))
(stripped-args (svg--plist-delete args :relative))
- (d (mapconcat 'identity
+ (d (mapconcat #'identity
(mapcar
(lambda (command)
(svg--eval-path-command command
diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el
index 30cb9e3303f..ec36f543789 100644
--- a/lisp/t-mouse.el
+++ b/lisp/t-mouse.el
@@ -1,4 +1,4 @@
-;;; t-mouse.el --- mouse support within the text terminal
+;;; t-mouse.el --- mouse support within the text terminal -*- lexical-binding:t -*-
;; Author: Nick Roberts <nickrob@gnu.org>
;; Maintainer: emacs-devel@gnu.org
@@ -63,8 +63,6 @@
(set-terminal-parameter nil 'gpm-mouse-active nil))
;;;###autoload
-(define-obsolete-function-alias 't-mouse-mode 'gpm-mouse-mode "23.1")
-;;;###autoload
(define-minor-mode gpm-mouse-mode
"Toggle mouse support in GNU/Linux consoles (GPM Mouse mode).
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 6693c69ce0c..7459e1b78c2 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -72,6 +72,24 @@
:version "27.1"
:group 'tab-bar-faces)
+(defface tab-bar-tab-group-current
+ '((t :inherit tab-bar-tab :box nil :weight bold))
+ "Tab bar face for current group tab."
+ :version "28.1"
+ :group 'tab-bar-faces)
+
+(defface tab-bar-tab-group-inactive
+ '((t :inherit (shadow tab-bar-tab-inactive)))
+ "Tab bar face for inactive group tab."
+ :version "28.1"
+ :group 'tab-bar-faces)
+
+(defface tab-bar-tab-ungrouped
+ '((t :inherit (shadow tab-bar-tab-inactive)))
+ "Tab bar face for ungrouped tab when tab groups are used."
+ :version "28.1"
+ :group 'tab-bar-faces)
+
(defcustom tab-bar-select-tab-modifiers '()
"List of modifier keys for selecting a tab by its index digit.
@@ -89,29 +107,55 @@ Possible modifier keys are `control', `meta', `shift', `hyper', `super' and
:set (lambda (sym val)
(set-default sym val)
;; Reenable the tab-bar with new keybindings
- (tab-bar-mode -1)
- (tab-bar-mode 1))
+ (when tab-bar-mode
+ (tab-bar--undefine-keys)
+ (tab-bar--define-keys)))
:group 'tab-bar
:version "27.1")
-(define-minor-mode tab-bar-mode
- "Toggle the tab bar in all graphical frames (Tab Bar mode)."
- :global t
- ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
- :variable tab-bar-mode
- (let ((val (if tab-bar-mode 1 0)))
- (dolist (frame (frame-list))
- (set-frame-parameter frame 'tab-bar-lines val))
- ;; If the user has given `default-frame-alist' a `tab-bar-lines'
- ;; parameter, replace it.
- (if (assq 'tab-bar-lines default-frame-alist)
- (setq default-frame-alist
- (cons (cons 'tab-bar-lines val)
- (assq-delete-all 'tab-bar-lines
- default-frame-alist)))))
-
- (when (and tab-bar-mode tab-bar-new-button
+(defun tab-bar--define-keys ()
+ "Install key bindings for switching between tabs if the user has configured them."
+ (when tab-bar-select-tab-modifiers
+ (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0)))
+ 'tab-recent)
+ (dotimes (i 8)
+ (global-set-key (vector (append tab-bar-select-tab-modifiers
+ (list (+ i 1 ?0))))
+ 'tab-bar-select-tab))
+ (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9)))
+ 'tab-last))
+ ;; Don't override user customized key bindings
+ (unless (global-key-binding [(control tab)])
+ (global-set-key [(control tab)] 'tab-next))
+ (unless (global-key-binding [(control shift tab)])
+ (global-set-key [(control shift tab)] 'tab-previous))
+ (unless (global-key-binding [(control shift iso-lefttab)])
+ (global-set-key [(control shift iso-lefttab)] 'tab-previous))
+
+ ;; Replace default value with a condition that supports displaying
+ ;; global-mode-string in the tab bar instead of the mode line.
+ (when (and (memq 'tab-bar-format-global tab-bar-format)
+ (member '(global-mode-string ("" global-mode-string))
+ mode-line-misc-info))
+ (setf (alist-get 'global-mode-string mode-line-misc-info)
+ '(("" (:eval (if (and tab-bar-mode
+ (memq 'tab-bar-format-global
+ tab-bar-format))
+ "" global-mode-string)))))))
+
+(defun tab-bar--undefine-keys ()
+ "Uninstall key bindings previously bound by `tab-bar--define-keys'."
+ (when (eq (global-key-binding [(control tab)]) 'tab-next)
+ (global-unset-key [(control tab)]))
+ (when (eq (global-key-binding [(control shift tab)]) 'tab-previous)
+ (global-unset-key [(control shift tab)]))
+ (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous)
+ (global-unset-key [(control shift iso-lefttab)])))
+
+(defun tab-bar--load-buttons ()
+ "Load the icons for the tab buttons."
+ (when (and tab-bar-new-button
(not (get-text-property 0 'display tab-bar-new-button)))
;; This file is pre-loaded so only here we can use the right data-directory:
(add-text-properties 0 (length tab-bar-new-button)
@@ -121,7 +165,7 @@ Possible modifier keys are `control', `meta', `shift', `hyper', `super' and
:ascent center))
tab-bar-new-button))
- (when (and tab-bar-mode tab-bar-close-button
+ (when (and tab-bar-close-button
(not (get-text-property 0 'display tab-bar-close-button)))
;; This file is pre-loaded so only here we can use the right data-directory:
(add-text-properties 0 (length tab-bar-close-button)
@@ -129,31 +173,56 @@ Possible modifier keys are `control', `meta', `shift', `hyper', `super' and
:file "tabs/close.xpm"
:margin (2 . 0)
:ascent center))
- tab-bar-close-button))
+ tab-bar-close-button)))
+
+(defun tab-bar--tab-bar-lines-for-frame (frame)
+ "Determine and return the value of `tab-bar-lines' for FRAME.
+Return 0 if `tab-bar-mode' is not enabled. Otherwise return
+either 1 or 0 depending on the value of the customizable variable
+`tab-bar-show', which see."
+ (cond
+ ((not tab-bar-mode) 0)
+ ((not tab-bar-show) 0)
+ ((eq tab-bar-show t) 1)
+ ((natnump tab-bar-show)
+ (if (> (length (funcall tab-bar-tabs-function frame)) tab-bar-show) 1 0))))
+
+(defun tab-bar--update-tab-bar-lines (&optional frames)
+ "Update the `tab-bar-lines' frame parameter in FRAMES.
+If the optional parameter FRAMES is omitted, update only
+the currently selected frame. If it is `t', update all frames
+as well as the default for new frames. Otherwise FRAMES should be
+a list of frames to update."
+ (let ((frame-lst (cond ((null frames)
+ (list (selected-frame)))
+ ((eq frames t)
+ (frame-list))
+ (t frames))))
+ ;; Loop over all frames and update `tab-bar-lines'
+ (dolist (frame frame-lst)
+ (unless (frame-parameter frame 'tab-bar-lines-keep-state)
+ (set-frame-parameter frame 'tab-bar-lines
+ (tab-bar--tab-bar-lines-for-frame frame)))))
+ ;; Update `default-frame-alist'
+ (when (eq frames t)
+ (setq default-frame-alist
+ (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0))
+ (assq-delete-all 'tab-bar-lines default-frame-alist)))))
+
+(define-minor-mode tab-bar-mode
+ "Toggle the tab bar in all graphical frames (Tab Bar mode)."
+ :global t
+ ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+ :variable tab-bar-mode
+ ;; Recalculate `tab-bar-lines' for all frames
+ (tab-bar--update-tab-bar-lines t)
+
+ (when tab-bar-mode
+ (tab-bar--load-buttons))
(if tab-bar-mode
- (progn
- (when tab-bar-select-tab-modifiers
- (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0)))
- 'tab-bar-switch-to-recent-tab)
- (dotimes (i 9)
- (global-set-key (vector (append tab-bar-select-tab-modifiers
- (list (+ i 1 ?0))))
- 'tab-bar-select-tab)))
- ;; Don't override user customized key bindings
- (unless (global-key-binding [(control tab)])
- (global-set-key [(control tab)] 'tab-next))
- (unless (global-key-binding [(control shift tab)])
- (global-set-key [(control shift tab)] 'tab-previous))
- (unless (global-key-binding [(control shift iso-lefttab)])
- (global-set-key [(control shift iso-lefttab)] 'tab-previous)))
- ;; Unset only keys bound by tab-bar
- (when (eq (global-key-binding [(control tab)]) 'tab-next)
- (global-unset-key [(control tab)]))
- (when (eq (global-key-binding [(control shift tab)]) 'tab-previous)
- (global-unset-key [(control shift tab)]))
- (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous)
- (global-unset-key [(control shift iso-lefttab)]))))
+ (tab-bar--define-keys)
+ (tab-bar--undefine-keys)))
(defun tab-bar-handle-mouse (event)
"Text-mode emulation of switching tabs on the tab bar.
@@ -181,15 +250,29 @@ on a console which has no window system but does have a mouse."
;; Clicking anywhere outside existing tabs will add a new tab
(tab-bar-new-tab)))))
-;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
(defun toggle-tab-bar-mode-from-frame (&optional arg)
"Toggle tab bar on or off, based on the status of the current frame.
+Used in the Show/Hide menu, to have the toggle reflect the current frame.
See `tab-bar-mode' for more information."
(interactive (list (or current-prefix-arg 'toggle)))
(if (eq arg 'toggle)
(tab-bar-mode (if (> (frame-parameter nil 'tab-bar-lines) 0) 0 1))
(tab-bar-mode arg)))
+(defun toggle-frame-tab-bar (&optional frame)
+ "Toggle tab bar of FRAME.
+This is useful when you want to enable the tab bar individually
+on each new frame when the global `tab-bar-mode' is disabled,
+or when you want to disable the tab bar individually on each
+new frame when the global `tab-bar-mode' is enabled, by using
+
+ (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)"
+ (interactive)
+ (set-frame-parameter frame 'tab-bar-lines
+ (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1))
+ (set-frame-parameter frame 'tab-bar-lines-keep-state
+ (not (frame-parameter frame 'tab-bar-lines-keep-state))))
+
(defvar tab-bar-map (make-sparse-keymap)
"Keymap for the tab bar.
Define this locally to override the global tab bar.")
@@ -218,18 +301,23 @@ If the value is `1', then hide the tab bar when it has only one tab,
and show it again once more tabs are created.
If nil, always keep the tab bar hidden. In this case it's still
possible to use persistent named window configurations by relying on
-keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc."
+keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc.
+
+Setting this variable directly does not take effect; please customize
+it (see the info node `Easy Customization'), then it will automatically
+update the tab bar on all frames according to the new value.
+
+To enable or disable the tab bar individually on each frame,
+you can use the command `toggle-frame-tab-bar'."
:type '(choice (const :tag "Always" t)
(const :tag "When more than one tab" 1)
(const :tag "Never" nil))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
- (tab-bar-mode
- (if (or (eq val t)
- (and (natnump val)
- (> (length (funcall tab-bar-tabs-function)) val)))
- 1 -1)))
+ (if val
+ (tab-bar-mode 1)
+ (tab-bar--update-tab-bar-lines t)))
:group 'tab-bar
:version "27.1")
@@ -253,6 +341,20 @@ before calling the command that adds a new tab."
:group 'tab-bar
:version "27.1")
+(defcustom tab-bar-new-tab-group t
+ "Defines what group to assign to a new tab.
+If nil, don't set a default group automatically.
+If t, inherit the group name from the previous tab.
+If the value is a string, use it as the group name of a new tab.
+If the value is a function, call it with no arguments
+to get the group name."
+ :type '(choice (const :tag "No automatic group" nil)
+ (const :tag "Inherit group from previous tab" t)
+ (string :tag "Fixed group name")
+ (function :tag "Function that returns group name"))
+ :group 'tab-bar
+ :version "28.1")
+
(defcustom tab-bar-new-button-show t
"If non-nil, show the \"New tab\" button in the tab bar.
When this is nil, you can create new tabs with \\[tab-new]."
@@ -296,6 +398,16 @@ If nil, don't show it at all."
(defvar tab-bar-forward-button " > "
"Button for going forward in tab history.")
+(defcustom tab-bar-history-buttons-show t
+ "Show back and forward buttons when `tab-bar-history-mode' is enabled."
+ :type 'boolean
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-bar
+ :version "28.1")
+
(defcustom tab-bar-tab-hints nil
"Show absolute numbers on tabs in the tab bar before the tab name.
This helps to select the tab by its number using `tab-bar-select-tab'
@@ -311,6 +423,9 @@ and `tab-bar-select-tab-modifiers'."
(defvar tab-bar-separator nil
"String that delimits tabs.")
+(defun tab-bar-separator ()
+ (or tab-bar-separator (if window-system " " "|")))
+
(defcustom tab-bar-tab-name-function #'tab-bar-tab-name-current
"Function to get a tab name.
@@ -363,22 +478,18 @@ to `tab-bar-tab-name-truncated'."
:group 'tab-bar
:version "27.1")
-(defvar tab-bar-tab-name-ellipsis nil)
+(defvar tab-bar-tab-name-ellipsis t)
(defun tab-bar-tab-name-truncated ()
"Generate tab name from the buffer of the selected window.
Truncate it to the length specified by `tab-bar-tab-name-truncated-max'.
Append ellipsis `tab-bar-tab-name-ellipsis' in this case."
- (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window))))
- (ellipsis (cond
- (tab-bar-tab-name-ellipsis)
- ((char-displayable-p ?…) "…")
- ("..."))))
+ (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window)))))
(if (< (length tab-name) tab-bar-tab-name-truncated-max)
tab-name
(propertize (truncate-string-to-width
tab-name tab-bar-tab-name-truncated-max nil nil
- ellipsis)
+ tab-bar-tab-name-ellipsis)
'help-echo tab-name))))
@@ -392,13 +503,13 @@ For example, \\='((tab (name . \"Tab 1\")) (current-tab (name . \"Tab 2\")))
By default, use function `tab-bar-tabs'.")
(defun tab-bar-tabs (&optional frame)
- "Return a list of tabs belonging to the selected frame.
+ "Return a list of tabs belonging to the FRAME.
Ensure the frame parameter `tabs' is pre-populated.
Update the current tab name when it exists.
Return its existing value or a new value."
(let ((tabs (frame-parameter frame 'tabs)))
(if tabs
- (let* ((current-tab (assq 'current-tab tabs))
+ (let* ((current-tab (tab-bar--current-tab-find tabs))
(current-tab-name (assq 'name current-tab))
(current-tab-explicit-name (assq 'explicit-name current-tab)))
(when (and current-tab-name
@@ -407,73 +518,257 @@ Return its existing value or a new value."
(setf (cdr current-tab-name)
(funcall tab-bar-tab-name-function))))
;; Create default tabs
- (setq tabs (list (tab-bar--current-tab)))
- (set-frame-parameter frame 'tabs tabs))
+ (setq tabs (list (tab-bar--current-tab-make)))
+ (tab-bar-tabs-set tabs frame))
tabs))
+(defun tab-bar-tabs-set (tabs &optional frame)
+ "Set a list of TABS on the FRAME."
+ (set-frame-parameter frame 'tabs tabs))
+
+(defcustom tab-bar-tab-face-function #'tab-bar-tab-face-default
+ "Function to define a tab face.
+Function gets one argument: a tab."
+ :type 'function
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-tab-face-default (tab)
+ (if (eq (car tab) 'current-tab) 'tab-bar-tab 'tab-bar-tab-inactive))
+
+(defcustom tab-bar-tab-name-format-function #'tab-bar-tab-name-format-default
+ "Function to format a tab name.
+Function gets two arguments, the tab and its number, and should return
+the formatted tab name to display in the tab bar."
+ :type 'function
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-tab-name-format-default (tab i)
+ (let ((current-p (eq (car tab) 'current-tab)))
+ (propertize
+ (concat (if tab-bar-tab-hints (format "%d " i) "")
+ (alist-get 'name tab)
+ (or (and tab-bar-close-button-show
+ (not (eq tab-bar-close-button-show
+ (if current-p 'non-selected 'selected)))
+ tab-bar-close-button)
+ ""))
+ 'face (funcall tab-bar-tab-face-function tab))))
+
+(defcustom tab-bar-format '(tab-bar-format-history
+ tab-bar-format-tabs
+ tab-bar-separator
+ tab-bar-format-add-tab)
+ "Template for displaying tab bar items.
+Every item in the list is a function that returns
+a string, or a list of menu-item elements, or nil.
+When you add more items `tab-bar-format-align-right' and
+`tab-bar-format-global' to the end, then after enabling
+`display-time-mode' (or any other mode that uses `global-mode-string')
+it will display time aligned to the right on the tab bar instead of
+the mode line. Replacing `tab-bar-format-tabs' with
+`tab-bar-format-tabs-groups' will group tabs on the tab bar."
+ :type 'hook
+ :options '(tab-bar-format-history
+ tab-bar-format-tabs
+ tab-bar-format-tabs-groups
+ tab-bar-separator
+ tab-bar-format-add-tab
+ tab-bar-format-align-right
+ tab-bar-format-global)
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-format-history ()
+ (when (and tab-bar-history-mode tab-bar-history-buttons-show)
+ `((sep-history-back menu-item ,(tab-bar-separator) ignore)
+ (history-back
+ menu-item ,tab-bar-back-button tab-bar-history-back
+ :help "Click to go back in tab history")
+ (sep-history-forward menu-item ,(tab-bar-separator) ignore)
+ (history-forward
+ menu-item ,tab-bar-forward-button tab-bar-history-forward
+ :help "Click to go forward in tab history"))))
+
+(defun tab-bar--format-tab (tab i)
+ (append
+ `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore))
+ (cond
+ ((eq (car tab) 'current-tab)
+ `((current-tab
+ menu-item
+ ,(funcall tab-bar-tab-name-format-function tab i)
+ ignore
+ :help "Current tab")))
+ (t
+ `((,(intern (format "tab-%i" i))
+ menu-item
+ ,(funcall tab-bar-tab-name-format-function tab i)
+ ,(or
+ (alist-get 'binding tab)
+ `(lambda ()
+ (interactive)
+ (tab-bar-select-tab ,i)))
+ :help "Click to visit tab"))))
+ `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i)))
+ menu-item ""
+ ,(or
+ (alist-get 'close-binding tab)
+ `(lambda ()
+ (interactive)
+ (tab-bar-close-tab ,i)))))))
+
+(defun tab-bar-format-tabs ()
+ (let ((i 0))
+ (mapcan
+ (lambda (tab)
+ (setq i (1+ i))
+ (tab-bar--format-tab tab i))
+ (funcall tab-bar-tabs-function))))
+
+(defcustom tab-bar-tab-group-function #'tab-bar-tab-group-default
+ "Function to get a tab group name.
+Function gets one argument: a tab."
+ :type 'function
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-tab-group-default (tab)
+ (alist-get 'group tab))
+
+(defcustom tab-bar-tab-group-format-function #'tab-bar-tab-group-format-default
+ "Function to format a tab group name.
+Function gets two arguments, a tab with a group name and its number,
+and should return the formatted tab group name to display in the tab bar."
+ :type 'function
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-tab-group-format-default (tab i)
+ (propertize
+ (concat (if tab-bar-tab-hints (format "%d " i) "")
+ (funcall tab-bar-tab-group-function tab))
+ 'face 'tab-bar-tab-group-inactive))
+
+(defcustom tab-bar-tab-group-face-function #'tab-bar-tab-group-face-default
+ "Function to define a tab group face.
+Function gets one argument: a tab."
+ :type 'function
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-tab-group-face-default (tab)
+ (if (not (or (eq (car tab) 'current-tab)
+ (funcall tab-bar-tab-group-function tab)))
+ 'tab-bar-tab-ungrouped
+ (tab-bar-tab-face-default tab)))
+
+(defun tab-bar--format-tab-group (tab i &optional current-p)
+ (append
+ `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore))
+ `((,(intern (format "group-%i" i))
+ menu-item
+ ,(if current-p
+ (propertize (funcall tab-bar-tab-group-function tab)
+ 'face 'tab-bar-tab-group-current)
+ (funcall tab-bar-tab-group-format-function tab i))
+ ,(if current-p 'ignore
+ (or
+ (alist-get 'binding tab)
+ `(lambda ()
+ (interactive)
+ (tab-bar-select-tab ,i))))
+ :help "Click to visit group"))))
+
+(defun tab-bar-format-tabs-groups ()
+ (let* ((tabs (funcall tab-bar-tabs-function))
+ (current-group (funcall tab-bar-tab-group-function
+ (tab-bar--current-tab-find tabs)))
+ (previous-group nil)
+ (i 0))
+ (mapcan
+ (lambda (tab)
+ (let ((tab-group (funcall tab-bar-tab-group-function tab)))
+ (setq i (1+ i))
+ (prog1 (cond
+ ;; Show current group tabs and ungrouped tabs
+ ((or (equal tab-group current-group) (not tab-group))
+ (append
+ ;; Prepend current group name before first tab
+ (when (and (not (equal previous-group tab-group)) tab-group)
+ (tab-bar--format-tab-group tab i t))
+ ;; Override default tab faces to use group faces
+ (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function))
+ (tab-bar--format-tab tab i))))
+ ;; Show first tab of other groups with a group name
+ ((not (equal previous-group tab-group))
+ (tab-bar--format-tab-group tab i))
+ ;; Hide other group tabs
+ (t nil))
+ (setq previous-group tab-group))))
+ tabs)))
+
+(defun tab-bar-format-add-tab ()
+ (when (and tab-bar-new-button-show tab-bar-new-button)
+ `((add-tab menu-item ,tab-bar-new-button tab-bar-new-tab
+ :help "New tab"))))
+
+(defun tab-bar-format-align-right ()
+ "Align the rest of tab bar items to the right."
+ (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format)))
+ (rest (tab-bar-format-list rest))
+ (rest (mapconcat (lambda (item) (nth 2 item)) rest ""))
+ (hpos (length rest))
+ (str (propertize " " 'display `(space :align-to (- right ,hpos)))))
+ `((align-right menu-item ,str ignore))))
+
+(defun tab-bar-format-global ()
+ "Format `global-mode-string' to display it in the tab bar.
+When `tab-bar-format-global' is added to `tab-bar-format'
+(possibly appended after `tab-bar-format-align-right'),
+then modes that display information on the mode line
+using `global-mode-string' will display the same text
+on the tab bar instead."
+ `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore)))
+
+(defun tab-bar-format-list (format-list)
+ (let ((i 0))
+ (apply #'append
+ (mapcar
+ (lambda (format)
+ (setq i (1+ i))
+ (cond
+ ((functionp format)
+ (let ((ret (funcall format)))
+ (when (stringp ret)
+ (setq ret `((,(intern (format "str-%i" i))
+ menu-item ,ret ignore))))
+ ret))))
+ format-list))))
+
(defun tab-bar-make-keymap-1 ()
"Generate an actual keymap from `tab-bar-map', without caching."
- (let* ((separator (or tab-bar-separator (if window-system " " "|")))
- (i 0)
- (tabs (funcall tab-bar-tabs-function)))
- (append
- '(keymap (mouse-1 . tab-bar-handle-mouse))
- (when tab-bar-history-mode
- `((sep-history-back menu-item ,separator ignore)
- (history-back
- menu-item ,tab-bar-back-button tab-bar-history-back
- :help "Click to go back in tab history")
- (sep-history-forward menu-item ,separator ignore)
- (history-forward
- menu-item ,tab-bar-forward-button tab-bar-history-forward
- :help "Click to go forward in tab history")))
- (mapcan
- (lambda (tab)
- (setq i (1+ i))
- (append
- `((,(intern (format "sep-%i" i)) menu-item ,separator ignore))
- (cond
- ((eq (car tab) 'current-tab)
- `((current-tab
- menu-item
- ,(propertize (concat (if tab-bar-tab-hints (format "%d " i) "")
- (alist-get 'name tab)
- (or (and tab-bar-close-button-show
- (not (eq tab-bar-close-button-show
- 'non-selected))
- tab-bar-close-button) ""))
- 'face 'tab-bar-tab)
- ignore
- :help "Current tab")))
- (t
- `((,(intern (format "tab-%i" i))
- menu-item
- ,(propertize (concat (if tab-bar-tab-hints (format "%d " i) "")
- (alist-get 'name tab)
- (or (and tab-bar-close-button-show
- (not (eq tab-bar-close-button-show
- 'selected))
- tab-bar-close-button) ""))
- 'face 'tab-bar-tab-inactive)
- ,(or
- (alist-get 'binding tab)
- `(lambda ()
- (interactive)
- (tab-bar-select-tab ,i)))
- :help "Click to visit tab"))))
- `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i)))
- menu-item ""
- ,(or
- (alist-get 'close-binding tab)
- `(lambda ()
- (interactive)
- (tab-bar-close-tab ,i)))))))
- tabs)
- `((sep-add-tab menu-item ,separator ignore))
- (when (and tab-bar-new-button-show tab-bar-new-button)
- `((add-tab menu-item ,tab-bar-new-button tab-bar-new-tab
- :help "New tab"))))))
+ (append
+ '(keymap (mouse-1 . tab-bar-handle-mouse))
+ (tab-bar-format-list tab-bar-format)))
;; Some window-configuration parameters don't need to be persistent.
@@ -496,8 +791,9 @@ Return its existing value or a new value."
(push '(tabs . frameset-filter-tabs) frameset-filter-alist)
(defun tab-bar--tab (&optional frame)
- (let* ((tab (assq 'current-tab (frame-parameter frame 'tabs)))
+ (let* ((tab (tab-bar--current-tab-find nil frame))
(tab-explicit-name (alist-get 'explicit-name tab))
+ (tab-group (alist-get 'group tab))
(bl (seq-filter #'buffer-live-p (frame-parameter frame 'buffer-list)))
(bbl (seq-filter #'buffer-live-p (frame-parameter frame 'buried-buffer-list))))
`(tab
@@ -505,6 +801,7 @@ Return its existing value or a new value."
(alist-get 'name tab)
(funcall tab-bar-tab-name-function)))
(explicit-name . ,tab-explicit-name)
+ ,@(if tab-group `((group . ,tab-group)))
(time . ,(float-time))
(ws . ,(window-state-get
(frame-root-window (or frame (selected-frame))) 'writable))
@@ -516,16 +813,27 @@ Return its existing value or a new value."
(wc-history-forward . ,(gethash (or frame (selected-frame)) tab-bar-history-forward)))))
(defun tab-bar--current-tab (&optional tab frame)
- ;; `tab` here is an argument meaning 'use tab as template'. This is
+ (tab-bar--current-tab-make (or tab (tab-bar--current-tab-find nil frame))))
+
+(defun tab-bar--current-tab-make (&optional tab)
+ ;; `tab' here is an argument meaning "use tab as template". This is
;; necessary when switching tabs, otherwise the destination tab
- ;; inherit the current tab's `explicit-name` parameter.
- (let* ((tab (or tab (assq 'current-tab (frame-parameter frame 'tabs))))
- (tab-explicit-name (alist-get 'explicit-name tab)))
+ ;; inherits the current tab's `explicit-name' parameter.
+ (let* ((tab-explicit-name (alist-get 'explicit-name tab))
+ (tab-group (if tab
+ (alist-get 'group tab)
+ (pcase tab-bar-new-tab-group
+ ((pred stringp) tab-bar-new-tab-group)
+ ((pred functionp) (funcall tab-bar-new-tab-group))))))
`(current-tab
(name . ,(if tab-explicit-name
(alist-get 'name tab)
(funcall tab-bar-tab-name-function)))
- (explicit-name . ,tab-explicit-name))))
+ (explicit-name . ,tab-explicit-name)
+ ,@(if tab-group `((group . ,tab-group))))))
+
+(defun tab-bar--current-tab-find (&optional tabs frame)
+ (assq 'current-tab (or tabs (funcall tab-bar-tabs-function frame))))
(defun tab-bar--current-tab-index (&optional tabs frame)
(seq-position (or tabs (funcall tab-bar-tabs-function frame))
@@ -558,7 +866,7 @@ Return its existing value or a new value."
When this command is bound to a numeric key (with a prefix or modifier key
using `tab-bar-select-tab-modifiers'), calling it without an argument
will translate its bound numeric key to the numeric argument.
-ARG counts from 1."
+ARG counts from 1. Negative ARG counts tabs from the end of the tab bar."
(interactive "P")
(unless (integerp arg)
(let ((key (event-basic-type last-command-event)))
@@ -568,7 +876,9 @@ ARG counts from 1."
(let* ((tabs (funcall tab-bar-tabs-function))
(from-index (tab-bar--current-tab-index tabs))
- (to-index (1- (max 1 (min arg (length tabs))))))
+ (to-index (if (< arg 0) (+ (length tabs) (1+ arg)) arg))
+ (to-index (1- (max 1 (min to-index (length tabs))))))
+
(unless (eq from-index to-index)
(let* ((from-tab (tab-bar--tab))
(to-tab (nth to-index tabs))
@@ -616,13 +926,13 @@ ARG counts from 1."
tab-bar-history-forward)))
(ws
- (window-state-put ws (frame-root-window (selected-frame)) 'safe)))
+ (window-state-put ws nil 'safe)))
(setq tab-bar-history-omit t)
(when from-index
(setf (nth from-index tabs) from-tab))
- (setf (nth to-index tabs) (tab-bar--current-tab (nth to-index tabs)))
+ (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs)))
(unless tab-bar-mode
(message "Selected tab '%s'" (alist-get 'name to-tab))))
@@ -646,6 +956,12 @@ ARG counts from 1."
(setq arg 1))
(tab-bar-switch-to-next-tab (- arg)))
+(defun tab-bar-switch-to-last-tab (&optional arg)
+ "Switch to the last tab or ARGth tab from the end of the tab bar."
+ (interactive "p")
+ (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function))
+ (1- (or arg 1)))))
+
(defun tab-bar-switch-to-recent-tab (&optional arg)
"Switch to ARGth most recently visited tab."
(interactive "p")
@@ -660,12 +976,14 @@ ARG counts from 1."
"Switch to the tab by NAME.
Default values are tab names sorted by recency, so you can use \
\\<minibuffer-local-map>\\[next-history-element]
-to get the name of the last visited tab, the second last, and so on."
+to get the name of the most recently visited tab, the second
+most recent, and so on."
(interactive
(let* ((recent-tabs (mapcar (lambda (tab)
(alist-get 'name tab))
(tab-bar--tabs-recent))))
- (list (completing-read "Switch to tab by name (default recent): "
+ (list (completing-read (format-prompt "Switch to tab by name"
+ (car recent-tabs))
recent-tabs nil nil nil nil recent-tabs))))
(tab-bar-select-tab (1+ (or (tab-bar--tab-index-by-name name) 0))))
@@ -675,20 +993,27 @@ to get the name of the last visited tab, the second last, and so on."
(defun tab-bar-move-tab-to (to-index &optional from-index)
"Move tab from FROM-INDEX position to new position at TO-INDEX.
FROM-INDEX defaults to the current tab index.
-FROM-INDEX and TO-INDEX count from 1."
+FROM-INDEX and TO-INDEX count from 1.
+Negative TO-INDEX counts tabs from the end of the tab bar.
+Argument addressing is absolute in contrast to `tab-bar-move-tab'
+where argument addressing is relative."
(interactive "P")
(let* ((tabs (funcall tab-bar-tabs-function))
(from-index (or from-index (1+ (tab-bar--current-tab-index tabs))))
(from-tab (nth (1- from-index) tabs))
- (to-index (max 0 (min (1- (or to-index 1)) (1- (length tabs))))))
+ (to-index (if to-index (prefix-numeric-value to-index) 1))
+ (to-index (if (< to-index 0) (+ (length tabs) (1+ to-index)) to-index))
+ (to-index (max 0 (min (1- to-index) (1- (length tabs))))))
(setq tabs (delq from-tab tabs))
(cl-pushnew from-tab (nthcdr to-index tabs))
- (set-frame-parameter nil 'tabs tabs)
+ (tab-bar-tabs-set tabs)
(force-mode-line-update)))
(defun tab-bar-move-tab (&optional arg)
"Move the current tab ARG positions to the right.
-If a negative ARG, move the current tab ARG positions to the left."
+If a negative ARG, move the current tab ARG positions to the left.
+Argument addressing is relative in contrast to `tab-bar-move-tab-to'
+where argument addressing is absolute."
(interactive "p")
(let* ((tabs (funcall tab-bar-tabs-function))
(from-index (or (tab-bar--current-tab-index tabs) 0))
@@ -723,7 +1048,7 @@ Interactively, ARG selects the ARGth different frame to move to."
(let ((inhibit-message t) ; avoid message about deleted tab
tab-bar-closed-tabs)
(tab-bar-close-tab from-index)))
- (set-frame-parameter to-frame 'tabs to-tabs)
+ (tab-bar-tabs-set to-tabs to-frame)
(force-mode-line-update t))))
@@ -745,9 +1070,8 @@ on the tab bar specifying where to insert a new tab."
(defcustom tab-bar-tab-post-open-functions nil
"List of functions to call after creating a new tab.
-The current tab is supplied as an argument. Any modifications
-made to the tab argument will be applied after all functions are
-called."
+The current tab is supplied as an argument. Any modifications made
+to the tab argument will be applied after all functions are called."
:type '(repeat function)
:group 'tab-bar
:version "27.1")
@@ -756,7 +1080,9 @@ called."
"Add a new tab at the absolute position TO-INDEX.
TO-INDEX counts from 1. If no TO-INDEX is specified, then add
a new tab at the position specified by `tab-bar-new-tab-to'.
-
+Negative TO-INDEX counts tabs from the end of the tab bar.
+Argument addressing is absolute in contrast to `tab-bar-new-tab'
+where argument addressing is relative.
After the tab is created, the hooks in
`tab-bar-tab-post-open-functions' are run."
(interactive "P")
@@ -765,6 +1091,9 @@ After the tab is created, the hooks in
(from-tab (tab-bar--tab)))
(when tab-bar-new-tab-choice
+ ;; Handle the case when it's called in the active minibuffer.
+ (when (minibuffer-selected-window)
+ (select-window (minibuffer-selected-window)))
(delete-other-windows)
;; Create a new window to get rid of old window parameters
;; (e.g. prev/next buffers) of old window.
@@ -780,30 +1109,38 @@ After the tab is created, the hooks in
(when from-index
(setf (nth from-index tabs) from-tab))
- (let ((to-tab (tab-bar--current-tab))
- (to-index (or (if to-index (1- to-index))
- (pcase tab-bar-new-tab-to
- ('leftmost 0)
- ('rightmost (length tabs))
- ('left (or from-index 1))
- ('right (1+ (or from-index 0)))
- ((pred functionp)
- (funcall tab-bar-new-tab-to))))))
+
+ (let* ((to-tab (tab-bar--current-tab-make
+ (when (eq tab-bar-new-tab-group t)
+ `((group . ,(alist-get 'group from-tab))))))
+ (to-index (and to-index (prefix-numeric-value to-index)))
+ (to-index (or (if to-index
+ (if (< to-index 0)
+ (+ (length tabs) (1+ to-index))
+ (1- to-index)))
+ (pcase tab-bar-new-tab-to
+ ('leftmost 0)
+ ('rightmost (length tabs))
+ ('left (or from-index 1))
+ ('right (1+ (or from-index 0)))
+ ((pred functionp)
+ (funcall tab-bar-new-tab-to))))))
(setq to-index (max 0 (min (or to-index 0) (length tabs))))
(cl-pushnew to-tab (nthcdr to-index tabs))
(when (eq to-index 0)
- ;; pushnew handles the head of tabs but not frame-parameter
- (set-frame-parameter nil 'tabs tabs))
+ ;; `pushnew' handles the head of tabs but not frame-parameter
+ (tab-bar-tabs-set tabs))
(run-hook-with-args 'tab-bar-tab-post-open-functions
(nth to-index tabs)))
- (when (and (not tab-bar-mode)
- (or (eq tab-bar-show t)
- (and (natnump tab-bar-show)
- (> (length tabs) tab-bar-show))))
- (tab-bar-mode 1))
+ (when tab-bar-show
+ (if (not tab-bar-mode)
+ ;; Turn on `tab-bar-mode' since a tab was created.
+ ;; Note: this also updates `tab-bar-lines'.
+ (tab-bar-mode 1)
+ (tab-bar--update-tab-bar-lines)))
(force-mode-line-update)
(unless tab-bar-mode
@@ -812,7 +1149,11 @@ After the tab is created, the hooks in
(defun tab-bar-new-tab (&optional arg)
"Create a new tab ARG positions to the right.
If a negative ARG, create a new tab ARG positions to the left.
-If ARG is zero, create a new tab in place of the current tab."
+If ARG is zero, create a new tab in place of the current tab.
+If no ARG is specified, then add a new tab at the position
+specified by `tab-bar-new-tab-to'.
+Argument addressing is relative in contrast to `tab-bar-new-tab-to'
+where argument addressing is absolute."
(interactive "P")
(if arg
(let* ((tabs (funcall tab-bar-tabs-function))
@@ -821,6 +1162,15 @@ If ARG is zero, create a new tab in place of the current tab."
(tab-bar-new-tab-to (1+ to-index)))
(tab-bar-new-tab-to)))
+(defun tab-bar-duplicate-tab (&optional arg)
+ "Duplicate the current tab to ARG positions to the right.
+If a negative ARG, duplicate the tab to ARG positions to the left.
+If ARG is zero, duplicate the tab in place of the current tab."
+ (interactive "P")
+ (let ((tab-bar-new-tab-choice nil)
+ (tab-bar-new-tab-group t))
+ (tab-bar-new-tab arg)))
+
(defvar tab-bar-closed-tabs nil
"A list of closed tabs to be able to undo their closing.")
@@ -840,8 +1190,10 @@ If `recent', select the most recently visited tab."
"Defines what to do when the last tab is closed.
If nil, do nothing and show a message, like closing the last window or frame.
If `delete-frame', delete the containing frame, as a web browser would do.
-If `tab-bar-mode-disable', disable tab-bar-mode so that tabs no longer show in the frame.
-If the value is a function, call that function with the tab to be closed as an argument."
+If `tab-bar-mode-disable', disable tab-bar-mode so that tabs no longer show
+in the frame.
+If the value is a function, call that function with the tab to be closed
+as an argument."
:type '(choice (const :tag "Do nothing and show message" nil)
(const :tag "Close the containing frame" delete-frame)
(const :tag "Disable tab-bar-mode" tab-bar-mode-disable)
@@ -852,7 +1204,7 @@ If the value is a function, call that function with the tab to be closed as an a
(defcustom tab-bar-tab-prevent-close-functions nil
"List of functions to call to determine whether to close a tab.
The tab to be closed and a boolean indicating whether or not it
-is the only tab in the frame are supplied as arguments. If any
+is the only tab in the frame are supplied as arguments. If any
function returns a non-nil value, the tab will not be closed."
:type '(repeat function)
:group 'tab-bar
@@ -934,12 +1286,10 @@ for the last tab on a frame is determined by
(tab-bar--tab)
close-tab)))
tab-bar-closed-tabs)
- (set-frame-parameter nil 'tabs (delq close-tab tabs)))
+ (tab-bar-tabs-set (delq close-tab tabs)))
- (when (and tab-bar-mode
- (and (natnump tab-bar-show)
- (<= (length tabs) tab-bar-show)))
- (tab-bar-mode -1))
+ ;; Recalculate `tab-bar-lines' and update frames
+ (tab-bar--update-tab-bar-lines)
(force-mode-line-update)
(unless tab-bar-mode
@@ -958,34 +1308,34 @@ for the last tab on a frame is determined by
"Close all tabs on the selected frame, except the selected one."
(interactive)
(let* ((tabs (funcall tab-bar-tabs-function))
- (current-index (tab-bar--current-tab-index tabs)))
- (when current-index
- (dotimes (index (length tabs))
- (unless (or (eq index current-index)
+ (current-tab (tab-bar--current-tab-find tabs))
+ (index 0))
+ (when current-tab
+ (dolist (tab tabs)
+ (unless (or (eq tab current-tab)
(run-hook-with-args-until-success
- 'tab-bar-tab-prevent-close-functions
- (nth index tabs)
- ; last-tab-p logically can't ever be true if we
- ; make it this far
+ 'tab-bar-tab-prevent-close-functions tab
+ ;; `last-tab-p' logically can't ever be true
+ ;; if we make it this far
nil))
(push `((frame . ,(selected-frame))
(index . ,index)
- (tab . ,(nth index tabs)))
+ (tab . ,tab))
tab-bar-closed-tabs)
- (run-hook-with-args 'tab-bar-tab-pre-close-functions (nth index tabs) nil)))
- (set-frame-parameter nil 'tabs (list (nth current-index tabs)))
+ (run-hook-with-args 'tab-bar-tab-pre-close-functions tab nil)
+ (setq tabs (delq tab tabs)))
+ (setq index (1+ index)))
+ (tab-bar-tabs-set tabs)
- (when (and tab-bar-mode
- (and (natnump tab-bar-show)
- (<= 1 tab-bar-show)))
- (tab-bar-mode -1))
+ ;; Recalculate tab-bar-lines and update frames
+ (tab-bar--update-tab-bar-lines)
(force-mode-line-update)
(unless tab-bar-mode
(message "Deleted all other tabs")))))
(defun tab-bar-undo-close-tab ()
- "Restore the last closed tab."
+ "Restore the most recently closed tab."
(interactive)
;; Pop out closed tabs that were on already deleted frames
(while (and tab-bar-closed-tabs
@@ -1005,7 +1355,7 @@ for the last tab on a frame is determined by
(cl-pushnew tab (nthcdr index tabs))
(when (eq index 0)
;; pushnew handles the head of tabs but not frame-parameter
- (set-frame-parameter nil 'tabs tabs))
+ (tab-bar-tabs-set tabs))
(tab-bar-select-tab (1+ index))))
(message "No more closed tabs to undo")))
@@ -1056,6 +1406,109 @@ function `tab-bar-tab-name-function'."
(tab-bar-rename-tab new-name (1+ (tab-bar--tab-index-by-name tab-name))))
+;;; Tab groups
+
+(defun tab-bar-move-tab-to-group (&optional tab)
+ "Relocate TAB (or the current tab) closer to its group."
+ (interactive)
+ (let* ((tabs (funcall tab-bar-tabs-function))
+ (tab (or tab (tab-bar--current-tab-find tabs)))
+ (tab-index (tab-bar--tab-index tab))
+ (group (alist-get 'group tab))
+ ;; Beginning position of the same group
+ (beg (seq-position tabs group
+ (lambda (tb gr)
+ (and (not (eq tb tab))
+ (equal (alist-get 'group tb) gr)))))
+ ;; Size of the same group
+ (len (when beg
+ (seq-position (nthcdr beg tabs) group
+ (lambda (tb gr)
+ (not (equal (alist-get 'group tb) gr))))))
+ (pos (when beg
+ (cond
+ ;; Don't move tab when it's already inside group bounds
+ ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil)
+ ;; Move tab from the right to the group end
+ ((and len (> tab-index (+ beg len))) (+ beg len 1))
+ ;; Move tab from the left to the group beginning
+ ((< tab-index beg) beg)))))
+ (when pos
+ (tab-bar-move-tab-to pos (1+ tab-index)))))
+
+(defcustom tab-bar-tab-post-change-group-functions nil
+ "List of functions to call after changing a tab group.
+The current tab is supplied as an argument."
+ :type 'hook
+ :options '(tab-bar-move-tab-to-group)
+ :group 'tab-bar
+ :version "28.1")
+
+(defun tab-bar-change-tab-group (group-name &optional arg)
+ "Add the tab specified by its absolute position ARG to GROUP-NAME.
+If no ARG is specified, then set the GROUP-NAME for the current tab.
+ARG counts from 1.
+If GROUP-NAME is the empty string, then remove the tab from any group.
+While using this command, you might also want to replace
+`tab-bar-format-tabs' with `tab-bar-format-tabs-groups' in
+`tab-bar-format' to group tabs on the tab bar."
+ (interactive
+ (let* ((tabs (funcall tab-bar-tabs-function))
+ (tab-index (or current-prefix-arg
+ (1+ (tab-bar--current-tab-index tabs))))
+ (group-name (funcall tab-bar-tab-group-function
+ (nth (1- tab-index) tabs))))
+ (list (completing-read
+ "Group name for tab (leave blank to remove group): "
+ (delete-dups
+ (delq nil (cons group-name
+ (mapcar (lambda (tab)
+ (funcall tab-bar-tab-group-function tab))
+ (funcall tab-bar-tabs-function))))))
+ current-prefix-arg)))
+ (let* ((tabs (funcall tab-bar-tabs-function))
+ (tab-index (if arg
+ (1- (max 0 (min arg (length tabs))))
+ (tab-bar--current-tab-index tabs)))
+ (tab (nth tab-index tabs))
+ (group (assq 'group tab))
+ (group-new-name (and (> (length group-name) 0) group-name)))
+ (if group
+ (setcdr group group-new-name)
+ (nconc tab `((group . ,group-new-name))))
+
+ (run-hook-with-args 'tab-bar-tab-post-change-group-functions tab)
+
+ (force-mode-line-update)
+ (unless tab-bar-mode
+ (message "Set tab group to '%s'" group-new-name))))
+
+(defun tab-bar-close-group-tabs (group-name)
+ "Close all tabs that belong to GROUP-NAME on the selected frame."
+ (interactive
+ (let ((group-name (funcall tab-bar-tab-group-function
+ (tab-bar--current-tab-find))))
+ (list (completing-read
+ "Close all tabs with group name: "
+ (delete-dups
+ (delq nil (cons group-name
+ (mapcar (lambda (tab)
+ (funcall tab-bar-tab-group-function tab))
+ (funcall tab-bar-tabs-function)))))))))
+ (let* ((close-group (and (> (length group-name) 0) group-name))
+ (tab-bar-tab-prevent-close-functions
+ (cons (lambda (tab _last-tab-p)
+ (not (equal (funcall tab-bar-tab-group-function tab)
+ close-group)))
+ tab-bar-tab-prevent-close-functions)))
+ (tab-bar-close-other-tabs)
+
+ (when (equal (funcall tab-bar-tab-group-function
+ (tab-bar--current-tab-find))
+ close-group)
+ (tab-bar-close-tab))))
+
+
;;; Tab history mode
(defvar tab-bar-history-limit 10
@@ -1076,7 +1529,7 @@ function `tab-bar-tab-name-function'."
(defvar tab-bar-history-old-minibuffer-depth 0
"Minibuffer depth before the current command.")
-(defun tab-bar-history--pre-change ()
+(defun tab-bar--history-pre-change ()
(setq tab-bar-history-old-minibuffer-depth (minibuffer-depth))
;; Store wc before possibly entering the minibuffer
(when (zerop tab-bar-history-old-minibuffer-depth)
@@ -1159,29 +1612,12 @@ and can restore them."
:ascent center))
tab-bar-forward-button))
- (add-hook 'pre-command-hook 'tab-bar-history--pre-change)
+ (add-hook 'pre-command-hook 'tab-bar--history-pre-change)
(add-hook 'window-configuration-change-hook 'tab-bar--history-change))
- (remove-hook 'pre-command-hook 'tab-bar-history--pre-change)
+ (remove-hook 'pre-command-hook 'tab-bar--history-pre-change)
(remove-hook 'window-configuration-change-hook 'tab-bar--history-change)))
-;;; Short aliases
-
-(defalias 'tab-new 'tab-bar-new-tab)
-(defalias 'tab-new-to 'tab-bar-new-tab-to)
-(defalias 'tab-close 'tab-bar-close-tab)
-(defalias 'tab-close-other 'tab-bar-close-other-tabs)
-(defalias 'tab-undo 'tab-bar-undo-close-tab)
-(defalias 'tab-select 'tab-bar-select-tab)
-(defalias 'tab-next 'tab-bar-switch-to-next-tab)
-(defalias 'tab-previous 'tab-bar-switch-to-prev-tab)
-(defalias 'tab-recent 'tab-bar-switch-to-recent-tab)
-(defalias 'tab-move 'tab-bar-move-tab)
-(defalias 'tab-move-to 'tab-bar-move-tab-to)
-(defalias 'tab-rename 'tab-bar-rename-tab)
-(defalias 'tab-list 'tab-switcher)
-
-
;;; Non-graphical access to frame-local tabs (named window configurations)
(defun tab-switcher ()
@@ -1197,18 +1633,11 @@ Type q to remove the list of window configurations from the display.
The first column shows `D' for a window configuration you have
marked for deletion."
(interactive)
- (let ((dir default-directory)
- (minibuf (minibuffer-selected-window)))
- (let ((tab-bar-show nil)) ; don't enable tab-bar-mode if it's disabled
+ (let ((dir default-directory))
+ (let ((tab-bar-new-tab-choice t)
+ ;; Don't enable tab-bar-mode if it's disabled
+ (tab-bar-show nil))
(tab-bar-new-tab))
- ;; Handle the case when it's called in the active minibuffer.
- (when minibuf (select-window (minibuffer-selected-window)))
- (delete-other-windows)
- ;; Create a new window to replace the existing one, to not break the
- ;; window parameters (e.g. prev/next buffers) of the window just saved
- ;; to the window configuration. So when a saved window is restored,
- ;; its parameters left intact.
- (split-window) (delete-window)
(let ((switch-to-buffer-preserve-window-point nil))
(switch-to-buffer (tab-switcher-noselect)))
(setq default-directory dir))
@@ -1253,8 +1682,7 @@ For more information, see the function `tab-switcher'."
(setq buffer-read-only t)
(current-buffer))))
-(defvar tab-switcher-column 3)
-(make-variable-buffer-local 'tab-switcher-column)
+(defvar-local tab-switcher-column 3)
(defvar tab-switcher-mode-map
(let ((map (make-keymap)))
@@ -1367,7 +1795,7 @@ Then move up one line. Prefix arg means move that many lines."
(index . ,(tab-bar--tab-index tab))
(tab . ,tab))
tab-bar-closed-tabs)
- (set-frame-parameter nil 'tabs (delq tab (funcall tab-bar-tabs-function))))
+ (tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function))))
(defun tab-switcher-execute ()
"Delete window configurations marked with \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands."
@@ -1471,6 +1899,8 @@ a function, then it is called with two arguments: BUFFER and ALIST, and
should return the tab name. When a `tab-name' entry is omitted, create
a new tab without an explicit name.
+The ALIST entry `tab-group' (string or function) defines the tab group.
+
If ALIST contains a `reusable-frames' entry, its value determines
which frames to search for a reusable tab:
nil -- the selected frame (actually the last non-minibuffer frame)
@@ -1483,8 +1913,7 @@ This is an action function for buffer display, see Info
node `(elisp) Buffer Display Action Functions'. It should be
called only by `display-buffer' or a function directly or
indirectly called by the latter."
- (let* ((tab-name (alist-get 'tab-name alist))
- (reusable-frames (alist-get 'reusable-frames alist))
+ (let* ((reusable-frames (alist-get 'reusable-frames alist))
(reusable-tab (when reusable-frames
(tab-bar-get-buffer-tab buffer reusable-frames))))
(if reusable-tab
@@ -1496,17 +1925,53 @@ indirectly called by the latter."
(tab-bar-select-tab (1+ index)))
(when (get-buffer-window buffer frame)
(select-window (get-buffer-window buffer frame))))
+ (let ((tab-name (alist-get 'tab-name alist)))
+ (when (functionp tab-name)
+ (setq tab-name (funcall tab-name buffer alist)))
+ (if tab-name
+ (let ((tab-index (tab-bar--tab-index-by-name tab-name)))
+ (if tab-index
+ (progn
+ (tab-bar-select-tab (1+ tab-index))
+ (when (get-buffer-window buffer)
+ (select-window (get-buffer-window buffer))))
+ (display-buffer-in-new-tab buffer alist)))
+ (display-buffer-in-new-tab buffer alist))))))
+
+(defun display-buffer-in-new-tab (buffer alist)
+ "Display BUFFER in a new tab.
+ALIST is an association list of action symbols and values. See
+Info node `(elisp) Buffer Display Action Alists' for details of
+such alists.
+
+Like `display-buffer-in-tab', but always creates a new tab unconditionally,
+without checking if a suitable tab already exists.
+
+If ALIST contains a `tab-name' entry, it creates a new tab with that name
+and displays BUFFER in a new tab. The `tab-name' entry can be a function,
+then it is called with two arguments: BUFFER and ALIST, and should return
+the tab name. When a `tab-name' entry is omitted, create a new tab without
+an explicit name.
+
+The ALIST entry `tab-group' (string or function) defines the tab group.
+
+This is an action function for buffer display, see Info
+node `(elisp) Buffer Display Action Functions'. It should be
+called only by `display-buffer' or a function directly or
+indirectly called by the latter."
+ (let ((tab-bar-new-tab-choice t))
+ (tab-bar-new-tab)
+ (let ((tab-name (alist-get 'tab-name alist)))
(when (functionp tab-name)
(setq tab-name (funcall tab-name buffer alist)))
- (if tab-name
- (let ((tab-index (tab-bar--tab-index-by-name tab-name)))
- (if tab-index
- (tab-bar-select-tab (1+ tab-index))
- (let ((tab-bar-new-tab-choice t))
- (tab-bar-new-tab)
- (tab-bar-rename-tab tab-name))))
- (let ((tab-bar-new-tab-choice t))
- (tab-bar-new-tab))))))
+ (when tab-name
+ (tab-bar-rename-tab tab-name)))
+ (let ((tab-group (alist-get 'tab-group alist)))
+ (when (functionp tab-group)
+ (setq tab-group (funcall tab-group buffer alist)))
+ (when tab-group
+ (tab-bar-change-tab-group tab-group)))
+ (window--display-buffer buffer (selected-window) 'tab alist)))
(defun switch-to-buffer-other-tab (buffer-or-name &optional norecord)
"Switch to buffer BUFFER-OR-NAME in another tab.
@@ -1514,8 +1979,7 @@ Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab."
(interactive
(list (read-buffer-to-switch "Switch to buffer in other tab: ")))
(display-buffer (window-normalize-buffer-to-switch-to buffer-or-name)
- '((display-buffer-in-tab
- display-buffer-same-window)
+ '((display-buffer-in-tab)
(inhibit-same-window . nil))
norecord))
@@ -1534,16 +1998,100 @@ Like \\[find-file-other-frame] (which see), but creates a new tab."
value)
(switch-to-buffer-other-tab value))))
+(defun find-file-read-only-other-tab (filename &optional wildcards)
+ "Edit file FILENAME, in another tab, but don't allow changes.
+Like \\[find-file-other-frame] (which see), but creates a new tab.
+Like \\[find-file-other-tab], but marks buffer as read-only.
+Use \\[read-only-mode] to permit editing."
+ (interactive
+ (find-file-read-args "Find file read-only in other tab: "
+ (confirm-nonexistent-file-or-buffer)))
+ (find-file--read-only (lambda (filename wildcards)
+ (window-buffer
+ (find-file-other-tab filename wildcards)))
+ filename wildcards))
+
+(defun other-tab-prefix ()
+ "Display the buffer of the next command in a new tab.
+The next buffer is the buffer displayed by the next command invoked
+immediately after this command (ignoring reading from the minibuffer).
+Creates a new tab before displaying the buffer, or switches to the tab
+that already contains that buffer.
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ (interactive)
+ (display-buffer-override-next-command
+ (lambda (buffer alist)
+ (cons (progn
+ (display-buffer-in-tab
+ buffer (append alist '((inhibit-same-window . nil))))
+ (selected-window))
+ 'tab))
+ nil "[other-tab]")
+ (message "Display next command buffer in a new tab..."))
+
+
+;;; Short aliases and keybindings
+
+(defalias 'tab-new 'tab-bar-new-tab)
+(defalias 'tab-new-to 'tab-bar-new-tab-to)
+(defalias 'tab-duplicate 'tab-bar-duplicate-tab)
+(defalias 'tab-close 'tab-bar-close-tab)
+(defalias 'tab-close-other 'tab-bar-close-other-tabs)
+(defalias 'tab-close-group 'tab-bar-close-group-tabs)
+(defalias 'tab-undo 'tab-bar-undo-close-tab)
+(defalias 'tab-select 'tab-bar-select-tab)
+(defalias 'tab-switch 'tab-bar-switch-to-tab)
+(defalias 'tab-next 'tab-bar-switch-to-next-tab)
+(defalias 'tab-previous 'tab-bar-switch-to-prev-tab)
+(defalias 'tab-last 'tab-bar-switch-to-last-tab)
+(defalias 'tab-recent 'tab-bar-switch-to-recent-tab)
+(defalias 'tab-move 'tab-bar-move-tab)
+(defalias 'tab-move-to 'tab-bar-move-tab-to)
+(defalias 'tab-rename 'tab-bar-rename-tab)
+(defalias 'tab-group 'tab-bar-change-tab-group)
+(defalias 'tab-list 'tab-switcher)
+
+(define-key tab-prefix-map "n" 'tab-duplicate)
+(define-key tab-prefix-map "N" 'tab-new-to)
(define-key tab-prefix-map "2" 'tab-new)
(define-key tab-prefix-map "1" 'tab-close-other)
(define-key tab-prefix-map "0" 'tab-close)
+(define-key tab-prefix-map "u" 'tab-undo)
(define-key tab-prefix-map "o" 'tab-next)
+(define-key tab-prefix-map "O" 'tab-previous)
(define-key tab-prefix-map "m" 'tab-move)
+(define-key tab-prefix-map "M" 'tab-move-to)
+(define-key tab-prefix-map "G" 'tab-group)
(define-key tab-prefix-map "r" 'tab-rename)
-(define-key tab-prefix-map "\r" 'tab-bar-select-tab-by-name)
+(define-key tab-prefix-map "\r" 'tab-switch)
(define-key tab-prefix-map "b" 'switch-to-buffer-other-tab)
(define-key tab-prefix-map "f" 'find-file-other-tab)
(define-key tab-prefix-map "\C-f" 'find-file-other-tab)
+(define-key tab-prefix-map "\C-r" 'find-file-read-only-other-tab)
+(define-key tab-prefix-map "t" 'other-tab-prefix)
+
+(defvar tab-bar-switch-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "o" 'tab-next)
+ (define-key map "O" 'tab-previous)
+ map)
+ "Keymap to repeat tab switch key sequences `C-x t o o O'.
+Used in `repeat-mode'.")
+(put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map)
+(put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map)
+
+(defvar tab-bar-move-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "m" 'tab-move)
+ (define-key map "M" (lambda ()
+ (interactive)
+ (setq repeat-map 'tab-bar-move-repeat-map)
+ (tab-move -1)))
+ map)
+ "Keymap to repeat tab move key sequences `C-x t m m M'.
+Used in `repeat-mode'.")
+(put 'tab-move 'repeat-map 'tab-bar-move-repeat-map)
(provide 'tab-bar)
diff --git a/lisp/tab-line.el b/lisp/tab-line.el
index 89f85c5888b..d5fad353638 100644
--- a/lisp/tab-line.el
+++ b/lisp/tab-line.el
@@ -27,6 +27,7 @@
;;; Code:
+(require 'cl-lib)
(require 'seq) ; tab-line.el is not pre-loaded so it's safe to use it here
@@ -35,6 +36,19 @@
:group 'convenience
:version "27.1")
+(defcustom tab-line-tab-face-functions '(tab-line-tab-face-special)
+ "Functions called to modify tab faces.
+Each function is called with five arguments: the tab, a list of
+all tabs, the face returned by the previously called modifier,
+whether the tab is a buffer, and whether the tab is selected."
+ :type '(repeat
+ (choice (function-item tab-line-tab-face-special)
+ (function-item tab-line-tab-face-inactive-alternating)
+ (function-item tab-line-tab-face-group)
+ (function :tag "Custom function")))
+ :group 'tab-line
+ :version "28.1")
+
(defgroup tab-line-faces '((tab-line custom-face)) ; tab-line is defined in faces.el
"Faces used in the tab line."
:group 'tab-line
@@ -42,30 +56,52 @@
:version "27.1")
(defface tab-line-tab
- '((default
- :inherit tab-line)
+ '((default :inherit tab-line)
(((class color) (min-colors 88))
:box (:line-width 1 :style released-button))
- (t
- :inverse-video nil))
+ (t :inverse-video nil))
"Tab line face for selected tab."
:version "27.1"
:group 'tab-line-faces)
(defface tab-line-tab-inactive
- '((default
- :inherit tab-line-tab)
+ '((default :inherit tab-line-tab)
(((class color) (min-colors 88))
:background "grey75")
- (t
- :inverse-video t))
+ (t :inverse-video t))
"Tab line face for non-selected tab."
:version "27.1"
:group 'tab-line-faces)
+(defface tab-line-tab-inactive-alternate
+ '((t :inherit tab-line-tab-inactive :background "grey65"))
+ "Alternate face for inactive tab-line tabs.
+Applied to alternating tabs when option
+`tab-line-tab-face-functions' includes function
+`tab-line-tab-face-inactive-alternating'."
+ :version "28.1"
+ :group 'tab-line-faces)
+
+(defface tab-line-tab-special
+ '((default :weight bold)
+ (((supports :slant italic))
+ :slant italic :weight normal))
+ "Face for special (i.e. non-file-backed) tabs.
+Applied when option `tab-line-tab-face-functions' includes
+function `tab-line-tab-face-special'."
+ :version "28.1"
+ :group 'tab-line-faces)
+
+(defface tab-line-tab-group
+ '((t :inherit tab-line :box nil))
+ "Face for group tabs.
+Applied when option `tab-line-tab-face-functions' includes
+function `tab-line-tab-face-group'."
+ :version "28.1"
+ :group 'tab-line-faces)
+
(defface tab-line-tab-current
- '((default
- :inherit tab-line-tab)
+ '((default :inherit tab-line-tab)
(((class color) (min-colors 88))
:background "grey85"))
"Tab line face for tab with current buffer in selected window."
@@ -73,7 +109,7 @@
:group 'tab-line-faces)
(defface tab-line-highlight
- '((default :inherit tab-line-tab))
+ '((t :inherit tab-line-tab))
"Tab line face for highlighting."
:version "27.1"
:group 'tab-line-faces)
@@ -146,7 +182,7 @@ If the value is a function, call it with no arguments."
(defvar tab-line-new-button
(propertize " + "
- 'display `(image :type xpm
+ 'display '(image :type xpm
:file "tabs/new.xpm"
:margin (2 . 0)
:ascent center)
@@ -174,7 +210,7 @@ If nil, don't show it at all."
(defvar tab-line-close-button
(propertize " x"
- 'display `(image :type xpm
+ 'display '(image :type xpm
:file "tabs/close.xpm"
:margin (2 . 0)
:ascent center)
@@ -185,7 +221,7 @@ If nil, don't show it at all."
(defvar tab-line-left-button
(propertize " <"
- 'display `(image :type xpm
+ 'display '(image :type xpm
:file "tabs/left-arrow.xpm"
:margin (2 . 0)
:ascent center)
@@ -196,7 +232,7 @@ If nil, don't show it at all."
(defvar tab-line-right-button
(propertize "> "
- 'display `(image :type xpm
+ 'display '(image :type xpm
:file "tabs/right-arrow.xpm"
:margin (2 . 0)
:ascent center)
@@ -240,8 +276,7 @@ to `tab-line-tab-name-truncated-buffer'."
:group 'tab-line
:version "27.1")
-(defvar tab-line-tab-name-ellipsis
- (if (char-displayable-p ?…) "…" "..."))
+(defvar tab-line-tab-name-ellipsis t)
(defun tab-line-tab-name-truncated-buffer (buffer &optional _buffers)
"Generate tab name from BUFFER.
@@ -263,7 +298,10 @@ be displayed, or just a list of strings to display in the tab line.
By default, use function `tab-line-tabs-window-buffers' that
returns a list of buffers associated with the selected window.
When `tab-line-tabs-mode-buffers', return a list of buffers
-with the same major mode as the current buffer."
+with the same major mode as the current buffer.
+When `tab-line-tabs-buffer-groups', return a list of buffers
+grouped either by `tab-line-tabs-buffer-group-function', when set,
+or by `tab-line-tabs-buffer-groups'."
:type '(choice (const :tag "Window buffers"
tab-line-tabs-window-buffers)
(const :tag "Same mode buffers"
@@ -325,6 +363,11 @@ If the major mode's name string matches REGEXP, use GROUPNAME instead.")
mode))))
(defun tab-line-tabs-buffer-groups ()
+ "Return a list of tabs that should be displayed in the tab line.
+By default return a list of buffers grouped by major mode,
+according to `tab-line-tabs-buffer-groups'.
+If non-nil, `tab-line-tabs-buffer-group-function' is used to
+generate the group name."
(if (window-parameter nil 'tab-line-groups)
(let* ((buffers (funcall tab-line-tabs-buffer-list-function))
(groups
@@ -354,6 +397,7 @@ If the major mode's name string matches REGEXP, use GROUPNAME instead.")
(set-window-parameter nil 'tab-line-group nil))))
(group-tab `(tab
(name . ,group)
+ (group-tab . t)
(select . ,(lambda ()
(set-window-parameter nil 'tab-line-groups t)
(set-window-parameter nil 'tab-line-group group)
@@ -399,39 +443,59 @@ variable `tab-line-tabs-function'."
next-buffers)))
+(defcustom tab-line-tab-name-format-function #'tab-line-tab-name-format-default
+ "Function to format a tab name.
+Function gets two arguments: the tab and a list of all tabs, and
+should return the formatted tab name to display in the tab line."
+ :type 'function
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (force-mode-line-update))
+ :group 'tab-line
+ :version "28.1")
+
+(defun tab-line-tab-name-format-default (tab tabs)
+ (let* ((buffer-p (bufferp tab))
+ (selected-p (if buffer-p
+ (eq tab (window-buffer))
+ (cdr (assq 'selected tab))))
+ (name (if buffer-p
+ (funcall tab-line-tab-name-function tab tabs)
+ (cdr (assq 'name tab))))
+ (face (if selected-p
+ (if (eq (selected-window) (old-selected-window))
+ 'tab-line-tab-current
+ 'tab-line-tab)
+ 'tab-line-tab-inactive)))
+ (dolist (fn tab-line-tab-face-functions)
+ (setf face (funcall fn tab tabs face buffer-p selected-p)))
+ (apply 'propertize
+ (concat (propertize name
+ 'keymap tab-line-tab-map
+ ;; Don't turn mouse-1 into mouse-2 (bug#49247)
+ 'follow-link 'ignore)
+ (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab))
+ tab-line-close-button-show
+ (not (eq tab-line-close-button-show
+ (if selected-p 'non-selected 'selected)))
+ tab-line-close-button)
+ ""))
+ `(
+ tab ,tab
+ ,@(if selected-p '(selected t))
+ face ,face
+ mouse-face tab-line-highlight))))
+
(defun tab-line-format-template (tabs)
"Template for displaying tab line for selected window."
- (let* ((selected-buffer (window-buffer))
- (separator (or tab-line-separator (if window-system " " "|")))
+ (let* ((separator (or tab-line-separator (if window-system " " "|")))
(hscroll (window-parameter nil 'tab-line-hscroll))
(strings
(mapcar
(lambda (tab)
- (let* ((buffer-p (bufferp tab))
- (selected-p (if buffer-p
- (eq tab selected-buffer)
- (cdr (assq 'selected tab))))
- (name (if buffer-p
- (funcall tab-line-tab-name-function tab tabs)
- (cdr (assq 'name tab)))))
- (concat
- separator
- (apply 'propertize
- (concat (propertize name 'keymap tab-line-tab-map)
- (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab))
- tab-line-close-button-show
- (not (eq tab-line-close-button-show
- (if selected-p 'non-selected 'selected)))
- tab-line-close-button) ""))
- `(
- tab ,tab
- ,@(if selected-p '(selected t))
- face ,(if selected-p
- (if (eq (selected-window) (old-selected-window))
- 'tab-line-tab-current
- 'tab-line-tab)
- 'tab-line-tab-inactive)
- mouse-face tab-line-highlight)))))
+ (concat separator
+ (funcall tab-line-tab-name-format-function tab tabs)))
tabs))
(hscroll-data (tab-line-auto-hscroll strings hscroll)))
(setq hscroll (nth 1 hscroll-data))
@@ -454,6 +518,31 @@ variable `tab-line-tabs-function'."
tab-line-new-button)
(list tab-line-new-button)))))
+(defun tab-line-tab-face-inactive-alternating (tab tabs face _buffer-p selected-p)
+ "Return FACE for TAB in TABS with alternation.
+When TAB is an inactive buffer and is even-numbered, make FACE
+inherit from `tab-line-tab-inactive-alternate'. For use in
+`tab-line-tab-face-functions'."
+ (when (and (not selected-p) (cl-evenp (cl-position tab tabs)))
+ (setf face `(:inherit (tab-line-tab-inactive-alternate ,face))))
+ face)
+
+(defun tab-line-tab-face-special (tab _tabs face buffer-p _selected-p)
+ "Return FACE for TAB according to whether it's special.
+When TAB is a non-file-backed buffer, make FACE inherit from
+`tab-line-tab-special'. For use in
+`tab-line-tab-face-functions'."
+ (when (and buffer-p (not (buffer-file-name tab)))
+ (setf face `(:inherit (tab-line-tab-special ,face))))
+ face)
+
+(defun tab-line-tab-face-group (tab _tabs face _buffer-p _selected-p)
+ "Return FACE for TAB according to whether it's a group tab.
+For use in `tab-line-tab-face-functions'."
+ (when (alist-get 'group-tab tab)
+ (setf face `(:inherit (tab-line-tab-group ,face))))
+ face)
+
(defvar tab-line-auto-hscroll)
(defun tab-line-format ()
@@ -599,7 +688,9 @@ corresponding to the switched buffer."
(if (functionp tab-line-new-tab-choice)
(funcall tab-line-new-tab-choice)
(let ((tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups))
- (if (and (listp mouse-event) window-system) ; (display-popup-menus-p)
+ (if (and (listp mouse-event)
+ (display-popup-menus-p)
+ (not tty-menu-open-use-tmm))
(mouse-buffer-menu mouse-event) ; like (buffer-menu-open)
;; tty menu doesn't support mouse clicks, so use tmm
(tmm-prompt (mouse-buffer-menu-keymap))))))
@@ -642,6 +733,16 @@ using the `previous-buffer' command."
(with-selected-window window
(switch-to-buffer buffer))))))
+(defcustom tab-line-switch-cycling nil
+ "Enable cycling tab switch.
+If non-nil, `tab-line-switch-to-prev-tab' in the first tab
+switches to the last tab and `tab-line-switch-to-next-tab' in the
+last tab switches to the first tab. This variable is not consulted
+when `tab-line-tabs-function' is `tab-line-tabs-window-buffers'."
+ :type 'boolean
+ :group 'tab-line
+ :version "28.1")
+
(defun tab-line-switch-to-prev-tab (&optional mouse-event)
"Switch to the previous tab.
Its effect is the same as using the `previous-buffer' command
@@ -652,13 +753,16 @@ Its effect is the same as using the `previous-buffer' command
(switch-to-prev-buffer window)
(with-selected-window (or window (selected-window))
(let* ((tabs (funcall tab-line-tabs-function))
- (tab (nth (1- (seq-position
- tabs (current-buffer)
- (lambda (tab buffer)
- (if (bufferp tab)
- (eq buffer tab)
- (eq buffer (cdr (assq 'buffer tab)))))))
- tabs))
+ (pos (seq-position
+ tabs (current-buffer)
+ (lambda (tab buffer)
+ (if (bufferp tab)
+ (eq buffer tab)
+ (eq buffer (cdr (assq 'buffer tab)))))))
+ (tab (if pos
+ (if (and tab-line-switch-cycling (<= pos 0))
+ (nth (1- (length tabs)) tabs)
+ (nth (1- pos) tabs))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
(when (bufferp buffer)
(switch-to-buffer buffer)))))))
@@ -673,13 +777,16 @@ Its effect is the same as using the `next-buffer' command
(switch-to-next-buffer window)
(with-selected-window (or window (selected-window))
(let* ((tabs (funcall tab-line-tabs-function))
- (tab (nth (1+ (seq-position
- tabs (current-buffer)
- (lambda (tab buffer)
- (if (bufferp tab)
- (eq buffer tab)
- (eq buffer (cdr (assq 'buffer tab)))))))
- tabs))
+ (pos (seq-position
+ tabs (current-buffer)
+ (lambda (tab buffer)
+ (if (bufferp tab)
+ (eq buffer tab)
+ (eq buffer (cdr (assq 'buffer tab)))))))
+ (tab (if pos
+ (if (and tab-line-switch-cycling (<= (length tabs) (1+ pos)))
+ (car tabs)
+ (nth (1+ pos) tabs))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
(when (bufferp buffer)
(switch-to-buffer buffer)))))))
@@ -740,9 +847,7 @@ from the tab line."
:version "27.1")
;;;###autoload
-(defvar tab-line-exclude nil)
-;;;###autoload
-(make-variable-buffer-local 'tab-line-exclude)
+(defvar-local tab-line-exclude nil)
(defun tab-line-mode--turn-on ()
"Turn on `tab-line-mode'."
@@ -764,11 +869,15 @@ from the tab line."
(global-set-key [tab-line mouse-5] 'tab-line-hscroll-right)
(global-set-key [tab-line wheel-up] 'tab-line-hscroll-left)
(global-set-key [tab-line wheel-down] 'tab-line-hscroll-right)
+(global-set-key [tab-line wheel-left] 'tab-line-hscroll-left)
+(global-set-key [tab-line wheel-right] 'tab-line-hscroll-right)
(global-set-key [tab-line S-mouse-4] 'tab-line-switch-to-prev-tab)
(global-set-key [tab-line S-mouse-5] 'tab-line-switch-to-next-tab)
(global-set-key [tab-line S-wheel-up] 'tab-line-switch-to-prev-tab)
(global-set-key [tab-line S-wheel-down] 'tab-line-switch-to-next-tab)
+(global-set-key [tab-line S-wheel-left] 'tab-line-switch-to-prev-tab)
+(global-set-key [tab-line S-wheel-right] 'tab-line-switch-to-next-tab)
(provide 'tab-line)
diff --git a/lisp/talk.el b/lisp/talk.el
index b047955284e..56d36dd8df4 100644
--- a/lisp/talk.el
+++ b/lisp/talk.el
@@ -1,4 +1,4 @@
-;;; talk.el --- allow several users to talk to each other through Emacs
+;;; talk.el --- allow several users to talk to each other through Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
;;; Commentary:
;; This is a multi-user talk package that runs in Emacs.
-;; Use talk-connect to bring a new person into the conversation.
+;; Use `talk-connect' to bring a new person into the conversation.
;;; Code:
@@ -90,7 +90,7 @@ Each element has the form (DISPLAY FRAME BUFFER).")
(let ((frame (nth 1 (car tail)))
(this-buffer (nth 2 (car tail)))
(buffers
- (mapcar (function (lambda (elt) (nth 2 elt)))
+ (mapcar (lambda (elt) (nth 2 elt))
talk-display-alist)))
;; Put this display's own talk buffer
;; at the front of the list.
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index 01a8885292c..3f0cca0ab7a 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -37,13 +37,6 @@
;; This code now understands the extra fields that GNU tar adds to tar files.
-;; This interacts correctly with "uncompress.el" in the Emacs library,
-;; which you get with
-;;
-;; (autoload 'uncompress-while-visiting "uncompress")
-;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting)
-;; auto-mode-alist))
-;;
;; Do not attempt to use tar-mode.el with crypt.el, you will lose.
;; *************** TO DO ***************
@@ -156,12 +149,11 @@ This information is useful, but it takes screen space away from file names."
;; So instead, we now keep the two pieces of data in separate buffers, and
;; use the new buffer-swap-text primitive when we need to change which data
;; is associated with "the" buffer.
-(defvar tar-data-buffer nil "Buffer that holds the actual raw tar bytes.")
-(make-variable-buffer-local 'tar-data-buffer)
+(defvar-local tar-data-buffer nil
+ "Buffer that holds the actual raw tar bytes.")
-(defvar tar-data-swapped nil
+(defvar-local tar-data-swapped nil
"If non-nil, `tar-data-buffer' indeed holds raw tar bytes.")
-(make-variable-buffer-local 'tar-data-swapped)
(defun tar-data-swapped-p ()
"Return non-nil if the tar-data is in `tar-data-buffer'."
@@ -480,23 +472,10 @@ checksum before doing the check."
(defun tar-grind-file-mode (mode)
"Construct a `rw-r--r--' string indicating MODE.
-MODE should be an integer which is a file mode value."
- (string
- (if (zerop (logand 256 mode)) ?- ?r)
- (if (zerop (logand 128 mode)) ?- ?w)
- (if (zerop (logand 2048 mode))
- (if (zerop (logand 64 mode)) ?- ?x)
- (if (zerop (logand 64 mode)) ?S ?s))
- (if (zerop (logand 32 mode)) ?- ?r)
- (if (zerop (logand 16 mode)) ?- ?w)
- (if (zerop (logand 1024 mode))
- (if (zerop (logand 8 mode)) ?- ?x)
- (if (zerop (logand 8 mode)) ?S ?s))
- (if (zerop (logand 4 mode)) ?- ?r)
- (if (zerop (logand 2 mode)) ?- ?w)
- (if (zerop (logand 512 mode))
- (if (zerop (logand 1 mode)) ?- ?x)
- (if (zerop (logand 1 mode)) ?T ?t))))
+MODE should be an integer which is a file mode value.
+For instance, if mode is #o700, then it produces `rwx------'."
+ (declare (obsolete file-modes-number-to-symbolic "28.1"))
+ (substring (file-modes-number-to-symbolic mode) 1))
(defun tar-header-block-summarize (tar-hblock &optional mod-p)
"Return a line similar to the output of `tar -vtf'."
@@ -511,25 +490,26 @@ MODE should be an integer which is a file mode value."
;; (ck (tar-header-checksum tar-hblock))
(type (tar-header-link-type tar-hblock))
(link-name (tar-header-link-name tar-hblock)))
- (format "%c%c%s %7s/%-7s %7s%s %s%s"
+ (format "%c%s %7s/%-7s %7s%s %s%s"
(if mod-p ?* ? )
- (cond ((or (eq type nil) (eq type 0)) ?-)
- ((eq type 1) ?h) ; link
- ((eq type 2) ?l) ; symlink
- ((eq type 3) ?c) ; char special
- ((eq type 4) ?b) ; block special
- ((eq type 5) ?d) ; directory
- ((eq type 6) ?p) ; FIFO/pipe
- ((eq type 20) ?*) ; directory listing
- ((eq type 28) ?L) ; next has longname
- ((eq type 29) ?M) ; multivolume continuation
- ((eq type 35) ?S) ; sparse
- ((eq type 38) ?V) ; volume header
- ((eq type 55) ?H) ; pax global extended header
- ((eq type 72) ?X) ; pax extended header
- (t ?\s)
- )
- (tar-grind-file-mode mode)
+ (file-modes-number-to-symbolic
+ mode
+ (cond ((or (eq type nil) (eq type 0)) ?-)
+ ((eq type 1) ?h) ; link
+ ((eq type 2) ?l) ; symlink
+ ((eq type 3) ?c) ; char special
+ ((eq type 4) ?b) ; block special
+ ((eq type 5) ?d) ; directory
+ ((eq type 6) ?p) ; FIFO/pipe
+ ((eq type 20) ?*) ; directory listing
+ ((eq type 28) ?L) ; next has longname
+ ((eq type 29) ?M) ; multivolume continuation
+ ((eq type 35) ?S) ; sparse
+ ((eq type 38) ?V) ; volume header
+ ((eq type 55) ?H) ; pax global extended header
+ ((eq type 72) ?X) ; pax extended header
+ (t ?\s)
+ ))
(if (= 0 (length uname)) uid uname)
(if (= 0 (length gname)) gid gname)
size
@@ -609,7 +589,7 @@ MODE should be an integer which is a file mode value."
(setq pos (tar-header-data-end descriptor))
(progress-reporter-update progress-reporter pos)))
- (set (make-local-variable 'tar-parse-info) (nreverse result))
+ (setq-local tar-parse-info (nreverse result))
;; A tar file should end with a block or two of nulls,
;; but let's not get a fatal error if it doesn't.
(if (null descriptor)
@@ -657,54 +637,38 @@ MODE should be an integer which is a file mode value."
;; Let mouse-1 follow the link.
(define-key map [follow-link] 'mouse-face)
- ;; Make menu bar items.
-
;; Get rid of the Edit menu bar item to save space.
(define-key map [menu-bar edit] 'undefined)
- (define-key map [menu-bar immediate]
- (cons "Immediate" (make-sparse-keymap "Immediate")))
-
- (define-key map [menu-bar immediate woman]
- '("Read Man Page (WoMan)" . woman-tar-extract-file))
- (define-key map [menu-bar immediate view]
- '("View This File" . tar-view))
- (define-key map [menu-bar immediate display]
- '("Display in Other Window" . tar-display-other-window))
- (define-key map [menu-bar immediate find-file-other-window]
- '("Find in Other Window" . tar-extract-other-window))
- (define-key map [menu-bar immediate find-file]
- '("Find This File" . tar-extract))
-
- (define-key map [menu-bar mark]
- (cons "Mark" (make-sparse-keymap "Mark")))
-
- (define-key map [menu-bar mark unmark-all]
- '("Unmark All" . tar-clear-modification-flags))
- (define-key map [menu-bar mark deletion]
- '("Flag" . tar-flag-deleted))
- (define-key map [menu-bar mark unmark]
- '("Unflag" . tar-unflag))
-
- (define-key map [menu-bar operate]
- (cons "Operate" (make-sparse-keymap "Operate")))
-
- (define-key map [menu-bar operate chown]
- '("Change Owner..." . tar-chown-entry))
- (define-key map [menu-bar operate chgrp]
- '("Change Group..." . tar-chgrp-entry))
- (define-key map [menu-bar operate chmod]
- '("Change Mode..." . tar-chmod-entry))
- (define-key map [menu-bar operate rename]
- '("Rename to..." . tar-rename-entry))
- (define-key map [menu-bar operate copy]
- '("Copy to..." . tar-copy))
- (define-key map [menu-bar operate expunge]
- '("Expunge Marked Files" . tar-expunge))
-
map)
"Local keymap for Tar mode listings.")
+(easy-menu-define tar-mode-immediate-menu tar-mode-map
+ "Immediate menu for Tar mode."
+ '("Immediate"
+ ["Find This File" tar-extract]
+ ["Find in Other Window" tar-extract-other-window]
+ ["Display in Other Window" tar-display-other-window]
+ ["View This File" tar-view]
+ ["Read Man Page (WoMan)" woman-tar-extract-file]))
+
+(easy-menu-define tar-mode-mark-menu tar-mode-map
+ "Mark menu for Tar mode."
+ '("Mark"
+ ["Unflag" tar-unflag]
+ ["Flag" tar-flag-deleted]
+ ["Unmark All" tar-clear-modification-flags]))
+
+(easy-menu-define tar-mode-operate-menu tar-mode-map
+ "Operate menu for Tar mode."
+ '("Operate"
+ ["Expunge Marked Files" tar-expunge]
+ ["Copy to..." tar-copy]
+ ["Rename to..." tar-rename-entry]
+ ["Change Mode..." tar-chmod-entry]
+ ["Change Group..." tar-chgrp-entry]
+ ["Change Owner..." tar-chown-entry]))
+
;; tar mode is suitable only for specially formatted data.
(put 'tar-mode 'mode-class 'special)
@@ -723,12 +687,12 @@ MODE should be an integer which is a file mode value."
(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.
-Type `e' to pull a file out of the tar file and into its own buffer;
+Letters no longer insert themselves.\\<tar-mode-map>
+Type \\[tar-extract] to pull a file out of the tar file and into its own buffer;
or click mouse-2 on the file's line in the Tar mode buffer.
-Type `c' to copy an entry from the tar file into another file on disk.
+Type \\[tar-copy] to copy an entry from the tar file into another file on disk.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[tar-extract] command) and
save it with \\[save-buffer], the contents of that buffer will be
saved back into the tar-file buffer; in this way you can edit a file
inside of a tar archive without extracting it and re-archiving it.
@@ -739,21 +703,21 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
(file-writable-p buffer-file-name)
(setq buffer-read-only nil)) ; undo what `special-mode' did
(make-local-variable 'tar-parse-info)
- (set (make-local-variable 'require-final-newline) nil) ; binary data, dude...
- (set (make-local-variable 'local-enable-local-variables) nil)
- (set (make-local-variable 'next-line-add-newlines) nil)
- (set (make-local-variable 'tar-file-name-coding-system)
- (or file-name-coding-system
- default-file-name-coding-system
- locale-coding-system))
+ (setq-local require-final-newline nil) ; binary data, dude...
+ (setq-local local-enable-local-variables nil)
+ (setq-local next-line-add-newlines nil)
+ (setq-local tar-file-name-coding-system
+ (or file-name-coding-system
+ default-file-name-coding-system
+ locale-coding-system))
;; Prevent loss of data when saving the file.
- (set (make-local-variable 'file-precious-flag) t)
+ (setq-local file-precious-flag t)
(buffer-disable-undo)
(widen)
;; Now move the Tar data into an auxiliary buffer, so we can use the main
;; buffer for the summary.
(cl-assert (not (tar-data-swapped-p)))
- (set (make-local-variable 'revert-buffer-function) #'tar-mode-revert)
+ (setq-local revert-buffer-function #'tar-mode-revert)
;; We started using write-contents-functions, but this hook is not
;; used during auto-save, so we now use
;; write-region-annotate-functions which hooks at a lower-level.
@@ -762,10 +726,10 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
(add-hook 'change-major-mode-hook #'tar-change-major-mode-hook nil t)
;; Tar data is made of bytes, not chars.
(set-buffer-multibyte nil) ;Hopefully a no-op.
- (set (make-local-variable 'tar-data-buffer)
- (generate-new-buffer (format " *tar-data %s*"
- (file-name-nondirectory
- (or buffer-file-name (buffer-name))))))
+ (setq-local tar-data-buffer (generate-new-buffer
+ (format " *tar-data %s*"
+ (file-name-nondirectory
+ (or buffer-file-name (buffer-name))))))
(condition-case err
(progn
(tar-swap-data)
@@ -789,7 +753,7 @@ into the tar-file buffer that it came from. The changes will
actually appear on disk when you save the tar-file's buffer."
;; Don't do this, because it is redundant and wastes mode line space.
;; :lighter " TarFile"
- nil nil nil
+ :lighter nil
(or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
(error "This buffer is not an element of a tar file"))
(cond (tar-subfile-mode
@@ -936,6 +900,56 @@ actually appear on disk when you save the tar-file's buffer."
(setq buffer-undo-list nil))))
buffer))
+(defun tar-goto-file (file)
+ "Go to FILE in the current buffer.
+FILE should be a relative file name. If FILE can't be found,
+return nil. Otherwise point is returned."
+ (let ((start (point))
+ found)
+ (goto-char (point-min))
+ (while (and (not found)
+ (not (eobp)))
+ (forward-line 1)
+ (when-let ((descriptor (ignore-errors (tar-get-descriptor))))
+ (when (equal (tar-header-name descriptor) file)
+ (setq found t))))
+ (if (not found)
+ (progn
+ (goto-char start)
+ nil)
+ (point))))
+
+(defun tar-next-file-displayer (file regexp n)
+ "Return a closure to display the next file after FILE that matches REGEXP."
+ (let ((short (replace-regexp-in-string "\\`.*!" "" file))
+ next)
+ ;; The tar buffer chops off leading "./", so do the same
+ ;; here.
+ (setq short (replace-regexp-in-string "\\`\\./" "" file))
+ (tar-goto-file short)
+ (while (and (not next)
+ ;; Stop if we reach the end/start of the buffer.
+ (if (> n 0)
+ (not (eobp))
+ (not (save-excursion
+ (beginning-of-line)
+ (bobp)))))
+ (tar-next-line n)
+ (when-let ((descriptor (ignore-errors (tar-get-descriptor))))
+ (let ((candidate (tar-header-name descriptor))
+ (buffer (current-buffer)))
+ (when (and candidate
+ (string-match-p regexp candidate))
+ (setq next (lambda ()
+ (kill-buffer (current-buffer))
+ (switch-to-buffer buffer)
+ (tar-extract)))))))
+ (unless next
+ ;; If we didn't find a next/prev file, then restore
+ ;; point.
+ (tar-goto-file short))
+ next))
+
(defun tar-extract (&optional other-window-p)
"In Tar mode, extract this entry of the tar file into its own buffer."
(interactive)
@@ -975,8 +989,8 @@ actually appear on disk when you save the tar-file's buffer."
default-directory))
(set-buffer-modified-p nil)
(normal-mode) ; pick a mode.
- (set (make-local-variable 'tar-superior-buffer) tar-buffer)
- (set (make-local-variable 'tar-superior-descriptor) descriptor)
+ (setq-local tar-superior-buffer tar-buffer)
+ (setq-local tar-superior-descriptor descriptor)
(setq buffer-read-only read-only-p)
(tar-subfile-mode 1)))
(cond
@@ -1056,7 +1070,7 @@ extracted file."
(write-region start end to-file nil nil nil t))
(when (and tar-copy-preserve-time
date)
- (set-file-times to-file date)))
+ (set-file-times to-file date 'nofollow)))
(message "Copied tar entry %s to %s" name to-file)))
(defun tar-new-entry (filename &optional index)
diff --git a/lisp/tempo.el b/lisp/tempo.el
index aa8ca6dcca5..87e274a527c 100644
--- a/lisp/tempo.el
+++ b/lisp/tempo.el
@@ -75,7 +75,7 @@
;; ftp.lysator.liu.se in the directory /pub/emacs
;; There is also a WWW page at
-;; http://www.lysator.liu.se/~davidk/elisp/ which has some information
+;; https://www.lysator.liu.se/~davidk/elisp/ which has some information
;;; Known bugs:
@@ -220,7 +220,9 @@ list of elements in the template, TAG is the tag used for completion,
DOCUMENTATION is the documentation string for the insertion command
created, and TAGLIST (a symbol) is the tag list that TAG (if provided)
should be added to. If TAGLIST is nil and TAG is non-nil, TAG is
-added to `tempo-tags'.
+added to `tempo-tags'. If TAG already corresponds to a template in
+the tag list, modify the list so that TAG now corresponds to the newly
+defined template.
The elements in ELEMENTS can be of several types:
@@ -304,8 +306,8 @@ mode, ON-REGION is ignored and assumed true if the region is active."
(goto-char tempo-region-start))
(save-excursion
(tempo-insert-mark (point-marker))
- (mapc (function (lambda (elt)
- (tempo-insert elt on-region)))
+ (mapc (lambda (elt)
+ (tempo-insert elt on-region))
(symbol-value template))
(tempo-insert-mark (point-marker)))
(tempo-forward-mark))
@@ -351,9 +353,8 @@ possible."
((and (consp element)
(eq (car element) 's)) (tempo-insert-named (car (cdr element))))
((and (consp element)
- (eq (car element) 'l)) (mapcar (function
- (lambda (elt)
- (tempo-insert elt on-region)))
+ (eq (car element) 'l)) (mapcar (lambda (elt)
+ (tempo-insert elt on-region))
(cdr element)))
((eq element 'p) (tempo-insert-mark (point-marker)))
((eq element 'r) (if on-region
@@ -447,9 +448,9 @@ never prompted."
"Tries all the user-defined element handlers in `tempo-user-elements'."
;; Sigh... I need (some list)
(catch 'found
- (mapc (function (lambda (handler)
- (let ((result (funcall handler element)))
- (if result (throw 'found result)))))
+ (mapc (lambda (handler)
+ (let ((result (funcall handler element)))
+ (if result (throw 'found result))))
tempo-user-elements)
(throw 'found nil)))
@@ -544,10 +545,9 @@ and insert the results."
(interactive)
(let ((next-mark (catch 'found
(mapc
- (function
- (lambda (mark)
- (if (< (point) mark)
- (throw 'found mark))))
+ (lambda (mark)
+ (if (< (point) mark)
+ (throw 'found mark)))
tempo-marks)
;; return nil if not found
nil)))
@@ -563,11 +563,10 @@ and insert the results."
(let ((prev-mark (catch 'found
(let (last)
(mapc
- (function
- (lambda (mark)
- (if (<= (point) mark)
- (throw 'found last))
- (setq last mark)))
+ (lambda (mark)
+ (if (<= (point) mark)
+ (throw 'found last))
+ (setq last mark))
tempo-marks)
last))))
(if prev-mark
@@ -579,14 +578,20 @@ and insert the results."
(defun tempo-add-tag (tag template &optional tag-list)
"Add a template tag.
Add the TAG, that should complete to TEMPLATE to the list in TAG-LIST,
-or to `tempo-tags' if TAG-LIST is nil."
+or to `tempo-tags' if TAG-LIST is nil. If TAG was already in the list,
+replace its template with TEMPLATE."
(interactive "sTag: \nCTemplate: ")
(if (null tag-list)
(setq tag-list 'tempo-tags))
- (if (not (assoc tag (symbol-value tag-list)))
- (set tag-list (cons (cons tag template) (symbol-value tag-list))))
- (tempo-invalidate-collection))
+ (let ((entry (assoc tag (symbol-value tag-list))))
+ (if entry
+ ;; Tag is already in the list, assign a new template to it.
+ (setcdr entry template)
+ ;; Tag is not present in the list, add it with its template.
+ (set tag-list (cons (cons tag template) (symbol-value tag-list)))))
+ ;; Invalidate globally if we're modifying 'tempo-tags'.
+ (tempo-invalidate-collection (eq tag-list 'tempo-tags)))
;;;
;;; tempo-use-tag-list
@@ -609,10 +614,17 @@ COMPLETION-FUNCTION just sets `tempo-match-finder' locally."
;;;
;;; tempo-invalidate-collection
-(defun tempo-invalidate-collection ()
+(defun tempo-invalidate-collection (&optional global)
"Marks the tag collection as obsolete.
-Whenever it is needed again it will be rebuilt."
- (setq tempo-dirty-collection t))
+Whenever it is needed again it will be rebuilt. If GLOBAL is non-nil,
+mark the tag collection of all buffers as obsolete, not just the
+current one."
+ (if global
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (assq 'tempo-dirty-collection (buffer-local-variables))
+ (setq tempo-dirty-collection t))))
+ (setq tempo-dirty-collection t)))
;;;
;;; tempo-build-collection
@@ -625,11 +637,11 @@ If `tempo-dirty-collection' is nil, the old collection is reused."
tempo-collection)
(setq tempo-collection
(apply (function append)
- (mapcar (function (lambda (tag-list)
+ (mapcar (lambda (tag-list)
; If the format for
; tempo-local-tags changes,
; change this
- (eval (car tag-list))))
+ (eval (car tag-list)))
tempo-local-tags))))
(setq tempo-dirty-collection nil)))
diff --git a/lisp/term.el b/lisp/term.el
index c296e9eef0b..27f0bb1be3b 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -123,13 +123,12 @@
;; full advantage of this package
;;
;; (add-hook 'term-mode-hook
-;; (function
-;; (lambda ()
-;; (setq term-prompt-regexp "^[^#$%>\n]*[#$%>] *")
-;; (setq-local mouse-yank-at-point t)
-;; (setq-local transient-mark-mode nil)
-;; (auto-fill-mode -1)
-;; (setq tab-width 8 ))))
+;; (lambda ()
+;; (setq term-prompt-regexp "^[^#$%>\n]*[#$%>] *")
+;; (setq-local mouse-yank-at-point t)
+;; (setq-local transient-mark-mode nil)
+;; (auto-fill-mode -1)
+;; (setq tab-width 8)))
;;
;; ----------------------------------------
;;
@@ -241,9 +240,9 @@
;; printf '\033AnSiTu %s\n' "$USER"
;; printf '\033AnSiTc %s\n' "$PWD"
;;
-;; cd() { command cd "$@"; printf '\033AnSiTc %s\n' "$PWD"; }
-;; pushd() { command pushd "$@"; printf '\033AnSiTc %s\n' "$PWD"; }
-;; popd() { command popd "$@"; printf '\033AnSiTc %s\n' "$PWD"; }
+;; cd() { command cd "$@" && printf '\033AnSiTc %s\n' "$PWD"; }
+;; pushd() { command pushd "$@" && printf '\033AnSiTc %s\n' "$PWD"; }
+;; popd() { command popd "$@" && printf '\033AnSiTc %s\n' "$PWD"; }
;;
;; # Use custom dircolors in term buffers.
;; # eval $(dircolors $HOME/.emacs_dircolors)
@@ -265,7 +264,7 @@
;; M-p term-previous-input Cycle backwards in input history
;; M-n term-next-input Cycle forwards
;; M-r term-previous-matching-input Previous input matching a regexp
-;; M-s comint-next-matching-input Next input that matches
+;; M-s term-next-matching-input Next input that matches
;; return term-send-input
;; C-c C-a term-bol Beginning of line; skip prompt.
;; C-d term-delchar-or-maybe-eof Delete char unless at end of buff.
@@ -300,17 +299,13 @@
;; so it is important to increase it if there are protocol-relevant changes.
(defconst term-protocol-version "0.96")
-(eval-when-compile (require 'ange-ftp))
-(eval-when-compile (require 'cl-lib))
-(require 'ring)
-(require 'ehelp)
+(eval-when-compile
+ (require 'ange-ftp)
+ (require 'cl-lib))
(require 'comint) ; Password regexp.
-
-(declare-function ring-empty-p "ring" (ring))
-(declare-function ring-ref "ring" (ring index))
-(declare-function ring-insert-at-beginning "ring" (ring item))
-(declare-function ring-length "ring" (ring))
-(declare-function ring-insert "ring" (ring item))
+(require 'ehelp)
+(require 'ring)
+(require 'shell)
(defgroup term nil
"General command interpreter in a window."
@@ -370,8 +365,8 @@ not allowed.")
(defvar-local term-scroll-end nil
"Bottom-most line (inclusive) of the scrolling region.
`term-scroll-end' must be in the range [0,term-height). In addition, its
-value has to be greater than `term-scroll-start', i.e. one line scroll regions are
-not allowed.")
+value has to be greater than `term-scroll-start', i.e. one line scroll regions
+are not allowed.")
(defvar term-pager-count nil
"Number of lines before we need to page; if nil, paging is disabled.")
(defvar term-saved-cursor nil)
@@ -394,11 +389,6 @@ by moving term-home-marker. It is set to t if there is a
(defvar-local term-line-mode-buffer-read-only nil
"The `buffer-read-only' state to set in `term-line-mode'.")
-(defcustom explicit-shell-file-name nil
- "If non-nil, is file name to use for explicitly requested inferior shell."
- :type '(choice (const nil) file)
- :group 'term)
-
(defvar term-prompt-regexp "^"
"Regexp to recognize prompts in the inferior process.
Defaults to \"^\", the null string at BOL.
@@ -467,6 +457,11 @@ Customize this option to nil if you want the previous behavior."
:type 'boolean
:group 'term)
+(defcustom term-set-terminal-size nil
+ "If non-nil, set the LINES and COLUMNS environment variables."
+ :type 'boolean
+ :version "28.1")
+
(defcustom term-char-mode-point-at-process-mark t
"If non-nil, keep point at the process mark in char mode.
@@ -501,6 +496,14 @@ This variable is buffer-local."
:type 'boolean
:group 'term)
+(defcustom term-scroll-snap-to-bottom t
+ "Control whether to keep the prompt at the bottom of the window.
+If non-nil, when the prompt is visible within the window, then
+scroll so that the prompt is on the bottom on any input or
+output."
+ :version "28.1"
+ :type 'boolean)
+
(defcustom term-scroll-show-maximum-output nil
"Controls how interpreter output causes window to scroll.
If non-nil, then show the maximum output when the window is scrolled.
@@ -541,7 +544,7 @@ See also `term-dynamic-complete'.
This is a good thing to set in mode hooks.")
(defvar term-input-filter
- (function (lambda (str) (not (string-match "\\`\\s *\\'" str))))
+ (lambda (str) (not (string-match "\\`\\s *\\'" str)))
"Predicate for filtering additions to input history.
Only inputs answering true to this function are saved on the input
history list. Default is to save anything that isn't all whitespace.")
@@ -680,8 +683,7 @@ Buffer local variable.")
"Index of last matched history element.")
(defvar term-matching-input-from-input-string ""
"Input previously used to match input history.")
-; This argument to set-process-filter disables reading from the process,
-; assuming this is Emacs 19.20 or newer.
+; This argument to set-process-filter disables reading from the process.
(defvar term-pager-filter t)
(put 'term-input-ring 'permanent-local t)
@@ -847,6 +849,7 @@ is buffer-local."
(define-key map [prior] 'term-send-prior)
(define-key map [next] 'term-send-next)
(define-key map [xterm-paste] #'term--xterm-paste)
+ (define-key map [?\C-/] #'term-send-C-_)
map)
"Keyboard map for sending characters directly to the inferior process.")
@@ -861,8 +864,30 @@ is buffer-local."
["Paging" term-pager-toggle :style toggle :selected term-pager-count
:help "Toggle paging feature"]))
+(defun term--update-term-menu (&optional force)
+ (when (and (lookup-key term-mode-map [menu-bar terminal])
+ (or force (frame-or-buffer-changed-p)))
+ (let ((buffer-list
+ (seq-filter
+ (lambda (buffer)
+ (provided-mode-derived-p (buffer-local-value 'major-mode buffer)
+ 'term-mode))
+ (buffer-list))))
+ (easy-menu-change
+ '("Terminal")
+ "Terminal Buffers"
+ (mapcar
+ (lambda (buffer)
+ (vector (format "%s (%s)" (buffer-name buffer)
+ (abbreviate-file-name
+ (buffer-local-value 'default-directory buffer)))
+ (lambda ()
+ (interactive)
+ (switch-to-buffer buffer))))
+ buffer-list)))))
+
(easy-menu-define term-signals-menu
- (list term-mode-map term-raw-map term-pager-break-map)
+ (list term-mode-map term-raw-map term-pager-break-map)
"Signals menu for Term mode."
'("Signals"
["BREAK" term-interrupt-subjob :active t
@@ -1001,12 +1026,12 @@ Entry to this mode runs the hooks on `term-mode-hook'."
;; we do not want indent to sneak in any tabs
(setq indent-tabs-mode nil)
(setq buffer-display-table term-display-table)
- (set (make-local-variable 'term-home-marker) (copy-marker 0))
- (set (make-local-variable 'term-height) (floor (window-screen-lines)))
- (set (make-local-variable 'term-width) (window-max-chars-per-line))
- (set (make-local-variable 'term-last-input-start) (make-marker))
- (set (make-local-variable 'term-last-input-end) (make-marker))
- (set (make-local-variable 'term-last-input-match) "")
+ (setq-local term-home-marker (copy-marker 0))
+ (setq-local term-height (floor (window-screen-lines)))
+ (setq-local term-width (window-max-chars-per-line))
+ (setq-local term-last-input-start (make-marker))
+ (setq-local term-last-input-end (make-marker))
+ (setq-local term-last-input-match "")
;; These local variables are set to their local values:
(make-local-variable 'term-saved-home-marker)
@@ -1024,9 +1049,9 @@ Entry to this mode runs the hooks on `term-mode-hook'."
;; a properly configured ange-ftp, I've decided to be conservative
;; and put them in. -mm
- (set (make-local-variable 'term-ansi-at-host) (system-name))
- (set (make-local-variable 'term-ansi-at-dir) default-directory)
- (set (make-local-variable 'term-ansi-at-message) nil)
+ (setq-local term-ansi-at-host (system-name))
+ (setq-local term-ansi-at-dir default-directory)
+ (setq-local term-ansi-at-message nil)
;; For user tracking purposes -mm
(make-local-variable 'ange-ftp-default-user)
@@ -1069,15 +1094,16 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(make-local-variable 'term-scroll-to-bottom-on-output)
(make-local-variable 'term-scroll-show-maximum-output)
(make-local-variable 'term-ptyp)
- (set (make-local-variable 'term-vertical-motion) 'vertical-motion)
- (set (make-local-variable 'term-pending-delete-marker) (make-marker))
+ (setq-local term-vertical-motion 'vertical-motion)
+ (setq-local term-pending-delete-marker (make-marker))
(make-local-variable 'term-current-face)
(term-ansi-reset)
- (set (make-local-variable 'term-pending-frame) nil)
+ (add-hook 'menu-bar-update-hook 'term--update-term-menu)
+ (setq-local term-pending-frame nil)
;; Cua-mode's keybindings interfere with the term keybindings, disable it.
- (set (make-local-variable 'cua-mode) nil)
+ (setq-local cua-mode nil)
- (set (make-local-variable 'font-lock-defaults) '(nil t))
+ (setq-local font-lock-defaults '(nil t))
(add-function :filter-return
(local 'filter-buffer-substring-function)
@@ -1094,8 +1120,6 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(term--reset-scroll-region)
- (easy-menu-add term-terminal-menu)
- (easy-menu-add term-signals-menu)
(or term-input-ring
(setq term-input-ring (make-ring term-input-ring-size)))
(term-update-mode-line))
@@ -1269,18 +1293,20 @@ without any interpretation."
(defun term-send-next () (interactive) (term-send-raw-string "\e[6~"))
(defun term-send-del () (interactive) (term-send-raw-string "\e[3~"))
(defun term-send-backspace () (interactive) (term-send-raw-string "\C-?"))
+(defun term-send-C-_ () (interactive) (term-send-raw-string "\C-_"))
(defun term-char-mode ()
"Switch to char (\"raw\") sub-mode of term mode.
Each character you type is sent directly to the inferior without
-intervention from Emacs, except for the escape character (usually C-c)."
+intervention from Emacs, except for the escape character (usually C-c).
+
+This command will send existing partial lines to the terminal
+process."
(interactive)
;; FIXME: Emit message? Cfr ilisp-raw-message
(when (term-in-line-mode)
(setq term-old-mode-map (current-local-map))
(use-local-map term-raw-map)
- (easy-menu-add term-terminal-menu)
- (easy-menu-add term-signals-menu)
;; Don't allow changes to the buffer or to point which are not
;; caused by the process filter.
@@ -1422,8 +1448,7 @@ buffer. The hook `term-exec-hook' is run after each exec."
(when proc (delete-process proc)))
;; Crank up a new process
(let ((proc (term-exec-1 name buffer command switches)))
- (make-local-variable 'term-ptyp)
- (setq term-ptyp process-connection-type) ; t if pty, nil if pipe.
+ (setq-local term-ptyp process-connection-type) ; t if pty, nil if pipe.
;; Jump to the end, and set the process mark.
(goto-char (point-max))
(set-marker (process-mark proc) (point))
@@ -1543,9 +1568,12 @@ Nil if unknown.")
(format term-termcap-format "TERMCAP="
term-term-name term-height term-width)
- (format "INSIDE_EMACS=%s,term:%s" emacs-version term-protocol-version)
- (format "LINES=%d" term-height)
- (format "COLUMNS=%d" term-width))
+ (format "INSIDE_EMACS=%s,term:%s"
+ emacs-version term-protocol-version))
+ (when term-set-terminal-size
+ (list
+ (format "LINES=%d" term-height)
+ (format "COLUMNS=%d" term-width)))
process-environment))
(process-connection-type t)
;; We should suppress conversion of end-of-line format.
@@ -1559,9 +1587,9 @@ Nil if unknown.")
process-environment))
(apply #'start-process name buffer
"/bin/sh" "-c"
- (format "stty -nl echo rows %d columns %d sane 2>/dev/null;\
+ (format "stty -nl echo rows %d columns %d sane 2>%s;\
if [ $1 = .. ]; then shift; fi; exec \"$@\""
- term-height term-width)
+ term-height term-width null-device)
".."
command switches)))
@@ -2533,7 +2561,7 @@ See `term-prompt-regexp'."
;; then the filename reader will only accept a file that exists.
;;
;; A typical use:
-;; (interactive (term-get-source "Compile file: " prev-lisp-dir/file
+;; (interactive (term-get-source "Compile file" prev-lisp-dir/file
;; '(lisp-mode) t))
;; This is pretty stupid about strings. It decides we're in a string
@@ -2564,9 +2592,7 @@ See `term-prompt-regexp'."
(car def)))
(deffile (if sfile-p (file-name-nondirectory stringfile)
(cdr def)))
- (ans (read-file-name (if deffile (format "%s(default %s) "
- prompt deffile)
- prompt)
+ (ans (read-file-name (format-prompt prompt deffile)
defdir
(concat defdir deffile)
mustmatch-p)))
@@ -2787,7 +2813,7 @@ See `term-prompt-regexp'."
;; References:
;; [ctlseqs]: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
-;; [ECMA-48]: http://www.ecma-international.org/publications/standards/Ecma-048.htm
+;; [ECMA-48]: https://www.ecma-international.org/publications/standards/Ecma-048.htm
;; [vt100]: https://vt100.net/docs/vt100-ug/chapter3.html
(defconst term-control-seq-regexp
@@ -2796,12 +2822,12 @@ See `term-prompt-regexp'."
"\\(?:[\r\n\000\007\t\b\016\017]\\|"
;; some Emacs specific control sequences, implemented by
;; `term-command-hook',
- "\032[^\n]+\r?\n\\|"
+ "\032[^\n]+\n\\|"
;; a C1 escape coded character (see [ECMA-48] section 5.3 "Elements
;; of the C1 set"),
"\e\\(?:[DM78c]\\|"
;; another Emacs specific control sequence,
- "AnSiT[^\n]+\r?\n\\|"
+ "AnSiT[^\n]+\n\\|"
;; or an escape sequence (section 5.4 "Control Sequences"),
"\\[\\([\x30-\x3F]*\\)[\x20-\x2F]*[\x40-\x7E]\\)\\)")
"Regexp matching control sequences handled by term.el.")
@@ -2810,330 +2836,334 @@ See `term-prompt-regexp'."
"[\032\e]")
(defun term-emulate-terminal (proc str)
- (with-current-buffer (process-buffer proc)
- (let* ((i 0) funny
- decoded-substring
- save-point save-marker win
- (inhibit-read-only t)
- (buffer-undo-list t)
- (selected (selected-window))
- last-win
- (str-length (length str)))
- (save-selected-window
-
- (when (marker-buffer term-pending-delete-marker)
- ;; Delete text following term-pending-delete-marker.
- (delete-region term-pending-delete-marker (process-mark proc))
- (set-marker term-pending-delete-marker nil))
-
- (when (/= (point) (process-mark proc))
- (setq save-point (point-marker)))
-
- (setf term-vertical-motion
- (if (eq (window-buffer) (current-buffer))
- 'vertical-motion
- 'term-buffer-vertical-motion))
- (setq save-marker (copy-marker (process-mark proc)))
- (goto-char (process-mark proc))
-
- (save-restriction
- ;; If the buffer is in line mode, and there is a partial
- ;; input line, save the line (by narrowing to leave it
- ;; outside the restriction ) until we're done with output.
- (when (and (> (point-max) (process-mark proc))
- (term-in-line-mode))
- (narrow-to-region (point-min) (process-mark proc)))
-
- (when term-log-buffer
- (princ str term-log-buffer))
- (when term-terminal-undecoded-bytes
- (setq str (concat term-terminal-undecoded-bytes str))
- (setq str-length (length str))
- (setq term-terminal-undecoded-bytes nil))
-
- (while (< i str-length)
- (setq funny (string-match term-control-seq-regexp str i))
- (let ((ctl-params (and funny (match-string 1 str)))
- (ctl-params-end (and funny (match-end 1)))
- (ctl-end (if funny (match-end 0)
- (setq funny (string-match term-control-seq-prefix-regexp str i))
- (if funny
- (setq term-terminal-undecoded-bytes
- (substring str funny))
- (setq funny str-length))
- ;; The control sequence ends somewhere
- ;; past the end of this string.
- (1+ str-length))))
- (when (> funny i)
- (when term-do-line-wrapping
- (term-down 1 t)
- (term-move-to-column 0)
- (setq term-do-line-wrapping nil))
- ;; Handle non-control data. Decode the string before
- ;; counting characters, to avoid garbling of certain
- ;; multibyte characters (bug#1006).
- (setq decoded-substring
- (decode-coding-string
- (substring str i funny)
- locale-coding-system t))
- ;; Check for multibyte characters that ends
- ;; before end of string, and save it for
- ;; next time.
- (when (= funny str-length)
- (let ((partial 0)
- (count (length decoded-substring)))
- (while (and (< partial count)
- (eq (char-charset (aref decoded-substring
- (- count 1 partial)))
- 'eight-bit))
- (cl-incf partial))
- (when (> count partial 0)
- (setq term-terminal-undecoded-bytes
- (substring decoded-substring (- partial)))
- (setq decoded-substring
- (substring decoded-substring 0 (- partial)))
- (cl-decf str-length partial)
- (cl-decf funny partial))))
-
- ;; Insert a string, check how many columns
- ;; we moved, then delete that many columns
- ;; following point if not eob nor insert-mode.
- (let ((old-column (term-horizontal-column))
- (old-point (point))
- columns)
- (unless term-suppress-hard-newline
- (while (> (+ (length decoded-substring) old-column)
- term-width)
- (insert (substring decoded-substring 0
- (- term-width old-column)))
- ;; Since we've enough text to fill the whole line,
- ;; delete previous text regardless of
- ;; `term-insert-mode's value.
- (delete-region (point) (line-end-position))
- (term-down 1 t)
- (term-move-columns (- (term-current-column)))
- (add-text-properties (1- (point)) (point)
- '(term-line-wrap t rear-nonsticky t))
- (setq decoded-substring
- (substring decoded-substring (- term-width old-column)))
- (setq old-column 0)))
- (insert decoded-substring)
- (setq term-current-column (current-column)
- columns (- term-current-column old-column))
- (when (not (or (eobp) term-insert-mode))
- (let ((pos (point)))
- (term-move-columns columns)
- (delete-region pos (point))
- (setq term-current-column nil)))
- ;; In insert mode if the current line
- ;; has become too long it needs to be
- ;; chopped off.
- (when term-insert-mode
- (let ((pos (point)))
- (end-of-line)
- (when (> (current-column) term-width)
- (delete-region (- (point) (- (current-column) term-width))
- (point)))
- (goto-char pos)))
-
- (put-text-property old-point (point)
- 'font-lock-face term-current-face))
- ;; If the last char was written in last column,
- ;; back up one column, but remember we did so.
- ;; Thus we emulate xterm/vt100-style line-wrapping.
- (when (eq (term-current-column) term-width)
- (term-move-columns -1)
- ;; We check after ctrl sequence handling if point
- ;; was moved (and leave line-wrapping state if so).
- (setq term-do-line-wrapping (point)))
- (setq term-current-column nil)
- (setq i funny))
- (pcase-exhaustive (and (<= ctl-end str-length) (aref str i))
- (?\t ;; TAB (terminfo: ht)
- ;; The line cannot exceed term-width. TAB at
- ;; the end of a line should not cause wrapping.
- (let ((col (term-current-column)))
- (term-move-to-column
- (min (1- term-width)
- (+ col 8 (- (mod col 8)))))))
- (?\r ;; (terminfo: cr)
- (term-vertical-motion 0)
- (setq term-current-column term-start-line-column))
- (?\n ;; (terminfo: cud1, ind)
- (unless (and term-kill-echo-list
- (term-check-kill-echo-list))
- (term-down 1 t)))
- (?\b ;; (terminfo: cub1)
- (term-move-columns -1))
- (?\C-g ;; (terminfo: bel)
- (beep t))
- (?\032 ; Emacs specific control sequence.
- (funcall term-command-function
- (decode-coding-string
- (substring str (1+ i)
- (- ctl-end
- (if (eq (aref str (- ctl-end 2)) ?\r)
- 2 1)))
- locale-coding-system t)))
- (?\e
- (pcase (aref str (1+ i))
- (?\[
- ;; We only handle control sequences with a single
- ;; "Final" byte (see [ECMA-48] section 5.4).
- (when (eq ctl-params-end (1- ctl-end))
- (term-handle-ansi-escape
- proc
- (mapcar ;; We don't distinguish empty params
- ;; from 0 (according to [ECMA-48] we
- ;; should, but all commands we support
- ;; default to 0 values anyway).
- #'string-to-number
- (split-string ctl-params ";"))
- (aref str (1- ctl-end)))))
- (?D ;; Scroll forward (apparently not documented in
- ;; [ECMA-48], [ctlseqs] mentions it as C1
- ;; character "Index" though).
- (term-handle-deferred-scroll)
- (term-down 1 t))
- (?M ;; Scroll reversed (terminfo: ri, ECMA-48
- ;; "Reverse Linefeed").
- (if (or (< (term-current-row) term-scroll-start)
- (>= (1- (term-current-row))
- term-scroll-start))
- ;; Scrolling up will not move outside
- ;; the scroll region.
- (term-down -1)
- ;; Scrolling the scroll region is needed.
- (term-down -1 t)))
- (?7 ;; Save cursor (terminfo: sc, not in [ECMA-48],
- ;; [ctlseqs] has it as "DECSC").
- (term-handle-deferred-scroll)
- (setq term-saved-cursor
- (list (term-current-row)
- (term-horizontal-column)
- term-ansi-current-bg-color
- term-ansi-current-bold
- term-ansi-current-color
- term-ansi-current-invisible
- term-ansi-current-reverse
- term-ansi-current-underline
- term-current-face)))
- (?8 ;; Restore cursor (terminfo: rc, [ctlseqs]
- ;; "DECRC").
- (when term-saved-cursor
- (term-goto (nth 0 term-saved-cursor)
- (nth 1 term-saved-cursor))
- (setq term-ansi-current-bg-color
- (nth 2 term-saved-cursor)
- term-ansi-current-bold
- (nth 3 term-saved-cursor)
- term-ansi-current-color
- (nth 4 term-saved-cursor)
- term-ansi-current-invisible
- (nth 5 term-saved-cursor)
- term-ansi-current-reverse
- (nth 6 term-saved-cursor)
- term-ansi-current-underline
- (nth 7 term-saved-cursor)
- term-current-face
- (nth 8 term-saved-cursor))))
- (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS").
- ;; This is used by the "clear" program.
- (term-reset-terminal))
- (?A ;; An \eAnSiT sequence (Emacs specific).
- (term-handle-ansi-terminal-messages
- (substring str i ctl-end)))))
- ;; Ignore NUL, Shift Out, Shift In.
- ((or ?\0 #xE #xF 'nil) nil))
- ;; Leave line-wrapping state if point was moved.
- (unless (eq term-do-line-wrapping (point))
- (setq term-do-line-wrapping nil))
- (if (term-handling-pager)
- (progn
- ;; Finish stuff to get ready to handle PAGER.
- (if (> (% (current-column) term-width) 0)
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (let* ((i 0) funny
+ decoded-substring
+ save-point save-marker win
+ (inhibit-read-only t)
+ (buffer-undo-list t)
+ (selected (selected-window))
+ last-win
+ (str-length (length str)))
+ (save-selected-window
+
+ (when (marker-buffer term-pending-delete-marker)
+ ;; Delete text following term-pending-delete-marker.
+ (delete-region term-pending-delete-marker (process-mark proc))
+ (set-marker term-pending-delete-marker nil))
+
+ (when (/= (point) (process-mark proc))
+ (setq save-point (point-marker)))
+
+ (setf term-vertical-motion
+ (if (eq (window-buffer) (current-buffer))
+ 'vertical-motion
+ 'term-buffer-vertical-motion))
+ (setq save-marker (copy-marker (process-mark proc)))
+ (goto-char (process-mark proc))
+
+ (save-restriction
+ ;; If the buffer is in line mode, and there is a partial
+ ;; input line, save the line (by narrowing to leave it
+ ;; outside the restriction ) until we're done with output.
+ (when (and (> (point-max) (process-mark proc))
+ (term-in-line-mode))
+ (narrow-to-region (point-min) (process-mark proc)))
+
+ (when term-log-buffer
+ (princ str term-log-buffer))
+ (when term-terminal-undecoded-bytes
+ (setq str (concat term-terminal-undecoded-bytes str))
+ (setq str-length (length str))
+ (setq term-terminal-undecoded-bytes nil))
+
+ (while (< i str-length)
+ (setq funny (string-match term-control-seq-regexp str i))
+ (let ((ctl-params (and funny (match-string 1 str)))
+ (ctl-params-end (and funny (match-end 1)))
+ (ctl-end (if funny (match-end 0)
+ (setq funny (string-match term-control-seq-prefix-regexp str i))
+ (if funny
+ (setq term-terminal-undecoded-bytes
+ (substring str funny))
+ (setq funny str-length))
+ ;; The control sequence ends somewhere
+ ;; past the end of this string.
+ (1+ str-length))))
+ (when (> funny i)
+ (when term-do-line-wrapping
+ (term-down 1 t)
+ (term-move-to-column 0)
+ (setq term-do-line-wrapping nil))
+ ;; Handle non-control data. Decode the string before
+ ;; counting characters, to avoid garbling of certain
+ ;; multibyte characters (bug#1006).
+ (setq decoded-substring
+ (decode-coding-string
+ (substring str i funny)
+ locale-coding-system t))
+ ;; Check for multibyte characters that ends
+ ;; before end of string, and save it for
+ ;; next time.
+ (when (= funny str-length)
+ (let ((partial 0)
+ (count (length decoded-substring)))
+ (while (and (< partial count)
+ (eq (char-charset (aref decoded-substring
+ (- count 1 partial)))
+ 'eight-bit))
+ (cl-incf partial))
+ (when (> count partial 0)
(setq term-terminal-undecoded-bytes
- (substring str i))
- ;; We're at column 0. Goto end of buffer; to compensate,
- ;; prepend a ?\r for later. This looks more consistent.
- (if (zerop i)
+ (substring decoded-substring (- partial)))
+ (setq decoded-substring
+ (substring decoded-substring 0 (- partial)))
+ (cl-decf str-length partial)
+ (cl-decf funny partial))))
+
+ ;; Insert a string, check how many columns
+ ;; we moved, then delete that many columns
+ ;; following point if not eob nor insert-mode.
+ (let ((old-column (term-horizontal-column))
+ (old-point (point))
+ columns)
+ (unless term-suppress-hard-newline
+ (while (> (+ (length decoded-substring) old-column)
+ term-width)
+ (insert (substring decoded-substring 0
+ (- term-width old-column)))
+ ;; Since we've enough text to fill the whole line,
+ ;; delete previous text regardless of
+ ;; `term-insert-mode's value.
+ (delete-region (point) (line-end-position))
+ (term-down 1 t)
+ (term-move-columns (- (term-current-column)))
+ (add-text-properties (1- (point)) (point)
+ '(term-line-wrap t rear-nonsticky t))
+ (setq decoded-substring
+ (substring decoded-substring (- term-width old-column)))
+ (setq old-column 0)))
+ (insert decoded-substring)
+ (setq term-current-column (current-column)
+ columns (- term-current-column old-column))
+ (when (not (or (eobp) term-insert-mode))
+ (let ((pos (point)))
+ (term-move-columns columns)
+ (delete-region pos (point))
+ (setq term-current-column nil)))
+ ;; In insert mode if the current line
+ ;; has become too long it needs to be
+ ;; chopped off.
+ (when term-insert-mode
+ (let ((pos (point)))
+ (end-of-line)
+ (when (> (current-column) term-width)
+ (delete-region (- (point) (- (current-column) term-width))
+ (point)))
+ (goto-char pos)))
+
+ (put-text-property old-point (point)
+ 'font-lock-face term-current-face))
+ ;; If the last char was written in last column,
+ ;; back up one column, but remember we did so.
+ ;; Thus we emulate xterm/vt100-style line-wrapping.
+ (when (eq (term-current-column) term-width)
+ (term-move-columns -1)
+ ;; We check after ctrl sequence handling if point
+ ;; was moved (and leave line-wrapping state if so).
+ (setq term-do-line-wrapping (point)))
+ (setq term-current-column nil)
+ (setq i funny))
+ (pcase-exhaustive (and (<= ctl-end str-length) (aref str i))
+ (?\t ;; TAB (terminfo: ht)
+ ;; The line cannot exceed term-width. TAB at
+ ;; the end of a line should not cause wrapping.
+ (let ((col (term-current-column)))
+ (term-move-to-column
+ (min (1- term-width)
+ (+ col 8 (- (mod col 8)))))))
+ (?\r ;; (terminfo: cr)
+ (term-vertical-motion 0)
+ (setq term-current-column term-start-line-column))
+ (?\n ;; (terminfo: cud1, ind)
+ (unless (and term-kill-echo-list
+ (term-check-kill-echo-list))
+ (term-down 1 t)))
+ (?\b ;; (terminfo: cub1)
+ (term-move-columns -1))
+ (?\C-g ;; (terminfo: bel)
+ (beep t))
+ (?\032 ; Emacs specific control sequence.
+ (funcall term-command-function
+ (decode-coding-string
+ (substring str (1+ i)
+ (- ctl-end
+ (if (eq (aref str (- ctl-end 2)) ?\r)
+ 2 1)))
+ locale-coding-system t)))
+ (?\e
+ (pcase (aref str (1+ i))
+ (?\[
+ ;; We only handle control sequences with a single
+ ;; "Final" byte (see [ECMA-48] section 5.4).
+ (when (eq ctl-params-end (1- ctl-end))
+ (term-handle-ansi-escape
+ proc
+ (mapcar ;; We don't distinguish empty params
+ ;; from 0 (according to [ECMA-48] we
+ ;; should, but all commands we support
+ ;; default to 0 values anyway).
+ #'string-to-number
+ (split-string ctl-params ";"))
+ (aref str (1- ctl-end)))))
+ (?D ;; Scroll forward (apparently not documented in
+ ;; [ECMA-48], [ctlseqs] mentions it as C1
+ ;; character "Index" though).
+ (term-handle-deferred-scroll)
+ (term-down 1 t))
+ (?M ;; Scroll reversed (terminfo: ri, ECMA-48
+ ;; "Reverse Linefeed").
+ (if (or (< (term-current-row) term-scroll-start)
+ (>= (1- (term-current-row))
+ term-scroll-start))
+ ;; Scrolling up will not move outside
+ ;; the scroll region.
+ (term-down -1)
+ ;; Scrolling the scroll region is needed.
+ (term-down -1 t)))
+ (?7 ;; Save cursor (terminfo: sc, not in [ECMA-48],
+ ;; [ctlseqs] has it as "DECSC").
+ (term-handle-deferred-scroll)
+ (setq term-saved-cursor
+ (list (term-current-row)
+ (term-horizontal-column)
+ term-ansi-current-bg-color
+ term-ansi-current-bold
+ term-ansi-current-color
+ term-ansi-current-invisible
+ term-ansi-current-reverse
+ term-ansi-current-underline
+ term-current-face)))
+ (?8 ;; Restore cursor (terminfo: rc, [ctlseqs]
+ ;; "DECRC").
+ (when term-saved-cursor
+ (term-goto (nth 0 term-saved-cursor)
+ (nth 1 term-saved-cursor))
+ (setq term-ansi-current-bg-color
+ (nth 2 term-saved-cursor)
+ term-ansi-current-bold
+ (nth 3 term-saved-cursor)
+ term-ansi-current-color
+ (nth 4 term-saved-cursor)
+ term-ansi-current-invisible
+ (nth 5 term-saved-cursor)
+ term-ansi-current-reverse
+ (nth 6 term-saved-cursor)
+ term-ansi-current-underline
+ (nth 7 term-saved-cursor)
+ term-current-face
+ (nth 8 term-saved-cursor))))
+ (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS").
+ ;; This is used by the "clear" program.
+ (term-reset-terminal))
+ (?A ;; An \eAnSiT sequence (Emacs specific).
+ (term-handle-ansi-terminal-messages
+ (substring str i ctl-end)))))
+ ;; Ignore NUL, Shift Out, Shift In.
+ ((or ?\0 #xE #xF 'nil) nil))
+ ;; Leave line-wrapping state if point was moved.
+ (unless (eq term-do-line-wrapping (point))
+ (setq term-do-line-wrapping nil))
+ (if (term-handling-pager)
+ (progn
+ ;; Finish stuff to get ready to handle PAGER.
+ (if (> (% (current-column) term-width) 0)
(setq term-terminal-undecoded-bytes
- (concat "\r" (substring str i)))
- (setq term-terminal-undecoded-bytes (substring str (1- i)))
- (aset term-terminal-undecoded-bytes 0 ?\r))
- (goto-char (point-max)))
- ;; FIXME: Use (add-function :override (process-filter proc)
- (make-local-variable 'term-pager-old-filter)
- (setq term-pager-old-filter (process-filter proc))
- ;; FIXME: Where is `term-pager-filter' set to a function?!
- (set-process-filter proc term-pager-filter)
- (setq i str-length))
- (setq i ctl-end)))))
-
- (when (>= (term-current-row) term-height)
- (term-handle-deferred-scroll))
-
- (set-marker (process-mark proc) (point))
- (when (stringp decoded-substring)
- (term-watch-for-password-prompt decoded-substring))
- (when save-point
- (goto-char save-point)
- (set-marker save-point nil))
-
- ;; Check for a pending filename-and-line number to display.
- ;; We do this before scrolling, because we might create a new window.
- (when (and term-pending-frame
- (eq (window-buffer selected) (current-buffer)))
- (term-display-line (car term-pending-frame)
- (cdr term-pending-frame))
- (setq term-pending-frame nil))
-
- ;; Scroll each window displaying the buffer but (by default)
- ;; only if the point matches the process-mark we started with.
- (setq win selected)
- ;; Avoid infinite loop in strange case where minibuffer window
- ;; is selected but not active.
- (while (window-minibuffer-p win)
- (setq win (next-window win nil t)))
- (setq last-win win)
- (while (progn
- (setq win (next-window win nil t))
- (when (eq (window-buffer win) (process-buffer proc))
- (let ((scroll term-scroll-to-bottom-on-output))
- (select-window win)
- (when (or (= (point) save-marker)
- (eq scroll t) (eq scroll 'all)
- ;; Maybe user wants point to jump to the end.
- (and (eq selected win)
- (or (eq scroll 'this) (not save-point)))
- (and (eq scroll 'others)
- (not (eq selected win))))
- (goto-char term-home-marker)
- (recenter 0)
- (goto-char (process-mark proc))
- (if (not (pos-visible-in-window-p (point) win))
- (recenter -1)))
- ;; Optionally scroll so that the text
- ;; ends at the bottom of the window.
- (when (and term-scroll-show-maximum-output
- (>= (point) (process-mark proc)))
- (save-excursion
- (goto-char (point-max))
- (recenter -1)))))
- (not (eq win last-win))))
-
- ;; Stolen from comint.el and adapted -mm
- (when (> term-buffer-maximum-size 0)
- (save-excursion
- (goto-char (process-mark (get-buffer-process (current-buffer))))
- (forward-line (- term-buffer-maximum-size))
- (beginning-of-line)
- (delete-region (point-min) (point))))
- (set-marker save-marker nil)))
- ;; This might be expensive, but we need it to handle something
- ;; like `sleep 5 | less -c' in more-or-less real time.
- (when (get-buffer-window (current-buffer))
- (redisplay))))
+ (substring str i))
+ ;; We're at column 0. Goto end of buffer; to compensate,
+ ;; prepend a ?\r for later. This looks more consistent.
+ (if (zerop i)
+ (setq term-terminal-undecoded-bytes
+ (concat "\r" (substring str i)))
+ (setq term-terminal-undecoded-bytes (substring str (1- i)))
+ (aset term-terminal-undecoded-bytes 0 ?\r))
+ (goto-char (point-max)))
+ ;; FIXME: Use (add-function :override (process-filter proc)
+ (setq-local term-pager-old-filter (process-filter proc))
+ ;; FIXME: Where is `term-pager-filter' set to a function?!
+ (set-process-filter proc term-pager-filter)
+ (setq i str-length))
+ (setq i ctl-end)))))
+
+ (when (>= (term-current-row) term-height)
+ (term-handle-deferred-scroll))
+
+ (set-marker (process-mark proc) (point))
+ (when (stringp decoded-substring)
+ (term-watch-for-password-prompt decoded-substring))
+ (when save-point
+ (goto-char save-point)
+ (set-marker save-point nil))
+
+ ;; Check for a pending filename-and-line number to display.
+ ;; We do this before scrolling, because we might create a new window.
+ (when (and term-pending-frame
+ (eq (window-buffer selected) (current-buffer)))
+ (term-display-line (car term-pending-frame)
+ (cdr term-pending-frame))
+ (setq term-pending-frame nil))
+
+ ;; Scroll each window displaying the buffer but (by default)
+ ;; only if the point matches the process-mark we started with.
+ (setq win selected)
+ ;; Avoid infinite loop in strange case where minibuffer window
+ ;; is selected but not active.
+ (while (window-minibuffer-p win)
+ (setq win (next-window win nil t)))
+ (setq last-win win)
+ (while (progn
+ (setq win (next-window win nil t))
+ (when (eq (window-buffer win) (process-buffer proc))
+ (let ((scroll term-scroll-to-bottom-on-output))
+ (select-window win)
+ (when (or (= (point) save-marker)
+ (eq scroll t) (eq scroll 'all)
+ ;; Maybe user wants point to jump to the end.
+ (and (eq selected win)
+ (or (eq scroll 'this) (not save-point)))
+ (and (eq scroll 'others)
+ (not (eq selected win))))
+ (when term-scroll-snap-to-bottom
+ (goto-char term-home-marker)
+ (recenter 0))
+ (goto-char (process-mark proc))
+ (if (not (pos-visible-in-window-p (point) win))
+ (recenter -1)))
+ ;; Optionally scroll so that the text
+ ;; ends at the bottom of the window.
+ (when (and term-scroll-show-maximum-output
+ (>= (point) (process-mark proc))
+ (or term-scroll-snap-to-bottom
+ (not (pos-visible-in-window-p
+ (point-max) win))))
+ (save-excursion
+ (goto-char (point-max))
+ (recenter -1)))))
+ (not (eq win last-win))))
+
+ ;; Stolen from comint.el and adapted -mm
+ (when (> term-buffer-maximum-size 0)
+ (save-excursion
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (forward-line (- term-buffer-maximum-size))
+ (beginning-of-line)
+ (delete-region (point-min) (point))))
+ (set-marker save-marker nil)))
+ ;; This might be expensive, but we need it to handle something
+ ;; like `sleep 5 | less -c' in more-or-less real time.
+ (when (get-buffer-window (current-buffer))
+ (redisplay)))))
(defvar-local term-goto-process-mark t
"Whether to reset point to the current process mark after this command.
@@ -3529,11 +3559,7 @@ The top-most line is line 0."
;; (stop-process process))
(setq term-pager-old-local-map (current-local-map))
(use-local-map term-pager-break-map)
- (easy-menu-add term-terminal-menu)
- (easy-menu-add term-signals-menu)
- (easy-menu-add term-pager-menu)
- (make-local-variable 'term-old-mode-line-format)
- (setq term-old-mode-line-format mode-line-format)
+ (setq-local term-old-mode-line-format mode-line-format)
(setq mode-line-format
(list "-- **MORE** "
mode-line-buffer-identification
@@ -3618,8 +3644,8 @@ The top-most line is line 0."
(message "Terminal-emulator pager break help...")
(sit-for 0)
(with-electric-help
- (function (lambda ()
- (princ (substitute-command-keys
+ (lambda ()
+ (princ (substitute-command-keys
"\\<term-pager-break-map>\
Terminal-emulator MORE break.\n\
Type one of the following keys:\n\n\
@@ -3637,7 +3663,7 @@ Type one of the following keys:\n\n\
Any other key is passed through to the program
running under the terminal emulator and disables pager processing until
all pending output has been dealt with."))
- nil))))
+ nil)))
(defun term-pager-continue (new-count)
(let ((process (get-buffer-process (current-buffer))))
@@ -4090,53 +4116,6 @@ see `expand-file-name' and `substitute-in-file-name'. For completion see
(term-dynamic-complete-filename))
-(defun term-dynamic-simple-complete (stub candidates)
- "Dynamically complete STUB from CANDIDATES list.
-This function inserts completion characters at point by completing STUB from
-the strings in CANDIDATES. A completions listing may be shown in a help buffer
-if completion is ambiguous.
-
-Returns nil if no completion was inserted.
-Returns `sole' if completed with the only completion match.
-Returns `shortest' if completed with the shortest of the completion matches.
-Returns `partial' if completed as far as possible with the completion matches.
-Returns `listed' if a completion listing was shown.
-
-See also `term-dynamic-complete-filename'."
- (declare (obsolete completion-in-region "23.2"))
- (let* ((completion-ignore-case nil)
- (completions (all-completions stub candidates)))
- (cond ((null completions)
- (message "No completions of %s" stub)
- nil)
- ((= 1 (length completions)) ; Gotcha!
- (let ((completion (car completions)))
- (if (string-equal completion stub)
- (message "Sole completion")
- (insert (substring completion (length stub)))
- (message "Completed"))
- (when term-completion-addsuffix (insert " "))
- 'sole))
- (t ; There's no unique completion.
- (let ((completion (try-completion stub candidates)))
- ;; Insert the longest substring.
- (insert (substring completion (length stub)))
- (cond ((and term-completion-recexact term-completion-addsuffix
- (string-equal stub completion)
- (member completion completions))
- ;; It's not unique, but user wants shortest match.
- (insert " ")
- (message "Completed shortest")
- 'shortest)
- ((or term-completion-autolist
- (string-equal stub completion))
- ;; It's not unique, list possible completions.
- (term-dynamic-list-completions completions)
- 'listed)
- (t
- (message "Partially completed")
- 'partial)))))))
-
(defun term-dynamic-list-filename-completions ()
"List in help buffer possible completions of the filename at point."
(interactive)
@@ -4166,7 +4145,7 @@ Typing SPC flushes the help buffer."
(eq (window-buffer (posn-window (event-start first)))
(get-buffer "*Completions*"))
(memq (key-binding key)
- '(mouse-choose-completion choose-completion))))
+ '(choose-completion))))
;; If the user does choose-completion with the mouse,
;; execute the command, then delete the completion window.
(progn
@@ -4305,8 +4284,7 @@ well as the newer ports COM10 and higher."
;; `prompt': The most recently used port is provided as
;; the default value, which is used when the user
;; simply presses return.
- (if (stringp h) (format "Serial port (default %s): " h)
- "Serial port: ")
+ (format-prompt "Serial port" h)
;; `directory': Most systems have their serial ports
;; in the same directory, so start in the directory
;; of the most recently used port, or in a reasonable
@@ -4321,8 +4299,7 @@ well as the newer ports COM10 and higher."
;; serial port.
"")
(read-from-minibuffer
- (if (stringp h) (format "Serial port (default %s): " h)
- "Serial port: ")
+ (format-prompt "Serial port" h)
nil nil nil '(file-name-history . 1) nil nil))))
(if (or (null x) (and (stringp x) (zerop (length x))))
(setq x h)
@@ -4344,7 +4321,7 @@ Try to be nice by providing useful defaults and history."
(cond ((string= h serial-no-speed)
"Speed (default nil = set by port): ")
(h
- (format "Speed (default %s b/s): " h))
+ (format-prompt "Speed" (format "%s b/s" h)))
(t
(format "Speed (b/s): ")))
nil nil nil '(history . 1) nil nil)))
diff --git a/lisp/term/AT386.el b/lisp/term/AT386.el
index 1cf06a7eebb..3bedde503f6 100644
--- a/lisp/term/AT386.el
+++ b/lisp/term/AT386.el
@@ -1,4 +1,4 @@
-;;; AT386.el --- terminal support package for IBM AT keyboards
+;;; AT386.el --- terminal support package for IBM AT keyboards -*- lexical-binding: t -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el
index a32da6ae8f2..983c8cded2f 100644
--- a/lisp/term/bobcat.el
+++ b/lisp/term/bobcat.el
@@ -1,3 +1,4 @@
+;;; bobcat.el -*- lexical-binding:t -*-
(defun terminal-init-bobcat ()
"Terminal initialization function for bobcat."
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el
index 8d5cb191dd8..8ae58718e3f 100644
--- a/lisp/term/common-win.el
+++ b/lisp/term/common-win.el
@@ -1,4 +1,4 @@
-;;; common-win.el --- common part of handling window systems
+;;; common-win.el --- common part of handling window systems -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/cygwin.el b/lisp/term/cygwin.el
index edc64b4404d..8f0d751cf29 100644
--- a/lisp/term/cygwin.el
+++ b/lisp/term/cygwin.el
@@ -1,4 +1,4 @@
-;;; cygwin.el --- support for the Cygwin terminal
+;;; cygwin.el --- support for the Cygwin terminal -*- lexical-binding:t -*-
;;; The Cygwin terminal can't really display underlines.
diff --git a/lisp/term/internal.el b/lisp/term/internal.el
index f9ecb90e5a8..fd75ded081f 100644
--- a/lisp/term/internal.el
+++ b/lisp/term/internal.el
@@ -1,4 +1,4 @@
-;;; internal.el --- support for PC internal terminal
+;;; internal.el --- support for PC internal terminal -*- lexical-binding: t -*-
;; Copyright (C) 1993-1994, 1998-1999, 2001-2021 Free Software
;; Foundation, Inc.
@@ -400,9 +400,9 @@ If TABLE is nil or omitted, `standard-display-table' is used."
;; The following alist was compiled from:
;;
;; Ralf Brown's Interrupt List. file INTERRUP.F, D-2138, Table 01400
-;; http://www.ethnologue.com/country_index.asp (official languages)
-;; http://unicode.org/onlinedat/languages.html
-;; http://unicode.org/onlinedat/countries.html
+;; https://www.ethnologue.com/country_index.asp (official languages)
+;; https://unicode.org/onlinedat/languages.html
+;; https://unicode.org/onlinedat/countries.html
;;
;; Only the official languages listed for each country.
;;
diff --git a/lisp/term/iris-ansi.el b/lisp/term/iris-ansi.el
index d0260ef155a..e5b94eab76b 100644
--- a/lisp/term/iris-ansi.el
+++ b/lisp/term/iris-ansi.el
@@ -1,4 +1,4 @@
-;;; iris-ansi.el --- configure Emacs for SGI xwsh and winterm apps
+;;; iris-ansi.el --- configure Emacs for SGI xwsh and winterm apps -*- lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/konsole.el b/lisp/term/konsole.el
index 9cd8f96c546..1f65a46011c 100644
--- a/lisp/term/konsole.el
+++ b/lisp/term/konsole.el
@@ -1,4 +1,4 @@
-;;; konsole.el --- terminal initialization for konsole
+;;; konsole.el --- terminal initialization for konsole -*- lexical-binding:t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
(require 'term/xterm)
@@ -9,4 +9,4 @@
(provide 'term/konsole)
-;; konsole.el ends here
+;;; konsole.el ends here
diff --git a/lisp/term/linux.el b/lisp/term/linux.el
index 70730dc5844..c6d84ab96c3 100644
--- a/lisp/term/linux.el
+++ b/lisp/term/linux.el
@@ -1,3 +1,5 @@
+;;; linux.el -*- lexical-binding:t -*-
+
;; The Linux console handles Latin-1 by default.
(declare-function gpm-mouse-enable "t-mouse" ())
diff --git a/lisp/term/lk201.el b/lisp/term/lk201.el
index aab4110b3ae..c2802477670 100644
--- a/lisp/term/lk201.el
+++ b/lisp/term/lk201.el
@@ -1,4 +1,4 @@
-;; Define function key sequences for DEC terminals.
+;;; lk201.el --- Define function key sequences for DEC terminals. -*- lexical-binding: t -*-
(defvar lk201-function-map
(let ((map (make-sparse-keymap)))
diff --git a/lisp/term/news.el b/lisp/term/news.el
index f329c910f8c..40aa58ef1c8 100644
--- a/lisp/term/news.el
+++ b/lisp/term/news.el
@@ -1,4 +1,4 @@
-;;; news.el --- keypad and function key bindings for the Sony NEWS keyboard
+;;; news.el --- keypad and function key bindings for the Sony NEWS keyboard -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index bd6d79c505b..af1e388c2a3 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -47,7 +47,6 @@
;; Documentation-purposes only: actually loaded in loadup.el.
(require 'frame)
(require 'mouse)
-(require 'faces)
(require 'menu-bar)
(require 'fontset)
(require 'dnd)
@@ -121,6 +120,15 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [?\s-d] 'isearch-repeat-backward)
(define-key global-map [?\s-e] 'isearch-yank-kill)
(define-key global-map [?\s-f] 'isearch-forward)
+(define-key esc-map [?\s-f] 'isearch-forward-regexp)
+(define-key minibuffer-local-isearch-map [?\s-f]
+ 'isearch-forward-exit-minibuffer)
+(define-key isearch-mode-map [?\s-f] 'isearch-repeat-forward)
+(define-key global-map [?\s-F] 'isearch-backward)
+(define-key esc-map [?\s-F] 'isearch-backward-regexp)
+(define-key minibuffer-local-isearch-map [?\s-F]
+ 'isearch-reverse-exit-minibuffer)
+(define-key isearch-mode-map [?\s-F] 'isearch-repeat-backward)
(define-key global-map [?\s-g] 'isearch-repeat-forward)
(define-key global-map [?\s-h] 'ns-do-hide-emacs)
(define-key global-map [?\s-H] 'ns-do-hide-others)
@@ -148,9 +156,8 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [?\s-|] 'shell-command-on-region)
(define-key global-map [s-kp-bar] 'shell-command-on-region)
(define-key global-map [?\C-\s- ] 'ns-do-show-character-palette)
-;; (as in Terminal.app)
-(define-key global-map [s-right] 'ns-next-frame)
-(define-key global-map [s-left] 'ns-prev-frame)
+(define-key global-map [s-right] 'move-end-of-line)
+(define-key global-map [s-left] 'move-beginning-of-line)
(define-key global-map [home] 'beginning-of-buffer)
(define-key global-map [end] 'end-of-buffer)
@@ -314,10 +321,9 @@ The overlay is assigned the face `ns-working-text-face'."
(interactive)
(ns-delete-working-text)
(let ((start (point)))
- (insert ns-working-text)
- (overlay-put (setq ns-working-overlay (make-overlay start (point)
- (current-buffer) nil t))
- 'face 'ns-working-text-face)))
+ (overlay-put (setq ns-working-overlay (make-overlay start (point)))
+ 'after-string
+ (propertize ns-working-text 'face 'ns-working-text-face))))
(defun ns-echo-working-text ()
"Echo contents of `ns-working-text' in message display area.
@@ -340,8 +346,7 @@ See `ns-insert-working-text'."
;; Still alive?
(overlay-buffer ns-working-overlay))
(with-current-buffer (overlay-buffer ns-working-overlay)
- (delete-region (overlay-start ns-working-overlay)
- (overlay-end ns-working-overlay))
+ (overlay-put ns-working-overlay 'after-string nil)
(delete-overlay ns-working-overlay)))
((integerp ns-working-overlay)
(let ((msg (current-message))
@@ -369,9 +374,8 @@ prompting. If file is a directory perform a `find-file' on it."
(find-file f)
(push-mark (+ (point) (cadr (insert-file-contents f)))))))
-(defvar ns-select-overlay nil
+(defvar-local ns-select-overlay nil
"Overlay used to highlight areas in files requested by Nextstep apps.")
-(make-variable-buffer-local 'ns-select-overlay)
(defvar ns-input-line) ; nsterm.m
@@ -628,15 +632,21 @@ This function has been overloaded in Nextstep.")
(defvar ns-input-fontsize)
(defun ns-respond-to-change-font ()
- "Respond to changeFont: event, expecting `ns-input-font' and\n\
-`ns-input-fontsize' of new font."
+ "Set the font chosen in the font-picker panel.
+Respond to changeFont: event, expecting ns-input-font and
+ns-input-fontsize of new font."
(interactive)
- (modify-frame-parameters (selected-frame)
- (list (cons 'fontsize ns-input-fontsize)))
- (modify-frame-parameters (selected-frame)
- (list (cons 'font ns-input-font)))
- (set-frame-font ns-input-font))
-
+ (let ((face 'default))
+ (set-face-attribute face t
+ :family ns-input-font
+ :height (* 10 ns-input-fontsize))
+ (set-face-attribute face (selected-frame)
+ :family ns-input-font
+ :height (* 10 ns-input-fontsize))
+ (let ((spec (list (list t (face-attr-construct 'default)))))
+ (put face 'customized-face spec)
+ (custom-push-theme 'theme-face face 'user 'set spec)
+ (put face 'face-modified nil))))
;; Default fontset for macOS. This is mainly here to show how a fontset
;; can be set up manually. Ordinarily, fontsets are auto-created whenever
diff --git a/lisp/term/rxvt.el b/lisp/term/rxvt.el
index 56fc4fa206d..9671e95aeb4 100644
--- a/lisp/term/rxvt.el
+++ b/lisp/term/rxvt.el
@@ -1,4 +1,4 @@
-;;; rxvt.el --- define function key sequences and standard colors for rxvt
+;;; rxvt.el --- define function key sequences and standard colors for rxvt -*- lexical-binding: t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -26,6 +26,16 @@
(require 'term/xterm)
+(defgroup rxvt nil
+ "(U)RXVT support."
+ :version "28.1"
+ :group 'terminals)
+
+(defcustom rxvt-set-window-title nil
+ "Whether Emacs should set window titles to an Emacs frame in RXVT."
+ :version "28.1"
+ :type 'boolean)
+
(defvar rxvt-function-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map xterm-rxvt-function-map)
@@ -171,7 +181,16 @@
(xterm-register-default-colors rxvt-standard-colors)
(rxvt-set-background-mode)
;; This recomputes all the default faces given the colors we've just set up.
- (tty-set-up-initial-frame-faces))
+ (tty-set-up-initial-frame-faces)
+
+ ;; Unconditionally enable bracketed paste mode: terminals that don't
+ ;; support it just ignore the sequence.
+ (xterm--init-bracketed-paste-mode)
+
+ (when rxvt-set-window-title
+ (xterm--init-frame-title))
+
+ (run-hooks 'terminal-init-rxvt-hook))
;; rxvt puts the default colors into an environment variable
;; COLORFGBG. We use this to set the background mode in a more
diff --git a/lisp/term/screen.el b/lisp/term/screen.el
index 04481e8358b..9655f41b6c1 100644
--- a/lisp/term/screen.el
+++ b/lisp/term/screen.el
@@ -22,4 +22,4 @@ it runs, which can change when the screen session is moved to another tty."
(provide 'term/screen)
-;; screen.el ends here
+;;; screen.el ends here
diff --git a/lisp/term/st.el b/lisp/term/st.el
new file mode 100644
index 00000000000..9a1c0646f89
--- /dev/null
+++ b/lisp/term/st.el
@@ -0,0 +1,20 @@
+;;; st.el --- terminal initialization for st -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;;; Commentary:
+
+;; Support for the st terminal emulator.
+;; https://st.suckless.org/
+
+;;; Code:
+
+(require 'term/xterm)
+
+(defun terminal-init-st ()
+ "Terminal initialization function for st."
+ (tty-run-terminal-initialization (selected-frame) "xterm"))
+
+(provide 'term/st)
+
+;;; st.el ends here
diff --git a/lisp/term/sun.el b/lisp/term/sun.el
index 975ff06e58c..3dfd4c697a2 100644
--- a/lisp/term/sun.el
+++ b/lisp/term/sun.el
@@ -1,4 +1,4 @@
-;;; sun.el --- keybinding for standard default sunterm keys
+;;; sun.el --- keybinding for standard default sunterm keys -*- lexical-binding: t -*-
;; Copyright (C) 1987, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/tmux.el b/lisp/term/tmux.el
index aa0c98364f3..4ea6f416c8c 100644
--- a/lisp/term/tmux.el
+++ b/lisp/term/tmux.el
@@ -22,4 +22,4 @@ it runs, which can change when the tmux session is moved to another tty."
(provide 'term/tmux)
-;; tmux.el ends here
+;;; tmux.el ends here
diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el
index 34e5a18eebe..740d0654a17 100644
--- a/lisp/term/tty-colors.el
+++ b/lisp/term/tty-colors.el
@@ -1,4 +1,4 @@
-;;; tty-colors.el --- color support for character terminals
+;;; tty-colors.el --- color support for character terminals -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -923,62 +923,8 @@ The returned value reflects the standard Emacs definition of
COLOR (see the info node `(emacs) Colors'), regardless of whether
the terminal can display it, so the return value should be the
same regardless of what display is being used."
- (let ((len (length color)))
- (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec
- (eq (aref color 0) ?#)
- (member (aref color 1)
- '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
- ?a ?b ?c ?d ?e ?f
- ?A ?B ?C ?D ?E ?F)))
- ;; Translate the string "#XXYYZZ" into a list of numbers
- ;; (XX YY ZZ), scaling each to the {0..65535} range. This
- ;; follows the HTML color convention, where both "#fff" and
- ;; "#ffffff" represent the same color, white.
- (let* ((ndig (/ (- len 1) 3))
- (maxval (1- (ash 1 (* 4 ndig))))
- (i1 1)
- (i2 (+ i1 ndig))
- (i3 (+ i2 ndig))
- (i4 (+ i3 ndig)))
- (list
- (/ (* (string-to-number
- (substring color i1 i2) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i2 i3) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i3 i4) 16)
- 65535)
- maxval))))
- ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec
- (string= (substring color 0 4) "rgb:"))
- ;; Translate the string "rgb:XX/YY/ZZ" into a list of
- ;; numbers (XX YY ZZ), scaling each to the {0..65535}
- ;; range. "rgb:F/F/F" is white.
- (let* ((ndig (/ (- len 3) 3))
- (maxval (1- (ash 1 (* 4 (- ndig 1)))))
- (i1 4)
- (i2 (+ i1 ndig))
- (i3 (+ i2 ndig))
- (i4 (+ i3 ndig)))
- (list
- (/ (* (string-to-number
- (substring color i1 (- i2 1)) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i2 (- i3 1)) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i3 (1- i4)) 16)
- 65535)
- maxval))))
- (t
- (cdr (assoc color color-name-rgb-alist))))))
+ (or (color-values-from-color-spec color)
+ (cdr (assoc color color-name-rgb-alist))))
(defun tty-color-translate (color &optional frame)
"Given a color COLOR, return the index of the corresponding TTY color.
diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el
index ba1b4ae318f..4447657d44f 100644
--- a/lisp/term/tvi970.el
+++ b/lisp/term/tvi970.el
@@ -1,4 +1,4 @@
-;;; tvi970.el --- terminal support for the Televideo 970
+;;; tvi970.el --- terminal support for the Televideo 970 -*- lexical-binding: t -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el
index de70e161f41..5e32e297921 100644
--- a/lisp/term/vt100.el
+++ b/lisp/term/vt100.el
@@ -1,4 +1,4 @@
-;;; vt100.el --- define VT100 function key sequences in function-key-map
+;;; vt100.el --- define VT100 function key sequences in function-key-map -*- lexical-binding:t -*-
;; Copyright (C) 1989, 1993, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el
index dde2e229068..569b79e25a1 100644
--- a/lisp/term/vt200.el
+++ b/lisp/term/vt200.el
@@ -1,3 +1,5 @@
+;;; vt200.el -*- lexical-binding:t -*-
+
;; For our purposes we can treat the vt200 and vt100 almost alike.
;; Most differences are handled by the termcap entry.
(defun terminal-init-vt200 ()
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 1aecd68a96f..6b849164aec 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -72,18 +72,13 @@
(require 'frame)
(require 'mouse)
(require 'scroll-bar)
-(require 'faces)
(require 'select)
(require 'menu-bar)
(require 'dnd)
(require 'w32-vars)
-;; Keep an obsolete alias for w32-focus-frame and w32-select-font in case
-;; they are used by code outside Emacs.
-(define-obsolete-function-alias 'w32-focus-frame 'x-focus-frame "23.1")
(declare-function x-select-font "w32font.c"
(&optional frame exclude-proportional))
-(define-obsolete-function-alias 'w32-select-font 'x-select-font "23.1")
(defvar w32-color-map) ;; defined in w32fns.c
(make-obsolete 'w32-default-color-map nil "24.1")
@@ -231,6 +226,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;;; Set default known names for external libraries
(setq dynamic-library-alist
(list
+ '(gdiplus "gdiplus.dll")
+ '(shlwapi "shlwapi.dll")
'(xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll")
;; Versions of libpng 1.4.x and later are incompatible with
;; earlier versions. Set up the list of libraries according to
@@ -287,7 +284,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(libxml2 "libxml2-2.dll" "libxml2.dll")
'(zlib "zlib1.dll" "libz-1.dll")
'(lcms2 "liblcms2-2.dll")
- '(json "libjansson-4.dll")))
+ '(json "libjansson-4.dll")
+ '(gccjit "libgccjit-0.dll")))
;;; multi-tty support
(defvar w32-initialized nil
@@ -558,6 +556,9 @@ be found in this alist.
This alist is used by w32font.c when it looks for fonts that can display
characters from scripts for which no USBs are defined.")
+(declare-function x-list-fonts "xfaces.c"
+ (pattern &optional face frame maximum width))
+
(defun w32-find-non-USB-fonts (&optional frame size)
"Compute the value of `w32-non-USB-fonts' for specified SIZE and FRAME.
FRAME defaults to the selected frame.
@@ -569,46 +570,45 @@ default font on FRAME, or its best approximation."
(x-list-fonts "-*-*-medium-r-normal-*-*-*-*-*-*-iso10646-1"
'default frame)))
val)
- (mapc (function
- (lambda (script-desc)
- (let* ((script (car script-desc))
- (script-chars (vconcat (cdr script-desc)))
- (nchars (length script-chars))
- (fntlist all-fonts)
- (entry (list script))
- fspec ffont font-obj glyphs idx)
- ;; For each font in FNTLIST, determine whether it
- ;; supports the representative character(s) of any
- ;; scripts that have no USBs defined for it.
- (dolist (fnt fntlist)
- (setq fspec (ignore-errors (font-spec :name fnt)))
- (if fspec
- (setq ffont (find-font fspec frame)))
- (when ffont
- (setq font-obj
- (open-font ffont size frame))
- ;; Ignore fonts for which open-font returns nil:
- ;; they are buggy fonts that we cannot use anyway.
- (setq glyphs
- (if font-obj
- (font-get-glyphs font-obj
- 0 nchars script-chars)
- '[nil]))
- ;; Does this font support ALL of the script's
- ;; representative characters?
- (setq idx 0)
- (while (and (< idx nchars) (not (null (aref glyphs idx))))
- (setq idx (1+ idx)))
- (if (= idx nchars)
- ;; It does; add this font to the script's entry in alist.
- (let ((font-family (font-get font-obj :family)))
- ;; Unifont is an ugly font, and it is already
- ;; present in the default fontset.
- (unless (string= (downcase (symbol-name font-family))
- "unifont")
- (push font-family entry))))))
- (if (> (length entry) 1)
- (push (nreverse entry) val)))))
+ (mapc (lambda (script-desc)
+ (let* ((script (car script-desc))
+ (script-chars (vconcat (cdr script-desc)))
+ (nchars (length script-chars))
+ (fntlist all-fonts)
+ (entry (list script))
+ fspec ffont font-obj glyphs idx)
+ ;; For each font in FNTLIST, determine whether it
+ ;; supports the representative character(s) of any
+ ;; scripts that have no USBs defined for it.
+ (dolist (fnt fntlist)
+ (setq fspec (ignore-errors (font-spec :name fnt)))
+ (if fspec
+ (setq ffont (find-font fspec frame)))
+ (when ffont
+ (setq font-obj
+ (open-font ffont size frame))
+ ;; Ignore fonts for which open-font returns nil:
+ ;; they are buggy fonts that we cannot use anyway.
+ (setq glyphs
+ (if font-obj
+ (font-get-glyphs font-obj
+ 0 nchars script-chars)
+ '[nil]))
+ ;; Does this font support ALL of the script's
+ ;; representative characters?
+ (setq idx 0)
+ (while (and (< idx nchars) (not (null (aref glyphs idx))))
+ (setq idx (1+ idx)))
+ (if (= idx nchars)
+ ;; It does; add this font to the script's entry in alist.
+ (let ((font-family (font-get font-obj :family)))
+ ;; Unifont is an ugly font, and it is already
+ ;; present in the default fontset.
+ (unless (string= (downcase (symbol-name font-family))
+ "unifont")
+ (push font-family entry))))))
+ (if (> (length entry) 1)
+ (push (nreverse entry) val))))
(w32--filter-USB-scripts))
;; We've opened a lot of fonts, so clear the font caches to free
;; some memory.
diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el
index 8859f13bd20..1a5dc05783e 100644
--- a/lisp/term/w32console.el
+++ b/lisp/term/w32console.el
@@ -1,4 +1,4 @@
-;;; w32console.el -- Setup w32 console keys and colors.
+;;; w32console.el --- Setup w32 console keys and colors. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/term/wyse50.el b/lisp/term/wyse50.el
index 677677cf109..d3b0fdad24b 100644
--- a/lisp/term/wyse50.el
+++ b/lisp/term/wyse50.el
@@ -1,4 +1,4 @@
-;;; wyse50.el --- terminal support code for Wyse 50
+;;; wyse50.el --- terminal support code for Wyse 50 -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1993-1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -126,9 +126,9 @@
;; On such terminals, Emacs should sacrifice the first and last character of
;; each mode line, rather than a whole screen column!
(add-hook 'kill-emacs-hook
- (function (lambda () (interactive)
- (send-string-to-terminal
- (concat "\ea23R" (1+ (frame-width)) "C\eG0"))))))
+ (lambda () (interactive)
+ (send-string-to-terminal
+ (concat "\ea23R" (1+ (frame-width)) "C\eG0")))))
(defun enable-arrow-keys ()
"To be called by `tty-setup-hook'. Overrides 6 Emacs standard keys
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index f2ebd3ea224..8c6c75e7e22 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -75,7 +75,6 @@
(require 'frame)
(require 'mouse)
(require 'scroll-bar)
-(require 'faces)
(require 'select)
(require 'menu-bar)
(require 'fontset)
@@ -1356,7 +1355,7 @@ This returns an error if any Emacs frames are X frames."
(declare-function x-get-selection-internal "xselect.c"
(selection-symbol target-type &optional time-stamp terminal))
-(add-to-list 'display-format-alist '("\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" . x))
+(add-to-list 'display-format-alist '("\\`.*:[0-9]+\\(\\.[0-9]+\\)?\\'" . x))
(cl-defmethod handle-args-function (args &context (window-system x))
(x-handle-args args))
@@ -1407,13 +1406,13 @@ This returns an error if any Emacs frames are X frames."
("etc/images/right-arrow" . ("go-next" "gtk-go-forward"))
("etc/images/home" . ("go-home" "gtk-home"))
("etc/images/jump-to" . ("go-jump" "gtk-jump-to"))
- ("etc/images/index" . "gtk-index")
+ ("etc/images/index" . ("gtk-search" "gtk-index"))
("etc/images/exit" . ("application-exit" "gtk-quit"))
("etc/images/cancel" . "gtk-cancel")
("etc/images/info" . ("dialog-information" "gtk-info"))
("etc/images/bookmark_add" . "n:bookmark_add")
;; Used in Gnus and/or MH-E:
- ("etc/images/attach" . "gtk-attach")
+ ("etc/images/attach" . ("mail-attachment" "gtk-attach"))
("etc/images/connect" . "gtk-connect")
("etc/images/contact" . "gtk-contact")
("etc/images/delete" . ("edit-delete" "gtk-delete"))
@@ -1425,14 +1424,16 @@ This returns an error if any Emacs frames are X frames."
("etc/images/lock" . "gtk-lock")
("etc/images/next-page" . "gtk-next-page")
("etc/images/refresh" . ("view-refresh" "gtk-refresh"))
+ ("etc/images/search-replace" . "edit-find-replace")
("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending"))
("etc/images/sort-column-ascending" . "gtk-sort-column-ascending")
("etc/images/sort-criteria" . "gtk-sort-criteria")
("etc/images/sort-descending" . ("view-sort-descending"
"gtk-sort-descending"))
("etc/images/sort-row-ascending" . "gtk-sort-row-ascending")
+ ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check"))
("images/gnus/toggle-subscription" . "gtk-task-recurring")
- ("images/mail/compose" . "gtk-mail-compose")
+ ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose"))
("images/mail/copy" . "gtk-mail-copy")
("images/mail/forward" . "gtk-mail-forward")
("images/mail/inbox" . "gtk-inbox")
@@ -1442,7 +1443,7 @@ This returns an error if any Emacs frames are X frames."
("images/mail/reply-all" . "gtk-mail-reply-to-all")
("images/mail/reply" . "gtk-mail-reply")
("images/mail/save-draft" . "gtk-mail-handling")
- ("images/mail/send" . "gtk-mail-send")
+ ("images/mail/send" . ("mail-send" "gtk-mail-send"))
("images/mail/spam" . "gtk-spam")
;; Used for GDB Graphical Interface
("images/gud/break" . "gtk-no")
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index 150ff872a05..8bcae37afe4 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -710,15 +710,18 @@ Return the pasted text as a string."
(while (and (setq chr (xterm--read-event-for-query)) (not (equal chr ?c)))
(setq str (concat str (string chr))))
;; Since xterm-280, the terminal type (NUMBER1) is now 41 instead of 0.
- (when (string-match "\\([0-9]+\\);\\([0-9]+\\);0" str)
+ (when (string-match "\\([0-9]+\\);\\([0-9]+\\);[01]" str)
(let ((version (string-to-number (match-string 2 str))))
- (when (and (> version 2000) (equal (match-string 1 str) "1"))
+ (when (and (> version 2000)
+ (or (equal (match-string 1 str) "1")
+ (equal (match-string 1 str) "65")))
;; Hack attack! bug#16988: gnome-terminal reports "1;NNNN;0"
;; with a large NNNN but is based on a rather old xterm code.
;; Gnome terminal 2.32.1 reports 1;2802;0
;; Gnome terminal 3.6.1 reports 1;3406;0
;; Gnome terminal 3.22.2 reports 1;4601;0 and *does* support
;; background color querying (Bug#29716).
+ ;; Gnome terminal 3.38.0 reports 65;6200;1.
(when (> version 4000)
(xterm--query "\e]11;?\e\\"
'(("\e]11;" . xterm--report-background-handler))))
@@ -767,8 +770,7 @@ Can be nil to mean \"no timeout\".")
By not redisplaying right away for xterm queries, we can avoid
unsightly flashing during initialization. Give up and redisplay
anyway if we've been waiting a little while."
- (let ((start-time (current-time))
- (inhibit--record-char t))
+ (let ((start-time (current-time)))
(or (let ((inhibit-redisplay t))
(read-event nil nil xterm-query-redisplay-timeout))
(read-event nil nil
@@ -836,8 +838,8 @@ We run the first FUNCTION whose STRING matches the input events."
basemap
(make-composed-keymap map (keymap-parent basemap))))
-(defun terminal-init-xterm ()
- "Terminal initialization function for xterm."
+(defun xterm--init ()
+ "Initialize the terminal for xterm."
;; rxvt terminals sometimes set the TERM variable to "xterm", but
;; rxvt's keybindings are incompatible with xterm's. It is
;; better in that case to use rxvt's initialization function.
@@ -879,9 +881,18 @@ We run the first FUNCTION whose STRING matches the input events."
;; support it just ignore the sequence.
(xterm--init-bracketed-paste-mode)
;; We likewise unconditionally enable support for focus tracking.
- (xterm--init-focus-tracking)
+ (xterm--init-focus-tracking))
- (run-hooks 'terminal-init-xterm-hook))
+(defun terminal-init-xterm ()
+ "Terminal initialization function for xterm."
+ (unwind-protect
+ (progn
+ (xterm--init)
+ ;; If the terminal initialization completed without errors, clear
+ ;; the lossage to discard the responses of the terminal emulator
+ ;; during initialization; otherwise they appear in the recent keys.
+ (clear-this-command-keys))
+ (run-hooks 'terminal-init-xterm-hook)))
(defun xterm--init-modify-other-keys ()
"Terminal initialization for xterm's modifyOtherKeys support."
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index ccdd9210512..d9a83c566b4 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -1,12 +1,12 @@
-;;; artist.el --- draw ascii graphics with your mouse
+;;; artist.el --- draw ascii graphics with your mouse -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Author: Tomas Abrahamsson <tab@lysator.liu.se>
;; Keywords: mouse
-;; Version: 1.2.6
+;; Old-Version: 1.2.6
;; Release-date: 6-Aug-2004
-;; Location: http://www.lysator.liu.se/~tab/artist/
+;; Location: https://www.lysator.liu.se/~tab/artist/
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 19/3/2008, and the maintainer agreed that when a bug is filed in
@@ -33,7 +33,7 @@
;; What is artist?
;; ---------------
;;
-;; Artist is an Emacs lisp package that allows you to draw lines,
+;; Artist is an Emacs Lisp package that allows you to draw lines,
;; rectangles and ellipses by using your mouse and/or keyboard. The
;; shapes are made up with the ascii characters |, -, / and \.
;;
@@ -106,17 +106,8 @@
;; If you add a new drawing mode, send it to me, and I would gladly
;; include in the next release!
-;;; Installation:
-
-;; To use artist, put this in your .emacs:
-;;
-;; (autoload 'artist-mode "artist" "Enter artist-mode" t)
-
-
;;; Requirements:
-;; Artist requires Emacs 19.28 or higher.
-;;
;; Artist requires the `rect' package (which comes with Emacs) to be
;; loadable, unless the variable `artist-interface-with-rect' is set
;; to nil.
@@ -127,9 +118,6 @@
;;; Known bugs:
-;; The shifted operations are not available when drawing with the mouse
-;; in Emacs 19.29 and 19.30.
-;;
;; It is not possible to change between shifted and unshifted operation
;; while drawing with the mouse. (See the comment in the function
;; artist-shift-has-changed for further details.)
@@ -413,57 +401,43 @@ be in `artist-spray-chars', or spraying will behave strangely.")
;; Internal variables
;;
-(defvar artist-mode nil
- "Non-nil to enable `artist-mode' and nil to disable.")
-(make-variable-buffer-local 'artist-mode)
-
(defvar artist-mode-name " Artist"
"Name of Artist mode beginning with a space (appears in the mode-line).")
-(defvar artist-curr-go 'pen-line
+(defvar-local artist-curr-go 'pen-line
"Current selected graphics operation.")
-(make-variable-buffer-local 'artist-curr-go)
-(defvar artist-line-char-set nil
+(defvar-local artist-line-char-set nil
"Boolean to tell whether user has set some char to use when drawing lines.")
-(make-variable-buffer-local 'artist-line-char-set)
-(defvar artist-line-char nil
+(defvar-local artist-line-char nil
"Char to use when drawing lines.")
-(make-variable-buffer-local 'artist-line-char)
-(defvar artist-fill-char-set nil
+(defvar-local artist-fill-char-set nil
"Boolean to tell whether user has set some char to use when filling.")
-(make-variable-buffer-local 'artist-fill-char-set)
-(defvar artist-fill-char nil
+(defvar-local artist-fill-char nil
"Char to use when filling.")
-(make-variable-buffer-local 'artist-fill-char)
-(defvar artist-erase-char ?\s
+(defvar-local artist-erase-char ?\s
"Char to use when erasing.")
-(make-variable-buffer-local 'artist-erase-char)
-(defvar artist-default-fill-char ?.
+(defvar-local artist-default-fill-char ?.
"Char to use when a fill-char is required but none is set.")
-(make-variable-buffer-local 'artist-default-fill-char)
; This variable is not buffer local
(defvar artist-copy-buffer nil
"Copy buffer.")
-(defvar artist-draw-region-min-y 0
+(defvar-local artist-draw-region-min-y 0
"Line-number for top-most visited line for draw operation.")
-(make-variable-buffer-local 'artist-draw-region-min-y)
-(defvar artist-draw-region-max-y 0
+(defvar-local artist-draw-region-max-y 0
"Line-number for bottom-most visited line for draw operation.")
-(make-variable-buffer-local 'artist-draw-region-max-y)
-(defvar artist-borderless-shapes nil
+(defvar-local artist-borderless-shapes nil
"When non-nil, draw shapes without border.
The fill char is used instead, if it is set.")
-(make-variable-buffer-local 'artist-borderless-shapes)
(defvar artist-prev-next-op-alist nil
"Assoc list for looking up next and/or previous draw operation.
@@ -500,50 +474,6 @@ 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)
- ("Square" artist-select-op-square square)
- ("Rectangle" artist-select-op-rectangle rectangle)
- ("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))
@@ -596,10 +526,50 @@ 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-mode'.")
+(easy-menu-define artist-menu-map artist-mode-map
+ "Menu for `artist-mode'."
+ `("Artist"
+ ,@(mapcar
+ (lambda (op)
+ `[,(nth 0 op) ,(nth 1 op)
+ :help ,(format "Draw using the %s style" (nth 0 op))
+ :style radio
+ :selected (eq artist-curr-go ',(nth 2 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)
+ ("Square" artist-select-op-square square)
+ ("Rectangle" artist-select-op-rectangle rectangle)
+ ("Line" artist-select-op-straight-line s-line)
+ ("Pen" artist-select-op-pen-line pen-line)))
+ "---"
+ ["Character for Fill..." artist-select-fill-char
+ :help "Choose the character to insert when filling in shapes"]
+ ["Character for Line..." artist-select-line-char
+ :help "Choose the character to insert when drawing lines"]
+ ["Character to Erase..." artist-select-erase-char
+ :help "Choose a specific character to erase"]
+ ["Rubber-banding" artist-toggle-rubber-banding
+ :help "Toggle rubber-banding"
+ :style toggle
+ :selected artist-rubber-banding]
+ ["Trim Line Endings" artist-toggle-trim-line-endings
+ :help "Toggle trimming of line-endings"
+ :style toggle
+ :selected artist-trim-line-endings]
+ ["Draw Shape Borders" artist-toggle-borderless-shapes
+ :help "Toggle whether shapes are drawn with borders"
+ :style toggle
+ :selected (not artist-borderless-shapes)]
+ ["Characters for Spray" artist-select-spray-chars
+ :help "Choose characters for sprayed by the spray-can"]))
+
(defvar artist-replacement-table (make-vector 256 0)
"Replacement table for `artist-replace-char'.")
@@ -1418,32 +1388,20 @@ Keymap summary
(aset artist-replacement-table ?\t ?\s)
(aset artist-replacement-table 0 ?\s)
;; More setup
- (make-local-variable 'artist-key-is-drawing)
- (make-local-variable 'artist-key-endpoint1)
- (make-local-variable 'artist-key-poly-point-list)
- (make-local-variable 'artist-key-shape)
- (make-local-variable 'artist-key-draw-how)
- (make-local-variable 'artist-popup-menu-table)
- (make-local-variable 'artist-key-compl-table)
- (make-local-variable 'artist-prev-next-op-alist)
- (make-local-variable 'artist-rb-save-data)
- (make-local-variable 'artist-arrow-point-1)
- (make-local-variable 'artist-arrow-point-2)
- (setq artist-key-is-drawing nil)
- (setq artist-key-endpoint1 nil)
- (setq artist-key-poly-point-list nil)
- (setq artist-key-shape nil)
- (setq artist-popup-menu-table (artist-compute-popup-menu-table artist-mt))
- (setq artist-key-compl-table (artist-compute-key-compl-table artist-mt))
- (setq artist-prev-next-op-alist
- (artist-make-prev-next-op-alist artist-key-compl-table))
- (setq artist-rb-save-data (make-vector 7 0))
- (setq artist-arrow-point-1 nil)
- (setq artist-arrow-point-2 nil)
- (make-local-variable 'next-line-add-newlines)
- (setq next-line-add-newlines t)
- (setq artist-key-draw-how
- (artist-go-get-draw-how-from-symbol artist-curr-go))
+ (setq-local artist-key-is-drawing nil)
+ (setq-local artist-key-endpoint1 nil)
+ (setq-local artist-key-poly-point-list nil)
+ (setq-local artist-key-shape nil)
+ (setq-local artist-popup-menu-table (artist-compute-popup-menu-table artist-mt))
+ (setq-local artist-key-compl-table (artist-compute-key-compl-table artist-mt))
+ (setq-local artist-prev-next-op-alist
+ (artist-make-prev-next-op-alist artist-key-compl-table))
+ (setq-local artist-rb-save-data (make-vector 7 0))
+ (setq-local artist-arrow-point-1 nil)
+ (setq-local artist-arrow-point-2 nil)
+ (setq-local next-line-add-newlines t)
+ (setq-local artist-key-draw-how
+ (artist-go-get-draw-how-from-symbol artist-curr-go))
(if (and artist-picture-compatibility (not (eq major-mode 'picture-mode)))
(progn
(picture-mode)
@@ -1795,13 +1753,6 @@ info-variant-part."
"Call function FN with ARGS, if FN is not nil."
`(if ,fn (funcall ,fn ,@args)))
-(defun artist-uniq (l)
- "Remove consecutive duplicates in list L. Comparison is done with `equal'."
- (cond ((null l) nil)
- ((null (cdr l)) l) ; only one element in list
- ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal
- (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different
-
(defun artist-string-split (str r)
"Split string STR at occurrences of regexp R, returning a list of strings."
(let ((res nil)
@@ -1849,9 +1800,7 @@ Return a list (RETURN-CODE STDOUT STDERR)."
nil))
(tmp-stdout-buffer (get-buffer-create
(concat "*artist-" program "*")))
- (tmp-stderr-file-name (make-temp-file "artist-stdout."))
- (binary-process-input nil) ; for msdos
- (binary-process-output nil))
+ (tmp-stderr-file-name (make-temp-file "artist-stdout.")))
;; Prepare stdin
(if stdin (artist-string-to-file stdin tmp-stdin-file-name))
@@ -1999,25 +1948,11 @@ The replacement is used to convert tabs and new-lines to spaces."
(defun artist-replace-chars (new-char count)
"Replace characters at point with NEW-CHAR. COUNT chars are replaced."
- ;; 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.
- (let* ((replaced-c (artist-get-replacement-char new-char))
- (replaced-s (make-string count replaced-c)))
- (artist-move-to-xy (+ (artist-current-column) count)
- (artist-current-line))
- (delete-char (- count))
- (insert replaced-s))
- ;; In emacs-19, the self-insert-command works better
- (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 count))))
+ (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 count)))
(defsubst artist-replace-string (string &optional see-thru)
"Replace contents at point with STRING.
@@ -2740,7 +2675,7 @@ SHAPE-INFO is a list of four straight lines."
;; Filling rectangles and squares
;;
-(defun artist-fill-rect (rect x1 y1 x2 y2)
+(defun artist-fill-rect (_rect x1 y1 x2 y2)
"Fill rectangle RECT from X1,Y1 to X2,Y2."
(let ((x (1+ (min x1 x2)))
(y (1+ (min y1 y2)))
@@ -2752,7 +2687,7 @@ SHAPE-INFO is a list of four straight lines."
(artist-replace-chars artist-fill-char w)
(setq y (1+ y))))))
-(defun artist-fill-square (square x1 y1 x2 y2)
+(defun artist-fill-square (_square x1 y1 x2 y2)
"Fill a SQUARE from X1,Y1 to X2,Y2."
(let* ((square-corners (artist-rect-corners-squarify x1 y1 x2 y2))
(new-x1 (elt square-corners 0))
@@ -2814,12 +2749,12 @@ to append to the end of the list, when doing free-hand drawing)."
(setq artist-key-poly-point-list (list (cons x1 y1))))
-(defun artist-pen-set-arrow-points (x1 y1)
+(defun artist-pen-set-arrow-points (_x1 _y1)
"Set arrow points for pen drawing using X1, Y1.
Also, the `artist-key-poly-point-list' is reversed."
(setq artist-key-poly-point-list
- (artist-uniq artist-key-poly-point-list))
+ (seq-uniq artist-key-poly-point-list))
(if (>= (length artist-key-poly-point-list) 2)
@@ -3015,11 +2950,11 @@ Returns a list of points. Each point is on the form (X1 . Y1)."
;; Step to next spray point
(setq spray-points (cdr spray-points)))))
-(defun artist-spray-clear-circle (circle x1 y1 x2 y2)
+(defun artist-spray-clear-circle (circle _x1 _y1 _x2 _y2)
"Clear circle CIRCLE at X1, Y1 through X2, Y2."
(artist-undraw-circle circle))
-(defun artist-spray-set-radius (circle x1 y1 x2 y2)
+(defun artist-spray-set-radius (_circle x1 y1 x2 y2)
"Set spray radius from CIRCLE at X1, Y1 through X2, Y2."
(let ((dx (- x2 x1))
(dy (- y2 y1)))
@@ -3512,13 +3447,12 @@ POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR].
FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE].
The Y-RADIUS must be 0, but the X-RADIUS must not be 0."
- (let ((point-list nil)
- (width (max (- (abs (* 2 x-radius)) 1)))
+ (let ((width (max (- (abs (* 2 x-radius)) 1)))
(left-edge (1+ (- x1 (abs x-radius))))
(line-char (if artist-line-char-set artist-line-char ?-))
(i 0)
(point-list nil)
- (fill-info nil)
+ ;; (fill-info nil)
(shape-info (make-vector 2 0)))
(while (< i width)
(let* ((line-x (+ left-edge i))
@@ -3531,7 +3465,7 @@ The Y-RADIUS must be 0, but the X-RADIUS must not be 0."
(setq point-list (append point-list (list new-coord)))
(setq i (1+ i))))
(aset shape-info 0 point-list)
- (aset shape-info 1 fill-info)
+ (aset shape-info 1 nil) ;; fill-info
(artist-make-2point-object (artist-make-endpoint x1 y1)
(artist-make-endpoint x-radius y-radius)
shape-info)))
@@ -3621,7 +3555,7 @@ FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE]."
;
; Filling ellipses
;
-(defun artist-fill-ellipse (ellipse x y x-radius y-radius)
+(defun artist-fill-ellipse (ellipse _x _y _x-radius _y-radius)
"Fill an ELLIPSE centered at X,Y with radius X-RADIUS and Y-RADIUS."
(let ((fill-info (aref (artist-2point-get-shapeinfo ellipse) 1)))
(mapcar
@@ -3741,11 +3675,11 @@ original contents of that area in the buffer."
(setq x (1+ x)))
last-x)))
-(defun artist-ff-is-topmost-line (x y)
+(defun artist-ff-is-topmost-line (_x y)
"Determine whether the position X,Y is on the topmost line or not."
(= y 0))
-(defun artist-ff-is-bottommost-line (x y)
+(defun artist-ff-is-bottommost-line (_x y)
"Determine whether the position X,Y is on the bottommost line or not."
(save-excursion
(goto-char (point-max))
@@ -3761,7 +3695,6 @@ original contents of that area in the buffer."
(defun artist-flood-fill (x1 y1)
"Flood-fill starting at X1, Y1. Fill with the char in `artist-fill-char'."
(let ((stack nil)
- (input-queue nil)
;; We are flood-filling the area that has this character.
(c (artist-get-char-at-xy-conv x1 y1))
(artist-fill-char (if artist-fill-char-set
@@ -3903,7 +3836,7 @@ Optional argument STATE can be used to set state (default is nil)."
(setq artist-arrow-point-2 (artist-make-arrow-point xn yn dirn))))
-(defun artist-set-arrow-points-for-2points (shape x1 y1 x2 y2)
+(defun artist-set-arrow-points-for-2points (shape _x1 _y1 _x2 _y2)
"Generic function for setting arrow-points for 2-point shapes.
The 2-point shape SHAPE is drawn from X1, Y1 to X2, Y2."
(let* ((endpoint1 (artist-2point-get-endpoint1 shape))
@@ -3925,28 +3858,24 @@ The 2-point shape SHAPE is drawn from X1, Y1 to X2, Y2."
;; on the draw-how
;;
-(defun artist-key-undraw-continously (x y)
+(defun artist-key-undraw-continously (_x _y)
"Undraw current continuous shape with point at X, Y."
;; No undraw-info for continuous shapes
nil)
-(defun artist-key-undraw-poly (x y)
+(defun artist-key-undraw-poly (_x _y)
"Undraw current poly shape with point at X, Y."
- (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go))
- (x1 (artist-endpoint-get-x artist-key-endpoint1))
- (y1 (artist-endpoint-get-y artist-key-endpoint1)))
+ (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)))
(artist-funcall undraw-fn artist-key-shape)))
-(defun artist-key-undraw-1point (x y)
+(defun artist-key-undraw-1point (_x _y)
"Undraw current 1-point shape at X, Y."
;; No undraw-info for 1-point shapes
nil)
-(defun artist-key-undraw-2points (x y)
+(defun artist-key-undraw-2points (_x _y)
"Undraw current 2-point shape at X, Y."
- (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go))
- (x1 (artist-endpoint-get-x artist-key-endpoint1))
- (y1 (artist-endpoint-get-y artist-key-endpoint1)))
+ (let ((undraw-fn (artist-go-get-undraw-fn-from-symbol artist-curr-go)))
(artist-funcall undraw-fn artist-key-shape)))
(defun artist-key-undraw-common ()
@@ -4090,7 +4019,7 @@ Trimming here means removing white space at end of a line."
(setq artist-key-shape (artist-funcall draw-fn x1 y1 x2 y2))))))
-(defun artist-key-do-continously-1point (x y)
+(defun artist-key-do-continously-1point (_x _y)
"Update current 1-point shape at X,Y."
;; Nothing to do continuously for operations
;; where we have only one input point
@@ -4290,8 +4219,7 @@ If optional argument THIS-IS-LAST-POINT is non-nil, this point is the last."
(defun artist-key-set-point-1point (x y)
"Set point for current 1-point shape at X,Y."
- (let ((draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go))
- (init-fn (artist-go-get-init-fn-from-symbol artist-curr-go))
+ (let ((init-fn (artist-go-get-init-fn-from-symbol artist-curr-go))
(prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol artist-curr-go))
(exit-fn (artist-go-get-exit-fn-from-symbol artist-curr-go))
(draw-fn (artist-go-get-draw-fn-from-symbol artist-curr-go))
@@ -4821,7 +4749,7 @@ If optional argument STATE is positive, turn borders on."
(orig-draw-region-min-y artist-draw-region-min-y)
(orig-draw-region-max-y artist-draw-region-max-y)
(orig-pointer-shape (if (eq window-system 'x) x-pointer-shape nil))
- (echoq-keystrokes 10000) ; a lot of seconds
+ (echo-keystrokes 0) ; Don't echo unfinished commands.
;; Remember original binding for the button-up event to this
;; button-down event.
(key (artist-compute-up-event-key ev))
@@ -4937,7 +4865,7 @@ If optional argument STATE is positive, turn borders on."
;; Mouse routines
;;
-(defsubst artist-shift-has-changed (shift-state ev)
+(defsubst artist-shift-has-changed (_shift-state _ev)
"From the last SHIFT-STATE and EV, determine if the shift-state has changed."
;; This one simply doesn't work.
;;
@@ -4962,6 +4890,12 @@ If optional argument STATE is positive, turn borders on."
(cons (+ window-x window-start-x)
(+ window-y window-start-y))))
+(defun artist--adjust-x (x)
+ "Adjust the X position wrt. `display-line-numbers-mode'."
+ (let ((adjust (line-number-display-width)))
+ (if (= adjust 0)
+ x
+ (- x adjust 2))))
(defun artist-mouse-draw-continously (ev)
"Generic function for shapes that require 1 point as input.
@@ -4983,10 +4917,9 @@ The event, EV, is the mouse event."
(ev-start (event-start ev))
(initial-win (posn-window ev-start))
(ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start)))
- (x1 (car ev-start-pos))
+ (x1 (artist--adjust-x (car ev-start-pos)))
(y1 (cdr ev-start-pos))
- (shape)
- (timer))
+ (timer nil))
(select-window (posn-window ev-start))
(artist-funcall init-fn x1 y1)
(if (not artist-rubber-banding)
@@ -5000,7 +4933,7 @@ The event, EV, is the mouse event."
(member 'down (event-modifiers ev)))
(setq ev-start-pos (artist-coord-win-to-buf
(posn-col-row (event-start ev))))
- (setq x1 (car ev-start-pos))
+ (setq x1 (artist--adjust-x (car ev-start-pos)))
(setq y1 (cdr ev-start-pos))
;; Cancel previous timer
@@ -5030,7 +4963,7 @@ The event, EV, is the mouse event."
(setq draw-fn (artist-go-get-draw-fn-from-symbol op))))
;; Draw the new shape
- (setq shape (artist-funcall draw-fn x1 y1))
+ (artist-funcall draw-fn x1 y1)
(artist-move-to-xy x1 y1)
;; Start the timer to call `draw-fn' repeatedly every
@@ -5039,7 +4972,7 @@ The event, EV, is the mouse event."
(setq timer (run-at-time interval interval draw-fn x1 y1))))
;; Read next event
- (setq ev (read-event))))
+ (setq ev (read--potential-mouse-event))))
;; Cleanup: get rid of any active timer.
(if timer
(cancel-timer timer)))
@@ -5080,7 +5013,7 @@ The event, EV, is the mouse event."
(ev-start (event-start ev))
(initial-win (posn-window ev-start))
(ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start)))
- (x1-last (car ev-start-pos))
+ (x1-last (artist--adjust-x (car ev-start-pos)))
(y1-last (cdr ev-start-pos))
(x2 x1-last)
(y2 y1-last)
@@ -5172,7 +5105,7 @@ The event, EV, is the mouse event."
;;
(setq ev-start-pos (artist-coord-win-to-buf
(posn-col-row (event-start ev))))
- (setq x2 (car ev-start-pos))
+ (setq x2 (artist--adjust-x (car ev-start-pos)))
(setq y2 (cdr ev-start-pos))
;; Draw the new shape (if not rubber-banding, place both marks)
@@ -5199,7 +5132,7 @@ The event, EV, is the mouse event."
;; set x2 and y2
(setq ev-start-pos (artist-coord-win-to-buf
(posn-col-row (event-start ev))))
- (setq x2 (car ev-start-pos))
+ (setq x2 (artist--adjust-x (car ev-start-pos)))
(setq y2 (cdr ev-start-pos))
;; First undraw last shape
@@ -5247,7 +5180,7 @@ The event, EV, is the mouse event."
;; Read next event (only if we should not stop)
(if (not done)
- (setq ev (read-event)))))
+ (setq ev (read--potential-mouse-event)))))
;; Reverse point-list (last points are cond'ed first)
(setq point-list (reverse point-list))
@@ -5275,7 +5208,6 @@ Operation is done once. The event, EV, is the mouse event."
(shifted (artist-go-get-symbol-shift artist-curr-go t))
(shift-state (artist-event-is-shifted ev))
(op (if shift-state shifted unshifted))
- (draw-how (artist-go-get-draw-how-from-symbol op))
(init-fn (artist-go-get-init-fn-from-symbol op))
(prep-fill-fn (artist-go-get-prep-fill-fn-from-symbol op))
(exit-fn (artist-go-get-exit-fn-from-symbol op))
@@ -5284,7 +5216,7 @@ Operation is done once. The event, EV, is the mouse event."
(arrow-set-fn (artist-go-get-arrow-set-fn-from-symbol op))
(ev-start (event-start ev))
(ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start)))
- (x1 (car ev-start-pos))
+ (x1 (artist--adjust-x (car ev-start-pos)))
(y1 (cdr ev-start-pos)))
(select-window (posn-window ev-start))
(artist-funcall init-fn x1 y1)
@@ -5318,7 +5250,7 @@ The event, EV, is the mouse event."
(ev-start (event-start ev))
(initial-win (posn-window ev-start))
(ev-start-pos (artist-coord-win-to-buf (posn-col-row ev-start)))
- (x1 (car ev-start-pos))
+ (x1 (artist--adjust-x (car ev-start-pos)))
(y1 (cdr ev-start-pos))
(x2)
(y2)
@@ -5332,7 +5264,7 @@ The event, EV, is the mouse event."
(member 'down (event-modifiers ev)))
(setq ev-start-pos (artist-coord-win-to-buf
(posn-col-row (event-start ev))))
- (setq x2 (car ev-start-pos))
+ (setq x2 (artist--adjust-x (car ev-start-pos)))
(setq y2 (cdr ev-start-pos))
(if (not (eq initial-win (posn-window (event-start ev))))
@@ -5375,7 +5307,7 @@ The event, EV, is the mouse event."
;; Read next event
- (setq ev (read-event))))
+ (setq ev (read--potential-mouse-event))))
;; If we are not rubber-banding (that is, we were moving around the `2')
;; draw the shape
@@ -5407,8 +5339,7 @@ The event, EV, is the mouse event."
(interactive)
(require 'reporter)
(if (y-or-n-p "Do you want to submit a bug report on Artist? ")
- (let ((to artist-maintainer-address)
- (vars '(window-system
+ (let ((vars '(window-system
window-system-version
;;
artist-rubber-banding
@@ -5423,10 +5354,9 @@ The event, EV, is the mouse event."
artist-arrow-point-2)))
;; Remove those variables from vars that are not bound
(mapc
- (function
- (lambda (x)
- (if (not (and (boundp x) (symbol-value x)))
- (setq vars (delq x vars))))) vars)
+ (lambda (x)
+ (if (not (and (boundp x) (symbol-value x)))
+ (setq vars (delq x vars)))) vars)
(reporter-submit-bug-report
artist-maintainer-address
(concat "artist.el " artist-version)
@@ -5435,10 +5365,7 @@ The event, EV, is the mouse event."
(concat "Hello Tomas,\n\n"
"I have a nice bug report on Artist for you! Here it is:")))))
-
-;;
-;; Now provide this minor mode
-;;
+(define-obsolete-function-alias 'artist-uniq #'seq-uniq "28.1")
(provide 'artist)
diff --git a/lisp/textmodes/bib-mode.el b/lisp/textmodes/bib-mode.el
index 1e22287d32e..e2fd3ecaa42 100644
--- a/lisp/textmodes/bib-mode.el
+++ b/lisp/textmodes/bib-mode.el
@@ -1,4 +1,4 @@
-;;; bib-mode.el --- major mode for editing bib files
+;;; bib-mode.el --- major mode for editing bib files -*- lexical-binding: t -*-
;; Copyright (C) 1989, 2001-2021 Free Software Foundation, Inc.
@@ -29,6 +29,8 @@
;; bibliography file. Keys are automagically inserted as you type,
;; and appropriate keys are presented for various kinds of entries.
+;; FIXME: Fix the namespace use of this library.
+
;;; Code:
(defgroup bib nil
@@ -39,21 +41,19 @@
(defcustom bib-file "~/my-bibliography.bib"
"Default name of file used by `addbib'."
- :type 'file
- :group 'bib)
+ :type 'file)
(defcustom unread-bib-file "~/to-be-read.bib"
"Default name of file used by `unread-bib' in Bib mode."
- :type 'file
- :group 'bib)
+ :type 'file)
(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)
+ (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 ()
@@ -138,8 +138,7 @@ with the cdr.")
(defcustom bib-auto-capitalize t
"True to automatically capitalize appropriate fields in Bib mode."
- :type 'boolean
- :group 'bib)
+ :type 'boolean)
(defconst bib-capitalized-fields "%[AETCBIJR]")
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el
index 37b373054d4..27b2e0e3331 100644
--- a/lisp/textmodes/bibtex-style.el
+++ b/lisp/textmodes/bibtex-style.el
@@ -24,7 +24,6 @@
;; Done: font-lock, imenu, outline, commenting, indentation.
;; Todo: tab-completion.
-;; Bugs:
;;; Code:
@@ -49,7 +48,7 @@
"REVERSE" "SORT" "STRINGS"))
(defconst bibtex-style-functions
- ;; From http://www.eeng.dcu.ie/local-docs/btxdocs/btxhak/btxhak/node4.html.
+ ;; From https://www.eeng.dcu.ie/local-docs/btxdocs/btxhak/btxhak/node4.html.
'("<" ">" "=" "+" "-" "*" ":="
"add.period$" "call.type$" "change.case$" "chr.to.int$" "cite$"
"duplicate$" "empty$" "format.name$" "if$" "int.to.chr$" "int.to.str$"
@@ -66,12 +65,12 @@
;;;###autoload
(define-derived-mode bibtex-style-mode nil "BibStyle"
"Major mode for editing BibTeX style files."
- (set (make-local-variable 'comment-start) "%")
- (set (make-local-variable 'outline-regexp) "^[a-z]")
- (set (make-local-variable 'imenu-generic-expression)
- '((nil "\\<\\(FUNCTION\\|MACRO\\)\\s-+{\\([^}\n]+\\)}" 2)))
- (set (make-local-variable 'indent-line-function) 'bibtex-style-indent-line)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (setq-local comment-start "%")
+ (setq-local outline-regexp "^[a-z]")
+ (setq-local imenu-generic-expression
+ '((nil "\\<\\(FUNCTION\\|MACRO\\)\\s-+{\\([^}\n]+\\)}" 2)))
+ (setq-local indent-line-function #'bibtex-style-indent-line)
+ (setq-local parse-sexp-ignore-comments t)
(setq font-lock-defaults
'(bibtex-style-font-lock-keywords nil t
((?. . "w")))))
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 80f237720c3..31186fb4fac 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -40,7 +40,7 @@
;;; Code:
-(require 'button)
+(require 'iso8601)
;; User Options:
@@ -85,8 +85,8 @@ If this is a function, call it to generate the initial field text."
:type '(choice (const :tag "None" nil)
(string :tag "Initial text")
(function :tag "Initialize Function")
- (const :tag "Default" t)))
-(put 'bibtex-include-OPTkey 'risky-local-variable t)
+ (const :tag "Default" t))
+ :risky t)
(defcustom bibtex-user-optional-fields
'(("annote" "Personal annotation (ignored)"))
@@ -97,8 +97,8 @@ in `bibtex-BibTeX-entry-alist' (which see)."
:type '(repeat (group (string :tag "Field")
(string :tag "Comment")
(option (choice :tag "Init"
- (const nil) string function)))))
-(put 'bibtex-user-optional-fields 'risky-local-variable t)
+ (const nil) string function))))
+ :risky t)
(defcustom bibtex-entry-format
'(opts-or-alts required-fields numerical-fields)
@@ -122,7 +122,8 @@ last-comma Add or delete comma on end of last field in entry,
according to value of `bibtex-comma-after-last-field'.
delimiters Change delimiters according to variables
`bibtex-field-delimiters' and `bibtex-entry-delimiters'.
-unify-case Change case of entry types and field names.
+unify-case Change case of entry and field names according to
+ `bibtex-unify-case-function'.
braces Enclose parts of field entries by braces according to
`bibtex-field-braces-alist'.
strings Replace parts of field entries by string constants
@@ -148,20 +149,18 @@ The value nil means do no formatting at all."
(const unify-case)
(const braces)
(const strings)
- (const sort-fields))))
-(put 'bibtex-entry-format 'safe-local-variable
- (lambda (x)
- (or (eq x t)
- (let ((OK t))
- (while (consp x)
- (unless (memq (pop x)
- '(opts-or-alts required-fields numerical-fields
- page-dashes whitespace inherit-booktitle realign
- last-comma delimiters unify-case braces strings
- sort-fields))
- (setq OK nil)))
- (unless (null x) (setq OK nil))
- OK))))
+ (const sort-fields)))
+ :safe (lambda (x)
+ (or (eq x t)
+ (let ((ok t))
+ (while (consp x)
+ (unless (memq (pop x)
+ '( opts-or-alts required-fields numerical-fields
+ page-dashes whitespace inherit-booktitle
+ realign last-comma delimiters unify-case
+ braces strings sort-fields ))
+ (setq ok nil)))
+ (unless x ok)))))
(defcustom bibtex-field-braces-alist nil
"Alist of field regexps that \\[bibtex-clean-entry] encloses by braces.
@@ -184,6 +183,17 @@ Space characters in REGEXP will be replaced by \"[ \\t\\n]+\"."
(regexp :tag "From regexp")
(regexp :tag "To string constant"))))
+(defcustom bibtex-unify-case-function #'identity
+ "Function for unifying case of entry and field names.
+It is called with one argument, the entry or field name."
+ :version "28.1"
+ :type '(choice (const :tag "Same case as in `bibtex-field-alist'" identity)
+ (const :tag "Downcase" downcase)
+ (const :tag "Capitalize" capitalize)
+ (const :tag "Upcase" upcase)
+ (function :tag "Conversion function"))
+ :safe (lambda (x) (memq x '(upcase downcase capitalize identity))))
+
(defcustom bibtex-clean-entry-hook nil
"List of functions to call when entry has been cleaned.
Functions are called with point inside the cleaned entry, and the buffer
@@ -194,22 +204,35 @@ narrowed to just the entry."
(defcustom bibtex-maintain-sorted-entries nil
"If non-nil, BibTeX mode maintains all entries in sorted order.
Allowed non-nil values are:
-plain or t All entries are sorted alphabetically.
-crossref All entries are sorted alphabetically unless an entry has a
+plain or t Sort entries alphabetically by keys.
+crossref Sort entries alphabetically by keys unless an entry has a
crossref field. These crossrefed entries are placed in
alphabetical order immediately preceding the main entry.
entry-class The entries are divided into classes according to their
entry type, see `bibtex-sort-entry-class'. Within each class
- the entries are sorted alphabetically.
+ sort entries alphabetically by keys.
+(INDEX-FUN PREDICATE)
+(INDEX-FUN PREDICATE INIT-FUN) Sort entries using INDEX-FUN and PREDICATE.
+ Function INDEX-FUN is called for each entry with point at the
+ end of the head of the entry. Its return values are used to
+ sort the entries using PREDICATE. Function PREDICATE takes two
+ arguments INDEX1 and INDEX2 as returned by INDEX-FUN.
+ It should return non-nil if INDEX1 should sort before INDEX2.
+ If INIT-FUN is non-nil, it should be a function that is called
+ with no arguments to initialize the sorting.
See also `bibtex-sort-ignore-string-entries'."
:group 'bibtex
+ :version "28.1"
:type '(choice (const nil)
+ (const t)
(const plain)
(const crossref)
(const entry-class)
- (const t)))
-(put 'bibtex-maintain-sorted-entries 'safe-local-variable
- (lambda (a) (memq a '(nil t plain crossref entry-class))))
+ (group :tag "Custom scheme"
+ (function :tag "Index-Fun")
+ (function :tag "Predicate")
+ (option (function :tag "Init-Fun"))))
+ :safe (lambda (a) (memq a '(nil t plain crossref entry-class))))
(defcustom bibtex-sort-entry-class
'(("String")
@@ -223,18 +246,17 @@ to all entries not explicitly mentioned."
:group 'bibtex
:type '(repeat (choice :tag "Class"
(const :tag "catch-all" (catch-all))
- (repeat :tag "Entry type" string))))
-(put 'bibtex-sort-entry-class 'safe-local-variable
- (lambda (x) (let ((OK t))
- (while (consp x)
- (let ((y (pop x)))
- (while (consp y)
- (let ((z (pop y)))
- (unless (or (stringp z) (eq z 'catch-all))
- (setq OK nil))))
- (unless (null y) (setq OK nil))))
- (unless (null x) (setq OK nil))
- OK)))
+ (repeat :tag "Entry type" string)))
+ :safe (lambda (x)
+ (let ((ok t))
+ (while (consp x)
+ (let ((y (pop x)))
+ (while (consp y)
+ (let ((z (pop y)))
+ (unless (or (stringp z) (eq z 'catch-all))
+ (setq ok nil))))
+ (when y (setq ok nil))))
+ (unless x ok))))
(defcustom bibtex-sort-ignore-string-entries t
"If non-nil, BibTeX @String entries are not sort-significant.
@@ -290,7 +312,9 @@ If parsing fails, try to set this variable to nil."
(option (choice :tag "Comment" :value nil
(const nil) string))
(option (choice :tag "Init" :value nil
- (const nil) string function)))))))
+ (const nil) string function))
+ (option (choice :tag "Alternative" :value nil
+ (const nil) integer)))))))
(define-obsolete-variable-alias 'bibtex-entry-field-alist
'bibtex-BibTeX-entry-alist "24.1")
@@ -391,13 +415,13 @@ If parsing fails, try to set this variable to nil."
(("author")
("howpublished" "The way in which the booklet was published")
("address") ("month") ("year") ("note")))
- ("PhdThesis" "PhD. Thesis"
+ ("PhdThesis" "PhD Thesis"
(("author")
- ("title" "Title of the PhD. thesis")
- ("school" "School where the PhD. thesis was written")
+ ("title" "Title of the PhD thesis")
+ ("school" "School where the PhD thesis was written")
("year"))
nil
- (("type" "Type of the PhD. thesis")
+ (("type" "Type of the PhD thesis")
("address" "Address of the school (if not part of field \"school\") or country")
("month") ("note")))
("MastersThesis" "Master's Thesis"
@@ -440,7 +464,7 @@ If parsing fails, try to set this variable to nil."
"Alist of BibTeX entry types and their associated fields.
Elements are lists (ENTRY-TYPE DOC REQUIRED CROSSREF OPTIONAL).
ENTRY-TYPE is the type of a BibTeX entry.
-DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used.
+DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used.
REQUIRED is a list of required fields.
CROSSREF is a list of fields that are optional if a crossref field
is present; but these fields are required otherwise.
@@ -455,267 +479,382 @@ COMMENT is the comment string that appears in the echo area.
If COMMENT is nil use `bibtex-BibTeX-field-alist' if possible.
INIT is either the initial content of the field or a function,
which is called to determine the initial content of the field.
-ALTERNATIVE if non-nil is an integer that numbers sets of
-alternatives, starting from zero."
+ALTERNATIVE if non-nil is an integer N that numbers sets of
+alternatives. A negative integer -N indicates an alias for the
+field +N. Such aliases are ignored by `bibtex-entry' in the template
+for a new entry."
:group 'bibtex
- :version "26.1" ; add Conference
- :type 'bibtex-entry-alist)
-(put 'bibtex-BibTeX-entry-alist 'risky-local-variable t)
+ :version "28.1" ; extend alternatives
+ :type 'bibtex-entry-alist
+ :risky t)
(defcustom bibtex-biblatex-entry-alist
;; Compare in biblatex documentation:
;; Sec. 2.1.1 Regular types (required and optional fields)
+ ;; Sec. 2.2.5 Field Aliases
;; Appendix A Default Crossref setup
'(("Article" "Article in Journal"
- (("author") ("title") ("journaltitle")
- ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("journaltitle" nil nil 3) ("journal" nil nil -3)
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("translator") ("annotator") ("commentator") ("subtitle") ("titleaddon")
- ("editor") ("editora") ("editorb") ("editorc")
- ("journalsubtitle") ("issuetitle") ("issuesubtitle")
+ ("editor") ("editora") ("editorb") ("editorc") ("journalsubtitle")
+ ("journaltitleaddon") ("issuetitle") ("issuesubtitle") ("issuetitleaddon")
("language") ("origlanguage") ("series") ("volume") ("number") ("eid")
("issue") ("month") ("pages") ("version") ("note") ("issn")
- ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass")
- ("eprinttype") ("url") ("urldate")))
+ ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Book" "Single-Volume Book"
- (("author") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("editor") ("editora") ("editorb") ("editorc")
("translator") ("annotator") ("commentator")
("introduction") ("foreword") ("afterword") ("subtitle") ("titleaddon")
("maintitle") ("mainsubtitle") ("maintitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes")
- ("series") ("number") ("note") ("publisher") ("location") ("isbn")
+ ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("isbn") ("eid")
("chapter") ("pages") ("pagetotal") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("MVBook" "Multi-Volume Book"
- (("author") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("editor") ("editora") ("editorb") ("editorc")
("translator") ("annotator") ("commentator")
("introduction") ("foreword") ("afterword") ("subtitle")
("titleaddon") ("language") ("origlanguage") ("edition") ("volumes")
("series") ("number") ("note") ("publisher")
- ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("InBook" "Chapter or Pages in a Book"
- (("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("title") ("date" nil nil 1) ("year" nil nil -1))
(("author") ("booktitle"))
(("bookauthor") ("editor") ("editora") ("editorb") ("editorc")
("translator") ("annotator") ("commentator") ("introduction") ("foreword")
("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes")
- ("series") ("number") ("note") ("publisher") ("location") ("isbn")
- ("chapter") ("pages") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("isbn") ("eid")
+ ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("BookInBook" "Book in Collection" ; same as @inbook
- (("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("title") ("date" nil nil 1) ("year" nil nil -1))
(("author") ("booktitle"))
(("bookauthor") ("editor") ("editora") ("editorb") ("editorc")
("translator") ("annotator") ("commentator") ("introduction") ("foreword")
("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes")
- ("series") ("number") ("note") ("publisher") ("location") ("isbn")
- ("chapter") ("pages") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("isbn") ("eid")
+ ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("SuppBook" "Supplemental Material in a Book" ; same as @inbook
- (("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("title") ("date" nil nil 1) ("year" nil nil -1))
(("author") ("booktitle"))
(("bookauthor") ("editor") ("editora") ("editorb") ("editorc")
("translator") ("annotator") ("commentator") ("introduction") ("foreword")
("afterword") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition") ("volumes")
- ("series") ("number") ("note") ("publisher") ("location") ("isbn")
- ("chapter") ("pages") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("isbn") ("eid")
+ ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint")("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Booklet" "Booklet (Bound, but no Publisher)"
(("author" nil nil 0) ("editor" nil nil 0) ("title")
- ("year" nil nil 1) ("date" nil nil 1))
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("subtitle") ("titleaddon") ("language") ("howpublished") ("type")
- ("note") ("location") ("chapter") ("pages") ("pagetotal") ("addendum")
- ("pubstate") ("doi") ("eprint") ("eprintclass") ("eprinttype")
+ ("note") ("location" nil nil 2) ("address" nil nil -2)
+ ("eid") ("chapter") ("pages") ("pagetotal")
+ ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
("url") ("urldate")))
("Collection" "Single-Volume Collection"
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("editor") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("editora") ("editorb") ("editorc") ("translator") ("annotator")
("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("language") ("origlanguage") ("volume")
("part") ("edition") ("volumes") ("series") ("number") ("note")
- ("publisher") ("location") ("isbn") ("chapter") ("pages") ("pagetotal")
- ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass")
- ("eprinttype") ("url") ("urldate")))
+ ("publisher") ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter") ("pages")
+ ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("MVCollection" "Multi-Volume Collection"
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("editor") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("editora") ("editorb") ("editorc") ("translator") ("annotator")
("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("language") ("origlanguage") ("edition")
("volumes") ("series") ("number") ("note") ("publisher")
- ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("InCollection" "Article in a Collection"
- (("author") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
(("booktitle"))
- (("editor") ("editora") ("editorb") ("editorc") ("translator") ("annotator")
- ("commentator") ("introduction") ("foreword") ("afterword")
+ (("editor") ("editora") ("editorb") ("editorc") ("translator")
+ ("annotator") ("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition")
- ("volumes") ("series") ("number") ("note") ("publisher") ("location")
- ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("volumes") ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("SuppCollection" "Supplemental Material in a Collection" ; same as @incollection
- (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
(("booktitle"))
- (("editora") ("editorb") ("editorc") ("translator") ("annotator")
- ("commentator") ("introduction") ("foreword") ("afterword")
+ (("editor") ("editora") ("editorb") ("editorc") ("translator")
+ ("annotator") ("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition")
- ("volumes") ("series") ("number") ("note") ("publisher") ("location")
- ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("volumes") ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
+ ("Dataset" "Data Set"
+ (("author" nil nil 0) ("editor" nil nil 0) ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
+ nil
+ (("subtitle") ("titleaddon") ("language") ("edition") ("type") ("series")
+ ("number") ("version") ("note") ("organization") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Manual" "Technical Manual"
(("author" nil nil 0) ("editor" nil nil 0) ("title")
- ("year" nil nil 1) ("date" nil nil 1))
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("subtitle") ("titleaddon") ("language") ("edition")
("type") ("series") ("number") ("version") ("note")
- ("organization") ("publisher") ("location") ("isbn") ("chapter")
- ("pages") ("pagetotal") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("organization") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter")
+ ("pages") ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Misc" "Miscellaneous"
(("author" nil nil 0) ("editor" nil nil 0) ("title")
- ("year" nil nil 1) ("date" nil nil 1))
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("subtitle") ("titleaddon") ("language") ("howpublished") ("type")
- ("version") ("note") ("organization") ("location")
- ("date") ("month") ("year") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("version") ("note") ("organization")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("month") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Online" "Online Resource"
(("author" nil nil 0) ("editor" nil nil 0) ("title")
- ("year" nil nil 1) ("date" nil nil 1) ("url"))
+ ("date" nil nil 1) ("year" nil nil -1)
+ ("doi" nil nil 2) ("eprint" nil nil 2) ("url" nil nil 2))
nil
(("subtitle") ("titleaddon") ("language") ("version") ("note")
- ("organization") ("date") ("month") ("year") ("addendum")
- ("pubstate") ("urldate")))
+ ("organization") ("month") ("addendum")
+ ("pubstate") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5) ("urldate")))
("Patent" "Patent"
- (("author") ("title") ("number") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title") ("number")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
- (("holder") ("subtitle") ("titleaddon") ("type") ("version") ("location")
- ("note") ("date") ("month") ("year") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ (("holder") ("subtitle") ("titleaddon") ("type") ("version")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("note") ("month") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Periodical" "Complete Issue of a Periodical"
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("editor") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
- (("editora") ("editorb") ("editorc") ("subtitle") ("issuetitle")
- ("issuesubtitle") ("language") ("series") ("volume") ("number") ("issue")
- ("date") ("month") ("year") ("note") ("issn") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ (("editora") ("editorb") ("editorc") ("subtitle") ("titleaddon")
+ ("issuetitle") ("issuesubtitle") ("issuetitleaddon") ("language")
+ ("series") ("volume") ("number") ("issue")
+ ("month") ("note") ("issn") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("SuppPeriodical" "Supplemental Material in a Periodical" ; same as @article
- (("author") ("title") ("journaltitle")
- ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("journaltitle" nil nil 3) ("journal" nil nil -3)
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("translator") ("annotator") ("commentator") ("subtitle") ("titleaddon")
- ("editor") ("editora") ("editorb") ("editorc")
- ("journalsubtitle") ("issuetitle") ("issuesubtitle")
+ ("editor") ("editora") ("editorb") ("editorc") ("journalsubtitle")
+ ("journaltitleaddon") ("issuetitle") ("issuesubtitle") ("issuetitleaddon")
("language") ("origlanguage") ("series") ("volume") ("number") ("eid")
("issue") ("month") ("pages") ("version") ("note") ("issn")
- ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass")
- ("eprinttype") ("url") ("urldate")))
+ ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Proceedings" "Single-Volume Conference Proceedings"
- (("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("title") ("date" nil nil 1) ("year" nil nil -1))
nil
- (("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
- ("maintitleaddon") ("eventtitle") ("eventdate") ("venue") ("language")
- ("editor")
- ("volume") ("part") ("volumes") ("series") ("number") ("note")
- ("organization") ("publisher") ("location") ("month")
- ("isbn") ("chapter") ("pages") ("pagetotal") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ (("editor") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
+ ("maintitleaddon") ("eventtitle") ("eventtitleaddon") ("eventdate")
+ ("venue") ("language") ("volume") ("part") ("volumes") ("series")
+ ("number") ("note") ("organization") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("month")
+ ("isbn") ("eid") ("chapter") ("pages") ("pagetotal") ("addendum")
+ ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("MVProceedings" "Multi-Volume Conference Proceedings"
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("title") ("date" nil nil 1) ("year" nil nil -1))
nil
- (("subtitle") ("titleaddon") ("eventtitle") ("eventdate") ("venue")
- ("language") ("volumes") ("series") ("number") ("note")
- ("organization") ("publisher") ("location") ("month")
- ("isbn") ("pagetotal") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ (("editor") ("subtitle") ("titleaddon") ("eventtitle") ("eventtitleaddon")
+ ("eventdate") ("venue") ("language") ("volumes") ("series") ("number")
+ ("note") ("organization") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("month")
+ ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("InProceedings" "Article in Conference Proceedings"
- (("author") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
(("booktitle"))
(("editor") ("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
- ("eventtitle") ("eventdate") ("venue") ("language")
+ ("eventtitle") ("eventtitleaddon") ("eventdate") ("venue") ("language")
("volume") ("part") ("volumes") ("series") ("number") ("note")
- ("organization") ("publisher") ("location") ("month") ("isbn")
- ("chapter") ("pages") ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("organization") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2) ("month") ("isbn") ("eid")
+ ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Reference" "Single-Volume Work of Reference" ; same as @collection
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("editor") ("title") ("date" nil nil 1) ("year" nil nil -1))
nil
(("editora") ("editorb") ("editorc") ("translator") ("annotator")
("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("language") ("origlanguage") ("volume")
("part") ("edition") ("volumes") ("series") ("number") ("note")
- ("publisher") ("location") ("isbn") ("chapter") ("pages") ("pagetotal")
- ("addendum") ("pubstate") ("doi") ("eprint") ("eprintclass")
- ("eprinttype") ("url") ("urldate")))
+ ("publisher") ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter") ("pages")
+ ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("MVReference" "Multi-Volume Work of Reference" ; same as @mvcollection
- (("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("editor") ("title") ("date" nil nil 1) ("year" nil nil -1))
nil
(("editora") ("editorb") ("editorc") ("translator") ("annotator")
("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("language") ("origlanguage") ("edition")
("volumes") ("series") ("number") ("note") ("publisher")
- ("location") ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("InReference" "Article in a Work of Reference" ; same as @incollection
- (("author") ("editor") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title") ("date" nil nil 1) ("year" nil nil -1))
(("booktitle"))
- (("editora") ("editorb") ("editorc") ("translator") ("annotator")
- ("commentator") ("introduction") ("foreword") ("afterword")
+ (("editor") ("editora") ("editorb") ("editorc") ("translator")
+ ("annotator") ("commentator") ("introduction") ("foreword") ("afterword")
("subtitle") ("titleaddon") ("maintitle") ("mainsubtitle")
("maintitleaddon") ("booksubtitle") ("booktitleaddon")
("language") ("origlanguage") ("volume") ("part") ("edition")
- ("volumes") ("series") ("number") ("note") ("publisher") ("location")
- ("isbn") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
- ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ ("volumes") ("series") ("number") ("note") ("publisher")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("eid") ("chapter") ("pages") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Report" "Technical or Research Report"
- (("author") ("title") ("type") ("institution")
- ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title") ("type")
+ ("institution" nil nil 6) ("school" nil nil -6)
+ ("date" nil nil 1) ("year" nil nil -1))
nil
(("subtitle") ("titleaddon") ("language") ("number") ("version") ("note")
- ("location") ("month") ("isrn") ("chapter") ("pages") ("pagetotal")
- ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
- ("Thesis" "PhD. or Master's Thesis"
- (("author") ("title") ("type") ("institution")
- ("year" nil nil 0) ("date" nil nil 0))
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("month") ("isrn") ("eid") ("chapter") ("pages")
+ ("pagetotal") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
+ ("Software" "Computer Software" ; Same as @misc.
+ (("author" nil nil 0) ("editor" nil nil 0) ("title")
+ ("date" nil nil 1) ("year" nil nil -1))
nil
- (("subtitle") ("titleaddon") ("language") ("note") ("location")
- ("month") ("isbn") ("chapter") ("pages") ("pagetotal")
- ("addendum") ("pubstate")
- ("doi") ("eprint") ("eprintclass") ("eprinttype") ("url") ("urldate")))
+ (("subtitle") ("titleaddon") ("language") ("howpublished") ("type")
+ ("version") ("note") ("organization")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("month") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
+ ("Thesis" "PhD or Master's Thesis"
+ (("author") ("title") ("type")
+ ("institution" nil nil 6) ("school" nil nil -6)
+ ("date" nil nil 1) ("year" nil nil -1))
+ nil
+ (("subtitle") ("titleaddon") ("language") ("note")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("month") ("isbn") ("eid") ("chapter") ("pages") ("pagetotal")
+ ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate")))
("Unpublished" "Unpublished"
- (("author") ("title") ("year" nil nil 0) ("date" nil nil 0))
+ (("author") ("title") ("date" nil nil 1) ("year" nil nil -1))
nil
- (("subtitle") ("titleaddon") ("language") ("howpublished")
- ("note") ("location") ("isbn") ("date") ("month") ("year")
- ("addendum") ("pubstate") ("url") ("urldate"))))
+ (("subtitle") ("titleaddon") ("type") ("eventtitle") ("eventtitleaddon")
+ ("eventdate") ("venue") ("language") ("howpublished") ("note")
+ ("location" nil nil 2) ("address" nil nil -2)
+ ("isbn") ("month") ("addendum") ("pubstate") ("doi")
+ ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4)
+ ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5)
+ ("url") ("urldate"))))
"Alist of biblatex entry types and their associated fields.
It has the same format as `bibtex-BibTeX-entry-alist'."
:group 'bibtex
- :version "24.1"
- :type 'bibtex-entry-alist)
-(put 'bibtex-biblatex-entry-alist 'risky-local-variable t)
+ :version "28.1"
+ :type 'bibtex-entry-alist
+ :risky t)
(define-widget 'bibtex-field-alist 'lazy
"Format of `bibtex-BibTeX-entry-alist' and friends."
@@ -770,6 +909,7 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD."
("eprinttype" "Type of eprint identifier")
("eventdate" "Date of a conference or some other event")
("eventtitle" "Title of a conference or some other event")
+ ("eventtitleaddon" "Annex to the eventtitle (e.g., acronym of known event)")
("file" "Local link to an electronic version of the work")
("foreword" "Author(s) of a foreword to the work")
("holder" "Holder(s) of a patent")
@@ -785,9 +925,11 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD."
("issue" "Issue of a journal")
("issuesubtitle" "Subtitle of a specific issue of a journal or other periodical.")
("issuetitle" "Title of a specific issue of a journal or other periodical.")
+ ("issuetitleaddon" "Annex to the issuetitle")
("iswc" "International Standard Work Code of a musical work")
("journalsubtitle" "Subtitle of a journal, a newspaper, or some other periodical.")
("journaltitle" "Name of a journal, a newspaper, or some other periodical.")
+ ("journaltitleaddon" "Annex to the journaltitle")
("label" "Substitute for the regular label to be used by the citation style")
("language" "Language(s) of the work")
("library" "Library name and a call number")
@@ -815,6 +957,8 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD."
("series" "Name of a publication series")
("shortauthor" "Author(s) of the work, given in an abbreviated form")
("shorteditor" "Editor(s) of the work, given in an abbreviated form")
+ ("shorthand" "Special designation overriding the default label")
+ ("shorthandintro" "Phrase overriding the standard shorthand introduction")
("shortjournal" "Short version or an acronym of the journal title")
("shortseries" "Short version or an acronym of the series field")
("shorttitle" "Title in an abridged form")
@@ -833,7 +977,7 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD."
"Alist of biblatex fields.
It has the same format as `bibtex-BibTeX-entry-alist'."
:group 'bibtex
- :version "24.1"
+ :version "28.1"
:type 'bibtex-field-alist)
(defcustom bibtex-dialect-list '(BibTeX biblatex)
@@ -850,15 +994,15 @@ Predefined dialects include BibTeX and biblatex."
To interactively change the dialect use the command `bibtex-set-dialect'."
:group 'bibtex
:version "24.1"
- :set '(lambda (symbol value)
- (set-default symbol value)
- ;; `bibtex-set-dialect' is undefined during loading (no problem)
- (if (fboundp 'bibtex-set-dialect)
- (bibtex-set-dialect value)))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ ;; `bibtex-set-dialect' is undefined during loading (no problem).
+ (if (fboundp 'bibtex-set-dialect)
+ (bibtex-set-dialect value)))
:type '(choice (const BibTeX)
(const biblatex)
- (symbol :tag "Custom")))
-(put 'bibtex-dialect 'safe-local-variable 'symbolp)
+ (symbol :tag "Custom"))
+ :safe #'symbolp)
(defcustom bibtex-no-opt-remove-re "\\`option"
"If a field name matches this regexp, the prefix OPT is not removed.
@@ -870,7 +1014,8 @@ If nil prefix OPT is always removed."
(defcustom bibtex-comment-start "@Comment"
"String starting a BibTeX comment."
:group 'bibtex
- :type 'string)
+ :type 'string
+ :safe #'stringp)
(defcustom bibtex-add-entry-hook nil
"List of functions to call when BibTeX entry has been inserted."
@@ -1051,7 +1196,7 @@ See `bibtex-generate-autokey' for details."
(defvaralias 'bibtex-autokey-name-case-convert
'bibtex-autokey-name-case-convert-function)
-(defcustom bibtex-autokey-name-case-convert-function 'downcase
+(defcustom bibtex-autokey-name-case-convert-function #'downcase
"Function called for each name to perform case conversion.
See `bibtex-generate-autokey' for details."
:group 'bibtex-autokey
@@ -1059,9 +1204,8 @@ See `bibtex-generate-autokey' for details."
(const :tag "Downcase" downcase)
(const :tag "Capitalize" capitalize)
(const :tag "Upcase" upcase)
- (function :tag "Conversion function")))
-(put 'bibtex-autokey-name-case-convert-function 'safe-local-variable
- (lambda (x) (memq x '(upcase downcase capitalize identity))))
+ (function :tag "Conversion function" :value identity))
+ :safe (lambda (x) (memq x '(upcase downcase capitalize identity))))
(defcustom bibtex-autokey-name-length 'infty
"Number of characters from name to incorporate into key.
@@ -1127,7 +1271,7 @@ Case is significant. See `bibtex-generate-autokey' for details."
(defvaralias 'bibtex-autokey-titleword-case-convert
'bibtex-autokey-titleword-case-convert-function)
-(defcustom bibtex-autokey-titleword-case-convert-function 'downcase
+(defcustom bibtex-autokey-titleword-case-convert-function #'downcase
"Function called for each titleword to perform case conversion.
See `bibtex-generate-autokey' for details."
:group 'bibtex-autokey
@@ -1188,18 +1332,20 @@ See `bibtex-generate-autokey' for details."
:group 'bibtex-autokey
:type 'boolean)
-(defcustom bibtex-autokey-before-presentation-function nil
- "If non-nil, function to call before generated key is presented.
+(defcustom bibtex-autokey-before-presentation-function #'identity
+ "Function to call before generated key is presented.
The function must take one argument (the automatically generated key),
and must return a string (the key to use)."
:group 'bibtex-autokey
- :type '(choice (const nil) function))
+ :version "28.1"
+ :type 'function)
(defcustom bibtex-entry-offset 0
"Offset for BibTeX entries.
Added to the value of all other variables which determine columns."
:group 'bibtex
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom bibtex-field-indentation 2
"Starting column for the name part in BibTeX fields."
@@ -1212,13 +1358,15 @@ Added to the value of all other variables which determine columns."
"Starting column for the text part in BibTeX fields.
Should be equal to the space needed for the longest name part."
:group 'bibtex
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom bibtex-contline-indentation
(+ bibtex-text-indentation 1)
"Starting column for continuation lines of BibTeX fields."
:group 'bibtex
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom bibtex-align-at-equal-sign nil
"If non-nil, align fields at equal sign instead of field text.
@@ -1242,7 +1390,7 @@ If non-nil, the column for the equal sign is the value of
:group 'bibtex
:type '(repeat string))
-(defcustom bibtex-summary-function 'bibtex-summary
+(defcustom bibtex-summary-function #'bibtex-summary
"Function to call for generating a summary of current BibTeX entry.
It takes no arguments. Point must be at beginning of entry.
Used by `bibtex-complete-crossref-cleanup' and `bibtex-copy-summary-as-kill'."
@@ -1283,7 +1431,7 @@ If `bibtex-expand-strings' is non-nil, BibTeX strings are expanded
for generating the URL.
Set this variable before loading BibTeX mode.
-The following is a complex example, see URL `http://link.aps.org/'.
+The following is a complex example, see URL `https://link.aps.org/'.
(((\"journal\" . \"\\\\=<\\(PR[ABCDEL]?\\|RMP\\)\\\\=>\")
\"http://link.aps.org/abstract/%s/v%s/p%s\"
@@ -1312,8 +1460,8 @@ The following is a complex example, see URL `http://link.aps.org/'.
(regexp :tag "Regexp")
(choice (string :tag "Replacement")
(integer :tag "Sub-match")
- (function :tag "Filter"))))))))
-(put 'bibtex-generate-url-list 'risky-local-variable t)
+ (function :tag "Filter")))))))
+ :risky t)
(defcustom bibtex-cite-matcher-alist
'(("\\\\cite[ \t\n]*{\\([^}]+\\)}" . 1))
@@ -1535,21 +1683,19 @@ At most `bibtex-entry-kill-ring-max' items are kept here.")
(defvar bibtex-last-kill-command nil
"Type of the last kill command (either `field' or `entry').")
-(defvar bibtex-strings
+(defvar-local bibtex-strings
(lazy-completion-table bibtex-strings
(lambda ()
(bibtex-parse-strings (bibtex-string-files-init))))
"Completion table for BibTeX string keys.
Initialized from `bibtex-predefined-strings' and `bibtex-string-files'.")
-(make-variable-buffer-local 'bibtex-strings)
(put 'bibtex-strings 'risky-local-variable t)
-(defvar bibtex-reference-keys
+(defvar-local bibtex-reference-keys
(lazy-completion-table bibtex-reference-keys
(lambda () (bibtex-parse-keys nil t)))
"Completion table for BibTeX reference keys.
The CDRs of the elements are t for header keys and nil for crossref keys.")
-(make-variable-buffer-local 'bibtex-reference-keys)
(put 'bibtex-reference-keys 'risky-local-variable t)
(defvar bibtex-buffer-last-parsed-tick nil
@@ -1660,7 +1806,7 @@ Initialized by `bibtex-set-dialect'.")
(defvar bibtex-font-lock-url-regexp
;; Assume that field names begin at the beginning of a line.
(concat "^[ \t]*"
- (regexp-opt (delete-dups (mapcar 'caar bibtex-generate-url-list)) t)
+ (regexp-opt (delete-dups (mapcar #'caar bibtex-generate-url-list)) t)
"[ \t]*=[ \t]*")
"Regexp for `bibtex-font-lock-url' derived from `bibtex-generate-url-list'.")
@@ -1707,7 +1853,7 @@ BibTeX field as necessary."
;; It can be confusing if non-editing commands try to
;; modify the buffer.
(if buffer-read-only
- (error "Comma missing at buffer position %s" (point)))
+ (user-error "Comma missing at buffer position %s" (point)))
(insert ",")
(forward-char -1)
;; Now try again.
@@ -1892,30 +2038,36 @@ If `bibtex-expand-strings' is non-nil, also expand BibTeX strings."
(let ((mtch (match-string-no-properties 0)))
(push (or (if bibtex-expand-strings
(cdr (assoc-string mtch (bibtex-strings) t)))
- mtch) content)
+ mtch)
+ content)
(goto-char (match-end 0)))
(let ((bounds (bibtex-parse-field-string)))
(push (buffer-substring-no-properties
- (1+ (car bounds)) (1- (cdr bounds))) content)
+ (1+ (car bounds)) (1- (cdr bounds)))
+ content)
(goto-char (cdr bounds))))
(re-search-forward "\\=[ \t\n]*#[ \t\n]*" nil t))
- (apply 'concat (nreverse content))))
+ (apply #'concat (nreverse content))))
(buffer-substring-no-properties (bibtex-start-of-text-in-field bounds)
(bibtex-end-of-text-in-field bounds))))
(defun bibtex-text-in-field (field &optional follow-crossref)
- "Get content of field FIELD of current BibTeX entry.
-Return nil if not found.
+ "Return content of field FIELD of current BibTeX entry or nil if not found.
+FIELD may also be a list of fields that are tried in order.
If optional arg FOLLOW-CROSSREF is non-nil, follow crossref."
(save-excursion
- (let* ((end (if follow-crossref (bibtex-end-of-entry) t))
- (beg (bibtex-beginning-of-entry)) ; move point
- (bounds (bibtex-search-forward-field field end)))
+ (let ((end (if (and (not follow-crossref) (stringp field))
+ t ; try to minimize parsing
+ (bibtex-end-of-entry)))
+ bounds)
+ (bibtex-beginning-of-entry) ; move point
+ (let ((field (if (stringp field) (list field) field)))
+ (while (and field (not bounds))
+ (setq bounds (bibtex-search-forward-field (pop field) end))))
(cond (bounds (bibtex-text-in-field-bounds bounds t))
((and follow-crossref
- (progn (goto-char beg)
- (setq bounds (bibtex-search-forward-field
- "\\(OPT\\)?crossref" end))))
+ (setq bounds (bibtex-search-forward-field
+ "\\(OPT\\)?crossref" end)))
(let ((crossref-field (bibtex-text-in-field-bounds bounds t)))
(if (bibtex-search-crossref crossref-field)
;; Do not pass FOLLOW-CROSSREF because we want
@@ -2225,7 +2377,7 @@ On success return bounds, nil otherwise. Do not move point."
(>= (bibtex-end-of-field bounds) (point)))
bounds)
((not noerr)
- (error "Can't find enclosing BibTeX field"))))))
+ (user-error "Can't find enclosing BibTeX field"))))))
(defun bibtex-beginning-first-field (&optional beg)
"Move point to beginning of first field.
@@ -2237,10 +2389,11 @@ Optional arg BEG is beginning of entry."
(defun bibtex-insert-kill (n &optional comma)
"Reinsert the Nth stretch of killed BibTeX text (field or entry).
Optional arg COMMA is as in `bibtex-enclosing-field'."
- (unless bibtex-last-kill-command (error "BibTeX kill ring is empty"))
+ (unless bibtex-last-kill-command (user-error "BibTeX kill ring is empty"))
(let ((fun (lambda (kryp kr) ; adapted from `current-kill'
- (car (set kryp (nthcdr (mod (- n (length (eval kryp)))
- (length kr)) kr))))))
+ (car (set kryp (nthcdr (mod (- n (length (symbol-value kryp)))
+ (length kr))
+ kr))))))
;; We put the mark at the beginning of the inserted field or entry
;; and point at its end - a behavior similar to what `yank' does.
;; The mark is then used by `bibtex-yank-pop', which needs to know
@@ -2251,7 +2404,8 @@ Optional arg COMMA is as in `bibtex-enclosing-field'."
(goto-char (bibtex-end-of-field (bibtex-enclosing-field comma)))
(push-mark)
(bibtex-make-field (funcall fun 'bibtex-field-kill-ring-yank-pointer
- bibtex-field-kill-ring) t nil t))
+ bibtex-field-kill-ring)
+ t nil t))
;; insert past the current entry
(bibtex-skip-to-valid-entry)
(push-mark)
@@ -2272,10 +2426,6 @@ Optional arg COMMA is as in `bibtex-enclosing-field'."
"Add NEWELT to the list stored in VEC at index IDX."
(aset vec idx (cons newelt (aref vec idx))))
-(defsubst bibtex-vec-incr (vec idx)
- "Increment by 1 the counter which is stored in VEC at index IDX."
- (aset vec idx (1+ (aref vec idx))))
-
(defun bibtex-format-entry ()
"Helper function for `bibtex-clean-entry'.
Formats current entry according to variable `bibtex-entry-format'."
@@ -2296,7 +2446,8 @@ Formats current entry according to variable `bibtex-entry-format'."
strings sort-fields)
bibtex-entry-format))
(left-delim-re (regexp-quote (bibtex-field-left-delimiter)))
- bounds crossref-key req-field-list default-field-list field-list
+ bounds crossref-key req-field-list opt-field-list
+ default-field-list field-list
num-alt alt-fields idx error-field-name)
(unwind-protect
;; formatting (undone if error occurs)
@@ -2314,7 +2465,7 @@ Formats current entry according to variable `bibtex-entry-format'."
;; identify entry type
(goto-char (point-min))
(or (re-search-forward bibtex-entry-type nil t)
- (error "Not inside a BibTeX entry"))
+ (user-error "Not inside a BibTeX entry"))
(let* ((beg-type (1+ (match-beginning 0)))
(end-type (match-end 0))
(entry-list (assoc-string (buffer-substring-no-properties
@@ -2324,7 +2475,7 @@ Formats current entry according to variable `bibtex-entry-format'."
;; unify case of entry type
(when (memq 'unify-case format)
(delete-region beg-type end-type)
- (insert (car entry-list)))
+ (insert (funcall bibtex-unify-case-function (car entry-list))))
;; update left entry delimiter
(when (memq 'delimiters format)
@@ -2343,16 +2494,22 @@ Formats current entry according to variable `bibtex-entry-format'."
;; list of required fields appropriate for an entry with
;; or without crossref key.
- (setq req-field-list (if crossref-key (nth 2 entry-list)
- (append (nth 2 entry-list) (nth 3 entry-list)))
+ (setq req-field-list (append (nth 2 entry-list)
+ (unless crossref-key
+ (nth 3 entry-list)))
+ opt-field-list (append (if crossref-key
+ (nth 3 entry-list))
+ (nth 4 entry-list)
+ bibtex-user-optional-fields)
;; default list of fields that may appear in this entry
- default-field-list (append (nth 2 entry-list) (nth 3 entry-list)
- (nth 4 entry-list)
- bibtex-user-optional-fields)
- ;; number of ALT fields we expect to find
- num-alt (length (delq nil (delete-dups
- (mapcar (lambda (x) (nth 3 x))
- req-field-list))))
+ default-field-list (append req-field-list opt-field-list)
+ ;; number of ALT fields we may find
+ num-alt (let ((n 0))
+ (mapc (lambda (x)
+ (if (nth 3 x)
+ (setq n (max n (abs (nth 3 x))))))
+ default-field-list)
+ (1+ n))
;; ALT fields of respective groups
alt-fields (make-vector num-alt nil))
@@ -2391,8 +2548,9 @@ Formats current entry according to variable `bibtex-entry-format'."
(if opt-alt (setq field-name (substring field-name 3)))
;; keep track of alternatives
- (if (setq idx (nth 3 (assoc-string field-name req-field-list t)))
- (bibtex-vec-push alt-fields idx field-name))
+ (if (and (not empty-field)
+ (setq idx (nth 3 (assoc-string field-name default-field-list t))))
+ (bibtex-vec-push alt-fields (abs idx) field-name))
(if (memq 'opts-or-alts format)
;; delete empty optional and alternative fields
@@ -2524,50 +2682,51 @@ Formats current entry according to variable `bibtex-entry-format'."
(memq 'required-fields format)
(assoc-string field-name req-field-list t))
(setq error-field-name field-name)
- (error "Mandatory field `%s' is empty" field-name))
+ (user-error "Mandatory field `%s' is empty" field-name))
;; unify case of field name
- (if (memq 'unify-case format)
- (let ((fname (car (assoc-string field-name
- default-field-list t))))
- (if fname
- (progn
- (delete-region beg-name end-name)
- (goto-char beg-name)
- (insert fname))
- ;; there are no rules we could follow
- (downcase-region beg-name end-name))))
+ (when (memq 'unify-case format)
+ (let ((fname (car (assoc-string field-name
+ default-field-list t)))
+ (curname (buffer-substring beg-name end-name)))
+ (delete-region beg-name end-name)
+ (goto-char beg-name)
+ (insert (funcall bibtex-unify-case-function
+ (or fname curname)))))
;; update point
(goto-char end-field))))
;; check whether all required fields are present
- (if (memq 'required-fields format)
- (let ((alt-expect (make-vector num-alt nil))
- (alt-found (make-vector num-alt 0)))
- (dolist (fname req-field-list)
- (cond ((setq idx (nth 3 fname))
- ;; t if field has alternative flag
- (bibtex-vec-push alt-expect idx (car fname))
- (if (member-ignore-case (car fname) field-list)
- (bibtex-vec-incr alt-found idx)))
- ((not (member-ignore-case (car fname) field-list))
- ;; If we use the crossref field, a required field
- ;; can have the OPT prefix. So if it was empty,
- ;; we have deleted by now. Nonetheless we can
- ;; move point on this empty field.
- (setq error-field-name (car fname))
- (error "Mandatory field `%s' is missing" (car fname)))))
- (dotimes (idx num-alt)
- (cond ((= 0 (aref alt-found idx))
- (setq error-field-name (car (last (aref alt-fields idx))))
- (error "Alternative mandatory field `%s' is missing"
- (aref alt-expect idx)))
- ((< 1 (aref alt-found idx))
- (setq error-field-name (car (last (aref alt-fields idx))))
- (error "Alternative fields `%s' are defined %s times"
- (aref alt-expect idx)
- (length (aref alt-fields idx))))))))
+ (when (memq 'required-fields format)
+ (let ((alt-expect (make-vector num-alt nil)))
+ (dolist (fname req-field-list)
+ (cond ((nth 3 fname)
+ ;; t if required field has alternative flag
+ (setq idx (abs (nth 3 fname)))
+ (bibtex-vec-push alt-expect idx (car fname)))
+ ((not (member-ignore-case (car fname) field-list))
+ (setq error-field-name (car fname))
+ (user-error "Mandatory field `%s' is missing"
+ (car fname)))))
+ (dotimes (idx num-alt)
+ (cond ((and (aref alt-expect idx)
+ (not (aref alt-fields idx)))
+ (setq error-field-name
+ (car (last (aref alt-fields idx))))
+ (user-error "Alternative mandatory fields `%s' are missing"
+ (mapconcat 'identity
+ (reverse
+ (aref alt-expect idx))
+ ", ")))
+ ((nth 1 (aref alt-fields idx))
+ (setq error-field-name
+ (car (last (aref alt-fields idx))))
+ (user-error "Fields `%s' are alternatives"
+ (mapconcat 'identity
+ (reverse
+ (aref alt-fields idx))
+ ", ")))))))
;; update comma after last field
(if (memq 'last-comma format)
@@ -2615,7 +2774,7 @@ Return optimized value to be used by `bibtex-format-entry'."
regexp-alist))
(let (opt-list)
;; Loop over field names
- (dolist (field (delete-dups (apply 'append (mapcar 'car regexp-alist))))
+ (dolist (field (delete-dups (apply #'append (mapcar #'car regexp-alist))))
(let (rules)
;; Collect all matches we have for this field name
(dolist (e regexp-alist)
@@ -2623,7 +2782,7 @@ Return optimized value to be used by `bibtex-format-entry'."
(push (cons (nth 1 e) (nth 2 e)) rules)))
(if (eq type 'braces)
;; concatenate all regexps to a single regexp
- (setq rules (concat "\\(?:" (mapconcat 'car rules "\\|") "\\)")))
+ (setq rules (concat "\\(?:" (mapconcat #'car rules "\\|") "\\)")))
;; create list of replacement rules.
(push (cons field rules) opt-list)))
opt-list))
@@ -2650,6 +2809,7 @@ is returned unchanged."
(defun bibtex-autokey-get-field (field &optional change-list)
"Get content of BibTeX field FIELD. Return empty string if not found.
+FIELD may also be a list of fields that are tried in order.
Optional arg CHANGE-LIST is a list of substitution patterns that is
applied to the content of FIELD. It is an alist with pairs
\(OLD-REGEXP . NEW-STRING)."
@@ -2674,7 +2834,7 @@ and `bibtex-autokey-names-stretch'."
(if (string= "" names)
names
(let* ((case-fold-search t)
- (name-list (mapcar 'bibtex-autokey-demangle-name
+ (name-list (mapcar #'bibtex-autokey-demangle-name
(split-string names "[ \t\n]+and[ \t\n]+")))
additional-names)
(unless (or (not (numberp bibtex-autokey-names))
@@ -2686,7 +2846,7 @@ and `bibtex-autokey-names-stretch'."
bibtex-autokey-names)
(nreverse name-list)))
additional-names bibtex-autokey-additional-names))
- (concat (mapconcat 'identity name-list
+ (concat (mapconcat #'identity name-list
bibtex-autokey-name-separator)
additional-names)))))
@@ -2712,15 +2872,23 @@ and `bibtex-autokey-names-stretch'."
;; name is of the form "First Middle Last" or "Last"
;; --> take the last token
(match-string 1 fullname))
- (t (error "Name `%s' is incorrectly formed" fullname)))))
+ (t (user-error "Name `%s' is incorrectly formed"
+ fullname)))))
(funcall bibtex-autokey-name-case-convert-function
(bibtex-autokey-abbrev name bibtex-autokey-name-length))))
(defun bibtex-autokey-get-year ()
"Return year field contents as a string obeying `bibtex-autokey-year-length'."
- (let ((yearfield (bibtex-autokey-get-field "year")))
- (substring yearfield (max 0 (- (length yearfield)
- bibtex-autokey-year-length)))))
+ (let* ((str (bibtex-autokey-get-field '("date" "year"))) ; possibly ""
+ (year (or (and (iso8601-valid-p str)
+ (let ((year (decoded-time-year (iso8601-parse str))))
+ (and year (number-to-string year))))
+ ;; BibTeX permits a year field "(about 1984)", where only
+ ;; the last four nonpunctuation characters must be numerals.
+ (and (string-match "\\([0-9][0-9][0-9][0-9]\\)[^[:alnum:]]*\\'" str)
+ (match-string 1 str))
+ (user-error "Year or date field `%s' invalid" str))))
+ (substring year (max 0 (- (length year) bibtex-autokey-year-length)))))
(defun bibtex-autokey-get-title ()
"Get title field contents up to a terminator.
@@ -2736,7 +2904,7 @@ Return the result as a string."
;; specific words and use only a specific amount of words.
(let ((counter 0)
(ignore-re (concat "\\`\\(?:"
- (mapconcat 'identity
+ (mapconcat #'identity
bibtex-autokey-titleword-ignore "\\|")
"\\)\\'"))
titlewords titlewords-extra word)
@@ -2760,7 +2928,7 @@ Return the result as a string."
;; titlewords-extra in titlewords. Otherwise, we ignore titlewords-extra.
(unless (string-match "\\b\\w+" titlestring)
(setq titlewords (append titlewords-extra titlewords)))
- (mapconcat 'bibtex-autokey-demangle-title (nreverse titlewords)
+ (mapconcat #'bibtex-autokey-demangle-title (nreverse titlewords)
bibtex-autokey-titleword-separator))))
(defun bibtex-autokey-demangle-title (titleword)
@@ -2803,12 +2971,12 @@ The name part:
The year part:
1. Build the year part of the key by truncating the content of the year
- field to the rightmost `bibtex-autokey-year-length' digits (useful
- values are 2 and 4).
- 2. If the year field (or any other field required to generate the key)
- is absent, but the entry has a valid crossref field and
- `bibtex-autokey-use-crossref' is non-nil, use the field of the
- crossreferenced entry instead.
+ component of the date or year field to the rightmost
+ `bibtex-autokey-year-length' digits (useful values are 2 and 4).
+ 2. If both the year and date fields are absent, but the entry has a
+ valid crossref field and `bibtex-autokey-use-crossref' is
+ non-nil, use the date or year field of the crossreferenced entry
+ instead.
The title part
1. Change the content of the title field according to
@@ -2837,7 +3005,7 @@ Concatenate the key:
non-empty insert `bibtex-autokey-name-year-separator' between the two.
If the title part and the year (or name) part are non-empty, insert
`bibtex-autokey-year-title-separator' between the two.
- 2. If `bibtex-autokey-before-presentation-function' is non-nil, it must be
+ 2. `bibtex-autokey-before-presentation-function' must be
a function taking one argument. Call this function with the generated
key as the argument. Use the return value of this function (a string)
as the key.
@@ -2865,7 +3033,7 @@ Concatenate the key:
(defun bibtex-global-key-alist ()
"Return global key alist based on `bibtex-files'."
(if bibtex-files
- (apply 'append
+ (apply #'append
(mapcar (lambda (buf)
(with-current-buffer buf bibtex-reference-keys))
;; include current buffer only if it uses `bibtex-mode'
@@ -2919,7 +3087,7 @@ for parsing BibTeX keys. If parsing fails, try to set this variable to nil."
(1+ (match-beginning 3)) (1- (match-end 3)))))
(unless (assoc key crossref-keys)
(push (list key) crossref-keys))))
- ;; We have probably have a non-bibtex file.
+ ;; We probably have a non-bibtex file.
((not (match-beginning bibtex-type-in-head))
(throw 'userkey nil))
;; only keys of known entries
@@ -3007,15 +3175,15 @@ Use `bibtex-predefined-strings' and BibTeX files `bibtex-string-files'."
(if (file-name-absolute-p filename)
(if (file-readable-p filename)
(push filename string-files)
- (error "BibTeX strings file %s not found" filename))
+ (user-error "BibTeX strings file %s not found" filename))
(dolist (dir dirlist)
(when (file-readable-p
(setq fullfilename (expand-file-name filename dir)))
(push fullfilename string-files)
(setq found t)))
(unless found
- (error "File %s not in paths defined via bibtex-string-file-path"
- filename))))
+ (user-error "File %s not in paths defined via bibtex-string-file-path"
+ filename))))
;; parse string files
(dolist (filename string-files)
(with-temp-buffer
@@ -3090,11 +3258,11 @@ does not use `bibtex-mode'."
(push expanded-file-name file-list)
(setq found t)))
(unless found
- (error "File `%s' not in paths defined via bibtex-file-path"
- file))))))
+ (user-error "File `%s' not in paths defined via bibtex-file-path"
+ file))))))
(dolist (file file-list)
(unless (file-readable-p file)
- (error "BibTeX file `%s' not found" file)))
+ (user-error "BibTeX file `%s' not found" file)))
;; expand dir-list
(dolist (dir dir-list)
(setq file-list
@@ -3129,7 +3297,7 @@ does not use `bibtex-mode'."
(if buffer-list
(switch-to-buffer
(completing-read "Switch to BibTeX buffer: "
- (mapcar 'buffer-name buffer-list)
+ (mapcar #'buffer-name buffer-list)
nil t
(if current (buffer-name (current-buffer)))))
(message "No BibTeX buffers defined")))
@@ -3159,7 +3327,7 @@ Use `bibtex-summary-function' to generate summary."
(message "%s %s" key summary))))))
(defun bibtex-copy-summary-as-kill (&optional arg)
- "Push summery of current BibTeX entry to kill ring.
+ "Push summary of current BibTeX entry to kill ring.
Use `bibtex-summary-function' to generate summary.
If prefix ARG is non-nil push BibTeX entry's URL to kill ring
that is generated by calling `bibtex-url'."
@@ -3171,14 +3339,14 @@ that is generated by calling `bibtex-url'."
(bibtex-beginning-of-entry)
(if (looking-at bibtex-entry-maybe-empty-head)
(kill-new (message "%s" (funcall bibtex-summary-function)))
- (error "No entry found")))))
+ (user-error "No entry found")))))
(defun bibtex-summary ()
"Return summary of current BibTeX entry.
Used as default value of `bibtex-summary-function'."
;; It would be neat to make this function customizable. How?
(if (looking-at bibtex-entry-maybe-empty-head)
- (let* ((bibtex-autokey-name-case-convert-function 'identity)
+ (let* ((bibtex-autokey-name-case-convert-function #'identity)
(bibtex-autokey-name-length 'infty)
(bibtex-autokey-names 1)
(bibtex-autokey-names-stretch 0)
@@ -3189,7 +3357,7 @@ Used as default value of `bibtex-summary-function'."
(year (bibtex-autokey-get-year))
(bibtex-autokey-titlewords 5)
(bibtex-autokey-titlewords-stretch 2)
- (bibtex-autokey-titleword-case-convert-function 'identity)
+ (bibtex-autokey-titleword-case-convert-function #'identity)
(bibtex-autokey-titleword-length 5)
(bibtex-autokey-titleword-separator " ")
(title (bibtex-autokey-get-title))
@@ -3203,7 +3371,7 @@ Used as default value of `bibtex-summary-function'."
`((" " . ,names) (" " . ,year) (": " . ,title)
(", " . ,journal) (" " . ,volume) (":" . ,pages))
""))
- (error "Entry not found")))
+ (user-error "Entry not found")))
(defun bibtex-pop (arg direction)
"Fill current field from the ARGth same field's text in DIRECTION.
@@ -3237,8 +3405,8 @@ Generic function used by `bibtex-pop-previous' and `bibtex-pop-next'."
(goto-char (bibtex-end-of-field bounds))
(setq failure t))))
(if failure
- (error "No %s matching BibTeX field"
- (if (eq direction 'previous) "previous" "next"))
+ (user-error "No %s matching BibTeX field"
+ (if (eq direction 'previous) "previous" "next"))
;; Found a matching field. Remember boundaries.
(let ((new-text (bibtex-text-in-field-bounds bounds))
(nbeg (copy-marker (bibtex-start-of-field bounds)))
@@ -3336,12 +3504,12 @@ BOUND limits the search."
(define-button-type 'bibtex-url
'action 'bibtex-button-action
- 'bibtex-function 'bibtex-url
+ 'bibtex-function #'bibtex-url
'help-echo (purecopy "mouse-2, RET: follow URL"))
(define-button-type 'bibtex-search-crossref
'action 'bibtex-button-action
- 'bibtex-function 'bibtex-search-crossref
+ 'bibtex-function #'bibtex-search-crossref
'help-echo (purecopy "mouse-2, RET: follow crossref"))
(defun bibtex-button (beg end type &rest args)
@@ -3405,43 +3573,48 @@ if that value is non-nil.
\\{bibtex-mode-map}"
(add-hook 'completion-at-point-functions
- 'bibtex-completion-at-point-function nil 'local)
+ #'bibtex-completion-at-point-function nil 'local)
(make-local-variable 'bibtex-buffer-last-parsed-tick)
;; Install stealthy parse function if not already installed
(unless bibtex-parse-idle-timer
(setq bibtex-parse-idle-timer (run-with-idle-timer
bibtex-parse-keys-timeout t
'bibtex-parse-buffers-stealthily)))
- (set (make-local-variable 'paragraph-start) "[ \f\n\t]*$")
- (set (make-local-variable 'comment-start) bibtex-comment-start)
- (set (make-local-variable 'comment-start-skip)
- (concat (regexp-quote bibtex-comment-start) "\\>[ \t]*"))
- (set (make-local-variable 'comment-column) 0)
- (set (make-local-variable 'defun-prompt-regexp) "^[ \t]*@[[:alnum:]]+[ \t]*")
- (set (make-local-variable 'outline-regexp) "[ \t]*@")
- (set (make-local-variable 'fill-paragraph-function) 'bibtex-fill-field)
- (set (make-local-variable 'fill-prefix)
- (make-string (+ bibtex-entry-offset bibtex-contline-indentation) ?\s))
- (set (make-local-variable 'font-lock-defaults)
- '(bibtex-font-lock-keywords
- nil t ((?$ . "\"")
- ;; Mathematical expressions should be fontified as strings
- (?\" . ".")
- ;; Quotes are field delimiters and quote-delimited
- ;; entries should be fontified in the same way as
- ;; brace-delimited ones
- )
- nil
- (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))
- ;; Allow `bibtex-dialect' as a file-local variable.
- (add-hook 'hack-local-variables-hook 'bibtex-set-dialect nil t))
+ (setq-local paragraph-start "[ \f\n\t]*$")
+ (setq-local comment-column 0)
+ (setq-local defun-prompt-regexp "^[ \t]*@[[:alnum:]]+[ \t]*")
+ (setq-local outline-regexp "[ \t]*@")
+ (setq-local fill-paragraph-function #'bibtex-fill-field)
+ (setq-local font-lock-defaults
+ '(bibtex-font-lock-keywords
+ nil t ((?$ . "\"")
+ ;; Mathematical expressions should be fontified as strings
+ (?\" . ".")
+ ;; Quotes are field delimiters and quote-delimited
+ ;; entries should be fontified in the same way as
+ ;; brace-delimited ones
+ )
+ nil
+ (font-lock-extra-managed-props . (category))
+ (font-lock-mark-block-function
+ . (lambda ()
+ (set-mark (bibtex-end-of-entry))
+ (bibtex-beginning-of-entry)))))
+ (setq-local syntax-propertize-function
+ (syntax-propertize-via-font-lock
+ bibtex-font-lock-syntactic-keywords))
+ (let ((fun (lambda ()
+ (bibtex-set-dialect)
+ (setq-local comment-start bibtex-comment-start)
+ (setq-local comment-start-skip
+ (concat (regexp-quote bibtex-comment-start) "\\>[ \t]*"))
+ (setq-local fill-prefix
+ (make-string (+ bibtex-entry-offset
+ bibtex-contline-indentation)
+ ?\s)))))
+ (if (and buffer-file-name enable-local-variables)
+ (add-hook 'hack-local-variables-hook fun nil t)
+ (funcall fun))))
(defun bibtex-entry-alist (dialect)
"Return entry-alist for DIALECT."
@@ -3449,7 +3622,7 @@ if that value is non-nil.
entry-alist)
(if (boundp var)
(setq entry-alist (symbol-value var))
- (error "BibTeX dialect `%s' undefined" dialect))
+ (user-error "BibTeX dialect `%s' undefined" dialect))
(if (not (consp (nth 1 (car entry-alist))))
;; new format
entry-alist
@@ -3488,8 +3661,9 @@ are also bound buffer-locally if `bibtex-dialect' is already buffer-local
in the current buffer (for example, as a file-local variable).
LOCAL is t for interactive calls."
(interactive (list (intern (completing-read "Dialect: "
- (mapcar 'list bibtex-dialect-list)
- nil t)) t))
+ (mapcar #'list bibtex-dialect-list)
+ nil t))
+ t))
(let ((setfun (if (or local (local-variable-p 'bibtex-dialect))
(lambda (var val) (set (make-local-variable var) val))
'set)))
@@ -3502,11 +3676,11 @@ LOCAL is t for interactive calls."
bibtex-dialect))))
(if (boundp var)
(symbol-value var)
- (error "Field types for BibTeX dialect `%s' undefined"
- bibtex-dialect))))
+ (user-error "Field types for BibTeX dialect `%s' undefined"
+ bibtex-dialect))))
(funcall setfun 'bibtex-entry-type
(concat "@[ \t]*\\(?:"
- (regexp-opt (mapcar 'car bibtex-entry-alist)) "\\)"))
+ (regexp-opt (mapcar #'car bibtex-entry-alist)) "\\)"))
(funcall setfun 'bibtex-entry-head
(concat "^[ \t]*\\(" bibtex-entry-type "\\)[ \t]*[({][ \t\n]*\\("
bibtex-reference-key "\\)"))
@@ -3516,7 +3690,7 @@ LOCAL is t for interactive calls."
(concat "^[ \t]*@[ \t]*\\(?:"
(regexp-opt
(append '("String" "Preamble")
- (mapcar 'car bibtex-entry-alist))) "\\)"))
+ (mapcar #'car bibtex-entry-alist))) "\\)"))
(setq imenu-generic-expression
(list (list nil bibtex-entry-head bibtex-key-in-head))
imenu-case-fold-search t)))
@@ -3549,11 +3723,13 @@ LOCAL is t for interactive calls."
(let* ((entry (car elt))
(fname (intern (format "bibtex-%s" entry))))
(unless (fboundp fname)
- (eval (list 'defun fname nil
- (format "Insert a template for a @%s entry; see also `bibtex-entry'."
- entry)
- '(interactive "*")
- `(bibtex-entry ,entry))))
+ (defalias fname
+ (lambda ()
+ (:documentation
+ (format "Insert a template for a @%s entry; see also `bibtex-entry'."
+ entry))
+ (interactive "*")
+ (bibtex-entry entry))))
;; Menu entries
(define-key menu-map (vector fname)
`(menu-item ,(or (nth 1 elt) (car elt)) ,fname))))
@@ -3572,15 +3748,14 @@ and `bibtex-user-optional-fields'."
(let ((e-list (assoc-string entry-type bibtex-entry-alist t))
required optional)
(unless e-list
- (error "Fields for BibTeX entry type %s not defined" entry-type))
+ (user-error "Fields for BibTeX entry type %s not defined" entry-type))
(if (member-ignore-case entry-type bibtex-include-OPTcrossref)
(setq required (nth 2 e-list)
optional (append (nth 3 e-list) (nth 4 e-list)))
(setq required (append (nth 2 e-list) (nth 3 e-list))
optional (nth 4 e-list)))
(if bibtex-include-OPTkey
- (push (list "key"
- "Used for reference key creation if author and editor fields are missing"
+ (push (list "key" "Used as label with certain BibTeX styles"
(if (or (stringp bibtex-include-OPTkey)
(functionp bibtex-include-OPTkey))
bibtex-include-OPTkey))
@@ -3589,7 +3764,41 @@ and `bibtex-user-optional-fields'."
(push '("crossref" "Reference key of the cross-referenced entry")
optional))
(setq optional (append optional bibtex-user-optional-fields))
- (cons required optional)))
+ (cons (bibtex--skip-field-aliases required)
+ (bibtex--skip-field-aliases optional))))
+
+(defun bibtex--skip-field-aliases (list)
+ "Skip fields in LIST that are aliases, return the shortened list.
+Aliases are fields for which the element ALTERNATIVE is a negative number,
+see `bibtex-BibTeX-entry-alist'. The shortened field list is used
+for the templates of `bibtex-entry', whereas entry validation performed by
+`bibtex-format-entry' uses the full list of fields for an entry."
+ ;; FIXME: `bibtex-entry' and `bibtex-format-entry' handle aliases
+ ;; under the hood in a manner that is largely invisible to users.
+ ;; If instead one wanted to display the aliases as alternatives
+ ;; in the usual way, field names may get both the ALT and the OPT prefix.
+ ;; That gets rather clumsy. Also, the code currently assumes that
+ ;; field names have either the ALT or the OPT prefix, but not both.
+ ;; Are there scenarios when it would be useful to display both?
+ (let (alt-list new-list)
+ (dolist (elt list) ; identify alternatives
+ (if (and (nth 3 elt)
+ (<= 0 (nth 3 elt)))
+ (push (nth 3 elt) alt-list)))
+ (setq alt-list (sort alt-list '<))
+ ;; Skip aliases. If ELT is marked as "proper alternative", but all
+ ;; alternatives for field ELT are aliases, we do not label ELT
+ ;; as an alternative either.
+ (dolist (elt list)
+ (let ((alt (nth 3 elt)))
+ (if alt
+ (if (<= 0 alt)
+ (push (if (eq alt (cadr (memq alt alt-list)))
+ elt ; ELT has proper alternatives
+ (butlast elt)) ; alternatives of ELT are alias
+ new-list))
+ (push elt new-list))))
+ (reverse new-list)))
(defun bibtex-entry (entry-type)
"Insert a template for a BibTeX entry of type ENTRY-TYPE.
@@ -3603,13 +3812,13 @@ is non-nil."
(bibtex-read-key (format "%s key: " entry-type))))
(field-list (bibtex-field-list entry-type)))
(unless (bibtex-prepare-new-entry (list key nil entry-type))
- (error "Entry with key `%s' already exists" key))
+ (user-error "Entry with key `%s' already exists" key))
(indent-to-column bibtex-entry-offset)
(insert "@" entry-type (bibtex-entry-left-delimiter))
(if key (insert key))
(save-excursion
- (mapc 'bibtex-make-field (car field-list))
- (mapc 'bibtex-make-optional-field (cdr field-list))
+ (mapc #'bibtex-make-field (car field-list))
+ (mapc #'bibtex-make-optional-field (cdr field-list))
(if bibtex-comma-after-last-field
(insert ","))
(insert "\n")
@@ -3657,8 +3866,8 @@ When called interactively with a prefix arg, query for a value of ENTRY-TYPE."
(insert (bibtex-field-left-delimiter)))
(goto-char end)))
(skip-chars-backward " \t\n")
- (mapc 'bibtex-make-field required)
- (mapc 'bibtex-make-optional-field optional)))))
+ (mapc #'bibtex-make-field required)
+ (mapc #'bibtex-make-optional-field optional)))))
(defun bibtex-parse-entry (&optional content keep-opt-alt)
"Parse entry at point, return an alist.
@@ -3815,7 +4024,7 @@ INIT is surrounded by field delimiters, unless NODELIM is non-nil."
(let ((init (nth 2 field)))
(if (not init) (setq init "")
(if (functionp init) (setq init (funcall init)))
- (unless (stringp init) (error "`%s' is not a string" init)))
+ (unless (stringp init) (user-error "`%s' is not a string" init)))
;; NODELIM is required by `bibtex-insert-kill'
(if nodelim (insert init)
(insert (bibtex-field-left-delimiter) init
@@ -3853,7 +4062,7 @@ Return the new location of point."
(goto-char (bibtex-end-of-string bounds)))
((looking-at bibtex-any-valid-entry-type)
;; Parsing of entry failed
- (error "Syntactically incorrect BibTeX entry starts here"))
+ (user-error "Syntactically incorrect BibTeX entry starts here"))
(t (if (called-interactively-p 'interactive)
(message "Not on a known BibTeX entry."))
(goto-char pnt)))
@@ -3928,7 +4137,7 @@ If mark is active count entries in region, if not in whole buffer."
(if bounds
(ispell-region (bibtex-start-of-text-in-field bounds)
(bibtex-end-of-text-in-field bounds))
- (error "No abstract in entry"))))
+ (user-error "No abstract in entry"))))
(defun bibtex-narrow-to-entry ()
"Narrow buffer to current BibTeX entry."
@@ -3938,38 +4147,54 @@ If mark is active count entries in region, if not in whole buffer."
(narrow-to-region (bibtex-beginning-of-entry)
(bibtex-end-of-entry))))
+(define-obsolete-function-alias 'bibtex-init-sort-entry-class-alist
+ #'bibtex-init-sort "28.1")
+(defun bibtex-init-sort (&optional parse)
+ "Initialize sorting of BibTeX entries.
+If PARSE is non-nil, also parse BibTeX keys."
+ (if (or parse
+ (and (eq bibtex-maintain-sorted-entries 'crossref)
+ (functionp bibtex-reference-keys)))
+ (bibtex-parse-keys))
+ (unless (local-variable-p 'bibtex-sort-entry-class-alist)
+ (setq-local bibtex-sort-entry-class-alist
+ (let ((i -1) alist)
+ (dolist (class bibtex-sort-entry-class)
+ (setq i (1+ i))
+ (dolist (entry class)
+ ;; All entry types should be downcase (for ease of comparison).
+ (push (cons (if (stringp entry) (downcase entry) entry) i)
+ alist)))
+ alist)))
+ ;; Custom sorting scheme
+ (if (and (consp bibtex-maintain-sorted-entries)
+ (nth 2 bibtex-maintain-sorted-entries))
+ (funcall (nth 2 bibtex-maintain-sorted-entries))))
+
(defun bibtex-entry-index ()
"Return index of BibTeX entry head at or past position of point.
The index is a list (KEY CROSSREF-KEY ENTRY-TYPE) that is used for sorting
-the entries of the BibTeX buffer. CROSSREF-KEY is nil unless the value
-of `bibtex-maintain-sorted-entries' is `crossref'. Move point to the end
-of the head of the entry found. Return nil if no entry found."
+the entries of the BibTeX buffer. CROSSREF-KEY is nil unless the value of
+`bibtex-maintain-sorted-entries' is `crossref'.
+If `bibtex-maintain-sorted-entries' is (INDEX-FUN ...), the index is the return
+value of INDEX-FUN. Return nil if no entry found.
+Move point to the end of the head of the entry found."
(let ((case-fold-search t))
(if (re-search-forward bibtex-entry-maybe-empty-head nil t)
- (let ((key (bibtex-key-in-head))
- ;; all entry types should be downcase (for ease of comparison)
- (entry-type (downcase (bibtex-type-in-head))))
- ;; Don't search CROSSREF-KEY if we don't need it.
- (if (eq bibtex-maintain-sorted-entries 'crossref)
- (let ((bounds (bibtex-search-forward-field
- "\\(OPT\\)?crossref" t)))
- (list key
- (if bounds (bibtex-text-in-field-bounds bounds t))
- entry-type))
- (list key nil entry-type))))))
-
-(defun bibtex-init-sort-entry-class-alist ()
- "Initialize `bibtex-sort-entry-class-alist' (buffer-local)."
- (unless (local-variable-p 'bibtex-sort-entry-class-alist)
- (set (make-local-variable 'bibtex-sort-entry-class-alist)
- (let ((i -1) alist)
- (dolist (class bibtex-sort-entry-class)
- (setq i (1+ i))
- (dolist (entry class)
- ;; All entry types should be downcase (for ease of comparison).
- (push (cons (if (stringp entry) (downcase entry) entry) i)
- alist)))
- alist))))
+ (if (consp bibtex-maintain-sorted-entries)
+ ;; Custom sorting scheme
+ (funcall (car bibtex-maintain-sorted-entries))
+ (let ((key (bibtex-key-in-head))
+ ;; ENTRY-TYPE should be downcase (for ease of comparison)
+ (entry-type (downcase (bibtex-type-in-head)))
+ bounds)
+ (list key
+ ;; Don't search CROSSREF-KEY if we don't need it.
+ (and (eq bibtex-maintain-sorted-entries 'crossref)
+ (setq bounds (bibtex-search-forward-field
+ "\\(OPT\\)?crossref" t))
+ (bibtex-text-in-field-bounds bounds t))
+ entry-type))))))
(defun bibtex-lessp (index1 index2)
"Predicate for sorting BibTeX entries with indices INDEX1 and INDEX2.
@@ -3978,6 +4203,8 @@ The predicate depends on the variable `bibtex-maintain-sorted-entries'.
If its value is nil use plain sorting."
(cond ((not index1) (not index2)) ; indices can be nil
((not index2) nil)
+ ((consp bibtex-maintain-sorted-entries)
+ (funcall (cadr bibtex-maintain-sorted-entries) index1 index2))
((eq bibtex-maintain-sorted-entries 'crossref)
;; CROSSREF-KEY may be nil or it can point to an entry
;; in another BibTeX file. In both cases we ignore CROSSREF-KEY.
@@ -4014,10 +4241,7 @@ affected. If `bibtex-sort-ignore-string-entries' is non-nil, @String entries
are ignored."
(interactive)
(bibtex-beginning-of-first-entry) ; Needed by `sort-subr'
- (bibtex-init-sort-entry-class-alist) ; Needed by `bibtex-lessp'.
- (if (and (eq bibtex-maintain-sorted-entries 'crossref)
- (functionp bibtex-reference-keys))
- (bibtex-parse-keys)) ; Needed by `bibtex-lessp'.
+ (bibtex-init-sort) ; Needed by `bibtex-lessp'.
(sort-subr nil
'bibtex-skip-to-valid-entry ; NEXTREC function
'bibtex-end-of-entry ; ENDREC function
@@ -4045,7 +4269,7 @@ for a crossref key, t otherwise."
(let* ((pnt (point))
(_ (bibtex-beginning-of-entry))
(end (cdr (bibtex-valid-entry t)))
- (_ (unless end (error "Not inside valid entry")))
+ (_ (unless end (user-error "Not inside valid entry")))
(beg (match-end 0)) ; set by `bibtex-valid-entry'
(bounds (bibtex-search-forward-field "\\(OPT\\)?crossref" end))
case-fold-search best temp crossref-key)
@@ -4085,7 +4309,7 @@ for a crossref key, t otherwise."
(bibtex-reposition-window pos)
(beginning-of-line)
(if (and eqb (> pnt pos) (not noerror))
- (error "The referencing entry must precede the crossrefed entry!"))))
+ (user-error "The referencing entry must precede the crossrefed entry"))))
;; `bibtex-search-crossref' is called noninteractively during
;; clean-up of an entry. Then it is not possible to check
;; whether the current entry and the crossrefed entry have
@@ -4168,10 +4392,7 @@ If `bibtex-maintain-sorted-entries' is non-nil, perform a binary
search to look for place for KEY. This requires that buffer is sorted,
see `bibtex-validate'.
Return t if preparation was successful or nil if entry KEY already exists."
- (bibtex-init-sort-entry-class-alist) ; Needed by `bibtex-lessp'.
- (if (and (eq bibtex-maintain-sorted-entries 'crossref)
- (functionp bibtex-reference-keys))
- (bibtex-parse-keys)) ; Needed by `bibtex-lessp'.
+ (bibtex-init-sort) ; Needed by `bibtex-lessp'.
(let ((key (nth 0 index))
key-exist)
(cond ((or (null key)
@@ -4262,9 +4483,7 @@ Return t if test was successful, nil otherwise."
(setq syntax-error t)
;; Check for duplicate keys and correct sort order
- (bibtex-init-sort-entry-class-alist) ; Needed by `bibtex-lessp'.
- (bibtex-parse-keys) ; Possibly needed by `bibtex-lessp'.
- ; Always needed by subsequent global key check.
+ (bibtex-init-sort t) ; Needed by `bibtex-lessp' and global key check.
(let (previous current key-list)
(bibtex-progress-message "Checking for duplicate keys")
(bibtex-map-entries
@@ -4315,12 +4534,19 @@ Return t if test was successful, nil otherwise."
(entry-list (assoc-string (bibtex-type-in-head)
bibtex-entry-alist t))
(crossref (bibtex-search-forward-field "crossref" end))
- (req (if crossref (copy-sequence (nth 2 entry-list))
- (append (nth 2 entry-list)
+ (req (append (nth 2 entry-list)
+ (unless crossref
(copy-sequence (nth 3 entry-list)))))
- (num-alt (length (delq nil (delete-dups
- (mapcar (lambda (x) (nth 3 x))
- req)))))
+ (opt (append (if crossref (nth 3 entry-list))
+ (nth 4 entry-list)
+ bibtex-user-optional-fields))
+ (default (append req opt))
+ (num-alt (let ((n 0))
+ (mapc (lambda (x)
+ (if (nth 3 x)
+ (setq n (max n (abs (nth 3 x))))))
+ default)
+ (1+ n)))
(alt-fields (make-vector num-alt nil))
bounds field idx)
(while (setq bounds (bibtex-parse-field))
@@ -4335,7 +4561,7 @@ Return t if test was successful, nil otherwise."
(push (cons (bibtex-current-line)
"Questionable month field")
error-list))
- (setq field (assoc-string field-name req t)
+ (setq field (assoc-string field-name default t)
req (delete field req))
(if (setq idx (nth 3 field))
(if (aref alt-fields idx)
@@ -4354,12 +4580,13 @@ Return t if test was successful, nil otherwise."
(car field)))
error-list)))
(dotimes (idx num-alt)
- (unless (aref alt-fields idx)
- (push (cons beg-line
- (format-message
- "Alternative fields `%s' missing"
- (aref alt-expect idx)))
- error-list))))))))
+ (if (and (aref alt-expect idx)
+ (not (aref alt-fields idx)))
+ (push (cons beg-line
+ (format-message
+ "Alternative fields `%s' missing"
+ (aref alt-expect idx)))
+ error-list))))))))
(bibtex-progress-message 'done)))))
(if error-list
@@ -4506,7 +4733,7 @@ interactive calls."
(if (memq (preceding-char) '(?} ?\"))
(forward-char -1)))
(if help (bibtex-print-help-message (car bounds))))
- ((not noerror) (error "Not on BibTeX field")))))
+ ((not noerror) (user-error "Not on BibTeX field")))))
(defun bibtex-find-text-internal (&optional noerror subfield comma)
"Find text part of current BibTeX field or entry head.
@@ -4582,8 +4809,8 @@ Optional arg COMMA is as in `bibtex-enclosing-field'."
(cond ((not failure)
(list name start-text end-text end string-const))
((and no-sub (not noerror))
- (error "Not on text part of BibTeX field"))
- ((not noerror) (error "Not on BibTeX field"))))))
+ (user-error "Not on text part of BibTeX field"))
+ ((not noerror) (user-error "Not on BibTeX field"))))))
(defun bibtex-remove-OPT-or-ALT (&optional comma)
"Remove the string starting optional/alternative fields.
@@ -4721,7 +4948,7 @@ The sequence of kills wraps around, so that after the oldest one
comes the newest one."
(interactive "*p")
(unless (eq last-command 'bibtex-yank)
- (error "Previous command was not a BibTeX yank"))
+ (user-error "Previous command was not a BibTeX yank"))
(setq this-command 'bibtex-yank)
(let ((inhibit-read-only t) key)
;; point is at end of yanked entry
@@ -4779,12 +5006,12 @@ At end of the cleaning process, the functions in
(let ((case-fold-search t)
(start (bibtex-beginning-of-entry))
(_ (or (looking-at bibtex-any-entry-maybe-empty-head)
- (error "Not inside a BibTeX entry")))
+ (user-error "Not inside a BibTeX entry")))
(entry-type (bibtex-type-in-head))
(key (bibtex-key-in-head)))
(cond ((bibtex-string= entry-type "preamble")
;; (bibtex-format-preamble)
- (error "No clean up of @Preamble entries"))
+ (user-error "No clean up of @Preamble entries"))
((bibtex-string= entry-type "string")
(setq entry-type 'string))
;; (bibtex-format-string)
@@ -4834,11 +5061,11 @@ At end of the cleaning process, the functions in
(setq error (or (/= (point) start)
(bibtex-search-entry key nil end))))
(if error
- (error "New inserted entry yields duplicate key"))
+ (user-error "New inserted entry yields duplicate key"))
(dolist (buffer (bibtex-initialize))
(with-current-buffer buffer
(if (cdr (assoc-string key bibtex-reference-keys))
- (error "Duplicate key in %s" (buffer-file-name)))))
+ (user-error "Duplicate key in %s" (buffer-file-name)))))
;; Only update `bibtex-strings' and `bibtex-reference-keys'
;; if they have been built already.
@@ -4980,7 +5207,8 @@ If mark is active reformat entries in region, if not in whole buffer."
("Remove empty optional and alternative fields? " . opts-or-alts)
("Remove delimiters around pure numerical fields? " . numerical-fields)
(,(concat (if bibtex-comma-after-last-field "Insert" "Remove")
- " comma at end of entry? ") . last-comma)
+ " comma at end of entry? ")
+ . last-comma)
("Replace double page dashes by single ones? " . page-dashes)
("Delete whitespace at the beginning and end of fields? " . whitespace)
("Inherit booktitle? " . inherit-booktitle)
@@ -5047,7 +5275,7 @@ entries from minibuffer."
(goto-char (point-max))
(message "Buffer is now parsable. Please save it.")))
-(define-obsolete-function-alias 'bibtex-complete 'completion-at-point "24.1")
+(define-obsolete-function-alias 'bibtex-complete #'completion-at-point "24.1")
(defun bibtex-completion-at-point-function ()
(let ((pnt (point))
(case-fold-search t)
@@ -5139,7 +5367,7 @@ entries from minibuffer."
bibtex-maintain-sorted-entries))
endpos)
(unless (bibtex-prepare-new-entry (list key nil "String"))
- (error "Entry with key `%s' already exists" key))
+ (user-error "Entry with key `%s' already exists" key))
(if (zerop (length key)) (setq key nil))
(indent-to-column bibtex-entry-offset)
(insert "@String"
@@ -5258,8 +5486,8 @@ Return the URL or nil if none can be generated."
;; If SCHEME is set up correctly,
;; we should never reach this point
(error "Match failed: %s" text)))
- (if fmt (apply 'format fmt (nreverse obj))
- (apply 'concat (nreverse obj)))))
+ (if fmt (apply #'format fmt (nreverse obj))
+ (apply #'concat (nreverse obj)))))
(if (called-interactively-p 'interactive) (message "%s" url))
(unless no-browse (browse-url url)))
(if (and (not url) (called-interactively-p 'interactive))
@@ -5289,10 +5517,11 @@ where FILE is the BibTeX file of ENTRY."
(list (completing-read
"Field: "
(delete-dups
- (apply 'append
+ (apply #'append
bibtex-user-optional-fields
- (mapcar (lambda (x) (mapcar 'car (apply 'append (nthcdr 2 x))))
- bibtex-entry-alist))) nil t)
+ (mapcar (lambda (x) (mapcar #'car (apply #'append (nthcdr 2 x))))
+ bibtex-entry-alist)))
+ nil t)
(read-string "Regexp: ")
(if bibtex-search-entry-globally
(not current-prefix-arg)
@@ -5379,8 +5608,5 @@ If APPEND is non-nil, append ENTRIES to those already displayed."
(setq buffer-read-only t)
(goto-char (point-min)))
-
-;; Make BibTeX a Feature
-
(provide 'bibtex)
;;; bibtex.el ends here
diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el
index d244a48cbf2..5f34ae152d1 100644
--- a/lisp/textmodes/conf-mode.el
+++ b/lisp/textmodes/conf-mode.el
@@ -44,32 +44,26 @@
"Align assignments to this column by default with \\[conf-align-assignments].
If this number is negative, the `=' comes before the whitespace. Use 0 to
not align (only setting space according to `conf-assignment-space')."
- :type 'integer
- :group 'conf)
+ :type 'integer)
(defcustom conf-javaprop-assignment-column 32
"Value for `conf-assignment-column' in Java properties buffers."
- :type 'integer
- :group 'conf)
+ :type 'integer)
(defcustom conf-colon-assignment-column (- (abs conf-assignment-column))
"Value for `conf-assignment-column' in Java properties buffers."
- :type 'integer
- :group 'conf)
+ :type 'integer)
(defcustom conf-assignment-space t
"Put at least one space around assignments when aligning."
- :type 'boolean
- :group 'conf)
+ :type 'boolean)
(defcustom conf-colon-assignment-space nil
"Value for `conf-assignment-space' in colon style Conf mode buffers."
- :type 'boolean
- :group 'conf)
+ :type 'boolean)
(defvar conf-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
+ (let ((map (make-sparse-keymap)))
(define-key map "\C-c\C-u" 'conf-unix-mode)
(define-key map "\C-c\C-w" 'conf-windows-mode)
(define-key map "\C-c\C-j" 'conf-javaprop-mode)
@@ -83,52 +77,46 @@ not align (only setting space according to `conf-assignment-space')."
(define-key map "\C-c\"" 'conf-quote-normal)
(define-key map "\C-c'" 'conf-quote-normal)
(define-key map "\C-c\C-a" 'conf-align-assignments)
- (define-key map [menu-bar sh-script] (cons "Conf" menu-map))
- (define-key menu-map [conf-windows-mode]
- '(menu-item "Windows mode"
- conf-windows-mode
- :help "Conf Mode starter for Windows style Conf files"
- :button (:radio . (eq major-mode 'conf-windows-mode))))
- (define-key menu-map [conf-javaprop-mode]
- '(menu-item "Java properties mode"
- conf-javaprop-mode
- :help "Conf Mode starter for Java properties files"
- :button (:radio . (eq major-mode 'conf-javaprop-mode))))
- (define-key menu-map [conf-space-keywords]
- '(menu-item "Space keywords mode..."
- conf-space-keywords
- :help "Enter Conf Space mode using regexp KEYWORDS to match the keywords"
- :button (:radio . (eq major-mode 'conf-space-keywords))))
- (define-key menu-map [conf-ppd-mode]
- '(menu-item "PPD mode"
- conf-ppd-mode
- :help "Conf Mode starter for Adobe/CUPS PPD files"
- :button (:radio . (eq major-mode 'conf-ppd-mode))))
- (define-key menu-map [conf-colon-mode]
- '(menu-item "Colon mode"
- conf-colon-mode
- :help "Conf Mode starter for Colon files"
- :button (:radio . (eq major-mode 'conf-colon-mode))))
- (define-key menu-map [conf-unix-mode]
- '(menu-item "Unix mode"
- conf-unix-mode
- :help "Conf Mode starter for Unix style Conf files"
- :button (:radio . (eq major-mode 'conf-unix-mode))))
- (define-key menu-map [conf-xdefaults-mode]
- '(menu-item "Xdefaults mode"
- conf-xdefaults-mode
- :help "Conf Mode starter for Xdefaults files"
- :button (:radio . (eq major-mode 'conf-xdefaults-mode))))
- (define-key menu-map [c-s0] '("--"))
- (define-key menu-map [conf-quote-normal]
- '(menu-item "Set quote syntax normal" conf-quote-normal
- :help "Set the syntax of \\=' and \" to punctuation"))
- (define-key menu-map [conf-align-assignments]
- '(menu-item "Align assignments" conf-align-assignments
- :help "Align assignments"))
map)
"Local keymap for `conf-mode' buffers.")
+(easy-menu-define conf-mode-menu conf-mode-map
+ "Menu for `conf-mode'."
+ '("Conf"
+ ["Align assignments" conf-align-assignments
+ :help "Align assignments"]
+ ["Set quote syntax normal" conf-quote-normal
+ :help "Set the syntax of \\=' and \" to punctuation"]
+ "---"
+ ["Xdefaults mode" conf-xdefaults-mode
+ :help "Conf Mode starter for Xdefaults files"
+ :style radio
+ :selected (eq major-mode 'conf-xdefaults-mode)]
+ ["Unix mode" conf-unix-mode
+ :help "Conf Mode starter for Unix style Conf files"
+ :style radio
+ :selected (eq major-mode 'conf-unix-mode)]
+ ["Colon mode" conf-colon-mode
+ :help "Conf Mode starter for Colon files"
+ :style radio
+ :selected (eq major-mode 'conf-colon-mode)]
+ ["PPD mode" conf-ppd-mode
+ :help "Conf Mode starter for Adobe/CUPS PPD files"
+ :style radio
+ :selected (eq major-mode 'conf-ppd-mode)]
+ ["Space keywords mode..." conf-space-keywords
+ :help "Enter Conf Space mode using regexp KEYWORDS to match the keywords"
+ :style radio
+ :selected (eq major-mode 'conf-space-keywords)]
+ ["Java properties mode" conf-javaprop-mode
+ :help "Conf Mode starter for Java properties files"
+ :style radio
+ :selected (eq major-mode 'conf-javaprop-mode)]
+ ["Windows mode" conf-windows-mode
+ :help "Conf Mode starter for Windows style Conf files"
+ :style radio
+ :selected (eq major-mode 'conf-windows-mode)]))
+
(defvar conf-mode-syntax-table
(let ((table (make-syntax-table)))
(modify-syntax-entry ?= "." table)
@@ -349,9 +337,37 @@ unbalanced, but hey...)"
(scan-error depth))))
+(defun conf--guess-mode ()
+ "Try to guess sub-mode of `conf-mode' based on buffer content."
+ (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0))
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\f")
+ (cond ((eq (char-after) ?\#) (setq unix (1+ unix)))
+ ((eq (char-after) ?\;) (setq win (1+ win)))
+ ((eq (char-after) ?\[)) ; nop
+ ((eolp)) ; nop
+ ((eq (char-after) ?})) ; nop
+ ;; recognize at most double spaces within names
+ ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]")
+ (if (eq (char-before (match-end 0)) ?=)
+ (setq equal (1+ equal))
+ (setq colon (1+ colon))))
+ ((looking-at "/[/*]") (setq jp (1+ jp)))
+ ((looking-at ".*{")) ; nop
+ ((setq space (1+ space))))
+ (forward-line)))
+ (cond
+ ((> jp (max unix win 3)) #'conf-javaprop-mode)
+ ((> colon (max equal space)) #'conf-colon-mode)
+ ((> space (max equal colon)) #'conf-space-mode)
+ ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt)))
+ #'conf-windows-mode)
+ (t #'conf-unix-mode))))
;;;###autoload
-(defun conf-mode ()
+(define-derived-mode conf-mode nil "Conf[?]"
"Mode for Unix and Windows Conf files and Java properties.
Most conf files know only three kinds of constructs: parameter
assignments optionally grouped into sections and comments. Yet
@@ -382,75 +398,41 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode',
\\{conf-mode-map}"
- (interactive)
- ;; `conf-mode' plays two roles: it's the parent of several sub-modes
- ;; but it's also the function that chooses between those submodes.
- ;; To tell the difference between those two cases where the function
- ;; might be called, we check `delay-mode-hooks'.
- ;; (adopted from tex-mode.el)
- (if (not delay-mode-hooks)
- ;; try to guess sub-mode of conf-mode based on buffer content
- (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0))
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward " \t\f")
- (cond ((eq (char-after) ?\#) (setq unix (1+ unix)))
- ((eq (char-after) ?\;) (setq win (1+ win)))
- ((eq (char-after) ?\[)) ; nop
- ((eolp)) ; nop
- ((eq (char-after) ?})) ; nop
- ;; recognize at most double spaces within names
- ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]")
- (if (eq (char-before (match-end 0)) ?=)
- (setq equal (1+ equal))
- (setq colon (1+ colon))))
- ((looking-at "/[/*]") (setq jp (1+ jp)))
- ((looking-at ".*{")) ; nop
- ((setq space (1+ space))))
- (forward-line)))
- (cond
- ((> jp (max unix win 3)) (conf-javaprop-mode))
- ((> colon (max equal space)) (conf-colon-mode))
- ((> space (max equal colon)) (conf-space-mode))
- ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt)))
- (conf-windows-mode))
- (t (conf-unix-mode))))
-
- (kill-all-local-variables)
- (use-local-map conf-mode-map)
- (setq major-mode 'conf-mode
- mode-name "Conf[?]")
- (set (make-local-variable 'font-lock-defaults)
- '(conf-font-lock-keywords nil t nil nil))
- ;; Let newcomment.el decide this for itself.
- ;; (set (make-local-variable 'comment-use-syntax) t)
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'outline-regexp)
- "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)")
- (set (make-local-variable 'outline-heading-end-regexp)
- "[\n}]")
- (set (make-local-variable 'outline-level)
- 'conf-outline-level)
- (set-syntax-table conf-mode-syntax-table)
- (setq imenu-generic-expression
- '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1)
- ;; [section]
- (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1)
- ;; section { ... }
- (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1)))
- (run-mode-hooks 'conf-mode-hook)))
+ (setq-local font-lock-defaults '(conf-font-lock-keywords nil t nil nil))
+ ;; Let newcomment.el decide this for itself.
+ ;; (setq-local comment-use-syntax t)
+ (setq-local parse-sexp-ignore-comments t)
+ (setq-local outline-regexp "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)")
+ (setq-local outline-heading-end-regexp "[\n}]")
+ (setq-local outline-level #'conf-outline-level)
+ (setq-local imenu-generic-expression
+ '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1)
+ ;; [section]
+ (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1)
+ ;; section { ... }
+ (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1))))
+
+;; `conf-mode' plays two roles: it's the parent of several sub-modes
+;; but it's also the function that chooses between those submodes.
+;; To tell the difference between those two cases where the function
+;; might be called, we check `delay-mode-hooks'.
+;; (inspired from tex-mode.el)
+(advice-add 'conf-mode :around
+ (lambda (orig-fun)
+ "Redirect to one of the submodes when called directly."
+ (funcall (if delay-mode-hooks orig-fun (conf--guess-mode)))))
+
+
(defun conf-mode-initialize (comment &optional font-lock)
"Initializations for sub-modes of `conf-mode'.
COMMENT initializes `comment-start' and `comment-start-skip'.
The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS."
- (set (make-local-variable 'comment-start) comment)
- (set (make-local-variable 'comment-start-skip)
- (concat (regexp-quote comment-start) "+\\s *"))
+ (setq-local comment-start comment)
+ (setq-local comment-start-skip
+ (concat (regexp-quote comment-start) "+\\s *"))
(if font-lock
- (set (make-local-variable 'font-lock-defaults)
- `(,font-lock nil t nil nil))))
+ (setq-local font-lock-defaults `(,font-lock nil t nil nil))))
;;;###autoload
(define-derived-mode conf-unix-mode conf-mode "Conf[Unix]"
@@ -497,13 +479,11 @@ x.1 =
x.2.y.1.z.1 =
x.2.y.1.z.2.zz ="
(conf-mode-initialize "#" 'conf-javaprop-font-lock-keywords)
- (set (make-local-variable 'conf-assignment-column)
- conf-javaprop-assignment-column)
- (set (make-local-variable 'conf-assignment-regexp)
- ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)")
- (setq comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *")
- (setq imenu-generic-expression
- '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1))))
+ (setq-local conf-assignment-column conf-javaprop-assignment-column)
+ (setq-local conf-assignment-regexp ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)")
+ (setq-local comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *")
+ (setq-local imenu-generic-expression
+ '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1))))
;;;###autoload
(define-derived-mode conf-space-mode conf-unix-mode "Conf[Space]"
@@ -529,20 +509,18 @@ class desktop
add /dev/audio desktop
add /dev/mixer desktop"
(conf-mode-initialize "#" 'conf-space-font-lock-keywords)
- (make-local-variable 'conf-assignment-sign)
- (setq conf-assignment-sign nil)
- (make-local-variable 'conf-space-keywords)
+ (setq-local conf-assignment-sign nil)
(cond (buffer-file-name
;; We set conf-space-keywords directly, but a value which is
;; in the local variables list or interactively specified
;; (see the function conf-space-keywords) takes precedence.
- (setq conf-space-keywords
- (assoc-default buffer-file-name conf-space-keywords-alist
- 'string-match))))
+ (setq-local conf-space-keywords
+ (assoc-default buffer-file-name conf-space-keywords-alist
+ #'string-match))))
(conf-space-mode-internal)
;; In case the local variables list specifies conf-space-keywords,
;; recompute other things from that afterward.
- (add-hook 'hack-local-variables-hook 'conf-space-mode-internal nil t))
+ (add-hook 'hack-local-variables-hook #'conf-space-mode-internal nil t))
;;;###autoload
(defun conf-space-keywords (keywords)
@@ -553,16 +531,16 @@ See `conf-space-mode'."
(conf-space-mode))
(if (string-equal keywords "")
(setq keywords nil))
- (setq conf-space-keywords keywords)
+ (setq-local conf-space-keywords keywords)
(conf-space-mode-internal)
(run-mode-hooks))
(defun conf-space-mode-internal ()
- (make-local-variable 'conf-assignment-regexp)
- (setq conf-assignment-regexp
- (if conf-space-keywords
- (concat "\\(?:" conf-space-keywords "\\)[ \t]+.+?\\([ \t]+\\|$\\)")
- ".+?\\([ \t]+\\|$\\)"))
+ (setq-local conf-assignment-regexp
+ (if conf-space-keywords
+ (concat "\\(?:" conf-space-keywords
+ "\\)[ \t]+.+?\\([ \t]+\\|$\\)")
+ ".+?\\([ \t]+\\|$\\)"))
;; If Font Lock is already enabled, reenable it with new
;; conf-assignment-regexp.
(when (and font-lock-mode
@@ -596,17 +574,13 @@ For details see `conf-mode'. Example:
<Multi_key> <exclam> <exclam> : \"\\241\" exclamdown
<Multi_key> <c> <slash> : \"\\242\" cent"
(conf-mode-initialize "#" 'conf-colon-font-lock-keywords)
- (set (make-local-variable 'conf-assignment-space)
- conf-colon-assignment-space)
- (set (make-local-variable 'conf-assignment-column)
- conf-colon-assignment-column)
- (set (make-local-variable 'conf-assignment-sign)
- ?:)
- (set (make-local-variable 'conf-assignment-regexp)
- ".+?\\([ \t]*:[ \t]*\\)")
- (setq imenu-generic-expression
- `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1)
- ,@(cdr imenu-generic-expression))))
+ (setq-local conf-assignment-space conf-colon-assignment-space)
+ (setq-local conf-assignment-column conf-colon-assignment-column)
+ (setq-local conf-assignment-sign ?:)
+ (setq-local conf-assignment-regexp ".+?\\([ \t]*:[ \t]*\\)")
+ (setq-local imenu-generic-expression
+ `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1)
+ ,@(cdr imenu-generic-expression))))
;;;###autoload
(define-derived-mode conf-ppd-mode conf-colon-mode "Conf[PPD]"
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 9236e23e475..61a2f6b3bc0 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -67,13 +67,12 @@
(defconst scss-at-ids
'("at-root" "content" "debug" "each" "else" "else if" "error" "extend"
- "for" "function" "if" "import" "include" "mixin" "return" "warn"
+ "for" "function" "if" "import" "include" "mixin" "return" "use" "warn"
"while")
"Additional identifiers that appear in the form @foo in SCSS.")
-(defvar css--at-ids css-at-ids
+(defvar-local css--at-ids css-at-ids
"List of at-rules for the current mode.")
-(make-variable-buffer-local 'css--at-ids)
(defconst css-bang-ids
'("important")
@@ -83,9 +82,8 @@
'("default" "global" "optional")
"Additional identifiers that appear in the form !foo in SCSS.")
-(defvar css--bang-ids css-bang-ids
+(defvar-local css--bang-ids css-bang-ids
"List of bang-rules for the current mode.")
-(make-variable-buffer-local 'css--bang-ids)
(defconst css-descriptor-ids
'("ascent" "baseline" "bbox" "cap-height" "centerline" "definition-src"
@@ -100,7 +98,7 @@
"Identifiers for types of media.")
(defconst css-property-alist
- ;; CSS 2.1 properties (http://www.w3.org/TR/CSS21/propidx.html).
+ ;; CSS 2.1 properties (https://www.w3.org/TR/CSS21/propidx.html).
;;
;; Properties duplicated by any of the CSS3 modules below have been
;; removed.
@@ -119,7 +117,6 @@
("cue" cue-before cue-after)
("cue-after" uri "none")
("cue-before" uri "none")
- ("direction" "ltr" "rtl")
("display" "inline" "block" "list-item" "inline-block" "table"
"inline-table" "table-row-group" "table-header-group"
"table-footer-group" "table-row" "table-column-group"
@@ -180,7 +177,6 @@
("stress" number)
("table-layout" "auto" "fixed")
("top" length percentage "auto")
- ("unicode-bidi" "normal" "embed" "bidi-override")
("vertical-align" "baseline" "sub" "super" "top" "text-top"
"middle" "bottom" "text-bottom" percentage length)
("visibility" "visible" "hidden" "collapse")
@@ -192,7 +188,7 @@
("z-index" "auto" integer)
;; CSS Animations
- ;; (http://www.w3.org/TR/css3-animations/#property-index)
+ ;; (https://www.w3.org/TR/css3-animations/#property-index)
("animation" single-animation-name time single-timing-function
single-animation-iteration-count single-animation-direction
single-animation-fill-mode single-animation-play-state)
@@ -206,7 +202,7 @@
("animation-timing-function" single-timing-function)
;; CSS Backgrounds and Borders Module Level 3
- ;; (http://www.w3.org/TR/css3-background/#property-index)
+ ;; (https://www.w3.org/TR/css3-background/#property-index)
("background" bg-layer final-bg-layer)
("background-attachment" attachment)
("background-clip" box)
@@ -251,7 +247,7 @@
("box-shadow" "none" shadow)
;; CSS Basic User Interface Module Level 3 (CSS3 UI)
- ;; (http://www.w3.org/TR/css3-ui/#property-index)
+ ;; (https://www.w3.org/TR/css3-ui/#property-index)
("box-sizing" "content-box" "border-box")
("caret-color" "auto" color)
("cursor" uri x y "auto" "default" "none" "context-menu" "help"
@@ -274,10 +270,14 @@
("text-overflow" "clip" "ellipsis" string)
;; CSS Color Module Level 3
- ;; (http://www.w3.org/TR/css3-color/#property)
+ ;; (https://www.w3.org/TR/css3-color/#property)
("color" color)
("opacity" alphavalue)
+ ;; CSS Containment Module Level 1
+ ;; (https://www.w3.org/TR/css-contain-1/#property-index)
+ ("contain" "none" "strict" "content" "size" "layout" "paint")
+
;; CSS Grid Layout Module Level 1
;; (https://www.w3.org/TR/css-grid-1/#property-index)
("grid" grid-template grid-template-rows "auto-flow" "dense"
@@ -302,7 +302,7 @@
("grid-template-rows" "none" track-list auto-track-list)
;; CSS Flexible Box Layout Module Level 1
- ;; (http://www.w3.org/TR/css-flexbox-1/#property-index)
+ ;; (https://www.w3.org/TR/css-flexbox-1/#property-index)
("align-content" "flex-start" "flex-end" "center" "space-between"
"space-around" "stretch")
("align-items" "flex-start" "flex-end" "center" "baseline"
@@ -321,7 +321,7 @@
("order" integer)
;; CSS Fonts Module Level 3
- ;; (http://www.w3.org/TR/css3-fonts/#property-index)
+ ;; (https://www.w3.org/TR/css3-fonts/#property-index)
("font" font-style font-variant-css21 font-weight font-stretch
font-size line-height font-family "caption" "icon" "menu"
"message-box" "small-caption" "status-bar")
@@ -417,7 +417,7 @@
("columns" column-width column-count)
;; CSS Overflow Module Level 3
- ;; (http://www.w3.org/TR/css-overflow-3/#property-index)
+ ;; (https://www.w3.org/TR/css-overflow-3/#property-index)
("max-lines" "none" integer)
("overflow" "visible" "hidden" "scroll" "auto" "paged-x" "paged-y"
"paged-x-controls" "paged-y-controls" "fragments")
@@ -427,7 +427,7 @@
"paged-y" "paged-x-controls" "paged-y-controls" "fragments")
;; CSS Text Decoration Module Level 3
- ;; (http://dev.w3.org/csswg/css-text-decor-3/#property-index)
+ ;; (https://dev.w3.org/csswg/css-text-decor-3/#property-index)
("text-decoration" text-decoration-line text-decoration-style
text-decoration-color)
("text-decoration-color" color)
@@ -446,7 +446,7 @@
("text-underline-position" "auto" "under" "left" "right")
;; CSS Text Module Level 3
- ;; (http://www.w3.org/TR/css3-text/#property-index)
+ ;; (https://www.w3.org/TR/css3-text/#property-index)
("hanging-punctuation" "none" "first" "force-end" "allow-end"
"last")
("hyphens" "none" "manual" "auto")
@@ -468,7 +468,7 @@
("word-wrap" "normal" "break-word")
;; CSS Transforms Module Level 1
- ;; (http://www.w3.org/TR/css3-2d-transforms/#property-index)
+ ;; (https://www.w3.org/TR/css3-2d-transforms/#property-index)
("backface-visibility" "visible" "hidden")
("perspective" "none" length)
("perspective-origin" "left" "center" "right" "top" "bottom"
@@ -479,7 +479,7 @@
("transform-style" "flat" "preserve-3d")
;; CSS Transitions
- ;; (http://www.w3.org/TR/css3-transitions/#property-index)
+ ;; (https://www.w3.org/TR/css3-transitions/#property-index)
("transition" single-transition)
("transition-delay" time)
("transition-duration" time)
@@ -490,8 +490,18 @@
;; (https://www.w3.org/TR/css-will-change-1/#property-index)
("will-change" "auto" animateable-feature)
+ ;; CSS Writing Modes Level 3
+ ;; (https://www.w3.org/TR/css-writing-modes-3/#property-index)
+ ;; "glyph-orientation-vertical" is obsolete and left out.
+ ("direction" "ltr" "rtl")
+ ("text-combine-upright" "none" "all")
+ ("text-orientation" "mixed" "upright" "sideways")
+ ("unicode-bidi" "normal" "embed" "isolate" "bidi-override"
+ "isolate-override" "plaintext")
+ ("writing-mode" "horizontal-tb" "vertical-rl" "vertical-lr")
+
;; Filter Effects Module Level 1
- ;; (http://www.w3.org/TR/filter-effects/#property-index)
+ ;; (https://www.w3.org/TR/filter-effects/#property-index)
("color-interpolation-filters" "auto" "sRGB" "linearRGB")
("filter" "none" filter-function-list)
("flood-color" color)
@@ -874,7 +884,7 @@ cannot be completed sensibly: `custom-ident',
(defconst css-escapes-re
"\\\\\\(?:[^\000-\037\177]\\|[[:xdigit:]]+[ \n\t\r\f]?\\)")
-(defconst css-nmchar-re (concat "\\(?:[-[:alnum:]]\\|" css-escapes-re "\\)"))
+(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 "*")
;; Apparently, "at rules" names can start with a dash, e.g. @-moz-keyframes.
@@ -1137,17 +1147,6 @@ returns, point will be at the end of the recognized color."
;; Evaluate to the color if the name is found.
((css--named-color start-point match))))
-(defun css--contrasty-color (name)
- "Return a color that contrasts with NAME.
-NAME is of any form accepted by `color-distance'.
-The returned color will be usable by Emacs and will contrast
-with NAME; in particular so that if NAME is used as a background
-color, the returned color can be used as the foreground and still
-be readable."
- ;; See bug#25525 for a discussion of this.
- (if (> (color-distance name "black") 292485)
- "black" "white"))
-
(defcustom css-fontify-colors t
"Whether CSS colors should be fontified using the color as the background.
When non-`nil', a text representing CSS color will be fontified
@@ -1187,7 +1186,8 @@ START and END are buffer positions."
(add-text-properties
start (point)
(list 'face (list :background color
- :foreground (css--contrasty-color color)
+ :foreground (readable-foreground-color
+ color)
:box '(:line-width -1))))))))))))
extended-region))
@@ -1307,10 +1307,14 @@ for determining whether point is within a selector."
(let ((pos (point)))
(skip-chars-backward "-[:alnum:]")
(when (eq (char-before) ?\:)
- (list (point) pos
- (if (eq (char-before (- (point) 1)) ?\:)
- css-pseudo-element-ids
- css-pseudo-class-ids))))))
+ (let ((double-colon (eq (char-before (- (point) 1)) ?\:)))
+ (list (- (point) (if double-colon 2 1))
+ pos
+ (nconc
+ (unless double-colon
+ (mapcar (lambda (id) (concat ":" id)) css-pseudo-class-ids))
+ (mapcar (lambda (id) (concat "::" id)) css-pseudo-element-ids))
+ :company-kind (lambda (_) 'function)))))))
(defun css--complete-at-rule ()
"Complete at-rule (statement beginning with `@') at point."
@@ -1318,7 +1322,8 @@ for determining whether point is within a selector."
(let ((pos (point)))
(skip-chars-backward "-[:alnum:]")
(when (eq (char-before) ?\@)
- (list (point) pos css--at-ids)))))
+ (list (point) pos css--at-ids
+ :company-kind (lambda (_) 'keyword))))))
(defvar css--property-value-cache
(make-hash-table :test 'equal :size (length css-property-alist))
@@ -1354,29 +1359,27 @@ the string PROPERTY."
(defun css--complete-property-value ()
"Complete property value at point."
- (let ((property
- (save-excursion
- (re-search-backward ":[^/]" (line-beginning-position) t)
- (when (eq (char-after) ?:)
- (let ((property-end (point)))
- (skip-chars-backward "-[:alnum:]")
- (let ((prop (buffer-substring (point) property-end)))
- (car (member prop css-property-ids))))))))
+ (let ((property (and (looking-back "\\([[:alnum:]-]+\\):[^/][^;]*"
+ (or (ppss-innermost-start (syntax-ppss))
+ (point))
+ t)
+ (member (match-string-no-properties 1)
+ css-property-ids))))
(when property
(let ((end (point)))
(save-excursion
(skip-chars-backward "[:graph:]")
(list (point) end
(append '("inherit" "initial" "unset")
- (css--property-values property))))))))
+ (css--property-values (car property)))
+ :company-kind (lambda (_) 'value)))))))
(defvar css--html-tags (mapcar #'car html-tag-alist)
"List of HTML tags.
Used to provide completion of HTML tags in selectors.")
-(defvar css--nested-selectors-allowed nil
+(defvar-local css--nested-selectors-allowed nil
"Non-nil if nested selectors are allowed in the current mode.")
-(make-variable-buffer-local 'css--nested-selectors-allowed)
(defvar css-class-list-function #'ignore
"Called to provide completions of class names.
@@ -1438,6 +1441,8 @@ tags, classes and IDs."
(list prop-beg prop-end)
(list sel-beg sel-end))
,(completion-table-merge prop-table sel-table)
+ :company-kind
+ ,(lambda (s) (if (test-completion s prop-table) 'property 'keyword))
:exit-function
,(lambda (string status)
(and (eq status 'finished)
@@ -1881,12 +1886,9 @@ on what is seen near point."
(list
(let* ((sym (css--mdn-find-symbol))
(enable-recursive-minibuffers t)
- (value (completing-read
- (if sym
- (format "Describe CSS symbol (default %s): " sym)
- "Describe CSS symbol: ")
- css--mdn-completion-list nil nil nil
- 'css--mdn-lookup-history sym)))
+ (value (completing-read (format-prompt "Describe CSS symbol" sym)
+ css--mdn-completion-list nil nil nil
+ 'css--mdn-lookup-history sym)))
(if (equal value "") sym value))))
(when symbol
;; If we see a single-colon pseudo-element like ":after", turn it
diff --git a/lisp/textmodes/dns-mode.el b/lisp/textmodes/dns-mode.el
index 170b0d23ffe..2fa5e8de398 100644
--- a/lisp/textmodes/dns-mode.el
+++ b/lisp/textmodes/dns-mode.el
@@ -1,4 +1,4 @@
-;;; dns-mode.el --- a mode for viewing/editing Domain Name System master files
+;;; dns-mode.el --- a mode for viewing/editing Domain Name System master files -*- lexical-binding: t -*-
;; Copyright (C) 2000-2001, 2004-2021 Free Software Foundation, Inc.
@@ -70,23 +70,19 @@
(defface dns-mode-control-entity '((t :inherit font-lock-keyword-face))
"Face used for DNS control entities, e.g. $ORIGIN."
- :version "26.1"
- :group 'dns-mode)
+ :version "26.1")
(defface dns-mode-bad-control-entity '((t :inherit font-lock-warning-face))
"Face used for non-standard DNS control entities, e.g. $FOO."
- :version "26.1"
- :group 'dns-mode)
+ :version "26.1")
(defface dns-mode-type '((t :inherit font-lock-type-face))
"Face used for DNS types, e.g., SOA."
- :version "26.1"
- :group 'dns-mode)
+ :version "26.1")
(defface dns-mode-class '((t :inherit font-lock-constant-face))
"Face used for DNS classes, e.g., IN."
- :version "26.1"
- :group 'dns-mode)
+ :version "26.1")
(defvar dns-mode-control-entity-face ''dns-mode-control-entity
"Name of face used for control entities, e.g. $ORIGIN.")
@@ -121,8 +117,7 @@
(,(regexp-opt dns-mode-types) 0 ,dns-mode-type-face))
"Font lock keywords used to highlight text in DNS master file mode."
:version "26.1"
- :type 'sexp
- :group 'dns-mode)
+ :type 'sexp)
(defcustom dns-mode-soa-auto-increment-serial t
"Whether to increment the SOA serial number automatically.
@@ -134,8 +129,7 @@ manually with \\[dns-mode-soa-increment-serial]."
:type '(choice (const :tag "Always" t)
(const :tag "Ask" ask)
(const :tag "Never" nil))
- :safe 'symbolp
- :group 'dns-mode)
+ :safe 'symbolp)
;; Syntax table.
@@ -150,8 +144,8 @@ manually with \\[dns-mode-soa-increment-serial]."
(defvar dns-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-s" 'dns-mode-soa-increment-serial)
- (define-key map "\C-c\C-e" 'dns-mode-ipv6-to-nibbles)
+ (define-key map "\C-c\C-s" #'dns-mode-soa-increment-serial)
+ (define-key map "\C-c\C-e" #'dns-mode-ipv6-to-nibbles)
map)
"Keymap for DNS master file mode.")
@@ -178,14 +172,13 @@ variables for customizing indentation. It has its own abbrev
table and its own syntax table.
Turning on DNS mode runs `dns-mode-hook'."
- (set (make-local-variable 'comment-start) ";")
- (set (make-local-variable 'comment-end) "")
- (set (make-local-variable 'comment-start-skip) ";+ *")
- (set (make-local-variable 'font-lock-defaults)
- '(dns-mode-font-lock-keywords nil nil ((?_ . "w"))))
- (add-hook 'before-save-hook 'dns-mode-soa-maybe-increment-serial
- nil t)
- (easy-menu-add dns-mode-menu dns-mode-map))
+ (setq-local comment-start ";")
+ (setq-local comment-end "")
+ (setq-local comment-start-skip ";+ *")
+ (setq-local font-lock-defaults
+ '(dns-mode-font-lock-keywords nil nil ((?_ . "w"))))
+ (add-hook 'before-save-hook #'dns-mode-soa-maybe-increment-serial
+ nil t))
;;;###autoload (defalias 'zone-mode 'dns-mode)
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index c75a7cedb4d..877658a5a55 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -1,4 +1,4 @@
-;;; enriched.el --- read and save files in text/enriched format
+;;; enriched.el --- read and save files in text/enriched format -*- lexical-binding: t; -*-
;; Copyright (C) 1994-1996, 2001-2021 Free Software Foundation, Inc.
@@ -38,7 +38,7 @@
;;; Code:
-(provide 'enriched)
+(require 'facemenu)
;;;
;;; Variables controlling the display
@@ -50,8 +50,7 @@
(defcustom enriched-verbose t
"If non-nil, give status messages when reading and writing files."
- :type 'boolean
- :group 'enriched)
+ :type 'boolean)
;;;
;;; Set up faces & display table
@@ -65,14 +64,12 @@
"Face used for text that must be shown in fixed width.
Currently, Emacs can only display fixed-width fonts, but this may change.
This face is used for text specifically marked as fixed-width, for example
-in text/enriched files."
- :group 'enriched)
+in text/enriched files.")
(defface excerpt
'((t (:slant italic)))
"Face used for text that is an excerpt from another document.
-This is used in Enriched mode for text explicitly marked as an excerpt."
- :group 'enriched)
+This is used in Enriched mode for text explicitly marked as an excerpt.")
(defconst enriched-display-table (or (copy-sequence standard-display-table)
(make-display-table)))
@@ -146,8 +143,7 @@ Any property that is neither on this list nor dealt with by
If you set variables in this hook, you should arrange for them to be restored
to their old values if you leave Enriched mode. One way to do this is to add
them and their old values to `enriched-old-bindings'."
- :type 'hook
- :group 'enriched)
+ :type 'hook)
(defcustom enriched-allow-eval-in-display-props nil
"If non-nil allow to evaluate arbitrary forms in display properties.
@@ -162,13 +158,11 @@ Note, however, that applying unsafe display properties could
execute malicious Lisp code, if that code came from an external source."
:risky t
:type 'boolean
- :version "26.1"
- :group 'enriched)
+ :version "26.1")
-(defvar enriched-old-bindings nil
+(defvar-local enriched-old-bindings nil
"Store old variable values that we change when entering mode.
The value is a list of \(VAR VALUE VAR VALUE...).")
-(make-variable-buffer-local 'enriched-old-bindings)
;; The next variable is buffer local if and only if Enriched mode is
;; enabled. The buffer local value records whether
@@ -187,15 +181,16 @@ The value is a list of \(VAR VALUE VAR VALUE...).")
(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)
+ ;; FIXME: These newline/reindent bindings might be redundant now
+ ;; that we have `electric-indent-mode' enabled by default.
+ (define-key map "\C-m" #'reindent-then-newline-and-indent)
(define-key map
- [remap newline-and-indent] 'reindent-then-newline-and-indent)
+ [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)
+ (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.")
@@ -222,7 +217,7 @@ Commands:
(cond ((null enriched-mode)
;; Turn mode off
(remove-hook 'change-major-mode-hook
- 'enriched-before-change-major-mode 'local)
+ #'enriched-before-change-major-mode 'local)
(setq buffer-file-format (delq 'text/enriched buffer-file-format))
;; restore old variable values
(while enriched-old-bindings
@@ -239,7 +234,7 @@ Commands:
(t ; Turn mode on
(add-hook 'change-major-mode-hook
- 'enriched-before-change-major-mode nil 'local)
+ #'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.
@@ -247,16 +242,17 @@ Commands:
(list 'buffer-display-table buffer-display-table
'default-text-properties default-text-properties
'use-hard-newlines use-hard-newlines))
- (make-local-variable 'enriched-default-text-properties-local-flag)
- (setq enriched-default-text-properties-local-flag
- (local-variable-p 'default-text-properties))
+ (setq-local enriched-default-text-properties-local-flag
+ (local-variable-p 'default-text-properties))
(make-local-variable 'default-text-properties)
(setq buffer-display-table enriched-display-table)
(use-hard-newlines 1 (if enriched-rerun-flag 'never nil))
- (let ((sticky (plist-get default-text-properties 'front-sticky))
- (p enriched-par-props))
- (dolist (x p)
- (add-to-list 'sticky x))
+ (let* ((sticky
+ (delete-dups
+ (append
+ enriched-par-props
+ (copy-sequence
+ (plist-get default-text-properties 'front-sticky))))))
(if sticky
(setq default-text-properties
(plist-put default-text-properties
@@ -272,7 +268,7 @@ Commands:
(let ((enriched-rerun-flag t))
(enriched-mode 1))))
-(add-hook 'after-change-major-mode-hook 'enriched-after-change-major-mode)
+(add-hook 'after-change-major-mode-hook #'enriched-after-change-major-mode)
(fset 'enriched-mode-map enriched-mode-map)
@@ -350,7 +346,7 @@ the region, and the START and END of each region."
(if orig-buf (set-buffer orig-buf))
(funcall enriched-initial-annotation))))
(enriched-map-property-regions 'hard
- (lambda (v b e)
+ (lambda (v b _e)
(if (and v (= ?\n (char-after b)))
(progn (goto-char b) (insert "\n"))))
(point) nil)
@@ -394,9 +390,11 @@ which can be the value of the `face' text property."
((and (listp face) (eq (car face) :background))
(list (list "x-bg-color" (cadr face))))
((listp face)
- (apply 'append (mapcar 'enriched-face-ans face)))
+ (apply #'append (mapcar #'enriched-face-ans face)))
((let* ((fg (face-attribute face :foreground))
(bg (face-attribute face :background))
+ (weight (face-attribute face :weight))
+ (slant (face-attribute face :slant))
(props (face-font face t))
(ans (cdr (format-annotate-single-property-change
'face nil props enriched-translations))))
@@ -404,6 +402,10 @@ which can be the value of the `face' text property."
(setq ans (cons (list "x-color" fg) ans)))
(unless (eq bg 'unspecified)
(setq ans (cons (list "x-bg-color" bg) ans)))
+ (if (eq weight 'bold)
+ (setq ans (cons (list "bold") ans)))
+ (if (eq slant 'italic)
+ (setq ans (cons (list "italic") ans)))
ans))))
;;;
@@ -536,4 +538,6 @@ the range of text to assign text property SYMBOL with value VALUE."
(list start end 'display prop)
(list start end 'display (list 'disable-eval prop)))))
+(provide 'enriched)
+
;;; enriched.el ends here
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index 6d283bd6f14..f394171fb6c 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -1,4 +1,4 @@
-;;; fill.el --- fill commands for Emacs
+;;; fill.el --- fill commands for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1992, 1994-1997, 1999, 2001-2021 Free
;; Software Foundation, Inc.
@@ -40,14 +40,12 @@ Non-nil means changing indent doesn't end a paragraph.
That mode can handle paragraphs with extra indentation on the first line,
but it requires separator lines between paragraphs.
A value of nil means that any change in indentation starts a new paragraph."
- :type 'boolean
- :group 'fill)
+ :type 'boolean)
(defcustom colon-double-space nil
"Non-nil means put two spaces after a colon when filling."
- :type 'boolean
- :group 'fill)
-(put 'colon-double-space 'safe-local-variable 'booleanp)
+ :type 'boolean)
+(put 'colon-double-space 'safe-local-variable #'booleanp)
(defcustom fill-separate-heterogeneous-words-with-space nil
"Non-nil means to use a space to separate words of a different kind.
@@ -58,7 +56,6 @@ Whether to use a space to separate such words also depends on the entry
in `fill-nospace-between-words-table' for the characters before and
after the newline."
:type 'boolean
- :group 'fill
:version "26.1")
(defvar fill-paragraph-function nil
@@ -77,8 +74,7 @@ such as `fill-forward-paragraph-function'.")
Kinsoku processing is designed to prevent certain characters from being
placed at the beginning or end of a line by filling.
See the documentation of `kinsoku' for more information."
- :type 'boolean
- :group 'fill)
+ :type 'boolean)
(defun set-fill-prefix ()
"Set the fill prefix to the current line up to point.
@@ -98,8 +94,7 @@ reinserts the fill prefix in each resulting line."
(defcustom adaptive-fill-mode t
"Non-nil means determine a paragraph's fill prefix from its text."
- :type 'boolean
- :group 'fill)
+ :type 'boolean)
(defcustom adaptive-fill-regexp
;; Added `!' for doxygen comments starting with `//!' or `/*!'.
@@ -115,8 +110,7 @@ standard indentation for the whole paragraph.
If the paragraph has just one line, the indentation is taken from that
line, but in that case `adaptive-fill-first-line-regexp' also plays
a role."
- :type 'regexp
- :group 'fill)
+ :type 'regexp)
(defcustom adaptive-fill-first-line-regexp (purecopy "\\`[ \t]*\\'")
"Regexp specifying whether to set fill prefix from a one-line paragraph.
@@ -128,19 +122,19 @@ By default, this regexp matches sequences of just spaces and tabs.
However, we never use a prefix from a one-line paragraph
if it would act as a paragraph-starter on the second line."
- :type 'regexp
- :group 'fill)
+ :type 'regexp)
(defcustom adaptive-fill-function #'ignore
"Function to call to choose a fill prefix for a paragraph.
A nil return value means the function has not determined the fill prefix."
:version "27.1"
- :type 'function
- :group 'fill)
+ :type 'function)
(defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks.
"Whether or not filling should try to use the major mode's indentation.")
+(defvar current-fill-column--has-warned nil)
+
(defun current-fill-column ()
"Return the fill-column to use for this line.
The fill-column to use for a buffer is stored in the variable `fill-column',
@@ -166,7 +160,14 @@ number equals or exceeds the local fill-column - right-margin difference."
(< col fill-col)))
(setq here change
here-col col))
- (max here-col fill-col)))))
+ (max here-col fill-col))
+ ;; This warning was added in 28.1. It should be removed later,
+ ;; and this function changed to never return nil.
+ (unless current-fill-column--has-warned
+ (lwarn '(fill-column) :warning
+ "Setting this variable to nil is obsolete; use `(auto-fill-mode -1)' instead")
+ (setq current-fill-column--has-warned t))
+ most-positive-fixnum)))
(defun canonically-space-region (beg end)
"Remove extra spaces between words in region.
@@ -369,15 +370,13 @@ which is an error according to some typographical conventions."
The predicates are called with no arguments, with point at the place to
be tested. If it returns a non-nil value, fill commands do not break
the line there."
- :group 'fill
:type 'hook
:options '(fill-french-nobreak-p fill-single-word-nobreak-p
fill-single-char-nobreak-p))
(defcustom fill-nobreak-invisible nil
"Non-nil means that fill commands do not break lines in invisible text."
- :type 'boolean
- :group 'fill)
+ :type 'boolean)
(defun fill-nobreak-p ()
"Return nil if breaking the line at point is allowed.
@@ -424,12 +423,12 @@ and `fill-nobreak-invisible'."
;; Register `kinsoku' for scripts HAN, KANA, BOPOMOFO, and CJK-MISC.
;; Also tell that they don't use space between words.
(map-char-table
- #'(lambda (key val)
- (when (memq val '(han kana bopomofo cjk-misc))
- (set-char-table-range fill-find-break-point-function-table
- key 'kinsoku)
- (set-char-table-range fill-nospace-between-words-table
- key t)))
+ (lambda (key val)
+ (when (memq val '(han kana bopomofo cjk-misc))
+ (set-char-table-range fill-find-break-point-function-table
+ key 'kinsoku)
+ (set-char-table-range fill-nospace-between-words-table
+ key t)))
char-script-table)
;; Do the same thing also for full width characters and half
;; width kana variants.
@@ -715,7 +714,8 @@ space does not end a sentence, so don't break a line there."
(or justify (setq justify (current-justification)))
;; Don't let Adaptive Fill mode alter the fill prefix permanently.
- (let ((fill-prefix fill-prefix))
+ (let ((actual-fill-prefix fill-prefix)
+ (fill-prefix fill-prefix))
;; Figure out how this paragraph is indented, if desired.
(when (and adaptive-fill-mode
(or (null fill-prefix) (string= fill-prefix "")))
@@ -729,7 +729,7 @@ space does not end a sentence, so don't break a line there."
(goto-char from)
(beginning-of-line)
- (if (not justify) ; filling disabled: just check indentation
+ (if (not justify) ; filling disabled: just check indentation
(progn
(goto-char from)
(while (< (point) to)
@@ -755,9 +755,18 @@ space does not end a sentence, so don't break a line there."
;; This is the actual filling loop.
(goto-char from)
- (let (linebeg)
+ (let ((first t)
+ linebeg)
(while (< (point) to)
- (setq linebeg (point))
+ ;; On the first line, there may be text in the fill prefix
+ ;; zone (when `fill-prefix' is specified externally, and
+ ;; not computed). In that case, don't consider that area
+ ;; when trying to find a place to put a line break
+ ;; (bug#45720).
+ (if (not first)
+ (setq linebeg (point))
+ (setq first nil
+ linebeg (+ (point) (length actual-fill-prefix))))
(move-to-column (current-fill-column))
(if (when (< (point) to)
;; Find the position where we'll break the line.
@@ -1112,8 +1121,7 @@ The `justification' text-property can locally override this variable."
(const full)
(const center)
(const none))
- :safe 'symbolp
- :group 'fill)
+ :safe 'symbolp)
(make-variable-buffer-local 'default-justification)
(defun current-justification ()
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 1ddb68f538f..836d889a1cf 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -57,7 +57,6 @@
(defcustom flyspell-highlight-flag t
"How Flyspell should indicate misspelled words.
Non-nil means use highlight, nil means use minibuffer messages."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-mark-duplications-flag t
@@ -65,12 +64,10 @@ Non-nil means use highlight, nil means use minibuffer messages."
See `flyspell-mark-duplications-exceptions' to add exceptions to this rule.
Detection of repeated words is not implemented in
\"large\" regions; see variable `flyspell-large-region'."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-case-fold-duplications t
"Non-nil means Flyspell matches duplicate words case-insensitively."
- :group 'flyspell
:type 'boolean
:version "27.1")
@@ -80,16 +77,15 @@ Detection of repeated words is not implemented in
"A list of exceptions for duplicated words.
It should be a list of (LANGUAGE . EXCEPTION-LIST).
-LANGUAGE is nil, which means the exceptions apply regardless of
+LANGUAGE can be 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 (choice (const :tag "All dictionaries" nil)
- string)
+ regexp)
:value-type (repeat string))
:version "24.1")
@@ -97,7 +93,6 @@ downcased before comparing with these exceptions."
"If non-nil, sort the corrections before popping them.
The sorting is controlled by the `flyspell-sort-corrections-function'
variable, and defaults to sorting alphabetically."
- :group 'flyspell
:version "21.1"
:type 'boolean)
@@ -109,8 +104,7 @@ function takes three parameters -- the two correction candidates
to be sorted, and the third parameter is the word that's being
corrected."
:version "26.1"
- :type 'function
- :group 'flyspell)
+ :type 'function)
(defun flyspell-sort-corrections-alphabetically (corr1 corr2 _)
(string< corr1 corr2))
@@ -130,14 +124,12 @@ Flyspell uses a different face (`flyspell-duplicate') to highlight it.
This variable specifies how far to search to find such a duplicate.
-1 means no limit (search the whole buffer).
0 means do not search for duplicate unrecognized spellings."
- :group 'flyspell
:version "24.5" ; -1 -> 400000
:type '(choice (const :tag "no limit" -1)
number))
(defcustom flyspell-delay 3
"The number of seconds to wait before checking, after a \"delayed\" command."
- :group 'flyspell
:type 'number)
(defcustom flyspell-persistent-highlight t
@@ -147,12 +139,10 @@ is highlighted, and the highlight is turned off as soon as point moves
off the misspelled word.
Make sure this variable is non-nil if you use `flyspell-region'."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-highlight-properties t
"Non-nil means highlight incorrect words even if a property exists for this word."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-default-delayed-commands
@@ -164,7 +154,6 @@ Make sure this variable is non-nil if you use `flyspell-region'."
backward-delete-char-untabify)
"The standard list of delayed commands for Flyspell.
See `flyspell-delayed-commands'."
- :group 'flyspell
:version "21.1"
:type '(repeat (symbol)))
@@ -172,7 +161,6 @@ See `flyspell-delayed-commands'."
"List of commands that are \"delayed\" for Flyspell mode.
After these commands, Flyspell checking is delayed for a short time,
whose length is specified by `flyspell-delay'."
- :group 'flyspell
:type '(repeat (symbol)))
(defcustom flyspell-default-deplacement-commands
@@ -182,7 +170,6 @@ whose length is specified by `flyspell-delay'."
scroll-down)
"The standard list of deplacement commands for Flyspell.
See variable `flyspell-deplacement-commands'."
- :group 'flyspell
:version "21.1"
:type '(repeat (symbol)))
@@ -190,18 +177,15 @@ See variable `flyspell-deplacement-commands'."
"List of commands that are \"deplacement\" for Flyspell mode.
After these commands, Flyspell checking is performed only if the previous
command was not the very same command."
- :group 'flyspell
:version "21.1"
:type '(repeat (symbol)))
(defcustom flyspell-issue-welcome-flag t
"Non-nil means that Flyspell should display a welcome message when started."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-issue-message-flag t
"Non-nil means that Flyspell emits messages when checking words."
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-incorrect-hook nil
@@ -213,7 +197,6 @@ of possible corrections as returned by `ispell-parse-output'.
If any of the functions return non-nil, the word is not highlighted as
incorrect."
- :group 'flyspell
:version "21.1"
:type 'hook)
@@ -225,50 +208,43 @@ when flyspell is started, the value of that variable is used instead
of `flyspell-default-dictionary' to select the default dictionary.
Otherwise, if `flyspell-default-dictionary' is nil, it means to use
Ispell's ultimate default dictionary."
- :group 'flyspell
:version "21.1"
:type '(choice string (const :tag "Default" nil)))
(defcustom flyspell-tex-command-regexp
"\\(\\(begin\\|end\\)[ \t]*{\\|\\(cite[a-z*]*\\|label\\|ref\\|eqref\\|usepackage\\|documentclass\\)[ \t]*\\(\\[[^]]*\\]\\)?{[^{}]*\\)"
"A string that is the regular expression that matches TeX commands."
- :group 'flyspell
:version "21.1"
- :type 'string)
+ :type 'regexp)
(defcustom flyspell-check-tex-math-command nil
"Non-nil means check even inside TeX math environment.
TeX math environments are discovered by `texmathp', implemented
inside AUCTeX package. That package may be found at
URL `https://www.gnu.org/software/auctex/'"
- :group 'flyspell
:type 'boolean)
(defcustom flyspell-dictionaries-that-consider-dash-as-word-delimiter
'("francais" "deutsch8" "norsk")
"List of dictionary names that consider `-' as word delimiter."
- :group 'flyspell
:version "21.1"
:type '(repeat (string)))
(defcustom flyspell-abbrev-p
nil
"If non-nil, add correction to abbreviation table."
- :group 'flyspell
:version "21.1"
:type 'boolean)
(defcustom flyspell-use-global-abbrev-table-p
nil
"If non-nil, prefer global abbrev table to local abbrev table."
- :group 'flyspell
:version "21.1"
:type 'boolean)
(defcustom flyspell-mode-line-string " Fly"
"String displayed on the mode line when flyspell is active.
Set this to nil if you don't want a mode line indicator."
- :group 'flyspell
:type '(choice string (const :tag "None" nil)))
(defcustom flyspell-large-region 1000
@@ -282,30 +258,25 @@ Doubled words are not detected in a large region, because Ispell
does not check for them.
If this variable is nil, all regions are treated as small."
- :group 'flyspell
:version "21.1"
:type '(choice number (const :tag "All small" nil)))
(defcustom flyspell-insert-function (function insert)
"Function for inserting word by flyspell upon correction."
- :group 'flyspell
:type 'function)
(defcustom flyspell-before-incorrect-word-string nil
"String used to indicate an incorrect word starting."
- :group 'flyspell
:type '(choice string (const nil)))
(defcustom flyspell-after-incorrect-word-string nil
"String used to indicate an incorrect word ending."
- :group 'flyspell
:type '(choice string (const nil)))
(defvar flyspell-mode-map)
(defcustom flyspell-use-meta-tab t
"Non-nil means that flyspell uses M-TAB to correct word."
- :group 'flyspell
:type 'boolean
:initialize 'custom-initialize-default
:set (lambda (sym val)
@@ -316,8 +287,7 @@ If this variable is nil, all regions are treated as small."
(defcustom flyspell-auto-correct-binding
[(control ?\;)]
"The key binding for flyspell auto correction."
- :type 'key-sequence
- :group 'flyspell)
+ :type 'key-sequence)
;;*---------------------------------------------------------------------*/
;;* Mode specific options */
@@ -334,12 +304,11 @@ If this variable is nil, all regions are treated as small."
(define-obsolete-variable-alias 'flyspell-generic-check-word-p
'flyspell-generic-check-word-predicate "25.1")
-(defvar flyspell-generic-check-word-predicate nil
+(defvar-local flyspell-generic-check-word-predicate nil
"Function providing per-mode customization over which words are flyspelled.
Returns t to continue checking, nil otherwise.
Flyspell mode sets this variable to whatever is the `flyspell-mode-predicate'
property of the major mode name.")
-(make-variable-buffer-local 'flyspell-generic-check-word-predicate)
;;*--- mail mode -------------------------------------------------------*/
(put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify)
@@ -417,9 +386,13 @@ like <img alt=\"Some thing.\">."
;;*---------------------------------------------------------------------*/
;;* Programming mode */
;;*---------------------------------------------------------------------*/
-(defvar flyspell-prog-text-faces
+(defcustom flyspell-prog-text-faces
'(font-lock-string-face font-lock-comment-face font-lock-doc-face)
- "Faces corresponding to text in programming-mode buffers.")
+ "Faces corresponding to text in programming-mode buffers."
+ :type '(set (const font-lock-string-face)
+ (const font-lock-comment-face)
+ (const font-lock-doc-face))
+ :version "28.1")
(defun flyspell-generic-progmode-verify ()
"Used for `flyspell-generic-check-word-predicate' in programming modes."
@@ -428,18 +401,12 @@ like <img alt=\"Some thing.\">."
(let ((f (get-text-property (1- (point)) 'face)))
(memq f flyspell-prog-text-faces))))
-;; Records the binding of M-TAB in effect before flyspell was activated.
-(defvar flyspell--prev-meta-tab-binding)
-
;;;###autoload
(defun flyspell-prog-mode ()
"Turn on `flyspell-mode' for comments and strings."
(interactive)
(setq flyspell-generic-check-word-predicate
#'flyspell-generic-progmode-verify)
- (setq-local flyspell--prev-meta-tab-binding
- (or (local-key-binding "\M-\t" t)
- (global-key-binding "\M-\t" t)))
(flyspell-mode 1)
(run-hooks 'flyspell-prog-mode-hook))
@@ -475,14 +442,27 @@ like <img alt=\"Some thing.\">."
map)
"Minor mode keymap for Flyspell mode--for the whole buffer.")
+;; correct on mouse 3
+(defun flyspell--set-use-mouse-3-for-menu (var value)
+ (set-default var value)
+ (if value
+ (progn (define-key flyspell-mouse-map [mouse-2] nil)
+ (define-key flyspell-mouse-map [down-mouse-3] 'flyspell-correct-word))
+ (define-key flyspell-mouse-map [mouse-2] 'flyspell-correct-word)
+ (define-key flyspell-mouse-map [down-mouse-3] nil)))
+
+(defcustom flyspell-use-mouse-3-for-menu nil
+ "Non-nil means to bind `mouse-3' to `flyspell-correct-word'.
+If this is set, also unbind `mouse-2'."
+ :type 'boolean
+ :set 'flyspell--set-use-mouse-3-for-menu
+ :version "28.1")
+
;; dash character machinery
-(defvar flyspell-consider-dash-as-word-delimiter-flag nil
+(defvar-local flyspell-consider-dash-as-word-delimiter-flag nil
"Non-nil means that the `-' char is considered as a word delimiter.")
-(make-variable-buffer-local 'flyspell-consider-dash-as-word-delimiter-flag)
-(defvar flyspell-dash-dictionary nil)
-(make-variable-buffer-local 'flyspell-dash-dictionary)
-(defvar flyspell-dash-local-dictionary nil)
-(make-variable-buffer-local 'flyspell-dash-local-dictionary)
+(defvar-local flyspell-dash-dictionary nil)
+(defvar-local flyspell-dash-local-dictionary nil)
;;*---------------------------------------------------------------------*/
;;* Highlighting */
@@ -493,8 +473,7 @@ like <img alt=\"Some thing.\">."
(t
:underline t :inherit error))
"Flyspell face for misspelled words."
- :version "24.4"
- :group 'flyspell)
+ :version "24.4")
(defface flyspell-duplicate
'((((supports :underline (:style wave)))
@@ -503,8 +482,7 @@ like <img alt=\"Some thing.\">."
:underline t :inherit warning))
"Flyspell face for words that appear twice in a row.
See also `flyspell-duplicate-distance'."
- :version "24.4"
- :group 'flyspell)
+ :version "24.4")
(defvar flyspell-overlay nil)
@@ -536,17 +514,33 @@ invoking `ispell-change-dictionary'.
Consider using the `ispell-parser' to check your text. For instance
consider adding:
-\(add-hook \\='tex-mode-hook (function (lambda () (setq ispell-parser \\='tex))))
+\(add-hook \\='tex-mode-hook (lambda () (setq ispell-parser \\='tex)))
in your init file.
\\[flyspell-region] checks all words inside a region.
\\[flyspell-buffer] checks the whole buffer."
- :lighter flyspell-mode-line-string
+ :lighter (flyspell-mode-line-string
+ ;; If `flyspell-mode-line-string' is nil, then nothing of
+ ;; the following is displayed in the mode line.
+ ((:propertize flyspell-mode-line-string)
+ (:propertize
+ (:eval
+ (concat "/" (substring (or ispell-local-dictionary
+ ispell-dictionary
+ "--")
+ 0 2)))
+ help-echo "mouse-1: Change dictionary"
+ local-map (keymap
+ (mode-line keymap
+ (mouse-1 . ispell-change-dictionary))))))
:keymap flyspell-mode-map
:group 'flyspell
(if flyspell-mode
(condition-case err
- (flyspell-mode-on)
+ (progn
+ (when flyspell-use-mouse-3-for-menu
+ (flyspell--set-use-mouse-3-for-menu 'flyspell-use-mouse-3-for-menu t))
+ (flyspell-mode-on (called-interactively-p 'interactive)))
(error (message "Error enabling Flyspell mode:\n%s" (cdr err))
(flyspell-mode -1)))
(flyspell-mode-off)))
@@ -563,12 +557,9 @@ in your init file.
(custom-add-option 'text-mode-hook 'turn-on-flyspell)
-;;*---------------------------------------------------------------------*/
-;;* flyspell-buffers ... */
-;;* ------------------------------------------------------------- */
-;;* For remembering buffers running flyspell */
-;;*---------------------------------------------------------------------*/
-(defvar flyspell-buffers nil)
+(defvar flyspell-buffers nil
+ "For remembering buffers running flyspell")
+(make-obsolete-variable 'flyspell-buffers "not used." "28.1")
;;*---------------------------------------------------------------------*/
;;* flyspell-minibuffer-p ... */
@@ -624,8 +615,12 @@ in your init file.
;;*---------------------------------------------------------------------*/
;;* flyspell-mode-on ... */
;;*---------------------------------------------------------------------*/
-(defun flyspell-mode-on ()
- "Turn Flyspell mode on. Do not use this; use `flyspell-mode' instead."
+(defun flyspell-mode-on (&optional show-msg)
+ "Turn Flyspell mode on. Do not use this; use `flyspell-mode' instead.
+
+If optional argument SHOW-MSG is non-nil, show a welcome message
+if `flyspell-issue-message-flag' and `flyspell-issue-welcome-flag'
+are both non-nil."
(ispell-set-spellchecker-params) ; Initialize variables and dicts alists
(setq ispell-highlight-face 'flyspell-incorrect)
;; local dictionaries setup
@@ -657,15 +652,17 @@ in your init file.
(setq flyspell-generic-check-word-predicate mode-predicate)))
;; the welcome message
(if (and flyspell-issue-message-flag
- flyspell-issue-welcome-flag
- (called-interactively-p 'interactive))
- (let ((binding (where-is-internal 'flyspell-auto-correct-word
- nil 'non-ascii)))
- (message "%s"
- (if binding
- (format "Welcome to flyspell. Use %s or Mouse-2 to correct words."
- (key-description binding))
- "Welcome to flyspell. Use Mouse-2 to correct words.")))))
+ flyspell-issue-welcome-flag
+ show-msg)
+ (let* ((binding (where-is-internal 'flyspell-auto-correct-word
+ nil 'non-ascii))
+ (mouse-button (if flyspell-use-mouse-3-for-menu
+ "Mouse-3" "Mouse-2")))
+ (message (format-message
+ "Welcome to Flyspell. Use %s to correct words."
+ (if binding
+ (format "`%s' or `%s'" (key-description binding) mouse-button)
+ (format "`%s'" mouse-button)))))))
;;*---------------------------------------------------------------------*/
;;* flyspell-delay-commands ... */
@@ -707,14 +704,10 @@ has been used, the current word is not checked."
;;*---------------------------------------------------------------------*/
;;* flyspell-word-cache ... */
;;*---------------------------------------------------------------------*/
-(defvar flyspell-word-cache-start nil)
-(defvar flyspell-word-cache-end nil)
-(defvar flyspell-word-cache-word nil)
-(defvar flyspell-word-cache-result '_)
-(make-variable-buffer-local 'flyspell-word-cache-start)
-(make-variable-buffer-local 'flyspell-word-cache-end)
-(make-variable-buffer-local 'flyspell-word-cache-word)
-(make-variable-buffer-local 'flyspell-word-cache-result)
+(defvar-local flyspell-word-cache-start nil)
+(defvar-local flyspell-word-cache-end nil)
+(defvar-local flyspell-word-cache-word nil)
+(defvar-local flyspell-word-cache-result '_)
;;*---------------------------------------------------------------------*/
;;* The flyspell pre-hook, store the current position. In the */
@@ -820,8 +813,7 @@ before the current command."
;;* the post command hook, we will check, if the word at this */
;;* position has to be spell checked. */
;;*---------------------------------------------------------------------*/
-(defvar flyspell-changes nil)
-(make-variable-buffer-local 'flyspell-changes)
+(defvar-local flyspell-changes nil)
;;*---------------------------------------------------------------------*/
;;* flyspell-after-change-function ... */
@@ -1265,14 +1257,27 @@ spell-check."
(t
(setq flyspell-word-cache-result nil)
;; Highlight the location as incorrect,
- ;; including offset specified in POSS.
+ ;; including offset specified in POSS
+ ;; and only for the length of the
+ ;; misspelled word specified by POSS.
(if flyspell-highlight-flag
- (flyspell-highlight-incorrect-region
- (if (and (consp poss)
- (integerp (nth 1 poss)))
- (+ start (nth 1 poss) -1)
- start)
- end poss)
+ (let ((hstart start)
+ (hend end)
+ offset misspelled)
+ (when (consp poss)
+ (setq misspelled (car poss)
+ offset (nth 1 poss))
+ (if (integerp offset)
+ (setq hstart (+ start offset -1)))
+ ;; POSS includes the misspelled
+ ;; word; use that to figure out
+ ;; how many characters to highlight.
+ (if (stringp misspelled)
+ (setq hend
+ (+ hstart
+ (length misspelled)))))
+ (flyspell-highlight-incorrect-region
+ hstart hend poss))
(flyspell-notify-misspell word poss))
nil))))
;; return to original location
@@ -1815,7 +1820,9 @@ for the overlay."
(overlay-put overlay 'mouse-face mouse-face)
(overlay-put overlay 'flyspell-overlay t)
(overlay-put overlay 'evaporate t)
- (overlay-put overlay 'help-echo "mouse-2: correct word at point")
+ (overlay-put overlay 'help-echo (concat (if flyspell-use-mouse-3-for-menu
+ "mouse-3"
+ "mouse-2") ": correct word at point"))
;; If misspelled text has a 'keymap' property, let that remain in
;; effect for the bindings that flyspell-mouse-map doesn't override.
(set-keymap-parent flyspell-mouse-map (get-char-property beg 'keymap))
@@ -1885,14 +1892,10 @@ as returned by `ispell-parse-output'."
;;*---------------------------------------------------------------------*/
;;* flyspell-auto-correct-cache ... */
;;*---------------------------------------------------------------------*/
-(defvar flyspell-auto-correct-pos nil)
-(defvar flyspell-auto-correct-region nil)
-(defvar flyspell-auto-correct-ring nil)
-(defvar flyspell-auto-correct-word nil)
-(make-variable-buffer-local 'flyspell-auto-correct-pos)
-(make-variable-buffer-local 'flyspell-auto-correct-region)
-(make-variable-buffer-local 'flyspell-auto-correct-ring)
-(make-variable-buffer-local 'flyspell-auto-correct-word)
+(defvar-local flyspell-auto-correct-pos nil)
+(defvar-local flyspell-auto-correct-region nil)
+(defvar-local flyspell-auto-correct-ring nil)
+(defvar-local flyspell-auto-correct-word nil)
;;*---------------------------------------------------------------------*/
;;* flyspell-check-previous-highlighted-word ... */
@@ -1912,7 +1915,7 @@ before point that's highlighted as misspelled."
(while (and (setq pos (previous-overlay-change pos))
(not (= pos pos1)))
(setq pos1 pos)
- (if (> pos (point-min))
+ (if (>= pos (point-min))
(progn
(setq ovs (overlays-at pos))
(while (consp ovs)
@@ -1981,15 +1984,14 @@ spell-check."
(interactive)
;; If we are not in the construct where flyspell should be active,
;; invoke the original binding of M-TAB, if that was recorded.
- (if (and (local-variable-p 'flyspell--prev-meta-tab-binding)
- (commandp flyspell--prev-meta-tab-binding t)
- (functionp flyspell-generic-check-word-predicate)
- (not (funcall flyspell-generic-check-word-predicate))
- (equal (where-is-internal 'flyspell-auto-correct-word nil t)
- [?\M-\t]))
- (call-interactively flyspell--prev-meta-tab-binding)
- (let ((pos (point))
- (old-max (point-max)))
+ (let ((pos (point))
+ (old-max (point-max))
+ (next-cmd (and (functionp flyspell-generic-check-word-predicate)
+ (not (funcall flyspell-generic-check-word-predicate))
+ (let ((flyspell-mode nil))
+ (key-binding (this-command-keys))))))
+ (if next-cmd
+ (command-execute next-cmd)
;; Flush a possibly stale cache from previous invocations of
;; flyspell-auto-correct-word/flyspell-auto-correct-previous-word.
(if (not (memq last-command '(flyspell-auto-correct-word
@@ -2297,8 +2299,8 @@ If OPOINT is non-nil, restore point there after adjusting it for replacement."
corrects)
'()))
(affix (car (cdr (cdr (cdr poss)))))
- show-affix-info
- (base-menu (let ((save (if (and (consp affix) show-affix-info)
+ ;; show-affix-info
+ (base-menu (let ((save (if nil ;; (and (consp affix) show-affix-info)
(list
(list (concat "Save affix: " (car affix))
'save)
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index d458dd93c8f..4c64531ea35 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -44,6 +44,7 @@
;; ispell-buffer
;; ispell-message
;; ispell-comments-and-strings
+;; ispell-comment-or-string-at-point
;; ispell-continue
;; ispell-complete-word
;; ispell-complete-word-interior-frag
@@ -130,8 +131,7 @@
(defcustom ispell-highlight-p 'block
"Highlight spelling errors when non-nil.
When set to `block', assumes a block cursor with TTY displays."
- :type '(choice (const block) (const :tag "off" nil) (const :tag "on" t))
- :group 'ispell)
+ :type '(choice (const block) (const :tag "off" nil) (const :tag "on" t)))
(defcustom ispell-lazy-highlight (boundp 'lazy-highlight-cleanup)
"Controls the lazy-highlighting of spelling errors.
@@ -140,7 +140,6 @@ error is highlighted lazily using isearch lazy highlighting (see
`lazy-highlight-initial-delay' and `lazy-highlight-interval')."
:type 'boolean
:group 'lazy-highlight
- :group 'ispell
:version "22.1")
(defcustom ispell-highlight-face (if ispell-lazy-highlight 'isearch 'highlight)
@@ -148,16 +147,14 @@ error is highlighted lazily using isearch lazy highlighting (see
This variable can be set by the user to whatever face they desire.
It's most convenient if the cursor color and highlight color are
slightly different."
- :type 'face
- :group 'ispell)
+ :type 'face)
(defcustom ispell-check-comments t
"Spelling of comments checked when non-nil.
When set to `exclusive', ONLY comments are checked. (For code comments).
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)
+ :type '(choice (const exclusive) (const :tag "off" nil) (const :tag "on" t)))
;;;###autoload
(put 'ispell-check-comments 'safe-local-variable
(lambda (a) (memq a '(nil t exclusive))))
@@ -165,8 +162,7 @@ may produce undesired results."
(defcustom ispell-query-replace-choices nil
"Corrections made throughout region when non-nil.
Uses `query-replace' (\\[query-replace]) for corrections."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-skip-tib nil
"Does not spell check `tib' bibliography references when non-nil.
@@ -176,8 +172,7 @@ Skips any text between strings matching regular expressions
TeX users beware: Any text between [. and .] will be skipped -- even if
that's your whole buffer -- unless you set `ispell-skip-tib' to nil.
That includes the [.5mm] type of number..."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defvar ispell-tib-ref-beginning "[[<]\\."
"Regexp matching the beginning of a Tib reference.")
@@ -188,31 +183,27 @@ That includes the [.5mm] type of number..."
(defcustom ispell-keep-choices-win t
"If non-nil, keep the `*Choices*' window for the entire spelling session.
This minimizes redisplay thrashing."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-choices-win-default-height 2
"The default size of the `*Choices*' window, including the mode line.
Must be greater than 1."
- :type 'integer
- :group 'ispell)
+ :type 'integer)
-;; XXX Add enchant to this list once enchant >= 2.1.0 is widespread.
-;; Before that, adding it is useless, as if it is found, it will just
-;; cause an error; and one of the other spelling engines below is
-;; almost certainly installed in any case, for enchant to use.
(defcustom ispell-program-name
(or (executable-find "aspell")
(executable-find "ispell")
(executable-find "hunspell")
+ ;; Enchant is commonly installed as `enchant-2', so use this
+ ;; name and avoid old versions of `enchant'.
+ (executable-find "enchant-2")
"ispell")
"Program invoked by \\[ispell-word] and \\[ispell-region] commands."
:type 'string
:set (lambda (symbol value)
(set-default symbol value)
(if (featurep 'ispell)
- (ispell-set-spellchecker-params)))
- :group 'ispell)
+ (ispell-set-spellchecker-params))))
(defcustom ispell-alternate-dictionary
(cond ((file-readable-p "/usr/dict/web2") "/usr/dict/web2")
@@ -224,14 +215,12 @@ Must be greater than 1."
"/usr/share/lib/dict/words")
((file-readable-p "/sys/dict") "/sys/dict"))
"Alternate plain word-list dictionary for spelling help."
- :type '(choice file (const :tag "None" nil))
- :group 'ispell)
+ :type '(choice file (const :tag "None" nil)))
(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)
+ :type '(choice file (const :tag "None" nil)))
(defcustom ispell-message-dictionary-alist nil
"List used by `ispell-message' to select a new dictionary.
@@ -241,29 +230,25 @@ DICTIONARY if `ispell-local-dictionary' is not buffer-local.
E.g. you may use the following value:
((\"^Newsgroups:[ \\t]*de\\\\.\" . \"deutsch8\")
(\"^To:[^\\n,]+\\\\.de[ \\t\\n,>]\" . \"deutsch8\"))"
- :type '(repeat (cons regexp string))
- :group 'ispell)
+ :type '(repeat (cons regexp string)))
(defcustom ispell-message-fcc-skip 50000
"Query before saving Fcc message copy if attachment larger than this value.
Always stores Fcc copy of message when nil."
- :type '(choice integer (const :tag "off" nil))
- :group 'ispell)
+ :type '(choice integer (const :tag "off" nil)))
(defcustom ispell-grep-command
"grep"
"Name of the grep command for search processes."
- :type 'string
- :group 'ispell)
+ :type 'string)
(defcustom ispell-grep-options
"-Ei"
"String of options to use when running the program in `ispell-grep-command'.
Should probably be \"-Ei\"."
- :type 'string
- :group 'ispell)
+ :type 'string)
(defcustom ispell-look-command
(cond ((file-exists-p "/bin/look") "/bin/look")
@@ -272,36 +257,30 @@ Should probably be \"-Ei\"."
(t "look"))
"Name of the look command for search processes.
This must be an absolute file name."
- :type 'file
- :group 'ispell)
+ :type 'file)
(defcustom ispell-look-p (file-exists-p ispell-look-command)
"Non-nil means use `look' rather than `grep'.
Default is based on whether `look' seems to be available."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-have-new-look nil
"Non-nil means use the `-r' option (regexp) when running `look'."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-look-options (if ispell-have-new-look "-dfr" "-df")
"String of command options for `ispell-look-command'."
- :type 'string
- :group 'ispell)
+ :type 'string)
(defcustom ispell-use-ptys-p nil
"When non-nil, Emacs uses ptys to communicate with Ispell.
When nil, Emacs uses pipes."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-following-word nil
"Non-nil means `ispell-word' checks the word around or after point.
Otherwise `ispell-word' checks the preceding word."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defcustom ispell-help-in-bufferp nil
"Non-nil means display interactive keymap help in a buffer.
@@ -312,48 +291,41 @@ The following values are supported:
for a couple of seconds.
electric Pop up a new buffer and display a long help message there.
User can browse and then exit the help mode."
- :type '(choice (const electric) (const :tag "off" nil) (const :tag "on" t))
- :group 'ispell)
+ :type '(choice (const electric) (const :tag "off" nil) (const :tag "on" t)))
(defcustom ispell-quietly nil
"Non-nil means suppress messages in `ispell-word'."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
(defvaralias 'ispell-format-word 'ispell-format-word-function)
(defcustom ispell-format-word-function (function upcase)
"Formatting function for displaying word being spell checked.
The function must take one string argument and return a string."
- :type 'function
- :group 'ispell)
+ :type 'function)
;; FIXME framepop.el last updated c 2003 (?),
-;; probably something else replaces it these days.
+;; use posframe.
(defcustom ispell-use-framepop-p nil
"When non-nil ispell uses framepop to display choices in a dedicated frame.
You can set this variable to dynamically use framepop if you are in a
window system by evaluating the following on startup to set this variable:
(and (display-graphic-p) (require \\='framepop nil t))"
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
;;;###autoload
(defcustom ispell-personal-dictionary nil
"File name of your personal spelling dictionary, or nil.
If nil, the default personal dictionary for your spelling checker is used."
:type '(choice file
- (const :tag "default" nil))
- :group 'ispell)
+ (const :tag "default" nil)))
(defcustom ispell-silently-savep nil
"When non-nil, save personal dictionary without asking for confirmation."
- :type 'boolean
- :group 'ispell)
+ :type 'boolean)
-(defvar ispell-local-dictionary-overridden nil
+(defvar-local ispell-local-dictionary-overridden nil
"Non-nil means the user has explicitly set this buffer's Ispell dictionary.")
-(make-variable-buffer-local 'ispell-local-dictionary-overridden)
(defcustom ispell-local-dictionary nil
"If non-nil, the dictionary to be used for Ispell commands in this buffer.
@@ -367,8 +339,7 @@ calling \\[ispell-change-dictionary] with that value. This variable
is automatically set when defined in the file with either
`ispell-dictionary-keyword' or the Local Variable syntax."
:type '(choice string
- (const :tag "default" nil))
- :group 'ispell)
+ (const :tag "default" nil)))
;;;###autoload
(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p)
@@ -377,16 +348,14 @@ is automatically set when defined in the file with either
(defcustom ispell-dictionary nil
"Default dictionary to use if `ispell-local-dictionary' is nil."
:type '(choice string
- (const :tag "default" nil))
- :group 'ispell)
+ (const :tag "default" nil)))
(defcustom ispell-extra-args nil
"If non-nil, a list of extra switches to pass to the Ispell program.
For example, (\"-W\" \"3\") to cause it to accept all 1-3 character
words as correct. See also `ispell-dictionary-alist', which may be used
for language-specific arguments."
- :type '(repeat string)
- :group 'ispell)
+ :type '(repeat string))
@@ -401,8 +370,7 @@ such as \"&amp;\". See `ispell-html-skip-alists' for more details.
This variable affects spell-checking of HTML, XML, and SGML files."
:type '(choice (const :tag "always" t) (const :tag "never" nil)
- (const :tag "use-mode-name" use-mode-name))
- :group 'ispell)
+ (const :tag "use-mode-name" use-mode-name)))
(make-variable-buffer-local 'ispell-skip-html)
@@ -428,8 +396,7 @@ re-start Emacs."
(const "~nroff") (const "~list")
(const "~latin1") (const "~latin3")
(const :tag "default" nil))
- (coding-system :tag "Coding System")))
- :group 'ispell)
+ (coding-system :tag "Coding System"))))
(defvar ispell-dictionary-base-alist
@@ -621,15 +588,6 @@ For Aspell, non-nil also means to try to automatically find its dictionaries.
Earlier Aspell versions do not consistently support charset encoding. Handling
this would require some extra guessing in `ispell-aspell-find-dictionary'.")
-(defvar ispell-aspell-supports-utf8 nil
- "Non-nil if Aspell has consistent command line UTF-8 support. Obsolete.
-ispell.el and flyspell.el will use for this purpose the more generic
-variable `ispell-encoding8-command' for both Aspell and Hunspell. Is left
-here just for backwards compatibility.")
-
-(make-obsolete-variable 'ispell-aspell-supports-utf8
- 'ispell-encoding8-command "23.1")
-
(defvar ispell-dicts-name2locale-equivs-alist
'(("american" "en_US")
("brasileiro" "pt_BR")
@@ -682,9 +640,7 @@ Otherwise returns the library directory name, if that is defined."
;; all versions, since versions earlier than 3.0.09 didn't identify
;; themselves on startup.
(interactive "p")
- (let ((default-directory (or (and (boundp 'temporary-file-directory)
- temporary-file-directory)
- default-directory))
+ (let ((default-directory (or temporary-file-directory default-directory))
(get-config-var
(lambda (var)
(when (re-search-forward
@@ -693,15 +649,7 @@ Otherwise returns the library directory name, if that is defined."
result libvar status ispell-program-version)
(with-temp-buffer
- (setq status (ispell-call-process
- ispell-program-name nil t nil
- ;; aspell doesn't accept the -vv switch.
- (let ((case-fold-search
- (memq system-type '(ms-dos windows-nt)))
- (speller
- (file-name-nondirectory ispell-program-name)))
- ;; Assume anything that isn't `aspell' is Ispell.
- (if (string-match "\\`aspell" speller) "-v" "-vv"))))
+ (setq status (ispell-call-process ispell-program-name nil t nil "-vv"))
(goto-char (point-min))
(if interactivep
;; Report version information of ispell
@@ -782,18 +730,23 @@ Otherwise returns the library directory name, if that is defined."
(setq ispell-really-hunspell nil))))))
result))
+(defmacro ispell-with-safe-default-directory (&rest body)
+ "Execute the forms in BODY with a reasonable
+`default-directory'."
+ (declare (indent 0) (debug t))
+ `(let ((default-directory default-directory))
+ (unless (file-accessible-directory-p default-directory)
+ (setq default-directory (expand-file-name "~/")))
+ ,@body))
+
(defun ispell-call-process (&rest args)
- "Like `call-process' but defend against bad `default-directory'."
- (let ((default-directory default-directory))
- (unless (file-accessible-directory-p default-directory)
- (setq default-directory (expand-file-name "~/")))
+ "Like `call-process', but defend against bad `default-directory'."
+ (ispell-with-safe-default-directory
(apply 'call-process args)))
(defun ispell-call-process-region (&rest args)
- "Like `call-process-region' but defend against bad `default-directory'."
- (let ((default-directory default-directory))
- (unless (file-accessible-directory-p default-directory)
- (setq default-directory (expand-file-name "~/")))
+ "Like `call-process-region', but defend against bad `default-directory'."
+ (ispell-with-safe-default-directory
(apply 'call-process-region args)))
(defvar ispell-debug-buffer)
@@ -1106,28 +1059,38 @@ to dictionaries found, and will remove aliases from the list
in `ispell-dicts-name2locale-equivs-alist' if an explicit
dictionary from that list was found."
(let ((hunspell-found-dicts
- (split-string
- (with-temp-buffer
- (ispell-call-process ispell-program-name
- null-device
- t
- nil
- "-D"
- ;; Use -a to prevent Hunspell from
- ;; trying to initialize its
- ;; curses/termcap UI, which causes it
- ;; to crash or fail to start in some
- ;; MS-Windows ports.
- "-a"
- ;; Hunspell 1.7.0 (and later?) won't
- ;; show LOADED DICTIONARY unless
- ;; there's at least one file argument
- ;; on the command line. So we feed
- ;; it with the null device.
- null-device)
- (buffer-string))
- "[\n\r]+"
- t))
+ (seq-filter
+ (lambda (str)
+ (when (string-match
+ ;; Hunspell gives this error when there is some
+ ;; installation problem, for example if $LANG is unset.
+ (concat "^Can't open affix or dictionary files "
+ "for dictionary named \"default\".$")
+ str)
+ (user-error "Hunspell error (is $LANG unset?): %s" str))
+ (file-name-absolute-p str))
+ (split-string
+ (with-temp-buffer
+ (ispell-call-process ispell-program-name
+ nil
+ t
+ nil
+ "-D"
+ ;; Use -a to prevent Hunspell from
+ ;; trying to initialize its
+ ;; curses/termcap UI, which causes it
+ ;; to crash or fail to start in some
+ ;; MS-Windows ports.
+ "-a"
+ ;; Hunspell 1.7.0 (and later?) won't
+ ;; show LOADED DICTIONARY unless
+ ;; there's at least one file argument
+ ;; on the command line. So we feed
+ ;; it with the null device.
+ null-device)
+ (buffer-string))
+ "[\n\r]+"
+ t)))
hunspell-default-dict
hunspell-default-dict-entry
hunspell-multi-dict)
@@ -1217,13 +1180,14 @@ Internal use.")
(defun ispell--call-enchant-lsmod (&rest args)
"Call enchant-lsmod with ARGS and return the output as string."
(with-output-to-string
- (with-current-buffer
- standard-output
+ (with-current-buffer standard-output
(apply #'ispell-call-process
(replace-regexp-in-string "enchant\\(-[0-9]\\)?\\'"
"enchant-lsmod\\1"
ispell-program-name)
- nil t nil args))))
+ ;; We discard stderr here because enchant-lsmod can emit
+ ;; unrelated warnings that will confuse us.
+ nil '(t nil) nil args))))
(defun ispell--get-extra-word-characters (&optional lang)
"Get the extra word characters for LANG as a character class.
@@ -1237,24 +1201,13 @@ If LANG is omitted, get the extra word characters for the default language."
"Find Enchant's dictionaries, and record in `ispell-enchant-dictionary-alist'."
(let* ((dictionaries
(split-string
- (ispell--call-enchant-lsmod "-list-dicts" (buffer-string)) " ([^)]+)\n"))
+ (ispell--call-enchant-lsmod "-list-dicts") " ([^)]+)\n" t))
(found
- (mapcar #'(lambda (lang)
- `(,lang "[[:alpha:]]" "[^[:alpha:]]"
- ,(ispell--get-extra-word-characters) t nil nil utf-8))
+ (mapcar (lambda (lang)
+ `(,lang "[[:alpha:]]" "[^[:alpha:]]"
+ ,(ispell--get-extra-word-characters lang) t nil nil utf-8))
dictionaries)))
- ;; Merge into FOUND any elements from the standard ispell-dictionary-base-alist
- ;; which have no element in FOUND at all.
- (dolist (dict ispell-dictionary-base-alist)
- (unless (assoc (car dict) found)
- (setq found (nconc found (list dict)))))
- (setq ispell-enchant-dictionary-alist found)
- ;; Add a default entry
- (let ((default-dict
- `(nil "[[:alpha:]]" "[^[:alpha:]]"
- ,(ispell--get-extra-word-characters)
- t nil nil utf-8)))
- (push default-dict ispell-enchant-dictionary-alist))))
+ (setq ispell-enchant-dictionary-alist found)))
;; Set params according to the selected spellchecker
@@ -1277,7 +1230,7 @@ aspell is used along with Emacs).")
(defun ispell-set-spellchecker-params ()
"Initialize some spellchecker parameters when changed or first used."
- (unless (eq ispell-last-program-name ispell-program-name)
+ (unless (equal ispell-last-program-name ispell-program-name)
(ispell-kill-ispell t)
(if (and (condition-case ()
(progn
@@ -1747,7 +1700,7 @@ Note - substrings of other matches must come last
(e.g. \"<[tT][tT]/\" and \"<[^ \\t\\n>]\").")
(put 'ispell-html-skip-alists 'risky-local-variable t)
-(defvar ispell-local-pdict ispell-personal-dictionary
+(defvar-local ispell-local-pdict ispell-personal-dictionary
"A buffer local variable containing the current personal dictionary.
If non-nil, the value must be a string, which is a file name.
@@ -1757,18 +1710,15 @@ to calling \\[ispell-change-dictionary]. This variable is automatically
set when defined in the file with either `ispell-pdict-keyword' or the
local variable syntax.")
-(make-variable-buffer-local 'ispell-local-pdict)
;;;###autoload(put 'ispell-local-pdict 'safe-local-variable 'stringp)
(defvar ispell-buffer-local-name nil
"Contains the buffer name if local word definitions were used.
Ispell is then restarted because the local words could conflict.")
-(defvar ispell-buffer-session-localwords nil
+(defvar-local ispell-buffer-session-localwords nil
"List of words accepted for session in this buffer.")
-(make-variable-buffer-local 'ispell-buffer-session-localwords)
-
(defvar ispell-parser 'use-mode-name
"Indicates whether ispell should parse the current buffer as TeX Code.
Special value `use-mode-name' tries to guess using the name of `major-mode'.
@@ -1800,10 +1750,12 @@ You can set this variable in hooks in your init file -- eg:
If asynchronous subprocesses are not supported, call function `ispell-filter'
and pass it the output of the last Ispell invocation."
(if ispell-async-processp
- (let ((timeout (if timeout-msecs
- (+ (or timeout-secs 0) (/ timeout-msecs 1000.0))
- timeout-secs)))
- (accept-process-output ispell-process timeout))
+ (if (process-live-p ispell-process)
+ (let ((timeout (if timeout-msecs
+ (+ (or timeout-secs 0) (/ timeout-msecs 1000.0))
+ timeout-secs)))
+ (accept-process-output ispell-process timeout))
+ (error "No Ispell process to read output from!"))
(if (null ispell-process)
(error "No Ispell process to read output from!")
(let ((buf ispell-output-buffer)
@@ -1828,7 +1780,8 @@ Only works for Aspell and Enchant."
(defun ispell-send-string (string)
"Send the string STRING to the Ispell process."
(if ispell-async-processp
- (process-send-string ispell-process string)
+ (if (process-live-p ispell-process)
+ (process-send-string ispell-process string))
;; Asynchronous subprocesses aren't supported on this losing system.
;; We keep all the directives passed to Ispell during the entire
;; session in a buffer, and pass them anew each time we invoke
@@ -2463,14 +2416,14 @@ SPC: Accept word this time.
(progn
(require 'ehelp)
(with-electric-help
- (function (lambda ()
- ;;This shouldn't be necessary: with-electric-help needs
- ;; an optional argument telling it about the smallest
- ;; acceptable window-height of the help buffer.
- ;;(if (< (window-height) 15)
- ;; (enlarge-window
- ;; (- 15 (ispell-adjusted-window-height))))
- (princ "Selections are:
+ (lambda ()
+ ;;This shouldn't be necessary: with-electric-help needs
+ ;; an optional argument telling it about the smallest
+ ;; acceptable window-height of the help buffer.
+ ;;(if (< (window-height) 15)
+ ;; (enlarge-window
+ ;; (- 15 (ispell-adjusted-window-height))))
+ (princ "Selections are:
DIGIT: Replace the word with a digit offered in the *Choices* buffer.
SPC: Accept word this time.
@@ -2490,7 +2443,7 @@ SPC: Accept word this time.
`C-l': Redraw screen.
`C-r': Recursive edit.
`C-z': Suspend Emacs or iconify frame.")
- nil))))
+ nil)))
(let ((help-1 (concat "[r/R]eplace word; [a/A]ccept for this session; "
@@ -3273,15 +3226,15 @@ otherwise, the current line is skipped."
Generated from `ispell-tex-skip-alists'."
(concat
;; raw tex keys
- (mapconcat (function (lambda (lst) (car lst)))
+ (mapconcat (lambda (lst) (car lst))
(car ispell-tex-skip-alists)
"\\|")
"\\|"
;; keys wrapped in begin{}
- (mapconcat (function (lambda (lst)
- (concat "\\\\begin[ \t\n]*{[ \t\n]*"
- (car lst)
- "[ \t\n]*}")))
+ (mapconcat (lambda (lst)
+ (concat "\\\\begin[ \t\n]*{[ \t\n]*"
+ (car lst)
+ "[ \t\n]*}"))
(car (cdr ispell-tex-skip-alists))
"\\|")))
@@ -3591,24 +3544,40 @@ Returns the sum SHIFT due to changes in word replacements."
;;;###autoload
-(defun ispell-comments-and-strings ()
- "Check comments and strings in the current buffer for spelling errors."
- (interactive)
- (goto-char (point-min))
+(defun ispell-comments-and-strings (&optional start end)
+ "Check comments and strings in the current buffer for spelling errors.
+If called interactively with an active region, check only comments and
+strings in the region.
+When called from Lisp, START and END buffer positions can be provided
+to limit the check."
+ (interactive (when (use-region-p) (list (region-beginning) (region-end))))
+ (unless end (setq end (point-max)))
+ (goto-char (or start (point-min)))
(let (state done)
(while (not done)
(setq done t)
- (setq state (parse-partial-sexp (point) (point-max)
- nil nil state 'syntax-table))
+ (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
(if (or (nth 3 state) (nth 4 state))
(let ((start (point)))
- (setq state (parse-partial-sexp start (point-max)
+ (setq state (parse-partial-sexp start end
nil nil state 'syntax-table))
(if (or (nth 3 state) (nth 4 state))
(error "Unterminated string or comment"))
(save-excursion
(setq done (not (ispell-region start (point))))))))))
+;;;###autoload
+(defun ispell-comment-or-string-at-point ()
+ "Check the comment or string containing point for spelling errors."
+ (interactive)
+ (save-excursion
+ (let ((state (syntax-ppss)))
+ (if (or (nth 3 state) (nth 4 state))
+ (ispell-region (nth 8 state)
+ (progn (parse-partial-sexp (point) (point-max)
+ nil nil state 'syntax-table)
+ (point)))
+ (user-error "Not inside a string or comment")))))
;;;###autoload
(defun ispell-buffer ()
@@ -3687,11 +3656,10 @@ Standard ispell choices are then available."
((string-equal (upcase word) word)
(setq possibilities (mapcar #'upcase possibilities)))
((eq (upcase (aref word 0)) (aref word 0))
- (setq possibilities (mapcar (function
- (lambda (pos)
- (if (eq (aref word 0) (aref pos 0))
- pos
- (capitalize pos))))
+ (setq possibilities (mapcar (lambda (pos)
+ (if (eq (aref word 0) (aref pos 0))
+ pos
+ (capitalize pos)))
possibilities))))
(setq case-fold-search case-fold-search-val)
(save-window-excursion
@@ -3734,8 +3702,7 @@ looking for a dictionary, please see the distribution of the GNU ispell
program, or do an Internet search; there are various dictionaries
available on the net."
(interactive)
- (if (and (boundp 'transient-mark-mode) transient-mark-mode
- (boundp 'mark-active) mark-active)
+ (if (and transient-mark-mode mark-active)
(ispell-region (region-beginning) (region-end))
(ispell-buffer)))
@@ -3765,7 +3732,7 @@ SPC.
For spell-checking \"on the fly\", not just after typing SPC or
RET, use `flyspell-mode'."
- nil " Spell" ispell-minor-keymap)
+ :lighter " Spell" :keymap ispell-minor-keymap)
(defun ispell-minor-check ()
"Check previous word, then continue with the normal binding of this key.
@@ -3923,7 +3890,7 @@ in your init file:
You can bind this to the key C-c i in GNUS or mail by adding to
`news-reply-mode-hook' or `mail-mode-hook' the following lambda expression:
- (function (lambda () (local-set-key \"\\C-ci\" \\='ispell-message)))"
+ (lambda () (local-set-key \"\\C-ci\" \\='ispell-message))"
(interactive)
(save-excursion
(goto-char (point-min))
@@ -4083,7 +4050,7 @@ Includes LaTeX/Nroff modes and extended character mode."
(progn
(ispell-send-string "+\n") ; set ispell mode to tex
(if (not (eq ispell-parser 'tex))
- (set (make-local-variable 'ispell-parser) 'tex)))
+ (setq-local ispell-parser 'tex)))
(ispell-send-string "-\n")) ; set mode to normal (nroff)
;; If needed, test for SGML & HTML modes and set a buffer local nil/t value.
(if (and ispell-skip-html (not (eq ispell-skip-html t)))
@@ -4200,7 +4167,7 @@ Both should not be used to define a buffer-local dictionary."
(let (line-okay search done found)
(while (not done)
(let ((case-fold-search nil))
- (setq search (search-forward ispell-words-keyword nil 'move)
+ (setq search (search-forward ispell-words-keyword nil t)
found (or found search)
line-okay (< (+ (length word) 1 ; 1 for space after word..
(progn (end-of-line) (current-column)))
@@ -4211,8 +4178,10 @@ Both should not be used to define a buffer-local dictionary."
(setq done t)
(if (null search)
(progn
- (open-line 1)
- (unless found (newline))
+ (if found (insert "\n") ;; after an existing LocalWords
+ (goto-char (point-max)) ;; no LocalWords, go to end of file
+ (open-line 1)
+ (newline))
(insert (if comment-start
(concat
(progn
diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el
index 9cacc175ba9..d374cab27a4 100644
--- a/lisp/textmodes/less-css-mode.el
+++ b/lisp/textmodes/less-css-mode.el
@@ -73,7 +73,6 @@
(require 'compile)
(require 'css-mode)
-(require 'derived)
(eval-when-compile (require 'subr-x))
(defgroup less-css nil
@@ -92,7 +91,7 @@ executable, e.g.: \"~/.gem/ruby/1.8/bin/lessc\"."
"If non-nil, Less buffers are compiled to CSS after each save."
:type 'boolean)
;;;###autoload
-(put 'less-css-compile-at-save 'safe-local-variable 'booleanp)
+(put 'less-css-compile-at-save 'safe-local-variable #'booleanp)
(defcustom less-css-lessc-options '("--no-color")
"Command line options for Less executable.
@@ -108,7 +107,7 @@ using `expand-file-name', so both relative and absolute paths
will work as expected."
:type '(choice (const :tag "Same as Less file" nil) directory))
;;;###autoload
-(put 'less-css-output-directory 'safe-local-variable 'stringp)
+(put 'less-css-output-directory 'safe-local-variable #'stringp)
(defcustom less-css-output-file-name nil
"File name in which to save CSS, or nil to use <name>.css for <name>.less.
@@ -134,7 +133,7 @@ the path is relative, it will be relative to the current
directory by default."
:type '(choice (const nil) file))
;;;###autoload
-(put 'less-css-input-file-name 'safe-local-variable 'stringp)
+(put 'less-css-input-file-name 'safe-local-variable #'stringp)
(make-variable-buffer-local 'less-css-input-file-name)
(defconst less-css-default-error-regex
@@ -212,7 +211,7 @@ directory by default."
(defvar less-css-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'less-css-compile)
+ (define-key map "\C-c\C-c" #'less-css-compile)
map))
;;;###autoload (add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode))
@@ -227,7 +226,7 @@ Special commands:
(setq-local comment-continue " *")
(setq-local comment-start-skip "/[*/]+[ \t]*")
(setq-local comment-end-skip "[ \t]*\\(?:\n\\|\\*+/\\)")
- (add-hook 'after-save-hook 'less-css-compile-maybe nil t))
+ (add-hook 'after-save-hook #'less-css-compile-maybe nil t))
(provide 'less-css-mode)
;;; less-css-mode.el ends here
diff --git a/lisp/textmodes/makeinfo.el b/lisp/textmodes/makeinfo.el
index e48649bae37..13367a09bcf 100644
--- a/lisp/textmodes/makeinfo.el
+++ b/lisp/textmodes/makeinfo.el
@@ -1,4 +1,4 @@
-;;; makeinfo.el --- run makeinfo conveniently
+;;; makeinfo.el --- run makeinfo conveniently -*- lexical-binding: t; -*-
;; Copyright (C) 1991, 1993, 2001-2021 Free Software Foundation, Inc.
@@ -59,16 +59,14 @@
(defcustom makeinfo-run-command "makeinfo"
"Command used to run `makeinfo' subjob.
The name of the file is appended to this string, separated by a space."
- :type 'string
- :group 'makeinfo)
+ :type 'string)
(defcustom makeinfo-options "--fill-column=70"
"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'."
- :type 'string
- :group 'makeinfo)
+ :type 'string)
(require 'texinfo)
@@ -87,6 +85,7 @@ the proper way to specify those is with the Texinfo commands
;;; The `makeinfo' function definitions
+;;;###autoload
(defun makeinfo-region (region-beginning region-end)
"Make Info file from region of current Texinfo file, and switch to it.
@@ -95,7 +94,7 @@ apply to a temporary file, not the original; use the `makeinfo-buffer'
command to gain use of `next-error'."
(interactive "r")
- (let (filename-or-header
+ (let (;; filename-or-header
filename-or-header-beginning
filename-or-header-end)
;; Cannot use `let' for makeinfo-temp-file or
@@ -175,7 +174,7 @@ command to gain use of `next-error'."
t
'makeinfo-compilation-sentinel-region)))))))
-(defun makeinfo-next-error (arg reset)
+(defun makeinfo-next-error (_arg _reset)
"This function is used to disable `next-error' if the user has
used `makeinfo-region'. Since the compilation process is used on
a temporary file in that case, calling `next-error' would give
@@ -224,6 +223,7 @@ nonsensical results."
(match-string 1)
"Top")))
+;;;###autoload
(defun makeinfo-buffer ()
"Make Info file from current buffer.
@@ -268,6 +268,7 @@ Use the \\[next-error] command to move to the next error
(Info-revert-find-node
makeinfo-output-file-name makeinfo-output-node-name))))
+;;;###autoload
(defun makeinfo-recenter-compilation-buffer (linenum)
"Redisplay `*compilation*' buffer so most recent output can be seen.
The last line of the buffer is displayed on
@@ -286,7 +287,10 @@ line LINE of the window, or centered if LINE is nil."
(pop-to-buffer old-buffer)
)))
-;;; Place `provide' at end of file.
(provide 'makeinfo)
+;; Local Variables:
+;; generated-autoload-file: "texinfo-loaddefs.el"
+;; End:
+
;;; makeinfo.el ends here
diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el
index 173008d1da1..25905385685 100644
--- a/lisp/textmodes/mhtml-mode.el
+++ b/lisp/textmodes/mhtml-mode.el
@@ -22,6 +22,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'pcase))
(require 'sgml-mode)
(require 'js)
(require 'css-mode)
@@ -73,7 +74,9 @@ code();
(defconst mhtml--crucial-variable-prefix
(regexp-opt '("comment-" "uncomment-" "electric-indent-"
- "smie-" "forward-sexp-function" "completion-" "major-mode"))
+ "smie-" "forward-sexp-function" "completion-" "major-mode"
+ "adaptive-fill-" "fill-" "normal-auto-fill-function"
+ "paragraph-"))
"Regexp matching the prefix of \"crucial\" buffer-locals we want to capture.")
(defconst mhtml--variable-prefix
@@ -157,54 +160,6 @@ code();
(mhtml--submode-name submode)
"")))
-(defvar font-lock-beg)
-(defvar font-lock-end)
-
-(defun mhtml--extend-font-lock-region ()
- "Extend the font lock region according to HTML sub-mode needs.
-
-This is used via `font-lock-extend-region-functions'. It ensures
-that the font-lock region is extended to cover either whole
-lines, or to the spot where the submode changes, whichever is
-smallest."
- (let ((orig-beg font-lock-beg)
- (orig-end font-lock-end))
- ;; The logic here may look odd but it is needed to ensure that we
- ;; do the right thing when trying to limit the search.
- (save-excursion
- (goto-char font-lock-beg)
- ;; previous-single-property-change starts by looking at the
- ;; previous character, but we're trying to extend a region to
- ;; include just characters with the same submode as this
- ;; character.
- (unless (eobp)
- (forward-char))
- (setq font-lock-beg (previous-single-property-change
- (point) 'mhtml-submode nil
- (line-beginning-position)))
- (unless (eq (get-text-property font-lock-beg 'mhtml-submode)
- (get-text-property orig-beg 'mhtml-submode))
- (cl-incf font-lock-beg))
-
- (goto-char font-lock-end)
- (unless (bobp)
- (backward-char))
- (setq font-lock-end (next-single-property-change
- (point) 'mhtml-submode nil
- (line-beginning-position 2)))
- (unless (eq (get-text-property font-lock-end 'mhtml-submode)
- (get-text-property orig-end 'mhtml-submode))
- (cl-decf font-lock-end)))
-
- ;; Also handle the multiline property -- but handle it here, and
- ;; not via font-lock-extend-region-functions, to avoid the
- ;; situation where the two extension functions disagree.
- ;; See bug#29159.
- (font-lock-extend-region-multiline)
-
- (or (/= font-lock-beg orig-beg)
- (/= font-lock-end orig-end))))
-
(defun mhtml--submode-fontify-one-region (submode beg end &optional loudly)
(if submode
(mhtml--with-locals submode
@@ -303,17 +258,14 @@ This is used by `mhtml--pre-command'.")
sgml-syntax-propertize-rules))
(defun mhtml-syntax-propertize (start end)
- ;; First remove our special settings from the affected text. They
- ;; will be re-applied as needed.
- (remove-list-of-text-properties start end
- '(syntax-table local-map mhtml-submode))
- (goto-char start)
- ;; Be sure to look back one character, because START won't yet have
- ;; been propertized.
- (unless (bobp)
- (let ((submode (get-text-property (1- (point)) 'mhtml-submode)))
- (if submode
- (mhtml--syntax-propertize-submode submode end))))
+ (let ((submode (get-text-property start 'mhtml-submode)))
+ ;; First remove our special settings from the affected text. They
+ ;; will be re-applied as needed.
+ (remove-list-of-text-properties start end
+ '(syntax-table local-map mhtml-submode))
+ (goto-char start)
+ (if submode
+ (mhtml--syntax-propertize-submode submode end)))
(sgml-syntax-propertize (point) end mhtml--syntax-propertize))
(defun mhtml-indent-line ()
@@ -352,6 +304,17 @@ This is used by `mhtml--pre-command'.")
(flyspell-generic-progmode-verify)
t)))
+;; Support for hideshow.el (see `hs-special-modes-alist').
+(defun mhtml-forward (arg)
+ "Move point forward past a structured expression.
+If point is on a tag, move to the end of the tag.
+Otherwise, this calls `forward-sexp'.
+Prefix arg specifies how many times to move (default 1)."
+ (interactive "P")
+ (pcase (get-text-property (point) 'mhtml-submode)
+ ('nil (sgml-skip-tag-forward arg))
+ (_submode (forward-sexp arg))))
+
;;;###autoload
(define-derived-mode mhtml-mode html-mode
'((sgml-xml-mode "XHTML+" "HTML+") (:eval (mhtml--submode-lighter)))
@@ -364,8 +327,6 @@ the rules from `css-mode'."
(setq-local syntax-propertize-function #'mhtml-syntax-propertize)
(setq-local font-lock-fontify-region-function
#'mhtml--submode-fontify-region)
- (setq-local font-lock-extend-region-functions
- '(mhtml--extend-font-lock-region))
;; Attach this to both pre- and post- hooks just in case it ever
;; changes a key binding that might be accessed from the menu bar.
@@ -383,6 +344,18 @@ the rules from `css-mode'."
;: Hack
(js--update-quick-match-re)
+ ;; Setup the appropriate js-mode value of auto-fill-function.
+ (setf (mhtml--submode-crucial-captured-locals mhtml--js-submode)
+ (push (cons 'auto-fill-function
+ (if (and (boundp 'auto-fill-function) auto-fill-function)
+ #'js-do-auto-fill
+ nil))
+ (mhtml--submode-crucial-captured-locals mhtml--js-submode)))
+
+ ;; This mode might be using CC Mode's filling functionality.
+ (c-foreign-init-lit-pos-cache)
+ (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t)
+
;; This is sort of a prog-mode as well as a text mode.
(run-hooks 'prog-mode-hook))
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el
index 90e15ec4edb..94519c3420b 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/textmodes/nroff-mode.el
@@ -1,4 +1,4 @@
-;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source
+;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1994-1995, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@@ -43,43 +43,37 @@
(defcustom nroff-electric-mode nil
"Non-nil means automatically closing requests when you insert an open."
- :group 'nroff
:type 'boolean)
(defvar nroff-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
- (define-key map "\t" 'tab-to-tab-stop)
- (define-key map "\es" 'center-line)
- (define-key map "\e?" 'nroff-count-text-lines)
- (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
- :help "Insert newline for nroff mode; special if nroff-electric mode"))
- (define-key menu-map [nc]
- '(menu-item "Count text lines" nroff-count-text-lines
- :help "Count lines in region, except for nroff request lines."))
- (define-key menu-map [nf]
- '(menu-item "Forward text line" nroff-forward-text-line
- :help "Go forward one nroff text line, skipping lines of nroff requests"))
- (define-key menu-map [nb]
- '(menu-item "Backward text line" nroff-backward-text-line
- :help "Go backward one nroff text line, skipping lines of nroff requests"))
- (define-key menu-map [ne]
- '(menu-item "Electric newline mode"
- 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."))
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\t" #'tab-to-tab-stop)
+ (define-key map "\e?" #'nroff-count-text-lines)
+ (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)
map)
"Major mode keymap for `nroff-mode'.")
+(easy-menu-define nroff-mode-menu nroff-mode-map
+ "Menu for `nroff-mode'."
+ '("Nroff"
+ ["Preview as man page" nroff-view
+ :help "Run man on this file."]
+ ["Electric newline mode" nroff-electric-mode
+ :help "Auto insert closing requests if necessary"
+ :style toggle
+ :selected nroff-electric-mode]
+ ["Backward text line" nroff-backward-text-line
+ :help "Go backward one nroff text line, skipping lines of nroff requests"]
+ ["Forward text line" nroff-forward-text-line
+ :help "Go forward one nroff text line, skipping lines of nroff requests"]
+ ["Count text lines" nroff-count-text-lines
+ :help "Count lines in region, except for nroff request lines."]
+ ["Newline" nroff-electric-newline
+ :help "Insert newline for nroff mode; special if nroff-electric mode"]))
+
(defvar nroff-mode-syntax-table
(let ((st (copy-syntax-table text-mode-syntax-table)))
;; " isn't given string quote syntax in text-mode but it
@@ -112,7 +106,7 @@
;; arguments in common cases, like \f.
(concat "\\\\" ; backslash
"\\(" ; followed by various possibilities
- (mapconcat 'identity
+ (mapconcat #'identity
'("[f*n]*\\[.+?]" ; some groff extensions
"(.." ; two chars after (
"[^(\"#]" ; single char escape
@@ -120,13 +114,11 @@
"\\)")
)
"Font-lock highlighting control in `nroff-mode'."
- :group 'nroff
:type '(repeat regexp))
(defcustom nroff-mode-hook nil
"Hook run by function `nroff-mode'."
- :type 'hook
- :group 'nroff)
+ :type 'hook)
;;;###autoload
(define-derived-mode nroff-mode text-mode "Nroff"
@@ -135,35 +127,32 @@
Turning on Nroff mode runs `text-mode-hook', then `nroff-mode-hook'.
Also, try `nroff-electric-mode', for automatically inserting
closing requests for requests that are used in matched pairs."
- (set (make-local-variable 'font-lock-defaults)
- ;; SYNTAX-BEGIN is set to backward-paragraph to avoid slow-down
- ;; near the end of large buffers due to searching to buffer's
- ;; beginning.
- '(nroff-font-lock-keywords nil t nil backward-paragraph))
- (set (make-local-variable 'outline-regexp) "\\.H[ ]+[1-7]+ ")
- (set (make-local-variable 'outline-level) 'nroff-outline-level)
+ (setq-local font-lock-defaults
+ ;; SYNTAX-BEGIN is set to backward-paragraph to avoid slow-down
+ ;; near the end of large buffers due to searching to buffer's
+ ;; beginning.
+ '(nroff-font-lock-keywords nil t nil backward-paragraph))
+ (setq-local outline-regexp "\\.H[ ]+[1-7]+ ")
+ (setq-local outline-level 'nroff-outline-level)
;; now define a bunch of variables for use by commands in this mode
- (set (make-local-variable 'page-delimiter) "^\\.\\(bp\\|SK\\|OP\\)")
- (set (make-local-variable 'paragraph-start)
- (concat "[.']\\|" paragraph-start))
- (set (make-local-variable 'paragraph-separate)
- (concat "[.']\\|" paragraph-separate))
+ (setq-local page-delimiter "^\\.\\(bp\\|SK\\|OP\\)")
+ (setq-local paragraph-start (concat "[.']\\|" paragraph-start))
+ (setq-local paragraph-separate (concat "[.']\\|" paragraph-separate))
;; Don't auto-fill directive lines starting . or ' since they normally
;; have to be one line. But do auto-fill comments .\" .\# and '''.
;; Comment directives (those starting . or ') are [.'][ \t]*\\[#"]
;; or ''', and this regexp is everything except those. So [.']
;; followed by not backslash and not ' or followed by backslash but
;; then not # or "
- (set (make-local-variable 'auto-fill-inhibit-regexp)
- "[.'][ \t]*\\([^ \t\\']\\|\\\\[^#\"]\\)")
+ (setq-local auto-fill-inhibit-regexp
+ "[.'][ \t]*\\([^ \t\\']\\|\\\\[^#\"]\\)")
;; comment syntax added by mit-erl!gildea 18 Apr 86
- (set (make-local-variable 'comment-start) "\\\" ")
- (set (make-local-variable 'comment-start-skip) "\\\\[\"#][ \t]*")
- (set (make-local-variable 'comment-column) 24)
- (set (make-local-variable 'comment-indent-function) 'nroff-comment-indent)
- (set (make-local-variable 'comment-insert-comment-function)
- 'nroff-insert-comment-function)
- (set (make-local-variable 'imenu-generic-expression) nroff-imenu-expression))
+ (setq-local comment-start "\\\" ")
+ (setq-local comment-start-skip "\\\\[\"#][ \t]*")
+ (setq-local comment-column 24)
+ (setq-local comment-indent-function #'nroff-comment-indent)
+ (setq-local comment-insert-comment-function #'nroff-insert-comment-function)
+ (setq-local imenu-generic-expression nroff-imenu-expression))
(defun nroff-outline-level ()
(save-excursion
@@ -323,7 +312,7 @@ otherwise off."
(save-buffer))
(if viewbuf
(kill-buffer viewbuf))
- (Man-getpage-in-background file)))
+ (Man-getpage-in-background (shell-quote-argument file))))
(provide 'nroff-mode)
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
index 2b557ef28f0..87c91e8f1b7 100644
--- a/lisp/textmodes/page-ext.el
+++ b/lisp/textmodes/page-ext.el
@@ -293,7 +293,7 @@ Used by `pages-directory-for-addresses' function."
;; FIXME: Merely loading a package shouldn't have this kind of side-effects!
(global-unset-key "\C-x\C-p")
(define-key ctl-x-map "\C-p" #'pages-ctl-x-ctl-p-prefix)
-(define-obsolete-function-alias 'ctl-x-ctl-p-prefix 'pages-ctl-x-ctl-p-prefix "27.1")
+(define-obsolete-function-alias 'ctl-x-ctl-p-prefix #'pages-ctl-x-ctl-p-prefix "27.1")
(defalias 'pages-ctl-x-ctl-p-prefix pages--ctl-x-ctl-p-map)
@@ -429,20 +429,19 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)."
;; NEXTRECFUN is called with point at the end of the
;; previous record. It moves point to the start of the
;; next record.
- (function (lambda ()
- (re-search-forward page-delimiter nil t)
- (skip-chars-forward " \t\n")
- ))
+ (lambda ()
+ (re-search-forward page-delimiter nil t)
+ (skip-chars-forward " \t\n"))
;; ENDRECFUN is called with point within the record.
;; It should move point to the end of the record.
- (function (lambda ()
- (if (re-search-forward
- page-delimiter
- nil
- t)
- (goto-char (match-beginning 0))
- (goto-char (point-max))))))))
+ (lambda ()
+ (if (re-search-forward
+ page-delimiter
+ nil
+ t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max)))))))
(define-obsolete-function-alias 'sort-pages-buffer #'pages-sort-buffer "27.1")
(defun pages-sort-buffer (&optional reverse)
diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el
index e1d7fb7431c..b86a2f149de 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/textmodes/page.el
@@ -170,8 +170,6 @@ point, respectively."
(interactive)
(apply #'message (cons "Page %d, line %d" (page--what-page))))
-
-;;; Place `provide' at end of file.
(provide 'page)
;;; page.el ends here
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index bec7348c9ab..59b15e82a81 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -96,9 +96,8 @@ lines that start paragraphs from lines that separate them.
If the variable `use-hard-newlines' is non-nil, then only lines following a
hard newline are considered to match."
- :group 'paragraphs
:type 'regexp)
-(put 'paragraph-start 'safe-local-variable 'stringp)
+(put 'paragraph-start 'safe-local-variable #'stringp)
;; paragraph-start requires a hard newline, but paragraph-separate does not:
;; It is assumed that paragraph-separate is distinctive enough to be believed
@@ -114,9 +113,8 @@ This is matched against the text at the left margin, which is not necessarily
the beginning of the line, so it should not use \"^\" as an anchor. This
ensures that the paragraph functions will work equally within a region of
text indented by a margin setting."
- :group 'paragraphs
:type 'regexp)
-(put 'paragraph-separate 'safe-local-variable 'stringp)
+(put 'paragraph-separate 'safe-local-variable #'stringp)
(defcustom sentence-end-double-space t
"Non-nil means a single space does not end a sentence.
@@ -128,7 +126,7 @@ regexp describing the end of a sentence, when the value of the variable
`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
:type 'boolean
:group 'fill)
-(put 'sentence-end-double-space 'safe-local-variable 'booleanp)
+(put 'sentence-end-double-space 'safe-local-variable #'booleanp)
(defcustom sentence-end-without-period nil
"Non-nil means a sentence will end without a period.
@@ -140,7 +138,7 @@ regexp describing the end of a sentence, when the value of the variable
`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
:type 'boolean
:group 'fill)
-(put 'sentence-end-without-period 'safe-local-variable 'booleanp)
+(put 'sentence-end-without-period 'safe-local-variable #'booleanp)
(defcustom sentence-end-without-space
"。.?ï¼"
@@ -149,9 +147,8 @@ regexp describing the end of a sentence, when the value of the variable
This value is used by the function `sentence-end' to construct the
regexp describing the end of a sentence, when the value of the variable
`sentence-end' is nil. See Info node `(elisp)Standard Regexps'."
- :group 'paragraphs
:type 'string)
-(put 'sentence-end-without-space 'safe-local-variable 'stringp)
+(put 'sentence-end-without-space 'safe-local-variable #'stringp)
(defcustom sentence-end nil
"Regexp describing the end of a sentence.
@@ -161,16 +158,14 @@ All paragraph boundaries also end sentences, regardless.
The value nil means to use the default value defined by the
function `sentence-end'. You should always use this function
to obtain the value of this variable."
- :group 'paragraphs
:type '(choice regexp (const :tag "Use default value" nil)))
-(put 'sentence-end 'safe-local-variable 'string-or-null-p)
+(put 'sentence-end 'safe-local-variable #'string-or-null-p)
(defcustom sentence-end-base "[.?!…‽][]\"'â€â€™)}»›]*"
"Regexp matching the basic end of a sentence, not including following space."
- :group 'paragraphs
- :type 'string
+ :type 'regexp
:version "25.1")
-(put 'sentence-end-base 'safe-local-variable 'stringp)
+(put 'sentence-end-base 'safe-local-variable #'stringp)
(defun sentence-end ()
"Return the regexp describing the end of a sentence.
@@ -197,20 +192,16 @@ in between. See Info node `(elisp)Standard Regexps'."
(defcustom page-delimiter "^\014"
"Regexp describing line-beginnings that separate pages."
- :group 'paragraphs
:type 'regexp)
-(put 'page-delimiter 'safe-local-variable 'stringp)
+(put 'page-delimiter 'safe-local-variable #'stringp)
(defcustom paragraph-ignore-fill-prefix nil
"Non-nil means the paragraph commands are not affected by `fill-prefix'.
This is desirable in modes where blank lines are the paragraph delimiters."
- :group 'paragraphs
:type 'boolean)
-(put 'paragraph-ignore-fill-prefix 'safe-local-variable 'booleanp)
+(put 'paragraph-ignore-fill-prefix 'safe-local-variable #'booleanp)
;; Silence the compiler.
-(defvar multiple-lines)
-
(defun forward-paragraph (&optional arg)
"Move forward to end of paragraph.
With argument ARG, do it ARG times;
@@ -269,13 +260,13 @@ Returns the count of paragraphs left to move."
;; Search back for line that starts or separates paragraphs.
(if (if fill-prefix-regexp
;; There is a fill prefix; it overrides parstart.
- (let (multiple-lines)
+ (let () ;; multiple-lines
(while (and (progn (beginning-of-line) (not (bobp)))
(progn (move-to-left-margin)
(not (looking-at parsep)))
(looking-at fill-prefix-regexp))
- (unless (= (point) start)
- (setq multiple-lines t))
+ ;; (unless (= (point) start)
+ ;; (setq multiple-lines t))
(forward-line -1))
(move-to-left-margin)
;; This deleted code caused a long hanging-indent line
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index c4109214137..1368af01bac 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -1,4 +1,4 @@
-;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model
+;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1994, 2001-2021 Free Software Foundation, Inc.
@@ -37,28 +37,22 @@
(defcustom picture-rectangle-ctl ?+
"Character `picture-draw-rectangle' uses for top left corners."
- :type 'character
- :group 'picture)
+ :type 'character)
(defcustom picture-rectangle-ctr ?+
"Character `picture-draw-rectangle' uses for top right corners."
- :type 'character
- :group 'picture)
+ :type 'character)
(defcustom picture-rectangle-cbr ?+
"Character `picture-draw-rectangle' uses for bottom right corners."
- :type 'character
- :group 'picture)
+ :type 'character)
(defcustom picture-rectangle-cbl ?+
"Character `picture-draw-rectangle' uses for bottom left corners."
- :type 'character
- :group 'picture)
+ :type 'character)
(defcustom picture-rectangle-v ?|
"Character `picture-draw-rectangle' uses for vertical lines."
- :type 'character
- :group 'picture)
+ :type 'character)
(defcustom picture-rectangle-h ?-
"Character `picture-draw-rectangle' uses for horizontal lines."
- :type 'character
- :group 'picture)
+ :type 'character)
;; Picture Movement Commands
@@ -409,8 +403,7 @@ character `\\' in the set it must be preceded by itself: \"\\\\\".
The command \\[picture-tab-search] is defined to move beneath (or to) a
character belonging to this set independent of the tab stops list."
- :type 'string
- :group 'picture)
+ :type 'string)
(defun picture-set-tab-stops (&optional arg)
"Set value of `tab-stop-list' according to context of this line.
@@ -682,8 +675,7 @@ Leaves the region surrounding the rectangle."
(defcustom picture-mode-hook nil
"If non-nil, its value is called on entry to Picture mode.
Picture mode is invoked by the command \\[picture-mode]."
- :type 'hook
- :group 'picture)
+ :type 'hook)
(defvar picture-mode-old-local-map)
(defvar picture-mode-old-mode-name)
@@ -764,18 +756,17 @@ they are not by default assigned to keys."
(interactive)
(if (eq major-mode 'picture-mode)
(error "You are already editing a picture")
- (set (make-local-variable 'picture-mode-old-local-map) (current-local-map))
+ (setq-local picture-mode-old-local-map (current-local-map))
(use-local-map picture-mode-map)
- (set (make-local-variable 'picture-mode-old-mode-name) mode-name)
- (set (make-local-variable 'picture-mode-old-major-mode) major-mode)
+ (setq-local picture-mode-old-mode-name mode-name)
+ (setq-local picture-mode-old-major-mode major-mode)
(setq major-mode 'picture-mode)
- (set (make-local-variable 'picture-killed-rectangle) nil)
- (set (make-local-variable 'tab-stop-list) (default-value 'tab-stop-list))
- (set (make-local-variable 'picture-tab-chars)
- (default-value 'picture-tab-chars))
+ (setq-local picture-killed-rectangle nil)
+ (setq-local tab-stop-list (default-value 'tab-stop-list))
+ (setq-local picture-tab-chars (default-value 'picture-tab-chars))
(make-local-variable 'picture-vertical-step)
(make-local-variable 'picture-horizontal-step)
- (set (make-local-variable 'picture-mode-old-truncate-lines) truncate-lines)
+ (setq-local picture-mode-old-truncate-lines truncate-lines)
(setq truncate-lines t)
(picture-set-motion 0 1)
diff --git a/lisp/textmodes/po.el b/lisp/textmodes/po.el
index 426b6ffe191..1066e93af10 100644
--- a/lisp/textmodes/po.el
+++ b/lisp/textmodes/po.el
@@ -1,4 +1,4 @@
-;;; po.el --- basic support of PO translation files
+;;; po.el --- basic support of PO translation files -*- lexical-binding:t -*-
;; Copyright (C) 1995-1998, 2000-2021 Free Software Foundation, Inc.
diff --git a/lisp/textmodes/refbib.el b/lisp/textmodes/refbib.el
index bff57128c51..084b17c676b 100644
--- a/lisp/textmodes/refbib.el
+++ b/lisp/textmodes/refbib.el
@@ -1,4 +1,4 @@
-;;; refbib.el --- convert refer-style references to ones usable by Latex bib
+;;; refbib.el --- convert refer-style references to ones usable by Latex bib -*- lexical-binding: t; -*-
;; Copyright (C) 1989, 2001-2021 Free Software Foundation, Inc.
@@ -65,8 +65,7 @@
(defcustom r2b-trace-on nil
"Non-nil means trace conversion."
- :type 'boolean
- :group 'refbib)
+ :type 'boolean)
(defcustom r2b-journal-abbrevs
'(
@@ -83,8 +82,7 @@ letter, even if it really doesn't.
\(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
\"Artificial Intelligence\", but would replace Ijcai81 with the
BibTeX macro \"ijcai7\"."
- :type '(repeat (list string string))
- :group 'refbib)
+ :type '(repeat (list string string)))
(defcustom r2b-booktitle-abbrevs
'(
@@ -101,8 +99,7 @@ should be listed as beginning with a capital letter, even if it doesn't.
\(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
\"Artificial Intelligence\", but would replace Ijcai81 with the
BibTeX macro \"ijcai7\"."
- :type '(repeat (list string string))
- :group 'refbib)
+ :type '(repeat (list string string)))
(defcustom r2b-proceedings-list
'()
@@ -119,8 +116,7 @@ a conference, and its expansion is the BibTeX macro \"ijcai7\". Then
expansion were \"Proceedings of the Seventh International Conference
on Artificial Intelligence\", then you would NOT need to include Ijcai81
in `r2b-proceedings-list' (although it wouldn't cause an error)."
- :type '(repeat (list string string))
- :group 'refbib)
+ :type '(repeat (list string string)))
(defvar r2b-additional-stop-words
"Some\\|What"
@@ -129,8 +125,7 @@ This is in addition to the `r2b-capitalize-title-stop-words'.")
(defcustom r2b-delimit-with-quote t
"If true, then use \" to delimit fields, otherwise use braces."
- :type 'boolean
- :group 'refbib)
+ :type 'boolean)
;**********************************************************
; Utility Functions
@@ -205,13 +200,11 @@ This is in addition to the `r2b-capitalize-title-stop-words'.")
(defcustom r2b-out-buf-name "*Out*"
"Name of buffer for output from refer-to-bibtex."
- :type 'string
- :group 'refbib)
+ :type 'string)
(defcustom r2b-log-name "*Log*"
"Name of buffer for logs errors from refer-to-bibtex."
- :type 'string
- :group 'refbib)
+ :type 'string)
(defvar r2b-in-buf nil)
(defvar r2b-out-buf nil)
@@ -418,7 +411,7 @@ title if CAPITALIZE is true. Returns value of VAR."
with a comma and newline; if ABBREVS list is given, then
try to replace the {DATA} with an abbreviation."
(if data
- (let (match nodelim multi-line index)
+ (let (match nodelim index) ;; multi-line
(cond
((and abbrevs (setq match (assoc data abbrevs)))
(if (null (cdr match))
@@ -514,7 +507,7 @@ but not a publisher."
(defun r2b-barf-output ()
"Generate bibtex based on global variables."
- (let ((standard-output r2b-out-buf) (case-fold-search t) match)
+ (let ((standard-output r2b-out-buf) (case-fold-search t)) ;; match
(r2b-trace "...barfing")
(sit-for 0)
diff --git a/lisp/textmodes/refer.el b/lisp/textmodes/refer.el
index 0eefc68ced5..e710180d5f5 100644
--- a/lisp/textmodes/refer.el
+++ b/lisp/textmodes/refer.el
@@ -1,4 +1,4 @@
-;;; refer.el --- look up references in bibliography files
+;;; refer.el --- look up references in bibliography files -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 1996, 2001-2021 Free Software Foundation, Inc.
@@ -91,8 +91,7 @@ the default search path. Since Refer does not know that default path,
it cannot search it. Include that path explicitly in your BIBINPUTS
environment if you really want it searched (which is not likely to
happen anyway)."
- :type '(choice (repeat directory) (const bibinputs) (const texinputs))
- :group 'refer)
+ :type '(choice (repeat directory) (const bibinputs) (const texinputs)))
(defcustom refer-bib-files 'dir
"List of \\.bib files to search for references,
@@ -110,16 +109,14 @@ If `refer-bib-files' is nil, auto or dir, it is setq'd to the appropriate
list of files when it is first used if `refer-cache-bib-files' is t. If
`refer-cache-bib-files' is nil, the list of \\.bib files to use is re-read
each time it is needed."
- :type '(choice (repeat file) (const nil) (const auto) (const dir))
- :group 'refer)
+ :type '(choice (repeat file) (const nil) (const auto) (const dir)))
(defcustom refer-cache-bib-files t
"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."
- :type 'boolean
- :group 'refer)
+ :type 'boolean)
(defcustom refer-bib-files-regexp "\\\\bibliography"
"Regexp matching a bibliography file declaration.
@@ -131,8 +128,7 @@ command is expected to specify a file name, or a list of comma-separated file
names, within curly braces.
If a specified file doesn't exist and has no extension, a \\.bib extension
is automatically tried."
- :type 'regexp
- :group 'refer)
+ :type 'regexp)
(make-variable-buffer-local 'refer-bib-files)
(make-variable-buffer-local 'refer-cache-bib-files)
@@ -180,7 +176,7 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(defun refer-find-entry-internal (keywords continue)
(let ((keywords-list (refer-convert-string-to-list-of-strings keywords))
- (old-buffer (current-buffer))
+ ;; (old-buffer (current-buffer))
(old-window (selected-window))
(new-window (selected-window))
(files (if continue
@@ -188,7 +184,7 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(setq refer-saved-pos nil)
(refer-get-bib-files)))
(n 0)
- (found nil)
+ ;; (found nil)
(file nil))
;; find window in which to display bibliography file.
;; if a bibliography file is already displayed in a window, use
@@ -249,10 +245,10 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(forward-paragraph 1)
(setq end (point))
(setq found
- (refer-every (function (lambda (keyword)
- (goto-char begin)
- (re-search-forward keyword end t)))
- keywords-list))
+ (seq-every-p (lambda (keyword)
+ (goto-char begin)
+ (re-search-forward keyword end t))
+ keywords-list))
(if (not found)
(progn
(setq begin end)
@@ -264,12 +260,6 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(progn (message "Scanning %s... not found" file)
nil))))
-(defun refer-every (pred l)
- (cond ((null l) nil)
- ((funcall pred (car l))
- (or (null (cdr l))
- (refer-every pred (cdr l))))))
-
(defun refer-convert-string-to-list-of-strings (s)
(let ((current (current-buffer))
(temp-buffer (get-buffer-create "*refer-temp*")))
@@ -336,9 +326,9 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(list (expand-file-name
(if (eq major-mode 'bibtex-mode)
(read-file-name
- (format ".bib file (default %s): "
- (file-name-nondirectory
- (buffer-file-name)))
+ (format-prompt ".bib file"
+ (file-name-nondirectory
+ (buffer-file-name)))
(file-name-directory (buffer-file-name))
(file-name-nondirectory (buffer-file-name))
t)
@@ -395,4 +385,6 @@ found on the last `refer-find-entry' or `refer-find-next-entry'."
(setq refer-bib-files files))
files))
+(define-obsolete-function-alias 'refer-every #'seq-every-p "28.1")
+
;;; refer.el ends here
diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el
index b4eaa5decc1..0a0e4cc444c 100644
--- a/lisp/textmodes/refill.el
+++ b/lisp/textmodes/refill.el
@@ -1,4 +1,4 @@
-;;; refill.el --- `auto-fill' by refilling paragraphs on changes
+;;; refill.el --- `auto-fill' by refilling paragraphs on changes -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -83,17 +83,11 @@
;;; Code:
-;; Unused.
-;;; (defgroup refill nil
-;;; "Refilling paragraphs on changes."
-;;; :group 'fill)
-
-(defvar refill-ignorable-overlay nil
+(defvar-local refill-ignorable-overlay nil
"Portion of the most recently filled paragraph not needing filling.
This is used to optimize refilling.")
-(make-variable-buffer-local 'refill-ignorable-overlay)
-(defun refill-adjust-ignorable-overlay (overlay afterp beg end &optional len)
+(defun refill-adjust-ignorable-overlay (overlay afterp beg _end &optional _len)
"Adjust OVERLAY to not include the about-to-be-modified region."
(when (not afterp)
(save-excursion
@@ -149,7 +143,7 @@ This is used to optimize refilling.")
"Like `fill-paragraph' but don't delete whitespace at paragraph end."
(refill-fill-paragraph-at (point) arg))
-(defvar refill-doit nil
+(defvar-local refill-doit nil
"Non-nil tells `refill-post-command-function' to do its processing.
Set by `refill-after-change-function' in `after-change-functions' and
unset by `refill-post-command-function' in `post-command-hook', and
@@ -157,9 +151,8 @@ sometimes `refill-pre-command-function' in `pre-command-hook'. This
ensures refilling is only done once per command that causes a change,
regardless of the number of after-change calls from commands doing
complex processing.")
-(make-variable-buffer-local 'refill-doit)
-(defun refill-after-change-function (beg end len)
+(defun refill-after-change-function (_beg end _len)
"Function for `after-change-functions' which just sets `refill-doit'."
(unless undo-in-progress
(setq refill-doit end)))
@@ -234,27 +227,25 @@ For true \"word wrap\" behavior, use `visual-line-mode' instead."
(kill-local-variable 'refill-saved-state))
(if refill-mode
(progn
- (add-hook 'after-change-functions 'refill-after-change-function nil t)
- (add-hook 'post-command-hook 'refill-post-command-function nil t)
- (add-hook 'pre-command-hook 'refill-pre-command-function nil t)
- (set (make-local-variable 'refill-saved-state)
- (mapcar (lambda (s) (cons s (symbol-value s)))
- '(fill-paragraph-function auto-fill-function)))
+ (add-hook 'after-change-functions #'refill-after-change-function nil t)
+ (add-hook 'post-command-hook #'refill-post-command-function nil t)
+ (add-hook 'pre-command-hook #'refill-pre-command-function nil t)
+ (setq-local refill-saved-state
+ (mapcar (lambda (s) (cons s (symbol-value s)))
+ '(fill-paragraph-function auto-fill-function)))
;; This provides the test for recursive paragraph filling.
- (set (make-local-variable 'fill-paragraph-function)
- 'refill-fill-paragraph)
+ (setq-local fill-paragraph-function #'refill-fill-paragraph)
;; When using justification, doing DEL on 2 spaces should remove
;; both, otherwise, the subsequent refill will undo the DEL.
- (set (make-local-variable 'backward-delete-char-untabify-method)
- 'hungry)
+ (setq-local backward-delete-char-untabify-method 'hungry)
(setq refill-ignorable-overlay (make-overlay 1 1 nil nil t))
(overlay-put refill-ignorable-overlay 'modification-hooks
'(refill-adjust-ignorable-overlay))
(overlay-put refill-ignorable-overlay 'insert-behind-hooks
'(refill-adjust-ignorable-overlay))
(auto-fill-mode 0))
- (remove-hook 'after-change-functions 'refill-after-change-function t)
- (remove-hook 'post-command-hook 'refill-post-command-function t)
+ (remove-hook 'after-change-functions #'refill-after-change-function t)
+ (remove-hook 'post-command-hook #'refill-post-command-function t)
(kill-local-variable 'backward-delete-char-untabify-method)))
(provide 'refill)
diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el
index ae3faec4fdc..977da700fd0 100644
--- a/lisp/textmodes/reftex-auc.el
+++ b/lisp/textmodes/reftex-auc.el
@@ -1,4 +1,4 @@
-;;; reftex-auc.el --- RefTeX's interface to AUCTeX
+;;; reftex-auc.el --- RefTeX's interface to AUCTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -32,11 +32,12 @@
(optional prompt default &optional complete))
(declare-function TeX-argument-insert "ext:tex"
(name optional &optional prefix))
-(declare-function LaTeX-add-labels "ext:tex" (&rest entries) t)
-(declare-function LaTeX-add-index-entries "ext:tex" (&rest entries) t)
-(declare-function LaTeX-bibitem-list "ext:tex" () t)
-(declare-function LaTeX-index-entry-list "ext:tex" () t)
-(declare-function LaTeX-label-list "ext:tex" () t)
+(declare-function LaTeX-add-labels "ext:latex" (&rest labels) t)
+(declare-function LaTeX-add-index-entries "ext:latex" (&rest index-entries) t)
+(declare-function LaTeX-add-bibitems "ext:latex" (&rest bibitems) t)
+(declare-function LaTeX-bibitem-list "ext:latex" () t)
+(declare-function LaTeX-index-entry-list "ext:latex" () t)
+(declare-function LaTeX-label-list "ext:latex" () t)
(declare-function multi-prompt "ext:multi-prompt"
(separator unique prompt table &optional
mp-predicate require-match initial history))
@@ -82,13 +83,12 @@ What is being used depends upon `reftex-plug-into-AUCTeX'."
(if prompt prompt "Add key")
" (default none): "))
(setq items (multi-prompt "," t prompt (LaTeX-bibitem-list)))))
- (apply 'LaTeX-add-bibitems items)
- (TeX-argument-insert (mapconcat 'identity items reftex-cite-key-separator)
+ (apply #'LaTeX-add-bibitems items)
+ (TeX-argument-insert (mapconcat #'identity items reftex-cite-key-separator)
optional)))
-
;;;###autoload
-(defun reftex-arg-index-tag (optional &optional prompt &rest args)
+(defun reftex-arg-index-tag (optional &optional prompt &rest _args)
"Prompt for an index tag with completion.
This is the name of an index, not the entry."
(let (tag taglist)
@@ -102,13 +102,13 @@ This is the name of an index, not the entry."
(setq taglist
(cdr (assoc 'index-tags
(symbol-value reftex-docstruct-symbol)))
- tag (completing-read prompt (mapcar 'list taglist))))
+ tag (completing-read prompt (mapcar #'list taglist))))
;; Just ask like AUCTeX does.
(setq tag (read-string prompt)))
(TeX-argument-insert tag optional)))
;;;###autoload
-(defun reftex-arg-index (optional &optional prompt &rest args)
+(defun reftex-arg-index (optional &optional prompt &rest _args)
"Prompt for an index entry completing with known entries.
Completion is specific for just one index, if the macro or a tag
argument identify one of multiple indices."
@@ -149,23 +149,27 @@ argument identify one of multiple indices."
;; `reftex-plug-into-AUCTeX'.
(if (reftex-plug-flag 0)
- (setq LaTeX-label-function 'reftex-label)
- (setq LaTeX-label-function nil))
-
- (and (or (reftex-plug-flag 1) (reftex-plug-flag 2))
- (fboundp 'TeX-arg-label)
- (fset 'TeX-arg-label 'reftex-arg-label))
-
- (and (reftex-plug-flag 3)
- (fboundp 'TeX-arg-cite)
- (fset 'TeX-arg-cite 'reftex-arg-cite))
-
- (and (reftex-plug-flag 4)
- (fboundp 'TeX-arg-index-tag)
- (fset 'TeX-arg-index-tag 'reftex-arg-index-tag))
- (and (reftex-plug-flag 4)
- (fboundp 'TeX-arg-index)
- (fset 'TeX-arg-index 'reftex-arg-index)))
+ (if (bound-and-true-p LaTeX-label-function)
+ (add-function :override LaTeX-label-function #'reftex-label)
+ (setq LaTeX-label-function #'reftex-label))
+ (if (eq #'reftex-label (bound-and-true-p LaTeX-label-function))
+ (setq LaTeX-label-function nil)
+ (remove-function LaTeX-label-function #'reftex-label)))
+
+ (if (or (reftex-plug-flag 1) (reftex-plug-flag 2))
+ (advice-add 'TeX-arg-label :override #'reftex-arg-label)
+ (advice-remove 'TeX-arg-label #'reftex-arg-label))
+
+ (if (reftex-plug-flag 3)
+ (advice-add 'TeX-arg-cite :override #'reftex-arg-cite)
+ (advice-remove 'TeX-arg-cite #'reftex-arg-cite))
+
+ (if (reftex-plug-flag 4)
+ (advice-add 'TeX-arg-index-tag :override #'reftex-arg-index-tag)
+ (advice-remove 'TeX-arg-index-tag #'reftex-arg-index-tag))
+ (if (reftex-plug-flag 4)
+ (advice-add 'TeX-arg-index :override #'reftex-arg-index)
+ (advice-remove 'TeX-arg-index #'reftex-arg-index)))
;;;###autoload
(defun reftex-toggle-plug-into-AUCTeX ()
@@ -205,7 +209,7 @@ the label information is recompiled on next use."
(when changed
(put reftex-docstruct-symbol 'reftex-label-alist-style list)))))
;;;###autoload
-(defalias 'reftex-add-to-label-alist 'reftex-add-label-environments)
+(defalias 'reftex-add-to-label-alist #'reftex-add-label-environments)
;;;###autoload
(defun reftex-add-section-levels (entry-list)
diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el
index 5579e401790..650d11d4aca 100644
--- a/lisp/textmodes/reftex-cite.el
+++ b/lisp/textmodes/reftex-cite.el
@@ -1,4 +1,4 @@
-;;; reftex-cite.el --- creating citations with RefTeX
+;;; reftex-cite.el --- creating citations with RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -310,11 +310,11 @@ Return list with entries."
;; Sorting
(cond
((eq 'author reftex-sort-bibtex-matches)
- (sort found-list 'reftex-bib-sort-author))
+ (sort found-list #'reftex-bib-sort-author))
((eq 'year reftex-sort-bibtex-matches)
- (sort found-list 'reftex-bib-sort-year))
+ (sort found-list #'reftex-bib-sort-year))
((eq 'reverse-year reftex-sort-bibtex-matches)
- (sort found-list 'reftex-bib-sort-year-reverse))
+ (sort found-list #'reftex-bib-sort-year-reverse))
(t found-list))))
(defun reftex-bib-sort-author (e1 e2)
@@ -390,7 +390,7 @@ The environment should be located in FILES."
(when (and start end)
(setq entries
(append entries
- (mapcar 'reftex-parse-bibitem
+ (mapcar #'reftex-parse-bibitem
(delete ""
(split-string
(buffer-substring-no-properties
@@ -533,7 +533,7 @@ If FORMAT is non-nil `format' entry accordingly."
"Format a BibTeX ENTRY so that it is nice to look at."
(let*
((auth-list (reftex-get-bib-names "author" entry))
- (authors (mapconcat 'identity auth-list ", "))
+ (authors (mapconcat #'identity auth-list ", "))
(year (reftex-get-bib-field "year" entry))
(title (reftex-get-bib-field "title" entry))
(type (reftex-get-bib-field "&type" entry))
@@ -607,7 +607,7 @@ If FORMAT is non-nil `format' entry accordingly."
(push (substring text 0 (+ 60 (match-beginning 0))) lines)
(setq text (substring text (+ 61 (match-beginning 0)))))
(push text lines)
- (setq text (mapconcat 'identity (nreverse lines) "\n "))
+ (setq text (mapconcat #'identity (nreverse lines) "\n "))
(when (reftex-use-fonts)
(put-text-property 0 (length text) 'face reftex-bib-author-face text))
@@ -676,7 +676,7 @@ While entering the regexp, completion on knows citation keys is possible.
;; All keys go into a single command - we need to trick a little
;; FIXME: Unfortunately, this means that commenting does not work right.
(pop selected-entries)
- (let ((concat-keys (mapconcat 'car selected-entries
+ (let ((concat-keys (mapconcat #'car selected-entries
reftex-cite-key-separator)))
(setq insert-entries
(list (list concat-keys (cons "&key" concat-keys))))))
@@ -726,7 +726,7 @@ While entering the regexp, completion on knows citation keys is possible.
(when (and reftex-mode
(fboundp 'LaTeX-add-bibitems)
reftex-plug-into-AUCTeX)
- (apply 'LaTeX-add-bibitems (mapcar 'car selected-entries)))
+ (apply #'LaTeX-add-bibitems (mapcar #'car selected-entries)))
;; Produce the cite-view strings
(when (and reftex-mode reftex-cache-cite-echo cite-view)
@@ -749,7 +749,7 @@ While entering the regexp, completion on knows citation keys is possible.
(forward-char 1)))
;; Return the citation key
- (mapcar 'car selected-entries)))
+ (mapcar #'car selected-entries)))
(defun reftex-figure-out-cite-format (arg &optional no-insert format-key)
"Check if there is already a cite command at point and change cite format
@@ -815,15 +815,16 @@ in order to only add another reference in the same cite command."
(reftex-citation nil ?t))
(defvar reftex-select-bib-map)
+(defvar reftex--found-list)
(defun reftex-offer-bib-menu ()
"Offer bib menu and return list of selected items."
(let ((bibtype (reftex-bib-or-thebib))
- found-list rtn key data selected-entries)
+ reftex--found-list rtn key data selected-entries)
(while
(not
(catch 'done
;; Scan bibtex files
- (setq found-list
+ (setq reftex--found-list
(cond
((eq bibtype 'bib)
; ((assq 'bib (symbol-value reftex-docstruct-symbol))
@@ -834,7 +835,7 @@ in order to only add another reference in the same cite command."
;; using thebibliography environment.
(reftex-extract-bib-entries-from-thebibliography
(reftex-uniquify
- (mapcar 'cdr
+ (mapcar #'cdr
(reftex-all-assq
'thebib (symbol-value reftex-docstruct-symbol))))))
(reftex-default-bibliography
@@ -842,7 +843,7 @@ in order to only add another reference in the same cite command."
(reftex-extract-bib-entries (reftex-default-bibliography)))
(t (error "No valid bibliography in this document, and no default available"))))
- (unless found-list
+ (unless reftex--found-list
(error "Sorry, no matches found"))
;; Remember where we came from
@@ -854,11 +855,11 @@ in order to only add another reference in the same cite command."
(delete-other-windows)
(reftex-kill-buffer "*RefTeX Select*")
(switch-to-buffer-other-window "*RefTeX Select*")
- (unless (eq major-mode 'reftex-select-bib-mode)
+ (unless (derived-mode-p 'reftex-select-bib-mode)
(reftex-select-bib-mode))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(erase-buffer)
- (reftex-insert-bib-matches found-list))
+ (reftex-insert-bib-matches reftex--found-list))
(setq buffer-read-only t)
(if (= 0 (buffer-size))
(error "No matches found"))
@@ -881,34 +882,36 @@ in order to only add another reference in the same cite command."
(throw 'done nil))
((eq key ?r)
;; Restrict with new regular expression
- (setq found-list (reftex-restrict-bib-matches found-list))
+ (setq reftex--found-list
+ (reftex-restrict-bib-matches reftex--found-list))
(let ((buffer-read-only nil))
(erase-buffer)
- (reftex-insert-bib-matches found-list))
+ (reftex-insert-bib-matches reftex--found-list))
(goto-char 1))
((eq key ?A)
;; Take all (marked)
(setq selected-entries
(if reftex-select-marked
- (mapcar 'car (nreverse reftex-select-marked))
- found-list))
+ (mapcar #'car (nreverse reftex-select-marked))
+ reftex--found-list))
(throw 'done t))
((eq key ?a)
;; Take all (marked), and push the symbol 'concat
(setq selected-entries
(cons 'concat
(if reftex-select-marked
- (mapcar 'car (nreverse reftex-select-marked))
- found-list)))
+ (mapcar #'car (nreverse reftex-select-marked))
+ reftex--found-list)))
(throw 'done t))
((eq key ?e)
;; Take all (marked), and push the symbol 'concat
- (reftex-extract-bib-file found-list reftex-select-marked)
+ (reftex-extract-bib-file reftex--found-list
+ reftex-select-marked)
(setq selected-entries "BibTeX database file created")
(throw 'done t))
((eq key ?E)
;; Take all (marked), and push the symbol 'concat
- (reftex-extract-bib-file found-list reftex-select-marked
+ (reftex-extract-bib-file reftex--found-list reftex-select-marked
'complement)
(setq selected-entries "BibTeX database file created")
(throw 'done t))
@@ -918,7 +921,7 @@ in order to only add another reference in the same cite command."
(setq selected-entries
(if reftex-select-marked
(cons 'concat
- (mapcar 'car (nreverse reftex-select-marked)))
+ (mapcar #'car (nreverse reftex-select-marked)))
(if data (list data) nil)))
(throw 'done t))
((stringp key)
@@ -971,7 +974,7 @@ in order to only add another reference in the same cite command."
nil)
(cdr (assoc "&entry" x))))
all)))
- (insert (mapconcat 'identity all "\n\n"))
+ (insert (mapconcat #'identity all "\n\n"))
(save-buffer)
(goto-char (point-min))))
@@ -1004,7 +1007,7 @@ in order to only add another reference in the same cite command."
last (nth (1- n) namelist))
(setcdr (nthcdr (- n 2) namelist) nil)
(concat
- (mapconcat 'identity namelist (nth 0 reftex-cite-punctuation))
+ (mapconcat #'identity namelist (nth 0 reftex-cite-punctuation))
(nth 1 reftex-cite-punctuation)
last)))))
@@ -1100,7 +1103,7 @@ in order to only add another reference in the same cite command."
(put reftex-docstruct-symbol 'modified t)))
string))
-(defun reftex-bibtex-selection-callback (data ignore no-revisit)
+(defun reftex-bibtex-selection-callback (data _ignore no-revisit)
"Callback function to be called from the BibTeX selection, in
order to display context. This function is relatively slow and not
recommended for follow mode. It works OK for individual lookups."
@@ -1119,7 +1122,7 @@ recommended for follow mode. It works OK for individual lookups."
; ((assq 'thebib (symbol-value reftex-docstruct-symbol))
(setq bibfile-list
(reftex-uniquify
- (mapcar 'cdr
+ (mapcar #'cdr
(reftex-all-assq
'thebib (symbol-value reftex-docstruct-symbol))))
item t))
@@ -1163,7 +1166,7 @@ recommended for follow mode. It works OK for individual lookups."
"Return a list of BibTeX @string references that appear as values in ALIST."
(reftex-remove-if (lambda (x) (string-match "^\\([\"{]\\|[0-9]+$\\)" x))
;; get list of values, discard keys
- (mapcar 'cdr
+ (mapcar #'cdr
;; remove &key and &type entries
(reftex-remove-if (lambda (pair)
(string-match "^&" (car pair)))
@@ -1186,7 +1189,7 @@ created files in the variables `reftex-create-bibtex-header' or
(interactive "FNew BibTeX file: ")
(let ((keys (reftex-all-used-citation-keys))
(files (reftex-get-bibfile-list))
- file key entries beg end entry string-keys string-entries)
+ key entries beg end entry string-keys string-entries)
(save-current-buffer
(dolist (file files)
(set-buffer (reftex-get-file-buffer-force file 'mark))
@@ -1252,9 +1255,9 @@ created files in the variables `reftex-create-bibtex-header' or
(error "Abort")))
(erase-buffer)
(if reftex-create-bibtex-header (insert reftex-create-bibtex-header "\n\n"))
- (insert (mapconcat 'identity (reverse string-entries) "\n\n"))
+ (insert (mapconcat #'identity (reverse string-entries) "\n\n"))
(if string-entries (insert "\n\n\n"))
- (insert (mapconcat 'identity (reverse entries) "\n\n"))
+ (insert (mapconcat #'identity (reverse entries) "\n\n"))
(if reftex-create-bibtex-footer (insert "\n\n" reftex-create-bibtex-footer))
(goto-char (point-min))
(save-buffer)
diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el
index e517cea2669..a21dd3362b0 100644
--- a/lisp/textmodes/reftex-dcr.el
+++ b/lisp/textmodes/reftex-dcr.el
@@ -1,4 +1,4 @@
-;;; reftex-dcr.el --- viewing cross references and citations with RefTeX
+;;; reftex-dcr.el --- viewing cross references and citations with RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -132,7 +132,7 @@ to the functions `reftex-view-cr-cite' and `reftex-view-cr-ref'."
((eq bibtype 'thebib)
(setq item t
files (reftex-uniquify
- (mapcar 'cdr
+ (mapcar #'cdr
(reftex-all-assq
'thebib (symbol-value reftex-docstruct-symbol))))))
(reftex-default-bibliography
@@ -161,10 +161,10 @@ to the functions `reftex-view-cr-cite' and `reftex-view-cr-ref'."
(shrink-window (1- (- (window-height) size)))
(recenter 0))
;; Arrange restoration
- (add-hook 'pre-command-hook 'reftex-restore-window-conf))
+ (add-hook 'pre-command-hook #'reftex-restore-window-conf))
;; Normal display in other window
- (add-hook 'pre-command-hook 'reftex-highlight-shall-die)
+ (add-hook 'pre-command-hook #'reftex-highlight-shall-die)
(setq pop-win (selected-window))
(select-window win)
(goto-char pos)
@@ -212,13 +212,13 @@ to the functions `reftex-view-cr-cite' and `reftex-view-cr-ref'."
(error (set-window-configuration window-conf)
(message "ref: Label %s not found" label)
(error "ref: Label %s not found" label)))) ;; 2nd is line OK
- (add-hook 'pre-command-hook 'reftex-highlight-shall-die)
+ (add-hook 'pre-command-hook #'reftex-highlight-shall-die)
(when (eq how 'tmp-window)
;; Resize window and arrange restoration
(shrink-window (1- (- (window-height) 9)))
(recenter '(4))
- (add-hook 'pre-command-hook 'reftex-restore-window-conf))
+ (add-hook 'pre-command-hook #'reftex-restore-window-conf))
(setq pop-win (selected-window))
(select-window win)
(goto-char pos)
@@ -266,7 +266,7 @@ With argument, actually select the window showing the cross reference."
(defun reftex-restore-window-conf ()
(set-window-configuration (get 'reftex-auto-view-crossref 'last-window-conf))
(put 'reftex-auto-view-crossref 'last-window-conf nil)
- (remove-hook 'pre-command-hook 'reftex-restore-window-conf))
+ (remove-hook 'pre-command-hook #'reftex-restore-window-conf))
(defun reftex-echo-ref (label entry docstruct)
;; Display crossref info in echo area.
@@ -320,10 +320,6 @@ With argument, actually select the window showing the cross reference."
(with-current-buffer buf
(run-hooks 'reftex-display-copied-context-hook)))))
-(defvar reftex-use-itimer-in-xemacs nil
- "Non-nil means use the idle timers in XEmacs for crossref display.
-Currently, idle timer restart is broken and we use the post-command-hook.")
-
;;;###autoload
(defun reftex-toggle-auto-view-crossref ()
"Toggle the automatic display of crossref information in the echo area.
@@ -332,36 +328,16 @@ will display info in the echo area."
(interactive)
(if reftex-auto-view-crossref-timer
(progn
- (if (featurep 'xemacs)
- (if reftex-use-itimer-in-xemacs
- (delete-itimer reftex-auto-view-crossref-timer)
- (remove-hook 'post-command-hook 'reftex-start-itimer-once))
- (cancel-timer reftex-auto-view-crossref-timer))
+ (cancel-timer reftex-auto-view-crossref-timer)
(setq reftex-auto-view-crossref-timer nil)
(message "Automatic display of crossref information was turned off"))
(setq reftex-auto-view-crossref-timer
- (if (featurep 'xemacs)
- (if reftex-use-itimer-in-xemacs
- (start-itimer "RefTeX Idle Timer"
- 'reftex-view-crossref-when-idle
- reftex-idle-time reftex-idle-time t)
- (add-hook 'post-command-hook 'reftex-start-itimer-once)
- t)
- (run-with-idle-timer
- reftex-idle-time t 'reftex-view-crossref-when-idle)))
+ (run-with-idle-timer
+ reftex-idle-time t #'reftex-view-crossref-when-idle))
(unless reftex-auto-view-crossref
(setq reftex-auto-view-crossref t))
(message "Automatic display of crossref information was turned on")))
-(defun reftex-start-itimer-once ()
- (and (featurep 'xemacs)
- reftex-mode
- (not (itimer-live-p reftex-auto-view-crossref-timer))
- (setq reftex-auto-view-crossref-timer
- (start-itimer "RefTeX Idle Timer"
- 'reftex-view-crossref-when-idle
- reftex-idle-time nil t))))
-
;;;###autoload
(defun reftex-view-crossref-from-bibtex (&optional arg)
"View location in a LaTeX document which cites the BibTeX entry at point.
@@ -431,7 +407,7 @@ Calling this function several times find successive citation locations."
(put 'reftex-view-regexp-match :cnt (cl-incf cnt))
(reftex-highlight 0 (match-beginning highlight-group)
(match-end highlight-group))
- (add-hook 'pre-command-hook 'reftex-highlight-shall-die)
+ (add-hook 'pre-command-hook #'reftex-highlight-shall-die)
(setq pop-window (selected-window)))
(put 'reftex-view-regexp-match :props nil)
(or cont (set-window-configuration window-conf)))
diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el
index 4d021609019..3b7518e5c3f 100644
--- a/lisp/textmodes/reftex-global.el
+++ b/lisp/textmodes/reftex-global.el
@@ -1,4 +1,4 @@
-;;; reftex-global.el --- operations on entire documents with RefTeX
+;;; reftex-global.el --- operations on entire documents with RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -39,7 +39,7 @@ The TAGS file is also immediately visited with `visit-tags-table'."
(reftex-access-scan-info current-prefix-arg)
(let* ((master (reftex-TeX-master-file))
(files (reftex-all-document-files))
- (cmd (format "etags %s" (mapconcat 'shell-quote-argument
+ (cmd (format "etags %s" (mapconcat #'shell-quote-argument
files " "))))
(with-current-buffer (reftex-get-file-buffer-force master)
(message "Running etags to create TAGS file...")
@@ -65,7 +65,7 @@ No active TAGS table is required."
(let* ((files (reftex-all-document-files t))
(cmd (format
"%s %s" grep-cmd
- (mapconcat 'identity files " "))))
+ (mapconcat #'identity files " "))))
(grep cmd)))
;;;###autoload
@@ -160,7 +160,7 @@ No active TAGS table is required."
(when (and (car (car dlist))
(cdr (car dlist)))
(cl-incf cnt)
- (insert (mapconcat 'identity (car dlist) "\n ") "\n"))
+ (insert (mapconcat #'identity (car dlist) "\n ") "\n"))
(pop dlist))
(goto-char (point-min))
(when (= cnt 0)
@@ -208,7 +208,7 @@ one with the `xr' package."
(error "Abort"))
;; Make the translation list
(let* ((re-core (concat "\\("
- (mapconcat 'cdr reftex-typekey-to-prefix-alist "\\|")
+ (mapconcat #'cdr reftex-typekey-to-prefix-alist "\\|")
"\\)"))
(label-re (concat "\\`" re-core "\\([0-9]+\\)\\'"))
(search-re (concat "[{,]\\(" re-core "\\([0-9]+\\)\\)[,}]"))
@@ -326,7 +326,7 @@ labels."
file buffer)
(save-current-buffer
(while (setq file (pop files))
- (setq buffer (reftex-get-buffer-visiting file))
+ (setq buffer (find-buffer-visiting file))
(when buffer
(set-buffer buffer)
(save-buffer))))))
@@ -344,7 +344,7 @@ Also checks if buffers visiting the files are in read-only mode."
(ding)
(or (y-or-n-p (format "No write access to %s. Continue? " file))
(error "Abort")))
- (when (and (setq buf (reftex-get-buffer-visiting file))
+ (when (and (setq buf (find-buffer-visiting file))
(with-current-buffer buf
buffer-read-only))
(ding)
@@ -366,10 +366,10 @@ Also checks if buffers visiting the files are in read-only mode."
(goto-char (if isearch-forward (point-min) (point-max))))
(defun reftex-isearch-push-state-function ()
- `(lambda (cmd)
- (reftex-isearch-pop-state-function cmd ,(current-buffer))))
+ (let ((buf (current-buffer)))
+ (lambda (cmd) (reftex-isearch-pop-state-function cmd buf))))
-(defun reftex-isearch-pop-state-function (cmd buffer)
+(defun reftex-isearch-pop-state-function (_cmd buffer)
(switch-to-buffer buffer))
(defun reftex-isearch-isearch-search (string bound noerror)
@@ -451,17 +451,17 @@ With no argument, this command toggles
(if (boundp 'multi-isearch-next-buffer-function)
(set (make-local-variable
'multi-isearch-next-buffer-function)
- 'reftex-isearch-switch-to-next-file)
+ #'reftex-isearch-switch-to-next-file)
(set (make-local-variable 'isearch-wrap-function)
- 'reftex-isearch-wrap-function)
+ #'reftex-isearch-wrap-function)
(set (make-local-variable 'isearch-search-fun-function)
- (lambda () 'reftex-isearch-isearch-search))
+ (lambda () #'reftex-isearch-isearch-search))
(set (make-local-variable 'isearch-push-state-function)
- 'reftex-isearch-push-state-function)
+ #'reftex-isearch-push-state-function)
(set (make-local-variable 'isearch-next-buffer-function)
- 'reftex-isearch-switch-to-next-file))
+ #'reftex-isearch-switch-to-next-file))
(setq reftex-isearch-minor-mode t))))
- (add-hook 'reftex-mode-hook 'reftex-isearch-minor-mode))
+ (add-hook 'reftex-mode-hook #'reftex-isearch-minor-mode))
(dolist (crt-buf (buffer-list))
(with-current-buffer crt-buf
(when reftex-mode
@@ -472,7 +472,7 @@ With no argument, this command toggles
(kill-local-variable 'isearch-push-state-function)
(kill-local-variable 'isearch-next-buffer-function))
(setq reftex-isearch-minor-mode nil))))
- (remove-hook 'reftex-mode-hook 'reftex-isearch-minor-mode)))
+ (remove-hook 'reftex-mode-hook #'reftex-isearch-minor-mode)))
;; Force mode line redisplay.
(set-buffer-modified-p (buffer-modified-p))))
diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el
index 806f6c085c3..28cc7db2dcd 100644
--- a/lisp/textmodes/reftex-index.el
+++ b/lisp/textmodes/reftex-index.el
@@ -1,4 +1,4 @@
-;;; reftex-index.el --- index support with RefTeX
+;;; reftex-index.el --- index support with RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -30,8 +30,6 @@
(require 'reftex)
;; START remove for XEmacs release
-(defvar mark-active)
-(defvar transient-mark-mode)
(defvar TeX-master)
;; END remove for XEmacs release
@@ -49,7 +47,7 @@ which is part of AUCTeX, the string is first processed with the
(interactive "P")
(let* ((use-default (not (equal arg '(16)))) ; check for double prefix
;; check if we have an active selection
- (active (reftex-region-active-p))
+ (active (region-active-p))
(beg (if active
(region-beginning)
(save-excursion
@@ -89,7 +87,7 @@ which is part of AUCTeX, the string is first processed with the
(reftex-index def-char full-entry def-tag sel)))))
;;;###autoload
-(defun reftex-index (&optional char key tag sel no-insert)
+(defun reftex-index (&optional char key tag sel _no-insert)
"Query for an index macro and insert it along with its arguments.
The index macros available are those defined in `reftex-index-macro' or
by a call to `reftex-add-index-macros', typically from an AUCTeX style file.
@@ -178,7 +176,7 @@ will prompt for other arguments."
(format "default %s" default))
"")))
": ")))
- (tag (completing-read prompt (mapcar 'list index-tags))))
+ (tag (completing-read prompt (mapcar #'list index-tags))))
(if (and default (equal tag "")) (setq tag default))
(reftex-update-default-index tag)
tag))
@@ -239,7 +237,7 @@ will prompt for other arguments."
(format "[^M] %s (the default)\n" default)
"")
(mapconcat (lambda(x)
- (apply 'format "[%c] %s" x))
+ (apply #'format "[%c] %s" x))
tag-alist "\n")))
;; Query the user for an index-tag
(setq rpl (reftex-select-with-char prompt help 3 t))
@@ -278,56 +276,57 @@ will prompt for other arguments."
(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 [(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)
+ #'next-line #'reftex-index-next map global-map)
(substitute-key-definition
- 'previous-line 'reftex-index-previous map global-map)
-
- (define-key map "n" 'reftex-index-next)
- (define-key map "p" 'reftex-index-previous)
- (define-key map "?" 'reftex-index-show-help)
- (define-key map " " 'reftex-index-view-entry)
- (define-key map "\C-m" 'reftex-index-goto-entry-and-hide)
- (define-key map "\C-i" 'reftex-index-goto-entry)
- (define-key map "\C-k" 'reftex-index-kill)
- (define-key map "r" 'reftex-index-rescan)
- (define-key map "R" 'reftex-index-Rescan)
- (define-key map "g" 'revert-buffer)
- (define-key map "q" 'reftex-index-quit)
- (define-key map "k" 'reftex-index-quit-and-kill)
- (define-key map "f" 'reftex-index-toggle-follow)
- (define-key map "s" 'reftex-index-switch-index-tag)
- (define-key map "e" 'reftex-index-edit)
- (define-key map "^" 'reftex-index-level-up)
- (define-key map "_" 'reftex-index-level-down)
- (define-key map "}" 'reftex-index-restrict-to-section)
- (define-key map "{" 'reftex-index-widen)
- (define-key map ">" 'reftex-index-restriction-forward)
- (define-key map "<" 'reftex-index-restriction-backward)
- (define-key map "(" 'reftex-index-toggle-range-beginning)
- (define-key map ")" 'reftex-index-toggle-range-end)
- (define-key map "|" 'reftex-index-edit-attribute)
- (define-key map "@" 'reftex-index-edit-visual)
- (define-key map "*" 'reftex-index-edit-key)
- (define-key map "\C-c=" 'reftex-index-goto-toc)
- (define-key map "c" 'reftex-index-toggle-context)
+ #'previous-line #'reftex-index-previous map global-map)
+
+ (define-key map "n" #'reftex-index-next)
+ (define-key map "p" #'reftex-index-previous)
+ (define-key map "?" #'reftex-index-show-help)
+ (define-key map " " #'reftex-index-view-entry)
+ (define-key map "\C-m" #'reftex-index-goto-entry-and-hide)
+ (define-key map "\C-i" #'reftex-index-goto-entry)
+ (define-key map "\C-k" #'reftex-index-kill)
+ (define-key map "r" #'reftex-index-rescan)
+ (define-key map "R" #'reftex-index-Rescan)
+ (define-key map "g" #'revert-buffer)
+ (define-key map "q" #'reftex-index-quit)
+ (define-key map "k" #'reftex-index-quit-and-kill)
+ (define-key map "f" #'reftex-index-toggle-follow)
+ (define-key map "s" #'reftex-index-switch-index-tag)
+ (define-key map "e" #'reftex-index-edit)
+ (define-key map "^" #'reftex-index-level-up)
+ (define-key map "_" #'reftex-index-level-down)
+ (define-key map "}" #'reftex-index-restrict-to-section)
+ (define-key map "{" #'reftex-index-widen)
+ (define-key map ">" #'reftex-index-restriction-forward)
+ (define-key map "<" #'reftex-index-restriction-backward)
+ (define-key map "(" #'reftex-index-toggle-range-beginning)
+ (define-key map ")" #'reftex-index-toggle-range-end)
+ (define-key map "|" #'reftex-index-edit-attribute)
+ (define-key map "@" #'reftex-index-edit-visual)
+ (define-key map "*" #'reftex-index-edit-key)
+ (define-key map "\C-c=" #'reftex-index-goto-toc)
+ (define-key map "c" #'reftex-index-toggle-context)
;; The capital letters and the exclamation mark
- (cl-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))))
+ (mapc (lambda (key)
+ (define-key map (vector (list key))
+ (lambda () (interactive)
+ (reftex-index-goto-letter key))))
+ (concat "!" reftex-index-section-letters))
(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]
+ 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]
@@ -394,7 +393,7 @@ Press `?' for a summary of important key bindings, or check the menu.
Here are all local bindings.
\\{reftex-index-mode-map}"
- (set (make-local-variable 'revert-buffer-function) 'reftex-index-revert)
+ (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)
(setq mode-line-format
@@ -403,14 +402,9 @@ Here are all local bindings.
" R<" 'reftex-index-restriction-indicator ">"
" -%-"))
(setq truncate-lines t)
- (when (featurep 'xemacs)
- ;; XEmacs needs the call to make-local-hook
- (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-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))
+ (add-hook 'post-command-hook #'reftex-index-post-command-hook nil t)
+ (add-hook 'pre-command-hook #'reftex-index-pre-command-hook nil t))
(defconst reftex-index-help
" AVAILABLE KEYS IN INDEX BUFFER
@@ -449,7 +443,7 @@ _ ^ Add/Remove parent key (to make this item a subitem).
(match
(cond
((or (not no-revisit)
- (reftex-get-buffer-visiting file))
+ (find-buffer-visiting file))
(switch-to-buffer-other-window
(reftex-get-file-buffer-force file nil))
(goto-char (or pos (point-min)))
@@ -566,7 +560,7 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(run-hooks 'reftex-display-copied-context-hook)
(message "Building %s buffer...done." buffer-name)
(setq buffer-read-only t))
- (and locations (apply 'reftex-find-start-point (point) locations))
+ (and locations (apply #'reftex-find-start-point (point) locations))
(if reftex-index-restriction-indicator
(message "Index restricted: <%s>" reftex-index-restriction-indicator))))
@@ -581,7 +575,7 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(indent " ")
(context reftex-index-include-context)
(context-indent (concat indent " "))
- (section-chars (mapcar 'identity reftex-index-section-letters))
+ (section-chars (mapcar #'identity reftex-index-section-letters))
(this-section-char 0)
(font (reftex-use-fonts))
(bor (car reftex-index-restriction-data))
@@ -732,9 +726,9 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(if reftex-index-follow-mode
(setq reftex-index-follow-mode 1)))
-(defun reftex-index-next (&optional arg)
+(defun reftex-index-next (&optional _arg)
"Move to next selectable item."
- (interactive "p")
+ (interactive "^")
(setq reftex-callback-fwd t)
(or (eobp) (forward-char 1))
(goto-char (or (next-single-property-change (point) :data)
@@ -742,9 +736,9 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(unless (get-text-property (point) :data)
(goto-char (or (next-single-property-change (point) :data)
(point)))))
-(defun reftex-index-previous (&optional arg)
+(defun reftex-index-previous (&optional _arg)
"Move to previous selectable item."
- (interactive "p")
+ (interactive "^")
(setq reftex-callback-fwd nil)
(goto-char (or (previous-single-property-change (point) :data)
(point)))
@@ -792,7 +786,7 @@ Label context is only displayed when the labels are there as well."
(or (one-window-p) (delete-window))
(switch-to-buffer (marker-buffer reftex-index-return-marker))
(goto-char (or (marker-position reftex-index-return-marker) (point))))
-(defun reftex-index-goto-toc (&rest ignore)
+(defun reftex-index-goto-toc (&rest _ignore)
"Switch to the table of contents of the current document.
The function will go to the section where the entry at point was defined."
(interactive)
@@ -801,7 +795,7 @@ The function will go to the section where the entry at point was defined."
(switch-to-buffer (marker-buffer reftex-index-return-marker)))
(delete-other-windows)
(reftex-toc))
-(defun reftex-index-rescan (&rest ignore)
+(defun reftex-index-rescan (&rest _ignore)
"Regenerate the *Index* buffer after reparsing file of section at point."
(interactive)
(let ((index-tag reftex-index-tag))
@@ -817,7 +811,7 @@ The function will go to the section where the entry at point was defined."
(reftex-display-index index-tag nil 'redo line)))
(reftex-index-Rescan))
(reftex-kill-temporary-buffers)))
-(defun reftex-index-Rescan (&rest ignore)
+(defun reftex-index-Rescan (&rest _ignore)
"Regenerate the *Index* buffer after reparsing the entire document."
(interactive)
(let ((index-tag reftex-index-tag)
@@ -826,7 +820,7 @@ The function will go to the section where the entry at point was defined."
(reftex-get-file-buffer-force reftex-last-index-file))
(setq current-prefix-arg '(16))
(reftex-display-index index-tag nil 'redo line)))
-(defun reftex-index-revert (&rest ignore)
+(defun reftex-index-revert (&rest _ignore)
"Regenerate the *Index* from the internal lists. No reparsing os done."
(interactive)
(let ((buf (current-buffer))
@@ -839,7 +833,7 @@ The function will go to the section where the entry at point was defined."
(setq current-prefix-arg nil
reftex-last-follow-point 1)
(reftex-display-index index-tag nil 'redo data line)))
-(defun reftex-index-switch-index-tag (&rest ignore)
+(defun reftex-index-switch-index-tag (&rest _ignore)
"Switch to a different index of the same document."
(interactive)
(switch-to-buffer
@@ -864,14 +858,14 @@ The function will go to the section where the entry at point was defined."
reftex-index-restriction-indicator (nth 6 bor) )))
(reftex-index-revert))
-(defun reftex-index-widen (&rest ignore)
+(defun reftex-index-widen (&rest _ignore)
"Show the unrestricted index (all entries)."
(interactive)
(setq reftex-index-restriction-indicator nil
reftex-index-restriction-data nil)
(reftex-index-revert)
(message "Index widened"))
-(defun reftex-index-restriction-forward (&rest ignore)
+(defun reftex-index-restriction-forward (&rest _ignore)
"Restrict to previous section.
When index is currently unrestricted, restrict it to a section.
When index is restricted, select the next section as restriction criterion."
@@ -887,7 +881,7 @@ When index is restricted, select the next section as restriction criterion."
(car (memq (assq 'toc (cdr (memq bor docstruct)))
docstruct))))
(reftex-index-revert))))
-(defun reftex-index-restriction-backward (&rest ignore)
+(defun reftex-index-restriction-backward (&rest _ignore)
"Restrict to next section.
When index is currently unrestricted, restrict it to a section.
When index is restricted, select the previous section as restriction criterion."
@@ -985,7 +979,7 @@ When index is restricted, select the previous section as restriction criterion."
(setq analyze (reftex-index-analyze-entry data)
attr (nth 2 analyze))
(setf (nth 2 analyze) (if (string= attr bor) "" bor))
- (setq new (apply 'concat analyze))
+ (setq new (apply #'concat analyze))
(reftex-index-change-entry
new (if (string= (nth 2 analyze) bor)
"Entry is now START-OF-PAGE-RANGE"
@@ -1001,7 +995,7 @@ When index is restricted, select the previous section as restriction criterion."
(setq analyze (reftex-index-analyze-entry data)
attr (nth 2 analyze))
(setf (nth 2 analyze) (if (string= attr eor) "" eor))
- (setq new (apply 'concat analyze))
+ (setq new (apply #'concat analyze))
(reftex-index-change-entry
new (if (string= (nth 2 analyze) eor)
"Entry is now END-OF-PAGE-RANGE"
@@ -1042,7 +1036,7 @@ When index is restricted, select the previous section as restriction criterion."
(error "Invalid value")
(setf (nth n analyze) npart)))
(t (setf (nth n analyze) (concat initial npart))))
- (setq new (apply 'concat analyze))
+ (setq new (apply #'concat analyze))
;; Change the entry and insert the changed version into the index.
(reftex-index-change-entry
new (if (string= npart "")
@@ -1179,27 +1173,50 @@ This gets refreshed in every phrases command.")
(defvar reftex-index-phrases-files nil
"List of document files relevant for the phrases file.")
-(defvar reftex-index-phrases-font-lock-keywords nil
- "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-font-lock-keywords
+ (list
+ (cons reftex-index-phrases-comment-regexp 'font-lock-comment-face)
+ (list reftex-index-phrases-macrodef-regexp
+ '(1 font-lock-type-face)
+ '(2 font-lock-keyword-face)
+ '(3 'secondary-selection)
+ '(4 font-lock-function-name-face)
+ '(5 'secondary-selection)
+ '(6 font-lock-string-face))
+ (list reftex-index-phrases-phrase-regexp1
+ '(1 font-lock-keyword-face)
+ '(2 'secondary-selection)
+ '(3 font-lock-string-face)
+ '(4 'secondary-selection))
+ (list reftex-index-phrases-phrase-regexp2
+ '(1 font-lock-keyword-face)
+ '(2 'secondary-selection)
+ '(3 font-lock-string-face)
+ '(4 'secondary-selection)
+ '(5 font-lock-function-name-face))
+ '("^\t$" . 'secondary-selection))
+ "Font lock keywords for `reftex-index-phrases-mode'.")
+(defvar reftex-index-phrases-font-lock-defaults
+ '((reftex-index-phrases-font-lock-keywords)
+ nil t nil beginning-of-line)
+ "Font lock defaults for `reftex-index-phrases-mode'.")
(define-obsolete-variable-alias
'reftex-index-phrases-map 'reftex-index-phrases-mode-map "24.1")
(defvar reftex-index-phrases-mode-map
(let ((map (make-sparse-keymap)))
;; Keybindings and Menu for phrases buffer
- (define-key map "\C-c\C-c" 'reftex-index-phrases-save-and-return)
- (define-key map "\C-c\C-x" 'reftex-index-this-phrase)
- (define-key map "\C-c\C-f" 'reftex-index-next-phrase)
- (define-key map "\C-c\C-r" 'reftex-index-region-phrases)
- (define-key map "\C-c\C-a" 'reftex-index-all-phrases)
- (define-key map "\C-c\C-d" 'reftex-index-remaining-phrases)
- (define-key map "\C-c\C-s" 'reftex-index-sort-phrases)
- (define-key map "\C-c\C-n" 'reftex-index-new-phrase)
- (define-key map "\C-c\C-m" 'reftex-index-phrases-set-macro-key)
- (define-key map "\C-c\C-i" 'reftex-index-phrases-info)
- (define-key map "\C-c\C-t" 'reftex-index-find-next-conflict-phrase)
- (define-key map "\C-i" 'self-insert-command)
+ (define-key map "\C-c\C-c" #'reftex-index-phrases-save-and-return)
+ (define-key map "\C-c\C-x" #'reftex-index-this-phrase)
+ (define-key map "\C-c\C-f" #'reftex-index-next-phrase)
+ (define-key map "\C-c\C-r" #'reftex-index-region-phrases)
+ (define-key map "\C-c\C-a" #'reftex-index-all-phrases)
+ (define-key map "\C-c\C-d" #'reftex-index-remaining-phrases)
+ (define-key map "\C-c\C-s" #'reftex-index-sort-phrases)
+ (define-key map "\C-c\C-n" #'reftex-index-new-phrase)
+ (define-key map "\C-c\C-m" #'reftex-index-phrases-set-macro-key)
+ (define-key map "\C-c\C-i" #'reftex-index-phrases-info)
+ (define-key map "\C-c\C-t" #'reftex-index-find-next-conflict-phrase)
+ (define-key map "\C-i" #'self-insert-command)
(easy-menu-define reftex-index-phrases-menu map
"Menu for Phrases buffer"
@@ -1294,7 +1311,7 @@ If the buffer is non-empty, delete the old header first."
reftex-key-to-index-macro-alist)))
(macro-alist
(sort (copy-sequence reftex-index-macro-alist)
- (lambda (a b) (equal (car a) default-macro))))
+ (lambda (a _b) (equal (car a) default-macro))))
macro entry key repeat)
(if master (set (make-local-variable 'TeX-master)
@@ -1310,9 +1327,7 @@ If the buffer is non-empty, delete the old header first."
(beginning-of-line 2))
(while (looking-at "^[ \t]*$")
(beginning-of-line 2))
- (if (featurep 'xemacs)
- (zmacs-activate-region)
- (setq mark-active t))
+ (activate-mark)
(if (yes-or-no-p "Delete and rebuild header? ")
(delete-region (point-min) (point))))
@@ -1335,7 +1350,6 @@ If the buffer is non-empty, delete the old header first."
(if repeat "t" "nil"))))
(insert "%---------------------------------------------------------------------\n\n\n")))
-(defvar TeX-master)
(defun reftex-index-phrase-tex-master (&optional dir)
"Return the name of the master file associated with a phrase buffer."
(if (and (boundp 'TeX-master)
@@ -1386,40 +1400,8 @@ Here are all local bindings.
:syntax-table reftex-index-phrases-syntax-table
(set (make-local-variable 'font-lock-defaults)
reftex-index-phrases-font-lock-defaults)
- (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)))
- (setq reftex-index-phrases-font-lock-keywords
- (list
- (cons reftex-index-phrases-comment-regexp 'font-lock-comment-face)
- (list reftex-index-phrases-macrodef-regexp
- '(1 font-lock-type-face)
- '(2 font-lock-keyword-face)
- (list 3 ss)
- '(4 font-lock-function-name-face)
- (list 5 ss)
- '(6 font-lock-string-face))
- (list reftex-index-phrases-phrase-regexp1
- '(1 font-lock-keyword-face)
- (list 2 ss)
- '(3 font-lock-string-face)
- (list 4 ss))
- (list reftex-index-phrases-phrase-regexp2
- '(1 font-lock-keyword-face)
- (list 2 ss)
- '(3 font-lock-string-face)
- (list 4 ss)
- '(5 font-lock-function-name-face))
- (cons "^\t$" ss)))
- (setq reftex-index-phrases-font-lock-defaults
- '((reftex-index-phrases-font-lock-keywords)
- nil t nil beginning-of-line))
- (put 'reftex-index-phrases-mode 'font-lock-defaults
- reftex-index-phrases-font-lock-defaults) ; XEmacs
- )
+;; (add-hook 'reftex-index-phrases-mode-hook #'turn-on-font-lock)
(defun reftex-index-next-phrase (&optional arg)
"Index the next ARG phrases in the phrases buffer."
@@ -1559,9 +1541,7 @@ index the new part without having to go over the unchanged parts again."
(unwind-protect
(progn
;; Hide the region highlighting
- (if (featurep 'xemacs)
- (zmacs-deactivate-region)
- (deactivate-mark))
+ (deactivate-mark)
(delete-other-windows)
(reftex-index-visit-phrases-buffer)
(reftex-index-all-phrases))
@@ -1591,7 +1571,7 @@ index the new part without having to go over the unchanged parts again."
(if (and text (stringp text))
(insert text)))
-(defun reftex-index-find-next-conflict-phrase (&optional arg)
+(defun reftex-index-find-next-conflict-phrase (&optional _arg)
"Find the next a phrase which is has conflicts in the phrase buffer.
The command helps to find possible conflicts in the phrase indexing process.
It searches downward from point for a phrase which is repeated elsewhere
@@ -1599,7 +1579,7 @@ in the buffer, or which is a subphrase of another phrase. If such a
phrase is found, the phrase info is displayed.
To check the whole buffer, start at the beginning and continue by calling
this function repeatedly."
- (interactive "P")
+ (interactive)
(if (catch 'exit
(while (re-search-forward reftex-index-phrases-phrase-regexp12 nil t)
(goto-char (match-beginning 3))
@@ -1741,6 +1721,8 @@ information about the currently selected macro."
(if repeat "with" "without")))
(error "Abort")))))
+(defvar reftex--chars-first)
+
(defun reftex-index-sort-phrases (&optional chars-first)
"Sort the phrases lines in the buffer alphabetically.
Normally, this looks only at the phrases. With a prefix arg CHARS-FIRST,
@@ -1760,19 +1742,18 @@ it first compares the macro identifying chars and then the phrases."
(if end (setq end (progn (goto-char end) (end-of-line) (point))))
;; Take the lines, sort them and re-insert.
(if (and beg end)
- (progn
+ (let ((reftex--chars-first chars-first))
(message "Sorting lines...")
(let* ((lines (split-string (buffer-substring beg end) "\n"))
- (lines1 (sort lines 'reftex-compare-phrase-lines)))
+ (lines1 (sort lines #'reftex-compare-phrase-lines)))
(message "Sorting lines...done")
(let ((inhibit-quit t)) ;; make sure we do not lose lines
(delete-region beg end)
- (insert (mapconcat 'identity lines1 "\n"))))
+ (insert (mapconcat #'identity lines1 "\n"))))
(goto-char (point-max))
(re-search-backward (concat "^" (regexp-quote line) "$") nil t))
(error "Cannot find phrases lines to sort"))))
-(defvar chars-first)
(defun reftex-compare-phrase-lines (a b)
"The comparison function used for sorting."
(let (ca cb pa pb c-p p-p)
@@ -1796,7 +1777,7 @@ it first compares the macro identifying chars and then the phrases."
p-p (string< pa pb))
;; Do the right comparison, based on the value of `chars-first'
;; `chars-first' is bound locally in the calling function
- (if chars-first
+ (if reftex--chars-first
(if (string= ca cb) p-p c-p)
(if (string= pa pb) c-p p-p)))))
;; If line a does not match, the answer we return determines
@@ -1828,14 +1809,14 @@ With optional arg ALLOW-NEWLINE, allow single newline between words."
(defun reftex-index-simplify-phrase (phrase)
"Make phrase single spaces and single line."
- (mapconcat 'identity (split-string phrase) " "))
+ (mapconcat #'identity (split-string phrase) " "))
(defun reftex-index-phrases-find-dup-re (phrase &optional sub)
"Return a regexp which matches variations of PHRASE (with additional space).
When SUB ins non-nil, the regexp will also match when PHRASE is a subphrase
of another phrase. The regexp works lonly in the phrase buffer."
(concat (if sub "^\\S-?\t\\([^\t\n]*" "^\\S-?\t")
- (mapconcat 'regexp-quote (split-string phrase) " +")
+ (mapconcat #'regexp-quote (split-string phrase) " +")
(if sub "[^\t\n]*\\)\\([\t\n]\\|$\\)" " *\\([\t\n]\\|$\\)")))
(defun reftex-index-make-replace-string (macro-fmt match index-key
@@ -1868,7 +1849,7 @@ Treats the logical `and' for index phrases."
(unless (stringp reftex-index-phrases-restrict-file)
(widen))
(goto-char (point-min))
- (apply 'reftex-query-index-phrase args))))))
+ (apply #'reftex-query-index-phrase args))))))
(reftex-unhighlight 0)
(set-window-configuration win-conf))))
diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el
index 6e04a5f6ede..0157f8443aa 100644
--- a/lisp/textmodes/reftex-parse.el
+++ b/lisp/textmodes/reftex-parse.el
@@ -1,4 +1,4 @@
-;;; reftex-parse.el --- parser functions for RefTeX
+;;; reftex-parse.el --- parser functions for RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -143,7 +143,7 @@ When allowed, do only a partial scan from FILE."
(car (push (list 'is-multi is-multi) docstruct)))))
(setcdr entry (cons is-multi nil)))
(and reftex--index-tags
- (setq reftex--index-tags (sort reftex--index-tags 'string<)))
+ (setq reftex--index-tags (sort reftex--index-tags #'string<)))
(let ((index-tag-cell (assq 'index-tags docstruct)))
(if index-tag-cell
(setcdr index-tag-cell reftex--index-tags)
@@ -160,10 +160,10 @@ When allowed, do only a partial scan from FILE."
nil))
allxr))
(alist (delq nil alist))
- (allprefix (delq nil (mapcar 'car alist)))
+ (allprefix (delq nil (mapcar #'car alist)))
(regexp (if allprefix
(concat "\\`\\("
- (mapconcat 'identity allprefix "\\|")
+ (mapconcat #'identity allprefix "\\|")
"\\)")
"\\\\\\\\\\\\"))) ; this will never match
(push (list 'xr alist regexp) docstruct)))
@@ -209,7 +209,7 @@ of master file."
(catch 'exit
(setq file-found (reftex-locate-file file "tex" master-dir))
(if (and (not file-found)
- (setq buf (reftex-get-buffer-visiting file)))
+ (setq buf (find-buffer-visiting file)))
(setq file-found (buffer-file-name buf)))
(unless file-found
@@ -384,8 +384,9 @@ of master file."
(concat
;; "\\(\\`\\|[\n\r]\\)[^%]*\\\\\\("
"\\(^\\)[^%\n\r]*\\\\\\("
- (mapconcat 'identity reftex-bibliography-commands "\\|")
- "\\)\\(\\[.+?\\]\\)?{[ \t]*\\([^}]+\\)") nil t))
+ (mapconcat #'identity reftex-bibliography-commands "\\|")
+ "\\)\\(\\[.+?\\]\\)?{[ \t]*\\([^}]+\\)")
+ nil t))
(setq files
(append files
(split-string (reftex-match-string 4)
@@ -532,7 +533,7 @@ Careful: This function expects the match-data to be still in place!"
(key (if prefix (concat prefix rawkey) rawkey))
(sortkey (downcase key))
- (showkey (mapconcat 'identity
+ (showkey (mapconcat #'identity
(split-string key reftex-index-level-re)
" ! ")))
(goto-char end-of-args)
@@ -1046,7 +1047,7 @@ When point is just after a { or [, limit string to matching parenthesis."
;;;###autoload
(defun reftex-init-section-numbers (&optional toc-entry appendix)
- "Initialize the section numbers with zeros or with what is found in the TOC-ENTRY."
+ "Initialize section numbers with zeros or with what is found in the TOC-ENTRY."
(let* ((level (or (nth 5 toc-entry) -1))
(numbers (nreverse (split-string (or (nth 6 toc-entry) "") "\\.")))
(depth (1- (length reftex-section-numbers)))
diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el
index d729ef4031b..611102ecbac 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -1,4 +1,4 @@
-;;; reftex-ref.el --- code to create labels and references with RefTeX
+;;; reftex-ref.el --- code to create labels and references with RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -84,10 +84,12 @@ If optional BOUND is an integer, limit backward searches to that point."
(if (or (re-search-forward
(format reftex-find-label-regexp-format
- (regexp-quote label)) nil t)
+ (regexp-quote label))
+ nil t)
(re-search-forward
(format reftex-find-label-regexp-format2
- (regexp-quote label)) nil t))
+ (regexp-quote label))
+ nil t))
(progn
(backward-char 1)
@@ -248,13 +250,13 @@ This function is controlled by the settings of reftex-insert-label-flags."
""
"POSITION UNCERTAIN. RESCAN TO FIX."))
(file (buffer-file-name))
- (text nil)
+ ;; (text nil)
(tail (memq here-I-am (symbol-value reftex-docstruct-symbol))))
(or (cdr here-I-am-info) (setq rescan-is-useful t))
(when tail
- (push (list label typekey text file nil note) (cdr tail))
+ (push (list label typekey nil file nil note) (cdr tail))
(put reftex-docstruct-symbol 'modified t)))
;; Insert the label into the buffer
@@ -286,7 +288,7 @@ also applies `reftex-translate-to-ascii-function' to the string."
(when (and reftex-translate-to-ascii-function
(fboundp reftex-translate-to-ascii-function))
(setq string (funcall reftex-translate-to-ascii-function string)))
- (apply 'reftex-convert-string string
+ (apply #'reftex-convert-string string
"[-~ \t\n\r,;]+" reftex-label-illegal-re nil nil
reftex-derive-label-parameters))
@@ -402,6 +404,8 @@ also applies `reftex-translate-to-ascii-function' to the string."
a / A Put all marked entries into one/many \\ref commands.
q / RET Quit without referencing / Accept current label (also on mouse-2).")
+(defvar reftex-refstyle)
+
;;;###autoload
(defun reftex-reference (&optional type no-insert cut)
"Make a LaTeX reference. Look only for labels of a certain TYPE.
@@ -473,7 +477,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
;; If the first entry is the symbol 'concat, concat all labels.
;; We keep the cdr of the first label for typekey etc information.
(if (eq (car labels) 'concat)
- (setq labels (list (list (mapconcat 'car (cdr labels) ",")
+ (setq labels (list (list (mapconcat #'car (cdr labels) ",")
(cdr (nth 1 labels))))))
(setq type (nth 1 (car labels))
form (or (cdr (assoc type reftex-typekey-to-format-alist))
@@ -502,7 +506,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
(setq form (substring form 1)))
;; do we have a special format?
(unless (string= reftex-refstyle "\\ref")
- (setq reftex-format-ref-function 'reftex-format-special))
+ (setq reftex-format-ref-function #'reftex-format-special))
;; ok, insert the reference
(if sep1 (insert sep1))
(insert
@@ -744,7 +748,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
;; Goto the file in another window
(setq buffer
(if no-revisit
- (reftex-get-buffer-visiting file)
+ (find-buffer-visiting file)
(reftex-get-file-buffer-force
file (not reftex-keep-temporary-buffers))))
(if buffer
@@ -826,14 +830,16 @@ When called with 2 C-u prefix args, disable magic word recognition."
(dolist (item (nth 2 elt))
(let ((macro (car item))
(package (nth 1 elt)))
- (eval `(defun ,(intern (format "reftex-%s-%s" package
- (substring macro 1 (length macro)))) ()
- ,(format "Insert a reference using the `%s' macro from the %s \
+ (defalias (intern (format "reftex-%s-%s" package
+ (substring macro 1 (length macro))))
+ (lambda ()
+ (:documentation
+ (format "Insert a reference using the `%s' macro from the %s \
package.\n\nThis is a generated function."
- macro package)
- (interactive)
- (let ((reftex-refstyle ,macro))
- (reftex-reference))))))))
+ macro package))
+ (interactive)
+ (let ((reftex-refstyle macro))
+ (reftex-reference))))))))
(defun reftex-format-special (label fmt refstyle)
"Apply selected reference style to format FMT and add LABEL.
@@ -861,9 +867,7 @@ Optional prefix argument OTHER-WINDOW goes to the label in another window."
(default (when (looking-back "\\\\\\(?:page\\)?ref{[-a-zA-Z0-9_*.:]*"
(line-beginning-position))
(reftex-this-word "-a-zA-Z0-9_*.:")))
- (label (completing-read (if default
- (format "Label (default %s): " default)
- "Label: ")
+ (label (completing-read (format-prompt "Label" default)
docstruct
(lambda (x) (stringp (car x))) t nil nil
default))
diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el
index d2e9974499b..b0a8ebf8ac0 100644
--- a/lisp/textmodes/reftex-sel.el
+++ b/lisp/textmodes/reftex-sel.el
@@ -1,4 +1,4 @@
-;;; reftex-sel.el --- the selection modes for RefTeX
+;;; reftex-sel.el --- the selection modes for RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
@@ -34,31 +34,29 @@
(let ((map (make-sparse-keymap)))
(set-keymap-parent map special-mode-map)
(substitute-key-definition
- 'next-line 'reftex-select-next map global-map)
+ #'next-line #'reftex-select-next map global-map)
(substitute-key-definition
- 'previous-line 'reftex-select-previous map global-map)
+ #'previous-line #'reftex-select-previous map global-map)
(substitute-key-definition
- 'keyboard-quit 'reftex-select-keyboard-quit map global-map)
+ #'keyboard-quit #'reftex-select-keyboard-quit map global-map)
(substitute-key-definition
- 'newline 'reftex-select-accept map global-map)
-
- (define-key map " " 'reftex-select-callback)
- (define-key map "n" 'reftex-select-next)
- (define-key map [(down)] 'reftex-select-next)
- (define-key map "p" 'reftex-select-previous)
- (define-key map [(up)] 'reftex-select-previous)
- (define-key map "f" 'reftex-select-toggle-follow)
- (define-key map "\C-m" 'reftex-select-accept)
- (define-key map [(return)] 'reftex-select-accept)
- (define-key map "q" 'reftex-select-quit)
- (define-key map "." 'reftex-select-show-insertion-point)
- (define-key map "?" 'reftex-select-help)
+ #'newline #'reftex-select-accept map global-map)
+
+ (define-key map " " #'reftex-select-callback)
+ (define-key map "n" #'reftex-select-next)
+ (define-key map [(down)] #'reftex-select-next)
+ (define-key map "p" #'reftex-select-previous)
+ (define-key map [(up)] #'reftex-select-previous)
+ (define-key map "f" #'reftex-select-toggle-follow)
+ (define-key map "\C-m" #'reftex-select-accept)
+ (define-key map [(return)] #'reftex-select-accept)
+ (define-key map "q" #'reftex-select-quit)
+ (define-key map "." #'reftex-select-show-insertion-point)
+ (define-key map "?" #'reftex-select-help)
;; 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))
+ (define-key map [(mouse-2)] #'reftex-select-mouse-accept)
+ (define-key map [follow-link] 'mouse-face)
map))
(define-obsolete-variable-alias
@@ -67,25 +65,26 @@
(let ((map (make-sparse-keymap)))
(set-keymap-parent map reftex-select-shared-map)
- (cl-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))))
-
- (define-key map "b" 'reftex-select-jump-to-previous)
- (define-key map "z" 'reftex-select-jump)
- (define-key map "v" 'reftex-select-cycle-ref-style-forward)
- (define-key map "V" 'reftex-select-cycle-ref-style-backward)
- (define-key map "m" 'reftex-select-mark)
- (define-key map "u" 'reftex-select-unmark)
- (define-key map "," 'reftex-select-mark-comma)
- (define-key map "-" 'reftex-select-mark-to)
- (define-key map "+" 'reftex-select-mark-and)
- (define-key map [(tab)] 'reftex-select-read-label)
- (define-key map "\C-i" 'reftex-select-read-label)
- (define-key map "\C-c\C-n" 'reftex-select-next-heading)
- (define-key map "\C-c\C-p" 'reftex-select-previous-heading)
+ (mapc (lambda (key)
+ (define-key map (vector (list key))
+ (lambda ()
+ "Press `?' during selection to find out about this key."
+ (interactive) (throw 'myexit key))))
+ "aAcgFlrRstx#%")
+
+ (define-key map "b" #'reftex-select-jump-to-previous)
+ (define-key map "z" #'reftex-select-jump)
+ (define-key map "v" #'reftex-select-cycle-ref-style-forward)
+ (define-key map "V" #'reftex-select-cycle-ref-style-backward)
+ (define-key map "m" #'reftex-select-mark)
+ (define-key map "u" #'reftex-select-unmark)
+ (define-key map "," #'reftex-select-mark-comma)
+ (define-key map "-" #'reftex-select-mark-to)
+ (define-key map "+" #'reftex-select-mark-and)
+ (define-key map [(tab)] #'reftex-select-read-label)
+ (define-key map "\C-i" #'reftex-select-read-label)
+ (define-key map "\C-c\C-n" #'reftex-select-next-heading)
+ (define-key map "\C-c\C-p" #'reftex-select-previous-heading)
map)
"Keymap used for *RefTeX Select* buffer, when selecting a label.
@@ -104,10 +103,6 @@ Press `?' for a summary of important key bindings.
During a selection process, these are the local bindings.
\\{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))
(set (make-local-variable 'reftex-select-marked) nil)
(when (syntax-table-p reftex-latex-syntax-table)
(set-syntax-table reftex-latex-syntax-table))
@@ -120,16 +115,17 @@ During a selection process, these are the local bindings.
(let ((map (make-sparse-keymap)))
(set-keymap-parent map reftex-select-shared-map)
- (cl-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))))
+ (mapc (lambda (key)
+ (define-key map (vector (list key))
+ (lambda ()
+ "Press `?' during selection to find out about this key."
+ (interactive) (throw 'myexit key))))
+ "grRaAeE")
- (define-key map "\C-i" 'reftex-select-read-cite)
- (define-key map [(tab)] 'reftex-select-read-cite)
- (define-key map "m" 'reftex-select-mark)
- (define-key map "u" 'reftex-select-unmark)
+ (define-key map "\C-i" #'reftex-select-read-cite)
+ (define-key map [(tab)] #'reftex-select-read-cite)
+ (define-key map "m" #'reftex-select-mark)
+ (define-key map "u" #'reftex-select-unmark)
map)
"Keymap used for *RefTeX Select* buffer, when selecting a BibTeX entry.
@@ -148,10 +144,6 @@ Press `?' for a summary of important key bindings.
During a selection process, these are the local bindings.
\\{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))
(set (make-local-variable 'reftex-select-marked) nil)
;; We do not set a local map - reftex-select-item does this.
)
@@ -432,12 +424,21 @@ During a selection process, these are the local bindings.
(defvar reftex-last-data nil)
(defvar reftex-last-line nil)
(defvar reftex-select-marked nil)
+(defvar reftex-refstyle)
+
+;; The following variables are all bound dynamically in `reftex-select-item'.
+
+(defvar reftex-select-data)
+(defvar reftex-select-prompt)
+(defvar reftex--cb-flag)
+(defvar reftex--last-data)
+(defvar reftex--call-back)
+(defvar reftex--help-string)
;;;###autoload
-(defun reftex-select-item (reftex-select-prompt help-string keymap
- &optional offset
- call-back cb-flag)
- ;; Select an item, using REFTEX-SELECT-PROMPT.
+(defun reftex-select-item ( 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
@@ -448,7 +449,12 @@ During a selection process, these are the local bindings.
;; 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)))
+ (let ((reftex-select-prompt prompt)
+ (reftex--help-string help-string)
+ (reftex--call-back call-back)
+ (reftex--cb-flag cb-flag)
+ ev reftex-select-data reftex--last-data
+ (selection-buffer (current-buffer)))
(setq reftex-select-marked nil)
@@ -466,43 +472,29 @@ During a selection process, these are the local bindings.
(unwind-protect
(progn
(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)
+ (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 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))
(recursive-edit))
(set-marker reftex-recursive-edit-marker nil)
(with-current-buffer selection-buffer
(use-local-map nil)
- (remove-hook 'pre-command-hook 'reftex-select-pre-command-hook t)
+ (remove-hook 'pre-command-hook #'reftex-select-pre-command-hook t)
(remove-hook 'post-command-hook
- 'reftex-select-post-command-hook t))
+ #'reftex-select-post-command-hook t))
;; Kill the mark overlays
- (mapc (lambda (c) (reftex-delete-overlay (nth 1 c)))
+ (mapc (lambda (c) (delete-overlay (nth 1 c)))
reftex-select-marked)))))
(set (make-local-variable 'reftex-last-line)
(+ (count-lines (point-min) (point)) (if (bolp) 1 0)))
- (set (make-local-variable 'reftex-last-data) last-data)
+ (set (make-local-variable 'reftex-last-data) reftex--last-data)
(reftex-kill-buffer "*RefTeX Help*")
(setq reftex-callback-fwd (not reftex-callback-fwd)) ;; ;-)))
(message "")
- (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 reftex-select-data)
-(defvar reftex-select-prompt)
-(defvar last-data)
-(defvar call-back)
-(defvar help-string)
-(defvar reftex-refstyle)
+ (list ev reftex-select-data reftex--last-data)))
;; The selection commands
@@ -513,12 +505,12 @@ During a selection process, these are the local bindings.
(defun reftex-select-post-command-hook ()
(let (b e)
(setq reftex-select-data (get-text-property (point) :data))
- (setq last-data (or reftex-select-data last-data))
+ (setq reftex--last-data (or reftex-select-data reftex--last-data))
- (when (and reftex-select-data cb-flag
+ (when (and reftex-select-data reftex--cb-flag
(not (equal reftex-last-follow-point (point))))
(setq reftex-last-follow-point (point))
- (funcall call-back reftex-select-data reftex-callback-fwd
+ (funcall reftex--call-back reftex-select-data reftex-callback-fwd
(not reftex-revisit-to-follow)))
(if reftex-select-data
(setq b (or (previous-single-property-change
@@ -594,7 +586,7 @@ Useful for large TOC's."
"Toggle follow mode: Other window follows with full context."
(interactive)
(setq reftex-last-follow-point -1)
- (setq cb-flag (not cb-flag)))
+ (setq reftex--cb-flag (not reftex--cb-flag)))
(defun reftex-select-cycle-ref-style-internal (&optional reverse)
"Cycle through macros used for referencing.
@@ -632,7 +624,9 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
(defun reftex-select-callback ()
"Show full context in another window."
(interactive)
- (if reftex-select-data (funcall call-back reftex-select-data reftex-callback-fwd nil) (ding)))
+ (if reftex-select-data
+ (funcall reftex--call-back reftex-select-data reftex-callback-fwd nil)
+ (ding)))
(defun reftex-select-accept ()
"Accept the currently selected item."
(interactive)
@@ -642,7 +636,7 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
(interactive "e")
(mouse-set-point ev)
(setq reftex-select-data (get-text-property (point) :data))
- (setq last-data (or reftex-select-data last-data))
+ (setq reftex--last-data (or reftex-select-data reftex--last-data))
(throw 'myexit 'return))
(defun reftex-select-read-label ()
"Use minibuffer to read a label to reference, with completion."
@@ -652,16 +646,19 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
nil nil reftex-prefix)))
(unless (or (equal label "") (equal label reftex-prefix))
(throw 'myexit label))))
+
+(defvar reftex--found-list)
+
(defun reftex-select-read-cite ()
"Use minibuffer to read a citation key with completion."
(interactive)
- (let* ((key (completing-read "Citation key: " found-list))
- (entry (assoc key found-list)))
+ (let* ((key (completing-read "Citation key: " reftex--found-list))
+ (entry (assoc key reftex--found-list)))
(cond
((or (null key) (equal key "")))
(entry
(setq reftex-select-data entry)
- (setq last-data reftex-select-data)
+ (setq reftex--last-data reftex-select-data)
(throw 'myexit 'return))
(t (throw 'myexit key)))))
@@ -676,14 +673,14 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
(setq boe (or (previous-single-property-change (1+ (point)) :data)
(point-min))
eoe (or (next-single-property-change (point) :data) (point-max)))
- (setq ovl (reftex-make-overlay boe eoe))
+ (setq ovl (make-overlay boe eoe))
(push (list data ovl separator) reftex-select-marked)
- (reftex-overlay-put ovl 'font-lock-face reftex-select-mark-face)
- (reftex-overlay-put ovl 'before-string
- (if separator
- (format "*%c%d* " separator
- (length reftex-select-marked))
- (format "*%d* " (length reftex-select-marked))))
+ (overlay-put ovl 'font-lock-face reftex-select-mark-face)
+ (overlay-put ovl 'before-string
+ (if separator
+ (format "*%c%d* " separator
+ (length reftex-select-marked))
+ (format "*%d* " (length reftex-select-marked))))
(message "Entry has mark no. %d" (length reftex-select-marked))))
(defun reftex-select-mark-comma ()
@@ -709,15 +706,15 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
sep)
(unless cell
(error "No marked entry at point"))
- (and ovl (reftex-delete-overlay ovl))
+ (and ovl (delete-overlay ovl))
(setq reftex-select-marked (delq cell reftex-select-marked))
(setq cnt (1+ (length reftex-select-marked)))
(mapc (lambda (c)
(setq sep (nth 2 c))
- (reftex-overlay-put (nth 1 c) 'before-string
- (if sep
- (format "*%c%d* " sep (cl-decf cnt))
- (format "*%d* " (cl-decf cnt)))))
+ (overlay-put (nth 1 c) 'before-string
+ (if sep
+ (format "*%c%d* " sep (cl-decf cnt))
+ (format "*%d* " (cl-decf cnt)))))
reftex-select-marked)
(message "Entry no longer marked")))
@@ -725,7 +722,7 @@ Cycle in reverse order if optional argument REVERSE is non-nil."
"Display a summary of the special key bindings."
(interactive)
(with-output-to-temp-buffer "*RefTeX Help*"
- (princ help-string))
+ (princ reftex--help-string))
(reftex-enlarge-to-fit "*RefTeX Help*" t))
(provide 'reftex-sel)
diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el
index 78d516820ee..b5643491338 100644
--- a/lisp/textmodes/reftex-toc.el
+++ b/lisp/textmodes/reftex-toc.el
@@ -1,4 +1,4 @@
-;;; reftex-toc.el --- RefTeX's table of contents mode
+;;; reftex-toc.el --- RefTeX's table of contents mode -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2000, 2003-2021 Free Software Foundation, Inc.
@@ -32,8 +32,7 @@
(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 [(mouse-2)] #'reftex-toc-mouse-goto-line-and-hide)
(define-key map [follow-link] 'mouse-face)
(substitute-key-definition
@@ -41,34 +40,34 @@
(substitute-key-definition
'previous-line 'reftex-toc-previous map global-map)
- (define-key map "n" 'reftex-toc-next)
- (define-key map "p" 'reftex-toc-previous)
- (define-key map "?" 'reftex-toc-show-help)
- (define-key map " " 'reftex-toc-view-line)
- (define-key map "\C-m" 'reftex-toc-goto-line-and-hide)
- (define-key map "\C-i" 'reftex-toc-goto-line)
- (define-key map "\C-c>" 'reftex-toc-display-index)
- (define-key map "r" 'reftex-toc-rescan)
- (define-key map "R" 'reftex-toc-Rescan)
- (define-key map "q" 'reftex-toc-quit) ;
- (define-key map "k" 'reftex-toc-quit-and-kill)
- (define-key map "f" 'reftex-toc-toggle-follow) ;
- (define-key map "a" 'reftex-toggle-auto-toc-recenter)
- (define-key map "d" 'reftex-toc-toggle-dedicated-frame)
- (define-key map "F" 'reftex-toc-toggle-file-boundary)
- (define-key map "i" 'reftex-toc-toggle-index)
- (define-key map "l" 'reftex-toc-toggle-labels)
- (define-key map "t" 'reftex-toc-max-level)
- (define-key map "c" 'reftex-toc-toggle-context)
- ;; (define-key map "%" 'reftex-toc-toggle-commented)
- (define-key map "\M-%" 'reftex-toc-rename-label)
- (define-key map "x" 'reftex-toc-external)
- (define-key map "z" 'reftex-toc-jump)
- (define-key map "." 'reftex-toc-show-calling-point)
- (define-key map "\C-c\C-n" 'reftex-toc-next-heading)
- (define-key map "\C-c\C-p" 'reftex-toc-previous-heading)
- (define-key map ">" 'reftex-toc-demote)
- (define-key map "<" 'reftex-toc-promote)
+ (define-key map "n" #'reftex-toc-next)
+ (define-key map "p" #'reftex-toc-previous)
+ (define-key map "?" #'reftex-toc-show-help)
+ (define-key map " " #'reftex-toc-view-line)
+ (define-key map "\C-m" #'reftex-toc-goto-line-and-hide)
+ (define-key map "\C-i" #'reftex-toc-goto-line)
+ (define-key map "\C-c>" #'reftex-toc-display-index)
+ (define-key map "r" #'reftex-toc-rescan)
+ (define-key map "R" #'reftex-toc-Rescan)
+ (define-key map "q" #'reftex-toc-quit) ;
+ (define-key map "k" #'reftex-toc-quit-and-kill)
+ (define-key map "f" #'reftex-toc-toggle-follow) ;
+ (define-key map "a" #'reftex-toggle-auto-toc-recenter)
+ (define-key map "d" #'reftex-toc-toggle-dedicated-frame)
+ (define-key map "F" #'reftex-toc-toggle-file-boundary)
+ (define-key map "i" #'reftex-toc-toggle-index)
+ (define-key map "l" #'reftex-toc-toggle-labels)
+ (define-key map "t" #'reftex-toc-max-level)
+ (define-key map "c" #'reftex-toc-toggle-context)
+ ;; (define-key map "%" #'reftex-toc-toggle-commented)
+ (define-key map "\M-%" #'reftex-toc-rename-label)
+ (define-key map "x" #'reftex-toc-external)
+ (define-key map "z" #'reftex-toc-jump)
+ (define-key map "." #'reftex-toc-show-calling-point)
+ (define-key map "\C-c\C-n" #'reftex-toc-next-heading)
+ (define-key map "\C-c\C-p" #'reftex-toc-previous-heading)
+ (define-key map ">" #'reftex-toc-demote)
+ (define-key map "<" #'reftex-toc-promote)
(easy-menu-define
reftex-toc-menu map
@@ -130,9 +129,7 @@ Here are all local bindings.
\\{reftex-toc-mode-map}"
(set (make-local-variable 'transient-mark-mode) t)
- (when (featurep 'xemacs)
- (set (make-local-variable 'zmacs-regions) t))
- (set (make-local-variable 'revert-buffer-function) 'reftex-toc-revert)
+ (set (make-local-variable 'revert-buffer-function) #'reftex-toc-revert)
(set (make-local-variable 'reftex-toc-include-labels-indicator) "")
(set (make-local-variable 'reftex-toc-max-level-indicator)
(if (= reftex-toc-max-level 100)
@@ -146,14 +143,9 @@ Here are all local bindings.
" T<" 'reftex-toc-max-level-indicator ">"
" -%-"))
(setq truncate-lines t)
- (when (featurep 'xemacs)
- ;; XEmacs needs the call to make-local-hook
- (make-local-hook 'post-command-hook)
- (make-local-hook 'pre-command-hook))
(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-mode-map))
+ (add-hook 'post-command-hook #'reftex-toc-post-command-hook nil t)
+ (add-hook 'pre-command-hook #'reftex-toc-pre-command-hook nil t))
(defvar reftex-last-toc-file nil
"Stores the file name from which `reftex-toc' was called. For redo command.")
@@ -419,7 +411,6 @@ SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [l]abels [f]ollow [x]r [?]Help
(defun reftex-toc-next (&optional _arg)
"Move to next selectable item."
(interactive)
- (when (featurep 'xemacs) (setq zmacs-region-stays t))
(setq reftex-callback-fwd t)
(or (eobp) (forward-char 1))
(goto-char (or (next-single-property-change (point) :data)
@@ -427,21 +418,18 @@ SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [l]abels [f]ollow [x]r [?]Help
(defun reftex-toc-previous (&optional _arg)
"Move to previous selectable item."
(interactive)
- (when (featurep 'xemacs) (setq zmacs-region-stays t))
(setq reftex-callback-fwd nil)
(goto-char (or (previous-single-property-change (point) :data)
(point))))
(defun reftex-toc-next-heading (&optional arg)
"Move to next table of contents line."
(interactive "p")
- (when (featurep 'xemacs) (setq zmacs-region-stays t))
(end-of-line)
(re-search-forward "^ " nil t arg)
(beginning-of-line))
(defun reftex-toc-previous-heading (&optional arg)
"Move to previous table of contents line."
(interactive "p")
- (when (featurep 'xemacs) (setq zmacs-region-stays t))
(re-search-backward "^ " nil t arg))
(defun reftex-toc-toggle-follow ()
"Toggle follow (other window follows with context)."
@@ -661,7 +649,7 @@ point."
(let* ((reftex--start-line (+ (count-lines (point-min) (point))
(if (bolp) 1 0)))
(reftex--mark-line
- (if (reftex-region-active-p)
+ (if (region-active-p)
(save-excursion (goto-char (mark))
(+ (count-lines (point-min) (point))
(if (bolp) 1 0)))))
@@ -670,7 +658,7 @@ point."
beg end entries data sections nsec msg)
(setq msg
(catch 'exit
- (if (reftex-region-active-p)
+ (if (region-active-p)
;; A region is dangerous, check if we have a brand new scan,
;; to make sure we are not missing any section statements.
(if (not (reftex-toc-check-docstruct))
@@ -711,7 +699,7 @@ point."
nil ; we have permission, do nothing
(error "Abort")) ; abort, we don't have permission
;; Do the changes
- (mapc 'reftex-toc-promote-action entries)
+ (mapc #'reftex-toc-promote-action entries)
;; Rescan the document and rebuilt the toc buffer
(save-window-excursion
(reftex-toc-Rescan))
@@ -733,10 +721,8 @@ point."
(forward-line (1- point-line)))
(when mpos
(set-mark mpos)
- (if (featurep 'xemacs)
- (zmacs-activate-region)
- (setq mark-active t
- deactivate-mark nil)))))
+ (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.
@@ -850,7 +836,8 @@ if these sets are sorted blocks in the alist."
"Make sure all files of the document are being visited by buffers,
and that the scanning info is absolutely up to date.
We do this by rescanning with `reftex-keep-temporary-buffers' bound to t.
-The variable `reftex--pro-or-de' is assumed to be dynamically scoped into this function.
+The variable `reftex--pro-or-de' is assumed to be dynamically
+scoped into this function.
When finished, we exit with an error message."
(let ((reftex-keep-temporary-buffers t))
(reftex-toc-Rescan)
@@ -916,7 +903,7 @@ label prefix determines the wording of a reference."
(setq match
(let ((where (car toc))
(file (nth 1 toc)))
- (if (or (not no-revisit) (reftex-get-buffer-visiting file))
+ (if (or (not no-revisit) (find-buffer-visiting file))
(progn
(switch-to-buffer-other-window
(reftex-get-file-buffer-force file nil))
@@ -979,7 +966,7 @@ label prefix determines the wording of a reference."
reftex-section-levels-all)))
"[[{]?"))))
((or (not no-revisit)
- (reftex-get-buffer-visiting file))
+ (find-buffer-visiting file))
;; Marker is lost. Use the backup method.
(switch-to-buffer-other-window
(reftex-get-file-buffer-force file nil))
@@ -1033,18 +1020,12 @@ section."
(interactive)
(if reftex-toc-auto-recenter-timer
(progn
- (if (featurep 'xemacs)
- (delete-itimer reftex-toc-auto-recenter-timer)
- (cancel-timer reftex-toc-auto-recenter-timer))
+ (cancel-timer reftex-toc-auto-recenter-timer)
(setq reftex-toc-auto-recenter-timer nil)
(message "Automatic recentering of TOC window was turned off"))
(setq reftex-toc-auto-recenter-timer
- (if (featurep 'xemacs)
- (start-itimer "RefTeX Idle Timer for recenter"
- 'reftex-recenter-toc-when-idle
- reftex-idle-time reftex-idle-time t)
- (run-with-idle-timer
- reftex-idle-time t 'reftex-recenter-toc-when-idle)))
+ (run-with-idle-timer
+ reftex-idle-time t #'reftex-recenter-toc-when-idle))
(message "Automatic recentering of TOC window was turned on")))
(defun reftex-toc-toggle-dedicated-frame ()
@@ -1088,15 +1069,12 @@ always show the current section in connection with the option
(switch-to-buffer "*toc*")
(select-frame current-frame)
(cond ((fboundp 'x-focus-frame)
- (x-focus-frame current-frame))
- ((and (featurep 'xemacs) ; `focus-frame' is a nop in Emacs.
- (fboundp 'focus-frame))
- (focus-frame current-frame)))
+ (x-focus-frame current-frame)))
(select-window current-window)
(when (eq reftex-auto-recenter-toc 'frame)
(unless reftex-toc-auto-recenter-timer
(reftex-toggle-auto-toc-recenter))
- (add-hook 'delete-frame-functions 'reftex-toc-delete-frame-hook)))))
+ (add-hook 'delete-frame-functions #'reftex-toc-delete-frame-hook)))))
(defun reftex-toc-delete-frame-hook (frame)
(if (and reftex-toc-auto-recenter-timer
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index a722eabc6d6..96065ee69e1 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -1,4 +1,4 @@
-;;; reftex-vars.el --- configuration variables for RefTeX
+;;; reftex-vars.el --- configuration variables for RefTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1999, 2001-2021 Free Software Foundation, Inc.
@@ -121,7 +121,7 @@
(regexp "tables?" "tab\\." "Tabellen?"))
("table*" ?t nil nil caption)
- ("\\footnote[]{}" ?n "fn:" "~\\ref{%s}" 2
+ ("\\footnote[]{}" ?n "fn:" "~\\footref{%s}" 2
(regexp "footnotes?" "Fussnoten?"))
("any" ?\ " " "~\\ref{%s}" nil)
@@ -282,7 +282,7 @@ distribution. Mixed-case symbols are convenience aliases.")
The file name is expected after the command, either in braces or separated
by whitespace."
:group 'reftex-table-of-contents-browser
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type '(repeat string))
(defcustom reftex-max-section-depth 12
@@ -319,7 +319,7 @@ commands, promotion only works correctly if this list is sorted first
by set, then within each set by level. The promotion commands always
select the nearest entry with the correct new level."
:group 'reftex-table-of-contents-browser
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type '(repeat
(cons (string :tag "sectioning macro" "")
(choice
@@ -463,7 +463,7 @@ The value of this variable is a list of symbols with associations in the
constant `reftex-label-alist-builtin'. Check that constant for a full list
of options."
:group 'reftex-defining-label-environments
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type `(set
:indent 4
:inline t
@@ -611,7 +611,7 @@ Any list entry may also be a symbol. If that has an association in
list. However, builtin defaults should normally be set with the variable
`reftex-default-label-alist-entries'."
:group 'reftex-defining-label-environments
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type
`(repeat
(choice :tag "Package or Detailed "
@@ -741,8 +741,8 @@ The function must take an argument BOUND. If non-nil, BOUND is a
boundary for backwards searches which should be observed.
Here is an example. The LaTeX package linguex.sty defines list macros
-`\\ex.', `\\a.', etc for lists which are terminated by `\\z.' or an empty
-line.
+`\\ex.', `\\a.', etc for lists which are terminated by `\\z.' or an
+empty line.
\\ex. \\label{ex:12} Some text in an exotic language ...
\\a. \\label{ex:13} more stuff
@@ -766,10 +766,12 @@ And here is the setup for RefTeX:
(save-excursion
;; Search for any of the linguex item macros at the beginning of a line
(if (re-search-backward
- \"^[ \\t]*\\\\(\\\\\\\\\\\\(ex\\\\|a\\\\|b\\\\|c\\\\|d\\\\|e\\\\|f\\\\)g?\\\\.\\\\)\" bound t)
+ (concat \"^[ \\t]*\\\\(\\\\\\\\\\\\(ex\\\\|a\\\\|\"
+ \"b\\\\|c\\\\|d\\\\|e\\\\|f\\\\)g?\\\\.\\\\)\")
+ bound t)
(progn
(setq p1 (match-beginning 1))
- ;; Make sure no empty line or \\z. is between us and the item macro
+ ;; Make sure no empty line or \\z. is between us and item macro
(if (re-search-forward \"\\n[ \\t]*\\n\\\\|\\\\\\\\z\\\\.\" pos t)
;; Return nil because list was already closed
nil
@@ -886,55 +888,53 @@ DOWNCASE t: Downcase words before using them."
(string :tag ""))
(option (boolean :tag "Downcase words "))))
-(if (featurep 'xemacs)
- ;; XEmacs 21.5 doesn't have explicitly numbered matching groups,
- ;; so this list mustn't get any more items.
- (defconst reftex-label-regexps '("\\\\label{\\([^}]*\\)}"))
- (defcustom reftex-label-regexps
- `(;; Normal \\label{foo} labels
- "\\\\label{\\(?1:[^}]*\\)}"
- ;; keyvals [..., label = {foo}, ...] forms used by ctable,
- ;; listings, breqn, ...
- ,(concat
- ;; Make sure we search only for optional arguments of
- ;; environments/macros and don't match any other [. ctable
- ;; provides a macro called \ctable, listings/breqn have
- ;; environments. Start with a backslash and a group for names
- "\\\\\\(?:"
- ;; begin, optional spaces and opening brace
- "begin[[:space:]]*{"
- ;; Build a regexp for env names
- (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup" "darray"))
- ;; closing brace, optional spaces
- "}[[:space:]]*"
- ;; Now for macros
- "\\|"
- ;; Build a regexp for macro names; currently only \ctable
- (regexp-opt '("ctable"))
- ;; Close the group for names
- "\\)"
- ;; Match the opening [ and the following chars
- "\\[[^][]*"
- ;; Allow nested levels of chars enclosed in braces
- "\\(?:{[^}{]*"
- "\\(?:{[^}{]*"
- "\\(?:{[^}{]*}[^}{]*\\)*"
- "}[^}{]*\\)*"
- "}[^][]*\\)*"
- ;; Match the label key
- "\\<label[[:space:]]*=[[:space:]]*"
- ;; Match the label value; braces around the value are
- ;; optional.
- "{?\\(?1:[^] ,}\r\n\t%]+\\)}?"
- ;; We are done. Just search until the next closing bracket
- "[^]]*\\]"))
- "List of regexps matching \\label definitions.
+(defcustom reftex-label-regexps
+ `(;; Normal \\label{foo} labels
+ "\\\\label{\\(?1:[^}]*\\)}"
+ ;; keyvals [..., label = {foo}, ...] forms used by ctable,
+ ;; listings, breqn, ...
+ ,(concat
+ ;; Make sure we search only for optional arguments of
+ ;; environments/macros and don't match any other [. ctable
+ ;; provides a macro called \ctable, beamer/breqn/listings have
+ ;; environments. Start with a backslash and a group for names
+ "\\\\\\(?:"
+ ;; begin, optional spaces and opening brace
+ "begin[[:space:]]*{"
+ ;; Build a regexp for env names
+ (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup"
+ "darray" "frame"))
+ ;; closing brace, optional spaces
+ "}[[:space:]]*"
+ ;; Now for macros
+ "\\|"
+ ;; Build a regexp for macro names; currently only \ctable
+ (regexp-opt '("ctable"))
+ ;; Close the group for names
+ "\\)"
+ ;; Match the opening [ and the following chars
+ "\\[[^][]*"
+ ;; Allow nested levels of chars enclosed in braces
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*}[^}{]*\\)*"
+ "}[^}{]*\\)*"
+ "}[^][]*\\)*"
+ ;; Match the label key
+ "\\<label[[:space:]]*=[[:space:]]*"
+ ;; Match the label value; braces around the value are
+ ;; optional.
+ "{?\\(?1:[^] ,}\r\n\t%]+\\)"
+ ;; We are done. Just search until the next closing bracket
+ "[^]]*\\]"))
+ "List of regexps matching \\label definitions.
The default value matches usual \\label{...} definitions and
keyval style [..., label = {...}, ...] label definitions. The
regexp for keyval style explicitly looks for environments
provided by the packages \"listings\" (\"lstlisting\"),
-\"breqn\" (\"dmath\", \"dseries\", \"dgroup\", \"darray\") and
-the macro \"\\ctable\" provided by the package of the same name.
+\"beamer\" (\"frame\"), \"breqn\" (\"dmath\", \"dseries\",
+\"dgroup\", \"darray\") and the macro \"\\ctable\" provided by
+the package of the same name.
It is assumed that the regexp group 1 matches the label text, so
you have to define it using \\(?1:...\\) when adding new regexps.
@@ -942,13 +942,13 @@ you have to define it using \\(?1:...\\) when adding new regexps.
When changed from Lisp, make sure to call
`reftex-compile-variables' afterwards to make the change
effective."
- :version "27.1"
- :set (lambda (symbol value)
- (set symbol value)
- (when (fboundp 'reftex-compile-variables)
- (reftex-compile-variables)))
- :group 'reftex-defining-label-environments
- :type '(repeat (regexp :tag "Regular Expression"))))
+ :version "28.1"
+ :set (lambda (symbol value)
+ (set symbol value)
+ (when (fboundp 'reftex-compile-variables)
+ (reftex-compile-variables)))
+ :group 'reftex-defining-label-environments
+ :type '(repeat (regexp :tag "Regular Expression")))
(defcustom reftex-label-ignored-macros-and-environments nil
"List of macros and environments to be ignored when searching for labels.
@@ -1059,7 +1059,7 @@ This is used to string together whole reference sets, like
(defcustom reftex-ref-style-alist
'(("Default" t
- (("\\ref" ?\C-m) ("\\Ref" ?R) ("\\pageref" ?p)))
+ (("\\ref" ?\C-m) ("\\Ref" ?R) ("\\footref" ?n) ("\\pageref" ?p)))
("Varioref" "varioref"
(("\\vref" ?v) ("\\Vref" ?V) ("\\vpageref" ?g)))
("Fancyref" "fancyref"
@@ -1079,7 +1079,7 @@ the macro type is being prompted for. (See also
`reftex-ref-macro-prompt'.) The keys, represented as characters,
have to be unique."
:group 'reftex-referencing-labels
- :version "27.1"
+ :version "28.1"
:type '(alist :key-type (string :tag "Style name")
:value-type (group (choice :tag "Package"
(const :tag "Any package" t)
@@ -1194,7 +1194,7 @@ File names matched by these regexps will not be parsed by RefTeX.
Intended for files which contain only `@string' macro definitions and the
like, which are ignored by RefTeX anyway."
:group 'reftex-citation-support
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type '(repeat (regexp)))
(defcustom reftex-default-bibliography nil
@@ -1314,7 +1314,7 @@ macro before insertion. For example, it will change
\\cite[][Chapter 1]{Jones} -> \\cite[Chapter 1]{Jones}
\\cite[see][]{Jones} -> \\cite[see][]{Jones}
\\cite[see][Chapter 1]{Jones} -> \\cite{Jones}
-Is is possible that other packages have other conventions about which
+It is possible that other packages have other conventions about which
optional argument is interpreted how - that is why this cleaning up
can be turned off."
:group 'reftex-citation-support
@@ -1456,7 +1456,7 @@ Note that AUCTeX sets these things internally for RefTeX as well, so
with a sufficiently new version of AUCTeX, you should not set the
package here."
:group 'reftex-index-support
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type `(list
(repeat
:inline t
@@ -1724,7 +1724,7 @@ Multiple directories can be separated by the system dependent `path-separator'.
Directories ending in `//' or `!!' will be expanded recursively.
See also `reftex-use-external-file-finders'."
:group 'reftex-finding-files
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type '(repeat (string :tag "Specification")))
(defcustom reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB")
@@ -1740,7 +1740,7 @@ Directories ending in `//' or `!!' will be expanded recursively.
See also `reftex-use-external-file-finders'."
:group 'reftex-citation-support
:group 'reftex-finding-files
- :set 'reftex-set-dirty
+ :set #'reftex-set-dirty
:type '(repeat (string :tag "Specification")))
(defcustom reftex-file-extensions '(("tex" . (".tex" ".ltx"))
@@ -2100,6 +2100,8 @@ construct: \\bbb [xxx] {aaa}."
"Hook which is being run when loading reftex.el."
:group 'reftex-miscellaneous-configurations
:type 'hook)
+(make-obsolete-variable 'reftex-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom reftex-mode-hook nil
"Hook which is being run when turning on RefTeX mode."
diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el
index 65072d60f0a..c732299361c 100644
--- a/lisp/textmodes/reftex.el
+++ b/lisp/textmodes/reftex.el
@@ -1,4 +1,4 @@
-;;; reftex.el --- minor mode for doing \label, \ref, \cite, \index in LaTeX
+;;; reftex.el --- minor mode for doing \label, \ref, \cite, \index in LaTeX -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2000, 2003-2021 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@science.uva.nl>
@@ -38,9 +38,8 @@
;;
;; https://www.gnu.org/software/auctex/manual/reftex.index.html
;;
-;; RefTeX is bundled with Emacs and available as a plug-in package for
-;; XEmacs 21.x. If you need to install it yourself, you can find a
-;; distribution at
+;; RefTeX is bundled with Emacs.
+;; If you need to install it yourself, you can find a distribution at
;;
;; https://www.gnu.org/software/auctex/reftex.html
;;
@@ -51,11 +50,8 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-
-;; Stuff that needs to be there when we use defcustom
-(require 'custom)
-
-(require 'easymenu)
+(when (< emacs-major-version 28) ; preloaded in Emacs 28
+ (require 'easymenu))
(defvar reftex-tables-dirty t
"Flag showing if tables need to be re-computed.")
@@ -103,37 +99,34 @@
(defvar reftex-mode-map
(let ((map (make-sparse-keymap)))
;; The default bindings in the mode map.
- (define-key map "\C-c=" 'reftex-toc)
- (define-key map "\C-c-" 'reftex-toc-recenter)
- (define-key map "\C-c(" 'reftex-label)
- (define-key map "\C-c)" 'reftex-reference)
- (define-key map "\C-c[" 'reftex-citation)
- (define-key map "\C-c<" 'reftex-index)
- (define-key map "\C-c>" 'reftex-display-index)
- (define-key map "\C-c/" 'reftex-index-selection-or-word)
- (define-key map "\C-c\\" 'reftex-index-phrase-selection-or-word)
- (define-key map "\C-c|" 'reftex-index-visit-phrases-buffer)
- (define-key map "\C-c&" 'reftex-view-crossref)
+ (define-key map "\C-c=" #'reftex-toc)
+ (define-key map "\C-c-" #'reftex-toc-recenter)
+ (define-key map "\C-c(" #'reftex-label)
+ (define-key map "\C-c)" #'reftex-reference)
+ (define-key map "\C-c[" #'reftex-citation)
+ (define-key map "\C-c<" #'reftex-index)
+ (define-key map "\C-c>" #'reftex-display-index)
+ (define-key map "\C-c/" #'reftex-index-selection-or-word)
+ (define-key map "\C-c\\" #'reftex-index-phrase-selection-or-word)
+ (define-key map "\C-c|" #'reftex-index-visit-phrases-buffer)
+ (define-key map "\C-c&" #'reftex-view-crossref)
;; Bind `reftex-mouse-view-crossref' only when the key is still free
- (if (featurep 'xemacs)
- (unless (key-binding [(shift button2)])
- (define-key map [(shift button2)] 'reftex-mouse-view-crossref))
- (unless (key-binding [(shift mouse-2)])
- (define-key map [(shift mouse-2)] 'reftex-mouse-view-crossref)))
+ (unless (key-binding [(shift mouse-2)])
+ (define-key map [(shift mouse-2)] #'reftex-mouse-view-crossref))
;; For most of these commands there are already bindings in place.
;; Setting `reftex-extra-bindings' really is only there to spare users
;; the hassle of defining bindings in the user space themselves. This
;; is why they violate the key binding recommendations.
(when reftex-extra-bindings
- (define-key map "\C-ct" 'reftex-toc)
- (define-key map "\C-cl" 'reftex-label)
- (define-key map "\C-cr" 'reftex-reference)
- (define-key map "\C-cc" 'reftex-citation)
- (define-key map "\C-cv" 'reftex-view-crossref)
- (define-key map "\C-cg" 'reftex-grep-document)
- (define-key map "\C-cs" 'reftex-search-document))
+ (define-key map "\C-ct" #'reftex-toc)
+ (define-key map "\C-cl" #'reftex-label)
+ (define-key map "\C-cr" #'reftex-reference)
+ (define-key map "\C-cc" #'reftex-citation)
+ (define-key map "\C-cv" #'reftex-view-crossref)
+ (define-key map "\C-cg" #'reftex-grep-document)
+ (define-key map "\C-cs" #'reftex-search-document))
map)
"Keymap for RefTeX mode.")
@@ -207,7 +200,6 @@ on the menu bar.
(if reftex-mode
(progn
;; Mode was turned on
- (easy-menu-add reftex-mode-menu)
(and reftex-plug-into-AUCTeX
(reftex-plug-into-AUCTeX))
(unless (get 'reftex-auto-view-crossref 'initialized)
@@ -222,9 +214,7 @@ on the menu bar.
;; Prepare the special syntax tables.
(reftex--prepare-syntax-tables)
- (run-hooks 'reftex-mode-hook))
- ;; Mode was turned off
- (easy-menu-remove reftex-mode-menu)))
+ (run-hooks 'reftex-mode-hook))))
(defvar reftex-docstruct-symbol)
(defun reftex-kill-buffer-hook ()
@@ -392,11 +382,11 @@ If the symbols for the current master file do not exist, they are created."
((null master)
(error "Need a filename for this buffer, please save it first"))
((or (file-exists-p (concat master ".tex"))
- (reftex-get-buffer-visiting (concat master ".tex")))
+ (find-buffer-visiting (concat master ".tex")))
;; Ahh, an extra .tex was missing...
(setq master (concat master ".tex")))
((or (file-exists-p master)
- (reftex-get-buffer-visiting master))
+ (find-buffer-visiting master))
;; We either see the file, or have a buffer on it. OK.
)
(t
@@ -891,7 +881,7 @@ This enforces rescanning the buffer on next use."
;; Are the magic words regular expressions? Quote normal words.
(if (eq (car wordlist) 'regexp)
(setq wordlist (cdr wordlist))
- (setq wordlist (mapcar 'regexp-quote wordlist)))
+ (setq wordlist (mapcar #'regexp-quote wordlist)))
;; Remember the first association of each word.
(while (stringp (setq word (pop wordlist)))
(or (assoc word reftex-words-to-typekey-alist)
@@ -1018,11 +1008,11 @@ This enforces rescanning the buffer on next use."
(wbol "\\(^\\)%?[ \t]*") ; Need to keep the empty group because
; match numbers are hard coded
(label-re (concat "\\(?:"
- (mapconcat 'identity reftex-label-regexps "\\|")
+ (mapconcat #'identity reftex-label-regexps "\\|")
"\\)"))
(include-re (concat wbol
"\\\\\\("
- (mapconcat 'identity
+ (mapconcat #'identity
reftex-include-file-commands "\\|")
"\\)[{ \t]+\\([^} \t\n\r]+\\)"))
(section-re
@@ -1034,23 +1024,24 @@ This enforces rescanning the buffer on next use."
(macro-re
(if macros-with-labels
(concat "\\("
- (mapconcat 'regexp-quote macros-with-labels "\\|")
+ (mapconcat #'regexp-quote macros-with-labels "\\|")
"\\)[[{]")
""))
(index-re
(concat "\\("
- (mapconcat 'regexp-quote reftex-macros-with-index "\\|")
+ (mapconcat #'regexp-quote reftex-macros-with-index "\\|")
"\\)[[{]"))
(find-index-re-format
(concat "\\("
- (mapconcat 'regexp-quote reftex-macros-with-index "\\|")
+ (mapconcat #'regexp-quote reftex-macros-with-index "\\|")
"\\)\\([[{][^]}]*[]}]\\)*[[{]\\(%s\\)[]}]"))
(find-label-re-format
(concat "\\("
"label[[:space:]]*=[[:space:]]*"
"\\|"
- (mapconcat 'regexp-quote (append '("\\label")
- macros-with-labels) "\\|")
+ (mapconcat #'regexp-quote (append '("\\label")
+ macros-with-labels)
+ "\\|")
"\\)\\([[{][^]}]*[]}]\\)*[[{]\\(%s\\)[]}]"))
(index-level-re
(regexp-quote (nth 0 reftex-index-special-chars)))
@@ -1082,7 +1073,7 @@ This enforces rescanning the buffer on next use."
"\\([]} \t\n\r]\\)\\([[{]\\)\\(%s\\)[]}]")
(message "Compiling label environment definitions...done")))
(put reftex-docstruct-symbol 'reftex-cache
- (mapcar 'symbol-value reftex-cache-variables)))
+ (mapcar #'symbol-value reftex-cache-variables)))
(defun reftex-parse-args (macro)
;; Return a list of macro name, nargs, arg-nr which is label and a list of
@@ -1278,8 +1269,8 @@ Valid actions are: readable, restore, read, kill, write."
(- 1 xr-index))
(t
(save-excursion
- (let* ((length (apply 'max (mapcar
- (lambda(x) (length (car x))) xr-alist)))
+ (let* ((length (apply #'max (mapcar
+ (lambda(x) (length (car x))) xr-alist)))
(fmt (format " [%%c] %%-%ds %%s\n" length))
(n (1- ?0)))
(setq key
@@ -1313,7 +1304,7 @@ When DIE is non-nil, throw an error if file not found."
(extensions (cdr (assoc type reftex-file-extensions)))
(def-ext (car extensions))
(ext-re (concat "\\("
- (mapconcat 'regexp-quote extensions "\\|")
+ (mapconcat #'regexp-quote extensions "\\|")
"\\)\\'"))
(files (if (string-match ext-re file)
(cons file nil)
@@ -1355,7 +1346,7 @@ When DIE is non-nil, throw an error if file not found."
out)
(if (string-match "%f" prg)
(setq prg (replace-match file t t prg)))
- (setq out (apply 'reftex-process-string (split-string prg)))
+ (setq out (apply #'reftex-process-string (split-string prg)))
(if (string-match "[ \t\n]+\\'" out) ; chomp
(setq out (replace-match "" nil nil out)))
(cond ((equal out "") nil)
@@ -1368,7 +1359,7 @@ When DIE is non-nil, throw an error if file not found."
(with-output-to-string
(with-current-buffer standard-output
(let ((default-directory calling-dir)) ; set default directory
- (apply 'call-process program nil '(t nil) nil args))))))
+ (apply #'call-process program nil '(t nil) nil args))))))
(defun reftex-access-search-path (type &optional recurse master-dir file)
;; Access path from environment variables. TYPE is either "tex" or "bib".
@@ -1387,7 +1378,7 @@ When DIE is non-nil, throw an error if file not found."
(mapconcat
(lambda(x)
(if (string-match "^!" x)
- (apply 'reftex-process-string
+ (apply #'reftex-process-string
(split-string (substring x 1)))
(or (getenv x) x)))
;; For consistency, the next line should look like this:
@@ -1532,12 +1523,7 @@ When DIE is non-nil, throw an error if file not found."
(when (match-beginning n)
(buffer-substring-no-properties (match-beginning n) (match-end n))))
-(defun reftex-region-active-p ()
- "Should we operate on an active region?"
- (if (fboundp 'use-region-p)
- (use-region-p)
- ;; For XEmacs.
- (region-active-p)))
+(define-obsolete-function-alias 'reftex-region-active-p #'use-region-p "28.1")
(defun reftex-kill-buffer (buffer)
;; Kill buffer if it exists.
@@ -1746,26 +1732,12 @@ When DIE is non-nil, throw an error if file not found."
(setq string (replace-match "[\n\r]" nil t string)))
string))
-(defun reftex-get-buffer-visiting (file)
- ;; return a buffer visiting FILE
- (cond
- ((boundp 'find-file-compare-truenames) ; XEmacs
- (let ((find-file-compare-truenames t))
- (get-file-buffer file)))
- ((fboundp 'find-buffer-visiting) ; Emacs
- (find-buffer-visiting file))
- (t (error "This should not happen (reftex-get-buffer-visiting)"))))
-
-;; Define `current-message' for compatibility with XEmacs prior to 20.4
-(defvar message-stack)
-(if (and (featurep 'xemacs)
- (not (fboundp 'current-message)))
- (defun current-message (&optional _frame)
- (cdr (car message-stack))))
+(define-obsolete-function-alias 'reftex-get-buffer-visiting
+ #'find-buffer-visiting "28.1")
(defun reftex-visited-files (list)
;; Takes a list of filenames and returns the buffers of those already visited
- (delq nil (mapcar (lambda (x) (if (reftex-get-buffer-visiting x) x nil))
+ (delq nil (mapcar (lambda (x) (if (find-buffer-visiting x) x nil))
list)))
(defun reftex-get-file-buffer-force (file &optional mark-to-kill)
@@ -1775,7 +1747,7 @@ When DIE is non-nil, throw an error if file not found."
;; initializations according to `reftex-initialize-temporary-buffers',
;; and mark the buffer to be killed after use.
- (let ((buf (reftex-get-buffer-visiting file)))
+ (let ((buf (find-buffer-visiting file)))
(cond (buf
;; We have it already as a buffer - just return it
@@ -1867,7 +1839,7 @@ When DIE is non-nil, throw an error if file not found."
(setq list (copy-sequence list))
(if sort
(progn
- (setq list (sort list 'string<))
+ (setq list (sort list #'string<))
(let ((p list))
(while (cdr p)
(if (string= (car p) (car (cdr p)))
@@ -2004,7 +1976,7 @@ IGNORE-WORDS List of words which should be removed from the string."
(setcdr (nthcdr (1- nwords) words) nil))
;; First, try to use all words
- (setq string (mapconcat 'identity words sep))
+ (setq string (mapconcat #'identity words sep))
;; Abbreviate words if enforced by user settings or string length
(if (or (eq t abbrev)
@@ -2018,7 +1990,7 @@ IGNORE-WORDS List of words which should be removed from the string."
(match-string 1 w))
w))
words)
- string (mapconcat 'identity words sep)))
+ string (mapconcat #'identity words sep)))
;; Shorten if still to long
(setq string
@@ -2082,24 +2054,11 @@ IGNORE-WORDS List of words which should be removed from the string."
(progn
;; Rename buffer temporarily to start w/o space (because of font-lock)
(rename-buffer newname t)
- (cond
- ((fboundp 'font-lock-default-fontify-region)
- ;; Good: we have the indirection functions
- (set (make-local-variable 'font-lock-fontify-region-function)
- 'reftex-select-font-lock-fontify-region)
- (let ((major-mode 'latex-mode))
- (font-lock-mode 1)))
- ((fboundp 'font-lock-set-defaults-1)
- ;; Looks like the XEmacs font-lock stuff.
- ;; FIXME: this is still kind of a hack, but it works.
- (set (make-local-variable 'font-lock-keywords) nil)
- (let ((major-mode 'latex-mode)
- (font-lock-defaults-computed nil))
- (font-lock-set-defaults-1)
- (reftex-select-font-lock-fontify-region (point-min) (point-max))))
- (t
- ;; Oops?
- (message "Sorry: cannot refontify RefTeX Select buffer."))))
+ ;; Good: we have the indirection functions
+ (set (make-local-variable 'font-lock-fontify-region-function)
+ #'reftex-select-font-lock-fontify-region)
+ (let ((major-mode 'latex-mode))
+ (font-lock-mode 1)))
(rename-buffer oldname))))
(defun reftex-select-font-lock-fontify-region (beg end &optional _loudly)
@@ -2124,46 +2083,39 @@ IGNORE-WORDS List of words which should be removed from the string."
(let (face)
(catch 'exit
(while (setq face (pop faces))
- (if (featurep 'xemacs)
- (if (find-face face) (throw 'exit face))
- (if (facep face) (throw 'exit face)))))))
-
-;; Highlighting uses overlays. For XEmacs, we use extends.
-(defalias 'reftex-make-overlay
- (if (featurep 'xemacs) 'make-extent 'make-overlay))
-(defalias 'reftex-overlay-put
- (if (featurep 'xemacs) 'set-extent-property 'overlay-put))
-(defalias 'reftex-move-overlay
- (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay))
-(defalias 'reftex-delete-overlay
- (if (featurep 'xemacs) 'detach-extent 'delete-overlay))
+ (if (facep face) (throw 'exit face))))))
+
+(define-obsolete-function-alias 'reftex-make-overlay #'make-overlay "28.1")
+(define-obsolete-function-alias 'reftex-overlay-put #'overlay-put "28.1")
+(define-obsolete-function-alias 'reftex-move-overlay #'move-overlay "28.1")
+(define-obsolete-function-alias 'reftex-delete-overlay #'delete-overlay "28.1")
;; We keep a vector with several different overlays to do our highlighting.
(defvar reftex-highlight-overlays [nil nil nil])
;; Initialize the overlays
-(aset reftex-highlight-overlays 0 (reftex-make-overlay 1 1))
-(reftex-overlay-put (aref reftex-highlight-overlays 0)
+(aset reftex-highlight-overlays 0 (make-overlay 1 1))
+(overlay-put (aref reftex-highlight-overlays 0)
'face 'highlight)
-(aset reftex-highlight-overlays 1 (reftex-make-overlay 1 1))
-(reftex-overlay-put (aref reftex-highlight-overlays 1)
+(aset reftex-highlight-overlays 1 (make-overlay 1 1))
+(overlay-put (aref reftex-highlight-overlays 1)
'face reftex-cursor-selected-face)
-(aset reftex-highlight-overlays 2 (reftex-make-overlay 1 1))
-(reftex-overlay-put (aref reftex-highlight-overlays 2)
+(aset reftex-highlight-overlays 2 (make-overlay 1 1))
+(overlay-put (aref reftex-highlight-overlays 2)
'face reftex-cursor-selected-face)
;; Two functions for activating and deactivation highlight overlays
(defun reftex-highlight (index begin end &optional buffer)
"Highlight a region with overlay INDEX."
- (reftex-move-overlay (aref reftex-highlight-overlays index)
+ (move-overlay (aref reftex-highlight-overlays index)
begin end (or buffer (current-buffer))))
(defun reftex-unhighlight (index)
"Detach overlay INDEX."
- (reftex-delete-overlay (aref reftex-highlight-overlays index)))
+ (delete-overlay (aref reftex-highlight-overlays index)))
(defun reftex-highlight-shall-die ()
;; Function used in pre-command-hook to remove highlights.
- (remove-hook 'pre-command-hook 'reftex-highlight-shall-die)
+ (remove-hook 'pre-command-hook #'reftex-highlight-shall-die)
(reftex-unhighlight 0))
;;; =========================================================================
@@ -2175,7 +2127,7 @@ IGNORE-WORDS List of words which should be removed from the string."
;; Bind `reftex-view-crossref-from-bibtex' in BibTeX mode map
(eval-after-load
"bibtex"
- '(define-key bibtex-mode-map "\C-c&" 'reftex-view-crossref-from-bibtex))
+ '(define-key bibtex-mode-map "\C-c&" #'reftex-view-crossref-from-bibtex))
;;; =========================================================================
;;;
@@ -2371,7 +2323,7 @@ what in fact did happen.
Check if the bug is reproducible with an up-to-date version of
RefTeX available from https://www.gnu.org/software/auctex/.
-If the bug is triggered by a specific \(La)TeX file, you should try
+If the bug is triggered by a specific (La)TeX file, you should try
to produce a minimal sample file showing the problem and include it
in your report.
@@ -2380,9 +2332,9 @@ Your bug report will be posted to the AUCTeX bug reporting list.
;;; Install the kill-buffer and kill-emacs hooks ------------------------------
-(add-hook 'kill-buffer-hook 'reftex-kill-buffer-hook)
+(add-hook 'kill-buffer-hook #'reftex-kill-buffer-hook)
(unless noninteractive
- (add-hook 'kill-emacs-hook 'reftex-kill-emacs-hook))
+ (add-hook 'kill-emacs-hook #'reftex-kill-emacs-hook))
;;; Run Hook ------------------------------------------------------------------
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index 35ed825bb09..fbb66fe40e9 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -1,11 +1,11 @@
-;;; remember --- a mode for quickly jotting down things to remember
+;;; remember.el --- a mode for quickly jotting down things to remember -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2001, 2003-2021 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: emacs-devel@gnu.org
;; Created: 29 Mar 1999
-;; Version: 2.0
+;; Old-Version: 2.0
;; Keywords: data memory todo pim
;; URL: http://gna.org/projects/remember-el/
@@ -159,7 +159,8 @@
;; ;; This should be before other entries that may return t
;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries)
;;
-;; This module recognizes entries of the form
+;; This module recognizes entries of the form (defined by
+;; `remember-diary-regexp')
;;
;; DIARY: ....
;;
@@ -175,13 +176,8 @@
;;
;; 2003.08.12 Sacha's birthday
-;;; History:
-
;;; Code:
-(defconst remember-version "2.0"
- "This version of remember.")
-
(defgroup remember nil
"A mode to remember information."
:group 'data)
@@ -191,24 +187,20 @@
(defcustom remember-mode-hook nil
"Functions run upon entering `remember-mode'."
:type 'hook
- :options '(flyspell-mode turn-on-auto-fill org-remember-apply-template)
- :group 'remember)
+ :options '(flyspell-mode turn-on-auto-fill org-remember-apply-template))
(defcustom remember-in-new-frame nil
"Non-nil means use a separate frame for capturing remember data."
- :type 'boolean
- :group 'remember)
+ :type 'boolean)
(defcustom remember-register ?R
"The register in which the window configuration is stored."
- :type 'character
- :group 'remember)
+ :type 'character)
(defcustom remember-filter-functions nil
"Functions run to filter remember data.
All functions are run in the remember buffer."
- :type 'hook
- :group 'remember)
+ :type 'hook)
(defcustom remember-handler-functions '(remember-append-to-file)
"Functions run to process remember data.
@@ -221,54 +213,50 @@ recorded somewhere by that function."
remember-append-to-file
remember-store-in-files
remember-diary-extract-entries
- org-remember-handler)
- :group 'remember)
+ org-remember-handler))
(defcustom remember-all-handler-functions nil
"If non-nil every function in `remember-handler-functions' is called."
- :type 'boolean
- :group 'remember)
+ :type 'boolean)
;; See below for more user variables.
;;; Internal Variables:
-(defvar remember-buffer "*Remember*"
- "The name of the remember data entry buffer.")
+(defcustom remember-buffer "*Remember*"
+ "The name of the remember data entry buffer."
+ :version "28.1"
+ :type 'string)
(defcustom remember-save-after-remembering t
"Non-nil means automatically save after remembering."
- :type 'boolean
- :group 'remember)
+ :type 'boolean)
;;; User Functions:
(defcustom remember-annotation-functions '(buffer-file-name)
"Hook that returns an annotation to be inserted into the remember buffer."
:type 'hook
- :options '(org-remember-annotation buffer-file-name)
- :group 'remember)
+ :options '(org-remember-annotation buffer-file-name))
(defvar remember-annotation nil
"Current annotation.")
(defvar remember-initial-contents nil
- "Initial contents to place into *Remember* buffer.")
+ "Initial contents to place into `remember-buffer'.")
(defcustom remember-before-remember-hook nil
- "Functions run before switching to the *Remember* buffer."
- :type 'hook
- :group 'remember)
+ "Functions run before switching to the `remember-buffer'."
+ :type 'hook)
(defcustom remember-run-all-annotation-functions-flag nil
"Non-nil means use all annotations returned by `remember-annotation-functions'."
- :type 'boolean
- :group 'remember)
+ :type 'boolean)
;;;###autoload
(defun remember (&optional initial)
"Remember an arbitrary piece of data.
-INITIAL is the text to initially place in the *Remember* buffer,
-or nil to bring up a blank *Remember* buffer.
+INITIAL is the text to initially place in the `remember-buffer',
+or nil to bring up a blank `remember-buffer'.
With a prefix or a visible region, use the region as INITIAL."
(interactive
@@ -278,12 +266,13 @@ With a prefix or a visible region, use the region as INITIAL."
(buffer-substring (region-beginning) (region-end)))))
(funcall (if remember-in-new-frame
#'frameset-to-register
- #'window-configuration-to-register) remember-register)
+ #'window-configuration-to-register)
+ remember-register)
(let* ((annotation
(if remember-run-all-annotation-functions-flag
- (mapconcat 'identity
+ (mapconcat #'identity
(delq nil
- (mapcar 'funcall remember-annotation-functions))
+ (mapcar #'funcall remember-annotation-functions))
"\n")
(run-hook-with-args-until-success
'remember-annotation-functions)))
@@ -291,7 +280,8 @@ With a prefix or a visible region, use the region as INITIAL."
(run-hooks 'remember-before-remember-hook)
(funcall (if remember-in-new-frame
#'switch-to-buffer-other-frame
- #'switch-to-buffer-other-window) buf)
+ #'switch-to-buffer-other-window)
+ buf)
(if remember-in-new-frame
(set-window-dedicated-p
(get-buffer-window (current-buffer) (selected-frame)) t))
@@ -335,13 +325,11 @@ With a prefix or a visible region, use the region as INITIAL."
(defcustom remember-mailbox "~/Mail/remember"
"The file in which to store remember data as mail."
- :type 'file
- :group 'remember)
+ :type 'file)
(defcustom remember-default-priority "medium"
"The default priority for remembered mail messages."
- :type 'string
- :group 'remember)
+ :type 'string)
(defun remember-store-in-mailbox ()
"Store remember data as if it were incoming mail.
@@ -394,28 +382,35 @@ exists) might be changed."
(with-current-buffer buf
(set-visited-file-name
(expand-file-name remember-data-file))))))
- :initialize 'custom-initialize-default
- :group 'remember)
+ :initialize #'custom-initialize-default)
(defcustom remember-leader-text "** "
"The text used to begin each remember item."
- :type 'string
- :group 'remember)
+ :type 'string)
(defcustom remember-time-format "%a %b %d %H:%M:%S %Y"
"The format for time stamp, passed to `format-time-string'.
The default emulates `current-time-string' for backward compatibility."
:type 'string
- :group 'remember
:version "27.1")
+(defcustom remember-text-format-function nil
+ "The function to format the remembered text.
+The function receives the remembered text as argument and should
+return the text to be remembered."
+ :type '(choice (const nil) function)
+ :version "28.1")
+
(defun remember-append-to-file ()
"Remember, with description DESC, the given TEXT."
(let* ((text (buffer-string))
(desc (remember-buffer-desc))
- (remember-text (concat "\n" remember-leader-text
- (format-time-string remember-time-format)
- " (" desc ")\n\n" text
+ (remember-text (concat "\n"
+ (if remember-text-format-function
+ (funcall remember-text-format-function text)
+ (concat remember-leader-text
+ (format-time-string remember-time-format)
+ " (" desc ")\n\n" text))
(save-excursion (goto-char (point-max))
(if (bolp) nil "\n"))))
(buf (find-buffer-visiting remember-data-file)))
@@ -429,7 +424,7 @@ The default emulates `current-time-string' for backward compatibility."
(defun remember-region (&optional beg end)
"Remember the data from BEG to END.
-It is called from within the *Remember* buffer to save the text
+It is called from within the `remember-buffer' to save the text
that was entered.
If BEG and END are nil, the entire buffer will be remembered.
@@ -452,16 +447,14 @@ If you want to remember a region, supply a universal prefix to
"The directory in which to store remember data as files.
Used by `remember-store-in-files'."
:type 'directory
- :version "24.4"
- :group 'remember)
+ :version "24.4")
(defcustom remember-directory-file-name-format "%Y-%m-%d_%T-%z"
"Format string for the file name in which to store unprocessed data.
This is passed to `format-time-string'.
Used by `remember-store-in-files'."
:type 'string
- :version "24.4"
- :group 'remember)
+ :version "24.4")
(defun remember-store-in-files ()
"Store remember data in a file in `remember-data-directory'.
@@ -486,11 +479,8 @@ Most useful for remembering things from other applications."
(interactive)
(remember-region (point-min) (point-max)))
-;; Org needs this
-(define-obsolete-function-alias 'remember-buffer 'remember-finalize "23.1")
-
(defun remember-destroy ()
- "Destroy the current *Remember* buffer."
+ "Destroy the current `remember-buffer'."
(interactive)
(when (equal remember-buffer (buffer-name))
(kill-buffer (current-buffer))
@@ -501,8 +491,7 @@ Most useful for remembering things from other applications."
(defcustom remember-diary-file nil
"File for extracted diary entries.
If this is nil, then `diary-file' will be used instead."
- :type '(choice (const :tag "diary-file" nil) file)
- :group 'remember)
+ :type '(choice (const :tag "diary-file" nil) file))
(defvar calendar-date-style) ; calendar.el
@@ -534,26 +523,37 @@ If this is nil, then `diary-file' will be used instead."
(autoload 'diary-make-entry "diary-lib")
+(defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)"
+ "Regexp to extract diary entries."
+ :type 'regexp
+ :version "28.1")
+
+(defvar diary-file)
+
;;;###autoload
(defun remember-diary-extract-entries ()
- "Extract diary entries from the region."
+ "Extract diary entries from the region based on `remember-diary-regexp'."
(save-excursion
(goto-char (point-min))
(let (list)
- (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t)
+ (while (re-search-forward remember-diary-regexp nil t)
(push (remember-diary-convert-entry (match-string 1)) list))
(when list
- (diary-make-entry (mapconcat 'identity list "\n")
- nil remember-diary-file))
+ (diary-make-entry (mapconcat #'identity list "\n")
+ nil remember-diary-file)
+ (when remember-save-after-remembering
+ (with-current-buffer (find-buffer-visiting (or remember-diary-file
+ diary-file))
+ (save-buffer))))
nil))) ;; Continue processing
;;; Internal Functions:
(defvar remember-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-x\C-s" 'remember-finalize)
- (define-key map "\C-c\C-c" 'remember-finalize)
- (define-key map "\C-c\C-k" 'remember-destroy)
+ (define-key map "\C-x\C-s" #'remember-finalize)
+ (define-key map "\C-c\C-c" #'remember-finalize)
+ (define-key map "\C-c\C-k" #'remember-destroy)
map)
"Keymap used in `remember-mode'.")
@@ -599,7 +599,7 @@ If this is nil, use `initial-major-mode'."
(defvar remember-notes-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'remember-notes-save-and-bury-buffer)
+ (define-key map "\C-c\C-c" #'remember-notes-save-and-bury-buffer)
map)
"Keymap used in `remember-notes-mode'.")
@@ -609,7 +609,7 @@ This sets `buffer-save-without-query' so that `save-some-buffers' will
save the notes buffer without asking.
\\{remember-notes-mode-map}"
- nil nil nil
+ :lighter nil
(cond
(remember-notes-mode
(add-hook 'kill-buffer-query-functions
@@ -640,9 +640,14 @@ to turn the *scratch* buffer into your notes buffer."
(interactive "p")
(let ((buf (or (find-buffer-visiting remember-data-file)
(with-current-buffer (find-file-noselect remember-data-file)
- (and remember-notes-buffer-name
- (not (get-buffer remember-notes-buffer-name))
- (rename-buffer remember-notes-buffer-name))
+ (when remember-notes-buffer-name
+ (when (and (get-buffer remember-notes-buffer-name)
+ (equal remember-notes-buffer-name "*scratch*"))
+ (kill-buffer remember-notes-buffer-name))
+ ;; Rename the buffer to the requested name (if
+ ;; it's not already in use).
+ (unless (get-buffer remember-notes-buffer-name)
+ (rename-buffer remember-notes-buffer-name)))
(funcall (or remember-notes-initial-major-mode
initial-major-mode))
(remember-notes-mode 1)
@@ -664,6 +669,11 @@ is non-nil, bury it and return nil; otherwise return t."
nil)
t))
+;; Obsolete
+
+(defconst remember-version "2.0" "This version of remember.")
+(make-obsolete-variable 'remember-version 'emacs-version "28.1")
+
(provide 'remember)
;;; remember.el ends here
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 2702279b082..1471be0ecd6 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -105,10 +105,6 @@
;; Common Lisp stuff
(require 'cl-lib)
-;; Correct wrong declaration.
-(def-edebug-spec push
- (&or [form symbolp] [form gv-place]))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support for `testcover'
@@ -558,32 +554,30 @@ After interpretation of ARGS the results are concatenated as for
`:seq'."
(apply #'concat
(mapcar
- #'(lambda (re)
- (cond
- ((stringp re)
- re)
- ((symbolp re)
- (cadr (assoc re rst-re-alist)))
- ((characterp re)
- (regexp-quote (char-to-string re)))
- ((listp re)
- (let ((nested
- (mapcar (lambda (elt)
- (rst-re elt))
- (cdr re))))
- (cond
- ((eq (car re) :seq)
- (mapconcat #'identity nested ""))
- ((eq (car re) :shy)
- (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
- ((eq (car re) :grp)
- (concat "\\(" (mapconcat #'identity nested "") "\\)"))
- ((eq (car re) :alt)
- (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
- (t
- (error "Unknown list car: %s" (car re))))))
- (t
- (error "Unknown object type for building regex: %s" re))))
+ (lambda (re)
+ (cond
+ ((stringp re)
+ re)
+ ((symbolp re)
+ (cadr (assoc re rst-re-alist)))
+ ((characterp re)
+ (regexp-quote (char-to-string re)))
+ ((listp re)
+ (let ((nested
+ (mapcar #'rst-re (cdr re))))
+ (cond
+ ((eq (car re) :seq)
+ (mapconcat #'identity nested ""))
+ ((eq (car re) :shy)
+ (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :grp)
+ (concat "\\(" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :alt)
+ (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
+ (t
+ (error "Unknown list car: %s" (car re))))))
+ (t
+ (error "Unknown object type for building regex: %s" re))))
args)))
;; FIXME: Remove circular dependency between `rst-re' and `rst-re-alist'.
@@ -622,7 +616,7 @@ After interpretation of ARGS the results are concatenated as for
(:constructor
rst-Ado-new-transition
(&aux
- (char nil)
+ ;; (char nil)
(-style 'transition)))
;; Construct a simple section header.
(:constructor
@@ -715,8 +709,8 @@ Return CHAR if so or signal an error otherwise."
;; testcover: ok.
"Return position of SELF in ADOS or nil."
(cl-check-type self rst-Ado)
- (cl-position-if #'(lambda (e)
- (rst-Ado-equal self e))
+ (cl-position-if (lambda (e)
+ (rst-Ado-equal self e))
ados))
@@ -820,8 +814,8 @@ Return ADO if so or signal an error otherwise."
"Return sublist of HDRS whose car's adornment equals that of SELF or nil."
(cl-check-type self rst-Hdr)
(let ((ado (rst-Hdr-ado self)))
- (cl-member-if #'(lambda (hdr)
- (rst-Ado-equal ado (rst-Hdr-ado hdr)))
+ (cl-member-if (lambda (hdr)
+ (rst-Ado-equal ado (rst-Hdr-ado hdr)))
hdrs)))
(defun rst-Hdr-ado-map (selves)
@@ -1283,8 +1277,8 @@ This inherits from Text mode.")
;; Abbrevs.
(define-abbrev-table 'rst-mode-abbrev-table
- (mapcar #'(lambda (x)
- (append x '(nil 0 system)))
+ (mapcar (lambda (x)
+ (append x '(nil 0 system)))
'(("contents" ".. contents::\n..\n ")
("con" ".. contents::\n..\n ")
("cont" "[...]")
@@ -1302,7 +1296,8 @@ This inherits from Text mode.")
(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)
(modify-syntax-entry ?/ "." st)
@@ -1330,7 +1325,6 @@ The hook for `text-mode' is run before this one."
;; Pull in variable definitions silencing byte-compiler.
(require 'newcomment)
-(defvar electric-pair-pairs)
(defvar electric-indent-inhibit)
;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files
@@ -1387,8 +1381,6 @@ highlighting.
(setq-local comment-region-function #'rst-comment-region)
(setq-local uncomment-region-function #'rst-uncomment-region)
- (setq-local electric-pair-pairs '((?\" . ?\") (?\* . ?\*) (?\` . ?\`)))
-
;; Imenu and which function.
;; FIXME: Check documentation of `which-function' for alternative ways to
;; determine the current function name.
@@ -1400,7 +1392,8 @@ highlighting.
t nil nil nil
(font-lock-multiline . t)
(font-lock-mark-block-function . mark-paragraph)))
- (add-hook 'font-lock-extend-region-functions #'rst-font-lock-extend-region t)
+ (add-hook 'font-lock-extend-region-functions
+ #'rst-font-lock-extend-region nil t)
;; Text after a changed line may need new fontification.
(setq-local jit-lock-contextually t)
@@ -1415,13 +1408,11 @@ highlighting.
When ReST minor mode is enabled, the ReST mode keybindings
are installed on top of the major mode bindings. Use this
for modes derived from Text mode, like Mail mode."
- ;; The initial value.
- nil
- ;; The indicator for the mode line.
- " ReST"
- ;; The minor mode bindings.
- rst-mode-map
- :group 'rst)
+ ;; The indicator for the mode line.
+ :lighter " ReST"
+ ;; The minor mode bindings.
+ :keymap rst-mode-map
+ :group 'rst)
;; FIXME: can I somehow install these too?
;; :abbrev-table rst-mode-abbrev-table
@@ -1508,9 +1499,9 @@ file."
:type `(repeat
(group :tag "Adornment specification"
(choice :tag "Adornment character"
- ,@(mapcar #'(lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ ,@(mapcar (lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-adornment-chars))
(radio :tag "Adornment type"
(const :tag "Overline and underline" over-and-under)
@@ -1547,8 +1538,8 @@ search starts after this entry. Return nil if no new preferred
;; Start searching after the level of the previous adornment.
(cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments))))
(rst-Hdr-preferred-adornments))))
- (cl-find-if #'(lambda (cand)
- (not (rst-Hdr-member-ado cand seen)))
+ (cl-find-if (lambda (cand)
+ (not (rst-Hdr-member-ado cand seen)))
candidates)))
(defun rst-update-section (hdr)
@@ -1627,55 +1618,55 @@ returned."
(ttl-blw ; Title found below starting here.
(rst-forward-line-looking-at
+1 'ttl-beg-1
- #'(lambda (mtcd)
- (when mtcd
- (setq txt-blw (match-string-no-properties 1))
- (point)))))
+ (lambda (mtcd)
+ (when mtcd
+ (setq txt-blw (match-string-no-properties 1))
+ (point)))))
txt-abv
(ttl-abv ; Title found above starting here.
(rst-forward-line-looking-at
-1 'ttl-beg-1
- #'(lambda (mtcd)
- (when mtcd
- (setq txt-abv (match-string-no-properties 1))
- (point)))))
+ (lambda (mtcd)
+ (when mtcd
+ (setq txt-abv (match-string-no-properties 1))
+ (point)))))
(und-fnd ; Matching underline found starting here.
(and ttl-blw
(rst-forward-line-looking-at
+2 (list ado-re 'lin-end)
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(ovr-fnd ; Matching overline found starting here.
(and ttl-abv
(rst-forward-line-looking-at
-2 (list ado-re 'lin-end)
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(und-wng ; Wrong underline found starting here.
(and ttl-blw
(not und-fnd)
(rst-forward-line-looking-at
+2 'ado-beg-2-1
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(ovr-wng ; Wrong overline found starting here.
(and ttl-abv (not ovr-fnd)
(rst-forward-line-looking-at
-2 'ado-beg-2-1
- #'(lambda (mtcd)
- (when (and
- mtcd
- ;; An adornment above may be a legal
- ;; adornment for the line above - consider it
- ;; a wrong overline only when it is equally
- ;; long.
- (equal
- (length (match-string-no-properties 1))
- (length adornment)))
- (point)))))))
+ (lambda (mtcd)
+ (when (and
+ mtcd
+ ;; An adornment above may be a legal
+ ;; adornment for the line above - consider it
+ ;; a wrong overline only when it is equally
+ ;; long.
+ (equal
+ (length (match-string-no-properties 1))
+ (length adornment)))
+ (point)))))))
(cond
((and nxt-emp prv-emp)
;; A transition.
@@ -1715,11 +1706,11 @@ a section header or nil if no title line is found."
(rst-forward-line-strict 0))
(let* (cnd-beg ; Beginning of a title candidate.
cnd-txt ; Text of a title candidate.
- (cnd-fun #'(lambda (mtcd) ; Function setting title candidate data.
- (when mtcd
- (setq cnd-beg (match-beginning 0))
- (setq cnd-txt (match-string-no-properties 1))
- t)))
+ (cnd-fun (lambda (mtcd) ; Function setting title candidate data.
+ (when mtcd
+ (setq cnd-beg (match-beginning 0))
+ (setq cnd-txt (match-string-no-properties 1))
+ t)))
ttl)
(cond
((looking-at (rst-re 'ado-beg-2-1))
@@ -1735,10 +1726,10 @@ a section header or nil if no title line is found."
;; Title line found - check for a following underline.
(setq ttl (rst-forward-line-looking-at
1 'ado-beg-2-1
- #'(lambda (mtcd)
- (when mtcd
- (rst-classify-adornment
- (match-string-no-properties 0) (match-end 0))))))
+ (lambda (mtcd)
+ (when mtcd
+ (rst-classify-adornment
+ (match-string-no-properties 0) (match-end 0))))))
;; Title candidate found if no valid adornment found.
(funcall cnd-fun (not ttl))))
(cond
@@ -1834,15 +1825,15 @@ given."
(ignore-ttl
(if ignore-position
(cl-find-if
- #'(lambda (ttl)
- (equal (rst-Ttl-contains ttl ignore-position) 0))
+ (lambda (ttl)
+ (equal (rst-Ttl-contains ttl ignore-position) 0))
all-ttls)))
(really-ignore
(if ignore-ttl
(<= (cl-count-if
- #'(lambda (ttl)
- (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
- (rst-Ttl-ado ttl)))
+ (lambda (ttl)
+ (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
+ (rst-Ttl-ado ttl)))
all-ttls)
1)))
(real-ttls (delq (if really-ignore ignore-ttl) all-ttls)))
@@ -1866,14 +1857,14 @@ given."
Return a list of (`rst-Ttl' . LEVEL) with ascending line number."
(let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
(mapcar
- #'(lambda (ttl)
- (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
+ (lambda (ttl)
+ (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
(rst-all-ttls))))
(defun rst-get-previous-hdr ()
"Return the `rst-Hdr' before point or nil if none."
- (let ((prev (cl-find-if #'(lambda (ttl)
- (< (rst-Ttl-contains ttl (point)) 0))
+ (let ((prev (cl-find-if (lambda (ttl)
+ (< (rst-Ttl-contains ttl (point)) 0))
(rst-all-ttls)
:from-end t)))
(and prev (rst-Ttl-hdr prev))))
@@ -2176,19 +2167,19 @@ hierarchy is similar to that used by `rst-adjust-section'."
(let* ((beg (region-beginning))
(end (region-end))
(ttls-reg (cl-remove-if-not
- #'(lambda (ttl)
- (and
- (>= (rst-Ttl-contains ttl beg) 0)
- (< (rst-Ttl-contains ttl end) 0)))
+ (lambda (ttl)
+ (and
+ (>= (rst-Ttl-contains ttl beg) 0)
+ (< (rst-Ttl-contains ttl end) 0)))
(rst-all-ttls))))
(save-excursion
;; Apply modifications.
(rst-destructuring-dolist
((marker &rest hdr
&aux (hier (rst-hdr-hierarchy)))
- (mapcar #'(lambda (ttl)
- (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
- (rst-Ttl-hdr ttl)))
+ (mapcar (lambda (ttl)
+ (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
+ (rst-Ttl-hdr ttl)))
ttls-reg))
(set-marker
(goto-char marker) nil)
@@ -2363,7 +2354,7 @@ If user selects enumerations, a further prompt is given. User need to
input a starting item, for example 'e' for 'A)' style. The position is
also arranged by `rst-insert-list-new-tag'."
(let* ((itemstyle (completing-read
- "Select preferred item style [#.]: "
+ (format-prompt "Select preferred item style" "#.")
rst-initial-items nil t nil nil "#."))
(cnt (if (string-match (rst-re 'cntexp-tag) itemstyle)
(match-string 0 itemstyle)))
@@ -2371,21 +2362,23 @@ also arranged by `rst-insert-list-new-tag'."
(save-match-data
(cond
((equal cnt "a")
- (let ((itemno (read-string "Give starting value [a]: "
- nil nil "a")))
+ (let ((itemno (read-string
+ (format-prompt "Give starting value" "a")
+ nil nil "a")))
(downcase (substring itemno 0 1))))
((equal cnt "A")
- (let ((itemno (read-string "Give starting value [A]: "
- nil nil "A")))
+ (let ((itemno (read-string
+ (format-prompt "Give starting value" "A")
+ nil nil "A")))
(upcase (substring itemno 0 1))))
((equal cnt "I")
- (let ((itemno (read-number "Give starting value [1]: " 1)))
+ (let ((itemno (read-number "Give starting value: " 1)))
(rst-arabic-to-roman itemno)))
((equal cnt "i")
- (let ((itemno (read-number "Give starting value [1]: " 1)))
+ (let ((itemno (read-number "Give starting value: " 1)))
(downcase (rst-arabic-to-roman itemno))))
((equal cnt "1")
- (let ((itemno (read-number "Give starting value [1]: " 1)))
+ (let ((itemno (read-number "Give starting value: " 1)))
(number-to-string itemno)))))))
(if no
(setq itemstyle (replace-match no t t itemstyle)))
@@ -2396,9 +2389,9 @@ also arranged by `rst-insert-list-new-tag'."
"List of favorite bullets."
:group 'rst
:type `(repeat
- (choice ,@(mapcar #'(lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ (choice ,@(mapcar (lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-bullets)))
:package-version '(rst . "1.1.0"))
@@ -2522,13 +2515,13 @@ ordered by POINT."
(looking-at (rst-re rst-re-beg)) ; Start found
(not (rst-forward-line-looking-at
-1 'lin-end
- #'(lambda (mtcd) ; Previous line exists and is...
- (and
- (not mtcd) ; non-empty,
- (<= (current-indentation) clm) ; less indented
- (not (and (= (current-indentation) clm)
+ (lambda (mtcd) ; Previous line exists and is...
+ (and
+ (not mtcd) ; non-empty,
+ (<= (current-indentation) clm) ; less indented
+ (not (and (= (current-indentation) clm)
; not a beg at same level.
- (looking-at (rst-re rst-re-beg)))))))))
+ (looking-at (rst-re rst-re-beg)))))))))
(back-to-indentation)
(push (cons (point) clm) r)))
(1value ; At least one line is moved in this loop.
@@ -2558,8 +2551,8 @@ modified."
((bullet _clm &rest pnts)
;; Zip preferred bullets and sorted columns associating a bullet
;; with a column and all the points this column is found.
- (cl-mapcar #'(lambda (bullet clm2pnt)
- (cons bullet clm2pnt))
+ (cl-mapcar (lambda (bullet clm2pnt)
+ (cons bullet clm2pnt))
rst-preferred-bullets
(sort clm2pnts #'car-less-than-car)))
;; Replace the bullets by the preferred ones.
@@ -2619,8 +2612,8 @@ section headers at all."
(when (>= point (rst-Stn-get-title-beginning stn))
;; Point may be in this section or a child.
(let ((in-child (cl-find-if
- #'(lambda (child)
- (>= point (rst-Stn-get-title-beginning child)))
+ (lambda (child)
+ (>= point (rst-Stn-get-title-beginning child)))
(rst-Stn-children stn)
:from-end t)))
(if in-child
@@ -2834,18 +2827,18 @@ file-write hook to always make it up-to-date automatically."
(and beg
(rst-forward-line-looking-at
1 'lin-end
- #'(lambda (mtcd)
- (unless mtcd
- (rst-apply-indented-blocks
- (point) (point-max) (current-indentation)
- #'(lambda (count _in-first _in-sub in-super in-empty
- _relind)
- (cond
- ((or (> count 1) in-super))
- ((not in-empty)
- (setq fnd (line-end-position))
- nil)))))
- t)))
+ (lambda (mtcd)
+ (unless mtcd
+ (rst-apply-indented-blocks
+ (point) (point-max) (current-indentation)
+ (lambda (count _in-first _in-sub in-super in-empty
+ _relind)
+ (cond
+ ((or (> count 1) in-super))
+ ((not in-empty)
+ (setq fnd (line-end-position))
+ nil)))))
+ t)))
(when fnd
(delete-region beg fnd))
(goto-char beg)
@@ -2860,7 +2853,7 @@ file-write hook to always make it up-to-date automatically."
;; FIXME: Updating the toc on saving would be nice. However, this doesn't work
;; correctly:
;;
-;; (add-hook 'write-contents-hooks 'rst-toc-update-fun)
+;; (add-hook 'write-contents-functions 'rst-toc-update-fun)
;; (defun rst-toc-update-fun ()
;; ;; Disable undo for the write file hook.
;; (let ((buffer-undo-list t)) (rst-toc-update) ))
@@ -3029,14 +3022,14 @@ direction."
(contained nil) ; Title contains point (or is after point otherwise).
(found (or (cl-position-if
;; Find a title containing or after point.
- #'(lambda (ttl)
- (let ((cmp (rst-Ttl-contains ttl pnt)))
- (cond
- ((= cmp 0) ; Title contains point.
- (setq contained t)
- t)
- ((> cmp 0) ; Title after point.
- t))))
+ (lambda (ttl)
+ (let ((cmp (rst-Ttl-contains ttl pnt)))
+ (cond
+ ((= cmp 0) ; Title contains point.
+ (setq contained t)
+ t)
+ ((> cmp 0) ; Title after point.
+ t))))
ttls)
;; Point after all titles.
count))
@@ -3295,8 +3288,8 @@ remove all indentation (CNT = 0). A tab is taken from the text
above. If no suitable tab is found `rst-indent-width' is used."
(interactive "r\np")
(let ((tabs (sort (rst-compute-tabs beg)
- #'(lambda (x y)
- (<= x y))))
+ (lambda (x y)
+ (<= x y))))
(leftmostcol (rst-find-leftmost-column beg end)))
(when (or (> leftmostcol 0) (> cnt 0))
;; Apply the indent.
@@ -3311,8 +3304,8 @@ above. If no suitable tab is found `rst-indent-width' is used."
(dir (cl-signum cnt)) ; Direction to take.
(abs (abs cnt)) ; Absolute number of steps to take.
;; Get the position of the first tab beyond leftmostcol.
- (fnd (cl-position-if #'(lambda (elt)
- (funcall cmp elt leftmostcol))
+ (fnd (cl-position-if (lambda (elt)
+ (funcall cmp elt leftmostcol))
tabs))
;; Virtual position of tab.
(pos (+ (or fnd len) (1- abs)))
@@ -3497,20 +3490,20 @@ do all lines instead of just paragraphs."
(indent ""))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- #'(lambda (count in-first in-sub in-super in-empty _relind)
- (cond
- (in-empty)
- (in-super)
- ((zerop count))
- (in-sub
- (insert indent))
- ((or in-first all)
- (let ((tag (format "%d. " (cl-incf enum))))
- (setq indent (make-string (length tag) ? ))
- (insert tag)))
- (t
- (insert indent)))
- nil))))
+ (lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (let ((tag (format "%d. " (cl-incf enum))))
+ (setq indent (make-string (length tag) ? ))
+ (insert tag)))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with deeper indentation - although
;; `rst-apply-indented-blocks' could.
@@ -3525,18 +3518,18 @@ do all lines instead of just paragraphs."
(indent (make-string (length bul) ? )))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- #'(lambda (count in-first in-sub in-super in-empty _relind)
- (cond
- (in-empty)
- (in-super)
- ((zerop count))
- (in-sub
- (insert indent))
- ((or in-first all)
- (insert bul))
- (t
- (insert indent)))
- nil))))
+ (lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (insert bul))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with a varying number of digits appropriately.
;; FIXME: Does not deal with multiple levels independently.
@@ -3566,18 +3559,16 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
(let ((ind (rst-find-leftmost-column beg end)))
(rst-apply-indented-blocks
beg end ind
- #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
- (when (and (not in-super) (or with-empty (not in-empty)))
- (move-to-column ind t)
- (insert "| "))
- nil))))
+ (lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (when (and (not in-super) (or with-empty (not in-empty)))
+ (move-to-column ind t)
+ (insert "| "))
+ nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Font lock
-(require 'font-lock)
-
;; FIXME: The obsolete variables need to disappear.
;; The following versions have been done inside Emacs and should not be
@@ -3630,10 +3621,7 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too."
"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)))
+(defface rst-directive '((t :inherit font-lock-builtin-face))
"Face used for directives and roles."
:version "24.1"
:group 'rst-faces)
@@ -4095,16 +4083,16 @@ end of the buffer) return nil and do not move point."
(setq fnd (rst-apply-indented-blocks
(line-beginning-position 2) ; Skip the current line
(or limit (point-max)) (or column (current-column))
- #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
- (cond
- (in-empty
- (setq candidate (or candidate (line-beginning-position)))
- nil)
- (in-super
- (or candidate (line-beginning-position)))
- (t ; Non-empty, same or more indented line.
- (setq candidate nil)
- nil)))))
+ (lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (cond
+ (in-empty
+ (setq candidate (or candidate (line-beginning-position)))
+ nil)
+ (in-super
+ (or candidate (line-beginning-position)))
+ (t ; Non-empty, same or more indented line.
+ (setq candidate nil)
+ nil)))))
(when fnd
(goto-char fnd))))
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 83e02fb8a2b..fda00ec367e 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -34,6 +34,7 @@
(require 'dom)
(require 'seq)
+(require 'facemenu)
(eval-when-compile (require 'subr-x))
(eval-when-compile
(require 'skeleton)
@@ -46,7 +47,8 @@
(defcustom sgml-basic-offset 2
"Specifies the basic indentation level for `sgml-indent-line'."
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom sgml-attribute-offset 0
"Specifies a delta for attribute indentation in `sgml-indent-line'.
@@ -116,8 +118,7 @@ definitions. So we normally turn it off.")
This takes effect when first loading the `sgml-mode' library.")
(defvar sgml-mode-map
- (let ((map (make-keymap)) ;`sparse' doesn't allow binding to charsets.
- (menu-map (make-sparse-keymap "SGML")))
+ (let ((map (make-keymap))) ;`sparse' doesn't allow binding to charsets.
(define-key map "\C-c\C-i" 'sgml-tags-invisible)
(define-key map "/" 'sgml-slash)
(define-key map "\C-c\C-n" 'sgml-name-char)
@@ -152,26 +153,24 @@ This takes effect when first loading the `sgml-mode' library.")
(map (nth 1 map)))
(while (< (setq c (1+ c)) 256)
(aset map c 'sgml-maybe-name-self)))
- (define-key map [menu-bar sgml] (cons "SGML" menu-map))
- (define-key menu-map [sgml-validate] '("Validate" . sgml-validate))
- (define-key menu-map [sgml-name-8bit-mode]
- '("Toggle 8 Bit Insertion" . sgml-name-8bit-mode))
- (define-key menu-map [sgml-tags-invisible]
- '("Toggle Tag Visibility" . sgml-tags-invisible))
- (define-key menu-map [sgml-tag-help]
- '("Describe Tag" . sgml-tag-help))
- (define-key menu-map [sgml-delete-tag]
- '("Delete Tag" . sgml-delete-tag))
- (define-key menu-map [sgml-skip-tag-forward]
- '("Forward Tag" . sgml-skip-tag-forward))
- (define-key menu-map [sgml-skip-tag-backward]
- '("Backward Tag" . sgml-skip-tag-backward))
- (define-key menu-map [sgml-attributes]
- '("Insert Attributes" . sgml-attributes))
- (define-key menu-map [sgml-tag] '("Insert Tag" . sgml-tag))
map)
"Keymap for SGML mode. See also `sgml-specials'.")
+(easy-menu-define sgml-mode-menu sgml-mode-map
+ "Menu for SGML mode."
+ '("SGML"
+ ["Insert Tag" sgml-tag]
+ ["Insert Attributes" sgml-attributes]
+ ["Backward Tag" sgml-skip-tag-backward]
+ ["Forward Tag" sgml-skip-tag-forward]
+ ["Delete Tag" sgml-delete-tag]
+ ["Describe Tag" sgml-tag-help]
+ "---"
+ ["Toggle Tag Visibility" sgml-tags-invisible]
+ ["Toggle 8 Bit Insertion" sgml-name-8bit-mode]
+ "---"
+ ["Validate" sgml-validate]))
+
(defun sgml-make-syntax-table (specials)
(let ((table (make-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?< "(>" table)
@@ -191,8 +190,19 @@ This takes effect when first loading the `sgml-mode' library.")
"Syntax table used in SGML mode. See also `sgml-specials'.")
(defconst sgml-tag-syntax-table
- (let ((table (sgml-make-syntax-table sgml-specials)))
- (dolist (char '(?\( ?\) ?\{ ?\} ?\[ ?\] ?$ ?% ?& ?* ?+ ?/))
+ (let ((table (sgml-make-syntax-table sgml-specials))
+ brackets)
+ (map-char-table
+ (lambda (key value)
+ (setq brackets (cons (list
+ (if (consp key)
+ (list (car key) (cdr key))
+ key)
+ value)
+ brackets)))
+ (unicode-property-table-internal 'paired-bracket))
+ (setq brackets (delete-dups (flatten-tree brackets)))
+ (dolist (char (append brackets (list ?$ ?% ?& ?* ?+ ?/)))
(modify-syntax-entry char "." table))
(unless (memq ?' sgml-specials)
;; Avoid that skipping a tag backwards skips any "'" prefixing it.
@@ -286,7 +296,10 @@ separated by a space."
(defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*")
(defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*")
(defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)"))
-(defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*")
+(defconst sgml-attrs-re
+ ;; This pattern cannot begin with a character matched by the end of
+ ;; `sgml-name-re' above.
+ "\\(?:[^_.:\"'/><[:alnum:]-]\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?")
(defconst sgml-start-tag-regex (concat "<" sgml-name-re sgml-attrs-re)
"Regular expression that matches a non-empty start tag.
Any terminating `>' or `/' is not matched.")
@@ -506,10 +519,12 @@ an optional alist of possible values."
(with-no-warnings (defvar v2)) ; free for skeleton
(defun sgml-comment-indent-new-line (&optional soft)
- (let ((comment-start "-- ")
- (comment-start-skip "\\(<!\\)?--[ \t]*")
- (comment-end " --")
- (comment-style 'plain))
+ (if (ppss-comment-depth (syntax-ppss))
+ (let ((comment-start "-- ")
+ (comment-start-skip "\\(<!\\)?--[ \t]*")
+ (comment-end " --")
+ (comment-style 'plain))
+ (comment-indent-new-line soft))
(comment-indent-new-line soft)))
(defun sgml-mode-facemenu-add-face-function (face _end)
@@ -619,7 +634,8 @@ Do \\[describe-key] on the following bindings to discover what they do.
(setq-local syntax-propertize-function #'sgml-syntax-propertize)
(setq-local syntax-ppss-table sgml-tag-syntax-table)
(setq-local facemenu-add-face-function 'sgml-mode-facemenu-add-face-function)
- (setq-local sgml-xml-mode (sgml-xml-guess))
+ (when (sgml-xml-guess)
+ (setq-local sgml-xml-mode t))
(unless sgml-xml-mode
(setq-local skeleton-transformation-function sgml-transformation-function))
;; This will allow existing comments within declarations to be
@@ -775,7 +791,7 @@ If you like tags and attributes in uppercase, customize
(setq sgml-tag-last
(completing-read
(if (> (length sgml-tag-last) 0)
- (format "Tag (default %s): " sgml-tag-last)
+ (format-prompt "Tag" sgml-tag-last)
"Tag: ")
sgml-tag-alist nil nil nil 'sgml-tag-history sgml-tag-last)))
?< str |
@@ -874,9 +890,7 @@ With prefix argument, only self insert."
(list (let ((def (save-excursion
(if (eq (following-char) ?<) (forward-char))
(sgml-beginning-of-tag))))
- (completing-read (if def
- (format "Tag (default %s): " def)
- "Tag: ")
+ (completing-read (format-prompt "Tag" def)
sgml-tag-alist nil nil nil
'sgml-tag-history def))))
(or (and tag (> (length tag) 0))
@@ -1186,10 +1200,9 @@ and move to the line in the SGML document that caused it."
(or sgml-saved-validate-command
(concat sgml-validate-command
" "
- (shell-quote-argument
- (let ((name (buffer-file-name)))
- (and name
- (file-name-nondirectory name)))))))))
+ (when-let ((name (buffer-file-name)))
+ (shell-quote-argument
+ (file-name-nondirectory name))))))))
(setq sgml-saved-validate-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
(compilation-start command))
@@ -1785,8 +1798,7 @@ This defaults to `sgml-quick-keys'.
This takes effect when first loading the library.")
(defvar html-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "HTML")))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map sgml-mode-map)
(define-key map "\C-c6" 'html-headline-6)
(define-key map "\C-c5" 'html-headline-5)
@@ -1803,6 +1815,7 @@ This takes effect when first loading the library.")
(define-key map "\C-c\C-cc" 'html-checkboxes)
(define-key map "\C-c\C-cl" 'html-list-item)
(define-key map "\C-c\C-ch" 'html-href-anchor)
+ (define-key map "\C-c\C-cf" 'html-href-anchor-file)
(define-key map "\C-c\C-cn" 'html-name-anchor)
(define-key map "\C-c\C-c#" 'html-id-anchor)
(define-key map "\C-c\C-ci" 'html-image)
@@ -1815,42 +1828,45 @@ This takes effect when first loading the library.")
(define-key map "\C-cc" 'html-checkboxes)
(define-key map "\C-cl" 'html-list-item)
(define-key map "\C-ch" 'html-href-anchor)
+ (define-key map "\C-cf" 'html-href-anchor-file)
(define-key map "\C-cn" 'html-name-anchor)
(define-key map "\C-c#" 'html-id-anchor)
(define-key map "\C-ci" 'html-image)
(define-key map "\C-cs" 'html-span))
(define-key map "\C-c\C-s" 'html-autoview-mode)
(define-key map "\C-c\C-v" 'browse-url-of-buffer)
- (define-key map [menu-bar html] (cons "HTML" menu-map))
- (define-key menu-map [html-autoview-mode]
- '("Toggle Autoviewing" . html-autoview-mode))
- (define-key menu-map [browse-url-of-buffer]
- '("View Buffer Contents" . browse-url-of-buffer))
- (define-key menu-map [nil] '("--"))
- ;;(define-key menu-map "6" '("Heading 6" . html-headline-6))
- ;;(define-key menu-map "5" '("Heading 5" . html-headline-5))
- ;;(define-key menu-map "4" '("Heading 4" . html-headline-4))
- (define-key menu-map "3" '("Heading 3" . html-headline-3))
- (define-key menu-map "2" '("Heading 2" . html-headline-2))
- (define-key menu-map "1" '("Heading 1" . html-headline-1))
- (define-key menu-map "l" '("Radio Buttons" . html-radio-buttons))
- (define-key menu-map "c" '("Checkboxes" . html-checkboxes))
- (define-key menu-map "l" '("List Item" . html-list-item))
- (define-key menu-map "u" '("Unordered List" . html-unordered-list))
- (define-key menu-map "o" '("Ordered List" . html-ordered-list))
- (define-key menu-map "-" '("Horizontal Rule" . html-horizontal-rule))
- (define-key menu-map "\n" '("Line Break" . html-line))
- (define-key menu-map "\r" '("Paragraph" . html-paragraph))
- (define-key menu-map "i" '("Image" . html-image))
- (define-key menu-map "h" '("Href Anchor" . html-href-anchor))
- (define-key menu-map "n" '("Name Anchor" . html-name-anchor))
- (define-key menu-map "#" '("ID Anchor" . html-id-anchor))
map)
"Keymap for commands for use in HTML mode.")
+(easy-menu-define html-mode-menu html-mode-map
+ "Menu for HTML mode."
+ '("HTML"
+ ["ID Anchor" html-id-anchor]
+ ["Name Anchor" html-name-anchor]
+ ["Href Anchor File" html-href-anchor-file]
+ ["Href Anchor URL" html-href-anchor]
+ ["Image" html-image]
+ ["Paragraph" html-paragraph]
+ ["Line Break" html-line]
+ ["Horizontal Rule" html-horizontal-rule]
+ ["Ordered List" html-ordered-list]
+ ["Unordered List" html-unordered-list]
+ ["List Item" html-list-item]
+ ["Checkboxes" html-checkboxes]
+ ["Radio Buttons" html-radio-buttons]
+ ["Heading 1" html-headline-1]
+ ["Heading 2" html-headline-2]
+ ["Heading 3" html-headline-3]
+ ;; ["Heading 4" html-headline-4]
+ ;; ["Heading 5" html-headline-5]
+ ;; ["Heading 6" html-headline-6]
+ "---"
+ ["View Buffer Contents" browse-url-of-buffer]
+ ["Toggle Autoviewing" html-autoview-mode]))
+
(defvar html-face-tag-alist
- '((bold . "b")
- (italic . "i")
+ '((bold . "strong")
+ (italic . "em")
(underline . "u")
(mode-line . "rev"))
"Value of `sgml-face-tag-alist' for HTML mode.")
@@ -2286,19 +2302,17 @@ This takes effect when first loading the library.")
nil t)
(match-string-no-properties 1))))
-(defvar html--buffer-classes-cache nil
+(defvar-local html--buffer-classes-cache nil
"Cache for `html-current-buffer-classes'.
When set, this should be a cons cell where the CAR is the
buffer's tick counter (as produced by `buffer-modified-tick'),
and the CDR is the list of class names found in the buffer.")
-(make-variable-buffer-local 'html--buffer-classes-cache)
-(defvar html--buffer-ids-cache nil
+(defvar-local html--buffer-ids-cache nil
"Cache for `html-current-buffer-ids'.
When set, this should be a cons cell where the CAR is the
buffer's tick counter (as produced by `buffer-modified-tick'),
and the CDR is the list of class names found in the buffer.")
-(make-variable-buffer-local 'html--buffer-ids-cache)
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url discard-comments))
@@ -2360,13 +2374,13 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6>
<p>Paragraphs only need an opening tag. Line breaks and multiple spaces are
ignored unless the text is <pre>preformatted.</pre> Text can be marked as
-<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or
-Edit/Text Properties/Face commands.
+<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o
+or Edit/Text Properties/Face commands.
Pages can have <a name=\"SOMENAME\">named points</a> and can link other points
to them with <a href=\"#SOMENAME\">see also somename</a>. In the same way <a
href=\"URL\">see also URL</a> where URL is a filename relative to current
-directory, or absolute as in `http://www.cs.indiana.edu/elisp/w3/docs.html'.
+directory, or absolute as in `https://www.cs.indiana.edu/elisp/w3/docs.html'.
Images in many formats can be inlined with <img src=\"URL\">.
@@ -2398,9 +2412,9 @@ To work around that, do:
(setq-local sgml-empty-tags
;; From HTML-4.01's loose.dtd, parsed with
- ;; `sgml-parse-dtd', plus manual addition of "wbr".
+ ;; `sgml-parse-dtd', plus manual additions of "source" and "wbr".
'("area" "base" "basefont" "br" "col" "frame" "hr" "img" "input"
- "isindex" "link" "meta" "param" "wbr"))
+ "isindex" "link" "meta" "source" "param" "wbr"))
(setq-local sgml-unclosed-tags
;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd'.
'("body" "colgroup" "dd" "dt" "head" "html" "li" "option"
@@ -2438,7 +2452,7 @@ The third `match-string' will be the used in the menu.")
HTML Autoview mode is a buffer-local minor mode for use with
`html-mode'. If enabled, saving the file automatically runs
`browse-url-of-buffer' to view it."
- nil nil nil
+ :lighter nil
(if html-autoview-mode
(add-hook 'after-save-hook #'browse-url-of-buffer nil t)
(remove-hook 'after-save-hook #'browse-url-of-buffer t)))
@@ -2450,6 +2464,11 @@ HTML Autoview mode is a buffer-local minor mode for use with
;; '(setq input "http:")
"<a href=\"" str "\">" _ "</a>")
+(define-skeleton html-href-anchor-file
+ "HTML anchor tag with href attribute (from a local file)."
+ (file-relative-name (read-file-name "File name: ") default-directory)
+ "<a href=\"" str "\">" _ "</a>")
+
(define-skeleton html-name-anchor
"HTML anchor tag with name attribute."
"Name: "
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 642d5229940..2dd52b87b79 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -339,8 +339,8 @@
;; When using `table-cell-map-hook' do not use `local-set-key'.
;;
;; (add-hook 'table-cell-map-hook
-;; (function (lambda ()
-;; (local-set-key [<key sequence>] '<function>))))
+;; (lambda ()
+;; (local-set-key [<key sequence>] '<function>)))
;;
;; Adding the above to your init file is a common way to customize a
;; mode specific keymap. However it does not work for this package.
@@ -349,8 +349,8 @@
;; explicitly. The correct way of achieving above task is:
;;
;; (add-hook 'table-cell-map-hook
-;; (function (lambda ()
-;; (define-key table-cell-map [<key sequence>] '<function>))))
+;; (lambda ()
+;; (define-key table-cell-map [<key sequence>] '<function>)))
;;
;; -----
;; Menu:
@@ -383,7 +383,7 @@
;; There is no artificial-intelligence magic in this package. The
;; definition of a table and the cells inside the table is reasonably
;; limited in order to achieve acceptable performance in the
-;; interactive operation under Emacs lisp implementation. A valid
+;; interactive operation under Emacs Lisp implementation. A valid
;; table is a rectangular text area completely filled with valid
;; cells. A valid cell is a rectangle text area, which four borders
;; consist of valid border characters. Cells can not be nested one to
@@ -620,13 +620,6 @@
(defvar flyspell-mode)
(defvar real-last-command)
(defvar delete-selection-mode)
-;; This is evil!!
-;; (eval-when-compile
-;; (unless (fboundp 'set-face-property)
-;; (defun set-face-property (face prop value)))
-;; (unless (fboundp 'unibyte-char-to-multibyte)
-;; (defun unibyte-char-to-multibyte (char)))
-;; (defun table--point-in-cell-p (&optional location)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -793,6 +786,8 @@ simply by any key input."
"List of functions to be called after the table is first loaded."
:type 'hook
:group 'table-hooks)
+(make-obsolete-variable 'table-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom table-point-entered-cell-hook nil
"List of functions to be called after point entered a table cell."
@@ -809,13 +804,6 @@ simply by any key input."
(setplist 'table-disable-incompatibility-warning nil)
-(defvar table-disable-menu (null (and (locate-library "easymenu")
- (require 'easymenu)
- (fboundp 'easy-menu-add-item)))
- "When non-nil, use of menu by table package is disabled.
-It must be set before loading this package `table.el' for the first
-time.")
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -865,15 +853,16 @@ time.")
"Timer id for deferred cell update.")
(defvar table-inhibit-update nil
"Non-nil inhibits implicit cell and cache updates.
-It inhibits `table-with-cache-buffer' to update data in both direction, cell to cache and cache to cell.")
+It inhibits `table-with-cache-buffer' to update data in both directions,
+cell to cache and cache to cell.")
(defvar table-inhibit-auto-fill-paragraph nil
"Non-nil inhibits auto fill paragraph when `table-with-cache-buffer' exits.
-This is always set to nil at the entry to `table-with-cache-buffer' before executing body forms.")
-(defvar table-mode-indicator nil
+This is always set to nil at the entry to `table-with-cache-buffer' before
+executing body forms.")
+(defvar-local table-mode-indicator nil
"For mode line indicator")
;; This is not a real minor-mode but placed in the minor-mode-alist
;; so that we can show the indicator on the mode line handy.
-(make-variable-buffer-local 'table-mode-indicator)
(unless (assq table-mode-indicator minor-mode-alist)
(push '(table-mode-indicator (table-fixed-width-mode " Fixed-Table" " Table"))
minor-mode-alist))
@@ -969,7 +958,7 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu
(describe-bindings . *table--cell-describe-bindings)
(dabbrev-expand . *table--cell-dabbrev-expand)
(dabbrev-completion . *table--cell-dabbrev-completion))
- "List of cons cells consisting of (ORIGINAL-COMMAND . TABLE-VERSION-OF-THE-COMMAND).")
+ "List of the form (ORIGINAL-COMMAND . TABLE-VERSION-OF-THE-COMMAND).")
(defvar table-command-list
;; Construct the real contents of the `table-command-list'.
@@ -1200,12 +1189,11 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu
))
;; register table menu under global tools menu
-(unless table-disable-menu
- (easy-menu-define table-global-menu-map nil
- "Table global menu" table-global-menu)
- (easy-menu-add-item (current-global-map) '("menu-bar" "tools") "--")
- (easy-menu-add-item (current-global-map)
- '("menu-bar" "tools") table-global-menu-map))
+(easy-menu-define table-global-menu-map nil
+ "Table global menu" table-global-menu)
+(easy-menu-add-item (current-global-map) '("menu-bar" "tools") "--")
+(easy-menu-add-item (current-global-map)
+ '("menu-bar" "tools") table-global-menu-map)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -1285,12 +1273,8 @@ the last cache point coordinate."
;; set up the update timer unless it is explicitly inhibited.
(unless table-inhibit-update
(table--update-cell)))))
-(if (null (fboundp 'font-lock-add-keywords))
- nil
- ;; Color it as a keyword.
- (font-lock-add-keywords
- 'emacs-lisp-mode
- '("\\<table-with-cache-buffer\\>")))
+;; Color it as a keyword.
+(font-lock-add-keywords 'emacs-lisp-mode '("\\<table-with-cache-buffer\\>"))
(defmacro table-put-source-info (prop value)
"Register source generation information."
@@ -1322,17 +1306,16 @@ the last cache point coordinate."
(let ((func-symbol (intern (format "*table--cell-%s" command)))
(doc-string (format "Table remapped function for `%s'." command)))
(defalias func-symbol
- `(lambda
- (&rest args)
- ,doc-string
- (interactive)
- (let ((table-inhibit-update t)
- (deactivate-mark nil))
- (table--finish-delayed-tasks)
- (table-recognize-cell 'force)
- (table-with-cache-buffer
- (call-interactively ',command)
- (setq table-inhibit-auto-fill-paragraph t)))))
+ (lambda (&rest _args)
+ (:documentation doc-string)
+ (interactive)
+ (let ((table-inhibit-update t)
+ (deactivate-mark nil))
+ (table--finish-delayed-tasks)
+ (table-recognize-cell 'force)
+ (table-with-cache-buffer
+ (call-interactively command)
+ (setq table-inhibit-auto-fill-paragraph t)))))
(push (cons command func-symbol)
table-command-remap-alist)))
@@ -1354,17 +1337,16 @@ the last cache point coordinate."
(let ((func-symbol (intern (format "*table--cell-%s" command)))
(doc-string (format "Table remapped function for `%s'." command)))
(defalias func-symbol
- `(lambda
- (&rest args)
- ,doc-string
- (interactive)
- (table--finish-delayed-tasks)
- (table-recognize-cell 'force)
- (table-with-cache-buffer
- (table--remove-cell-properties (point-min) (point-max))
- (table--remove-eol-spaces (point-min) (point-max))
- (call-interactively ',command))
- (table--finish-delayed-tasks)))
+ (lambda (&rest _args)
+ (:documentation doc-string)
+ (interactive)
+ (table--finish-delayed-tasks)
+ (table-recognize-cell 'force)
+ (table-with-cache-buffer
+ (table--remove-cell-properties (point-min) (point-max))
+ (table--remove-eol-spaces (point-min) (point-max))
+ (call-interactively command))
+ (table--finish-delayed-tasks)))
(push (cons command func-symbol)
table-command-remap-alist)))
@@ -1376,19 +1358,18 @@ the last cache point coordinate."
insert))
(let ((func-symbol (intern (format "*table--cell-%s" command)))
(doc-string (format "Table remapped function for `%s'." command)))
- (fset func-symbol
- `(lambda
- (&rest args)
- ,doc-string
- (interactive)
- (table--finish-delayed-tasks)
- (table-recognize-cell 'force)
- (table-with-cache-buffer
- (call-interactively ',command)
- (table--untabify (point-min) (point-max))
- (table--fill-region (point-min) (point-max))
- (setq table-inhibit-auto-fill-paragraph t))
- (table--finish-delayed-tasks)))
+ (defalias func-symbol
+ (lambda (&rest _args)
+ (:documentation doc-string)
+ (interactive)
+ (table--finish-delayed-tasks)
+ (table-recognize-cell 'force)
+ (table-with-cache-buffer
+ (call-interactively command)
+ (table--untabify (point-min) (point-max))
+ (table--fill-region (point-min) (point-max))
+ (setq table-inhibit-auto-fill-paragraph t))
+ (table--finish-delayed-tasks)))
(push (cons command func-symbol)
table-command-remap-alist)))
@@ -1400,18 +1381,17 @@ the last cache point coordinate."
fill-paragraph))
(let ((func-symbol (intern (format "*table--cell-%s" command)))
(doc-string (format "Table remapped function for `%s'." command)))
- (fset func-symbol
- `(lambda
- (&rest args)
- ,doc-string
- (interactive)
- (table--finish-delayed-tasks)
- (table-recognize-cell 'force)
- (table-with-cache-buffer
- (let ((fill-column table-cell-info-width))
- (call-interactively ',command))
- (setq table-inhibit-auto-fill-paragraph t))
- (table--finish-delayed-tasks)))
+ (defalias func-symbol
+ (lambda (&rest _args)
+ (:documentation doc-string)
+ (interactive)
+ (table--finish-delayed-tasks)
+ (table-recognize-cell 'force)
+ (table-with-cache-buffer
+ (let ((fill-column table-cell-info-width))
+ (call-interactively command))
+ (setq table-inhibit-auto-fill-paragraph t))
+ (table--finish-delayed-tasks)))
(push (cons command func-symbol)
table-command-remap-alist)))
@@ -1508,7 +1488,7 @@ Move the point under the table as shown below.
+--------------+------+--------------------------------+
-!-
-Type M-x table-insert-row instead of \\[table-insert-row-column]. \\[table-insert-row-column] does not work
+Type \\[table-insert-row] instead of \\[table-insert-row-column]. \\[table-insert-row-column] does not work
when the point is outside of the table. This insertion at
outside of the table effectively appends a row at the end.
@@ -1822,11 +1802,11 @@ See `table-insert-row' and `table-insert-column'."
(list (intern (let ((completion-ignore-case t)
(default (car table-insert-row-column-history)))
(downcase (completing-read
- (format "Insert %s row%s/column%s (default %s): "
- (if (> n 1) (format "%d" n) "a")
- (if (> n 1) "s" "")
- (if (> n 1) "s" "")
- default)
+ (format-prompt
+ "Insert %s row%s/column%s" default
+ (if (> n 1) (format "%d" n) "a")
+ (if (> n 1) "s" "")
+ (if (> n 1) "s" ""))
'(("row") ("column"))
nil t nil 'table-insert-row-column-history default))))
n)))
@@ -1973,7 +1953,7 @@ is negative the cell becomes inactive, meaning that the cell becomes
plain text and loses all the table specific features."
(interactive "i\ni\np")
(table--make-cell-map)
- (if (or force (not (memq (table--get-last-command) table-command-list)))
+ (if (or force (not (memq real-last-command table-command-list)))
(let* ((cell (table--probe-cell (called-interactively-p 'interactive)))
(cache-buffer (get-buffer-create table-cache-buffer-name))
(modified-flag (buffer-modified-p))
@@ -2532,7 +2512,7 @@ DIRECTION is one of symbols; right, left, above or below."
(caar direction-list)))
(completion-ignore-case t))
(intern (downcase (completing-read
- (format "Span into (default %s): " default-direction)
+ (format-prompt "Span into" default-direction)
direction-list
nil t nil 'table-cell-span-direction-history default-direction))))))
(unless (memq direction '(right left above below))
@@ -2666,7 +2646,8 @@ Creates a cell above and a cell below the current point location."
;;;###autoload
(defun table-split-cell-horizontally ()
"Split current cell horizontally.
-Creates a cell on the left and a cell on the right of the current point location."
+Creates a cell on the left and a cell on the right of the current
+point location."
(interactive "*")
(table-recognize-cell 'force)
(let* ((o-coordinate (table--get-coordinate))
@@ -2695,7 +2676,7 @@ Creates a cell on the left and a cell on the right of the current point location
("Title"
("Split" . "split") ("Left" . "left") ("Right" . "right"))))
(downcase (completing-read
- (format "Existing cell contents to (default %s): " default)
+ (format-prompt "Existing cell contents to" default)
'(("split") ("left") ("right"))
nil t nil 'table-cell-split-contents-to-history default)))))))
(unless (eq contents-to 'split)
@@ -2767,7 +2748,7 @@ ORIENTATION is a symbol either horizontally or vertically."
(completion-ignore-case t)
(default (car table-cell-split-orientation-history)))
(intern (downcase (completing-read
- (format "Split orientation (default %s): " default)
+ (format-prompt "Split orientation" default)
'(("horizontally") ("vertically"))
nil t nil 'table-cell-split-orientation-history default))))))
(unless (memq orientation '(horizontally vertically))
@@ -2787,7 +2768,7 @@ WHAT is a symbol `cell', `row' or `column'. JUSTIFY is a symbol
(completion-ignore-case t)
(default (car table-target-history)))
(intern (downcase (completing-read
- (format "Justify what (default %s): " default)
+ (format-prompt "Justify what" default)
'(("cell") ("row") ("column"))
nil t nil 'table-target-history default))))
(table--query-justification)))
@@ -2927,21 +2908,21 @@ buffer, and leaves the previous contents of the buffer untouched.
References used for this implementation:
HTML:
- URL `http://www.w3.org'
+ URL `https://www.w3.org'
LaTeX:
- URL `http://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
+ URL `https://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
CALS (DocBook DTD):
- URL `http://www.oasis-open.org/html/a502.htm'
- URL `http://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
+ URL `https://www.oasis-open.org/html/a502.htm'
+ URL `https://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
"
(interactive
(let* ((_ (unless (table--probe-cell) (error "Table not found here")))
(completion-ignore-case t)
(default (car table-source-language-history))
(language (downcase (completing-read
- (format "Language (default %s): " default)
+ (format-prompt "Language" default)
table-source-languages
nil t nil 'table-source-language-history default))))
(list
@@ -2990,8 +2971,8 @@ CALS (DocBook DTD):
(setq col-list (cons (car lu-coordinate) col-list)))
(unless (memq (cdr lu-coordinate) row-list)
(setq row-list (cons (cdr lu-coordinate) row-list))))))
- (setq col-list (sort col-list '<))
- (setq row-list (sort row-list '<))
+ (setq col-list (sort col-list #'<))
+ (setq row-list (sort row-list #'<))
(message "Generating source...")
;; clear the source generation property list
(setplist 'table-source-info-plist nil)
@@ -3038,7 +3019,7 @@ CALS (DocBook DTD):
"")))
((eq language 'latex)
(insert (format "%% This LaTeX table template is generated by emacs %s\n" emacs-version)
- "\\begin{tabular}{|" (apply 'concat (make-list (length col-list) "l|")) "}\n"
+ "\\begin{tabular}{|" (apply #'concat (make-list (length col-list) "l|")) "}\n"
"\\hline\n"))
((eq language 'cals)
(insert (format "<!-- This CALS table template is generated by emacs %s -->\n" emacs-version)
@@ -3069,7 +3050,7 @@ CALS (DocBook DTD):
(set-marker-insertion-type (table-get-source-info 'colspec-marker) t) ;; insert before
(save-excursion
(goto-char (table-get-source-info 'colspec-marker))
- (dolist (col (sort (table-get-source-info 'colnum-list) '<))
+ (dolist (col (sort (table-get-source-info 'colnum-list) #'<))
(insert (format " <colspec colnum=\"%d\" colname=\"c%d\"/>\n" col col))))
(insert (format " </%s>\n </tgroup>\n</table>\n" (table-get-source-info 'row-type))))
((eq language 'mediawiki)
@@ -3207,11 +3188,7 @@ CALS (DocBook DTD):
(while (and (re-search-forward "$" nil t)
(not (eobp)))
(insert "<br />")
- (forward-char 1)))
- (unless (and table-html-delegate-spacing-to-user-agent
- (progn
- (goto-char (point-min))
- (looking-at "\\s *\\'")))))
+ (forward-char 1))))
((eq language 'cals)
(table--remove-eol-spaces (point-min) (point-max))
(if (re-search-forward "\\s +\\'" nil t)
@@ -3272,34 +3249,33 @@ Currently this method is for LaTeX only."
(let* ((span 1) ;; spanning length
(first-p t) ;; first in a row
(insert-column ;; a function that processes one column/multicolumn
- (function
- (lambda (from to)
- (let ((line (table--buffer-substring-and-trim
- (table--goto-coordinate (cons from y))
- (table--goto-coordinate (cons to y)))))
- ;; escape special characters
- (with-temp-buffer
- (insert line)
- (goto-char (point-min))
- (while (re-search-forward "\\([#$~_^%{}]\\)\\|\\(\\\\\\)\\|\\([<>|]\\)" nil t)
- (if (match-beginning 1)
- (save-excursion
- (goto-char (match-beginning 1))
- (insert "\\"))
- (if (match-beginning 2)
- (replace-match "$\\backslash$" t t)
- (replace-match (concat "$" (match-string 3) "$")) t t)))
- (setq line (buffer-substring (point-min) (point-max))))
- ;; insert a column separator and column/multicolumn contents
- (with-current-buffer dest-buffer
- (unless first-p
- (insert (if (eq (char-before) ?\s) "" " ") "& "))
- (if (> span 1)
- (insert (format "\\multicolumn{%d}{%sl|}{%s}" span (if first-p "|" "") line))
- (insert line)))
- (setq first-p nil)
- (setq span 1)
- (setq start (nth i col-list)))))))
+ (lambda (from to)
+ (let ((line (table--buffer-substring-and-trim
+ (table--goto-coordinate (cons from y))
+ (table--goto-coordinate (cons to y)))))
+ ;; escape special characters
+ (with-temp-buffer
+ (insert line)
+ (goto-char (point-min))
+ (while (re-search-forward "\\([#$~_^%{}&]\\)\\|\\(\\\\\\)\\|\\([<>|]\\)" nil t)
+ (if (match-beginning 1)
+ (save-excursion
+ (goto-char (match-beginning 1))
+ (insert "\\"))
+ (if (match-beginning 2)
+ (replace-match "$\\backslash$" t t)
+ (replace-match (concat "$" (match-string 3) "$")) t t)))
+ (setq line (buffer-substring (point-min) (point-max))))
+ ;; insert a column separator and column/multicolumn contents
+ (with-current-buffer dest-buffer
+ (unless first-p
+ (insert (if (eq (char-before) ?\s) "" " ") "& "))
+ (if (> span 1)
+ (insert (format "\\multicolumn{%d}{%sl|}{%s}" span (if first-p "|" "") line))
+ (insert line)))
+ (setq first-p nil)
+ (setq span 1)
+ (setq start (nth i col-list))))))
(setq start x0)
(setq i 1)
(while (setq c (nth i border-char-list))
@@ -3368,7 +3344,7 @@ Example:
(let* ((completion-ignore-case t)
(default (car table-sequence-justify-history)))
(intern (downcase (completing-read
- (format "Justify (default %s): " default)
+ (format-prompt "Justify" default)
'(("left") ("center") ("right"))
nil t nil 'table-sequence-justify-history default)))))))
(unless (or (called-interactively-p 'interactive) (table--probe-cell))
@@ -3505,9 +3481,9 @@ column must consists from cells of same width."
(let ((cell-list (table--vertical-cell-list 'top-to-bottom)))
(unless
(and (table--uniform-list-p
- (mapcar (function (lambda (cell) (car (table--get-coordinate (car cell))))) cell-list))
+ (mapcar (lambda (cell) (car (table--get-coordinate (car cell)))) cell-list))
(table--uniform-list-p
- (mapcar (function (lambda (cell) (car (table--get-coordinate (cdr cell))))) cell-list)))
+ (mapcar (lambda (cell) (car (table--get-coordinate (cdr cell)))) cell-list)))
(error "Cells in this column are not in uniform width"))
(unless lu-coord
(setq lu-coord (table--get-coordinate (caar cell-list))))
@@ -3670,7 +3646,7 @@ companion command to `table-capture' this way.
(if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) 'left
(intern
(downcase (completing-read
- (format "Justify (default %s): " default)
+ (format-prompt "Justify" default)
'(("left") ("center") ("right"))
nil t nil 'table-capture-justify-history default)))))
(if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) "1"
@@ -3866,14 +3842,13 @@ converts a table into plain text without frames. It is a companion to
(setq table-cell-map map)
(fset 'table-cell-map map)))
;; Add menu for table cells.
- (unless table-disable-menu
- (easy-menu-define table-cell-menu-map table-cell-map
- "Table cell menu" table-cell-menu))
+ (easy-menu-define table-cell-menu-map table-cell-map
+ "Table cell menu" table-cell-menu)
(run-hooks 'table-cell-map-hook))
;; Create the keymap after running the user init file so that the user
;; modification to the global-map is accounted.
-(add-hook 'after-init-hook 'table--make-cell-map t)
+(add-hook 'after-init-hook #'table--make-cell-map t)
(defun *table--cell-self-insert-command ()
"Table cell version of `self-insert-command'."
@@ -4059,16 +4034,15 @@ key binding
(defun *table--present-cell-popup-menu (event)
"Present and handle cell popup menu."
(interactive "e")
- (unless table-disable-menu
- (select-window (posn-window (event-start event)))
- (goto-char (posn-point (event-start event)))
- (let ((item-list (x-popup-menu event table-cell-menu-map))
- (func table-cell-menu-map))
- (while item-list
- (setq func (nth 3 (assoc (car item-list) func)))
- (setq item-list (cdr item-list)))
- (if (and (symbolp func) (fboundp func))
- (call-interactively func)))))
+ (select-window (posn-window (event-start event)))
+ (goto-char (posn-point (event-start event)))
+ (let ((item-list (x-popup-menu event table-cell-menu-map))
+ (func table-cell-menu-map))
+ (while item-list
+ (setq func (nth 3 (assoc (car item-list) func)))
+ (setq item-list (cdr item-list)))
+ (if (and (symbolp func) (fboundp func))
+ (call-interactively func))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -4089,17 +4063,20 @@ cache buffer into the designated cell in the table buffer."
(and (boundp 'quail-translating)
quail-translating))
(setq table-update-timer
- (table--set-timer table-time-before-update
- (function table--update-cell)
- 'now))
+ (run-with-idle-timer table-time-before-update
+ nil
+ (function table--update-cell)
+ 'now))
(save-current-buffer
(set-buffer table-cell-buffer)
(let ((cache-buffer (get-buffer-create table-cache-buffer-name))
(org-coord (table--get-coordinate))
+ (fixed table-fixed-width-mode)
(in-cell (equal (table--cell-to-coord (table--probe-cell))
(cons table-cell-info-lu-coordinate table-cell-info-rb-coordinate)))
rectangle)
(set-buffer cache-buffer)
+ (setq-local table-fixed-width-mode fixed)
(setq rectangle
(extract-rectangle
1
@@ -4128,9 +4105,10 @@ cache buffer into the designated cell in the table buffer."
(setq table-widen-timer nil))
(if (not now)
(setq table-widen-timer
- (table--set-timer (+ table-time-before-update table-time-before-reformat)
- (function table--update-cell-widened)
- 'now))
+ (run-with-idle-timer (+ table-time-before-update table-time-before-reformat)
+ nil
+ (function table--update-cell-widened)
+ 'now))
(save-current-buffer
(if table-update-timer
(table--update-cell 'now))
@@ -4167,9 +4145,10 @@ cache buffer into the designated cell in the table buffer."
(setq table-heighten-timer nil))
(if (not now)
(setq table-heighten-timer
- (table--set-timer (+ table-time-before-update table-time-before-reformat)
- (function table--update-cell-heightened)
- 'now))
+ (run-with-idle-timer (+ table-time-before-update table-time-before-reformat)
+ nil
+ (function table--update-cell-heightened)
+ 'now))
(save-current-buffer
(if table-update-timer
(table--update-cell 'now))
@@ -4214,21 +4193,21 @@ cache buffer into the designated cell in the table buffer."
(1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
(defun table-goto-top-right-corner ()
- "Move point to top right corner of the current table and return the char position."
+ "Move point to top right corner of the current table and return char position."
(table--goto-coordinate
(cons
(car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
(1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
(defun table-goto-bottom-left-corner ()
- "Move point to bottom left corner of the current table and return the char position."
+ "Move point to bottom left corner of the current table and return char position."
(table--goto-coordinate
(cons
(1- (car (table--get-coordinate (car (table--horizontal-cell-list t t)))))
(1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))))
(defun table-goto-bottom-right-corner ()
- "Move point to bottom right corner of the current table and return the char position."
+ "Move point to bottom right corner of the current table and return char position."
(table--goto-coordinate
(cons
(car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
@@ -4255,9 +4234,8 @@ cache buffer into the designated cell in the table buffer."
PROMPT-HISTORY is a cons cell which car is the prompt string and the
cdr is the history symbol."
(let ((default (car (symbol-value (cdr prompt-history)))))
- (read-from-minibuffer
- (format "%s (default %s): " (car prompt-history) default)
- "" nil nil (cdr prompt-history) default))
+ (read-from-minibuffer (format-prompt (car prompt-history) default)
+ "" nil nil (cdr prompt-history) default))
(car (symbol-value (cdr prompt-history))))
(defun table--buffer-substring-and-trim (beg end)
@@ -4314,7 +4292,7 @@ Returns the coordinate of the final point location."
(let* ((completion-ignore-case t)
(default (car table-justify-history)))
(intern (downcase (completing-read
- (format "Justify (default %s): " default)
+ (format-prompt "Justify" default)
'(("left") ("center") ("right") ("top") ("middle") ("bottom") ("none"))
nil t nil 'table-justify-history default)))))
@@ -4714,8 +4692,7 @@ in the list."
(defun table--cell-insert-char (char &optional overwrite)
"Insert CHAR inside a table cell."
- (let ((delete-selection-p (and (boundp 'delete-selection-mode)
- delete-selection-mode
+ (let ((delete-selection-p (and delete-selection-mode
transient-mark-mode mark-active
(not buffer-read-only)))
(mark-coordinate (table--transcoord-table-to-cache (table--get-coordinate (mark t)))))
@@ -4944,7 +4921,7 @@ When optional LOCATION is provided the test is performed at that location."
t))
(defun table--region-in-cell-p (beg end)
- "Return t when location BEG and END are in a valid table cell in the current buffer."
+ "Return t when location BEG and END are in a valid table cell in current buffer."
(and (table--at-cell-p (min beg end))
(save-excursion
(let ((cell-beg (progn (goto-char beg) (table--probe-cell))))
@@ -5243,8 +5220,7 @@ This feature is disabled when `table-disable-incompatibility-warning'
is non-nil. The warning is done only once per session for each item."
(unless (and table-disable-incompatibility-warning
(not (called-interactively-p 'interactive)))
- (when (and (boundp 'flyspell-mode)
- flyspell-mode
+ (when (and flyspell-mode
(not (get 'table-disable-incompatibility-warning 'flyspell)))
(put 'table-disable-incompatibility-warning 'flyspell t)
(display-warning 'table
@@ -5265,7 +5241,7 @@ works better than the previous versions however not fully compatible.
str))
(defun table--remove-eol-spaces (beg end &optional bol force)
- "Remove spaces at the end of each line in the BEG END region of the current buffer.
+ "Remove spaces at the end of each line in the BEG END region of current buffer.
When optional BOL is non-nil spaces at the beginning of line are
removed. When optional FORCE is non-nil removal operation is enforced
even when point is within the removal area."
@@ -5406,7 +5382,8 @@ point"
(defun table--transcoord-table-to-cache (&optional coordinate)
"Transpose COORDINATE from table coordinate system to cache coordinate system.
-When COORDINATE is omitted or nil the point in current buffer is assumed in place."
+When COORDINATE is omitted or nil the point in current buffer is
+assumed in place."
(table--offset-coordinate
(or coordinate (table--get-coordinate))
table-cell-info-lu-coordinate
@@ -5414,7 +5391,8 @@ When COORDINATE is omitted or nil the point in current buffer is assumed in plac
(defun table--transcoord-cache-to-table (&optional coordinate)
"Transpose COORDINATE from cache coordinate system to table coordinate system.
-When COORDINATE is omitted or nil the point in current buffer is assumed in place."
+When COORDINATE is omitted or nil the point in current buffer is
+assumed in place."
(table--offset-coordinate
(or coordinate (table--get-coordinate))
table-cell-info-lu-coordinate))
@@ -5447,15 +5425,24 @@ It returns COLUMN unless STR contains some wide characters."
idx
nil)))
+
+;;;; Obsolete.
+
+(defvar table-disable-menu nil
+ "When non-nil, use of menu by table package is disabled.
+It must be set before loading this package `table.el' for the first
+time.")
+(make-obsolete-variable 'table-disable-menu "no longer used." "28.1")
+
(defun table--set-timer (seconds func args)
"Generic wrapper for setting up a timer."
+ (declare (obsolete run-with-idle-timer "28.1"))
(run-with-idle-timer seconds nil func args))
(defun table--get-last-command ()
"Generic wrapper for getting the real last command."
- (if (boundp 'real-last-command)
- real-last-command
- last-command))
+ (declare (obsolete real-last-command "28.1"))
+ real-last-command)
(run-hooks 'table-load-hook)
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 1f2043ac340..d9d8059f960 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -28,7 +28,6 @@
;;; Code:
-;; Pacify the byte-compiler
(eval-when-compile
(require 'compare-w)
(require 'cl-lib)
@@ -224,7 +223,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on."
:group 'tex-view)
;;;###autoload
-(defcustom tex-default-mode 'latex-mode
+(defcustom tex-default-mode #'latex-mode
"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.
@@ -422,7 +421,7 @@ An alternative value is \" . \", if you use a font with a narrow period."
(push (cons "--" (match-beginning 0)) menu))
;; Sort in increasing buffer position order.
- (sort menu (function (lambda (a b) (< (cdr a) (cdr b))))))))
+ (sort menu (lambda (a b) (< (cdr a) (cdr b)))))))
;;;;
;;;; Outline support
@@ -465,7 +464,7 @@ An alternative value is \" . \", if you use a font with a narrow period."
; ("{\\\\bf\\([^}]+\\)}" 1 'bold keep)
; ("{\\\\\\(em\\|it\\|sl\\)\\([^}]+\\)}" 2 'italic keep)
; ("\\\\\\([a-zA-Z@]+\\|.\\)" . font-lock-keyword-face)
-; ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep))
+; ("^[ \t\n]*\\\\def[\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep))
; ;; Rewritten and extended for LaTeX2e by Ulrik Dickow <dickow@nbi.dk>.
; '(("\\\\\\(begin\\|end\\|newcommand\\){\\([a-zA-Z0-9\\*]+\\)}"
; 2 font-lock-function-name-face)
@@ -593,18 +592,20 @@ An alternative value is \" . \", if you use a font with a narrow period."
;; Miscellany.
(slash "\\\\")
(opt " *\\(\\[[^]]*\\] *\\)*")
- (args "\\(\\(?:[^{}&\\]+\\|\\\\.\\|{[^}]*}\\)+\\)")
+ (args "\\(\\(?:[^${}&\\]+\\|\\\\.\\|{[^}]*}\\)+\\)")
(arg "{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)"))
(list
;;
;; Citation args.
(list (concat slash citations opt arg) 3 'font-lock-constant-face)
;;
- ;; Text between `` quotes ''.
- (cons (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
- "[^'\">{]+" ;a bit pessimistic
- (regexp-opt '("''" "\">" "\"'" ">>" "»") t))
- 'font-lock-string-face)
+ ;; Text between `` quotes ''.
+ (list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
+ "\\(\\(.\\|\n\\)+?\\)"
+ (regexp-opt `("''" "\">" "\"'" ">>" "»") t))
+ '(1 font-lock-keyword-face)
+ '(2 font-lock-string-face)
+ '(4 font-lock-keyword-face))
;;
;; Command names, special and general.
(cons (concat slash specials-1) 'font-lock-warning-face)
@@ -668,7 +669,9 @@ An alternative value is \" . \", if you use a font with a narrow period."
"Default expressions to highlight in TeX modes.")
(defvar tex-verbatim-environments
- '("verbatim" "verbatim*"))
+ '("verbatim" "verbatim*"
+ "Verbatim" ;; From "fancyvrb"
+ ))
(put 'tex-verbatim-environments 'safe-local-variable
(lambda (x) (not (memq nil (mapcar #'stringp x)))))
@@ -855,11 +858,11 @@ START is the position of the \\ and DELIM is the delimiter char."
(defun tex-define-common-keys (keymap)
"Define the keys that we want defined both in TeX mode and in the TeX shell."
- (define-key keymap "\C-c\C-k" 'tex-kill-job)
- (define-key keymap "\C-c\C-l" 'tex-recenter-output-buffer)
- (define-key keymap "\C-c\C-q" 'tex-show-print-queue)
- (define-key keymap "\C-c\C-p" 'tex-print)
- (define-key keymap "\C-c\C-v" 'tex-view)
+ (define-key keymap "\C-c\C-k" #'tex-kill-job)
+ (define-key keymap "\C-c\C-l" #'tex-recenter-output-buffer)
+ (define-key keymap "\C-c\C-q" #'tex-show-print-queue)
+ (define-key keymap "\C-c\C-p" #'tex-print)
+ (define-key keymap "\C-c\C-v" #'tex-view)
(define-key keymap [menu-bar tex] (cons "TeX" (make-sparse-keymap "TeX")))
@@ -882,27 +885,27 @@ START is the position of the \\ and DELIM is the delimiter char."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map text-mode-map)
(tex-define-common-keys map)
- (define-key map "\"" 'tex-insert-quote)
- (define-key map "\n" 'tex-handle-newline)
- (define-key map "\M-\r" 'latex-insert-item)
- (define-key map "\C-c}" 'up-list)
- (define-key map "\C-c{" 'tex-insert-braces)
- (define-key map "\C-c\C-r" 'tex-region)
- (define-key map "\C-c\C-b" 'tex-buffer)
- (define-key map "\C-c\C-f" 'tex-file)
- (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)
+ (define-key map "\"" #'tex-insert-quote)
+ (define-key map "\n" #'tex-handle-newline)
+ (define-key map "\M-\r" #'latex-insert-item)
+ (define-key map "\C-c}" #'up-list)
+ (define-key map "\C-c{" #'tex-insert-braces)
+ (define-key map "\C-c\C-r" #'tex-region)
+ (define-key map "\C-c\C-b" #'tex-buffer)
+ (define-key map "\C-c\C-f" #'tex-file)
+ (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)
- (define-key map [(control return)] 'tex-feed-input)
+ (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)
+ (define-key map [(control return)] #'tex-feed-input)
(define-key map [menu-bar tex tex-bibtex-file]
'("BibTeX File" . tex-bibtex-file))
(define-key map [menu-bar tex tex-validate-region]
@@ -920,7 +923,7 @@ START is the position of the \\ and DELIM is the delimiter char."
(defvar latex-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map tex-mode-map)
- (define-key map "\C-c\C-s" 'latex-split-block)
+ (define-key map "\C-c\C-s" #'latex-split-block)
map)
"Keymap for `latex-mode'. See also `tex-mode-map'.")
@@ -966,7 +969,7 @@ Inherits `shell-mode-map' with a few additions.")
;; This would be a lot simpler if we just used a regexp search,
;; but then it would be too slow.
-(defun tex-guess-mode ()
+(defun tex--guess-mode ()
(let ((mode tex-default-mode) slash comment)
(save-excursion
(goto-char (point-min))
@@ -983,52 +986,40 @@ Inherits `shell-mode-map' with a few additions.")
(regexp-opt '("documentstyle" "documentclass"
"begin" "subsection" "section"
"part" "chapter" "newcommand"
- "renewcommand" "RequirePackage") 'words)
+ "renewcommand" "RequirePackage")
+ 'words)
"\\|NeedsTeXFormat{LaTeX")))
(if (and (looking-at
"document\\(style\\|class\\)\\(\\[.*\\]\\)?{slides}")
;; SliTeX is almost never used any more nowadays.
(tex-executable-exists-p slitex-run-command))
- 'slitex-mode
- 'latex-mode)
- 'plain-tex-mode))))
- (funcall mode)))
+ #'slitex-mode
+ #'latex-mode)
+ #'plain-tex-mode))))
+ mode))
;; `tex-mode' plays two roles: it's the parent of several sub-modes
;; but it's also the function that chooses between those submodes.
;; To tell the difference between those two cases where the function
;; might be called, we check `delay-mode-hooks'.
-(define-derived-mode tex-mode text-mode "generic-TeX"
- (tex-common-initialization))
-;; We now move the function and define it again. This gives a warning
-;; in the byte-compiler :-( but it's difficult to avoid because
-;; `define-derived-mode' will necessarily define the function once
-;; and we need to define it a second time for `autoload' to get the
-;; proper docstring.
-(defalias 'tex-mode-internal (symbol-function 'tex-mode))
-
-;; Suppress the byte-compiler warning about multiple definitions.
-;; This is a) ugly, and b) cheating, but this was the last
-;; remaining warning from byte-compiling all of Emacs...
-(eval-when-compile
- (if (boundp 'byte-compile-function-environment)
- (setq byte-compile-function-environment
- (delq (assq 'tex-mode byte-compile-function-environment)
- byte-compile-function-environment))))
-
;;;###autoload
-(defun tex-mode ()
+(define-derived-mode tex-mode text-mode "generic-TeX"
"Major mode for editing files of input for TeX, LaTeX, or SliTeX.
+This is the shared parent mode of several submodes.
Tries to determine (by looking at the beginning of the file) whether
this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode',
-`latex-mode', or `slitex-mode', respectively. If it cannot be determined,
+`latex-mode', or `slitex-mode', accordingly. If it cannot be determined,
such as if there are no commands in the file, the value of `tex-default-mode'
says which mode to use."
- (interactive)
- (if delay-mode-hooks
- ;; We're called from one of the children already.
- (tex-mode-internal)
- (tex-guess-mode)))
+ (tex-common-initialization))
+
+(advice-add 'tex-mode :around #'tex--redirect-to-submode)
+(defun tex--redirect-to-submode (orig-fun)
+ "Redirect to one of the submodes when called directly."
+ (funcall (if delay-mode-hooks
+ ;; We're called from one of the children already.
+ orig-fun
+ (tex--guess-mode))))
;; The following three autoloaded aliases appear to conflict with
;; AUCTeX. However, even though AUCTeX uses the mixed case variants
@@ -1037,13 +1028,17 @@ says which mode to use."
;; AUCTeX to provide a fully functional user-level replacement. So
;; these aliases should remain as they are, in particular since AUCTeX
;; users are likely to use them.
+;; Note from Stef: I don't understand the above explanation, the only
+;; justification I can find to keep those confusing aliases is for those
+;; users who may have files annotated with -*- LaTeX -*- (e.g. because they
+;; received them from someone using AUCTeX).
;;;###autoload
-(defalias 'TeX-mode 'tex-mode)
+(defalias 'TeX-mode #'tex-mode)
;;;###autoload
-(defalias 'plain-TeX-mode 'plain-tex-mode)
+(defalias 'plain-TeX-mode #'plain-tex-mode)
;;;###autoload
-(defalias 'LaTeX-mode 'latex-mode)
+(defalias 'LaTeX-mode #'latex-mode)
;;;###autoload
(define-derived-mode plain-tex-mode tex-mode "TeX"
@@ -1175,7 +1170,12 @@ subshell is initiated, `tex-shell-hook' is run."
(setq-local outline-regexp latex-outline-regexp)
(setq-local outline-level #'latex-outline-level)
(setq-local forward-sexp-function #'latex-forward-sexp)
- (setq-local skeleton-end-hook nil))
+ (setq-local skeleton-end-hook nil)
+ (setq-local comment-region-function #'latex--comment-region)
+ (setq-local comment-style 'plain))
+
+(defun latex--comment-region (beg end &optional arg)
+ (comment-region-default-1 beg end arg t))
;;;###autoload
(define-derived-mode slitex-mode latex-mode "SliTeX"
@@ -1252,10 +1252,10 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
("\\\\[a-zA-Z]+\\( +\\|{}\\)[a-zA-Z]*" . "")
("%" . "$"))))
;; A line containing just $$ is treated as a paragraph separator.
- (setq-local paragraph-start "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$")
+ (setq-local paragraph-start "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$")
;; A line starting with $$ starts a paragraph,
;; but does not separate paragraphs if it has more stuff on it.
- (setq-local paragraph-separate "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$[ \t]*$")
+ (setq-local paragraph-separate "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$[ \t]*$")
(setq-local add-log-current-defun-function #'tex-current-defun-name)
(setq-local comment-start "%")
(setq-local comment-add 1)
@@ -1426,20 +1426,25 @@ on the line for the invalidity you want to see."
;; Skip "Mismatches:" header line.
(forward-line 1)
(setq num-matches (1+ num-matches))
- (insert-buffer-substring buffer start end)
- (let (text-beg (text-end (point-marker)))
- (forward-char (- start end))
- (setq text-beg (point-marker))
- (insert (format "%3d: " linenum))
- (add-text-properties
- text-beg (- text-end 1)
- '(mouse-face highlight
- help-echo
- "mouse-2: go to this invalidity"))
- (put-text-property text-beg (- text-end 1)
- 'occur-target tem))))))))
+ (let ((inhibit-read-only t))
+ (insert-buffer-substring buffer start end)
+ (let ((text-end (point-marker))
+ text-beg)
+ (forward-char (- start end))
+ (setq text-beg (point-marker))
+ (insert (format "%3d: " linenum))
+ (add-text-properties
+ text-beg (- text-end 1)
+ '(mouse-face highlight
+ help-echo
+ "mouse-2: go to this invalidity"))
+ (put-text-property (point) (- text-end 1)
+ 'occur-match t)
+ (put-text-property text-beg text-end
+ 'occur-target tem)))))))))
(with-current-buffer standard-output
- (let ((no-matches (zerop num-matches)))
+ (let ((no-matches (zerop num-matches))
+ (inhibit-read-only t))
(if no-matches
(insert "None!\n"))
(if (called-interactively-p 'interactive)
@@ -1561,7 +1566,7 @@ the name of the environment and SKEL-ELEM is an element to use in
a skeleton (see `skeleton-insert').")
;; Like tex-insert-braces, but for LaTeX.
-(defalias 'tex-latex-block 'latex-insert-block)
+(defalias 'tex-latex-block #'latex-insert-block)
(define-skeleton latex-insert-block
"Create a matching pair of lines \\begin{NAME} and \\end{NAME} at point.
Puts point on a blank line between them."
@@ -1867,7 +1872,7 @@ Mark is left at original location."
(with-syntax-table tex-mode-syntax-table
(forward-sexp))))))
-(defalias 'tex-close-latex-block 'latex-close-block)
+(defalias 'tex-close-latex-block #'latex-close-block)
(define-skeleton latex-close-block
"Create an \\end{...} to match the last unclosed \\begin{...}."
(save-excursion
@@ -2009,7 +2014,7 @@ Mark is left at original location."
;; Specify an interactive shell, to make sure it prompts.
"-i")
(let ((proc (get-process "tex-shell")))
- (set-process-sentinel proc 'tex-shell-sentinel)
+ (set-process-sentinel proc #'tex-shell-sentinel)
(set-process-query-on-exit-flag proc nil)
(tex-shell)
(while (zerop (buffer-size))
@@ -2045,8 +2050,7 @@ In the tex shell buffer this command behaves like `comint-send-input'."
(with-current-buffer buffer
(setq default-directory directory))))
-(defvar tex-send-command-modified-tick 0)
-(make-variable-buffer-local 'tex-send-command-modified-tick)
+(defvar-local tex-send-command-modified-tick 0)
(defun tex-shell-proc ()
(or (tex-shell-running) (error "No TeX subprocess")))
@@ -2065,7 +2069,7 @@ evaluates to a command string.
Return the process in which TeX is running."
(save-excursion
- (let* ((cmd (eval command))
+ (let* ((cmd (eval command t))
(proc (tex-shell-proc))
(buf (process-buffer proc))
(star (string-match "\\*" cmd))
@@ -2133,6 +2137,7 @@ If NOT-ALL is non-nil, save the `.dvi' file."
(defvar tex-compile-commands
`(,@(mapcar (lambda (prefix)
`((concat ,prefix tex-command
+ " " tex-start-options
" " (if (< 0 (length tex-start-commands))
(shell-quote-argument tex-start-commands))
" %f")
@@ -2301,9 +2306,6 @@ FILE is typically the output DVI or PDF file."
(setq uptodate nil)))))
uptodate)))
-
-(autoload 'format-spec "format-spec")
-
(defvar tex-executable-cache nil)
(defun tex-executable-exists-p (name)
"Like `executable-find' but with a cache."
@@ -2318,7 +2320,7 @@ FILE is typically the output DVI or PDF file."
executable))))))
(defun tex-command-executable (cmd)
- (let ((s (if (stringp cmd) cmd (eval (car cmd)))))
+ (let ((s (if (stringp cmd) cmd (eval (car cmd) t))))
(substring s 0 (string-match "[ \t]\\|\\'" s))))
(defun tex-command-active-p (cmd fspec)
@@ -2340,9 +2342,14 @@ FILE is typically the output DVI or PDF file."
:version "23.1"
:group 'tex-run)
+(defun tex--quote-spec (fspec)
+ (cl-loop for (char . file) in fspec
+ collect (cons char (shell-quote-argument file))))
+
(defun tex-format-cmd (format fspec)
"Like `format-spec' but adds user-specified args to the command.
Only applies the FSPEC to the args part of FORMAT."
+ (setq fspec (tex--quote-spec fspec))
(if (not (string-match "\\([^ /\\]+\\) " format))
(format-spec format fspec)
(let* ((prefix (substring format 0 (match-beginning 0)))
@@ -2400,7 +2407,7 @@ Only applies the FSPEC to the args part of FORMAT."
(setq latest (nth 1 cmd) cmds (list cmd)))))))
;; Expand the command spec into the actual text.
(dolist (cmd (prog1 cmds (setq cmds nil)))
- (push (cons (eval (car cmd)) (cdr cmd)) cmds))
+ (push (cons (eval (car cmd) t) (cdr cmd)) cmds))
;; Select the favorite command from the history.
(let ((hist tex-compile-history)
re hist-cmd)
@@ -2439,14 +2446,14 @@ Only applies the FSPEC to the args part of FORMAT."
(prog1 (file-name-directory (expand-file-name file))
(setq file (file-name-nondirectory file))))
(root (file-name-sans-extension file))
- (fspec (list (cons ?r (shell-quote-argument root))
- (cons ?f (shell-quote-argument file))))
+ (fspec (list (cons ?r root)
+ (cons ?f file)))
(default (tex-compile-default fspec)))
(list default-directory
(completing-read
(format "Command [%s]: " (tex-summarize-command default))
(mapcar (lambda (x)
- (list (tex-format-cmd (eval (car x)) fspec)))
+ (list (tex-format-cmd (eval (car x) t) fspec)))
tex-compile-commands)
nil nil nil 'tex-compile-history default))))
(save-some-buffers (not compilation-ask-about-save) nil)
@@ -2740,7 +2747,7 @@ because there is no standard value that would generally work."
;; Restart the TeX shell if necessary.
(or (tex-shell-running)
(tex-start-shell))
- (let ((tex-dvi-print-command (eval tex-dvi-view-command)))
+ (let ((tex-dvi-print-command (eval tex-dvi-view-command t)))
(tex-print)))
(defun tex-append (file-name suffix)
@@ -3550,6 +3557,8 @@ There might be text before point."
(process-send-region tex-chktex--process (point-min) (point-max))
(process-send-eof tex-chktex--process))))
+(make-obsolete-variable 'tex-mode-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'tex-mode-load-hook)
(provide 'tex-mode)
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index ed0a367d01d..977f3bab6ce 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -1,4 +1,4 @@
-;;; texinfmt.el --- format Texinfo files into Info files
+;;; texinfmt.el --- format Texinfo files into Info files -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1988, 1990-1998, 2000-2021 Free Software
;; Foundation, Inc.
@@ -23,15 +23,17 @@
;;; Commentary:
-;;; Code:
+;;; Emacs Lisp functions to convert Texinfo files to Info files.
-;;; Emacs lisp functions to convert Texinfo files to Info files.
+;;; Code:
(defvar texinfmt-version "2.42 of 7 Jul 2006")
+(make-obsolete-variable 'texinfmt-version 'emacs-version "28.1")
(defun texinfmt-version (&optional here)
"Show the version of texinfmt.el in the minibuffer.
If optional argument HERE is non-nil, insert info at point."
+ (declare (obsolete emacs-version "28.1"))
(interactive "P")
(let ((version-string
(format-message "Version of `texinfmt.el': %s" texinfmt-version)))
@@ -184,6 +186,7 @@ containing the Texinfo file.")
;; These come from tex-mode.el.
(defvar tex-start-of-header)
(defvar tex-end-of-header)
+(defvar texinfo-example-start)
;;;###autoload
(defun texinfo-format-region (region-beginning region-end)
@@ -209,7 +212,7 @@ converted to Info is stored in a temporary buffer."
texinfo-last-node
texinfo-node-names
(texinfo-footnote-number 0)
- last-input-buffer
+ ;; last-input-buffer
(fill-column-for-info fill-column)
(input-buffer (current-buffer))
(input-directory default-directory)
@@ -345,8 +348,8 @@ converted to Info is stored in a temporary buffer."
(file-name-nondirectory
(buffer-file-name input-buffer))))
(format-message "buffer `%s'" (buffer-name input-buffer)))
- (format-message "\nusing `texinfmt.el' version ")
- texinfmt-version
+ (format-message "\nusing `texinfmt.el' on Emacs version ")
+ emacs-version
".\n\n")
;; Now convert for real.
@@ -403,7 +406,7 @@ if large. You can use `Info-split' to do this manually."
texinfo-stack
texinfo-node-names
(texinfo-footnote-number 0)
- last-input-buffer
+ ;; last-input-buffer
outfile
(fill-column-for-info fill-column)
(input-buffer (current-buffer))
@@ -489,8 +492,8 @@ if large. You can use `Info-split' to do this manually."
(file-name-nondirectory
(buffer-file-name input-buffer))))
(format-message "buffer `%s'" (buffer-name input-buffer)))
- (format-message "\nusing `texinfmt.el' version ")
- texinfmt-version
+ (format-message "\nusing `texinfmt.el' on Emacs version ")
+ emacs-version
".\n\n")
;; Return data for indices.
(list outfile
@@ -922,7 +925,7 @@ commands."
(error "Unterminated @%s" (car (car texinfo-stack)))))
;; Remove excess whitespace
- (let ((whitespace-silent t))
+ (dlet ((whitespace-silent t))
(whitespace-cleanup)))
(defvar texinfo-copying-text ""
@@ -1030,18 +1033,18 @@ Leave point after argument."
(defun texinfo-optional-braces-discard ()
"Discard braces following command, if any."
(goto-char texinfo-command-end)
- (let ((start (point)))
- (cond ((looking-at "[ \t]*\n")) ; do nothing
- ((looking-at "{") ; remove braces, if any
- (forward-list 1)
- (setq texinfo-command-end (point)))
- (t
- (error
- "Invalid `texinfo-optional-braces-discard' format (need braces?)")))
- (delete-region texinfo-command-start texinfo-command-end)))
+ ;; (let ((start (point)))
+ (cond ((looking-at "[ \t]*\n")) ; do nothing
+ ((looking-at "{") ; remove braces, if any
+ (forward-list 1)
+ (setq texinfo-command-end (point)))
+ (t
+ (error
+ "Invalid `texinfo-optional-braces-discard' format (need braces?)")))
+ (delete-region texinfo-command-start texinfo-command-end)) ;;)
(defun texinfo-format-parse-line-args ()
- (let ((start (1- (point)))
+ (let (;; (start (1- (point)))
next beg end
args)
(skip-chars-forward " ")
@@ -1062,7 +1065,7 @@ Leave point after argument."
(nreverse args)))
(defun texinfo-format-parse-args ()
- (let ((start (1- (point)))
+ (let (;; (start (1- (point)))
next beg end
args)
(search-forward "{")
@@ -2005,26 +2008,26 @@ commands that are defined in texinfo.tex for printed output.
;;
;; Case 2: {Column 1 template} {Column 2} {Column 3 example}
((looking-at "{")
- (let ((start-of-templates (point)))
- (while (not (eolp))
- (skip-chars-forward " \t")
- (let* ((start-of-template (1+ (point)))
- (end-of-template
- ;; forward-sexp works with braces in Texinfo mode
- (progn (forward-sexp 1) (1- (point)))))
- (push (- end-of-template start-of-template)
- texinfo-multitable-width-list)
- ;; Remove carriage return from within a template, if any.
- ;; This helps those who want to use more than
- ;; one line's worth of words in @multitable line.
- (narrow-to-region start-of-template end-of-template)
- (goto-char (point-min))
- (while (search-forward "
+ ;; (let ((start-of-templates (point)))
+ (while (not (eolp))
+ (skip-chars-forward " \t")
+ (let* ((start-of-template (1+ (point)))
+ (end-of-template
+ ;; forward-sexp works with braces in Texinfo mode
+ (progn (forward-sexp 1) (1- (point)))))
+ (push (- end-of-template start-of-template)
+ texinfo-multitable-width-list)
+ ;; Remove carriage return from within a template, if any.
+ ;; This helps those who want to use more than
+ ;; one line's worth of words in @multitable line.
+ (narrow-to-region start-of-template end-of-template)
+ (goto-char (point-min))
+ (while (search-forward "
" nil t)
- (delete-char -1))
- (goto-char (point-max))
- (widen)
- (forward-char 1)))))
+ (delete-char -1))
+ (goto-char (point-max))
+ (widen)
+ (forward-char 1)))) ;; )
;;
;; Case 3: Trouble
(t
@@ -2038,7 +2041,7 @@ commands that are defined in texinfo.tex for printed output.
;; additional between column spaces, if any
texinfo-extra-inter-column-width
;; sum of spaces for each entry
- (apply '+ texinfo-multitable-width-list))))
+ (apply #'+ texinfo-multitable-width-list))))
(if (> desired-columns fill-column)
(error
"Multi-column table width, %d chars, is greater than page width, %d chars."
@@ -2169,9 +2172,9 @@ This command is executed when texinfmt sees @item inside @multitable."
(while (< column-number total-number-of-columns)
(setq here (point))
(insert-rectangle
- (eval (intern
- (concat texinfo-multitable-rectangle-name
- (int-to-string column-number)))))
+ (symbol-value (intern
+ (concat texinfo-multitable-rectangle-name
+ (int-to-string column-number)))))
(goto-char here)
(end-of-line)
(setq column-number (1+ column-number))))
@@ -2394,8 +2397,8 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
(put 'alias 'texinfo-format 'texinfo-alias)
(defun texinfo-alias ()
- (let ((start (1- (point)))
- args)
+ (let (;; (start (1- (point))
+ ) ;; args
(skip-chars-forward " ")
(setq texinfo-command-end (line-end-position))
(if (not (looking-at "\\([^=]+\\)=\\(.*\\)"))
@@ -3408,7 +3411,7 @@ Default is to leave paragraph indentation as is."
(while args
(insert " "
(if (or (= ?& (aref (car args) 0))
- (eq (eval (car texinfo-defun-type)) 'deftp-type))
+ (eq (car texinfo-defun-type) 'deftp-type))
(car args)
(upcase (car args))))
(setq args (cdr args)))))
@@ -3773,80 +3776,80 @@ Default is to leave paragraph indentation as is."
(put 'deffn 'texinfo-format 'texinfo-format-defun)
(put 'deffnx 'texinfo-format 'texinfo-format-defunx)
(put 'deffn 'texinfo-end 'texinfo-end-defun)
-(put 'deffn 'texinfo-defun-type '('deffn-type nil))
-(put 'deffnx 'texinfo-defun-type '('deffn-type nil))
+(put 'deffn 'texinfo-defun-type '(deffn-type nil))
+(put 'deffnx 'texinfo-defun-type '(deffn-type nil))
(put 'deffn 'texinfo-defun-index 'texinfo-findex)
(put 'deffnx 'texinfo-defun-index 'texinfo-findex)
(put 'defun 'texinfo-format 'texinfo-format-defun)
(put 'defunx 'texinfo-format 'texinfo-format-defunx)
(put 'defun 'texinfo-end 'texinfo-end-defun)
-(put 'defun 'texinfo-defun-type '('defun-type "Function"))
-(put 'defunx 'texinfo-defun-type '('defun-type "Function"))
+(put 'defun 'texinfo-defun-type '(defun-type "Function"))
+(put 'defunx 'texinfo-defun-type '(defun-type "Function"))
(put 'defun 'texinfo-defun-index 'texinfo-findex)
(put 'defunx 'texinfo-defun-index 'texinfo-findex)
(put 'defmac 'texinfo-format 'texinfo-format-defun)
(put 'defmacx 'texinfo-format 'texinfo-format-defunx)
(put 'defmac 'texinfo-end 'texinfo-end-defun)
-(put 'defmac 'texinfo-defun-type '('defun-type "Macro"))
-(put 'defmacx 'texinfo-defun-type '('defun-type "Macro"))
+(put 'defmac 'texinfo-defun-type '(defun-type "Macro"))
+(put 'defmacx 'texinfo-defun-type '(defun-type "Macro"))
(put 'defmac 'texinfo-defun-index 'texinfo-findex)
(put 'defmacx 'texinfo-defun-index 'texinfo-findex)
(put 'defspec 'texinfo-format 'texinfo-format-defun)
(put 'defspecx 'texinfo-format 'texinfo-format-defunx)
(put 'defspec 'texinfo-end 'texinfo-end-defun)
-(put 'defspec 'texinfo-defun-type '('defun-type "Special form"))
-(put 'defspecx 'texinfo-defun-type '('defun-type "Special form"))
+(put 'defspec 'texinfo-defun-type '(defun-type "Special form"))
+(put 'defspecx 'texinfo-defun-type '(defun-type "Special form"))
(put 'defspec 'texinfo-defun-index 'texinfo-findex)
(put 'defspecx 'texinfo-defun-index 'texinfo-findex)
(put 'defvr 'texinfo-format 'texinfo-format-defun)
(put 'defvrx 'texinfo-format 'texinfo-format-defunx)
(put 'defvr 'texinfo-end 'texinfo-end-defun)
-(put 'defvr 'texinfo-defun-type '('deffn-type nil))
-(put 'defvrx 'texinfo-defun-type '('deffn-type nil))
+(put 'defvr 'texinfo-defun-type '(deffn-type nil))
+(put 'defvrx 'texinfo-defun-type '(deffn-type nil))
(put 'defvr 'texinfo-defun-index 'texinfo-vindex)
(put 'defvrx 'texinfo-defun-index 'texinfo-vindex)
(put 'defvar 'texinfo-format 'texinfo-format-defun)
(put 'defvarx 'texinfo-format 'texinfo-format-defunx)
(put 'defvar 'texinfo-end 'texinfo-end-defun)
-(put 'defvar 'texinfo-defun-type '('defun-type "Variable"))
-(put 'defvarx 'texinfo-defun-type '('defun-type "Variable"))
+(put 'defvar 'texinfo-defun-type '(defun-type "Variable"))
+(put 'defvarx 'texinfo-defun-type '(defun-type "Variable"))
(put 'defvar 'texinfo-defun-index 'texinfo-vindex)
(put 'defvarx 'texinfo-defun-index 'texinfo-vindex)
(put 'defconst 'texinfo-format 'texinfo-format-defun)
(put 'defconstx 'texinfo-format 'texinfo-format-defunx)
(put 'defconst 'texinfo-end 'texinfo-end-defun)
-(put 'defconst 'texinfo-defun-type '('defun-type "Constant"))
-(put 'defconstx 'texinfo-defun-type '('defun-type "Constant"))
+(put 'defconst 'texinfo-defun-type '(defun-type "Constant"))
+(put 'defconstx 'texinfo-defun-type '(defun-type "Constant"))
(put 'defconst 'texinfo-defun-index 'texinfo-vindex)
(put 'defconstx 'texinfo-defun-index 'texinfo-vindex)
(put 'defcmd 'texinfo-format 'texinfo-format-defun)
(put 'defcmdx 'texinfo-format 'texinfo-format-defunx)
(put 'defcmd 'texinfo-end 'texinfo-end-defun)
-(put 'defcmd 'texinfo-defun-type '('defun-type "Command"))
-(put 'defcmdx 'texinfo-defun-type '('defun-type "Command"))
+(put 'defcmd 'texinfo-defun-type '(defun-type "Command"))
+(put 'defcmdx 'texinfo-defun-type '(defun-type "Command"))
(put 'defcmd 'texinfo-defun-index 'texinfo-findex)
(put 'defcmdx 'texinfo-defun-index 'texinfo-findex)
(put 'defopt 'texinfo-format 'texinfo-format-defun)
(put 'defoptx 'texinfo-format 'texinfo-format-defunx)
(put 'defopt 'texinfo-end 'texinfo-end-defun)
-(put 'defopt 'texinfo-defun-type '('defun-type "User Option"))
-(put 'defoptx 'texinfo-defun-type '('defun-type "User Option"))
+(put 'defopt 'texinfo-defun-type '(defun-type "User Option"))
+(put 'defoptx 'texinfo-defun-type '(defun-type "User Option"))
(put 'defopt 'texinfo-defun-index 'texinfo-vindex)
(put 'defoptx 'texinfo-defun-index 'texinfo-vindex)
(put 'deftp 'texinfo-format 'texinfo-format-defun)
(put 'deftpx 'texinfo-format 'texinfo-format-defunx)
(put 'deftp 'texinfo-end 'texinfo-end-defun)
-(put 'deftp 'texinfo-defun-type '('deftp-type nil))
-(put 'deftpx 'texinfo-defun-type '('deftp-type nil))
+(put 'deftp 'texinfo-defun-type '(deftp-type nil))
+(put 'deftpx 'texinfo-defun-type '(deftp-type nil))
(put 'deftp 'texinfo-defun-index 'texinfo-tindex)
(put 'deftpx 'texinfo-defun-index 'texinfo-tindex)
@@ -3855,32 +3858,32 @@ Default is to leave paragraph indentation as is."
(put 'defop 'texinfo-format 'texinfo-format-defun)
(put 'defopx 'texinfo-format 'texinfo-format-defunx)
(put 'defop 'texinfo-end 'texinfo-end-defun)
-(put 'defop 'texinfo-defun-type '('defop-type nil))
-(put 'defopx 'texinfo-defun-type '('defop-type nil))
+(put 'defop 'texinfo-defun-type '(defop-type nil))
+(put 'defopx 'texinfo-defun-type '(defop-type nil))
(put 'defop 'texinfo-defun-index 'texinfo-findex)
(put 'defopx 'texinfo-defun-index 'texinfo-findex)
(put 'defmethod 'texinfo-format 'texinfo-format-defun)
(put 'defmethodx 'texinfo-format 'texinfo-format-defunx)
(put 'defmethod 'texinfo-end 'texinfo-end-defun)
-(put 'defmethod 'texinfo-defun-type '('defmethod-type "Method"))
-(put 'defmethodx 'texinfo-defun-type '('defmethod-type "Method"))
+(put 'defmethod 'texinfo-defun-type '(defmethod-type "Method"))
+(put 'defmethodx 'texinfo-defun-type '(defmethod-type "Method"))
(put 'defmethod 'texinfo-defun-index 'texinfo-findex)
(put 'defmethodx 'texinfo-defun-index 'texinfo-findex)
(put 'defcv 'texinfo-format 'texinfo-format-defun)
(put 'defcvx 'texinfo-format 'texinfo-format-defunx)
(put 'defcv 'texinfo-end 'texinfo-end-defun)
-(put 'defcv 'texinfo-defun-type '('defop-type nil))
-(put 'defcvx 'texinfo-defun-type '('defop-type nil))
+(put 'defcv 'texinfo-defun-type '(defop-type nil))
+(put 'defcvx 'texinfo-defun-type '(defop-type nil))
(put 'defcv 'texinfo-defun-index 'texinfo-vindex)
(put 'defcvx 'texinfo-defun-index 'texinfo-vindex)
(put 'defivar 'texinfo-format 'texinfo-format-defun)
(put 'defivarx 'texinfo-format 'texinfo-format-defunx)
(put 'defivar 'texinfo-end 'texinfo-end-defun)
-(put 'defivar 'texinfo-defun-type '('defmethod-type "Instance variable"))
-(put 'defivarx 'texinfo-defun-type '('defmethod-type "Instance variable"))
+(put 'defivar 'texinfo-defun-type '(defmethod-type "Instance variable"))
+(put 'defivarx 'texinfo-defun-type '(defmethod-type "Instance variable"))
(put 'defivar 'texinfo-defun-index 'texinfo-vindex)
(put 'defivarx 'texinfo-defun-index 'texinfo-vindex)
@@ -3889,32 +3892,32 @@ Default is to leave paragraph indentation as is."
(put 'deftypefn 'texinfo-format 'texinfo-format-defun)
(put 'deftypefnx 'texinfo-format 'texinfo-format-defunx)
(put 'deftypefn 'texinfo-end 'texinfo-end-defun)
-(put 'deftypefn 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypefnx 'texinfo-defun-type '('deftypefn-type nil))
+(put 'deftypefn 'texinfo-defun-type '(deftypefn-type nil))
+(put 'deftypefnx 'texinfo-defun-type '(deftypefn-type nil))
(put 'deftypefn 'texinfo-defun-index 'texinfo-findex)
(put 'deftypefnx 'texinfo-defun-index 'texinfo-findex)
(put 'deftypefun 'texinfo-format 'texinfo-format-defun)
(put 'deftypefunx 'texinfo-format 'texinfo-format-defunx)
(put 'deftypefun 'texinfo-end 'texinfo-end-defun)
-(put 'deftypefun 'texinfo-defun-type '('deftypefun-type "Function"))
-(put 'deftypefunx 'texinfo-defun-type '('deftypefun-type "Function"))
+(put 'deftypefun 'texinfo-defun-type '(deftypefun-type "Function"))
+(put 'deftypefunx 'texinfo-defun-type '(deftypefun-type "Function"))
(put 'deftypefun 'texinfo-defun-index 'texinfo-findex)
(put 'deftypefunx 'texinfo-defun-index 'texinfo-findex)
(put 'deftypevr 'texinfo-format 'texinfo-format-defun)
(put 'deftypevrx 'texinfo-format 'texinfo-format-defunx)
(put 'deftypevr 'texinfo-end 'texinfo-end-defun)
-(put 'deftypevr 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypevrx 'texinfo-defun-type '('deftypefn-type nil))
+(put 'deftypevr 'texinfo-defun-type '(deftypefn-type nil))
+(put 'deftypevrx 'texinfo-defun-type '(deftypefn-type nil))
(put 'deftypevr 'texinfo-defun-index 'texinfo-vindex)
(put 'deftypevrx 'texinfo-defun-index 'texinfo-vindex)
(put 'deftypevar 'texinfo-format 'texinfo-format-defun)
(put 'deftypevarx 'texinfo-format 'texinfo-format-defunx)
(put 'deftypevar 'texinfo-end 'texinfo-end-defun)
-(put 'deftypevar 'texinfo-defun-type '('deftypevar-type "Variable"))
-(put 'deftypevarx 'texinfo-defun-type '('deftypevar-type "Variable"))
+(put 'deftypevar 'texinfo-defun-type '(deftypevar-type "Variable"))
+(put 'deftypevarx 'texinfo-defun-type '(deftypevar-type "Variable"))
(put 'deftypevar 'texinfo-defun-index 'texinfo-vindex)
(put 'deftypevarx 'texinfo-defun-index 'texinfo-vindex)
@@ -3941,7 +3944,8 @@ Default is to leave paragraph indentation as is."
"Clear the value of the flag."
(let* ((arg (texinfo-parse-arg-discard))
(flag (car (read-from-string arg)))
- (value (substring arg (cdr (read-from-string arg)))))
+ ;; (value (substring arg (cdr (read-from-string arg))))
+ )
(put flag 'texinfo-whether-setp 'flag-cleared)
(put flag 'texinfo-set-value "")))
@@ -4041,7 +4045,7 @@ the @ifeq command."
(goto-char texinfo-command-end)
(let* ((case-fold-search t)
(stop (save-excursion (forward-sexp 1) (point)))
- start end
+ start ;; end
;; @ifeq{arg1, arg2, @command{optional-args}}
(arg1
(progn
@@ -4306,8 +4310,6 @@ For example, invoke
(setq error 1))))
(kill-emacs error))))
-
-;;; Place `provide' at end of file.
(provide 'texinfmt)
;;; texinfmt.el ends here
diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el
index 572b93d6a97..11d60e1eb03 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -1,4 +1,4 @@
-;;; texinfo.el --- major mode for editing Texinfo files
+;;; texinfo.el --- major mode for editing Texinfo files -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 1988-1993, 1996-1997, 2000-2021 Free Software
;; Foundation, Inc.
@@ -54,220 +54,27 @@
;;;###autoload
(defcustom texinfo-open-quote (purecopy "``")
"String inserted by typing \\[texinfo-insert-quote] to open a quotation."
- :type 'string
- :group 'texinfo)
+ :type 'string)
;;;###autoload
(defcustom texinfo-close-quote (purecopy "''")
"String inserted by typing \\[texinfo-insert-quote] to close a quotation."
- :type 'string
- :group 'texinfo)
+ :type 'string)
(defcustom texinfo-mode-hook nil
"Normal hook run when entering Texinfo mode."
:type 'hook
- :options '(turn-on-auto-fill flyspell-mode)
- :group 'texinfo)
+ :options '(turn-on-auto-fill flyspell-mode))
;;; Autoloads:
-(autoload 'makeinfo-region
- "makeinfo"
- "Make Info file from region of current Texinfo file, and switch to it.
-
-This command does not offer the `next-error' feature since it would
-apply to a temporary file, not the original; use the `makeinfo-buffer'
-command to gain use of `next-error'."
- t nil)
-
-(autoload 'makeinfo-buffer
- "makeinfo"
- "Make Info file from current buffer.
-
-Use the \\[next-error] command to move to the next error
-\(if there are errors)."
- t nil)
-
(autoload 'kill-compilation
"compile"
"Kill the process made by the \\[compile] command."
t nil)
-(autoload 'makeinfo-recenter-compilation-buffer
- "makeinfo"
- "Redisplay `*compilation*' buffer so most recent output can be seen.
-The last line of the buffer is displayed on
-line LINE of the window, or centered if LINE is nil."
- t nil)
-
-(autoload 'texinfo-update-node
- "texnfo-upd"
- "Without any prefix argument, update the node in which point is located.
-Non-nil argument (prefix, if interactive) means update the nodes in the
-marked region.
-
-The functions for creating or updating nodes and menus, and their
-keybindings, are:
-
- `texinfo-update-node' (&optional region-p) \\[texinfo-update-node]
- `texinfo-every-node-update' () \\[texinfo-every-node-update]
- `texinfo-sequential-node-update' (&optional region-p)
-
- `texinfo-make-menu' (&optional region-p) \\[texinfo-make-menu]
- `texinfo-all-menus-update' () \\[texinfo-all-menus-update]
- `texinfo-master-menu' ()
-
- `texinfo-indent-menu-description' (column &optional region-p)
-
-The `texinfo-column-for-description' variable specifies the column to
-which menu descriptions are indented. Its default value is 32."
- t nil)
-
-(autoload 'texinfo-every-node-update
- "texnfo-upd"
- "Update every node in a Texinfo file."
- t nil)
-
-(autoload 'texinfo-sequential-node-update
- "texnfo-upd"
- "Update one node (or many) in a Texinfo file with sequential pointers.
-
-This function causes the `Next' or `Previous' pointer to point to the
-immediately preceding or following node, even if it is at a higher or
-lower hierarchical level in the document. Continually pressing `n' or
-`p' takes you straight through the file.
-
-Without any prefix argument, update the node in which point is located.
-Non-nil argument (prefix, if interactive) means update the nodes in the
-marked region.
-
-This command makes it awkward to navigate among sections and
-subsections; it should be used only for those documents that are meant
-to be read like a novel rather than a reference, and for which the
-Info `g*' command is inadequate."
- t nil)
-
-(autoload 'texinfo-make-menu
- "texnfo-upd"
- "Without any prefix argument, make or update a menu.
-Make the menu for the section enclosing the node found following point.
-
-Non-nil argument (prefix, if interactive) means make or update menus
-for nodes within or part of the marked region.
-
-Whenever a menu exists, and is being updated, the descriptions that
-are associated with node names in the pre-existing menu are
-incorporated into the new menu. Otherwise, the nodes' section titles
-are inserted as descriptions."
- t nil)
-
-(autoload 'texinfo-all-menus-update
- "texnfo-upd"
- "Update every regular menu in a Texinfo file.
-Remove pre-existing master menu, if there is one.
-
-If called with a non-nil argument, this function first updates all the
-nodes in the buffer before updating the menus."
- t nil)
-
-(autoload 'texinfo-master-menu
- "texnfo-upd"
- "Make a master menu for a whole Texinfo file.
-Non-nil argument (prefix, if interactive) means first update all
-existing nodes and menus. Remove pre-existing master menu, if there is one.
-
-This function creates a master menu that follows the top node. The
-master menu includes every entry from all the other menus. It
-replaces any existing ordinary menu that follows the top node.
-
-If called with a non-nil argument, this function first updates all the
-menus in the buffer (incorporating descriptions from pre-existing
-menus) before it constructs the master menu.
-
-The function removes the detailed part of an already existing master
-menu. This action depends on the pre-existing master menu using the
-standard `texinfo-master-menu-header'.
-
-The master menu has the following format, which is adapted from the
-recommendation in the Texinfo Manual:
-
- * The first part contains the major nodes in the Texinfo file: the
- nodes for the chapters, chapter-like sections, and the major
- appendices. This includes the indices, so long as they are in
- chapter-like sections, such as unnumbered sections.
-
- * The second and subsequent parts contain a listing of the other,
- lower level menus, in order. This way, an inquirer can go
- directly to a particular node if he or she is searching for
- specific information.
-
-Each of the menus in the detailed node listing is introduced by the
-title of the section containing the menu."
- t nil)
-
-(autoload 'texinfo-indent-menu-description
- "texnfo-upd"
- "Indent every description in menu following point to COLUMN.
-Non-nil argument (prefix, if interactive) means indent every
-description in every menu in the region. Does not indent second and
-subsequent lines of a multi-line description."
- t nil)
-
-(autoload 'texinfo-insert-node-lines
- "texnfo-upd"
- "Insert missing `@node' lines in region of Texinfo file.
-Non-nil argument (prefix, if interactive) means also to insert the
-section titles as node names; and also to insert the section titles as
-node names in pre-existing @node lines that lack names."
- t nil)
-
-(autoload 'texinfo-start-menu-description
- "texnfo-upd"
- "In this menu entry, insert the node's section title as a description.
-Position point at beginning of description ready for editing.
-Do not insert a title if the line contains an existing description.
-
-You will need to edit the inserted text since a useful description
-complements the node name rather than repeats it as a title does."
- t nil)
-
-(autoload 'texinfo-multiple-files-update
- "texnfo-upd"
- "Update first node pointers in each file included in OUTER-FILE;
-create or update main menu in the outer file that refers to such nodes.
-This does not create or update menus or pointers within the included files.
-
-With optional MAKE-MASTER-MENU argument (prefix arg, if interactive),
-insert a master menu in OUTER-FILE. This does not create or update
-menus or pointers within the included files.
-
-With optional UPDATE-EVERYTHING argument (numeric prefix arg, if
-interactive), update all the menus and all the `Next', `Previous', and
-`Up' pointers of all the files included in OUTER-FILE before inserting
-a master menu in OUTER-FILE.
-
-The command also updates the `Top' level node pointers of OUTER-FILE.
-
-Notes:
-
- * this command does NOT save any files--you must save the
- outer file and any modified, included files.
-
- * except for the `Top' node, this command does NOT handle any
- pre-existing nodes in the outer file; hence, indices must be
- enclosed in an included file.
-
-Requirements:
-
- * each of the included files must contain exactly one highest
- hierarchical level node,
- * this highest node must be the first node in the included file,
- * each highest hierarchical level node must be of the same type.
-
-Thus, normally, each included file contains one, and only one,
-chapter."
- t nil)
+(require 'texinfo-loaddefs)
;;; Code:
@@ -349,8 +156,7 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
(defface texinfo-heading
'((t (:inherit font-lock-function-name-face)))
- "Face used for section headings in `texinfo-mode'."
- :group 'texinfo)
+ "Face used for section headings in `texinfo-mode'.")
(defvar texinfo-font-lock-keywords
`(;; All but the first had an OVERRIDE of t.
@@ -377,7 +183,7 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
("@\\(end\\|itemx?\\) +\\(.+\\)" 2 font-lock-keyword-face keep)
;; (,texinfo-environment-regexp
;; 1 (texinfo-clone-environment (match-beginning 1) (match-end 1)) keep)
- (,(concat "^@" (regexp-opt (mapcar 'car texinfo-section-list) t)
+ (,(concat "^@" (regexp-opt (mapcar #'car texinfo-section-list) t)
".*\n")
0 'texinfo-heading t))
"Additional expressions to highlight in Texinfo mode.")
@@ -404,19 +210,21 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
;;; Keys common both to Texinfo mode and to TeX shell.
+(declare-function tex-show-print-queue "tex-mode" ())
+
(defun texinfo-define-common-keys (keymap)
"Define the keys both in Texinfo mode and in the texinfo-tex-shell."
- (define-key keymap "\C-c\C-t\C-k" 'tex-kill-job)
- (define-key keymap "\C-c\C-t\C-x" 'texinfo-quit-job)
- (define-key keymap "\C-c\C-t\C-l" 'tex-recenter-output-buffer)
- (define-key keymap "\C-c\C-t\C-d" 'texinfo-delete-from-print-queue)
- (define-key keymap "\C-c\C-t\C-q" 'tex-show-print-queue)
- (define-key keymap "\C-c\C-t\C-p" 'texinfo-tex-print)
- (define-key keymap "\C-c\C-t\C-v" 'texinfo-tex-view)
- (define-key keymap "\C-c\C-t\C-i" 'texinfo-texindex)
-
- (define-key keymap "\C-c\C-t\C-r" 'texinfo-tex-region)
- (define-key keymap "\C-c\C-t\C-b" 'texinfo-tex-buffer))
+ (define-key keymap "\C-c\C-t\C-k" #'tex-kill-job)
+ (define-key keymap "\C-c\C-t\C-x" #'texinfo-quit-job)
+ (define-key keymap "\C-c\C-t\C-l" #'tex-recenter-output-buffer)
+ (define-key keymap "\C-c\C-t\C-d" #'texinfo-delete-from-print-queue)
+ (define-key keymap "\C-c\C-t\C-q" #'tex-show-print-queue)
+ (define-key keymap "\C-c\C-t\C-p" #'texinfo-tex-print)
+ (define-key keymap "\C-c\C-t\C-v" #'texinfo-tex-view)
+ (define-key keymap "\C-c\C-t\C-i" #'texinfo-texindex)
+
+ (define-key keymap "\C-c\C-t\C-r" #'texinfo-tex-region)
+ (define-key keymap "\C-c\C-t\C-b" #'texinfo-tex-buffer))
;; Mode documentation displays commands in reverse order
;; from how they are listed in the texinfo-mode-map.
@@ -427,61 +235,68 @@ Subexpression 1 is what goes into the corresponding `@end' statement.")
;; bindings for `texnfo-tex.el'
(texinfo-define-common-keys map)
- (define-key map "\"" 'texinfo-insert-quote)
+ (define-key map "\"" #'texinfo-insert-quote)
;; bindings for `makeinfo.el'
- (define-key map "\C-c\C-m\C-k" 'kill-compilation)
+ (define-key map "\C-c\C-m\C-k" #'kill-compilation)
(define-key map "\C-c\C-m\C-l"
- 'makeinfo-recenter-compilation-buffer)
- (define-key map "\C-c\C-m\C-r" 'makeinfo-region)
- (define-key map "\C-c\C-m\C-b" 'makeinfo-buffer)
+ #'makeinfo-recenter-compilation-buffer)
+ (define-key map "\C-c\C-m\C-r" #'makeinfo-region)
+ (define-key map "\C-c\C-m\C-b" #'makeinfo-buffer)
;; bindings for `texinfmt.el'
- (define-key map "\C-c\C-e\C-r" 'texinfo-format-region)
- (define-key map "\C-c\C-e\C-b" 'texinfo-format-buffer)
+ (define-key map "\C-c\C-e\C-r" #'texinfo-format-region)
+ (define-key map "\C-c\C-e\C-b" #'texinfo-format-buffer)
;; AUCTeX-like bindings
- (define-key map "\e\r" 'texinfo-insert-@item)
+ (define-key map "\e\r" #'texinfo-insert-@item)
;; bindings for updating nodes and menus
- (define-key map "\C-c\C-um" 'texinfo-master-menu)
+ (define-key map "\C-c\C-um" #'texinfo-master-menu)
- (define-key map "\C-c\C-u\C-m" 'texinfo-make-menu)
- (define-key map "\C-c\C-u\C-n" 'texinfo-update-node)
- (define-key map "\C-c\C-u\C-e" 'texinfo-every-node-update)
- (define-key map "\C-c\C-u\C-a" 'texinfo-all-menus-update)
+ (define-key map "\C-c\C-u\C-m" #'texinfo-make-menu)
+ (define-key map "\C-c\C-u\C-n" #'texinfo-update-node)
+ (define-key map "\C-c\C-u\C-e" #'texinfo-every-node-update)
+ (define-key map "\C-c\C-u\C-a" #'texinfo-all-menus-update)
- (define-key map "\C-c\C-s" 'texinfo-show-structure)
+ (define-key map "\C-c\C-s" #'texinfo-show-structure)
- (define-key map "\C-c}" 'up-list)
+ (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)
+ (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
- (define-key map "\C-c\C-o" 'texinfo-insert-block)
- (define-key map "\C-c\C-c\C-d" 'texinfo-start-menu-description)
- (define-key map "\C-c\C-c\C-s" 'texinfo-insert-@strong)
- (define-key map "\C-c\C-c\C-e" 'texinfo-insert-@emph)
-
- (define-key map "\C-c\C-cv" 'texinfo-insert-@var)
- (define-key map "\C-c\C-cu" 'texinfo-insert-@uref)
- (define-key map "\C-c\C-ct" 'texinfo-insert-@table)
- (define-key map "\C-c\C-cs" 'texinfo-insert-@samp)
- (define-key map "\C-c\C-cr" 'texinfo-insert-dwim-@ref)
- (define-key map "\C-c\C-cq" 'texinfo-insert-@quotation)
- (define-key map "\C-c\C-co" 'texinfo-insert-@noindent)
- (define-key map "\C-c\C-cn" 'texinfo-insert-@node)
- (define-key map "\C-c\C-cm" 'texinfo-insert-@email)
- (define-key map "\C-c\C-ck" 'texinfo-insert-@kbd)
- (define-key map "\C-c\C-ci" 'texinfo-insert-@item)
- (define-key map "\C-c\C-cf" 'texinfo-insert-@file)
- (define-key map "\C-c\C-cx" 'texinfo-insert-@example)
- (define-key map "\C-c\C-ce" 'texinfo-insert-@end)
- (define-key map "\C-c\C-cd" 'texinfo-insert-@dfn)
- (define-key map "\C-c\C-cc" 'texinfo-insert-@code)
+ (define-key map "\C-c\C-o" #'texinfo-insert-block)
+ (define-key map "\C-c\C-c\C-d" #'texinfo-start-menu-description)
+ (define-key map "\C-c\C-c\C-s" #'texinfo-insert-@strong)
+ (define-key map "\C-c\C-c\C-e" #'texinfo-insert-@emph)
+
+ (define-key map "\C-c\C-cv" #'texinfo-insert-@var)
+ (define-key map "\C-c\C-cu" #'texinfo-insert-@uref)
+ (define-key map "\C-c\C-ct" #'texinfo-insert-@table)
+ (define-key map "\C-c\C-cs" #'texinfo-insert-@samp)
+ (define-key map "\C-c\C-cr" #'texinfo-insert-dwim-@ref)
+ (define-key map "\C-c\C-cq" #'texinfo-insert-@quotation)
+ (define-key map "\C-c\C-co" #'texinfo-insert-@noindent)
+ (define-key map "\C-c\C-cn" #'texinfo-insert-@node)
+ (define-key map "\C-c\C-cm" #'texinfo-insert-@email)
+ (define-key map "\C-c\C-ck" #'texinfo-insert-@kbd)
+ (define-key map "\C-c\C-ci" #'texinfo-insert-@item)
+ (define-key map "\C-c\C-cf" #'texinfo-insert-@file)
+ (define-key map "\C-c\C-cx" #'texinfo-insert-@example)
+ (define-key map "\C-c\C-ce" #'texinfo-insert-@end)
+ (define-key map "\C-c\C-cd" #'texinfo-insert-@dfn)
+ (define-key map "\C-c\C-cc" #'texinfo-insert-@code)
+
+ ;; bindings for environment movement
+ (define-key map "\C-c." #'texinfo-to-environment-bounds)
+ (define-key map "\C-c\C-c\C-f" #'texinfo-next-environment-end)
+ (define-key map "\C-c\C-c\C-b" #'texinfo-previous-environment-end)
+ (define-key map "\C-c\C-c\C-n" #'texinfo-next-environment-start)
+ (define-key map "\C-c\C-c\C-p" #'texinfo-previous-environment-start)
map))
(easy-menu-define texinfo-mode-menu
@@ -621,7 +436,7 @@ value of `texinfo-mode-hook'."
(mapcar (lambda (x) (cons (concat "@" (car x)) (cadr x)))
texinfo-section-list))
(setq-local outline-regexp
- (concat (regexp-opt (mapcar 'car outline-heading-alist) t)
+ (concat (regexp-opt (mapcar #'car outline-heading-alist) t)
"\\>"))
(setq-local tex-start-of-header "%\\*\\*start")
@@ -890,7 +705,7 @@ A numeric argument says how many words the braces should surround.
The default is not to surround any existing words with the braces."
nil
"@uref{" _ "}")
-(defalias 'texinfo-insert-@url 'texinfo-insert-@uref)
+(defalias 'texinfo-insert-@url #'texinfo-insert-@uref)
;;; Texinfo file structure
@@ -955,26 +770,27 @@ to jump to the corresponding spot in the Texinfo source file."
(defcustom texinfo-texi2dvi-command "texi2dvi"
"Command used by `texinfo-tex-buffer' to run TeX and texindex on a buffer."
+ :type 'string)
+
+(defcustom texinfo-texi2dvi-options ""
+ "Command line options for `texinfo-texi2dvi-command'."
:type 'string
- :group 'texinfo)
+ :version "28.1")
(defcustom texinfo-tex-command "tex"
"Command used by `texinfo-tex-region' to run TeX on a region."
- :type 'string
- :group 'texinfo)
+ :type 'string)
(defcustom texinfo-texindex-command "texindex"
"Command used by `texinfo-texindex' to sort unsorted index files."
- :type 'string
- :group 'texinfo)
+ :type 'string)
(defcustom texinfo-delete-from-print-queue-command "lprm"
"Command string used to delete a job from the line printer queue.
Command is used by \\[texinfo-delete-from-print-queue] based on
number provided by a previous \\[tex-show-print-queue]
command."
- :type 'string
- :group 'texinfo)
+ :type 'string)
(defvar texinfo-tex-trailer "@bye"
"String appended after a region sent to TeX by `texinfo-tex-region'.")
@@ -1002,9 +818,10 @@ The value of `texinfo-tex-trailer' is appended to the temporary file after the r
(interactive)
(require 'tex-mode)
(let ((tex-command texinfo-texi2dvi-command)
- ;; Disable tex-start-options-string. texi2dvi would not
- ;; understand anything specified here.
- (tex-start-options-string ""))
+ (tex-start-options texinfo-texi2dvi-options)
+ ;; Disable tex-start-commands. texi2dvi would not understand
+ ;; anything specified here.
+ (tex-start-commands ""))
(tex-buffer)))
(defun texinfo-texindex ()
@@ -1065,6 +882,70 @@ You are prompted for the job number (use a number shown by a previous
;; job-number"\n"))
(tex-recenter-output-buffer nil))
+(defun texinfo-to-environment-bounds ()
+ "Move point alternately to the start and end of a Texinfo environment.
+Do nothing when outside of an environment. This command does not
+handle nested environments."
+ (interactive)
+ (cond ((save-excursion
+ (forward-line 0)
+ (looking-at texinfo-environment-regexp))
+ (if (save-excursion
+ (forward-line 0)
+ (looking-at "^@end"))
+ (texinfo-previous-environment-start)
+ (texinfo-next-environment-end)))
+ ((save-excursion
+ (and (re-search-backward texinfo-environment-regexp nil t)
+ (not (looking-at "^@end"))))
+ (texinfo-previous-environment-start))
+ ;; Otherwise, point is outside of an environment, so do nothing.
+ ))
+
+(defun texinfo-next-environment-start ()
+ "Move forward to the beginning of a Texinfo environment."
+ (interactive)
+ (if (looking-at texinfo-environment-regexp)
+ (forward-line 1))
+ (while (and (re-search-forward texinfo-environment-regexp nil t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (looking-at "@end"))))
+ (if (save-excursion
+ (forward-line 0)
+ (looking-at texinfo-environment-regexp))
+ (forward-line 0)))
+
+(defun texinfo-previous-environment-start ()
+ "Move back to the beginning of the previous Texinfo environment."
+ (interactive)
+ (while (and (re-search-backward texinfo-environment-regexp nil t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (looking-at "@end")))))
+
+(defun texinfo-next-environment-end ()
+ "Move forward to the beginning of the next @end line of an environment."
+ (interactive)
+ (if (looking-at "^@end")
+ (forward-line 1))
+ (while (and (re-search-forward texinfo-environment-regexp nil t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (not (looking-at "^@end")))))
+ (if (save-excursion
+ (forward-line 0)
+ (looking-at "^@end"))
+ (forward-line 0)))
+
+(defun texinfo-previous-environment-end ()
+ "Move backward to the beginning of the next @end line of an environment."
+ (interactive)
+ (while (and (re-search-backward texinfo-environment-regexp nil t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (not (looking-at "@end"))))))
+
(provide 'texinfo)
;;; texinfo.el ends here
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
index ea35641a6c6..f56f197c502 100644
--- a/lisp/textmodes/texnfo-upd.el
+++ b/lisp/textmodes/texnfo-upd.el
@@ -1,4 +1,4 @@
-;;; texnfo-upd.el --- utilities for updating nodes and menus in Texinfo files
+;;; texnfo-upd.el --- utilities for updating nodes and menus in Texinfo files -*- lexical-binding: t; -*-
;; Copyright (C) 1989-1992, 2001-2021 Free Software Foundation, Inc.
@@ -275,6 +275,7 @@ The keys are strings specifying the general hierarchical level in the
document; the values are regular expressions.")
+;;;###autoload
(defun texinfo-make-menu (&optional beginning end)
"Without any prefix argument, make or update a menu.
Make the menu for the section enclosing the node found following point.
@@ -351,6 +352,7 @@ at the level specified by LEVEL. Point is left at the end of menu."
(texinfo-delete-old-menu beginning first))
(texinfo-insert-menu new-menu-list node-name)))
+;;;###autoload
(defun texinfo-all-menus-update (&optional update-all-nodes-p)
"Update every regular menu in a Texinfo file.
Update pre-existing master menu, if there is one.
@@ -420,7 +422,7 @@ of the node if one is found; else do not move point."
"\\|" ; or
"\\(^@ifnottex[ ]*\n\\)" ; ifnottex line, if any
"\\)?" ; end of expression
- (eval (cdr (assoc level texinfo-update-menu-lower-regexps))))
+ (eval (cdr (assoc level texinfo-update-menu-lower-regexps)) t))
;; the next higher level node marks the end of this
;; section, and no lower level node will be found beyond
;; this position even if region-end is farther off
@@ -454,7 +456,7 @@ if the match is found there, the value is t and point does not move."
"\\|" ; or
"\\(^@ifnottex[ ]*\n\\)" ; ifnottex line, if any
"\\)?" ; end of expression
- (eval (cdr (assoc level texinfo-update-menu-higher-regexps))))
+ (eval (cdr (assoc level texinfo-update-menu-higher-regexps)) t))
region-end t)
(beginning-of-line) t)))))
@@ -505,7 +507,7 @@ The function finds entries of the same type. Thus `subsections' and
"\\(^@ifnottex[ ]*\n\\)" ; ifnottex line, if any
"\\)?" ; end of expression
(eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps))))
+ (cdr (assoc level texinfo-update-menu-same-level-regexps)) t))
search-end
t)
(goto-char (match-beginning 1)))))
@@ -733,6 +735,7 @@ is the menu entry name, and the cdr of P is the node name."
;;; Starting menu descriptions by inserting titles
+;;;###autoload
(defun texinfo-start-menu-description ()
"In this menu entry, insert the node's section title as a description.
Position point at beginning of description ready for editing.
@@ -742,7 +745,7 @@ You will need to edit the inserted text since a useful description
complements the node name rather than repeats it as a title does."
(interactive)
- (let (beginning end node-name title)
+ (let (beginning node-name title) ;; end
(save-excursion
(beginning-of-line)
(if (search-forward "* " (line-end-position) t)
@@ -817,6 +820,7 @@ complements the node name rather than repeats it as a title does."
;; Since the make-menu functions indent descriptions, these functions
;; are useful primarily for indenting a single menu specially.
+;;;###autoload
(defun texinfo-indent-menu-description (column &optional region-p)
"Indent every description in menu following point to COLUMN.
Non-nil argument (prefix, if interactive) means indent every
@@ -872,6 +876,7 @@ second and subsequent lines of a multi-line description."
;;; Making the master menu
+;;;###autoload
(defun texinfo-master-menu (update-all-nodes-menus-p)
"Make a master menu for a whole Texinfo file.
Remove pre-existing master menu, if there is one.
@@ -1033,7 +1038,7 @@ However, there does not need to be a title field."
(save-excursion
;; `master-menu-inserted-p' is a kludge to tell
- ;; whether to insert @end detailmenu (see bleow)
+ ;; whether to insert @end detailmenu (see below)
(let (master-menu-inserted-p)
;; Handle top of menu
(insert "\n@menu\n")
@@ -1219,7 +1224,7 @@ Only argument is a string of the general type of section."
"\\(^@ifnottex[ ]*\n\\)" ; ifnottex line, if any
"\\)?" ; end of expression
(eval
- (cdr (assoc level texinfo-update-menu-higher-regexps))))
+ (cdr (assoc level texinfo-update-menu-higher-regexps)) t))
nil
'goto-beginning)
(point))))))
@@ -1243,7 +1248,7 @@ string of the general type of section."
"\\)?" ; end of expression
(eval
;; Never finds end of level above chapter so goes to end.
- (cdr (assoc level texinfo-update-menu-higher-regexps))))
+ (cdr (assoc level texinfo-update-menu-higher-regexps)) t))
nil
'goto-end)
(match-beginning 1)
@@ -1266,6 +1271,7 @@ end of that region; it limits the search."
;;; Updating a node
+;;;###autoload
(defun texinfo-update-node (&optional beginning end)
"Without any prefix argument, update the node in which point is located.
Interactively, a prefix argument means to operate on the region.
@@ -1313,6 +1319,7 @@ which menu descriptions are indented. Its default value is 32."
(goto-char (point-max))
(message "Done...nodes updated in region. You may save the buffer."))))))
+;;;###autoload
(defun texinfo-every-node-update ()
"Update every node in a Texinfo file.
@@ -1430,7 +1437,7 @@ will be at some level higher in the Texinfo file. The fourth argument
"\\(^@ifnottex[ ]*\n\\)"
"\\)?")
(eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps))))
+ (cdr (assoc level texinfo-update-menu-same-level-regexps)) t))
end
t)
'normal
@@ -1451,7 +1458,7 @@ will be at some level higher in the Texinfo file. The fourth argument
"\\(^@ifnottex[ ]*\n\\)"
"\\)?")
(eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps)))
+ (cdr (assoc level texinfo-update-menu-same-level-regexps)) t)
"\\|"
;; Match node line.
"\\(^@node\\).*\n"
@@ -1465,7 +1472,7 @@ will be at some level higher in the Texinfo file. The fourth argument
"\\(^@ifnottex[ ]*\n\\)"
"\\)?")
(eval
- (cdr (assoc level texinfo-update-menu-higher-regexps)))
+ (cdr (assoc level texinfo-update-menu-higher-regexps)) t)
"\\|"
;; Handle `Top' node specially.
"^@node [ \t]*top[ \t]*\\(,\\|$\\)"
@@ -1489,7 +1496,7 @@ will be at some level higher in the Texinfo file. The fourth argument
"\\|"
"\\(^@ifnottex[ ]*\n\\)"
"\\)?")
- (eval (cdr (assoc level texinfo-update-menu-higher-regexps)))
+ (eval (cdr (assoc level texinfo-update-menu-higher-regexps)) t)
"\\|"
;; Handle `Top' node specially.
"^@node [ \t]*top[ \t]*\\(,\\|$\\)"
@@ -1553,6 +1560,7 @@ towards which the pointer is directed, one of `next', `previous', or `up'."
;; (The subsection to which `Next' points will most likely be the first
;; item on the section's menu.)
+;;;###autoload
(defun texinfo-sequential-node-update (&optional region-p)
"Update one node (or many) in a Texinfo file with sequential pointers.
@@ -1662,7 +1670,7 @@ or `Up' pointer."
'no-pointer))
((eq direction 'up)
(if (re-search-backward
- (eval (cdr (assoc level texinfo-update-menu-higher-regexps)))
+ (eval (cdr (assoc level texinfo-update-menu-higher-regexps)) t)
(point-min)
t)
'normal
@@ -1676,6 +1684,7 @@ or `Up' pointer."
;; before the `@chapter', `@section', and such like lines of a region
;; in a Texinfo file.
+;;;###autoload
(defun texinfo-insert-node-lines (beginning end &optional title-p)
"Insert missing `@node' lines in region of Texinfo file.
Non-nil argument (prefix, if interactive) means also to insert the
@@ -1686,7 +1695,7 @@ node names in pre-existing `@node' lines that lack names."
;; Use marker; after inserting node lines, leave point at end of
;; region and mark at beginning.
- (let (beginning-marker end-marker title last-section-position)
+ (let (end-marker title last-section-position) ;; beginning-marker
;; Save current position on mark ring and set mark to end.
(push-mark end t)
@@ -1989,6 +1998,7 @@ be the files included within it. A main menu must already exist."
;;; The multiple-file update function
+;;;###autoload
(defun texinfo-multiple-files-update
(outer-file &optional make-master-menu update-everything)
"Update first node pointers in each file included in OUTER-FILE;
@@ -2043,8 +2053,8 @@ chapter."
(let* ((included-file-list (texinfo-multi-file-included-list outer-file))
(files included-file-list)
- next-node-name
- previous-node-name
+ ;; next-node-name
+ ;; previous-node-name
;; Update the pointers and collect the names of the nodes and titles
(main-menu-list (texinfo-multi-file-update files update-everything)))
@@ -2112,8 +2122,10 @@ chapter."
(message "Multiple files updated."))
-
-;; Place `provide' at end of file.
(provide 'texnfo-upd)
+;; Local Variables:
+;; generated-autoload-file: "texinfo-loaddefs.el"
+;; End:
+
;;; texnfo-upd.el ends here
diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el
index 1432ab6a300..74c6d412a65 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -49,7 +49,7 @@
(modify-syntax-entry ?' "w p" st)
;; UAX #29 says HEBREW PUNCTUATION GERESH behaves like a letter
;; for the purposes of finding word boundaries.
- (modify-syntax-entry #x5f3 "w ") ; GERESH
+ (modify-syntax-entry #x5f3 "w " st) ; GERESH
;; UAX #29 says HEBREW PUNCTUATION GERSHAYIM should not be a word
;; boundary when surrounded by letters. Our infrastructure for
;; finding a word boundary doesn't support 3-character
@@ -57,45 +57,44 @@
;; character. This leaves a problem of having GERSHAYIM at the
;; beginning or end of a word, where it should be a boundary;
;; FIXME.
- (modify-syntax-entry #x5f4 "w ") ; GERSHAYIM
+ (modify-syntax-entry #x5f4 "w " st) ; GERSHAYIM
;; These all should not be a word boundary when between letters,
;; according to UAX #29, so they again are prone to the same
;; problem as GERSHAYIM; FIXME.
- (modify-syntax-entry #xb7 "w ") ; MIDDLE DOT
- (modify-syntax-entry #x2027 "w ") ; HYPHENATION POINT
- (modify-syntax-entry #xff1a "w ") ; FULLWIDTH COLON
+ (modify-syntax-entry #xb7 "w " st) ; MIDDLE DOT
+ (modify-syntax-entry #x2027 "w " st) ; HYPHENATION POINT
+ (modify-syntax-entry #xff1a "w " st) ; FULLWIDTH COLON
st)
"Syntax table used while in `text-mode'.")
(defvar text-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\e\t" 'ispell-complete-word)
- (define-key map [menu-bar text]
- (cons "Text" (make-sparse-keymap "Text")))
- (bindings--define-key map [menu-bar text toggle-text-mode-auto-fill]
- '(menu-item "Auto Fill" toggle-text-mode-auto-fill
- :button (:toggle . (memq 'turn-on-auto-fill text-mode-hook))
- :help "Automatically fill text while typing in text modes (Auto Fill mode)"))
- (bindings--define-key map [menu-bar text paragraph-indent-minor-mode]
- '(menu-item "Paragraph Indent" paragraph-indent-minor-mode
- :button (:toggle . (bound-and-true-p paragraph-indent-minor-mode))
- :help "Toggle paragraph indent minor mode"))
- (bindings--define-key map [menu-bar text sep] menu-bar-separator)
- (bindings--define-key map [menu-bar text center-region]
- '(menu-item "Center Region" center-region
- :help "Center the marked region"
- :enable (region-active-p)))
- (bindings--define-key map [menu-bar text center-paragraph]
- '(menu-item "Center Paragraph" center-paragraph
- :help "Center the current paragraph"))
- (bindings--define-key map [menu-bar text center-line]
- '(menu-item "Center Line" center-line
- :help "Center the current line"))
+ (define-key map "\e\t" #'ispell-complete-word)
map)
"Keymap for `text-mode'.
Many other modes, such as `mail-mode', `outline-mode' and `indented-text-mode',
inherit all the commands defined in this map.")
+(easy-menu-define text-mode-menu text-mode-map
+ "Menu for `text-mode'."
+ '("Text"
+ ["Center Line" center-line
+ :help "Center the current line"]
+ ["Center Paragraph" center-paragraph
+ :help "Center the current paragraph"]
+ ["Center Region" center-region
+ :help "Center the marked region"
+ :enable (region-active-p)]
+ "---"
+ ["Paragraph Indent" paragraph-indent-minor-mode
+ :help "Toggle paragraph indent minor mode"
+ :style toggle
+ :selected (bound-and-true-p paragraph-indent-minor-mode)]
+ ["Auto Fill" toggle-text-mode-auto-fill
+ :help "Automatically fill text while typing in text modes (Auto Fill mode)"
+ :style toggle
+ :selected (memq 'turn-on-auto-fill text-mode-hook)]))
+
(define-derived-mode text-mode nil "Text"
"Major mode for editing text written for humans to read.
@@ -142,7 +141,7 @@ Turning on Paragraph-Indent minor mode runs the normal hook
(remove-function (local 'indent-line-function)
#'indent-to-left-margin)))
-(defalias 'indented-text-mode 'text-mode)
+(defalias 'indented-text-mode #'text-mode)
;; This can be made a no-op once all modes that use text-mode-hook
;; are "derived" from text-mode. (As of 2015/04, and probably well before,
@@ -169,8 +168,6 @@ both existing buffers and buffers that you subsequently create."
(if enable-mode "enabled" "disabled"))))
-(define-key facemenu-keymap "\eS" 'center-paragraph)
-
(defun center-paragraph ()
"Center each nonblank line in the paragraph at or after point.
See `center-line' for more info."
@@ -198,8 +195,6 @@ See `center-line' for more info."
(center-line))
(forward-line 1)))))
-(define-key facemenu-keymap "\es" 'center-line)
-
(defun center-line (&optional nlines)
"Center the line point is on, within the width specified by `fill-column'.
This means adjusting the indentation so that it equals
diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el
index 82775a580b8..01e2ad72d88 100644
--- a/lisp/textmodes/tildify.el
+++ b/lisp/textmodes/tildify.el
@@ -66,8 +66,7 @@ non-capturing groups can be used for grouping prior to the part of the regexp
matching the white space). The pattern is matched case-sensitive regardless of
the value of `case-fold-search' setting."
:version "25.1"
- :group 'tildify
- :type 'string
+ :type 'regexp
:safe t)
(defcustom tildify-pattern-alist ()
@@ -90,7 +89,6 @@ by the hard space character.
The form (MAJOR-MODE . SYMBOL) defines alias item for MAJOR-MODE. For this
mode, the item for the mode SYMBOL is looked up in the alist instead."
- :group 'tildify
:type '(repeat (cons :tag "Entry for major mode"
(choice (const :tag "Default" t)
(symbol :tag "Major mode"))
@@ -110,7 +108,6 @@ might be used for other modes if compatible encoding is used.
If nil, current major mode has no way to represent a hard space."
:version "25.1"
- :group 'tildify
:type '(choice (const :tag "Space character (no hard-space representation)"
" ")
(const :tag "No-break space (U+00A0)" "\u00A0")
@@ -133,7 +130,6 @@ STRING defines the hard space, which is inserted at places defined by
The form (MAJOR-MODE . SYMBOL) defines alias item for MAJOR-MODE. For this
mode, the item for the mode SYMBOL is looked up in the alist instead."
- :group 'tildify
:type '(repeat (cons :tag "Entry for major mode"
(choice (const :tag "Default" t)
(symbol :tag "Major mode"))
@@ -164,7 +160,6 @@ or better still:
See `tildify-foreach-ignore-environments' function for other ways to use the
variable."
:version "25.1"
- :group 'tildify
:type 'function)
(defcustom tildify-ignored-environments-alist ()
@@ -183,7 +178,6 @@ MAJOR-MODE defines major mode, for which the item applies. It can be either:
See `tildify-foreach-ignore-environments' function for description of BEG-REGEX
and END-REGEX."
- :group 'tildify
:type '(repeat
(cons :tag "Entry for major mode"
(choice (const :tag "Default" t)
@@ -295,7 +289,7 @@ variable. For example, for an XML file one might use:
(setq-local tildify-foreach-region-function
(apply-partially \\='tildify-foreach-ignore-environments
\\='((\"<! *--\" . \"-- *>\") (\"<\" . \">\"))))"
- (let ((beg-re (concat "\\(?:" (mapconcat 'car pairs "\\)\\|\\(?:") "\\)"))
+ (let ((beg-re (concat "\\(?:" (mapconcat #'car pairs "\\)\\|\\(?:") "\\)"))
p end-re)
(save-excursion
(save-restriction
@@ -416,19 +410,16 @@ If the pattern matches `looking-back', a hard space needs to be inserted instead
of a space at point. The regexp is always case sensitive, regardless of the
current `case-fold-search' setting."
:version "25.1"
- :group 'tildify
- :type 'string)
+ :type 'regexp)
(defcustom tildify-space-predicates '(tildify-space-region-predicate)
"A list of predicate functions for `tildify-space' function."
:version "25.1"
- :group 'tildify
:type '(repeat function))
(defcustom tildify-double-space-undos t
"Weather `tildify-space' should undo hard space when space is typed again."
:version "25.1"
- :group 'tildify
:type 'boolean)
;;;###autoload
@@ -495,7 +486,7 @@ that space character is replaced by a hard space specified by
When `tildify-mode' is enabled, if `tildify-string-alist' specifies a hard space
representation for current major mode, the `tildify-space-string' buffer-local
variable will be set to the representation."
- nil " ~" nil
+ :lighter " ~"
(when tildify-mode
(let ((space (with-suppressed-warnings ((obsolete
tildify--pick-alist-entry))
@@ -508,12 +499,10 @@ variable will be set to the representation."
"mode won't have any effect, disabling.")))
(setq tildify-mode nil))))
(if tildify-mode
- (add-hook 'post-self-insert-hook 'tildify-space nil t)
- (remove-hook 'post-self-insert-hook 'tildify-space t)))
+ (add-hook 'post-self-insert-hook #'tildify-space nil t)
+ (remove-hook 'post-self-insert-hook #'tildify-space t)))
-;;; *** Announce ***
-
(provide 'tildify)
;;; tildify.el ends here
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
index af81d7a9857..5a3a64ad79f 100644
--- a/lisp/textmodes/two-column.el
+++ b/lisp/textmodes/two-column.el
@@ -1,4 +1,4 @@
-;;; two-column.el --- minor mode for editing of two-column text
+;;; two-column.el --- minor mode for editing of two-column text -*- lexical-binding: t; -*-
;; Copyright (C) 1992-1995, 2001-2021 Free Software Foundation, Inc.
@@ -133,26 +133,22 @@
'("-%*- %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."
- :type 'sexp
- :group 'two-column)
+ :type 'sexp)
(defcustom 2C-other-buffer-hook 'text-mode
"Hook run in new buffer when it is associated with current one."
- :type 'function
- :group 'two-column)
+ :type 'function)
(defcustom 2C-separator ""
"A string inserted between the two columns when merging.
This gets set locally by \\[2C-split]."
- :type 'string
- :group 'two-column)
+ :type 'string)
(put '2C-separator 'permanent-local t)
(defcustom 2C-window-width 40
"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)
+ :type 'integer)
(make-variable-buffer-local '2C-window-width)
(put '2C-window-width 'permanent-local t)
@@ -160,21 +156,19 @@ This value is local for every buffer that sets it."
"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
- :group 'two-column)
+ :type 'integer)
(defcustom 2C-autoscroll t
"If non-nil, Emacs attempts to keep the two column's buffers aligned."
- :type 'boolean
- :group 'two-column)
+ :type 'boolean)
(defvar 2C-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "2" '2C-two-columns)
- (define-key map [f2] '2C-two-columns)
- (define-key map "b" '2C-associate-buffer)
- (define-key map "s" '2C-split)
+ (define-key map "2" #'2C-two-columns)
+ (define-key map [f2] #'2C-two-columns)
+ (define-key map "b" #'2C-associate-buffer)
+ (define-key map "s" #'2C-split)
map)
"Keymap for commands for setting up two-column mode.")
@@ -184,19 +178,19 @@ minus this value."
;; This one is for historical reasons and simple keyboards, it is not
;; at all mnemonic. All usual sequences containing 2 were used, and
;; f2 could not be set up in a standard way under Emacs 18.
-;;;###autoload (global-set-key "\C-x6" '2C-command)
+;;;###autoload (global-set-key "\C-x6" #'2C-command)
-;;;###autoload (global-set-key [f2] '2C-command)
+;;;###autoload (global-set-key [f2] #'2C-command)
(defvar 2C-minor-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "1" '2C-merge)
- (define-key map "d" '2C-dissociate)
- (define-key map "o" '2C-associated-buffer)
- (define-key map "\^m" '2C-newline)
- (define-key map "|" '2C-toggle-autoscroll)
- (define-key map "{" '2C-shrink-window-horizontally)
- (define-key map "}" '2C-enlarge-window-horizontally)
+ (define-key map "1" #'2C-merge)
+ (define-key map "d" #'2C-dissociate)
+ (define-key map "o" #'2C-associated-buffer)
+ (define-key map "\^m" #'2C-newline)
+ (define-key map "|" #'2C-toggle-autoscroll)
+ (define-key map "{" #'2C-shrink-window-horizontally)
+ (define-key map "}" #'2C-enlarge-window-horizontally)
map)
"Keymap for commands for use in two-column mode.")
@@ -218,15 +212,13 @@ minus this value."
;; Markers seem to be the only buffer-id not affected by renaming a buffer.
;; This nevertheless loses when a buffer is killed. The variable-name is
;; required by `describe-mode'.
-(defvar 2C-mode nil
+(defvar-local 2C-mode nil
"Marker to the associated buffer, if non-nil.")
-(make-variable-buffer-local '2C-mode)
(put '2C-mode 'permanent-local t)
(setq minor-mode-alist (cons '(2C-mode " 2C") minor-mode-alist))
-(defvar 2C-autoscroll-start nil)
-(make-variable-buffer-local '2C-autoscroll-start)
+(defvar-local 2C-autoscroll-start nil)
;;;;; base functions ;;;;;
@@ -283,7 +275,7 @@ some prefix.
The appearance of the screen can be customized by the variables
`2C-window-width', `2C-beyond-fill-column', `2C-mode-line-format' and
`truncate-partial-width-windows'."
- (add-hook 'post-command-hook '2C-autoscroll nil t)
+ (add-hook 'post-command-hook #'2C-autoscroll nil t)
(setq fill-column (- 2C-window-width
2C-beyond-fill-column)
mode-line-format 2C-mode-line-format
@@ -327,16 +319,17 @@ first and the associated buffer to its right."
;;;###autoload
-(defun 2C-associate-buffer ()
- "Associate another buffer with this one in two-column minor mode.
+(defun 2C-associate-buffer (buffer)
+ "Associate another BUFFER with this one in two-column minor mode.
Can also be used to associate a just previously visited file, by
accepting the proposed default buffer.
\(See \\[describe-mode] .)"
- (interactive)
+ (interactive
+ (list (or (2C-other)
+ (read-buffer "Associate buffer: " (other-buffer)))))
(let ((b1 (current-buffer))
- (b2 (or (2C-other)
- (read-buffer "Associate buffer: " (other-buffer)))))
+ (b2 buffer))
(setq 2C-mode nil)
(with-current-buffer b2
(and (2C-other)
@@ -388,9 +381,8 @@ First column's text sSs Second column's text
(backward-char arg)
(setq chars (buffer-substring (point) point))
(skip-chars-forward " \t" point)
- (make-local-variable '2C-separator)
- (setq 2C-separator (buffer-substring (point) point)
- 2C-window-width (+ (fringe-columns 'left)
+ (setq-local 2C-separator (buffer-substring (point) point))
+ (setq 2C-window-width (+ (fringe-columns 'left)
(fringe-columns 'right)
(scroll-bar-columns 'left)
(scroll-bar-columns 'right)
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index cd2809fa4c4..4c2470fbcb6 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -52,8 +52,30 @@
;;; Code:
+(require 'cl-lib)
(provide 'thingatpt)
+(defvar thing-at-point-provider-alist nil
+ "Alist of providers for returning a \"thing\" at point.
+This variable can be set globally, or appended to buffer-locally
+by modes, to provide functions that will return a \"thing\" at
+point. The first provider for the \"thing\" that returns a
+non-nil value wins.
+
+For instance, a major mode could say:
+
+\(setq-local thing-at-point-provider-alist
+ (append thing-at-point-provider-alist
+ \\='((url . my-mode--url-at-point))))
+
+to provide a way to get an `url' at point in that mode. The
+provider functions are called with no parameters at the point in
+question.
+
+\"things\" include `symbol', `list', `sexp', `defun', `filename',
+`url', `email', `uuid', `word', `sentence', `whitespace', `line',
+and `page'.")
+
;; Basic movement
;;;###autoload
@@ -143,11 +165,18 @@ strip text properties from the return value.
See the file `thingatpt.el' for documentation on how to define
a symbol as a valid THING."
(let ((text
- (if (get thing 'thing-at-point)
- (funcall (get thing 'thing-at-point))
+ (cond
+ ((cl-loop for (pthing . function) in thing-at-point-provider-alist
+ when (eq pthing thing)
+ for result = (funcall function)
+ when result
+ return result))
+ ((get thing 'thing-at-point)
+ (funcall (get thing 'thing-at-point)))
+ (t
(let ((bounds (bounds-of-thing-at-point thing)))
(when bounds
- (buffer-substring (car bounds) (cdr bounds)))))))
+ (buffer-substring (car bounds) (cdr bounds))))))))
(when (and text no-properties (sequencep text))
(set-text-properties 0 (length text) nil text))
text))
@@ -218,6 +247,15 @@ The bounds of THING are determined by `bounds-of-thing-at-point'."
(put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp)
+;; Symbols
+
+(put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol)
+
+(defun thing-at-point--beginning-of-symbol ()
+ "Move point to the beginning of the current symbol."
+ (and (re-search-backward "\\(\\sw\\|\\s_\\)+")
+ (skip-syntax-backward "w_")))
+
;; Lists
(put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point)
@@ -258,7 +296,7 @@ E.g.:
;; Filenames
-(defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:"
+(defvar thing-at-point-file-name-chars "-@~/[:alnum:]_.${}#%,:"
"Characters allowable in filenames.")
(define-thing-chars filename thing-at-point-file-name-chars)
@@ -278,7 +316,7 @@ If nil, construct the regexp from `thing-at-point-uri-schemes'.")
"Regexp matching a URI without a scheme component.")
(defvar thing-at-point-uri-schemes
- ;; Officials from http://www.iana.org/assignments/uri-schemes.html
+ ;; Officials from https://www.iana.org/assignments/uri-schemes.html
'("aaa://" "about:" "acap://" "apt:" "bzr://" "bzr+ssh://"
"attachment:/" "chrome://" "cid:" "content://" "crid://" "cvs://"
"data:" "dav:" "dict://" "doi:" "dns:" "dtn:" "feed:" "file:/"
@@ -334,7 +372,7 @@ the bounds of a possible ill-formed URI (one lacking a scheme)."
;; may contain parentheses but may not contain spaces (RFC3986).
(let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'")
(skip-before "^[0-9a-zA-Z]")
- (skip-after ":;.,!?")
+ (skip-after ":;.,!?'")
(pt (point))
(beg (save-excursion
(skip-chars-backward allowed-chars)
@@ -562,10 +600,14 @@ with angle brackets.")
(buffer-substring-no-properties
(car boundary-pair) (cdr boundary-pair))))))
-;; Buffer
+;; Buffer and region
(put 'buffer 'end-op (lambda () (goto-char (point-max))))
(put 'buffer 'beginning-op (lambda () (goto-char (point-min))))
+(put 'region 'bounds-of-thing-at-point
+ (lambda ()
+ (when (use-region-p)
+ (cons (region-beginning) (region-end)))))
;; UUID
@@ -635,14 +677,14 @@ Signal an error if the entire string was not used."
"Return the number at point, or nil if none is found.
Decimal numbers like \"14\" or \"-14.5\", as well as hex numbers
like \"0xBEEF09\" or \"#xBEEF09\", are recognized."
- (when (thing-at-point-looking-at
- "\\(-?[0-9]+\\.?[0-9]*\\)\\|\\(0x\\|#x\\)\\([a-zA-Z0-9]+\\)" 500)
- (if (match-beginning 1)
- (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1)))
- (string-to-number
- (buffer-substring (match-beginning 3) (match-end 3))
- 16))))
+ (cond
+ ((thing-at-point-looking-at "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" 500)
+ (string-to-number
+ (buffer-substring (match-beginning 2) (match-end 2))
+ 16))
+ ((thing-at-point-looking-at "-?[0-9]+\\.?[0-9]*" 500)
+ (string-to-number
+ (buffer-substring (match-beginning 0) (match-end 0))))))
(put 'number 'thing-at-point 'number-at-point)
;;;###autoload
diff --git a/lisp/thread.el b/lisp/thread.el
index e1e658315f5..efb058c4361 100644
--- a/lisp/thread.el
+++ b/lisp/thread.el
@@ -43,8 +43,6 @@ An EVENT has the format
(err (cddr event)))
(message "Error %s: %S" thread err))))
-(make-obsolete 'thread-alive-p 'thread-live-p "27.1")
-
;;; The thread list buffer and list-threads command
(defcustom thread-list-refresh-seconds 0.5
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index a2f7b033f0a..5710b8c353b 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -1,4 +1,4 @@
-;;; thumbs.el --- Thumbnails previewer for images files
+;;; thumbs.el --- Thumbnails previewer for images files -*- lexical-binding: t -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -23,18 +23,18 @@
;;; Commentary:
-;; This package create two new modes: thumbs-mode and thumbs-view-image-mode.
+;; This package create two new modes: `thumbs-mode' and `thumbs-view-image-mode'.
;; It is used for basic browsing and viewing of images from within Emacs.
;; Minimal image manipulation functions are also available via external
;; programs. If you want to do more complex tasks like categorize and tag
;; your images, use image-dired.el
;;
;; The 'convert' program from 'ImageMagick'
-;; [URL:http://www.imagemagick.org/] is required.
+;; [URL:https://www.imagemagick.org/] is required.
;;
;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some
;; time. The peoples at #emacs@freenode.net for numerous help. RMS
-;; for emacs and the GNU project.
+;; for Emacs and the GNU project.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@@ -51,9 +51,6 @@
;; In thumbs-mode, pressing <return> on an image will bring you in image view
;; mode for that image. C-h m will give you a list of available keybinding.
-;;; History:
-;;
-
;;; Code:
(require 'dired)
@@ -68,29 +65,24 @@
(defcustom thumbs-thumbsdir (locate-user-emacs-file "thumbs")
"Directory to store thumbnails."
- :type 'directory
- :group 'thumbs)
+ :type 'directory)
(defcustom thumbs-geometry "100x100"
"Size of thumbnails."
- :type 'string
- :group 'thumbs)
+ :type 'string)
(defcustom thumbs-per-line 4
"Number of thumbnails per line to show in directory."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
(defcustom thumbs-max-image-number 16
"Maximum number of images initially displayed in thumbs buffer."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
(defcustom thumbs-thumbsdir-max-size 50000000
"Maximum size for thumbnails directory.
When it reaches that size (in bytes), a warning is sent."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
;; Unfortunately Windows XP has a program called CONVERT.EXE in
;; C:/WINDOWS/SYSTEM32/ for partitioning NTFS systems. So Emacs
@@ -98,86 +90,74 @@ When it reaches that size (in bytes), a warning is sent."
;; customize this value to the absolute filename.
(defcustom thumbs-conversion-program
(if (eq system-type 'windows-nt)
+ ;; FIXME is this necessary, or can a sane PATHEXE be assumed?
+ ;; Eg find-program does not do this.
"convert.exe"
- (or (executable-find "convert")
- "/usr/X11R6/bin/convert"))
+ "convert")
"Name of conversion program for thumbnails generation.
-It must be \"convert\"."
+This must be the ImageMagick \"convert\" utility."
:type 'string
- :group 'thumbs)
+ :version "28.1")
(defcustom thumbs-setroot-command
"xloadimage -onroot -fullscreen *"
"Command to set the root window."
- :type 'string
- :group 'thumbs)
+ :type 'string)
(defcustom thumbs-relief 5
"Size of button-like border around thumbnails."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
(defcustom thumbs-margin 2
"Size of the margin around thumbnails.
This is where you see the cursor."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
(defcustom thumbs-thumbsdir-auto-clean t
"If set, delete older file in the thumbnails directory.
Deletion is done at load time when the directory size is bigger
than `thumbs-thumbsdir-max-size'."
- :type 'boolean
- :group 'thumbs)
+ :type 'boolean)
(defcustom thumbs-image-resizing-step 10
"Step by which to resize image as a percentage."
- :type 'integer
- :group 'thumbs)
+ :type 'integer)
(defcustom thumbs-temp-dir temporary-file-directory
"Temporary directory to use.
Defaults to `temporary-file-directory'. Leaving it to
this value can let another user see some of your images."
- :type 'directory
- :group 'thumbs)
+ :type 'directory)
(defcustom thumbs-temp-prefix "emacsthumbs"
"Prefix to add to temp files."
- :type 'string
- :group 'thumbs)
+ :type 'string)
;; Initialize some variable, for later use.
-(defvar thumbs-current-tmp-filename nil
+(defvar-local thumbs-current-tmp-filename nil
"Temporary filename of current image.")
-(make-variable-buffer-local 'thumbs-current-tmp-filename)
-(defvar thumbs-current-image-filename nil
+(defvar-local thumbs-current-image-filename nil
"Filename of current image.")
-(make-variable-buffer-local 'thumbs-current-image-filename)
-(defvar thumbs-extra-images 1
+(defvar-local thumbs-extra-images 1
"Counter for showing extra images in thumbs buffer.")
-(make-variable-buffer-local 'thumbs-extra-images)
(put 'thumbs-extra-images 'permanent-local t)
(defvar thumbs-current-image-size nil
"Size of current image.")
-(defvar thumbs-image-num nil
+(defvar-local thumbs-image-num nil
"Number of current image.")
-(make-variable-buffer-local 'thumbs-image-num)
-(defvar thumbs-buffer nil
+(defvar-local thumbs-buffer nil
"Name of buffer containing thumbnails associated with image.")
-(make-variable-buffer-local 'thumbs-buffer)
(defvar thumbs-current-dir nil
"Current directory.")
-(defvar thumbs-marked-list nil
+(defvar-local thumbs-marked-list nil
"List of marked files.")
-(make-variable-buffer-local 'thumbs-marked-list)
(put 'thumbs-marked-list 'permanent-local t)
(defsubst thumbs-temp-dir ()
@@ -205,23 +185,24 @@ Create the thumbnails directory if it does not exist."
If the total size of all files in `thumbs-thumbsdir' is bigger than
`thumbs-thumbsdir-max-size', files are deleted until the max size is
reached."
- (let* ((files-list
- (sort
- (mapcar
- (lambda (f)
- (let ((fattribs-list (file-attributes f)))
- `(,(file-attribute-access-time fattribs-list)
- ,(file-attribute-size fattribs-list)
- ,f)))
- (directory-files (thumbs-thumbsdir) t (image-file-name-regexp)))
- (lambda (l1 l2) (time-less-p (car l1) (car l2)))))
- (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files-list))))
- (while (> dirsize thumbs-thumbsdir-max-size)
- (progn
- (message "Deleting file %s" (cadr (cdar files-list))))
- (delete-file (cadr (cdar files-list)))
- (setq dirsize (- dirsize (car (cdar files-list))))
- (setq files-list (cdr files-list)))))
+ (when (file-directory-p thumbs-thumbsdir)
+ (let* ((files-list
+ (sort
+ (mapcar
+ (lambda (f)
+ (let ((fattribs-list (file-attributes f)))
+ `(,(file-attribute-access-time fattribs-list)
+ ,(file-attribute-size fattribs-list)
+ ,f)))
+ (directory-files (thumbs-thumbsdir) t (image-file-name-regexp)))
+ (lambda (l1 l2) (time-less-p (car l1) (car l2)))))
+ (dirsize (apply #'+ (mapcar (lambda (x) (cadr x)) files-list))))
+ (while (> dirsize thumbs-thumbsdir-max-size)
+ (progn
+ (message "Deleting file %s" (cadr (cdar files-list))))
+ (delete-file (cadr (cdar files-list)))
+ (setq dirsize (- dirsize (car (cdar files-list))))
+ (setq files-list (cdr files-list))))))
;; Check the thumbnail directory size and clean it if necessary.
(when thumbs-thumbsdir-auto-clean
@@ -295,7 +276,7 @@ smaller according to whether INCREMENT is 1 or -1."
(subst-char-in-string
?\s ?\_
(apply
- 'concat
+ #'concat
(split-string filename "/")))))))
(defun thumbs-make-thumb (img)
@@ -347,8 +328,7 @@ If MARKED is non-nil, the image is marked."
:conversion ,(if marked 'disabled)
:margin ,thumbs-margin)))
(insert-image i)
- (set (make-local-variable 'thumbs-current-image-size)
- (image-size i t))))
+ (setq-local thumbs-current-image-size (image-size i t))))
(defun thumbs-insert-thumb (img &optional marked)
"Insert the thumbnail for IMG at point.
@@ -387,14 +367,14 @@ If MARKED is non-nil, the image is marked."
(if dir (setq default-directory dir))
(thumbs-do-thumbs-insertion list)
(goto-char (point-min))
- (set (make-local-variable 'thumbs-current-dir) default-directory)))
+ (setq-local thumbs-current-dir default-directory)))
;;;###autoload
(defun thumbs-show-from-dir (dir &optional reg same-window)
"Make a preview buffer for all images in DIR.
Optional argument REG to select file matching a regexp,
and SAME-WINDOW to show thumbs in the same window."
- (interactive "DDir: ")
+ (interactive "DThumbs (directory): ")
(thumbs-show-thumbs-list
(directory-files dir t (or reg (image-file-name-regexp)))
dir same-window))
@@ -624,7 +604,7 @@ Open another window."
(when (eolp) (forward-char)))
;; cleaning of old temp files
-(mapc 'delete-file
+(mapc #'delete-file
(directory-files (thumbs-temp-dir) t thumbs-temp-prefix))
;; Image modification routines
diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el
index 2bfabd95ed1..ae911717151 100644
--- a/lisp/time-stamp.el
+++ b/lisp/time-stamp.el
@@ -1,4 +1,4 @@
-;;; time-stamp.el --- Maintain last change time stamps in files edited by Emacs
+;;; time-stamp.el --- Maintain last change time stamps in files edited by Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1993-1995, 1997, 2000-2021 Free Software
;; Foundation, Inc.
@@ -25,7 +25,7 @@
;; A template in a file can be updated with a new time stamp when
;; you save the file. For example:
-;; static char *ts = "sdmain.c Time-stamp: <2001-08-13 10:20:51 gildea>";
+;; static char *ts = "sdmain.c Time-stamp: <2020-04-18 14:10:21 gildea>";
;; To use time-stamping, add this line to your init file:
;; (add-hook 'before-save-hook 'time-stamp)
@@ -87,7 +87,6 @@ transitional behavior (again, as shown).
The behavior of `%5z' is new in Emacs 27. If your files might be
edited by older versions of Emacs also, do not use this format yet."
:type 'string
- :group 'time-stamp
:version "27.1")
;;;###autoload(put 'time-stamp-format 'safe-local-variable 'stringp)
@@ -102,8 +101,7 @@ when they are saved, either add this line to your init file:
or customize option `before-save-hook'.
See also the variable `time-stamp-warn-inactive'."
- :type 'boolean
- :group 'time-stamp)
+ :type 'boolean)
(defcustom time-stamp-warn-inactive t
"Have \\[time-stamp] warn if a buffer did not get time-stamped.
@@ -111,7 +109,6 @@ If non-nil, a warning is displayed if `time-stamp-active' has
deactivated time stamping and the buffer contains a template that
otherwise would have been updated."
:type 'boolean
- :group 'time-stamp
:version "19.29")
(defcustom time-stamp-time-zone nil
@@ -125,7 +122,6 @@ Its format is that of the ZONE argument of the `format-time-string' function."
(integer :tag "Offset (seconds east of UTC)")
(string :tag "Time zone abbreviation"))
(integer :tag "Offset (seconds east of UTC)"))
- :group 'time-stamp
:version "20.1")
;;;###autoload(put 'time-stamp-time-zone 'safe-local-variable 'time-stamp-zone-type-p)
@@ -282,7 +278,7 @@ look like one of the following:
Time-stamp: <>
Time-stamp: \" \"
The time stamp is written between the brackets or quotes:
- Time-stamp: <2001-02-18 10:20:51 gildea>
+ Time-stamp: <2020-08-07 17:10:21 gildea>
The time stamp is updated only if the variable
`time-stamp-active' is non-nil.
@@ -426,7 +422,7 @@ Returns the end point, which is where `time-stamp' begins the next search."
;;;###autoload
(defun time-stamp-toggle-active (&optional arg)
"Toggle `time-stamp-active', setting whether \\[time-stamp] updates a buffer.
-With ARG, turn time stamping on if and only if arg is positive."
+With ARG, turn time stamping on if and only if ARG is positive."
(interactive "P")
(setq time-stamp-active
(if (null arg)
@@ -461,200 +457,225 @@ normally the current time is used."
(defun time-stamp-string-preprocess (format &optional time)
"Use a FORMAT to format date, time, file, and user information.
Optional second argument TIME is only for testing.
-Implements non-time extensions to `format-time-string'
+Implements extensions to `format-time-string'
and all `time-stamp-format' compatibility."
(let ((fmt-len (length format))
(ind 0)
cur-char
- (prev-char nil)
- (result "")
- field-width
- field-result
- alt-form change-case upcase
- (paren-level 0))
+ (result ""))
(while (< ind fmt-len)
(setq cur-char (aref format ind))
(setq
result
- (concat result
- (cond
- ((eq cur-char ?%)
- ;; eat any additional args to allow for future expansion
- (setq alt-form 0 change-case nil upcase nil field-width "")
- (while (progn
- (setq ind (1+ ind))
- (setq cur-char (if (< ind fmt-len)
- (aref format ind)
- ?\0))
- (or (eq ?. cur-char)
- (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char)
- (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char)
- (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char)
- (and (eq ?\( cur-char)
- (not (eq prev-char ?\\))
- (setq paren-level (1+ paren-level)))
- (if (and (eq ?\) cur-char)
+ (concat
+ result
+ (cond
+ ((eq cur-char ?%)
+ (let ((prev-char nil)
+ (field-width "")
+ field-result
+ (alt-form 0)
+ (change-case nil)
+ (upcase nil)
+ (flag-pad-with-spaces nil)
+ (flag-pad-with-zeros nil)
+ (flag-minimize nil)
+ (paren-level 0))
+ ;; eat any additional args to allow for future expansion
+ (while (progn
+ (setq ind (1+ ind))
+ (setq cur-char (if (< ind fmt-len)
+ (aref format ind)
+ ?\0))
+ (or (eq ?. cur-char)
+ (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char)
+ (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char)
+ (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char)
+ (and (eq ?\( cur-char)
(not (eq prev-char ?\\))
- (> paren-level 0))
- (setq paren-level (1- paren-level))
- (and (> paren-level 0)
- (< ind fmt-len)))
- (if (and (<= ?0 cur-char) (>= ?9 cur-char))
- ;; get format width
- (let ((field-index ind))
- (while (progn
- (setq ind (1+ ind))
- (setq cur-char (if (< ind fmt-len)
- (aref format ind)
- ?\0))
- (and (<= ?0 cur-char) (>= ?9 cur-char))))
- (setq field-width (substring format field-index ind))
- (setq ind (1- ind))
- t))))
- (setq prev-char cur-char)
- ;; some characters we actually use
- (cond ((eq cur-char ?:)
- (setq alt-form (1+ alt-form)))
- ((eq cur-char ?#)
- (setq change-case t))
- ((eq cur-char ?^)
- (setq upcase t))
- ((eq cur-char ?-)
- (setq field-width "1"))
- ((eq cur-char ?_)
- (setq field-width "2"))))
- (setq field-result
- (cond
- ((eq cur-char ?%)
- "%")
- ((eq cur-char ?a) ;day of week
- (if (> alt-form 0)
- (if (string-equal field-width "")
- (time-stamp--format "%A" time)
- "") ;discourage "%:3a"
- (if (or change-case upcase)
- (time-stamp--format "%#a" time)
- (time-stamp--format "%a" time))))
- ((eq cur-char ?A)
- (if (or change-case upcase (not (string-equal field-width "")))
- (time-stamp--format "%#A" time)
- (time-stamp--format "%A" time)))
- ((eq cur-char ?b) ;month name
- (if (> alt-form 0)
- (if (string-equal field-width "")
- (time-stamp--format "%B" time)
- "") ;discourage "%:3b"
- (if (or change-case upcase)
- (time-stamp--format "%#b" time)
- (time-stamp--format "%b" time))))
- ((eq cur-char ?B)
- (if (or change-case upcase (not (string-equal field-width "")))
- (time-stamp--format "%#B" time)
- (time-stamp--format "%B" time)))
- ((eq cur-char ?d) ;day of month, 1-31
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?H) ;hour, 0-23
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?I) ;hour, 1-12
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?m) ;month number, 1-12
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?M) ;minute, 0-59
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?p) ;am or pm
- (if change-case
- (time-stamp--format "%#p" time)
- (time-stamp--format "%p" time)))
- ((eq cur-char ?P) ;AM or PM
- (time-stamp--format "%p" time))
- ((eq cur-char ?S) ;seconds, 00-60
- (time-stamp-do-number cur-char alt-form field-width time))
- ((eq cur-char ?w) ;weekday number, Sunday is 0
- (time-stamp--format "%w" time))
- ((eq cur-char ?y) ;year
- (if (> alt-form 0)
- (string-to-number (time-stamp--format "%Y" time))
- (if (or (string-equal field-width "")
- (<= (string-to-number field-width) 2))
- (string-to-number (time-stamp--format "%y" time))
- (time-stamp-conv-warn (format "%%%sy" field-width) "%Y")
- (string-to-number (time-stamp--format "%Y" time)))))
- ((eq cur-char ?Y) ;4-digit year
- (string-to-number (time-stamp--format "%Y" time)))
- ((eq cur-char ?z) ;time zone offset
- (if change-case
- "" ;discourage %z variations
- (cond ((= alt-form 0)
- (if (string-equal field-width "")
- (progn
- (time-stamp-conv-warn "%z" "%#Z")
- (time-stamp--format "%#Z" time))
- (cond ((string-equal field-width "1")
- (setq field-width "3")) ;%-z -> "+00"
- ((string-equal field-width "2")
- (setq field-width "5")) ;%_z -> "+0000"
- ((string-equal field-width "4")
- (setq field-width "0"))) ;discourage %4z
- (time-stamp--format "%z" time)))
- ((= alt-form 1)
- (time-stamp--format "%:z" time))
- ((= alt-form 2)
- (time-stamp--format "%::z" time))
- ((= alt-form 3)
- (time-stamp--format "%:::z" time)))))
- ((eq cur-char ?Z) ;time zone name
- (if change-case
- (time-stamp--format "%#Z" time)
- (time-stamp--format "%Z" time)))
- ((eq cur-char ?f) ;buffer-file-name, base name only
- (if buffer-file-name
- (file-name-nondirectory buffer-file-name)
- time-stamp-no-file))
- ((eq cur-char ?F) ;buffer-file-name, full path
- (or buffer-file-name
- time-stamp-no-file))
- ((eq cur-char ?s) ;system name, legacy
- (system-name))
- ((eq cur-char ?u) ;user name, legacy
- (user-login-name))
- ((eq cur-char ?U) ;user full name, legacy
- (user-full-name))
- ((eq cur-char ?l) ;login name
- (user-login-name))
- ((eq cur-char ?L) ;full name of logged-in user
- (user-full-name))
- ((eq cur-char ?h) ;mail host name
- (or mail-host-address (system-name)))
- ((eq cur-char ?q) ;unqualified host name
- (let ((qualname (system-name)))
- (if (string-match "\\." qualname)
- (substring qualname 0 (match-beginning 0))
- qualname)))
- ((eq cur-char ?Q) ;fully-qualified host name
- (system-name))
- ))
- (and (numberp field-result)
- (= alt-form 0)
- (string-equal field-width "")
- ;; no width provided; set width for default
- (setq field-width "02"))
- (let ((padded-result
- (format (format "%%%s%c"
- field-width
- (if (numberp field-result) ?d ?s))
- (or field-result ""))))
- (let* ((initial-length (length padded-result))
- (desired-length (if (string-equal field-width "")
- initial-length
- (string-to-number field-width))))
- (if (> initial-length desired-length)
- ;; truncate strings on right
- (if (stringp field-result)
- (substring padded-result 0 desired-length)
- padded-result) ;numbers don't truncate
- padded-result))))
- (t
- (char-to-string cur-char)))))
+ (setq paren-level (1+ paren-level)))
+ (if (and (eq ?\) cur-char)
+ (not (eq prev-char ?\\))
+ (> paren-level 0))
+ (setq paren-level (1- paren-level))
+ (and (> paren-level 0)
+ (< ind fmt-len)))
+ (if (and (<= ?0 cur-char) (>= ?9 cur-char))
+ ;; get format width
+ (let ((field-index ind)
+ (first-digit cur-char))
+ (while (progn
+ (setq ind (1+ ind))
+ (setq cur-char (if (< ind fmt-len)
+ (aref format ind)
+ ?\0))
+ (and (<= ?0 cur-char)
+ (>= ?9 cur-char))))
+ (setq field-width
+ (substring format field-index ind))
+ (setq ind (1- ind))
+ (setq cur-char first-digit)
+ t))))
+ (setq prev-char cur-char)
+ ;; some characters we actually use
+ (cond ((eq cur-char ?:)
+ (setq alt-form (1+ alt-form)))
+ ((eq cur-char ?#)
+ (setq change-case t))
+ ((eq cur-char ?^)
+ (setq upcase t))
+ ((eq cur-char ?0)
+ (setq flag-pad-with-zeros t))
+ ((eq cur-char ?-)
+ (setq field-width "1" flag-minimize t))
+ ((eq cur-char ?_)
+ (setq field-width "2" flag-pad-with-spaces t))))
+ (setq field-result
+ (cond
+ ((eq cur-char ?%)
+ "%")
+ ((eq cur-char ?a) ;day of week
+ (if (> alt-form 0)
+ (if (string-equal field-width "")
+ (time-stamp--format "%A" time)
+ "") ;discourage "%:3a"
+ (if (or change-case upcase)
+ (time-stamp--format "%#a" time)
+ (time-stamp--format "%a" time))))
+ ((eq cur-char ?A)
+ (if (or change-case upcase (not (string-equal field-width
+ "")))
+ (time-stamp--format "%#A" time)
+ (time-stamp--format "%A" time)))
+ ((eq cur-char ?b) ;month name
+ (if (> alt-form 0)
+ (if (string-equal field-width "")
+ (time-stamp--format "%B" time)
+ "") ;discourage "%:3b"
+ (if (or change-case upcase)
+ (time-stamp--format "%#b" time)
+ (time-stamp--format "%b" time))))
+ ((eq cur-char ?B)
+ (if (or change-case upcase (not (string-equal field-width
+ "")))
+ (time-stamp--format "%#B" time)
+ (time-stamp--format "%B" time)))
+ ((eq cur-char ?d) ;day of month, 1-31
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?H) ;hour, 0-23
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?I) ;hour, 1-12
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?m) ;month number, 1-12
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?M) ;minute, 0-59
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?p) ;am or pm
+ (if change-case
+ (time-stamp--format "%#p" time)
+ (time-stamp--format "%p" time)))
+ ((eq cur-char ?P) ;AM or PM
+ (time-stamp--format "%p" time))
+ ((eq cur-char ?S) ;seconds, 00-60
+ (time-stamp-do-number cur-char alt-form field-width time))
+ ((eq cur-char ?w) ;weekday number, Sunday is 0
+ (time-stamp--format "%w" time))
+ ((eq cur-char ?y) ;year
+ (if (> alt-form 0)
+ (string-to-number (time-stamp--format "%Y" time))
+ (if (or (string-equal field-width "")
+ (<= (string-to-number field-width) 2))
+ (string-to-number (time-stamp--format "%y" time))
+ (time-stamp-conv-warn (format "%%%sy" field-width) "%Y")
+ (string-to-number (time-stamp--format "%Y" time)))))
+ ((eq cur-char ?Y) ;4-digit year
+ (string-to-number (time-stamp--format "%Y" time)))
+ ((eq cur-char ?z) ;time zone offset
+ (let ((field-width-num (string-to-number field-width))
+ ;; Handle numeric time zone ourselves, because
+ ;; current-time-zone cannot handle offsets
+ ;; greater than 24 hours.
+ (offset-secs
+ (cond ((numberp time-stamp-time-zone)
+ time-stamp-time-zone)
+ ((and (consp time-stamp-time-zone)
+ (numberp (car time-stamp-time-zone)))
+ (car time-stamp-time-zone))
+ ;; interpret text time zone
+ (t (car (current-time-zone
+ time time-stamp-time-zone))))))
+ ;; we do our own padding; do not let it be updated further
+ (setq field-width "")
+ (cond (change-case
+ "") ;discourage %z variations
+ ((and (= alt-form 0)
+ (not flag-minimize)
+ (not flag-pad-with-spaces)
+ (not flag-pad-with-zeros)
+ (= field-width-num 0))
+ (time-stamp-conv-warn "%z" "%#Z")
+ (time-stamp--format "%#Z" time))
+ (t (time-stamp-formatz-from-parsed-options
+ flag-minimize
+ flag-pad-with-spaces
+ flag-pad-with-zeros
+ alt-form
+ field-width-num
+ offset-secs)))))
+ ((eq cur-char ?Z) ;time zone name
+ (if change-case
+ (time-stamp--format "%#Z" time)
+ (time-stamp--format "%Z" time)))
+ ((eq cur-char ?f) ;buffer-file-name, base name only
+ (if buffer-file-name
+ (file-name-nondirectory buffer-file-name)
+ time-stamp-no-file))
+ ((eq cur-char ?F) ;buffer-file-name, full path
+ (or buffer-file-name
+ time-stamp-no-file))
+ ((eq cur-char ?s) ;system name, legacy
+ (system-name))
+ ((eq cur-char ?u) ;user name, legacy
+ (user-login-name))
+ ((eq cur-char ?U) ;user full name, legacy
+ (user-full-name))
+ ((eq cur-char ?l) ;login name
+ (user-login-name))
+ ((eq cur-char ?L) ;full name of logged-in user
+ (user-full-name))
+ ((eq cur-char ?h) ;mail host name
+ (or mail-host-address (system-name)))
+ ((eq cur-char ?q) ;unqualified host name
+ (let ((qualname (system-name)))
+ (if (string-match "\\." qualname)
+ (substring qualname 0 (match-beginning 0))
+ qualname)))
+ ((eq cur-char ?Q) ;fully-qualified host name
+ (system-name))
+ ))
+ (and (numberp field-result)
+ (= alt-form 0)
+ (string-equal field-width "")
+ ;; no width provided; set width for default
+ (setq field-width "02"))
+ (let ((padded-result
+ (format (format "%%%s%c"
+ field-width
+ (if (numberp field-result) ?d ?s))
+ (or field-result ""))))
+ (let* ((initial-length (length padded-result))
+ (desired-length (if (string-equal field-width "")
+ initial-length
+ (string-to-number field-width))))
+ (if (> initial-length desired-length)
+ ;; truncate strings on right
+ (if (and (stringp field-result)
+ (not (eq cur-char ?z))) ;offset does not truncate
+ (substring padded-result 0 desired-length)
+ padded-result) ;numbers don't truncate
+ padded-result)))))
+ (t
+ (char-to-string cur-char)))))
(setq ind (1+ ind)))
result))
@@ -694,6 +715,176 @@ Suggests replacing OLD-FORM with NEW-FORM."
(insert "\"" old-form "\" -- use " new-form "\n"))
(display-buffer "*Time-stamp-compatibility*"))))
+;;; A principled, expressive implementation of time zone offset
+;;; formatting ("%z" and variants).
+
+;;; * Overarching principle for %z
+
+;; The output should be clear and complete.
+;;
+;; That is,
+;; a) it should be unambiguous what offset is represented, and
+;; b) it should be possible to exactly recreate the offset.
+
+;;; * Principles for %z
+
+;; - The numeric fields are HHMMSS.
+;; - The fixed point is at the left. The first 2 digits are always
+;; hours, the next 2 (if they exist) minutes, and next 2 (if they
+;; exist) seconds. "+11" is 11 hours (not 11 minutes, not 11 seconds).
+;; "+1015" is 10 hours 15 minutes (not 10 minutes 15 seconds).
+;; - Each of the three numeric fields is two digits.
+;; "+1" and "+100" are illegal. (Is that 1 hour? 10 hours? 100 hours?)
+;; - The MMSS fields may be omitted only if both are 00. Thus, the width
+;; of the field depends on the data. (This is similar to how
+;; %B is always long enough to spell the entire month name.)
+;; - The SS field may be omitted only if it is 00.
+;; - Colons between the numeric fields are an option, unless the hours
+;; field is greater than 99, when colons are needed to prevent ambiguity.
+;; - If padding with zeros, we must pad on the right, because the
+;; fixed point is at the left. (This is similar to how %N,
+;; fractional seconds, must add its zeros on the right.)
+;; - After zero-padding has filled out minutes and seconds with zeros,
+;; further padding can be blanks only.
+;; Any additional zeros would be confusing.
+
+;;; * Padding for %z
+
+;; Padding is under-specified, so we had to make choices.
+;;
+;; Principles guiding our choices:
+;;
+;; - The syntax should be easy to remember and the effect predictable.
+;; - It should be possible to produces as many useful effects as possible.
+;;
+;; Padding choices:
+;;
+;; - By default, pad with spaces, as other formats with non-digits do.
+;; The "0" flag pads first with zeros, until seconds are filled out.
+;; - If padding with spaces, pad on the right. This is consistent with
+;; how zero-padding works. Padding on the right also keeps the fixed
+;; point in the same place, as other formats do for any given width.
+;; - The %_z format always outputs seconds, allowing all added padding
+;; to be spaces. Without this rule, there would be no way to
+;; request seconds that worked for both 2- and 3-digit hours.
+;; - Conflicting options are rejected, lest users depend
+;; on incidental behavior.
+;;
+;; Padding combos that make no sense and are thus disallowed:
+;;
+;; %-:z - minus minimizes to hours, : expands to minutes
+;; %-::z - minus minimizes to hours, :: expands to seconds
+;; %_:z - underscore requires seconds, : displays minutes
+;; %_:::z - underscore requires seconds, ::: minimizes to hours
+;;
+;; Example padding effects (with offsets of 99 and 100 hours):
+;;
+;; %-7z "+99 " "+100:00"
+;; %7z "+9900 " "+100:00"
+;; %07z "+990000" "+100:00"
+;; %_7z "+990000" "+100:00:00"
+;;
+;; %7:::z "+99 " "+100:00"
+;; %7:z "+99:00 " "+100:00"
+;; %07:z "+99:00:00" "+100:00"
+;; %7::z "+99:00:00" "+100:00:00"
+
+;;; * BNF syntax of the offset string produced by %z
+
+;; <offset> ::= <sign><hours>[<minutes>[<seconds>]]<padding> |
+;; <sign><hours>[<colonminutes>[<colonseconds>]]<padding> |
+;; <sign><bighours><colonminutes>[<colonseconds>]<padding>
+;; <sign> ::= "+"|"-"
+;; <hours> ::= <2digits>
+;; <minutes> ::= <2digits>
+;; <seconds> ::= <2digits>
+;; <colonminutes> ::= ":"<minutes>
+;; <colonseconds> ::= ":"<seconds>
+;; <2digits> ::= <digit><digit>
+;; <digit> ::= "0"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"
+;; <bighours> ::= <digit>*<digit><2digits>
+;; <padding> ::= " "*
+
+(defun time-stamp-formatz-from-parsed-options (flag-minimize
+ flag-pad-spaces-only
+ flag-pad-zeros-first
+ colon-count
+ field-width
+ offset-secs)
+ "Formats a time offset according to a %z variation.
+The caller of this function must have already parsed the %z format
+string; this function accepts just the parts of the format.
+
+With no flags, the output includes hours and minutes: +-HHMM
+unless there is a non-zero seconds part, in which case the seconds
+are included: +-HHMMSS
+
+FLAG-MINIMIZE is whether \"-\" was specified. If non-nil, the
+output may be limited to hours if minutes and seconds are zero.
+
+FLAG-PAD-SPACES-ONLY is whether \"_\" was specified. If non-nil,
+seconds must be output, so that any padding can be spaces only.
+
+FLAG-PAD-ZEROS-FIRST is whether \"0\" was specified. If non-nil,
+padding to the requested FIELD-WIDTH (if any) is done by adding
+00 seconds before padding with spaces.
+
+COLON-COUNT is the number of colons preceding the \"z\" (0-3). One or
+two colons put that many colons in the output (+-HH:MM or +-HH:MM:SS).
+Three colons outputs only hours if minutes and seconds are zero and
+includes colon separators if minutes and seconds are output.
+
+FIELD-WIDTH is a whole number giving the minimum number of characters
+in the output; 0 specifies no minimum. Additional characters will be
+added on the right if necessary. The added characters will be spaces
+unless FLAG-PAD-ZEROS-FIRST is non-nil.
+
+OFFSET-SECS is the time zone offset (in seconds east of UTC) to be
+formatted according to the preceding parameters."
+ (let ((hrs (/ (abs offset-secs) 3600))
+ (mins (/ (% (abs offset-secs) 3600) 60))
+ (secs (% (abs offset-secs) 60))
+ (result ""))
+ ;; valid option combo?
+ (cond
+ ((not (or (and flag-minimize (> colon-count 0))
+ (and flag-pad-spaces-only (> colon-count 0))
+ (and flag-pad-spaces-only flag-minimize)
+ (and flag-pad-spaces-only flag-pad-zeros-first)
+ (and flag-pad-zeros-first flag-minimize)))
+ (setq result (concat result (if (>= offset-secs 0) "+" "-")))
+ (setq result (concat result (format "%02d" hrs)))
+ ;; Need minutes?
+ (cond
+ ((or (> hrs 99)
+ (> mins 0)
+ (> secs 0)
+ (not (or flag-minimize (= colon-count 3)))
+ (and (> field-width (length result))
+ flag-pad-zeros-first))
+ ;; Need colon before minutes?
+ (if (or (> colon-count 0)
+ (> hrs 99))
+ (setq result (concat result ":")))
+ (setq result (concat result (format "%02d" mins)))
+ ;; Need seconds, too?
+ (cond
+ ((or (> secs 0)
+ (= colon-count 2)
+ flag-pad-spaces-only
+ (and (> field-width (length result))
+ flag-pad-zeros-first))
+ ;; Need colon before seconds?
+ (if (or (> colon-count 0)
+ (> hrs 99))
+ (setq result (concat result ":")))
+ (setq result (concat result (format "%02d" secs)))))))
+ ;; Need padding?
+ (let ((needed-padding (- field-width (length result))))
+ (if (> needed-padding 0)
+ (setq result (concat result (make-string needed-padding ?\s)))))))
+ result))
+
(provide 'time-stamp)
;;; time-stamp.el ends here
diff --git a/lisp/time.el b/lisp/time.el
index 96c9f62fd38..9f25f99a149 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -1,4 +1,4 @@
-;;; time.el --- display time, load and mail indicator in mode line of Emacs
+;;; time.el --- display time, load and mail indicator in mode line of Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1985-1987, 1993-1994, 1996, 2000-2021 Free Software
;; Foundation, Inc.
@@ -25,33 +25,31 @@
;; Facilities to display current time/date and a new-mail indicator
;; in the Emacs mode line. The entry point is `display-time'.
-;; Display time world in a buffer, the entry point is
-;; `display-time-world'.
+;; Use `world-clock' to display world clock in a buffer.
;;; Code:
+(eval-when-compile (require 'subr-x))
+
(defgroup display-time nil
"Display time and load in mode line of Emacs."
:group 'mode-line
:group 'mail)
-
(defcustom display-time-mail-file nil
"File name of mail inbox file, for indicating existence of new mail.
Non-nil and not a string means don't check for mail; nil means use
default, which is system-dependent, and is the same as used by Rmail."
:type '(choice (const :tag "None" none)
(const :tag "Default" nil)
- (file :format "%v"))
- :group 'display-time)
+ (file :format "%v")))
(defcustom display-time-mail-directory nil
"Name of mail inbox directory, for indicating existence of new mail.
Any nonempty regular file in the directory is regarded as newly arrived mail.
If nil, do not check a directory for arriving mail."
:type '(choice (const :tag "None" nil)
- (directory :format "%v"))
- :group 'display-time)
+ (directory :format "%v")))
(defcustom display-time-mail-function nil
"Function to call, for indicating existence of new mail.
@@ -59,8 +57,7 @@ If nil, that means use the default method: check that the file
specified by `display-time-mail-file' is nonempty or that the
directory `display-time-mail-directory' contains nonempty files."
:type '(choice (const :tag "Default" nil)
- (function))
- :group 'display-time)
+ (function)))
(defcustom display-time-default-load-average 0
"Which load average value will be shown in the mode line.
@@ -75,8 +72,7 @@ The value can be one of:
:type '(choice (const :tag "1 minute load" 0)
(const :tag "5 minutes load" 1)
(const :tag "15 minutes load" 2)
- (const :tag "None" nil))
- :group 'display-time)
+ (const :tag "None" nil)))
(defvar display-time-load-average nil
"Value of the system's load average currently shown on the mode line.
@@ -86,27 +82,23 @@ This is an internal variable; setting it has no effect.")
(defcustom display-time-load-average-threshold 0.1
"Load-average values below this value won't be shown in the mode line."
- :type 'number
- :group 'display-time)
+ :type 'number)
;;;###autoload
(defcustom display-time-day-and-date nil "\
Non-nil means \\[display-time] should display day and date as well as time."
- :type 'boolean
- :group 'display-time)
+ :type 'boolean)
(defvar display-time-timer nil)
(defcustom display-time-interval 60
"Seconds between updates of time in the mode line."
- :type 'integer
- :group 'display-time)
+ :type 'integer)
(defcustom display-time-24hr-format nil
"Non-nil indicates time should be displayed as hh:mm, 0 <= hh <= 23.
A value of nil means 1 <= hh <= 12, and an AM/PM suffix is used."
- :type 'boolean
- :group 'display-time)
+ :type 'boolean)
(defvar display-time-string nil
"String used in mode lines to display a time string.
@@ -116,103 +108,12 @@ It should not be set directly, but is instead updated by the
(defcustom display-time-hook nil
"List of functions to be called when the time is updated on the mode line."
- :type 'hook
- :group 'display-time)
+ :type 'hook)
(defvar display-time-server-down-time nil
"Time when mail file's file system was recorded to be down.
If that file system seems to be up, the value is nil.")
-(defcustom zoneinfo-style-world-list
- '(("America/Los_Angeles" "Seattle")
- ("America/New_York" "New York")
- ("Europe/London" "London")
- ("Europe/Paris" "Paris")
- ("Asia/Calcutta" "Bangalore")
- ("Asia/Tokyo" "Tokyo"))
- "Alist of zoneinfo-style time zones and places for `display-time-world'.
-Each element has the form (TIMEZONE LABEL).
-TIMEZONE should be a string of the form AREA/LOCATION, where AREA is
-the name of a region -- a continent or ocean, and LOCATION is the name
-of a specific location, e.g., a city, within that region.
-LABEL is a string to display as the label of that TIMEZONE's time."
- :group 'display-time
- :type '(repeat (list string string))
- :version "23.1")
-
-(defcustom legacy-style-world-list
- '(("PST8PDT" "Seattle")
- ("EST5EDT" "New York")
- ("GMT0BST" "London")
- ("CET-1CDT" "Paris")
- ("IST-5:30" "Bangalore")
- ("JST-9" "Tokyo"))
- "Alist of traditional-style time zones and places for `display-time-world'.
-Each element has the form (TIMEZONE LABEL).
-TIMEZONE should be a string of the form:
-
- std[+|-]offset[dst[offset][,date[/time],date[/time]]]
-
-See the documentation of the TZ environment variable on your system,
-for more details about the format of TIMEZONE.
-LABEL is a string to display as the label of that TIMEZONE's time."
- :group 'display-time
- :type '(repeat (list string string))
- :version "23.1")
-
-(defcustom display-time-world-list t
- "Alist of time zones and places for `display-time-world' to display.
-Each element has the form (TIMEZONE LABEL).
-TIMEZONE should be in a format supported by your system. See the
-documentation of `zoneinfo-style-world-list' and
-`legacy-style-world-list' for two widely used formats. LABEL is
-a string to display as the label of that TIMEZONE's time.
-
-If the value is t instead of an alist, use the value of
-`zoneinfo-style-world-list' if it works on this platform, and of
-`legacy-style-world-list' otherwise."
-
- :group 'display-time
- :type '(choice (const :tag "Default" t)
- (repeat :tag "List of zones and labels"
- (list (string :tag "Zone") (string :tag "Label"))))
- :version "23.1")
-
-(defun time--display-world-list ()
- (if (listp display-time-world-list)
- display-time-world-list
- ;; Determine if zoneinfo style timezones are supported by testing that
- ;; America/New York and Europe/London return different timezones.
- (let ((nyt (format-time-string "%z" nil "America/New_York"))
- (gmt (format-time-string "%z" nil "Europe/London")))
- (if (string-equal nyt gmt)
- legacy-style-world-list
- zoneinfo-style-world-list))))
-
-(defcustom display-time-world-time-format "%A %d %B %R %Z"
- "Format of the time displayed, see `format-time-string'."
- :group 'display-time
- :type 'string
- :version "23.1")
-
-(defcustom display-time-world-buffer-name "*wclock*"
- "Name of the world clock buffer."
- :group 'display-time
- :type 'string
- :version "23.1")
-
-(defcustom display-time-world-timer-enable t
- "If non-nil, a timer will update the world clock."
- :group 'display-time
- :type 'boolean
- :version "23.1")
-
-(defcustom display-time-world-timer-second 60
- "Interval in seconds for updating the world clock."
- :group 'display-time
- :type 'integer
- :version "23.1")
-
;;;###autoload
(defun display-time ()
"Enable display of time, load level, and mail flag in mode lines.
@@ -249,14 +150,12 @@ See `display-time-use-mail-icon' and `display-time-mail-face'.")
"Non-nil means use an icon as mail indicator on a graphic display.
Otherwise use `display-time-mail-string'. The icon may consume less
of the mode line. It is specified by `display-time-mail-icon'."
- :group 'display-time
:type 'boolean)
;; Fixme: maybe default to the character if we can display Unicode.
(defcustom display-time-mail-string "Mail"
"String to use as the mail indicator in `display-time-string-forms'.
This can use the Unicode letter character if you can display it."
- :group 'display-time
:version "22.1"
:type '(choice (const "Mail")
;; Use :tag here because the Lucid menu won't display
@@ -270,8 +169,7 @@ See the function `format-time-string' for an explanation of
how to write this string. If this is nil, the defaults
depend on `display-time-day-and-date' and `display-time-24hr-format'."
:type '(choice (const :tag "Default" nil)
- string)
- :group 'display-time)
+ string))
(defcustom display-time-string-forms
'((if (and (not display-time-format) display-time-day-and-date)
@@ -307,7 +205,8 @@ depend on `display-time-day-and-date' and `display-time-24hr-format'."
'mouse-face 'mode-line-highlight
'local-map (make-mode-line-mouse-map 'mouse-2
read-mail-command)))
- ""))
+ "")
+ " ")
"List of expressions governing display of the time in the mode line.
For most purposes, you can control the time format using `display-time-format'
which is a more standard interface.
@@ -325,8 +224,7 @@ For example:
(if mail \" Mail\" \"\"))
would give mode line times like `94/12/30 21:07:48 (UTC)'."
- :type '(repeat sexp)
- :group 'display-time)
+ :type '(repeat sexp))
(defun display-time-event-handler ()
(display-time-update)
@@ -387,6 +285,60 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1."
(defvar month)
(defvar dayname))
+(defun display-time-update--load ()
+ (if (null display-time-load-average)
+ ""
+ (condition-case ()
+ ;; Do not show values less than
+ ;; `display-time-load-average-threshold'.
+ (if (> (* display-time-load-average-threshold 100)
+ (nth display-time-load-average (load-average)))
+ ""
+ ;; The load average number is mysterious, so
+ ;; provide some help.
+ (let ((str (format " %03d"
+ (nth display-time-load-average
+ (load-average)))))
+ (propertize
+ (concat (substring str 0 -2) "." (substring str -2))
+ 'local-map (make-mode-line-mouse-map
+ 'mouse-2 'display-time-next-load-average)
+ 'mouse-face 'mode-line-highlight
+ 'help-echo (concat
+ "System load average for past "
+ (if (= 0 display-time-load-average)
+ "1 minute"
+ (if (= 1 display-time-load-average)
+ "5 minutes"
+ "15 minutes"))
+ "; mouse-2: next"))))
+ (error ""))))
+
+(defun display-time-update--mail ()
+ (let ((mail-spool-file (or display-time-mail-file
+ (getenv "MAIL")
+ (concat rmail-spool-directory
+ (user-login-name)))))
+ (cond
+ (display-time-mail-function
+ (funcall display-time-mail-function))
+ (display-time-mail-directory
+ (display-time-mail-check-directory))
+ ((and (stringp mail-spool-file)
+ (or (null display-time-server-down-time)
+ ;; If have been down for 20 min, try again.
+ (time-less-p 1200 (time-since
+ display-time-server-down-time))))
+ (let ((start-time (current-time)))
+ (prog1
+ (display-time-file-nonempty-p mail-spool-file)
+ ;; Record whether mail file is accessible.
+ (setq display-time-server-down-time
+ (let ((end-time (current-time)))
+ (and (time-less-p 20 (time-subtract
+ end-time start-time))
+ (float-time end-time))))))))))
+
(defun display-time-update ()
"Update the display-time info for the mode line.
However, don't redisplay right now.
@@ -394,57 +346,9 @@ However, don't redisplay right now.
This is used for things like Rmail `g' that want to force an
update which can wait for the next redisplay."
(let* ((now (current-time))
- (time (current-time-string now))
- (load (if (null display-time-load-average)
- ""
- (condition-case ()
- ;; Do not show values less than
- ;; `display-time-load-average-threshold'.
- (if (> (* display-time-load-average-threshold 100)
- (nth display-time-load-average (load-average)))
- ""
- ;; The load average number is mysterious, so
- ;; provide some help.
- (let ((str (format " %03d"
- (nth display-time-load-average
- (load-average)))))
- (propertize
- (concat (substring str 0 -2) "." (substring str -2))
- 'local-map (make-mode-line-mouse-map
- 'mouse-2 'display-time-next-load-average)
- 'mouse-face 'mode-line-highlight
- 'help-echo (concat
- "System load average for past "
- (if (= 0 display-time-load-average)
- "1 minute"
- (if (= 1 display-time-load-average)
- "5 minutes"
- "15 minutes"))
- "; mouse-2: next"))))
- (error ""))))
- (mail-spool-file (or display-time-mail-file
- (getenv "MAIL")
- (concat rmail-spool-directory
- (user-login-name))))
- (mail (cond
- (display-time-mail-function
- (funcall display-time-mail-function))
- (display-time-mail-directory
- (display-time-mail-check-directory))
- ((and (stringp mail-spool-file)
- (or (null display-time-server-down-time)
- ;; If have been down for 20 min, try again.
- (time-less-p 1200 (time-since
- display-time-server-down-time))))
- (let ((start-time (current-time)))
- (prog1
- (display-time-file-nonempty-p mail-spool-file)
- ;; Record whether mail file is accessible.
- (setq display-time-server-down-time
- (let ((end-time (current-time)))
- (and (time-less-p 20 (time-subtract
- end-time start-time))
- (float-time end-time)))))))))
+ (time (current-time-string now))
+ (load (display-time-update--load))
+ (mail (display-time-update--mail))
(24-hours (substring time 11 13))
(hour (string-to-number 24-hours))
(12-hours (int-to-string (1+ (% (+ hour 11) 12))))
@@ -508,13 +412,137 @@ runs the normal hook `display-time-hook' after each update."
(remove-hook 'rmail-after-get-new-mail-hook
'display-time-event-handler)))
+
+;;; Obsolete names
+
+(define-obsolete-variable-alias 'display-time-world-list
+ 'world-clock-list "28.1")
+(define-obsolete-variable-alias 'display-time-world-time-format
+ 'world-clock-time-format "28.1")
+(define-obsolete-variable-alias 'display-time-world-buffer-name
+ 'world-clock-buffer-name "28.1")
+(define-obsolete-variable-alias 'display-time-world-timer-enable
+ 'world-clock-timer-enable "28.1")
+(define-obsolete-variable-alias 'display-time-world-timer-second
+ 'world-clock-timer-second "28.1")
+
+(define-obsolete-function-alias 'display-time-world-mode
+ #'world-clock-mode "28.1")
+(define-obsolete-function-alias 'display-time-world-display
+ #'world-clock-display "28.1")
+(define-obsolete-function-alias 'display-time-world-timer
+ #'world-clock-update "28.1")
+
+
+;;; World clock
+
+(defgroup world-clock nil
+ "Display a world clock."
+ :group 'display-time)
+
+(defcustom zoneinfo-style-world-list
+ '(("America/Los_Angeles" "Seattle")
+ ("America/New_York" "New York")
+ ("Europe/London" "London")
+ ("Europe/Paris" "Paris")
+ ("Asia/Calcutta" "Bangalore")
+ ("Asia/Tokyo" "Tokyo"))
+ "Alist of zoneinfo-style time zones and places for `world-clock'.
+Each element has the form (TIMEZONE LABEL).
+TIMEZONE should be a string of the form AREA/LOCATION, where AREA is
+the name of a region -- a continent or ocean, and LOCATION is the name
+of a specific location, e.g., a city, within that region.
+LABEL is a string to display as the label of that TIMEZONE's time."
+ :type '(repeat (list string string))
+ :version "23.1")
+
+(defcustom legacy-style-world-list
+ '(("PST8PDT" "Seattle")
+ ("EST5EDT" "New York")
+ ("GMT0BST" "London")
+ ("CET-1CDT" "Paris")
+ ("IST-5:30" "Bangalore")
+ ("JST-9" "Tokyo"))
+ "Alist of traditional-style time zones and places for `world-clock'.
+Each element has the form (TIMEZONE LABEL).
+TIMEZONE should be a string of the form:
+
+ std[+|-]offset[dst[offset][,date[/time],date[/time]]]
+
+See the documentation of the TZ environment variable on your system,
+for more details about the format of TIMEZONE.
+LABEL is a string to display as the label of that TIMEZONE's time."
+ :type '(repeat (list string string))
+ :version "23.1")
+
+(defcustom world-clock-list t
+ "Alist of time zones and places for `world-clock' to display.
+Each element has the form (TIMEZONE LABEL).
+TIMEZONE should be in a format supported by your system. See the
+documentation of `zoneinfo-style-world-list' and
+`legacy-style-world-list' for two widely used formats. LABEL is
+a string to display as the label of that TIMEZONE's time.
+
+If the value is t instead of an alist, use the value of
+`zoneinfo-style-world-list' if it works on this platform, and of
+`legacy-style-world-list' otherwise."
+ :type '(choice (const :tag "Default" t)
+ (repeat :tag "List of zones and labels"
+ (list (string :tag "Zone") (string :tag "Label"))))
+ :version "28.1")
-(define-derived-mode display-time-world-mode special-mode "World clock"
+(defun time--display-world-list ()
+ (if (listp world-clock-list)
+ world-clock-list
+ ;; Determine if zoneinfo style timezones are supported by testing that
+ ;; America/New York and Europe/London return different timezones.
+ (let ((nyt (format-time-string "%z" nil "America/New_York"))
+ (gmt (format-time-string "%z" nil "Europe/London")))
+ (if (string-equal nyt gmt)
+ legacy-style-world-list
+ zoneinfo-style-world-list))))
+
+(defcustom world-clock-time-format "%A %d %B %R %Z"
+ "Time format for `world-clock', see `format-time-string'."
+ :type 'string
+ :version "28.1")
+
+(defcustom world-clock-buffer-name "*wclock*"
+ "Name of the `world-clock' buffer."
+ :type 'string
+ :version "28.1")
+
+(defcustom world-clock-timer-enable t
+ "If non-nil, a timer will update the `world-clock' buffer."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom world-clock-timer-second 60
+ "Interval in seconds for updating the `world-clock' buffer."
+ :type 'integer
+ :version "28.1")
+
+(defface world-clock-label
+ '((t :inherit font-lock-variable-name-face))
+ "Face for time zone label in `world-clock' buffer.")
+
+(defvar world-clock-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ map))
+
+(define-derived-mode world-clock-mode special-mode "World clock"
"Major mode for buffer that displays times in various time zones.
-See `display-time-world'."
+See `world-clock'."
+ :interactive nil
+ (setq-local revert-buffer-function #'world-clock-update)
(setq show-trailing-whitespace nil))
-(defun display-time-world-display (alist)
+(defvar world-clock--timer nil
+ "The current world clock timer.")
+
+(defun world-clock-display (alist)
"Replace current buffer text with times in various zones, based on ALIST."
(let ((inhibit-read-only t)
(buffer-undo-list t)
@@ -526,67 +554,84 @@ See `display-time-world'."
(let* ((label (cadr zone))
(width (string-width label)))
(push (cons label
- (format-time-string display-time-world-time-format
+ (format-time-string world-clock-time-format
now (car zone)))
result)
(when (> width max-width)
(setq max-width width))))
(setq fmt (concat "%-" (int-to-string max-width) "s %s\n"))
(dolist (timedata (nreverse result))
- (insert (format fmt (car timedata) (cdr timedata))))
+ (insert (format fmt
+ (propertize (car timedata)
+ 'face 'world-clock-label)
+ (cdr timedata))))
(delete-char -1))
(goto-char (point-min)))
;;;###autoload
-(defun display-time-world ()
- "Enable updating display of times in various time zones.
-`display-time-world-list' specifies the zones.
-To turn off the world time display, go to that window and type `q'."
+(define-obsolete-function-alias 'display-time-world
+ #'world-clock "28.1")
+
+;;;###autoload
+(defun world-clock ()
+ "Display a world clock buffer with times in various time zones.
+The variable `world-clock-list' specifies which time zones to use.
+To turn off the world time display, go to the window and type `\\[quit-window]'."
(interactive)
- (when (and display-time-world-timer-enable
- (not (get-buffer display-time-world-buffer-name)))
- (run-at-time t display-time-world-timer-second 'display-time-world-timer))
- (with-current-buffer (get-buffer-create display-time-world-buffer-name)
- (display-time-world-display (time--display-world-list))
- (display-buffer display-time-world-buffer-name
- (cons nil '((window-height . fit-window-to-buffer))))
- (display-time-world-mode)))
-
-(defun display-time-world-timer ()
- (if (get-buffer display-time-world-buffer-name)
- (with-current-buffer (get-buffer display-time-world-buffer-name)
- (display-time-world-display (time--display-world-list)))
- ;; cancel timer
- (let ((list timer-list))
- (while list
- (let ((elt (pop list)))
- (when (equal (symbol-name (timer--function elt))
- "display-time-world-timer")
- (cancel-timer elt)))))))
+ (if-let ((buffer (get-buffer world-clock-buffer-name)))
+ (pop-to-buffer buffer)
+ (pop-to-buffer world-clock-buffer-name)
+ (when world-clock-timer-enable
+ (setq world-clock--timer
+ (run-at-time t world-clock-timer-second #'world-clock-update))
+ (add-hook 'kill-buffer-hook #'world-clock-cancel-timer nil t)))
+ (world-clock-display (time--display-world-list))
+ (world-clock-mode)
+ (fit-window-to-buffer))
+
+(defun world-clock-cancel-timer ()
+ "Cancel the world clock timer."
+ (when world-clock--timer
+ (cancel-timer world-clock--timer)
+ (setq world-clock--timer nil)))
+
+(defun world-clock-update (&optional _arg _noconfirm)
+ "Update the `world-clock' buffer."
+ (if (get-buffer world-clock-buffer-name)
+ (with-current-buffer (get-buffer world-clock-buffer-name)
+ (let ((op (point)))
+ (world-clock-display (time--display-world-list))
+ (goto-char op)))
+ (world-clock-cancel-timer)))
;;;###autoload
-(defun emacs-uptime (&optional format)
+(defun emacs-uptime (&optional format here)
"Return a string giving the uptime of this instance of Emacs.
FORMAT is a string to format the result, using `format-seconds'.
-For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"."
- (interactive)
+For example, the Unix uptime command format is \"%D, %z%2h:%.2m\".
+If the optional argument HERE is non-nil, insert string at
+point."
+ (interactive "i\nP")
(let ((str
(format-seconds (or format "%Y, %D, %H, %M, %z%S")
(time-convert
(time-since before-init-time)
'integer))))
- (if (called-interactively-p 'interactive)
- (message "%s" str)
- str)))
+ (if here
+ (insert str)
+ (if (called-interactively-p 'interactive)
+ (message "%s" str)
+ str))))
;;;###autoload
-(defun emacs-init-time ()
- "Return a string giving the duration of the Emacs initialization."
+(defun emacs-init-time (&optional format)
+ "Return a string giving the duration of the Emacs initialization.
+FORMAT is a string to format the result, using `format'. If nil,
+the default format \"%f seconds\" is used."
(interactive)
- (let ((str
- (format "%s seconds"
- (float-time
- (time-subtract after-init-time before-init-time)))))
+ (let ((str (format (or format "%f seconds")
+ (float-time (time-subtract after-init-time
+ before-init-time)))))
(if (called-interactively-p 'interactive)
(message "%s" str)
str)))
diff --git a/lisp/timezone.el b/lisp/timezone.el
index ae31ac311e0..2c96343a74b 100644
--- a/lisp/timezone.el
+++ b/lisp/timezone.el
@@ -1,4 +1,4 @@
-;;; timezone.el --- time zone package for GNU Emacs -- lexical-binding: t -*-
+;;; timezone.el --- time zone package for GNU Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1990-1993, 1996, 1999, 2001-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/tmm.el b/lisp/tmm.el
index dc9340b1468..2040f522700 100644
--- a/lisp/tmm.el
+++ b/lisp/tmm.el
@@ -42,25 +42,7 @@
(defvar tmm-next-shortcut-digit)
(defvar tmm-table-undef)
-(defun tmm-menubar-keymap ()
- "Return the current menu-bar keymap.
-
-The ordering of the return value respects `menu-bar-final-items'."
- (let ((menu-bar '())
- (menu-end '()))
- (map-keymap
- (lambda (key binding)
- (push (cons key binding)
- ;; If KEY is the name of an item that we want to put last,
- ;; move it to the end.
- (if (memq key menu-bar-final-items)
- menu-end
- menu-bar)))
- (tmm-get-keybind [menu-bar]))
- `(keymap ,@(nreverse menu-bar) ,@(nreverse menu-end))))
-
;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
-;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
;;;###autoload
(defun tmm-menubar (&optional x-position)
@@ -74,30 +56,14 @@ to invoke `tmm-menubar' instead, customize the variable
`tty-menu-open-use-tmm' to a non-nil value."
(interactive)
(run-hooks 'menu-bar-update-hook)
- ;; Obey menu-bar-final-items; put those items last.
- (let ((menu-bar (tmm-menubar-keymap))
- menu-bar-item)
- (if x-position
- (let ((column 0)
- prev-key)
- (catch 'done
- (map-keymap
- (lambda (key binding)
- (when (> column x-position)
- (setq menu-bar-item prev-key)
- (throw 'done nil))
- (setq prev-key key)
- (pcase binding
- ((or `(,(and (pred stringp) name) . ,_) ;Simple menu item.
- `(menu-item ,name ,_cmd ;Extended menu item.
- . ,(and props
- (guard (let ((visible
- (plist-get props :visible)))
- (or (null visible)
- (eval visible)))))))
- (setq column (+ column (length name) 1)))))
- menu-bar))))
- (tmm-prompt menu-bar nil menu-bar-item)))
+ (if isearch-mode
+ (isearch-tmm-menubar)
+ (let ((menu-bar (menu-bar-keymap))
+ (menu-bar-item-cons (and x-position
+ (menu-bar-item-at-x x-position))))
+ (tmm-prompt menu-bar
+ nil
+ (and menu-bar-item-cons (car menu-bar-item-cons))))))
;;;###autoload
(defun tmm-menubar-mouse (event)
@@ -517,14 +483,6 @@ It uses the free variable `tmm-table-undef' to keep undefined keys."
(or (assoc str tmm-km-list)
(push (cons str (cons event km)) tmm-km-list))))))
-(defun tmm-get-keybind (keyseq)
- "Return the current binding of KEYSEQ, merging prefix definitions.
-If KEYSEQ is a prefix key that has local and global bindings,
-we merge them into a single keymap which shows the proper order of the menu.
-However, for the menu bar itself, the value does not take account
-of `menu-bar-final-items'."
- (lookup-key (cons 'keymap (nreverse (current-active-maps))) keyseq))
-
(provide 'tmm)
;;; tmm.el ends here
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index 1800203f91b..6da401187b1 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -1,4 +1,4 @@
-;;; tool-bar.el --- setting up the tool bar
+;;; tool-bar.el --- setting up the tool bar -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -139,7 +139,7 @@ ICON.xbm, using `find-image'.
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))
+ (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."
@@ -159,7 +159,8 @@ To define items in any other map, use `tool-bar-local-item'."
((< (display-color-cells) 256)
',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
(t
- ',(list xpm-spec pbm-spec xbm-spec))))))
+ ',(list xpm-spec pbm-spec xbm-spec)))
+ t)))
;;;###autoload
(defun tool-bar-local-item (icon def key map &rest props)
@@ -191,7 +192,7 @@ MAP must contain appropriate binding for `[menu-bar]' which holds a keymap.
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-from-menu'."
- (apply 'tool-bar-local-item-from-menu command icon
+ (apply #'tool-bar-local-item-from-menu command icon
(default-value 'tool-bar-map) map props))
;;;###autoload
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index bb53a138d84..03d9f54ea6c 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -1,4 +1,4 @@
-;;; tooltip.el --- show tooltip windows
+;;; tooltip.el --- show tooltip windows -*- lexical-binding:t -*-
;; Copyright (C) 1997, 1999-2021 Free Software Foundation, Inc.
@@ -70,24 +70,20 @@ echo area, instead of making a pop-up window."
(defcustom tooltip-delay 0.7
"Seconds to wait before displaying a tooltip the first time."
- :type 'number
- :group 'tooltip)
+ :type 'number)
(defcustom tooltip-short-delay 0.1
"Seconds to wait between subsequent tooltips on different items."
- :type 'number
- :group 'tooltip)
+ :type 'number)
(defcustom tooltip-recent-seconds 1
"Display tooltips if changing tip items within this many seconds.
Do so after `tooltip-short-delay'."
- :type 'number
- :group 'tooltip)
+ :type 'number)
(defcustom tooltip-hide-delay 10
"Hide tooltips automatically after this many seconds."
- :type 'number
- :group 'tooltip)
+ :type 'number)
(defcustom tooltip-x-offset 5
"X offset, in pixels, for the display of tooltips.
@@ -98,8 +94,7 @@ interfere with clicking where you wish.
If `tooltip-frame-parameters' includes the `left' parameter,
the value of `tooltip-x-offset' is ignored."
- :type 'integer
- :group 'tooltip)
+ :type 'integer)
(defcustom tooltip-y-offset +20
"Y offset, in pixels, for the display of tooltips.
@@ -110,8 +105,7 @@ interfere with clicking where you wish.
If `tooltip-frame-parameters' includes the `top' parameter,
the value of `tooltip-y-offset' is ignored."
- :type 'integer
- :group 'tooltip)
+ :type 'integer)
(defcustom tooltip-frame-parameters
'((name . "tooltip")
@@ -127,8 +121,7 @@ Note that font and color parameters are ignored, and the attributes
of the `tooltip' face are used instead."
:type '(repeat (cons :format "%v"
(symbol :tag "Parameter")
- (sexp :tag "Value")))
- :group 'tooltip
+ (sexp :tag "Value")))
:version "26.1")
(defface tooltip
@@ -149,8 +142,7 @@ When using the GTK toolkit, this face will only be used if
"Use the echo area instead of tooltip frames for help and GUD tooltips.
This variable is obsolete; instead of setting it to t, disable
`tooltip-mode' (which has a similar effect)."
- :type 'boolean
- :group 'tooltip)
+ :type 'boolean)
(make-obsolete-variable 'tooltip-use-echo-area
"disable Tooltip mode instead" "24.1" 'set)
@@ -164,14 +156,11 @@ the echo area is resized as needed to accommodate the full text
of the tooltip.
This variable has effect only on GUI frames."
:type 'boolean
- :group 'tooltip
:version "27.1")
;;; Variables that are not customizable.
-(define-obsolete-variable-alias 'tooltip-hook 'tooltip-functions "23.1")
-
(defvar tooltip-functions nil
"Functions to call to display tooltips.
Each function is called with one argument EVENT which is a copy
@@ -263,7 +252,12 @@ in echo area."
(setf (alist-get 'border-color params) fg))
(when (stringp bg)
(setf (alist-get 'background-color params) bg))
- (x-show-tip (propertize text 'face 'tooltip)
+ ;; Use non-nil APPEND argument below to avoid overriding any
+ ;; faces used in our TEXT. Among other things, this allows
+ ;; tooltips to use the `help-key-binding' face used in
+ ;; `substitute-command-keys' substitutions.
+ (add-face-text-property 0 (length text) 'tooltip t text)
+ (x-show-tip text
(selected-frame)
params
tooltip-hide-delay
diff --git a/lisp/transient.el b/lisp/transient.el
new file mode 100644
index 00000000000..5f66a13094b
--- /dev/null
+++ b/lisp/transient.el
@@ -0,0 +1,3676 @@
+;;; transient.el --- Transient commands -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2021 Free Software Foundation, Inc.
+
+;; Author: Jonas Bernoulli <jonas@bernoul.li>
+;; Homepage: https://github.com/magit/transient
+;; Keywords: bindings
+
+;; Package-Requires: ((emacs "25.1"))
+;; Package-Version: 0.3.6
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is part of GNU Emacs.
+
+;;; Commentary:
+
+;; Taking inspiration from prefix keys and prefix arguments, Transient
+;; implements a similar abstraction involving a prefix command, infix
+;; arguments and suffix commands. We could call this abstraction a
+;; "transient command", but because it always involves at least two
+;; commands (a prefix and a suffix) we prefer to call it just a
+;; "transient".
+
+;; When the user calls a transient prefix command, then a transient
+;; (temporary) keymap is activated, which binds the transient's infix
+;; and suffix commands, and functions that control the transient state
+;; are added to `pre-command-hook' and `post-command-hook'. The
+;; available suffix and infix commands and their state are shown in
+;; the echo area until the transient is exited by invoking a suffix
+;; command.
+
+;; Calling an infix command causes its value to be changed, possibly
+;; by reading a new value in the minibuffer.
+
+;; Calling a suffix command usually causes the transient to be exited
+;; but suffix commands can also be configured to not exit the
+;; transient state.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'eieio)
+(require 'format-spec)
+(require 'seq)
+
+(eval-when-compile
+ (require 'subr-x))
+
+(declare-function info 'info)
+(declare-function Man-find-section 'man)
+(declare-function Man-next-section 'man)
+(declare-function Man-getpage-in-background 'man)
+
+(defvar Man-notify-method)
+
+(define-obsolete-function-alias 'define-transient-command
+ 'transient-define-prefix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-suffix-command
+ 'transient-define-suffix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-infix-command
+ 'transient-define-infix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-infix-argument
+ 'transient-define-argument "Transient 0.3.0")
+
+(define-obsolete-variable-alias 'current-transient-prefix
+ 'transient-current-prefix "Transient 0.3.0")
+(define-obsolete-variable-alias 'current-transient-command
+ 'transient-current-command "Transient 0.3.0")
+(define-obsolete-variable-alias 'current-transient-suffixes
+ 'transient-current-suffixes "Transient 0.3.0")
+(define-obsolete-variable-alias 'post-transient-hook
+ 'transient-exit-hook "Transient 0.3.0")
+
+(defmacro transient--with-emergency-exit (&rest body)
+ (declare (indent defun))
+ `(condition-case err
+ (let ((debugger #'transient--exit-and-debug))
+ ,(macroexp-progn body))
+ ((debug error)
+ (transient--emergency-exit)
+ (signal (car err) (cdr err)))))
+
+(defun transient--exit-and-debug (&rest args)
+ (transient--emergency-exit)
+ (apply #'debug args))
+
+;;; Options
+
+(defgroup transient nil
+ "Transient commands."
+ :group 'extensions)
+
+(defcustom transient-show-popup t
+ "Whether to show the current transient in a popup buffer.
+
+- If t, then show the popup as soon as a transient prefix command
+ is invoked.
+
+- If nil, then do not show the popup unless the user explicitly
+ requests it, by pressing an incomplete prefix key sequence.
+
+- If a number, then delay displaying the popup and instead show
+ a brief one-line summary. If zero or negative, then suppress
+ even showing that summary and display the pressed key only.
+
+ Show the popup when the user explicitly requests it by pressing
+ an incomplete prefix key sequence. Unless zero, then also show
+ the popup after that many seconds of inactivity (using the
+ absolute value)."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "instantly" t)
+ (const :tag "on demand" nil)
+ (const :tag "on demand (no summary)" 0)
+ (number :tag "after delay" 1)))
+
+(defcustom transient-enable-popup-navigation nil
+ "Whether navigation commands are enabled in the transient popup.
+
+While a transient is active the transient popup buffer is not the
+current buffer, making it necessary to use dedicated commands to
+act on that buffer itself. If this non-nil, then the following
+features are available:
+
+- \"<up>\" moves the cursor to the previous suffix.
+ \"<down>\" moves the cursor to the next suffix.
+ \"RET\" invokes the suffix the cursor is on.
+- \"<mouse-1>\" invokes the clicked on suffix.
+- \"C-s\" and \"C-r\" start isearch in the popup buffer."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-display-buffer-action
+ '(display-buffer-in-side-window
+ (side . bottom)
+ (inhibit-same-window . t))
+ "The action used to display the transient popup buffer.
+
+The transient popup buffer is displayed in a window using
+
+ \(display-buffer buf transient-display-buffer-action)
+
+The value of this option has the form (FUNCTION . ALIST),
+where FUNCTION is a function or a list of functions. Each such
+function should accept two arguments: a buffer to display and
+an alist of the same form as ALIST. See `display-buffer' for
+details.
+
+The default is:
+
+ (display-buffer-in-side-window
+ (side . bottom)
+ (inhibit-same-window . t))
+
+This displays the window at the bottom of the selected frame.
+Another useful value is (display-buffer-below-selected). This
+is what `magit-popup' used by default. For more alternatives
+see info node `(elisp)Display Action Functions'.
+
+It may be possible to display the window in another frame, but
+whether that works in practice depends on the window-manager.
+If the window manager selects the new window (Emacs frame),
+then it doesn't work.
+
+If you change the value of this option, then you might also
+want to change the value of `transient-mode-line-format'."
+ :package-version '(transient . "0.3.0")
+ :group 'transient
+ :type '(cons (choice function (repeat :tag "Functions" function))
+ alist))
+
+(defcustom transient-mode-line-format 'line
+ "The mode-line format for the transient popup buffer.
+
+If nil, then the buffer has no mode-line. If the buffer is not
+displayed right above the echo area, then this probably is not
+a good value.
+
+If `line' (the default), then the buffer also has no mode-line,
+but a thin line is drawn instead, using the background color of
+the face `transient-separator'. Termcap frames cannot display
+thin lines and therefore fallback to treating `line' like nil.
+
+Otherwise this can be any mode-line format.
+See `mode-line-format' for details."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type '(choice (const :tag "hide mode-line" nil)
+ (const :tag "substitute thin line" line)
+ (const :tag "name of prefix command"
+ ("%e" mode-line-front-space
+ mode-line-buffer-identification))
+ (sexp :tag "custom mode-line format")))
+
+(defcustom transient-show-common-commands nil
+ "Whether to show common transient suffixes in the popup buffer.
+
+These commands are always shown after typing the prefix key
+\"C-x\" when a transient command is active. To toggle the value
+of this variable use \"C-x t\" when a transient is active."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-read-with-initial-input nil
+ "Whether to use the last history element as initial minibuffer input."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-highlight-mismatched-keys nil
+ "Whether to highlight keys that do not match their argument.
+
+This only affects infix arguments that represent command-line
+arguments. When this option is non-nil, then the key binding
+for infix argument are highlighted when only a long argument
+\(e.g. \"--verbose\") is specified but no shor-thand (e.g \"-v\").
+In the rare case that a short-hand is specified but does not
+match the key binding, then it is highlighed differently.
+
+The highlighting is done using using `transient-mismatched-key'
+and `transient-nonstandard-key'."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-highlight-higher-levels nil
+ "Whether to highlight suffixes on higher levels.
+
+This is primarily intended for package authors.
+
+When non-nil then highlight the description of suffixes whose
+level is above 4, the default of `transient-default-level'.
+Assuming you have set that variable to 7, this highlights all
+suffixes that won't be available to users without them making
+the same customization."
+ :package-version '(transient . "0.3.6")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-substitute-key-function nil
+ "Function used to modify key bindings.
+
+This function is called with one argument, the prefix object,
+and must return a key binding description, either the existing
+key description it finds in the `key' slot, or a substitution.
+
+This is intended to let users replace certain prefix keys. It
+could also be used to make other substitutions, but that is
+discouraged.
+
+For example, \"=\" is hard to reach using my custom keyboard
+layout, so I substitute \"(\" for that, which is easy to reach
+using a layout optimized for lisp.
+
+ (setq transient-substitute-key-function
+ (lambda (obj)
+ (let ((key (oref obj key)))
+ (if (string-match \"\\\\`\\\\(=\\\\)[a-zA-Z]\" key)
+ (replace-match \"(\" t t key 1)
+ key)))))"
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "Transform no keys (nil)" nil) function))
+
+(defcustom transient-semantic-coloring nil
+ "Whether to color prefixes and suffixes in Hydra-like fashion.
+This feature is experimental.
+
+If non-nil, then the key binding of each suffix is colorized to
+indicate whether it exits the transient state or not. The color
+of the prefix is indicated using the line that is drawn when the
+value of `transient-mode-line-format' is `line'.
+
+For more information about how Hydra uses colors see
+https://github.com/abo-abo/hydra#color and
+https://oremacs.com/2015/02/19/hydra-colors-reloaded."
+ :package-version '(transient . "0.3.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-detect-key-conflicts nil
+ "Whether to detect key binding conflicts.
+
+Conflicts are detected when a transient prefix command is invoked
+and results in an error, which prevents the transient from being
+used."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-force-fixed-pitch nil
+ "Whether to force use of monospaced font in the popup buffer.
+
+Even if you use a proportional font for the `default' face,
+you might still want to use a monospaced font in transient's
+popup buffer. Setting this option to t causes `default' to
+be remapped to `fixed-pitch' in that buffer."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-force-single-column nil
+ "Whether to force use of a single column to display suffixes.
+
+This might be useful for users with low vision who use large
+text and might otherwise have to scroll in two dimensions."
+ :package-version '(transient . "0.3.6")
+ :group 'transient
+ :type 'boolean)
+
+(defconst transient--default-child-level 1)
+
+(defconst transient--default-prefix-level 4)
+
+(defcustom transient-default-level transient--default-prefix-level
+ "Control what suffix levels are made available by default.
+
+Each suffix command is placed on a level and each prefix command
+has a level, which controls which suffix commands are available.
+Integers between 1 and 7 (inclusive) are valid levels.
+
+The levels of individual transients and/or their individual
+suffixes can be changed individually, by invoking the prefix and
+then pressing \"C-x l\".
+
+The default level for both transients and their suffixes is 4.
+This option only controls the default for transients. The default
+suffix level is always 4. The author of a transient should place
+certain suffixes on a higher level if they expect that it won't be
+of use to most users, and they should place very important suffixes
+on a lower level so that they remain available even if the user
+lowers the transient level.
+
+\(Magit currently places nearly all suffixes on level 4 and lower
+levels are not used at all yet. So for the time being you should
+not set a lower level here and using a higher level might not
+give you as many additional suffixes as you hoped.)"
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "1 - fewest suffixes" 1)
+ (const 2)
+ (const 3)
+ (const :tag "4 - default" 4)
+ (const 5)
+ (const 6)
+ (const :tag "7 - most suffixes" 7)))
+
+(defcustom transient-levels-file
+ (locate-user-emacs-file (convert-standard-filename "transient/levels.el"))
+ "File used to save levels of transients and their suffixes."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-values-file
+ (locate-user-emacs-file (convert-standard-filename "transient/values.el"))
+ "File used to save values of transients."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-history-file
+ (locate-user-emacs-file (convert-standard-filename "transient/history.el"))
+ "File used to save history of transients and their infixes."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-history-limit 10
+ "Number of history elements to keep when saving to file."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'integer)
+
+(defcustom transient-save-history t
+ "Whether to save history of transient commands when exiting Emacs."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+;;; Faces
+
+(defgroup transient-faces nil
+ "Faces used by Transient."
+ :group 'transient)
+
+(defface transient-heading '((t :inherit font-lock-keyword-face))
+ "Face used for headings."
+ :group 'transient-faces)
+
+(defface transient-key '((t :inherit font-lock-builtin-face))
+ "Face used for keys."
+ :group 'transient-faces)
+
+(defface transient-argument '((t :inherit font-lock-warning-face))
+ "Face used for enabled arguments."
+ :group 'transient-faces)
+
+(defface transient-value '((t :inherit font-lock-string-face))
+ "Face used for values."
+ :group 'transient-faces)
+
+(defface transient-inactive-argument '((t :inherit shadow))
+ "Face used for inactive arguments."
+ :group 'transient-faces)
+
+(defface transient-inactive-value '((t :inherit shadow))
+ "Face used for inactive values."
+ :group 'transient-faces)
+
+(defface transient-unreachable '((t :inherit shadow))
+ "Face used for suffixes unreachable from the current prefix sequence."
+ :group 'transient-faces)
+
+(defface transient-active-infix '((t :inherit secondary-selection))
+ "Face used for the infix for which the value is being read."
+ :group 'transient-faces)
+
+(defface transient-unreachable-key '((t :inherit shadow))
+ "Face used for keys unreachable from the current prefix sequence."
+ :group 'transient-faces)
+
+(defface transient-nonstandard-key '((t :underline t))
+ "Face optionally used to highlight keys conflicting with short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
+
+(defface transient-mismatched-key '((t :underline t))
+ "Face optionally used to highlight keys without a short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
+
+(defface transient-inapt-suffix '((t :inherit shadow :italic t))
+ "Face used for suffixes that are inapt at this time."
+ :group 'transient-faces)
+
+(defface transient-enabled-suffix
+ '((t :background "green" :foreground "black" :weight bold))
+ "Face used for enabled levels while editing suffix levels.
+See info node `(transient)Enabling and Disabling Suffixes'."
+ :group 'transient-faces)
+
+(defface transient-disabled-suffix
+ '((t :background "red" :foreground "black" :weight bold))
+ "Face used for disabled levels while editing suffix levels.
+See info node `(transient)Enabling and Disabling Suffixes'."
+ :group 'transient-faces)
+
+(defface transient-higher-level '((t :underline t))
+ "Face optionally used to highlight suffixes on higher levels.
+Also see option `transient-highlight-higher-levels'."
+ :group 'transient-faces)
+
+(defface transient-separator
+ `((((class color) (background light))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "grey80")
+ (((class color) (background dark))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "grey30"))
+ "Face used to draw line below transient popup window.
+This is only used if `transient-mode-line-format' is `line'.
+Only the background color is significant."
+ :group 'transient-faces)
+
+(defgroup transient-color-faces
+ '((transient-semantic-coloring custom-variable))
+ "Faces used by Transient for Hydra-like command coloring.
+These faces are only used if `transient-semantic-coloring'
+\(which see) is non-nil."
+ :group 'transient-faces)
+
+(defface transient-red
+ '((t :inherit transient-key :foreground "red"))
+ "Face used for red prefixes and suffixes."
+ :group 'transient-color-faces)
+
+(defface transient-blue
+ '((t :inherit transient-key :foreground "blue"))
+ "Face used for blue prefixes and suffixes."
+ :group 'transient-color-faces)
+
+(defface transient-amaranth
+ '((t :inherit transient-key :foreground "#E52B50"))
+ "Face used for amaranth prefixes."
+ :group 'transient-color-faces)
+
+(defface transient-pink
+ '((t :inherit transient-key :foreground "#FF6EB4"))
+ "Face used for pink prefixes."
+ :group 'transient-color-faces)
+
+(defface transient-teal
+ '((t :inherit transient-key :foreground "#367588"))
+ "Face used for teal prefixes."
+ :group 'transient-color-faces)
+
+;;; Persistence
+
+(defun transient--read-file-contents (file)
+ (with-demoted-errors "Transient error: %S"
+ (and (file-exists-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (read (current-buffer))))))
+
+(defun transient--pp-to-file (list file)
+ (make-directory (file-name-directory file) t)
+ (setq list (cl-sort (copy-sequence list) #'string< :key #'car))
+ (with-temp-file file
+ (let ((print-level nil)
+ (print-length nil))
+ (pp list (current-buffer)))))
+
+(defvar transient-values
+ (transient--read-file-contents transient-values-file)
+ "Values of transient commands.
+The value of this variable persists between Emacs sessions
+and you usually should not change it manually.")
+
+(defun transient-save-values ()
+ (transient--pp-to-file transient-values transient-values-file))
+
+(defvar transient-levels
+ (transient--read-file-contents transient-levels-file)
+ "Levels of transient commands.
+The value of this variable persists between Emacs sessions
+and you usually should not change it manually.")
+
+(defun transient-save-levels ()
+ (transient--pp-to-file transient-levels transient-levels-file))
+
+(defvar transient-history
+ (transient--read-file-contents transient-history-file)
+ "History of transient commands and infix arguments.
+The value of this variable persists between Emacs sessions
+\(unless `transient-save-history' is nil) and you usually
+should not change it manually.")
+
+(defun transient-save-history ()
+ (setq transient-history
+ (cl-sort (mapcar (pcase-lambda (`(,key . ,val))
+ (cons key (seq-take (delete-dups val)
+ transient-history-limit)))
+ transient-history)
+ #'string< :key #'car))
+ (transient--pp-to-file transient-history transient-history-file))
+
+(defun transient-maybe-save-history ()
+ "Save the value of `transient-history'.
+If `transient-save-history' is nil, then do nothing."
+ (when transient-save-history
+ (transient-save-history)))
+
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'transient-maybe-save-history))
+
+;;; Classes
+;;;; Prefix
+
+(defclass transient-prefix ()
+ ((prototype :initarg :prototype)
+ (command :initarg :command)
+ (level :initarg :level)
+ (variable :initarg :variable :initform nil)
+ (init-value :initarg :init-value)
+ (value) (default-value :initarg :value)
+ (scope :initarg :scope :initform nil)
+ (history :initarg :history :initform nil)
+ (history-pos :initarg :history-pos :initform 0)
+ (history-key :initarg :history-key :initform nil)
+ (man-page :initarg :man-page :initform nil)
+ (info-manual :initarg :info-manual :initform nil)
+ (transient-suffix :initarg :transient-suffix :initform nil)
+ (transient-non-suffix :initarg :transient-non-suffix :initform nil)
+ (incompatible :initarg :incompatible :initform nil)
+ (suffix-description :initarg :suffix-description))
+ "Transient prefix command.
+
+Each transient prefix command consists of a command, which is
+stored in a symbol's function slot and an object, which is
+stored in the `transient--prefix' property of the same symbol.
+
+When a transient prefix command is invoked, then a clone of that
+object is stored in the global variable `transient--prefix' and
+the prototype is stored in the clone's `prototype' slot.")
+
+;;;; Suffix
+
+(defclass transient-child ()
+ ((level
+ :initarg :level
+ :initform (symbol-value 'transient--default-child-level)
+ :documentation "Enable if level of prefix is equal or greater.")
+ (if
+ :initarg :if
+ :initform nil
+ :documentation "Enable if predicate returns non-nil.")
+ (if-not
+ :initarg :if-not
+ :initform nil
+ :documentation "Enable if predicate returns nil.")
+ (if-non-nil
+ :initarg :if-non-nil
+ :initform nil
+ :documentation "Enable if variable's value is non-nil.")
+ (if-nil
+ :initarg :if-nil
+ :initform nil
+ :documentation "Enable if variable's value is nil.")
+ (if-mode
+ :initarg :if-mode
+ :initform nil
+ :documentation "Enable if major-mode matches value.")
+ (if-not-mode
+ :initarg :if-not-mode
+ :initform nil
+ :documentation "Enable if major-mode does not match value.")
+ (if-derived
+ :initarg :if-derived
+ :initform nil
+ :documentation "Enable if major-mode derives from value.")
+ (if-not-derived
+ :initarg :if-not-derived
+ :initform nil
+ :documentation "Enable if major-mode does not derive from value."))
+ "Abstract superclass for group and and suffix classes.
+
+It is undefined what happens if more than one `if*' predicate
+slot is non-nil."
+ :abstract t)
+
+(defclass transient-suffix (transient-child)
+ ((key :initarg :key)
+ (command :initarg :command)
+ (transient :initarg :transient)
+ (format :initarg :format :initform " %k %d")
+ (description :initarg :description :initform nil)
+ (inapt :initform nil)
+ (inapt-if
+ :initarg :inapt-if
+ :initform nil
+ :documentation "Inapt if predicate returns non-nil.")
+ (inapt-if-not
+ :initarg :inapt-if-not
+ :initform nil
+ :documentation "Inapt if predicate returns nil.")
+ (inapt-if-non-nil
+ :initarg :inapt-if-non-nil
+ :initform nil
+ :documentation "Inapt if variable's value is non-nil.")
+ (inapt-if-nil
+ :initarg :inapt-if-nil
+ :initform nil
+ :documentation "Inapt if variable's value is nil.")
+ (inapt-if-mode
+ :initarg :inapt-if-mode
+ :initform nil
+ :documentation "Inapt if major-mode matches value.")
+ (inapt-if-not-mode
+ :initarg :inapt-if-not-mode
+ :initform nil
+ :documentation "Inapt if major-mode does not match value.")
+ (inapt-if-derived
+ :initarg :inapt-if-derived
+ :initform nil
+ :documentation "Inapt if major-mode derives from value.")
+ (inapt-if-not-derived
+ :initarg :inapt-if-not-derived
+ :initform nil
+ :documentation "Inapt if major-mode does not derive from value."))
+ "Superclass for suffix command.")
+
+(defclass transient-infix (transient-suffix)
+ ((transient :initform t)
+ (argument :initarg :argument)
+ (shortarg :initarg :shortarg)
+ (value :initform nil)
+ (init-value :initarg :init-value)
+ (unsavable :initarg :unsavable :initform nil)
+ (multi-value :initarg :multi-value :initform nil)
+ (always-read :initarg :always-read :initform nil)
+ (allow-empty :initarg :allow-empty :initform nil)
+ (history-key :initarg :history-key :initform nil)
+ (reader :initarg :reader :initform nil)
+ (prompt :initarg :prompt :initform nil)
+ (choices :initarg :choices :initform nil)
+ (format :initform " %k %d (%v)"))
+ "Transient infix command."
+ :abstract t)
+
+(defclass transient-argument (transient-infix) ()
+ "Abstract superclass for infix arguments."
+ :abstract t)
+
+(defclass transient-switch (transient-argument) ()
+ "Class used for command-line argument that can be turned on and off.")
+
+(defclass transient-option (transient-argument) ()
+ "Class used for command-line argument that can take a value.")
+
+(defclass transient-variable (transient-infix)
+ ((variable :initarg :variable)
+ (format :initform " %k %d %v"))
+ "Abstract superclass for infix commands that set a variable."
+ :abstract t)
+
+(defclass transient-switches (transient-argument)
+ ((argument-format :initarg :argument-format)
+ (argument-regexp :initarg :argument-regexp))
+ "Class used for sets of mutually exclusive command-line switches.")
+
+(defclass transient-files (transient-infix) ()
+ "Class used for the \"--\" argument.
+All remaining arguments are treated as files.
+They become the value of this this argument.")
+
+;;;; Group
+
+(defclass transient-group (transient-child)
+ ((suffixes :initarg :suffixes :initform nil)
+ (hide :initarg :hide :initform nil)
+ (description :initarg :description :initform nil)
+ (setup-children :initarg :setup-children)
+ (pad-keys :initarg :pad-keys))
+ "Abstract superclass of all group classes."
+ :abstract t)
+
+(defclass transient-column (transient-group) ()
+ "Group class that displays each element on a separate line.")
+
+(defclass transient-row (transient-group) ()
+ "Group class that displays all elements on a single line.")
+
+(defclass transient-columns (transient-group) ()
+ "Group class that displays elements organized in columns.
+Direct elements have to be groups whose elements have to be
+commands or string. Each subgroup represents a column. This
+class takes care of inserting the subgroups' elements.")
+
+(defclass transient-subgroups (transient-group) ()
+ "Group class that wraps other groups.
+
+Direct elements have to be groups whose elements have to be
+commands or strings. This group inserts an empty line between
+subgroups. The subgroups are responsible for displaying their
+elements themselves.")
+
+;;; Define
+
+(defmacro transient-define-prefix (name arglist &rest args)
+ "Define NAME as a transient prefix command.
+
+ARGLIST are the arguments that command takes.
+DOCSTRING is the documentation string and is optional.
+
+These arguments can optionally be followed by key-value pairs.
+Each key has to be a keyword symbol, either `:class' or a keyword
+argument supported by the constructor of that class. The
+`transient-prefix' class is used if the class is not specified
+explicitly.
+
+GROUPs add key bindings for infix and suffix commands and specify
+how these bindings are presented in the popup buffer. At least
+one GROUP has to be specified. See info node `(transient)Binding
+Suffix and Infix Commands'.
+
+The BODY is optional. If it is omitted, then ARGLIST is also
+ignored and the function definition becomes:
+
+ (lambda ()
+ (interactive)
+ (transient-setup \\='NAME))
+
+If BODY is specified, then it must begin with an `interactive'
+form that matches ARGLIST, and it must call `transient-setup'.
+It may however call that function only when some condition is
+satisfied; that is one of the reason why you might want to use
+an explicit BODY.
+
+All transients have a (possibly nil) value, which is exported
+when suffix commands are called, so that they can consume that
+value. For some transients it might be necessary to have a sort
+of secondary value, called a scope. Such a scope would usually
+be set in the commands `interactive' form and has to be passed
+to the setup function:
+
+ (transient-setup \\='NAME nil nil :scope SCOPE)
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]
+ [&rest vectorp]
+ [&optional ("interactive" interactive) def-body]))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,suffixes ,docstr ,body)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name
+ ,(if body
+ `(lambda ,arglist ,@body)
+ `(lambda ()
+ (interactive)
+ (transient-setup ',name))))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--prefix
+ (,(or class 'transient-prefix) :command ',name ,@slots))
+ (put ',name 'transient--layout
+ ',(cl-mapcan (lambda (s) (transient--parse-child name s))
+ suffixes)))))
+
+(defmacro transient-define-suffix (name arglist &rest args)
+ "Define NAME as a transient suffix command.
+
+ARGLIST are the arguments that the command takes.
+DOCSTRING is the documentation string and is optional.
+
+These arguments can optionally be followed by key-value pairs.
+Each key has to be a keyword symbol, either `:class' or a
+keyword argument supported by the constructor of that class.
+The `transient-suffix' class is used if the class is not
+specified explicitly.
+
+The BODY must begin with an `interactive' form that matches
+ARGLIST. The infix arguments are usually accessed by using
+`transient-args' inside `interactive'.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]
+ ("interactive" interactive)
+ def-body))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,_ ,docstr ,body)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name (lambda ,arglist ,@body))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--suffix
+ (,(or class 'transient-suffix) :command ',name ,@slots)))))
+
+(defmacro transient-define-infix (name _arglist &rest args)
+ "Define NAME as a transient infix command.
+
+ARGLIST is always ignored and reserved for future use.
+DOCSTRING is the documentation string and is optional.
+
+The key-value pairs are mandatory. All transient infix commands
+are equal to each other (but not eq), so it is meaningless to
+define an infix command without also setting at least `:class'
+and one other keyword (which it is depends on the used class,
+usually `:argument' or `:variable').
+
+Each key has to be a keyword symbol, either `:class' or a keyword
+argument supported by the constructor of that class. The
+`transient-switch' class is used if the class is not specified
+explicitly.
+
+The function definitions is always:
+
+ (lambda ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
+
+`transient-infix-read' and `transient-infix-set' are generic
+functions. Different infix commands behave differently because
+the concrete methods are different for different infix command
+classes. In rare case the above command function might not be
+suitable, even if you define your own infix command class. In
+that case you have to use `transient-suffix-command' to define
+the infix command and use t as the value of the `:transient'
+keyword.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,_ ,docstr ,_)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name ,(transient--default-infix-command))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--suffix
+ (,(or class 'transient-switch) :command ',name ,@slots)))))
+
+(defalias 'transient-define-argument 'define-infix-command
+ "Define NAME as a transient infix command.
+
+Only use this alias to define an infix command that actually
+sets an infix argument. To define a infix command that, for
+example, sets a variable use `transient-define-infix' instead.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)")
+
+(defun transient--expand-define-args (args)
+ (let (class keys suffixes docstr)
+ (when (stringp (car args))
+ (setq docstr (pop args)))
+ (while (keywordp (car args))
+ (let ((k (pop args))
+ (v (pop args)))
+ (if (eq k :class)
+ (setq class v)
+ (push k keys)
+ (push v keys))))
+ (while (let ((arg (car args)))
+ (or (vectorp arg)
+ (and arg (symbolp arg))))
+ (push (pop args) suffixes))
+ (list (if (eq (car-safe class) 'quote)
+ (cadr class)
+ class)
+ (nreverse keys)
+ (nreverse suffixes)
+ docstr
+ args)))
+
+(defun transient--parse-child (prefix spec)
+ (cl-etypecase spec
+ (symbol (let ((value (symbol-value spec)))
+ (if (and (listp value)
+ (or (listp (car value))
+ (vectorp (car value))))
+ (cl-mapcan (lambda (s) (transient--parse-child prefix s)) value)
+ (transient--parse-child prefix value))))
+ (vector (when-let ((c (transient--parse-group prefix spec))) (list c)))
+ (list (when-let ((c (transient--parse-suffix prefix spec))) (list c)))
+ (string (list spec))))
+
+(defun transient--parse-group (prefix spec)
+ (setq spec (append spec nil))
+ (cl-symbol-macrolet
+ ((car (car spec))
+ (pop (pop spec)))
+ (let (level class args)
+ (when (integerp car)
+ (setq level pop))
+ (when (stringp car)
+ (setq args (plist-put args :description pop)))
+ (while (keywordp car)
+ (let ((k pop))
+ (if (eq k :class)
+ (setq class pop)
+ (setq args (plist-put args k pop)))))
+ (vector (or level transient--default-child-level)
+ (or class
+ (if (vectorp car)
+ 'transient-columns
+ 'transient-column))
+ args
+ (cl-mapcan (lambda (s) (transient--parse-child prefix s)) spec)))))
+
+(defun transient--parse-suffix (prefix spec)
+ (let (level class args)
+ (cl-symbol-macrolet
+ ((car (car spec))
+ (pop (pop spec)))
+ (when (integerp car)
+ (setq level pop))
+ (when (or (stringp car)
+ (vectorp car))
+ (setq args (plist-put args :key pop)))
+ (when (or (stringp car)
+ (eq (car-safe car) 'lambda)
+ (and (symbolp car)
+ (not (commandp car))
+ (commandp (cadr spec))))
+ (setq args (plist-put args :description pop)))
+ (cond
+ ((keywordp car)
+ (error "Need command, got %S" car))
+ ((symbolp car)
+ (setq args (plist-put args :command pop)))
+ ((and (commandp car)
+ (not (stringp car)))
+ (let ((cmd pop)
+ (sym (intern (format "transient:%s:%s"
+ prefix
+ (or (plist-get args :description)
+ (plist-get args :key))))))
+ (defalias sym cmd)
+ (setq args (plist-put args :command sym))))
+ ((or (stringp car)
+ (and car (listp car)))
+ (let ((arg pop))
+ (cl-typecase arg
+ (list
+ (setq args (plist-put args :shortarg (car arg)))
+ (setq args (plist-put args :argument (cadr arg)))
+ (setq arg (cadr arg)))
+ (string
+ (when-let ((shortarg (transient--derive-shortarg arg)))
+ (setq args (plist-put args :shortarg shortarg)))
+ (setq args (plist-put args :argument arg))))
+ (setq args (plist-put args :command
+ (intern (format "transient:%s:%s"
+ prefix arg))))
+ (cond ((and car (not (keywordp car)))
+ (setq class 'transient-option)
+ (setq args (plist-put args :reader pop)))
+ ((not (string-suffix-p "=" arg))
+ (setq class 'transient-switch))
+ (t
+ (setq class 'transient-option)))))
+ (t
+ (error "Needed command or argument, got %S" car)))
+ (while (keywordp car)
+ (let ((k pop))
+ (cl-case k
+ (:class (setq class pop))
+ (:level (setq level pop))
+ (t (setq args (plist-put args k pop)))))))
+ (unless (plist-get args :key)
+ (when-let ((shortarg (plist-get args :shortarg)))
+ (setq args (plist-put args :key shortarg))))
+ (list (or level transient--default-child-level)
+ (or class 'transient-suffix)
+ args)))
+
+(defun transient--default-infix-command ()
+ (cons 'lambda
+ '(()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))))
+
+(defun transient--ensure-infix-command (obj)
+ (let ((cmd (oref obj command)))
+ (unless (or (commandp cmd)
+ (get cmd 'transient--infix-command))
+ (if (or (cl-typep obj 'transient-switch)
+ (cl-typep obj 'transient-option))
+ (put cmd 'transient--infix-command
+ (transient--default-infix-command))
+ ;; This is not an anonymous infix argument.
+ (error "Suffix %s is not defined or autoloaded as a command" cmd)))))
+
+(defun transient--derive-shortarg (arg)
+ (save-match-data
+ (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg)
+ (match-string 1 arg))))
+
+;;; Edit
+
+(defun transient--insert-suffix (prefix loc suffix action)
+ (let* ((suf (cl-etypecase suffix
+ (vector (transient--parse-group prefix suffix))
+ (list (transient--parse-suffix prefix suffix))
+ (string suffix)))
+ (mem (transient--layout-member loc prefix))
+ (elt (car mem)))
+ (cond
+ ((not mem)
+ (message "Cannot insert %S into %s; %s not found"
+ suffix prefix loc))
+ ((or (and (vectorp suffix) (not (vectorp elt)))
+ (and (listp suffix) (vectorp elt))
+ (and (stringp suffix) (vectorp elt)))
+ (message "Cannot place %S into %s at %s; %s"
+ suffix prefix loc
+ "suffixes and groups cannot be siblings"))
+ (t
+ (when (and (listp suffix)
+ (listp elt))
+ ;; Both suffixes are key bindings; not heading strings.
+ (let ((key (transient--spec-key suf)))
+ (if (equal (transient--kbd key)
+ (transient--kbd (transient--spec-key elt)))
+ ;; We must keep `mem' until after we have inserted
+ ;; behind it, which `transient-remove-suffix' does
+ ;; not allow us to do.
+ (let ((spred (transient--suffix-predicate suf))
+ (epred (transient--suffix-predicate elt)))
+ ;; If both suffixes have a predicate and they
+ ;; are not identical, then there is a high
+ ;; probability that we want to keep both.
+ (when (or (not spred)
+ (not epred)
+ (equal spred epred))
+ (setq action 'replace)))
+ (transient-remove-suffix prefix key))))
+ (cl-ecase action
+ (insert (setcdr mem (cons elt (cdr mem)))
+ (setcar mem suf))
+ (append (setcdr mem (cons suf (cdr mem))))
+ (replace (setcar mem suf)))))))
+
+;;;###autoload
+(defun transient-insert-suffix (prefix loc suffix)
+ "Insert a SUFFIX into PREFIX before LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'insert))
+
+;;;###autoload
+(defun transient-append-suffix (prefix loc suffix)
+ "Insert a SUFFIX into PREFIX after LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'append))
+
+;;;###autoload
+(defun transient-replace-suffix (prefix loc suffix)
+ "Replace the suffix at LOC in PREFIX with SUFFIX.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'replace))
+
+;;;###autoload
+(defun transient-remove-suffix (prefix loc)
+ "Remove the suffix or group at LOC in PREFIX.
+PREFIX is a prefix command, a symbol.
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--layout-member loc prefix 'remove))
+
+(defun transient-get-suffix (prefix loc)
+ "Return the suffix or group at LOC in PREFIX.
+PREFIX is a prefix command, a symbol.
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (if-let ((mem (transient--layout-member loc prefix)))
+ (car mem)
+ (error "%s not found in %s" loc prefix)))
+
+(defun transient-suffix-put (prefix loc prop value)
+ "Edit the suffix at LOC in PREFIX, setting PROP to VALUE.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (let ((suf (transient-get-suffix prefix loc)))
+ (setf (elt suf 2)
+ (plist-put (elt suf 2) prop value))))
+
+(defun transient--layout-member (loc prefix &optional remove)
+ (let ((val (or (get prefix 'transient--layout)
+ (error "%s is not a transient command" prefix))))
+ (when (listp loc)
+ (while (integerp (car loc))
+ (let* ((children (if (vectorp val) (aref val 3) val))
+ (mem (transient--nthcdr (pop loc) children)))
+ (if (and remove (not loc))
+ (let ((rest (delq (car mem) children)))
+ (if (vectorp val)
+ (aset val 3 rest)
+ (put prefix 'transient--layout rest))
+ (setq val nil))
+ (setq val (if loc (car mem) mem)))))
+ (setq loc (car loc)))
+ (if loc
+ (transient--layout-member-1 (transient--kbd loc) val remove)
+ val)))
+
+(defun transient--layout-member-1 (loc layout remove)
+ (cond ((listp layout)
+ (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
+ layout))
+ ((vectorp (car (aref layout 3)))
+ (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
+ (aref layout 3)))
+ (remove
+ (aset layout 3
+ (delq (car (transient--group-member loc layout))
+ (aref layout 3)))
+ nil)
+ (t (transient--group-member loc layout))))
+
+(defun transient--group-member (loc group)
+ (cl-member-if (lambda (suffix)
+ (and (listp suffix)
+ (let* ((def (nth 2 suffix))
+ (cmd (plist-get def :command)))
+ (if (symbolp loc)
+ (eq cmd loc)
+ (equal (transient--kbd
+ (or (plist-get def :key)
+ (transient--command-key cmd)))
+ loc)))))
+ (aref group 3)))
+
+(defun transient--kbd (keys)
+ (when (vectorp keys)
+ (setq keys (key-description keys)))
+ (when (stringp keys)
+ (setq keys (kbd keys)))
+ keys)
+
+(defun transient--spec-key (spec)
+ (let ((plist (nth 2 spec)))
+ (or (plist-get plist :key)
+ (transient--command-key
+ (plist-get plist :command)))))
+
+(defun transient--command-key (cmd)
+ (when-let ((obj (get cmd 'transient--suffix)))
+ (cond ((slot-boundp obj 'key)
+ (oref obj key))
+ ((slot-exists-p obj 'shortarg)
+ (if (slot-boundp obj 'shortarg)
+ (oref obj shortarg)
+ (transient--derive-shortarg (oref obj argument)))))))
+
+(defun transient--nthcdr (n list)
+ (nthcdr (if (< n 0) (- (length list) (abs n)) n) list))
+
+;;; Variables
+
+(defvar transient-current-prefix nil
+ "The transient from which this suffix command was invoked.
+This is an object representing that transient, use
+`transient-current-command' to get the respective command.")
+
+(defvar transient-current-command nil
+ "The transient from which this suffix command was invoked.
+This is a symbol representing that transient, use
+`current-transient-object' to get the respective object.")
+
+(defvar transient-current-suffixes nil
+ "The suffixes of the transient from which this suffix command was invoked.
+This is a list of objects. Usually it is sufficient to instead
+use the function `transient-args', which returns a list of
+values. In complex cases it might be necessary to use this
+variable instead.")
+
+(defvar transient-exit-hook nil
+ "Hook run after exiting a transient.")
+
+(defvar transient--prefix nil)
+(defvar transient--layout nil)
+(defvar transient--suffixes nil)
+
+(defconst transient--stay t "Do not exit the transient.")
+(defconst transient--exit nil "Do exit the transient.")
+
+(defvar transient--exitp nil "Whether to exit the transient.")
+(defvar transient--showp nil "Whether the transient is show in a popup buffer.")
+(defvar transient--helpp nil "Whether help-mode is active.")
+(defvar transient--editp nil "Whether edit-mode is active.")
+
+(defvar transient--active-infix nil "The active infix awaiting user input.")
+
+(defvar transient--timer nil)
+
+(defvar transient--stack nil)
+
+(defvar transient--buffer-name " *transient*"
+ "Name of the transient buffer.")
+
+(defvar transient--window nil
+ "The window used to display the transient popup.")
+
+(defvar transient--original-window nil
+ "The window that was selected before the transient was invoked.
+Usually it remains selected while the transient is active.")
+
+(define-obsolete-variable-alias 'transient--source-buffer
+ 'transient--original-buffer "Transient 0.2.0")
+
+(defvar transient--original-buffer nil
+ "The buffer that was current before the transient was invoked.
+Usually it remains current while the transient is active.")
+
+(defvar transient--debug nil "Whether put debug information into *Messages*.")
+
+(defvar transient--history nil)
+
+(defvar transient--scroll-commands
+ '(transient-scroll-up
+ transient-scroll-down
+ mwheel-scroll
+ scroll-bar-toolkit-scroll))
+
+;;; Identities
+
+(defun transient-suffix-object (&optional command)
+ "Return the object associated with the current suffix command.
+
+Each suffix commands is associated with an object, which holds
+additional information about the suffix, such as its value (in
+the case of an infix command, which is a kind of suffix command).
+
+This function is intended to be called by infix commands, whose
+command definition usually (at least when defined using
+`transient-define-infix') is this:
+
+ (lambda ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
+
+\(User input is read outside of `interactive' to prevent the
+command from being added to `command-history'. See #23.)
+
+Such commands need to be able to access their associated object
+to guide how `transient-infix-read' reads the new value and to
+store the read value. Other suffix commands (including non-infix
+commands) may also need the object to guide their behavior.
+
+This function attempts to return the object associated with the
+current suffix command even if the suffix command was not invoked
+from a transient. (For some suffix command that is a valid thing
+to do, for others it is not.) In that case nil may be returned
+if the command was not defined using one of the macros intended
+to define such commands.
+
+The optional argument COMMAND is intended for internal use. If
+you are contemplating using it in your own code, then you should
+probably use this instead:
+
+ (get COMMAND 'transient--suffix)"
+ (when command
+ (cl-check-type command command))
+ (if (or transient--prefix
+ transient-current-prefix)
+ (cl-find-if (lambda (obj)
+ (eq (transient--suffix-command obj)
+ (or command this-original-command)))
+ (or transient--suffixes
+ transient-current-suffixes))
+ (when-let ((obj (get (or command this-command) 'transient--suffix))
+ (obj (clone obj)))
+ (transient-init-scope obj)
+ (transient-init-value obj)
+ obj)))
+
+(defun transient--suffix-command (object)
+ "Return the command represented by OBJECT.
+
+If the value of OBJECT's `command' slot is a command, then return
+that. Otherwise it is a symbol whose `transient--infix-command'
+property holds an anonymous command, which is returned instead."
+ (cl-check-type object transient-suffix)
+ (let ((sym (oref object command)))
+ (if (commandp sym)
+ sym
+ (get sym 'transient--infix-command))))
+
+(defun transient--suffix-symbol (arg)
+ "Return a symbol representing ARG.
+
+ARG must be a command and/or a symbol. If it is a symbol,
+then just return it. Otherwise return the symbol whose
+`transient--infix-command' property's value is ARG."
+ (or (cl-typep arg 'command)
+ (cl-typep arg 'symbol)
+ (signal 'wrong-type-argument `((command symbol) ,arg)))
+ (if (symbolp arg)
+ arg
+ (let* ((obj (transient-suffix-object))
+ (sym (oref obj command)))
+ (if (eq (get sym 'transient--infix-command) arg)
+ sym
+ (catch 'found
+ (mapatoms (lambda (sym)
+ (when (eq (get sym 'transient--infix-command) arg)
+ (throw 'found sym)))))))))
+
+;;; Keymaps
+
+(defvar transient-base-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "ESC ESC ESC") 'transient-quit-all)
+ (define-key map (kbd "C-g") 'transient-quit-one)
+ (define-key map (kbd "C-q") 'transient-quit-all)
+ (define-key map (kbd "C-z") 'transient-suspend)
+ (define-key map (kbd "C-v") 'transient-scroll-up)
+ (define-key map (kbd "C-M-v") 'transient-scroll-down)
+ (define-key map [next] 'transient-scroll-up)
+ (define-key map [prior] 'transient-scroll-down)
+ map)
+ "Parent of other keymaps used by Transient.
+
+This is the parent keymap of all the keymaps that are used in
+all transients: `transient-map' (which in turn is the parent
+of the transient-specific keymaps), `transient-edit-map' and
+`transient-sticky-map'.
+
+If you change a binding here, then you might also have to edit
+`transient-sticky-map' and `transient-common-commands'. While
+the latter isn't a proper transient prefix command, it can be
+edited using the same functions as used for transients.
+
+If you add a new command here, then you must also add a binding
+to `transient-predicate-map'.")
+
+(defvar transient-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "C-p") 'universal-argument)
+ (define-key map (kbd "C--") 'negative-argument)
+ (define-key map (kbd "C-t") 'transient-show)
+ (define-key map (kbd "?") 'transient-help)
+ (define-key map (kbd "C-h") 'transient-help)
+ ;; Also bound to "C-x p" and "C-x n" in transient-common-commands.
+ (define-key map (kbd "C-M-p") 'transient-history-prev)
+ (define-key map (kbd "C-M-n") 'transient-history-next)
+ map)
+ "Top-level keymap used by all transients.
+
+If you add a new command here, then you must also add a binding
+to `transient-predicate-map'. Also see `transient-base-map'.")
+
+(defvar transient-edit-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "?") 'transient-help)
+ (define-key map (kbd "C-h") 'transient-help)
+ (define-key map (kbd "C-x l") 'transient-set-level)
+ map)
+ "Keymap that is active while a transient in is in \"edit mode\".")
+
+(defvar transient-sticky-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "C-g") 'transient-quit-seq)
+ map)
+ "Keymap that is active while an incomplete key sequence is active.")
+
+(defvar transient--common-command-prefixes '(?\C-x))
+
+(put 'transient-common-commands
+ 'transient--layout
+ (cl-mapcan
+ (lambda (s) (transient--parse-child 'transient-common-commands s))
+ '([:hide (lambda ()
+ (and (not (memq (car transient--redisplay-key)
+ transient--common-command-prefixes))
+ (not transient-show-common-commands)))
+ ["Value commands"
+ ("C-x s " "Set" transient-set)
+ ("C-x C-s" "Save" transient-save)
+ ("C-x p " "Previous value" transient-history-prev)
+ ("C-x n " "Next value" transient-history-next)]
+ ["Sticky commands"
+ ;; Like `transient-sticky-map' except that
+ ;; "C-g" has to be bound to a different command.
+ ("C-g" "Quit prefix or transient" transient-quit-one)
+ ("C-q" "Quit transient stack" transient-quit-all)
+ ("C-z" "Suspend transient stack" transient-suspend)]
+ ["Customize"
+ ("C-x t" transient-toggle-common
+ :description (lambda ()
+ (if transient-show-common-commands
+ "Hide common commands"
+ "Show common permanently")))
+ ("C-x l" "Show/hide suffixes" transient-set-level)]])))
+
+(defvar transient-predicate-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [handle-switch-frame] 'transient--do-suspend)
+ (define-key map [transient-suspend] 'transient--do-suspend)
+ (define-key map [transient-help] 'transient--do-stay)
+ (define-key map [transient-set-level] 'transient--do-stay)
+ (define-key map [transient-history-prev] 'transient--do-stay)
+ (define-key map [transient-history-next] 'transient--do-stay)
+ (define-key map [universal-argument] 'transient--do-stay)
+ (define-key map [negative-argument] 'transient--do-stay)
+ (define-key map [digit-argument] 'transient--do-stay)
+ (define-key map [transient-quit-all] 'transient--do-quit-all)
+ (define-key map [transient-quit-one] 'transient--do-quit-one)
+ (define-key map [transient-quit-seq] 'transient--do-stay)
+ (define-key map [transient-show] 'transient--do-stay)
+ (define-key map [transient-update] 'transient--do-stay)
+ (define-key map [transient-toggle-common] 'transient--do-stay)
+ (define-key map [transient-set] 'transient--do-call)
+ (define-key map [transient-save] 'transient--do-call)
+ (define-key map [describe-key-briefly] 'transient--do-stay)
+ (define-key map [describe-key] 'transient--do-stay)
+ (define-key map [transient-scroll-up] 'transient--do-stay)
+ (define-key map [transient-scroll-down] 'transient--do-stay)
+ (define-key map [mwheel-scroll] 'transient--do-stay)
+ (define-key map [scroll-bar-toolkit-scroll] 'transient--do-stay)
+ (define-key map [transient-noop] 'transient--do-noop)
+ (define-key map [transient-mouse-push-button] 'transient--do-move)
+ (define-key map [transient-push-button] 'transient--do-move)
+ (define-key map [transient-backward-button] 'transient--do-move)
+ (define-key map [transient-forward-button] 'transient--do-move)
+ (define-key map [transient-isearch-backward] 'transient--do-move)
+ (define-key map [transient-isearch-forward] 'transient--do-move)
+ map)
+ "Base keymap used to map common commands to their transient behavior.
+
+The \"transient behavior\" of a command controls, among other
+things, whether invoking the command causes the transient to be
+exited or not and whether infix arguments are exported before
+doing so.
+
+Each \"key\" is a command that is common to all transients and
+that is bound in `transient-map', `transient-edit-map',
+`transient-sticky-map' and/or `transient-common-command'.
+
+Each binding is a \"pre-command\", a function that controls the
+transient behavior of the respective command.
+
+For transient commands that are bound in individual transients,
+the transient behavior is specified using the `:transient' slot
+of the corresponding object.")
+
+(defvar transient-popup-navigation-map)
+
+(defvar transient--transient-map nil)
+(defvar transient--predicate-map nil)
+(defvar transient--redisplay-map nil)
+(defvar transient--redisplay-key nil)
+
+(defun transient--push-keymap (map)
+ (transient--debug " push %s%s" map (if (symbol-value map) "" " VOID"))
+ (with-demoted-errors "transient--push-keymap: %S"
+ (internal-push-keymap (symbol-value map) 'overriding-terminal-local-map)))
+
+(defun transient--pop-keymap (map)
+ (transient--debug " pop %s%s" map (if (symbol-value map) "" " VOID"))
+ (with-demoted-errors "transient--pop-keymap: %S"
+ (internal-pop-keymap (symbol-value map) 'overriding-terminal-local-map)))
+
+(defun transient--make-transient-map ()
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (if transient--editp
+ transient-edit-map
+ transient-map))
+ (dolist (obj transient--suffixes)
+ (let ((key (oref obj key)))
+ (when (vectorp key)
+ (setq key (key-description key))
+ (oset obj key key))
+ (when transient-substitute-key-function
+ (setq key (save-match-data
+ (funcall transient-substitute-key-function obj)))
+ (oset obj key key))
+ (let ((kbd (kbd key))
+ (cmd (transient--suffix-command obj)))
+ (when-let ((conflict (and transient-detect-key-conflicts
+ (transient--lookup-key map kbd))))
+ (unless (eq cmd conflict)
+ (error "Cannot bind %S to %s and also %s"
+ (string-trim key)
+ cmd conflict)))
+ (define-key map kbd cmd))))
+ (when transient-enable-popup-navigation
+ (setq map
+ (make-composed-keymap (list map transient-popup-navigation-map))))
+ map))
+
+(defun transient--make-predicate-map ()
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-predicate-map)
+ (dolist (obj transient--suffixes)
+ (let* ((cmd (oref obj command))
+ (sub-prefix (and (symbolp cmd) (get cmd 'transient--prefix)))
+ (sym (transient--suffix-symbol cmd)))
+ (cond
+ ((oref obj inapt)
+ (define-key map (vector sym) 'transient--do-warn-inapt))
+ ((slot-boundp obj 'transient)
+ (define-key map (vector sym)
+ (let ((do (oref obj transient)))
+ (pcase do
+ (`t (if sub-prefix
+ 'transient--do-replace
+ 'transient--do-stay))
+ (`nil 'transient--do-exit)
+ (_ do)))))
+ ((not (lookup-key transient-predicate-map (vector sym)))
+ (define-key map (vector sym)
+ (if sub-prefix
+ 'transient--do-replace
+ (or (oref transient--prefix transient-suffix)
+ 'transient--do-exit)))))))
+ map))
+
+(defun transient--make-redisplay-map ()
+ (setq transient--redisplay-key
+ (cl-case this-command
+ (transient-update
+ (setq transient--showp t)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))))
+ (transient-quit-seq
+ (setq unread-command-events
+ (butlast (listify-key-sequence
+ (this-single-command-raw-keys))
+ 2))
+ (butlast transient--redisplay-key))
+ (t nil)))
+ (let ((topmap (make-sparse-keymap))
+ (submap (make-sparse-keymap)))
+ (when transient--redisplay-key
+ (define-key topmap (vconcat transient--redisplay-key) submap)
+ (set-keymap-parent submap transient-sticky-map))
+ (map-keymap-internal
+ (lambda (key def)
+ (when (and (not (eq key ?\e))
+ (listp def)
+ (keymapp def))
+ (define-key topmap (vconcat transient--redisplay-key (list key))
+ 'transient-update)))
+ (if transient--redisplay-key
+ (lookup-key transient--transient-map (vconcat transient--redisplay-key))
+ transient--transient-map))
+ topmap))
+
+;;; Setup
+
+(defun transient-setup (&optional name layout edit &rest params)
+ "Setup the transient specified by NAME.
+
+This function is called by transient prefix commands to setup the
+transient. In that case NAME is mandatory, LAYOUT and EDIT must
+be nil and PARAMS may be (but usually is not) used to set e.g. the
+\"scope\" of the transient (see `transient-define-prefix').
+
+This function is also called internally in which case LAYOUT and
+EDIT may be non-nil."
+ (transient--debug 'setup)
+ (when (> (minibuffer-depth) 0)
+ (user-error "Cannot invoke transient %s while minibuffer is active" name))
+ (transient--with-emergency-exit
+ (cond
+ ((not name)
+ ;; Switching between regular and edit mode.
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (setq name (oref transient--prefix command))
+ (setq params (list :scope (oref transient--prefix scope))))
+ (transient--transient-map
+ ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}"
+ ;; of an outer prefix. Unlike the usual `transient--do-replace',
+ ;; these predicates fail to clean up after the outer prefix.
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map))
+ ((not (or layout ; resuming parent/suspended prefix
+ transient-current-command)) ; entering child prefix
+ (transient--stack-zap)) ; replace suspended prefix, if any
+ (edit
+ ;; Returning from help to edit.
+ (setq transient--editp t)))
+ (transient--init-objects name layout params)
+ (transient--history-init transient--prefix)
+ (setq transient--predicate-map (transient--make-predicate-map))
+ (setq transient--transient-map (transient--make-transient-map))
+ (setq transient--redisplay-map (transient--make-redisplay-map))
+ (setq transient--original-window (selected-window))
+ (setq transient--original-buffer (current-buffer))
+ (transient--redisplay)
+ (transient--init-transient)
+ (transient--suspend-which-key-mode)))
+
+(cl-defgeneric transient-setup-children (group children)
+ "Setup the CHILDREN of GROUP.
+If the value of the `setup-children' slot is non-nil, then call
+that function with CHILDREN as the only argument and return the
+value. Otherwise return CHILDREN as is."
+ (if (slot-boundp group 'setup-children)
+ (funcall (oref group setup-children) children)
+ children))
+
+(defun transient--init-objects (name layout params)
+ (setq transient--prefix (transient--init-prefix name params))
+ (setq transient--layout (or layout (transient--init-suffixes name)))
+ (setq transient--suffixes (transient--flatten-suffixes transient--layout)))
+
+(defun transient--init-prefix (name &optional params)
+ (let ((obj (let ((proto (get name 'transient--prefix)))
+ (apply #'clone proto
+ :prototype proto
+ :level (or (alist-get t (alist-get name transient-levels))
+ transient-default-level)
+ params))))
+ (transient-init-value obj)
+ obj))
+
+(defun transient--init-suffixes (name)
+ (let ((levels (alist-get name transient-levels)))
+ (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (append (get name 'transient--layout)
+ (and (not transient--editp)
+ (get 'transient-common-commands
+ 'transient--layout))))))
+
+(defun transient--flatten-suffixes (layout)
+ (cl-labels ((s (def)
+ (cond
+ ((stringp def) nil)
+ ((listp def) (cl-mapcan #'s def))
+ ((transient-group--eieio-childp def)
+ (cl-mapcan #'s (oref def suffixes)))
+ ((transient-suffix--eieio-childp def)
+ (list def)))))
+ (cl-mapcan #'s layout)))
+
+(defun transient--init-child (levels spec)
+ (cl-etypecase spec
+ (vector (transient--init-group levels spec))
+ (list (transient--init-suffix levels spec))
+ (string (list spec))))
+
+(defun transient--init-group (levels spec)
+ (pcase-let ((`(,level ,class ,args ,children) (append spec nil)))
+ (when (transient--use-level-p level)
+ (let ((obj (apply class :level level args)))
+ (when (transient--use-suffix-p obj)
+ (when-let ((suffixes
+ (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (transient-setup-children obj children))))
+ (oset obj suffixes suffixes)
+ (list obj)))))))
+
+(defun transient--init-suffix (levels spec)
+ (pcase-let* ((`(,level ,class ,args) spec)
+ (cmd (plist-get args :command))
+ (level (or (alist-get (transient--suffix-symbol cmd) levels)
+ level)))
+ (let ((fn (and (symbolp cmd)
+ (symbol-function cmd))))
+ (when (autoloadp fn)
+ (transient--debug " autoload %s" cmd)
+ (autoload-do-load fn)))
+ (when (transient--use-level-p level)
+ (let ((obj (if-let ((proto (and cmd
+ (symbolp cmd)
+ (get cmd 'transient--suffix))))
+ (apply #'clone proto :level level args)
+ (apply class :level level args))))
+ (transient--init-suffix-key obj)
+ (transient--ensure-infix-command obj)
+ (when (transient--use-suffix-p obj)
+ (if (transient--inapt-suffix-p obj)
+ (oset obj inapt t)
+ (transient-init-scope obj)
+ (transient-init-value obj))
+ (list obj))))))
+
+(cl-defmethod transient--init-suffix-key ((obj transient-suffix))
+ (unless (slot-boundp obj 'key)
+ (error "No key for %s" (oref obj command))))
+
+(cl-defmethod transient--init-suffix-key ((obj transient-argument))
+ (if (transient-switches--eieio-childp obj)
+ (cl-call-next-method obj)
+ (unless (slot-boundp obj 'shortarg)
+ (when-let ((shortarg (transient--derive-shortarg (oref obj argument))))
+ (oset obj shortarg shortarg)))
+ (unless (slot-boundp obj 'key)
+ (if (slot-boundp obj 'shortarg)
+ (oset obj key (oref obj shortarg))
+ (error "No key for %s" (oref obj command))))))
+
+(defun transient--use-level-p (level &optional edit)
+ (or (and transient--editp (not edit))
+ (and (>= level 1)
+ (<= level (oref transient--prefix level)))))
+
+(defun transient--use-suffix-p (obj)
+ (transient--do-suffix-p
+ (oref obj if)
+ (oref obj if-not)
+ (oref obj if-nil)
+ (oref obj if-non-nil)
+ (oref obj if-mode)
+ (oref obj if-not-mode)
+ (oref obj if-derived)
+ (oref obj if-not-derived)
+ t))
+
+(defun transient--inapt-suffix-p (obj)
+ (transient--do-suffix-p
+ (oref obj inapt-if)
+ (oref obj inapt-if-not)
+ (oref obj inapt-if-nil)
+ (oref obj inapt-if-non-nil)
+ (oref obj inapt-if-mode)
+ (oref obj inapt-if-not-mode)
+ (oref obj inapt-if-derived)
+ (oref obj inapt-if-not-derived)
+ nil))
+
+(defun transient--do-suffix-p
+ (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived
+ default)
+ (cond
+ (if (funcall if))
+ (if-not (not (funcall if-not)))
+ (if-non-nil (symbol-value if-non-nil))
+ (if-nil (not (symbol-value if-nil)))
+ (if-mode (if (atom if-mode)
+ (eq major-mode if-mode)
+ (memq major-mode if-mode)))
+ (if-not-mode (not (if (atom if-not-mode)
+ (eq major-mode if-not-mode)
+ (memq major-mode if-not-mode))))
+ (if-derived (if (atom if-derived)
+ (derived-mode-p if-derived)
+ (apply #'derived-mode-p if-derived)))
+ (if-not-derived (not (if (atom if-not-derived)
+ (derived-mode-p if-not-derived)
+ (apply #'derived-mode-p if-not-derived))))
+ (t default)))
+
+(defun transient--suffix-predicate (spec)
+ (let ((plist (nth 2 spec)))
+ (seq-some (lambda (prop)
+ (when-let ((pred (plist-get plist prop)))
+ (list prop pred)))
+ '( :if :if-not
+ :if-nil :if-non-nil
+ :if-mode :if-not-mode
+ :if-derived :if-not-derived
+ :inapt-if :inapt-if-not
+ :inapt-if-nil :inapt-if-non-nil
+ :inapt-if-mode :inapt-if-not-mode
+ :inapt-if-derived :inapt-if-not-derived))))
+
+;;; Flow-Control
+
+(defun transient--init-transient ()
+ (transient--debug 'init-transient)
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command)
+ (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (add-hook 'post-command-hook #'transient--post-command)
+ (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit)
+ (when transient--exitp
+ ;; This prefix command was invoked as the suffix of another.
+ ;; Prevent `transient--post-command' from removing the hooks
+ ;; that we just added.
+ (setq transient--exitp 'replace)))
+
+(defun transient--pre-command ()
+ (transient--debug 'pre-command)
+ (cond
+ ((memq this-command '(transient-update transient-quit-seq))
+ (transient--pop-keymap 'transient--redisplay-map))
+ ((and transient--helpp
+ (not (memq this-command '(transient-quit-one
+ transient-quit-all))))
+ (cond
+ ((transient-help)
+ (transient--do-suspend)
+ (setq this-command 'transient-suspend)
+ (transient--pre-exit))
+ ((not (transient--edebug-command-p))
+ (setq this-command 'transient-undefined))))
+ ((and transient--editp
+ (transient-suffix-object)
+ (not (memq this-command '(transient-quit-one
+ transient-quit-all
+ transient-help))))
+ (setq this-command 'transient-set-level))
+ (t
+ (setq transient--exitp nil)
+ (when (eq (if-let ((fn (transient--get-predicate-for
+ this-original-command)))
+ (let ((action (funcall fn)))
+ (when (eq action transient--exit)
+ (setq transient--exitp (or transient--exitp t)))
+ action)
+ (if (let ((keys (this-command-keys-vector)))
+ (eq (aref keys (1- (length keys))) ?\C-g))
+ (setq this-command 'transient-noop)
+ (unless (transient--edebug-command-p)
+ (setq this-command 'transient-undefined)))
+ transient--stay)
+ transient--exit)
+ (transient--pre-exit)))))
+
+(defun transient--get-predicate-for (cmd)
+ (or (lookup-key transient--predicate-map
+ (vector (transient--suffix-symbol cmd)))
+ (oref transient--prefix transient-non-suffix)))
+
+(defun transient--pre-exit ()
+ (transient--debug 'pre-exit)
+ (transient--delete-window)
+ (transient--timer-cancel)
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command)
+ (unless transient--showp
+ (let ((message-log-max nil))
+ (message "")))
+ (setq transient--transient-map nil)
+ (setq transient--predicate-map nil)
+ (setq transient--redisplay-map nil)
+ (setq transient--redisplay-key nil)
+ (setq transient--showp nil)
+ (setq transient--helpp nil)
+ (setq transient--editp nil)
+ (setq transient--prefix nil)
+ (setq transient--layout nil)
+ (setq transient--suffixes nil)
+ (setq transient--original-window nil)
+ (setq transient--original-buffer nil)
+ (setq transient--window nil))
+
+(defun transient--delete-window ()
+ (when (window-live-p transient--window)
+ (let ((buf (window-buffer transient--window)))
+ (with-demoted-errors "Error while exiting transient: %S"
+ (delete-window transient--window))
+ (kill-buffer buf))))
+
+(defun transient--export ()
+ (setq transient-current-prefix transient--prefix)
+ (setq transient-current-command (oref transient--prefix command))
+ (setq transient-current-suffixes transient--suffixes)
+ (transient--history-push transient--prefix))
+
+(defun transient--minibuffer-setup ()
+ (transient--debug 'minibuffer-setup)
+ (unless (> (minibuffer-depth) 1)
+ (unless transient--exitp
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command))
+ (remove-hook 'post-command-hook #'transient--post-command)))
+
+(defun transient--minibuffer-exit ()
+ (transient--debug 'minibuffer-exit)
+ (unless (> (minibuffer-depth) 1)
+ (unless transient--exitp
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command))
+ (add-hook 'post-command-hook #'transient--post-command)))
+
+(defun transient--suspend-override (&optional minibuffer-hooks)
+ (transient--debug 'suspend-override)
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command)
+ (remove-hook 'post-command-hook #'transient--post-command)
+ (when minibuffer-hooks
+ (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit)))
+
+(defun transient--resume-override (&optional minibuffer-hooks)
+ (transient--debug 'resume-override)
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command)
+ (add-hook 'post-command-hook #'transient--post-command)
+ (when minibuffer-hooks
+ (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit)))
+
+(defun transient--post-command ()
+ (transient--debug 'post-command)
+ (unless this-command
+ (transient--debug "-- force pre-exit from post-command")
+ (message "Quit transient!")
+ (transient--pre-exit)
+ (setq transient--exitp t))
+ (if transient--exitp
+ (progn
+ (unless (and (eq transient--exitp 'replace)
+ (or transient--prefix
+ ;; The current command could act as a prefix,
+ ;; but decided not to call `transient-setup'.
+ (prog1 nil (transient--stack-zap))))
+ (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit)
+ (remove-hook 'post-command-hook #'transient--post-command))
+ (setq transient-current-prefix nil)
+ (setq transient-current-command nil)
+ (setq transient-current-suffixes nil)
+ (let ((resume (and transient--stack
+ (not (memq transient--exitp '(replace suspend))))))
+ (setq transient--exitp nil)
+ (setq transient--helpp nil)
+ (setq transient--editp nil)
+ (run-hooks 'transient-exit-hook)
+ (when resume
+ (transient--stack-pop))))
+ (transient--pop-keymap 'transient--redisplay-map)
+ (setq transient--redisplay-map (transient--make-redisplay-map))
+ (transient--push-keymap 'transient--redisplay-map)
+ (unless (eq this-command (oref transient--prefix command))
+ (transient--redisplay))))
+
+(defun transient--stack-push ()
+ (transient--debug 'stack-push)
+ (push (list (oref transient--prefix command)
+ transient--layout
+ transient--editp
+ :scope (oref transient--prefix scope))
+ transient--stack))
+
+(defun transient--stack-pop ()
+ (transient--debug 'stack-pop)
+ (and transient--stack
+ (prog1 t (apply #'transient-setup (pop transient--stack)))))
+
+(defun transient--stack-zap ()
+ (transient--debug 'stack-zap)
+ (setq transient--stack nil))
+
+(defun transient--redisplay ()
+ (if (or (eq transient-show-popup t)
+ transient--showp)
+ (unless (memq this-command transient--scroll-commands)
+ (transient--show))
+ (when (and (numberp transient-show-popup)
+ (not (zerop transient-show-popup))
+ (not transient--timer))
+ (transient--timer-start))
+ (transient--show-brief)))
+
+(defun transient--timer-start ()
+ (setq transient--timer
+ (run-at-time (abs transient-show-popup) nil
+ (lambda ()
+ (transient--timer-cancel)
+ (transient--show)
+ (let ((message-log-max nil))
+ (message ""))))))
+
+(defun transient--timer-cancel ()
+ (when transient--timer
+ (cancel-timer transient--timer)
+ (setq transient--timer nil)))
+
+(defun transient--debug (arg &rest args)
+ (when transient--debug
+ (if (symbolp arg)
+ (message "-- %-16s (cmd: %s, event: %S, exit: %s)"
+ arg
+ (or (transient--suffix-symbol this-command)
+ (list this-command this-original-command last-command))
+ (key-description (this-command-keys-vector))
+ transient--exitp)
+ (apply #'message arg args))))
+
+(defun transient--emergency-exit ()
+ "Exit the current transient command after an error occurred.
+When no transient is active (i.e. when `transient--prefix') is
+nil, then do nothing."
+ (transient--debug 'emergency-exit)
+ (when transient--prefix
+ (setq transient--stack nil)
+ (setq transient--exitp t)
+ (transient--pre-exit)
+ (transient--post-command)))
+
+;;; Pre-Commands
+
+(defun transient--do-stay ()
+ "Call the command without exporting variables and stay transient."
+ transient--stay)
+
+(defun transient--do-noop ()
+ "Call `transient-noop' and stay transient."
+ (setq this-command 'transient-noop)
+ transient--stay)
+
+(defun transient--do-warn ()
+ "Call `transient-undefined' and stay transient."
+ (setq this-command 'transient-undefined)
+ transient--stay)
+
+(defun transient--do-warn-inapt ()
+ "Call `transient-inapt' and stay transient."
+ (setq this-command 'transient-inapt)
+ transient--stay)
+
+(defun transient--do-call ()
+ "Call the command after exporting variables and stay transient."
+ (transient--export)
+ transient--stay)
+
+(defun transient--do-exit ()
+ "Call the command after exporting variables and exit the transient."
+ (transient--export)
+ (transient--stack-zap)
+ transient--exit)
+
+(defun transient--do-replace ()
+ "Call the transient prefix command, replacing the active transient."
+ (transient--export)
+ (transient--stack-push)
+ (setq transient--exitp 'replace)
+ transient--exit)
+
+(defun transient--do-suspend ()
+ "Suspend the active transient, saving the transient stack."
+ (transient--stack-push)
+ (setq transient--exitp 'suspend)
+ transient--exit)
+
+(defun transient--do-quit-one ()
+ "If active, quit help or edit mode, else exit the active transient."
+ (cond (transient--helpp
+ (setq transient--helpp nil)
+ transient--stay)
+ (transient--editp
+ (setq transient--editp nil)
+ (transient-setup)
+ transient--stay)
+ (t transient--exit)))
+
+(defun transient--do-quit-all ()
+ "Exit all transients without saving the transient stack."
+ (transient--stack-zap)
+ transient--exit)
+
+(defun transient--do-move ()
+ "Call the command if `transient-enable-popup-navigation' is non-nil.
+In that case behave like `transient--do-stay', otherwise similar
+to `transient--do-warn'."
+ (unless transient-enable-popup-navigation
+ (setq this-command 'transient-popup-navigation-help))
+ transient--stay)
+
+(put 'transient--do-stay 'transient-color 'transient-blue)
+(put 'transient--do-noop 'transient-color 'transient-blue)
+(put 'transient--do-warn 'transient-color 'transient-blue)
+(put 'transient--do-warn-inapt 'transient-color 'transient-blue)
+(put 'transient--do-call 'transient-color 'transient-blue)
+(put 'transient--do-exit 'transient-color 'transient-red)
+(put 'transient--do-replace 'transient-color 'transient-red)
+(put 'transient--do-suspend 'transient-color 'transient-red)
+(put 'transient--do-quit-one 'transient-color 'transient-red)
+(put 'transient--do-quit-all 'transient-color 'transient-red)
+(put 'transient--do-move 'transient-color 'transient-blue)
+
+;;; Commands
+
+(defun transient-noop ()
+ "Do nothing at all."
+ (interactive))
+
+(defun transient-undefined ()
+ "Warn the user that the pressed key is not bound to any suffix."
+ (interactive)
+ (transient--invalid "Unbound suffix"))
+
+(defun transient-inapt ()
+ "Warn the user that the invoked command is inapt."
+ (interactive)
+ (transient--invalid "Inapt command"))
+
+(defun transient--invalid (msg)
+ (ding)
+ (message "%s: `%s' (Use `%s' to abort, `%s' for help) [%s]"
+ msg
+ (propertize (key-description (this-single-command-keys))
+ 'face 'font-lock-warning-face)
+ (propertize "C-g" 'face 'transient-key)
+ (propertize "?" 'face 'transient-key)
+ (propertize (symbol-name (transient--suffix-symbol
+ this-original-command))
+ 'face 'font-lock-warning-face)))
+
+(defun transient-toggle-common ()
+ "Toggle whether common commands are always shown."
+ (interactive)
+ (setq transient-show-common-commands (not transient-show-common-commands)))
+
+(defun transient-suspend ()
+ "Suspend the current transient.
+It can later be resumed using `transient-resume' while no other
+transient is active."
+ (interactive))
+
+(defun transient-quit-all ()
+ "Exit all transients without saving the transient stack."
+ (interactive))
+
+(defun transient-quit-one ()
+ "Exit the current transients, possibly returning to the previous."
+ (interactive))
+
+(defun transient-quit-seq ()
+ "Abort the current incomplete key sequence."
+ (interactive))
+
+(defun transient-update ()
+ "Redraw the transient's state in the popup buffer."
+ (interactive))
+
+(defun transient-show ()
+ "Show the transient's state in the popup buffer."
+ (interactive)
+ (setq transient--showp t))
+
+(defvar-local transient--restore-winconf nil)
+
+(defvar transient-resume-mode)
+
+(defun transient-help ()
+ "Show help for the active transient or one of its suffixes."
+ (interactive)
+ (if (called-interactively-p 'any)
+ (setq transient--helpp t)
+ (with-demoted-errors "transient-help: %S"
+ (when (lookup-key transient--transient-map
+ (this-single-command-raw-keys))
+ (setq transient--helpp nil)
+ (let ((winconf (current-window-configuration)))
+ (transient-show-help
+ (if (eq this-original-command 'transient-help)
+ transient--prefix
+ (or (transient-suffix-object)
+ this-original-command)))
+ (setq transient--restore-winconf winconf))
+ (fit-window-to-buffer nil (frame-height) (window-height))
+ (transient-resume-mode)
+ (message "Type \"q\" to resume transient command.")
+ t))))
+
+(defun transient-set-level (&optional command level)
+ "Set the level of the transient or one of its suffix commands."
+ (interactive
+ (let ((command this-original-command)
+ (prefix (oref transient--prefix command)))
+ (and (or (not (eq command 'transient-set-level))
+ (and transient--editp
+ (setq command prefix)))
+ (list command
+ (let ((keys (this-single-command-raw-keys)))
+ (and (lookup-key transient--transient-map keys)
+ (string-to-number
+ (let ((transient--active-infix
+ (transient-suffix-object command)))
+ (transient--show)
+ (transient--read-number-N
+ (format "Set level for `%s': "
+ (transient--suffix-symbol command))
+ nil nil (not (eq command prefix)))))))))))
+ (cond
+ ((not command)
+ (setq transient--editp t)
+ (transient-setup))
+ (level
+ (let* ((prefix (oref transient--prefix command))
+ (alist (alist-get prefix transient-levels))
+ (sym (transient--suffix-symbol command)))
+ (if (eq command prefix)
+ (progn (oset transient--prefix level level)
+ (setq sym t))
+ (oset (transient-suffix-object command) level level))
+ (setf (alist-get sym alist) level)
+ (setf (alist-get prefix transient-levels) alist))
+ (transient-save-levels))
+ (t
+ (transient-undefined))))
+
+(defun transient-set ()
+ "Save the value of the active transient for this Emacs session."
+ (interactive)
+ (transient-set-value (or transient--prefix transient-current-prefix)))
+
+(defun transient-save ()
+ "Save the value of the active transient persistenly across Emacs sessions."
+ (interactive)
+ (transient-save-value (or transient--prefix transient-current-prefix)))
+
+(defun transient-history-next ()
+ "Switch to the next value used for the active transient."
+ (interactive)
+ (let* ((obj transient--prefix)
+ (pos (1- (oref obj history-pos)))
+ (hst (oref obj history)))
+ (if (< pos 0)
+ (user-error "End of history")
+ (oset obj history-pos pos)
+ (oset obj value (nth pos hst))
+ (mapc #'transient-init-value transient--suffixes))))
+
+(defun transient-history-prev ()
+ "Switch to the previous value used for the active transient."
+ (interactive)
+ (let* ((obj transient--prefix)
+ (pos (1+ (oref obj history-pos)))
+ (hst (oref obj history))
+ (len (length hst)))
+ (if (> pos (1- len))
+ (user-error "End of history")
+ (oset obj history-pos pos)
+ (oset obj value (nth pos hst))
+ (mapc #'transient-init-value transient--suffixes))))
+
+(defun transient-scroll-up (&optional arg)
+ "Scroll text of transient popup window upward ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-up-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-up-command arg)))
+
+(defun transient-scroll-down (&optional arg)
+ "Scroll text of transient popup window down ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-down-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-down-command arg)))
+
+(defun transient-resume ()
+ "Resume a previously suspended stack of transients."
+ (interactive)
+ (cond (transient--stack
+ (let ((winconf transient--restore-winconf))
+ (kill-local-variable 'transient--restore-winconf)
+ (when transient-resume-mode
+ (transient-resume-mode -1)
+ (quit-window))
+ (when winconf
+ (set-window-configuration winconf)))
+ (transient--stack-pop))
+ (transient-resume-mode
+ (kill-local-variable 'transient--restore-winconf)
+ (transient-resume-mode -1)
+ (quit-window))
+ (t
+ (message "No suspended transient command"))))
+
+;;; Value
+;;;; Init
+
+(cl-defgeneric transient-init-scope (obj)
+ "Set the scope of the suffix object OBJ.
+
+The scope is actually a property of the transient prefix, not of
+individual suffixes. However it is possible to invoke a suffix
+command directly instead of from a transient. In that case, if
+the suffix expects a scope, then it has to determine that itself
+and store it in its `scope' slot.
+
+This function is called for all suffix commands, but unless a
+concrete method is implemented this falls through to the default
+implementation, which is a noop.")
+
+(cl-defmethod transient-init-scope ((_ transient-suffix))
+ "Noop." nil)
+
+(cl-defgeneric transient-init-value (_)
+ "Set the initial value of the object OBJ.
+
+This function is called for all prefix and suffix commands.
+
+For suffix commands (including infix argument commands) the
+default implementation is a noop. Classes derived from the
+abstract `transient-infix' class must implement this function.
+Non-infix suffix commands usually don't have a value."
+ nil)
+
+(cl-defmethod transient-init-value :around ((obj transient-prefix))
+ "If bound, then call OBJ's `init-value' function.
+Otherwise call the primary method according to objects class."
+ (if (slot-boundp obj 'init-value)
+ (funcall (oref obj init-value) obj)
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-init-value :around ((obj transient-infix))
+ "If bound, then call OBJ's `init-value' function.
+Otherwise call the primary method according to objects class."
+ (if (slot-boundp obj 'init-value)
+ (funcall (oref obj init-value) obj)
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-init-value ((obj transient-prefix))
+ (if (slot-boundp obj 'value)
+ (oref obj value)
+ (oset obj value
+ (if-let ((saved (assq (oref obj command) transient-values)))
+ (cdr saved)
+ (if-let ((default (and (slot-boundp obj 'default-value)
+ (oref obj default-value))))
+ (if (functionp default)
+ (funcall default)
+ default)
+ nil)))))
+
+(cl-defmethod transient-init-value ((obj transient-switch))
+ (oset obj value
+ (car (member (oref obj argument)
+ (oref transient--prefix value)))))
+
+(cl-defmethod transient-init-value ((obj transient-option))
+ (oset obj value
+ (transient--value-match (format "\\`%s\\(.*\\)" (oref obj argument)))))
+
+(cl-defmethod transient-init-value ((obj transient-switches))
+ (oset obj value
+ (transient--value-match (oref obj argument-regexp))))
+
+(defun transient--value-match (re)
+ (when-let ((match (cl-find-if (lambda (v)
+ (and (stringp v)
+ (string-match re v)))
+ (oref transient--prefix value))))
+ (match-string 1 match)))
+
+(cl-defmethod transient-init-value ((obj transient-files))
+ (oset obj value
+ (cdr (assoc "--" (oref transient--prefix value)))))
+
+;;;; Read
+
+(cl-defgeneric transient-infix-read (obj)
+ "Determine the new value of the infix object OBJ.
+
+This function merely determines the value; `transient-infix-set'
+is used to actually store the new value in the object.
+
+For most infix classes this is done by reading a value from the
+user using the reader specified by the `reader' slot (using the
+`transient-infix' method described below).
+
+For some infix classes the value is changed without reading
+anything in the minibuffer, i.e. the mere act of invoking the
+infix command determines what the new value should be, based
+on the previous value.")
+
+(cl-defmethod transient-infix-read :around ((obj transient-infix))
+ "Highlight the infix in the popup buffer.
+
+Also arrange for the transient to be exited in case of an error
+because otherwise Emacs would get stuck in an inconsistent state,
+which might make it necessary to kill it from the outside."
+ (let ((transient--active-infix obj))
+ (transient--show))
+ (transient--with-emergency-exit
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-infix-read ((obj transient-infix))
+ "Read a value while taking care of history.
+
+This method is suitable for a wide variety of infix commands,
+including but not limited to inline arguments and variables.
+
+If you do not use this method for your own infix class, then
+you should likely replicate a lot of the behavior of this
+method. If you fail to do so, then users might not appreciate
+the lack of history, for example.
+
+Only for very simple classes that toggle or cycle through a very
+limited number of possible values should you replace this with a
+simple method that does not handle history. (E.g. for a command
+line switch the only possible values are \"use it\" and \"don't use
+it\", in which case it is pointless to preserve history.)"
+ (with-slots (value multi-value always-read allow-empty choices) obj
+ (if (and value
+ (not multi-value)
+ (not always-read)
+ transient--prefix)
+ (oset obj value nil)
+ (let* ((overriding-terminal-local-map nil)
+ (reader (oref obj reader))
+ (prompt (transient-prompt obj))
+ (value (if multi-value (mapconcat #'identity value ",") value))
+ (history-key (or (oref obj history-key)
+ (oref obj command)))
+ (transient--history (alist-get history-key transient-history))
+ (transient--history (if (or (null value)
+ (eq value (car transient--history)))
+ transient--history
+ (cons value transient--history)))
+ (initial-input (and transient-read-with-initial-input
+ (car transient--history)))
+ (history (if initial-input
+ (cons 'transient--history 1)
+ 'transient--history))
+ (value
+ (cond
+ (reader (funcall reader prompt initial-input history))
+ (multi-value
+ (completing-read-multiple prompt choices nil nil
+ initial-input history))
+ (choices
+ (completing-read prompt choices nil t initial-input history))
+ (t (read-string prompt initial-input history)))))
+ (cond ((and (equal value "") (not allow-empty))
+ (setq value nil))
+ ((and (equal value "\"\"") allow-empty)
+ (setq value "")))
+ (when value
+ (when (and (bound-and-true-p ivy-mode)
+ (stringp (car transient--history)))
+ (set-text-properties 0 (length (car transient--history)) nil
+ (car transient--history)))
+ (setf (alist-get history-key transient-history)
+ (delete-dups transient--history)))
+ value))))
+
+(cl-defmethod transient-infix-read ((obj transient-switch))
+ "Toggle the switch on or off."
+ (if (oref obj value) nil (oref obj argument)))
+
+(cl-defmethod transient-infix-read ((obj transient-switches))
+ "Cycle through the mutually exclusive switches.
+The last value is \"don't use any of these switches\"."
+ (let ((choices (mapcar (apply-partially #'format (oref obj argument-format))
+ (oref obj choices))))
+ (if-let ((value (oref obj value)))
+ (cadr (member value choices))
+ (car choices))))
+
+(cl-defmethod transient-infix-read ((command symbol))
+ "Elsewhere use the reader of the infix command COMMAND.
+Use this if you want to share an infix's history with a regular
+stand-alone command."
+ (cl-letf (((symbol-function #'transient--show) #'ignore))
+ (transient-infix-read (get command 'transient--suffix))))
+
+;;;; Readers
+
+(defun transient-read-file (prompt _initial-input _history)
+ "Read a file."
+ (file-local-name (expand-file-name (read-file-name prompt))))
+
+(defun transient-read-existing-file (prompt _initial-input _history)
+ "Read an existing file."
+ (file-local-name (expand-file-name (read-file-name prompt nil nil t))))
+
+(defun transient-read-directory (prompt _initial-input _history)
+ "Read a directory."
+ (file-local-name (expand-file-name (read-directory-name prompt))))
+
+(defun transient-read-existing-directory (prompt _initial-input _history)
+ "Read an existing directory."
+ (file-local-name (expand-file-name (read-directory-name prompt nil nil t))))
+
+(defun transient-read-number-N0 (prompt initial-input history)
+ "Read a natural number (including zero) and return it as a string."
+ (transient--read-number-N prompt initial-input history t))
+
+(defun transient-read-number-N+ (prompt initial-input history)
+ "Read a natural number (excluding zero) and return it as a string."
+ (transient--read-number-N prompt initial-input history nil))
+
+(defun transient--read-number-N (prompt initial-input history include-zero)
+ (save-match-data
+ (cl-block nil
+ (while t
+ (let ((str (read-from-minibuffer prompt initial-input nil nil history)))
+ (cond ((string-equal str "")
+ (cl-return nil))
+ ((string-match-p (if include-zero
+ "\\`\\(0\\|[1-9][0-9]*\\)\\'"
+ "\\`[1-9][0-9]*\\'")
+ str)
+ (cl-return str))))
+ (message "Please enter a natural number (%s zero)."
+ (if include-zero "including" "excluding"))
+ (sit-for 1)))))
+
+(defun transient-read-date (prompt default-time _history)
+ "Read a date using `org-read-date' (which see)."
+ (require 'org)
+ (when (fboundp 'org-read-date)
+ (org-read-date 'with-time nil nil prompt default-time)))
+
+;;;; Prompt
+
+(cl-defgeneric transient-prompt (obj)
+ "Return the prompt to be used to read infix object OBJ's value.")
+
+(cl-defmethod transient-prompt ((obj transient-infix))
+ "Return the prompt to be used to read infix object OBJ's value.
+
+This implementation should be suitable for almost all infix
+commands.
+
+If the value of OBJ's `prompt' slot is non-nil, then it must be
+a string or a function. If it is a string, then use that. If
+it is a function, then call that with OBJ as the only argument.
+That function must return a string, which is then used as the
+prompt.
+
+Otherwise, if the value of either the `argument' or `variable'
+slot of OBJ is a string, then base the prompt on that (preferring
+the former), appending either \"=\" (if it appears to be a
+command-line option) or \": \".
+
+Finally fall through to using \"(BUG: no prompt): \" as the
+prompt."
+ (if-let ((prompt (oref obj prompt)))
+ (let ((prompt (if (functionp prompt)
+ (funcall prompt obj)
+ prompt)))
+ (if (stringp prompt)
+ prompt
+ "(BUG: no prompt): "))
+ (or (when-let ((arg (and (slot-boundp obj 'argument) (oref obj argument))))
+ (if (and (stringp arg) (string-suffix-p "=" arg))
+ arg
+ (concat arg ": ")))
+ (when-let ((var (and (slot-boundp obj 'variable) (oref obj variable))))
+ (and (stringp var)
+ (concat var ": ")))
+ "(BUG: no prompt): ")))
+
+;;;; Set
+
+(defvar transient--unset-incompatible t)
+
+(cl-defgeneric transient-infix-set (obj value)
+ "Set the value of infix object OBJ to value.")
+
+(cl-defmethod transient-infix-set ((obj transient-infix) value)
+ "Set the value of infix object OBJ to value."
+ (oset obj value value))
+
+(cl-defmethod transient-infix-set :around ((obj transient-argument) value)
+ "Unset incompatible infix arguments."
+ (let ((arg (if (slot-boundp obj 'argument)
+ (oref obj argument)
+ (oref obj argument-regexp))))
+ (if-let ((sic (and value arg transient--unset-incompatible))
+ (spec (oref transient--prefix incompatible))
+ (incomp (remove arg (cl-find-if (lambda (elt) (member arg elt)) spec))))
+ (progn
+ (cl-call-next-method obj value)
+ (dolist (arg incomp)
+ (when-let ((obj (cl-find-if (lambda (obj)
+ (and (slot-boundp obj 'argument)
+ (equal (oref obj argument) arg)))
+ transient--suffixes)))
+ (let ((transient--unset-incompatible nil))
+ (transient-infix-set obj nil)))))
+ (cl-call-next-method obj value))))
+
+(cl-defmethod transient-set-value ((obj transient-prefix))
+ (oset (oref obj prototype) value (transient-get-value))
+ (transient--history-push obj))
+
+;;;; Save
+
+(cl-defmethod transient-save-value ((obj transient-prefix))
+ (let ((value (transient-get-value)))
+ (oset (oref obj prototype) value value)
+ (setf (alist-get (oref obj command) transient-values) value)
+ (transient-save-values))
+ (transient--history-push obj))
+
+;;;; Get
+
+(defun transient-args (prefix)
+ "Return the value of the transient prefix command PREFIX.
+If the current command was invoked from the transient prefix
+command PREFIX, then return the active infix arguments. If
+the current command was not invoked from PREFIX, then return
+the set, saved or default value for PREFIX."
+ (delq nil (mapcar 'transient-infix-value (transient-suffixes prefix))))
+
+(defun transient-suffixes (prefix)
+ "Return the suffix objects of the transient prefix command PREFIX."
+ (if (eq transient-current-command prefix)
+ transient-current-suffixes
+ (let ((transient--prefix (transient--init-prefix prefix)))
+ (transient--flatten-suffixes
+ (transient--init-suffixes prefix)))))
+
+(defun transient-get-value ()
+ (delq nil (mapcar (lambda (obj)
+ (and (or (not (slot-exists-p obj 'unsavable))
+ (not (oref obj unsavable)))
+ (transient-infix-value obj)))
+ transient-current-suffixes)))
+
+(cl-defgeneric transient-infix-value (obj)
+ "Return the value of the suffix object OBJ.
+
+This function is called by `transient-args' (which see), meaning
+this function is how the value of a transient is determined so
+that the invoked suffix command can use it.
+
+Currently most values are strings, but that is not set in stone.
+Nil is not a value, it means \"no value\".
+
+Usually only infixes have a value, but see the method for
+`transient-suffix'.")
+
+(cl-defmethod transient-infix-value ((_ transient-suffix))
+ "Return nil, which means \"no value\".
+
+Infix arguments contribute the the transient's value while suffix
+commands consume it. This function is called for suffixes anyway
+because a command that both contributes to the transient's value
+and also consumes it is not completely unconceivable.
+
+If you define such a command, then you must define a derived
+class and implement this function because this default method
+does nothing." nil)
+
+(cl-defmethod transient-infix-value ((obj transient-infix))
+ "Return the value of OBJ's `value' slot."
+ (oref obj value))
+
+(cl-defmethod transient-infix-value ((obj transient-option))
+ "Return (concat ARGUMENT VALUE) or nil.
+
+ARGUMENT and VALUE are the values of the respective slots of OBJ.
+If VALUE is nil, then return nil. VALUE may be the empty string,
+which is not the same as nil."
+ (when-let ((value (oref obj value)))
+ (concat (oref obj argument) value)))
+
+(cl-defmethod transient-infix-value ((_ transient-variable))
+ "Return nil, which means \"no value\".
+
+Setting the value of a variable is done by, well, setting the
+value of the variable. I.e. this is a side-effect and does not
+contribute to the value of the transient."
+ nil)
+
+(cl-defmethod transient-infix-value ((obj transient-files))
+ "Return (cons ARGUMENT VALUE) or nil.
+
+ARGUMENT and VALUE are the values of the respective slots of OBJ.
+If VALUE is nil, then return nil. VALUE may be the empty string,
+which is not the same as nil."
+ (when-let ((value (oref obj value)))
+ (cons (oref obj argument) value)))
+
+;;;; Utilities
+
+(defun transient-arg-value (arg args)
+ "Return the value of ARG as it appears in ARGS.
+
+For a switch return a boolean. For an option return the value as
+a string, using the empty string for the empty value, or nil if
+the option does not appear in ARGS."
+ (if (string-match-p "=\\'" arg)
+ (save-match-data
+ (when-let ((match (let ((re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'"
+ (substring arg 0 -1))))
+ (cl-find-if (lambda (a)
+ (and (stringp a)
+ (string-match re a)))
+ args))))
+ (or (match-string 1 match) "")))
+ (and (member arg args) t)))
+
+;;; History
+
+(cl-defgeneric transient--history-key (obj)
+ "Return OBJ's history key.
+If the value of the `history-key' slot is non-nil, then return
+that. Otherwise return the value of the `command' slot."
+ (or (oref obj history-key)
+ (oref obj command)))
+
+(cl-defgeneric transient--history-push (obj)
+ "Push the current value of OBJ to its entry in `transient-history'."
+ (let ((key (transient--history-key obj)))
+ (setf (alist-get key transient-history)
+ (let ((args (transient-get-value)))
+ (cons args (delete args (alist-get key transient-history)))))))
+
+(cl-defgeneric transient--history-init (obj)
+ "Initialize OBJ's `history' slot.
+This is the transient-wide history; many individual infixes also
+have a history of their own.")
+
+(cl-defmethod transient--history-init ((obj transient-prefix))
+ "Initialize OBJ's `history' slot from the variable `transient-history'."
+ (let ((val (oref obj value)))
+ (oset obj history
+ (cons val (delete val (alist-get (transient--history-key obj)
+ transient-history))))))
+
+;;; Draw
+
+(defun transient--show-brief ()
+ (let ((message-log-max nil))
+ (if (and transient-show-popup (<= transient-show-popup 0))
+ (message "%s-" (key-description (this-command-keys)))
+ (message
+ "%s- [%s] %s"
+ (key-description (this-command-keys))
+ (oref transient--prefix command)
+ (mapconcat
+ #'identity
+ (sort
+ (cl-mapcan
+ (lambda (suffix)
+ (let ((key (kbd (oref suffix key))))
+ ;; Don't list any common commands.
+ (and (not (memq (oref suffix command)
+ `(,(lookup-key transient-map key)
+ ,(lookup-key transient-sticky-map key)
+ ;; From transient-common-commands:
+ transient-set
+ transient-save
+ transient-history-prev
+ transient-history-next
+ transient-quit-one
+ transient-toggle-common
+ transient-set-level)))
+ (list (propertize (oref suffix key) 'face 'transient-key)))))
+ transient--suffixes)
+ #'string<)
+ (propertize "|" 'face 'transient-unreachable-key))))))
+
+(defun transient--show ()
+ (transient--timer-cancel)
+ (setq transient--showp t)
+ (let ((buf (get-buffer-create transient--buffer-name))
+ (focus nil))
+ (unless (window-live-p transient--window)
+ (setq transient--window
+ (display-buffer buf transient-display-buffer-action)))
+ (with-selected-window transient--window
+ (when transient-enable-popup-navigation
+ (setq focus (button-get (point) 'command)))
+ (erase-buffer)
+ (set-window-hscroll transient--window 0)
+ (set-window-dedicated-p transient--window t)
+ (set-window-parameter transient--window 'no-other-window t)
+ (setq window-size-fixed t)
+ (when (bound-and-true-p tab-line-format)
+ (setq tab-line-format nil))
+ (setq mode-line-format (if (eq transient-mode-line-format 'line)
+ nil
+ transient-mode-line-format))
+ (setq mode-line-buffer-identification
+ (symbol-name (oref transient--prefix command)))
+ (if transient-enable-popup-navigation
+ (setq-local cursor-in-non-selected-windows 'box)
+ (setq cursor-type nil))
+ (setq display-line-numbers nil)
+ (setq show-trailing-whitespace nil)
+ (transient--insert-groups)
+ (when (or transient--helpp transient--editp)
+ (transient--insert-help))
+ (when (and (eq transient-mode-line-format 'line)
+ window-system)
+ (let ((face
+ (if-let ((f (and (transient--semantic-coloring-p)
+ (transient--prefix-color transient--prefix))))
+ `(,@(and (>= emacs-major-version 27) '(:extend t))
+ :background ,(face-foreground f))
+ 'transient-separator)))
+ (insert (propertize "__" 'face face 'display '(space :height (1))))
+ (insert (propertize "\n" 'face face 'line-height t))))
+ (let ((window-resize-pixelwise t)
+ (window-size-fixed nil))
+ (fit-window-to-buffer nil nil 1))
+ (goto-char (point-min))
+ (when transient-force-fixed-pitch
+ (transient--force-fixed-pitch))
+ (when transient-enable-popup-navigation
+ (transient--goto-button focus)))))
+
+(defun transient--insert-groups ()
+ (let ((groups (cl-mapcan (lambda (group)
+ (let ((hide (oref group hide)))
+ (and (not (and (functionp hide)
+ (funcall hide)))
+ (list group))))
+ transient--layout))
+ group)
+ (while (setq group (pop groups))
+ (transient--insert-group group)
+ (when groups
+ (insert ?\n)))))
+
+(cl-defgeneric transient--insert-group (group)
+ "Format GROUP and its elements and insert the result.")
+
+(cl-defmethod transient--insert-group :before ((group transient-group))
+ "Insert GROUP's description, if any."
+ (when-let ((desc (transient-format-description group)))
+ (insert desc ?\n)))
+
+(cl-defmethod transient--insert-group ((group transient-row))
+ (transient--maybe-pad-keys group)
+ (dolist (suffix (oref group suffixes))
+ (insert (transient-format suffix))
+ (insert " "))
+ (insert ?\n))
+
+(cl-defmethod transient--insert-group ((group transient-column))
+ (transient--maybe-pad-keys group)
+ (dolist (suffix (oref group suffixes))
+ (let ((str (transient-format suffix)))
+ (insert str)
+ (unless (string-match-p ".\n\\'" str)
+ (insert ?\n)))))
+
+(cl-defmethod transient--insert-group ((group transient-columns))
+ (let* ((columns
+ (mapcar
+ (lambda (column)
+ (transient--maybe-pad-keys column group)
+ (let ((rows (mapcar 'transient-format (oref column suffixes))))
+ (when-let ((desc (transient-format-description column)))
+ (push desc rows))
+ rows))
+ (oref group suffixes)))
+ (rs (apply #'max (mapcar #'length columns)))
+ (cs (length columns))
+ (cw (mapcar (lambda (col) (apply #'max (mapcar #'length col)))
+ columns))
+ (cc (transient--seq-reductions-from (apply-partially #'+ 3) cw 0)))
+ (if transient-force-single-column
+ (dotimes (c cs)
+ (dotimes (r rs)
+ (when-let ((cell (nth r (nth c columns))))
+ (unless (equal cell "")
+ (insert cell ?\n))))
+ (unless (= c (1- cs))
+ (insert ?\n)))
+ (dotimes (r rs)
+ (dotimes (c cs)
+ (insert (make-string (- (nth c cc) (current-column)) ?\s))
+ (when-let ((cell (nth r (nth c columns))))
+ (insert cell))
+ (when (= c (1- cs))
+ (insert ?\n)))))))
+
+(cl-defmethod transient--insert-group ((group transient-subgroups))
+ (let* ((subgroups (oref group suffixes))
+ (n (length subgroups)))
+ (dotimes (s n)
+ (let ((subgroup (nth s subgroups)))
+ (transient--maybe-pad-keys subgroup group)
+ (transient--insert-group subgroup)
+ (when (< s (1- n))
+ (insert ?\n))))))
+
+(cl-defgeneric transient-format (obj)
+ "Format and return OBJ for display.
+
+When this function is called, then the current buffer is some
+temporary buffer. If you need the buffer from which the prefix
+command was invoked to be current, then do so by temporarily
+making `transient--original-buffer' current.")
+
+(cl-defmethod transient-format ((arg string))
+ "Return the string ARG after applying the `transient-heading' face."
+ (propertize arg 'face 'transient-heading))
+
+(cl-defmethod transient-format ((_ null))
+ "Return a string containing just the newline character."
+ "\n")
+
+(cl-defmethod transient-format ((arg integer))
+ "Return a string containing just the ARG character."
+ (char-to-string arg))
+
+(cl-defmethod transient-format :around ((obj transient-infix))
+ "When reading user input for this infix, then highlight it."
+ (let ((str (cl-call-next-method obj)))
+ (when (eq obj transient--active-infix)
+ (setq str (concat str "\n"))
+ (add-face-text-property
+ (if (eq this-command 'transient-set-level) 3 0)
+ (length str)
+ 'transient-active-infix nil str))
+ str))
+
+(cl-defmethod transient-format :around ((obj transient-suffix))
+ "When edit-mode is enabled, then prepend the level information.
+Optional support for popup buttons is also implemented here."
+ (let ((str (concat
+ (and transient--editp
+ (let ((level (oref obj level)))
+ (propertize (format " %s " level)
+ 'face (if (transient--use-level-p level t)
+ 'transient-enabled-suffix
+ 'transient-disabled-suffix))))
+ (cl-call-next-method obj))))
+ (when (oref obj inapt)
+ (add-face-text-property 0 (length str) 'transient-inapt-suffix nil str))
+ (if transient-enable-popup-navigation
+ (make-text-button str nil
+ 'type 'transient-button
+ 'command (transient--suffix-command obj))
+ str)))
+
+(cl-defmethod transient-format ((obj transient-infix))
+ "Return a string generated using OBJ's `format'.
+%k is formatted using `transient-format-key'.
+%d is formatted using `transient-format-description'.
+%v is formatted using `transient-format-value'."
+ (format-spec (oref obj format)
+ `((?k . ,(transient-format-key obj))
+ (?d . ,(transient-format-description obj))
+ (?v . ,(transient-format-value obj)))))
+
+(cl-defmethod transient-format ((obj transient-suffix))
+ "Return a string generated using OBJ's `format'.
+%k is formatted using `transient-format-key'.
+%d is formatted using `transient-format-description'."
+ (format-spec (oref obj format)
+ `((?k . ,(transient-format-key obj))
+ (?d . ,(transient-format-description obj)))))
+
+(cl-defgeneric transient-format-key (obj)
+ "Format OBJ's `key' for display and return the result.")
+
+(cl-defmethod transient-format-key ((obj transient-suffix))
+ "Format OBJ's `key' for display and return the result."
+ (let ((key (oref obj key))
+ (cmd (oref obj command)))
+ (if transient--redisplay-key
+ (let ((len (length transient--redisplay-key))
+ (seq (cl-coerce (edmacro-parse-keys key t) 'list)))
+ (cond
+ ((equal (seq-take seq len) transient--redisplay-key)
+ (let ((pre (key-description (vconcat (seq-take seq len))))
+ (suf (key-description (vconcat (seq-drop seq len)))))
+ (setq pre (replace-regexp-in-string "RET" "C-m" pre t))
+ (setq pre (replace-regexp-in-string "TAB" "C-i" pre t))
+ (setq suf (replace-regexp-in-string "RET" "C-m" suf t))
+ (setq suf (replace-regexp-in-string "TAB" "C-i" suf t))
+ ;; We use e.g. "-k" instead of the more correct "- k",
+ ;; because the former is prettier. If we did that in
+ ;; the definition, then we want to drop the space that
+ ;; is reinserted above. False-positives are possible
+ ;; for silly bindings like "-C-c C-c".
+ (unless (string-match-p " " key)
+ (setq pre (replace-regexp-in-string " " "" pre))
+ (setq suf (replace-regexp-in-string " " "" suf)))
+ (concat (propertize pre 'face 'default)
+ (and (string-prefix-p (concat pre " ") key) " ")
+ (transient--colorize-key suf cmd)
+ (save-excursion
+ (when (string-match " +\\'" key)
+ (match-string 0 key))))))
+ ((transient--lookup-key transient-sticky-map (kbd key))
+ (transient--colorize-key key cmd))
+ (t
+ (propertize key 'face 'transient-unreachable-key))))
+ (transient--colorize-key key cmd))))
+
+(defun transient--colorize-key (key command)
+ (propertize key 'face
+ (or (and (transient--semantic-coloring-p)
+ (transient--suffix-color command))
+ 'transient-key)))
+
+(cl-defmethod transient-format-key :around ((obj transient-argument))
+ (let ((key (cl-call-next-method obj)))
+ (cond ((not transient-highlight-mismatched-keys))
+ ((not (slot-boundp obj 'shortarg))
+ (add-face-text-property
+ 0 (length key) 'transient-nonstandard-key nil key))
+ ((not (string-equal key (oref obj shortarg)))
+ (add-face-text-property
+ 0 (length key) 'transient-mismatched-key nil key)))
+ key))
+
+(cl-defgeneric transient-format-description (obj)
+ "Format OBJ's `description' for display and return the result.")
+
+(cl-defmethod transient-format-description ((obj transient-child))
+ "The `description' slot may be a function, in which case that is
+called inside the correct buffer (see `transient-insert-group')
+and its value is returned to the caller."
+ (when-let ((desc (oref obj description)))
+ (if (functionp desc)
+ (with-current-buffer transient--original-buffer
+ (funcall desc))
+ desc)))
+
+(cl-defmethod transient-format-description ((obj transient-group))
+ "Format the description by calling the next method. If the result
+doesn't use the `face' property at all, then apply the face
+`transient-heading' to the complete string."
+ (when-let ((desc (cl-call-next-method obj)))
+ (if (text-property-not-all 0 (length desc) 'face nil desc)
+ desc
+ (propertize desc 'face 'transient-heading))))
+
+(cl-defmethod transient-format-description :around ((obj transient-suffix))
+ "Format the description by calling the next method. If the result
+is nil, then use \"(BUG: no description)\" as the description.
+If the OBJ's `key' is currently unreachable, then apply the face
+`transient-unreachable' to the complete string."
+ (let ((desc (or (cl-call-next-method obj)
+ (and (slot-boundp transient--prefix 'suffix-description)
+ (funcall (oref transient--prefix suffix-description)
+ obj))
+ (propertize "(BUG: no description)" 'face 'error))))
+ (cond ((transient--key-unreachable-p obj)
+ (propertize desc 'face 'transient-unreachable))
+ ((and transient-highlight-higher-levels
+ (> (oref obj level) transient--default-prefix-level))
+ (add-face-text-property
+ 0 (length desc) 'transient-higher-level nil desc)
+ desc)
+ (t
+ desc))))
+
+(cl-defgeneric transient-format-value (obj)
+ "Format OBJ's value for display and return the result.")
+
+(cl-defmethod transient-format-value ((obj transient-suffix))
+ (propertize (oref obj argument)
+ 'face (if (oref obj value)
+ 'transient-argument
+ 'transient-inactive-argument)))
+
+(cl-defmethod transient-format-value ((obj transient-option))
+ (let ((value (oref obj value)))
+ (propertize (concat (oref obj argument)
+ (if (listp value)
+ (mapconcat #'identity value ",")
+ value))
+ 'face (if value
+ 'transient-value
+ 'transient-inactive-value))))
+
+(cl-defmethod transient-format-value ((obj transient-switches))
+ (with-slots (value argument-format choices) obj
+ (format (propertize argument-format
+ 'face (if value
+ 'transient-value
+ 'transient-inactive-value))
+ (concat
+ (propertize "[" 'face 'transient-inactive-value)
+ (mapconcat
+ (lambda (choice)
+ (propertize choice 'face
+ (if (equal (format argument-format choice) value)
+ 'transient-value
+ 'transient-inactive-value)))
+ choices
+ (propertize "|" 'face 'transient-inactive-value))
+ (propertize "]" 'face 'transient-inactive-value)))))
+
+(cl-defmethod transient-format-value ((obj transient-files))
+ (let ((argument (oref obj argument)))
+ (if-let ((value (oref obj value)))
+ (propertize (concat argument " "
+ (mapconcat (lambda (f) (format "%S" f))
+ (oref obj value) " "))
+ 'face 'transient-argument)
+ (propertize argument 'face 'transient-inactive-argument))))
+
+(defun transient--key-unreachable-p (obj)
+ (and transient--redisplay-key
+ (let ((key (oref obj key)))
+ (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list)
+ (length transient--redisplay-key))
+ transient--redisplay-key)
+ (transient--lookup-key transient-sticky-map (kbd key)))))))
+
+(defun transient--lookup-key (keymap key)
+ (let ((val (lookup-key keymap key)))
+ (and val (not (integerp val)) val)))
+
+(defun transient--maybe-pad-keys (group &optional parent)
+ (when-let ((pad (if (slot-boundp group 'pad-keys)
+ (oref group pad-keys)
+ (and parent
+ (slot-boundp parent 'pad-keys)
+ (oref parent pad-keys)))))
+ (let ((width (apply #'max
+ (cons (if (integerp pad) pad 0)
+ (mapcar (lambda (suffix)
+ (length (oref suffix key)))
+ (oref group suffixes))))))
+ (dolist (suffix (oref group suffixes))
+ (oset suffix key
+ (truncate-string-to-width (oref suffix key) width nil ?\s))))))
+
+(defun transient-command-summary-or-name (obj)
+ "Return the summary or name of the command represented by OBJ.
+
+If the command has a doc-string, then return the first line of
+that, else its name.
+
+Intended to be temporarily used as the `:suffix-description' of
+a prefix command, while porting a regular keymap to a transient."
+ (let ((command (transient--suffix-symbol (oref obj command))))
+ (if-let ((doc (documentation command)))
+ (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face)
+ (propertize (symbol-name command) 'face 'font-lock-function-name-face))))
+
+;;; Help
+
+(cl-defgeneric transient-show-help (obj)
+ "Show help for OBJ's command.")
+
+(cl-defmethod transient-show-help ((obj transient-prefix))
+ "Show the info manual, manpage or command doc-string.
+Show the first one that is specified."
+ (if-let ((manual (oref obj info-manual)))
+ (info manual)
+ (if-let ((manpage (oref obj man-page)))
+ (transient--show-manpage manpage)
+ (transient--describe-function (oref obj command)))))
+
+(cl-defmethod transient-show-help ((obj transient-suffix))
+ "Show the command doc-string."
+ (if (eq this-original-command 'transient-help)
+ (if-let ((manpage (oref transient--prefix man-page)))
+ (transient--show-manpage manpage)
+ (transient--describe-function (oref transient--prefix command)))
+ (if-let ((prefix (get (transient--suffix-command obj) 'transient--prefix))
+ (manpage (oref prefix man-page)))
+ (transient--show-manpage manpage)
+ (transient--describe-function this-original-command))))
+
+(cl-defmethod transient-show-help ((obj transient-infix))
+ "Show the manpage if defined or the command doc-string.
+If the manpage is specified, then try to jump to the correct
+location."
+ (if-let ((manpage (oref transient--prefix man-page)))
+ (transient--show-manpage manpage (ignore-errors (oref obj argument)))
+ (transient--describe-function this-original-command)))
+
+;; `cl-generic-generalizers' doesn't support `command' et al.
+(cl-defmethod transient-show-help (cmd)
+ "Show the command doc-string."
+ (transient--describe-function cmd))
+
+(defun transient--show-manpage (manpage &optional argument)
+ (require 'man)
+ (let* ((Man-notify-method 'meek)
+ (buf (Man-getpage-in-background manpage))
+ (proc (get-buffer-process buf)))
+ (while (and proc (eq (process-status proc) 'run))
+ (accept-process-output proc))
+ (switch-to-buffer buf)
+ (when argument
+ (transient--goto-argument-description argument))))
+
+(defun transient--describe-function (fn)
+ (describe-function fn)
+ (select-window (get-buffer-window (help-buffer))))
+
+(defun transient--goto-argument-description (arg)
+ (goto-char (point-min))
+ (let ((case-fold-search nil)
+ ;; This matches preceding/proceeding options. Options
+ ;; such as "-a", "-S[<keyid>]", and "--grep=<pattern>"
+ ;; are matched by this regex without the shy group.
+ ;; The ". " in the shy group is for options such as
+ ;; "-m parent-number", and the "-[^[:space:]]+ " is
+ ;; for options such as "--mainline parent-number"
+ (others "-\\(?:. \\|-[^[:space:]]+ \\)?[^[:space:]]+"))
+ (when (re-search-forward
+ (if (equal arg "--")
+ ;; Special case.
+ "^[\t\s]+\\(--\\(?: \\|$\\)\\|\\[--\\]\\)"
+ ;; Should start with whitespace and may have
+ ;; any number of options before and/or after.
+ (format
+ "^[\t\s]+\\(?:%s, \\)*?\\(?1:%s\\)%s\\(?:, %s\\)*$"
+ others
+ ;; Options don't necessarily end in an "="
+ ;; (e.g., "--gpg-sign[=<keyid>]")
+ (string-remove-suffix "=" arg)
+ ;; Simple options don't end in an "=". Splitting this
+ ;; into 2 cases should make getting false positives
+ ;; less likely.
+ (if (string-suffix-p "=" arg)
+ ;; "[^[:space:]]*[^.[:space:]]" matches the option
+ ;; value, which is usually after the option name
+ ;; and either '=' or '[='. The value can't end in
+ ;; a period, as that means it's being used at the
+ ;; end of a sentence. The space is for options
+ ;; such as '--mainline parent-number'.
+ "\\(?: \\|\\[?=\\)[^[:space:]]*[^.[:space:]]"
+ ;; Either this doesn't match anything (e.g., "-a"),
+ ;; or the option is followed by a value delimited
+ ;; by a "[", "<", or ":". A space might appear
+ ;; before this value, as in "-f <file>". The
+ ;; space alternative is for options such as
+ ;; "-m parent-number".
+ "\\(?:\\(?: \\| ?[\\[<:]\\)[^[:space:]]*[^.[:space:]]\\)?")
+ others))
+ nil t)
+ (goto-char (match-beginning 1)))))
+
+(defun transient--insert-help ()
+ (unless (looking-back "\n\n" 2)
+ (insert "\n"))
+ (when transient--helpp
+ (insert
+ (format (propertize "\
+Type a %s to show help for that suffix command, or %s to show manual.
+Type %s to exit help.\n"
+ 'face 'transient-heading)
+ (propertize "<KEY>" 'face 'transient-key)
+ (propertize "?" 'face 'transient-key)
+ (propertize "C-g" 'face 'transient-key))))
+ (when transient--editp
+ (unless transient--helpp
+ (insert
+ (format (propertize "\
+Type a %s to set level for that suffix command.
+Type %s to set what levels are available for this prefix command.\n"
+ 'face 'transient-heading)
+ (propertize "<KEY>" 'face 'transient-key)
+ (propertize "C-x l" 'face 'transient-key))))
+ (with-slots (level) transient--prefix
+ (insert
+ (format (propertize "
+Suffixes on levels %s are available.
+Suffixes on levels %s and %s are unavailable.\n"
+ 'face 'transient-heading)
+ (propertize (format "1-%s" level)
+ 'face 'transient-enabled-suffix)
+ (propertize " 0 "
+ 'face 'transient-disabled-suffix)
+ (propertize (format ">=%s" (1+ level))
+ 'face 'transient-disabled-suffix))))))
+
+(defvar transient-resume-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap Man-quit] 'transient-resume)
+ (define-key map [remap Info-exit] 'transient-resume)
+ (define-key map [remap quit-window] 'transient-resume)
+ map)
+ "Keymap for `transient-resume-mode'.
+
+This keymap remaps every command that would usually just quit the
+documentation buffer to `transient-resume', which additionally
+resumes the suspended transient.")
+
+(define-minor-mode transient-resume-mode
+ "Auxiliary minor-mode used to resume a transient after viewing help.")
+
+;;; Compatibility
+;;;; Popup Navigation
+
+(defun transient-popup-navigation-help ()
+ "Inform the user how to enable popup navigation commands."
+ (interactive)
+ (message "This command is only available if `%s' is non-nil"
+ 'transient-enable-popup-navigation))
+
+(define-button-type 'transient-button
+ 'face nil
+ 'action (lambda (button)
+ (let ((command (button-get button 'command)))
+ ;; Yes, I know that this is wrong(tm).
+ ;; Unfortunately it is also necessary.
+ (setq this-original-command command)
+ (call-interactively command))))
+
+(defvar transient-popup-navigation-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "<down-mouse-1>") 'transient-noop)
+ (define-key map (kbd "<mouse-1>") 'transient-mouse-push-button)
+ (define-key map (kbd "RET") 'transient-push-button)
+ (define-key map (kbd "<up>") 'transient-backward-button)
+ (define-key map (kbd "C-p") 'transient-backward-button)
+ (define-key map (kbd "<down>") 'transient-forward-button)
+ (define-key map (kbd "C-n") 'transient-forward-button)
+ (define-key map (kbd "C-r") 'transient-isearch-backward)
+ (define-key map (kbd "C-s") 'transient-isearch-forward)
+ map))
+
+(defun transient-mouse-push-button (&optional pos)
+ "Invoke the suffix the user clicks on."
+ (interactive (list last-command-event))
+ (push-button pos))
+
+(defun transient-push-button ()
+ "Invoke the selected suffix command."
+ (interactive)
+ (with-selected-window transient--window
+ (push-button)))
+
+(defun transient-backward-button (n)
+ "Move to the previous button in the transient popup buffer.
+See `backward-button' for information about N."
+ (interactive "p")
+ (with-selected-window transient--window
+ (backward-button n t)))
+
+(defun transient-forward-button (n)
+ "Move to the next button in the transient popup buffer.
+See `forward-button' for information about N."
+ (interactive "p")
+ (with-selected-window transient--window
+ (forward-button n t)))
+
+(defun transient--goto-button (command)
+ (if (not command)
+ (forward-button 1)
+ (while (and (ignore-errors (forward-button 1))
+ (not (eq (button-get (button-at (point)) 'command) command))))
+ (unless (eq (button-get (button-at (point)) 'command) command)
+ (goto-char (point-min))
+ (forward-button 1))))
+
+;;;; Popup Isearch
+
+(defvar transient--isearch-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map isearch-mode-map)
+ (define-key map [remap isearch-exit] 'transient-isearch-exit)
+ (define-key map [remap isearch-cancel] 'transient-isearch-cancel)
+ (define-key map [remap isearch-abort] 'transient-isearch-abort)
+ map))
+
+(defun transient-isearch-backward (&optional regexp-p)
+ "Do incremental search backward.
+With a prefix argument, do an incremental regular expression
+search instead."
+ (interactive "P")
+ (transient--isearch-setup)
+ (let ((isearch-mode-map transient--isearch-mode-map))
+ (isearch-mode nil regexp-p)))
+
+(defun transient-isearch-forward (&optional regexp-p)
+ "Do incremental search forward.
+With a prefix argument, do an incremental regular expression
+search instead."
+ (interactive "P")
+ (transient--isearch-setup)
+ (let ((isearch-mode-map transient--isearch-mode-map))
+ (isearch-mode t regexp-p)))
+
+(defun transient-isearch-exit ()
+ "Like `isearch-exit' but adapted for `transient'."
+ (interactive)
+ (isearch-exit)
+ (transient--isearch-exit))
+
+(defun transient-isearch-cancel ()
+ "Like `isearch-cancel' but adapted for `transient'."
+ (interactive)
+ (condition-case nil (isearch-cancel) (quit))
+ (transient--isearch-exit))
+
+(defun transient-isearch-abort ()
+ "Like `isearch-abort' but adapted for `transient'."
+ (interactive)
+ (condition-case nil (isearch-abort) (quit))
+ (transient--isearch-exit))
+
+(defun transient--isearch-setup ()
+ (select-window transient--window)
+ (transient--suspend-override))
+
+(defun transient--isearch-exit ()
+ (select-window transient--original-window)
+ (transient--resume-override))
+
+;;;; Hydra Color Emulation
+
+(defun transient--semantic-coloring-p ()
+ (and transient-semantic-coloring
+ (not transient--helpp)
+ (not transient--editp)))
+
+(defun transient--suffix-color (command)
+ (or (get command 'transient-color)
+ (get (transient--get-predicate-for command) 'transient-color)))
+
+(defun transient--prefix-color (command)
+ (let* ((nonsuf (or (oref command transient-non-suffix)
+ 'transient--do-warn))
+ (nonsuf (if (memq nonsuf '(transient--do-noop transient--do-warn))
+ 'disallow
+ (get nonsuf 'transient-color)))
+ (suffix (if-let ((pred (oref command transient-suffix)))
+ (get pred 'transient-color)
+ (if (eq nonsuf 'transient-red)
+ 'transient-red
+ 'transient-blue))))
+ (pcase (list suffix nonsuf)
+ (`(transient-red disallow) 'transient-amaranth)
+ (`(transient-blue disallow) 'transient-teal)
+ (`(transient-red transient-red) 'transient-pink)
+ (`(transient-red transient-blue) 'transient-red)
+ (`(transient-blue transient-blue) 'transient-blue))))
+
+;;;; Edebug
+
+(defun transient--edebug--recursive-edit (fn arg-mode)
+ (transient--debug 'edebug--recursive-edit)
+ (if (not transient--prefix)
+ (funcall fn arg-mode)
+ (transient--suspend-override t)
+ (funcall fn arg-mode)
+ (transient--resume-override t)))
+
+(advice-add 'edebug--recursive-edit :around 'transient--edebug--recursive-edit)
+
+(defun transient--abort-edebug ()
+ (when (bound-and-true-p edebug-active)
+ (transient--emergency-exit)))
+
+(advice-add 'abort-recursive-edit :before 'transient--abort-edebug)
+(advice-add 'top-level :before 'transient--abort-edebug)
+
+(defun transient--edebug-command-p ()
+ (and (bound-and-true-p edebug-active)
+ (or (memq this-command '(top-level abort-recursive-edit))
+ (string-prefix-p "edebug" (symbol-name this-command)))))
+
+;;;; Miscellaneous
+
+(declare-function which-key-mode "which-key" (&optional arg))
+
+(defun transient--suspend-which-key-mode ()
+ (when (bound-and-true-p which-key-mode)
+ (which-key-mode -1)
+ (add-hook 'transient-exit-hook 'transient--resume-which-key-mode)))
+
+(defun transient--resume-which-key-mode ()
+ (unless transient--prefix
+ (which-key-mode 1)
+ (remove-hook 'transient-exit-hook 'transient--resume-which-key-mode)))
+
+(defun transient-bind-q-to-quit ()
+ "Modify some keymaps to bind \"q\" to the appropriate quit command.
+
+\"C-g\" is the default binding for such commands now, but Transient's
+predecessor Magit-Popup used \"q\" instead. If you would like to get
+that binding back, then call this function in your init file like so:
+
+ (with-eval-after-load \\='transient
+ (transient-bind-q-to-quit))
+
+Individual transients may already bind \"q\" to something else
+and such a binding would shadow the quit binding. If that is the
+case then \"Q\" is bound to whatever \"q\" would have been bound
+to by setting `transient-substitute-key-function' to a function
+that does that. Of course \"Q\" may already be bound to something
+else, so that function binds \"M-q\" to that command instead.
+Of course \"M-q\" may already be bound to something else, but
+we stop there."
+ (define-key transient-base-map "q" 'transient-quit-one)
+ (define-key transient-sticky-map "q" 'transient-quit-seq)
+ (setq transient-substitute-key-function
+ 'transient-rebind-quit-commands))
+
+(defun transient-rebind-quit-commands (obj)
+ "See `transient-bind-q-to-quit'."
+ (let ((key (oref obj key)))
+ (cond ((string-equal key "q") "Q")
+ ((string-equal key "Q") "M-q")
+ (t key))))
+
+(defun transient--force-fixed-pitch ()
+ (require 'face-remap)
+ (face-remap-reset-base 'default)
+ (face-remap-add-relative 'default 'fixed-pitch))
+
+;;;; Missing from Emacs
+
+(defun transient--seq-reductions-from (function sequence initial-value)
+ (let ((acc (list initial-value)))
+ (seq-doseq (elt sequence)
+ (push (funcall function (car acc) elt) acc))
+ (nreverse acc)))
+
+(defun transient-plist-to-alist (plist)
+ (let (alist)
+ (while plist
+ (push (cons (let* ((symbol (pop plist))
+ (name (symbol-name symbol)))
+ (if (eq (aref name 0) ?:)
+ (intern (substring name 1))
+ symbol))
+ (pop plist))
+ alist))
+ (nreverse alist)))
+
+;;; Font-Lock
+
+(defconst transient-font-lock-keywords
+ (eval-when-compile
+ `((,(concat "("
+ (regexp-opt (list "transient-define-prefix"
+ "transient-define-infix"
+ "transient-define-argument"
+ "transient-define-suffix")
+ t)
+ "\\_>[ \t'(]*"
+ "\\(\\(?:\\sw\\|\\s_\\)+\\)?")
+ (1 'font-lock-keyword-face)
+ (2 'font-lock-function-name-face nil t)))))
+
+(font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords)
+
+;;; Auxiliary Classes
+;;;; `transient-lisp-variable'
+
+(defclass transient-lisp-variable (transient-variable)
+ ((reader :initform #'transient-lisp-variable--reader)
+ (always-read :initform t)
+ (set-value :initarg :set-value :initform #'set))
+ "[Experimental] Class used for Lisp variables.")
+
+(cl-defmethod transient-init-value ((obj transient-lisp-variable))
+ (oset obj value (symbol-value (oref obj variable))))
+
+(cl-defmethod transient-infix-set ((obj transient-lisp-variable) value)
+ (funcall (oref obj set-value)
+ (oref obj variable)
+ (oset obj value value)))
+
+(cl-defmethod transient-format-description ((obj transient-lisp-variable))
+ (or (oref obj description)
+ (symbol-name (oref obj variable))))
+
+(cl-defmethod transient-format-value ((obj transient-lisp-variable))
+ (propertize (prin1-to-string (oref obj value))
+ 'face 'transient-value))
+
+(cl-defmethod transient-prompt ((obj transient-lisp-variable))
+ (format "Set %s: " (oref obj variable)))
+
+(defun transient-lisp-variable--reader (prompt initial-input _history)
+ (read--expression prompt initial-input))
+
+;;; _
+(provide 'transient)
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; End:
+;;; transient.el ends here
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
index 37861e75fae..d40a628b994 100644
--- a/lisp/tree-widget.el
+++ b/lisp/tree-widget.el
@@ -110,10 +110,8 @@
;; `tree-widget-themes-directory', and `tree-widget-theme' options for
;; more details.
-;;; History:
-;;
-
;;; Code:
+
(require 'wid-edit)
;;; Customization
@@ -260,10 +258,9 @@ Typically it should contain something like this:
\\='(:ascent center :mask (heuristic t)))"
(or name (setq name (or tree-widget-theme "default")))
(unless (string-equal name (tree-widget-theme-name))
- (set (make-local-variable 'tree-widget--theme)
- (make-vector 4 nil))
- (tree-widget-set-parent-theme name)
- (tree-widget-set-parent-theme "default")))
+ (setq-local tree-widget--theme (make-vector 4 nil))
+ (tree-widget-set-parent-theme name)
+ (tree-widget-set-parent-theme "default")))
(defun tree-widget--locate-sub-directory (name path)
"Locate all occurrences of the sub-directory NAME in PATH.
diff --git a/lisp/tutorial.el b/lisp/tutorial.el
index 5ec52108f24..186bf35fe7e 100644
--- a/lisp/tutorial.el
+++ b/lisp/tutorial.el
@@ -1,4 +1,4 @@
-;;; tutorial.el --- tutorial for Emacs
+;;; tutorial.el --- tutorial for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -25,10 +25,6 @@
;; Code for running the Emacs tutorial.
-;;; History:
-
-;; File was created 2006-09.
-
;;; Code:
(require 'help-mode) ;; for function help-buffer
@@ -38,17 +34,17 @@
"Face used to highlight warnings in the tutorial."
:group 'help)
-(defvar tutorial--point-before-chkeys 0
+(defvar-local tutorial--point-before-chkeys 0
"Point before display of key changes.")
-(make-variable-buffer-local 'tutorial--point-before-chkeys)
-(defvar tutorial--point-after-chkeys 0
+(defvar-local tutorial--point-after-chkeys 0
"Point after display of key changes.")
-(make-variable-buffer-local 'tutorial--point-after-chkeys)
-(defvar tutorial--lang nil
+(defvar-local tutorial--lang nil
"Tutorial language.")
-(make-variable-buffer-local 'tutorial--lang)
+
+(defvar tutorial--buffer nil
+ "The selected tutorial buffer.")
(defun tutorial--describe-nonstandard-key (value)
"Give more information about a changed key binding.
@@ -517,8 +513,8 @@ where
(list "more info" 'current-binding
key-fun def-fun key where))
nil))
- (add-to-list 'changed-keys
- (list key def-fun def-fun-txt where remark nil))))))
+ (push (list key def-fun def-fun-txt where remark nil)
+ changed-keys)))))
changed-keys))
(defun tutorial--key-description (key)
@@ -655,6 +651,15 @@ with some explanatory links."
(unless (eq prop-val 'key-sequence)
(delete-region prop-start prop-end))))))
+(defun tutorial--save-on-kill ()
+ "Query the user about saving the tutorial when killing Emacs."
+ (when (buffer-live-p tutorial--buffer)
+ (with-current-buffer tutorial--buffer
+ (if (y-or-n-p "Save your position in the tutorial? ")
+ (tutorial--save-tutorial-to (tutorial--saved-file))
+ (message "Tutorial position not saved"))))
+ t)
+
(defun tutorial--save-tutorial ()
"Save the tutorial buffer.
This saves the part of the tutorial before and after the area
@@ -759,7 +764,7 @@ Run the Viper tutorial? "))
(if (fboundp 'viper-tutorial)
(if (y-or-n-p (concat prompt1 prompt2))
(progn (message "")
- (funcall 'viper-tutorial 0))
+ (funcall #'viper-tutorial 0))
(message "Tutorial aborted by user"))
(message prompt1)))
(let* ((lang (cond
@@ -802,6 +807,7 @@ Run the Viper tutorial? "))
;; (Re)build the tutorial buffer if it is not ok
(unless old-tut-is-ok
(switch-to-buffer (get-buffer-create tut-buf-name))
+ (setq tutorial--buffer (current-buffer))
;; (unless old-tut-buf (text-mode))
(unless lang (error "Variable lang is nil"))
(setq tutorial--lang lang)
@@ -814,6 +820,7 @@ Run the Viper tutorial? "))
;; a hook to save it when the buffer is killed.
(setq buffer-auto-save-file-name nil)
(add-hook 'kill-buffer-hook 'tutorial--save-tutorial nil t)
+ (add-hook 'kill-emacs-query-functions 'tutorial--save-on-kill)
;; Insert the tutorial. First offer to resume last tutorial
;; editing session.
diff --git a/lisp/type-break.el b/lisp/type-break.el
index d73ddb123eb..a6d5cd01702 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -51,8 +51,6 @@
;; this, but I think the health of my hands is far more important than a
;; few pages of virtual memory.
-;; This program has no hope of working in Emacs 18.
-
;; This package was inspired by Roland McGrath's hanoi-break.el.
;; Several people contributed feedback and ideas, including
;; Roland McGrath <roland@gnu.org>
@@ -489,7 +487,7 @@ Return nil if the file is missing or if the time is not a Lisp time value."
(goto-char (point-min))
(read (current-buffer)))
(end-of-file
- (error "End of file in `%s'" file))))))))
+ (warn "End of file in `%s'" file))))))))
(defun type-break-get-previous-count ()
"Get previous keystroke count from `type-break-file-name'.
@@ -507,7 +505,7 @@ integer."
(forward-line 1)
(read (current-buffer)))
(end-of-file
- (error "End of file in `%s'" file)))))))
+ (warn "End of file in `%s'" file)))))))
file
0)))
@@ -958,11 +956,7 @@ FRAC should be the inverse of the fractional value; for example, a value of
sum))
(defun type-break-time-stamp (&optional when)
- (if (fboundp 'format-time-string)
- (format-time-string type-break-time-stamp-format when)
- ;; Emacs 19.28 and prior do not have format-time-string.
- ;; In that case, result is not customizable. Upgrade today!
- (format "[%s] " (substring (current-time-string when) 11 16))))
+ (format-time-string type-break-time-stamp-format when))
(defun type-break-format-time (secs)
(let ((mins (/ secs 60)))
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index df702b83abc..ffb5ecc9024 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -104,6 +104,14 @@ would have the following buffer names in the various styles:
post-forward-angle-brackets name<bar/mumble> name<quux/mumble>
nil name name<2>
+The value can be set to a customized function with two arguments
+BASE and EXTRA-STRINGS where BASE is a string and EXTRA-STRINGS
+is a list of strings. For example the current implementation for
+post-forward-angle-brackets could be:
+
+(defun my-post-forward-angle-brackets (base extra-string)
+ (concat base \"<\" (mapconcat #'identity extra-string \"/\") \">\"))
+
The \"mumble\" part may be stripped as well, depending on the
setting of `uniquify-strip-common-suffix'. For more options that
you can set, browse the `uniquify' custom group."
@@ -111,6 +119,7 @@ you can set, browse the `uniquify' custom group."
(const reverse)
(const post-forward)
(const post-forward-angle-brackets)
+ (function :tag "Other")
(const :tag "numeric suffixes" nil))
:version "24.4"
:require 'uniquify)
@@ -166,8 +175,8 @@ contains the name of the directory which the buffer is visiting.")
(cl-defstruct (uniquify-item
(:constructor nil) (:copier nil)
(:constructor uniquify-make-item
- (base dirname buffer &optional proposed)))
- base dirname buffer proposed)
+ (base dirname buffer &optional proposed original-dirname)))
+ base dirname buffer proposed original-dirname)
;; Internal variables used free
(defvar uniquify-possibly-resolvable nil)
@@ -202,7 +211,8 @@ this rationalization."
(with-current-buffer newbuf (setq uniquify-managed nil))
(when dirname
(setq dirname (expand-file-name (directory-file-name dirname)))
- (let ((fix-list (list (uniquify-make-item base dirname newbuf)))
+ (let ((fix-list (list (uniquify-make-item base dirname newbuf
+ nil dirname)))
items)
(dolist (buffer (buffer-list))
(when (and (not (and uniquify-ignore-buffers-re
@@ -236,7 +246,14 @@ this rationalization."
(if (buffer-live-p (uniquify-item-buffer item))
item))
items)))
- (setq fix-list (append fix-list items))))
+ ;; Other buffer's `uniquify-managed' lists may share
+ ;; elements. Ensure that we don't add these elements more
+ ;; than once to this buffer's `uniquify-managed' list.
+ (let ((new-items nil))
+ (dolist (item items)
+ (unless (memq item fix-list)
+ (push item new-items)))
+ (setq fix-list (append fix-list new-items)))))
;; selects buffers whose names may need changing, and others that
;; may conflict, then bring conflicting names together
(uniquify-rationalize fix-list))))
@@ -275,7 +292,9 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
;; Refresh the dirnames and proposed names.
(setf (uniquify-item-proposed item)
(uniquify-get-proposed-name (uniquify-item-base item)
- (uniquify-item-dirname item)))
+ (uniquify-item-dirname item)
+ nil
+ (uniquify-item-original-dirname item)))
(setq uniquify-managed fix-list)))
;; Strip any shared last directory names of the dirname.
(when (and (cdr fix-list) uniquify-strip-common-suffix)
@@ -298,7 +317,8 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-item-dirname item))))
(and f (directory-file-name f)))
(uniquify-item-buffer item)
- (uniquify-item-proposed item))
+ (uniquify-item-proposed item)
+ (uniquify-item-original-dirname item))
fix-list)))))
;; If uniquify-min-dir-content is 0, this will end up just
;; passing fix-list to uniquify-rationalize-conflicting-sublist.
@@ -326,13 +346,14 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-rationalize-conflicting-sublist conflicting-sublist
old-proposed depth)))
-(defun uniquify-get-proposed-name (base dirname &optional depth)
+(defun uniquify-get-proposed-name (base dirname &optional depth
+ original-dirname)
(unless depth (setq depth uniquify-min-dir-content))
(cl-assert (equal (directory-file-name dirname) dirname)) ;No trailing slash.
;; Distinguish directories by adding extra separator.
(if (and uniquify-trailing-separator-p
- (file-directory-p (expand-file-name base dirname))
+ (file-directory-p (expand-file-name base original-dirname))
(not (string-equal base "")))
(cond ((eq uniquify-buffer-name-style 'forward)
(setq base (file-name-as-directory base)))
@@ -364,20 +385,22 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(cond
((null extra-string) base)
((string-equal base "") ;Happens for dired buffers on the root directory.
- (mapconcat 'identity extra-string "/"))
+ (mapconcat #'identity extra-string "/"))
((eq uniquify-buffer-name-style 'reverse)
- (mapconcat 'identity
+ (mapconcat #'identity
(cons base (nreverse extra-string))
(or uniquify-separator "\\")))
((eq uniquify-buffer-name-style 'forward)
- (mapconcat 'identity (nconc extra-string (list base))
+ (mapconcat #'identity (nconc extra-string (list base))
"/"))
((eq uniquify-buffer-name-style 'post-forward)
(concat base (or uniquify-separator "|")
- (mapconcat 'identity extra-string "/")))
+ (mapconcat #'identity extra-string "/")))
((eq uniquify-buffer-name-style 'post-forward-angle-brackets)
- (concat base "<" (mapconcat 'identity extra-string "/")
+ (concat base "<" (mapconcat #'identity extra-string "/")
">"))
+ ((functionp uniquify-buffer-name-style)
+ (funcall uniquify-buffer-name-style base extra-string))
(t (error "Bad value for uniquify-buffer-name-style: %s"
uniquify-buffer-name-style)))))
@@ -399,7 +422,8 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-get-proposed-name
(uniquify-item-base item)
(uniquify-item-dirname item)
- depth)))
+ depth
+ (uniquify-item-original-dirname item))))
(uniquify-rationalize-a-list conf-list depth))
(unless (string= old-name "")
(uniquify-rename-buffer (car conf-list) old-name)))))
@@ -481,8 +505,6 @@ For use on `kill-buffer-hook'."
(file-name-directory filename) retval)))
retval))
-;;; The End
-
(defun uniquify-unload-function ()
"Unload the uniquify library."
(save-current-buffer
diff --git a/lisp/url/ChangeLog.1 b/lisp/url/ChangeLog.1
index b8ab2939949..cdd37a64cdd 100644
--- a/lisp/url/ChangeLog.1
+++ b/lisp/url/ChangeLog.1
@@ -449,7 +449,7 @@
2012-04-10 William Xu <william.xwl@gmail.com> (tiny change)
- * url.el (url-retrieve-internal): Hexify multibye URL string first
+ * url.el (url-retrieve-internal): Hexify multibyte URL string first
when necessary (bug#7017).
2012-04-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -2337,7 +2337,7 @@
recurse when retrieving the property lists. Returns an assoc
list keyed off of the resource, the cdr of which is a property list.
(url-dav-datatype-attribute): We support the XML-Data note
- (http://www.w3.org/TR/1998/NOTE-XML-data) to figure out what the
+ (https://www.w3.org/TR/1998/NOTE-XML-data) to figure out what the
datatypes of attributes are. Currently only date, dateTime, int,
number, float, boolean, and uri are supported.
diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el
index 8ffb80c247c..6ae90ccefad 100644
--- a/lisp/url/url-about.el
+++ b/lisp/url/url-about.el
@@ -1,4 +1,4 @@
-;;; url-about.el --- Show internal URLs
+;;; url-about.el --- Show internal URLs -*- lexical-binding: t; -*-
;; Copyright (C) 2001, 2004-2021 Free Software Foundation, Inc.
@@ -44,14 +44,14 @@
(defvar url-scheme-registry)
-(defun url-about-protocols (url)
+(defun url-about-protocols (_url)
(url-probe-protocols)
(insert "<html>\n"
" <head>\n"
" <title>Supported Protocols</title>\n"
" </head>\n"
" <body>\n"
- " <h1>Supported Protocols - URL v" url-version "</h1>\n"
+ " <h1>Supported Protocols - URL package in Emacs " emacs-version "</h1>\n"
" <table width='100%' border='1'>\n"
" <tr>\n"
" <td>Protocol\n"
@@ -73,13 +73,15 @@
"ynchronous<br>\n"
(if (url-scheme-get-property k 'default-port)
(format "Default Port: %d<br>\n"
- (url-scheme-get-property k 'default-port)) "")
+ (url-scheme-get-property k 'default-port))
+ "")
(if (assoc k url-proxy-services)
(format "Proxy: %s<br>\n" (assoc k url-proxy-services)) ""))
;; Now the description...
(insert " <td valign=top>"
(or (url-scheme-get-property k 'description) "N/A"))))
- (sort (let (x) (maphash (lambda (k v) (push k x)) url-scheme-registry) x) 'string-lessp))
+ (sort (let (x) (maphash (lambda (k _v) (push k x)) url-scheme-registry) x)
+ #'string-lessp))
(insert " </table>\n"
" </body>\n"
"</html>\n"))
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index 55d8d9d943e..f291414e81b 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -23,7 +23,6 @@
(require 'url-vars)
(require 'url-parse)
-(autoload 'url-warn "url")
(autoload 'auth-source-search "auth-source")
(defsubst url-auth-user-prompt (url realm)
@@ -39,7 +38,7 @@
;;; ------------------------
;;; This implements the BASIC authorization type. See the online
;;; documentation at
-;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
+;;; https://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
;;; for the complete documentation on this type.
;;;
;;; This is very insecure, but it works as a proof-of-concept
@@ -494,21 +493,19 @@ PROMPT is boolean - specifies whether to ask the user for a username/password
(car-safe
(sort
(mapcar
- (function
- (lambda (scheme)
- (if (fboundp (car (cdr scheme)))
- (cons (cdr (cdr scheme))
- (funcall (car (cdr scheme)) url nil nil realm))
- (cons 0 nil))))
+ (lambda (scheme)
+ (if (fboundp (car (cdr scheme)))
+ (cons (cdr (cdr scheme))
+ (funcall (car (cdr scheme)) url nil nil realm))
+ (cons 0 nil)))
url-registered-auth-schemes)
- (function
- (lambda (x y)
- (cond
- ((null (cdr x)) nil)
- ((and (cdr x) (null (cdr y))) t)
- ((and (cdr x) (cdr y))
- (>= (car x) (car y)))
- (t nil)))))))
+ (lambda (x y)
+ (cond
+ ((null (cdr x)) nil)
+ ((and (cdr x) (null (cdr y))) t)
+ ((and (cdr x) (cdr y))
+ (>= (car x) (car y)))
+ (t nil))))))
(if (symbolp type) (setq type (symbol-name type)))
(let* ((scheme (car-safe
(cdr-safe (assoc (downcase type)
@@ -542,7 +539,7 @@ RATING a rating between 1 and 10 of the strength of the authentication.
(t rating)))
(node (assoc type url-registered-auth-schemes)))
(if (not (fboundp function))
- (url-warn
+ (display-warning
'security
(format-message
"Tried to register `%s' as an auth scheme, but it is not a function!"
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index c3680dedee5..830e6ba9dcc 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -1,4 +1,4 @@
-;;; url-cache.el --- Uniform Resource Locator retrieval tool
+;;; url-cache.el --- Uniform Resource Locator retrieval tool -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -110,23 +110,22 @@ The actual return value is the last modification time of the cache file."
(let ((slash nil))
(setq fname
(mapconcat
- (function
- (lambda (x)
- (cond
- ((and (= ?/ x) slash)
- (setq slash nil)
- "%2F")
- ((= ?/ x)
- (setq slash t)
- "/")
- (t
- (setq slash nil)
- (char-to-string x))))) fname ""))))
+ (lambda (x)
+ (cond
+ ((and (= ?/ x) slash)
+ (setq slash nil)
+ "%2F")
+ ((= ?/ x)
+ (setq slash t)
+ "/")
+ (t
+ (setq slash nil)
+ (char-to-string x)))) fname ""))))
(setq fname (and fname
(mapconcat
- (function (lambda (x)
- (if (= x ?~) "" (char-to-string x))))
+ (lambda (x)
+ (if (= x ?~) "" (char-to-string x)))
fname ""))
fname (cond
((null fname) nil)
diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el
index d465cabc90c..0ca2d8a0737 100644
--- a/lisp/url/url-cid.el
+++ b/lisp/url/url-cid.el
@@ -1,4 +1,4 @@
-;;; url-cid.el --- Content-ID URL loader
+;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*-
;; Copyright (C) 1998-1999, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 486348c9db5..60388df2554 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -60,7 +60,7 @@
(defcustom url-cookie-multiple-line nil
"If nil, HTTP requests put all cookies for the server on one line.
-Some web servers, such as http://www.hotmail.com/, only accept cookies
+Some web servers, such as https://www.hotmail.com/, only accept cookies
when they are on one line. This is broken behavior, but just try
telling Microsoft that."
:type 'boolean
@@ -162,7 +162,7 @@ i.e. 1970-1-1) are loaded as expiring one year from now instead."
";; version-control: never\n"
";; no-byte-compile: t\n"
";; End:\n")
- (set (make-local-variable 'version-control) 'never)
+ (setq-local version-control 'never)
(write-file fname))
(setq url-cookies-changed-since-last-save nil))))
@@ -358,10 +358,10 @@ i.e. 1970-1-1) are loaded as expiring one year from now instead."
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-cookie-setup-save-timer' function manually."
- :set #'(lambda (var val)
- (set-default var val)
- (if (bound-and-true-p url-setup-done)
- (url-cookie-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (if (bound-and-true-p url-setup-done)
+ (url-cookie-setup-save-timer)))
:type 'integer
:group 'url-cookie)
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
index 12d5a683e97..192b1ac4f41 100644
--- a/lisp/url/url-dav.el
+++ b/lisp/url/url-dav.el
@@ -1,4 +1,4 @@
-;;; url-dav.el --- WebDAV support
+;;; url-dav.el --- WebDAV support -*- lexical-binding: t; -*-
;; Copyright (C) 2001, 2004-2021 Free Software Foundation, Inc.
@@ -43,22 +43,11 @@
(defvar url-http-response-status)
(defvar url-http-end-of-headers)
-(defun url-intersection (l1 l2)
- "Return a list of the elements occurring in both of the lists L1 and L2."
- (if (null l2)
- l2
- (let (result)
- (while l1
- (if (member (car l1) l2)
- (setq result (cons (pop l1) result))
- (pop l1)))
- (nreverse result))))
-
;;;###autoload
(defun url-dav-supported-p (url)
"Return WebDAV protocol version supported by URL.
Returns nil if WebDAV is not supported."
- (url-intersection url-dav-supported-protocols
+ (seq-intersection url-dav-supported-protocols
(plist-get (url-http-options url) 'dav)))
(defun url-dav-node-text (node)
@@ -133,7 +122,8 @@ Returns nil if WebDAV is not supported."
(node-type nil)
(props nil)
(value nil)
- (handler-func nil))
+ ;; (handler-func nil)
+ )
(when (not children)
(error "No child nodes in DAV:prop"))
@@ -453,7 +443,7 @@ FAILURE-RESULTS is a list of (URL STATUS)."
" </DAV:owner>\n"))
(response nil) ; Responses to the LOCK request
(result nil) ; For walking thru the response list
- (child-url nil)
+ ;; (child-url nil)
(child-status nil)
(failures nil) ; List of failure cases (URL . STATUS)
(successes nil)) ; List of success cases (URL . STATUS)
@@ -468,7 +458,7 @@ FAILURE-RESULTS is a list of (URL STATUS)."
;; status code.
(while response
(setq result (pop response)
- child-url (url-expand-file-name (pop result) url)
+ ;; child-url (url-expand-file-name (pop result) url)
child-status (or (plist-get result 'DAV:status) 500))
(if (url-dav-http-success-p child-status)
(push (list url child-status "huh") successes)
@@ -478,7 +468,7 @@ FAILURE-RESULTS is a list of (URL STATUS)."
(defun url-dav-active-locks (url &optional depth)
"Return an assoc list of all active locks on URL."
(let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
- (properties nil)
+ ;; (properties nil)
(child nil)
(child-url nil)
(child-results nil)
@@ -676,7 +666,6 @@ Use with care, and even then think three times."
If optional second argument RECURSIVE is non-nil, then delete all
files in the collection as well."
(let ((status nil)
- (props nil)
(props nil))
(setq props (url-dav-delete-something
url lock-token
@@ -769,7 +758,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
(when (member 'DAV:collection (plist-get properties 'DAV:resourcetype))
t)))
-(defun url-dav-make-directory (url &optional parents)
+(defun url-dav-make-directory (url &optional _parents)
"Create the directory DIR and any nonexistent parent dirs."
(let* ((url-request-extra-headers nil)
(url-request-method "MKCOL")
@@ -849,7 +838,9 @@ that start with FILE.
If there is only one and FILE matches it exactly, returns t.
Returns nil if URL contains no name starting with FILE."
(let ((matches (url-dav-file-name-all-completions file url))
- (result nil))
+ ;; (result nil)
+ )
+ ;; FIXME: Use `try-completion'!
(cond
((null matches)
;; No matches
@@ -908,7 +899,9 @@ Returns nil if URL contains no name starting with FILE."
t)))
-;;; Miscellaneous stuff.
+;;; Obsolete.
+
+(define-obsolete-function-alias 'url-intersection #'seq-intersection "28.1")
(provide 'url-dav)
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
index 472b43ed23f..398113db139 100644
--- a/lisp/url/url-dired.el
+++ b/lisp/url/url-dired.el
@@ -1,4 +1,4 @@
-;;; url-dired.el --- URL Dired minor mode
+;;; url-dired.el --- URL Dired minor mode -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-domsuf.el b/lisp/url/url-domsuf.el
index 107d349a243..59d70cbd0ee 100644
--- a/lisp/url/url-domsuf.el
+++ b/lisp/url/url-domsuf.el
@@ -1,4 +1,4 @@
-;;; url-domsuf.el --- Say what domain names can have cookies set.
+;;; url-domsuf.el --- Say what domain names can have cookies set. -*- lexical-binding:t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
@@ -24,7 +24,7 @@
;;; Commentary:
;; The rules for what domains can have cookies set is defined here:
-;; http://publicsuffix.org/list/
+;; https://publicsuffix.org/list/
;;; Code:
@@ -87,17 +87,6 @@
(setq allowedp nil))))
allowedp))
-;; Tests:
-
-;; TODO convert to a proper test.
-;; (url-domsuf-cookie-allowed-p "com") => nil
-;; (url-domsuf-cookie-allowed-p "foo.bar.bd") => t
-;; (url-domsuf-cookie-allowed-p "bar.bd") => nil
-;; (url-domsuf-cookie-allowed-p "co.uk") => nil
-;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t
-;; (url-domsuf-cookie-allowed-p "bar.yokohama.jp") => nil
-;; (url-domsuf-cookie-allowed-p "city.yokohama.jp") => t
-
(provide 'url-domsuf)
;;; url-domsuf.el ends here
diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el
index 3da03c049d8..05088e3cac8 100644
--- a/lisp/url/url-expand.el
+++ b/lisp/url/url-expand.el
@@ -65,10 +65,10 @@ path components followed by `..' are removed, along with the `..' itself."
(if (and url (not (string-match "^#" url)))
;; Need to nuke newlines and spaces in the URL, or we open
;; ourselves up to potential security holes.
- (setq url (mapconcat (function (lambda (x)
- (if (memq x '(? ?\n ?\r))
- ""
- (char-to-string x))))
+ (setq url (mapconcat (lambda (x)
+ (if (memq x '(?\s ?\n ?\r))
+ ""
+ (char-to-string x)))
url "")))
;; Need to figure out how/where to expand the fragment relative to
@@ -92,12 +92,19 @@ path components followed by `..' are removed, along with the `..' itself."
(cond
((= (length url) 0) ; nil or empty string
(url-recreate-url default))
- ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately
+ ((string-match url-nonrelative-link url) ; Fully-qualified URL,
+ ; return it immediately
url)
(t
(let* ((urlobj (url-generic-parse-url url))
(inhibit-file-name-handlers t)
- (expander (url-scheme-get-property (url-type default) 'expand-file-name)))
+ (expander (if (url-type default)
+ (url-scheme-get-property (url-type default)
+ 'expand-file-name)
+ ;; If neither the default nor the URL to be
+ ;; expanded have a protocol, then just use the
+ ;; identity expander as a fallback.
+ 'url-identity-expander)))
(if (string-match "^//" url)
(setq urlobj (url-generic-parse-url (concat (url-type default) ":"
url))))
@@ -113,7 +120,7 @@ path components followed by `..' are removed, along with the `..' itself."
;; Well, they told us the scheme, let's just go with it.
nil
(setf (url-type urlobj) (or (url-type urlobj) (url-type defobj)))
- (setf (url-port urlobj) (or (url-portspec urlobj)
+ (setf (url-portspec urlobj) (or (url-portspec urlobj)
(and (string= (url-type urlobj)
(url-type defobj))
(url-port defobj))))
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 52a9588030e..0e2ab5544b9 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -154,7 +154,7 @@ to them."
;; not the compressed one.
;; FIXME should this regexp not include more extensions; basically
;; everything that url-file-find-possibly-compressed-file does?
- (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
+ (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)\\'" filename)
(substring filename 0 (match-beginning 0))
filename))
(setq content-type (mailcap-extension-to-mime
diff --git a/lisp/url/url-ftp.el b/lisp/url/url-ftp.el
index 1abfc660bcf..3cda29a086d 100644
--- a/lisp/url/url-ftp.el
+++ b/lisp/url/url-ftp.el
@@ -1,4 +1,4 @@
-;;; url-ftp.el --- FTP wrapper
+;;; url-ftp.el --- FTP wrapper -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 81522a52223..d2bf843fc36 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -1,4 +1,4 @@
-;;; url-gw.el --- Gateway munging for URL loading
+;;; url-gw.el --- Gateway munging for URL loading -*- lexical-binding: t; -*-
;; Copyright (C) 1997-1998, 2004-2021 Free Software Foundation, Inc.
@@ -191,7 +191,7 @@ linked Emacs under SunOS 4.x."
proc (concat (mapconcat 'identity
(append url-gateway-telnet-parameters
(list host service)) " ") "\n"))
- (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
+ (url-wait-for-string "^\r*Escape character.*\n+" proc)
(delete-region (point-min) (match-end 0))
(process-send-string proc "\^]\n")
(url-wait-for-string "^telnet" proc)
@@ -222,18 +222,17 @@ overriding the value of `url-gateway-method'."
host))
'native
gwm))
- ;; An attempt to deal with denied connections, and attempt
- ;; to reconnect
- (cur-retries 0)
- (retry t)
- (errobj nil)
- (conn nil))
+ ;; An attempt to deal with denied connections, and attempt
+ ;; to reconnect
+ ;; (cur-retries 0)
+ ;; (retry t)
+ (conn nil))
;; If the user told us to do DNS for them, do it.
(if url-gateway-broken-resolution
(setq host (url-gateway-nslookup-host host)))
- (condition-case errobj
+ (condition-case nil
;; This is a clean way to ensure the new process inherits the
;; right coding systems in both Emacs and XEmacs.
(let ((coding-system-for-read 'binary)
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index bdd87d9db80..68556d6aa9c 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -299,8 +299,8 @@ BUFFER should be a complete URL buffer as returned by `url-retrieve'.
If the headers specify a coding-system (and current buffer is multibyte),
it is applied to the body before it is inserted.
Returns a list of the form (SIZE CHARSET), where SIZE is the size in bytes
-of the inserted text and CHARSET is the charset that was specified in the header,
-or nil if none was found.
+of the inserted text and CHARSET is the charset that was specified in the
+header, or nil if none was found.
BEG and END can be used to only insert a subpart of the body.
They count bytes from the beginning of the body."
(let* ((handle (with-current-buffer buffer (mm-dissect-buffer t)))
@@ -339,8 +339,7 @@ if it had been inserted from a file named URL."
(decode-coding-inserted-region (point-min) (point) url
visit beg end replace))
(let ((inserted (car size-and-charset)))
- (list url (or (and (fboundp 'after-insert-file-set-coding)
- (after-insert-file-set-coding inserted visit))
+ (list url (or (after-insert-file-set-coding inserted visit)
inserted))))))
;;;###autoload
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
index 10238a46607..5dd1f099136 100644
--- a/lisp/url/url-history.el
+++ b/lisp/url/url-history.el
@@ -38,10 +38,10 @@
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."
- :set #'(lambda (var val)
- (set-default var val)
- (and (bound-and-true-p url-setup-done)
- (url-history-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (and (bound-and-true-p url-setup-done)
+ (url-history-setup-save-timer)))
:type '(choice (const :tag "off" nil)
(const :tag "on" t)
(other :tag "within session" session))
@@ -59,10 +59,10 @@ is parsed at startup and used to provide URL completion."
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."
- :set #'(lambda (var val)
- (set-default var val)
- (if (bound-and-true-p url-setup-done)
- (url-history-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (if (bound-and-true-p url-setup-done)
+ (url-history-setup-save-timer)))
:type 'integer
:group 'url-history)
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 473da6f84c9..e3c178630ae 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -66,7 +66,7 @@
(defconst url-http-default-port 80 "Default HTTP port.")
(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
-(defalias 'url-http-expand-file-name 'url-default-expander)
+(defalias 'url-http-expand-file-name #'url-default-expander)
(defvar url-http-real-basic-auth-storage nil)
(defvar url-http-proxy-basic-auth-storage nil)
@@ -150,7 +150,7 @@ request.")
;; These routines will allow us to implement persistent HTTP
;; connections.
(defsubst url-http-debug (&rest args)
- (apply 'url-debug 'http args))
+ (apply #'url-debug 'http args))
(defun url-http-mark-connection-as-busy (host port proc)
(url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
@@ -225,7 +225,7 @@ request.")
(os-info (unless (and (listp url-privacy-level)
(memq 'os url-privacy-level))
(format "(%s; %s)" url-system-type url-os-type)))
- (url-info (format "URL/%s" url-version)))
+ (url-info (format "URL/Emacs")))
(string-join (delq nil (list package-info url-info
emacs-info os-info))
" ")))
@@ -704,15 +704,7 @@ should be shown to the user."
;; Treat everything like '300'
nil))
(when redirect-uri
- ;; Clean off any whitespace and/or <...> cruft.
- (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
- (setq redirect-uri (match-string 1 redirect-uri)))
- (if (string-match "^<\\(.*\\)>$" redirect-uri)
- (setq redirect-uri (match-string 1 redirect-uri)))
-
- ;; Some stupid sites (like sourceforge) send a
- ;; non-fully-qualified URL (ie: /), which royally confuses
- ;; the URL library.
+ ;; Handle relative redirect URIs.
(if (not (string-match url-nonrelative-link redirect-uri))
;; Be careful to use the real target URL, otherwise we may
;; compute the redirection relative to the URL of the proxy.
@@ -751,12 +743,12 @@ should be shown to the user."
;; without changing the API. Instead url-retrieve should
;; either simply not return the "destination" buffer, or it
;; should take an optional `dest-buf' argument.
- (set (make-local-variable 'url-redirect-buffer)
- (url-retrieve-internal
- redirect-uri url-callback-function
- url-callback-arguments
- (url-silent url-current-object)
- (not (url-use-cookies url-current-object))))
+ (setq-local url-redirect-buffer
+ (url-retrieve-internal
+ redirect-uri url-callback-function
+ url-callback-arguments
+ (url-silent url-current-object)
+ (not (url-use-cookies url-current-object))))
(url-mark-buffer-as-dead buffer))
;; We hit url-max-redirections, so issue an error and
;; stop redirecting.
@@ -1129,9 +1121,7 @@ the end of the document."
(beginning-of-line)
(looking-at regexp))
(add-text-properties (match-beginning 0) (match-end 0)
- (list 'start-open t
- 'end-open t
- 'chunked-encoding t
+ (list 'chunked-encoding t
'face 'cursor
'invisible t))
(setq url-http-chunked-length (string-to-number (buffer-substring
@@ -1215,8 +1205,7 @@ the end of the document."
;; 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))
+ ((memq url-http-response-status '(204 205))
(url-http-debug "%d response must have headers only (%s)."
url-http-response-status (buffer-name))
(when (url-http-parse-headers)
@@ -1251,11 +1240,11 @@ the end of the document."
(url-http-debug
"Saw HTTP/0.9 response, connection closed means end of document.")
(setq url-http-after-change-function
- 'url-http-simple-after-change-function))
+ #'url-http-simple-after-change-function))
((equal url-http-transfer-encoding "chunked")
(url-http-debug "Saw chunked encoding.")
(setq url-http-after-change-function
- 'url-http-chunked-encoding-after-change-function)
+ #'url-http-chunked-encoding-after-change-function)
(when (> nd url-http-end-of-headers)
(url-http-debug
"Calling initial chunked-encoding for extra data at end of headers")
@@ -1266,7 +1255,7 @@ the end of the document."
(url-http-debug
"Got a content-length, being smart about document end.")
(setq url-http-after-change-function
- 'url-http-content-length-after-change-function)
+ #'url-http-content-length-after-change-function)
(cond
((= 0 url-http-content-length)
;; We got a NULL body! Activate the callback
@@ -1287,7 +1276,7 @@ the end of the document."
(t
(url-http-debug "No content-length, being dumb.")
(setq url-http-after-change-function
- 'url-http-simple-after-change-function)))))
+ #'url-http-simple-after-change-function)))))
;; We are still at the beginning of the buffer... must just be
;; waiting for a response.
(url-http-debug "Spinning waiting for headers...")
@@ -1303,7 +1292,7 @@ passing it an updated value of CBARGS as arguments. The first
element in CBARGS should be a plist describing what has happened
so far during the request, as described in the docstring of
`url-retrieve' (if in doubt, specify nil). The current buffer
-then CALLBACK is executed is the retrieval buffer.
+when CALLBACK is executed is the retrieval buffer.
Optional arg RETRY-BUFFER, if non-nil, specifies the buffer of a
previous `url-http' call, which is being re-attempted.
@@ -1386,7 +1375,7 @@ The return value of this function is the retrieval buffer."
url-http-referer referer)
(set-process-buffer connection buffer)
- (set-process-filter connection 'url-http-generic-filter)
+ (set-process-filter connection #'url-http-generic-filter)
(pcase (process-status connection)
('connect
;; Asynchronous connection
@@ -1400,19 +1389,28 @@ The return value of this function is the retrieval buffer."
(url-type url-current-object)))
(url-https-proxy-connect connection)
(set-process-sentinel connection
- 'url-http-end-of-document-sentinel)
+ #'url-http-end-of-document-sentinel)
(process-send-string connection (url-http-create-request)))))))
buffer))
(defun url-https-proxy-connect (connection)
- (setq url-http-after-change-function 'url-https-proxy-after-change-function)
- (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n"
- "Host: %s\r\n"
- "\r\n")
- (url-host url-current-object)
- (or (url-port url-current-object)
- url-https-default-port)
- (url-host url-current-object))))
+ (setq url-http-after-change-function #'url-https-proxy-after-change-function)
+ (process-send-string
+ connection
+ (format
+ (concat "CONNECT %s:%d HTTP/1.1\r\n"
+ "Host: %s\r\n"
+ (let ((proxy-auth (let ((url-basic-auth-storage
+ 'url-http-proxy-basic-auth-storage))
+ (url-get-authentication url-http-proxy nil
+ 'any nil))))
+ (and proxy-auth
+ (concat "Proxy-Authorization: " proxy-auth "\r\n")))
+ "\r\n")
+ (url-host url-current-object)
+ (or (url-port url-current-object)
+ url-https-default-port)
+ (url-host url-current-object))))
(defun url-https-proxy-after-change-function (_st _nd _length)
(let* ((process-buffer (current-buffer))
@@ -1444,7 +1442,7 @@ The return value of this function is the retrieval buffer."
(with-current-buffer process-buffer (erase-buffer))
(set-process-buffer tls-connection process-buffer)
(setq url-http-after-change-function
- 'url-http-wait-for-headers-change-function)
+ #'url-http-wait-for-headers-change-function)
(set-process-filter tls-connection 'url-http-generic-filter)
(process-send-string tls-connection
(url-http-create-request)))
@@ -1513,7 +1511,7 @@ The return value of this function is the retrieval buffer."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defalias 'url-http-symbol-value-in-buffer
(if (fboundp 'symbol-value-in-buffer)
- 'symbol-value-in-buffer
+ #'symbol-value-in-buffer
(lambda (symbol buffer &optional unbound-value)
"Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
(with-current-buffer buffer
diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el
index 05c3e73fb0e..492907f33ff 100644
--- a/lisp/url/url-imap.el
+++ b/lisp/url/url-imap.el
@@ -1,4 +1,4 @@
-;;; url-imap.el --- IMAP retrieval routines
+;;; url-imap.el --- IMAP retrieval routines -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2004-2021 Free Software Foundation, Inc.
@@ -37,6 +37,9 @@
(defconst url-imap-default-port 143 "Default IMAP port.")
+(defvar imap-username)
+(defvar imap-password)
+
(defun url-imap-open-host (host port user pass)
;; xxx use user and password
(if (fboundp 'nnheader-init-server-buffer)
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
index 228eb593852..c895144ae2a 100644
--- a/lisp/url/url-irc.el
+++ b/lisp/url/url-irc.el
@@ -1,4 +1,4 @@
-;;; url-irc.el --- IRC URL interface
+;;; url-irc.el --- IRC URL interface -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -22,7 +22,7 @@
;;; Commentary:
;; IRC URLs are defined in
-;; http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
+;; https://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
;;; Code:
@@ -48,6 +48,8 @@ PASSWORD - What password to use"
;; External.
(declare-function zenirc "ext:zenirc" (&optional prefix))
(declare-function zenirc-send-line "ext:zenirc" ())
+(defvar zenirc-server-alist)
+(defvar zenirc-buffer-name)
(defun url-irc-zenirc (host port channel user password)
(let ((zenirc-buffer-name (if (and user host port)
@@ -65,7 +67,7 @@ PASSWORD - What password to use"
(defun url-irc-rcirc (host port channel user password)
(let ((chan (when channel (concat "#" channel))))
- (rcirc-connect host port user nil nil (when chan (list chan)))
+ (rcirc-connect host port user nil nil (when chan (list chan)) password)
(when chan
(switch-to-buffer (concat chan "@" host)))))
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
index 0fa9970fa47..d26562b7f10 100644
--- a/lisp/url/url-ldap.el
+++ b/lisp/url/url-ldap.el
@@ -1,4 +1,4 @@
-;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
+;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
;; Copyright (C) 1998-1999, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
index 688f102cabd..29c2780121a 100644
--- a/lisp/url/url-mailto.el
+++ b/lisp/url/url-mailto.el
@@ -1,4 +1,4 @@
-;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
+;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -67,7 +67,7 @@
;; mailto:wmperry@gnu.org
(setf (url-filename url) (concat (url-user url) "@" (url-filename url))))
(setq url (url-filename url))
- (let (to args source-url subject func headers-start)
+ (let (to args source-url subject headers-start) ;; func
(if (string-match (regexp-quote "?") url)
(setq headers-start (match-end 0)
to (url-unhex-string (substring url 0 (match-beginning 0)))
@@ -76,10 +76,11 @@
(setq to (url-unhex-string url)))
(setq source-url (url-view-url t))
(if (and url-request-data (not (assoc "subject" args)))
- (setq args (cons (list "subject"
+ (push (list "subject"
(concat "Automatic submission from "
url-package-name "/"
- url-package-version)) args)))
+ url-package-version))
+ args))
(if (and source-url (not (assoc "x-url-from" args)))
(setq args (cons (list "x-url-from" source-url) args)))
@@ -103,11 +104,11 @@
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
(goto-char (point-max)))
(insert (mapconcat
- #'(lambda (string)
- (replace-regexp-in-string "\r\n" "\n" string))
+ (lambda (string)
+ (replace-regexp-in-string "\r\n" "\n" string))
(cdar args) "\n")))
(url-mail-goto-field (caar args))
- (setq func (intern-soft (concat "mail-" (caar args))))
+ ;; (setq func (intern-soft (concat "mail-" (caar args))))
(insert (mapconcat 'identity (cdar args) ", ")))
(setq args (cdr args)))
;; (url-mail-goto-field "User-Agent")
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
index 7aad741210d..cfe7d5bc6a3 100644
--- a/lisp/url/url-methods.el
+++ b/lisp/url/url-methods.el
@@ -1,4 +1,4 @@
-;;; url-methods.el --- Load URL schemes as needed
+;;; url-methods.el --- Load URL schemes as needed -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -57,7 +57,7 @@
'file-exists-p 'ignore
'file-attributes 'ignore))
-(defun url-scheme-default-loader (url &optional callback cbargs)
+(defun url-scheme-default-loader (url &optional _callback _cbargs)
"Signal an error for an unknown URL scheme."
(error "Unknown URL scheme: %s" (url-type url)))
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
index d3db31d612a..fe2393beb64 100644
--- a/lisp/url/url-misc.el
+++ b/lisp/url/url-misc.el
@@ -1,4 +1,4 @@
-;;; url-misc.el --- Misc Uniform Resource Locator retrieval code
+;;; url-misc.el --- Misc Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2002, 2004-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el
index 2ce28ab8875..49cc587590e 100644
--- a/lisp/url/url-news.el
+++ b/lisp/url/url-news.el
@@ -1,4 +1,4 @@
-;;; url-news.el --- News Uniform Resource Locator retrieval code
+;;; url-news.el --- News Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -25,14 +25,8 @@
(require 'url-util)
(require 'url-parse)
(require 'nntp)
-(autoload 'url-warn "url")
(autoload 'gnus-group-read-ephemeral-group "gnus-group")
-;; Unused.
-;;; (defgroup url-news nil
-;;; "News related options."
-;;; :group 'url)
-
(defun url-news-open-host (host port user pass)
(if (fboundp 'nnheader-init-server-buffer)
(nnheader-init-server-buffer))
@@ -42,7 +36,7 @@
(nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
(nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
(if (not (nntp-server-opened host))
- (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
+ (display-warning 'url (format "NNTP authentication to `%s' as `%s' failed"
host user))))))
(defun url-news-fetch-message-id (host message-id)
@@ -75,7 +69,7 @@
" </div>\n"
" </body>\n"
"</html>\n"
- "<!-- Automatically generated by URL v" url-version " -->\n"
+ "<!-- Automatically generated by URL in Emacs " emacs-version " -->\n"
)))
buf))
@@ -107,7 +101,7 @@
;; Find a news reference
(let* ((host (or (url-host url) url-news-server))
(port (url-port url))
- (article-brackets nil)
+ ;; (article-brackets nil)
(buf nil)
(article (url-unhex-string (url-filename url))))
(url-news-open-host host port (url-user url) (url-password url))
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
index 3c80c8059b5..0449930408d 100644
--- a/lisp/url/url-nfs.el
+++ b/lisp/url/url-nfs.el
@@ -1,4 +1,4 @@
-;;; url-nfs.el --- NFS URL interface
+;;; url-nfs.el --- NFS URL interface -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index e3ca0f66d98..d926775c48d 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -1,4 +1,4 @@
-;;; url-privacy.el --- Global history tracking for URL package
+;;; url-privacy.el --- Global history tracking for URL package -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -23,7 +23,7 @@
(require 'url-vars)
-(defun url-device-type (&optional device)
+(defun url-device-type (&optional _device)
(declare (obsolete nil "27.1"))
(or window-system 'tty))
diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el
index 6959bd68044..c89c1b6bc3e 100644
--- a/lisp/url/url-proxy.el
+++ b/lisp/url/url-proxy.el
@@ -1,4 +1,4 @@
-;;; url-proxy.el --- Proxy server support
+;;; url-proxy.el --- Proxy server support -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2004-2021 Free Software Foundation, Inc.
@@ -22,7 +22,6 @@
;;; Code:
(require 'url-parse)
-(autoload 'url-warn "url")
(defun url-default-find-proxy-for-url (urlobj host)
(cond
@@ -50,17 +49,15 @@
;; Not sure how I should handle gracefully degrading from one proxy to
;; another, so for now just deal with the first one
;; (while proxies
- (if (listp proxies)
- (setq proxy (car proxies))
- (setq proxy proxies))
+ (setq proxy (if (listp proxies) (car proxies) proxies))
(cond
- ((string-match "^direct" proxy) nil)
- ((string-match "^proxy +" proxy)
+ ((string-match "^DIRECT" proxy) nil)
+ ((string-match "^PROXY +" proxy)
(concat "http://" (substring proxy (match-end 0)) "/"))
- ((string-match "^socks +" proxy)
+ ((string-match "^SOCKS +" proxy)
(concat "socks://" (substring proxy (match-end 0))))
(t
- (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical)
+ (display-warning 'url (format "Unknown proxy directive: %s" proxy) :error)
nil))))
(autoload 'url-http "url-http")
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index ee337693097..0923731ad8e 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -123,17 +123,24 @@ The variable `url-queue-timeout' sets a timeout."
(setq url-queue-progress-timer nil))))
(defun url-queue-callback-function (status job)
- (setq url-queue (delq job url-queue))
- (when (and (eq (car status) :error)
- (eq (cadr (cadr status)) 'connection-failed))
- ;; If we get a connection error, then flush all other jobs from
- ;; the host from the queue. This particularly makes sense if the
- ;; error really is a DNS resolver issue, which happens
- ;; synchronously and totally halts Emacs.
- (url-queue-remove-jobs-from-host
- (plist-get (nthcdr 3 (cadr status)) :host)))
- (url-queue-run-queue)
- (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
+ (let ((buffer (current-buffer)))
+ (setq url-queue (delq job url-queue))
+ (when (and (eq (car status) :error)
+ (eq (cadr (cadr status)) 'connection-failed))
+ ;; If we get a connection error, then flush all other jobs from
+ ;; the host from the queue. This particularly makes sense if the
+ ;; error really is a DNS resolver issue, which happens
+ ;; synchronously and totally halts Emacs.
+ (url-queue-remove-jobs-from-host
+ (plist-get (nthcdr 3 (cadr status)) :host)))
+ (url-queue-run-queue)
+ ;; Somehow something deep in the bowels in the URL library may
+ ;; have killed off the current buffer. So check that it's still
+ ;; alive before doing anything, and if not, just create a dummy
+ ;; buffer and do the callback anyway.
+ (unless (buffer-live-p buffer)
+ (set-buffer (generate-new-buffer " *temp*")))
+ (apply (url-queue-callback job) (cons status (url-queue-cbargs job)))))
(defun url-queue-remove-jobs-from-host (host)
(let ((jobs nil))
diff --git a/lisp/url/url-tramp.el b/lisp/url/url-tramp.el
index 325d25cb8e2..5b9dd8a2682 100644
--- a/lisp/url/url-tramp.el
+++ b/lisp/url/url-tramp.el
@@ -1,4 +1,4 @@
-;;; url-tramp.el --- file-name-handler magic invoking Tramp for some protocols
+;;; url-tramp.el --- file-name-handler magic invoking Tramp for some protocols -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 85574aa28d3..8b79736d004 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -335,10 +335,13 @@ instead of just \"key\" as in the example above."
;;;###autoload
(defun url-unhex-string (str &optional allow-newlines)
- "Remove %XX embedded spaces, etc in a URL.
+ "Decode %XX sequences in a percent-encoded URL.
If optional second argument ALLOW-NEWLINES is non-nil, then allow the
decoding of carriage returns and line feeds in the string, which is normally
-forbidden in URL encoding."
+forbidden in URL encoding.
+
+The resulting string in general requires decoding using an
+appropriate coding-system; see `decode-coding-string'."
(setq str (or str ""))
(let ((tmp "")
(case-fold-search t))
@@ -569,38 +572,13 @@ Has a preference for looking backward when not directly on a symbol."
(setq url nil))
url)))
-(defun url-generate-unique-filename (&optional fmt)
- "Generate a unique filename in `url-temporary-directory'."
- (declare (obsolete make-temp-file "23.1"))
- ;; This variable is obsolete, but so is this function.
- (let ((tempdir (with-no-warnings url-temporary-directory)))
- (if (not fmt)
- (let ((base (format "url-tmp.%d" (user-real-uid)))
- (fname "")
- (x 0))
- (setq fname (format "%s%d" base x))
- (while (file-exists-p
- (expand-file-name fname tempdir))
- (setq x (1+ x)
- fname (concat base (int-to-string x))))
- (expand-file-name fname tempdir))
- (let ((base (concat "url" (int-to-string (user-real-uid))))
- (fname "")
- (x 0))
- (setq fname (format fmt (concat base (int-to-string x))))
- (while (file-exists-p
- (expand-file-name fname tempdir))
- (setq x (1+ x)
- fname (format fmt (concat base (int-to-string x)))))
- (expand-file-name fname tempdir)))))
-
(defun url-extract-mime-headers ()
"Set `url-current-mime-headers' in current buffer."
(save-excursion
(goto-char (point-min))
(unless url-current-mime-headers
- (set (make-local-variable 'url-current-mime-headers)
- (mail-header-extract)))))
+ (setq-local url-current-mime-headers
+ (mail-header-extract)))))
(defun url-make-private-file (file)
"Make FILE only readable and writable by the current user.
@@ -615,9 +593,7 @@ Creates FILE and its parent directories if they do not exist."
(with-temp-buffer
(write-region (point-min) (point-max) file nil 'silent nil 'excl)))
(file-already-exists
- (if (file-symlink-p file)
- (error "Danger: `%s' is a symbolic link" file))
- (set-file-modes file #o0600))))
+ (set-file-modes file #o0600 'nofollow))))
(autoload 'puny-encode-domain "puny")
(autoload 'url-domsuf-cookie-allowed-p "url-domsuf")
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index debe98c0b11..2aa2e7912f5 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -1,4 +1,4 @@
-;;; url-vars.el --- Variables for Uniform Resource Locator tool
+;;; url-vars.el --- Variables for Uniform Resource Locator tool -*- lexical-binding:t -*-
;; Copyright (C) 1996-1999, 2001, 2004-2021 Free Software Foundation,
;; Inc.
@@ -22,9 +22,6 @@
;;; Code:
-(defconst url-version "Emacs"
- "Version number of URL package.")
-
(defgroup url nil
"Uniform Resource Locator tool."
:version "22.1"
@@ -54,26 +51,19 @@
:group 'url)
-(defvar url-current-object nil
+(defvar-local url-current-object nil
"A parsed representation of the current URL.")
-(defvar url-current-mime-headers nil
+(defvar-local url-current-mime-headers nil
"A parsed representation of the MIME headers for the current URL.")
-(defvar url-current-lastloc nil
+(defvar-local url-current-lastloc nil
"A parsed representation of the URL to be considered as the last location.
Use of this value on outbound connections is subject to
`url-privacy-level' and `url-lastloc-privacy-level'. This is never set
by the url library, applications are expected to set this
variable in buffers representing a displayed location.")
-(mapc 'make-variable-buffer-local
- '(
- url-current-object
- url-current-mime-headers
- url-current-lastloc
- ))
-
(defcustom url-honor-refresh-requests t
"Whether to do automatic page reloads.
These are done at the request of the document author or the server via
@@ -311,13 +301,6 @@ 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."
- :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.
Can cause a large hit if using a remote X display over a slow link, or
@@ -430,6 +413,8 @@ Should be one of:
"Hook run after initializing the URL library."
:group 'url
:type 'hook)
+(make-obsolete-variable 'url-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defconst url-working-buffer " *url-work")
@@ -438,6 +423,11 @@ Should be one of:
This should be set, e.g. by mail user agents rendering HTML to avoid
`bugs' which call home.")
+;; Obsolete
+
+(defconst url-version "Emacs" "Version number of URL package.")
+(make-obsolete-variable 'url-version 'emacs-version "28.1")
+
(provide 'url-vars)
;;; url-vars.el ends here
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 51503b867a4..a6565e2cdb6 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -24,7 +24,7 @@
;;; Commentary:
-;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
+;; Registered URI schemes: https://www.iana.org/assignments/uri-schemes
;;; Code:
@@ -156,16 +156,16 @@ If INHIBIT-COOKIES, cookies will neither be stored nor sent to
the server.
If URL is a multibyte string, it will be encoded as utf-8 and
URL-encoded before it's used."
-;;; 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,
-;;; url-confirmation-func, url-cookie-multiple-line,
-;;; url-cookie-{{,secure-}storage,confirmation}
-;;; url-standalone-mode and url-gateway-unplugged should work as
-;;; usual. url-confirmation-func is only used in nnwarchive.el and
-;;; 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.
+ ;; 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,
+ ;; url-confirmation-func, url-cookie-multiple-line,
+ ;; url-cookie-{{,secure-}storage,confirmation}
+ ;; url-standalone-mode and url-gateway-unplugged should work as
+ ;; usual. url-confirmation-func is only used in nnwarchive.el and
+ ;; 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) silent
inhibit-cookies))
@@ -208,9 +208,10 @@ URL-encoded before it's used."
(url-find-proxy-for-url url (url-host url))))
(buffer nil)
(asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
- (if url-using-proxy
- (setq asynch t
- loader 'url-proxy))
+ (when url-using-proxy
+ (setf asynch t
+ loader #'url-proxy
+ (url-asynchronous url) t))
(if asynch
(let ((url-current-object url))
(setq buffer (funcall loader url callback cbargs)))
@@ -238,7 +239,8 @@ how long to wait for a response before giving up."
(let ((retrieval-done nil)
(start-time (current-time))
(url-asynchronous nil)
- (asynch-buffer nil))
+ (asynch-buffer nil)
+ (timed-out nil))
(setq asynch-buffer
(url-retrieve url (lambda (&rest ignored)
(url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
@@ -261,7 +263,9 @@ how long to wait for a response before giving up."
;; process output.
(while (and (not retrieval-done)
(or (not timeout)
- (time-less-p (time-since start-time) timeout)))
+ (not (setq timed-out
+ (time-less-p timeout
+ (time-since start-time))))))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
retrieval-done asynch-buffer)
@@ -300,8 +304,16 @@ how long to wait for a response before giving up."
(when quit-flag
(delete-process proc))
(setq proc (and (not quit-flag)
- (get-buffer-process asynch-buffer)))))))
- asynch-buffer)))
+ (get-buffer-process asynch-buffer))))))
+ ;; On timeouts, make sure we kill any pending processes.
+ ;; There may be more than one if we had a redirect.
+ (when timed-out
+ (when (process-live-p proc)
+ (delete-process proc))
+ (when-let ((aproc (get-buffer-process asynch-buffer)))
+ (when (process-live-p aproc)
+ (delete-process aproc))))))
+ asynch-buffer))
;; url-mm-callback called from url-mm, which requires mm-decode.
(declare-function mm-dissect-buffer "mm-decode"
@@ -354,19 +366,7 @@ how long to wait for a response before giving up."
(if (buffer-live-p buff)
(kill-buffer buff)))))
-(cond
- ((fboundp 'display-warning)
- (defalias 'url-warn 'display-warning))
- ((fboundp 'warn)
- (defun url-warn (class message &optional level)
- (warn "(%s/%s) %s" class (or level 'warning) message)))
- (t
- (defun url-warn (class message &optional level)
- (with-current-buffer (get-buffer-create "*URL-WARNINGS*")
- (goto-char (point-max))
- (save-excursion
- (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
- (display-buffer (current-buffer))))))
+(define-obsolete-function-alias 'url-warn #'display-warning "28.1")
(provide 'url)
diff --git a/lisp/userlock.el b/lisp/userlock.el
index ef0a2dd9448..38aaf6aec23 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -1,4 +1,4 @@
-;;; userlock.el --- handle file access contention between multiple users
+;;; userlock.el --- handle file access contention between multiple users -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 2001-2021 Free Software Foundation, Inc.
@@ -39,6 +39,10 @@
(define-error 'file-locked "File is locked" 'file-error)
+(defun userlock--fontify-key (key)
+ "Add the `help-key-binding' face to string KEY."
+ (propertize key 'face 'help-key-binding))
+
;;;###autoload
(defun ask-user-about-lock (file opponent)
"Ask user what to do when he wants to edit FILE but it is locked by OPPONENT.
@@ -64,8 +68,12 @@ in any way you like."
(match-string 0 opponent)))
opponent))
(while (null answer)
- (message "%s locked by %s: (s, q, p, ?)? "
- short-file short-opponent)
+ (message "%s locked by %s: (%s, %s, %s, %s)? "
+ short-file short-opponent
+ (userlock--fontify-key "s")
+ (userlock--fontify-key "q")
+ (userlock--fontify-key "p")
+ (userlock--fontify-key "?"))
(if noninteractive (error "Cannot resolve lock conflict in batch mode"))
(let ((tem (let ((inhibit-quit t)
(cursor-in-echo-area t))
@@ -80,7 +88,12 @@ in any way you like."
(?? . help))))
(cond ((null answer)
(beep)
- (message "Please type q, s, or p; or ? for help")
+ (message "Please type %s, %s, or %s; or %s for help"
+ (userlock--fontify-key "q")
+ (userlock--fontify-key "s")
+ (userlock--fontify-key "p")
+ ;; FIXME: Why do we use "?" here and "C-h" below?
+ (userlock--fontify-key "?"))
(sit-for 3))
((eq (cdr answer) 'help)
(ask-user-about-lock-help)
@@ -91,14 +104,19 @@ in any way you like."
(defun ask-user-about-lock-help ()
(with-output-to-temp-buffer "*Help*"
- (princ "It has been detected that you want to modify a file that someone else has
+ (with-current-buffer standard-output
+ (insert
+ (format
+ "It has been detected that you want to modify a file that someone else has
already started modifying in Emacs.
-You can <s>teal the file; the other user becomes the
+You can <%s>teal the file; the other user becomes the
intruder if (s)he ever unmodifies the file and then changes it again.
-You can <p>roceed; you edit at your own (and the other user's) risk.
-You can <q>uit; don't modify this file.")
- (with-current-buffer standard-output
+You can <%s>roceed; you edit at your own (and the other user's) risk.
+You can <%s>uit; don't modify this file."
+ (userlock--fontify-key "s")
+ (userlock--fontify-key "p")
+ (userlock--fontify-key "q")))
(help-mode))))
(define-error 'file-supersession nil 'file-error)
@@ -151,15 +169,20 @@ The buffer in question is current when this function is called."
(save-window-excursion
(let ((prompt
(format "%s changed on disk; \
-really edit the buffer? (y, n, r or C-h) "
- (file-name-nondirectory filename)))
+really edit the buffer? (%s, %s, %s or %s) "
+ (file-name-nondirectory filename)
+ (userlock--fontify-key "y")
+ (userlock--fontify-key "n")
+ (userlock--fontify-key "r")
+ ;; FIXME: Why do we use "C-h" here and "?" above?
+ (userlock--fontify-key "C-h")))
(choices '(?y ?n ?r ?? ?\C-h))
answer)
(when noninteractive
(message "%s" prompt)
(error "Cannot resolve conflict in batch mode"))
(while (null answer)
- (setq answer (read-char-from-minibuffer prompt choices))
+ (setq answer (read-char-choice prompt choices))
(cond ((memq answer '(?? ?\C-h))
(ask-user-about-supersession-help)
(setq answer nil))
@@ -177,20 +200,38 @@ really edit the buffer? (y, n, r or C-h) "
(defun ask-user-about-supersession-help ()
(with-output-to-temp-buffer "*Help*"
- (princ
- (substitute-command-keys
- "You want to modify a buffer whose disk file has changed
+ (let ((revert-buffer-binding
+ ;; This takes place in the original buffer.
+ (substitute-command-keys "\\[revert-buffer]")))
+ (with-current-buffer standard-output
+ (insert
+ (format
+ "You want to modify a buffer whose disk file has changed
since you last read it in or saved it with this buffer.
-If you say `y' to go ahead and modify this buffer,
+If you say %s to go ahead and modify this buffer,
you risk ruining the work of whoever rewrote the file.
-If you say `r' to revert, the contents of the buffer are refreshed
+If you say %s to revert, the contents of the buffer are refreshed
from the file on disk.
-If you say `n', the change you started to make will be aborted.
+If you say %s, the change you started to make will be aborted.
-Usually, you should type `n' and then `\\[revert-buffer]',
-to get the latest version of the file, then make the change again."))
- (with-current-buffer standard-output
- (help-mode))))
+Usually, you should type %s and then %s,
+to get the latest version of the file, then make the change again."
+ (userlock--fontify-key "y")
+ (userlock--fontify-key "r")
+ (userlock--fontify-key "n")
+ (userlock--fontify-key "n")
+ revert-buffer-binding))
+ (help-mode)))))
+
+;;;###autoload
+(defun userlock--handle-unlock-error (error)
+ "Report an ERROR that occurred while unlocking a file."
+ (display-warning
+ '(unlock-file)
+ ;; There is no need to explain that this is an unlock error because
+ ;; ERROR is a `file-error' condition, which explains this.
+ (message "%s, ignored" (error-message-string error))
+ :warning))
;;; userlock.el ends here
diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el
index e4c170dfb41..2e20284951f 100644
--- a/lisp/vc/add-log.el
+++ b/lisp/vc/add-log.el
@@ -1,4 +1,4 @@
-;;; add-log.el --- change log maintenance commands for Emacs
+;;; add-log.el --- change log maintenance commands for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1988, 1993-1994, 1997-1998, 2000-2021 Free
;; Software Foundation, Inc.
@@ -49,15 +49,13 @@
(defcustom change-log-default-name nil
"Name of a change log file for \\[add-change-log-entry]."
:type '(choice (const :tag "default" nil)
- string)
- :group 'change-log)
+ string))
;;;###autoload
-(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
+(put 'change-log-default-name 'safe-local-variable #'string-or-null-p)
(defcustom change-log-mode-hook nil
"Normal hook run by `change-log-mode'."
- :type 'hook
- :group 'change-log)
+ :type 'hook)
;; Many modes set this variable, so avoid warnings.
;;;###autoload
@@ -66,16 +64,14 @@
It is called by `add-log-current-defun' with no argument, and
should return the function's name as a string, or nil if point is
outside a function."
- :type '(choice (const nil) function)
- :group 'change-log)
+ :type '(choice (const nil) function))
;;;###autoload
(defcustom add-log-full-name nil
"Full name of user, for inclusion in ChangeLog daily headers.
This defaults to the value returned by the function `user-full-name'."
:type '(choice (const :tag "Default" nil)
- string)
- :group 'change-log)
+ string))
;;;###autoload
(defcustom add-log-mailing-address nil
@@ -86,8 +82,7 @@ will be recognized as referring to the same user; when creating a new
ChangeLog entry, one element will be chosen at random."
:type '(choice (const :tag "Default" nil)
(string :tag "String")
- (repeat :tag "List of Strings" string))
- :group 'change-log)
+ (repeat :tag "List of Strings" string)))
(defcustom add-log-time-format 'add-log-iso8601-time-string
"Function that defines the time format.
@@ -98,8 +93,7 @@ and `current-time-string' are two valid values."
add-log-iso8601-time-string)
(const :tag "Old format, as returned by `current-time-string'"
current-time-string)
- (function :tag "Other"))
- :group 'change-log)
+ (function :tag "Other")))
(defcustom add-log-keep-changes-together nil
"If non-nil, normally keep day's log entries for one file together.
@@ -130,14 +124,12 @@ and in the former:
The NEW-ENTRY arg to `add-change-log-entry' can override the effect of
this variable."
:version "20.3"
- :type 'boolean
- :group 'change-log)
+ :type 'boolean)
(defcustom add-log-always-start-new-record nil
"If non-nil, `add-change-log-entry' will always start a new record."
:version "22.1"
- :type 'boolean
- :group 'change-log)
+ :type 'boolean)
(defvar add-log-buffer-file-name-function 'buffer-file-name
"If non-nil, function to call to identify the full filename of a buffer.
@@ -149,15 +141,13 @@ use `buffer-file-name'.")
This function is called with one argument, the value of variable
`buffer-file-name' in that buffer. If this is nil, the default is to
use the file's name relative to the directory of the change log file."
- :type '(choice (const nil) function)
- :group 'change-log)
+ :type '(choice (const nil) function))
(defcustom change-log-version-info-enabled nil
"If non-nil, enable recording version numbers with the changes."
:version "21.1"
- :type 'boolean
- :group 'change-log)
+ :type 'boolean)
(defcustom change-log-version-number-regexp-list
(let ((re "\\([0-9]+\\.[0-9.]+\\)"))
@@ -170,64 +160,54 @@ use the file's name relative to the directory of the change log file."
The version number must be in group 1.
Note: The search is conducted only within 10%, at the beginning of the file."
:version "21.1"
- :type '(repeat regexp)
- :group 'change-log)
+ :type '(repeat regexp))
(defcustom change-log-directory-files '(".bzr" ".git" ".hg" ".svn")
"List of files that cause `find-change-log' to stop in containing directory.
This applies if no pre-existing ChangeLog is found. If nil, then in such
a case simply use the directory containing the changed file."
:version "26.1"
- :type '(repeat file)
- :group 'change-log)
+ :type '(repeat file))
(defface change-log-date
'((t (:inherit font-lock-string-face)))
"Face used to highlight dates in date lines."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-name
'((t (:inherit font-lock-constant-face)))
"Face for highlighting author names."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-email
'((t (:inherit font-lock-variable-name-face)))
"Face for highlighting author email addresses."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-file
'((t (:inherit font-lock-function-name-face)))
"Face for highlighting file names."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-list
'((t (:inherit font-lock-keyword-face)))
"Face for highlighting parenthesized lists of functions or variables."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-conditionals
'((t (:inherit font-lock-variable-name-face)))
"Face for highlighting conditionals of the form `[...]'."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-function
'((t (:inherit font-lock-variable-name-face)))
"Face for highlighting items of the form `<....>'."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(defface change-log-acknowledgment
'((t (:inherit font-lock-comment-face)))
"Face for highlighting acknowledgments."
- :version "21.1"
- :group 'change-log)
+ :version "21.1")
(define-obsolete-face-alias 'change-log-acknowledgement
'change-log-acknowledgment "24.3")
@@ -519,7 +499,7 @@ try to visit the file for the change under `point' instead."
change-log-find-tail)
(setq change-log-find-tail
(condition-case nil
- (apply 'change-log-goto-source-1
+ (apply #'change-log-goto-source-1
(append change-log-find-head change-log-find-tail))
(error
(format-message
@@ -556,7 +536,7 @@ try to visit the file for the change under `point' instead."
file (find-file-noselect file)))
(condition-case nil
(setq change-log-find-tail
- (apply 'change-log-goto-source-1 change-log-find-head))
+ (apply #'change-log-goto-source-1 change-log-find-head))
(error
(format-message "Cannot find matches for tag `%s' in file `%s'"
tag file)))))))))
@@ -569,7 +549,7 @@ Compatibility function for \\[next-error] invocations."
(count (abs argp)) ; how many cycles
(down (< argp 0)) ; are we going down? (is argp negative?)
(up (not down))
- (search-function (if up 're-search-forward 're-search-backward)))
+ (search-function (if up #'re-search-forward #'re-search-backward)))
;; set the starting position
(goto-char (cond (reset (point-min))
@@ -589,29 +569,27 @@ Compatibility function for \\[next-error] invocations."
(select-window change-log-find-window)))))
(defvar change-log-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
- (define-key map [?\C-c ?\C-p] 'add-log-edit-prev-comment)
- (define-key map [?\C-c ?\C-n] 'add-log-edit-next-comment)
- (define-key map [?\C-c ?\C-f] 'change-log-find-file)
- (define-key map [?\C-c ?\C-c] 'change-log-goto-source)
- (define-key map [menu-bar changelog] (cons "ChangeLog" menu-map))
- (define-key menu-map [gs]
- '(menu-item "Go To Source" change-log-goto-source
- :help "Go to source location of ChangeLog tag near point"))
- (define-key menu-map [ff]
- '(menu-item "Find File" change-log-find-file
- :help "Visit the file for the change under point"))
- (define-key menu-map [sep] '("--"))
- (define-key menu-map [nx]
- '(menu-item "Next Log-Edit Comment" add-log-edit-next-comment
- :help "Cycle forward through Log-Edit mode comment history"))
- (define-key menu-map [pr]
- '(menu-item "Previous Log-Edit Comment" add-log-edit-prev-comment
- :help "Cycle backward through Log-Edit mode comment history"))
+ (let ((map (make-sparse-keymap)))
+ (define-key map [?\C-c ?\C-p] #'add-log-edit-prev-comment)
+ (define-key map [?\C-c ?\C-n] #'add-log-edit-next-comment)
+ (define-key map [?\C-c ?\C-f] #'change-log-find-file)
+ (define-key map [?\C-c ?\C-c] #'change-log-goto-source)
map)
"Keymap for Change Log major mode.")
+(easy-menu-define change-log-mode-menu change-log-mode-map
+ "Menu for Change Log major mode."
+ '("ChangeLog"
+ ["Previous Log-Edit Comment" add-log-edit-prev-comment
+ :help "Cycle backward through Log-Edit mode comment history"]
+ ["Next Log-Edit Comment" add-log-edit-next-comment
+ :help "Cycle forward through Log-Edit mode comment history"]
+ "---"
+ ["Find File" change-log-find-file
+ :help "Visit the file for the change under point"]
+ ["Go To Source" change-log-goto-source
+ :help "Go to source location of ChangeLog tag near point"]))
+
;; It used to be called change-log-time-zone-rule but really should be
;; called add-log-time-zone-rule since it's only used from add-log-* code.
(defvaralias 'change-log-time-zone-rule 'add-log-time-zone-rule)
@@ -667,7 +645,7 @@ With a numeric prefix ARG, go back ARG comments."
"Prompt for a change log name."
(let* ((default (change-log-name))
(name (expand-file-name
- (read-file-name (format "Log file (default %s): " default)
+ (read-file-name (format-prompt "Log file" default)
nil default))))
;; Handle something that is syntactically a directory name.
;; Look for ChangeLog or whatever in that directory.
@@ -779,7 +757,7 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'."
found)))))))
(if root (setq file-name (expand-file-name cbase root))))))
;; Make a local variable in this buffer so we needn't search again.
- (set (make-local-variable 'change-log-default-name) file-name))
+ (setq-local change-log-default-name file-name))
file-name)
(defun add-log-file-name (buffer-file log-file)
@@ -814,7 +792,7 @@ means to put log entries in a suitably named buffer."
:type 'boolean
:version "27.1")
-(put 'add-log-dont-create-changelog-file 'safe-local-variable 'booleanp)
+(put 'add-log-dont-create-changelog-file 'safe-local-variable #'booleanp)
(defun add-log--pseudo-changelog-buffer-name (changelog-file-name)
"Compute a suitable name for a non-file visiting ChangeLog buffer.
@@ -1134,40 +1112,40 @@ Runs `change-log-mode-hook'.
indent-tabs-mode t
tab-width 8
show-trailing-whitespace t)
- (set (make-local-variable 'fill-forward-paragraph-function)
- 'change-log-fill-forward-paragraph)
- (set (make-local-variable 'comment-start) nil)
+ (setq-local fill-forward-paragraph-function
+ 'change-log-fill-forward-paragraph)
+ (setq-local comment-start nil)
;; Make sure we call `change-log-indent' when filling.
- (set (make-local-variable 'fill-indent-according-to-mode) t)
+ (setq-local fill-indent-according-to-mode t)
;; Avoid that filling leaves behind a single "*" on a line.
(add-hook 'fill-nobreak-predicate
(lambda ()
(looking-back "^\\s *\\*\\s *" (line-beginning-position)))
nil t)
- (set (make-local-variable 'indent-line-function) 'change-log-indent)
- (set (make-local-variable 'tab-always-indent) nil)
- (set (make-local-variable 'copyright-at-end-flag) t)
+ (setq-local indent-line-function 'change-log-indent)
+ (setq-local tab-always-indent nil)
+ (setq-local copyright-at-end-flag t)
;; We really do want "^" in paragraph-start below: it is only the
;; lines that begin at column 0 (despite the left-margin of 8) that
;; we are looking for. Adding `* ' allows eliding the blank line
;; between entries for different files.
- (set (make-local-variable 'paragraph-start) "\\s *$\\|\f\\|^\\<")
- (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (setq-local paragraph-start "\\s *$\\|\f\\|^\\<")
+ (setq-local paragraph-separate paragraph-start)
;; Match null string on the date-line so that the date-line
;; is grouped with what follows.
- (set (make-local-variable 'page-delimiter) "^\\<\\|^\f")
- (set (make-local-variable 'version-control) 'never)
- (set (make-local-variable 'smerge-resolve-function)
- 'change-log-resolve-conflict)
- (set (make-local-variable 'adaptive-fill-regexp) "\\s *")
- (set (make-local-variable 'font-lock-defaults)
- '(change-log-font-lock-keywords t nil nil backward-paragraph))
- (set (make-local-variable 'multi-isearch-next-buffer-function)
- 'change-log-next-buffer)
- (set (make-local-variable 'beginning-of-defun-function)
- 'change-log-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function)
- 'change-log-end-of-defun)
+ (setq-local page-delimiter "^\\<\\|^\f")
+ (setq-local version-control 'never)
+ (setq-local smerge-resolve-function
+ 'change-log-resolve-conflict)
+ (setq-local adaptive-fill-regexp "\\s *")
+ (setq-local font-lock-defaults
+ '(change-log-font-lock-keywords t nil nil backward-paragraph))
+ (setq-local multi-isearch-next-buffer-function
+ 'change-log-next-buffer)
+ (setq-local beginning-of-defun-function
+ 'change-log-beginning-of-defun)
+ (setq-local end-of-defun-function
+ 'change-log-end-of-defun)
;; next-error function glue
(setq next-error-function 'change-log-next-error))
@@ -1216,12 +1194,11 @@ file were isearch was started."
(forward-paragraph n)))
(defcustom add-log-current-defun-header-regexp
- "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alpha:]]+\\)[ \t]*[:=]"
+ "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alnum:]]*[[:alpha:]][-_[:alnum:]]*\\)[ \t]*[:=]"
"Heuristic regexp used by `add-log-current-defun' for unknown major modes.
The regexp's first submatch is placed in the ChangeLog entry, in
parentheses."
- :type 'regexp
- :group 'change-log)
+ :type 'regexp)
(declare-function c-cpp-define-name "cc-cmds" ())
(declare-function c-defun-name "cc-cmds" ())
diff --git a/lisp/vc/compare-w.el b/lisp/vc/compare-w.el
index 932dcd78920..4c1d9eaad55 100644
--- a/lisp/vc/compare-w.el
+++ b/lisp/vc/compare-w.el
@@ -1,4 +1,4 @@
-;;; compare-w.el --- compare text between windows for Emacs
+;;; compare-w.el --- compare text between windows for Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1986, 1989, 1993, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@@ -52,19 +52,16 @@ any text before that point.
If the function returns the same value for both windows, then the
whitespace is considered to match, and is skipped."
:version "24.4" ; added \240
- :type '(choice regexp function)
- :group 'compare-windows)
+ :type '(choice regexp function))
(defcustom compare-ignore-whitespace nil
"Non-nil means command `compare-windows' ignores whitespace."
:type 'boolean
- :group 'compare-windows
:version "22.1")
(defcustom compare-ignore-case nil
"Non-nil means command `compare-windows' ignores case differences."
- :type 'boolean
- :group 'compare-windows)
+ :type 'boolean)
(defcustom compare-windows-sync 'compare-windows-sync-default-function
"Function or regexp that is used to synchronize points in two
@@ -92,7 +89,6 @@ If the value of this variable is nil (option \"No sync\"), then
no synchronization is performed, and the function `ding' is called
to beep or flash the screen when points are mismatched."
:type '(choice function regexp (const :tag "No sync" nil))
- :group 'compare-windows
:version "22.1")
(defcustom compare-windows-sync-string-size 32
@@ -104,7 +100,6 @@ difference regions more coarse-grained.
The default value 32 is good for the most cases."
:type 'integer
- :group 'compare-windows
:version "22.1")
(defcustom compare-windows-recenter nil
@@ -115,7 +110,6 @@ matching points side-by-side.
The value `(-1 0)' is useful if windows are split vertically,
and the value `((4) (4))' for horizontally split windows."
:type '(list sexp sexp)
- :group 'compare-windows
:version "22.1")
(defcustom compare-windows-highlight t
@@ -127,19 +121,16 @@ out all highlighting later with the command `compare-windows-dehighlight'."
:type '(choice (const :tag "No highlighting" nil)
(const :tag "Persistent highlighting" persistent)
(other :tag "Highlight until next command" t))
- :group 'compare-windows
:version "22.1")
(defface compare-windows-removed
'((t :inherit diff-removed))
"Face for highlighting `compare-windows' differing regions in the other window."
- :group 'compare-windows
:version "25.1")
(defface compare-windows-added
'((t :inherit diff-added))
"Face for highlighting `compare-windows' differing regions in current window."
- :group 'compare-windows
:version "25.1")
(define-obsolete-face-alias 'compare-windows 'compare-windows-added "25.1")
@@ -159,7 +150,6 @@ out all highlighting later with the command `compare-windows-dehighlight'."
(function-item :tag "Next window"
compare-windows-get-next-window)
(function :tag "Your function"))
- :group 'compare-windows
:version "25.1")
(defun compare-windows-get-recent-window ()
@@ -389,7 +379,7 @@ on third call it again advances points to the next difference and so on."
(setq p1 (1+ p1)))))
(when p12s
;; use closest matching points (i.e. points with minimal sum)
- (setq p12 (cdr (assq (apply 'min (mapcar 'car p12s)) p12s)))
+ (setq p12 (cdr (assq (apply #'min (mapcar #'car p12s)) p12s)))
(goto-char (car p12))
(compare-windows-highlight op1 (car p12) (current-buffer) w1
op2 (cadr p12) b2 w2))
@@ -416,7 +406,7 @@ on third call it again advances points to the next difference and so on."
(overlay-put compare-windows-overlay2 'window w2)
(if (not (eq compare-windows-highlight 'persistent))
;; Remove highlighting before next command is executed
- (add-hook 'pre-command-hook 'compare-windows-dehighlight)
+ (add-hook 'pre-command-hook #'compare-windows-dehighlight)
(when compare-windows-overlay1
(push (copy-overlay compare-windows-overlay1) compare-windows-overlays1)
(delete-overlay compare-windows-overlay1))
@@ -427,9 +417,9 @@ on third call it again advances points to the next difference and so on."
(defun compare-windows-dehighlight ()
"Remove highlighting created by function `compare-windows-highlight'."
(interactive)
- (remove-hook 'pre-command-hook 'compare-windows-dehighlight)
- (mapc 'delete-overlay compare-windows-overlays1)
- (mapc 'delete-overlay compare-windows-overlays2)
+ (remove-hook 'pre-command-hook #'compare-windows-dehighlight)
+ (mapc #'delete-overlay compare-windows-overlays1)
+ (mapc #'delete-overlay compare-windows-overlays2)
(and compare-windows-overlay1 (delete-overlay compare-windows-overlay1))
(and compare-windows-overlay2 (delete-overlay compare-windows-overlay2)))
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el
index c24c863f0f2..63b886362ba 100644
--- a/lisp/vc/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -28,7 +28,7 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(require 'pcvs-util)
;;;
@@ -92,8 +92,8 @@
;;;###autoload
(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
"Mode used for cvs status output."
- (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
- (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
+ (setq-local font-lock-defaults cvs-status-font-lock-defaults)
+ (setq-local cvs-minor-wrap-function #'cvs-status-minor-wrap))
;; Define cvs-status-next and cvs-status-prev
(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
@@ -169,7 +169,7 @@
name
type)
-(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
+(defsubst cvs-status-vl-to-str (vl) (mapconcat #'number-to-string vl "."))
(defun cvs-tag->string (tag)
(if (stringp tag) tag
@@ -283,7 +283,7 @@ BEWARE: because of stability issues, this is not a symmetric operation."
tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
(defun cvs-tag-make-tag (tag)
- (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
+ (let ((vl (mapcar #'string-to-number (split-string (nth 2 tag) "\\."))))
(cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
(defun cvs-tags->tree (tags)
@@ -356,9 +356,8 @@ the list is a three-string list TAG, KIND, REV."
(defvar font-lock-mode)
;; (defun cvs-refontify (beg end)
-;; (when (and (boundp 'font-lock-mode)
-;; font-lock-mode
-;; (fboundp 'font-lock-fontify-region))
+;; (when (and font-lock-mode
+;; (fboundp 'font-lock-fontify-region))
;; (font-lock-fontify-region (1- beg) (1+ end))))
(defun cvs-status-trees ()
@@ -451,10 +450,10 @@ Optional prefix ARG chooses between two representations."
(tags nil)
(cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
(while (listp (setq tags (cvs-status-get-tags)))
- (let ((tags (mapcar 'cvs-tag-make-tag tags))
+ (let ((tags (mapcar #'cvs-tag-make-tag tags))
;;(pt (save-excursion (forward-line -1) (point)))
)
- (setq tags (sort tags 'cvs-tag-lessp))
+ (setq tags (sort tags #'cvs-tag-lessp))
(let* ((first (car tags))
(prev (if (cvs-tag-p first)
(list (car (cvs-tag->vlist first))) nil)))
@@ -473,7 +472,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)))
+ (cl-mapcar (lambda (v _p) v) nprev prev)))
(after (save-excursion
(newline)
(cvs-tree-tags-insert (cdr tags) nprev)))
@@ -485,7 +484,7 @@ Optional prefix ARG chooses between two representations."
(as after (cdr as)))
((and (null as) (null vs) (null ps))
(let ((revname (cvs-status-vl-to-str vlist)))
- (if (cvs-every 'identity (cvs-map 'equal prev vlist))
+ (if (cl-every #'identity (cl-mapcar #'equal prev vlist))
(insert (make-string (+ 4 (length revname)) ? )
(or (cvs-tag->name tag) ""))
(insert " " revname ": " (or (cvs-tag->name tag) "")))))
@@ -501,7 +500,7 @@ Optional prefix ARG chooses between two representations."
(if next-eq (cons nil cvs-tree-char-space)
(cons t cvs-tree-char-eob))
(cons nil (if (and (eq (cvs-tag->type tag) 'branch)
- (cvs-every 'null as))
+ (cl-every #'null as))
cvs-tree-char-space
cvs-tree-char-hbar))))))
(insert (cdr na+char))
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 095bc0595fe..4652afa1f92 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -83,7 +83,10 @@ When editing a diff file, the line numbers in the hunk headers
need to be kept consistent with the actual diff. This can
either be done on the fly (but this sometimes interacts poorly with the
undo mechanism) or whenever the file is written (can be slow
-when editing big diffs)."
+when editing big diffs).
+
+If this variable is nil, the hunk header numbers are updated when
+the file is written instead."
:type 'boolean)
(defcustom diff-advance-after-apply-hunk t
@@ -205,6 +208,8 @@ and hunk-based syntax highlighting otherwise as a fallback."
;; `d' because it duplicates the context :-( --Stef
("\C-c\C-d" . diff-unified->context)
("\C-c\C-w" . diff-ignore-whitespace-hunk)
+ ;; `l' because it "refreshes" the hunk like C-l refreshes the screen
+ ("\C-c\C-l" . diff-refresh-hunk)
("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-(
("\C-c\C-f" . next-error-follow-minor-mode))
"Keymap for `diff-mode'. See also `diff-mode-shared-map'.")
@@ -241,6 +246,8 @@ and hunk-based syntax highlighting otherwise as a fallback."
:help "Split the current (unified diff) hunk at point into two hunks"]
["Ignore whitespace changes" diff-ignore-whitespace-hunk
:help "Re-diff the current hunk, ignoring whitespace differences"]
+ ["Recompute the hunk" diff-refresh-hunk
+ :help "Re-diff the current hunk, keeping the whitespace differences"]
["Highlight fine changes" diff-refine-hunk
:help "Highlight changes of hunk at point at a finer granularity"]
["Kill current hunk" diff-hunk-kill
@@ -392,6 +399,13 @@ well."
'((t :inherit diff-file-header))
"`diff-mode' face used to highlight nonexistent files in recursive diffs.")
+(defface diff-error
+ '((((class color))
+ :foreground "red" :background "black" :weight bold)
+ (t :weight bold))
+ "`diff-mode' face for error messages from diff."
+ :version "28.1")
+
(defconst diff-yank-handler '(diff-yank-function))
(defun diff-yank-function (text)
;; FIXME: the yank-handler is now called separately on each piece of text
@@ -472,6 +486,7 @@ and the face `diff-added' for added lines.")
("^\\(#\\)\\(.*\\)"
(1 font-lock-comment-delimiter-face)
(2 font-lock-comment-face))
+ ("^diff: .*" (0 'diff-error))
("^[^-=+*!<>#].*\n" (0 'diff-context))
(,#'diff--font-lock-syntax)
(,#'diff--font-lock-prettify)
@@ -484,7 +499,7 @@ and the face `diff-added' for added lines.")
;; Prefer second name as first is most likely to be a backup or
;; version-control name. The [\t\n] at the end of the unidiff pattern
;; catches Debian source diff files (which lack the trailing date).
- '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs
+ '((nil "\\+\\+\\+ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs
(nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs
;;;;
@@ -724,9 +739,9 @@ start and end positions."
"Restrict the view to the current hunk.
If the prefix ARG is given, restrict the view to the current file instead."
(interactive "P")
- (apply 'narrow-to-region
+ (apply #'narrow-to-region
(if arg (diff-bounds-of-file) (diff-bounds-of-hunk)))
- (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk)))
+ (setq-local diff-narrowed-to (if arg 'file 'hunk)))
(defun diff--some-hunks-p ()
(save-excursion
@@ -755,7 +770,7 @@ If the prefix ARG is given, restrict the view to the current file instead."
file-bounds
hunk-bounds))
(inhibit-read-only t))
- (apply 'kill-region bounds)
+ (apply #'kill-region bounds)
(goto-char (car bounds))
(ignore-errors (diff-beginning-of-hunk t)))))
@@ -813,7 +828,7 @@ data such as \"Index: ...\" and such."
(error "No hunks")
(diff-beginning-of-hunk t)
(let ((inhibit-read-only t))
- (apply 'kill-region (diff-bounds-of-file)))
+ (apply #'kill-region (diff-bounds-of-file)))
(ignore-errors (diff-beginning-of-hunk t))))
(defun diff-kill-junk ()
@@ -923,8 +938,12 @@ If the OLD prefix arg is passed, tell the file NAME of the old file."
(progn (diff-hunk-prev) (point))
(error (point-min)))))
(header-files
- ;; handle filenames with spaces;
+ ;; handle file names with spaces;
;; cf. diff-font-lock-keywords / diff-file-header
+ ;; FIXME if there are nonascii characters in the file names,
+ ;; GNU diff displays them as octal escapes.
+ ;; This function should undo that, so as to return file names
+ ;; that are usable in Emacs.
(if (looking-at "[-*][-*][-*] \\([^\t\n]+\\).*\n[-+][-+][-+] \\([^\t\n]+\\)")
(list (if old (match-string 1) (match-string 2))
(if old (match-string 2) (match-string 1)))
@@ -950,8 +969,8 @@ Non-nil NOPROMPT means to prefer returning nil than to prompt the user.
PREFIX is only used internally: don't use it."
(unless (equal diff-remembered-defdir default-directory)
;; Flush diff-remembered-files-alist if the default-directory is changed.
- (set (make-local-variable 'diff-remembered-defdir) default-directory)
- (set (make-local-variable 'diff-remembered-files-alist) nil))
+ (setq-local diff-remembered-defdir default-directory)
+ (setq-local diff-remembered-files-alist nil))
(save-excursion
(save-restriction
(widen)
@@ -997,8 +1016,8 @@ PREFIX is only used internally: don't use it."
(read-file-name (format "Use file %s: " file)
(file-name-directory file) file t
(file-name-nondirectory file)))
- (set (make-local-variable 'diff-remembered-files-alist)
- (cons (cons fs file) diff-remembered-files-alist))
+ (setq-local diff-remembered-files-alist
+ (cons (cons fs file) diff-remembered-files-alist))
file)))))))
@@ -1456,27 +1475,25 @@ a diff with \\[diff-reverse-direction].
\\{diff-mode-map}"
- (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults)
+ (setq-local font-lock-defaults diff-font-lock-defaults)
(add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local)
- (set (make-local-variable 'outline-regexp) diff-outline-regexp)
- (set (make-local-variable 'imenu-generic-expression)
- diff-imenu-generic-expression)
+ (setq-local outline-regexp diff-outline-regexp)
+ (setq-local imenu-generic-expression
+ diff-imenu-generic-expression)
;; These are not perfect. They would be better done separately for
;; context diffs and unidiffs.
- ;; (set (make-local-variable 'paragraph-start)
+ ;; (setq-local paragraph-start
;; (concat "@@ " ; unidiff hunk
;; "\\|\\*\\*\\* " ; context diff hunk or file start
;; "\\|--- [^\t]+\t")) ; context or unidiff file
;; ; start (first or second line)
- ;; (set (make-local-variable 'paragraph-separate) paragraph-start)
- ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
+ ;; (setq-local paragraph-separate paragraph-start)
+ ;; (setq-local page-delimiter "--- [^\t]+\t")
;; compile support
- (set (make-local-variable 'next-error-function) #'diff-next-error)
+ (setq-local next-error-function #'diff-next-error)
- (set (make-local-variable 'beginning-of-defun-function)
- #'diff-beginning-of-file-and-junk)
- (set (make-local-variable 'end-of-defun-function)
- #'diff-end-of-file)
+ (setq-local beginning-of-defun-function #'diff-beginning-of-file-and-junk)
+ (setq-local end-of-defun-function #'diff-end-of-file)
(diff-setup-whitespace)
@@ -1498,10 +1515,9 @@ a diff with \\[diff-reverse-direction].
(delq ro-bind minor-mode-overriding-map-alist)))
nil t))
;; add-log support
- (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)))
+ (setq-local add-log-current-defun-function #'diff-current-defun)
+ (setq-local add-log-buffer-file-name-function
+ (lambda () (diff-find-file-name nil 'noprompt)))
(add-function :filter-return (local 'filter-buffer-substring-function)
#'diff--filter-substring)
(unless buffer-file-name
@@ -1533,7 +1549,7 @@ a diff with \\[diff-reverse-direction].
This sets `whitespace-style' and `whitespace-trailing-regexp' so
that Whitespace mode shows trailing whitespace problems on the
modified lines of the diff."
- (set (make-local-variable 'whitespace-style) '(face trailing))
+ (setq-local whitespace-style '(face trailing))
(let ((style (save-excursion
(goto-char (point-min))
;; FIXME: For buffers filled from async processes, this search
@@ -1541,10 +1557,10 @@ modified lines of the diff."
(when (re-search-forward diff-hunk-header-re nil t)
(goto-char (match-beginning 0))
(diff-hunk-style)))))
- (set (make-local-variable 'whitespace-trailing-regexp)
- (if (eq style 'context)
- "^[-+!] .*?\\([\t ]+\\)$"
- "^[-+!<>].*?\\([\t ]+\\)$"))))
+ (setq-local whitespace-trailing-regexp
+ (if (eq style 'context)
+ "^[-+!] .*?\\([\t ]+\\)$"
+ "^[-+!<>].*?\\([\t ]+\\)$"))))
(defun diff-delete-if-empty ()
;; An empty diff file means there's no more diffs to integrate, so we
@@ -1751,13 +1767,26 @@ char-offset in TEXT."
(delete-region (point-min) keep))
;; Remove line-prefix characters, and unneeded lines (unified diffs).
;; Also skip lines like "\ No newline at end of file"
- (let ((kill-chars (list (if destp ?- ?+) ?\\)))
+ (let ((kill-chars (list (if destp ?- ?+) ?\\))
+ curr-char last-char)
(goto-char (point-min))
(while (not (eobp))
- (if (memq (char-after) kill-chars)
- (delete-region (point) (progn (forward-line 1) (point)))
+ (setq curr-char (char-after))
+ (if (memq curr-char kill-chars)
+ (delete-region
+ ;; Check for "\ No newline at end of file"
+ (if (and (eq curr-char ?\\)
+ (not (eq last-char (if destp ?- ?+)))
+ (save-excursion
+ (forward-line 1)
+ (or (eobp) (and (eq last-char ?-)
+ (eq (char-after) ?+)))))
+ (max (1- (point)) (point-min))
+ (point))
+ (progn (forward-line 1) (point)))
(delete-char num-pfx-chars)
- (forward-line 1)))))
+ (forward-line 1))
+ (setq last-char curr-char))))
(let ((text (buffer-substring-no-properties (point-min) (point-max))))
(if char-offset (cons text (- (point) (point-min))) text))))))
@@ -1794,7 +1823,7 @@ Whitespace differences are ignored."
(if (> (- (car forw) orig) (- orig (car back))) back forw)
(or back forw))))
-(define-obsolete-function-alias 'diff-xor 'xor "27.1")
+(define-obsolete-function-alias 'diff-xor #'xor "27.1")
(defun diff-find-source-location (&optional other-file reverse noprompt)
"Find current diff location within the source file.
@@ -1846,7 +1875,10 @@ SWITCHED is non-nil if the patch is already applied."
(buf (if revision
(let ((vc-find-revision-no-save t))
(vc-find-revision (expand-file-name file) revision diff-vc-backend))
- (find-file-noselect file))))
+ ;; NOPROMPT is only non-nil when called from
+ ;; `which-function-mode', so avoid "File x changed
+ ;; on disk. Reread from disk?" warnings.
+ (find-file-noselect file noprompt))))
;; Update the user preference if he so wished.
(when (> (prefix-numeric-value other-file) 8)
(setq diff-jump-to-old-file other))
@@ -1914,10 +1946,10 @@ With a prefix argument, REVERSE the hunk."
(and buffer-file-name
(backup-file-name-p buffer-file-name)
(not diff-apply-hunk-to-backup-file)
- (not (set (make-local-variable 'diff-apply-hunk-to-backup-file)
- (yes-or-no-p (format "Really apply this hunk to %s? "
- (file-name-nondirectory
- buffer-file-name)))))))
+ (not (setq-local diff-apply-hunk-to-backup-file
+ (yes-or-no-p (format "Really apply this hunk to %s? "
+ (file-name-nondirectory
+ buffer-file-name)))))))
(error "%s"
(substitute-command-keys
(format "Use %s\\[diff-apply-hunk] to apply it to the other file"
@@ -1965,7 +1997,7 @@ With a prefix argument, try to REVERSE the hunk."
(diff-hunk-kill)
(diff-hunk-next)))))
-(defalias 'diff-mouse-goto-source 'diff-goto-source)
+(defalias 'diff-mouse-goto-source #'diff-goto-source)
(defun diff-goto-source (&optional other-file event)
"Jump to the corresponding source line.
@@ -1984,12 +2016,11 @@ revision of the file otherwise."
(if event (posn-set-point (event-end event)))
(let ((buffer (when event (current-buffer)))
(reverse (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
- (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched)
+ (pcase-let ((`(,buf ,_line-offset ,pos ,src ,_dst ,_switched)
(diff-find-source-location other-file reverse)))
(pop-to-buffer buf)
(goto-char (+ (car pos) (cdr src)))
- (when buffer (next-error-found buffer (current-buffer)))
- (diff-hunk-status-msg line-offset (xor reverse switched) t))))
+ (when buffer (next-error-found buffer (current-buffer))))))
(defun diff-current-defun ()
@@ -2029,8 +2060,15 @@ For use in `add-log-current-defun-function'."
(defun diff-ignore-whitespace-hunk ()
"Re-diff the current hunk, ignoring whitespace differences."
(interactive)
+ (diff-refresh-hunk t))
+
+(defun diff-refresh-hunk (&optional ignore-whitespace)
+ "Re-diff the current hunk."
+ (interactive)
(let* ((char-offset (- (point) (diff-beginning-of-hunk t)))
- (opts (pcase (char-after) (?@ "-bu") (?* "-bc") (_ "-b")))
+ (opt-type (pcase (char-after)
+ (?@ "-u")
+ (?* "-c")))
(line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)")
(error "Can't find line number"))
(string-to-number (match-string 1))))
@@ -2041,7 +2079,12 @@ For use in `add-log-current-defun-function'."
(file1 (make-temp-file "diff1"))
(file2 (make-temp-file "diff2"))
(coding-system-for-read buffer-file-coding-system)
- old new)
+ opts old new)
+ (when ignore-whitespace
+ (setq opts '("-b")))
+ (when opt-type
+ (setq opts (cons opt-type opts)))
+
(unwind-protect
(save-excursion
(setq old (diff-hunk-text hunk nil char-offset))
@@ -2050,8 +2093,9 @@ For use in `add-log-current-defun-function'."
(write-region (concat lead (car new)) nil file2 nil 'nomessage)
(with-temp-buffer
(let ((status
- (call-process diff-command nil t nil
- opts file1 file2)))
+ (apply #'call-process
+ `(,diff-command nil t nil
+ ,@opts ,file1 ,file2))))
(pcase status
(0 nil) ;Nothing to reformat.
(1 (goto-char (point-min))
@@ -2163,9 +2207,10 @@ Return new point, if it was moved."
(smerge-refine-regions beg-del beg-add beg-add end-add
nil #'diff-refine-preproc props-r props-a)))))
('context
- (let* ((middle (save-excursion (re-search-forward "^---" end)))
+ (let* ((middle (save-excursion (re-search-forward "^---" end t)))
(other middle))
- (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (while (and middle
+ (re-search-forward "^\\(?:!.*\n\\)+" middle t))
(smerge-refine-regions (match-beginning 0) (match-end 0)
(save-excursion
(goto-char other)
@@ -2220,17 +2265,20 @@ Call FUN with two args (BEG and END) for each hunk."
;; same hunk.
(goto-char (next-single-char-property-change
(point) 'diff--font-lock-refined nil max)))
- (diff--iterate-hunks
- max
- (lambda (beg end)
- (unless (get-char-property beg 'diff--font-lock-refined)
- (diff--refine-hunk beg end)
- (let ((ol (make-overlay beg end)))
- (overlay-put ol 'diff--font-lock-refined t)
- (overlay-put ol 'diff-mode 'fine)
- (overlay-put ol 'evaporate t)
- (overlay-put ol 'modification-hooks
- '(diff--overlay-auto-delete))))))))
+ ;; Ignore errors that diff cannot be found so that custom font-lock
+ ;; keywords after `diff--font-lock-refined' can still be evaluated.
+ (ignore-error file-missing
+ (diff--iterate-hunks
+ max
+ (lambda (beg end)
+ (unless (get-char-property beg 'diff--font-lock-refined)
+ (diff--refine-hunk beg end)
+ (let ((ol (make-overlay beg end)))
+ (overlay-put ol 'diff--font-lock-refined t)
+ (overlay-put ol 'diff-mode 'fine)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'modification-hooks
+ '(diff--overlay-auto-delete)))))))))
(defun diff--overlay-auto-delete (ol _after _beg _end &optional _len)
(delete-overlay ol))
@@ -2291,7 +2339,7 @@ where DEFUN... is a list of function names found in FILE."
;; would look for non-existent files like
;; /dev/null.
(diff-find-source-location
- (not (equal "/dev/null"
+ (not (equal null-device
(car (diff-hunk-file-names t))))))
(other-buf nil)
(goto-otherbuf
@@ -2518,7 +2566,7 @@ fixed, visit it in a buffer."
'((?+ . (left-fringe diff-fringe-add diff-indicator-added))
(?- . (left-fringe diff-fringe-del diff-indicator-removed))
(?! . (left-fringe diff-fringe-rep diff-indicator-changed))
- (?\s . (left-fringe diff-fringe-nul))))))
+ (?\s . (left-fringe diff-fringe-nul fringe))))))
(put-text-property (match-beginning 0) (match-end 0) 'display spec))))
;; Mimicks the output of Magit's diff.
;; FIXME: This has only been tested with Git's diff output.
@@ -2532,8 +2580,8 @@ fixed, visit it in a buffer."
(concat "diff.*\n"
"\\(?:\\(?:new file\\|deleted\\).*\n\\)?"
"\\(?:index.*\n\\)?"
- "--- \\(?:/dev/null\\|a/\\(.*\\)\\)\n"
- "\\+\\+\\+ \\(?:/dev/null\\|b/\\(.*\\)\\)\n"))))
+ "--- \\(?:" null-device "\\|a/\\(.*\\)\\)\n"
+ "\\+\\+\\+ \\(?:" null-device "\\|b/\\(.*\\)\\)\n"))))
(put-text-property (match-beginning 0)
(or (match-beginning 2) (match-beginning 1))
'display (propertize
@@ -2720,7 +2768,9 @@ hunk text is not found in the source file."
;; When initialization is requested, we should be in a brand new
;; temp buffer.
(cl-assert (null buffer-file-name))
- (let ((enable-local-variables :safe) ;; to find `mode:'
+ ;; Use `:safe' to find `mode:'. In case of hunk-only, use nil because
+ ;; Local Variables list might be incomplete when context is truncated.
+ (let ((enable-local-variables (unless hunk-only :safe))
(buffer-file-name file))
;; Don't run hooks that might assume buffer-file-name
;; really associates buffer with a file (bug#39190).
@@ -2792,7 +2842,7 @@ hunk text is not found in the source file."
;;; Support for converting a diff to diff3 markers via `wiggle'.
-;; Wiggle can be found at http://neil.brown.name/wiggle/ or in your nearest
+;; Wiggle can be found at https://neil.brown.name/wiggle/ or in your nearest
;; Debian repository.
(defun diff-wiggle ()
diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el
index d952133454a..7bb1151602c 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -45,14 +45,12 @@ This variable is also used in the `vc-diff' command (and related
commands) if the backend-specific diff switch variable isn't
set (`vc-git-diff-switches' for git, for instance), and
`vc-diff-switches' isn't set."
- :type '(choice string (repeat string))
- :group 'diff)
+ :type '(choice string (repeat string)))
;;;###autoload
(defcustom diff-command (purecopy "diff")
"The command to use to run diff."
- :type 'string
- :group 'diff)
+ :type 'string)
;; prompt if prefix arg present
(defun diff-switches ()
@@ -60,7 +58,7 @@ set (`vc-git-diff-switches' for git, for instance), and
(read-string "Diff switches: "
(if (stringp diff-switches)
diff-switches
- (mapconcat 'identity diff-switches " ")))))
+ (mapconcat #'identity diff-switches " ")))))
(defun diff-sentinel (code &optional old-temp-file new-temp-file)
"Code run when the diff process exits.
@@ -165,7 +163,7 @@ returns the buffer used."
(let* ((old-alt (diff-file-local-copy old))
(new-alt (diff-file-local-copy new))
(command
- (mapconcat 'identity
+ (mapconcat #'identity
`(,diff-command
;; Use explicitly specified switches
,@switches
@@ -190,9 +188,9 @@ returns the buffer used."
(erase-buffer))
(buffer-enable-undo (current-buffer))
(diff-mode)
- (set (make-local-variable 'revert-buffer-function)
- (lambda (_ignore-auto _noconfirm)
- (diff-no-select old new switches no-async (current-buffer))))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (diff-no-select old new switches no-async (current-buffer))))
(setq default-directory thisdir)
(setq diff-default-directory default-directory)
(let ((inhibit-read-only t))
@@ -200,7 +198,7 @@ returns the buffer used."
(if (and (not no-async) (fboundp 'make-process))
(let ((proc (start-process "Diff" buf shell-file-name
shell-command-switch command)))
- (set-process-filter proc 'diff-process-filter)
+ (set-process-filter proc #'diff-process-filter)
(set-process-sentinel
proc (lambda (proc _msg)
(with-current-buffer (process-buffer proc)
@@ -258,6 +256,8 @@ This requires the external program `diff' to be in your `exec-path'."
(interactive "bBuffer: ")
(let ((buf (get-buffer (or buffer (current-buffer)))))
(with-current-buffer (or (buffer-base-buffer buf) buf)
+ (unless buffer-file-name
+ (error "Buffer is not visiting a file"))
(diff buffer-file-name (current-buffer) nil 'noasync))))
;;;###autoload
diff --git a/lisp/vc/ediff-diff.el b/lisp/vc/ediff-diff.el
index 9d41b94946c..0965e888f06 100644
--- a/lisp/vc/ediff-diff.el
+++ b/lisp/vc/ediff-diff.el
@@ -87,7 +87,7 @@ options after the default ones.
This variable is not for customizing the look of the differences produced by
the command \\[ediff-show-diff-output]. Use the variable
`ediff-custom-diff-options' for that."
- :set 'ediff-set-diff-options
+ :set #'ediff-set-diff-options
:type 'string)
(ediff-defvar-local ediff-ignore-case nil
@@ -149,7 +149,7 @@ This variable can be set either in .emacs or toggled interactively.
Use `setq-default' if setting it in .emacs")
(ediff-defvar-local ediff-ignore-similar-regions nil
- "If t, skip over difference regions that differ only in the white space and line breaks.
+ "If t, skip difference regions that differ only in white space and line breaks.
This variable can be set either in .emacs or toggled interactively.
Use `setq-default' if setting it in .emacs")
@@ -231,10 +231,7 @@ one optional arguments, diff-number to refine.")
(sit-for 2)
;; 1 is an error exit code
1)
- (t (message "Computing differences between %s and %s ..."
- (file-name-nondirectory file1)
- (file-name-nondirectory file2))
- ;; this erases the diff buffer automatically
+ (t ;; this erases the diff buffer automatically
(ediff-exec-process ediff-diff-program
diff-buffer
'synchronize
@@ -325,6 +322,10 @@ one optional arguments, diff-number to refine.")
(error-buf ediff-error-buffer))
(ediff-skip-unsuitable-frames)
(switch-to-buffer error-buf)
+ ;; We output data from the diff command using `raw-text' as
+ ;; the coding system, so decode before displaying.
+ (when (eq ediff-coding-system-for-read 'raw-text)
+ (decode-coding-region (point-min) (point-max) 'undecided))
(ediff-kill-buffer-carefully ctl-buf)
(user-error "Errors in diff output. Diff output is in %S" diff-buff))))
@@ -1142,7 +1143,10 @@ are ignored."
(if (string-match "buffer" (symbol-name ediff-job-name))
ediff-coding-system-for-write
ediff-coding-system-for-read))
- args)
+ (process-environment
+ ;; Avoid localization of messages so we can parse the output.
+ (cons "LC_MESSAGES=C" process-environment))
+ args)
(setq args (append (split-string options)
(mapcar (lambda (file)
(when (stringp file)
@@ -1226,35 +1230,30 @@ are ignored."
Used for splitting difference regions into individual words.")
;; \240 is Unicode symbol for nonbreakable whitespace
-(defvar ediff-whitespace " \n\t\f\r\240"
+(defvar-local ediff-whitespace " \n\t\f\r\240"
"Characters constituting white space.
These characters are ignored when differing regions are split into words.")
-(make-variable-buffer-local 'ediff-whitespace)
-(defvar ediff-word-1 "-[:word:]_"
+(defvar-local ediff-word-1 "-[:word:]_"
"Characters that constitute words of type 1.
More precisely, [ediff-word-1] is a regexp that matches type 1 words.
See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-1)
-(defvar ediff-word-2 "0-9.,"
+(defvar-local ediff-word-2 "0-9.,"
"Characters that constitute words of type 2.
More precisely, [ediff-word-2] is a regexp that matches type 2 words.
See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-2)
-(defvar ediff-word-3 "`'?!:;\"{}[]()"
+(defvar-local ediff-word-3 "`'?!:;\"{}[]()"
"Characters that constitute words of type 3.
More precisely, [ediff-word-3] is a regexp that matches type 3 words.
See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-3)
-(defvar ediff-word-4
+(defvar-local ediff-word-4
(concat "^" ediff-word-1 ediff-word-2 ediff-word-3 ediff-whitespace)
"Characters that constitute words of type 4.
More precisely, [ediff-word-4] is a regexp that matches type 4 words.
See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-4)
;; Split region along word boundaries. Each word will be on its own line.
;; Output to buffer out-buffer.
diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el
index 84bf063aedf..a5bb953b6d4 100644
--- a/lisp/vc/ediff-help.el
+++ b/lisp/vc/ediff-help.el
@@ -156,7 +156,7 @@ the value of this variable and the variables `ediff-help-message-*' in
;; the keymap that defines clicks over the quick help regions
(defvar ediff-help-region-map (make-sparse-keymap))
-(define-key ediff-help-region-map [mouse-2] 'ediff-help-for-quick-help)
+(define-key ediff-help-region-map [mouse-2] #'ediff-help-for-quick-help)
;; runs in the control buffer
(defun ediff-set-help-overlays ()
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index def1e56d6a7..17c4202d647 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'cl-lib)
+(require 'ediff-util)
;; Start compiler pacifier
(defvar ediff-metajob-name)
@@ -80,13 +81,12 @@ that Ediff doesn't know about.")
;; so that `kill-all-local-variables' (called by major-mode setting
;; commands) won't destroy Ediff control variables.
;;
-;; Plagiarized from `emerge-defvar-local' for XEmacs.
+;; Plagiarized from `emerge-defvar-local'.
(defmacro ediff-defvar-local (var value doc)
"Defines VAR as a local variable."
(declare (indent defun) (doc-string 3))
`(progn
- (defvar ,var ,value ,doc)
- (make-variable-buffer-local ',var)
+ (defvar-local ,var ,value ,doc)
(put ',var 'permanent-local t)))
@@ -432,7 +432,7 @@ Can be used to move the frame where it is desired."
:type 'hook
:group 'ediff-hook)
(defcustom ediff-startup-hook nil
- "Hooks to run in the control buffer after Ediff has been set up and is ready for the job."
+ "Hooks to run in the control buffer after Ediff has been set up and is ready."
:type 'hook
:group 'ediff-hook)
(defcustom ediff-select-hook nil
@@ -452,6 +452,8 @@ For each buffer, the hooks are run with that buffer made current."
"Hook run after Ediff is loaded. Can be used to change defaults."
:type 'hook
:group 'ediff-hook)
+(make-obsolete-variable 'ediff-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(defcustom ediff-mode-hook nil
"Hook run just after ediff-mode is set up in the control buffer.
@@ -478,7 +480,7 @@ set local variables that determine how the display looks like."
:type 'hook
:group 'ediff-hook)
(defcustom ediff-cleanup-hook nil
- "Hooks to run on exiting Ediff but before killing the control and variant buffers."
+ "Hooks to run on exiting Ediff, before killing the control and variant buffers."
:type 'hook
:group 'ediff-hook)
@@ -552,19 +554,19 @@ See the documentation string of `ediff-focus-on-regexp-matches' for details.")
;; Highlighting
(defcustom ediff-before-flag-bol "->>"
- "Flag placed before a highlighted block of differences, if block starts at beginning of a line."
+ "Flag placed before highlighted block of differences at beginning of a line."
:type 'string
:tag "Region before-flag at beginning of line"
:group 'ediff)
(defcustom ediff-after-flag-eol "<<-"
- "Flag placed after a highlighted block of differences, if block ends at end of a line."
+ "Flag placed after highlighted block of differences that ends at end of line."
:type 'string
:tag "Region after-flag at end of line"
:group 'ediff)
(defcustom ediff-before-flag-mol "->>"
- "Flag placed before a highlighted block of differences, if block starts in mid-line."
+ "Flag placed before highlighted block of differences that starts mid-line."
:type 'string
:tag "Region before-flag in the middle of line"
:group 'ediff)
@@ -796,13 +798,6 @@ to temp files in buffer jobs and when Ediff needs to find fine differences."
(message "Pixmap not found for %S: %s" (face-name face) pixmap)
(sit-for 1)))))
-(defun ediff-hide-face (face)
- (if (and (ediff-has-face-support-p)
- (boundp 'add-to-list)
- (boundp 'facemenu-unlisted-faces))
- (add-to-list 'facemenu-unlisted-faces face)))
-
-
(defface ediff-current-diff-A
'((((class color) (min-colors 88) (background light))
@@ -823,7 +818,6 @@ to temp files in buffer jobs and when Ediff needs to find fine differences."
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-current-diff-A'
this variable represents.")
-(ediff-hide-face ediff-current-diff-face-A)
(defface ediff-current-diff-B
'((((class color) (min-colors 88) (background light))
@@ -845,7 +839,6 @@ this variable represents.")
this variable. Instead, use the customization
widget to customize the actual face `ediff-current-diff-B'
this variable represents.")
-(ediff-hide-face ediff-current-diff-face-B)
(defface ediff-current-diff-C
'((((class color) (min-colors 88) (background light))
@@ -866,7 +859,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-current-diff-C'
this variable represents.")
-(ediff-hide-face ediff-current-diff-face-C)
(defface ediff-current-diff-Ancestor
'((((class color) (min-colors 88) (background light))
@@ -889,7 +881,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-current-diff-Ancestor'
this variable represents.")
-(ediff-hide-face ediff-current-diff-face-Ancestor)
(defface ediff-fine-diff-A
'((((class color) (min-colors 88) (background light))
@@ -910,7 +901,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-fine-diff-A'
this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-A)
(defface ediff-fine-diff-B
'((((class color) (min-colors 88) (background light))
@@ -931,7 +921,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-fine-diff-B'
this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-B)
(defface ediff-fine-diff-C
'((((class color) (min-colors 88) (background light))
@@ -955,7 +944,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-fine-diff-C'
this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-C)
(defface ediff-fine-diff-Ancestor
'((((class color) (min-colors 88) (background light))
@@ -980,7 +968,6 @@ ancestor buffer."
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-fine-diff-Ancestor'
this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-Ancestor)
;; Some installs don't have stipple or Stipple. So, try them in turn.
(defvar stipple-pixmap
@@ -994,8 +981,10 @@ this variable represents.")
(defface ediff-even-diff-A
`((((type pc))
(:foreground "green3" :background "light grey" :extend t))
- (((class color) (min-colors 88))
- (:background "light grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "light grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dark grey" :extend t))
(((class color) (min-colors 16))
(:foreground "Black" :background "light grey" :extend t))
(((class color))
@@ -1011,11 +1000,12 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-even-diff-A'
this variable represents.")
-(ediff-hide-face ediff-even-diff-face-A)
(defface ediff-even-diff-B
- `((((class color) (min-colors 88))
- (:background "Grey" :extend t))
+ `((((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "Grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dim grey" :extend t))
(((class color) (min-colors 16))
(:foreground "White" :background "Grey" :extend t))
(((class color))
@@ -1030,13 +1020,14 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-even-diff-B'
this variable represents.")
-(ediff-hide-face ediff-even-diff-face-B)
(defface ediff-even-diff-C
`((((type pc))
(:foreground "yellow3" :background "light grey" :extend t))
- (((class color) (min-colors 88))
- (:background "light grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "light grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dark grey" :extend t))
(((class color) (min-colors 16))
(:foreground "Black" :background "light grey" :extend t))
(((class color))
@@ -1052,13 +1043,14 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-even-diff-C'
this variable represents.")
-(ediff-hide-face ediff-even-diff-face-C)
(defface ediff-even-diff-Ancestor
`((((type pc))
(:foreground "cyan3" :background "light grey" :extend t))
- (((class color) (min-colors 88))
- (:background "Grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "Grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dim grey" :extend t))
(((class color) (min-colors 16))
(:foreground "White" :background "Grey" :extend t))
(((class color))
@@ -1074,7 +1066,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-even-diff-Ancestor'
this variable represents.")
-(ediff-hide-face ediff-even-diff-face-Ancestor)
;; Association between buffer types and even-diff-face symbols
(defconst ediff-even-diff-face-alist
@@ -1086,8 +1077,10 @@ this variable represents.")
(defface ediff-odd-diff-A
'((((type pc))
(:foreground "green3" :background "gray40" :extend t))
- (((class color) (min-colors 88))
- (:background "Grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "Grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dim grey" :extend t))
(((class color) (min-colors 16))
(:foreground "White" :background "Grey" :extend t))
(((class color))
@@ -1102,14 +1095,14 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-odd-diff-A'
this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-A)
-
(defface ediff-odd-diff-B
'((((type pc))
(:foreground "White" :background "gray40" :extend t))
- (((class color) (min-colors 88))
- (:background "light grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "light grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dark grey" :extend t))
(((class color) (min-colors 16))
(:foreground "Black" :background "light grey" :extend t))
(((class color))
@@ -1124,13 +1117,14 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-odd-diff-B'
this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-B)
(defface ediff-odd-diff-C
'((((type pc))
(:foreground "yellow3" :background "gray40" :extend t))
- (((class color) (min-colors 88))
- (:background "Grey" :extend t))
+ (((class color) (min-colors 88) (background light))
+ (:distant-foreground "Black" :background "Grey" :extend t))
+ (((class color) (min-colors 88) (background dark))
+ (:distant-foreground "White" :background "dim grey" :extend t))
(((class color) (min-colors 16))
(:foreground "White" :background "Grey" :extend t))
(((class color))
@@ -1145,7 +1139,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-odd-diff-C'
this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-C)
(defface ediff-odd-diff-Ancestor
'((((class color) (min-colors 88))
@@ -1164,7 +1157,6 @@ this variable represents.")
DO NOT CHANGE this variable. Instead, use the customization
widget to customize the actual face object `ediff-odd-diff-Ancestor'
this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-Ancestor)
;; Association between buffer types and odd-diff-face symbols
(defconst ediff-odd-diff-face-alist
@@ -1190,8 +1182,8 @@ this variable represents.")
(put ediff-fine-diff-face-Ancestor 'ediff-help-echo
"A `refinement' of the current difference region")
-(add-hook 'ediff-quit-hook 'ediff-cleanup-mess)
-(add-hook 'ediff-suspend-hook 'ediff-default-suspend-function)
+(add-hook 'ediff-quit-hook #'ediff-cleanup-mess)
+(add-hook 'ediff-suspend-hook #'ediff-default-suspend-function)
;;; Overlays
@@ -1255,22 +1247,8 @@ Instead, C-h would jump to previous difference."
:type 'boolean
:group 'ediff)
-;; This is the same as temporary-file-directory from Emacs 20.3.
-;; Copied over here because XEmacs doesn't have this variable.
-(defcustom ediff-temp-file-prefix
- (file-name-as-directory
- (cond ((boundp 'temporary-file-directory) temporary-file-directory)
- ((fboundp 'temp-directory) (temp-directory))
- (t "/tmp/")))
-;;; (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"))))
- "Prefix to put on Ediff temporary file names.
-Do not start with `~/' or `~USERNAME/'."
- :type 'string
- :group 'ediff)
+(define-obsolete-variable-alias 'ediff-temp-file-prefix
+ 'temporary-file-directory "28.1")
(defcustom ediff-temp-file-mode 384 ; u=rw only
"Mode for Ediff temporary files."
@@ -1280,13 +1258,13 @@ Do not start with `~/' or `~USERNAME/'."
;; Metacharacters that have to be protected from the shell when executing
;; a diff/diff3 command.
(defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
- "Regexp that matches characters that must be quoted with `\\' in shell command line.
+ "Regexp matching characters that must be quoted with `\\' in shell command line.
This default should work without changes."
- :type 'string
+ :type 'regexp
:group 'ediff)
-;; needed to simulate frame-char-width in XEmacs.
-(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H")))
+(defvar ediff-H-glyph nil)
+(make-obsolete-variable 'ediff-H-glyph nil "28.1")
;; Temporary file used for refining difference regions in buffer A.
@@ -1335,7 +1313,8 @@ This default should work without changes."
(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight)
(let ((diff-vector
(eval (ediff-get-symbol-from-alist
- buf-type ediff-difference-vector-alist)))
+ buf-type ediff-difference-vector-alist)
+ t))
overl diff-num)
(mapcar (lambda (rec)
(setq overl (ediff-get-diff-overlay-from-diff-record rec)
@@ -1522,34 +1501,9 @@ This default should work without changes."
(setq dir (substring dir 0 pos)))
(ediff-abbreviate-file-name (file-name-directory dir))))
-(defun ediff-truncate-string-left (str newlen)
- ;; leave space for ... on the left
- (let ((len (length str))
- substr)
- (if (<= len newlen)
- str
- (setq newlen (max 0 (- newlen 3)))
- (setq substr (substring str (max 0 (- len 1 newlen))))
- (concat "..." substr))))
-
(defsubst ediff-nonempty-string-p (string)
(and (stringp string) (not (string= string ""))))
-(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.
-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)))
-
-(unless (fboundp 'format-message)
- (defalias 'format-message 'format))
-
(defun ediff-abbrev-jobname (jobname)
(cond ((eq jobname 'ediff-directories)
"Compare two directories")
@@ -1609,13 +1563,16 @@ Unless optional argument INPLACE is non-nil, return a new string."
(ediff-file-attributes filename 5))
+;;; Obsolete
+
(defun ediff-convert-standard-filename (fname)
- (if (fboundp 'convert-standard-filename)
- (convert-standard-filename fname)
- fname))
+ (declare (obsolete convert-standard-filename "28.1"))
+ (convert-standard-filename fname))
(define-obsolete-function-alias 'ediff-with-syntax-table
#'with-syntax-table "27.1")
+(define-obsolete-function-alias 'ediff-hide-face #'ignore "28.1")
+
(provide 'ediff-init)
;;; ediff-init.el ends here
diff --git a/lisp/vc/ediff-merg.el b/lisp/vc/ediff-merg.el
index 9e2b20930b6..ad4ef473f84 100644
--- a/lisp/vc/ediff-merg.el
+++ b/lisp/vc/ediff-merg.el
@@ -70,7 +70,7 @@ STRING4
:group 'ediff-merge)
(defcustom ediff-show-clashes-only nil
- "If t, show only those diff regions where both buffers disagree with the ancestor.
+ "If t, show only diff regions where both buffers disagree with the ancestor.
This means that regions that have status prefer-A or prefer-B will be
skipped over. A value of nil means show all regions."
:type 'boolean
@@ -194,7 +194,7 @@ Buffer B."
(defun ediff-set-merge-mode ()
(normal-mode t)
- (remove-hook 'write-file-functions 'ediff-set-merge-mode t))
+ (remove-hook 'write-file-functions #'ediff-set-merge-mode t))
;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C
diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el
index 406b5611174..8e88b60a0bd 100644
--- a/lisp/vc/ediff-mult.el
+++ b/lisp/vc/ediff-mult.el
@@ -113,7 +113,6 @@
(require 'ediff-wind)
(require 'ediff-util)
-
;; meta-buffer
(ediff-defvar-local ediff-meta-buffer nil "")
(ediff-defvar-local ediff-parent-meta-buffer nil "")
@@ -148,15 +147,15 @@ Useful commands (type ? to hide them and free up screen):
(defvar ediff-dir-diffs-buffer-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
- (define-key map "q" 'ediff-bury-dir-diffs-buffer)
- (define-key map " " 'next-line)
- (define-key map "n" 'next-line)
- (define-key map "\C-?" 'previous-line)
- (define-key map "p" 'previous-line)
- (define-key map "C" 'ediff-dir-diff-copy-file)
- (define-key map [mouse-2] 'ediff-dir-diff-copy-file)
- (define-key map [delete] 'previous-line)
- (define-key map [backspace] 'previous-line)
+ (define-key map "q" #'ediff-bury-dir-diffs-buffer)
+ (define-key map " " #'next-line)
+ (define-key map "n" #'next-line)
+ (define-key map "\C-?" #'previous-line)
+ (define-key map "p" #'previous-line)
+ (define-key map "C" #'ediff-dir-diff-copy-file)
+ (define-key map [mouse-2] #'ediff-dir-diff-copy-file)
+ (define-key map [delete] #'previous-line)
+ (define-key map [backspace] #'previous-line)
map)
"The keymap to be installed in the buffer showing differences between
directories.")
@@ -182,7 +181,7 @@ directories.")
(defvar ediff-filtering-regexp-history nil "")
(defcustom ediff-default-filtering-regexp nil
- "The default regular expression used as a filename filter in multifile comparisons.
+ "Default regular expression used as a filename filter in multifile comparisons.
Should be a sexp. For instance (car ediff-filtering-regexp-history) or nil."
:type 'sexp ; yuck - why not just a regexp?
:risky t)
@@ -414,12 +413,11 @@ Toggled by ediff-toggle-verbose-help-meta-buffer" )
'(menu-item "Show Manual" ediff-documentation
:help "Display Ediff's manual"))
- (or (ediff-one-filegroup-metajob)
- (progn
- (define-key ediff-meta-buffer-map "=" nil)
- (define-key ediff-meta-buffer-map "==" 'ediff-meta-mark-equal-files)
- (define-key ediff-meta-buffer-map "=m" 'ediff-meta-mark-equal-files)
- (define-key ediff-meta-buffer-map "=h" 'ediff-meta-mark-equal-files)))
+ (unless (ediff-one-filegroup-metajob)
+ (define-key ediff-meta-buffer-map "=" nil)
+ (define-key ediff-meta-buffer-map "==" #'ediff-meta-mark-equal-files)
+ (define-key ediff-meta-buffer-map "=m" #'ediff-meta-mark-equal-files)
+ (define-key ediff-meta-buffer-map "=h" #'ediff-meta-mark-equal-files))
(define-key menu-map [ediff-next-meta-item]
@@ -431,7 +429,7 @@ Toggled by ediff-toggle-verbose-help-meta-buffer" )
(if ediff-no-emacs-help-in-control-buffer
- (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item))
+ (define-key ediff-meta-buffer-map "\C-h" #'ediff-previous-meta-item))
(define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function)
(use-local-map ediff-meta-buffer-map)
@@ -622,7 +620,7 @@ behavior."
(setq common (ediff-intersection common lis3 #'string=)))
;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
+ (setq common (sort (copy-sequence common) #'string-lessp))
;; compute difference list
(setq difflist (ediff-set-difference
@@ -633,8 +631,8 @@ behavior."
#'string=)
difflist (delete "." difflist)
;; copying is needed because sort sorts via side effects
- difflist (sort (ediff-copy-list (delete ".." difflist))
- 'string-lessp))
+ difflist (sort (copy-sequence (delete ".." difflist))
+ #'string-lessp))
(setq difflist (mapcar (lambda (elt) (cons elt 1)) difflist))
@@ -731,7 +729,7 @@ behavior."
)
;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
+ (setq common (sort (copy-sequence common) #'string-lessp))
;; return result
(cons
@@ -838,14 +836,14 @@ behavior."
(ediff-draw-dir-diffs ediff-dir-difference-list))
(define-key
ediff-meta-buffer-map "h" 'ediff-mark-for-hiding-at-pos)
- (define-key ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions)
+ (define-key ediff-meta-buffer-map "x" #'ediff-hide-marked-sessions)
(define-key
- ediff-meta-buffer-map "m" 'ediff-mark-for-operation-at-pos)
+ ediff-meta-buffer-map "m" #'ediff-mark-for-operation-at-pos)
(define-key ediff-meta-buffer-map "u" nil)
(define-key
- ediff-meta-buffer-map "um" 'ediff-unmark-all-for-operation)
+ ediff-meta-buffer-map "um" #'ediff-unmark-all-for-operation)
(define-key
- ediff-meta-buffer-map "uh" 'ediff-unmark-all-for-hiding)
+ ediff-meta-buffer-map "uh" #'ediff-unmark-all-for-hiding)
(define-key ediff-meta-buffer-map
[menu-bar ediff-meta-mode ediff-hide-marked-sessions]
@@ -878,7 +876,7 @@ behavior."
'(menu-item "Collect diffs" ediff-collect-custom-diffs
:help "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'"))
(define-key
- ediff-meta-buffer-map "P" 'ediff-collect-custom-diffs))
+ ediff-meta-buffer-map "P" #'ediff-collect-custom-diffs))
((ediff-patch-metajob jobname)
(define-key ediff-meta-buffer-map
[menu-bar ediff-meta-mode ediff-meta-show-patch]
@@ -886,8 +884,8 @@ behavior."
:help "Show the multi-file patch associated with this group session"))
(define-key
ediff-meta-buffer-map "P" 'ediff-meta-show-patch)))
- (define-key ediff-meta-buffer-map "^" 'ediff-up-meta-hierarchy)
- (define-key ediff-meta-buffer-map "D" 'ediff-show-dir-diffs)
+ (define-key ediff-meta-buffer-map "^" #'ediff-up-meta-hierarchy)
+ (define-key ediff-meta-buffer-map "D" #'ediff-show-dir-diffs)
(define-key ediff-meta-buffer-map
[menu-bar ediff-meta-mode ediff-up-meta-hierarchy]
@@ -1172,7 +1170,7 @@ behavior."
;; abbreviate the file name, if file exists
(if (and (not (stringp fname)) (< file-size -1))
"-------" ; file doesn't exist
- (ediff-truncate-string-left
+ (string-truncate-left
(ediff-abbreviate-file-name fname)
max-filename-width)))))))
@@ -1266,7 +1264,7 @@ Useful commands:
(if (= (mod membership-code ediff-membership-code1) 0) ; dir1
(let ((beg (point)))
(insert (format "%-27s"
- (ediff-truncate-string-left
+ (string-truncate-left
(ediff-abbreviate-file-name
(if (file-directory-p (concat dir1 file))
(file-name-as-directory file)
@@ -1281,7 +1279,7 @@ Useful commands:
(if (= (mod membership-code ediff-membership-code2) 0) ; dir2
(let ((beg (point)))
(insert (format "%-26s"
- (ediff-truncate-string-left
+ (string-truncate-left
(ediff-abbreviate-file-name
(if (file-directory-p (concat dir2 file))
(file-name-as-directory file)
@@ -1295,7 +1293,7 @@ Useful commands:
(if (= (mod membership-code ediff-membership-code3) 0) ; dir3
(let ((beg (point)))
(insert (format " %-25s"
- (ediff-truncate-string-left
+ (string-truncate-left
(ediff-abbreviate-file-name
(if (file-directory-p (concat dir3 file))
(file-name-as-directory file)
@@ -1808,11 +1806,9 @@ all marked sessions must be active."
(ediff-show-meta-buffer session-buf)
(setq regexp
(read-string
- (if (stringp default-regexp)
- (format
- "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt
+ "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
(eval ediff-default-filtering-regexp t)))
@@ -2131,7 +2127,7 @@ all marked sessions must be active."
))
;;;###autoload
-(defalias 'eregistry 'ediff-show-registry)
+(defalias 'eregistry #'ediff-show-registry)
;; If meta-buf doesn't exist, it is created. In that case, id doesn't have a
;; parent meta-buf
@@ -2320,7 +2316,7 @@ If this is a session registry buffer then just bury it."
(meta-patchbuf ediff-meta-patchbufer)
session-buf beg-marker end-marker)
- (if (or (file-directory-p file) (string-match "/dev/null" file))
+ (if (or (file-directory-p file) (string-match null-device file))
(user-error "`%s' is not an ordinary file" (file-name-as-directory file)))
(setq session-buf (ediff-get-session-buffer info)
beg-marker (ediff-get-session-objB-name info)
diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 5c7a2c76805..d52910efceb 100644
--- a/lisp/vc/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -119,7 +119,7 @@ patch. So, don't change these variables, unless the default doesn't work."
(defcustom ediff-context-diff-label-regexp
(let ((stuff "\\([^ \t\n]+\\)"))
(concat "\\(" ; context diff 2-liner
- "^\\*\\*\\* +" stuff "[^*]+[\t ]*\n--- +" stuff
+ "^\\*\\*\\* +" stuff "[^*]+\n--- +" stuff
"\\|" ; unified format diff 2-liner
"^--- +" stuff ".*\n\\+\\+\\+ +" stuff
"\\)"))
@@ -193,7 +193,7 @@ program."
(let ((count 0)
(mark1 (point-min-marker))
(mark1-end (point-min))
- (possible-file-names '("/dev/null" . "/dev/null"))
+ (possible-file-names `(,null-device . ,null-device))
mark2-end mark2 filenames
beg1 beg2 end1 end2
patch-map opoint)
@@ -217,10 +217,10 @@ program."
(setq possible-file-names
(cons (if (and beg1 end1)
(buffer-substring beg1 end1)
- "/dev/null")
+ null-device)
(if (and beg2 end2)
(buffer-substring beg2 end2)
- "/dev/null")))
+ null-device)))
;; Remove file junk (Bug#26084).
(while (re-search-backward
(concat "^\\(?:" diff-file-junk-re "\\)") mark1-end t)
@@ -309,12 +309,12 @@ program."
(file-exists-p (cdr m2)))
(setq base-dir1 (car m1)
base-dir2 (car m2))))))))
- (or (string= (car proposed-file-names) "/dev/null")
+ (or (string= (car proposed-file-names) null-device)
(setcar proposed-file-names
(ediff-file-name-sans-prefix
(car proposed-file-names) base-dir1)))
(or (string=
- (cdr proposed-file-names) "/dev/null")
+ (cdr proposed-file-names) null-device)
(setcdr proposed-file-names
(ediff-file-name-sans-prefix
(cdr proposed-file-names) base-dir2)))
@@ -323,7 +323,7 @@ program."
;; take the given file name into account
(or (file-directory-p filename)
- (string= "/dev/null" filename)
+ (string= null-device filename)
(setcar (ediff-get-session-objA (car ediff-patch-map))
(cons (file-name-nondirectory filename)
(file-name-nondirectory filename))))
@@ -465,6 +465,9 @@ are two possible targets for this %spatch. However, these files do not exist."
file1 file2 (if multi-patch-p "multi-" ""))))
(princ "
\nPlease enter an alternative patch target ...\n"))
+ (when (and (string= file1 file2)
+ (y-or-n-p (format "Create %s?" file1)))
+ (write-region (point-min) (point-min) file1))
(let ((directory t)
target)
(while directory
@@ -582,7 +585,7 @@ optional argument, then use it."
patch-buf
(if (and ediff-patch-map
(not (string-match-p
- "^/dev/null"
+ (concat "^" null-device)
;; this is the file to patch
(ediff-get-session-objA-name (car ediff-patch-map))))
(> (length
diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el
index da90f54c42c..0cbea2c28d7 100644
--- a/lisp/vc/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -123,107 +123,106 @@ to invocation.")
(setq ediff-mode-map (make-sparse-keymap))
(suppress-keymap ediff-mode-map)
- (define-key ediff-mode-map [mouse-2] 'ediff-help-for-quick-help)
- (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help)
+ (define-key ediff-mode-map [mouse-2] #'ediff-help-for-quick-help)
+ (define-key ediff-mode-map "\C-m" #'ediff-help-for-quick-help)
- (define-key ediff-mode-map "p" 'ediff-previous-difference)
- (define-key ediff-mode-map "\C-?" 'ediff-previous-difference)
- (define-key ediff-mode-map [delete] 'ediff-previous-difference)
+ (define-key ediff-mode-map "p" #'ediff-previous-difference)
+ (define-key ediff-mode-map "\C-?" #'ediff-previous-difference)
+ (define-key ediff-mode-map [delete] #'ediff-previous-difference)
(define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer
- 'ediff-previous-difference nil))
- ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs
- (define-key ediff-mode-map [backspace] 'ediff-previous-difference)
- (define-key ediff-mode-map [?\S-\ ] 'ediff-previous-difference)
- (define-key ediff-mode-map "n" 'ediff-next-difference)
- (define-key ediff-mode-map " " 'ediff-next-difference)
- (define-key ediff-mode-map "j" 'ediff-jump-to-difference)
+ #'ediff-previous-difference nil))
+ (define-key ediff-mode-map [backspace] #'ediff-previous-difference)
+ (define-key ediff-mode-map [?\S-\ ] #'ediff-previous-difference)
+ (define-key ediff-mode-map "n" #'ediff-next-difference)
+ (define-key ediff-mode-map " " #'ediff-next-difference)
+ (define-key ediff-mode-map "j" #'ediff-jump-to-difference)
(define-key ediff-mode-map "g" nil)
- (define-key ediff-mode-map "ga" 'ediff-jump-to-difference-at-point)
- (define-key ediff-mode-map "gb" 'ediff-jump-to-difference-at-point)
- (define-key ediff-mode-map "q" 'ediff-quit)
- (define-key ediff-mode-map "D" 'ediff-show-diff-output)
- (define-key ediff-mode-map "z" 'ediff-suspend)
- (define-key ediff-mode-map "\C-l" 'ediff-recenter)
- (define-key ediff-mode-map "|" 'ediff-toggle-split)
- (define-key ediff-mode-map "h" 'ediff-toggle-hilit)
+ (define-key ediff-mode-map "ga" #'ediff-jump-to-difference-at-point)
+ (define-key ediff-mode-map "gb" #'ediff-jump-to-difference-at-point)
+ (define-key ediff-mode-map "q" #'ediff-quit)
+ (define-key ediff-mode-map "D" #'ediff-show-diff-output)
+ (define-key ediff-mode-map "z" #'ediff-suspend)
+ (define-key ediff-mode-map "\C-l" #'ediff-recenter)
+ (define-key ediff-mode-map "|" #'ediff-toggle-split)
+ (define-key ediff-mode-map "h" #'ediff-toggle-hilit)
(or ediff-word-mode
- (define-key ediff-mode-map "@" 'ediff-toggle-autorefine))
+ (define-key ediff-mode-map "@" #'ediff-toggle-autorefine))
(if ediff-narrow-job
- (define-key ediff-mode-map "%" 'ediff-toggle-narrow-region))
- (define-key ediff-mode-map "~" 'ediff-swap-buffers)
- (define-key ediff-mode-map "v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "\C-v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "^" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "\M-v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "V" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "<" 'ediff-scroll-horizontally)
- (define-key ediff-mode-map ">" 'ediff-scroll-horizontally)
- (define-key ediff-mode-map "i" 'ediff-status-info)
- (define-key ediff-mode-map "E" 'ediff-documentation)
- (define-key ediff-mode-map "?" 'ediff-toggle-help)
- (define-key ediff-mode-map "!" 'ediff-update-diffs)
- (define-key ediff-mode-map "M" 'ediff-show-current-session-meta-buffer)
- (define-key ediff-mode-map "R" 'ediff-show-registry)
+ (define-key ediff-mode-map "%" #'ediff-toggle-narrow-region))
+ (define-key ediff-mode-map "~" #'ediff-swap-buffers)
+ (define-key ediff-mode-map "v" #'ediff-scroll-vertically)
+ (define-key ediff-mode-map "\C-v" #'ediff-scroll-vertically)
+ (define-key ediff-mode-map "^" #'ediff-scroll-vertically)
+ (define-key ediff-mode-map "\M-v" #'ediff-scroll-vertically)
+ (define-key ediff-mode-map "V" #'ediff-scroll-vertically)
+ (define-key ediff-mode-map "<" #'ediff-scroll-horizontally)
+ (define-key ediff-mode-map ">" #'ediff-scroll-horizontally)
+ (define-key ediff-mode-map "i" #'ediff-status-info)
+ (define-key ediff-mode-map "E" #'ediff-documentation)
+ (define-key ediff-mode-map "?" #'ediff-toggle-help)
+ (define-key ediff-mode-map "!" #'ediff-update-diffs)
+ (define-key ediff-mode-map "M" #'ediff-show-current-session-meta-buffer)
+ (define-key ediff-mode-map "R" #'ediff-show-registry)
(or ediff-word-mode
- (define-key ediff-mode-map "*" 'ediff-make-or-kill-fine-diffs))
+ (define-key ediff-mode-map "*" #'ediff-make-or-kill-fine-diffs))
(define-key ediff-mode-map "a" nil)
(define-key ediff-mode-map "b" nil)
(define-key ediff-mode-map "r" nil)
(cond (ediff-merge-job
;; Will barf if no ancestor
- (define-key ediff-mode-map "/" 'ediff-toggle-show-ancestor)
+ (define-key ediff-mode-map "/" #'ediff-toggle-show-ancestor)
;; In merging, we allow only A->C and B->C copying.
- (define-key ediff-mode-map "a" 'ediff-copy-A-to-C)
- (define-key ediff-mode-map "b" 'ediff-copy-B-to-C)
- (define-key ediff-mode-map "r" 'ediff-restore-diff-in-merge-buffer)
- (define-key ediff-mode-map "s" 'ediff-shrink-window-C)
- (define-key ediff-mode-map "+" 'ediff-combine-diffs)
+ (define-key ediff-mode-map "a" #'ediff-copy-A-to-C)
+ (define-key ediff-mode-map "b" #'ediff-copy-B-to-C)
+ (define-key ediff-mode-map "r" #'ediff-restore-diff-in-merge-buffer)
+ (define-key ediff-mode-map "s" #'ediff-shrink-window-C)
+ (define-key ediff-mode-map "+" #'ediff-combine-diffs)
(define-key ediff-mode-map "$" nil)
- (define-key ediff-mode-map "$$" 'ediff-toggle-show-clashes-only)
- (define-key ediff-mode-map "$*" 'ediff-toggle-skip-changed-regions)
- (define-key ediff-mode-map "&" 'ediff-re-merge))
+ (define-key ediff-mode-map "$$" #'ediff-toggle-show-clashes-only)
+ (define-key ediff-mode-map "$*" #'ediff-toggle-skip-changed-regions)
+ (define-key ediff-mode-map "&" #'ediff-re-merge))
(ediff-3way-comparison-job
- (define-key ediff-mode-map "ab" 'ediff-copy-A-to-B)
- (define-key ediff-mode-map "ba" 'ediff-copy-B-to-A)
- (define-key ediff-mode-map "ac" 'ediff-copy-A-to-C)
- (define-key ediff-mode-map "bc" 'ediff-copy-B-to-C)
+ (define-key ediff-mode-map "ab" #'ediff-copy-A-to-B)
+ (define-key ediff-mode-map "ba" #'ediff-copy-B-to-A)
+ (define-key ediff-mode-map "ac" #'ediff-copy-A-to-C)
+ (define-key ediff-mode-map "bc" #'ediff-copy-B-to-C)
(define-key ediff-mode-map "c" nil)
- (define-key ediff-mode-map "ca" 'ediff-copy-C-to-A)
- (define-key ediff-mode-map "cb" 'ediff-copy-C-to-B)
- (define-key ediff-mode-map "ra" 'ediff-restore-diff)
- (define-key ediff-mode-map "rb" 'ediff-restore-diff)
- (define-key ediff-mode-map "rc" 'ediff-restore-diff)
- (define-key ediff-mode-map "C" 'ediff-toggle-read-only))
+ (define-key ediff-mode-map "ca" #'ediff-copy-C-to-A)
+ (define-key ediff-mode-map "cb" #'ediff-copy-C-to-B)
+ (define-key ediff-mode-map "ra" #'ediff-restore-diff)
+ (define-key ediff-mode-map "rb" #'ediff-restore-diff)
+ (define-key ediff-mode-map "rc" #'ediff-restore-diff)
+ (define-key ediff-mode-map "C" #'ediff-toggle-read-only))
(t ; 2-way comparison
- (define-key ediff-mode-map "a" 'ediff-copy-A-to-B)
- (define-key ediff-mode-map "b" 'ediff-copy-B-to-A)
- (define-key ediff-mode-map "ra" 'ediff-restore-diff)
- (define-key ediff-mode-map "rb" 'ediff-restore-diff))
+ (define-key ediff-mode-map "a" #'ediff-copy-A-to-B)
+ (define-key ediff-mode-map "b" #'ediff-copy-B-to-A)
+ (define-key ediff-mode-map "ra" #'ediff-restore-diff)
+ (define-key ediff-mode-map "rb" #'ediff-restore-diff))
) ; cond
- (define-key ediff-mode-map "G" 'ediff-submit-report)
+ (define-key ediff-mode-map "G" #'ediff-submit-report)
(define-key ediff-mode-map "#" nil)
- (define-key ediff-mode-map "#h" 'ediff-toggle-regexp-match)
- (define-key ediff-mode-map "#f" 'ediff-toggle-regexp-match)
- (define-key ediff-mode-map "#c" 'ediff-toggle-ignore-case)
+ (define-key ediff-mode-map "#h" #'ediff-toggle-regexp-match)
+ (define-key ediff-mode-map "#f" #'ediff-toggle-regexp-match)
+ (define-key ediff-mode-map "#c" #'ediff-toggle-ignore-case)
(or ediff-word-mode
- (define-key ediff-mode-map "##" 'ediff-toggle-skip-similar))
+ (define-key ediff-mode-map "##" #'ediff-toggle-skip-similar))
(define-key ediff-mode-map "o" nil)
- (define-key ediff-mode-map "A" 'ediff-toggle-read-only)
- (define-key ediff-mode-map "B" 'ediff-toggle-read-only)
+ (define-key ediff-mode-map "A" #'ediff-toggle-read-only)
+ (define-key ediff-mode-map "B" #'ediff-toggle-read-only)
(define-key ediff-mode-map "w" nil)
- (define-key ediff-mode-map "wa" 'ediff-save-buffer)
- (define-key ediff-mode-map "wb" 'ediff-save-buffer)
- (define-key ediff-mode-map "wd" 'ediff-save-buffer)
- (define-key ediff-mode-map "=" 'ediff-inferior-compare-regions)
+ (define-key ediff-mode-map "wa" #'ediff-save-buffer)
+ (define-key ediff-mode-map "wb" #'ediff-save-buffer)
+ (define-key ediff-mode-map "wd" #'ediff-save-buffer)
+ (define-key ediff-mode-map "=" #'ediff-inferior-compare-regions)
(if (and (fboundp 'ediff-show-patch-diagnostics) (ediff-patch-job))
- (define-key ediff-mode-map "P" 'ediff-show-patch-diagnostics))
+ (define-key ediff-mode-map "P" #'ediff-show-patch-diagnostics))
(if ediff-3way-job
(progn
- (define-key ediff-mode-map "wc" 'ediff-save-buffer)
- (define-key ediff-mode-map "gc" 'ediff-jump-to-difference-at-point)
+ (define-key ediff-mode-map "wc" #'ediff-save-buffer)
+ (define-key ediff-mode-map "gc" #'ediff-jump-to-difference-at-point)
))
- (define-key ediff-mode-map "m" 'ediff-toggle-wide-display)
+ (define-key ediff-mode-map "m" #'ediff-toggle-wide-display)
;; Allow ediff-mode-map to be referenced indirectly
(fset 'ediff-mode-map ediff-mode-map)
@@ -241,18 +240,16 @@ to invocation.")
startup-hooks setup-parameters
&optional merge-buffer-file)
(run-hooks 'ediff-before-setup-hook)
- ;; ediff-convert-standard-filename puts file names in the form appropriate
+ ;; convert-standard-filename puts file names in the form appropriate
;; for the OS at hand.
- (setq file-A (ediff-convert-standard-filename (expand-file-name file-A)))
- (setq file-B (ediff-convert-standard-filename (expand-file-name file-B)))
+ (setq file-A (convert-standard-filename (expand-file-name file-A)))
+ (setq file-B (convert-standard-filename (expand-file-name file-B)))
(if (stringp file-C)
- (setq file-C
- (ediff-convert-standard-filename (expand-file-name file-C))))
+ (setq file-C (convert-standard-filename (expand-file-name file-C))))
(if (stringp merge-buffer-file)
(progn
(setq merge-buffer-file
- (ediff-convert-standard-filename
- (expand-file-name merge-buffer-file)))
+ (convert-standard-filename (expand-file-name merge-buffer-file)))
;; check the directory exists
(or (file-exists-p (file-name-directory merge-buffer-file))
(error "Directory %s given as place to save the merge doesn't exist"
@@ -278,8 +275,7 @@ to invocation.")
(make-local-variable 'ediff-window-setup-function)
(make-local-variable 'ediff-keep-variants)
- (make-local-variable 'window-min-height)
- (setq window-min-height 2)
+ (setq-local window-min-height 2)
;; unwrap set up parameters passed as argument
(while setup-parameters
@@ -567,8 +563,9 @@ to invocation.")
(set-visited-file-name merge-buffer-file))))
(ediff-with-current-buffer ediff-buffer-C
(setq buffer-offer-save t) ; ask before killing buffer
- ;; make sure the contents is auto-saved
- (auto-save-mode 1))
+ (when make-backup-files
+ ;; make sure the contents is auto-saved
+ (auto-save-mode 1)))
))
@@ -1540,10 +1537,10 @@ the width of the A/B/C windows."
;; hscrolling.
(if (= last-command-event ?<)
(lambda (arg)
- (let ((prefix-arg arg))
+ (let ((current-prefix-arg arg))
(call-interactively #'scroll-left)))
(lambda (arg)
- (let ((prefix-arg arg))
+ (let ((current-prefix-arg arg))
(call-interactively #'scroll-right))))
;; calculate argument to scroll-left/right
;; if there is an explicit argument
@@ -2006,9 +2003,8 @@ ARG is a prefix argument. If nil, copy the current difference region."
(goto-char reg-to-delete-end)
(insert reg-to-copy)
- (if (> reg-to-delete-end reg-to-delete-beg)
- (kill-region reg-to-delete-beg reg-to-delete-end))
- ))
+ (when (> reg-to-delete-end reg-to-delete-beg)
+ (delete-region reg-to-delete-beg reg-to-delete-end))))
(or batch-invocation
(setq
messg
@@ -2109,8 +2105,8 @@ ARG is a prefix argument. If nil, copy the current difference region."
(goto-char reg-end)
(insert saved-diff)
- (if (> reg-end reg-beg)
- (kill-region reg-beg reg-end))
+ (when (> reg-end reg-beg)
+ (delete-region reg-beg reg-end))
(setq recovered t)
))
@@ -2184,19 +2180,18 @@ a regular expression typed in by the user."
(setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function
regexp-A
(read-string
- (format
- "Ignore A-regions matching this regexp (default %s): "
- ediff-regexp-hide-A))
+ (format-prompt
+ "Ignore A-regions matching this regexp" ediff-regexp-hide-A))
regexp-B
(read-string
- (format
- "Ignore B-regions matching this regexp (default %s): "
+ (format-prompt
+ "Ignore B-regions matching this regexp"
ediff-regexp-hide-B)))
(if ediff-3way-comparison-job
(setq regexp-C
(read-string
- (format
- "Ignore C-regions matching this regexp (default %s): "
+ (format-prompt
+ "Ignore C-regions matching this regexp"
ediff-regexp-hide-C))))
(if (eq ediff-hide-regexp-connective 'and)
(setq msg-connective "BOTH"
@@ -2223,20 +2218,18 @@ a regular expression typed in by the user."
ediff-focus-on-regexp-matches-function
regexp-A
(read-string
- (format
- "Focus on A-regions matching this regexp (default %s): "
- ediff-regexp-focus-A))
+ (format-prompt
+ "Focus on A-regions matching this regexp" ediff-regexp-focus-A))
regexp-B
(read-string
- (format
- "Focus on B-regions matching this regexp (default %s): "
- ediff-regexp-focus-B)))
+ (format-prompt
+ "Focus on B-regions matching this regexp" ediff-regexp-focus-B)))
(if ediff-3way-comparison-job
(setq regexp-C
(read-string
- (format
- "Focus on C-regions matching this regexp (default %s): "
- ediff-regexp-focus-C))))
+ (format-prompt
+ "Focus on C-regions matching this regexp"
+ ediff-regexp-focus-C))))
(if (eq ediff-focus-regexp-connective 'and)
(setq msg-connective "BOTH"
alt-msg-connective "ONE OF"
@@ -3070,10 +3063,8 @@ Hit \\[ediff-recenter] to reset the windows afterward."
;; for compatibility
-(defmacro ediff-minibuffer-with-setup-hook (fun &rest body)
- `(if (fboundp 'minibuffer-with-setup-hook)
- (minibuffer-with-setup-hook ,fun ,@body)
- ,@body))
+(define-obsolete-function-alias 'ediff-minibuffer-with-setup-hook
+ #'minibuffer-with-setup-hook "28.1")
;; This is adapted from a similar function in `emerge.el'.
;; PROMPT should not have a trailing ': ', so that it can be modified
@@ -3102,7 +3093,7 @@ Hit \\[ediff-recenter] to reset the windows afterward."
(and default-file (list default-file))
default-dir)))
f)
- (setq f (ediff-minibuffer-with-setup-hook
+ (setq f (minibuffer-with-setup-hook
(lambda () (when defaults
(setq minibuffer-default defaults)))
(read-file-name
@@ -3135,7 +3126,7 @@ Hit \\[ediff-recenter] to reset the windows afterward."
;; Also, save buffer from START to END in the file.
;; START defaults to (point-min), END to (point-max)
(defun ediff-make-temp-file (buff &optional prefix given-file start end)
- (let* ((p (ediff-convert-standard-filename (or prefix "ediff")))
+ (let* ((p (convert-standard-filename (or prefix "ediff")))
(short-p p)
(coding-system-for-write ediff-coding-system-for-write)
f short-f)
@@ -3144,8 +3135,8 @@ Hit \\[ediff-recenter] to reset the windows afterward."
(> (length p) 2))
(setq short-p (substring p 0 2)))
- (setq f (concat ediff-temp-file-prefix p)
- short-f (concat ediff-temp-file-prefix short-p)
+ (setq f (concat temporary-file-directory p)
+ short-f (concat temporary-file-directory short-p)
f (cond (given-file)
((find-file-name-handler f 'insert-file-contents)
;; to thwart file name handlers in write-region,
@@ -3449,19 +3440,17 @@ Without an argument, it saves customized diff argument, if available
(declare-function ediff-regions-internal "ediff"
(buffer-a beg-a end-a buffer-b beg-b end-b
startup-hooks job-name word-mode setup-parameters))
-(defvar zmacs-regions) ;;XEmacs'ism.
(defun ediff-inferior-compare-regions ()
"Compare regions in an active Ediff session.
-Like `ediff-regions-linewise' but is called from under an active Ediff session on
-the files that belong to that session.
+Like `ediff-regions-linewise' but is called from under an active Ediff session
+on the files that belong to that session.
After quitting the session invoked via this function, type C-l to the parent
Ediff Control Panel to restore highlighting."
(interactive)
(let ((answer "")
(possibilities (list ?A ?B ?C))
- (zmacs-regions t)
use-current-diff-p
begA begB endA endB bufA bufB)
@@ -4009,8 +3998,8 @@ Mail anyway? (y or n) ")
(define-obsolete-function-alias 'ediff-deactivate-mark #'deactivate-mark "27.1")
(defun ediff-activate-mark ()
- (make-local-variable 'transient-mark-mode)
- (setq mark-active 'ediff-util transient-mark-mode t))
+ (setq mark-active 'ediff-util)
+ (setq-local transient-mark-mode t))
(define-obsolete-function-alias 'ediff-nuke-selective-display #'ignore "27.1")
@@ -4139,10 +4128,10 @@ Mail anyway? (y or n) ")
(ediff-with-current-buffer standard-output
(fundamental-mode))
(princ (format "\nCtl buffer: %S\n" ediff-control-buffer))
- (ediff-print-diff-vector (intern "ediff-difference-vector-A"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-B"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-C"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-Ancestor"))
+ (ediff-print-diff-vector 'ediff-difference-vector-A)
+ (ediff-print-diff-vector 'ediff-difference-vector-B)
+ (ediff-print-diff-vector 'ediff-difference-vector-C)
+ (ediff-print-diff-vector 'ediff-difference-vector-Ancestor)
))
@@ -4199,12 +4188,7 @@ Mail anyway? (y or n) ")
(cdr result)))
(define-obsolete-function-alias 'ediff-add-to-history #'add-to-history "27.1")
-
-(defalias 'ediff-copy-list 'copy-sequence)
-
-
-;; don't report error if version control package wasn't found
-;;(ediff-load-version-control 'silent)
+(define-obsolete-function-alias 'ediff-copy-list #'copy-sequence "28.1")
(run-hooks 'ediff-load-hook)
diff --git a/lisp/vc/ediff-vers.el b/lisp/vc/ediff-vers.el
index 389da055590..9e82392725d 100644
--- a/lisp/vc/ediff-vers.el
+++ b/lisp/vc/ediff-vers.el
@@ -24,23 +24,9 @@
;;; Code:
-;; Compiler pacifier
-(defvar rcs-default-co-switches)
+(eval-when-compile (require 'ediff-init))
-(and noninteractive
- (eval-when-compile
- (condition-case nil
- ;; for compatibility with current stable version of xemacs
- (progn
- ;;(require 'pcvs nil 'noerror)
- ;;(require 'rcs nil 'noerror)
- (require 'pcvs)
- (require 'rcs))
- (error nil))
- (require 'vc)
- (require 'ediff-init)
- ))
-;; end pacifier
+(defvar rcs-default-co-switches)
(defcustom ediff-keep-tmp-versions nil
"If t, do not delete temporary previous versions for the files on which
@@ -49,15 +35,10 @@ comparison or merge operations are being performed."
:group 'ediff-vers
)
-(defalias 'ediff-vc-revision-other-window
- (if (fboundp 'vc-revision-other-window)
- 'vc-revision-other-window
- 'vc-version-other-window))
-
-(defalias 'ediff-vc-working-revision
- (if (fboundp 'vc-working-revision)
- 'vc-working-revision
- 'vc-workfile-version))
+(define-obsolete-function-alias 'ediff-vc-revision-other-window
+ #'vc-revision-other-window "28.1")
+(define-obsolete-function-alias 'ediff-vc-working-revision
+ #'vc-working-revision "28.1")
;; VC.el support
@@ -88,12 +69,12 @@ comparison or merge operations are being performed."
(setq rev1 (ediff-vc-latest-version (buffer-file-name))))
(save-window-excursion
(save-excursion
- (ediff-vc-revision-other-window rev1)
+ (vc-revision-other-window rev1)
(setq rev1buf (current-buffer)
file1 (buffer-file-name)))
(save-excursion
(or (string= rev2 "") ; use current buffer
- (ediff-vc-revision-other-window rev2))
+ (vc-revision-other-window rev2))
(setq rev2buf (current-buffer)
file2 (buffer-file-name)))
(push (lambda ()
@@ -165,18 +146,18 @@ comparison or merge operations are being performed."
(let (buf1 buf2 ancestor-buf)
(save-window-excursion
(save-excursion
- (ediff-vc-revision-other-window rev1)
+ (vc-revision-other-window rev1)
(setq buf1 (current-buffer)))
(save-excursion
(or (string= rev2 "")
- (ediff-vc-revision-other-window rev2))
+ (vc-revision-other-window rev2))
(setq buf2 (current-buffer)))
(if ancestor-rev
(save-excursion
(if (string= ancestor-rev "")
- (setq ancestor-rev (ediff-vc-working-revision
+ (setq ancestor-rev (vc-working-revision
buffer-file-name)))
- (ediff-vc-revision-other-window ancestor-rev)
+ (vc-revision-other-window ancestor-rev)
(setq ancestor-buf (current-buffer))))
(push (let ((f1 (buffer-file-name buf1))
(f2 (unless (string= rev2 "") (buffer-file-name buf2)))
diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el
index f348d294fe6..fc6ea944ae1 100644
--- a/lisp/vc/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -42,13 +42,6 @@
(require 'ediff-help)
;; end pacifier
-
-;; be careful with ediff-tbar
-(eval-and-compile
- (if (featurep 'xemacs)
- (require 'ediff-tbar)
- (defun ediff-compute-toolbar-width () 0)))
-
(defgroup ediff-window nil
"Ediff window manipulation."
:prefix "ediff-"
@@ -156,12 +149,10 @@ In this case, Ediff will use those frames to display these buffers."
'(name . "Ediff")
;;'(unsplittable . t)
'(minibuffer . nil)
- '(user-position . t) ; Emacs only
- '(vertical-scroll-bars . nil) ; Emacs only
- '(scrollbar-width . 0) ; XEmacs only
- '(scrollbar-height . 0) ; XEmacs only
- '(menu-bar-lines . 0) ; Emacs only
- '(tool-bar-lines . 0) ; Emacs 21+ only
+ '(user-position . t)
+ '(vertical-scroll-bars . nil)
+ '(menu-bar-lines . 0)
+ '(tool-bar-lines . 0)
'(left-fringe . 0)
'(right-fringe . 0)
;; don't lower but auto-raise
@@ -191,7 +182,7 @@ Used internally---not a user option.")
;; not used for now
(defvar ediff-mouse-pixel-threshold 30
- "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.")
+ "If mouse moved more than this many pixels, don't warp mouse into control window.")
(defcustom ediff-grab-mouse t
"If t, Ediff will always grab the mouse and put it in the control frame.
@@ -260,10 +251,9 @@ the frame used for the wide display.")
This has effect only on a windowing system.
If t, hitting `?' to toggle control panel off iconifies it.
-This is only useful in Emacs and only for certain kinds of window managers,
-such as TWM and its derivatives, since the window manager must permit
-keyboard input to go into icons. XEmacs completely ignores keyboard input
-into icons, regardless of the window manager."
+This is only useful for certain kinds of window managers, such as
+TWM and its derivatives, since the window manager must permit
+keyboard input to go into icons."
:type 'boolean)
;;; Functions
@@ -272,11 +262,12 @@ into icons, regardless of the window manager."
(let (event)
(message
"Select windows by clicking. Please click on Window %d " wind-number)
- (while (not (ediff-mouse-event-p (setq event (read-event))))
+ (while (not (ediff-mouse-event-p (setq event
+ (read--potential-mouse-event))))
(if (sit-for 1) ; if sequence of events, wait till the final word
(beep 1))
(message "Please click on Window %d " wind-number))
- (read-event) ; discard event
+ (read--potential-mouse-event) ; discard event
(posn-window (event-start event))))
@@ -952,8 +943,7 @@ create a new splittable frame if none is found."
;; just a precaution--we should be in ctl-buffer already
(with-current-buffer ctl-buffer
(make-local-variable 'frame-title-format)
- (make-local-variable 'frame-icon-title-format) ; XEmacs
- (make-local-variable 'icon-title-format)) ; Emacs
+ (make-local-variable 'icon-title-format))
(ediff-setup-control-buffer ctl-buffer)
(setq dont-iconify-ctl-frame
@@ -965,8 +955,7 @@ create a new splittable frame if none is found."
;; 1 more line for the mode line
(setq lines (1+ (count-lines (point-min) (point-max)))
fheight lines
- fwidth (max (+ (ediff-help-message-line-length) 2)
- (ediff-compute-toolbar-width))
+ fwidth (max (+ (ediff-help-message-line-length) 2) 0)
adjusted-parameters
(list
;; possibly change surrogate minibuffer
@@ -1054,8 +1043,8 @@ create a new splittable frame if none is found."
(with-current-buffer ctl-buffer
(let* ((frame-A (window-frame ediff-window-A))
(frame-A-parameters (frame-parameters frame-A))
- (frame-A-top (eval (cdr (assoc 'top frame-A-parameters))))
- (frame-A-left (eval (cdr (assoc 'left frame-A-parameters))))
+ (frame-A-top (eval (cdr (assoc 'top frame-A-parameters)) t))
+ (frame-A-left (eval (cdr (assoc 'left frame-A-parameters)) t))
(frame-A-width (frame-width frame-A))
(ctl-frame ediff-control-frame)
horizontal-adjustment upward-adjustment
@@ -1098,6 +1087,7 @@ create a new splittable frame if none is found."
)))
(defun ediff-xemacs-select-frame-hook ()
+ (declare (obsolete nil "28.1"))
(if (and (equal (selected-frame) ediff-control-frame)
(not ediff-use-long-help-message))
(raise-frame ediff-control-frame)))
@@ -1115,7 +1105,7 @@ It assumes that it is called from within the control buffer."
(cw (frame-char-width frame-A))
(wd (- (/ (display-pixel-width) cw) 5)))
(setq ediff-wide-display-orig-parameters
- (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params)))))
+ (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params)) t)))
(cons 'width (cdr (assoc 'width frame-A-params))))
ediff-wide-display-frame frame-A)
(modify-frame-parameters
@@ -1294,6 +1284,9 @@ It assumes that it is called from within the control buffer."
(ediff-multiframe-setup-p)
ediff-wide-display-p)))))))
+(defun ediff-compute-toolbar-width ()
+ (declare (obsolete nil "28.1"))
+ 0)
(provide 'ediff-wind)
;;; ediff-wind.el ends here
diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el
index 36e681c2b4c..3536cbf7381 100644
--- a/lisp/vc/ediff.el
+++ b/lisp/vc/ediff.el
@@ -264,7 +264,7 @@ arguments after setting up the Ediff buffers."
'ediff-files3))
;;;###autoload
-(defalias 'ediff3 'ediff-files3)
+(defalias 'ediff3 #'ediff-files3)
(defvar-local ediff--magic-file-name nil
"Name of file where buffer's content was saved.
@@ -359,7 +359,7 @@ has been saved (if not in `buffer-file-name')."
(declare-function diff-latest-backup-file "diff" (fn))
;;;###autoload
-(defalias 'ediff 'ediff-files)
+(defalias 'ediff #'ediff-files)
;;;###autoload
(defun ediff-current-file ()
@@ -442,7 +442,7 @@ symbol describing the Ediff job type; it defaults to
(ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name))
;;;###autoload
-(defalias 'ebuffers 'ediff-buffers)
+(defalias 'ebuffers #'ediff-buffers)
;;;###autoload
@@ -479,7 +479,7 @@ symbol describing the Ediff job type; it defaults to
(ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name))
;;;###autoload
-(defalias 'ebuffers3 'ediff-buffers3)
+(defalias 'ebuffers3 #'ediff-buffers3)
@@ -556,7 +556,7 @@ the same name in both. The third argument, REGEXP, is nil or a regular
expression; only file names that match the regexp are considered."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
f)
(list (setq f (read-directory-name
"Directory A to compare: " dir-A nil 'must-match))
@@ -566,20 +566,18 @@ expression; only file names that match the regexp are considered."
(ediff-strip-last-dir f))
nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directories-internal
dir1 dir2 nil regexp #'ediff-files 'ediff-directories
))
;;;###autoload
-(defalias 'edirs 'ediff-directories)
+(defalias 'edirs #'ediff-directories)
;;;###autoload
@@ -589,25 +587,23 @@ The second argument, REGEXP, is a regular expression that filters the file
names. Only the files that are under revision control are taken into account."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
)
(list (read-directory-name
"Directory to compare with revision:" dir-A nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt
+ "Filter filenames through regular expression" default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directory-revisions-internal
- dir1 regexp 'ediff-revision 'ediff-directory-revisions
+ dir1 regexp #'ediff-revision 'ediff-directory-revisions
))
;;;###autoload
-(defalias 'edir-revisions 'ediff-directory-revisions)
+(defalias 'edir-revisions #'ediff-directory-revisions)
;;;###autoload
@@ -618,7 +614,7 @@ regular expression; only file names that match the regexp are considered."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
f)
(list (setq f (read-directory-name "Directory A to compare:" dir-A nil))
(setq f (read-directory-name "Directory B to compare:"
@@ -632,20 +628,18 @@ regular expression; only file names that match the regexp are considered."
(ediff-strip-last-dir f))
nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directories-internal
dir1 dir2 dir3 regexp #'ediff-files3 'ediff-directories3
))
;;;###autoload
-(defalias 'edirs3 'ediff-directories3)
+(defalias 'edirs3 #'ediff-directories3)
;;;###autoload
(defun ediff-merge-directories (dir1 dir2 regexp &optional merge-autostore-dir)
@@ -655,7 +649,7 @@ expression; only file names that match the regexp are considered.
MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
f)
(list (setq f (read-directory-name "Directory A to merge:"
dir-A nil 'must-match))
@@ -665,13 +659,11 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(ediff-strip-last-dir f))
nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directories-internal
dir1 dir2 nil regexp #'ediff-merge-files 'ediff-merge-directories
@@ -679,7 +671,7 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
))
;;;###autoload
-(defalias 'edirs-merge 'ediff-merge-directories)
+(defalias 'edirs-merge #'ediff-merge-directories)
;;;###autoload
(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp
@@ -693,7 +685,7 @@ only file names that match the regexp are considered.
MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
f)
(list (setq f (read-directory-name "Directory A to merge:" dir-A nil))
(setq f (read-directory-name "Directory B to merge:"
@@ -707,13 +699,11 @@ MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(ediff-strip-last-dir f))
nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directories-internal
dir1 dir2 ancestor-dir regexp
@@ -730,26 +720,24 @@ names. Only the files that are under revision control are taken into account.
MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
)
(list (read-directory-name
"Directory to merge with revisions:" dir-A nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directory-revisions-internal
- dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions
+ dir1 regexp #'ediff-merge-revisions 'ediff-merge-directory-revisions
nil merge-autostore-dir
))
;;;###autoload
-(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions)
+(defalias 'edir-merge-revisions #'ediff-merge-directory-revisions)
;;;###autoload
(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp
@@ -761,22 +749,20 @@ names. Only the files that are under revision control are taken into account.
MERGE-AUTOSTORE-DIR is the directory in which to store merged files."
(interactive
(let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
+ (default-regexp (eval ediff-default-filtering-regexp t))
)
(list (read-directory-name
"Directory to merge with revisions and ancestors:"
dir-A nil 'must-match)
(read-string
- (if (stringp default-regexp)
- (format "Filter filenames through regular expression (default %s): "
- default-regexp)
- "Filter filenames through regular expression: ")
+ (format-prompt "Filter filenames through regular expression"
+ default-regexp)
nil
'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
+ (eval ediff-default-filtering-regexp t))
)))
(ediff-directory-revisions-internal
- dir1 regexp 'ediff-merge-revisions-with-ancestor
+ dir1 regexp #'ediff-merge-revisions-with-ancestor
'ediff-merge-directory-revisions-with-ancestor
nil merge-autostore-dir
))
@@ -953,7 +939,7 @@ arguments after setting up the Ediff buffers."
;; If WIND-A is nil, use selected window.
;; If WIND-B is nil, use window next to WIND-A.
(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode)
- (if (or dumb-mode (not (ediff-window-display-p)))
+ (if (or dumb-mode (not (display-mouse-p)))
(setq wind-A (ediff-get-next-window wind-A nil)
wind-B (ediff-get-next-window wind-B wind-A))
(setq wind-A (ediff-get-window-by-clicking wind-A nil 1)
@@ -1353,16 +1339,18 @@ the merge buffer."
(let (rev1 rev2)
(setq rev1
(read-string
- (format-message
- "Version 1 to merge (default %s's working version): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
+ (format-prompt "Version 1 to merge"
+ (concat
+ (if (stringp file)
+ (file-name-nondirectory file)
+ "current buffer")
+ "'s working version")))
rev2
(read-string
- (format
- "Version 2 to merge (default %s): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer"))))
+ (format-prompt "Version 2 to merge"
+ (if (stringp file)
+ (file-name-nondirectory file)
+ "current buffer"))))
(ediff-load-version-control)
;; ancestor-revision=nil
(funcall
@@ -1388,22 +1376,26 @@ the merge buffer."
(let (rev1 rev2 ancestor-rev)
(setq rev1
(read-string
- (format-message
- "Version 1 to merge (default %s's working version): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
+ (format-prompt "Version 1 to merge"
+ (concat
+ (if (stringp file)
+ (file-name-nondirectory file)
+ "current buffer")
+ "'s working version")))
rev2
(read-string
- (format
- "Version 2 to merge (default %s): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
+ (format-prompt "Version 2 to merge"
+ (if (stringp file)
+ (file-name-nondirectory file)
+ "current buffer")))
ancestor-rev
- (read-string
- (format-message
- "Ancestor version (default %s's base revision): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer"))))
+ (read-string (format-prompt
+ "Ancestor version"
+ (concat
+ (if (stringp file)
+ (file-name-nondirectory file)
+ "current buffer")
+ "'s base revision"))))
(ediff-load-version-control)
(funcall
(intern (format "ediff-%S-merge-internal" ediff-version-control-package))
@@ -1503,13 +1495,14 @@ arguments after setting up the Ediff buffers."
(save-buffer (current-buffer)))
(let (rev1 rev2)
(setq rev1
- (read-string
- (format "Revision 1 to compare (default %s's latest revision): "
- (file-name-nondirectory file)))
+ (read-string (format-prompt "Revision 1 to compare"
+ (concat (file-name-nondirectory file)
+ "'s latest revision")))
rev2
(read-string
- (format "Revision 2 to compare (default %s's current state): "
- (file-name-nondirectory file))))
+ (format-prompt "Revision 2 to compare"
+ (concat (file-name-nondirectory file)
+ "'s current state"))))
(ediff-load-version-control)
(funcall
(intern (format "ediff-%S-internal" ediff-version-control-package))
diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el
index fc8c318e3af..8f7affeea4e 100644
--- a/lisp/vc/emerge.el
+++ b/lisp/vc/emerge.el
@@ -79,90 +79,75 @@ but can be invoked directly in `fast' mode."
;; way they number lines of a file.
(defcustom emerge-diff-program "diff"
"Name of the program which compares two files."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-diff3-program "diff3"
"Name of the program which compares three files.
Its arguments are the ancestor file and the two variant files."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-diff-options ""
"Options to pass to `emerge-diff-program' and `emerge-diff3-program'."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-match-diff-line
(let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)"))
(concat "^" x "\\([acd]\\)" x "$"))
"Pattern to match lines produced by diff that describe differences.
This is as opposed to lines from the source files."
- :type 'regexp
- :group 'emerge)
+ :type 'regexp)
(defcustom emerge-diff-ok-lines-regexp
"^\\([0-9,]+[acd][0-9,]+$\\|[<>] \\|---\\)"
"Regexp that matches normal output lines from `emerge-diff-program'.
Lines that do not match are assumed to be error messages."
- :type 'regexp
- :group 'emerge)
+ :type 'regexp)
(defcustom emerge-diff3-ok-lines-regexp
"^\\([1-3]:\\|====\\| \\)"
"Regexp that matches normal output lines from `emerge-diff3-program'.
Lines that do not match are assumed to be error messages."
- :type 'regexp
- :group 'emerge)
+ :type 'regexp)
(defcustom emerge-rcs-ci-program "ci"
"Name of the program that checks in RCS revisions."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-rcs-co-program "co"
"Name of the program that checks out RCS revisions."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-process-local-variables nil
"Non-nil if Emerge should process local-variables lists in merge buffers.
\(You can explicitly request processing the local-variables
by executing `(hack-local-variables)'.)"
- :type 'boolean
- :group 'emerge)
+ :type 'boolean)
(defcustom emerge-execute-line-deletions nil
"If non-nil: `emerge-execute-line' makes no output if an input was deleted.
It concludes that an input version has been deleted when an ancestor entry
is present, only one A or B entry is present, and an output entry is present.
If nil: In such circumstances, the A or B file that is present will be
copied to the designated output file."
- :type 'boolean
- :group 'emerge)
+ :type 'boolean)
(defcustom emerge-before-flag "vvvvvvvvvvvvvvvvvvvv\n"
"Flag placed above the highlighted block of code. Must end with newline.
Must be set before Emerge is loaded, or emerge-new-flags must be run
after setting."
- :type 'string
- :group 'emerge)
+ :type 'string)
(defcustom emerge-after-flag "^^^^^^^^^^^^^^^^^^^^\n"
"Flag placed below the highlighted block of code. Must end with newline.
Must be set before Emerge is loaded, or emerge-new-flags must be run
after setting."
- :type 'string
- :group 'emerge)
+ :type 'string)
;; Hook variables
(defcustom emerge-startup-hook nil
"Hook to run in the merge buffer after the merge has been set up."
- :type 'hook
- :group 'emerge)
+ :type 'hook)
(defcustom emerge-select-hook nil
"Hook to run after a difference has been selected.
The variable `n' holds the (internal) number of the difference."
- :type 'hook
- :group 'emerge)
+ :type 'hook)
(defcustom emerge-unselect-hook nil
"Hook to run after a difference has been unselected.
The variable `n' holds the (internal) number of the difference."
- :type 'hook
- :group 'emerge)
+ :type 'hook)
;; Variables to control the default directories of the arguments to
;; Emerge commands.
@@ -171,8 +156,7 @@ The variable `n' holds the (internal) number of the difference."
"If nil, default dir for filenames in emerge is `default-directory'.
If non-nil, filenames complete in the directory of the last argument of the
same type to an `emerge-files...' command."
- :type 'boolean
- :group 'emerge)
+ :type 'boolean)
(defvar emerge-last-dir-A nil
"Last directory for the first file of an `emerge-files...' command.")
@@ -235,15 +219,13 @@ depend on the flags."
(defcustom emerge-min-visible-lines 3
"Number of lines that we want to show above and below the flags when we are
displaying a difference."
- :type 'integer
- :group 'emerge)
+ :type 'integer)
(defcustom emerge-temp-file-prefix
(expand-file-name "emerge" temporary-file-directory)
"Prefix to put on Emerge temporary file names.
Do not start with `~/' or `~USERNAME/'."
- :type 'string
- :group 'emerge)
+ :type 'string)
(make-obsolete-variable 'emerge-temp-file-prefix
"customize `temporary-file-directory' instead."
@@ -251,8 +233,7 @@ Do not start with `~/' or `~USERNAME/'."
(defcustom emerge-temp-file-mode 384 ; u=rw only
"Mode for Emerge temporary files."
- :type 'integer
- :group 'emerge)
+ :type 'integer)
(make-obsolete-variable 'emerge-temp-file-mode
"it has no effect, temporary files are always private."
@@ -268,8 +249,7 @@ The template is inserted as a string, with the following interpolations:
Don't forget to end the template with a newline.
Note that this variable can be made local to a particular merge buffer by
giving a prefix argument to `emerge-set-combine-versions-template'."
- :type 'string
- :group 'emerge)
+ :type 'string)
;; Build keymaps
@@ -294,8 +274,7 @@ Makes Emerge commands directly available.")
(defcustom emerge-command-prefix "\C-c\C-c"
"Command prefix for Emerge commands in `edit' mode.
Must be set before Emerge is loaded."
- :type 'string
- :group 'emerge)
+ :type 'string)
;; This function sets up the fixed keymaps. It is executed when the first
;; Emerge is done to allow the user maximum time to set up the global keymap.
@@ -1245,8 +1224,7 @@ Otherwise, the A or B file present is copied to the output file."
(defcustom emerge-merge-directories-filename-regexp "[^.]"
"Regexp describing files to be processed by `emerge-merge-directories'."
- :type 'regexp
- :group 'emerge)
+ :type 'regexp)
;;;###autoload
(defun emerge-merge-directories (a-dir b-dir ancestor-dir output-dir)
@@ -2757,15 +2735,14 @@ Otherwise, signal an error."
alternative-default-dir
(not (string-equal alternative-default-dir
(file-name-directory A-file))))
- (read-file-name (format "%s (default %s): "
- prompt (file-name-nondirectory A-file))
+ (read-file-name (format-prompt prompt (file-name-nondirectory A-file))
alternative-default-dir
(concat alternative-default-dir
(file-name-nondirectory A-file))
(and must-match 'confirm)))
;; If there is a default file, use it.
(default-file
- (read-file-name (format "%s (default %s): " prompt default-file)
+ (read-file-name (format-prompt prompt default-file)
;; If emerge-default-last-directories is set, use the
;; directory from the same argument of the last call of
;; Emerge as the default for this argument.
@@ -3071,8 +3048,7 @@ See also `auto-save-file-name-p'."
(defcustom emerge-metachars nil
"No longer used. Emerge now uses `shell-quote-argument'."
- :type '(choice (const nil) regexp)
- :group 'emerge)
+ :type '(choice (const nil) regexp))
(make-obsolete-variable 'emerge-metachars nil "26.1")
(provide 'emerge)
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index 17468f957cc..4a44787bb03 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -51,6 +51,9 @@
;; The main keymap
+(define-obsolete-variable-alias 'vc-log-mode-map 'log-edit-mode-map "28.1")
+(define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1")
+
(easy-mmode-defmap log-edit-mode-map
'(("\C-c\C-c" . log-edit-done)
("\C-c\C-a" . log-edit-insert-changelog)
@@ -67,10 +70,6 @@
"Keymap for the `log-edit-mode' (to edit version control log messages)."
:group 'log-edit)
-;; Compatibility with old names. Should we bother ?
-(defvar vc-log-mode-map log-edit-mode-map)
-(defvar vc-log-entry-mode vc-log-mode-map)
-
(easy-menu-define log-edit-menu log-edit-mode-map
"Menu used for `log-edit-mode'."
'("Log-Edit"
@@ -192,7 +191,8 @@ when this variable is set to nil.")
(defconst log-edit-files-buf "*log-edit-files*")
(defvar log-edit-initial-files nil)
(defvar log-edit-callback nil)
-(defvar log-edit-diff-function nil)
+(defvar log-edit-diff-function
+ (lambda () (error "Diff functionality has not been setup")))
(defvar log-edit-listfun nil)
(defvar log-edit-parent-buffer nil)
@@ -247,7 +247,9 @@ If the optional argument STRIDE is present, that is a step-width to use
when going through the comment ring, `log-edit-comment-ring'."
;; Why substring rather than regexp ? -sm
(interactive
- (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (list (read-string (format-prompt "Comment substring"
+ log-edit-last-comment-match)
+ nil nil log-edit-last-comment-match)))
(unless stride (setq stride 1))
(if (string= str "")
(setq str log-edit-last-comment-match)
@@ -264,7 +266,9 @@ when going through the comment ring, `log-edit-comment-ring'."
(defun log-edit-comment-search-forward (str)
"Search forwards through VC commit comment history for a match of STR."
(interactive
- (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (list (read-string (format-prompt "Comment substring"
+ log-edit-last-comment-match)
+ nil nil log-edit-last-comment-match)))
(log-edit-comment-search-backward str -1))
(defun log-edit-comment-to-change-log (&optional whoami file-name)
@@ -391,7 +395,8 @@ The first subexpression is the actual text of the field.")
nil lax))
("^\n"
(progn (goto-char (match-end 0)) (1+ (match-end 0))) nil
- (0 '(:height 0.1 :inverse-video t :extend t))))
+ (0 '(face (:height 0.1 :inverse-video t :extend t)
+ display-line-numbers-disable t rear-nonsticky t))))
(log-edit--match-first-line (0 'log-edit-summary))))
(defvar log-edit-font-lock-gnu-style nil
@@ -469,16 +474,16 @@ done. Otherwise, this function will use the current buffer."
(if mode
(funcall mode)
(log-edit-mode))
- (set (make-local-variable 'log-edit-callback) callback)
+ (setq-local log-edit-callback callback)
(if (listp params)
(dolist (crt params)
(set (make-local-variable (car crt)) (cdr crt)))
;; For backward compatibility with log-edit up to version 22.2
;; accept non-list PARAMS to mean `log-edit-list'.
- (set (make-local-variable 'log-edit-listfun) params))
+ (setq-local log-edit-listfun params))
- (if buffer (set (make-local-variable 'log-edit-parent-buffer) parent))
- (set (make-local-variable 'log-edit-initial-files) (log-edit-files))
+ (if buffer (setq-local log-edit-parent-buffer parent))
+ (setq-local log-edit-initial-files (log-edit-files))
(when setup
(erase-buffer)
(run-hooks 'log-edit-hook))
@@ -495,8 +500,10 @@ from which this is used might also provide additional commands (under
the \"C-x v\" prefix for VC commands, for example).
\\{log-edit-mode-map}"
- (set (make-local-variable 'font-lock-defaults)
- '(log-edit-font-lock-keywords t))
+ (setq-local font-lock-defaults '(log-edit-font-lock-keywords t))
+ (make-local-variable 'font-lock-extra-managed-props)
+ (cl-pushnew 'rear-nonsticky font-lock-extra-managed-props)
+ (cl-pushnew 'display-line-numbers-disable font-lock-extra-managed-props)
(setq-local jit-lock-contextually t) ;For the "first line is summary".
(setq-local fill-paragraph-function #'log-edit-fill-entry)
(make-local-variable 'log-edit-comment-ring-index)
@@ -662,9 +669,7 @@ comment history, see `log-edit-comment-ring', and hides `log-edit-files-buf'."
(defun log-edit-show-diff ()
"Show the diff for the files to be committed."
(interactive)
- (if (functionp log-edit-diff-function)
- (funcall log-edit-diff-function)
- (error "Diff functionality has not been setup")))
+ (funcall log-edit-diff-function))
(defun log-edit-show-files ()
"Show the list of files to be committed."
@@ -792,11 +797,15 @@ to build the Fixes: header.")
(declare-function diff-add-log-current-defuns "diff-mode" ())
(defun log-edit-generate-changelog-from-diff ()
- "Insert a VC commit log message by looking at the current diff.
-This command is intended to be uses on the \"*vc-log*\" buffer.
-This command will generate a ChangeLog entries listing the
-changed functions. You can then add a description where needed,
-and use \\[fill-paragraph] to join consecutive function names."
+ "Insert a VC commit log message by looking at the current diffs.
+This command is intended to be used in the \"*vc-log*\" buffer.
+This command will generate ChangeLog entries listing the modified
+files and functions changed in those files, based on the diffs
+you are about to commit. You can then add a description for each
+change where needed, and use \\[fill-paragraph] to join consecutive function
+names into a single entry where they all share the same description.
+Should you need to look at the diffs themselves, they can be found
+in the \"*vc-diff*\" buffer produced by this command."
(interactive)
(change-log-insert-entries
(with-current-buffer
@@ -991,16 +1000,17 @@ where LOGBUFFER is the name of the ChangeLog buffer, and each
(visiting-buffer (find-buffer-visiting file)))
;; If there is a buffer visiting FILE, and it has a local
;; value for `change-log-default-name', use that.
- (if (and visiting-buffer
+ (or (and visiting-buffer
(local-variable-p 'change-log-default-name
- visiting-buffer))
- (with-current-buffer visiting-buffer
- change-log-default-name)
- ;; `find-change-log' uses `change-log-default-name' if set
- ;; and sets it before exiting, so we need to work around
- ;; that memoizing which is undesired here.
- (setq change-log-default-name nil)
- (find-change-log)))))
+ visiting-buffer)
+ (with-current-buffer visiting-buffer
+ change-log-default-name))
+ ;; `find-change-log' uses `change-log-default-name' if set
+ ;; and sets it before exiting, so we need to work around
+ ;; that memoizing which is undesired here.
+ (progn
+ (setq change-log-default-name nil)
+ (find-change-log))))))
(when (or (find-buffer-visiting changelog-file-name)
(file-exists-p changelog-file-name)
add-log-dont-create-changelog-file)
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el
index 324ea3128e8..e8930979b5d 100644
--- a/lisp/vc/log-view.el
+++ b/lisp/vc/log-view.el
@@ -208,6 +208,10 @@ If it is nil, `log-view-toggle-entry-display' does nothing.")
"Face for the message header line in `log-view-mode'."
:group 'log-view)
+(defface log-view-commit-body '((t :inherit font-lock-comment-face))
+ "Face for the commit body in `log-view-mode'."
+ :version "28.1")
+
(defvar log-view-file-re
(concat "^\\(?:Working file: \\(?1:.+\\)" ;RCS and CVS.
;; Subversion has no such thing??
@@ -261,12 +265,10 @@ The match group number 1 should match the revision number itself.")
(define-derived-mode log-view-mode special-mode "Log-View"
"Major mode for browsing CVS log output."
(setq buffer-read-only t)
- (set (make-local-variable 'font-lock-defaults) log-view-font-lock-defaults)
- (set (make-local-variable 'beginning-of-defun-function)
- '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)
+ (setq-local font-lock-defaults log-view-font-lock-defaults)
+ (setq-local beginning-of-defun-function #'log-view-beginning-of-defun)
+ (setq-local end-of-defun-function #'log-view-end-of-defun)
+ (setq-local cvs-minor-wrap-function #'log-view-minor-wrap)
(hack-dir-local-variables-non-file-buffer))
;;;;
@@ -415,7 +417,7 @@ This calls `log-view-expanded-log-entry-function' to do the work."
(insert long-entry "\n")
(add-text-properties
beg (point)
- '(font-lock-face font-lock-comment-face log-view-comment t))
+ '(font-lock-face log-view-commit-body log-view-comment t))
(goto-char opoint))))))))
(defun log-view-beginning-of-defun (&optional arg)
diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el
index 2ee3da70274..54ef06960f9 100644
--- a/lisp/vc/pcvs-defs.el
+++ b/lisp/vc/pcvs-defs.el
@@ -1,4 +1,4 @@
-;;; pcvs-defs.el --- variable definitions for PCL-CVS
+;;; pcvs-defs.el --- variable definitions for PCL-CVS -*- lexical-binding: t; -*-
;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
@@ -71,7 +71,6 @@ versions, such as the one in SunOS-4.")
(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc")
"Path to your cvsrc file."
- :group 'pcl-cvs
:type '(file))
(defvar cvs-shared-start 4
@@ -96,24 +95,20 @@ If t, they will be removed from the *cvs* buffer after every command.
If `delayed', they will be removed from the *cvs* buffer before every command.
If `status', they will only be removed after a `cvs-mode-status' command.
Else, they will never be automatically removed from the *cvs* buffer."
- :group 'pcl-cvs
:type '(choice (const nil) (const status) (const delayed) (const t)))
(defcustom cvs-auto-remove-directories 'handled
"If `all', directory entries will never be shown.
If `handled', only non-handled directories will be shown.
If `empty', only non-empty directories will be shown."
- :group 'pcl-cvs
:type '(choice (const :tag "No" nil) (const all) (const handled) (const empty)))
(defcustom cvs-auto-revert t
"Non-nil if changed files should automatically be reverted."
- :group 'pcl-cvs
:type '(boolean))
(defcustom cvs-sort-ignore-file t
"Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically."
- :group 'pcl-cvs
:type '(boolean))
(defcustom cvs-force-dir-tag t
@@ -121,7 +116,6 @@ If `empty', only non-empty directories will be shown."
Tagging should generally be applied a directory at a time, but sometimes it is
useful to be able to tag a single file. The normal way to do that is to use
`cvs-mode-force-command' so as to temporarily override the restrictions."
- :group 'pcl-cvs
:type '(boolean))
(defcustom cvs-default-ignore-marks nil
@@ -130,7 +124,6 @@ Normally they run on the files that are marked (with `cvs-mode-mark'),
or the file under the cursor if no files are marked. If this variable
is set to a non-nil value they will by default run on the file on the
current line. See also `cvs-invert-ignore-marks'."
- :group 'pcl-cvs
:type '(boolean))
(defcustom cvs-invert-ignore-marks
@@ -143,7 +136,6 @@ current line. See also `cvs-invert-ignore-marks'."
"List of cvs commands that invert the default ignore-mark behavior.
Commands in this set will use the opposite default from the one set
in `cvs-default-ignore-marks'."
- :group 'pcl-cvs
:type '(set (const "diff")
(const "tag")
(const "ignore")))
@@ -154,7 +146,6 @@ Non-nil means that PCL-CVS will ask confirmation before removing files
except for files whose content can readily be recovered from the repository.
A value of `list' means that the list of files to be deleted will be
displayed when asking for confirmation."
- :group 'pcl-cvs
:type '(choice (const list)
(const t)
(const nil)))
@@ -162,7 +153,6 @@ displayed when asking for confirmation."
(defcustom cvs-add-default-message nil
"Default message to use when adding files.
If set to nil, `cvs-mode-add' will always prompt for a message."
- :group 'pcl-cvs
:type '(choice (const :tag "Prompt" nil)
(string)))
@@ -171,7 +161,6 @@ If set to nil, `cvs-mode-add' will always prompt for a message."
If non-nil, `cvs-mode-find-file' will place the cursor at the beginning of
the modified area. If the file is not locally modified, this will obviously
have no effect."
- :group 'pcl-cvs
:type '(boolean))
(defcustom cvs-buffer-name-alist
@@ -193,7 +182,6 @@ POSTPROC is a function that should be executed when the command terminates
The CMD used for `cvs-mode-commit' is \"message\". For that special
case, POSTPROC is called just after MODE with special arguments."
- :group 'pcl-cvs
:type '(repeat
(list (choice (const "diff")
(const "status")
@@ -236,7 +224,6 @@ Output from cvs is placed here for asynchronous commands.")
'(cvs-ediff-diff . cvs-ediff-merge)
'(cvs-emerge-diff . cvs-emerge-merge))
"Pair of functions to be used for resp. diff'ing and merg'ing interactively."
- :group 'pcl-cvs
:type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge))
(const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge))))
@@ -255,7 +242,6 @@ Alternatives are:
`samedir': reuse any cvs buffer displaying the same directory
`subdir': or reuse any cvs buffer displaying any sub- or super- directory
`always': reuse any cvs buffer."
- :group 'pcl-cvs
:type '(choice (const always) (const subdir) (const samedir) (const current)))
(defvar cvs-temp-buffer nil
@@ -424,8 +410,7 @@ This variable is buffer local and only used in the *cvs* buffer.")
(defcustom cvs-minor-mode-prefix "\C-xc"
"Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
- :type 'string
- :group 'pcl-cvs)
+ :type 'string)
(easy-mmode-defmap cvs-minor-mode-map
`((,cvs-minor-mode-prefix . cvs-mode-map)
diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el
index e1197176af2..21fe98dacab 100644
--- a/lisp/vc/pcvs-info.el
+++ b/lisp/vc/pcvs-info.el
@@ -1,4 +1,4 @@
-;;; pcvs-info.el --- internal representation of a fileinfo entry
+;;; pcvs-info.el --- internal representation of a fileinfo entry -*- lexical-binding: t; -*-
;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
@@ -384,8 +384,8 @@ For use by the ewoc package."
The ordering defined by this function is such that directories are
sorted alphabetically, and inside every directory the DIRCHANGE
fileinfo will appear first, followed by all files (alphabetically)."
- (let ((subtypea (cvs-fileinfo->subtype a))
- (subtypeb (cvs-fileinfo->subtype b)))
+ (let ( ;; (subtypea (cvs-fileinfo->subtype a))
+ ) ;; (subtypeb (cvs-fileinfo->subtype b))
(cond
;; Sort according to directories.
((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t)
diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el
index fa94c20a5d1..3a96c930544 100644
--- a/lisp/vc/pcvs-parse.el
+++ b/lisp/vc/pcvs-parse.el
@@ -1,4 +1,4 @@
-;;; pcvs-parse.el --- the CVS output parser
+;;; pcvs-parse.el --- the CVS output parser -*- lexical-binding: t; -*-
;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
@@ -73,12 +73,12 @@ by `$'."
'("status" "add" "commit" "update" "remove" "checkout" "ci")
"List of CVS commands whose output is understood by the parser.")
-(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir)
+(defun cvs-parse-buffer (parse-spec dcd &optional subdir)
"Parse current buffer according to PARSE-SPEC.
PARSE-SPEC is a function of no argument advancing the point and returning
either a fileinfo or t (if the matched text should be ignored) or
nil if it didn't match anything.
-DONT-CHANGE-DISC just indicates whether the command was changing the disc
+DCD just indicates whether the command was changing the disc
or not (useful to tell the difference between `cvs-examine' and `cvs-update'
output.
The path names should be interpreted as relative to SUBDIR (defaults
@@ -86,6 +86,7 @@ The path names should be interpreted as relative to SUBDIR (defaults
Return a list of collected entries, or t if an error occurred."
(goto-char (point-min))
(let ((fileinfos ())
+ (dont-change-disc dcd)
(cvs-current-dir "")
(case-fold-search nil)
(cvs-current-subdir (or subdir "")))
@@ -134,12 +135,12 @@ Match RE and if successful, execute MATCHES."
(defmacro cvs-or (&rest alts)
"Try each one of the ALTS alternatives until one matches."
+ (declare (debug t))
`(let ((-cvs-parse-point (point)))
,(cons 'or
(mapcar (lambda (es)
`(or ,es (ignore (goto-char -cvs-parse-point))))
alts))))
-(def-edebug-spec cvs-or t)
;; This is how parser tables should be executed
(defun cvs-parse-run-table (parse-spec)
@@ -185,17 +186,20 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
(let ((type (if (consp type) (car type) type))
(subtype (if (consp type) (cdr type))))
(when dir (setq cvs-current-dir dir))
- (apply 'cvs-create-fileinfo type
+ (apply #'cvs-create-fileinfo type
(concat cvs-current-subdir (or dir cvs-current-dir))
file (cvs-parse-msg) :subtype subtype keys))))
;;;; CVS Process Parser Tables:
-;;;;
-;;;; The table for status and update could actually be merged since they
-;;;; don't conflict. But they don't overlap much either.
+;;
+;; The table for status and update could actually be merged since they
+;; don't conflict. But they don't overlap much either.
(defun cvs-parse-table ()
"Table of message objects for `cvs-parse-process'."
+ (with-suppressed-warnings ((lexical c file dir path base-rev subtype))
+ (defvar c) (defvar file) (defvar dir) (defvar path) (defvar base-rev)
+ (defvar subtype))
(let (c file dir path base-rev subtype)
(cvs-or
@@ -401,6 +405,8 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
(defun cvs-parse-merge ()
+ (with-suppressed-warnings ((lexical path base-rev head-rev type))
+ (defvar path) (defvar base-rev) (defvar head-rev) (defvar type))
(let (path base-rev head-rev type)
;; A merge (maybe with a conflict).
(and
@@ -445,6 +451,9 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
:merge (cons base-rev head-rev))))))
(defun cvs-parse-status ()
+ (with-suppressed-warnings ((lexical nofile path base-rev head-rev type))
+ (defvar nofile) (defvar path) (defvar base-rev) (defvar head-rev)
+ (defvar type))
(let (nofile path base-rev head-rev type)
(and
(cvs-match
@@ -472,7 +481,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
;; Let's not get all worked up if the format changes a bit
(cvs-match " *Working revision:.*$"))
(cvs-or
- (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1))
+ (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\).*$" (head-rev 1))
(cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$"
(head-rev 1))
(cvs-match " *Repository revision:.*"))
@@ -493,6 +502,8 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'."
:head-rev head-rev))))
(defun cvs-parse-commit ()
+ (with-suppressed-warnings ((lexical path file base-rev subtype))
+ (defvar path) (defvar file) (defvar base-rev) (defvar subtype))
(let (path file base-rev subtype)
(cvs-or
diff --git a/lisp/vc/pcvs-util.el b/lisp/vc/pcvs-util.el
index 57da7bf730e..75d9fe9bee1 100644
--- a/lisp/vc/pcvs-util.el
+++ b/lisp/vc/pcvs-util.el
@@ -1,4 +1,4 @@
-;;; pcvs-util.el --- utility functions for PCL-CVS
+;;; pcvs-util.el --- utility functions for PCL-CVS -*- lexical-binding: t; -*-
;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
@@ -33,27 +33,9 @@
;;;;
(defsubst cvs-car (x) (if (consp x) (car x) x))
-(defalias 'cvs-cdr 'cdr-safe)
+(defalias 'cvs-cdr #'cdr-safe)
(defsubst cvs-append (&rest xs)
- (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
-
-(defsubst cvs-every (-cvs-every-f -cvs-every-l)
- (while (consp -cvs-every-l)
- (unless (funcall -cvs-every-f (pop -cvs-every-l))
- (setq -cvs-every-l t)))
- (not -cvs-every-l))
-
-(defun cvs-union (xs ys)
- (let ((zs ys))
- (dolist (x xs zs)
- (unless (member x ys) (push x zs)))))
-
-(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
- (let ((accum ()))
- (while (not (cvs-every 'null -cvs-map-ls))
- (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
- (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
- (nreverse accum)))
+ (apply #'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
(defun cvs-first (l &optional n)
(if (null n) (car l)
@@ -146,7 +128,7 @@ If NOREUSE is non-nil, always return a new buffer."
"Insert a list of STRINGS into the current buffer.
Uses columns to keep the listing readable but compact."
(when (consp strings)
- (let* ((length (apply 'max (mapcar 'length strings)))
+ (let* ((length (apply #'max (mapcar #'length strings)))
(wwidth (1- (window-width)))
(columns (min
;; At least 2 columns; at least 2 spaces between columns.
@@ -174,7 +156,7 @@ arguments. If ARGS is not a list, no argument will be passed."
(condition-case nil
(with-temp-buffer
(if args
- (apply 'call-process
+ (apply #'call-process
file nil t nil (when (listp args) args))
(insert-file-contents file))
(goto-char (point-min))
@@ -182,7 +164,7 @@ arguments. If ARGS is not a list, no argument will be passed."
(if oneline (line-end-position) (point-max))))
(file-error nil)))
-(define-obsolete-function-alias 'cvs-string-prefix-p 'string-prefix-p "24.3")
+(define-obsolete-function-alias 'cvs-string-prefix-p #'string-prefix-p "24.3")
;;;;
;;;; file names
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index 882055fcfc3..42f531e4f75 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -115,7 +115,7 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(require 'ewoc) ;Ewoc was once cookie
(require 'pcvs-defs)
(require 'pcvs-util)
@@ -331,7 +331,7 @@ the primary since reading the primary can deactivate it."
"This mode is used for buffers related to a main *cvs* buffer.
All the `cvs-mode' buffer operations are simply rebound under
the \\[cvs-mode-map] prefix."
- nil " CVS"
+ :lighter " CVS"
:group 'pcl-cvs)
(put 'cvs-minor-mode 'permanent-local t)
@@ -356,10 +356,10 @@ from the current buffer."
((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
cvs-temp-buffer)
(t
- (set (make-local-variable 'cvs-temp-buffer)
- (cvs-get-buffer-create
- (eval cvs-temp-buffer-name `((dir . ,dir)))
- 'noreuse))))))
+ (setq-local cvs-temp-buffer
+ (cvs-get-buffer-create
+ (eval cvs-temp-buffer-name `((dir . ,dir)))
+ 'noreuse))))))
;; Handle the potential pre-existing process.
(let ((proc (get-buffer-process buf)))
@@ -381,7 +381,7 @@ from the current buffer."
(unless nosetup (save-excursion (display-buffer buf)))
;; FIXME: this doesn't do the right thing if the user later on
;; does a `find-file-other-window' and `scroll-other-window'
- (set (make-local-variable 'other-window-scroll-buffer) buf))
+ (setq-local other-window-scroll-buffer buf))
(add-to-list 'cvs-temp-buffers buf)
@@ -393,13 +393,13 @@ from the current buffer."
;; a very large and unwanted undo record.
(buffer-disable-undo)
(erase-buffer))
- (set (make-local-variable 'cvs-buffer) cvs-buf)
+ (setq-local cvs-buffer cvs-buf)
;;(cvs-minor-mode 1)
(let ((lbd list-buffers-directory))
(if (fboundp mode) (funcall mode) (fundamental-mode))
(when lbd (setq list-buffers-directory lbd)))
(cvs-minor-mode 1)
- ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
+ ;;(setq-local cvs-buffer cvs-buf)
(if normal
(buffer-enable-undo)
(setq buffer-read-only t)
@@ -466,10 +466,10 @@ If non-nil, NEW means to create a new buffer no matter what."
"\n")
(setq buffer-read-only t)
(cvs-mode)
- (set (make-local-variable 'list-buffers-directory) buffer-name)
- ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
+ (setq-local list-buffers-directory buffer-name)
+ ;;(setq-local cvs-temp-buffer (cvs-temp-buffer))
(let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t)))
- (set (make-local-variable 'cvs-cookies) cookies)
+ (setq-local cvs-cookies cookies)
(add-hook 'kill-buffer-hook
(lambda ()
(ignore-errors (kill-buffer cvs-temp-buffer)))
@@ -513,7 +513,7 @@ If non-nil, NEW means to create a new buffer no matter what."
(let* ((dir+files+rest
(if (or (null fis) (not single-dir))
;; not single-dir mode: just process the whole thing
- (list "" (mapcar 'cvs-fileinfo->full-name fis) nil)
+ (list "" (mapcar #'cvs-fileinfo->full-name fis) nil)
;; single-dir mode: extract the same-dir-elements
(let ((dir (cvs-fileinfo->dir (car fis))))
;; output the concerned dir so the parser can translate paths
@@ -1103,7 +1103,7 @@ for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
(let ((msg (match-string 1))
(lock (match-string 2)))
(with-current-buffer cvs-buffer
- (set (make-local-variable 'cvs-lock-file) lock)
+ (setq-local cvs-lock-file lock)
;; display the lock situation in the *cvs* buffer:
(ewoc-enter-last
cvs-cookies
@@ -1146,8 +1146,8 @@ Full documentation is in the Texinfo file."
(if buffer-file-name
(error "Use M-x cvs-quickdir to get a *cvs* buffer"))
(buffer-disable-undo)
- ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
- (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer)
+ ;;(setq-local goal-column cvs-cursor-column)
+ (setq-local revert-buffer-function 'cvs-mode-revert-buffer)
(setq truncate-lines t)
(cvs-prefix-make-local 'cvs-branch-prefix)
(cvs-prefix-make-local 'cvs-secondary-branch-prefix)
@@ -1464,7 +1464,7 @@ The POSTPROC specified there (typically `log-edit') is then called,
(funcall setupfun 'cvs-do-commit setup
'((log-edit-listfun . cvs-commit-filelist)
(log-edit-diff-function . cvs-mode-diff)) buf)
- (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
+ (setq-local cvs-minor-wrap-function 'cvs-commit-minor-wrap)
(run-hooks 'cvs-mode-commit-hook)))
(defun cvs-commit-minor-wrap (_buf f)
@@ -1525,15 +1525,14 @@ This is best called from a `log-view-mode' buffer."
(with-current-buffer buf
;; Set the filename before, so log-edit can correctly setup its
;; log-edit-initial-files variable.
- (set (make-local-variable 'cvs-edit-log-files) (list file)))
+ (setq-local cvs-edit-log-files (list file)))
(funcall setupfun 'cvs-do-edit-log nil
'((log-edit-listfun . cvs-edit-log-filelist)
(log-edit-diff-function . cvs-mode-diff))
buf)
(when text (erase-buffer) (insert text))
- (set (make-local-variable 'cvs-edit-log-revision) rev)
- (set (make-local-variable 'cvs-minor-wrap-function)
- 'cvs-edit-log-minor-wrap)
+ (setq-local cvs-edit-log-revision rev)
+ (setq-local cvs-minor-wrap-function 'cvs-edit-log-minor-wrap)
;; (run-hooks 'cvs-mode-commit-hook)
))
@@ -2136,11 +2135,11 @@ Returns a list of FIS that should be `cvs remove'd."
(eq (cvs-fileinfo->type fi) 'UNKNOWN))
(cvs-mode-marked filter cmd))))
(silent (or (not cvs-confirm-removals)
- (cvs-every (lambda (fi)
- (or (not (file-exists-p
- (cvs-fileinfo->full-name fi)))
- (cvs-applicable-p fi 'safe-rm)))
- files)))
+ (cl-every (lambda (fi)
+ (or (not (file-exists-p
+ (cvs-fileinfo->full-name fi)))
+ (cvs-applicable-p fi 'safe-rm)))
+ files)))
(tmpbuf (cvs-temp-buffer)))
(when (and (not silent) (equal cvs-confirm-removals 'list))
(with-current-buffer tmpbuf
@@ -2396,7 +2395,7 @@ The exact behavior is determined also by `cvs-dired-use-hook'."
(string-prefix-p default-directory dir))
(let ((subdir (substring dir (length default-directory))))
(set-buffer buffer)
- (set (make-local-variable 'cvs-buffer) cvs-buf)
+ (setq-local cvs-buffer cvs-buf)
;; `cvs -q add file' produces no useful output :-(
(when (and (equal (car flags) "add")
(goto-char (point-min))
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index 769eeaca69b..694d4529b97 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -173,8 +173,7 @@ Used in `smerge-diff-base-upper' and related functions."
`((,smerge-command-prefix . ,smerge-basic-map))
"Keymap for `smerge-mode'.")
-(defvar smerge-check-cache nil)
-(make-variable-buffer-local 'smerge-check-cache)
+(defvar-local smerge-check-cache nil)
(defun smerge-check (n)
(condition-case nil
(let ((state (cons (point) (buffer-modified-tick))))
@@ -827,7 +826,7 @@ An error is raised if not inside a conflict."
((re-search-backward smerge-base-re start t)
;; a 3-parts conflict
- (set (make-local-variable 'smerge-conflict-style) 'diff3-A)
+ (setq-local smerge-conflict-style 'diff3-A)
(setq base-end upper-end)
(setq upper-end (match-beginning 0))
(setq base-start (match-end 0)))
@@ -835,7 +834,7 @@ An error is raised if not inside a conflict."
((string= filename (file-name-nondirectory
(or buffer-file-name "")))
;; a 2-parts conflict
- (set (make-local-variable 'smerge-conflict-style) 'diff3-E))
+ (setq-local smerge-conflict-style 'diff3-E))
((and (not base-start)
(or (eq smerge-conflict-style 'diff3-A)
@@ -925,7 +924,7 @@ 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, `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.
@@ -1350,26 +1349,28 @@ buffer names."
;; Ediff is now set up, and we are in the control buffer.
;; Do a few further adjustments and take precautions for exit.
- (set (make-local-variable 'smerge-ediff-windows) config)
- (set (make-local-variable 'smerge-ediff-buf) buf)
- (set (make-local-variable 'ediff-quit-hook)
- (lambda ()
- (let ((buffer-A ediff-buffer-A)
- (buffer-B ediff-buffer-B)
- (buffer-C ediff-buffer-C)
- (buffer-Ancestor ediff-ancestor-buffer)
- (buf smerge-ediff-buf)
- (windows smerge-ediff-windows))
- (ediff-cleanup-mess)
- (with-current-buffer buf
- (erase-buffer)
- (insert-buffer-substring buffer-C)
- (kill-buffer buffer-A)
- (kill-buffer buffer-B)
- (kill-buffer buffer-C)
- (when (bufferp buffer-Ancestor) (kill-buffer buffer-Ancestor))
- (set-window-configuration windows)
- (message "Conflict resolution finished; you may save the buffer")))))
+ (setq-local smerge-ediff-windows config)
+ (setq-local smerge-ediff-buf buf)
+ (add-hook 'ediff-quit-hook
+ (lambda ()
+ (let ((buffer-A ediff-buffer-A)
+ (buffer-B ediff-buffer-B)
+ (buffer-C ediff-buffer-C)
+ (buffer-Ancestor ediff-ancestor-buffer)
+ (buf smerge-ediff-buf)
+ (windows smerge-ediff-windows))
+ (ediff-cleanup-mess)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert-buffer-substring buffer-C)
+ (kill-buffer buffer-A)
+ (kill-buffer buffer-B)
+ (kill-buffer buffer-C)
+ (when (bufferp buffer-Ancestor)
+ (kill-buffer buffer-Ancestor))
+ (set-window-configuration windows)
+ (message "Conflict resolution finished; you may save the buffer"))))
+ nil t)
(message "Please resolve conflicts now; exit ediff when done")))
(defun smerge-makeup-conflict (pt1 pt2 pt3 &optional pt4)
@@ -1409,7 +1410,7 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict."
\\{smerge-mode-map}"
:group 'smerge :lighter " SMerge"
- (when (and (boundp 'font-lock-mode) font-lock-mode)
+ (when font-lock-mode
(save-excursion
(if smerge-mode
(font-lock-add-keywords nil smerge-font-lock-keywords 'append)
@@ -1420,24 +1421,25 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict."
(font-lock-fontify-region (match-beginning 0) (match-end 0) nil)))))
(if (string-match (regexp-quote smerge-parsep-re) paragraph-separate)
(unless smerge-mode
- (set (make-local-variable 'paragraph-separate)
- (replace-match "" t t paragraph-separate)))
+ (setq-local paragraph-separate
+ (replace-match "" t t paragraph-separate)))
(when smerge-mode
- (set (make-local-variable 'paragraph-separate)
- (concat smerge-parsep-re paragraph-separate))))
+ (setq-local paragraph-separate
+ (concat smerge-parsep-re paragraph-separate))))
(unless smerge-mode
(smerge-remove-props (point-min) (point-max))))
;;;###autoload
-(defun smerge-start-session ()
+(defun smerge-start-session (&optional interactively)
"Turn on `smerge-mode' and move point to first conflict marker.
If no conflict maker is found, turn off `smerge-mode'."
- (interactive)
- (smerge-mode 1)
- (condition-case nil
- (unless (looking-at smerge-begin-re)
- (smerge-next))
- (error (smerge-auto-leave))))
+ (interactive "p")
+ (when (or (null smerge-mode) interactively)
+ (smerge-mode 1)
+ (condition-case nil
+ (unless (looking-at smerge-begin-re)
+ (smerge-next))
+ (error (smerge-auto-leave)))))
(defcustom smerge-change-buffer-confirm t
"If non-nil, request confirmation before moving to another buffer."
@@ -1448,30 +1450,31 @@ If no conflict maker is found, turn off `smerge-mode'."
First tries to go to the next conflict in the current buffer, and if not
found, uses VC to try and find the next file with conflict."
(interactive)
- (let ((buffer (current-buffer)))
- (condition-case nil
- ;; FIXME: Try again from BOB before moving to the next file.
- (smerge-next)
- (error
- (if (and (or smerge-change-buffer-confirm
- (and (buffer-modified-p) buffer-file-name))
- (not (or (eq last-command this-command)
- (eq ?\r last-command-event)))) ;Called via M-x!?
- ;; FIXME: Don't emit this message if `vc-find-conflicted-file' won't
- ;; go to another file anyway (because there are no more conflicted
- ;; files).
- (message (if (buffer-modified-p)
- "No more conflicts here. Repeat to save and go to next buffer"
- "No more conflicts here. Repeat to go to next buffer"))
- (if (and (buffer-modified-p) buffer-file-name)
- (save-buffer))
- (vc-find-conflicted-file)
- (if (eq buffer (current-buffer))
- ;; Do nothing: presumably `vc-find-conflicted-file' already
- ;; emitted a message explaining there aren't any more conflicts.
- nil
+ (condition-case nil
+ ;; FIXME: Try again from BOB before moving to the next file.
+ (smerge-next)
+ (error
+ (if (and (or smerge-change-buffer-confirm
+ (and (buffer-modified-p) buffer-file-name))
+ (not (or (eq last-command this-command)
+ (eq ?\r last-command-event)))) ;Called via M-x!?
+ ;; FIXME: Don't emit this message if `vc-find-conflicted-file' won't
+ ;; go to another file anyway (because there are no more conflicted
+ ;; files).
+ (message (if (buffer-modified-p)
+ "No more conflicts here. Repeat to save and go to next buffer"
+ "No more conflicts here. Repeat to go to next buffer"))
+ (if (and (buffer-modified-p) buffer-file-name)
+ (save-buffer))
+ (vc-find-conflicted-file)
+ ;; At this point, the caret will only be at a conflict marker
+ ;; if the file did not correspond to an opened
+ ;; buffer. Otherwise we need to jump to a marker explicitly.
+ (unless (looking-at "^<<<<<<<")
+ (let ((prev-pos (point)))
(goto-char (point-min))
- (smerge-next)))))))
+ (unless (ignore-errors (not (smerge-next)))
+ (goto-char prev-pos))))))))
(provide 'smerge-mode)
diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el
index 9434cc13dfd..07b2800c2dc 100644
--- a/lisp/vc/vc-annotate.el
+++ b/lisp/vc/vc-annotate.el
@@ -164,18 +164,18 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'."
(defvar vc-annotate-mode-map
(let ((m (make-sparse-keymap)))
- (define-key m "a" 'vc-annotate-revision-previous-to-line)
- (define-key m "d" 'vc-annotate-show-diff-revision-at-line)
- (define-key m "=" 'vc-annotate-show-diff-revision-at-line)
- (define-key m "D" 'vc-annotate-show-changeset-diff-revision-at-line)
- (define-key m "f" 'vc-annotate-find-revision-at-line)
- (define-key m "j" 'vc-annotate-revision-at-line)
- (define-key m "l" 'vc-annotate-show-log-revision-at-line)
- (define-key m "n" 'vc-annotate-next-revision)
- (define-key m "p" 'vc-annotate-prev-revision)
- (define-key m "w" 'vc-annotate-working-revision)
- (define-key m "v" 'vc-annotate-toggle-annotation-visibility)
- (define-key m "\C-m" 'vc-annotate-goto-line)
+ (define-key m "a" #'vc-annotate-revision-previous-to-line)
+ (define-key m "d" #'vc-annotate-show-diff-revision-at-line)
+ (define-key m "=" #'vc-annotate-show-diff-revision-at-line)
+ (define-key m "D" #'vc-annotate-show-changeset-diff-revision-at-line)
+ (define-key m "f" #'vc-annotate-find-revision-at-line)
+ (define-key m "j" #'vc-annotate-revision-at-line)
+ (define-key m "l" #'vc-annotate-show-log-revision-at-line)
+ (define-key m "n" #'vc-annotate-next-revision)
+ (define-key m "p" #'vc-annotate-prev-revision)
+ (define-key m "w" #'vc-annotate-working-revision)
+ (define-key m "v" #'vc-annotate-toggle-annotation-visibility)
+ (define-key m "\C-m" #'vc-annotate-goto-line)
m)
"Local keymap used for VC-Annotate mode.")
@@ -208,9 +208,8 @@ menu items."
;; it will become a list, to avoid initial annotations being invisible.
(add-to-invisibility-spec 'foo)
(remove-from-invisibility-spec 'foo)
- (set (make-local-variable 'truncate-lines) t)
- (set (make-local-variable 'font-lock-defaults)
- '(vc-annotate-font-lock-keywords t))
+ (setq-local truncate-lines t)
+ (setq-local font-lock-defaults '(vc-annotate-font-lock-keywords t))
(hack-dir-local-variables-non-file-buffer))
(defun vc-annotate-toggle-annotation-visibility ()
@@ -403,12 +402,12 @@ should be applied to the background or to the foreground."
(let ((def (vc-working-revision buffer-file-name)))
(if (null current-prefix-arg) def
(vc-read-revision
- (format "Annotate from revision (default %s): " def)
+ (format-prompt "Annotate from revision" def)
(list buffer-file-name) nil def)))
(if (null current-prefix-arg)
vc-annotate-display-mode
(float (string-to-number
- (read-string "Annotate span days (default 20): "
+ (read-string (format-prompt "Annotate span days" 20)
nil nil "20")))))))
(vc-ensure-vc-buffer)
(setq vc-annotate-display-mode display-mode) ;Not sure why. --Stef
@@ -449,11 +448,10 @@ should be applied to the background or to the foreground."
(with-current-buffer temp-buffer-name
(unless (equal major-mode 'vc-annotate-mode)
(vc-annotate-mode))
- (set (make-local-variable 'vc-annotate-backend) backend)
- (set (make-local-variable 'vc-annotate-parent-file) file)
- (set (make-local-variable 'vc-annotate-parent-rev) rev)
- (set (make-local-variable 'vc-annotate-parent-display-mode)
- display-mode))))
+ (setq-local vc-annotate-backend backend)
+ (setq-local vc-annotate-parent-file file)
+ (setq-local vc-annotate-parent-rev rev)
+ (setq-local vc-annotate-parent-display-mode display-mode))))
(with-current-buffer temp-buffer-name
(vc-run-delayed
@@ -702,10 +700,10 @@ or OFFSET if present."
RATIO is the expansion that should be applied to `vc-annotate-color-map'.
The annotations are relative to the current time, unless overridden by OFFSET."
(when (/= ratio 1.0)
- (set (make-local-variable 'vc-annotate-color-map)
+ (setq-local vc-annotate-color-map
(mapcar (lambda (elem) (cons (* (car elem) ratio) (cdr elem)))
vc-annotate-color-map)))
- (set (make-local-variable 'vc-annotate-offset) offset)
+ (setq-local vc-annotate-offset offset)
(font-lock-mode 1))
(defun vc-annotate-lines (limit)
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index a8d372710c1..de5a90dc602 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -26,7 +26,7 @@
;;; Commentary:
-;; See <URL:http://bazaar.canonical.com/> concerning bzr.
+;; See <URL:https://bazaar.canonical.com/> concerning bzr.
;; This library provides bzr support in VC.
@@ -45,9 +45,9 @@
;;; Code:
+(require 'vc-dispatcher)
(eval-when-compile
(require 'cl-lib)
- (require 'vc-dispatcher)
(require 'vc-dir)) ; vc-dir-at-event
(declare-function vc-deduce-fileset "vc"
@@ -66,7 +66,6 @@
(defcustom vc-bzr-program "bzr"
"Name of the bzr command (excluding any arguments)."
- :group 'vc-bzr
:type 'string)
(defcustom vc-bzr-diff-switches nil
@@ -75,8 +74,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:type '(choice (const :tag "Unspecified" nil)
(const :tag "None" t)
(string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-bzr)
+ (repeat :tag "Argument List" :value ("") string)))
(defcustom vc-bzr-annotate-switches nil
"String or list of strings specifying switches for bzr annotate under VC.
@@ -85,15 +83,13 @@ If nil, use the value of `vc-annotate-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "25.1"
- :group 'vc-bzr)
+ :version "25.1")
(defcustom vc-bzr-log-switches nil
"String or list of strings specifying switches for bzr log under VC."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-bzr)
+ (repeat :tag "Argument List" :value ("") string)))
(defcustom vc-bzr-status-switches
(ignore-errors
@@ -108,7 +104,6 @@ The option \"--no-classify\" should be present if your bzr supports it."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :group 'vc-bzr
:version "24.1")
;; since v0.9, bzr supports removing the progress indicators
@@ -122,7 +117,7 @@ prepends `vc-bzr-status-switches' to ARGS."
`("BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
"LC_MESSAGES=C" ; Force English output
,@process-environment)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
+ (apply #'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
file-or-list bzr-command
(if (and (string-equal "status" bzr-command)
vc-bzr-status-switches)
@@ -144,7 +139,7 @@ Use the current Bzr root directory as the ROOT argument to
,@process-environment))
(root (vc-bzr-root default-directory))
(buffer (format "*vc-bzr : %s*" (expand-file-name root))))
- (apply 'vc-do-async-command buffer root
+ (apply #'vc-do-async-command buffer root
vc-bzr-program bzr-command args)
buffer))
@@ -267,7 +262,8 @@ in the repository root directory of FILE."
;; 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)
+ (eq (char-after (match-beginning 4)) ?a))
+ 'added)
((or (and (eql (string-to-number (match-string 3))
(file-attribute-size (file-attributes file)))
(equal (match-string 5)
@@ -280,7 +276,7 @@ in the repository root directory of FILE."
(memq
?x
(mapcar
- 'identity
+ #'identity
(file-attribute-modes
(file-attributes file))))))
(if (eq (char-after (match-beginning 7))
@@ -374,13 +370,13 @@ If PROMPT is non-nil, prompt for the Bzr command to run."
command (cadr args)
args (cddr args)))
(require 'vc-dispatcher)
- (let ((buf (apply 'vc-bzr-async-command command args)))
+ (let ((buf (apply #'vc-bzr-async-command command args)))
(with-current-buffer buf
(vc-run-delayed
(vc-compilation-mode 'bzr)
(setq-local compile-command
(concat vc-bzr-program " " command " "
- (if args (mapconcat 'identity args " ") "")))))
+ (if args (mapconcat #'identity args " ") "")))))
(vc-set-async-update buf))))
(defun vc-bzr-pull (prompt)
@@ -424,7 +420,7 @@ default if it is available."
(vc-bzr-program (car cmd))
(command (cadr cmd))
(args (cddr cmd)))
- (let ((buf (apply 'vc-bzr-async-command command args)))
+ (let ((buf (apply #'vc-bzr-async-command command args)))
(with-current-buffer buf (vc-run-delayed (vc-compilation-mode 'bzr)))
(vc-set-async-update buf))))
@@ -512,7 +508,7 @@ in the branch repository (or whose status not be determined)."
(unless (re-search-forward "^<<<<<<< " nil t)
(vc-bzr-command "resolve" nil 0 buffer-file-name)
;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-bzr-resolve-when-done t))))
+ (remove-hook 'after-save-hook #'vc-bzr-resolve-when-done t))))
(defun vc-bzr-find-file-hook ()
(when (and buffer-file-name
@@ -529,7 +525,7 @@ in the branch repository (or whose status not be determined)."
;; but the one in `bzr pull' isn't, so it would be good to provide an
;; elisp function to remerge from the .BASE/OTHER/THIS files.
(smerge-start-session)
- (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t)
+ (add-hook 'after-save-hook #'vc-bzr-resolve-when-done nil t)
(vc-message-unresolved-conflicts buffer-file-name)))
(defun vc-bzr-version-dirstate (dir)
@@ -643,7 +639,7 @@ Returns nil if unable to find this information."
;; Could run `bzr status' in the directory and see if it succeeds, but
;; that's relatively expensive.
-(defalias 'vc-bzr-responsible-p 'vc-bzr-root
+(defalias 'vc-bzr-responsible-p #'vc-bzr-root
"Return non-nil if FILE is (potentially) controlled by bzr.
The criterion is that there is a `.bzr' directory in the same
or a superior directory.")
@@ -664,7 +660,7 @@ or a superior directory.")
(defun vc-bzr-checkin (files comment &optional _rev)
"Check FILES in to bzr with log message COMMENT."
- (apply 'vc-bzr-command "commit" nil 0 files
+ (apply #'vc-bzr-command "commit" nil 0 files
(cons "-m" (log-edit-extract-headers
`(("Author" . ,(vc-bzr--sanitize-header "--author"))
("Date" . ,(vc-bzr--sanitize-header "--commit-time"))
@@ -699,20 +695,20 @@ or a superior directory.")
(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.
+ (remove-hook 'log-view-mode-hook #'vc-bzr-log-view-mode) ;Deactivate the hack.
(require 'add-log)
- (set (make-local-variable 'log-view-per-file-logs) nil)
- (set (make-local-variable 'log-view-file-re) regexp-unmatchable)
- (set (make-local-variable 'log-view-message-re)
+ (setq-local log-view-per-file-logs nil)
+ (setq-local log-view-file-re regexp-unmatchable)
+ (setq-local log-view-message-re
(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)
+ (setq-local log-view-expanded-log-entry-function
+ 'vc-bzr-expanded-log-entry))
+ (setq-local 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.
(if (eq vc-log-view-type 'short)
@@ -745,7 +741,7 @@ If LIMIT is non-nil, show no more than this many entries."
;; the log display may not what the user wants - but I see no other
;; way of getting the above regexps working.
(with-current-buffer buffer
- (apply 'vc-bzr-command "log" buffer 'async files
+ (apply #'vc-bzr-command "log" buffer 'async files
(append
(if shortlog '("--line") '("--long"))
;; The extra complications here when start-revision and limit
@@ -761,7 +757,8 @@ If LIMIT is non-nil, show no more than this many entries."
;; This means we don't have to use --no-aliases.
;; Is -c any different to -r in this case?
"-r%s"
- "-r..%s") start-revision)))
+ "-r..%s")
+ start-revision)))
(if (eq vc-log-view-type 'with-diff) (list "-p"))
(when limit (list "-l" (format "%s" limit)))
;; There is no sensible way to combine --limit and --forward,
@@ -782,7 +779,7 @@ If LIMIT is non-nil, show no more than this many entries."
(defun vc-bzr-expanded-log-entry (revision)
(with-temp-buffer
- (apply 'vc-bzr-command "log" t nil nil
+ (apply #'vc-bzr-command "log" t nil nil
(append
(list "--long" (format "-r%s" revision))
(if (stringp vc-bzr-log-switches)
@@ -795,11 +792,11 @@ If LIMIT is non-nil, show no more than this many entries."
(buffer-substring (match-end 0) (point-max)))))
(defun vc-bzr-log-incoming (buffer remote-location)
- (apply 'vc-bzr-command "missing" buffer 'async nil
+ (apply #'vc-bzr-command "missing" buffer 'async nil
(list "--theirs-only" (unless (string= remote-location "") remote-location))))
(defun vc-bzr-log-outgoing (buffer remote-location)
- (apply 'vc-bzr-command "missing" buffer 'async nil
+ (apply #'vc-bzr-command "missing" buffer 'async nil
(list "--mine-only" (unless (string= remote-location "") remote-location))))
(defun vc-bzr-show-log-entry (revision)
@@ -830,7 +827,7 @@ If LIMIT is non-nil, show no more than this many entries."
(append
;; Only add --diff-options if there are any diff switches.
(unless (zerop (length switches))
- (list "--diff-options" (mapconcat 'identity 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)
@@ -860,9 +857,8 @@ If LIMIT is non-nil, show no more than this many entries."
(vc-bzr-command "mv" nil 0 new old)
(message "Renamed %s => %s" old new))
-(defvar vc-bzr-annotation-table nil
+(defvar-local vc-bzr-annotation-table nil
"Internal use.")
-(make-variable-buffer-local 'vc-bzr-annotation-table)
(defun vc-bzr-annotate-command (file buffer &optional revision)
"Prepare BUFFER for `vc-annotate' on FILE.
@@ -996,7 +992,7 @@ stream. Standard error output is discarded."
(defun vc-bzr-dir-status-files (dir files update-function)
"Return a list of conses (file . state) for DIR."
- (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
+ (apply #'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
(vc-run-delayed
(vc-bzr-after-dir-status update-function
;; "bzr status" results are relative to
@@ -1011,15 +1007,15 @@ stream. Standard error output is discarded."
(defvar vc-bzr-shelve-map
(let ((map (make-sparse-keymap)))
;; Turn off vc-dir marking
- (define-key map [mouse-2] 'ignore)
-
- (define-key map [down-mouse-3] 'vc-bzr-shelve-menu)
- (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point)
- (define-key map "=" 'vc-bzr-shelve-show-at-point)
- (define-key map "\C-m" 'vc-bzr-shelve-show-at-point)
- (define-key map "A" 'vc-bzr-shelve-apply-and-keep-at-point)
- (define-key map "P" 'vc-bzr-shelve-apply-at-point)
- (define-key map "S" 'vc-bzr-shelve-snapshot)
+ (define-key map [mouse-2] #'ignore)
+
+ (define-key map [down-mouse-3] #'vc-bzr-shelve-menu)
+ (define-key map "\C-k" #'vc-bzr-shelve-delete-at-point)
+ (define-key map "=" #'vc-bzr-shelve-show-at-point)
+ (define-key map "\C-m" #'vc-bzr-shelve-show-at-point)
+ (define-key map "A" #'vc-bzr-shelve-apply-and-keep-at-point)
+ (define-key map "P" #'vc-bzr-shelve-apply-at-point)
+ (define-key map "S" #'vc-bzr-shelve-snapshot)
map))
(defvar vc-bzr-shelve-menu-map
@@ -1077,49 +1073,49 @@ stream. Standard error output is discarded."
(when (string-match ".+checkout of branch: \\(.+\\)$" str)
(match-string 1 str)))))
(concat
- (propertize "Parent branch : " 'face 'font-lock-type-face)
+ (propertize "Parent branch : " 'face 'vc-dir-header)
(propertize
(if (string-match "parent branch: \\(.+\\)$" str)
(match-string 1 str)
"None")
- 'face 'font-lock-variable-name-face)
+ 'face 'vc-dir-header-value)
"\n"
(when light-checkout
(concat
- (propertize "Light checkout root: " 'face 'font-lock-type-face)
- (propertize light-checkout 'face 'font-lock-variable-name-face)
+ (propertize "Light checkout root: " 'face 'vc-dir-header)
+ (propertize light-checkout 'face 'vc-dir-header-value)
"\n"))
(when light-checkout-branch
(concat
- (propertize "Checkout of branch : " 'face 'font-lock-type-face)
- (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
+ (propertize "Checkout of branch : " 'face 'vc-dir-header)
+ (propertize light-checkout-branch 'face 'vc-dir-header-value)
"\n"))
(when pending-merge
(concat
- (propertize "Warning : " 'face 'font-lock-warning-face
+ (propertize "Warning : " 'face 'vc-dir-status-warning
'help-echo pending-merge-help-echo)
(propertize "Pending merges, commit recommended before any other action"
'help-echo pending-merge-help-echo
- 'face 'font-lock-warning-face)
+ 'face 'vc-dir-status-warning)
"\n"))
(if shelve
(concat
- (propertize "Shelves :\n" 'face 'font-lock-type-face
+ (propertize "Shelves :\n" 'face 'vc-dir-header
'help-echo shelve-help-echo)
(mapconcat
(lambda (x)
(propertize x
- 'face 'font-lock-variable-name-face
+ 'face 'vc-dir-header-value
'mouse-face 'highlight
'help-echo "mouse-3: Show shelve menu\nA: Apply and keep shelf\nP: Apply and remove shelf (pop)\nS: Snapshot to a shelf\nC-k: Delete shelf"
'keymap vc-bzr-shelve-map))
shelve "\n"))
(concat
- (propertize "Shelves : " 'face 'font-lock-type-face
+ (propertize "Shelves : " 'face 'vc-dir-header
'help-echo shelve-help-echo)
(propertize "No shelved changes"
'help-echo shelve-help-echo
- 'face 'font-lock-variable-name-face))))))
+ 'face 'vc-dir-header-value))))))
;; Follows vc-bzr-command, which uses vc-do-command from vc-dispatcher.
(declare-function vc-resynch-buffer "vc-dispatcher"
@@ -1212,7 +1208,7 @@ stream. Standard error output is discarded."
(let ((vc-bzr-revisions '())
(default-directory (file-name-directory (car files))))
(with-temp-buffer
- (apply 'vc-bzr-command "log" t 0 files
+ (apply #'vc-bzr-command "log" t 0 files
(append '("--line")
(if (stringp vc-bzr-log-switches)
(list vc-bzr-log-switches)
@@ -1316,6 +1312,15 @@ stream. Standard error output is discarded."
vc-bzr-revision-keywords))
string pred)))))
+(defun vc-bzr-repository-url (file-or-dir &optional _remote-name)
+ (let ((default-directory (vc-bzr-root file-or-dir)))
+ (with-temp-buffer
+ (vc-bzr-command "info" (current-buffer) 0 nil)
+ (goto-char (point-min))
+ (if (re-search-forward "parent branch: \\(.*\\)$" nil t)
+ (match-string 1)
+ (error "Cannot determine Bzr repository URL")))))
+
(provide 'vc-bzr)
;;; vc-bzr.el ends here
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index 5b749474220..ef607133e86 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -76,8 +76,7 @@
(repeat :tag "Argument List"
:value ("")
string))
- :version "22.1"
- :group 'vc-cvs)
+ :version "22.1")
(defcustom vc-cvs-register-switches nil
"Switches for registering a file into CVS.
@@ -88,8 +87,7 @@ If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-cvs)
+ :version "21.1")
(defcustom vc-cvs-diff-switches nil
"String or list of strings specifying switches for CVS diff under VC.
@@ -98,8 +96,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-cvs)
+ :version "21.1")
(defcustom vc-cvs-annotate-switches nil
"String or list of strings specifying switches for cvs annotate under VC.
@@ -109,22 +106,19 @@ switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "25.1"
- :group 'vc-cvs)
+ :version "25.1")
(defcustom vc-cvs-header '("$Id\ $")
"Header keywords to be inserted by `vc-insert-headers'."
:version "24.1" ; no longer consult the obsolete vc-header-alist
- :type '(repeat string)
- :group 'vc-cvs)
+ :type '(repeat string))
(defcustom vc-cvs-use-edit t
"Non-nil means to use `cvs edit' to \"check out\" a file.
This is only meaningful if you don't use the implicit checkout model
\(i.e. if you have $CVSREAD set)."
:type 'boolean
- :version "21.1"
- :group 'vc-cvs)
+ :version "21.1")
(defcustom vc-cvs-stay-local 'only-file
"Non-nil means use local operations when possible for remote repositories.
@@ -151,16 +145,14 @@ except for hosts matched by these regular expressions."
(regexp :format " stay local,\n%t: %v"
:tag "if it matches")
(repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
- :version "23.1"
- :group 'vc-cvs)
+ :version "23.1")
(defcustom vc-cvs-sticky-date-format-string "%c"
"Format string for mode-line display of sticky date.
Format is according to `format-time-string'. Only used if
`vc-cvs-sticky-tag-display' is t."
:type '(string)
- :version "22.1"
- :group 'vc-cvs)
+ :version "22.1")
(defcustom vc-cvs-sticky-tag-display t
"Specify the mode-line display of sticky tags.
@@ -198,8 +190,7 @@ displayed. Date and time is displayed for sticky dates.
See also variable `vc-cvs-sticky-date-format-string'."
:type '(choice boolean function)
- :version "22.1"
- :group 'vc-cvs)
+ :version "22.1")
;;;
;;; Internal variables
@@ -310,7 +301,7 @@ to the CVS command."
(vc-cvs-could-register file)
(push (directory-file-name (file-name-directory file)) dirs)))
(if dirs (vc-cvs-register dirs)))
- (apply 'vc-cvs-command nil 0 files
+ (apply #'vc-cvs-command nil 0 files
"add"
(and comment (string-match "[^\t\n ]" comment)
(concat "-m" comment))
@@ -337,32 +328,35 @@ its parents."
(directory-file-name dir))))
(eq dir t)))
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
(defun vc-cvs-checkin (files comment &optional rev)
"CVS-specific version of `vc-backend-checkin'."
- (unless (or (not rev) (vc-cvs-valid-revision-number-p rev))
- (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
+ (unless (or (not rev) (vc-cvs-valid-revision-number-p rev))
+ (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
(error "%s is not a valid symbolic tag name" rev)
- ;; If the input revision is a valid symbolic tag name, we create it
- ;; as a branch, commit and switch to it.
- (apply 'vc-cvs-command nil 0 files "tag" "-b" (list rev))
- (apply 'vc-cvs-command nil 0 files "update" "-r" (list rev))
- (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev))
+ ;; If the input revision is a valid symbolic tag name, we create it
+ ;; as a branch, commit and switch to it.
+ (apply #'vc-cvs-command nil 0 files "tag" "-b" (list rev))
+ (apply #'vc-cvs-command nil 0 files "update" "-r" (list rev))
+ (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev))
files)))
- (let ((status (apply 'vc-cvs-command nil 1 files
- "ci" (if rev (concat "-r" rev))
- (concat "-m" comment)
- (vc-switches 'CVS 'checkin))))
+ (let ((status (apply
+ #'vc-cvs-command nil 1 files
+ "ci" (if rev (concat "-r" rev))
+ (concat "-m" (car (log-edit-extract-headers nil comment)))
+ (vc-switches 'CVS 'checkin))))
(set-buffer "*vc*")
(goto-char (point-min))
(when (not (zerop status))
;; Check checkin problem.
(cond
((re-search-forward "Up-to-date check failed" nil t)
- (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
+ (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
files)
(error "%s" (substitute-command-keys
- (concat "Up-to-date check failed: "
- "type \\[vc-next-action] to merge in changes"))))
+ (concat "Up-to-date check failed: "
+ "type \\[vc-next-action] to merge in changes"))))
(t
(pop-to-buffer (current-buffer))
(goto-char (point-min))
@@ -372,10 +366,10 @@ its parents."
;; Otherwise we can't necessarily tell what goes with what; clear
;; its properties so they have to be refetched.
(if (= (length files) 1)
- (vc-file-setprop
+ (vc-file-setprop
(car files) 'vc-working-revision
(vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
- (mapc 'vc-file-clearprops files))
+ (mapc #'vc-file-clearprops files))
;; Anyway, forget the checkout model of the file, because we might have
;; guessed wrong when we found the file. After commit, we can
;; tell it from the permissions of the file (see
@@ -385,10 +379,10 @@ its parents."
;; if this was an explicit check-in (does not include creation of
;; a branch), remove the sticky tag.
(if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev)))
- (vc-cvs-command nil 0 files "update" "-A"))))
+ (vc-cvs-command nil 0 files "update" "-A"))))
(defun vc-cvs-find-revision (file rev buffer)
- (apply 'vc-cvs-command
+ (apply #'vc-cvs-command
buffer 0 file
"-Q" ; suppress diagnostic output
"update"
@@ -413,7 +407,7 @@ REV is the revision to check out."
(if (equal file buffer-file-name) (read-only-mode -1))))
;; Check out a particular revision (or recreate the file).
(vc-file-setprop file 'vc-working-revision nil)
- (apply 'vc-cvs-command nil 0 file
+ (apply #'vc-cvs-command nil 0 file
"-w"
"update"
(when rev
@@ -597,7 +591,7 @@ Remaining arguments are ignored."
;; This used to append diff-switches and vc-diff-switches,
;; which was consistent with the vc-diff-switches doc at that
;; time, but not with the actual behavior of any other VC diff.
- (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil
+ (apply #'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil
;; Not a CVS diff, does not use vc-cvs-diff-switches.
(append (vc-switches nil 'diff)
(list (file-relative-name file-oldvers)
@@ -605,7 +599,7 @@ Remaining arguments are ignored."
(setq status 0))
(push file invoke-cvs-diff-list)))))
(when invoke-cvs-diff-list
- (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*")
+ (setq status (apply #'vc-cvs-command (or buffer "*vc-diff*")
(if async 'async 1)
invoke-cvs-diff-list "diff"
(and oldvers (concat "-r" oldvers))
@@ -784,7 +778,7 @@ If UPDATE is non-nil, then update (resynch) any affected buffers."
"A wrapper around `vc-do-command' for use in vc-cvs.el.
The difference to vc-do-command is that this function always invokes `cvs',
and that it passes `vc-cvs-global-switches' to it before FLAGS."
- (apply 'vc-do-command (or buffer "*vc*") okstatus "cvs" files
+ (apply #'vc-do-command (or buffer "*vc*") okstatus "cvs" files
(if (stringp vc-cvs-global-switches)
(cons vc-cvs-global-switches flags)
(append vc-cvs-global-switches
@@ -813,7 +807,7 @@ individually should stay local."
(setq default nil stay-local (cdr stay-local)))
(when (consp stay-local)
(setq stay-local
- (mapconcat 'identity stay-local "\\|")))
+ (mapconcat #'identity stay-local "\\|")))
(if (if (string-match stay-local hostname)
default (not default))
'yes 'no))))))))))))
@@ -1044,29 +1038,29 @@ Query all files in DIR if files is nil."
(file-error nil))))
(concat
(cond (repo
- (concat (propertize "Repository : " 'face 'font-lock-type-face)
- (propertize repo 'face 'font-lock-variable-name-face)))
+ (concat (propertize "Repository : " 'face 'vc-dir-header)
+ (propertize repo 'face 'vc-dir-header-value)))
(t ""))
(cond (module
- (concat (propertize "Module : " 'face 'font-lock-type-face)
- (propertize module 'face 'font-lock-variable-name-face)))
+ (concat (propertize "Module : " 'face 'vc-dir-header)
+ (propertize module 'face 'vc-dir-header-value)))
(t ""))
(if (file-readable-p "CVS/Tag")
(let ((tag (vc-cvs-file-to-string "CVS/Tag")))
(cond
((string-match "\\`T" tag)
- (concat (propertize "Tag : " 'face 'font-lock-type-face)
+ (concat (propertize "Tag : " 'face 'vc-dir-header)
(propertize (substring tag 1)
- 'face 'font-lock-variable-name-face)))
+ 'face 'vc-dir-header-value)))
((string-match "\\`D" tag)
- (concat (propertize "Date : " 'face 'font-lock-type-face)
+ (concat (propertize "Date : " 'face 'vc-dir-header)
(propertize (substring tag 1)
- 'face 'font-lock-variable-name-face)))
+ 'face 'vc-dir-header-value)))
(t ""))))
;; In CVS, branch is a per-file property, not a per-directory property.
;; We can't really do this here without making dangerous assumptions.
- ;;(propertize "Branch: " 'face 'font-lock-type-face)
+ ;;(propertize "Branch: " 'face 'vc-dir-header)
;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
;; 'face 'font-lock-warning-face)
)))
diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el
index 88f46eff059..5fd8d8e5036 100644
--- a/lisp/vc/vc-dav.el
+++ b/lisp/vc/vc-dav.el
@@ -1,4 +1,4 @@
-;;; vc-dav.el --- vc.el support for WebDAV
+;;; vc-dav.el --- vc.el support for WebDAV -*- lexical-binding: t; -*-
;; Copyright (C) 2001, 2004-2021 Free Software Foundation, Inc.
@@ -64,7 +64,7 @@ For a list of possible values, see `vc-state'."
'edited
(cdr (car locks)))))))
-(defun vc-dav-checkout-model (url)
+(defun vc-dav-checkout-model (_url)
"Indicate whether URL needs to be \"checked out\" before it can be edited.
See `vc-checkout-model' for a list of possible values."
;; The only thing we can support with webdav is 'locking
@@ -72,21 +72,21 @@ See `vc-checkout-model' for a list of possible values."
;; This should figure out the version # of the file somehow. What is
;; the most appropriate property in WebDAV to look at for this?
-(defun vc-dav-workfile-version (url)
+(defun vc-dav-workfile-version (_url)
"Return the current workfile version of URL."
"Unknown")
-(defun vc-dav-register (url &optional _comment)
+(defun vc-dav-register (_url &optional _comment)
"Register URL in the DAV backend."
;; Do we need to do anything here? FIXME?
)
-(defun vc-dav-checkin (url comment &optional _rev)
+(defun vc-dav-checkin (_url _comment &optional _rev)
"Commit changes in URL to WebDAV. COMMENT is used as a check-in comment."
;; This should PUT the resource and release any locks that we hold.
)
-(defun vc-dav-checkout (url &optional rev destfile)
+(defun vc-dav-checkout (_url &optional _rev _destfile)
"Check out revision REV of URL into the working area.
If EDITABLE is non-nil URL should be writable by the user and if
@@ -101,7 +101,7 @@ write the contents to.
;; This should LOCK the resource.
)
-(defun vc-dav-revert (url &optional contents-done)
+(defun vc-dav-revert (_url &optional _contents-done)
"Revert URL back to the current workfile version.
If optional arg CONTENTS-DONE is non-nil, then the contents of FILE
@@ -112,11 +112,11 @@ only needs to update the status of URL within the backend.
;; Should UNLOCK the file.
)
-(defun vc-dav-print-log (url)
+(defun vc-dav-print-log (_url)
"Insert the revision log of URL into the *vc* buffer."
)
-(defun vc-dav-diff (url &optional rev1 rev2 buffer async)
+(defun vc-dav-diff (_url &optional _rev1 _rev2 _buffer _async)
"Insert the diff for URL into the *vc-diff* buffer.
If REV1 and REV2 are non-nil report differences from REV1 to REV2.
If REV1 is nil, use the current workfile version as the older version.
@@ -135,11 +135,11 @@ It should return a status of either 0 (no differences found), or
;; This should use url-dav-get-properties with a depth of `1' to get
;; all the properties.
-(defun vc-dav-dir-state (url)
+(defun vc-dav-dir-state (_url)
"find the version control state of all files in DIR in a fast way."
)
-(defun vc-dav-responsible-p (url)
+(defun vc-dav-responsible-p (_url)
"Return non-nil if DAV considers itself `responsible' for URL."
;; Check for DAV support on the web server.
t)
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 99f4b7a603f..eb8cf8192c1 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -54,6 +54,51 @@ See `run-hooks'."
:type 'hook
:group 'vc)
+(defface vc-dir-header '((t :inherit font-lock-type-face))
+ "Face for headers in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-header-value '((t :inherit font-lock-variable-name-face))
+ "Face for header values in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-directory '((t :inherit font-lock-comment-delimiter-face))
+ "Face for directories in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-file '((t :inherit font-lock-function-name-face))
+ "Face for files in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-mark-indicator '((t :inherit font-lock-type-face))
+ "Face for mark indicators in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-status-warning '((t :inherit font-lock-warning-face))
+ "Face for warning status in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-status-edited '((t :inherit font-lock-variable-name-face))
+ "Face for edited status in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-status-up-to-date '((t :inherit font-lock-builtin-face))
+ "Face for up-to-date status in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
+(defface vc-dir-status-ignored '((t :inherit shadow))
+ "Face for ignored or empty values in VC-dir buffers."
+ :group 'vc
+ :version "28.1")
+
;; Used to store information for the files displayed in the directory buffer.
;; Each item displayed corresponds to one of these defstructs.
(cl-defstruct (vc-dir-fileinfo
@@ -147,6 +192,12 @@ See `run-hooks'."
'(menu-item "Unmark Previous " vc-dir-unmark-file-up
:help "Move to the previous line and unmark the file"))
+ (define-key map [mark-unregistered]
+ '(menu-item "Mark Unregistered" vc-dir-mark-unregistered-files
+ :help "Mark all files in the unregistered state"))
+ (define-key map [mark-registered]
+ '(menu-item "Mark Registered" vc-dir-mark-registered-files
+ :help "Mark all files in the state edited, added or removed"))
(define-key map [mark-all]
'(menu-item "Mark All" vc-dir-mark-all-files
:help "Mark all files that are in the same state as the current file\
@@ -251,64 +302,67 @@ See `run-hooks'."
(defvar vc-dir-mode-map
(let ((map (make-sparse-keymap)))
;; VC commands
- (define-key map "v" 'vc-next-action) ;; C-x v v
- (define-key map "=" 'vc-diff) ;; C-x v =
- (define-key map "D" 'vc-root-diff) ;; C-x v D
- (define-key map "i" 'vc-register) ;; C-x v i
- (define-key map "+" 'vc-update) ;; C-x v +
+ (define-key map "v" #'vc-next-action) ;; C-x v v
+ (define-key map "=" #'vc-diff) ;; C-x v =
+ (define-key map "D" #'vc-root-diff) ;; C-x v D
+ (define-key map "i" #'vc-register) ;; C-x v i
+ (define-key map "+" #'vc-update) ;; C-x v +
;; I'd prefer some kind of symmetry with vc-update:
- (define-key map "P" 'vc-push) ;; C-x v P
- (define-key map "l" 'vc-print-log) ;; C-x v l
- (define-key map "L" 'vc-print-root-log) ;; C-x v L
- (define-key map "I" 'vc-log-incoming) ;; C-x v I
- (define-key map "O" 'vc-log-outgoing) ;; C-x v O
+ (define-key map "P" #'vc-push) ;; C-x v P
+ (define-key map "l" #'vc-print-log) ;; C-x v l
+ (define-key map "L" #'vc-print-root-log) ;; C-x v L
+ (define-key map "I" #'vc-log-incoming) ;; C-x v I
+ (define-key map "O" #'vc-log-outgoing) ;; C-x v O
;; More confusing than helpful, probably
- ;;(define-key map "R" 'vc-revert) ;; u is taken by vc-dir-unmark.
- ;;(define-key map "A" 'vc-annotate) ;; g is taken by revert-buffer
+ ;;(define-key map "R" #'vc-revert) ;; u is taken by vc-dir-unmark.
+ ;;(define-key map "A" #'vc-annotate) ;; g is taken by revert-buffer
;; bound by `special-mode'.
;; Marking.
- (define-key map "m" 'vc-dir-mark)
- (define-key map "d" 'vc-dir-clean-files)
- (define-key map "M" 'vc-dir-mark-all-files)
- (define-key map "u" 'vc-dir-unmark)
- (define-key map "U" 'vc-dir-unmark-all-files)
- (define-key map "\C-?" 'vc-dir-unmark-file-up)
- (define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
+ (define-key map "m" #'vc-dir-mark)
+ (define-key map "d" #'vc-dir-clean-files)
+ (define-key map "M" #'vc-dir-mark-all-files)
+ (define-key map "u" #'vc-dir-unmark)
+ (define-key map "U" #'vc-dir-unmark-all-files)
+ (define-key map "\C-?" #'vc-dir-unmark-file-up)
+ (define-key map "\M-\C-?" #'vc-dir-unmark-all-files)
;; Movement.
- (define-key map "n" 'vc-dir-next-line)
- (define-key map " " 'vc-dir-next-line)
- (define-key map "\t" 'vc-dir-next-directory)
- (define-key map "p" 'vc-dir-previous-line)
- (define-key map [?\S-\ ] 'vc-dir-previous-line)
- (define-key map [backtab] 'vc-dir-previous-directory)
+ (define-key map "n" #'vc-dir-next-line)
+ (define-key map " " #'vc-dir-next-line)
+ (define-key map "\t" #'vc-dir-next-directory)
+ (define-key map "p" #'vc-dir-previous-line)
+ (define-key map [?\S-\ ] #'vc-dir-previous-line)
+ (define-key map [backtab] #'vc-dir-previous-directory)
;;; Rebind paragraph-movement commands.
- (define-key map "\M-}" 'vc-dir-next-directory)
- (define-key map "\M-{" 'vc-dir-previous-directory)
- (define-key map [C-down] 'vc-dir-next-directory)
- (define-key map [C-up] 'vc-dir-previous-directory)
+ (define-key map "\M-}" #'vc-dir-next-directory)
+ (define-key map "\M-{" #'vc-dir-previous-directory)
+ (define-key map [C-down] #'vc-dir-next-directory)
+ (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-o" 'vc-dir-display-file)
- (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
- (define-key map [down-mouse-3] 'vc-dir-menu)
- (define-key map [mouse-2] 'vc-dir-toggle-mark)
+ (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-o" #'vc-dir-display-file)
+ (define-key map "\C-c\C-c" #'vc-dir-kill-dir-status-process)
+ (define-key map [down-mouse-3] #'vc-dir-menu)
(define-key map [follow-link] 'mouse-face)
- (define-key map "x" 'vc-dir-hide-up-to-date)
- (define-key map [?\C-k] 'vc-dir-kill-line)
- (define-key map "S" 'vc-dir-search) ;; FIXME: Maybe use A like dired?
- (define-key map "Q" 'vc-dir-query-replace-regexp)
- (define-key map (kbd "M-s a C-s") 'vc-dir-isearch)
- (define-key map (kbd "M-s a M-C-s") 'vc-dir-isearch-regexp)
- (define-key map "G" 'vc-dir-ignore)
+ (define-key map "x" #'vc-dir-hide-up-to-date)
+ (define-key map [?\C-k] #'vc-dir-kill-line)
+ (define-key map "S" #'vc-dir-search) ;; FIXME: Maybe use A like dired?
+ (define-key map "Q" #'vc-dir-query-replace-regexp)
+ (define-key map (kbd "M-s a C-s") #'vc-dir-isearch)
+ (define-key map (kbd "M-s a M-C-s") #'vc-dir-isearch-regexp)
+ (define-key map "G" #'vc-dir-ignore)
(let ((branch-map (make-sparse-keymap)))
(define-key map "B" branch-map)
- (define-key branch-map "c" 'vc-create-tag)
- (define-key branch-map "l" 'vc-print-branch-log)
- (define-key branch-map "s" 'vc-retrieve-tag))
+ (define-key branch-map "c" #'vc-create-tag)
+ (define-key branch-map "l" #'vc-print-branch-log)
+ (define-key branch-map "s" #'vc-retrieve-tag))
+
+ (let ((mark-map (make-sparse-keymap)))
+ (define-key map "*" mark-map)
+ (define-key mark-map "r" #'vc-dir-mark-registered-files))
;; Hook up the menu.
(define-key map [menu-bar vc-dir-mode]
@@ -452,7 +506,7 @@ If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
(t
(unless noinsert
(ewoc-enter-before vc-ewoc node
- (apply 'vc-dir-create-fileinfo entry)))
+ (apply #'vc-dir-create-fileinfo entry)))
(setq entries (cdr entries))
(setq entry (car entries))))))
(t
@@ -468,7 +522,7 @@ If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
vc-ewoc node (vc-dir-create-fileinfo rd nil nil nil entrydir))))
;; Now insert the node itself.
(ewoc-enter-before vc-ewoc node
- (apply 'vc-dir-create-fileinfo entry)))
+ (apply #'vc-dir-create-fileinfo entry)))
(setq entries (cdr entries) entry (car entries))))))
;; We're past the last node, all remaining entries go to the end.
(unless (or node noinsert)
@@ -484,10 +538,10 @@ If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))))
;; Now insert the node itself.
(ewoc-enter-last vc-ewoc
- (apply 'vc-dir-create-fileinfo entry))))))
+ (apply #'vc-dir-create-fileinfo entry))))))
(when to-remove
(let ((inhibit-read-only t))
- (apply 'ewoc-delete vc-ewoc (nreverse to-remove)))))))
+ (apply #'ewoc-delete vc-ewoc (nreverse to-remove)))))))
(defun vc-dir-busy ()
(and (buffer-live-p vc-dir-process-buffer)
@@ -696,6 +750,38 @@ share the same state."
(vc-dir-mark-file crt)))
(setq crt (ewoc-next vc-ewoc crt))))))))
+(defun vc-dir-mark-files (mark-files)
+ "Mark files specified by file names in the argument MARK-FILES.
+MARK-FILES should be a list of absolute filenames."
+ (ewoc-map
+ (lambda (filearg)
+ (when (member (expand-file-name (vc-dir-fileinfo->name filearg))
+ mark-files)
+ (setf (vc-dir-fileinfo->marked filearg) t)
+ t))
+ vc-ewoc))
+
+(defun vc-dir-mark-state-files (states)
+ "Mark files that are in the state specified by the list in STATES."
+ (unless (listp states)
+ (setq states (list states)))
+ (ewoc-map
+ (lambda (filearg)
+ (when (memq (vc-dir-fileinfo->state filearg) states)
+ (setf (vc-dir-fileinfo->marked filearg) t)
+ t))
+ vc-ewoc))
+
+(defun vc-dir-mark-registered-files ()
+ "Mark files that are in one of registered state: edited, added or removed."
+ (interactive)
+ (vc-dir-mark-state-files '(edited added removed)))
+
+(defun vc-dir-mark-unregistered-files ()
+ "Mark files that are in unregistered state."
+ (interactive)
+ (vc-dir-mark-state-files 'unregistered))
+
(defun vc-dir-unmark-file ()
;; Unmark the current file and move to the next line.
(let* ((crt (ewoc-locate vc-ewoc))
@@ -796,7 +882,7 @@ system; see `vc-dir-delete-file'."
The files will also be marked as deleted in the version control
system."
(interactive)
- (mapc 'vc-delete-file (or (vc-dir-marked-files)
+ (mapc #'vc-delete-file (or (vc-dir-marked-files)
(list (vc-dir-current-file)))))
(defun vc-dir-find-file ()
@@ -826,13 +912,13 @@ system."
"Search for a string through all marked buffers using Isearch."
(interactive)
(multi-isearch-files
- (mapcar 'car (vc-dir-marked-only-files-and-states))))
+ (mapcar #'car (vc-dir-marked-only-files-and-states))))
(defun vc-dir-isearch-regexp ()
"Search for a regexp through all marked buffers using Isearch."
(interactive)
(multi-isearch-files-regexp
- (mapcar 'car (vc-dir-marked-only-files-and-states))))
+ (mapcar #'car (vc-dir-marked-only-files-and-states))))
(defun vc-dir-search (regexp)
"Search through all marked files for a match for REGEXP.
@@ -857,13 +943,13 @@ with the command \\[tags-loop-continue]."
(query-replace-read-args
"Query replace regexp in marked files" t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
- (dolist (file (mapcar 'car (vc-dir-marked-only-files-and-states)))
+ (dolist (file (mapcar #'car (vc-dir-marked-only-files-and-states)))
(let ((buffer (get-file-buffer file)))
(if (and buffer (with-current-buffer buffer
buffer-read-only))
(error "File `%s' is visited read-only" file))))
(fileloop-initialize-replace
- from to (mapcar 'car (vc-dir-marked-only-files-and-states))
+ from to (mapcar #'car (vc-dir-marked-only-files-and-states))
(if (equal from (downcase from)) nil 'default)
delimited)
(fileloop-continue))
@@ -1043,7 +1129,6 @@ U - if the cursor is on a file: unmark all the files with the same state
as the current file
- if the cursor is on a directory: unmark all child files
- with a prefix argument: unmark all files
-mouse-2 - toggles the mark state
VC commands
VC commands in the `C-x v' prefix can be used.
@@ -1061,23 +1146,22 @@ commands act on the child files of that directory that are displayed in
the *vc-dir* buffer.
\\{vc-dir-mode-map}"
- (set (make-local-variable 'vc-dir-backend) use-vc-backend)
- (set (make-local-variable 'desktop-save-buffer)
- 'vc-dir-desktop-buffer-misc-data)
+ (setq-local vc-dir-backend use-vc-backend)
+ (setq-local desktop-save-buffer 'vc-dir-desktop-buffer-misc-data)
+ (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record)
(setq buffer-read-only t)
(when (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
+ (setq-local tool-bar-map vc-dir-tool-bar-map))
(let ((buffer-read-only nil))
(erase-buffer)
- (set (make-local-variable 'vc-dir-process-buffer) nil)
- (set (make-local-variable 'vc-ewoc) (ewoc-create #'vc-dir-printer))
- (set (make-local-variable 'revert-buffer-function)
- 'vc-dir-revert-buffer-function)
+ (setq-local vc-dir-process-buffer nil)
+ (setq-local vc-ewoc (ewoc-create #'vc-dir-printer))
+ (setq-local revert-buffer-function 'vc-dir-revert-buffer-function)
(setq list-buffers-directory (expand-file-name "*vc-dir*" default-directory))
(add-to-list 'vc-dir-buffers (current-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)
+ (add-hook 'kill-buffer-query-functions #'vc-dir-kill-query nil t)
(hack-dir-local-variables-non-file-buffer)
(vc-dir-refresh)))
@@ -1087,11 +1171,11 @@ It calls the `dir-extra-headers' backend method to display backend
specific headers."
(concat
;; First layout the common headers.
- (propertize "VC backend : " 'face 'font-lock-type-face)
- (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face)
- (propertize "Working dir: " 'face 'font-lock-type-face)
+ (propertize "VC backend : " 'face 'vc-dir-header)
+ (propertize (format "%s\n" backend) 'face 'vc-dir-header-value)
+ (propertize "Working dir: " 'face 'vc-dir-header)
(propertize (format "%s\n" (abbreviate-file-name dir))
- 'face 'font-lock-variable-name-face)
+ 'face 'vc-dir-header-value)
;; Then the backend specific ones.
(vc-call-backend backend 'dir-extra-headers dir)
"\n"))
@@ -1192,8 +1276,9 @@ Throw an error if another update process is in progress."
vc-ewoc 'vc-dir-fileinfo->needs-update)))
(if remaining
(vc-dir-refresh-files
- (mapcar 'vc-dir-fileinfo->name remaining))
- (setq mode-line-process nil))))))))))))
+ (mapcar #'vc-dir-fileinfo->name remaining))
+ (setq mode-line-process nil)
+ (run-hooks 'vc-dir-refresh-hook))))))))))))
(defun vc-dir-show-fileentry (file)
"Insert an entry for a specific file into the current *VC-dir* listing.
@@ -1245,7 +1330,7 @@ state of item at point, if any."
(ewoc-delete vc-ewoc crt))
(setq crt prev)))))
-(defalias 'vc-dir-hide-up-to-date 'vc-dir-hide-state)
+(defalias 'vc-dir-hide-up-to-date #'vc-dir-hide-state)
(defun vc-dir-kill-line ()
"Remove the current line from display."
@@ -1281,12 +1366,22 @@ state of item at point, if any."
(unless (vc-compatible-state (cdr crt) state)
(error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s"
(car crt) (cdr crt) (caar only-files-list) state)))
- (setq only-files-list (mapcar 'car only-files-list))
+ (setq only-files-list (mapcar #'car only-files-list))
(when (and state (not (eq state 'unregistered)))
(setq model (vc-checkout-model vc-dir-backend only-files-list))))
(list vc-dir-backend files only-files-list state model)))
;;;###autoload
+(defun vc-dir-root ()
+ "Run `vc-dir' in the repository root directory without prompt.
+If the default directory of the current buffer is
+not under version control, prompt for a directory."
+ (interactive)
+ (let ((root-dir (vc-root-dir)))
+ (if root-dir (vc-dir root-dir)
+ (call-interactively 'vc-dir))))
+
+;;;###autoload
(defun vc-dir (dir &optional backend)
"Show the VC status for \"interesting\" files in and below DIR.
This allows you to mark files and perform VC operations on them.
@@ -1309,7 +1404,7 @@ These are the commands available for use in the file status buffer:
;; When you hit C-x v d in a visited VC file,
;; the *vc-dir* buffer visits the directory under its truename;
;; therefore it makes sense to always do that.
- ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d
+ ;; Otherwise if you do C-x v d -> C-x C-f -> C-x v d
;; you may get a new *vc-dir* buffer, different from the original
(file-truename (read-directory-name "VC status for directory: "
(vc-root-dir) nil t
@@ -1336,13 +1431,19 @@ These are the commands available for use in the file status buffer:
;; backend specific headers.
;; XXX: change this to return nil before the release.
(concat
- (propertize "Extra : " 'face 'font-lock-type-face)
+ (propertize "Extra : " 'face 'vc-dir-header)
(propertize "Please add backend specific headers here. It's easy!"
- 'face 'font-lock-warning-face)))
+ 'face 'vc-dir-status-warning)))
+
+(defvar vc-dir-status-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] #'vc-dir-toggle-mark)
+ map)
+ "Local keymap for toggling mark.")
(defvar vc-dir-filename-mouse-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'vc-dir-find-file-other-window)
+ (define-key map [mouse-2] #'vc-dir-find-file-other-window)
map)
"Local keymap for visiting a file.")
@@ -1358,20 +1459,23 @@ These are the commands available for use in the file status buffer:
(insert
(propertize
(format "%c" (if (vc-dir-fileinfo->marked fileentry) ?* ? ))
- 'face 'font-lock-type-face)
+ 'face 'vc-dir-mark-indicator)
" "
(propertize
(format "%-20s" state)
- 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
- ((memq state '(missing conflict)) 'font-lock-warning-face)
- ((eq state 'edited) 'font-lock-constant-face)
- (t 'font-lock-variable-name-face))
- 'mouse-face 'highlight)
+ 'face (cond
+ ((eq state 'up-to-date) 'vc-dir-status-up-to-date)
+ ((memq state '(missing conflict needs-update unlocked-changes))
+ 'vc-dir-status-warning)
+ ((eq state 'ignored) 'vc-dir-status-ignored)
+ (t 'vc-dir-status-edited))
+ 'mouse-face 'highlight
+ 'keymap vc-dir-status-mouse-map)
" "
(propertize
(format "%s" filename)
'face
- (if isdir 'font-lock-comment-delimiter-face 'font-lock-function-name-face)
+ (if isdir 'vc-dir-directory 'vc-dir-file)
'help-echo
(if isdir
"Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
@@ -1413,6 +1517,42 @@ These are the commands available for use in the file status buffer:
'(vc-dir-mode . vc-dir-restore-desktop-buffer))
+;;; Support for bookmark.el (adapted from what info.el does).
+
+(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 vc-dir-bookmark-make-record ()
+ "Make record used to bookmark a `vc-dir' buffer.
+This implements the `bookmark-make-record-function' type for
+`vc-dir' buffers."
+ (let* ((bookmark-name
+ (concat "(" (symbol-name vc-dir-backend) ") "
+ (file-name-nondirectory
+ (directory-file-name default-directory))))
+ (defaults (list bookmark-name default-directory)))
+ `(,bookmark-name
+ ,@(bookmark-make-record-default 'no-file)
+ (filename . ,default-directory)
+ (handler . vc-dir-bookmark-jump)
+ (defaults . ,defaults))))
+
+;;;###autoload
+(defun vc-dir-bookmark-jump (bmk)
+ "Provides the bookmark-jump behavior for a `vc-dir' buffer.
+This implements the `handler' function interface for the record
+type returned by `vc-dir-bookmark-make-record'."
+ (let* ((file (bookmark-prop-get bmk 'filename))
+ (buf (progn ;; Don't use save-window-excursion (bug#39722)
+ (vc-dir file)
+ (current-buffer))))
+ (bookmark-default-handler
+ `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk)))))
+
+
(provide 'vc-dir)
;;; vc-dir.el ends here
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index 64b5c59a349..c29458620e9 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -1,4 +1,4 @@
-;;; vc-dispatcher.el -- generic command-dispatcher facility. -*- lexical-binding: t -*-
+;;; vc-dispatcher.el --- generic command-dispatcher facility. -*- lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -138,7 +138,9 @@ preserve the setting."
;; Variables the user doesn't need to know about.
(defvar vc-log-operation nil)
-(defvar vc-log-after-operation-hook nil)
+(defvar vc-log-after-operation-hook nil
+ "Name of the hook run at the end of `vc-finish-logentry'.
+BEWARE: Despite its name, this variable is not itself a hook!")
(defvar vc-log-fileset)
;; In a log entry buffer, this is a local variable
@@ -177,9 +179,9 @@ Another is that undo information is not kept."
;; want any of its output to appear from now on.
(when oldproc (delete-process oldproc)))
(kill-all-local-variables)
- (set (make-local-variable 'vc-parent-buffer) camefrom)
- (set (make-local-variable 'vc-parent-buffer-name)
- (concat " from " (buffer-name camefrom)))
+ (setq-local vc-parent-buffer camefrom)
+ (setq-local vc-parent-buffer-name
+ (concat " from " (buffer-name camefrom)))
(setq default-directory olddir)
(let ((buffer-undo-list t)
(inhibit-read-only t))
@@ -240,7 +242,7 @@ CODE should be a function of no arguments."
((or (null proc) (eq (process-status proc) 'exit))
;; Make sure we've read the process's output before going further.
(when proc (accept-process-output proc))
- (if (functionp code) (funcall code) (eval code)))
+ (if (functionp code) (funcall code) (eval code t)))
;; If a process is running, add CODE to the sentinel
((eq (process-status proc) 'run)
(vc-set-mode-line-busy-indicator)
@@ -252,7 +254,7 @@ CODE should be a function of no arguments."
nil)
(defmacro vc-run-delayed (&rest body)
- (declare (indent 0) (debug t))
+ (declare (indent 0) (debug (def-body)))
`(vc-exec-after (lambda () ,@body)))
(defvar vc-post-command-functions nil
@@ -265,7 +267,7 @@ and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
(defun vc-delistify (filelist)
"Smash a FILELIST into a file list string suitable for info messages."
;; FIXME what about file names with spaces?
- (if (not filelist) "." (mapconcat 'identity filelist " ")))
+ (if (not filelist) "." (mapconcat #'identity filelist " ")))
(defcustom vc-tor nil
"If non-nil, communicate with the repository site via Tor.
@@ -329,7 +331,7 @@ case, and the process object in the asynchronous case."
;; Run asynchronously.
(let ((proc
(let ((process-connection-type nil))
- (apply 'start-file-process command (current-buffer)
+ (apply #'start-file-process command (current-buffer)
command squeezed))))
(when vc-command-messages
(let ((inhibit-message (eq (selected-window) (active-minibuffer-window))))
@@ -337,7 +339,7 @@ case, and the process object in the asynchronous case."
;; Get rid of the default message insertion, in case we don't
;; set a sentinel explicitly.
(set-process-sentinel proc #'ignore)
- (set-process-filter proc 'vc-process-filter)
+ (set-process-filter proc #'vc-process-filter)
(setq status proc)
(when vc-command-messages
(vc-run-delayed
@@ -349,7 +351,7 @@ case, and the process object in the asynchronous case."
(let ((inhibit-message (eq (selected-window) (active-minibuffer-window))))
(message "Running in foreground: %s" full-command)))
(let ((buffer-undo-list t))
- (setq status (apply 'process-file command nil t nil squeezed)))
+ (setq status (apply #'process-file command nil t nil squeezed)))
(when (and (not (eq t okstatus))
(or (not (integerp status))
(and okstatus (< okstatus status))))
@@ -392,7 +394,7 @@ Display the buffer in some window, but don't select it."
(insert "\"...\n")
;; Run in the original working directory.
(let ((default-directory dir))
- (apply 'vc-do-command t 'async command nil args)))
+ (apply #'vc-do-command t 'async command nil args)))
(setq window (display-buffer buffer))
(if window
(set-window-start window new-window-start))
@@ -409,8 +411,8 @@ Display the buffer in some window, but don't select it."
(symbol-value error-regexp-alist))))
(let ((compilation-error-regexp-alist error-regexp-alist))
(compilation-mode))
- (set (make-local-variable 'compilation-error-regexp-alist)
- error-regexp-alist)))
+ (setq-local compilation-error-regexp-alist
+ error-regexp-alist)))
(declare-function vc-dir-refresh "vc-dir" ())
@@ -529,8 +531,7 @@ ARG and NO-CONFIRM are passed on to `revert-buffer'."
(revert-buffer arg no-confirm t))
(vc-restore-buffer-context context)))
-(defvar vc-mode-line-hook nil)
-(make-variable-buffer-local 'vc-mode-line-hook)
+(defvar-local vc-mode-line-hook nil)
(put 'vc-mode-line-hook 'permanent-local t)
(defvar view-old-buffer-read-only)
@@ -676,14 +677,14 @@ BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer."
(if (and comment (not initial-contents))
(set-buffer (get-buffer-create logbuf))
(pop-to-buffer (get-buffer-create logbuf)))
- (set (make-local-variable 'vc-parent-buffer) parent)
- (set (make-local-variable 'vc-parent-buffer-name)
- (concat " from " (buffer-name vc-parent-buffer)))
+ (setq-local vc-parent-buffer parent)
+ (setq-local vc-parent-buffer-name
+ (concat " from " (buffer-name vc-parent-buffer)))
(vc-log-edit files mode backend)
(make-local-variable 'vc-log-after-operation-hook)
(when after-hook
(setq vc-log-after-operation-hook after-hook))
- (set (make-local-variable 'vc-log-operation) action)
+ (setq-local vc-log-operation action)
(when comment
(erase-buffer)
(when (stringp comment) (insert comment)))
@@ -691,7 +692,6 @@ BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer."
(message "%s Type C-c C-c when done" msg)
(vc-finish-logentry (eq comment t)))))
-(declare-function vc-dir-move-to-goal-column "vc-dir" ())
;; vc-finish-logentry is typically called from a log-edit buffer (see
;; vc-start-logentry).
(defun vc-finish-logentry (&optional nocomment)
@@ -740,13 +740,12 @@ the buffer contents as a comment."
(mapc
(lambda (file) (vc-resynch-buffer file t t))
log-fileset))
- (when (vc-dispatcher-browsing)
- (vc-dir-move-to-goal-column))
(run-hooks after-hook 'vc-finish-logentry-hook)))
(defun vc-dispatcher-browsing ()
"Are we in a directory browser buffer?"
- (derived-mode-p 'vc-dir-mode))
+ (or (derived-mode-p 'vc-dir-mode)
+ (derived-mode-p 'dired-mode)))
;; These are unused.
;; (defun vc-dispatcher-in-fileset-p (fileset)
diff --git a/lisp/vc/vc-filewise.el b/lisp/vc/vc-filewise.el
index ee73aa6f938..254e47933d6 100644
--- a/lisp/vc/vc-filewise.el
+++ b/lisp/vc/vc-filewise.el
@@ -1,4 +1,4 @@
-;;; vc-filewise.el --- common functions for file-oriented back ends.
+;;; vc-filewise.el --- common functions for file-oriented back ends. -*- lexical-binding: t; -*-
;; Copyright (C) 1992-1996, 1998-2021 Free Software Foundation, Inc.
@@ -82,3 +82,5 @@ If the file is not registered, or the master name is not known, return nil."
nil)))) ; Not registered
(provide 'vc-filewise)
+
+;;; vc-filewise.el ends here
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index ab348d71e21..143087122fd 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -27,14 +27,6 @@
;; system.
;;
-;;; Installation:
-
-;; To install: put this file on the load-path and add Git to the list
-;; of supported backends in `vc-handled-backends'; the following line,
-;; placed in your init file, will accomplish this:
-;;
-;; (add-to-list 'vc-handled-backends 'Git)
-
;;; Todo:
;; - check if more functions could use vc-git-command instead
;; of start-process.
@@ -72,6 +64,7 @@
;; by git, so it's probably
;; not a good idea.
;; - merge-news (file) see `merge-file'
+;; - mark-resolved (files) OK
;; - steal-lock (file &optional revision) NOT NEEDED
;; HISTORY FUNCTIONS
;; * print-log (files buffer &optional shortlog start-revision limit) OK
@@ -100,10 +93,12 @@
;; - rename-file (old new) OK
;; - find-file-hook () OK
;; - conflicted-files OK
+;; - repository-url (file-or-dir) OK
;;; Code:
(require 'cl-lib)
+(require 'vc-dispatcher)
(eval-when-compile
(require 'subr-x) ; for string-trim-right
(require 'vc)
@@ -132,6 +127,13 @@ If nil, use the value of `vc-annotate-switches'. If t, use no switches."
(repeat :tag "Argument List" :value ("") string))
:version "25.1")
+(defcustom vc-git-log-switches nil
+ "String or list of strings specifying switches for Git log under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "28.1")
+
(defcustom vc-git-resolve-conflicts t
"When non-nil, mark conflicted file as resolved upon saving.
That is performed after all conflict markers in it have been
@@ -166,7 +168,7 @@ 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))
+ :type '(list string regexp (repeat sexp))
:version "24.1")
(defcustom vc-git-commits-coding-system 'utf-8
@@ -208,6 +210,16 @@ toggle display of the entire list."
widget))))
:version "27.1")
+(defcustom vc-git-revision-complete-only-branches nil
+ "Control whether tags are returned by revision completion for Git.
+
+When non-nil, only branches and remotes will be returned by
+`vc-git-revision-completion-table'. This is used by various VC
+commands when completing branch names. When nil, tags are also
+included in the completions."
+ :type 'boolean
+ :version "28.1")
+
;; History of Git commands.
(defvar vc-git-history nil)
@@ -239,9 +251,9 @@ toggle display of the entire list."
;; Do not use the `file-name-directory' here: git-ls-files
;; sometimes fails to return the correct status for relative
;; path specs.
- ;; See also: http://marc.info/?l=git&m=125787684318129&w=2
+ ;; See also: https://marc.info/?l=git&m=125787684318129&w=2
(name (file-relative-name file dir))
- (str (ignore-errors
+ (str (with-demoted-errors "Error: %S"
(cd dir)
(vc-git--out-ok "ls-files" "-c" "-z" "--" name)
;; If result is empty, use ls-tree to check for deleted
@@ -363,7 +375,7 @@ in the order given by `git status'."
"Return a string for `vc-mode-line' to put in the mode line for FILE."
(let* ((rev (vc-working-revision file 'Git))
(disp-rev (or (vc-git--symbolic-ref file)
- (substring rev 0 7)))
+ (and rev (substring rev 0 7))))
(def-ml (vc-default-mode-line-string 'Git file))
(help-echo (get-text-property 0 'help-echo def-ml))
(face (get-text-property 0 'face def-ml)))
@@ -450,7 +462,7 @@ or an empty string if none."
(eq 0 (logand ?\111 (logxor old-perm new-perm))))
" "
(if (eq 0 (logand ?\111 old-perm)) "+x" "-x"))
- 'face 'font-lock-type-face))
+ 'face 'vc-dir-header))
(defun vc-git-dir-printer (info)
"Pretty-printer for the vc-dir-fileinfo structure."
@@ -462,19 +474,21 @@ or an empty string if none."
(insert
" "
(propertize (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
- 'face 'font-lock-type-face)
+ 'face 'vc-dir-mark-indicator)
" "
(propertize
(format "%-12s" state)
- 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
- ((eq state 'missing) 'font-lock-warning-face)
- (t 'font-lock-variable-name-face))
- 'mouse-face 'highlight)
+ 'face (cond ((eq state 'up-to-date) 'vc-dir-status-up-to-date)
+ ((memq state '(missing conflict)) 'vc-dir-status-warning)
+ ((eq state 'ignored) 'vc-dir-status-ignored)
+ (t 'vc-dir-status-edited))
+ 'mouse-face 'highlight
+ 'keymap vc-dir-status-mouse-map)
" " (vc-git-permissions-as-string old-perm new-perm)
" "
(propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info))
- 'face (if isdir 'font-lock-comment-delimiter-face
- 'font-lock-function-name-face)
+ 'face (if isdir 'vc-dir-directory
+ 'vc-dir-file)
'help-echo
(if isdir
"Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
@@ -644,29 +658,29 @@ or an empty string if none."
(defvar vc-git-stash-shared-map
(let ((map (make-sparse-keymap)))
- (define-key map "S" 'vc-git-stash-snapshot)
- (define-key map "C" 'vc-git-stash)
+ (define-key map "S" #'vc-git-stash-snapshot)
+ (define-key map "C" #'vc-git-stash)
map))
(defvar vc-git-stash-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map vc-git-stash-shared-map)
;; Turn off vc-dir marking
- (define-key map [mouse-2] 'ignore)
-
- (define-key map [down-mouse-3] 'vc-git-stash-menu)
- (define-key map "\C-k" 'vc-git-stash-delete-at-point)
- (define-key map "=" 'vc-git-stash-show-at-point)
- (define-key map "\C-m" 'vc-git-stash-show-at-point)
- (define-key map "A" 'vc-git-stash-apply-at-point)
- (define-key map "P" 'vc-git-stash-pop-at-point)
+ (define-key map [mouse-2] #'ignore)
+
+ (define-key map [down-mouse-3] #'vc-git-stash-menu)
+ (define-key map "\C-k" #'vc-git-stash-delete-at-point)
+ (define-key map "=" #'vc-git-stash-show-at-point)
+ (define-key map "\C-m" #'vc-git-stash-show-at-point)
+ (define-key map "A" #'vc-git-stash-apply-at-point)
+ (define-key map "P" #'vc-git-stash-pop-at-point)
map))
(defvar vc-git-stash-button-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map vc-git-stash-shared-map)
- (define-key map [mouse-2] 'push-button)
- (define-key map "\C-m" 'push-button)
+ (define-key map [mouse-2] #'push-button)
+ (define-key map "\C-m" #'push-button)
map))
(defconst vc-git-stash-shared-help
@@ -733,6 +747,7 @@ or an empty string if none."
(with-current-buffer standard-output
(vc-git--out-ok "symbolic-ref" "HEAD"))))
(stash-list (vc-git-stash-list))
+ (default-directory dir)
branch remote remote-url stash-button stash-string)
(if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
@@ -745,14 +760,8 @@ or an empty string if none."
(concat "branch." branch ".remote")))))
(when (string-match "\\([^\n]+\\)" remote)
(setq remote (match-string 1 remote)))
- (when remote
- (setq remote-url
- (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "config"
- (concat "remote." remote ".url"))))))
- (when (string-match "\\([^\n]+\\)" remote-url)
- (setq remote-url (match-string 1 remote-url))))
+ (when (> (length remote) 0)
+ (setq remote-url (vc-git-repository-url dir remote))))
(setq branch "not (detached HEAD)"))
(when stash-list
(let* ((len (length stash-list))
@@ -776,7 +785,7 @@ or an empty string if none."
(mapconcat
(lambda (x)
(propertize x
- 'face 'font-lock-variable-name-face
+ 'face 'vc-dir-header-value
'mouse-face 'highlight
'vc-git-hideable all-hideable
'help-echo vc-git-stash-list-help
@@ -792,7 +801,7 @@ or an empty string if none."
(mapconcat
(lambda (x)
(propertize x
- 'face 'font-lock-variable-name-face
+ 'face 'vc-dir-header-value
'mouse-face 'highlight
'invisible t
'vc-git-hideable t
@@ -802,33 +811,32 @@ or an empty string if none."
(propertize "\n"
'invisible t
'vc-git-hideable t))))))))
- ;; FIXME: maybe use a different face when nothing is stashed.
(concat
- (propertize "Branch : " 'face 'font-lock-type-face)
+ (propertize "Branch : " 'face 'vc-dir-header)
(propertize branch
- 'face 'font-lock-variable-name-face)
- (when remote
+ 'face 'vc-dir-header-value)
+ (when remote-url
(concat
"\n"
- (propertize "Remote : " 'face 'font-lock-type-face)
+ (propertize "Remote : " 'face 'vc-dir-header)
(propertize remote-url
- 'face 'font-lock-variable-name-face)))
+ 'face 'vc-dir-header-value)))
;; For now just a heading, key bindings can be added later for various bisect actions
(when (file-exists-p (expand-file-name ".git/BISECT_START" (vc-git-root dir)))
- (propertize "\nBisect : in progress" 'face 'font-lock-warning-face))
+ (propertize "\nBisect : in progress" 'face 'vc-dir-status-warning))
(when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir)))
- (propertize "\nRebase : in progress" 'face 'font-lock-warning-face))
+ (propertize "\nRebase : in progress" 'face 'vc-dir-status-warning))
(if stash-list
+ (concat
+ (propertize "\nStash : " 'face 'vc-dir-header)
+ stash-button
+ stash-string)
(concat
- (propertize "\nStash : " 'face 'font-lock-type-face)
- stash-button
- stash-string)
- (concat
- (propertize "\nStash : " 'face 'font-lock-type-face)
+ (propertize "\nStash : " 'face 'vc-dir-header)
(propertize "Nothing stashed"
'help-echo vc-git-stash-shared-help
'keymap vc-git-stash-shared-map
- 'face 'font-lock-variable-name-face))))))
+ 'face 'vc-dir-header-value))))))
(defun vc-git-branches ()
"Return the existing branches, as a list of strings.
@@ -863,7 +871,7 @@ The car of the list is the current branch."
(when dlist
(vc-git-command nil 0 dlist "add"))))
-(defalias 'vc-git-responsible-p 'vc-git-root)
+(defalias 'vc-git-responsible-p #'vc-git-root)
(defun vc-git-unregister (file)
(vc-git-command nil 0 file "rm" "-f" "--cached" "--"))
@@ -897,9 +905,9 @@ If toggling on, also insert its message into the buffer."
(defvar vc-git-log-edit-mode-map
(let ((map (make-sparse-keymap "Git-Log-Edit")))
- (define-key map "\C-c\C-s" 'vc-git-log-edit-toggle-signoff)
- (define-key map "\C-c\C-n" 'vc-git-log-edit-toggle-no-verify)
- (define-key map "\C-c\C-e" 'vc-git-log-edit-toggle-amend)
+ (define-key map "\C-c\C-s" #'vc-git-log-edit-toggle-signoff)
+ (define-key map "\C-c\C-n" #'vc-git-log-edit-toggle-no-verify)
+ (define-key map "\C-c\C-e" #'vc-git-log-edit-toggle-amend)
map))
(define-derived-mode vc-git-log-edit-mode log-edit-mode "Log-Edit/git"
@@ -933,7 +941,7 @@ It is based on `log-edit-mode', and has Git-specific extensions.")
(lambda (value) (when (equal value "yes") (list argument)))))
;; When operating on the whole tree, better pass "-a" than ".", since "."
;; fails when we're committing a merge.
- (apply 'vc-git-command nil 0 (if only files)
+ (apply #'vc-git-command nil 0 (if only files)
(nconc (if msg-file (list "commit" "-F"
(file-local-name msg-file))
(list "commit" "-m"))
@@ -1016,13 +1024,13 @@ If PROMPT is non-nil, prompt for the Git command to run."
args (cddr args)))
(setq args (nconc args extra-args))
(require 'vc-dispatcher)
- (apply 'vc-do-async-command buffer root git-program command args)
+ (apply #'vc-do-async-command buffer root git-program command args)
(with-current-buffer buffer
(vc-run-delayed
(vc-compilation-mode 'git)
(setq-local compile-command
(concat git-program " " command " "
- (mapconcat 'identity args " ")))
+ (mapconcat #'identity args " ")))
(setq-local compilation-directory root)
;; Either set `compilation-buffer-name-function' locally to nil
;; or use `compilation-arguments' to set `name-function'.
@@ -1060,7 +1068,7 @@ This prompts for a branch to merge from."
branches
(cons "FETCH_HEAD" branches))
nil t)))
- (apply 'vc-do-async-command buffer root vc-git-program "merge"
+ (apply #'vc-do-async-command buffer root vc-git-program "merge"
(list merge-source))
(with-current-buffer buffer (vc-run-delayed (vc-compilation-mode 'git)))
(vc-set-async-update buffer)))
@@ -1081,6 +1089,13 @@ This prompts for a branch to merge from."
"DU" "AA" "UU"))
(push (expand-file-name file directory) files)))))))
+(defun vc-git-repository-url (file-or-dir &optional remote-name)
+ (let ((default-directory (vc-git-root file-or-dir)))
+ (with-temp-buffer
+ (vc-git-command (current-buffer) 0 nil "remote" "get-url"
+ (or remote-name "origin"))
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
+
;; Everywhere but here, follows vc-git-command, which uses vc-do-command
;; from vc-dispatcher.
(autoload 'vc-resynch-buffer "vc-dispatcher")
@@ -1100,7 +1115,7 @@ This prompts for a branch to merge from."
(vc-git-command nil 0 nil "reset"))
(vc-resynch-buffer buffer-file-name t t)
;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-git-resolve-when-done t))))
+ (remove-hook 'after-save-hook #'vc-git-resolve-when-done t))))
(defun vc-git-find-file-hook ()
"Activate `smerge-mode' if there is a conflict."
@@ -1111,7 +1126,7 @@ This prompts for a branch to merge from."
(re-search-forward "^<<<<<<< " nil 'noerror)))
(smerge-start-session)
(when vc-git-resolve-conflicts
- (add-hook 'after-save-hook 'vc-git-resolve-when-done nil 'local))
+ (add-hook 'after-save-hook #'vc-git-resolve-when-done nil 'local))
(vc-message-unresolved-conflicts buffer-file-name)))
;;; HISTORY FUNCTIONS
@@ -1123,6 +1138,8 @@ This prompts for a branch to merge from."
:type 'boolean
:version "26.1")
+(autoload 'vc-switches "vc")
+
(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
"Print commit log associated with FILES into specified BUFFER.
If SHORTLOG is non-nil, use a short format based on `vc-git-root-log-format'.
@@ -1139,7 +1156,7 @@ If LIMIT is a revision string, use it as an end-revision."
;; read-only.
(let ((inhibit-read-only t))
(with-current-buffer buffer
- (apply 'vc-git-command buffer
+ (apply #'vc-git-command buffer
'async files
(append
'("log" "--no-color")
@@ -1154,9 +1171,10 @@ If LIMIT is a revision string, use it as an end-revision."
(when shortlog
`("--graph" "--decorate" "--date=short"
,(format "--pretty=tformat:%s"
- (car vc-git-root-log-format))
- "--abbrev-commit"))
- (when (numberp limit)
+ (car vc-git-root-log-format))
+ "--abbrev-commit"))
+ vc-git-log-switches
+ (when (numberp limit)
(list "-n" (format "%s" limit)))
(when start-revision
(if (and limit (not (numberp limit)))
@@ -1209,11 +1227,11 @@ log entries."
(read-shell-command
"Search log with command: "
(format "%s %s" vc-git-program
- (mapconcat 'identity args " "))
+ (mapconcat #'identity args " "))
'vc-git-history)
" " t))))
(vc-setup-buffer buffer)
- (apply 'vc-git-command buffer 'async nil args)))
+ (apply #'vc-git-command buffer 'async nil args)))
(defun vc-git-mergebase (rev1 &optional rev2)
(unless rev2 (setq rev2 "HEAD"))
@@ -1228,18 +1246,18 @@ log entries."
(define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
(require 'add-log) ;; We need the faces add-log.
;; Don't have file markers, so use impossible regexp.
- (set (make-local-variable 'log-view-file-re) regexp-unmatchable)
- (set (make-local-variable 'log-view-per-file-logs) nil)
- (set (make-local-variable 'log-view-message-re)
- (if (not (memq vc-log-view-type '(long log-search with-diff)))
- (cadr vc-git-root-log-format)
- "^commit *\\([0-9a-z]+\\)"))
+ (setq-local log-view-file-re regexp-unmatchable)
+ (setq-local log-view-per-file-logs nil)
+ (setq-local log-view-message-re
+ (if (not (memq vc-log-view-type '(long log-search with-diff)))
+ (cadr vc-git-root-log-format)
+ "^commit +\\([0-9a-z]+\\)"))
;; Allow expanding short log entries.
(when (memq vc-log-view-type '(short log-outgoing log-incoming mergebase))
(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)
+ (setq-local log-view-expanded-log-entry-function
+ 'vc-git-expanded-log-entry))
+ (setq-local log-view-font-lock-keywords
(if (not (memq vc-log-view-type '(long log-search with-diff)))
(list (cons (nth 1 vc-git-root-log-format)
(nth 2 vc-git-root-log-format)))
@@ -1262,7 +1280,7 @@ log entries."
("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
(1 'change-log-acknowledgment)
(2 'change-log-acknowledgment))
- ("^Date: \\(.+\\)" (1 'change-log-date))
+ ("^\\(?:Date: \\|AuthorDate: \\)\\(.+\\)" (1 'change-log-date))
("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
@@ -1284,7 +1302,7 @@ or BRANCH^ (where \"^\" can be repeated)."
(defun vc-git-expanded-log-entry (revision)
(with-temp-buffer
- (apply 'vc-git-command t nil nil (list "log" revision "-1" "--"))
+ (apply #'vc-git-command t nil nil (list "log" revision "-1" "--"))
(goto-char (point-min))
(unless (eobp)
;; Indent the expanded log entry.
@@ -1377,8 +1395,6 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
samp coding-system-for-read t)))
(setq coding-system-for-read 'undecided)))
-(autoload 'vc-switches "vc")
-
(defun vc-git-diff (files &optional rev1 rev2 buffer _async)
"Get a difference report using Git between two revisions of FILES."
(let (process-file-side-effects
@@ -1400,7 +1416,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(vc-git-command (or buffer "*vc-diff*") 1 files
"difftool" "--exit-code" "--no-prompt" "-x"
(concat "diff "
- (mapconcat 'identity
+ (mapconcat #'identity
(vc-switches nil 'diff) " "))
rev1 rev2 "--"))))
@@ -1411,9 +1427,11 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(with-temp-buffer
(vc-git-command t nil nil "for-each-ref" "--format=%(refname)")
(goto-char (point-min))
- (while (re-search-forward "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$"
- nil t)
- (push (match-string 2) table)))
+ (let ((regexp (if vc-git-revision-complete-only-branches
+ "^refs/\\(heads\\|remotes\\)/\\(.*\\)$"
+ "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$")))
+ (while (re-search-forward regexp nil t)
+ (push (match-string 2) table))))
table))
(defun vc-git-revision-completion-table (files)
@@ -1530,6 +1548,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(defun vc-git-rename-file (old new)
(vc-git-command nil 0 (list old new) "mv" "-f" "--"))
+(defun vc-git-mark-resolved (files)
+ (vc-git-command nil 0 files "add"))
+
(defvar vc-git-extra-menu-map
(let ((map (make-sparse-keymap)))
(define-key map [git-grep]
@@ -1554,8 +1575,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(defun vc-git-extra-status-menu () vc-git-extra-menu-map)
(defun vc-git-root (file)
- (or (vc-file-getprop file 'git-root)
- (vc-file-setprop file 'git-root (vc-find-root file ".git"))))
+ (vc-find-root file ".git"))
;; grep-compute-defaults autoloads grep.
(declare-function grep-read-regexp "grep" ())
@@ -1688,12 +1708,13 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(vc-resynch-buffer (vc-git-root default-directory) t t))
(defun vc-git-stash-list ()
- (delete
- ""
- (split-string
- (replace-regexp-in-string
- "^stash@" " " (vc-git--run-command-string nil "stash" "list"))
- "\n")))
+ (when-let ((out (vc-git--run-command-string nil "stash" "list")))
+ (delete
+ ""
+ (split-string
+ (replace-regexp-in-string
+ "^stash@" " " out)
+ "\n"))))
(defun vc-git-stash-get-at-point (point)
(save-excursion
@@ -1751,12 +1772,13 @@ The difference to vc-do-command is that this function always invokes
(process-environment
(append
`("GIT_DIR"
+ "GIT_LITERAL_PATHSPECS=1"
;; Avoid repository locking during background operations
;; (bug#21559).
,@(when revert-buffer-in-progress-p
'("GIT_OPTIONAL_LOCKS=0")))
process-environment)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
+ (apply #'vc-do-command (or buffer "*vc*") okstatus vc-git-program
;; https://debbugs.gnu.org/16897
(unless (and (not (cdr-safe file-or-list))
(let ((file (or (car-safe file-or-list)
@@ -1775,9 +1797,9 @@ The difference to vc-do-command is that this function always invokes
(defun vc-git--call (buffer command &rest args)
;; 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. We enable `inhibit-nul-byte-detection', otherwise
+ ;; directories. We enable `inhibit-null-byte-detection', otherwise
;; Tramp's eol conversion might be confused.
- (let ((inhibit-nul-byte-detection t)
+ (let ((inhibit-null-byte-detection t)
(coding-system-for-read
(or coding-system-for-read vc-git-log-output-coding-system))
(coding-system-for-write
@@ -1785,15 +1807,16 @@ The difference to vc-do-command is that this function always invokes
(process-environment
(append
`("GIT_DIR"
+ "GIT_LITERAL_PATHSPECS=1"
;; Avoid repository locking during background operations
;; (bug#21559).
,@(when revert-buffer-in-progress-p
'("GIT_OPTIONAL_LOCKS=0")))
process-environment)))
- (apply 'process-file vc-git-program nil buffer nil "--no-pager" command args)))
+ (apply #'process-file vc-git-program nil buffer nil "--no-pager" command args)))
(defun vc-git--out-ok (command &rest args)
- (zerop (apply 'vc-git--call '(t nil) command args)))
+ (zerop (apply #'vc-git--call '(t nil) command args)))
(defun vc-git--run-command-string (file &rest args)
"Run a git command on FILE and return its output as string.
@@ -1801,7 +1824,7 @@ FILE can be nil."
(let* ((ok t)
(str (with-output-to-string
(with-current-buffer standard-output
- (unless (apply 'vc-git--out-ok
+ (unless (apply #'vc-git--out-ok
(if file
(append args (list (file-relative-name
file)))
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index d1c886cbc36..c9c1e91d483 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -26,12 +26,6 @@
;; This is a mercurial version control backend
-;;; Thanks:
-
-;;; Bugs:
-
-;;; Installation:
-
;;; Todo:
;; 1) Implement the rest of the vc interface. See the comment at the
@@ -97,9 +91,6 @@
;; without even using `hg' (this way even if you don't have `hg' installed,
;; Emacs is able to tell you this file is under mercurial's control).
-;;; History:
-;;
-
;;; Code:
(require 'cl-lib)
@@ -124,8 +115,7 @@
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "22.2"
- :group 'vc-hg)
+ :version "22.2")
(defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
"String or list of strings specifying switches for Hg diff under VC.
@@ -134,8 +124,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc-hg)
+ :version "23.1")
(defcustom vc-hg-annotate-switches '("-u" "--follow")
"String or list of strings specifying switches for hg annotate under VC.
@@ -145,8 +134,7 @@ switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "25.1"
- :group 'vc-hg)
+ :version "25.1")
(defcustom vc-hg-revert-switches nil
"String or list of strings specifying switches for hg revert
@@ -154,13 +142,11 @@ under VC."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "27.1"
- :group 'vc-hg)
+ :version "27.1")
(defcustom vc-hg-program "hg"
"Name of the Mercurial executable (excluding any arguments)."
- :type 'string
- :group 'vc-hg)
+ :type 'string)
(defcustom vc-hg-root-log-format
`(,(concat "{rev}:{ifeq(branch, 'default','', '{branch}')}"
@@ -182,10 +168,19 @@ 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-hg
+ :type '(list string regexp (repeat sexp))
:version "24.5")
+(defcustom vc-hg-create-bookmark t
+ "This controls whether `vc-create-tag' will create a bookmark or branch.
+If nil, named branch will be created.
+If t, bookmark will be created.
+If `ask', you will be prompted for a branch type."
+ :type '(choice (const :tag "No" nil)
+ (const :tag "Yes" t)
+ (const :tag "Ask" ask))
+ :version "28.1")
+
;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
@@ -212,8 +207,11 @@ highlighting the Log View buffer."
(defun vc-hg-registered (file)
"Return non-nil if FILE is registered with hg."
(when (vc-hg-root file) ; short cut
- (let ((state (vc-hg-state file))) ; expensive
- (and state (not (memq state '(ignored unregistered)))))))
+ (let ((state (vc-state file 'Hg))) ; expensive
+ (if (memq state '(ignored unregistered nil))
+ ;; Clear the cache for proper fallback to another backend.
+ (ignore (vc-file-setprop file 'vc-state nil))
+ t))))
(defun vc-hg-state (file)
"Hg-specific version of `vc-state'."
@@ -263,13 +261,12 @@ highlighting the Log View buffer."
((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
(t 'up-to-date))))))
-(defun vc-hg-working-revision (file)
+(defun vc-hg-working-revision (_file)
"Hg-specific version of `vc-working-revision'."
- (or (ignore-errors
- (with-output-to-string
- (vc-hg-command standard-output 0 file
- "parent" "--template" "{rev}")))
- "0"))
+ (ignore-errors
+ (with-output-to-string
+ (vc-hg-command standard-output 0 nil
+ "log" "-r" "." "--template" "{rev}"))))
(defcustom vc-hg-symbolic-revision-styles
'(builtin-active-bookmark
@@ -299,8 +296,7 @@ If no list entry produces a useful revision, return `nil'."
(const :tag "Active bookmark" builtin-active-bookmark)
(string :tag "Hg template")
(function :tag "Custom")))
- :version "26.1"
- :group 'vc-hg)
+ :version "26.1")
(defcustom vc-hg-use-file-version-for-mode-line-version nil
"When enabled, the modeline contains revision information for the visited file.
@@ -308,8 +304,7 @@ When not, the revision in the modeline is for the repository
working copy. `nil' is the much faster setting for
large repositories."
:type 'boolean
- :version "26.1"
- :group 'vc-hg)
+ :version "26.1")
(defun vc-hg--active-bookmark-internal (rev)
(when (equal rev ".")
@@ -401,8 +396,7 @@ specific file to query."
"String or list of strings specifying switches for hg log under VC."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-hg)
+ (repeat :tag "Argument List" :value ("") string)))
(autoload 'vc-setup-buffer "vc-dispatcher")
@@ -430,7 +424,7 @@ If LIMIT is non-nil, show no more than this many entries."
(let ((inhibit-read-only t))
(with-current-buffer
buffer
- (apply 'vc-hg-command buffer 'async files "log"
+ (apply #'vc-hg-command buffer 'async files "log"
(nconc
(when start-revision (list (format "-r%s:0" start-revision)))
(when limit (list "-l" (format "%s" limit)))
@@ -451,19 +445,19 @@ If LIMIT is non-nil, show no more than this many entries."
(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
(require 'add-log) ;; we need the add-log faces
- (set (make-local-variable 'log-view-file-re) regexp-unmatchable)
- (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)
- (cadr vc-hg-root-log-format)
- "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
- (set (make-local-variable 'tab-width) 2)
+ (setq-local log-view-file-re regexp-unmatchable)
+ (setq-local log-view-per-file-logs nil)
+ (setq-local log-view-message-re
+ (if (eq vc-log-view-type 'short)
+ (cadr vc-hg-root-log-format)
+ "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ (setq-local tab-width 2)
;; 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)
+ (setq-local log-view-expanded-log-entry-function
+ 'vc-hg-expanded-log-entry))
+ (setq-local log-view-font-lock-keywords
(if (eq vc-log-view-type 'short)
(list (cons (nth 1 vc-hg-root-log-format)
(nth 2 vc-hg-root-log-format)))
@@ -625,10 +619,18 @@ Optional arg REVISION is a revision to annotate from."
;;; Tag system
(defun vc-hg-create-tag (dir name branchp)
- "Attach the tag NAME to the state of the working copy."
+ "Create tag NAME in repo in DIR. Create branch if BRANCHP.
+Variable `vc-hg-create-bookmark' controls what kind of branch will be created."
(let ((default-directory dir))
- (and (vc-hg-command nil 0 nil "status")
- (vc-hg-command nil 0 nil (if branchp "bookmark" "tag") name))))
+ (vc-hg-command nil 0 nil
+ (if branchp
+ (if (if (eq vc-hg-create-bookmark 'ask)
+ (yes-or-no-p "Create bookmark instead of branch? ")
+ vc-hg-create-bookmark)
+ "bookmark"
+ "branch")
+ "tag")
+ name)))
(defun vc-hg-retrieve-tag (dir name _update)
"Retrieve the version tagged by NAME of all registered files at or below DIR."
@@ -646,8 +648,7 @@ directly instead of always running Mercurial. We try to be safe
against Mercurial data structure format changes and always fall
back to running Mercurial directly."
:type 'boolean
- :version "26.1"
- :group 'vc-hg)
+ :version "26.1")
(defsubst vc-hg--read-u8 ()
"Read and advance over an unsigned byte.
@@ -1146,7 +1147,8 @@ hg binary."
;; Modeled after the similar function in vc-bzr.el
(defun vc-hg-rename-file (old new)
"Rename file from OLD to NEW using `hg mv'."
- (vc-hg-command nil 0 new "mv" old))
+ (vc-hg-command nil 0 (expand-file-name new) "mv"
+ (expand-file-name old)))
(defun vc-hg-register (files &optional _comment)
"Register FILES under hg. COMMENT is ignored."
@@ -1156,7 +1158,7 @@ hg binary."
"Create a new Mercurial repository."
(vc-hg-command nil 0 nil "init"))
-(defalias 'vc-hg-responsible-p 'vc-hg-root)
+(defalias 'vc-hg-responsible-p #'vc-hg-root)
(defun vc-hg-unregister (file)
"Unregister FILE from hg."
@@ -1179,7 +1181,7 @@ If toggling on, also insert its message into the buffer."
(defvar vc-hg-log-edit-mode-map
(let ((map (make-sparse-keymap "Hg-Log-Edit")))
- (define-key map "\C-c\C-e" 'vc-hg-log-edit-toggle-amend)
+ (define-key map "\C-c\C-e" #'vc-hg-log-edit-toggle-amend)
map))
(define-derived-mode vc-hg-log-edit-mode log-edit-mode "Log-Edit/hg"
@@ -1193,7 +1195,7 @@ REV is ignored."
(lambda (value)
(when (equal value "yes")
(list "--amend")))))
- (apply 'vc-hg-command nil 0 files
+ (apply #'vc-hg-command nil 0 files
(nconc (list "commit" "-m")
(log-edit-extract-headers `(("Author" . "--user")
("Date" . "--date")
@@ -1231,7 +1233,7 @@ REV is the revision to check out into WORKFILE."
(unless (re-search-forward "^<<<<<<< " nil t)
(vc-hg-command nil 0 buffer-file-name "resolve" "-m")
;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-hg-resolve-when-done t))))
+ (remove-hook 'after-save-hook #'vc-hg-resolve-when-done t))))
(defun vc-hg-find-file-hook ()
(when (and buffer-file-name
@@ -1247,7 +1249,7 @@ REV is the revision to check out into WORKFILE."
;; Hg may not recognize "conflict" as a state, but we can do better.
(vc-file-setprop buffer-file-name 'vc-state 'conflict)
(smerge-start-session)
- (add-hook 'after-save-hook 'vc-hg-resolve-when-done nil t)
+ (add-hook 'after-save-hook #'vc-hg-resolve-when-done nil t)
(vc-message-unresolved-conflicts buffer-file-name)))
@@ -1366,25 +1368,28 @@ REV is the revision to check out into WORKFILE."
(vc-run-delayed
(vc-hg-after-dir-status update-function)))
-(defun vc-hg-dir-extra-header (name &rest commands)
- (concat (propertize name 'face 'font-lock-type-face)
- (propertize
- (with-temp-buffer
- (apply 'vc-hg-command (current-buffer) 0 nil commands)
- (buffer-substring-no-properties (point-min) (1- (point-max))))
- 'face 'font-lock-variable-name-face)))
-
(defun vc-hg-dir-extra-headers (dir)
- "Generate extra status headers for a Mercurial tree."
+ "Generate extra status headers for a repository in DIR.
+This runs the command \"hg summary\"."
(let ((default-directory dir))
- (concat
- (vc-hg-dir-extra-header "Root : " "root") "\n"
- (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
- (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
- ;; these change after each commit
- ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
- ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
- )))
+ (with-temp-buffer
+ (vc-hg-command t 0 nil "summary")
+ (goto-char (point-min))
+ (mapconcat
+ #'identity
+ (let (result)
+ (while (not (eobp))
+ (push
+ (let ((entry (if (looking-at "\\([^ ].*\\): \\(.*\\)")
+ (cons (capitalize (match-string 1)) (match-string 2))
+ (cons "" (buffer-substring (point) (line-end-position))))))
+ (concat
+ (propertize (format "%-11s: " (car entry)) 'face 'vc-dir-header)
+ (propertize (cdr entry) 'face 'vc-dir-header-value)))
+ result)
+ (forward-line))
+ (nreverse result))
+ "\n"))))
(defun vc-hg-log-incoming (buffer remote-location)
(vc-setup-buffer buffer)
@@ -1419,7 +1424,7 @@ commands, which only operated on marked files."
(apply #'vc-hg-command
nil 0 nil
command
- (apply 'nconc
+ (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)))
@@ -1439,18 +1444,18 @@ commands, which only operated on marked files."
(setq hg-program (car args)
command (cadr args)
args (cddr args)))
- (apply 'vc-do-async-command buffer root hg-program command args)
+ (apply #'vc-do-async-command buffer root hg-program command args)
(with-current-buffer buffer
(vc-run-delayed
(dolist (cmd post-processing)
- (apply 'vc-do-command buffer nil hg-program nil cmd))
+ (apply #'vc-do-command buffer nil hg-program nil cmd))
(vc-compilation-mode 'hg)
(setq-local compile-command
(concat hg-program " " command " "
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
(mapconcat (lambda (args)
(concat " && " hg-program " "
- (mapconcat 'identity
+ (mapconcat #'identity
args " ")))
post-processing "")))
(setq-local compilation-directory root)
@@ -1501,7 +1506,7 @@ This runs the command \"hg merge\"."
;; Disable pager.
(process-environment (cons "HGPLAIN=1" process-environment))
(branch (vc-read-revision "Revision to merge: ")))
- (apply 'vc-do-async-command buffer root vc-hg-program
+ (apply #'vc-do-async-command buffer root vc-hg-program
(append '("--config" "ui.report_untrusted=0" "merge")
(unless (string= branch "") (list branch))))
(with-current-buffer buffer (vc-run-delayed (vc-compilation-mode 'hg)))
@@ -1516,7 +1521,8 @@ This function differs from vc-do-command in that it invokes
;; Disable pager.
(let ((process-environment (cons "HGPLAIN=1" process-environment))
(flags (append '("--config" "ui.report_untrusted=0") flags)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
+ (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)
(append vc-hg-global-switches
@@ -1525,6 +1531,14 @@ This function differs from vc-do-command in that it invokes
(defun vc-hg-root (file)
(vc-find-root file ".hg"))
+(defun vc-hg-repository-url (file-or-dir &optional remote-name)
+ (let ((default-directory (vc-hg-root file-or-dir)))
+ (with-temp-buffer
+ (vc-hg-command (current-buffer) 0 nil
+ "config"
+ (concat "paths." (or remote-name "default")))
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
+
(provide 'vc-hg)
;;; vc-hg.el ends here
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index e93f7ee8410..4b3c829a2c6 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -50,50 +50,42 @@
(defface vc-up-to-date-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file is up to date."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-needs-update-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file needs update."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-locked-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file locked."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-locally-added-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file is locally added."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-conflict-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file contains merge conflicts."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-removed-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file was removed from the VC system."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-missing-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file is missing from the file system."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
(defface vc-edited-state
'((default :inherit vc-state-base))
"Face for VC modeline state when the file is edited."
- :version "25.1"
- :group 'vc-faces)
+ :version "25.1")
;; Customization Variables (the rest is in vc.el)
@@ -498,21 +490,13 @@ status of this file. Otherwise, the value returned is one of:
"Return the repository version from which FILE was checked out.
If FILE is not registered, this function always returns nil."
(or (vc-file-getprop file 'vc-working-revision)
- (progn
+ (let ((default-directory (file-name-directory file)))
(setq backend (or backend (vc-backend file)))
(when backend
(vc-file-setprop file 'vc-working-revision
(vc-call-backend
backend 'working-revision file))))))
-;; Backward compatibility.
-(define-obsolete-function-alias
- 'vc-workfile-version 'vc-working-revision "23.1")
-(defun vc-default-working-revision (backend file)
- (message
- "`working-revision' not found: using the old `workfile-version' instead")
- (vc-call-backend backend 'workfile-version file))
-
(defun vc-default-registered (backend file)
"Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
(let ((sym (vc-make-backend-sym backend 'master-templates)))
@@ -822,7 +806,7 @@ In the latter case, VC mode is deactivated for this buffer."
(unless vc-make-backup-files
;; Use this variable, not make-backup-files,
;; because this is for things that depend on the file name.
- (set (make-local-variable 'backup-inhibited) t)))
+ (setq-local backup-inhibited t)))
((let* ((truename (and buffer-file-truename
(expand-file-name buffer-file-truename)))
(link-type (and truename
@@ -879,31 +863,31 @@ In the latter case, VC mode is deactivated for this buffer."
;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
(defvar vc-prefix-map
(let ((map (make-sparse-keymap)))
- (define-key map "a" 'vc-update-change-log)
- (define-key map "b" 'vc-switch-backend)
- (define-key map "d" 'vc-dir)
- (define-key map "g" 'vc-annotate)
- (define-key map "G" 'vc-ignore)
- (define-key map "h" 'vc-region-history)
- (define-key map "i" 'vc-register)
- (define-key map "l" 'vc-print-log)
- (define-key map "L" 'vc-print-root-log)
- (define-key map "I" 'vc-log-incoming)
- (define-key map "O" 'vc-log-outgoing)
- (define-key map "ML" 'vc-log-mergebase)
- (define-key map "MD" 'vc-diff-mergebase)
- (define-key map "m" 'vc-merge)
- (define-key map "r" 'vc-retrieve-tag)
- (define-key map "s" 'vc-create-tag)
- (define-key map "u" 'vc-revert)
- (define-key map "v" 'vc-next-action)
- (define-key map "+" 'vc-update)
+ (define-key map "a" #'vc-update-change-log)
+ (define-key map "b" #'vc-switch-backend)
+ (define-key map "d" #'vc-dir)
+ (define-key map "g" #'vc-annotate)
+ (define-key map "G" #'vc-ignore)
+ (define-key map "h" #'vc-region-history)
+ (define-key map "i" #'vc-register)
+ (define-key map "l" #'vc-print-log)
+ (define-key map "L" #'vc-print-root-log)
+ (define-key map "I" #'vc-log-incoming)
+ (define-key map "O" #'vc-log-outgoing)
+ (define-key map "ML" #'vc-log-mergebase)
+ (define-key map "MD" #'vc-diff-mergebase)
+ (define-key map "m" #'vc-merge)
+ (define-key map "r" #'vc-retrieve-tag)
+ (define-key map "s" #'vc-create-tag)
+ (define-key map "u" #'vc-revert)
+ (define-key map "v" #'vc-next-action)
+ (define-key map "+" #'vc-update)
;; I'd prefer some kind of symmetry with vc-update:
- (define-key map "P" 'vc-push)
- (define-key map "=" 'vc-diff)
- (define-key map "D" 'vc-root-diff)
- (define-key map "~" 'vc-revision-other-window)
- (define-key map "x" 'vc-delete-file)
+ (define-key map "P" #'vc-push)
+ (define-key map "=" #'vc-diff)
+ (define-key map "D" #'vc-root-diff)
+ (define-key map "~" #'vc-revision-other-window)
+ (define-key map "x" #'vc-delete-file)
map))
(fset 'vc-prefix-map vc-prefix-map)
(define-key ctl-x-map "v" 'vc-prefix-map)
@@ -972,9 +956,9 @@ In the latter case, VC mode is deactivated for this buffer."
(bindings--define-key map [vc-ignore]
'(menu-item "Ignore File..." vc-ignore
:help "Ignore a file under current version control system"))
- (bindings--define-key map [vc-dir]
- '(menu-item "VC Dir" vc-dir
- :help "Show the VC status of files in a directory"))
+ (bindings--define-key map [vc-dir-root]
+ '(menu-item "VC Dir" vc-dir-root
+ :help "Show the VC status of the repository"))
map))
(defalias 'vc-menu-map vc-menu-map)
diff --git a/lisp/vc/vc-mtn.el b/lisp/vc/vc-mtn.el
index 6022ee910e4..ea69893071a 100644
--- a/lisp/vc/vc-mtn.el
+++ b/lisp/vc/vc-mtn.el
@@ -46,8 +46,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc-mtn)
+ :version "23.1")
(defcustom vc-mtn-annotate-switches nil
"String or list of strings specifying switches for mtn annotate under VC.
@@ -57,14 +56,11 @@ switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "25.1"
- :group 'vc-mtn)
+ :version "25.1")
-(define-obsolete-variable-alias 'vc-mtn-command 'vc-mtn-program "23.1")
(defcustom vc-mtn-program "mtn"
"Name of the monotone executable."
- :type 'string
- :group 'vc-mtn)
+ :type 'string)
;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
@@ -116,7 +112,7 @@ switches."
(let ((process-environment
;; Avoid localization of messages so we can parse the output.
(cons "LC_MESSAGES=C" process-environment)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
+ (apply #'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
files flags)))
(defun vc-mtn-state (file)
@@ -177,8 +173,7 @@ switches."
'(("\\`[^:/#]*[:/#]" . "")) ;Drop the host part.
"Rewrite rules to shorten Mtn's revision names on the mode-line."
:type '(repeat (cons regexp string))
- :version "22.2"
- :group 'vc-mtn)
+ :version "22.2")
(defun vc-mtn-mode-line-string (file)
"Return a string for `vc-mode-line' to put in the mode line for FILE."
@@ -204,7 +199,7 @@ switches."
(declare-function log-edit-extract-headers "log-edit" (headers string))
(defun vc-mtn-checkin (files comment &optional _rev)
- (apply 'vc-mtn-command nil 0 files
+ (apply #'vc-mtn-command nil 0 files
(nconc (list "commit" "-m")
(log-edit-extract-headers '(("Author" . "--author")
("Date" . "--date"))
@@ -228,7 +223,7 @@ switches."
_SHORTLOG is ignored.
If START-REVISION is non-nil, it is the newest revision to show.
If LIMIT is non-nil, show no more than this many entries."
- (apply 'vc-mtn-command buffer 0 files "log"
+ (apply #'vc-mtn-command buffer 0 files "log"
(append
(when start-revision (list "--from" (format "%s" start-revision)))
(when limit (list "--last" (format "%s" limit))))))
@@ -240,14 +235,14 @@ If LIMIT is non-nil, show no more than this many entries."
(define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View"
;; Don't match anything.
- (set (make-local-variable 'log-view-file-re) regexp-unmatchable)
- (set (make-local-variable 'log-view-per-file-logs) nil)
+ (setq-local log-view-file-re regexp-unmatchable)
+ (setq-local log-view-per-file-logs nil)
;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives
;; in the ChangeLog text.
- (set (make-local-variable 'log-view-message-re)
- "^[ |/]+Revision: \\([0-9a-f]+\\)")
+ (setq-local log-view-message-re
+ "^[ |/]+Revision: \\([0-9a-f]+\\)")
(require 'add-log) ;For change-log faces.
- (set (make-local-variable 'log-view-font-lock-keywords)
+ (setq-local log-view-font-lock-keywords
(append log-view-font-lock-keywords
'(("^[ |]+Author: \\(.*\\)" (1 'change-log-email))
("^[ |]+Date: \\(.*\\)" (1 'change-log-date))))))
@@ -259,7 +254,7 @@ If LIMIT is non-nil, show no more than this many entries."
(defun vc-mtn-diff (files &optional rev1 rev2 buffer _async)
"Get a difference report using monotone between two revisions of FILES."
- (apply 'vc-mtn-command (or buffer "*vc-diff*")
+ (apply #'vc-mtn-command (or buffer "*vc-diff*")
1 ; bug#21969
files "diff"
(append
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index 4acb896d135..6ffc1a8a2ff 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -58,8 +58,7 @@
If nil, VC itself computes this value when it is first needed."
:type '(choice (const :tag "Auto" nil)
(string :tag "Specified")
- (const :tag "Unknown" unknown))
- :group 'vc-rcs)
+ (const :tag "Unknown" unknown)))
(defcustom vc-rcs-register-switches nil
"Switches for registering a file in RCS.
@@ -70,8 +69,7 @@ If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-rcs)
+ :version "21.1")
(defcustom vc-rcs-diff-switches nil
"String or list of strings specifying switches for RCS diff under VC.
@@ -80,21 +78,18 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-rcs)
+ :version "21.1")
(defcustom vc-rcs-header '("$Id\ $")
"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-rcs)
+ :version "24.1") ; no longer consult the obsolete vc-header-alist
(defcustom vc-rcsdiff-knows-brief nil
"Indicates whether rcsdiff understands the --brief option.
The value is either `yes', `no', or nil. If it is nil, VC tries
to use --brief and sets this variable to remember whether it worked."
- :type '(choice (const :tag "Work out" nil) (const yes) (const no))
- :group 'vc-rcs)
+ :type '(choice (const :tag "Work out" nil) (const yes) (const no)))
;; This needs to be autoloaded because vc-rcs-registered uses it (via
;; vc-default-registered), and vc-hooks needs to be able to check
@@ -109,8 +104,7 @@ For a description of possible values, see `vc-check-master-templates'."
(repeat :tag "User-specified"
(choice string
function)))
- :version "21.1"
- :group 'vc-rcs)
+ :version "21.1")
;;; Properties of the backend
@@ -312,7 +306,7 @@ whether to remove it."
(and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
;; check whether RCS dir is empty, i.e. it does not
;; contain any files except "." and ".."
- (not (directory-files dir nil (rx (or (not ".") "..."))))
+ (not (directory-files dir nil directory-files-no-dot-files-regexp))
(yes-or-no-p (format "Directory %s is empty; remove it? " dir))
(delete-directory dir)))))
@@ -379,7 +373,7 @@ whether to remove it."
"Retrieve a copy of a saved version of FILE. If FILE is a directory,
attempt the checkout for all registered files beneath it."
(if (file-directory-p file)
- (mapc 'vc-rcs-checkout (vc-expand-dirs (list file) 'RCS))
+ (mapc #'vc-rcs-checkout (vc-expand-dirs (list file) 'RCS))
(let ((file-buffer (get-file-buffer file))
switches)
(message "Checking out %s..." file)
@@ -445,7 +439,7 @@ attempt the checkout for all registered files beneath it."
"Revert FILE to the version it was based on. If FILE is a directory,
revert all registered files beneath it."
(if (file-directory-p file)
- (mapc 'vc-rcs-revert (vc-expand-dirs (list file) 'RCS))
+ (mapc #'vc-rcs-revert (vc-expand-dirs (list file) 'RCS))
(vc-do-command "*vc*" 0 "co" (vc-master-name file) "-f"
(concat (if (eq (vc-state file) 'edited) "-u" "-r")
(vc-working-revision file)))))
@@ -488,7 +482,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
If FILE is a directory, steal the lock on all registered files beneath it.
Needs RCS 5.6.2 or later for -M."
(if (file-directory-p file)
- (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file) 'RCS))
+ (mapc #'vc-rcs-steal-lock (vc-expand-dirs (list file) 'RCS))
(vc-do-command "*vc*" 0 "rcs" (vc-master-name file) "-M" (concat "-u" rev))
;; Do a real checkout after stealing the lock, so that we see
;; expanded headers.
@@ -539,7 +533,7 @@ Remaining arguments are ignored.
If FILE is a directory the operation is applied to all registered
files beneath it."
(vc-do-command (or buffer "*vc*") 0 "rlog"
- (mapcar 'vc-master-name (vc-expand-dirs files 'RCS)))
+ (mapcar #'vc-master-name (vc-expand-dirs files 'RCS)))
(with-current-buffer (or buffer "*vc*")
(vc-rcs-print-log-cleanup))
(when limit 'limit-unsupported))
@@ -1344,7 +1338,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
(push `(,(to-eol)
,(k-semi 'date
(lambda ()
- (let ((ls (mapcar 'string-to-number
+ (let ((ls (mapcar #'string-to-number
(split-string
(buffer-substring-no-properties
b e)
diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el
index 3d3f4048052..92cce5f13a8 100644
--- a/lisp/vc/vc-sccs.el
+++ b/lisp/vc/vc-sccs.el
@@ -55,8 +55,7 @@ If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-sccs)
+ :version "21.1")
(defcustom vc-sccs-diff-switches nil
"String or list of strings specifying switches for SCCS diff under VC.
@@ -65,14 +64,12 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc-sccs)
+ :version "21.1")
(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-sccs)
+ :version "24.1") ; no longer consult the obsolete vc-header-alist
;; This needs to be autoloaded because vc-sccs-registered uses it (via
;; vc-default-registered), and vc-hooks needs to be able to check
@@ -87,8 +84,7 @@ For a description of possible values, see `vc-check-master-templates'."
(repeat :tag "User-specified"
(choice string
function)))
- :version "21.1"
- :group 'vc-sccs)
+ :version "21.1")
;;;
@@ -163,7 +159,7 @@ For a description of possible values, see `vc-check-master-templates'."
"Write the SCCS version of input file FILE to output file OUTFILE.
Optional string REV is a revision."
(with-temp-buffer
- (apply 'vc-sccs-do-command t 0 "get" (vc-master-name file)
+ (apply #'vc-sccs-do-command t 0 "get" (vc-master-name file)
(append '("-s" "-p" "-k") ; -k: no keyword expansion
(if rev (list (concat "-r" rev)))))
(write-region nil nil outfile nil 'silent)))
@@ -185,7 +181,7 @@ Optional string REV is a revision."
(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags)
;; (let ((load-path (append vc-sccs-path load-path)))
;; (apply 'vc-do-command buffer okstatus command file-or-list flags))
- (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
+ (apply #'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
(defun vc-sccs-create-repo ()
"Create a new SCCS repository."
@@ -207,7 +203,7 @@ to the SCCS command."
(let ((vc-master-name
(or project-file
(format (car vc-sccs-master-templates) dirname basename))))
- (apply 'vc-sccs-do-command nil 0 "admin" vc-master-name
+ (apply #'vc-sccs-do-command nil 0 "admin" vc-master-name
"-fb"
(concat "-i" (file-relative-name file))
(and comment (concat "-y" comment))
@@ -225,14 +221,14 @@ to the SCCS command."
(defun vc-sccs-checkin (files comment &optional rev)
"SCCS-specific version of `vc-backend-checkin'."
(dolist (file (vc-expand-dirs files 'SCCS))
- (apply 'vc-sccs-do-command nil 0 "delta" (vc-master-name file)
+ (apply #'vc-sccs-do-command nil 0 "delta" (vc-master-name file)
(if rev (concat "-r" rev))
(concat "-y" comment)
(vc-switches 'SCCS 'checkin))
(vc-sccs-do-command nil 0 "get" (vc-master-name file))))
(defun vc-sccs-find-revision (file rev buffer)
- (apply 'vc-sccs-do-command
+ (apply #'vc-sccs-do-command
buffer 0 "get" (vc-master-name file)
"-s" ;; suppress diagnostic output
"-p"
@@ -247,7 +243,7 @@ If FILE is a directory, all version-controlled files beneath are checked out.
EDITABLE non-nil means that the file should be writable and
locked. REV is the revision to check out."
(if (file-directory-p file)
- (mapc 'vc-sccs-checkout (vc-expand-dirs (list file) 'SCCS))
+ (mapc #'vc-sccs-checkout (vc-expand-dirs (list file) 'SCCS))
(let ((file-buffer (get-file-buffer file))
switches)
(message "Checking out %s..." file)
@@ -267,7 +263,7 @@ locked. REV is the revision to check out."
(and rev (or (string= rev "")
(not (stringp rev)))
(setq rev nil))
- (apply 'vc-sccs-do-command nil 0 "get" (vc-master-name file)
+ (apply #'vc-sccs-do-command nil 0 "get" (vc-master-name file)
"-e"
(and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
switches))))
@@ -277,7 +273,7 @@ locked. REV is the revision to check out."
"Revert FILE to the version it was based on. If FILE is a directory,
revert all subfiles."
(if (file-directory-p file)
- (mapc 'vc-sccs-revert (vc-expand-dirs (list file) 'SCCS))
+ (mapc #'vc-sccs-revert (vc-expand-dirs (list file) 'SCCS))
(vc-sccs-do-command nil 0 "unget" (vc-master-name file))
(vc-sccs-do-command nil 0 "get" (vc-master-name file))
;; Checking out explicit revisions is not supported under SCCS, yet.
@@ -288,7 +284,7 @@ revert all subfiles."
(defun vc-sccs-steal-lock (file &optional rev)
"Steal the lock on the current workfile for FILE and revision REV."
(if (file-directory-p file)
- (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file) 'SCCS))
+ (mapc #'vc-sccs-steal-lock (vc-expand-dirs (list file) 'SCCS))
(vc-sccs-do-command nil 0 "unget"
(vc-master-name file) "-n" (if rev (concat "-r" rev)))
(vc-sccs-do-command nil 0 "get"
@@ -309,7 +305,7 @@ revert all subfiles."
"Print commit log associated with FILES into specified BUFFER.
Remaining arguments are ignored."
(setq files (vc-expand-dirs files 'SCCS))
- (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-master-name files))
+ (vc-sccs-do-command buffer 0 "prs" (mapcar #'vc-master-name files))
(when limit 'limit-unsupported))
(autoload 'vc-setup-buffer "vc-dispatcher")
@@ -338,7 +334,7 @@ Remaining arguments are ignored."
(fake-command
(format "diff%s %s"
(if fake-flags
- (concat " " (mapconcat 'identity fake-flags " "))
+ (concat " " (mapconcat #'identity fake-flags " "))
"")
(vc-delistify files)))
(status 0)
@@ -362,7 +358,7 @@ Remaining arguments are ignored."
(cons "LC_MESSAGES=C" process-environment))
(w32-quote-process-args t)
(this-status
- (apply 'process-file "diff" nil t nil
+ (apply #'process-file "diff" nil t nil
(append (vc-switches 'SCCS 'diff)
(list (file-local-name oldfile)
(or newfile
diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el
index aeff73391f2..faba5bce2b7 100644
--- a/lisp/vc/vc-src.el
+++ b/lisp/vc/vc-src.el
@@ -97,13 +97,11 @@
If nil, VC itself computes this value when it is first needed."
:type '(choice (const :tag "Auto" nil)
(string :tag "Specified")
- (const :tag "Unknown" unknown))
- :group 'vc-src)
+ (const :tag "Unknown" unknown)))
(defcustom vc-src-program "src"
"Name of the SRC executable (excluding any arguments)."
- :type 'string
- :group 'vc-src)
+ :type 'string)
(defcustom vc-src-diff-switches nil
"String or list of strings specifying switches for SRC diff under VC.
@@ -111,8 +109,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:type '(choice (const :tag "Unspecified" nil)
(const :tag "None" t)
(string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-src)
+ (repeat :tag "Argument List" :value ("") string)))
;; This needs to be autoloaded because vc-src-registered uses it (via
;; vc-default-registered), and vc-hooks needs to be able to check
@@ -126,8 +123,7 @@ For a description of possible values, see `vc-check-master-templates'."
'("%s.src/%s,v"))
(repeat :tag "User-specified"
(choice string
- function)))
- :group 'vc-src)
+ function))))
;;; Properties of the backend
@@ -146,6 +142,20 @@ For a description of possible values, see `vc-check-master-templates'."
(progn
(defun vc-src-registered (f) (vc-default-registered 'src f)))
+(defun vc-src--parse-state (out)
+ (when (null (string-match "does not exist or is unreadable" out))
+ (let ((state (aref out 0)))
+ (cond
+ ;; FIXME: What to do about L code?
+ ((eq state ?.) 'up-to-date)
+ ((eq state ?A) 'added)
+ ((eq state ?M) 'edited)
+ ((eq state ?I) 'ignored)
+ ((eq state ?R) 'removed)
+ ((eq state ?!) 'missing)
+ ((eq state ??) 'unregistered)
+ (t 'up-to-date)))))
+
(defun vc-src-state (file)
"SRC-specific version of `vc-state'."
(let*
@@ -163,32 +173,41 @@ For a description of possible values, see `vc-check-master-templates'."
"status" "-a" (file-relative-name file))
(error nil)))))))
(when (eq 0 status)
- (when (null (string-match "does not exist or is unreadable" out))
- (let ((state (aref out 0)))
- (cond
- ;; FIXME: What to do about A and L codes?
- ((eq state ?.) 'up-to-date)
- ((eq state ?A) 'added)
- ((eq state ?M) 'edited)
- ((eq state ?I) 'ignored)
- ((eq state ?R) 'removed)
- ((eq state ?!) 'missing)
- ((eq state ??) 'unregistered)
- (t 'up-to-date)))))))
+ (vc-src--parse-state out))))
(autoload 'vc-expand-dirs "vc")
(defun vc-src-dir-status-files (dir files update-function)
- ;; FIXME: Use one src status -a call for this
- (if (not files) (setq files (vc-expand-dirs (list dir) 'SRC)))
- (let ((result nil))
- (dolist (file files)
- (let ((state (vc-state file))
- (frel (file-relative-name file)))
- (when (and (eq (vc-backend file) 'SRC)
- (not (eq state 'up-to-date)))
- (push (list frel state) result))))
- (funcall update-function result)))
+ (let* ((result nil)
+ (status nil)
+ (default-directory (or dir default-directory))
+ (out
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (setq status
+ (ignore-errors
+ (apply
+ #'process-file vc-src-program nil t nil
+ "status" "-a"
+ (mapcar #'file-relative-name files)))))))
+ dlist)
+ (when (eq 0 status)
+ (dolist (line (split-string out "[\n\r]" t))
+ (let* ((pair (split-string line "[\t]" t))
+ (state (vc-src--parse-state (car pair)))
+ (frel (cadr pair)))
+ (if (file-directory-p frel)
+ (push frel dlist)
+ (when (not (eq state 'up-to-date))
+ (push (list frel state) result)))))
+ (dolist (drel dlist)
+ (let ((dresult (vc-src-dir-status-files
+ (expand-file-name drel) nil #'identity)))
+ (dolist (dres dresult)
+ (push (list (concat (file-name-as-directory drel) (car dres))
+ (cadr dres))
+ result))))
+ (funcall update-function result))))
(defun vc-src-command (buffer file-or-list &rest flags)
"A wrapper around `vc-do-command' for use in vc-src.el.
@@ -198,7 +217,7 @@ This function differs from vc-do-command in that it invokes `vc-src-program'."
(setq file-list (list "--" file-or-list)))
(file-or-list
(setq file-list (cons "--" file-or-list))))
- (apply 'vc-do-command (or buffer "*vc*") 0 vc-src-program file-list flags)))
+ (apply #'vc-do-command (or buffer "*vc*") 0 vc-src-program file-list flags)))
(defun vc-src-working-revision (file)
"SRC-specific version of `vc-working-revision'."
@@ -252,7 +271,7 @@ REV is the revision to check out into WORKFILE."
"Revert FILE to the version it was based on. If FILE is a directory,
revert all registered files beneath it."
(if (file-directory-p file)
- (mapc 'vc-src-revert (vc-expand-dirs (list file) 'SRC))
+ (mapc #'vc-src-revert (vc-expand-dirs (list file) 'SRC))
(vc-src-command nil file "co")))
(defun vc-src-modify-change-comment (files rev comment)
@@ -267,8 +286,7 @@ directory the operation is applied to all registered files beneath it."
"String or list of strings specifying switches for src log under VC."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-src)
+ (repeat :tag "Argument List" :value ("") string)))
(defun vc-src-print-log (files buffer &optional shortlog _start-revision limit)
"Print commit log associated with FILES into specified BUFFER.
@@ -284,7 +302,7 @@ If LIMIT is non-nil, show no more than this many entries."
(let ((inhibit-read-only t))
(with-current-buffer
buffer
- (apply 'vc-src-command buffer files (if shortlog "list" "log")
+ (apply #'vc-src-command buffer files (if shortlog "list" "log")
(nconc
;;(when start-revision (list (format "%s-1" start-revision)))
(when limit (list "-l" (format "%s" limit)))
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index 084f357d31f..c30920dd157 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -47,12 +47,11 @@
;; FIXME there is also svnadmin.
(defcustom vc-svn-program "svn"
"Name of the SVN executable."
- :type 'string
- :group 'vc-svn)
+ :type 'string)
;; Might be nice if svn defaulted to non-interactive if stdin not tty.
-;; http://svn.haxx.se/dev/archive-2008-05/0762.shtml
-;; http://svn.haxx.se/dev/archive-2009-04/0094.shtml
+;; https://svn.haxx.se/dev/archive-2008-05/0762.shtml
+;; https://svn.haxx.se/dev/archive-2009-04/0094.shtml
;; Maybe newer ones do?
(defcustom vc-svn-global-switches (unless (eq system-type 'darwin) ; bug#13513
'("--non-interactive"))
@@ -64,8 +63,7 @@ hanging while prompting for authorization."
(repeat :tag "Argument List"
:value ("")
string))
- :version "24.4"
- :group 'vc-svn)
+ :version "24.4")
(defcustom vc-svn-register-switches nil
"Switches for registering a file into SVN.
@@ -76,8 +74,7 @@ If t, use no switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "22.1"
- :group 'vc-svn)
+ :version "22.1")
(defcustom vc-svn-diff-switches
t ;`svn' doesn't support common args like -c or -b.
@@ -92,8 +89,7 @@ If you want to force an empty list of arguments, use t."
(repeat :tag "Argument List"
:value ("")
string))
- :version "22.1"
- :group 'vc-svn)
+ :version "22.1")
(defcustom vc-svn-annotate-switches nil
"String or list of strings specifying switches for svn annotate under VC.
@@ -103,14 +99,12 @@ switches."
(const :tag "None" t)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
- :version "25.1"
- :group 'vc-svn)
+ :version "25.1")
(defcustom vc-svn-header '("$Id\ $")
"Header keywords to be inserted by `vc-insert-headers'."
:version "24.1" ; no longer consult the obsolete vc-header-alist
- :type '(repeat string)
- :group 'vc-svn)
+ :type '(repeat string))
;; We want to autoload it for use by the autoloaded version of
;; vc-svn-registered, but we want the value to be compiled at startup, not
@@ -239,8 +233,8 @@ RESULT is a list of conses (FILE . STATE) for directory DIR."
(concat
(cond (repo
(concat
- (propertize "Repository : " 'face 'font-lock-type-face)
- (propertize repo 'face 'font-lock-variable-name-face)))
+ (propertize "Repository : " 'face 'vc-dir-header)
+ (propertize repo 'face 'vc-dir-header-value)))
(t "")))))
(defun vc-svn-working-revision (file)
@@ -305,19 +299,19 @@ RESULT is a list of conses (FILE . STATE) for directory DIR."
The COMMENT argument is ignored This does an add but not a commit.
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)))
+ (apply #'vc-svn-command nil 0 files "add" (vc-switches 'SVN 'register)))
(defun vc-svn-root (file)
(vc-find-root file vc-svn-admin-directory))
-(defalias 'vc-svn-responsible-p 'vc-svn-root)
+(defalias 'vc-svn-responsible-p #'vc-svn-root)
(declare-function log-edit-extract-headers "log-edit" (headers string))
(defun vc-svn-checkin (files comment &optional _extra-args-ignored)
"SVN-specific version of `vc-backend-checkin'."
(let ((status (apply
- 'vc-svn-command nil 1 files "ci"
+ #'vc-svn-command nil 1 files "ci"
(nconc (cons "-m" (log-edit-extract-headers nil comment))
(vc-switches 'SVN 'checkin)))))
(set-buffer "*vc*")
@@ -345,7 +339,7 @@ to the SVN command."
(defun vc-svn-find-revision (file rev buffer)
"SVN-specific retrieval of a specified version into a buffer."
(let (process-file-side-effects)
- (apply 'vc-svn-command
+ (apply #'vc-svn-command
buffer 0 file
"cat"
(and rev (not (string= rev ""))
@@ -391,7 +385,7 @@ DIRECTORY or absolute."
nil
;; Check out a particular version (or recreate the file).
(vc-file-setprop file 'vc-working-revision nil)
- (apply 'vc-svn-command nil 0 file
+ (apply #'vc-svn-command nil 0 file
"update"
(cond
((null rev) "-rBASE")
@@ -548,7 +542,7 @@ or svn+ssh://."
(define-derived-mode vc-svn-log-view-mode log-view-mode "SVN-Log-View"
(require 'add-log)
- (set (make-local-variable 'log-view-per-file-logs) nil))
+ (setq-local log-view-per-file-logs nil))
(autoload 'vc-setup-buffer "vc-dispatcher")
@@ -563,27 +557,27 @@ If LIMIT is non-nil, show no more than this many entries."
(goto-char (point-min))
(if files
(dolist (file files)
- (insert "Working file: " file "\n")
- (apply
- 'vc-svn-command
- buffer
- 'async
- (list file)
- "log"
- (append
- (list
- (if start-revision
- (format "-r%s:1" start-revision)
- ;; By default Subversion only shows the log up to the
- ;; working revision, whereas we also want the log of the
- ;; subsequent commits. At least that's what the
- ;; vc-cvs.el code does.
- "-rHEAD:0"))
- (if (eq vc-log-view-type 'with-diff)
- (list "--diff"))
- (when limit (list "--limit" (format "%s" limit))))))
+ (insert "Working file: " file "\n")
+ (apply
+ #'vc-svn-command
+ buffer
+ 'async
+ (list file)
+ "log"
+ (append
+ (list
+ (if start-revision
+ (format "-r%s:1" start-revision)
+ ;; By default Subversion only shows the log up to the
+ ;; working revision, whereas we also want the log of the
+ ;; subsequent commits. At least that's what the
+ ;; vc-cvs.el code does.
+ "-rHEAD:0"))
+ (if (eq vc-log-view-type 'with-diff)
+ (list "--diff"))
+ (when limit (list "--limit" (format "%s" limit))))))
;; Dump log for the entire directory.
- (apply 'vc-svn-command buffer 0 nil "log"
+ (apply #'vc-svn-command buffer 0 nil "log"
(append
(list
(if start-revision (format "-r%s" start-revision) "-rHEAD:0"))
@@ -611,8 +605,8 @@ If LIMIT is non-nil, show no more than this many entries."
(if vc-svn-diff-switches
(vc-switches 'SVN 'diff)
(list (concat "--diff-cmd=" diff-command) "-x"
- (mapconcat 'identity (vc-switches nil 'diff) " ")))))
- (apply 'vc-svn-command buffer
+ (mapconcat #'identity (vc-switches nil 'diff) " ")))))
+ (apply #'vc-svn-command buffer
(if async 'async 0)
files "diff"
(append
@@ -671,7 +665,7 @@ NAME is assumed to be a URL."
"A wrapper around `vc-do-command' for use in vc-svn.el.
The difference to vc-do-command is that this function always invokes `svn',
and that it passes `vc-svn-global-switches' to it before FLAGS."
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-svn-program file-or-list
+ (apply #'vc-do-command (or buffer "*vc*") okstatus vc-svn-program file-or-list
(if (stringp vc-svn-global-switches)
(cons vc-svn-global-switches flags)
(append vc-svn-global-switches flags))))
@@ -683,7 +677,7 @@ and that it passes `vc-svn-global-switches' to it before FLAGS."
(unless (re-search-forward "^<<<<<<< " nil t)
(vc-svn-command nil 0 buffer-file-name "resolved")
;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-svn-resolve-when-done t))))
+ (remove-hook 'after-save-hook #'vc-svn-resolve-when-done t))))
;; Inspired by vc-arch-find-file-hook.
(defun vc-svn-find-file-hook ()
@@ -696,7 +690,7 @@ and that it passes `vc-svn-global-switches' to it before FLAGS."
;; There are conflict markers.
(progn
(smerge-start-session)
- (add-hook 'after-save-hook 'vc-svn-resolve-when-done nil t))
+ (add-hook 'after-save-hook #'vc-svn-resolve-when-done nil t))
;; There are no conflict markers. This is problematic: maybe it means
;; the conflict has been resolved and we should immediately call "svn
;; resolved", or it means that the file's type does not allow Svn to
@@ -816,7 +810,14 @@ Set file properties accordingly. If FILENAME is non-nil, return its status."
(push (match-string 1 loglines) vc-svn-revisions)
(setq start (+ start (match-end 0)))
(setq loglines (buffer-substring-no-properties start (point-max)))))
- vc-svn-revisions)))
+ vc-svn-revisions)))
+
+(defun vc-svn-repository-url (file-or-dir &optional _remote-name)
+ (let ((default-directory (vc-svn-root file-or-dir)))
+ (with-temp-buffer
+ (vc-svn-command (current-buffer) 0 nil
+ "info" "--show-item" "repos-root-url")
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
(provide 'vc-svn)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 3d712731904..9338b7191d0 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -553,6 +553,13 @@
;; Return the list of files where conflict resolution is needed in
;; the project that contains DIR.
;; FIXME: what should it do with non-text conflicts?
+;;
+;; - repository-url (file-or-dir &optional remote-name)
+;;
+;; Returns the URL of the repository of the current checkout
+;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the
+;; remote (in Git parlance) whose URL is to be returned. It has
+;; only a meaning for distributed VCS and is ignored otherwise.
;;; Changes from the pre-25.1 API:
;;
@@ -957,7 +964,7 @@ use."
(throw 'found bk))))
;;;###autoload
-(defun vc-responsible-backend (file)
+(defun vc-responsible-backend (file &optional no-error)
"Return the name of a backend system that is responsible for FILE.
If FILE is already registered, return the
@@ -967,15 +974,32 @@ responsible for FILE is returned.
Note that if FILE is a symbolic link, it will not be resolved --
the responsible backend system for the symbolic link itself will
-be reported."
+be reported.
+
+If NO-ERROR is nil, signal an error that no VC backend is
+responsible for the given file."
(or (and (not (file-directory-p file)) (vc-backend file))
- (catch 'found
- ;; First try: find a responsible backend. If this is for registration,
- ;; it must be a backend under which FILE is not yet registered.
- (dolist (backend vc-handled-backends)
- (and (vc-call-backend backend 'responsible-p file)
- (throw 'found backend))))
- (error "No VC backend is responsible for %s" file)))
+ ;; FIXME it would be more efficient to walk up the directory tree,
+ ;; stopping the first time a backend is responsible.
+ ;;
+ ;; First try: find a responsible backend. If this is for registration,
+ ;; it must be a backend under which FILE is not yet registered.
+ (let ((dirs (delq nil
+ (mapcar
+ (lambda (backend)
+ (when-let ((dir (vc-call-backend
+ backend 'responsible-p file)))
+ (cons backend dir)))
+ vc-handled-backends))))
+ ;; Just a single response (or none); use it.
+ (if (< (length dirs) 2)
+ (caar dirs)
+ ;; Several roots; we seem to have one vc inside another's
+ ;; directory. Choose the most specific.
+ (caar (sort dirs (lambda (d1 d2)
+ (< (length (cdr d2)) (length (cdr d1))))))))
+ (unless no-error
+ (error "No VC backend is responsible for %s" file))))
(defun vc-expand-dirs (file-or-dir-list backend)
"Expands directories in a file list specification.
@@ -1006,35 +1030,57 @@ Within directories, only files already under version control are noticed."
(declare-function vc-dir-current-file "vc-dir" ())
(declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files))
+(declare-function dired-vc-deduce-fileset "dired-aux" (&optional state-model-only-files not-state-changing))
-(defun vc-deduce-fileset (&optional observer allow-unregistered
+(defun vc-deduce-fileset (&optional not-state-changing
+ allow-unregistered
state-model-only-files)
"Deduce a set of files and a backend to which to apply an operation.
-Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL).
+Return a list of the form:
+
+ (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL)
-If we're in VC-dir mode, FILESET is the list of marked files,
-or the directory if no files are marked.
-Otherwise, if in a buffer visiting a version-controlled file,
-FILESET is a single-file fileset containing that file.
+where the last 3 members are optional, and must be present only if
+STATE-MODEL-ONLY-FILES is non-nil.
+
+NOT-STATE-CHANGING, if non-nil, means that the operation
+requesting the fileset doesn't intend to change the VC state,
+such as when printing the log or showing the diffs.
+
+If the current buffer is in `vc-dir' or Dired mode, FILESET is the
+list of marked files, or the file under point if no files are
+marked.
+Otherwise, if the current buffer is visiting a version-controlled
+file or is an indirect buffer whose base buffer visits a
+version-controlled file, FILESET is a single-file list containing
+that file's name.
Otherwise, if ALLOW-UNREGISTERED is non-nil and the visited file
-is unregistered, FILESET is a single-file fileset containing it.
+is unregistered, FILESET is a single-file list containing the
+name of the visited file.
Otherwise, throw an error.
-STATE-MODEL-ONLY-FILES if non-nil, means that the caller needs
-the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that
-part may be skipped.
+STATE-MODEL-ONLY-FILES, if non-nil, means that the caller needs
+the FILESET-ONLY-FILES, STATE, and CHECKOUT-MODEL info, where
+FILESET-ONLY-FILES means only files in similar VC states,
+possible values of STATE are explained in `vc-state', and MODEL in
+`vc-checkout-model'. Otherwise, these 3 members may be omitted from
+the returned list.
BEWARE: this function may change the current buffer."
- ;; FIXME: OBSERVER is unused. The name is not intuitive and is not
- ;; documented. It's set to t when called from diff and print-log.
+ (with-current-buffer (or (buffer-base-buffer) (current-buffer))
+ (vc-deduce-fileset-1 not-state-changing
+ allow-unregistered
+ state-model-only-files)))
+
+(defun vc-deduce-fileset-1 (not-state-changing
+ allow-unregistered
+ state-model-only-files)
(let (backend)
(cond
((derived-mode-p 'vc-dir-mode)
(vc-dir-deduce-fileset state-model-only-files))
((derived-mode-p 'dired-mode)
- (if observer
- (vc-dired-deduce-fileset)
- (error "State changing VC operations not supported in `dired-mode'")))
+ (dired-vc-deduce-fileset state-model-only-files not-state-changing))
((setq backend (vc-backend buffer-file-name))
(if state-model-only-files
(list backend (list buffer-file-name)
@@ -1046,15 +1092,14 @@ BEWARE: this function may change the current buffer."
;; FIXME: Why this test? --Stef
(or (buffer-file-name vc-parent-buffer)
(with-current-buffer vc-parent-buffer
- (derived-mode-p 'vc-dir-mode))))
+ (or (derived-mode-p 'vc-dir-mode)
+ (derived-mode-p 'dired-mode)))))
(progn ;FIXME: Why not `with-current-buffer'? --Stef.
(set-buffer vc-parent-buffer)
- (vc-deduce-fileset observer allow-unregistered state-model-only-files)))
- ((and (derived-mode-p 'log-view-mode)
+ (vc-deduce-fileset-1 not-state-changing allow-unregistered state-model-only-files)))
+ ((and (not buffer-file-name)
(setq backend (vc-responsible-backend default-directory)))
(list backend nil))
- ((not buffer-file-name)
- (error "Buffer %s is not associated with a file" (buffer-name)))
((and allow-unregistered (not (vc-registered buffer-file-name)))
(if state-model-only-files
(list (vc-backend-for-registration (buffer-file-name))
@@ -1066,10 +1111,6 @@ BEWARE: this function may change the current buffer."
(list buffer-file-name))))
(t (error "File is not under version control")))))
-(defun vc-dired-deduce-fileset ()
- (list (vc-responsible-backend default-directory)
- (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."
(cond
@@ -1328,8 +1369,6 @@ For old-style locking-based version control systems, like RCS:
nil t)))))
(vc-call-backend backend 'create-repo))
-(declare-function vc-dir-move-to-goal-column "vc-dir" ())
-
;;;###autoload
(defun vc-register (&optional vc-fileset comment)
"Register into a version control system.
@@ -1355,7 +1394,7 @@ first backend that could register the file is used."
(unless fname
(setq fname buffer-file-name))
(when (vc-call-backend backend 'registered fname)
- (error "This file is already registered"))
+ (error "This file is already registered: %s" fname))
;; Watch out for new buffers of size 0: the corresponding file
;; does not exist yet, even though buffer-modified-p is nil.
(when bname
@@ -1375,13 +1414,10 @@ first backend that could register the file is used."
;; the buffers visiting files affected by this `vc-register', not
;; in the current-buffer.
;; (unless vc-make-backup-files
- ;; (make-local-variable 'backup-inhibited)
- ;; (setq backup-inhibited t))
+ ;; (setq-local backup-inhibited t))
(vc-resynch-buffer file t t))
files)
- (when (derived-mode-p 'vc-dir-mode)
- (vc-dir-move-to-goal-column))
(message "Registering %s... done" files)))
(defun vc-register-with (backend)
@@ -1392,6 +1428,7 @@ first backend that could register the file is used."
(let ((vc-handled-backends (list backend)))
(call-interactively 'vc-register)))
+;;;###autoload
(defun vc-ignore (file &optional directory remove)
"Ignore FILE under the VCS of DIRECTORY.
@@ -1516,6 +1553,9 @@ After check-out, runs the normal hook `vc-checkout-hook'."
(vc-call-backend backend 'mark-resolved files)
;; FIXME: Is this TRTD? Might not be.
`((vc-state . edited)))
+ ;; Recompute mode lines.
+ (dolist (file files)
+ (vc-mode-line file backend))
(message
(substitute-command-keys
"Conflicts have been resolved in %s. \
@@ -1740,16 +1780,16 @@ Return t if the buffer had changes, nil otherwise."
;; Diff it against /dev/null.
(apply #'vc-do-command buffer
(if async 'async 1) "diff" file
- (append (vc-switches nil 'diff) '("/dev/null"))))))
+ (append (vc-switches nil 'diff) `(,(null-device)))))))
(setq files (nreverse filtered))))
(vc-call-backend (car vc-fileset) 'diff files rev1 rev2 buffer async)
(set-buffer buffer)
(diff-mode)
- (set (make-local-variable 'diff-vc-backend) (car vc-fileset))
- (set (make-local-variable 'diff-vc-revisions) (list rev1 rev2))
- (set (make-local-variable 'revert-buffer-function)
- (lambda (_ignore-auto _noconfirm)
- (vc-diff-internal async vc-fileset rev1 rev2 verbose)))
+ (setq-local diff-vc-backend (car vc-fileset))
+ (setq-local diff-vc-revisions (list rev1 rev2))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (vc-diff-internal async vc-fileset rev1 rev2 verbose)))
;; Make the *vc-diff* buffer read only, the diff-mode key
;; bindings are nicer for read only buffers. pcl-cvs does the
;; same thing.
@@ -1795,7 +1835,7 @@ Return t if the buffer had changes, nil otherwise."
(backend (car vc-fileset))
(first (car files))
(rev1-default nil)
- (rev2-default nil))
+ ) ;; (rev2-default nil)
(cond
;; someday we may be able to do revision completion on non-singleton
;; filesets, but not yet.
@@ -1819,9 +1859,10 @@ Return t if the buffer had changes, nil otherwise."
rev1-default "): ")
"Older revision: "))
(rev2-prompt (concat "Newer revision (default "
- (or rev2-default "current source") "): "))
+ ;; (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)))
+ (rev2 (vc-read-revision rev2-prompt files backend nil))) ;; rev2-default
(when (string= rev1 "") (setq rev1 nil))
(when (string= rev2 "") (setq rev2 nil))
(list files rev1 rev2))))
@@ -1869,6 +1910,10 @@ state of each file in the fileset."
t (list backend (list rootdir)) rev1 rev2
(called-interactively-p 'interactive)))))
+(defun vc-maybe-buffer-sync (not-urgent)
+ (with-current-buffer (or (buffer-base-buffer) (current-buffer))
+ (when buffer-file-name (vc-buffer-sync not-urgent))))
+
;;;###autoload
(defun vc-diff (&optional historic not-urgent)
"Display diffs between file revisions.
@@ -1881,9 +1926,17 @@ saving the buffer."
(interactive (list current-prefix-arg t))
(if historic
(call-interactively 'vc-version-diff)
- (when buffer-file-name (vc-buffer-sync not-urgent))
- (vc-diff-internal t (vc-deduce-fileset t) nil nil
- (called-interactively-p 'interactive))))
+ (vc-maybe-buffer-sync not-urgent)
+ (let ((fileset (vc-deduce-fileset t)))
+ (vc-buffer-sync-fileset fileset not-urgent)
+ (vc-diff-internal t fileset nil nil
+ (called-interactively-p 'interactive)))))
+
+(defun vc-buffer-sync-fileset (fileset not-urgent)
+ (dolist (filename (cadr fileset))
+ (when-let ((buffer (find-buffer-visiting filename)))
+ (with-current-buffer buffer
+ (vc-buffer-sync not-urgent)))))
;;;###autoload
(defun vc-diff-mergebase (_files rev1 rev2)
@@ -1960,7 +2013,7 @@ 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-maybe-buffer-sync not-urgent)
(vc-version-ediff (cadr (vc-deduce-fileset t)) nil nil)))
;;;###autoload
@@ -1977,7 +2030,7 @@ saving the buffer."
(if historic
;; We want the diff for the VC root dir.
(call-interactively 'vc-root-version-diff)
- (when buffer-file-name (vc-buffer-sync not-urgent))
+ (vc-maybe-buffer-sync not-urgent)
(let ((backend (vc-deduce-backend))
(default-directory default-directory)
rootdir working-revision)
@@ -2017,16 +2070,17 @@ Return nil if the root directory cannot be identified."
If the current file is named `F', the revision is named `F.~REV~'.
If `F.~REV~' already exists, use it instead of checking it out again."
(interactive
- (save-current-buffer
+ (with-current-buffer (or (buffer-base-buffer) (current-buffer))
(vc-ensure-vc-buffer)
(list
(vc-read-revision "Revision to visit (default is working revision): "
(list buffer-file-name)))))
+ (set-buffer (or (buffer-base-buffer) (current-buffer)))
(vc-ensure-vc-buffer)
(let* ((file buffer-file-name)
(revision (if (string-equal rev "")
- (vc-working-revision file)
- rev)))
+ (vc-working-revision file)
+ rev)))
(switch-to-buffer-other-window (vc-find-revision file revision))))
(defun vc-find-revision (file revision &optional backend)
@@ -2071,7 +2125,7 @@ Saves the buffer to the file."
(with-current-buffer result-buf
;; Set the parent buffer so that things like
;; C-x v g, C-x v l, ... etc work.
- (set (make-local-variable 'vc-parent-buffer) filebuf))
+ (setq-local vc-parent-buffer filebuf))
result-buf)))
(defun vc-find-revision-no-save (file revision &optional backend buffer)
@@ -2118,7 +2172,7 @@ Unlike `vc-find-revision-save', doesn't save the buffer to the file."
(get-file-buffer filename)
(find-file-noselect filename))))
(with-current-buffer result-buf
- (set (make-local-variable 'vc-parent-buffer) filebuf))
+ (setq-local vc-parent-buffer filebuf))
result-buf)))
;; Header-insertion code
@@ -2279,7 +2333,8 @@ checked out in that new branch."
;; to ask for a directory, branches are created at repository level.
default-directory
(read-directory-name "Directory: " default-directory default-directory t))
- (read-string (if current-prefix-arg "New branch name: " "New tag name: "))
+ (read-string (if current-prefix-arg "New branch name: " "New tag name: ")
+ nil 'vc-revision-history)
current-prefix-arg)))
(message "Making %s... " (if branchp "branch" "tag"))
(when (file-directory-p dir) (setq dir (file-name-as-directory dir)))
@@ -2339,11 +2394,13 @@ This function runs the hook `vc-retrieve-tag-hook' when finished."
;; for the root directory.
(defvar vc-log-short-style '(directory)
"Whether or not to show a short log.
-If it contains `directory' then if the fileset contains a directory show a short log.
-If it contains `file' then show short logs for files.
+If it contains `directory', show a short log if the fileset
+contains a directory.
+If it contains `file', show short logs for files.
Not all VC backends support short logs!")
(defvar log-view-vc-fileset)
+(defvar log-view-message-re)
(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return)
"Insert at the end of the current buffer buttons to show more log entries.
@@ -2353,21 +2410,32 @@ Does nothing if IS-START-REVISION is non-nil, or if LIMIT is nil,
or if PL-RETURN is `limit-unsupported'."
(when (and limit (not (eq 'limit-unsupported pl-return))
(not is-start-revision))
- (goto-char (point-max))
- (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")))
+ (let ((entries 0))
+ (goto-char (point-min))
+ (while (re-search-forward log-view-message-re nil t)
+ (cl-incf entries))
+ ;; If we got fewer entries than we asked for, then displaying
+ ;; the "more" buttons isn't useful.
+ (when (>= entries limit)
+ (goto-char (point-max))
+ (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")
+ (insert "\n")))))
(defun vc-print-log-internal (backend files working-revision
&optional is-start-revision limit type)
@@ -2419,7 +2487,7 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
rev-buff-func)
(let (retval (buffer (get-buffer-create buffer-name)))
(with-current-buffer buffer
- (set (make-local-variable 'vc-log-view-type) type))
+ (setq-local vc-log-view-type type))
(setq retval (funcall backend-func backend buffer-name type files))
(with-current-buffer buffer
(let ((inhibit-read-only t))
@@ -2431,10 +2499,9 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
backend 'region-history-mode))
'region-history-mode
'log-view-mode))
- (set (make-local-variable 'log-view-vc-backend) backend)
- (set (make-local-variable 'log-view-vc-fileset) files)
- (set (make-local-variable 'revert-buffer-function)
- rev-buff-func)))
+ (setq-local log-view-vc-backend backend)
+ (setq-local log-view-vc-fileset files)
+ (setq-local revert-buffer-function rev-buff-func)))
;; Display after setting up major-mode, so display-buffer-alist can know
;; the major-mode.
(pop-to-buffer buffer)
@@ -2502,11 +2569,8 @@ with its diffs (if the underlying VCS supports that)."
(cond
((eq current-prefix-arg 1)
(let* ((default (thing-at-point 'word t))
- (revision (read-string
- (if default
- (format "Revision to show (default %s): " default)
- "Revision to show: ")
- nil nil default)))
+ (revision (read-string (format-prompt "Revision to show" default)
+ nil nil default)))
(list 1 revision)))
((numberp current-prefix-arg)
(list current-prefix-arg))
@@ -2537,15 +2601,17 @@ with its diffs (if the underlying VCS supports that)."
;;;###autoload
(defun vc-print-branch-log (branch)
- "Show the change log for BRANCH in a window."
+ "Show the change log for BRANCH root in a window."
(interactive
(list
(vc-read-revision "Branch to log: ")))
(when (equal branch "")
(error "No branch specified"))
- (vc-print-log-internal (vc-responsible-backend default-directory)
- (list default-directory) branch t
- (when (> vc-log-show-limit 0) vc-log-show-limit)))
+ (let* ((backend (vc-responsible-backend default-directory))
+ (rootdir (vc-call-backend backend 'root default-directory)))
+ (vc-print-log-internal backend
+ (list rootdir) branch t
+ (when (> vc-log-show-limit 0) vc-log-show-limit))))
;;;###autoload
(defun vc-log-incoming (&optional remote-location)
@@ -2633,13 +2699,13 @@ mark."
(vc-call region-history file buf lfrom lto)
(with-current-buffer buf
(vc-call-backend backend 'region-history-mode)
- (set (make-local-variable 'log-view-vc-backend) backend)
- (set (make-local-variable 'log-view-vc-fileset) (list file))
- (set (make-local-variable 'revert-buffer-function)
- (lambda (_ignore-auto _noconfirm)
- (with-current-buffer buf
- (let ((inhibit-read-only t)) (erase-buffer)))
- (vc-call region-history file buf lfrom lto))))
+ (setq-local log-view-vc-backend backend)
+ (setq-local log-view-vc-fileset (list file))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (with-current-buffer buf
+ (let ((inhibit-read-only t)) (erase-buffer)))
+ (vc-call region-history file buf lfrom lto))))
(display-buffer buf)))
;;;###autoload
@@ -2690,9 +2756,6 @@ to the working revision (except for keyword expansion)."
(message "Reverting %s...done" (vc-delistify files)))))
;;;###autoload
-(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
-
-;;;###autoload
(defun vc-pull (&optional arg)
"Update the current fileset or branch.
You must be visiting a version controlled file, or in a `vc-dir' buffer.
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index baa7cbe3666..e219dc2d1a5 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -1,4 +1,4 @@
-;;; vcursor.el --- manipulate an alternative ("virtual") cursor
+;;; vcursor.el --- manipulate an alternative ("virtual") cursor -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 1996, 1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -27,34 +27,30 @@
;; Latest changes
;; ==============
;;
-;; - *IMPORTANT* vcursor-key-bindings is now nil by default, to avoid
+;; - *IMPORTANT* `vcursor-key-bindings' is now nil by default, to avoid
;; side-effects when the package is loaded. This means no keys are
;; bound by default. Use customize to change it to t to restore
;; the old behavior. (If you do it by hand in .emacs, it
;; must come before vcursor is loaded.)
;; - You can alter the main variables and the vcursor face via
;; M-x customize: go to the Editing group and find Vcursor.
-;; - vcursor-auto-disable can now be 'copy (actually any value not nil
+;; - `vcursor-auto-disable' can now be 'copy (actually any value not nil
;; or t), which means that copying from the vcursor will be turned
;; off after any operation not involving the vcursor, but the
;; vcursor itself will be left alone.
-;; - works on dumb terminals with Emacs 19.29 and later
+;; - works on dumb terminals
;; - new keymap vcursor-map for binding to a prefix key
-;; - vcursor-compare-windows substantially improved
-;; - vcursor-execute-{key,command} much better about using the
+;; - `vcursor-compare-windows' substantially improved
+;; - `vcursor-execute-{key,command}' much better about using the
;; right keymaps and arranging for the correct windows to be used
-;; - vcursor-window-funcall can call functions interactively
-;; - vcursor-interpret-input for special effects
+;; - `vcursor-window-funcall' can call functions interactively
+;; - `vcursor-interpret-input' for special effects
;;
;; Introduction
;; ============
;;
;; Virtual cursor commands. I got this idea from the old BBC micro.
-;; You need Emacs 19 or 20 and a window system for the best effects.
-;; For character terminals, at least Emacs 19.29 is required
-;; (special behavior for the overlay property
-;; "before-string" must be implemented). Search for "dumb terminals"
-;; for more information.
+;; You need a window system for the best effects.
;;
;; This is much easier to use than the instructions are to read.
;; First, you need to let vcursor define some keys: setting
@@ -330,21 +326,18 @@
(defface vcursor
'((((class color)) (:foreground "blue" :background "cyan" :underline t))
(t (:inverse-video t :underline t)))
- "Face for the virtual cursor."
- :group 'vcursor)
+ "Face for the virtual cursor.")
(defcustom vcursor-auto-disable nil
"If non-nil, disable the virtual cursor after use.
Any non-vcursor command will force `vcursor-disable' to be called.
If non-nil but not t, just make sure copying is toggled off, but don't
disable the vcursor."
- :type '(choice (const t) (const nil) (const copy))
- :group 'vcursor)
+ :type '(choice (const t) (const nil) (const copy)))
(defcustom vcursor-modifiers (list 'control 'shift)
"A list of modifiers that are used to define vcursor key bindings."
- :type '(repeat symbol)
- :group 'vcursor)
+ :type '(repeat symbol))
;; Needed for defcustom, must be up here
(defun vcursor-cs-binding (base &optional meta)
@@ -353,112 +346,114 @@ disable the vcursor."
(cons 'meta key)
key))))
+;; (defvar vcursor)
+
(defun vcursor-bind-keys (var value)
"Alter the value of the variable VAR to VALUE, binding keys as required.
VAR is usually `vcursor-key-bindings'. Normally this function is called
on loading vcursor and from the customize package."
(set var value)
(cond
- ((not value));; don't set any key bindings
+ ((not value)) ;; Don't set any key bindings.
((or (eq value 'oemacs)
(and (eq value t) (fboundp 'oemacs-version)))
- (global-set-key [C-f1] 'vcursor-toggle-copy)
- (global-set-key [C-f2] 'vcursor-copy)
- (global-set-key [C-f3] 'vcursor-copy-word)
- (global-set-key [C-f4] 'vcursor-copy-line)
-
- (global-set-key [S-f1] 'vcursor-disable)
- (global-set-key [S-f2] 'vcursor-other-window)
- (global-set-key [S-f3] 'vcursor-goto)
- (global-set-key [S-f4] 'vcursor-swap-point)
-
- (global-set-key [C-f5] 'vcursor-backward-char)
- (global-set-key [C-f6] 'vcursor-previous-line)
- (global-set-key [C-f7] 'vcursor-next-line)
- (global-set-key [C-f8] 'vcursor-forward-char)
-
- (global-set-key [M-f5] 'vcursor-beginning-of-line)
- (global-set-key [M-f6] 'vcursor-backward-word)
- (global-set-key [M-f6] 'vcursor-forward-word)
- (global-set-key [M-f8] 'vcursor-end-of-line)
-
- (global-set-key [S-f5] 'vcursor-beginning-of-buffer)
- (global-set-key [S-f6] 'vcursor-scroll-down)
- (global-set-key [S-f7] 'vcursor-scroll-up)
- (global-set-key [S-f8] 'vcursor-end-of-buffer)
-
- (global-set-key [C-f9] 'vcursor-isearch-forward)
-
- (global-set-key [S-f9] 'vcursor-execute-key)
- (global-set-key [S-f10] 'vcursor-execute-command)
-
-;;; Partial dictionary of Oemacs key sequences for you to roll your own,
-;;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line)
-;;; Sequence: Sends:
-;;; "\M-[\C-f\M-\C-m" C-S-up
-;;; "\M-[\C-f\M-\C-q" C-S-down
-;;; "\M-[\C-fs" C-S-left
-;;; "\M-[\C-ft" C-S-right
-;;;
-;;; "\M-[\C-fw" C-S-home
-;;; "\M-[\C-b\C-o" S-tab
-;;; "\M-[\C-f\M-\C-r" C-S-insert
-;;; "\M-[\C-fu" C-S-end
-;;; "\M-[\C-f\M-\C-s" C-S-delete
-;;; "\M-[\C-f\M-\C-d" C-S-prior
-;;; "\M-[\C-fv" C-S-next
-;;;
-;;; "\M-[\C-f^" C-S-f1
-;;; "\M-[\C-f_" C-S-f2
-;;; "\M-[\C-f`" C-S-f3
-;;; "\M-[\C-fa" C-S-f4
-;;; "\M-[\C-fb" C-S-f5
-;;; "\M-[\C-fc" C-S-f6
-;;; "\M-[\C-fd" C-S-f7
-;;; "\M-[\C-fe" C-S-f8
-;;; "\M-[\C-ff" C-S-f9
-;;; "\M-[\C-fg" C-S-f10
+ (global-set-key [C-f1] #'vcursor-toggle-copy)
+ (global-set-key [C-f2] #'vcursor-copy)
+ (global-set-key [C-f3] #'vcursor-copy-word)
+ (global-set-key [C-f4] #'vcursor-copy-line)
+
+ (global-set-key [S-f1] #'vcursor-disable)
+ (global-set-key [S-f2] #'vcursor-other-window)
+ (global-set-key [S-f3] #'vcursor-goto)
+ (global-set-key [S-f4] #'vcursor-swap-point)
+
+ (global-set-key [C-f5] #'vcursor-backward-char)
+ (global-set-key [C-f6] #'vcursor-previous-line)
+ (global-set-key [C-f7] #'vcursor-next-line)
+ (global-set-key [C-f8] #'vcursor-forward-char)
+
+ (global-set-key [M-f5] #'vcursor-beginning-of-line)
+ (global-set-key [M-f6] #'vcursor-backward-word)
+ (global-set-key [M-f6] #'vcursor-forward-word)
+ (global-set-key [M-f8] #'vcursor-end-of-line)
+
+ (global-set-key [S-f5] #'vcursor-beginning-of-buffer)
+ (global-set-key [S-f6] #'vcursor-scroll-down)
+ (global-set-key [S-f7] #'vcursor-scroll-up)
+ (global-set-key [S-f8] #'vcursor-end-of-buffer)
+
+ (global-set-key [C-f9] #'vcursor-isearch-forward)
+
+ (global-set-key [S-f9] #'vcursor-execute-key)
+ (global-set-key [S-f10] #'vcursor-execute-command)
+
+ ;; Partial dictionary of Oemacs key sequences for you to roll your own,
+ ;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line)
+ ;; Sequence: Sends:
+ ;; "\M-[\C-f\M-\C-m" C-S-up
+ ;; "\M-[\C-f\M-\C-q" C-S-down
+ ;; "\M-[\C-fs" C-S-left
+ ;; "\M-[\C-ft" C-S-right
+ ;;
+ ;; "\M-[\C-fw" C-S-home
+ ;; "\M-[\C-b\C-o" S-tab
+ ;; "\M-[\C-f\M-\C-r" C-S-insert
+ ;; "\M-[\C-fu" C-S-end
+ ;; "\M-[\C-f\M-\C-s" C-S-delete
+ ;; "\M-[\C-f\M-\C-d" C-S-prior
+ ;; "\M-[\C-fv" C-S-next
+ ;;
+ ;; "\M-[\C-f^" C-S-f1
+ ;; "\M-[\C-f_" C-S-f2
+ ;; "\M-[\C-f`" C-S-f3
+ ;; "\M-[\C-fa" C-S-f4
+ ;; "\M-[\C-fb" C-S-f5
+ ;; "\M-[\C-fc" C-S-f6
+ ;; "\M-[\C-fd" C-S-f7
+ ;; "\M-[\C-fe" C-S-f8
+ ;; "\M-[\C-ff" C-S-f9
+ ;; "\M-[\C-fg" C-S-f10
)
(t
- (global-set-key (vcursor-cs-binding "up") 'vcursor-previous-line)
- (global-set-key (vcursor-cs-binding "down") 'vcursor-next-line)
- (global-set-key (vcursor-cs-binding "left") 'vcursor-backward-char)
- (global-set-key (vcursor-cs-binding "right") 'vcursor-forward-char)
-
- (global-set-key (vcursor-cs-binding "return") 'vcursor-disable)
- (global-set-key (vcursor-cs-binding "insert") 'vcursor-copy)
- (global-set-key (vcursor-cs-binding "delete") 'vcursor-copy-word)
- (global-set-key (vcursor-cs-binding "remove") 'vcursor-copy-word)
- (global-set-key (vcursor-cs-binding "tab") 'vcursor-toggle-copy)
- (global-set-key (vcursor-cs-binding "backtab") 'vcursor-toggle-copy)
- (global-set-key (vcursor-cs-binding "home") 'vcursor-beginning-of-buffer)
- (global-set-key (vcursor-cs-binding "up" t) 'vcursor-beginning-of-buffer)
- (global-set-key (vcursor-cs-binding "end") 'vcursor-end-of-buffer)
- (global-set-key (vcursor-cs-binding "down" t) 'vcursor-end-of-buffer)
- (global-set-key (vcursor-cs-binding "prior") 'vcursor-scroll-down)
- (global-set-key (vcursor-cs-binding "next") 'vcursor-scroll-up)
-
- (global-set-key (vcursor-cs-binding "f6") 'vcursor-other-window)
- (global-set-key (vcursor-cs-binding "f7") 'vcursor-goto)
+ (global-set-key (vcursor-cs-binding "up") #'vcursor-previous-line)
+ (global-set-key (vcursor-cs-binding "down") #'vcursor-next-line)
+ (global-set-key (vcursor-cs-binding "left") #'vcursor-backward-char)
+ (global-set-key (vcursor-cs-binding "right") #'vcursor-forward-char)
+
+ (global-set-key (vcursor-cs-binding "return") #'vcursor-disable)
+ (global-set-key (vcursor-cs-binding "insert") #'vcursor-copy)
+ (global-set-key (vcursor-cs-binding "delete") #'vcursor-copy-word)
+ (global-set-key (vcursor-cs-binding "remove") #'vcursor-copy-word)
+ (global-set-key (vcursor-cs-binding "tab") #'vcursor-toggle-copy)
+ (global-set-key (vcursor-cs-binding "backtab") #'vcursor-toggle-copy)
+ (global-set-key (vcursor-cs-binding "home") #'vcursor-beginning-of-buffer)
+ (global-set-key (vcursor-cs-binding "up" t) #'vcursor-beginning-of-buffer)
+ (global-set-key (vcursor-cs-binding "end") #'vcursor-end-of-buffer)
+ (global-set-key (vcursor-cs-binding "down" t) #'vcursor-end-of-buffer)
+ (global-set-key (vcursor-cs-binding "prior") #'vcursor-scroll-down)
+ (global-set-key (vcursor-cs-binding "next") #'vcursor-scroll-up)
+
+ (global-set-key (vcursor-cs-binding "f6") #'vcursor-other-window)
+ (global-set-key (vcursor-cs-binding "f7") #'vcursor-goto)
(global-set-key (vcursor-cs-binding "select")
- 'vcursor-swap-point) ; DEC keyboards
- (global-set-key (vcursor-cs-binding "tab" t) 'vcursor-swap-point)
+ #'vcursor-swap-point) ; DEC keyboards
+ (global-set-key (vcursor-cs-binding "tab" t) #'vcursor-swap-point)
(global-set-key (vcursor-cs-binding "find")
- 'vcursor-isearch-forward) ; DEC keyboards
- (global-set-key (vcursor-cs-binding "f8") 'vcursor-isearch-forward)
+ #'vcursor-isearch-forward) ; DEC keyboards
+ (global-set-key (vcursor-cs-binding "f8") #'vcursor-isearch-forward)
- (global-set-key (vcursor-cs-binding "left" t) 'vcursor-beginning-of-line)
- (global-set-key (vcursor-cs-binding "right" t) 'vcursor-end-of-line)
+ (global-set-key (vcursor-cs-binding "left" t) #'vcursor-beginning-of-line)
+ (global-set-key (vcursor-cs-binding "right" t) #'vcursor-end-of-line)
- (global-set-key (vcursor-cs-binding "prior" t) 'vcursor-backward-word)
- (global-set-key (vcursor-cs-binding "next" t) 'vcursor-forward-word)
+ (global-set-key (vcursor-cs-binding "prior" t) #'vcursor-backward-word)
+ (global-set-key (vcursor-cs-binding "next" t) #'vcursor-forward-word)
- (global-set-key (vcursor-cs-binding "return" t) 'vcursor-copy-line)
+ (global-set-key (vcursor-cs-binding "return" t) #'vcursor-copy-line)
- (global-set-key (vcursor-cs-binding "f9") 'vcursor-execute-key)
- (global-set-key (vcursor-cs-binding "f10") 'vcursor-execute-command)
+ (global-set-key (vcursor-cs-binding "f9") #'vcursor-execute-key)
+ (global-set-key (vcursor-cs-binding "f10") #'vcursor-execute-command)
)))
(defcustom vcursor-key-bindings nil
@@ -469,8 +464,7 @@ define any key bindings.
Default is nil."
:type '(choice (const t) (const nil) (const xterm) (const oemacs))
- :group 'vcursor
- :set 'vcursor-bind-keys
+ :set #'vcursor-bind-keys
:version "20.3")
(defcustom vcursor-interpret-input nil
@@ -479,13 +473,11 @@ This will cause text insertion to be much slower. Note that no special
interpretation of strings is done: \"\C-x\" is a string of four
characters. The default is simply to copy strings."
:type 'boolean
- :group 'vcursor
:version "20.3")
(defcustom vcursor-string "**>"
"String used to show the vcursor position on dumb terminals."
:type 'string
- :group 'vcursor
:version "20.3")
(defvar vcursor-overlay nil
@@ -505,42 +497,41 @@ scrolling set this. It is used by the `vcursor-auto-disable' code.")
(defcustom vcursor-copy-flag nil
"Non-nil means moving vcursor should copy characters moved over to point."
- :type 'boolean
- :group 'vcursor)
+ :type 'boolean)
(defvar vcursor-temp-goal-column nil
"Keeps track of temporary goal columns for the virtual cursor.")
(defvar vcursor-map
(let ((map (make-sparse-keymap)))
- (define-key map "t" 'vcursor-use-vcursor-map)
-
- (define-key map "\C-p" 'vcursor-previous-line)
- (define-key map "\C-n" 'vcursor-next-line)
- (define-key map "\C-b" 'vcursor-backward-char)
- (define-key map "\C-f" 'vcursor-forward-char)
-
- (define-key map "\r" 'vcursor-disable)
- (define-key map " " 'vcursor-copy)
- (define-key map "\C-y" 'vcursor-copy-word)
- (define-key map "\C-i" 'vcursor-toggle-copy)
- (define-key map "<" 'vcursor-beginning-of-buffer)
- (define-key map ">" 'vcursor-end-of-buffer)
- (define-key map "\M-v" 'vcursor-scroll-down)
- (define-key map "\C-v" 'vcursor-scroll-up)
- (define-key map "o" 'vcursor-other-window)
- (define-key map "g" 'vcursor-goto)
- (define-key map "x" 'vcursor-swap-point)
- (define-key map "\C-s" 'vcursor-isearch-forward)
- (define-key map "\C-r" 'vcursor-isearch-backward)
- (define-key map "\C-a" 'vcursor-beginning-of-line)
- (define-key map "\C-e" 'vcursor-end-of-line)
- (define-key map "\M-w" 'vcursor-forward-word)
- (define-key map "\M-b" 'vcursor-backward-word)
- (define-key map "\M-l" 'vcursor-copy-line)
- (define-key map "c" 'vcursor-compare-windows)
- (define-key map "k" 'vcursor-execute-key)
- (define-key map "\M-x" 'vcursor-execute-command)
+ (define-key map "t" #'vcursor-use-vcursor-map)
+
+ (define-key map "\C-p" #'vcursor-previous-line)
+ (define-key map "\C-n" #'vcursor-next-line)
+ (define-key map "\C-b" #'vcursor-backward-char)
+ (define-key map "\C-f" #'vcursor-forward-char)
+
+ (define-key map "\r" #'vcursor-disable)
+ (define-key map " " #'vcursor-copy)
+ (define-key map "\C-y" #'vcursor-copy-word)
+ (define-key map "\C-i" #'vcursor-toggle-copy)
+ (define-key map "<" #'vcursor-beginning-of-buffer)
+ (define-key map ">" #'vcursor-end-of-buffer)
+ (define-key map "\M-v" #'vcursor-scroll-down)
+ (define-key map "\C-v" #'vcursor-scroll-up)
+ (define-key map "o" #'vcursor-other-window)
+ (define-key map "g" #'vcursor-goto)
+ (define-key map "x" #'vcursor-swap-point)
+ (define-key map "\C-s" #'vcursor-isearch-forward)
+ (define-key map "\C-r" #'vcursor-isearch-backward)
+ (define-key map "\C-a" #'vcursor-beginning-of-line)
+ (define-key map "\C-e" #'vcursor-end-of-line)
+ (define-key map "\M-w" #'vcursor-forward-word)
+ (define-key map "\M-b" #'vcursor-backward-word)
+ (define-key map "\M-l" #'vcursor-copy-line)
+ (define-key map "c" #'vcursor-compare-windows)
+ (define-key map "k" #'vcursor-execute-key)
+ (define-key map "\M-x" #'vcursor-execute-command)
map)
"Keymap for vcursor command.")
;; This seems unused, but it was done as part of define-prefix-command,
@@ -602,21 +593,21 @@ Set `vcursor-window' to the returned value as a side effect."
(pos-visible-in-window-p (point) vcursor-window))
(progn
(walk-windows
- (function
- (lambda (win)
- (and (not winok)
- (eq (current-buffer) (window-buffer win))
- (not (and not-this (eq thiswin win)))
- (cond
- ((pos-visible-in-window-p (point) win) (setq winok win))
- ((eq thiswin win))
- ((not winbuf) (setq winbuf win))))))
+ (lambda (win)
+ (and (not winok)
+ (eq (current-buffer) (window-buffer win))
+ (not (and not-this (eq thiswin win)))
+ (cond
+ ((pos-visible-in-window-p (point) win) (setq winok win))
+ ((eq thiswin win))
+ ((not winbuf) (setq winbuf win)))))
nil (not this-frame))
(setq vcursor-window
(cond
(winok) ; choice 2
((and vcursor-window ; choice 3
- (not (eq thiswin vcursor-window))) vcursor-window)
+ (not (eq thiswin vcursor-window)))
+ vcursor-window)
(winbuf) ; choice 4
(new-win (display-buffer (current-buffer) t)) ; choice 5
(t nil))))))) ; default (choice 6)
@@ -724,16 +715,14 @@ not be visible otherwise, display it in another window."
The vcursor will always appear in an unselected window."
(interactive "P")
- (vcursor-window-funcall 'scroll-up n)
-)
+ (vcursor-window-funcall #'scroll-up n))
(defun vcursor-scroll-down (&optional n)
"Scroll down the vcursor window ARG lines or near full screen if none.
The vcursor will always appear in an unselected window."
(interactive "P")
- (vcursor-window-funcall 'scroll-down n)
- )
+ (vcursor-window-funcall #'scroll-down n))
(defun vcursor-isearch-forward (&optional rep norecurs)
"Perform forward incremental search in the virtual cursor window.
@@ -741,7 +730,7 @@ The virtual cursor is moved to the resulting point; the ordinary
cursor stays where it was."
(interactive "P")
- (vcursor-window-funcall 'isearch-forward rep norecurs)
+ (vcursor-window-funcall #'isearch-forward rep norecurs)
)
(defun vcursor-isearch-backward (&optional rep norecurs)
@@ -750,7 +739,7 @@ The virtual cursor is moved to the resulting point; the ordinary
cursor stays where it was."
(interactive "P")
- (vcursor-window-funcall 'isearch-backward rep norecurs)
+ (vcursor-window-funcall #'isearch-backward rep norecurs)
)
(defun vcursor-window-funcall (func &rest args)
@@ -896,7 +885,7 @@ A prefix argument, if any, means ignore changes in whitespace.
The variable `compare-windows-whitespace' controls how whitespace is skipped.
If `compare-ignore-case' is non-nil, changes in case are also ignored."
(interactive "P")
- ;; (vcursor-window-funcall 'compare-windows arg)
+ ;; (vcursor-window-funcall #'compare-windows arg)
(require 'compare-w)
(let* (p1 p2 maxp1 maxp2 b1 b2 w2
success
@@ -1010,32 +999,32 @@ If `compare-ignore-case' is non-nil, changes in case are also ignored."
(defun vcursor-forward-char (arg)
"Move the virtual cursor forward ARG characters."
(interactive "p")
- (vcursor-relative-move 'forward-char arg)
+ (vcursor-relative-move #'forward-char arg)
)
(defun vcursor-backward-char (arg)
"Move the virtual cursor backward ARG characters."
(interactive "p")
- (vcursor-relative-move 'backward-char arg)
+ (vcursor-relative-move #'backward-char arg)
)
(defun vcursor-forward-word (arg)
"Move the virtual cursor forward ARG words."
(interactive "p")
- (vcursor-relative-move 'forward-word arg)
+ (vcursor-relative-move #'forward-word arg)
)
(defun vcursor-backward-word (arg)
"Move the virtual cursor backward ARG words."
(interactive "p")
- (vcursor-relative-move 'backward-word arg)
+ (vcursor-relative-move #'backward-word arg)
)
(defun vcursor-beginning-of-line (arg)
"Move the virtual cursor to beginning of its current line.
ARG is as for `beginning-of-line'."
(interactive "P")
- (vcursor-relative-move 'beginning-of-line
+ (vcursor-relative-move #'beginning-of-line
(if arg (prefix-numeric-value arg)))
)
@@ -1043,7 +1032,7 @@ ARG is as for `beginning-of-line'."
"Move the virtual cursor to end of its current line.
ARG is as for `end-of-line'."
(interactive "P")
- (vcursor-relative-move 'end-of-line
+ (vcursor-relative-move #'end-of-line
(if arg (prefix-numeric-value arg)))
)
@@ -1115,7 +1104,7 @@ is called interactively, so prefix argument etc. are usable."
(defun vcursor-copy-word (arg)
"Copy ARG words from the virtual cursor position to point."
(interactive "p")
- (vcursor-copy (vcursor-get-char-count 'forward-word arg))
+ (vcursor-copy (vcursor-get-char-count #'forward-word arg))
)
(defun vcursor-copy-line (arg)
@@ -1128,13 +1117,10 @@ line is treated like ordinary characters."
(interactive "P")
(let* ((num (prefix-numeric-value arg))
- (count (vcursor-get-char-count 'end-of-line num)))
+ (count (vcursor-get-char-count #'end-of-line num)))
(vcursor-copy (if (or (= count 0) arg) (1+ count) count)))
)
-(define-obsolete-function-alias
- 'vcursor-toggle-vcursor-map 'vcursor-use-vcursor-map "23.1")
-
(defun vcursor-post-command ()
(and vcursor-auto-disable (not vcursor-last-command)
vcursor-overlay
@@ -1144,7 +1130,7 @@ line is treated like ordinary characters."
(setq vcursor-last-command nil)
)
-(add-hook 'post-command-hook 'vcursor-post-command)
+(add-hook 'post-command-hook #'vcursor-post-command)
(provide 'vcursor)
diff --git a/lisp/version.el b/lisp/version.el
index 8be77cbf014..3a3093fdd4a 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -1,4 +1,4 @@
-;;; version.el --- record version number of Emacs
+;;; version.el --- record version number of Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985, 1992, 1994-1995, 1999-2021 Free Software
;; Foundation, Inc.
@@ -29,14 +29,12 @@
(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.")
+ "Major version number of this version of Emacs.")
(defconst emacs-minor-version
(progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
(string-to-number (match-string 1 emacs-version)))
- "Minor version number of this version of Emacs.
-This variable first existed in version 19.23.")
+ "Minor version number of this version of Emacs.")
(defconst emacs-build-system (system-name)
"Name of the system on which Emacs was built, or nil if not available.")
@@ -123,7 +121,7 @@ or if we could not determine the revision.")
(looking-at "[[:xdigit:]]\\{40\\}"))
(match-string 0)))))
-(defun emacs-repository-get-version (&optional dir external)
+(defun emacs-repository-get-version (&optional dir _external)
"Try to return as a string the repository revision of the Emacs sources.
The format of the returned string is dependent on the VCS in use.
Value is nil if the sources do not seem to be under version
diff --git a/lisp/view.el b/lisp/view.el
index 2c48bac1ca7..3476ced3f79 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -1,4 +1,4 @@
-;;; view.el --- peruse file or buffer without editing
+;;; view.el --- peruse file or buffer without editing -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1989, 1994-1995, 1997, 2000-2021 Free Software
;; Foundation, Inc.
@@ -26,9 +26,9 @@
;; This package provides the `view' minor mode documented in the Emacs
;; user's manual.
-;; View mode entry and exit is done through the functions view-mode-enter
-;; and view-mode-exit. Use these functions to enter or exit view-mode from
-;; emacs lisp programs.
+;; View mode entry and exit is done through the functions `view-mode-enter'
+;; and `view-mode-exit'. Use these functions to enter or exit `view-mode' from
+;; Emacs Lisp programs.
;; We use both view- and View- as prefix for symbols. View- is used as
;; prefix for commands that have a key binding. view- is used for commands
;; without key binding. The purpose of this is to make it easier for a
@@ -36,11 +36,11 @@
;;; Suggested key bindings:
;;
-;; (define-key ctl-x-4-map "v" 'view-file-other-window) ; ^x4v
-;; (define-key ctl-x-5-map "v" 'view-file-other-frame) ; ^x5v
+;; (define-key ctl-x-4-map "v" #'view-file-other-window) ; ^x4v
+;; (define-key ctl-x-5-map "v" #'view-file-other-frame) ; ^x5v
;;
-;; You could also bind view-file, view-buffer, view-buffer-other-window and
-;; view-buffer-other-frame to keys.
+;; You could also bind `view-file', `view-buffer', `view-buffer-other-window' and
+;; `view-buffer-other-frame' to keys.
;;; Code:
@@ -51,31 +51,27 @@
:group 'text)
(defcustom view-highlight-face 'highlight
- "The face used for highlighting the match found by View mode search."
- :type 'face
- :group 'view)
+ "The face used for highlighting the match found by View mode search."
+ :type 'face)
(defcustom view-scroll-auto-exit nil
"Non-nil means scrolling past the end of buffer exits View mode.
A value of nil means attempting to scroll past the end of the buffer,
only rings the bell and gives a message on how to leave."
- :type 'boolean
- :group 'view)
+ :type 'boolean)
(defcustom view-try-extend-at-buffer-end nil
"Non-nil means try to load more of file when reaching end of buffer.
This variable is mainly intended to be temporarily set to non-nil by
-the F command in view-mode, but you can set it to t if you want the action
+the F command in `view-mode', but you can set it to t if you want the action
for all scroll commands in view mode."
- :type 'boolean
- :group 'view)
+ :type 'boolean)
;;;###autoload
(defcustom view-remove-frame-by-deleting t
"Determine how View mode removes a frame no longer needed.
If nil, make an icon of the frame. If non-nil, delete the frame."
:type 'boolean
- :group 'view
:version "23.1")
(defcustom view-exits-all-viewing-windows nil
@@ -84,48 +80,40 @@ Commands that restore windows when finished viewing a buffer,
apply to all windows that display the buffer and have restore
information. If `view-exits-all-viewing-windows' is nil, only
the selected window is considered for restoring."
- :type 'boolean
- :group 'view)
+ :type 'boolean)
(defcustom view-inhibit-help-message nil
- "Non-nil inhibits the help message shown upon entering View mode."
+ "Non-nil inhibits the help message shown upon entering View mode.
+This setting takes effect only when View mode is entered via an
+interactive command; otherwise the help message is not shown."
:type 'boolean
- :group 'view
:version "22.1")
;;;###autoload
-(defvar view-mode nil
+(defvar-local view-mode nil
"Non-nil if View mode is enabled.
Don't change this variable directly, you must change it by one of the
functions that enable or disable view mode.")
-;;;###autoload
-(make-variable-buffer-local 'view-mode)
(defcustom view-mode-hook nil
"Normal hook run when starting to view a buffer or file."
- :type 'hook
- :group 'view)
+ :type 'hook)
-(defvar view-old-buffer-read-only nil)
-(make-variable-buffer-local 'view-old-buffer-read-only)
+(defvar-local view-old-buffer-read-only nil)
-(defvar view-old-Helper-return-blurb)
-(make-variable-buffer-local 'view-old-Helper-return-blurb)
+(defvar-local view-old-Helper-return-blurb nil)
-(defvar view-page-size nil
+(defvar-local view-page-size nil
"Default number of lines to scroll by View page commands.
If nil that means use the window size.")
-(make-variable-buffer-local 'view-page-size)
-(defvar view-half-page-size nil
+(defvar-local view-half-page-size nil
"Default number of lines to scroll by View half page commands.
If nil that means use half the window size.")
-(make-variable-buffer-local 'view-half-page-size)
-(defvar view-last-regexp nil)
-(make-variable-buffer-local 'view-last-regexp) ; Global is better???
+(defvar-local view-last-regexp nil) ; Global is better???
-(defvar view-return-to-alist nil
+(defvar-local view-return-to-alist nil
"What to do with used windows and where to go when finished viewing buffer.
This is local in each buffer being viewed.
It is added to by `view-mode-enter' when starting to view a buffer and
@@ -134,17 +122,16 @@ subtracted from by `view-mode-exit' when finished viewing the buffer.
See RETURN-TO-ALIST argument of function `view-mode-exit' for the format of
`view-return-to-alist'.")
(make-obsolete-variable
- 'view-return-to-alist "this variable is no more used." "24.1")
-(make-variable-buffer-local 'view-return-to-alist)
+ 'view-return-to-alist "this variable is no longer used." "24.1")
(put 'view-return-to-alist 'permanent-local t)
-(defvar view-exit-action nil
- "If non-nil, a function with one argument (a buffer) called when finished viewing.
+(defvar-local view-exit-action nil
+ "If non-nil, a function called when finished viewing.
+The function should take one argument (a buffer).
Commands like \\[view-file] and \\[view-file-other-window] may
set this to bury or kill the viewed buffer.
Observe that the buffer viewed might not appear in any window at
the time this function is called.")
-(make-variable-buffer-local 'view-exit-action)
(defvar view-no-disable-on-exit nil
"If non-nil, View mode \"exit\" commands don't actually disable View mode.
@@ -152,71 +139,70 @@ Instead, these commands just switch buffers or windows.
This is set in certain buffers by specialized features such as help commands
that use View mode automatically.")
-(defvar view-overlay nil
+(defvar-local view-overlay nil
"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)
;; Define keymap inside defvar to make it easier to load changes.
;; Some redundant "less"-like key bindings below have been commented out.
(defvar view-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "C" 'View-kill-and-leave)
- (define-key map "c" 'View-leave)
- (define-key map "Q" 'View-quit-all)
- (define-key map "E" 'View-exit-and-edit)
- ;; (define-key map "v" 'View-exit)
- (define-key map "e" 'View-exit)
- (define-key map "q" 'View-quit)
- ;; (define-key map "N" 'View-search-last-regexp-backward)
- (define-key map "p" 'View-search-last-regexp-backward)
- (define-key map "n" 'View-search-last-regexp-forward)
- ;; (define-key map "?" 'View-search-regexp-backward) ; Less does this.
- (define-key map "\\" 'View-search-regexp-backward)
- (define-key map "/" 'View-search-regexp-forward)
- (define-key map "r" 'isearch-backward)
- (define-key map "s" 'isearch-forward)
- (define-key map "m" 'point-to-register)
- (define-key map "'" 'register-to-point)
- (define-key map "x" 'exchange-point-and-mark)
- (define-key map "@" 'View-back-to-mark)
- (define-key map "." 'set-mark-command)
- (define-key map "%" 'View-goto-percent)
- ;; (define-key map "G" 'View-goto-line-last)
- (define-key map "g" 'View-goto-line)
- (define-key map "=" 'what-line)
- (define-key map "F" 'View-revert-buffer-scroll-page-forward)
- ;; (define-key map "k" 'View-scroll-line-backward)
- (define-key map "y" 'View-scroll-line-backward)
- ;; (define-key map "j" 'View-scroll-line-forward)
- (define-key map "\n" 'View-scroll-line-forward)
- (define-key map "\r" 'View-scroll-line-forward)
- (define-key map "u" 'View-scroll-half-page-backward)
- (define-key map "d" 'View-scroll-half-page-forward)
- (define-key map "z" 'View-scroll-page-forward-set-page-size)
- (define-key map "w" 'View-scroll-page-backward-set-page-size)
- ;; (define-key map "b" 'View-scroll-page-backward)
- (define-key map "\C-?" 'View-scroll-page-backward)
- ;; (define-key map "f" 'View-scroll-page-forward)
- (define-key map " " 'View-scroll-page-forward)
- (define-key map [?\S-\ ] 'View-scroll-page-backward)
- (define-key map "o" 'View-scroll-to-buffer-end)
- (define-key map ">" 'end-of-buffer)
- (define-key map "<" 'beginning-of-buffer)
- (define-key map "-" 'negative-argument)
- (define-key map "9" 'digit-argument)
- (define-key map "8" 'digit-argument)
- (define-key map "7" 'digit-argument)
- (define-key map "6" 'digit-argument)
- (define-key map "5" 'digit-argument)
- (define-key map "4" 'digit-argument)
- (define-key map "3" 'digit-argument)
- (define-key map "2" 'digit-argument)
- (define-key map "1" 'digit-argument)
- (define-key map "0" 'digit-argument)
- (define-key map "H" 'describe-mode)
- (define-key map "?" 'describe-mode) ; Maybe do as less instead? See above.
- (define-key map "h" 'describe-mode)
+ (define-key map "C" #'View-kill-and-leave)
+ (define-key map "c" #'View-leave)
+ (define-key map "Q" #'View-quit-all)
+ (define-key map "E" #'View-exit-and-edit)
+ ;; (define-key map "v" #'View-exit)
+ (define-key map "e" #'View-exit)
+ (define-key map "q" #'View-quit)
+ ;; (define-key map "N" #'View-search-last-regexp-backward)
+ (define-key map "p" #'View-search-last-regexp-backward)
+ (define-key map "n" #'View-search-last-regexp-forward)
+ ;; (define-key map "?" #'View-search-regexp-backward) ; Less does this.
+ (define-key map "\\" #'View-search-regexp-backward)
+ (define-key map "/" #'View-search-regexp-forward)
+ (define-key map "r" #'isearch-backward)
+ (define-key map "s" #'isearch-forward)
+ (define-key map "m" #'point-to-register)
+ (define-key map "'" #'register-to-point)
+ (define-key map "x" #'exchange-point-and-mark)
+ (define-key map "@" #'View-back-to-mark)
+ (define-key map "." #'set-mark-command)
+ (define-key map "%" #'View-goto-percent)
+ ;; (define-key map "G" #'View-goto-line-last)
+ (define-key map "g" #'View-goto-line)
+ (define-key map "=" #'what-line)
+ (define-key map "F" #'View-revert-buffer-scroll-page-forward)
+ ;; (define-key map "k" #'View-scroll-line-backward)
+ (define-key map "y" #'View-scroll-line-backward)
+ ;; (define-key map "j" #'View-scroll-line-forward)
+ (define-key map "\n" #'View-scroll-line-forward)
+ (define-key map "\r" #'View-scroll-line-forward)
+ (define-key map "u" #'View-scroll-half-page-backward)
+ (define-key map "d" #'View-scroll-half-page-forward)
+ (define-key map "z" #'View-scroll-page-forward-set-page-size)
+ (define-key map "w" #'View-scroll-page-backward-set-page-size)
+ ;; (define-key map "b" #'View-scroll-page-backward)
+ (define-key map "\C-?" #'View-scroll-page-backward)
+ ;; (define-key map "f" #'View-scroll-page-forward)
+ (define-key map " " #'View-scroll-page-forward)
+ (define-key map [?\S-\ ] #'View-scroll-page-backward)
+ (define-key map "o" #'View-scroll-to-buffer-end)
+ (define-key map ">" #'end-of-buffer)
+ (define-key map "<" #'beginning-of-buffer)
+ (define-key map "-" #'negative-argument)
+ (define-key map "9" #'digit-argument)
+ (define-key map "8" #'digit-argument)
+ (define-key map "7" #'digit-argument)
+ (define-key map "6" #'digit-argument)
+ (define-key map "5" #'digit-argument)
+ (define-key map "4" #'digit-argument)
+ (define-key map "3" #'digit-argument)
+ (define-key map "2" #'digit-argument)
+ (define-key map "1" #'digit-argument)
+ (define-key map "0" #'digit-argument)
+ (define-key map "H" #'describe-mode)
+ (define-key map "?" #'describe-mode) ; Maybe do as less instead? See above.
+ (define-key map "h" #'describe-mode)
map))
;;; Commands that enter or exit view mode.
@@ -227,7 +213,7 @@ This is local in each buffer, once it is used.")
;; types C-x C-q again to return to view mode.
;;;###autoload
(defun kill-buffer-if-not-modified (buf)
- "Like `kill-buffer', but does nothing if the buffer is modified."
+ "Like `kill-buffer', but does nothing if buffer BUF is modified."
(let ((buf (get-buffer buf)))
(and buf (not (buffer-modified-p buf))
(kill-buffer buf))))
@@ -312,7 +298,7 @@ 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.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings."
(interactive "bView buffer: ")
@@ -338,7 +324,7 @@ Optional argument EXIT-ACTION is either nil or a function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings."
(interactive "bIn other window view buffer:\nP")
@@ -365,7 +351,7 @@ Optional argument EXIT-ACTION is either nil or a function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings."
(interactive "bView buffer in other frame: \nP")
@@ -559,7 +545,10 @@ This function runs the normal hook `view-mode-hook'."
(unless view-mode
(view-mode 1)
- (unless view-inhibit-help-message
+ (when (and (not view-inhibit-help-message)
+ ;; Avoid spamming the echo area if `view-mode' is entered
+ ;; non-interactively, e.g., in a temporary buffer (bug#44629).
+ this-command)
(message "%s"
(substitute-command-keys "\
View mode: type \\[help-command] for help, \\[describe-mode] for commands, \\[View-quit] to quit.")))))
@@ -666,8 +655,8 @@ previous state and go to previous buffer or window."
(recenter '(1)))
(defun view-page-size-default (lines)
- ;; If LINES is nil, 0, or larger than `view-window-size', return nil.
- ;; Otherwise, return LINES.
+ "If LINES is nil, 0, or larger than `view-window-size', return nil.
+Otherwise, return LINES."
(and lines
(not (zerop (setq lines (prefix-numeric-value lines))))
(<= (abs lines)
@@ -675,7 +664,7 @@ previous state and go to previous buffer or window."
(abs lines)))
(defun view-set-half-page-size-default (lines)
- ;; Get and maybe set half page size.
+ "Get and maybe set half page size."
(if (not lines) (or view-half-page-size
(/ (view-window-size) 2))
(setq view-half-page-size
@@ -753,7 +742,7 @@ invocations return to earlier marks."
(if (view-really-at-end) (view-end-message)))))
(defun view-really-at-end ()
- ;; Return true if buffer end visible. Maybe revert buffer and test.
+ "Return non-nil if buffer end visible. Maybe revert buffer and test."
(and (or (null scroll-error-top-bottom) (eobp))
(pos-visible-in-window-p (point-max))
(let ((buf (current-buffer))
@@ -776,7 +765,7 @@ invocations return to earlier marks."
(pos-visible-in-window-p (point-max)))))))
(defun view-end-message ()
- ;; Tell that we are at end of buffer.
+ "Tell that we are at end of buffer."
(goto-char (point-max))
(if (window-parameter nil 'quit-restore)
(message "End of buffer. Type %s to quit viewing."
@@ -983,7 +972,7 @@ for highlighting the match that is found."
;; https://lists.gnu.org/r/bug-gnu-emacs/2007-09/msg00073.html
(defun view-search-no-match-lines (times regexp)
"Search for the TIMESth occurrence of a line with no match for REGEXP.
-If such a line is found, return non-nil and set the match-data to that line.
+If such a line is found, return non-nil and set the match data to that line.
If TIMES is negative, search backwards."
(let ((step (if (>= times 0) 1
(setq times (- times))
diff --git a/lisp/vt-control.el b/lisp/vt-control.el
index e48f03c9b59..bac0069b852 100644
--- a/lisp/vt-control.el
+++ b/lisp/vt-control.el
@@ -1,4 +1,4 @@
-;;; vt-control.el --- Common VTxxx control functions
+;;; vt-control.el --- Common VTxxx control functions -*- lexical-binding:t -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -83,26 +83,24 @@
(defun vt-keypad-on (&optional tell)
"Turn on the VT applications keypad."
- (interactive)
+ (interactive "p")
(send-string-to-terminal "\e=")
(setq vt-applications-keypad-p t)
- (if (or tell (called-interactively-p 'interactive))
- (message "Applications keypad enabled.")))
+ (if tell (message "Applications keypad enabled.")))
(defun vt-keypad-off (&optional tell)
"Turn off the VT applications keypad."
(interactive "p")
(send-string-to-terminal "\e>")
(setq vt-applications-keypad-p nil)
- (if (or tell (called-interactively-p 'interactive))
- (message "Applications keypad disabled.")))
+ (if tell (message "Applications keypad disabled.")))
-(defun vt-numlock nil
+(defun vt-numlock (&optional tell)
"Toggle VT application keypad on and off."
- (interactive)
+ (interactive "p")
(if vt-applications-keypad-p
- (vt-keypad-off (called-interactively-p 'interactive))
- (vt-keypad-on (called-interactively-p 'interactive))))
+ (vt-keypad-off tell)
+ (vt-keypad-on tell)))
(provide 'vt-control)
diff --git a/lisp/vt100-led.el b/lisp/vt100-led.el
index 137d65b7ce4..117bef70653 100644
--- a/lisp/vt100-led.el
+++ b/lisp/vt100-led.el
@@ -1,4 +1,4 @@
-;;; vt100-led.el --- functions for LED control on VT-100 terminals & clones
+;;; vt100-led.el --- functions for LED control on VT-100 terminals & clones -*- lexical-binding:t -*-
;; Copyright (C) 1988, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index 687afc828d1..2548fa4d448 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -1,4 +1,4 @@
-;;; w32-fns.el --- Lisp routines for 32-bit Windows
+;;; w32-fns.el --- Lisp routines for 32-bit Windows -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
@@ -55,7 +55,7 @@
w32-system-shells)))
(defun w32-shell-dos-semantics ()
- "Return non-nil if the interactive shell being used expects MS-DOS shell semantics."
+ "Return non-nil if current interactive shell expects MS-DOS shell semantics."
(or (w32-system-shell-p (w32-shell-name))
(and (member (downcase (file-name-nondirectory (w32-shell-name)))
'("cmdproxy" "cmdproxy.exe"))
@@ -202,8 +202,7 @@ This function is provided for backward compatibility, since
(interactive
(list (let ((default locale-coding-system))
(read-coding-system
- (format "Coding system for system calls (default %s): "
- default)
+ (format-prompt "Coding system for system calls" default)
default))))
(check-coding-system coding-system)
(setq locale-coding-system coding-system))
@@ -238,14 +237,18 @@ bit output with no translation."
;; value from x-select-font etc, so list the most important charsets last.
(w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604)
(w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605)
+ (w32-add-charset-info "iso8859-16" 'w32-charset-ansi 28606)
;; The following two are included for pattern matching.
(w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932)
(w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932)
(w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932)
(w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932)
+ (w32-add-charset-info "jisx0212" 'w32-charset-shiftjis 932)
(w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949)
+ (w32-add-charset-info "ksx1001" 'w32-charset-hangeul 949)
(w32-add-charset-info "big5" 'w32-charset-chinesebig5 950)
(w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936)
+ (w32-add-charset-info "gbk" 'w32-charset-gb2312 936)
(w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil)
(w32-add-charset-info "ms-oem" 'w32-charset-oem 437)
(w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850)
@@ -259,9 +262,12 @@ bit output with no translation."
(w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254)
(w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257)
(w32-add-charset-info "koi8-r" 'w32-charset-russian 20866)
+ (w32-add-charset-info "microsoft-cp1251" 'w32-charset-russian 1251)
+ (w32-add-charset-info "windows-1251" 'w32-charset-russian 1251)
(w32-add-charset-info "tis620-2533" 'w32-charset-russian 28595)
(w32-add-charset-info "iso8859-11" 'w32-charset-thai 874)
(w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258)
+ (w32-add-charset-info "viscii" 'w32-charset-vietnamese 1258)
(w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361)
(w32-add-charset-info "mac-roman" 'w32-charset-mac 10000)
(w32-add-charset-info "iso10646-1" 'w32-charset-default t)
@@ -378,10 +384,10 @@ for any permissions.
This is required because the Windows build environment is not required
to include Sed, which is used by leim/Makefile.in to do the job."
- (find-file orig)
- (goto-char (point-max))
- (insert-file-contents extra)
- (delete-matching-lines "^$\\|^;")
- (save-buffers-kill-emacs t))
+ (with-current-buffer (find-file-noselect orig)
+ (goto-char (point-max))
+ (insert-file-contents extra)
+ (delete-matching-lines "^$\\|^;")
+ (save-buffers-kill-emacs t)))
;;; w32-fns.el ends here
diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el
index eacbdda4594..f00e474e1e4 100644
--- a/lisp/w32-vars.el
+++ b/lisp/w32-vars.el
@@ -1,4 +1,4 @@
-;;; w32-vars.el --- MS-Windows specific user options
+;;; w32-vars.el --- MS-Windows specific user options -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -44,22 +44,19 @@ after changing the value of this variable."
:type 'boolean
:set (lambda (symbol value)
(set symbol value)
- (setq mouse-appearance-menu-map nil))
- :group 'w32)
+ (setq mouse-appearance-menu-map nil)))
(unless (eq system-type 'cygwin)
(defcustom w32-allow-system-shell nil
"Disable startup warning when using \"system\" shells."
- :type 'boolean
- :group 'w32))
+ :type 'boolean))
(unless (eq system-type 'cygwin)
(defcustom w32-system-shells '("cmd" "cmd.exe" "command" "command.com"
"4nt" "4nt.exe" "4dos" "4dos.exe"
"tcc" "tcc.exe" "ndos" "ndos.exe")
"List of strings recognized as Windows system shells."
- :type '(repeat string)
- :group 'w32))
+ :type '(repeat string)))
;; Want "menu" custom type for this.
(defcustom w32-fixed-font-alist
@@ -149,8 +146,7 @@ menu if the variable `w32-use-w32-font-dialog' is nil."
(const :tag "Separator" (""))
(list :tag "Font Entry"
(string :tag "Menu text")
- (string :tag "Font")))))))
- :group 'w32)
+ (string :tag "Font"))))))))
(make-obsolete-variable 'w32-enable-synthesized-fonts nil "24.4")
diff --git a/lisp/wdired.el b/lisp/wdired.el
index fc47e775989..fd549bac322 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -1,10 +1,10 @@
-;;; wdired.el --- Rename files editing their names in dired buffers -*- coding: utf-8; -*-
+;;; wdired.el --- Rename files editing their names in dired buffers -*- coding: utf-8; lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
;; Filename: wdired.el
;; Author: Juan León Lahoz García <juanleon1@gmail.com>
-;; Version: 2.0
+;; Old-Version: 2.0
;; Keywords: dired, environment, files, renaming
;; This file is part of GNU Emacs.
@@ -27,26 +27,26 @@
;; wdired.el (the "w" is for writable) provides an alternative way of
;; renaming files.
;;
-;; Have you ever wished to use C-x r t (string-rectangle), M-%
+;; Have you ever wanted to use C-x r t (string-rectangle), M-%
;; (query-replace), M-c (capitalize-word), etc... to change the name of
-;; the files in a "dired" buffer? Now you can do this. All the power
-;; of Emacs commands are available to renaming files!
+;; the files in a "dired" buffer? Now you can do this. All the power
+;; of Emacs commands are available when renaming files!
;;
;; This package provides a function that makes the filenames of a
;; dired buffer editable, by changing the buffer mode (which inhibits
-;; all of the commands of dired mode). Here you can edit the names of
+;; all of the commands of dired mode). Here you can edit the names of
;; one or more files and directories, and when you press C-c C-c, the
;; renaming takes effect and you are back to dired mode.
;;
-;; Another things you can do with WDired:
+;; Other things you can do with WDired:
;;
-;; - To move files to another directory (by typing their path,
+;; - Move files to another directory (by typing their path,
;; absolute or relative, as a part of the new filename).
;;
-;; - To change the target of symbolic links.
+;; - Change the target of symbolic links.
;;
-;; - To change the permission bits of the filenames (in systems with a
-;; working unix-alike `dired-chmod-program'). See and customize the
+;; - Change the permission bits of the filenames (in systems with a
+;; working unix-alike `dired-chmod-program'). See and customize the
;; variable `wdired-allow-to-change-permissions'. To change a single
;; char (toggling between its two more usual values) you can press
;; the space bar over it or left-click the mouse. To set any char to
@@ -56,7 +56,7 @@
;; the change would affect to their targets, and this would not be
;; WYSIWYG :-).
;;
-;; - To mark files for deletion, by deleting their whole filename.
+;; - Mark files for deletion, by deleting their whole filename.
;;; Usage:
@@ -68,8 +68,8 @@
;;; Change Log:
-;; Google is your friend (previous versions with complete changelogs
-;; were posted to gnu.emacs.sources)
+;; Previous versions with complete changelogs were posted to
+;; gnu.emacs.sources.
;;; Code:
@@ -85,15 +85,13 @@
If nil, WDired doesn't require confirmation to change the file names,
and the variable `wdired-confirm-overwrite' controls whether it is ok
to overwrite files without asking."
- :type 'boolean
- :group 'wdired)
+ :type 'boolean)
(defcustom wdired-confirm-overwrite t
"If nil the renames can overwrite files without asking.
This variable has no effect at all if `wdired-use-interactive-rename'
is not nil."
- :type 'boolean
- :group 'wdired)
+ :type 'boolean)
(defcustom wdired-use-dired-vertical-movement nil
"If t, the \"up\" and \"down\" movement works as in Dired mode.
@@ -106,15 +104,13 @@ when editing several filenames.
If nil, \"up\" and \"down\" movement is done as in any other buffer."
:type '(choice (const :tag "As in any other mode" nil)
(const :tag "Smart cursor placement" sometimes)
- (other :tag "As in dired mode" t))
- :group 'wdired)
+ (other :tag "As in dired mode" t)))
(defcustom wdired-allow-to-redirect-links t
"If non-nil, the target of the symbolic links are editable.
In systems without symbolic links support, this variable has no effect
at all."
- :type 'boolean
- :group 'wdired)
+ :type 'boolean)
(defcustom wdired-allow-to-change-permissions nil
"If non-nil, the permissions bits of the files are editable.
@@ -135,8 +131,7 @@ Anyway, the real change of the permissions is done by the external
program `dired-chmod-program', which must exist."
:type '(choice (const :tag "Not allowed" nil)
(const :tag "Toggle/set bits" t)
- (other :tag "Bits freely editable" advanced))
- :group 'wdired)
+ (other :tag "Bits freely editable" advanced)))
(defcustom wdired-keep-marker-rename t
;; Use t as default so that renamed files "take their markers with them".
@@ -149,8 +144,7 @@ See `dired-keep-marker-rename' if you want to do the same for files
renamed by `dired-do-rename' and `dired-do-rename-regexp'."
:type '(choice (const :tag "Keep" t)
(character :tag "Mark" :value ?R))
- :version "24.3"
- :group 'wdired)
+ :version "24.3")
(defcustom wdired-create-parent-directories t
"If non-nil, create parent directories of destination files.
@@ -159,51 +153,47 @@ nonexistent directory, wdired will create any parent directories
necessary. When nil, attempts to rename a file into a
nonexistent directory will fail."
:version "26.1"
- :type 'boolean
- :group 'wdired)
+ :type 'boolean)
(defvar wdired-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-x\C-s" 'wdired-finish-edit)
- (define-key map "\C-c\C-c" 'wdired-finish-edit)
- (define-key map "\C-c\C-k" 'wdired-abort-changes)
- (define-key map "\C-c\C-[" 'wdired-abort-changes)
- (define-key map "\C-x\C-q" 'wdired-exit)
- (define-key map "\C-m" 'ignore)
- (define-key map "\C-j" 'ignore)
- (define-key map "\C-o" 'ignore)
- (define-key map [up] 'wdired-previous-line)
- (define-key map "\C-p" 'wdired-previous-line)
- (define-key map [down] 'wdired-next-line)
- (define-key map "\C-n" 'wdired-next-line)
-
- (define-key map [menu-bar wdired]
- (cons "WDired" (make-sparse-keymap "WDired")))
- (define-key map [menu-bar wdired wdired-customize]
- '("Options" . wdired-customize))
- (define-key map [menu-bar wdired dashes]
- '("--"))
- (define-key map [menu-bar wdired wdired-abort-changes]
- '(menu-item "Abort Changes" wdired-abort-changes
- :help "Abort changes and return to dired mode"))
- (define-key map [menu-bar wdired wdired-finish-edit]
- '("Commit Changes" . wdired-finish-edit))
-
- (define-key map [remap upcase-word] 'wdired-upcase-word)
- (define-key map [remap capitalize-word] 'wdired-capitalize-word)
- (define-key map [remap downcase-word] 'wdired-downcase-word)
-
+ (define-key map "\C-x\C-s" #'wdired-finish-edit)
+ (define-key map "\C-c\C-c" #'wdired-finish-edit)
+ (define-key map "\C-c\C-k" #'wdired-abort-changes)
+ (define-key map "\C-c\C-[" #'wdired-abort-changes)
+ (define-key map "\C-x\C-q" #'wdired-exit)
+ (define-key map "\C-m" #'undefined)
+ (define-key map "\C-j" #'undefined)
+ (define-key map "\C-o" #'undefined)
+ (define-key map [up] #'wdired-previous-line)
+ (define-key map "\C-p" #'wdired-previous-line)
+ (define-key map [down] #'wdired-next-line)
+ (define-key map "\C-n" #'wdired-next-line)
+ (define-key map [remap upcase-word] #'wdired-upcase-word)
+ (define-key map [remap capitalize-word] #'wdired-capitalize-word)
+ (define-key map [remap downcase-word] #'wdired-downcase-word)
+ (define-key map [remap self-insert-command] #'wdired--self-insert)
map)
"Keymap used in `wdired-mode'.")
+(easy-menu-define wdired-mode-menu wdired-mode-map
+ "Menu for `wdired-mode'."
+ '("WDired"
+ ["Commit Changes" wdired-finish-edit]
+ ["Abort Changes" wdired-abort-changes
+ :help "Abort changes and return to Dired mode"]
+ "---"
+ ["Options" wdired-customize]))
+
(defvar wdired-mode-hook nil
"Hooks run when changing to WDired mode.")
;; Local variables (put here to avoid compilation gripes)
-(defvar wdired-col-perm) ;; Column where the permission bits start
-(defvar wdired-old-content)
-(defvar wdired-old-point)
-(defvar wdired-old-marks)
+(defvar wdired--perm-beg) ;; Column where the permission bits start
+(defvar wdired--perm-end) ;; Column where the permission bits stop
+(defvar wdired--old-content)
+(defvar wdired--old-point)
+(defvar wdired--old-marks)
(defun wdired-mode ()
"Writable Dired (WDired) mode.
@@ -242,33 +232,25 @@ See `wdired-mode'."
(interactive)
(unless (derived-mode-p 'dired-mode)
(error "Not a Dired buffer"))
- (set (make-local-variable 'wdired-old-content)
- (buffer-substring (point-min) (point-max)))
- (set (make-local-variable 'wdired-old-marks)
- (dired-remember-marks (point-min) (point-max)))
- (set (make-local-variable 'wdired-old-point) (point))
- (set (make-local-variable 'query-replace-skip-read-only) t)
+ (setq-local wdired--old-content
+ (buffer-substring (point-min) (point-max)))
+ (setq-local wdired--old-marks
+ (dired-remember-marks (point-min) (point-max)))
+ (setq-local wdired--old-point (point))
+ (wdired--set-permission-bounds)
+ (setq-local query-replace-skip-read-only t)
(add-function :after-while (local 'isearch-filter-predicate)
#'wdired-isearch-filter-read-only)
(use-local-map wdired-mode-map)
(force-mode-line-update)
(setq buffer-read-only nil)
(dired-unadvertise default-directory)
- (add-hook 'kill-buffer-hook 'wdired-check-kill-buffer nil t)
- (add-hook 'after-change-functions 'wdired--restore-dired-filename-prop nil t)
+ (add-hook 'kill-buffer-hook #'wdired-check-kill-buffer nil t)
+ (add-hook 'before-change-functions #'wdired--before-change-fn nil t)
+ (add-hook 'after-change-functions #'wdired--restore-properties nil t)
(setq major-mode 'wdired-mode)
(setq mode-name "Editable Dired")
- (setq revert-buffer-function 'wdired-revert)
- ;; I temp disable undo for performance: since I'm going to clear the
- ;; undo list, it can save more than a 9% of time with big
- ;; directories because setting properties modify the undo-list.
- (buffer-disable-undo)
- (wdired-preprocess-files)
- (if wdired-allow-to-change-permissions
- (wdired-preprocess-perms))
- (if (and wdired-allow-to-redirect-links (fboundp 'make-symbolic-link))
- (wdired-preprocess-symlinks))
- (buffer-enable-undo) ; Performance hack. See above.
+ (add-function :override (local 'revert-buffer-function) #'wdired-revert)
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
(run-mode-hooks 'wdired-mode-hook)
@@ -276,6 +258,68 @@ See `wdired-mode'."
"Press \\[wdired-finish-edit] when finished \
or \\[wdired-abort-changes] to abort changes")))
+(defun wdired--set-permission-bounds ()
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (re-search-forward dired-re-perms nil t 1))
+ (progn
+ (setq-local wdired--perm-beg nil)
+ (setq-local wdired--perm-end nil))
+ (goto-char (match-beginning 0))
+ ;; Add 1 since the first char matched by `dired-re-perms' is the
+ ;; one describing the nature of the entry (dir/symlink/...) rather
+ ;; than its permissions.
+ (setq-local wdired--perm-beg (1+ (wdired--current-column)))
+ (goto-char (match-end 0))
+ (setq-local wdired--perm-end (wdired--current-column)))))
+
+(defun wdired--current-column ()
+ (- (point) (line-beginning-position)))
+
+(defun wdired--point-at-perms-p ()
+ (and wdired--perm-beg
+ (<= wdired--perm-beg (wdired--current-column) wdired--perm-end)))
+
+(defun wdired--line-preprocessed-p ()
+ (get-text-property (line-beginning-position) 'front-sticky))
+
+(defun wdired--self-insert ()
+ (interactive)
+ (if (wdired--line-preprocessed-p)
+ (call-interactively 'self-insert-command)
+ (wdired--before-change-fn (point) (point))
+ (let* ((map (get-text-property (point) 'keymap)))
+ (call-interactively (or (if map (lookup-key map (this-command-keys)))
+ #'self-insert-command)))))
+
+(put 'wdired--self-insert 'delete-selection 'delete-selection-uses-region-p)
+
+(defun wdired--before-change-fn (beg end)
+ (save-match-data
+ (save-excursion
+ (save-restriction
+ (widen)
+ ;; Make sure to process entire lines.
+ (goto-char end)
+ (setq end (line-end-position))
+ (goto-char beg)
+ (forward-line 0)
+
+ (while (< (point) end)
+ (unless (wdired--line-preprocessed-p)
+ (with-silent-modifications
+ (put-text-property (point) (1+ (point)) 'front-sticky t)
+ (wdired--preprocess-files)
+ (when wdired-allow-to-change-permissions
+ (wdired--preprocess-perms))
+ (when (fboundp 'make-symbolic-link)
+ (wdired--preprocess-symlinks))))
+ (forward-line))
+ (when (eobp)
+ (with-silent-modifications
+ ;; Is this good enough? Assumes no extra white lines from dired.
+ (put-text-property (1- (point-max)) (point-max) 'read-only t)))))))
+
(defun wdired-isearch-filter-read-only (beg end)
"Skip matches that have a read-only property."
(not (text-property-not-all (min beg end) (max beg end)
@@ -283,37 +327,58 @@ or \\[wdired-abort-changes] to abort changes")))
;; Protect the buffer so only the filenames can be changed, and put
;; properties so filenames (old and new) can be easily found.
-(defun wdired-preprocess-files ()
- (put-text-property (point-min) (1+ (point-min))'front-sticky t)
+(defun wdired--preprocess-files ()
(save-excursion
- (goto-char (point-min))
- (let ((b-protection (point))
- filename)
- (while (not (eobp))
- (setq filename (dired-get-filename nil t))
- (when (and filename
- (not (member (file-name-nondirectory filename) '("." ".."))))
- (dired-move-to-filename)
- ;; The rear-nonsticky property below shall ensure that text preceding
- ;; the filename can't be modified.
- (add-text-properties
- (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only)))
- (put-text-property b-protection (point) 'read-only t)
- (setq b-protection (dired-move-to-end-of-filename t))
- (put-text-property (point) (1+ (point)) 'end-name t))
- (forward-line))
- (put-text-property b-protection (point-max) 'read-only t))))
+ (let ((used-F (dired-check-switches dired-actual-switches "F" "classify"))
+ (beg (point))
+ (filename (dired-get-filename nil t)))
+ (when (and filename
+ (not (member (file-name-nondirectory filename) '("." ".."))))
+ (dired-move-to-filename)
+ ;; The rear-nonsticky property below shall ensure that text preceding
+ ;; the filename can't be modified.
+ (add-text-properties
+ (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only)))
+ (put-text-property beg (point) 'read-only t)
+ (dired-move-to-end-of-filename t)
+ (put-text-property (point) (1+ (point)) 'end-name t))
+ (when (and used-F (looking-at "[*/@|=>]$")) (forward-char))
+ (when (save-excursion
+ (and (re-search-backward
+ dired-permission-flags-regexp nil t)
+ (looking-at "l")
+ (search-forward " -> " (line-end-position) t)))
+ (goto-char (line-end-position))))))
;; This code is a copy of some dired-get-filename lines.
(defsubst wdired-normalize-filename (file unquotep)
(when unquotep
- (setq file
- ;; FIXME: shouldn't we check for a `b' argument or somesuch before
- ;; doing such unquoting? --Stef
- (read (concat
- "\"" (replace-regexp-in-string
- "\\([^\\]\\|\\`\\)\"" "\\1\\\\\"" file)
- "\""))))
+ ;; Unquote names quoted by ls or by dired-insert-directory.
+ ;; This code was written using `read' to unquote, because
+ ;; it's faster than substituting \007 (4 chars) -> ^G (1
+ ;; char) etc. in a lisp loop. Unfortunately, this decision
+ ;; has necessitated hacks such as dealing with filenames
+ ;; with quotation marks in their names.
+ (while (string-match "\\(?:[^\\]\\|\\`\\)\\(\"\\)" file)
+ (setq file (replace-match "\\\"" nil t file 1)))
+ ;; Unescape any spaces escaped by ls -b (bug#10469).
+ ;; Other -b quotes, eg \t, \n, work transparently.
+ (if (dired-switches-escape-p dired-actual-switches)
+ (let ((start 0)
+ (rep "")
+ (shift -1))
+ (while (string-match "\\(\\\\\\) " file start)
+ (setq file (replace-match rep nil t file 1)
+ start (+ shift (match-end 0))))))
+ (when (eq system-type 'windows-nt)
+ (save-match-data
+ (let ((start 0))
+ (while (string-match "\\\\" file start)
+ (aset file (match-beginning 0) ?/)
+ (setq start (match-end 0))))))
+
+ ;; Hence we don't need to worry about converting `\\' back to `\'.
+ (setq file (read (concat "\"" file "\""))))
(and file buffer-file-coding-system
(not file-name-coding-system)
(not default-file-name-coding-system)
@@ -327,7 +392,9 @@ relies on WDired buffer's properties. Optional arg NO-DIR with value
non-nil means don't include directory. Optional arg OLD with value
non-nil means return old filename."
;; FIXME: Use dired-get-filename's new properties.
- (let (beg end file)
+ (let ((used-F (dired-check-switches dired-actual-switches "F" "classify"))
+ beg end file)
+ (wdired--before-change-fn (point) (point))
(save-excursion
(setq end (line-end-position))
(beginning-of-line)
@@ -339,16 +406,31 @@ non-nil means return old filename."
;; the filename end is found even when the filename is empty.
;; Fixes error and spurious newlines when marking files for
;; deletion.
- (setq end (next-single-property-change beg 'end-name))
+ (setq end (next-single-property-change beg 'end-name nil end))
+ (when (save-excursion
+ (and (re-search-forward
+ dired-permission-flags-regexp nil t)
+ (goto-char (match-beginning 0))
+ (looking-at "l")
+ (if (and used-F
+ dired-ls-F-marks-symlinks)
+ (re-search-forward "@? -> " (line-end-position) t)
+ (search-forward " -> " (line-end-position) t))))
+ (goto-char (match-beginning 0))
+ (setq end (point)))
+ (when (and used-F
+ (save-excursion
+ (goto-char end)
+ (looking-back "[*/@|=>]$" (1- (point)))))
+ (setq end (1- end)))
(setq file (buffer-substring-no-properties (1+ beg) end)))
;; Don't unquote the old name, it wasn't quoted in the first place
(and file (setq file (wdired-normalize-filename file (not old)))))
(if (or no-dir old)
- file
+ (if no-dir (file-relative-name file) file)
(and file (> (length file) 0)
(concat (dired-current-directory) file))))))
-
(defun wdired-change-to-dired-mode ()
"Change the mode back to dired."
(or (eq major-mode 'wdired-mode)
@@ -365,18 +447,19 @@ non-nil means return old filename."
(setq major-mode 'dired-mode)
(setq mode-name "Dired")
(dired-advertise)
- (remove-hook 'kill-buffer-hook 'wdired-check-kill-buffer t)
- (remove-hook 'after-change-functions 'wdired--restore-dired-filename-prop t)
- (set (make-local-variable 'revert-buffer-function) 'dired-revert))
-
+ (remove-hook 'kill-buffer-hook #'wdired-check-kill-buffer t)
+ (remove-hook 'before-change-functions #'wdired--before-change-fn t)
+ (remove-hook 'after-change-functions #'wdired--restore-properties t)
+ (remove-function (local 'revert-buffer-function) #'wdired-revert))
(defun wdired-abort-changes ()
"Abort changes and return to dired mode."
(interactive)
+ (remove-hook 'before-change-functions #'wdired--before-change-fn t)
(let ((inhibit-read-only t))
(erase-buffer)
- (insert wdired-old-content)
- (goto-char wdired-old-point))
+ (insert wdired--old-content)
+ (goto-char wdired--old-point))
(wdired-change-to-dired-mode)
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
@@ -398,13 +481,14 @@ non-nil means return old filename."
(setq errors (cdr tmp-value))
(setq changes (car tmp-value)))
(when (and wdired-allow-to-change-permissions
- (boundp 'wdired-col-perm)) ; could have been changed
+ wdired--perm-beg) ; could have been changed
(setq tmp-value (wdired-do-perm-changes))
(setq errors (+ errors (cdr tmp-value)))
(setq changes (or changes (car tmp-value))))
(goto-char (point-max))
(while (not (bobp))
- (setq file-old (wdired-get-filename nil t))
+ (setq file-old (and (wdired--line-preprocessed-p)
+ (wdired-get-filename nil t)))
(when file-old
(setq file-new (wdired-get-filename))
(if (equal file-new file-old)
@@ -416,20 +500,20 @@ non-nil means return old filename."
(let ((mark (cond ((integerp wdired-keep-marker-rename)
wdired-keep-marker-rename)
(wdired-keep-marker-rename
- (cdr (assoc file-old wdired-old-marks)))
+ (cdr (assoc file-old wdired--old-marks)))
(t nil))))
(when mark
(push (cons (substitute-in-file-name file-new) mark)
- wdired-old-marks))))
+ wdired--old-marks))))
(push (cons file-old (substitute-in-file-name file-new))
files-renamed))))
(forward-line -1)))
(when files-renamed
(setq errors (+ errors (wdired-do-renames files-renamed))))
;; We have to be in wdired-mode when wdired-do-renames is executed
- ;; so that wdired--restore-dired-filename-prop runs, but we have
- ;; to change back to dired-mode before reverting the buffer to
- ;; avoid using wdired-revert, which changes back to wdired-mode.
+ ;; so that wdired--restore-properties runs, but we have to change
+ ;; back to dired-mode before reverting the buffer to avoid using
+ ;; wdired-revert, which changes back to wdired-mode.
(wdired-change-to-dired-mode)
(if changes
(progn
@@ -445,26 +529,32 @@ non-nil means return old filename."
;; Re-sort the buffer.
(revert-buffer)
(let ((inhibit-read-only t))
- (dired-mark-remembered wdired-old-marks)))
+ (dired-mark-remembered wdired--old-marks)))
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max)
'(old-name nil end-name nil old-link nil
end-link nil end-perm nil
old-perm nil perm-changed nil))
- (message "(No changes to be performed)")))
+ (message "(No changes to be performed)")
+ ;; Deleting file indicator characters or editing the symlink
+ ;; arrow in WDired are noops, so redisplay them immediately on
+ ;; returning to Dired.
+ (revert-buffer)))
(when files-deleted
(wdired-flag-for-deletion files-deleted))
(when (> errors 0)
- (dired-log-summary (format "%d rename actions failed" errors) nil)))
+ (dired-log-summary (format "%d actions failed" errors) nil)))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil))
(defun wdired-do-renames (renames)
"Perform RENAMES in parallel."
- (let ((residue ())
- (progress nil)
- (errors 0)
- (overwrite (or (not wdired-confirm-overwrite) 1)))
+ (let* ((residue ())
+ (progress nil)
+ (errors 0)
+ (total (1- (length renames)))
+ (prep (make-progress-reporter "Renaming" 0 total))
+ (overwrite (or (not wdired-confirm-overwrite) 1)))
(while (or renames
;; We've done one round through the renames, we have found
;; some residue, but we also made some progress, so maybe
@@ -472,6 +562,7 @@ non-nil means return old filename."
(prog1 (setq renames residue)
(setq progress nil)
(setq residue nil)))
+ (progress-reporter-update prep (- total (length renames)))
(let* ((rename (pop renames))
(file-new (cdr rename)))
(cond
@@ -509,7 +600,7 @@ non-nil means return old filename."
;; So we must ensure dired-aux is loaded.
(require 'dired-aux)
(condition-case err
- (let ((dired-backup-overwrite nil))
+ (dlet ((dired-backup-overwrite nil))
(and wdired-create-parent-directories
(wdired-create-parentdirs file-new))
(dired-rename-file file-ori file-new
@@ -519,6 +610,7 @@ non-nil means return old filename."
(dired-log "Rename `%s' to `%s' failed:\n%s\n"
file-ori file-new
err)))))))))
+ (progress-reporter-done prep)
errors))
(defun wdired-create-parentdirs (file-new)
@@ -605,41 +697,61 @@ Optional arguments are ignored."
;; dired-filename text property, which allows functions that look for
;; this property (e.g. dired-isearch-filenames) to work in wdired-mode
;; and also avoids an error with non-nil wdired-use-interactive-rename
-;; (bug#32173).
-(defun wdired--restore-dired-filename-prop (beg end _len)
+;; (bug#32173). Also prevents editing the symlink arrow (which is a
+;; noop) from corrupting the link name (see bug#18475 for elaboration).
+(defun wdired--restore-properties (beg end _len)
(save-match-data
(save-excursion
- (let ((lep (line-end-position)))
- (beginning-of-line)
- (when (re-search-forward
- directory-listing-before-filename-regexp lep t)
- (setq beg (point)
- end (if (or
- ;; If the file is a symlink, put the
- ;; dired-filename property only on the link
- ;; name. (Using (file-symlink-p
- ;; (dired-get-filename)) fails in
- ;; wdired-mode, bug#32673.)
- (and (re-search-backward
- dired-permission-flags-regexp nil t)
- (looking-at "l")
- (search-forward " -> " lep t))
- ;; When dired-listing-switches includes "F"
- ;; or "classify", don't treat appended
- ;; indicator characters as part of the file
- ;; name (bug#34915).
- (and (dired-check-switches dired-actual-switches
- "F" "classify")
- (re-search-forward "[*/@|=>]$" lep t)))
- (goto-char (match-beginning 0))
- lep))
- (put-text-property beg end 'dired-filename t))))))
+ (save-restriction
+ (widen)
+ (let ((lep (line-end-position))
+ (used-F (dired-check-switches
+ dired-actual-switches
+ "F" "classify")))
+ ;; Deleting the space between the link name and the arrow (a
+ ;; noop) also deletes the end-name property, so restore it.
+ (when (and (save-excursion
+ (re-search-backward dired-permission-flags-regexp nil t)
+ (looking-at "l"))
+ (get-text-property (1- (point)) 'dired-filename)
+ (not (get-text-property (point) 'dired-filename))
+ (not (get-text-property (point) 'end-name)))
+ (put-text-property (point) (1+ (point)) 'end-name t))
+ (beginning-of-line)
+ (when (re-search-forward
+ directory-listing-before-filename-regexp lep t)
+ (setq beg (point)
+ end (if (or
+ ;; If the file is a symlink, put the
+ ;; dired-filename property only on the link
+ ;; name. (Using (file-symlink-p
+ ;; (dired-get-filename)) fails in
+ ;; wdired-mode, bug#32673.)
+ (and (re-search-backward
+ dired-permission-flags-regexp nil t)
+ (looking-at "l")
+ ;; macOS and Ultrix adds "@" to the end
+ ;; of symlinks when using -F.
+ (if (and used-F
+ dired-ls-F-marks-symlinks)
+ (re-search-forward "@? -> " lep t)
+ (search-forward " -> " lep t)))
+ ;; When dired-listing-switches includes "F"
+ ;; or "classify", don't treat appended
+ ;; indicator characters as part of the file
+ ;; name (bug#34915).
+ (and used-F
+ (re-search-forward "[*/@|=>]$" lep t)))
+ (goto-char (match-beginning 0))
+ lep))
+ (put-text-property beg end 'dired-filename t)))))))
(defun wdired-next-line (arg)
"Move down lines then position at filename or the current column.
See `wdired-use-dired-vertical-movement'. Optional prefix ARG
says how many lines to move; default is one line."
(interactive "^p")
+ (setq this-command 'next-line) ;Let `line-move' preserve the column.
(with-no-warnings (next-line arg))
(if (or (eq wdired-use-dired-vertical-movement t)
(and wdired-use-dired-vertical-movement
@@ -653,6 +765,7 @@ says how many lines to move; default is one line."
See `wdired-use-dired-vertical-movement'. Optional prefix ARG
says how many lines to move; default is one line."
(interactive "^p")
+ (setq this-command 'previous-line) ;Let `line-move' preserve the column.
(with-no-warnings (previous-line arg))
(if (or (eq wdired-use-dired-vertical-movement t)
(and wdired-use-dired-vertical-movement
@@ -662,38 +775,37 @@ says how many lines to move; default is one line."
(dired-move-to-filename)))
;; Put the needed properties to allow the user to change links' targets
-(defun wdired-preprocess-symlinks ()
- (let ((inhibit-read-only t))
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at dired-re-sym)
- (progn
- (re-search-forward " -> \\(.*\\)$")
- (put-text-property (- (match-beginning 1) 2)
- (1- (match-beginning 1)) 'old-link
- (match-string-no-properties 1))
- (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t)
- (put-text-property (1- (match-beginning 1))
- (match-beginning 1)
- 'rear-nonsticky '(read-only))
- (put-text-property (match-beginning 1)
- (match-end 1) 'read-only nil)))
- (forward-line)))))
-
+(defun wdired--preprocess-symlinks ()
+ (save-excursion
+ (when (looking-at dired-re-sym)
+ (re-search-forward " -> \\(.*\\)$")
+ (put-text-property (1- (match-beginning 1))
+ (match-beginning 1) 'old-link
+ (match-string-no-properties 1))
+ (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t)
+ (unless wdired-allow-to-redirect-links
+ (put-text-property (match-beginning 0)
+ (match-end 1) 'read-only t)))))
(defun wdired-get-previous-link (&optional old move)
"Return the next symlink target.
If OLD, return the old target. If MOVE, move point before it."
(let (beg end target)
(setq beg (previous-single-property-change (point) 'old-link nil))
- (if beg
- (progn
- (if old
- (setq target (get-text-property (1- beg) 'old-link))
- (setq end (next-single-property-change beg 'end-link))
- (setq target (buffer-substring-no-properties (1+ beg) end)))
- (if move (goto-char (1- beg)))))
+ (when beg
+ (when (save-excursion
+ (goto-char beg)
+ (and (looking-at " ")
+ (looking-back " ->" (line-beginning-position))))
+ (setq beg (1+ beg)))
+ (if old
+ (setq target (get-text-property (1- beg) 'old-link))
+ (setq end (save-excursion
+ (goto-char beg)
+ (next-single-property-change beg 'end-link nil
+ (line-end-position))))
+ (setq target (buffer-substring-no-properties beg end)))
+ (if move (goto-char (1- beg))))
(and target (wdired-normalize-filename target t))))
(declare-function make-symbolic-link "fileio.c")
@@ -710,7 +822,7 @@ If OLD, return the old target. If MOVE, move point before it."
(unless (equal link-to-new link-to-ori)
(setq changes t)
(if (equal link-to-new "") ;empty filename!
- (setq link-to-new "/dev/null"))
+ (setq link-to-new (null-device)))
(condition-case err
(progn
(delete-file link-from)
@@ -757,56 +869,49 @@ Like original function but it skips read-only words."
(interactive "p")
(wdired-xcase-word 'capitalize-word arg))
-
;; The following code deals with changing the access bits (or
;; permissions) of the files.
(defvar wdired-perm-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map " " 'wdired-toggle-bit)
- (define-key map "r" 'wdired-set-bit)
- (define-key map "w" 'wdired-set-bit)
- (define-key map "x" 'wdired-set-bit)
- (define-key map "-" 'wdired-set-bit)
- (define-key map "S" 'wdired-set-bit)
- (define-key map "s" 'wdired-set-bit)
- (define-key map "T" 'wdired-set-bit)
- (define-key map "t" 'wdired-set-bit)
- (define-key map "s" 'wdired-set-bit)
- (define-key map "l" 'wdired-set-bit)
- (define-key map [down-mouse-1] 'wdired-mouse-toggle-bit)
+ (define-key map " " #'wdired-toggle-bit)
+ (define-key map "r" #'wdired-set-bit)
+ (define-key map "w" #'wdired-set-bit)
+ (define-key map "x" #'wdired-set-bit)
+ (define-key map "-" #'wdired-set-bit)
+ (define-key map "S" #'wdired-set-bit)
+ (define-key map "s" #'wdired-set-bit)
+ (define-key map "T" #'wdired-set-bit)
+ (define-key map "t" #'wdired-set-bit)
+ (define-key map "s" #'wdired-set-bit)
+ (define-key map "l" #'wdired-set-bit)
+ (define-key map [mouse-1] #'wdired-mouse-toggle-bit)
map))
;; Put a keymap property to the permission bits of the files, and store the
;; original name and permissions as a property
-(defun wdired-preprocess-perms ()
- (let ((inhibit-read-only t))
- (set (make-local-variable 'wdired-col-perm) nil)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (when (and (not (looking-at dired-re-sym))
- (wdired-get-filename)
- (re-search-forward dired-re-perms (line-end-position) 'eol))
- (let ((begin (match-beginning 0))
- (end (match-end 0)))
- (unless wdired-col-perm
- (setq wdired-col-perm (- (current-column) 9)))
- (if (eq wdired-allow-to-change-permissions 'advanced)
- (progn
- (put-text-property begin end 'read-only nil)
- ;; make first permission bit writable
- (put-text-property
- (1- begin) begin 'rear-nonsticky '(read-only)))
- ;; avoid that keymap applies to text following permissions
- (add-text-properties
- (1+ begin) end
- `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap))))
- (put-text-property end (1+ end) 'end-perm t)
- (put-text-property
- begin (1+ begin) 'old-perm (match-string-no-properties 0))))
- (forward-line)
- (beginning-of-line)))))
+(defun wdired--preprocess-perms ()
+ (save-excursion
+ (when (and (not (looking-at dired-re-sym))
+ (wdired-get-filename)
+ (re-search-forward dired-re-perms
+ (line-end-position) 'eol))
+ (let ((begin (match-beginning 0))
+ (end (match-end 0)))
+ (if (eq wdired-allow-to-change-permissions 'advanced)
+ (progn
+ (put-text-property begin end 'read-only nil)
+ ;; make first permission bit writable
+ (put-text-property
+ (1- begin) begin 'rear-nonsticky '(read-only)))
+ ;; avoid that keymap applies to text following permissions
+ (add-text-properties
+ (1+ begin) end
+ `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap))))
+ (put-text-property end (1+ end) 'end-perm t)
+ (put-text-property
+ begin (1+ begin)
+ 'old-perm (match-string-no-properties 0))))))
(defun wdired-perm-allowed-in-pos (char pos)
(cond
@@ -818,39 +923,30 @@ Like original function but it skips read-only words."
((memq char '(?t ?T)) (= pos 8))
((= char ?l) (= pos 5))))
-(defun wdired-set-bit ()
+(defun wdired-set-bit (&optional char)
"Set a permission bit character."
- (interactive)
- (if (wdired-perm-allowed-in-pos last-command-event
- (- (current-column) wdired-col-perm))
- (let ((new-bit (char-to-string last-command-event))
+ (interactive (list last-command-event))
+ (unless char (setq char last-command-event))
+ (if (wdired-perm-allowed-in-pos char
+ (- (wdired--current-column) wdired--perm-beg))
+ (let ((new-bit (char-to-string char))
(inhibit-read-only t)
- (pos-prop (- (point) (- (current-column) wdired-col-perm))))
- (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit)
- (put-text-property 0 1 'read-only t new-bit)
+ (pos-prop (+ (line-beginning-position) wdired--perm-beg)))
+ (set-text-properties 0 1 (text-properties-at (point)) new-bit)
(insert new-bit)
(delete-char 1)
- (put-text-property (1- pos-prop) pos-prop 'perm-changed t)
- (put-text-property (1- (point)) (point) 'rear-nonsticky '(keymap)))
+ (put-text-property (1- pos-prop) pos-prop 'perm-changed t))
(forward-char 1)))
(defun wdired-toggle-bit ()
"Toggle the permission bit at point."
(interactive)
- (let ((inhibit-read-only t)
- (new-bit "-")
- (pos-prop (- (point) (- (current-column) wdired-col-perm))))
- (if (eq (char-after (point)) ?-)
- (setq new-bit
- (if (= (% (- (current-column) wdired-col-perm) 3) 0) "r"
- (if (= (% (- (current-column) wdired-col-perm) 3) 1) "w"
- "x"))))
- (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit)
- (put-text-property 0 1 'read-only t new-bit)
- (insert new-bit)
- (delete-char 1)
- (put-text-property (1- pos-prop) pos-prop 'perm-changed t)
- (put-text-property (1- (point)) (point) 'rear-nonsticky '(keymap))))
+ (wdired-set-bit
+ (cond
+ ((not (eq (char-after (point)) ?-)) ?-)
+ ((= (% (- (wdired--current-column) wdired--perm-beg) 3) 0) ?r)
+ ((= (% (- (wdired--current-column) wdired--perm-beg) 3) 1) ?w)
+ (t ?x))))
(defun wdired-mouse-toggle-bit (event)
"Toggle the permission bit that was left clicked."
@@ -858,26 +954,26 @@ Like original function but it skips read-only words."
(mouse-set-point event)
(wdired-toggle-bit))
-;; Allowed chars for 4000 bit are Ss in position 3
-;; Allowed chars for 2000 bit are Ssl in position 6
-;; Allowed chars for 1000 bit are Tt in position 9
+;; Allowed chars for #o4000 bit are Ss in position 3
+;; Allowed chars for #o2000 bit are Ssl in position 6
+;; Allowed chars for #o1000 bit are Tt in position 9
(defun wdired-perms-to-number (perms)
- (let ((nperm 0777))
- (if (= (elt perms 1) ?-) (setq nperm (- nperm 400)))
- (if (= (elt perms 2) ?-) (setq nperm (- nperm 200)))
+ (let ((nperm #o0777))
+ (if (= (elt perms 1) ?-) (setq nperm (- nperm #o400)))
+ (if (= (elt perms 2) ?-) (setq nperm (- nperm #o200)))
(let ((p-bit (elt perms 3)))
- (if (memq p-bit '(?- ?S)) (setq nperm (- nperm 100)))
- (if (memq p-bit '(?s ?S)) (setq nperm (+ nperm 4000))))
- (if (= (elt perms 4) ?-) (setq nperm (- nperm 40)))
- (if (= (elt perms 5) ?-) (setq nperm (- nperm 20)))
+ (if (memq p-bit '(?- ?S)) (setq nperm (- nperm #o100)))
+ (if (memq p-bit '(?s ?S)) (setq nperm (+ nperm #o4000))))
+ (if (= (elt perms 4) ?-) (setq nperm (- nperm #o40)))
+ (if (= (elt perms 5) ?-) (setq nperm (- nperm #o20)))
(let ((p-bit (elt perms 6)))
- (if (memq p-bit '(?- ?S ?l)) (setq nperm (- nperm 10)))
- (if (memq p-bit '(?s ?S ?l)) (setq nperm (+ nperm 2000))))
+ (if (memq p-bit '(?- ?S ?l)) (setq nperm (- nperm #o10)))
+ (if (memq p-bit '(?s ?S ?l)) (setq nperm (+ nperm #o2000))))
(if (= (elt perms 7) ?-) (setq nperm (- nperm 4)))
(if (= (elt perms 8) ?-) (setq nperm (- nperm 2)))
(let ((p-bit (elt perms 9)))
(if (memq p-bit '(?- ?T)) (setq nperm (- nperm 1)))
- (if (memq p-bit '(?t ?T)) (setq nperm (+ nperm 1000))))
+ (if (memq p-bit '(?t ?T)) (setq nperm (+ nperm #o1000))))
nperm))
;; Perform the changes in the permissions of the files that have
@@ -887,7 +983,7 @@ Like original function but it skips read-only words."
(errors 0)
(prop-wanted (if (eq wdired-allow-to-change-permissions 'advanced)
'old-perm 'perm-changed))
- filename perms-ori perms-new perm-tmp)
+ filename perms-ori perms-new)
(goto-char (next-single-property-change (point-min) prop-wanted
nil (point-max)))
(while (not (eobp))
@@ -898,14 +994,12 @@ Like original function but it skips read-only words."
(setq changes t)
(setq filename (wdired-get-filename nil t))
(if (= (length perms-new) 10)
- (progn
- (setq perm-tmp
- (int-to-string (wdired-perms-to-number perms-new)))
- (unless (equal 0 (process-file dired-chmod-program
- nil nil nil perm-tmp filename))
- (setq errors (1+ errors))
- (dired-log "%s %s `%s' failed\n\n"
- dired-chmod-program perm-tmp filename)))
+ (condition-case nil
+ (set-file-modes filename (wdired-perms-to-number perms-new))
+ (error
+ (setq errors (1+ errors))
+ (dired-log "Setting mode of `%s' to `%s' failed\n\n"
+ filename perms-new)))
(setq errors (1+ errors))
(dired-log "Cannot parse permission `%s' for file `%s'\n\n"
perms-new filename)))
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index 0be063b6f8d..a2dc6ab9814 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -5,7 +5,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: data, wp
;; Version: 13.2.2
-;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; This file is part of GNU Emacs.
@@ -86,19 +86,6 @@
;; * if global whitespace is turned off, whitespace continues on only
;; in the buffers in which local whitespace is on.
;;
-;; To use whitespace, insert in your ~/.emacs:
-;;
-;; (require 'whitespace)
-;;
-;; Or autoload at least one of the commands`whitespace-mode',
-;; `whitespace-toggle-options', `global-whitespace-mode' or
-;; `global-whitespace-toggle-options'. For example:
-;;
-;; (autoload 'whitespace-mode "whitespace"
-;; "Toggle whitespace visualization." t)
-;; (autoload 'whitespace-toggle-options "whitespace"
-;; "Toggle local `whitespace-mode' options." t)
-;;
;; whitespace was inspired by:
;;
;; whitespace.el Rajesh Vaidheeswarran <rv@gnu.org>
@@ -262,7 +249,7 @@
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; code:
+;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -283,7 +270,8 @@
'(face
tabs spaces trailing lines space-before-tab newline
indentation empty space-after-tab
- space-mark tab-mark newline-mark)
+ space-mark tab-mark newline-mark
+ missing-newline-at-eof)
"Specify which kind of blank is visualized.
It's a list containing some or all of the following values:
@@ -326,6 +314,11 @@ It's a list containing some or all of the following values:
It has effect only if `face' (see above)
is present in `whitespace-style'.
+ missing-newline-at-eof Missing newline at the end of the file is
+ visualized via faces.
+ It has effect only if `face' (see above)
+ is present in `whitespace-style'.
+
empty empty lines at beginning and/or end of buffer
are visualized via faces.
It has effect only if `face' (see above)
@@ -439,6 +432,8 @@ See also `whitespace-display-mappings' for documentation."
(const :tag "(Face) Lines" lines)
(const :tag "(Face) Lines, only overlong part" lines-tail)
(const :tag "(Face) NEWLINEs" newline)
+ (const :tag "(Face) Missing newlines at EOB"
+ missing-newline-at-eof)
(const :tag "(Face) Empty Lines At BOB And/Or EOB" empty)
(const :tag "(Face) Indentation SPACEs" indentation::tab)
(const :tag "(Face) Indentation TABs"
@@ -586,6 +581,10 @@ line. Used when `whitespace-style' includes the value `indentation'.")
"Face used to visualize big indentation."
:group 'whitespace)
+(defface whitespace-missing-newline-at-eof
+ '((((class mono)) :inverse-video t :weight bold :underline t)
+ (t :background "#d0d040" :foreground "black"))
+ "Face used to visualize missing newline at the end of the file.")
(defvar whitespace-empty 'whitespace-empty
"Symbol face used to visualize empty lines at beginning and/or end of buffer.
@@ -594,7 +593,7 @@ Used when `whitespace-style' includes the value `empty'.")
(defface whitespace-empty
'((((class mono)) :inverse-video t :weight bold :underline t)
- (t :background "yellow" :foreground "firebrick"))
+ (t :background "yellow" :foreground "firebrick" :extend t))
"Face used to visualize empty lines at beginning and/or end of buffer."
:group 'whitespace)
@@ -717,7 +716,7 @@ and the cons cdr is used for TABs visualization.
Used when `whitespace-style' includes `indentation',
`indentation::tab' or `indentation::space'."
:type '(cons (string :tag "Indentation SPACEs")
- (string :tag "Indentation TABs"))
+ (regexp :tag "Indentation TABs"))
:group 'whitespace)
@@ -1001,8 +1000,8 @@ See also `whitespace-style', `whitespace-newline' and
((eq whitespace-global-modes t))
((listp whitespace-global-modes)
(if (eq (car-safe whitespace-global-modes) 'not)
- (not (memq major-mode (cdr whitespace-global-modes)))
- (memq major-mode whitespace-global-modes)))
+ (not (apply #'derived-mode-p (cdr whitespace-global-modes)))
+ (apply #'derived-mode-p whitespace-global-modes)))
(t nil))
;; ...we have a display (not running a batch job)
(not noninteractive)
@@ -1040,6 +1039,9 @@ See also `whitespace-newline' and `whitespace-display-mappings'."
1 -1))
;; sync states (running a batch job)
(setq global-whitespace-newline-mode global-whitespace-mode)))
+(make-obsolete 'global-whitespace-newline-mode
+ "use `global-whitespace-mode' with `whitespace-style' set to `(newline-mark newline)' instead."
+ "28.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1700,6 +1702,8 @@ cleaning up these problems."
(whitespace-space-after-tab-regexp 'tab))
((eq (car option) 'space-after-tab::space)
(whitespace-space-after-tab-regexp 'space))
+ ((eq (car option) 'missing-newline-at-eof)
+ "[^\n]\\'")
(t
(cdr option)))))
(when (re-search-forward regexp rend t)
@@ -1985,13 +1989,13 @@ resultant list will be returned."
;; prepare local hooks
(add-hook 'write-file-functions 'whitespace-write-file-hook nil t)
;; create whitespace local buffer environment
- (set (make-local-variable 'whitespace-font-lock-keywords) nil)
- (set (make-local-variable 'whitespace-display-table) nil)
- (set (make-local-variable 'whitespace-display-table-was-local) nil)
- (set (make-local-variable 'whitespace-active-style)
- (if (listp whitespace-style)
- whitespace-style
- (list whitespace-style)))
+ (setq-local whitespace-font-lock-keywords nil)
+ (setq-local whitespace-display-table nil)
+ (setq-local whitespace-display-table-was-local nil)
+ (setq-local whitespace-active-style
+ (if (listp whitespace-style)
+ whitespace-style
+ (list whitespace-style)))
;; turn on whitespace
(when whitespace-active-style
(whitespace-color-on)
@@ -2033,19 +2037,14 @@ resultant list will be returned."
"Turn on color visualization."
(when (whitespace-style-face-p)
;; save current point and refontify when necessary
- (set (make-local-variable 'whitespace-point)
- (point))
+ (setq-local whitespace-point (point))
(setq whitespace-point--used
(let ((ol (make-overlay (point) (point) nil nil t)))
(delete-overlay ol) ol))
- (set (make-local-variable 'whitespace-font-lock-refontify)
- 0)
- (set (make-local-variable 'whitespace-bob-marker)
- (point-min-marker))
- (set (make-local-variable 'whitespace-eob-marker)
- (point-max-marker))
- (set (make-local-variable 'whitespace-buffer-changed)
- nil)
+ (setq-local whitespace-font-lock-refontify 0)
+ (setq-local whitespace-bob-marker (point-min-marker))
+ (setq-local whitespace-eob-marker (point-max-marker))
+ (setq-local whitespace-buffer-changed nil)
(add-hook 'post-command-hook #'whitespace-post-command-hook nil t)
(add-hook 'before-change-functions #'whitespace-buffer-changed nil t)
;; Add whitespace-mode color into font lock.
@@ -2067,16 +2066,7 @@ resultant list will be returned."
,@(when (or (memq 'lines whitespace-active-style)
(memq 'lines-tail whitespace-active-style))
;; Show "long" lines.
- `((,(let ((line-column (or whitespace-line-column fill-column)))
- (format
- "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$"
- tab-width
- (1- tab-width)
- (/ line-column tab-width)
- (let ((rem (% line-column tab-width)))
- (if (zerop rem)
- ""
- (format ".\\{%d\\}" rem)))))
+ `((,#'whitespace-lines-regexp
,(if (memq 'lines whitespace-active-style)
0 ; whole line
2) ; line tail
@@ -2131,7 +2121,16 @@ resultant list will be returned."
((memq 'space-after-tab::space whitespace-active-style)
;; Show SPACEs after TAB (TABs).
(whitespace-space-after-tab-regexp 'space)))
- 1 whitespace-space-after-tab t)))))
+ 1 whitespace-space-after-tab t)))
+ ,@(when (memq 'missing-newline-at-eof whitespace-active-style)
+ ;; Show missing newline.
+ `(("[^\n]\\'" 0
+ ;; Don't mark the end of the buffer is point is there --
+ ;; it probably means that the user is typing something
+ ;; at the end of the buffer.
+ (and (/= whitespace-point (point-max))
+ 'whitespace-missing-newline-at-eof)
+ t)))))
(font-lock-add-keywords nil whitespace-font-lock-keywords t)
(font-lock-flush)))
@@ -2177,6 +2176,19 @@ resultant list will be returned."
(setq status nil))) ;; end of buffer
status))
+(defun whitespace-lines-regexp (limit)
+ (re-search-forward
+ (let ((line-column (or whitespace-line-column fill-column)))
+ (format
+ "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$"
+ tab-width
+ (1- tab-width)
+ (/ line-column tab-width)
+ (let ((rem (% line-column tab-width)))
+ (if (zerop rem)
+ ""
+ (format ".\\{%d\\}" rem)))))
+ limit t))
(defun whitespace-empty-at-bob-regexp (limit)
"Match spaces at beginning of buffer which do not contain the point at \
@@ -2446,7 +2458,8 @@ It should be added buffer-locally to `write-file-functions'."
(provide 'whitespace)
-
+(make-obsolete-variable 'whitespace-load-hook
+ "use `with-eval-after-load' instead." "28.1")
(run-hooks 'whitespace-load-hook)
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index 34062c9b36b..54b71c9f9f6 100644
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -1,7 +1,7 @@
-;;; wid-browse.el --- functions for browsing widgets
-;;
+;;; wid-browse.el --- functions for browsing widgets -*- lexical-binding: t -*-
+
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
-;;
+
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Package: emacs
@@ -22,13 +22,11 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; Widget browser. See `widget.el'.
;;; Code:
-(require 'easymenu)
-(require 'custom)
(require 'wid-edit)
(defgroup widget-browse nil
@@ -40,7 +38,7 @@
(defvar widget-browse-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map widget-keymap)
- (define-key map "q" 'bury-buffer)
+ (define-key map "q" #'bury-buffer)
map)
"Keymap for `widget-browse-mode'.")
@@ -57,11 +55,10 @@
["Browse At" widget-browse-at t]))
(defcustom widget-browse-mode-hook nil
- "Hook called when entering widget-browse-mode."
- :type 'hook
- :group 'widget-browse)
+ "Hook run after entering `widget-browse-mode'."
+ :type 'hook)
-(defun widget-browse-mode ()
+(define-derived-mode widget-browse-mode special-mode "Widget Browse"
"Major mode for widget browser buffers.
The following commands are available:
@@ -69,17 +66,7 @@ The following commands are available:
\\[widget-forward] Move to next button or editable field.
\\[widget-backward] Move to previous button or editable field.
\\[widget-button-click] Activate button under the mouse pointer.
-\\[widget-button-press] Activate button under point.
-
-Entry to this mode calls the value of `widget-browse-mode-hook'
-if that value is non-nil."
- (kill-all-local-variables)
- (setq major-mode 'widget-browse-mode
- mode-name "Widget")
- (use-local-map widget-browse-mode-map)
- (easy-menu-add widget-browse-mode-customize-menu)
- (easy-menu-add widget-browse-mode-menu)
- (run-mode-hooks 'widget-browse-mode-hook))
+\\[widget-button-press] Activate button under point.")
(put 'widget-browse-mode 'mode-class 'special)
@@ -187,17 +174,17 @@ if that value is non-nil."
(define-widget 'widget-browse 'push-button
"Button for creating a widget browser.
-The :value of the widget shuld be the widget to be browsed."
+The :value of the widget should be the widget to be browsed."
:format "%[[%v]%]"
:value-create 'widget-browse-value-create
:action 'widget-browse-action)
(defun widget-browse-action (widget &optional _event)
- ;; Create widget browser for WIDGET's :value.
+ "Create widget browser for :value of WIDGET."
(widget-browse (widget-get widget :value)))
(defun widget-browse-value-create (widget)
- ;; Insert type name.
+ "Insert type name for WIDGET."
(let ((value (widget-get widget :value)))
(cond ((symbolp value)
(insert (symbol-name value)))
@@ -276,8 +263,6 @@ VALUE is assumed to be a list of widgets."
"Minor mode for traversing widgets."
:lighter " Widget")
-;;; The End:
-
(provide 'wid-browse)
;;; wid-browse.el ends here
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index ec3a1c9693e..9a34dc8d438 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -131,16 +131,21 @@ This exists as a variable so it can be set locally in certain buffers.")
(((class grayscale color)
(background light))
:background "gray85"
+ ;; We use negative thickness of the horizontal box border line to
+ ;; avoid making lines taller when fields become visible.
+ :box (:line-width (1 . -1) :color "gray80")
:extend t)
(((class grayscale color)
(background dark))
:background "dim gray"
+ :box (:line-width (1 . -1) :color "gray46")
:extend t)
(t
:slant italic
:extend t))
"Face used for editable fields."
- :group 'widget-faces)
+ :group 'widget-faces
+ :version "28.1")
(defface widget-single-line-field '((((type tty))
:background "green3"
@@ -203,27 +208,100 @@ nil means read a single character."
:group 'widgets
:type 'boolean)
+(defun widget--simplify-menu (extended)
+ "Convert the EXTENDED menu into a menu composed of simple menu items.
+
+Each item in the simplified menu is of the form (ITEM-STRING . REAL-BINDING),
+where both elements are taken from the EXTENDED MENU. ITEM-STRING is the
+correspondent ITEM-NAME in the menu-item entry:
+ (menu-item ITEM-NAME REAL-BINDING . ITEM-PROPERTY-LIST), and REAL-BINDING is
+the symbol in the key vector, as in `define-key'.
+ (See `(elisp)Defining Menus' for more information.)
+
+Only visible, enabled and meaningful menu items make their way into
+the returned simplified menu. That is:
+For the menu item to be visible, it has to either lack a :visible form in its
+item-property-list, or the :visible form has to evaluate to a non-nil value.
+For the menu item to be enabled, it has to either lack a :enabled form in its
+item-property-list, or the :enable form has to evaluate to a non-nil value.
+Additionally, if the menu item is a radio button, then its selected form has
+to evaluate to nil for the menu item to be meaningful."
+ (let (simplified)
+ (map-keymap (lambda (ev def)
+ (when (and (eq (nth 0 def) 'menu-item)
+ (nth 2 def)) ; Only menu-items with a real binding.
+ ;; Loop through the item-property-list, looking for
+ ;; :visible, :enable (or :active) and :button properties.
+ (let ((plist (nthcdr 3 def))
+ (enable t) ; Enabled by default.
+ (visible t) ; Visible by default.
+ selected keyword value)
+ (while (and plist (cdr plist)
+ (keywordp (setq keyword (car plist))))
+ (setq value (cadr plist))
+ (cond ((memq keyword '(:visible :included))
+ (setq visible value))
+ ((memq keyword '(:enable :active))
+ (setq enable value))
+ ((and (eq keyword :button)
+ (eq (car value) :radio))
+ (setq selected (cdr value))))
+ (setq plist (cddr plist)))
+ (when (and (eval visible)
+ (eval enable)
+ (or (not selected)
+ (not (eval selected))))
+ (push (cons (nth 1 def) ev) simplified)))))
+ extended)
+ (reverse simplified)))
+
(defun widget-choose (title items &optional event)
"Choose an item from a list.
First argument TITLE is the name of the list.
-Second argument ITEMS is a list whose members are either
+Second argument ITEMS should be a menu, either with simple item definitions,
+or with extended item definitions.
+When ITEMS has simple item definitions, it is a list whose members are either
(NAME . VALUE), to indicate selectable items, or just strings to
indicate unselectable items.
+
+When ITEMS is a menu that uses an extended format, then ITEMS should be a
+keymap, and each binding should look like this:
+ (menu-item ITEM-NAME REAL-BINDING . ITEM-PROPERTY-LIST)
+or like this: (menu-item ITEM-NAME) to indicate a non-selectable item.
+REAL-BINDING should be a symbol, and should not be a keymap, because submenus
+are not supported.
+
Optional third argument EVENT is an input event.
-The user is asked to choose between each NAME from the items alist,
-and the VALUE of the chosen element will be returned. If EVENT is a
-mouse event, and the number of elements in items is less than
+If EVENT is a mouse event, and the number of elements in items is less than
`widget-menu-max-size', a popup menu will be used, otherwise the
-minibuffer."
+minibuffer.
+
+The user is asked to choose between each NAME from ITEMS.
+If ITEMS has simple item definitions, then this function returns the VALUE of
+the chosen element. If ITEMS is a keymap, then the return value is the symbol
+in the key vector, as in the argument of `define-key'."
(cond ((and (< (length items) widget-menu-max-size)
event (display-popup-menus-p))
;; Mouse click.
- (x-popup-menu event
- (list title (cons "" items))))
+ (if (keymapp items)
+ ;; Modify the keymap prompt, and then restore the old one, if any.
+ (let ((prompt (keymap-prompt items)))
+ (unwind-protect
+ (progn
+ (setq items (delete prompt items))
+ (push title (cdr items))
+ ;; Return just the first element of the list of events.
+ (car (x-popup-menu event items)))
+ (setq items (delete title items))
+ (when prompt
+ (push prompt (cdr items)))))
+ (x-popup-menu event (list title (cons "" items)))))
((or widget-menu-minibuffer-flag
(> (length items) widget-menu-max-shortcuts))
+ (when (keymapp items)
+ (setq items (widget--simplify-menu items)))
;; Read the choice of name from the minibuffer.
(setq items (cl-remove-if 'stringp items))
(let ((val (completing-read (concat title ": ") items nil t)))
@@ -233,11 +311,12 @@ minibuffer."
(setq val try))
(cdr (assoc val items))))))
(t
+ (when (keymapp items)
+ (setq items (widget--simplify-menu items)))
;; Construct a menu of the choices
;; and then use it for prompting for a single character.
(let* ((next-digit ?0)
- (map (make-sparse-keymap))
- choice some-choice-enabled value)
+ alist choice some-choice-enabled value)
(with-current-buffer (get-buffer-create " widget-choose")
(erase-buffer)
(insert "Available choices:\n\n")
@@ -247,7 +326,7 @@ minibuffer."
(let* ((name (substitute-command-keys (car choice)))
(function (cdr choice)))
(insert (format "%c = %s\n" next-digit name))
- (define-key map (vector next-digit) function)
+ (push (cons next-digit function) alist)
(setq some-choice-enabled t)))
;; Allocate digits to disabled alternatives
;; so that the digit of a given alternative never varies.
@@ -257,33 +336,17 @@ minibuffer."
(forward-line))
(or some-choice-enabled
(error "None of the choices is currently meaningful"))
- (define-key map [?\M-\C-v] 'scroll-other-window)
- (define-key map [?\M--] 'negative-argument)
(save-window-excursion
- (let ((buf (get-buffer " widget-choose")))
- (display-buffer buf
- '(display-buffer-in-direction
- (direction . bottom)
- (window-height . fit-window-to-buffer)))
- (let ((cursor-in-echo-area t)
- (arg 1))
- (while (not value)
- (setq value (lookup-key map (read-key-sequence (format "%s: " title))))
- (unless value
- (user-error "Canceled"))
- (when
- (cond ((eq value 'scroll-other-window)
- (let ((minibuffer-scroll-window
- (get-buffer-window buf)))
- (if (> 0 arg)
- (scroll-other-window-down
- (window-height minibuffer-scroll-window))
- (scroll-other-window))
- (setq arg 1)))
- ((eq value 'negative-argument)
- (setq arg -1)))
- (setq value nil))))))
- value))))
+ ;; Select window to be able to scroll it from minibuffer
+ (with-selected-window
+ (display-buffer (get-buffer " widget-choose")
+ '(display-buffer-in-direction
+ (direction . bottom)
+ (window-height . fit-window-to-buffer)))
+ (setq value (read-char-choice
+ (format "%s: " title)
+ (mapcar #'car alist)))))
+ (cdr (assoc value alist))))))
;;; Widget text specifications.
;;
@@ -320,12 +383,15 @@ the :notify function can't know the new value.")
(or (not widget-field-add-space) (widget-get widget :size))))
(if (functionp help-echo)
(setq help-echo 'widget-mouse-help))
- (when (= (char-before to) ?\n)
+ (when (and (or (> to (1+ from)) (null (widget-get widget :size)))
+ (= (char-before to) ?\n))
;; When the last character in the field is a newline, we want to
;; give it a `field' char-property of `boundary', which helps the
;; C-n/C-p act more naturally when entering/leaving the field. We
- ;; do this by making a small secondary overlay to contain just that
- ;; one character.
+ ;; do this by making a small secondary overlay to contain just that
+ ;; one character. BUT we only do this if there is more than one
+ ;; character (so we don't do this for the character widget),
+ ;; or if the size of the editable field isn't specified.
(let ((overlay (make-overlay (1- to) to nil t nil)))
(overlay-put overlay 'field 'boundary)
;; We need the real field for tabbing.
@@ -530,9 +596,25 @@ Otherwise, just return the value."
(widget-put widget :args args)))
(widget-apply widget :default-get)))))
+(defun widget-inline-p (widget &optional bubblep)
+ "Non-nil if the widget WIDGET is inline.
+
+With BUBBLEP non-nil, check also if WIDGET has a member that bubbles its inline
+property (if any), up to WIDGET, so that WIDGET can act as an inline widget."
+ (or (widget-get widget :inline)
+ (and bubblep
+ (widget-get widget :inline-bubbles-p)
+ (widget-apply widget :inline-bubbles-p))))
+
(defun widget-match-inline (widget vals)
- "In WIDGET, match the start of VALS."
- (cond ((widget-get widget :inline)
+ "In WIDGET, match the start of VALS.
+
+For an inline widget or for a widget that acts like one (see `widget-inline-p'),
+try to match elements in VALS as far as possible. Otherwise, match the first
+element of the list VALS.
+
+Return a list whose car contains all members of VALS that matched WIDGET."
+ (cond ((widget-inline-p widget t)
(widget-apply widget :match-inline vals))
((and (listp vals)
(widget-apply widget :match (car vals)))
@@ -594,6 +676,63 @@ respectively."
(if (and widget (funcall function widget maparg))
(setq overlays nil)))))
+(defun widget-describe (&optional widget-or-pos)
+ "Describe the widget at point.
+Displays a buffer with information about the widget (e.g., its actions) as well
+as a link to browse all the properties of the widget.
+
+This command resolves the indirection of widgets running the action of its
+parents, so the real action executed can be known.
+
+When called from Lisp, pass WIDGET-OR-POS as the widget to describe,
+or a buffer position where a widget is present. If WIDGET-OR-POS is nil,
+the widget at point is the widget to describe."
+ (interactive "d")
+ (require 'wid-browse) ; The widget-browse widget.
+ (let ((widget (if (widgetp widget-or-pos)
+ widget-or-pos
+ (widget-at widget-or-pos)))
+ props)
+ (when widget
+ (help-setup-xref (list #'widget-describe widget)
+ (called-interactively-p 'interactive))
+ (setq props (list (cons 'action (widget--resolve-parent-action widget))
+ (cons 'mouse-down-action
+ (widget-get widget :mouse-down-action))))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (widget-insert "This widget's type is ")
+ (widget-create 'widget-browse :format "%[%v%]\n%d"
+ :doc (get (car widget) 'widget-documentation)
+ :help-echo "Browse this widget's properties"
+ widget)
+ (dolist (action '(action mouse-down-action))
+ (let ((name (symbol-name action))
+ (val (alist-get action props)))
+ (when (functionp val)
+ (widget-insert "\n\n" (propertize (capitalize name) 'face 'bold)
+ "'\nThe " name " of this widget is")
+ (if (symbolp val)
+ (progn (widget-insert " ")
+ (widget-create 'function-link :value val
+ :button-prefix "" :button-suffix ""
+ :help-echo "Describe this function"))
+ (widget-insert "\n")
+ (princ val)))))))
+ (widget-setup)
+ t)))
+
+(defun widget--resolve-parent-action (widget)
+ "Resolve the real action of WIDGET up its inheritance chain.
+Follow the WIDGET's parents, until its :action is no longer
+`widget-parent-action', and return its value."
+ (let ((action (widget-get widget :action))
+ (parent (widget-get widget :parent)))
+ (while (eq action 'widget-parent-action)
+ (setq parent (widget-get parent :parent)
+ action (widget-get parent :action)))
+ action))
+
;;; Images.
(defcustom widget-image-directory (file-name-as-directory
@@ -611,7 +750,7 @@ automatically."
:type 'boolean)
(defcustom widget-image-conversion
- '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
+ '((svg ".svg") (xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
(xbm ".xbm"))
"Conversion alist from image formats to file name suffixes."
:group 'widgets
@@ -885,9 +1024,8 @@ button end points."
Recommended as a parent keymap for modes using widgets.
Note that such modes will need to require wid-edit.")
-(defvar widget-global-map global-map
+(defvar-local widget-global-map global-map
"Keymap used for events a widget does not handle itself.")
-(make-variable-buffer-local 'widget-global-map)
(defvar widget-field-keymap
(let ((map (copy-keymap widget-keymap)))
@@ -933,86 +1071,91 @@ Note that such modes will need to require wid-edit.")
"If non-nil, `widget-button-click' moves point to a button after invoking it.
If nil, point returns to its original position after invoking a button.")
+(defun widget-button--check-and-call-button (event button)
+ "Call BUTTON if BUTTON is a widget and EVENT is correct for it.
+If nothing was called, return non-nil."
+ (let* ((oevent event)
+ (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1)))
+ (pos (widget-event-point event))
+ newpoint)
+ (catch 'button-press-cancelled
+ ;; Mouse click on a widget button. Do the following
+ ;; in a save-excursion so that the click on the button
+ ;; doesn't change point.
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (save-excursion
+ (goto-char (posn-point (event-start event)))
+ (let* ((overlay (widget-get button :button-overlay))
+ (pressed-face (or (widget-get button :pressed-face)
+ widget-button-pressed-face))
+ (face (overlay-get overlay 'face))
+ (mouse-face (overlay-get overlay 'mouse-face)))
+ (unwind-protect
+ ;; Read events, including mouse-movement
+ ;; events, waiting for a release event. If we
+ ;; began with a mouse-1 event and receive a
+ ;; movement event, that means the user wants
+ ;; to perform drag-selection, so cancel the
+ ;; button press and do the default mouse-1
+ ;; action. For mouse-2, just highlight/
+ ;; unhighlight the button the mouse was
+ ;; initially on when we move over it.
+ (save-excursion
+ (when face ; avoid changing around image
+ (overlay-put overlay 'face pressed-face)
+ (overlay-put overlay 'mouse-face pressed-face))
+ (unless (widget-apply button :mouse-down-action event)
+ (let ((track-mouse t))
+ (while (not (widget-button-release-event-p event))
+ (setq event (read--potential-mouse-event))
+ (when (and mouse-1 (mouse-movement-p event))
+ (push event unread-command-events)
+ (setq event oevent)
+ (throw 'button-press-cancelled t))
+ (unless (or (integerp event)
+ (memq (car event)
+ '(switch-frame select-window))
+ (eq (car event) 'scroll-bar-movement))
+ (setq pos (widget-event-point event))
+ (if (and pos
+ (eq (get-char-property pos 'button)
+ button))
+ (when face
+ (overlay-put overlay 'face pressed-face)
+ (overlay-put overlay 'mouse-face pressed-face))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face))))))
+
+ ;; When mouse is released over the button, run
+ ;; its action function.
+ (when (and pos (eq (get-char-property pos 'button) button))
+ (goto-char pos)
+ (widget-apply-action button event)
+ (if widget-button-click-moves-point
+ (setq newpoint (point)))))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face))))
+
+ (when newpoint
+ (goto-char newpoint)))
+ nil)))
+
(defun widget-button-click (event)
"Invoke the button that the mouse is pointing at."
(interactive "e")
(if (widget-event-point event)
- (let* ((oevent event)
- (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1)))
+ (let* ((mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1)))
(pos (widget-event-point event))
(start (event-start event))
- (button (get-char-property
+ (button (get-char-property
pos 'button (and (windowp (posn-window start))
- (window-buffer (posn-window start)))))
- newpoint)
+ (window-buffer (posn-window start))))))
+
(when (or (null button)
- (catch 'button-press-cancelled
- ;; Mouse click on a widget button. Do the following
- ;; in a save-excursion so that the click on the button
- ;; doesn't change point.
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (save-excursion
- (goto-char (posn-point (event-start event)))
- (let* ((overlay (widget-get button :button-overlay))
- (pressed-face (or (widget-get button :pressed-face)
- widget-button-pressed-face))
- (face (overlay-get overlay 'face))
- (mouse-face (overlay-get overlay 'mouse-face)))
- (unwind-protect
- ;; Read events, including mouse-movement
- ;; events, waiting for a release event. If we
- ;; began with a mouse-1 event and receive a
- ;; movement event, that means the user wants
- ;; to perform drag-selection, so cancel the
- ;; button press and do the default mouse-1
- ;; action. For mouse-2, just highlight/
- ;; unhighlight the button the mouse was
- ;; initially on when we move over it.
- (save-excursion
- (when face ; avoid changing around image
- (overlay-put overlay 'face pressed-face)
- (overlay-put overlay 'mouse-face pressed-face))
- (unless (widget-apply button :mouse-down-action event)
- (let ((track-mouse t))
- (while (not (widget-button-release-event-p event))
- (setq event (read-event))
- (when (and mouse-1 (mouse-movement-p event))
- (push event unread-command-events)
- (setq event oevent)
- (throw 'button-press-cancelled t))
- (unless (or (integerp event)
- (memq (car event) '(switch-frame select-window))
- (eq (car event) 'scroll-bar-movement))
- (setq pos (widget-event-point event))
- (if (and pos
- (eq (get-char-property pos 'button)
- button))
- (when face
- (overlay-put overlay 'face pressed-face)
- (overlay-put overlay 'mouse-face pressed-face))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face))))))
-
- ;; When mouse is released over the button, run
- ;; its action function.
- (when (and pos (eq (get-char-property pos 'button) button))
- (goto-char pos)
- (widget-apply-action button event)
- (if widget-button-click-moves-point
- (setq newpoint (point)))))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face))))
-
- (if newpoint (goto-char newpoint))
- ;; This loses if the widget action switches windows. -- cyd
- ;; (unless (pos-visible-in-window-p (widget-event-point event))
- ;; (mouse-set-point event)
- ;; (beginning-of-line)
- ;; (recenter))
- )
- nil))
- (let ((up t) command)
+ (widget-button--check-and-call-button event button))
+ (let ((up t)
+ command)
;; Mouse click not on a widget button. Find the global
;; command to run, and check whether it is bound to an
;; up event.
@@ -1030,7 +1173,7 @@ If nil, point returns to its original position after invoking a button.")
(when up
;; Don't execute up events twice.
(while (not (widget-button-release-event-p event))
- (setq event (read-event))))
+ (setq event (read--potential-mouse-event))))
(when command
(call-interactively command)))))
(message "You clicked somewhere weird.")))
@@ -1065,7 +1208,6 @@ This is much faster.")
ARG may be negative to move backward.
When the second optional argument is non-nil,
nothing is shown in the echo area."
- (or (bobp) (> arg 0) (backward-char))
(let ((wrapped 0)
(number arg)
(old (widget-tabable-at)))
@@ -1188,13 +1330,11 @@ When not inside a field, signal an error."
;;; Setting up the buffer.
-(defvar widget-field-new nil
+(defvar-local widget-field-new nil
"List of all newly created editable fields in the buffer.")
-(make-variable-buffer-local 'widget-field-new)
-(defvar widget-field-list nil
+(defvar-local widget-field-list nil
"List of all editable fields in the buffer.")
-(make-variable-buffer-local 'widget-field-list)
(defun widget-at (&optional pos)
"The button or field at POS (default, point)."
@@ -1221,13 +1361,11 @@ When not inside a field, signal an error."
(widget-clear-undo)
(widget-add-change))
-(defvar widget-field-last nil)
-;; Last field containing point.
-(make-variable-buffer-local 'widget-field-last)
+(defvar-local widget-field-last nil
+ "Last field containing point.")
-(defvar widget-field-was nil)
-;; The widget data before the change.
-(make-variable-buffer-local 'widget-field-was)
+(defvar-local widget-field-was nil
+ "The widget data before the change.")
(defun widget-field-at (pos)
"Return the widget field at POS, or nil if none."
@@ -1321,7 +1459,8 @@ Unlike (get-char-property POS \\='field), this works with empty fields too."
(signal 'text-read-only
'("Attempt to change text outside editable field")))
(widget-field-use-before-change
- (widget-apply from-field :notify from-field))))))
+ (widget-apply from-field :notify
+ from-field (list 'before-change from to)))))))
(defun widget-add-change ()
(remove-hook 'post-command-hook 'widget-add-change t)
@@ -1358,7 +1497,7 @@ Unlike (get-char-property POS \\='field), this works with empty fields too."
(> (point) begin))
(delete-char -1)))))))
(widget-specify-secret field))
- (widget-apply field :notify field))))
+ (widget-apply field :notify field (list 'after-change from to)))))
;;; Widget Functions
;;
@@ -1739,20 +1878,9 @@ as the argument to `documentation-property'."
(let ((value (widget-get widget :value)))
(and (listp value)
(<= (length value) (length vals))
- (let ((head (widget-sublist vals 0 (length value))))
+ (let ((head (seq-subseq vals 0 (length value))))
(and (equal head value)
- (cons head (widget-sublist vals (length value))))))))
-
-(defun widget-sublist (list start &optional end)
- "Return the sublist of LIST from START to END.
-If END is omitted, it defaults to the length of LIST."
- (if (> start 0) (setq list (nthcdr start list)))
- (if end
- (unless (<= end start)
- (setq list (copy-sequence list))
- (setcdr (nthcdr (- end start 1) list) nil)
- list)
- (copy-sequence list)))
+ (cons head (seq-subseq vals (length value))))))))
(defun widget-item-action (widget &optional event)
;; Just notify itself.
@@ -1871,6 +1999,16 @@ If END is omitted, it defaults to the length of LIST."
"Show the variable specified by WIDGET."
(describe-variable (widget-value widget)))
+;;; The `face-link' Widget.
+
+(define-widget 'face-link 'link
+ "A link to an Emacs face."
+ :action 'widget-face-link-action)
+
+(defun widget-face-link-action (widget &optional _event)
+ "Show the variable specified by WIDGET."
+ (describe-face (widget-value widget)))
+
;;; The `file-link' Widget.
(define-widget 'file-link 'link
@@ -2064,7 +2202,7 @@ But if NO-TRUNCATE is non-nil, include them."
(let ((value (widget-get widget :value))
(args (widget-get widget :args))
(explicit (widget-get widget :explicit-choice))
- current)
+ current val inline-p fun)
(if explicit
(progn
;; If the user specified the choice for this value,
@@ -2073,15 +2211,24 @@ But if NO-TRUNCATE is non-nil, include them."
widget explicit value)))
(widget-put widget :choice explicit)
(widget-put widget :explicit-choice nil))
+ (setq inline-p (widget-inline-p widget t))
(while args
(setq current (car args)
args (cdr args))
- (when (widget-apply current :match value)
- (widget-put widget :children (list (widget-create-child-value
- widget current value)))
- (widget-put widget :choice current)
- (setq args nil
- current nil)))
+ (if inline-p
+ (if (widget-get current :inline)
+ (setq val value
+ fun :match-inline)
+ (setq val (car value)
+ fun :match))
+ (setq val value
+ fun :match))
+ (when (widget-apply current fun val)
+ (widget-put widget :children (list (widget-create-child-value
+ widget current val)))
+ (widget-put widget :choice current)
+ (setq args nil
+ current nil)))
(when current
(let ((void (widget-get widget :void)))
(widget-put widget :children (list (widget-create-child-and-convert
@@ -2304,7 +2451,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
(let ((child (widget-create-child widget type)))
(widget-apply child :deactivate)
child))
- ((widget-get type :inline)
+ ((widget-inline-p type t)
(widget-create-child-value
widget type (cdr chosen)))
(t
@@ -2417,9 +2564,9 @@ Return an alist of (TYPE MATCH)."
:button-suffix ""
:button-prefix ""
:on "(*)"
- :on-glyph "radio1"
+ :on-glyph "radio-checked"
:off "( )"
- :off-glyph "radio0")
+ :off-glyph "radio")
(defun widget-radio-button-notify (widget _child &optional event)
;; Tell daddy.
@@ -2587,7 +2734,10 @@ Return an alist of (TYPE MATCH)."
(define-widget 'insert-button 'push-button
"An insert button for the `editable-list' widget."
:tag "INS"
- :help-echo "Insert a new item into the list at this position."
+ :help-echo (lambda (widget)
+ (if (widget-get (widget-get widget :parent) :last-deleted)
+ "Insert back the last deleted item from this list, at this position."
+ "Insert a new item into the list at this position."))
:action 'widget-insert-button-action)
(defun widget-insert-button-action (widget &optional _event)
@@ -2600,7 +2750,7 @@ Return an alist of (TYPE MATCH)."
(define-widget 'delete-button 'push-button
"A delete button for the `editable-list' widget."
:tag "DEL"
- :help-echo "Delete this item from the list."
+ :help-echo "Delete this item from the list, saving it for later reinsertion."
:action 'widget-delete-button-action)
(defun widget-delete-button-action (widget &optional _event)
@@ -2658,7 +2808,7 @@ Return an alist of (TYPE MATCH)."
(if answer
(setq children (cons (widget-editable-list-entry-create
widget
- (if (widget-get type :inline)
+ (if (widget-inline-p type t)
(car answer)
(car (car answer)))
t)
@@ -2690,9 +2840,18 @@ Return an alist of (TYPE MATCH)."
(cons found value)))
(defun widget-editable-list-insert-before (widget before)
- ;; Insert a new child in the list of children.
+ "Insert a new widget as a child of WIDGET.
+
+If there is a recently deleted child, the new widget is that deleted child.
+Otherwise, the new widget is the default child of WIDGET.
+
+The new widget gets inserted at the position of the BEFORE child."
(save-excursion
(let ((children (widget-get widget :children))
+ (last-deleted (when-let ((lst (widget-get widget :last-deleted)))
+ (prog1
+ (pop lst)
+ (widget-put widget :last-deleted lst))))
(inhibit-read-only t)
(inhibit-modification-hooks t))
(cond (before
@@ -2700,7 +2859,11 @@ Return an alist of (TYPE MATCH)."
(t
(goto-char (widget-get widget :value-pos))))
(let ((child (widget-editable-list-entry-create
- widget nil nil)))
+ widget (and last-deleted
+ (widget-apply last-deleted
+ :value-to-external
+ (widget-get last-deleted :value)))
+ last-deleted)))
(when (< (widget-get child :entry-from) (widget-get widget :from))
(set-marker (widget-get widget :from)
(widget-get child :entry-from)))
@@ -2713,6 +2876,15 @@ Return an alist of (TYPE MATCH)."
(widget-apply widget :notify widget))
(defun widget-editable-list-delete-at (widget child)
+ "Delete the widget CHILD from the known children of widget WIDGET.
+
+Save CHILD into the :last-deleted list, so it can be inserted later."
+ ;; Save the current value of CHILD, to use if the user later inserts the
+ ;; widget.
+ (widget-put child :value (widget-apply child :value-get))
+ (let ((lst (widget-get widget :last-deleted)))
+ (push child lst)
+ (widget-put widget :last-deleted lst))
;; Delete child from list of children.
(save-excursion
(let ((buttons (copy-sequence (widget-get widget :buttons)))
@@ -2820,7 +2992,7 @@ Return an alist of (TYPE MATCH)."
(insert-char ?\s (widget-get widget :indent)))
(push (cond ((null answer)
(widget-create-child widget arg))
- ((widget-get arg :inline)
+ ((widget-inline-p arg t)
(widget-create-child-value widget arg (car answer)))
(t
(widget-create-child-value widget arg (car (car answer)))))
@@ -3121,6 +3293,16 @@ It reads a file name from an editable text field."
:completions (completion-table-case-fold
#'completion-file-name-table
(not read-file-name-completion-ignore-case))
+ :match (lambda (widget value)
+ (and (stringp value)
+ (or (not (widget-get widget :must-match))
+ (file-exists-p value))))
+ :validate (lambda (widget)
+ (let ((value (widget-value widget)))
+ (unless (widget-apply widget :match value)
+ (widget-put widget
+ :error (format "File %s does not exist" value))
+ widget)))
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
;; Doesn't work well with terminating newline.
@@ -3132,11 +3314,10 @@ It reads a file name from an editable text field."
(abbreviate-file-name
(if unbound
(read-file-name prompt)
- (let ((prompt2 (format "%s (default %s): " prompt value))
- (dir (file-name-directory value))
+ (let ((dir (file-name-directory value))
(file (file-name-nondirectory value))
(must-match (widget-get widget :must-match)))
- (read-file-name prompt2 dir nil must-match file)))))
+ (read-file-name (format-prompt prompt value) dir nil must-match file)))))
;;;(defun widget-file-action (widget &optional event)
;;; ;; Read a file name from the minibuffer.
@@ -3248,10 +3429,10 @@ It reads a directory name from an editable text field."
"Read coding-system from minibuffer."
(if (widget-get widget :base-only)
(intern
- (completing-read (format "%s (default %s): " prompt value)
+ (completing-read (format-prompt prompt value)
(mapcar #'list (coding-system-list t)) nil nil nil
coding-system-history))
- (read-coding-system (format "%s (default %s): " prompt value) value)))
+ (read-coding-system (format-prompt prompt value) value)))
(defun widget-coding-system-action (widget &optional event)
(let ((answer
@@ -3294,14 +3475,16 @@ It reads a directory name from an editable text field."
:help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value"
:tag "Key sequence")
+;; FIXME: Consider combining this with help--read-key-sequence which
+;; can also read double and triple mouse events.
(defun widget-key-sequence-read-event (ev)
(interactive (list
(let ((inhibit-quit t) quit-flag)
- (read-event "Insert KEY, EVENT, or CODE: "))))
+ (read-key "Insert KEY, EVENT, or CODE: " t))))
(let ((ev2 (and (memq 'down (event-modifiers ev))
- (read-event)))
- (tr (and (keymapp function-key-map)
- (lookup-key function-key-map (vector ev)))))
+ (read-key nil t)))
+ (tr (and (keymapp local-function-key-map)
+ (lookup-key local-function-key-map (vector ev)))))
(when (and (integerp ev)
(or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
(and (<= ?a (downcase ev))
@@ -3416,8 +3599,31 @@ To use this type, you must define :match or :match-alternatives."
:match 'widget-restricted-sexp-match
:value-to-internal (lambda (widget value)
(if (widget-apply widget :match value)
- (prin1-to-string value)
- value)))
+ (widget-sexp-value-to-internal widget value)
+ value))
+ :value-to-external (lambda (widget value)
+ ;; We expect VALUE to be a string, so we can convert it
+ ;; into the external format just by `read'ing it.
+ ;; But for a restricted-sexp widget with a bad default
+ ;; value, we might end up calling read with a nil
+ ;; argument, resulting in an undesired prompt to the
+ ;; user. A bad default value is not always a big
+ ;; problem, but might end up in a messed up buffer,
+ ;; so display a warning here. (Bug#25152)
+ (unless (stringp value)
+ (display-warning
+ 'widget-bad-default-value
+ (format-message
+ "\nA widget of type %S has a bad default value.
+value: %S
+match function: %S
+match-alternatives: %S"
+ (widget-type widget)
+ value
+ (widget-get widget :match)
+ (widget-get widget :match-alternatives))
+ :warning))
+ (read value)))
(defun widget-restricted-sexp-match (widget value)
(let ((alternatives (widget-get widget :match-alternatives))
@@ -3459,19 +3665,76 @@ To use this type, you must define :match or :match-alternatives."
:value 0
:size 1
:format "%{%t%}: %v\n"
- :valid-regexp "\\`.\\'"
+ :valid-regexp "\\`\\(.\\|\n\\)\\'"
:error "This field should contain a single character"
:value-get (lambda (w) (widget-field-value-get w t))
:value-to-internal (lambda (_widget value)
(if (stringp value)
value
- (char-to-string value)))
+ (let ((disp
+ (widget-character--change-character-display
+ value)))
+ (if disp
+ (propertize (char-to-string value) 'display disp)
+ (char-to-string value)))))
:value-to-external (lambda (_widget value)
(if (stringp value)
(aref value 0)
value))
:match (lambda (_widget value)
- (characterp value)))
+ (characterp value))
+ :notify #'widget-character-notify)
+
+;; Only some escape sequences, not all of them. (Bug#15925)
+(defvar widget-character--escape-sequences-alist
+ '((?\t . ?t)
+ (?\n . ?n)
+ (?\s . ?s))
+ "Alist that associates escape sequences to a character.
+Each element has the form (ESCAPE-SEQUENCE . CHARACTER).
+
+The character widget uses this alist to display the
+non-printable character represented by ESCAPE-SEQUENCE as \\CHARACTER,
+since that makes it easier to see what's in the widget.")
+
+(defun widget-character--change-character-display (c)
+ "Return a string to represent the character C, or nil.
+
+The character widget represents some characters (e.g., the newline character
+or the tab character) specially, to make it easier for the user to see what's
+in it. For those characters, return a string to display that character in a
+more user-friendly way.
+
+For the caller, nil should mean that it is good enough to use the return value
+of `char-to-string' for the representation of C."
+ (let ((char (alist-get c widget-character--escape-sequences-alist)))
+ (and char (propertize (format "\\%c" char) 'face 'escape-glyph))))
+
+(defun widget-character-notify (widget child &optional event)
+ "Notify function for the character widget.
+
+This function allows the widget character to better display some characters,
+like the newline character or the tab character."
+ (when (eq (car-safe event) 'after-change)
+ (let* ((start (nth 1 event))
+ (end (nth 2 event))
+ str)
+ (if (eql start end)
+ (when (char-equal (widget-value widget) ?\s)
+ ;; The character widget is not really empty:
+ ;; its value is a single space character.
+ ;; We need to propertize it again, if it became empty for a while.
+ (let ((ov (widget-get widget :field-overlay)))
+ (put-text-property
+ (overlay-start ov) (overlay-end ov)
+ 'display (widget-character--change-character-display ?\s))))
+ (setq str (buffer-substring-no-properties start end))
+ ;; This assumes the user enters one character at a time,
+ ;; and does nothing crazy, like yanking a long string.
+ (let ((disp (widget-character--change-character-display (aref str 0))))
+ (when disp
+ (put-text-property start end 'display disp))))))
+ (widget-default-notify widget child event))
(define-widget 'list 'group
"A Lisp list."
@@ -3652,12 +3915,17 @@ example:
`(cons :format "Key: %v" ,key-type ,value-type)))
(define-widget 'choice 'menu-choice
- "A union of several sexp types."
+ "A union of several sexp types.
+
+If one of the choices of a choice widget has an :inline t property,
+then the choice widget can act as an inline widget on its own if the
+current choice is inline."
:tag "Choice"
:format "%{%t%}: %[Value Menu%] %v"
:button-prefix 'widget-push-button-prefix
:button-suffix 'widget-push-button-suffix
- :prompt-value 'widget-choice-prompt-value)
+ :prompt-value 'widget-choice-prompt-value
+ :inline-bubbles-p #'widget-choice-inline-bubbles-p)
(defun widget-choice-prompt-value (widget prompt value _unbound)
"Make a choice."
@@ -3700,6 +3968,20 @@ example:
(if current
(widget-prompt-value current prompt nil t)
value)))
+
+(defun widget-choice-inline-bubbles-p (widget)
+ "Non-nil if the choice WIDGET has at least one choice that is inline.
+This is used when matching values, because a choice widget needs to
+match a value inline rather than just match it if at least one of its choices
+is inline."
+ (let ((args (widget-get widget :args))
+ cur found)
+ (while (and args (not found))
+ (setq cur (car args)
+ args (cdr args)
+ found (widget-get cur :inline)))
+ found))
+
(define-widget 'radio 'radio-button-choice
"A union of several sexp types."
@@ -3729,21 +4011,26 @@ example:
(defun widget-boolean-prompt-value (_widget prompt _value _unbound)
;; Toggle a boolean.
- (y-or-n-p prompt))
+ ;; Say what "y" means. A la
+ ;; "Set customized value for bar to true: (y or n)"
+ (y-or-n-p (concat (replace-regexp-in-string ": ?\\'" "" prompt)
+ " true: ")))
;;; The `color' Widget.
-;; Fixme: match
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
:value-create 'widget-color-value-create
- :size 10
+ :size (1+ (apply #'max 13 ; Longest RGB hex string.
+ (mapcar #'length (defined-colors))))
:tag "Color"
:value "black"
- :completions (or facemenu-color-alist (defined-colors))
+ :completions (defined-colors)
:sample-face-get 'widget-color-sample-face-get
:notify 'widget-color-notify
+ :match #'widget-color-match
+ :validate #'widget-color-validate
:action 'widget-color-action)
(defun widget-color-value-create (widget)
@@ -3754,7 +4041,10 @@ example:
:tag " Choose " :action 'widget-color--choose-action)
(widget-insert " "))
+(declare-function list-colors-display "facemenu")
+
(defun widget-color--choose-action (widget &optional _event)
+ (require 'facemenu)
(list-colors-display
nil nil
(let ((cbuf (current-buffer))
@@ -3777,8 +4067,11 @@ example:
(list (cons 'foreground-color value))
'default)))
+(declare-function facemenu-read-color "facemenu")
+
(defun widget-color-action (widget &optional event)
"Prompt for a color."
+ (require 'facemenu)
(let* ((tag (widget-apply widget :menu-tag-get))
(prompt (concat tag ": "))
(answer (facemenu-read-color prompt)))
@@ -3792,6 +4085,19 @@ example:
(overlay-put (widget-get widget :sample-overlay)
'face (widget-apply widget :sample-face-get))
(widget-default-notify widget child event))
+
+(defun widget-color-match (_widget value)
+ "Non-nil if VALUE is a defined color or a RGB hex string."
+ (and (stringp value)
+ (or (color-defined-p value)
+ (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
+
+(defun widget-color-validate (widget)
+ "Check that WIDGET's value is a valid color."
+ (let ((value (widget-value widget)))
+ (unless (widget-color-match widget value)
+ (widget-put widget :error (format "Invalid color: %S" value))
+ widget)))
;;; The Help Echo
@@ -3803,7 +4109,9 @@ example:
(setq help-echo (funcall help-echo widget)))
(if help-echo (message "%s" (eval help-echo)))))
-;;; The End:
+;;; Obsolete.
+
+(define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1")
(provide 'wid-edit)
diff --git a/lisp/widget.el b/lisp/widget.el
index de690ad225d..d258e6fae2b 100644
--- a/lisp/widget.el
+++ b/lisp/widget.el
@@ -1,4 +1,4 @@
-;;; widget.el --- a library of user interface components
+;;; widget.el --- a library of user interface components -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
;;
@@ -94,8 +94,6 @@ The third argument DOC is a documentation string for the widget."
;; This is used by external widget code (in W3, at least).
(define-obsolete-function-alias 'widget-plist-member #'plist-member "26.1")
-;;; The End.
-
(provide 'widget)
;;; widget.el ends here
diff --git a/lisp/windmove.el b/lisp/windmove.el
index 99671efec9f..f747c409431 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -138,17 +138,24 @@ If this variable is set to t, moving left from the leftmost window in
a frame will find the rightmost one, and similarly for the other
directions. The minibuffer is skipped over in up/down movements if it
is inactive."
- :type 'boolean
- :group 'windmove)
+ :type 'boolean)
(defcustom windmove-create-window nil
"Whether movement off the edge of the frame creates a new window.
If this variable is set to t, moving left from the leftmost window in
a frame will create a new window on the left, and similarly for the other
-directions."
- :type 'boolean
- :group 'windmove
- :version "27.1")
+directions.
+This variable may also be a function to be called in this circumstance
+by `windmove-do-window-select'. The function should accept then as
+argument the DIRECTION targeted, an interactive ARG and a WINDOW
+corresponding to the currently selected window. It should also return
+a valid window that `windmove-do-window-select' will select,
+or the symbol `no-select' to ignore that final selection."
+ :type '(choice
+ (const :tag "Don't create new windows" nil)
+ (const :tag "Create new windows" t)
+ (function :tag "Provide a function"))
+ :version "28.1")
;; If your Emacs sometimes places an empty column between two adjacent
;; windows, you may wish to set this delta to 2.
@@ -157,11 +164,18 @@ directions."
Measured in characters either horizontally or vertically; setting this
to a value larger than 1 may be useful in getting around window-
placement bugs in old versions of Emacs."
- :type 'number
- :group 'windmove)
+ :type 'number)
(make-obsolete-variable 'windmove-window-distance-delta
"no longer used." "27.1")
+(defcustom windmove-allow-all-windows nil
+ "Whether the windmove commands are allowed to target all type of windows.
+If this variable is set to non-nil, all windmove commmands will
+ignore the `no-other-window' parameter applied by `display-buffer-alist'
+or `set-window-parameter'."
+ :type 'boolean
+ :version "28.1")
+
;; Note:
;;
@@ -342,7 +356,8 @@ WINDOW must be a live window and defaults to the selected one.
Optional ARG, if negative, means to use the right or bottom edge of
WINDOW as reference position, instead of `window-point'; if positive,
use the left or top edge of WINDOW as reference point."
- (window-in-direction dir window nil arg windmove-wrap-around t))
+ (window-in-direction dir window windmove-allow-all-windows
+ arg windmove-wrap-around t))
;; Selects the window that's hopefully at the location returned by
;; `windmove-find-other-window', or screams if there's no window there.
@@ -350,19 +365,23 @@ use the left or top edge of WINDOW as reference point."
"Move to the window at direction DIR as seen from WINDOW.
DIR, ARG, and WINDOW are handled as by `windmove-find-other-window'.
If no window is at direction DIR, an error is signaled.
-If `windmove-create-window' is non-nil, try to create a new window
+If `windmove-create-window' is a function, call that function with
+DIR, ARG and WINDOW. If it is non-nil, try to create a new window
in direction DIR instead."
(let ((other-window (windmove-find-other-window dir arg window)))
(when (and windmove-create-window
(or (null other-window)
(and (window-minibuffer-p other-window)
(not (minibuffer-window-active-p other-window)))))
- (setq other-window (split-window window nil dir)))
+ (setq other-window (if (functionp windmove-create-window)
+ (funcall windmove-create-window dir arg window)
+ (split-window window nil dir))))
(cond ((null other-window)
(user-error "No window %s from selected window" dir))
((and (window-minibuffer-p other-window)
(not (minibuffer-window-active-p other-window)))
(user-error "Minibuffer is inactive"))
+ ((eq other-window 'no-select))
(t
(select-window other-window)))))
@@ -426,27 +445,72 @@ unless `windmove-create-window' is non-nil and a new window is created."
;; I don't think these bindings will work on non-X terminals; you
;; probably want to use different bindings in that case.
+(defvar windmove-mode-map (make-sparse-keymap)
+ "Map used by `windmove-install-defaults'.")
+
+(define-minor-mode windmove-mode
+ "Global minor mode for default windmove commands."
+ :keymap windmove-mode-map
+ :init-value t
+ :global t)
+
+(defun windmove-install-defaults (prefix modifiers alist &optional uninstall)
+ "Install keys as specified by ALIST.
+Every element of ALIST has the form (FN KEY), where KEY is
+appended to MODIFIERS, adding PREFIX to the beginning, before
+installing the key. Previous bindings of FN are unbound.
+If UNINSTALL is non-nil, just remove the keys from ALIST."
+ (dolist (bind alist)
+ (dolist (old (where-is-internal (car bind) windmove-mode-map))
+ (define-key windmove-mode-map old nil))
+ (unless uninstall
+ (let ((key (vconcat (if (or (equal prefix [ignore])
+ (eq prefix 'none))
+ nil prefix)
+ (list (append modifiers (cdr bind))))))
+ (when (eq (key-binding key) #'self-insert-command)
+ (warn "Command %S is shadowing self-insert-key" (car bind)))
+ (let ((old-fn (lookup-key windmove-mode-map key)))
+ (when (functionp old-fn)
+ (warn "Overriding %S with %S" old-fn (car bind))))
+ (define-key windmove-mode-map key (car bind))))))
+
;;;###autoload
(defun windmove-default-keybindings (&optional modifiers)
"Set up keybindings for `windmove'.
Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift'."
(interactive)
(unless modifiers (setq modifiers 'shift))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left))) 'windmove-left)
- (global-set-key (vector (append modifiers '(right))) 'windmove-right)
- (global-set-key (vector (append modifiers '(up))) 'windmove-up)
- (global-set-key (vector (append modifiers '(down))) 'windmove-down))
+ (windmove-install-defaults nil modifiers
+ '((windmove-left left)
+ (windmove-right right)
+ (windmove-up up)
+ (windmove-down down))))
;;; Directional window display and selection
(defcustom windmove-display-no-select nil
- "Whether the window should be selected after displaying the buffer in it."
- :type 'boolean
- :group 'windmove
+ "Whether the window should be selected after displaying the buffer in it.
+If `nil', then the new window where the buffer is displayed will be selected.
+If `ignore', then don't select a window: neither the new nor the old window,
+thus allowing the next command to decide what window it selects.
+Other non-nil values will reselect the old window that was selected before.
+
+The value of this variable can be overridden by the prefix arg of the
+windmove-display-* commands that use `windmove-display-in-direction'.
+
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ :type '(choice (const :tag "Select new window" nil)
+ (const :tag "Select old window" t)
+ (const :tag "Don't select a window" ignore))
:version "27.1")
(defun windmove-display-in-direction (dir &optional arg)
@@ -454,83 +518,82 @@ Default value of MODIFIERS is `shift'."
The next buffer is the buffer displayed by the next command invoked
immediately after this command (ignoring reading from the minibuffer).
Create a new window if there is no window in that direction.
-By default, select the window with a displayed buffer.
-If prefix ARG is `C-u', reselect a previously selected window.
-If `windmove-display-no-select' is non-nil, this command doesn't
-select the window with a displayed buffer, and the meaning of
-the prefix argument is reversed.
+
+By default, select the new window with a displayed buffer.
+If `windmove-display-no-select' is `ignore', then allow the next command
+to decide what window it selects. With other non-nil values of
+`windmove-display-no-select', this function reselects
+a previously selected old window.
+
+If prefix ARG is `C-u', reselect a previously selected old window.
+If `windmove-display-no-select' is non-nil, the meaning of
+the prefix argument is reversed and it selects the new window.
+
When `switch-to-buffer-obey-display-actions' is non-nil,
`switch-to-buffer' commands are also supported."
- (let* ((no-select (xor (consp arg) windmove-display-no-select))
- (old-window (or (minibuffer-selected-window) (selected-window)))
- (new-window)
- (minibuffer-depth (minibuffer-depth))
- (action (lambda (buffer alist)
- (unless (> (minibuffer-depth) minibuffer-depth)
- (let ((window (cond
- ((eq dir 'new-tab)
- (let ((tab-bar-new-tab-choice t))
- (tab-bar-new-tab))
- (selected-window))
- ((eq dir 'same-window)
- (selected-window))
- (t (window-in-direction
- dir nil nil
- (and arg (prefix-numeric-value arg))
- windmove-wrap-around))))
- (type 'reuse))
- (unless window
- (setq window (split-window nil nil dir) type 'window))
- (setq new-window (window--display-buffer buffer window
- type alist))))))
- (command this-command)
- (clearfun (make-symbol "clear-display-buffer-overriding-action"))
- (exitfun
- (lambda ()
- (setq display-buffer-overriding-action
- (delq action display-buffer-overriding-action))
- (when (window-live-p (if no-select old-window new-window))
- (select-window (if no-select old-window new-window)))
- (remove-hook 'post-command-hook clearfun))))
- (fset clearfun
- (lambda ()
- (unless (or
- ;; Remove the hook immediately
- ;; after exiting the minibuffer.
- (> (minibuffer-depth) minibuffer-depth)
- ;; But don't remove immediately after
- ;; adding the hook by the same command below.
- (eq this-command command))
- (funcall exitfun))))
- (add-hook 'post-command-hook clearfun)
- (push action display-buffer-overriding-action)
- (message "[display-%s]" dir)))
+ (let ((no-select (xor (consp arg) windmove-display-no-select)))
+ (display-buffer-override-next-command
+ (lambda (_buffer alist)
+ (let* ((type 'reuse)
+ (window (cond
+ ((eq dir 'new-tab)
+ (let ((tab-bar-new-tab-choice t))
+ (tab-bar-new-tab))
+ (setq type 'tab)
+ (selected-window))
+ ((eq dir 'new-frame)
+ (let* ((params (cdr (assq 'pop-up-frame-parameters alist)))
+ (pop-up-frame-alist (append params pop-up-frame-alist))
+ (frame (make-frame-on-current-monitor
+ pop-up-frame-alist)))
+ (unless (cdr (assq 'inhibit-switch-frame alist))
+ (window--maybe-raise-frame frame))
+ (setq type 'frame)
+ (frame-selected-window frame)))
+ ((eq dir 'same-window)
+ (selected-window))
+ (t (window-in-direction
+ dir nil windmove-allow-all-windows
+ (and arg (prefix-numeric-value arg))
+ windmove-wrap-around 'nomini)))))
+ (unless window
+ (setq window (split-window nil nil dir) type 'window))
+ (cons window type)))
+ (lambda (old-window new-window)
+ (when (and (not (eq windmove-display-no-select 'ignore))
+ (window-live-p (if no-select old-window new-window)))
+ (select-window (if no-select old-window new-window))))
+ (format "[display-%s]" dir))))
;;;###autoload
(defun windmove-display-left (&optional arg)
"Display the next buffer in window to the left of the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'."
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'."
(interactive "P")
(windmove-display-in-direction 'left arg))
;;;###autoload
(defun windmove-display-up (&optional arg)
"Display the next buffer in window above the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'."
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'."
(interactive "P")
(windmove-display-in-direction 'up arg))
;;;###autoload
(defun windmove-display-right (&optional arg)
"Display the next buffer in window to the right of the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'."
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'."
(interactive "P")
(windmove-display-in-direction 'right arg))
;;;###autoload
(defun windmove-display-down (&optional arg)
"Display the next buffer in window below the current one.
-See the logic of the prefix ARG in `windmove-display-in-direction'."
+See the logic of the prefix ARG and `windmove-display-no-select'
+in `windmove-display-in-direction'."
(interactive "P")
(windmove-display-in-direction 'down arg))
@@ -541,6 +604,12 @@ See the logic of the prefix ARG in `windmove-display-in-direction'."
(windmove-display-in-direction 'same-window arg))
;;;###autoload
+(defun windmove-display-new-frame (&optional arg)
+ "Display the next buffer in a new frame."
+ (interactive "P")
+ (windmove-display-in-direction 'new-frame arg))
+
+;;;###autoload
(defun windmove-display-new-tab (&optional arg)
"Display the next buffer in a new tab."
(interactive "P")
@@ -552,16 +621,21 @@ See the logic of the prefix ARG in `windmove-display-in-direction'."
Keys are bound to commands that display the next buffer in the specified
direction. Keybindings are of the form MODIFIERS-{left,right,up,down},
where MODIFIERS is either a list of modifiers or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to
+the arrow keys.
Default value of MODIFIERS is `shift-meta'."
(interactive)
(unless modifiers (setq modifiers '(shift meta)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left))) 'windmove-display-left)
- (global-set-key (vector (append modifiers '(right))) 'windmove-display-right)
- (global-set-key (vector (append modifiers '(up))) 'windmove-display-up)
- (global-set-key (vector (append modifiers '(down))) 'windmove-display-down)
- (global-set-key (vector (append modifiers '(?0))) 'windmove-display-same-window)
- (global-set-key (vector (append modifiers '(?t))) 'windmove-display-new-tab))
+ (windmove-install-defaults nil modifiers
+ '((windmove-display-left left)
+ (windmove-display-right right)
+ (windmove-display-up up)
+ (windmove-display-down down)
+ (windmove-display-same-window ?0)
+ (windmove-display-new-frame ?f)
+ (windmove-display-new-tab ?t))))
;;; Directional window deletion
@@ -573,8 +647,8 @@ With `M-0' prefix, delete the selected window and
select the window at direction DIR.
When `windmove-wrap-around' is non-nil, takes the window
from the opposite side of the frame."
- (let ((other-window (window-in-direction dir nil nil arg
- windmove-wrap-around t)))
+ (let ((other-window (window-in-direction dir nil windmove-allow-all-windows
+ arg windmove-wrap-around 'nomini)))
(cond ((null other-window)
(user-error "No window %s from selected window" dir))
(t
@@ -623,16 +697,22 @@ select the window that was below the current one."
Keys are bound to commands that delete windows in the specified
direction. Keybindings are of the form PREFIX MODIFIERS-{left,right,up,down},
where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or
-a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
+a single modifier.
+If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings
+are directly bound to the arrow keys.
+Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
(interactive)
(unless prefix (setq prefix '(?\C-x)))
+ (when (eq prefix 'none) (setq prefix nil))
(unless (listp prefix) (setq prefix (list prefix)))
(unless modifiers (setq modifiers '(shift)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector prefix (append modifiers '(left))) 'windmove-delete-left)
- (global-set-key (vector prefix (append modifiers '(right))) 'windmove-delete-right)
- (global-set-key (vector prefix (append modifiers '(up))) 'windmove-delete-up)
- (global-set-key (vector prefix (append modifiers '(down))) 'windmove-delete-down))
+ (windmove-install-defaults prefix modifiers
+ '((windmove-delete-left left)
+ (windmove-delete-right right)
+ (windmove-delete-up up)
+ (windmove-delete-down down))))
;;; Directional window swap states
@@ -641,8 +721,8 @@ a single modifier. Default value of PREFIX is `C-x' and MODIFIERS is `shift'."
"Swap the states of the selected window and the window at direction DIR.
When `windmove-wrap-around' is non-nil, takes the window
from the opposite side of the frame."
- (let ((other-window (window-in-direction dir nil nil nil
- windmove-wrap-around t)))
+ (let ((other-window (window-in-direction dir nil windmove-allow-all-windows
+ nil windmove-wrap-around 'nomini)))
(cond ((or (null other-window) (window-minibuffer-p other-window))
(user-error "No window %s from selected window" dir))
(t
@@ -678,14 +758,99 @@ from the opposite side of the frame."
Keys are bound to commands that swap the states of the selected window
with the window in the specified direction. Keybindings are of the form
MODIFIERS-{left,right,up,down}, where MODIFIERS is either a list of modifiers
-or a single modifier. Default value of MODIFIERS is `shift-super'."
+or a single modifier.
+If MODIFIERS is `none', the keybindings will be directly bound to the
+arrow keys.
+Default value of MODIFIERS is `shift-super'."
(interactive)
(unless modifiers (setq modifiers '(shift super)))
+ (when (eq modifiers 'none) (setq modifiers nil))
(unless (listp modifiers) (setq modifiers (list modifiers)))
- (global-set-key (vector (append modifiers '(left))) 'windmove-swap-states-left)
- (global-set-key (vector (append modifiers '(right))) 'windmove-swap-states-right)
- (global-set-key (vector (append modifiers '(up))) 'windmove-swap-states-up)
- (global-set-key (vector (append modifiers '(down))) 'windmove-swap-states-down))
+ (windmove-install-defaults nil modifiers
+ '((windmove-swap-states-left left)
+ (windmove-swap-states-right right)
+ (windmove-swap-states-up up)
+ (windmove-swap-states-down down))))
+
+
+
+(defconst windmove--default-keybindings-type
+ `(choice (const :tag "Don't bind" nil)
+ (cons :tag "Bind using"
+ (key-sequence :tag "Prefix")
+ (set :tag "Modifier"
+ :greedy t
+ ;; See `(elisp) Keyboard Events'
+ (const :tag "Meta" meta)
+ (const :tag "Control" control)
+ (const :tag "Shift" shift)
+ (const :tag "Hyper" hyper)
+ (const :tag "Super" super)
+ (const :tag "Alt" alt))))
+ "Customisation type for windmove modifiers.")
+
+(defcustom windmove-default-keybindings nil
+ "Default keybindings for regular windmove commands.
+See `windmove-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-left left)
+ (windmove-right right)
+ (windmove-up up)
+ (windmove-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1")
+
+(defcustom windmove-display-default-keybindings nil
+ "Default keybindings for windmove directional buffer display commands.
+See `windmove-display-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-display-left left)
+ (windmove-display-right right)
+ (windmove-display-up up)
+ (windmove-display-down down)
+ (windmove-display-same-window ?0)
+ (windmove-display-new-frame ?f)
+ (windmove-display-new-tab ?t))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1")
+
+(defcustom windmove-delete-default-keybindings nil
+ "Default keybindings for windmove directional window deletion commands.
+See `windmove-delete-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-delete-left left)
+ (windmove-delete-right right)
+ (windmove-delete-up up)
+ (windmove-delete-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1")
+
+(defcustom windmove-swap-states-default-keybindings nil
+ "Default keybindings for windmove's directional window swap-state commands.
+See `windmove-swap-states-default-keybindings' for more detail."
+ :set (lambda (sym val)
+ (windmove-install-defaults
+ (car val) (cdr val)
+ '((windmove-swap-states-left left)
+ (windmove-swap-states-right right)
+ (windmove-swap-states-up up)
+ (windmove-swap-states-down down))
+ (null val))
+ (set-default sym val))
+ :type windmove--default-keybindings-type
+ :version "28.1")
(provide 'windmove)
diff --git a/lisp/window.el b/lisp/window.el
index 95db01bca48..0346397566a 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -226,7 +226,9 @@ BODY."
"Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer.
This construct is like `with-current-buffer-window' but unlike that,
displays the buffer specified by BUFFER-OR-NAME before running BODY."
- (declare (debug t) (indent 3))
+ (declare (debug t) (indent 3)
+ (obsolete "use `with-current-buffer-window' with action alist entry `body-function'."
+ "28.1"))
(let ((buffer (make-symbol "buffer"))
(window (make-symbol "window"))
(value (make-symbol "value")))
@@ -278,6 +280,24 @@ displays the buffer specified by BUFFER-OR-NAME before running BODY."
(funcall ,vquit-function ,window ,value)
,value)))))
+(defmacro with-window-non-dedicated (window &rest body)
+ "Evaluate BODY with WINDOW temporarily made non-dedicated.
+If WINDOW is nil, use the selected window. Return the value of
+the last form in BODY."
+ (declare (indent 1) (debug t))
+ (let ((window-dedicated-sym (gensym))
+ (window-sym (gensym)))
+ `(let* ((,window-sym (window-normalize-window ,window t))
+ (,window-dedicated-sym (window-dedicated-p ,window-sym)))
+ (set-window-dedicated-p ,window-sym nil)
+ (unwind-protect
+ (progn ,@body)
+ ;; `window-dedicated-p' returns the value set by
+ ;; `set-window-dedicated-p', which differentiates non-nil and
+ ;; t, so we cannot simply use t here. That's why we use
+ ;; `window-dedicated-sym'.
+ (set-window-dedicated-p ,window-sym ,window-dedicated-sym)))))
+
;; The following two functions are like `window-next-sibling' and
;; `window-prev-sibling' but the WINDOW argument is _not_ optional (so
;; they don't substitute the selected window for nil), and they return
@@ -1480,7 +1500,7 @@ otherwise."
(window-pixel-height window)
(window-total-height window round))))
-(defvar window-size-fixed nil
+(defvar-local window-size-fixed nil
"Non-nil in a buffer means windows displaying the buffer are fixed-size.
If the value is `height', then only the window's height is fixed.
If the value is `width', then only the window's width is fixed.
@@ -1489,7 +1509,6 @@ Any other non-nil value fixes both the width and the height.
Emacs won't change the size of any window displaying that buffer,
unless it has no other choice (like when deleting a neighboring
window).")
-(make-variable-buffer-local 'window-size-fixed)
(defun window--preservable-size (window &optional horizontal)
"Return height of WINDOW as `window-preserve-size' would preserve it.
@@ -2154,7 +2173,8 @@ the font."
(with-selected-window (window-normalize-window window t)
(let* ((window-width (window-body-width window t))
(font-width (window-font-width window face))
- (ncols (/ window-width font-width)))
+ (ncols (- (/ window-width font-width)
+ (ceiling (line-number-display-width 'columns)))))
(if (and (display-graphic-p)
overflow-newline-into-fringe
(not
@@ -2290,7 +2310,7 @@ SIDE can be any of the symbols `left', `top', `right' or
;; Neither of these allow one to selectively ignore specific windows
;; (windows whose `no-other-window' parameter is non-nil) as targets of
;; the movement.
-(defun window-in-direction (direction &optional window ignore sign wrap mini)
+(defun window-in-direction (direction &optional window ignore sign wrap minibuf)
"Return window in DIRECTION as seen from WINDOW.
More precisely, return the nearest window in direction DIRECTION
as seen from the position of `window-point' in window WINDOW.
@@ -2313,10 +2333,11 @@ frame borders. This means to return for WINDOW at the top of the
frame and DIRECTION `above' the minibuffer window if the frame
has one, and a window at the bottom of the frame otherwise.
-Optional argument MINI nil means to return the minibuffer window
-if and only if it is currently active. MINI non-nil means to
-return the minibuffer window even when it's not active. However,
-if WRAP is non-nil, always act as if MINI were nil.
+Optional argument MINIBUF t means to return the minibuffer
+window even if it isn't active. MINIBUF nil or omitted means
+to return the minibuffer window if and only if it is currently active.
+MINIBUF neither nil nor t means never return the minibuffer window.
+However, if WRAP is non-nil, always act as if MINIBUF were nil.
Return nil if no suitable window can be found."
(setq window (window-normalize-window window t))
@@ -2432,7 +2453,7 @@ Return nil if no suitable window can be found."
(setq best-edge-2 w-top)
(setq best-diff-2 best-diff-2-new)
(setq best-2 w)))))
- frame nil (and mini t))
+ frame nil minibuf)
(or best best-2)))
(defun get-window-with-predicate (predicate &optional minibuf all-frames default)
@@ -2478,14 +2499,16 @@ and no others."
(defalias 'some-window 'get-window-with-predicate)
-(defun get-lru-window (&optional all-frames dedicated not-selected)
+(defun get-lru-window (&optional all-frames dedicated not-selected no-other)
"Return the least recently used window on frames specified by ALL-FRAMES.
Return a full-width window if possible. A minibuffer window is
never a candidate. A dedicated window is never a candidate
unless DEDICATED is non-nil, so if all windows are dedicated, the
value is nil. Avoid returning the selected window if possible.
Optional argument NOT-SELECTED non-nil means never return the
-selected window.
+selected window. Optional argument NO-OTHER non-nil means to
+never return a window whose 'no-other-window' parameter is
+non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2505,7 +2528,9 @@ selected frame and no others."
(let (best-window best-time second-best-window second-best-time time)
(dolist (window (window-list-1 nil 'nomini all-frames))
(when (and (or dedicated (not (window-dedicated-p window)))
- (or (not not-selected) (not (eq window (selected-window)))))
+ (or (not not-selected) (not (eq window (selected-window))))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window))))
(setq time (window-use-time window))
(if (or (eq window (selected-window))
(not (window-full-width-p window)))
@@ -2517,12 +2542,14 @@ selected frame and no others."
(setq best-window window)))))
(or best-window second-best-window)))
-(defun get-mru-window (&optional all-frames dedicated not-selected)
+(defun get-mru-window (&optional all-frames dedicated not-selected no-other)
"Return the most recently used window on frames specified by ALL-FRAMES.
A minibuffer window is never a candidate. A dedicated window is
never a candidate unless DEDICATED is non-nil, so if all windows
are dedicated, the value is nil. Optional argument NOT-SELECTED
-non-nil means never return the selected window.
+non-nil means never return the selected window. Optional
+argument NO-OTHER non-nil means to never return a window whose
+'no-other-window' parameter is non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2544,17 +2571,21 @@ selected frame and no others."
(setq time (window-use-time window))
(when (and (or dedicated (not (window-dedicated-p window)))
(or (not not-selected) (not (eq window (selected-window))))
- (or (not best-time) (> time best-time)))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window)))
+ (or (not best-time) (> time best-time)))
(setq best-time time)
(setq best-window window)))
best-window))
-(defun get-largest-window (&optional all-frames dedicated not-selected)
+(defun get-largest-window (&optional all-frames dedicated not-selected no-other)
"Return the largest window on frames specified by ALL-FRAMES.
A minibuffer window is never a candidate. A dedicated window is
never a candidate unless DEDICATED is non-nil, so if all windows
are dedicated, the value is nil. Optional argument NOT-SELECTED
-non-nil means never return the selected window.
+non-nil means never return the selected window. Optional
+argument NO-OTHER non-nil means to never return a window whose
+'no-other-window' parameter is non-nil.
The following non-nil values of the optional argument ALL-FRAMES
have special meanings:
@@ -2575,7 +2606,9 @@ selected frame and no others."
best-window size)
(dolist (window (window-list-1 nil 'nomini all-frames))
(when (and (or dedicated (not (window-dedicated-p window)))
- (or (not not-selected) (not (eq window (selected-window)))))
+ (or (not not-selected) (not (eq window (selected-window))))
+ (or (not no-other)
+ (not (window-parameter window 'no-other-window))))
(setq size (* (window-pixel-height window)
(window-pixel-width window)))
(when (> size best-size)
@@ -2624,12 +2657,17 @@ and no others."
"Return t if WINDOW is the currently active minibuffer window."
(and (window-live-p window) (eq window (active-minibuffer-window))))
-(defun count-windows (&optional minibuf)
+(defun count-windows (&optional minibuf all-frames)
"Return the number of live windows on the selected frame.
+
The optional argument MINIBUF specifies whether the minibuffer
-window shall be counted. See `walk-windows' for the precise
-meaning of this argument."
- (length (window-list-1 nil minibuf)))
+window is included in the count.
+
+If ALL-FRAMES is non-nil, count the windows in all frames instead
+just the selected frame.
+
+See `walk-windows' for the precise meaning of this argument."
+ (length (window-list-1 nil minibuf all-frames)))
;;; Resizing windows.
(defun window--size-to-pixel (window size &optional horizontal pixelwise round-maybe)
@@ -3729,8 +3767,6 @@ WINDOW must be a valid window and defaults to the selected one.
If the option `window-resize-pixelwise' is non-nil minimize
WINDOW pixelwise."
(interactive)
- (when switch-to-buffer-preserve-window-point
- (window--before-delete-windows window))
(setq window (window-normalize-window window))
(window-resize
window
@@ -3913,7 +3949,7 @@ TOP RIGHT BOTTOM) as returned by `window-edges'."
(setq frame (window-normalize-frame frame))
(window--subtree (frame-root-window frame) t))
-(defun other-window (count &optional all-frames)
+(defun other-window (count &optional all-frames interactive)
"Select another window in cyclic ordering of windows.
COUNT specifies the number of windows to skip, starting with the
selected window, before making the selection. If COUNT is
@@ -3933,7 +3969,7 @@ This function uses `next-window' for finding the window to
select. The argument ALL-FRAMES has the same meaning as in
`next-window', but the MINIBUF argument of `next-window' is
always effectively nil."
- (interactive "p")
+ (interactive "p\ni\np")
(let* ((window (selected-window))
(original-window window)
(function (and (not ignore-window-parameters)
@@ -3979,13 +4015,53 @@ always effectively nil."
(setq count (1+ count)))))
(when (and (eq window original-window)
- (called-interactively-p 'interactive))
+ interactive
+ (not (or executing-kbd-macro noninteractive)))
(message "No other window to select"))
(select-window window)
;; Always return nil.
nil))))
+(defun other-window-prefix ()
+ "Display the buffer of the next command in a new window.
+The next buffer is the buffer displayed by the next command invoked
+immediately after this command (ignoring reading from the minibuffer).
+Creates a new window before displaying the buffer.
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ (interactive)
+ (display-buffer-override-next-command
+ (lambda (buffer alist)
+ (let ((alist (append '((inhibit-same-window . t)) alist))
+ window type)
+ (if (setq window (display-buffer-pop-up-window buffer alist))
+ (setq type 'window)
+ (setq window (display-buffer-use-some-window buffer alist)
+ type 'reuse))
+ (cons window type)))
+ nil "[other-window]")
+ (message "Display next command buffer in a new window..."))
+
+(defun same-window-prefix ()
+ "Display the buffer of the next command in the same window.
+The next buffer is the buffer displayed by the next command invoked
+immediately after this command (ignoring reading from the minibuffer).
+Even when the default rule should display the buffer in a new window,
+force its display in the already selected window.
+When `switch-to-buffer-obey-display-actions' is non-nil,
+`switch-to-buffer' commands are also supported."
+ (interactive)
+ (display-buffer-override-next-command
+ (lambda (buffer alist)
+ (setq alist (append '((inhibit-same-window . nil)) alist))
+ (cons (or
+ (display-buffer-same-window buffer alist)
+ (display-buffer-use-some-window buffer alist))
+ 'reuse))
+ nil "[same-window]")
+ (message "Display next command buffer in the same window..."))
+
;; This should probably return non-nil when the selected window is part
;; of an atomic window whose root is the frame's root window.
(defun one-window-p (&optional nomini all-frames)
@@ -4051,7 +4127,10 @@ frame can be safely deleted."
frame))
(throw 'other t))))
(let ((minibuf (active-minibuffer-window)))
- (and minibuf (eq frame (window-frame minibuf)))))
+ (and minibuf (eq frame (window-frame minibuf))
+ (not (eq (default-toplevel-value
+ 'minibuffer-follows-selected-frame)
+ t)))))
'frame))
((window-minibuffer-p window)
;; If WINDOW is the minibuffer window of a non-minibuffer-only
@@ -4063,53 +4142,56 @@ frame can be safely deleted."
;; of its frame.
t))))
-(defun window--in-subtree-p (window root)
- "Return t if WINDOW is either ROOT or a member of ROOT's subtree."
- (or (eq window root)
- (let ((parent (window-parent window)))
- (catch 'done
- (while parent
- (if (eq parent root)
- (throw 'done t)
- (setq parent (window-parent parent))))))))
-
-;; This function is called by `delete-window' and
-;; `delete-other-windows' when `switch-to-buffer-preserve-window-point'
-;; evaluates non-nil: it allows `winner-undo' to restore the
-;; buffer point from deleted windows (Bug#23621).
-(defun window--before-delete-windows (&optional window)
- "Update `window-prev-buffers' before delete a window.
-Optional arg WINDOW, if non-nil, update WINDOW-START and POS
-in `window-prev-buffers' for all windows displaying same
-buffer as WINDOW. Otherwise, update `window-prev-buffers' for
-all windows.
-
-The new values for WINDOW-START and POS are those
-returned by `window-start' and `window-point' respectively.
-
-This function is called only if `switch-to-buffer-preserve-window-point'
-evaluates non-nil."
- (dolist (win (window-list))
- (let* ((buf (window-buffer (or window win)))
- (start (window-start win))
- (pos (window-point win))
- (entry (assq buf (window-prev-buffers win))))
- (cond (entry
- (let ((marker (nth 2 entry)))
- (unless (= pos marker)
- (set-marker (nth 1 entry) start buf)
- (set-marker marker pos buf))))
- (t
- (let ((prev-buf (window-prev-buffers win))
- (start-m (make-marker))
- (pos-m (make-marker)))
- (set-marker start-m start buf)
- (set-marker pos-m pos buf)
- (push (list buf start-m pos-m) prev-buf)
- (set-window-prev-buffers win prev-buf)))))))
+(defun window-at-x-y (x y &optional frame no-other)
+ "Return live window at coordinates X, Y on specified FRAME.
+X and Y are FRAME-relative pixel coordinates. A coordinate on an
+edge shared by two windows is attributed to the window on the
+right (or below). Return nil if no such window can be found.
+
+Optional argument FRAME must specify a live frame and defaults to
+the selected one. Optional argument NO-OTHER non-nil means to
+return nil if the window located at the specified coordinates has
+a non-nil `no-other-window' parameter."
+ (setq frame (window-normalize-frame frame))
+ (let* ((root-edges (window-edges (frame-root-window frame) nil nil t))
+ (root-left (nth 2 root-edges))
+ (root-bottom (nth 3 root-edges)))
+ (catch 'window
+ (walk-window-tree
+ (lambda (window)
+ (let ((edges (window-edges window nil nil t)))
+ (when (and (>= x (nth 0 edges))
+ (or (< x (nth 2 edges)) (= x root-left))
+ (>= y (nth 1 edges))
+ (or (< y (nth 3 edges)) (= y root-bottom)))
+ (if (and no-other (window-parameter window 'no-other-window))
+ (throw 'window nil)
+ (throw 'window window)))))
+ frame))))
+
+(defcustom delete-window-choose-selected 'mru
+ "How to choose a frame's selected window after window deletion.
+When a frame's selected window gets deleted, Emacs has to choose
+another live window on that frame to serve as its selected
+window. This option allows to control which window gets selected
+instead.
+
+The possible choices are 'mru' (the default) to select the most
+recently used window on that frame, and 'pos' to choose the
+window at the frame coordinates of point of the previously
+selected window. If this is nil, choose the frame's first window
+instead. A window with a non-nil `no-other-window' parameter is
+chosen only if all windows on that frame have that parameter set
+to a non-nil value."
+ :type '(choice (const :tag "Most recently used" mru)
+ (const :tag "At position of deleted" pos)
+ (const :tag "Frame's first " nil))
+ :group 'windows
+ :group 'frames
+ :version "28.1")
(defun delete-window (&optional window)
- "Delete WINDOW.
+ "Delete specified WINDOW.
WINDOW must be a valid window and defaults to the selected one.
Return nil.
@@ -4124,10 +4206,12 @@ Otherwise, if WINDOW is part of an atomic window, call
`delete-window' with the root of the atomic window as its
argument. Signal an error if WINDOW is either the only window on
its frame, the last non-side window, or part of an atomic window
-that is its frame's root window."
+that is its frame's root window.
+
+If WINDOW is the selected window on its frame, choose some other
+window as that frame's selected window according to the value of
+the option `delete-window-choose-selected'."
(interactive)
- (when switch-to-buffer-preserve-window-point
- (window--before-delete-windows))
(setq window (window-normalize-window window))
(let* ((frame (window-frame window))
(function (window-parameter window 'delete-window))
@@ -4161,11 +4245,11 @@ that is its frame's root window."
(window-combination-resize
(or window-combination-resize
(window-parameter parent 'window-side)))
- (frame-selected
- (window--in-subtree-p (frame-selected-window frame) window))
+ (frame-selected-window (frame-selected-window frame))
;; Emacs 23 preferably gives WINDOW's space to its left
;; sibling.
- (sibling (or (window-left window) (window-right window))))
+ (sibling (or (window-left window) (window-right window)))
+ frame-selected-window-edges frame-selected-window-pos)
(window--resize-reset frame horizontal)
(cond
((and (not (eq window-combination-resize t))
@@ -4181,20 +4265,68 @@ that is its frame's root window."
(t
;; Can't do without resizing fixed-size windows.
(window--resize-siblings window (- size) horizontal t)))
+
+ (when (eq delete-window-choose-selected 'pos)
+ ;; Remember edges and position of point of the selected window
+ ;; of WINDOW'S frame.
+ (setq frame-selected-window-edges
+ (window-edges frame-selected-window nil nil t))
+ (setq frame-selected-window-pos
+ (nth 2 (posn-at-point nil frame-selected-window))))
+
;; Actually delete WINDOW.
(delete-window-internal window)
(window--pixel-to-total frame horizontal)
- (when (and frame-selected
- (window-parameter
- (frame-selected-window frame) 'no-other-window))
- ;; `delete-window-internal' has selected a window that should
- ;; not be selected, fix this here.
- (other-window -1 frame))
+
+ ;; If we deleted the selected window of WINDOW's frame, choose
+ ;; another one based on `delete-window-choose-selected'. Note
+ ;; that both `window-at-x-y' and `get-mru-window' may fail to
+ ;; produce a suitable window in which case we will fall back on
+ ;; its frame's first window, chosen by `delete-window-internal'.
+ (cond
+ ((window-live-p frame-selected-window))
+ ((and frame-selected-window-pos
+ ;; We have a recorded position of point of the previously
+ ;; selected window. Try to find the window that is now
+ ;; at that position.
+ (let ((new-frame-selected-window
+ (window-at-x-y
+ (+ (nth 0 frame-selected-window-edges)
+ (car frame-selected-window-pos))
+ (+ (nth 1 frame-selected-window-edges)
+ (cdr frame-selected-window-pos))
+ frame t)))
+ (and new-frame-selected-window
+ ;; Select window at WINDOW's position at point.
+ (set-frame-selected-window
+ frame new-frame-selected-window)))))
+ ((and (eq delete-window-choose-selected 'mru)
+ ;; Try to use the most recently used window.
+ (let ((mru-window (get-mru-window frame nil nil t)))
+ (and mru-window
+ (set-frame-selected-window frame mru-window)))))
+ ((and (window-parameter
+ (frame-selected-window frame) 'no-other-window)
+ ;; If `delete-window-internal' selected a window with a
+ ;; non-nil 'no-other-window' parameter as its frame's
+ ;; selected window, try to choose another one.
+ (catch 'found
+ (walk-window-tree
+ (lambda (other)
+ (unless (window-parameter other 'no-other-window)
+ (set-frame-selected-window frame other)
+ (throw 'found t)))
+ frame))))
+ (t
+ ;; Record the window chosen by `delete-window-internal'.
+ (set-frame-selected-window
+ frame (frame-selected-window frame))))
+
(window--check frame)
;; Always return nil.
nil))))
-(defun delete-other-windows (&optional window)
+(defun delete-other-windows (&optional window interactive)
"Make WINDOW fill its frame.
WINDOW must be a valid window and defaults to the selected one.
Return nil.
@@ -4211,7 +4343,7 @@ with the root of the atomic window as its argument. Signal an
error if that root window is the root window of WINDOW's frame.
Also signal an error if WINDOW is a side window. Do not delete
any window whose `no-delete-other-windows' parameter is non-nil."
- (interactive)
+ (interactive "i\np")
(setq window (window-normalize-window window))
(let* ((frame (window-frame window))
(function (window-parameter window 'delete-other-windows))
@@ -4277,7 +4409,8 @@ any window whose `no-delete-other-windows' parameter is non-nil."
(if (eq window main)
;; Give a message to the user if this has been called as a
;; command.
- (when (called-interactively-p 'interactive)
+ (when (and interactive
+ (not (or executing-kbd-macro noninteractive)))
(message "No other windows to delete"))
(delete-other-windows-internal window main)
(window--check frame))
@@ -4330,42 +4463,45 @@ This may be a useful alternative binding for \\[delete-other-windows]
;; The following function is called by `set-window-buffer' _before_ it
;; replaces the buffer of the argument window with the new buffer.
+(defun push-window-buffer-onto-prev (&optional window)
+ "Push entry for WINDOW's buffer onto WINDOW's prev-buffers list.
+WINDOW must be a live window and defaults to the selected one.
+
+Any duplicate entries for the buffer in the list are removed."
+ (let* ((window (window-normalize-window window t))
+ (buffer (window-buffer window))
+ (w-list (window-prev-buffers window))
+ (entry (assq buffer w-list)))
+ (when entry
+ (setq w-list (assq-delete-all buffer w-list)))
+ (let ((start (window-start window))
+ (point (window-point window)))
+ (setq entry
+ (cons buffer
+ (with-current-buffer buffer
+ (if entry
+ ;; We have an entry, update marker positions.
+ (list (set-marker (nth 1 entry) start)
+ (set-marker (nth 2 entry) point))
+ (list (copy-marker start)
+ (copy-marker
+ ;; Preserve window-point-insertion-type
+ ;; (Bug#12855)
+ point window-point-insertion-type))))))
+ (set-window-prev-buffers window (cons entry w-list)))))
+
(defun record-window-buffer (&optional window)
"Record WINDOW's buffer.
WINDOW must be a live window and defaults to the selected one."
(let* ((window (window-normalize-window window t))
- (buffer (window-buffer window))
- (entry (assq buffer (window-prev-buffers window))))
+ (buffer (window-buffer window)))
;; Reset WINDOW's next buffers. If needed, they are resurrected by
;; `switch-to-prev-buffer' and `switch-to-next-buffer'.
(set-window-next-buffers window nil)
- (when entry
- ;; Remove all entries for BUFFER from WINDOW's previous buffers.
- (set-window-prev-buffers
- window (assq-delete-all buffer (window-prev-buffers window))))
-
;; Don't record insignificant buffers.
- (unless (eq (aref (buffer-name buffer) 0) ?\s)
- ;; Add an entry for buffer to WINDOW's previous buffers.
- (with-current-buffer buffer
- (let ((start (window-start window))
- (point (window-point window)))
- (setq entry
- (cons buffer
- (if entry
- ;; We have an entry, update marker positions.
- (list (set-marker (nth 1 entry) start)
- (set-marker (nth 2 entry) point))
- ;; Make new markers.
- (list (copy-marker start)
- (copy-marker
- ;; Preserve window-point-insertion-type
- ;; (Bug#12855).
- point window-point-insertion-type)))))
- (set-window-prev-buffers
- window (cons entry (window-prev-buffers window)))))
-
+ (when (not (eq (aref (buffer-name buffer) 0) ?\s))
+ (push-window-buffer-onto-prev window)
(run-hooks 'buffer-list-update-hook))))
(defun unrecord-window-buffer (&optional window buffer)
@@ -4390,8 +4526,10 @@ point to POINT. If WINDOW is selected this also sets BUFFER's
before was current this also makes BUFFER the current buffer."
(setq window (window-normalize-window window t))
(let ((selected (eq window (selected-window)))
- (current (eq (window-buffer window) (current-buffer))))
+ (current (eq (window-buffer window) (current-buffer)))
+ (dedicated-side (eq (window-dedicated-p window) 'side)))
(set-window-buffer window buffer)
+ (and dedicated-side (set-window-dedicated-p window 'side))
(when (and selected current)
(set-buffer buffer))
(when start
@@ -4525,11 +4663,11 @@ This function is called by `prev-buffer'."
;; Scan WINDOW's previous buffers first, skipping entries of next
;; buffers.
(dolist (entry (window-prev-buffers window))
- (when (and (setq new-buffer (car entry))
+ (when (and (not (eq (car entry) old-buffer))
+ (setq new-buffer (car entry))
(or (buffer-live-p new-buffer)
(not (setq killed-buffers
(cons new-buffer killed-buffers))))
- (not (eq new-buffer old-buffer))
(or (null pred) (funcall pred new-buffer))
;; When BURY-OR-KILL is nil, avoid switching to a
;; buffer in WINDOW's next buffers list.
@@ -4692,11 +4830,11 @@ This function is called by `next-buffer'."
;; Scan WINDOW's reverted previous buffers last (must not use
;; nreverse here!)
(dolist (entry (reverse (window-prev-buffers window)))
- (when (and (setq new-buffer (car entry))
+ (when (and (not (eq new-buffer (car entry)))
+ (setq new-buffer (car entry))
(or (buffer-live-p new-buffer)
(not (setq killed-buffers
(cons new-buffer killed-buffers))))
- (not (eq new-buffer old-buffer))
(or (null pred) (funcall pred new-buffer)))
(if (switch-to-prev-buffer-skip-p skip window new-buffer)
(setq skipped (or skipped new-buffer))
@@ -4840,11 +4978,11 @@ displayed there."
(interactive)
(switch-to-buffer (last-buffer)))
-(defun next-buffer (&optional arg)
+(defun next-buffer (&optional arg interactive)
"In selected window switch to ARGth next buffer.
Call `switch-to-next-buffer' unless the selected window is the
minibuffer window or is dedicated to its buffer."
- (interactive "p")
+ (interactive "p\np")
(cond
((window-minibuffer-p)
(user-error "Cannot switch buffers in minibuffer window"))
@@ -4853,14 +4991,15 @@ minibuffer window or is dedicated to its buffer."
(t
(dotimes (_ (or arg 1))
(when (and (not (switch-to-next-buffer))
- (called-interactively-p 'interactive))
+ interactive
+ (not (or executing-kbd-macro noninteractive)))
(user-error "No next buffer"))))))
-(defun previous-buffer (&optional arg)
+(defun previous-buffer (&optional arg interactive)
"In selected window switch to ARGth previous buffer.
Call `switch-to-prev-buffer' unless the selected window is the
minibuffer window or is dedicated to its buffer."
- (interactive "p")
+ (interactive "p\np")
(cond
((window-minibuffer-p)
(user-error "Cannot switch buffers in minibuffer window"))
@@ -4869,7 +5008,8 @@ minibuffer window or is dedicated to its buffer."
(t
(dotimes (_ (or arg 1))
(when (and (not (switch-to-prev-buffer))
- (called-interactively-p 'interactive))
+ interactive
+ (not (or executing-kbd-macro noninteractive)))
(user-error "No previous buffer"))))))
(defun delete-windows-on (&optional buffer-or-name frame)
@@ -4921,9 +5061,10 @@ window's lists of previous and next buffers."
(all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame))))
(dolist (window (window-list-1 nil nil all-frames))
(if (eq (window-buffer window) buffer)
- (let ((deletable (window-deletable-p window)))
+ (let ((deletable (window-deletable-p window))
+ (dedicated (window-dedicated-p window)))
(cond
- ((and (eq deletable 'frame) (window-dedicated-p window))
+ ((and (eq deletable 'frame) dedicated)
;; Delete frame if and only if window is dedicated.
(delete-frame (window-frame window)))
((eq deletable t)
@@ -4932,7 +5073,10 @@ window's lists of previous and next buffers."
(t
;; In window switch to previous buffer.
(set-window-dedicated-p window nil)
- (switch-to-prev-buffer window 'bury))))
+ (switch-to-prev-buffer window 'bury)
+ ;; Restore the dedicated 'side' flag.
+ (when (eq dedicated 'side)
+ (set-window-dedicated-p window 'side)))))
;; If a window doesn't show BUFFER, unrecord BUFFER in it.
(unrecord-window-buffer window buffer)))))
@@ -4941,10 +5085,10 @@ window's lists of previous and next buffers."
BUFFER-OR-NAME may be a buffer or the name of an existing buffer
and defaults to the current buffer.
-When a window showing BUFFER-OR-NAME is dedicated, that window is
-deleted. If that window is the only window on its frame, the
-frame is deleted too when there are other frames left. If there
-are no other frames left, some other buffer is displayed in that
+With the exception of side windows, when a window showing BUFFER-OR-NAME
+is dedicated, that window is deleted. If that window is the only window
+on its frame, the frame is deleted too when there are other frames left.
+If there are no other frames left, some other buffer is displayed in that
window.
This function removes the buffer denoted by BUFFER-OR-NAME from
@@ -4953,10 +5097,14 @@ all window-local buffer lists."
(let ((buffer (window-normalize-buffer buffer-or-name)))
(dolist (window (window-list-1 nil nil t))
(if (eq (window-buffer window) buffer)
- (unless (window--delete window t t)
- ;; Switch to another buffer in window.
- (set-window-dedicated-p window nil)
- (switch-to-prev-buffer window 'kill))
+ ;; Delete a dedicated window unless it is a side window.
+ (let ((dedicated-side (eq (window-dedicated-p window) 'side)))
+ (when (or dedicated-side (not (window--delete window t t)))
+ ;; Switch to another buffer in that window.
+ (set-window-dedicated-p window nil)
+ (if (switch-to-prev-buffer window 'kill)
+ (and dedicated-side (set-window-dedicated-p window 'side))
+ (window--delete window nil 'kill))))
;; Unrecord BUFFER in WINDOW.
(unrecord-window-buffer window buffer)))))
@@ -4978,6 +5126,10 @@ buffer. If WINDOW is not deleted, reset its `quit-restore'
parameter to nil. See Info node `(elisp) Quitting Windows' for
more details.
+If WINDOW's dedicated flag is t, try to delete WINDOW. If it
+equals the value 'side', restore that value when WINDOW is not
+deleted.
+
Optional second argument BURY-OR-KILL tells how to proceed with
the buffer of WINDOW. The following values are handled:
@@ -5000,16 +5152,23 @@ nil means to not handle the buffer in a particular way. This
(setq window (window-normalize-window window t))
(let* ((buffer (window-buffer window))
(quit-restore (window-parameter window 'quit-restore))
- (prev-buffer
- (let* ((prev-buffers (window-prev-buffers window))
- (prev-buffer (caar prev-buffers)))
- (and (or (not (eq prev-buffer buffer))
- (and (cdr prev-buffers)
- (not (eq (setq prev-buffer (cadr prev-buffers))
- buffer))))
- prev-buffer)))
+ (prev-buffer (catch 'prev-buffer
+ (dolist (buf (window-prev-buffers window))
+ (unless (eq (car buf) buffer)
+ (throw 'prev-buffer (car buf))))))
+ (dedicated (window-dedicated-p window))
quad entry)
(cond
+ ;; First try to delete dedicated windows that are not side windows.
+ ((and dedicated (not (eq dedicated 'side))
+ (window--delete window 'dedicated (eq bury-or-kill 'kill))))
+ ((and (not prev-buffer)
+ (eq (nth 1 quit-restore) 'tab)
+ (eq (nth 3 quit-restore) buffer))
+ (tab-bar-close-tab)
+ ;; If the previously selected window is still alive, select it.
+ (when (window-live-p (nth 2 quit-restore))
+ (select-window (nth 2 quit-restore))))
((and (not prev-buffer)
(or (eq (nth 1 quit-restore) 'frame)
(and (eq (nth 1 quit-restore) 'window)
@@ -5045,6 +5204,9 @@ nil means to not handle the buffer in a particular way. This
;; Restore WINDOW's previous buffer, start and point position.
(set-window-buffer-start-and-point
window (nth 0 quad) (nth 1 quad) (nth 2 quad))
+ ;; Restore the 'side' dedicated flag as well.
+ (when (eq dedicated 'side)
+ (set-window-dedicated-p window 'side))
;; Deal with the buffer we just removed from WINDOW.
(setq entry (and (eq bury-or-kill 'append)
(assq buffer (window-prev-buffers window))))
@@ -5071,7 +5233,14 @@ nil means to not handle the buffer in a particular way. This
(set-window-parameter window 'quit-restore nil)
;; Make sure that WINDOW is no more dedicated.
(set-window-dedicated-p window nil)
- (switch-to-prev-buffer window bury-or-kill)))
+ ;; Try to switch to a previous buffer. Delete the window only if
+ ;; that is not possible (Bug#48367).
+ (if (switch-to-prev-buffer window bury-or-kill)
+ (when (eq dedicated 'side)
+ (set-window-dedicated-p window 'side))
+ (window--delete window nil (eq bury-or-kill 'kill))
+ (when (window-live-p (nth 2 quit-restore))
+ (select-window (nth 2 quit-restore))))))
;; Deal with the buffer.
(cond
@@ -5667,17 +5836,16 @@ window."
WINDOW defaults to the selected window. DIRECTION can be
nil (i.e. any), `height' or `width'."
(with-current-buffer (window-buffer window)
- (when (and (boundp 'window-size-fixed) window-size-fixed)
- (not (and direction
- (member (cons direction window-size-fixed)
- '((height . width) (width . height))))))))
+ (and window-size-fixed
+ (not (and direction
+ (member (cons direction window-size-fixed)
+ '((height . width) (width . height))))))))
;;; A different solution to balance-windows.
-(defvar window-area-factor 1
+(defvar-local window-area-factor 1
"Factor by which the window area should be over-estimated.
This is used by `balance-windows-area'.
Changing this globally has no effect.")
-(make-variable-buffer-local 'window-area-factor)
(defun balance-windows-area-adjust (window delta horizontal pixelwise)
"Wrapper around `window-resize' with error checking.
@@ -6093,29 +6261,27 @@ value can be also stored on disk and read back in a new session."
;; Select window if it's the selected one.
(when (cdr (assq 'selected state))
(select-window window))
- (when next-buffers
- (set-window-next-buffers
- window
- (delq nil (mapcar (lambda (buffer)
- (setq buffer (get-buffer buffer))
- (when (buffer-live-p buffer) buffer))
- next-buffers))))
- (when prev-buffers
- (set-window-prev-buffers
- window
- (delq nil (mapcar (lambda (entry)
- (let ((buffer (get-buffer (nth 0 entry)))
- (m1 (nth 1 entry))
- (m2 (nth 2 entry)))
- (when (buffer-live-p buffer)
- (list buffer
- (if (markerp m1) m1
- (set-marker (make-marker) m1
- buffer))
- (if (markerp m2) m2
- (set-marker (make-marker) m2
- buffer))))))
- prev-buffers)))))
+ (set-window-next-buffers
+ window
+ (delq nil (mapcar (lambda (buffer)
+ (setq buffer (get-buffer buffer))
+ (when (buffer-live-p buffer) buffer))
+ next-buffers)))
+ (set-window-prev-buffers
+ window
+ (delq nil (mapcar (lambda (entry)
+ (let ((buffer (get-buffer (nth 0 entry)))
+ (m1 (nth 1 entry))
+ (m2 (nth 2 entry)))
+ (when (buffer-live-p buffer)
+ (list buffer
+ (if (markerp m1) m1
+ (set-marker (make-marker) m1
+ buffer))
+ (if (markerp m2) m2
+ (set-marker (make-marker) m2
+ buffer))))))
+ prev-buffers))))
;; We don't want to raise an error in case the buffer does
;; not exist anymore, so we switch to a previous one and
;; save the window with the intention of deleting it later
@@ -6375,7 +6541,12 @@ fourth element is BUFFER."
;; WINDOW has been created on a new frame.
(set-window-parameter
window 'quit-restore
- (list 'frame 'frame (selected-window) buffer)))))
+ (list 'frame 'frame (selected-window) buffer)))
+ ((eq type 'tab)
+ ;; WINDOW has been created on a new tab.
+ (set-window-parameter
+ window 'quit-restore
+ (list 'tab 'tab (selected-window) buffer)))))
(defcustom display-buffer-function nil
"If non-nil, function to call to handle `display-buffer'.
@@ -7042,8 +7213,14 @@ Return WINDOW if BUFFER and WINDOW are live."
;; use that.
(display-buffer-mark-dedicated
(set-window-dedicated-p window display-buffer-mark-dedicated))))
- (when (memq type '(window frame))
+ (when (memq type '(window frame tab))
(set-window-prev-buffers window nil))
+
+ (when (functionp (cdr (assq 'body-function alist)))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (funcall (cdr (assq 'body-function alist)) window)))
+
(let ((quit-restore (window-parameter window 'quit-restore))
(height (cdr (assq 'window-height alist)))
(width (cdr (assq 'window-width alist)))
@@ -7157,6 +7334,7 @@ The actual non-nil value of this variable will be copied to the
(const display-buffer-below-selected)
(const display-buffer-at-bottom)
(const display-buffer-in-previous-window)
+ (const display-buffer-use-least-recent-window)
(const display-buffer-use-some-window)
(const display-buffer-use-some-frame)
(function :tag "Other function"))
@@ -7292,6 +7470,37 @@ fails, call `display-buffer-pop-up-frame'.")
(defun display-buffer (buffer-or-name &optional action frame)
"Display BUFFER-OR-NAME in some window, without selecting it.
+To change which window is used, set `display-buffer-alist'
+to an expression containing one of these \"action\" functions:
+
+ `display-buffer-same-window' -- Use the selected window.
+ `display-buffer-reuse-window' -- Use a window already showing
+ the buffer.
+ `display-buffer-in-previous-window' -- Use a window that did
+ show the buffer before.
+ `display-buffer-use-some-window' -- Use some existing window.
+ `display-buffer-use-least-recent-window' -- Try to avoid re-using
+ windows that have recently been switched to.
+ `display-buffer-pop-up-window' -- Pop up a new window.
+ `display-buffer-below-selected' -- Use or pop up a window below
+ the selected one.
+ `display-buffer-at-bottom' -- Use or pop up a window at the
+ bottom of the selected frame.
+ `display-buffer-pop-up-frame' -- Show the buffer on a new frame.
+ `display-buffer-in-child-frame' -- Show the buffer in a
+ child frame.
+ `display-buffer-no-window' -- Do not display the buffer and
+ have `display-buffer' return nil immediately.
+
+For instance:
+
+ (setq display-buffer-alist '((\".*\" display-buffer-at-bottom)))
+
+Buffer display can be further customized to a very high degree;
+the rest of this docstring explains some of the many
+possibilities, and also see Info node `(emacs)Window Choice' for
+more information.
+
BUFFER-OR-NAME must be a buffer or a string naming a live buffer.
Return the window chosen for displaying that buffer, or nil if no
such window is found.
@@ -7317,23 +7526,8 @@ function in the combined function list in turn, passing the
buffer as the first argument and the combined action alist as the
second argument, until one of the functions returns non-nil.
-Action functions and the action they try to perform are:
- `display-buffer-same-window' -- Use the selected window.
- `display-buffer-reuse-window' -- Use a window already showing
- the buffer.
- `display-buffer-in-previous-window' -- Use a window that did
- show the buffer before.
- `display-buffer-use-some-window' -- Use some existing window.
- `display-buffer-pop-up-window' -- Pop up a new window.
- `display-buffer-below-selected' -- Use or pop up a window below
- the selected one.
- `display-buffer-at-bottom' -- Use or pop up a window at the
- bottom of the selected frame.
- `display-buffer-pop-up-frame' -- Show the buffer on a new frame.
- `display-buffer-in-child-frame' -- Show the buffer in a
- child frame.
- `display-buffer-no-window' -- Do not display the buffer and
- have `display-buffer' return nil immediately.
+See above for the action functions and the action they try to
+perform.
Action alist entries are:
`inhibit-same-window' -- A non-nil value prevents the same
@@ -7371,6 +7565,12 @@ Action alist entries are:
parameters to give the chosen window.
`allow-no-window' -- A non-nil value means that `display-buffer'
may not display the buffer and return nil immediately.
+ `body-function' -- A function called with one argument - the
+ displayed window. It is called after the buffer is
+ displayed, and before `window-height', `window-width'
+ and `preserve-size' are applied. The function is supposed
+ to fill the window body with some contents that might depend
+ on dimensions of the displayed window.
The entries `window-height', `window-width' and `preserve-size'
are applied only when the window used for displaying the buffer
@@ -7627,7 +7827,7 @@ indirectly called by the latter."
(with-current-buffer (window-buffer window)
(cond ((memq major-mode allowed-modes)
'same)
- ((derived-mode-p allowed-modes)
+ ((apply #'derived-mode-p allowed-modes)
'derived)))))
(when (and mode?
(not (and inhibit-same-window-p
@@ -7887,15 +8087,15 @@ Info node `(elisp) Buffer Display Action Alists' for details of
such alists.
ALIST has to contain a `direction' entry whose value should be
-one of `left', `above' (or `up'), `right' and `below' (or
-'down'). Other values are usually interpreted as `below'.
+one of `left', `above' (or `up'), `right' and `below' (or `down').
+Other values are usually interpreted as `below'.
If ALIST also contains a `window' entry, its value specifies a
reference window. That value can be a special symbol like
-'main' (which stands for the selected frame's main window) or
-'root' (standings for the selected frame's root window) or an
+`main' (which stands for the selected frame's main window) or
+`root' (standings for the selected frame's root window) or an
arbitrary valid window. Any other value (or omitting the
-'window' entry) means to use the selected window as reference
+`window' entry) means to use the selected window as reference
window.
This function tries to reuse or split a window such that the
@@ -8082,8 +8282,8 @@ such alists.
If ALIST has a non-nil `inhibit-same-window' entry, the selected
window is not usable. A dedicated window is usable only if it
already shows BUFFER. If ALIST contains a `previous-window'
-entry, the window specified by that entry is usable even if it
-never showed BUFFER before.
+entry, the window specified by that entry (either a variable
+or a value) is usable even if it never showed BUFFER before.
If ALIST contains a `reusable-frames' entry, its value determines
which frames to search for a usable window:
@@ -8125,6 +8325,7 @@ indirectly called by the latter."
0)
(display-buffer-reuse-frames 0)
(t (last-nonminibuffer-frame))))
+ (previous-window (cdr (assq 'previous-window alist)))
best-window second-best-window window)
;; Scan windows whether they have shown the buffer recently.
(catch 'best
@@ -8138,7 +8339,9 @@ indirectly called by the latter."
(throw 'best t)))))
;; When ALIST has a `previous-window' entry, that entry may override
;; anything we found so far.
- (when (and (setq window (cdr (assq 'previous-window alist)))
+ (when (and previous-window (boundp previous-window))
+ (setq previous-window (symbol-value previous-window)))
+ (when (and (setq window previous-window)
(window-live-p window)
(or (eq buffer (window-buffer window))
(not (window-dedicated-p window))))
@@ -8150,6 +8353,16 @@ indirectly called by the latter."
(when (setq window (or best-window second-best-window))
(window--display-buffer buffer window 'reuse alist))))
+(defun display-buffer-use-least-recent-window (buffer alist)
+ "Display BUFFER in an existing window, but that hasn't been used lately.
+This `display-buffer' action function is like
+`display-buffer-use-some-window', but will cycle through windows
+when displaying buffers repeatedly, and if there's only a single
+window, it will split the window."
+ (when-let ((window (display-buffer-use-some-window
+ buffer (cons (cons 'inhibit-same-window t) alist))))
+ (window-bump-use-time window)))
+
(defun display-buffer-use-some-window (buffer alist)
"Display BUFFER in an existing window.
Search for a usable window, set that window to the buffer, and
@@ -8298,9 +8511,9 @@ from the list of completions and default values."
;; here manually.
(if (and (boundp 'icomplete-with-completion-tables)
(listp icomplete-with-completion-tables))
- (set (make-local-variable 'icomplete-with-completion-tables)
- (cons rbts-completion-table
- icomplete-with-completion-tables))))
+ (setq-local icomplete-with-completion-tables
+ (cons rbts-completion-table
+ icomplete-with-completion-tables))))
(read-buffer prompt (other-buffer (current-buffer))
(confirm-nonexistent-file-or-buffer)))))
@@ -8474,13 +8687,13 @@ Return the buffer switched to."
(when set-window-start-and-point
(let* ((entry (assq buffer (window-prev-buffers)))
- (displayed (and (eq switch-to-buffer-preserve-window-point
- 'already-displayed)
+ (preserve-win-point
+ (buffer-local-value 'switch-to-buffer-preserve-window-point
+ buffer))
+ (displayed (and (eq preserve-win-point 'already-displayed)
(get-buffer-window buffer 0))))
(set-window-buffer nil buffer)
- (when (and entry
- (or (eq switch-to-buffer-preserve-window-point t)
- displayed))
+ (when (and entry (or (eq preserve-win-point t) displayed))
;; Try to restore start and point of buffer in the selected
;; window (Bug#4041).
(set-window-start (selected-window) (nth 1 entry) t)
@@ -8520,6 +8733,13 @@ documentation for additional customization information."
BUFFER-OR-NAME may be a buffer, a string (a buffer name), or
nil. Return the buffer switched to.
+This uses the function `display-buffer' as a subroutine to
+display the buffer; see its documentation for additional
+customization information. By default, if the buffer is already
+displayed (even in the current frame), that window is selected.
+If the buffer isn't displayed in any frame, a new frame is popped
+up and the buffer is displayed there.
+
If called interactively, read the buffer name using `read-buffer'.
The variable `confirm-nonexistent-file-or-buffer' determines
whether to request confirmation before creating a new buffer.
@@ -8531,13 +8751,69 @@ buffer, create a new buffer with that name. If BUFFER-OR-NAME is
nil, switch to the buffer returned by `other-buffer'.
Optional second arg NORECORD non-nil means do not put this
-buffer at the front of the list of recently selected ones.
-
-This uses the function `display-buffer' as a subroutine; see its
-documentation for additional customization information."
+buffer at the front of the list of recently selected ones."
(interactive
(list (read-buffer-to-switch "Switch to buffer in other frame: ")))
(pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord))
+
+(defun display-buffer-override-next-command (pre-function &optional post-function echo)
+ "Set `display-buffer-overriding-action' for the next command.
+`pre-function' is called to prepare the window where the buffer should be
+displayed. This function takes two arguments `buffer' and `alist', and
+should return a cons with the displayed window and its type. See the
+meaning of these values in `window--display-buffer'.
+Optional `post-function' is called after the buffer is displayed in the
+window; the function takes two arguments: an old and new window.
+Optional string argument `echo' can be used to add a prefix to the
+command echo keystrokes that should describe the current prefix state.
+This returns an \"exit function\", which can be called with no argument
+to deactivate this overriding action."
+ (let* ((old-window (or (minibuffer-selected-window) (selected-window)))
+ (new-window nil)
+ (minibuffer-depth (minibuffer-depth))
+ (clearfun (make-symbol "clear-display-buffer-overriding-action"))
+ (postfun (make-symbol "post-display-buffer-override-next-command"))
+ (action (lambda (buffer alist)
+ (unless (> (minibuffer-depth) minibuffer-depth)
+ (let* ((ret (funcall pre-function buffer alist))
+ (window (car ret))
+ (type (cdr ret)))
+ (setq new-window (window--display-buffer buffer window
+ type alist))
+ ;; Reset display-buffer-overriding-action
+ ;; after the first display-buffer action (bug#39722).
+ (funcall clearfun)
+ new-window))))
+ (command this-command)
+ (echofun (when echo (lambda () echo)))
+ (exitfun
+ (lambda ()
+ (funcall clearfun)
+ (remove-hook 'post-command-hook postfun)
+ (remove-hook 'prefix-command-echo-keystrokes-functions echofun)
+ (when (functionp post-function)
+ (funcall post-function old-window new-window)))))
+ (fset clearfun
+ (lambda ()
+ (setcar display-buffer-overriding-action
+ (delq action (car display-buffer-overriding-action)))))
+ (fset postfun
+ (lambda ()
+ (unless (or
+ ;; Remove the hook immediately
+ ;; after exiting the minibuffer.
+ (> (minibuffer-depth) minibuffer-depth)
+ ;; But don't remove immediately after
+ ;; adding the hook by the same command below.
+ (eq this-command command))
+ (funcall exitfun))))
+ ;; Call post-function after the next command finishes (bug#49057).
+ (add-hook 'post-command-hook postfun)
+ (when echofun
+ (add-hook 'prefix-command-echo-keystrokes-functions echofun))
+ (push action (car display-buffer-overriding-action))
+ exitfun))
+
(defun set-window-text-height (window height)
"Set the height in lines of the text display area of WINDOW to HEIGHT.
@@ -8598,16 +8874,32 @@ in some window."
(setq end (point-max)))
(if (= beg end)
0
- (save-excursion
- (save-restriction
- (widen)
- (narrow-to-region (min beg end)
- (if (and (not count-final-newline)
- (= ?\n (char-before (max beg end))))
- (1- (max beg end))
- (max beg end)))
- (goto-char (point-min))
- (1+ (vertical-motion (buffer-size) window))))))
+ (let ((start (min beg end))
+ (finish (max beg end))
+ count end-invisible-p)
+ ;; When END is invisible because lines are truncated in WINDOW,
+ ;; vertical-motion returns a number that is 1 larger than it
+ ;; should. We need to fix that.
+ (setq end-invisible-p
+ (and (or truncate-lines
+ (and (natnump truncate-partial-width-windows)
+ (< (window-total-width window)
+ truncate-partial-width-windows)))
+ (save-excursion
+ (goto-char finish)
+ (> (- (current-column) (window-hscroll window))
+ (window-body-width window)))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (narrow-to-region start
+ (if (and (not count-final-newline)
+ (= ?\n (char-before finish)))
+ (1- finish)
+ finish))
+ (goto-char start)
+ (setq count (vertical-motion (buffer-size) window))
+ (if end-invisible-p count (1+ count)))))))
(defun window-buffer-height (window)
"Return the height (in screen lines) of the buffer that WINDOW is displaying.
@@ -8630,7 +8922,11 @@ font on WINDOW's frame."
(let* ((window (window-normalize-window window t))
(frame (window-frame window))
(default-font (face-font 'default frame)))
- (if (and (display-multi-font-p (frame-parameter frame 'display))
+ ;; Client frames can have the 'display' parameter set like for X
+ ;; frames, even though they are TTY frames, so make sure we won't
+ ;; be duped by that up front with 'framep'.
+ (if (and (not (eq (framep frame) t))
+ (display-multi-font-p (frame-parameter frame 'display))
(not (string-equal (frame-parameter frame 'font) default-font)))
(aref (font-info default-font frame) 3)
(frame-char-height frame))))
@@ -9383,8 +9679,7 @@ buffers displaying right to left text."
;; status is undone only when explicitly programmed, not when a buffer
;; is reverted or a mode function is called.
-(defvar window-group-start-function nil)
-(make-variable-buffer-local 'window-group-start-function)
+(defvar-local window-group-start-function nil)
(put 'window-group-start-function 'permanent-local t)
(defun window-group-start (&optional window)
"Return position at which display currently starts in the group of
@@ -9397,8 +9692,7 @@ This is updated by redisplay or by calling `set-window*-start'."
(funcall window-group-start-function window)
(window-start window)))
-(defvar window-group-end-function nil)
-(make-variable-buffer-local 'window-group-end-function)
+(defvar-local window-group-end-function nil)
(put 'window-group-end-function 'permanent-local t)
(defun window-group-end (&optional window update)
"Return position at which display currently ends in the group of
@@ -9417,8 +9711,7 @@ if it isn't already recorded."
(funcall window-group-end-function window update)
(window-end window update)))
-(defvar set-window-group-start-function nil)
-(make-variable-buffer-local 'set-window-group-start-function)
+(defvar-local set-window-group-start-function nil)
(put 'set-window-group-start-function 'permanent-local t)
(defun set-window-group-start (window pos &optional noforce)
"Make display in the group of windows containing WINDOW start at
@@ -9432,8 +9725,7 @@ overriding motion of point in order to display at this exact start."
(funcall set-window-group-start-function window pos noforce)
(set-window-start window pos noforce)))
-(defvar recenter-window-group-function nil)
-(make-variable-buffer-local 'recenter-window-group-function)
+(defvar-local recenter-window-group-function nil)
(put 'recenter-window-group-function 'permanent-local t)
(defun recenter-window-group (&optional arg)
"Center point in the group of windows containing the selected window
@@ -9459,8 +9751,7 @@ and redisplay normally--don't erase and redraw the frame."
(funcall recenter-window-group-function arg)
(recenter arg)))
-(defvar pos-visible-in-window-group-p-function nil)
-(make-variable-buffer-local 'pos-visible-in-window-group-p-function)
+(defvar-local pos-visible-in-window-group-p-function nil)
(put 'pos-visible-in-window-group-p-function 'permanent-local t)
(defun pos-visible-in-window-group-p (&optional pos window partially)
"Return non-nil if position POS is currently on the frame in the
@@ -9490,8 +9781,7 @@ POS, ROWH is the visible height of that row, and VPOS is the row number
(funcall pos-visible-in-window-group-p-function pos window partially)
(pos-visible-in-window-p pos window partially)))
-(defvar selected-window-group-function nil)
-(make-variable-buffer-local 'selected-window-group-function)
+(defvar-local selected-window-group-function nil)
(put 'selected-window-group-function 'permanent-local t)
(defun selected-window-group ()
"Return the list of windows in the group containing the selected window.
@@ -9501,8 +9791,7 @@ result is a list containing only the selected window."
(funcall selected-window-group-function)
(list (selected-window))))
-(defvar move-to-window-group-line-function nil)
-(make-variable-buffer-local 'move-to-window-group-line-function)
+(defvar-local move-to-window-group-line-function nil)
(put 'move-to-window-group-line-function 'permanent-local t)
(defun move-to-window-group-line (arg)
"Position point relative to the current group of windows.
@@ -9580,6 +9869,19 @@ With plain \\[universal-argument], move current line to window center."
(define-key global-map [?\C-l] 'recenter-top-bottom)
+(defun recenter-other-window (&optional arg)
+ "Call `recenter-top-bottom' in the other window.
+
+A prefix argument is handled like `recenter':
+ With numeric prefix ARG, move current line to window-line ARG.
+ With plain `C-u', move current line to window center."
+ (interactive "P")
+ (with-selected-window (other-window-for-scrolling)
+ (recenter-top-bottom arg)
+ (pulse-momentary-highlight-one-line (point))))
+
+(define-key global-map [?\S-\M-\C-l] 'recenter-other-window)
+
(defun move-to-window-line-top-bottom (&optional arg)
"Position point relative to window.
@@ -9887,6 +10189,9 @@ is active. This function is run by `mouse-autoselect-window-timer'."
;; already selected.
(and (not (eq frame (selected-frame)))
(frame-parameter frame 'no-accept-focus))
+ ;; Don't switch if window autoselection with mouse is active
+ ;; and minibuffer window is selected.
+ (and mouse-autoselect-window (window-minibuffer-p))
;; Don't switch to minibuffer window unless it's active.
(and (window-minibuffer-p window)
(not (minibuffer-window-active-p window))))
@@ -10048,5 +10353,35 @@ displaying that processes's buffer."
(define-key ctl-x-map "-" 'shrink-window-if-larger-than-buffer)
(define-key ctl-x-map "+" 'balance-windows)
(define-key ctl-x-4-map "0" 'kill-buffer-and-window)
+(define-key ctl-x-4-map "1" 'same-window-prefix)
+(define-key ctl-x-4-map "4" 'other-window-prefix)
+
+(defvar other-window-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "o" 'other-window)
+ (define-key map "O" (lambda ()
+ (interactive)
+ (setq repeat-map 'other-window-repeat-map)
+ (other-window -1)))
+ map)
+ "Keymap to repeat other-window key sequences. Used in `repeat-mode'.")
+(put 'other-window 'repeat-map 'other-window-repeat-map)
+
+(defvar resize-window-repeat-map
+ (let ((map (make-sparse-keymap)))
+ ;; Standard keys:
+ (define-key map "^" 'enlarge-window)
+ (define-key map "}" 'enlarge-window-horizontally)
+ (define-key map "{" 'shrink-window-horizontally)
+ ;; Additional keys:
+ (define-key map "v" 'shrink-window)
+ map)
+ "Keymap to repeat window resizing commands. Used in `repeat-mode'.")
+(put 'enlarge-window 'repeat-map 'resize-window-repeat-map)
+(put 'enlarge-window-horizontally 'repeat-map 'resize-window-repeat-map)
+(put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map)
+(put 'shrink-window 'repeat-map 'resize-window-repeat-map)
+
+(provide 'window)
;;; window.el ends here
diff --git a/lisp/winner.el b/lisp/winner.el
index 9506ac53bb2..8062fbae904 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -1,4 +1,4 @@
-;;; winner.el --- Restore old window configurations
+;;; winner.el --- Restore old window configurations -*- lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
@@ -33,14 +33,13 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(require 'ring)
(defun winner-active-region ()
(declare (gv-setter (lambda (store)
`(if ,store (activate-mark) (deactivate-mark)))))
(region-active-p))
-(require 'ring)
-
(defgroup winner nil
"Restoring window configurations."
:group 'windows)
@@ -273,7 +272,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
(let* ((buffers nil)
(alive
;; Possibly update `winner-point-alist'
- (cl-loop for buf in (mapcar 'cdr (cdr conf))
+ (cl-loop for buf in (mapcar #'cdr (cdr conf))
for pos = (winner-get-point buf nil)
if (and pos (not (memq buf buffers)))
do (push buf buffers)
@@ -284,17 +283,8 @@ You may want to include buffer names such as *Help*, *Apropos*,
;; Restore points
(dolist (win (winner-sorted-window-list))
(unless (and (pop alive)
- (let* ((buf (window-buffer win))
- (pos (winner-get-point (window-buffer win) win))
- (entry (assq buf (window-prev-buffers win))))
- ;; Try to restore point of buffer in the selected
- ;; window (Bug#23621).
- (let ((marker (nth 2 entry)))
- (when (and switch-to-buffer-preserve-window-point
- marker
- (not (= marker pos)))
- (setq pos marker))
- (setf (window-point win) pos)))
+ (setf (window-point win)
+ (winner-get-point (window-buffer win) win))
(not (or (member (buffer-name (window-buffer win))
winner-boring-buffers)
(and winner-boring-buffers-regexp
@@ -317,7 +307,7 @@ You may want to include buffer names such as *Help*, *Apropos*,
;; Return t if this is still a possible configuration.
(or (null xwins)
(progn
- (mapc 'delete-window (cdr xwins)) ; delete all but one
+ (mapc #'delete-window (cdr xwins)) ; delete all but one
(unless (one-window-p t)
(delete-window (car xwins))
t))))))
@@ -328,22 +318,20 @@ You may want to include buffer names such as *Help*, *Apropos*,
(defcustom winner-mode-hook nil
"Functions to run whenever Winner mode is turned on or off."
- :type 'hook
- :group 'winner)
+ :type 'hook)
(define-obsolete-variable-alias 'winner-mode-leave-hook
'winner-mode-off-hook "24.3")
(defcustom winner-mode-off-hook nil
"Functions to run whenever Winner mode is turned off."
- :type 'hook
- :group 'winner)
+ :type 'hook)
(defvar winner-mode-map
(let ((map (make-sparse-keymap)))
(unless winner-dont-bind-my-keys
- (define-key map [(control c) left] 'winner-undo)
- (define-key map [(control c) right] 'winner-redo))
+ (define-key map [(control c) left] #'winner-undo)
+ (define-key map [(control c) right] #'winner-redo))
map)
"Keymap for Winner mode.")
diff --git a/lisp/woman.el b/lisp/woman.el
index 73040e096a1..0bc992d8f7f 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1,4 +1,4 @@
-;;; woman.el --- browse UN*X manual pages `wo (without) man'
+;;; woman.el --- browse UN*X manual pages `wo (without) man' -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -6,7 +6,7 @@
;; Maintainer: emacs-devel@gnu.org
;; Keywords: help, unix
;; Adapted-By: Eli Zaretskii <eliz@gnu.org>
-;; Version: 0.551
+;; Old-Version: 0.551
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/
;; This file is part of GNU Emacs.
@@ -69,13 +69,7 @@
;; Recommended use
;; ===============
-;; Put this in your .emacs:
-;; (autoload 'woman "woman"
-;; "Decode and browse a UN*X man page." t)
-;; (autoload 'woman-find-file "woman"
-;; "Find, decode and browse a specific UN*X man-page file." t)
-
-;; Then either (1 -- *RECOMMENDED*): If the `MANPATH' environment
+;; Either (1 -- *RECOMMENDED*): If the `MANPATH' environment
;; variable is set then WoMan will use it; otherwise you may need to
;; reset the Lisp variable `woman-manpath', and you may also want to
;; set the Lisp variable `woman-path'. Please see the online
@@ -139,14 +133,8 @@
;; ==============================
;; WoMan supports the GNU Emacs customization facility, and puts
-;; a customization group called `WoMan' in the `Help' group under the
-;; top-level `Emacs' group. In order to be able to customize WoMan
-;; without first loading it, add the following sexp to your .emacs:
-
-;; (defgroup woman nil
-;; "Browse UNIX manual pages `wo (without) man'."
-;; :tag "WoMan" :group 'help :load "woman")
-
+;; a customization group called `woman' in the `help' group under the
+;; top-level `emacs' group.
;; WoMan currently runs two hooks: `woman-pre-format-hook' immediately
;; before formatting a buffer and `woman-post-format-hook' immediately
@@ -400,10 +388,9 @@
;;; Code:
-(defvar woman-version "0.551 (beta)" "WoMan version information.")
+(eval-when-compile (require 'cl-lib))
(require 'man)
-(require 'button)
(define-button-type 'WoMan-xref-man-page
:supertype 'Man-abstract-xref-man-page
'func (lambda (arg)
@@ -430,14 +417,14 @@ As a special case, if PATHS is nil then replace it by calling
;; an empty substring of MANPATH denotes the default list.
(if (memq system-type '(windows-nt ms-dos))
(cond ((null paths)
- (mapcar 'woman-Cyg-to-Win (woman-parse-man.conf)))
+ (mapcar #'woman-Cyg-to-Win (woman-parse-man.conf)))
((string-match-p ";" paths)
;; Assume DOS-style path-list...
(mapcan ; splice list into list
(lambda (x)
(if x
(list x)
- (mapcar 'woman-Cyg-to-Win (woman-parse-man.conf))))
+ (mapcar #'woman-Cyg-to-Win (woman-parse-man.conf))))
(parse-colon-path paths)))
((string-match-p "\\`[a-zA-Z]:" paths)
;; Assume single DOS-style path...
@@ -446,7 +433,7 @@ As a special case, if PATHS is nil then replace it by calling
;; Assume UNIX/Cygwin-style path-list...
(mapcan ; splice list into list
(lambda (x)
- (mapcar 'woman-Cyg-to-Win
+ (mapcar #'woman-Cyg-to-Win
(if x (list x) (woman-parse-man.conf))))
(let ((path-separator ":"))
(parse-colon-path paths)))))
@@ -521,7 +508,7 @@ Change only via `Customization' or the function `add-hook'."
(defcustom woman-man.conf-path
(let ((path '("/usr/lib" "/etc")))
(cond ((eq system-type 'windows-nt)
- (mapcar 'woman-Cyg-to-Win path))
+ (mapcar #'woman-Cyg-to-Win path))
((eq system-type 'darwin)
(cons "/usr/share/misc" path))
(t path)))
@@ -674,7 +661,7 @@ These normally have names of the form `man?'. Its default value is
\"[Mm][Aa][Nn]\", which is case-insensitive mainly for the benefit of
Microsoft platforms. Its purpose is to avoid `cat?', `.', `..', etc."
;; Based on a suggestion by Wei-Xue Shi.
- :type 'string
+ :type 'regexp
:group 'woman-interface)
(defcustom woman-path
@@ -753,7 +740,7 @@ Default is t."
An alist with elements of the form (MENU-TITLE REGEXP INDEX) --
see the documentation for `imenu-generic-expression'."
:type '(alist :key-type (choice :tag "Title" (const nil) string)
- :value-type (group (choice (string :tag "Regexp")
+ :value-type (group (choice (regexp :tag "Regexp")
function)
integer))
:group 'woman-interface)
@@ -821,7 +808,7 @@ in the ncurses package include `toe.1m', `form.3x', etc.
Note: an optional compression regexp will be appended, so this regexp
MUST NOT end with any kind of string terminator such as $ or \\\\='."
:type 'regexp
- :set 'set-woman-file-regexp
+ :set #'set-woman-file-regexp
:group 'woman-interface)
(defcustom woman-file-compression-regexp
@@ -837,7 +824,7 @@ Should begin with \\. and end with \\\\=' and MUST NOT be optional."
;; not loaded by default!
:version "24.1" ; added xz
:type 'regexp
- :set 'set-woman-file-regexp
+ :set #'set-woman-file-regexp
:group 'woman-interface)
(defcustom woman-use-own-frame nil
@@ -913,8 +900,8 @@ Troff emulation is experimental and largely untested.
:group 'faces)
(defcustom woman-fontify
- (or (and (fboundp 'display-color-p) (display-color-p))
- (and (fboundp 'display-graphic-p) (display-graphic-p))
+ (or (display-color-p)
+ (display-graphic-p)
(x-display-color-p))
"If non-nil then WoMan assumes that face support is available.
It defaults to a non-nil value if the display supports either colors
@@ -1078,9 +1065,8 @@ Set by `.ns' request; reset by any output or `.rs' request")
;; Could end with "\\( +\\|$\\)" instead of " *"
"Regexp to match a ?roff request plus trailing white space.")
-(defvar woman-imenu-done nil
+(defvar-local woman-imenu-done nil
"Buffer-local: set to true if function `woman-imenu' has been called.")
-(make-variable-buffer-local 'woman-imenu-done)
;; From imenu.el -- needed when reformatting a file in its old buffer.
;; The latest buffer index used to update the menu bar menu.
@@ -1199,7 +1185,7 @@ Called both to generate and to check the cache!"
(setq dir (and (member (car dir) path) (cdr dir))))
(when dir
(cl-pushnew (substitute-in-file-name dir) lst :test #'equal))))
- (mapcar 'substitute-in-file-name woman-path)))
+ (mapcar #'substitute-in-file-name woman-path)))
(defun woman-read-directory-cache ()
"Load the directory and topic cache.
@@ -1276,14 +1262,11 @@ cache to be re-read."
(test-completion
word-at-point woman-topic-all-completions))
word-at-point)))
- (completing-read
- (if default
- (format "Manual entry (default %s): " default)
- "Manual entry: ")
- woman-topic-all-completions nil 1
- nil
- 'woman-topic-history
- default))))
+ (completing-read (format-prompt "Manual entry" default)
+ woman-topic-all-completions nil 1
+ nil
+ 'woman-topic-history
+ default))))
;; Note that completing-read always returns a string.
(unless (= (length topic) 0)
(cond
@@ -1291,9 +1274,11 @@ cache to be re-read."
;; Complete topic more carefully, i.e. use the completion
;; rather than the string entered by the user:
((setq files (all-completions topic woman-topic-all-completions))
- (while (/= (length topic) (length (car files)))
+ (while (and files
+ (/= (length topic) (length (car files))))
(setq files (cdr files)))
- (setq files (woman-file-name-all-completions (car files)))))
+ (when files
+ (setq files (woman-file-name-all-completions (car files))))))
(cond
((null files) nil) ; no file found for topic.
((null (cdr files)) (car (car files))) ; only 1 file for topic.
@@ -1517,14 +1502,14 @@ Also make each path-info component into a list.
(if (woman-not-member dir path) ; use each directory only once!
(setq files (nconc files
(directory-files dir t topic-regexp))))))
- (mapcar 'list files)))
+ (mapcar #'list files)))
;;; dired support
(defun woman-dired-define-key (key)
"Bind the argument KEY to the command `woman-dired-find-file'."
- (define-key dired-mode-map key 'woman-dired-find-file))
+ (define-key dired-mode-map key #'woman-dired-find-file))
(defsubst woman-dired-define-key-maybe (key)
"If KEY is undefined in Dired, bind it to command `woman-dired-find-file'."
@@ -1536,7 +1521,7 @@ Also make each path-info component into a list.
"Define dired keys to run WoMan according to `woman-dired-keys'."
(if woman-dired-keys
(if (listp woman-dired-keys)
- (mapc 'woman-dired-define-key woman-dired-keys)
+ (mapc #'woman-dired-define-key woman-dired-keys)
(woman-dired-define-key-maybe "w")
(woman-dired-define-key-maybe "W")))
(define-key-after (lookup-key dired-mode-map [menu-bar immediate])
@@ -1544,7 +1529,7 @@ Also make each path-info component into a list.
(if (featurep 'dired)
(woman-dired-define-keys)
- (add-hook 'dired-mode-hook 'woman-dired-define-keys))
+ (add-hook 'dired-mode-hook #'woman-dired-define-keys))
(declare-function dired-get-filename "dired"
(&optional localp no-error-if-not-filep))
@@ -1770,15 +1755,15 @@ Leave point at end of new text. Return length of inserted text."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map Man-mode-map)
- (define-key map "R" 'woman-reformat-last-file)
- (define-key map "w" 'woman)
- (define-key map "\en" 'WoMan-next-manpage)
- (define-key map "\ep" 'WoMan-previous-manpage)
- (define-key map [M-mouse-2] 'woman-follow-word)
+ (define-key map "R" #'woman-reformat-last-file)
+ (define-key map "w" #'woman)
+ (define-key map "\en" #'WoMan-next-manpage)
+ (define-key map "\ep" #'WoMan-previous-manpage)
+ (define-key map [M-mouse-2] #'woman-follow-word)
;; We don't need to call `man' when we are in `woman-mode'.
- (define-key map [remap man] 'woman)
- (define-key map [remap man-follow] 'woman-follow)
+ (define-key map [remap man] #'woman)
+ (define-key map [remap man-follow] #'woman-follow)
map)
"Keymap for `woman-mode'.")
@@ -1830,7 +1815,6 @@ Argument EVENT is the invoking mouse event."
["Mini Help" woman-mini-help t]
,@(if (fboundp 'customize-group)
'(["Customize..." (customize-group 'woman) t]))
- ["Show Version" (message "WoMan %s" woman-version) t]
"--"
("Advanced"
["View Source" (view-file woman-last-file-name) woman-last-file-name]
@@ -1873,31 +1857,22 @@ Argument EVENT is the invoking mouse event."
(defvar bookmark-make-record-function)
-(define-derived-mode woman-mode special-mode "WoMan"
+(define-derived-mode woman-mode man-common "WoMan"
"Turn on (most of) Man mode to browse a buffer formatted by WoMan.
WoMan is an ELisp emulation of much of the functionality of the Emacs
`man' command running the standard UN*X man and ?roff programs.
WoMan author: F.J.Wright@Maths.QMW.ac.uk
-WoMan version: see `woman-version'.
See `Man-mode' for additional details.
\\{woman-mode-map}"
- (let ((Man-build-page-list (symbol-function 'Man-build-page-list))
- (Man-strip-page-headers (symbol-function 'Man-strip-page-headers))
- (Man-unindent (symbol-function 'Man-unindent))
- (Man-goto-page (symbol-function 'Man-goto-page)))
+ ;; FIXME: Should all this just be re-arranged so that this can just
+ ;; inherit `man-common' and be done with it?
+ (cl-letf (((symbol-function 'Man-build-page-list) #'ignore)
+ ((symbol-function 'Man-strip-page-headers) #'ignore)
+ ((symbol-function 'Man-unindent) #'ignore)
+ ((symbol-function 'Man-goto-page) #'ignore))
;; Prevent inappropriate operations:
- (fset 'Man-build-page-list 'ignore)
- (fset 'Man-strip-page-headers 'ignore)
- (fset 'Man-unindent 'ignore)
- (fset 'Man-goto-page 'ignore)
- (unwind-protect
- (delay-mode-hooks (Man-mode))
- ;; Restore the status quo:
- (fset 'Man-build-page-list Man-build-page-list)
- (fset 'Man-strip-page-headers Man-strip-page-headers)
- (fset 'Man-unindent Man-unindent)
- (fset 'Man-goto-page Man-goto-page)
- (setq tab-width woman-tab-width)))
+ (delay-mode-hooks (Man-mode)))
+ (setq tab-width woman-tab-width)
(setq major-mode 'woman-mode
mode-name "WoMan")
;; Don't show page numbers like Man-mode does. (Online documents do
@@ -1908,7 +1883,7 @@ See `Man-mode' for additional details.
(setq imenu-generic-expression woman-imenu-generic-expression)
(setq-local imenu-space-replacement " ")
;; Bookmark support.
- (setq-local bookmark-make-record-function 'woman-bookmark-make-record)
+ (setq-local 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)
@@ -2120,7 +2095,7 @@ No external programs are used."
(interactive) ; mainly for testing
(WoMan-log-begin)
(run-hooks 'woman-pre-format-hook)
- (and (boundp 'font-lock-mode) font-lock-mode (font-lock-mode -1))
+ (and font-lock-mode (font-lock-mode -1))
;; (fundamental-mode)
(let ((start-time (current-time))
time)
@@ -2293,6 +2268,12 @@ Currently set only from \\='\\\" t in the first line of the source file.")
(setq fill-column woman-fill-column
tab-width woman-tab-width)
+ ;; Ignore the \, and \/ kerning operators. See
+ ;; https://www.gnu.org/software/groff/manual/groff.html#Ligatures-and-Kerning
+ (goto-char (point-min))
+ (while (re-search-forward "\\\\[,/]" nil t)
+ (replace-match "" t t))
+
;; Hide unpaddable and digit-width spaces \(space) and \0:
(goto-char from)
(while (re-search-forward "\\\\[ 0]" nil t)
@@ -2441,6 +2422,10 @@ Preserves location of `point'."
(defvar woman0-rename-alist) ; bound in woman0-roff-buffer
+;; Bound locally by woman[012]-roff-buffer, and woman0-macro.
+;; Use dynamically in woman-unquote and woman-forward-arg.
+(defvar woman-request)
+
(defun woman0-roff-buffer (from)
"Process conditional-type requests and user-defined macros.
Start at FROM and re-scan new text as appropriate."
@@ -2760,15 +2745,16 @@ Optional argument APPEND, if non-nil, means append macro."
;; request may be used dynamically (woman-interpolate-macro calls
;; woman-forward-arg).
-(defun woman0-macro (woman-request)
- "Process the macro call named WOMAN-REQUEST."
+(defun woman0-macro (request)
+ "Process the macro call named REQUEST."
;; Leaves point at start of new text.
- (let ((macro (assoc woman-request woman0-macro-alist)))
+ (let ((woman-request request)
+ (macro (assoc 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!" woman-request))))
+ (WoMan-warn "Undefined macro %s not interpolated!" request))))
(defun woman-interpolate-macro (macro)
"Interpolate (.de) or append (.am) expansion of MACRO into the buffer."
@@ -2992,11 +2978,6 @@ Useful for constructing the alist variable `woman-special-characters'."
;;; Formatting macros that do not cause a break:
-;; 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.
Leave point at TO (which should be a marker)."
@@ -3077,7 +3058,7 @@ B-OR-I is the appropriate complete control line."
".SM -- Set the current line in small font, i.e. IGNORE!"
nil)
-(defalias 'woman1-SB 'woman1-B)
+(defalias 'woman1-SB #'woman1-B)
;; .SB -- Set the current line in small bold font, i.e. just embolden!
;; (This is what /usr/local/share/groff/tmac/tmac.an does. The
;; Linux man.7 is wrong about this!)
@@ -3207,27 +3188,27 @@ If optional arg CONCAT is non-nil then join arguments."
;;; Other non-breaking requests correctly ignored by nroff:
(put 'woman1-ps 'notfont t)
-(defalias 'woman1-ps 'woman-delete-whole-line)
+(defalias 'woman1-ps #'woman-delete-whole-line)
;; .ps -- Point size -- IGNORE!
(put 'woman1-ss 'notfont t)
-(defalias 'woman1-ss 'woman-delete-whole-line)
+(defalias 'woman1-ss #'woman-delete-whole-line)
;; .ss -- Space-character size -- IGNORE!
(put 'woman1-cs 'notfont t)
-(defalias 'woman1-cs 'woman-delete-whole-line)
+(defalias 'woman1-cs #'woman-delete-whole-line)
;; .cs -- Constant character space (width) mode -- IGNORE!
(put 'woman1-ne 'notfont t)
-(defalias 'woman1-ne 'woman-delete-whole-line)
+(defalias 'woman1-ne #'woman-delete-whole-line)
;; .ne -- Need vertical space -- IGNORE!
(put 'woman1-vs 'notfont t)
-(defalias 'woman1-vs 'woman-delete-whole-line)
+(defalias 'woman1-vs #'woman-delete-whole-line)
;; .vs -- Vertical base line spacing -- IGNORE!
(put 'woman1-bd 'notfont t)
-(defalias 'woman1-bd 'woman-delete-whole-line)
+(defalias 'woman1-bd #'woman-delete-whole-line)
;; .bd -- Embolden font -- IGNORE!
;;; Non-breaking SunOS-specific macros:
@@ -3238,7 +3219,7 @@ If optional arg CONCAT is non-nil then join arguments."
(woman-forward-arg 'unquote 'concat))
(put 'woman1-IX 'notfont t)
-(defalias 'woman1-IX 'woman-delete-whole-line)
+(defalias 'woman1-IX #'woman-delete-whole-line)
;; .IX -- Index macro, for Sun internal use -- IGNORE!
@@ -3587,7 +3568,7 @@ expression in parentheses. Leaves point after the value."
inc (cdr value)
;; eval internal (.X) registers
;; stored as lisp variable names:
- value (eval (car value)))
+ value (eval (car value) t))
(if (and pm inc) ; auto-increment
(setq value
(funcall (intern-soft pm) value inc)
@@ -3647,64 +3628,55 @@ expression in parentheses. Leaves point after the value."
"Process breaks. Format paragraphs and headings."
(let ((case-fold-search t)
(to (make-marker))
- (canonically-space-region
- (symbol-function 'canonically-space-region))
- (insert-and-inherit (symbol-function 'insert-and-inherit))
- (set-text-properties (symbol-function 'set-text-properties))
(woman-registers woman-registers)
fn woman-request woman-translations
tab-stop-list)
(set-marker-insertion-type to t)
;; ?roff does not squeeze multiple spaces, but does fill, so...
- (fset 'canonically-space-region 'ignore)
- ;; Try to avoid spaces inheriting underlines from preceding text!
- (fset 'insert-and-inherit (symbol-function 'insert))
- (fset 'set-text-properties 'ignore)
- (unwind-protect
- (progn
- (while
- ;; Find next control line:
- (re-search-forward woman-request-regexp nil t)
- (cond
- ;; Construct woman function to call:
- ((setq fn (intern-soft
- (concat "woman2-"
- (setq woman-request (match-string 1)))))
- ;; Delete request or macro name:
- (woman-delete-match 0))
- ;; Unrecognized request:
- ((prog1 nil
- ;; (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)
- ))
- ;; .LP assumes it is at eol and leaves a (blank) line,
- ;; so leave point at end of line before paragraph:
- ((or (looking-at "[ \t]*$") ; no argument
- woman-ignore) ; ignore all
- ;; (beginning-of-line) (kill-line)
- ;; AVOID LEAVING A BLANK LINE!
- (beginning-of-line) (woman-delete-line 1))
- (t (end-of-line) (insert ?\n)))
- (if (not (or fn
- (and (not (memq (following-char) '(?. ?')))
- (setq fn 'woman2-format-paragraphs))))
- ()
- ;; Find next control line:
- (if (equal woman-request "TS")
- (set-marker to (woman-find-next-control-line "TE"))
- (set-marker to (woman-find-next-control-line)))
- ;; Call the appropriate function:
- (funcall fn to)))
- (if (not (eobp)) ; This should not happen, but ...
- (woman2-format-paragraphs (copy-marker (point-max) t)
- woman-left-margin)))
- (fset 'canonically-space-region canonically-space-region)
- (fset 'set-text-properties set-text-properties)
- (fset 'insert-and-inherit insert-and-inherit)
- (set-marker to nil))))
+ (cl-letf (((symbol-function 'canonically-space-region) #'ignore)
+ ;; Try to avoid spaces inheriting underlines from preceding text!
+ ((symbol-function 'insert-and-inherit) #'insert)
+ ((symbol-function 'set-text-properties) #'ignore))
+ (while
+ ;; Find next control line:
+ (re-search-forward woman-request-regexp nil t)
+ (cond
+ ;; Construct woman function to call:
+ ((setq fn (intern-soft
+ (concat "woman2-"
+ (setq woman-request (match-string 1)))))
+ ;; Delete request or macro name:
+ (woman-delete-match 0))
+ ;; Unrecognized request:
+ ((prog1 nil
+ ;; (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)
+ ))
+ ;; .LP assumes it is at eol and leaves a (blank) line,
+ ;; so leave point at end of line before paragraph:
+ ((or (looking-at "[ \t]*$") ; no argument
+ woman-ignore) ; ignore all
+ ;; (beginning-of-line) (kill-line)
+ ;; AVOID LEAVING A BLANK LINE!
+ (beginning-of-line) (woman-delete-line 1))
+ (t (end-of-line) (insert ?\n)))
+ (if (not (or fn
+ (and (not (memq (following-char) '(?. ?')))
+ (setq fn 'woman2-format-paragraphs))))
+ ()
+ ;; Find next control line:
+ (if (equal woman-request "TS")
+ (set-marker to (woman-find-next-control-line "TE"))
+ (set-marker to (woman-find-next-control-line)))
+ ;; Call the appropriate function:
+ (funcall fn to)))
+ (if (not (eobp)) ; This should not happen, but ...
+ (woman2-format-paragraphs (copy-marker (point-max) t)
+ woman-left-margin)))
+ (set-marker to nil)))
(defun woman-find-next-control-line (&optional pat)
"Find and return start of next control line.
@@ -3815,8 +3787,8 @@ Leave 1 blank line. Format paragraphs upto TO."
(setq woman-prevailing-indent woman-default-indent)
(woman2-format-paragraphs to woman-left-margin))
-(defalias 'woman2-PP 'woman2-LP)
-(defalias 'woman2-P 'woman2-LP)
+(defalias 'woman2-PP #'woman2-LP)
+(defalias 'woman2-P #'woman2-LP)
(defun woman2-ns (to)
".ns -- Turn on no-space mode. Format paragraphs upto TO."
@@ -4287,16 +4259,16 @@ Set prevailing indent to amount of starting .RS."
If no argument then use value of optional arg PREVIOUS if non-nil,
otherwise set PREVIOUS. Delete the whole remaining control line."
(if (eolp) ; space already skipped
- (set arg (if previous (eval previous) 0))
- (if previous (set previous (eval arg)))
+ (set arg (if previous (symbol-value previous) 0))
+ (if previous (set previous (symbol-value arg)))
(woman2-process-escapes-to-eol 'numeric)
(let ((pm (if (looking-at "[+-]")
(prog1 (following-char)
(forward-char 1))))
(i (woman-parse-numeric-arg)))
(cond ((null pm) (set arg i))
- ((= pm ?+) (set arg (+ (eval arg) i)))
- ((= pm ?-) (set arg (- (eval arg) i)))
+ ((= pm ?+) (set arg (+ (symbol-value arg) i)))
+ ((= pm ?-) (set arg (- (symbol-value arg) i)))
))
(beginning-of-line))
(woman-delete-line 1)) ; ignore any remaining arguments
@@ -4493,7 +4465,7 @@ Format paragraphs upto TO."
(setq woman-nofill t)
(woman2-format-paragraphs to))
-(defalias 'woman2-TE 'woman2-fi)
+(defalias 'woman2-TE #'woman2-fi)
;; ".TE -- End of table code for the tbl processor."
;; Turn filling and adjusting back on.
@@ -4607,6 +4579,11 @@ logging the message."
(bookmark-default-handler
`("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark)))))
+;; Obsolete.
+
+(defvar woman-version "0.551 (beta)" "WoMan version information.")
+(make-obsolete-variable 'woman-version 'emacs-version "28.1")
+
(provide 'woman)
;;; woman.el ends here
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 53b3b549ade..23e8001c013 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -1,4 +1,4 @@
-;;; x-dnd.el --- drag and drop support for X
+;;; x-dnd.el --- drag and drop support for X -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -32,7 +32,7 @@
(require 'dnd)
;;; Customizable variables
-(defcustom x-dnd-test-function 'x-dnd-default-test-function
+(defcustom x-dnd-test-function #'x-dnd-default-test-function
"The function drag and drop uses to determine if to accept or reject a drop.
The function takes three arguments, WINDOW, ACTION and TYPES.
WINDOW is where the mouse is when the function is called. WINDOW may be a
@@ -411,20 +411,16 @@ Coordinates are required to be absolute.
FRAME is the frame and W is the window where the drop happened.
If W is a window, return its absolute coordinates,
otherwise return the frame coordinates."
- (let* ((frame-left (frame-parameter frame 'left))
- ;; If the frame is outside the display, frame-left looks like
- ;; '(0 -16). Extract the -16.
- (frame-real-left (if (consp frame-left) (car (cdr frame-left))
- frame-left))
- (frame-top (frame-parameter frame 'top))
- (frame-real-top (if (consp frame-top) (car (cdr frame-top))
- frame-top)))
+ (let* ((frame-left (or (car-safe (cdr-safe (frame-parameter frame 'left)))
+ (frame-parameter frame 'left)))
+ (frame-top (or (car-safe (cdr-safe (frame-parameter frame 'top)))
+ (frame-parameter frame 'top))))
(if (windowp w)
(let ((edges (window-inside-pixel-edges w)))
(cons
- (+ frame-real-left (nth 0 edges))
- (+ frame-real-top (nth 1 edges))))
- (cons frame-real-left frame-real-top))))
+ (+ frame-left (nth 0 edges))
+ (+ frame-top (nth 1 edges))))
+ (cons frame-left frame-top))))
(declare-function x-get-atom-name "xselect.c" (value &optional frame))
(declare-function x-send-client-message "xselect.c"
@@ -434,15 +430,11 @@ otherwise return the frame coordinates."
(defun x-dnd-version-from-flags (flags)
"Return the version byte from the 32 bit FLAGS in an XDndEnter message."
- (if (consp flags) ;; Long as cons
- (ash (car flags) -8)
- (ash flags -24))) ;; Ordinary number
+ (ash flags -24))
(defun x-dnd-more-than-3-from-flags (flags)
"Return the nmore-than3 bit from the 32 bit FLAGS in an XDndEnter message."
- (if (consp flags)
- (logand (cdr flags) 1)
- (logand flags 1)))
+ (logand flags 1))
(defun x-dnd-handle-xdnd (event frame window message _format data)
"Receive one XDND event (client message) and send the appropriate reply.
@@ -454,7 +446,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(version (x-dnd-version-from-flags flags))
(more-than-3 (x-dnd-more-than-3-from-flags flags))
(dnd-source (aref data 0)))
- (message "%s %s" version more-than-3)
+ (message "%s %s" version more-than-3)
(if version ;; If flags is bad, version will be nil.
(x-dnd-save-state
window nil nil
@@ -495,10 +487,12 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
((equal "XdndDrop" message)
(if (windowp window) (select-window window))
(let* ((dnd-source (aref data 0))
+ (timestamp (aref data 2))
(value (and (x-dnd-current-type window)
(x-get-selection-internal
'XdndSelection
- (intern (x-dnd-current-type window)))))
+ (intern (x-dnd-current-type window))
+ timestamp)))
success action)
(setq action (if value
@@ -545,14 +539,14 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
((eq size 4)
(if (eq byteorder ?l)
- (cons (+ (ash (aref data (+ 3 offset)) 8)
- (aref data (+ 2 offset)))
- (+ (ash (aref data (1+ offset)) 8)
- (aref data offset)))
- (cons (+ (ash (aref data offset) 8)
- (aref data (1+ offset)))
- (+ (ash (aref data (+ 2 offset)) 8)
- (aref data (+ 3 offset))))))))
+ (+ (ash (aref data (+ 3 offset)) 24)
+ (ash (aref data (+ 2 offset)) 16)
+ (ash (aref data (1+ offset)) 8)
+ (aref data offset))
+ (+ (ash (aref data offset) 24)
+ (ash (aref data (1+ offset)) 16)
+ (ash (aref data (+ 2 offset)) 8)
+ (aref data (+ 3 offset)))))))
(defun x-dnd-motif-value-to-list (value size byteorder)
(let ((bytes (cond ((eq size 2)
@@ -560,15 +554,10 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(logand value ?\xff)))
((eq size 4)
- (if (consp value)
- (list (logand (ash (car value) -8) ?\xff)
- (logand (car value) ?\xff)
- (logand (ash (cdr value) -8) ?\xff)
- (logand (cdr value) ?\xff))
- (list (logand (ash value -24) ?\xff)
- (logand (ash value -16) ?\xff)
- (logand (ash value -8) ?\xff)
- (logand value ?\xff)))))))
+ (list (logand (ash value -24) ?\xff)
+ (logand (ash value -16) ?\xff)
+ (logand (ash value -8) ?\xff)
+ (logand value ?\xff))))))
(if (eq byteorder ?l)
(reverse bytes)
bytes)))
diff --git a/lisp/xdg.el b/lisp/xdg.el
index 0f0df53d27e..0bdfd114c48 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -231,7 +231,7 @@ admin config, and finally system cached associations."
(desktop (getenv "XDG_CURRENT_DESKTOP"))
res)
(when desktop
- (setq desktop (format "%s-mimeapps.list" desktop)))
+ (setq desktop (list (format "%s-mimeapps.list" desktop))))
(dolist (name (cons "mimeapps.list" desktop))
(push (expand-file-name name (xdg-config-home)) res)
(push (expand-file-name (format "applications/%s" name) (xdg-data-home))
@@ -256,8 +256,8 @@ which is expected to be ordered by priority as in
(when (file-readable-p f)
(insert-file-contents-literally f nil nil nil t)
(goto-char (point-min))
- (let (end)
- (while (not (or (eobp) end))
+ (let () ;; end
+ (while (not (or (eobp))) ;; end
(if (= (following-char) ?\[)
(progn (setq sec (char-after (1+ (point))))
(forward-line))
diff --git a/lisp/xml.el b/lisp/xml.el
index b0b117e7b72..4e2dd13ecbd 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -655,7 +655,7 @@ Leave point at the first non-blank character after the tag."
(setq name (xml-maybe-do-ns (match-string-no-properties 1) nil xml-ns))
(goto-char end-pos)
- ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize
+ ;; See also: https://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize
;; Do we have a string between quotes (or double-quotes),
;; or a simple word ?
@@ -1015,7 +1015,10 @@ The first line is indented with the optional INDENT-STRING."
(defalias 'xml-print 'xml-debug-print)
-(defun xml-escape-string (string)
+(defconst xml-invalid-characters-re
+ "[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]")
+
+(defun xml-escape-string (string &optional noerror)
"Convert STRING into a string containing valid XML character data.
Replace occurrences of &<>\\='\" in STRING with their default XML
entity references (e.g., replace each & with &amp;).
@@ -1023,9 +1026,20 @@ entity references (e.g., replace each & with &amp;).
XML character data must not contain & or < characters, nor the >
character under some circumstances. The XML spec does not impose
restriction on \" or \\=', but we just substitute for these too
-\(as is permitted by the spec)."
+\(as is permitted by the spec).
+
+If STRING contains characters that are invalid in XML (as defined
+by https://www.w3.org/TR/xml/#charsets), operate depending on the
+value of NOERROR: if it is non-nil, remove them; else, signal an
+error of type `xml-invalid-character'."
(with-temp-buffer
(insert string)
+ (goto-char (point-min))
+ (while (re-search-forward xml-invalid-characters-re nil t)
+ (if noerror
+ (replace-match "")
+ (signal 'xml-invalid-character
+ (list (char-before) (match-beginning 0)))))
(dolist (substitution '(("&" . "&amp;")
("<" . "&lt;")
(">" . "&gt;")
@@ -1036,6 +1050,9 @@ restriction on \" or \\=', but we just substitute for these too
(replace-match (cdr substitution) t t nil)))
(buffer-string)))
+(define-error 'xml-invalid-character "Invalid XML character"
+ 'wrong-type-argument)
+
(defun xml-debug-print-internal (xml indent-string)
"Outputs the XML tree in the current buffer.
The first line is indented with INDENT-STRING."
diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el
index 1bee03c2681..72faff81015 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -76,7 +76,12 @@ https://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
;; to guard against that.
(copy-sequence event))
vec)
- (is-move vec)
+ (is-move
+ (xterm-mouse--handle-mouse-movement)
+ (if track-mouse vec
+ ;; Mouse movement events are currently supposed to be
+ ;; suppressed. Return no event.
+ []))
(t
(let* ((down (terminal-parameter nil 'xterm-mouse-last-down))
(down-data (nth 1 down))
@@ -102,8 +107,14 @@ https://invisible-island.net/xterm/ctlseqs/ctlseqs.html)."
(if (null track-mouse)
(vector drag)
(push drag unread-command-events)
+ (xterm-mouse--handle-mouse-movement)
(vector (list 'mouse-movement ev-data))))))))))))
+(defun xterm-mouse--handle-mouse-movement ()
+ "Handle mouse motion that was just generated for XTerm mouse."
+ (display--update-for-mouse-movement (terminal-parameter nil 'xterm-mouse-x)
+ (terminal-parameter nil 'xterm-mouse-y)))
+
;; These two variables have been converted to terminal parameters.
;;
;;(defvar xterm-mouse-x 0
@@ -237,7 +248,10 @@ which is the \"1006\" extension implemented in Xterm >= 277."
(xterm-mouse--read-event-sequence extension))
(t
(error "Unsupported XTerm mouse protocol")))))
- (when click
+ (when (and click
+ ;; In very obscure circumstances, the click may become
+ ;; invalid (see bug#17378).
+ (>= (nth 1 click) 0))
(let* ((type (nth 0 click))
(x (nth 1 click))
(y (nth 2 click))
@@ -260,7 +274,7 @@ which is the \"1006\" extension implemented in Xterm >= 277."
(eq y 1)))
'tab-bar
'menu-bar))
- (nthcdr 2 (posn-at-x-y x y)))))
+ (nthcdr 2 (posn-at-x-y x y (selected-frame))))))
(event (list type posn)))
(setcar (nthcdr 3 posn) timestamp)
@@ -318,11 +332,13 @@ down the SHIFT key while pressing the mouse button."
(if xterm-mouse-mode
;; Turn it on
(progn
- (setq mouse-position-function #'xterm-mouse-position-function)
+ (setq mouse-position-function #'xterm-mouse-position-function
+ tty-menu-calls-mouse-position-function t)
(mapc #'turn-on-xterm-mouse-tracking-on-terminal (terminal-list)))
;; Turn it off
(mapc #'turn-off-xterm-mouse-tracking-on-terminal (terminal-list))
- (setq mouse-position-function nil)))
+ (setq mouse-position-function nil
+ tty-menu-calls-mouse-position-function nil)))
(defun xterm-mouse-tracking-enable-sequence ()
"Return a control sequence to enable XTerm mouse tracking.
@@ -336,8 +352,8 @@ modern xterms:
position (<= 223), which can be reported in this
basic mode.
-\"\\e[?1002h\" \"Mouse motion mode\": Enables reports for mouse
- motion events during dragging operations.
+\"\\e[?1003h\" \"Mouse motion mode\": Enables reports for mouse
+ motion events.
\"\\e[?1005h\" \"UTF-8 coordinate extension\": Enables an
extension to the basic mouse mode, which uses UTF-8
@@ -357,7 +373,7 @@ given escape sequence takes precedence over the former."
(apply #'concat (xterm-mouse--tracking-sequence ?h)))
(defconst xterm-mouse-tracking-enable-sequence
- "\e[?1000h\e[?1002h\e[?1005h\e[?1006h"
+ "\e[?1000h\e[?1003h\e[?1005h\e[?1006h"
"Control sequence to enable xterm mouse tracking.
Enables basic mouse tracking, mouse motion events and finally
extended tracking on terminals that support it. The following
@@ -368,8 +384,8 @@ escape sequences are understood by modern xterms:
position (<= 223), which can be reported in this
basic mode.
-\"\\e[?1002h\" \"Mouse motion mode\": Enables reports for mouse
- motion events during dragging operations.
+\"\\e[?1003h\" \"Mouse motion mode\": Enables reports for mouse
+ motion events.
\"\\e[?1005h\" \"UTF-8 coordinate extension\": Enables an extension
to the basic mouse mode, which uses UTF-8
@@ -397,7 +413,7 @@ The control sequence resets the modes set by
(apply #'concat (nreverse (xterm-mouse--tracking-sequence ?l))))
(defconst xterm-mouse-tracking-disable-sequence
- "\e[?1006l\e[?1005l\e[?1002l\e[?1000l"
+ "\e[?1006l\e[?1005l\e[?1003l\e[?1000l"
"Reset the modes set by `xterm-mouse-tracking-enable-sequence'.")
(make-obsolete-variable
@@ -411,7 +427,7 @@ SUFFIX is the last character of each escape sequence (?h to
enable, ?l to disable)."
(mapcar
(lambda (code) (format "\e[?%d%c" code suffix))
- `(1000 1002 ,@(when xterm-mouse-utf-8 '(1005)) 1006)))
+ `(1000 1003 ,@(when xterm-mouse-utf-8 '(1005)) 1006)))
(defun turn-on-xterm-mouse-tracking-on-terminal (&optional terminal)
"Enable xterm mouse tracking on TERMINAL."
diff --git a/lisp/xwidget.el b/lisp/xwidget.el
index dbb36e5c2cb..b8df55090a2 100644
--- a/lisp/xwidget.el
+++ b/lisp/xwidget.el
@@ -41,7 +41,10 @@
(declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height))
(declare-function xwidget-webkit-execute-script "xwidget.c"
(xwidget script &optional callback))
+(declare-function xwidget-webkit-uri "xwidget.c" (xwidget))
+(declare-function xwidget-webkit-title "xwidget.c" (xwidget))
(declare-function xwidget-webkit-goto-uri "xwidget.c" (xwidget uri))
+(declare-function xwidget-webkit-goto-history "xwidget.c" (xwidget rel-pos))
(declare-function xwidget-webkit-zoom "xwidget.c" (xwidget factor))
(declare-function xwidget-plist "xwidget.c" (xwidget))
(declare-function set-xwidget-plist "xwidget.c" (xwidget plist))
@@ -51,6 +54,10 @@
(declare-function get-buffer-xwidgets "xwidget.c" (buffer))
(declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget))
+(defgroup xwidget nil
+ "Displaying native widgets in Emacs buffers."
+ :group 'widgets)
+
(defun xwidget-insert (pos type title width height &optional args)
"Insert an xwidget at position POS.
Supply the xwidget's TYPE, TITLE, WIDTH, and HEIGHT.
@@ -78,6 +85,8 @@ This returns the result of `make-xwidget'."
;;; webkit support
(require 'browse-url)
(require 'image-mode);;for some image-mode alike functionality
+(require 'seq)
+(require 'url-handlers)
;;;###autoload
(defun xwidget-webkit-browse-url (url &optional new-session)
@@ -92,10 +101,31 @@ Interactively, URL defaults to the string looking like a url around point."
(or (featurep 'xwidget-internal)
(user-error "Your Emacs was not compiled with xwidgets support"))
(when (stringp url)
+ ;; If it's a "naked url", just try adding https: to it.
+ (unless (string-match "\\`[A-Za-z]+:" url)
+ (setq url (concat "https://" url)))
(if new-session
(xwidget-webkit-new-session url)
(xwidget-webkit-goto-url url))))
+(defun xwidget-webkit-clone-and-split-below ()
+ "Clone current URL into a new widget place in new window below.
+Get the URL of current session, then browse to the URL
+in `split-window-below' with a new xwidget webkit session."
+ (interactive)
+ (let ((url (xwidget-webkit-current-url)))
+ (with-selected-window (split-window-below)
+ (xwidget-webkit-new-session url))))
+
+(defun xwidget-webkit-clone-and-split-right ()
+ "Clone current URL into a new widget place in new window right.
+Get the URL of current session, then browse to the URL
+in `split-window-right' with a new xwidget webkit session."
+ (interactive)
+ (let ((url (xwidget-webkit-current-url)))
+ (with-selected-window (split-window-right)
+ (xwidget-webkit-new-session url))))
+
;;todo.
;; - check that the webkit support is compiled in
(defvar xwidget-webkit-mode-map
@@ -103,6 +133,7 @@ Interactively, URL defaults to the string looking like a url around point."
(define-key map "g" 'xwidget-webkit-browse-url)
(define-key map "a" 'xwidget-webkit-adjust-size-dispatch)
(define-key map "b" 'xwidget-webkit-back)
+ (define-key map "f" 'xwidget-webkit-forward)
(define-key map "r" 'xwidget-webkit-reload)
(define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!?
(define-key map "\C-m" 'xwidget-webkit-insert-string)
@@ -112,20 +143,21 @@ Interactively, URL defaults to the string looking like a url around point."
;;similar to image mode bindings
(define-key map (kbd "SPC") 'xwidget-webkit-scroll-up)
+ (define-key map (kbd "S-SPC") 'xwidget-webkit-scroll-down)
(define-key map (kbd "DEL") 'xwidget-webkit-scroll-down)
- (define-key map [remap scroll-up] 'xwidget-webkit-scroll-up)
+ (define-key map [remap scroll-up] 'xwidget-webkit-scroll-up-line)
(define-key map [remap scroll-up-command] 'xwidget-webkit-scroll-up)
- (define-key map [remap scroll-down] 'xwidget-webkit-scroll-down)
+ (define-key map [remap scroll-down] 'xwidget-webkit-scroll-down-line)
(define-key map [remap scroll-down-command] 'xwidget-webkit-scroll-down)
(define-key map [remap forward-char] 'xwidget-webkit-scroll-forward)
(define-key map [remap backward-char] 'xwidget-webkit-scroll-backward)
(define-key map [remap right-char] 'xwidget-webkit-scroll-forward)
(define-key map [remap left-char] 'xwidget-webkit-scroll-backward)
- (define-key map [remap previous-line] 'xwidget-webkit-scroll-down)
- (define-key map [remap next-line] 'xwidget-webkit-scroll-up)
+ (define-key map [remap previous-line] 'xwidget-webkit-scroll-down-line)
+ (define-key map [remap next-line] 'xwidget-webkit-scroll-up-line)
;; (define-key map [remap move-beginning-of-line] 'image-bol)
;; (define-key map [remap move-end-of-line] 'image-eol)
@@ -144,33 +176,63 @@ Interactively, URL defaults to the string looking like a url around point."
(interactive)
(xwidget-webkit-zoom (xwidget-webkit-current-session) -0.1))
-(defun xwidget-webkit-scroll-up ()
- "Scroll webkit up."
- (interactive)
+(defun xwidget-webkit-scroll-up (&optional arg)
+ "Scroll webkit up by ARG pixels; or full window height if no ARG.
+Stop if bottom of page is reached.
+Interactively, ARG is the prefix numeric argument.
+Negative ARG scrolls down."
+ (interactive "P")
(xwidget-webkit-execute-script
(xwidget-webkit-current-session)
- "window.scrollBy(0, 50);"))
-
-(defun xwidget-webkit-scroll-down ()
- "Scroll webkit down."
- (interactive)
+ (format "window.scrollBy(0, %d);"
+ (or arg (xwidget-window-inside-pixel-height (selected-window))))))
+
+(defun xwidget-webkit-scroll-down (&optional arg)
+ "Scroll webkit down by ARG pixels; or full window height if no ARG.
+Stop if top of page is reached.
+Interactively, ARG is the prefix numeric argument.
+Negative ARG scrolls up."
+ (interactive "P")
(xwidget-webkit-execute-script
(xwidget-webkit-current-session)
- "window.scrollBy(0, -50);"))
-
-(defun xwidget-webkit-scroll-forward ()
- "Scroll webkit forwards."
- (interactive)
+ (format "window.scrollBy(0, -%d);"
+ (or arg (xwidget-window-inside-pixel-height (selected-window))))))
+
+(defun xwidget-webkit-scroll-up-line (&optional n)
+ "Scroll webkit up by N lines.
+The height of line is calculated with `window-font-height'.
+Stop if the bottom edge of the page is reached.
+If N is omitted or nil, scroll up by one line."
+ (interactive "p")
+ (xwidget-webkit-scroll-up (* n (window-font-height))))
+
+(defun xwidget-webkit-scroll-down-line (&optional n)
+ "Scroll webkit down by N lines.
+The height of line is calculated with `window-font-height'.
+Stop if the top edge of the page is reached.
+If N is omitted or nil, scroll down by one line."
+ (interactive "p")
+ (xwidget-webkit-scroll-down (* n (window-font-height))))
+
+(defun xwidget-webkit-scroll-forward (&optional n)
+ "Scroll webkit horizontally by N chars.
+The width of char is calculated with `window-font-width'.
+If N is omitted or nil, scroll forwards by one char."
+ (interactive "p")
(xwidget-webkit-execute-script
(xwidget-webkit-current-session)
- "window.scrollBy(50, 0);"))
-
-(defun xwidget-webkit-scroll-backward ()
- "Scroll webkit backwards."
- (interactive)
+ (format "window.scrollBy(%d, 0);"
+ (* n (window-font-width)))))
+
+(defun xwidget-webkit-scroll-backward (&optional n)
+ "Scroll webkit back by N chars.
+The width of char is calculated with `window-font-width'.
+If N is omitted or nil, scroll backwards by one char."
+ (interactive "p")
(xwidget-webkit-execute-script
(xwidget-webkit-current-session)
- "window.scrollBy(-50, 0);"))
+ (format "window.scrollBy(-%d, 0);"
+ (* n (window-font-width)))))
(defun xwidget-webkit-scroll-top ()
"Scroll webkit to the very top."
@@ -184,7 +246,7 @@ Interactively, URL defaults to the string looking like a url around point."
(interactive)
(xwidget-webkit-execute-script
(xwidget-webkit-current-session)
- "window.scrollTo(pageXOffset, window.document.body.clientHeight);"))
+ "window.scrollTo(pageXOffset, window.document.body.scrollHeight);"))
;; The xwidget event needs to go into a higher level handler
;; since the xwidget can generate an event even if it's offscreen.
@@ -204,12 +266,8 @@ Interactively, URL defaults to the string looking like a url around point."
(let*
((xwidget-event-type (nth 1 last-input-event))
(xwidget (nth 2 last-input-event))
- ;;(xwidget-callback (xwidget-get xwidget 'callback))
- ;;TODO stopped working for some reason
- )
- ;;(funcall xwidget-callback xwidget xwidget-event-type)
- (message "xw callback %s" xwidget)
- (funcall 'xwidget-webkit-callback xwidget xwidget-event-type)))
+ (xwidget-callback (xwidget-get xwidget 'callback)))
+ (funcall xwidget-callback xwidget xwidget-event-type)))
(defun xwidget-webkit-callback (xwidget xwidget-event-type)
"Callback for xwidgets.
@@ -219,21 +277,23 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget."
"error: callback called for xwidget with dead buffer")
(with-current-buffer (xwidget-buffer xwidget)
(cond ((eq xwidget-event-type 'load-changed)
- (xwidget-webkit-execute-script
- xwidget "document.title"
- (lambda (title)
- (xwidget-log "webkit finished loading: '%s'" title)
- ;;TODO - check the native/internal scroll
- ;;(xwidget-adjust-size-to-content xwidget)
- (xwidget-webkit-adjust-size-to-window xwidget)
- (rename-buffer (format "*xwidget webkit: %s *" title))))
- (pop-to-buffer (current-buffer)))
+ (let ((title (xwidget-webkit-title xwidget)))
+ (xwidget-log "webkit finished loading: %s" title)
+ ;; Do not adjust webkit size to window here, the selected window
+ ;; can be the mini-buffer window unwantedly.
+ (rename-buffer (format "*xwidget webkit: %s *" title) t)))
((eq xwidget-event-type 'decide-policy)
(let ((strarg (nth 3 last-input-event)))
(if (string-match ".*#\\(.*\\)" strarg)
(xwidget-webkit-show-id-or-named-element
xwidget
(match-string 1 strarg)))))
+ ;; TODO: Response handling other than download.
+ ((eq xwidget-event-type 'download-callback)
+ (let ((url (nth 3 last-input-event))
+ (mime-type (nth 4 last-input-event))
+ (file-name (nth 5 last-input-event)))
+ (xwidget-webkit-save-as-file url mime-type file-name)))
((eq xwidget-event-type 'javascript-callback)
(let ((proc (nth 3 last-input-event))
(arg (nth 4 last-input-event)))
@@ -241,21 +301,66 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget."
(t (xwidget-log "unhandled event:%s" xwidget-event-type))))))
(defvar bookmark-make-record-function)
+(when (memq window-system '(mac ns))
+ (defvar xwidget-webkit-enable-plugins nil
+ "Enable plugins for xwidget webkit.
+If non-nil, plugins are enabled. Otherwise, disabled."))
+
(define-derived-mode xwidget-webkit-mode
- special-mode "xwidget-webkit" "Xwidget webkit view mode."
- (setq buffer-read-only t)
- (setq-local bookmark-make-record-function
- #'xwidget-webkit-bookmark-make-record)
- ;; Keep track of [vh]scroll when switching buffers
- (image-mode-setup-winprops))
+ special-mode "xwidget-webkit" "Xwidget webkit view mode."
+ (setq buffer-read-only t)
+ (setq-local bookmark-make-record-function
+ #'xwidget-webkit-bookmark-make-record)
+ ;; Keep track of [vh]scroll when switching buffers
+ (image-mode-setup-winprops))
+
+;;; Download, save as file.
+
+(defcustom xwidget-webkit-download-dir "~/Downloads/"
+ "Directory where download file saved."
+ :version "28.1"
+ :type 'file)
+
+(defun xwidget-webkit-save-as-file (url mime-type file-name)
+ "For XWIDGET webkit, save URL of MIME-TYPE to location specified by user.
+FILE-NAME combined with `xwidget-webkit-download-dir' is the default file name
+of the prompt when reading. When the file name the user specified is a
+directory, URL is saved at the specified directory as FILE-NAME."
+ (let ((save-name (read-file-name
+ (format "Save URL `%s' of type `%s' in file/directory: "
+ url mime-type)
+ xwidget-webkit-download-dir
+ (when file-name
+ (expand-file-name
+ file-name
+ xwidget-webkit-download-dir)))))
+ (if (file-directory-p save-name)
+ (setq save-name
+ (expand-file-name (file-name-nondirectory file-name) save-name)))
+ (setq xwidget-webkit-download-dir (file-name-directory save-name))
+ (url-copy-file url save-name t)))
+
+;;; Bookmarks integration
+
+(defcustom xwidget-webkit-bookmark-jump-new-session nil
+ "Control bookmark jump to use new session or not.
+If non-nil, use a new xwidget webkit session after bookmark jump.
+Otherwise, it will use `xwidget-webkit-last-session'.
+When you set this variable to nil, consider further customization with
+`xwidget-webkit-last-session-buffer'."
+ :version "28.1"
+ :type 'boolean)
(defun xwidget-webkit-bookmark-make-record ()
- "Integrate Emacs bookmarks with the webkit xwidget."
+ "Create bookmark record in webkit xwidget."
(nconc (bookmark-make-record-default t t)
- `((page . ,(xwidget-webkit-current-url))
- (handler . (lambda (bmk) (browse-url
- (bookmark-prop-get bmk 'page)))))))
+ `((page . ,(xwidget-webkit-uri (xwidget-webkit-current-session)))
+ (handler . (lambda (bmk)
+ (xwidget-webkit-browse-url
+ (bookmark-prop-get bmk 'page)
+ xwidget-webkit-bookmark-jump-new-session))))))
+;;; xwidget webkit session
(defvar xwidget-webkit-last-session-buffer nil)
@@ -303,7 +408,7 @@ function findactiveelement(doc){
"
- "javascript that finds the active element."
+ "Javascript that finds the active element."
;; Yes it's ugly, because:
;; - there is apparently no way to find the active frame other than recursion
;; - the js "for each" construct misbehaved on the "frames" collection
@@ -313,19 +418,22 @@ function findactiveelement(doc){
)
(defun xwidget-webkit-insert-string ()
- "Prompt for a string and insert it in the active field in the
-current webkit widget."
+ "Insert string into the active field in the current webkit widget."
;; Read out the string in the field first and provide for edit.
(interactive)
+ ;; As the prompt differs on JavaScript execution results,
+ ;; the function must handle the prompt itself.
(let ((xww (xwidget-webkit-current-session)))
(xwidget-webkit-execute-script
xww
(concat xwidget-webkit-activeelement-js "
(function () {
var res = findactiveelement(document);
- return [res.value, res.type];
+ if (res)
+ return [res.value, res.type];
})();")
(lambda (field)
+ "Prompt a string for the FIELD and insert in the active input."
(let ((str (pcase field
(`[,val "text"]
(read-string "Text: " val))
@@ -343,7 +451,7 @@ current webkit widget."
XW is the xwidget identifier, TEXT is retrieved from the webkit."
(switch-to-buffer
(generate-new-buffer "textarea"))
- (set (make-local-variable 'xwidget-xwbl) xw)
+ (setq-local xwidget-xwbl xw)
(insert text))
(defun xwidget-webkit-end-edit-textarea ()
@@ -444,11 +552,23 @@ For example, use this to display an anchor."
(ignore-errors
(recenter-top-bottom)))
+;; Utility functions
+
+(defun xwidget-window-inside-pixel-width (window)
+ "Return Emacs WINDOW body width in pixel."
+ (let ((edges (window-inside-pixel-edges window)))
+ (- (nth 2 edges) (nth 0 edges))))
+
+(defun xwidget-window-inside-pixel-height (window)
+ "Return Emacs WINDOW body height in pixel."
+ (let ((edges (window-inside-pixel-edges window)))
+ (- (nth 3 edges) (nth 1 edges))))
+
(defun xwidget-webkit-adjust-size-to-window (xwidget &optional window)
"Adjust the size of the webkit XWIDGET to fit the WINDOW."
(xwidget-resize xwidget
- (window-pixel-width window)
- (window-pixel-height window)))
+ (xwidget-window-inside-pixel-width window)
+ (xwidget-window-inside-pixel-height window)))
(defun xwidget-webkit-adjust-size (w h)
"Manually set webkit size to width W, height H."
@@ -478,51 +598,56 @@ For example, use this to display an anchor."
(add-to-list 'window-size-change-functions
'xwidget-webkit-adjust-size-in-frame))
-(defun xwidget-webkit-new-session (url)
+(defun xwidget-webkit-new-session (url &optional callback)
"Create a new webkit session buffer with URL."
(let*
((bufname (generate-new-buffer-name "*xwidget-webkit*"))
+ (callback (or callback #'xwidget-webkit-callback))
xw)
(setq xwidget-webkit-last-session-buffer (switch-to-buffer
(get-buffer-create bufname)))
;; The xwidget id is stored in a text property, so we need to have
;; at least character in this buffer.
- (insert " ")
- (setq xw (xwidget-insert 1 'webkit bufname
- (window-pixel-width)
- (window-pixel-height)))
- (xwidget-put xw 'callback 'xwidget-webkit-callback)
+ ;; Insert invisible url, good default for next `g' to browse url.
+ (let ((start (point)))
+ (insert url)
+ (put-text-property start (+ start (length url)) 'invisible t)
+ (setq xw (xwidget-insert
+ start 'webkit bufname
+ (xwidget-window-inside-pixel-width (selected-window))
+ (xwidget-window-inside-pixel-height (selected-window)))))
+ (xwidget-put xw 'callback callback)
(xwidget-webkit-mode)
(xwidget-webkit-goto-uri (xwidget-webkit-last-session) url)))
(defun xwidget-webkit-goto-url (url)
- "Goto URL."
+ "Goto URL with xwidget webkit."
(if (xwidget-webkit-current-session)
(progn
(xwidget-webkit-goto-uri (xwidget-webkit-current-session) url))
(xwidget-webkit-new-session url)))
(defun xwidget-webkit-back ()
- "Go back in history."
+ "Go back to previous URL in xwidget webkit buffer."
(interactive)
- (xwidget-webkit-execute-script (xwidget-webkit-current-session)
- "history.go(-1);"))
+ (xwidget-webkit-goto-history (xwidget-webkit-current-session) -1))
+
+(defun xwidget-webkit-forward ()
+ "Go forward in history."
+ (interactive)
+ (xwidget-webkit-goto-history (xwidget-webkit-current-session) 1))
(defun xwidget-webkit-reload ()
- "Reload current url."
+ "Reload current URL."
(interactive)
- (xwidget-webkit-execute-script (xwidget-webkit-current-session)
- "history.go(0);"))
+ (xwidget-webkit-goto-history (xwidget-webkit-current-session) 0))
(defun xwidget-webkit-current-url ()
- "Get the webkit url and place it on the kill-ring."
+ "Display the current xwidget webkit URL and place it on the `kill-ring'."
(interactive)
- (xwidget-webkit-execute-script
- (xwidget-webkit-current-session)
- "document.URL" (lambda (rv)
- (let ((url (kill-new (or rv ""))))
- (message "url: %s" url)))))
+ (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session))))
+ (message "URL: %s" (kill-new (or url "")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xwidget-webkit-get-selection (proc)
@@ -533,10 +658,9 @@ For example, use this to display an anchor."
proc))
(defun xwidget-webkit-copy-selection-as-kill ()
- "Get the webkit selection and put it on the kill-ring."
+ "Get the webkit selection and put it on the `kill-ring'."
(interactive)
- (xwidget-webkit-get-selection (lambda (selection) (kill-new selection))))
-
+ (xwidget-webkit-get-selection #'kill-new))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Xwidget plist management (similar to the process plist functions)